1 | IBARXEU1 ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE (CONT.) ; 3/27/07 3:10pm
|
---|
2 | ;;2.0;INTEGRATED BILLING;**26,112,74,275,367**;21-MAR-94;Build 11
|
---|
3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
---|
4 | ;
|
---|
5 | STATUS(DFN,IBDT) ; -- Determine medication copayment exemption status
|
---|
6 | ; -- requests data from MAS
|
---|
7 | ;
|
---|
8 | ; returns : = exemption reason (pointer to 354.2) ^ date
|
---|
9 | ;
|
---|
10 | N X,Y
|
---|
11 | I $G(IBDT)="" S IBDT=DT
|
---|
12 | S X=$$AUTOST(DFN,IBDT)
|
---|
13 | I X'="" G STATUSQ
|
---|
14 | S X=$$INCST(DFN,IBDT)
|
---|
15 | STATUSQ Q X
|
---|
16 | ;
|
---|
17 | AUTOST(DFN,IBDT) ; -- Determine automatically exempt patients.
|
---|
18 | ; input : dfn = patient file pointer
|
---|
19 | ; ibdt = internal form of effective date
|
---|
20 | ;
|
---|
21 | ; returns : = exemption reason (pointer to 354.2) ^ date
|
---|
22 | ; null if no autostatus
|
---|
23 | ;
|
---|
24 | N IBEXREA,IBEXMT,I
|
---|
25 | S (IBEXREA,IBEXMT)=""
|
---|
26 | I $G(IBDT)="" S IBDT=DT
|
---|
27 | ;
|
---|
28 | ; -- ask mas if in receipt of pension/a&a/hb, etc.
|
---|
29 | ; the automatic determinations
|
---|
30 | ; returns:
|
---|
31 | ; sc>50% ^ rec a&a ^ rec hb ^ rec pen ^ n/a ^ non-vet ^ ^ POW ^ Unempl.
|
---|
32 | ; 1 1 1 1 1 1 1
|
---|
33 | ; pieces =1 if true
|
---|
34 | S IBEXMT=$$AUTOINFO^DGMTCOU1(DFN) I IBEXMT="" G AUTOSTQ
|
---|
35 | I IBEXMT[1 F I=1,2,3,4,6,8,9 I $P(IBEXMT,"^",I)=1 S IBEXREA=I*10 Q ;lookup code is piece position time 10
|
---|
36 | ;
|
---|
37 | AUTOSTQ I IBEXREA="" Q IBEXREA
|
---|
38 | Q $O(^IBE(354.2,"ACODE",+IBEXREA,0))_"^"_IBDT
|
---|
39 | ;
|
---|
40 | ;
|
---|
41 | INCST(DFN,IBDT) ; -- return medication copayment exemption reason/date
|
---|
42 | ; -- ask mas for income data
|
---|
43 | ;
|
---|
44 | ; returns : = exemption reason (pointer to 354.2) ^ date
|
---|
45 | ;
|
---|
46 | N IBDATA,X,DGMT,CLN,CONV
|
---|
47 | S IBDATA=$G(^DGMT(408.31,+$$LST^DGMTCOU1(DFN,IBDT,3),0)) ;get any test
|
---|
48 | I $$PLUS^IBARXEU0(+IBDATA)<IBDT S X=$O(^IBE(354.2,"ACODE",210,0))_"^"_IBDT G INCSTQ ; means test too old -no data
|
---|
49 | I $P(IBDATA,U,23)=2 D G:CONV INCSTQ ;skip Edb conv. tests
|
---|
50 | .;Loop through the MT comments, Check for EDB converted test
|
---|
51 | .;No comments to check
|
---|
52 | .S (CLN,CONV)=0,DGMT=$$LST^DGMTCOU1(DFN,IBDT,3)
|
---|
53 | .F S CLN=$O(^DGMT(408.31,+DGMT,"C",CLN)) Q:'CLN!(CONV) D
|
---|
54 | ..;If most recent test is a converted test use current info from IBA(354
|
---|
55 | ..I $G(^DGMT(408.31,+DGMT,"C",CLN,0))["Z06 MT via Edb" S CONV=1,X=$P($G(^IBA(354,DFN,0)),"^",5)_"^"_$P($G(^IBA(354,DFN,0)),"^",3)
|
---|
56 | ;
|
---|
57 | I $$NETW^IBARXEU1 S X=$$MTCOMP^IBARXEU5($$INCDT(IBDATA),IBDATA)
|
---|
58 | I '$$NETW^IBARXEU1 S X=$$INCDT(IBDATA),X=$P(X,"^",3)_"^"_$P(X,"^",2)
|
---|
59 | INCSTQ Q X
|
---|
60 | ;
|
---|
61 | INCDT(IBDATA) ; -- calcualtes copay exemption status based on income
|
---|
62 | ; and net worth
|
---|
63 | ; input := zeroth node from 408.31
|
---|
64 | ; output := 1 = exempt ^date of test^ exemption reason
|
---|
65 | ; 2 = non-exempt^...
|
---|
66 | ; 3 = pending adjudication (if active)^...
|
---|
67 | ;
|
---|
68 | N X,IBDT,IBINCOM,IBEXREA,IBDEPEN,IBNETW,IBTABLE,IBLEVEL,IBTHRES
|
---|
69 | I '$D(DFN) N DFN S DFN=$P(IBDATA,"^",2)
|
---|
70 | S IBEXREA=""
|
---|
71 | ;
|
---|
72 | ; -- if test incomplete, no longer required, no longer applicable, or
|
---|
73 | ; required set to no income data
|
---|
74 | ; autoexempt test should be done first before getting to here
|
---|
75 | S X=$P(IBDATA,"^",3) I X=1!(X=3)!(X=10)!(X=9)!($P(IBDATA,"^",14)) S IBEXREA=$S($P(IBDATA,"^",14):110,1:210) G NO
|
---|
76 | ;
|
---|
77 | S IBDT=+IBDATA
|
---|
78 | S IBINCOM=$P(IBDATA,"^",4)-$P(IBDATA,"^",15) I IBINCOM<0 S IBINCOM=0
|
---|
79 | S IBDEPEN=$P(IBDATA,"^",18),IBNETW=$P(IBDATA,"^",5)
|
---|
80 | ;
|
---|
81 | ; -- get A&A income level
|
---|
82 | ;S IBLEVEL=$$THRES(IBDT,2,IBDEPEN)
|
---|
83 | S IBLEVEL=$$THRES(IBDT,$S($E(IBDT,1,5)'<29612:1,1:2),IBDEPEN)
|
---|
84 | I $P(IBLEVEL,"^",3) S IBPRIOR=$P(IBLEVEL,"^",3)
|
---|
85 | ;
|
---|
86 | S IBEXREA=120 ; low income
|
---|
87 | I IBINCOM>+IBLEVEL S IBEXREA=110 G NO ;high income not exempt
|
---|
88 | ;
|
---|
89 | I '$$NETW G NO
|
---|
90 | ;
|
---|
91 | ; -- get networth threshold amount
|
---|
92 | S IBTHRES=+$$THRES(IBDT,4,0)
|
---|
93 | ; -- low income check for net worth
|
---|
94 | S IBEXREA=$S((IBINCOM+IBNETW)>IBTHRES:130,1:120)
|
---|
95 | ;
|
---|
96 | NO ; -- not enough information
|
---|
97 | I IBEXREA="" S IBEXREA=210
|
---|
98 | ;
|
---|
99 | I $$NETW S Y=$S(IBEXREA=110:2,IBEXREA=120:1,IBEXREA=130:3,1:2)
|
---|
100 | I '$$NETW S Y=$S(IBEXREA=120:1,1:2)
|
---|
101 | ;
|
---|
102 | INCDTQ Q Y_"^"_+IBDATA_"^"_$O(^IBE(354.2,"ACODE",+IBEXREA,0))
|
---|
103 | ;
|
---|
104 | THRES(DATE,TYPE,DEPEND) ; -- return threshold amount
|
---|
105 | ;
|
---|
106 | ; -- if date is less than 12/1/92 will use 12/1 92 rates
|
---|
107 | ; date =: fileman format of effective date
|
---|
108 | ; type =: 2= pension plus A&A 1992 thru 1995
|
---|
109 | ; type =: 1= basic pension 1996 to present
|
---|
110 | ; depend =: number of dependents
|
---|
111 | ;
|
---|
112 | ; -- returns rate^effective date^prior year
|
---|
113 | ;
|
---|
114 | I DATE<2921201 S DATE=2921201 ; use threshold rates from 12/1/92
|
---|
115 | N IBTABLE,IBLEVEL,IBPRIOR
|
---|
116 | S IBLEVEL=""
|
---|
117 | ; -- get entry to determine income amounts
|
---|
118 | S IBTABLE=$G(^IBE(354.3,+$O(^(+$O(^IBE(354.3,"AIVDT",TYPE,-(DATE+.000001))),0)),0))
|
---|
119 | G:IBTABLE="" THRESQ
|
---|
120 | I TYPE=4 S DEPEND=0
|
---|
121 | ;
|
---|
122 | ; --see if rate is for prior year
|
---|
123 | S IBPRIOR="" I $$PLUS^IBARXEU0(+IBTABLE)<DATE S IBPRIOR=+IBTABLE
|
---|
124 | ;
|
---|
125 | ; -- rates begin in piece 3 for veteran alone, piece 4 for 1 dependent..
|
---|
126 | S IBLEVEL=$S(DEPEND<9:$P(IBTABLE,"^",DEPEND+3),1:"")
|
---|
127 | I IBLEVEL="" S IBLEVEL=$P(IBTABLE,"^",4)+((DEPEND-1)*$P(IBTABLE,"^",12))
|
---|
128 | THRESQ Q IBLEVEL_"^"_+IBTABLE_"^"_IBPRIOR
|
---|
129 | ;
|
---|
130 | NETW() ; -- use networth in determining copay exemptions - specs keep changing
|
---|
131 | ; returns 1 if should use networth in exemption determination
|
---|
132 | ; returns 0 if should not use networth in exemption
|
---|
133 | Q 0
|
---|