DGPTFM1 ;ALB/MTC/PLT,WOIFO/PMK - MASTER DIAG/OP/PRO CODE ENTER/EDIT ;7/6/15 3:37PM
 ;;5.3;Registration;**114,517,635,850,884**;Aug 13, 1993;Build 31
 ;;Per VA Directive 6402, this routine should not be modified.
 ;
D G D^DGPTFM0
 ;
A S DGCODSYS=$$CODESYS^DGPTIC10(PTF),L="" F I=1:1:PM S L2=1 D
 . N A
 . F J=5:1:9 I $P(M(I),U,J)="" S L=L_I_",",L2=0 QUIT
 . QUIT:DGCODSYS="ICD9"!'L2
 . F J=11:1:15 I $P(M(I),U,J)="" S L=L_I_",",L2=0 QUIT
 . QUIT:'L2
 . S A=$G(^DGPT(PTF,"M",+M(I),81)) F J=1:1:15 I $P(A,U,J)="" S L=L_I_",",L2=0 QUIT
 . QUIT
 I L="" W !!,"There are no movement records that can be added to.",*7,*7 H 2 G ^DGPTFM
 S L=$E(L,1,$L(L)-1) I L=+L S RC=+L G A2
A1 I 'Z W !!,"Add to movement record <",L,"> : " R RC:DTIME G ^DGPTFM:RC[U!('$T)!(RC="")
 E  S RC=+$E(A,2,99)
A2 I +RC'=RC!(","_L_","'[(","_RC_",")) W !!,"Enter the movement record number to add ICD diagnosis to: ",L S Z="" G A1
 S DGCODSYS=$$CODESYS^DGPTIC10(PTF),DIE="^DGPT(",(DA,DGPTF)=PTF,DR=$S(DGCODSYS="ICD10":"[DG501-10D]",1:"[DG501]"),DGJUMP="" S:DGPTFE DR=$S(DGCODSYS="ICD10":"[DG501F-10D]",1:"[DG501F]")
 S DGMOV=+M(RC),DGADD=1 D ^DIE K DR,DA,DGADD,DIE,DGJUMP,DGCODSYS,DGXX,DGTYPE D CHK501^DGPTSCAN K DGPTF,DGMOV,DGADD
 G ^DGPTFM
 ;
M I DGPTFE G ADD^DGPTFM4
 S X=80 X ^%ZOSF("RM") D MVT K T,AM,M I $L(DGVO_DGVI)>4 S X=132 X ^%ZOSF("RM")
 G ^DGPTFM:'$D(DGPMDA) S DA=$S('$D(^DGPM(DGPMDA,"PTF")):"",1:$P(^("PTF"),"^",3)) G ^DGPTFM:'$D(^DGPT(PTF,"M",+DA,0)) S Y=^(0)
 S X=$S($D(^DIC(42.4,+$P(Y,U,2),0)):$P(^(0),U,1),1:""),Y=$P(Y,U,10)
 D D^DGPTUTL K M W !,"Editing ",$S(DA=1:"Discharge ",1:""),"Movement " W:Y]"" "of ",Y W "  Losing Specialty ",X
 S DGCODSYS=$$CODESYS^DGPTIC10(PTF),DGMOV=DA,(DA,DGPTF)=PTF,DIE="^DGPT(",DR=$S(DGCODSYS="ICD10":"[DG501-10D]",1:"[DG501]"),DGJUMP="1-2" D ^DIE
 K DA,DR,DIE,DGJUMP,DGCODSYS,DGXX,DGTYPE D CHK501^DGPTSCAN K DGPTF,DGMOV
 ;- update MT indicator after edit movement
 N DGPMCA,DGPMAN D PM^DGPTUTL
 I '$G(DGADM) S DGADM=+^DGPT(PTF,0)
 D MT^DGPTUTL
 G ^DGPTFM
 ;
Z I 'SU W !,"No surgeries to delete",! H 3 G ^DGPTFM
 S ST=1 I 'Z W !!,"Delete surgery record <1",$S(SU=1:"",1:"-"_SU),">: " R RC:DTIME G ^DGPTFM:'$T!(RC[U)!(RC="")
 E  S RC=$E(A,2,99) W !
 I +RC'=RC!('$D(S(RC))) W !!,"Enter the record # to delete from the PTF file, 1",$S(SU=1:"",1:"-"_SU) S Z=0 G Z
 K DA S DIK="^DGPT("_PTF_",""S"",",ST=1,(DGPTF,DA(1))=PTF,(DGSUR,DA)=+S(RC,1) D ^DIK K DA W "  ",RC,"-DELETED***" D CHK401^DGPTSCAN K DGPTF,DGSUR H 2 G ^DGPTFM
 ;
C G CEL:Z
 I '$D(S2) W !,"View Surgery Codes first",! H 2 G ^DGPTFM
 I 'S2 W !,"No codes to delete",! H 2 G ^DGPTFM
C1 R !!,"Enter the item #'s of the ICD operation codes to delete: ",A1:DTIME
 S:'$T A1=U I A1'?1N.NP G ^DGPTFM:"^"[A1 W:A1'["?" "  ???",*7 D C^DGPTFM0 G C1
 S A=A_A1
CEL D EXPL^DGPTUTL
 K X,A1 S DA(1)=PTF,DP=45.01 W !!
 F J=1:1 S L=+$P(DGA,",",J),DIE="^DGPT("_PTF_",""S""," Q:'L  D
 .S L1=$S($D(S2(L)):S2(L),1:"Undefined, ") W:'L1 " ",L,"-",L1
 .I L1 S (DA,DGSUR)=+S(+L1,1),(DA(1),DGPTF)=PTF,DR=$$FLDNUM^DILFD(45.01,"OPERATION CODE "_$P(S2(+L),U,2))_"///@" D ^DIE,CEL1
 H 3 S ST=1 G ^DGPTFM
 ;
CEL1 ;
 K DR W " ",L,"-Deleted, " W:$X>70 ! D CHK401^DGPTSCAN K DGPTF,DGSUR
 Q
 ;
O I '$D(S2) W !,"View Surgery Codes first",! H 2 G ^DGPTFM
 I 'S2 W !,"No codes can be added to a Surgery Record.",! H 2 G ^DGPTFM
 S DGCODSYS=$$CODESYS^DGPTIC10(PTF),L="" F I=1:1:SU S L2=1 D
 . N A
 . F J=8:1:12 I $P(S(I),U,J)="" S L=L_I_",",L2=0 QUIT:'L2
 . QUIT:DGCODSYS="ICD9"!'L2
 . F J=13:1:27 I $P(S(I),U,J)="" S L=L_I_",",L2=0 QUIT:'L2
 . QUIT:'L2
 . S A=$G(^DGPT(PTF,"S",+S(I,1),1)) F J=1:1:5 I $P(A,U,J)="" S L=L_I_",",L2=0 QUIT:'L2
 . QUIT
 I L="" W !!,"There are no surgery records that can be added to.",*7 H 2 S ST=1 G ^DGPTFM
 S L=$E(L,1,$L(L)-1) I L=+L S RC=+L G O2
O1 I 'Z S ST=1 W !!,"Add to surgery record <",L,"> : " R RC:DTIME G ^DGPTFM:'$T!(RC[U)!(RC="")
 E  S RC=+$E(A,2,99)
O2 I +RC'=RC!(","_L_","'[(","_RC_",")) W !!,"Enter the surgery record number to add ICD operation codes to: ",L G O1:'Z S Z="" G O1
 S DGCODSYS=$$CODESYS^DGPTIC10(PTF),DIE="^DGPT(",(DGPTF,DA)=PTF,DR=$S(DGCODSYS="ICD10":"[DG401-10P]",1:"[DG401]")
 S ST=1,DGZS0=RC,DGADD=1,DGSUR=S(DGZS0,1) D ^DIE,CHK401^DGPTSCAN K DR,DGPTF,DGSUR,DGADD G ^DGPTFM
 ;
S G ADD^DGPTFM5
V S DGZM0=0 G ^DGPTFM4
J S DGZS0=0 G ^DGPTFM5
 ;
 ;delete procedure code in 401p(before 2871000) or procedure record
Q I $G(P2P) G Q401P
 G QELP:Z
 I '$D(P2) W !,"View Prodedure Codes first",! H 2 G ^DGPTFM
 I 'P2 W !,"No codes to delete",! H 2 G ^DGPTFM
QP1 R !!,"Enter the item #'s of the ICD procedure codes to delete: ",A1:DTIME
 S:'$T A1=U I A1'?1N.NP G ^DGPTFM:"^"[A1 W:A1'["?" "  ???",*7 D Q^DGPTFM0 G QP1
 S A=A_A1
QELP D EXPL^DGPTUTL
 K X,A1 S DA(1)=PTF,DP=45.05 W !!
 F J=1:1 S L=+$P(DGA,",",J),DIE="^DGPT("_PTF_",""P""," Q:'L  D
 . S L1=$S($D(P2(L)):P2(L),1:"Undefined, ") I 'L1 W " ",L,"-",L1 W:$X>70 ! Q  ; P884
 . I L1 S DA=+P(+L1,1),DGZP=+L1,(DA(1),DGPTF)=PTF,DR=$$FLDNUM^DILFD(45.05,"PROCEDURE CODE "_$P(P2(+L),U,2))_"///@" D ^DIE
 . K DR W " ",L,"-Deleted, " W:$X>70 ! D CHK601^DGPTSCAN K DGPTF,DGZP
 . QUIT
 H 3 S ST=1 G ^DGPTFM
 ;
Q401P G QEL:Z
 I $G(^DGPT(PTF,70))>2871000!'$G(^(70)) D EN^DDIOL("Patient with no Discharge Date or after 09/30/1987 needs to have all Procedure Codes deleted in 401P Transaction.")
QQ R !!,"Enter the item #'s of the 401P - Procedure codes to delete: ",A1:DTIME
 S:'$T A1=U I A1'?1N.NP G ^DGPTFM:"^"[A1 W:A1'["?" "  ???",*7 D Q1^DGPTFM0 G QQ
 S A=A_A1
QEL D EXPL^DGPTUTL
 S DGA=$E(A,2,999) K X,A1 S DIE="^DGPT(",DA=PTF W !!
 F J=1:1 S DP=45,L=+$P(DGA,",",J) Q:'L  D
 . S L1=$S($D(P2P(L)):P2P(L),1:"Undefined, ")
 . W:'L1 " ",L,"-",L1
 . I L1 S DR=+P2P(+L)/100+45_"///@",DA(1)=PTF D
 .. D ^DIE
 .. K DR W " ",L,"-Deleted, " W:$X>70 !
 H 3 G ^DGPTFM
 ;
P G P^DGPTFM6
Q1 Q
T G ^DGPTFM6
R G R^DGPTFM4
E I $D(^DGPT(PTF,70)),+^(70)>2871000 D MOB^DGPTFM6 G SET^DGPTFM6
 I DT>2871000 D MOB^DGPTFM6 G SET^DGPTFM6
 G ^DGPTFM6
 ;
MVT ;
 N PTF,DGPMAN
 S DGPMT=6 D CA^DGPMV S DGPMDA=+Y
 K DGPMT Q
I G ADD^DGPTFM2
Y G DEL^DGPTFM2
N G N^DGPTFM2
G G DC^DGPTFM2
F G F^DGPTFM2
 Q
 
--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTFM1   6135     printed  Sep 23, 2025@20:28:10                                                                                                                                                                                                     Page 2
DGPTFM1   ;ALB/MTC/PLT,WOIFO/PMK - MASTER DIAG/OP/PRO CODE ENTER/EDIT ;7/6/15 3:37PM
 +1       ;;5.3;Registration;**114,517,635,850,884**;Aug 13, 1993;Build 31
 +2       ;;Per VA Directive 6402, this routine should not be modified.
 +3       ;
D          GOTO D^DGPTFM0
 +1       ;
A          SET DGCODSYS=$$CODESYS^DGPTIC10(PTF)
           SET L=""
           FOR I=1:1:PM
               SET L2=1
               Begin DoDot:1
 +1                NEW A
 +2                FOR J=5:1:9
                       IF $PIECE(M(I),U,J)=""
                           SET L=L_I_","
                           SET L2=0
                           QUIT 
 +3                if DGCODSYS="ICD9"!'L2
                       QUIT 
 +4                FOR J=11:1:15
                       IF $PIECE(M(I),U,J)=""
                           SET L=L_I_","
                           SET L2=0
                           QUIT 
 +5                if 'L2
                       QUIT 
 +6                SET A=$GET(^DGPT(PTF,"M",+M(I),81))
                   FOR J=1:1:15
                       IF $PIECE(A,U,J)=""
                           SET L=L_I_","
                           SET L2=0
                           QUIT 
 +7                QUIT 
               End DoDot:1
 +8        IF L=""
               WRITE !!,"There are no movement records that can be added to.",*7,*7
               HANG 2
               GOTO ^DGPTFM
 +9        SET L=$EXTRACT(L,1,$LENGTH(L)-1)
           IF L=+L
               SET RC=+L
               GOTO A2
A1         IF 'Z
               WRITE !!,"Add to movement record <",L,"> : "
               READ RC:DTIME
               if RC[U!('$TEST)!(RC="")
                   GOTO ^DGPTFM
 +1       IF '$TEST
               SET RC=+$EXTRACT(A,2,99)
A2         IF +RC'=RC!(","_L_","'[(","_RC_","))
               WRITE !!,"Enter the movement record number to add ICD diagnosis to: ",L
               SET Z=""
               GOTO A1
 +1        SET DGCODSYS=$$CODESYS^DGPTIC10(PTF)
           SET DIE="^DGPT("
           SET (DA,DGPTF)=PTF
           SET DR=$SELECT(DGCODSYS="ICD10":"[DG501-10D]",1:"[DG501]")
           SET DGJUMP=""
           if DGPTFE
               SET DR=$SELECT(DGCODSYS="ICD10":"[DG501F-10D]",1:"[DG501F]")
 +2        SET DGMOV=+M(RC)
           SET DGADD=1
           DO ^DIE
           KILL DR,DA,DGADD,DIE,DGJUMP,DGCODSYS,DGXX,DGTYPE
           DO CHK501^DGPTSCAN
           KILL DGPTF,DGMOV,DGADD
 +3        GOTO ^DGPTFM
 +4       ;
M          IF DGPTFE
               GOTO ADD^DGPTFM4
 +1        SET X=80
           XECUTE ^%ZOSF("RM")
           DO MVT
           KILL T,AM,M
           IF $LENGTH(DGVO_DGVI)>4
               SET X=132
               XECUTE ^%ZOSF("RM")
 +2        if '$DATA(DGPMDA)
               GOTO ^DGPTFM
           SET DA=$SELECT('$DATA(^DGPM(DGPMDA,"PTF")):"",1:$PIECE(^("PTF"),"^",3))
           if '$DATA(^DGPT(PTF,"M",+DA,0))
               GOTO ^DGPTFM
           SET Y=^(0)
 +3        SET X=$SELECT($DATA(^DIC(42.4,+$PIECE(Y,U,2),0)):$PIECE(^(0),U,1),1:"")
           SET Y=$PIECE(Y,U,10)
 +4        DO D^DGPTUTL
           KILL M
           WRITE !,"Editing ",$SELECT(DA=1:"Discharge ",1:""),"Movement "
           if Y]""
               WRITE "of ",Y
           WRITE "  Losing Specialty ",X
 +5        SET DGCODSYS=$$CODESYS^DGPTIC10(PTF)
           SET DGMOV=DA
           SET (DA,DGPTF)=PTF
           SET DIE="^DGPT("
           SET DR=$SELECT(DGCODSYS="ICD10":"[DG501-10D]",1:"[DG501]")
           SET DGJUMP="1-2"
           DO ^DIE
 +6        KILL DA,DR,DIE,DGJUMP,DGCODSYS,DGXX,DGTYPE
           DO CHK501^DGPTSCAN
           KILL DGPTF,DGMOV
 +7       ;- update MT indicator after edit movement
 +8        NEW DGPMCA,DGPMAN
           DO PM^DGPTUTL
 +9        IF '$GET(DGADM)
               SET DGADM=+^DGPT(PTF,0)
 +10       DO MT^DGPTUTL
 +11       GOTO ^DGPTFM
 +12      ;
Z          IF 'SU
               WRITE !,"No surgeries to delete",!
               HANG 3
               GOTO ^DGPTFM
 +1        SET ST=1
           IF 'Z
               WRITE !!,"Delete surgery record <1",$SELECT(SU=1:"",1:"-"_SU),">: "
               READ RC:DTIME
               if '$TEST!(RC[U)!(RC="")
                   GOTO ^DGPTFM
 +2       IF '$TEST
               SET RC=$EXTRACT(A,2,99)
               WRITE !
 +3        IF +RC'=RC!('$DATA(S(RC)))
               WRITE !!,"Enter the record # to delete from the PTF file, 1",$SELECT(SU=1:"",1:"-"_SU)
               SET Z=0
               GOTO Z
 +4        KILL DA
           SET DIK="^DGPT("_PTF_",""S"","
           SET ST=1
           SET (DGPTF,DA(1))=PTF
           SET (DGSUR,DA)=+S(RC,1)
           DO ^DIK
           KILL DA
           WRITE "  ",RC,"-DELETED***"
           DO CHK401^DGPTSCAN
           KILL DGPTF,DGSUR
           HANG 2
           GOTO ^DGPTFM
 +5       ;
C          if Z
               GOTO CEL
 +1        IF '$DATA(S2)
               WRITE !,"View Surgery Codes first",!
               HANG 2
               GOTO ^DGPTFM
 +2        IF 'S2
               WRITE !,"No codes to delete",!
               HANG 2
               GOTO ^DGPTFM
C1         READ !!,"Enter the item #'s of the ICD operation codes to delete: ",A1:DTIME
 +1        if '$TEST
               SET A1=U
           IF A1'?1N.NP
               if "^"[A1
                   GOTO ^DGPTFM
               if A1'["?"
                   WRITE "  ???",*7
               DO C^DGPTFM0
               GOTO C1
 +2        SET A=A_A1
CEL        DO EXPL^DGPTUTL
 +1        KILL X,A1
           SET DA(1)=PTF
           SET DP=45.01
           WRITE !!
 +2        FOR J=1:1
               SET L=+$PIECE(DGA,",",J)
               SET DIE="^DGPT("_PTF_",""S"","
               if 'L
                   QUIT 
               Begin DoDot:1
 +3                SET L1=$SELECT($DATA(S2(L)):S2(L),1:"Undefined, ")
                   if 'L1
                       WRITE " ",L,"-",L1
 +4                IF L1
                       SET (DA,DGSUR)=+S(+L1,1)
                       SET (DA(1),DGPTF)=PTF
                       SET DR=$$FLDNUM^DILFD(45.01,"OPERATION CODE "_$PIECE(S2(+L),U,2))_"///@"
                       DO ^DIE
                       DO CEL1
               End DoDot:1
 +5        HANG 3
           SET ST=1
           GOTO ^DGPTFM
 +6       ;
CEL1      ;
 +1        KILL DR
           WRITE " ",L,"-Deleted, "
           if $X>70
               WRITE !
           DO CHK401^DGPTSCAN
           KILL DGPTF,DGSUR
 +2        QUIT 
 +3       ;
O          IF '$DATA(S2)
               WRITE !,"View Surgery Codes first",!
               HANG 2
               GOTO ^DGPTFM
 +1        IF 'S2
               WRITE !,"No codes can be added to a Surgery Record.",!
               HANG 2
               GOTO ^DGPTFM
 +2        SET DGCODSYS=$$CODESYS^DGPTIC10(PTF)
           SET L=""
           FOR I=1:1:SU
               SET L2=1
               Begin DoDot:1
 +3                NEW A
 +4                FOR J=8:1:12
                       IF $PIECE(S(I),U,J)=""
                           SET L=L_I_","
                           SET L2=0
                           if 'L2
                               QUIT 
 +5                if DGCODSYS="ICD9"!'L2
                       QUIT 
 +6                FOR J=13:1:27
                       IF $PIECE(S(I),U,J)=""
                           SET L=L_I_","
                           SET L2=0
                           if 'L2
                               QUIT 
 +7                if 'L2
                       QUIT 
 +8                SET A=$GET(^DGPT(PTF,"S",+S(I,1),1))
                   FOR J=1:1:5
                       IF $PIECE(A,U,J)=""
                           SET L=L_I_","
                           SET L2=0
                           if 'L2
                               QUIT 
 +9                QUIT 
               End DoDot:1
 +10       IF L=""
               WRITE !!,"There are no surgery records that can be added to.",*7
               HANG 2
               SET ST=1
               GOTO ^DGPTFM
 +11       SET L=$EXTRACT(L,1,$LENGTH(L)-1)
           IF L=+L
               SET RC=+L
               GOTO O2
O1         IF 'Z
               SET ST=1
               WRITE !!,"Add to surgery record <",L,"> : "
               READ RC:DTIME
               if '$TEST!(RC[U)!(RC="")
                   GOTO ^DGPTFM
 +1       IF '$TEST
               SET RC=+$EXTRACT(A,2,99)
O2         IF +RC'=RC!(","_L_","'[(","_RC_","))
               WRITE !!,"Enter the surgery record number to add ICD operation codes to: ",L
               if 'Z
                   GOTO O1
               SET Z=""
               GOTO O1
 +1        SET DGCODSYS=$$CODESYS^DGPTIC10(PTF)
           SET DIE="^DGPT("
           SET (DGPTF,DA)=PTF
           SET DR=$SELECT(DGCODSYS="ICD10":"[DG401-10P]",1:"[DG401]")
 +2        SET ST=1
           SET DGZS0=RC
           SET DGADD=1
           SET DGSUR=S(DGZS0,1)
           DO ^DIE
           DO CHK401^DGPTSCAN
           KILL DR,DGPTF,DGSUR,DGADD
           GOTO ^DGPTFM
 +3       ;
S          GOTO ADD^DGPTFM5
V          SET DGZM0=0
           GOTO ^DGPTFM4
J          SET DGZS0=0
           GOTO ^DGPTFM5
 +1       ;
 +2       ;delete procedure code in 401p(before 2871000) or procedure record
Q          IF $GET(P2P)
               GOTO Q401P
 +1        if Z
               GOTO QELP
 +2        IF '$DATA(P2)
               WRITE !,"View Prodedure Codes first",!
               HANG 2
               GOTO ^DGPTFM
 +3        IF 'P2
               WRITE !,"No codes to delete",!
               HANG 2
               GOTO ^DGPTFM
QP1        READ !!,"Enter the item #'s of the ICD procedure codes to delete: ",A1:DTIME
 +1        if '$TEST
               SET A1=U
           IF A1'?1N.NP
               if "^"[A1
                   GOTO ^DGPTFM
               if A1'["?"
                   WRITE "  ???",*7
               DO Q^DGPTFM0
               GOTO QP1
 +2        SET A=A_A1
QELP       DO EXPL^DGPTUTL
 +1        KILL X,A1
           SET DA(1)=PTF
           SET DP=45.05
           WRITE !!
 +2        FOR J=1:1
               SET L=+$PIECE(DGA,",",J)
               SET DIE="^DGPT("_PTF_",""P"","
               if 'L
                   QUIT 
               Begin DoDot:1
 +3       ; P884
                   SET L1=$SELECT($DATA(P2(L)):P2(L),1:"Undefined, ")
                   IF 'L1
                       WRITE " ",L,"-",L1
                       if $X>70
                           WRITE !
                       QUIT 
 +4                IF L1
                       SET DA=+P(+L1,1)
                       SET DGZP=+L1
                       SET (DA(1),DGPTF)=PTF
                       SET DR=$$FLDNUM^DILFD(45.05,"PROCEDURE CODE "_$PIECE(P2(+L),U,2))_"///@"
                       DO ^DIE
 +5                KILL DR
                   WRITE " ",L,"-Deleted, "
                   if $X>70
                       WRITE !
                   DO CHK601^DGPTSCAN
                   KILL DGPTF,DGZP
 +6                QUIT 
               End DoDot:1
 +7        HANG 3
           SET ST=1
           GOTO ^DGPTFM
 +8       ;
Q401P      if Z
               GOTO QEL
 +1        IF $GET(^DGPT(PTF,70))>2871000!'$GET(^(70))
               DO EN^DDIOL("Patient with no Discharge Date or after 09/30/1987 needs to have all Procedure Codes deleted in 401P Transaction.")
QQ         READ !!,"Enter the item #'s of the 401P - Procedure codes to delete: ",A1:DTIME
 +1        if '$TEST
               SET A1=U
           IF A1'?1N.NP
               if "^"[A1
                   GOTO ^DGPTFM
               if A1'["?"
                   WRITE "  ???",*7
               DO Q1^DGPTFM0
               GOTO QQ
 +2        SET A=A_A1
QEL        DO EXPL^DGPTUTL
 +1        SET DGA=$EXTRACT(A,2,999)
           KILL X,A1
           SET DIE="^DGPT("
           SET DA=PTF
           WRITE !!
 +2        FOR J=1:1
               SET DP=45
               SET L=+$PIECE(DGA,",",J)
               if 'L
                   QUIT 
               Begin DoDot:1
 +3                SET L1=$SELECT($DATA(P2P(L)):P2P(L),1:"Undefined, ")
 +4                if 'L1
                       WRITE " ",L,"-",L1
 +5                IF L1
                       SET DR=+P2P(+L)/100+45_"///@"
                       SET DA(1)=PTF
                       Begin DoDot:2
 +6                        DO ^DIE
 +7                        KILL DR
                           WRITE " ",L,"-Deleted, "
                           if $X>70
                               WRITE !
                       End DoDot:2
               End DoDot:1
 +8        HANG 3
           GOTO ^DGPTFM
 +9       ;
P          GOTO P^DGPTFM6
Q1         QUIT 
T          GOTO ^DGPTFM6
R          GOTO R^DGPTFM4
E          IF $DATA(^DGPT(PTF,70))
               IF +^(70)>2871000
                   DO MOB^DGPTFM6
                   GOTO SET^DGPTFM6
 +1        IF DT>2871000
               DO MOB^DGPTFM6
               GOTO SET^DGPTFM6
 +2        GOTO ^DGPTFM6
 +3       ;
MVT       ;
 +1        NEW PTF,DGPMAN
 +2        SET DGPMT=6
           DO CA^DGPMV
           SET DGPMDA=+Y
 +3        KILL DGPMT
           QUIT 
I          GOTO ADD^DGPTFM2
Y          GOTO DEL^DGPTFM2
N          GOTO N^DGPTFM2
G          GOTO DC^DGPTFM2
F          GOTO F^DGPTFM2
 +1        QUIT