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

IBARXEU0.m

Go to the documentation of this file.
  1. IBARXEU0 ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE ; 2-NOV-92
  1. ;;2.0;INTEGRATED BILLING;**139,385**; 21-MAR-94;Build 35
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ;
  1. RXEXMT(DFN,IBDT) ; -- Check income exemption status of patient
  1. ; -- Warning, this function may cause new entries to be created
  1. ; when no data exists of new entry for current caledar year exists.
  1. ;
  1. ; input = : dfn = patient file pointer
  1. ; ibdt = date to check for
  1. ; returns :
  1. ; 0 if not exempt
  1. ; 1 if exempt^text^reason code^reason^date of test
  1. ;
  1. ;*** START RT CLOCK
  1. ;S XRTN="ADD EXEMPTION",XRTL=$ZU(0) D T0^%ZOSV
  1. ;
  1. N X,Y,IBON,IBX,IBJOB,IBEXERR,IBWHER,DA,DR,DIC,DIE,IBOUT
  1. ;
  1. S IBON=$$ON I IBON<1 Q IBON
  1. ;
  1. S IBX="",IBJOB=14,IBEXERR="",IBOUT=0
  1. I '$G(IBDT) S IBDT=DT
  1. I IBDT>DT S IBDT=DT ; no future dates
  1. ;
  1. ; -- date before legislation
  1. I IBDT<$$STDATE^IBARXEU S IBX="0^NON-EXEMPT^^Date is prior to legislation^" G RXEXMTQ
  1. ;
  1. S X=$G(^IBA(354,DFN,0))
  1. ;
  1. ; -- if current patient, current request, get data and quit
  1. I IBDT'<$P(X,"^",3),IBDT'>$$PLUS($P(X,"^",3)),$P(X,"^",4)'="" S IBX=$$IBX(DFN,IBDT) G RXEXMTQ
  1. ;
  1. ; -- if no patient add one
  1. I '+X D ADDP^IBAUTL6 S X=$G(^IBA(354,DFN,0)) G:$G(IBEXERR) RXEXMTQ D AEX(DFN,IBDT) S IBX=$$IBX(DFN,IBDT) G RXEXMTQ
  1. ;
  1. ; -- if current exemption older than 365 days add new one
  1. I IBDT'<$P(X,"^",3),IBDT>$$PLUS($P(X,"^",3)) D G RXEXMTQ
  1. . ;
  1. . ; -- is the exemption still ok under VFA rules
  1. . I $$VFAOK^IBARXEU($$LST(DFN,IBDT)) S IBX=$$IBX(DFN,IBDT) Q
  1. . ;
  1. . ; add a new one
  1. . D AEX(DFN,IBDT) S IBX=$$IBX(DFN,IBDT)
  1. ;
  1. ; -- if ibdt less than current date need old exemption data
  1. I IBDT<$P(X,"^",3) D
  1. .;
  1. .;find status of prior year
  1. .S Y=$G(^IBA(354.1,+$O(^(+$O(^IBA(354.1,"AIVDT",1,DFN,-(IBDT+.0001))),0)),0))
  1. .; -- no data
  1. .I Y="" D AEX(DFN,IBDT)
  1. .;
  1. .; -- old data too old need to insert exemption
  1. .I IBDT>$$PLUS(+Y) D Q:IBOUT
  1. .. ;
  1. .. ; -- is old exemption still good under VFA
  1. .. I $$VFAOK^IBARXEU(Y) S IBX=$$IBX(DFN,IBDT),IBOUT=1 Q
  1. .. ;
  1. .. ; -- need to insert exemption
  1. .. D AEX(DFN,IBDT)
  1. .;
  1. .; -- if old exemption is current for this copay date
  1. .S IBX=$$IBXOLD(DFN,IBDT)
  1. .Q
  1. ;
  1. ;*** STOP RT CLOCK
  1. RXEXMTQ ;I $D(XRT0),$D(XRTN) D T1^%ZOSV
  1. ;
  1. Q IBX
  1. ;
  1. ;
  1. AEX(DFN,IBDT) ; -- add exemption
  1. ; set exemption effective date to means test dates
  1. ;
  1. N X
  1. S X=$$STATUS^IBARXEU1(DFN,IBDT)
  1. D ADDEX^IBAUTL6(+X,$P(X,"^",2))
  1. Q
  1. ;
  1. IBX(DFN,IBDT) ; -- format output from current status
  1. N X,Y
  1. S X=$G(^IBA(354,DFN,0)),Y=$$LST(DFN,IBDT)
  1. Q +$P(X,"^",4)_"^"_$$TEXT(+$P(X,"^",4))_"^"_$$ACODE(Y)_"^"_$$REASON(Y)_"^"_+Y
  1. ;
  1. IBXOLD(DFN,IBDT) ; -- format output from old exemption
  1. N X,Y
  1. S Y=$$LST(DFN,IBDT)
  1. S X=$G(^IBE(354.2,+$P(Y,"^",5),0)) ; exemption reason node
  1. Q +$P(X,"^",4)_"^"_$$TEXT(+$P(X,"^",4))_"^"_$$ACODE(Y)_"^"_$$REASON(Y)_"^"_+Y
  1. ;
  1. ;
  1. ON() ; -- is copay exemption testing on
  1. ; output 1 = exemption testing is active
  1. ; 0 = exemption testing is inactive (everybody non-exempt)
  1. ; -1 = copay is off (everybody exempt)
  1. Q 1
  1. ;Q "0^NON-EXEMPT^0^Medication Copay Exemption Testing turned off^"_DT
  1. ;Q "-1^EXEMPT^0^Medication Copayment has been turned off^"_DT
  1. ;
  1. PLUS(X1) ; -- computes plus 1 year (into future)
  1. ; if x1=2920930 + 1 year = +10000 = 2930930
  1. I $E(X1,4,7)="0229" Q X1+10072 ;makes the anniversary date March 1
  1. Q X1+10000
  1. ;
  1. MINUS(X1) ; -- computes minus 1 year (into past)
  1. Q X1-10000
  1. ;
  1. ACODE(Y) ; -- return lookup code of reason, input zeroth node of exemption
  1. Q $P($G(^IBE(354.2,+$P($G(Y),"^",5),0)),"^",5)
  1. ;
  1. REASON(Y) ; -- return reason description, input zeroth node of exemption
  1. Q $P($G(^IBE(354.2,+$P($G(Y),"^",5),0)),"^",2)
  1. ;
  1. TEXT(X) ; -- convert 0 or 1 to text
  1. Q $S(X=1:"EXEMPT",X=0:"NON-EXEMPT",1:"UNKNOWN")
  1. ;
  1. LST(DFN,IBDT) ; -- returns last exemption entry before date x
  1. ;
  1. ; -- returns zeroth node of last test before date
  1. ;
  1. I '$G(IBDT) S IBDT=DT
  1. Q $G(^IBA(354.1,+$O(^(+$O(^IBA(354.1,"AIVDT",1,DFN,-(IBDT+.00001))),0)),0))
  1. ;
  1. LSTAC(DFN) ; -- computes last reason code and date for a patient
  1. ; -- returns exemption reason ^ exemption date
  1. N X1
  1. S X1=$G(^IBA(354.1,+$O(^(+$O(^IBA(354.1,"AIVDT",1,DFN,-(DT+.00001))),0)),0))
  1. Q $P($G(^IBE(354.2,+$P(X1,"^",5),0)),"^",5)_"^"_+X1