DGPTOLC2 ;ALB/AS/ADL - SUMMARY BY ADM RPT, lists diagnoses,sur,pro (cont.) ; 11/15/06 3:15pm
;;5.3;Registration;**164,510,559,599,729,1015**; Aug 13, 1993;Build 21
;;ADL;Update for CSV Project;;Mar 27, 2003
;
EN 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 S DGELIG=$S('$D(^DPT(DFN,.36)):"Unknown",$D(^DIC(8,+$P(^(.36),"^"),0)):$P(^(0),"^"),1:"Unknown"),X=$S($D(^DPT(DFN,.361)):$P(^(.361),"^"),1:""),%=";"_$P(^DD(2,.3611,0),"^",3),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)) S DGM=^(0),X=$P(DGM,"^",10),DGBS=+$P(DGM,"^",2) W !!,"Movement Date: " D DT W:DGMD(DGS)=1 ?40,"(Discharge 501)" D:DGFEE LOS D BS F DGC=5:1:15 I DGC#10 D C
I DG70 S DGM=DG70 W !!,"Discharge Move: (701/2/3 Diagnoses)",! F DGC=10,11,16:1:24 D C
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 F DGC=8:1:12 D P1
K DGF I $D(^DGPT(PTF,"401P")) S DGSUR=^("401P") F DGC=1:1:5 X:'($D(DGF)) "W !!,""Procedure: (401P)"" S DGF=1" 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 F DGC=5:1:9 D P1
W:DGFEE !,"Total LOS: ",$S(DGLOS>0:DGLOS,1:"1") W ! D:IOST?1"C-".E CONT Q
C S DGPTTMP=$$ICDDX^ICDCODE(+$P(DGM,"^",DGC),$$GETDATE^ICDGTDRG(PTF),,1) Q:+DGPTTMP<0!('$P(DGPTTMP,U,10)) S DGICD=$P(DGPTTMP,U,2,99) D
. I $Y>($S($D(IOSL):IOSL,1:66)-4) D CRT W !,"Diagnosis Codes, (cont.)"
W:DGC=10 ?4,"PRINCIPAL DIAGNOSIS: " W:DGC'=10 ! W ?10,$P(DGICD,"^",3)_" ("_$P(DGICD,"^",1)_")" Q
P1 S DGPTTMP=$$ICDOP^ICDCODE(+$P(DGSUR,"^",DGC),$$GETDATE^ICDGTDRG(PTF),,1) Q:+DGPTTMP<0!('$P(DGPTTMP,U,10)) S DGICD=$P(DGPTTMP,U,2,99) Q:DGICD']"" D
. 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.)"
W !?10,$P(DGICD,"^",4)_" ("_$P(DGICD,"^")_")" 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
DGPTOLC2 ;ALB/AS/ADL - SUMMARY BY ADM RPT, lists diagnoses,sur,pro (cont.) ; 11/15/06 3:15pm
+1 ;;5.3;Registration;**164,510,559,599,729,1015**; Aug 13, 1993;Build 21
+2 ;;ADL;Update for CSV Project;;Mar 27, 2003
+3 ;
EN 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)
+1 ;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)
+2 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
+3 DO Q2^DGPTOLC1
QUIT
E SET DGELIG=$SELECT('$DATA(^DPT(DFN,.36)):"Unknown",$DATA(^DIC(8,+$PIECE(^(.36),"^"),0)):$PIECE(^(0),"^"),1:"Unknown")
SET X=$SELECT($DATA(^DPT(DFN,.361)):$PIECE(^(.361),"^"),1:"")
SET %=";"_$PIECE(^DD(2,.3611,0),"^",3)
SET DGSTAT=$SELECT(X']"":"Unknown",1:$PIECE($PIECE(%,";"_X_":",2),";",1))
+1 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
+2 IF '+DG70
SET DGPRO=$SELECT($DATA(^DPT(DFN,.104)):+^(.104),1:"")
SET DGPRO=$SELECT($DATA(^VA(200,+DGPRO,0)):$PIECE(^(0),"^"),1:"Unknown")
+3 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
+4 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",!
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))
SET DGM=^(0)
SET X=$PIECE(DGM,"^",10)
SET DGBS=+$PIECE(DGM,"^",2)
WRITE !!,"Movement Date: "
DO DT
IF DGMD(DGS)=1
WRITE ?40,"(Discharge 501)"
IF DGFEE
DO LOS
DO BS
FOR DGC=5:1:15
IF DGC#10
DO C
+3 IF DG70
SET DGM=DG70
WRITE !!,"Discharge Move: (701/2/3 Diagnoses)",!
FOR DGC=10,11,16:1:24
DO C
S 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
FOR DGC=8:1:12
DO P1
+1 KILL DGF
IF $DATA(^DGPT(PTF,"401P"))
SET DGSUR=^("401P")
FOR DGC=1:1:5
IF '($DATA(DGF))
XECUTE "W !!,""Procedure: (401P)"" S DGF=1"
DO P1
+2 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
FOR DGC=5:1:9
DO P1
+3 IF DGFEE
WRITE !,"Total LOS: ",$SELECT(DGLOS>0:DGLOS,1:"1")
WRITE !
IF IOST?1"C-".E
DO CONT
QUIT
C SET DGPTTMP=$$ICDDX^ICDCODE(+$PIECE(DGM,"^",DGC),$$GETDATE^ICDGTDRG(PTF),,1)
IF +DGPTTMP<0!('$PIECE(DGPTTMP,U,10))
QUIT
SET DGICD=$PIECE(DGPTTMP,U,2,99)
Begin DoDot:1
+1 IF $Y>($SELECT($DATA(IOSL):IOSL,1:66)-4)
DO CRT
WRITE !,"Diagnosis Codes, (cont.)"
End DoDot:1
+2 IF DGC=10
WRITE ?4,"PRINCIPAL DIAGNOSIS: "
IF DGC'=10
WRITE !
WRITE ?10,$PIECE(DGICD,"^",3)_" ("_$PIECE(DGICD,"^",1)_")"
QUIT
P1 SET DGPTTMP=$$ICDOP^ICDCODE(+$PIECE(DGSUR,"^",DGC),$$GETDATE^ICDGTDRG(PTF),,1)
IF +DGPTTMP<0!('$PIECE(DGPTTMP,U,10))
QUIT
SET DGICD=$PIECE(DGPTTMP,U,2,99)
IF DGICD']""
QUIT
Begin DoDot:1
+1 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.)"
End DoDot:1
+2 WRITE !?10,$PIECE(DGICD,"^",4)_" ("_$PIECE(DGICD,"^")_")"
QUIT
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
QUIT
LOS FOR %=3,4
SET DGLV=$PIECE(DGM,"^",%)+DGLV
+1 SET DGLOS=DGLOS-DGLV
QUIT
CONT FOR Y=1:1:($SELECT($DATA(IOSL):IOSL,1:66)-$Y-2)
WRITE !
+1 READ ?20,"Enter <RETURN> to continue",Y:DTIME
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
QUIT
