DGPTFM4.m

DGPTFM4 ;ALB/MTC/ADL/PLT - PTF ENTRY/EDIT-2 ;12/18/07 11:37am

 ;;5.3;Registration;**114,195,397,510,565,775,664,759,850,884,1104**;Aug 13, 1993;Build 59

 ;;Per VA Directive 6402, this routine should not be modified.

 ; Reference to $$DRGD^ICDGTDRG in ICR #4052

 ; Reference to DIS^EASECU in ICR #6771

 ; Reference to $$DISPLAY^PXCOMPACT in ICR #7327

 ;;ADL;Update for CSV Project;;Mar 26, 2003

 ;

 S DGZM0=DGZM0+1

EN ;

 N M3,M82,DGMPOA

 D MOB:'$D(M)

 S M(DGZM0)=$S($D(M(DGZM0)):M(DGZM0),1:"") G NEXM:M(DGZM0)=""

 S (M3,M(DGZM0),M1)=$S($D(^DGPT(PTF,"M",+M(DGZM0),0)):^DGPT(PTF,"M",+M(DGZM0),0),1:"")

 S M82=$G(^DGPT(PTF,"M",+M(DGZM0),82))

 I $D(^DGPT(PTF,"M",+M(DGZM0),"P")) S $P(M(DGZM0),U,20)=^("P"),$P(M1,U,20)=^("P")

WR S DG300=$S($D(^DGPT(PTF,"M",+M(DGZM0),300)):^(300),1:"")

 W @IOF,HEAD,?70 S Z="<501-"_DGZM0_">" D Z^DGPTFM I +M(DGZM0)=1 W !,?62,"Discharge Movement"

M S L=+$P(M1,U,10),Y=L D D^DGPTUTL W !! S Z=1 D Z W "Date of Move: " S Z=Y,Z1=20 D Z1 W "Losing Specialty: ",$E($S($D(^DIC(42.4,+$P(M1,U,2),0)):$P(^(0),U,1),1:""),1,25)

 W !,"     Leave days: ",$P(M1,U,3),?44,"Pass days: ",$P(M1,U,4)

 W !,"Treated for SC Condition: ",$S($P(M3,U,18)=1:"Yes",1:"No")

 W !,"Treated for Acute Suicidal Crisis: ",$S($P(^DGPT(PTF,"M",+M(DGZM0),0),"^",33)="Y":"Yes",1:"No")

 ;check for COMPACT Act information

 N DISPLAY

 S DISPLAY=$$DISPLAY^PXCOMPACT(DFN)

 ;DISPLAY will contain one of the following groups of information:

 ;  If end date exists (episode has ended) and there are no extensions,

 ;     "COMPACT Act Start Date"^EPISODE START DATE^"End Date"^EPISODE END DATE^"IP Benefit End Date"^INPATIENT BENEFIT END DATE^"OP Benefit end date"^OUTPATIENT BENEFIT END DATE

 ;  If end date exists (episode has ended) and an extension exists,

 ;     "Extension Start Date"^EXTENSION START DATE^"Episode End Date"^EPISODE END DATE

 ;  If end date does not exist (episode is ongoing) and there are no extensions,

 ;     For an inpatient with an INPATIENT BENEFIT END DATE,

 ;         "COMPACT Act Start Date"^EPISODE START DATE^"Remaining Days"^REMAINING INPATIENT DAYS^"Inpatient Benefit End Date"^INPATIENT BENEFIT END DATE

 ;     Otherwise,

 ;         "COMPACT Act Start Date"^EPISODE START DATE^"Remaining Days"^REMAINING INPATIENT DAYS or REMAINING OUTPATIENT DAYS

 ;  If end date does not exist (episode is ongoing) and an extension exists,

 ;     "Extension Start Date"^EXTENSION START DATE^"Remaining Days"^REMAINING INPATIENT DAYS or REMAINING OUTPATIENT DAYS

 ;

 I $P(DISPLAY,U)="COMPACT Act Start Date" W ?42,"COMPACT Start Date: ",$P(DISPLAY,U,2)

 I $P(DISPLAY,U)="Extension Start Date" W ?40,"Extension Start Date: ",$P(DISPLAY,U,2)

 I $P(DISPLAY,U,3)["End Date" W !,"                                            COMPACT End Date: ",$S($P(DISPLAY,U,6)]"":$P(DISPLAY,U,6),1:$P(DISPLAY,U,4))

 I $P(DISPLAY,U,3)="Remaining Days" W !,"                                              Remaining Days: ",$P(DISPLAY,U,4)

 N NL S NL=1 ; Changed from 0 to accommodate new COMPACT line

 I $P(M3,U,31)'="" W @($S(NL#2:"!",1:"?37")),"Potentially Related to Combat: ",$S($P(M3,U,31)="Y":"Yes",1:"No") S NL=NL+1

 I $P(M3,U,26)'="" W @($S(NL#2:"!",1:"?37")),"Treated for AO Condition: ",$S($P(M3,U,26)="Y":"Yes",1:"No") S NL=NL+1

 I $P(M3,U,27)'="" W @($S(NL#2:"!",1:"?37")),"Treated for IR Condition: ",$S($P(M3,U,27)="Y":"Yes",1:"No") S NL=NL+1

 I $P(M3,U,28)'="" W @($S(NL#2:"!",1:"?37")),"Treated for service in SW Asia: ",$S($P(M3,U,28)="Y":"Yes",1:"No") S NL=NL+1

 I $P(M3,U,29)'="" W @($S(NL#2:"!",1:"?37")),"Treated for MST Condition: ",$S($P(M3,U,29)="Y":"Yes",1:"No") S NL=NL+1

 K DGNTARR

 S DGNTARR=$$GETCUR^DGNTAPI(DFN,"DGNTARR")

 I $P(M3,U,30)="",(",3,4,5,"[(","_$P($G(DGNTARR("STAT")),U)_",")) S $P(M3,U,30)="N"

 I $P(M3,U,30)'="" W @($S(NL#2:"!",1:"?37")),"Treated for HEAD/NECK CA Condition: ",$S($P(M3,U,30)="Y":"Yes",1:"No") S NL=NL+1

 I $P(M3,U,32)'="" W @($S(NL#2:"!",1:"?37")),"Treated for Project 112/SHAD: ",$S($P(M3,U,32)="Y":"Yes",1:"No")

 K NL

 N EFFDATE,IMPDATE

 D EFFDATE^DGPTIC10(PTF)

 W !! S Z=2 D Z W "          DX: ",$$GETLABEL^DGPTIC10(EFFDATE,"D")

 ;F I=1:1:11 S L=$P(M1,U,I+4) I L'=""&(I'=6) D

 D PTFICD^DGPTFUT(501,PTF,+M(DGZM0),.DGX501)

 S I=0 F  S I=$O(DGX501(I)) QUIT:'I  S L=DGX501(I) D

 . S DGMPOA=$P(L,U,2)

 . S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+L,EFFDATE)

 . D WRITECOD^DGPTIC10("DIAG",+L,EFFDATE,2,1,15)

 . I $P(DGPTTMP,U,20)=30 W:$X>73 !,"            " W " (POA=",$S(DGMPOA]"":DGMPOA,1:"''"),")"

 . W $S(+DGPTTMP<1!('$P(DGPTTMP,U,10)):"*",1:"")

 . I $Y>(IOSL-4) D PGBR W @IOF,HEAD,?72 S Z="<501-"_DGZM0_">" D Z^DGPTFM W !

 . QUIT

 K DGX501

 D PRN2^DGPTFM8:DG300]""

 ;

 I $P(M1,U,20) S DRG=$P(M1,U,20) W:DRG=998!(DRG=999)!((DRG=468!(DRG=469)!(DRG=470))&(+$P($G(M1),U,10)<3071001)) *7 W !!?14,"TRANSFER DRG: ",DRG D

 . N DXD,DGDX

 . S DXD=$$DRGD^ICDGTDRG(DRG,"DGDX",,$P(M1,U,10)),DGDS=0

 . F  S DGDS=$O(DGDX(DGDS)) Q:'+DGDS  Q:DGDX(DGDS)=" "  W !,DGDX(DGDS)

JUMP K DG300 F I=$Y:1:21 W !

X S DGNUM=$S($D(M(DGZM0+1)):501_"-"_(DGZM0+1),1:"MAS") G 501^DGPTFJC:DGST

 W "Enter <RET> to continue, 1-2 to edit,",!,"'M' ",$S(DGPTFE:" to add a patient movement",1:"to edit Treat. Specialty"),", '^N' for screen N, or '^' to abort:<",DGNUM,">// " R X:DTIME

 K DGNUM G Q:X="^",NEXM:X="",^DGPTFJ:X?1"^".E,M^DGPTFM1:X="M"!(X="m")

X1 I X'=1,X'=2,X'="1-2" G PR

 S DGCODSYS=$$CODESYS^DGPTIC10(PTF)

 S DR=$S(DGPTFE:"[DG501F-10D]",1:"[DG501-10D]") I DGCODSYS="ICD9" S DR=$S(DGPTFE:"[DG501F]",1:"[DG501]")

 S DGJUMP=X,DIE="^DGPT(",(DA,DGPTF)=PTF,DGMOV=+M(DGZM0) D ^DIE

 I DR'["-10D" K DR,DA,DIE,DIC S DR="" X:(+M(DGZM0)=1) "S J=^DGPT(PTF,""M"",1,0) F I=11:1:15 I $P(J,U,I) S DR=DR_I_"";""" I DR'="" D

 . S DGJUMP=X,DIE="^DGPT("_DGPTF_",""M"",",(DA(1),DGPTF)=PTF,(DA,DGMOV)=+M(DGZM0)

 . D ^DIE

 . QUIT

 K M,DR,DIE D CHK501^DGPTSCAN K DGPTF,DGMOV

 ; Determine if NTR HISTORY (#28.11) filer is called if question for

 ;  'Treated for Head/Neck CA Condition:' is answered YES.

 ; Only a NTR screening status of 3=PENDING DIAGNOSIS gets Filed.

 I $P($G(M3),U,30)="Y",$P($G(DGNTARR("STAT")),U)=3 D

 . S DGNTARR=$$FILEHNC^DGNTAPI1(DFN)

 . QUIT

 K DGNTARR

 ;- update MT indicator after edit movement

 N DGPMCA,DGPMAN D PM^DGPTUTL

 I '$G(DGADM) S DGADM=+^DGPT(PTF,0)

 D MT^DGPTUTL

 G EN

 ;

PR W !,"Enter '^' to stop the display and edit of data",!,"'^N' to jump to screen #N (appears in upper right of screen '<N>'",!,"<RET> to continue on to the next screen or 1-2 to edit:"

 W !?10,"1-",$S(DGPTFE:"Date of movement, Losing Specialty, ",1:""),"Leave and Pass days",!?10,"2-ICD DIAGNOSIS CODES"

 W !,"You may also enter 1-2",!

 R !!,"Enter <RET>: ",X:DTIME G WR

 Q

NEXM S DGZM0=DGZM0+1 G ^DGPTFM:'$D(M(DGZM0)),EN

 ;

ADD ;add movement record of fee basis patent

 S DGZM0=$S($D(DGZM0):DGZM0+1,1:0) S L=$S($D(^DGPT(PTF,"M",0)):^(0),1:"^45.02DA^^"),L1=$P(L,U,3) F I=1:1 Q:'$D(^DGPT(PTF,"M",L1+I))

 S DA(1)=PTF,DIC="^DGPT("_DA(1)_",""M"",",X=L1+I,DIC(0)="LMZQE" D ^DIC K DIC,DIE G ^DGPTFM:Y'>0

 S M(DGZM0)=L1+I S X="1-2" G X1

 Q

MOB S I=0 K M,M1,M2 S M2=0 F I1=1:1 S I=$O(^DGPT(PTF,"M",I)) Q:'I  S M(I1)=^(I,0)

 S PM=I1-1 D ORDER^DGPTF Q

Q G Q^DGPTF

Z I 'DGN S Z=$S(IOST="C-QUME"&($L(DGVI)'=2):Z,1:"["_Z_"]") W @DGVI,Z,@DGVO

 E  W "   "

 Q

Z1 F I=1:1:(Z1-$L(Z)) S Z=Z_" "

 W Z

 Q

R ;DELETE PROCEDURE RECORD

 I '$D(^DGPT(PTF,"P")) G NOPROC

 I $O(^DGPT(PTF,"P",0))']"" G NOPROC

 S DGPNUM="" F DGPROC=0:0 S DGPROC=$O(P(DGPROC)) Q:'DGPROC  S:$D(P(DGPROC,1)) DGPNUM=DGPNUM_","_DGPROC

 S DGPNUM=DGPNUM_","

ASKPRO W !!,"Delete procedure record <",$P(DGPNUM,",",2,99),"> : " R DGPROC:DTIME I DGPROC[U!(DGPROC="") K DGPNUM,DGPROC G ^DGPTFM

 I DGPNUM'[(","_DGPROC_",") W !!,"Enter the record # to delete from the PTF file <",$P(DGPNUM,",",2,99),">",! G ASKPRO

 K DA N DGJ

 F DGJ=1:1 S DA=+$P(DGPROC,",",DGJ) Q:'DA  S DA=$S($D(P(DA,1)):+P(DA,1),1:0) I DA S DA(1)=PTF,DIK="^DGPT("_PTF_",""P""," D ^DIK K DA W "   ",$P(DGPROC,",",DGJ),"-DELETED***" H:'$P(DGPROC,",",DGJ+1) 2

 K DIK,DA,DGPROC,DGPNUM G ^DGPTFM

NOPROC W !!,*7,"No procedures to delete",! H 3 G ^DGPTFM

 Q

 ;

PGBR N DIR,X,Y S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DGPTFM4   8171     printed  Feb 19, 2025@00:18:24                                                                                                                                                                                                     Page 2

DGPTFM4   ;ALB/MTC/ADL/PLT - PTF ENTRY/EDIT-2 ;12/18/07 11:37am

 +1       ;;5.3;Registration;**114,195,397,510,565,775,664,759,850,884,1104**;Aug 13, 1993;Build 59

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3       ; Reference to $$DRGD^ICDGTDRG in ICR #4052

 +4       ; Reference to DIS^EASECU in ICR #6771

 +5       ; Reference to $$DISPLAY^PXCOMPACT in ICR #7327

 +6       ;;ADL;Update for CSV Project;;Mar 26, 2003

 +7       ;

 +8        SET DGZM0=DGZM0+1

EN        ;

 +1        NEW M3,M82,DGMPOA

 +2        if '$DATA(M)

               DO MOB

 +3        SET M(DGZM0)=$SELECT($DATA(M(DGZM0)):M(DGZM0),1:"")

           if M(DGZM0)=""

               GOTO NEXM

 +4        SET (M3,M(DGZM0),M1)=$SELECT($DATA(^DGPT(PTF,"M",+M(DGZM0),0)):^DGPT(PTF,"M",+M(DGZM0),0),1:"")

 +5        SET M82=$GET(^DGPT(PTF,"M",+M(DGZM0),82))

 +6        IF $DATA(^DGPT(PTF,"M",+M(DGZM0),"P"))

               SET $PIECE(M(DGZM0),U,20)=^("P")

               SET $PIECE(M1,U,20)=^("P")

WR         SET DG300=$SELECT($DATA(^DGPT(PTF,"M",+M(DGZM0),300)):^(300),1:"")

 +1        WRITE @IOF,HEAD,?70

           SET Z="<501-"_DGZM0_">"

           DO Z^DGPTFM

           IF +M(DGZM0)=1

               WRITE !,?62,"Discharge Movement"

M          SET L=+$PIECE(M1,U,10)

           SET Y=L

           DO D^DGPTUTL

           WRITE !!

           SET Z=1

           DO Z

           WRITE "Date of Move: "

           SET Z=Y

           SET Z1=20

           DO Z1

           WRITE "Losing Specialty: ",$EXTRACT($SELECT($DATA(^DIC(42.4,+$PIECE(M1,U,2),0)):$PIECE(^(0),U,1),1:""),1,25)

 +1        WRITE !,"     Leave days: ",$PIECE(M1,U,3),?44,"Pass days: ",$PIECE(M1,U,4)

 +2        WRITE !,"Treated for SC Condition: ",$SELECT($PIECE(M3,U,18)=1:"Yes",1:"No")

 +3        WRITE !,"Treated for Acute Suicidal Crisis: ",$SELECT($PIECE(^DGPT(PTF,"M",+M(DGZM0),0),"^",33)="Y":"Yes",1:"No")

 +4       ;check for COMPACT Act information

 +5        NEW DISPLAY

 +6        SET DISPLAY=$$DISPLAY^PXCOMPACT(DFN)

 +7       ;DISPLAY will contain one of the following groups of information:

 +8       ;  If end date exists (episode has ended) and there are no extensions,

 +9       ;     "COMPACT Act Start Date"^EPISODE START DATE^"End Date"^EPISODE END DATE^"IP Benefit End Date"^INPATIENT BENEFIT END DATE^"OP Benefit end date"^OUTPATIENT BENEFIT END DATE

 +10      ;  If end date exists (episode has ended) and an extension exists,

 +11      ;     "Extension Start Date"^EXTENSION START DATE^"Episode End Date"^EPISODE END DATE

 +12      ;  If end date does not exist (episode is ongoing) and there are no extensions,

 +13      ;     For an inpatient with an INPATIENT BENEFIT END DATE,

 +14      ;         "COMPACT Act Start Date"^EPISODE START DATE^"Remaining Days"^REMAINING INPATIENT DAYS^"Inpatient Benefit End Date"^INPATIENT BENEFIT END DATE

 +15      ;     Otherwise,

 +16      ;         "COMPACT Act Start Date"^EPISODE START DATE^"Remaining Days"^REMAINING INPATIENT DAYS or REMAINING OUTPATIENT DAYS

 +17      ;  If end date does not exist (episode is ongoing) and an extension exists,

 +18      ;     "Extension Start Date"^EXTENSION START DATE^"Remaining Days"^REMAINING INPATIENT DAYS or REMAINING OUTPATIENT DAYS

 +19      ;

 +20       IF $PIECE(DISPLAY,U)="COMPACT Act Start Date"

               WRITE ?42,"COMPACT Start Date: ",$PIECE(DISPLAY,U,2)

 +21       IF $PIECE(DISPLAY,U)="Extension Start Date"

               WRITE ?40,"Extension Start Date: ",$PIECE(DISPLAY,U,2)

 +22       IF $PIECE(DISPLAY,U,3)["End Date"

               WRITE !,"                                            COMPACT End Date: ",$SELECT($PIECE(DISPLAY,U,6)]"":$PIECE(DISPLAY,U,6),1:$PIECE(DISPLAY,U,4))

 +23       IF $PIECE(DISPLAY,U,3)="Remaining Days"

               WRITE !,"                                              Remaining Days: ",$PIECE(DISPLAY,U,4)

 +24      ; Changed from 0 to accommodate new COMPACT line

           NEW NL

           SET NL=1

 +25       IF $PIECE(M3,U,31)'=""

               WRITE @($SELECT(NL#2:"!",1:"?37")),"Potentially Related to Combat: ",$SELECT($PIECE(M3,U,31)="Y":"Yes",1:"No")

               SET NL=NL+1

 +26       IF $PIECE(M3,U,26)'=""

               WRITE @($SELECT(NL#2:"!",1:"?37")),"Treated for AO Condition: ",$SELECT($PIECE(M3,U,26)="Y":"Yes",1:"No")

               SET NL=NL+1

 +27       IF $PIECE(M3,U,27)'=""

               WRITE @($SELECT(NL#2:"!",1:"?37")),"Treated for IR Condition: ",$SELECT($PIECE(M3,U,27)="Y":"Yes",1:"No")

               SET NL=NL+1

 +28       IF $PIECE(M3,U,28)'=""

               WRITE @($SELECT(NL#2:"!",1:"?37")),"Treated for service in SW Asia: ",$SELECT($PIECE(M3,U,28)="Y":"Yes",1:"No")

               SET NL=NL+1

 +29       IF $PIECE(M3,U,29)'=""

               WRITE @($SELECT(NL#2:"!",1:"?37")),"Treated for MST Condition: ",$SELECT($PIECE(M3,U,29)="Y":"Yes",1:"No")

               SET NL=NL+1

 +30       KILL DGNTARR

 +31       SET DGNTARR=$$GETCUR^DGNTAPI(DFN,"DGNTARR")

 +32       IF $PIECE(M3,U,30)=""

               IF (",3,4,5,"[(","_$PIECE($GET(DGNTARR("STAT")),U)_","))

                   SET $PIECE(M3,U,30)="N"

 +33       IF $PIECE(M3,U,30)'=""

               WRITE @($SELECT(NL#2:"!",1:"?37")),"Treated for HEAD/NECK CA Condition: ",$SELECT($PIECE(M3,U,30)="Y":"Yes",1:"No")

               SET NL=NL+1

 +34       IF $PIECE(M3,U,32)'=""

               WRITE @($SELECT(NL#2:"!",1:"?37")),"Treated for Project 112/SHAD: ",$SELECT($PIECE(M3,U,32)="Y":"Yes",1:"No")

 +35       KILL NL

 +36       NEW EFFDATE,IMPDATE

 +37       DO EFFDATE^DGPTIC10(PTF)

 +38       WRITE !!

           SET Z=2

           DO Z

           WRITE "          DX: ",$$GETLABEL^DGPTIC10(EFFDATE,"D")

 +39      ;F I=1:1:11 S L=$P(M1,U,I+4) I L'=""&(I'=6) D

 +40       DO PTFICD^DGPTFUT(501,PTF,+M(DGZM0),.DGX501)

 +41       SET I=0

           FOR 

               SET I=$ORDER(DGX501(I))

               if 'I

                   QUIT 

               SET L=DGX501(I)

               Begin DoDot:1

 +42               SET DGMPOA=$PIECE(L,U,2)

 +43               SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+L,EFFDATE)

 +44               DO WRITECOD^DGPTIC10("DIAG",+L,EFFDATE,2,1,15)

 +45               IF $PIECE(DGPTTMP,U,20)=30

                       if $X>73

                           WRITE !,"            "

                       WRITE " (POA=",$SELECT(DGMPOA]"":DGMPOA,1:"''"),")"

 +46               WRITE $SELECT(+DGPTTMP<1!('$PIECE(DGPTTMP,U,10)):"*",1:"")

 +47               IF $Y>(IOSL-4)

                       DO PGBR

                       WRITE @IOF,HEAD,?72

                       SET Z="<501-"_DGZM0_">"

                       DO Z^DGPTFM

                       WRITE !

 +48               QUIT 

               End DoDot:1

 +49       KILL DGX501

 +50       if DG300]""

               DO PRN2^DGPTFM8

 +51      ;

 +52       IF $PIECE(M1,U,20)

               SET DRG=$PIECE(M1,U,20)

               if DRG=998!(DRG=999)!((DRG=468!(DRG=469)!(DRG=470))&(+$PIECE($GET(M1),U,10)<3071001))

                   WRITE *7

               WRITE !!?14,"TRANSFER DRG: ",DRG

               Begin DoDot:1

 +53               NEW DXD,DGDX

 +54               SET DXD=$$DRGD^ICDGTDRG(DRG,"DGDX",,$PIECE(M1,U,10))

                   SET DGDS=0

 +55               FOR 

                       SET DGDS=$ORDER(DGDX(DGDS))

                       if '+DGDS

                           QUIT 

                       if DGDX(DGDS)=" "

                           QUIT 

                       WRITE !,DGDX(DGDS)

               End DoDot:1

JUMP       KILL DG300

           FOR I=$Y:1:21

               WRITE !

X          SET DGNUM=$SELECT($DATA(M(DGZM0+1)):501_"-"_(DGZM0+1),1:"MAS")

           if DGST

               GOTO 501^DGPTFJC

 +1        WRITE "Enter <RET> to continue, 1-2 to edit,",!,"'M' ",$SELECT(DGPTFE:" to add a patient movement",1:"to edit Treat. Specialty"),", '^N' for screen N, or '^' to abort:<",DGNUM,">// "

           READ X:DTIME

 +2        KILL DGNUM

           if X="^"

               GOTO Q

           if X=""

               GOTO NEXM

           if X?1"^".E

               GOTO ^DGPTFJ

           if X="M"!(X="m")

               GOTO M^DGPTFM1

X1         IF X'=1

               IF X'=2

                   IF X'="1-2"

                       GOTO PR

 +1        SET DGCODSYS=$$CODESYS^DGPTIC10(PTF)

 +2        SET DR=$SELECT(DGPTFE:"[DG501F-10D]",1:"[DG501-10D]")

           IF DGCODSYS="ICD9"

               SET DR=$SELECT(DGPTFE:"[DG501F]",1:"[DG501]")

 +3        SET DGJUMP=X

           SET DIE="^DGPT("

           SET (DA,DGPTF)=PTF

           SET DGMOV=+M(DGZM0)

           DO ^DIE

 +4        IF DR'["-10D"

               KILL DR,DA,DIE,DIC

               SET DR=""

               if (+M(DGZM0)=1)

                   XECUTE "S J=^DGPT(PTF,""M"",1,0) F I=11:1:15 I $P(J,U,I) S DR=DR_I_"";"""

               IF DR'=""

                   Begin DoDot:1

 +5                    SET DGJUMP=X

                       SET DIE="^DGPT("_DGPTF_",""M"","

                       SET (DA(1),DGPTF)=PTF

                       SET (DA,DGMOV)=+M(DGZM0)

 +6                    DO ^DIE

 +7                    QUIT 

                   End DoDot:1

 +8        KILL M,DR,DIE

           DO CHK501^DGPTSCAN

           KILL DGPTF,DGMOV

 +9       ; Determine if NTR HISTORY (#28.11) filer is called if question for

 +10      ;  'Treated for Head/Neck CA Condition:' is answered YES.

 +11      ; Only a NTR screening status of 3=PENDING DIAGNOSIS gets Filed.

 +12       IF $PIECE($GET(M3),U,30)="Y"

               IF $PIECE($GET(DGNTARR("STAT")),U)=3

                   Begin DoDot:1

 +13                   SET DGNTARR=$$FILEHNC^DGNTAPI1(DFN)

 +14                   QUIT 

                   End DoDot:1

 +15       KILL DGNTARR

 +16      ;- update MT indicator after edit movement

 +17       NEW DGPMCA,DGPMAN

           DO PM^DGPTUTL

 +18       IF '$GET(DGADM)

               SET DGADM=+^DGPT(PTF,0)

 +19       DO MT^DGPTUTL

 +20       GOTO EN

 +21      ;

PR         WRITE !,"Enter '^' to stop the display and edit of data",!,"'^N' to jump to screen #N (appears in upper right of screen '<N>'",!,"<RET> to continue on to the next screen or 1-2 to edit:"

 +1        WRITE !?10,"1-",$SELECT(DGPTFE:"Date of movement, Losing Specialty, ",1:""),"Leave and Pass days",!?10,"2-ICD DIAGNOSIS CODES"

 +2        WRITE !,"You may also enter 1-2",!

 +3        READ !!,"Enter <RET>: ",X:DTIME

           GOTO WR

 +4        QUIT 

NEXM       SET DGZM0=DGZM0+1

           if '$DATA(M(DGZM0))

               GOTO ^DGPTFM

           GOTO EN

 +1       ;

ADD       ;add movement record of fee basis patent

 +1        SET DGZM0=$SELECT($DATA(DGZM0):DGZM0+1,1:0)

           SET L=$SELECT($DATA(^DGPT(PTF,"M",0)):^(0),1:"^45.02DA^^")

           SET L1=$PIECE(L,U,3)

           FOR I=1:1

               if '$DATA(^DGPT(PTF,"M",L1+I))

                   QUIT 

 +2        SET DA(1)=PTF

           SET DIC="^DGPT("_DA(1)_",""M"","

           SET X=L1+I

           SET DIC(0)="LMZQE"

           DO ^DIC

           KILL DIC,DIE

           if Y'>0

               GOTO ^DGPTFM

 +3        SET M(DGZM0)=L1+I

           SET X="1-2"

           GOTO X1

 +4        QUIT 

MOB        SET I=0

           KILL M,M1,M2

           SET M2=0

           FOR I1=1:1

               SET I=$ORDER(^DGPT(PTF,"M",I))

               if 'I

                   QUIT 

               SET M(I1)=^(I,0)

 +1        SET PM=I1-1

           DO ORDER^DGPTF

           QUIT 

Q          GOTO Q^DGPTF

Z          IF 'DGN

               SET Z=$SELECT(IOST="C-QUME"&($LENGTH(DGVI)'=2):Z,1:"["_Z_"]")

               WRITE @DGVI,Z,@DGVO

 +1       IF '$TEST

               WRITE "   "

 +2        QUIT 

Z1         FOR I=1:1:(Z1-$LENGTH(Z))

               SET Z=Z_" "

 +1        WRITE Z

 +2        QUIT 

R         ;DELETE PROCEDURE RECORD

 +1        IF '$DATA(^DGPT(PTF,"P"))

               GOTO NOPROC

 +2        IF $ORDER(^DGPT(PTF,"P",0))']""

               GOTO NOPROC

 +3        SET DGPNUM=""

           FOR DGPROC=0:0

               SET DGPROC=$ORDER(P(DGPROC))

               if 'DGPROC

                   QUIT 

               if $DATA(P(DGPROC,1))

                   SET DGPNUM=DGPNUM_","_DGPROC

 +4        SET DGPNUM=DGPNUM_","

ASKPRO     WRITE !!,"Delete procedure record <",$PIECE(DGPNUM,",",2,99),"> : "

           READ DGPROC:DTIME

           IF DGPROC[U!(DGPROC="")

               KILL DGPNUM,DGPROC

               GOTO ^DGPTFM

 +1        IF DGPNUM'[(","_DGPROC_",")

               WRITE !!,"Enter the record # to delete from the PTF file <",$PIECE(DGPNUM,",",2,99),">",!

               GOTO ASKPRO

 +2        KILL DA

           NEW DGJ

 +3        FOR DGJ=1:1

               SET DA=+$PIECE(DGPROC,",",DGJ)

               if 'DA

                   QUIT 

               SET DA=$SELECT($DATA(P(DA,1)):+P(DA,1),1:0)

               IF DA

                   SET DA(1)=PTF

                   SET DIK="^DGPT("_PTF_",""P"","

                   DO ^DIK

                   KILL DA

                   WRITE "   ",$PIECE(DGPROC,",",DGJ),"-DELETED***"

                   if '$PIECE(DGPROC,",",DGJ+1)

                       HANG 2

 +4        KILL DIK,DA,DGPROC,DGPNUM

           GOTO ^DGPTFM

NOPROC     WRITE !!,*7,"No procedures to delete",!

           HANG 3

           GOTO ^DGPTFM

 +1        QUIT 

 +2       ;

PGBR       NEW DIR,X,Y

           SET DIR(0)="E"

           SET DIR("A")="Enter RETURN to continue"

           DO ^DIR

           QUIT