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

IBARXEU1.m

Go to the documentation of this file. 
  1. IBARXEU1	;AAS/ALB - RX EXEMPTION UTILITY ROUTINE (CONT.) ; 2-NOV-92
  1. 	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
  1. 	;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. 	;
  1. STATUS(DFN,IBDT)	; -- Determine medication copayment exemption status
  1. 	; -- requests data from MAS
  1. 	;
  1. 	;    returns :        = exemption reason (pointer to 354.2) ^ date
  1. 	;
  1. 	N X,Y
  1. 	I $G(IBDT)="" S IBDT=DT
  1. 	S X=$$AUTOST(DFN,IBDT)
  1. 	I X'="" G STATUSQ
  1. 	S X=$$INCST(DFN,IBDT)
  1. STATUSQ	Q X
  1. 	;
  1. AUTOST(DFN,IBDT)	; -- Determine automatically exempt patients.
  1. 	;    input :     dfn  =  patient file pointer
  1. 	;               ibdt  =  internal form of effective date
  1. 	;
  1. 	;    returns :        =  exemption reason (pointer to 354.2) ^ date
  1. 	;                        null if no autostatus
  1. 	;
  1. 	N IBEXREA,IBEXMT,I
  1. 	S (IBEXREA,IBEXMT)=""
  1. 	I $G(IBDT)="" S IBDT=DT
  1. 	;
  1. 	; -- ask mas if in receipt of pension/a&a/hb, etc.
  1. 	;    the automatic determinations
  1. 	;    returns:
  1. 	;        := sc>50% ^ rec a&a ^ rec hb ^ rec pen ^ n/a ^ non-vet
  1. 	;            1         1        1         1                1
  1. 	;    pieces =1 if true
  1. 	;
  1. 	S IBEXMT=$$AUTOINFO^DGMTCOU1(DFN) I IBEXMT="" G AUTOSTQ
  1. 	I IBEXMT[1 F I=1,2,3,4,6 I $P(IBEXMT,"^",I)=1 S IBEXREA=I*10 Q  ;lookup code is piece position time 10
  1. 	;
  1. AUTOSTQ	I IBEXREA="" Q IBEXREA
  1. 	Q $O(^IBE(354.2,"ACODE",+IBEXREA,0))_"^"_IBDT
  1. 	;
  1. 	;
  1. INCST(DFN,IBDT)	; -- return medication copayment exemption reason/date
  1. 	; -- ask mas for income data
  1. 	;
  1. 	;    returns :  = exemption reason (pointer to 354.2) ^ date
  1. 	;
  1. 	N IBDATA,X
  1. 	S IBDATA=$G(^DGMT(408.31,+$$LST^DGMTCOU1(DFN,IBDT,3),0)) ;get any test
  1. 	I $$PLUS^IBARXEU0(+IBDATA)<IBDT S X=$O(^IBE(354.2,"ACODE",210,0))_"^"_IBDT G INCSTQ ; means test too old -no data
  1. 	I $$NETW^IBARXEU1 S X=$$MTCOMP^IBARXEU5($$INCDT(IBDATA),IBDATA)
  1. 	I '$$NETW^IBARXEU1 S X=$$INCDT(IBDATA),X=$P(X,"^",3)_"^"_$P(X,"^",2)
  1. INCSTQ	Q X
  1. 	;
  1. INCDT(IBDATA)	; -- calcualtes copay exemption status based on income
  1. 	; and net worth
  1. 	;    input  := zeroth node from 408.31
  1. 	;    output := 1 = exempt    ^date of test^ exemption reason 
  1. 	;              2 = non-exempt^...
  1. 	;              3 = pending adjudication (if active)^...
  1. 	;
  1. 	N X,IBDT,IBINCOM,IBEXREA,IBDEPEN,IBNETW,IBTABLE,IBLEVEL,IBTHRES
  1. 	I '$D(DFN) N DFN S DFN=$P(IBDATA,"^",2)
  1. 	S IBEXREA=""
  1. 	;
  1. 	; -- if test incomplete, no longer required, no longer applicable, or
  1. 	;    required set to no income data 
  1. 	;    autoexempt test should be done first before getting to here
  1. 	S X=$P(IBDATA,"^",3) I X=1!(X=3)!(X=10)!(X=9)!($P(IBDATA,"^",14)) S IBEXREA=210 G NO
  1. 	;
  1. 	S IBDT=+IBDATA
  1. 	S IBINCOM=$P(IBDATA,"^",4)-$P(IBDATA,"^",15) I IBINCOM<0 S IBINCOM=0
  1. 	S IBDEPEN=$P(IBDATA,"^",18),IBNETW=$P(IBDATA,"^",5)
  1. 	;
  1. 	; -- get A&A income level
  1. 	S IBLEVEL=$$THRES(IBDT,2,IBDEPEN)
  1. 	I $P(IBLEVEL,"^",3) S IBPRIOR=$P(IBLEVEL,"^",3)
  1. 	;
  1. 	S IBEXREA=120 ; low income
  1. 	I IBINCOM>+IBLEVEL S IBEXREA=110 G NO ;high income not exempt
  1. 	;
  1. 	I '$$NETW G NO
  1. 	;
  1. 	; -- get networth threshold amount
  1. 	S IBTHRES=+$$THRES(IBDT,4,0)
  1. 	; -- low income check for net worth
  1. 	S IBEXREA=$S((IBINCOM+IBNETW)>IBTHRES:130,1:120)
  1. 	;
  1. NO	; -- not enough information
  1. 	I IBEXREA="" S IBEXREA=210
  1. 	;
  1. 	I $$NETW S Y=$S(IBEXREA=110:2,IBEXREA=120:1,IBEXREA=130:3,1:2)
  1. 	I '$$NETW S Y=$S(IBEXREA=120:1,1:2)
  1. 	;
  1. INCDTQ	Q Y_"^"_+IBDATA_"^"_$O(^IBE(354.2,"ACODE",+IBEXREA,0))
  1. 	;
  1. THRES(DATE,TYPE,DEPEND)	; -- return threshold amount 
  1. 	;
  1. 	; -- if date is less than 12/1/92 will use 12/1 92 rates
  1. 	;     date =: fileman format of effective date
  1. 	;     type =: 2= pension plus A&A
  1. 	;     depend =: number of dependents
  1. 	;
  1. 	; -- returns rate^effective date^prior year
  1. 	;
  1. 	I DATE<2921201 S DATE=2921201 ; use threshold rates from 12/1/92
  1. 	N IBTABLE,IBLEVEL,IBPRIOR
  1. 	S IBLEVEL=""
  1. 	; -- get entry to determine income amounts
  1. 	S IBTABLE=$G(^IBE(354.3,+$O(^(+$O(^IBE(354.3,"AIVDT",TYPE,-(DATE+.000001))),0)),0))
  1. 	G:IBTABLE="" THRESQ
  1. 	I TYPE=4 S DEPEND=0
  1. 	;
  1. 	; --see if rate is for prior year
  1. 	S IBPRIOR="" I $$PLUS^IBARXEU0(+IBTABLE)<DT S IBPRIOR=+IBTABLE
  1. 	;
  1. 	; -- rates begin in piece 3 for veteran alone, piece 4 for 1 dependent..
  1. 	S IBLEVEL=$S(DEPEND<9:$P(IBTABLE,"^",DEPEND+3),1:"")
  1. 	I IBLEVEL="" S IBLEVEL=$P(IBTABLE,"^",4)+((DEPEND-1)*$P(IBTABLE,"^",12))
  1. THRESQ	Q IBLEVEL_"^"_+IBTABLE_"^"_IBPRIOR
  1. 	;
  1. NETW()	; -- use networth in determining copay exemptions - specs keep changing
  1. 	;    returns 1 if should use networth in exemption determination
  1. 	;    returns 0 if should not use networth in exemption
  1. 	Q 0