PXBMCPT2 ;ISL/JVS,ESW - MAIN ROUTINE CPT CODES ; 12/5/02 11:37am
;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,88,89,108**;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 = Appointment-Encounter Visit IEN
; PXBDPRV = Default Provider for clinic appointment IEN
;--Set up
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
N DATA,PROMPT,FIRSTCPT,KFIRST,FROM,IDATE,%,CYCL
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
N PXBSKY,PXBKY,PXBSAM,PXBCNT,PRVDR,FPRI ;108
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
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
;
Q
P ;--Obtain the correct provider
;
Q
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
PXBMCPT2 ;ISL/JVS,ESW - MAIN ROUTINE CPT CODES ; 12/5/02 11:37am
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,88,89,108**;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 = Appointment-Encounter Visit IEN
+4 ; PXBDPRV = Default Provider for clinic appointment IEN
+5 ;--Set up
+6 NEW PXBCNT,I,J,IDATE,PRIP,PRIPOV,PRISEC,QUA,VISIT,PRI,POV,PRV,PXBENT,SAVE
+7 NEW PXBUT,FPRI,ENTRY,PXBSAVE,NAME,VAR,DOUBLEQQ,CPTQUA,PXBPRV,ERROR
+8 NEW REQI,REQE,DEL,COM,FROM,NOREV
+9 NEW DATA,PROMPT,FIRSTCPT,KFIRST,FROM,IDATE,%,CYCL
+10 NEW PXBNCPT,PXBNPRV,PXBNPOV,FIRST,PXBWIN,CLINIC
+11 NEW PXBPMT,LEAVE,PATIENT,PXMODSTR,PXMDCNT,PXNEWIEN,PXMREQ,PXTLNS
+12 SET (REQE,REQI)=""
+13 SET CLINIC=$PIECE(^AUPNVSIT(PXBVST,0),"^",22)
SET PROMPT="CPT"
+14 ;--KILL OF THE TMP GLOGALS IN ALL PROMPTS
+15 SET ^TMP("PXBDCPT",$JOB,"START")=0
SET FIRST=1
SET FIRSTCPT=1
SET PXBEXIT=1
+16 ;
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 ;108
NEW PXBSKY,PXBKY,PXBSAM,PXBCNT,PRVDR,FPRI
+2 DO PRV^PXBGPRV(PXBVST,.PXBSKY,.PXBKY,.PXBSAM,.PXBCNT,.PRVDR,.FPRI)
WRITE IOSC
+3 SET FROM="CPT"
DO PRV^PXBPPRV
IF DATA["^P"
Begin DoDot:1
+4 SET $PIECE(REQI,"^",1)=""
SET $PIECE(REQI,"^",2)=""
SET $PIECE(REQI,"^",7)=""
+5 KILL PXBDPRV
End DoDot:1
WRITE IOCUU
GOTO TEST3P
+6 DO EN0^PXBSTOR(PXBVST,PATIENT,REQI,.PXMREQ)
+7 DO EN1^PXKMAIN
+8 ;--RSET^PXBDREQ("PRV")
DO RSET^PXBDREQ("CPT")
+9 KILL PXMREQ
+10 SET $PIECE(REQI,"^",7)=""
+11 GOTO TEST3C
+12 ;
+13 QUIT
P ;--Obtain the correct provider
+1 ;
+2 QUIT
+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
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
