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

IBARXEC3.m

Go to the documentation of this file. 
  1. IBARXEC3	;ALB/AAS -RX CO-PAY INCOME EXEMPTION CONVERSION ; 2-NOV-92
  1. 	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
  1. 	;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. 	;
  1. DQ	; -- run background sweep
  1. 	;
  1. 	U IO
  1. 	S IBJOB=11
  1. 	I $G(IBDONE)=1 G REPORT
  1. 	S (IBTCNT,IBTECNT,IBTNCNT,IBTAMT,IBTEAMT,IBTNAMT,IBTCECNT,IBTCEAMT,IBTNECNT,IBTBCNT,IBTCBCNT,IBQUIT)=0
  1. 	I IBARXJOB>1 S X=^IBE(350.9,1,3) D GET ; -- set variables to previous amounts
  1. 	;
  1. 	; -- Don't allow multiple conversion to run
  1. 	D CHK G:IBQUIT DQEND
  1. 	;
  1. 	; -- Start with last patient processed
  1. 	S DFN=+$P(^IBE(350.9,1,3),"^",4)
  1. 	;
  1. 	S IBDT=$S(IBDT<$$STDATE^IBARXEU:$$STDATE^IBARXEU,1:IBDT)
  1. 	F  S DFN=$O(^IB("APTDT",DFN)) Q:'DFN  D CHK Q:IBQUIT  I $O(^IB("APTDT",DFN,(IBDT-.01)))'>IBEDT D PAT I '$D(ZTQUEUED),'(IBTCNT#10) D READ W "."
  1. 	I DFN="" S IBDONE=1 D 
  1. 	.; --set done flag once completed
  1. 	.D NOW^%DTC S $P(^IBE(350.9,1,3),"^",14)=%
  1. 	.;
  1. 	.D ^IBARXEC2 ;send mail message if done
  1. 	.Q
  1. 	;
  1. REPORT	; -- start the report process here
  1. 	D:$G(IBDONE)=1 REPORT^IBARXEC1
  1. DQEND	D END^IBARXEC ;conversion all done
  1. 	Q
  1. 	;
  1. PAT	; -- process one patient
  1. 	;
  1. 	K ^TMP($J,"IBARRY") D KVAR^VADPT
  1. 	S (IBCNT,IBECNT,IBCECNT,IBNCNT,IBAMT,IBEAMT,IBCEAMT,IBNAMT,IBNECNT,IBBCNT,IBCBCNT)=0
  1. 	S IBCNT=1 ;one patient checked
  1. 	S IBSTAT=$$RXEXMT^IBARXEU0(DFN,DT) ;get current status
  1. 	S:IBSTAT IBECNT=1 S:'IBSTAT IBNCNT=1 ; current status count
  1. 	;
  1. 	; -- must check each charge even if patient is exempt
  1. 	D CANCEL^IBARXECA(DFN,IBDT,IBEDT) ;cancel IB charges for patient from beg to end
  1. 	D COUNTS
  1. 	D CANDT^IBARXEU4 ;see if converted on the fly
  1. 	D ARCAN^IBARXEU4(DFN,IBSTAT,$P(IBCANDT,"^"),$P(IBCANDT,"^",2))
  1. 	;
  1. PATQ	Q
  1. 	;
  1. 	;
  1. COUNTS	; -- update the counts  -  Variables by:
  1. 	;
  1. 	;      Patient    Totals       Represents
  1. 	;      -------    ------       ----------
  1. 	;  5   ibcnt      ibtcnt   = : total patient count checked
  1. 	;  6   ibecnt     ibtecnt  = : total exempt patients
  1. 	;  7   ibncnt     ibtncnt  = : total non-exempt patients
  1. 	;  8   ibcecnt    ibtcecnt = : total count of exempt charges (rx's)
  1. 	;  9   ibamt      ibtamt   = : total dollar amount checked
  1. 	; 10   ibeamt     ibteamt  = : total exempt dollar amount
  1. 	; 11   ibnamt     ibtnamt  = : total non-exempt dollar amount
  1. 	; 12   ibceamt    ibtceamt = : total cancelled charges amount
  1. 	; 15   ibnecnt    ibtnecnt = : total non-exempt count
  1. 	; 16   ibbcnt     ibtbcnt  = : total bills checked
  1. 	; 17   ibcbcnt    ibtcbcnt = : total number of cancelled bills
  1. 	;
  1. 	S IBTCNT=IBTCNT+IBCNT
  1. 	S IBTECNT=IBTECNT+IBECNT
  1. 	S IBTNCNT=IBTNCNT+IBNCNT
  1. 	S IBTCECNT=IBTCECNT+IBCECNT
  1. 	S IBTAMT=IBTAMT+IBAMT
  1. 	S IBTEAMT=IBTEAMT+IBEAMT
  1. 	S IBTNAMT=IBTNAMT+IBNAMT
  1. 	S IBTCEAMT=IBTCEAMT+IBCEAMT
  1. 	S IBTNECNT=IBTNECNT+IBNECNT
  1. 	S IBTBCNT=IBTBCNT+IBBCNT
  1. 	S IBTCBCNT=IBTCBCNT+IBCBCNT
  1. 	Q:'$D(IBCONVER)
  1. 	;
  1. 	; -- set run paramters for conversion
  1. 	S $P(^IBE(350.9,1,3),"^",4,12)=DFN_U_IBTCNT_U_IBTECNT_U_IBTNCNT_U_IBTCECNT_U_IBTAMT_U_IBTEAMT_U_IBTNAMT_U_IBTCEAMT,$P(^(3),"^",15,17)=IBTNECNT_U_IBTBCNT_U_IBTCBCNT
  1. 	Q
  1. 	;
  1. CHK	; -- Don't allow multiple conversion to run
  1. 	I IBARXJOB'=$P(^IBE(350.9,1,3),"^",3)  W !!,"The Integrated Billing Check of Pharmacy Copay Exemption due to Income",!,"was terminated.  Appears to be already running!" S IBQUIT=1
  1. 	Q
  1. 	;
  1. READ	; -- pause, check for an excape
  1. 	N X,IBSHOW F  R X:1 Q:'$T  I X["^" D:'$D(IBSHOW) QUIC^IBARXEC1 S IBSHOW=""
  1. 	Q
  1. 	;
  1. GET	; -- set initialization variable if restarting
  1. 	S IBTCNT=$P(X,"^",5)
  1. 	S IBTECNT=$P(X,"^",6)
  1. 	S IBTNCNT=$P(X,"^",7)
  1. 	S IBTCECNT=$P(X,"^",8)
  1. 	S IBTAMT=$P(X,"^",9)
  1. 	S IBTEAMT=$P(X,"^",10)
  1. 	S IBTNAMT=$P(X,"^",11)
  1. 	S IBTCEAMT=$P(X,"^",12)
  1. 	S IBTNECNT=$P(X,"^",15)
  1. 	S IBTBCNT=$P(X,"^",16)
  1. 	S IBTCBCNT=$P(X,"^",17)
  1. 	Q