- DGPTOLC2 ;ALB/AS/ADL,HIOFO/FT - SUMMARY BY ADM RPT, lists diagnoses,sur,pro (cont.) ;3/19/15 11:44am
- ;;5.3;Registration;**164,510,559,599,729,850,884**;Aug 13, 1993;Build 31
- ;;ADL;Update for CSV Project;;Mar 27, 2003
- ;
- ; ICDXCODE APIs - #5699
- ; VA(200) global - #10060
- ; VADPT APIs - #10061
- ; XLFDT APIs - #10103
- ;
- EN ;called from DGPTOLC1
- D LO^DGUTL,NOW^%DTC S DGPT=0,DGDT=$TR($$FMTE^XLFDT(DT,"5DF")," ","0")_"@",%=$P(%,".",2),DGDT=DGDT_$E(%,1,2)_":"_$E(%_"0000",3,4)
- F PTF=0:0 S PTF=$O(DGPTF(PTF)) Q:PTF'>0 S DGNAME=$P(DGPTF(PTF),"^"),DGADM=$P(DGPTF(PTF),"^",2),DGPTF(DGNAME,DGADM,PTF)="" K DGPTF(PTF) ;put names in alphabetical order
- F DGPTX=0:0 S DGPT=$O(DGPTF(DGPT)) Q:DGPT']"" F DGADM=0:0 S DGADM=$O(DGPTF(DGPT,DGADM)) Q:DGADM'>0 S DGPG=1,PTF=$O(DGPTF(DGPT,DGADM,0)),DFN=$S($D(^DGPT(PTF,0)):+^(0),1:"") I DFN]"" S DGPMIFN=$O(^DGPM("APTF",PTF,0)) D E,HD,D
- D Q2^DGPTOLC1
- Q
- E ;
- D EFFDATE^DGPTIC10(PTF)
- S DGELIG=$S('$D(^DPT(DFN,.36)):"Unknown",$D(^DIC(8,+$P(^(.36),"^"),0)):$P(^(0),"^"),1:"Unknown")
- N DGFLDPTR,DGFLDERR
- S %=""
- D FIELD^DID(2,.3611,,"POINTER","DGFLDPTR","DGFLDERR")
- S:$D(DGFLDPTR("POINTER")) %=";"_DGFLDPTR("POINTER")
- S X=$S($D(^DPT(DFN,.361)):$P(^(.361),"^"),1:"")
- S DGSTAT=$S(X']"":"Unknown",1:$P($P(%,";"_X_":",2),";",1))
- S DG70=$S($D(^DGPT(PTF,70)):^(70),1:""),DGFEE=$S($P(^DGPT(PTF,0),"^",4):1,1:"") I DGFEE S X1=$S(+DG70:+DG70,1:DT),X2=DGADM D ^%DTC S DGLOS=$S(X:X,1:1),DGLV=0,D1=0
- I '+DG70 S DGPRO=$S($D(^DPT(DFN,.104)):+^(.104),1:""),DGPRO=$S($D(^VA(200,+DGPRO,0)):$P(^(0),"^"),1:"Unknown")
- I +DG70 S DGPRO=$S('$D(^DGPT(PTF,"M",1,"P")):"",1:$P(^("P"),"^",5)),DGPRO=$S($D(^VA(200,+DGPRO,0)):$P(^(0),"^"),1:"") I DGPRO']"" D DGPRO
- Q
- CRT I IOST?1"C-".E R !?20,"Enter <RETURN> to continue",Y:DTIME
- HD W @IOF,?21,"PATIENT SUMMARY by ADMISSION",!!?51,"Run Date: ",DGDT,!,DGPT,?32,"SSN: ",$P(^DPT(+^DGPT(PTF,0),0),"^",9),?51,"Admitted: " S X=DGADM D DT
- W !,"Elig: ",DGELIG," (",DGSTAT,")",?50,"Discharge: " S X=$P(DG70,"^") D DT W ! W:DGFEE "Fee Basis"
- I DGPMIFN>0 W "Total LOS: " D ^DGPMLOS S X=+$P(X,"^")-(+$P(X,"^",2))-(+$P(X,"^",4)) W $S(X>0:X,1:"1") W ?18,"* Provider: ",$E(DGPRO,1,19)
- W ?55,"PTF #: ",PTF,?72,"Pg: ",DGPG S DGPG=DGPG+1 W:DGPMIFN>0 !,"* indicates the most recent PROVIDER entered for this admission",!
- Q
- D G S:'$D(^DGPT(PTF,"M","AC"))
- K DGMD F DGS=0:0 S DGS=$O(^DGPT(PTF,"M",DGS)) Q:DGS'>0 I $D(^(DGS,0)) S DGMD=+$P(^(0),"^",10) S:'DGMD DGMD=999999999 S:$D(DGMD(DGMD)) DGMD=DGMD+.01*DGS S DGMD(DGMD)=DGS ;put movements in date order
- F DGS=0:0 S DGS=$O(DGMD(DGS)) Q:DGS'>0 I $D(^DGPT(PTF,"M",DGMD(DGS),0)) D
- . S DGM=^(0),X=$P(DGM,"^",10),DGBS=+$P(DGM,"^",2) ;^(0) references global on line above
- . W !!,"Movement Date: " D DT W:DGMD(DGS)=1 ?40,"(Discharge 501)" W $$GETLABEL^DGPTIC10(EFFDATE,"D") D:DGFEE LOS D BS
- . K DG501
- . D PTFICD^DGPTFUT(501,PTF,DGMD(DGS),.DG501,1) ;get all DX and POAs for this multiple
- . S DGLOOP=0
- . F S DGLOOP=$O(DG501(DGLOOP)) Q:'DGLOOP S DGDXPOA=$G(DG501(DGLOOP)) D C
- I DG70 D
- . S DGM=DG70 W !!,"Discharge Move: (701/2/3 Diagnoses)",$$GETLABEL^DGPTIC10(EFFDATE,"D"),!
- . K DG701
- . D PTFICD^DGPTFUT(701,PTF,,.DG701,1) ;get all DX and POAs for this multiple
- . S DGLOOP=""
- . F S DGLOOP=$O(DG701(DGLOOP)) Q:DGLOOP="" S DGDXPOA=$G(DG701(DGLOOP)) D C
- K DG501,DG701,DGDXPOA,DGLOOP
- S ; --
- S DGF="S" F DGS=0:0 S DGS=$O(^DGPT(PTF,"S",DGS)) Q:DGS'>0 S DGSUR=^(DGS,0),X=+DGSUR W !!,"Surgery Date: " D DT W $$GETLABEL^DGPTIC10(EFFDATE,"P") D
- . F DGC=8:1:27 D P1
- . S DGSUR=$G(^DGPT(PTF,"S",DGS,1)) ;*884* get node with new/additional procedure codes
- . F DGC=1:1:5 D:$P(DGSUR,U,DGC) P1 ;*884* process procedure codes
- K DGF I $D(^DGPT(PTF,"401P")) S DGSUR=^("401P") W:'$D(DGF) !!,"Procedure: (401P)",$$GETLABEL^DGPTIC10(EFFDATE,"P") F DGC=1:1:5 D P1
- F DGS=0:0 S DGS=$O(^DGPT(PTF,"P",DGS)) Q:DGS'>0 S DGSUR=^(DGS,0),X=+DGSUR W !!,"Procedure Date: " D DT W $$GETLABEL^DGPTIC10(EFFDATE,"P") D
- . F DGC=5:1:24 D P1
- . S DGSUR=$G(^DGPT(PTF,"P",DGS,1)) ;*884* get node with new/additional procedure codes
- . F DGC=1:1:5 D:$P(DGSUR,U,DGC) P1 ;*884* process procedure codes
- W:DGFEE !,"Total LOS: ",$S(DGLOS>0:DGLOS,1:"1") W ! D:IOST?1"C-".E CONT
- Q
- ;
- C ; --Print Diagnosis and POA display
- Q:'+$P(DGDXPOA,U,1)
- S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$P(DGDXPOA,U,1),EFFDATE) D ;*884* get DX entry record info
- . I $Y>($S($D(IOSL):IOSL,1:66)-4) D CRT W !,"Diagnosis Codes, (cont.)",$$GETLABEL^DGPTIC10(EFFDATE,"D")
- . W:DGLOOP=0 ?4,"PRINCIPAL DIAGNOSIS: "
- . D WRITECOD^DGPTIC10("DIAG",+$P(DGDXPOA,U,1),EFFDATE,2,1,7)
- . W $S(+DGPTTMP<1!('$P(DGPTTMP,U,10)):"*",1:"") ;piece 1 is DX ien, piece 10 is STATUS (multiple)
- . Q:$P(DGPTTMP,U,20)=1 ;icd9 code, so there is no POA to display
- . W " ["_$S($P(DGDXPOA,U,2)]"":$P(DGDXPOA,U,2),1:" ")_"]" ;show POA value in brackets
- Q
- ;
- P1 ; -- Print Procedure Code
- Q:'+$P(DGSUR,"^",DGC)
- S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+$P(DGSUR,U,DGC),EFFDATE) D ;*884* get procedure record info
- . I $Y>($S($D(IOSL):IOSL,1:66)-4) D CRT W !,$S('$D(DGF):"Non-OR Procedures",DGF="S":"Surgery",1:"Non-OR Procedures") W " Codes, (cont.)"
- . D WRITECOD^DGPTIC10("PROC",+$P(DGSUR,"^",DGC),EFFDATE,2,1,7)
- . W $S(+DGPTTMP<1!('$P(DGPTTMP,U,10)):"*",1:"") ;piece 1 is DX ien, piece 10 is STATUS (multiple)
- Q
- ;
- DT Q:X']"" W $TR($$FMTE^XLFDT(X,"5DF")," ","0") S X=$P(X,".",2) I X]"" W "@"_$E(X,1,2)_":"_$E(X_"0000",3,4)
- Q
- BS S DGBS=$S('DGBS:DGBS,$D(^DIC(42.4,+DGBS,0)):$P(^(0),"^",1),1:"") W !,"Losing Specialty: ",DGBS
- Q
- LOS F %=3,4 S DGLV=$P(DGM,"^",%)+DGLV
- S DGLOS=DGLOS-DGLV
- Q
- CONT F Y=1:1:($S($D(IOSL):IOSL,1:66)-$Y-2) W !
- R ?20,"Enter <RETURN> to continue",Y:DTIME
- Q
- DGPRO S X=$O(^DGPM("APTF",PTF,0)),VAIP("E")=$S('$D(^DGPM(+X,0)):"",1:$P(^DGPM(X,0),"^",17))
- I VAIP("E") D IN5^VADPT S DGPRO=$S($P(VAIP(7),"^",2)]"":$P(VAIP(7),"^",2),1:"Unknown") K VAIP Q
- S DGPRO="Unknown" K VAIP
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTOLC2 5933 printed Apr 23, 2025@19:07:17 Page 2
- DGPTOLC2 ;ALB/AS/ADL,HIOFO/FT - SUMMARY BY ADM RPT, lists diagnoses,sur,pro (cont.) ;3/19/15 11:44am
- +1 ;;5.3;Registration;**164,510,559,599,729,850,884**;Aug 13, 1993;Build 31
- +2 ;;ADL;Update for CSV Project;;Mar 27, 2003
- +3 ;
- +4 ; ICDXCODE APIs - #5699
- +5 ; VA(200) global - #10060
- +6 ; VADPT APIs - #10061
- +7 ; XLFDT APIs - #10103
- +8 ;
- EN ;called from DGPTOLC1
- +1 DO LO^DGUTL
- DO NOW^%DTC
- SET DGPT=0
- SET DGDT=$TRANSLATE($$FMTE^XLFDT(DT,"5DF")," ","0")_"@"
- SET %=$PIECE(%,".",2)
- SET DGDT=DGDT_$EXTRACT(%,1,2)_":"_$EXTRACT(%_"0000",3,4)
- +2 ;put names in alphabetical order
- FOR PTF=0:0
- SET PTF=$ORDER(DGPTF(PTF))
- if PTF'>0
- QUIT
- SET DGNAME=$PIECE(DGPTF(PTF),"^")
- SET DGADM=$PIECE(DGPTF(PTF),"^",2)
- SET DGPTF(DGNAME,DGADM,PTF)=""
- KILL DGPTF(PTF)
- +3 FOR DGPTX=0:0
- SET DGPT=$ORDER(DGPTF(DGPT))
- if DGPT']""
- QUIT
- FOR DGADM=0:0
- SET DGADM=$ORDER(DGPTF(DGPT,DGADM))
- if DGADM'>0
- QUIT
- SET DGPG=1
- SET PTF=$ORDER(DGPTF(DGPT,DGADM,0))
- SET DFN=$SELECT($DATA(^DGPT(PTF,0)):+^(0),1:"")
- IF DFN]""
- SET DGPMIFN=$ORDER(^DGPM("APTF",PTF,0))
- DO E
- DO HD
- DO D
- +4 DO Q2^DGPTOLC1
- +5 QUIT
- E ;
- +1 DO EFFDATE^DGPTIC10(PTF)
- +2 SET DGELIG=$SELECT('$DATA(^DPT(DFN,.36)):"Unknown",$DATA(^DIC(8,+$PIECE(^(.36),"^"),0)):$PIECE(^(0),"^"),1:"Unknown")
- +3 NEW DGFLDPTR,DGFLDERR
- +4 SET %=""
- +5 DO FIELD^DID(2,.3611,,"POINTER","DGFLDPTR","DGFLDERR")
- +6 if $DATA(DGFLDPTR("POINTER"))
- SET %=";"_DGFLDPTR("POINTER")
- +7 SET X=$SELECT($DATA(^DPT(DFN,.361)):$PIECE(^(.361),"^"),1:"")
- +8 SET DGSTAT=$SELECT(X']"":"Unknown",1:$PIECE($PIECE(%,";"_X_":",2),";",1))
- +9 SET DG70=$SELECT($DATA(^DGPT(PTF,70)):^(70),1:"")
- SET DGFEE=$SELECT($PIECE(^DGPT(PTF,0),"^",4):1,1:"")
- IF DGFEE
- SET X1=$SELECT(+DG70:+DG70,1:DT)
- SET X2=DGADM
- DO ^%DTC
- SET DGLOS=$SELECT(X:X,1:1)
- SET DGLV=0
- SET D1=0
- +10 IF '+DG70
- SET DGPRO=$SELECT($DATA(^DPT(DFN,.104)):+^(.104),1:"")
- SET DGPRO=$SELECT($DATA(^VA(200,+DGPRO,0)):$PIECE(^(0),"^"),1:"Unknown")
- +11 IF +DG70
- SET DGPRO=$SELECT('$DATA(^DGPT(PTF,"M",1,"P")):"",1:$PIECE(^("P"),"^",5))
- SET DGPRO=$SELECT($DATA(^VA(200,+DGPRO,0)):$PIECE(^(0),"^"),1:"")
- IF DGPRO']""
- DO DGPRO
- +12 QUIT
- CRT IF IOST?1"C-".E
- READ !?20,"Enter <RETURN> to continue",Y:DTIME
- HD WRITE @IOF,?21,"PATIENT SUMMARY by ADMISSION",!!?51,"Run Date: ",DGDT,!,DGPT,?32,"SSN: ",$PIECE(^DPT(+^DGPT(PTF,0),0),"^",9),?51,"Admitted: "
- SET X=DGADM
- DO DT
- +1 WRITE !,"Elig: ",DGELIG," (",DGSTAT,")",?50,"Discharge: "
- SET X=$PIECE(DG70,"^")
- DO DT
- WRITE !
- if DGFEE
- WRITE "Fee Basis"
- +2 IF DGPMIFN>0
- WRITE "Total LOS: "
- DO ^DGPMLOS
- SET X=+$PIECE(X,"^")-(+$PIECE(X,"^",2))-(+$PIECE(X,"^",4))
- WRITE $SELECT(X>0:X,1:"1")
- WRITE ?18,"* Provider: ",$EXTRACT(DGPRO,1,19)
- +3 WRITE ?55,"PTF #: ",PTF,?72,"Pg: ",DGPG
- SET DGPG=DGPG+1
- if DGPMIFN>0
- WRITE !,"* indicates the most recent PROVIDER entered for this admission",!
- +4 QUIT
- D if '$DATA(^DGPT(PTF,"M","AC"))
- GOTO S
- +1 ;put movements in date order
- KILL DGMD
- FOR DGS=0:0
- SET DGS=$ORDER(^DGPT(PTF,"M",DGS))
- if DGS'>0
- QUIT
- IF $DATA(^(DGS,0))
- SET DGMD=+$PIECE(^(0),"^",10)
- if 'DGMD
- SET DGMD=999999999
- if $DATA(DGMD(DGMD))
- SET DGMD=DGMD+.01*DGS
- SET DGMD(DGMD)=DGS
- +2 FOR DGS=0:0
- SET DGS=$ORDER(DGMD(DGS))
- if DGS'>0
- QUIT
- IF $DATA(^DGPT(PTF,"M",DGMD(DGS),0))
- Begin DoDot:1
- +3 ;^(0) references global on line above
- SET DGM=^(0)
- SET X=$PIECE(DGM,"^",10)
- SET DGBS=+$PIECE(DGM,"^",2)
- +4 WRITE !!,"Movement Date: "
- DO DT
- if DGMD(DGS)=1
- WRITE ?40,"(Discharge 501)"
- WRITE $$GETLABEL^DGPTIC10(EFFDATE,"D")
- if DGFEE
- DO LOS
- DO BS
- +5 KILL DG501
- +6 ;get all DX and POAs for this multiple
- DO PTFICD^DGPTFUT(501,PTF,DGMD(DGS),.DG501,1)
- +7 SET DGLOOP=0
- +8 FOR
- SET DGLOOP=$ORDER(DG501(DGLOOP))
- if 'DGLOOP
- QUIT
- SET DGDXPOA=$GET(DG501(DGLOOP))
- DO C
- End DoDot:1
- +9 IF DG70
- Begin DoDot:1
- +10 SET DGM=DG70
- WRITE !!,"Discharge Move: (701/2/3 Diagnoses)",$$GETLABEL^DGPTIC10(EFFDATE,"D"),!
- +11 KILL DG701
- +12 ;get all DX and POAs for this multiple
- DO PTFICD^DGPTFUT(701,PTF,,.DG701,1)
- +13 SET DGLOOP=""
- +14 FOR
- SET DGLOOP=$ORDER(DG701(DGLOOP))
- if DGLOOP=""
- QUIT
- SET DGDXPOA=$GET(DG701(DGLOOP))
- DO C
- End DoDot:1
- +15 KILL DG501,DG701,DGDXPOA,DGLOOP
- S ; --
- +1 SET DGF="S"
- FOR DGS=0:0
- SET DGS=$ORDER(^DGPT(PTF,"S",DGS))
- if DGS'>0
- QUIT
- SET DGSUR=^(DGS,0)
- SET X=+DGSUR
- WRITE !!,"Surgery Date: "
- DO DT
- WRITE $$GETLABEL^DGPTIC10(EFFDATE,"P")
- Begin DoDot:1
- +2 FOR DGC=8:1:27
- DO P1
- +3 ;*884* get node with new/additional procedure codes
- SET DGSUR=$GET(^DGPT(PTF,"S",DGS,1))
- +4 ;*884* process procedure codes
- FOR DGC=1:1:5
- if $PIECE(DGSUR,U,DGC)
- DO P1
- End DoDot:1
- +5 KILL DGF
- IF $DATA(^DGPT(PTF,"401P"))
- SET DGSUR=^("401P")
- if '$DATA(DGF)
- WRITE !!,"Procedure: (401P)",$$GETLABEL^DGPTIC10(EFFDATE,"P")
- FOR DGC=1:1:5
- DO P1
- +6 FOR DGS=0:0
- SET DGS=$ORDER(^DGPT(PTF,"P",DGS))
- if DGS'>0
- QUIT
- SET DGSUR=^(DGS,0)
- SET X=+DGSUR
- WRITE !!,"Procedure Date: "
- DO DT
- WRITE $$GETLABEL^DGPTIC10(EFFDATE,"P")
- Begin DoDot:1
- +7 FOR DGC=5:1:24
- DO P1
- +8 ;*884* get node with new/additional procedure codes
- SET DGSUR=$GET(^DGPT(PTF,"P",DGS,1))
- +9 ;*884* process procedure codes
- FOR DGC=1:1:5
- if $PIECE(DGSUR,U,DGC)
- DO P1
- End DoDot:1
- +10 if DGFEE
- WRITE !,"Total LOS: ",$SELECT(DGLOS>0:DGLOS,1:"1")
- WRITE !
- if IOST?1"C-".E
- DO CONT
- +11 QUIT
- +12 ;
- C ; --Print Diagnosis and POA display
- +1 if '+$PIECE(DGDXPOA,U,1)
- QUIT
- +2 ;*884* get DX entry record info
- SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$PIECE(DGDXPOA,U,1),EFFDATE)
- Begin DoDot:1
- +3 IF $Y>($SELECT($DATA(IOSL):IOSL,1:66)-4)
- DO CRT
- WRITE !,"Diagnosis Codes, (cont.)",$$GETLABEL^DGPTIC10(EFFDATE,"D")
- +4 if DGLOOP=0
- WRITE ?4,"PRINCIPAL DIAGNOSIS: "
- +5 DO WRITECOD^DGPTIC10("DIAG",+$PIECE(DGDXPOA,U,1),EFFDATE,2,1,7)
- +6 ;piece 1 is DX ien, piece 10 is STATUS (multiple)
- WRITE $SELECT(+DGPTTMP<1!('$PIECE(DGPTTMP,U,10)):"*",1:"")
- +7 ;icd9 code, so there is no POA to display
- if $PIECE(DGPTTMP,U,20)=1
- QUIT
- +8 ;show POA value in brackets
- WRITE " ["_$SELECT($PIECE(DGDXPOA,U,2)]"":$PIECE(DGDXPOA,U,2),1:" ")_"]"
- End DoDot:1
- +9 QUIT
- +10 ;
- P1 ; -- Print Procedure Code
- +1 if '+$PIECE(DGSUR,"^",DGC)
- QUIT
- +2 ;*884* get procedure record info
- SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+$PIECE(DGSUR,U,DGC),EFFDATE)
- Begin DoDot:1
- +3 IF $Y>($SELECT($DATA(IOSL):IOSL,1:66)-4)
- DO CRT
- WRITE !,$SELECT('$DATA(DGF):"Non-OR Procedures",DGF="S":"Surgery",1:"Non-OR Procedures")
- WRITE " Codes, (cont.)"
- +4 DO WRITECOD^DGPTIC10("PROC",+$PIECE(DGSUR,"^",DGC),EFFDATE,2,1,7)
- +5 ;piece 1 is DX ien, piece 10 is STATUS (multiple)
- WRITE $SELECT(+DGPTTMP<1!('$PIECE(DGPTTMP,U,10)):"*",1:"")
- End DoDot:1
- +6 QUIT
- +7 ;
- DT if X']""
- QUIT
- WRITE $TRANSLATE($$FMTE^XLFDT(X,"5DF")," ","0")
- SET X=$PIECE(X,".",2)
- IF X]""
- WRITE "@"_$EXTRACT(X,1,2)_":"_$EXTRACT(X_"0000",3,4)
- +1 QUIT
- BS SET DGBS=$SELECT('DGBS:DGBS,$DATA(^DIC(42.4,+DGBS,0)):$PIECE(^(0),"^",1),1:"")
- WRITE !,"Losing Specialty: ",DGBS
- +1 QUIT
- LOS FOR %=3,4
- SET DGLV=$PIECE(DGM,"^",%)+DGLV
- +1 SET DGLOS=DGLOS-DGLV
- +2 QUIT
- CONT FOR Y=1:1:($SELECT($DATA(IOSL):IOSL,1:66)-$Y-2)
- WRITE !
- +1 READ ?20,"Enter <RETURN> to continue",Y:DTIME
- +2 QUIT
- DGPRO SET X=$ORDER(^DGPM("APTF",PTF,0))
- SET VAIP("E")=$SELECT('$DATA(^DGPM(+X,0)):"",1:$PIECE(^DGPM(X,0),"^",17))
- +1 IF VAIP("E")
- DO IN5^VADPT
- SET DGPRO=$SELECT($PIECE(VAIP(7),"^",2)]"":$PIECE(VAIP(7),"^",2),1:"Unknown")
- KILL VAIP
- QUIT
- +2 SET DGPRO="Unknown"
- KILL VAIP
- +3 QUIT
