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

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

initial load of WorldVistAEHR

File size: 9.0 KB
Line 
1DGEN ;ALB/RMO/CJM - Patient Enrollment Option; 11/17/00 12:12pm ; 12/6/00 5:32pm
2 ;;5.3;Registration;**121,122,165,147,232,314,624**;Aug 13,1993
3 ;
4EN ;Entry point for stand-alone enrollment option
5 ; Input -- None
6 ; Output -- None
7 N DFN
8 ;
9 ;Get Patient file (#2) IEN - DFN
10 D GETPAT^DGRPTU(,,.DFN,) G ENQ:DFN<0
11 ;
12 ;Load patient enrollment screen
13 D EN^DGENL(DFN)
14ENQ Q
15 ;
16EN1(DFN) ;Entry point for enrollment from registration and disposition
17 ; Input -- DFN Patient IEN
18 ; Output -- None
19 N DGENOUT
20 ;
21 ;Check if patient should be asked to enroll
22 I $$CHK(DFN) D
23 . ;Enroll patient
24 . I $$ENRPAT(DFN,.DGENOUT)
25 ;
26 ;If user did not timeout or '^' and
27 ;patient is an eligible veteran or has an enrollment status
28 I '$G(DGENOUT),($$VET^DGENPTA(DFN)!($$STATUS^DGENA(DFN))) D
29 . ;Display enrollment
30 . D DISPLAY^DGENU(DFN)
31EN1Q Q
32 ;
33CHK(DFN) ;Check if patient should be asked to enroll
34 ; Input -- DFN Patient IEN
35 ; Output -- 1=Yes and 0=No
36 N Y,STATUS
37 S Y=1
38 ;Is patient an eligible veteran
39 S Y=$$VET^DGENPTA(DFN)
40 ;
41 ;Is patient already enrolled or pending enrollment
42 S STATUS=$$STATUS^DGENA(DFN)
43 ; Purple Heart added status 21
44 I Y,(STATUS=9)!(STATUS=1)!(STATUS=2)!(STATUS=14)!(STATUS=15)!(STATUS=16)!(STATUS=17)!(STATUS=18)!(STATUS=21) S Y=0
45 Q +$G(Y)
46 ;
47ENRPAT(DFN,DGENOUT) ;Enroll patient
48 ; Input -- DFN Patient IEN
49 ; Output -- 1=Successful and 0=Failure
50 ; DGENOUT 1=Timeout or up-arrow
51 N DGOKF
52 ;Ask patient if s/he would like to enroll
53 I $$ASK("enroll",.DGENOUT) D
54 . ;If 'Yes' enroll patient
55 . S DGOKF=$$ENROLL(DFN)
56 ELSE D
57 . ;Quit if timeout or '^'
58 . Q:$G(DGENOUT)
59 . ;Otherwise patient declined enrollment
60 . ;Cancel/decline functionality disabled by DG*5.3*232
61 . ;S DGOKF=$$DECLINE(DFN,DT)
62 . S DGOKF=0
63 . ;* Prompt for requested appt. (DG*5.3*624)
64 . I $P($G(^DPT(DFN,1010.15)),"^",9)="" DO
65 . . N DGSXS,DGAPPTAN
66 . . S DGSXS=$$PROMPT^DGENU(2,1010.159,1,.DGAPPTAN,"",1)
67 . . I DGSXS DO
68 . . . N DA,DR,DIE
69 . . . S DA=DFN
70 . . . S DIE="^DPT("
71 . . . S DR="1010.159////^S X=DGAPPTAN"
72 . . . D ^DIE
73 . . . K DA,DR,DIE
74 . . . ;*Set Appointment Request Date to current date
75 . . . N DA,DR,DIE
76 . . . S DIE="^DPT("
77 . . . S DA=DFN
78 . . . S DR="1010.1511////^S X=DT"
79 . . . D ^DIE
80 . . . K DA,DR,DIE
81ENRPATQ Q +$G(DGOKF)
82 ;
83ASK(ACTION,DGENOUT) ;Ask patient if s/he would like to enroll or cease enrollment
84 ; Input -- ACTION Action description
85 ; Output -- 1=Yes and 0=No
86 ; DGENOUT 1=Timeout or up-arrow
87 N DIR,DTOUT,DUOUT,Y
88 S DIR("A")="Do you wish to "_ACTION_" in the VA Patient Enrollment System"
89 S DIR("B")="YES",DIR(0)="Y"
90 W ! D ^DIR
91 I $D(DTOUT)!($D(DUOUT)) S DGENOUT=1
92 Q +$G(Y)
93 ;
94ENROLL(DFN) ;Create new local unverified enrollment
95 ; Input -- DFN Patient IEN
96 ; Output -- 1=Successful and 0=Failure
97 N DGENR,DGOKF,DGREQF,APPDATE
98 ;Lock enrollment record
99 I '$$LOCK^DGENA1(DFN) D G ENROLLQ
100 . W !,">>> Another user is editing, try later ..."
101 . D PAUSE^VALM1
102 ;
103 ;now that the enrollment history is locked, need to check again whether or not patient may be enrolled (query reply may have been received)
104 G:'$$CHK^DGEN(DFN) ENROLLQ
105 ;
106 ;Ask Application Date
107 W !
108 I $$PROMPT^DGENU(27.11,.01,DT,.APPDATE) D
109 . ;Does patient require a Means Test?
110 . D EN^DGMTR
111 . ;Create local enrollment array
112 . I $$CREATE^DGENA6(DFN,APPDATE,,,,.DGENR) D
113 . . ;Store local enrollment as current
114 . . I $$STORECUR^DGENA1(.DGENR) D
115 . . . S DGOKF=1
116 . . . ;Ask preferred facility
117 . . . D PREFER^DGENPT(DFN)
118 . . . ;If patient's means test status is required, send bulletin
119 . . . I $$MTREQ(DFN) D MTBULL(DFN,.DGENR)
120 I $P($G(^DPT(DFN,1010.15)),"^",11)="" DO
121 . N DGSXS,DGAPPTAN,DGDFLT
122 . S DGDFLT=$P($G(^DPT(DFN,1010.15)),"^",9)
123 . S:DGDFLT="" DGDFLT=1
124 . S DGSXS=$$PROMPT^DGENU(2,1010.159,DGDFLT,.DGAPPTAN,"",1)
125 . I DGSXS DO
126 . . N DA,DR,DIE
127 . . S DA=DFN
128 . . S DIE="^DPT("
129 . . S DR="1010.159////^S X=DGAPPTAN"
130 . . D ^DIE
131 . . K DA,DR,DIE
132 . . ;*If patient answered NO to "Do you want an appt" question
133 . . I $P($G(^DPT(DFN,1010.15)),"^",9)=0 DO
134 . . . N DA,DR,DIE
135 . . . S DIE="^DPT("
136 . . . S DA=DFN
137 . . . S DR="1010.1511////^S X=DT"
138 . . . D ^DIE
139 . . . K DA,DR,DIE
140 . . ;*If patient answered YES to "Do you want an appt" question
141 . . I $P($G(^DPT(DFN,1010.15)),"^",9)=1 DO
142 . . . N DA,DR,DIE
143 . . . S DIE="^DPT("
144 . . . S DA=DFN
145 . . . S DR="1010.1511////^S X=APPDATE"
146 . . . D ^DIE
147 . . . K DA,DR,DIE
148ENROLLQ D UNLOCK^DGENA1(DFN)
149 Q +$G(DGOKF)
150 ;
151CANCEL(DFN,DGENR,EFFDATE) ;Cancel current enrollment
152 ; Input
153 ; DFN Patient IEN
154 ; DGENR Array containing current enrollment (pass by reference)
155 ; EFFDATE Enrollment Effective Date Of Change (optional)
156 ; Output
157 ; Function Return Value is 1 if Successful and 0 on Failure
158 ;
159 N DGENR2,DGOKF,REASON,REMARKS,BEGIN,END,ERRMSG
160 ;Lock enrollment record
161 I '$$LOCK^DGENA1(DFN) D G CANCELQ
162 .W !,">>> Another user is editing, try later ..."
163 .D PAUSE^VALM1
164 W !
165 ;Ask effective date of change for cessation
166 I '$G(EFFDATE) D G:'EFFDATE CANCELQ
167 .N DIR
168 .S BEGIN=$S(DGENR("DATE"):DGENR("DATE"),1:DGENR("APP"))
169 .S END=DGENR("END")
170 .S DIR(0)="D^::AEX"
171 .S DIR("A")="Effective Date of Cancellation"
172 .S DIR("B")=$$VIEWDATE(DT)
173ASKDATE .W !,"Please enter the date to cease enrollment, no earlier than "_$$VIEWDATE(BEGIN)
174 .I END W !,"and no later than "_$$VIEWDATE(END)_"."
175 .D ^DIR
176 .I $D(DIRUT)!('Y) S EFFDATE="" Q
177 .E S EFFDATE=Y I (EFFDATE<BEGIN)!(END&(END<EFFDATE)) G ASKDATE
178 .;
179 ;Ask reason canceled/declined enrollment
180 I '$$PROMPT^DGENU(27.11,.05,,.REASON,1) G CANCELQ
181 ;If reason is 'Other', ask for remarks
182 I REASON=4,'$$PROMPT^DGENU(27.11,25,,.REMARKS,1) G CANCELQ
183 ;Create local enrollment array
184 I $$CREATE^DGENA6(DFN,DGENR("APP"),EFFDATE,REASON,$G(REMARKS),.DGENR2,DGENR("DATE"),EFFDATE) D
185 .;Store local enrollment as current
186 .I $$STORECUR^DGENA1(.DGENR2,,.ERRMSG) D
187 ..S DGOKF=1
188 .E D
189 ..W !,$G(ERRMSG)
190 ;
191 D UNLOCK^DGENA1(DFN)
192CANCELQ Q +$G(DGOKF)
193 ;
194DECLINE(DFN,APPDATE) ;Create Declined enrollment
195 ; Input -- DFN Patient IEN
196 ; APPDATE Application date (optional)
197 ; Output -- 1=Successful and 0=Failure
198 N DGENR,DGOKF,REASON,REMARKS
199 ;Lock enrollment record
200 I '$$LOCK^DGENA1(DFN) D G DECLINEQ
201 . W !,">>> Another user is editing, try later ..."
202 . D PAUSE^VALM1
203 ;Ask enrollment date
204 W !
205 I '$G(APPDATE),'$$PROMPT^DGENU(27.11,.01,DT,.APPDATE) G DECLINEQ
206 ;Ask reason declined enrollment
207 I '$$PROMPT^DGENU(27.11,.05,,.REASON,1) G DECLINEQ
208 ;If reason is 'Other', ask for remarks
209 I REASON=4,'$$PROMPT^DGENU(27.11,25,,.REMARKS,1) G DECLINEQ
210 ;Create local enrollment array
211 I $$CREATE^DGENA6(DFN,APPDATE,DT,REASON,$G(REMARKS),.DGENR) D
212 . ;Store local enrollment as current
213 . I $$STORECUR^DGENA1(.DGENR) D
214 . . S DGOKF=1
215 . . ;Ask preferred facility
216 . . D PREFER^DGENPT(DFN)
217 D UNLOCK^DGENA1(DFN)
218DECLINEQ ;
219 Q +$G(DGOKF)
220 ;
221MTBULL(DFN,DGENR) ;Create/Send means test 'REQUIRED' bulletin for PATIENT ENROLLMENT
222 ;
223 ; Input:
224 ; DFN - patient IEN
225 ; DGENR - this local array represents the PATIENT ENROLLMENT and
226 ; should be passed by reference
227 ;
228 ; Output: None
229 ;
230 N DGBULL,DGLINE,DGMGRP,DGNAME,DIFROM,VA,VAERR,XMTEXT,XMSUB,XMDUZ
231 ;
232 ; get Means Test 'Required' mail group
233 S DGMGRP=$P($G(^DG(43,1,"NOT")),"^",13)
234 ;
235 ; if mail group not defined, exit
236 I 'DGMGRP G MTBULLQ
237 ;
238 ; set up XMY array
239 D XMY^DGMTUTL(DGMGRP,0,1)
240 ;
241 ; obtain patient identifier
242 D PID^VADPT6
243 ;
244 ; patient name
245 S DGNAME=$P($G(^DPT(DFN,0)),"^")
246 ;
247 ; local array containing msg text
248 S XMTEXT="DGBULL("
249 ;
250 ; - msg subject
251 S XMSUB=$E("Patient: "_DGNAME,1,30)_" ("_VA("BID")_") "_"Means Test Required"
252 ;
253 ; - insert lines of text into message
254 S DGLINE=0
255 D LINE("The following patient is enrolled in the VA Patient Enrollment",.DGLINE)
256 D LINE("System and 'REQUIRES' a means test.",.DGLINE)
257 D LINE("",.DGLINE)
258 D LINE(" Patient Name: "_DGNAME,.DGLINE)
259 D LINE(" Patient ID: "_VA("PID"),.DGLINE)
260 D LINE("",.DGLINE)
261 D LINE(" Enrollment Date: "_$$EXT^DGENU("DATE",DGENR("DATE")),.DGLINE)
262 D LINE(" Enrollment Status: "_$$EXT^DGENU("STATUS",DGENR("STATUS")),.DGLINE)
263 D LINE(" Entered By: "_$$EXT^DGENU("USER",DGENR("USER")),.DGLINE)
264 D LINE(" Date/Time Entered: "_$$EXT^DGENU("DATETIME",DGENR("DATETIME")),.DGLINE)
265 D ^XMD
266 ;
267MTBULLQ Q
268 ;
269LINE(DGTEXT,DGLINE) ;Add lines of text to mail message
270 ;
271 ; Input:
272 ; DGTEXT - as line of text to be inserted into mail message
273 ; DGLINE - as number of lines in message, passed by reference
274 ;
275 ; Output:
276 ; DGBULL - as local array containing message text
277 ;
278 S DGLINE=DGLINE+1
279 S DGBULL(DGLINE)=DGTEXT
280 Q
281 ;
282MTREQ(DFN) ; --
283 ;Determine if Means Test (required) bulletin should be sent for patient.
284 ;
285 ; Input:
286 ; DFN - patient IEN
287 ;
288 ; Output:
289 ; 1=Successful and 0=Failure
290 ;
291 N DGMTNODE,DGMTREQ
292 ;
293 ;Last means test for patient
294 S DGMTNODE=$$LST^DGMTU(DFN)
295 ;
296 ;If scheduling bulletin already sent, exit
297 I $P($G(^DGMT(408.31,+DGMTNODE,"BUL")),"^")=DT G MTREQQ
298 ;
299 ;If patient means test status is 'REQUIRED'
300 I $P(DGMTNODE,"^",4)="R" D
301 . ;set flag (send bulletin)
302 . S DGMTREQ=1
303 ;
304MTREQQ Q +$G(DGMTREQ)
305 ;
306VIEWDATE(FMDATE) ;
307 ;This function changes a FM date to its external representation
308 N Y
309 S Y=$G(FMDATE)
310 D DD^%DT
311 Q Y
Note: See TracBrowser for help on using the repository browser.