Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXBMCPT2

PXBMCPT2.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  W !,"This is not the entry into this routine" Q
  1.  ;
  1.  ;  VARABLE LIST
  1.  ;
  1.  ;
  1. CPT(PXBVST) ;---Real entry point
  1.  Q:'$D(^AUPNVSIT(PXBVST))
  1.  S TEST=1
  1.  ; PXBVST  = Appointment-Encounter Visit IEN
  1.  ; PXBDPRV = Default Provider for clinic appointment IEN
  1.  ;--Set up
  1.  N PXBCNT,I,J,IDATE,PRIP,PRIPOV,PRISEC,QUA,VISIT,PRI,POV,PRV,PXBENT,SAVE
  1.  N PXBUT,FPRI,ENTRY,PXBSAVE,NAME,VAR,DOUBLEQQ,CPTQUA,PXBPRV,ERROR
  1.  N REQI,REQE,DEL,COM,FROM,NOREV
  1.  N DATA,PROMPT,FIRSTCPT,KFIRST,FROM,IDATE,%,CYCL
  1.  N PXBNCPT,PXBNPRV,PXBNPOV,FIRST,PXBWIN,CLINIC
  1.  N PXBPMT,LEAVE,PATIENT,PXMODSTR,PXMDCNT,PXNEWIEN,PXMREQ,PXTLNS
  1.  S (REQE,REQI)=""
  1.  S CLINIC=$P(^AUPNVSIT(PXBVST,0),"^",22),PROMPT="CPT"
  1.  ;--KILL OF THE TMP GLOGALS IN ALL PROMPTS
  1.  S ^TMP("PXBDCPT",$J,"START")=0,FIRST=1,FIRSTCPT=1,PXBEXIT=1
  1.  ;
  1. TEST3 ;---THIRD SERERIO FOR PROMPTING FOR CPT'S
  1.  I $G(DOUBLEQQ) S FIRST=1
  1.  D TERM^PXBCC
  1. TEST3C ;--Display the CPT codes
  1.  D HEADER
  1.  ;---ADDED 11/4/96
  1.  D RSET^PXBDREQ("PRV")
  1.  ;------END--------
  1. R2 K ERROR,PXMODSTR
  1.  S (PXNEWIEN,PXMREQ)=""
  1.  D CPT^PXBPCPT G:$G(PXBEXIT)<1 CPTXIT G:$G(ERROR) R2 W IOEDEOP
  1.  I DATA["^C" D RSET^PXBDREQ("CPT") K PXMREQ G TEST3C
  1.  I DATA=""!(DATA["^") D RSET^PXBDREQ("CPT") K DIRUT,PXBUT,PXMREQ G CPTXIT
  1.  ;
  1.  ;--Display the requested CPT code
  1.  D PRINT^PXBDREQ(2)
  1.  ;
  1.  ;--Prompt for CPT Modifiers
  1.  D FULL0^PXBCC
  1.  S PXNEWIEN=""
  1.  S PXMDCNT=$$CODM^ICPTCOD($P(REQI,"^",3),"^TMP(""PXMODARR"",$J",PXBSOURC,PXBVSTDT)
  1.  K ^TMP("PXMODARR",$J)
  1.  D MOD^PXBPMOD(PXBVST,PXBPAT,$P(REQI,"^",3),$G(PXMODSTR),$P(REQI,"^",8),IDATE,PXMDCNT,.PXMREQ)
  1.  I DATA["^C" D RSET^PXBDREQ("CPT") K PXMREQ G TEST3
  1.  I PXNEWIEN]"" S PXBNCPT($P(REQI,"^",3),PXNEWIEN)=""
  1.  ;
  1. TEST3Q ;--Prompt of the QUANTITY of the CPT code
  1.  S DEL=0
  1.  D WIN17^PXBCC(PXBCNT)
  1.  D QUA^PXBPQUA S PROMPT="CPT"
  1.  I EDATA["^C" D  G TEST3
  1.  .I PXNEWIEN]"" D REMOVE^PXCEVFIL(PXNEWIEN)
  1.  .D RSET^PXBDREQ("CPT") K PXMREQ
  1.  ;
  1.  ;--Create The ^TMP("PXK", ARRAY
  1.  S COM="0@" I COM[$P(REQI,"^",4) D
  1.  .D EN0^PXBSTOR(PXBVST,PATIENT,REQI,.PXMREQ)
  1.  .D EN1^PXKMAIN
  1.  .S DEL=1
  1.  ;--File the data into the V files
  1.  I $G(DEL)=1 D  G TEST3C
  1.  .I PXNEWIEN]"" D REMOVE^PXCEVFIL(PXNEWIEN)
  1.  ;
  1. TEST3P ;--GET PROVIDER
  1.  N PXBSKY,PXBKY,PXBSAM,PXBCNT,PRVDR,FPRI ;108
  1.  D PRV^PXBGPRV(PXBVST,.PXBSKY,.PXBKY,.PXBSAM,.PXBCNT,.PRVDR,.FPRI) W IOSC
  1.  S FROM="CPT" D PRV^PXBPPRV I DATA["^P" D  W IOCUU G TEST3P
  1.  .S $P(REQI,"^",1)="",$P(REQI,"^",2)="",$P(REQI,"^",7)=""
  1.  .K PXBDPRV
  1.  D EN0^PXBSTOR(PXBVST,PATIENT,REQI,.PXMREQ)
  1.  D EN1^PXKMAIN
  1.  D RSET^PXBDREQ("CPT") ;--RSET^PXBDREQ("PRV")
  1.  K PXMREQ
  1.  S $P(REQI,"^",7)=""
  1.  G TEST3C
  1.  ;
  1.  Q
  1. P ;--Obtain the correct provider
  1.  ;
  1.  Q
  1.  D HDR^PXBUTL(PXBVST,1)
  1.  D REQ^PXBDREQ(4)
  1.  D LOC^PXBCC(3,1)
  1.  W IOEDEOP
  1.  D CPT^PXBGCPT(PXBVST)
  1.  D EN0^PXBDCPT
  1.  D WIN17^PXBCC(PXBCNT)
  1.  D LOC^PXBCC(15,1)
  1.  Q
  1. CPTXIT ;----EXIT AND CLEAN UP
  1.  D KILL^PXBUTL3
  1.  D PRIM^PXBUTL
  1.  D FULL0^PXBCC
  1.  D CLEAR1^PXBCC
  1.  K PXBKY,PXBSAM,PXBSKY,PXKVST
  1.  ;
  1.  ;----Do the EVENT to the Protocol
  1.  ;D EVENT^PXKMAIN
  1.  K ^TMP("PXBDCPT",$J),^TMP("PXBSTOR",$J),^TMP("PXK",$J)
  1.  K ^TMP("PXBTOTAL",$J),^TMP("PXBTANA",$J)
  1.  Q