- DGPTFMO ;ALB/JDS/ADL,HIOFO/FT - DGPTF PRINT TEMPLATE ;10/15/14 2:25pm
- ;;5.3;Registration;**195,397,510,590,594,606,683,729,664,850,884,1057**;Aug 13, 1993;Build 17
- ;;ADL;Updated for CSV Project;;Mar 4, 2003
- ;
- ; ICDEX APIs - #5747
- ; ICDGTDRG APIs - #4052
- ; ICDXCODE APIs - #5699
- ;
- EN ;called from print template DGPT CENSUS INQUIRY
- K A,B,AD,ADA,DGDD,DGDDPTR,DGLOOP,DGFC,HEAD,DGPTFE,DGST,DGN,T,T82,DGM82,EFFDATE,IMPDATE,DGPTDAT
- F DGLOOP=4:1:7 D ;get the set of codes for fields 4,5,6, & 7 in 45.01 (401 data - Surgery)
- .K DGERROR,DGRESULT
- .S DGDDPTR(DGLOOP)=""
- .D FIELD^DID(45.01,DGLOOP,,"POINTER","DGRESULT","DGERROR")
- .I '$D(DGERROR) S DGDDPTR(DGLOOP)=$G(DGRESULT("POINTER"))
- K DGERROR,DGRESULT
- ;
- 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:"") D:DGM]"" 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 !!?5,"Procedure Date: ",Y,$$GETLABEL^DGPTIC10(EFFDATE,"P") 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 !
- K T82,DGM82,DGMPOA,DGLOOP
- 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
- ; ICD-10 CALLS
- D EFFDATE^DGPTIC10(D0)
- ;
- 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="",J=0 K DG501
- D PTFICD^DGPTFUT(501,D0,T(I),.DG501,1)
- F S J=$O(DG501(J)) Q:'J D
- . S DGMPOA=$P(DG501(J),U,2) ;get POA code
- . S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$P(DG501(J),U,1),EFFDATE)
- . W:DGF="" !!?5,"DX: ",$$GETLABEL^DGPTIC10(EFFDATE,"D")
- . D WRITECOD^DGPTIC10("DIAG",+$P(DG501(J),U,1),EFFDATE,2,1,8)
- . I $P(DGPTTMP,U,20)=30 W:$X>73 !," " W " (POA=",$S(DGMPOA]"":DGMPOA,1:"''"),")"
- . W $S(+DGPTTMP<1!('$P(DGPTTMP,U,10)):"*",1:"")
- . S DGF=1
- K DG501
- ;-- 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:$P($$CODEC^ICDEX(80,DGTD),U,1)="-1" 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=";"_DGDDPTR(4),L1=";"_$P(S1,U,4)_":" W $P($P(L,L1,2),";",1)
- W !," Anesth Tech: " S L=";"_DGDDPTR(6),L1=";"_$P(S1,U,6)_":" W $P($P(L,L1,2),";",1),?45,"First Asst: "
- S L=";"_DGDDPTR(5),L1=";"_$P(S1,U,5)_":" W $P($P(L,L1,2),";",1)
- W !," Source of pay: " S L=";"_DGDDPTR(7),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 !!,?5,"Surg/pro: ",$$GETLABEL^DGPTIC10(EFFDATE,"P"),!?7
- S K=0 K DG401
- D PTFICD^DGPTFUT(401,D0,I,.DG401,1)
- F S K=$O(DG401(K)) Q:'K D
- . S L=$P(DG401(K),U,1),DGPTTMP=""
- . I L'="" S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+L,EFFDATE) D
- .. D WRITECOD^DGPTIC10("PROC",+L,EFFDATE,2,1,8)
- .. W $S(+DGPTTMP<1!('$P(DGPTTMP,U,10)):"*",1:"")
- K DG401
- ;-- 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 D:$P(DGOP1,U,I)'=""
- . S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+$P(DGOP1,U,I),EFFDATE)
- . W:'DGF !!?5,"Procedure: ",$$GETLABEL^DGPTIC10(EFFDATE,"P") S DGF=1
- . D WRITECOD^DGPTIC10("PROC",+$P(DGOP1,U,I),EFFDATE,2,1,8)
- . W $S(+DGPTTMP<1!('$P(DGPTTMP,U,10)):"*",1:"")
- Q
- 601 ;print the procedures/dates from the 601 procedure multiple (eff. 10/1/87)
- K DG601 S J=0
- D PTFICD^DGPTFUT(601,D0,I,.DG601,1)
- F S J=$O(DG601(J)) Q:'J D
- . S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+$P(DG601(J),U,1),EFFDATE)
- . D WRITECOD^DGPTIC10("PROC",+$P(DG601(J),U,1),EFFDATE,2,1,8)
- . W $S(+DGPTTMP<1!('$P(DGPTTMP,U,10)):"*",1:"")
- K DG601
- Q
- DXLS ;
- N DGIDTS
- D HEAD:$Y>(IOSL-16)
- S DGPOA1=$P($G(^DGPT(D0,82)),U,1) ;POA for principal DX
- I +$P(DGPT,U,10) D
- . S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$P(DGPT,U,10),EFFDATE),DXLS=$S(+DGPTTMP>0:$P(DGPTTMP,U,2,99),1:"")
- . W !!?5,"PRINCIPAL DIAGNOSIS: ",$$GETLABEL^DGPTIC10(EFFDATE,"D")
- . D WRITECOD^DGPTIC10("DIAG",+$P(DGPT,U,10),EFFDATE,2,1,8)
- . W $S(+DGPTTMP<1!('$P(DGPTTMP,U,10)):"*",1:"")
- . Q:$P(DGPTTMP,U,20)'=30 ;not an ICD10 DX
- . W " ["_$S(DGPOA1]"":DGPOA1,1:" ")_"]" ;show POA value
- ;
- I +$P(DGPT,U,11) D
- . S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$P(DGPT,U,11),EFFDATE)
- . D WRITECOD^DGPTIC10("DIAG",+$P(DGPT,U,11),EFFDATE,2,1,8)
- . W $S(+DGPTTMP<1!('$P(DGPTTMP,U,10)):"*",1:"")
- . Q:$P(DGPTTMP,U,20)'=30 ;not an ICD10 DX
- . W " ["_$S(DGPOA1]"":DGPOA1,1:" ")_"]" ;show POA value. there shouldn't be one for old records
- K DG701,DGPOA1 S K=0
- D PTFICD^DGPTFUT(701,D0,,.DG701,1)
- F S K=$O(DG701(K)) Q:'K D:$P(DG701(K),U,1)>0 DSP
- K DG701
- ;-- display expanded code information
- S DG300=$S($D(^DGPT(D0,300)):^(300),1:"") D:DG300]"" PRN2^DGPTFM8 K DG300
- D EN2^DGPTF4 ;calls ^DGPTFD to get DX/OP codes and then calls DGPTICD to calculate & store DRG value in PTF CLOSE OUT (#45.84) file.
- ; display initial date of service DG*5.3*1057
- S DGIDTS=+$P(^DGPT(D0,0),U,14) I DGIDTS>0 D
- .W !,"*Initial Date Of Service: "_$$EXTERNAL^DILFD(45,14,,$G(DGIDTS))
- .W !," *Utilize section 1 on the 101 screen for editing."
- .Q
- ;
- 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=$$ICDDATA^ICDXCODE("DIAG",+$P(DG701(K),U,1),EFFDATE) D
- . D WRITECOD^DGPTIC10("DIAG",+$P(DG701(K),U,1),EFFDATE,2,1,8)
- . W $S(+J<1!('$P(J,U,10)):"*",1:"")
- . Q:$P(J,U,20)'=30 ;not an ICD-10 DX
- . W " ["_$S($P(DG701(K),U,2)]"":$P(DG701(K),U,2),1:" ")_"]"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTFMO 7386 printed Feb 19, 2025@00:18:29 Page 2
- DGPTFMO ;ALB/JDS/ADL,HIOFO/FT - DGPTF PRINT TEMPLATE ;10/15/14 2:25pm
- +1 ;;5.3;Registration;**195,397,510,590,594,606,683,729,664,850,884,1057**;Aug 13, 1993;Build 17
- +2 ;;ADL;Updated for CSV Project;;Mar 4, 2003
- +3 ;
- +4 ; ICDEX APIs - #5747
- +5 ; ICDGTDRG APIs - #4052
- +6 ; ICDXCODE APIs - #5699
- +7 ;
- EN ;called from print template DGPT CENSUS INQUIRY
- +1 KILL A,B,AD,ADA,DGDD,DGDDPTR,DGLOOP,DGFC,HEAD,DGPTFE,DGST,DGN,T,T82,DGM82,EFFDATE,IMPDATE,DGPTDAT
- +2 ;get the set of codes for fields 4,5,6, & 7 in 45.01 (401 data - Surgery)
- FOR DGLOOP=4:1:7
- Begin DoDot:1
- +3 KILL DGERROR,DGRESULT
- +4 SET DGDDPTR(DGLOOP)=""
- +5 DO FIELD^DID(45.01,DGLOOP,,"POINTER","DGRESULT","DGERROR")
- +6 IF '$DATA(DGERROR)
- SET DGDDPTR(DGLOOP)=$GET(DGRESULT("POINTER"))
- End DoDot:1
- +7 KILL DGERROR,DGRESULT
- +8 ;
- +9 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
- +10 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
- +11 ;
- +12 KILL T
- FOR I=0:0
- SET I=$ORDER(^DGPT(D0,"S",I))
- if I'>0
- QUIT
- DO SUR
- +13 SET DGOP1=$SELECT($DATA(^DGPT(D0,"401P")):^("401P"),1:"")
- +14 IF DGOP1]""
- if $Y>(IOSL-10)
- DO HEAD
- if 'DN
- GOTO Q
- DO PROC
- +15 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 !!?5,"Procedure Date: ",Y,$$GETLABEL^DGPTIC10(EFFDATE,"P")
- DO 601
- +16 SET DGPT=$GET(^DGPT(D0,70))
- IF DGPT]""
- if 'DN
- GOTO Q
- DO DXLS
- +17 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
- +18 WRITE !
- +19 KILL T82,DGM82,DGMPOA,DGLOOP
- +20 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 ; ICD-10 CALLS
- +2 DO EFFDATE^DGPTIC10(D0)
- +3 ;
- +4 WRITE !!,"Movement Date: ",Y,?40,"Losing Specialty: ",$EXTRACT(DGL,1,22),!,"Leave Days: ",$PIECE(DGM,U,3),?40,"Pass Days: ",$PIECE(DGM,U,4)
- +5 WRITE !,"Treated for SC condition: ",$SELECT($PIECE(DGM,U,18)=1:"Yes",1:"No")
- +6 if $PIECE(DGM,U,31)'=""
- WRITE !,"Potentially Related to Combat: ",$SELECT($PIECE(DGM,U,31)="Y":"Yes",1:"No")
- +7 if $PIECE(DGM,U,26)'=""
- WRITE !,"Treated for AO condition: ",$SELECT($PIECE(DGM,U,26)="Y":"Yes",1:"No")
- +8 if $PIECE(DGM,U,27)'=""
- WRITE !,"Treated for IR condition: ",$SELECT($PIECE(DGM,U,27)="Y":"Yes",1:"No")
- +9 if $PIECE(DGM,U,28)'=""
- WRITE !,"Treated for service in SW Asia: ",$SELECT($PIECE(DGM,U,28)="Y":"Yes",1:"No")
- +10 ; 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")
- +11 if $PIECE(DGM,U,30)'=""
- WRITE !,"Treated for HEAD/NECK CA condition: ",$SELECT($PIECE(DGM,U,30)="Y":"Yes",1:"No")
- +12 if $PIECE(DGM,U,32)'=""
- WRITE !,"Treated for SHAD Condition: ",$SELECT($PIECE(DGM,U,32)="Y":"Yes",1:"No")
- +13 if T(I)=1
- WRITE !,"Discharge "
- +14 SET DGF=""
- SET J=0
- KILL DG501
- +15 DO PTFICD^DGPTFUT(501,D0,T(I),.DG501,1)
- +16 FOR
- SET J=$ORDER(DG501(J))
- if 'J
- QUIT
- Begin DoDot:1
- +17 ;get POA code
- SET DGMPOA=$PIECE(DG501(J),U,2)
- +18 SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$PIECE(DG501(J),U,1),EFFDATE)
- +19 if DGF=""
- WRITE !!?5,"DX: ",$$GETLABEL^DGPTIC10(EFFDATE,"D")
- +20 DO WRITECOD^DGPTIC10("DIAG",+$PIECE(DG501(J),U,1),EFFDATE,2,1,8)
- +21 IF $PIECE(DGPTTMP,U,20)=30
- if $X>73
- WRITE !," "
- WRITE " (POA=",$SELECT(DGMPOA]"":DGMPOA,1:"''"),")"
- +22 WRITE $SELECT(+DGPTTMP<1!('$PIECE(DGPTTMP,U,10)):"*",1:"")
- +23 SET DGF=1
- End DoDot:1
- +24 KILL DG501
- +25 ;-- display expanded codes
- +26 SET DG300=$SELECT($DATA(^DGPT(D0,"M",T(I),300)):^(300),1:"")
- IF DG300]""
- if $Y>(IOSL-6)
- DO HEAD
- DO PRN2^DGPTFM8
- WRITE !
- +27 KILL DG300
- +28 ;Display TRANSFER DRG with description
- +29 if '$DATA(^DGPT(D0,"M",T(I),"P"))
- QUIT
- SET DGTD=+^("P")
- if $PIECE($$CODEC^ICDEX(80,DGTD),U,1)="-1"
- QUIT
- WRITE !?3,"TRANSFER DRG: ",DGTD," - "
- +30 NEW DXD,DGDX
- +31 SET DXD=$$DRGD^ICDGTDRG(DGTD,"DGDX",,$$GETDATE^ICDGTDRG(D0))
- SET DGDS=0
- +32 FOR
- SET DGDS=$ORDER(DGDX(DGDS))
- if '+DGDS
- QUIT
- if DGDX(DGDS)=" "
- QUIT
- WRITE !,DGDX(DGDS)
- +33 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 ;
- +1 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: "
- +2 SET L=";"_DGDDPTR(4)
- SET L1=";"_$PIECE(S1,U,4)_":"
- WRITE $PIECE($PIECE(L,L1,2),";",1)
- +3 WRITE !," Anesth Tech: "
- SET L=";"_DGDDPTR(6)
- SET L1=";"_$PIECE(S1,U,6)_":"
- WRITE $PIECE($PIECE(L,L1,2),";",1),?45,"First Asst: "
- +4 SET L=";"_DGDDPTR(5)
- SET L1=";"_$PIECE(S1,U,5)_":"
- WRITE $PIECE($PIECE(L,L1,2),";",1)
- +5 WRITE !," Source of pay: "
- SET L=";"_DGDDPTR(7)
- SET L1=";"_$PIECE(S1,U,7)_":"
- WRITE $PIECE($PIECE(L,L1,2),";",1)
- +6 WRITE ?46,"Surg spec: ",$SELECT($DATA(^DIC(45.3,+$PIECE(S1,U,3),0)):$PIECE(^(0),U,2),1:"")
- +7 WRITE !!,?5,"Surg/pro: ",$$GETLABEL^DGPTIC10(EFFDATE,"P"),!?7
- +8 SET K=0
- KILL DG401
- +9 DO PTFICD^DGPTFUT(401,D0,I,.DG401,1)
- +10 FOR
- SET K=$ORDER(DG401(K))
- if 'K
- QUIT
- Begin DoDot:1
- +11 SET L=$PIECE(DG401(K),U,1)
- SET DGPTTMP=""
- +12 IF L'=""
- SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+L,EFFDATE)
- Begin DoDot:2
- +13 DO WRITECOD^DGPTIC10("PROC",+L,EFFDATE,2,1,8)
- +14 WRITE $SELECT(+DGPTTMP<1!('$PIECE(DGPTTMP,U,10)):"*",1:"")
- End DoDot:2
- End DoDot:1
- +15 KILL DG401
- +16 ;-- display expanded codes
- +17 SET DG300=$SELECT($DATA(^DGPT(D0,"S",I,300)):^(300),1:"")
- IF DG300]""
- DO PRN3^DGPTFM8
- +18 KILL DG300
- +19 QUIT
- PROC ;
- +1 SET DGF=""
- FOR I=1:1:5
- if $PIECE(DGOP1,U,I)'=""
- Begin DoDot:1
- +2 SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+$PIECE(DGOP1,U,I),EFFDATE)
- +3 if 'DGF
- WRITE !!?5,"Procedure: ",$$GETLABEL^DGPTIC10(EFFDATE,"P")
- SET DGF=1
- +4 DO WRITECOD^DGPTIC10("PROC",+$PIECE(DGOP1,U,I),EFFDATE,2,1,8)
- +5 WRITE $SELECT(+DGPTTMP<1!('$PIECE(DGPTTMP,U,10)):"*",1:"")
- End DoDot:1
- +6 QUIT
- 601 ;print the procedures/dates from the 601 procedure multiple (eff. 10/1/87)
- +1 KILL DG601
- SET J=0
- +2 DO PTFICD^DGPTFUT(601,D0,I,.DG601,1)
- +3 FOR
- SET J=$ORDER(DG601(J))
- if 'J
- QUIT
- Begin DoDot:1
- +4 SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+$PIECE(DG601(J),U,1),EFFDATE)
- +5 DO WRITECOD^DGPTIC10("PROC",+$PIECE(DG601(J),U,1),EFFDATE,2,1,8)
- +6 WRITE $SELECT(+DGPTTMP<1!('$PIECE(DGPTTMP,U,10)):"*",1:"")
- End DoDot:1
- +7 KILL DG601
- +8 QUIT
- DXLS ;
- +1 NEW DGIDTS
- +2 if $Y>(IOSL-16)
- DO HEAD
- +3 ;POA for principal DX
- SET DGPOA1=$PIECE($GET(^DGPT(D0,82)),U,1)
- +4 IF +$PIECE(DGPT,U,10)
- Begin DoDot:1
- +5 SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$PIECE(DGPT,U,10),EFFDATE)
- SET DXLS=$SELECT(+DGPTTMP>0:$PIECE(DGPTTMP,U,2,99),1:"")
- +6 WRITE !!?5,"PRINCIPAL DIAGNOSIS: ",$$GETLABEL^DGPTIC10(EFFDATE,"D")
- +7 DO WRITECOD^DGPTIC10("DIAG",+$PIECE(DGPT,U,10),EFFDATE,2,1,8)
- +8 WRITE $SELECT(+DGPTTMP<1!('$PIECE(DGPTTMP,U,10)):"*",1:"")
- +9 ;not an ICD10 DX
- if $PIECE(DGPTTMP,U,20)'=30
- QUIT
- +10 ;show POA value
- WRITE " ["_$SELECT(DGPOA1]"":DGPOA1,1:" ")_"]"
- End DoDot:1
- +11 ;
- +12 IF +$PIECE(DGPT,U,11)
- Begin DoDot:1
- +13 SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$PIECE(DGPT,U,11),EFFDATE)
- +14 DO WRITECOD^DGPTIC10("DIAG",+$PIECE(DGPT,U,11),EFFDATE,2,1,8)
- +15 WRITE $SELECT(+DGPTTMP<1!('$PIECE(DGPTTMP,U,10)):"*",1:"")
- +16 ;not an ICD10 DX
- if $PIECE(DGPTTMP,U,20)'=30
- QUIT
- +17 ;show POA value. there shouldn't be one for old records
- WRITE " ["_$SELECT(DGPOA1]"":DGPOA1,1:" ")_"]"
- End DoDot:1
- +18 KILL DG701,DGPOA1
- SET K=0
- +19 DO PTFICD^DGPTFUT(701,D0,,.DG701,1)
- +20 FOR
- SET K=$ORDER(DG701(K))
- if 'K
- QUIT
- if $PIECE(DG701(K),U,1)>0
- DO DSP
- +21 KILL DG701
- +22 ;-- display expanded code information
- +23 SET DG300=$SELECT($DATA(^DGPT(D0,300)):^(300),1:"")
- if DG300]""
- DO PRN2^DGPTFM8
- KILL DG300
- +24 ;calls ^DGPTFD to get DX/OP codes and then calls DGPTICD to calculate & store DRG value in PTF CLOSE OUT (#45.84) file.
- DO EN2^DGPTF4
- +25 ; display initial date of service DG*5.3*1057
- +26 SET DGIDTS=+$PIECE(^DGPT(D0,0),U,14)
- IF DGIDTS>0
- Begin DoDot:1
- +27 WRITE !,"*Initial Date Of Service: "_$$EXTERNAL^DILFD(45,14,,$GET(DGIDTS))
- +28 WRITE !," *Utilize section 1 on the 101 screen for editing."
- +29 QUIT
- End DoDot:1
- +30 ;
- +31 QUIT
- Q QUIT
- Q1 KILL ^UTILITY(U,$JOB),DG1
- +1 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 ;
- +1 SET J=$$ICDDATA^ICDXCODE("DIAG",+$PIECE(DG701(K),U,1),EFFDATE)
- Begin DoDot:1
- +2 DO WRITECOD^DGPTIC10("DIAG",+$PIECE(DG701(K),U,1),EFFDATE,2,1,8)
- +3 WRITE $SELECT(+J<1!('$PIECE(J,U,10)):"*",1:"")
- +4 ;not an ICD-10 DX
- if $PIECE(J,U,20)'=30
- QUIT
- +5 WRITE " ["_$SELECT($PIECE(DG701(K),U,2)]"":$PIECE(DG701(K),U,2),1:" ")_"]"
- End DoDot:1
- +6 QUIT