DGPTFM ;ALB/MTC - PTF OP-PRO-DIAG ;7/22/05 9:18am
;;5.3;PIMS;**510,517,590,594,606,635,683,696,1015,1016**;JUN 30, 2012;Build 20
K M,S,M1,M2,M3,S1,S2,PS2,SDCLY,^TMP("PTF",$J)
GET S I=0 F I1=1:1 S I=$O(^DGPT(PTF,"M",I)) Q:'I S (M3(I1),M(I1))=^(I,0) I $D(^DGPT(PTF,"M",I,"P")) S $P(M(I1),U,20)=^("P")
K MT D ORDER^DGPTF K MT D GETVAR^DGPTFM6,CL^SDCO21(DFN,$P(^DGPT(PTF,0),U,2),"",.SDCLY),MOB^DGPTFM2
S DGPC=I1-1 D WR K M1,M2,^UTILITY($J) S ST=1,M2=0
DIAG K DGZSER,DGZPRO,DGZSUR S DGZDIAG=1 F J=ST:2:PM S NL=1,L5=0,L6=J D WD2 S L5=1,L6=J+1 D:$D(M(L6)) WD2 D WD G PRO1:$Y>16 D WD3^DGPTFM8 G PRO1:$Y>16 W !
S ST=1 G SER
WD F J1=1:1:11 I J1'=6 S L=$P(M(J),U,J1+4),L1=0,L3=1 D:+L WD1 S L1=1,L=$S($D(M(J+1)):$P(M(J+1),U,J1+4),1:"") D:+L WD1
Q
WD1 S N=$$ICDDX^ICDCODE(+L,$$GETDATE^ICDGTDRG(PTF)),L2=$S(N:$P(N,U,2,99),1:""),M2=M2+1,L4=$P(L2,"^",1),L4=L4_$E(" ",1,3-$L($P(L4,".",2)))
W:L3 ! S:L3 L3=0 W ?L1*40,$J(M2,3)," ",$J(L4,7)," ",$E($P(L2,U,3),1,25) K ^UTILITY($J,"M2",M2) S ^UTILITY($J,"M2",M2)=+M(J+L1)_U_J1 Q
WD2 N Z3
X:NL "W ! S NL=0" W ?L5*40,"Move #",+L6 S Z=M(L6),Z3=M3(L6) W:+Z=1 " D/C" S Y=$P(Z,U,10)\1 D D^DGPTUTL W " ",Y," "
W " <",$S($P(Z3,U,18)=1:"",1:"N"),"SC"_$S($P(Z3,U,26)="Y":",AO",1:"")_$S($P(Z3,U,27)="Y":",IR",1:"")_$S($P(Z3,U,28)="Y":",SWAC",1:"")_$S($P(Z3,U,32)="Y":",SHAD",1:"")_">"
I $D(^DIC(42.4,+$P(Z,U,2),0)) D
. I $P(^DIC(42.4,+$P(Z,U,2),0),U,2)'="" W $E($P(^DIC(42.4,+$P(Z,U,2),0),U,2),1,10)
. E W $E($P(^(0),U,1),1,10)
Q
NDG D WR S I=0 K M,M1,M2 S M2=0 F I1=1:1 S I=$O(^DGPT(PTF,"M",I)) Q:I'>0 S M(I1)=^(I,0)
S PM=I1-1 D ORDER^DGPTF K MT G DIAG:$D(ST) G GET S ST=1
SER K DGZDIAG,DGZPRO,DGZSUR S DGZSER=1 G PRO1:$Y>19 K S1,S2 S S2=0 G SERV:ST G PRO
SERV F J=ST:2:SU S NL=1,L5=0,L6=J D SD2 S L5=1,L6=J+1 D:$D(S(L6)) SD2 D SD G PRO1:$Y>11 D SD3^DGPTFM8 G PRO1:$Y>11 W !
G PRC^DGPTFM0
SD F J1=1:1:5 S L=$P(S(J),U,J1+7),L1=0,L3=1 D:+L SD1 S L1=1,L=$S($D(S(J+1)):$P(S(J+1),U,J1+7),1:"") D:+L SD1
Q
SD1 S N=$$ICDOP^ICDCODE(+L,$$GETDATE^ICDGTDRG(PTF)),L2=$S(N:$P(N,U,2,99),1:""),S2=S2+1,L4=$P(L2,"^",1),L4=L4_$E(" ",1,3-$L($P(L4,".",2)))
W:L3 ! S:L3 L3=0 W ?L1*40,$J(S2,3)," ",$J(L4,7)," ",$E($P(L2,U,4),1,25) K S2(S2) S S2(S2)=J+L1_U_J1 Q
SD2 S Y=+S(L6) D D^DGPTUTL W:NL ! S:NL NL=0 W ?L5*40,L6,"-Surgery date: ",Y
Q
NSR K S,S1,S2 S I=0 F I1=1:1 S I=$O(^DGPT(PTF,"S",I)) Q:I'>0 S S(I1)=^(I,0),S(I1,1)=I
S S2=0,SU=I1-1 D WR G SERV
;
WR W @IOF,HEAD,?70 S Z="<MAS>" D Z Q
PRO K DGZSER,DGZDIAG,DGZSUR S DGZPRO=1 G PRO1:$Y>14 K P1,P2 S ST=1,P2=0 G NPR:'$D(PROC)
PROC D:$Y>14 WR W:PROC]"" !!,"Procedures: ",!
F J1=1:1:5 S L=$P(PROC,"^",J1) I L'="" S P2=P2+1,N=$$ICDOP^ICDCODE(+L,$$GETDATE^ICDGTDRG(PTF)),L2=$S(N:$P(N,U,2,99),1:""),L4=$P(L2,U,1),L4=L4_$E(" ",1,3-$L($P(L4,".",2))) D
.W:$X>5 ?40 W $J(P2,3)," ",$J(L4,7)," ",$E($P(L2,"^",4),1,25) K P2(P2) S P2(P2)=J1 W:$X>45 !
K DGZSER,DGZPRO,DGZDIAG,DGZSUR
ENC G PRO1:$Y>7,PRO1:'$P(DGZPRF,U,3)
PF S PS2=0,J=+DGZPRF,Y=+DGZPRF(J),DGSTRT=$S(+$P(DGZPRF,U,4):$P(DGZPRF,U,4),1:4),DGLST=0
D CL^SDCO21(DFN,+DGZPRF(J),"",.SDCLY),ICDINFO^DGAPI(DFN,PTF),XREF^DGPTFM21 ; load SCI info and DGN's for this service date
D D^DGPTUTL W !,J,"-CPT Capture Date/Time: ",Y W:($P(DGZPRF,U,2)-1!($G(PGBRK))) " (cont.)"
I $P(DGZPRF(J),U,2) W !,?5,"Referring or Ordering Provider: " S L=$P(DGZPRF(J),U,2) D PRV
W !,?5,"Rendering Provider: " S L=$P(DGZPRF(J),U,3) D PRV
I $P(DGZPRF(J),U,5) W !,?5,"Rendering Location: ",$P($G(^SC($P(DGZPRF(J),U,5),0)),U)
S (L1,PGBRK)=0
F K=$P(DGZPRF,U,2):1 Q:'$D(DGZPRF(J,K)) I '$G(DGZPRF(J,K,9)) S PS2=PS2+1 W !,?2,PS2," " D CPT^DGPTUTL1 D Q:$Y+$G(DGZPRF(J,K+1,1))>16!($G(PGBRK))
. W !,?4 S $P(DS,"-",27)="" W DS," Related Diagnosis ",DS
. F L1=DGSTRT:1:11 S DGLOC=$S(L1<8:L1,1:L1+7),CD=$P(DGZPRF(J,K),U,DGLOC) I CD D I $Y+$G(CKSCI)>16 S PGBRK=1 Q
. . S N=$$ICDDX^ICDCODE(CD,$$GETDATE^ICDGTDRG(PTF)),N=$S(N:$P(N,U,2,99),1:"")
. . S CD=$P(N,U) W !,?8,CD," ",$P(N,U,3)
. . D CKSCI($P(DGZPRF(J,K),U,DGLOC))
. S PS2(PS2)=J_U_K,CD=1,DGLOC=0,DGSTRT=4
I L1'=11,$S(L1<8:$P($G(DGZPRF(J,K)),U,L1+1,7),1:"")_$P($G(DGZPRF(J,K)),U,$S(L1<8:15,1:L1+8),18)?."^" S L1=11
I L1=11 S $P(DGZPRF,U,1,2)=$S($D(DGZPRF(J,K+1)):J_U_(K+1),1:J+1_U_1),$P(DGZPRF,U,4)="",PGBRK=0
E S $P(DGZPRF,U,1,2)=J_U_K,$P(DGZPRF,U,4)=L1+1
;I '$D(DGZPRF(J,K+1)) S $P(DGZPRF,U,1,2)=$S($P($G(DGZPRF(J,K)),U,NXTDGN)'="":J,1:J+1)_U_1,$P(DGZPRF,U,4)=DGLST
;I $D(DGZPRF(J,K+1)) S $P(DGZPRF,U,1,2)=J_U_(K+1)
K I,K,L,L1,CD,N G PRO1
;
CKSCI(IEN) ;print SCI for each Diagnosis code
N DGINFO Q:'$D(XREF(IEN))
S DGINFO=$G(^DGICD9(46.1,(XREF(IEN)),0)),CKSCI=0
I 'DGINFO Q
F I=3,7,1,2,4,5,6,8 I $D(SDCLY(I)) S L=$S(I=3:8,I<4:8+I,1:7+I) D
.W ?45 S M=1,CKSCI=CKSCI+1
.W $P("Treated for AO Condition^Treated for IR Condition^Treated for SC Condition^Exposed to SW Asia Conditions^Treatment for MST^Treatment for Head/Neck CA^Related to Combat^Treatment for SHAD Condition",U,I)
.W ":",$S($P(DGINFO,U,($S(I<3:I+2,I=3:2,1:I+1))):"YES",1:"NO"),!
Q ;CKSCI
;
NPR S ST=1,PROC=$S($D(^DGPT(PTF,"401P")):^("401P"),1:"") D WR G PRO
;
NPS D WR G PF
;
DONE G EN1^DGPTF4
PRO1 ;SET MENU TYPE AND DISPLAY MENU
N ICDVDT,ICPTVDT
S (ICDVDT,ICPTVDT)=$S($D(PTF):$$GETDATE^ICDGTDRG(PTF),1:DT)
S DGNUM=$S($D(DGZDIAG)!($D(DGZPRO))!($D(DGZSER))!($D(DGZSUR)!(+DGZPRF-1'=$P(DGZPRF,U,3))):"MAS",1:"701") G MAS^DGPTFJC:DGST F X=$Y:1:(IOSL-8) W !
W !! S Z="Patient Movements:" W Z S Z=" "_$S(DGPTFE:"M=Add PM X=Delete PM",1:"M=Edit Treat Spec/PM ")_" A=Add Code D=Delete Code V=Edit Mov" W Z
W ! S Z="Surgical Episodes:" W Z S Z=" S=Add SE Z=Delete SE O=Add Code C=Delete Code J=Edit SE" W Z
W ! S Z="Procedure Records:" W Z S Z=" T=Add PR R=Delete PR P=Add Code Q=Delete Code E=Edit PR" W Z
W ! S Z="801:" W Z S Z=" I=Add 801 Y=Delete 801 N=Add CPT G=Delete CPT F=Edit 801" W Z K Z
W !," ^=Abort <RET> to Continue:<",DGNUM,">// " R ANS:DTIME K DGNUM
A S Z="^C Delete Code^A Add Code^O Add Code^P Add NOP^S Add SE^D Delete Code^M Add PM^X Delete PM^Z Delete SE^J Edit SE^Q Delete NOP^V Edit Move^"
S Z=Z_"T Add PR^R Delete PR^E Edit PR^I Add 801^Y Delete 801^N Add CPT^G Delete CPT^F Edit 801"
I 'DGPTFE S $P(Z,U,8,9)="M Edit treat Spec/PM"
S X=ANS G Q^DGPTF:ANS="^" G ^DGPTFJ:ANS?1"^".E S (A,X)=ANS,X=$E(X,1) D IN^DGHELP
I $P(^DGPT(PTF,0),U,4),X'="","IYNGF"[X W !,"***WARNING: This is a Fee Basis PTF record*** 801 encounters are not allowed." H 3 G DGPTFM
I ANS="" S (ST,ST1)=J+2 D:$D(DGZSUR) WR G @($S($D(DGZDIAG):"NDG",$D(DGZSER):"NSR",$D(DGZPRO):"NPR",$D(DGZSUR):"EN^DGPTFM0",+DGZPRF-1'=$P(DGZPRF,U,3):"NPS",1:"DONE"))
G HELP^DGPTFM1A:%=-1 S Z=$L(A)-1 G @(X_$S(X="X":"",1:"^DGPTFM1"))
PRV I $D(^VA(200,L,0)) W $P(^(0),U) Q
W L Q
X ;
I 'Z S:PM=1 RC=1 G X1:PM=1 W !!,"Delete Patient move <1",$S(PM<3:"",1:"-"_(PM-1)),">: " R RC:DTIME G ^DGPTFM:RC["^"!(RC="")
E S RC=$E(A,2,99) W !
I +RC'=RC!('$D(M(RC))) W !!,"Enter the record # to delete from the PTF file, 1",$S(PM<3:"",1:"-"_(PM-1)) S Z=0 G X
X1 I +M(RC)=1 W !,*7,"Cannot delete discharge movement",! H 3 G ^DGPTFM
S DIE="^DGPT("_PTF_",""M"",",DP=45.02,DR=".01///@",DA(1)=PTF,DA=+M(RC) D ^DIE K DR W " ",RC,"-DELETED***" H 2 G ^DGPTFM
Z W @DGVI,Z,@DGVO Q
EN D WR G EN^DGPTFM0
DGPTFM ;ALB/MTC - PTF OP-PRO-DIAG ;7/22/05 9:18am
+1 ;;5.3;PIMS;**510,517,590,594,606,635,683,696,1015,1016**;JUN 30, 2012;Build 20
+2 KILL M,S,M1,M2,M3,S1,S2,PS2,SDCLY,^TMP("PTF",$JOB)
GET SET I=0
FOR I1=1:1
SET I=$ORDER(^DGPT(PTF,"M",I))
IF 'I
QUIT
SET (M3(I1),M(I1))=^(I,0)
IF $DATA(^DGPT(PTF,"M",I,"P"))
SET $PIECE(M(I1),U,20)=^("P")
+1 KILL MT
DO ORDER^DGPTF
KILL MT
DO GETVAR^DGPTFM6
DO CL^SDCO21(DFN,$PIECE(^DGPT(PTF,0),U,2),"",.SDCLY)
DO MOB^DGPTFM2
+2 SET DGPC=I1-1
DO WR
KILL M1,M2,^UTILITY($JOB)
SET ST=1
SET M2=0
DIAG KILL DGZSER,DGZPRO,DGZSUR
SET DGZDIAG=1
FOR J=ST:2:PM
SET NL=1
SET L5=0
SET L6=J
DO WD2
SET L5=1
SET L6=J+1
IF $DATA(M(L6))
DO WD2
DO WD
IF $Y>16
GOTO PRO1
DO WD3^DGPTFM8
IF $Y>16
GOTO PRO1
WRITE !
+1 SET ST=1
GOTO SER
WD FOR J1=1:1:11
IF J1'=6
SET L=$PIECE(M(J),U,J1+4)
SET L1=0
SET L3=1
IF +L
DO WD1
SET L1=1
SET L=$SELECT($DATA(M(J+1)):$PIECE(M(J+1),U,J1+4),1:"")
IF +L
DO WD1
+1 QUIT
WD1 SET N=$$ICDDX^ICDCODE(+L,$$GETDATE^ICDGTDRG(PTF))
SET L2=$SELECT(N:$PIECE(N,U,2,99),1:"")
SET M2=M2+1
SET L4=$PIECE(L2,"^",1)
SET L4=L4_$EXTRACT(" ",1,3-$LENGTH($PIECE(L4,".",2)))
+1 IF L3
WRITE !
IF L3
SET L3=0
WRITE ?L1*40,$JUSTIFY(M2,3)," ",$JUSTIFY(L4,7)," ",$EXTRACT($PIECE(L2,U,3),1,25)
KILL ^UTILITY($JOB,"M2",M2)
SET ^UTILITY($JOB,"M2",M2)=+M(J+L1)_U_J1
QUIT
WD2 NEW Z3
+1 IF NL
XECUTE "W ! S NL=0"
WRITE ?L5*40,"Move #",+L6
SET Z=M(L6)
SET Z3=M3(L6)
IF +Z=1
WRITE " D/C"
SET Y=$PIECE(Z,U,10)\1
DO D^DGPTUTL
WRITE " ",Y," "
+2 WRITE " <",$SELECT($PIECE(Z3,U,18)=1:"",1:"N"),"SC"_$SELECT($PIECE(Z3,U,26)="Y":",AO",1:"")_$SELECT($PIECE(Z3,U,27)="Y":",IR",1:"")_$SELECT($PIECE(Z3,U,28)="Y":",SWAC",1:"")_$SELECT($PIECE(Z3,U,32)="Y":",SHAD",1:"")_">"
+3 IF $DATA(^DIC(42.4,+$PIECE(Z,U,2),0))
Begin DoDot:1
+4 IF $PIECE(^DIC(42.4,+$PIECE(Z,U,2),0),U,2)'=""
WRITE $EXTRACT($PIECE(^DIC(42.4,+$PIECE(Z,U,2),0),U,2),1,10)
+5 IF '$TEST
WRITE $EXTRACT($PIECE(^(0),U,1),1,10)
End DoDot:1
+6 QUIT
NDG DO WR
SET I=0
KILL M,M1,M2
SET M2=0
FOR I1=1:1
SET I=$ORDER(^DGPT(PTF,"M",I))
IF I'>0
QUIT
SET M(I1)=^(I,0)
+1 SET PM=I1-1
DO ORDER^DGPTF
KILL MT
IF $DATA(ST)
GOTO DIAG
GOTO GET
SET ST=1
SER KILL DGZDIAG,DGZPRO,DGZSUR
SET DGZSER=1
IF $Y>19
GOTO PRO1
KILL S1,S2
SET S2=0
IF ST
GOTO SERV
GOTO PRO
SERV FOR J=ST:2:SU
SET NL=1
SET L5=0
SET L6=J
DO SD2
SET L5=1
SET L6=J+1
IF $DATA(S(L6))
DO SD2
DO SD
IF $Y>11
GOTO PRO1
DO SD3^DGPTFM8
IF $Y>11
GOTO PRO1
WRITE !
+1 GOTO PRC^DGPTFM0
SD FOR J1=1:1:5
SET L=$PIECE(S(J),U,J1+7)
SET L1=0
SET L3=1
IF +L
DO SD1
SET L1=1
SET L=$SELECT($DATA(S(J+1)):$PIECE(S(J+1),U,J1+7),1:"")
IF +L
DO SD1
+1 QUIT
SD1 SET N=$$ICDOP^ICDCODE(+L,$$GETDATE^ICDGTDRG(PTF))
SET L2=$SELECT(N:$PIECE(N,U,2,99),1:"")
SET S2=S2+1
SET L4=$PIECE(L2,"^",1)
SET L4=L4_$EXTRACT(" ",1,3-$LENGTH($PIECE(L4,".",2)))
+1 IF L3
WRITE !
IF L3
SET L3=0
WRITE ?L1*40,$JUSTIFY(S2,3)," ",$JUSTIFY(L4,7)," ",$EXTRACT($PIECE(L2,U,4),1,25)
KILL S2(S2)
SET S2(S2)=J+L1_U_J1
QUIT
SD2 SET Y=+S(L6)
DO D^DGPTUTL
IF NL
WRITE !
IF NL
SET NL=0
WRITE ?L5*40,L6,"-Surgery date: ",Y
+1 QUIT
NSR KILL S,S1,S2
SET I=0
FOR I1=1:1
SET I=$ORDER(^DGPT(PTF,"S",I))
IF I'>0
QUIT
SET S(I1)=^(I,0)
SET S(I1,1)=I
+1 SET S2=0
SET SU=I1-1
DO WR
GOTO SERV
+2 ;
WR WRITE @IOF,HEAD,?70
SET Z="<MAS>"
DO Z
QUIT
PRO KILL DGZSER,DGZDIAG,DGZSUR
SET DGZPRO=1
IF $Y>14
GOTO PRO1
KILL P1,P2
SET ST=1
SET P2=0
IF '$DATA(PROC)
GOTO NPR
PROC IF $Y>14
DO WR
IF PROC]""
WRITE !!,"Procedures: ",!
+1 FOR J1=1:1:5
SET L=$PIECE(PROC,"^",J1)
IF L'=""
SET P2=P2+1
SET N=$$ICDOP^ICDCODE(+L,$$GETDATE^ICDGTDRG(PTF))
SET L2=$SELECT(N:$PIECE(N,U,2,99),1:"")
SET L4=$PIECE(L2,U,1)
SET L4=L4_$EXTRACT(" ",1,3-$LENGTH($PIECE(L4,".",2)))
Begin DoDot:1
+2 IF $X>5
WRITE ?40
WRITE $JUSTIFY(P2,3)," ",$JUSTIFY(L4,7)," ",$EXTRACT($PIECE(L2,"^",4),1,25)
KILL P2(P2)
SET P2(P2)=J1
IF $X>45
WRITE !
End DoDot:1
+3 KILL DGZSER,DGZPRO,DGZDIAG,DGZSUR
ENC IF $Y>7
GOTO PRO1
IF '$PIECE(DGZPRF,U,3)
GOTO PRO1
PF SET PS2=0
SET J=+DGZPRF
SET Y=+DGZPRF(J)
SET DGSTRT=$SELECT(+$PIECE(DGZPRF,U,4):$PIECE(DGZPRF,U,4),1:4)
SET DGLST=0
+1 ; load SCI info and DGN's for this service date
DO CL^SDCO21(DFN,+DGZPRF(J),"",.SDCLY)
DO ICDINFO^DGAPI(DFN,PTF)
DO XREF^DGPTFM21
+2 DO D^DGPTUTL
WRITE !,J,"-CPT Capture Date/Time: ",Y
IF ($PIECE(DGZPRF,U,2)-1!($GET(PGBRK)))
WRITE " (cont.)"
+3 IF $PIECE(DGZPRF(J),U,2)
WRITE !,?5,"Referring or Ordering Provider: "
SET L=$PIECE(DGZPRF(J),U,2)
DO PRV
+4 WRITE !,?5,"Rendering Provider: "
SET L=$PIECE(DGZPRF(J),U,3)
DO PRV
+5 IF $PIECE(DGZPRF(J),U,5)
WRITE !,?5,"Rendering Location: ",$PIECE($GET(^SC($PIECE(DGZPRF(J),U,5),0)),U)
+6 SET (L1,PGBRK)=0
+7 FOR K=$PIECE(DGZPRF,U,2):1
IF '$DATA(DGZPRF(J,K))
QUIT
IF '$GET(DGZPRF(J,K,9))
SET PS2=PS2+1
WRITE !,?2,PS2," "
DO CPT^DGPTUTL1
Begin DoDot:1
+8 WRITE !,?4
SET $PIECE(DS,"-",27)=""
WRITE DS," Related Diagnosis ",DS
+9 FOR L1=DGSTRT:1:11
SET DGLOC=$SELECT(L1<8:L1,1:L1+7)
SET CD=$PIECE(DGZPRF(J,K),U,DGLOC)
IF CD
Begin DoDot:2
+10 SET N=$$ICDDX^ICDCODE(CD,$$GETDATE^ICDGTDRG(PTF))
SET N=$SELECT(N:$PIECE(N,U,2,99),1:"")
+11 SET CD=$PIECE(N,U)
WRITE !,?8,CD," ",$PIECE(N,U,3)
+12 DO CKSCI($PIECE(DGZPRF(J,K),U,DGLOC))
End DoDot:2
IF $Y+$GET(CKSCI)>16
SET PGBRK=1
QUIT
+13 SET PS2(PS2)=J_U_K
SET CD=1
SET DGLOC=0
SET DGSTRT=4
End DoDot:1
IF $Y+$GET">GET(DGZPRF(J,K+1,1))>16!($GET">GET(PGBRK))
QUIT
+14 IF L1'=11
IF $SELECT(L1<8:$PIECE($GET">GET(DGZPRF(J,K)),U,L1+1,7),1:"")_$PIECE($GET">GET(DGZPRF(J,K)),U,$SELECT(L1<8:15,1:L1+8),18)?."^"
SET L1=11
+15 IF L1=11
SET $PIECE(DGZPRF,U,1,2)=$SELECT($DATA(DGZPRF(J,K+1)):J_U_(K+1),1:J+1_U_1)
SET $PIECE(DGZPRF,U,4)=""
SET PGBRK=0
+16 IF '$TEST
SET $PIECE(DGZPRF,U,1,2)=J_U_K
SET $PIECE(DGZPRF,U,4)=L1+1
+17 ;I '$D(DGZPRF(J,K+1)) S $P(DGZPRF,U,1,2)=$S($P($G(DGZPRF(J,K)),U,NXTDGN)'="":J,1:J+1)_U_1,$P(DGZPRF,U,4)=DGLST
+18 ;I $D(DGZPRF(J,K+1)) S $P(DGZPRF,U,1,2)=J_U_(K+1)
+19 KILL I,K,L,L1,CD,N
GOTO PRO1
+20 ;
CKSCI(IEN) ;print SCI for each Diagnosis code
+1 NEW DGINFO
IF '$DATA(XREF(IEN))
QUIT
+2 SET DGINFO=$GET(^DGICD9(46.1,(XREF(IEN)),0))
SET CKSCI=0
+3 IF 'DGINFO
QUIT
+4 FOR I=3,7,1,2,4,5,6,8
IF $DATA(SDCLY(I))
SET L=$SELECT(I=3:8,I<4:8+I,1:7+I)
Begin DoDot:1
+5 WRITE ?45
SET M=1
SET CKSCI=CKSCI+1
+6 WRITE $PIECE("Treated for AO Condition^Treated for IR Condition^Treated for SC Condition^Exposed to SW Asia Conditions^Treatment for MST^Treatment for Head/Neck CA^Related to Combat^Treatment for SHAD Condition",U,I)
+7 WRITE ":",$SELECT($PIECE(DGINFO,U,($SELECT(I<3:I+2,I=3:2,1:I+1))):"YES",1:"NO"),!
End DoDot:1
+8 ;CKSCI
QUIT
+9 ;
NPR SET ST=1
SET PROC=$SELECT($DATA(^DGPT(PTF,"401P")):^("401P"),1:"")
DO WR
GOTO PRO
+1 ;
NPS DO WR
GOTO PF
+1 ;
DONE GOTO EN1^DGPTF4
PRO1 ;SET MENU TYPE AND DISPLAY MENU
+1 NEW ICDVDT,ICPTVDT
+2 SET (ICDVDT,ICPTVDT)=$SELECT($DATA(PTF):$$GETDATE^ICDGTDRG(PTF),1:DT)
+3 SET DGNUM=$SELECT($DATA(DGZDIAG)!($DATA(DGZPRO))!($DATA(DGZSER))!($DATA(DGZSUR)!(+DGZPRF-1'=$PIECE(DGZPRF,U,3))):"MAS",1:"701")
IF DGST
GOTO MAS^DGPTFJC
FOR X=$Y:1:(IOSL-8)
WRITE !
+4 WRITE !!
SET Z="Patient Movements:"
WRITE Z
SET Z=" "_$SELECT(DGPTFE:"M=Add PM X=Delete PM",1:"M=Edit Treat Spec/PM ")_" A=Add Code D=Delete Code V=Edit Mov"
WRITE Z
+5 WRITE !
SET Z="Surgical Episodes:"
WRITE Z
SET Z=" S=Add SE Z=Delete SE O=Add Code C=Delete Code J=Edit SE"
WRITE Z
+6 WRITE !
SET Z="Procedure Records:"
WRITE Z
SET Z=" T=Add PR R=Delete PR P=Add Code Q=Delete Code E=Edit PR"
WRITE Z
+7 WRITE !
SET Z="801:"
WRITE Z
SET Z=" I=Add 801 Y=Delete 801 N=Add CPT G=Delete CPT F=Edit 801"
WRITE Z
KILL Z
+8 WRITE !," ^=Abort <RET> to Continue:<",DGNUM,">// "
READ ANS:DTIME
KILL DGNUM
A SET Z="^C Delete Code^A Add Code^O Add Code^P Add NOP^S Add SE^D Delete Code^M Add PM^X Delete PM^Z Delete SE^J Edit SE^Q Delete NOP^V Edit Move^"
+1 SET Z=Z_"T Add PR^R Delete PR^E Edit PR^I Add 801^Y Delete 801^N Add CPT^G Delete CPT^F Edit 801"
+2 IF 'DGPTFE
SET $PIECE(Z,U,8,9)="M Edit treat Spec/PM"
+3 SET X=ANS
IF ANS="^"
GOTO Q^DGPTF
IF ANS?1"^".E
GOTO ^DGPTFJ
SET (A,X)=ANS
SET X=$EXTRACT(X,1)
DO IN^DGHELP
+4 IF $PIECE(^DGPT(PTF,0),U,4)
IF X'=""
IF "IYNGF"[X
WRITE !,"***WARNING: This is a Fee Basis PTF record*** 801 encounters are not allowed."
HANG 3
GOTO DGPTFM
+5 IF ANS=""
SET (ST,ST1)=J+2
IF $DATA(DGZSUR)
DO WR
GOTO @($SELECT($DATA(DGZDIAG):"NDG",$DATA(DGZSER):"NSR",$DATA(DGZPRO):"NPR",$DATA(DGZSUR):"EN^DGPTFM0",+DGZPRF-1'=$PIECE(DGZPRF,U,3):"NPS",1:"DONE"))
+6 IF %=-1
GOTO HELP^DGPTFM1A
SET Z=$LENGTH(A)-1
GOTO @(X_$SELECT(X="X":"",1:"^DGPTFM1"))
PRV IF $DATA(^VA(200,L,0))
WRITE $PIECE(^(0),U)
QUIT
+1 WRITE L
QUIT
X ;
+1 IF 'Z
IF PM=1
SET RC=1
IF PM=1
GOTO X1
WRITE !!,"Delete Patient move <1",$SELECT(PM<3:"",1:"-"_(PM-1)),">: "
READ RC:DTIME
IF RC["^"!(RC="")
GOTO ^DGPTFM
+2 IF '$TEST
SET RC=$EXTRACT(A,2,99)
WRITE !
+3 IF +RC'=RC!('$DATA(M(RC)))
WRITE !!,"Enter the record # to delete from the PTF file, 1",$SELECT(PM<3:"",1:"-"_(PM-1))
SET Z=0
GOTO X
X1 IF +M(RC)=1
WRITE !,*7,"Cannot delete discharge movement",!
HANG 3
GOTO ^DGPTFM
+1 SET DIE="^DGPT("_PTF_",""M"","
SET DP=45.02
SET DR=".01///@"
SET DA(1)=PTF
SET DA=+M(RC)
DO ^DIE
KILL DR
WRITE " ",RC,"-DELETED***"
HANG 2
GOTO ^DGPTFM
Z WRITE @DGVI,Z,@DGVO
QUIT
EN DO WR
GOTO EN^DGPTFM0
