- 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 Jan 18, 2025@03:08:35 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 ;