source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBARXEU0.m@ 1769

IBARXEU0 ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE ; 2-NOV-92

 ;;2.0;INTEGRATED BILLING;**139**; 21-MAR-94

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

 ;

 ;

RXEXMT(DFN,IBDT) ; -- Check income exemption status of patient

 ; -- Warning, this function may cause new entries to be created

 ;    when no data exists of new entry for current caledar year exists.

 ;

 ;  input = :  dfn  = patient file pointer

 ;             ibdt = date to check for

 ;  returns :

 ;              0 if not exempt

 ;              1 if exempt^text^reason code^reason^date of test

 ;

 ;*** START RT CLOCK

 ;S XRTN="ADD EXEMPTION",XRTL=$ZU(0) D T0^%ZOSV

 ;

 N X,Y,IBON,IBX,IBJOB,IBEXERR,IBWHER,DA,DR,DIC,DIE

 ;

 S IBON=$$ON I IBON<1 Q IBON

 ;

 S IBX="",IBJOB=14,IBEXERR=""

 I '$G(IBDT) S IBDT=DT

 I IBDT>DT S IBDT=DT ; no future dates

 ;

 ; -- date before legislation

 I IBDT<$$STDATE^IBARXEU S IBX="0^NON-EXEMPT^^Date is prior to legislation^" G RXEXMTQ

 ;

 S X=$G(^IBA(354,DFN,0))

 ;

 ; -- if current patient, current request, get data and quit

 I IBDT'<$P(X,"^",3),IBDT'>$$PLUS($P(X,"^",3)),$P(X,"^",4)'="" S IBX=$$IBX(DFN,IBDT) G RXEXMTQ

 ;

 ; -- if no patient add one

 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

 ;

 ; -- if current exemption older than 365 days add new one

 I IBDT'<$P(X,"^",3),IBDT>$$PLUS($P(X,"^",3)) D AEX(DFN,IBDT) S IBX=$$IBX(DFN,IBDT) G RXEXMTQ

 ;

 ; -- if ibdt less than current date need old exemption data

 I IBDT<$P(X,"^",3) D

 .;

 .;find status of prior year

 .S Y=$G(^IBA(354.1,+$O(^(+$O(^IBA(354.1,"AIVDT",1,DFN,-(IBDT+.0001))),0)),0))

 .; -- no data

 .I Y="" D AEX(DFN,IBDT)

 .;

 .; -- old data too old need to insert exemption

 .I IBDT>$$PLUS(+Y) D AEX(DFN,IBDT)

 .;

 .; -- if old exemption is current for this copay date

 .S IBX=$$IBXOLD(DFN,IBDT)

 .Q

 ;

 ;*** STOP RT CLOCK

RXEXMTQ ;I $D(XRT0),$D(XRTN) D T1^%ZOSV

 ;

 Q IBX

 ;

 ;

AEX(DFN,IBDT) ; -- add exemption

 ; set exemption effective date to means test dates

 ;

 N X

 S X=$$STATUS^IBARXEU1(DFN,IBDT)

 D ADDEX^IBAUTL6(+X,$P(X,"^",2))

 Q

 ;

IBX(DFN,IBDT) ; -- format output from current status

 N X,Y

 S X=$G(^IBA(354,DFN,0)),Y=$$LST(DFN,IBDT)

 Q +$P(X,"^",4)_"^"_$$TEXT(+$P(X,"^",4))_"^"_$$ACODE(Y)_"^"_$$REASON(Y)_"^"_+Y

 ;

IBXOLD(DFN,IBDT) ; -- format output from old exemption

 N X,Y

 S Y=$$LST(DFN,IBDT)

 S X=$G(^IBE(354.2,+$P(Y,"^",5),0)) ; exemption reason node

 Q +$P(X,"^",4)_"^"_$$TEXT(+$P(X,"^",4))_"^"_$$ACODE(Y)_"^"_$$REASON(Y)_"^"_+Y

 ;

 ;

ON() ; -- is copay exemption testing on

 ;    output 1 = exemption testing is active

 ;           0 = exemption testing is inactive (everybody non-exempt)

 ;          -1 = copay is off (everybody exempt)

 Q 1

 ;Q "0^NON-EXEMPT^0^Medication Copay Exemption Testing turned off^"_DT

 ;Q "-1^EXEMPT^0^Medication Copayment has been turned off^"_DT

 ;

PLUS(X1) ; -- computes plus 1 year (into future)

 ; if x1=2920930 + 1 year = +10000 = 2930930

 I $E(X1,4,7)="0229" Q X1+10072  ;makes the anniversary date March 1

 Q X1+10000

 ;

MINUS(X1) ; -- computes minus 1 year (into past)

 Q X1-10000

 ;

ACODE(Y) ; -- return lookup code of reason, input zeroth node of exemption

 Q $P($G(^IBE(354.2,+$P($G(Y),"^",5),0)),"^",5)

 ;

REASON(Y) ; -- return reason description, input zeroth node of exemption

 Q $P($G(^IBE(354.2,+$P($G(Y),"^",5),0)),"^",2)

 ;

TEXT(X) ; -- convert 0 or 1 to text

 Q $S(X=1:"EXEMPT",X=0:"NON-EXEMPT",1:"UNKNOWN")

 ;

LST(DFN,IBDT) ; -- returns last exemption entry before date x

 ;

 ; -- returns zeroth node of last test before date

 ;

 I '$G(IBDT) S IBDT=DT

 Q $G(^IBA(354.1,+$O(^(+$O(^IBA(354.1,"AIVDT",1,DFN,-(IBDT+.00001))),0)),0))

 ;

LSTAC(DFN) ; -- computes last reason code and date for a patient

 ; -- returns exemption reason ^ exemption date

 N X1

 S X1=$G(^IBA(354.1,+$O(^(+$O(^IBA(354.1,"AIVDT",1,DFN,-(DT+.00001))),0)),0))

 Q $P($G(^IBE(354.2,+$P(X1,"^",5),0)),"^",5)_"^"_+X1