Released DG*5.3*775 SEQ #684 Extracted from mail message **KIDS**:DG*5.3*775^ **INSTALL NAME** DG*5.3*775 "BLD",7402,0) DG*5.3*775^REGISTRATION^0^3071219^y "BLD",7402,4,0) ^9.64PA^^ "BLD",7402,6.3) 3 "BLD",7402,"ABPKG") n "BLD",7402,"KRN",0) ^9.67PA^8989.52^19 "BLD",7402,"KRN",.4,0) .4 "BLD",7402,"KRN",.401,0) .401 "BLD",7402,"KRN",.402,0) .402 "BLD",7402,"KRN",.403,0) .403 "BLD",7402,"KRN",.5,0) .5 "BLD",7402,"KRN",.84,0) .84 "BLD",7402,"KRN",3.6,0) 3.6 "BLD",7402,"KRN",3.8,0) 3.8 "BLD",7402,"KRN",9.2,0) 9.2 "BLD",7402,"KRN",9.8,0) 9.8 "BLD",7402,"KRN",9.8,"NM",0) ^9.68A^3^3 "BLD",7402,"KRN",9.8,"NM",1,0) DGPTICD^^0^B8640114 "BLD",7402,"KRN",9.8,"NM",2,0) DGPTF4^^0^B24206467 "BLD",7402,"KRN",9.8,"NM",3,0) DGPTFM4^^0^B27400766 "BLD",7402,"KRN",9.8,"NM","B","DGPTF4",2) "BLD",7402,"KRN",9.8,"NM","B","DGPTFM4",3) "BLD",7402,"KRN",9.8,"NM","B","DGPTICD",1) "BLD",7402,"KRN",19,0) 19 "BLD",7402,"KRN",19.1,0) 19.1 "BLD",7402,"KRN",101,0) 101 "BLD",7402,"KRN",409.61,0) 409.61 "BLD",7402,"KRN",771,0) 771 "BLD",7402,"KRN",870,0) 870 "BLD",7402,"KRN",8989.51,0) 8989.51 "BLD",7402,"KRN",8989.52,0) 8989.52 "BLD",7402,"KRN",8994,0) 8994 "BLD",7402,"KRN","B",.4,.4) "BLD",7402,"KRN","B",.401,.401) "BLD",7402,"KRN","B",.402,.402) "BLD",7402,"KRN","B",.403,.403) "BLD",7402,"KRN","B",.5,.5) "BLD",7402,"KRN","B",.84,.84) "BLD",7402,"KRN","B",3.6,3.6) "BLD",7402,"KRN","B",3.8,3.8) "BLD",7402,"KRN","B",9.2,9.2) "BLD",7402,"KRN","B",9.8,9.8) "BLD",7402,"KRN","B",19,19) "BLD",7402,"KRN","B",19.1,19.1) "BLD",7402,"KRN","B",101,101) "BLD",7402,"KRN","B",409.61,409.61) "BLD",7402,"KRN","B",771,771) "BLD",7402,"KRN","B",870,870) "BLD",7402,"KRN","B",8989.51,8989.51) "BLD",7402,"KRN","B",8989.52,8989.52) "BLD",7402,"KRN","B",8994,8994) "BLD",7402,"QUES",0) ^9.62^^ "BLD",7402,"REQB",0) ^9.611^3^3 "BLD",7402,"REQB",1,0) DG*5.3*683^2 "BLD",7402,"REQB",2,0) DG*5.3*565^2 "BLD",7402,"REQB",3,0) DG*5.3*606^2 "BLD",7402,"REQB","B","DG*5.3*565",2) "BLD",7402,"REQB","B","DG*5.3*606",3) "BLD",7402,"REQB","B","DG*5.3*683",1) "MBREQ") 0 "PKG",114,-1) 1^1 "PKG",114,0) REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER "PKG",114,20,0) ^9.402P^^ "PKG",114,22,0) ^9.49I^1^1 "PKG",114,22,1,0) 5.3^2930813^2930821 "PKG",114,22,1,"PAH",1,0) 775^3071219 "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") NO "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 3 "RTN","DGPTF4") 0^2^B24206467^B22914415 "RTN","DGPTF4",1,0) DGPTF4 ;ALB/JDS - PTF ENTRY/EDIT-4 ; 2/19/04 9:33am "RTN","DGPTF4",2,0) ;;5.3;Registration;**114,115,397,510,517,478,683,775**;Aug 13, 1993;Build 3 "RTN","DGPTF4",3,0) ; "RTN","DGPTF4",4,0) WR ; "RTN","DGPTF4",5,0) W @IOF,HEAD,?72 S Z="<701>" D Z^DGPTFM K X S $P(X,"-",81)="" W !,X "RTN","DGPTF4",6,0) Q "RTN","DGPTF4",7,0) EN S Y=+B(70) D D^DGPTUTL W ! S Z=5 D Z W $S($P(B(0),U,11)=1:"Date of Disch: ",1:"Census Date : ") S Z=Y,Z1=20 D Z1 W "Disch Specialty: ",$S($D(^DIC(42.4,+$P(B(70),U,2),0)):$E($P(^(0),U,1),1,25),1:"") "RTN","DGPTF4",8,0) W !," Type of Disch: " S L=";"_$P(^DD(45,72,0),U,3),L1=";"_$P(B(70),U,3)_":" W $P($P(L,L1,2),";",1),?41 S L=";"_$P(^DD(45,72.1,0),U,3),L1=";"_$P(B(70),U,14)_":" W "Disch Status: ",$P($P(L,L1,2),";",1) "RTN","DGPTF4",9,0) W !," Place of Disp: ",$S($D(^DIC(45.6,+$P(B(70),U,6),0)):$E($P(^(0),U,1),1,21),1:"") "RTN","DGPTF4",10,0) W ?40 S Z=6 D Z W " Out Treat: ",$P("YES^^NO",U,+$P(B(70),U,4)) "RTN","DGPTF4",11,0) W !?6,"Means Test: " S L=";"_$P(^DD(45,10,0),U,3),L1=";"_$P(B(0),U,10)_":" W $P($P(L,L1,2),";",1) "RTN","DGPTF4",12,0) W ?42,"VA Auspices: ",$S($P(B(70),U,5)=1:"YES",$P(B(70),U,5)=2:"NO",1:"") "RTN","DGPTF4",13,0) W ! S Z=7 D Z W " Receiv facil: " S Z=$P(B(70),U,12)_$P(B(70),U,13),Z1=18 D Z1 W ?38 S Z="Other Fields" D Z "RTN","DGPTF4",14,0) S DGINC=$P(B(101),U,7) "RTN","DGPTF4",15,0) I DGINC>1000 S DGINC=$E(DGINC,1,$L(DGINC)-3)_","_$E(DGINC,$L(DGINC)-2,$L(DGINC)) "RTN","DGPTF4",16,0) W !," C&P Status: " S L=";"_$P(^DD(45,78,0),U,3),L1=";"_$P(B(70),U,9)_":" W $E($P($P(L,L1,2),";",1),1,24),?47,"Income: $",DGINC "RTN","DGPTF4",17,0) K DGINC "RTN","DGPTF4",18,0) AS ; "RTN","DGPTF4",19,0) N DGRSC "RTN","DGPTF4",20,0) S DGRSC=$S($P(A(.3),U)="Y":$$RTEN^DGPTR4($P(A(.3),U,2)),1:"") "RTN","DGPTF4",21,0) W !," ASIH Days: ",$P(B(70),U,8) "RTN","DGPTF4",22,0) W ?40,"SC Percentage: ",$S($P(A(.3),U)="Y":$P(A(.3),U,2)_"%",1:"") "RTN","DGPTF4",23,0) I DGRSC]"",DGRSC'=$P(A(.3),U,2) W ?60,"Transmitted: ["_DGRSC_"%]" "RTN","DGPTF4",24,0) ;W !,?39,"Period Of Serv: ",$S($D(^DIC(21,$S('$D(^DGPM(+$O(^DGPM("APTF",PTF,0)),"ODS")):+$P(A(.32),U,3),+^("ODS"):+$O(^DIC(21,"D",6,0)),1:+$P(A(.32),U,3)),0)):$E($P(^(0),U),1,26),1:""),! "RTN","DGPTF4",25,0) W !,?39,"Period Of Serv: " "RTN","DGPTF4",26,0) W $S($D(^DIC(21,$S('$D(^DGPM(+$O(^DGPM("APTF",PTF,0)),"ODS")):+$$CKPOS^DGPTUTL($P(B(101),U,8),+$P(A(.32),U,3)),+^("ODS"):+$O(^DIC(21,"D",6,0)),1:$$CKPOS^DGPTUTL($P(B(101),U,8),+$P(A(.32),U,3))),0)):$E($P(^(0),U),1,26),1:""),! "RTN","DGPTF4",27,0) Q "RTN","DGPTF4",28,0) ; "RTN","DGPTF4",29,0) EN1 ;LOAD AND DISPLAY DIAGNOSES FOR PTF 701 SCREEN "RTN","DGPTF4",30,0) K DRG S B(70)=$S($D(^DGPT(PTF,70)):^(70),1:""),B(71)=$S($D(^DGPT(PTF,71)):^(71),1:"") D WR "RTN","DGPTF4",31,0) S DGPTDAT=$$GETDATE^ICDGTDRG(PTF) ;Get correct effective date "RTN","DGPTF4",32,0) S DGPTTMP=$$ICDDX^ICDCODE(+$P(B(70),U,10),DGPTDAT) "RTN","DGPTF4",33,0) W ! S Z=1 D Z W " Principal Diagnosis: ",$S(DGPTTMP&$P(DGPTTMP,U,10):$P(DGPTTMP,U,4)_"("_$P(DGPTTMP,U,2)_")",1:"") "RTN","DGPTF4",34,0) S DGPTTMP=$$ICDDX^ICDCODE(+$P(B(70),U,11),DGPTDAT) "RTN","DGPTF4",35,0) W:$P(B(70),U,11)&('$P(B(70),U,10)) !," Principal Diag: ",$S(DGPTTMP&$P(DGPTTMP,U,10):$P(DGPTTMP,U,4)_" ("_$P(DGPTTMP,U,2)_")",1:"") "RTN","DGPTF4",36,0) S K=B(70) F I=16:1:24 D DSP "RTN","DGPTF4",37,0) S K=B(71) F I=1:1:4 D DSP "RTN","DGPTF4",38,0) S DGPTF=PTF D:'DGST CHK701^DGPTSCAN,UP701^DGPTSPQ "RTN","DGPTF4",39,0) ; display contents of 300th node "RTN","DGPTF4",40,0) S DG300=$S($D(^DGPT(PTF,300)):^(300),1:"") D:DG300]"" PRN2^DGPTFM8 K DG300 "RTN","DGPTF4",41,0) EN2 K DRG "RTN","DGPTF4",42,0) I $D(^DGPT(PTF,0)),$P(^(0),U,11)=1 D "RTN","DGPTF4",43,0) .S DA=DFN "RTN","DGPTF4",44,0) .D EN1^DGPTFD "RTN","DGPTF4",45,0) .I $D(DRG),$D(^DGP(45.84,PTF,0)),$P(^(0),U,6)'=DRG D "RTN","DGPTF4",46,0) ..N DGFDA,DGMSG "RTN","DGPTF4",47,0) ..S DGFDA(45.84,PTF_",",6)=DRG "RTN","DGPTF4",48,0) ..D FILE^DIE("","DGFDA","DGMSG") "RTN","DGPTF4",49,0) JUMP K AGE,B,CC,DA,DAM,DOB,DXLS,EXP,I,L1,L2,SEX,DRGCAL,S,DIC,DR,DIE "RTN","DGPTF4",50,0) Q:DGPR "RTN","DGPTF4",51,0) ;F I=$Y:1:18 W ! "RTN","DGPTF4",52,0) K X S $P(X,"-",81)="" W X "RTN","DGPTF4",53,0) ; "RTN","DGPTF4",54,0) G O:DGST&(('$D(DRG))!('DGDD)!('$D(^DGP(45.84,PTF)))) "RTN","DGPTF4",55,0) X G ACT^DGPTF41 "RTN","DGPTF4",56,0) CLS G NOT:('$D(DRG))!('DGDD)!('DGFC) "RTN","DGPTF4",57,0) ;I DRG=470!(DRG=469) W !!,*7,"Unable to release DRG ",DRG,". Please verify data entered.",*7 D HANG^DGPTUTL G EN1 "RTN","DGPTF4",58,0) ; "RTN","DGPTF4",59,0) ;change made to allow release of 470, before grouper released to vamc's "RTN","DGPTF4",60,0) ; patch 115 "RTN","DGPTF4",61,0) ;DGDAT = effective date of DRG used in DGPTICD (468=CMS-DRG,998=MS-DRG) "RTN","DGPTF4",62,0) I DRG=469,(+$G(DGDAT)<3071001) W !!,*7,"Unable to release DRG ",DRG,". Please verify data entered.",*7 D HANG^DGPTUTL G EN1 "RTN","DGPTF4",63,0) I DRG=998 W !!,*7,"Unable to release DRG ",DRG,". Please verify data entered.",*7 D HANG^DGPTUTL G EN1 "RTN","DGPTF4",64,0) I $D(DGCST),'DGCST D CEN G EN1:'DGCST "RTN","DGPTF4",65,0) I '$P(^DGPT(PTF,0),"^",4) W !,"Updating TRANSFER DRGs..." S DGADM=$P(^DGPT(PTF,0),U,2) D SUDO1^DGPTSUDO "RTN","DGPTF4",66,0) I DGDD>(DT+1) W !,"Cannot close with Discharge date in future." D HANG^DGPTUTL G EN1 "RTN","DGPTF4",67,0) I $D(^DGM("PT",DFN)) F I=0:0 S I=$O(^DGM("PT",DFN,I)) Q:'I I '$D(^DGM(I,0)) K ^DGM(I),^DGM("PT",DFN,I) "RTN","DGPTF4",68,0) I $D(^DGM("PT",DFN)) W !!,"Not all messages have been cleared up for this patient--cannot close.",*7,*7 S DGPTF=DFN,X="??" K DGALL D HELP^DGPTMSGD K DGPTF G EN1:'$D(DGALL) K DGALL "RTN","DGPTF4",69,0) G CLS^DGPTF2 "RTN","DGPTF4",70,0) ; "RTN","DGPTF4",71,0) O I '$D(^DGP(45.84,PTF,0)) S DR="6///0",DIE="^DGPT(",DA=PTF,(DGST,DGN)=0 D ^DIE W !," NOT CLOSED " D HANG^DGPTUTL G EN1 "RTN","DGPTF4",72,0) S (DGST,DGN)=0 "RTN","DGPTF4",73,0) S DGPTIFN=PTF,DGRTY=1 D OPEN^DGPTFDEL S DGST=0 "RTN","DGPTF4",74,0) K DGPTIFN,DGRTY G EN1 "RTN","DGPTF4",75,0) ; "RTN","DGPTF4",76,0) Q G Q^DGPTF "RTN","DGPTF4",77,0) ; "RTN","DGPTF4",78,0) NOT I 'DGFC S DR="3//^S X=$P($$SITE^VASITE,U,2);5",DIE="^DGPT(",DA=PTF D ^DIE S DGFC=$P(^DGPT(PTF,0),U,3) I DGFC G EN1 "RTN","DGPTF4",79,0) W !!,"Unable to close without a ",$S('$D(DRG):"DRG being calculated.",'DGDD:" discharge date.",1:" facility specified"),!!,*7,*7 H 4 G EN1 "RTN","DGPTF4",80,0) Q "RTN","DGPTF4",81,0) ; "RTN","DGPTF4",82,0) Z D Z^DGPTF5 Q "RTN","DGPTF4",83,0) Z1 D Z1^DGPTF5 Q "RTN","DGPTF4",84,0) CEN D CEN^DGPTF5 Q "RTN","DGPTF4",85,0) DSP S J=$$ICDDX^ICDCODE(+$P(K,U,I),DGPTDAT) I J&$P(J,U,10) D "RTN","DGPTF4",86,0) .I I#2 W ?40,$P(J,U,4)_"("_$P(J,U,2)_")" Q "RTN","DGPTF4",87,0) .W !,$P(J,U,4)_"("_$P(J,U,2)_")" "RTN","DGPTF4",88,0) Q "RTN","DGPTFM4") 0^3^B27400766^B26889694 "RTN","DGPTFM4",1,0) DGPTFM4 ;ALB/MTC/ADL - PTF ENTRY/EDIT-2 ; 12/18/07 11:37am "RTN","DGPTFM4",2,0) ;;5.3;Registration;**114,195,397,510,565,775**;Aug 13, 1993;Build 3 "RTN","DGPTFM4",3,0) ;;ADL;Update for CSV Project;;Mar 26, 2003 "RTN","DGPTFM4",4,0) ; "RTN","DGPTFM4",5,0) S DGZM0=DGZM0+1 "RTN","DGPTFM4",6,0) EN N M3 D MOB:'$D(M) S M(DGZM0)=$S($D(M(DGZM0)):M(DGZM0),1:"") G NEXM:M(DGZM0)="" S (M3,M(DGZM0),M1)=$S($D(^DGPT(PTF,"M",+M(DGZM0),0)):^DGPT(PTF,"M",+M(DGZM0),0),1:"") "RTN","DGPTFM4",7,0) I $D(^DGPT(PTF,"M",+M(DGZM0),"P")) S $P(M(DGZM0),U,20)=^("P"),$P(M1,U,20)=^("P") "RTN","DGPTFM4",8,0) WR S DG300=$S($D(^DGPT(PTF,"M",+M(DGZM0),300)):^(300),1:"") "RTN","DGPTFM4",9,0) W @IOF,HEAD,?70 S Z="<501-"_DGZM0_">" D Z^DGPTFM I +M(DGZM0)=1 W !,?62,"Discharge Movement" "RTN","DGPTFM4",10,0) M S L=+$P(M1,U,10),Y=L D D^DGPTUTL W !! S Z=1 D Z W "Date of Move: " S Z=Y,Z1=20 D Z1 W "Losing Specialty: ",$E($S($D(^DIC(42.4,+$P(M1,U,2),0)):$P(^(0),U,1),1:""),1,25) "RTN","DGPTFM4",11,0) W !," Leave days: ",$P(M1,U,3),?44,"Pass days: ",$P(M1,U,4) "RTN","DGPTFM4",12,0) W !,"Treated for SC Condition: ",$S($P(M3,U,18)=1:"Yes",1:"No") "RTN","DGPTFM4",13,0) N NL S NL=0 "RTN","DGPTFM4",14,0) I $P(M3,U,31)'="" W @($S(NL#2:"!",1:"?37")),"Potentially Related to Combat: ",$S($P(M3,U,31)="Y":"Yes",1:"No") S NL=NL+1 "RTN","DGPTFM4",15,0) I $P(M3,U,26)'="" W @($S(NL#2:"!",1:"?37")),"Treated for AO Condition: ",$S($P(M3,U,26)="Y":"Yes",1:"No") S NL=NL+1 "RTN","DGPTFM4",16,0) I $P(M3,U,27)'="" W @($S(NL#2:"!",1:"?37")),"Treated for IR Condition: ",$S($P(M3,U,27)="Y":"Yes",1:"No") S NL=NL+1 "RTN","DGPTFM4",17,0) I $P(M3,U,28)'="" W @($S(NL#2:"!",1:"?37")),"Treated for EC Condition: ",$S($P(M3,U,28)="Y":"Yes",1:"No") S NL=NL+1 "RTN","DGPTFM4",18,0) ; added 6/17/98 for MST enhancement "RTN","DGPTFM4",19,0) I $P(M3,U,29)'="" W @($S(NL#2:"!",1:"?37")),"Treated for MST Condition: ",$S($P(M3,U,29)="Y":"Yes",1:"No") S NL=NL+1 "RTN","DGPTFM4",20,0) K DGNTARR "RTN","DGPTFM4",21,0) S DGNTARR=$$GETCUR^DGNTAPI(DFN,"DGNTARR") "RTN","DGPTFM4",22,0) I $P(M3,U,30)="",(",3,4,5,"[(","_$P($G(DGNTARR("STAT")),U)_",")) S $P(M3,U,30)="N" "RTN","DGPTFM4",23,0) I $P(M3,U,30)'="" W @($S(NL#2:"!",1:"?37")),"Treated for HEAD/NECK CA Condition: ",$S($P(M3,U,30)="Y":"Yes",1:"No") "RTN","DGPTFM4",24,0) K NL "RTN","DGPTFM4",25,0) W !! S Z=2 D Z W " DX: " F I=1:1:11 S L=$P(M1,U,I+4) I L'=""&(I'=6) S DGPTTMP=$$ICDDX^ICDCODE(+L,$$GETDATE^ICDGTDRG(PTF)) D "RTN","DGPTFM4",26,0) . W $S(+DGPTTMP>0&($P(DGPTTMP,U,10)):$P(DGPTTMP,U,4)_" ("_$P(DGPTTMP,U,2)_")",1:"**********-"_L),!?17 "RTN","DGPTFM4",27,0) D PRN2^DGPTFM8:DG300]"" "RTN","DGPTFM4",28,0) I $P(M1,U,20) S DRG=$P(M1,U,20) W:DRG=998!(DRG=999)!((DRG=468!(DRG=469)!(DRG=470))&(+$P($G(M1),U,10)<3071001)) *7 W !!?14,"TRANSFER DRG: ",DRG D "RTN","DGPTFM4",29,0) . N DXD,DGDX "RTN","DGPTFM4",30,0) . S DXD=$$DRGD^ICDGTDRG(DRG,"DGDX",,$P(M1,U,10)),DGDS=0 "RTN","DGPTFM4",31,0) . F S DGDS=$O(DGDX(DGDS)) Q:'+DGDS Q:DGDX(DGDS)=" " W !,DGDX(DGDS) "RTN","DGPTFM4",32,0) JUMP K DG300 F I=$Y:1:21 W ! "RTN","DGPTFM4",33,0) X S DGNUM=$S($D(M(DGZM0+1)):501_"-"_(DGZM0+1),1:"MAS") G 501^DGPTFJC:DGST "RTN","DGPTFM4",34,0) W "Enter to continue, 1-2 to edit,",!,"'M' ",$S(DGPTFE:" to add a patient movement",1:"to edit Treat. Specialty"),", '^N' for screen N, or '^' to abort:<",DGNUM,">// " R X:DTIME "RTN","DGPTFM4",35,0) K DGNUM G Q:X="^",NEXM:X="",^DGPTFJ:X?1"^".E,M^DGPTFM1:X="M"!(X="m") "RTN","DGPTFM4",36,0) X1 I X[1!(X[2) S DR="[DG501"_$E("F",DGPTFE) X:(+M(DGZM0)=1) "S J=^DGPT(PTF,""M"",1,0) F I=11:1:15 I $P(J,U,I) S DR=DR_1" S DR=DR_"]",DGJUMP=X,DIE="^DGPT(",(DA,DGPTF)=PTF,DGMOV=+M(DGZM0) D ^DIE K M,DR,DIE D CHK501^DGPTSCAN K DGPTF,DGMOV "RTN","DGPTFM4",37,0) ; Determine if NTR HISTORY (#28.11) filer is called if question for "RTN","DGPTFM4",38,0) ; 'Treated for Head/Neck CA Condition:' is answered YES. "RTN","DGPTFM4",39,0) ; Only a NTR screening status of 3=PENDING DIAGNOSIS gets Filed. "RTN","DGPTFM4",40,0) I $P($G(M3),U,30)="Y",$P($G(DGNTARR("STAT")),U)=3 D "RTN","DGPTFM4",41,0) .S DGNTARR=$$FILEHNC^DGNTAPI1(DFN) "RTN","DGPTFM4",42,0) K DGNTARR "RTN","DGPTFM4",43,0) ;- update MT indicator after edit movement "RTN","DGPTFM4",44,0) N DGPMCA,DGPMAN D PM^DGPTUTL "RTN","DGPTFM4",45,0) I '$G(DGADM) S DGADM=+^DGPT(PTF,0) "RTN","DGPTFM4",46,0) D MT^DGPTUTL "RTN","DGPTFM4",47,0) G EN "RTN","DGPTFM4",48,0) PR W !,"Enter '^' to stop the display and edit of data",!,"'^N' to jump to screen #N (appears in upper right of screen ''",!," to continue on to the next screen or 1-2 to edit:" "RTN","DGPTFM4",49,0) W !?10,"1-",$S(DGPTFE:"Date of movement, Losing Specialty, ",1:""),"Leave and Pass days",!?10,"2-ICD DIAGNOSIS CODES" "RTN","DGPTFM4",50,0) W !,"You may also enter 1-2",! "RTN","DGPTFM4",51,0) R !!,"Enter : ",X:DTIME G WR "RTN","DGPTFM4",52,0) Q "RTN","DGPTFM4",53,0) NEXM S DGZM0=DGZM0+1 G ^DGPTFM:'$D(M(DGZM0)),EN "RTN","DGPTFM4",54,0) ADD S DGZM0=$S($D(DGZM0):DGZM0+1,1:0) S L=$S($D(^DGPT(PTF,"M",0)):^(0),1:"^45.02DA^^"),L1=$P(L,U,3) F I=1:1 Q:'$D(^DGPT(PTF,"M",L1+I)) "RTN","DGPTFM4",55,0) S DA(1)=PTF,DIC="^DGPT("_DA(1)_",""M"",",X=L1+I,DIC(0)="LMZQE" D ^DIC K DIC,DIE G ^DGPTFM:Y'>0 "RTN","DGPTFM4",56,0) S M(DGZM0)=L1+I S X="1-2" G X1 "RTN","DGPTFM4",57,0) Q "RTN","DGPTFM4",58,0) MOB S I=0 K M,M1,M2 S M2=0 F I1=1:1 S I=$O(^DGPT(PTF,"M",I)) Q:'I S M(I1)=^(I,0) "RTN","DGPTFM4",59,0) S PM=I1-1 D ORDER^DGPTF Q "RTN","DGPTFM4",60,0) Q G Q^DGPTF "RTN","DGPTFM4",61,0) Z I 'DGN S Z=$S(IOST="C-QUME"&($L(DGVI)'=2):Z,1:"["_Z_"]") W @DGVI,Z,@DGVO "RTN","DGPTFM4",62,0) E W " " "RTN","DGPTFM4",63,0) Q "RTN","DGPTFM4",64,0) Z1 F I=1:1:(Z1-$L(Z)) S Z=Z_" " "RTN","DGPTFM4",65,0) W Z "RTN","DGPTFM4",66,0) Q "RTN","DGPTFM4",67,0) R ;DELETE PROCEDURE RECORD "RTN","DGPTFM4",68,0) I '$D(^DGPT(PTF,"P")) G NOPROC "RTN","DGPTFM4",69,0) I $O(^DGPT(PTF,"P",0))']"" G NOPROC "RTN","DGPTFM4",70,0) S DGPNUM="" F DGPROC=0:0 S DGPROC=$O(P(DGPROC)) Q:'DGPROC S:$D(P(DGPROC,1)) DGPNUM=DGPNUM_","_DGPROC "RTN","DGPTFM4",71,0) S DGPNUM=DGPNUM_"," "RTN","DGPTFM4",72,0) ASKPRO W !!,"Delete procedure record <",$P(DGPNUM,",",2,99),"> : " R DGPROC:DTIME I DGPROC[U!(DGPROC="") K DGPNUM,DGPROC G ^DGPTFM "RTN","DGPTFM4",73,0) I DGPNUM'[(","_DGPROC_",") W !!,"Enter the record # to delete from the PTF file <",$P(DGPNUM,",",2,99),">",! G ASKPRO "RTN","DGPTFM4",74,0) K DA N DGJ "RTN","DGPTFM4",75,0) F DGJ=1:1 S DA=+$P(DGPROC,",",DGJ) Q:'DA S DA=$S($D(P(DA,1)):+P(DA,1),1:0) I DA S DA(1)=PTF,DIK="^DGPT("_PTF_",""P""," D ^DIK K DA W " ",$P(DGPROC,",",DGJ),"-DELETED***" H:'$P(DGPROC,",",DGJ+1) 2 "RTN","DGPTFM4",76,0) K DIK,DA,DGPROC,DGPNUM G ^DGPTFM "RTN","DGPTFM4",77,0) NOPROC W !!,*7,"No procedures to delete",! H 3 G ^DGPTFM "RTN","DGPTICD") 0^1^B8640114^B8396264 "RTN","DGPTICD",1,0) DGPTICD ;ALB/MTC - PTF DRG Grouper Utility ; 2/19/02 3:08pm "RTN","DGPTICD",2,0) ;;5.3;Registration;**375,441,510,559,599,606,775**;Aug 13, 1993;Build 3 "RTN","DGPTICD",3,0) ;variables to pass in: "RTN","DGPTICD",4,0) ; DGDX <- format: DX CODE1^DX CODE2^DX CODE3^... (REQUIRED) "RTN","DGPTICD",5,0) ; DGSURG <- format: SURGERY CODE1^SURGERY CODE2^SURGERY CODE3^... (OPTIONAL) "RTN","DGPTICD",6,0) ; DGPROC <- format: PROCEDURE CODE1^PROCEDURE CODE2^PROCEDURE CODE3^... (OPTIONAL) "RTN","DGPTICD",7,0) ; DGTRS <- 1 if patient transferred to acute care facility (REQUIRED) "RTN","DGPTICD",8,0) ; DGEXP <- 1 if patient died during this episode (REQUIRED) "RTN","DGPTICD",9,0) ; DGDMS <- 1 if patient was discharged with an Irregular discharge (discharged against medical advice) (REQUIRED) "RTN","DGPTICD",10,0) ; AGE,SEX (REQUIRED) "RTN","DGPTICD",11,0) ;values of variables listed above are left unchanged by this routine "RTN","DGPTICD",12,0) ;variable passed back: DRG(0) <- zero node of DRG in DRG file "RTN","DGPTICD",13,0) ; : DRG <- IFN of DRG in DRG file "RTN","DGPTICD",14,0) ; DGDAT <- Effective date to be used in calculating DRG "RTN","DGPTICD",15,0) ; "RTN","DGPTICD",16,0) ;-- check for required variables "RTN","DGPTICD",17,0) Q:'$D(DGDX)!'$D(DGTRS)!'$D(DGEXP)!'$D(DGDMS) "RTN","DGPTICD",18,0) N DGI "RTN","DGPTICD",19,0) ;-- build ICDDX array "RTN","DGPTICD",20,0) K ICDDX "RTN","DGPTICD",21,0) S DGI=0 F S DGI=DGI+1 Q:$P(DGDX,U,DGI)="" D "RTN","DGPTICD",22,0) . S DGPTTMP=$$ICDDX^ICDCODE(+$P(DGDX,U,DGI),+$G(DGDAT)) "RTN","DGPTICD",23,0) . I +DGPTTMP>0,($P(DGPTTMP,U,10)) S ICDDX(DGI)=$P(DGDX,U,DGI) "RTN","DGPTICD",24,0) G Q:'$D(ICDDX) "RTN","DGPTICD",25,0) ; "RTN","DGPTICD",26,0) ;-- build ICDPRC array "RTN","DGPTICD",27,0) ;K ICDPRC "RTN","DGPTICD",28,0) ;I $D(DGPROC) S DGSURG=$S('$D(DGSURG):DGPROC,1:DGSURG_DGPROC) "RTN","DGPTICD",29,0) ;I $D(DGSURG) S DGI=0 F S DGI=DGI+1 Q:$P(DGSURG,U,DGI)="" D "RTN","DGPTICD",30,0) ;. I $D(^ICD0($P(DGSURG,U,DGI),0)) S ICDPRC(DGI)=$P(DGSURG,U,DGI) "RTN","DGPTICD",31,0) ;-- build ICDPRC array eliminating dupes as we go "RTN","DGPTICD",32,0) K ICDPRC "RTN","DGPTICD",33,0) N I,J,X,Y,FLG,SUB S SUB=0 "RTN","DGPTICD",34,0) I $D(DGPROC) F I=2:1 S X=$P(DGPROC,U,I) Q:X="" D "RTN","DGPTICD",35,0) . S DGPTTMP=$$ICDOP^ICDCODE(X,+$G(DGDAT)) "RTN","DGPTICD",36,0) . I +DGPTTMP>0,($P(DGPTTMP,U,10)) S SUB=SUB+1,ICDPRC(SUB)=X "RTN","DGPTICD",37,0) I $D(DGSURG) F I=2:1 S X=$P(DGSURG,U,I) Q:X="" D "RTN","DGPTICD",38,0) . S FLG=0,J=0 F S J=$O(ICDPRC(J)) Q:'J I X=$G(ICDPRC(J)) S FLG=1 Q "RTN","DGPTICD",39,0) . I FLG Q "RTN","DGPTICD",40,0) . S DGPTTMP=$$ICDOP^ICDCODE(X,+$G(DGDAT)) "RTN","DGPTICD",41,0) . I +DGPTTMP>0,($P(DGPTTMP,U,10)) S SUB=SUB+1,ICDPRC(SUB)=X "RTN","DGPTICD",42,0) ; "RTN","DGPTICD",43,0) ;-- set other required variables "RTN","DGPTICD",44,0) S ICDTRS=DGTRS,ICDEXP=DGEXP,ICDDMS=DGDMS "RTN","DGPTICD",45,0) S ICDDATE=$S($D(DGDAT):DGDAT,1:DT),DGDAT=ICDDATE ;Ensure that DGDAT is defined prior to executing PRT "RTN","DGPTICD",46,0) ; "RTN","DGPTICD",47,0) ;-- calculate DRG "RTN","DGPTICD",48,0) D ^ICDDRG S DRG=ICDDRG I '$D(DGDRGPRT) G Q "RTN","DGPTICD",49,0) ; "RTN","DGPTICD",50,0) PRT ;print DRG and national HCFA values "RTN","DGPTICD",51,0) I (ICDDATE<3071001)&(DRG=468!(DRG=469)!(DRG=470)) W *7 "RTN","DGPTICD",52,0) I DRG=998!(DRG=999) W *7 "RTN","DGPTICD",53,0) S Y=ICDDATE D DD^%DT ; Y=external representation of effective date "RTN","DGPTICD",54,0) W !!?9,"Effective Date:"," ",Y "RTN","DGPTICD",55,0) S DRG(0)=$$DRG^ICDGTDRG(DRG,DGDAT) W !!,"Diagnosis Related Group: ",$J(DRG,6),?36,"Average Length of Stay(ALOS): ",$J($P(DRG(0),"^",8),6) "RTN","DGPTICD",56,0) W !?17,"Weight: ",$J($P(DRG(0),"^",2),6) ;,?40,"Local Breakeven: ",$J($P(DRG(0),"^",12),6) "RTN","DGPTICD",57,0) W !?12," Low Day(s): ",$J($P(DRG(0),"^",3),6) ;,?39,"Local Low Day(s): ",$J($P(DRG(0),"^",9),6) "RTN","DGPTICD",58,0) W !?13," High Days: ",$J($P(DRG(0),"^",4),6) ;,?40,"Local High Days: ",$J($P(DRG(0),"^",10),6) "RTN","DGPTICD",59,0) N DXD,DGDX "RTN","DGPTICD",60,0) S DXD=$$DRGD^ICDGTDRG(DRG,"DGDX",,DGDAT),DGI=0 "RTN","DGPTICD",61,0) W !!,"DRG: ",DRG,"-" F S DGI=$O(DGDX(DGI)) Q:'+DGI Q:DGDX(DGI)=" " W ?10,DGDX(DGI),! "RTN","DGPTICD",62,0) Q K ICDDMS,ICDDRG,ICDDX,ICDEXP,ICDMDC,ICDPRC,ICDRTC,ICDTRS,ICDDATE Q "VER") 8.0^22.0 "BLD",7402,6) ^684 **END** **END**