source: FOIAVistA/trunk/r/ENROLLMENT_APPLICATION_SYSTEM-EAS/EASECMT.m@ 1800

Last change on this file since 1800 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.1 KB
Line 
1EASECMT ;ALB/LBD - Means Test for LTC Co-Pay exemption ; 27 DEC 2001
2 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**7,16,18**;Mar 15, 2001
3 ;
4EN ; This is the entry point for the routine that will find the
5 ; financial test for a veteran that can be used to check if
6 ; veteran's income is below the threshold and exempt from LTC
7 ; co-payments. If a financial test is not on file for the veteran
8 ; it can be added through this process.
9 ; Input -- DFN = Patient IEN
10 ; Output -- DGEXMPT = 1 (exempt from LTC co-payments)
11 ; = 0 or "" (not exempt from LTC co-payments)
12 ; DGOUT = 1 (user wants to exit from the process)
13 N DGMTI,DGMTDT,DGMTYPT,DGMTACT,DGL,DGCS,DGMSGF,DGREQF,DGDOM,DGDOM1,Y
14 ; Does veteran have current LTC co-pay exemption test (type 4)?
15 S Y=$$GETLTC4(DFN) I Y S DGEXMPT=$S($P(Y,U,3)="EXEMPT":1,1:0) Q
16 ; Does veteran have current means test?
17 S DGL=$$LST^DGMTU(DFN),DGMTI=+DGL,DGMTDT=$P(DGL,U,2),DGCS=$P(DGL,U,4)
18 ; If last means test has status of Cat C or Pend. Adj. and vet agreed
19 ; to pay MT copay, new means test is not required
20 I ((DGCS="C")!(DGCS="P")),$P($G(^DGMT(408.31,DGMTI,0)),U,11)=1,DGMTDT>2991005 S DGEXMPT=0 D LTC4(DGMTI,DGEXMPT) Q
21 ; If means test is required or more than a year old, do new means test
22 I (DGCS="R")!($$OLD^DGMTU4(DGMTDT)) D Q:$G(DGOUT)!(DGMTYPT=4)
23 .S (DGADDF,DGMSGF)=1 D ^DGMTR S DGMTYPT=$S(DGREQF:1,1:4)
24 .I '$$ASK(DGMTYPT) S DGOUT=1 Q
25 .S DGMTACT="ADD" I DGMTYPT=1,$E(DGMTDT,1,3)=$E(DT,1,3) S DGMTACT="EDT"
26 .I '$$MT(DFN,DGMTYPT,DGMTACT,.DGMTI) S DGOUT=1 Q
27 .I DGMTYPT=4 D
28 ..D DOM^DGMTR I '$G(DGDOM1) D COPYRX^DGMTR1(DFN,DGMTI)
29 ..S Y=$$GETCODE^DGMTH($P($G(^DGMT(408.31,DGMTI,0)),U,3)),DGEXMPT=$S(Y=0:1,1:0)
30 ; If no means test or means test is no longer required, check if
31 ; there is an RX co-pay test, otherwise do new LTC co-pay exemption test
32 I DGCS=""!(DGCS="N") D Q:$G(DGOUT)!($G(DGMTYPT)=4)
33 .S DGL=$$LST^DGMTU(DFN,DT,2),DGMTI=+DGL,DGMTDT=$P(DGL,U,2),DGCS=$P(DGL,U,4)
34 .I DGMTI,'$$OLD^DGMTU4(DGMTDT),("^I^L^")'[("^"_DGCS_"^") Q
35 .S DGMTYPT=4
36 .I '$$ASK(DGMTYPT) S DGOUT=1 Q
37 .I '$$MT(DFN,DGMTYPT,"ADD",.DGMTI) S DGOUT=1 Q
38 .D DOM^DGMTR I '$G(DGDOM1) D COPYRX^DGMTR1(DFN,DGMTI)
39 .S Y=$$GETCODE^DGMTH($P($G(^DGMT(408.31,DGMTI,0)),U,3))
40 .S DGEXMPT=$S(Y=0:1,1:0)
41 ; Check if veteran's income is below the pension threshold
42 S DGEXMPT=$$THRES(DFN,DGMTDT)
43 I DGEXMPT<0 W !!,"The income threshold check could not be completed due to an error." S DGOUT=1 Q
44 ; Create LTC co-pay exemption test (type 4) by copying MT
45 D LTC4(DGMTI,DGEXMPT)
46 Q
47 ;
48THRES(DFN,DGMTDT) ; Is veteran's income below the pension threshold
49 ; Input - DFN = Patient IEN
50 ; DGMTDT = Test date
51 ; Output - = 1 (Below the threshold)
52 ; = 0 (Above the threshold)
53 ; = -1(Error)
54 N DGDC,DGDEP,DGDET,DGERR,DGIN0,DGIN1,DGIN2,DGINI,DGINT,DGINTF,DGIRI
55 N DGNC,DGND,DGNWT,DGNWTF,DGPRI,DGSP,DGVINI,DGVIR0,DGVIRI,DGTHRES
56 N DGLY,DGMTPAR
57 ; Get current single veteran pension threshold amount
58 S DGTHRES=$$THRES^IBARXEU1(DGMTDT,1,0) I '+DGTHRES Q -1
59 ; Calculate veteran's income level and check against the threshold
60 S DGPRI=$O(^DGPR(408.12,"C",DFN_";DPT(",0)) I 'DGPRI Q -1
61 D GETIENS^DGMTU2(DFN,DGPRI,DGMTDT) I '$G(DGIRI),'$G(DGINI) Q -1
62 S DGVIRI=DGIRI,DGVINI=DGINI
63 S DGLY=$$LYR^DGMTSCU1(DGMTDT) D PAR^DGMTSCU
64 D DEP^DGMTSCU2,INC^DGMTSCU3 I '$D(DGINT) Q -1
65 ; If vet declined to provide financial info, return 0 (above threshold)
66 I $P($G(^DGMT(408.31,+$G(DGMTI),0)),U,14) Q 0
67 I (DGINT-DGDET)'>+DGTHRES Q 1
68 Q 0
69 ;
70MT(DFN,TYPE,ACT,DGMTI) ; Complete a means test or LTC co-pay exemption test
71 ; Input - DFN = Patient IEN
72 ; DGMTYPT = Type of test (1=MT; 4=LTC4)
73 ; ACT = Type of action (ADD or EDT)
74 ; DGMTI = If EDT action, IEN of test to be edited
75 ; Output - EASECMT = 1 (MT completed)
76 ; = 0 (MT not completed)
77 ; DGMTI = IEN of new test
78 N DGMTYPT,DGMTACT,DGMTROU,DGMT0,DGSTA,EASECMT
79 S EASECMT=0
80 I $$LOCK^DGMTUTL(DFN) E Q EASECMT
81 S DGMTYPT=TYPE,DGMTACT=ACT
82 S DGMTDT=$S(DGMTACT="EDT":+$G(^DGMT(408.31,DGMTI,0)),1:DT) G MT1:'DGMTDT
83 I DGMTACT="ADD" D ADD^DGMTA G MT1:'$G(DGMTI)
84 S DGMTROU="MT1^EASECMT"
85 G EN^DGMTSC
86MT1 I $G(DGMTI) D
87 .S DGMT0=$G(^DGMT(408.31,DGMTI,0)),DGSTA=$$GETCODE^DGMTH($P(DGMT0,U,3))
88 .I DGSTA'="","ACP01"[DGSTA,$P(DGMT0,U,7)]"" S EASECMT=1
89 .I 'EASECMT,TYPE=4 D DEL ;Delete incomplete LTC copay exemption test
90 D UNLOCK^DGMTUTL(DFN)
91 Q +$G(EASECMT)
92 ;
93LTC4(DGMT,DGEXMPT) ; Create or update LTC copay exemption test (type 4) by copying
94 ; means test
95 ; Input - DGMT = Annual Means Test IEN of test to be copied
96 ; - DGEXMPT = LTC copayments exemption status (optional)
97 Q:'DGMT
98 N DGMT0,DGMT2,DA,DIC,DIK,DLAYGO,X,DFN,DGMTI
99 N DGMTA,DGMTP,DGMTACT,DGMTINF,DGMTYPT
100 ; Quit if this is a LTC copay exemption test (type 4)
101 S DGMT0=$G(^DGMT(408.31,DGMT,0)) I $P(DGMT0,U,19)=4 Q
102 S DGMT2=$G(^DGMT(408.31,DGMT,2))
103 ; Add a new LTC 4 test or edit an existing LTC 4 test?
104 S DGMTI=$O(^DGMT(408.31,"AT",DGMT,0))
105 S DGMTACT=$S(DGMTI:"EDT",1:"ADD")
106 S DGMTP="" I DGMTACT="EDT" S DGMTP=$G(^DGMT(408.31,DGMTI,0))
107 ; Add new entry to Annual Means Test file (#408.31) for LTC 4 test
108 I DGMTACT="ADD" D Q:DGMTI'>0
109 .S X=+DGMT0,(DIC,DIK)="^DGMT(408.31,",DIC(0)="L",DLAYGO=408.31
110 .D FILE^DICN S DGMTI=+Y
111 S DFN=$P(DGMT0,U,2)
112 F I=.01,.02,.04,.05,.06,.11,.14,.15,.18,.23 S DATA(I)=$P(DGMT0,U,(I/.01))
113 I '$D(DGEXMPT) S DGEXMPT=$$THRES(DFN,$P(DGMT0,U,1))
114 S DATA(.03)=$S(DGEXMPT:15,1:14),DATA(.07)=DT
115 S DATA(.019)=4,DATA(2.02)=$P(DGMT2,U,2),DATA(2.08)=DGMT
116 S DATA(2.05)=$P(DGMT2,U,5)
117 I $$UPD^DGENDBS(408.31,DGMTI,.DATA,.ERROR)
118 K DATA,ERROR
119 ; Update the LTC copay test (type 3), if status changed
120 I DGMTACT="EDT" D UPLTC3(DGMTI)
121 ; Update Audit file and IVM Patient file
122 S DGMTYPT=4,DGMTINF=1 D AFTER^DGMTEVT
123 D EN^DGMTAUD
124 D EN^IVMPMTE
125 Q
126 ;
127ASK(TYPE) ; Does user want to perform MT/LTC4 test now?
128 ; Input - TYPE = Type of test, 1: MT; 4: LTC Copay Exemption
129 ; Output - Y = 1 (YES)
130 ; = 0 (NO)
131 N DIR,TST
132 S TST=$S(TYPE=1:"Means Test",1:"LTC Copay Exemption Test")
133 W !!,"The previous year's financial information is not on file for this veteran.",!,"A ",TST," is required."
134 S DIR("A")="Do you wish to complete the "_TST_" at this time"
135 S DIR("B")="NO",DIR(0)="Y"
136 W ! D ^DIR
137 Q +(Y)
138 ;
139GETLTC4(DFN,DGMTDT) ; Return last LTC co-pay exemption test (type 4),
140 ; if less than a year old
141 ; Input - DFN = Patient IEN
142 ; DGMTDT (optional) = Date of test
143 ; Output - Y = Annual Means Test IEN^Date of Test^Status Name^
144 ; Status Code^Source of Test
145 ; = "" (no current LTC co-pay exemption test)
146 N Y
147 S Y="" Q:'$G(DFN) Y I '$G(DGMTDT) S DGMTDT=DT
148 S Y=$$LST^DGMTU(DFN,DGMTDT,4) I '(+Y) Q Y
149 I $$OLD^DGMTU4($P(Y,U,2)) S Y=""
150 Q Y
151 ;
152DEL ;Delete incomplete LTC Copay Exemption test (type 4)
153 ; Input -- DGMTI LTC Copay Exemption test IEN
154 N DA,DIK,DIE,DR,V
155 Q:'$G(DGMTI) Q:$P($G(^DGMT(408.31,DGMTI,0)),U,19)'=4
156 ; Delete pointer in Income Relation file (#408.22)
157 I $D(^DGMT(408.22,"AMT",DGMTI)) D
158 .S DIE="^DGMT(408.22,",DR="31///@"
159 .S V=$O(^DGMT(408.22,"AMT",DGMTI,0)) Q:'V
160 .S IR=0 F S IR=$O(^DGMT(408.22,"AMT",DGMTI,V,IR)) Q:'IR S DA=$O(^(IR,0)) I DA D ^DIE
161 ; Delete LTC Copay Exemption test from Annual Means Test file (#408.31)
162 S DA=DGMTI,DIK="^DGMT(408.31,"
163 D ^DIK
164 Q
165 ;
166UPLTC3(DGMT4) ;If the status of a LTC Copay Exemption test (type 4) changes,
167 ;update the status of the LTC Copay test (type 3), if necessary
168 ; Input -- DGMT4 LTC Copay Exemption test IEN
169 N DGMT3,DGMTS4,DGMTS3,DGS,DATA,ERROR
170 Q:'DGMT4
171 S DGMT3=$O(^DGMT(408.31,"AT",DGMT4,0)) Q:$G(^DGMT(408.31,+DGMT3,0))=""
172 ; Get test status
173 S DGMTS4=$$GETNAME^DGMTH($P(^DGMT(408.31,DGMT4,0),U,3))
174 S DGMTS3=$$GETNAME^DGMTH($P(^DGMT(408.31,DGMT3,0),U,3))
175 ; If test status is the same quit
176 I DGMTS4=DGMTS3 Q
177 ; If LTC copay test (type 3) is Exempt and the Reason for Exemption is
178 ; anything other than 2 (Income Last Year Below Threshold), quit
179 I DGMTS3="EXEMPT",$P($G(^DGMT(408.31,DGMT3,2)),U,7)'=2 Q
180 ; Get IEN of Means Test Status and update LTC copay test
181 S DGS="" F S DGS=$O(^DG(408.32,"B",DGMTS4,DGS)) Q:'DGS I $P(^DG(408.32,DGS,0),U,19)=3 Q
182 S DATA(.03)=DGS,DATA(2.07)=$S(DGMTS4="EXEMPT":2,1:"@")
183 I $$UPD^DGENDBS(408.31,DGMT3,.DATA,.ERROR)
184 Q
Note: See TracBrowser for help on using the repository browser.