IBARXEU ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE ;2-NOV-92
;;2.0;INTEGRATED BILLING;**20,222,293,385**;21-MAR-94;Build 35
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;
RXST(DFN,IBDT) ; -- Check rx income exemption status of patient
;
; input = : dfn = patient file pointer
; ibdt = date to check for (optional) default is today
;
; returns : -1 if no data ^text^reason code^reason text^date of test
; 0 if non exempt
; 1 if exempt
;
N X,Y,Z,IBX,IBON
;
S IBON=$$ON^IBARXEU0 I IBON<1 Q IBON
;
S IBX=""
I '$G(IBDT) S IBDT=DT
I IBDT>DT S IBDT=DT ; no future dates
;
; -- date before legislations
I IBDT<$$STDATE S IBX="0^NON-EXEMPT^^Date is Prior to Legislation^" G RXSTQ ; nobody exempt prior to legislation
;
; -- if no data on patient quit
S X=$G(^IBA(354,DFN,0))
I X=""!('$D(^IBA(354.1,"AP",DFN))) S IBX="-1^UNKNOWN^^Medication Copayment Exemption status never determined" G RXSTQ ; no data return -1
;
; -- use current status if ibdt not less than current test and
; not greater than current test date +365
I IBDT'<$P(X,U,3),IBDT'>$$PLUS^IBARXEU0($P(X,U,3)) S IBX=$$IBX^IBARXEU0(DFN,IBDT) G RXSTQ
;
; -- if ibdt not less than current date but greater than
; current test +365 is into future
I IBDT'<$P(X,U,3),IBDT>$$PLUS^IBARXEU0($P(X,U,3)) D
.S Y=$$LST^IBARXEU0(DFN,IBDT)
.;
.; -- see if patient was SC>50, can't be updated so don't say previous
.; also check to see if last is still ok under VFA rules
.I $L($$ACODE^IBARXEU0(Y))<3!($$VFAOK(Y)) S IBX=+$P(X,U,4)_U_$$TEXT^IBARXEU0($P(X,U,4))_U_$$ACODE^IBARXEU0(Y)_U_$$REASON^IBARXEU0(X)_U_$P(X,U,3) Q
.;
.S IBX=+$P(X,U,4)_U_"Previously "_$$TEXT^IBARXEU0($P(X,U,4))_U_$$ACODE^IBARXEU0(Y)_U_"Requires new exemption. Previously "_$$REASON^IBARXEU0(X)_U_$P(X,U,3)
;
; -- if ibdt less than current date need old exemption data
I IBDT<$P(X,U,3) D G RXSTQ
.;
.; -- find status of prior test
.S Y=$$LST^IBARXEU0(DFN,IBDT)
.;
.; -- no previous data
.I Y="" D Q
..S IBX="-1^UNKNOWN^^No data for date requested."
..Q
.;
.S Z=$G(^IBA(354,DFN,0)),Z=$P(Z,U,5)_U_$P(Z,U,3) ; get status & date
.;
.; -- if old exemption is current for copay date
.I IBDT'>$$PLUS^IBARXEU0(+Y) D Q
..S X=$G(^IBE(354.2,+$P(Y,U,5),0)) ; exemption reason node
..S IBX=+$P(X,U,4)_U_$$TEXT^IBARXEU0($P(X,U,4))_U_$$ACODE^IBARXEU0(Y)_U_$$REASON^IBARXEU0(X)_U_$P(X,U,3)
..Q
.;
.; -- if ibdt is greater than old exemption + 365
.; report previous
.I IBDT>$$PLUS^IBARXEU0(+Y) D Q
..S X=$G(^IBE(354.2,+$P(Y,U,5),0)) ;exemption reason node
..;
..; -- see if patient was SC>50, can't be updated so don't say previous
..; also check to see if last is still ok under VFA rules
..I $L($$ACODE^IBARXEU0(Y))<3!($$VFAOK(Y)) S IBX=+$P(X,U,4)_U_$$TEXT^IBARXEU0($P(X,U,4))_U_$$ACODE^IBARXEU0(Y)_U_$$REASON^IBARXEU0(X)_U_$P(X,U,3) Q
..;
..S IBX=+$P(X,U,4)_U_"Previously "_$$TEXT^IBARXEU0($P(X,U,4))_U_$$ACODE^IBARXEU0(Y)_U_"Requires new exemption. Previously "_$$REASON^IBARXEU0(X)_U_$P(X,U,3)
..Q
.Q
;
RXSTQ Q IBX
;
DISP(DFN,IBDT,NO,NULL) ; -- formats text to display
; -- input = dfn
; ibdt = date to check for
; no = number of lines to print (1, 2, or 3)
; null = if zero print unknown, if non-zero quit
;
I '$G(IBDT) S IBDT=DT
I '$D(NULL) S NULL=1
I IBDT>DT S IBDT=DT ; no future dates
I '$G(NO) S NO=3
S X=$$RXST(DFN,IBDT)
S IBON=$$ON^IBARXEU0 I IBON<1 S X=IBON
I X<0&(NULL) G DISPQ
W !,"Medication Copayment Exemption Status: ",$P(X,U,2) G:NO<2 DISPQ
W !,$P(X,U,4) G:NO<3 DISPQ
I $P(X,U,5) W !,"Last Rx Copay Exemption date: " S Y=$P(X,U,5) D DT^DIQ
DISPQ Q
;
STDATE() ; -- legislative start date for income exemption
Q 2921030
;
;
ACTIVE(IBZ) ; -- SCREEN for active field of billing exemptions file
; only one entry per effective date can be active
;
N IBX,IBY,T
S T=0
S IBZ=$S(IBZ=1:IBZ,$E(IBZ)="A":1,1:0)
I 'IBZ S T=1 G ACTIVEQ
S IBX=$G(^IBA(354.1,DA,0))
S IBY=$O(^IBA(354.1,"AIVDT",+$P(IBX,U,3),+$P(IBX,U,2),-$P(IBX,U),0))
I 'IBY!(IBY=DA) S T=1
W:$D(IBTALK) !!,"Another entry is already Active, You must inactivate it first",!!
ACTIVEQ Q T
;
VFA() ; -- returns VFA (no longer asking for mt income info) start date
; less One year
; ICR #431
N IBDT
S IBDT=$$GET1^DIQ(43,"1,",1205,"I")
S:IBDT IBDT=$$MINUS^IBARXEU0(IBDT)
Q IBDT
;
VFAOK(X) ; - under VFA (veterans financial assestment) rules, MT no
; longer required if within one year of VFA start date, use last test.
; Pass in the zeroth node of the 354.1 exemption.
; Output = OK under VFA rules or not (1 or 0)
;
N IBACODE,IBLST
;
; -- is this test income related, if not then not OK
S IBACODE=$$ACODE^IBARXEU0(X)
I IBACODE<100,IBACODE>200 Q 0
;
; -- is the test MT related, if not then not OK, ICR# 423
S IBLST=$$LST^DGMTCOU1(+$P(X,"^",2),+X,1)
I 'IBLST!($P(IBLST,"^",2)'=+X) Q 0
;
; -- is the test within dates needed?
Q $S(X<$$VFA:0,1:1)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXEU 5100 printed Dec 13, 2024@02:07:22 Page 2
IBARXEU ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE ;2-NOV-92
+1 ;;2.0;INTEGRATED BILLING;**20,222,293,385**;21-MAR-94;Build 35
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;
RXST(DFN,IBDT) ; -- Check rx income exemption status of patient
+1 ;
+2 ; input = : dfn = patient file pointer
+3 ; ibdt = date to check for (optional) default is today
+4 ;
+5 ; returns : -1 if no data ^text^reason code^reason text^date of test
+6 ; 0 if non exempt
+7 ; 1 if exempt
+8 ;
+9 NEW X,Y,Z,IBX,IBON
+10 ;
+11 SET IBON=$$ON^IBARXEU0
IF IBON<1
QUIT IBON
+12 ;
+13 SET IBX=""
+14 IF '$GET(IBDT)
SET IBDT=DT
+15 ; no future dates
IF IBDT>DT
SET IBDT=DT
+16 ;
+17 ; -- date before legislations
+18 ; nobody exempt prior to legislation
IF IBDT<$$STDATE
SET IBX="0^NON-EXEMPT^^Date is Prior to Legislation^"
GOTO RXSTQ
+19 ;
+20 ; -- if no data on patient quit
+21 SET X=$GET(^IBA(354,DFN,0))
+22 ; no data return -1
IF X=""!('$DATA(^IBA(354.1,"AP",DFN)))
SET IBX="-1^UNKNOWN^^Medication Copayment Exemption status never determined"
GOTO RXSTQ
+23 ;
+24 ; -- use current status if ibdt not less than current test and
+25 ; not greater than current test date +365
+26 IF IBDT'<$PIECE(X,U,3)
IF IBDT'>$$PLUS^IBARXEU0($PIECE(X,U,3))
SET IBX=$$IBX^IBARXEU0(DFN,IBDT)
GOTO RXSTQ
+27 ;
+28 ; -- if ibdt not less than current date but greater than
+29 ; current test +365 is into future
+30 IF IBDT'<$PIECE(X,U,3)
IF IBDT>$$PLUS^IBARXEU0($PIECE(X,U,3))
Begin DoDot:1
+31 SET Y=$$LST^IBARXEU0(DFN,IBDT)
+32 ;
+33 ; -- see if patient was SC>50, can't be updated so don't say previous
+34 ; also check to see if last is still ok under VFA rules
+35 IF $LENGTH($$ACODE^IBARXEU0(Y))<3!($$VFAOK(Y))
SET IBX=+$PIECE(X,U,4)_U_$$TEXT^IBARXEU0($PIECE(X,U,4))_U_$$ACODE^IBARXEU0(Y)_U_$$REASON^IBARXEU0(X)_U_$PIECE(X,U,3)
QUIT
+36 ;
+37 SET IBX=+$PIECE(X,U,4)_U_"Previously "_$$TEXT^IBARXEU0($PIECE(X,U,4))_U_$$ACODE^IBARXEU0(Y)_U_"Requires new exemption. Previously "_$$REASON^IBARXEU0(X)_U_$PIECE(X,U,3)
End DoDot:1
+38 ;
+39 ; -- if ibdt less than current date need old exemption data
+40 IF IBDT<$PIECE(X,U,3)
Begin DoDot:1
+41 ;
+42 ; -- find status of prior test
+43 SET Y=$$LST^IBARXEU0(DFN,IBDT)
+44 ;
+45 ; -- no previous data
+46 IF Y=""
Begin DoDot:2
+47 SET IBX="-1^UNKNOWN^^No data for date requested."
+48 QUIT
End DoDot:2
QUIT
+49 ;
+50 ; get status & date
SET Z=$GET(^IBA(354,DFN,0))
SET Z=$PIECE(Z,U,5)_U_$PIECE(Z,U,3)
+51 ;
+52 ; -- if old exemption is current for copay date
+53 IF IBDT'>$$PLUS^IBARXEU0(+Y)
Begin DoDot:2
+54 ; exemption reason node
SET X=$GET(^IBE(354.2,+$PIECE(Y,U,5),0))
+55 SET IBX=+$PIECE(X,U,4)_U_$$TEXT^IBARXEU0($PIECE(X,U,4))_U_$$ACODE^IBARXEU0(Y)_U_$$REASON^IBARXEU0(X)_U_$PIECE(X,U,3)
+56 QUIT
End DoDot:2
QUIT
+57 ;
+58 ; -- if ibdt is greater than old exemption + 365
+59 ; report previous
+60 IF IBDT>$$PLUS^IBARXEU0(+Y)
Begin DoDot:2
+61 ;exemption reason node
SET X=$GET(^IBE(354.2,+$PIECE(Y,U,5),0))
+62 ;
+63 ; -- see if patient was SC>50, can't be updated so don't say previous
+64 ; also check to see if last is still ok under VFA rules
+65 IF $LENGTH($$ACODE^IBARXEU0(Y))<3!($$VFAOK(Y))
SET IBX=+$PIECE(X,U,4)_U_$$TEXT^IBARXEU0($PIECE(X,U,4))_U_$$ACODE^IBARXEU0(Y)_U_$$REASON^IBARXEU0(X)_U_$PIECE(X,U,3)
QUIT
+66 ;
+67 SET IBX=+$PIECE(X,U,4)_U_"Previously "_$$TEXT^IBARXEU0($PIECE(X,U,4))_U_$$ACODE^IBARXEU0(Y)_U_"Requires new exemption. Previously "_$$REASON^IBARXEU0(X)_U_$PIECE(X,U,3)
+68 QUIT
End DoDot:2
QUIT
+69 QUIT
End DoDot:1
GOTO RXSTQ
+70 ;
RXSTQ QUIT IBX
+1 ;
DISP(DFN,IBDT,NO,NULL) ; -- formats text to display
+1 ; -- input = dfn
+2 ; ibdt = date to check for
+3 ; no = number of lines to print (1, 2, or 3)
+4 ; null = if zero print unknown, if non-zero quit
+5 ;
+6 IF '$GET(IBDT)
SET IBDT=DT
+7 IF '$DATA(NULL)
SET NULL=1
+8 ; no future dates
IF IBDT>DT
SET IBDT=DT
+9 IF '$GET(NO)
SET NO=3
+10 SET X=$$RXST(DFN,IBDT)
+11 SET IBON=$$ON^IBARXEU0
IF IBON<1
SET X=IBON
+12 IF X<0&(NULL)
GOTO DISPQ
+13 WRITE !,"Medication Copayment Exemption Status: ",$PIECE(X,U,2)
if NO<2
GOTO DISPQ
+14 WRITE !,$PIECE(X,U,4)
if NO<3
GOTO DISPQ
+15 IF $PIECE(X,U,5)
WRITE !,"Last Rx Copay Exemption date: "
SET Y=$PIECE(X,U,5)
DO DT^DIQ
DISPQ QUIT
+1 ;
STDATE() ; -- legislative start date for income exemption
+1 QUIT 2921030
+2 ;
+3 ;
ACTIVE(IBZ) ; -- SCREEN for active field of billing exemptions file
+1 ; only one entry per effective date can be active
+2 ;
+3 NEW IBX,IBY,T
+4 SET T=0
+5 SET IBZ=$SELECT(IBZ=1:IBZ,$EXTRACT(IBZ)="A":1,1:0)
+6 IF 'IBZ
SET T=1
GOTO ACTIVEQ
+7 SET IBX=$GET(^IBA(354.1,DA,0))
+8 SET IBY=$ORDER(^IBA(354.1,"AIVDT",+$PIECE(IBX,U,3),+$PIECE(IBX,U,2),-$PIECE(IBX,U),0))
+9 IF 'IBY!(IBY=DA)
SET T=1
+10 if $DATA(IBTALK)
WRITE !!,"Another entry is already Active, You must inactivate it first",!!
ACTIVEQ QUIT T
+1 ;
VFA() ; -- returns VFA (no longer asking for mt income info) start date
+1 ; less One year
+2 ; ICR #431
+3 NEW IBDT
+4 SET IBDT=$$GET1^DIQ(43,"1,",1205,"I")
+5 if IBDT
SET IBDT=$$MINUS^IBARXEU0(IBDT)
+6 QUIT IBDT
+7 ;
VFAOK(X) ; - under VFA (veterans financial assestment) rules, MT no
+1 ; longer required if within one year of VFA start date, use last test.
+2 ; Pass in the zeroth node of the 354.1 exemption.
+3 ; Output = OK under VFA rules or not (1 or 0)
+4 ;
+5 NEW IBACODE,IBLST
+6 ;
+7 ; -- is this test income related, if not then not OK
+8 SET IBACODE=$$ACODE^IBARXEU0(X)
+9 IF IBACODE<100
IF IBACODE>200
QUIT 0
+10 ;
+11 ; -- is the test MT related, if not then not OK, ICR# 423
+12 SET IBLST=$$LST^DGMTCOU1(+$PIECE(X,"^",2),+X,1)
+13 IF 'IBLST!($PIECE(IBLST,"^",2)'=+X)
QUIT 0
+14 ;
+15 ; -- is the test within dates needed?
+16 QUIT $SELECT(X<$$VFA:0,1:1)
+17 ;
