- 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 Mar 13, 2025@21:31:48 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 ;
