PXBMCPT2 ;ISL/JVS,ESW - MAIN ROUTINE CPT CODES ;3/22/05 9:22am
;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,88,89,108,124**;Aug 12, 1996
;
W !,"This is not the entry into this routine" Q
;
; VARABLE LIST
;
;
CPT(PXBVST) ;---Real entry point
Q:'$D(^AUPNVSIT(PXBVST))
S TEST=1
; PXBVST = Appiontment-Encounter Visit IEN
; PXBDPRV = Default Provider for clinic appointment IEN
;--Set up
N PXBSKY,PXBKY,PXBSAM,PRVDR,FPRI ;108
N PXBCNT,I,J,IDATE,PRIP,PRIPOV,PRISEC,QUA,VISIT,PRI,POV,PRV,PXBENT,SAVE
N PXBUT,FPRI,ENTRY,PXBSAVE,NAME,VAR,DOUBLEQQ,CPTQUA,PXBPRV,ERROR
N REQI,REQE,DEL,COM,FROM,NOREV,PX124,PXCEAFTR,PXCEVIEN
N DATA,PROMPT,FIRSTCPT,KFIRST,FROM,IDATE,%,CYCL,PXBDXPRI
N PXBNCPT,PXBNPRV,PXBNPOV,FIRST,PXBWIN,CLINIC
N PXBPMT,LEAVE,PATIENT,PXMODSTR,PXMDCNT,PXNEWIEN,PXMREQ,PXTLNS
S (REQE,REQI)=""
S CLINIC=$P(^AUPNVSIT(PXBVST,0),"^",22),PROMPT="CPT"
;--KILL OF THE TMP GLOGALS IN ALL PROMPTS
S ^TMP("PXBDCPT",$J,"START")=0,FIRST=1,FIRSTCPT=1,PXBEXIT=1
;
TEST3 ;---THIRD SERERIO FOR PROMPTING FOR CPT'S
I $G(DOUBLEQQ) S FIRST=1
D TERM^PXBCC
TEST3C ;--Display the CPT codes
D HEADER
;---ADDED 11/4/96
D RSET^PXBDREQ("PRV")
;------END--------
R2 K ERROR,PXMODSTR
S (PXNEWIEN,PXMREQ)=""
D CPT^PXBPCPT G:$G(PXBEXIT)<1 CPTXIT G:$G(ERROR) R2 W IOEDEOP
I DATA["^C" D RSET^PXBDREQ("CPT") K PXMREQ G TEST3C
I DATA=""!(DATA["^") D RSET^PXBDREQ("CPT") K DIRUT,PXBUT,PXMREQ G CPTXIT
;
;--Display the requested CPT code
D PRINT^PXBDREQ(2)
;
;--Prompt for CPT Modifiers
D FULL0^PXBCC
S PXNEWIEN=""
S PXMDCNT=$$CODM^ICPTCOD($P(REQI,"^",3),"^TMP(""PXMODARR"",$J",PXBSOURC,PXBVSTDT)
K ^TMP("PXMODARR",$J)
D MOD^PXBPMOD(PXBVST,PXBPAT,$P(REQI,"^",3),$G(PXMODSTR),$P(REQI,"^",8),IDATE,PXMDCNT,.PXMREQ)
I DATA["^C" D RSET^PXBDREQ("CPT") K PXMREQ G TEST3
I PXNEWIEN]"" S PXBNCPT($P(REQI,"^",3),PXNEWIEN)=""
;
TEST3Q ;--Prompt of the QUANTITY of the CPT code
S DEL=0
D WIN17^PXBCC(PXBCNT)
D QUA^PXBPQUA S PROMPT="CPT"
I EDATA["^C" D G TEST3
.I PXNEWIEN]"" D REMOVE^PXCEVFIL(PXNEWIEN)
.D RSET^PXBDREQ("CPT") K PXMREQ
;
;--Create The ^TMP("PXK", ARRAY
S COM="0@" I COM[$P(REQI,"^",4) D
.D EN0^PXBSTOR(PXBVST,PATIENT,REQI,.PXMREQ)
.D EN1^PXKMAIN
.S DEL=1
;--File the data into the V files
I $G(DEL)=1 D G TEST3C
.I PXNEWIEN]"" D REMOVE^PXCEVFIL(PXNEWIEN)
;
TEST3P ;--GET PROVIDER
D PRV^PXBGPRV(PXBVST,.PXBSKY,.PXBKY,.PXBSAM,.PXBCNT,.PRVDR,.FPRI) W IOSC
S FROM="CPT" D PRV^PXBPPRV I DATA["^P" D W IOCUU G TEST3P
.S $P(REQI,"^",1)="",$P(REQI,"^",2)="",$P(REQI,"^",7)=""
.K PXBDPRV
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)
;
STORE ;SAVE IN V FILES
D EN0^PXBSTOR(PXBVST,PATIENT,REQI,.PXMREQ)
D EN1^PXKMAIN
D RSET^PXBDREQ("CPT") ;--RSET^PXBDREQ("PRV")
K PXMREQ
S $P(REQI,"^",7)=""
G TEST3C
;
D HDR^PXBUTL(PXBVST,1)
D REQ^PXBDREQ(4)
D LOC^PXBCC(3,1)
W IOEDEOP
D CPT^PXBGCPT(PXBVST)
D EN0^PXBDCPT
D WIN17^PXBCC(PXBCNT)
D LOC^PXBCC(15,1)
Q
;
CPTXIT ;----EXIT AND CLEAN UP
D KILL^PXBUTL3
D PRIM^PXBUTL
D FULL0^PXBCC
D CLEAR1^PXBCC
K PXBKY,PXBSAM,PXBSKY,PXKVST
;
;----Do the EVENT to the Protocol
;D EVENT^PXKMAIN
K ^TMP("PXBDCPT",$J),^TMP("PXBSTOR",$J),^TMP("PXK",$J)
K ^TMP("PXBTOTAL",$J),^TMP("PXBTANA",$J)
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[HPXBMCPT2 4070 printed Apr 09, 2024@21:34:36 Page 2
PXBMCPT2 ;ISL/JVS,ESW - MAIN ROUTINE CPT CODES ;3/22/05 9:22am
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,88,89,108,124**;Aug 12, 1996
+2 ;
+3 WRITE !,"This is not the entry into this routine"
QUIT
+4 ;
+5 ; VARABLE LIST
+6 ;
+7 ;
CPT(PXBVST) ;---Real entry point
+1 if '$DATA(^AUPNVSIT(PXBVST))
QUIT
+2 SET TEST=1
+3 ; PXBVST = Appiontment-Encounter Visit IEN
+4 ; PXBDPRV = Default Provider for clinic appointment IEN
+5 ;--Set up
+6 ;108
NEW PXBSKY,PXBKY,PXBSAM,PRVDR,FPRI
+7 NEW PXBCNT,I,J,IDATE,PRIP,PRIPOV,PRISEC,QUA,VISIT,PRI,POV,PRV,PXBENT,SAVE
+8 NEW PXBUT,FPRI,ENTRY,PXBSAVE,NAME,VAR,DOUBLEQQ,CPTQUA,PXBPRV,ERROR
+9 NEW REQI,REQE,DEL,COM,FROM,NOREV,PX124,PXCEAFTR,PXCEVIEN
+10 NEW DATA,PROMPT,FIRSTCPT,KFIRST,FROM,IDATE,%,CYCL,PXBDXPRI
+11 NEW PXBNCPT,PXBNPRV,PXBNPOV,FIRST,PXBWIN,CLINIC
+12 NEW PXBPMT,LEAVE,PATIENT,PXMODSTR,PXMDCNT,PXNEWIEN,PXMREQ,PXTLNS
+13 SET (REQE,REQI)=""
+14 SET CLINIC=$PIECE(^AUPNVSIT(PXBVST,0),"^",22)
SET PROMPT="CPT"
+15 ;--KILL OF THE TMP GLOGALS IN ALL PROMPTS
+16 SET ^TMP("PXBDCPT",$JOB,"START")=0
SET FIRST=1
SET FIRSTCPT=1
SET PXBEXIT=1
+17 ;
TEST3 ;---THIRD SERERIO FOR PROMPTING FOR CPT'S
+1 IF $GET(DOUBLEQQ)
SET FIRST=1
+2 DO TERM^PXBCC
TEST3C ;--Display the CPT codes
+1 DO HEADER
+2 ;---ADDED 11/4/96
+3 DO RSET^PXBDREQ("PRV")
+4 ;------END--------
R2 KILL ERROR,PXMODSTR
+1 SET (PXNEWIEN,PXMREQ)=""
+2 DO CPT^PXBPCPT
if $GET(PXBEXIT)<1
GOTO CPTXIT
if $GET(ERROR)
GOTO R2
WRITE IOEDEOP
+3 IF DATA["^C"
DO RSET^PXBDREQ("CPT")
KILL PXMREQ
GOTO TEST3C
+4 IF DATA=""!(DATA["^")
DO RSET^PXBDREQ("CPT")
KILL DIRUT,PXBUT,PXMREQ
GOTO CPTXIT
+5 ;
+6 ;--Display the requested CPT code
+7 DO PRINT^PXBDREQ(2)
+8 ;
+9 ;--Prompt for CPT Modifiers
+10 DO FULL0^PXBCC
+11 SET PXNEWIEN=""
+12 SET PXMDCNT=$$CODM^ICPTCOD($PIECE(REQI,"^",3),"^TMP(""PXMODARR"",$J",PXBSOURC,PXBVSTDT)
+13 KILL ^TMP("PXMODARR",$JOB)
+14 DO MOD^PXBPMOD(PXBVST,PXBPAT,$PIECE(REQI,"^",3),$GET(PXMODSTR),$PIECE(REQI,"^",8),IDATE,PXMDCNT,.PXMREQ)
+15 IF DATA["^C"
DO RSET^PXBDREQ("CPT")
KILL PXMREQ
GOTO TEST3
+16 IF PXNEWIEN]""
SET PXBNCPT($PIECE(REQI,"^",3),PXNEWIEN)=""
+17 ;
TEST3Q ;--Prompt of the QUANTITY of the CPT code
+1 SET DEL=0
+2 DO WIN17^PXBCC(PXBCNT)
+3 DO QUA^PXBPQUA
SET PROMPT="CPT"
+4 IF EDATA["^C"
Begin DoDot:1
+5 IF PXNEWIEN]""
DO REMOVE^PXCEVFIL(PXNEWIEN)
+6 DO RSET^PXBDREQ("CPT")
KILL PXMREQ
End DoDot:1
GOTO TEST3
+7 ;
+8 ;--Create The ^TMP("PXK", ARRAY
+9 SET COM="0@"
IF COM[$PIECE(REQI,"^",4)
Begin DoDot:1
+10 DO EN0^PXBSTOR(PXBVST,PATIENT,REQI,.PXMREQ)
+11 DO EN1^PXKMAIN
+12 SET DEL=1
End DoDot:1
+13 ;--File the data into the V files
+14 IF $GET(DEL)=1
Begin DoDot:1
+15 IF PXNEWIEN]""
DO REMOVE^PXCEVFIL(PXNEWIEN)
End DoDot:1
GOTO TEST3C
+16 ;
TEST3P ;--GET PROVIDER
+1 DO PRV^PXBGPRV(PXBVST,.PXBSKY,.PXBKY,.PXBSAM,.PXBCNT,.PRVDR,.FPRI)
WRITE IOSC
+2 SET FROM="CPT"
DO PRV^PXBPPRV
IF DATA["^P"
Begin DoDot:1
+3 SET $PIECE(REQI,"^",1)=""
SET $PIECE(REQI,"^",2)=""
SET $PIECE(REQI,"^",7)=""
+4 KILL PXBDPRV
End DoDot:1
WRITE IOCUU
GOTO TEST3P
TEST3O ;ORDERING PROVIDER - PX124
+1 DO ORD^PXBPORD
+2 IF DATA["^O"
Begin DoDot:1
+3 SET $PIECE(REQI,U,22)=""
End DoDot:1
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:1
+3 IF $PIECE(^AUPNVPOV(PX124,0),U,12)="P"
SET PXBDXPRI=$PIECE(^(0),U,1)
End DoDot:1
+4 FOR PX124=1:1:8
if DATA=""!(DATA["^")&$$MORE(PX124)
QUIT
DO DX(PX124)
+5 ;
STORE ;SAVE IN V FILES
+1 DO EN0^PXBSTOR(PXBVST,PATIENT,REQI,.PXMREQ)
+2 DO EN1^PXKMAIN
+3 ;--RSET^PXBDREQ("PRV")
DO RSET^PXBDREQ("CPT")
+4 KILL PXMREQ
+5 SET $PIECE(REQI,"^",7)=""
+6 GOTO TEST3C
+7 ;
+1 DO HDR^PXBUTL(PXBVST,1)
+2 DO REQ^PXBDREQ(4)
+3 DO LOC^PXBCC(3,1)
+4 WRITE IOEDEOP
+5 DO CPT^PXBGCPT(PXBVST)
+6 DO EN0^PXBDCPT
+7 DO WIN17^PXBCC(PXBCNT)
+8 DO LOC^PXBCC(15,1)
+9 QUIT
+10 ;
CPTXIT ;----EXIT AND CLEAN UP
+1 DO KILL^PXBUTL3
+2 DO PRIM^PXBUTL
+3 DO FULL0^PXBCC
+4 DO CLEAR1^PXBCC
+5 KILL PXBKY,PXBSAM,PXBSKY,PXKVST
+6 ;
+7 ;----Do the EVENT to the Protocol
+8 ;D EVENT^PXKMAIN
+9 KILL ^TMP("PXBDCPT",$JOB),^TMP("PXBSTOR",$JOB),^TMP("PXK",$JOB)
+10 KILL ^TMP("PXBTOTAL",$JOB),^TMP("PXBTANA",$JOB)
+11 QUIT
+12 ;
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
+8 ;
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 ;
