source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTHL1.m@ 767

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

initial load of WorldVistAEHR

File size: 8.5 KB
Line 
1DGMTHL1 ;ALB/CJM/TDM - Hardship Determinations - Build List Area;13 JUN 1997 08:00 am ; 8/29/02 4:50pm
2 ;;5.3;Registration;**182,456**;08/13/93
3 ;
4EN(DGARY,HARDSHIP,DGCNT) ;Entry point to build list area
5 ; Input;
6 ; DGARY Global array subscript
7 ; HARDSHIP - hardship array (pass by reference)
8 ; Output -- DGCNT Number of lines in the list
9 ;
10 N DGLINE
11 S DGLINE=1,DGCNT=0
12 D SET(DGARY,.HARDSHIP,.DGLINE,.DGCNT)
13 Q
14 ;
15SET(DGARY,HARDSHIP,DGLINE,DGCNT) ;
16 ;Description: Writes hardship
17 ; Input -- DGARY Global array subscript
18 ; HARDSHIP Hardship array
19 ; DGLINE Line number
20 ; Output -- DGCNT Number of lines in the list
21 N DGSTART,LINE
22 ;
23 S DGSTART=DGLINE ; starting line number
24 D SET^DGENL1(DGARY,DGLINE,"Hardship",21,IORVON,IORVOFF,,,,.DGCNT)
25 S DGLINE=DGLINE+1
26 D SET^DGENL1(DGARY,DGLINE,$J("Current Means Test Status: ",31)_$$EXT^DGMTH("CURRENT STATUS",HARDSHIP("CURRENT STATUS")),1,,,,,,.DGCNT)
27 S DGLINE=DGLINE+1
28 D SET^DGENL1(DGARY,DGLINE,$J("Income Year: ",31)_$S(HARDSHIP("YEAR"):$$EXT^DGMTH("YEAR",HARDSHIP("YEAR")),1:""),1,,,,,,.DGCNT)
29 S DGLINE=DGLINE+1
30 D SET^DGENL1(DGARY,DGLINE,$J("Means Test Date: ",31)_$$EXT^DGMTH("TEST DATE",HARDSHIP("TEST DATE")),1,,,,,,.DGCNT)
31 S DGLINE=DGLINE+1
32 I (HARDSHIP("AGREE")'="") D SET^DGENL1(DGARY,DGLINE,$J("Agreed To Pay Deductible: ",31)_$$EXT^DGMTH("AGREE",HARDSHIP("AGREE")),1,,,,,,.DGCNT) S DGLINE=DGLINE+1
33 ;
34 S DGLINE=DGLINE+1
35 D SET^DGENL1(DGARY,DGLINE,$J("Hardship?: ",31)_$$EXT^DGMTH("HARDSHIP?",HARDSHIP("HARDSHIP?")),1,,,,,,.DGCNT)
36 S DGLINE=DGLINE+1
37 D SET^DGENL1(DGARY,DGLINE,$J("Hardship Effective Date: ",31)_$$EXT^DGMTH("EFFECTIVE",HARDSHIP("EFFECTIVE")),1,,,,,,.DGCNT)
38 S DGLINE=DGLINE+1
39 D SET^DGENL1(DGARY,DGLINE,$J("Review Date: ",31)_$$EXT^DGMTH("REVIEW",HARDSHIP("REVIEW")),1,,,,,,.DGCNT)
40 S DGLINE=DGLINE+1
41 D SET^DGENL1(DGARY,DGLINE,$J("Site Granting Hardship: ",31)_$$EXT^DGMTH("SITE",HARDSHIP("SITE")),1,,,,,,.DGCNT)
42 S DGLINE=DGLINE+1
43 D SET^DGENL1(DGARY,DGLINE,$J("Approved By: ",31)_$$EXT^DGMTH("BY",HARDSHIP("BY")),1,,,,,,.DGCNT)
44 S DGLINE=DGLINE+1
45 D SET^DGENL1(DGARY,DGLINE,$J("Hardship Reason: ",31)_$$EXT^DGMTH("REASON",HARDSHIP("REASON")),1,,,,,,.DGCNT)
46 S DGLINE=DGLINE+2
47 ;
48 D SET^DGENL1(DGARY,DGLINE,$J("Date Category Last Changed: ",31)_$$EXT^DGMTH("DT/TM CTGRY CHNGD",HARDSHIP("DT/TM CTGRY CHNGD")),1,,,,,,.DGCNT)
49 S DGLINE=DGLINE+1
50 D SET^DGENL1(DGARY,DGLINE,$J("Category Last Changed By: ",31)_$$EXT^DGMTH("CTGRY CHNGD BY",HARDSHIP("CTGRY CHNGD BY")),1,,,,,,.DGCNT)
51 S DGLINE=DGLINE+1
52 I $D(^DGMT(408.31,HARDSHIP("MTIEN"),"C")) D
53 .N LINE
54 .D SET^DGENL1(DGARY,DGLINE,"COMMENTS:",1,$G(IOINHI),$G(IOINORM),,,,.DGCNT)
55 .S DGLINE=DGLINE+1
56 .S LINE=0
57 .F S LINE=$O(^DGMT(408.31,HARDSHIP("MTIEN"),"C",LINE)) Q:'LINE D
58 ..D SET^DGENL1(DGARY,DGLINE,$G(^DGMT(408.31,HARDSHIP("MTIEN"),"C",LINE,0)),1,,,,,,.DGCNT)
59 ..S DGLINE=DGLINE+1
60 Q
61 ;
62CHKADD(HARDSHIP) ;
63 ;Determines whether granting a hardship is appropriate
64 ;Input:
65 ; HARDSHIP - hardship array (pass by reference)
66 ;Output:
67 ; Function Value - 1 if the hardship can be granted, 0 otherwise
68 ;
69 N CODE
70 S CODE=""
71 S CODE=$$GETCODE^DGMTH(HARDSHIP("CURRENT STATUS"))
72 I CODE'="C",CODE'="P",CODE'="G" Q 0
73 Q 1
74 ;
75ADD(HARDSHIP) ;
76 ;Add hardship protocol.
77 ;
78 ;Input:
79 ; HARDSHIP - hardship array, pass by reference
80 ;Output:
81 ; HARDSHIP - hardship array (pass by reference)
82 ;
83 N CODE,ERROR
84 I $G(DUZ)'>1 W !,"YOUR DUZ IS NOT DEFINED!" D PAUSE^VALM1 S VALMBCK="R" Q
85 S CODE=""
86 S CODE=$$GETCODE^DGMTH(HARDSHIP("CURRENT STATUS"))
87 I CODE'="C",CODE'="P",CODE'="G" W !,"PATIENT NOT CURRENTLY RESPONSIBLE FOR COPAYMENT CHARGES!" D PAUSE^VALM1 Q
88 S HARDSHIP("EFFECTIVE")=DT
89 S HARDSHIP("SITE")=$$GETSITE^DGMTU4(.DUZ)
90 I HARDSHIP("TEST STATUS")="" S HARDSHIP("TEST STATUS")=HARDSHIP("CURRENT STATUS")
91 ;S HARDSHIP("CURRENT STATUS")=$$GETSTAT^DGMTH("A",1)
92 S HARDSHIP("BY")=DUZ
93 S HARDSHIP("CTGRY CHNGD BY")=DUZ
94 S HARDSHIP("DT/TM CTGRY CHNGD")=$$NOW^XLFDT
95 S HARDSHIP("HARDSHIP?")=1
96 S HARDSHIP("AGREE")=""
97 D
98 .I '$$GETSTAT(.HARDSHIP) Q
99 .I '$$GETEFF(.HARDSHIP) Q
100 .I '$$GETREV(.HARDSHIP) Q
101 .I '$$GETREAS(.HARDSHIP) Q
102 .D PRIOR(.HARDSHIP)
103 .I $$STORE^DGMTH(.HARDSHIP,.ERROR) D
104 ..N EVENTS
105 ..S EVENTS("IVM")=1
106 ..I $$LOG^IVMPLOG(HARDSHIP("DFN"),HARDSHIP("YEAR"),.EVENTS)
107 .E W !,$G(ERROR) D PAUSE^VALM1
108 .D AFTER(.HARDSHIP)
109 D INIT^DGMTHL
110 S VALMBCK="R"
111 Q
112 ;
113EDIT(HARDSHIP) ;
114 ;Add hardship protocol.
115 ;
116 ;Input:
117 ; HARDSHIP - hardship array, pass by reference
118 ;Output:
119 ; HARDSHIP - hardship array (pass by reference)
120 ;
121 N ERROR
122 D
123 .I '$$GETSTAT(.HARDSHIP,1) Q
124 .I '$$GETEFF(.HARDSHIP) Q
125 .I '$$GETREV(.HARDSHIP) Q
126 .I '$$GETREAS(.HARDSHIP) Q
127 .D PRIOR(.HARDSHIP)
128 .I $$STORE^DGMTH(.HARDSHIP,.ERROR) D
129 ..N EVENTS
130 ..S EVENTS("IVM")=1
131 ..I $$LOG^IVMPLOG(HARDSHIP("DFN"),HARDSHIP("YEAR"),.EVENTS)
132 .E W !,$G(ERROR) D PAUSE^VALM1
133 .D AFTER(.HARDSHIP)
134 D INIT^DGMTHL
135 S VALMBCK="R"
136 Q
137 ;
138CHKDEL(HARDSHIP) ;
139 ;Checks whether the hardship can be deleted.
140 ;Input:
141 ; HARDSHIP - hardship array (pass by reference)
142 I (HARDSHIP("HARDSHIP?")="1"),(HARDSHIP("BY")!((+HARDSHIP("SITE")=+$$GETSITE^DGMTU4($G(DUZ))))) Q 1
143 Q 0
144DELETE(HARDSHIP) ;
145 ;Deletes the hardship.
146 ;
147 ;Input:
148 ; HARDSHIP - hardship array (pass by reference)
149 ;
150 N ERROR
151 I $$RUSURE,'$$DELETE^DGMTH(.HARDSHIP,1,.ERROR) W !,"AN ERROR OCCURRED - "_$G(ERROR) D PAUSE^VALM1
152 D INIT^DGMTHL
153 S VALMBCK="R"
154 Q
155 ;
156GETSTAT(HARDSHIP,EDITFLG) ;
157 ;Asks the user to enter the means test status.
158 ;
159 ;Input:
160 ; HARDSHIP - hardship array (pass by reference)
161 ; EDITFLG - Edit Flag: 1=Edit
162 ;Output:
163 ; HARDSHIP("CURRENT STATUS")
164 ;
165 N DIR,FLTRSTAT
166 S FLTRSTAT=$$GETCODE^DGMTH($S($G(EDITFLG):HARDSHIP("TEST STATUS"),1:HARDSHIP("CURRENT STATUS")))
167 S DIR(0)="Pr^408.32:EMZ"
168 S DIR("S")="I $P(^(0),U,19)=1"
169 I "CP"[FLTRSTAT S DIR("S")=DIR("S")_",""AG""[$P(^(0),U,2)"
170 I FLTRSTAT="G" S DIR("S")=DIR("S")_",""A""[$P(^(0),U,2)"
171 S DIR("A")="Means Test Status"
172 S DIR("B")=$$EXT^DGMTH("CURRENT STATUS",HARDSHIP("CURRENT STATUS"))
173 D FULL^VALM1
174 D ^DIR
175 I $D(DIRUT) Q 0
176 I Y<1 Q 0
177 S HARDSHIP("CURRENT STATUS")=+Y
178 S VALMBCK="R"
179 Q 1
180 ;
181GETEFF(HARDSHIP) ;
182 ;Asks the user to enter the effective date. Returns 1 on success, 0 on failure
183 ;
184 ;Input:
185 ; HARDSHIP - hardship array (pass by reference)
186 ;Output:
187 ; HARDSHIP("EFFECTIVE")
188 ;
189 N DIR
190 S DIR(0)="D^"_HARDSHIP("TEST DATE")_":"_DT_":EX"
191 S DIR("A")="Hardship Effective Date"
192 S DIR("B")=$$FMTE^XLFDT($S(HARDSHIP("EFFECTIVE"):HARDSHIP("EFFECTIVE"),1:HARDSHIP("TEST DATE")),"1D")
193 D ^DIR
194 I $D(DIRUT) Q 0
195 I Y<1 Q 0
196 S HARDSHIP("EFFECTIVE")=Y
197 Q 1
198GETREV(HARDSHIP) ;
199 ;Asks the user to enter the review date. Returns 1 on success, 0 on failure
200 ;
201 ;Input:
202 ; HARDSHIP - hardship array (pass by reference)
203 ;Output:
204 ; HARDSHIP("REVIEW")
205 ;
206 N RET,STOP,X,Y
207 S (STOP,RET)=0
208 S DIR(0)="DO^::EX"
209 S DIR("A")="Hardship Review Date"
210 I HARDSHIP("REVIEW") S DIR("B")=$$FMTE^XLFDT(HARDSHIP("REVIEW"),"1D")
211 S DIR("?")="Enter a future date if you wish to conduct a review."
212 F D Q:STOP
213 .N DIR
214 .S DIR(0)="DO^::EX"
215 .S DIR("A")="Hardship Review Date"
216 .I HARDSHIP("REVIEW") S DIR("B")=$$FMTE^XLFDT(HARDSHIP("REVIEW"),"1D")
217 .S DIR("?")="Enter a future date if you wish to conduct a review."
218 .D ^DIR
219 .I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S STOP=1,RET=0 Q
220 .I X="@" S Y="",STOP=1,RET=1 Q
221 .I Y=-1 S STOP=1,RET=0 Q
222 .I Y<DT W !,DIR("?") Q
223 .S (STOP,RET)=1
224 S:RET HARDSHIP("REVIEW")=Y
225 Q RET
226 ;
227GETREAS(HARDSHIP) ;
228 ;Asks the user to enter the hardship reason.
229 ;
230 ;Input:
231 ; HARDSHIP - hardship array (pass by reference)
232 ;Output
233 ; HARDSHIP("REASON")
234 ;
235 N DIR
236 S DIR(0)="FO^3:80"
237 S DIR("A")="Hardship Reason"
238 S DIR("B")=$G(HARDSHIP("REASON")) K:DIR("B")="" DIR("B")
239 D ^DIR
240 I $D(DTOUT)!$D(DUOUT) Q 0
241 S HARDSHIP("REASON")=Y
242 Q 1
243 ;
244PRIOR(HARDSHIP) ;set up for means test event driver
245 S DFN=HARDSHIP("DFN")
246 S DGMTI=HARDSHIP("MTIEN")
247 S DGMTS=HARDSHIP("CURRENT STATUS")
248 S DGMTACT="CAT"
249 S DGMTYPT=1
250 D PRIOR^DGMTEVT
251 Q
252AFTER(HARDSHIP) ;calls means test event driver
253 D AFTER^DGMTEVT
254 S DGMTINF=0
255 D EN^DGMTEVT
256 K DGMTA,DGMTACT,DGMTDT,DGMTI,DGMTINF,DGMTP,DGMTS,DGMTYPT,I,J,Y
257 Q
258COMMENTS(HARDSHIP) ;
259 ;Edit Comments protocol.
260 ;
261 ;Input:
262 ; HARDSHIP - hardship array, pass by reference
263 ;Output:
264 ; none
265 ;
266 N DA,DIE,DR
267 I $G(DUZ)'>1 W !,"YOUR DUZ IS NOT DEFINED!" D PAUSE^VALM1 S VALMBCK="R" Q
268 D FULL^VALM1
269 I $G(HARDSHIP("MTIEN")) S DR="50",DA=HARDSHIP("MTIEN"),DIE=408.31 D ^DIE
270 D INIT^DGMTHL
271 I VALMCNT<15 S VALMBG=1
272 S VALMBCK="R"
273 Q
274 ;
275RUSURE() ;
276 ;Description: Asks user 'Are you sure?'
277 ;Input: none
278 ;Output: Function Value returns 0 or 1
279 ;
280 N DIR
281 S DIR(0)="Y"
282 S DIR("A")="Are you sure that the hardship should be deleted"
283 S DIR("B")="NO"
284 D ^DIR
285 Q:$D(DIRUT) 0
286 Q Y
Note: See TracBrowser for help on using the repository browser.