1. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 1/4/2018 5:07:20 PM Eastern Standard Time. See www.araxis.com for information about Merge. This report uses XHTML and CSS2, and is best viewed with a modern standards-compliant browser. For optimum results when printing this report, use landscape orientation and enable printing of background images and colours in your browser.

1.1 Files compared

#	Location	File	Last Modified
1	ESM_v5.3_iter_5.zip	DG_53_P935_V5.KID	Fri Dec 8 01:23:10 2017 UTC
2	ESM_v5.3_iter_5.zip	DG_53_P935_V5.KID	Thu Jan 4 22:03:01 2018 UTC

1.2 Comparison summary

Description	Between Files 1 and 2
Description	Text Blocks	Lines
Unchanged	1	14888
Changed	0	0
Inserted	1	12
Removed	0	0

1.3 Comparison options

Whitespace
Character case	Differences in character case are significant
Line endings	Differences in line endings (`CR` and `LF` characters) are ignored
CR/LF characters	Not shown in the comparison detail

1.4 Active regular expressions

No regular expressions were active.

1.5 Comparison detail

1	KIDS Distr ibution sa ved on Nov 06, 2017@ 11:05:45
2	Enrollment System Mo dernizatio n Build
3	KIDS:D G5.3935^ IVM2.016 7^
4
5	INSTALL NAME
6	DG5.3935
7	"BLD",9964 ,0)
8	DG5.3935 ^REGISTRAT ION^0^3171 106^y
9	"BLD",9964 ,1,0)
10	^^2^2^3171 031^^^
11	"BLD",9964 ,1,1,0)
12	Enrollment System Mo dernizatio n Project VistA DG_5 3_P935.KID Build
13	"BLD",9964 ,1,2,0)
14	enhancemen ts; see th e patch de scription for more i nformation .
15	"BLD",9964 ,4,0)
16	^9.64PA^2^ 1
17	"BLD",9964 ,4,2,0)
18	2
19	"BLD",9964 ,4,2,2,0)
20	^9.641^2.3 216^1
21	"BLD",9964 ,4,2,2,2.3 216,0)
22	MILITARY S ERVICE EPI SODE (sub -file)
23	"BLD",9964 ,4,2,2,2.3 216,1,0)
24	^9.6411^.0 8^1
25	"BLD",9964 ,4,2,2,2.3 216,1,.08, 0)
26	FUTURE DIS CHARGE DAT E
27	"BLD",9964 ,4,2,222)
28	y^y^p^^^^n ^^n
29	"BLD",9964 ,4,2,224)
30
31	"BLD",9964 ,4,25.11,2 ,25.11,1,. 01,0)
32	NAME
33	"BLD",9964 ,4,"APDD", 2,2.3216)
34
35	"BLD",9964 ,4,"APDD", 2,2.3216,. 08)
36
37	"BLD",9964 ,4,"APDD", 25.11,25.1 1,.01)
38
39	"BLD",9964 ,4,"B",2,2 )
40
41	"BLD",9964 ,6.3)
42	53
43	"BLD",9964 ,"ABPKG")
44	n
45	"BLD",9964 ,"INID")
46	^
47	"BLD",9964 ,"INIT")
48	POST^DG53P 935
49	"BLD",9964 ,"KRN",0)
50	^9.67PA^77 9.2^20
51	"BLD",9964 ,"KRN",.4, 0)
52	.4
53	"BLD",9964 ,"KRN",.4, "NM",0)
54	^9.68A^^
55	"BLD",9964 ,"KRN",.40 1,0)
56	.401
57	"BLD",9964 ,"KRN",.40 1,"NM",0)
58	^9.68A^^
59	"BLD",9964 ,"KRN",.40 2,0)
60	.402
61	"BLD",9964 ,"KRN",.40 2,"NM",0)
62	^9.68A^^
63	"BLD",9964 ,"KRN",.40 3,0)
64	.403
65	"BLD",9964 ,"KRN",.40 3,"NM",0)
66	^9.68A^^
67	"BLD",9964 ,"KRN",.5, 0)
68	.5
69	"BLD",9964 ,"KRN",.5, "NM",0)
70	^9.68A^^
71	"BLD",9964 ,"KRN",.84 ,0)
72	.84
73	"BLD",9964 ,"KRN",.84 ,"NM",0)
74	^9.68A^^
75	"BLD",9964 ,"KRN",3.6 ,0)
76	3.6
77	"BLD",9964 ,"KRN",3.6 ,"NM",0)
78	^9.68A^^
79	"BLD",9964 ,"KRN",3.8 ,0)
80	3.8
81	"BLD",9964 ,"KRN",3.8 ,"NM",0)
82	^9.68A^^
83	"BLD",9964 ,"KRN",9.2 ,0)
84	9.2
85	"BLD",9964 ,"KRN",9.2 ,"NM",0)
86	^9.68A^^
87	"BLD",9964 ,"KRN",9.8 ,0)
88	9.8
89	"BLD",9964 ,"KRN",9.8 ,"NM",0)
90	^9.68A^14^ 12
91	"BLD",9964 ,"KRN",9.8 ,"NM",1,0)
92	DGRPU^^0^B 88766469
93	"BLD",9964 ,"KRN",9.8 ,"NM",2,0)
94	DGRPD1^^0^ B7682498
95	"BLD",9964 ,"KRN",9.8 ,"NM",3,0)
96	DGRPCF^^0^ B26225283
97	"BLD",9964 ,"KRN",9.8 ,"NM",5,0)
98	DGENUPL3^^ 0^B8956753 5
99	"BLD",9964 ,"KRN",9.8 ,"NM",6,0)
100	DGMSEUTL^^ 0^B1788347 5
101	"BLD",9964 ,"KRN",9.8 ,"NM",7,0)
102	DGENUPL1^^ 0^B5485866 5
103	"BLD",9964 ,"KRN",9.8 ,"NM",8,0)
104	DGRP61^^0^ B57864374
105	"BLD",9964 ,"KRN",9.8 ,"NM",9,0)
106	VAFHLZM2^^ 0^B1113457 8
107	"BLD",9964 ,"KRN",9.8 ,"NM",10,0 )
108	VADPT4^^0^ B43698033
109	"BLD",9964 ,"KRN",9.8 ,"NM",11,0 )
110	DGRPMS^^0^ B68853041
111	"BLD",9964 ,"KRN",9.8 ,"NM",13,0 )
112	DGNOZMH^^0 ^B1893168
113	"BLD",9964 ,"KRN",9.8 ,"NM",14,0 )
114	VAFHLZMH^^ 0^B3126601 4
115	"BLD",9964 ,"KRN",9.8 ,"NM","B", "DGENUPL1" ,7)
116
117	"BLD",9964 ,"KRN",9.8 ,"NM","B", "DGENUPL3" ,5)
118
119	"BLD",9964 ,"KRN",9.8 ,"NM","B", "DGMSEUTL" ,6)
120
121	"BLD",9964 ,"KRN",9.8 ,"NM","B", "DGNOZMH", 13)
122
123	"BLD",9964 ,"KRN",9.8 ,"NM","B", "DGRP61",8 )
124
125	"BLD",9964 ,"KRN",9.8 ,"NM","B", "DGRPCF",3 )
126
127	"BLD",9964 ,"KRN",9.8 ,"NM","B", "DGRPD1",2 )
128
129	"BLD",9964 ,"KRN",9.8 ,"NM","B", "DGRPMS",1 1)
130
131	"BLD",9964 ,"KRN",9.8 ,"NM","B", "DGRPU",1)
132
133	"BLD",9964 ,"KRN",9.8 ,"NM","B", "VADPT4",1 0)
134
135	"BLD",9964 ,"KRN",9.8 ,"NM","B", "VAFHLZM2" ,9)
136
137	"BLD",9964 ,"KRN",9.8 ,"NM","B", "VAFHLZMH" ,14)
138
139	"BLD",9964 ,"KRN",19, 0)
140	19
141	"BLD",9964 ,"KRN",19, "NM",0)
142	^9.68A^^
143	"BLD",9964 ,"KRN",19. 1,0)
144	19.1
145	"BLD",9964 ,"KRN",19. 1,"NM",0)
146	^9.68A^^
147	"BLD",9964 ,"KRN",101 ,0)
148	101
149	"BLD",9964 ,"KRN",101 ,"NM",0)
150	^9.68A^^
151	"BLD",9964 ,"KRN",409 .61,0)
152	409.61
153	"BLD",9964 ,"KRN",409 .61,"NM",0 )
154	^9.68A^^
155	"BLD",9964 ,"KRN",771 ,0)
156	771
157	"BLD",9964 ,"KRN",771 ,"NM",0)
158	^9.68A^^
159	"BLD",9964 ,"KRN",779 .2,0)
160	779.2
161	"BLD",9964 ,"KRN",779 .2,"NM",0)
162	^9.68A^^
163	"BLD",9964 ,"KRN",870 ,0)
164	870
165	"BLD",9964 ,"KRN",870 ,"NM",0)
166	^9.68A^^
167	"BLD",9964 ,"KRN",898 9.51,0)
168	8989.51
169	"BLD",9964 ,"KRN",898 9.51,"NM", 0)
170	^9.68A^^
171	"BLD",9964 ,"KRN",898 9.52,0)
172	8989.52
173	"BLD",9964 ,"KRN",898 9.52,"NM", 0)
174	^9.68A^^
175	"BLD",9964 ,"KRN",899 4,0)
176	8994
177	"BLD",9964 ,"KRN",899 4,"NM",0)
178	^9.68A^^
179	"BLD",9964 ,"KRN","B" ,.4,.4)
180
181	"BLD",9964 ,"KRN","B" ,.401,.401 )
182
183	"BLD",9964 ,"KRN","B" ,.402,.402 )
184
185	"BLD",9964 ,"KRN","B" ,.403,.403 )
186
187	"BLD",9964 ,"KRN","B" ,.5,.5)
188
189	"BLD",9964 ,"KRN","B" ,.84,.84)
190
191	"BLD",9964 ,"KRN","B" ,3.6,3.6)
192
193	"BLD",9964 ,"KRN","B" ,3.8,3.8)
194
195	"BLD",9964 ,"KRN","B" ,9.2,9.2)
196
197	"BLD",9964 ,"KRN","B" ,9.8,9.8)
198
199	"BLD",9964 ,"KRN","B" ,19,19)
200
201	"BLD",9964 ,"KRN","B" ,19.1,19.1 )
202
203	"BLD",9964 ,"KRN","B" ,101,101)
204
205	"BLD",9964 ,"KRN","B" ,409.61,40 9.61)
206
207	"BLD",9964 ,"KRN","B" ,771,771)
208
209	"BLD",9964 ,"KRN","B" ,779.2,779 .2)
210
211	"BLD",9964 ,"KRN","B" ,870,870)
212
213	"BLD",9964 ,"KRN","B" ,8989.51,8 989.51)
214
215	"BLD",9964 ,"KRN","B" ,8989.52,8 989.52)
216
217	"BLD",9964 ,"KRN","B" ,8994,8994 )
218
219	"BLD",9964 ,"QDEF")
220	^^^^NO^^^^ NO^^YES
221	"BLD",9964 ,"QUES",0)
222	^9.62^^
223	"BLD",9964 ,"REQB",0)
224	^9.611^6^6
225	"BLD",9964 ,"REQB",1, 0)
226	DG5.3863 ^1
227	"BLD",9964 ,"REQB",2, 0)
228	DG5.3867 ^1
229	"BLD",9964 ,"REQB",3, 0)
230	DG5.3936 ^1
231	"BLD",9964 ,"REQB",4, 0)
232	DG5.3909 ^1
233	"BLD",9964 ,"REQB",5, 0)
234	DG5.3928 ^1
235	"BLD",9964 ,"REQB",6, 0)
236	DG5.3871 ^1
237	"BLD",9964 ,"REQB","B ","DG5.3 863",1)
238
239	"BLD",9964 ,"REQB","B ","DG5.3 867",2)
240
241	"BLD",9964 ,"REQB","B ","DG5.3 871",6)
242
243	"BLD",9964 ,"REQB","B ","DG5.3 909",4)
244
245	"BLD",9964 ,"REQB","B ","DG5.3 928",5)
246
247	"BLD",9964 ,"REQB","B ","DG5.3 936",3)
248
249	"FIA",2)
250	PATIENT
251	"FIA",2,0)
252	^DPT(
253	"FIA",2,0, 0)
254	2I
255	"FIA",2,0, 1)
256	y^y^p^^^^n ^^n
257	"FIA",2,0, 10)
258
259	"FIA",2,0, 11)
260
261	"FIA",2,0, "RLRO")
262
263	"FIA",2,0, "VR")
264	5.3^DG
265	"FIA",2,2)
266	1
267	"FIA",2,2. 3216)
268	1
269	"FIA",2,2. 3216,.08)
270
271	"FIA",25.1 1)
272	HEALTH BEN EFIT PLAN
273	"FIA",25.1 1,0)
274	^DGHBP(25. 11,
275	"FIA",25.1 1,0,0)
276	25.11I
277	"FIA",25.1 1,0,1)
278	^^f
279	"FIA",25.1 1,0,10)
280
281	"FIA",25.1 1,0,11)
282
283	"FIA",25.1 1,0,"RLRO" )
284
285	"FIA",25.1 1,0,"VR")
286	5.3^DG
287	"FIA",25.1 1,25.11)
288	0
289	"FIA",25.1 1,25.13)
290	0
291	"FIA",25.1 1,25.14)
292	0
293	"INIT")
294	POST^DG53P 935
295	"IX",25.11 ,25.11,"B" ,0)
296	25.11^B^Co ntains all the Healt h Benefit Plans in a lphabetica l order.^R ^^F^IR^I^2 5.11^^^^^L S
297	"IX",25.11 ,25.11,"B" ,1)
298	S ^DGHBP(2 5.11,"B",$ E(X,1,64), DA)=""
299	"IX",25.11 ,25.11,"B" ,2)
300	K ^DGHBP(2 5.11,"B",$ E(X,1,64), DA)
301	"IX",25.11 ,25.11,"B" ,2.5)
302	K ^DGHBP(2 5.11,"B")
303	"IX",25.11 ,25.11,"B" ,11.1,0)
304	^.114IA^1^ 1
305	"IX",25.11 ,25.11,"B" ,11.1,1,0)
306	1^F^25.11^ .01^64^1^F
307	"IX",25.11 ,25.11,"B" ,11.1,1,3)
308
309	"MBREQ")
310	0
311	"PKG",47,- 1)
312	1^1
313	"PKG",47,0 )
314	REGISTRATI ON^DG^PATI ENT REGIST RATION, AD MISSION, D ISCHARGE, EMBOSSER
315	"PKG",47,2 0,0)
316	^9.402P^^
317	"PKG",47,2 2,0)
318	^9.49I^1^1
319	"PKG",47,2 2,1,0)
320	5.3^293081 3^2960613
321	"PKG",47,2 2,1,"PAH", 1,0)
322	935^317110 6^101100
323	"PKG",47,2 2,1,"PAH", 1,1,0)
324	^^2^2^3171 106
325	"PKG",47,2 2,1,"PAH", 1,1,1,0)
326	Enrollment System Mo dernizatio n Project VistA DG_5 3_P935.KID Build
327	"PKG",47,2 2,1,"PAH", 1,1,2,0)
328	enhancemen ts; see th e patch de scription for more i nformation .
329	"QUES","XP F1",0)
330	Y
331	"QUES","XP F1","??")
332	^D REP^XPD H
333	"QUES","XP F1","A")
334	Shall I wr ite over y our \|FLAG\| File
335	"QUES","XP F1","B")
336	YES
337	"QUES","XP F1","M")
338	D XPF1^XPD IQ
339	"QUES","XP F2",0)
340	Y
341	"QUES","XP F2","??")
342	^D DTA^XPD H
343	"QUES","XP F2","A")
344	Want my da ta \|FLAG\| yours
345	"QUES","XP F2","B")
346	YES
347	"QUES","XP F2","M")
348	D XPF2^XPD IQ
349	"QUES","XP I1",0)
350	YO
351	"QUES","XP I1","??")
352	^D INHIBIT ^XPDH
353	"QUES","XP I1","A")
354	Want KIDS to INHIBIT LOGONs du ring the i nstall
355	"QUES","XP I1","B")
356	NO
357	"QUES","XP I1","M")
358	D XPI1^XPD IQ
359	"QUES","XP M1",0)
360	PO^VA(200, :EM
361	"QUES","XP M1","??")
362	^D MG^XPDH
363	"QUES","XP M1","A")
364	Enter the Coordinato r for Mail Group '\|F LAG\|'
365	"QUES","XP M1","B")
366
367	"QUES","XP M1","M")
368	D XPM1^XPD IQ
369	"QUES","XP O1",0)
370	Y
371	"QUES","XP O1","??")
372	^D MENU^XP DH
373	"QUES","XP O1","A")
374	Want KIDS to Rebuild Menu Tree s Upon Com pletion of Install
375	"QUES","XP O1","B")
376	NO
377	"QUES","XP O1","M")
378	D XPO1^XPD IQ
379	"QUES","XP Z1",0)
380	Y
381	"QUES","XP Z1","??")
382	^D OPT^XPD H
383	"QUES","XP Z1","A")
384	Want to DI SABLE Sche duled Opti ons, Menu Options, a nd Protoco ls
385	"QUES","XP Z1","B")
386	YES
387	"QUES","XP Z1","M")
388	D XPZ1^XPD IQ
389	"QUES","XP Z2",0)
390	Y
391	"QUES","XP Z2","??")
392	^D RTN^XPD H
393	"QUES","XP Z2","A")
394	Want to MO VE routine s to other CPUs
395	"QUES","XP Z2","B")
396	NO
397	"QUES","XP Z2","M")
398	D XPZ2^XPD IQ
399	"RTN")
400	13
401	"RTN","DG5 3P935")
402	0^^B454000 1
403	"RTN","DG5 3P935",1,0 )
404	DG53P935 ; ALB/KUM - DG5.3935 POST INST ALL ;8/30/ 17 9:18am
405	"RTN","DG5 3P935",2,0 )
406	;;5.3;Reg istration; 935;Au g 13, 1993 ;Build 53
407	"RTN","DG5 3P935",3,0 )
408	;Per VHA Directive 2004-038, this routi ne should not be mod ified.
409	"RTN","DG5 3P935",4,0 )
410	;
411	"RTN","DG5 3P935",5,0 )
412	; DG5.3 935 Post I nstall rou tine to co rrect Vete ran Plan - Veterans Choice Wai t Time
413	"RTN","DG5 3P935",6,0 )
414	; Integr ation Agre ements:
415	"RTN","DG5 3P935",7,0 )
416	; 10141 : BM ES^XPDUTL
417	"RTN","DG5 3P935",8,0 )
418	; : ME S^XPDUTL
419	"RTN","DG5 3P935",9,0 )
420	; 2053 : FI LE^DIE
421	"RTN","DG5 3P935",10, 0)
422	; 2051 : FI ND1^DIC
423	"RTN","DG5 3P935",11, 0)
424	;
425	"RTN","DG5 3P935",12, 0)
426	Q
427	"RTN","DG5 3P935",13, 0)
428	;
429	"RTN","DG5 3P935",14, 0)
430	POST ;Upda te Health Benefit Pl an
431	"RTN","DG5 3P935",15, 0)
432	;
433	"RTN","DG5 3P935",16, 0)
434	D BMES^XP DUTL(" Checking E ntry in HE ALTH BENEF IT PLAN Fi le - Veter an Plan - Veterans C hoice Wait Time ")
435	"RTN","DG5 3P935",17, 0)
436	D UPDREQ
437	"RTN","DG5 3P935",18, 0)
438	Q
439	"RTN","DG5 3P935",19, 0)
440	;
441	"RTN","DG5 3P935",20, 0)
442	UPDREQ ; U pdate entr y in the H EALTH BENE FIT PLAN F ile (25.11 )
443	"RTN","DG5 3P935",21, 0)
444	;
445	"RTN","DG5 3P935",22, 0)
446	N IEN,ERR ,NAME,FDA, IEN1,NAME1
447	"RTN","DG5 3P935",23, 0)
448	S ERR=""
449	"RTN","DG5 3P935",24, 0)
450	S NAME="V eteran Pla n - Vetera ns Choice Wait Time"
451	"RTN","DG5 3P935",25, 0)
452	; Check i f entry ex ists, use it if it d oes
453	"RTN","DG5 3P935",26, 0)
454	S IEN=$$F IND1^DIC(2 5.11,,"B", NAME)
455	"RTN","DG5 3P935",27, 0)
456	I 'IEN D BMES^XPDUT L(" "_N AME_" does not exist , no actio n is taken . ") Q
457	"RTN","DG5 3P935",28, 0)
458	L +^DGHBP (25.11,IEN ):10 I '$T D BMES^XP DUTL(" "_NAME_" i s locked b y another user. Try later. " ) Q
459	"RTN","DG5 3P935",29, 0)
460	S IEN1=IE N
461	"RTN","DG5 3P935",30, 0)
462	S IEN=IEN _","
463	"RTN","DG5 3P935",31, 0)
464	;
465	"RTN","DG5 3P935",32, 0)
466	S FDA(25. 11,IEN,.01 )="Veteran Plan - Ve terans Cho ice Wait-T ime"
467	"RTN","DG5 3P935",33, 0)
468	; file n ew Address Change Da te/Time
469	"RTN","DG5 3P935",34, 0)
470	;
471	"RTN","DG5 3P935",35, 0)
472	D FILE^DI E("E","FDA ","ERR")
473	"RTN","DG5 3P935",36, 0)
474	L -^DGHBP (25.11,IEN 1)
475	"RTN","DG5 3P935",37, 0)
476	I ERR'="" D
477	"RTN","DG5 3P935",38, 0)
478	. D BMES^ XPDUTL(" *** An Error occu rred durin g updating Plan: Vet eran Plan - Veterans Choice Wa it Time")
479	"RTN","DG5 3P935",39, 0)
480	. D MES^X PDUTL(" Please l og CA SDM ticket.")
481	"RTN","DG5 3P935",40, 0)
482	. Q
483	"RTN","DG5 3P935",41, 0)
484	;
485	"RTN","DG5 3P935",42, 0)
486	I ERR="" D
487	"RTN","DG5 3P935",43, 0)
488	. S NAME1 =$P(^DGHBP (25.11,IEN 1,0),"^",1 )
489	"RTN","DG5 3P935",44, 0)
490	. D BMES^ XPDUTL(" "_NAME_" is correc ted in HEA LTH BENEFI T PLAN Fil e to "_NAM E1_".")
491	"RTN","DG5 3P935",45, 0)
492	Q
493	"RTN","DG5 3P935",46, 0)
494	;
495	"RTN","DGE NUPL1")
496	0^7^B54858 665
497	"RTN","DGE NUPL1",1,0 )
498	DGENUPL1 ; ALB/CJM,IS A,KWP,CKN, LBD,LMD,TD M,TGH,DJS - PROCESS INCOMING ( Z11 EVENT TYPE) HL7 MESSAGES ; 30 Oct 201 7 7:32PM
499	"RTN","DGE NUPL1",2,0 )
500	;;5.3;REG ISTRATION; 147,222, 232,314,39 7,379,407, 363,673,65 3,688,797, 842,894,87 1,935;Au g 13,1993; Build 53
501	"RTN","DGE NUPL1",3,0 )
502	;
503	"RTN","DGE NUPL1",4,0 )
504	PARSE(MSGI EN,MSGID,C URLINE,ERR COUNT,DGPA T,DGELG,DG ENR,DGCDIS ,DGOEIF,DG SEC,DGNTR, DGMST,DGNM SE,DGHBP) ;
505	"RTN","DGE NUPL1",5,0 )
506	;
507	"RTN","DGE NUPL1",6,0 )
508	;Descript ion: This function parses the HL7 segme nts. It c reates arr ays
509	"RTN","DGE NUPL1",7,0 )
510	;defined by the PAT IENT, ENRO LLMENT, EL IGIBILY, C ATASTROPHI C DISABILI TY,
511	"RTN","DGE NUPL1",8,0 )
512	;OEF/OIF CONFLICT o bjects.
513	"RTN","DGE NUPL1",9,0 )
514	;Field va lues are p ut in DHCP format an d the vali dity at th e
515	"RTN","DGE NUPL1",10, 0)
516	;field le vel is tes ted. Fiel ds to be d eleted are set to "@ ".
517	"RTN","DGE NUPL1",11, 0)
518	;
519	"RTN","DGE NUPL1",12, 0)
520	;Input:
521	"RTN","DGE NUPL1",13, 0)
522	; MSGIEN - the ien of the HL 7 message in the HL7 MESSAGE T EXT file ( 772)
523	"RTN","DGE NUPL1",14, 0)
524	; MSGID -message c ontrol id of HL7 msg in the MS H segment
525	"RTN","DGE NUPL1",15, 0)
526	; CURLIN E - the su bscript of the PID s egment of the curren t message (pass by r eference)
527	"RTN","DGE NUPL1",16, 0)
528	; ERRCOU NT - is a count of t he number of message s in the b atch that can not be processed (pass by ref)
529	"RTN","DGE NUPL1",17, 0)
530	;
531	"RTN","DGE NUPL1",18, 0)
532	;Output:
533	"RTN","DGE NUPL1",19, 0)
534	; Functi on Value: Returns 1 on success , 0 on fai lure.
535	"RTN","DGE NUPL1",20, 0)
536	; CURLIN E - upon l eaving the procedure this para meter shou ld be set to the end of the cu rrent mess age.
537	"RTN","DGE NUPL1",21, 0)
538	; ERRCOU NT - set t o count of messages that were not proces sed due to errors en countered. (pass by ref)
539	"RTN","DGE NUPL1",22, 0)
540	; DGPAT - array de fined by t he PATIENT object. ( pass by re f)
541	"RTN","DGE NUPL1",23, 0)
542	; DGENR - array de fined by t he PATIENT ENROLLMEN T object. (pass by r ef)
543	"RTN","DGE NUPL1",24, 0)
544	; DGELG - array de fined by t he PATIENT ELIGIBILI TY object. (pass by ref)
545	"RTN","DGE NUPL1",25, 0)
546	; DGCDIS - array d efined by the CATAST ROPHIC DIS ABILITY ob ject. (pas s by ref)
547	"RTN","DGE NUPL1",26, 0)
548	; DGSEC - array de fined by t he PATIENT SECURITY object. (p ass by ref )
549	"RTN","DGE NUPL1",27, 0)
550	; DGOEIF - array d efined by the OEF/OI F CONFLICT object. (pass by r ef)
551	"RTN","DGE NUPL1",28, 0)
552	; DGNTR - array de fined for NTR data.
553	"RTN","DGE NUPL1",29, 0)
554	; DGMST - array de fined for MST data.
555	"RTN","DGE NUPL1",30, 0)
556	; DGNMSE - array d efine for MILITARY S ERVICE EPI SODE data (pass by r ef)
557	"RTN","DGE NUPL1",31, 0)
558	; DGHBP - array de fine for H EALTH BENE FIT PLAN d ata (pass by ref) DG 5.3871
559	"RTN","DGE NUPL1",32, 0)
560	;
561	"RTN","DGE NUPL1",33, 0)
562	N SEG,ERR OR,COUNT,Q FLG,NFLG
563	"RTN","DGE NUPL1",34, 0)
564	;
565	"RTN","DGE NUPL1",35, 0)
566	;DJS, Set TMP globa l to track the prese nce of ZMH segment; DG5.3935
567	"RTN","DGE NUPL1",36, 0)
568	K ^TMP($J ,"DGENUPL" ) S ^TMP($ J,"DGENUPL ","ZMH",0) =0
569	"RTN","DGE NUPL1",37, 0)
570	;
571	"RTN","DGE NUPL1",38, 0)
572	K DGEN,DG PAT,DGELG, DGCDIS,DGN TR,DGMST
573	"RTN","DGE NUPL1",39, 0)
574	;
575	"RTN","DGE NUPL1",40, 0)
576	S ERROR=0 ,NFLG=1
577	"RTN","DGE NUPL1",41, 0)
578	F SEG="PI D","ZPD"," ZIE","ZIO" ,"ZEL" D Q:ERROR
579	"RTN","DGE NUPL1",42, 0)
580	.D:NFLG N XTSEG^DGEN UPL(MSGIEN ,.CURLINE, .SEG)
581	"RTN","DGE NUPL1",43, 0)
582	.I SEG="Z IO",SEG("T YPE")'="ZI O" S NFLG= 0 Q
583	"RTN","DGE NUPL1",44, 0)
584	.I SEG("T YPE")=SEG D Q
585	"RTN","DGE NUPL1",45, 0)
586	..I SEG'= "ZEL" N DG RTN S DGRT N=SEG_"^DG ENUPL2" D @DGRTN ; DG5.3 894
587	"RTN","DGE NUPL1",46, 0)
588	..D:(SEG= "ZEL") ZEL ^DGENUPL2( 1)
589	"RTN","DGE NUPL1",47, 0)
590	..S NFLG= 1
591	"RTN","DGE NUPL1",48, 0)
592	.D ADDERR OR^DGENUPL (MSGID,$G( DGPAT("SSN ")),SEG_" SEGMENT MI SSING OR O UT OF ORDE R",.ERRCOU NT)
593	"RTN","DGE NUPL1",49, 0)
594	.S ERROR= 1
595	"RTN","DGE NUPL1",50, 0)
596	.;
597	"RTN","DGE NUPL1",51, 0)
598	.;possibl e that in a bad mess age we are now past the end
599	"RTN","DGE NUPL1",52, 0)
600	.S CURLIN E=CURLINE- 1
601	"RTN","DGE NUPL1",53, 0)
602	;
603	"RTN","DGE NUPL1",54, 0)
604	;DJS, Set segment b efore proc essing pos sible mult iple segme nts; DG5. 3935
605	"RTN","DGE NUPL1",55, 0)
606	I 'ERROR S SEG="ZEL " F COUNT= 2:1 D NXTS EG^DGENUPL (MSGIEN,CU RLINE,.SEG ) Q:(SEG(" TYPE")'="Z EL") D Q :ERROR
607	"RTN","DGE NUPL1",56, 0)
608	.S CURLIN E=CURLINE+ 1
609	"RTN","DGE NUPL1",57, 0)
610	.D ZEL^DG ENUPL2(COU NT)
611	"RTN","DGE NUPL1",58, 0)
612	;
613	"RTN","DGE NUPL1",59, 0)
614	;ZE2 is o ptional, I f no ZE2 s egment del ete pensio n data
615	"RTN","DGE NUPL1",60, 0)
616	I 'ERROR D
617	"RTN","DGE NUPL1",61, 0)
618	.I SEG("T YPE")="ZE2 " D ZE2^DG ENUPLB S C URLINE=CUR LINE+1 Q
619	"RTN","DGE NUPL1",62, 0)
620	.I SEG("T YPE")'="ZE 2" D
621	"RTN","DGE NUPL1",63, 0)
622	..Q:$$GET 1^DIQ(2,DF N,.3852,"I ")=$O(^DG( 27.18,"C", "00",""))
623	"RTN","DGE NUPL1",64, 0)
624	..N PSUB
625	"RTN","DGE NUPL1",65, 0)
626	..F PSUB= "PENAEFDT" ,"PENTRMDT ","PENAREA S","PENTRM R1","PENTR MR2","PENT RMR3","PEN TRMR4" S D GPAT(PSUB) ="@"
627	"RTN","DGE NUPL1",66, 0)
628	;
629	"RTN","DGE NUPL1",67, 0)
630	;ZHP is o ptional & can repeat . DG5.38 71
631	"RTN","DGE NUPL1",68, 0)
632	K DGHBP
633	"RTN","DGE NUPL1",69, 0)
634	;DJS, Add ed call to extrinsic function to determi ne if mult iple segme nts are pr esent ; DG 5.3935
635	"RTN","DGE NUPL1",70, 0)
636	I 'ERROR S SEG="ZHP " I $$CHKN XT(CURLINE +1,SEG) D Q:ERROR $ S(ERROR:0, 1:1)
637	"RTN","DGE NUPL1",71, 0)
638	. D NXTSE G^DGENUPL( MSGIEN,.CU RLINE,.SEG )
639	"RTN","DGE NUPL1",72, 0)
640	. S QFLG= 0 F D Q: QFLG
641	"RTN","DGE NUPL1",73, 0)
642	. . I SEG ("TYPE")'= "ZHP" S QF LG=1,CURLI NE=CURLINE -1 Q
643	"RTN","DGE NUPL1",74, 0)
644	. . D ZHP ^DGENUPLB
645	"RTN","DGE NUPL1",75, 0)
646	. . D NXT SEG^DGENUP L(MSGIEN,. CURLINE,.S EG)
647	"RTN","DGE NUPL1",76, 0)
648	;
649	"RTN","DGE NUPL1",77, 0)
650	;Phase II Add the c apability to accept more than 1 ZCD
651	"RTN","DGE NUPL1",78, 0)
652	I 'ERROR F SEG="ZEN ","ZMT","Z CD" D Q:E RROR
653	"RTN","DGE NUPL1",79, 0)
654	.D NXTSEG ^DGENUPL(M SGIEN,.CUR LINE,.SEG)
655	"RTN","DGE NUPL1",80, 0)
656	.I SEG("T YPE")=SEG D
657	"RTN","DGE NUPL1",81, 0)
658	..N DGRTN S DGRTN=S EG_"^DGENU PL2" D @DG RTN ; DG5.3894
659	"RTN","DGE NUPL1",82, 0)
660	.E D
661	"RTN","DGE NUPL1",83, 0)
662	..D ADDER ROR^DGENUP L(MSGID,$G (DGPAT("SS N")),SEG_" SEGMENT M ISSING OR OUT OF ORD ER",.ERRCO UNT)
663	"RTN","DGE NUPL1",84, 0)
664	..S ERROR =1
665	"RTN","DGE NUPL1",85, 0)
666	..;
667	"RTN","DGE NUPL1",86, 0)
668	..;possib le that in a bad mes sage we ar e now past the end
669	"RTN","DGE NUPL1",87, 0)
670	..S CURLI NE=CURLINE -1
671	"RTN","DGE NUPL1",88, 0)
672	;
673	"RTN","DGE NUPL1",89, 0)
674	;DJS, Add ed call to extrinsic function to determi ne if mult iple segme nts are pr esent ; DG 5.3935
675	"RTN","DGE NUPL1",90, 0)
676	I 'ERROR S SEG="ZCD " I $$CHKN XT(CURLINE +1,SEG) F COUNT=2:1 D NXTSEG^D GENUPL(MSG IEN,CURLIN E,.SEG) Q: (SEG("TYPE ")'="ZCD") D Q:ERR OR
677	"RTN","DGE NUPL1",91, 0)
678	.S CURLIN E=CURLINE+ 1
679	"RTN","DGE NUPL1",92, 0)
680	.D ZCD^DG ENUPL2
681	"RTN","DGE NUPL1",93, 0)
682	;
683	"RTN","DGE NUPL1",94, 0)
684	; Purple Heart/OEF- OIF Addit ion of opt ional ZMH segment
685	"RTN","DGE NUPL1",95, 0)
686	; Modi fied handl ing of ZSP and ZRD t o accomoda te ZMH
687	"RTN","DGE NUPL1",96, 0)
688	;
689	"RTN","DGE NUPL1",97, 0)
690	;DJS, Add ed call to extrinsic function to determi ne if mult iple segme nts are pr esent ; DG 5.3935
691	"RTN","DGE NUPL1",98, 0)
692	I 'ERROR S SEG="ZSP " I $$CHKN XT(CURLINE +1,SEG) D Q:ERROR $ S(ERROR:0, 1:1)
693	"RTN","DGE NUPL1",99, 0)
694	.D NXTSEG ^DGENUPL(M SGIEN,.CUR LINE,.SEG)
695	"RTN","DGE NUPL1",100 ,0)
696	.I SEG("T YPE")="ZSP " D ZSP^DG ENUPL2 Q
697	"RTN","DGE NUPL1",101 ,0)
698	.D ADDERR OR^DGENUPL (MSGID,$G( DGPAT("SSN ")),SEG_" SEGMENT MI SSING OR O UT OF ORDE R",.ERRCOU NT)
699	"RTN","DGE NUPL1",102 ,0)
700	.S ERROR= 1
701	"RTN","DGE NUPL1",103 ,0)
702	.;possibl e that in a bad mess age we are now past the end
703	"RTN","DGE NUPL1",104 ,0)
704	.S CURLIN E=CURLINE- 1
705	"RTN","DGE NUPL1",105 ,0)
706	;
707	"RTN","DGE NUPL1",106 ,0)
708	;Modified following code to r eceive mul tiple ZMH segment fo r
709	"RTN","DGE NUPL1",107 ,0)
710	;Military service i nformation - DG5.3 653
711	"RTN","DGE NUPL1",108 ,0)
712	;
713	"RTN","DGE NUPL1",109 ,0)
714	;DJS, Add ed call to extrinsic function to determi ne if mult iple segme nts are pr esent ; DG 5.3935
715	"RTN","DGE NUPL1",110 ,0)
716	I 'ERROR S SEG="ZMH " D Q:ERR OR
717	"RTN","DGE NUPL1",111 ,0)
718	.;DJS, No ZMH segme nt present , so branc h to DGNOZ MH; DG5.3 935
719	"RTN","DGE NUPL1",112 ,0)
720	.I '$$CHK NXT(CURLIN E+1,SEG) I ^TMP($J," DGENUPL"," ZMH",0)=0 D EN^DGNOZ MH(DFN) K ^TMP($J,"D GENUPL") Q
721	"RTN","DGE NUPL1",113 ,0)
722	.S QFLG=0 F D Q:Q FLG!(ERROR )
723	"RTN","DGE NUPL1",114 ,0)
724	..I '$$CH KNXT(CURLI NE+1,SEG) S QFLG=1 Q
725	"RTN","DGE NUPL1",115 ,0)
726	..D NXTSE G^DGENUPL( MSGIEN,.CU RLINE,.SEG )
727	"RTN","DGE NUPL1",116 ,0)
728	..D ZMH^D GENUPL2
729	"RTN","DGE NUPL1",117 ,0)
730	..Q
731	"RTN","DGE NUPL1",118 ,0)
732	.Q
733	"RTN","DGE NUPL1",119 ,0)
734	;
735	"RTN","DGE NUPL1",120 ,0)
736	;DJS, Add ed call to extrinsic function to determi ne if mult iple segme nts are pr esent ; DG 5.3935
737	"RTN","DGE NUPL1",121 ,0)
738	I 'ERROR S SEG="ZRD " I $$CHKN XT(CURLINE +1,SEG) F COUNT=2:1 D NXTSEG^D GENUPL(MSG IEN,CURLIN E,.SEG) Q: (SEG("TYPE ")'="ZRD") D Q:ERR OR
739	"RTN","DGE NUPL1",122 ,0)
740	.S CURLIN E=CURLINE+ 1
741	"RTN","DGE NUPL1",123 ,0)
742	.D ZRD^DG ENUPL2
743	"RTN","DGE NUPL1",124 ,0)
744	;
745	"RTN","DGE NUPL1",125 ,0)
746	;DJS, Add ed call to extrinsic function to determi ne if mult iple segme nts are pr esent ; DG 5.3935
747	"RTN","DGE NUPL1",126 ,0)
748	I 'ERROR S SEG="OBX " F D Q: (ERROR!('$ $CHKNXT(CU RLINE+1,SE G)))
749	"RTN","DGE NUPL1",127 ,0)
750	.;possibl e if OBX s egment not present t hat we are now past the end
751	"RTN","DGE NUPL1",128 ,0)
752	.Q:'$$CHK NXT(CURLIN E+1,SEG)
753	"RTN","DGE NUPL1",129 ,0)
754	.D NXTSEG ^DGENUPL(M SGIEN,.CUR LINE,.SEG)
755	"RTN","DGE NUPL1",130 ,0)
756	.D OBX^DG ENUPL2
757	"RTN","DGE NUPL1",131 ,0)
758	.Q
759	"RTN","DGE NUPL1",132 ,0)
760	;
761	"RTN","DGE NUPL1",133 ,0)
762	Q $S(ERRO R:0,1:1)
763	"RTN","DGE NUPL1",134 ,0)
764	;
765	"RTN","DGE NUPL1",135 ,0)
766	CONVERT(VA L,DATATYPE ,ERROR) ;
767	"RTN","DGE NUPL1",136 ,0)
768	;Descript ion: Conve rts the va lue found in the HL7 segment t o DHCP for mat
769	"RTN","DGE NUPL1",137 ,0)
770	;
771	"RTN","DGE NUPL1",138 ,0)
772	;Input:
773	"RTN","DGE NUPL1",139 ,0)
774	; VAL - value pars ed from th e HL7 segm ent
775	"RTN","DGE NUPL1",140 ,0)
776	; DATATY PE: indica tes the ty pe of conv ersion nec essary
777	"RTN","DGE NUPL1",141 ,0)
778	; "D ATE" - nee ds to be c onverted t o FM forma t
779	"RTN","DGE NUPL1",142 ,0)
780	; "T S" - time stamp, nee ds to be c onverted t o FM forma t
781	"RTN","DGE NUPL1",143 ,0)
782	; "Y /N" - 0->" N",1->"Y"
783	"RTN","DGE NUPL1",144 ,0)
784	; "1 /0" - "Y"- >1,"N"->0
785	"RTN","DGE NUPL1",145 ,0)
786	; "I NSTITUTION " - needs to convert the stati on number with suffi x to a poi nt to the INSTITUTIO N file
787	"RTN","DGE NUPL1",146 ,0)
788	; "E LIGIBILITY " - VAL is a pointer to the na tional eli gibility c ode file ( #8.1), nee ds to be c onverted t o a local eligibilit y code (fi le #8)
789	"RTN","DGE NUPL1",147 ,0)
790	;
791	"RTN","DGE NUPL1",148 ,0)
792	; "M T" - VAL is a Means Test Stat us code, i t needs to be conver ted
793	"RTN","DGE NUPL1",149 ,0)
794	; to a pointer to the Means Test Stat us file
795	"RTN","DGE NUPL1",150 ,0)
796	; P hase II co nvert code to RSN IE N for DGCD IS object
797	"RTN","DGE NUPL1",151 ,0)
798	; " CDRSN" dat a type con verts the codes diag nosis,proc edure,cond ition to R SN IEN. (H L7TORSN^DG ENA5)
799	"RTN","DGE NUPL1",152 ,0)
800	; " CDDSCR" da ta type co nverts the codes des criptor(s) to DSCR I EN. (HL7TO DSC^DGENA5 ) DG5.3 894
801	"RTN","DGE NUPL1",153 ,0)
802	; " EXT" conve rt from co de to abbr eviation
803	"RTN","DGE NUPL1",154 ,0)
804	; " POS" conve rt from Pe riod of Se rvice code to a poin t to Perio d of Servi ce file
805	"RTN","DGE NUPL1",155 ,0)
806	; " AGENCY" co nvert Agen cy/Allied Country co de from fi le 35
807	"RTN","DGE NUPL1",156 ,0)
808	; " PENSIONCD" convert P ension Awa rd/Termina tion Reaso n code fro m file 27. 18
809	"RTN","DGE NUPL1",157 ,0)
810	; " HBP" conve rt from co de to file 25.11 ien DG5.387 1
811	"RTN","DGE NUPL1",158 ,0)
812	;OUTPUT:
813	"RTN","DGE NUPL1",159 ,0)
814	; Functi on Value - the resul t of the c onversion
815	"RTN","DGE NUPL1",160 ,0)
816	; ERROR - set to 1 if an err or is dete cted, 0 ot herwise (o ptional,pa ss by ref)
817	"RTN","DGE NUPL1",161 ,0)
818	S ERROR=0
819	"RTN","DGE NUPL1",162 ,0)
820	D
821	"RTN","DGE NUPL1",163 ,0)
822	.I VAL="" Q
823	"RTN","DGE NUPL1",164 ,0)
824	.I VAL="" """" S VAL ="@" Q
825	"RTN","DGE NUPL1",165 ,0)
826	.I $G(DAT ATYPE)="EX T" D Q
827	"RTN","DGE NUPL1",166 ,0)
828	..S VAL=$ $HLTOLIMB^ DGENA5(VAL )
829	"RTN","DGE NUPL1",167 ,0)
830	.I $G(DAT ATYPE)="CD RSN" D Q
831	"RTN","DGE NUPL1",168 ,0)
832	..S VAL=$ $HL7TORSN^ DGENA5(VAL )
833	"RTN","DGE NUPL1",169 ,0)
834	.; * chec k the new DESCRIPTOR seq - D G5.3894
835	"RTN","DGE NUPL1",170 ,0)
836	.I $G(DAT ATYPE)="CD DSCR" D Q
837	"RTN","DGE NUPL1",171 ,0)
838	..S VAL=$ $HL7TODSC^ DGENA5(VAL )
839	"RTN","DGE NUPL1",172 ,0)
840	.I ($G(DA TATYPE)="M T") D Q
841	"RTN","DGE NUPL1",173 ,0)
842	..S VAL=$ O(^DG(408. 32,"AC",1, VAL,0))
843	"RTN","DGE NUPL1",174 ,0)
844	..I 'VAL S ERROR=1
845	"RTN","DGE NUPL1",175 ,0)
846	.I ($G(DA TATYPE)="D ATE") D Q
847	"RTN","DGE NUPL1",176 ,0)
848	..I $L(VA L)'=8 S ER ROR=1 Q
849	"RTN","DGE NUPL1",177 ,0)
850	..S VAL=$ $FMDATE^HL FNC(VAL)
851	"RTN","DGE NUPL1",178 ,0)
852	..I ((VAL '=+VAL)!($ L($P(VAL," ."))<7)) S ERROR=1
853	"RTN","DGE NUPL1",179 ,0)
854	.I ($G(DA TATYPE)="T S") D Q
855	"RTN","DGE NUPL1",180 ,0)
856	..I $L(VA L)<8 S ERR OR=1 Q
857	"RTN","DGE NUPL1",181 ,0)
858	..S VAL=$ $FMDATE^HL FNC(VAL)
859	"RTN","DGE NUPL1",182 ,0)
860	..I ((VAL '=+VAL)!($ L($P(VAL," ."))<7)) S ERROR=1
861	"RTN","DGE NUPL1",183 ,0)
862	.I ($G(DA TATYPE)="Y /N") D Q
863	"RTN","DGE NUPL1",184 ,0)
864	..I VAL=0 S VAL="N" Q
865	"RTN","DGE NUPL1",185 ,0)
866	..I VAL=1 S VAL="Y" Q
867	"RTN","DGE NUPL1",186 ,0)
868	..S ERROR =1
869	"RTN","DGE NUPL1",187 ,0)
870	.I ($G(DA TATYPE)="1 /0") D Q
871	"RTN","DGE NUPL1",188 ,0)
872	..I VAL=" N" S VAL=0 Q
873	"RTN","DGE NUPL1",189 ,0)
874	..I VAL=" Y" S VAL=1 Q
875	"RTN","DGE NUPL1",190 ,0)
876	..S ERROR =1
877	"RTN","DGE NUPL1",191 ,0)
878	.I ($G(DA TATYPE)="E LIGIBILITY ") D Q
879	"RTN","DGE NUPL1",192 ,0)
880	..S VAL=$ $MAP(VAL)
881	"RTN","DGE NUPL1",193 ,0)
882	..I 'VAL S ERROR=1
883	"RTN","DGE NUPL1",194 ,0)
884	.I ($G(DA TATYPE)="I NSTITUTION ") D Q
885	"RTN","DGE NUPL1",195 ,0)
886	..N OLDVA L
887	"RTN","DGE NUPL1",196 ,0)
888	..S OLDVA L=VAL
889	"RTN","DGE NUPL1",197 ,0)
890	..S VAL=$ O(^DIC(4," D",OLDVAL, 0))
891	"RTN","DGE NUPL1",198 ,0)
892	..I 'VAL S VAL=$O(^ DIC(4,"D", (+OLDVAL), 0))
893	"RTN","DGE NUPL1",199 ,0)
894	..I 'VAL S ERROR=1
895	"RTN","DGE NUPL1",200 ,0)
896	.I ($G(DA TATYPE)="P OS") D Q
897	"RTN","DGE NUPL1",201 ,0)
898	..N OLDVA L
899	"RTN","DGE NUPL1",202 ,0)
900	..S OLDVA L=VAL
901	"RTN","DGE NUPL1",203 ,0)
902	..S VAL=$ O(^DIC(21, "D",OLDVAL ,0))
903	"RTN","DGE NUPL1",204 ,0)
904	..I 'VAL S ERROR=1
905	"RTN","DGE NUPL1",205 ,0)
906	.I ($G(DA TATYPE)="A GENCY") D Q
907	"RTN","DGE NUPL1",206 ,0)
908	..N OLDVA L
909	"RTN","DGE NUPL1",207 ,0)
910	..S OLDVA L=VAL
911	"RTN","DGE NUPL1",208 ,0)
912	..S VAL=$ O(^DIC(35, "C",OLDVAL ,0))
913	"RTN","DGE NUPL1",209 ,0)
914	..I 'VAL S ERROR=1
915	"RTN","DGE NUPL1",210 ,0)
916	.I ($G(DA TATYPE)="P ENSIONCD") D Q
917	"RTN","DGE NUPL1",211 ,0)
918	..N OLDVA L
919	"RTN","DGE NUPL1",212 ,0)
920	..S OLDVA L=VAL
921	"RTN","DGE NUPL1",213 ,0)
922	..S VAL=$ O(^DG(27.1 8,"C",OLDV AL,0))
923	"RTN","DGE NUPL1",214 ,0)
924	..I 'VAL S ERROR=1
925	"RTN","DGE NUPL1",215 ,0)
926	.I ($G(DA TATYPE)="H BP") D Q ; DG5. 3871
927	"RTN","DGE NUPL1",216 ,0)
928	..N OLDVA L
929	"RTN","DGE NUPL1",217 ,0)
930	..S OLDVA L=VAL
931	"RTN","DGE NUPL1",218 ,0)
932	..S VAL=$ O(^DGHBP(2 5.11,"C",O LDVAL,0))
933	"RTN","DGE NUPL1",219 ,0)
934	..I 'VAL S ERROR=1
935	"RTN","DGE NUPL1",220 ,0)
936	Q VAL
937	"RTN","DGE NUPL1",221 ,0)
938	;
939	"RTN","DGE NUPL1",222 ,0)
940	MAP(VALUE) ;
941	"RTN","DGE NUPL1",223 ,0)
942	;Descript ion: Tries to map an eligibili ty code fr om file #8 .1 (the na tional MAS ELIGIBILI TY CODE fi le) to fil e #8 (the local ELIG IBILITY CO DE file)
943	"RTN","DGE NUPL1",224 ,0)
944	;
945	"RTN","DGE NUPL1",225 ,0)
946	;Input: V ALUE - ien of an ent ry in file #8.1
947	"RTN","DGE NUPL1",226 ,0)
948	;
949	"RTN","DGE NUPL1",227 ,0)
950	;Output: Function v alue - NUL L if mappi ng is not found, oth erwise ret urns an ie n of entry in file # 8
951	"RTN","DGE NUPL1",228 ,0)
952	;
953	"RTN","DGE NUPL1",229 ,0)
954	N ECODE,N ODE,COUNT, NAME
955	"RTN","DGE NUPL1",230 ,0)
956	;try to c hoose a co de from fi le 8 to us e that is appropriat e
957	"RTN","DGE NUPL1",231 ,0)
958	S (COUNT, ECODE)=0
959	"RTN","DGE NUPL1",232 ,0)
960	;
961	"RTN","DGE NUPL1",233 ,0)
962	F S ECOD E=$O(^DIC( 8,"D",VALU E,ECODE)) Q:'ECODE D
963	"RTN","DGE NUPL1",234 ,0)
964	.S NODE=$ G(^DIC(8,E CODE,0))
965	"RTN","DGE NUPL1",235 ,0)
966	.;put cod e on list if active
967	"RTN","DGE NUPL1",236 ,0)
968	.I (NODE' =""),'$P(N ODE,"^",7) S ECODE(E CODE)=$P(N ODE,"^"),C OUNT=COUNT +1
969	"RTN","DGE NUPL1",237 ,0)
970	;
971	"RTN","DGE NUPL1",238 ,0)
972	;only one match fou nd, so use it
973	"RTN","DGE NUPL1",239 ,0)
974	Q:COUNT=1 $O(ECODE( 0))
975	"RTN","DGE NUPL1",240 ,0)
976	;
977	"RTN","DGE NUPL1",241 ,0)
978	;no match found
979	"RTN","DGE NUPL1",242 ,0)
980	Q:'COUNT ""
981	"RTN","DGE NUPL1",243 ,0)
982	;
983	"RTN","DGE NUPL1",244 ,0)
984	;multiple matches f ound, try to match b y name
985	"RTN","DGE NUPL1",245 ,0)
986	I COUNT>1 D
987	"RTN","DGE NUPL1",246 ,0)
988	.S ECODE= 0
989	"RTN","DGE NUPL1",247 ,0)
990	.S NAME=$ P($G(^DIC( 8.1,VALUE, 0)),"^")
991	"RTN","DGE NUPL1",248 ,0)
992	.F S ECO DE=$O(ECOD E(ECODE)) Q:'ECODE Q:ECODE(EC ODE)=NAME
993	"RTN","DGE NUPL1",249 ,0)
994	Q ECODE
995	"RTN","DGE NUPL1",250 ,0)
996	;
997	"RTN","DGE NUPL1",251 ,0)
998	ACCEPT(MSG ID) ;
999	"RTN","DGE NUPL1",252 ,0)
1000	;Descript ion: Write s an ack ( AA) to a g lobal to b e transmit ted later.
1001	"RTN","DGE NUPL1",253 ,0)
1002	;
1003	"RTN","DGE NUPL1",254 ,0)
1004	;Inputs:
1005	"RTN","DGE NUPL1",255 ,0)
1006	; MSGID -message c ontrol id of HL7 msg in the MS H segment
1007	"RTN","DGE NUPL1",256 ,0)
1008	;
1009	"RTN","DGE NUPL1",257 ,0)
1010	;Outputs: none
1011	"RTN","DGE NUPL1",258 ,0)
1012	;
1013	"RTN","DGE NUPL1",259 ,0)
1014	K HL,HLMI D,HLMTIEN, HLDT,HLDT1
1015	"RTN","DGE NUPL1",260 ,0)
1016	D INIT^HL FNC2(HLEID ,.HL)
1017	"RTN","DGE NUPL1",261 ,0)
1018	D CREATE^ HLTF(.HLMI D,.HLMTIEN ,.HLDT,.HL DT1)
1019	"RTN","DGE NUPL1",262 ,0)
1020	S HLEVN=1
1021	"RTN","DGE NUPL1",263 ,0)
1022	S MID=HLM ID_"-"_HLE VN
1023	"RTN","DGE NUPL1",264 ,0)
1024	D MSH^HLF NC2(.HL,MI D,.HLRES)
1025	"RTN","DGE NUPL1",265 ,0)
1026	S ^TMP("H LS",$J,1)= HLRES
1027	"RTN","DGE NUPL1",266 ,0)
1028	;
1029	"RTN","DGE NUPL1",267 ,0)
1030	;it seems HLFS some times disa ppears upo n reaching this poin t
1031	"RTN","DGE NUPL1",268 ,0)
1032	I $G(HLFS )="" S HLF S="^"
1033	"RTN","DGE NUPL1",269 ,0)
1034	;
1035	"RTN","DGE NUPL1",270 ,0)
1036	S ^TMP("H LS",$J,2)= "MSA"_HLFS _"AA"_HLFS _MSGID
1037	"RTN","DGE NUPL1",271 ,0)
1038	Q
1039	"RTN","DGE NUPL1",272 ,0)
1040	;
1041	"RTN","DGE NUPL1",273 ,0)
1042	MVERRORS ;
1043	"RTN","DGE NUPL1",274 ,0)
1044	;Error me ssages wer e being de leted from ^TMP("HLS ",$J by an other pack age
1045	"RTN","DGE NUPL1",275 ,0)
1046	;during t he upload. To fix t his, error s are writ ten to ano ther
1047	"RTN","DGE NUPL1",276 ,0)
1048	;subscrip t, then mo ved when t he error l ist is com plete.
1049	"RTN","DGE NUPL1",277 ,0)
1050	;
1051	"RTN","DGE NUPL1",278 ,0)
1052	M ^TMP("H LS",$J)=^T MP("IVM"," HLS",$J)
1053	"RTN","DGE NUPL1",279 ,0)
1054	K ^TMP("I VM","HLS", $J)
1055	"RTN","DGE NUPL1",280 ,0)
1056	Q
1057	"RTN","DGE NUPL1",281 ,0)
1058	;
1059	"RTN","DGE NUPL1",282 ,0)
1060	;DJS, Add ed Extrins ic Functio n to deter mine if mu ltiple seg ments are present ; DG5.3935
1061	"RTN","DGE NUPL1",283 ,0)
1062	CHKNXT(DGN VAL,DGNSEG ) ; Check the SEG in the next segment ma nually
1063	"RTN","DGE NUPL1",284 ,0)
1064	; DGNVAL = CURLINE or CURLINE +1
1065	"RTN","DGE NUPL1",285 ,0)
1066	; DGNSEG = SEG (3 c haracter S EG)
1067	"RTN","DGE NUPL1",286 ,0)
1068	; Returns 1 if ther e is a mat ch or 0 if there is no match
1069	"RTN","DGE NUPL1",287 ,0)
1070	;
1071	"RTN","DGE NUPL1",288 ,0)
1072	Q $S($E($ G(^TMP($J, IVMRTN,+DG NVAL,0)),1 ,3)=DGNSEG :1,1:0)
1073	"RTN","DGE NUPL3")
1074	0^5^B89567 535
1075	"RTN","DGE NUPL3",1,0 )
1076	DGENUPL3 ; ALB/CJM,IS A,KWP,AEG, BRM,ERC,CK N,BAJ,PHH, TDM,LBD,DJ S - PROCES S INCOMING (Z11 EVEN T TYPE) HL 7 MESSAGES ;28 Sep 2 017 5:35P M
1077	"RTN","DGE NUPL3",2,0 )
1078	;;5.3;REG ISTRATION; 147,230, 232,377,40 4,451,653, 688,793,79 7,841,928, 935;Aug 13,1993;Bu ild 53
1079	"RTN","DGE NUPL3",3,0 )
1080	;
1081	"RTN","DGE NUPL3",4,0 )
1082	;
1083	"RTN","DGE NUPL3",5,0 )
1084	ADDMSG(MSG S,MESSAGE, TOHEC) ;
1085	"RTN","DGE NUPL3",6,0 )
1086	;Descript ion: Used to add a m essage to an array o f messages to be sen t.
1087	"RTN","DGE NUPL3",7,0 )
1088	;
1089	"RTN","DGE NUPL3",8,0 )
1090	;Input:
1091	"RTN","DGE NUPL3",9,0 )
1092	; MSGS - the array to store the messag e (pass by reference )
1093	"RTN","DGE NUPL3",10, 0)
1094	; MESSAG E - the me ssage to s tore
1095	"RTN","DGE NUPL3",11, 0)
1096	; TOHEC - a flag, if set to 1 it means that HEC should als o receive notificati on
1097	"RTN","DGE NUPL3",12, 0)
1098	;
1099	"RTN","DGE NUPL3",13, 0)
1100	;Output: none
1101	"RTN","DGE NUPL3",14, 0)
1102	;
1103	"RTN","DGE NUPL3",15, 0)
1104	I MESSAGE ["DATE OF DEATH" Q
1105	"RTN","DGE NUPL3",16, 0)
1106	S MSGS(0) =($G(MSGS( 0))+1)
1107	"RTN","DGE NUPL3",17, 0)
1108	S MSGS(MS GS(0))=MES SAGE
1109	"RTN","DGE NUPL3",18, 0)
1110	I ($G(TOH EC)=1) S M SGS("HEC") =1
1111	"RTN","DGE NUPL3",19, 0)
1112	Q
1113	"RTN","DGE NUPL3",20, 0)
1114	;
1115	"RTN","DGE NUPL3",21, 0)
1116	;
1117	"RTN","DGE NUPL3",22, 0)
1118	NOTIFY(DGP AT,MSGS) ;
1119	"RTN","DGE NUPL3",23, 0)
1120	;Descript ion: This is used to send a me ssage to t he local m ail group
1121	"RTN","DGE NUPL3",24, 0)
1122	;defined by the MAS Parameter ELIGIBILI TY UPLOAD MAIL GROUP .The
1123	"RTN","DGE NUPL3",25, 0)
1124	;notifica tion is to be used w hen specif ic problem s or condi tions
1125	"RTN","DGE NUPL3",26, 0)
1126	;regardin g the uplo ad of the enrollment or eligib ility data .
1127	"RTN","DGE NUPL3",27, 0)
1128	;
1129	"RTN","DGE NUPL3",28, 0)
1130	;Input:
1131	"RTN","DGE NUPL3",29, 0)
1132	; OLDPAT -used if the DGPAT elements h ave not be en built
1133	"RTN","DGE NUPL3",30, 0)
1134	; DGPAT - patient array (pas s by refer ence)
1135	"RTN","DGE NUPL3",31, 0)
1136	; MSGS - the an ar ray of mes sages that should be included in the
1137	"RTN","DGE NUPL3",32, 0)
1138	; notificat ion (pass by referen ce). If MS GS("HEC")= 1
1139	"RTN","DGE NUPL3",33, 0)
1140	; it means that HEC s hould also receive n otificatio n.
1141	"RTN","DGE NUPL3",34, 0)
1142	;
1143	"RTN","DGE NUPL3",35, 0)
1144	;Output: none
1145	"RTN","DGE NUPL3",36, 0)
1146	;
1147	"RTN","DGE NUPL3",37, 0)
1148	N TEXT,XM DUZ,XMTEXT ,XMSUB,XMS TRIP,XMROU ,XMY,XMZ,X MDF,COUNT
1149	"RTN","DGE NUPL3",38, 0)
1150	N HEADER, NSC,POW,TM PSTR,MAILG RP,ELIG,CD ,DGFDD
1151	"RTN","DGE NUPL3",39, 0)
1152	;
1153	"RTN","DGE NUPL3",40, 0)
1154	;if there are no al erts, then quit
1155	"RTN","DGE NUPL3",41, 0)
1156	Q:'$G(MSG S(0))
1157	"RTN","DGE NUPL3",42, 0)
1158	;
1159	"RTN","DGE NUPL3",43, 0)
1160	;Get reas on for ale rt. If th ere is mor e than one reason de cide which
1161	"RTN","DGE NUPL3",44, 0)
1162	;reason t o display. 'NON-SER VICE' aler ts have a higher pri ority than
1163	"RTN","DGE NUPL3",45, 0)
1164	;other al erts and a re therefo re display ed before other aler ts in the
1165	"RTN","DGE NUPL3",46, 0)
1166	;subject line, foll owed by 'P OW' alerts in priori ty.
1167	"RTN","DGE NUPL3",47, 0)
1168	S (ELIG,N SC,POW,CD) =0
1169	"RTN","DGE NUPL3",48, 0)
1170	S COUNT=0 F S COUN T=$O(MSGS( COUNT)) Q: 'COUNT!NSC D
1171	"RTN","DGE NUPL3",49, 0)
1172	.I MSGS(C OUNT)["PRE VIOUSLY EL IGIBLE" S ELIG=1 Q
1173	"RTN","DGE NUPL3",50, 0)
1174	.I MSGS(C OUNT)["NON -SERVICE" S NSC=1 Q
1175	"RTN","DGE NUPL3",51, 0)
1176	.I MSGS(C OUNT)["POW " S POW=1 Q
1177	"RTN","DGE NUPL3",52, 0)
1178	.I MSGS(C OUNT)["CD EVALUATION " S CD=1 Q
1179	"RTN","DGE NUPL3",53, 0)
1180	.S HEADER =MSGS(COUN T)
1181	"RTN","DGE NUPL3",54, 0)
1182	.Q
1183	"RTN","DGE NUPL3",55, 0)
1184	D
1185	"RTN","DGE NUPL3",56, 0)
1186	.I ELIG S HEADER="I neligibili ty Alert: " Q
1187	"RTN","DGE NUPL3",57, 0)
1188	.I NSC S HEADER="NS C Alert: " Q
1189	"RTN","DGE NUPL3",58, 0)
1190	.I POW&'N SC S HEADE R="POW Ale rt: " Q
1191	"RTN","DGE NUPL3",59, 0)
1192	.I CD S H EADER="CD Alert: " Q
1193	"RTN","DGE NUPL3",60, 0)
1194	.Q
1195	"RTN","DGE NUPL3",61, 0)
1196	;
1197	"RTN","DGE NUPL3",62, 0)
1198	S XMDF=""
1199	"RTN","DGE NUPL3",63, 0)
1200	S (XMDUN, XMDUZ)="Re gistration Enrollmen t Module"
1201	"RTN","DGE NUPL3",64, 0)
1202	;Phase II Re-Enroll ment
1203	"RTN","DGE NUPL3",65, 0)
1204	;DGPAT("S SN") is bu ilt by the parser. DGPAT("NAM E"),DGPAT( "SEX"),DGP AT("DOB")( are merged into DGPA T from OLD PAT.
1205	"RTN","DGE NUPL3",66, 0)
1206	;The chec ks below a re to setu p the DGPA T elements from OLDP AT if NOTI FY is call ed before the merge.
1207	"RTN","DGE NUPL3",67, 0)
1208	I '$D(DGP AT("NAME") ) S DGPAT( "NAME")=$G (OLDPAT("N AME"))
1209	"RTN","DGE NUPL3",68, 0)
1210	I '$D(DGP AT("SEX")) S DGPAT(" SEX")=$G(O LDPAT("SEX "))
1211	"RTN","DGE NUPL3",69, 0)
1212	I '$D(DGP AT("DOB")) S DGPAT(" DOB")=$G(O LDPAT("DOB "))
1213	"RTN","DGE NUPL3",70, 0)
1214	S TMPSTR= " ("_$E(DG PAT("NAME" ),1,1)
1215	"RTN","DGE NUPL3",71, 0)
1216	S TMPSTR= TMPSTR_$E( DGPAT("SSN "),$L(DGPA T("SSN"))- 3,1000)_") "
1217	"RTN","DGE NUPL3",72, 0)
1218	S XMSUB=$ E(HEADER,1 ,30)_$E(DG PAT("NAME" ),1,25)_TM PSTR
1219	"RTN","DGE NUPL3",73, 0)
1220	;
1221	"RTN","DGE NUPL3",74, 0)
1222	; send ms g to local mail grou p specifie d in IVM S ITE PARAME TER file
1223	"RTN","DGE NUPL3",75, 0)
1224	S MAILGRP =+$P($G(^I VM(301.9,1 ,0)),"^",9 )
1225	"RTN","DGE NUPL3",76, 0)
1226	S MAILGRP =$$EXTERNA L^DILFD(30 1.9,.09,"F ",MAILGRP)
1227	"RTN","DGE NUPL3",77, 0)
1228	I MAILGRP ]"" S XMY( "G."_MAILG RP)=""
1229	"RTN","DGE NUPL3",78, 0)
1230	;
1231	"RTN","DGE NUPL3",79, 0)
1232	;Patch DG 5.3928 i s removing ability t o send ema ils to rem ote email group. Ema ils have b een decomm issioned a nd no long er require d.
1233	"RTN","DGE NUPL3",80, 0)
1234	;if flag is set, se nd msg to remote mai l group sp ecified in
1235	"RTN","DGE NUPL3",81, 0)
1236	;the IVM SITE PARAM ETER file
1237	"RTN","DGE NUPL3",82, 0)
1238	;I $G(MSG S("HEC"))= 1 D
1239	"RTN","DGE NUPL3",83, 0)
1240	;.S MAILG RP=$P($G(^ IVM(301.9, 1,0)),"^", 10)
1241	"RTN","DGE NUPL3",84, 0)
1242	;.S MAILG RP=$$EXTER NAL^DILFD( 301.9,.10, "F",MAILGR P)
1243	"RTN","DGE NUPL3",85, 0)
1244	;.I MAILG RP]"" S XM Y("G."_MAI LGRP)=""
1245	"RTN","DGE NUPL3",86, 0)
1246	;
1247	"RTN","DGE NUPL3",87, 0)
1248	;
1249	"RTN","DGE NUPL3",88, 0)
1250	S XMTEXT= "TEXT("
1251	"RTN","DGE NUPL3",89, 0)
1252	S TEXT(1) ="The enro llment/eli gibility u pload prod uced the f ollowing a lerts:"
1253	"RTN","DGE NUPL3",90, 0)
1254	S TEXT(2) =" "
1255	"RTN","DGE NUPL3",91, 0)
1256	S TEXT(3) ="Patient Name : "_DGPAT ("NAME")
1257	"RTN","DGE NUPL3",92, 0)
1258	S TEXT(4) ="SSN : "_DGPAT ("SSN")
1259	"RTN","DGE NUPL3",93, 0)
1260	S TEXT(5) ="DOB : "_$$EXT ERNAL^DILF D(2,$$FIEL D^DGENPTA1 ("DOB"),"F ",DGPAT("D OB"))
1261	"RTN","DGE NUPL3",94, 0)
1262	S TEXT(6) ="SEX : "_$$EXT ERNAL^DILF D(2,$$FIEL D^DGENPTA1 ("SEX"),"F ",DGPAT("S EX"))
1263	"RTN","DGE NUPL3",95, 0)
1264	S TEXT(7) =" "
1265	"RTN","DGE NUPL3",96, 0)
1266	;
1267	"RTN","DGE NUPL3",97, 0)
1268	S TEXT(8) =" Aler ts "
1269	"RTN","DGE NUPL3",98, 0)
1270	S TEXT(9) =" "
1271	"RTN","DGE NUPL3",99, 0)
1272	S COUNT=0 F S COUN T=$O(MSGS( COUNT)) Q: 'COUNT S TEXT(10+CO UNT)=COUNT _") "_MSGS (COUNT)
1273	"RTN","DGE NUPL3",100 ,0)
1274	;
1275	"RTN","DGE NUPL3",101 ,0)
1276	D ^XMD
1277	"RTN","DGE NUPL3",102 ,0)
1278	Q
1279	"RTN","DGE NUPL3",103 ,0)
1280	;
1281	"RTN","DGE NUPL3",104 ,0)
1282	BEGUPLD(DF N) ;
1283	"RTN","DGE NUPL3",105 ,0)
1284	;Descript ion: Sets a lock use d to deter mine if an eligibili ty/enrollm ent
1285	"RTN","DGE NUPL3",106 ,0)
1286	;upload i s in progr ess.
1287	"RTN","DGE NUPL3",107 ,0)
1288	;
1289	"RTN","DGE NUPL3",108 ,0)
1290	;Input:
1291	"RTN","DGE NUPL3",109 ,0)
1292	; DFN - ien, Pati ent record
1293	"RTN","DGE NUPL3",110 ,0)
1294	;
1295	"RTN","DGE NUPL3",111 ,0)
1296	;Output:
1297	"RTN","DGE NUPL3",112 ,0)
1298	; Functi on value - returns 1 if the lo ck was obt ained, 0 o therwise.
1299	"RTN","DGE NUPL3",113 ,0)
1300	;
1301	"RTN","DGE NUPL3",114 ,0)
1302	Q:'$G(DFN ) 1
1303	"RTN","DGE NUPL3",115 ,0)
1304	L +^DGEN( "ELIGIBILI TY UPLOAD" ,DFN):3
1305	"RTN","DGE NUPL3",116 ,0)
1306	Q $T
1307	"RTN","DGE NUPL3",117 ,0)
1308	;
1309	"RTN","DGE NUPL3",118 ,0)
1310	ENDUPLD(DF N) ;
1311	"RTN","DGE NUPL3",119 ,0)
1312	;Descript ion: Relea ses the lo ck obtaine d by calli ng $$BEGUP LD(DFN)
1313	"RTN","DGE NUPL3",120 ,0)
1314	;
1315	"RTN","DGE NUPL3",121 ,0)
1316	Q:'$G(DFN )
1317	"RTN","DGE NUPL3",122 ,0)
1318	L -^DGEN( "ELIGIBILI TY UPLOAD" ,DFN)
1319	"RTN","DGE NUPL3",123 ,0)
1320	Q
1321	"RTN","DGE NUPL3",124 ,0)
1322	;
1323	"RTN","DGE NUPL3",125 ,0)
1324	CKUPLOAD(D FN) ;
1325	"RTN","DGE NUPL3",126 ,0)
1326	;Descript ion: Check s if an up load is in progress. If so, i t pauses
1327	"RTN","DGE NUPL3",127 ,0)
1328	;until it is comple ted.
1329	"RTN","DGE NUPL3",128 ,0)
1330	;The enro llment/eli gibility u pload can take a whi le to acco mplish.
1331	"RTN","DGE NUPL3",129 ,0)
1332	;If the l ock is not obtained initially, it is ass umed that the upload
1333	"RTN","DGE NUPL3",130 ,0)
1334	;is in pr ogress, an d a messag e is displ ayed to th e user.
1335	"RTN","DGE NUPL3",131 ,0)
1336	;
1337	"RTN","DGE NUPL3",132 ,0)
1338	;Input: D FN
1339	"RTN","DGE NUPL3",133 ,0)
1340	;Output: none
1341	"RTN","DGE NUPL3",134 ,0)
1342	;
1343	"RTN","DGE NUPL3",135 ,0)
1344	N I
1345	"RTN","DGE NUPL3",136 ,0)
1346	I '$$BEGU PLD(DFN) D
1347	"RTN","DGE NUPL3",137 ,0)
1348	.W !!,"Up load of pa tient enro llment/eli gibility d ata is in progress . .."
1349	"RTN","DGE NUPL3",138 ,0)
1350	.D UNLOCK ^DGENPTA1( DFN)
1351	"RTN","DGE NUPL3",139 ,0)
1352	.F I=1:1: 50 Q:$$BEG UPLD(DFN) W "."
1353	"RTN","DGE NUPL3",140 ,0)
1354	.W !,"Upl oad of pat ient enrol lment/elig ibility da ta is comp leted.",!
1355	"RTN","DGE NUPL3",141 ,0)
1356	D ENDUPLD (DFN)
1357	"RTN","DGE NUPL3",142 ,0)
1358	Q
1359	"RTN","DGE NUPL3",143 ,0)
1360	SCVET ;mov ed from DG ENUPL4 - D G5.3688
1361	"RTN","DGE NUPL3",144 ,0)
1362	I DGPAT3( "VETERAN") '="N" D
1363	"RTN","DGE NUPL3",145 ,0)
1364	. I DGELG 3("SC")="N " S DGPAT3 ("VETERAN" )="Y",DGPA T3("PATYPE ")=$O(^DG( 391,"B","N SC VETERAN ",0))
1365	"RTN","DGE NUPL3",146 ,0)
1366	. I DGELG 3("SC")="Y " S DGPAT3 ("VETERAN" )="Y",DGPA T3("PATYPE ")=$O(^DG( 391,"B","S C VETERAN" ,0))
1367	"RTN","DGE NUPL3",147 ,0)
1368	I DGPAT3( "VETERAN") ="N" S DGP AT3("PATYP E")=$$NONV ET(DGELG(" ELIG","COD E"))
1369	"RTN","DGE NUPL3",148 ,0)
1370	Q
1371	"RTN","DGE NUPL3",149 ,0)
1372	;
1373	"RTN","DGE NUPL3",150 ,0)
1374	NONVET(DGC ODE) ;map Patient Ty pe from Pr imary Elig (and POS)
1375	"RTN","DGE NUPL3",151 ,0)
1376	;added wi th DG5.3 688 - ERC
1377	"RTN","DGE NUPL3",152 ,0)
1378	; input: DG CODE is th e Primary Eligibilit y code
1379	"RTN","DGE NUPL3",153 ,0)
1380	; output: DG TPYE is re turned as the value for Patien t Type
1381	"RTN","DGE NUPL3",154 ,0)
1382	N PTELG,D GTYPE
1383	"RTN","DGE NUPL3",155 ,0)
1384	S (PTELG, DGTYPE)=""
1385	"RTN","DGE NUPL3",156 ,0)
1386	Q:$G(DGCO DE)']"" ""
1387	"RTN","DGE NUPL3",157 ,0)
1388	S PTELG=$ $NATNAME^D GENELA(DGC ODE)
1389	"RTN","DGE NUPL3",158 ,0)
1390	Q:$G(PTEL G)']"" ""
1391	"RTN","DGE NUPL3",159 ,0)
1392	I "CHAMPV A^OTHER FE DERAL AGEN CY^REIMBUR SABLE INSU RANCE^SHAR ING AGREEM ENT"[PTELG S DGTYPE= $$POS(.DGT YPE) Q:DGT YPE DGTYPE
1393	"RTN","DGE NUPL3",160 ,0)
1394	S DGTYPE= $S(PTELG[" ALLIED":"A LLIED VETE RAN",PTELG ["COLLATER AL":"COLLA TERAL",PTE LG["EMPLOY EE":"EMPLO YEE",PTELG ["TRICARE" :"TRICARE" ,1:"")
1395	"RTN","DGE NUPL3",161 ,0)
1396	I DGTYPE' ]"" S DGTY PE="NON-VE TERAN (OTH ER)" ;defa ult Pat Ty pe
1397	"RTN","DGE NUPL3",162 ,0)
1398	S DGTYPE= $O(^DG(391 ,"B",DGTYP E,""))
1399	"RTN","DGE NUPL3",163 ,0)
1400	Q DGTYPE
1401	"RTN","DGE NUPL3",164 ,0)
1402	POS(DGTYPE ) ;for the se Elig Co des, check POS to de termine Pa tient Type
1403	"RTN","DGE NUPL3",165 ,0)
1404	S DGPOS=D GELG("POS" )
1405	"RTN","DGE NUPL3",166 ,0)
1406	I $G(DGPO S)']"" Q " "
1407	"RTN","DGE NUPL3",167 ,0)
1408	I '$D(^DI C(21,DGPOS ,0)) Q ""
1409	"RTN","DGE NUPL3",168 ,0)
1410	S DGPOS=$ P(^DIC(21, DGPOS,0),U )
1411	"RTN","DGE NUPL3",169 ,0)
1412	S DGTYPE= $S(DGPOS[" ACTIVE":"A CTIVE DUTY ",DGPOS["O PERAT":"AC TIVE DUTY" ,DGPOS["RE TIR":"MILI TARY RETIR EE",1:"")
1413	"RTN","DGE NUPL3",170 ,0)
1414	I $G(DGTY PE)]"" S D GTYPE=$O(^ DG(391,"B" ,DGTYPE,"" ))
1415	"RTN","DGE NUPL3",171 ,0)
1416	Q DGTYPE
1417	"RTN","DGE NUPL3",172 ,0)
1418	;
1419	"RTN","DGE NUPL3",173 ,0)
1420	;ZMH code moved her e from DGE NUPL2 - DG 5.3653
1421	"RTN","DGE NUPL3",174 ,0)
1422	ZMH ;Purpl e Heart, P OW, OEF/OI F Conflict Loc, Mili tary Servi ce Episode s, Medal o f Honor
1423	"RTN","DGE NUPL3",175 ,0)
1424	;PROCESS PH, OEF/OI F, MH & PO W FROM ZMH
1425	"RTN","DGE NUPL3",176 ,0)
1426	;Process Military S ervice Epi sodes (SL, SNL,SNNL,M SD) - DG5 .3797
1427	"RTN","DGE NUPL3",177 ,0)
1428	;Process Military S ervice Epi sodes (SL, SNL,SNNL,M SD,FDD) - Future Dis charge Dat e Added DG 5.3935
1429	"RTN","DGE NUPL3",178 ,0)
1430	;DJS, Ind icate if t he ZMH seg ment exist s in this message; D G5.3935
1431	"RTN","DGE NUPL3",179 ,0)
1432	N DGNEW
1433	"RTN","DGE NUPL3",180 ,0)
1434	S ^TMP($J ,"DGENUPL" ,"ZMH",0)= 1
1435	"RTN","DGE NUPL3",181 ,0)
1436	I "^SL^SN L^SNNL^MSD ^FDD^"[("^ "_SEG(2)_" ^") D Q
1437	"RTN","DGE NUPL3",182 ,0)
1438	. ;DJS, S tore the F uture Disc harge Date (FDD); DG 5.3935
1439	"RTN","DGE NUPL3",183 ,0)
1440	. I SEG(2 )="FDD"&($ L(SEG(8))< 5) S SEG(8 )="",I=0 D Q
1441	"RTN","DGE NUPL3",184 ,0)
1442	. . S DGN EW=0 F S I=$O(^DPT( DFN,.3216, I)) Q:I'?. N!($G(I)=" ") S DA(1 )=DFN,DA=I ,DIE="^DPT ("_DA(1)_" ,"_.3216_" ,",DIE(0)= "",DR=".08 ///@" D ^D IE D ID1^D GNOZMH(DFN ,I,DGNEW) S I=DA ;D elete an i ncomplete MSE ;DG5. 3935
1443	"RTN","DGE NUPL3",185 ,0)
1444	. . K DGN EW Q
1445	"RTN","DGE NUPL3",186 ,0)
1446	. N BOS,S N,DIS,SED, SSD,COM,DG FDD,DIE,DA ,DR S ERRO R=""
1447	"RTN","DGE NUPL3",187 ,0)
1448	. S BOS=$ $CONVERT^D GENUPL1($P (SEG(3),$E (HLECH))) ;Service Branch
1449	"RTN","DGE NUPL3",188 ,0)
1450	. S:BOS]" " BOS=$O(^ DIC(23,"B" ,BOS,""))
1451	"RTN","DGE NUPL3",189 ,0)
1452	. S SN=$$ CONVERT^DG ENUPL1($P( SEG(3),$E( HLECH),2)) ;Service Number
1453	"RTN","DGE NUPL3",190 ,0)
1454	. S DIS=$ $CONVERT^D GENUPL1($P (SEG(3),$E (HLECH),3) ) ;Discha rge Type
1455	"RTN","DGE NUPL3",191 ,0)
1456	. S:DIS]" " DIS=$O(^ DIC(25,"B" ,DIS,""))
1457	"RTN","DGE NUPL3",192 ,0)
1458	. S SED=$ $CONVERT^D GENUPL1($P (SEG(4),$E (HLECH))," DATE") ;E ntry Date
1459	"RTN","DGE NUPL3",193 ,0)
1460	. I 'SED! ERROR D Q
1461	"RTN","DGE NUPL3",194 ,0)
1462	. . Q:SEG (2)="FDD"& (SEG(8)="" ) D ADDER ROR^DGENUP L(MSGID,$G (DGPAT("SS N")),"BAD VALUE, ZMH SEGMENT, SEQ 4, SER VICE ENTRY DATE",.ER RCOUNT)
1463	"RTN","DGE NUPL3",195 ,0)
1464	. S SSD=$ $CONVERT^D GENUPL1($P (SEG(4),$E (HLECH),2) ,"DATE") ;Sep. Date
1465	"RTN","DGE NUPL3",196 ,0)
1466	. S COM=$ $CONVERT^D GENUPL1($P (SEG(5),$E (HLECH))) ;Service Component
1467	"RTN","DGE NUPL3",197 ,0)
1468	. ;DJS, C reate vari able DGFDD for stora ge in Mili tary Servi ce Episode (MSE); DG 5.3935
1469	"RTN","DGE NUPL3",198 ,0)
1470	. ;DJS, C reate MSE whether or not FDD e xists & is a valid d ate; DG5. 3935
1471	"RTN","DGE NUPL3",199 ,0)
1472	. I SEG(2 )="FDD" D
1473	"RTN","DGE NUPL3",200 ,0)
1474	. . S DGF DD=$$CONVE RT^DGENUPL 1($P(SEG(8 ),$E(HLECH )),"DATE")
1475	"RTN","DGE NUPL3",201 ,0)
1476	. . I $$V ALID^DGRPD T(.DGFDD)= 1 D
1477	"RTN","DGE NUPL3",202 ,0)
1478	. . .S DG NMSE(-SED) =SED_U_SSD _U_BOS_U_C OM_U_SN_U_ DIS_U_1_U_ DGFDD
1479	"RTN","DGE NUPL3",203 ,0)
1480	. E S DG NMSE(-SED) =SED_U_SSD _U_BOS_U_C OM_U_SN_U_ DIS_U_1
1481	"RTN","DGE NUPL3",204 ,0)
1482	;
1483	"RTN","DGE NUPL3",205 ,0)
1484	I SEG(2)= "PH" D Q ;Process Purple Hea rt from ZM H
1485	"RTN","DGE NUPL3",206 ,0)
1486	. S DGPAT ("PHI")=$P (SEG(3),$E (HLECH))
1487	"RTN","DGE NUPL3",207 ,0)
1488	. S DGELG ("PH")=$$C ONVERT^DGE NUPL1($P(S EG(3),$E(H LECH)))
1489	"RTN","DGE NUPL3",208 ,0)
1490	. S DGPAT ("PHST")=$ $CONVERT^D GENUPL1($P (SEG(3),$E (HLECH),2) )
1491	"RTN","DGE NUPL3",209 ,0)
1492	. S DGPAT ("PHRR")=$ $CONVERT^D GENUPL1($P (SEG(3),$E (HLECH),3) )
1493	"RTN","DGE NUPL3",210 ,0)
1494	;
1495	"RTN","DGE NUPL3",211 ,0)
1496	I SEG(2)= "OEIF" D Q
1497	"RTN","DGE NUPL3",212 ,0)
1498	. N OEIFL OC
1499	"RTN","DGE NUPL3",213 ,0)
1500	. S OEIFL OC=$P(SEG( 3),$E(HLEC H))
1501	"RTN","DGE NUPL3",214 ,0)
1502	. I OEIFL OC="Confli ct Unspeci fied" Q ;Ignore th ese entrie s
1503	"RTN","DGE NUPL3",215 ,0)
1504	. I OEIFL OC="Unknow n OEF/OIF" S OEIFLOC ="UNK"
1505	"RTN","DGE NUPL3",216 ,0)
1506	. S OEIFL OC=$E(OEIF LOC,1,3)
1507	"RTN","DGE NUPL3",217 ,0)
1508	. Q:((OEI FLOC'="OIF ")&(OEIFLO C'="OEF")& (OEIFLOC'= "UNK"))
1509	"RTN","DGE NUPL3",218 ,0)
1510	. S DGOEI F("COUNT") =$G(DGOEIF ("COUNT")) +1
1511	"RTN","DGE NUPL3",219 ,0)
1512	. S DGOEI F("LOC",DG OEIF("COUN T"))=OEIFL OC
1513	"RTN","DGE NUPL3",220 ,0)
1514	. S DGOEI F("SITE",D GOEIF("COU NT"))=$$CO NVERT^DGEN UPL1($P(SE G(3),$E(HL ECH),2),"I NSTITUTION ")
1515	"RTN","DGE NUPL3",221 ,0)
1516	. S DGOEI F("FR",DGO EIF("COUNT "))=$$CONV ERT^DGENUP L1($P(SEG( 4),$E(HLEC H)),"DATE" )
1517	"RTN","DGE NUPL3",222 ,0)
1518	. S DGOEI F("TO",DGO EIF("COUNT "))=$$CONV ERT^DGENUP L1($P(SEG( 4),$E(HLEC H),2),"DAT E")
1519	"RTN","DGE NUPL3",223 ,0)
1520	. S DGOEI F("LOCK",D GOEIF("COU NT"))=1
1521	"RTN","DGE NUPL3",224 ,0)
1522	;
1523	"RTN","DGE NUPL3",225 ,0)
1524	I SEG(2)= "POW" D ; Process PO W from ZMH
1525	"RTN","DGE NUPL3",226 ,0)
1526	. S DGPAT ("POWI")=$ $CONVERT^D GENUPL1($P (SEG(3),$E (HLECH))) ;POW STATU S INDICATE D
1527	"RTN","DGE NUPL3",227 ,0)
1528	. S DGELG ("POW")=$$ CONVERT^DG ENUPL1($P( SEG(3),$E( HLECH)))
1529	"RTN","DGE NUPL3",228 ,0)
1530	. S DGPAT ("POWLOC") =$$CONVERT ^DGENUPL1( $P(SEG(3), $E(HLECH), 2))
1531	"RTN","DGE NUPL3",229 ,0)
1532	. I DGPAT ("POWLOC") '="@" S DG PAT("POWLO C")=$$POWL OC(DGPAT(" POWLOC"),. ERROR) ;PO W CONFINEM ENT LOCATI ON
1533	"RTN","DGE NUPL3",230 ,0)
1534	. I ERROR D Q
1535	"RTN","DGE NUPL3",231 ,0)
1536	. . D ADD ERROR^DGEN UPL(MSGID, $G(DGPAT(" SSN")),"BA D VALUE, Z MH SEGMENT , SEQ 3, P OW CONFINE MENT LOCAT ION",.ERRC OUNT)
1537	"RTN","DGE NUPL3",232 ,0)
1538	. S DGPAT ("POWFDT") =$$CONVERT ^DGENUPL1( $P(SEG(4), $E(HLECH)) ,"DATE",.E RROR) ;POW FROM DATE
1539	"RTN","DGE NUPL3",233 ,0)
1540	. I ERROR D Q
1541	"RTN","DGE NUPL3",234 ,0)
1542	. . D ADD ERROR^DGEN UPL(MSGID, $G(DGPAT(" SSN")),"BA D VALUE, Z MH SEGMENT , SEQ 4, P OW FROM DA TE",.ERRCO UNT)
1543	"RTN","DGE NUPL3",235 ,0)
1544	. S DGPAT ("POWTDT") =$$CONVERT ^DGENUPL1( $P(SEG(4), $E(HLECH), 2),"DATE", .ERROR) ;P OW TO DATE
1545	"RTN","DGE NUPL3",236 ,0)
1546	. I ERROR D Q
1547	"RTN","DGE NUPL3",237 ,0)
1548	. . D ADD ERROR^DGEN UPL(MSGID, $G(DGPAT(" SSN")),"BA D VALUE, Z MH SEGMENT , SEQ 4, P OW TO DATE ",.ERRCOUN T)
1549	"RTN","DGE NUPL3",238 ,0)
1550	;
1551	"RTN","DGE NUPL3",239 ,0)
1552	I SEG(2)= "MH" D ;P rocess Med al of Hono r from ZMH
1553	"RTN","DGE NUPL3",240 ,0)
1554	. S DGPAT ("MOH")=$$ CONVERT^DG ENUPL1($P( SEG(3),$E( HLECH))) ; MH STATUS INDICATED
1555	"RTN","DGE NUPL3",241 ,0)
1556	. S DGELG ("MOH")=$$ CONVERT^DG ENUPL1($P( SEG(3),$E( HLECH)))
1557	"RTN","DGE NUPL3",242 ,0)
1558	Q
1559	"RTN","DGE NUPL3",243 ,0)
1560	POWLOC(LOC ,ERROR) ;P OW Confine ment Locat ion mappin g with HL7 table VA0 23
1561	"RTN","DGE NUPL3",244 ,0)
1562	; Input: LOC - HL7 code for location
1563	"RTN","DGE NUPL3",245 ,0)
1564	; Output: ERROR - R eturn erro r 1 on fai lure
1565	"RTN","DGE NUPL3",246 ,0)
1566	; IEN22 - I EN of file 22
1567	"RTN","DGE NUPL3",247 ,0)
1568	N TBL023
1569	"RTN","DGE NUPL3",248 ,0)
1570	S ERROR=0
1571	"RTN","DGE NUPL3",249 ,0)
1572	I LOC="" S ERROR=1 Q ""
1573	"RTN","DGE NUPL3",250 ,0)
1574	S TBL023( 4)="WWI",T BL023(5)=" WWII-EUROP E",TBL023( 6)="WWII-P ACIFIC"
1575	"RTN","DGE NUPL3",251 ,0)
1576	S TBL023( 7)="KOREAN ",TBL023(8 )="VIETNAM ",TBL023(9 )="OTHER"
1577	"RTN","DGE NUPL3",252 ,0)
1578	S TBL023( "A")="PERS IAN GULF", TBL023("B" )="YUGOSLA VIA"
1579	"RTN","DGE NUPL3",253 ,0)
1580	S IEN22=$ O(^DIC(22, "C",TBL023 (LOC),""))
1581	"RTN","DGE NUPL3",254 ,0)
1582	I IEN22=" " S ERROR= 1
1583	"RTN","DGE NUPL3",255 ,0)
1584	Q IEN22
1585	"RTN","DGE NUPL3",256 ,0)
1586	;
1587	"RTN","DGM SEUTL")
1588	0^6^B17883 475
1589	"RTN","DGM SEUTL",1,0 )
1590	DGMSEUTL ; ALB/PJH,LB D,DJS - MS DS Utility Routine ; 28 Sep 201 7 5:36PM
1591	"RTN","DGM SEUTL",2,0 )
1592	;;5.3;Reg istration; *797,935 *;08/13/93 ;Build 53
1593	"RTN","DGM SEUTL",3,0 )
1594	;
1595	"RTN","DGM SEUTL",4,0 )
1596	;
1597	"RTN","DGM SEUTL",5,0 )
1598	MOVMSE(DFN ) ;Move MS E data fro m .32 node to .3216 multiple i n Patient file #2
1599	"RTN","DGM SEUTL",6,0 )
1600	Q:'$G(DFN ) Q:$O(^D PT(DFN,.32 16,0))
1601	"RTN","DGM SEUTL",7,0 )
1602	N ARRAY
1603	"RTN","DGM SEUTL",8,0 )
1604	D ARRAY(D FN,.ARRAY)
1605	"RTN","DGM SEUTL",9,0 )
1606	I $D(ARRA Y) D MSE(D FN,.ARRAY)
1607	"RTN","DGM SEUTL",10, 0)
1608	Q
1609	"RTN","DGM SEUTL",11, 0)
1610	;
1611	"RTN","DGM SEUTL",12, 0)
1612	ARRAY(DFN, ARRAY) ;Ge t old form at VistA d ata
1613	"RTN","DGM SEUTL",13, 0)
1614	N DGRP,DG RPX,DGRPED ,DGRPSD,DG RPBR,DGRPC O,DGRPSN,D GRPDI
1615	"RTN","DGM SEUTL",14, 0)
1616	S DGRP(.3 2)=$G(^DPT (DFN,.32)) ,DGRP(.329 1)=$G(^DPT (DFN,.3291 ))
1617	"RTN","DGM SEUTL",15, 0)
1618	;Last ser vice episo de (SL)
1619	"RTN","DGM SEUTL",16, 0)
1620	D EPISODE (1,4,8)
1621	"RTN","DGM SEUTL",17, 0)
1622	;Next to last servi ce episode (SNL)
1623	"RTN","DGM SEUTL",18, 0)
1624	Q:$P(DGRP (.32),"^", 19)'="Y" D EPISODE( 2,9,13)
1625	"RTN","DGM SEUTL",19, 0)
1626	;Prior ep isode (SNN L)
1627	"RTN","DGM SEUTL",20, 0)
1628	I $P(DGRP (.32),"^", 20)="Y" D EPISODE(3, 14,18)
1629	"RTN","DGM SEUTL",21, 0)
1630	Q
1631	"RTN","DGM SEUTL",22, 0)
1632	;
1633	"RTN","DGM SEUTL",23, 0)
1634	EPISODE(SU B,P1,P2) ; Get old Vi stA data a nd save
1635	"RTN","DGM SEUTL",24, 0)
1636	S DGRPX=$ P(DGRP(.32 ),U,P1,P2) ,DGRPCO=$P (DGRP(.329 1),U,SUB)
1637	"RTN","DGM SEUTL",25, 0)
1638	S DGRPDI= $P(DGRPX,U ),DGRPBR=$ P(DGRPX,U, 2),DGRPED= $P(DGRPX,U ,3)
1639	"RTN","DGM SEUTL",26, 0)
1640	S DGRPSD= $P(DGRPX,U ,4),DGRPSN =$P(DGRPX, U,5)
1641	"RTN","DGM SEUTL",27, 0)
1642	;DJS, Sav e Future D ischarge D ate; DG5. 3935
1643	"RTN","DGM SEUTL",28, 0)
1644	;Save in format of new .3216 multiple ( no lock fl ag)
1645	"RTN","DGM SEUTL",29, 0)
1646	S ARRAY(S UB)=DGRPED _U_DGRPSD_ U_DGRPBR_U _DGRPCO_U_ DGRPSN_U_D GRPDI_U_U_ $G(DGFDD) ; DG5.3 935
1647	"RTN","DGM SEUTL",30, 0)
1648	Q
1649	"RTN","DGM SEUTL",31, 0)
1650	;
1651	"RTN","DGM SEUTL",32, 0)
1652	MSE(DFN,AR RAY,DEL) ; Copy old V istA data to new .32 16 multipl e
1653	"RTN","DGM SEUTL",33, 0)
1654	N ECNT,DA ,DIK,SUB,X ,Y,DIC,DLA YGO,FLDS,D GFDD,DGNEW
1655	"RTN","DGM SEUTL",34, 0)
1656	S ECNT=0
1657	"RTN","DGM SEUTL",35, 0)
1658	;Delete e xisting en tries
1659	"RTN","DGM SEUTL",36, 0)
1660	I $G(DEL) F S ECNT =$O(^DPT(D FN,.3216,E CNT)) Q:+E CNT'>0 D
1661	"RTN","DGM SEUTL",37, 0)
1662	.S DA(1)= DFN,DA=ECN T,DIK="^DP T("_DA(1)_ ",.3216," D ^DIK
1663	"RTN","DGM SEUTL",38, 0)
1664	;Add serv ice episod es
1665	"RTN","DGM SEUTL",39, 0)
1666	S SUB=""
1667	"RTN","DGM SEUTL",40, 0)
1668	F S SUB= $O(ARRAY(S UB)) Q:'SU B D
1669	"RTN","DGM SEUTL",41, 0)
1670	.;Ignore if Service Entry Dat e is null
1671	"RTN","DGM SEUTL",42, 0)
1672	.Q:'+ARRA Y(SUB)
1673	"RTN","DGM SEUTL",43, 0)
1674	.N DA,DIC ,DD,DO,DLA YGO,FLDS,X
1675	"RTN","DGM SEUTL",44, 0)
1676	.S FLDS=A RRAY(SUB)
1677	"RTN","DGM SEUTL",45, 0)
1678	.S DIC="^ DPT(DFN,.3 216,"
1679	"RTN","DGM SEUTL",46, 0)
1680	.S DIC(0) ="L",DLAYG O=2
1681	"RTN","DGM SEUTL",47, 0)
1682	.S DA(1)= DFN
1683	"RTN","DGM SEUTL",48, 0)
1684	.S X=$P(F LDS,U) ;En try Date
1685	"RTN","DGM SEUTL",49, 0)
1686	.S DIC("D R")=".02// //"_$P(FLD S,U,2) ;Se paration D ate
1687	"RTN","DGM SEUTL",50, 0)
1688	.S DIC("D R")=DIC("D R")_";.03/ ///"_$P(FL DS,U,3) ;S ervice Bra nch
1689	"RTN","DGM SEUTL",51, 0)
1690	.S DIC("D R")=DIC("D R")_";.04/ ///"_$P(FL DS,U,4) ;S ervice Com ponent
1691	"RTN","DGM SEUTL",52, 0)
1692	.S DIC("D R")=DIC("D R")_";.05/ ///"_$P(FL DS,U,5) ;S ervice Num ber
1693	"RTN","DGM SEUTL",53, 0)
1694	.S DIC("D R")=DIC("D R")_";.06/ ///"_$P(FL DS,U,6) ;D ischarge t ype
1695	"RTN","DGM SEUTL",54, 0)
1696	.S DIC("D R")=DIC("D R")_";.07/ ///"_$P(FL DS,U,7) ;L ocked
1697	"RTN","DGM SEUTL",55, 0)
1698	. ;DJS, S tore FUTUR E DISCHARG E DATE; DG 5.3935
1699	"RTN","DGM SEUTL",56, 0)
1700	.S DIC("D R")=DIC("D R")_";.08/ //"_$P(FLD S,U,8) ;Fu ture Disch arge Date
1701	"RTN","DGM SEUTL",57, 0)
1702	.D FILE^D ICN
1703	"RTN","DGM SEUTL",58, 0)
1704	Q
1705	"RTN","DGM SEUTL",59, 0)
1706	;
1707	"RTN","DGM SEUTL",60, 0)
1708	GETMSE(DFN ,MSE) ;Ret urn all re cords in M SE sub-fil e #2.3216 in MSE arr ay
1709	"RTN","DGM SEUTL",61, 0)
1710	;Records are sorted in revers e chronolo gical orde r and the second
1711	"RTN","DGM SEUTL",62, 0)
1712	;subscrip t is the M SE IEN in the multip le e.g. M SE(1,4)=la st
1713	"RTN","DGM SEUTL",63, 0)
1714	I '$G(DFN ) Q
1715	"RTN","DGM SEUTL",64, 0)
1716	N I,SDT,I EN
1717	"RTN","DGM SEUTL",65, 0)
1718	S SDT=""
1719	"RTN","DGM SEUTL",66, 0)
1720	F I=1:1 S SDT=$O(^D PT(DFN,.32 16,"B",SDT ),-1) Q:'S DT D
1721	"RTN","DGM SEUTL",67, 0)
1722	.S IEN=0 F S IEN=$ O(^DPT(DFN ,.3216,"B" ,SDT,IEN)) Q:'IEN D
1723	"RTN","DGM SEUTL",68, 0)
1724	..I '$D(^ DPT(DFN,.3 216,IEN,0) ) Q
1725	"RTN","DGM SEUTL",69, 0)
1726	..S MSE(I )=^DPT(DFN ,.3216,IEN ,0)
1727	"RTN","DGM SEUTL",70, 0)
1728	..S MSE(I ,IEN)=""
1729	"RTN","DGM SEUTL",71, 0)
1730	Q
1731	"RTN","DGM SEUTL",72, 0)
1732	;
1733	"RTN","DGM SEUTL",73, 0)
1734	LAST(DFN) ;Return la st (most r ecent) MSE
1735	"RTN","DGM SEUTL",74, 0)
1736	I '$G(DFN ) Q ""
1737	"RTN","DGM SEUTL",75, 0)
1738	N MSE
1739	"RTN","DGM SEUTL",76, 0)
1740	D GETMSE( DFN,.MSE)
1741	"RTN","DGM SEUTL",77, 0)
1742	S MSE=$O( MSE(0))
1743	"RTN","DGM SEUTL",78, 0)
1744	Q $G(MSE( +MSE))
1745	"RTN","DGM SEUTL",79, 0)
1746	;
1747	"RTN","DGM SEUTL",80, 0)
1748	UPDMSE(DFN ,DGNMSE) ; File MSE d ata from t he HEC Z11 message
1749	"RTN","DGM SEUTL",81, 0)
1750	Q:'$G(DFN ) Q:'$D(D GNMSE)
1751	"RTN","DGM SEUTL",82, 0)
1752	N DGOMSE, DGTOT,DGCH G,DGN,DGO, I
1753	"RTN","DGM SEUTL",83, 0)
1754	S DGTOT=0 ,DGN="" F S DGN=$O( DGNMSE(DGN )) Q:'DGN S DGTOT=D GTOT+1
1755	"RTN","DGM SEUTL",84, 0)
1756	;Get curr ent MSE da ta for pat ient from MSE sub-fi le #2.3216
1757	"RTN","DGM SEUTL",85, 0)
1758	D GETMSE( DFN,.DGOMS E)
1759	"RTN","DGM SEUTL",86, 0)
1760	I $D(DGOM SE) D Q:' DGCHG
1761	"RTN","DGM SEUTL",87, 0)
1762	.;Compare the old a nd new dat a. If the y match, n o update i s needed.
1763	"RTN","DGM SEUTL",88, 0)
1764	.S DGCHG= 0
1765	"RTN","DGM SEUTL",89, 0)
1766	.I DGTOT' =$O(DGOMSE (""),-1) S DGCHG=1 Q
1767	"RTN","DGM SEUTL",90, 0)
1768	.S (DGO,D GN)=""
1769	"RTN","DGM SEUTL",91, 0)
1770	.F I=1:1: DGTOT S DG O=$O(DGOMS E(DGO)),DG N=$O(DGNMS E(DGN)) D Q:DGCHG
1771	"RTN","DGM SEUTL",92, 0)
1772	..I DGOMS E(DGO)'=DG NMSE(DGN) S DGCHG=1 Q
1773	"RTN","DGM SEUTL",93, 0)
1774	;File the new MSE d ata from H EC, delete old data first if i t exists
1775	"RTN","DGM SEUTL",94, 0)
1776	D MSE(DFN ,.DGNMSE,$ D(DGOMSE))
1777	"RTN","DGM SEUTL",95, 0)
1778	Q
1779	"RTN","DGM SEUTL",96, 0)
1780	;
1781	"RTN","DGM SEUTL",97, 0)
1782	ESRDATA(DF N) ;Check if any rec ords in .3 216 are fr om ESR
1783	"RTN","DGM SEUTL",98, 0)
1784	N IEN,LOC KED
1785	"RTN","DGM SEUTL",99, 0)
1786	S IEN=0,L OCKED=0
1787	"RTN","DGM SEUTL",100 ,0)
1788	F S IEN= $O(^DPT(DF N,.3216,IE N)) Q:'IEN D Q:LOC KED
1789	"RTN","DGM SEUTL",101 ,0)
1790	.;Check i f record i s locked
1791	"RTN","DGM SEUTL",102 ,0)
1792	.S LOCKED =$P($G(^DP T(DFN,.321 6,IEN,0)), U,7)
1793	"RTN","DGM SEUTL",103 ,0)
1794	;Return L OCKED indi cating ESR data foun d
1795	"RTN","DGM SEUTL",104 ,0)
1796	Q LOCKED
1797	"RTN","DGM SEUTL",105 ,0)
1798	;
1799	"RTN","DGM SEUTL",106 ,0)
1800	WARNMSG(DF N) ;Warnin g Message if some ep isodes did not copy
1801	"RTN","DGM SEUTL",107 ,0)
1802	N DATA32, OLDMSE,NEW MSE,DATA
1803	"RTN","DGM SEUTL",108 ,0)
1804	;If ESR d ata exists quit
1805	"RTN","DGM SEUTL",109 ,0)
1806	Q:$$ESRDA TA(DFN) 0
1807	"RTN","DGM SEUTL",110 ,0)
1808	;Count nu mber of ol d episodes
1809	"RTN","DGM SEUTL",111 ,0)
1810	N LBRANCH ,LDATE,SDA T,NODT
1811	"RTN","DGM SEUTL",112 ,0)
1812	S DATA32= $G(^DPT(DF N,.32))
1813	"RTN","DGM SEUTL",113 ,0)
1814	S LDATE=$ P(DATA32,U ,6),LBRANC H=$P(DATA3 2,U,5),OLD MSE=0,NODT =0
1815	"RTN","DGM SEUTL",114 ,0)
1816	;If entry date or b ranch assu me last ep isode exis ts
1817	"RTN","DGM SEUTL",115 ,0)
1818	I LDATE!L BRANCH S O LDMSE=OLDM SE+1 S:'LD ATE NODT=1
1819	"RTN","DGM SEUTL",116 ,0)
1820	;Check fo r second e pisode
1821	"RTN","DGM SEUTL",117 ,0)
1822	I $P(DATA 32,U,19)=" Y" D
1823	"RTN","DGM SEUTL",118 ,0)
1824	.S OLDMSE =OLDMSE+1 S:'$P(DATA 32,U,11) N ODT=1
1825	"RTN","DGM SEUTL",119 ,0)
1826	.;and thi rd episode
1827	"RTN","DGM SEUTL",120 ,0)
1828	.I $P(DAT A32,U,20)= "Y" S OLDM SE=OLDMSE+ 1 S:'$P(DA TA32,U,16) NODT=1
1829	"RTN","DGM SEUTL",121 ,0)
1830	;
1831	"RTN","DGM SEUTL",122 ,0)
1832	;If no ol d episodes no messag e is neces sary
1833	"RTN","DGM SEUTL",123 ,0)
1834	Q:'OLDMSE 0
1835	"RTN","DGM SEUTL",124 ,0)
1836	;
1837	"RTN","DGM SEUTL",125 ,0)
1838	;Count nu mber of ne w episodes
1839	"RTN","DGM SEUTL",126 ,0)
1840	S NEWMSE= 0,SDAT=""
1841	"RTN","DGM SEUTL",127 ,0)
1842	F S SDAT =$O(^DPT(D FN,.3216," B",SDAT),- 1) Q:'SDAT D
1843	"RTN","DGM SEUTL",128 ,0)
1844	.S IEN=$O (^DPT(DFN, .3216,"B", SDAT,0)) Q :'IEN
1845	"RTN","DGM SEUTL",129 ,0)
1846	.S DATA=$ G(^DPT(DFN ,.3216,IEN ,0)) Q:DAT A=""
1847	"RTN","DGM SEUTL",130 ,0)
1848	.S NEWMSE =NEWMSE+1
1849	"RTN","DGM SEUTL",131 ,0)
1850	;
1851	"RTN","DGM SEUTL",132 ,0)
1852	;If numbe r old MSEs greater t han new MS Es, and se rvice entr y date
1853	"RTN","DGM SEUTL",133 ,0)
1854	;is missi ng, return 1
1855	"RTN","DGM SEUTL",134 ,0)
1856	I OLDMSE> NEWMSE,NOD T Q 1
1857	"RTN","DGM SEUTL",135 ,0)
1858	;Otherwis e, return 0
1859	"RTN","DGM SEUTL",136 ,0)
1860	Q 0
1861	"RTN","DGN OZMH")
1862	0^13^B1893 168
1863	"RTN","DGN OZMH",1,0)
1864	DGNOZMH ;A LB/CLT - N O ZMH SEGM ENT IN Z11 HL7 MESSA GE AND CLE AN UP INCO MPLETE MIL ITARY SERV ICE EPISOD ES ;21 Jul 2017 9:0 5 AM
1865	"RTN","DGN OZMH",2,0)
1866	;;5.3;REG ISTRATION; 935;AU G 13, 1993 ;Build 53
1867	"RTN","DGN OZMH",3,0)
1868	;
1869	"RTN","DGN OZMH",4,0)
1870	;The prim ary purpos e of this routine is to delete all HEC
1871	"RTN","DGN OZMH",5,0)
1872	;issued m ilitary se rvice epis odes (MSE) .
1873	"RTN","DGN OZMH",6,0)
1874	;
1875	"RTN","DGN OZMH",7,0)
1876	EN(DFN) ;P rimary ent ry point
1877	"RTN","DGN OZMH",8,0)
1878	Q:'$D(^DP T(DFN,.321 6))
1879	"RTN","DGN OZMH",9,0)
1880	N DGMSE,D GMSEDT,DIK ,S
1881	"RTN","DGN OZMH",10,0 )
1882	S DGMSEDT =""
1883	"RTN","DGN OZMH",11,0 )
1884	F S DGMS EDT=$O(^DP T(DFN,.321 6,"B",DGMS EDT),-1) Q :DGMSEDT=" " D
1885	"RTN","DGN OZMH",12,0 )
1886	. S DGMSE ="",DGMSE= $O(^DPT(DF N,.3216,"B ",DGMSEDT, DGMSE))
1887	"RTN","DGN OZMH",13,0 )
1888	. Q:$P(^D PT(DFN,.32 16,DGMSE,0 ),U,7)'=1
1889	"RTN","DGN OZMH",14,0 )
1890	. S DA=DG MSE,DA(1)= DFN
1891	"RTN","DGN OZMH",15,0 )
1892	. S DIK=" ^DPT("_DA( 1)_","_.32 16_"," D ^ DIK
1893	"RTN","DGN OZMH",16,0 )
1894	. Q
1895	"RTN","DGN OZMH",17,0 )
1896	D INCDEL( DFN)
1897	"RTN","DGN OZMH",18,0 )
1898	Q
1899	"RTN","DGN OZMH",19,0 )
1900	INCDEL(DFN ) ;DELETE LAST MSE I F INCOMPLE TE
1901	"RTN","DGN OZMH",20,0 )
1902	Q:'$D(^DP T(DFN,.321 6))
1903	"RTN","DGN OZMH",21,0 )
1904	Q:$P(^DPT (DFN,.3216 ,0),U,4)=0
1905	"RTN","DGN OZMH",22,0 )
1906	Q:$P(^DPT (DFN,.3216 ,$P(^DPT(D FN,.3216,0 ),U,3),0), U,2)'=""
1907	"RTN","DGN OZMH",23,0 )
1908	Q:$P(^DPT (DFN,.3216 ,$P(^DPT(D FN,.3216,0 ),U,3),0), U,8)'=""
1909	"RTN","DGN OZMH",24,0 )
1910	S DA(1)=D FN,DA=$P(^ DPT(DFN,.3 216,0),U,3 ) S DIK="^ DPT("_DA(1 )_","_.321 6_"," D ^D IK
1911	"RTN","DGN OZMH",25,0 )
1912	Q
1913	"RTN","DGN OZMH",26,0 )
1914	ID1(DFN,DA ,DGNEW) ;D ELETE AN M SE IF INCO MPLETE
1915	"RTN","DGN OZMH",27,0 )
1916	Q:$G(DGNE W)=1
1917	"RTN","DGN OZMH",28,0 )
1918	G:$G(DA)= "" IDQ
1919	"RTN","DGN OZMH",29,0 )
1920	Q:$L($P($ G(^DPT(DFN ,.3216,DA, 0)),U,2))> 4
1921	"RTN","DGN OZMH",30,0 )
1922	Q:$P(^DPT (DFN,.3216 ,DA,0),U,8 )'=""
1923	"RTN","DGN OZMH",31,0 )
1924	S DA(1)=D FN,DIK="^D PT("_DA(1) _","_.3216 _"," D ^DI K K DIK
1925	"RTN","DGN OZMH",32,0 )
1926	IDQ ;
1927	"RTN","DGN OZMH",33,0 )
1928	Q
1929	"RTN","DGR P61")
1930	0^8^B57864 374
1931	"RTN","DGR P61",1,0)
1932	DGRP61 ;AL B/PJH,LBD, DJS - Pati ent MSDS H istory - L ist Manage r Screen ; 16 Oct 201 7 16:04:16
1933	"RTN","DGR P61",2,0)
1934	;;5.3;Reg istration; 797,909, 935;Aug 13,1993;Bu ild 53
1935	"RTN","DGR P61",3,0)
1936	;
1937	"RTN","DGR P61",4,0)
1938	EN(DFN) ;M ain entry point to i nvoke the DGEN MSDS PATIENT li st
1939	"RTN","DGR P61",5,0)
1940	; Input -- DFN Patient IEN
1941	"RTN","DGR P61",6,0)
1942	;
1943	"RTN","DGR P61",7,0)
1944	D WAIT^DI CD
1945	"RTN","DGR P61",8,0)
1946	D EN^VALM ("DGEN MSD S PATIENT" )
1947	"RTN","DGR P61",9,0)
1948	Q
1949	"RTN","DGR P61",10,0)
1950	;
1951	"RTN","DGR P61",11,0)
1952	HDR ;Heade r code
1953	"RTN","DGR P61",12,0)
1954	N DGPREFN M,X,VA,VAE RR
1955	"RTN","DGR P61",13,0)
1956	S VALMHDR (1)=$J("", 25)_"MILIT ARY SERVIC E DATA, SC REEN <6.1> "
1957	"RTN","DGR P61",14,0)
1958	D PID^VAD PT
1959	"RTN","DGR P61",15,0)
1960	S VALMHDR (2)=$E("Pa tient: "_$ P($G(^DPT( DFN,0)),U) ,1,30)
1961	"RTN","DGR P61",16,0)
1962	S VALMHDR (2)=VALMHD R(2)_" ("_ VA("BID")_ ")"
1963	"RTN","DGR P61",17,0)
1964	S X="PATI ENT TYPE U NKNOWN"
1965	"RTN","DGR P61",18,0)
1966	I $D(^DPT (DFN,"TYPE ")),$D(^DG (391,+^("T YPE"),0)) S X=$P(^(0 ),U,1)
1967	"RTN","DGR P61",19,0)
1968	S VALMHDR (2)=$$SETS TR^VALM1(X ,VALMHDR(2 ),60,80)
1969	"RTN","DGR P61",20,0)
1970	S VALMHDR (3)=$J("", 4)_"Servic e Branch/C omponent Service #"
1971	"RTN","DGR P61",21,0)
1972	S VALMHDR (3)=VALMHD R(3)_" Entere d Separ ated Dis charge"
1973	"RTN","DGR P61",22,0)
1974	Q
1975	"RTN","DGR P61",23,0)
1976	;
1977	"RTN","DGR P61",24,0)
1978	INIT ;Buil d patient MSDS scree n
1979	"RTN","DGR P61",25,0)
1980	D CLEAN^V ALM10
1981	"RTN","DGR P61",26,0)
1982	K ^TMP("D GRP61",$J) ,DGSEL
1983	"RTN","DGR P61",27,0)
1984	;
1985	"RTN","DGR P61",28,0)
1986	N GLBL
1987	"RTN","DGR P61",29,0)
1988	S GLBL=$N A(^TMP("DG RP61",$J))
1989	"RTN","DGR P61",30,0)
1990	D GETMSE( DFN,GLBL,1 )
1991	"RTN","DGR P61",31,0)
1992	;Check if any old M SEs didn't copy and display wa rning mess age
1993	"RTN","DGR P61",32,0)
1994	I $$WARNM SG^DGMSEUT L(DFN) D
1995	"RTN","DGR P61",33,0)
1996	.S VALMSG ="*More M SEs availa ble to vie w on Histo ry Screen *"
1997	"RTN","DGR P61",34,0)
1998	.D MSG^VA LM10(VALMS G)
1999	"RTN","DGR P61",35,0)
2000	Q
2001	"RTN","DGR P61",36,0)
2002	;
2003	"RTN","DGR P61",37,0)
2004	GETMSE(DFN ,GLBL,NUM) ;Load ser vice episo des from . 3216 array
2005	"RTN","DGR P61",38,0)
2006	; INPUT: DFN = Pati ent IEN
2007	"RTN","DGR P61",39,0)
2008	; GLBL = ^TM P global r ef
2009	"RTN","DGR P61",40,0)
2010	; NUM = 1 - display li ne numbers
2011	"RTN","DGR P61",41,0)
2012	N DGDATA, DGDATE,DGS UB,X1,X2,X
2013	"RTN","DGR P61",42,0)
2014	; DGSEL - selectabl e items, D GSEL("epis ode count" ) - episod e count fo r DGSEL
2015	"RTN","DGR P61",43,0)
2016	; not all items may be select able
2017	"RTN","DGR P61",44,0)
2018	K DGSEL S VALMCNT=0 ,DGDATE="" ,DGSEL("ep isode coun t")=0
2019	"RTN","DGR P61",45,0)
2020	F S DGDA TE=$O(^DPT (DFN,.3216 ,"B",DGDAT E),-1) Q:' DGDATE D
2021	"RTN","DGR P61",46,0)
2022	. S DGSUB =$O(^DPT(D FN,.3216," B",DGDATE, "")) Q:'DG SUB
2023	"RTN","DGR P61",47,0)
2024	. S DGDAT A=$G(^DPT( DFN,.3216, DGSUB,0)) Q:DGDATA=" "
2025	"RTN","DGR P61",48,0)
2026	. D EPISO DE(DGDATA, GLBL,NUM)
2027	"RTN","DGR P61",49,0)
2028	Q
2029	"RTN","DGR P61",50,0)
2030	;
2031	"RTN","DGR P61",51,0)
2032	EPISODE(DG DATA,GLBL, NUM) ;Form at individ ual servic e episode
2033	"RTN","DGR P61",52,0)
2034	N DGFDD,D GRPSB,DGRP SC,DGRPSD, DGRPSE,DGR PSN,DGRPSS ,Z
2035	"RTN","DGR P61",53,0)
2036	; increme nt episode count
2037	"RTN","DGR P61",54,0)
2038	S DGSEL(" episode co unt")=DGSE L("episode count")+1
2039	"RTN","DGR P61",55,0)
2040	S DGRPSB= +$P(DGDATA ,U,3),DGRP SC=$P(DGDA TA,U,4),DG RPSN=$P(DG DATA,U,5)
2041	"RTN","DGR P61",56,0)
2042	;Service Branch/Com ponent
2043	"RTN","DGR P61",57,0)
2044	S Z=$S($D (^DIC(23,D GRPSB,0)): $E($P(^(0) ,"^",1),1, 15),1:"UNK NOWN")
2045	"RTN","DGR P61",58,0)
2046	I DGRPSC' ="" D
2047	"RTN","DGR P61",59,0)
2048	. N Z0
2049	"RTN","DGR P61",60,0)
2050	. S Z0=$$ SVCCOMP^DG RP6CL(DGRP SC) Q:Z0=" "
2051	"RTN","DGR P61",61,0)
2052	. S Z=Z_" /"_Z0
2053	"RTN","DGR P61",62,0)
2054	;Filipino vet proof
2055	"RTN","DGR P61",63,0)
2056	I $$FV^DG RPMS(DGRPS B)=1 S Z=$ E(Z_$J("", 21),1,21)_ "("_$P($G( ^DPT(DFN,. 321)),U,14 )_")"
2057	"RTN","DGR P61",64,0)
2058	;Service Number
2059	"RTN","DGR P61",65,0)
2060	S Z=Z_$J( "",26-$L(Z ))_$S(DGRP SN]"":DGRP SN,1:"UNKN OWN")
2061	"RTN","DGR P61",66,0)
2062	S Z=Z_$J( "",42-$L(Z ))
2063	"RTN","DGR P61",67,0)
2064	;Entry an d separati on dates
2065	"RTN","DGR P61",68,0)
2066	S DGRPSE= $P(DGDATA, U,1),DGRPS S=$P(DGDAT A,U,2)
2067	"RTN","DGR P61",69,0)
2068	S X=$S(DG RPSE]"":$$ FMTE^XLFDT (DGRPSE,"5 DZ"),1:"UN KNOWN ")
2069	"RTN","DGR P61",70,0)
2070	S Z=Z_$E( X,1,10)_" "
2071	"RTN","DGR P61",71,0)
2072	S X=$S(DG RPSS]"":$$ FMTE^XLFDT (DGRPSS,"5 DZ"),1:"UN KNOWN ")
2073	"RTN","DGR P61",72,0)
2074	S Z=Z_$E( X,1,10)_" "
2075	"RTN","DGR P61",73,0)
2076	;DJS, Add FUTURE DI SCHARGE DA TE; DG5.3 935
2077	"RTN","DGR P61",74,0)
2078	;DGFDD = FUTURE DIS CHARGE DAT E (interna l)
2079	"RTN","DGR P61",75,0)
2080	;DGFDD("D ISP") = FU TURE DISCH ARGE DATE (display)
2081	"RTN","DGR P61",76,0)
2082	S DGFDD=$ P(DGDATA,U ,8),DGFDD( "DISP")=$S (DGFDD]"": $$FMTE^XLF DT(DGFDD," 5DZ"),1:"" )
2083	"RTN","DGR P61",77,0)
2084	;Discharg e type
2085	"RTN","DGR P61",78,0)
2086	S DGRPSD= +$P(DGDATA ,U,6)
2087	"RTN","DGR P61",79,0)
2088	I 'DGRPSD S Z=Z_"UN KNOWN"
2089	"RTN","DGR P61",80,0)
2090	E S Z=Z_ $S($D(^DIC (25,+DGRPS D)):$E($P( ^DIC(25,DG RPSD,0),"^ ",1),1,9), 1:"UNKNOWN ")
2091	"RTN","DGR P61",81,0)
2092	;
2093	"RTN","DGR P61",82,0)
2094	S VALMCNT =VALMCNT+1
2095	"RTN","DGR P61",83,0)
2096	; Add lin e numbers if NUM tru e
2097	"RTN","DGR P61",84,0)
2098	I $G(NUM) D
2099	"RTN","DGR P61",85,0)
2100	. ;DJS, I ndicate MS E episode with FDD n ot editabl e or delet able; DG5 .3935
2101	"RTN","DGR P61",86,0)
2102	. ; not s electable, put < > a round numb er, stop
2103	"RTN","DGR P61",87,0)
2104	. I $G(DG RPV)!($P(D GDATA,U,7) ]"")!($P(D GDATA,U,8) ]"") S Z=" <"_DGSEL(" episode co unt")_"> " _Z Q
2105	"RTN","DGR P61",88,0)
2106	. ; item is selecta ble, put i nto DGSEL, [ ] aroun d number
2107	"RTN","DGR P61",89,0)
2108	. S Z="[" _DGSEL("ep isode coun t")_"] "_Z ,DGSEL(DGS EL("episod e count")) =DGRPSE
2109	"RTN","DGR P61",90,0)
2110	;
2111	"RTN","DGR P61",91,0)
2112	; Save to List Mana ger array for displa y
2113	"RTN","DGR P61",92,0)
2114	S @GLBL@( VALMCNT,0) =$S($G(NUM ):Z,1:$J(" ",4)_Z)
2115	"RTN","DGR P61",93,0)
2116	D:DGFDD ; if FDD f ound, add to display
2117	"RTN","DGR P61",94,0)
2118	. S VALMC NT=VALMCNT +1,@GLBL@( VALMCNT,0) =" Futu re Dischar ge Date: " _DGFDD("DI SP")
2119	"RTN","DGR P61",95,0)
2120	Q
2121	"RTN","DGR P61",96,0)
2122	;
2123	"RTN","DGR P61",97,0)
2124	HELP ;Help code
2125	"RTN","DGR P61",98,0)
2126	S X="?" D DISP^XQOR M1 W !!
2127	"RTN","DGR P61",99,0)
2128	Q
2129	"RTN","DGR P61",100,0 )
2130	;
2131	"RTN","DGR P61",101,0 )
2132	EXIT ;Exit code
2133	"RTN","DGR P61",102,0 )
2134	D CLEAN^V ALM10
2135	"RTN","DGR P61",103,0 )
2136	D CLEAR^V ALM1
2137	"RTN","DGR P61",104,0 )
2138	K ^TMP("D GRP61",$J)
2139	"RTN","DGR P61",105,0 )
2140	Q
2141	"RTN","DGR P61",106,0 )
2142	;
2143	"RTN","DGR P61",107,0 )
2144	PEXIT ;DGE N MSDS MEN U protocol exit code
2145	"RTN","DGR P61",108,0 )
2146	S VALMSG= "+ Next Sc reen - P rev Screen ?? More Actions"
2147	"RTN","DGR P61",109,0 )
2148	;Reset af ter page u p or down
2149	"RTN","DGR P61",110,0 )
2150	;D XQORM
2151	"RTN","DGR P61",111,0 )
2152	Q
2153	"RTN","DGR P61",112,0 )
2154	;
2155	"RTN","DGR P61",113,0 )
2156	ACT(DGACT) ; Entry p oint for m enu action selection
2157	"RTN","DGR P61",114,0 )
2158	; INPUT: DGACT = "A " - Add - DGEN MSDS ADD protoc ol
2159	"RTN","DGR P61",115,0 )
2160	; = "E " - Edit - DGEN MSDS EDIT prot ocol
2161	"RTN","DGR P61",116,0 )
2162	; = "D " - Delete - DGEN MS DS DELETE protocol
2163	"RTN","DGR P61",117,0 )
2164	N DGX,DA, DIE,DIC,DI K,DIPA,DR, X,Y
2165	"RTN","DGR P61",118,0 )
2166	I $G(DGAC T)="" G AC TQ
2167	"RTN","DGR P61",119,0 )
2168	I $G(DGRP V) W !,"Vi ew only. T his action cannot be selected. " D PAUSE^ VALM1 G AC TQ
2169	"RTN","DGR P61",120,0 )
2170	D FULL^VA LM1
2171	"RTN","DGR P61",121,0 )
2172	I DGACT=" A" D ADD G ACTQ
2173	"RTN","DGR P61",122,0 )
2174	I '$O(DGS EL(0)) D G ACTQ
2175	"RTN","DGR P61",123,0 )
2176	. W !,"Th ere are no episodes to "_$S(DG ACT="E":"e dit.",1:"d elete.")
2177	"RTN","DGR P61",124,0 )
2178	. I $G(VA LMCNT) D H ECHLP
2179	"RTN","DGR P61",125,0 )
2180	. D PAUSE ^VALM1
2181	"RTN","DGR P61",126,0 )
2182	S DGX=$$S EL(DGACT) I 'DGX G A CTQ
2183	"RTN","DGR P61",127,0 )
2184	S DGX=$G( DGSEL(DGX) ) I 'DGX G ACTQ
2185	"RTN","DGR P61",128,0 )
2186	S DA(1)=D FN,DIC="^D PT("_DA(1) _",.3216," ,DIC(0)="B X",X=DGX
2187	"RTN","DGR P61",129,0 )
2188	D ^DIC I Y<0 W !,"T his episod e is not i n the pati ent's reco rd." D PAU SE^VALM1 G ACTQ
2189	"RTN","DGR P61",130,0 )
2190	S DIPA("D A")=+Y
2191	"RTN","DGR P61",131,0 )
2192	I DGACT=" E" K DA,DI C,DGFRDT S DIE="^DPT (",DA=DFN D SETDR1 D ^DIE G AC TQ
2193	"RTN","DGR P61",132,0 )
2194	; deletio n, ask use r first
2195	"RTN","DGR P61",133,0 )
2196	I DGACT=" D",$$RUSUR E S DIK=DI C,DA(1)=DF N,DA=DIPA( "DA") D ^D IK K DA,DI K
2197	"RTN","DGR P61",134,0 )
2198	;
2199	"RTN","DGR P61",135,0 )
2200	; DG5.3 909 Potent ially chan ge Camp Le jeune to N o with MSE changes
2201	"RTN","DGR P61",136,0 )
2202	ACTQ ; men u action e xit point
2203	"RTN","DGR P61",137,0 )
2204	D INIT S VALMBCK="R " D SETCLN O^DGENCLEA Q
2205	"RTN","DGR P61",138,0 )
2206	;
2207	"RTN","DGR P61",139,0 )
2208	ADD ; Add new MSE to #2.3216 s ub-file
2209	"RTN","DGR P61",140,0 )
2210	N X,Y,DIK ,DA,DR,DIE ,NEXT,DGFR DT
2211	"RTN","DGR P61",141,0 )
2212	; Get nex t record n umber in s ub-file
2213	"RTN","DGR P61",142,0 )
2214	S NEXT=$O (^DPT(DFN, .3216,"A") ,-1),NEXT= NEXT+1
2215	"RTN","DGR P61",143,0 )
2216	D ZNODE(1 )
2217	"RTN","DGR P61",144,0 )
2218	; Prompt for MSE fi elds
2219	"RTN","DGR P61",145,0 )
2220	S DIE="^D PT("_DFN_" ,.3216,",D A(1)=DFN,D A=NEXT D S ETDR2 D ^D IE
2221	"RTN","DGR P61",146,0 )
2222	I X["BAD" S DIK="^D PT("_DFN_" ,.3216,",D A(1)=DFN,D A=NEXT D ^ DIK
2223	"RTN","DGR P61",147,0 )
2224	; Check i f new reco rd is miss ing or inc omplete
2225	"RTN","DGR P61",148,0 )
2226	I '$D(^DP T(DFN,.321 6,NEXT)) D ZNODE(-1) Q
2227	"RTN","DGR P61",149,0 )
2228	I '$P(^DP T(DFN,.321 6,NEXT,0), U) D Q
2229	"RTN","DGR P61",150,0 )
2230	.S DIK="^ DPT("_DFN_ ",.3216,", DA(1)=DFN, DA=NEXT D ^DIK D ZNO DE(-1)
2231	"RTN","DGR P61",151,0 )
2232	;
2233	"RTN","DGR P61",152,0 )
2234	; File FI LIPINO VET PROOF, if set
2235	"RTN","DGR P61",153,0 )
2236	I $G(DIPA ("FVP"))]" " D
2237	"RTN","DGR P61",154,0 )
2238	.K DA,DR S DIE="^DP T(",DA=DFN ,DR=".3214 ///^S X=DI PA(""FVP"" )"
2239	"RTN","DGR P61",155,0 )
2240	.D ^DIE
2241	"RTN","DGR P61",156,0 )
2242	Q
2243	"RTN","DGR P61",157,0 )
2244	;
2245	"RTN","DGR P61",158,0 )
2246	SEL(ACT) ; function, prompt fo r episode to edit/de lete
2247	"RTN","DGR P61",159,0 )
2248	N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,X,Y
2249	"RTN","DGR P61",160,0 )
2250	; range i s 1 to epi sode count , must be in DGSEL t o be selec table
2251	"RTN","DGR P61",161,0 )
2252	S DIR(0)= "NAO^1:"_D GSEL("epis ode count" )_"^K:'$D( DGSEL(X)) X"
2253	"RTN","DGR P61",162,0 )
2254	S DIR("A" )="Select Episode: "
2255	"RTN","DGR P61",163,0 )
2256	S DIR("?" )="^D SELH LP^DGRP61( ACT)"
2257	"RTN","DGR P61",164,0 )
2258	D ^DIR I 'Y Q 0
2259	"RTN","DGR P61",165,0 )
2260	Q Y
2261	"RTN","DGR P61",166,0 )
2262	;
2263	"RTN","DGR P61",167,0 )
2264	SELHLP(ACT ) ; Help m essage for episode p rompt
2265	"RTN","DGR P61",168,0 )
2266	W !,"Sele ct an epis ode to ",$ S(ACT="E": "edit.",1: "delete.")
2267	"RTN","DGR P61",169,0 )
2268	W !,"Only numbers i n square b rackets [ ] are sele ctable."
2269	"RTN","DGR P61",170,0 )
2270	D HECHLP
2271	"RTN","DGR P61",171,0 )
2272	N DIR D P AUSE^VALM1
2273	"RTN","DGR P61",172,0 )
2274	Q
2275	"RTN","DGR P61",173,0 )
2276	HECHLP ; H elp messag e for epis odes that can only b e changed by HEC
2277	"RTN","DGR P61",174,0 )
2278	W !,"Angl ed bracket s < > indi cate episo des that c annot be c hanged in VistA."
2279	"RTN","DGR P61",175,0 )
2280	W !,"Plea se contact the HECAl ert mail g roup or th e HEC if y ou need to update"
2281	"RTN","DGR P61",176,0 )
2282	W !,"this informati on."
2283	"RTN","DGR P61",177,0 )
2284	Q
2285	"RTN","DGR P61",178,0 )
2286	;
2287	"RTN","DGR P61",179,0 )
2288	ZNODE(VAL) ; Update zero node of MSE mul tiple .321 6
2289	"RTN","DGR P61",180,0 )
2290	Q:'$G(VAL ) Q:'$G(D FN)
2291	"RTN","DGR P61",181,0 )
2292	N ZNODE
2293	"RTN","DGR P61",182,0 )
2294	S ZNODE=$ G(^DPT(DFN ,.3216,0))
2295	"RTN","DGR P61",183,0 )
2296	S ^DPT(DF N,.3216,0) ="^2.3216D ^"_($P(ZNO DE,U,3)+VA L)_U_($P(Z NODE,U,4)+ VAL)
2297	"RTN","DGR P61",184,0 )
2298	Q
2299	"RTN","DGR P61",185,0 )
2300	SETDR1 ; S et DR arra y to edit MSE fields
2301	"RTN","DGR P61",186,0 )
2302	S DR="I ' $G(DIPA("" DA"")) S Y =0;.3216// //^S X=""` ""_DIPA("" DA"");.321 4///^S X=$ G(DIPA(""F VP""))"
2303	"RTN","DGR P61",187,0 )
2304	S DR(2,2. 3216)="D S ET0^DGRP61 (.DA,.DIPA );@61;.03; S DIPA(""X "")=X;I X' ="""" S:$$ FV^DGRPMS( X)'=1 Y="" @62"";S DI PA(""FVP"" )=$$FVP^DG RP61"
2305	"RTN","DGR P61",188,0 )
2306	S DR(2,2. 3216,1)="I DIPA(""FV P"")=""^"" K DIPA("" FVP"") S Y =0;I DIPA( ""FVP"")=" """ D PRF^ DGRPE S Y= ""@61"";S Y=""@63"""
2307	"RTN","DGR P61",189,0 )
2308	S DR(2,2. 3216,2)="@ 62;D:DIPA( ""X"")]""" " WARN^DGR P61(.DIPA, .Y);.04;@6 3;.05;.01; .02;.06"
2309	"RTN","DGR P61",190,0 )
2310	Q
2311	"RTN","DGR P61",191,0 )
2312	SETDR2 ; S et DR arra y to add M SE fields
2313	"RTN","DGR P61",192,0 )
2314	S DR="@61 ;.03;S DIP A(""X"")=X ;I X'="""" S:$$FV^DG RPMS(X)'=1 Y=""@62"" ;S DIPA("" FVP"")=$$F VP^DGRP61; I DIPA(""F VP"")=""^" " S Y=0;I DIPA(""FVP "")="""" D PRF^DGRPE S Y=""@61 "";@62;S:' $$CMP^DGRP 61(DIPA("" X"")) Y="" @63"";.04; @63;.05;.0 1;.02;.06"
2315	"RTN","DGR P61",193,0 )
2316	Q
2317	"RTN","DGR P61",194,0 )
2318	FVP() ; Pr ompt for F ILIPINO VE T PROOF
2319	"RTN","DGR P61",195,0 )
2320	N DA,X,Y, DIR,DIRUT, DIROUT,DTO UT,DUOUT
2321	"RTN","DGR P61",196,0 )
2322	S DIR(0)= "2,.3214", DA=DFN
2323	"RTN","DGR P61",197,0 )
2324	D ^DIR I Y=""!(Y="^ ") Q Y
2325	"RTN","DGR P61",198,0 )
2326	Q Y
2327	"RTN","DGR P61",199,0 )
2328	;
2329	"RTN","DGR P61",200,0 )
2330	SET0(DA,DI PA) ; Set DIPA(0) to values of Service B ranch and Service Co mponent
2331	"RTN","DGR P61",201,0 )
2332	K DIPA(0)
2333	"RTN","DGR P61",202,0 )
2334	S DIPA(0) =$P($G(^DP T(DA(1),.3 216,DA,0)) ,U,3,4)
2335	"RTN","DGR P61",203,0 )
2336	Q
2337	"RTN","DGR P61",204,0 )
2338	;
2339	"RTN","DGR P61",205,0 )
2340	WARN(DIPA, Y) ;Warns that the S ervice Bra nch was ch anged so t he
2341	"RTN","DGR P61",206,0 )
2342	; Service Component was delet ed
2343	"RTN","DGR P61",207,0 )
2344	; Returns Y to skip component if the co mponent sh ould not b e asked
2345	"RTN","DGR P61",208,0 )
2346	; for t his branch of servic e
2347	"RTN","DGR P61",209,0 )
2348	I '$$CMP( $G(DIPA("X "))) S Y=" @63"
2349	"RTN","DGR P61",210,0 )
2350	I $P($G(D IPA(0)),U, 2)=""!($P( $G(DIPA(0) ),U)="") Q
2351	"RTN","DGR P61",211,0 )
2352	I $P(DIPA (0),U)=DIP A("X") Q ;Service Branch did n't change
2353	"RTN","DGR P61",212,0 )
2354	;
2355	"RTN","DGR P61",213,0 )
2356	I '$D(DIQ UIET) W !! ,7,"* WA RNING - BR ANCH OF SE RVICE WAS CHANGED SO THE COMPO NENT WAS D ELETED",!
2357	"RTN","DGR P61",214,0 )
2358	Q
2359	"RTN","DGR P61",215,0 )
2360	;
2361	"RTN","DGR P61",216,0 )
2362	CMP(X) ; F unction to determine if servic e componen t is valid for
2363	"RTN","DGR P61",217,0 )
2364	; branch of service ien in X 0 = inva lid 1 = v alid
2365	"RTN","DGR P61",218,0 )
2366	; Compone nt only va lid for AR MY/AIR FOR CE/MARINES /COAST GUA RD/NOAA/US PHS
2367	"RTN","DGR P61",219,0 )
2368	Q $S('$G( X):0,X'>5! (X=9)!(X=1 0):1,1:0)
2369	"RTN","DGR P61",220,0 )
2370	;
2371	"RTN","DGR P61",221,0 )
2372	RUSURE() ; Confirmat ion prompt for delet ing episod e
2373	"RTN","DGR P61",222,0 )
2374	N DIR,Y,X ,DIRUT,DIR OUT,DTOUT, DUOUT
2375	"RTN","DGR P61",223,0 )
2376	S DIR(0)= "YA",DIR(" B")="NO"
2377	"RTN","DGR P61",224,0 )
2378	S DIR("A" )="Are you sure you want to de lete this military s ervice epi sode? "
2379	"RTN","DGR P61",225,0 )
2380	D ^DIR I 'Y W !,"<< NOTHING D ELETED >>" Q 0
2381	"RTN","DGR P61",226,0 )
2382	Q 1
2383	"RTN","DGR P61",227,0 )
2384	;
2385	"RTN","DGR PCF")
2386	0^3^B26225 283
2387	"RTN","DGR PCF",1,0)
2388	DGRPCF ;AL B/MRL,BAJ, TDM,DJE - CONSISTENC Y OF PATIE NT DATA (F ILE/EDIT) ;Sep 28, 2 017 5:35P M
2389	"RTN","DGR PCF",2,0)
2390	;;5.3;Reg istration; 250,653, 786,754,86 7,935;Au g 13, 1993 ;Build 53
2391	"RTN","DGR PCF",3,0)
2392	;
2393	"RTN","DGR PCF",4,0)
2394	; file ne w inconsis tencies or update fi le entries for patie nt
2395	"RTN","DGR PCF",5,0)
2396	;
2397	"RTN","DGR PCF",6,0)
2398	; DGCT = count of i nconsisten cies found (passed i n from che cker)
2399	"RTN","DGR PCF",7,0)
2400	; DGCT1= count of i nconsisten cies which can't be edited bec ause
2401	"RTN","DGR PCF",8,0)
2402	; user does not hold a ppropriate key
2403	"RTN","DGR PCF",9,0)
2404	; DGCT2= count of a lready fil ed inconsi stencies
2405	"RTN","DGR PCF",10,0)
2406	; DGCT3= count of i nconsisten cies which are unedi table thro ugh
2407	"RTN","DGR PCF",11,0)
2408	; checker op tions
2409	"RTN","DGR PCF",12,0)
2410	; DGCTZ7= count of inconsiste ncies foun d that wil l prevent Z07
2411	"RTN","DGR PCF",13,0)
2412	;
2413	"RTN","DGR PCF",14,0)
2414	;
2415	"RTN","DGR PCF",15,0)
2416	;
2417	"RTN","DGR PCF",16,0)
2418	EN I '$D(D GCT) G KVA R^DGRPCE
2419	"RTN","DGR PCF",17,0)
2420	; DG5.3 653 BAJ mo dified to delete onl y inconsis tencies nu mbered 99 or less
2421	"RTN","DGR PCF",18,0)
2422	N DGADD S DGADD=0 ; 786 correc ts problem with inco rrect head er
2423	"RTN","DGR PCF",19,0)
2424	;I 'DGCT, $O(^DGIN(3 8.5,DFN,"I ",""),-1)> 99 D DELET E G KVAR^D GRPCE
2425	"RTN","DGR PCF",20,0)
2426	I 'DGCT D DELETE G KVAR^DGRPC E
2427	"RTN","DGR PCF",21,0)
2428	S DGEDCN= +$G(DGEDCN ),DGRPOUT= +$G(DGRPOU T),DGCON=1 D:DGEDCN START^DGRP C I 'DGCT D ^DGRPCF1 ,TIMEQ^DGR PC G KVAR^ DGRPCE
2429	"RTN","DGR PCF",22,0)
2430	S:'$D(^DG IN(38.5,DF N,0)) ^(0) =DFN_"^"_D T_"^"_$S(( '$D(DUZ)#2 ):"",1:DUZ ),DGADD=1 S X=$P(^(0 ),"^",4),^ DGIN(38.5, DFN,0)=$P( ^(0),"^",1 ,3)_"^"_DT _"^"_$S((' $D(DUZ)#2) :"",1:DUZ) _"^"_$P(^( 0),"^",6) K ^DGIN(38 .5,"AC",99 99999-X,DF N)
2431	"RTN","DGR PCF",23,0)
2432	S ^DGIN(3 8.5,"B",DF N,DFN)="", ^DGIN(38.5 ,"AC",9999 999-DT,DFN )="",^DGIN (38.5,0)=$ P(^DGIN(38 .5,0),"^", 1,2)_"^"_D FN_"^"_($P (^(0),"^", 4)+DGADD) ;786 corre cted for i ncorrect h eader
2433	"RTN","DGR PCF",24,0)
2434	I $D(^DGI N(38.5,DFN ,"I")) D D ELETE
2435	"RTN","DGR PCF",25,0)
2436	S DGD2=0 F DGD=1:1 S DGD1=$P( DGER,",",D GD) Q:DGD1 ="" I $D( ^DGIN(38.6 ,DGD1,0)) S DGD2=DGD 1 S ^DGIN( 38.5,DFN," I",DGD1,0) =DGD1
2437	"RTN","DGR PCF",26,0)
2438	S ^DGIN(3 8.5,DFN,"I ",0)="^38. 51PA^"_DGD 2_"^"_DGCT I DGCT,DG EDCN G DIS
2439	"RTN","DGR PCF",27,0)
2440	G KVAR^DG RPCE
2441	"RTN","DGR PCF",28,0)
2442	;
2443	"RTN","DGR PCF",29,0)
2444	;DJE DG5 .3935 - A dd Member ID To Vist a Registra tion Banne r - RM#879 322 (added SSNNM cal l)
2445	"RTN","DGR PCF",30,0)
2446	DIS D TIME ^DGRPC S D GRPE=$S($D (DGRPE):DG RPE+1,1:0) D KEY S I OP="HOME" D ^%ZIS K IOP W @IOF ,! D DEM^V ADPT W $$S SNNM^DGRPU (DFN),?65, $P(VADM(3) ,"^",2) S X="",$P(X, "=",79)="" W !,X
2447	"RTN","DGR PCF",31,0)
2448	S (C,DGCT 1,DGCT2,DG CT3,DGCTZ7 )=0,DGEDIT ="00000000 1111111001 1111113333 2222233133 3333222222 0030000" F I=1:1 S J =$P(DGER," ,",I) Q:J= "" I $D(^ DGIN(38.6, J,0)) S X2 =$P(^(0)," ^",1) D WR IT
2449	"RTN","DGR PCF",32,0)
2450	I DGCT1!D GCT3 W ! D NOEDIT
2451	"RTN","DGR PCF",33,0)
2452	I DGCTZ7 W !!,"Inco nsistencie s followed by [+] wi ll prevent a Z07"
2453	"RTN","DGR PCF",34,0)
2454	S DGINC55 =$S(DGER'[ 55:0,($G(D GRPVV(9))' ["0"):0,1: 1)
2455	"RTN","DGR PCF",35,0)
2456	EDIT G:DGR POUT BUL I DGCT1+DGC T3'=DGCT W !!,"DO YO U WANT TO UPDATE THE SE INCONSI STENCIES N OW" S %=1 D YN^DICN I %=1 D G ^DGRPC
2457	"RTN","DGR PCF",36,0)
2458	. S DGINC 55=$S(DGER '[55:0,($G (DGRPVV(9) )'["0"):0, 1:1)
2459	"RTN","DGR PCF",37,0)
2460	. L +^DPT (DFN):3 E W *7,!!," Patient is being edi ted. Try a gain later ." S DGED CN=0 Q
2461	"RTN","DGR PCF",38,0)
2462	. D ^DGRP CE
2463	"RTN","DGR PCF",39,0)
2464	. L -^DPT (DFN)
2465	"RTN","DGR PCF",40,0)
2466	. S DGEDC N=1
2467	"RTN","DGR PCF",41,0)
2468	I $S(($G( DGRETURN)> 10):0,$G(D GINC55):1, 1:0) D
2469	"RTN","DGR PCF",42,0)
2470	.N DIR
2471	"RTN","DGR PCF",43,0)
2472	.S DIR(0) ="Y",DIR(" A")="Do yo u wish to return to Screen #9 to enter m issing Inc ome Data? ",DIR("B") ="YES" D ^ DIR
2473	"RTN","DGR PCF",44,0)
2474	.S:Y>0 DG RPV=0
2475	"RTN","DGR PCF",45,0)
2476	.S:Y>0 DG RETURN=$G( DGRETURN)+ 1
2477	"RTN","DGR PCF",46,0)
2478	I $S($G(Y )'>0:0,(DG RETURN>11) :0,1:1) D ^DGRPV G ^ DGRP9
2479	"RTN","DGR PCF",47,0)
2480	I DGCT1+D GCT3'=DGCT ,'% W !!?4 ,"YES - To correct i nconsisten cies to un restricted fields im mediately. ",!?4,"NO - To abor t this pro cess immed iately." G EDIT
2481	"RTN","DGR PCF",48,0)
2482	I DGER[31 3 D
2483	"RTN","DGR PCF",49,0)
2484	. N DIR
2485	"RTN","DGR PCF",50,0)
2486	. S DIR(0 )="Y",DIR( "A")="Do y ou wish to return to Screen #1 5 to enter Sponsor i nformation ? ",DIR("B ")="YES" D ^DIR
2487	"RTN","DGR PCF",51,0)
2488	. S:Y>0 D GRPV=0
2489	"RTN","DGR PCF",52,0)
2490	. S:Y>0 D GRETURN=$G (DGRETURN) +1
2491	"RTN","DGR PCF",53,0)
2492	I $G(Y)>0 &(DGER[313 ) D ^DGRPV G ^DGRP15
2493	"RTN","DGR PCF",54,0)
2494	BUL K DGRE TURN,X,Y D ^DGRPCB G KVAR^DGRP CE
2495	"RTN","DGR PCF",55,0)
2496	;
2497	"RTN","DGR PCF",56,0)
2498	WRIT ;S C= C+1 W:(C#2 ) ! S X1=$ S((C#2):0, 1:40) W ?X 1,$E(J_" ",1,3),"- ",X2 I DGK EY(+$E(DGE DIT,J)) W "*" S DGCT 1=DGCT1+1
2499	"RTN","DGR PCF",57,0)
2500	S C=C+1 W :(C#2) ! S X1=$S((C# 2):0,1:40) W ?X1,$E( J_" ",1,3 ),"- "
2501	"RTN","DGR PCF",58,0)
2502	W X2 I DG KEY(+$E(DG EDIT,J))!( J=407) W " *" S DGCT1 =DGCT1+1
2503	"RTN","DGR PCF",59,0)
2504	I "^17^55 ^313^314^" [("^"_+J_" ^") W "**" S DGCT3=D GCT3+1
2505	"RTN","DGR PCF",60,0)
2506	I +$P(DGR PCOLD,",", 2),DGRPCOL D'[(","_J_ ",") S DGC T2=DGCT2+1
2507	"RTN","DGR PCF",61,0)
2508	I $P($G(^ DGIN(38.6, J,0)),"^", 6) W "+" S DGCTZ7=DG CTZ7+1
2509	"RTN","DGR PCF",62,0)
2510	Q
2511	"RTN","DGR PCF",63,0)
2512	KEY S X=$S (('$D(DUZ) #2):1,'$D( ^XUSEC("DG ELIGIBILI TY",DUZ)): 1,1:0) F I =.3,.32,.3 61 S DGP(I )=$S($D(^D PT(DFN,I)) :^(I),1:"" )
2513	"RTN","DGR PCF",64,0)
2514	F I=0:1:4 S DGKEY(I )=""
2515	"RTN","DGR PCF",65,0)
2516	I $P(DGP( .361),"^", 1)="V",X S DGKEY(1)= 1
2517	"RTN","DGR PCF",66,0)
2518	I $P(DGP( .3),"^",6) ]"",X S DG KEY(2)=1
2519	"RTN","DGR PCF",67,0)
2520	I $P(DGP( .32),"^",2 )]"",X S D GKEY(3)=1
2521	"RTN","DGR PCF",68,0)
2522	S:'X DGKE Y(4)=1 K D GP Q
2523	"RTN","DGR PCF",69,0)
2524	;
2525	"RTN","DGR PCF",70,0)
2526	DELETE ; D elete all Registrati on inconsi stencies f rom INCONS ISTENT DAT A file (#3 8.5).
2527	"RTN","DGR PCF",71,0)
2528	;
2529	"RTN","DGR PCF",72,0)
2530	;
2531	"RTN","DGR PCF",73,0)
2532	N RULE,DI K,DA
2533	"RTN","DGR PCF",74,0)
2534	;
2535	"RTN","DGR PCF",75,0)
2536	S RULE=0, DA=""
2537	"RTN","DGR PCF",76,0)
2538	S DIK="^D GIN(38.5," _DFN_","_" ""I"""_","
2539	"RTN","DGR PCF",77,0)
2540	;F S RUL E=$O(^DGIN (38.5,DFN, "I",RULE)) Q:RULE="" Q:RULE>9 9 S DA=RU LE D ^DIK
2541	"RTN","DGR PCF",78,0)
2542	F S RULE =$O(^DGIN( 38.5,DFN," I",RULE)) Q:RULE="" D
2543	"RTN","DGR PCF",79,0)
2544	. I RULE> 99,OVER99' [(","_RULE _",") Q
2545	"RTN","DGR PCF",80,0)
2546	. S DA=RU LE D ^DIK
2547	"RTN","DGR PCF",81,0)
2548	Q
2549	"RTN","DGR PCF",82,0)
2550	;
2551	"RTN","DGR PCF",83,0)
2552	NOEDIT ; w rite expla nation of non-editab le items
2553	"RTN","DGR PCF",84,0)
2554	I DGCT1 W !,"You wi ll not be able to ed it inconsi stencies f ollowed by an asteri sk [*]",!, "as you do not hold the approp riate ""DG ELIGIBILI TY"" secur ity key."
2555	"RTN","DGR PCF",85,0)
2556	I DGCT3 W !,"Incons istencies followed b y two (2) asterisks [**] must be correct ed by",!," using the appropriat e MAS menu option(s) ."
2557	"RTN","DGR PCF",86,0)
2558	I DGCT1+D GCT3'=DGCT W !!,"All items not followed by an aste risk can b e edited a t this tim e. If the se",!,"ite ms are not corrected at this t ime, a bul letin will be sent t o the",!," appropriat e hospital personnel ."
2559	"RTN","DGR PCF",87,0)
2560	;;QUIT
2561	"RTN","DGR PD1")
2562	0^2^B76824 98
2563	"RTN","DGR PD1",1,0)
2564	DGRPD1 ;BP FO/JRC,BAJ ,DJE - PAT IENT INQUI RY (NEW) ; Sep 28, 20 17 5:35PM
2565	"RTN","DGR PD1",2,0)
2566	;;5.3;Reg istration; 703,730, 688,863,93 5;Aug 13 , 1993;Bui ld 53
2567	"RTN","DGR PD1",3,0)
2568	; DG5.3 688 BAJ
2569	"RTN","DGR PD1",4,0)
2570	; tags HD R & OKLINE moved as is from DG RPD for si ze conside rations
2571	"RTN","DGR PD1",5,0)
2572	Q
2573	"RTN","DGR PD1",6,0)
2574	EC ;displa y emergenc y contact informatio n
2575	"RTN","DGR PD1",7,0)
2576	N DGEC1,D GEC2
2577	"RTN","DGR PD1",8,0)
2578	Q:'$G(DFN )
2579	"RTN","DGR PD1",9,0)
2580	S VAOA("A ")=1,VAROO T="DGEC1" D OAD^VAD PT ; Get P rimary EC
2581	"RTN","DGR PD1",10,0)
2582	S VAOA("A ")=4,VAROO T="DGEC2" D OAD^VAD PT ; Get S econdary E C
2583	"RTN","DGR PD1",11,0)
2584	I DGEC1(9 )]"" D
2585	"RTN","DGR PD1",12,0)
2586	. W !,"Em ergency Co ntact Info rmation:"
2587	"RTN","DGR PD1",13,0)
2588	. ;Contac ts name an d realtion ship
2589	"RTN","DGR PD1",14,0)
2590	. W !?5," E-Cont.: " ,DGEC1(9)
2591	"RTN","DGR PD1",15,0)
2592	. I DGEC2 (9)]"" W ? 40,"E2-Con t.: ",DGEC 2(9)
2593	"RTN","DGR PD1",16,0)
2594	. W !,"Re lationship : ",DGEC1( 10)
2595	"RTN","DGR PD1",17,0)
2596	. I DGEC2 (9)]"" W ? 36,"Relati onship: ", DGEC2(10)
2597	"RTN","DGR PD1",18,0)
2598	. ;ECs ad dress line s 1, 2 and 3
2599	"RTN","DGR PD1",19,0)
2600	. I DGEC1 (1)]"" W ! ?14,DGEC1( 1)
2601	"RTN","DGR PD1",20,0)
2602	. I DGEC1 (1)']"",DG EC2(1)]"" W !
2603	"RTN","DGR PD1",21,0)
2604	. I DGEC2 (1)]"" W ? 50,DGEC2(1 )
2605	"RTN","DGR PD1",22,0)
2606	. I DGEC1 (2)]"" W ! ?14,DGEC1( 2)
2607	"RTN","DGR PD1",23,0)
2608	. I DGEC1 (2)']"",DG EC2(2)]"" W !
2609	"RTN","DGR PD1",24,0)
2610	. I DGEC2 (2)]"" W ? 50,DGEC2(2 )
2611	"RTN","DGR PD1",25,0)
2612	. I DGEC1 (3)]"" W ! ?14,DGEC1( 3)
2613	"RTN","DGR PD1",26,0)
2614	. I DGEC1 (3)']"",DG EC2(3)]"" W !
2615	"RTN","DGR PD1",27,0)
2616	. I DGEC2 (3)]"" W ? 50,DGEC2(3 )
2617	"RTN","DGR PD1",28,0)
2618	. ;Emerge ncy Contac t 1 City, State an Z ip+4
2619	"RTN","DGR PD1",29,0)
2620	. I DGEC1 (4)]"" D
2621	"RTN","DGR PD1",30,0)
2622	. . W !?1 4,DGEC1(4)
2623	"RTN","DGR PD1",31,0)
2624	. . I DGE C1(5)]"" W ", "_$$GE T1^DIQ(5,+ DGEC1(5),1 )
2625	"RTN","DGR PD1",32,0)
2626	. . W " ",$P(DGEC1 (11),"^",2 )
2627	"RTN","DGR PD1",33,0)
2628	. ;Emerge ncy Contac t 2 City S tate and Z ip+4
2629	"RTN","DGR PD1",34,0)
2630	. I DGEC2 (4)]"" D
2631	"RTN","DGR PD1",35,0)
2632	. . I DGE C1(4)']"" W !
2633	"RTN","DGR PD1",36,0)
2634	. . W ?50 ,DGEC2(4)
2635	"RTN","DGR PD1",37,0)
2636	. . I DGE C2(5)]"" W ", "_$$GE T1^DIQ(5,+ DGEC2(5),1 )
2637	"RTN","DGR PD1",38,0)
2638	. . W " ",$P(DGEC2 (11),"^",2 )
2639	"RTN","DGR PD1",39,0)
2640	.;Home an d work pho nes
2641	"RTN","DGR PD1",40,0)
2642	. W !,?7, "Phone: ", $S(DGEC1(8 )]"":DGEC1 (8),1:"UNS PECIFIED")
2643	"RTN","DGR PD1",41,0)
2644	. I DGEC2 (9)]"" W ? 43,"Phone: ",$S(DGEC 2(8)]"":DG EC2(8),1:" UNSPECIFIE D")
2645	"RTN","DGR PD1",42,0)
2646	. W !?2," Work Phone : ",$S($P( ^DPT(DFN,. 33),U,11)] "":$P(^DPT (DFN,.33), U,11),1:"U NSPECIFIED ")
2647	"RTN","DGR PD1",43,0)
2648	. I DGEC2 (9)]"" W ? 38,"Work P hone: ",$S ($P(^DPT(D FN,.331),U ,11)]"":$P (^DPT(DFN, .331),U,11 ),1:"UNSPE CIFIED")
2649	"RTN","DGR PD1",44,0)
2650	D KVAR^VA DPT
2651	"RTN","DGR PD1",45,0)
2652	Q
2653	"RTN","DGR PD1",46,0)
2654	;
2655	"RTN","DGR PD1",47,0)
2656	CATDIS ;
2657	"RTN","DGR PD1",48,0)
2658	;displays catastrop hic disabi ty review date if th ere is one
2659	"RTN","DGR PD1",49,0)
2660	N DGCDIS
2661	"RTN","DGR PD1",50,0)
2662	Q:'$G(DFN )
2663	"RTN","DGR PD1",51,0)
2664	I $$GET^D GENCDA(DFN ,.DGCDIS) D
2665	"RTN","DGR PD1",52,0)
2666	.Q:'DGCDI S("REVDTE" )
2667	"RTN","DGR PD1",53,0)
2668	.W !!,"Ca tastrophic ally Disab led Review Date: ",$ $FMTE^XLFD T(DGCDIS(" REVDTE"),1 )
2669	"RTN","DGR PD1",54,0)
2670	Q
2671	"RTN","DGR PD1",55,0)
2672	HDR I '$D( IOF) S IOP ="HOME" D ^%ZIS K IO P
2673	"RTN","DGR PD1",56,0)
2674	;MPI/PD C HANGE
2675	"RTN","DGR PD1",57,0)
2676	;DJE DG5 .3935 - A dd Member ID To Vist a Registra tion Banne r - RM#879 322 (added SSNNM cal l)
2677	"RTN","DGR PD1",58,0)
2678	W @IOF,!, $$SSNNM^DG RPU(DFN),? 65,$P(VADM (3),"^",2) S X="",$P (X,"=",78) ="" W !,X, ! Q ;**86 3 - MVI_23 51 (ptd)
2679	"RTN","DGR PD1",59,0)
2680	;END MPI/ PD CHANGE
2681	"RTN","DGR PD1",60,0)
2682	OKLINE(DGL INE) ;DOES PAUSE/HEA DER IF $Y EXCEEDS DG LINE
2683	"RTN","DGR PD1",61,0)
2684	;
2685	"RTN","DGR PD1",62,0)
2686	;IN: DG LINE --MAX LINE COUN T W/O PAUS E
2687	"RTN","DGR PD1",63,0)
2688	;OUT: DG LINE[RETUR NED] -- 0 IF TIMEOUT /UP ARROW
2689	"RTN","DGR PD1",64,0)
2690	; DG RPOUT[SET] -- 1 IF "
2691	"RTN","DGR PD1",65,0)
2692	N X,Y ;* 286* MLR 09/25/00 Newing X & Y variab les prior to ^DIR
2693	"RTN","DGR PD1",66,0)
2694	I $G(IOST )["P-" Q D GLINE ; if printer, quit
2695	"RTN","DGR PD1",67,0)
2696	I $Y>DGLI NE N DIR S DIR(0)="E " D ^DIR D :Y HDR I ' Y S DGRPOU T=1,DGLINE =0
2697	"RTN","DGR PD1",68,0)
2698	Q DGLINE
2699	"RTN","DGR PD1",69,0)
2700	;
2701	"RTN","DGR PMS")
2702	0^11^B6885 3041
2703	"RTN","DGR PMS",1,0)
2704	DGRPMS ;AL B/BRM,LBD, DJS - MILI TARY SERVI CE APIS ;1 1 Oct 2017 11:14am
2705	"RTN","DGR PMS",2,0)
2706	;;5.3;Reg istration; 451,626, 646,673,68 9,688,797, 935;Aug 13, 1993;B uild 53
2707	"RTN","DGR PMS",3,0)
2708	;
2709	"RTN","DGR PMS",4,0)
2710	VALCON1(DF N,IEN,CDAT E,FRTO) ; Valid conf lict input for OIF/O EF/UNKNOWN OEF/OIF?
2711	"RTN","DGR PMS",5,0)
2712	; Need to send the ien of the multiple as well as the DFN a nd
2713	"RTN","DGR PMS",6,0)
2714	; determi ne the spe cific conf lict area
2715	"RTN","DGR PMS",7,0)
2716	N Z
2717	"RTN","DGR PMS",8,0)
2718	S Z=$P("O IF^OEF^UNK ",U,+$G(^D PT(DFN,.32 15,+IEN,0) ))
2719	"RTN","DGR PMS",9,0)
2720	;Q:Z="UNK " 1 ; Nev er need to check thi s - only e ntered thr ough HEC
2721	"RTN","DGR PMS",10,0)
2722	Q $$VALCO N(DFN,Z_"- "_IEN,CDAT E,FRTO)
2723	"RTN","DGR PMS",11,0)
2724	;
2725	"RTN","DGR PMS",12,0)
2726	VALCON(DFN ,CNFLCT,CD ATE,FRTO,O EIFAIL) ;i s this a v alid confl ict input?
2727	"RTN","DGR PMS",13,0)
2728	;
2729	"RTN","DGR PMS",14,0)
2730	;INPUT:
2731	"RTN","DGR PMS",15,0)
2732	; FR TO - 0=FRD T 1=TODT (defaults to FRDT if FRTO="")
2733	"RTN","DGR PMS",16,0)
2734	;OUTPUT:
2735	"RTN","DGR PMS",17,0)
2736	; OE IFAIL = 1 for not wi thin MSE f or OIF/OEF data (pas s by ref)
2737	"RTN","DGR PMS",18,0)
2738	;
2739	"RTN","DGR PMS",19,0)
2740	N RTN,X,Y ,FRDT,TODT ,CNFLCTV,I GNORE,COMP OW,MSG,DTC HK,CNFLCT2 ,OEFOIF
2741	"RTN","DGR PMS",20,0)
2742	S OEIFAIL =0
2743	"RTN","DGR PMS",21,0)
2744	Q:'$D(DFN ) "0^INVAL ID PATIENT "
2745	"RTN","DGR PMS",22,0)
2746	Q:'$D(^DP T(DFN)) "0 ^INVALID P ATIENT"
2747	"RTN","DGR PMS",23,0)
2748	Q:'$$VALI D^DGRPDT(. CDATE) "0^ INVALID DA TE"
2749	"RTN","DGR PMS",24,0)
2750	S FRTO=+$ G(FRTO)
2751	"RTN","DGR PMS",25,0)
2752	I 'FRTO S TODT=$$GE TDT(DFN,.C NFLCT),FRD T=CDATE K DGFRDT
2753	"RTN","DGR PMS",26,0)
2754	E S FRDT =$$GETDT(D FN,.CNFLCT ,FRTO) S:$ G(DGFRDT) FRDT=$G(DG FRDT) S TO DT=CDATE K DGFRDT
2755	"RTN","DGR PMS",27,0)
2756	S DTCHK=$ $DTUTIL^DG RPDT(CDATE ,$$GETDT(D FN,.CNFLCT ,'FRTO),1)
2757	"RTN","DGR PMS",28,0)
2758	I 'DTCHK D MSG($P(D TCHK,"^",2 ),2,2) Q D TCHK
2759	"RTN","DGR PMS",29,0)
2760	I CNFLCT= "COMB"!(CN FLCT="POW" ) D
2761	"RTN","DGR PMS",30,0)
2762	.S COMPOW =$S(CNFLCT ="COMB":1, 1:2)
2763	"RTN","DGR PMS",31,0)
2764	.S CNFLCT 2=CNFLCT
2765	"RTN","DGR PMS",32,0)
2766	.S CNFLCT =$$COMPOW( $S($G(DGCO MLOC):$P(D GCOMLOC,"^ "),1:$$GET DT(DFN,CNF LCT,3)))
2767	"RTN","DGR PMS",33,0)
2768	S CNFLCTV =""
2769	"RTN","DGR PMS",34,0)
2770	I CNFLCT] "" S CNFLC TV=$$CNFLC TDT^DGRPDT (FRDT,$S(F RTO:TODT,1 :""),.CNFL CT)
2771	"RTN","DGR PMS",35,0)
2772	I ('CNFLC TV) D MSG( $P(CNFLCTV ,"^",2),2, 1) Q CNFLC TV ;dates are not w ithin conf lict
2773	"RTN","DGR PMS",36,0)
2774	;
2775	"RTN","DGR PMS",37,0)
2776	S MSG=$S( '$G(COMPOW ):"Conflic t",$G(COMP OW)=2:"POW ",1:"Comba t")
2777	"RTN","DGR PMS",38,0)
2778	I FRDT,TO DT,'$$B4^D GRPDT(FRDT ,TODT,0) D MSG((MSG_ " From Dat e is not B efore "_MS G_" To Dat e"),2,1) Q "0^"_MSG_ " From Dat e is not B efore "_MS G_" To Dat e"
2779	"RTN","DGR PMS",39,0)
2780	S IGNORE= $S('$P(CNF LCT,"-",2) :$P($P($T( @($P(CNFLC T,"-")))," ;;",2),"^" ,FRTO+1),1 :"")
2781	"RTN","DGR PMS",40,0)
2782	S:$G(COMP OW) IGNORE =$P($P($T( @(CNFLCT2) ),";;",2), "^",FRTO+1 )
2783	"RTN","DGR PMS",41,0)
2784	;
2785	"RTN","DGR PMS",42,0)
2786	; Check f or overlap s and date s w/in MSE 's, except for POW D G5.3688
2787	"RTN","DGR PMS",43,0)
2788	S RTN=1
2789	"RTN","DGR PMS",44,0)
2790	I $G(COMP OW)'=2 D
2791	"RTN","DGR PMS",45,0)
2792	. S OEFOI F=$S($P(CN FLCT,"-",2 ):$P(CNFLC T,"-",2)_U _CNFLCT,1: ""),RTN=$$ COVRLP2^DG RPDT(DFN,F RDT,TODT,I GNORE,.OEF OIF)
2793	"RTN","DGR PMS",46,0)
2794	. I 'RTN, $G(OEFOIF) ,$G(OEFOIF (1)) S OEI FAIL=1
2795	"RTN","DGR PMS",47,0)
2796	Q:RTN RTN
2797	"RTN","DGR PMS",48,0)
2798	D MSG($P( RTN,"^",2) ,2,1)
2799	"RTN","DGR PMS",49,0)
2800	Q RTN
2801	"RTN","DGR PMS",50,0)
2802	;
2803	"RTN","DGR PMS",51,0)
2804	VALMSE(DFN ,MDATE,FRT O,FLD) ;is this a va lid Milita ry Service Episode d ate?
2805	"RTN","DGR PMS",52,0)
2806	;
2807	"RTN","DGR PMS",53,0)
2808	;INPUT:
2809	"RTN","DGR PMS",54,0)
2810	; FR TO - 0=FRD T 1=TODT (defaults to FRDT if FRTO="")
2811	"RTN","DGR PMS",55,0)
2812	; F LD - MSE f ield being edited/ad ded (MSL,M SNTL,MSNNT L)
2813	"RTN","DGR PMS",56,0)
2814	; "MSE- "_IEN of M SE in sub- file #2.32 16 (DG5.3 797)
2815	"RTN","DGR PMS",57,0)
2816	;
2817	"RTN","DGR PMS",58,0)
2818	N DTCHK,D UPCHK,FDDF LAG,FRDT,I GNORE,RTN, TODT,X,Y
2819	"RTN","DGR PMS",59,0)
2820	; DGCOMBR - branch of service , from inp ut transfo rms
2821	"RTN","DGR PMS",60,0)
2822	; FDDFLAG - boolean for FDD o verlap
2823	"RTN","DGR PMS",61,0)
2824	Q:'$D(DFN ) "0^INVAL ID PATIENT "
2825	"RTN","DGR PMS",62,0)
2826	Q:'$D(^DP T(DFN)) "0 ^INVALID P ATIENT"
2827	"RTN","DGR PMS",63,0)
2828	Q:'$$VALI D^DGRPDT(. MDATE) "0^ INVALID DA TE"
2829	"RTN","DGR PMS",64,0)
2830	; DJS, Ch eck for Fu ture Disch arge Date overlap; D G5.3935
2831	"RTN","DGR PMS",65,0)
2832	S (FDDFLA G,X)=0 F S X=$O(^DP T(DFN,.321 6,X)) Q:'X !FDDFLAG S Y=$G(^(X ,0)) I $P( Y,U,8),'(M DATE>$P(Y, U,8))&'(MD ATE<$P(Y,U )) S FDDFL AG=1
2833	"RTN","DGR PMS",66,0)
2834	I FDDFLAG D Q "0^F DD date ov erlap"
2835	"RTN","DGR PMS",67,0)
2836	. D MSG(" Date overl aps with a record th at has a F uture Disc harge Date .",2,1)
2837	"RTN","DGR PMS",68,0)
2838	;
2839	"RTN","DGR PMS",69,0)
2840	S FRTO=+$ G(FRTO)
2841	"RTN","DGR PMS",70,0)
2842	I 'FRTO S FRDT=MDAT E,TODT=$$G ETDT(DFN,. FLD,FRTO) K DGFRDT
2843	"RTN","DGR PMS",71,0)
2844	E S FRDT =$$GETDT(D FN,.FLD,FR TO) S:$G(D GFRDT) FRD T=$G(DGFRD T) S TODT= MDATE K DG FRDT
2845	"RTN","DGR PMS",72,0)
2846	S DTCHK=$ $DTUTIL^DG RPDT(MDATE ,$$GETDT(D FN,.FLD,'F RTO),1)
2847	"RTN","DGR PMS",73,0)
2848	I 'DTCHK D MSG($P(D TCHK,"^",2 ),2,2) K D GCOMBR Q D TCHK
2849	"RTN","DGR PMS",74,0)
2850	;Check fo r duplicat e Service Entry Date
2851	"RTN","DGR PMS",75,0)
2852	I 'FRTO,F RDT S DUPC HK=$$DUPCH K(DFN,.FRD T,.FLD) I 'DUPCHK D MSG($P(DUP CHK,"^",2) ,2,2) Q DU PCHK
2853	"RTN","DGR PMS",76,0)
2854	I FRTO,FR DT,TODT,'$ $B4^DGRPDT (.FRDT,.TO DT,0) D MS G("Service Entry Dat e is not b efore Serv ice Separa tion Date" ,2,1) K DG COMBR Q "0 ^Service E ntry Date is not bef ore Servic e Separati on Date"
2855	"RTN","DGR PMS",77,0)
2856	S IGNORE= $P($P($T(@ ($P(FLD,"- "))),";;", 2),"^",FRT O+1)
2857	"RTN","DGR PMS",78,0)
2858	S RTN=$$O VRLPCHK^DG RPDT(.DFN, .FRDT,.TOD T,1,.IGNOR E,,$P(FLD, "MSE-",2))
2859	"RTN","DGR PMS",79,0)
2860	I $G(DGCO MBR)']"" S DGCOMBR=$ $GETDT(DFN ,.FLD,4)
2861	"RTN","DGR PMS",80,0)
2862	I RTN,FRT O,$$BRANCH (.DGCOMBR) ,('$$WWII( DFN,TODT,. FLD)) D MS G("Branch of Service Requires WWII Dates of Servic e",2,1) K DGCOMBR Q "0^BOS Req uires WWII Dates"
2863	"RTN","DGR PMS",81,0)
2864	K DGCOMBR
2865	"RTN","DGR PMS",82,0)
2866	Q:RTN RTN
2867	"RTN","DGR PMS",83,0)
2868	D MSG($P( RTN,"^",2) ,2,1)
2869	"RTN","DGR PMS",84,0)
2870	Q RTN
2871	"RTN","DGR PMS",85,0)
2872	;
2873	"RTN","DGR PMS",86,0)
2874	BRANCH(DGC OMBR) ;bra nches of s ervice tha t require WWII servi ce dates
2875	"RTN","DGR PMS",87,0)
2876	N BRANCH
2877	"RTN","DGR PMS",88,0)
2878	Q:'$G(DGC OMBR) 0
2879	"RTN","DGR PMS",89,0)
2880	S BRANCH= $P(DGCOMBR ,"^",2)
2881	"RTN","DGR PMS",90,0)
2882	Q:BRANCH= "MERCHANT SEAMAN" 1
2883	"RTN","DGR PMS",91,0)
2884	Q:BRANCH= "F.COMMONW EALTH" 1
2885	"RTN","DGR PMS",92,0)
2886	Q:BRANCH= "F.GUERILL A" 1
2887	"RTN","DGR PMS",93,0)
2888	Q:BRANCH= "F.SCOUTS NEW" 1
2889	"RTN","DGR PMS",94,0)
2890	Q:BRANCH= "F.SCOUTS OLD" 1
2891	"RTN","DGR PMS",95,0)
2892	Q 0
2893	"RTN","DGR PMS",96,0)
2894	;
2895	"RTN","DGR PMS",97,0)
2896	VALCOMP(DF N,CODE,DGE PI) ; Veri fy compone nt is cons istent wit h the corr esponding
2897	"RTN","DGR PMS",98,0)
2898	; branch of servic e Also, b ranch of s ervice mus t be enter ed before
2899	"RTN","DGR PMS",99,0)
2900	; compon ent.
2901	"RTN","DGR PMS",100,0 )
2902	; ACTIVA TED NATION AL GUARD ( G) only va lid for AR MY or AIR FORCE bran ch
2903	"RTN","DGR PMS",101,0 )
2904	; ACTIVA TED RESERV E (V) only valid for ARMY, AIR FORCE, MA RINES, NAV Y
2905	"RTN","DGR PMS",102,0 )
2906	; or COAST GUARD bra nch
2907	"RTN","DGR PMS",103,0 )
2908	; DFN = i en of pati ent in fil e 2
2909	"RTN","DGR PMS",104,0 )
2910	; DGEPI = episode # to check (1=LAST, 2 =NTL, 3=NN TL)
2911	"RTN","DGR PMS",105,0 )
2912	; CODE = the compon ent code
2913	"RTN","DGR PMS",106,0 )
2914	; OUTPUT: 1 if vali d componen t
2915	"RTN","DGR PMS",107,0 )
2916	; 0 if inva lid compon ent or bra nch of ser v missing
2917	"RTN","DGR PMS",108,0 )
2918	N Z
2919	"RTN","DGR PMS",109,0 )
2920	;Get BOS from MSE m ultiple .3 216 if DGE PI contain s "MSE" (D G5.3797)
2921	"RTN","DGR PMS",110,0 )
2922	I $G(DGEP I)["MSE" S Z=+$P($G( ^DPT(DFN,. 3216,+DGEP I,0)),U,3)
2923	"RTN","DGR PMS",111,0 )
2924	E S Z=+$ P($G(^DPT( DFN,.32)), U,DGEPI*5)
2925	"RTN","DGR PMS",112,0 )
2926	I 'Z Q 0 ; Require bos
2927	"RTN","DGR PMS",113,0 )
2928	I CODE="R " Q 1 ; R egular is valid for all
2929	"RTN","DGR PMS",114,0 )
2930	Q:Z=1!(Z= 2) 1 ; Ar my (1)/air force (2) valid for guard and reserves
2931	"RTN","DGR PMS",115,0 )
2932	; reserve s also inc lude navy (3), marin es (4), co ast guard (5)
2933	"RTN","DGR PMS",116,0 )
2934	I CODE="V " Q $S(Z>2 &(Z<6):1,1 :0)
2935	"RTN","DGR PMS",117,0 )
2936	;
2937	"RTN","DGR PMS",118,0 )
2938	Q 0
2939	"RTN","DGR PMS",119,0 )
2940	;
2941	"RTN","DGR PMS",120,0 )
2942	GETDT(DFN, CNFLCT,FRT O) ; get f rom date, to date, o r location from pati ent file
2943	"RTN","DGR PMS",121,0 )
2944	;
2945	"RTN","DGR PMS",122,0 )
2946	N CFLDS,C FLD,CNF1,C NF2,RTN1,I ENS,FILE
2947	"RTN","DGR PMS",123,0 )
2948	Q:'$D(DFN ) ""
2949	"RTN","DGR PMS",124,0 )
2950	Q:'$D(^DP T(DFN)) ""
2951	"RTN","DGR PMS",125,0 )
2952	Q:$G(CNFL CT)="" ""
2953	"RTN","DGR PMS",126,0 )
2954	S:$G(FRTO )="" FRTO= 0
2955	"RTN","DGR PMS",127,0 )
2956	S CNF1=$P (CNFLCT,"- "),CNF2=+$ P(CNFLCT," -",2)
2957	"RTN","DGR PMS",128,0 )
2958	; OEF/OIF / UNKNOWN OEF/OIF da ta without a supplie d entry in the
2959	"RTN","DGR PMS",129,0 )
2960	; multi ple cannot be retrie ved OEF-1 indicates an OEF lo cation
2961	"RTN","DGR PMS",130,0 )
2962	; store d at the ' 1' subscri pt of the .3215 mult iple
2963	"RTN","DGR PMS",131,0 )
2964	I "^OEF^O IF^UNK^"[( U_CNF1_U), 'CNF2 Q ""
2965	"RTN","DGR PMS",132,0 )
2966	; MSE dat a retrieve d from .32 16 multipl e (DG5.3 797)
2967	"RTN","DGR PMS",133,0 )
2968	I CNF1="M SE",'CNF2 Q ""
2969	"RTN","DGR PMS",134,0 )
2970	S CFLDS=$ P($T(@(CNF 1)),";;",2 ) Q:CFLDS' ]"" ""
2971	"RTN","DGR PMS",135,0 )
2972	S CFLD=$S ('FRTO:$P( CFLDS,"^", 2),FRTO=1: $P(CFLDS," ^"),1:$P(C FLDS,"^",3 ))
2973	"RTN","DGR PMS",136,0 )
2974	Q:'CFLD " "
2975	"RTN","DGR PMS",137,0 )
2976	S IENS=DF N_",",FILE =2
2977	"RTN","DGR PMS",138,0 )
2978	; For MSE set ref t o sub-file 2.3216 (D G5.3797)
2979	"RTN","DGR PMS",139,0 )
2980	; For OIF /OEF set r ef to sub- file 2.321 5
2981	"RTN","DGR PMS",140,0 )
2982	S:CNF2 IE NS=CNF2_", "_IENS,FIL E=$S(CNF1= "MSE":2.32 16,1:2.321 5)
2983	"RTN","DGR PMS",141,0 )
2984	S RTN1=$$ GET1^DIQ(F ILE,IENS,C FLD,"I")
2985	"RTN","DGR PMS",142,0 )
2986	I FRTO=4 S RTN1=RTN 1_"^"_$$EX TERNAL^DIL FD(FILE,CF LD,"",RTN1 )
2987	"RTN","DGR PMS",143,0 )
2988	Q RTN1
2989	"RTN","DGR PMS",144,0 )
2990	;
2991	"RTN","DGR PMS",145,0 )
2992	WWII(DFN,T ODT,FLD) ; was this patient in WWII?
2993	"RTN","DGR PMS",146,0 )
2994	; this A PI assumes the WWII period to be from 12 /07/41-12/ 31/46
2995	"RTN","DGR PMS",147,0 )
2996	;
2997	"RTN","DGR PMS",148,0 )
2998	N OK,NODE ,DATA,WWII S,WWIIE,PA TDT,PATE,P ATS
2999	"RTN","DGR PMS",149,0 )
3000	Q:'$G(DFN ) "-1^UNKN OWN"
3001	"RTN","DGR PMS",150,0 )
3002	; Use MSE data from sub-file #2.3216 (D G5.3797)
3003	"RTN","DGR PMS",151,0 )
3004	I $G(FLD) ["MSE" S N ODE(2.3216 )=".01,.02 "
3005	"RTN","DGR PMS",152,0 )
3006	E S NODE (.32)=".32 6,.327,.32 85,.3292,. 3293,.3294 5,.3297,.3 298"
3007	"RTN","DGR PMS",153,0 )
3008	S WWIIS=2 411207,WWI IE=2461231
3009	"RTN","DGR PMS",154,0 )
3010	D GETDAT^ DGRPDT(DFN ,.NODE,.DA TA)
3011	"RTN","DGR PMS",155,0 )
3012	S PATDT=$ G(FLD) Q:P ATDT']"" 0
3013	"RTN","DGR PMS",156,0 )
3014	S PATS=$P ($G(DATA(P ATDT)),"^" ),PATE=$P( $G(DATA(PA TDT)),"^", 2)
3015	"RTN","DGR PMS",157,0 )
3016	S:'$G(TOD T) TODT=PA TE
3017	"RTN","DGR PMS",158,0 )
3018	S OK=0
3019	"RTN","DGR PMS",159,0 )
3020	S OK=$$WI THIN^DGRPD T(WWIIS,WW IIE,PATS)
3021	"RTN","DGR PMS",160,0 )
3022	S:'OK OK= $$WITHIN^D GRPDT(WWII S,WWIIE,TO DT)
3023	"RTN","DGR PMS",161,0 )
3024	S:'OK OK= $$RWITHIN^ DGRPDT(PAT S,TODT,WWI IS,WWIIE)
3025	"RTN","DGR PMS",162,0 )
3026	Q $G(OK)
3027	"RTN","DGR PMS",163,0 )
3028	DELMSE(DFN ,TYPE) ; d elete MSE from patie nt
3029	"RTN","DGR PMS",164,0 )
3030	;
3031	"RTN","DGR PMS",165,0 )
3032	; Input: DFN - Inte rnal entry number fo r the Pati ent File ( #2)
3033	"RTN","DGR PMS",166,0 )
3034	; T YPE - 1=La st MSE 2= Next to La st MSE 3= Next to Ne xt to Last
3035	"RTN","DGR PMS",167,0 )
3036	;
3037	"RTN","DGR PMS",168,0 )
3038	Q:'$G(TYP E)
3039	"RTN","DGR PMS",169,0 )
3040	Q:(('$G(D FN))!'$D(^ DPT(DFN)))
3041	"RTN","DGR PMS",170,0 )
3042	N IENS,FD A,X,X1,X2, Y,ZZ,ROOT
3043	"RTN","DGR PMS",171,0 )
3044	S IENS=DF N_",",ROOT ="FDA(2,IE NS)",X=""
3045	"RTN","DGR PMS",172,0 )
3046	I TYPE=1 F ZZ=.324, .326,.327, .328 S @RO OT@(ZZ)=X
3047	"RTN","DGR PMS",173,0 )
3048	I TYPE=2 F ZZ=.329, .3292,.329 3,.3294 S @ROOT@(ZZ) =X
3049	"RTN","DGR PMS",174,0 )
3050	I TYPE=3 F ZZ=.3295 ,.3297,.32 98,.3299 S @ROOT@(ZZ )=X
3051	"RTN","DGR PMS",175,0 )
3052	D FILE^DI E("K","FDA ","ERR")
3053	"RTN","DGR PMS",176,0 )
3054	Q
3055	"RTN","DGR PMS",177,0 )
3056	;
3057	"RTN","DGR PMS",178,0 )
3058	COMPOW(VAL ) ;convert POW and C ombat Loca tion field s
3059	"RTN","DGR PMS",179,0 )
3060	;
3061	"RTN","DGR PMS",180,0 )
3062	N ABRV
3063	"RTN","DGR PMS",181,0 )
3064	Q:'$G(VAL ) ""
3065	"RTN","DGR PMS",182,0 )
3066	S ABRV=$$ GET1^DIQ(2 2,VAL_",", 1,"I")
3067	"RTN","DGR PMS",183,0 )
3068	Q:ABRV="W WI" "WWI"
3069	"RTN","DGR PMS",184,0 )
3070	Q:ABRV="W WII-EUROPE " "WWIIE"
3071	"RTN","DGR PMS",185,0 )
3072	Q:ABRV="W WII-PACIFI C" "WWIIP"
3073	"RTN","DGR PMS",186,0 )
3074	Q:ABRV="K OREAN" "KO R"
3075	"RTN","DGR PMS",187,0 )
3076	Q:ABRV="V IETNAM" "V IET"
3077	"RTN","DGR PMS",188,0 )
3078	Q:ABRV="O THER" "OTH ER"
3079	"RTN","DGR PMS",189,0 )
3080	Q:ABRV="P ERSIAN GUL F" "GULF"
3081	"RTN","DGR PMS",190,0 )
3082	Q:ABRV="Y UGOSLAVIA" "YUG"
3083	"RTN","DGR PMS",191,0 )
3084	Q:ABRV="S OMALIA" "S OM"
3085	"RTN","DGR PMS",192,0 )
3086	Q ""
3087	"RTN","DGR PMS",193,0 )
3088	;
3089	"RTN","DGR PMS",194,0 )
3090	FV(X) ;Is this a Fil ipino Vet branch of service?
3091	"RTN","DGR PMS",195,0 )
3092	;Added fo r HVE II ( DG5.3451 )
3093	"RTN","DGR PMS",196,0 )
3094	;INPUT: X = IEN Br anch of Se rvice file #23
3095	"RTN","DGR PMS",197,0 )
3096	;OUTPUT: 1 = Filipi no Vet BOS (F.COMMON WEALTH, F. GUERILLA, F.SCOUTS N EW)
3097	"RTN","DGR PMS",198,0 )
3098	; 2 = Filipi no Vet BOS (F.SCOUTS OLD)
3099	"RTN","DGR PMS",199,0 )
3100	; 0 = Not Fi lipino Vet BOS
3101	"RTN","DGR PMS",200,0 )
3102	N FV
3103	"RTN","DGR PMS",201,0 )
3104	I '$G(X) Q 0
3105	"RTN","DGR PMS",202,0 )
3106	S FV=$P($ G(^DIC(23, X,0)),U,1)
3107	"RTN","DGR PMS",203,0 )
3108	Q $S(FV=" F.SCOUTS O LD":2,$E(F V,1,2)="F. ":1,1:0)
3109	"RTN","DGR PMS",204,0 )
3110	;
3111	"RTN","DGR PMS",205,0 )
3112	FVP ;MUMPS cross-ref erence "AF V1" on Ser vice Branc h [Last] ( #.325), "A FV2"
3113	"RTN","DGR PMS",206,0 )
3114	;on Servi ce Branch [NTL] (#.3 291), and "AFV3" on Service Br anch [NNTL ]
3115	"RTN","DGR PMS",207,0 )
3116	;(#.3296) in the Pa tient file #2. If t he Service Branch fi elds do no t
3117	"RTN","DGR PMS",208,0 )
3118	;contain a Filipino Veteran b ranch of s ervice, th e Filipino Vet Proof
3119	"RTN","DGR PMS",209,0 )
3120	;field (# .3214) wil l be delet ed.
3121	"RTN","DGR PMS",210,0 )
3122	Q:'$G(DA)
3123	"RTN","DGR PMS",211,0 )
3124	N BOS,MS, FV,IENS,FD A
3125	"RTN","DGR PMS",212,0 )
3126	S MS=$G(^ DPT(DA,.32 ))
3127	"RTN","DGR PMS",213,0 )
3128	F BOS=5,1 0,15 S FV= $$FV($P(MS ,U,BOS)) Q :FV=1
3129	"RTN","DGR PMS",214,0 )
3130	I FV=1 Q ;Filipino Vet BOS f ound, quit
3131	"RTN","DGR PMS",215,0 )
3132	;Delete F ilipino Ve t Proof
3133	"RTN","DGR PMS",216,0 )
3134	S IENS=DA _",",FDA(2 ,IENS,.321 4)="@"
3135	"RTN","DGR PMS",217,0 )
3136	D FILE^DI E("","FDA" )
3137	"RTN","DGR PMS",218,0 )
3138	Q
3139	"RTN","DGR PMS",219,0 )
3140	;
3141	"RTN","DGR PMS",220,0 )
3142	FVP1 ;MUMP S cross-re ference "A FV3216" on the Servi ce Branch field (#.0 3)
3143	"RTN","DGR PMS",221,0 )
3144	;in the M ilitary Se rvice Epis ode sub-fi le (#2.321 6) of the Patient
3145	"RTN","DGR PMS",222,0 )
3146	;file (#2 ). If non e of the S ervice Bra nch fields in the mu ltiple
3147	"RTN","DGR PMS",223,0 )
3148	;contain a Filipino Veteran b ranch of s ervice, th e Filipino Vet Proof
3149	"RTN","DGR PMS",224,0 )
3150	;field (# .3214) wil l be delet ed.
3151	"RTN","DGR PMS",225,0 )
3152	;Added fo r DG5.37 97
3153	"RTN","DGR PMS",226,0 )
3154	Q:'$G(DA( 1))
3155	"RTN","DGR PMS",227,0 )
3156	N BOS,MS, FV,IENS,FD A
3157	"RTN","DGR PMS",228,0 )
3158	S (FV,MS) =0
3159	"RTN","DGR PMS",229,0 )
3160	F S MS=$ O(^DPT(DA( 1),.3216,M S)) Q:'MS! (FV=1) D
3161	"RTN","DGR PMS",230,0 )
3162	.I $G(DA) =MS Q
3163	"RTN","DGR PMS",231,0 )
3164	.S BOS=$P ($G(^DPT(D A(1),.3216 ,MS,0)),U, 3)
3165	"RTN","DGR PMS",232,0 )
3166	.S FV=$$F V(BOS)
3167	"RTN","DGR PMS",233,0 )
3168	I FV=1 Q ;Filipino Vet BOS f ound, quit
3169	"RTN","DGR PMS",234,0 )
3170	;Delete F ilipino Ve t Proof
3171	"RTN","DGR PMS",235,0 )
3172	S IENS=DA (1)_",",FD A(2,IENS,. 3214)="@"
3173	"RTN","DGR PMS",236,0 )
3174	D FILE^DI E("","FDA" )
3175	"RTN","DGR PMS",237,0 )
3176	Q
3177	"RTN","DGR PMS",238,0 )
3178	;
3179	"RTN","DGR PMS",239,0 )
3180	DUPCHK(DFN ,FRDT,FLD) ; Check f or duplica te Service Entry Dat e
3181	"RTN","DGR PMS",240,0 )
3182	;INPUT: DFN = Pat ient file IEN
3183	"RTN","DGR PMS",241,0 )
3184	; FRDT = Ser vice Entry Date bein g checked
3185	"RTN","DGR PMS",242,0 )
3186	; FLD = "MS E-"_IEN of 2.3216 su b-file rec ord
3187	"RTN","DGR PMS",243,0 )
3188	;OUTPUT: DUP = Err or message if duplic ate found
3189	"RTN","DGR PMS",244,0 )
3190	; 1 = No duplicate found
3191	"RTN","DGR PMS",245,0 )
3192	N MSEIEN, IEN,MSE,DU P
3193	"RTN","DGR PMS",246,0 )
3194	I '$G(DFN ) Q 1
3195	"RTN","DGR PMS",247,0 )
3196	I '$G(FRD T) Q 1
3197	"RTN","DGR PMS",248,0 )
3198	S MSEIEN= $P($G(FLD) ,"MSE-",2) I 'MSEIEN Q 1
3199	"RTN","DGR PMS",249,0 )
3200	; Get MSE data
3201	"RTN","DGR PMS",250,0 )
3202	D GETMSE^ DGMSEUTL(D FN,.MSE) I '$D(MSE) Q 1
3203	"RTN","DGR PMS",251,0 )
3204	S IEN=0 F S IEN=$O (MSE(IEN)) Q:'IEN D
3205	"RTN","DGR PMS",252,0 )
3206	.I FRDT=$ P(MSE(IEN) ,"^"),'$D( MSE(IEN,MS EIEN)) S D UP="0^Dupl icate Serv ice Entry Date not a llowed"
3207	"RTN","DGR PMS",253,0 )
3208	I $D(DUP) Q DUP
3209	"RTN","DGR PMS",254,0 )
3210	Q 1
3211	"RTN","DGR PMS",255,0 )
3212	;
3213	"RTN","DGR PMS",256,0 )
3214	MSG(MSGTXT ,LF1,LF2) ; This api will form at the out put text i n order to utilize
3215	"RTN","DGR PMS",257,0 )
3216	; the EN^ DDIOL util ity.
3217	"RTN","DGR PMS",258,0 )
3218	;INPUT: MSGTXT = M essage tex t to displ ay
3219	"RTN","DGR PMS",259,0 )
3220	; LF1 = N umber of l ine feeds to preceed the messa ge
3221	"RTN","DGR PMS",260,0 )
3222	; L2F = N umber of l ine feeds to follow the messag e
3223	"RTN","DGR PMS",261,0 )
3224	;
3225	"RTN","DGR PMS",262,0 )
3226	N MSGARY, LFSTR
3227	"RTN","DGR PMS",263,0 )
3228	S $P(LFST R,"!",50)= "!"
3229	"RTN","DGR PMS",264,0 )
3230	S:$G(LF1) '="" MSGAR Y(.5,"F")= $E(LFSTR,1 ,(LF1-1))
3231	"RTN","DGR PMS",265,0 )
3232	S MSGARY( 1)=MSGTXT
3233	"RTN","DGR PMS",266,0 )
3234	S:$G(LF2) '="" MSGAR Y(2,"F")=$ E(LFSTR,1, LF2)
3235	"RTN","DGR PMS",267,0 )
3236	D EN^DDIO L(.MSGARY)
3237	"RTN","DGR PMS",268,0 )
3238	Q
3239	"RTN","DGR PMS",269,0 )
3240	;
3241	"RTN","DGR PMS",270,0 )
3242	CNFLCT ;; * DO NO T REMOVE B ELOW CONFL ICT FIELD LOCATIONS *
3243	"RTN","DGR PMS",271,0 )
3244	;; FROM D ATE^TO DAT E
3245	"RTN","DGR PMS",272,0 )
3246	WWI ;;
3247	"RTN","DGR PMS",273,0 )
3248	WWIIE ;;
3249	"RTN","DGR PMS",274,0 )
3250	WWIIP ;;
3251	"RTN","DGR PMS",275,0 )
3252	KOR ;;
3253	"RTN","DGR PMS",276,0 )
3254	VIET ;;.32 104^.32105
3255	"RTN","DGR PMS",277,0 )
3256	LEB ;;.322 2^.3223
3257	"RTN","DGR PMS",278,0 )
3258	GREN ;;.32 25^.3226
3259	"RTN","DGR PMS",279,0 )
3260	PAN ;;.322 8^.3229
3261	"RTN","DGR PMS",280,0 )
3262	GULF ;;.32 2011^.3220 12
3263	"RTN","DGR PMS",281,0 )
3264	SOM ;;.322 017^.32201 8
3265	"RTN","DGR PMS",282,0 )
3266	YUG ;;.322 02^.322021
3267	"RTN","DGR PMS",283,0 )
3268	OEF ;;.02^ .03
3269	"RTN","DGR PMS",284,0 )
3270	OIF ;;.02^ .03
3271	"RTN","DGR PMS",285,0 )
3272	UNK ;;.02^ .03
3273	"RTN","DGR PMS",286,0 )
3274	;;
3275	"RTN","DGR PMS",287,0 )
3276	;; BEL OW VALUES ARE USED F OR MSE CHE CKS - DO N OT REMOVE *
3277	"RTN","DGR PMS",288,0 )
3278	;; ENTRY DATE^SEPAR ATION DATE
3279	"RTN","DGR PMS",289,0 )
3280	MSE ;;.01^ .02^.03
3281	"RTN","DGR PMS",290,0 )
3282	MSL ;;.326 ^.327^.325
3283	"RTN","DGR PMS",291,0 )
3284	MSNTL ;;.3 292^.3293^ .3291
3285	"RTN","DGR PMS",292,0 )
3286	MSNNTL ;;. 3297^.3298 ^.3296
3287	"RTN","DGR PMS",293,0 )
3288	;;
3289	"RTN","DGR PMS",294,0 )
3290	;; **BEL OW VALUES ARE USED F OR POW AND COMBAT CH ECKS - DO NOT REMOVE
3291	"RTN","DGR PMS",295,0 )
3292	;; FROM D ATE^TO DAT E^LOCATION
3293	"RTN","DGR PMS",296,0 )
3294	COMB ;;.52 93^.5294^. 5292
3295	"RTN","DGR PMS",297,0 )
3296	POW ;;.527 ^.528^.526
3297	"RTN","DGR PMS",298,0 )
3298	;;
3299	"RTN","DGR PU")
3300	0^1^B88766 469
3301	"RTN","DGR PU",1,0)
3302	DGRPU ;ALB /MRL,TMK,B AJ,DJE - R EGISTRATIO N UTILITY ROUTINE ;S ep 28, 201 7 5:35PM
3303	"RTN","DGR PU",2,0)
3304	;;5.3;Reg istration; 33,114,4 89,624,672 ,689,688,9 35;Aug 1 3, 1993;Bu ild 53
3305	"RTN","DGR PU",3,0)
3306	H ;Screen Header
3307	"RTN","DGR PU",4,0)
3308	I DGRPS'= 1.1 W @IOF S Z=$P($T (H1+DGRPS) ,";;",2)_" , SCREEN < "_DGRPS_"> "_$S($D(DG RPH):" HEL P",1:""),X =79-$L(Z)\ 2 D W
3309	"RTN","DGR PU",5,0)
3310	I DGRPS=1 .1 W @IOF S Z="ADDIT IONAL PATI ENT DEMOGR APHIC DATA , SCREEN < "_DGRPS_"> "_$S($D(DG RPH):" HEL P",1:""),X =79-$L(Z)\ 2 D W
3311	"RTN","DGR PU",6,0)
3312	S X=$$SSN NM(DFN)
3313	"RTN","DGR PU",7,0)
3314	I '$D(DGR PH) W !,X S X=$S($D( DGRPTYPE): $P(DGRPTYP E,"^",1),1 :"PATIENT TYPE UNKNO WN"),X1=79 -$L(X) W ? X1,X
3315	"RTN","DGR PU",8,0)
3316	S X="",$P (X,"=",80) ="" W !,X Q
3317	"RTN","DGR PU",9,0)
3318	Q
3319	"RTN","DGR PU",10,0)
3320	AL(DGLEN) ;DGLEN= Av ailable le ngth of li ne
3321	"RTN","DGR PU",11,0)
3322	A ;Format address(es )
3323	"RTN","DGR PU",12,0)
3324	; DG5.3 688 BAJ 12 /20/2005 m odified fo r foreign address
3325	"RTN","DGR PU",13,0)
3326	I '$D(DGL EN) N DGLE N S DGLEN= 29
3327	"RTN","DGR PU",14,0)
3328	N I,DGX,F ILE,IEN,CN TRY,TMP,FN ODE,FPCE,R OU
3329	"RTN","DGR PU",15,0)
3330	; set up variables
3331	"RTN","DGR PU",16,0)
3332	S FNODE=$ S(DGAD=.12 1:.122,1:D GAD),FPCE= $S(DGAD=.1 21:3,DGAD= .141:16,1: 10)
3333	"RTN","DGR PU",17,0)
3334	; collect Street Ad dress info
3335	"RTN","DGR PU",18,0)
3336	F I=DGA1: 1:DGA1+2 I $P(DGRP(D GAD),U,I)] "" S TMP(D GA2)=$P(DG RP(DGAD),U ,I),DGA2=D GA2+2
3337	"RTN","DGR PU",19,0)
3338	I DGA2=1 S TMP(1)=" STREET ADD RESS UNKNO WN",DGA2=D GA2+2
3339	"RTN","DGR PU",20,0)
3340	; retriev e country info -- PE RM country is piece 10 of node .11
3341	"RTN","DGR PU",21,0)
3342	S FOR=0
3343	"RTN","DGR PU",22,0)
3344	I DGA1=1 D
3345	"RTN","DGR PU",23,0)
3346	. S FILE= 779.004,IE N=$P(DGRP( FNODE),U,F PCE),CNTRY =$E($$CNTR YI^DGADDUT L(IEN),1,2 5) I CNTRY =-1 S CNTR Y="UNKNOWN COUNTRY"
3347	"RTN","DGR PU",24,0)
3348	. ; assem ble (US) C ITY, STATE ZIP or (F OREIGN) CI TY PROVINC E POSTAL C ODE
3349	"RTN","DGR PU",25,0)
3350	. S FOR=$ $FORIEN^DG ADDUTL(IEN ) I FOR=-1 S FOR=1
3351	"RTN","DGR PU",26,0)
3352	S ROU=$S( FOR=1:"FOR EIGN",1:"U S")_"(DGAD ,.TMP,DGA1 ,.DGA2)" D @ROU
3353	"RTN","DGR PU",27,0)
3354	; append COUNTRY to address
3355	"RTN","DGR PU",28,0)
3356	S DGA2=DG A2+2,TMP(D GA2)=$S($G (CNTRY)="" :"",1:CNTR Y)
3357	"RTN","DGR PU",29,0)
3358	M DGA=TMP
3359	"RTN","DGR PU",30,0)
3360	K DGA1
3361	"RTN","DGR PU",31,0)
3362	Q
3363	"RTN","DGR PU",32,0)
3364	;
3365	"RTN","DGR PU",33,0)
3366	US(DGAD,TM P,DGA1,DGA 2) ;proces s US addre sses and f ormat in D GA array
3367	"RTN","DGR PU",34,0)
3368	; DG5.3 688 BAJ th is is the code for a ll address es prior t o the addi tion of Fo reign addr ess logic.
3369	"RTN","DGR PU",35,0)
3370	; Modific ations for Foreign a ddress are in Tag FO REIGN
3371	"RTN","DGR PU",36,0)
3372	N DGX,I,J
3373	"RTN","DGR PU",37,0)
3374	; format STATE fiel d and merg e with CIT Y & ZIP
3375	"RTN","DGR PU",38,0)
3376	S J=$S('$ D(^DIC(5,+ $P(DGRP(DG AD),U,DGA1 +4),0)):"" ,('$L($P(^ (0),U,2))) :$P(^(0),U ,1),1:$P(^ (0),U,2)), J(1)=$P(DG RP(DGAD),U ,DGA1+3),J (2)=$P(DGR P(DGAD),U, DGA1+5),TM P(DGA2)=$S (J(1)]""&( J]""):J(1) _","_J,J(1 )]"":J(1), J]"":J,1:" UNK. CITY/ STATE")
3377	"RTN","DGR PU",39,0)
3378	; zip cod e capture
3379	"RTN","DGR PU",40,0)
3380	I ".33^.3 4^.211^.33 1^.311^.25 ^.21"[DGAD D
3381	"RTN","DGR PU",41,0)
3382	.F I=1:1: 7 I $P(".3 3^.34^.211 ^.331^.311 ^.25^.21", U,I)=DGAD S DGX=$P($ G(^DPT(DFN ,.22)),U,I )
3383	"RTN","DGR PU",42,0)
3384	E D
3385	"RTN","DGR PU",43,0)
3386	.I DGAD=. 141 S DGX= $P(DGRP(.1 41),U,6) Q
3387	"RTN","DGR PU",44,0)
3388	.S DGX=$P (DGRP(DGAD ),U,DGA1+1 1)
3389	"RTN","DGR PU",45,0)
3390	; format ZIP+4 with hyphen
3391	"RTN","DGR PU",46,0)
3392	S:$L(DGX) >5 DGX=$E( DGX,1,5)_" -"_$E(DGX, 6,9)
3393	"RTN","DGR PU",47,0)
3394	;combine CITY,STATE and ZIP f ields on a single li ne
3395	"RTN","DGR PU",48,0)
3396	S TMP(DGA 2)=$E($P(T MP(DGA2)," ,",1),1,(D GLEN-($L(D GX)+4)))_$ S($L($P(TM P(DGA2),", ",2)):",", 1:"")_$P(T MP(DGA2)," ,",2)_" "_ DGX
3397	"RTN","DGR PU",49,0)
3398	F I=0:0 S I=$O(TMP( I)) Q:'I S TMP(I)=$ E(TMP(I),1 ,DGLEN)
3399	"RTN","DGR PU",50,0)
3400	Q
3401	"RTN","DGR PU",51,0)
3402	;
3403	"RTN","DGR PU",52,0)
3404	FOREIGN(DG AD,TMP,DGA 1,DGA2) ;p rocess FOR EIGN addre sses and f ormat in D GA array
3405	"RTN","DGR PU",53,0)
3406	N I,J,CIT Y,PRVNCE,P STCD,FNODE
3407	"RTN","DGR PU",54,0)
3408	F I=1:1 S J=$P($T(F NPCS+I),"; ;",3) Q:J= "QUIT" D
3409	"RTN","DGR PU",55,0)
3410	. I DGAD= $P(J,";",1 ) S FNODE= $P(J,";",2 ),CITY=$P( J,";",3),P RVNCE=$P(J ,";",4),PS TCD=$P(J," ;",5)
3411	"RTN","DGR PU",56,0)
3412	; assembl e CITY PRO VINCE and POSTAL COD E on the s ame line
3413	"RTN","DGR PU",57,0)
3414	; NOTE CI TY is some times on a different node than the PROVI NCE & POST AL CODE
3415	"RTN","DGR PU",58,0)
3416	S TMP(DGA 2)=$P(DGRP (FNODE),U, PSTCD)_" " _$P(DGRP(D GAD),U,CIT Y)_" "_$P( DGRP(FNODE ),U,PRVNCE )
3417	"RTN","DGR PU",59,0)
3418	F I=0:0 S I=$O(TMP( I)) Q:'I S TMP(I)=$ E(TMP(I),1 ,DGLEN)
3419	"RTN","DGR PU",60,0)
3420	Q
3421	"RTN","DGR PU",61,0)
3422	;
3423	"RTN","DGR PU",62,0)
3424	W I IOST=" C-QUME",$L (DGVI)'=2 W ?X,Z Q
3425	"RTN","DGR PU",63,0)
3426	W ?X,@DGV I,Z,@DGVO
3427	"RTN","DGR PU",64,0)
3428	Q
3429	"RTN","DGR PU",65,0)
3430	;
3431	"RTN","DGR PU",66,0)
3432	FNPCS ; Fo reign data pieces. Structure- ->Descript ion;;Main Node;Data Node;City; Province;P ostal code .
3433	"RTN","DGR PU",67,0)
3434	;;Permane nt;;.11;.1 1;4;8;9
3435	"RTN","DGR PU",68,0)
3436	;;Tempora ry;;.121;. 122;4;1;2
3437	"RTN","DGR PU",69,0)
3438	;;Confide ntial;;.14 1;.141;4;1 4;15
3439	"RTN","DGR PU",70,0)
3440	;;QUIT;;Q UIT
3441	"RTN","DGR PU",71,0)
3442	;
3443	"RTN","DGR PU",72,0)
3444	H1 ;
3445	"RTN","DGR PU",73,0)
3446	;;PATIENT DEMOGRAPH IC DATA
3447	"RTN","DGR PU",74,0)
3448	;;PATIENT DATA
3449	"RTN","DGR PU",75,0)
3450	;;EMERGEN CY CONTACT DATA
3451	"RTN","DGR PU",76,0)
3452	;;APPLICA NT/SPOUSE EMPLOYMENT DATA
3453	"RTN","DGR PU",77,0)
3454	;;INSURAN CE DATA
3455	"RTN","DGR PU",78,0)
3456	;;MILITAR Y SERVICE DATA
3457	"RTN","DGR PU",79,0)
3458	;;ELIGIBI LITY STATU S DATA
3459	"RTN","DGR PU",80,0)
3460	;;FAMILY DEMOGRAPHI C DATA
3461	"RTN","DGR PU",81,0)
3462	;;INCOME SCREENING DATA
3463	"RTN","DGR PU",82,0)
3464	;;INELIGI BLE/MISSIN G DATA
3465	"RTN","DGR PU",83,0)
3466	;;ELIGIBI LITY VERIF ICATION DA TA
3467	"RTN","DGR PU",84,0)
3468	;;ADMISSI ON INFORMA TION
3469	"RTN","DGR PU",85,0)
3470	;;APPLICA TION INFOR MATION
3471	"RTN","DGR PU",86,0)
3472	;;APPOINT MENT INFOR MATION
3473	"RTN","DGR PU",87,0)
3474	;;SPONSOR DEMOGRAPH IC INFORMA TION
3475	"RTN","DGR PU",88,0)
3476	;
3477	"RTN","DGR PU",89,0)
3478	;
3479	"RTN","DGR PU",90,0)
3480	INCOME(DFN ,DGDT) ; c ompute inc ome for ve teran...if not in 40 8.21, pass back file 2 data
3481	"RTN","DGR PU",91,0)
3482	; (called by PTF)
3483	"RTN","DGR PU",92,0)
3484	;
3485	"RTN","DGR PU",93,0)
3486	;
3487	"RTN","DGR PU",94,0)
3488	; Input: DFN as I EN of PATI ENT file
3489	"RTN","DGR PU",95,0)
3490	; DGDT as date to re turn incom e as of
3491	"RTN","DGR PU",96,0)
3492	;
3493	"RTN","DGR PU",97,0)
3494	; Output: total in come (comp uted funct ion)
3495	"RTN","DGR PU",98,0)
3496	; (from 40 8.21 if av ailable... otherwise from file 2)
3497	"RTN","DGR PU",99,0)
3498	;
3499	"RTN","DGR PU",100,0)
3500	;
3501	"RTN","DGR PU",101,0)
3502	N DGDEP,D GINC,DGREL ,DGTOT,DGX ,I S DGTOT =0
3503	"RTN","DGR PU",102,0)
3504	D ALL^DGM TU21(DFN," V",DGDT,"I ")
3505	"RTN","DGR PU",103,0)
3506	S DGX=$G( ^DGMT(408. 21,+$G(DGI NC("V")),0 )) I DGX]" " F I=8:1: 17 S DGTOT =DGTOT+$P( DGX,"^",I)
3507	"RTN","DGR PU",104,0)
3508	I DGX']"" S DGTOT=$ P($G(^DPT( DFN,.362)) ,U,20)
3509	"RTN","DGR PU",105,0)
3510	Q DGTOT
3511	"RTN","DGR PU",106,0)
3512	;
3513	"RTN","DGR PU",107,0)
3514	;
3515	"RTN","DGR PU",108,0)
3516	MTCOMP(DFN ,DGDT) ; i s current means test OR COPAY complete?
3517	"RTN","DGR PU",109,0)
3518	;
3519	"RTN","DGR PU",110,0)
3520	; Input: DFN as I EN of PATI ENT file
3521	"RTN","DGR PU",111,0)
3522	; DGDT as 'as of' da te
3523	"RTN","DGR PU",112,0)
3524	;
3525	"RTN","DGR PU",113,0)
3526	; Output: 1 if mea ns test/CO PAY for ye ar prior t o DT passe d is compl ete
3527	"RTN","DGR PU",114,0)
3528	; 0 otherw ise
3529	"RTN","DGR PU",115,0)
3530	; DGMTYPT 1=MT;2=CP; 0=NONE
3531	"RTN","DGR PU",116,0)
3532	;
3533	"RTN","DGR PU",117,0)
3534	N COMP,MT ,X,YR
3535	"RTN","DGR PU",118,0)
3536	S YR=$$LY R^DGMTSCU1 (DGDT),MT= $$LST^DGMT COU1(DFN,D GDT)
3537	"RTN","DGR PU",119,0)
3538	S DGMTYPT =+$P(MT,U, 5)
3539	"RTN","DGR PU",120,0)
3540	S COMP=1
3541	"RTN","DGR PU",121,0)
3542	I DGMTYPT =1 D ;MT
3543	"RTN","DGR PU",122,0)
3544	.I $P(MT, "^",4)']"" !("^R^N^"[ ("^"_$P(MT ,"^",4)_"^ ")) S COMP =0
3545	"RTN","DGR PU",123,0)
3546	I DGMTYPT =2 D ;CP
3547	"RTN","DGR PU",124,0)
3548	.I $P(MT, "^",4)']"" !("^I^L^"[ ("^"_$P(MT ,"^",4)_"^ ")) S COMP =0
3549	"RTN","DGR PU",125,0)
3550	S X=+$P(M T,"^",2) I ($E(X,1,3 )-1)*10000 <YR S COMP =0
3551	"RTN","DGR PU",126,0)
3552	Q COMP
3553	"RTN","DGR PU",127,0)
3554	;
3555	"RTN","DGR PU",128,0)
3556	HLP1010 ;* This is c alled by t he Executa ble Help f or Patient field #10 10.159
3557	"RTN","DGR PU",129,0)
3558	; (APPO INTMENT RE QUEST ON 1 010EZ)
3559	"RTN","DGR PU",130,0)
3560	W !!," Enter a ' Y' if the veteran ap plicant ha s requeste d an"
3561	"RTN","DGR PU",131,0)
3562	W !," appointmen t with a V A doctor o r provider and wants to be"
3563	"RTN","DGR PU",132,0)
3564	W !," seen as so on as one becomes av ailable E nter a 'N' "
3565	"RTN","DGR PU",133,0)
3566	W !," if the vet eran appli cant has n ot request ed an appo intment."
3567	"RTN","DGR PU",134,0)
3568	W !!," This ques tion may O NLY be ent ered ONCE for the ve teran."
3569	"RTN","DGR PU",135,0)
3570	W !," The answer to this q uestion CA NNOT be ch anged afte r the"
3571	"RTN","DGR PU",136,0)
3572	W !," initial en try.",!
3573	"RTN","DGR PU",137,0)
3574	Q
3575	"RTN","DGR PU",138,0)
3576	;
3577	"RTN","DGR PU",139,0)
3578	HLPCS ; * This is ca lled by th e Executab le Help fo r Income R elation fi eld #.1
3579	"RTN","DGR PU",140,0)
3580	Q:X="?"
3581	"RTN","DGR PU",141,0)
3582	N DIR,DGR DVAR
3583	"RTN","DGR PU",142,0)
3584	W !?8,"En ter in thi s field a Yes or No to indicat e whether the vetera n"
3585	"RTN","DGR PU",143,0)
3586	W !?8,"co ntributed any dollar amount to the child 's support last cale ndar"
3587	"RTN","DGR PU",144,0)
3588	W !?8,"ye ar. The c ontributio ns do not have to be in regula r set amou nts."
3589	"RTN","DGR PU",145,0)
3590	W !?8,"Fo r example, a veteran who paid a child's school tui tion or"
3591	"RTN","DGR PU",146,0)
3592	W !?8,"me dical bill s would be contribut ing to the child's s upport.",!
3593	"RTN","DGR PU",147,0)
3594	W !,"Ente r RETURN t o continue :" R DGRDV AR:DTIME W !
3595	"RTN","DGR PU",148,0)
3596	Q
3597	"RTN","DGR PU",149,0)
3598	;
3599	"RTN","DGR PU",150,0)
3600	HLP1823 ;* This is ca lled by th e Executab le Help fo r Patient Relation f ield #.18
3601	"RTN","DGR PU",151,0)
3602	N DIR,DGR DVAR
3603	"RTN","DGR PU",152,0)
3604	W !?7,"En ter 'Y' if the child is curren tly 18 to 23 years o ld and the child"
3605	"RTN","DGR PU",153,0)
3606	W !?7,"at tended sch ool last c alendar ye ar. Enter 'N' if th e child is currently "
3607	"RTN","DGR PU",154,0)
3608	W !?7,"18 to 23 yea rs old but the child did not a ttend scho ol last ca lendar"
3609	"RTN","DGR PU",155,0)
3610	W !?7,"ye ar. Enter 'N' if th e child is not curre ntly 18 to 23 years old.",!
3611	"RTN","DGR PU",156,0)
3612	I $G(DA) W !,"Enter RETURN to continue: " R DGRDVA R:DTIME W !
3613	"RTN","DGR PU",157,0)
3614	Q
3615	"RTN","DGR PU",158,0)
3616	;
3617	"RTN","DGR PU",159,0)
3618	HLPMLDS ;* This is c alled by t he Executa ble Help f or Patient field #.3 62
3619	"RTN","DGR PU",160,0)
3620	; (DISA BILITY RET . FROM MIL ITARY?)
3621	"RTN","DGR PU",161,0)
3622	N X,Y,DIR
3623	"RTN","DGR PU",162,0)
3624	W !!," E nter '0' o r 'NO' if the vetera n:"
3625	"RTN","DGR PU",163,0)
3626	W !," -- Is NOT retired fr om the mil itary OR"
3627	"RTN","DGR PU",164,0)
3628	W !," -- Is reti red from t he militar y due to l ength of s ervice AND "
3629	"RTN","DGR PU",165,0)
3630	W !," does NO T have a d isability confirmed by the Mil itary Bran ch"
3631	"RTN","DGR PU",166,0)
3632	W !," to have been incu rred in or aggravate d while on active du ty."
3633	"RTN","DGR PU",167,0)
3634	W !!," E nter '1' o r 'YES, RE CEIVING MI LITARY RET IREMENT' i f the vete ran:"
3635	"RTN","DGR PU",168,0)
3636	W !," -- Is conf irmed by t he Militar y Branch t o have bee n discharg ed"
3637	"RTN","DGR PU",169,0)
3638	W !," or rele ased due t o a disabi lity incur red in or aggravated "
3639	"RTN","DGR PU",170,0)
3640	W !," while o n active d uty AND"
3641	"RTN","DGR PU",171,0)
3642	W !," -- Has NOT filed a claim fo r VA compe nsation be nefits OR"
3643	"RTN","DGR PU",172,0)
3644	W !," -- Has been rated by the VA to be NSC OR"
3645	"RTN","DGR PU",173,0)
3646	W !," -- Has been rated by the VA to have n oncompensa ble 0%"
3647	"RTN","DGR PU",174,0)
3648	W !," SC c onditions. "
3649	"RTN","DGR PU",175,0)
3650	S DIR(0)= "E" D ^DIR Q:+Y<1
3651	"RTN","DGR PU",176,0)
3652	W !!," E nter '2' o r 'YES, RE CEIVING MI LITARY RET IREMENT IN LIEU OF V A"
3653	"RTN","DGR PU",177,0)
3654	W !," COMPENSA TION' if t he veteran :"
3655	"RTN","DGR PU",178,0)
3656	W !," -- Is c onfirmed b y the Mili tary Branc h to have been disch arged"
3657	"RTN","DGR PU",179,0)
3658	W !," or r eleased du e to a dis ability in curred in or aggrava ted"
3659	"RTN","DGR PU",180,0)
3660	W !," whil e on activ e duty AND "
3661	"RTN","DGR PU",181,0)
3662	W !," -- Is r eceiving m ilitary di sability r etirement pay AND"
3663	"RTN","DGR PU",182,0)
3664	W !," -- Has been rated by VA to have compe nsable SC conditions "
3665	"RTN","DGR PU",183,0)
3666	W !," but is NOT rec eiving com pensation from the V A"
3667	"RTN","DGR PU",184,0)
3668	W !!," Onc e eligibil ity has be en verifie d, this fi eld will n o longer"
3669	"RTN","DGR PU",185,0)
3670	W !," be e ditable to any user who does n ot hold th e designat ed securit y"
3671	"RTN","DGR PU",186,0)
3672	W !," key. "
3673	"RTN","DGR PU",187,0)
3674	Q
3675	"RTN","DGR PU",188,0)
3676	HLP3602 ;h elp text f or field . 3602, Rec' ing Disabi lity in Li eu of VA C omp
3677	"RTN","DGR PU",189,0)
3678	W !," Enter 'Y' if this v eteran app licant is receiving disability "
3679	"RTN","DGR PU",190,0)
3680	W !," retiremen t pay from the Milit ary instea d of VA co mpensation ."
3681	"RTN","DGR PU",191,0)
3682	W !," Enter 'N' if this v eteran app licant is not receiv ing disabi lity"
3683	"RTN","DGR PU",192,0)
3684	W !," retiremen t pay from the Milit ary instea d of VA co mpensation ."
3685	"RTN","DGR PU",193,0)
3686	W !," Once elig ibility ha s been ver ified by H EC this fi eld will n o longer "
3687	"RTN","DGR PU",194,0)
3688	W !," be editab le by Vist A users. S end update s and/or r equests to HEC."
3689	"RTN","DGR PU",195,0)
3690	Q
3691	"RTN","DGR PU",196,0)
3692	HLP3603 ;h elp text f or field . 3603, Disc harge Due to LOD Dis ability
3693	"RTN","DGR PU",197,0)
3694	W !," Enter 'Y' if this v eteran app licant was discharge d from the "
3695	"RTN","DGR PU",198,0)
3696	W !," military for a disa bility inc urred or a ggravated in the lin e "
3697	"RTN","DGR PU",199,0)
3698	W !," of duty. Enter 'N' if this v eteran app licant was not disch arged"
3699	"RTN","DGR PU",200,0)
3700	W !," from the military f or a disab ility incu rred or ag gravated i n the"
3701	"RTN","DGR PU",201,0)
3702	W !," line of d uty. Once eligibilit y has been verified by HEC thi s field"
3703	"RTN","DGR PU",202,0)
3704	W !," will no l onger be e ditable by VistA use rs. Send u pdates and /or reques ts"
3705	"RTN","DGR PU",203,0)
3706	W !," to HEC."
3707	"RTN","DGR PU",204,0)
3708	Q
3709	"RTN","DGR PU",205,0)
3710	SSNNM(DFN) ; SSN, ED IPI and na me on firs t line of screen
3711	"RTN","DGR PU",206,0)
3712	;DJE - DG 5.3935 - Add Membe r ID To Vi sta Regist ration Ban ner
3713	"RTN","DGR PU",207,0)
3714	N X,SSN,E DIPI,IDSTA T,J,ASFC,L IST,PT,STK
3715	"RTN","DGR PU",208,0)
3716	S X=$S($D (^DPT(+DFN ,0)):^(0), 1:""),SSN= $P(X,"^",9 ),SSN=$E(S SN,1,3)_"- "_$E(SSN,4 ,5)_"-"_$E (SSN,6,10)
3717	"RTN","DGR PU",209,0)
3718	;
3719	"RTN","DGR PU",210,0)
3720	S PT=DFN_ "^PI^USVHA ^"_$P($$SI TE^VASITE( ),U,3)
3721	"RTN","DGR PU",211,0)
3722	D TFL^VAF CTFU2(.LIS T,PT)
3723	"RTN","DGR PU",212,0)
3724	S EDIPI=" ",IDSTAT=" ",J=1
3725	"RTN","DGR PU",213,0)
3726	S STK="" F S STK=$ O(LIST(STK )) D Q:ST K=""
3727	"RTN","DGR PU",214,0)
3728	.Q:STK=""
3729	"RTN","DGR PU",215,0)
3730	.S ASFC=$ P(LIST(STK ),U,3)
3731	"RTN","DGR PU",216,0)
3732	.Q:ASFC'= "USDOD"
3733	"RTN","DGR PU",217,0)
3734	.S IDSTAT =$P(LIST(S TK),U,5)
3735	"RTN","DGR PU",218,0)
3736	.S EDIPI= $P(LIST(ST K),U,1)
3737	"RTN","DGR PU",219,0)
3738	.I (IDSTA T="A"),(ED IPI>1) S S TK="" Q ;First act ive EDIPI
3739	"RTN","DGR PU",220,0)
3740	.I IDSTAT ="H" S EDI PI(J)=EDIP I S J=J+1
3741	"RTN","DGR PU",221,0)
3742	.S EDIPI= ""
3743	"RTN","DGR PU",222,0)
3744	I IDSTAT= "H" S EDIP I=EDIPI(1) ; First i nactive ED IPI
3745	"RTN","DGR PU",223,0)
3746	S X=$P(X, U)_"; "_E DIPI_" "_ SSN
3747	"RTN","DGR PU",224,0)
3748	Q X
3749	"RTN","VAD PT4")
3750	0^10^B4369 8033
3751	"RTN","VAD PT4",1,0)
3752	VADPT4 ;AL B/MRL,MJK, ERC,DJS - PATIENT VA RIABLES ;1 6 Sep 2017 11:38AM
3753	"RTN","VAD PT4",2,0)
3754	;;5.3;Reg istration; 343,342, 528,689,68 8,790,797, 935;Aug 13, 1993;B uild 53
3755	"RTN","VAD PT4",3,0)
3756	7 ;Eligibi lity [ELIG ]
3757	"RTN","VAD PT4",4,0)
3758	F I=.15,. 3,.31,.32, .36,.361," INE","TYPE ","VET" S VAX(I)=$S( $D(^DPT(DF N,I)):^(I) ,1:"")
3759	"RTN","VAD PT4",5,0)
3760	S VAZ=$P( VAX(.36)," ^",1) S:$D (^DIC(8,+V AZ,0)) VAZ =VAZ_"^"_$ P(^(0),"^" ,1) S @VAV @($P(VAS," ^",1))=VAZ
3761	"RTN","VAD PT4",6,0)
3762	S VAX=0 F I=0:0 S V AX=$O(^DPT (DFN,"E",V AX)) Q:VAX '>0 S VAZ =VAX I $D( ^DIC(8,+VA Z,0)),+@VA V@($P(VAS, "^"))'=VAZ S VAZ=VAZ _"^"_$P(^D IC(8,+VAZ, 0),"^") S @VAV@($P(V AS,"^",1), VAX)=VAZ
3763	"RTN","VAD PT4",7,0)
3764	S VAZ=$P( VAX(.32)," ^",3) S:$D (^DIC(21,+ VAZ,0)) VA Z=VAZ_"^"_ $P(^(0),"^ ",1) S @VA V@($P(VAS, "^",2))=VA Z
3765	"RTN","VAD PT4",8,0)
3766	S VAZ=$S( $P(VAX(.3) ,"^",1)="Y ":1,1:0) S :VAZ VAZ=V AZ_"^"_$P( VAX(.3),"^ ",2) S @VA V@($P(VAS, "^",3))=VA Z
3767	"RTN","VAD PT4",9,0)
3768	S @VAV@($ P(VAS,"^", 4))=$S(VAX ("VET")="Y ":1,1:0),V AZ=$S(+$P( VAX(.15)," ^",2):0,1: 1),@VAV@($ P(VAS,"^", 5))=VAZ
3769	"RTN","VAD PT4",10,0)
3770	I VAZ F I =1:1:6 S @ VAV@($P(VA S,"^",5),I )="" G 71
3771	"RTN","VAD PT4",11,0)
3772	S VAZ=$P( VAX(.15)," ^",2),Y=VA Z X ^DD("D D") S @VAV @($P(VAS," ^",5),1)=V AZ_"^"_Y,V AZ=$P(VAX( "INE"),"^" ,1) S:VAZ] "" VAZ=VAZ _"^"_$P("V AMC^REGION AL OFFICE^ RPC","^",V AZ) S @VAV @($P(VAS," ^",5),2)=V AZ
3773	"RTN","VAD PT4",12,0)
3774	S @VAV@($ P(VAS,"^", 5),3)=$P(V AX("INE"), "^",3),VAZ =$P(VAX("I NE"),"^",4 ) S:$D(^DI C(5,+VAZ,0 )) VAZ=VAZ _"^"_$P(^( 0),"^",1) S @VAV@($P (VAS,"^",5 ),4)=VAZ
3775	"RTN","VAD PT4",13,0)
3776	S @VAV@($ P(VAS,"^", 5),5)=$P(V AX("INE"), "^",6),@VA V@($P(VAS, "^",5),6)= $P(VAX(.3) ,"^",7)
3777	"RTN","VAD PT4",14,0)
3778	71 S VAZ=V AX("TYPE") S:$D(^DG( 391,+VAZ,0 )) VAZ=VAZ _"^"_$P(^( 0),"^",1) S @VAV@($P (VAS,"^",6 ))=VAZ
3779	"RTN","VAD PT4",15,0)
3780	S @VAV@($ P(VAS,"^", 7))=$P(VAX (.31),"^", 3),VAZ=$P( VAX(.361), "^",1) S:V AZ]"" VAZ= VAZ_"^"_$S (VAZ="V":" VERIFIED", VAZ="P":"P ENDING VER IFICATION" ,VAZ="R":" PENDING RE -VERIFICAT ION",1:"") S @VAV@($ P(VAS,"^", 8))=VAZ
3781	"RTN","VAD PT4",16,0)
3782	I $D(^DPT (DFN,0)) S VAX=$P(^( 0),"^",14) ,VAX=$G(^D G(408.32,+ VAX,0)) I VAX]"" S @ VAV@($P(VA S,"^",9))= $P(VAX,"^" ,2)_"^"_$P (VAX,"^",1 )
3783	"RTN","VAD PT4",17,0)
3784	Q
3785	"RTN","VAD PT4",18,0)
3786	;
3787	"RTN","VAD PT4",19,0)
3788	8 ;Monetar y Benefits [MB]
3789	"RTN","VAD PT4",20,0)
3790	N DGTOTVA
3791	"RTN","VAD PT4",21,0)
3792	S @VAV@($ P(VAS,"^", 6))=0 ; SS I no longe r supporte d
3793	"RTN","VAD PT4",22,0)
3794	D ALL^DGM TU21(DFN," V",DT,"I")
3795	"RTN","VAD PT4",23,0)
3796	S VAX=$G( ^DGMT(408. 21,+$G(DGI NC("V")),0 )) F I=8,1 1,13 S @VA V@($S(I=8: $P(VAS,"^" ,3),I=11:$ P(VAS,"^", 5),1:$P(VA S,"^",8))) =$S($P(VAX ,"^",I)'=" ":"1^"_$P( VAX,"^",I) ,1:0)
3797	"RTN","VAD PT4",24,0)
3798	S VAX=$G( ^DPT(DFN,. 362))
3799	"RTN","VAD PT4",25,0)
3800	S DGTOTVA =$P(VAX,U, 20)
3801	"RTN","VAD PT4",26,0)
3802	F I=12,13 ,14 S @VAV @($S(I=12: $P(VAS,"^" ,1),(I=13) :$P(VAS,"^ ",2),1:$P( VAS,"^",4) ))=$S($P(V AX,"^",I)= "Y":1_U_DG TOTVA,1:0)
3803	"RTN","VAD PT4",27,0)
3804	S I=17 S @VAV@($P(V AS,"^",9)) =$S($P(VAX ,"^",17)=" Y":1_U_$P( VAX,U,6),1 :0)
3805	"RTN","VAD PT4",28,0)
3806	S VAX=$G( ^DPT(DFN,. 3)) S @VAV @($P(VAS," ^",7))=$S( $P(VAX,"^" ,11)="Y":1 _U_DGTOTVA ,1:0)
3807	"RTN","VAD PT4",29,0)
3808	K DGDEP,D GREL,DGINC ,DGINR Q
3809	"RTN","VAD PT4",30,0)
3810	;
3811	"RTN","VAD PT4",31,0)
3812	9 ;Service informati on
3813	"RTN","VAD PT4",32,0)
3814	F I=.32,. 321,.3291, .52,.53 S VAX(I)=$S( $D(^DPT(DF N,I)):^(I) ,1:"")
3815	"RTN","VAD PT4",33,0)
3816	D:$D(^DPT (DFN,.3216 )) MSDS
3817	"RTN","VAD PT4",34,0)
3818	S VAX("N" )=.321 F I =1,2,3 S V AX(3)=I,VA Z=$S($P(VA X(.321),"^ ",I)="Y":1 ,1:0),@VAV @($P(VAS," ^",VAX(3)) )=VAZ I VA Z S VAX(1) =$S(I=1:"4 ^5",I=2:"7 ^9^8",1:11 ),VAX(4)=0 D 91
3819	"RTN","VAD PT4",35,0)
3820	S VAX("N" )=.52 F I= 5,11 S VAX (3)=$S(I=5 :4,1:5),VA X(1)=$S(I= 5:"7^8",1: "13^14"),V AZ=$S($P(V AX(.52),"^ ",I)="Y":1 ,1:0),@VAV @($P(VAS," ^",VAX(3)) )=VAZ I VA Z S VAX(4) =0 D 91
3821	"RTN","VAD PT4",36,0)
3822	;Combat V et
3823	"RTN","VAD PT4",37,0)
3824	S VAX(3)= 10,VAX(1)= "15",VAZ=$ S($P(VAX(. 52),U,15)] "":1,1:0), @VAV@($P(V AS,U,VAX(3 )))=VAZ I VAZ S VAX( 4)=0 D 91
3825	"RTN","VAD PT4",38,0)
3826	F I=6,7,8 S @VAV@($ P(VAS,"^", I))="" F V AX(1)=1:1: 6 S @VAV@( $P(VAS,"^" ,I),VAX(1) )=""
3827	"RTN","VAD PT4",39,0)
3828	S VAX("N" )=.32,VAZ= $S($P(VAX( .32),"^",5 )]"":1,1:0 ),@VAV@($P (VAS,"^",6 ))=VAZ I V AZ,$P(VAX( .32),"^",1 9)="Y" S V AZ=1,@VAV@ ($P(VAS,"^ ",7))=VAZ I VAZ,$P(V AX(.32),"^ ",20)="Y" S @VAV@($P (VAS,"^",8 ))=1
3829	"RTN","VAD PT4",40,0)
3830	F I=6,7,8 I @VAV@($ P(VAS,"^", I)) S VAX( 3)=I,VAX(1 )=$S(I=6:" 6^7",I=7:" 11^12",1:" 16^17"),VA X(4)=3 D 9 1
3831	"RTN","VAD PT4",41,0)
3832	S VAX("N" )=.3291
3833	"RTN","VAD PT4",42,0)
3834	F I=6,7,8 I @VAV@($ P(VAS,"^", I)) S VAX( 3)=I,VAX(1 )=I-5,VAX( 4)=6 D 94
3835	"RTN","VAD PT4",43,0)
3836	S VAX("N" )=.53,VAX( 3)=9,VAX(1 )="2^3",VA Z=$S($P(VA X(.53),U)= "Y":1,$P(V AX(.53),U) ="N":1,1:0 ),@VAV@($P (VAS,U,VAX (3)))=$S($ P(VAX(.53) ,U)="Y":1, $P(VAX(.53 ),U)="N":0 ,1:"") I V AZ S VAX(4 )=0 D 93
3837	"RTN","VAD PT4",44,0)
3838	S VAX("N" )=.3215,VA Z=$$GET^DG ENOEIF(DFN ,.VAZ,1)
3839	"RTN","VAD PT4",45,0)
3840	;OEF/OIF
3841	"RTN","VAD PT4",46,0)
3842	F I=11,12 ,13 S @VAV @(I)=+$G(V AZ($P("OIF ^OEF^UNK", U,I-10),"C OUNT"))
3843	"RTN","VAD PT4",47,0)
3844	S VAX(2)= 11
3845	"RTN","VAD PT4",48,0)
3846	F I="OIF" ,"OEF","UN K" S VAX=0 F S VAX= $O(VAZ(I,V AX)) S:'VA X VAX(2)=V AX(2)+1 Q: 'VAX S VA X(3)=0 D
3847	"RTN","VAD PT4",49,0)
3848	. N Z
3849	"RTN","VAD PT4",50,0)
3850	. F VAX(1 )="LOC","F R","TO" S VAX(3)=VAX (3)+1,Z=$G (VAZ(I,VAX ,VAX(1))), @VAV@(VAX( 2),VAX,VAX (3))=Z D 9 5
3851	"RTN","VAD PT4",51,0)
3852	;SHAD - a dded with DG5.3688
3853	"RTN","VAD PT4",52,0)
3854	S VAX(3)= 14,VAZ=$S( $P(VAX(.32 1),U,15)]" ":1,1:0),@ VAV@($P(VA S,U,VAX(3) ))=VAZ I V AZ S @VAV@ ($P(VAS,U, VAX(3)),1) =$S($P(VAX (.321),U,1 5)=1:"1^YE S",1:"0^NO ")
3855	"RTN","VAD PT4",53,0)
3856	Q
3857	"RTN","VAD PT4",54,0)
3858	;
3859	"RTN","VAD PT4",55,0)
3860	91 ;date f ields
3861	"RTN","VAD PT4",56,0)
3862	F VAX(2)= 1:1 S VAX( 4)=VAX(4)+ 1,X=+$P(VA X(1),"^",V AX(2)) Q:' X S X=$P( VAX(VAX("N ")),"^",X) ,VAZ=X,Y=V AZ X:Y]"" ^DD("DD") S @VAV@($P (VAS,"^",V AX(3)),VAX (4))=$S(VA Z]"":VAZ_" ^"_Y,1:"")
3863	"RTN","VAD PT4",57,0)
3864	Q:VAX(3)= 1!(VAX(3)= 9)!(VAX(3) =10)
3865	"RTN","VAD PT4",58,0)
3866	;some set s of codes
3867	"RTN","VAD PT4",59,0)
3868	I VAX(3)= 2 S @VAV@( $P(VAS,"^" ,2),4)=$P( VAX(.321), "^",10) S (X,VAZ)=$P (VAX(.321) ,"^",13) S :X]"" VAZ= VAZ_"^"_$S (X="K":"KO REAN DMZ", 1:"VIETNAM ") S @VAV@ ($P(VAS,"^ ",2),5)=VA Z Q
3869	"RTN","VAD PT4",60,0)
3870	I VAX(3)< 4 S X=$P(V AX(.321)," ^",12),VAZ =X D
3871	"RTN","VAD PT4",61,0)
3872	.S:X]"" V AZ=VAZ_"^" _$S(X="2": "HIROSHIMA /NAGASAKI" ,X="3":"AT MOSPHERIC NUCLEAR TE STING",X=" 4":"H/N AN D ATMOSPHE RIC TESTIN G",X="5":" UNDERGROUN D NUCLEAR TESTING",X ="6":"EXPO SURE AT NU CLEAR FACI LITY",1:"O THER")
3873	"RTN","VAD PT4",62,0)
3874	.S @VAV@( $P(VAS,"^" ,3),2)=VAZ Q
3875	"RTN","VAD PT4",63,0)
3876	;POW, com bat locati ons
3877	"RTN","VAD PT4",64,0)
3878	I VAX(3)< 6 S X=$P(V AX(VAX("N" )),"^",$S( VAX(3)=4:6 ,1:12)),VA Z=X S:$D(^ DIC(22,+X, 0)) VAZ=VA Z_"^"_$P(^ (0),"^",1) S @VAV@($ P(VAS,"^", VAX(3)),3) =VAZ Q
3879	"RTN","VAD PT4",65,0)
3880	;service episodes
3881	"RTN","VAD PT4",66,0)
3882	S X=$S(VA X(3)=6:5,V AX(3)=7:10 ,1:15),VAX (2)=0 F VA X(5)=X,X+3 ,X-1 S VAX (2)=VAX(2) +1,VAZ=$P( VAX(VAX("N ")),"^",VA X(5)),@VAV @($P(VAS," ^",VAX(3)) ,VAX(2))=V AZ I "^4^5 ^9^10^14^1 5^"[("^"_V AX(5)_"^") ,+VAZ D 92
3883	"RTN","VAD PT4",67,0)
3884	Q
3885	"RTN","VAD PT4",68,0)
3886	92 ;pointe rs to Bran ch of Serv ice (23) a nd Type Di scharge (2 5)
3887	"RTN","VAD PT4",69,0)
3888	S VAX(6)= "^DIC("_$S ('(VAX(5)# 5):23,1:25 )_","_+VAZ _",0)" I $ D(@(VAX(6) )) S VAZ=$ P(^(0),"^" ,1),@VAV@( $P(VAS,"^" ,VAX(3)),V AX(2))=@VA V@($P(VAS, "^",VAX(3) ),VAX(2))_ "^"_VAZ
3889	"RTN","VAD PT4",70,0)
3890	Q
3891	"RTN","VAD PT4",71,0)
3892	93 ;Purple Heart
3893	"RTN","VAD PT4",72,0)
3894	NEW VAFIL E,VAIENS,V AFLDS,VAAR R,VAI
3895	"RTN","VAD PT4",73,0)
3896	S VAFILE= 2,VAIENS=D FN_",",VAF LDS=".532; .533"
3897	"RTN","VAD PT4",74,0)
3898	D GETS^DI Q(VAFILE,V AIENS,VAFL DS,"IEN"," VAARR")
3899	"RTN","VAD PT4",75,0)
3900	F VAI=1:1 S VAFLDS( VAI)=$P(VA FLDS,";",V AI) Q:VAFL DS(VAI)="" D
3901	"RTN","VAD PT4",76,0)
3902	. I '$D(V AARR(VAFIL E,VAIENS,V AFLDS(VAI) ,"I")),'$D (VAARR(VAF ILE,VAIENS ,VAFLDS(VA I),"E")) S @VAV@($P( VAS,"^",VA X(3)),VAI) =""
3903	"RTN","VAD PT4",77,0)
3904	. E S @V AV@($P(VAS ,U,VAX(3)) ,VAI)=$G(V AARR(VAFIL E,VAIENS,V AFLDS(VAI) ,"I"))_"^" _$G(VAARR( VAFILE,VAI ENS,VAFLDS (VAI),"E") )
3905	"RTN","VAD PT4",78,0)
3906	Q
3907	"RTN","VAD PT4",79,0)
3908	94 ;more m ilitary se rvice
3909	"RTN","VAD PT4",80,0)
3910	N VAARR,V AIENS,VAFL DS
3911	"RTN","VAD PT4",81,0)
3912	S VAIENS= DFN_",",VA FLDS=".329 1"_VAX(1)
3913	"RTN","VAD PT4",82,0)
3914	D GETS^DI Q(2,VAIENS ,VAFLDS,"I EN","VAARR ")
3915	"RTN","VAD PT4",83,0)
3916	I $G(VAAR R(2,VAIENS ,VAFLDS,"I "))'="" D
3917	"RTN","VAD PT4",84,0)
3918	. S @VAV@ ($P(VAS,"^ ",VAX(3)), VAX(4))=$G (VAARR(2,V AIENS,VAFL DS,"I"))_" ^"_$G(VAAR R(2,VAIENS ,VAFLDS,"E "))
3919	"RTN","VAD PT4",85,0)
3920	Q
3921	"RTN","VAD PT4",86,0)
3922	;
3923	"RTN","VAD PT4",87,0)
3924	95 ;OEF/OI F
3925	"RTN","VAD PT4",88,0)
3926	N X,Y
3927	"RTN","VAD PT4",89,0)
3928	I VAX(3)= 1 S $P(@VA V@(VAX(2), VAX,VAX(3) ),U,2)=$$E XTERNAL^DI LFD(2.3215 ,.01,"",Z)
3929	"RTN","VAD PT4",90,0)
3930	I VAX(3)= 2!(VAX(3)= 3) S Y=Z X ^DD("DD") S:Y'="" $ P(@VAV@(VA X(2),VAX,V AX(3)),U,2 )=Y
3931	"RTN","VAD PT4",91,0)
3932	Q
3933	"RTN","VAD PT4",92,0)
3934	;
3935	"RTN","VAD PT4",93,0)
3936	MSDS ;Retu rns latest service e pisodes fr om ESR sou rced data
3937	"RTN","VAD PT4",94,0)
3938	N BRANCH, COUNT,COMP ,DA,DONE,D TYP,EDATA, EDATE,I,SD ATE,SERVNO ,SUB
3939	"RTN","VAD PT4",95,0)
3940	S COUNT=0 ,EDATE=""
3941	"RTN","VAD PT4",96,0)
3942	;Clear mi litary ser vice disch arge, bran ch, start, end and n umber info
3943	"RTN","VAD PT4",97,0)
3944	F I=4:1:2 0 S $P(VAX (.32),U,I) =""
3945	"RTN","VAD PT4",98,0)
3946	;Clear mi litary ser vice compo nent info
3947	"RTN","VAD PT4",99,0)
3948	F I=1:1:3 S $P(VAX( .3291),U,I )=""
3949	"RTN","VAD PT4",100,0 )
3950	;Scan bac k for thre e most rec ent servic e episodes
3951	"RTN","VAD PT4",101,0 )
3952	F S EDAT E=$O(^DPT( DFN,.3216, "B",EDATE) ,-1) Q:'ED ATE D Q: COUNT'<3
3953	"RTN","VAD PT4",102,0 )
3954	.S DA=$O( ^DPT(DFN,. 3216,"B",E DATE,0)) Q :'DA
3955	"RTN","VAD PT4",103,0 )
3956	.;DJS, sk ip an MSE that has F uture Disc harge Date ; DG5.39 35
3957	"RTN","VAD PT4",104,0 )
3958	.S EDATA= $G(^DPT(DF N,.3216,DA ,0)) Q:EDA TA=""!($P( EDATA,U,8) '="")
3959	"RTN","VAD PT4",105,0 )
3960	.S COUNT= COUNT+1,SD ATE=$P(EDA TA,U,2)
3961	"RTN","VAD PT4",106,0 )
3962	.S BRANCH =$P(EDATA, U,3),COMP= $P(EDATA,U ,4)
3963	"RTN","VAD PT4",107,0 )
3964	.S SERVNO =$P(EDATA, U,5),DTYP= $P(EDATA,U ,6)
3965	"RTN","VAD PT4",108,0 )
3966	.;SL = 4, SNL = 9 o r SNNL = 1 4
3967	"RTN","VAD PT4",109,0 )
3968	.S SUB=(C OUNT*5)-1
3969	"RTN","VAD PT4",110,0 )
3970	.S $P(VAX (.32),U,SU B)=DTYP
3971	"RTN","VAD PT4",111,0 )
3972	.S $P(VAX (.32),U,SU B+1)=BRANC H
3973	"RTN","VAD PT4",112,0 )
3974	.S $P(VAX (.32),U,SU B+2)=EDATE
3975	"RTN","VAD PT4",113,0 )
3976	.S $P(VAX (.32),U,SU B+3)=SDATE
3977	"RTN","VAD PT4",114,0 )
3978	.S $P(VAX (.32),U,SU B+4)=SERVN O
3979	"RTN","VAD PT4",115,0 )
3980	.S $P(VAX (.3291),U, COUNT)=COM P
3981	"RTN","VAD PT4",116,0 )
3982	.S:SUB=9 $P(VAX(.32 ),U,19)="Y "
3983	"RTN","VAD PT4",117,0 )
3984	.S:SUB=14 $P(VAX(.3 2),U,20)=" Y"
3985	"RTN","VAD PT4",118,0 )
3986	Q
3987	"RTN","VAF HLZM2")
3988	0^9^B11134 578
3989	"RTN","VAF HLZM2",1,0 )
3990	VAFHLZM2 ; ALB/KCL,PJ H,LBD,DJS - Create H L7 Militar y History segment (Z MH) Cont ; 11 Oct 201 7 2:45pm
3991	"RTN","VAF HLZM2",2,0 )
3992	;;5.3;Reg istration; 673,797, 935;Aug 13, 1993;B uild 53
3993	"RTN","VAF HLZM2",3,0 )
3994	;
3995	"RTN","VAF HLZM2",4,0 )
3996	;-------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- --
3997	"RTN","VAF HLZM2",5,0 )
3998	;This rou tine creat es HL7 VA- specific M ilitary Hi story ("ZM H") segmen ts. It is a
3999	"RTN","VAF HLZM2",6,0 )
4000	;continua tion of VA FHLZM1 and uses vari ables from both VAFH LZMH and V AFHLZM1.
4001	"RTN","VAF HLZM2",7,0 )
4002	;-------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- --
4003	"RTN","VAF HLZM2",8,0 )
4004	;
4005	"RTN","VAF HLZM2",9,0 )
4006	;no direc t entry
4007	"RTN","VAF HLZM2",10, 0)
4008	Q
4009	"RTN","VAF HLZM2",11, 0)
4010	;
4011	"RTN","VAF HLZM2",12, 0)
4012	;
4013	"RTN","VAF HLZM2",13, 0)
4014	OEIF ;Buil d Operatio n Enduring /Iraqi Fre edom segme nts
4015	"RTN","VAF HLZM2",14, 0)
4016	;
4017	"RTN","VAF HLZM2",15, 0)
4018	N VAFDATA ,VAFFROM,V AFIDX,VAFN ODE,VAFSIT E,VAFTO,VA FTYPE
4019	"RTN","VAF HLZM2",16, 0)
4020	;
4021	"RTN","VAF HLZM2",17, 0)
4022	;need to build segm ent even i f no data in OEIF ar ray
4023	"RTN","VAF HLZM2",18, 0)
4024	S $P(VAFY ,VAFHLS,2) ="OEIF"
4025	"RTN","VAF HLZM2",19, 0)
4026	I VAFSTR[ ",3," S $P (VAFY,VAFH LS,3)=VAFH LQ_$E(VAFH LC)_VAFHLQ
4027	"RTN","VAF HLZM2",20, 0)
4028	I VAFSTR[ ",4," S $P (VAFY,VAFH LS,4)=VAFH LQ_$E(VAFH LC)_VAFHLQ
4029	"RTN","VAF HLZM2",21, 0)
4030	I VAFSTR[ ",5," S $P (VAFY,VAFH LS,5)=VAFH LQ
4031	"RTN","VAF HLZM2",22, 0)
4032	Q:'$D(VAF OPS)
4033	"RTN","VAF HLZM2",23, 0)
4034	;
4035	"RTN","VAF HLZM2",24, 0)
4036	;if data in OEIF ar ray, build segment f or each ep isode
4037	"RTN","VAF HLZM2",25, 0)
4038	S (VAFNOD E,VAFIDX)= 0
4039	"RTN","VAF HLZM2",26, 0)
4040	F S VAFN ODE=$O(VAF OPS(VAFNOD E)) Q:'$G( VAFNODE) D
4041	"RTN","VAF HLZM2",27, 0)
4042	.;
4043	"RTN","VAF HLZM2",28, 0)
4044	.S VAFDAT A=$G(VAFOP S(VAFNODE) )
4045	"RTN","VAF HLZM2",29, 0)
4046	.;
4047	"RTN","VAF HLZM2",30, 0)
4048	.I VAFSTR [",3," D
4049	"RTN","VAF HLZM2",31, 0)
4050	..S VAFTY PE=$$EXTER NAL^DILFD( 2.3215,.01 ,"F",$P(VA FDATA,U,1) ) I VAFTYP E']"" S VA FTYPE=VAFH LQ
4051	"RTN","VAF HLZM2",32, 0)
4052	..S VAFSI TE=$$STATI ON^VAFHLFN C($P(VAFDA TA,U,6)) I VAFSITE=" " S VAFSIT E=VAFHLQ
4053	"RTN","VAF HLZM2",33, 0)
4054	..S $P(VA FY,VAFHLS, 3)=VAFTYPE _$E(VAFHLC )_VAFSITE
4055	"RTN","VAF HLZM2",34, 0)
4056	.;
4057	"RTN","VAF HLZM2",35, 0)
4058	.I VAFSTR [",4," D
4059	"RTN","VAF HLZM2",36, 0)
4060	..S VAFFR OM=$P(VAFD ATA,U,2) S VAFFROM=$ S(VAFFROM: $$HLDATE^H LFNC(VAFFR OM),1:VAFH LQ)
4061	"RTN","VAF HLZM2",37, 0)
4062	..S VAFTO =$P(VAFDAT A,U,3) S V AFTO=$S(VA FTO:$$HLDA TE^HLFNC(V AFTO),1:VA FHLQ)
4063	"RTN","VAF HLZM2",38, 0)
4064	..S $P(VA FY,VAFHLS, 4)=VAFFROM _$E(VAFHLC )_VAFTO
4065	"RTN","VAF HLZM2",39, 0)
4066	.;
4067	"RTN","VAF HLZM2",40, 0)
4068	.I VAFSTR [",5," D
4069	"RTN","VAF HLZM2",41, 0)
4070	..S $P(VA FY,VAFHLS, 5)=VAFHLQ
4071	"RTN","VAF HLZM2",42, 0)
4072	.;
4073	"RTN","VAF HLZM2",43, 0)
4074	.;put seg ment into array
4075	"RTN","VAF HLZM2",44, 0)
4076	.S VAFIDX =VAFIDX+1
4077	"RTN","VAF HLZM2",45, 0)
4078	.S VAFY(V AFIDX)=$G( VAFY)
4079	"RTN","VAF HLZM2",46, 0)
4080	;
4081	"RTN","VAF HLZM2",47, 0)
4082	Q
4083	"RTN","VAF HLZM2",48, 0)
4084	;
4085	"RTN","VAF HLZM2",49, 0)
4086	;
4087	"RTN","VAF HLZM2",50, 0)
4088	NOSEG ;
4089	"RTN","VAF HLZM2",51, 0)
4090	Q
4091	"RTN","VAF HLZM2",52, 0)
4092	;
4093	"RTN","VAF HLZM2",53, 0)
4094	MSDS ;Retu rns all se rvice epis odes from ESR source d data
4095	"RTN","VAF HLZM2",54, 0)
4096	;
4097	"RTN","VAF HLZM2",55, 0)
4098	N BRANCH, COMP,DA,DA TE,DONE,DT YP,EDATA,E DATE,NUM,S DATE,SERVN O,VAFIDX
4099	"RTN","VAF HLZM2",56, 0)
4100	S DATE="" ,(NUM,VAFI DX)=0
4101	"RTN","VAF HLZM2",57, 0)
4102	;Scan bac k through entry date s for serv ice episod es
4103	"RTN","VAF HLZM2",58, 0)
4104	F S DATE =$O(^DPT(D FN,.3216," B",DATE),- 1) Q:'DATE D
4105	"RTN","VAF HLZM2",59, 0)
4106	.S DA=$O( ^DPT(DFN,. 3216,"B",D ATE,0)) Q: 'DA
4107	"RTN","VAF HLZM2",60, 0)
4108	.S EDATA= $G(^DPT(DF N,.3216,DA ,0)) Q:EDA TA=""
4109	"RTN","VAF HLZM2",61, 0)
4110	.;DJS, sk ip an MSE that has F uture Disc harge Date ; DG5.39 35
4111	"RTN","VAF HLZM2",62, 0)
4112	.Q:$P(EDA TA,U,8)'=" "
4113	"RTN","VAF HLZM2",63, 0)
4114	.S NUM=NU M+1
4115	"RTN","VAF HLZM2",64, 0)
4116	.S SDATE= $P(EDATA,U ,2),EDATE= DATE
4117	"RTN","VAF HLZM2",65, 0)
4118	.S BRANCH =$P(EDATA, U,3),COMP= $P(EDATA,U ,4)
4119	"RTN","VAF HLZM2",66, 0)
4120	.S SERVNO =$P(EDATA, U,5),DTYP= $P(EDATA,U ,6)
4121	"RTN","VAF HLZM2",67, 0)
4122	.S $P(VAF Y,VAFHLS,2 )=$S(NUM=1 :"SL",NUM= 2:"SNL",NU M=3:"SNNL" ,1:"MSD")
4123	"RTN","VAF HLZM2",68, 0)
4124	.I VAFSTR [",3," D
4125	"RTN","VAF HLZM2",69, 0)
4126	..S BRANC H=$S(BRANC H:$P($G(^D IC(23,BRAN CH,0)),U), 1:VAFHLQ)
4127	"RTN","VAF HLZM2",70, 0)
4128	..I SERVN O="" S SER VNO=VAFHLQ
4129	"RTN","VAF HLZM2",71, 0)
4130	..S DTYP= $S(DTYP:$P ($G(^DIC(2 5,DTYP,0)) ,U),1:VAFH LQ)
4131	"RTN","VAF HLZM2",72, 0)
4132	..; Servi ce branch~ Service nu mber~Servi ce dischar ge type
4133	"RTN","VAF HLZM2",73, 0)
4134	..S $P(VA FY,VAFHLS, 3)=BRANCH_ $E(VAFHLC) _SERVNO_$E (VAFHLC)_D TYP
4135	"RTN","VAF HLZM2",74, 0)
4136	.I VAFSTR [",4," D
4137	"RTN","VAF HLZM2",75, 0)
4138	..S EDATE =$S(EDATE: $$HLDATE^H LFNC(EDATE ),1:VAFHLQ )
4139	"RTN","VAF HLZM2",76, 0)
4140	..S SDATE =$S(SDATE: $$HLDATE^H LFNC(SDATE ),1:VAFHLQ )
4141	"RTN","VAF HLZM2",77, 0)
4142	..; Servi ce entry d ate~Servic e separati on date
4143	"RTN","VAF HLZM2",78, 0)
4144	..S $P(VA FY,VAFHLS, 4)=EDATE_$ E(VAFHLC)_ SDATE
4145	"RTN","VAF HLZM2",79, 0)
4146	.I VAFSTR [",5," D
4147	"RTN","VAF HLZM2",80, 0)
4148	..; Servi ce Compone nt [L]
4149	"RTN","VAF HLZM2",81, 0)
4150	..I COMP= "" S COMP= VAFHLQ
4151	"RTN","VAF HLZM2",82, 0)
4152	..S $P(VA FY,VAFHLS, 5)=COMP
4153	"RTN","VAF HLZM2",83, 0)
4154	.;
4155	"RTN","VAF HLZM2",84, 0)
4156	.;put seg ment into array
4157	"RTN","VAF HLZM2",85, 0)
4158	.S VAFIDX =VAFIDX+1
4159	"RTN","VAF HLZM2",86, 0)
4160	.S VAFY(V AFIDX)=$G( VAFY)
4161	"RTN","VAF HLZM2",87, 0)
4162	Q
4163	"RTN","VAF HLZMH")
4164	0^14^B3126 6014
4165	"RTN","VAF HLZMH",1,0 )
4166	VAFHLZMH ; BAY/JAT,PJ H,DJS - Cr eate HL7 M ilitary Hi story seg. (ZMH) ;2 Nov 2017 7:16pm
4167	"RTN","VAF HLZMH",2,0 )
4168	;;5.3;Reg istration; 190,314, 673,797,93 5;Aug 13 , 1993;Bui ld 53
4169	"RTN","VAF HLZMH",3,0 )
4170	;
4171	"RTN","VAF HLZMH",4,0 )
4172	; This ro utine crea tes HL7 VA -specific Military H istory ("Z MH") segme nts
4173	"RTN","VAF HLZMH",5,0 )
4174	Q
4175	"RTN","VAF HLZMH",6,0 )
4176	;
4177	"RTN","VAF HLZMH",7,0 )
4178	EN(DFN,VAF HMIEN,VAFS TR) ; RAI/ MDS Reserv ed entry p oint!!
4179	"RTN","VAF HLZMH",8,0 )
4180	; !!!!!!! !!! don't enter here !!!!!!!!! !!!!!!!!!! !!!!!!!!!! !!!!!
4181	"RTN","VAF HLZMH",9,0 )
4182	;DFN - Pa tient Inte rnal Entry Number
4183	"RTN","VAF HLZMH",10, 0)
4184	;VAFHMIEN - Patient Movement Internal E ntry Numbe r
4185	"RTN","VAF HLZMH",11, 0)
4186	;VAFSTR - Sequence numbers to be includ ed
4187	"RTN","VAF HLZMH",12, 0)
4188	;
4189	"RTN","VAF HLZMH",13, 0)
4190	N VAFHLRE C,VAFHA,VA FHSUB,VAFH ADD,VAFHLO C S VAFHSU B="" ;Init ialize var iables
4191	"RTN","VAF HLZMH",14, 0)
4192	S $P(VAFH LREC,HL("F S"))="ZMH" ;Set segm ent ID to ZMH
4193	"RTN","VAF HLZMH",15, 0)
4194	S $P(VAFH LREC,HL("F S"),2)=1 ; Set Set ID to 1
4195	"RTN","VAF HLZMH",16, 0)
4196	I VAFSTR[ ",4," D
4197	"RTN","VAF HLZMH",17, 0)
4198	.N EDATE, SDATE
4199	"RTN","VAF HLZMH",18, 0)
4200	.I '$D(^D PT(DFN,.32 16)) D
4201	"RTN","VAF HLZMH",19, 0)
4202	..S EDATE =$$HLDATE^ HLFNC($$GE T1^DIQ(2,D FN,".326", "I"))
4203	"RTN","VAF HLZMH",20, 0)
4204	..S SDATE =$$HLDATE^ HLFNC($$GE T1^DIQ(2,D FN,".327", "I"))
4205	"RTN","VAF HLZMH",21, 0)
4206	.E D MSD SD
4207	"RTN","VAF HLZMH",22, 0)
4208	.S $P(VAF HLREC,HL(" FS"),5)=ED ATE_$E(HL( "ECH"))_SD ATE
4209	"RTN","VAF HLZMH",23, 0)
4210	Q VAFHLRE C ;Quit an d return f ormatted s egment
4211	"RTN","VAF HLZMH",24, 0)
4212	;
4213	"RTN","VAF HLZMH",25, 0)
4214	MSDSD ;Ret urns last service se paration d ate from E SR sourced data
4215	"RTN","VAF HLZMH",26, 0)
4216	N DA,DONE ,EDATA
4217	"RTN","VAF HLZMH",27, 0)
4218	S EDATE=" ",SDATE="" ,DONE=0
4219	"RTN","VAF HLZMH",28, 0)
4220	F S EDAT E=$O(^DPT( DFN,.3216, "B",""),-1 ) Q:'EDATE D Q:DON E
4221	"RTN","VAF HLZMH",29, 0)
4222	.S DA=$O( ^DPT(DFN,. 3216,"B",E DATE,0)) Q :'DA
4223	"RTN","VAF HLZMH",30, 0)
4224	.S EDATA= $G(^DPT(DF N,.3216,DA ,0)) Q:EDA TA=""
4225	"RTN","VAF HLZMH",31, 0)
4226	.S DONE=1
4227	"RTN","VAF HLZMH",32, 0)
4228	;
4229	"RTN","VAF HLZMH",33, 0)
4230	Q:'DONE
4231	"RTN","VAF HLZMH",34, 0)
4232	S EDATE=$ $HLDATE^HL FNC(EDATE)
4233	"RTN","VAF HLZMH",35, 0)
4234	S SDATE=$ $HLDATE^HL FNC($P(EDA TA,U,2))
4235	"RTN","VAF HLZMH",36, 0)
4236	Q
4237	"RTN","VAF HLZMH",37, 0)
4238	;
4239	"RTN","VAF HLZMH",38, 0)
4240	ENTER(DFN, VAFARRAY,V AFTYPE,VAF STR,VAFHLS ,VAFHLC,VA FHLQ) ;
4241	"RTN","VAF HLZMH",39, 0)
4242	; DFN is the only r equired pa rameter. Defaults a re used if no
4243	"RTN","VAF HLZMH",40, 0)
4244	; values are passed for the o ther param eters.
4245	"RTN","VAF HLZMH",41, 0)
4246	; Output:
4247	"RTN","VAF HLZMH",42, 0)
4248	; VAFARRA Y = array name to ho ld the "ZM H" segment s.
4249	"RTN","VAF HLZMH",43, 0)
4250	; Defaul t is ^TMP( "VAFHLZMH" ,$J)
4251	"RTN","VAF HLZMH",44, 0)
4252	; Input:
4253	"RTN","VAF HLZMH",45, 0)
4254	; DFN = i nternal en try number (IEN) of Patient (# 2) file
4255	"RTN","VAF HLZMH",46, 0)
4256	; VAFTYPE = Militar y History type desir ed (separa ted by com mas) where
4257	"RTN","VAF HLZMH",47, 0)
4258	; 1=Last Service b ranch (SL)
4259	"RTN","VAF HLZMH",48, 0)
4260	; 2=Next to last S ervice bra nch (SNL)
4261	"RTN","VAF HLZMH",49, 0)
4262	; 3=Next to next t o last Ser vice branc h (SNNL)
4263	"RTN","VAF HLZMH",50, 0)
4264	; 4=Pris oner of Wa r Status i ndicated? (POW)
4265	"RTN","VAF HLZMH",51, 0)
4266	; 5=Comb at Service indicated ? (COMB)
4267	"RTN","VAF HLZMH",52, 0)
4268	; 6=Viet nam Servic e indicate d? (VIET)
4269	"RTN","VAF HLZMH",53, 0)
4270	; 7=Leba non Servic e indicate d? (LEBA)
4271	"RTN","VAF HLZMH",54, 0)
4272	; 8=Gren ada Servic e indicate d? (GREN)
4273	"RTN","VAF HLZMH",55, 0)
4274	; 9=Pana ma Service indicated ? (PANA)
4275	"RTN","VAF HLZMH",56, 0)
4276	; 10=Pers ian Gulf S ervice ind icated? (G ULF)
4277	"RTN","VAF HLZMH",57, 0)
4278	; 11=Soma lia Servic e indicate d? (SOMA)
4279	"RTN","VAF HLZMH",58, 0)
4280	; 12=Yugo slavia Ser vice indic ated? (YUG O)
4281	"RTN","VAF HLZMH",59, 0)
4282	; 13=Purp le Heart R eceipient? (PH)
4283	"RTN","VAF HLZMH",60, 0)
4284	; 14=Oper ation Endu ring/Iraqi Freedom ( OEIF)
4285	"RTN","VAF HLZMH",61, 0)
4286	; A range of numbers separated by colons can be se nt
4287	"RTN","VAF HLZMH",62, 0)
4288	; (e.g. 1:4, 8,10:12)
4289	"RTN","VAF HLZMH",63, 0)
4290	; Default is all(1,2 ,3...)
4291	"RTN","VAF HLZMH",64, 0)
4292	;
4293	"RTN","VAF HLZMH",65, 0)
4294	; OR
4295	"RTN","VAF HLZMH",66, 0)
4296	;
4297	"RTN","VAF HLZMH",67, 0)
4298	; If value '*' is pa ssed into the routin e then the default
4299	"RTN","VAF HLZMH",68, 0)
4300	; is to re turn all m ilitary hi story and all milita ry service
4301	"RTN","VAF HLZMH",69, 0)
4302	; episodes for the v et. Rather than usin g SL, SNL AND SNNL
4303	"RTN","VAF HLZMH",70, 0)
4304	; the ZMH type will be 'MSD'.
4305	"RTN","VAF HLZMH",71, 0)
4306	;
4307	"RTN","VAF HLZMH",72, 0)
4308	;
4309	"RTN","VAF HLZMH",73, 0)
4310	; VAFSTR = Fields ( sequence n umbers) de sired (sep arated by comma) whe re
4311	"RTN","VAF HLZMH",74, 0)
4312	; 3=qualif ier #1 (Se rvice bran ch if VAFT YPE is 1,2 or 3
4313	"RTN","VAF HLZMH",75, 0)
4314	; or Yes/No res ponse if V AFTYPE is 4 thru 13)
4315	"RTN","VAF HLZMH",76, 0)
4316	; qualif ier #2 (Se rvice numb er if VAFT YPE is 1,2 or 3
4317	"RTN","VAF HLZMH",77, 0)
4318	; or Location i f VAFTYPE is 4 or 5)
4319	"RTN","VAF HLZMH",78, 0)
4320	; or
4321	"RTN","VAF HLZMH",79, 0)
4322	; qualif ier #3 (Se rvice disc harge type if VAFTYP E is 1,2
4323	"RTN","VAF HLZMH",80, 0)
4324	; or 3)
4325	"RTN","VAF HLZMH",81, 0)
4326	; 4=From/T o Date ran ge for eac h VAFTYPE
4327	"RTN","VAF HLZMH",82, 0)
4328	; 5=Servic e Componen t
4329	"RTN","VAF HLZMH",83, 0)
4330	; Default is 3,4,5
4331	"RTN","VAF HLZMH",84, 0)
4332	; VAFHLS = HL7 fiel d separato r (1 chara cter)
4333	"RTN","VAF HLZMH",85, 0)
4334	; Default is ^ (carr ot)
4335	"RTN","VAF HLZMH",86, 0)
4336	; VAFHLC = HL7 enco ding chara cters (4 c haracters must be su pplied)
4337	"RTN","VAF HLZMH",87, 0)
4338	; Default is ~\|\& (t ilde bar b ackslash a mpersand)
4339	"RTN","VAF HLZMH",88, 0)
4340	; VAFHLQ = HL7 null designati on
4341	"RTN","VAF HLZMH",89, 0)
4342	; Default is "" (quo te quote)
4343	"RTN","VAF HLZMH",90, 0)
4344	;
4345	"RTN","VAF HLZMH",91, 0)
4346	; Check i nput and a pply defau lt values as needed
4347	"RTN","VAF HLZMH",92, 0)
4348	S VAFARRA Y=$G(VAFAR RAY) I VAF ARRAY="" S VAFARRAY= $NA(^TMP(" VAFHLZMH", $J))
4349	"RTN","VAF HLZMH",93, 0)
4350	K @VAFARR AY
4351	"RTN","VAF HLZMH",94, 0)
4352	S VAFTYPE =$G(VAFTYP E)
4353	"RTN","VAF HLZMH",95, 0)
4354	I VAFTYPE ="" S VAFT YPE="1,2,3 ,4,5,6,7,8 ,9,10,11,1 2,13,14"
4355	"RTN","VAF HLZMH",96, 0)
4356	S VAFSTR= $G(VAFSTR) I VAFSTR= "" S VAFST R="3,4,5"
4357	"RTN","VAF HLZMH",97, 0)
4358	S VAFHLS= $G(VAFHLS) I VAFHLS= "" S VAFHL S="^"
4359	"RTN","VAF HLZMH",98, 0)
4360	S:($L(VAF HLS)'=1) V AFHLS="^"
4361	"RTN","VAF HLZMH",99, 0)
4362	S VAFHLC= $G(VAFHLC) I VAFHLC= "" S VAFHL C="~\|\&"
4363	"RTN","VAF HLZMH",100 ,0)
4364	S:($L(VAF HLC)'=4) V AFHLC="~\|\ &"
4365	"RTN","VAF HLZMH",101 ,0)
4366	S:('$D(VA FHLQ)) VAF HLQ=$C(34, 34)
4367	"RTN","VAF HLZMH",102 ,0)
4368	I '$G(DFN ) D NOGO Q
4369	"RTN","VAF HLZMH",103 ,0)
4370	I '$D(^DP T(DFN,0)) D NOGO Q
4371	"RTN","VAF HLZMH",104 ,0)
4372	S VAFSTR= $TR(VAFSTR ,":",",")
4373	"RTN","VAF HLZMH",105 ,0)
4374	I VAFSTR' =3,VAFSTR' =4,VAFSTR' =5,VAFSTR' ="3,4",VAF STR'="3,5" ,VAFSTR'=" 4,5",VAFST R'="3,4,5" D NOGO Q
4375	"RTN","VAF HLZMH",106 ,0)
4376	S VAFSTR= ","_VAFSTR _","
4377	"RTN","VAF HLZMH",107 ,0)
4378	I VAFTYPE ="" S VAF TYPE=",4, 5,6,7,8,9, 10,11,12,1 3,14"
4379	"RTN","VAF HLZMH",108 ,0)
4380	E I '$$E DIT(VAFTYP E) D NOGO Q
4381	"RTN","VAF HLZMH",109 ,0)
4382	I VAFTYPE [":" D UNC RUNCH
4383	"RTN","VAF HLZMH",110 ,0)
4384	; it's a Go
4385	"RTN","VAF HLZMH",111 ,0)
4386	N VAFY,VA FX,VAFZ,VA FINDX,VAFT AG
4387	"RTN","VAF HLZMH",112 ,0)
4388	S VAFINDX =0
4389	"RTN","VAF HLZMH",113 ,0)
4390	; set all the Patie nt file no des that m ay be need ed
4391	"RTN","VAF HLZMH",114 ,0)
4392	N VAF32N, VAF321N,VA F322N,VAF5 2N,VAF53N, VAF3291N
4393	"RTN","VAF HLZMH",115 ,0)
4394	S VAF321N =$G(^DPT(D FN,.321)) ; used for Vietnam
4395	"RTN","VAF HLZMH",116 ,0)
4396	S VAF322N =$G(^DPT(D FN,.322)) ; used for minor ski rmishes
4397	"RTN","VAF HLZMH",117 ,0)
4398	S VAF52N= $G(^DPT(DF N,.52)) ; used for P OW and Com bat
4399	"RTN","VAF HLZMH",118 ,0)
4400	S VAF53N= $G(^DPT(DF N,.53)) ;u sed for Pu rple Heart
4401	"RTN","VAF HLZMH",119 ,0)
4402	I '$D(^DP T(DFN,.321 6)) D
4403	"RTN","VAF HLZMH",120 ,0)
4404	.S VAF32N =$G(^DPT(D FN,.32)) ; used for Service br anches
4405	"RTN","VAF HLZMH",121 ,0)
4406	.S VAF329 1N=$G(^DPT (DFN,.3291 )) ;used f or service component
4407	"RTN","VAF HLZMH",122 ,0)
4408	I $D(^DPT (DFN,.3216 )),VAFTYPE '["*" D MS DS
4409	"RTN","VAF HLZMH",123 ,0)
4410	;used for Operation Enduring/ Iraqi Free dom
4411	"RTN","VAF HLZMH",124 ,0)
4412	N VAFOPS, VAFREC,VAF SUB
4413	"RTN","VAF HLZMH",125 ,0)
4414	S (VAFREC ,VAFSUB)=0
4415	"RTN","VAF HLZMH",126 ,0)
4416	;set oper ations int o local ar ray since there may be mult OE IF episode s
4417	"RTN","VAF HLZMH",127 ,0)
4418	F S VAFR EC=$O(^DPT (DFN,.3215 ,VAFREC)) Q:'$G(VAFR EC) D
4419	"RTN","VAF HLZMH",128 ,0)
4420	. S VAFSU B=VAFSUB+1
4421	"RTN","VAF HLZMH",129 ,0)
4422	. S VAFOP S(VAFSUB)= $G(^DPT(DF N,.3215,VA FREC,0))
4423	"RTN","VAF HLZMH",130 ,0)
4424	;
4425	"RTN","VAF HLZMH",131 ,0)
4426	D ENTER^V AFHLZM1
4427	"RTN","VAF HLZMH",132 ,0)
4428	;
4429	"RTN","VAF HLZMH",133 ,0)
4430	Q
4431	"RTN","VAF HLZMH",134 ,0)
4432	;
4433	"RTN","VAF HLZMH",135 ,0)
4434	MSDS ;Retu rns latest service e pisodes fr om ESR sou rced data
4435	"RTN","VAF HLZMH",136 ,0)
4436	;
4437	"RTN","VAF HLZMH",137 ,0)
4438	;* the number of episodes i s unlimite d **
4439	"RTN","VAF HLZMH",138 ,0)
4440	;
4441	"RTN","VAF HLZMH",139 ,0)
4442	N BRANCH, COUNT,COMP ,DA,DONE,D TYP,EDATA, EDATE,SDAT E,SERVNO,S UB
4443	"RTN","VAF HLZMH",140 ,0)
4444	S COUNT=0 ,EDATE="", VAF32N="", VAF3291N=" "
4445	"RTN","VAF HLZMH",141 ,0)
4446	;Scan bac k for thre e most rec ent servic e episodes
4447	"RTN","VAF HLZMH",142 ,0)
4448	F S EDAT E=$O(^DPT( DFN,.3216, "B",EDATE) ,-1) Q:'ED ATE D Q: COUNT'<3
4449	"RTN","VAF HLZMH",143 ,0)
4450	.S DA=$O( ^DPT(DFN,. 3216,"B",E DATE,0)) Q :'DA
4451	"RTN","VAF HLZMH",144 ,0)
4452	.S EDATA= $G(^DPT(DF N,.3216,DA ,0)) Q:EDA TA=""
4453	"RTN","VAF HLZMH",145 ,0)
4454	.;DJS, sk ip an MSE that has a Future Di scharge Da te; DG5.3 935
4455	"RTN","VAF HLZMH",146 ,0)
4456	.Q:$P(EDA TA,U,8)'=" "
4457	"RTN","VAF HLZMH",147 ,0)
4458	.S COUNT= COUNT+1,SD ATE=$P(EDA TA,U,2)
4459	"RTN","VAF HLZMH",148 ,0)
4460	.S BRANCH =$P(EDATA, U,3),COMP= $P(EDATA,U ,4)
4461	"RTN","VAF HLZMH",149 ,0)
4462	.S SERVNO =$P(EDATA, U,5),DTYP= $P(EDATA,U ,6)
4463	"RTN","VAF HLZMH",150 ,0)
4464	.;SL = 4, SNL = 9 o r SNNL = 1 4
4465	"RTN","VAF HLZMH",151 ,0)
4466	.S SUB=(C OUNT*5)-1
4467	"RTN","VAF HLZMH",152 ,0)
4468	.S $P(VAF 32N,U,SUB) =DTYP
4469	"RTN","VAF HLZMH",153 ,0)
4470	.S $P(VAF 32N,U,SUB+ 1)=BRANCH
4471	"RTN","VAF HLZMH",154 ,0)
4472	.S $P(VAF 32N,U,SUB+ 2)=EDATE
4473	"RTN","VAF HLZMH",155 ,0)
4474	.S $P(VAF 32N,U,SUB+ 3)=SDATE
4475	"RTN","VAF HLZMH",156 ,0)
4476	.S $P(VAF 32N,U,SUB+ 4)=SERVNO
4477	"RTN","VAF HLZMH",157 ,0)
4478	.S $P(VAF 3291N,U,CO UNT)=COMP
4479	"RTN","VAF HLZMH",158 ,0)
4480	Q
4481	"RTN","VAF HLZMH",159 ,0)
4482	;
4483	"RTN","VAF HLZMH",160 ,0)
4484	EDIT(X) ; function validates VAFTYP (re turns 1 if valid)
4485	"RTN","VAF HLZMH",161 ,0)
4486	N P,Q,R,C NT,Z,Z1,Z2 ,ERR S ERR =0
4487	"RTN","VAF HLZMH",162 ,0)
4488	S X=$G(X)
4489	"RTN","VAF HLZMH",163 ,0)
4490	I X>0,X<1 5,X?.N Q 1 ; only 1 number and between 1 -14
4491	"RTN","VAF HLZMH",164 ,0)
4492	I X'[":", X'["," Q 0 ; comma n ot used as separator
4493	"RTN","VAF HLZMH",165 ,0)
4494	I X'?.NP Q 0 ; cont ains lette rs or cont rol charac ters
4495	"RTN","VAF HLZMH",166 ,0)
4496	; contain s punctuat ion other than comma /colon
4497	"RTN","VAF HLZMH",167 ,0)
4498	S P="!#$% &'()*+-./; <=>?@[\]^_ `{\|]~"
4499	"RTN","VAF HLZMH",168 ,0)
4500	F CNT=1:1 S Z=$E(X, CNT) Q:Z=" " I P[Z S ERR=1 Q
4501	"RTN","VAF HLZMH",169 ,0)
4502	I ERR=1 Q 0
4503	"RTN","VAF HLZMH",170 ,0)
4504	S Q="",R= """"
4505	"RTN","VAF HLZMH",171 ,0)
4506	I Q[X!R[X Q 0
4507	"RTN","VAF HLZMH",172 ,0)
4508	; checks that numbe rs are >0< 15
4509	"RTN","VAF HLZMH",173 ,0)
4510	F CNT=1:1 S Z=$P(X, ",",CNT) Q :Z="" D
4511	"RTN","VAF HLZMH",174 ,0)
4512	.I Z'[":" ,Z>0,Z<15 Q
4513	"RTN","VAF HLZMH",175 ,0)
4514	.S Z1=$P( Z,":",1),Z 2=$P(Z,":" ,2)
4515	"RTN","VAF HLZMH",176 ,0)
4516	.I Z1>0,Z 1<15,Z2>0, Z2<15 Q
4517	"RTN","VAF HLZMH",177 ,0)
4518	.S ERR=1
4519	"RTN","VAF HLZMH",178 ,0)
4520	I ERR=1 Q 0
4521	"RTN","VAF HLZMH",179 ,0)
4522	Q 1
4523	"RTN","VAF HLZMH",180 ,0)
4524	;
4525	"RTN","VAF HLZMH",181 ,0)
4526	UNCRUNCH ; reformat VAFTYPE by translati ng any ran ge of numb ers,
4527	"RTN","VAF HLZMH",182 ,0)
4528	; for exa mple repla ce "1:3,6, 9:11" by " 1,2,3,6,9, 10,11,"
4529	"RTN","VAF HLZMH",183 ,0)
4530	N X,Y,Z,A ,B S Y=""
4531	"RTN","VAF HLZMH",184 ,0)
4532	F X=1:1 S Z=$P(VAFT YPE,",",X) Q:Z="" D
4533	"RTN","VAF HLZMH",185 ,0)
4534	.I Z'[":" S Y=Y_Z_" ," Q
4535	"RTN","VAF HLZMH",186 ,0)
4536	.S A=$P(Z ,":",1),B= $P(Z,":",2 )
4537	"RTN","VAF HLZMH",187 ,0)
4538	.S Y=Y_A_ ","
4539	"RTN","VAF HLZMH",188 ,0)
4540	.F S A=A +1 Q:A>B S Y=Y_A_", "
4541	"RTN","VAF HLZMH",189 ,0)
4542	S VAFTYPE =Y
4543	"RTN","VAF HLZMH",190 ,0)
4544	Q
4545	"RTN","VAF HLZMH",191 ,0)
4546	NOGO ;
4547	"RTN","VAF HLZMH",192 ,0)
4548	S @VAFARR AY@(1,0)=" ZMH"_VAFHL S_1
4549	"RTN","VAF HLZMH",193 ,0)
4550	Q
4551	"UP",2,2.3 216,-1)
4552	2^.3216
4553	"UP",2,2.3 216,0)
4554	2.3216
4555	"VER")
4556	8.0^22.2
4557	"^DD",2,2. 3216,.08,0 )
4558	FUTURE DIS CHARGE DAT E^DX^^0;8^ S %DT="EX" D ^%DT S X=Y K:Y<1 X
4559	"^DD",2,2. 3216,.08,3 )
4560	Enter the date that an active duty servi ce member is expecte d to be di scharged.
4561	"^DD",2,2. 3216,.08,2 1,0)
4562	^^3^3^3171 013^
4563	"^DD",2,2. 3216,.08,2 1,1,0)
4564	The Future Discharge Date (FDD ) is the d ate that a n active d uty servic e
4565	"^DD",2,2. 3216,.08,2 1,2,0)
4566	member is expected t o be disch arged. Thi s date is controlled in VistA by
4567	"^DD",2,2. 3216,.08,2 1,3,0)
4568	the Enroll ment Servi ce (ES) an d cannot b e edited w ithin Vist A.
4569	"^DD",2,2. 3216,.08," DT")
4570	3171020
4571	"^DD",25.1 1,25.11,0)
4572	FIELD^NL^. 05^5
4573	"^DD",25.1 1,25.11,0, "DDA")
4574	N
4575	"^DD",25.1 1,25.11,0, "DT")
4576	3170817
4577	"^DD",25.1 1,25.11,0, "IX","C",2 5.11,.02)
4578
4579	"^DD",25.1 1,25.11,0, "NM","HEAL TH BENEFIT PLAN")
4580
4581	"^DD",25.1 1,25.11,0, "PT",2.251 1,.01)
4582
4583	"^DD",25.1 1,25.11,0, "PT",2.251 2,1)
4584
4585	"^DD",25.1 1,25.11,0, "VRPK")
4586	DG
4587	"^DD",25.1 1,25.11,.0 1,0)
4588	NAME ^RF^^ 0;1^K:$L(X )>200!($L( X)<3)!'(X' ?1P.E) X
4589	"^DD",25.1 1,25.11,.0 1,1,0)
4590	^.1^^0
4591	"^DD",25.1 1,25.11,.0 1,3)
4592	Answer mus t be 3-200 character s in lengt h.
4593	"^DD",25.1 1,25.11,.0 1,21,0)
4594	^.001^1^1^ 3130306^^^ ^
4595	"^DD",25.1 1,25.11,.0 1,21,1,0)
4596	This field contains the Health Benefit P lan name.
4597	"^DD",25.1 1,25.11,.0 1,"DT")
4598	3130326
4599	"^DD",25.1 1,25.11,.0 2,0)
4600	PLAN CODE^ RNJ3,0^^0; 2^K:+X'=X! (X>999)!(X <100)!(X?. E1"."1N.N) X
4601	"^DD",25.1 1,25.11,.0 2,1,0)
4602	^.1
4603	"^DD",25.1 1,25.11,.0 2,1,1,0)
4604	25.11^C
4605	"^DD",25.1 1,25.11,.0 2,1,1,1)
4606	S ^DGHBP(2 5.11,"C",$ E(X,1,30), DA)=""
4607	"^DD",25.1 1,25.11,.0 2,1,1,2)
4608	K ^DGHBP(2 5.11,"C",$ E(X,1,30), DA)
4609	"^DD",25.1 1,25.11,.0 2,1,1,"%D" ,0)
4610	^^2^2^3130 307^
4611	"^DD",25.1 1,25.11,.0 2,1,1,"%D" ,1,0)
4612	This will contain th e cross-re ference pl an code to its corre sponding
4613	"^DD",25.1 1,25.11,.0 2,1,1,"%D" ,2,0)
4614	Health Ben efit Plan.
4615	"^DD",25.1 1,25.11,.0 2,1,1,"DT" )
4616	3130307
4617	"^DD",25.1 1,25.11,.0 2,3)
4618	Type a num ber betwee n 100 and 999, 0 dec imal digit s.
4619	"^DD",25.1 1,25.11,.0 2,21,0)
4620	^.001^1^1^ 3130307^^
4621	"^DD",25.1 1,25.11,.0 2,21,1,0)
4622	This field contains the Plan C ode associ ated with the Health Benefit P lan.
4623	"^DD",25.1 1,25.11,.0 2,"DT")
4624	3130307
4625	"^DD",25.1 1,25.11,.0 3,0)
4626	SHORT DESC RIPTION^25 .13^^1;0
4627	"^DD",25.1 1,25.11,.0 3,21,0)
4628	^^2^2^3130 307^
4629	"^DD",25.1 1,25.11,.0 3,21,1,0)
4630	This field contains the short descriptio n associat ed with th e Health
4631	"^DD",25.1 1,25.11,.0 3,21,2,0)
4632	Benefit Pl an.
4633	"^DD",25.1 1,25.11,.0 4,0)
4634	LONG DESCR IPTION^25. 14^^2;0
4635	"^DD",25.1 1,25.11,.0 4,21,0)
4636	^^2^2^3130 307^
4637	"^DD",25.1 1,25.11,.0 4,21,1,0)
4638	This field contains the detail ed long de scription associated with the
4639	"^DD",25.1 1,25.11,.0 4,21,2,0)
4640	Health Ben efit Plan.
4641	"^DD",25.1 1,25.11,.0 5,0)
4642	COVERAGE C ODE^F^^0;3 ^K:$L(X)>3 0!($L(X)<1 ) X
4643	"^DD",25.1 1,25.11,.0 5,3)
4644	Answer mus t be 1-30 characters in length .
4645	"^DD",25.1 1,25.11,.0 5,21,0)
4646	^^1^1^3170 117^
4647	"^DD",25.1 1,25.11,.0 5,21,1,0)
4648	This field contains the Covera ge Code as sociated w ith the He alth Benef it Plan.
4649	"^DD",25.1 1,25.11,.0 5,"DT")
4650	3170117
4651	"^DD",25.1 1,25.13,0)
4652	SHORT DESC RIPTION SU B-FIELD^^. 01^1
4653	"^DD",25.1 1,25.13,0, "DT")
4654	3130307
4655	"^DD",25.1 1,25.13,0, "NM","SHOR T DESCRIPT ION")
4656
4657	"^DD",25.1 1,25.13,0, "UP")
4658	25.11
4659	"^DD",25.1 1,25.13,.0 1,0)
4660	SHORT DESC RIPTION^Wx ^^0;1^Q
4661	"^DD",25.1 1,25.13,.0 1,3)
4662	Enter the short desc ription fo r the Heal th Benefit Plan.
4663	"^DD",25.1 1,25.13,.0 1,21,0)
4664	^.001^2^2^ 3130307^^
4665	"^DD",25.1 1,25.13,.0 1,21,1,0)
4666	This field contains the short descriptio n associat ed with th e Health
4667	"^DD",25.1 1,25.13,.0 1,21,2,0)
4668	Benefit Pl an.
4669	"^DD",25.1 1,25.13,.0 1,"DT")
4670	3130307
4671	"^DD",25.1 1,25.14,0)
4672	LONG DESCR IPTION SUB -FIELD^^.0 1^1
4673	"^DD",25.1 1,25.14,0, "DT")
4674	3130307
4675	"^DD",25.1 1,25.14,0, "NM","LONG DESCRIPTI ON")
4676
4677	"^DD",25.1 1,25.14,0, "UP")
4678	25.11
4679	"^DD",25.1 1,25.14,.0 1,0)
4680	LONG DESCR IPTION^Wx^ ^0;1^Q
4681	"^DD",25.1 1,25.14,.0 1,3)
4682	Enter the detailed d escription for the H ealth Bene fit Plan.
4683	"^DD",25.1 1,25.14,.0 1,21,0)
4684	^.001^2^2^ 3130307^^
4685	"^DD",25.1 1,25.14,.0 1,21,1,0)
4686	This field contains the detail ed long de scription associated with the
4687	"^DD",25.1 1,25.14,.0 1,21,2,0)
4688	Health Ben efit Plan.
4689	"^DD",25.1 1,25.14,.0 1,"DT")
4690	3130307
4691	"^DIC",25. 11,25.11,0 )
4692	HEALTH BEN EFIT PLAN^ 25.11
4693	"^DIC",25. 11,25.11,0 ,"GL")
4694	^DGHBP(25. 11,
4695	"^DIC",25. 11,25.11," %",0)
4696	^1.005^^0
4697	"^DIC",25. 11,25.11," %D",0)
4698	^1.001^2^2 ^3150209^^ ^^
4699	"^DIC",25. 11,25.11," %D",1,0)
4700	This file contains t he Health Benefit Pl an names a nd their s hort and l ong
4701	"^DIC",25. 11,25.11," %D",2,0)
4702	descriptio ns.
4703	"^DIC",25. 11,"B","HE ALTH BENEF IT PLAN",2 5.11)
4704
4705	INSTALL NAME
4706	IVM2.016 7
4707	"BLD",1021 2,0)
4708	IVM2.016 7^INCOME V ERIFICATIO N MATCH^0^ 3171106^y
4709	"BLD",1021 2,1,0)
4710	^^2^2^3171 031^^
4711	"BLD",1021 2,1,1,0)
4712	ENROLLMENT SYSTEM CO MMUNITY CA RE (ESCC) HOME PHONE AND FUTUR E DISCHARG E
4713	"BLD",1021 2,1,2,0)
4714	DATE UPDAT ES
4715	"BLD",1021 2,4,0)
4716	^9.64PA^^
4717	"BLD",1021 2,6)
4718	1^
4719	"BLD",1021 2,6.3)
4720	39
4721	"BLD",1021 2,"ABPKG")
4722	n
4723	"BLD",1021 2,"KRN",0)
4724	^9.67PA^77 9.2^20
4725	"BLD",1021 2,"KRN",.4 ,0)
4726	.4
4727	"BLD",1021 2,"KRN",.4 01,0)
4728	.401
4729	"BLD",1021 2,"KRN",.4 02,0)
4730	.402
4731	"BLD",1021 2,"KRN",.4 03,0)
4732	.403
4733	"BLD",1021 2,"KRN",.5 ,0)
4734	.5
4735	"BLD",1021 2,"KRN",.8 4,0)
4736	.84
4737	"BLD",1021 2,"KRN",3. 6,0)
4738	3.6
4739	"BLD",1021 2,"KRN",3. 8,0)
4740	3.8
4741	"BLD",1021 2,"KRN",9. 2,0)
4742	9.2
4743	"BLD",1021 2,"KRN",9. 8,0)
4744	9.8
4745	"BLD",1021 2,"KRN",9. 8,"NM",0)
4746	^9.68A^5^4
4747	"BLD",1021 2,"KRN",9. 8,"NM",2,0 )
4748	IVMPREC6^^ 0^B1551613 80
4749	"BLD",1021 2,"KRN",9. 8,"NM",3,0 )
4750	IVMPREC8^^ 0^B2429381 45
4751	"BLD",1021 2,"KRN",9. 8,"NM",4,0 )
4752	IVMPREC9^^ 0^B7540469 5
4753	"BLD",1021 2,"KRN",9. 8,"NM",5,0 )
4754	IVMPTRN8^^ 0^B8657127 1
4755	"BLD",1021 2,"KRN",9. 8,"NM","B" ,"IVMPREC6 ",2)
4756
4757	"BLD",1021 2,"KRN",9. 8,"NM","B" ,"IVMPREC8 ",3)
4758
4759	"BLD",1021 2,"KRN",9. 8,"NM","B" ,"IVMPREC9 ",4)
4760
4761	"BLD",1021 2,"KRN",9. 8,"NM","B" ,"IVMPTRN8 ",5)
4762
4763	"BLD",1021 2,"KRN",19 ,0)
4764	19
4765	"BLD",1021 2,"KRN",19 .1,0)
4766	19.1
4767	"BLD",1021 2,"KRN",10 1,0)
4768	101
4769	"BLD",1021 2,"KRN",40 9.61,0)
4770	409.61
4771	"BLD",1021 2,"KRN",77 1,0)
4772	771
4773	"BLD",1021 2,"KRN",77 9.2,0)
4774	779.2
4775	"BLD",1021 2,"KRN",87 0,0)
4776	870
4777	"BLD",1021 2,"KRN",89 89.51,0)
4778	8989.51
4779	"BLD",1021 2,"KRN",89 89.52,0)
4780	8989.52
4781	"BLD",1021 2,"KRN",89 94,0)
4782	8994
4783	"BLD",1021 2,"KRN","B ",.4,.4)
4784
4785	"BLD",1021 2,"KRN","B ",.401,.40 1)
4786
4787	"BLD",1021 2,"KRN","B ",.402,.40 2)
4788
4789	"BLD",1021 2,"KRN","B ",.403,.40 3)
4790
4791	"BLD",1021 2,"KRN","B ",.5,.5)
4792
4793	"BLD",1021 2,"KRN","B ",.84,.84)
4794
4795	"BLD",1021 2,"KRN","B ",3.6,3.6)
4796
4797	"BLD",1021 2,"KRN","B ",3.8,3.8)
4798
4799	"BLD",1021 2,"KRN","B ",9.2,9.2)
4800
4801	"BLD",1021 2,"KRN","B ",9.8,9.8)
4802
4803	"BLD",1021 2,"KRN","B ",19,19)
4804
4805	"BLD",1021 2,"KRN","B ",19.1,19. 1)
4806
4807	"BLD",1021 2,"KRN","B ",101,101)
4808
4809	"BLD",1021 2,"KRN","B ",409.61,4 09.61)
4810
4811	"BLD",1021 2,"KRN","B ",771,771)
4812
4813	"BLD",1021 2,"KRN","B ",779.2,77 9.2)
4814
4815	"BLD",1021 2,"KRN","B ",870,870)
4816
4817	"BLD",1021 2,"KRN","B ",8989.51, 8989.51)
4818
4819	"BLD",1021 2,"KRN","B ",8989.52, 8989.52)
4820
4821	"BLD",1021 2,"KRN","B ",8994,899 4)
4822
4823	"BLD",1021 2,"QDEF")
4824	^^^^NO^^^^ NO^^YES
4825	"BLD",1021 2,"QUES",0 )
4826	^9.62^^
4827	"BLD",1021 2,"REQB",0 )
4828	^9.611^3^3
4829	"BLD",1021 2,"REQB",1 ,0)
4830	IVM2.015 9^1
4831	"BLD",1021 2,"REQB",2 ,0)
4832	IVM2.016 5^1
4833	"BLD",1021 2,"REQB",3 ,0)
4834	IVM2.016 8^1
4835	"BLD",1021 2,"REQB"," B","IVM2. 0159",1)
4836
4837	"BLD",1021 2,"REQB"," B","IVM2. 0165",2)
4838
4839	"BLD",1021 2,"REQB"," B","IVM2. 0168",3)
4840
4841	"MBREQ")
4842	0
4843	"PKG",120, -1)
4844	1^1
4845	"PKG",120, 0)
4846	INCOME VER IFICATION MATCH^IVM^ IVM Softwa re for int erface wit h the IVM Center
4847	"PKG",120, 20,0)
4848	^9.402P^^
4849	"PKG",120, 22,0)
4850	^9.49I^1^1
4851	"PKG",120, 22,1,0)
4852	2.0^294102 1^2960823
4853	"PKG",120, 22,1,"PAH" ,1,0)
4854	167^317110 6^101100
4855	"PKG",120, 22,1,"PAH" ,1,1,0)
4856	^^2^2^3171 106
4857	"PKG",120, 22,1,"PAH" ,1,1,1,0)
4858	ENROLLMENT SYSTEM CO MMUNITY CA RE (ESCC) HOME PHONE AND FUTUR E DISCHARG E
4859	"PKG",120, 22,1,"PAH" ,1,1,2,0)
4860	DATE UPDAT ES
4861	"QUES","XP F1",0)
4862	Y
4863	"QUES","XP F1","??")
4864	^D REP^XPD H
4865	"QUES","XP F1","A")
4866	Shall I wr ite over y our \|FLAG\| File
4867	"QUES","XP F1","B")
4868	YES
4869	"QUES","XP F1","M")
4870	D XPF1^XPD IQ
4871	"QUES","XP F2",0)
4872	Y
4873	"QUES","XP F2","??")
4874	^D DTA^XPD H
4875	"QUES","XP F2","A")
4876	Want my da ta \|FLAG\| yours
4877	"QUES","XP F2","B")
4878	YES
4879	"QUES","XP F2","M")
4880	D XPF2^XPD IQ
4881	"QUES","XP I1",0)
4882	YO
4883	"QUES","XP I1","??")
4884	^D INHIBIT ^XPDH
4885	"QUES","XP I1","A")
4886	Want KIDS to INHIBIT LOGONs du ring the i nstall
4887	"QUES","XP I1","B")
4888	NO
4889	"QUES","XP I1","M")
4890	D XPI1^XPD IQ
4891	"QUES","XP M1",0)
4892	PO^VA(200, :EM
4893	"QUES","XP M1","??")
4894	^D MG^XPDH
4895	"QUES","XP M1","A")
4896	Enter the Coordinato r for Mail Group '\|F LAG\|'
4897	"QUES","XP M1","B")
4898
4899	"QUES","XP M1","M")
4900	D XPM1^XPD IQ
4901	"QUES","XP O1",0)
4902	Y
4903	"QUES","XP O1","??")
4904	^D MENU^XP DH
4905	"QUES","XP O1","A")
4906	Want KIDS to Rebuild Menu Tree s Upon Com pletion of Install
4907	"QUES","XP O1","B")
4908	NO
4909	"QUES","XP O1","M")
4910	D XPO1^XPD IQ
4911	"QUES","XP Z1",0)
4912	Y
4913	"QUES","XP Z1","??")
4914	^D OPT^XPD H
4915	"QUES","XP Z1","A")
4916	Want to DI SABLE Sche duled Opti ons, Menu Options, a nd Protoco ls
4917	"QUES","XP Z1","B")
4918	YES
4919	"QUES","XP Z1","M")
4920	D XPZ1^XPD IQ
4921	"QUES","XP Z2",0)
4922	Y
4923	"QUES","XP Z2","??")
4924	^D RTN^XPD H
4925	"QUES","XP Z2","A")
4926	Want to MO VE routine s to other CPUs
4927	"QUES","XP Z2","B")
4928	NO
4929	"QUES","XP Z2","M")
4930	D XPZ2^XPD IQ
4931	"RTN")
4932	4
4933	"RTN","IVM PREC6")
4934	0^2^B15516 1380
4935	"RTN","IVM PREC6",1,0 )
4936	IVMPREC6 ; ALB/KCL,BR M,CKN,TDM, PWC,LBD,KU M - PROCES S INCOMING (Z05 EVEN T TYPE) HL 7 MESSAGES ;09-05-20 17 8:06AM
4937	"RTN","IVM PREC6",2,0 )
4938	;;2.0;INC OME VERIFI CATION MAT CH;*3,4,1 2,17,34,58 ,79,102,11 5,140,144, 121,151,15 2,165,167 *;21-OCT-9 4;Build 39
4939	"RTN","IVM PREC6",3,0 )
4940	;Per VA D irective 6 402, this routine sh ould not b e modified .
4941	"RTN","IVM PREC6",4,0 )
4942	;
4943	"RTN","IVM PREC6",5,0 )
4944	; This ro utine will process b atch ORU d emographic (event ty pe Z05) HL 7
4945	"RTN","IVM PREC6",6,0 )
4946	; message s received from the IVM center . Format of HL7 bat ch message :
4947	"RTN","IVM PREC6",7,0 )
4948	;
4949	"RTN","IVM PREC6",8,0 )
4950	; B HS
4951	"RTN","IVM PREC6",9,0 )
4952	; { MSH
4953	"RTN","IVM PREC6",10, 0)
4954	; PID
4955	"RTN","IVM PREC6",11, 0)
4956	; ZPD
4957	"RTN","IVM PREC6",12, 0)
4958	; ZTA
4959	"RTN","IVM PREC6",13, 0)
4960	; ZGD
4961	"RTN","IVM PREC6",14, 0)
4962	; ZCT (1 epi sode requi red, multi ple possib le)
4963	"RTN","IVM PREC6",15, 0)
4964	; ZEM (Veter an)
4965	"RTN","IVM PREC6",16, 0)
4966	; ZEM (Spous e - Option al)
4967	"RTN","IVM PREC6",17, 0)
4968	; RF1 (optio nal, multi ple possib le)
4969	"RTN","IVM PREC6",18, 0)
4970	; }
4971	"RTN","IVM PREC6",19, 0)
4972	; B TS
4973	"RTN","IVM PREC6",20, 0)
4974	;
4975	"RTN","IVM PREC6",21, 0)
4976	;
4977	"RTN","IVM PREC6",22, 0)
4978	EN ; - ent ry point t o process HL7 patien t demograp hic messag e
4979	"RTN","IVM PREC6",23, 0)
4980	;
4981	"RTN","IVM PREC6",24, 0)
4982	N DGENUPL D,VAFCA08, DGRUGA08,C OMP,DODSEG ,GUARSEG
4983	"RTN","IVM PREC6",25, 0)
4984	;N MULTDO NE,XREP
4985	"RTN","IVM PREC6",26, 0)
4986	N XIVMA,I VMALADT,MU LTIDONE
4987	"RTN","IVM PREC6",27, 0)
4988	;
4989	"RTN","IVM PREC6",28, 0)
4990	; Setup a rray to ho ld all the Allowed A ddress Typ es
4991	"RTN","IVM PREC6",29, 0)
4992	;F XIVMA= "N","P","V AB1","VAB2 ","VAB3"," VAB4" S IV MALADT(XIV MA)=""
4993	"RTN","IVM PREC6",30, 0)
4994	F XIVMA=" P","VAB1", "VAB2","VA B3","VAB4" S IVMALAD T(XIVMA)=" "
4995	"RTN","IVM PREC6",31, 0)
4996	; Define the Confid ential Add ress Categ ories
4997	"RTN","IVM PREC6",32, 0)
4998	;S IVMALA DT("VACAE" )="CA^1" ; ELIG IBILITY/EN ROLLMENT
4999	"RTN","IVM PREC6",33, 0)
5000	;S IVMALA DT("VACAA" )="CA^2" ; APPO INTMENT/SC HEDULING
5001	"RTN","IVM PREC6",34, 0)
5002	;S IVMALA DT("VACAC" )="CA^3" ; COPA YMENTS/VET ERAN BILLI NG
5003	"RTN","IVM PREC6",35, 0)
5004	;S IVMALA DT("VACAM" )="CA^4" ; MEDI CAL RECORD S
5005	"RTN","IVM PREC6",36, 0)
5006	;S IVMALA DT("VACAO" )="CA^5" ; ALL OTHERS
5007	"RTN","IVM PREC6",37, 0)
5008	; prevent a return Z07 when u ploading a Z05 (Pati ent file t riggers)
5009	"RTN","IVM PREC6",38, 0)
5010	S DGENUPL D="ENROLLM ENT/ELIGIB ILITY UPLO AD IN PROG RESS"
5011	"RTN","IVM PREC6",39, 0)
5012	;
5013	"RTN","IVM PREC6",40, 0)
5014	; prevent MPI A08 m essage whe n uploadin g Z05 (Pat ient file triggers)
5015	"RTN","IVM PREC6",41, 0)
5016	S VAFCA08 =1 ;MPI/C IRN A08 su ppression flag
5017	"RTN","IVM PREC6",42, 0)
5018	;
5019	"RTN","IVM PREC6",43, 0)
5020	S IVMFLG= 0,IVMADFLG =0
5021	"RTN","IVM PREC6",44, 0)
5022	; - get i ncoming HL 7 message from HL7 T ransmissio n (#772) f ile
5023	"RTN","IVM PREC6",45, 0)
5024	F IVMDA=0 :0 S IVMDA =$O(^TMP($ J,IVMRTN,I VMDA)) Q:' IVMDA S I VMSEG=$G(^ (IVMDA,0)) I $E(IVMS EG,1,3)="M SH" D
5025	"RTN","IVM PREC6",46, 0)
5026	.K HLERR, ZEMADRUP
5027	"RTN","IVM PREC6",47, 0)
5028	.S IVMTST PT="" ;Initiali ze Temp Ad dr County
5029	"RTN","IVM PREC6",48, 0)
5030	.;
5031	"RTN","IVM PREC6",49, 0)
5032	.; - mess age contro l id from MSH segmen t
5033	"RTN","IVM PREC6",50, 0)
5034	.S MSGID= $P(IVMSEG, HLFS,10),H LMID=MSGID
5035	"RTN","IVM PREC6",51, 0)
5036	.;
5037	"RTN","IVM PREC6",52, 0)
5038	.; - perf orm demogr aphics mes sage consi stency che ck
5039	"RTN","IVM PREC6",53, 0)
5040	.D EN^IVM PRECA Q:$D (HLERR)
5041	"RTN","IVM PREC6",54, 0)
5042	.;
5043	"RTN","IVM PREC6",55, 0)
5044	.;Set arr ay of Emai l, Cell, P ager field s
5045	"RTN","IVM PREC6",56, 0)
5046	.D EPCFLD S(.EPCFARY ,.EPCDEL)
5047	"RTN","IVM PREC6",57, 0)
5048	.D AUPBLD (.AUPFARY, .UPDAUPG)
5049	"RTN","IVM PREC6",58, 0)
5050	.; - get next msg s egment
5051	"RTN","IVM PREC6",59, 0)
5052	.D NEXT I $E(IVMSEG ,1,3)'="PI D" D Q
5053	"RTN","IVM PREC6",60, 0)
5054	..S HLERR ="Missing PID segmen t" D ACK^I VMPREC
5055	"RTN","IVM PREC6",61, 0)
5056	.;
5057	"RTN","IVM PREC6",62, 0)
5058	.F I=1:1 D NEXT Q:$ E(IVMSEG,1 ,4)="ZPD^" ;Go thro ugh all PI D
5059	"RTN","IVM PREC6",63, 0)
5060	.; - pati ent IEN (D FN) from P ID segment
5061	"RTN","IVM PREC6",64, 0)
5062	.;Use IVM PID array created in IVMPRECA while perf orming con sistency
5063	"RTN","IVM PREC6",65, 0)
5064	.;to proc ess PID se gment
5065	"RTN","IVM PREC6",66, 0)
5066	.;
5067	"RTN","IVM PREC6",67, 0)
5068	.;I '$G(I VMDFN) S H LERR="Inva lid DFN" D ACK^IVMPR EC Q
5069	"RTN","IVM PREC6",68, 0)
5070	.S DFN=$G (IVMDFN)
5071	"RTN","IVM PREC6",69, 0)
5072	.;I ('DFN !(DFN'=+DF N)!('$D(^D PT(+DFN,0) ))) D Q
5073	"RTN","IVM PREC6",70, 0)
5074	.;.S HLER R="Invalid DFN" D AC K^IVMPREC
5075	"RTN","IVM PREC6",71, 0)
5076	.;I IVMPI D(19)'=$P( ^DPT(DFN,0 ),"^",9) D Q
5077	"RTN","IVM PREC6",72, 0)
5078	.;.S HLER R="Couldn' t match HE C SSN with DHCP SSN" D ACK^IVM PREC
5079	"RTN","IVM PREC6",73, 0)
5080	.;
5081	"RTN","IVM PREC6",74, 0)
5082	.; - chec k for entr y in IVM P ATIENT fil e, otherwi se create stub entry
5083	"RTN","IVM PREC6",75, 0)
5084	.S IVM301 5=$O(^IVM( 301.5,"B", DFN,0))
5085	"RTN","IVM PREC6",76, 0)
5086	.I 'IVM30 15 S DGENU PLD="",IVM 3015=$$LOG ^IVMPLOG(D FN,DT),DGE NUPLD="ENR OLLMENT/EL IGIBILITY UPLOAD IN PROGRESS" ;IVM2.01 65
5087	"RTN","IVM PREC6",77, 0)
5088	.I 'IVM30 15 D Q
5089	"RTN","IVM PREC6",78, 0)
5090	..S HLERR ="Failed t o create e ntry in IV M PATIENT file"
5091	"RTN","IVM PREC6",79, 0)
5092	..D ACK^I VMPREC
5093	"RTN","IVM PREC6",80, 0)
5094	.;
5095	"RTN","IVM PREC6",81, 0)
5096	.; - comp are PID se gment fiel ds with DH CP fields
5097	"RTN","IVM PREC6",82, 0)
5098	.S IVMSEG ="PID" ;S etting IVM SEG to PID before it calls COM PARE
5099	"RTN","IVM PREC6",83, 0)
5100	.I 'DODSE G,'GUARSEG D COMPARE (IVMSEG) Q :$D(HLERR)
5101	"RTN","IVM PREC6",84, 0)
5102	.;
5103	"RTN","IVM PREC6",85, 0)
5104	.; - get next msg s egment -de crement th e counter so it can pickup ZPD
5105	"RTN","IVM PREC6",86, 0)
5106	.S IVMDA= IVMDA-1 D NEXT I $E( IVMSEG,1,3 )'="ZPD" D Q
5107	"RTN","IVM PREC6",87, 0)
5108	..S HLERR ="Missing ZPD segmen t" D ACK^I VMPREC
5109	"RTN","IVM PREC6",88, 0)
5110	.;Convert "" to nul l in ZPD s egment exc ept seq. 8 ,9, 31 and 32
5111	"RTN","IVM PREC6",89, 0)
5112	.S IVMSEG =$$CLEARF^ IVMPRECA(I VMSEG,HLFS ,",9,10,32 ,33,")
5113	"RTN","IVM PREC6",90, 0)
5114	.;
5115	"RTN","IVM PREC6",91, 0)
5116	.; - comp are ZPD se gment fiel ds with DH CP fields
5117	"RTN","IVM PREC6",92, 0)
5118	.D COMPAR E(IVMSEG)
5119	"RTN","IVM PREC6",93, 0)
5120	.;
5121	"RTN","IVM PREC6",94, 0)
5122	.; - get next msg s egment
5123	"RTN","IVM PREC6",95, 0)
5124	.D NEXT I $E(IVMSEG ,1,3)="ZEL " D Q
5125	"RTN","IVM PREC6",96, 0)
5126	..S HLERR ="ZEL segm ent should not be se nt in Z05 message" D ACK^IVMPR EC
5127	"RTN","IVM PREC6",97, 0)
5128	.;
5129	"RTN","IVM PREC6",98, 0)
5130	.I $E(IVM SEG,1,3)'= "ZTA" D Q
5131	"RTN","IVM PREC6",99, 0)
5132	..S HLERR ="Missing ZTA segmen t" D ACK^I VMPREC
5133	"RTN","IVM PREC6",100 ,0)
5134	.;Convert "" to nul l in ZTA s egment seq . 7
5135	"RTN","IVM PREC6",101 ,0)
5136	.I $P(IVM SEG,HLFS,8 )=HLQ S $P (IVMSEG,HL FS,8)=""
5137	"RTN","IVM PREC6",102 ,0)
5138	.;
5139	"RTN","IVM PREC6",103 ,0)
5140	.; - comp are ZTA se gment fiel ds with DH CP fields
5141	"RTN","IVM PREC6",104 ,0)
5142	.I 'DODSE G,'GUARSEG D COMPARE (IVMSEG)
5143	"RTN","IVM PREC6",105 ,0)
5144	.D NEXT
5145	"RTN","IVM PREC6",106 ,0)
5146	.;
5147	"RTN","IVM PREC6",107 ,0)
5148	.; - get next msg s egment
5149	"RTN","IVM PREC6",108 ,0)
5150	.I $E(IVM SEG,1,3)'= "ZGD" D Q
5151	"RTN","IVM PREC6",109 ,0)
5152	..S HLERR ="Missing ZGD segmen t" D ACK^I VMPREC
5153	"RTN","IVM PREC6",110 ,0)
5154	.;
5155	"RTN","IVM PREC6",111 ,0)
5156	.; - comp are ZGD se gment fiel ds with DH CP fields
5157	"RTN","IVM PREC6",112 ,0)
5158	.; conver t "" to nu ll for ZGD segment
5159	"RTN","IVM PREC6",113 ,0)
5160	.S IVMSEG =$$CLEARF^ IVMPRECA(I VMSEG,HLFS ,",7,") ;i gnore seq. 6
5161	"RTN","IVM PREC6",114 ,0)
5162	.; conver t seq. 6 s eparately
5163	"RTN","IVM PREC6",115 ,0)
5164	.S $P(IVM SEG,HLFS,7 )=$$CLEARF ^IVMPRECA( $P(IVMSEG, HLFS,7),$E (HLECH))
5165	"RTN","IVM PREC6",116 ,0)
5166	.D COMPAR E(IVMSEG)
5167	"RTN","IVM PREC6",117 ,0)
5168	.;S IVMFL G=0
5169	"RTN","IVM PREC6",118 ,0)
5170	.;
5171	"RTN","IVM PREC6",119 ,0)
5172	.;S MULTD ONE=0 F XR EP=1:1 D Q:MULTDONE ;Skip ZC T & ZEM -c oming late r
5173	"RTN","IVM PREC6",120 ,0)
5174	.;.D NEXT
5175	"RTN","IVM PREC6",121 ,0)
5176	.;.I ($E( IVMSEG,1,3 )'="ZCT")& ($E(IVMSEG ,1,3)'="ZE M") S MULT DONE=1 Q
5177	"RTN","IVM PREC6",122 ,0)
5178	.;S IVMDA =IVMDA-1
5179	"RTN","IVM PREC6",123 ,0)
5180	.;
5181	"RTN","IVM PREC6",124 ,0)
5182	.; - get next msg s egment
5183	"RTN","IVM PREC6",125 ,0)
5184	.D NEXT
5185	"RTN","IVM PREC6",126 ,0)
5186	.I $E(IVM SEG,1,3)'= "ZCT" D Q
5187	"RTN","IVM PREC6",127 ,0)
5188	..S HLERR ="Missing ZCT segmen t" D ACK^I VMPREC
5189	"RTN","IVM PREC6",128 ,0)
5190	.S IVMSEG =$$CLEARF^ IVMPRECA(I VMSEG,HLFS )
5191	"RTN","IVM PREC6",129 ,0)
5192	.I 'DODSE G,'GUARSEG D COMPARE (IVMSEG) ;Process 1st ZCT
5193	"RTN","IVM PREC6",130 ,0)
5194	.S MULTDO NE=0 F XRE P=1:1 D Q :MULTDONE ;Handle p ossible mu lt ZCTs
5195	"RTN","IVM PREC6",131 ,0)
5196	..D NEXT I $E(IVMSE G,1,3)'="Z CT" S MULT DONE=1 Q
5197	"RTN","IVM PREC6",132 ,0)
5198	..S IVMSE G=$$CLEARF ^IVMPRECA( IVMSEG,HLF S)
5199	"RTN","IVM PREC6",133 ,0)
5200	..I 'DODS EG,'GUARSE G D COMPAR E(IVMSEG)
5201	"RTN","IVM PREC6",134 ,0)
5202	.;
5203	"RTN","IVM PREC6",135 ,0)
5204	.S IVMDA= IVMDA-1 D NEXT
5205	"RTN","IVM PREC6",136 ,0)
5206	.I $E(IVM SEG,1,3)'= "ZEM" D Q
5207	"RTN","IVM PREC6",137 ,0)
5208	..S HLERR ="Missing ZEM segmen t" D ACK^I VMPREC
5209	"RTN","IVM PREC6",138 ,0)
5210	.I 'DODSE G,'GUARSEG D COMPARE (IVMSEG) ;Process 1st ZEM
5211	"RTN","IVM PREC6",139 ,0)
5212	.S MULTDO NE=0 F XRE P=1:1 D Q :MULTDONE ;Handle p ossible mu lt ZEMs
5213	"RTN","IVM PREC6",140 ,0)
5214	..D NEXT I $E(IVMSE G,1,3)'="Z EM" S MULT DONE=1 Q
5215	"RTN","IVM PREC6",141 ,0)
5216	..I 'DODS EG,'GUARSE G D COMPAR E(IVMSEG)
5217	"RTN","IVM PREC6",142 ,0)
5218	.S IVMDA= IVMDA-1
5219	"RTN","IVM PREC6",143 ,0)
5220	.;
5221	"RTN","IVM PREC6",144 ,0)
5222	.; - chec k for RF1 segment an d get segm ent if it exists
5223	"RTN","IVM PREC6",145 ,0)
5224	.; Th is process will auto matically update pat ient addre ss data
5225	"RTN","IVM PREC6",146 ,0)
5226	.; in the Patie nt (#2) fi le if the incoming a ddress is more
5227	"RTN","IVM PREC6",147 ,0)
5228	.; re cent than the existi ng one.
5229	"RTN","IVM PREC6",148 ,0)
5230	.;Modifie d code to handle mul tiple RF1 segment - IVM2115
5231	"RTN","IVM PREC6",149 ,0)
5232	.S (UPDEP C("SAD"),U PDEPC("CPH "),UPDEPC( "PNO"),UPD EPC("EAD") ,UPDEPC("P HH"))=0
5233	"RTN","IVM PREC6",150 ,0)
5234	.S QFLG=0 I $$RF1CH K(IVMRTN,I VMDA) F I= 1:1 D Q:Q FLG
5235	"RTN","IVM PREC6",151 ,0)
5236	..D NEXT
5237	"RTN","IVM PREC6",152 ,0)
5238	..S IVMSE G=$$CLEARF ^IVMPRECA( IVMSEG,HLF S,",7,") ; ignore seq . 6
5239	"RTN","IVM PREC6",153 ,0)
5240	..S $P(IV MSEG,HLFS, 7)=$$CLEAR F^IVMPRECA ($P(IVMSEG ,HLFS,7),$ E(HLECH))
5241	"RTN","IVM PREC6",154 ,0)
5242	..I $P(IV MSEG,HLFS, 4)="" S QF LG=1 Q ;Q uit if RF1 is blank
5243	"RTN","IVM PREC6",155 ,0)
5244	..D COMPA RE(IVMSEG)
5245	"RTN","IVM PREC6",156 ,0)
5246	..I '$$RF 1CHK(IVMRT N,IVMDA) S QFLG=1
5247	"RTN","IVM PREC6",157 ,0)
5248	.D AUTOAU P^IVMPREC9 (DFN,.UPDA UP,.UPDAUP G)
5249	"RTN","IVM PREC6",158 ,0)
5250	.S IVMFLG =0
5251	"RTN","IVM PREC6",159 ,0)
5252	;
5253	"RTN","IVM PREC6",160 ,0)
5254	; - send mail messa ge if nece ssary
5255	"RTN","IVM PREC6",161 ,0)
5256	; This bu lletin has been disa bled. IVM 2140
5257	"RTN","IVM PREC6",162 ,0)
5258	;I IVMCNT R D MAIL^I VMUFNC()
5259	"RTN","IVM PREC6",163 ,0)
5260	; Cleanup variables if no msg necessary
5261	"RTN","IVM PREC6",164 ,0)
5262	I 'IVMCNT R K IVMTEX T,XMSUB
5263	"RTN","IVM PREC6",165 ,0)
5264	;
5265	"RTN","IVM PREC6",166 ,0)
5266	ENQ ; - cl eanup vari ables
5267	"RTN","IVM PREC6",167 ,0)
5268	K DA,DFN, IVMADDR,IV MADFLG,IVM DA,IVMDHCP ,IVMFLAG,I VMFLD,IVMP IECE,IVMSE G,IVMSTART ,IVMXREF,D GENUPLD,IV MPID,PIDST R,ADDRESS, TELECOM,UP DEPC,EPCFA RY,IVMDFN, DODSEG,EPC DEL,GUARSE G,UPDAUP,I VMRACE,IVM TSTPT
5269	"RTN","IVM PREC6",168 ,0)
5270	Q
5271	"RTN","IVM PREC6",169 ,0)
5272	;
5273	"RTN","IVM PREC6",170 ,0)
5274	;
5275	"RTN","IVM PREC6",171 ,0)
5276	NEXT ; - g et the nex t HL7 segm ent in the message f rom HL7 Tr ansmission (#772) fi le
5277	"RTN","IVM PREC6",172 ,0)
5278	;
5279	"RTN","IVM PREC6",173 ,0)
5280	S IVMDA=$ O(^TMP($J, IVMRTN,IVM DA)),IVMSE G=$G(^(+IV MDA,0))
5281	"RTN","IVM PREC6",174 ,0)
5282	Q
5283	"RTN","IVM PREC6",175 ,0)
5284	;
5285	"RTN","IVM PREC6",176 ,0)
5286	;
5287	"RTN","IVM PREC6",177 ,0)
5288	COMPARE(IV MSEG) ; - compare in coming HL7 segment/f ields with DHCP fiel ds
5289	"RTN","IVM PREC6",178 ,0)
5290	;
5291	"RTN","IVM PREC6",179 ,0)
5292	; Input: IVMSEG -- as the text of t he incomin g HL7 mess age
5293	"RTN","IVM PREC6",180 ,0)
5294	;
5295	"RTN","IVM PREC6",181 ,0)
5296	; Output: None
5297	"RTN","IVM PREC6",182 ,0)
5298	;
5299	"RTN","IVM PREC6",183 ,0)
5300	; - get 3 letter HL 7 segment name
5301	"RTN","IVM PREC6",184 ,0)
5302	S IVMXREF =$P(IVMSEG ,HLFS,1),I VMSTART=IV MXREF
5303	"RTN","IVM PREC6",185 ,0)
5304	;
5305	"RTN","IVM PREC6",186 ,0)
5306	; - strip off HL7 s egment nam e
5307	"RTN","IVM PREC6",187 ,0)
5308	S IVMSEG= $P(IVMSEG, HLFS,2,99)
5309	"RTN","IVM PREC6",188 ,0)
5310	;
5311	"RTN","IVM PREC6",189 ,0)
5312	; - roll through "C " x-ref in IVM Demog raphic Upl oad Fields (#301.92) file
5313	"RTN","IVM PREC6",190 ,0)
5314	F S IVMX REF=$O(^IV M(301.92," C",IVMXREF )) Q:IVMXR EF']"" D
5315	"RTN","IVM PREC6",191 ,0)
5316	.S IVMDEM DA=$O(^IVM (301.92,"C ",IVMXREF, "")) Q:IVM DEMDA']""
5317	"RTN","IVM PREC6",192 ,0)
5318	.I $$INAC TIVE(IVMDE MDA) Q
5319	"RTN","IVM PREC6",193 ,0)
5320	.;
5321	"RTN","IVM PREC6",194 ,0)
5322	.; - comp are incomi ng HL7 seg ment field s with DHC P fields
5323	"RTN","IVM PREC6",195 ,0)
5324	.I IVMXRE F["PID",(I VMSTART["P ID") D PID ^IVMPREC8
5325	"RTN","IVM PREC6",196 ,0)
5326	.I IVMXRE F["ZPD",(I VMSTART["Z PD") D ZPD ^IVMPREC8
5327	"RTN","IVM PREC6",197 ,0)
5328	.I IVMXRE F["ZTA",(I VMSTART["Z TA") D ZTA ^IVMPREC8
5329	"RTN","IVM PREC6",198 ,0)
5330	.I IVMXRE F["ZGD",(I VMSTART["Z GD") D ZGD ^IVMPREC8
5331	"RTN","IVM PREC6",199 ,0)
5332	.I IVMXRE F["ZCT",(I VMSTART["Z CT") D ZCT ^IVMPREC8
5333	"RTN","IVM PREC6",200 ,0)
5334	.I IVMXRE F["ZEM",(I VMSTART["Z EM") D ZEM ^IVMPREC8
5335	"RTN","IVM PREC6",201 ,0)
5336	.I IVMXRE F["RF1",(I VMSTART["R F1") D RF1 ^IVMPREC8
5337	"RTN","IVM PREC6",202 ,0)
5338	Q
5339	"RTN","IVM PREC6",203 ,0)
5340	;
5341	"RTN","IVM PREC6",204 ,0)
5342	;
5343	"RTN","IVM PREC6",205 ,0)
5344	DEMBULL ; - build m ail messag e for tran smission t o IVM mail group not ifying
5345	"RTN","IVM PREC6",206 ,0)
5346	; them that pati ents with updated de mographic data has b een receiv ed
5347	"RTN","IVM PREC6",207 ,0)
5348	; from the IVM C enter and may now be uploaded into DHCP.
5349	"RTN","IVM PREC6",208 ,0)
5350	;
5351	"RTN","IVM PREC6",209 ,0)
5352	; If reco rd is auto uploaded, don't add veteran t o bulletin
5353	"RTN","IVM PREC6",210 ,0)
5354	I $$CKAUT O Q
5355	"RTN","IVM PREC6",211 ,0)
5356	;
5357	"RTN","IVM PREC6",212 ,0)
5358	S IVMPTID =$$PT^IVMU FNC4(DFN)
5359	"RTN","IVM PREC6",213 ,0)
5360	S XMSUB=" IVM - DEMO GRAPHIC UP LOAD for " _$P($P(IVM PTID,"^"), ",")_" ("_ $P(IVMPTID ,"^",3)_") "
5361	"RTN","IVM PREC6",214 ,0)
5362	S IVMTEXT (1)="Updat ed demogra phic infor mation has been rece ived from the"
5363	"RTN","IVM PREC6",215 ,0)
5364	S IVMTEXT (2)="Healt h Eligibil ty Center. Please s elect the 'Demograph ic Upload' "
5365	"RTN","IVM PREC6",216 ,0)
5366	S IVMTEXT (3)="optio n from the IVM Uploa d Menu in order to t ake action on this"
5367	"RTN","IVM PREC6",217 ,0)
5368	S IVMTEXT (4)="demog raphic inf ormation. If you ha ve any que stions con cerning th e"
5369	"RTN","IVM PREC6",218 ,0)
5370	S IVMTEXT (5)="infor mation rec eived, ple ase contac t the Heal th Eligibi lity Cente r."
5371	"RTN","IVM PREC6",219 ,0)
5372	S IVMTEXT (7)=""
5373	"RTN","IVM PREC6",220 ,0)
5374	S IVMTEXT (8)="The H ealth Elig ibilty Cen ter has id entified t he followi ng"
5375	"RTN","IVM PREC6",221 ,0)
5376	S IVMTEXT (9)="patie nts as hav ing update d demograp hic inform ation:"
5377	"RTN","IVM PREC6",222 ,0)
5378	S IVMTEXT (10)=""
5379	"RTN","IVM PREC6",223 ,0)
5380	S IVMCNTR =IVMCNTR+1
5381	"RTN","IVM PREC6",224 ,0)
5382	S IVMTEXT (IVMCNTR+1 0)=$J(IVMC NTR_")",5) _" "_$P(I VMPTID,"^" )_" ("_$P( IVMPTID,"^ ",3)_")"
5383	"RTN","IVM PREC6",225 ,0)
5384	Q
5385	"RTN","IVM PREC6",226 ,0)
5386	;
5387	"RTN","IVM PREC6",227 ,0)
5388	INACTIVE(I VMDEMDA) ; Check if f ield is in active in Demographi c Upload
5389	"RTN","IVM PREC6",228 ,0)
5390	; Input -- IVMDEMD A IVM Demo graphic Up load Field s IEN
5391	"RTN","IVM PREC6",229 ,0)
5392	; Output -- 1=Yes a nd 0=No
5393	"RTN","IVM PREC6",230 ,0)
5394	Q +$P($G( ^IVM(301.9 2,IVMDEMDA ,0)),U,9)
5395	"RTN","IVM PREC6",231 ,0)
5396	;
5397	"RTN","IVM PREC6",232 ,0)
5398	RF1CHK(IVM RTN,IVMDA) ;does an RF1 segmen t exist in this mess age?
5399	"RTN","IVM PREC6",233 ,0)
5400	N RF1
5401	"RTN","IVM PREC6",234 ,0)
5402	S RF1=$O( ^TMP($J,IV MRTN,IVMDA ))
5403	"RTN","IVM PREC6",235 ,0)
5404	I $E($G(^ (+RF1,0)), 1,3)'="RF1 " Q 0
5405	"RTN","IVM PREC6",236 ,0)
5406	Q 1
5407	"RTN","IVM PREC6",237 ,0)
5408	;
5409	"RTN","IVM PREC6",238 ,0)
5410	CKAUTO() ;
5411	"RTN","IVM PREC6",239 ,0)
5412	; Chect i f message qualifies for an aut o upload.
5413	"RTN","IVM PREC6",240 ,0)
5414	N AUTO,IV MI,DOD
5415	"RTN","IVM PREC6",241 ,0)
5416	S AUTO=0, IVMI=$O(^I VM(301.92, "C","ZPD09 ",""))
5417	"RTN","IVM PREC6",242 ,0)
5418	I IVMI=IV MDEMDA D
5419	"RTN","IVM PREC6",243 ,0)
5420	.I +IVMFL D'>0 S AUT O=1 Q
5421	"RTN","IVM PREC6",244 ,0)
5422	.S DOD=$P ($G(^DPT(D FN,.35)),U )
5423	"RTN","IVM PREC6",245 ,0)
5424	.I DOD=IV MFLD S AUT O=1 Q
5425	"RTN","IVM PREC6",246 ,0)
5426	;
5427	"RTN","IVM PREC6",247 ,0)
5428	Q AUTO
5429	"RTN","IVM PREC6",248 ,0)
5430	BLDPID(PID TMP,IVMPID ) ;Build I VMPID subs cripted by sequence number
5431	"RTN","IVM PREC6",249 ,0)
5432	N STR,X1, X2,N,TEXT, C,L
5433	"RTN","IVM PREC6",250 ,0)
5434	S STR="", X1=1,(N,X2 )=0
5435	"RTN","IVM PREC6",251 ,0)
5436	F S N=$O (PIDTMP(N) ) Q:N="" S TEXT=PID TMP(N) F L =1:1:$L(TE XT) S C=$E (TEXT,L) D
5437	"RTN","IVM PREC6",252 ,0)
5438	. I C="^" D Q
5439	"RTN","IVM PREC6",253 ,0)
5440	. . I X2 S X2=X2+1, IVMPID(X1, X2)=STR
5441	"RTN","IVM PREC6",254 ,0)
5442	. . E S IVMPID(X1) =STR
5443	"RTN","IVM PREC6",255 ,0)
5444	. . S STR ="",X1=X1+ 1,X2=0
5445	"RTN","IVM PREC6",256 ,0)
5446	. I C="\|" D Q
5447	"RTN","IVM PREC6",257 ,0)
5448	. . S X2= X2+1,IVMPI D(X1,X2)=S TR,STR=""
5449	"RTN","IVM PREC6",258 ,0)
5450	. S STR=S TR_C
5451	"RTN","IVM PREC6",259 ,0)
5452	I $G(C)'= "",$G(C)'= "^",$G(C)' ="\|" D
5453	"RTN","IVM PREC6",260 ,0)
5454	. I X2 S X2=X2+1,IV MPID(X1,X2 )=STR Q
5455	"RTN","IVM PREC6",261 ,0)
5456	. S IVMPI D(X1)=STR
5457	"RTN","IVM PREC6",262 ,0)
5458	Q
5459	"RTN","IVM PREC6",263 ,0)
5460	ADDRCHNG(D FN) ;Store Address C hange Date /time, Sou rce and si te if nece ssary
5461	"RTN","IVM PREC6",264 ,0)
5462	;Store Re sidence Nu mber Chang e Date/Tim e, Source and Site ( IVM2152)
5463	"RTN","IVM PREC6",265 ,0)
5464	N IVMVALU E,IVMFIELD
5465	"RTN","IVM PREC6",266 ,0)
5466	I '$D(^TM P($J,"CHAN GE UPDATE" )) Q
5467	"RTN","IVM PREC6",267 ,0)
5468	S IVMFIEL D=0 F S I VMFIELD=$O (^TMP($J," CHANGE UPD ATE",IVMFI ELD)) Q:IV MFIELD="" D
5469	"RTN","IVM PREC6",268 ,0)
5470	. S IVMVA LUE=$G(^TM P($J,"CHAN GE UPDATE" ,IVMFIELD) )
5471	"RTN","IVM PREC6",269 ,0)
5472	. S DIE=" ^DPT(",DA= DFN,DR=IVM FIELD_"/// /^S X=IVMV ALUE"
5473	"RTN","IVM PREC6",270 ,0)
5474	. D ^DIE K DA,DIE,D R
5475	"RTN","IVM PREC6",271 ,0)
5476	.; - dele te inaccur ate Addr C hange Site data if S ource is n ot VAMC
5477	"RTN","IVM PREC6",272 ,0)
5478	. I IVMFI ELD=.119,I VMVALUE'=" VAMC" S FD A(2,+DFN_" ,",.12)="@ " D UPDATE ^DIE("E"," FDA")
5479	"RTN","IVM PREC6",273 ,0)
5480	.; - dele te inaccur ate Reside nce Number Change Si te data if Source
5481	"RTN","IVM PREC6",274 ,0)
5482	.; is n ot VAMC (I VM2152)
5483	"RTN","IVM PREC6",275 ,0)
5484	. I IVMFI ELD=.1322, IVMVALUE'= "VAMC" S F DA(2,+DFN_ ",",.1323) ="@" D UPD ATE^DIE("E ","FDA")
5485	"RTN","IVM PREC6",276 ,0)
5486	K ^TMP($J ,"CHANGE U PDATE")
5487	"RTN","IVM PREC6",277 ,0)
5488	Q
5489	"RTN","IVM PREC6",278 ,0)
5490	EPCFLDS(EP CFARY,EPCD EL) ;
5491	"RTN","IVM PREC6",279 ,0)
5492	;EPCFARY - Contains IENs of P ager, emai l, Cell ph one and Ho me phone r ecords in 301.92 Fil e - Passed by refere nce
5493	"RTN","IVM PREC6",280 ,0)
5494	;EPCDEL - Contains field # of Pager, Em ail, Cell phone and Home phone fields in Patient(# 2) file. - Passed by reference
5495	"RTN","IVM PREC6",281 ,0)
5496	I (DODSEG )!(GUARSEG ) Q
5497	"RTN","IVM PREC6",282 ,0)
5498	S EPCFARY ("PNO")=$O (^IVM(301. 92,"B","PA GER NUMBER ",0))_"^"_ $O(^IVM(30 1.92,"B"," PAGER CHAN GE DT/TM", 0))_"^"_$O (^IVM(301. 92,"B","PA GER CHANGE SITE",0)) _"^"_$O(^I VM(301.92, "B","PAGER CHANGE SO URCE",0))
5499	"RTN","IVM PREC6",283 ,0)
5500	S EPCFARY ("CPH")=$O (^IVM(301. 92,"B","CE LLULAR NUM BER",0))_" ^"_$O(^IVM (301.92,"B ","CELL PH ONE CHANGE DT/TM",0) )_"^"_$O(^ IVM(301.92 ,"B","CELL PHONE CHA NGE SITE", 0))_"^"_$O (^IVM(301. 92,"B","CE LL PHONE C HANGE SOUR CE",0))
5501	"RTN","IVM PREC6",284 ,0)
5502	S EPCFARY ("EAD")=$O (^IVM(301. 92,"B","EM AIL ADDRES S",0))_"^" _$O(^IVM(3 01.92,"B", "EMAIL CHA NGE DT/TM" ,0))_"^"_$ O(^IVM(301 .92,"B","E MAIL CHANG E SITE",0) )_"^"_$O(^ IVM(301.92 ,"B","EMAI L CHANGE S OURCE",0))
5503	"RTN","IVM PREC6",285 ,0)
5504	; IVM2.0 167 - Mak e Home pho ne records auto-uplo ad to Pati ent File
5505	"RTN","IVM PREC6",286 ,0)
5506	S EPCFARY ("PHH")=$O (^IVM(301. 92,"B","PH ONE NUMBER [RESIDENC E]",0))_"^ "_$O(^IVM( 301.92,"B" ,"RESIDENC E NUMBER C HANGE DT/T M",0))_"^" _$O(^IVM(3 01.92,"B", "RESIDENCE NUMBER CH ANGE SITE" ,0))_"^"_$ O(^IVM(301 .92,"B","R ESIDENCE N UMBER CHAN GE SOURCE" ,0))
5507	"RTN","IVM PREC6",287 ,0)
5508	S EPCDEL( "PNO")=".1 35^.1312^. 1313^.1314 "
5509	"RTN","IVM PREC6",288 ,0)
5510	S EPCDEL( "CPH")=".1 34^.139^.1 311^.13111 "
5511	"RTN","IVM PREC6",289 ,0)
5512	S EPCDEL( "EAD")=".1 33^.136^.1 37^.138"
5513	"RTN","IVM PREC6",290 ,0)
5514	; IVM2.0 167 - Mak e Home pho ne records auto-uplo ad to Pati ent File
5515	"RTN","IVM PREC6",291 ,0)
5516	S EPCDEL( "PHH")=".1 31^.1321^. 1322^.1323 "
5517	"RTN","IVM PREC6",292 ,0)
5518	Q
5519	"RTN","IVM PREC6",293 ,0)
5520	;
5521	"RTN","IVM PREC6",294 ,0)
5522	AUPBLD(AUP FARY,UPDAU PG) ; Set up array c ontaining fields for auto uplo ad.
5523	"RTN","IVM PREC6",295 ,0)
5524	;AUPFARY - Contains fields in 301.92 Fi le-Passed by referen ce
5525	"RTN","IVM PREC6",296 ,0)
5526	;UPDAUPG - Contains all group s initiali zed to '0'
5527	"RTN","IVM PREC6",297 ,0)
5528	N AUPSTR, AUPGRP,AUP FLST,AUPPC E,AUPSGSQ, AUPDA
5529	"RTN","IVM PREC6",298 ,0)
5530	F I=3:1 S AUPSTR=$P ($T(AUPLST +I),";;",2 ,3) Q:$P(A UPSTR,";") ="QUIT" D
5531	"RTN","IVM PREC6",299 ,0)
5532	.S AUPGRP =$P(AUPSTR ,";"),AUPF LST=$P(AUP STR,";",2)
5533	"RTN","IVM PREC6",300 ,0)
5534	.F AUPPCE =1:1:$L(AU PFLST,"^") D
5535	"RTN","IVM PREC6",301 ,0)
5536	..S AUPSG SQ=$P(AUPF LST,"^",AU PPCE) Q:AU PSGSQ=""
5537	"RTN","IVM PREC6",302 ,0)
5538	..S AUPDA =$O(^IVM(3 01.92,"C", AUPSGSQ,0) ) Q:AUPDA= ""
5539	"RTN","IVM PREC6",303 ,0)
5540	..S AUPFA RY(AUPDA)= AUPGRP
5541	"RTN","IVM PREC6",304 ,0)
5542	..S:AUPGR P'="" UPDA UPG(AUPGRP )=0 ; Def ault group update fl ags to '0'
5543	"RTN","IVM PREC6",305 ,0)
5544	Q
5545	"RTN","IVM PREC6",306 ,0)
5546	;
5547	"RTN","IVM PREC6",307 ,0)
5548	AUPLST ; P 1;P2
5549	"RTN","IVM PREC6",308 ,0)
5550	; P1 = Gr oup Name ( treat all entries as this grou p if prese nt)
5551	"RTN","IVM PREC6",309 ,0)
5552	; P2 = .0 1 field(s) from 301. 92 seperat ed by '^'
5553	"RTN","IVM PREC6",310 ,0)
5554	;;D1;ZCT0 3D1^ZCT04D 1^ZCT051D1 ^ZCT052D1^ ZCT053D1^Z CT054D1^ZC T055D1^ZCT 06D1^ZCT07 D1^ZCT10D1
5555	"RTN","IVM PREC6",311 ,0)
5556	;;E1;ZCT0 3E1^ZCT04E 1^ZCT051E1 ^ZCT052E1^ ZCT053E1^Z CT054E1^ZC T055E1^ZCT 06E1^ZCT07 E1^ZCT10E1
5557	"RTN","IVM PREC6",312 ,0)
5558	;;E2;ZCT0 3E2^ZCT04E 2^ZCT051E2 ^ZCT052E2^ ZCT053E2^Z CT054E2^ZC T055E2^ZCT 06E2^ZCT07 E2^ZCT10E2
5559	"RTN","IVM PREC6",313 ,0)
5560	;;K1;ZCT0 3K1^ZCT04K 1^ZCT051K1 ^ZCT052K1^ ZCT053K1^Z CT054K1^ZC T055K1^ZCT 06K1^ZCT07 K1^ZCT10K1
5561	"RTN","IVM PREC6",314 ,0)
5562	;;K2;ZCT0 3K2^ZCT04K 2^ZCT051K2 ^ZCT052K2^ ZCT053K2^Z CT054K2^ZC T055K2^ZCT 06K2^ZCT07 K2^ZCT10K2
5563	"RTN","IVM PREC6",315 ,0)
5564	;;TA;ZTA0 2^ZTA03^ZT A04^ZTA051 ^ZTA052^ZT A053^ZTA05 4^ZTA055^Z TA056^ZTA0 58^ZTA059^ ZTA07^ZTA0 8^ZTA09^ZT A054F^ZTA0 55F
5565	"RTN","IVM PREC6",316 ,0)
5566	;;;ZEM03^ ZEM04^ZEM0 5^ZEM061^Z EM062^ZEM0 63^ZEM064^ ZEM065^ZEM 068^ZEM07^ ZEM09
5567	"RTN","IVM PREC6",317 ,0)
5568	;;;ZEM03S ^ZEM04S^ZE M05S^ZEM06 1S^ZEM062S ^ZEM063S^Z EM064S^ZEM 065S^ZEM06 8S^ZEM07S^ ZEM09S
5569	"RTN","IVM PREC6",318 ,0)
5570	;;;PID06^ PID10^PID1 6^PID17^PI D22^ZPD30^ ZPD06^ZPD0 7
5571	"RTN","IVM PREC6",319 ,0)
5572	;;QUIT
5573	"RTN","IVM PREC6",320 ,0)
5574	;;
5575	"RTN","IVM PREC6",321 ,0)
5576	;;The fol lowing hav e been dis abled unti l further notice
5577	"RTN","IVM PREC6",322 ,0)
5578	;;;PID113 N^PID114N^ PID24^PID1 3W
5579	"RTN","IVM PREC6",323 ,0)
5580	;;CA;PID1 11C^PID112 C^PID113C^ PID114C^PI D114CF^PID 115C^PID11 5CF^PID116 C^PID117C^ PID118C^PI D119C^PID1 112C1^PID1 112C2^PID1 3CA^RF161C A^RF171CA
5581	"RTN","IVM PREC8")
5582	0^3^B24293 8145
5583	"RTN","IVM PREC8",1,0 )
5584	IVMPREC8 ; ALB/KCL,BR M,PJR,CKN, TDM,PWC,LB D,DPR,KUM - PROCESS INCOMING ( Z05 EVENT TYPE) HL7 MESSAGES ( CON'T) ;05 Sep 2017 8:56 AM
5585	"RTN","IVM PREC8",2,0 )
5586	;;2.0;INC OME VERIFI CATION MAT CH;5,6,1 2,58,73,79 ,102,115,1 21,148,151 ,152,168,1 67;21-OC T-94;Build 39
5587	"RTN","IVM PREC8",3,0 )
5588	;Per VA D irective 6 402, this routine sh ould not b e modified .
5589	"RTN","IVM PREC8",4,0 )
5590	;
5591	"RTN","IVM PREC8",5,0 )
5592	; This ro utine is c alled from IVMPREC6.
5593	"RTN","IVM PREC8",6,0 )
5594	; This ro utine will process b atch ORU d emographic (event ty pe Z05) HL 7
5595	"RTN","IVM PREC8",7,0 )
5596	; message s received from the IVM center .
5597	"RTN","IVM PREC8",8,0 )
5598	;
5599	"RTN","IVM PREC8",9,0 )
5600	;
5601	"RTN","IVM PREC8",10, 0)
5602	;
5603	"RTN","IVM PREC8",11, 0)
5604	PID ; - co mpare PID segment fi elds with DHCP field s
5605	"RTN","IVM PREC8",12, 0)
5606	N COMPPH1 ,COMPPH2,C OUNTRY
5607	"RTN","IVM PREC8",13, 0)
5608	;
5609	"RTN","IVM PREC8",14, 0)
5610	S IVMFLD= ""
5611	"RTN","IVM PREC8",15, 0)
5612	; - strip off segme nt name
5613	"RTN","IVM PREC8",16, 0)
5614	S IVMPIEC E=$E(IVMXR EF,4,9)
5615	"RTN","IVM PREC8",17, 0)
5616	;Only pro cess if va lue exist - also han dles multi ple addres s
5617	"RTN","IVM PREC8",18, 0)
5618	I $G(IVMP ID(+$E(IVM PIECE,1,2) ))'=""!($O (IVMPID(+$ E(IVMPIECE ,1,2),"")) ) D
5619	"RTN","IVM PREC8",19, 0)
5620	.;
5621	"RTN","IVM PREC8",20, 0)
5622	.; - if P ID field i s the addr ess field - parse ad dress
5623	"RTN","IVM PREC8",21, 0)
5624	.S IVMADF LG=0
5625	"RTN","IVM PREC8",22, 0)
5626	.I IVMXRE F["PID11", '$G(DODSEG ) D Q:IVM FLD=""
5627	"RTN","IVM PREC8",23, 0)
5628	..;
5629	"RTN","IVM PREC8",24, 0)
5630	..; - Pro cess Place of Birth City & Sta te
5631	"RTN","IVM PREC8",25, 0)
5632	..;I (IVM XREF="PID1 13N")!(IVM XREF="PID1 14N") D Q
5633	"RTN","IVM PREC8",26, 0)
5634	..;.Q:'$D (ADDRESS(" N"))
5635	"RTN","IVM PREC8",27, 0)
5636	..;.S IVM ADDR=ADDRE SS("N")
5637	"RTN","IVM PREC8",28, 0)
5638	..;.S IVM PIECE=$E(I VMPIECE,3, 4),IVMFLD= $P(IVMADDR ,$E(HLECH) ,IVMPIECE)
5639	"RTN","IVM PREC8",29, 0)
5640	..;.Q:IVM FLD=""
5641	"RTN","IVM PREC8",30, 0)
5642	..;.I IVM PIECE="4N" S (IVMSTP TR,IVMFLD) =+$O(^DIC( 5,"C",IVMF LD,0))
5643	"RTN","IVM PREC8",31, 0)
5644	..;
5645	"RTN","IVM PREC8",32, 0)
5646	..; - get PID addre ss field c ontaining 5 pieces s eperated b y HLECH (~ )
5647	"RTN","IVM PREC8",33, 0)
5648	..;I $G(A UPFARY(IVM DEMDA))="C A" S IVMAD DR=$G(ADDR ESS("CA")) ;Conf Add r
5649	"RTN","IVM PREC8",34, 0)
5650	..I $G(AU PFARY(IVMD EMDA))'="C A" D
5651	"RTN","IVM PREC8",35, 0)
5652	...S IVMA DDR=$S($D( ADDRESS("P ")):ADDRES S("P"),$D( ADDRESS("V AB1")):ADD RESS("VAB1 "),$D(ADDR ESS("VAB2" )):ADDRESS ("VAB2"),$ D(ADDRESS( "VAB3")):A DDRESS("VA B3"),$D(AD DRESS("VAB 4")):ADDRE SS("VAB4") ,1:"")
5653	"RTN","IVM PREC8",36, 0)
5654	..I IVMAD DR="" Q
5655	"RTN","IVM PREC8",37, 0)
5656	..S COUNT RY=$P(IVMA DDR,$E(HLE CH),6)
5657	"RTN","IVM PREC8",38, 0)
5658	..S FORAD DR=$S(COUN TRY="USA": 0,1:1)
5659	"RTN","IVM PREC8",39, 0)
5660	..; - get piece of address fi eld, and s et IVMFLD
5661	"RTN","IVM PREC8",40, 0)
5662	..S IVMPI ECE=$E(IVM PIECE,3,6) ,IVMFLD=$P (IVMADDR,$ E(HLECH),I VMPIECE)
5663	"RTN","IVM PREC8",41, 0)
5664	..;I (IVM PIECE="2C" )!(IVMPIEC E="8C") S: IVMFLD="" IVMFLD="@"
5665	"RTN","IVM PREC8",42, 0)
5666	..Q:IVMFL D=""
5667	"RTN","IVM PREC8",43, 0)
5668	..; - con vert state abbrev. t o pointer
5669	"RTN","IVM PREC8",44, 0)
5670	..I (IVMP IECE=4)!(I VMPIECE="4 C") D
5671	"RTN","IVM PREC8",45, 0)
5672	...S IVMF LD=$S('FOR ADDR:IVMFL D,1:"")
5673	"RTN","IVM PREC8",46, 0)
5674	...I IVMF LD'="" S ( IVMSTPTR,I VMFLD)=+$O (^DIC(5,"C ",IVMFLD,0 ))
5675	"RTN","IVM PREC8",47, 0)
5676	..I (IVMP IECE=5)!(I VMPIECE="5 C") D
5677	"RTN","IVM PREC8",48, 0)
5678	...S IVMF LD=$S('FOR ADDR:IVMFL D,1:"")
5679	"RTN","IVM PREC8",49, 0)
5680	...I IVMF LD'="" S X =IVMFLD D ZIPIN^VAFA DDR S IVMF LD=X
5681	"RTN","IVM PREC8",50, 0)
5682	..I (IVMP IECE="4F") !(IVMPIECE ="4CF") S IVMFLD=$S( FORADDR:IV MFLD,1:"") ;PROVINCE
5683	"RTN","IVM PREC8",51, 0)
5684	..I (IVMP IECE="5F") !(IVMPIECE ="5CF") S IVMFLD=$S( FORADDR:IV MFLD,1:"") ;POSTAL C ODE
5685	"RTN","IVM PREC8",52, 0)
5686	..I (IVMP IECE=6)!(I VMPIECE="6 C") S IVMF LD=$$CNTRC ONV(COUNTR Y) ;COUNTR Y
5687	"RTN","IVM PREC8",53, 0)
5688	..I IVMPI ECE=7 S IV MFLD=$$BAI CONV(IVMFL D) ;Bad Ad dress Indi cator
5689	"RTN","IVM PREC8",54, 0)
5690	..I IVMPI ECE="7C" S IVMFLD=CO NFADCT ;C ONFADCT se t in PID11 ^IVMPRECA
5691	"RTN","IVM PREC8",55, 0)
5692	..I IVMPI ECE="9C" D
5693	"RTN","IVM PREC8",56, 0)
5694	...S IVMF LD=$S('FOR ADDR:IVMFL D,1:"") Q: IVMFLD=""
5695	"RTN","IVM PREC8",57, 0)
5696	...S IVMF LD=+$O(^DI C(5,IVMSTP TR,1,"C",I VMFLD,0)) ;CONF ADD R COUNTY
5697	"RTN","IVM PREC8",58, 0)
5698	..I $E(IV MPIECE,1,3 )="12C" S IVMFLD=$$F MDATE^HLFN C($P(IVMFL D,$E(HLECH ,4),$E(IVM PIECE,4)))
5699	"RTN","IVM PREC8",59, 0)
5700	..S IVMAD FLG=1
5701	"RTN","IVM PREC8",60, 0)
5702	.;
5703	"RTN","IVM PREC8",61, 0)
5704	.I IVMXRE F["PID12", '$G(DODSEG ) D
5705	"RTN","IVM PREC8",62, 0)
5706	..I 'FORA DDR S IVMA DFLG=1,IVM FLD=+$O(^D IC(5,IVMST PTR,1,"C", IVMPID(12) ,0)) ;Pro cess count y only if not foreig n address
5707	"RTN","IVM PREC8",63, 0)
5708	.; line r emove so t hat the ph one number is compar ed
5709	"RTN","IVM PREC8",64, 0)
5710	.; before saving to 301.5.
5711	"RTN","IVM PREC8",65, 0)
5712	.I IVMXRE F["PID13", $D(TELECOM ),'$G(DODS EG) D
5713	"RTN","IVM PREC8",66, 0)
5714	..;Confid ential Pho ne Number
5715	"RTN","IVM PREC8",67, 0)
5716	..;I IVMX REF="PID13 CA",$D(TEL ECOM("VACP N")) D
5717	"RTN","IVM PREC8",68, 0)
5718	..;.S IVM FLD=$$CONV PH($P($G(T ELECOM("VA CPN")),$E( HLECH))),I VMADFLG=1
5719	"RTN","IVM PREC8",69, 0)
5720	..;Phone Number [Wo rk]
5721	"RTN","IVM PREC8",70, 0)
5722	..;I IVMX REF="PID13 W",$D(TELE COM("WPN") ) D
5723	"RTN","IVM PREC8",71, 0)
5724	..;.S IVM FLD=$$CONV PH($P($G(T ELECOM("WP N")),$E(HL ECH))),IVM ADFLG=1
5725	"RTN","IVM PREC8",72, 0)
5726	..;Pager Number
5727	"RTN","IVM PREC8",73, 0)
5728	..I IVMXR EF="PID13B ",$D(TELEC OM("BPN")) D
5729	"RTN","IVM PREC8",74, 0)
5730	...S IVMF LD=$$CONVP H($P($G(TE LECOM("BPN ")),$E(HLE CH))),IVMA DFLG=1
5731	"RTN","IVM PREC8",75, 0)
5732	..;Cell P hone Numbe r
5733	"RTN","IVM PREC8",76, 0)
5734	..I IVMXR EF="PID13C ",$D(TELEC OM("ORN")) D
5735	"RTN","IVM PREC8",77, 0)
5736	...S IVMF LD=$$CONVP H($P($G(TE LECOM("ORN ")),$E(HLE CH))),IVMA DFLG=1
5737	"RTN","IVM PREC8",78, 0)
5738	..;Email Address
5739	"RTN","IVM PREC8",79, 0)
5740	..I IVMXR EF="PID13E ",$D(TELEC OM("NET")) D
5741	"RTN","IVM PREC8",80, 0)
5742	...S IVMF LD=$P($G(T ELECOM("NE T")),$E(HL ECH),4)
5743	"RTN","IVM PREC8",81, 0)
5744	...S IVMF LD=$S($$CH KEMAIL(IVM FLD):IVMFL D,1:""),IV MADFLG=1
5745	"RTN","IVM PREC8",82, 0)
5746	.; - file address f ields and quit
5747	"RTN","IVM PREC8",83, 0)
5748	.I IVMADF LG D STORE ^IVMPREC9 Q
5749	"RTN","IVM PREC8",84, 0)
5750	.;
5751	"RTN","IVM PREC8",85, 0)
5752	.; - othe rwise, set IVMFLD to field rec 'd from IV M
5753	"RTN","IVM PREC8",86, 0)
5754	.; for comparison with DHCP field
5755	"RTN","IVM PREC8",87, 0)
5756	.;I (IVMX REF'="PID1 13N")&(IVM XREF'="PID 114N")&($E (IVMXREF,1 ,5)'="PID1 3") S IVMF LD=$G(IVMP ID(+IVMPIE CE))
5757	"RTN","IVM PREC8",88, 0)
5758	.I $E(IVM XREF,1,5)' ="PID13" S IVMFLD=$G (IVMPID(+I VMPIECE))
5759	"RTN","IVM PREC8",89, 0)
5760	.;
5761	"RTN","IVM PREC8",90, 0)
5762	.; - if H L7 date co nvert to F M date and set IVMFL D
5763	"RTN","IVM PREC8",91, 0)
5764	.I IVMXRE F["PID07" S IVMFLD=$ $FMDATE^HL FNC(IVMFLD )
5765	"RTN","IVM PREC8",92, 0)
5766	.;
5767	"RTN","IVM PREC8",93, 0)
5768	.; - if H L7 code co nvert to V istA and s et IVMFLD
5769	"RTN","IVM PREC8",94, 0)
5770	.I IVMXRE F["PID16" D ;Marita l Status
5771	"RTN","IVM PREC8",95, 0)
5772	..S IVMFL D=$S(IVMFL D="D":"DIV ORCED",IVM FLD="M":"M ARRIED",IV MFLD="W":" WIDOWED",I VMFLD="A": "SEPARATED ",IVMFLD=" S":"NEVER MARRIED",I VMFLD="U": "UNKNOWN")
5773	"RTN","IVM PREC8",96, 0)
5774	..S IVMFL D=$O(^DIC( 11,"B",IVM FLD,0))
5775	"RTN","IVM PREC8",97, 0)
5776	.;
5777	"RTN","IVM PREC8",98, 0)
5778	.I IVMXRE F["PID17" S IVMFLD=$ O(^DIC(13, "C",IVMFLD ,0)) ;Rel igion
5779	"RTN","IVM PREC8",99, 0)
5780	.;
5781	"RTN","IVM PREC8",100 ,0)
5782	.I IVMXRE F["PID22" D ;Ethnic ity
5783	"RTN","IVM PREC8",101 ,0)
5784	..S IVMFL D=$$CODE2P TR^DGUTL4( $P($G(IVMP ID(22)),$E (HLECH),4) ,2,2)
5785	"RTN","IVM PREC8",102 ,0)
5786	.;
5787	"RTN","IVM PREC8",103 ,0)
5788	.I IVMXRE F="PID10", '$G(DODSEG ),$D(IVMRA CE) D Q
5789	"RTN","IVM PREC8",104 ,0)
5790	..N XVAL, IVMLST,DHC PLST
5791	"RTN","IVM PREC8",105 ,0)
5792	..S (XVAL ,IVMLST,DH CPLST)=""
5793	"RTN","IVM PREC8",106 ,0)
5794	..F S XV AL=$O(^DPT (DFN,.02," B",XVAL)) Q:XVAL="" S IVMLST= IVMLST_XVA L_U
5795	"RTN","IVM PREC8",107 ,0)
5796	..S XVAL= "" F S XV AL=$O(IVMR ACE(2,XVAL )) Q:XVAL= "" S DHCP LST=DHCPLS T_XVAL_U
5797	"RTN","IVM PREC8",108 ,0)
5798	..Q:IVMLS T=DHCPLST
5799	"RTN","IVM PREC8",109 ,0)
5800	..F XVAL= 1:1:($L(DH CPLST,U)-1 ) S IVMFLD =$P(DHCPLS T,U,XVAL) D
5801	"RTN","IVM PREC8",110 ,0)
5802	...D STOR E^IVMPREC9
5803	"RTN","IVM PREC8",111 ,0)
5804	.;
5805	"RTN","IVM PREC8",112 ,0)
5806	.; - call VADPT rou tine to re turn DHCP demographi cs
5807	"RTN","IVM PREC8",113 ,0)
5808	.D DEM^VA DPT,ADD^VA DPT,OPD^VA DPT
5809	"RTN","IVM PREC8",114 ,0)
5810	.;
5811	"RTN","IVM PREC8",115 ,0)
5812	.; - exec ute code o n the 1 no de and get DHCP fiel d for comp arison
5813	"RTN","IVM PREC8",116 ,0)
5814	.S IVMDHC P="" X:$D( ^IVM(301.9 2,+IVMDEMD A,1)) ^(1) S IVMDHCP =Y
5815	"RTN","IVM PREC8",117 ,0)
5816	.;
5817	"RTN","IVM PREC8",118 ,0)
5818	.; - spec ial logic for phone number pro cessing
5819	"RTN","IVM PREC8",119 ,0)
5820	.; - if d ifferent, then store the actua l value re ceived, th en quit
5821	"RTN","IVM PREC8",120 ,0)
5822	.;
5823	"RTN","IVM PREC8",121 ,0)
5824	.I IVMXRE F="PID13", $D(TELECOM ("PRN")),' $G(DODSEG) D Q
5825	"RTN","IVM PREC8",122 ,0)
5826	..S IVMFL D=$P($G(TE LECOM("PRN ")),$E(HLE CH))
5827	"RTN","IVM PREC8",123 ,0)
5828	..I IVMFL D]"" D
5829	"RTN","IVM PREC8",124 ,0)
5830	...K UPPH N
5831	"RTN","IVM PREC8",125 ,0)
5832	...S COMP PH1=$$CONV PH(IVMFLD) ,COMPPH2=$ $CONVPH(IV MDHCP)
5833	"RTN","IVM PREC8",126 ,0)
5834	...I COMP PH1'=COMPP H2 D STORE ^IVMPREC9 S UPPHN=1
5835	"RTN","IVM PREC8",127 ,0)
5836	.;
5837	"RTN","IVM PREC8",128 ,0)
5838	.; - if f ield from IVM does n ot equal D HCP field - store fo r uploadin g
5839	"RTN","IVM PREC8",129 ,0)
5840	.I IVMFLD ]"",(IVMFL D'=IVMDHCP ) D STORE^ IVMPREC9
5841	"RTN","IVM PREC8",130 ,0)
5842	Q
5843	"RTN","IVM PREC8",131 ,0)
5844	;
5845	"RTN","IVM PREC8",132 ,0)
5846	;
5847	"RTN","IVM PREC8",133 ,0)
5848	ZPD ; - co mpare ZPD segment fi elds with DHCP field s
5849	"RTN","IVM PREC8",134 ,0)
5850	N STFLG
5851	"RTN","IVM PREC8",135 ,0)
5852	S STFLG=0
5853	"RTN","IVM PREC8",136 ,0)
5854	S IVMPIEC E=$E(IVMXR EF,4,5)
5855	"RTN","IVM PREC8",137 ,0)
5856	I IVMXREF ="ZPD09"!( IVMXREF="Z PD31")!(IV MXREF="ZPD 32") Q:$$D ODCK(DFN)
5857	"RTN","IVM PREC8",138 ,0)
5858	I $P(IVMS EG,HLFS,IV MPIECE)]"" D
5859	"RTN","IVM PREC8",139 ,0)
5860	.;
5861	"RTN","IVM PREC8",140 ,0)
5862	.; - set var to HL7 field
5863	"RTN","IVM PREC8",141 ,0)
5864	.S IVMFLD =$P(IVMSEG ,HLFS,IVMP IECE)
5865	"RTN","IVM PREC8",142 ,0)
5866	.;
5867	"RTN","IVM PREC8",143 ,0)
5868	.; - if H L7 name fo rmat conve rt to FM
5869	"RTN","IVM PREC8",144 ,0)
5870	.I (IVMXR EF["ZPD06" )!(IVMXREF ["ZPD07") S IVMFLD=$ $FMNAME^HL FNC(IVMFLD )
5871	"RTN","IVM PREC8",145 ,0)
5872	.;
5873	"RTN","IVM PREC8",146 ,0)
5874	.; - if H L7 date co nvert to F M date
5875	"RTN","IVM PREC8",147 ,0)
5876	.I IVMXRE F["ZPD09"! (IVMXREF[" ZPD13")!(I VMXREF["ZP D32") S IV MFLD=$$FMD ATE^HLFNC( IVMFLD)
5877	"RTN","IVM PREC8",148 ,0)
5878	.;
5879	"RTN","IVM PREC8",149 ,0)
5880	.; - exec ute code o n the 1 no de and get DHCP fiel d
5881	"RTN","IVM PREC8",150 ,0)
5882	.S IVMDHC P="" X:$D( ^IVM(301.9 2,+IVMDEMD A,1)) ^(1) S IVMDHCP =Y
5883	"RTN","IVM PREC8",151 ,0)
5884	.;
5885	"RTN","IVM PREC8",152 ,0)
5886	.; - if f ield from IVM does n ot equal D HCP field - store fo r uploadin g
5887	"RTN","IVM PREC8",153 ,0)
5888	.I IVMFLD ]"",(IVMFL D'=IVMDHCP ) S STFLG= 1 D STORE^ IVMPREC9 Q
5889	"RTN","IVM PREC8",154 ,0)
5890	.I $P(IVM SEG,"^",IV MPIECE)'=" """"" D
5891	"RTN","IVM PREC8",155 ,0)
5892	..I IVMXR EF["ZPD09" D STORE^I VMPREC9
5893	"RTN","IVM PREC8",156 ,0)
5894	..;I IVMX REF["ZPD09 "!(IVMXREF ["ZPD31")! (IVMXREF[" ZPD32") D STORE^IVMP REC9
5895	"RTN","IVM PREC8",157 ,0)
5896	I IVMXREF ["ZPD08",S TFLG,$$AUT ORINC^IVMP REC9(DFN) Q
5897	"RTN","IVM PREC8",158 ,0)
5898	I IVMXREF ["ZPD32",$ $AUTODOD^I VMLDEMD(DF N)
5899	"RTN","IVM PREC8",159 ,0)
5900	Q
5901	"RTN","IVM PREC8",160 ,0)
5902	;
5903	"RTN","IVM PREC8",161 ,0)
5904	;
5905	"RTN","IVM PREC8",162 ,0)
5906	DODCK(DFN) ;this wil l check if Date of D eath infor mation nee ds to be u ploaded or not.
5907	"RTN","IVM PREC8",163 ,0)
5908	;2 requir ements are :
5909	"RTN","IVM PREC8",164 ,0)
5910	; 1. Whe n the DOD is receive d from ESR with a So urce of De ath Notifi cation equ al to "Dea th Certifi cate on fi le and the
5911	"RTN","IVM PREC8",165 ,0)
5912	; Vis tA DOD is null or em pty then V istA will upload the Date of D eath from ESR
5913	"RTN","IVM PREC8",166 ,0)
5914	; 2. Whe n DOD is R eceived fr om ESR and VistA DOD is alread y populate d then Vis ta will ig nore the D OD from ES R and Vist A
5915	"RTN","IVM PREC8",167 ,0)
5916	; wil l not crea te an entr y in the I VM demogra phic uploa d option.
5917	"RTN","IVM PREC8",168 ,0)
5918	;
5919	"RTN","IVM PREC8",169 ,0)
5920	; Inputs: DFN for ^ DPT
5921	"RTN","IVM PREC8",170 ,0)
5922	; IVMXREF ( must be ZP D09, ZPD31 and ZPD32 )
5923	"RTN","IVM PREC8",171 ,0)
5924	; IVMSEG (t he ZPD dat a)
5925	"RTN","IVM PREC8",172 ,0)
5926	; IVMFLD (t he field n umber in ^ DPT(DFN)
5927	"RTN","IVM PREC8",173 ,0)
5928	; IVMPIECE (the piece number of IVMSEG)
5929	"RTN","IVM PREC8",174 ,0)
5930	; IVMDHCP ( the data f rom ^DPT(D FN)
5931	"RTN","IVM PREC8",175 ,0)
5932	;
5933	"RTN","IVM PREC8",176 ,0)
5934	;
5935	"RTN","IVM PREC8",177 ,0)
5936	N DODARRA Y,QUIT
5937	"RTN","IVM PREC8",178 ,0)
5938	;
5939	"RTN","IVM PREC8",179 ,0)
5940	S (CKDEL, QUIT)=0
5941	"RTN","IVM PREC8",180 ,0)
5942	;
5943	"RTN","IVM PREC8",181 ,0)
5944	I $P(IVMS EG,"^",9)= """""" Q 0
5945	"RTN","IVM PREC8",182 ,0)
5946	D GETS^DI Q(2,DFN,". 351:.355", "","DODARR AY")
5947	"RTN","IVM PREC8",183 ,0)
5948	S DOD=DOD ARRAY(2,DF N_",",.351 )
5949	"RTN","IVM PREC8",184 ,0)
5950	I DOD'="" Q 1
5951	"RTN","IVM PREC8",185 ,0)
5952	I $P(IVMS EG,"^",31) =3,DOD="" S QUIT=0 ;Death C ertificate not on Fi le
5953	"RTN","IVM PREC8",186 ,0)
5954	I $P(IVMS EG,"^",31) =3,DOD'="" S QUIT=1
5955	"RTN","IVM PREC8",187 ,0)
5956	;
5957	"RTN","IVM PREC8",188 ,0)
5958	Q QUIT ;
5959	"RTN","IVM PREC8",189 ,0)
5960	;
5961	"RTN","IVM PREC8",190 ,0)
5962	ZTA ; - co mpare ZTA segment fi elds with DHCP field s
5963	"RTN","IVM PREC8",191 ,0)
5964	N COMPPH1 ,COMPPH2,C OUNTRY
5965	"RTN","IVM PREC8",192 ,0)
5966	S IVMPIEC E=$E(IVMXR EF,4,7)
5967	"RTN","IVM PREC8",193 ,0)
5968	I $P(IVMS EG,HLFS,$E (IVMPIECE, 1,2))]"" D
5969	"RTN","IVM PREC8",194 ,0)
5970	.;
5971	"RTN","IVM PREC8",195 ,0)
5972	.; - set var IVMFLD to incomi ng HL7 fie ld
5973	"RTN","IVM PREC8",196 ,0)
5974	.S IVMFLD =$P(IVMSEG ,HLFS,$E(I VMPIECE,1, 2))
5975	"RTN","IVM PREC8",197 ,0)
5976	.;
5977	"RTN","IVM PREC8",198 ,0)
5978	.; - ZTA0 5 as the Z TA address field con taining 5 pieces sep erated by HLECH (~)
5979	"RTN","IVM PREC8",199 ,0)
5980	.I IVMXRE F["ZTA05" D
5981	"RTN","IVM PREC8",200 ,0)
5982	..S IVMAD DR=$P(IVMS EG,HLFS,$E (IVMPIECE, 1,2)) Q:IV MADDR=""
5983	"RTN","IVM PREC8",201 ,0)
5984	..S COUNT RY=$P(IVMA DDR,$E(HLE CH),6)
5985	"RTN","IVM PREC8",202 ,0)
5986	..S FORAD DR=$S(COUN TRY="USA": 0,1:1)
5987	"RTN","IVM PREC8",203 ,0)
5988	..; - get piece of address fi eld, and s et IVMFLD
5989	"RTN","IVM PREC8",204 ,0)
5990	..S IVMPI ECE=$E(IVM PIECE,3,4)
5991	"RTN","IVM PREC8",205 ,0)
5992	..S IVMFL D=$P(IVMAD DR,$E(HLEC H),IVMPIEC E)
5993	"RTN","IVM PREC8",206 ,0)
5994	..I (IVMP IECE=2)!(I VMPIECE=8) S:IVMFLD= "" IVMFLD= "@"
5995	"RTN","IVM PREC8",207 ,0)
5996	..Q:IVMFL D=""
5997	"RTN","IVM PREC8",208 ,0)
5998	..I (IVMP IECE=4)!(I VMPIECE=5) !(IVMPIECE =9) S IVMF LD=$S('FOR ADDR:IVMFL D,1:"") Q: IVMFLD=""
5999	"RTN","IVM PREC8",209 ,0)
6000	..I IVMPI ECE=4 S (I VMTSTPT,IV MFLD)=$O(^ DIC(5,"C", IVMFLD,0))
6001	"RTN","IVM PREC8",210 ,0)
6002	..I IVMPI ECE=5 S X= IVMFLD D Z IPIN^VAFAD DR S IVMFL D=$G(X)
6003	"RTN","IVM PREC8",211 ,0)
6004	..I IVMPI ECE="4F" S IVMFLD=$S (FORADDR:I VMFLD,1:"" ) ;PROVIN CE
6005	"RTN","IVM PREC8",212 ,0)
6006	..I IVMPI ECE="5F" S IVMFLD=$S (FORADDR:I VMFLD,1:"" ) ;POSTAL CODE
6007	"RTN","IVM PREC8",213 ,0)
6008	..I IVMPI ECE=6 S IV MFLD=$$CNT RCONV(COUN TRY) ;COUNTR Y
6009	"RTN","IVM PREC8",214 ,0)
6010	..I IVMPI ECE=9 S IV MFLD=+$O(^ DIC(5,+IVM TSTPT,1,"C ",IVMFLD,0 )) ;COUNT Y
6011	"RTN","IVM PREC8",215 ,0)
6012	.Q:IVMFLD =""
6013	"RTN","IVM PREC8",216 ,0)
6014	.;
6015	"RTN","IVM PREC8",217 ,0)
6016	.; - if H L7 data co nvert to Y /N value
6017	"RTN","IVM PREC8",218 ,0)
6018	.I IVMXRE F["ZTA02" S IVMFLD=$ S(IVMFLD=0 :"N",IVMFL D=1:"Y",1: "")
6019	"RTN","IVM PREC8",219 ,0)
6020	.;
6021	"RTN","IVM PREC8",220 ,0)
6022	.; - if H L7 date co nvert to F M date
6023	"RTN","IVM PREC8",221 ,0)
6024	.I (IVMXR EF["ZTA03" )!(IVMXREF ["ZTA04")! (IVMXREF[" ZTA08") S IVMFLD=$$F MDATE^HLFN C(IVMFLD)
6025	"RTN","IVM PREC8",222 ,0)
6026	.;
6027	"RTN","IVM PREC8",223 ,0)
6028	.; - exec ute code o n the 1 no de and get DHCP fiel d
6029	"RTN","IVM PREC8",224 ,0)
6030	.S IVMDHC P="" X:$D( ^IVM(301.9 2,+IVMDEMD A,1)) ^(1) S IVMDHCP =Y
6031	"RTN","IVM PREC8",225 ,0)
6032	.;
6033	"RTN","IVM PREC8",226 ,0)
6034	.; - spec ial logic for phone number pro cessing
6035	"RTN","IVM PREC8",227 ,0)
6036	.; - if d ifferent, then store the actua l value re ceived, th en quit
6037	"RTN","IVM PREC8",228 ,0)
6038	.I IVMXRE F["ZTA07" D Q
6039	"RTN","IVM PREC8",229 ,0)
6040	..S COMPP H1=$$CONVP H(IVMFLD), COMPPH2=$$ CONVPH(IVM DHCP)
6041	"RTN","IVM PREC8",230 ,0)
6042	..I COMPP H1'=COMPPH 2 D STORE^ IVMPREC9
6043	"RTN","IVM PREC8",231 ,0)
6044	.;
6045	"RTN","IVM PREC8",232 ,0)
6046	.; if fie ld from IV M does not equal DHC P field - store for uploading
6047	"RTN","IVM PREC8",233 ,0)
6048	.I IVMFLD ]"",(IVMFL D'=IVMDHCP ) D STORE^ IVMPREC9
6049	"RTN","IVM PREC8",234 ,0)
6050	.;
6051	"RTN","IVM PREC8",235 ,0)
6052	.I IVMXRE F["ZTA08" D
6053	"RTN","IVM PREC8",236 ,0)
6054	..I IVMFL D]"",(IVMF LD>IVMDHCP ) S UPDAUP G("TA")=1
6055	"RTN","IVM PREC8",237 ,0)
6056	Q
6057	"RTN","IVM PREC8",238 ,0)
6058	;
6059	"RTN","IVM PREC8",239 ,0)
6060	ZGD ; - co mpare ZGD segment fi elds with DHCP field s
6061	"RTN","IVM PREC8",240 ,0)
6062	S IVMADFL G=0
6063	"RTN","IVM PREC8",241 ,0)
6064	S IVMPIEC E=$E(IVMXR EF,4,7)
6065	"RTN","IVM PREC8",242 ,0)
6066	I $P(IVMS EG,HLFS,$E (IVMPIECE, 1,2))]"" D
6067	"RTN","IVM PREC8",243 ,0)
6068	.;
6069	"RTN","IVM PREC8",244 ,0)
6070	.; - set var IVMFLD to incomi ng HL7 fie ld
6071	"RTN","IVM PREC8",245 ,0)
6072	.I 'IVMAD FLG S IVMF LD=$P(IVMS EG,HLFS,IV MPIECE)
6073	"RTN","IVM PREC8",246 ,0)
6074	.;
6075	"RTN","IVM PREC8",247 ,0)
6076	.; - ZGD0 6 as the Z GD address field con taining 5 pieces sep erated by HLECH (~)
6077	"RTN","IVM PREC8",248 ,0)
6078	.I IVMXRE F["ZGD06" D
6079	"RTN","IVM PREC8",249 ,0)
6080	..S IVMAD DR=$P(IVMS EG,HLFS,$E (IVMPIECE, 1,2)),IVMP IECE=$E(IV MPIECE,3)
6081	"RTN","IVM PREC8",250 ,0)
6082	..S IVMFL D=$P(IVMAD DR,$E(HLEC H),IVMPIEC E),IVMADFL G=1
6083	"RTN","IVM PREC8",251 ,0)
6084	..I IVMFL D]"",IVMPI ECE=4 S IV MFLD=$O(^D IC(5,"C",I VMFLD,0))
6085	"RTN","IVM PREC8",252 ,0)
6086	..I IVMFL D]"",IVMPI ECE=5 S X= IVMFLD D Z IPIN^VAFAD DR S IVMFL D=$G(X)
6087	"RTN","IVM PREC8",253 ,0)
6088	.;
6089	"RTN","IVM PREC8",254 ,0)
6090	.; - if H L7 date co nvert to F M date
6091	"RTN","IVM PREC8",255 ,0)
6092	.I IVMXRE F["ZGD08" S IVMFLD=$ $FMDATE^HL FNC(IVMFLD )
6093	"RTN","IVM PREC8",256 ,0)
6094	.;
6095	"RTN","IVM PREC8",257 ,0)
6096	.; - exec ute code o n the 1 no de and get DHCP fiel d
6097	"RTN","IVM PREC8",258 ,0)
6098	.S IVMDHC P="" X:$D( ^IVM(301.9 2,+IVMDEMD A,1)) ^(1) S IVMDHCP =Y
6099	"RTN","IVM PREC8",259 ,0)
6100	.;
6101	"RTN","IVM PREC8",260 ,0)
6102	.; if fie ld from IV M does not equal DHC P field - store for uploading
6103	"RTN","IVM PREC8",261 ,0)
6104	.I IVMFLD ]"",(IVMFL D'=IVMDHCP ) D STORE^ IVMPREC9
6105	"RTN","IVM PREC8",262 ,0)
6106	Q
6107	"RTN","IVM PREC8",263 ,0)
6108	;
6109	"RTN","IVM PREC8",264 ,0)
6110	ZCT ; - co mpare ZCT segment fi elds with DHCP field s
6111	"RTN","IVM PREC8",265 ,0)
6112	N ZCTTYP
6113	"RTN","IVM PREC8",266 ,0)
6114	S IVMADFL G=0
6115	"RTN","IVM PREC8",267 ,0)
6116	S IVMPIEC E=$E(IVMXR EF,4,8)
6117	"RTN","IVM PREC8",268 ,0)
6118	S IVMSEG= $$CLEARF^I VMPRECA(IV MSEG,HLFS)
6119	"RTN","IVM PREC8",269 ,0)
6120	S ZCTTYP= $E(IVMPIEC E,$L(IVMPI ECE)-1,$L( IVMPIECE))
6121	"RTN","IVM PREC8",270 ,0)
6122	Q:$P(IVMS EG,HLFS,2) '=$S(ZCTTY P="K1":1,Z CTTYP="K2" :2,ZCTTYP= "E1":3,ZCT TYP="E2":4 ,ZCTTYP="D 1":5,1:"")
6123	"RTN","IVM PREC8",271 ,0)
6124	I $P(IVMS EG,HLFS,$E (IVMPIECE, 1,2))]"" D
6125	"RTN","IVM PREC8",272 ,0)
6126	.;
6127	"RTN","IVM PREC8",273 ,0)
6128	.; - set var IVMFLD to incomi ng HL7 fie ld
6129	"RTN","IVM PREC8",274 ,0)
6130	.I 'IVMAD FLG S IVMF LD=$P(IVMS EG,HLFS,$E (IVMPIECE, 1,2))
6131	"RTN","IVM PREC8",275 ,0)
6132	.;
6133	"RTN","IVM PREC8",276 ,0)
6134	.; - if H L7 name fo rmat conve rt to FM
6135	"RTN","IVM PREC8",277 ,0)
6136	.I IVMXRE F["ZCT03" S IVMFLD=$ $FMNAME^HL FNC(IVMFLD )
6137	"RTN","IVM PREC8",278 ,0)
6138	.;
6139	"RTN","IVM PREC8",279 ,0)
6140	.; - ZCT0 5 as the Z CT address field con taining 5 pieces sep erated by HLECH (~)
6141	"RTN","IVM PREC8",280 ,0)
6142	.I IVMXRE F["ZCT05" D
6143	"RTN","IVM PREC8",281 ,0)
6144	..S IVMAD DR=$P(IVMS EG,HLFS,$E (IVMPIECE, 1,2)),IVMP IECE=$E(IV MPIECE,3)
6145	"RTN","IVM PREC8",282 ,0)
6146	..S IVMFL D=$P(IVMAD DR,$E(HLEC H),IVMPIEC E),IVMADFL G=1
6147	"RTN","IVM PREC8",283 ,0)
6148	..I IVMFL D]"",IVMPI ECE=4 S IV MFLD=$O(^D IC(5,"C",I VMFLD,0))
6149	"RTN","IVM PREC8",284 ,0)
6150	..I IVMFL D]"",IVMPI ECE=5 S X= IVMFLD D Z IPIN^VAFAD DR S IVMFL D=$G(X)
6151	"RTN","IVM PREC8",285 ,0)
6152	.;
6153	"RTN","IVM PREC8",286 ,0)
6154	.I IVMADF LG D STORE ^IVMPREC9 Q
6155	"RTN","IVM PREC8",287 ,0)
6156	.; - if H L7 date co nvert to F M date
6157	"RTN","IVM PREC8",288 ,0)
6158	.I IVMXRE F["ZCT10" S IVMFLD=$ $FMDATE^HL FNC(IVMFLD )
6159	"RTN","IVM PREC8",289 ,0)
6160	.;
6161	"RTN","IVM PREC8",290 ,0)
6162	.; - exec ute code o n the 1 no de and get DHCP fiel d
6163	"RTN","IVM PREC8",291 ,0)
6164	.S IVMDHC P="" X:$D( ^IVM(301.9 2,+IVMDEMD A,1)) ^(1) S IVMDHCP =Y
6165	"RTN","IVM PREC8",292 ,0)
6166	.;
6167	"RTN","IVM PREC8",293 ,0)
6168	.; if fie ld from IV M does not equal DHC P field - store for uploading
6169	"RTN","IVM PREC8",294 ,0)
6170	.I IVMFLD ]"",(IVMFL D'=IVMDHCP ) D STORE^ IVMPREC9
6171	"RTN","IVM PREC8",295 ,0)
6172	.;
6173	"RTN","IVM PREC8",296 ,0)
6174	.I IVMXRE F["ZCT10" D
6175	"RTN","IVM PREC8",297 ,0)
6176	..I IVMFL D]"",(IVMF LD>IVMDHCP ) S UPDAUP G(ZCTTYP)= 1
6177	"RTN","IVM PREC8",298 ,0)
6178	Q
6179	"RTN","IVM PREC8",299 ,0)
6180	;
6181	"RTN","IVM PREC8",300 ,0)
6182	ZEM ; - co mpare ZEM segment fi elds with DHCP field s
6183	"RTN","IVM PREC8",301 ,0)
6184	S IVMADFL G=0
6185	"RTN","IVM PREC8",302 ,0)
6186	S IVMPIEC E=$E(IVMXR EF,4,7)
6187	"RTN","IVM PREC8",303 ,0)
6188	S IVMSEG= $$CLEARF^I VMPRECA(IV MSEG,HLFS)
6189	"RTN","IVM PREC8",304 ,0)
6190	Q:$P(IVMS EG,HLFS,2) '=$S($E(IV MXREF,$L(I VMXREF))=" S":2,1:1)
6191	"RTN","IVM PREC8",305 ,0)
6192	I $P(IVMS EG,HLFS,$E (IVMPIECE, 1,2))]"" D
6193	"RTN","IVM PREC8",306 ,0)
6194	.;
6195	"RTN","IVM PREC8",307 ,0)
6196	.; - set var IVMFLD to incomi ng HL7 fie ld
6197	"RTN","IVM PREC8",308 ,0)
6198	.I 'IVMAD FLG S IVMF LD=$P(IVMS EG,HLFS,$E (IVMPIECE, 1,2))
6199	"RTN","IVM PREC8",309 ,0)
6200	.;
6201	"RTN","IVM PREC8",310 ,0)
6202	.; - ZEM0 6 as the Z EM address field con taining 5 pieces sep erated by HLECH (~)
6203	"RTN","IVM PREC8",311 ,0)
6204	.I IVMXRE F["ZEM06" D
6205	"RTN","IVM PREC8",312 ,0)
6206	..S IVMAD DR=$P(IVMS EG,HLFS,$E (IVMPIECE, 1,2)),IVMP IECE=$E(IV MPIECE,3)
6207	"RTN","IVM PREC8",313 ,0)
6208	..S IVMFL D=$P(IVMAD DR,$E(HLEC H),IVMPIEC E) ;,IV MADFLG=1
6209	"RTN","IVM PREC8",314 ,0)
6210	..I IVMFL D]"",IVMPI ECE=4 S IV MFLD=$O(^D IC(5,"C",I VMFLD,0))
6211	"RTN","IVM PREC8",315 ,0)
6212	..I IVMFL D]"",IVMPI ECE=5 S X= IVMFLD D Z IPIN^VAFAD DR S IVMFL D=$G(X)
6213	"RTN","IVM PREC8",316 ,0)
6214	.;
6215	"RTN","IVM PREC8",317 ,0)
6216	.; - if H L7 date co nvert to F M date
6217	"RTN","IVM PREC8",318 ,0)
6218	.I IVMXRE F["ZEM09" S IVMFLD=$ $FMDATE^HL FNC(IVMFLD )
6219	"RTN","IVM PREC8",319 ,0)
6220	.;
6221	"RTN","IVM PREC8",320 ,0)
6222	.; - exec ute code o n the 1 no de and get DHCP fiel d
6223	"RTN","IVM PREC8",321 ,0)
6224	.S IVMDHC P="" X:$D( ^IVM(301.9 2,+IVMDEMD A,1)) ^(1) S IVMDHCP =Y
6225	"RTN","IVM PREC8",322 ,0)
6226	.;
6227	"RTN","IVM PREC8",323 ,0)
6228	.; if fie ld from IV M does not equal DHC P field - store for uploading
6229	"RTN","IVM PREC8",324 ,0)
6230	.I $E(IVM XREF,1,6)= "ZEM062",I VMFLD'=IVM DHCP S ZEM ADRUP(IVMX REF)=1 D S TORE^IVMPR EC9 Q
6231	"RTN","IVM PREC8",325 ,0)
6232	.I IVMFLD ]"",(IVMFL D'=IVMDHCP ) D STORE^ IVMPREC9
6233	"RTN","IVM PREC8",326 ,0)
6234	Q
6235	"RTN","IVM PREC8",327 ,0)
6236	;
6237	"RTN","IVM PREC8",328 ,0)
6238	RF1 ; - co mpare RF1 segment fi elds with DHCP field s
6239	"RTN","IVM PREC8",329 ,0)
6240	S IVMPIEC E=$E(IVMXR EF,4),IVMA DFLG=1,RF1 TYPE=$P(IV MSEG,HLFS, 3)
6241	"RTN","IVM PREC8",330 ,0)
6242	;As per r equirement s, delete the commun ication da ta (Email, Cell and Pager) if it is not received i n Z05.
6243	"RTN","IVM PREC8",331 ,0)
6244	;Hence, r emove it f rom EPCDEL (deletion array) if Data exis t in Z05. Comm. fiel ds contain ed in EPCD EL will be deleted a fter updat ing all in coming com munication data.
6245	"RTN","IVM PREC8",332 ,0)
6246	K EPCDEL( RF1TYPE)
6247	"RTN","IVM PREC8",333 ,0)
6248	;if RF1 f ield is SE Q6, then p arse subco mponents
6249	"RTN","IVM PREC8",334 ,0)
6250	I RF1TYPE ="SAD",((I VMXREF="RF 161")!(IVM XREF="RF16 2")!(IVMXR EF="RF171" )) D RF1PR OC
6251	"RTN","IVM PREC8",335 ,0)
6252	;I RF1TYP E="CAD",(( IVMXREF="R F161CA")!( IVMXREF="R F171CA")) D RF1PROC
6253	"RTN","IVM PREC8",336 ,0)
6254	I RF1TYPE ="CPH",((I VMXREF="RF 161C")!(IV MXREF="RF1 62C")!(IVM XREF="RF17 1C")) D RF 1PROC
6255	"RTN","IVM PREC8",337 ,0)
6256	I RF1TYPE ="PNO",((I VMXREF="RF 161B")!(IV MXREF="RF1 62B")!(IVM XREF="RF17 1B")) D RF 1PROC
6257	"RTN","IVM PREC8",338 ,0)
6258	I RF1TYPE ="EAD",((I VMXREF="RF 161E")!(IV MXREF="RF1 62E")!(IVM XREF="RF17 1E")) D RF 1PROC
6259	"RTN","IVM PREC8",339 ,0)
6260	I RF1TYPE ="PHH",((I VMXREF="RF 161P")!(IV MXREF="RF1 62P")!(IVM XREF="RF17 1P")) D RF 1PROC ;Added for IVM2152
6261	"RTN","IVM PREC8",340 ,0)
6262	I '$$RF1C HK^IVMPREC 6(IVMRTN,I VMDA),IVMX REF="RF171 P" D ;Las t RF1
6263	"RTN","IVM PREC8",341 ,0)
6264	. I $$AUT OEPC^IVMPR EC9(DFN,.U PDEPC)
6265	"RTN","IVM PREC8",342 ,0)
6266	. N NOUPD T,NOPHUP S (NOUPDT,N OPHUP)=0 ;Added fo r IVM215 2
6267	"RTN","IVM PREC8",343 ,0)
6268	. I 'UPDE PC("SAD") S NOUPDT=1
6269	"RTN","IVM PREC8",344 ,0)
6270	. ;Set th e NOPHUP f lag = 1 if Home Phon e Change D t/Tm not m ore recent , or
6271	"RTN","IVM PREC8",345 ,0)
6272	. ;if Hom e Phone Ch ange Dt/Tm more rece nt, but ph one # the same
6273	"RTN","IVM PREC8",346 ,0)
6274	. ;Added for IVM2 152
6275	"RTN","IVM PREC8",347 ,0)
6276	. ; IVM2 .0167 - M ake Home p hone recor ds auto-up load to Pa tient File
6277	"RTN","IVM PREC8",348 ,0)
6278	. ; Alway s keep NOP HUP = 0 so Home phon e number d ata is not handled h ere
6279	"RTN","IVM PREC8",349 ,0)
6280	. ;I 'UPD EPC("PHH") S NOPHUP= 1
6281	"RTN","IVM PREC8",350 ,0)
6282	. ;I UPDE PC("PHH"), '$G(UPPHN) S NOPHUP= 1
6283	"RTN","IVM PREC8",351 ,0)
6284	. K UPPHN
6285	"RTN","IVM PREC8",352 ,0)
6286	. I $$AUT OADDR^IVML DEM6(DFN,1 ,NOUPDT,NO PHUP)
6287	"RTN","IVM PREC8",353 ,0)
6288	Q
6289	"RTN","IVM PREC8",354 ,0)
6290	;
6291	"RTN","IVM PREC8",355 ,0)
6292	RF1PROC ;
6293	"RTN","IVM PREC8",356 ,0)
6294	N IVMEPC
6295	"RTN","IVM PREC8",357 ,0)
6296	I $P(IVMS EG,HLFS,IV MPIECE)]"" D
6297	"RTN","IVM PREC8",358 ,0)
6298	.;if RF1 field is S EQ6, then parse subc omponents
6299	"RTN","IVM PREC8",359 ,0)
6300	.I IVMXRE F["RF16" D Q
6301	"RTN","IVM PREC8",360 ,0)
6302	..;- get data conta ining 4 pi eces seper ated by HL ECH (~)
6303	"RTN","IVM PREC8",361 ,0)
6304	..S IVMRF DAT=$P(IVM SEG,HLFS,6 )
6305	"RTN","IVM PREC8",362 ,0)
6306	..S IVMPI ECE=$E(IVM XREF,5),IV MFLD=$P(IV MRFDAT,"~" ,IVMPIECE)
6307	"RTN","IVM PREC8",363 ,0)
6308	..;get 6t h characte r of IVMXR EF to dete rmine if v alue is fo r Address
6309	"RTN","IVM PREC8",364 ,0)
6310	..;OR Ema il, Cell a nd Pager
6311	"RTN","IVM PREC8",365 ,0)
6312	..S IVMEP C=$E(IVMXR EF,6)
6313	"RTN","IVM PREC8",366 ,0)
6314	..;Conver t Change S ource for Address, E mail, Cell and Pager
6315	"RTN","IVM PREC8",367 ,0)
6316	..I IVMPI ECE=2 S IV MFLD=$S(IV MEPC'="":$ $EPCSRCC(I VMFLD),1:$ $ADDRCNV(I VMFLD))
6317	"RTN","IVM PREC8",368 ,0)
6318	..Q:IVMFL D=""
6319	"RTN","IVM PREC8",369 ,0)
6320	..D STORE ^IVMPREC9
6321	"RTN","IVM PREC8",370 ,0)
6322	.I IVMXRE F["RF17" D Q
6323	"RTN","IVM PREC8",371 ,0)
6324	..;get ad dress/tele comm chang e date/tm field
6325	"RTN","IVM PREC8",372 ,0)
6326	..S IVMFL D=$$FMDATE ^HLFNC($P( IVMSEG,HLF S,7))
6327	"RTN","IVM PREC8",373 ,0)
6328	..Q:IVMFL D=""
6329	"RTN","IVM PREC8",374 ,0)
6330	..D STORE ^IVMPREC9
6331	"RTN","IVM PREC8",375 ,0)
6332	..;
6333	"RTN","IVM PREC8",376 ,0)
6334	..;I RF1T YPE="CAD", $P($G(ADDR ESS("CA")) ,HLFS)]"" D Q
6335	"RTN","IVM PREC8",377 ,0)
6336	..;.; - e xecute cod e on the 1 node and get DHCP f ield
6337	"RTN","IVM PREC8",378 ,0)
6338	..;.S IVM DHCP="" X: $D(^IVM(30 1.92,+IVMD EMDA,1)) ^ (1) S IVMD HCP=Y
6339	"RTN","IVM PREC8",379 ,0)
6340	..;.I IVM FLD]"",(IV MFLD>IVMDH CP) S UPDA UPG("CA")= 1
6341	"RTN","IVM PREC8",380 ,0)
6342	..;
6343	"RTN","IVM PREC8",381 ,0)
6344	..; check for auto- upload
6345	"RTN","IVM PREC8",382 ,0)
6346	..S IVMDH CP=$S(RF1T YPE="SAD": $P($G(^DPT (DFN,.11)) ,HLFS,13), RF1TYPE="C PH":$P($G( ^DPT(DFN,. 13)),HLFS, 9),RF1TYPE ="PNO":$P( $G(^DPT(DF N,.13)),HL FS,12),RF1 TYPE="EAD" :$P($G(^DP T(DFN,.13) ),HLFS,6), 1:"")
6347	"RTN","IVM PREC8",383 ,0)
6348	..I IVMDH CP="" S IV MDHCP=$S(R F1TYPE="PH H":$P($G(^ DPT(DFN,.1 32)),HLFS, 1),1:"") ;Added for IVM2 152
6349	"RTN","IVM PREC8",384 ,0)
6350	..I IVMFL D]"",(IVMF LD>IVMDHCP ) D
6351	"RTN","IVM PREC8",385 ,0)
6352	...S UPDE PC(RF1TYPE )=$G(EPCFA RY(RF1TYPE ))
6353	"RTN","IVM PREC8",386 ,0)
6354	...I RF1T YPE="SAD" S UPDEPC(" SAD")=1
6355	"RTN","IVM PREC8",387 ,0)
6356	...; IVM* 2.0*167 - Make Home phone reco rds auto-u pload to P atient Fil e
6357	"RTN","IVM PREC8",388 ,0)
6358	...; Keep UPDEPC("P HH") value as Home p hone recor d IENs of #301.92 fi le
6359	"RTN","IVM PREC8",389 ,0)
6360	...;I RF1 TYPE="PHH" S UPDEPC( "PHH")=1 ; Added f or IVM21 52
6361	"RTN","IVM PREC8",390 ,0)
6362	Q
6363	"RTN","IVM PREC8",391 ,0)
6364	ADDRCNV(AD DRSRC) ;co nvert Addr ess Source from HL7 to DHCP fo rmat
6365	"RTN","IVM PREC8",392 ,0)
6366	;
6367	"RTN","IVM PREC8",393 ,0)
6368	Q:$G(ADDR SRC)']"" " "
6369	"RTN","IVM PREC8",394 ,0)
6370	Q:ADDRSRC ="USVAHEC" "HEC"
6371	"RTN","IVM PREC8",395 ,0)
6372	Q:ADDRSRC ="USVAMC" "VAMC"
6373	"RTN","IVM PREC8",396 ,0)
6374	Q:ADDRSRC ="USVAHBSC " "HBSC"
6375	"RTN","IVM PREC8",397 ,0)
6376	Q:ADDRSRC ="USNCOA" "NCOA"
6377	"RTN","IVM PREC8",398 ,0)
6378	Q:ADDRSRC ="USVABVA" "BVA"
6379	"RTN","IVM PREC8",399 ,0)
6380	Q:ADDRSRC ="USVAINS" "VAINS"
6381	"RTN","IVM PREC8",400 ,0)
6382	Q:ADDRSRC ="USPS" "U SPS"
6383	"RTN","IVM PREC8",401 ,0)
6384	Q:ADDRSRC ="LACS" "L ACS"
6385	"RTN","IVM PREC8",402 ,0)
6386	Q:ADDRSRC ="USVOA" " VOA"
6387	"RTN","IVM PREC8",403 ,0)
6388	Q ""
6389	"RTN","IVM PREC8",404 ,0)
6390	EPCSRCC(EP CSRC) ;Con vert Email , Cell, Pa ger Change Source fr om HL7 to DHCP
6391	"RTN","IVM PREC8",405 ,0)
6392	;
6393	"RTN","IVM PREC8",406 ,0)
6394	Q:$G(EPCS RC)']"" ""
6395	"RTN","IVM PREC8",407 ,0)
6396	Q:EPCSRC= "USVAHEC" "HEC"
6397	"RTN","IVM PREC8",408 ,0)
6398	Q:EPCSRC= "USVAMC" " VAMC"
6399	"RTN","IVM PREC8",409 ,0)
6400	Q:EPCSRC= "USVAHBSC" "HBSC"
6401	"RTN","IVM PREC8",410 ,0)
6402	Q ""
6403	"RTN","IVM PREC8",411 ,0)
6404	BAICONV(BA ISRC) ;Con vert Bad a ddress sou rce from H L7 to DHCP format
6405	"RTN","IVM PREC8",412 ,0)
6406	Q:$G(BAIS RC)']"" ""
6407	"RTN","IVM PREC8",413 ,0)
6408	Q:BAISRC= "VAB1" 1
6409	"RTN","IVM PREC8",414 ,0)
6410	Q:BAISRC= "VAB2" 2
6411	"RTN","IVM PREC8",415 ,0)
6412	Q:BAISRC= "VAB3" 3
6413	"RTN","IVM PREC8",416 ,0)
6414	Q:BAISRC= "VAB4" 4
6415	"RTN","IVM PREC8",417 ,0)
6416	Q ""
6417	"RTN","IVM PREC8",418 ,0)
6418	CONVPH(PH) ;remove s pecial cha rs/spaces from Phone number
6419	"RTN","IVM PREC8",419 ,0)
6420	;*168 Che ck format, quit if O K else str ip and ret urn if not 10 numeri c
6421	"RTN","IVM PREC8",420 ,0)
6422	;Format i f 10 numer ic.
6423	"RTN","IVM PREC8",421 ,0)
6424	Q:PH?1"(" .3N.1")".3 N.1"-".4N PH
6425	"RTN","IVM PREC8",422 ,0)
6426	S PH=$TR( PH," )(/#\ -","")
6427	"RTN","IVM PREC8",423 ,0)
6428	Q:PH'?10N PH
6429	"RTN","IVM PREC8",424 ,0)
6430	Q "("_$E( PH,1,3)_") "_$E(PH,4, 6)_"-"_$E( PH,7,10)
6431	"RTN","IVM PREC8",425 ,0)
6432	;
6433	"RTN","IVM PREC8",426 ,0)
6434	CNTRCONV(C OUNTRY) ;C heck if va lid countr y
6435	"RTN","IVM PREC8",427 ,0)
6436	I COUNTRY ="" Q 0
6437	"RTN","IVM PREC8",428 ,0)
6438	Q $O(^HL( 779.004,"B ",COUNTRY, ""))
6439	"RTN","IVM PREC8",429 ,0)
6440	CHKEMAIL(E MAIL) ;Che ck for Val id Email
6441	"RTN","IVM PREC8",430 ,0)
6442	I $G(EMAI L)="" Q 0
6443	"RTN","IVM PREC8",431 ,0)
6444	I '(EMAIL ?1.E1"@"1. E1"."1.E) Q 0
6445	"RTN","IVM PREC8",432 ,0)
6446	Q 1
6447	"RTN","IVM PREC9")
6448	0^4^B75404 695
6449	"RTN","IVM PREC9",1,0 )
6450	IVMPREC9 ; ALB/KCL,BR M,CKN,TDM, KUM - PROC ESS INCOMI NG (Z05 EV ENT TYPE) HL7 MESSAG ES (CON'T) ;09-05-20 17 10:03am
6451	"RTN","IVM PREC9",2,0 )
6452	;;2.0;INC OME VERIFI CATION MAT CH;34,58 ,115,121,1 51,159,167 ; 21-OCT -94;Build 39
6453	"RTN","IVM PREC9",3,0 )
6454	;Per VA D irective 6 402, this routine sh ould not b e modified .
6455	"RTN","IVM PREC9",4,0 )
6456	;
6457	"RTN","IVM PREC9",5,0 )
6458	;
6459	"RTN","IVM PREC9",6,0 )
6460	;
6461	"RTN","IVM PREC9",7,0 )
6462	STORE ; - store HL7 fields tha t have a d ifferent v alue than DHCP field s in
6463	"RTN","IVM PREC9",8,0 )
6464	; the I VM Patient (#301.5) file (#301 .511) mult iple for u ploading
6465	"RTN","IVM PREC9",9,0 )
6466	;
6467	"RTN","IVM PREC9",10, 0)
6468	S:$D(AUPF ARY(IVMDEM DA)) UPDAU P(IVMDEMDA )=""
6469	"RTN","IVM PREC9",11, 0)
6470	G:IVMFLG STORE2
6471	"RTN","IVM PREC9",12, 0)
6472	S X=$$IEN ^IVMUFNC4( "PID")
6473	"RTN","IVM PREC9",13, 0)
6474	;
6475	"RTN","IVM PREC9",14, 0)
6476	K DIC("DR ")
6477	"RTN","IVM PREC9",15, 0)
6478	S DA(1)=I VM3015
6479	"RTN","IVM PREC9",16, 0)
6480	I $G(^IVM (301.5,DA( 1),"IN",0) )']"" S ^( 0)="^301.5 01PA^^"
6481	"RTN","IVM PREC9",17, 0)
6482	S DIC="^I VM(301.5," _DA(1)_"," "IN"",",DI C(0)="L",D LAYGO=301. 501
6483	"RTN","IVM PREC9",18, 0)
6484	K DD,DO D FILE^DICN
6485	"RTN","IVM PREC9",19, 0)
6486	K DIC,DLA YGO,X,Y
6487	"RTN","IVM PREC9",20, 0)
6488	;
6489	"RTN","IVM PREC9",21, 0)
6490	; - build mail mess age if SUP RESS DEMOG RAPHIC NOT IFICATION field is
6491	"RTN","IVM PREC9",22, 0)
6492	; not s et in the IVM Site P arameter ( #301.9) fi le
6493	"RTN","IVM PREC9",23, 0)
6494	;
6495	"RTN","IVM PREC9",24, 0)
6496	I '$P($G( ^IVM(301.9 ,1,0)),"^" ,5),'IVMAD FLG D DEMB ULL^IVMPRE C6
6497	"RTN","IVM PREC9",25, 0)
6498	;
6499	"RTN","IVM PREC9",26, 0)
6500	; - set f lag in ord er to not repeat STO RE tag for one msg
6501	"RTN","IVM PREC9",27, 0)
6502	S IVMFLG= 1
6503	"RTN","IVM PREC9",28, 0)
6504	;
6505	"RTN","IVM PREC9",29, 0)
6506	S DA(2)=D A(1)
6507	"RTN","IVM PREC9",30, 0)
6508	S DA(1)=$ P(^IVM(301 .5,DA(1)," IN",0),"^" ,3)
6509	"RTN","IVM PREC9",31, 0)
6510	;
6511	"RTN","IVM PREC9",32, 0)
6512	STORE2 ;
6513	"RTN","IVM PREC9",33, 0)
6514	; - X as the record in the IV M Demo Upl oad Fields (#301.92) file
6515	"RTN","IVM PREC9",34, 0)
6516	S X=+IVMD EMDA
6517	"RTN","IVM PREC9",35, 0)
6518	I $G(^IVM (301.5,DA( 2),"IN",DA (1),"DEM", 0))']"" S ^(0)="^301 .511PA^^"
6519	"RTN","IVM PREC9",36, 0)
6520	S DIC="^I VM(301.5," _DA(2)_"," "IN"",DA(1 ),""DEM"", ",DIC(0)=" L"
6521	"RTN","IVM PREC9",37, 0)
6522	S DIC("DR ")=".02/// /^S X=IVMF LD",DLAYGO =301.511
6523	"RTN","IVM PREC9",38, 0)
6524	K DD,DO D FILE^DICN
6525	"RTN","IVM PREC9",39, 0)
6526	K DIC,DLA YGO,X,Y
6527	"RTN","IVM PREC9",40, 0)
6528	;
6529	"RTN","IVM PREC9",41, 0)
6530	Q
6531	"RTN","IVM PREC9",42, 0)
6532	;
6533	"RTN","IVM PREC9",43, 0)
6534	;
6535	"RTN","IVM PREC9",44, 0)
6536	LOOK ; Fin d the curr ent DHCP f ield value .
6537	"RTN","IVM PREC9",45, 0)
6538	; Input: DR -- Field nu mber of th e field in file #2
6539	"RTN","IVM PREC9",46, 0)
6540	; DFN -- Pointer to the pat ient in fi le #2
6541	"RTN","IVM PREC9",47, 0)
6542	; Output : Y -- Internal value of field
6543	"RTN","IVM PREC9",48, 0)
6544	;
6545	"RTN","IVM PREC9",49, 0)
6546	N IVMOUTT Y,I
6547	"RTN","IVM PREC9",50, 0)
6548	;S DIC="^ DPT(",DA=D FN,DIQ="IV M",DIQ(0)= "I" D EN^D IQ1
6549	"RTN","IVM PREC9",51, 0)
6550	S DIQ(0)= $S($G(DIQ( 0))="":"I" ,$G(DIQ(0) )="E":"E", 1:"I")
6551	"RTN","IVM PREC9",52, 0)
6552	S IVMOUTT Y=DIQ(0)
6553	"RTN","IVM PREC9",53, 0)
6554	S DIC="^D PT(",DA=DF N,DIQ="IVM " D EN^DIQ 1
6555	"RTN","IVM PREC9",54, 0)
6556	;S Y=$G(I VM(2,DFN,D R,"I"))
6557	"RTN","IVM PREC9",55, 0)
6558	S Y=$G(IV M(2,DFN,DR ,IVMOUTTY) )
6559	"RTN","IVM PREC9",56, 0)
6560	K DIC,DIQ ,DR,IVM
6561	"RTN","IVM PREC9",57, 0)
6562	Q
6563	"RTN","IVM PREC9",58, 0)
6564	AUTOEPC(DF N,UPDEPC) ;
6565	"RTN","IVM PREC9",59, 0)
6566	; this fu nctionalit y is copie d from IVM LDEM6 and modified t o allow
6567	"RTN","IVM PREC9",60, 0)
6568	; an auto mated uplo ad of pati ent commun ications i nformation
6569	"RTN","IVM PREC9",61, 0)
6570	; Input: DFN - as pati ent IEN
6571	"RTN","IVM PREC9",62, 0)
6572	; UPDEPC - array c ontains fl ag for upd ate/noupda te for all
6573	"RTN","IVM PREC9",63, 0)
6574	; communi cation typ es.
6575	"RTN","IVM PREC9",64, 0)
6576	; Output: IVMFLAG - 1 if co mmunicatio ns fields updated
6577	"RTN","IVM PREC9",65, 0)
6578	; 0 if co mmunicatio ns fields not update d
6579	"RTN","IVM PREC9",66, 0)
6580	;
6581	"RTN","IVM PREC9",67, 0)
6582	N IVMFLAG ,IVMI,IVMJ ,IVMNODE,I VMPTR,Y,UP DT,IVMCVAL ,IVMCFLD,S ITEFLD,DFL G,CTYP,UPD T
6583	"RTN","IVM PREC9",68, 0)
6584	S IVMFLAG =0 ;initi alize flag s
6585	"RTN","IVM PREC9",69, 0)
6586	; - check for requi red parame ters
6587	"RTN","IVM PREC9",70, 0)
6588	Q:'$G(DFN ) IVMFLAG
6589	"RTN","IVM PREC9",71, 0)
6590	S IVMDA2= $G(IVM3015 )
6591	"RTN","IVM PREC9",72, 0)
6592	Q:'$G(IVM DA2) IVMFL AG
6593	"RTN","IVM PREC9",73, 0)
6594	S IVMDA1= $O(^HL(771 .3,"B","PI D",""))
6595	"RTN","IVM PREC9",74, 0)
6596	S IVMDA1= $O(^IVM(30 1.5,IVMDA2 ,"IN","B", IVMDA1,"") ,-1)
6597	"RTN","IVM PREC9",75, 0)
6598	Q:'IVMDA1 IVMFLAG
6599	"RTN","IVM PREC9",76, 0)
6600	;
6601	"RTN","IVM PREC9",77, 0)
6602	S IVMI=0 F S IVMI= $O(^IVM(30 1.92,"AD", IVMI)) Q:I VMI']"" D
6603	"RTN","IVM PREC9",78, 0)
6604	.S IVMJ=0 F S IVMJ =$O(^IVM(3 01.5,IVMDA 2,"IN",IVM DA1,"DEM", "B",IVMI,I VMJ)) Q:IV MJ']"" D
6605	"RTN","IVM PREC9",79, 0)
6606	..S (UPDT ,DFLG)=0
6607	"RTN","IVM PREC9",80, 0)
6608	..; - che ck for dat a node in (#301.511) sub-file
6609	"RTN","IVM PREC9",81, 0)
6610	..S IVMNO DE=$G(^IVM (301.5,IVM DA2,"IN",I VMDA1,"DEM ",IVMJ,0))
6611	"RTN","IVM PREC9",82, 0)
6612	..I ('+IV MNODE)!($P (IVMNODE," ^",2)']"") Q
6613	"RTN","IVM PREC9",83, 0)
6614	..;Check if fields needs to b e updated for partic ular comm. Type.
6615	"RTN","IVM PREC9",84, 0)
6616	..S CTYP= 0 F S CTY P=$O(UPDEP C(CTYP)) Q :CTYP=""!U PDT D
6617	"RTN","IVM PREC9",85, 0)
6618	...I ("^" _$G(UPDEPC (CTYP))_"^ ")[("^"_+I VMNODE_"^" ) S UPDT=1
6619	"RTN","IVM PREC9",86, 0)
6620	..S IVMCF LD=$P($G(^ IVM(301.92 ,+IVMNODE, 0)),"^",5) ,IVMCVAL=$ P(IVMNODE, "^",2)
6621	"RTN","IVM PREC9",87, 0)
6622	..; - loa d communic ations fie lds rec'd from IVM i nto DHCP ( #2) file
6623	"RTN","IVM PREC9",88, 0)
6624	..I UPDT D UPLOAD^I VMLDEM6(+D FN,IVMCFLD ,IVMCVAL) S IVMFLAG= 1
6625	"RTN","IVM PREC9",89, 0)
6626	..; delet e inaccura te Addr Ch ange Site data if So urce is no t VAMC
6627	"RTN","IVM PREC9",90, 0)
6628	..; IVM2 .0167 - M ake Home p hone recor ds auto-up load to Pa tient File
6629	"RTN","IVM PREC9",91, 0)
6630	..;I UPDT ,((IVMCFLD =.1311)!(I VMCFLD=.13 13)!(IVMCF LD=.137)) D
6631	"RTN","IVM PREC9",92, 0)
6632	..I UPDT, ((IVMCFLD= .1311)!(IV MCFLD=.131 3)!(IVMCFL D=.137)!(I VMCFLD=.13 22)) D
6633	"RTN","IVM PREC9",93, 0)
6634	...I IVMC VAL="VAMC" Q
6635	"RTN","IVM PREC9",94, 0)
6636	...; IVM* 2.0*167 - Make Home phone reco rds auto-u pload to P atient Fil e
6637	"RTN","IVM PREC9",95, 0)
6638	...; S SI TEFLD=$S(I VMCFLD=.13 11:.13111, IVMCFLD=.1 313:.1314, IVMCFLD=.1 37:.138)
6639	"RTN","IVM PREC9",96, 0)
6640	...S SITE FLD=$S(IVM CFLD=.1311 :.13111,IV MCFLD=.131 3:.1314,IV MCFLD=.137 :.138,IVMC FLD=.1322: .1323)
6641	"RTN","IVM PREC9",97, 0)
6642	...S FDA( 2,+DFN_"," ,SITEFLD)= "@" D UPDA TE^DIE("E" ,"FDA")
6643	"RTN","IVM PREC9",98, 0)
6644	..; - rem ove entry only for E mail, Cell , Home pho ne and Pag er from (# 301.511) s ub-file
6645	"RTN","IVM PREC9",99, 0)
6646	..S CTYP= 0 F S CTY P=$O(EPCFA RY(CTYP)) Q:CTYP=""! DFLG D
6647	"RTN","IVM PREC9",100 ,0)
6648	...I ("^" _$G(EPCFAR Y(CTYP))_" ^")[("^"_+ IVMNODE_"^ ") S DFLG= 1
6649	"RTN","IVM PREC9",101 ,0)
6650	..I DFLG D DELENT^I VMLDEMU(IV MDA2,IVMDA 1,IVMJ)
6651	"RTN","IVM PREC9",102 ,0)
6652	;Delete a ll communi cation dat a (Email, Cell phone , Pager, H ome phone) if they a re not rec eived in Z 05.
6653	"RTN","IVM PREC9",103 ,0)
6654	I $D(EPCD EL) D
6655	"RTN","IVM PREC9",104 ,0)
6656	. N CTYPE ,DIE,DR,DA ,CNTR,VAL
6657	"RTN","IVM PREC9",105 ,0)
6658	. S DR="" ,CNTR=0,VA L="@"
6659	"RTN","IVM PREC9",106 ,0)
6660	. S CTYPE ="" F S C TYPE=$O(EP CDEL(CTYPE )) Q:CTYPE ="" D
6661	"RTN","IVM PREC9",107 ,0)
6662	. . F I=1 :1:$L(EPCD EL(CTYPE), "^") S CNT R=CNTR+1,$ P(DR,";",C NTR)=$P(EP CDEL(CTYPE ),"^",I)_" ////^S X=V AL"
6663	"RTN","IVM PREC9",108 ,0)
6664	. S DIE=" ^DPT(",DA= DFN
6665	"RTN","IVM PREC9",109 ,0)
6666	. D ^DIE K DIE,DA,D R
6667	"RTN","IVM PREC9",110 ,0)
6668	Q IVMFLAG
6669	"RTN","IVM PREC9",111 ,0)
6670	;
6671	"RTN","IVM PREC9",112 ,0)
6672	AUTORINC(D FN) ;
6673	"RTN","IVM PREC9",113 ,0)
6674	; applica tion to au tomaticall y upload R ated Incom petent dat a
6675	"RTN","IVM PREC9",114 ,0)
6676	; Input: DFN - Patien t IEN
6677	"RTN","IVM PREC9",115 ,0)
6678	N IVMI,IV MJ,IVMDA1, IVMDA2,IVM NODE,IVMFL AG,IVMRIVA L,IVMRIFLD
6679	"RTN","IVM PREC9",116 ,0)
6680	S IVMFLAG =0
6681	"RTN","IVM PREC9",117 ,0)
6682	S IVMDA2= $G(IVM3015 )
6683	"RTN","IVM PREC9",118 ,0)
6684	I 'IVMDA2 Q IVMFLAG
6685	"RTN","IVM PREC9",119 ,0)
6686	S IVMDA1= $O(^HL(771 .3,"B","PI D",""))
6687	"RTN","IVM PREC9",120 ,0)
6688	S IVMDA1= $O(^IVM(30 1.5,IVMDA2 ,"IN","B", IVMDA1,"") ,-1)
6689	"RTN","IVM PREC9",121 ,0)
6690	S IVMI=$O (^IVM(301. 92,"C","ZP D08","")) I IVMI="" Q IVMFLAG
6691	"RTN","IVM PREC9",122 ,0)
6692	S IVMJ=$O (^IVM(301. 5,IVMDA2," IN",IVMDA1 ,"DEM","B" ,IVMI,""))
6693	"RTN","IVM PREC9",123 ,0)
6694	I IVMJ']" " Q IVMFLA G
6695	"RTN","IVM PREC9",124 ,0)
6696	; - check for data node in (# 301.511) s ub-file
6697	"RTN","IVM PREC9",125 ,0)
6698	S IVMNODE =$G(^IVM(3 01.5,IVMDA 2,"IN",IVM DA1,"DEM", IVMJ,0))
6699	"RTN","IVM PREC9",126 ,0)
6700	I '(+IVMN ODE)!($P(I VMNODE,"^" ,2)']"") Q IVMFLAG
6701	"RTN","IVM PREC9",127 ,0)
6702	S IVMRIFL D=$P($G(^I VM(301.92, +IVMNODE,0 )),"^",5), IVMRIVAL=$ P(IVMNODE, "^",2)
6703	"RTN","IVM PREC9",128 ,0)
6704	I IVMRIVA L="""""" S IVMRIVAL= "@"
6705	"RTN","IVM PREC9",129 ,0)
6706	D UPLOAD^ IVMLDEM6(D FN,IVMRIFL D,IVMRIVAL ) S IVMFLA G=1
6707	"RTN","IVM PREC9",130 ,0)
6708	; - remov e entry fr om (#301.5 11) sub-fi le
6709	"RTN","IVM PREC9",131 ,0)
6710	D DELENT^ IVMLDEMU(I VMDA2,IVMD A1,IVMJ)
6711	"RTN","IVM PREC9",132 ,0)
6712	Q IVMFLAG
6713	"RTN","IVM PREC9",133 ,0)
6714	PHONE ; - ask user t o delete p hone # [Re sidence] f rom Patien t (#2) fil e
6715	"RTN","IVM PREC9",134 ,0)
6716	; This ta g is moved here from IVMLDEM6 due to rou tine size limit
6717	"RTN","IVM PREC9",135 ,0)
6718	D FULL^VA LM1
6719	"RTN","IVM PREC9",136 ,0)
6720	W ! S DIR ("A")="Is it okay to delete th e patient' s Phone Nu mber [Resi dence]"
6721	"RTN","IVM PREC9",137 ,0)
6722	W ! S DIR ("A",1)="T he patient 's address has been updated an d the phon enumber"
6723	"RTN","IVM PREC9",138 ,0)
6724	S DIR("A" ,2)="remai ns on file ."
6725	"RTN","IVM PREC9",139 ,0)
6726	S DIR("A" ,3)=" "
6727	"RTN","IVM PREC9",140 ,0)
6728	S DIR("A" ,4)="Patie nt Name: " _$P($$PT^I VMUFNC4(+D FN),"^")_" ("_$P($$P T^IVMUFNC4 (+DFN),"^" ,3)_")"
6729	"RTN","IVM PREC9",141 ,0)
6730	S DIR("A" ,5)="Phone Number [R esidence]: "_$P($G(^ DPT(+DFN,. 13)),"^")
6731	"RTN","IVM PREC9",142 ,0)
6732	S DIR("A" ,6)=" "
6733	"RTN","IVM PREC9",143 ,0)
6734	S DIR("?" ,1)="Enter 'YES' to delete the patient's Phone Num ber [Resid ence] that is"
6735	"RTN","IVM PREC9",144 ,0)
6736	S DIR("?" ,2)="curre ntly on fi le. Enter 'NO' to q uit withou t deleting the patie nt's"
6737	"RTN","IVM PREC9",145 ,0)
6738	S DIR("?" )="Phone N umber [Res idence]."
6739	"RTN","IVM PREC9",146 ,0)
6740	S DIR(0)= "Y",DIR("B ")="NO"
6741	"RTN","IVM PREC9",147 ,0)
6742	D ^DIR K DIR
6743	"RTN","IVM PREC9",148 ,0)
6744	S:Y $P(^D PT(DFN,.13 ),"^")="" W !!,"Pati ent's Phon e Number [ Residence] has ",$S( Y:"",1:"no t "),"been deleted."
6745	"RTN","IVM PREC9",149 ,0)
6746	Q
6747	"RTN","IVM PREC9",150 ,0)
6748	;
6749	"RTN","IVM PREC9",151 ,0)
6750	AUTOAUP(DF N,UPDAUP,U PDAUPG) ;
6751	"RTN","IVM PREC9",152 ,0)
6752	; automat ed upload of misc in formation
6753	"RTN","IVM PREC9",153 ,0)
6754	; Input: DFN - patient IEN
6755	"RTN","IVM PREC9",154 ,0)
6756	; UPDAUP - array c ontains fi elds for a uto-upload
6757	"RTN","IVM PREC9",155 ,0)
6758	; UPDAUPG - array c ontains fi eld group flag for a uto-upload
6759	"RTN","IVM PREC9",156 ,0)
6760	;
6761	"RTN","IVM PREC9",157 ,0)
6762	N IVMDA2, IVMDA1,IVM I,MULTFLG, IVMXREF,UF LG,IVMJ,IV MNODE,IVMC FLD,IVMCVA L,Y,IVM301 92,MULFIL
6763	"RTN","IVM PREC9",158 ,0)
6764	Q:'$G(DFN )
6765	"RTN","IVM PREC9",159 ,0)
6766	S IVMDA2= $G(IVM3015 ) Q:'IVMDA 2
6767	"RTN","IVM PREC9",160 ,0)
6768	S IVMDA1= $O(^HL(771 .3,"B","PI D",""))
6769	"RTN","IVM PREC9",161 ,0)
6770	S IVMDA1= $O(^IVM(30 1.5,IVMDA2 ,"IN","B", IVMDA1,"") ,-1) Q:'IV MDA1
6771	"RTN","IVM PREC9",162 ,0)
6772	;
6773	"RTN","IVM PREC9",163 ,0)
6774	S IVMI="" F S IVMI =$O(UPDAUP (IVMI)) Q: IVMI="" D
6775	"RTN","IVM PREC9",164 ,0)
6776	.;
6777	"RTN","IVM PREC9",165 ,0)
6778	.;If DHCP field is a multiple set multi ple flag f or special filing
6779	"RTN","IVM PREC9",166 ,0)
6780	.S MULTFL G=0
6781	"RTN","IVM PREC9",167 ,0)
6782	.S IVM301 92=$G(^IVM (301.92,IV MI,0)),IVM XREF=$P(IV M30192,"^" ,2)
6783	"RTN","IVM PREC9",168 ,0)
6784	.I IVMXRE F="PID10" S MULTFLG= 1 ;R ace
6785	"RTN","IVM PREC9",169 ,0)
6786	.I IVMXRE F="PID117C " S MULTFL G=1 ;C onf Addr C ategory
6787	"RTN","IVM PREC9",170 ,0)
6788	.I IVMXRE F="PID22" S MULTFLG= 1 ;E thnicity
6789	"RTN","IVM PREC9",171 ,0)
6790	.;
6791	"RTN","IVM PREC9",172 ,0)
6792	.;Don't f ile if par t of a gro up & group update fl ag not set
6793	"RTN","IVM PREC9",173 ,0)
6794	.S UFLG=1 I AUPFARY (IVMI)'="" ,'UPDAUPG( AUPFARY(IV MI)) S UFL G=0
6795	"RTN","IVM PREC9",174 ,0)
6796	.;
6797	"RTN","IVM PREC9",175 ,0)
6798	.S IVMJ=0 F S IVMJ =$O(^IVM(3 01.5,IVMDA 2,"IN",IVM DA1,"DEM", "B",IVMI,I VMJ)) Q:IV MJ']"" D
6799	"RTN","IVM PREC9",176 ,0)
6800	..S IVMNO DE=$G(^IVM (301.5,IVM DA2,"IN",I VMDA1,"DEM ",IVMJ,0))
6801	"RTN","IVM PREC9",177 ,0)
6802	..I $G(AU PFARY(+$P( IVMNODE,"^ ")))'="",( ($P(IVMNOD E,"^",2)=" ")!($P(IVM NODE,"^",2 )="""""")) S $P(IVMN ODE,"^",2) ="@"
6803	"RTN","IVM PREC9",178 ,0)
6804	..I +$G(Z EMADRUP(IV MXREF)),$P (IVMNODE," ^",2)="" S $P(IVMNOD E,"^",2)=" @"
6805	"RTN","IVM PREC9",179 ,0)
6806	..I ('+IV MNODE)!($P (IVMNODE," ^",2)']"") Q
6807	"RTN","IVM PREC9",180 ,0)
6808	..S IVMCF LD=$P($G(^ IVM(301.92 ,+IVMNODE, 0)),"^",5)
6809	"RTN","IVM PREC9",181 ,0)
6810	..S IVMCV AL=$P(IVMN ODE,"^",2)
6811	"RTN","IVM PREC9",182 ,0)
6812	..;
6813	"RTN","IVM PREC9",183 ,0)
6814	..I UFLG D
6815	"RTN","IVM PREC9",184 ,0)
6816	...I MULT FLG D AUTO AUPM(+DFN, IVM30192,I VMCVAL) ;fil e mult fld
6817	"RTN","IVM PREC9",185 ,0)
6818	...I 'MUL TFLG D UPL OAD^IVMLDE M6(+DFN,IV MCFLD,IVMC VAL) ;fil e non-mult
6819	"RTN","IVM PREC9",186 ,0)
6820	..D DELEN T^IVMLDEMU (IVMDA2,IV MDA1,IVMJ) ;remove fr om 301.511
6821	"RTN","IVM PREC9",187 ,0)
6822	..; - if no display or upload able field s left, de lete the P ID segment
6823	"RTN","IVM PREC9",188 ,0)
6824	..I '$$DE MO^IVMLDEM 5(IVMDA2,I VMDA1,0),' $$DEMO^IVM LDEM5(IVMD A2,IVMDA1, 1) D
6825	"RTN","IVM PREC9",189 ,0)
6826	...D DELE TE^IVMLDEM 5(IVMDA2,I VMDA1," ") ; Dummy u p name par ameter
6827	"RTN","IVM PREC9",190 ,0)
6828	Q
6829	"RTN","IVM PREC9",191 ,0)
6830	;
6831	"RTN","IVM PREC9",192 ,0)
6832	AUTOAUPM(D FN,IVM3019 2,IVMVALUE ) ;
6833	"RTN","IVM PREC9",193 ,0)
6834	; Input: DFN - as pa tient IEN
6835	"RTN","IVM PREC9",194 ,0)
6836	; IVM30192 - as '0 ' node of the 301.92 entry
6837	"RTN","IVM PREC9",195 ,0)
6838	; IVMVALUE - as th e value of the field
6839	"RTN","IVM PREC9",196 ,0)
6840	;
6841	"RTN","IVM PREC9",197 ,0)
6842	; Output: None
6843	"RTN","IVM PREC9",198 ,0)
6844	;
6845	"RTN","IVM PREC9",199 ,0)
6846	N MFIL,MF LD,DDINFO, DDMNOD,DDM FLD,DA,DIK ,DGENDA,MU LFIL,DATA, SUB
6847	"RTN","IVM PREC9",200 ,0)
6848	S MFIL=$P (IVM30192, "^",4),MFL D=$P(IVM30 192,"^",5)
6849	"RTN","IVM PREC9",201 ,0)
6850	S DDINFO= $G(^DD(MFI L,MFLD,0))
6851	"RTN","IVM PREC9",202 ,0)
6852	S DDMNOD= $P($P(DDIN FO,"^",4), ";"),DDMFL D=+$P(DDIN FO,"^",2)
6853	"RTN","IVM PREC9",203 ,0)
6854	;
6855	"RTN","IVM PREC9",204 ,0)
6856	; - delet e values c urrently i n the mult iple field
6857	"RTN","IVM PREC9",205 ,0)
6858	S DA(1)=D FN,DIK="^D PT("_DFN_" ,"""_DDMNO D_""","
6859	"RTN","IVM PREC9",206 ,0)
6860	S DA=0 F S DA=$O(^ DPT(DFN,DD MNOD,DA)) Q:'DA D ^ DIK
6861	"RTN","IVM PREC9",207 ,0)
6862	;
6863	"RTN","IVM PREC9",208 ,0)
6864	; - add n ew values to multipl e field
6865	"RTN","IVM PREC9",209 ,0)
6866	S DGENDA( 1)=DFN
6867	"RTN","IVM PREC9",210 ,0)
6868	;
6869	"RTN","IVM PREC9",211 ,0)
6870	I DDMFLD= 2.02 D
6871	"RTN","IVM PREC9",212 ,0)
6872	.S DATA(. 02)=$$FIND 1^DIC(10.3 ,,,"SELF I DENTIFICAT ION")
6873	"RTN","IVM PREC9",213 ,0)
6874	.S SUB="" F S SUB= $O(IVMRACE (2,SUB)) Q :SUB="" D
6875	"RTN","IVM PREC9",214 ,0)
6876	..S DATA( .01)=SUB
6877	"RTN","IVM PREC9",215 ,0)
6878	..; Chang ed FileMan call for processing of DINUM recs IVM2 .0159
6879	"RTN","IVM PREC9",216 ,0)
6880	..;I $$AD D^DGENDBS( DDMFLD,.DG ENDA,.DATA )
6881	"RTN","IVM PREC9",217 ,0)
6882	..S (X,DI NUM)=DATA( .01),DIC=" ^DPT(DFN,. 02,",DA(1) =DFN,DIC(0 )="L"
6883	"RTN","IVM PREC9",218 ,0)
6884	..K DO D FILE^DICN K DIC,X,DI NUM,DA
6885	"RTN","IVM PREC9",219 ,0)
6886	;
6887	"RTN","IVM PREC9",220 ,0)
6888	I DDMFLD= 2.06 D
6889	"RTN","IVM PREC9",221 ,0)
6890	.S DATA(. 01)=IVMVAL UE
6891	"RTN","IVM PREC9",222 ,0)
6892	.S DATA(. 02)=$$FIND 1^DIC(10.3 ,,,"SELF I DENTIFICAT ION")
6893	"RTN","IVM PREC9",223 ,0)
6894	.;Changed Fileman c all for pr ocessing o f Dinum re cs IVM2.0 159-BG
6895	"RTN","IVM PREC9",224 ,0)
6896	.;I $$ADD ^DGENDBS(D DMFLD,.DGE NDA,.DATA)
6897	"RTN","IVM PREC9",225 ,0)
6898	.S (X,DIN UM)=DATA(. 01),DIC="^ DPT(DFN,.0 6,",DA(1)= DFN,DIC(0) ="L"
6899	"RTN","IVM PREC9",226 ,0)
6900	.K DO D F ILE^DICN K DIC,X,DIN UM,DA
6901	"RTN","IVM PREC9",227 ,0)
6902	;
6903	"RTN","IVM PREC9",228 ,0)
6904	I DDMFLD= 2.141 D
6905	"RTN","IVM PREC9",229 ,0)
6906	.S DATA(1 )="Y"
6907	"RTN","IVM PREC9",230 ,0)
6908	.S SUB="" F S SUB= $O(CONFADC T(SUB)) Q: SUB="" D
6909	"RTN","IVM PREC9",231 ,0)
6910	..S DATA( .01)=SUB
6911	"RTN","IVM PREC9",232 ,0)
6912	..I $$ADD ^DGENDBS(D DMFLD,.DGE NDA,.DATA)
6913	"RTN","IVM PREC9",233 ,0)
6914	Q
6915	"RTN","IVM PTRN8")
6916	0^5^B86571 271
6917	"RTN","IVM PTRN8",1,0 )
6918	IVMPTRN8 ; ALB/RKS,PD J,BRM,TDM, PJH,TDM,PW C,LBD,DRP, DJS - HL7 FULL DATA TRANSMISSI ON (Z07) B UILDER ;27 Oct 2017 8:56 AM
6919	"RTN","IVM PTRN8",2,0 )
6920	;;2.0;INC OME VERIFI CATION MAT CH;9,11, 19,12,21,1 7,24,36,37 ,47,48,42, 34,77,76,7 5,79,85,89 ,98,56,97, 104,113,10 9,114,105, 115,121,15 1,141,150, 160,161,16 8,167;21 -OCT-94;Bu ild 39
6921	"RTN","IVM PTRN8",3,0 )
6922	;
6923	"RTN","IVM PTRN8",4,0 )
6924	;
6925	"RTN","IVM PTRN8",5,0 )
6926	BUILD(DFN, IVMMTDT,IV MCT,IVMQUE RY) ; --
6927	"RTN","IVM PTRN8",6,0 )
6928	; Descri ption: Thi s entry po int will b e used to create an HL7
6929	"RTN","IVM PTRN8",7,0 )
6930	; "Full Data Trans mission" m essage for a patient .
6931	"RTN","IVM PTRN8",8,0 )
6932	;
6933	"RTN","IVM PTRN8",9,0 )
6934	; Input:
6935	"RTN","IVM PTRN8",10, 0)
6936	; DFN - Pati ent IEN
6937	"RTN","IVM PTRN8",11, 0)
6938	; IVMM TDT - date of the pa tient's Me ans Test o r Copay Te st
6939	"RTN","IVM PTRN8",12, 0)
6940	; IV MCT - coun t of hl7 s egments tr ansmitted, pass by r eference
6941	"RTN","IVM PTRN8",13, 0)
6942	; IVMQU ERY - arra y passed i n by refer ence where
6943	"RTN","IVM PTRN8",14, 0)
6944	; IVMQ UERY("LTD" ) -- # of the QUERY that is cu rrently op en or
6945	"RTN","IVM PTRN8",15, 0)
6946	; un defined, z ero, or nu ll if no Q UERY opene d for
6947	"RTN","IVM PTRN8",16, 0)
6948	; la st treatme nt date
6949	"RTN","IVM PTRN8",17, 0)
6950	; IVMQ UERY("OVIS ") -- # of the QUERY that is c urrently o pen or
6951	"RTN","IVM PTRN8",18, 0)
6952	; un defined, z ero, or nu ll if no Q UERY opene d for
6953	"RTN","IVM PTRN8",19, 0)
6954	; fi nding outp atient vis its
6955	"RTN","IVM PTRN8",20, 0)
6956	;
6957	"RTN","IVM PTRN8",21, 0)
6958	; HL7 va riables as defined b y call to INIT^IVMUF NC:
6959	"RTN","IVM PTRN8",22, 0)
6960	; HL EVN - HL7 message ev ent counte r
6961	"RTN","IVM PTRN8",23, 0)
6962	; HL SDT - a fl ag that in dicates th at the dat a to be se nt is
6963	"RTN","IVM PTRN8",24, 0)
6964	; stor ed in the ^TMP("HLS" ) global a rray.
6965	"RTN","IVM PTRN8",25, 0)
6966	;
6967	"RTN","IVM PTRN8",26, 0)
6968	; The fo llowing va riables re turned by the INIT^H LTRANS ent ry point:
6969	"RTN","IVM PTRN8",27, 0)
6970	; HLND AP - Non-D HCP Applic ation Poin ter from f ile 770
6971	"RTN","IVM PTRN8",28, 0)
6972	; HLNDA P0 - Zero node from file 770 c orrespondi ng to HLND AP
6973	"RTN","IVM PTRN8",29, 0)
6974	; HLD AP - DHCP Applicatio n Pointer from file 771
6975	"RTN","IVM PTRN8",30, 0)
6976	; HLD AN - The D HCP Applic ation Name (.01 fiel d, file 77 1) for HLD AP
6977	"RTN","IVM PTRN8",31, 0)
6978	; HLP ID - HL7 p rocessing ID from fi le 770
6979	"RTN","IVM PTRN8",32, 0)
6980	; HLV ER - HL7 v ersion num ber from f ile 770
6981	"RTN","IVM PTRN8",33, 0)
6982	; HL FS - HL7 F ield Separ ator from the 'FS' n ode of fil e 771
6983	"RTN","IVM PTRN8",34, 0)
6984	; HLE CH - HL7 E ncoding Ch aracters f rom the 'E C' node of file 771
6985	"RTN","IVM PTRN8",35, 0)
6986	; H LQ - Doubl e quotes ( "") for us e in build ing HL7 se gments
6987	"RTN","IVM PTRN8",36, 0)
6988	; HLE RR - if an error is encountere d, an erro r message is returne d
6989	"RTN","IVM PTRN8",37, 0)
6990	; in th e HLERR va riable.
6991	"RTN","IVM PTRN8",38, 0)
6992	; HL DA - the i nternal en try number for the e ntry creat ed in
6993	"RTN","IVM PTRN8",39, 0)
6994	; file #772.
6995	"RTN","IVM PTRN8",40, 0)
6996	; HL DT - trans mission da te/time (a ssociated with the e ntry in fi le
6997	"RTN","IVM PTRN8",41, 0)
6998	; #772 identified by HLDA) in interna l VA FileM an format.
6999	"RTN","IVM PTRN8",42, 0)
7000	; HLD T1 - the s ame transm ission dat e/time as the HLDT v ariable,
7001	"RTN","IVM PTRN8",43, 0)
7002	; only in HL7 for mat.
7003	"RTN","IVM PTRN8",44, 0)
7004	;
7005	"RTN","IVM PTRN8",45, 0)
7006	; Output:
7007	"RTN","IVM PTRN8",46, 0)
7008	; ^TMP(" HLS",$J,IV MCT) - glo bal array containing all segme nts of the HL7 messa ge that th e VistA ap plication wishes to send. The HLSDT var iable is d efined abo ve and the IVMCT var iable is a sequentia l number i ncremented by 1.
7009	"RTN","IVM PTRN8",47, 0)
7010	;
7011	"RTN","IVM PTRN8",48, 0)
7012	;
7013	"RTN","IVM PTRN8",49, 0)
7014	N DGINC,D GIR,DGREL, I,IVMNTE,I VMPID,IVMS UB,IVMZRD, VAFPID,VAF ZEL,FBZFE, IVMZCD,DEL ETE,NODE,I VMPIEN,TES T,IVMPNODE ,TESTTYPE, SEQS,TESTC ODE,HARDSH IP,ACTVIEN ,IVMZMH,IV MSEQ
7015	"RTN","IVM PTRN8",50, 0)
7016	N EDBMTZ0 6,ZMHSQ,SE TID,OBXCNT ,OBXTMP,DG SEC,SEGOCC ,ZIOSEG,N1 01015,RF1S EG,ZCTTYP, ZCTARY,ZCT SQ,VAFPID, CAFLG
7017	"RTN","IVM PTRN8",51, 0)
7018	;
7019	"RTN","IVM PTRN8",52, 0)
7020	; create (PID) Pati ent Identi fication s egment
7021	"RTN","IVM PTRN8",53, 0)
7022	; **** Ad d ICN to 2 nd piece P ID segment for MPI@H EC.
7023	"RTN","IVM PTRN8",54, 0)
7024	S IVMCMOR ="1,2",IVM SEQ=1
7025	"RTN","IVM PTRN8",55, 0)
7026	; check t o see if s ite is a l egacy site . If not add ICN to PID segme nt.
7027	"RTN","IVM PTRN8",56, 0)
7028	I '$D(^PP P(1020.128 ,"AC",$P($ $SITE^VASI TE,"^",3)) ) D
7029	"RTN","IVM PTRN8",57, 0)
7030	. I +$$GE TICN^MPIF0 01(DFN)>0, ($$IFLOCAL ^MPIF001(D FN)=0) S I VMSEQ=IVMS EQ_",2",IV MCMOR="1,2 ,3" ;add SEQ 1 and 2 for PID
7031	"RTN","IVM PTRN8",58, 0)
7032	;
7033	"RTN","IVM PTRN8",59, 0)
7034	; send SS N indicati ng pseudo
7035	"RTN","IVM PTRN8",60, 0)
7036	; I $P(IV MPID_$G(IV MPID(1)),H LFS,20)["P " D PSEUDO ^IVMPTRN1 ; strip ' P' from ps eudo SSNs
7037	"RTN","IVM PTRN8",61, 0)
7038	S IVMSEQ= IVMSEQ_",3 ,5,6,7,8,1 0,11,12,13 ,14,16,17, 19,22,24"
7039	"RTN","IVM PTRN8",62, 0)
7040	K IVMPID D BLDPID^V AFCQRY1(DF N,1,IVMSEQ ,.IVMPID,. HL,.ERROR)
7041	"RTN","IVM PTRN8",63, 0)
7042	K VAFPID D STRIP11
7043	"RTN","IVM PTRN8",64, 0)
7044	S SEGOCC= "" F S SE GOCC=$O(VA FPID(SEGOC C)) Q:SEGO CC="" D
7045	"RTN","IVM PTRN8",65, 0)
7046	. S IVMCT =IVMCT+1,^ TMP("HLS", $J,IVMCT)= VAFPID(SEG OCC)
7047	"RTN","IVM PTRN8",66, 0)
7048	;
7049	"RTN","IVM PTRN8",67, 0)
7050	; **** cr eate (PD1) Patient C MOR segmen t for MPI@ HEC.
7051	"RTN","IVM PTRN8",68, 0)
7052	S:'$D(HL( "FS")) HL( "FS")=HLFS
7053	"RTN","IVM PTRN8",69, 0)
7054	S:'$D(HL( "ECH")) HL ("ECH")=HL ECH
7055	"RTN","IVM PTRN8",70, 0)
7056	S:'$D(HL( "Q")) HL(" Q")=HLQ
7057	"RTN","IVM PTRN8",71, 0)
7058	S IVMCT=I VMCT+1,^TM P("HLS",$J ,IVMCT)=$$ EN^VAFHLPD 1(DFN,IVMC MOR)
7059	"RTN","IVM PTRN8",72, 0)
7060	;
7061	"RTN","IVM PTRN8",73, 0)
7062	; create (ZPD) Pati ent Depend ent Info. segment
7063	"RTN","IVM PTRN8",74, 0)
7064	S IVMCT=I VMCT+1,^TM P("HLS",$J ,IVMCT)=$$ EN1^VAFHLZ PD(DFN,"1, 6,7,8,9,11 ,12,13,17, 19,30,31,3 2,33,34,35 ,40"),IVMI NS=$P(^(IV MCT),HLFS, 12)
7065	"RTN","IVM PTRN8",75, 0)
7066	I $D(VAFZ PD(1)) S I VMCT=IVMCT +1,^TMP("H LS",$J,IVM CT)=VAFZPD (1) K VAFZ PD(1)
7067	"RTN","IVM PTRN8",76, 0)
7068	;
7069	"RTN","IVM PTRN8",77, 0)
7070	; create (ZTA) Temp orary Addr ess segmen t
7071	"RTN","IVM PTRN8",78, 0)
7072	S IVMCT=I VMCT+1,^TM P("HLS",$J ,IVMCT)=$$ EN^VAFHLZT A(DFN,"1,2 ,3,4,5,6,7 ,8,9",,.HL )
7073	"RTN","IVM PTRN8",79, 0)
7074	;
7075	"RTN","IVM PTRN8",80, 0)
7076	; create (ZIE) Inel igible seg ment
7077	"RTN","IVM PTRN8",81, 0)
7078	S IVMCT=I VMCT+1,^TM P("HLS",$J ,IVMCT)=$$ EN^VAFHLZI E(DFN,"1,2 ,3",1)
7079	"RTN","IVM PTRN8",82, 0)
7080	;
7081	"RTN","IVM PTRN8",83, 0)
7082	; create (ZEL) Elig ibility se gment(s)
7083	"RTN","IVM PTRN8",84, 0)
7084	; **** Ad d 5th piec e to ZEL t o correct consistenc y check
7085	"RTN","IVM PTRN8",85, 0)
7086	; added 4 1-44 for C LV IVM2.0 161
7087	"RTN","IVM PTRN8",86, 0)
7088	D EN1^VAF HLZEL(DFN, "1,2,5,6,7 ,8,10,11,1 3,14,15,16 ,17,18,19, 20,21,22,2 3,24,25,29 ,34,35,37, 38,39,40,4 1,42,43,44 ",2,.VAFZE L)
7089	"RTN","IVM PTRN8",87, 0)
7090	S IVMCT=I VMCT+1,^TM P("HLS",$J ,IVMCT)=$G (VAFZEL(1) ) ; Prima ry Eligibi lity
7091	"RTN","IVM PTRN8",88, 0)
7092	I $D(VAFZ EL(1,1)) S IVMCT=IVM CT+1,^TMP( "HLS",$J,I VMCT)=$G(V AFZEL(1,1) )
7093	"RTN","IVM PTRN8",89, 0)
7094	; - other entitled eligibilit ies
7095	"RTN","IVM PTRN8",90, 0)
7096	F IVMSUB= 1:0 S IVMS UB=+$O(VAF ZEL(IVMSUB )) Q:'IVMS UB D
7097	"RTN","IVM PTRN8",91, 0)
7098	. S IVMCT =IVMCT+1,^ TMP("HLS", $J,IVMCT)= $G(VAFZEL( +IVMSUB))
7099	"RTN","IVM PTRN8",92, 0)
7100	;
7101	"RTN","IVM PTRN8",93, 0)
7102	; create ZE2 segmen t (Optiona l)
7103	"RTN","IVM PTRN8",94, 0)
7104	I $P($G(^ DPT(DFN,.3 85)),U)'=" " S IVMCT= IVMCT+1,^T MP("HLS",$ J,IVMCT)=$ $EN^VAFHLZ E2(DFN,"1, 2")
7105	"RTN","IVM PTRN8",95, 0)
7106	;
7107	"RTN","IVM PTRN8",96, 0)
7108	; create (ZEN) Enro llment seg ment
7109	"RTN","IVM PTRN8",97, 0)
7110	S IVMCT=I VMCT+1,^TM P("HLS",$J ,IVMCT)=$$ EN^VAFHLZE N(DFN)
7111	"RTN","IVM PTRN8",98, 0)
7112	;
7113	"RTN","IVM PTRN8",99, 0)
7114	; create (ZCD) Cata strophic D isability segment(s)
7115	"RTN","IVM PTRN8",100 ,0)
7116	D BUILD^V AFHLZCD(.I VMZCD,DFN, ,HLQ,HLFS)
7117	"RTN","IVM PTRN8",101 ,0)
7118	F IVMSUB= 0:0 S IVMS UB=+$O(IVM ZCD(IVMSUB )) Q:'IVMS UB D
7119	"RTN","IVM PTRN8",102 ,0)
7120	. S IVMCT =IVMCT+1,^ TMP("HLS", $J,IVMCT)= $G(IVMZCD( +IVMSUB))
7121	"RTN","IVM PTRN8",103 ,0)
7122	;
7123	"RTN","IVM PTRN8",104 ,0)
7124	; Optiona lly create (ZMH) Mil itary Hist ory segmen ts
7125	"RTN","IVM PTRN8",105 ,0)
7126	; Pass "* " as param eter to se nd unlimit ed MSEs in Z07 (IVM* 2*141)
7127	"RTN","IVM PTRN8",106 ,0)
7128	D ENTER^V AFHLZMH(DF N,"IVMZMH" ,"*")
7129	"RTN","IVM PTRN8",107 ,0)
7130	;DJS, Don 't create ZMH segmen t if array entry is an FDD MSE ; IVM2.0 167
7131	"RTN","IVM PTRN8",108 ,0)
7132	N ZMHED,M SESUB,DONE MSE
7133	"RTN","IVM PTRN8",109 ,0)
7134	S (ZMHSQ, SETID,DONE MSE)=0
7135	"RTN","IVM PTRN8",110 ,0)
7136	I $D(IVMZ MH) F S Z MHSQ=$O(IV MZMH(ZMHSQ )) Q:ZMHSQ ="" D
7137	"RTN","IVM PTRN8",111 ,0)
7138	. Q:$TR($ P(IVMZMH(Z MHSQ,0),HL FS,4,5),"" "^~")=""
7139	"RTN","IVM PTRN8",112 ,0)
7140	. ;If no Service En try Date, QUIT
7141	"RTN","IVM PTRN8",113 ,0)
7142	. S ZMHED =$P(IVMZMH (ZMHSQ,0), U,5),ZMHED =$P(ZMHED, "~",1) Q:Z MHED=""
7143	"RTN","IVM PTRN8",114 ,0)
7144	. S ZMHED =$$HL7TFM^ XLFDT(ZMHE D)
7145	"RTN","IVM PTRN8",115 ,0)
7146	. ;Get MS E, if no m ore MSEs, process Co nflict Inf ormation, if present
7147	"RTN","IVM PTRN8",116 ,0)
7148	. I 'DONE MSE S MSES UB="",MSES UB=$O(^DPT (DFN,.3216 ,"B",ZMHED ,MSESUB)) S:MSESUB=" " DONEMSE= 1
7149	"RTN","IVM PTRN8",117 ,0)
7150	. ;Do not create ZM H segment if FDD MSE
7151	"RTN","IVM PTRN8",118 ,0)
7152	. I 'DONE MSE,$P(^DP T(DFN,.321 6,MSESUB,0 ),U,8)'="" Q ;Only check for FDD if MSE entry
7153	"RTN","IVM PTRN8",119 ,0)
7154	. S SETID =SETID+1,I VMCT=IVMCT +1
7155	"RTN","IVM PTRN8",120 ,0)
7156	. S ^TMP( "HLS",$J,I VMCT)="ZMH "_HLFS_SET ID_HLFS_$P (IVMZMH(ZM HSQ,0),HLF S,3,6)
7157	"RTN","IVM PTRN8",121 ,0)
7158	;
7159	"RTN","IVM PTRN8",122 ,0)
7160	; create (ZRD) Rate d Disabili ties segme nt(s)
7161	"RTN","IVM PTRN8",123 ,0)
7162	D EN^VAFH LZRD(DFN," 1,2,3,4,12 ,13,14,",H LQ,HLFS,"I VMZRD")
7163	"RTN","IVM PTRN8",124 ,0)
7164	F IVMSUB= 0:0 S IVMS UB=+$O(IVM ZRD(IVMSUB )) Q:'IVMS UB D
7165	"RTN","IVM PTRN8",125 ,0)
7166	. S IVMCT =IVMCT+1,^ TMP("HLS", $J,IVMCT)= $G(IVMZRD( +IVMSUB,0) )
7167	"RTN","IVM PTRN8",126 ,0)
7168	;
7169	"RTN","IVM PTRN8",127 ,0)
7170	; create (ZCT) Emer gency Cont act segmen t
7171	"RTN","IVM PTRN8",128 ,0)
7172	;S IVMCT= IVMCT+1,^T MP("HLS",$ J,IVMCT)=$ $EN^VAFHLZ CT(DFN,"1, 2,3,4,5,6, 7,10","",1 ,1)
7173	"RTN","IVM PTRN8",129 ,0)
7174	K ZCTARY F ZCTTYP=1 :1:5 D ; Create Opt ional ZCT Segments
7175	"RTN","IVM PTRN8",130 ,0)
7176	. S ZCTAR Y(ZCTTYP)= $$EN^VAFHL ZCT(DFN,"1 ,2,3,4,5,6 ,7,10","", ZCTTYP,1)
7177	"RTN","IVM PTRN8",131 ,0)
7178	S (ZCTTYP ,ZCTSQ)=0
7179	"RTN","IVM PTRN8",132 ,0)
7180	I $D(ZCTA RY) F S Z CTTYP=$O(Z CTARY(ZCTT YP)) Q:ZCT TYP="" D
7181	"RTN","IVM PTRN8",133 ,0)
7182	. Q:$P(ZC TARY(ZCTTY P),HLFS,11 )=HLQ
7183	"RTN","IVM PTRN8",134 ,0)
7184	. S ZCTSQ =ZCTSQ+1,$ P(ZCTARY(Z CTTYP),HLF S,2)=ZCTSQ
7185	"RTN","IVM PTRN8",135 ,0)
7186	. S IVMCT =IVMCT+1,^ TMP("HLS", $J,IVMCT)= ZCTARY(ZCT TYP)
7187	"RTN","IVM PTRN8",136 ,0)
7188	I ZCTSQ=0 S IVMCT=I VMCT+1,^TM P("HLS",$J ,IVMCT)=ZC TARY(1)
7189	"RTN","IVM PTRN8",137 ,0)
7190	;
7191	"RTN","IVM PTRN8",138 ,0)
7192	; create (ZEM) Empl oyment Inf o. segment for (1) P atient & ( 2) Spouse
7193	"RTN","IVM PTRN8",139 ,0)
7194	;*168 S I VMCT=IVMCT +1,^TMP("H LS",$J,IVM CT)=$$EN^V AFHLZEM(DF N,"1,2,3,4 ,5,6,7")
7195	"RTN","IVM PTRN8",140 ,0)
7196	;*168 S I VMCT=IVMCT +1,^TMP("H LS",$J,IVM CT)=$$EN^V AFHLZEM(DF N,"1,2,3,4 ,5,6,7",2, 2)
7197	"RTN","IVM PTRN8",141 ,0)
7198	S IVMCT=I VMCT+1,^TM P("HLS",$J ,IVMCT)=$$ EN^VAFHLZE M(DFN,"1,2 ,3,4,5,6,7 ,9") ;re-e nable impr ecise date .
7199	"RTN","IVM PTRN8",142 ,0)
7200	S IVMCT=I VMCT+1,^TM P("HLS",$J ,IVMCT)=$$ EN^VAFHLZE M(DFN,"1,2 ,3,4,5,6,7 ,9",2,2)
7201	"RTN","IVM PTRN8",143 ,0)
7202	;
7203	"RTN","IVM PTRN8",144 ,0)
7204	; create (ZGD) Guar dian segme nt for (1) VA & (2) Civil
7205	"RTN","IVM PTRN8",145 ,0)
7206	S IVMCT=I VMCT+1,^TM P("HLS",$J ,IVMCT)=$$ EN^VAFHLZG D(DFN,"1,2 ,3,4,5,6,7 ,8",1)
7207	"RTN","IVM PTRN8",146 ,0)
7208	S IVMCT=I VMCT+1,^TM P("HLS",$J ,IVMCT)=$$ EN^VAFHLZG D(DFN,"1,2 ,3,4,5,6,7 ,8",2)
7209	"RTN","IVM PTRN8",147 ,0)
7210	;
7211	"RTN","IVM PTRN8",148 ,0)
7212	; Income Year requi ring trans mission fr om IVM Pat ient File (301.5)
7213	"RTN","IVM PTRN8",149 ,0)
7214	S IVMIY=$ S($D(IVMIY ):IVMIY,1: (IVMMTDT-1 0000))
7215	"RTN","IVM PTRN8",150 ,0)
7216	N MTINFO S MTINFO=$ $FUT^DGMTU (DFN)
7217	"RTN","IVM PTRN8",151 ,0)
7218	I ($E(IVM IY,1,3)+1) =$E($P(MTI NFO,U,2),1 ,3) S IVMM TDT=$P(MTI NFO,U,2)
7219	"RTN","IVM PTRN8",152 ,0)
7220	;get the primary te st for the income ye ar
7221	"RTN","IVM PTRN8",153 ,0)
7222	S TESTTYP E=$$GETTYP E^IVMPTRN9 (DFN,IVMMT DT,.TESTCO DE,.HARDSH IP,.ACTVIE N)
7223	"RTN","IVM PTRN8",154 ,0)
7224	;
7225	"RTN","IVM PTRN8",155 ,0)
7226	; The fol lowing fun ction call returns:
7227	"RTN","IVM PTRN8",156 ,0)
7228	; - Pat ient Relat ion IEN ar ray in DGR EL
7229	"RTN","IVM PTRN8",157 ,0)
7230	; - Ind ividual An nual Incom e IEN arra y in DGINC
7231	"RTN","IVM PTRN8",158 ,0)
7232	; - Inc ome Relati on IEN arr ay in DGIN R
7233	"RTN","IVM PTRN8",159 ,0)
7234	D ALL^DGM TU21(DFN," VSC",IVMMT DT,"IPR",A CTVIEN)
7235	"RTN","IVM PTRN8",160 ,0)
7236	;
7237	"RTN","IVM PTRN8",161 ,0)
7238	S EDBMTZ0 6=0 I $$VE RZ06^EASPT RN1(DFN) S EDBMTZ06= 1
7239	"RTN","IVM PTRN8",162 ,0)
7240	; create (ZIC) Inco me segment for veter an
7241	"RTN","IVM PTRN8",163 ,0)
7242	S IVMCT=I VMCT+1
7243	"RTN","IVM PTRN8",164 ,0)
7244	;IVM2.0 115 -- Che ck for Mea ns Test Ve rsion Indi cator
7245	"RTN","IVM PTRN8",165 ,0)
7246	N MTVERS S MTVERS=$ S(+$G(ACTV IEN):+$P($ G(^DGMT(40 8.31,ACTVI EN,2)),"^" ,11),1:0)
7247	"RTN","IVM PTRN8",166 ,0)
7248	I MTVERS= 0 D I 1
7249	"RTN","IVM PTRN8",167 ,0)
7250	. S ^TMP( "HLS",$J,I VMCT)=$$EN ^VAFHLZIC( +$G(DGINC( "V")),"1,2 ,3,4,5,6,7 ,8,9,10,11 ,12,13,14, 15,16,17,1 8,19,20")
7251	"RTN","IVM PTRN8",168 ,0)
7252	E D
7253	"RTN","IVM PTRN8",169 ,0)
7254	. S ^TMP( "HLS",$J,I VMCT)=$$EN ^VAFHLZIC( +$G(DGINC( "V")),"1,2 ,3,9,12,13 ,14,15,16, 18,19")
7255	"RTN","IVM PTRN8",170 ,0)
7256	I EDBMTZ0 6 S ^TMP(" HLS",$J,IV MCT)="ZIC^ "_$P(^TMP( "HLS",$J,I VMCT),"^", 2,3)
7257	"RTN","IVM PTRN8",171 ,0)
7258	;use IVMI Y not IVMM TDT. For L TC copay e xemption, IVMMTDT is not corre ct
7259	"RTN","IVM PTRN8",172 ,0)
7260	S $P(^TMP ("HLS",$J, IVMCT),"^" ,3)=$$HLDA TE^HLFNC(I VMIY)
7261	"RTN","IVM PTRN8",173 ,0)
7262	;
7263	"RTN","IVM PTRN8",174 ,0)
7264	; create (ZIR) Inco me Relatio n segment for vetera n
7265	"RTN","IVM PTRN8",175 ,0)
7266	S IVMCT=I VMCT+1,^TM P("HLS",$J ,IVMCT)=$$ EN^VAFHLZI R(+$G(DGIN R("V")),"1 ,2,3,4,5,1 0,15") ;I VM * 2.0 * 160
7267	"RTN","IVM PTRN8",176 ,0)
7268	I EDBMTZ0 6 S ^TMP(" HLS",$J,IV MCT)="ZIR^ 1"
7269	"RTN","IVM PTRN8",177 ,0)
7270	;
7271	"RTN","IVM PTRN8",178 ,0)
7272	; create (ZDP) Pati ent Depend ent Info. segment fo r spouse
7273	"RTN","IVM PTRN8",179 ,0)
7274	S IVMCT=I VMCT+1,^TM P("HLS",$J ,IVMCT)=$$ EN^VAFHLZD P(+$G(DGRE L("S")),"1 ,2,3,4,5,6 ,7,8,9,10, 13,14")
7275	"RTN","IVM PTRN8",180 ,0)
7276	I $P(^TMP ("HLS",$J, IVMCT),HLF S,3)'=HLQ, ($P($G(^(I VMCT)),HLF S,6)=HLQ) D
7277	"RTN","IVM PTRN8",181 ,0)
7278	. ; - pas s non-exis tent SSNs as 0s
7279	"RTN","IVM PTRN8",182 ,0)
7280	. S $P(X, HLFS,6)="0 00000000"
7281	"RTN","IVM PTRN8",183 ,0)
7282	;
7283	"RTN","IVM PTRN8",184 ,0)
7284	; create (ZIC) Inco me segment for spous e
7285	"RTN","IVM PTRN8",185 ,0)
7286	S IVMCT=I VMCT+1
7287	"RTN","IVM PTRN8",186 ,0)
7288	;IVM2.0 115
7289	"RTN","IVM PTRN8",187 ,0)
7290	I MTVERS= 0 D I 1
7291	"RTN","IVM PTRN8",188 ,0)
7292	. S ^TMP( "HLS",$J,I VMCT)=$$EN ^VAFHLZIC( +$G(DGINC( "S")),"1,2 ,3,4,5,6,7 ,8,9,10,11 ,12,16,17, 18,19,20")
7293	"RTN","IVM PTRN8",189 ,0)
7294	E D
7295	"RTN","IVM PTRN8",190 ,0)
7296	. S ^TMP( "HLS",$J,I VMCT)=$$EN ^VAFHLZIC( +$G(DGINC( "S")),"1,2 ,3,9,12,16 ,18,19")
7297	"RTN","IVM PTRN8",191 ,0)
7298	I EDBMTZ0 6 S ^TMP(" HLS",$J,IV MCT)="ZIC^ "_$P(^TMP( "HLS",$J,I VMCT),"^", 2,3)
7299	"RTN","IVM PTRN8",192 ,0)
7300	;
7301	"RTN","IVM PTRN8",193 ,0)
7302	; create (ZIR) Inco me Relatio n segment for spouse
7303	"RTN","IVM PTRN8",194 ,0)
7304	S IVMCT=I VMCT+1,^TM P("HLS",$J ,IVMCT)=$$ EN^VAFHLZI R(+$G(DGIN R("S")),"1 ,2,3")
7305	"RTN","IVM PTRN8",195 ,0)
7306	I EDBMTZ0 6 S ^TMP(" HLS",$J,IV MCT)="ZIR^ "_$P(^TMP( "HLS",$J,I VMCT),"^", 2)
7307	"RTN","IVM PTRN8",196 ,0)
7308	;
7309	"RTN","IVM PTRN8",197 ,0)
7310	;
7311	"RTN","IVM PTRN8",198 ,0)
7312	; create ZDP, ZIC, and ZIR se gments for all Means Test depe ndents
7313	"RTN","IVM PTRN8",199 ,0)
7314	F IVMSUB= 0:0 S IVMS UB=$O(DGRE L("C",IVMS UB)) Q:'IV MSUB D
7315	"RTN","IVM PTRN8",200 ,0)
7316	. ;
7317	"RTN","IVM PTRN8",201 ,0)
7318	. ; - cre ate (ZDP) Dependent Info. segm ent for de pendent ch ild
7319	"RTN","IVM PTRN8",202 ,0)
7320	. S IVMCT =IVMCT+1,^ TMP("HLS", $J,IVMCT)= $$EN^VAFHL ZDP(+$G(DG REL("C",IV MSUB)),"1, 2,3,4,5,6, 7,9,10")
7321	"RTN","IVM PTRN8",203 ,0)
7322	. I $P(^T MP("HLS",$ J,IVMCT),H LFS,3)'=HL Q,($P($G(^ (IVMCT)),H LFS,6)=HLQ ) D
7323	"RTN","IVM PTRN8",204 ,0)
7324	. . ; - p ass non-ex istent SSN s as 0s
7325	"RTN","IVM PTRN8",205 ,0)
7326	. . S $P( X,HLFS,6)= "000000000 "
7327	"RTN","IVM PTRN8",206 ,0)
7328	. ;
7329	"RTN","IVM PTRN8",207 ,0)
7330	. ; - cre ate (ZIC) Income seg ment for d ependent c hild
7331	"RTN","IVM PTRN8",208 ,0)
7332	. S IVMCT =IVMCT+1
7333	"RTN","IVM PTRN8",209 ,0)
7334	. ;IVM2. 0115
7335	"RTN","IVM PTRN8",210 ,0)
7336	. I MTVER S=0 D I 1
7337	"RTN","IVM PTRN8",211 ,0)
7338	. . S ^TM P("HLS",$J ,IVMCT)=$$ EN^VAFHLZI C(+$G(DGIN C("C",IVMS UB)),"1,2, 3,4,5,6,7, 8,9,10,11, 12,15")
7339	"RTN","IVM PTRN8",212 ,0)
7340	. E D
7341	"RTN","IVM PTRN8",213 ,0)
7342	. . S ^TM P("HLS",$J ,IVMCT)=$$ EN^VAFHLZI C(+$G(DGIN C("C",IVMS UB)),"1,2, 3,9,12,15, 16,18,19")
7343	"RTN","IVM PTRN8",214 ,0)
7344	. I EDBMT Z06 S ^TMP ("HLS",$J, IVMCT)="ZI C^"_$P(^TM P("HLS",$J ,IVMCT),"^ ",2,3)
7345	"RTN","IVM PTRN8",215 ,0)
7346	. ;
7347	"RTN","IVM PTRN8",216 ,0)
7348	. ; - cre ate (ZIR) Income Rel ation segm ent for de pendent ch ild
7349	"RTN","IVM PTRN8",217 ,0)
7350	. S IVMCT =IVMCT+1,^ TMP("HLS", $J,IVMCT)= $$EN^VAFHL ZIR(+$G(DG INR("C",IV MSUB)),"1, 2,3,4,6,7, 8,9,14,15" ) ;IVM * 2.0 *160
7351	"RTN","IVM PTRN8",218 ,0)
7352	. I EDBMT Z06 S ^TMP ("HLS",$J, IVMCT)="ZI R^"_$P(^TM P("HLS",$J ,IVMCT),"^ ",2)
7353	"RTN","IVM PTRN8",219 ,0)
7354	. ;
7355	"RTN","IVM PTRN8",220 ,0)
7356	; Send IN ACTIVE spo use/depend ents.
7357	"RTN","IVM PTRN8",221 ,0)
7358	D GETINAC D^DGMTU11( DFN,.DGREL )
7359	"RTN","IVM PTRN8",222 ,0)
7360	F I="S"," C" D
7361	"RTN","IVM PTRN8",223 ,0)
7362	. F IVMSU B=0:0 S IV MSUB=$O(DG IREL(I,IVM SUB)) Q:'I VMSUB D
7363	"RTN","IVM PTRN8",224 ,0)
7364	. . S IVM CT=IVMCT+1 ,^TMP("HLS ",$J,IVMCT )=$$EN^VAF HLZDP(+$G( DGIREL(I,I VMSUB)),"1 ,2,3,4,5,6 ,7,9,10,11 ",,,$P(DGI REL(I,IVMS UB),U,3))
7365	"RTN","IVM PTRN8",225 ,0)
7366	;
7367	"RTN","IVM PTRN8",226 ,0)
7368	D GOTO^IV MPTRN9
7369	"RTN","IVM PTRN8",227 ,0)
7370	Q
7371	"RTN","IVM PTRN8",228 ,0)
7372	;
7373	"RTN","IVM PTRN8",229 ,0)
7374	STRIP11 N APID,ZPID, ASQ,ATYP,S SQ
7375	"RTN","IVM PTRN8",230 ,0)
7376	;Extract PID segmen t
7377	"RTN","IVM PTRN8",231 ,0)
7378	S IVMPID( 1)=$E(IVMP ID(1),5,$L (IVMPID(1) ))
7379	"RTN","IVM PTRN8",232 ,0)
7380	D BLDPID^ IVMPREC6(. IVMPID,.AP ID)
7381	"RTN","IVM PTRN8",233 ,0)
7382	;
7383	"RTN","IVM PTRN8",234 ,0)
7384	S CAFLG=0
7385	"RTN","IVM PTRN8",235 ,0)
7386	I $D(APID (11)) D
7387	"RTN","IVM PTRN8",236 ,0)
7388	.I $O(API D(11,"")) D Q
7389	"RTN","IVM PTRN8",237 ,0)
7390	..M ZPID( 11)=APID(1 1) K APID( 11)
7391	"RTN","IVM PTRN8",238 ,0)
7392	..S (ASQ, SSQ)=0 F S ASQ=$O(Z PID(11,ASQ )) Q:ASQ=" " D
7393	"RTN","IVM PTRN8",239 ,0)
7394	...S ATYP =$P($G(ZPI D(11,ASQ)) ,$E(HLECH) ,7) Q:ATYP =""
7395	"RTN","IVM PTRN8",240 ,0)
7396	...I (ATY P="VACAA") !(ATYP="VA CAC")!(ATY P="VACAM") !(ATYP="VA CAO") Q
7397	"RTN","IVM PTRN8",241 ,0)
7398	...I ATYP ="VACAE" S CAFLG=1
7399	"RTN","IVM PTRN8",242 ,0)
7400	...S SSQ= SSQ+1,APID (11,SSQ)=Z PID(11,ASQ )
7401	"RTN","IVM PTRN8",243 ,0)
7402	.Q:$G(API D(11))=""
7403	"RTN","IVM PTRN8",244 ,0)
7404	.S ATYP=$ P($G(APID( 11)),$E(HL ECH),7) Q: ATYP=""
7405	"RTN","IVM PTRN8",245 ,0)
7406	.I ATYP=" VACAE" S C AFLG=1 Q
7407	"RTN","IVM PTRN8",246 ,0)
7408	.I (ATYP= "VACAA")!( ATYP="VACA C")!(ATYP= "VACAM")!( ATYP="VACA O") K APID (11)
7409	"RTN","IVM PTRN8",247 ,0)
7410	;
7411	"RTN","IVM PTRN8",248 ,0)
7412	I 'CAFLG, $D(APID(13 )) D
7413	"RTN","IVM PTRN8",249 ,0)
7414	.I $O(API D(13,"")) D Q
7415	"RTN","IVM PTRN8",250 ,0)
7416	..S ASQ=0 F S ASQ= $O(APID(13 ,ASQ)) Q:A SQ="" D
7417	"RTN","IVM PTRN8",251 ,0)
7418	...Q:$G(A PID(13,ASQ ))=""
7419	"RTN","IVM PTRN8",252 ,0)
7420	...S ATYP =$P($G(API D(13,ASQ)) ,$E(HLECH) ,2) Q:ATYP =""
7421	"RTN","IVM PTRN8",253 ,0)
7422	...I ATYP ="VACPN" K APID(13,A SQ) Q
7423	"RTN","IVM PTRN8",254 ,0)
7424	.Q:$G(API D(13))=""
7425	"RTN","IVM PTRN8",255 ,0)
7426	.S ATYP=$ P($G(APID( 13)),$E(HL ECH),2) Q: ATYP=""
7427	"RTN","IVM PTRN8",256 ,0)
7428	.I ATYP=" VACPN" K A PID(13) Q
7429	"RTN","IVM PTRN8",257 ,0)
7430	;
7431	"RTN","IVM PTRN8",258 ,0)
7432	;Rebuild PID
7433	"RTN","IVM PTRN8",259 ,0)
7434	D KVA^VAD PT
7435	"RTN","IVM PTRN8",260 ,0)
7436	D MAKEIT^ VAFHLU("PI D",.APID,. VAFPID,.VA FPID)
7437	"RTN","IVM PTRN8",261 ,0)
7438	S VAFPID( 0)=VAFPID
7439	"RTN","IVM PTRN8",262 ,0)
7440	Q
7441	"VER")
7442	8.0^22.2
7443	END
7444	END
		7445
		7446
		7447
		7448
		7449
		7450
		7451
		7452
		7453
		7454
		7455
		7456