DGPTFMO ;ALB/JDS/ADL - DGPTF PRINT TEMPLATE ; 4/13/04 12:11pm
;;5.3;PIMS;**195,397,510,590,594,606,683,729,1015,1016**;JUN 30, 2012;Build 20
;;ADL;Updated for CSV Project;;Mar 4, 2003
;FOR PTF REPORT CALLED FROM TEMPLATE DGPTF
EN K A,B,AD,ADA,DGDD,DGFC,HEAD,DGPTFE,DGST,DGN,T
F I=0:0 S I=$O(^DGPT(D0,"M",I)) Q:I'>0 I $D(^(I,0)) S J=+$P(^(0),U,10) S:'J J=999999999 S:$D(T(J)) J=J+.01*I S T(J)=I
F I=0:0 S I=$O(T(I)) Q:I'>0 S DGM=$S($D(^DGPT(D0,"M",T(I),0)):^(0),1:"") I DGM]"" D WRITE
K T F I=0:0 S I=$O(^DGPT(D0,"S",I)) Q:I'>0 D SUR
S DGOP1=$S($D(^DGPT(D0,"401P")):^("401P"),1:"") I DGOP1]"" D HEAD:$Y>(IOSL-10) G Q:'DN D PROC
I $D(^DGPT(D0,"P")) D HEAD:$Y>(IOSL-10) G Q:'DN F I=0:0 S I=$O(^DGPT(D0,"P",I)) Q:I'>0 S DG601=^DGPT(D0,"P",I,0),Y=+DG601 D D^DGPTUTL W !!," Procedure Date: ",Y D 601
S DGPT=$G(^DGPT(D0,70)) I DGPT]"" G Q:'DN D DXLS
K %,DGL,DGM,DGPT,DGOP,DGOP1,DGF,DGP,DXLS,DGICD,L1,S1,T,J,K,DGPR,DGN,AGE,B,DA,DAM,DFN,DGST,DOB,DP,DRG,EXP,NO,P,PTF,DGPTFE,SD1,SEX,TAC,TRS,DGDS,DGTD,DGPROC,DG601,DGPTDAT
W ! ;F I=$Y:1:IOSL-1 W !
Q
WRITE D HEAD:$Y>(IOSL-12) G Q:'DN S Y=$P(DGM,U,10),DGL=+$P(DGM,U,2),DGL=$S($D(^DIC(42.4,DGL,0)):^(0),1:""),DGL=$P(DGL,U,1) D D^DGPTUTL
W !!,"Movement Date: ",Y,?40,"Losing Specialty: ",$E(DGL,1,22),!,"Leave Days: ",$P(DGM,U,3),?40,"Pass Days: ",$P(DGM,U,4)
W !,"Treated for SC condition: ",$S($P(DGM,U,18)=1:"Yes",1:"No")
W:$P(DGM,U,31)'="" !,"Potentially Related to Combat: ",$S($P(DGM,U,31)="Y":"Yes",1:"No")
W:$P(DGM,U,26)'="" !,"Treated for AO condition: ",$S($P(DGM,U,26)="Y":"Yes",1:"No")
W:$P(DGM,U,27)'="" !,"Treated for IR condition: ",$S($P(DGM,U,27)="Y":"Yes",1:"No")
W:$P(DGM,U,28)'="" !,"Treated for service in SW Asia: ",$S($P(DGM,U,28)="Y":"Yes",1:"No")
W:$P(DGM,U,29)'="" !,"Treated for MST condition: ",$S($P(DGM,U,29)="Y":"Yes",$P(DGM,U,29)="N":"No",1:"Declined to answer") ; added 6/17/98 for MST enhancement
W:$P(DGM,U,30)'="" !,"Treated for HEAD/NECK CA condition: ",$S($P(DGM,U,30)="Y":"Yes",1:"No")
W:$P(DGM,U,32)'="" !,"Treated for SHAD Condition: ",$S($P(DGM,U,32)="Y":"Yes",1:"No")
W:T(I)=1 !,"Discharge "
S DGF="" F J=5:1:15 I J#10 S DGPTTMP=$$ICDDX^ICDCODE(+$P(DGM,U,J),$$GETDATE^ICDGTDRG(D0)),DGICD=$S(+DGPTTMP>0:$P(DGPTTMP,U,2,99),1:"") I DGICD]"" D
. W:DGF="" !!?13,"DX: " W $P(DGICD,U,3)_" ("_$P(DGICD,U)_")",!?17 S DGF=1
;-- display expanded codes
S DG300=$S($D(^DGPT(D0,"M",T(I),300)):^(300),1:"") I DG300]"" D HEAD:$Y>(IOSL-6) D PRN2^DGPTFM8 W !
K DG300
;Display TRANSFER DRG with description
Q:'$D(^DGPT(D0,"M",T(I),"P")) S DGTD=+^("P") Q:'$D(^ICD(DGTD,0)) W !?3,"TRANSFER DRG: ",DGTD," - "
N DXD,DGDX
S DXD=$$DRGD^ICDGTDRG(DGTD,"DGDX",,$$GETDATE^ICDGTDRG(D0)),DGDS=0
F S DGDS=$O(DGDX(DGDS)) Q:'+DGDS Q:DGDX(DGDS)=" " W !,DGDX(DGDS)
Q
HEAD I $E(IOST,1)="C" W *7 R X:DTIME I X=U S DN=0 Q
S DC=DC+1 W @IOF,! X:$D(^UTILITY($J,2)) ^(2) W ! F K=1:1:IOM W "_"
W !,"("_$P(^DPT(+^DGPT(D0,0),0),U,1)_")",!
Q
SUR D HEAD:$Y>(IOSL-7) G Q:'DN S S1=^DGPT(D0,"S",I,0),Y=+S1 D D^DGPTUTL W !!," Date of Surg: ",Y,?45,"Chief Surg: " S L=";"_$P(^DD(45.01,4,0),U,3),L1=";"_$P(S1,U,4)_":" W $P($P(L,L1,2),";",1)
W !," Anesth Tech: " S L=";"_$P(^DD(45.01,6,0),U,3),L1=";"_$P(S1,U,6)_":" W $P($P(L,L1,2),";",1),?45,"First Asst: " S L=";"_$P(^DD(45.01,5,0),U,3),L1=";"_$P(S1,U,5)_":" W $P($P(L,L1,2),";",1)
W !," Source of pay: " S L=";"_$P(^DD(45.01,7,0),U,3),L1=";"_$P(S1,U,7)_":" W $P($P(L,L1,2),";",1)
W ?46,"Surg spec: ",$S($D(^DIC(45.3,+$P(S1,U,3),0)):$P(^(0),U,2),1:"")
W !!,?7,"Surg/pro: " F K=1:1:5 S L=$P(S1,U,K+7) I L'="" S DGPTTMP=$$ICDOP^ICDCODE(+L,$$GETDATE^ICDGTDRG(D0)) W $S(+DGPTTMP>0:$P(DGPTTMP,U,5)_" ("_$P(DGPTTMP,U,2)_")",1:"**********-"_L),!?17
;-- display expanded codes
S DG300=$S($D(^DGPT(D0,"S",I,300)):^(300),1:"") I DG300]"" D PRN3^DGPTFM8
K DG300
Q
PROC S DGF="" F I=1:1:5 S DGPTTMP=$$ICDOP^ICDCODE(+$P(DGOP1,U,I),$$GETDATE^ICDGTDRG(D0)),DGOP=$S(DGPTTMP>0:$P(DGPTTMP,U,2,99),1:"") I DGOP D
. W:'DGF !!?6,"Procedure: " W $P(DGOP,U,4)_" ("_$P(DGOP,U)_")",!?17 S DGF=1
Q
601 ;print the procedures/dates from the 601 procedure multiple (eff. 10/1/87)
F J=5:1:9 S DGPTTMP=$$ICDOP^ICDCODE(+$P(DG601,U,J),$$GETDATE^ICDGTDRG(D0)),DGPROC=$S(+DGPTTMP>0:$P(DGPTTMP,U,2,99),1:"") I DGPROC W !?17,$P(DGPROC,U,4)_" ("_$P(DGPROC,U)_")"
Q
DXLS D HEAD:$Y>(IOSL-16) S DGPTDAT=$$GETDATE^ICDGTDRG(D0)
S DGPTTMP=$$ICDDX^ICDCODE(+$P(DGPT,U,10),DGPTDAT),DXLS=$S(+DGPTTMP>0:$P(DGPTTMP,U,2,99),1:"") I DXLS]"" W !!?11,"PRINCIPAL DIAGNOSIS: ",$P(DXLS,U,3)_" ("_$P(DXLS,U)_")"
I 'DXLS S DGPTTMP=$$ICDDX^ICDCODE(+$P(DGPT,U,11),DGPTDAT),DGP=$S(+DGPTTMP>0:$P(DGPTTMP,U,2,99),1:"") I DGP]"" W !!," Principal Diag: ",$P(DGP,U,3)_" ("_$P(DGP,U)_")"
S K=DGPT F I=16:1:24 D DSP
S K=$G(^DGPT(D0,71)) F I=1:1:4 D DSP
;-- display expanded code information
S DG300=$S($D(^DGPT(D0,300)):^(300),1:"") D:DG300]"" PRN2^DGPTFM8 K DG300
D EN2^DGPTF4 Q
Q Q
Q1 K ^UTILITY(U,$J),DG1 Q
DT I Y W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))," " W:Y#100 $J(Y#100\1,2),"," W Y\10000+1700 W:Y#1 " ",$E(Y_0,9,10),":",$E(Y_"000",11,12)
Q
DSP S J=$$ICDDX^ICDCODE(+$P(K,U,I),DGPTDAT) I J&$P(J,U,10) D
.I I#2 W ?40,$P(J,U,4)_"("_$P(J,U,2)_")" Q
.W !,$P(J,U,4)_"("_$P(J,U,2)_")"
Q
DGPTFMO ;ALB/JDS/ADL - DGPTF PRINT TEMPLATE ; 4/13/04 12:11pm
+1 ;;5.3;PIMS;**195,397,510,590,594,606,683,729,1015,1016**;JUN 30, 2012;Build 20
+2 ;;ADL;Updated for CSV Project;;Mar 4, 2003
+3 ;FOR PTF REPORT CALLED FROM TEMPLATE DGPTF
EN KILL A,B,AD,ADA,DGDD,DGFC,HEAD,DGPTFE,DGST,DGN,T
+1 FOR I=0:0
SET I=$ORDER(^DGPT(D0,"M",I))
IF I'>0
QUIT
IF $DATA(^(I,0))
SET J=+$PIECE(^(0),U,10)
IF 'J
SET J=999999999
IF $DATA(T(J))
SET J=J+.01*I
SET T(J)=I
+2 FOR I=0:0
SET I=$ORDER(T(I))
IF I'>0
QUIT
SET DGM=$SELECT($DATA(^DGPT(D0,"M",T(I),0)):^(0),1:"")
IF DGM]""
DO WRITE
+3 KILL T
FOR I=0:0
SET I=$ORDER(^DGPT(D0,"S",I))
IF I'>0
QUIT
DO SUR
+4 SET DGOP1=$SELECT($DATA(^DGPT(D0,"401P")):^("401P"),1:"")
IF DGOP1]""
IF $Y>(IOSL-10)
DO HEAD
IF 'DN
GOTO Q
DO PROC
+5 IF $DATA(^DGPT(D0,"P"))
IF $Y>(IOSL-10)
DO HEAD
IF 'DN
GOTO Q
FOR I=0:0
SET I=$ORDER(^DGPT(D0,"P",I))
IF I'>0
QUIT
SET DG601=^DGPT(D0,"P",I,0)
SET Y=+DG601
DO D^DGPTUTL
WRITE !!," Procedure Date: ",Y
DO 601
+6 SET DGPT=$GET(^DGPT(D0,70))
IF DGPT]""
IF 'DN
GOTO Q
DO DXLS
+7 KILL %,DGL,DGM,DGPT,DGOP,DGOP1,DGF,DGP,DXLS,DGICD,L1,S1,T,J,K,DGPR,DGN,AGE,B,DA,DAM,DFN,DGST,DOB,DP,DRG,EXP,NO,P,PTF,DGPTFE,SD1,SEX,TAC,TRS,DGDS,DGTD,DGPROC,DG601,DGPTDAT
+8 ;F I=$Y:1:IOSL-1 W !
WRITE !
+9 QUIT
WRITE IF $Y>(IOSL-12)
DO HEAD
IF 'DN
GOTO Q
SET Y=$PIECE(DGM,U,10)
SET DGL=+$PIECE(DGM,U,2)
SET DGL=$SELECT($DATA(^DIC(42.4,DGL,0)):^(0),1:"")
SET DGL=$PIECE(DGL,U,1)
DO D^DGPTUTL
+1 WRITE !!,"Movement Date: ",Y,?40,"Losing Specialty: ",$EXTRACT(DGL,1,22),!,"Leave Days: ",$PIECE(DGM,U,3),?40,"Pass Days: ",$PIECE(DGM,U,4)
+2 WRITE !,"Treated for SC condition: ",$SELECT($PIECE(DGM,U,18)=1:"Yes",1:"No")
+3 IF $PIECE(DGM,U,31)'=""
WRITE !,"Potentially Related to Combat: ",$SELECT($PIECE(DGM,U,31)="Y":"Yes",1:"No")
+4 IF $PIECE(DGM,U,26)'=""
WRITE !,"Treated for AO condition: ",$SELECT($PIECE(DGM,U,26)="Y":"Yes",1:"No")
+5 IF $PIECE(DGM,U,27)'=""
WRITE !,"Treated for IR condition: ",$SELECT($PIECE(DGM,U,27)="Y":"Yes",1:"No")
+6 IF $PIECE(DGM,U,28)'=""
WRITE !,"Treated for service in SW Asia: ",$SELECT($PIECE(DGM,U,28)="Y":"Yes",1:"No")
+7 ; added 6/17/98 for MST enhancement
IF $PIECE(DGM,U,29)'=""
WRITE !,"Treated for MST condition: ",$SELECT($PIECE(DGM,U,29)="Y":"Yes",$PIECE(DGM,U,29)="N":"No",1:"Declined to answer")
+8 IF $PIECE(DGM,U,30)'=""
WRITE !,"Treated for HEAD/NECK CA condition: ",$SELECT($PIECE(DGM,U,30)="Y":"Yes",1:"No")
+9 IF $PIECE(DGM,U,32)'=""
WRITE !,"Treated for SHAD Condition: ",$SELECT($PIECE(DGM,U,32)="Y":"Yes",1:"No")
+10 IF T(I)=1
WRITE !,"Discharge "
+11 SET DGF=""
FOR J=5:1:15
IF J#10
SET DGPTTMP=$$ICDDX^ICDCODE(+$PIECE(DGM,U,J),$$GETDATE^ICDGTDRG(D0))
SET DGICD=$SELECT(+DGPTTMP>0:$PIECE(DGPTTMP,U,2,99),1:"")
IF DGICD]""
Begin DoDot:1
+12 IF DGF=""
WRITE !!?13,"DX: "
WRITE $PIECE(DGICD,U,3)_" ("_$PIECE(DGICD,U)_")",!?17
SET DGF=1
End DoDot:1
+13 ;-- display expanded codes
+14 SET DG300=$SELECT($DATA(^DGPT(D0,"M",T(I),300)):^(300),1:"")
IF DG300]""
IF $Y>(IOSL-6)
DO HEAD
DO PRN2^DGPTFM8
WRITE !
+15 KILL DG300
+16 ;Display TRANSFER DRG with description
+17 IF '$DATA(^DGPT(D0,"M",T(I),"P"))
QUIT
SET DGTD=+^("P")
IF '$DATA(^ICD(DGTD,0))
QUIT
WRITE !?3,"TRANSFER DRG: ",DGTD," - "
+18 NEW DXD,DGDX
+19 SET DXD=$$DRGD^ICDGTDRG(DGTD,"DGDX",,$$GETDATE^ICDGTDRG(D0))
SET DGDS=0
+20 FOR
SET DGDS=$ORDER(DGDX(DGDS))
IF '+DGDS
QUIT
IF DGDX(DGDS)=" "
QUIT
WRITE !,DGDX(DGDS)
+21 QUIT
HEAD IF $EXTRACT(IOST,1)="C"
WRITE *7
READ X:DTIME
IF X=U
SET DN=0
QUIT
+1 SET DC=DC+1
WRITE @IOF,!
IF $DATA(^UTILITY($JOB,2))
XECUTE ^(2)
WRITE !
FOR K=1:1:IOM
WRITE "_"
+2 WRITE !,"("_$PIECE(^DPT(+^DGPT(D0,0),0),U,1)_")",!
+3 QUIT
SUR IF $Y>(IOSL-7)
DO HEAD
IF 'DN
GOTO Q
SET S1=^DGPT(D0,"S",I,0)
SET Y=+S1
DO D^DGPTUTL
WRITE !!," Date of Surg: ",Y,?45,"Chief Surg: "
SET L=";"_$PIECE(^DD(45.01,4,0),U,3)
SET L1=";"_$PIECE(S1,U,4)_":"
WRITE $PIECE($PIECE(L,L1,2),";",1)
+1 WRITE !," Anesth Tech: "
SET L=";"_$PIECE(^DD(45.01,6,0),U,3)
SET L1=";"_$PIECE(S1,U,6)_":"
WRITE $PIECE($PIECE(L,L1,2),";",1),?45,"First Asst: "
SET L=";"_$PIECE(^DD(45.01,5,0),U,3)
SET L1=";"_$PIECE(S1,U,5)_":"
WRITE $PIECE($PIECE(L,L1,2),";",1)
+2 WRITE !," Source of pay: "
SET L=";"_$PIECE(^DD(45.01,7,0),U,3)
SET L1=";"_$PIECE(S1,U,7)_":"
WRITE $PIECE($PIECE(L,L1,2),";",1)
+3 WRITE ?46,"Surg spec: ",$SELECT($DATA(^DIC(45.3,+$PIECE(S1,U,3),0)):$PIECE(^(0),U,2),1:"")
+4 WRITE !!,?7,"Surg/pro: "
FOR K=1:1:5
SET L=$PIECE(S1,U,K+7)
IF L'=""
SET DGPTTMP=$$ICDOP^ICDCODE(+L,$$GETDATE^ICDGTDRG(D0))
WRITE $SELECT(+DGPTTMP>0:$PIECE(DGPTTMP,U,5)_" ("_$PIECE(DGPTTMP,U,2)_")",1:"**********-"_L),!?17
+5 ;-- display expanded codes
+6 SET DG300=$SELECT($DATA(^DGPT(D0,"S",I,300)):^(300),1:"")
IF DG300]""
DO PRN3^DGPTFM8
+7 KILL DG300
+8 QUIT
PROC SET DGF=""
FOR I=1:1:5
SET DGPTTMP=$$ICDOP^ICDCODE(+$PIECE(DGOP1,U,I),$$GETDATE^ICDGTDRG(D0))
SET DGOP=$SELECT(DGPTTMP>0:$PIECE(DGPTTMP,U,2,99),1:"")
IF DGOP
Begin DoDot:1
+1 IF 'DGF
WRITE !!?6,"Procedure: "
WRITE $PIECE(DGOP,U,4)_" ("_$PIECE(DGOP,U)_")",!?17
SET DGF=1
End DoDot:1
+2 QUIT
601 ;print the procedures/dates from the 601 procedure multiple (eff. 10/1/87)
+1 FOR J=5:1:9
SET DGPTTMP=$$ICDOP^ICDCODE(+$PIECE(DG601,U,J),$$GETDATE^ICDGTDRG(D0))
SET DGPROC=$SELECT(+DGPTTMP>0:$PIECE(DGPTTMP,U,2,99),1:"")
IF DGPROC
WRITE !?17,$PIECE(DGPROC,U,4)_" ("_$PIECE(DGPROC,U)_")"
+2 QUIT
DXLS IF $Y>(IOSL-16)
DO HEAD
SET DGPTDAT=$$GETDATE^ICDGTDRG(D0)
+1 SET DGPTTMP=$$ICDDX^ICDCODE(+$PIECE(DGPT,U,10),DGPTDAT)
SET DXLS=$SELECT(+DGPTTMP>0:$PIECE(DGPTTMP,U,2,99),1:"")
IF DXLS]""
WRITE !!?11,"PRINCIPAL DIAGNOSIS: ",$PIECE(DXLS,U,3)_" ("_$PIECE(DXLS,U)_")"
+2 IF 'DXLS
SET DGPTTMP=$$ICDDX^ICDCODE(+$PIECE(DGPT,U,11),DGPTDAT)
SET DGP=$SELECT(+DGPTTMP>0:$PIECE(DGPTTMP,U,2,99),1:"")
IF DGP]""
WRITE !!," Principal Diag: ",$PIECE(DGP,U,3)_" ("_$PIECE(DGP,U)_")"
+3 SET K=DGPT
FOR I=16:1:24
DO DSP
+4 SET K=$GET(^DGPT(D0,71))
FOR I=1:1:4
DO DSP
+5 ;-- display expanded code information
+6 SET DG300=$SELECT($DATA(^DGPT(D0,300)):^(300),1:"")
IF DG300]""
DO PRN2^DGPTFM8
KILL DG300
+7 DO EN2^DGPTF4
QUIT
Q QUIT
Q1 KILL ^UTILITY(U,$JOB),DG1
QUIT
DT IF Y
WRITE $PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$EXTRACT(Y,4,5))," "
IF Y#100
WRITE $JUSTIFY(Y#100\1,2),","
WRITE Y\10000+1700
IF Y#1
WRITE " ",$EXTRACT(Y_0,9,10),":",$EXTRACT(Y_"000",11,12)
+1 QUIT
DSP SET J=$$ICDDX^ICDCODE(+$PIECE(K,U,I),DGPTDAT)
IF J&$PIECE(J,U,10)
Begin DoDot:1
+1 IF I#2
WRITE ?40,$PIECE(J,U,4)_"("_$PIECE(J,U,2)_")"
QUIT
+2 WRITE !,$PIECE(J,U,4)_"("_$PIECE(J,U,2)_")"
End DoDot:1
+3 QUIT
