Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBARXEU

IBARXEU.m

Go to the documentation of this file.
  1. IBARXEU ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE ;2-NOV-92
  1. ;;2.0;INTEGRATED BILLING;**20,222,293,385**;21-MAR-94;Build 35
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ;
  1. RXST(DFN,IBDT) ; -- Check rx income exemption status of patient
  1. ;
  1. ; input = : dfn = patient file pointer
  1. ; ibdt = date to check for (optional) default is today
  1. ;
  1. ; returns : -1 if no data ^text^reason code^reason text^date of test
  1. ; 0 if non exempt
  1. ; 1 if exempt
  1. ;
  1. N X,Y,Z,IBX,IBON
  1. ;
  1. S IBON=$$ON^IBARXEU0 I IBON<1 Q IBON
  1. ;
  1. S IBX=""
  1. I '$G(IBDT) S IBDT=DT
  1. I IBDT>DT S IBDT=DT ; no future dates
  1. ;
  1. ; -- date before legislations
  1. I IBDT<$$STDATE S IBX="0^NON-EXEMPT^^Date is Prior to Legislation^" G RXSTQ ; nobody exempt prior to legislation
  1. ;
  1. ; -- if no data on patient quit
  1. S X=$G(^IBA(354,DFN,0))
  1. I X=""!('$D(^IBA(354.1,"AP",DFN))) S IBX="-1^UNKNOWN^^Medication Copayment Exemption status never determined" G RXSTQ ; no data return -1
  1. ;
  1. ; -- use current status if ibdt not less than current test and
  1. ; not greater than current test date +365
  1. I IBDT'<$P(X,U,3),IBDT'>$$PLUS^IBARXEU0($P(X,U,3)) S IBX=$$IBX^IBARXEU0(DFN,IBDT) G RXSTQ
  1. ;
  1. ; -- if ibdt not less than current date but greater than
  1. ; current test +365 is into future
  1. I IBDT'<$P(X,U,3),IBDT>$$PLUS^IBARXEU0($P(X,U,3)) D
  1. .S Y=$$LST^IBARXEU0(DFN,IBDT)
  1. .;
  1. .; -- see if patient was SC>50, can't be updated so don't say previous
  1. .; also check to see if last is still ok under VFA rules
  1. .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
  1. .;
  1. .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)
  1. ;
  1. ; -- if ibdt less than current date need old exemption data
  1. I IBDT<$P(X,U,3) D G RXSTQ
  1. .;
  1. .; -- find status of prior test
  1. .S Y=$$LST^IBARXEU0(DFN,IBDT)
  1. .;
  1. .; -- no previous data
  1. .I Y="" D Q
  1. ..S IBX="-1^UNKNOWN^^No data for date requested."
  1. ..Q
  1. .;
  1. .S Z=$G(^IBA(354,DFN,0)),Z=$P(Z,U,5)_U_$P(Z,U,3) ; get status & date
  1. .;
  1. .; -- if old exemption is current for copay date
  1. .I IBDT'>$$PLUS^IBARXEU0(+Y) D Q
  1. ..S X=$G(^IBE(354.2,+$P(Y,U,5),0)) ; exemption reason node
  1. ..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)
  1. ..Q
  1. .;
  1. .; -- if ibdt is greater than old exemption + 365
  1. .; report previous
  1. .I IBDT>$$PLUS^IBARXEU0(+Y) D Q
  1. ..S X=$G(^IBE(354.2,+$P(Y,U,5),0)) ;exemption reason node
  1. ..;
  1. ..; -- see if patient was SC>50, can't be updated so don't say previous
  1. ..; also check to see if last is still ok under VFA rules
  1. ..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
  1. ..;
  1. ..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)
  1. ..Q
  1. .Q
  1. ;
  1. RXSTQ Q IBX
  1. ;
  1. DISP(DFN,IBDT,NO,NULL) ; -- formats text to display
  1. ; -- input = dfn
  1. ; ibdt = date to check for
  1. ; no = number of lines to print (1, 2, or 3)
  1. ; null = if zero print unknown, if non-zero quit
  1. ;
  1. I '$G(IBDT) S IBDT=DT
  1. I '$D(NULL) S NULL=1
  1. I IBDT>DT S IBDT=DT ; no future dates
  1. I '$G(NO) S NO=3
  1. S X=$$RXST(DFN,IBDT)
  1. S IBON=$$ON^IBARXEU0 I IBON<1 S X=IBON
  1. I X<0&(NULL) G DISPQ
  1. W !,"Medication Copayment Exemption Status: ",$P(X,U,2) G:NO<2 DISPQ
  1. W !,$P(X,U,4) G:NO<3 DISPQ
  1. I $P(X,U,5) W !,"Last Rx Copay Exemption date: " S Y=$P(X,U,5) D DT^DIQ
  1. DISPQ Q
  1. ;
  1. STDATE() ; -- legislative start date for income exemption
  1. Q 2921030
  1. ;
  1. ;
  1. ACTIVE(IBZ) ; -- SCREEN for active field of billing exemptions file
  1. ; only one entry per effective date can be active
  1. ;
  1. N IBX,IBY,T
  1. S T=0
  1. S IBZ=$S(IBZ=1:IBZ,$E(IBZ)="A":1,1:0)
  1. I 'IBZ S T=1 G ACTIVEQ
  1. S IBX=$G(^IBA(354.1,DA,0))
  1. S IBY=$O(^IBA(354.1,"AIVDT",+$P(IBX,U,3),+$P(IBX,U,2),-$P(IBX,U),0))
  1. I 'IBY!(IBY=DA) S T=1
  1. W:$D(IBTALK) !!,"Another entry is already Active, You must inactivate it first",!!
  1. ACTIVEQ Q T
  1. ;
  1. VFA() ; -- returns VFA (no longer asking for mt income info) start date
  1. ; less One year
  1. ; ICR #431
  1. N IBDT
  1. S IBDT=$$GET1^DIQ(43,"1,",1205,"I")
  1. S:IBDT IBDT=$$MINUS^IBARXEU0(IBDT)
  1. Q IBDT
  1. ;
  1. VFAOK(X) ; - under VFA (veterans financial assestment) rules, MT no
  1. ; longer required if within one year of VFA start date, use last test.
  1. ; Pass in the zeroth node of the 354.1 exemption.
  1. ; Output = OK under VFA rules or not (1 or 0)
  1. ;
  1. N IBACODE,IBLST
  1. ;
  1. ; -- is this test income related, if not then not OK
  1. S IBACODE=$$ACODE^IBARXEU0(X)
  1. I IBACODE<100,IBACODE>200 Q 0
  1. ;
  1. ; -- is the test MT related, if not then not OK, ICR# 423
  1. S IBLST=$$LST^DGMTCOU1(+$P(X,"^",2),+X,1)
  1. I 'IBLST!($P(IBLST,"^",2)'=+X) Q 0
  1. ;
  1. ; -- is the test within dates needed?
  1. Q $S(X<$$VFA:0,1:1)
  1. ;