source: FOIAVistA/trunk/r/ENROLLMENT_APPLICATION_SYSTEM-EAS/EASECPC1.m@ 811

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

initial load of FOIAVistA 6/30/08 version
File size: 8.3 KB
Line 
1EASECPC1 ;ALB/LBD,CKN - LTC CoPayment Report continuation ; 6-FEB-2002
2 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**7,24,40**;Mar 15, 2001
3 ;
4 ; This routine is a continuation of EASECPC.
5 ;
6 ; Input: DFN - Patient file IEN
7 ; DGMTI - LTC Copay Test IEN (file #408.31)
8 ; DGMTDT - LTC Copay Test Date
9 ; MAXRT - Maximum daily copay rates for LTC (OP^IP)
10 ; EASRPT - Report type: 1=Institutional (IP)
11 ; 2=Non-Institutional (OP)
12 ; EASRDT - Report start date
13 ; EASADM - LTC admission date (only if EASRPT=1)
14 ;
15START ; Generate Report
16 N ARRY,IPRPT,DGSP,SRIC,LSEP,DECINF,AGRPAY,ERR
17 I $G(ZTSK) S ZTREQ="@"
18 D INIT(EASRDT,.ARRY)
19 D BLDTBL(.ARRY) Q:$G(ERR)
20 D PRINT
21 Q
22PRINT ; Print the Report
23 N CRT,PAGE,RPTDT,LINE,HDR,CALC1,CALC2,SIDX,EIDX,MNTH,NAME,SSN,DOB,LOS
24 D PRTVAR
25 U IO
26 D HEADER
27 W !,$S(DGSP:"MARRIED",LSEP:"LEGALLY SEPARATED",1:"SINGLE")
28 W:SRIC ?15,"SPOUSE RESIDING IN THE COMMUNITY"
29 I DECINF,AGRPAY W !,"*** DECLINED TO PROVIDE INCOME INFORMATION -- AGREED TO PAY COPAYMENTS ***"
30 I AGRPAY=0 W !,"*** VETERAN IS INELIGIBLE FOR LTC SERVICES -- REFUSED TO SIGN 10-10EC ***"
31 W !,"LTC COPAY TEST DATE: ",$$FMTE^XLFDT(DGMTDT)
32 W:$G(EASADM) ?47,"LTC ADMISSION DATE: ",$$FMTE^XLFDT(EASADM)
33 W !!!,"LTC COPAYMENT CALCULATION"_$S(IPRPT:"S:",1:":")
34 W ! W:IPRPT "FOR DAYS 1-180 " W CALC1
35 I IPRPT W !,"FOR DAYS 181+ " W CALC2
36 ;
37 S SIDX=1,EIDX=6
38 W !!," "
39 F MNTH=1:1:6 W $J($P(ARRY(MNTH),"^"),11)
40 I IPRPT D PRINTROW("TOT ASSETS ",SIDX,EIDX,9)
41 D PRINTROW("TOT INCOME ",SIDX,EIDX,3)
42 I 'IPRPT!($G(LOS)<181)!(DGSP&(SRIC)) D PRINTROW("TOT EXPENSES ",SIDX,EIDX,4)
43 D PRINTROW("TOT ALLOWANCE ",SIDX,EIDX,5)
44 W ! D PRINTROW("CALC COPAY ",SIDX,EIDX,6)
45 D PRINTROW("MAX COPAY ",SIDX,EIDX,7)
46 W !,LINE
47 D PRINTROW("VET COPAY ",SIDX,EIDX,8)
48 W !,LINE
49 ;
50 S SIDX=7,EIDX=12
51 W !!," "
52 F MNTH=7:1:12 W $J($P(ARRY(MNTH),"^"),11)
53 I IPRPT D PRINTROW("TOT ASSETS ",SIDX,EIDX,9)
54 D PRINTROW("TOT INCOME ",SIDX,EIDX,3)
55 I 'IPRPT!(DGSP&(SRIC)) D PRINTROW("TOT EXPENSES ",SIDX,EIDX,4)
56 D PRINTROW("TOT ALLOWANCE ",SIDX,EIDX,5)
57 W ! D PRINTROW("CALC COPAY ",SIDX,EIDX,6)
58 D PRINTROW("MAX COPAY ",SIDX,EIDX,7)
59 W !,LINE
60 D PRINTROW("VET COPAY ",SIDX,EIDX,8)
61 W !,LINE
62 ;
63 I CRT Q:$$PAUSE(0)
64 D:CRT HEADER
65 D NOTETXT
66 I CRT Q:$$PAUSE(0)
67 I IPRPT D HEADER,SPNDDWN I CRT Q:$$PAUSE(0)
68 Q
69PRINTROW(TEXT,SIDX,EIDX,NODE) ; Print the Rows
70 N MNTH
71 W !,TEXT
72 F MNTH=SIDX:1:EIDX W $J($S($P(ARRY(MNTH),"^",NODE)[".":$P($P(ARRY(MNTH),"^",NODE),"."),1:$P(ARRY(MNTH),"^",NODE)),11)
73 Q
74PRTVAR ; Set up variables needed to print report
75 N PAT0
76 S CRT=$S($E(IOST,1,2)="C-":1,1:0)
77 S PAGE=0,RPTDT=$$FMTE^XLFDT(DT)
78 S LINE="",$P(LINE,"-",81)=""
79 S HDR=$$CJ^XLFSTR("LONG TERM CARE ESTIMATED COPAYMENTS FOR "_$S('IPRPT:"NON-",1:"")_"INSTITUTIONAL SERVICES",80)
80 S PAT0=$G(^DPT(DFN,0)),NAME=$P(PAT0,"^"),DOB=$P(PAT0,"^",3)
81 S SSN=$P(PAT0,"^",9),SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)
82 S CALC1="TOTAL INCOME - TOTAL EXPENSES - TOTAL ALLOWANCE"
83 I DGSP,SRIC S CALC2="(TOTAL ASSETS + TOTAL INCOME) - TOTAL EXPENSES - TOTAL ALLOWANCE"
84 E S CALC2="(TOTAL ASSETS + TOTAL INCOME) - TOTAL ALLOWANCE"
85 S:$G(EASADM) LOS=$$FMDIFF^XLFDT(EASRDT,EASADM)
86 Q
87HEADER ; Print the header
88 S PAGE=PAGE+1
89 W @IOF
90 W RPTDT,?71,"Page: ",$J(PAGE,3)
91 W !!,HDR
92 W !!,NAME,?35,SSN,?62,"DOB: ",$$FMTE^XLFDT(DOB)
93 Q
94PAUSE(RESP) ; Prompt user for next page or quit
95 N DIR,DIRUT,DUOUT,DTOUT,U,X,Y
96 S DIR(0)="E"
97 D ^DIR
98 I 'Y S RESP=1
99 Q RESP
100 ;
101INIT(DATE,ARRY) ; Initialize the Month/Year Table
102 N IDX,MNYR
103 S MNYR=$E(DATE,1,5)_"00"
104 F IDX=1:1:12 D
105 .S ARRY(IDX)=$$UP^XLFSTR($$FMTE^XLFDT(MNYR))
106 .S ARRY(IDX)=$P(ARRY(IDX)," ")_"'"_$E($P(ARRY(IDX)," ",2),3,4)
107 .S $P(ARRY(IDX),"^",2)=MNYR
108 .S MNYR=MNYR+100
109 .S:$E(MNYR,4,5)=13 MNYR=$E(MNYR,1,3)+1_"0100"
110 Q
111BLDTBL(ARRY) ; Get the veteran's financial data, do the copay calculations,
112 ; build the data table
113 ;
114 N DGDC,DGDEP,DGERR,DGFL,DGIN0,DGIN1,DGIN2,DGINI,DGIRI,DGDET,DGINT,DGNWT
115 N DGPRI,DGNC,DGND,DGNWTF,DGVINI,DGVIR0,DGVIRI,DGVPRI,DGINTF,CPYFLG,IDX
116 N OVR180,TAST,TINC,TEXP,ALLOW,CALCCPY,DAYS,MAXCPY,VETMAX,IPDR,OPDR,LOS
117 ;
118 S ERR=0
119 S DGPRI=$O(^DGPR(408.12,"C",DFN_";DPT(",0)) I 'DGPRI S ERR=1 Q
120 D GETIENS^EASECU2(DFN,DGPRI,DGMTDT) I '$G(DGIRI),'$G(DGINI) S ERR=1 Q
121 S DGVIRI=DGIRI,DGVINI=DGINI
122 D DEP^EASECSU3,INC^EASECSU3
123 S IPRPT=$S(EASRPT=1:1,1:0)
124 S CPYFLG=0
125 S DECINF=$P($G(^DGMT(408.31,DGMTI,0)),"^",14)
126 S AGRPAY=$P($G(^DGMT(408.31,DGMTI,0)),"^",11)
127 I DECINF=1!(AGRPAY=0) S CPYFLG=1
128 S SRIC=$P(DGVIR0,U,16),LSEP=$P(DGVIR0,U,17)
129 S OPDR=$P(MAXRT,U),IPDR=$P(MAXRT,U,2)
130 I IPRPT S LOS=$$FMDIFF^XLFDT(EASRDT,EASADM)+1
131 ;
132 S OVR180=$S($G(LOS)>180:1,1:0)
133 S TINC=DGINT/12,TEXP=DGDET/12
134 I OVR180,('DGSP!('SRIC)) S TEXP=0
135 S TAST=DGNWT I OVR180 S TAST=$$ASSET
136 ;
137 ; Build data table
138 F IDX=1:1:12 D
139 .S DAYS=$$DOM($P(ARRY(IDX),"^",2))
140 .D CALCALL
141 .S $P(ARRY(IDX),"^",3)=TINC
142 .S $P(ARRY(IDX),"^",4)=TEXP
143 .S $P(ARRY(IDX),"^",5)=ALLOW
144 .S $P(ARRY(IDX),"^",6)=CALCCPY
145 .S $P(ARRY(IDX),"^",7)=MAXCPY
146 .S $P(ARRY(IDX),"^",8)=VETMAX
147 .S $P(ARRY(IDX),"^",9)=$S(OVR180:TAST,1:"-")
148 .S:OVR180 TAST=$$ASTSPD
149 .I $G(LOS) D
150 ..S LOS=LOS+DAYS
151 ..S:'OVR180 OVR180=$S(LOS>180:1,1:0)
152 ..I OVR180,('DGSP!'(SRIC)) S:TEXP TEXP=0
153 Q
154 ;
155CALCALL ; Calculate the allowance and all the copayment amounts
156 S ALLOW=20*DAYS*(1+SRIC) S:CPYFLG ALLOW=0
157 S CALCCPY=$$CALCCPY
158 S MAXCPY=$$CALCMAX(DAYS)
159 S VETMAX=$$VETMAX(CALCCPY,MAXCPY)
160 Q
161ASSET() ; Initialize asset amount by applying spend-down
162 N NUM,MNYR,J,DONE,DAYS,ALLOW,CALCCPY,MAXCPY,VETMAX
163 S DONE=0
164 ; Calculate number of months to spend down the assets
165 S NUM=(LOS-180)\30
166 ; Get month to start spend down
167 S MNYR=$$FMADD^XLFDT(EASADM,180)
168 I NUM>0 F J=1:1:NUM D Q:DONE
169 .S DAYS=$$DOM(MNYR)
170 .D CALCALL
171 .S TAST=$$ASTSPD I TAST=0 S DONE=1 Q
172 .S MNYR=MNYR+100 S:$E(MNYR,4,5)=13 MNYR=$E(MNYR,1,3)+1_"0100"
173 Q TAST
174ASTSPD() ;Asset Spend down for 180+ days
175 Q:CPYFLG TAST
176 I (TINC-TEXP-ALLOW)'>VETMAX D
177 . I DGSP,SRIC S TAST=TAST-(VETMAX-(TINC-TEXP-ALLOW))
178 . E S TAST=TAST-(VETMAX-(TINC-ALLOW))
179 . S:TAST<0 TAST=0
180 Q TAST
181 ;
182CALCCPY() ; Calculate the Co-Pay Amount
183 ;
184 Q:CPYFLG 0
185 Q:OVR180 TAST+TINC-ALLOW-TEXP
186 Q TINC-ALLOW-TEXP
187DOM(MNYR) ; Days in Month
188 ; Returns: number of days in a month
189 N DAYS,MN,YR
190 S MN=+$E(MNYR,4,5)
191 I "^4^6^9^11^"[("^"_MN_"^") S DAYS=30 Q DAYS
192 I MN=2 D Q DAYS
193 .S DAYS=28
194 .S YR=$E(MNYR,1,3)+1700
195 .S:YR#4=0 DAYS=29
196 S DAYS=31
197 Q DAYS
198CALCMAX(DAYS) ; Calculate the Maximum Co-Pay Amount
199 ;
200 Q $S(IPRPT:IPDR,1:OPDR)*DAYS
201VETMAX(CALCCPY,MAXCPY) ; Calculate the Veteran Maximum Co-Pay Amount
202 ;
203 Q:CPYFLG MAXCPY
204 Q:CALCCPY<0 0
205 Q:CALCCPY<MAXCPY CALCCPY
206 Q MAXCPY
207 ;
208NOTETXT ; Write the Note message
209 W !!,"IMPORTANT NOTICE: The copayment amounts shown in this report are"
210 W " estimates",!,"based on calculations of the copayment amount for "
211 W "an entire month. The",!,"copayment amounts will be adjusted to "
212 W "reflect the actual start date of LTC",!,"services and the "
213 W "copayment exemption for the first 21 days of service. The VET",!
214 W "COPAY amount is based on the assumption that the veteran "
215 W "will be responsible",!,"to pay the lesser of EITHER the calculated"
216 W " copayment (CALC COPAY) OR the",!,"maximum copayment (MAX COPAY). "
217 W "In the event that the calculated copayment",!,"(CALC COPAY) is a "
218 W "negative figure, the veteran copayment (VET COPAY)",!
219 W "will be adjusted to zero (0). If the veteran declined to provide"
220 W " income",!,"information, the veteran will be obligated to pay the"
221 W " maximum copayment."
222 Q
223 ;
224SPNDDWN ; Text of message to explain the asset spend down
225 W !!,"EXPLANATION OF ASSET SPEND DOWN CALCULATION:"
226 W !,"============================================"
227 W !,"The veteran's assets are included in the calculation of copayments"
228 W !,"after 180 days of institutional LTC services. The assets then may"
229 W !,"be reduced each month according to the following formula:"
230 W !
231 W !,"Single Veteran:"
232 W !
233 W !," TOTAL ASSETS-(VET COPAY-(INCOME-ALLOWANCE))"
234 W !
235 W !,"Married Veteran (spouse residing in the community):"
236 W !
237 W !," TOTAL ASSETS-(VET COPAY-(INCOME-EXPENSES-ALLOWANCE))"
238 W !
239 W !,"In other words, the assets will be reduced by the amount of the"
240 W !,"veteran's copayment that is not covered by the veteran's income "
241 W !,"after all expenses and allowances are subtracted. If the amount"
242 W !,"of the veteran's income after all expenses and allowances are"
243 W !,"subtracted is greater than the veteran's copayment then the assets"
244 W !,"will not be reduced."
245 W !
246 Q
Note: See TracBrowser for help on using the repository browser.