IBARXEU0 ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE ; 2-NOV-92
;;2.0;INTEGRATED BILLING;**139,385**; 21-MAR-94;Build 35
;;Per VHA Directive 2004-038, 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,IBOUT
;
S IBON=$$ON I IBON<1 Q IBON
;
S IBX="",IBJOB=14,IBEXERR="",IBOUT=0
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 G RXEXMTQ
. ;
. ; -- is the exemption still ok under VFA rules
. I $$VFAOK^IBARXEU($$LST(DFN,IBDT)) S IBX=$$IBX(DFN,IBDT) Q
. ;
. ; add a new one
. D AEX(DFN,IBDT) S IBX=$$IBX(DFN,IBDT)
;
; -- 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 Q:IBOUT
.. ;
.. ; -- is old exemption still good under VFA
.. I $$VFAOK^IBARXEU(Y) S IBX=$$IBX(DFN,IBDT),IBOUT=1 Q
.. ;
.. ; -- need to insert exemption
.. 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXEU0 4380 printed Apr 09, 2024@21:09:23 Page 2
IBARXEU0 ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE ; 2-NOV-92
+1 ;;2.0;INTEGRATED BILLING;**139,385**; 21-MAR-94;Build 35
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;
RXEXMT(DFN,IBDT) ; -- Check income exemption status of patient
+1 ; -- Warning, this function may cause new entries to be created
+2 ; when no data exists of new entry for current caledar year exists.
+3 ;
+4 ; input = : dfn = patient file pointer
+5 ; ibdt = date to check for
+6 ; returns :
+7 ; 0 if not exempt
+8 ; 1 if exempt^text^reason code^reason^date of test
+9 ;
+10 ;*** START RT CLOCK
+11 ;S XRTN="ADD EXEMPTION",XRTL=$ZU(0) D T0^%ZOSV
+12 ;
+13 NEW X,Y,IBON,IBX,IBJOB,IBEXERR,IBWHER,DA,DR,DIC,DIE,IBOUT
+14 ;
+15 SET IBON=$$ON
IF IBON<1
QUIT IBON
+16 ;
+17 SET IBX=""
SET IBJOB=14
SET IBEXERR=""
SET IBOUT=0
+18 IF '$GET(IBDT)
SET IBDT=DT
+19 ; no future dates
IF IBDT>DT
SET IBDT=DT
+20 ;
+21 ; -- date before legislation
+22 IF IBDT<$$STDATE^IBARXEU
SET IBX="0^NON-EXEMPT^^Date is prior to legislation^"
GOTO RXEXMTQ
+23 ;
+24 SET X=$GET(^IBA(354,DFN,0))
+25 ;
+26 ; -- if current patient, current request, get data and quit
+27 IF IBDT'<$PIECE(X,"^",3)
IF IBDT'>$$PLUS($PIECE(X,"^",3))
IF $PIECE(X,"^",4)'=""
SET IBX=$$IBX(DFN,IBDT)
GOTO RXEXMTQ
+28 ;
+29 ; -- if no patient add one
+30 IF '+X
DO ADDP^IBAUTL6
SET X=$GET(^IBA(354,DFN,0))
if $GET(IBEXERR)
GOTO RXEXMTQ
DO AEX(DFN,IBDT)
SET IBX=$$IBX(DFN,IBDT)
GOTO RXEXMTQ
+31 ;
+32 ; -- if current exemption older than 365 days add new one
+33 IF IBDT'<$PIECE(X,"^",3)
IF IBDT>$$PLUS($PIECE(X,"^",3))
Begin DoDot:1
+34 ;
+35 ; -- is the exemption still ok under VFA rules
+36 IF $$VFAOK^IBARXEU($$LST(DFN,IBDT))
SET IBX=$$IBX(DFN,IBDT)
QUIT
+37 ;
+38 ; add a new one
+39 DO AEX(DFN,IBDT)
SET IBX=$$IBX(DFN,IBDT)
End DoDot:1
GOTO RXEXMTQ
+40 ;
+41 ; -- if ibdt less than current date need old exemption data
+42 IF IBDT<$PIECE(X,"^",3)
Begin DoDot:1
+43 ;
+44 ;find status of prior year
+45 SET Y=$GET(^IBA(354.1,+$ORDER(^(+$ORDER(^IBA(354.1,"AIVDT",1,DFN,-(IBDT+.0001))),0)),0))
+46 ; -- no data
+47 IF Y=""
DO AEX(DFN,IBDT)
+48 ;
+49 ; -- old data too old need to insert exemption
+50 IF IBDT>$$PLUS(+Y)
Begin DoDot:2
+51 ;
+52 ; -- is old exemption still good under VFA
+53 IF $$VFAOK^IBARXEU(Y)
SET IBX=$$IBX(DFN,IBDT)
SET IBOUT=1
QUIT
+54 ;
+55 ; -- need to insert exemption
+56 DO AEX(DFN,IBDT)
End DoDot:2
if IBOUT
QUIT
+57 ;
+58 ; -- if old exemption is current for this copay date
+59 SET IBX=$$IBXOLD(DFN,IBDT)
+60 QUIT
End DoDot:1
+61 ;
+62 ;*** STOP RT CLOCK
RXEXMTQ ;I $D(XRT0),$D(XRTN) D T1^%ZOSV
+1 ;
+2 QUIT IBX
+3 ;
+4 ;
AEX(DFN,IBDT) ; -- add exemption
+1 ; set exemption effective date to means test dates
+2 ;
+3 NEW X
+4 SET X=$$STATUS^IBARXEU1(DFN,IBDT)
+5 DO ADDEX^IBAUTL6(+X,$PIECE(X,"^",2))
+6 QUIT
+7 ;
IBX(DFN,IBDT) ; -- format output from current status
+1 NEW X,Y
+2 SET X=$GET(^IBA(354,DFN,0))
SET Y=$$LST(DFN,IBDT)
+3 QUIT +$PIECE(X,"^",4)_"^"_$$TEXT(+$PIECE(X,"^",4))_"^"_$$ACODE(Y)_"^"_$$REASON(Y)_"^"_+Y
+4 ;
IBXOLD(DFN,IBDT) ; -- format output from old exemption
+1 NEW X,Y
+2 SET Y=$$LST(DFN,IBDT)
+3 ; exemption reason node
SET X=$GET(^IBE(354.2,+$PIECE(Y,"^",5),0))
+4 QUIT +$PIECE(X,"^",4)_"^"_$$TEXT(+$PIECE(X,"^",4))_"^"_$$ACODE(Y)_"^"_$$REASON(Y)_"^"_+Y
+5 ;
+6 ;
ON() ; -- is copay exemption testing on
+1 ; output 1 = exemption testing is active
+2 ; 0 = exemption testing is inactive (everybody non-exempt)
+3 ; -1 = copay is off (everybody exempt)
+4 QUIT 1
+5 ;Q "0^NON-EXEMPT^0^Medication Copay Exemption Testing turned off^"_DT
+6 ;Q "-1^EXEMPT^0^Medication Copayment has been turned off^"_DT
+7 ;
PLUS(X1) ; -- computes plus 1 year (into future)
+1 ; if x1=2920930 + 1 year = +10000 = 2930930
+2 ;makes the anniversary date March 1
IF $EXTRACT(X1,4,7)="0229"
QUIT X1+10072
+3 QUIT X1+10000
+4 ;
MINUS(X1) ; -- computes minus 1 year (into past)
+1 QUIT X1-10000
+2 ;
ACODE(Y) ; -- return lookup code of reason, input zeroth node of exemption
+1 QUIT $PIECE($GET(^IBE(354.2,+$PIECE($GET(Y),"^",5),0)),"^",5)
+2 ;
REASON(Y) ; -- return reason description, input zeroth node of exemption
+1 QUIT $PIECE($GET(^IBE(354.2,+$PIECE($GET(Y),"^",5),0)),"^",2)
+2 ;
TEXT(X) ; -- convert 0 or 1 to text
+1 QUIT $SELECT(X=1:"EXEMPT",X=0:"NON-EXEMPT",1:"UNKNOWN")
+2 ;
LST(DFN,IBDT) ; -- returns last exemption entry before date x
+1 ;
+2 ; -- returns zeroth node of last test before date
+3 ;
+4 IF '$GET(IBDT)
SET IBDT=DT
+5 QUIT $GET(^IBA(354.1,+$ORDER(^(+$ORDER(^IBA(354.1,"AIVDT",1,DFN,-(IBDT+.00001))),0)),0))
+6 ;
LSTAC(DFN) ; -- computes last reason code and date for a patient
+1 ; -- returns exemption reason ^ exemption date
+2 NEW X1
+3 SET X1=$GET(^IBA(354.1,+$ORDER(^(+$ORDER(^IBA(354.1,"AIVDT",1,DFN,-(DT+.00001))),0)),0))
+4 QUIT $PIECE($GET(^IBE(354.2,+$PIECE(X1,"^",5),0)),"^",5)_"^"_+X1
