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 Dec 13, 2024@02:52:28 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
