PXBPCPT ;ISL/JVS,ESW - PROMPT CPT ;3/02/2023
;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,89,112,121,132,149,124,190,199,232**;Aug 12, 1996;Build 7
;
; Reference to ICRs
; ^ICPT( #5408
; ^IBE(357.69 #3547
; $$ICDDX^ICDEX #5747
; $$CPT^ICPTCOD #1995
;
CPT ;--CPT CODE
;SELINE=LINE NUMBER OF SELECTED ITEM
N BAD,CPT,DIC,DOUBLEQQ,EDATA,I,LINE,NF,OK,PXBUT,PXDXDATE,PXEDIT,Q
N SELINE,TIMED,X,XFLAG,Y
I $G(IDATE)="" S IDATE=+^AUPNVSIT(PXBVST,0) ; PXBVST defined in PXBMCPT2
S PXDXDATE=$$CSDATE^PXDXUTL(PXBVST) ; PXDXDATE for use with diagnosis only
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)
; ----- Check & remove control character PX*190 -----
S ZZDATA=""
S ZDATA="" F J=1:1:$L(DATA) S ZDATA=$E(DATA,J) D
.I $A(ZDATA)>31,($A(ZDATA)'=127) S ZZDATA=ZZDATA_ZDATA
I $L(ZZDATA)=0 W $C(7),"??" D HELP^PXBUTL0("CPTM") G C
S (DATA,EDATA)=ZZDATA
K ZZDATA,ZDATA,J
;
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",DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)" 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=$P(^ICPT(Y,0),U),DIC=81,DIC(0)="ZM",DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)" 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
N CPTDESC,CPTIEN,REQE1
S CPTIEN=$P(Y,U,1)
S REQE1=$P(REQE,U,1)
N PXINF S PXINF=$$CPT^ICPTCOD(CPTIEN,IDATE),CPTDESC=$P(PXINF,U,3)
S ^DISV(DUZ,"PXBCPT-1")=CPTIEN
I $D(PXBNCPT) S PXBNCPTF=1
I $D(PXBKY(CPTIEN)),$G(SELINE) D
.S $P(REQI,"^",8)=$O(PXBSKY(SELINE,0))
.S PREDOC=$P(PXBSAM(SELINE),"^",3)
.I $D(PXBPRV(REQE1,CPTIEN)) D
..Q:$P(REQI,"^",8)]""
..S $P(REQI,"^",8)=$O(PXBPRV(REQE1,CPTIEN,0))
.I $D(PXBPRV(REQE1)) D
..S CPTQUA=$P(PXBSAM($O(PXBPRV(REQE1,CPTIEN,$O(PXBPRV(REQE1,CPTIEN,0)),0))),"^",2)
I $D(PXBKY(CPTIEN)),'$G(SELINE) D
.S PREDOC=$P(PXBSAM($O(PXBKY(CPTIEN,0))),"^",3)
.I $D(PXBPRV(REQE1,CPTIEN)) D
..S $P(REQI,"^",8)=$O(PXBPRV(REQE1,CPTIEN,0))
.I $D(PXBPRV(REQE1,CPTIEN)) D
..S CPTQUA=$P(PXBSAM($O(PXBPRV(REQE1,CPTIEN,$O(PXBPRV(REQE1,CPTIEN,0)),0))),"^",2)
S $P(REQI,"^",3)=+Y
S $P(REQE,"^",3)=CPTIEN_"-- "_CPTDESC
S PXBNCPT(CPTIEN)=$P(REQI,"^",8)
S:$P(REQI,"^",8)]"" PXBNCPT(CPTIEN,$P(REQI,"^",8))=""
;PX124 adds to REQ*
REST I $P(REQI,U,8) D
.N CTR,VAL,IEN
.S IEN=$P(REQI,U,8)
.S $P(REQI,U,13,19)=$P($G(^AUPNVCPT(IEN,0)),U,9,15)
.S $P(REQI,U,12)=$P($G(^AUPNVCPT(IEN,0)),U,5)
.F CTR=12:1:19 D
..S VAL=$P(REQI,U,CTR)
..S:VAL VAL=$$ICDDX^ICDEX(VAL,PXDXDATE,"DIAG","I"),$P(REQE,U,CTR)=$P($G(VAL),U,2)_" --"_$P($G(VAL),U,4)
.S VAL=$P($G(^AUPNVCPT(IEN,12)),U,2),$P(REQI,U,22)=VAL
.S:VAL $P(REQE,U,22)=$P($G(^VA(200,VAL,0)),U,1)
;
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(REQE1,CPTIEN)) 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"
;PX*2.0*132
I (($E(CPTCD)?1N)&($D(^IBE(357.69,+CPTCD))))!(($E(CPTCD)?1A)&($D(^IBE(357.69,CPTCD)))) D
.S DIR(0)="SB^E:EDIT",DIR("A")="You may only (E)dit this code, no duplicate E&M codes allowed."
S DIR("A",1)="CPT "_CPTCD_" already on file for this Encounter"
D ^DIR
I Y']""!(Y="^") Q -1
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXBPCPT 7442 printed Apr 09, 2024@21:30:54 Page 2
PXBPCPT ;ISL/JVS,ESW - PROMPT CPT ;3/02/2023
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,89,112,121,132,149,124,190,199,232**;Aug 12, 1996;Build 7
+2 ;
+3 ; Reference to ICRs
+4 ; ^ICPT( #5408
+5 ; ^IBE(357.69 #3547
+6 ; $$ICDDX^ICDEX #5747
+7 ; $$CPT^ICPTCOD #1995
+8 ;
CPT ;--CPT CODE
+1 ;SELINE=LINE NUMBER OF SELECTED ITEM
+2 NEW BAD,CPT,DIC,DOUBLEQQ,EDATA,I,LINE,NF,OK,PXBUT,PXDXDATE,PXEDIT,Q
+3 NEW SELINE,TIMED,X,XFLAG,Y
+4 ; PXBVST defined in PXBMCPT2
IF $GET(IDATE)=""
SET IDATE=+^AUPNVSIT(PXBVST,0)
+5 ; PXDXDATE for use with diagnosis only
SET PXDXDATE=$$CSDATE^PXDXUTL(PXBVST)
+6 IF '$DATA(^DISV(DUZ,"PXBCPT-1"))
SET ^DISV(DUZ,"PXBCPT-1")=" "
+7 IF '$DATA(IOSC)
DO TERM^PXBCC
+8 SET DOUBLEQQ=0
SET PXEDIT=""
+9 SET TIMED="I '$T!(DATA[""^"")!(DATA="""")"
+10 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 ; ----- Check & remove control character PX*190 -----
+6 SET ZZDATA=""
+7 SET ZDATA=""
FOR J=1:1:$LENGTH(DATA)
SET ZDATA=$EXTRACT(DATA,J)
Begin DoDot:1
+8 IF $ASCII(ZDATA)>31
IF ($ASCII(ZDATA)'=127)
SET ZZDATA=ZZDATA_ZDATA
End DoDot:1
+9 IF $LENGTH(ZZDATA)=0
WRITE $CHAR(7),"??"
DO HELP^PXBUTL0("CPTM")
GOTO C
+10 SET (DATA,EDATA)=ZZDATA
+11 KILL ZZDATA,ZDATA,J
+12 ;
+13 DO CASE^PXBUTL
+14 ;----SPACE BAR---
+15 IF DATA=" "
IF $DATA(^DISV(DUZ,"PXBCPT-1"))
SET DATA=^DISV(DUZ,"PXBCPT-1")
WRITE DATA
+16 ;---------------
+17 IF DATA["^P"
GOTO CPTX
+18 IF DATA["^C"
GOTO CPTX
+19 ;
+20 IF ((DATA="+")!(DATA="-"))
DO DISCPT4^PXBDCPT(DATA)
GOTO C
+21 ;
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"
SET DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)"
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=$PIECE(^ICPT(Y,0),U)
SET DIC=81
SET DIC(0)="ZM"
SET DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)"
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 NEW CPTDESC,CPTIEN,REQE1
+8 SET CPTIEN=$PIECE(Y,U,1)
+9 SET REQE1=$PIECE(REQE,U,1)
+10 NEW PXINF
SET PXINF=$$CPT^ICPTCOD(CPTIEN,IDATE)
SET CPTDESC=$PIECE(PXINF,U,3)
+11 SET ^DISV(DUZ,"PXBCPT-1")=CPTIEN
+12 IF $DATA(PXBNCPT)
SET PXBNCPTF=1
+13 IF $DATA(PXBKY(CPTIEN))
IF $GET(SELINE)
Begin DoDot:1
+14 SET $PIECE(REQI,"^",8)=$ORDER(PXBSKY(SELINE,0))
+15 SET PREDOC=$PIECE(PXBSAM(SELINE),"^",3)
+16 IF $DATA(PXBPRV(REQE1,CPTIEN))
Begin DoDot:2
+17 if $PIECE(REQI,"^",8)]""
QUIT
+18 SET $PIECE(REQI,"^",8)=$ORDER(PXBPRV(REQE1,CPTIEN,0))
End DoDot:2
+19 IF $DATA(PXBPRV(REQE1))
Begin DoDot:2
+20 SET CPTQUA=$PIECE(PXBSAM($ORDER(PXBPRV(REQE1,CPTIEN,$ORDER(PXBPRV(REQE1,CPTIEN,0)),0))),"^",2)
End DoDot:2
End DoDot:1
+21 IF $DATA(PXBKY(CPTIEN))
IF '$GET(SELINE)
Begin DoDot:1
+22 SET PREDOC=$PIECE(PXBSAM($ORDER(PXBKY(CPTIEN,0))),"^",3)
+23 IF $DATA(PXBPRV(REQE1,CPTIEN))
Begin DoDot:2
+24 SET $PIECE(REQI,"^",8)=$ORDER(PXBPRV(REQE1,CPTIEN,0))
End DoDot:2
+25 IF $DATA(PXBPRV(REQE1,CPTIEN))
Begin DoDot:2
+26 SET CPTQUA=$PIECE(PXBSAM($ORDER(PXBPRV(REQE1,CPTIEN,$ORDER(PXBPRV(REQE1,CPTIEN,0)),0))),"^",2)
End DoDot:2
End DoDot:1
+27 SET $PIECE(REQI,"^",3)=+Y
+28 SET $PIECE(REQE,"^",3)=CPTIEN_"-- "_CPTDESC
+29 SET PXBNCPT(CPTIEN)=$PIECE(REQI,"^",8)
+30 if $PIECE(REQI,"^",8)]""
SET PXBNCPT(CPTIEN,$PIECE(REQI,"^",8))=""
+31 ;PX124 adds to REQ*
REST IF $PIECE(REQI,U,8)
Begin DoDot:1
+1 NEW CTR,VAL,IEN
+2 SET IEN=$PIECE(REQI,U,8)
+3 SET $PIECE(REQI,U,13,19)=$PIECE($GET(^AUPNVCPT(IEN,0)),U,9,15)
+4 SET $PIECE(REQI,U,12)=$PIECE($GET(^AUPNVCPT(IEN,0)),U,5)
+5 FOR CTR=12:1:19
Begin DoDot:2
+6 SET VAL=$PIECE(REQI,U,CTR)
+7 if VAL
SET VAL=$$ICDDX^ICDEX(VAL,PXDXDATE,"DIAG","I")
SET $PIECE(REQE,U,CTR)=$PIECE($GET(VAL),U,2)_" --"_$PIECE($GET(VAL),U,4)
End DoDot:2
+8 SET VAL=$PIECE($GET(^AUPNVCPT(IEN,12)),U,2)
SET $PIECE(REQI,U,22)=VAL
+9 if VAL
SET $PIECE(REQE,U,22)=$PIECE($GET(^VA(200,VAL,0)),U,1)
End DoDot:1
+10 ;
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#_C">C]""&($PIECPT_source.html#_C">CE(REQE,"^",1)'[PREDOCPT_source.html#_C">C)
WRITE !,IOINHI,"--WARNING!",IOINLOW," Currently stored Provider of service:-",IOINHI,PREDOC,IOINLOW
Begin DoDot:2
+6 IF '$DATA(PXBPRV(REQE1,CPTIEN))
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 ;PX*2.0*132
+6 IF (($EXTRACT(CPTCD)?1N)&($DATA(^IBE(357.69,+CPTCD))))!(($EXTRACT(CPTCD)?1A)&($DATA(^IBE(357.69,CPTCD))))
Begin DoDot:1
+7 SET DIR(0)="SB^E:EDIT"
SET DIR("A")="You may only (E)dit this code, no duplicate E&M codes allowed."
End DoDot:1
+8 SET DIR("A",1)="CPT "_CPTCD_" already on file for this Encounter"
+9 DO ^DIR
+10 IF Y']""!(Y="^")
QUIT -1
+11 QUIT Y
