DGPTFM.m

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"))