source: FOIAVistA/tag/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXBMCPT.m@ 628

PXBMCPT ;ISL/JVS,ESW - MAIN ROUTINE CPT CODES ; 12/5/02 11:36am
 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,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))
 D CPT^PXBMCPT2(PXBVST) Q
 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,PXBSKY,PXBKY,PXBSAM,PXBCNT,PRVDR
 N PXBUT,FPRI,ENTRY,PXBSAVE,NAME,VAR,DOUBLEQQ,CPTQUA,PXBPRV,ERROR
 N REQI,REQE,DATA,PROMPT,FIRSTCPT,KFIRST,FROM,IDATE,%,CYCL
 N PXBNCPT,PXBNPRV,PXBNPOV,FIRST,PXBWIN,CLINIC,PXBPMT,LEAVE,PATIENT
 N FROM,NOREV
 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
 ;
P ;--Obtain the correct provider
 I $G(DOUBLEQQ) S FIRST=1
 D TERM^PXBCC
 D HDR^PXBUTL(PXBVST,1),REQ^PXBDREQ(4)
 D PRV^PXBGPRV(PXBVST,.PXBSKY,.PXBKY,.PXBSAM,.PXBCNT,.PRVDR,.FPRI)
 I $G(TEST)=1 S FROM="CPT" D EN0^PXBDPRV K FROM
 I $G(TEST)=2 D CPT^PXBGCPT(PXBVST)
 I $G(TEST)=2 D EN0^PXBDCPT
R D WIN17^PXBCC(PXBCNT),LOC^PXBCC(15,1)
 K ERROR S FROM="CPT" D PRV^PXBPPRV W:$D(CYCL) IOSC K FROM G:$G(PXBEXIT)<1 CPTXIT G:$G(ERROR) R K CYCL
 W IOEDEOP
 I $G(DOUBLEQQ)=1,'$P(REQI,"^",1) G P
 I DATA["^P" D RSET^PXBDREQ("PRV") G P
 I $G(PXBUT)=1,'$D(FIRST) G CPTXIT
 I $G(PXBUT)=1,$D(LEAVE) G CPTXIT
 K FIRST
 ;
 ;--Prompt for Primary or Secondary Provider
 S PROMPT="CPT^PRV" D PRI^PXBPPRV1 S PROMPT="CPT"
 I $D(DIRUT) G P
 ;
 ;--Display the Requested Provider
 D PRINT^PXBDREQ(1)
 D EN0^PXBSTOR(PXBVST,PATIENT,REQI)
 ;
 ;--File the Provider data into the V files
 D EN1^PXKMAIN
 ;
C ;--Display the CPT codes
 D LOC^PXBCC(3,1) W IOEDEOP
 D CPT^PXBGCPT(PXBVST)
 D EN0^PXBDCPT
R2 D WIN17^PXBCC(PXBCNT),LOC^PXBCC(15,1)
 K ERROR D CPT^PXBPCPT G:$G(PXBEXIT)<1 CPTXIT G:$G(ERROR) R2 W IOEDEOP
 I DATA=""!(DATA["^P") D RSET^PXBDREQ("CPT"),RSET^PXBDREQ("PRV") K DIRUT,PXBUT G P
 I DATA["^C" D RSET^PXBDREQ("CPT") G C
 I DATA=""!(DATA["^") D RSET^PXBDREQ("CPT"),RSET^PXBDREQ("PRV") K DIRUT,PXBUT G P
 ;
 ;--Display the requested CPT code
 D PRINT^PXBDREQ(2)
 ;
Q ;--Prompt of the QUANTITY of the CPT code
 D WIN17^PXBCC(PXBCNT)
 S PROMPT="CPT^QUA" D QUA^PXBPQUA S PROMPT="CPT"
 I EDATA["^C" D RSET^PXBDREQ("CPT") G C
 I EDATA["^P" D RSET^PXBDREQ("CPT"),RSET^PXBDREQ("PRV") K DIRUT,PXBUT G P
 ;
 ;--Create The ^TMP("PXK", ARRAY
 D EN0^PXBSTOR(PXBVST,PATIENT,REQI)
 ;--File the data into the V files
 D EN1^PXKMAIN
 D RSET^PXBDREQ("CPT")
 G C
 ;
CPTXIT ;----EXIT AND CLEAN UP
 D KILL^PXBUTL3
 D PRIM^PXBUTL
 D FULL0^PXBCC
 D CLEAR1^PXBCC
 K PXBKY,PXBSAM,PXBSKY,PXBVST
 ;
 ;----Do the EVENT to the Protocol
 K ^TMP("PXBDCPT",$J),^TMP("PXBSTOR",$J),^TMP("PXK",$J)
 K ^TMP("PXBTOTAL",$J),^TMP("PXBTANA",$J)
 Q
 ;
TEST3 ;---THIRD SERERIO FOR PROMPTING FOR CPT'S
 I $G(DOUBLEQQ) S FIRST=1
 D TERM^PXBCC
 D HDR^PXBUTL(PXBVST,1),REQ^PXBDREQ(4)
 D TEST3C
 D TEST3Q
TEST3C ;--Display the CPT codes
 D LOC^PXBCC(3,1) W IOEDEOP
 D CPT^PXBGCPT(PXBVST)
 D EN0^PXBDCPT
R23 D WIN17^PXBCC(PXBCNT),LOC^PXBCC(15,1)
 K ERROR D CPT^PXBPCPT G:$G(PXBEXIT)<1 CPTXIT G:$G(ERROR) R2 W IOEDEOP
 I DATA=""!(DATA["^P") D RSET^PXBDREQ("CPT"),RSET^PXBDREQ("PRV") K DIRUT,PXBUT G P
 I DATA["^C" D RSET^PXBDREQ("CPT") G C
 I DATA=""!(DATA["^") D RSET^PXBDREQ("CPT"),RSET^PXBDREQ("PRV") K DIRUT,PXBUT G P
 ;
 ;--Display the requested CPT code
 D PRINT^PXBDREQ(2)
 Q
TEST3Q ;--Prompt of the QUANTITY of the CPT code
 D WIN17^PXBCC(PXBCNT)
 S PROMPT="CPT^QUA" D QUA^PXBPQUA S PROMPT="CPT"
 I EDATA["^C" D RSET^PXBDREQ("CPT") G C
 I EDATA["^P" D RSET^PXBDREQ("CPT"),RSET^PXBDREQ("PRV") K DIRUT,PXBUT G P
 ;
 ;--Create The ^TMP("PXK", ARRAY
 D EN0^PXBSTOR(PXBVST,PATIENT,REQI)
 ;--File the data into the V files
 D EN1^PXKMAIN
 D RSET^PXBDREQ("CPT")
 G C
 Q