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

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
 ;
HEADER ;--Display header and list CPT codes and associated modifiers
 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
 ;