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

IBARXEU3.m

Go to the documentation of this file. 
  1. IBARXEU3	;ALB/AAS - RX COPAY EXEMPTION PROCESS AR CANCELS ; 8-JAN-93
  1. 	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
  1. 	;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. 	;
  1. CANCEL	; -- cancel old ib and ar logic if going from non-exempt to exempt
  1. 	;    based on updated income testing.
  1. 	; -- called whenever adding an exemption
  1. 	;    requires event driver variables.
  1. 	;
  1. 	Q:'IBSTAT  ; non-exempt patient
  1. 	N IBDT,IBEDT,IBCODA,IBCODP,IBSITE,IBAFY,IBATYP,IBCANDT,IBCHRG,IBCRES,IBERR,IBFAC,IBIL,IBL,IBLAST,IBLDT,IBN,IBND,IBNN,IBNOW,IBPARNT,IBPARNT1,IBSEQNO,IBUNIT,LST
  1. 	;
  1. 	; -- if new code is income < pension (120) and no prior code or 
  1. 	;               prior code was no income data cancel charges
  1. 	;
  1. 	S IBCODP=$$ACODE^IBARXEU0(IBEVTP),IBCODA=$$ACODE^IBARXEU0(IBEVTA)
  1. 	I '$$NETW^IBARXEU1 G:IBCODA'=120 CANCELQ I $S(IBCODP="":0,IBCODP=210:0,1:1) G CANCELQ
  1. 	I $$NETW^IBARXEU1,$S(IBCODA=120:$S(IBCODP="":0,IBCODP=210:0,1:1),IBCODA=150:$S(IBCODP=130:0,1:1),1:1) G CANCELQ
  1. 	;
  1. 	; -- set begin and end dates
  1. 	S IBDT=+IBEVTP
  1. 	I IBDT<$$STDATE^IBARXEU S IBDT=$$STDATE^IBARXEU
  1. 	; -- if new exemption is most current, set begin date to dt, else set to exemption date
  1. 	S IBEDT=$S(+$$LST^IBARXEU0(DFN,DT)=+IBEVTA:DT,1:+IBEVTA)
  1. 	;
  1. 	; -- see if exemption prior to one being canceled same
  1. 	S LST=$$LST^IBARXEU0(DFN,+IBEVTP-.01)
  1. 	I +LST,$P(IBEVTP,"^",5)=$P(LST,"^",5) S IBDT=+LST
  1. 	D CANDT^IBARXEU4
  1. 	;
  1. 	; -- See if patient has any bills
  1. 	S X=$O(^IB("APTDT",DFN,(IBDT-.01))) I 'X!(X>(IBEDT+.9)) G CANCELQ
  1. 	;
  1. 	; -- cancel bills in IB
  1. 	D ARPARM^IBAUTL
  1. 	S IBBDT=$P(IBCANDT,"^")-.0001
  1. 	F  S IBBDT=$O(^IB("APTDT",DFN,IBBDT)) Q:'IBBDT!((IBEDT+.9)<IBBDT)  S IBN=0 F  S IBN=$O(^IB("APTDT",DFN,IBBDT,IBN)) Q:'IBN  D BILL
  1. 	;
  1. 	; -- cancel bills in AR
  1. 	Q:$P(IBCANDT,"^",2)<$P(IBCANDT,"^")  D ARCAN^IBARXEU4(DFN,IBSTAT,$P(IBCANDT,"^"),$P(IBCANDT,"^",2))
  1. 	;
  1. CANCELQ	Q
  1. 	;
  1. BILL	; -- process cancelling one bill
  1. 	S X=$G(^IB(IBN,0)) Q:X=""
  1. 	Q:+$P(X,"^",4)'=52  ;quit if not pharmacy co-pay
  1. 	;
  1. 	; -- find parent
  1. 	S IBPARNT=$P(X,"^",9)
  1. 	;
  1. 	S IBPARDT=$P($G(^IB(IBPARNT,1)),"^",2) ; get date of parent charge
  1. 	I $S(IBPARDT="":1,IBPARDT<IBDT:1,IBPARDT>(IBEDT+.9):1,1:0) Q  ; ignore charges started before or after date range
  1. 	;
  1. 	; -- get must recent ibaction
  1. 	S IBPARNT1=IBPARNT F  S IBPARNT1=$P($G(^IB(IBPARNT,0)),"^",9) Q:IBPARNT1=IBPARNT  S IBPARNT=IBPARNT1 ;gets parent of parents
  1. 	D LAST
  1. 	;
  1. 	Q:$P(^IBE(350.1,$P(^IB(IBLAST,0),"^",3),0),"^",5)=2  ;quit if already cancelled
  1. 	;
  1. 	S IBCRES=$O(^IBE(350.3,"B","RX COPAY INCOME EXEMPTION",0)) ; get cancellation reason
  1. 	;
  1. 	D CANRX
  1. 	Q
  1. 	;
  1. CANRX	; -- do acutal cancellation without calling ar
  1. 	;    input :  iblast := last entry for parnt
  1. 	;             ibparnt := parent charge
  1. 	;             ibnd    := ^(0) node of iblast
  1. 	;
  1. 	;    returns: ibnn    := entry number of new node
  1. 	;
  1. 	N IBN
  1. 	S IBNN="" ;return new node in ibnn
  1. 	I $D(^IB(IBLAST,0)),$P(^IBE(350.1,$P(^IB(IBLAST,0),"^",3),0),"^",5)=2 G CANRXQ ;already cancelled
  1. 	S IBND=$G(^IB(+IBLAST,0)),IBDUZ=DUZ
  1. 	;
  1. 	S IBATYP=$P(^IBE(350.1,+$P($G(^IB(IBPARNT,0)),"^",3),0),"^",6) ;cancellation action type for parent
  1. 	I '$D(^IBE(350.1,+IBATYP,0)) G CANRXQ
  1. 	S IBSEQNO=$P(^IBE(350.1,+IBATYP,0),"^",5) I 'IBSEQNO G CANRXQ
  1. 	S IBIL=$P($G(^IB(IBPARNT,0)),"^",11)
  1. 	S IBUNIT=$S($P(IBND,"^",6):$P(IBND,"^",6),$D(^IB(IBPARNT,0)):$P(^(0),"^",6),1:0) I IBUNIT<1 G CANRXQ
  1. 	S DA=IBATYP D COST^IBAUTL S IBCHRG=IBUNIT*X1
  1. 	;
  1. 	D ADD^IBAUTL I +Y<1 G CANRXQ
  1. 	S $P(^IB(IBN,1),"^",1)=IBDUZ,$P(^IB(IBN,0),"^",2,13)=DFN_"^"_IBATYP_"^"_$P(IBND,"^",4)_"^11^"_IBUNIT_"^"_IBCHRG_"^"_$P(IBND,"^",8)_"^"_IBPARNT_"^"_IBCRES_"^"_IBIL_"^^"_IBFAC
  1. 	K ^IB("AC",1,IBN)
  1. 	S DA=IBN,DIK="^IB(" D IX^DIK
  1. 	S IBNN=IBN
  1. 	;
  1. 	; -- update parent to cancelled
  1. 	;    note: parent status=10, cancellation due to exemption reason only
  1. 	;          on charge cancelled so reports work right.
  1. 	S DIE="^IB(",DA=IBPARNT,DR=".05////10;.1////"_IBCRES D ^DIE K DIE,DA,DR
  1. CANRXQ	Q
  1. 	;
  1. LAST	; -- find most recent (the last) entry for a parent action
  1. 	S IBLAST=""
  1. 	S IBLDT=$O(^IB("APDT",IBPARNT,"")) I +IBLDT F IBL=0:0 S IBL=$O(^IB("APDT",IBPARNT,IBLDT,IBL)) Q:'IBL  S IBLAST=IBL
  1. 	I IBLAST="" S IBLAST=IBPARNT
  1. 	Q