- 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
