PXBPCPT ;ISL/JVS,ESW - PROMPT CPT ; 4/23/03 7:15pm
;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,89,112**;Aug 12, 1996
;
;
;
CPT ;--CPT CODE
;SELINE=LINE NUMBER OF SELECTED ITEM
N TIMED,PXBUT,EDATA,DIC,LINE,XFLAG,SELINE
N I,X,Y,Q,DOUBLEQQ,NF,BAD,OK,CPT,PXEDIT
I '$D(^DISV(DUZ,"PXBCPT-1")) S ^DISV(DUZ,"PXBCPT-1")=" "
I '$D(IOSC) D TERM^PXBCC
S DOUBLEQQ=0,PXEDIT=""
S TIMED="I '$T!(DATA[""^"")!(DATA="""")"
S DIC("S")="I $$CPTSCREN^PXBUTL(Y,IDATE)"
C ;--SECOND ENTRY POINT
W IOSC
;---DYNAMIC HEADER-----------------
I '$D(CYCL) D
.I PXBCNT=0,DOUBLEQQ=0 D LOC^PXBCC(2,10) W IOUON,"...There are "_$G(PXBCNT)_" PROCEDURES associated with this encounter.",IOUOFF,IOELEOL
.I PXBCNT=1,DOUBLEQQ=0 D LOC^PXBCC(2,10) W IOUON,"...There is "_$G(PXBCNT)_" PROCEDURE associated with this encounter.",IOUOFF,IOELEOL
.I PXBCNT>1,DOUBLEQQ=0 D LOC^PXBCC(2,10) W IOUON,"...There are "_$G(PXBCNT)_" PROCEDURES associated with this encounter.",IOUOFF,IOELEOL
;
D LOC^PXBCC(15,0)
;I PXBCNT>30
;W IOCUU,IOELEOL,
W:PXTLNS>10 !,"Enter '+' for next page, '-' for last page." ;,IORC
D WIN17^PXBCC(PXBCNT)
I '$D(^TMP("PXK",$J,"CPT")) W !,"Enter PROCEDURE (CPT CODE): "
I $D(^TMP("PXK",$J,"CPT")) W !,"Enter ",IOINHI,"NEXT",IOINLOW," PROCEDURE (CPT CODE): "
W IOELEOL R DATA:DTIME S EDATA=DATA
C1 ;----Third entry point
X TIMED I S PXBUT=1 S:DATA="^^" PXBEXIT=0 S:DATA="^^^" PXBRRR="" G CPTX
I DATA?1.N1"E".NAP S DATA=" "_DATA
I $L(DATA)>200 S (DATA,EDATA)=$E(DATA,1,199)
I DATA?24.N S (DATA,EDATA)=$E(DATA,1,24)
D CASE^PXBUTL
;----SPACE BAR---
I DATA=" ",$D(^DISV(DUZ,"PXBCPT-1")) S DATA=^DISV(DUZ,"PXBCPT-1") W DATA
;---------------
I DATA["^P" G CPTX
I DATA["^C" G CPTX
;
I ((DATA="+")!(DATA="-")) D DISCPT4^PXBDCPT(DATA) G C
;
M ;--------If Multiple entries have been entered
D ADDM^PXBPCPT1
I $G(NF) G C1
;
DEL ;--------If Multiple deleting
D DELM^PXBPCPT1
I DATA["^C" G CPTX
I $G(NF) G C1
;
D MOD
;
LI ;--------If picked a line number display
;
I (DATA>0)&(DATA<(PXBCNT+1))&($L(DATA)'>$L(PXBCNT)) D
.S XFLAG=1
.D DISCPT4^PXBDCPT(PXBSAM(DATA,"LINE"))
.D REVCPT^PXBCC(DATA,1)
.S SELINE=DATA
.F I=1:1:$L(DATA) W IOCUB,IOECH
.S CPTQUA=$P($G(PXBSAM(DATA)),"^",2)
.S DATA=$P($G(PXBSAM(DATA)),"^",1)
.;I $G(Q)'>1 W DATA
I $D(XFLAG),XFLAG=1 S Y=DATA G FIN
;
;
;--------If CPT is already in the file
I $D(PXBKY(DATA)) D I +PXEDIT<0 S DATA="^C" G C1
.D DISCPT4^PXBDCPT(PXBSAM($O(PXBKY(DATA,0)),"LINE"))
.K Q
.D TIMES^PXBUTL(DATA)
.S PXEDIT=$$MULTI(DATA) Q:+PXEDIT<0
.I Q=1 D
..S LINE=$O(PXBKY(DATA,0))
..S XFLAG=1
..Q:PXEDIT="A"
..D REVCPT^PXBCC(LINE,1)
..S CPTQUA=$P($G(PXBSAM(LINE)),"^",2)
..S SELINE=$O(Q(0))
.I Q>1,PXEDIT="E" D
..N PXPG
..S NLINE=0
..S PXPG=+$G(^TMP("PXBDCPT",$J,"START"))+10
..F S NLINE=$O(Q(NLINE)) Q:NLINE="" Q:PXBSAM(NLINE,"LINE")>PXPG D
...D REVCPT^PXBCC(NLINE,1)
I '$G(Q) K SELINE
I PXEDIT="E",$D(Q),Q>1 D G:DATA="^C" C1 G LI
.D WHICH^PXBPWCH S:DATA["^" DATA="^C"
I $D(XFLAG),XFLAG=1 S Y=DATA G FIN
;
;--------Need to do a DIC lookup on data
I DATA'="??" D G:DATA="^C" C I DATA="?" G C
.D:DATA="?" EN1^PXBHLP0("PXB","CPT",1,"",1)
I DATA="??" D G:UDATA="^C" C1 G FIN
.S DOUBLEQQ=1
.D EN1^PXBHLP0("PXB","CPT","",1,2)
.I $L(DATA,"^")>1 D
..S DATA=+$P(DATA,"^",2)_$S($P(DATA,U,3)]"":"-"_$P(DATA,U,3),1:"")
..D MOD
..S Y=DATA
.S:$G(UDATA)="" UDATA="^C"
.S:UDATA="^C" (DATA,EDATA,Y)=UDATA
;
;--If a "?" is NOT entered during lookup
S FROM="CPT",(VAL,Y)=$P($P($$DOUBLE1^PXBGCPT2(FROM),"^",2),"--",1)
S (X,DATA,EDATA)=VAL,DIC=81,DIC(0)="MZ" D ^DIC
I Y<1 S DATA="^C" G C1
;
;--If Y is good and already in file...
I $D(Y),$D(PXBKY(Y)) W IORC,IOCUU,IOEDEOP,! D
.D DISCPT4^PXBDCPT($O(PXBKY($P(Y,"^",2),0)))
.S LINE=$O(PXBKY($P(Y,"^",2),0)) D REVCPT^PXBCC(LINE,1)
.S CPTQUA=$P($G(PXBSAM(LINE)),"^",2)
;
;
FIN ;--FINISH CPT
I $G(SELINE) S $P(REQE,"^",1)=$P($G(PXBSAM(SELINE)),"^",3)
I $P(REQE,"^",1)="" S $P(REQE,"^",1)="...No Provider Selected..."
I $L(Y,"^")'>1 S X=Y,DIC=81,DIC(0)="ZM" D ^DIC
I Y<0 D HELP^PXBUTL0("CPTM") G C
S OK=$$CPTOK^PXBUTL(+Y,IDATE) D G:+OK=0 C
.I +OK=0 W IOCUF,IOCUF,IORVON,"INACTIVE!--",IORVOFF D HELP1^PXBUTL1("CPTI") ;--HELP
S CPT=Y(0)
S ^DISV(DUZ,"PXBCPT-1")=$P(CPT,"^",1)
I $D(PXBNCPT) S PXBNCPTF=1
I $D(PXBKY(Y(0,0))),$G(SELINE) D
.S $P(REQI,"^",8)=$O(PXBSKY(SELINE,0))
.S PREDOC=$P(PXBSAM(SELINE),"^",3)
.I $D(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1))) D
..Q:$P(REQI,"^",8)]""
..S $P(REQI,"^",8)=$O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),0))
.I $D(PXBPRV($P(REQE,"^",1))) D
..S CPTQUA=$P(PXBSAM($O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),$O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),0)),0))),"^",2)
I $D(PXBKY(Y(0,0))),'$G(SELINE) D
.;S $P(REQI,"^",8)=$O(PXBSKY($O(PXBKY(Y(0,0),0)),0))
.S PREDOC=$P(PXBSAM($O(PXBKY(Y(0,0),0))),"^",3)
.I $D(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1))) D
..S $P(REQI,"^",8)=$O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),0))
.I $D(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1))) D
..S CPTQUA=$P(PXBSAM($O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),$O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),0)),0))),"^",2)
S $P(REQI,"^",3)=+Y
S $P(REQE,"^",3)=$P(CPT,"^",1)_"-- "_$P(CPT,"^",2)
S PXBNCPT($P(CPT,"^",1))=$P(REQI,"^",8)
S:$P(REQI,"^",8)]"" PXBNCPT($P(CPT,"^",1),$P(REQI,"^",8))=""
;
CPTX ;--CPT Exit and cleanup
I $P(REQE,"^",1)="" S $P(REQE,"^",1)="...No Provider Selected..."
I $G(WHAT)="INTV",DATA="^" S PXBEXIT="^^"
I $D(PXBRRR) S DATA="^"
I $D(PREDOC) D
.I PREDOC]""&($P(REQE,"^",1)'[PREDOC) W !,IOINHI,"--WARNING!",IOINLOW," Currently stored Provider of service:-",IOINHI,PREDOC,IOINLOW D
..I '$D(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1))) S $P(REQI,"^",8)=""
K PXBDPRV,PREDOC
W IOEDEOP
Q
MOD ;---Separate CPT modifiers from CPT codes in entry string, if entered
I DATA?1.N1"-".NE D
.S PXMODSTR=$P(DATA,"-",2)
.S (DATA,EDATA)=$P(DATA,"-",1)
Q
;
MULTI(CPTCD) ;--Prompt user to Edit existing CPT code or Add as new entry
;
N DIR,DA,X,Y
S DIR(0)="SB^E:EDIT;A:ADD"
S DIR("A")="Do you wish to (E)dit or (A)dd"
I $D(^IBE(357.69,+CPTCD)) S DIR(0)="SB^E:EDIT",DIR("A")="You may only (E)dit this code, no duplicate E&M allowed."
S DIR("A",1)="CPT "_CPTCD_" already on file for this Encounter"
D ^DIR
I Y']""!(Y="^") Q -1
Q Y
PXBPCPT ;ISL/JVS,ESW - PROMPT CPT ; 4/23/03 7:15pm
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,89,112**;Aug 12, 1996
+2 ;
+3 ;
+4 ;
CPT ;--CPT CODE
+1 ;SELINE=LINE NUMBER OF SELECTED ITEM
+2 NEW TIMED,PXBUT,EDATA,DIC,LINE,XFLAG,SELINE
+3 NEW I,X,Y,Q,DOUBLEQQ,NF,BAD,OK,CPT,PXEDIT
+4 IF '$DATA(^DISV(DUZ,"PXBCPT-1"))
SET ^DISV(DUZ,"PXBCPT-1")=" "
+5 IF '$DATA(IOSC)
DO TERM^PXBCC
+6 SET DOUBLEQQ=0
SET PXEDIT=""
+7 SET TIMED="I '$T!(DATA[""^"")!(DATA="""")"
+8 SET DIC("S")="I $$CPTSCREN^PXBUTL(Y,IDATE)"
C ;--SECOND ENTRY POINT
+1 WRITE IOSC
+2 ;---DYNAMIC HEADER-----------------
+3 IF '$DATA(CYCL)
Begin DoDot:1
+4 IF PXBCNT=0
IF DOUBLEQQ=0
DO LOC^PXBCC(2,10)
WRITE IOUON,"...There are "_$GET(PXBCNT)_" PROCEDURES associated with this encounter.",IOUOFF,IOELEOL
+5 IF PXBCNT=1
IF DOUBLEQQ=0
DO LOC^PXBCC(2,10)
WRITE IOUON,"...There is "_$GET(PXBCNT)_" PROCEDURE associated with this encounter.",IOUOFF,IOELEOL
+6 IF PXBCNT>1
IF DOUBLEQQ=0
DO LOC^PXBCC(2,10)
WRITE IOUON,"...There are "_$GET(PXBCNT)_" PROCEDURES associated with this encounter.",IOUOFF,IOELEOL
End DoDot:1
+7 ;
+8 DO LOC^PXBCC(15,0)
+9 ;I PXBCNT>30
+10 ;W IOCUU,IOELEOL,
+11 ;,IORC
IF PXTLNS>10
WRITE !,"Enter '+' for next page, '-' for last page."
+12 DO WIN17^PXBCC(PXBCNT)
+13 IF '$DATA(^TMP("PXK",$JOB,"CPT"))
WRITE !,"Enter PROCEDURE (CPT CODE): "
+14 IF $DATA(^TMP("PXK",$JOB,"CPT"))
WRITE !,"Enter ",IOINHI,"NEXT",IOINLOW," PROCEDURE (CPT CODE): "
+15 WRITE IOELEOL
READ DATA:DTIME
SET EDATA=DATA
C1 ;----Third entry point
+1 XECUTE TIMED
IF $TEST
SET PXBUT=1
IF DATA="^^"
SET PXBEXIT=0
IF DATA="^^^"
SET PXBRRR=""
GOTO CPTX
+2 IF DATA?1.N1"E".NAP
SET DATA=" "_DATA
+3 IF $LENGTH(DATA)>200
SET (DATA,EDATA)=$EXTRACT(DATA,1,199)
+4 IF DATA?24.N
SET (DATA,EDATA)=$EXTRACT(DATA,1,24)
+5 DO CASE^PXBUTL
+6 ;----SPACE BAR---
+7 IF DATA=" "
IF $DATA(^DISV(DUZ,"PXBCPT-1"))
SET DATA=^DISV(DUZ,"PXBCPT-1")
WRITE DATA
+8 ;---------------
+9 IF DATA["^P"
GOTO CPTX
+10 IF DATA["^C"
GOTO CPTX
+11 ;
+12 IF ((DATA="+")!(DATA="-"))
DO DISCPT4^PXBDCPT(DATA)
GOTO C
+13 ;
M ;--------If Multiple entries have been entered
+1 DO ADDM^PXBPCPT1
+2 IF $GET(NF)
GOTO C1
+3 ;
DEL ;--------If Multiple deleting
+1 DO DELM^PXBPCPT1
+2 IF DATA["^C"
GOTO CPTX
+3 IF $GET(NF)
GOTO C1
+4 ;
+5 DO MOD
+6 ;
LI ;--------If picked a line number display
+1 ;
+2 IF (DATA>0)&(DATA<(PXBCNT+1))&($LENGTH(DATA)'>$LENGTH(PXBCNT))
Begin DoDot:1
+3 SET XFLAG=1
+4 DO DISCPT4^PXBDCPT(PXBSAM(DATA,"LINE"))
+5 DO REVCPT^PXBCC(DATA,1)
+6 SET SELINE=DATA
+7 FOR I=1:1:$LENGTH(DATA)
WRITE IOCUB,IOECH
+8 SET CPTQUA=$PIECE($GET(PXBSAM(DATA)),"^",2)
+9 SET DATA=$PIECE($GET(PXBSAM(DATA)),"^",1)
+10 ;I $G(Q)'>1 W DATA
End DoDot:1
+11 IF $DATA(XFLAG)
IF XFLAG=1
SET Y=DATA
GOTO FIN
+12 ;
+13 ;
+14 ;--------If CPT is already in the file
+15 IF $DATA(PXBKY(DATA))
Begin DoDot:1
+16 DO DISCPT4^PXBDCPT(PXBSAM($ORDER(PXBKY(DATA,0)),"LINE"))
+17 KILL Q
+18 DO TIMES^PXBUTL(DATA)
+19 SET PXEDIT=$$MULTI(DATA)
IF +PXEDIT<0
QUIT
+20 IF Q=1
Begin DoDot:2
+21 SET LINE=$ORDER(PXBKY(DATA,0))
+22 SET XFLAG=1
+23 IF PXEDIT="A"
QUIT
+24 DO REVCPT^PXBCC(LINE,1)
+25 SET CPTQUA=$PIECE($GET(PXBSAM(LINE)),"^",2)
+26 SET SELINE=$ORDER(Q(0))
End DoDot:2
+27 IF Q>1
IF PXEDIT="E"
Begin DoDot:2
+28 NEW PXPG
+29 SET NLINE=0
+30 SET PXPG=+$GET(^TMP("PXBDCPT",$JOB,"START"))+10
+31 FOR
SET NLINE=$ORDER(Q(NLINE))
IF NLINE=""
QUIT
IF PXBSAM(NLINE,"LINE")>PXPG
QUIT
Begin DoDot:3
+32 DO REVCPT^PXBCC(NLINE,1)
End DoDot:3
End DoDot:2
End DoDot:1
IF +PXEDIT<0
SET DATA="^C"
GOTO C1
+33 IF '$GET(Q)
KILL SELINE
+34 IF PXEDIT="E"
IF $DATA(Q)
IF Q>1
Begin DoDot:1
+35 DO WHICH^PXBPWCH
IF DATA["^"
SET DATA="^C"
End DoDot:1
IF DATA="^C"
GOTO C1
GOTO LI
+36 IF $DATA(XFLAG)
IF XFLAG=1
SET Y=DATA
GOTO FIN
+37 ;
+38 ;--------Need to do a DIC lookup on data
+39 IF DATA'="??"
Begin DoDot:1
+40 IF DATA="?"
DO EN1^PXBHLP0("PXB","CPT",1,"",1)
End DoDot:1
IF DATA="^C"
GOTO C
IF DATA="?"
GOTO C
+41 IF DATA="??"
Begin DoDot:1
+42 SET DOUBLEQQ=1
+43 DO EN1^PXBHLP0("PXB","CPT","",1,2)
+44 IF $LENGTH(DATA,"^")>1
Begin DoDot:2
+45 SET DATA=+$PIECE(DATA,"^",2)_$SELECT($PIECE(DATA,U,3)]"":"-"_$PIECE(DATA,U,3),1:"")
+46 DO MOD
+47 SET Y=DATA
End DoDot:2
+48 IF $GET(UDATA)=""
SET UDATA="^C"
+49 IF UDATA="^C"
SET (DATA,EDATA,Y)=UDATA
End DoDot:1
IF UDATA="^C"
GOTO C1
GOTO FIN
+50 ;
+51 ;--If a "?" is NOT entered during lookup
+52 SET FROM="CPT"
SET (VAL,Y)=$PIECE($PIECE($$DOUBLE1^PXBGCPT2(FROM),"^",2),"--",1)
+53 SET (X,DATA,EDATA)=VAL
SET DIC=81
SET DIC(0)="MZ"
DO ^DIC
+54 IF Y<1
SET DATA="^C"
GOTO C1
+55 ;
+56 ;--If Y is good and already in file...
+57 IF $DATA(Y)
IF $DATA(PXBKY(Y))
WRITE IORC,IOCUU,IOEDEOP,!
Begin DoDot:1
+58 DO DISCPT4^PXBDCPT($ORDER(PXBKY($PIECE(Y,"^",2),0)))
+59 SET LINE=$ORDER(PXBKY($PIECE(Y,"^",2),0))
DO REVCPT^PXBCC(LINE,1)
+60 SET CPTQUA=$PIECE($GET(PXBSAM(LINE)),"^",2)
End DoDot:1
+61 ;
+62 ;
FIN ;--FINISH CPT
+1 IF $GET(SELINE)
SET $PIECE(REQE,"^",1)=$PIECE($GET(PXBSAM(SELINE)),"^",3)
+2 IF $PIECE(REQE,"^",1)=""
SET $PIECE(REQE,"^",1)="...No Provider Selected..."
+3 IF $LENGTH(Y,"^")'>1
SET X=Y
SET DIC=81
SET DIC(0)="ZM"
DO ^DIC
+4 IF Y<0
DO HELP^PXBUTL0("CPTM")
GOTO C
+5 SET OK=$$CPTOK^PXBUTL(+Y,IDATE)
Begin DoDot:1
+6 ;--HELP
IF +OK=0
WRITE IOCUF,IOCUF,IORVON,"INACTIVE!--",IORVOFF
DO HELP1^PXBUTL1("CPTI")
End DoDot:1
IF +OK=0
GOTO C
+7 SET CPT=Y(0)
+8 SET ^DISV(DUZ,"PXBCPT-1")=$PIECE(CPT,"^",1)
+9 IF $DATA(PXBNCPT)
SET PXBNCPTF=1
+10 IF $DATA(PXBKY(Y(0,0)))
IF $GET(SELINE)
Begin DoDot:1
+11 SET $PIECE(REQI,"^",8)=$ORDER(PXBSKY(SELINE,0))
+12 SET PREDOC=$PIECE(PXBSAM(SELINE),"^",3)
+13 IF $DATA(PXBPRV($PIECE(REQE,"^",1),$PIECE(CPT,"^",1)))
Begin DoDot:2
+14 IF $PIECE(REQI,"^",8)]""
QUIT
+15 SET $PIECE(REQI,"^",8)=$ORDER(PXBPRV($PIECE(REQE,"^",1),$PIECE(CPT,"^",1),0))
End DoDot:2
+16 IF $DATA(PXBPRV($PIECE(REQE,"^",1)))
Begin DoDot:2
+17 SET CPTQUA=$PIECE(PXBSAM($ORDER(PXBPRV($PIECE(REQE,"^",1),$PIECE(CPT,"^",1),$ORDER(PXBPRV($PIECE(REQE,"^",1),$PIECE(CPT,"^",1),0)),0))),"^",2)
End DoDot:2
End DoDot:1
+18 IF $DATA(PXBKY(Y(0,0)))
IF '$GET(SELINE)
Begin DoDot:1
+19 ;S $P(REQI,"^",8)=$O(PXBSKY($O(PXBKY(Y(0,0),0)),0))
+20 SET PREDOC=$PIECE(PXBSAM($ORDER(PXBKY(Y(0,0),0))),"^",3)
+21 IF $DATA(PXBPRV($PIECE(REQE,"^",1),$PIECE(CPT,"^",1)))
Begin DoDot:2
+22 SET $PIECE(REQI,"^",8)=$ORDER(PXBPRV($PIECE(REQE,"^",1),$PIECE(CPT,"^",1),0))
End DoDot:2
+23 IF $DATA(PXBPRV($PIECE(REQE,"^",1),$PIECE(CPT,"^",1)))
Begin DoDot:2
+24 SET CPTQUA=$PIECE(PXBSAM($ORDER(PXBPRV($PIECE(REQE,"^",1),$PIECE(CPT,"^",1),$ORDER(PXBPRV($PIECE(REQE,"^",1),$PIECE(CPT,"^",1),0)),0))),"^",2)
End DoDot:2
End DoDot:1
+25 SET $PIECE(REQI,"^",3)=+Y
+26 SET $PIECE(REQE,"^",3)=$PIECE(CPT,"^",1)_"-- "_$PIECE(CPT,"^",2)
+27 SET PXBNCPT($PIECE(CPT,"^",1))=$PIECE(REQI,"^",8)
+28 IF $PIECE(REQI,"^",8)]""
SET PXBNCPT($PIECE(CPT,"^",1),$PIECE(REQI,"^",8))=""
+29 ;
CPTX ;--CPT Exit and cleanup
+1 IF $PIECE(REQE,"^",1)=""
SET $PIECE(REQE,"^",1)="...No Provider Selected..."
+2 IF $GET(WHAT)="INTV"
IF DATA="^"
SET PXBEXIT="^^"
+3 IF $DATA(PXBRRR)
SET DATA="^"
+4 IF $DATA(PREDOC)
Begin DoDot:1
+5 IF PREDOCPT_source.html#xC">C]""&($PIECPT_source.html#xC">CE(REQE,"^",1)'[PREDOCPT_source.html#xC">C)
WRITE !,IOINHI,"--WARNING!",IOINLOW," Currently stored Provider of service:-",IOINHI,PREDOC,IOINLOW
Begin DoDot:2
+6 IF '$DATA(PXBPRV($PIECE(REQE,"^",1),$PIECE(CPT,"^",1)))
SET $PIECE(REQI,"^",8)=""
End DoDot:2
End DoDot:1
+7 KILL PXBDPRV,PREDOC
+8 WRITE IOEDEOP
+9 QUIT
MOD ;---Separate CPT modifiers from CPT codes in entry string, if entered
+1 IF DATA?1.N1"-".NE
Begin DoDot:1
+2 SET PXMODSTR=$PIECE(DATA,"-",2)
+3 SET (DATA,EDATA)=$PIECE(DATA,"-",1)
End DoDot:1
+4 QUIT
+5 ;
MULTI(CPTCD) ;--Prompt user to Edit existing CPT code or Add as new entry
+1 ;
+2 NEW DIR,DA,X,Y
+3 SET DIR(0)="SB^E:EDIT;A:ADD"
+4 SET DIR("A")="Do you wish to (E)dit or (A)dd"
+5 IF $DATA(^IBE(357.69,+CPTCD))
SET DIR(0)="SB^E:EDIT"
SET DIR("A")="You may only (E)dit this code, no duplicate E&M allowed."
+6 SET DIR("A",1)="CPT "_CPTCD_" already on file for this Encounter"
+7 DO ^DIR
+8 IF Y']""!(Y="^")
QUIT -1
+9 QUIT Y
