PXBPCPT1 ;ISL/JVS,ESW - PROMPT CPT ;3/22/05 9:23am
;;1.0;PCE PATIENT CARE ENCOUNTER;**7,73,88,89,108,112,121,124**;Aug 12, 1996
;
;
;
;
;
ADDM ;--------If Multiple entries have been entered assume quantity 1
;
;
N OK,PXBLEN,BDATA,PXMDCNT
D WIN17^PXBCC(PXBCNT)
S NF=0,PXBLEN=0
D EDITMM
Q
I DATA[","&(DATA'["-")&($L($P(DATA,",",1))=5) S NF=1 D
.D HELP1^PXBUTL1("CPTMM"),HELP1^PXBUTL1("CON")
.R OK:DTIME
.S PXBLEN=$L(DATA,",") F PXI=1:1:PXBLEN S PXBPIECE=$P(DATA,",",PXI) D
..I $L($G(PXBPIECE))'=5 S BAD($G(PXBPIECE))="" Q
..I $L(PXBPIECE)=5 S X=PXBPIECE,DIC=81,DIC(0)="Z",DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)" D ^DIC
..I Y=-1 S BAD(+$G(PXBPIECE))="" Q
..S $P(REQI,"^",3)=+Y,$P(REQI,"^",4)=1
..S PXBNCPT(PXBPIECE)=""
..D EN0^PXBSTOR(PXBVST,PATIENT,REQI)
..D EN1^PXKMAIN
..D RSET^PXBDREQ("CPT")
BAD ;----BAD CPT CODES
N Y I $G(NF)&($D(BAD)) D Q
.S (BDATA,EDATA)=""
.F S BDATA=$O(BAD(BDATA)) Q:BDATA="" S EDATA=EDATA_BDATA_" "
.W ! D HELP^PXBUTL0("CPTM") W !
.S DIR(0)="E" D ^DIR K DIR,DIRUT
.S:Y=1 DATA="^C" S:Y=0!(Y="") DATA="^"
I $G(NF)&('$D(BAD)) S DATA="^C" Q
Q
;
BADD(PAR,EDATA) ;----BAD CPT CODES - DISPLAY
I $G(NF)&($D(BAD)) D Q
.W !,*7 D HELP^PXBUTL0(PAR) W !
Q
EDITMM ;--ADD MULTIPLE ENTRIES
;
N STOP,BAD,GONE,PXBLEN,PXBPIECE,BDATA,PX,PXI,YY,BAD
S STOP=0
I DATA[",",DATA'["-" D
.S PXBLEN=$L(DATA,",")
.S NF=1
.F PXI=1:1:PXBLEN S PXBPIECE=$P(DATA,",",PXI) Q:STOP=1 D
..;----ADDED
..I PXBPIECE="" Q
..I $D(PXBKY(PXBPIECE)) S BAD(PXBPIECE)="" S NF=1 D BADD("CPTMDP",PXBPIECE) H 2 Q
..I PXI>1 I ","_$P(DATA,",",1,PXI-1)_","[(","_PXBPIECE_",") W !!,*7,"PROCEDURE "_PXBPIECE_" was already processed." H 1 Q
..S X=PXBPIECE,DIC=81,DIC(0)="ZB",DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)" D ^DIC
..I Y<1 S BAD(PXBPIECE)="" S NF=1 D BADD("CPTM",PXBPIECE) Q
..S $P(REQI,U,3)=+Y
..S $P(REQI,U,8)=""
..W !!,"For the PROCEDURE: "_X_"--"_$P(Y(0),U,2)
..;--Prompt for CPT Modifiers
..D FULL0^PXBCC
..S PXMDCNT=$$CODM^ICPTCOD($P(REQI,"^",3),"^TMP(""PXMODARR"",$J",PXBSOURC,PXBVSTDT)
..K ^TMP("PXMODARR",$J)
..D MOD^PXBPMOD(PXBVST,PXBPAT,$P(REQI,"^",3),"",$P(REQI,"^",8),IDATE,PXMDCNT,.PXMREQ)
..S:EDATA["^C" STOP=1
..Q:STOP
..S CPTQUA=1
..D QUA^PXBPQUA
..S:EDATA["^C" STOP=1 S:EDATA["^P" STOP=1 Q:STOP=1
..;--Get Provider for CPT
..N PXBSKY,PXBKY,PXBSAM,PXBCNT,PRVDR,FPRI
..D PRV^PXBGPRV(PXBVST,.PXBSKY,.PXBKY,.PXBSAM,.PXBCNT,.PRVDR,.FPRI) W IOSC
..S FROM="CPT" D Q:STOP
...N DATA D PRV^PXBPPRV I DATA["^P" D W IOCUU S STOP=1 Q
....S $P(REQI,"^",1)="",$P(REQI,"^",2)="",$P(REQI,"^",7)=""
....K PXBDPRV
...S (PXBNCPT(PXBPIECE),DATA)=""
TEST3O ...;ORDERING PROVIDER - PX124
...D ORD^PXBPORD
...I DATA["^O" D W IOCUU G TEST3O
....S $P(REQI,U,22)=""
TEST3D ...;UP TO 8 DIAGNOSES - PX124
...S (PXBDXPRI,PX124)="",DATA=1
...F S PX124=$O(^AUPNVPOV("AD",PXBVST,PX124)) Q:'PX124!PXBDXPRI D
....I $P(^AUPNVPOV(PX124,0),U,12)="P" S PXBDXPRI=$P(^(0),U,1)
...F PX124=1:1:8 Q:DATA=""!(DATA["^")&$$MORE(PX124) D DX(PX124)
..D EN0^PXBSTOR(PXBVST,PATIENT,REQI,.PXMREQ)
..D EN1^PXKMAIN
..D RSET^PXBDREQ("CPT")
..D RSET^PXBDREQ("PRV")
..K PXMREQ
..S $P(REQI,"^",7)=""
.S DATA="^C"
Q
;
DELM ;--------If Multiple deleting
N DELM,PXBJ,BAD,PXBPIECE,PXBLEN
S NF=0,PXBLEN=0 S $P(DELM,"^",2)=1
I $E(DATA,1)="@" D
.I '$$SURE^PXCEAE2 S DATA="^C" Q
.S DATA=$P(DATA,"@",2),NF=1
.S PXBLEN=$L(DATA,",")
.F PXI=1:1:PXBLEN S PXBPIECE=$P(DATA,",",PXI) D
..I PXBPIECE'["-"&(PXBPIECE'>0!(PXBPIECE'<(PXBCNT+1))) S BAD(+$G(PXBPIECE))="" Q
..I PXBPIECE'["-" D
...I $D(GONE(PXBPIECE)) Q
...Q:PXBPIECE'?.N
...S $P(REQI,"^",8)=$O(PXBSKY(PXBPIECE,0)) ;-IEN
...S X=$P(PXBSAM(PXBPIECE),"^",1),DIC=81,DIC(0)="ZM",DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)" D ^DIC
...S $P(REQI,"^",3)=+Y K Y
...S $P(REQI,"^",4)=0 ;-QUANTITY
...S GONE(PXBPIECE)=""
...D EN0^PXBSTOR(PXBVST,PATIENT,REQI)
...D EN1^PXKMAIN
..I PXBPIECE["-" D
...F PXBJ=$P(PXBPIECE,"-",1):1:$P(PXBPIECE,"-",2) D
....I $D(GONE(PXBJ)) Q
....I PXBJ'>0!(PXBJ'<(PXBCNT+1)) S BAD(PXBJ)="" Q
....S $P(REQI,"^",8)=$O(PXBSKY(PXBJ,0)) ;-IEN
....S X=$P(PXBSAM(PXBJ),"^",1),DIC=81,DIC(0)="ZM",DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)" D ^DIC
....S $P(REQI,"^",3)=+Y K Y
....S $P(REQI,"^",4)=0 ;-QUANTITY
....S GONE(PXBJ)=""
....D EN0^PXBSTOR(PXBVST,PATIENT,REQI)
....D EN1^PXKMAIN
K GONE
I $G(NF)&($D(BAD)) D Q
.S (BDATA,EDATA)=""
.F S BDATA=$O(BAD(BDATA)) Q:BDATA="" S EDATA=EDATA_BDATA_" "
.W ! D HELP^PXBUTL0("CPTMD") W !
.S DIR(0)="E" D ^DIR K DIR
.S:Y=1 DATA="^C" S:Y=0!(Y="") DATA="^" K Y
I $G(NF)&('$D(BAD)) S DATA="^C" Q
Q
DX(PXC) ;GET DIAGNOSIS - PX124
DX2 ;2nd entry
D CDX^PXBPCPT2(PXC)
I DATA["^D" D W IOCUU G DX2
.S $P(REQI,U,PXC+11)=""
Q:DATA["^"!(DATA["@")
D PRINT^PXBDREQ(PXC+5),WIN17^PXBCC(PXBCNT),LOC^PXBCC(15,1)
W IOSC,IOEDEOP,IORC
Q
MORE(PXC) ;MORE DXs? - PX124
Q:PXC=19 0 ;last in list - NO More DXs
N PX,ANS
S ANS=0
F PX=PXC+1:1:19 I $P(REQI,U,PX) S ANS=1 Q
Q ANS
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXBPCPT1 5093 printed Nov 22, 2024@17:37:05 Page 2
PXBPCPT1 ;ISL/JVS,ESW - PROMPT CPT ;3/22/05 9:23am
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**7,73,88,89,108,112,121,124**;Aug 12, 1996
+2 ;
+3 ;
+4 ;
+5 ;
+6 ;
ADDM ;--------If Multiple entries have been entered assume quantity 1
+1 ;
+2 ;
+3 NEW OK,PXBLEN,BDATA,PXMDCNT
+4 DO WIN17^PXBCC(PXBCNT)
+5 SET NF=0
SET PXBLEN=0
+6 DO EDITMM
+7 QUIT
+8 IF DATA[","&(DATA'["-")&($LENGTH($PIECE(DATA,",",1))=5)
SET NF=1
Begin DoDot:1
+9 DO HELP1^PXBUTL1("CPTMM")
DO HELP1^PXBUTL1("CON")
+10 READ OK:DTIME
+11 SET PXBLEN=$LENGTH(DATA,",")
FOR PXI=1:1:PXBLEN
SET PXBPIECE=$PIECE(DATA,",",PXI)
Begin DoDot:2
+12 IF $LENGTH($GET(PXBPIECE))'=5
SET BAD($GET(PXBPIECE))=""
QUIT
+13 IF $LENGTH(PXBPIECE)=5
SET X=PXBPIECE
SET DIC=81
SET DIC(0)="Z"
SET DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)"
DO ^DIC
+14 IF Y=-1
SET BAD(+$GET(PXBPIECE))=""
QUIT
+15 SET $PIECE(REQI,"^",3)=+Y
SET $PIECE(REQI,"^",4)=1
+16 SET PXBNCPT(PXBPIECE)=""
+17 DO EN0^PXBSTOR(PXBVST,PATIENT,REQI)
+18 DO EN1^PXKMAIN
+19 DO RSET^PXBDREQ("CPT")
End DoDot:2
End DoDot:1
BAD ;----BAD CPT CODES
+1 NEW Y
IF $GET(NF)&($DATA(BAD))
Begin DoDot:1
+2 SET (BDATA,EDATA)=""
+3 FOR
SET BDATA=$ORDER(BAD(BDATA))
if BDATA=""
QUIT
SET EDATA=EDATA_BDATA_" "
+4 WRITE !
DO HELP^PXBUTL0("CPTM")
WRITE !
+5 SET DIR(0)="E"
DO ^DIR
KILL DIR,DIRUT
+6 if Y=1
SET DATA="^C"
if Y=0!(Y="")
SET DATA="^"
End DoDot:1
QUIT
+7 IF $GET(NF)&('$DATA(BAD))
SET DATA="^C"
QUIT
+8 QUIT
+9 ;
BADD(PAR,EDATA) ;----BAD CPT CODES - DISPLAY
+1 IF $GET(NF)&($DATA(BAD))
Begin DoDot:1
+2 WRITE !,*7
DO HELP^PXBUTL0(PAR)
WRITE !
End DoDot:1
QUIT
+3 QUIT
EDITMM ;--ADD MULTIPLE ENTRIES
+1 ;
+2 NEW STOP,BAD,GONE,PXBLEN,PXBPIECE,BDATA,PX,PXI,YY,BAD
+3 SET STOP=0
+4 IF DATA[","
IF DATA'["-"
Begin DoDot:1
+5 SET PXBLEN=$LENGTH(DATA,",")
+6 SET NF=1
+7 FOR PXI=1:1:PXBLEN
SET PXBPIECE=$PIECE(DATA,",",PXI)
if STOP=1
QUIT
Begin DoDot:2
+8 ;----ADDED
+9 IF PXBPIECE=""
QUIT
+10 IF $DATA(PXBKY(PXBPIECE))
SET BAD(PXBPIECE)=""
SET NF=1
DO BADD("CPTMDP",PXBPIECE)
HANG 2
QUIT
+11 IF PXI>1
IF ","_$PIECE(DATA,",",1,PXI-1)_","[(","_PXBPIECE_",")
WRITE !!,*7,"PROCEDURE "_PXBPIECE_" was already processed."
HANG 1
QUIT
+12 SET X=PXBPIECE
SET DIC=81
SET DIC(0)="ZB"
SET DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)"
DO ^DIC
+13 IF Y<1
SET BAD(PXBPIECE)=""
SET NF=1
DO BADD("CPTM",PXBPIECE)
QUIT
+14 SET $PIECE(REQI,U,3)=+Y
+15 SET $PIECE(REQI,U,8)=""
+16 WRITE !!,"For the PROCEDURE: "_X_"--"_$PIECE(Y(0),U,2)
+17 ;--Prompt for CPT Modifiers
+18 DO FULL0^PXBCC
+19 SET PXMDCNT=$$CODM^ICPTCOD($PIECE(REQI,"^",3),"^TMP(""PXMODARR"",$J",PXBSOURC,PXBVSTDT)
+20 KILL ^TMP("PXMODARR",$JOB)
+21 DO MOD^PXBPMOD(PXBVST,PXBPAT,$PIECE(REQI,"^",3),"",$PIECE(REQI,"^",8),IDATE,PXMDCNT,.PXMREQ)
+22 if EDATA["^C"
SET STOP=1
+23 if STOP
QUIT
+24 SET CPTQUA=1
+25 DO QUA^PXBPQUA
+26 if EDATA["^C"
SET STOP=1
if EDATA["^P"
SET STOP=1
if STOP=1
QUIT
+27 ;--Get Provider for CPT
+28 NEW PXBSKY,PXBKY,PXBSAM,PXBCNT,PRVDR,FPRI
+29 DO PRV^PXBGPRV(PXBVST,.PXBSKY,.PXBKY,.PXBSAM,.PXBCNT,.PRVDR,.FPRI)
WRITE IOSC
+30 SET FROM="CPT"
Begin DoDot:3
+31 NEW DATA
DO PRV^PXBPPRV
IF DATA["^P"
Begin DoDot:4
+32 SET $PIECE(REQI,"^",1)=""
SET $PIECE(REQI,"^",2)=""
SET $PIECE(REQI,"^",7)=""
+33 KILL PXBDPRV
End DoDot:4
WRITE IOCUU
SET STOP=1
QUIT
+34 SET (PXBNCPT(PXBPIECE),DATA)=""
TEST3O ;ORDERING PROVIDER - PX124
+1 DO ORD^PXBPORD
+2 IF DATA["^O"
Begin DoDot:4
+3 SET $PIECE(REQI,U,22)=""
End DoDot:4
WRITE IOCUU
GOTO TEST3O
TEST3D ;UP TO 8 DIAGNOSES - PX124
+1 SET (PXBDXPRI,PX124)=""
SET DATA=1
+2 FOR
SET PX124=$ORDER(^AUPNVPOV("AD",PXBVST,PX124))
if 'PX124!PXBDXPRI
QUIT
Begin DoDot:4
+3 IF $PIECE(^AUPNVPOV(PX124,0),U,12)="P"
SET PXBDXPRI=$PIECE(^(0),U,1)
End DoDot:4
+4 FOR PX124=1:1:8
if DATA=""!(DATA["^")&$$MORE(PX124)
QUIT
DO DX(PX124)
End DoDot:3
if STOP
QUIT
+5 DO EN0^PXBSTOR(PXBVST,PATIENT,REQI,.PXMREQ)
+6 DO EN1^PXKMAIN
+7 DO RSET^PXBDREQ("CPT")
+8 DO RSET^PXBDREQ("PRV")
+9 KILL PXMREQ
+10 SET $PIECE(REQI,"^",7)=""
End DoDot:2
+11 SET DATA="^C"
End DoDot:1
+12 QUIT
+13 ;
DELM ;--------If Multiple deleting
+1 NEW DELM,PXBJ,BAD,PXBPIECE,PXBLEN
+2 SET NF=0
SET PXBLEN=0
SET $PIECE(DELM,"^",2)=1
+3 IF $EXTRACT(DATA,1)="@"
Begin DoDot:1
+4 IF '$$SURE^PXCEAE2
SET DATA="^C"
QUIT
+5 SET DATA=$PIECE(DATA,"@",2)
SET NF=1
+6 SET PXBLEN=$LENGTH(DATA,",")
+7 FOR PXI=1:1:PXBLEN
SET PXBPIECE=$PIECE(DATA,",",PXI)
Begin DoDot:2
+8 IF PXBPIECE'["-"&(PXBPIECE'>0!(PXBPIECE'<(PXBCNT+1)))
SET BAD(+$GET(PXBPIECE))=""
QUIT
+9 IF PXBPIECE'["-"
Begin DoDot:3
+10 IF $DATA(GONE(PXBPIECE))
QUIT
+11 if PXBPIECE'?.N
QUIT
+12 ;-IEN
SET $PIECE(REQI,"^",8)=$ORDER(PXBSKY(PXBPIECE,0))
+13 SET X=$PIECE(PXBSAM(PXBPIECE),"^",1)
SET DIC=81
SET DIC(0)="ZM"
SET DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)"
DO ^DIC
+14 SET $PIECE(REQI,"^",3)=+Y
KILL Y
+15 ;-QUANTITY
SET $PIECE(REQI,"^",4)=0
+16 SET GONE(PXBPIECE)=""
+17 DO EN0^PXBSTOR(PXBVST,PATIENT,REQI)
+18 DO EN1^PXKMAIN
End DoDot:3
+19 IF PXBPIECE["-"
Begin DoDot:3
+20 FOR PXBJ=$PIECE(PXBPIECE,"-",1):1:$PIECE(PXBPIECE,"-",2)
Begin DoDot:4
+21 IF $DATA(GONE(PXBJ))
QUIT
+22 IF PXBJ'>0!(PXBJ'<(PXBCNT+1))
SET BAD(PXBJ)=""
QUIT
+23 ;-IEN
SET $PIECE(REQI,"^",8)=$ORDER(PXBSKY(PXBJ,0))
+24 SET X=$PIECE(PXBSAM(PXBJ),"^",1)
SET DIC=81
SET DIC(0)="ZM"
SET DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)"
DO ^DIC
+25 SET $PIECE(REQI,"^",3)=+Y
KILL Y
+26 ;-QUANTITY
SET $PIECE(REQI,"^",4)=0
+27 SET GONE(PXBJ)=""
+28 DO EN0^PXBSTOR(PXBVST,PATIENT,REQI)
+29 DO EN1^PXKMAIN
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+30 KILL GONE
+31 IF $GET(NF)&($DATA(BAD))
Begin DoDot:1
+32 SET (BDATA,EDATA)=""
+33 FOR
SET BDATA=$ORDER(BAD(BDATA))
if BDATA=""
QUIT
SET EDATA=EDATA_BDATA_" "
+34 WRITE !
DO HELP^PXBUTL0("CPTMD")
WRITE !
+35 SET DIR(0)="E"
DO ^DIR
KILL DIR
+36 if Y=1
SET DATA="^C"
if Y=0!(Y="")
SET DATA="^"
KILL Y
End DoDot:1
QUIT
+37 IF $GET(NF)&('$DATA(BAD))
SET DATA="^C"
QUIT
+38 QUIT
DX(PXC) ;GET DIAGNOSIS - PX124
DX2 ;2nd entry
+1 DO CDX^PXBPCPT2(PXC)
+2 IF DATA["^D"
Begin DoDot:1
+3 SET $PIECE(REQI,U,PXC+11)=""
End DoDot:1
WRITE IOCUU
GOTO DX2
+4 if DATA["^"!(DATA["@")
QUIT
+5 DO PRINT^PXBDREQ(PXC+5)
DO WIN17^PXBCC(PXBCNT)
DO LOC^PXBCC(15,1)
+6 WRITE IOSC,IOEDEOP,IORC
+7 QUIT
MORE(PXC) ;MORE DXs? - PX124
+1 ;last in list - NO More DXs
if PXC=19
QUIT 0
+2 NEW PX,ANS
+3 SET ANS=0
+4 FOR PX=PXC+1:1:19
IF $PIECE(REQI,U,PX)
SET ANS=1
QUIT
+5 QUIT ANS
+6 ;
