DGPTFM2 ;ALB/DWS - MASTER PROFESSIONAL SERVICE ENTER/EDIT ;6/16/05 8:33am
;;5.3;Registration;**517,590,606,635,850,912,1057**;Aug 13, 1993;Build 17
ADD ;ADD CPT RECORD
N DGZP S DGZP=0 S:'$D(^DGPT(PTF,"C",0)) ^(0)="^45.06D^^"
S DIC="^DGPT("_PTF_",""C"",",DIC(0)="AELQMXZ",DA(1)=PTF,DLAYGO=45
D ^DIC K DIC,DLAYGO G ^DGPTFM:Y'>0,^DGPTFM:'$D(^DGPT(PTF,"C",+Y))
S DGPSM=+Y
I '$P(Y,U,3) S DIR("A")="Do you want to edit this CPT RECORD DATE/TIME?",DIR(0)="Y",DIR("B")="YES" D ^DIR G ^DGPTFM:'Y!$D(DIRUT)
D MOB
I $P(DGZPRF,U,3) F I=1:1:$P(DGZPRF,U,3) S:DGZPRF(I,0)=DGPSM DGZP=I
K I G:'DGZP ^DGPTFM S X="A,B",DGPSM=0
ED G HELP^DGPTUTL1:X'["A"&(X'["B")&(X'["a")&(X'["b") K DA
S DGJUMP=X,DGPRD=+DGZPRF(DGZP),X1="^801"
I X["A"!(X["a") D L -^DGPT(PTF) I FLAG D MOB,REQ^DGPTFM3 G EXIT
.S DA(1)=PTF,DIE="^DGPT("_PTF_",""C"",",(DA,REC)=DGZPRF(DGZP,0)
.S DR=".01;.02;.03;.05;.09////0",DIC(0)="AELQZ" Q:'$$LOCK
.D FMDIE S FLAG=$D(Y)>9!$D(DOUT)!'$D(DA) Q:$D(Y)>9!'$D(DA)
.S DGPRD=+^DGPT(PTF,"C",DGZPRF(DGZP,0),0) Q:+DGZPRF(DGZP)=DGPRD
.S DGI=0 F S DGI=$O(^DGCPT(46,"C",PTF,DGI)) Q:DGI'>0 D Q:$D(Y)>9!'$D(DA)
..Q:+^DGCPT(46,DGI,1)'=+DGZPRF(DGZP) Q:$D(^(9))
..S DR=".14////"_DGPRD,(DA,REC)=DGI,DIE="^DGCPT(46," D FMDIE
..I $D(Y)>9!'$D(DA) S FLAG=1
..;ADD IMPDATE check to see if Edit on date changed coding system
. I $P(DGZPRF(DGZP),U)<IMPDATE,DGPRD'<IMPDATE D EN^DDIOL("Primary Diagnosis changing from ICD-9 to ICD-10. You must edit the Diagnosis.") S DGJUMP="B"
. I $P(DGZPRF(DGZP),U)'<IMPDATE,DGPRD<IMPDATE D EN^DDIOL("Primary Diagnosis changing from ICD-10 to ICD-9. You must edit the Diagnosis.") S DGJUMP="B"
.S $P(DGZPRF(DGZP),U)=DGPRD
JUMP I DGJUMP["B"!(DGJUMP["b") S DGI=0 D CL^SDCO21(DFN,DGPRD,"",.SDCLY) D
.F S DGI=$O(^DGCPT(46,"C",PTF,DGI)) Q:DGI'>0 I +^DGCPT(46,DGI,1)=+DGZPRF(DGZP),'$G(^(9)) D I $D(DUOUT) Q:'DGDIAG K DUOUT S DGI=0
..S (DA,REC)=DGI,DR=".01;",DIE="^DGCPT(46," D GETINFO^DGPTFM21
.Q:$D(DUOUT)
.F D D ^DIC S A=0 Q:Y'>0 D SED Q:$D(DUOUT)
..S DA=PTF,DIC="^DGCPT(46,",DIC(0)="AELMQZ",DLAYGO=46
..S DIC("S")="D EN6^DGPTFJC I 'DGER"
I $D(DUOUT),$G(DGDIAG) K DUOUT G JUMP
I $D(DUOUT),$G(DGJUMP)["A"!($G(DGJUMP)["a") S X=DGJUMP K DUOUT G ED
K DR,DIE,DIC,DA,DGI,DGJUMP,DGPRD,DLAYGO,XREF
D REQ^DGPTFM3,MOB H:RFL 2 K RFL
G ^DGPTFM:'$D(DGZPRF(DGZP,0)),^DGPTFM:'$D(^DGPT(PTF,"C",DGZPRF(DGZP,0)))
SET D MOB:'$D(DGZPRF) S:'$D(DGZP) DGZP=1 I $G(DGZPRF(DGZP,0))="" K DGZPRF(DGZP) G NEXP
WRT G ^DGPTFM:'$D(^DGPT(PTF,"C",DGZPRF(DGZP,0),0)) S J=DGZP W @IOF,HEAD,?68
N DGNUM S Z="<"_DGZP_">" W @DGVI,Z,@DGVO
W !,?30,"Initial Date Of Service: ",$$EXTERNAL^DILFD(45,14,,$G(DGIDTS)) ; DG*5.3*1057
W !! S Y=+DGZPRF(J),Z="A"
D D^DGPTUTL,Z^DGPTFM5 W ?5,"CPT Record Date/Time: ",Y
I $P(DGZPRF(J),U,8)'="" W ?55,"Visit Service Category: ",$P(DGZPRF(J),U,8)
I $P(DGZPRF(J),U,2) W !,?5,"Referring or Ordering Provider: " D
.S L=$P(DGZPRF(J),U,2) D PRV^DGPTFM
W !,?5,"Rendering Provider: " S L=$P(DGZPRF(J),U,3) D PRV^DGPTFM
I $P(DGZPRF(J),U,5) W !,?5,"Rendering Location: ",$P($G(^SC($P(DGZPRF(J),U,5),0)),U)
W !! S Z="B" D Z^DGPTFM5 W " Procedures: "
F K=$P(DGZPRF,U,2):1 Q:'$D(DGZPRF(J,K)) I '$D(DGZPRF(J,K,9)) D
.W ?5 D CPT^DGPTUTL1 W ! Q:$Y>16
F I=1:1:(IOSL-$Y-5) W !
K I,J,K,L,Z S DGNUM=$S($D(DGZPRF(DGZP+1)):DGZP+1,1:"MAS")
G 801^DGPTFJC:DGST
S DIR("A")="Enter <RET> to continue, A-B to edit, 'I' to add an 801,"
S DIR("A")=DIR("A")_$C(10,13)_"the number of an 801 screen, ?? to list 801 screens,"
S DIR("A")=DIR("A")_$C(10,13)_"'S' for Send to PCE,"
S DIR("A")=DIR("A")_" '^N' for screen N, or '^' to abort:"
S DIR("?")="^D HELP^DGPTUTL1"
S DIR(0)="F^OU",DIR("B")=DGNUM,DIR("??")="^D DISP^DGPTUTL1" D ^DIR
K DIR G:$D(DIRUT) Q^DGPTF:X="^"
I X?1"^".E S DGPTSCRN=801 G ^DGPTFJ
I X="MAS" S DGZP=1 G ^DGPTFM
G ADD:X="I"!(X="i"),HELP^DGPTUTL1:X["?"
I X?1N.N,$D(DGZPRF(X)) S DGZP=X G SET
I X["A"!(X["B")!(X["a")!(X["b") G ED
I X="S"!(X="s") D PCE G WRT
D HELP^DGPTUTL1 R !!,"Enter <RET>: ",X:DTIME G WRT
PCE L +^DGPT(PTF):2
I '$T W !,"CPT Record is being edited by another user" H 2 Q
D ICDINFO^DGAPI(DFN,PTF),XREF^DGPTFM21
S RES=$$DATA2PCE^DGAPI1(DFN,PTF,DGZP)
I RES=1 L -^DGPT(PTF) W !,"PTF Record sent to PCE" H 2 Q
W @IOF
;F I=1:1 Q:'$D(^TMP("DGPAPI",$J,"DIERR",$J,1,"TEXT",I)) W !,^(I)
W !,"The PTF Record may not have been filed in PCE due to errors."
W !,"Press return to continue." R X:DTIME
L -^DGPT(PTF) Q
NEXP S DGZP=DGZP+1
I '$D(DGZPRF(DGZP)) W:DGZP=2 !,"NO PROF. SERVICES TO EDIT." G EXIT
G SET
EXIT K DGPSM H 2 S DGZP=1 G ^DGPTFM
DEL ;DELETE A CPT RECORD
I '$P(DGZPRF,U,3) G NOPROC
ASK S DIR("A")="Select 801 record to Delete"
S DIR(0)="NO^1:"_$P(DGZPRF,U,3),DIR("??")="^D DISP^DGPTUTL1"
D ^DIR K DIR G ^DGPTFM:$D(DIRUT),^DGPTFM:'Y,^DGPTFM:'$D(^DGPT(PTF,"C",DGZPRF(Y,0),0)) S DGZP=Y,Y=+^(0) D D^DGPTUTL
S DIR("A")="Are you sure you want to delete the entire 801 for "_Y
S DIR(0)="Y",DIR("B")="No" D ^DIR K DIR G ^DGPTFM:'Y,^DGPTFM:'$$LOCK
;patch DG*5.3*912 modifies where the date is being set for deletion. This allows multiple cpt codes to be deleted from 801 in the ptf
S DGI=0
F S DGI=$O(^DGCPT(46,"C",PTF,DGI)) Q:DGI'>0 D:+^DGCPT(46,DGI,1)=+DGZPRF(DGZP)&'$G(^(9))
.D NOW^%DTC S (DA,REC)=DGI,DIE="^DGCPT(46,",DR="1////^S X=%" D FMDIE
S DR=".09////1",DIE="^DGPT("_PTF_",""C"",",DA=DGZPRF(DGZP,0)
S DA(1)=PTF D ^DIE L -^DGPT(PTF)
W !!,"CPT Records....Deleted" H 2
K DIK,DA,DGI,DGPROC,DGPSM,DGPNUM,Y D MOB G ^DGPTFM
NOPROC W !!,*7,"No procedures to delete",! H 3 G ^DGPTFM
N ;ADD CPT CODES TO CPT RECORD
I '$P(DGZPRF,U,3) W !!,"There are no 801 records that can be added to.",*7 H 2 G ^DGPTFM
P1 S DIR("A")="Add to 801 record ",DIR(0)="NO^1:"_$P(DGZPRF,U,3)
S DIR("??")="^D DISP^DGPTUTL1"
D ^DIR K DIR G ^DGPTFM:'Y
S DGZP=Y,DGI=0,DGPRD=+DGZPRF(DGZP) D CL^SDCO21(DFN,DGPRD,"",.SDCLY)
S DA=PTF,DIC="^DGCPT(46,",DIC(0)="AELQMZ",DLAYGO=46,DIC("S")="D EN6^DGPTFJC I 'DGER"
D ^DIC K DIC,DLAYGO D:Y>0 SED,MOB,REQ^DGPTFM3 K DGPRD,Y
D PCE^DGPTFQWK G ^DGPTFM
DC ;DELETE A CPT PROCEDURE
I $E($G(ANS),2,99)>0 S DGPZ=+$E(ANS,2,99) G QQ
S DIR("A")="Select 801 record to Delete a CPT code in"
S DIR(0)="NO^1:"_$P(DGZPRF,U,3),DIR("??")="^D DISP^DGPTUTL1"
D ^DIR K DIR G ^DGPTFM:$D(DIRUT),^DGPTFM:'Y,^DGPTFM:'$D(^DGPT(PTF,"C",DGZPRF(Y,0),0)) S DGZP=Y,Y=+^(0) D D^DGPTUTL
F PS2=1:1 Q:'$D(DGZPRF(DGZP,PS2)) S PS2(PS2)=DGZP_"^"_PS2
S PS2=PS2-1
QQ S DIR("A")="Select CPT code to Delete <1 - "_PS2_">",DIR(0)="NO^^K:X<1!(X>"_PS2_") X" D ^DIR K DIR G ^DGPTFM:$D(DIRUT),^DGPTFM:'Y
QQA S A1=Y,DGZP=+PS2(A1),CPT=+DGZPRF(DGZP,$P(PS2(A1),U,2))
S DIR("A")="Are you sure you want to delete CPT code '"
I $D(^ICPT(CPT)) D
.S N=$$CPT^ICPTCOD(CPT,$$GETDATE^ICDGTDRG(PTF))
.S N=$S(N>0:$P(N,U,2,99),1:"")
.S DIR("A")=DIR("A")_$P(N,U)_" "_$P(N,U,2)_"'"
E S DIR("A")=DIR("A")_CPT_" UNKNOWN"
S DIR(0)="Y",DIR("B")="No" D ^DIR K DIR G ^DGPTFM:'Y
G ^DGPTFM:'$$LOCK
QEL D NOW^%DTC S DA=DGZPRF(DGZP,$P(PS2(A1),U,2),0),DR="1////^S X=%"
S REC=DGZPRF(DGZP,0)
S DIE="^DGCPT(46," D FMDIE K A1,DR W !!,"CPT Code....Deleted"
I '$D(DGZPRF(DGZP,2)) S DR=".09////1",DIE="^DGPT("_PTF_",""C"",",DA=DGZPRF(DGZP,0),DA(1)=PTF D ^DIE
I $D(DGZPRF(DGZP,2)) D PCE^DGPTFQWK
L -^DGPT(PTF) W:$X>70 ! D MOB H 2 G ^DGPTFM
F D MOB S DGZP=$S($E($G(ANS),2,99):+$E($G(ANS),2,99),1:1) G SET
MOB S (H,I,N)=0 K DGZPRF F M=1:1:6 S:$D(SDCLY(M)) N=N+1
F I2=1:1 S H=$O(^DGPT(PTF,"C","B",H)) Q:H'>0 D
.F S I=$O(^DGPT(PTF,"C","B",H,I)) Q:I'>0 D
..S DGZPRF(I2)=^DGPT(PTF,"C",I,0),DGZPRF(I2,0)=I,(K,K1)=0,F=1 D
...F S K=$O(^DGCPT(46,"C",PTF,K)),L=N+1\2+3 Q:K'>0 I +DGZPRF(I2)=+$G(^DGCPT(46,K,1)),'$G(^DGCPT(46,K,9)) D
....S K1=K1+1,DGZPRF(I2,K1)=^(0),DGZPRF(I2,K1,0)=K,F=0
....F M=2,3,5,6,7,15,16,17,18 S:$P(DGZPRF(I2,K1),U,M) L=L+1
....S DGZPRF(I2,K1,1)=L
...I F,$G(DGPSM)'=DGZPRF(I2,0) K DGZPRF(I2) S I2=I2-1
S DGZPRF="1^1^"_(I2-1) K F,I,K,K1,N Q
SED S DR=".14////"_DGPRD_";.16////"_PTF_";",(DA,REC)=+Y,DIE="^DGCPT(46," D GETINFO^DGPTFM21 Q
FMDIE ;Prompt user for questions and file answers (using DIE)
D ^DIE Q:$D(Y)>9 S RES=$$DELVFILE^DGAPI1(DFN,PTF,DGZP) K DIE,REC Q
LOCK() L +^DGPT(PTF):2 I Q 1
ERR W !,"CPT Record is being edited by another user" K DIE,REC H 2 Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTFM2 8285 printed Sep 23, 2025@20:28:12 Page 2
DGPTFM2 ;ALB/DWS - MASTER PROFESSIONAL SERVICE ENTER/EDIT ;6/16/05 8:33am
+1 ;;5.3;Registration;**517,590,606,635,850,912,1057**;Aug 13, 1993;Build 17
ADD ;ADD CPT RECORD
+1 NEW DGZP
SET DGZP=0
if '$DATA(^DGPT(PTF,"C",0))
SET ^(0)="^45.06D^^"
+2 SET DIC="^DGPT("_PTF_",""C"","
SET DIC(0)="AELQMXZ"
SET DA(1)=PTF
SET DLAYGO=45
+3 DO ^DIC
KILL DIC,DLAYGO
if Y'>0
GOTO ^DGPTFM
if '$DATA(^DGPT(PTF,"C",+Y))
GOTO ^DGPTFM
+4 SET DGPSM=+Y
+5 IF '$PIECE(Y,U,3)
SET DIR("A")="Do you want to edit this CPT RECORD DATE/TIME?"
SET DIR(0)="Y"
SET DIR("B")="YES"
DO ^DIR
if 'Y!$DATA(DIRUT)
GOTO ^DGPTFM
+6 DO MOB
+7 IF $PIECE(DGZPRF,U,3)
FOR I=1:1:$PIECE(DGZPRF,U,3)
if DGZPRF(I,0)=DGPSM
SET DGZP=I
+8 KILL I
if 'DGZP
GOTO ^DGPTFM
SET X="A,B"
SET DGPSM=0
ED if X'["A"&(X'["B")&(X'["a")&(X'["b")
GOTO HELP^DGPTUTL1
KILL DA
+1 SET DGJUMP=X
SET DGPRD=+DGZPRF(DGZP)
SET X1="^801"
+2 IF X["A"!(X["a")
Begin DoDot:1
+3 SET DA(1)=PTF
SET DIE="^DGPT("_PTF_",""C"","
SET (DA,REC)=DGZPRF(DGZP,0)
+4 SET DR=".01;.02;.03;.05;.09////0"
SET DIC(0)="AELQZ"
if '$$LOCK
QUIT
+5 DO FMDIE
SET FLAG=$DATA(Y)>9!$DATA(DOUT)!'$DATA(DA)
if $DATA(Y)>9!'$DATA(DA)
QUIT
+6 SET DGPRD=+^DGPT(PTF,"C",DGZPRF(DGZP,0),0)
if +DGZPRF(DGZP)=DGPRD
QUIT
+7 SET DGI=0
FOR
SET DGI=$ORDER(^DGCPT(46,"C",PTF,DGI))
if DGI'>0
QUIT
Begin DoDot:2
+8 if +^DGCPT(46,DGI,1)'=+DGZPRF(DGZP)
QUIT
if $DATA(^(9))
QUIT
+9 SET DR=".14////"_DGPRD
SET (DA,REC)=DGI
SET DIE="^DGCPT(46,"
DO FMDIE
+10 IF $DATA(Y)>9!'$DATA(DA)
SET FLAG=1
+11 ;ADD IMPDATE check to see if Edit on date changed coding system
End DoDot:2
if $DATA(Y)>9!'$DATA(DA)
QUIT
+12 IF $PIECE(DGZPRF(DGZP),U)<IMPDATE
IF DGPRD'<IMPDATE
DO EN^DDIOL("Primary Diagnosis changing from ICD-9 to ICD-10. You must edit the Diagnosis.")
SET DGJUMP="B"
+13 IF $PIECE(DGZPRF(DGZP),U)'<IMPDATE
IF DGPRD<IMPDATE
DO EN^DDIOL("Primary Diagnosis changing from ICD-10 to ICD-9. You must edit the Diagnosis.")
SET DGJUMP="B"
+14 SET $PIECE(DGZPRF(DGZP),U)=DGPRD
End DoDot:1
LOCK -^DGPT(PTF)
IF FLAG
DO MOB
DO REQ^DGPTFM3
GOTO EXIT
JUMP IF DGJUMP["B"!(DGJUMP["b")
SET DGI=0
DO CL^SDCO21(DFN,DGPRD,"",.SDCLY)
Begin DoDot:1
+1 FOR
SET DGI=$ORDER(^DGCPT(46,"C",PTF,DGI))
if DGI'>0
QUIT
IF +^DGCPT(46,DGI,1)=+DGZPRF(DGZP)
IF '$GET(^(9))
Begin DoDot:2
+2 SET (DA,REC)=DGI
SET DR=".01;"
SET DIE="^DGCPT(46,"
DO GETINFO^DGPTFM21
End DoDot:2
IF $DATA(DUOUT)
if 'DGDIAG
QUIT
KILL DUOUT
SET DGI=0
+3 if $DATA(DUOUT)
QUIT
+4 FOR
Begin DoDot:2
+5 SET DA=PTF
SET DIC="^DGCPT(46,"
SET DIC(0)="AELMQZ"
SET DLAYGO=46
+6 SET DIC("S")="D EN6^DGPTFJC I 'DGER"
End DoDot:2
DO ^DIC
SET A=0
if Y'>0
QUIT
DO SED
if $DATA(DUOUT)
QUIT
End DoDot:1
+7 IF $DATA(DUOUT)
IF $GET(DGDIAG)
KILL DUOUT
GOTO JUMP
+8 IF $DATA(DUOUT)
IF $GET(DGJUMP)["A"!($GET(DGJUMP)["a")
SET X=DGJUMP
KILL DUOUT
GOTO ED
+9 KILL DR,DIE,DIC,DA,DGI,DGJUMP,DGPRD,DLAYGO,XREF
+10 DO REQ^DGPTFM3
DO MOB
if RFL
HANG 2
KILL RFL
+11 if '$DATA(DGZPRF(DGZP,0))
GOTO ^DGPTFM
if '$DATA(^DGPT(PTF,"C",DGZPRF(DGZP,0)))
GOTO ^DGPTFM
SET if '$DATA(DGZPRF)
DO MOB
if '$DATA(DGZP)
SET DGZP=1
IF $GET(DGZPRF(DGZP,0))=""
KILL DGZPRF(DGZP)
GOTO NEXP
WRT if '$DATA(^DGPT(PTF,"C",DGZPRF(DGZP,0),0))
GOTO ^DGPTFM
SET J=DGZP
WRITE @IOF,HEAD,?68
+1 NEW DGNUM
SET Z="<"_DGZP_">"
WRITE @DGVI,Z,@DGVO
+2 ; DG*5.3*1057
WRITE !,?30,"Initial Date Of Service: ",$$EXTERNAL^DILFD(45,14,,$GET(DGIDTS))
+3 WRITE !!
SET Y=+DGZPRF(J)
SET Z="A"
+4 DO D^DGPTUTL
DO Z^DGPTFM5
WRITE ?5,"CPT Record Date/Time: ",Y
+5 IF $PIECE(DGZPRF(J),U,8)'=""
WRITE ?55,"Visit Service Category: ",$PIECE(DGZPRF(J),U,8)
+6 IF $PIECE(DGZPRF(J),U,2)
WRITE !,?5,"Referring or Ordering Provider: "
Begin DoDot:1
+7 SET L=$PIECE(DGZPRF(J),U,2)
DO PRV^DGPTFM
End DoDot:1
+8 WRITE !,?5,"Rendering Provider: "
SET L=$PIECE(DGZPRF(J),U,3)
DO PRV^DGPTFM
+9 IF $PIECE(DGZPRF(J),U,5)
WRITE !,?5,"Rendering Location: ",$PIECE($GET(^SC($PIECE(DGZPRF(J),U,5),0)),U)
+10 WRITE !!
SET Z="B"
DO Z^DGPTFM5
WRITE " Procedures: "
+11 FOR K=$PIECE(DGZPRF,U,2):1
if '$DATA(DGZPRF(J,K))
QUIT
IF '$DATA(DGZPRF(J,K,9))
Begin DoDot:1
+12 WRITE ?5
DO CPT^DGPTUTL1
WRITE !
if $Y>16
QUIT
End DoDot:1
+13 FOR I=1:1:(IOSL-$Y-5)
WRITE !
+14 KILL I,J,K,L,Z
SET DGNUM=$SELECT($DATA(DGZPRF(DGZP+1)):DGZP+1,1:"MAS")
+15 if DGST
GOTO 801^DGPTFJC
+16 SET DIR("A")="Enter <RET> to continue, A-B to edit, 'I' to add an 801,"
+17 SET DIR("A")=DIR("A")_$CHAR(10,13)_"the number of an 801 screen, ?? to list 801 screens,"
+18 SET DIR("A")=DIR("A")_$CHAR(10,13)_"'S' for Send to PCE,"
+19 SET DIR("A")=DIR("A")_" '^N' for screen N, or '^' to abort:"
+20 SET DIR("?")="^D HELP^DGPTUTL1"
+21 SET DIR(0)="F^OU"
SET DIR("B")=DGNUM
SET DIR("??")="^D DISP^DGPTUTL1"
DO ^DIR
+22 KILL DIR
if $DATA(DIRUT)
if X="^"
GOTO Q^DGPTF
+23 IF X?1"^".E
SET DGPTSCRN=801
GOTO ^DGPTFJ
+24 IF X="MAS"
SET DGZP=1
GOTO ^DGPTFM
+25 if X="I"!(X="i")
GOTO ADD
if X["?"
GOTO HELP^DGPTUTL1
+26 IF X?1N.N
IF $DATA(DGZPRF(X))
SET DGZP=X
GOTO SET
+27 IF X["A"!(X["B")!(X["a")!(X["b")
GOTO ED
+28 IF X="S"!(X="s")
DO PCE
GOTO WRT
+29 DO HELP^DGPTUTL1
READ !!,"Enter <RET>: ",X:DTIME
GOTO WRT
PCE LOCK +^DGPT(PTF):2
+1 IF '$TEST
WRITE !,"CPT Record is being edited by another user"
HANG 2
QUIT
+2 DO ICDINFO^DGAPI(DFN,PTF)
DO XREF^DGPTFM21
+3 SET RES=$$DATA2PCE^DGAPI1(DFN,PTF,DGZP)
+4 IF RES=1
LOCK -^DGPT(PTF)
WRITE !,"PTF Record sent to PCE"
HANG 2
QUIT
+5 WRITE @IOF
+6 ;F I=1:1 Q:'$D(^TMP("DGPAPI",$J,"DIERR",$J,1,"TEXT",I)) W !,^(I)
+7 WRITE !,"The PTF Record may not have been filed in PCE due to errors."
+8 WRITE !,"Press return to continue."
READ X:DTIME
+9 LOCK -^DGPT(PTF)
QUIT
NEXP SET DGZP=DGZP+1
+1 IF '$DATA(DGZPRF(DGZP))
if DGZP=2
WRITE !,"NO PROF. SERVICES TO EDIT."
GOTO EXIT
+2 GOTO SET
EXIT KILL DGPSM
HANG 2
SET DGZP=1
GOTO ^DGPTFM
DEL ;DELETE A CPT RECORD
+1 IF '$PIECE(DGZPRF,U,3)
GOTO NOPROC
ASK SET DIR("A")="Select 801 record to Delete"
+1 SET DIR(0)="NO^1:"_$PIECE(DGZPRF,U,3)
SET DIR("??")="^D DISP^DGPTUTL1"
+2 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO ^DGPTFM
if 'Y
GOTO ^DGPTFM
if '$DATA(^DGPT(PTF,"C",DGZPRF(Y,0),0))
GOTO ^DGPTFM
SET DGZP=Y
SET Y=+^(0)
DO D^DGPTUTL
+3 SET DIR("A")="Are you sure you want to delete the entire 801 for "_Y
+4 SET DIR(0)="Y"
SET DIR("B")="No"
DO ^DIR
KILL DIR
if 'Y
GOTO ^DGPTFM
if '$$LOCK
GOTO ^DGPTFM
+5 ;patch DG*5.3*912 modifies where the date is being set for deletion. This allows multiple cpt codes to be deleted from 801 in the ptf
+6 SET DGI=0
+7 FOR
SET DGI=$ORDER(^DGCPT(46,"C",PTF,DGI))
if DGI'>0
QUIT
if +^DGCPT(46,DGI,1)=+DGZPRF(DGZP)&'$GET(^(9))
Begin DoDot:1
+8 DO NOW^%DTC
SET (DA,REC)=DGI
SET DIE="^DGCPT(46,"
SET DR="1////^S X=%"
DO FMDIE
End DoDot:1
+9 SET DR=".09////1"
SET DIE="^DGPT("_PTF_",""C"","
SET DA=DGZPRF(DGZP,0)
+10 SET DA(1)=PTF
DO ^DIE
LOCK -^DGPT(PTF)
+11 WRITE !!,"CPT Records....Deleted"
HANG 2
+12 KILL DIK,DA,DGI,DGPROC,DGPSM,DGPNUM,Y
DO MOB
GOTO ^DGPTFM
NOPROC WRITE !!,*7,"No procedures to delete",!
HANG 3
GOTO ^DGPTFM
N ;ADD CPT CODES TO CPT RECORD
+1 IF '$PIECE(DGZPRF,U,3)
WRITE !!,"There are no 801 records that can be added to.",*7
HANG 2
GOTO ^DGPTFM
P1 SET DIR("A")="Add to 801 record "
SET DIR(0)="NO^1:"_$PIECE(DGZPRF,U,3)
+1 SET DIR("??")="^D DISP^DGPTUTL1"
+2 DO ^DIR
KILL DIR
if 'Y
GOTO ^DGPTFM
+3 SET DGZP=Y
SET DGI=0
SET DGPRD=+DGZPRF(DGZP)
DO CL^SDCO21(DFN,DGPRD,"",.SDCLY)
+4 SET DA=PTF
SET DIC="^DGCPT(46,"
SET DIC(0)="AELQMZ"
SET DLAYGO=46
SET DIC("S")="D EN6^DGPTFJC I 'DGER"
+5 DO ^DIC
KILL DIC,DLAYGO
if Y>0
DO SED
DO MOB
DO REQ^DGPTFM3
KILL DGPRD,Y
+6 DO PCE^DGPTFQWK
GOTO ^DGPTFM
DC ;DELETE A CPT PROCEDURE
+1 IF $EXTRACT($GET(ANS),2,99)>0
SET DGPZ=+$EXTRACT(ANS,2,99)
GOTO QQ
+2 SET DIR("A")="Select 801 record to Delete a CPT code in"
+3 SET DIR(0)="NO^1:"_$PIECE(DGZPRF,U,3)
SET DIR("??")="^D DISP^DGPTUTL1"
+4 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO ^DGPTFM
if 'Y
GOTO ^DGPTFM
if '$DATA(^DGPT(PTF,"C",DGZPRF(Y,0),0))
GOTO ^DGPTFM
SET DGZP=Y
SET Y=+^(0)
DO D^DGPTUTL
+5 FOR PS2=1:1
if '$DATA(DGZPRF(DGZP,PS2))
QUIT
SET PS2(PS2)=DGZP_"^"_PS2
+6 SET PS2=PS2-1
QQ SET DIR("A")="Select CPT code to Delete <1 - "_PS2_">"
SET DIR(0)="NO^^K:X<1!(X>"_PS2_") X"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO ^DGPTFM
if 'Y
GOTO ^DGPTFM
QQA SET A1=Y
SET DGZP=+PS2(A1)
SET CPT=+DGZPRF(DGZP,$PIECE(PS2(A1),U,2))
+1 SET DIR("A")="Are you sure you want to delete CPT code '"
+2 IF $DATA(^ICPT(CPT))
Begin DoDot:1
+3 SET N=$$CPT^ICPTCOD(CPT,$$GETDATE^ICDGTDRG(PTF))
+4 SET N=$SELECT(N>0:$PIECE(N,U,2,99),1:"")
+5 SET DIR("A")=DIR("A")_$PIECE(N,U)_" "_$PIECE(N,U,2)_"'"
End DoDot:1
+6 IF '$TEST
SET DIR("A")=DIR("A")_CPT_" UNKNOWN"
+7 SET DIR(0)="Y"
SET DIR("B")="No"
DO ^DIR
KILL DIR
if 'Y
GOTO ^DGPTFM
+8 if '$$LOCK
GOTO ^DGPTFM
QEL DO NOW^%DTC
SET DA=DGZPRF(DGZP,$PIECE(PS2(A1),U,2),0)
SET DR="1////^S X=%"
+1 SET REC=DGZPRF(DGZP,0)
+2 SET DIE="^DGCPT(46,"
DO FMDIE
KILL A1,DR
WRITE !!,"CPT Code....Deleted"
+3 IF '$DATA(DGZPRF(DGZP,2))
SET DR=".09////1"
SET DIE="^DGPT("_PTF_",""C"","
SET DA=DGZPRF(DGZP,0)
SET DA(1)=PTF
DO ^DIE
+4 IF $DATA(DGZPRF(DGZP,2))
DO PCE^DGPTFQWK
+5 LOCK -^DGPT(PTF)
if $X>70
WRITE !
DO MOB
HANG 2
GOTO ^DGPTFM
F DO MOB
SET DGZP=$SELECT($EXTRACT($GET(ANS),2,99):+$EXTRACT($GET(ANS),2,99),1:1)
GOTO SET
MOB SET (H,I,N)=0
KILL DGZPRF
FOR M=1:1:6
if $DATA(SDCLY(M))
SET N=N+1
+1 FOR I2=1:1
SET H=$ORDER(^DGPT(PTF,"C","B",H))
if H'>0
QUIT
Begin DoDot:1
+2 FOR
SET I=$ORDER(^DGPT(PTF,"C","B",H,I))
if I'>0
QUIT
Begin DoDot:2
+3 SET DGZPRF(I2)=^DGPT(PTF,"C",I,0)
SET DGZPRF(I2,0)=I
SET (K,K1)=0
SET F=1
Begin DoDot:3
+4 FOR
SET K=$ORDER(^DGCPT(46,"C",PTF,K))
SET L=N+1\2+3
if K'>0
QUIT
IF +DGZPRF(I2)=+$GET(^DGCPT(46,K,1))
IF '$GET(^DGCPT(46,K,9))
Begin DoDot:4
+5 SET K1=K1+1
SET DGZPRF(I2,K1)=^(0)
SET DGZPRF(I2,K1,0)=K
SET F=0
+6 FOR M=2,3,5,6,7,15,16,17,18
if $PIECE(DGZPRF(I2,K1),U,M)
SET L=L+1
+7 SET DGZPRF(I2,K1,1)=L
End DoDot:4
+8 IF F
IF $GET(DGPSM)'=DGZPRF(I2,0)
KILL DGZPRF(I2)
SET I2=I2-1
End DoDot:3
End DoDot:2
End DoDot:1
+9 SET DGZPRF="1^1^"_(I2-1)
KILL F,I,K,K1,N
QUIT
SED SET DR=".14////"_DGPRD_";.16////"_PTF_";"
SET (DA,REC)=+Y
SET DIE="^DGCPT(46,"
DO GETINFO^DGPTFM21
QUIT
FMDIE ;Prompt user for questions and file answers (using DIE)
+1 DO ^DIE
if $DATA(Y)>9
QUIT
SET RES=$$DELVFILE^DGAPI1(DFN,PTF,DGZP)
KILL DIE,REC
QUIT
LOCK() LOCK +^DGPT(PTF):2
IF $TEST
QUIT 1
ERR WRITE !,"CPT Record is being edited by another user"
KILL DIE,REC
HANG 2
QUIT 0
