source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBARXEU1.m@ 1321

Last change on this file since 1321 was 613, checked in by George Lilly, 16 years ago

initial load of WorldVistAEHR
File size: 5.0 KB
RevLine 
[613]1IBARXEU1 ;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 ;
5STATUS(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)
15STATUSQ Q X
16 ;
17AUTOST(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 ;
37AUTOSTQ I IBEXREA="" Q IBEXREA
38 Q $O(^IBE(354.2,"ACODE",+IBEXREA,0))_"^"_IBDT
39 ;
40 ;
41INCST(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)
59INCSTQ Q X
60 ;
61INCDT(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 ;
96NO ; -- 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 ;
102INCDTQ Q Y_"^"_+IBDATA_"^"_$O(^IBE(354.2,"ACODE",+IBEXREA,0))
103 ;
104THRES(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))
128THRESQ Q IBLEVEL_"^"_+IBTABLE_"^"_IBPRIOR
129 ;
130NETW() ; -- 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
Note: See TracBrowser for help on using the repository browser.