1 | KIDS Distribution saved on Mar 23, 2014@10:18:31
|
---|
2 | World VistA
|
---|
3 | **KIDS**:VWGUIR_UPDATE_03232014*1.0T*1^
|
---|
4 |
|
---|
5 | **INSTALL NAME**
|
---|
6 | VWGUIR_UPDATE_03232014*1.0T*1
|
---|
7 | "BLD",8495,0)
|
---|
8 | VWGUIR_UPDATE_03232014*1.0T*1^^0^3140323^n
|
---|
9 | "BLD",8495,1,0)
|
---|
10 | ^^2^2^3140323^
|
---|
11 | "BLD",8495,1,1,0)
|
---|
12 | Contains routine updates, pat inquiry display, enables making an
|
---|
13 | "BLD",8495,1,2,0)
|
---|
14 | input template through the GUI.
|
---|
15 | "BLD",8495,4,0)
|
---|
16 | ^9.64PA^^
|
---|
17 | "BLD",8495,6.3)
|
---|
18 | 1
|
---|
19 | "BLD",8495,"KRN",0)
|
---|
20 | ^9.67PA^779.2^20
|
---|
21 | "BLD",8495,"KRN",.4,0)
|
---|
22 | .4
|
---|
23 | "BLD",8495,"KRN",.401,0)
|
---|
24 | .401
|
---|
25 | "BLD",8495,"KRN",.402,0)
|
---|
26 | .402
|
---|
27 | "BLD",8495,"KRN",.402,"NM",0)
|
---|
28 | ^9.68A^^0
|
---|
29 | "BLD",8495,"KRN",.403,0)
|
---|
30 | .403
|
---|
31 | "BLD",8495,"KRN",.5,0)
|
---|
32 | .5
|
---|
33 | "BLD",8495,"KRN",.84,0)
|
---|
34 | .84
|
---|
35 | "BLD",8495,"KRN",3.6,0)
|
---|
36 | 3.6
|
---|
37 | "BLD",8495,"KRN",3.8,0)
|
---|
38 | 3.8
|
---|
39 | "BLD",8495,"KRN",3.8,"NM",0)
|
---|
40 | ^9.68A^^0
|
---|
41 | "BLD",8495,"KRN",9.2,0)
|
---|
42 | 9.2
|
---|
43 | "BLD",8495,"KRN",9.8,0)
|
---|
44 | 9.8
|
---|
45 | "BLD",8495,"KRN",9.8,"NM",0)
|
---|
46 | ^9.68A^11^4
|
---|
47 | "BLD",8495,"KRN",9.8,"NM",8,0)
|
---|
48 | VWREGIT^^0^B129809193
|
---|
49 | "BLD",8495,"KRN",9.8,"NM",9,0)
|
---|
50 | VWREGIT2^^0^B100003944
|
---|
51 | "BLD",8495,"KRN",9.8,"NM",10,0)
|
---|
52 | VWREGIT3^^0^B43452100
|
---|
53 | "BLD",8495,"KRN",9.8,"NM",11,0)
|
---|
54 | VWREGIT4^^0^B43791810
|
---|
55 | "BLD",8495,"KRN",9.8,"NM","B","VWREGIT",8)
|
---|
56 |
|
---|
57 | "BLD",8495,"KRN",9.8,"NM","B","VWREGIT2",9)
|
---|
58 |
|
---|
59 | "BLD",8495,"KRN",9.8,"NM","B","VWREGIT3",10)
|
---|
60 |
|
---|
61 | "BLD",8495,"KRN",9.8,"NM","B","VWREGIT4",11)
|
---|
62 |
|
---|
63 | "BLD",8495,"KRN",19,0)
|
---|
64 | 19
|
---|
65 | "BLD",8495,"KRN",19,"NM",0)
|
---|
66 | ^9.68A^^0
|
---|
67 | "BLD",8495,"KRN",19.1,0)
|
---|
68 | 19.1
|
---|
69 | "BLD",8495,"KRN",101,0)
|
---|
70 | 101
|
---|
71 | "BLD",8495,"KRN",101,"NM",0)
|
---|
72 | ^9.68A^^0
|
---|
73 | "BLD",8495,"KRN",409.61,0)
|
---|
74 | 409.61
|
---|
75 | "BLD",8495,"KRN",771,0)
|
---|
76 | 771
|
---|
77 | "BLD",8495,"KRN",771,"NM",0)
|
---|
78 | ^9.68A^^0
|
---|
79 | "BLD",8495,"KRN",779.2,0)
|
---|
80 | 779.2
|
---|
81 | "BLD",8495,"KRN",870,0)
|
---|
82 | 870
|
---|
83 | "BLD",8495,"KRN",8989.51,0)
|
---|
84 | 8989.51
|
---|
85 | "BLD",8495,"KRN",8989.51,"NM",0)
|
---|
86 | ^9.68A^^0
|
---|
87 | "BLD",8495,"KRN",8989.52,0)
|
---|
88 | 8989.52
|
---|
89 | "BLD",8495,"KRN",8994,0)
|
---|
90 | 8994
|
---|
91 | "BLD",8495,"KRN",8994,"NM",0)
|
---|
92 | ^9.68A^10^1
|
---|
93 | "BLD",8495,"KRN",8994,"NM",10,0)
|
---|
94 | VW REG PATINQ^^0
|
---|
95 | "BLD",8495,"KRN",8994,"NM","B","VW REG PATINQ",10)
|
---|
96 |
|
---|
97 | "BLD",8495,"KRN","B",.4,.4)
|
---|
98 |
|
---|
99 | "BLD",8495,"KRN","B",.401,.401)
|
---|
100 |
|
---|
101 | "BLD",8495,"KRN","B",.402,.402)
|
---|
102 |
|
---|
103 | "BLD",8495,"KRN","B",.403,.403)
|
---|
104 |
|
---|
105 | "BLD",8495,"KRN","B",.5,.5)
|
---|
106 |
|
---|
107 | "BLD",8495,"KRN","B",.84,.84)
|
---|
108 |
|
---|
109 | "BLD",8495,"KRN","B",3.6,3.6)
|
---|
110 |
|
---|
111 | "BLD",8495,"KRN","B",3.8,3.8)
|
---|
112 |
|
---|
113 | "BLD",8495,"KRN","B",9.2,9.2)
|
---|
114 |
|
---|
115 | "BLD",8495,"KRN","B",9.8,9.8)
|
---|
116 |
|
---|
117 | "BLD",8495,"KRN","B",19,19)
|
---|
118 |
|
---|
119 | "BLD",8495,"KRN","B",19.1,19.1)
|
---|
120 |
|
---|
121 | "BLD",8495,"KRN","B",101,101)
|
---|
122 |
|
---|
123 | "BLD",8495,"KRN","B",409.61,409.61)
|
---|
124 |
|
---|
125 | "BLD",8495,"KRN","B",771,771)
|
---|
126 |
|
---|
127 | "BLD",8495,"KRN","B",779.2,779.2)
|
---|
128 |
|
---|
129 | "BLD",8495,"KRN","B",870,870)
|
---|
130 |
|
---|
131 | "BLD",8495,"KRN","B",8989.51,8989.51)
|
---|
132 |
|
---|
133 | "BLD",8495,"KRN","B",8989.52,8989.52)
|
---|
134 |
|
---|
135 | "BLD",8495,"KRN","B",8994,8994)
|
---|
136 |
|
---|
137 | "BLD",8495,"QDEF")
|
---|
138 | ^^^^NO^^^^NO^^NO
|
---|
139 | "BLD",8495,"QUES",0)
|
---|
140 | ^9.62^^
|
---|
141 | "BLD",8495,"REQB",0)
|
---|
142 | ^9.611^^
|
---|
143 | "KRN",8994,2596,-1)
|
---|
144 | 0^10
|
---|
145 | "KRN",8994,2596,0)
|
---|
146 | VW REG PATINQ^DEMOG^VWREGIT4^2^P^^^0^1
|
---|
147 | "KRN",8994,2596,1,0)
|
---|
148 | ^8994.01^1^1^3140313^^
|
---|
149 | "KRN",8994,2596,1,1,0)
|
---|
150 | Returns all existing demographic (non-clinical) data on a patient
|
---|
151 | "KRN",8994,2596,2,0)
|
---|
152 | ^8994.02A^1^1
|
---|
153 | "KRN",8994,2596,2,1,0)
|
---|
154 | IDATA^1^^1^1
|
---|
155 | "KRN",8994,2596,2,"B","IDATA",1)
|
---|
156 |
|
---|
157 | "KRN",8994,2596,2,"PARAMSEQ",1,1)
|
---|
158 |
|
---|
159 | "MBREQ")
|
---|
160 | 0
|
---|
161 | "ORD",16,8994)
|
---|
162 | 8994;16;1;;;;;;;RPCDEL^XPDIA1
|
---|
163 | "ORD",16,8994,0)
|
---|
164 | REMOTE PROCEDURE
|
---|
165 | "QUES","XPF1",0)
|
---|
166 | Y
|
---|
167 | "QUES","XPF1","??")
|
---|
168 | ^D REP^XPDH
|
---|
169 | "QUES","XPF1","A")
|
---|
170 | Shall I write over your |FLAG| File
|
---|
171 | "QUES","XPF1","B")
|
---|
172 | YES
|
---|
173 | "QUES","XPF1","M")
|
---|
174 | D XPF1^XPDIQ
|
---|
175 | "QUES","XPF2",0)
|
---|
176 | Y
|
---|
177 | "QUES","XPF2","??")
|
---|
178 | ^D DTA^XPDH
|
---|
179 | "QUES","XPF2","A")
|
---|
180 | Want my data |FLAG| yours
|
---|
181 | "QUES","XPF2","B")
|
---|
182 | YES
|
---|
183 | "QUES","XPF2","M")
|
---|
184 | D XPF2^XPDIQ
|
---|
185 | "QUES","XPI1",0)
|
---|
186 | YO
|
---|
187 | "QUES","XPI1","??")
|
---|
188 | ^D INHIBIT^XPDH
|
---|
189 | "QUES","XPI1","A")
|
---|
190 | Want KIDS to INHIBIT LOGONs during the install
|
---|
191 | "QUES","XPI1","B")
|
---|
192 | NO
|
---|
193 | "QUES","XPI1","M")
|
---|
194 | D XPI1^XPDIQ
|
---|
195 | "QUES","XPM1",0)
|
---|
196 | PO^VA(200,:EM
|
---|
197 | "QUES","XPM1","??")
|
---|
198 | ^D MG^XPDH
|
---|
199 | "QUES","XPM1","A")
|
---|
200 | Enter the Coordinator for Mail Group '|FLAG|'
|
---|
201 | "QUES","XPM1","B")
|
---|
202 |
|
---|
203 | "QUES","XPM1","M")
|
---|
204 | D XPM1^XPDIQ
|
---|
205 | "QUES","XPO1",0)
|
---|
206 | Y
|
---|
207 | "QUES","XPO1","??")
|
---|
208 | ^D MENU^XPDH
|
---|
209 | "QUES","XPO1","A")
|
---|
210 | Want KIDS to Rebuild Menu Trees Upon Completion of Install
|
---|
211 | "QUES","XPO1","B")
|
---|
212 | NO
|
---|
213 | "QUES","XPO1","M")
|
---|
214 | D XPO1^XPDIQ
|
---|
215 | "QUES","XPZ1",0)
|
---|
216 | Y
|
---|
217 | "QUES","XPZ1","??")
|
---|
218 | ^D OPT^XPDH
|
---|
219 | "QUES","XPZ1","A")
|
---|
220 | Want to DISABLE Scheduled Options, Menu Options, and Protocols
|
---|
221 | "QUES","XPZ1","B")
|
---|
222 | NO
|
---|
223 | "QUES","XPZ1","M")
|
---|
224 | D XPZ1^XPDIQ
|
---|
225 | "QUES","XPZ2",0)
|
---|
226 | Y
|
---|
227 | "QUES","XPZ2","??")
|
---|
228 | ^D RTN^XPDH
|
---|
229 | "QUES","XPZ2","A")
|
---|
230 | Want to MOVE routines to other CPUs
|
---|
231 | "QUES","XPZ2","B")
|
---|
232 | NO
|
---|
233 | "QUES","XPZ2","M")
|
---|
234 | D XPZ2^XPDIQ
|
---|
235 | "RTN")
|
---|
236 | 4
|
---|
237 | "RTN","VWREGIT")
|
---|
238 | 0^8^B129809193
|
---|
239 | "RTN","VWREGIT",1,0)
|
---|
240 | VWREGIT ;VWEHR/BFProd - Jim Bell, et al... - World VistA Patient Registration Utility
|
---|
241 | "RTN","VWREGIT",2,0)
|
---|
242 | ;;1.0;WORLD VISTA;** **;;Build 1
|
---|
243 | "RTN","VWREGIT",3,0)
|
---|
244 | ;
|
---|
245 | "RTN","VWREGIT",4,0)
|
---|
246 | ;This routine utility is for Patient specific fields and
|
---|
247 | "RTN","VWREGIT",5,0)
|
---|
248 | ; calls a Fileman input template.
|
---|
249 | "RTN","VWREGIT",6,0)
|
---|
250 | ;
|
---|
251 | "RTN","VWREGIT",7,0)
|
---|
252 | ;GNU License: See WVLIC.txt
|
---|
253 | "RTN","VWREGIT",8,0)
|
---|
254 | ;Modified FOIA VISTA,
|
---|
255 | "RTN","VWREGIT",9,0)
|
---|
256 | ;Copyright 2013 WorldVistA. Licensed under the terms of the GNU
|
---|
257 | "RTN","VWREGIT",10,0)
|
---|
258 | Q
|
---|
259 | "RTN","VWREGIT",11,0)
|
---|
260 | ;
|
---|
261 | "RTN","VWREGIT",12,0)
|
---|
262 | ;S IDSTR="REG(1733)^^L^^"
|
---|
263 | "RTN","VWREGIT",13,0)
|
---|
264 | ;
|
---|
265 | "RTN","VWREGIT",14,0)
|
---|
266 | MV(PAT,SUBD,FLDS) ;Get the listing of multiple values in external format
|
---|
267 | "RTN","VWREGIT",15,0)
|
---|
268 | S VAL=""
|
---|
269 | "RTN","VWREGIT",16,0)
|
---|
270 | Q
|
---|
271 | "RTN","VWREGIT",17,0)
|
---|
272 | ;
|
---|
273 | "RTN","VWREGIT",18,0)
|
---|
274 | GDOBT(PATIENT) ;Get date of birth with time
|
---|
275 | "RTN","VWREGIT",19,0)
|
---|
276 | N DOB,Y
|
---|
277 | "RTN","VWREGIT",20,0)
|
---|
278 | S Y=$P(^DPT(PATIENT,0),"^",3)+$G(^DPT(PATIENT,540000))
|
---|
279 | "RTN","VWREGIT",21,0)
|
---|
280 | X ^DD("DD")
|
---|
281 | "RTN","VWREGIT",22,0)
|
---|
282 | Q Y
|
---|
283 | "RTN","VWREGIT",23,0)
|
---|
284 | ;
|
---|
285 | "RTN","VWREGIT",24,0)
|
---|
286 | MM ;Mis-match IDs belong to someone other than client input
|
---|
287 | "RTN","VWREGIT",25,0)
|
---|
288 | S RESULT(0)="MM^-1"
|
---|
289 | "RTN","VWREGIT",26,0)
|
---|
290 | S RESULT(1)="ID belongs to "_ARR("DILIST",1,1)
|
---|
291 | "RTN","VWREGIT",27,0)
|
---|
292 | Q
|
---|
293 | "RTN","VWREGIT",28,0)
|
---|
294 | ;
|
---|
295 | "RTN","VWREGIT",29,0)
|
---|
296 | FIELDS ;Get field numbers/labels/titles at ^DIE(TNUM...
|
---|
297 | "RTN","VWREGIT",30,0)
|
---|
298 | K XR
|
---|
299 | "RTN","VWREGIT",31,0)
|
---|
300 | S RESULT($$INR)="[FLDS]"
|
---|
301 | "RTN","VWREGIT",32,0)
|
---|
302 | S FSET=$G(^DIE(TNUM,"DR",1,2))
|
---|
303 | "RTN","VWREGIT",33,0)
|
---|
304 | S C=0 ;Keep order of template
|
---|
305 | "RTN","VWREGIT",34,0)
|
---|
306 | F I=1:1:$L(FSET,";")-1 D
|
---|
307 | "RTN","VWREGIT",35,0)
|
---|
308 | . S MF=+$P(^DD(XFILE,+$P(FSET,";",I),0),"^",2)
|
---|
309 | "RTN","VWREGIT",36,0)
|
---|
310 | . D:MF
|
---|
311 | "RTN","VWREGIT",37,0)
|
---|
312 | .. S MFS=$G(^DIE(TNUM,"DR",2,MF))
|
---|
313 | "RTN","VWREGIT",38,0)
|
---|
314 | .. I $L(MFS) F J=1:1:$L(MFS,";")-1 D
|
---|
315 | "RTN","VWREGIT",39,0)
|
---|
316 | ... S C=C+1
|
---|
317 | "RTN","VWREGIT",40,0)
|
---|
318 | ... S XR(C,MF,+$P(MFS,";",J))=$P(^DD(MF,+$P(MFS,";",J),0),"^")_"^"_MF_";"_+$P(MFS,";",J)_"^^^"
|
---|
319 | "RTN","VWREGIT",41,0)
|
---|
320 | ... I $P(^DD(MF,+$P(MFS,";",J),0),"^",2)["P" S $P(XR(C,MF,+$P(MFS,";",J)),"^",5)=$P(^DD(MF,+$P(MFS,";",J),0),"^",3)
|
---|
321 | "RTN","VWREGIT",42,0)
|
---|
322 | . Q:MF
|
---|
323 | "RTN","VWREGIT",43,0)
|
---|
324 | . S C=C+1,XR(C,+$P(FSET,";",I))=$P(^DD(XFILE,+$P(FSET,";",I),0),"^")_"^"_+$P(FSET,";",I)_"^^"_$$HINT(XFILE,+$P(FSET,";",I))_"^"_$P(^DD(XFILE,+$P(FSET,";",I),0),"^",3)
|
---|
325 | "RTN","VWREGIT",44,0)
|
---|
326 | S X="XR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X
|
---|
327 | "RTN","VWREGIT",45,0)
|
---|
328 | ;For county help listing until DB is fixed /jeb 9/15/2013 @ 08:43
|
---|
329 | "RTN","VWREGIT",46,0)
|
---|
330 | S N=0 F S N=$O(RESULT(N)) Q:'+N I $P(RESULT(N),"^",2)=.117 S $P(RESULT(N),"^",5)="VIC(5.1,"
|
---|
331 | "RTN","VWREGIT",47,0)
|
---|
332 | K XR
|
---|
333 | "RTN","VWREGIT",48,0)
|
---|
334 | S DIET=TNUM D GET^DIETED("AR"),PREFLAB^VWREGIT3
|
---|
335 | "RTN","VWREGIT",49,0)
|
---|
336 | Q
|
---|
337 | "RTN","VWREGIT",50,0)
|
---|
338 | ;
|
---|
339 | "RTN","VWREGIT",51,0)
|
---|
340 | GETTD(RESULT,XDESC) ;Get template description
|
---|
341 | "RTN","VWREGIT",52,0)
|
---|
342 | K RESULT
|
---|
343 | "RTN","VWREGIT",53,0)
|
---|
344 | N N,TNUM
|
---|
345 | "RTN","VWREGIT",54,0)
|
---|
346 | S TNUM=+$P(XDESC,"(",2)
|
---|
347 | "RTN","VWREGIT",55,0)
|
---|
348 | I '$O(^DIE(TNUM,"%D",0)) S RESULT(0)="No description on file" Q
|
---|
349 | "RTN","VWREGIT",56,0)
|
---|
350 | S N=0 F S N=$O(^DIE(TNUM,"%D",N)) Q:'+N S RESULT($$INR)=^(N,0)
|
---|
351 | "RTN","VWREGIT",57,0)
|
---|
352 | Q
|
---|
353 | "RTN","VWREGIT",58,0)
|
---|
354 | ;
|
---|
355 | "RTN","VWREGIT",59,0)
|
---|
356 | ME(X) ;mail to group
|
---|
357 | "RTN","VWREGIT",60,0)
|
---|
358 | S GROUP=$O(^XMB(3.8,"B","VW REG ERROR REPORT",0))
|
---|
359 | "RTN","VWREGIT",61,0)
|
---|
360 | S TITLE=X
|
---|
361 | "RTN","VWREGIT",62,0)
|
---|
362 | S INFO=1
|
---|
363 | "RTN","VWREGIT",63,0)
|
---|
364 | S FM=DUZ
|
---|
365 | "RTN","VWREGIT",64,0)
|
---|
366 | D MSG^BFPMAIL
|
---|
367 | "RTN","VWREGIT",65,0)
|
---|
368 | Q
|
---|
369 | "RTN","VWREGIT",66,0)
|
---|
370 | ;
|
---|
371 | "RTN","VWREGIT",67,0)
|
---|
372 | COUNTY ;Special listing for county (re: Saturday 9/14/2013 WV discussion)
|
---|
373 | "RTN","VWREGIT",68,0)
|
---|
374 | K RESULT,XR
|
---|
375 | "RTN","VWREGIT",69,0)
|
---|
376 | S RESULT(0)=0
|
---|
377 | "RTN","VWREGIT",70,0)
|
---|
378 | S PFILE="^"_PFILE
|
---|
379 | "RTN","VWREGIT",71,0)
|
---|
380 | S N=0 F S N=$O(@(PFILE_N_")")) Q:'+N S X=^(N,0) D
|
---|
381 | "RTN","VWREGIT",72,0)
|
---|
382 | . S STATE=$P(X,"^",2)
|
---|
383 | "RTN","VWREGIT",73,0)
|
---|
384 | . S COUNTY=$P(X,"^")
|
---|
385 | "RTN","VWREGIT",74,0)
|
---|
386 | . S STATE=$P($G(^DIC(5,STATE,0)),"^")
|
---|
387 | "RTN","VWREGIT",75,0)
|
---|
388 | . S STATE=$S(STATE="":"UNKNOWN",1:STATE)
|
---|
389 | "RTN","VWREGIT",76,0)
|
---|
390 | . S XR(STATE,COUNTY)=COUNTY_"~"_STATE
|
---|
391 | "RTN","VWREGIT",77,0)
|
---|
392 | S X="XR" F S X=$Q(@X) Q:X="" S Y=@X,RESULT($$INR)=Y
|
---|
393 | "RTN","VWREGIT",78,0)
|
---|
394 | S RESULT(0)=$O(RESULT(" "),-1)_" Items:"
|
---|
395 | "RTN","VWREGIT",79,0)
|
---|
396 | K XR
|
---|
397 | "RTN","VWREGIT",80,0)
|
---|
398 | Q
|
---|
399 | "RTN","VWREGIT",81,0)
|
---|
400 | ;
|
---|
401 | "RTN","VWREGIT",82,0)
|
---|
402 | PSF(RESULT,XLINE) ;Pointer/Set of Codes values
|
---|
403 | "RTN","VWREGIT",83,0)
|
---|
404 | ;W " ;Intentionally "instantiated" hard failure - jeb
|
---|
405 | "RTN","VWREGIT",84,0)
|
---|
406 | K RESULT
|
---|
407 | "RTN","VWREGIT",85,0)
|
---|
408 | N XFILE,XFIELD,XDATA,XIT,PFILE
|
---|
409 | "RTN","VWREGIT",86,0)
|
---|
410 | S RESULT(0)=0
|
---|
411 | "RTN","VWREGIT",87,0)
|
---|
412 | S DFN=$P(XLINE,"^",7)
|
---|
413 | "RTN","VWREGIT",88,0)
|
---|
414 | S PFILE=$P(XLINE,"^",6) ;POINTED TO FILE
|
---|
415 | "RTN","VWREGIT",89,0)
|
---|
416 | I PFILE="VIC(5.1," D COUNTY Q ;Work around until DB is fixed /jeb 9/15/2013
|
---|
417 | "RTN","VWREGIT",90,0)
|
---|
418 | S XIT=+$P(XLINE,"(",2) Q:'XIT
|
---|
419 | "RTN","VWREGIT",91,0)
|
---|
420 | S XFILE=$S($P(XLINE,"^",3)[";":$P($P(XLINE,"^",3),";"),1:$P(^DIE(XIT,0),"^",4))
|
---|
421 | "RTN","VWREGIT",92,0)
|
---|
422 | S XFIELD=$S($P(XLINE,"^",3)[";":$P($P(XLINE,"^",3),";",2),1:$P(XLINE,"^",3))
|
---|
423 | "RTN","VWREGIT",93,0)
|
---|
424 | S XFIELD=$S($L(XFIELD):XFIELD,1:+$P(XLINE,"^",3)) Q:'XFIELD
|
---|
425 | "RTN","VWREGIT",94,0)
|
---|
426 | Q:$P(^DD(XFILE,XFIELD,0),"^",2)'["S"&($P(^DD(XFILE,XFIELD,0),"^",2)'["P")
|
---|
427 | "RTN","VWREGIT",95,0)
|
---|
428 | I $P(^DD(XFILE,XFIELD,0),"^",2)["S" D S RESULT(0)=$O(RESULT(" "),-1) Q
|
---|
429 | "RTN","VWREGIT",96,0)
|
---|
430 | . S XDATA=$P(^(0),"^",3)
|
---|
431 | "RTN","VWREGIT",97,0)
|
---|
432 | . S XDATA=$E(XDATA,1,$L(XDATA)-1)
|
---|
433 | "RTN","VWREGIT",98,0)
|
---|
434 | . F I=1:1:$L(XDATA,";") S RESULT($$INR)=$P($P(XDATA,";",I),":",2)
|
---|
435 | "RTN","VWREGIT",99,0)
|
---|
436 | Q:'$L(PFILE) ;No pointer to reference
|
---|
437 | "RTN","VWREGIT",100,0)
|
---|
438 | S PFILE="^"_PFILE
|
---|
439 | "RTN","VWREGIT",101,0)
|
---|
440 | S N=0 F S N=$O(@(PFILE_N_")")) Q:'+N S RESULT($$INR)=$S(PFILE[779.004:$P(^(N,0),"^")_"~"_$P(^(0),"^",2),1:$P(^(N,0),"^"))
|
---|
441 | "RTN","VWREGIT",102,0)
|
---|
442 | S RESULT(0)=$O(RESULT(" "),-1)_" Items:"
|
---|
443 | "RTN","VWREGIT",103,0)
|
---|
444 | Q
|
---|
445 | "RTN","VWREGIT",104,0)
|
---|
446 | ;
|
---|
447 | "RTN","VWREGIT",105,0)
|
---|
448 | HINT(FILE,FLD) ;
|
---|
449 | "RTN","VWREGIT",106,0)
|
---|
450 | N X,N,Y
|
---|
451 | "RTN","VWREGIT",107,0)
|
---|
452 | Q:'$L(FLD) ;...hmmmm...
|
---|
453 | "RTN","VWREGIT",108,0)
|
---|
454 | S X="",N=0 F S N=$O(^DD(FILE,FLD,21,N)) Q:'+N D
|
---|
455 | "RTN","VWREGIT",109,0)
|
---|
456 | . S Y=$G(^DD(FILE,FLD,21,N,0))_$S($O(^DD(FILE,FLD,21,N)):" ",1:"")
|
---|
457 | "RTN","VWREGIT",110,0)
|
---|
458 | . S X=X_$TR(Y,"'","")
|
---|
459 | "RTN","VWREGIT",111,0)
|
---|
460 | I X="" S X="<No hint for this field. Press the ? at the top of the form for full demographic data>"
|
---|
461 | "RTN","VWREGIT",112,0)
|
---|
462 | Q X
|
---|
463 | "RTN","VWREGIT",113,0)
|
---|
464 | ;
|
---|
465 | "RTN","VWREGIT",114,0)
|
---|
466 | GETMULTS(MN) ;
|
---|
467 | "RTN","VWREGIT",115,0)
|
---|
468 | Q:'MN
|
---|
469 | "RTN","VWREGIT",116,0)
|
---|
470 | F I=1:1:$L(FSETM(MN),";")-1 D
|
---|
471 | "RTN","VWREGIT",117,0)
|
---|
472 | . S MNF=$P(FSETM(MN),";",I)
|
---|
473 | "RTN","VWREGIT",118,0)
|
---|
474 | . S RESULT($$INR)=$P(^DD(MN,MNF,0),"^")_"^"_MN_";"_MNF
|
---|
475 | "RTN","VWREGIT",119,0)
|
---|
476 | Q
|
---|
477 | "RTN","VWREGIT",120,0)
|
---|
478 | ;
|
---|
479 | "RTN","VWREGIT",121,0)
|
---|
480 | VPAR(SUBD) ;
|
---|
481 | "RTN","VWREGIT",122,0)
|
---|
482 | N X
|
---|
483 | "RTN","VWREGIT",123,0)
|
---|
484 | S X=""
|
---|
485 | "RTN","VWREGIT",124,0)
|
---|
486 | I $D(PAR(SUBD)) S X=@$Q(PAR(SUBD))
|
---|
487 | "RTN","VWREGIT",125,0)
|
---|
488 | Q X
|
---|
489 | "RTN","VWREGIT",126,0)
|
---|
490 | ;
|
---|
491 | "RTN","VWREGIT",127,0)
|
---|
492 | INC(C) Q C=C+1
|
---|
493 | "RTN","VWREGIT",128,0)
|
---|
494 | ;
|
---|
495 | "RTN","VWREGIT",129,0)
|
---|
496 | INR() Q $O(RESULT(" "),-1)+1
|
---|
497 | "RTN","VWREGIT",130,0)
|
---|
498 | ;
|
---|
499 | "RTN","VWREGIT",131,0)
|
---|
500 | CLNNUM(NUM) ;Clean NUM
|
---|
501 | "RTN","VWREGIT",132,0)
|
---|
502 | Q $TR(NUM," -^/~|\[]{}@!#$%&*()-_=+';:<>,.?")
|
---|
503 | "RTN","VWREGIT",133,0)
|
---|
504 | ;
|
---|
505 | "RTN","VWREGIT",134,0)
|
---|
506 | ALABEL(FL,FI) ;
|
---|
507 | "RTN","VWREGIT",135,0)
|
---|
508 | Q $S($D(^DIE(TNUM,"DIAB",FL,0,FI,0)):$TR($P(^(0),";",2),"""",""),1:$P(^DD(FI,$P(FSET,";",FL),0),"^"))
|
---|
509 | "RTN","VWREGIT",136,0)
|
---|
510 | ;
|
---|
511 | "RTN","VWREGIT",137,0)
|
---|
512 | SETMULTS ;
|
---|
513 | "RTN","VWREGIT",138,0)
|
---|
514 | K FSETM
|
---|
515 | "RTN","VWREGIT",139,0)
|
---|
516 | S FSET=$g(^DIE(TNUM,"DR",1,2))
|
---|
517 | "RTN","VWREGIT",140,0)
|
---|
518 | Q:FSET=""
|
---|
519 | "RTN","VWREGIT",141,0)
|
---|
520 | ;S N=1 F S N=$O(^DIE(TNUM,"DR",N)) Q:'+N S N1=0 F S N1=$O(^DIE(TNUM,"DR",N,N1)) Q:'+N1 S FSETM(N1)=$E(^(N1),1,$L(^(N1))-1)
|
---|
521 | "RTN","VWREGIT",142,0)
|
---|
522 | S N=0 F S N=$O(^DIE(TNUM,"DR",2,N)) Q:'+N S X=^(N) S:$E(X,$L(X))=";" X=$E(X,1,$L(X)-1) S FSETM(N)=X
|
---|
523 | "RTN","VWREGIT",143,0)
|
---|
524 | ;S FSET=$E(FSET,1,$L(FSET)-1)
|
---|
525 | "RTN","VWREGIT",144,0)
|
---|
526 | F I=1:1:$L(FSET,";") S XF=$P(FSET,";",I) D
|
---|
527 | "RTN","VWREGIT",145,0)
|
---|
528 | . S FSETNUM(+XF)=$P(^DD(XFILE,+XF,0),"^")_"^"_$TR($P($G(^DIE(TNUM,"DIAB",I,0,XFILE,0)),";",2),"""","")
|
---|
529 | "RTN","VWREGIT",146,0)
|
---|
530 | . I +$P(^DD(2,+XF,0),"^",2) S $P(FSETNUM(+XF),"^",2)=+$P(^(0),"^",2)
|
---|
531 | "RTN","VWREGIT",147,0)
|
---|
532 | S N=0 F S N=$O(FSETNUM(N)) Q:'+N S FSETMAT($P(FSETNUM(N),"^"))=""
|
---|
533 | "RTN","VWREGIT",148,0)
|
---|
534 | S N=0 F S N=$O(FSETM(N)) Q:'+N S FSTRING=FSETM(N) D
|
---|
535 | "RTN","VWREGIT",149,0)
|
---|
536 | . F I=1:1:$L(FSTRING,";") S MF=$P(FSTRING,";",I),FSETMM(N,$P(^DD(N,MF,0),"^"))=""
|
---|
537 | "RTN","VWREGIT",150,0)
|
---|
538 | Q
|
---|
539 | "RTN","VWREGIT",151,0)
|
---|
540 | ;
|
---|
541 | "RTN","VWREGIT",152,0)
|
---|
542 | PID(DFN,TID,XID) ;Patient ID
|
---|
543 | "RTN","VWREGIT",153,0)
|
---|
544 | N C,XHRN
|
---|
545 | "RTN","VWREGIT",154,0)
|
---|
546 | K PAR
|
---|
547 | "RTN","VWREGIT",155,0)
|
---|
548 | D FIND^DIC(XFILE,"",".01;.02;.03;.09;.363;391","CM",$S($G(DFN):"`"_DFN,1:$G(XID)),"","B^AVWPID^SSN","","","ARR","LUERR")
|
---|
549 | "RTN","VWREGIT",156,0)
|
---|
550 | I '$O(ARR("DILIST",0)) S RESULT(1)="-1^NEW" Q
|
---|
551 | "RTN","VWREGIT",157,0)
|
---|
552 | PIDS I '$O(ARR("DILIST",2,1)) D Q
|
---|
553 | "RTN","VWREGIT",158,0)
|
---|
554 | . S:'DFN DFN=$G(ARR("DILIST",2,1)) D RECALL^DILFD(2,DFN_",",DUZ)
|
---|
555 | "RTN","VWREGIT",159,0)
|
---|
556 | . S NAME=$G(ARR("DILIST",1,1))
|
---|
557 | "RTN","VWREGIT",160,0)
|
---|
558 | . S XSSN=$G(ARR("DILIST","ID",1,.09)) D:'$L(XSSN)
|
---|
559 | "RTN","VWREGIT",161,0)
|
---|
560 | .. S DA=DFN
|
---|
561 | "RTN","VWREGIT",162,0)
|
---|
562 | .. D PSEU^DGRPDD1
|
---|
563 | "RTN","VWREGIT",163,0)
|
---|
564 | .. S (XSSN,$P(^DPT(DFN,0),"^",9))=L,^DPT("SSN",L,DFN)=""
|
---|
565 | "RTN","VWREGIT",164,0)
|
---|
566 | . ;S DOB=$G(ARR("DILIST","ID",1,.03))
|
---|
567 | "RTN","VWREGIT",165,0)
|
---|
568 | . S DOB=$$GDOBT(DFN)
|
---|
569 | "RTN","VWREGIT",166,0)
|
---|
570 | . S SEX=$E($G(ARR("DILIST","ID",1,.02)))
|
---|
571 | "RTN","VWREGIT",167,0)
|
---|
572 | . S XID=$G(ARR("DILIST","ID",1,.363))
|
---|
573 | "RTN","VWREGIT",168,0)
|
---|
574 | . I '$L($G(XHRN)),TID="HRN" S XHRN=$P($G(^AUPNPAT(DFN,41,1,0)),"^",2)
|
---|
575 | "RTN","VWREGIT",169,0)
|
---|
576 | . ;D GETS^DIQ(XFILE,DFN_",",FSET,"NIER","PAR","ERR") ;unused code
|
---|
577 | "RTN","VWREGIT",170,0)
|
---|
578 | . ;Note: "**" used to gain all fields in multiples in the file - shotgun technique .vs focused/jeb 2013
|
---|
579 | "RTN","VWREGIT",171,0)
|
---|
580 | . D GETS^DIQ(XFILE,DFN_",","**","NIER","PAR","ERR")
|
---|
581 | "RTN","VWREGIT",172,0)
|
---|
582 | . D:$D(PAR(2,DFN_",","COUNTY","I"))
|
---|
583 | "RTN","VWREGIT",173,0)
|
---|
584 | .. S COUNTY=$G(PAR(2,DFN_",","COUNTY","I")),STATE=$G(PAR(2,DFN_",","STATE","I"))
|
---|
585 | "RTN","VWREGIT",174,0)
|
---|
586 | .. I STATE S PAR(2,DFN_",","COUNTY","E")=$P(^DIC(5,STATE,1,COUNTY,0),"^")
|
---|
587 | "RTN","VWREGIT",175,0)
|
---|
588 | . S RESULT($$INR)=DFN_"^"_XID_"^"_$P(NAME,",",2)_"^"_$P(NAME,",")_"^"_DOB_"^"_$E(SEX)_"^"_$G(^DPT(DFN,.1))_$S($L($G(^DPT(DFN,.101))):" in room-bed "_^(.101),1:"")
|
---|
589 | "RTN","VWREGIT",176,0)
|
---|
590 | . D FIELDS
|
---|
591 | "RTN","VWREGIT",177,0)
|
---|
592 | . S N=2 F S N=$O(RESULT(N)) Q:'+N S F=$P(RESULT(N),"^",2) I $D(FSETNUM(F)),$L($P(FSETNUM(F),"^",2)) S $P(RESULT(N),"^")=$P(FSETNUM(F),"^",2)
|
---|
593 | "RTN","VWREGIT",178,0)
|
---|
594 | . S N=2 F S N=$O(RESULT(N)) Q:'+N D
|
---|
595 | "RTN","VWREGIT",179,0)
|
---|
596 | .. S F=$P(RESULT(N),"^")
|
---|
597 | "RTN","VWREGIT",180,0)
|
---|
598 | .. S FDATA=$G(PAR(XFILE,DFN_",",F,"E"))
|
---|
599 | "RTN","VWREGIT",181,0)
|
---|
600 | .. S $P(RESULT(N),"^",3)=FDATA
|
---|
601 | "RTN","VWREGIT",182,0)
|
---|
602 | .. S $P(RESULT(N),"^",4)=$$HINT(XFILE,$P(RESULT(N),"^",2))
|
---|
603 | "RTN","VWREGIT",183,0)
|
---|
604 | . S N=2 F S N=$O(RESULT(N)) Q:'+N D:+RESULT(N)
|
---|
605 | "RTN","VWREGIT",184,0)
|
---|
606 | .. S SN=+RESULT(N) Q:'$D(FSETM(SN))
|
---|
607 | "RTN","VWREGIT",185,0)
|
---|
608 | .. S SNFLDS=FSETM(SN)
|
---|
609 | "RTN","VWREGIT",186,0)
|
---|
610 | .. S IX=.1
|
---|
611 | "RTN","VWREGIT",187,0)
|
---|
612 | .. F I=1:1:$L(SNFLDS,";") S SNFN=$P(SNFLDS,";",I) S:SNFN RESULT(N+IX)=$P(^DD(SN,SNFN,0),"^")_"^"_SN_";"_SNFN_"^"_$$VPAR(SN)_"^^",IX=IX+.1
|
---|
613 | "RTN","VWREGIT",188,0)
|
---|
614 | . S N=2 F S N=$O(RESULT(N)) Q:'+N K:+RESULT(N) RESULT(N)
|
---|
615 | "RTN","VWREGIT",189,0)
|
---|
616 | . S N=2 F S N=$O(RESULT(N)) Q:'+N D
|
---|
617 | "RTN","VWREGIT",190,0)
|
---|
618 | .. I $P(RESULT(N),"^",4)="" S $P(RESULT(N),"^",4)="<No Hint>"
|
---|
619 | "RTN","VWREGIT",191,0)
|
---|
620 | .. I $P(RESULT(N),"^",2)[";",$P($P(RESULT(N),"^",2),";")=2.101,+$P(RESULT(N),";",2)=.01,'$L($G(^DPT(DFN,.1))) S $P(RESULT(N),"^",3)=$$MV(DFN,$P($P(RESULT(N),"^",2),";"),$G(^DIE(TNUM,"DR",2,$P($P(RESULT(N),"^",2),";"))
|
---|
621 | "RTN","VWREGIT",192,0)
|
---|
622 | . S MATCH=1,$P(RESULT(0),"^",2)=1
|
---|
623 | "RTN","VWREGIT",193,0)
|
---|
624 | ;Below - list of possibles found
|
---|
625 | "RTN","VWREGIT",194,0)
|
---|
626 | PIDM S (C,N)=0 F S N=$O(ARR("DILIST",1,N)) Q:'+N D
|
---|
627 | "RTN","VWREGIT",195,0)
|
---|
628 | . S DFN=ARR("DILIST",2,N),C=C+1
|
---|
629 | "RTN","VWREGIT",196,0)
|
---|
630 | . S XID=$P($G(^DPT(DFN,.36)),"^",3)
|
---|
631 | "RTN","VWREGIT",197,0)
|
---|
632 | . S XSSN=ARR("DILIST","ID",N,.09)
|
---|
633 | "RTN","VWREGIT",198,0)
|
---|
634 | . S XHRN=$P($G(^AUPNPAT(DFN,41,1,0)),"^",2)
|
---|
635 | "RTN","VWREGIT",199,0)
|
---|
636 | . S XNAME=ARR("DILIST",1,N)
|
---|
637 | "RTN","VWREGIT",200,0)
|
---|
638 | . S XDOB=ARR("DILIST","ID",N,.03)
|
---|
639 | "RTN","VWREGIT",201,0)
|
---|
640 | . S XID=$S($L(XID):XID,$L(XSSN):XSSN,1:"")
|
---|
641 | "RTN","VWREGIT",202,0)
|
---|
642 | . S RESULT($$INR)=$S($L(XID):XID,1:$L(XHRN),1:"")_"~"_XNAME_"~"_XDOB_"~"_$P(^DPT(DFN,0),"^",2)_"~"_DFN
|
---|
643 | "RTN","VWREGIT",203,0)
|
---|
644 | . S $P(RESULT(0),"^",2)=C
|
---|
645 | "RTN","VWREGIT",204,0)
|
---|
646 | Q
|
---|
647 | "RTN","VWREGIT",205,0)
|
---|
648 | ;
|
---|
649 | "RTN","VWREGIT",206,0)
|
---|
650 | EN(RESULT) ;Template name and ID labels
|
---|
651 | "RTN","VWREGIT",207,0)
|
---|
652 | ;Parse stuff into Fileman-ese
|
---|
653 | "RTN","VWREGIT",208,0)
|
---|
654 | ;Testing - D EN^VWREGIT(.RESULT,"REG(1767)^^LEMON^^")
|
---|
655 | "RTN","VWREGIT",209,0)
|
---|
656 | ;;M ^TMP("IDSTR",1)=IDSTR
|
---|
657 | "RTN","VWREGIT",210,0)
|
---|
658 | ;;S RESULT(0)="[ID]"
|
---|
659 | "RTN","VWREGIT",211,0)
|
---|
660 | ;;S RESULT(1)="-1^NEW"
|
---|
661 | "RTN","VWREGIT",212,0)
|
---|
662 | ;;Q
|
---|
663 | "RTN","VWREGIT",213,0)
|
---|
664 | ;end testing
|
---|
665 | "RTN","VWREGIT",214,0)
|
---|
666 | ;
|
---|
667 | "RTN","VWREGIT",215,0)
|
---|
668 | ;Get the input template list
|
---|
669 | "RTN","VWREGIT",216,0)
|
---|
670 | ;housekeeping
|
---|
671 | "RTN","VWREGIT",217,0)
|
---|
672 | S DTIME=99999
|
---|
673 | "RTN","VWREGIT",218,0)
|
---|
674 | ;end housekeeping
|
---|
675 | "RTN","VWREGIT",219,0)
|
---|
676 | ;
|
---|
677 | "RTN","VWREGIT",220,0)
|
---|
678 | K AR,RESULT
|
---|
679 | "RTN","VWREGIT",221,0)
|
---|
680 | N N,HD,FILE,LOC,P4,P5,%ZISHF,%ZISHO
|
---|
681 | "RTN","VWREGIT",222,0)
|
---|
682 | S RESULT(0)=$$CONTROL^VWREGIT2()
|
---|
683 | "RTN","VWREGIT",223,0)
|
---|
684 | S RESULT(1)="-1^No templates found"
|
---|
685 | "RTN","VWREGIT",224,0)
|
---|
686 | S HD=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY")
|
---|
687 | "RTN","VWREGIT",225,0)
|
---|
688 | S FILE="regit.txt"
|
---|
689 | "RTN","VWREGIT",226,0)
|
---|
690 | S P4=1
|
---|
691 | "RTN","VWREGIT",227,0)
|
---|
692 | S P5=""
|
---|
693 | "RTN","VWREGIT",228,0)
|
---|
694 | S X=$$FTG^%ZISH(HD,FILE,$NA(AR(1)),P4,P5)
|
---|
695 | "RTN","VWREGIT",229,0)
|
---|
696 | I 'X K T,TITLE D Q ;Error report - home dir not found
|
---|
697 | "RTN","VWREGIT",230,0)
|
---|
698 | . S TITLE=$P(RESULT(1),"^")
|
---|
699 | "RTN","VWREGIT",231,0)
|
---|
700 | . S T(1)="The home directory could not be located."
|
---|
701 | "RTN","VWREGIT",232,0)
|
---|
702 | . S T(2)="End of data error message"
|
---|
703 | "RTN","VWREGIT",233,0)
|
---|
704 | . D ME(X)
|
---|
705 | "RTN","VWREGIT",234,0)
|
---|
706 | . K T,X
|
---|
707 | "RTN","VWREGIT",235,0)
|
---|
708 | S:+RESULT(0) $P(RESULT(0),"^",2)=HD
|
---|
709 | "RTN","VWREGIT",236,0)
|
---|
710 | I $O(AR(0)) S RESULT(1)="[TEMPLATES]"
|
---|
711 | "RTN","VWREGIT",237,0)
|
---|
712 | S N=0 F S N=$O(AR(N)) Q:'+N D
|
---|
713 | "RTN","VWREGIT",238,0)
|
---|
714 | . Q:$E(AR(N))="*"
|
---|
715 | "RTN","VWREGIT",239,0)
|
---|
716 | . Q:'+$P(AR(N),"(",2)
|
---|
717 | "RTN","VWREGIT",240,0)
|
---|
718 | . Q:$P(^DIE(+$P(AR(N),"(",2),0),"^",4)'=2 ;must be pat file
|
---|
719 | "RTN","VWREGIT",241,0)
|
---|
720 | . S RESULT($$INR)=AR(N)
|
---|
721 | "RTN","VWREGIT",242,0)
|
---|
722 | S RESULT($$INR)="[ID]"
|
---|
723 | "RTN","VWREGIT",243,0)
|
---|
724 | S N=0 F S N=$O(RESULT(N)) Q:'+N K:RESULT(N)="" RESULT(N)
|
---|
725 | "RTN","VWREGIT",244,0)
|
---|
726 | I '$O(RESULT(0)) S RESULT(1)="-1^No PATIENT FILE templates found"
|
---|
727 | "RTN","VWREGIT",245,0)
|
---|
728 | K AR
|
---|
729 | "RTN","VWREGIT",246,0)
|
---|
730 | Q
|
---|
731 | "RTN","VWREGIT",247,0)
|
---|
732 | ;
|
---|
733 | "RTN","VWREGIT",248,0)
|
---|
734 | PAT(RESULT,IDSTR) ;
|
---|
735 | "RTN","VWREGIT",249,0)
|
---|
736 | ; **********************************************************
|
---|
737 | "RTN","VWREGIT",250,0)
|
---|
738 | ; *IDSTR____Template(IEN)^ID/HRN/SSN:ID#^NAME^DOB^GENDER *
|
---|
739 | "RTN","VWREGIT",251,0)
|
---|
740 | ; * ^NEW<-EMPTY IF NOT NEW PT *
|
---|
741 | "RTN","VWREGIT",252,0)
|
---|
742 | ; *Action___Execute patient look up first with HRN/ID, *
|
---|
743 | "RTN","VWREGIT",253,0)
|
---|
744 | ; * then NAME; DOB is confirming ID if found *
|
---|
745 | "RTN","VWREGIT",254,0)
|
---|
746 | ; * If not found RESULT(0)="-1^NEW" *
|
---|
747 | "RTN","VWREGIT",255,0)
|
---|
748 | ; **********************************************************
|
---|
749 | "RTN","VWREGIT",256,0)
|
---|
750 | ;
|
---|
751 | "RTN","VWREGIT",257,0)
|
---|
752 | N DFN,FN,FSET,J,LABEL,MATCH,N,PID,TNUM,XAID,XDOB,XF,XFILE,XFLD,XHRN,XLABEL,XNAME,XUNM,XUMOV,XUFAM,XUOUT,XUREST,XUSP
|
---|
753 | "RTN","VWREGIT",258,0)
|
---|
754 | N NAME,XDOB,SEX,FAIL,STR,TID,FAIL,TID,IEN
|
---|
755 | "RTN","VWREGIT",259,0)
|
---|
756 | K RESULT,PAR,ARR,SPAR,LUERR,ERR
|
---|
757 | "RTN","VWREGIT",260,0)
|
---|
758 | S RESULT(0)="[ID]^0"
|
---|
759 | "RTN","VWREGIT",261,0)
|
---|
760 | S TNUM=+$P(IDSTR,"(",2)
|
---|
761 | "RTN","VWREGIT",262,0)
|
---|
762 | Q:'TNUM ;No template name from client
|
---|
763 | "RTN","VWREGIT",263,0)
|
---|
764 | I '$D(^DIE(TNUM)) S RESULT(0)="-1^Template not found" G XOUT
|
---|
765 | "RTN","VWREGIT",264,0)
|
---|
766 | S XFILE=$P(^DIE(TNUM,0),"^",4)
|
---|
767 | "RTN","VWREGIT",265,0)
|
---|
768 | S MATCH=0
|
---|
769 | "RTN","VWREGIT",266,0)
|
---|
770 | S DFN=0
|
---|
771 | "RTN","VWREGIT",267,0)
|
---|
772 | ;D SETMULTS
|
---|
773 | "RTN","VWREGIT",268,0)
|
---|
774 | S XEC=$$CFDFN^VWREGIT2(IDSTR)
|
---|
775 | "RTN","VWREGIT",269,0)
|
---|
776 | I $L(XEC) D:XEC'="XOUT" @XEC G XOUT ;Found DFN(s)...
|
---|
777 | "RTN","VWREGIT",270,0)
|
---|
778 | S DFN=+$P($P(IDSTR,"^",3),"(",2)
|
---|
779 | "RTN","VWREGIT",271,0)
|
---|
780 | I 'DFN,$P(IDSTR,"^",6) D D NEWPAT,FIELDS Q
|
---|
781 | "RTN","VWREGIT",272,0)
|
---|
782 | . S TID=$P($P(IDSTR,"^",2),":"),ID=$P($P(IDSTR,"^",2),":",2)
|
---|
783 | "RTN","VWREGIT",273,0)
|
---|
784 | . K:TID="SSN" VWREG ;Allow triggers and xfrs for the USA | jeb 2013
|
---|
785 | "RTN","VWREGIT",274,0)
|
---|
786 | . S ID=$S($L(ID):$$CLNNUM(ID),1:"")
|
---|
787 | "RTN","VWREGIT",275,0)
|
---|
788 | . S NAME=$$UP^XLFSTR($P(IDSTR,"^",3))
|
---|
789 | "RTN","VWREGIT",276,0)
|
---|
790 | . S XDOB=$P(IDSTR,"^",4)
|
---|
791 | "RTN","VWREGIT",277,0)
|
---|
792 | . S GENDER=$$UP^XLFSTR($P(IDSTR,"^",5))
|
---|
793 | "RTN","VWREGIT",278,0)
|
---|
794 | . ;1901,.301,391 From Sam Habiel's UJOPTREG c 2010,2011 by permission
|
---|
795 | "RTN","VWREGIT",279,0)
|
---|
796 | . S DATA(XFILE,"+1,",1901)="NO" ; Veteran?
|
---|
797 | "RTN","VWREGIT",280,0)
|
---|
798 | . S DATA(XFILE,"+1,",.301)="NO" ; Service Connected
|
---|
799 | "RTN","VWREGIT",281,0)
|
---|
800 | . S DATA(XFILE,"+1,",391)="NON-VETERAN (OTHER)" ; Type of Patient
|
---|
801 | "RTN","VWREGIT",282,0)
|
---|
802 | . S DATA(XFILE,"+1,",.01)=NAME
|
---|
803 | "RTN","VWREGIT",283,0)
|
---|
804 | . S DATA(XFILE,"+1,",.02)=GENDER
|
---|
805 | "RTN","VWREGIT",284,0)
|
---|
806 | . S DATA(XFILE,"+1,",.03)=XDOB
|
---|
807 | "RTN","VWREGIT",285,0)
|
---|
808 | . S DATA(XFILE,"+1,",.09)=$S(TID="SSN":ID,1:"")
|
---|
809 | "RTN","VWREGIT",286,0)
|
---|
810 | . S DATA(XFILE,"+1,",.363)=ID
|
---|
811 | "RTN","VWREGIT",287,0)
|
---|
812 | . D UPDATE^DIE("E","DATA","IEN","VWERR")
|
---|
813 | "RTN","VWREGIT",288,0)
|
---|
814 | . Q:$D(VWERR)
|
---|
815 | "RTN","VWREGIT",289,0)
|
---|
816 | . S DFN=IEN(1) D RECALL^DILFD(2,DFN_",",DUZ)
|
---|
817 | "RTN","VWREGIT",290,0)
|
---|
818 | . ;Set up IHS Patient file (9000001)
|
---|
819 | "RTN","VWREGIT",291,0)
|
---|
820 | . D NOW^%DTC
|
---|
821 | "RTN","VWREGIT",292,0)
|
---|
822 | . S AUPN=IEN(1),$P(AUPN,"^",2)=X,$P(AUPN,"^",11)=DUZ,$P(AUPN,"^",12)=X
|
---|
823 | "RTN","VWREGIT",293,0)
|
---|
824 | . S ^AUPNPAT(+IEN(1))=AUPN,^AUPNPAT("B",+IEN(1),+IEN(1))=""
|
---|
825 | "RTN","VWREGIT",294,0)
|
---|
826 | . I TID="HRN",'$O(^AUPNPAT("D",+IEN(1),ID,0)) D
|
---|
827 | "RTN","VWREGIT",295,0)
|
---|
828 | .. S ^AUPNPAT(+IEN(1),41,1,0)="1^"_ID
|
---|
829 | "RTN","VWREGIT",296,0)
|
---|
830 | .. S $P(^AUPNPAT(+IEN(1),41,0),"^",3)=ID,$P(^(0),"^",4)=$P(^(0),"^",4)+1
|
---|
831 | "RTN","VWREGIT",297,0)
|
---|
832 | LAUP . L ^AUPNPAT(0):1 G LAUP:'$T D L
|
---|
833 | "RTN","VWREGIT",298,0)
|
---|
834 | .. S $P(^AUPNPAT(0),"^",3)=+IEN(1)
|
---|
835 | "RTN","VWREGIT",299,0)
|
---|
836 | .. S $P(^AUPNPAT(0),"^",4)=$P(^(0),"^",4)+1
|
---|
837 | "RTN","VWREGIT",300,0)
|
---|
838 | D PID(DFN,$P($P(IDSTR,"^",2),":"),$P($P(IDSTR,"^",2),":",2))
|
---|
839 | "RTN","VWREGIT",301,0)
|
---|
840 | ;D:'MATCH&($P(RESULT(0),"^",2)<2) FIELDS
|
---|
841 | "RTN","VWREGIT",302,0)
|
---|
842 | XOUT K PAR,ARR,ERR,SPAR,LUERR Q
|
---|
843 | "RTN","VWREGIT",303,0)
|
---|
844 | ;
|
---|
845 | "RTN","VWREGIT",304,0)
|
---|
846 | NEWPAT ;Set up new patient data return
|
---|
847 | "RTN","VWREGIT",305,0)
|
---|
848 | S $P(RESULT(0),"^",2)=1
|
---|
849 | "RTN","VWREGIT",306,0)
|
---|
850 | ;S DFN=$G(IEN(1))
|
---|
851 | "RTN","VWREGIT",307,0)
|
---|
852 | I TID'="SSN" D
|
---|
853 | "RTN","VWREGIT",308,0)
|
---|
854 | . S DA=DFN
|
---|
855 | "RTN","VWREGIT",309,0)
|
---|
856 | . D PSEU^DGRPDD1
|
---|
857 | "RTN","VWREGIT",310,0)
|
---|
858 | . S (XSSN,$P(^DPT(DFN,0),"^",9))=L,^DPT("SSN",L,DFN)=""
|
---|
859 | "RTN","VWREGIT",311,0)
|
---|
860 | S RESULT($$INR)=DFN_"^"_ID_"^"_NAME_"^"_XDOB_"^"_GENDER_"^"_$G(^DPT(DFN,.1))_$S($L($G(^DPT(DFN,.101))):" in room-bed "_^(.101),1:"N/A")
|
---|
861 | "RTN","VWREGIT",312,0)
|
---|
862 | Q
|
---|
863 | "RTN","VWREGIT",313,0)
|
---|
864 | ;
|
---|
865 | "RTN","VWREGIT2")
|
---|
866 | 0^9^B100003944
|
---|
867 | "RTN","VWREGIT2",1,0)
|
---|
868 | VWREGIT2 ;VWEHR/Jim Bell, et al... - World VistA Input Template Utility
|
---|
869 | "RTN","VWREGIT2",2,0)
|
---|
870 | ;;1.0;WORLD VISTA;** **;;Build 1
|
---|
871 | "RTN","VWREGIT2",3,0)
|
---|
872 | ;
|
---|
873 | "RTN","VWREGIT2",4,0)
|
---|
874 | ;Continued from VWREGIT
|
---|
875 | "RTN","VWREGIT2",5,0)
|
---|
876 | ;
|
---|
877 | "RTN","VWREGIT2",6,0)
|
---|
878 | ;GNU License: See WVLIC.txt
|
---|
879 | "RTN","VWREGIT2",7,0)
|
---|
880 | ;Modified FOIA VISTA,
|
---|
881 | "RTN","VWREGIT2",8,0)
|
---|
882 | ;Copyright 2013 WorldVistA. Licensed under the terms of the GNU
|
---|
883 | "RTN","VWREGIT2",9,0)
|
---|
884 | Q
|
---|
885 | "RTN","VWREGIT2",10,0)
|
---|
886 | ;
|
---|
887 | "RTN","VWREGIT2",11,0)
|
---|
888 | PI ;Post Installation install
|
---|
889 | "RTN","VWREGIT2",12,0)
|
---|
890 | ;; NOTE: The parameter definition is installed but there is no installation for
|
---|
891 | "RTN","VWREGIT2",13,0)
|
---|
892 | ;;the actual parameter and value. Do it here.
|
---|
893 | "RTN","VWREGIT2",14,0)
|
---|
894 | ;parameter value attempt
|
---|
895 | "RTN","VWREGIT2",15,0)
|
---|
896 | ;Set a home directory for editing; SYSTEM (DIC(4,) and DOMAIN (DIC(4.2,) only:"/home/vista/regparam/"
|
---|
897 | "RTN","VWREGIT2",16,0)
|
---|
898 | S PARD=$O(^XTV(8989.51,"B","VW GUI REG TEMPLATE DIRECTORY",0))
|
---|
899 | "RTN","VWREGIT2",17,0)
|
---|
900 | I PARD D
|
---|
901 | "RTN","VWREGIT2",18,0)
|
---|
902 | . L +^XTV(8989.5,0):1 D L -^XTV(8989.5,0)
|
---|
903 | "RTN","VWREGIT2",19,0)
|
---|
904 | .. S NEW=$O(^XTV(8989.5," "),-1)+1
|
---|
905 | "RTN","VWREGIT2",20,0)
|
---|
906 | .. S $P(^XTV(8989.5,0),"^",3)=NEW
|
---|
907 | "RTN","VWREGIT2",21,0)
|
---|
908 | .. S $P(^XTV(8989.5,0),"^",4)=$P(^(0),"^",4)+1
|
---|
909 | "RTN","VWREGIT2",22,0)
|
---|
910 | .. S $P(^XTV(8989.5,NEW,0),"^")="1;DIC(4,"
|
---|
911 | "RTN","VWREGIT2",23,0)
|
---|
912 | .. S $P(^XTV(8989.5,NEW,0),"^",2)=PARD
|
---|
913 | "RTN","VWREGIT2",24,0)
|
---|
914 | .. S $P(^XTV(8989.5,NEW,0),"^",3)=1
|
---|
915 | "RTN","VWREGIT2",25,0)
|
---|
916 | .. S ^XTV(8989.5,NEW,1)="/home/vista/regparam/"
|
---|
917 | "RTN","VWREGIT2",26,0)
|
---|
918 | .. S DA=NEW,DIK="^XTV(8989.5," D IX^DIK
|
---|
919 | "RTN","VWREGIT2",27,0)
|
---|
920 | .. S NEW2=$O(^XTV(8989.5," "),-1)+1
|
---|
921 | "RTN","VWREGIT2",28,0)
|
---|
922 | .. S $P(^XTV(8989.5,0),"^",3)=NEW2
|
---|
923 | "RTN","VWREGIT2",29,0)
|
---|
924 | .. S $P(^XTV(8989.5,0),"^",4)=$P(^(0),"^",4)+1
|
---|
925 | "RTN","VWREGIT2",30,0)
|
---|
926 | .. S $P(^XTV(8989.5,NEW2,0),"^")="9;DIC(4.2,"
|
---|
927 | "RTN","VWREGIT2",31,0)
|
---|
928 | .. S $P(^XTV(8989.5,NEW2,0),"^",2)=PARD
|
---|
929 | "RTN","VWREGIT2",32,0)
|
---|
930 | .. S $P(^XTV(8989.5,NEW2,0),"^",3)=1
|
---|
931 | "RTN","VWREGIT2",33,0)
|
---|
932 | .. S ^XTV(8989.5,NEW2,1)="/home/vista/regparam/"
|
---|
933 | "RTN","VWREGIT2",34,0)
|
---|
934 | .. S DA=NEW2,DIK="^XTV(8989.5," D IX^DIK
|
---|
935 | "RTN","VWREGIT2",35,0)
|
---|
936 | .. ;S ^XTV(8989.5,"AC",PARD,"1;DIC(4,",1)="/home/vista/regparam/"
|
---|
937 | "RTN","VWREGIT2",36,0)
|
---|
938 | .. ;S ^XTV(8989.5,"AC",PARD,"1;DIC(4,",1,NE)=""
|
---|
939 | "RTN","VWREGIT2",37,0)
|
---|
940 | .. ;S ^XTV(8989.5,"B","1;DIC(4,",NE)=""
|
---|
941 | "RTN","VWREGIT2",38,0)
|
---|
942 | ;
|
---|
943 | "RTN","VWREGIT2",39,0)
|
---|
944 | ;Mailgroup VW REG ERROR REPORT - add programmer's email
|
---|
945 | "RTN","VWREGIT2",40,0)
|
---|
946 | S DA(1)=$O(^XMB(3.8,"B","VW REG ERROR REPORT",0))
|
---|
947 | "RTN","VWREGIT2",41,0)
|
---|
948 | Q:'DA(1)
|
---|
949 | "RTN","VWREGIT2",42,0)
|
---|
950 | S DIC="^XMB(3.8,"_DA(1)_",6,"
|
---|
951 | "RTN","VWREGIT2",43,0)
|
---|
952 | S X="jbellco65@gmail.com"
|
---|
953 | "RTN","VWREGIT2",44,0)
|
---|
954 | S DIC(0)="LZ"
|
---|
955 | "RTN","VWREGIT2",45,0)
|
---|
956 | D FILE^DICN
|
---|
957 | "RTN","VWREGIT2",46,0)
|
---|
958 | Q
|
---|
959 | "RTN","VWREGIT2",47,0)
|
---|
960 | ;
|
---|
961 | "RTN","VWREGIT2",48,0)
|
---|
962 | ABSDFN(RESULT,IDSTR) ;Absolute DFN
|
---|
963 | "RTN","VWREGIT2",49,0)
|
---|
964 | N TNUM,DFN,XFILE
|
---|
965 | "RTN","VWREGIT2",50,0)
|
---|
966 | K ERR,RESULT,PAR,FSET,FSETMAT
|
---|
967 | "RTN","VWREGIT2",51,0)
|
---|
968 | S RESULT(0)="ID^-1"
|
---|
969 | "RTN","VWREGIT2",52,0)
|
---|
970 | S TNUM=+$P($P(IDSTR,"^"),"(",2) I 'TNUM S RESULT(1)="Template not supplied. Please retry..." Q
|
---|
971 | "RTN","VWREGIT2",53,0)
|
---|
972 | S DFN=$P(IDSTR,"^",2) I 'DFN S RESULT(1)="Patient not supplied. Please try again..." Q
|
---|
973 | "RTN","VWREGIT2",54,0)
|
---|
974 | S XFILE=$P(^DIE(TNUM,0),"^",4)
|
---|
975 | "RTN","VWREGIT2",55,0)
|
---|
976 | ;D SETMULTS^VWREGIT
|
---|
977 | "RTN","VWREGIT2",56,0)
|
---|
978 | D RECALL^DILFD(2,DFN_",",DUZ)
|
---|
979 | "RTN","VWREGIT2",57,0)
|
---|
980 | D GETS^DIQ(XFILE,DFN_",","**","NIER","PAR","ERR")
|
---|
981 | "RTN","VWREGIT2",58,0)
|
---|
982 | S $P(RESULT(0),"^",2)=1
|
---|
983 | "RTN","VWREGIT2",59,0)
|
---|
984 | S $P(RESULT(1),"^",1)=DFN
|
---|
985 | "RTN","VWREGIT2",60,0)
|
---|
986 | S $P(RESULT(1),"^",2)=$G(ARR("DILIST","ID",1,.363))
|
---|
987 | "RTN","VWREGIT2",61,0)
|
---|
988 | S $P(RESULT(1),"^",3)=$G(ARR("DILIST","ID",1,.01))
|
---|
989 | "RTN","VWREGIT2",62,0)
|
---|
990 | ;S $P(RESULT(1),"^",4)=$G(ARR("DILIST","ID",1,.03))
|
---|
991 | "RTN","VWREGIT2",63,0)
|
---|
992 | S $P(RESULT(1),"^",4)=$$GDOBT^VWREGIT(DFN)
|
---|
993 | "RTN","VWREGIT2",64,0)
|
---|
994 | S $P(RESULT(1),"^",5)=$E($G(ARR("DILIST","ID",1,.02)))
|
---|
995 | "RTN","VWREGIT2",65,0)
|
---|
996 | S $P(RESULT(1),"^",6)=$S($G(^DPT(DFN,.1)):^(.1),1:"N/A")_$S($L($G(^DPT(DFN,.101))):" in room-bed "_^(.101),1:"")
|
---|
997 | "RTN","VWREGIT2",66,0)
|
---|
998 | S $P(RESULT(1),"^",7)=$G(ARR("DILIST",1,.09))
|
---|
999 | "RTN","VWREGIT2",67,0)
|
---|
1000 | D FIELDS^VWREGIT
|
---|
1001 | "RTN","VWREGIT2",68,0)
|
---|
1002 | S N=2 F S N=$O(RESULT(N)) Q:'+N S F=$P(RESULT(N),"^",2) I $D(FSETNUM(F)),$L($P(FSETNUM(F),"^",2)) S $P(RESULT(N),"^")=$P(FSETNUM(F),"^",2)
|
---|
1003 | "RTN","VWREGIT2",69,0)
|
---|
1004 | S N=2 F S N=$O(RESULT(N)) Q:'+N D
|
---|
1005 | "RTN","VWREGIT2",70,0)
|
---|
1006 | . S F=$P(RESULT(N),"^")
|
---|
1007 | "RTN","VWREGIT2",71,0)
|
---|
1008 | . S FDATA=$G(PAR(XFILE,DFN_",",F,"E"))
|
---|
1009 | "RTN","VWREGIT2",72,0)
|
---|
1010 | . S $P(RESULT(N),"^",3)=FDATA
|
---|
1011 | "RTN","VWREGIT2",73,0)
|
---|
1012 | . S $P(RESULT(N),"^",4)=$$HINT^VWREGIT(XFILE,$P(RESULT(N),"^",2))
|
---|
1013 | "RTN","VWREGIT2",74,0)
|
---|
1014 | S N=2 F S N=$O(RESULT(N)) Q:'+N D:+RESULT(N)
|
---|
1015 | "RTN","VWREGIT2",75,0)
|
---|
1016 | . S SN=+RESULT(N) Q:'$D(FSETM(SN))
|
---|
1017 | "RTN","VWREGIT2",76,0)
|
---|
1018 | . S SNFLDS=FSETM(SN)
|
---|
1019 | "RTN","VWREGIT2",77,0)
|
---|
1020 | . S IX=.1
|
---|
1021 | "RTN","VWREGIT2",78,0)
|
---|
1022 | . F I=1:1:$L(SNFLDS,";") S SNFN=$P(SNFLDS,";",I) S:SNFN RESULT(N+IX)=$P(^DD(SN,SNFN,0),"^")_"^"_SN_";"_SNFN_"^"_$$VPAR^VWREGIT(SN)_"^^",IX=IX+.1
|
---|
1023 | "RTN","VWREGIT2",79,0)
|
---|
1024 | S N=2 F S N=$O(RESULT(N)) Q:'+N K:+RESULT(N) RESULT(N)
|
---|
1025 | "RTN","VWREGIT2",80,0)
|
---|
1026 | S N=2 F S N=$O(RESULT(N)) Q:'+N D
|
---|
1027 | "RTN","VWREGIT2",81,0)
|
---|
1028 | . I $P(RESULT(N),"^",4)="" S $P(RESULT(N),"^",4)="<No Hint>"
|
---|
1029 | "RTN","VWREGIT2",82,0)
|
---|
1030 | . I $P(RESULT(N),"^",2)[";",$P($P(RESULT(N),"^",2),";")=2.101,+$P(RESULT(N),";",2)=.01,'$L($G(^DPT(DFN,.1))) S $P(RESULT(N),"^",3)="NOW"
|
---|
1031 | "RTN","VWREGIT2",83,0)
|
---|
1032 | Q
|
---|
1033 | "RTN","VWREGIT2",84,0)
|
---|
1034 | ;
|
---|
1035 | "RTN","VWREGIT2",85,0)
|
---|
1036 | CFDFN(STRING) ;Check for a DFN
|
---|
1037 | "RTN","VWREGIT2",86,0)
|
---|
1038 | ; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
---|
1039 | "RTN","VWREGIT2",87,0)
|
---|
1040 | ; | STRING___TEMPLATE(IEN)^ID^NAME^DOB^GENDER |
|
---|
1041 | "RTN","VWREGIT2",88,0)
|
---|
1042 | ; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
---|
1043 | "RTN","VWREGIT2",89,0)
|
---|
1044 | ;
|
---|
1045 | "RTN","VWREGIT2",90,0)
|
---|
1046 | N NAME,ID
|
---|
1047 | "RTN","VWREGIT2",91,0)
|
---|
1048 | S ID=$$CLNNUM^VWREGIT($P($P(STRING,"^",2),":",2))
|
---|
1049 | "RTN","VWREGIT2",92,0)
|
---|
1050 | S TID=$P($P(STRING,"^",2),":")
|
---|
1051 | "RTN","VWREGIT2",93,0)
|
---|
1052 | I TID="HRN" S DFN=$O(^AUPNPAT("D",ID,0)) S $P(IDSTR,"^",2)=DFN D ABSDFN(.RESULT,IDSTR) Q "XOUT"
|
---|
1053 | "RTN","VWREGIT2",94,0)
|
---|
1054 | S NAME=$$UP^XLFSTR($P(STRING,"^",3))
|
---|
1055 | "RTN","VWREGIT2",95,0)
|
---|
1056 | D FIND^DIC(2,"",".01;.02;.03;.09;.363","CM",$S(+ID:ID,1:NAME),"","B^SSN^AVWPID","","","ARR","LUERR")
|
---|
1057 | "RTN","VWREGIT2",96,0)
|
---|
1058 | I '$O(ARR("DILIST",0)) Q ""
|
---|
1059 | "RTN","VWREGIT2",97,0)
|
---|
1060 | ;I '$O(ARR("DILIST",1,1)),$L(NAME),ARR("DILIST",1,1)'=NAME Q "MM"
|
---|
1061 | "RTN","VWREGIT2",98,0)
|
---|
1062 | I $O(ARR("DILIST",1,1)) Q "PIDM" ;multiple found
|
---|
1063 | "RTN","VWREGIT2",99,0)
|
---|
1064 | I '$O(ARR("DILIST",1,1)) D D ABSDFN(.RESULT,IDSTR) Q "XOUT" ;Single found
|
---|
1065 | "RTN","VWREGIT2",100,0)
|
---|
1066 | . S $P(IDSTR,"^",2)=ARR("DILIST",2,1)
|
---|
1067 | "RTN","VWREGIT2",101,0)
|
---|
1068 | Q ""
|
---|
1069 | "RTN","VWREGIT2",102,0)
|
---|
1070 | ;
|
---|
1071 | "RTN","VWREGIT2",103,0)
|
---|
1072 | ST(TN) ;Screen these templates for PATIENT FILE(#2):1,1:0
|
---|
1073 | "RTN","VWREGIT2",104,0)
|
---|
1074 | I $E($P(^DIE(TN,0),"^"))="*" Q 0
|
---|
1075 | "RTN","VWREGIT2",105,0)
|
---|
1076 | I $P(^DIE(TN,0),"^",4)'=2 Q 0
|
---|
1077 | "RTN","VWREGIT2",106,0)
|
---|
1078 | Q 1
|
---|
1079 | "RTN","VWREGIT2",107,0)
|
---|
1080 | ;
|
---|
1081 | "RTN","VWREGIT2",108,0)
|
---|
1082 | INR() Q $O(RESULT(" "),-1)+1
|
---|
1083 | "RTN","VWREGIT2",109,0)
|
---|
1084 | ;
|
---|
1085 | "RTN","VWREGIT2",110,0)
|
---|
1086 | CLNNUM(NUM) ;Clean NUM
|
---|
1087 | "RTN","VWREGIT2",111,0)
|
---|
1088 | Q $TR(NUM," -^/~|\[]{}@!#$%&*()-_=+';:<>,.?")
|
---|
1089 | "RTN","VWREGIT2",112,0)
|
---|
1090 | ;
|
---|
1091 | "RTN","VWREGIT2",113,0)
|
---|
1092 | CONTROL() ;Check for CONTROL status
|
---|
1093 | "RTN","VWREGIT2",114,0)
|
---|
1094 | N X S X=$O(^DIC(19,"B","VW REG IT CONTROL",0))
|
---|
1095 | "RTN","VWREGIT2",115,0)
|
---|
1096 | I 'X Q 0 ;Ain't no option there
|
---|
1097 | "RTN","VWREGIT2",116,0)
|
---|
1098 | Q $S($D(^VA(200,DUZ,203,"B",X)):1,1:0)
|
---|
1099 | "RTN","VWREGIT2",117,0)
|
---|
1100 | ;
|
---|
1101 | "RTN","VWREGIT2",118,0)
|
---|
1102 | GETHD(RESULT) ;Get home directory for set up
|
---|
1103 | "RTN","VWREGIT2",119,0)
|
---|
1104 | S RESULT(0)=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY")
|
---|
1105 | "RTN","VWREGIT2",120,0)
|
---|
1106 | Q
|
---|
1107 | "RTN","VWREGIT2",121,0)
|
---|
1108 | ;
|
---|
1109 | "RTN","VWREGIT2",122,0)
|
---|
1110 | SAVEHD(RESULT,NHD) ;Saves Home Directory changes to PARAMETER file
|
---|
1111 | "RTN","VWREGIT2",123,0)
|
---|
1112 | ; Called from Remote Procedure VW REG SAVE HD
|
---|
1113 | "RTN","VWREGIT2",124,0)
|
---|
1114 | ; NHD_____New Home Directory
|
---|
1115 | "RTN","VWREGIT2",125,0)
|
---|
1116 | ;
|
---|
1117 | "RTN","VWREGIT2",126,0)
|
---|
1118 | I NHD="" S RESULT(0)="-1^No data from client" Q
|
---|
1119 | "RTN","VWREGIT2",127,0)
|
---|
1120 | K RESULT,SCRATCH
|
---|
1121 | "RTN","VWREGIT2",128,0)
|
---|
1122 | N HDIEN,N
|
---|
1123 | "RTN","VWREGIT2",129,0)
|
---|
1124 | S HDIEN=$O(^XTV(8989.51,"B","VW GUI REG TEMPLATE DIRECTORY",0))
|
---|
1125 | "RTN","VWREGIT2",130,0)
|
---|
1126 | I 'HDIEN D Q
|
---|
1127 | "RTN","VWREGIT2",131,0)
|
---|
1128 | . S T(1)="Error reported from routine SAVEHD^VWREGIT:"
|
---|
1129 | "RTN","VWREGIT2",132,0)
|
---|
1130 | . S T(2)="The PARAMETER DEFINITION ""VW GUI REG TEMPLATE DIRECTORY"" was"
|
---|
1131 | "RTN","VWREGIT2",133,0)
|
---|
1132 | . S T(3)="not found."
|
---|
1133 | "RTN","VWREGIT2",134,0)
|
---|
1134 | . D ME^VWREGIT("NO PARAMETER DEFINITION")
|
---|
1135 | "RTN","VWREGIT2",135,0)
|
---|
1136 | . S RESULT(0)="-1^Error sent to VW REG mail group"
|
---|
1137 | "RTN","VWREGIT2",136,0)
|
---|
1138 | S X="^XTV(8989.5,""AC"","_HDIEN_")" F S X=$Q(@X) Q:+$P(X,",",3)'=HDIEN S:$L(X,",")>6 SCRATCH(+$P(X,",",7))=""
|
---|
1139 | "RTN","VWREGIT2",137,0)
|
---|
1140 | S N=0 F S N=$O(SCRATCH(N)) Q:'+N D S RESULT(0)=1
|
---|
1141 | "RTN","VWREGIT2",138,0)
|
---|
1142 | . S ^XTV(8989.5,N,1)=NHD
|
---|
1143 | "RTN","VWREGIT2",139,0)
|
---|
1144 | . S DA=N,DIK="^XTV(8989.5," D IX^DIK
|
---|
1145 | "RTN","VWREGIT2",140,0)
|
---|
1146 | . K DIC,DA,DIK
|
---|
1147 | "RTN","VWREGIT2",141,0)
|
---|
1148 | Q
|
---|
1149 | "RTN","VWREGIT2",142,0)
|
---|
1150 | ;
|
---|
1151 | "RTN","VWREGIT2",143,0)
|
---|
1152 | SAVE(RESULT,FLDS) ;Template fields being returned with values
|
---|
1153 | "RTN","VWREGIT2",144,0)
|
---|
1154 | ;UPCASE everything!
|
---|
1155 | "RTN","VWREGIT2",145,0)
|
---|
1156 | ;;Testing
|
---|
1157 | "RTN","VWREGIT2",146,0)
|
---|
1158 | ;;S RESULT(0)="-1 Q
|
---|
1159 | "RTN","VWREGIT2",147,0)
|
---|
1160 | ;;End Testing
|
---|
1161 | "RTN","VWREGIT2",148,0)
|
---|
1162 | K AR,ERR,MFLD,DIERR
|
---|
1163 | "RTN","VWREGIT2",149,0)
|
---|
1164 | N N,TNUM,XFILE,C,PLID,COUNTY,PSSN,DA,DIE,DIC,DR,STR,VAFCA08
|
---|
1165 | "RTN","VWREGIT2",150,0)
|
---|
1166 | ;W " ;Used for "instantiating" a hard error
|
---|
1167 | "RTN","VWREGIT2",151,0)
|
---|
1168 | S C=0,RESULT(0)=""
|
---|
1169 | "RTN","VWREGIT2",152,0)
|
---|
1170 | S X="FLDS" F S X=$Q(@X) Q:X="" S STR=@X,@X=$$UP^XLFSTR(STR)
|
---|
1171 | "RTN","VWREGIT2",153,0)
|
---|
1172 | S VWREG=$S($P(FLDS(0),"^",2)="VWRGUI":1,1:0)
|
---|
1173 | "RTN","VWREGIT2",154,0)
|
---|
1174 | S VAFCA08=1 ;Prevents execution xfrs 991 and 992 of field 1901 and related other fields
|
---|
1175 | "RTN","VWREGIT2",155,0)
|
---|
1176 | S TNUM=+$P(FLDS(0),"(",2)
|
---|
1177 | "RTN","VWREGIT2",156,0)
|
---|
1178 | S XFILE=$P(^DIE(TNUM,0),"^",4)
|
---|
1179 | "RTN","VWREGIT2",157,0)
|
---|
1180 | S $P(FLDS(4),"^",2)=$$CLNNUM($P(FLDS(4),"^",2))
|
---|
1181 | "RTN","VWREGIT2",158,0)
|
---|
1182 | ;VA abnormal anomalies not experienced in the outside world
|
---|
1183 | "RTN","VWREGIT2",159,0)
|
---|
1184 | S N=0 F S N=$O(FLDS(N)) Q:'+N D
|
---|
1185 | "RTN","VWREGIT2",160,0)
|
---|
1186 | . S LFILE=$S($P(FLDS(N),"^")[";":+FLDS(N),1:XFILE)
|
---|
1187 | "RTN","VWREGIT2",161,0)
|
---|
1188 | . S LFLD=$P(FLDS(N),"^")
|
---|
1189 | "RTN","VWREGIT2",162,0)
|
---|
1190 | . S LFLD=$S(LFLD[";":$P($P(LFLD,"^"),";",2),1:LFLD)
|
---|
1191 | "RTN","VWREGIT2",163,0)
|
---|
1192 | . I $P(^DD(LFILE,+LFLD,0),"^")="PRIMARY LONG ID" S PLID=1
|
---|
1193 | "RTN","VWREGIT2",164,0)
|
---|
1194 | . I $P(^DD(LFILE,+LFLD,0),"^")["COUNTY" S COUNTY=FLDS(N) K FLDS(N)
|
---|
1195 | "RTN","VWREGIT2",165,0)
|
---|
1196 | ;End VA abnormal anomalies
|
---|
1197 | "RTN","VWREGIT2",166,0)
|
---|
1198 | S DFN=+$P(FLDS(1),"(",2)
|
---|
1199 | "RTN","VWREGIT2",167,0)
|
---|
1200 | DFN ;
|
---|
1201 | "RTN","VWREGIT2",168,0)
|
---|
1202 | ;Check standard ID fields (ID = NOT in the VA meaning): .01,.02,.03,.36^3 for outside the U.S. or 0^9 in the U.S.
|
---|
1203 | "RTN","VWREGIT2",169,0)
|
---|
1204 | I $P(^DPT(DFN,0),"^")'=$P($P(FLDS(1),"^",2),"(") S AR(XFILE,DFN_",",$P(FLDS(1),"^"))=$P($P(FLDS(1),"^",2),"(")
|
---|
1205 | "RTN","VWREGIT2",170,0)
|
---|
1206 | I $P(^DPT(DFN,0),"^",2)'=$P(FLDS(2),"^") S AR(XFILE,DFN_",",$P(FLDS(2),"^"))=$S($P(FLDS(2),"^",2)="F":"FEMALE",1:"MALE")
|
---|
1207 | "RTN","VWREGIT2",171,0)
|
---|
1208 | S X=$P(FLDS(3),"^",2) D ^%DT I $P(^DPT(DFN,0),"^",3)'=Y S AR(XFILE,DFN_",",$P(FLDS(3),"^"))=$P(FLDS(3),"^",2)
|
---|
1209 | "RTN","VWREGIT2",172,0)
|
---|
1210 | ;S FLD=$P(FLDS(4),"^"),PIECE=$S(FLD=.363:3,1:9),SUBS=$S(FLD=.363:.36,1:0)
|
---|
1211 | "RTN","VWREGIT2",173,0)
|
---|
1212 | ;I $P(^DPT(DFN,SUBS),"^",PIECE)'=$P(FLDS(4),"^",2) S AR(XFILE,DFN_",",FLD)=$P(FLDS(4),"^",2)
|
---|
1213 | "RTN","VWREGIT2",174,0)
|
---|
1214 | S N=4 F S N=$O(FLDS(N)) Q:'+N S:FLDS(N)'[";" AR(XFILE,DFN_",",$P(FLDS(N),"^"))=$P(FLDS(N),"^",2) D:FLDS(N)[";"
|
---|
1215 | "RTN","VWREGIT2",175,0)
|
---|
1216 | . I '$D(MFLD($P(FLDS(N),";"))) S MFLD=$P(FLDS(N),";"),MFLD(MFLD)=FLDS(N)
|
---|
1217 | "RTN","VWREGIT2",176,0)
|
---|
1218 | . E S MFLD($P(FLDS(N),";"))=MFLD($P(FLDS(N),";"))_"~"_$P(FLDS(N),";",2)
|
---|
1219 | "RTN","VWREGIT2",177,0)
|
---|
1220 | I $D(MFLD) S C=1,N=0 F S N=$O(MFLD(N)) Q:'+N S C=C+1,CN=0 F I=1:1:$L(MFLD(N),"~") S CN=CN+1,X=$P($P(MFLD(N),";",2),"~",I),AR(N,"+"_C_","_DFN_",",$P(X,"^"))=$P(X,"^",2)
|
---|
1221 | "RTN","VWREGIT2",178,0)
|
---|
1222 | D UPDATE^DIE("E","AR","","ERR") ;Edit existing entries noted by $D(DFN)
|
---|
1223 | "RTN","VWREGIT2",179,0)
|
---|
1224 | N Y,X,% D NOW^%DTC S Y=% X ^DD("DD")
|
---|
1225 | "RTN","VWREGIT2",180,0)
|
---|
1226 | S RESULT(0)=1_"^"_Y
|
---|
1227 | "RTN","VWREGIT2",181,0)
|
---|
1228 | SOUT Q
|
---|
1229 | "RTN","VWREGIT2",182,0)
|
---|
1230 | ;
|
---|
1231 | "RTN","VWREGIT2",183,0)
|
---|
1232 | UTF(RESULT,UTFLIST) ;Update Linux Template file (regit.txt)
|
---|
1233 | "RTN","VWREGIT2",184,0)
|
---|
1234 | I $O(UTFLIST(" "),-1)=0 S RESULT(0)="-1" Q
|
---|
1235 | "RTN","VWREGIT2",185,0)
|
---|
1236 | K RESULT
|
---|
1237 | "RTN","VWREGIT2",186,0)
|
---|
1238 | N HD,DOTHIS,N,NF
|
---|
1239 | "RTN","VWREGIT2",187,0)
|
---|
1240 | S HD=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY")
|
---|
1241 | "RTN","VWREGIT2",188,0)
|
---|
1242 | I +$P($G(^%ZOSF("OS")),"^",2)=19 D
|
---|
1243 | "RTN","VWREGIT2",189,0)
|
---|
1244 | . S DOTHIS="rm -f "_HD_"regit2.txt" ZSYSTEM DOTHIS ;Remove the prior copy
|
---|
1245 | "RTN","VWREGIT2",190,0)
|
---|
1246 | . S DOTHIS="cp "_HD_"regit.txt"_" "_HD_"regit2.txt" ZSYSTEM DOTHIS ;Copy the main regit file for safekeeping
|
---|
1247 | "RTN","VWREGIT2",191,0)
|
---|
1248 | . S DOTHIS="rm -f "_HD_"regit.txt" ZSYSTEM DOTHIS ;Kill the main regit template file
|
---|
1249 | "RTN","VWREGIT2",192,0)
|
---|
1250 | S RESULT(1)="[TEMPLATES]",N=0 F S N=$O(UTFLIST(N)) Q:'+N S RESULT($$INR)=UTFLIST(N)
|
---|
1251 | "RTN","VWREGIT2",193,0)
|
---|
1252 | S RESULT($$INR)="[ID]"
|
---|
1253 | "RTN","VWREGIT2",194,0)
|
---|
1254 | S X=$$GTF^%ZISH($NA(RESULT(1)),1,HD,"regit.txt")
|
---|
1255 | "RTN","VWREGIT2",195,0)
|
---|
1256 | Q
|
---|
1257 | "RTN","VWREGIT2",196,0)
|
---|
1258 | ;
|
---|
1259 | "RTN","VWREGIT2",197,0)
|
---|
1260 | GT(RESULT,XHOW) ;Get Templates from INPUT TEMPLATE FILE (.402)
|
---|
1261 | "RTN","VWREGIT2",198,0)
|
---|
1262 | ; *********************************************
|
---|
1263 | "RTN","VWREGIT2",199,0)
|
---|
1264 | ; * XHOW____ALL, DUZ, NAMESPACE, USER/NUM *
|
---|
1265 | "RTN","VWREGIT2",200,0)
|
---|
1266 | ; * RETURN ARRAY__List of template names(IEN) *
|
---|
1267 | "RTN","VWREGIT2",201,0)
|
---|
1268 | ; *********************************************
|
---|
1269 | "RTN","VWREGIT2",202,0)
|
---|
1270 | K RESULT,AR
|
---|
1271 | "RTN","VWREGIT2",203,0)
|
---|
1272 | N IEN,NAME,N,USER
|
---|
1273 | "RTN","VWREGIT2",204,0)
|
---|
1274 | S XHOW=$$UP^XLFSTR(XHOW) ;UPCASE EVERYTHING!
|
---|
1275 | "RTN","VWREGIT2",205,0)
|
---|
1276 | I XHOW="" D Q
|
---|
1277 | "RTN","VWREGIT2",206,0)
|
---|
1278 | . S RESULT(0)="I could not complete your request."
|
---|
1279 | "RTN","VWREGIT2",207,0)
|
---|
1280 | . S RESULT(1)="Ensure that one of the check boxes is checked."
|
---|
1281 | "RTN","VWREGIT2",208,0)
|
---|
1282 | . S RESULT(2)="Thank you, the Management."
|
---|
1283 | "RTN","VWREGIT2",209,0)
|
---|
1284 | I XHOW="ALL" D Q
|
---|
1285 | "RTN","VWREGIT2",210,0)
|
---|
1286 | . S RESULT(0)="Number of Templates: "
|
---|
1287 | "RTN","VWREGIT2",211,0)
|
---|
1288 | . S (C,N)=0 F I=1:1 S N=$O(^DIE(N)) Q:'+N S X=$P(^(N,0),"^") S:$$ST(N) AR(X,I)=X_"("_N_")"
|
---|
1289 | "RTN","VWREGIT2",212,0)
|
---|
1290 | . S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X,C=C+1
|
---|
1291 | "RTN","VWREGIT2",213,0)
|
---|
1292 | . K AR
|
---|
1293 | "RTN","VWREGIT2",214,0)
|
---|
1294 | . S $P(RESULT(0),": ",2)=C K C
|
---|
1295 | "RTN","VWREGIT2",215,0)
|
---|
1296 | I XHOW="DUZ" D Q
|
---|
1297 | "RTN","VWREGIT2",216,0)
|
---|
1298 | . S RESULT(0)="Number of templates: "
|
---|
1299 | "RTN","VWREGIT2",217,0)
|
---|
1300 | . S (C,IEN)=0 F S IEN=$O(^DIE(IEN)) Q:'+IEN I $P(^(IEN,0),"^",5)=DUZ,$$ST(IEN) D
|
---|
1301 | "RTN","VWREGIT2",218,0)
|
---|
1302 | .. S C=C+1
|
---|
1303 | "RTN","VWREGIT2",219,0)
|
---|
1304 | .. S NAME=$P(^(0),"^")_"("_IEN_")"
|
---|
1305 | "RTN","VWREGIT2",220,0)
|
---|
1306 | .. S RESULT($$INR)=NAME
|
---|
1307 | "RTN","VWREGIT2",221,0)
|
---|
1308 | . S $P(RESULT(0),":",2)=C
|
---|
1309 | "RTN","VWREGIT2",222,0)
|
---|
1310 | I +XHOW D Q
|
---|
1311 | "RTN","VWREGIT2",223,0)
|
---|
1312 | . S RESULT(0)="Number of templates: "
|
---|
1313 | "RTN","VWREGIT2",224,0)
|
---|
1314 | . S N=0 F I=1:1 S N=$O(^DIE(N)) Q:'+N S X=^(N,0) D
|
---|
1315 | "RTN","VWREGIT2",225,0)
|
---|
1316 | .. Q:$P(X,"^",5)'=XHOW
|
---|
1317 | "RTN","VWREGIT2",226,0)
|
---|
1318 | .. Q:'$$ST(N)
|
---|
1319 | "RTN","VWREGIT2",227,0)
|
---|
1320 | .. S AR($P(X,"^"),I)=$P(X,"^")_"("_N_")"
|
---|
1321 | "RTN","VWREGIT2",228,0)
|
---|
1322 | . S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X
|
---|
1323 | "RTN","VWREGIT2",229,0)
|
---|
1324 | . K AR
|
---|
1325 | "RTN","VWREGIT2",230,0)
|
---|
1326 | . S $P(RESULT(0),": ",2)=$O(RESULT(" "),-1)
|
---|
1327 | "RTN","VWREGIT2",231,0)
|
---|
1328 | I $L(XHOW,"^")>1,$P(XHOW,"^")="NS" D Q
|
---|
1329 | "RTN","VWREGIT2",232,0)
|
---|
1330 | . S RESULT(0)="Templates by Namespace: "
|
---|
1331 | "RTN","VWREGIT2",233,0)
|
---|
1332 | . S N=$P(XHOW,"^",2) F I=1:1 S N=$O(^DIE("B",N)) Q:N'[$P(XHOW,"^",2) S AR(N,I)=N_"("_$O(^DIE("B",N,0))_")"
|
---|
1333 | "RTN","VWREGIT2",234,0)
|
---|
1334 | . S X="AR" F S X=$Q(@X) Q:X="" S Y=@X S:$$ST(+$P(Y,"(",2)) RESULT($$INR)=Y
|
---|
1335 | "RTN","VWREGIT2",235,0)
|
---|
1336 | . S $P(RESULT(0),": ",2)=$O(RESULT(" "),-1)
|
---|
1337 | "RTN","VWREGIT2",236,0)
|
---|
1338 | I $L(XHOW,"^")>1,$P(XHOW,"^")="U",+$P(XHOW,"^",2) D Q
|
---|
1339 | "RTN","VWREGIT2",237,0)
|
---|
1340 | . S RESULT(0)="Templates from: "
|
---|
1341 | "RTN","VWREGIT2",238,0)
|
---|
1342 | . S USER=+$P(XHOW,"^",2)
|
---|
1343 | "RTN","VWREGIT2",239,0)
|
---|
1344 | . I '$D(^VA(200,USER)) S RESULT(0)="I Cannot ID that user number." Q
|
---|
1345 | "RTN","VWREGIT2",240,0)
|
---|
1346 | . S N=0 F I=1:1 S N=$O(^DIE(N)) Q:'+N S NAME=$P(^(N,0),"^") I $P(^(0),"^",5)=USER S AR(NAME,I)=NAME_"("_N_")"
|
---|
1347 | "RTN","VWREGIT2",241,0)
|
---|
1348 | . S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X
|
---|
1349 | "RTN","VWREGIT2",242,0)
|
---|
1350 | . S $P(RESULT(0),": ",2)=$P(^VA(200,USER,0),"^")_" - "_$O(RESULT(" "),-1)
|
---|
1351 | "RTN","VWREGIT2",243,0)
|
---|
1352 | . K AR
|
---|
1353 | "RTN","VWREGIT2",244,0)
|
---|
1354 | I $L(XHOW,"^")>1,$P(XHOW,"^")="U",'+$P(XHOW,"^",2) D Q
|
---|
1355 | "RTN","VWREGIT2",245,0)
|
---|
1356 | . S NAME=$P(XHOW,"^",2)
|
---|
1357 | "RTN","VWREGIT2",246,0)
|
---|
1358 | . K LUERR,ARR D FIND^DIC(200,"",".01;","CM",NAME,"","B","","","ARR","LUERR")
|
---|
1359 | "RTN","VWREGIT2",247,0)
|
---|
1360 | . I $O(ARR("DILIST",2,1)) D Q
|
---|
1361 | "RTN","VWREGIT2",248,0)
|
---|
1362 | .. S RESULT(0)="LIST"
|
---|
1363 | "RTN","VWREGIT2",249,0)
|
---|
1364 | .. S RESULT(1)="[Instruction: double-click to select; right-click to close]"
|
---|
1365 | "RTN","VWREGIT2",250,0)
|
---|
1366 | .. S N=0 F S N=$O(ARR("DILIST",1,N)) Q:'+N S RESULT($$INR)=ARR("DILIST",2,N)_"^"_ARR("DILIST",1,N)
|
---|
1367 | "RTN","VWREGIT2",251,0)
|
---|
1368 | . S IEN=ARR("DILIST",2,1) K ARR
|
---|
1369 | "RTN","VWREGIT2",252,0)
|
---|
1370 | . S RESULT(0)="Templates from: "
|
---|
1371 | "RTN","VWREGIT2",253,0)
|
---|
1372 | . S N=0 F I=1:1 S N=$O(^DIE(N)) Q:'+N!('$$ST(N)) S X=^(N,0) S:$P(X,"^",5)=IEN AR($P(X,"^"),I)=$P(X,"^")_"("_N_")"
|
---|
1373 | "RTN","VWREGIT2",254,0)
|
---|
1374 | . S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X
|
---|
1375 | "RTN","VWREGIT2",255,0)
|
---|
1376 | . S $P(RESULT(0),": ",2)=$O(RESULT(" "),-1)
|
---|
1377 | "RTN","VWREGIT2",256,0)
|
---|
1378 | . K AR
|
---|
1379 | "RTN","VWREGIT2",257,0)
|
---|
1380 | Q
|
---|
1381 | "RTN","VWREGIT2",258,0)
|
---|
1382 | ;
|
---|
1383 | "RTN","VWREGIT2",259,0)
|
---|
1384 |
|
---|
1385 | "RTN","VWREGIT3")
|
---|
1386 | 0^10^B43452100
|
---|
1387 | "RTN","VWREGIT3",1,0)
|
---|
1388 | VWREGIT ;VWEHR/BFProd-Jim Bell, et al - World VistA GUI Pat Reg Utility
|
---|
1389 | "RTN","VWREGIT3",2,0)
|
---|
1390 | ;;1.0;WORLD VISTA;** **;;Build 1
|
---|
1391 | "RTN","VWREGIT3",3,0)
|
---|
1392 | ;
|
---|
1393 | "RTN","VWREGIT3",4,0)
|
---|
1394 | ;This routine utility is for patient specific fields and
|
---|
1395 | "RTN","VWREGIT3",5,0)
|
---|
1396 | ;is used to build input templates for registration
|
---|
1397 | "RTN","VWREGIT3",6,0)
|
---|
1398 | ;
|
---|
1399 | "RTN","VWREGIT3",7,0)
|
---|
1400 | ;GNU License: See WVLIC.txt
|
---|
1401 | "RTN","VWREGIT3",8,0)
|
---|
1402 | ;Modified FOIA VISTA,
|
---|
1403 | "RTN","VWREGIT3",9,0)
|
---|
1404 | ;Copyright 2013 WorldVistA. Licensed under the terms of the GNU
|
---|
1405 | "RTN","VWREGIT3",10,0)
|
---|
1406 | Q
|
---|
1407 | "RTN","VWREGIT3",11,0)
|
---|
1408 | ;
|
---|
1409 | "RTN","VWREGIT3",12,0)
|
---|
1410 | PREFLAB ;Preferred label extract
|
---|
1411 | "RTN","VWREGIT3",13,0)
|
---|
1412 | N FIELD,LABEL,N,I,CUSLAB
|
---|
1413 | "RTN","VWREGIT3",14,0)
|
---|
1414 | S N=0 F S N=$O(RESULT(N)) Q:'+N D
|
---|
1415 | "RTN","VWREGIT3",15,0)
|
---|
1416 | . S LABEL=$P(RESULT(N),"^")
|
---|
1417 | "RTN","VWREGIT3",16,0)
|
---|
1418 | . S FIELD=$P(RESULT(N),"^",2)
|
---|
1419 | "RTN","VWREGIT3",17,0)
|
---|
1420 | . S I=0 F S I=$O(AR(I)) Q:'+I D:RESULT(N)'[";"
|
---|
1421 | "RTN","VWREGIT3",18,0)
|
---|
1422 | .. Q:AR(I)'[";"
|
---|
1423 | "RTN","VWREGIT3",19,0)
|
---|
1424 | .. I $P(AR(I),";")=LABEL!($P(AR(I),";")=FIELD) D
|
---|
1425 | "RTN","VWREGIT3",20,0)
|
---|
1426 | ... S CUSLAB=$P(AR(I),";",2)
|
---|
1427 | "RTN","VWREGIT3",21,0)
|
---|
1428 | ... S CUSLAB=$TR(CUSLAB,"""","")
|
---|
1429 | "RTN","VWREGIT3",22,0)
|
---|
1430 | ... S $P(RESULT(N),"^")=CUSLAB
|
---|
1431 | "RTN","VWREGIT3",23,0)
|
---|
1432 | Q
|
---|
1433 | "RTN","VWREGIT3",24,0)
|
---|
1434 | ;
|
---|
1435 | "RTN","VWREGIT3",25,0)
|
---|
1436 | PARSE(STRING) ;Extract necessary data components in the string
|
---|
1437 | "RTN","VWREGIT3",26,0)
|
---|
1438 | N VAL,PIECE,LABEL,PREFLAB,FLDSN
|
---|
1439 | "RTN","VWREGIT3",27,0)
|
---|
1440 | S VAL=-1 I STRING="" G POUT
|
---|
1441 | "RTN","VWREGIT3",28,0)
|
---|
1442 | ;I $E(STRING)=">" S VAL="" G POUT
|
---|
1443 | "RTN","VWREGIT3",29,0)
|
---|
1444 | S PIECE=$S(STRING["(Multiple)":2,$L(STRING,"(")>2:3,1:2)
|
---|
1445 | "RTN","VWREGIT3",30,0)
|
---|
1446 | I $E(STRING)=">" D G POUT
|
---|
1447 | "RTN","VWREGIT3",31,0)
|
---|
1448 | . S SUBF=+$P(STRING,";",2),MAR(SUBF)=""
|
---|
1449 | "RTN","VWREGIT3",32,0)
|
---|
1450 | . S MAR(SUBF)=MAR(SUBF)_+$P(STRING,"(",PIECE)
|
---|
1451 | "RTN","VWREGIT3",33,0)
|
---|
1452 | . S VAL=""
|
---|
1453 | "RTN","VWREGIT3",34,0)
|
---|
1454 | S LABEL=$P(STRING,"~")
|
---|
1455 | "RTN","VWREGIT3",35,0)
|
---|
1456 | S PREFLAB=$S($P(STRING,"~",2)="(Multiple)":"",1:$P(STRING,"~",2))
|
---|
1457 | "RTN","VWREGIT3",36,0)
|
---|
1458 | S FLDN=+$P(STRING,"(",PIECE)
|
---|
1459 | "RTN","VWREGIT3",37,0)
|
---|
1460 | I '+FLDN,$G(DUZ(0))="@" S VAL=STRING G POUT
|
---|
1461 | "RTN","VWREGIT3",38,0)
|
---|
1462 | S VAL=FLDN_PREFLAB_"~"_$S('$L(PREFLAB):"",1:$P(LABEL,"(",1,PIECE-1)_"^"_PREFLAB)
|
---|
1463 | "RTN","VWREGIT3",39,0)
|
---|
1464 | POUT Q VAL
|
---|
1465 | "RTN","VWREGIT3",40,0)
|
---|
1466 | ;
|
---|
1467 | "RTN","VWREGIT3",41,0)
|
---|
1468 | NEXT(XAR) ;Get next subscript
|
---|
1469 | "RTN","VWREGIT3",42,0)
|
---|
1470 | Q $O(XAR(" "),-1)+1
|
---|
1471 | "RTN","VWREGIT3",43,0)
|
---|
1472 | ;
|
---|
1473 | "RTN","VWREGIT3",44,0)
|
---|
1474 | REJECT(FIELD,IEN) ;Reject Asterisked and Computed fields
|
---|
1475 | "RTN","VWREGIT3",45,0)
|
---|
1476 | I FIELD["COMPONENTS" Q 1 ;Pain in the butt!
|
---|
1477 | "RTN","VWREGIT3",46,0)
|
---|
1478 | I $E(FIELD)="*" Q 1 ;field marked for deletion
|
---|
1479 | "RTN","VWREGIT3",47,0)
|
---|
1480 | I $E($P($G(^DD(2,IEN,0)),"^",2))="C" Q 1 ;computed field
|
---|
1481 | "RTN","VWREGIT3",48,0)
|
---|
1482 | Q 0 ;Passed
|
---|
1483 | "RTN","VWREGIT3",49,0)
|
---|
1484 | ;
|
---|
1485 | "RTN","VWREGIT3",50,0)
|
---|
1486 | GTNUM ;
|
---|
1487 | "RTN","VWREGIT3",51,0)
|
---|
1488 | K AR,RESULT S RESULT(0)=-1
|
---|
1489 | "RTN","VWREGIT3",52,0)
|
---|
1490 | M AR=^DIE(TNUM)
|
---|
1491 | "RTN","VWREGIT3",53,0)
|
---|
1492 | Q:'$D(AR(0)) ;Huh, no template?
|
---|
1493 | "RTN","VWREGIT3",54,0)
|
---|
1494 | S RESULT(0)=TNAME
|
---|
1495 | "RTN","VWREGIT3",55,0)
|
---|
1496 | S FLDS=AR("DR",1,2)
|
---|
1497 | "RTN","VWREGIT3",56,0)
|
---|
1498 | F I=1:1:$L(FLDS,";")-1 S FN=$P(FLDS,";",I) D
|
---|
1499 | "RTN","VWREGIT3",57,0)
|
---|
1500 | . S FDATA=$S(+FN:$P(^DD(2,FN,0),"^",1,2),1:FN)
|
---|
1501 | "RTN","VWREGIT3",58,0)
|
---|
1502 | . S RESULT($$NEXT(.RESULT))=$S(+FN:$P(FDATA,"^")_"("_FN_")",1:FN)_$S(+$P(FDATA,"^",2):"~(Multiple)",1:"")
|
---|
1503 | "RTN","VWREGIT3",59,0)
|
---|
1504 | . I +$P(FDATA,"^",2) S SFN=AR("DR",2,+$P(FDATA,"^",2)) D
|
---|
1505 | "RTN","VWREGIT3",60,0)
|
---|
1506 | .. F J=1:1:$L(SFN,";")-1 D
|
---|
1507 | "RTN","VWREGIT3",61,0)
|
---|
1508 | ... S SDF=$P(SFN,";",J)
|
---|
1509 | "RTN","VWREGIT3",62,0)
|
---|
1510 | ... S SDFDATA=$P(^DD(+$P(FDATA,"^",2),+SDF,0),"^",1,2)
|
---|
1511 | "RTN","VWREGIT3",63,0)
|
---|
1512 | ... S RESULT($$NEXT(.RESULT))=">>>>> "_$P(SDFDATA,"^")_"("_SDF_";"_+$P(FDATA,"^",2)_")"_$S(+$P(SDFDATA,"^",2):"~(Multiple)",1:"")
|
---|
1513 | "RTN","VWREGIT3",64,0)
|
---|
1514 | ... I +$P(SDFDATA,"^",2) S SF3=AR("DR",2,+$P(SDFDATA,"^",2)) D
|
---|
1515 | "RTN","VWREGIT3",65,0)
|
---|
1516 | .... F K=1:1:$L(SF3,";")-1 S SF3DATA=$P(^DD(+$P(SDFDATA,"^",2),SF3,0),"^",1,2) D
|
---|
1517 | "RTN","VWREGIT3",66,0)
|
---|
1518 | ..... S RESULT($$NEXT(.RESULT))=">>>>>>>>>> "_SF3_"~"_$P(SF3DATA,"^")_$S(+$P(SF3DATA,"^",2):"~(Multiple)",1:"")
|
---|
1519 | "RTN","VWREGIT3",67,0)
|
---|
1520 | Q
|
---|
1521 | "RTN","VWREGIT3",68,0)
|
---|
1522 | ;
|
---|
1523 | "RTN","VWREGIT3",69,0)
|
---|
1524 | NFT(SUBS) ;Patient file fields into scratch global
|
---|
1525 | "RTN","VWREGIT3",70,0)
|
---|
1526 | Q $O(^UTILITY(SUBS," "),-1)+1 ;Next suscript
|
---|
1527 | "RTN","VWREGIT3",71,0)
|
---|
1528 | ;
|
---|
1529 | "RTN","VWREGIT3",72,0)
|
---|
1530 | SD ;SUB-DICS
|
---|
1531 | "RTN","VWREGIT3",73,0)
|
---|
1532 | N N,FLD,X
|
---|
1533 | "RTN","VWREGIT3",74,0)
|
---|
1534 | K ^UTILITY("SFT")
|
---|
1535 | "RTN","VWREGIT3",75,0)
|
---|
1536 | S X="^DD(2,""SB"")"
|
---|
1537 | "RTN","VWREGIT3",76,0)
|
---|
1538 | F S X=$Q(@X) Q:X'["SB" D
|
---|
1539 | "RTN","VWREGIT3",77,0)
|
---|
1540 | . S N=+$P(X,",",3)
|
---|
1541 | "RTN","VWREGIT3",78,0)
|
---|
1542 | . S FLD=+$P(X,",",4)
|
---|
1543 | "RTN","VWREGIT3",79,0)
|
---|
1544 | . S ^UTILITY("SFT",FLD,N)=""
|
---|
1545 | "RTN","VWREGIT3",80,0)
|
---|
1546 | Q
|
---|
1547 | "RTN","VWREGIT3",81,0)
|
---|
1548 | ;
|
---|
1549 | "RTN","VWREGIT3",82,0)
|
---|
1550 | LF(RESULT,TNAME) ;Full list of patient fields
|
---|
1551 | "RTN","VWREGIT3",83,0)
|
---|
1552 | K RESULT
|
---|
1553 | "RTN","VWREGIT3",84,0)
|
---|
1554 | S TNUM=+$P(TNAME,"(",2) D:TNUM GTNUM ;Existing template
|
---|
1555 | "RTN","VWREGIT3",85,0)
|
---|
1556 | ; Add patient file fields
|
---|
1557 | "RTN","VWREGIT3",86,0)
|
---|
1558 | S RESULT($$NEXT(.RESULT))="[PF]"
|
---|
1559 | "RTN","VWREGIT3",87,0)
|
---|
1560 | K ^UTILITY("FT") D SD
|
---|
1561 | "RTN","VWREGIT3",88,0)
|
---|
1562 | S FLD="" F S FLD=$O(^DD(2,"B",FLD)) Q:FLD="" D
|
---|
1563 | "RTN","VWREGIT3",89,0)
|
---|
1564 | . S N=0 F S N=$O(^DD(2,"B",FLD,N)) Q:'+N D:'$$REJECT(FLD,N)
|
---|
1565 | "RTN","VWREGIT3",90,0)
|
---|
1566 | .. S ^UTILITY("FT",$$NFT("FT"))=FLD_"("_N_")"_"~"_$S($D(^UTILITY("SFT",N)):"(Multiple)",1:" ")
|
---|
1567 | "RTN","VWREGIT3",91,0)
|
---|
1568 | .. S SDD=$O(^UTILITY("SFT",N,0)) Q:'SDD
|
---|
1569 | "RTN","VWREGIT3",92,0)
|
---|
1570 | .. S SDFLD="" F S SDFLD=$O(^DD(SDD,"B",SDFLD)) Q:SDFLD="" D
|
---|
1571 | "RTN","VWREGIT3",93,0)
|
---|
1572 | ... S SDN=0 F S SDN=$O(^DD(SDD,"B",SDFLD,SDN)) Q:'+SDN I '$$REJECT(SDFLD,SDN) S ^UTILITY("FT",$$NFT("FT"))=">>>>> "_SDFLD_"("_SDN_";"_SDD_")"
|
---|
1573 | "RTN","VWREGIT3",94,0)
|
---|
1574 | K ^UTILITY("SFT")
|
---|
1575 | "RTN","VWREGIT3",95,0)
|
---|
1576 | I '$O(^UTILITY("FT",0)) Q
|
---|
1577 | "RTN","VWREGIT3",96,0)
|
---|
1578 | S X="^UTILITY(""FT"")"
|
---|
1579 | "RTN","VWREGIT3",97,0)
|
---|
1580 | F I=1:1 S X=$Q(@X) Q:X'["FT" S RESULT($$NEXT(.RESULT))=@X
|
---|
1581 | "RTN","VWREGIT3",98,0)
|
---|
1582 | K ^UTILITY("FT")
|
---|
1583 | "RTN","VWREGIT3",99,0)
|
---|
1584 | Q
|
---|
1585 | "RTN","VWREGIT3",100,0)
|
---|
1586 | ;
|
---|
1587 | "RTN","VWREGIT3",101,0)
|
---|
1588 | SAVE(RESULT,FLDS) ;
|
---|
1589 | "RTN","VWREGIT3",102,0)
|
---|
1590 | ;W " ;Intentional "Instantiated" Screw Job
|
---|
1591 | "RTN","VWREGIT3",103,0)
|
---|
1592 | Q:'$D(FLDS)
|
---|
1593 | "RTN","VWREGIT3",104,0)
|
---|
1594 | K ^UTILITY("FLDS") M ^UTILITY("FLDS")=FLDS
|
---|
1595 | "RTN","VWREGIT3",105,0)
|
---|
1596 | N TNUM,TNAME,DIC,DATA,FX,N,X,Y,DIE,NEWTEMP,PIECE
|
---|
1597 | "RTN","VWREGIT3",106,0)
|
---|
1598 | ;Clean FLDS or subscripts with empty values
|
---|
1599 | "RTN","VWREGIT3",107,0)
|
---|
1600 | I '$L(FLDS(0)) K FLDS(0)
|
---|
1601 | "RTN","VWREGIT3",108,0)
|
---|
1602 | S N=0 F S N=$O(FLDS(N)) Q:'+N D
|
---|
1603 | "RTN","VWREGIT3",109,0)
|
---|
1604 | . I '$L(FLDS(N)) K FLDS(N)
|
---|
1605 | "RTN","VWREGIT3",110,0)
|
---|
1606 | . S Y=$P(FLDS(N),"~",2)
|
---|
1607 | "RTN","VWREGIT3",111,0)
|
---|
1608 | . I $E(Y)=" " S $P(FLDS(N),"~",2)=$P(Y," ",2)
|
---|
1609 | "RTN","VWREGIT3",112,0)
|
---|
1610 | ;End cleaning
|
---|
1611 | "RTN","VWREGIT3",113,0)
|
---|
1612 | S NEWTEMP=0
|
---|
1613 | "RTN","VWREGIT3",114,0)
|
---|
1614 | S TNUM=+$P(FLDS(0),"(",2)
|
---|
1615 | "RTN","VWREGIT3",115,0)
|
---|
1616 | I 'TNUM S TNAME=$P(FLDS(0),"(")
|
---|
1617 | "RTN","VWREGIT3",116,0)
|
---|
1618 | S TNUM=$O(^DIE("B",TNAME,0))
|
---|
1619 | "RTN","VWREGIT3",117,0)
|
---|
1620 | I 'TNUM K DATA D ;File a new entry
|
---|
1621 | "RTN","VWREGIT3",118,0)
|
---|
1622 | . D NOW^%DTC
|
---|
1623 | "RTN","VWREGIT3",119,0)
|
---|
1624 | . S DIC="^DIE("
|
---|
1625 | "RTN","VWREGIT3",120,0)
|
---|
1626 | . S DATA(.402,"+1,",.01)=TNAME
|
---|
1627 | "RTN","VWREGIT3",121,0)
|
---|
1628 | . S DATA(.402,"+1,",2)=%
|
---|
1629 | "RTN","VWREGIT3",122,0)
|
---|
1630 | . S DATA(.402,"+1,",3)=$G(DUZ(0))
|
---|
1631 | "RTN","VWREGIT3",123,0)
|
---|
1632 | . S DATA(.402,"+1,",4)=2
|
---|
1633 | "RTN","VWREGIT3",124,0)
|
---|
1634 | . S DATA(.402,"+1,",5)=DUZ
|
---|
1635 | "RTN","VWREGIT3",125,0)
|
---|
1636 | . S DATA(.402,"+1,",6)=$G(DUZ(0))
|
---|
1637 | "RTN","VWREGIT3",126,0)
|
---|
1638 | . D UPDATE^DIE("","DATA","IEN","ERR")
|
---|
1639 | "RTN","VWREGIT3",127,0)
|
---|
1640 | . S TNUM=IEN(1) D RECALL^DILFD(.402,TNUM_",",DUZ)
|
---|
1641 | "RTN","VWREGIT3",128,0)
|
---|
1642 | . S NEWTEMP=1
|
---|
1643 | "RTN","VWREGIT3",129,0)
|
---|
1644 | ;Primary fields
|
---|
1645 | "RTN","VWREGIT3",130,0)
|
---|
1646 | ;K DATA,^DIE(TNUM,"DR")
|
---|
1647 | "RTN","VWREGIT3",131,0)
|
---|
1648 | K DATA,^UTILITY("DIETED",$J),^UTILITY("DIETEDIAB",$J)
|
---|
1649 | "RTN","VWREGIT3",132,0)
|
---|
1650 | K AR S N=0 F S N=$O(FLDS(N)) Q:'+N S X=$$PARSE(FLDS(N)) S:$L(X) AR(N)=X
|
---|
1651 | "RTN","VWREGIT3",133,0)
|
---|
1652 | S FX="",N=0 F S N=$O(AR(N)) Q:'+N D
|
---|
1653 | "RTN","VWREGIT3",134,0)
|
---|
1654 | . I AR(N)'["~" S FX=FX_AR(N)_";" Q
|
---|
1655 | "RTN","VWREGIT3",135,0)
|
---|
1656 | . S FLDN=+$P(AR(N),"~")
|
---|
1657 | "RTN","VWREGIT3",136,0)
|
---|
1658 | . S PREFLAB=$P($P(AR(N),FLDN,2),"~")
|
---|
1659 | "RTN","VWREGIT3",137,0)
|
---|
1660 | . S FX=FX_FLDN_$S($L(PREFLAB):PREFLAB_"~",1:"")_";"
|
---|
1661 | "RTN","VWREGIT3",138,0)
|
---|
1662 | S ^UTILITY("DIETED",$J,1,2)=FX
|
---|
1663 | "RTN","VWREGIT3",139,0)
|
---|
1664 | ;Set up the preferred labels
|
---|
1665 | "RTN","VWREGIT3",140,0)
|
---|
1666 | S N=0 F S N=$O(AR(N)) Q:'+N D
|
---|
1667 | "RTN","VWREGIT3",141,0)
|
---|
1668 | . S LABS=$P(AR(N),"~",2) Q:'$L(LABS)
|
---|
1669 | "RTN","VWREGIT3",142,0)
|
---|
1670 | . S ^UTILITY("DIETEDIAB",$J,N,0,2,0)=$P(LABS,"^")_";"_""""_$P(LABS,"^",2)_""""
|
---|
1671 | "RTN","VWREGIT3",143,0)
|
---|
1672 | Q ;TESTING
|
---|
1673 | "RTN","VWREGIT3",144,0)
|
---|
1674 | ;Sub-fields of primaries
|
---|
1675 | "RTN","VWREGIT3",145,0)
|
---|
1676 | K AR
|
---|
1677 | "RTN","VWREGIT3",146,0)
|
---|
1678 | S N=0 F S N=$O(FLDS(N)) Q:'+N Q:$E(FLDS(N))=">"
|
---|
1679 | "RTN","VWREGIT3",147,0)
|
---|
1680 | G REGIT:'+N ;No sub-fields found for primaries
|
---|
1681 | "RTN","VWREGIT3",148,0)
|
---|
1682 | S N=$G(N)-1 F S N=$O(FLDS(N)) Q:'+N D:$E(FLDS(N))=">"
|
---|
1683 | "RTN","VWREGIT3",149,0)
|
---|
1684 | . S PIECE=$L(FLDS(N),"(")
|
---|
1685 | "RTN","VWREGIT3",150,0)
|
---|
1686 | . S X=$P($P(FLDS(N),"(",PIECE),")")
|
---|
1687 | "RTN","VWREGIT3",151,0)
|
---|
1688 | . S SUBDIC=+$P(X,";",2),SUBFLD=+$P(X,";")
|
---|
1689 | "RTN","VWREGIT3",152,0)
|
---|
1690 | . I '$D(AR(SUBDIC)) S AR(SUBDIC)=""
|
---|
1691 | "RTN","VWREGIT3",153,0)
|
---|
1692 | . S AR(SUBDIC)=AR(SUBDIC)_SUBFLD_";"
|
---|
1693 | "RTN","VWREGIT3",154,0)
|
---|
1694 | M ^DIE(TNUM,"DR",2)=AR
|
---|
1695 | "RTN","VWREGIT3",155,0)
|
---|
1696 | REGIT I NEWTEMP D ;Update HD/regit.txt
|
---|
1697 | "RTN","VWREGIT3",156,0)
|
---|
1698 | . S HD=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY")
|
---|
1699 | "RTN","VWREGIT3",157,0)
|
---|
1700 | . S FILE="regit.txt"
|
---|
1701 | "RTN","VWREGIT3",158,0)
|
---|
1702 | . S P4=1
|
---|
1703 | "RTN","VWREGIT3",159,0)
|
---|
1704 | . S P5=""
|
---|
1705 | "RTN","VWREGIT3",160,0)
|
---|
1706 | . S X=$$FTG^%ZISH(HD,FILE,$NA(AR(1)),P4,P5)
|
---|
1707 | "RTN","VWREGIT3",161,0)
|
---|
1708 | . S N=0 F S N=$O(AR(N)) Q:'+N Q:AR(N)["[ID"
|
---|
1709 | "RTN","VWREGIT3",162,0)
|
---|
1710 | . K AR(N) S AR(N)=TNAME_"("_IEN(1)_")"
|
---|
1711 | "RTN","VWREGIT3",163,0)
|
---|
1712 | . S AR(N+1)="[ID]"
|
---|
1713 | "RTN","VWREGIT3",164,0)
|
---|
1714 | . ZWR AR
|
---|
1715 | "RTN","VWREGIT3",165,0)
|
---|
1716 | . S X=$$GTF^%ZISH($NA(AR(1)),1,HD,"regit.txt")
|
---|
1717 | "RTN","VWREGIT3",166,0)
|
---|
1718 | SOUT S RESULT(0)=$S($G(IEN(1)):TNAME_"("_IEN(1)_")",1:-1)
|
---|
1719 | "RTN","VWREGIT3",167,0)
|
---|
1720 | Q
|
---|
1721 | "RTN","VWREGIT3",168,0)
|
---|
1722 | ;
|
---|
1723 | "RTN","VWREGIT3",169,0)
|
---|
1724 | HELP(RESULT,DATA) ;Get help for Fileman Fields
|
---|
1725 | "RTN","VWREGIT3",170,0)
|
---|
1726 | ; ***************************************************
|
---|
1727 | "RTN","VWREGIT3",171,0)
|
---|
1728 | ; *Incoming DATA__FILE^IEN[O]^FIELD^FLAGS^MSG_ROOT) *
|
---|
1729 | "RTN","VWREGIT3",172,0)
|
---|
1730 | ; ***************************************************
|
---|
1731 | "RTN","VWREGIT3",173,0)
|
---|
1732 | K RESULT,@$P(DATA,"^",5)
|
---|
1733 | "RTN","VWREGIT3",174,0)
|
---|
1734 | N FILE,IEN,FLD,FLAGS,X
|
---|
1735 | "RTN","VWREGIT3",175,0)
|
---|
1736 | S X="FILE^IEN^FLD^FLAGS"
|
---|
1737 | "RTN","VWREGIT3",176,0)
|
---|
1738 | F I=1:1:4 S @$P(X,"^",I)=$P(DATA,"^",I)
|
---|
1739 | "RTN","VWREGIT3",177,0)
|
---|
1740 | D HELP^DIE(FILE,IEN,FLD,FLAGS,$P(DATA,"^",5))
|
---|
1741 | "RTN","VWREGIT3",178,0)
|
---|
1742 | F I=1:1:AR("DIHELP") S RESULT(I)=AR("DIHELP",I)
|
---|
1743 | "RTN","VWREGIT3",179,0)
|
---|
1744 | K @$P(DATA,"^",5),DATA
|
---|
1745 | "RTN","VWREGIT3",180,0)
|
---|
1746 | Q
|
---|
1747 | "RTN","VWREGIT3",181,0)
|
---|
1748 | ;
|
---|
1749 | "RTN","VWREGIT3",182,0)
|
---|
1750 | FP(RESULT,FLDS) ;Disassociated kids
|
---|
1751 | "RTN","VWREGIT3",183,0)
|
---|
1752 | ;W " ;Intentional "instantiated" failure
|
---|
1753 | "RTN","VWREGIT3",184,0)
|
---|
1754 | K RESULT,PAR
|
---|
1755 | "RTN","VWREGIT3",185,0)
|
---|
1756 | N N,FIELD,SUBDIC,PARENT,X
|
---|
1757 | "RTN","VWREGIT3",186,0)
|
---|
1758 | S N=0 F S N=$O(FLDS(N)) Q:'+N D:$E(FLDS(N))=">"
|
---|
1759 | "RTN","VWREGIT3",187,0)
|
---|
1760 | . S FIELD=$P($P(FLDS(N),"(",2),";")
|
---|
1761 | "RTN","VWREGIT3",188,0)
|
---|
1762 | . S SUBDIC=$P($P(FLDS(N),";",2),")")
|
---|
1763 | "RTN","VWREGIT3",189,0)
|
---|
1764 | . S PARENT=$O(^DD(2,"SB",SUBDIC,0))
|
---|
1765 | "RTN","VWREGIT3",190,0)
|
---|
1766 | . Q:'PARENT
|
---|
1767 | "RTN","VWREGIT3",191,0)
|
---|
1768 | . S PAR(PARENT)=$P(^DD(2,PARENT,0),"^")_"("_PARENT_")~(Multiple)"
|
---|
1769 | "RTN","VWREGIT3",192,0)
|
---|
1770 | . S PAR(PARENT,$O(PAR(PARENT," "),-1)+1)=FLDS(N)
|
---|
1771 | "RTN","VWREGIT3",193,0)
|
---|
1772 | . K FLDS(N)
|
---|
1773 | "RTN","VWREGIT3",194,0)
|
---|
1774 | S X="PAR" F S X=$Q(@X) Q:X="" S FLDS($$NEXT(.FLDS))=@X
|
---|
1775 | "RTN","VWREGIT3",195,0)
|
---|
1776 | K PAR
|
---|
1777 | "RTN","VWREGIT3",196,0)
|
---|
1778 | S N=0 F S N=$O(FLDS(N)) Q:'+N S RESULT($$NEXT(.RESULT))=FLDS(N)
|
---|
1779 | "RTN","VWREGIT3",197,0)
|
---|
1780 | K FLDS
|
---|
1781 | "RTN","VWREGIT3",198,0)
|
---|
1782 | Q
|
---|
1783 | "RTN","VWREGIT3",199,0)
|
---|
1784 | ;
|
---|
1785 | "RTN","VWREGIT4")
|
---|
1786 | 0^11^B43791810
|
---|
1787 | "RTN","VWREGIT4",1,0)
|
---|
1788 | VWREGIT4 ;VWEHR/BFPro-Jim Bell, et al-World VistA Patient Registration Utility
|
---|
1789 | "RTN","VWREGIT4",2,0)
|
---|
1790 | ;;1.0;WorldVistA;BellFelder Productions;** **;Build 1;
|
---|
1791 | "RTN","VWREGIT4",3,0)
|
---|
1792 | ;
|
---|
1793 | "RTN","VWREGIT4",4,0)
|
---|
1794 | ;This routine utility is for all known patient data fields
|
---|
1795 | "RTN","VWREGIT4",5,0)
|
---|
1796 | ;
|
---|
1797 | "RTN","VWREGIT4",6,0)
|
---|
1798 | ;GNU License: See WVLIC.txt
|
---|
1799 | "RTN","VWREGIT4",7,0)
|
---|
1800 | ;Modified FOIA VISTA,
|
---|
1801 | "RTN","VWREGIT4",8,0)
|
---|
1802 | ;Copyright 2013 WorldVistA. Licensed under the terms of the GNU
|
---|
1803 | "RTN","VWREGIT4",9,0)
|
---|
1804 | Q
|
---|
1805 | "RTN","VWREGIT4",10,0)
|
---|
1806 | ;
|
---|
1807 | "RTN","VWREGIT4",11,0)
|
---|
1808 | INR() Q $O(RESULT(" "),-1)+1
|
---|
1809 | "RTN","VWREGIT4",12,0)
|
---|
1810 | ;
|
---|
1811 | "RTN","VWREGIT4",13,0)
|
---|
1812 | CLEAN ;Remove VA Specific nodes
|
---|
1813 | "RTN","VWREGIT4",14,0)
|
---|
1814 | ;S X="AR" F S X=$Q(@X) Q:X="" I $P(X,",",$L(X,",")-1)["<LABEL HERE>" K @X
|
---|
1815 | "RTN","VWREGIT4",15,0)
|
---|
1816 | ;COMPONENTS
|
---|
1817 | "RTN","VWREGIT4",16,0)
|
---|
1818 | ;ENTERED BY
|
---|
1819 | "RTN","VWREGIT4",17,0)
|
---|
1820 | ;NEXT AVA. APPT. INDICATOR
|
---|
1821 | "RTN","VWREGIT4",18,0)
|
---|
1822 | ;DATA ENTRY CLERK
|
---|
1823 | "RTN","VWREGIT4",19,0)
|
---|
1824 | ;DESIRED DATE OF APPOINTMENT
|
---|
1825 | "RTN","VWREGIT4",20,0)
|
---|
1826 | ;DATE APPT. MADE
|
---|
1827 | "RTN","VWREGIT4",21,0)
|
---|
1828 | Q
|
---|
1829 | "RTN","VWREGIT4",22,0)
|
---|
1830 | ;
|
---|
1831 | "RTN","VWREGIT4",23,0)
|
---|
1832 | DEMOG(RESULT,IDATA) ;
|
---|
1833 | "RTN","VWREGIT4",24,0)
|
---|
1834 | K RESULT
|
---|
1835 | "RTN","VWREGIT4",25,0)
|
---|
1836 | Q:'$L(IDATA)
|
---|
1837 | "RTN","VWREGIT4",26,0)
|
---|
1838 | S XFN=$P(IDATA,"^")
|
---|
1839 | "RTN","VWREGIT4",27,0)
|
---|
1840 | S PAT=+$P(IDATA,"^",2)
|
---|
1841 | "RTN","VWREGIT4",28,0)
|
---|
1842 | Q:'PAT!('XFN) ;Huh? No patient! No File!
|
---|
1843 | "RTN","VWREGIT4",29,0)
|
---|
1844 | D GETS^DIQ(XFN,PAT_",","**","NIER","AR","ERR")
|
---|
1845 | "RTN","VWREGIT4",30,0)
|
---|
1846 | ;
|
---|
1847 | "RTN","VWREGIT4",31,0)
|
---|
1848 | N X,Y,AGE,XAGE,XDATA,XX,XPID,IDOB,DOB,LINE
|
---|
1849 | "RTN","VWREGIT4",32,0)
|
---|
1850 | I '$G(DT) S X="T" D ^%DT S DT=Y
|
---|
1851 | "RTN","VWREGIT4",33,0)
|
---|
1852 | DID S XDATA=""
|
---|
1853 | "RTN","VWREGIT4",34,0)
|
---|
1854 | ;Q ;testing
|
---|
1855 | "RTN","VWREGIT4",35,0)
|
---|
1856 | S $P(LINE,"-",78)=""
|
---|
1857 | "RTN","VWREGIT4",36,0)
|
---|
1858 | F I="NAME","PRIMARY LONG ID","DATE OF BIRTH","SEX" D
|
---|
1859 | "RTN","VWREGIT4",37,0)
|
---|
1860 | . I I="NAME" S XDATA=$G(AR(XFN,PAT_",",I,"E")) Q
|
---|
1861 | "RTN","VWREGIT4",38,0)
|
---|
1862 | . I I="PRIMARY LONG ID" S XPID=$G(AR(XFN,PAT_",",I,"E")) D Q
|
---|
1863 | "RTN","VWREGIT4",39,0)
|
---|
1864 | .. S XX=$E(XPID,1,$L(XPID)-4)
|
---|
1865 | "RTN","VWREGIT4",40,0)
|
---|
1866 | .. S XX=$TR(XX,"0123456789","#")
|
---|
1867 | "RTN","VWREGIT4",41,0)
|
---|
1868 | .. S XPID=XX_$E(XPID,$L(XPID)-3,$L(XPID))
|
---|
1869 | "RTN","VWREGIT4",42,0)
|
---|
1870 | .. S $P(XDATA," ",2)="IDN: "_XPID
|
---|
1871 | "RTN","VWREGIT4",43,0)
|
---|
1872 | . I I="DATE OF BIRTH" S DOB=$G(AR(PAT,XFN,PAT_",",I,"E")) D S $P(XDATA," ",3)="DOB: "_DOB_" ("_AGE_" old "_$G(AR(XFN,PAT_",","SEX","E"))_")" Q
|
---|
1873 | "RTN","VWREGIT4",44,0)
|
---|
1874 | .. S IDOB=$G(AR(XFN,PAT_",",I,"I"))
|
---|
1875 | "RTN","VWREGIT4",45,0)
|
---|
1876 | .. S DOBT=$G(AR(XFN,PAT_",",540000.1))
|
---|
1877 | "RTN","VWREGIT4",46,0)
|
---|
1878 | .. Q:'IDOB&'DOBT
|
---|
1879 | "RTN","VWREGIT4",47,0)
|
---|
1880 | .. S X1=DT,X2=IDOB D ^%DTC
|
---|
1881 | "RTN","VWREGIT4",48,0)
|
---|
1882 | .. I X=0,DOBT D S AGE=HOURS+MIN_" Hours"
|
---|
1883 | "RTN","VWREGIT4",49,0)
|
---|
1884 | ... S HOURS=$E($P(DOBT,".",2),1,2)
|
---|
1885 | "RTN","VWREGIT4",50,0)
|
---|
1886 | ... S MIN=$E($P(DOBT,".",2),3,99)/60
|
---|
1887 | "RTN","VWREGIT4",51,0)
|
---|
1888 | .. I X=0,'DOBT S XAGE=$P($H,",",2)/60/60,AGE=$P(XAGE,".")_"."_$E($P(XAGE,".",2))_" Hours" Q
|
---|
1889 | "RTN","VWREGIT4",52,0)
|
---|
1890 | .. S AGE=$S(X<60:X_" Days",1:"")
|
---|
1891 | "RTN","VWREGIT4",53,0)
|
---|
1892 | .. I 'AGE,X<365 S XAGE=X/30.4,AGE=$P(XAGE,".")_"."_$E($P(XAGE,".",2))_" Months"
|
---|
1893 | "RTN","VWREGIT4",54,0)
|
---|
1894 | .. I 'AGE S XAGE=X/365.25,AGE=$P(XAGE,".")_$E($P(XAGE,".",2))_" Years"
|
---|
1895 | "RTN","VWREGIT4",55,0)
|
---|
1896 | S RESULT(0)=XDATA
|
---|
1897 | "RTN","VWREGIT4",56,0)
|
---|
1898 | ADD D S RESULT($$INR)="Address: "_ST1
|
---|
1899 | "RTN","VWREGIT4",57,0)
|
---|
1900 | . S ST1=$G(AR(XFN,PAT_",","STREET ADDRESS 1 (CIVIL)","E"))
|
---|
1901 | "RTN","VWREGIT4",58,0)
|
---|
1902 | . I '$L(ST1) S ST1=$G(AR(XFN,PAT_",","STREET ADDRESS 1 (VA)","E"))
|
---|
1903 | "RTN","VWREGIT4",59,0)
|
---|
1904 | . I '$L(ST1) S ST1=$G(AR(XFN,PAT_",","STREET ADDRESS [LINE 1]","E"))
|
---|
1905 | "RTN","VWREGIT4",60,0)
|
---|
1906 | . Q:'$l(ST1)
|
---|
1907 | "RTN","VWREGIT4",61,0)
|
---|
1908 | . S ST2=$G(AR(XFN,PAT_",","STREET ADDRESS 2 (CIVIL)","E"))
|
---|
1909 | "RTN","VWREGIT4",62,0)
|
---|
1910 | . I '$L(ST2) S ST2=$G(AR(XFN,PAT_",","STREET ADDRESS 1 (VA)","E"))
|
---|
1911 | "RTN","VWREGIT4",63,0)
|
---|
1912 | . I '$L(ST2) S ST2=$G(AR(XFN,PAT_",","STREET ADDRESS [LINE 1]","E"))
|
---|
1913 | "RTN","VWREGIT4",64,0)
|
---|
1914 | . S ST1=ST1_" "_ST2_", "
|
---|
1915 | "RTN","VWREGIT4",65,0)
|
---|
1916 | . S CIT=$G(AR(XFN,PAT_",","CITY (CIVIL)","E"))
|
---|
1917 | "RTN","VWREGIT4",66,0)
|
---|
1918 | . I '$L(CIT) S CIT=$G(AR(XFN,PAT_",","CITY (VA)","E"))
|
---|
1919 | "RTN","VWREGIT4",67,0)
|
---|
1920 | . I '$L(CIT) S CIT=$G(AR(XFN,PAT_",","CITY","E"))
|
---|
1921 | "RTN","VWREGIT4",68,0)
|
---|
1922 | . S ST1=ST1_$S('$L(CIT):"<City not listed>",1:CIT)_", "
|
---|
1923 | "RTN","VWREGIT4",69,0)
|
---|
1924 | . S STATE=$G(AR(XFN,PAT_",","STATE (CIVIL)","E"))
|
---|
1925 | "RTN","VWREGIT4",70,0)
|
---|
1926 | . I '$L(STATE) S STATE=$G(AR(XFN,PAT_",","STATE (VA)","E"))
|
---|
1927 | "RTN","VWREGIT4",71,0)
|
---|
1928 | . I '$L(STATE) S STATE=$G(AR(XFN,PAT_",","STATE","E"))
|
---|
1929 | "RTN","VWREGIT4",72,0)
|
---|
1930 | . S ST1=ST1_$S('$L(STATE):"<State/province not listed>",1:STATE)
|
---|
1931 | "RTN","VWREGIT4",73,0)
|
---|
1932 | . S PC=$G(AR(XFN,PAT_",","POSTAL CODE","E"))
|
---|
1933 | "RTN","VWREGIT4",74,0)
|
---|
1934 | . I '$L(PC) S PC=$G(AR(XFN,PAT_",","ZIP (CIVIL)","E"))
|
---|
1935 | "RTN","VWREGIT4",75,0)
|
---|
1936 | . I '$L(PC) S PC=$G(AR(XFN,PAT_",","ZIP (VA)","E"))
|
---|
1937 | "RTN","VWREGIT4",76,0)
|
---|
1938 | . I '$L(PC) S PC=$G(AR(XFN,PAT_",","ZIP CODE","E"))
|
---|
1939 | "RTN","VWREGIT4",77,0)
|
---|
1940 | . I '$L(PC) S PC=$G(AR(XFN,PAT_",","ZIP+4 (VA)","E"))
|
---|
1941 | "RTN","VWREGIT4",78,0)
|
---|
1942 | . I '$L(PC) S PC=$G(AR(XFN,PAT_",","ZIP+4 (CIVIL)","E"))
|
---|
1943 | "RTN","VWREGIT4",79,0)
|
---|
1944 | . I '$L(PC) S PC=$G(AR(XFN,PAT_",","ZIP+4","E"))
|
---|
1945 | "RTN","VWREGIT4",80,0)
|
---|
1946 | . S ST1=ST1_" "_PC
|
---|
1947 | "RTN","VWREGIT4",81,0)
|
---|
1948 | S RESULT($$INR)=LINE
|
---|
1949 | "RTN","VWREGIT4",82,0)
|
---|
1950 | NOK D S RESULT($$INR)="Next of Kin: "_$S($L(NK):NK,1:"<No listing>")
|
---|
1951 | "RTN","VWREGIT4",83,0)
|
---|
1952 | . S NK="" Q:'$L($G(AR(XFN,PAT_",","K-NAME","E")))
|
---|
1953 | "RTN","VWREGIT4",84,0)
|
---|
1954 | . S NK=$G(AR(XFN,PAT_",","K-NAME OF PRIMARY NOK","E"))
|
---|
1955 | "RTN","VWREGIT4",85,0)
|
---|
1956 | . S NKDAT=$G(AR(XFN,PAT_",","K-RELATIONSHIP TO PATIENT","E")) S NK=NK_$S($L(NKDAT):"("_NKDAT_")",1:"")
|
---|
1957 | "RTN","VWREGIT4",86,0)
|
---|
1958 | . S NKDAT=$G(AR(XFN,PAT_",","K-STREET ADDRESS [LINE 1]","E"))
|
---|
1959 | "RTN","VWREGIT4",87,0)
|
---|
1960 | . I $L($G(AR(XFN,PAT_",","K-STREET ADDRESS [LINE 2]","E"))) S NKDAT=", "_$G(AR(XFN,PAT_",","K-STREET ADDRESS [LINE 2]","E"))
|
---|
1961 | "RTN","VWREGIT4",88,0)
|
---|
1962 | . S NK=NK_$S($L(NKDAT):NKDAT,1:"")
|
---|
1963 | "RTN","VWREGIT4",89,0)
|
---|
1964 | D I $L($G(NK)) S RESULT($$INR)="Next of Kin: "_NK
|
---|
1965 | "RTN","VWREGIT4",90,0)
|
---|
1966 | . Q:'$L($G(AR(XFN,PAT_",","K-NAME","E")))
|
---|
1967 | "RTN","VWREGIT4",91,0)
|
---|
1968 | . Q:'$L($G(AR(XFN,PAT_",","K2-NAME","E")))
|
---|
1969 | "RTN","VWREGIT4",92,0)
|
---|
1970 | . S NK=$G(AR(XFN,PAT_",","K2-NAME OF PRIMARY NOK","E"))
|
---|
1971 | "RTN","VWREGIT4",93,0)
|
---|
1972 | . S NKDAT=$G(AR(XFN,PAT_",","K2-RELATIONSHIP TO PATIENT","E")) S NK=NK_$S($L(NKDAT):"("_NKDAT_")",1:"")
|
---|
1973 | "RTN","VWREGIT4",94,0)
|
---|
1974 | . S NKDAT=$G(AR(XFN,PAT_",","K2-STREET ADDRESS [LINE 1]","E"))
|
---|
1975 | "RTN","VWREGIT4",95,0)
|
---|
1976 | . I $L($G(AR(XFN,PAT_",","K2-STREET ADDRESS [LINE 2]","E"))) S NKDAT=", "_$G(AR(XFN,PAT_",","K2-STREET ADDRESS [LINE 2]","E"))
|
---|
1977 | "RTN","VWREGIT4",96,0)
|
---|
1978 | . S NK=NK_$S($L(NKDAT):NKDAT,1:"")
|
---|
1979 | "RTN","VWREGIT4",97,0)
|
---|
1980 | ICE ;
|
---|
1981 | "RTN","VWREGIT4",98,0)
|
---|
1982 | I '$L($G(AR(XFN,PAT_",","E-NAME","E"))) S RESULT($$INR)=$J("ICE: ",$L("NEXT OF KIN: "))_"<No listing>" G ICEOUT
|
---|
1983 | "RTN","VWREGIT4",99,0)
|
---|
1984 | S ICE=$G(AR(XFN,PAT_",","E-NAME","E"))
|
---|
1985 | "RTN","VWREGIT4",100,0)
|
---|
1986 | S EADD=$G(AR(XFN,PAT_",","E-STREET ADDRESS [LINE 1]","E"))
|
---|
1987 | "RTN","VWREGIT4",101,0)
|
---|
1988 | S EAD2=$G(AR(XFN,PAT_",","E-STREET ADDRESS [LINE 2]","E"))
|
---|
1989 | "RTN","VWREGIT4",102,0)
|
---|
1990 | S ECITY=$G(AR(XFN,PAT_",","E-CITY","E"))
|
---|
1991 | "RTN","VWREGIT4",103,0)
|
---|
1992 | S ESTATE=$G(AR(XFN,PAT_",","E-STATE","E"))
|
---|
1993 | "RTN","VWREGIT4",104,0)
|
---|
1994 | S EZIP=$G(AR(XFN,PAT_",","E-ZIP+4","E"))
|
---|
1995 | "RTN","VWREGIT4",105,0)
|
---|
1996 | S IPHONE=$G(AR(XFN,PAT_",","E-PHONE NUMBER","E"))
|
---|
1997 | "RTN","VWREGIT4",106,0)
|
---|
1998 | S WPHONE=$G(AR(XFN,PAT_",","E-WORK PHONE NUMBER","E"))
|
---|
1999 | "RTN","VWREGIT4",107,0)
|
---|
2000 | S RESULT($$INR)=$J("ICE: ",$L("NEXT OF KIN: "))_ICE
|
---|
2001 | "RTN","VWREGIT4",108,0)
|
---|
2002 | S RESULT($$INR)=$J("Address: ",$L("NEXT OF KIN: "))_$S($L(EADD):EADD_$S($L(EAD2):" "_EAD2,1:""),1:"<No listing>")
|
---|
2003 | "RTN","VWREGIT4",109,0)
|
---|
2004 | S RESULT($$INR)=$J("City: ",$L("NEXT OF KIN: "))_ECITY
|
---|
2005 | "RTN","VWREGIT4",110,0)
|
---|
2006 | S RESULT($$INR)=$J("State: ",$L("NEXT OF KIN: "))_ESTATE
|
---|
2007 | "RTN","VWREGIT4",111,0)
|
---|
2008 | S RESULT($$INR)=$J("Zip: ",$L("NEXT OF KIN: "))_EZIP
|
---|
2009 | "RTN","VWREGIT4",112,0)
|
---|
2010 | S RESULT($$INR)=$J("Phone: ",$L("NEXT OF KIN: "))_IPHONE
|
---|
2011 | "RTN","VWREGIT4",113,0)
|
---|
2012 | S RESULT($$INR)=$J("Work: ",$L("NEXT OF KIN: "))_WPHONE
|
---|
2013 | "RTN","VWREGIT4",114,0)
|
---|
2014 | ICEOUT S RESULT($$INR)=LINE
|
---|
2015 | "RTN","VWREGIT4",115,0)
|
---|
2016 | INS D S RESULT($$INR)="Insurance/Coverage: "_$S($L(IC):IC,1:"<No listing>")
|
---|
2017 | "RTN","VWREGIT4",116,0)
|
---|
2018 | . K AR(2.312) ;Get it from the horse's mouth
|
---|
2019 | "RTN","VWREGIT4",117,0)
|
---|
2020 | . S IC="" S N=0 F S N=$O(^DPT(PAT,.312,N)) Q:'+N S IC=IC_$P(^DIC(36,+^(N,0),0),"^")_$S($O(^DPT(PAT,.312,N)):", ",1:"")
|
---|
2021 | "RTN","VWREGIT4",118,0)
|
---|
2022 | S RESULT($$INR)=LINE
|
---|
2023 | "RTN","VWREGIT4",119,0)
|
---|
2024 | ER S HEADER="Walk-in/ER",$P(HEADER," ",2)="Date/Time"
|
---|
2025 | "RTN","VWREGIT4",120,0)
|
---|
2026 | S $P(HEADER," ",3)="Type of Benefit"
|
---|
2027 | "RTN","VWREGIT4",121,0)
|
---|
2028 | S RESULT($$INR)=HEADER
|
---|
2029 | "RTN","VWREGIT4",122,0)
|
---|
2030 | S N=0 F S N=$O(^DPT(PAT,"DIS",N)) Q:'+N S XDIS=^(N,0) D
|
---|
2031 | "RTN","VWREGIT4",123,0)
|
---|
2032 | . S Y=+XDIS X ^DD("DD") S $P(WER," ",2)=Y
|
---|
2033 | "RTN","VWREGIT4",124,0)
|
---|
2034 | . S $P(WER," ",3)=$P($P($P(^DD(2.101,2,0),"^",3),";",$P(XDIS,"^",3)),":",2),RESULT($$INR)=WER,WER=""
|
---|
2035 | "RTN","VWREGIT4",125,0)
|
---|
2036 | S RESULT($$INR)=WER
|
---|
2037 | "RTN","VWREGIT4",126,0)
|
---|
2038 | S RESULT($$INR)=LINE
|
---|
2039 | "RTN","VWREGIT4",127,0)
|
---|
2040 | APPT S HEADER="Sched. Appts",$P(HEADER," ",2)="Date/Time",$P(HEADER," ",3)="Clinic"
|
---|
2041 | "RTN","VWREGIT4",128,0)
|
---|
2042 | S RESULT($$INR)=HEADER
|
---|
2043 | "RTN","VWREGIT4",129,0)
|
---|
2044 | S N=0 F S N=$O(^DPT(PAT,"S",N)) Q:'+N S XDIS=^(N,0) D
|
---|
2045 | "RTN","VWREGIT4",130,0)
|
---|
2046 | . S Y=N X ^DD("DD") S $P(WER," ",2)=Y
|
---|
2047 | "RTN","VWREGIT4",131,0)
|
---|
2048 | . S $P(WER," ",3)=$P(^SC(+XDIS,0),"^")
|
---|
2049 | "RTN","VWREGIT4",132,0)
|
---|
2050 | . S RESULT($$INR)=WER
|
---|
2051 | "RTN","VWREGIT4",133,0)
|
---|
2052 | S RESULT($$INR)=LINE
|
---|
2053 | "RTN","VWREGIT4",134,0)
|
---|
2054 | ADM S HEADER="Admit",$P(HEADER," ",2)="Discharge"
|
---|
2055 | "RTN","VWREGIT4",135,0)
|
---|
2056 | S RESULT($$INR)=HEADER
|
---|
2057 | "RTN","VWREGIT4",136,0)
|
---|
2058 | K WER
|
---|
2059 | "RTN","VWREGIT4",137,0)
|
---|
2060 | S N=0 F S N=$O(^DGPM("C",PAT,N)) Q:'+N S XDIS=^(N,0) D
|
---|
2061 | "RTN","VWREGIT4",138,0)
|
---|
2062 | . S Y=+XDIS X ^DD("DD") S WER=Y
|
---|
2063 | "RTN","VWREGIT4",139,0)
|
---|
2064 | . S DMOV=$P(XDIS,"^",17)
|
---|
2065 | "RTN","VWREGIT4",140,0)
|
---|
2066 | . S:DMOV Y=+^DGPM(DMOV,0) X ^DD("DD") S $P(WER," ",2)=Y
|
---|
2067 | "RTN","VWREGIT4",141,0)
|
---|
2068 | . S RESULT($$INR)=WER,WER=""
|
---|
2069 | "RTN","VWREGIT4",142,0)
|
---|
2070 | I '$L($G(WER)) S RESULT($$INR)="No admissions of file"
|
---|
2071 | "RTN","VWREGIT4",143,0)
|
---|
2072 | S RESULT($$INR)=LINE
|
---|
2073 | "RTN","VWREGIT4",144,0)
|
---|
2074 | XIT K AR,CIT,DIC,DOBT,EAD2,EADD,ECITY,ESTATE,EZIP,HEADER,I,IC,ICE
|
---|
2075 | "RTN","VWREGIT4",145,0)
|
---|
2076 | K IPHONE,N,NK,PAT,PC,XFN,ST1,ST2,STATE,WPHONE
|
---|
2077 | "RTN","VWREGIT4",146,0)
|
---|
2078 | Q
|
---|
2079 | "VER")
|
---|
2080 | 8.0^22.0
|
---|
2081 | **END**
|
---|
2082 | **END**
|
---|