- 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 Feb 18, 2025@23:33:47 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