1. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 3/19/2019 11:15:26 AM Eastern Daylight 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_P2_DG_5_3_914 v35.zip	DG_5_3_914 v35.KIDS	Tue Mar 19 13:06:30 2019 UTC
2	ESM_P2_DG_5_3_914 v35.zip	DG_5_3_914 v35.KIDS	Tue Mar 19 14:34:38 2019 UTC

1.2 Comparison summary

Description	Between Files 1 and 2
Description	Text Blocks	Lines
Unchanged	2	21086
Changed	1	2
Inserted	0	0
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	$END TXT
	2	$KID DG5. 3914
	3	INSTALL NAME
	4	DG5.3914
	5	"BLD",1132 8,0)
	6	DG5.3914 ^REGISTRAT ION^0^3190 205^y
	7	"BLD",1132 8,1,0)
	8	^^1^1^3181 018^^
	9	"BLD",1132 8,1,1,0)
	10	Please ref er to the patch desc ription fo r details.
	11	"BLD",1132 8,4,0)
	12	^9.64PA^40 5^3
	13	"BLD",1132 8,4,45,0)
	14	45
	15	"BLD",1132 8,4,45,2,0 )
	16	^9.641^45. 02^2
	17	"BLD",1132 8,4,45,2,4 5,0)
	18	PTF (File -top level )
	19	"BLD",1132 8,4,45,2,4 5,1,0)
	20	^9.6411^79 .33^1
	21	"BLD",1132 8,4,45,2,4 5,1,79.33, 0)
	22	TREATMENT FOR CAMP L EJEUNE
	23	"BLD",1132 8,4,45,2,4 5.02,0)
	24	501 (sub- file)
	25	"BLD",1132 8,4,45,2,4 5.02,1,0)
	26	^9.6411^33 ^1
	27	"BLD",1132 8,4,45,2,4 5.02,1,33, 0)
	28	TREATMENT FOR CAMP L EJEUNE
	29	"BLD",1132 8,4,45,222 )
	30	y^y^p^^^^n ^^n
	31	"BLD",1132 8,4,45,224 )
	32
	33	"BLD",1132 8,4,46.1,0 )
	34	46.1
	35	"BLD",1132 8,4,46.1,2 ,0)
	36	^9.641^46. 1^1
	37	"BLD",1132 8,4,46.1,2 ,46.1,0)
	38	INPATIENT POV (File -top level )
	39	"BLD",1132 8,4,46.1,2 ,46.1,1,0)
	40	^9.6411^.1 ^1
	41	"BLD",1132 8,4,46.1,2 ,46.1,1,.1 ,0)
	42	TREATMENT FOR CAMP L EJEUNE
	43	"BLD",1132 8,4,46.1,2 22)
	44	y^y^p^^^^n ^^n
	45	"BLD",1132 8,4,46.1,2 24)
	46
	47	"BLD",1132 8,4,405,0)
	48	405
	49	"BLD",1132 8,4,405,2, 0)
	50	^9.641^405 ^1
	51	"BLD",1132 8,4,405,2, 405,0)
	52	PATIENT MO VEMENT (F ile-top le vel)
	53	"BLD",1132 8,4,405,2, 405,1,0)
	54	^9.6411^29 ^1
	55	"BLD",1132 8,4,405,2, 405,1,29,0 )
	56	TREATMENT FOR CAMP L EJEUNE
	57	"BLD",1132 8,4,405,22 2)
	58	y^y^p^^^^n ^^n
	59	"BLD",1132 8,4,405,22 4)
	60
	61	"BLD",1132 8,4,"APDD" ,45,45)
	62
	63	"BLD",1132 8,4,"APDD" ,45,45,79. 33)
	64
	65	"BLD",1132 8,4,"APDD" ,45,45.02)
	66
	67	"BLD",1132 8,4,"APDD" ,45,45.02, 33)
	68
	69	"BLD",1132 8,4,"APDD" ,46.1,46.1 )
	70
	71	"BLD",1132 8,4,"APDD" ,46.1,46.1 ,.1)
	72
	73	"BLD",1132 8,4,"APDD" ,405,405)
	74
	75	"BLD",1132 8,4,"APDD" ,405,405,2 9)
	76
	77	"BLD",1132 8,4,"B",45 ,45)
	78
	79	"BLD",1132 8,4,"B",46 .1,46.1)
	80
	81	"BLD",1132 8,4,"B",40 5,405)
	82
	83	"BLD",1132 8,6)
	84	34^
	85	"BLD",1132 8,6.3)
	86	173
	87	"BLD",1132 8,"ABPKG")
	88	n
	89	"BLD",1132 8,"INI")
	90
	91	"BLD",1132 8,"INID")
	92	^n^n
	93	"BLD",1132 8,"INIT")
	94
	95	"BLD",1132 8,"KRN",0)
	96	^9.67PA^77 9.2^20
	97	"BLD",1132 8,"KRN",.4 ,0)
	98	.4
	99	"BLD",1132 8,"KRN",.4 01,0)
	100	.401
	101	"BLD",1132 8,"KRN",.4 02,0)
	102	.402
	103	"BLD",1132 8,"KRN",.4 02,"NM",0)
	104	^9.68A^13^ 12
	105	"BLD",1132 8,"KRN",.4 02,"NM",1, 0)
	106	DG101 F ILE #45^45 ^0
	107	"BLD",1132 8,"KRN",.4 02,"NM",2, 0)
	108	DG101F FILE #45^4 5^0
	109	"BLD",1132 8,"KRN",.4 02,"NM",4, 0)
	110	DG501 F ILE #45^45 ^0
	111	"BLD",1132 8,"KRN",.4 02,"NM",5, 0)
	112	DG501F FILE #45^4 5^0
	113	"BLD",1132 8,"KRN",.4 02,"NM",6, 0)
	114	DG801 F ILE #46.1^ 46.1^0
	115	"BLD",1132 8,"KRN",.4 02,"NM",7, 0)
	116	DGQWK F ILE #45^45 ^0
	117	"BLD",1132 8,"KRN",.4 02,"NM",8, 0)
	118	DGQWKF FILE #45^4 5^0
	119	"BLD",1132 8,"KRN",.4 02,"NM",9, 0)
	120	DG501-10D FILE #4 5^45^0
	121	"BLD",1132 8,"KRN",.4 02,"NM",10 ,0)
	122	DG501F-10D FILE # 45^45^0
	123	"BLD",1132 8,"KRN",.4 02,"NM",11 ,0)
	124	DGPM ADMIT FILE # 405^405^0
	125	"BLD",1132 8,"KRN",.4 02,"NM",12 ,0)
	126	DGPM ASIH ADMIT F ILE #405^4 05^0
	127	"BLD",1132 8,"KRN",.4 02,"NM",13 ,0)
	128	DGPM SPECI ALTY TRANS FER FIL E #405^405 ^0
	129	"BLD",1132 8,"KRN",.4 02,"NM","B ","DG101 FILE #45 ",1)
	130
	131	"BLD",1132 8,"KRN",.4 02,"NM","B ","DG101F FILE #4 5",2)
	132
	133	"BLD",1132 8,"KRN",.4 02,"NM","B ","DG501 FILE #45 ",4)
	134
	135	"BLD",1132 8,"KRN",.4 02,"NM","B ","DG501-1 0D FILE #45",9)
	136
	137	"BLD",1132 8,"KRN",.4 02,"NM","B ","DG501F FILE #4 5",5)
	138
	139	"BLD",1132 8,"KRN",.4 02,"NM","B ","DG501F- 10D FIL E #45",10)
	140
	141	"BLD",1132 8,"KRN",.4 02,"NM","B ","DG801 FILE #46 .1",6)
	142
	143	"BLD",1132 8,"KRN",.4 02,"NM","B ","DGPM AD MIT FIL E #405",11 )
	144
	145	"BLD",1132 8,"KRN",.4 02,"NM","B ","DGPM AS IH ADMIT FILE #40 5",12)
	146
	147	"BLD",1132 8,"KRN",.4 02,"NM","B ","DGPM SP ECIALTY TR ANSFER FILE #405" ,13)
	148
	149	"BLD",1132 8,"KRN",.4 02,"NM","B ","DGQWK FILE #45 ",7)
	150
	151	"BLD",1132 8,"KRN",.4 02,"NM","B ","DGQWKF FILE #4 5",8)
	152
	153	"BLD",1132 8,"KRN",.4 03,0)
	154	.403
	155	"BLD",1132 8,"KRN",.5 ,0)
	156	.5
	157	"BLD",1132 8,"KRN",.8 4,0)
	158	.84
	159	"BLD",1132 8,"KRN",3. 6,0)
	160	3.6
	161	"BLD",1132 8,"KRN",3. 8,0)
	162	3.8
	163	"BLD",1132 8,"KRN",9. 2,0)
	164	9.2
	165	"BLD",1132 8,"KRN",9. 8,0)
	166	9.8
	167	"BLD",1132 8,"KRN",9. 8,"NM",0)
	168	^9.68A^85^ 35
	169	"BLD",1132 8,"KRN",9. 8,"NM",2,0 )
	170	VADPT0^^0^ B14019831
	171	"BLD",1132 8,"KRN",9. 8,"NM",3,0 )
	172	VADPT4^^0^ B46948271
	173	"BLD",1132 8,"KRN",9. 8,"NM",6,0 )
	174	DGAPI1^^0^ B25401406
	175	"BLD",1132 8,"KRN",9. 8,"NM",16, 0)
	176	DGPTF^^0^B 25936099
	177	"BLD",1132 8,"KRN",9. 8,"NM",17, 0)
	178	DGPTF1^^0^ B43165446
	179	"BLD",1132 8,"KRN",9. 8,"NM",18, 0)
	180	DGPTFM^^0^ B88469796
	181	"BLD",1132 8,"KRN",9. 8,"NM",19, 0)
	182	DGPTFM4^^0 ^B49253177
	183	"BLD",1132 8,"KRN",9. 8,"NM",20, 0)
	184	DGPTFMO^^0 ^B45159824
	185	"BLD",1132 8,"KRN",9. 8,"NM",21, 0)
	186	DGPTFVC1^^ 0^B4342569 2
	187	"BLD",1132 8,"KRN",9. 8,"NM",22, 0)
	188	DGPTR0^^0^ B27460595
	189	"BLD",1132 8,"KRN",9. 8,"NM",24, 0)
	190	DGPTR4^^0^ B22236456
	191	"BLD",1132 8,"KRN",9. 8,"NM",25, 0)
	192	DGPTRI0^^0 ^B27777148
	193	"BLD",1132 8,"KRN",9. 8,"NM",27, 0)
	194	DGPTRI4^^0 ^B71363613
	195	"BLD",1132 8,"KRN",9. 8,"NM",55, 0)
	196	DGPTLMU6^^ 0^B9195265
	197	"BLD",1132 8,"KRN",9. 8,"NM",57, 0)
	198	DGPTUTL^^0 ^B23620117
	199	"BLD",1132 8,"KRN",9. 8,"NM",59, 0)
	200	DGPTFTR^^0 ^B55556979
	201	"BLD",1132 8,"KRN",9. 8,"NM",60, 0)
	202	DGPTSPQ^^0 ^B15523989
	203	"BLD",1132 8,"KRN",9. 8,"NM",64, 0)
	204	DGUTL3^^0^ B10396641
	205	"BLD",1132 8,"KRN",9. 8,"NM",65, 0)
	206	DGPTRNU^^0 ^B57891113
	207	"BLD",1132 8,"KRN",9. 8,"NM",66, 0)
	208	DGPTR1^^0^ B31569906
	209	"BLD",1132 8,"KRN",9. 8,"NM",67, 0)
	210	DGENCLEA^^ 0^B2305171 0
	211	"BLD",1132 8,"KRN",9. 8,"NM",68, 0)
	212	DGPTAEE2^^ 0^B3339982 5
	213	"BLD",1132 8,"KRN",9. 8,"NM",69, 0)
	214	DGPTAEE1^^ 0^B4331087 4
	215	"BLD",1132 8,"KRN",9. 8,"NM",70, 0)
	216	DGPTFFB^^0 ^B8592145
	217	"BLD",1132 8,"KRN",9. 8,"NM",71, 0)
	218	DGPTFCLV^^ 0^B1210177 8
	219	"BLD",1132 8,"KRN",9. 8,"NM",72, 0)
	220	DGPTFM2^^0 ^B54387133
	221	"BLD",1132 8,"KRN",9. 8,"NM",73, 0)
	222	DGPTFM21^^ 0^B1562382 9
	223	"BLD",1132 8,"KRN",9. 8,"NM",74, 0)
	224	DGPTFM3^^0 ^B19308986
	225	"BLD",1132 8,"KRN",9. 8,"NM",75, 0)
	226	DGPTFQWK^^ 0^B2791651 8
	227	"BLD",1132 8,"KRN",9. 8,"NM",76, 0)
	228	DGROHLR^^0 ^B19368133
	229	"BLD",1132 8,"KRN",9. 8,"NM",77, 0)
	230	DGRODEBR^^ 0^B6069333 2
	231	"BLD",1132 8,"KRN",9. 8,"NM",78, 0)
	232	DGPTRI1^^0 ^B48276824
	233	"BLD",1132 8,"KRN",9. 8,"NM",82, 0)
	234	DGPTSUDO^^ 0^B3518665 7
	235	"BLD",1132 8,"KRN",9. 8,"NM",84, 0)
	236	DGPTTS1^^0 ^B30655902
	237	"BLD",1132 8,"KRN",9. 8,"NM",85, 0)
	238	DGPTTS2^^0 ^B28542647
	239	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGAPI1", 6)
	240
	241	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGENCLEA ",67)
	242
	243	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTAEE1 ",69)
	244
	245	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTAEE2 ",68)
	246
	247	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTF",1 6)
	248
	249	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTF1", 17)
	250
	251	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTFCLV ",71)
	252
	253	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTFFB" ,70)
	254
	255	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTFM", 18)
	256
	257	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTFM2" ,72)
	258
	259	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTFM21 ",73)
	260
	261	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTFM3" ,74)
	262
	263	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTFM4" ,19)
	264
	265	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTFMO" ,20)
	266
	267	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTFQWK ",75)
	268
	269	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTFTR" ,59)
	270
	271	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTFVC1 ",21)
	272
	273	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTLMU6 ",55)
	274
	275	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTR0", 22)
	276
	277	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTR1", 66)
	278
	279	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTR4", 24)
	280
	281	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTRI0" ,25)
	282
	283	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTRI1" ,78)
	284
	285	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTRI4" ,27)
	286
	287	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTRNU" ,65)
	288
	289	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTSPQ" ,60)
	290
	291	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTSUDO ",82)
	292
	293	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTTS1" ,84)
	294
	295	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTTS2" ,85)
	296
	297	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGPTUTL" ,57)
	298
	299	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGRODEBR ",77)
	300
	301	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGROHLR" ,76)
	302
	303	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"DGUTL3", 64)
	304
	305	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"VADPT0", 2)
	306
	307	"BLD",1132 8,"KRN",9. 8,"NM","B" ,"VADPT4", 3)
	308
	309	"BLD",1132 8,"KRN",19 ,0)
	310	19
	311	"BLD",1132 8,"KRN",19 ,"NM",0)
	312	^9.68A^^
	313	"BLD",1132 8,"KRN",19 .1,0)
	314	19.1
	315	"BLD",1132 8,"KRN",10 1,0)
	316	101
	317	"BLD",1132 8,"KRN",10 1,"NM",0)
	318	^9.68A^^0
	319	"BLD",1132 8,"KRN",40 9.61,0)
	320	409.61
	321	"BLD",1132 8,"KRN",77 1,0)
	322	771
	323	"BLD",1132 8,"KRN",77 9.2,0)
	324	779.2
	325	"BLD",1132 8,"KRN",87 0,0)
	326	870
	327	"BLD",1132 8,"KRN",89 89.51,0)
	328	8989.51
	329	"BLD",1132 8,"KRN",89 89.52,0)
	330	8989.52
	331	"BLD",1132 8,"KRN",89 94,0)
	332	8994
	333	"BLD",1132 8,"KRN","B ",.4,.4)
	334
	335	"BLD",1132 8,"KRN","B ",.401,.40 1)
	336
	337	"BLD",1132 8,"KRN","B ",.402,.40 2)
	338
	339	"BLD",1132 8,"KRN","B ",.403,.40 3)
	340
	341	"BLD",1132 8,"KRN","B ",.5,.5)
	342
	343	"BLD",1132 8,"KRN","B ",.84,.84)
	344
	345	"BLD",1132 8,"KRN","B ",3.6,3.6)
	346
	347	"BLD",1132 8,"KRN","B ",3.8,3.8)
	348
	349	"BLD",1132 8,"KRN","B ",9.2,9.2)
	350
	351	"BLD",1132 8,"KRN","B ",9.8,9.8)
	352
	353	"BLD",1132 8,"KRN","B ",19,19)
	354
	355	"BLD",1132 8,"KRN","B ",19.1,19. 1)
	356
	357	"BLD",1132 8,"KRN","B ",101,101)
	358
	359	"BLD",1132 8,"KRN","B ",409.61,4 09.61)
	360
	361	"BLD",1132 8,"KRN","B ",771,771)
	362
	363	"BLD",1132 8,"KRN","B ",779.2,77 9.2)
	364
	365	"BLD",1132 8,"KRN","B ",870,870)
	366
	367	"BLD",1132 8,"KRN","B ",8989.51, 8989.51)
	368
	369	"BLD",1132 8,"KRN","B ",8989.52, 8989.52)
	370
	371	"BLD",1132 8,"KRN","B ",8994,899 4)
	372
	373	"BLD",1132 8,"QDEF")
	374	^^^^NO^^^^ NO^^YES
	375	"BLD",1132 8,"QUES",0 )
	376	^9.62^^
	377	"BLD",1132 8,"REQB",0 )
	378	^9.611^14^ 7
	379	"BLD",1132 8,"REQB",3 ,0)
	380	DG5.3909 ^1
	381	"BLD",1132 8,"REQB",5 ,0)
	382	DG5.3653 ^1
	383	"BLD",1132 8,"REQB",6 ,0)
	384	DG5.3749 ^1
	385	"BLD",1132 8,"REQB",1 0,0)
	386	DG5.3884 ^1
	387	"BLD",1132 8,"REQB",1 2,0)
	388	DG5.3887 ^1
	389	"BLD",1132 8,"REQB",1 3,0)
	390	DG5.3935 ^1
	391	"BLD",1132 8,"REQB",1 4,0)
	392	DG5.3912 ^1
	393	"BLD",1132 8,"REQB"," B","DG5.3 653",5)
	394
	395	"BLD",1132 8,"REQB"," B","DG5.3 749",6)
	396
	397	"BLD",1132 8,"REQB"," B","DG5.3 884",10)
	398
	399	"BLD",1132 8,"REQB"," B","DG5.3 887",12)
	400
	401	"BLD",1132 8,"REQB"," B","DG5.3 909",3)
	402
	403	"BLD",1132 8,"REQB"," B","DG5.3 912",14)
	404
	405	"BLD",1132 8,"REQB"," B","DG5.3 935",13)
	406
	407	"FIA",45)
	408	PTF
	409	"FIA",45,0 )
	410	^DGPT(
	411	"FIA",45,0 ,0)
	412	45IP
	413	"FIA",45,0 ,1)
	414	y^y^p^^^^n ^^n
	415	"FIA",45,0 ,10)
	416
	417	"FIA",45,0 ,11)
	418
	419	"FIA",45,0 ,"RLRO")
	420
	421	"FIA",45,0 ,"VR")
	422	5.3^DG
	423	"FIA",45,4 5)
	424	1
	425	"FIA",45,4 5,79.33)
	426
	427	"FIA",45,4 5.02)
	428	1
	429	"FIA",45,4 5.02,33)
	430
	431	"FIA",46.1 )
	432	INPATIENT POV
	433	"FIA",46.1 ,0)
	434	^DGICD9(46 .1,
	435	"FIA",46.1 ,0,0)
	436	46.1P
	437	"FIA",46.1 ,0,1)
	438	y^y^p^^^^n ^^n
	439	"FIA",46.1 ,0,10)
	440
	441	"FIA",46.1 ,0,11)
	442
	443	"FIA",46.1 ,0,"RLRO")
	444
	445	"FIA",46.1 ,0,"VR")
	446	5.3^DG
	447	"FIA",46.1 ,46.1)
	448	1
	449	"FIA",46.1 ,46.1,.1)
	450
	451	"FIA",405)
	452	PATIENT MO VEMENT
	453	"FIA",405, 0)
	454	^DGPM(
	455	"FIA",405, 0,0)
	456	405ID
	457	"FIA",405, 0,1)
	458	y^y^p^^^^n ^^n
	459	"FIA",405, 0,10)
	460
	461	"FIA",405, 0,11)
	462
	463	"FIA",405, 0,"RLRO")
	464
	465	"FIA",405, 0,"VR")
	466	5.3^DG
	467	"FIA",405, 405)
	468	1
	469	"FIA",405, 405,29)
	470
	471	"KRN",.402 ,183,-1)
	472	0^1
	473	"KRN",.402 ,183,0)
	474	DG101^3180 731.0802^^ 45^^^31902 03
	475	"KRN",.402 ,183,"DIAB ",1,0,45,2 )
	476	PATIENT MO VEMENT:
	477	"KRN",.402 ,183,"DIAB ",1,2,2.02 ,0)
	478	.01;"RACE"
	479	"KRN",.402 ,183,"DIAB ",1,2,2.06 ,0)
	480	.01;"ETHNI CITY"
	481	"KRN",.402 ,183,"DIAB ",2,0,45,1 )
	482	PATIENT:
	483	"KRN",.402 ,183,"DIAB ",4,1,2,0)
	484	6;"ETHNICI TY"
	485	"KRN",.402 ,183,"DIAB ",5,1,2,0)
	486	2;"RACE"
	487	"KRN",.402 ,183,"DIAB ",6,0,45,0 )
	488	SOURCE OF ADMISSION; REQ
	489	"KRN",.402 ,183,"DR", 1,45)
	490	S:+DGJUMP' =1 Y="@99" ;@1;S DGJU MP=$P(DGJU MP,"1,",2) ;3//^S X=$ P($$SITE^V ASITE,U,3) ;5;20R~;22 ;21.1;21.2 ;20.1////^ S X=$$ELIG ^DGUTL3(DF N,1,$P($G( ^DGPT(DA,1 01)),U,8)) ;I DGPTFMT >1 S Y="@1 0";23;@10; S:+DGJUMP' =2 Y="@99" ;@2;@3;@4;
	491	"KRN",.402 ,183,"DR", 1,45,1)
	492	S DGCLV=DG JUMP;^2^DP T(^^S I(0, 0)=D0 S Y( 1)=$S($D(^ DGPT(D0,0) ):^(0),1:" ") S X=$P( Y(1),U,1), X=X S D(0 )=+X S X=$ S(D(0)>0:D (0),1:""); S:(+$G(DGC LV)=2)!(+$ G(DGCLV)=4 ) Y="@99"; S:$$GETCL^ DGUTL3(DFN )'=1 Y="@3 9";
	493	"KRN",.402 ,183,"DR", 1,45,2)
	494	^405^DGPM( ^^S I(0,0) =$G(D0),D0 =$O(^DGPM( "APTF",I(0 ,0),0)) S: $O(^(D0))> 0 D0=0 S X =$S(D0>0:D 0,1:""),D( 0)=X S D0= I(0,0) S X =$S(D(0)>0 :D(0),1:"" );@39;S:+D GJUMP'=5 Y ="@99";@5; S DGJUMP=$ P(DGJUMP," 5,",2);75; S:+DGJUMP' =6 Y="@99" ;@6;
	495	"KRN",.402 ,183,"DR", 1,45,3)
	496	S DGJUMP=$ P(DGJUMP," 6,",2);73; 74;S:DGJUM P'=7 Y="@9 9";@7;S DG JUMP=$P(DG JUMP,"7,", 2);76.1;76 .2;78;77;@ 99;K DGCLV ;S:+DGJUMP Y="@"_+DG JUMP;
	497	"KRN",.402 ,183,"DR", 2,2)
	498	S:+DGJUMP' =2 Y="@991 ";S DGJUMP =$P(DGJUMP ,"2,",2);. 05;6ETHNIC ITY~;2RACE ~;57.4;S:+ DGJUMP'=3 Y="@991";@ 31;S DGJUM P=$P(DGJUM P,"3,",2); .32101;.32 102;S:X'=" Y" Y=.3210 3;.3213;.3 2103;S:X'= "Y" Y="@32 ";.3212;@3 2;.525;S:X '="Y" Y="@ 42";.526;
	499	"KRN",.402 ,183,"DR", 2,2,1)
	500	@42;S:+DGJ UMP'=4 Y=" @991";@41; S DGJUMP=$ P(DGJUMP," 4,",2);@99 1;I +DGJUM P>2&(+DGJU MP<5) S Y= "@"_+DGJUM P_1;
	501	"KRN",.402 ,183,"DR", 2,405)
	502	D PTF101^D GPTFCLV;
	503	"KRN",.402 ,183,"DR", 3,2.02)
	504	.01RACE~;I $P($G(^DI C(10.3,+$P ($G(^DPT(D A(1),.02,D A,0)),"^", 2),0)),"^" ,2)="S" S Y="@21";.0 2;@21;
	505	"KRN",.402 ,183,"DR", 3,2.06)
	506	.01ETHNICI TY~;I $P($ G(^DIC(10. 3,+$P($G(^ DPT(DA(1), .06,DA,0)) ,"^",2),0) ),"^",2)=" S" S Y="@6 1";.02;@61 ;
	507	"KRN",.402 ,183,"DR", 99,1)
	508	S I(0,0)=$ G(D0),D0=$ O(^DGPM("A PTF",I(0,0 ),0)) S:$O (^(D0))>0 D0=0 S X=$ S(D0>0:D0, 1:""),D(0) =X S D0=I( 0,0)
	509	"KRN",.402 ,183,"DR", 99,1,9.2)
	510	N DIADD,DI C S DIC=40 5,DIC(0)=" ",DIC("S") ="I $D(^DG PM(""APTF" ","_I(0,0) _",Y))" D ^DIC S D0= +Y,DIC(.16 )=I(0,0),D IH=405 D D ICL^DICR:$ P(Y,U,3)
	511	"KRN",.402 ,183,"ROU" )
	512	^DGPTX1
	513	"KRN",.402 ,183,"ROUO LD")
	514	DGPTX1
	515	"KRN",.402 ,216,-1)
	516	0^2
	517	"KRN",.402 ,216,0)
	518	DG101F^317 1226.1104^ ^45^^^3190 116
	519	"KRN",.402 ,216,"DIAB ",1,2,2.02 ,0)
	520	.01;"RACE"
	521	"KRN",.402 ,216,"DIAB ",1,2,2.06 ,0)
	522	.01;"ETHNI CITY"
	523	"KRN",.402 ,216,"DIAB ",2,0,45,1 )
	524	PATIENT:
	525	"KRN",.402 ,216,"DIAB ",4,1,2,0)
	526	6;"ETHNICI TY"
	527	"KRN",.402 ,216,"DIAB ",5,1,2,0)
	528	2;"RACE"
	529	"KRN",.402 ,216,"DIAB ",6,0,45,0 )
	530	20;REQ
	531	"KRN",.402 ,216,"DR", 1,45)
	532	S:+DGJUMP' =1 Y="@99" ;@1;S DGJU MP=$P(DGJU MP,"1,",2) ;3//^S X=$ P($$SITE^V ASITE,U,3) ;5;20R~;22 ;21.1;21.2 ;20.1////^ S X=$$ELIG ^DGUTL3(DF N,1,$P($G( ^DGPT(DA,1 01)),U,8)) ;I DGPTFMT >1 S Y="@1 0";23;@10; S:+DGJUMP' =2 Y="@99" ;@2;@3;@4;
	533	"KRN",.402 ,216,"DR", 1,45,1)
	534	S DGCLV=DG JUMP;^2^DP T(^^S I(0, 0)=D0 S Y( 1)=$S($D(^ DGPT(D0,0) ):^(0),1:" ") S X=$P( Y(1),U,1), X=X S D(0 )=+X S X=$ S(D(0)>0:D (0),1:""); S:(+$G(DGC LV)=2)!(+$ G(DGCLV)=4 ) Y="@99"; S:$$GETCL^ DGUTL3(DFN )'=1 Y="@3 7";D PTF10 1F^DGPTFCL V;@37;
	535	"KRN",.402 ,216,"DR", 1,45,2)
	536	S:+DGJUMP' =5 Y="@99" ;@5;S DGJU MP=$P(DGJU MP,"5,",2) ;70;71;72; 72.1;75;10 ;S:+DGJUMP '=6 Y="@99 ";@6;S DGJ UMP=$P(DGJ UMP,"6,",2 );73;74;S: DGJUMP'=7 Y="@99";@7 ;S DGJUMP= $P(DGJUMP, "7,",2);76 .1;76.2;78 ;77;@99;S: +DGJUMP Y= "@"_+DGJUM P;
	537	"KRN",.402 ,216,"DR", 2,2)
	538	S:+DGJUMP' =2 Y="@991 ";S DGJUMP =$P(DGJUMP ,"2,",2);. 05;6ETHNIC ITY~;2RACE ~;57.4;S:+ DGJUMP'=3 Y="@991";@ 31;S DGJUM P=$P(DGJUM P,"3,",2); .32101;.32 102;S:X'=" Y" Y=.3210 3;.3213;.3 2103;S:X'= "Y" Y="@32 ";.3212;@3 2;.525;S:X '="Y" Y="@ 42";.526;
	539	"KRN",.402 ,216,"DR", 2,2,1)
	540	@42;S:+DGJ UMP'=4 Y=" @991";@41; S DGJUMP=$ P(DGJUMP," 4,",2);@99 1;I +DGJUM P>2&(+DGJU MP<5) S Y= "@"_+DGJUM P_1;
	541	"KRN",.402 ,216,"DR", 3,2.02)
	542	.01RACE~;I $P($G(^DI C(10.3,+$P ($G(^DPT(D A(1),.02,D A,0)),"^", 2),0)),"^" ,2)="S" S Y="@21";.0 2;@21;
	543	"KRN",.402 ,216,"DR", 3,2.06)
	544	.01ETHNICI TY~;I $P($ G(^DIC(10. 3,+$P($G(^ DPT(DA(1), .06,DA,0)) ,"^",2),0) ),"^",2)=" S" S Y="@6 1";.02;@61 ;
	545	"KRN",.402 ,220,-1)
	546	0^5
	547	"KRN",.402 ,220,0)
	548	DG501F^318 1009.1617^ ^45^^^3130 328
	549	"KRN",.402 ,220,"AR", 45.02,440)
	550	1^DGX5F4
	551	"KRN",.402 ,220,"AR", 45.02,441)
	552	2^DGX5F4
	553	"KRN",.402 ,220,"AR", 45.02,442)
	554	3^DGX5F4
	555	"KRN",.402 ,220,"AR", 45.02,443)
	556	4^DGX5F4
	557	"KRN",.402 ,220,"AR", 45.02,444)
	558	5^DGX5F4
	559	"KRN",.402 ,220,"AR", 45.02,445)
	560	6^DGX5F4
	561	"KRN",.402 ,220,"AR", 45.02,446)
	562	7^DGX5F4
	563	"KRN",.402 ,220,"AR", 45.02,447)
	564	8^DGX5F4
	565	"KRN",.402 ,220,"AR", 45.02,448)
	566	9^DGX5F4
	567	"KRN",.402 ,220,"AR", 45.02,449)
	568	10^DGX5F4
	569	"KRN",.402 ,220,"AR", 45.02,460)
	570	11^DGX5F4
	571	"KRN",.402 ,220,"AR", 45.02,461)
	572	12^DGX5F4
	573	"KRN",.402 ,220,"AR", 45.02,464)
	574	13^DGX5F4
	575	"KRN",.402 ,220,"AR", 45.02,1225 )
	576	14^DGX5F4
	577	"KRN",.402 ,220,"AR", 45.02,1226 )
	578	15^DGX5F4
	579	"KRN",.402 ,220,"AR", 45.02,1227 )
	580	16^DGX5F4
	581	"KRN",.402 ,220,"AR", 45.02,1228 )
	582	17^DGX5F4
	583	"KRN",.402 ,220,"AR", 45.02,1229 )
	584	18^DGX5F4
	585	"KRN",.402 ,220,"AR", 45.02,1230 )
	586	19^DGX5F4
	587	"KRN",.402 ,220,"AR", 45.02,1231 )
	588	20^DGX5F4
	589	"KRN",.402 ,220,"AR", 45.02,1232 )
	590	21^DGX5F4
	591	"KRN",.402 ,220,"AR", 45.02,1233 )
	592	22^DGX5F4
	593	"KRN",.402 ,220,"AR", 45.02,1234 )
	594	23^DGX5F4
	595	"KRN",.402 ,220,"AR", 45.02,1235 )
	596	24^DGX5F4
	597	"KRN",.402 ,220,"AR", 45.02,1236 )
	598	25^DGX5F4
	599	"KRN",.402 ,220,"DIAB ",1,1,45.0 2,1)
	600	TREATED FO R SC CONDI TION//NO;" WAS TREATM ENT FOR A SERVICE CO NNECTED CO NDITION?"
	601	"KRN",.402 ,220,"DIAB ",1,1,45.0 2,10)
	602	TREATED FO R AO CONDI TION;"WAS TREATMENT RELATED TO AGENT ORA NGE EXPOSU RE?"
	603	"KRN",.402 ,220,"DIAB ",1,1,45.0 2,11)
	604	EXPOSED TO SW ASIA C ONDITIONS; "WAS TREAT MENT RELAT ED TO SERV ICE IN SW ASIA?"
	605	"KRN",.402 ,220,"DIAB ",1,1,45.0 2,12)
	606	29;"WAS TR EATMENT RE LATED TO M ILITARY SE XUAL TRAUM A?"
	607	"KRN",.402 ,220,"DIAB ",5,1,45.0 2,9)
	608	POTENTIALL Y RELATED TO COMBAT/ /YES;"WAS TREATMENT RELATED TO COMBAT?"
	609	"KRN",.402 ,220,"DIAB ",7,1,45.0 2,10)
	610	TREATED FO R IR CONDI TION;"WAS TREATMENT RELATED TO IONIZING RADIATION EXPOSURE?"
	611	"KRN",.402 ,220,"DIAB ",7,1,45.0 2,11)
	612	32;"WAS TR EATMENT RE LATED TO P ROJ 112/SH AD?"
	613	"KRN",.402 ,220,"DIAB ",7,1,45.0 2,12)
	614	30;"WAS TR EATMENT RE LATED TO H EAD AND/OR NECK CANC ER?"
	615	"KRN",.402 ,220,"DIAB ",7,1,45.0 2,13)
	616	33//"NO";" WAS TREATM ENT RELATE D TO CAMP LEJEUNE?"
	617	"KRN",.402 ,220,"DR", 1,45)
	618	F X=2:1:7 S DGDUP(X) =0;K DGPTI T;I $G(DGP TF)<1 S DG PTF=D0 W ! !,"Editing PTF Recor d "_DGPTF_ " in VA Fi leManager. ";I $G(DGM OV)<1 S DG MOV=1 W !! ,"Editing Discharge Movement i n VA FileM anager";I $G(DFN)<1 S DFN=+$G( ^DGPT(D0,0 ));
	619	"KRN",.402 ,220,"DR", 1,45,1)
	620	D CENSUS^D GPTIC10(DA );S DGJUMP =$G(DGJUMP );S DGXX=" ",DGTYPE=$ P(^DGPT(D0 ,0),U,11), DGCODSYS=$ $CODESYS^D GPTIC10(D0 );S DGHOLD =$S($D(^DG PT(DGPTF," M",+DGMOV, 0)):^(0),1 :"");S:'$D (DGADD) DG ADD=0;S DG NFLD="@10" ;50///^S X =+DGMOV;
	621	"KRN",.402 ,220,"DR", 2,45.02)
	622	S:DGJUMP'[ 1 Y="@2";1 0;@10;S DG NFLD="@15" ;2;@15;S D GNFLD="@16 ";3;@16;S DGNFLD="@1 7";4;@17;S :DGJUMP'[2 Y=0;@2;I $D(^DPT(+^ DGPT(DGPTF ,0),.3)),$ P(^(.3),U) ="Y" S (DG NFLD,Y)="@ 25";18//// ^S X=2;S ( DGNFLD,Y)= "@27";@25;
	623	"KRN",.402 ,220,"DR", 2,45.02,1)
	624	18WAS TREA TMENT FOR A SERVICE CONNECTED CONDITION? ~//NO;I X= "YES" S DG SC=1;@27;S DGNFLD="@ 28";S Y="@ 9000";@28; S DGNFLD=" @40";5;S D GXX=X;I DG CODSYS="IC D9"!(DGTYP E=2)!(DGXX ="") S Y=" @26";82.01 ;@26;S X=D GXX;
	625	"KRN",.402 ,220,"DR", 2,45.02,2)
	626	I X K DGPT IT S DGNFL D="@40",Y= "@8000",DG PTIT(X_$C( 59)_"ICD9( ")="";@40; I DGADD,$P (DGHOLD,U, 6)]"" S Y= "@50";S DG NFLD="@50" ;6;S DGXX= X;I DGCODS YS="ICD9"! (DGTYPE=2) !(DGXX="") S Y="@41" ;82.02;@41 ;S X=DGXX;
	627	"KRN",.402 ,220,"DR", 2,45.02,3)
	628	I X K DGPT IT S DGNFL D="@50",Y= "@8000",DG PTIT(X_$C( 59)_"ICD9( ")="";@50; I DGADD,$P (DGHOLD,U, 7)]"" S Y= "@60";S DG NFLD="@60" ;7;S DGXX= X;I DGCODS YS="ICD9"! (DGTYPE=2) !(DGXX="") S Y="@51" ;82.03;@51 ;S X=DGXX;
	629	"KRN",.402 ,220,"DR", 2,45.02,4)
	630	I X K DGPT IT S DGNFL D="@60",Y= "@8000",DG PTIT(X_$C( 59)_"ICD9( ")="";@60; I DGADD,$P (DGHOLD,U, 8)]"" S Y= "@70";S DG NFLD="@70" ;8;S DGXX= X;I DGCODS YS="ICD9"! (DGTYPE=2) !(DGXX="") S Y="@61" ;82.04;@61 ;S X=DGXX;
	631	"KRN",.402 ,220,"DR", 2,45.02,5)
	632	I X K DGPT IT S DGNFL D="@70",Y= "@8000",DG PTIT(X_$C( 59)_"ICD9( ")="";@70; I DGADD,$P (DGHOLD,U, 9)]"" S Y= "@80";S DG NFLD="@80" ;9;S DGXX= X;I DGCODS YS="ICD9"! (DGTYPE=2) !(DGXX="") S Y="@71" ;82.05;@71 ;S X=DGXX;
	633	"KRN",.402 ,220,"DR", 2,45.02,6)
	634	I X K DGPT IT S DGNFL D="@80",Y= "@8000",DG PTIT(X_$C( 59)_"ICD9( ")="";@80; K DGNFLD,D GDUP,DGADD ,DGXX,DGCO DSYS S Y=" ";@8000;D SCAN^DGPTS CAN S:'$D( DGBPC) Y=" @8990";I ' $D(DGBPC(2 ))!(DGDUP( 2)) S Y="@ 8200";300. 02;S:X]"" DGDUP(2)=1 ;@8200;
	635	"KRN",.402 ,220,"DR", 2,45.02,7)
	636	I '$D(DGBP C(3))!(DGD UP(3)) S Y ="@8300";3 00.03;S:X] "" DGDUP(3 )=1;@8300; I '$D(DGBP C(4))!(DGD UP(4)) S Y ="@8400";D DRUG^DGPT SC01 I $D( DGTX) S Y= "@8350";30 0.04;S:X]" " DGDUP(4) =1;S Y="@8 400";@8350 ;300.04//^ S X=DGTX;S :X]"" DGDU P(4)=1;
	637	"KRN",.402 ,220,"DR", 2,45.02,8)
	638	@8400;I '$ D(DGBPC(5) )!(DGDUP(5 )) S Y="@8 500";300.0 5;S:X]"" D GDUP(5)=1; @8500;I '$ D(DGBPC(6) )!(DGDUP(6 )) S Y="@8 600";300.0 6;S:X]"" D GDUP(6)=1; @8600;I '$ D(DGBPC(7) )!(DGDUP(7 )) S Y="@8 990";300.0 7;S:X]"" D GDUP(7)=1; @8990;
	639	"KRN",.402 ,220,"DR", 2,45.02,9)
	640	K DGPTIT S Y=DGNFLD; @9000;K DG EXQ D CHQU ES^DGPTSPQ I '$D(DGE XQ) S Y="@ 9999";I '$ D(DGEXQ(6) ) S Y="@90 40";31WAS TREATMENT RELATED TO COMBAT?~/ /YES;S Y=" @9050";@90 40;31///@; @9050;I '$ D(DGEXQ(1) ) S Y="@91 00";
	641	"KRN",.402 ,220,"DR", 2,45.02,10 )
	642	26WAS TREA TMENT RELA TED TO AGE NT ORANGE EXPOSURE?~ ;S Y="@915 0";@9100;2 6///@;@915 0;I '$D(DG EXQ(2)) S Y="@9200"; 27WAS TREA TMENT RELA TED TO ION IZING RADI ATION EXPO SURE?~;S Y ="@9250";@ 9200;27/// @;@9250;I '$D(DGEXQ( 3)) S Y="@ 9300";
	643	"KRN",.402 ,220,"DR", 2,45.02,11 )
	644	28WAS TREA TMENT RELA TED TO SER VICE IN SW ASIA?~;S Y="@9350"; @9300;28// /@;@9350;I '$D(DGEXQ (7)) S Y=" @9400";32W AS TREATME NT RELATED TO PROJ 1 12/SHAD?~; S Y="@9450 ";@9400;32 ///@;@9450 ;I '$D(DGE XQ(4)) S Y ="@9500";
	645	"KRN",.402 ,220,"DR", 2,45.02,12 )
	646	29WAS TREA TMENT RELA TED TO MIL ITARY SEXU AL TRAUMA? ~;S Y="@95 50";@9500; 29///@;@95 50;I '$D(D GEXQ(5)) S Y="@9600" ;30WAS TRE ATMENT REL ATED TO HE AD AND/OR NECK CANCE R?~;I X["Y ",$D(DFN), $$FILEHNC^ DGNTAPI1(D FN);S Y="@ 9650";@960 0;30///@;
	647	"KRN",.402 ,220,"DR", 2,45.02,13 )
	648	@9650;I '$ D(DGEXQ(8) ) S Y="@97 00";I $G(D GSC)=1 S Y ="@9700";S :$$GETCL^D GUTL3(DFN) '=1 Y="@97 00";I $P(^ DGPT(DGPTF ,"M",+$G(D GMOV),0),U ,18)=1 S Y ="@9700";Q ;33WAS TRE ATMENT REL ATED TO CA MP LEJEUNE ?~//^S X=" NO";S Y="@ 9750";@970 0;33///@;
	649	"KRN",.402 ,220,"DR", 2,45.02,14 )
	650	@9750;@999 9;K DGEXQ S Y=DGNFLD ;@99999;
	651	"KRN",.402 ,220,"ROU" )
	652	^DGX5F
	653	"KRN",.402 ,220,"ROUO LD")
	654	DGX5F
	655	"KRN",.402 ,221,-1)
	656	0^4
	657	"KRN",.402 ,221,0)
	658	DG501^3181 010.1028^^ 45^^^31901 16
	659	"KRN",.402 ,221,"AR", 45.02,440)
	660	1^DGPTX53
	661	"KRN",.402 ,221,"AR", 45.02,441)
	662	2^DGPTX53
	663	"KRN",.402 ,221,"AR", 45.02,442)
	664	3^DGPTX53
	665	"KRN",.402 ,221,"AR", 45.02,443)
	666	4^DGPTX53
	667	"KRN",.402 ,221,"AR", 45.02,444)
	668	5^DGPTX53
	669	"KRN",.402 ,221,"DIAB ",1,1,45.0 2,1)
	670	18;"WAS TR EATMENT FO R A SERVIC E CONNECTE D CONDITIO N?"//NO
	671	"KRN",.402 ,221,"DIAB ",2,1,45.0 2,12)
	672	29;"WAS TR EATMENT RE LATED TO M ILITARY SE XUAL TRAUM A?"
	673	"KRN",.402 ,221,"DIAB ",5,1,45.0 2,10)
	674	26;"WAS TR EATMENT RE LATED TO A GENT ORANG E EXPOSURE ?"
	675	"KRN",.402 ,221,"DIAB ",5,1,45.0 2,11)
	676	28;"WAS TR EATMENT RE LATED TO S ERVICE IN SW ASIA?"
	677	"KRN",.402 ,221,"DIAB ",8,1,45.0 2,12)
	678	30;"WAS TR EATMENT RE LATED TO H EAD AND/OR NECK CANC ER?"
	679	"KRN",.402 ,221,"DIAB ",9,1,45.0 2,9)
	680	31;"WAS TR EATMENT RE LATED TO C OMBAT?"/// YES
	681	"KRN",.402 ,221,"DIAB ",10,1,45. 02,13)
	682	33//"NO";" WAS TREATM ENT RELATE D TO CAMP LEJEUNE?"
	683	"KRN",.402 ,221,"DIAB ",11,1,45. 02,10)
	684	27;"WAS TR EATMENT RE LATED TO I ONIZING RA DIATION EX POSURE?"
	685	"KRN",.402 ,221,"DIAB ",11,1,45. 02,11)
	686	32;"WAS TR EATMENT RE LATED TO P ROJ 112/SH AD?"
	687	"KRN",.402 ,221,"DR", 1,45)
	688	F X=2:1:7 S DGDUP(X) =0;K DGPTI T;I $G(DGP TF)<1 S DG PTF=D0 W ! !,"Editing PTF Recor d "_DGPTF_ " in VA Fi leManager. ";I $G(DGM OV)<1 S DG MOV=1 W !! ,"Editing Discharge Movement i n VA FileM anager";I $G(DFN)<1 S DFN=+$G( ^DGPT(D0,0 ));
	689	"KRN",.402 ,221,"DR", 1,45,1)
	690	D CENSUS^D GPTIC10(DA );S DGJUMP =$G(DGJUMP );S DGXX=" ",DGTYPE=$ P(^DGPT(D0 ,0),U,11), DGCODSYS=$ $CODESYS^D GPTIC10(D0 );S DGHOLD =$S($D(^DG PT(DGPTF," M",+DGMOV, 0)):^(0),1 :"");50/// ^S X=+DGMO V;
	691	"KRN",.402 ,221,"DR", 2,45.02)
	692	S:'$D(DGAD D) DGADD=0 ;S:DGJUMP' [1 Y="@2"; S:DGADD Y= "@20";S DG NFLD="@10" ;3;@10;S D GNFLD="@15 ";4;I $D(^ DPT(+^DGPT (DGPTF,0), .3)),$P(^( .3),U)="Y" S Y="@15" ;18////^S X=2;S (DGN FLD,Y)="@2 0";@15;
	693	"KRN",.402 ,221,"DR", 2,45.02,1)
	694	18WAS TREA TMENT FOR A SERVICE CONNECTED CONDITION? ~;I X="YES " S DGSC=1 ;@20;S:DGJ UMP'[2 Y=" ";@2;S DGN FLD="@25"; S Y="@9000 ";@25;I DG ADD,$P(DGH OLD,U,5)]" " S Y="@40 ";S DGNFLD ="@40";5;S DGXX=X;
	695	"KRN",.402 ,221,"DR", 2,45.02,2)
	696	I DGCODSYS ="ICD9"!(D GTYPE=2)!( DGXX="") S Y="@26";8 2.01;@26;S X=DGXX;I X K DGPTIT S DGNFLD= "@40",Y="@ 8000",DGPT IT(X_$C(59 )_"ICD9(") ="";@40;I DGADD,$P(D GHOLD,U,6) ]"" S Y="@ 50";S DGNF LD="@50";6 ;S DGXX=X;
	697	"KRN",.402 ,221,"DR", 2,45.02,3)
	698	I DGCODSYS ="ICD9"!(D GTYPE=2)!( DGXX="") S Y="@41";8 2.02;@41;S X=DGXX;I X K DGPTIT S DGNFLD= "@50",Y="@ 8000",DGPT IT(X_$C(59 )_"ICD9(") ="";@50;I DGADD,$P(D GHOLD,U,7) ]"" S Y="@ 60";S DGNF LD="@60";7 ;S DGXX=X;
	699	"KRN",.402 ,221,"DR", 2,45.02,4)
	700	I DGCODSYS ="ICD9"!(D GTYPE=2)!( DGXX="") S Y="@51";8 2.03;@51;S X=DGXX;I X K DGPTIT S DGNFLD= "@60",Y="@ 8000",DGPT IT(X_$C(59 )_"ICD9(") ="";@60;I DGADD,$P(D GHOLD,U,8) ]"" S Y="@ 70";S DGNF LD="@70";8 ;S DGXX=X;
	701	"KRN",.402 ,221,"DR", 2,45.02,5)
	702	I DGCODSYS ="ICD9"!(D GTYPE=2)!( DGXX="") S Y="@61";8 2.04;@61;S X=DGXX;I X K DGPTIT S DGNFLD= "@70",Y="@ 8000",DGPT IT(X_$C(59 )_"ICD9(") ="";@70;I DGADD,$P(D GHOLD,U,9) ]"" S Y="@ 80";S DGNF LD="@80";9 ;S DGXX=X;
	703	"KRN",.402 ,221,"DR", 2,45.02,6)
	704	I DGCODSYS ="ICD9"!(D GTYPE=2)!( DGXX="") S Y="@71";8 2.05;@71;S X=DGXX;I X K DGPTIT S DGNFLD= "@80",Y="@ 8000",DGPT IT(X_$C(59 )_"ICD9(") ="";@80;K DGNFLD,DGD UP,DGADD S Y="";@800 0;D SCAN^D GPTSCAN S: '$D(DGBPC) Y="@8990" ;
	705	"KRN",.402 ,221,"DR", 2,45.02,7)
	706	I '$D(DGBP C(2))!(DGD UP(2)) S Y ="@8100";3 00.02;S:X] "" DGDUP(2 )=1;@8100; I '$D(DGBP C(3))!(DGD UP(3)) S Y ="@8200";3 00.03;S:X] "" DGDUP(3 )=1;@8200; I '$D(DGBP C(4))!(DGD UP(4)) S Y ="@8300";D DRUG^DGPT SC01 I $D( DGTX) S Y= "@8250";30 0.04;
	707	"KRN",.402 ,221,"DR", 2,45.02,8)
	708	S:X]"" DGD UP(4)=1;S Y="@8300"; @8250;300. 04//^S X=D GTX;S:X]"" DGDUP(4)= 1;@8300;I '$D(DGBPC( 5))!(DGDUP (5)) S Y=" @8400";300 .05;S:X]"" DGDUP(5)= 1;@8400;I '$D(DGBPC( 6))!(DGDUP (6)) S Y=" @8500";300 .06;S:X]"" DGDUP(6)= 1;@8500;
	709	"KRN",.402 ,221,"DR", 2,45.02,9)
	710	I '$D(DGBP C(7))!(DGD UP(7)) S Y ="@8990";3 00.07;S:X] "" DGDUP(7 )=1;@8990; K DGPTIT,D GTX S Y=DG NFLD;@9000 ;K DGEXQ D CHQUES^DG PTSPQ I '$ D(DGEXQ) S Y="@9999" ;I '$D(DGE XQ(6)) S Y ="@9040";3 1WAS TREAT MENT RELAT ED TO COMB AT?~;S Y=" @9050";
	711	"KRN",.402 ,221,"DR", 2,45.02,10 )
	712	@9040;31// /@;@9050;I '$D(DGEXQ (1)) S Y=" @9100";26W AS TREATME NT RELATED TO AGENT ORANGE EXP OSURE?~;S Y="@9150"; @9100;26// /@;@9150;I '$D(DGEXQ (2)) S Y=" @9200";27W AS TREATME NT RELATED TO IONIZI NG RADIATI ON EXPOSUR E?~;S Y="@ 9250";
	713	"KRN",.402 ,221,"DR", 2,45.02,11 )
	714	@9200;27// /@;@9250;I '$D(DGEXQ (3)) S Y=" @9300";28W AS TREATME NT RELATED TO SERVIC E IN SW AS IA?~;S Y=" @9350";@93 00;28///@; @9350;I '$ D(DGEXQ(7) ) S Y="@94 00";32WAS TREATMENT RELATED TO PROJ 112/ SHAD?~;S Y ="@9450";@ 9400;32/// @;@9450;
	715	"KRN",.402 ,221,"DR", 2,45.02,12 )
	716	I '$D(DGEX Q(4)) S Y= "@9500";29 WAS TREATM ENT RELATE D TO MILIT ARY SEXUAL TRAUMA?~; S Y="@9550 ";@9500;29 ///@;@9550 ;I '$D(DGE XQ(5)) S Y ="@9600";3 0WAS TREAT MENT RELAT ED TO HEAD AND/OR NE CK CANCER? ~;
	717	"KRN",.402 ,221,"DR", 2,45.02,13 )
	718	I X["Y",$D (DFN),$$FI LEHNC^DGNT API1(DFN); S Y="@9650 ";@9600;30 ///@;@9650 ;I '$D(DGE XQ(8)) S Y ="@9700";S :$$GETCL^D GUTL3(DFN) '=1 Y="@97 00";I $P(^ DGPT(DGPTF ,0),U,18)= 1 S Y="@97 00";Q;33WA S TREATMEN T RELATED TO CAMP LE JEUNE?~//^ S X="NO";
	719	"KRN",.402 ,221,"DR", 2,45.02,14 )
	720	@9700;33// /@;@9750;
	721	"KRN",.402 ,221,"ROU" )
	722	^DGPTX5
	723	"KRN",.402 ,221,"ROUO LD")
	724	DGPTX5
	725	"KRN",.402 ,280,-1)
	726	0^7
	727	"KRN",.402 ,280,0)
	728	DGQWK^3180 105.1128^^ 45^^^31901 29
	729	"KRN",.402 ,280,"DIAB ",1,2,2.02 ,0)
	730	.01;"RACE"
	731	"KRN",.402 ,280,"DIAB ",1,2,2.06 ,0)
	732	.01;"ETHNI CITY"
	733	"KRN",.402 ,280,"DIAB ",2,1,2,0)
	734	6;"ETHNICI TY"
	735	"KRN",.402 ,280,"DIAB ",3,1,2,0)
	736	2;"RACE"
	737	"KRN",.402 ,280,"DIAB ",8,0,45,0 )
	738	PATIENT:
	739	"KRN",.402 ,280,"DR", 1,45)
	740	3//^S X=$P ($$SITE^VA SITE,U,3); 5;20;22;21 .1;21.2;20 .1////^S X =$$ELIG^DG UTL3(DFN,2 ,$P($G(^DG PT(DA,101) ),U,8));^2 ^DPT(^^S I (0,0)=D0 S Y(1)=$S($ D(^DGPT(D0 ,0)):^(0), 1:"") S X= $P(Y(1),U, 1),X=X S D(0)=+X S X=$S(D(0)> 0:D(0),1:" ");
	741	"KRN",.402 ,280,"DR", 1,45,1)
	742	S:$$GETCL^ DGUTL3(DFN )'=1 Y="@2 7";D PTF10 1^DGPTFCLV ;@27;75;73 ;74;76.1;7 6.2;78;77;
	743	"KRN",.402 ,280,"DR", 2,2)
	744	.05;6ETHNI CITY~;2RAC E~;57.4;.3 2101;.3210 2;S:X'="Y" Y=.32103; .3213;.321 03;S:X'="Y " Y="@22"; .3212;@22; .525;S:X'= "Y" Y=.115 ;.526;
	745	"KRN",.402 ,280,"DR", 3,2.02)
	746	.01RACE~;I $P($G(^DI C(10.3,+$P ($G(^DPT(D A(1),.02,D A,0)),"^", 2),0)),"^" ,2)="S" S Y="@21";.0 2;@21;
	747	"KRN",.402 ,280,"DR", 3,2.06)
	748	.01ETHNICI TY~;I $P($ G(^DIC(10. 3,+$P($G(^ DPT(DA(1), .06,DA,0)) ,"^",2),0) ),"^",2)=" S" S Y="@6 1";.02;@61 ;
	749	"KRN",.402 ,283,-1)
	750	0^8
	751	"KRN",.402 ,283,0)
	752	DGQWKF^318 0108.0801^ ^45^^^3180 112
	753	"KRN",.402 ,283,"DIAB ",1,2,2.02 ,0)
	754	.01;"RACE"
	755	"KRN",.402 ,283,"DIAB ",1,2,2.06 ,0)
	756	.01;"ETHNI CITY"
	757	"KRN",.402 ,283,"DIAB ",2,1,2,0)
	758	6;"ETHNICI TY"
	759	"KRN",.402 ,283,"DIAB ",3,1,2,0)
	760	2;"RACE"
	761	"KRN",.402 ,283,"DIAB ",8,0,45,0 )
	762	PATIENT:
	763	"KRN",.402 ,283,"DR", 1,45)
	764	3//^S X=$P ($$SITE^VA SITE,U,3); 5;20;22;21 .1;21.2;20 .1////^S X =$$ELIG^DG UTL3(DFN,2 ,$P($G(^DG PT(DA,101) ),U,8));^2 ^DPT(^^S I (0,0)=D0 S Y(1)=$S($ D(^DGPT(D0 ,0)):^(0), 1:"") S X= $P(Y(1),U, 1),X=X S D(0)=+X S X=$S(D(0)> 0:D(0),1:" ");
	765	"KRN",.402 ,283,"DR", 1,45,1)
	766	S:$$GETCL^ DGUTL3(DFN )'=1 Y="@3 7";D PTF10 1F^DGPTFCL V;@37;10;7 0;71;72;72 .1;75;73;7 4;76.1;76. 2;78;77;
	767	"KRN",.402 ,283,"DR", 2,2)
	768	.05;6ETHNI CITY~;2RAC E~;57.4;.3 2101;.3210 2;S:X'="Y" Y=.32103; .3213;.321 03;S:X'="Y " Y="@22"; .3212;@22; .525;@27;S :X'="Y" Y= .115;.526;
	769	"KRN",.402 ,283,"DR", 3,2.02)
	770	.01RACE~;I $P($G(^DI C(10.3,+$P ($G(^DPT(D A(1),.02,D A,0)),"^", 2),0)),"^" ,2)="S" S Y="@21";.0 2;@21;
	771	"KRN",.402 ,283,"DR", 3,2.06)
	772	.01ETHNICI TY~;I $P($ G(^DIC(10. 3,+$P($G(^ DPT(DA(1), .06,DA,0)) ,"^",2),0) ),"^",2)=" S" S Y="@6 1";.02;@61 ;
	773	"KRN",.402 ,776,-1)
	774	0^11
	775	"KRN",.402 ,776,0)
	776	DGPM ADMIT ^3181228.0 956^^405^^ ^3190204
	777	"KRN",.402 ,776,"%D", 0)
	778	^^3^3^3171 206^^
	779	"KRN",.402 ,776,"%D", 1,0)
	780	This templ ate is use d by routi ne DGPMV3 to capture admission data for a
	781	"KRN",.402 ,776,"%D", 2,0)
	782	particular patient. This templ ate cannot be used w ithout the interacti on
	783	"KRN",.402 ,776,"%D", 3,0)
	784	of the 'Ad mit a Pati ent' optio n in MAS.
	785	"KRN",.402 ,776,"AR", 405,1534)
	786	1^DGPMX11
	787	"KRN",.402 ,776,"DIAB ",1,0,405, 2)
	788	TREATMENT FOR CAMP L EJEUNE//"N O";"WAS TR EATMENT RE LATED TO C AMP LEJEUN E?"
	789	"KRN",.402 ,776,"DIAB ",3,0,405, 0)
	790	41;"DOES T HE PATIENT WISH TO B E EXCLUDED FROM THE FACILITY D IRECTORY?" ;REQ
	791	"KRN",.402 ,776,"DIAB ",3,0,405, 2)
	792	.04;"TYPE OF ADMISSI ON"
	793	"KRN",.402 ,776,"DIAB ",7,0,405, 3)
	794	103///NOW
	795	"KRN",.402 ,776,"DR", 1,405)
	796	S:$S(DGPMN :1,DGPMY=+ ^DGPM(DA,0 ):1,1:0) Y =41;.01/// ^S X=DGPMY ;41R~DOES THE PATIEN T WISH TO BE EXCLUDE D FROM THE FACILITY DIRECTORY? ~;.12;54// //^S X=$$A DCAT^DGSAU TL($P(^DGP M(DA,0),U, 12));
	797	"KRN",.402 ,776,"DR", 1,405,1)
	798	I $S('$D(^ DPT(DFN,.3 )):1,$P(^( .3),"^",1) '="Y":1,1: 0) S Y="@1 1";.11;@11 ;S ^DISV(D UZ,"^DG(40 5.1,")=$S( $D(^DISV(D UZ,"DGPM1" )):^("DGPM 1"),1:""); S:$$GETCL^ DGUTL3(DFN )'=1 Y="@1 2";I $P(^D GPM(DA,0), U,11)=1 S Y="@12";Q;
	799	"KRN",.402 ,776,"DR", 1,405,2)
	800	29WAS TREA TMENT RELA TED TO CAM P LEJEUNE? ~//^S X="N O";@12;.04 TYPE OF AD MISSION~;S ^DISV(DUZ ,"DGPM1")= $S($D(^DIS V(DUZ,"^DG (405.1,")) :^("^DG(40 5.1,"),1:" ");I $P(^D GPM(DA,0), "^",18)'=9 S Y=.1;.0 5;.1;.06;. 07;
	801	"KRN",.402 ,776,"DR", 1,405,3)
	802	D DFN^DGYZ ODS S:'DGO DS Y="@13" ;11500.01/ ///1;@13;I DGPMP=^DG PM(DA,0) S Y="";102/ ///^S X=DU Z;Q;103/// ^N %I,%H,% D NOW^%DT C S X=%;
	803	"KRN",.402 ,776,"ROU" )
	804	^DGPMX1
	805	"KRN",.402 ,776,"ROUO LD")
	806	DGPMX1
	807	"KRN",.402 ,781,-1)
	808	0^13
	809	"KRN",.402 ,781,0)
	810	DGPM SPECI ALTY TRANS FER^318101 5.1633^^40 5^^^319020 4
	811	"KRN",.402 ,781,"AR", 405,1534)
	812	1^DGPMX61
	813	"KRN",.402 ,781,"DIAB ",2,0,405, 1)
	814	.04;"SPECI ALTY TRANS FER TYPE"
	815	"KRN",.402 ,781,"DIAB ",3,0,405, 2)
	816	29//"NO";" WAS TREATM ENT RELATE D TO CAMP LEJEUNE?"
	817	"KRN",.402 ,781,"DIAB ",12,0,405 ,2)
	818	103///NOW
	819	"KRN",.402 ,781,"DR", 1,405)
	820	S:$S(DGPMN :1,DGPMY=+ ^DGPM(DA,0 ):1,1:0) Y ="@10";.01 ///^S X=DG PMY;@10;S: $D(DGPMPC) Y="@35";D ONLY^DGPM V36 S:'$D( DGPMSPI) Y ="@20";.04 ////^S X=D GPMSPI;K D GPMSPI;S Y ="@30";@20 ;
	821	"KRN",.402 ,781,"DR", 1,405,1)
	822	S ^DISV(DU Z,"^DG(405 .1,")=$S($ D(^DISV(DU Z,"DGPM6") ):^("DGPM6 "),1:"");. 04SPECIALT Y TRANSFER TYPE~;S ^ DISV(DUZ," DGPM6")=$S ($D(^DISV( DUZ,"^DG(4 05.1,")):^ ("^DG(405. 1,"),1:"") ;@30;.09;@ 35;.08;.19 ;S:$$GETCL ^DGUTL3(DF N)'=1 Y="@ 36";
	823	"KRN",.402 ,781,"DR", 1,405,2)
	824	I $G(DGPMU C)="ADMISS ION" S Y=" @36";Q;29W AS TREATME NT RELATED TO CAMP L EJEUNE?~// ^S X="NO"; @36;K DIE( "NO^");S:$ D(DGPMBYP) Y="@40";9 9;@40;S:DG PMP=^DGPM( DA,0) Y="" ;102////^S X=DUZ;Q;1 03///^N %I ,%H,% D NO W^%DTC S X =%;
	825	"KRN",.402 ,781,"ROU" )
	826	^DGPMX6
	827	"KRN",.402 ,781,"ROUO LD")
	828	DGPMX6
	829	"KRN",.402 ,782,-1)
	830	0^12
	831	"KRN",.402 ,782,0)
	832	DGPM ASIH ADMIT^3190 205.0743^^ 405^^^3190 204
	833	"KRN",.402 ,782,"%D", 0)
	834	^^3^3^3180 817^
	835	"KRN",.402 ,782,"%D", 1,0)
	836	This templ ate is use d when tra nsfering a patient T O ASIH or CONTINUED
	837	"KRN",.402 ,782,"%D", 2,0)
	838	ASIH, both of which cause a ne w admissio n to be cr eated. Th is templat e
	839	"KRN",.402 ,782,"%D", 3,0)
	840	edits the hospital a dmission.
	841	"KRN",.402 ,782,"AR", 405,1534)
	842	1^DGPMXA1
	843	"KRN",.402 ,782,"DIAB ",1,0,405, 2)
	844	103///NOW
	845	"KRN",.402 ,782,"DIAB ",3,0,405, 0)
	846	41;"DOES T HE PATIENT WISH TO B E EXCLUDED FROM THE FACILITY D IRECTORY?" ;REQ
	847	"KRN",.402 ,782,"DIAB ",5,0,405, 1)
	848	TREATMENT FOR CAMP L EJEUNE//"N O";"WAS TR EATMENT RE LATED TO C AMP LEJEUN E?"
	849	"KRN",.402 ,782,"DR", 1,405)
	850	S:DGPMNA Y =41;.01/// ^S X=+DGPM A;41R~DOES THE PATIE NT WISH TO BE EXCLUD ED FROM TH E FACILITY DIRECTORY ?~;.06//// ^S X=$P(DG PMA,"^",6) ;.07////^S X=$P(DGPM A,"^",7);. 12;I $S('$ D(^DPT(DFN ,.3)):1,$P (^(.3),"^" ,1)'="Y":1 ,1:0) S Y= "@1";.11;
	851	"KRN",.402 ,782,"DR", 1,405,1)
	852	@1;S:$$GET CL^DGUTL3( DFN)'=1 Y= "@2";I $P( $G(^DGPM(D GPMA,0)),U ,11)=1 S Y ="@2";Q;29 WAS TREATM ENT RELATE D TO CAMP LEJEUNE?~/ /^S X="NO" ;@2;.1;D D FN^DGYZODS S:'DGODS Y=102;1150 0.01////1; 102////^S X=DUZ;Q;
	853	"KRN",.402 ,782,"DR", 1,405,2)
	854	103///^N % I,%H,% D N OW^%DTC S X=%;
	855	"KRN",.402 ,782,"ROU" )
	856	^DGPMXA
	857	"KRN",.402 ,782,"ROUO LD")
	858	DGPMXA
	859	"KRN",.402 ,2697,-1)
	860	0^6
	861	"KRN",.402 ,2697,0)
	862	DG801^3180 801.0746^@ ^46.1^^@^3 190118
	863	"KRN",.402 ,2697,"DIA B",1,0,46. 1,2)
	864	TREATED FO R AO CONDI TION;"WAS TREATMENT RELATED TO AGENT ORA NGE EXPOSU RE?"
	865	"KRN",.402 ,2697,"DIA B",1,0,46. 1,5)
	866	.06;"WAS T REATMENT R ELATED TO MILITARY S EXUAL TRAU MA?"
	867	"KRN",.402 ,2697,"DIA B",2,0,46. 1,1)
	868	COMBAT VET //YES;"WAS TREATMENT RELATED T O COMBAT?"
	869	"KRN",.402 ,2697,"DIA B",2,0,46. 1,4)
	870	.09;"WAS T REATMENT R ELATED TO PROJ 112/S HAD?"
	871	"KRN",.402 ,2697,"DIA B",3,0,46. 1,0)
	872	TREATED FO R SC CONDI TION;"WAS TREATMENT FOR A SERV ICE CONNEC TED CONDIT ION?"
	873	"KRN",.402 ,2697,"DIA B",4,0,46. 1,3)
	874	EXPOSURE T O SW ASIA CONDITIONS ;"WAS TREA TMENT RELA TED TO SW ASIA CONDI TIONS?"
	875	"KRN",.402 ,2697,"DIA B",4,0,46. 1,6)
	876	TREATMENT FOR CAMP L EJEUNE//"N O";"WAS TR EATMENT RE LATED TO C AMP LEJEUN E?"
	877	"KRN",.402 ,2697,"DIA B",7,0,46. 1,2)
	878	TREATMENT FOR IR CON DITION;"WA S TREATMEN T RELATED TO IONIZIN G RADIATIO N EXPOSURE ?"
	879	"KRN",.402 ,2697,"DIA B",7,0,46. 1,5)
	880	.07;"WAS T REATMENT R ELATED TO HEAD AND/O R NECK CAN CER?"
	881	"KRN",.402 ,2697,"DR" ,1,46.1)
	882	I '$D(SDCL Y(3)) S Y= $S($P($G(^ DGICD9(46. 1,D0,0)),U ,2)="":"@1 1",1:"@10" );D ELIG^D GPTUTL1;.0 2WAS TREAT MENT FOR A SERVICE C ONNECTED C ONDITION?~ ;S Y="@11" ;@10;.02// //0;@11;
	883	"KRN",.402 ,2697,"DR" ,1,46.1,1)
	884	I '$D(SDCL Y(7)) S Y= $S($P($G(^ DGICD9(46. 1,D0,0)),U ,8)="":"@2 1",1:"@20" );.08WAS T REATMENT R ELATED TO COMBAT?~// YES;S Y="@ 21";@20;.0 8////0;@21 ;I '$D(SDC LY(1)) S Y =$S($P($G( ^DGICD9(46 .1,D0,0)), U,3)="":"@ 31",1:"@30 ");
	885	"KRN",.402 ,2697,"DR" ,1,46.1,2)
	886	.03WAS TRE ATMENT REL ATED TO AG ENT ORANGE EXPOSURE? ~;S Y="@31 ";@30;.03/ ///0;@31;I '$D(SDCLY (2)) S Y=$ S($P($G(^D GICD9(46.1 ,D0,0)),U, 4)="":"@41 ",1:"@40") ;.04WAS TR EATMENT RE LATED TO I ONIZING RA DIATION EX POSURE?~;S Y="@41";@ 40;
	887	"KRN",.402 ,2697,"DR" ,1,46.1,3)
	888	.04////0;@ 41;I '$D(S DCLY(4)) S Y=$S($P($ G(^DGICD9( 46.1,D0,0) ),U,5)="": "@51",1:"@ 50");.05WA S TREATMEN T RELATED TO SW ASIA CONDITION S?~;S Y="@ 51";@50;.0 5////0;@51 ;
	889	"KRN",.402 ,2697,"DR" ,1,46.1,4)
	890	I '$D(SDCL Y(8)) S Y= $S($P($G(^ DGICD9(46. 1,D0,0)),U ,9)="":"@6 1",1:"@60" );.09WAS T REATMENT R ELATED TO PROJ 112/S HAD?~;S Y= "@61";@60; .09////0;@ 61;I '$D(S DCLY(5)) S Y=$S($P($ G(^DGICD9( 46.1,D0,0) ),U,6)="": "@71",1:"@ 70");
	891	"KRN",.402 ,2697,"DR" ,1,46.1,5)
	892	.06WAS TRE ATMENT REL ATED TO MI LITARY SEX UAL TRAUMA ?~;S Y="@7 1";@70;.06 ////0;@71; I '$D(SDCL Y(6)) S Y= $S($P($G(^ DGICD9(46. 1,D0,0)),U ,7)="":"@8 1",1:"@80" );.07WAS T REATMENT R ELATED TO HEAD AND/O R NECK CAN CER?~;S Y= "@81";@80; .07////0;
	893	"KRN",.402 ,2697,"DR" ,1,46.1,6)
	894	@81;S:$$GE TCL^DGUTL3 (DFN)'=1 Y ="@90";Q;. 1WAS TREAT MENT RELAT ED TO CAMP LEJEUNE?~ //^S X="NO ";S Y="@91 ";@90;.1// //0;@91;@9 9;1////^S X=PTF;
	895	"KRN",.402 ,2697,"ROU ")
	896	^DGPTX8
	897	"KRN",.402 ,2697,"ROU OLD")
	898	DGPTX8
	899	"KRN",.402 ,2857,-1)
	900	0^9
	901	"KRN",.402 ,2857,0)
	902	DG501-10D^ 3190125.13 11^"@"^45^ ^"@"^31902 04
	903	"KRN",.402 ,2857,"AR" ,45.02,440 )
	904	1^DGX59
	905	"KRN",.402 ,2857,"AR" ,45.02,441 )
	906	2^DGX59
	907	"KRN",.402 ,2857,"AR" ,45.02,442 )
	908	3^DGX59
	909	"KRN",.402 ,2857,"AR" ,45.02,443 )
	910	4^DGX59
	911	"KRN",.402 ,2857,"AR" ,45.02,444 )
	912	5^DGX59
	913	"KRN",.402 ,2857,"AR" ,45.02,445 )
	914	6^DGX59
	915	"KRN",.402 ,2857,"AR" ,45.02,446 )
	916	7^DGX59
	917	"KRN",.402 ,2857,"AR" ,45.02,447 )
	918	8^DGX59
	919	"KRN",.402 ,2857,"AR" ,45.02,448 )
	920	9^DGX59
	921	"KRN",.402 ,2857,"AR" ,45.02,449 )
	922	10^DGX59
	923	"KRN",.402 ,2857,"AR" ,45.02,460 )
	924	11^DGX59
	925	"KRN",.402 ,2857,"AR" ,45.02,461 )
	926	12^DGX59
	927	"KRN",.402 ,2857,"AR" ,45.02,464 )
	928	13^DGX59
	929	"KRN",.402 ,2857,"AR" ,45.02,122 5)
	930	14^DGX59
	931	"KRN",.402 ,2857,"AR" ,45.02,122 6)
	932	15^DGX59
	933	"KRN",.402 ,2857,"AR" ,45.02,122 7)
	934	16^DGX59
	935	"KRN",.402 ,2857,"AR" ,45.02,122 8)
	936	17^DGX59
	937	"KRN",.402 ,2857,"AR" ,45.02,122 9)
	938	18^DGX59
	939	"KRN",.402 ,2857,"AR" ,45.02,123 0)
	940	19^DGX59
	941	"KRN",.402 ,2857,"AR" ,45.02,123 1)
	942	20^DGX59
	943	"KRN",.402 ,2857,"AR" ,45.02,123 2)
	944	21^DGX59
	945	"KRN",.402 ,2857,"AR" ,45.02,123 3)
	946	22^DGX59
	947	"KRN",.402 ,2857,"AR" ,45.02,123 4)
	948	23^DGX59
	949	"KRN",.402 ,2857,"AR" ,45.02,123 5)
	950	24^DGX59
	951	"KRN",.402 ,2857,"AR" ,45.02,123 6)
	952	25^DGX59
	953	"KRN",.402 ,2857,"DIA B",1,1,45. 02,1)
	954	TREATED FO R SC CONDI TION//NO;" WAS TREATM ENT FOR A SERVICE CO NNECTED CO NDITION?"
	955	"KRN",.402 ,2857,"DIA B",1,1,45. 02,30)
	956	TREATED FO R AO CONDI TION;"WAS TREATMENT RELATED TO AGENT ORA NGE EXPOSU RE?"
	957	"KRN",.402 ,2857,"DIA B",1,1,45. 02,31)
	958	EXPOSED TO SW ASIA C ONDITIONS; "WAS TREAT MENT RELAT ED TO SERV ICE IN SW ASIA?"
	959	"KRN",.402 ,2857,"DIA B",1,1,45. 02,32)
	960	29;"WAS TR EATMENT RE LATED TO M ILITARY SE XUAL TRAUM A?"
	961	"KRN",.402 ,2857,"DIA B",5,1,45. 02,29)
	962	POTENTIALL Y RELATED TO COMBAT/ /YES;"WAS TREATMENT RELATED TO COMBAT?"
	963	"KRN",.402 ,2857,"DIA B",5,1,45. 02,36)
	964	33;"WAS TR EATMENT RE LATED TO C AMP LEJEUN E"
	965	"KRN",.402 ,2857,"DIA B",7,1,45. 02,30)
	966	TREATED FO R IR CONDI TION;"WAS TREATMENT RELATED TO IONIZING RADIATION EXPOSURE?"
	967	"KRN",.402 ,2857,"DIA B",7,1,45. 02,31)
	968	32;"WAS TR EATMENT RE LATED TO P ROJ 112/SH AD?"
	969	"KRN",.402 ,2857,"DIA B",7,1,45. 02,32)
	970	30;"WAS TR EATMENT RE LATED TO H EAD AND/OR NECK CANC ER?"
	971	"KRN",.402 ,2857,"DR" ,1,45)
	972	F X=2:1:7 S DGDUP(X) =0;K DGPTI T;I $G(DGP TF)<1 S DG PTF=D0 W ! !,"Editing PTF Recor d "_DGPTF_ " in VA Fi leManager. ";I $G(DGM OV)<1 S DG MOV=1 W !! ,"Editing Discharge Movement i n VA FileM anager";I $G(DFN)<1 S DFN=+$G( ^DGPT(D0,0 ));
	973	"KRN",.402 ,2857,"DR" ,1,45,1)
	974	D CENSUS^D GPTIC10(DA );S DGJUMP =$G(DGJUMP );S DGXX=" ",DGTYPE=$ P(^DGPT(D0 ,0),U,11), DGCODSYS=$ $CODESYS^D GPTIC10(D0 );S DGHOLD =$G(^DGPT( DGPTF,"M", +DGMOV,0)) ,DGHOLD1=$ G(^(81));5 0///^S X=+ DGMOV;
	975	"KRN",.402 ,2857,"DR" ,2,45.02)
	976	S:'$D(DGAD D) DGADD=0 ;S:DGJUMP' [1 Y="@2"; S:DGADD Y= "@20";S DG NFLD="@10" ;3;@10;S D GNFLD="@15 ";4;@9;I $ D(^DPT(+^D GPT(DGPTF, 0),.3)),$P (^(.3),U)= "Y" S Y="@ 15";18//// ^S X=2;S ( DGNFLD,Y)= "@20";@15;
	977	"KRN",.402 ,2857,"DR" ,2,45.02,1 )
	978	18WAS TREA TMENT FOR A SERVICE CONNECTED CONDITION? ~//NO;@20; S:DGJUMP'[ 2 Y="";@2; S DGNFLD=" @25";S Y=" @9000";@25 ;I DGADD,$ P(DGHOLD,U ,5)]"" S Y ="@40";S $ P(DGPT(DA( 1),"M",DA, 0),U,33)=$ P(DGHOLD,U ,33);S DGN FLD="@40"; 5;S DGXX=X ;
	979	"KRN",.402 ,2857,"DR" ,2,45.02,2 )
	980	I DGXX="" S Y="@26"; 82.01;@26; S X=DGXX;I X K DGPTI T S DGNFLD ="@40",Y=" @8000",DGP TIT(X_$C(5 9)_"ICD9(" )="";@40;I DGADD,$P( DGHOLD,U,6 )]"" S Y=" @50";S DGN FLD="@50"; 6;S DGXX=X ;I DGXX="" S Y="@41" ;82.02;@41 ;S X=DGXX;
	981	"KRN",.402 ,2857,"DR" ,2,45.02,3 )
	982	I X K DGPT IT S DGNFL D="@50",Y= "@8000",DG PTIT(X_$C( 59)_"ICD9( ")="";@50; I DGADD,$P (DGHOLD,U, 7)]"" S Y= "@60";S DG NFLD="@60" ;7;S DGXX= X;I DGXX=" " S Y="@51 ";82.03;@5 1;S X=DGXX ;
	983	"KRN",.402 ,2857,"DR" ,2,45.02,4 )
	984	I X K DGPT IT S DGNFL D="@60",Y= "@8000",DG PTIT(X_$C( 59)_"ICD9( ")="";@60; I DGADD,$P (DGHOLD,U, 8)]"" S Y= "@70";S DG NFLD="@70" ;8;S DGXX= X;I DGXX=" " S Y="@61 ";82.04;@6 1;S X=DGXX ;
	985	"KRN",.402 ,2857,"DR" ,2,45.02,5 )
	986	I X K DGPT IT S DGNFL D="@70",Y= "@8000",DG PTIT(X_$C( 59)_"ICD9( ")="";@70; I DGADD,$P (DGHOLD,U, 9)]"" S Y= "@80";S DG NFLD="@80" ;9;S DGXX= X;I DGXX=" " S Y="@71 ";82.05;@7 1;S X=DGXX ;
	987	"KRN",.402 ,2857,"DR" ,2,45.02,6 )
	988	I X K DGPT IT S DGNFL D="@80",Y= "@8000",DG PTIT(X_$C( 59)_"ICD9( ")="";@80; I DGCODSYS ="ICD9"!(D GTYPE=2) S Y="@280"; I DGADD,$P (DGHOLD,U, 11)]"" S Y ="@90";S D GNFLD="@90 ";11;S DGX X=X;I DGXX ="" S Y="@ 81";82.06; @81;S X=DG XX;
	989	"KRN",.402 ,2857,"DR" ,2,45.02,7 )
	990	I X K DGPT IT S DGNFL D="@90",Y= "@8000",DG PTIT(X_$C( 59)_"ICD9( ")="";@90; I DGADD,$P (DGHOLD,U, 12)]"" S Y ="@100";S DGNFLD="@1 00";12;S D GXX=X;I DG XX="" S Y= "@91";82.0 7;@91;S X= DGXX;
	991	"KRN",.402 ,2857,"DR" ,2,45.02,8 )
	992	I X K DGPT IT S DGNFL D="@100",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@10 0;I DGADD, $P(DGHOLD, U,13)]"" S Y="@110"; S DGNFLD=" @110";13;S DGXX=X;I DGXX="" S Y="@101";8 2.08;@101; S X=DGXX;
	993	"KRN",.402 ,2857,"DR" ,2,45.02,9 )
	994	I X K DGPT IT S DGNFL D="@110",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@11 0;I DGADD, $P(DGHOLD, U,14)]"" S Y="@120"; S DGNFLD=" @120";14;S DGXX=X;I DGXX="" S Y="@111";8 2.09;@111; S X=DGXX;
	995	"KRN",.402 ,2857,"DR" ,2,45.02,1 0)
	996	I X K DGPT IT S DGNFL D="@120",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@12 0;I DGADD, $P(DGHOLD, U,15)]"" S Y="@130"; S DGNFLD=" @130";15;S DGXX=X;I DGXX="" S Y="@121";8 2.1;@121;S X=DGXX;
	997	"KRN",.402 ,2857,"DR" ,2,45.02,1 1)
	998	I X K DGPT IT S DGNFL D="@130",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@13 0;I DGADD, $P(DGHOLD1 ,U,1)]"" S Y="@140"; S DGNFLD=" @140";81.0 1;S DGXX=X ;I DGXX="" S Y="@131 ";82.11;@1 31;S X=DGX X;
	999	"KRN",.402 ,2857,"DR" ,2,45.02,1 2)
	1000	I X K DGPT IT S DGNFL D="@140",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@14 0;I DGADD, $P(DGHOLD1 ,U,2)]"" S Y="@150"; S DGNFLD=" @150";81.0 2;S DGXX=X ;I DGXX="" S Y="@141 ";82.12;@1 41;S X=DGX X;
	1001	"KRN",.402 ,2857,"DR" ,2,45.02,1 3)
	1002	I X K DGPT IT S DGNFL D="@150",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@15 0;I DGADD, $P(DGHOLD1 ,U,3)]"" S Y="@160"; S DGNFLD=" @160";81.0 3;S DGXX=X ;I DGXX="" S Y="@151 ";82.13;@1 51;S X=DGX X;
	1003	"KRN",.402 ,2857,"DR" ,2,45.02,1 4)
	1004	I X K DGPT IT S DGNFL D="@160",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@16 0;I DGADD, $P(DGHOLD1 ,U,4)]"" S Y="@170"; S DGNFLD=" @170";81.0 4;S DGXX=X ;I DGXX="" S Y="@161 ";82.14;@1 61;S X=DGX X;
	1005	"KRN",.402 ,2857,"DR" ,2,45.02,1 5)
	1006	I X K DGPT IT S DGNFL D="@170",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@17 0;I DGADD, $P(DGHOLD1 ,U,5)]"" S Y="@180"; S DGNFLD=" @180";81.0 5;S DGXX=X ;I DGXX="" S Y="@171 ";82.15;@1 71;S X=DGX X;
	1007	"KRN",.402 ,2857,"DR" ,2,45.02,1 6)
	1008	I X K DGPT IT S DGNFL D="@180",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@18 0;I DGADD, $P(DGHOLD1 ,U,6)]"" S Y="@190"; S DGNFLD=" @190";81.0 6;S DGXX=X ;I DGXX="" S Y="@181 ";82.16;@1 81;S X=DGX X;
	1009	"KRN",.402 ,2857,"DR" ,2,45.02,1 7)
	1010	I X K DGPT IT S DGNFL D="@190",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@19 0;I DGADD, $P(DGHOLD1 ,U,7)]"" S Y="@200"; S DGNFLD=" @200";81.0 7;S DGXX=X ;I DGXX="" S Y="@191 ";82.17;@1 91;S X=DGX X;
	1011	"KRN",.402 ,2857,"DR" ,2,45.02,1 8)
	1012	I X K DGPT IT S DGNFL D="@200",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@20 0;I DGADD, $P(DGHOLD1 ,U,8)]"" S Y="@210"; S DGNFLD=" @210";81.0 8;S DGXX=X ;I DGCODSY S="ICD9"!( DGTYPE=2)! (DGXX="") S Y="@201" ;82.18;@20 1;S X=DGXX ;
	1013	"KRN",.402 ,2857,"DR" ,2,45.02,1 9)
	1014	I X K DGPT IT S DGNFL D="@210",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@21 0;I DGADD, $P(DGHOLD1 ,U,9)]"" S Y="@220"; S DGNFLD=" @220";81.0 9;S DGXX=X ;I DGXX="" S Y="@211 ";82.19;@2 11;S X=DGX X;
	1015	"KRN",.402 ,2857,"DR" ,2,45.02,2 0)
	1016	I X K DGPT IT S DGNFL D="@220",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@22 0;I DGADD, $P(DGHOLD1 ,U,10)]"" S Y="@230" ;S DGNFLD= "@230";81. 1;S DGXX=X ;I DGXX="" S Y="@221 ";82.2;@22 1;S X=DGXX ;
	1017	"KRN",.402 ,2857,"DR" ,2,45.02,2 1)
	1018	I X K DGPT IT S DGNFL D="@230",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@23 0;I DGADD, $P(DGHOLD1 ,U,11)]"" S Y="@240" ;S DGNFLD= "@240";81. 11;S DGXX= X;I DGXX=" " S Y="@23 1";82.21;@ 231;S X=DG XX;
	1019	"KRN",.402 ,2857,"DR" ,2,45.02,2 2)
	1020	I X K DGPT IT S DGNFL D="@240",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@24 0;I DGADD, $P(DGHOLD1 ,U,12)]"" S Y="@250" ;S DGNFLD= "@250";81. 12;S DGXX= X;I DGXX=" " S Y="@24 1";82.22;@ 241;S X=DG XX;
	1021	"KRN",.402 ,2857,"DR" ,2,45.02,2 3)
	1022	I X K DGPT IT S DGNFL D="@250",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@25 0;I DGADD, $P(DGHOLD1 ,U,13)]"" S Y="@260" ;S DGNFLD= "@260";81. 13;S DGXX= X;I DGXX=" " S Y="@25 1";82.23;@ 251;S X=DG XX;
	1023	"KRN",.402 ,2857,"DR" ,2,45.02,2 4)
	1024	I X K DGPT IT S DGNFL D="@260",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@26 0;I DGADD, $P(DGHOLD1 ,U,14)]"" S Y="@270" ;S DGNFLD= "@270";81. 14;S DGXX= X;I DGXX=" " S Y="@26 1";82.24;@ 261;S X=DG XX;
	1025	"KRN",.402 ,2857,"DR" ,2,45.02,2 5)
	1026	I X K DGPT IT S DGNFL D="@270",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@27 0;I DGADD, $P(DGHOLD1 ,U,15)]"" S Y="@280" ;S DGNFLD= "@280";81. 15;S DGXX= X;I DGXX=" " S Y="@27 1";82.25;@ 271;S X=DG XX;
	1027	"KRN",.402 ,2857,"DR" ,2,45.02,2 6)
	1028	I X K DGPT IT S DGNFL D="@280",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@28 0;K DGNFLD ,DGDUP,DGA DD S Y=""; @8000;D SC AN^DGPTSCA N S:'$D(DG BPC) Y="@8 990";I '$D (DGBPC(2)) !(DGDUP(2) ) S Y="@81 00";300.02 ;S:X]"" DG DUP(2)=1;@ 8100;
	1029	"KRN",.402 ,2857,"DR" ,2,45.02,2 7)
	1030	I '$D(DGBP C(3))!(DGD UP(3)) S Y ="@8200";3 00.03;S:X] "" DGDUP(3 )=1;@8200; I '$D(DGBP C(4))!(DGD UP(4)) S Y ="@8300";D DRUG^DGPT SC01 I $D( DGTX) S Y= "@8250";30 0.04;S:X]" " DGDUP(4) =1;S Y="@8 300";@8250 ;300.04//^ S X=DGTX;S :X]"" DGDU P(4)=1;
	1031	"KRN",.402 ,2857,"DR" ,2,45.02,2 8)
	1032	@8300;I '$ D(DGBPC(5) )!(DGDUP(5 )) S Y="@8 400";300.0 5;S:X]"" D GDUP(5)=1; @8400;I '$ D(DGBPC(6) )!(DGDUP(6 )) S Y="@8 500";300.0 6;S:X]"" D GDUP(6)=1; @8500;I '$ D(DGBPC(7) )!(DGDUP(7 )) S Y="@8 990";300.0 7;S:X]"" D GDUP(7)=1; @8990;
	1033	"KRN",.402 ,2857,"DR" ,2,45.02,2 9)
	1034	K DGPTIT,D GTX S Y=DG NFLD;@9000 ;K DGEXQ D CHQUES^DG PTSPQ I '$ D(DGEXQ) S Y="@9999" ;I '$D(DGE XQ(6)) S Y ="@9040";3 1WAS TREAT MENT RELAT ED TO COMB AT?~//YES; S Y="@9050 ";@9040;31 ///@;@9050 ;I '$D(DGE XQ(01)) S Y="@9100";
	1035	"KRN",.402 ,2857,"DR" ,2,45.02,3 0)
	1036	26WAS TREA TMENT RELA TED TO AGE NT ORANGE EXPOSURE?~ ;S Y="@915 0";@9100;2 6///@;@915 0;I '$D(DG EXQ(2)) S Y="@9200"; 27WAS TREA TMENT RELA TED TO ION IZING RADI ATION EXPO SURE?~;S Y ="@9250";@ 9200;27/// @;@9250;I '$D(DGEXQ( 3)) S Y="@ 9300";
	1037	"KRN",.402 ,2857,"DR" ,2,45.02,3 1)
	1038	28WAS TREA TMENT RELA TED TO SER VICE IN SW ASIA?~;S Y="@9350"; @9300;28// /@;@9350;I '$D(DGEXQ (7)) S Y=" @9400";32W AS TREATME NT RELATED TO PROJ 1 12/SHAD?~; S Y="@9450 ";@9400;32 ///@;@9450 ;I '$D(DGE XQ(4)) S Y ="@9500";
	1039	"KRN",.402 ,2857,"DR" ,2,45.02,3 2)
	1040	29WAS TREA TMENT RELA TED TO MIL ITARY SEXU AL TRAUMA? ~;S Y="@95 50";@9500; 29///@;@95 50;I '$D(D GEXQ(5)) S Y="@9600" ;30WAS TRE ATMENT REL ATED TO HE AD AND/OR NECK CANCE R?~;I X["Y ",$D(DFN), $$FILEHNC^ DGNTAPI1(D FN);S Y="@ 9650";@960 0;30///@;
	1041	"KRN",.402 ,2857,"DR" ,2,45.02,3 3)
	1042	@9650;I '$ D(DGEXQ(8) ) S Y="@97 00";S:$$GE TCL^DGUTL3 (DFN)'=1 Y ="@9700";I $P(^DGPT( DGPTF,"M", +$G(DGMOV) ,0),U,18)= 1 S Y="@97 00";S:$G(D GMOV)>0 DG DA=$G(DGMO V) S:$G(DG DA)="" DGD A=1;S:DGDA =0 DGDA=1; S DGDA1=DG PTF;
	1043	"KRN",.402 ,2857,"DR" ,2,45.02,3 4)
	1044	K DGEXQ S DA(1)=DGDA 1,DA=DGDA D CHQUES^D GPTSPQ;I D GDA=1 S DG LAST=$P(^D GPT(DGDA1, "M",0),U,3 );I DGDA=1 S:$P(^DGP T(DGDA1,"M ",1,0),U,3 3)="" $P(^ DGPT(DGDA1 ,"M",1,0), U,33)=$P(^ DGPT(DGDA1 ,"M",DGLAS T,0),U,33) ;I DGDA=1 S Y="@9699 ";
	1045	"KRN",.402 ,2857,"DR" ,2,45.02,3 5)
	1046	I DGDA=2&( $P(^DGPT(D GDA1,"M",D GDA,0),U,3 3)="") S D GPMV=$O(^D GPM("APTF" ,DGDA1,"") ),DGCLV=$P (^DGPM(DGP MV,0),U,29 );I DGDA'= 2,$P(^DGPT (DGDA1,"M" ,DGDA,0),U ,33)'="" S DGCLV=$P( ^DGPT(DGDA 1,"M",DGDA ,0),U,33);
	1047	"KRN",.402 ,2857,"DR" ,2,45.02,3 6)
	1048	I DGDA=2&( $P(^DGPT(D GDA1,"M",2 ,0),U,33)' ="") S Y= "@9699";S: $G(DGCLV)' =""&($P(^D GPT(DGDA1, "M",2,0),U ,33)'="") $P(^DGPT(D GDA1,"M",D GDA,0),U,3 3)=DGCLV;@ 9699;S DA= DGDA,DA(1) =DGDA1;33W AS TREATME NT RELATED TO CAMP L EJEUNE~;
	1049	"KRN",.402 ,2857,"DR" ,2,45.02,3 7)
	1050	S XY=X,$P( ^DGPT(DA(1 ),"M",DA,0 ),U,33)=$E (XY,1);S X Y=X S ^XTM P("DGPTF", $J,"T",2,D A)=$E(XY,1 );S Y="@97 50";@9700; 33///@;@97 50;@9999;K DGEXQ S Y =DGNFLD;
	1051	"KRN",.402 ,2857,"ROU ")
	1052	^DGX5
	1053	"KRN",.402 ,2857,"ROU OLD")
	1054	DGX5
	1055	"KRN",.402 ,2859,-1)
	1056	0^10
	1057	"KRN",.402 ,2859,0)
	1058	DG501F-10D ^3180808.1 246^@^45^^ @^3190116
	1059	"KRN",.402 ,2859,"AR" ,45.02,440 )
	1060	1^DGX5FD10
	1061	"KRN",.402 ,2859,"AR" ,45.02,441 )
	1062	2^DGX5FD10
	1063	"KRN",.402 ,2859,"AR" ,45.02,442 )
	1064	3^DGX5FD10
	1065	"KRN",.402 ,2859,"AR" ,45.02,443 )
	1066	4^DGX5FD10
	1067	"KRN",.402 ,2859,"AR" ,45.02,444 )
	1068	5^DGX5FD10
	1069	"KRN",.402 ,2859,"AR" ,45.02,445 )
	1070	6^DGX5FD10
	1071	"KRN",.402 ,2859,"AR" ,45.02,446 )
	1072	7^DGX5FD10
	1073	"KRN",.402 ,2859,"AR" ,45.02,447 )
	1074	8^DGX5FD10
	1075	"KRN",.402 ,2859,"AR" ,45.02,448 )
	1076	9^DGX5FD10
	1077	"KRN",.402 ,2859,"AR" ,45.02,449 )
	1078	10^DGX5FD1 0
	1079	"KRN",.402 ,2859,"AR" ,45.02,460 )
	1080	11^DGX5FD1 0
	1081	"KRN",.402 ,2859,"AR" ,45.02,461 )
	1082	12^DGX5FD1 0
	1083	"KRN",.402 ,2859,"AR" ,45.02,464 )
	1084	13^DGX5FD1 0
	1085	"KRN",.402 ,2859,"AR" ,45.02,122 5)
	1086	14^DGX5FD1 0
	1087	"KRN",.402 ,2859,"AR" ,45.02,122 6)
	1088	15^DGX5FD1 0
	1089	"KRN",.402 ,2859,"AR" ,45.02,122 7)
	1090	16^DGX5FD1 0
	1091	"KRN",.402 ,2859,"AR" ,45.02,122 8)
	1092	17^DGX5FD1 0
	1093	"KRN",.402 ,2859,"AR" ,45.02,122 9)
	1094	18^DGX5FD1 0
	1095	"KRN",.402 ,2859,"AR" ,45.02,123 0)
	1096	19^DGX5FD1 0
	1097	"KRN",.402 ,2859,"AR" ,45.02,123 1)
	1098	20^DGX5FD1 0
	1099	"KRN",.402 ,2859,"AR" ,45.02,123 2)
	1100	21^DGX5FD1 0
	1101	"KRN",.402 ,2859,"AR" ,45.02,123 3)
	1102	22^DGX5FD1 0
	1103	"KRN",.402 ,2859,"AR" ,45.02,123 4)
	1104	23^DGX5FD1 0
	1105	"KRN",.402 ,2859,"AR" ,45.02,123 5)
	1106	24^DGX5FD1 0
	1107	"KRN",.402 ,2859,"AR" ,45.02,123 6)
	1108	25^DGX5FD1 0
	1109	"KRN",.402 ,2859,"DIA B",1,1,45. 02,1)
	1110	TREATED FO R SC CONDI TION//NO;" WAS TREATM ENT FOR A SERVICE CO NNECTED CO NDITION?"
	1111	"KRN",.402 ,2859,"DIA B",1,1,45. 02,30)
	1112	TREATED FO R AO CONDI TION;"WAS TREATMENT RELATED TO AGENT ORA NGE EXPOSU RE?"
	1113	"KRN",.402 ,2859,"DIA B",1,1,45. 02,31)
	1114	EXPOSED TO SW ASIA C ONDITIONS; "WAS TREAT MENT RELAT ED TO SERV ICE IN SW ASIA?"
	1115	"KRN",.402 ,2859,"DIA B",1,1,45. 02,32)
	1116	29;"WAS TR EATMENT RE LATED TO M ILITARY SE XUAL TRAUM A?"
	1117	"KRN",.402 ,2859,"DIA B",5,1,45. 02,29)
	1118	POTENTIALL Y RELATED TO COMBAT/ /YES;"WAS TREATMENT RELATED TO COMBAT?"
	1119	"KRN",.402 ,2859,"DIA B",6,1,45. 02,33)
	1120	33//"NO";" WAS TREATM ENT RELATE D TO CAMP LEJEUNE?"
	1121	"KRN",.402 ,2859,"DIA B",7,1,45. 02,30)
	1122	TREATED FO R IR CONDI TION;"WAS TREATMENT RELATED TO IONIZING RADIATION EXPOSURE?"
	1123	"KRN",.402 ,2859,"DIA B",7,1,45. 02,31)
	1124	32;"WAS TR EATMENT RE LATED TO P ROJ 112/SH AD?"
	1125	"KRN",.402 ,2859,"DIA B",7,1,45. 02,32)
	1126	30;"WAS TR EATMENT RE LATED TO H EAD AND/OR NECK CANC ER?"
	1127	"KRN",.402 ,2859,"DR" ,1,45)
	1128	F X=2:1:7 S DGDUP(X) =0;K DGPTI T;I $G(DGP TF)<1 S DG PTF=D0 W ! !,"Editing PTF Recor d "_DGPTF_ " in VA Fi leManager. ";I $G(DGM OV)<1 S DG MOV=1 W !! ,"Editing Discharge Movement i n VA FileM anager";I $G(DFN)<1 S DFN=+$G( ^DGPT(D0,0 ));
	1129	"KRN",.402 ,2859,"DR" ,1,45,1)
	1130	D CENSUS^D GPTIC10(DA );S DGJUMP =$G(DGJUMP );S DGXX=" ",DGTYPE=$ P(^DGPT(D0 ,0),U,11), DGCODSYS=$ $CODESYS^D GPTIC10(D0 );S DGHOLD =$G(^DGPT( DGPTF,"M", +DGMOV,0)) S:DGHOLD] "" DGHOLD1 =$G(^(81)) ;S:'$D(DGA DD) DGADD= 0;S DGNFLD ="@10";
	1131	"KRN",.402 ,2859,"DR" ,1,45,2)
	1132	50///^S X= +DGMOV;
	1133	"KRN",.402 ,2859,"DR" ,2,45.02)
	1134	S:DGJUMP'[ 1 Y="@2";1 0;@10;S DG NFLD="@15" ;2;@15;S D GNFLD="@16 ";3;@16;S DGNFLD="@1 7";4;@17;S :DGJUMP'[2 Y=0;@2;I $D(^DPT(+^ DGPT(DGPTF ,0),.3)),$ P(^(.3),U) ="Y" S (DG NFLD,Y)="@ 25";18//// ^S X=2;S ( DGNFLD,Y)= "@27";@25;
	1135	"KRN",.402 ,2859,"DR" ,2,45.02,1 )
	1136	18WAS TREA TMENT FOR A SERVICE CONNECTED CONDITION? ~//NO;I X= "YES" S DG SC=1;@27;S DGNFLD="@ 28";S Y="@ 9000";@28; I DGADD,$P (DGHOLD,U, 5)]"" S Y= "@40";S DG NFLD="@40" ;5;S DGXX= X;I DGXX=" " S Y="@26 ";82.01;@2 6;S X=DGXX ;
	1137	"KRN",.402 ,2859,"DR" ,2,45.02,2 )
	1138	I X K DGPT IT S DGNFL D="@40",Y= "@8000",DG PTIT(X_$C( 59)_"ICD9( ")="";@40; I DGADD,$P (DGHOLD,U, 6)]"" S Y= "@50";S DG NFLD="@50" ;6;S DGXX= X;I DGXX=" " S Y="@41 ";82.02;@4 1;S X=DGXX ;
	1139	"KRN",.402 ,2859,"DR" ,2,45.02,3 )
	1140	I X K DGPT IT S DGNFL D="@50",Y= "@8000",DG PTIT(X_$C( 59)_"ICD9( ")="";@50; I DGADD,$P (DGHOLD,U, 7)]"" S Y= "@60";S DG NFLD="@60" ;7;S DGXX= X;I DGXX=" " S Y="@51 ";82.03;@5 1;S X=DGXX ;
	1141	"KRN",.402 ,2859,"DR" ,2,45.02,4 )
	1142	I X K DGPT IT S DGNFL D="@60",Y= "@8000",DG PTIT(X_$C( 59)_"ICD9( ")="";@60; I DGADD,$P (DGHOLD,U, 8)]"" S Y= "@70";S DG NFLD="@70" ;8;S DGXX= X;I DGXX=" " S Y="@61 ";82.04;@6 1;S X=DGXX ;
	1143	"KRN",.402 ,2859,"DR" ,2,45.02,5 )
	1144	I X K DGPT IT S DGNFL D="@70",Y= "@8000",DG PTIT(X_$C( 59)_"ICD9( ")="";@70; I DGADD,$P (DGHOLD,U, 9)]"" S Y= "@80";S DG NFLD="@80" ;9;S DGXX= X;I DGXX=" " S Y="@71 ";82.05;@7 1;S X=DGXX ;
	1145	"KRN",.402 ,2859,"DR" ,2,45.02,6 )
	1146	I X K DGPT IT S DGNFL D="@80",Y= "@8000",DG PTIT(X_$C( 59)_"ICD9( ")="";@80; I DGADD,$P (DGHOLD,U, 11)]"" S Y ="@90";S D GNFLD="@90 ";11;S DGX X=X;I DGXX ="" S Y="@ 81";82.06; @81;S X=DG XX;
	1147	"KRN",.402 ,2859,"DR" ,2,45.02,7 )
	1148	I X K DGPT IT S DGNFL D="@90",Y= "@8000",DG PTIT(X_$C( 59)_"ICD9( ")="";@90; I DGADD,$P (DGHOLD,U, 12)]"" S Y ="@100";S DGNFLD="@1 00";12;S D GXX=X;I DG XX="" S Y= "@91";82.0 7;@91;S X= DGXX;
	1149	"KRN",.402 ,2859,"DR" ,2,45.02,8 )
	1150	I X K DGPT IT S DGNFL D="@100",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@10 0;I DGADD, $P(DGHOLD, U,13)]"" S Y="@110"; S DGNFLD=" @110";13;S DGXX=X;I DGXX="" S Y="@101";8 2.08;@101; S X=DGXX;
	1151	"KRN",.402 ,2859,"DR" ,2,45.02,9 )
	1152	I X K DGPT IT S DGNFL D="@110",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@11 0;I DGADD, $P(DGHOLD, U,14)]"" S Y="@120"; S DGNFLD=" @120";14;S DGXX=X;I DGXX="" S Y="@111";8 2.09;@111; S X=DGXX;
	1153	"KRN",.402 ,2859,"DR" ,2,45.02,1 0)
	1154	I X K DGPT IT S DGNFL D="@120",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@12 0;I DGADD, $P(DGHOLD, U,15)]"" S Y="@130"; S DGNFLD=" @130";15;S DGXX=X;I DGXX="" S Y="@121";8 2.1;@121;S X=DGXX;
	1155	"KRN",.402 ,2859,"DR" ,2,45.02,1 1)
	1156	I X K DGPT IT S DGNFL D="@130",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@13 0;I DGADD, $P(DGHOLD1 ,U,1)]"" S Y="@140"; S DGNFLD=" @140";81.0 1;S DGXX=X ;I DGXX="" S Y="@131 ";82.11;@1 31;S X=DGX X;
	1157	"KRN",.402 ,2859,"DR" ,2,45.02,1 2)
	1158	I X K DGPT IT S DGNFL D="@140",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@14 0;I DGADD, $P(DGHOLD1 ,U,2)]"" S Y="@150"; S DGNFLD=" @150";81.0 2;S DGXX=X ;I DGXX="" S Y="@141 ";82.12;@1 41;S X=DGX X;
	1159	"KRN",.402 ,2859,"DR" ,2,45.02,1 3)
	1160	I X K DGPT IT S DGNFL D="@150",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@15 0;I DGADD, $P(DGHOLD1 ,U,3)]"" S Y="@160"; S DGNFLD=" @160";81.0 3;S DGXX=X ;I DGXX="" S Y="@151 ";82.13;@1 51;S X=DGX X;
	1161	"KRN",.402 ,2859,"DR" ,2,45.02,1 4)
	1162	I X K DGPT IT S DGNFL D="@160",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@16 0;I DGADD, $P(DGHOLD1 ,U,4)]"" S Y="@170"; S DGNFLD=" @170";81.0 4;S DGXX=X ;I DGXX="" S Y="@161 ";82.14;@1 61;S X=DGX X;
	1163	"KRN",.402 ,2859,"DR" ,2,45.02,1 5)
	1164	I X K DGPT IT S DGNFL D="@170",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@17 0;I DGADD, $P(DGHOLD1 ,U,5)]"" S Y="@180"; S DGNFLD=" @180";81.0 5;S DGXX=X ;I DGXX="" S Y="@171 ";82.15;@1 71;S X=DGX X;
	1165	"KRN",.402 ,2859,"DR" ,2,45.02,1 6)
	1166	I X K DGPT IT S DGNFL D="@180",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@18 0;I DGADD, $P(DGHOLD1 ,U,6)]"" S Y="@190"; S DGNFLD=" @190";81.0 6;S DGXX=X ;I DGXX="" S Y="@181 ";82.16;@1 81;S X=DGX X;
	1167	"KRN",.402 ,2859,"DR" ,2,45.02,1 7)
	1168	I X K DGPT IT S DGNFL D="@190",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@19 0;I DGADD, $P(DGHOLD1 ,U,7)]"" S Y="@200"; S DGNFLD=" @200";81.0 7;S DGXX=X ;I DGXX="" S Y="@191 ";82.17;@1 91;S X=DGX X;
	1169	"KRN",.402 ,2859,"DR" ,2,45.02,1 8)
	1170	I X K DGPT IT S DGNFL D="@200",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@20 0;I DGADD, $P(DGHOLD1 ,U,8)]"" S Y="@210"; S DGNFLD=" @210";81.0 8;S DGXX=X ;I DGXX="" S Y="@201 ";82.18;@2 01;S X=DGX X;
	1171	"KRN",.402 ,2859,"DR" ,2,45.02,1 9)
	1172	I X K DGPT IT S DGNFL D="@210",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@21 0;I DGADD, $P(DGHOLD1 ,U,9)]"" S Y="@220"; S DGNFLD=" @220";81.0 9;S DGXX=X ;I DGXX="" S Y="@211 ";82.19;@2 11;S X=DGX X;
	1173	"KRN",.402 ,2859,"DR" ,2,45.02,2 0)
	1174	I X K DGPT IT S DGNFL D="@220",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@22 0;I DGADD, $P(DGHOLD1 ,U,10)]"" S Y="@230" ;S DGNFLD= "@230";81. 1;S DGXX=X ;I DGXX="" S Y="@221 ";82.2;@22 1;S X=DGXX ;
	1175	"KRN",.402 ,2859,"DR" ,2,45.02,2 1)
	1176	I X K DGPT IT S DGNFL D="@230",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@23 0;I DGADD, $P(DGHOLD1 ,U,11)]"" S Y="@240" ;S DGNFLD= "@240";81. 11;S DGXX= X;I DGXX=" " S Y="@23 1";82.21;@ 231;S X=DG XX;
	1177	"KRN",.402 ,2859,"DR" ,2,45.02,2 2)
	1178	I X K DGPT IT S DGNFL D="@240",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@24 0;I DGADD, $P(DGHOLD1 ,U,12)]"" S Y="@250" ;S DGNFLD= "@250";81. 12;S DGXX= X;I DGXX=" " S Y="@24 1";82.22;@ 241;S X=DG XX;
	1179	"KRN",.402 ,2859,"DR" ,2,45.02,2 3)
	1180	I X K DGPT IT S DGNFL D="@250",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@25 0;I DGADD, $P(DGHOLD1 ,U,13)]"" S Y="@260" ;S DGNFLD= "@260";81. 13;S DGXX= X;I DGXX=" " S Y="@25 1";82.23;@ 251;S X=DG XX;
	1181	"KRN",.402 ,2859,"DR" ,2,45.02,2 4)
	1182	I X K DGPT IT S DGNFL D="@260",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@26 0;I DGADD, $P(DGHOLD1 ,U,14)]"" S Y="@270" ;S DGNFLD= "@270";81. 14;S DGXX= X;I DGXX=" " S Y="@26 1";82.24;@ 261;S X=DG XX;
	1183	"KRN",.402 ,2859,"DR" ,2,45.02,2 5)
	1184	I X K DGPT IT S DGNFL D="@270",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@27 0;I DGADD, $P(DGHOLD1 ,U,15)]"" S Y="@280" ;S DGNFLD= "@280";81. 15;S DGXX= X;I DGXX=" " S Y="@27 1";82.25;@ 271;S X=DG XX;
	1185	"KRN",.402 ,2859,"DR" ,2,45.02,2 6)
	1186	I X K DGPT IT S DGNFL D="@280",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@28 0;K DGNFLD ,DGDUP,DGA DD,DGXX,DG CODSYS S Y ="";@8000; D SCAN^DGP TSCAN S:'$ D(DGBPC) Y ="@8990";I '$D(DGBPC (2))!(DGDU P(2)) S Y= "@8200";30 0.02;S:X]" " DGDUP(2) =1;@8200;
	1187	"KRN",.402 ,2859,"DR" ,2,45.02,2 7)
	1188	I '$D(DGBP C(3))!(DGD UP(3)) S Y ="@8300";3 00.03;S:X] "" DGDUP(3 )=1;@8300; I '$D(DGBP C(4))!(DGD UP(4)) S Y ="@8400";D DRUG^DGPT SC01 I $D( DGTX) S Y= "@8350";30 0.04;S:X]" " DGDUP(4) =1;S Y="@8 400";@8350 ;300.04//^ S X=DGTX;S :X]"" DGDU P(4)=1;
	1189	"KRN",.402 ,2859,"DR" ,2,45.02,2 8)
	1190	@8400;I '$ D(DGBPC(5) )!(DGDUP(5 )) S Y="@8 500";300.0 5;S:X]"" D GDUP(5)=1; @8500;I '$ D(DGBPC(6) )!(DGDUP(6 )) S Y="@8 600";300.0 6;S:X]"" D GDUP(6)=1; @8600;I '$ D(DGBPC(7) )!(DGDUP(7 )) S Y="@8 990";300.0 7;S:X]"" D GDUP(7)=1; @8990;
	1191	"KRN",.402 ,2859,"DR" ,2,45.02,2 9)
	1192	K DGPTIT S Y=DGNFLD; @9000;K DG EXQ D CHQU ES^DGPTSPQ I '$D(DGE XQ) S Y="@ 9999";I '$ D(DGEXQ(6) ) S Y="@90 40";31WAS TREATMENT RELATED TO COMBAT?~/ /YES;S Y=" @9050";@90 40;31///@; @9050;I '$ D(DGEXQ(1) ) S Y="@91 00";
	1193	"KRN",.402 ,2859,"DR" ,2,45.02,3 0)
	1194	26WAS TREA TMENT RELA TED TO AGE NT ORANGE EXPOSURE?~ ;S Y="@915 0";@9100;2 6///@;@915 0;I '$D(DG EXQ(2)) S Y="@9200"; 27WAS TREA TMENT RELA TED TO ION IZING RADI ATION EXPO SURE?~;S Y ="@9250";@ 9200;27/// @;@9250;I '$D(DGEXQ( 3)) S Y="@ 9300";
	1195	"KRN",.402 ,2859,"DR" ,2,45.02,3 1)
	1196	28WAS TREA TMENT RELA TED TO SER VICE IN SW ASIA?~;S Y="@9350"; @9300;28// /@;@9350;I '$D(DGEXQ (7)) S Y=" @9400";32W AS TREATME NT RELATED TO PROJ 1 12/SHAD?~; S Y="@9450 ";@9400;32 ///@;@9450 ;I '$D(DGE XQ(4)) S Y ="@9500";
	1197	"KRN",.402 ,2859,"DR" ,2,45.02,3 2)
	1198	29WAS TREA TMENT RELA TED TO MIL ITARY SEXU AL TRAUMA? ~;S Y="@95 50";@9500; 29///@;@95 50;I '$D(D GEXQ(5)) S Y="@9600" ;30WAS TRE ATMENT REL ATED TO HE AD AND/OR NECK CANCE R?~;I X["Y ",$D(DFN), $$FILEHNC^ DGNTAPI1(D FN);S Y="@ 9650";@960 0;30///@;
	1199	"KRN",.402 ,2859,"DR" ,2,45.02,3 3)
	1200	@9650;I '$ D(DGEXQ(8) ) S Y="@97 00";S:$$GE TCL^DGUTL3 (DFN)'=1 Y ="@9700";I $P(^DGPT( DGPTF,"M", +$G(DGMOV) ,0),U,18)= 1 S Y="@97 00";Q;33WA S TREATMEN T RELATED TO CAMP LE JEUNE?~//^ S X="NO";S Y="@9750" ;@9700;33/ //@;@9750; @9999;
	1201	"KRN",.402 ,2859,"DR" ,2,45.02,3 4)
	1202	K DGEXQ S Y=DGNFLD;@ 99999;
	1203	"KRN",.402 ,2859,"ROU ")
	1204	^DGX5FD
	1205	"KRN",.402 ,2859,"ROU OLD")
	1206	DGX5FD
	1207	"MBREQ")
	1208	0
	1209	"ORD",7,.4 02)
	1210	.402;7;;;E DEOUT^DIFR OMSO(.402, DA,"",XPDA );FPRE^DIF ROMSI(.402 ,"",XPDA); EPRE^DIFRO MSI(.402,D A,$E("N",$ G(XPDNEW)) ,XPDA,"",O LDA);;EPOS T^DIFROMSI (.402,DA," ",XPDA);DE L^DIFROMSK (.402,"",% )
	1211	"ORD",7,.4 02,0)
	1212	INPUT TEMP LATE
	1213	"PKG",5,-1 )
	1214	1^1
	1215	"PKG",5,0)
	1216	REGISTRATI ON^DG^PATI ENT REGIST RATION, AD MISSION, D ISCHARGE, EMBOSSER
	1217	"PKG",5,22 ,0)
	1218	^9.49I^1^1
	1219	"PKG",5,22 ,1,0)
	1220	5.3^293081 3
	1221	"PKG",5,22 ,1,"PAH",1 ,0)
	1222	914^319020 5^1577
	1223	"PKG",5,22 ,1,"PAH",1 ,1,0)
	1224	^^1^1^3190 205
	1225	"PKG",5,22 ,1,"PAH",1 ,1,1,0)
	1226	Please ref er to the patch desc ription fo r details.
	1227	"QUES","XP F1",0)
	1228	Y
	1229	"QUES","XP F1","??")
	1230	^D REP^XPD H
	1231	"QUES","XP F1","A")
	1232	Shall I wr ite over y our \|FLAG\| File
	1233	"QUES","XP F1","B")
	1234	YES
	1235	"QUES","XP F1","M")
	1236	D XPF1^XPD IQ
	1237	"QUES","XP F2",0)
	1238	Y
	1239	"QUES","XP F2","??")
	1240	^D DTA^XPD H
	1241	"QUES","XP F2","A")
	1242	Want my da ta \|FLAG\| yours
	1243	"QUES","XP F2","B")
	1244	YES
	1245	"QUES","XP F2","M")
	1246	D XPF2^XPD IQ
	1247	"QUES","XP I1",0)
	1248	YO
	1249	"QUES","XP I1","??")
	1250	^D INHIBIT ^XPDH
	1251	"QUES","XP I1","A")
	1252	Want KIDS to INHIBIT LOGONs du ring the i nstall
	1253	"QUES","XP I1","B")
	1254	NO
	1255	"QUES","XP I1","M")
	1256	D XPI1^XPD IQ
	1257	"QUES","XP M1",0)
	1258	PO^VA(200, :EM
	1259	"QUES","XP M1","??")
	1260	^D MG^XPDH
	1261	"QUES","XP M1","A")
	1262	Enter the Coordinato r for Mail Group '\|F LAG\|'
	1263	"QUES","XP M1","B")
	1264
	1265	"QUES","XP M1","M")
	1266	D XPM1^XPD IQ
	1267	"QUES","XP O1",0)
	1268	Y
	1269	"QUES","XP O1","??")
	1270	^D MENU^XP DH
	1271	"QUES","XP O1","A")
	1272	Want KIDS to Rebuild Menu Tree s Upon Com pletion of Install
	1273	"QUES","XP O1","B")
	1274	NO
	1275	"QUES","XP O1","M")
	1276	D XPO1^XPD IQ
	1277	"QUES","XP Z1",0)
	1278	Y
	1279	"QUES","XP Z1","??")
	1280	^D OPT^XPD H
	1281	"QUES","XP Z1","A")
	1282	Want to DI SABLE Sche duled Opti ons, Menu Options, a nd Protoco ls
	1283	"QUES","XP Z1","B")
	1284	YES
	1285	"QUES","XP Z1","M")
	1286	D XPZ1^XPD IQ
	1287	"QUES","XP Z2",0)
	1288	Y
	1289	"QUES","XP Z2","??")
	1290	^D RTN^XPD H
	1291	"QUES","XP Z2","A")
	1292	Want to MO VE routine s to other CPUs
	1293	"QUES","XP Z2","B")
	1294	NO
	1295	"QUES","XP Z2","M")
	1296	D XPZ2^XPD IQ
	1297	"RTN")
	1298	35
	1299	"RTN","DGA PI1")
	1300	0^6^B25401 406^B24783 749
	1301	"RTN","DGA PI1",1,0)
	1302	DGAPI1 ;AL B/DWS - DG API TO CO MUNICATE W ITH PCE ;6 /16/05 1:4 4pm
	1303	"RTN","DGA PI1",2,0)
	1304	;;5.3;Reg istration; 635,664, 914;Aug 13, 1993;B uild 173
	1305	"RTN","DGA PI1",3,0)
	1306	DATA2PCE(D FN,PTF,DGZ P) ;SEND C PT PROCEDU RE TRANSAC TIONS TO P CE
	1307	"RTN","DGA PI1",4,0)
	1308	;
	1309	"RTN","DGA PI1",5,0)
	1310	N DGVISIT ,DR,DIE,DA ,X,Y
	1311	"RTN","DGA PI1",6,0)
	1312	;
	1313	"RTN","DGA PI1",7,0)
	1314	D BUILD
	1315	"RTN","DGA PI1",8,0)
	1316	;
	1317	"RTN","DGA PI1",9,0)
	1318	I $P($G(D GZPRF(DGZP )),U,6) S DGVISIT=$P (DGZPRF(DG ZP),U,6)
	1319	"RTN","DGA PI1",10,0)
	1320	;
	1321	"RTN","DGA PI1",11,0)
	1322	I $D(DGRE L) S DGREL SV=DGREL ; save DGREL , it gets killed off in SCDXMS G1
	1323	"RTN","DGA PI1",12,0)
	1324	S RES=$$D ATA2PCE^PX API("^TMP( ""DGPCE1"" ,$J,""PXAP I"")",107, "801 SCREE N",.DGVISI T)
	1325	"RTN","DGA PI1",13,0)
	1326	I $D(DGRE LSV) S DGR EL=DGRELSV K DGRELSV ;restore DGREL
	1327	"RTN","DGA PI1",14,0)
	1328	;
	1329	"RTN","DGA PI1",15,0)
	1330	D:$D(^TMP ("DGPCE1", $J,"PXAPI" ,"DIERR")) ERR
	1331	"RTN","DGA PI1",16,0)
	1332	;
	1333	"RTN","DGA PI1",17,0)
	1334	K ^TMP("D GPCE1",$J, "PXAPI")
	1335	"RTN","DGA PI1",18,0)
	1336	;
	1337	"RTN","DGA PI1",19,0)
	1338	;
	1339	"RTN","DGA PI1",20,0)
	1340	Q:RES<-1 RES
	1341	"RTN","DGA PI1",21,0)
	1342	;
	1343	"RTN","DGA PI1",22,0)
	1344	S DR=".06 ////"_DGVI SIT_";.07/ ///1",DIE= "^DGPT("_P TF_",""C"" ,",DA=DGZP RF(DGZP,0) ,DA(1)=PTF D ^DIE
	1345	"RTN","DGA PI1",23,0)
	1346	;
	1347	"RTN","DGA PI1",24,0)
	1348	Q RES
	1349	"RTN","DGA PI1",25,0)
	1350	;
	1351	"RTN","DGA PI1",26,0)
	1352	ERR ; look s to see i f there is an truly an error
	1353	"RTN","DGA PI1",27,0)
	1354	N DGX,DGQ
	1355	"RTN","DGA PI1",28,0)
	1356	S (DGQ,DG X)=0 F S DGX=$O(^TM P("DGPCE1" ,$J,"PXAPI ","DIERR", $J,DGX)) Q :'DGX!(DGQ ) I $E($G (^TMP("DGP CE1",$J,"P XAPI","DIE RR",$J,DGX ,"TEXT",1) ),1,5)="ER ROR" S DGQ =1 D ERRMS G(DGX)
	1357	"RTN","DGA PI1",29,0)
	1358	Q
	1359	"RTN","DGA PI1",30,0)
	1360	;
	1361	"RTN","DGA PI1",31,0)
	1362	ERRMSG(DGX ) ; sends the error message
	1363	"RTN","DGA PI1",32,0)
	1364	N XMDUZ,X MSUB,XMTEX T,XMY,XMZ, XMMG,DGL,D GTXT,DGY
	1365	"RTN","DGA PI1",33,0)
	1366	;
	1367	"RTN","DGA PI1",34,0)
	1368	D DEM^VAD PT
	1369	"RTN","DGA PI1",35,0)
	1370	;
	1371	"RTN","DGA PI1",36,0)
	1372	S XMDUZ=" PTF MODULE ",XMSUB="8 01 to PCE filing err or"
	1373	"RTN","DGA PI1",37,0)
	1374	S XMY("G. DG PTF 801 TO PCE ER ROR")="",X MY(DUZ)="" ,XMTEXT="D GTXT("
	1375	"RTN","DGA PI1",38,0)
	1376	;
	1377	"RTN","DGA PI1",39,0)
	1378	S DGTXT(1 ,0)="An er ror has oc curred whi le sending PTF 801 d ata to PCE ."
	1379	"RTN","DGA PI1",40,0)
	1380	S DGTXT(2 ,0)=" "
	1381	"RTN","DGA PI1",41,0)
	1382	S DGTXT(3 ,0)=" Patient Na me: "_VAD M(1)
	1383	"RTN","DGA PI1",42,0)
	1384	S DGTXT(4 ,0)=" Social Sec urity: "_ $P(VADM(2) ,"^",2)
	1385	"RTN","DGA PI1",43,0)
	1386	S DGTXT(5 ,0)=" Date/Time: "_$$FMTE ^XLFDT(+DG ZPRF(DGZP) )
	1387	"RTN","DGA PI1",44,0)
	1388	S DGTXT(6 ,0)=" Location: "_$P($G(^ SC($P(DGZP RF(DGZP)," ^",5),0)), "^")
	1389	"RTN","DGA PI1",45,0)
	1390	S DGTXT(7 ,0)=" "
	1391	"RTN","DGA PI1",46,0)
	1392	;
	1393	"RTN","DGA PI1",47,0)
	1394	S DGL=7,D GY=0 F S DGY=$O(^TM P("DGPCE1" ,$J,"PXAPI ","DIERR", $J,DGX,"TE XT",DGY)) Q:'DGY!($E (^TMP("DGP CE1",$J,"P XAPI","DIE RR",$J,DGX ,"TEXT",DG Y),1,25)=" ^TMP(""DGP CE1"",$J," "PXAPI"")" ) D
	1395	"RTN","DGA PI1",48,0)
	1396	. S DGL=D GL+1,DGTXT (DGL,0)=" "_^TMP ("DGPCE1", $J,"PXAPI" ,"DIERR",$ J,DGX,"TEX T",DGY)
	1397	"RTN","DGA PI1",49,0)
	1398	;
	1399	"RTN","DGA PI1",50,0)
	1400	D ^XMD
	1401	"RTN","DGA PI1",51,0)
	1402	D KVAR^VA DPT
	1403	"RTN","DGA PI1",52,0)
	1404	;
	1405	"RTN","DGA PI1",53,0)
	1406	Q
	1407	"RTN","DGA PI1",54,0)
	1408	;
	1409	"RTN","DGA PI1",55,0)
	1410	DELVFILE(D FN,PTF,DGZ P) ;DELETE VISIT IN PCE WHEN A CHANGE IS MADE
	1411	"RTN","DGA PI1",56,0)
	1412	N DIE,DA, DR S RES=1
	1413	"RTN","DGA PI1",57,0)
	1414	S:$P(DGZP RF(DGZP),U ,7) RES=$$ DELVFILE^P XAPI("ALL" ,$P(DGZPRF (DGZP),U,6 ))
	1415	"RTN","DGA PI1",58,0)
	1416	S DA=DGZP RF(DGZP,0) ,DA(1)=PTF
	1417	"RTN","DGA PI1",59,0)
	1418	S DIE="^D GPT("_PTF_ ",""C"",", DR=".06/// @;.07////0 " D ^DIE
	1419	"RTN","DGA PI1",60,0)
	1420	Q RES
	1421	"RTN","DGA PI1",61,0)
	1422	;
	1423	"RTN","DGA PI1",62,0)
	1424	BUILD ; no w build ar ray for pa ssing data to PCE
	1425	"RTN","DGA PI1",63,0)
	1426	N DGAPI,D GC,DGPROC, DGPROCZ,DG P,DGDXNO,D GDXC,DGDX, DGX
	1427	"RTN","DGA PI1",64,0)
	1428	K ^TMP("D GPCE1",$J, "PXAPI") S DGDXC=0
	1429	"RTN","DGA PI1",65,0)
	1430	S DGAPI=$ NA(^TMP("D GPCE1",$J, "PXAPI"))
	1431	"RTN","DGA PI1",66,0)
	1432	; ------- --encounte r date/tim e--------- -------
	1433	"RTN","DGA PI1",67,0)
	1434	S @DGAPI@ ("ENCOUNTE R",1,"ENC D/T")=+DGZ PRF(DGZP)
	1435	"RTN","DGA PI1",68,0)
	1436	; ------- -------pat ient------ ---------- -------
	1437	"RTN","DGA PI1",69,0)
	1438	S @DGAPI@ ("ENCOUNTE R",1,"PATI ENT")=DFN
	1439	"RTN","DGA PI1",70,0)
	1440	; ------- --------lo cation---- ---------- -------
	1441	"RTN","DGA PI1",71,0)
	1442	S @DGAPI@ ("ENCOUNTE R",1,"HOS LOC")=$P(D GZPRF(DGZP ),"^",5)
	1443	"RTN","DGA PI1",72,0)
	1444	; ------- -------ser vice categ ory------- -------
	1445	"RTN","DGA PI1",73,0)
	1446	S @DGAPI@ ("ENCOUNTE R",1,"SERV ICE CATEGO RY")="I"
	1447	"RTN","DGA PI1",74,0)
	1448	; ------- --------en counter ty pe-------- -------
	1449	"RTN","DGA PI1",75,0)
	1450	S @DGAPI@ ("ENCOUNTE R",1,"ENCO UNTER TYPE ")="P"
	1451	"RTN","DGA PI1",76,0)
	1452	; ------- -----prima ry provide r--------- -------
	1453	"RTN","DGA PI1",77,0)
	1454	S @DGAPI@ ("PROVIDER ",1,"NAME" )=$P(DGZPR F(DGZP),"^ ",3)
	1455	"RTN","DGA PI1",78,0)
	1456	S @DGAPI@ ("PROVIDER ",1,"PRIMA RY")=1
	1457	"RTN","DGA PI1",79,0)
	1458	; ------- -----secon dary provi der------- ------
	1459	"RTN","DGA PI1",80,0)
	1460	I $P(DGZP RF(DGZP)," ^",2),$P(D GZPRF(DGZP ),"^",2)'= $P(DGZPRF( DGZP),"^", 3) S @DGAP I@("PROVID ER",2,"NAM E")=$P(DGZ PRF(DGZP), "^",2)
	1461	"RTN","DGA PI1",81,0)
	1462	; ------- ---------p rocedures- ---------- ------
	1463	"RTN","DGA PI1",82,0)
	1464	S DGC=0,D GPROC=0 F S DGPROC= $O(DGZPRF( DGZP,DGPRO C)) Q:'DGP ROC D
	1465	"RTN","DGA PI1",83,0)
	1466	. S DGPRO CZ=$G(DGZP RF(DGZP,DG PROC)) Q:' DGPROCZ
	1467	"RTN","DGA PI1",84,0)
	1468	. S DGC=D GC+1,@DGAP I@("PROCED URE",DGC," PROCEDURE" )=+DGPROCZ
	1469	"RTN","DGA PI1",85,0)
	1470	. ; ----- ---------m odifiers-- ---------- ------
	1471	"RTN","DGA PI1",86,0)
	1472	. F DGP=2 ,3 I $P(DG PROCZ,"^", DGP) S @DG API@("PROC EDURE",DGC ,"MODIFIER S",$P($$MO D^ICPTMOD( $P(DGPROCZ ,"^",DGP), "I",+DGZPR F(DGZP))," ^",2))=""
	1473	"RTN","DGA PI1",87,0)
	1474	. ; ----- ---------q uantity--- ---------- ------
	1475	"RTN","DGA PI1",88,0)
	1476	. S @DGAP I@("PROCED URE",DGC," QTY")=$P(D GPROCZ,"^" ,14)
	1477	"RTN","DGA PI1",89,0)
	1478	. ; ----- ---------d iagnosis-- ---------- ------
	1479	"RTN","DGA PI1",90,0)
	1480	. F DGP=4 :1:7,15:1: 18 I $P(DG PROCZ,"^", DGP) D
	1481	"RTN","DGA PI1",91,0)
	1482	. . S DGD XNO=$S(DGP =4:"",DGP< 15:DGP-3,1 :DGP-11)
	1483	"RTN","DGA PI1",92,0)
	1484	. . S @DG API@("PROC EDURE",DGC ,"DIAGNOSI S"_$S(DGDX NO<2:"",1: " "_DGDXNO ))=$P(DGPR OCZ,"^",DG P)
	1485	"RTN","DGA PI1",93,0)
	1486	. . I $D( DGDX($P(DG PROCZ,"^", DGP))) Q
	1487	"RTN","DGA PI1",94,0)
	1488	. . S DGD X($P(DGPRO CZ,"^",DGP ))="",DGDX C=DGDXC+1
	1489	"RTN","DGA PI1",95,0)
	1490	. . S @DG API@("DX/P L",DGDXC," DIAGNOSIS" )=$P(DGPRO CZ,"^",DGP )
	1491	"RTN","DGA PI1",96,0)
	1492	. . S:DGD XC=1 @DGAP I@("DX/PL" ,DGDXC,"PR IMARY")=1
	1493	"RTN","DGA PI1",97,0)
	1494	. . S (DG Y,DGX)=0 F S DGX=$O (^DGICD9(4 6.1,"C",PT F,DGX)) Q: 'DGX!(DGY) I +$G(^D GICD9(46.1 ,DGX,0))=$ P(DGPROCZ, "^",DGP) S DGY=DGX
	1495	"RTN","DGA PI1",98,0)
	1496	. . S DGY =$G(^DGICD 9(46.1,+DG Y,0))
	1497	"RTN","DGA PI1",99,0)
	1498	. . I $L( $P(DGY,"^" ,2)) S @DG API@("DX/P L",DGDXC," PL SC")=$P (DGY,"^",2 )
	1499	"RTN","DGA PI1",100,0 )
	1500	. . I $L( $P(DGY,"^" ,3)) S @DG API@("DX/P L",DGDXC," PL AO")=$P (DGY,"^",3 )
	1501	"RTN","DGA PI1",101,0 )
	1502	. . I $L( $P(DGY,"^" ,4)) S @DG API@("DX/P L",DGDXC," PL IR")=$P (DGY,"^",4 )
	1503	"RTN","DGA PI1",102,0 )
	1504	. . I $L( $P(DGY,"^" ,5)) S @DG API@("DX/P L",DGDXC," PL EC")=$P (DGY,"^",5 )
	1505	"RTN","DGA PI1",103,0 )
	1506	. . I $L( $P(DGY,"^" ,6)) S @DG API@("DX/P L",DGDXC," PL MST")=$ P(DGY,"^", 6)
	1507	"RTN","DGA PI1",104,0 )
	1508	. . I $L( $P(DGY,"^" ,7)) S @DG API@("DX/P L",DGDXC," PL HNC")=$ P(DGY,"^", 7)
	1509	"RTN","DGA PI1",105,0 )
	1510	. . I $L( $P(DGY,"^" ,8)) S @DG API@("DX/P L",DGDXC," PL CV")=$P (DGY,"^",8 )
	1511	"RTN","DGA PI1",106,0 )
	1512	. . I $L( $P(DGY,"^" ,9)) S @DG API@("DX/P L",DGDXC," PL SHAD")= $P(DGY,"^" ,9)
	1513	"RTN","DGA PI1",107,0 )
	1514	. . I $L( $P(DGY,"^" ,10)) S @D GAPI@("DX/ PL",DGDXC, "PL CLV")= $P(DGY,"^" ,10)
	1515	"RTN","DGA PI1",108,0 )
	1516	;JMM DG5 .3914 RSD 2.6.5.3.3 .4, 2.6.5. 2.5.2 and 2.6.5.4.1 Add "PL CL V" line ab ove to inc lude Camp Lejeune in data sent to PCE
	1517	"RTN","DGA PI1",109,0 )
	1518	Q
	1519	"RTN","DGA PI1",110,0 )
	1520	;
	1521	"RTN","DGE NCLEA")
	1522	0^67^B2305 1710^B2289 2557
	1523	"RTN","DGE NCLEA",1,0 )
	1524	DGENCLEA ; ALB/JLS - Camp Lejeu ne Eligibi lity API - Retrieve Eligibilit y ;11/28/1 4 4:25pm
	1525	"RTN","DGE NCLEA",2,0 )
	1526	;;5.3;Reg istration; *909,914 *;Aug 13,1 993;Build 173
	1527	"RTN","DGE NCLEA",3,0 )
	1528	;
	1529	"RTN","DGE NCLEA",4,0 )
	1530	; Busines s Rules to determine Camp Leje une Eligib ility:
	1531	"RTN","DGE NCLEA",5,0 )
	1532	;. Person is a Vete ran AND
	1533	"RTN","DGE NCLEA",6,0 )
	1534	; . Eith er ("Rule 1")
	1535	"RTN","DGE NCLEA",7,0 )
	1536	; . Ha s one Mili tary Servi ce Episode (DGMSE) b etween, an d inclusiv e of, Aug 1, 1953 an d Dec 31, 1987 and
	1537	"RTN","DGE NCLEA",8,0 )
	1538	; . Th e identifi ed DGMSE h as a chara cter of di scharge ot her than
	1539	"RTN","DGE NCLEA",9,0 )
	1540	; . Dishonorab le
	1541	"RTN","DGE NCLEA",10, 0)
	1542	; . Other Than Honorable
	1543	"RTN","DGE NCLEA",11, 0)
	1544	; . Undesirabl e
	1545	"RTN","DGE NCLEA",12, 0)
	1546	; . Bad Conduc t
	1547	"RTN","DGE NCLEA",13, 0)
	1548	; . Dishonorab le-VA
	1549	"RTN","DGE NCLEA",14, 0)
	1550	;AND
	1551	"RTN","DGE NCLEA",15, 0)
	1552	; . Th e identifi ed DGMSE i s at least 30 days i n duration
	1553	"RTN","DGE NCLEA",16, 0)
	1554	; . OR ( "Rule 2"; perform th is check o nly if "Ru le 1" was not met)
	1555	"RTN","DGE NCLEA",17, 0)
	1556	; . Ha s more tha n one Mili tary Servi ce Episode s (DGMSEs) between, and inclus ive of, Au g 1, 1953 and Dec 31 , 1987 AND
	1557	"RTN","DGE NCLEA",18, 0)
	1558	; . Al l of the i dentified DGMSEs hav e a charac ter of dis charge oth er than
	1559	"RTN","DGE NCLEA",19, 0)
	1560	; . Dishonorab le
	1561	"RTN","DGE NCLEA",20, 0)
	1562	; . Other Than Honorable
	1563	"RTN","DGE NCLEA",21, 0)
	1564	; . Undesirabl e
	1565	"RTN","DGE NCLEA",22, 0)
	1566	; . Bad Conduc t
	1567	"RTN","DGE NCLEA",23, 0)
	1568	; . Dishonorab le-VA
	1569	"RTN","DGE NCLEA",24, 0)
	1570	;AND
	1571	"RTN","DGE NCLEA",25, 0)
	1572	; . Th e sum of t wo or more of the id entified D GMSEs add up to at l east 30 da ys in dura tion (mean ing that i t does not have to b e consecut ive days)
	1573	"RTN","DGE NCLEA",26, 0)
	1574	;
	1575	"RTN","DGE NCLEA",27, 0)
	1576	; Inputs : DFN
	1577	"RTN","DGE NCLEA",28, 0)
	1578	; Outputs : CLE retu rns 1 if p atient is camp lejeu ne eligibl e, returns 0 if not camp lejeu ne eligibl e
	1579	"RTN","DGE NCLEA",29, 0)
	1580	; 0 - CL E "Not Eli gible"
	1581	"RTN","DGE NCLEA",30, 0)
	1582	; 1 - CL E "Eligibl e"
	1583	"RTN","DGE NCLEA",31, 0)
	1584	;
	1585	"RTN","DGE NCLEA",32, 0)
	1586	CLE(DFN) ;
	1587	"RTN","DGE NCLEA",33, 0)
	1588	K DGMSE
	1589	"RTN","DGE NCLEA",34, 0)
	1590	; Is pati ent a vete ran VET1 I s the pati ent an eli gible vete ran VET
	1591	"RTN","DGE NCLEA",35, 0)
	1592	I '$$VET^ DGENPTA(DF N) Q 0
	1593	"RTN","DGE NCLEA",36, 0)
	1594	; If prim ary eligib ility code exists it must be a Veteran T ype Eligib ility Code from File 8
	1595	"RTN","DGE NCLEA",37, 0)
	1596	N DGPRIEL
	1597	"RTN","DGE NCLEA",38, 0)
	1598	S DGPRIEL =$P($G(^DP T(DFN,.36) ),U,1)
	1599	"RTN","DGE NCLEA",39, 0)
	1600	I DGPRIEL ]"",$P($G( ^DIC(8,DGP RIEL,0)),U ,5)="N" Q 0
	1601	"RTN","DGE NCLEA",40, 0)
	1602	; Get DGM SE data fr om DGMSE s ub-file #2 .3216 firs t, if that does not exist get DGMSE data from .32 node
	1603	"RTN","DGE NCLEA",41, 0)
	1604	N DGMSE
	1605	"RTN","DGE NCLEA",42, 0)
	1606	I $D(^DPT (DFN,.3216 )) D GETMS E^DGMSEUTL (DFN,.DGMS E)
	1607	"RTN","DGE NCLEA",43, 0)
	1608	I $G(DGMS E)="" S DG MSE=$G(^DP T(DFN,.32) )
	1609	"RTN","DGE NCLEA",44, 0)
	1610	I '$D(DGM SE) Q 0
	1611	"RTN","DGE NCLEA",45, 0)
	1612	; Loop th rough DGMS E to find at least 1 qualifyin g DGMSE ( CLE=1)
	1613	"RTN","DGE NCLEA",46, 0)
	1614	N DGENTDT ,DGEXITDT, DGTYPE,DGL OOP,DGCLE, DGCLSRDT,X 1,X2
	1615	"RTN","DGE NCLEA",47, 0)
	1616	S (DGCLE, DGCLSRDT)= 0
	1617	"RTN","DGE NCLEA",48, 0)
	1618	S DGLOOP= "" F S DG LOOP=$O(DG MSE(DGLOOP )) Q:(DGLO OP="")!(DG CLE=1) D
	1619	"RTN","DGE NCLEA",49, 0)
	1620	. S (DGEN TDT,DGEXIT DT,DGTYPE, X1,X2)=""
	1621	"RTN","DGE NCLEA",50, 0)
	1622	. S DGENT DT=$$FMTH^ XLFDT($P(D GMSE(DGLOO P),"^",1), 1),DGEXITD T=$$FMTH^X LFDT($P(DG MSE(DGLOOP ),"^",2),1 ),DGTYPE=$ P(DGMSE(DG LOOP),"^", 6)
	1623	"RTN","DGE NCLEA",51, 0)
	1624	. ;automa tically qu it out of this DGMSE if Discha rge is 2,4 ,5,6,8 or null
	1625	"RTN","DGE NCLEA",52, 0)
	1626	. ;File # 25 (Dishon orable,Oth er Than Di shonorable ,Undesirab le,Bad Con duct,Disho norable-VA
	1627	"RTN","DGE NCLEA",53, 0)
	1628	. Q:(DGTY PE=2)!(DGT YPE=4)!(DG TYPE=5)!(D GTYPE=6)!( DGTYPE=8)! (DGTYPE="" )
	1629	"RTN","DGE NCLEA",54, 0)
	1630	. ;automa tically qu it out if DGMSE is N OT within date range
	1631	"RTN","DGE NCLEA",55, 0)
	1632	. ;080119 53 and 123 11987
	1633	"RTN","DGE NCLEA",56, 0)
	1634	. ;$H 411 20(subtrac ted +1 to be 'inclus ive') and 53690(adde d +1 to be 'inclusiv e')
	1635	"RTN","DGE NCLEA",57, 0)
	1636	. ;FM 253 0801 and 2 871231
	1637	"RTN","DGE NCLEA",58, 0)
	1638	. Q:(DGEN TDT>53690) !(DGEXITDT <41120) ;if either date is o ut of CLE date range do not co ntinue (in eligible)
	1639	"RTN","DGE NCLEA",59, 0)
	1640	. I DGENT DT<41120 S DGENTDT=4 1120 ;onl y include Entry Date s starting from CLE date range
	1641	"RTN","DGE NCLEA",60, 0)
	1642	. I DGEXI TDT>53690 S DGEXITDT =53690 ;only incl ude Exit D ates endin g at CLE d ate range
	1643	"RTN","DGE NCLEA",61, 0)
	1644	. S X1=$$ HTFM^XLFDT ($G(DGEXIT DT)),X2=$$ HTFM^XLFDT ($G(DGENTD T)) D ^%DT C S DGCLSR DT=DGCLSRD T+(X+1)
	1645	"RTN","DGE NCLEA",62, 0)
	1646	. ;automa tically qu it out if DGMSE is N OT greater than 30 d ays
	1647	"RTN","DGE NCLEA",63, 0)
	1648	. Q:DGCLS RDT<30
	1649	"RTN","DGE NCLEA",64, 0)
	1650	. S DGCLE =1
	1651	"RTN","DGE NCLEA",65, 0)
	1652	Q DGCLE
	1653	"RTN","DGE NCLEA",66, 0)
	1654	;
	1655	"RTN","DGE NCLEA",67, 0)
	1656	ADDEDTCL(D FN) ; DG5 .3909 Ent er/Edit Ca mp Lejeune Indicator
	1657	"RTN","DGE NCLEA",68, 0)
	1658	; changed veteran t o Veteran pwc - DG* 5.3*914 Ca mp Lejeune
	1659	"RTN","DGE NCLEA",69, 0)
	1660	;
	1661	"RTN","DGE NCLEA",70, 0)
	1662	AECL2 N DG CLIND,DGCL OLD,DGSITE ,X,Y
	1663	"RTN","DGE NCLEA",71, 0)
	1664	K DIR S D IR(0)="YO"
	1665	"RTN","DGE NCLEA",72, 0)
	1666	S DIR("A" )="CAMP LE JEUNE WATE R CONTAMIN ANT EXPOSU RE INDICAT ED"
	1667	"RTN","DGE NCLEA",73, 0)
	1668	S DGCLOLD =$P($G(^DP T(DFN,.321 7)),U,1)
	1669	"RTN","DGE NCLEA",74, 0)
	1670	S DIR("B" )=$S(DGCLO LD="Y":"YE S",DGCLOLD ="N":"NO", 1:"")
	1671	"RTN","DGE NCLEA",75, 0)
	1672	K:DIR("B" )="" DIR(" B")
	1673	"RTN","DGE NCLEA",76, 0)
	1674	S DIR("?" ,1)="Enter "_$C(34)_ "Y"_$C(34) _" if Vete ran claims need "
	1675	"RTN","DGE NCLEA",77, 0)
	1676	S DIR("?" ,1)=DIR("? ",1)_"for care of co nditions r elated to exposure o f"
	1677	"RTN","DGE NCLEA",78, 0)
	1678	S DIR("?" ,2)=$C(34) _"Water Co ntaminatio n at Camp Lejeune"_$ C(34)
	1679	"RTN","DGE NCLEA",79, 0)
	1680	S DIR("?" ,2)=DIR("? ",2)_". En ter "_$C(3 4)_"N"_$C( 34)_" if V eteran "
	1681	"RTN","DGE NCLEA",80, 0)
	1682	S DIR("?" ,2)=DIR("? ",2)_"was not assign ed to"
	1683	"RTN","DGE NCLEA",81, 0)
	1684	S DIR("?" ,3)="Camp Lejeune be tween Augu st 1, 1953 and Decem ber 31, "
	1685	"RTN","DGE NCLEA",82, 0)
	1686	S DIR("?" ,3)=DIR("? ",3)_"1987 or does n ot claim n eed"
	1687	"RTN","DGE NCLEA",83, 0)
	1688	S DIR("?" ,4)="for c are of con ditions re lated to e xposure of "_$C(34)
	1689	"RTN","DGE NCLEA",84, 0)
	1690	S DIR("?" ,4)=DIR("? ",4)_"Wate r Contamin ation at C amp"
	1691	"RTN","DGE NCLEA",85, 0)
	1692	S DIR("?" ,5)="Lejeu ne"_$C(34) _"."
	1693	"RTN","DGE NCLEA",86, 0)
	1694	S DIR("?" ,6)="Choos e from:",D IR("?",7)= "Y YES",DI R("?",8)=" N NO"
	1695	"RTN","DGE NCLEA",87, 0)
	1696	S DIR("?" )="Null "_ $C(34)_"Bl ank"_$C(34 )
	1697	"RTN","DGE NCLEA",88, 0)
	1698	D ^DIR K DIR
	1699	"RTN","DGE NCLEA",89, 0)
	1700	I X="@" D G AECL2
	1701	"RTN","DGE NCLEA",90, 0)
	1702	. W !!,"C amp Lejeun e indicato r cannot b e deleted if already "
	1703	"RTN","DGE NCLEA",91, 0)
	1704	. W "indi cated.",!, "Enter '^' to exit." ,!
	1705	"RTN","DGE NCLEA",92, 0)
	1706	S DGCLIND =$S(Y=1:"Y ",Y=0:"N", 1:Y)
	1707	"RTN","DGE NCLEA",93, 0)
	1708	Q:DGCLIND ="^" Q:"^ Y^N^"'[(U_ DGCLIND_U)
	1709	"RTN","DGE NCLEA",94, 0)
	1710	S DGSITE= $P($$SITE^ VASITE,U,3 )
	1711	"RTN","DGE NCLEA",95, 0)
	1712	D SAVECL( DFN,DGCLIN D,$P($$NOW ^XLFDT,"." ,1),DGSITE ,"VAMC")
	1713	"RTN","DGE NCLEA",96, 0)
	1714	Q
	1715	"RTN","DGE NCLEA",97, 0)
	1716	;
	1717	"RTN","DGE NCLEA",98, 0)
	1718	SAVECL(DFN ,DGCLIND,D GCLDAT,DGS ITE,DGSOUR CE) ; DG5 .3909 Sav e CL-V inf o
	1719	"RTN","DGE NCLEA",99, 0)
	1720	; Check i f CL-V Ind icator alr eady No or Yes, then use old d ate.
	1721	"RTN","DGE NCLEA",100 ,0)
	1722	N DGCLVRE C S DGCLVR EC=$G(^DPT (DFN,.3217 ))
	1723	"RTN","DGE NCLEA",101 ,0)
	1724	I "^Y^N^" [(U_$P(DGC LVREC,U)_U ),$P(DGCLV REC,U,2)]" " D
	1725	"RTN","DGE NCLEA",102 ,0)
	1726	. S DGCLD AT=$P(DGCL VREC,U,2)
	1727	"RTN","DGE NCLEA",103 ,0)
	1728	S ^DPT(DF N,.3217)=D GCLIND_U_D GCLDAT_U_D GSITE_U_DG SOURCE
	1729	"RTN","DGE NCLEA",104 ,0)
	1730	Q
	1731	"RTN","DGE NCLEA",105 ,0)
	1732	;
	1733	"RTN","DGE NCLEA",106 ,0)
	1734	SETCLNO ; DG5.3909 Set Camp Lejeune to No when n o longer C L Eligible
	1735	"RTN","DGE NCLEA",107 ,0)
	1736	Q:$P($G(^ DPT(DFN,.3 217)),U,1) '="Y"
	1737	"RTN","DGE NCLEA",108 ,0)
	1738	Q:$G(^DPT (DFN,.3217 1))=1 ; if Locked then don' t change Y ES to NO
	1739	"RTN","DGE NCLEA",109 ,0)
	1740	N DGCLE S DGCLE=$$C LE(DFN) Q: DGCLE
	1741	"RTN","DGE NCLEA",110 ,0)
	1742	D SAVECL( DFN,"N",$P ($$NOW^XLF DT,".",1), $P($$SITE^ VASITE,U,3 ),"VAMC")
	1743	"RTN","DGE NCLEA",111 ,0)
	1744	D AUTOUPD ^DGENA2(DF N)
	1745	"RTN","DGE NCLEA",112 ,0)
	1746	Q
	1747	"RTN","DGE NCLEA",113 ,0)
	1748	;
	1749	"RTN","DGP TAEE1")
	1750	0^69^B4331 0874^B3912 5544
	1751	"RTN","DGP TAEE1",1,0 )
	1752	DGPTAEE1 ; ALB/MTC,HI OFO/FT - A ustin Edit s EAL List ing Contin ued ;12/4/ 14 3:05pm
	1753	"RTN","DGP TAEE1",2,0 )
	1754	;;5.3;Reg istration; *338,565, 678,729,66 4,884,914 *;Aug 13, 1993;Build 173
	1755	"RTN","DGP TAEE1",3,0 )
	1756	;
	1757	"RTN","DGP TAEE1",4,0 )
	1758	;no exter nal refere nces
	1759	"RTN","DGP TAEE1",5,0 )
	1760	;
	1761	"RTN","DGP TAEE1",6,0 )
	1762	;DGPTLINE =1 is icd9 layout
	1763	"RTN","DGP TAEE1",7,0 )
	1764	;DGPTLINE =2 is icd1 0 layout
	1765	"RTN","DGP TAEE1",8,0 )
	1766	H101(REC) ;-- 101 he ader //pat ch 850 mad e the need ed changes for 101 s o 884 did have to mo dify this subroutine . ft 12/2/ 14
	1767	"RTN","DGP TAEE1",9,0 )
	1768	; INPUT : REC - Nod e that con tains the error
	1769	"RTN","DGP TAEE1",10, 0)
	1770	N I,X,X1, X2
	1771	"RTN","DGP TAEE1",11, 0)
	1772	S X="ADM SSN ADM-DAT E-TIME LAS T-NAME INIT SOU FROM SOP POW MS SX"
	1773	"RTN","DGP TAEE1",12, 0)
	1774	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	1775	"RTN","DGP TAEE1",13, 0)
	1776	S X=$E(RE C,1,4)_" "_$E(REC,5 ,14)_SP_$E (REC,15,16 )_SP_$E(RE C,17,18)_S P_$E(REC,1 9,20)_SP_$ E(REC,21,2 4)_SP_$E(R EC,31,42)_ " "_$E(R EC,43,44)_ " "_$E(R EC,45,46)_ SP_$E(REC, 47,52)_SP_ $E(REC,53) _" "_$E( REC,54)_" "_$E(REC ,55)_" "_ $E(REC,56)
	1777	"RTN","DGP TAEE1",14, 0)
	1778	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	1779	"RTN","DGP TAEE1",15, 0)
	1780	S X="",$P (X," ",80) =" " F X1= 1:1 S I=$P (DGER,",", X1) Q:I="" I $P(I," :")<12 S X 2=+$P(I,": ",2),X=$E( X,1,X2-1)_ "#"_$E(X,X 2+1,80)
	1781	"RTN","DGP TAEE1",16, 0)
	1782	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	1783	"RTN","DGP TAEE1",17, 0)
	1784	;;Camp Le jeune PWC - RSD 2.6. 5.7 PTF Cl ose out Sc reen DG5. 3914 set to piece 1 00
	1785	"RTN","DGP TAEE1",18, 0)
	1786	S X="BIRT HDATE P OS AGO ION ST-CNTY ZIP MT I NCOME MST CV CV-END SHAD ERI C NTRY"
	1787	"RTN","DGP TAEE1",19, 0)
	1788	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	1789	"RTN","DGP TAEE1",20, 0)
	1790	S X=$E(RE C,57,58)_S P_$E(REC,5 9,60)_SP_$ E(REC,61,6 4)_" "_$ E(REC,65,6 6)_" "_ $E(REC,67) _" "_$E( REC,68)_" "_$E(REC, 69,73)_" "_$E(REC,7 4,78)_" " _$E(REC,79 ,80)_SP_$E (REC,81,86 )_" "_$E( REC,87)_" "_$E(REC ,88)_" "_$ E(REC,89,9 4)
	1791	"RTN","DGP TAEE1",21, 0)
	1792	S X=X_" "_$E(REC ,95)_" "_ $E(REC,96) _" "_$E( REC,97,99)
	1793	"RTN","DGP TAEE1",22, 0)
	1794	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	1795	"RTN","DGP TAEE1",23, 0)
	1796	S X="",$P (X," ",80) =" " F X1= 1:1 S I=$P (DGER,",", X1) Q:I="" I $P(I," :")>11 S X 2=+$P(I,": ",2),X=$E( X,1,X2-1)_ "#"_$E(X,X 2+1,80)
	1797	"RTN","DGP TAEE1",24, 0)
	1798	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	1799	"RTN","DGP TAEE1",25, 0)
	1800	;Camp Lej eune PWC - RSD 2.6.5 .7 PTF Clo se out Scr een DG5.3 914 set t o piece 10 0
	1801	"RTN","DGP TAEE1",26, 0)
	1802	;Add a bl ank line
	1803	"RTN","DGP TAEE1",27, 0)
	1804	S X=""
	1805	"RTN","DGP TAEE1",28, 0)
	1806	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	1807	"RTN","DGP TAEE1",29, 0)
	1808	;CL info will appea r on new l ine due to length of existing line
	1809	"RTN","DGP TAEE1",30, 0)
	1810	S X="CL"
	1811	"RTN","DGP TAEE1",31, 0)
	1812	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	1813	"RTN","DGP TAEE1",32, 0)
	1814	S X=" "_$ E(REC,100, 101)
	1815	"RTN","DGP TAEE1",33, 0)
	1816	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	1817	"RTN","DGP TAEE1",34, 0)
	1818	; CL has no edit ch ecks, just like SHAD
	1819	"RTN","DGP TAEE1",35, 0)
	1820	D WRER^DG PTAEE
	1821	"RTN","DGP TAEE1",36, 0)
	1822	Q
	1823	"RTN","DGP TAEE1",37, 0)
	1824	;
	1825	"RTN","DGP TAEE1",38, 0)
	1826	H401(REC) ;-- 401 he ader
	1827	"RTN","DGP TAEE1",39, 0)
	1828	; INPUT : REC - Nod e that con tains the error
	1829	"RTN","DGP TAEE1",40, 0)
	1830	N X,X1,X2
	1831	"RTN","DGP TAEE1",41, 0)
	1832	S X="SURG SSN ADM-DAT E-TIME SUR G-DATE-TIM E SPEC CA TEG TECH S OP"
	1833	"RTN","DGP TAEE1",42, 0)
	1834	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	1835	"RTN","DGP TAEE1",43, 0)
	1836	S X=$E(RE C,1,4)_" "_$E(REC,5 ,14)_SP_$E (REC,15,16 )_SP_$E(RE C,17,18)_S P_$E(REC,1 9,20)_SP_$ E(REC,21,2 4)_" "_$E (REC,31,32 )_SP_$E(RE C,33,34)_S P_$E(REC,3 5,36)_SP_$ E(REC,37,4 0)_" "
	1837	"RTN","DGP TAEE1",44, 0)
	1838	S X=X_$E( REC,41,42) _" "_$E(R EC,43)_" "_$E(REC, 44)_" "_ $E(REC,45) _" "_$E( REC,46)
	1839	"RTN","DGP TAEE1",45, 0)
	1840	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	1841	"RTN","DGP TAEE1",46, 0)
	1842	S X="",$P (X," ",80) =" " F X1= 1:1 S I=$P (DGER,",", X1) Q:I="" I $P(I," :")<9 S X2 =+$P(I,":" ,2),X=$E(X ,1,X2-1)_" #"_$E(X,X2 +1,80)
	1843	"RTN","DGP TAEE1",47, 0)
	1844	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	1845	"RTN","DGP TAEE1",48, 0)
	1846	I DGPTLIN E=1 D ;ic d9 layout. ft 12/2 /14
	1847	"RTN","DGP TAEE1",49, 0)
	1848	.S X="--- ---------S URGICAL CO DES------- ------ PH Y SSN TR NSPLNT"
	1849	"RTN","DGP TAEE1",50, 0)
	1850	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1851	"RTN","DGP TAEE1",51, 0)
	1852	.S X=$E(R EC,47,53)_ SP_$E(REC, 54,60)_SP_ $E(REC,61, 67)_SP_$E( REC,68,74) _SP_$E(REC ,75,81)_" "_$E(REC, 82,90)_" "_$E(RE C,91)
	1853	"RTN","DGP TAEE1",52, 0)
	1854	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1855	"RTN","DGP TAEE1",53, 0)
	1856	.S X="",$ P(X," ",80 )=" " F X1 =1:1 S I=$ P(DGER,"," ,X1) Q:I=" " I $P(I, ":")>8 S X 2=+$P(I,": ",2),X=$E( X,1,X2-1)_ "#"_$E(X,X 2+1,80)
	1857	"RTN","DGP TAEE1",54, 0)
	1858	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1859	"RTN","DGP TAEE1",55, 0)
	1860	I DGPTLIN E=2 D ;ic d10 layout . ft 12/ 2/14
	1861	"RTN","DGP TAEE1",56, 0)
	1862	.S X="--- ---------S URGICAL CO DES------- ------"
	1863	"RTN","DGP TAEE1",57, 0)
	1864	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1865	"RTN","DGP TAEE1",58, 0)
	1866	.S X=$E(R EC,47,53)_ SP_$E(REC, 55,61)_SP_ $E(REC,63, 69)_SP_$E( REC,71,77) _SP_$E(REC ,79,85)
	1867	"RTN","DGP TAEE1",59, 0)
	1868	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1869	"RTN","DGP TAEE1",60, 0)
	1870	.S X=$E(R EC,87,93)_ SP_$E(REC, 95,101)_SP _$E(REC,10 3,109)_SP_ $E(REC,111 ,117)_SP_$ E(REC,119, 125)
	1871	"RTN","DGP TAEE1",61, 0)
	1872	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1873	"RTN","DGP TAEE1",62, 0)
	1874	.S X=$E(R EC,127,133 )_SP_$E(RE C,135,141) _SP_$E(REC ,143,149)_ SP_$E(REC, 151,157)_S P_$E(REC,1 59,167)
	1875	"RTN","DGP TAEE1",63, 0)
	1876	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1877	"RTN","DGP TAEE1",64, 0)
	1878	.S X=$E(R EC,167,173 )_SP_$E(RE C,175,181) _SP_$E(REC ,183,189)_ SP_$E(REC, 191,197)_S P_$E(REC,1 99,205)
	1879	"RTN","DGP TAEE1",65, 0)
	1880	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1881	"RTN","DGP TAEE1",66, 0)
	1882	.S X=$E(R EC,207,213 )_SP_$E(RE C,215,221) _SP_$E(REC ,223,229)_ SP_$E(REC, 231,237)_S P_$E(REC,2 39,246)
	1883	"RTN","DGP TAEE1",67, 0)
	1884	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1885	"RTN","DGP TAEE1",68, 0)
	1886	.S X="",$ P(X," ",80 )=" " F X1 =1:1 S I=$ P(DGER,"," ,X1) Q:I=" " I $P(I, ":")>8 S X 2=+$P(I,": ",2),X=$E( X,1,X2-1)_ "#"_$E(X,X 2+1,80)
	1887	"RTN","DGP TAEE1",69, 0)
	1888	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1889	"RTN","DGP TAEE1",70, 0)
	1890	D WRER^DG PTAEE
	1891	"RTN","DGP TAEE1",71, 0)
	1892	Q
	1893	"RTN","DGP TAEE1",72, 0)
	1894	;
	1895	"RTN","DGP TAEE1",73, 0)
	1896	H501(REC) ;-- 501 he ader
	1897	"RTN","DGP TAEE1",74, 0)
	1898	; INPUT : REC - Nod e that con tains the error
	1899	"RTN","DGP TAEE1",75, 0)
	1900	N X,X1,X2
	1901	"RTN","DGP TAEE1",76, 0)
	1902	S X="DIAG SSN ADM-DAT E-TIME MOV E DATE-TIM E MPCR COD E SPC LVE PASS SCI"
	1903	"RTN","DGP TAEE1",77, 0)
	1904	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	1905	"RTN","DGP TAEE1",78, 0)
	1906	S X=$E(RE C,1,4)_" "_$E(REC,5 ,14)_SP_$E (REC,15,16 )_SP_$E(RE C,17,18)_S P_$E(REC,1 9,20)_SP_$ E(REC,21,2 4)_SP_$E(R EC,31,32)_ SP_$E(REC, 33,34)_SP_ $E(REC,35, 36)_SP_$E( REC,37,40) _SP
	1907	"RTN","DGP TAEE1",79, 0)
	1908	S X=X_" "_$E(REC,4 1,46)_" " _$E(REC,47 ,48)_" "_ $E(REC,49, 51)_" "_$ E(REC,52,5 4)_" "_$E (REC,55)
	1909	"RTN","DGP TAEE1",80, 0)
	1910	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	1911	"RTN","DGP TAEE1",81, 0)
	1912	S X="",$P (X," ",80) =" " F X1= 1:1 S I=$P (DGER,",", X1) Q:I="" I $P(I," :")<10 S X 2=+$P(I,": ",2),X=$E( X,1,X2-1)_ "#"_$E(X,X 2+1,80)
	1913	"RTN","DGP TAEE1",82, 0)
	1914	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	1915	"RTN","DGP TAEE1",83, 0)
	1916	I DGPTLIN E=1 D ;ic d9 layout. ft 12/2/ 14
	1917	"RTN","DGP TAEE1",84, 0)
	1918	.S X="--- --------DI AGNOSTIC C ODES------ ------"
	1919	"RTN","DGP TAEE1",85, 0)
	1920	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1921	"RTN","DGP TAEE1",86, 0)
	1922	.S X=$E(R EC,56,62)_ SP_$E(REC, 63,69)_SP_ $E(REC,70, 76)_SP_$E( REC,77,83) _SP_$E(REC ,84,90)
	1923	"RTN","DGP TAEE1",87, 0)
	1924	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1925	"RTN","DGP TAEE1",88, 0)
	1926	.S X="",$ P(X," ",80 )=" " F X1 =1:1 S I=$ P(DGER,"," ,X1) Q:I=" " I $P(I, ":")=10 S X2=+$P(I," :",2),X=$E (X,1,X2-1) _"#"_$E(X, X2+1,80)
	1927	"RTN","DGP TAEE1",89, 0)
	1928	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1929	"RTN","DGP TAEE1",90, 0)
	1930	.S X="SSN ATTY PHY PHY LOC C DE BSI LI SI DRUG A4 A5 SC A O IR SWAC"
	1931	"RTN","DGP TAEE1",91, 0)
	1932	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1933	"RTN","DGP TAEE1",92, 0)
	1934	.S X=$E(R EC,91,99)_ " "_$E( REC,100,10 5)_" "_ $E(REC,106 ,107)_" " _$E(REC,10 8)_" "_$ E(REC,109) _" "_$E(R EC,110)_SP _$E(REC,11 1,114)_" "_$E(REC,1 15)_SP_$E( REC,116,11 9)_" "_$E (REC,120)_ " "_$E(RE C,121)_" "_$E(REC,1 22)_" "_$ E(REC,123)
	1935	"RTN","DGP TAEE1",93, 0)
	1936	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1937	"RTN","DGP TAEE1",94, 0)
	1938	.S X="",$ P(X," ",80 )=" " F X1 =1:1 S I=$ P(DGER,"," ,X1) Q:I=" " I $P(I, ":")>10 S X2=+$P(I," :",2),X=$E (X,1,X2-1) _"#"_$E(X, X2+1,80)
	1939	"RTN","DGP TAEE1",95, 0)
	1940	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1941	"RTN","DGP TAEE1",96, 0)
	1942	I DGPTLIN E=2 D ;ic d10 layout . ft 12/2 /14
	1943	"RTN","DGP TAEE1",97, 0)
	1944	.S X="--- --------DI AGNOSTIC C ODES------ ------"
	1945	"RTN","DGP TAEE1",98, 0)
	1946	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1947	"RTN","DGP TAEE1",99, 0)
	1948	.S X=$E(R EC,56,63)_ SP_$E(REC, 64,71)_SP_ $E(REC,72, 79)_SP_$E( REC,80,87) _SP_$E(REC ,88,95)
	1949	"RTN","DGP TAEE1",100 ,0)
	1950	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1951	"RTN","DGP TAEE1",101 ,0)
	1952	.S X=$E(R EC,96,103) _SP_$E(REC ,104,111)_ SP_$E(REC, 112,119)_S P_$E(REC,1 20,127)_SP _$E(REC,12 8,135)
	1953	"RTN","DGP TAEE1",102 ,0)
	1954	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1955	"RTN","DGP TAEE1",103 ,0)
	1956	.S X=$E(R EC,136,143 )_SP_$E(RE C,144,151) _SP_$E(REC ,152,159)_ SP_$E(REC, 160,167)_S P_$E(REC,1 68,175)
	1957	"RTN","DGP TAEE1",104 ,0)
	1958	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1959	"RTN","DGP TAEE1",105 ,0)
	1960	.S X=$E(R EC,176,183 )_SP_$E(RE C,184,191) _SP_$E(REC ,192,199)_ SP_$E(REC, 200,207)_S P_$E(REC,2 08,215)
	1961	"RTN","DGP TAEE1",106 ,0)
	1962	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1963	"RTN","DGP TAEE1",107 ,0)
	1964	.S X=$E(R EC,216,223 )_SP_$E(RE C,224,231) _SP_$E(REC ,232,239)_ SP_$E(REC, 240,247)_S P_$E(REC,2 48,255)_SP _$E(REC,26 5,270)_SP_ $E(REC,271 ,272)_SP_$ E(REC,273)
	1965	"RTN","DGP TAEE1",108 ,0)
	1966	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1967	"RTN","DGP TAEE1",109 ,0)
	1968	.S X="",$ P(X," ",80 )=" " F X1 =1:1 S I=$ P(DGER,"," ,X1) Q:I=" " I $P(I, ":")>9 S X 2=+$P(I,": ",2),X=$E( X,1,X2-1)_ "#"_$E(X,X 2+1,80)
	1969	"RTN","DGP TAEE1",110 ,0)
	1970	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	1971	"RTN","DGP TAEE1",111 ,0)
	1972	D WRER^DG PTAEE
	1973	"RTN","DGP TAEE1",112 ,0)
	1974	Q
	1975	"RTN","DGP TAEE1",113 ,0)
	1976	;
	1977	"RTN","DGP TAEE2")
	1978	0^68^B3339 9825^B3076 5062
	1979	"RTN","DGP TAEE2",1,0 )
	1980	DGPTAEE2 ; ALB/MTC,HI OFO/FT - A ustin Edit s EAL Repo rt Continu ed ;12/17/ 14 11:09am
	1981	"RTN","DGP TAEE2",2,0 )
	1982	;;5.3;Reg istration; 8,338,41 5,565,729, 664,884,91 4;Aug 13 , 1993;Bui ld 173
	1983	"RTN","DGP TAEE2",3,0 )
	1984	;
	1985	"RTN","DGP TAEE2",4,0 )
	1986	;no exter nal refere nces
	1987	"RTN","DGP TAEE2",5,0 )
	1988	;
	1989	"RTN","DGP TAEE2",6,0 )
	1990	;DGPTLINE =1 is icd9 layout
	1991	"RTN","DGP TAEE2",7,0 )
	1992	;DGPTLINE =2 is icd1 0 layout
	1993	"RTN","DGP TAEE2",8,0 )
	1994	H601(REC) ;-- 601 er ror proces sing
	1995	"RTN","DGP TAEE2",9,0 )
	1996	; INPUT : REC - Rec ord that c ontains th e errors
	1997	"RTN","DGP TAEE2",10, 0)
	1998	N X,X1
	1999	"RTN","DGP TAEE2",11, 0)
	2000	S X="PROC SSN ADM-DAT E-TIME PRO C-DATE-TIM E SPC TYP E TRT"
	2001	"RTN","DGP TAEE2",12, 0)
	2002	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	2003	"RTN","DGP TAEE2",13, 0)
	2004	S X=$E(RE C,1,4)_" "_$E(REC,5 ,14)_SP_$E (REC,15,16 )_SP_$E(RE C,17,18)_S P_$E(REC,1 9,20)_SP_$ E(REC,21,2 4)_SP_$E(R EC,31,32)_ SP_$E(REC, 33,34)_SP_ $E(REC,35, 36)_SP_$E( REC,37,40) _" "
	2005	"RTN","DGP TAEE2",14, 0)
	2006	S X=X_$E( REC,41,42) _" "_$ E(REC,43)_ " "_$E(RE C,44,46)
	2007	"RTN","DGP TAEE2",15, 0)
	2008	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	2009	"RTN","DGP TAEE2",16, 0)
	2010	S X="---- -------PRO CEDURE COD ES-------- -----"
	2011	"RTN","DGP TAEE2",17, 0)
	2012	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	2013	"RTN","DGP TAEE2",18, 0)
	2014	I DGPTLIN E=1 D ;ic d9 layout. ft 12/2/ 14
	2015	"RTN","DGP TAEE2",19, 0)
	2016	.S X=$E(R EC,47,53)_ SP_$E(REC, 54,60)_SP_ $E(REC,61, 67)_SP_$E( REC,68,74) _SP_$E(REC ,75,81)
	2017	"RTN","DGP TAEE2",20, 0)
	2018	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	2019	"RTN","DGP TAEE2",21, 0)
	2020	I DGPTLIN E=2 D ;ic d10 layout . ft 11/1 9/14
	2021	"RTN","DGP TAEE2",22, 0)
	2022	.S X=$E(R EC,47,53)_ SP_$E(REC, 55,61)_SP_ $E(REC,63, 69)_SP_$E( REC,71,77) _SP_$E(REC ,79,85)
	2023	"RTN","DGP TAEE2",23, 0)
	2024	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	2025	"RTN","DGP TAEE2",24, 0)
	2026	.S X=$E(R EC,87,93)_ SP_$E(REC, 95,101)_SP _$E(REC,10 3,109)_SP_ $E(REC,111 ,117)_SP_$ E(REC,119, 125)
	2027	"RTN","DGP TAEE2",25, 0)
	2028	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	2029	"RTN","DGP TAEE2",26, 0)
	2030	.S X=$E(R EC,127,133 )_SP_$E(RE C,135,141) _SP_$E(REC ,143,149)_ SP_$E(REC, 151,157)_S P_$E(REC,1 59,165)
	2031	"RTN","DGP TAEE2",27, 0)
	2032	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	2033	"RTN","DGP TAEE2",28, 0)
	2034	.S X=$E(R EC,167,173 )_SP_$E(RE C,175,181) _SP_$E(REC ,183,189)_ SP_$E(REC, 191,197)_S P_$E(REC,1 99,205)
	2035	"RTN","DGP TAEE2",29, 0)
	2036	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	2037	"RTN","DGP TAEE2",30, 0)
	2038	.S X=$E(R EC,207,213 )_SP_$E(RE C,215,221) _SP_$E(REC ,223,229)_ SP_$E(REC, 231,237)_S P_$E(REC,2 39,245)
	2039	"RTN","DGP TAEE2",31, 0)
	2040	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	2041	"RTN","DGP TAEE2",32, 0)
	2042	D WRER^DG PTAEE
	2043	"RTN","DGP TAEE2",33, 0)
	2044	Q
	2045	"RTN","DGP TAEE2",34, 0)
	2046	;
	2047	"RTN","DGP TAEE2",35, 0)
	2048	H701(REC) ;-- 701 he ader
	2049	"RTN","DGP TAEE2",36, 0)
	2050	; INPUT : REC - Rec ord that c ontains th e errors
	2051	"RTN","DGP TAEE2",37, 0)
	2052	N X,X1,X2
	2053	"RTN","DGP TAEE2",38, 0)
	2054	S X="DISP SSN ADM-DAT E-TIME DIS -DATE-TIME SPC TYPE OP/RX VA/ AUS PLACE RECVNG"
	2055	"RTN","DGP TAEE2",39, 0)
	2056	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	2057	"RTN","DGP TAEE2",40, 0)
	2058	S X=$E(RE C,1,4)_" "_$E(REC,5 ,14)_SP_$E (REC,15,16 )_SP_$E(RE C,17,18)_S P_$E(REC,1 9,20)_SP_$ E(REC,21,2 4)_SP_$E(R EC,31,32)_ SP_$E(REC, 33,34)_SP_ $E(REC,35, 36)_SP_$E( REC,37,40) _SP
	2059	"RTN","DGP TAEE2",41, 0)
	2060	S X=X_$E( REC,41,42) _" "_$E (REC,43)_" "_$E( REC,44)_" "_$E(R EC,45)_" "_$E(R EC,46)_" "_$E(REC, 47,52)
	2061	"RTN","DGP TAEE2",42, 0)
	2062	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	2063	"RTN","DGP TAEE2",43, 0)
	2064	S X="",$P (X," ",80) =" " F X1= 1:1 S I=$P (DGER,",", X1) Q:I="" I $P(I," :")<11 S X 2=+$P(I,": ",2),X=$E( X,1,X2-1)_ "#"_$E(X,X 2+1,80)
	2065	"RTN","DGP TAEE2",44, 0)
	2066	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	2067	"RTN","DGP TAEE2",45, 0)
	2068	I DGPTLIN E=1 D
	2069	"RTN","DGP TAEE2",46, 0)
	2070	.S X="ASI H XXXX C/P DXLS O DX MPCR C ODE PHY LOC %SC L I SI DRUG A4 A5"
	2071	"RTN","DGP TAEE2",47, 0)
	2072	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	2073	"RTN","DGP TAEE2",48, 0)
	2074	.S X=$E(R EC,53,55)_ " "_$E( REC,56)_" "_$E(REC ,57)_" " _$E(REC,58 ,64)_" "_ $E(REC,65) _" "_$E(R EC,66,71)_ " "_ $E(REC,72, 73)_" "_$E(REC,7 4,76)_" " _$E(REC,77 )_" "_$E( REC,78)_SP _$E(REC,79 ,82)_" "_ $E(REC,83) _SP_$E(REC ,84,87)
	2075	"RTN","DGP TAEE2",49, 0)
	2076	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	2077	"RTN","DGP TAEE2",50, 0)
	2078	.S X="",$ P(X," ",80 )=" " F X1 =1:1 S I=$ P(DGER,"," ,X1) Q:I=" " I $P(I, ":")>10 S X2=+$P(I," :",2),X=$E (X,1,X2-1) _"#"_$E(X, X2+1,80)
	2079	"RTN","DGP TAEE2",51, 0)
	2080	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	2081	"RTN","DGP TAEE2",52, 0)
	2082	I DGPTLIN E=2 D
	2083	"RTN","DGP TAEE2",53, 0)
	2084	.S X="ASI H RACE C/P DXLS O DX MPCR C ODE PHY LOC %SC L I SI DRUG A4 A5"
	2085	"RTN","DGP TAEE2",54, 0)
	2086	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	2087	"RTN","DGP TAEE2",55, 0)
	2088	.S X=$E(R EC,53,55)_ " "_$E( REC,56)_" "_$E(REC ,57)_" " _$E(REC,58 ,65)_" "_ $E(REC,66) _" "_$E(R EC,67,72)_ " "_ $E(REC,73, 74)_" "_$E(REC,7 5,77)_" " _$E(REC,78 )_" "_$E( REC,79)_SP _$E(REC,80 ,83)_" "_ $E(REC,84) _SP_$E(REC ,85,88)
	2089	"RTN","DGP TAEE2",56, 0)
	2090	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	2091	"RTN","DGP TAEE2",57, 0)
	2092	.S X="",$ P(X," ",80 )=" " F X1 =1:1 S I=$ P(DGER,"," ,X1) Q:I=" " I $P(I, ":")>10,$P (I,":")<24 S X2=+$P( I,":",2),X =$E(X,1,X2 -1)_"#"_$E (X,X2+1,80 )
	2093	"RTN","DGP TAEE2",58, 0)
	2094	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	2095	"RTN","DGP TAEE2",59, 0)
	2096	.;Camp Le jeune PWC - RSD 2.6. 5.7 PTF Cl ose out Sc reen DG5. 3914
	2097	"RTN","DGP TAEE2",60, 0)
	2098	.S X="SC AO IR SWAC MST HNC E TH RACE CV S HAD CL "
	2099	"RTN","DGP TAEE2",61, 0)
	2100	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	2101	"RTN","DGP TAEE2",62, 0)
	2102	.;Camp Le jeune PWC - RSD 2.6. 5.7 PTF Cl ose out Sc reen DG5. 3914 set to piece 1 13 to matc h ICD9 lay out and 11 4 to match ICD10
	2103	"RTN","DGP TAEE2",63, 0)
	2104	.S X=$E(R EC,89)_" "_$E(REC,9 0)_" "_$E (REC,91)_" "_$E(REC ,92)_" "_$E(REC, 93)_" "_ $E(REC,94) _" "_$E(R EC,95,96)_ " "_$E(RE C,99,108)_ " "_$E(RE C,109)_" "_$E(REC,1 10)_" "_$S( DGPTLINE=1 :$E(REC,11 3),1:$E(RE C,114))
	2105	"RTN","DGP TAEE2",64, 0)
	2106	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	2107	"RTN","DGP TAEE2",65, 0)
	2108	D WRER^DG PTAEE
	2109	"RTN","DGP TAEE2",66, 0)
	2110	Q
	2111	"RTN","DGP TAEE2",67, 0)
	2112	;
	2113	"RTN","DGP TAEE2",68, 0)
	2114	H702(REC) ;-- 702 he ader
	2115	"RTN","DGP TAEE2",69, 0)
	2116	; INPUT : REC - Rec ord that c ontains th e errors
	2117	"RTN","DGP TAEE2",70, 0)
	2118	N X,X1
	2119	"RTN","DGP TAEE2",71, 0)
	2120	S X="ADM SSN ADM-DAT E-TIME DIS -DATE-TIME "
	2121	"RTN","DGP TAEE2",72, 0)
	2122	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	2123	"RTN","DGP TAEE2",73, 0)
	2124	S X=$E(RE C,1,4)_" "_$E(REC,5 ,14)_SP_$E (REC,15,16 )_SP_$E(RE C,17,18)_S P_$E(REC,1 9,20)_SP_$ E(REC,21,2 4)_SP_$E(R EC,31,32)_ SP_$E(REC, 33,34)_SP_ $E(REC,35, 36)_SP_$E( REC,37,40)
	2125	"RTN","DGP TAEE2",74, 0)
	2126	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	2127	"RTN","DGP TAEE2",75, 0)
	2128	S X="---- ---------- ---------- ----DIAGNO STIC CODES ---------- ---------- --------"
	2129	"RTN","DGP TAEE2",76, 0)
	2130	S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X
	2131	"RTN","DGP TAEE2",77, 0)
	2132	I DGPTLIN E=1 D ;ic d9 layout. ft 11/19 /14
	2133	"RTN","DGP TAEE2",78, 0)
	2134	.S X=$E(R EC,41,47)_ SP_$E(REC, 48,54)_SP_ $E(REC,55, 61)_SP_$E( REC,62,68) _SP_$E(REC ,69,75)_SP _$E(REC,76 ,82)_SP_$E (REC,83,89 )_SP_$E(RE C,90,96)_S P_$E(REC,9 7,103)
	2135	"RTN","DGP TAEE2",79, 0)
	2136	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	2137	"RTN","DGP TAEE2",80, 0)
	2138	I DGPTLIN E=2 D ;ic d10 layout . ft 11/1 9/14
	2139	"RTN","DGP TAEE2",81, 0)
	2140	.S X=$E(R EC,41,48)_ SP_$E(REC, 49,56)_SP_ $E(REC,57, 64)_SP_$E( REC,65,72) _SP_$E(REC ,73,80)
	2141	"RTN","DGP TAEE2",82, 0)
	2142	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	2143	"RTN","DGP TAEE2",83, 0)
	2144	.S X=$E(R EC,81,88)_ SP_$E(REC, 89,96)_SP_ $E(REC,97, 104)_SP_$E (REC,105,1 12)_SP_$E( REC,113,12 0)
	2145	"RTN","DGP TAEE2",84, 0)
	2146	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	2147	"RTN","DGP TAEE2",85, 0)
	2148	.S X=$E(R EC,121,128 )_SP_$E(RE C,129,136) _SP_$E(REC ,137,144)_ SP_$E(REC, 145,152)_S P_$E(REC,1 53,160)
	2149	"RTN","DGP TAEE2",86, 0)
	2150	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	2151	"RTN","DGP TAEE2",87, 0)
	2152	.S X=$E(R EC,161,168 )_SP_$E(RE C,169,176) _SP_$E(REC ,177,184)_ SP_$E(REC, 185,192)_S P_$E(REC,1 93,200)
	2153	"RTN","DGP TAEE2",88, 0)
	2154	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	2155	"RTN","DGP TAEE2",89, 0)
	2156	.S X=$E(R EC,201,208 )_SP_$E(RE C,209,216) _SP_$E(REC ,217,224)_ SP_$E(REC, 225,232)
	2157	"RTN","DGP TAEE2",90, 0)
	2158	.S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X
	2159	"RTN","DGP TAEE2",91, 0)
	2160	D WRER^DG PTAEE
	2161	"RTN","DGP TAEE2",92, 0)
	2162	Q
	2163	"RTN","DGP TAEE2",93, 0)
	2164	;
	2165	"RTN","DGP TF")
	2166	0^16^B2593 6099^B2302 8941
	2167	"RTN","DGP TF",1,0)
	2168	DGPTF ;ALB /JDS,AS - PTF LOAD/E DIT DRIVER ; 05 Feb 2019 9:52 AM
	2169	"RTN","DGP TF",2,0)
	2170	;;5.3;Reg istration; 26,58,16 4,195,397, 565,664,85 0,914;Au g 13, 1993 ;Build 173
	2171	"RTN","DGP TF",3,0)
	2172	;
	2173	"RTN","DGP TF",4,0)
	2174	I '$D(^XT MP("DGPTF" ,$J)) K ^X TMP("DGPTF ")
	2175	"RTN","DGP TF",5,0)
	2176	S ^XTMP(" DGPTF",$J, 0)=""
	2177	"RTN","DGP TF",6,0)
	2178	K ^TMP($J ,"DGPTF")
	2179	"RTN","DGP TF",7,0)
	2180	D LO^DGUT L
	2181	"RTN","DGP TF",8,0)
	2182	I $D(^DIS V(DUZ,"^DP T(")),$D(^ ("^DGPT(") ) S A=+^(" ^DGPT("),B =+^("^DPT( ") I $D(^D GPT(A,0)), $D(^DPT(B, 0)) S:(+^D GPT(A,0)'= B&$D(^DGPT ("B",B))) ^DISV(DUZ, "^DGPT(")= ""
	2183	"RTN","DGP TF",9,0)
	2184	;
	2185	"RTN","DGP TF",10,0)
	2186	ASK W !! K DIC S DIC ="^DGPT(", DIC(0)="EQ MZA",DGPR= 0,DIC("S") ="I '$P(^D GPT(+Y,0), U,6)!($P(^ (0),U,6)=1 ),$P(^(0), U,11)=1"
	2187	"RTN","DGP TF",11,0)
	2188	;DG5.38 61 Added D GRELKEY va riable to hold the v alue for D GREL that is killed in ^EASECU 21
	2189	"RTN","DGP TF",12,0)
	2190	N DGRELKE Y D ^DIC G Q1:Y'>0 S PTF=+Y,(D GRELKEY,DG REL)=$S($D (^XUSEC("D G PTFREL", DUZ)):1,1: 0)
	2191	"RTN","DGP TF",13,0)
	2192	I '$D(^DG PT(PTF,"M" ,0))#2 S ^ (0)="^45.0 2^^"
	2193	"RTN","DGP TF",14,0)
	2194	K DIC S D FN=+Y(0),D GADM=+$P(Y (0),U,2),^ DISV(DUZ," ^DPT(")=DF N,DGST=+$P (Y(0),U,6)
	2195	"RTN","DGP TF",15,0)
	2196	N DGPMCA, DGPMAN D P M^DGPTUTL
	2197	"RTN","DGP TF",16,0)
	2198	D:DGST=0 MT^DGPTUTL ,INCOME^DG PTUTL1
	2199	"RTN","DGP TF",17,0)
	2200	I DGST I 'DGREL!($D (DGQWK))!( DGST>1) W: $X>60 " ???--Alrea dy ",$S(DG ST=1:"Clos ed",DGST=2 :"Released ",1:"Trans mitted") G ASK
	2201	"RTN","DGP TF",18,0)
	2202	;
	2203	"RTN","DGP TF",19,0)
	2204	EN1 ;
	2205	"RTN","DGP TF",20,0)
	2206	K DGPTFE S DGPTFE=$ P(^DGPT(PT F,0),"^",4 )
	2207	"RTN","DGP TF",21,0)
	2208	I 'DGPTFE ,'DGST G U P:$P(DGPMA N,"^",16)' =PTF D:'$P (^DGPT(PTF ,0),"^",5) SUF D LE^ DGPTTS,DC
	2209	"RTN","DGP TF",22,0)
	2210	I $D(DGQW K) D ^DGPT FQWK,Q1 S DGQWK=1 G DGPTF
	2211	"RTN","DGP TF",23,0)
	2212	;
	2213	"RTN","DGP TF",24,0)
	2214	GETD ;
	2215	"RTN","DGP TF",25,0)
	2216	K A
	2217	"RTN","DGP TF",26,0)
	2218	I $P(^DGP T(PTF,0),U ,11)=1 D C EN^DGPTC1
	2219	"RTN","DGP TF",27,0)
	2220	; pwc DG* 5.3*914 RS D SPEC# 2. 6.5.2.1 10 1 Screen C amp Lejeun e added
	2221	"RTN","DGP TF",28,0)
	2222	F I=0,.52 1,.11,.52, .321,.32,. 3217,57,.3 S A(I)="" S:$D(^DPT (DFN,I))&( 'DGST) A(I )=^(I) I D GST S:$D(^ DGP(45.84, PTF,$S('I: 10,1:I))) A(I)=^($S( 'I:10,1:I) )
	2223	"RTN","DGP TF",29,0)
	2224	S A("MST" )=$P($$GET STAT^DGMST API(DFN),U ,2,5)
	2225	"RTN","DGP TF",30,0)
	2226	K DGNTARR N CLV ; pwc DG5.3 914 RSD S PEC# 2.6.5 .2.1 101 S creen Camp Lejeune
	2227	"RTN","DGP TF",31,0)
	2228	S A("NTR" )=$S($$GET CUR^DGNTAP I(DFN,"DGN TARR")>0:D GNTARR("IN TRP"),1:"" )
	2229	"RTN","DGP TF",32,0)
	2230	K DGNTARR
	2231	"RTN","DGP TF",33,0)
	2232	K B F I=0 ,101,70 S B(I)="" S: $D(^DGPT(P TF,I)) B(I )=^(I)
	2233	"RTN","DGP TF",34,0)
	2234	S A("CV") =$$CVEDT^D GCV(DFN,$P ($G(B(0)), U,2))
	2235	"RTN","DGP TF",35,0)
	2236	S A("SHAD ")=$$GETSH AD^DGUTL3( DFN)
	2237	"RTN","DGP TF",36,0)
	2238	; pwc DG* 5.3*914 RS D SPEC# 2. 6.5.2.1 10 1 Screen C amp Lejeun e
	2239	"RTN","DGP TF",37,0)
	2240	; needs t o be chang ed to this code S C LVYN=$$GET CL^DGUTL3( DFN),A("CL V")=$S(CLV YN=1:"Y",C LVYN=0:"N" ,1:"") ; returns 0, 1 or null
	2241	"RTN","DGP TF",38,0)
	2242	S A("CLV" )=$S($$GET CL^DGUTL3( DFN)=1:"Y" ,$$GETCL^D GUTL3(DFN) =0:"N",1:" ")
	2243	"RTN","DGP TF",39,0)
	2244	S CLV=$P( $G(^DGPT(P TF,70)),"^ ",33) ;ge t 'Treated for Camp Lejeune' f rom PTF fi le (#45)
	2245	"RTN","DGP TF",40,0)
	2246	S DGDD=+B (70),DGFC= +$P(B(0),U ,3)
	2247	"RTN","DGP TF",41,0)
	2248	S Y=DGDD D FMT^DGPT UTL
	2249	"RTN","DGP TF",42,0)
	2250	S Y=DGADM D D^DGPTU TL S DGAD= Y,HEAD="Na me: "_$P(A (0),U,1)_" SSN: "_$ P(A(0),U,9 )_" Dt of Adm: "_DGA D
	2251	"RTN","DGP TF",43,0)
	2252	S DGN=$S( DGST!DGPR: 1,1:0)
	2253	"RTN","DGP TF",44,0)
	2254	I DGPR S (DGST,DGPT FE)=1 G FA C^DGPTF1
	2255	"RTN","DGP TF",45,0)
	2256	I DGPTFE, 'DGST K DR S DIE="^D GPT(",DA=P TF,DR="2" D ^DIE K D R G Q:$D(Y ) S DGADM= $P(^DGPT(P TF,0),U,2) ,^DISV(DUZ ,"PTFAD",D FN)=DGADM, Y=DGADM D D^DGPTUTL S HEAD=$P( HEAD,DGAD, 1)_Y
	2257	"RTN","DGP TF",46,0)
	2258	G ^DGPTF1
	2259	"RTN","DGP TF",47,0)
	2260	;
	2261	"RTN","DGP TF",48,0)
	2262	Q I '$P(^D GPT(PTF,0) ,"^",4),'$ P(^(0),U,6 ) W !," U pdating TR ANSFER DRG s" S DGADM =$P(^DGPT( PTF,0),U,2 ) D SUDO1^ DGPTSUDO
	2263	"RTN","DGP TF",49,0)
	2264	D Q1
	2265	"RTN","DGP TF",50,0)
	2266	I $D(DGAD PR)!($D(DG PTOUT)) K DGPTOUT Q
	2267	"RTN","DGP TF",51,0)
	2268	G DGPTF
	2269	"RTN","DGP TF",52,0)
	2270	;
	2271	"RTN","DGP TF",53,0)
	2272	Q1 ; -- ho usekeeping
	2273	"RTN","DGP TF",54,0)
	2274	I $D(IOM) S X=IOM X ^%ZOSF("R M")
	2275	"RTN","DGP TF",55,0)
	2276	D KVAR^DG PTUTL1,KVA R^DGPTC1 K SDCLY
	2277	"RTN","DGP TF",56,0)
	2278	Q
	2279	"RTN","DGP TF",57,0)
	2280	;
	2281	"RTN","DGP TF",58,0)
	2282	SUF I $D(^ DIC(42,+$P (DGPMAN,U, 6),0)) S D GX=$P(^(0) ,U,3) D
	2283	"RTN","DGP TF",59,0)
	2284	.S DGX=$S (DGX="":"" ,DGX="D":" D NUMACT^D GPTSUF(30) ",DGX="NH" :"D NUMACT ^DGPTSUF(4 0)",1:"")
	2285	"RTN","DGP TF",60,0)
	2286	.Q:DGX=""
	2287	"RTN","DGP TF",61,0)
	2288	.X DGX Q: DGANUM'=1
	2289	"RTN","DGP TF",62,0)
	2290	.N DGFDA, DGMSG
	2291	"RTN","DGP TF",63,0)
	2292	.S DGFDA( 45,PTF_"," ,5)=DGSUFN AM(DGANUM)
	2293	"RTN","DGP TF",64,0)
	2294	.D FILE^D IE("","DGF DA","DGMSG ")
	2295	"RTN","DGP TF",65,0)
	2296	K DGANUM, DGSUFNAM,D GX
	2297	"RTN","DGP TF",66,0)
	2298	Q
	2299	"RTN","DGP TF",67,0)
	2300	ORDER ; -- order mvt ; I1 := # mvts+1 ; M () := mvt array
	2301	"RTN","DGP TF",68,0)
	2302	N DGRT S DGRT=$S(I1 <25:"MT",1 :"^UTILITY (""DGPTMT" ",$J)") K @DGRT
	2303	"RTN","DGP TF",69,0)
	2304	N DGRT82 S DGRT82=$ S(I1<25:"M T82",1:"^U TILITY(""D GPTMT82"", $J)") K @D GRT82
	2305	"RTN","DGP TF",70,0)
	2306	F I=0:0 S I=$O(M(I) ) Q:'I D
	2307	"RTN","DGP TF",71,0)
	2308	. S NU=+$ P(M(I),U,1 0),NU=$S(' NU:9999999 +I,1:NU)
	2309	"RTN","DGP TF",72,0)
	2310	. S NU=$S ($D(@DGRT@ (NU)):NU+( I*.1),1:NU ) S @DGRT@ (NU,I)=M(I ),@DGRT82@ (NU,I)=$G( M(I,82))
	2311	"RTN","DGP TF",73,0)
	2312	S K=0 F I =0:0 S I=$ O(@DGRT@(I )) Q:'I D
	2313	"RTN","DGP TF",74,0)
	2314	. S K=K+1 ,J=$O(@DGR T@(I,0)) S M(K)=@DGR T@(I,J),M( K,82)=@DGR T82@(I,J)
	2315	"RTN","DGP TF",75,0)
	2316	K @DGRT Q
	2317	"RTN","DGP TF",76,0)
	2318	;
	2319	"RTN","DGP TF",77,0)
	2320	ADM S DFN= +^DGPT(DA, 0),%=$O(^( "M","AM",0 )) I %<X&( %>0) K X W !,"Not af ter first movement"
	2321	"RTN","DGP TF",78,0)
	2322	Q:'$D(X) I $D(^DGP T("AAD",DF N,X))&($P( ^DGPT(DA,0 ),U,2)'=X) K X W !," There is a lready a P TF entry a t that tim e"
	2323	"RTN","DGP TF",79,0)
	2324	Q
	2325	"RTN","DGP TF",80,0)
	2326	;
	2327	"RTN","DGP TF",81,0)
	2328	WR ;Called from ^DD( 45,0,"ID", "WR")
	2329	"RTN","DGP TF",82,0)
	2330	Q:'$D(^DG PT(+$G(Y), 0)) S DGN ODE=^(0),D GADM=$P(DG NODE,U,2) W " Admit ted: ",$TR ($$FMTE^XL FDT(DGADM, "5DF")," " ,"0")," "
	2331	"RTN","DGP TF",83,0)
	2332	; uses ne w FMTE par ameter for XLFDT, Y2 K in line WR
	2333	"RTN","DGP TF",84,0)
	2334	;
	2335	"RTN","DGP TF",85,0)
	2336	F DGZ=6,4 S %=";"_$ S($D(^DD(4 5,DGZ,0)): $P(^(0),U, 3),1:"") W $P($P(%," ;"_$P(DGNO DE,U,DGZ)_ ":",2),";" ,1)_" "
	2337	"RTN","DGP TF",86,0)
	2338	K DGNODE, DGZ Q
	2339	"RTN","DGP TF",87,0)
	2340	;
	2341	"RTN","DGP TF",88,0)
	2342	DC S DGPDN =$S($D(^DG PM(+$P(DGP MAN,"^",17 ),0)):^(0) ,1:"")
	2343	"RTN","DGP TF",89,0)
	2344	S DGDC=+D GPDN,DG72= $S($D(^DG( 405.2,+$P( DGPDN,"^", 18),0)):$P (^(0),"^", 8),1:0),DG TY=$S(DGDC :1,1:"")
	2345	"RTN","DGP TF",90,0)
	2346	I DGDC F I=0:0 S I= $O(^DGPM(" APMV",DFN, DGPMCA,I)) Q:I'>0 I $D(^DGPM( +$O(^(I,0) ),0)),$P(^ (0),"^",2) =2 S J=U_$ P(^(0),"^" ,18)_U,DGT Y=$S("^43^ 44^13^45^" [J:4,"^1^" [J:2,"^2^3 ^"[J:3,1:1 ) Q
	2347	"RTN","DGP TF",91,0)
	2348	S X=$S($D (^DGPT(PTF ,70)):^(70 ),1:"")
	2349	"RTN","DGP TF",92,0)
	2350	S DR="70/ //"_$S(DGD C:"/"_DGDC ,'X:"",1:" @")_$S(DG7 2:";72//// "_DG72,1:" ")_";72.1/ //"_$S(DGT Y:"/"_DGTY ,'$P(X,"^" ,14):"",1: "@"),DIE=" ^DGPT(",DA =PTF D ^DI E
	2351	"RTN","DGP TF",93,0)
	2352	I DGDC>DT ,$P(DGPDN, "^",18)=42 W:'$D(ZTQ UEUED) !," Discharge 'While ASI H' is in t he future. "
	2353	"RTN","DGP TF",94,0)
	2354	K DG72,DG TY,DGPDN Q
	2355	"RTN","DGP TF",95,0)
	2356	;
	2357	"RTN","DGP TF",96,0)
	2358	UP S DIE=" ^DGPT(",DR ="4///F",D A=PTF D ^D IE W !,"Po inter from Patient f ile is inc orrect. Re cord chang ed to Fee Basis",! S DGPTFE=1 G GETD
	2359	"RTN","DGP TF1")
	2360	0^17^B4316 5446^B3505 1519
	2361	"RTN","DGP TF1",1,0)
	2362	DGPTF1 ;AL B/JDS/PLT - PTF ENTR Y/EDIT ; 2 4 Jan 2019 9:34 AM
	2363	"RTN","DGP TF1",2,0)
	2364	;;5.3;Reg istration; 69,114,1 95,397,342 ,415,565,6 64,884,914 ;Aug 13, 1993;Buil d 173
	2365	"RTN","DGP TF1",3,0)
	2366	;;Per VA Directive 6402, this routine s hould not be modifie d.
	2367	"RTN","DGP TF1",4,0)
	2368	;
	2369	"RTN","DGP TF1",5,0)
	2370	I '$D(IOF ) S IOP="H OME" D ^%Z IS K IOP
	2371	"RTN","DGP TF1",6,0)
	2372	S:'$D(IOS T) IOST="C " S DGVI=" """"",DGVO =DGVI I $D (IOST(0)) S:$D(^%ZIS (2,IOST(0) ,5)) I=^(5 ) S:$L($P( I,U,4)) DG VI=$P(I,U, 4) S:$L($P (I,U,5)) D GVO=$P(I,U ,5) I $L(D GVI_DGVO)> 4 S X=132 X ^%ZOSF(" RM")
	2373	"RTN","DGP TF1",7,0)
	2374	WR G GET:' $D(A)!('$D (B)) W @IO F,HEAD,?72 ,@DGVI,"<1 01>",@DGVO
	2375	"RTN","DGP TF1",8,0)
	2376	FAC ;
	2377	"RTN","DGP TF1",9,0)
	2378	W ! I $D( DGCST) S:$ G(DGCN) X= $G(^DG(45. 86,DGCN,0) ) W ?37,"C ensus " W: $G(DGCN) " Date: ",$E (X,4,5),"/ ",$E(X,6,7 ),"/",$E(X ,2,3)," " W "Status : ",$$EXTE RNAL^DILFD (45,6,,+DG CST)
	2379	"RTN","DGP TF1",10,0)
	2380	W ! S Z=1 D Z W " Facility: " S Z=$P( B(0),U,3)_ $P(B(0),U, 5),Z1=23 D Z1
	2381	"RTN","DGP TF1",11,0)
	2382	MAR S Z=2 D Z W " Ma rit Stat: ",$S($D(^D IC(11,+$P( A(0),U,5), 0)):$P(^(0 ),U,1),1:" ")
	2383	"RTN","DGP TF1",12,0)
	2384	SA W !," S ource of A dm: ",$S($ D(^DIC(45. 1,+B(101), 0)):$P(^(0 ),U,5),1:" ")
	2385	"RTN","DGP TF1",13,0)
	2386	N VADM D DEM^VADPT
	2387	"RTN","DGP TF1",14,0)
	2388	W ?39,"Et hnic: " D
	2389	"RTN","DGP TF1",15,0)
	2390	.I 'VADM( 11) W "" Q
	2391	"RTN","DGP TF1",16,0)
	2392	.N NODE,N UM,ETHNIC, I
	2393	"RTN","DGP TF1",17,0)
	2394	.S I=0
	2395	"RTN","DGP TF1",18,0)
	2396	.F NUM=0: 1 S I=+$O( VADM(11,I) ) Q:'I D
	2397	"RTN","DGP TF1",19,0)
	2398	..S X=$$P TR2CODE^DG UTL4(+VADM (11,I),2,4 )
	2399	"RTN","DGP TF1",20,0)
	2400	..S ETHNI C=$S(X="": "?",1:X)
	2401	"RTN","DGP TF1",21,0)
	2402	..S X=$$P TR2CODE^DG UTL4(+$G(V ADM(11,I,1 )),3,4)
	2403	"RTN","DGP TF1",22,0)
	2404	..S ETHNI C=ETHNIC_$ S(X="":"?" ,1:X)
	2405	"RTN","DGP TF1",23,0)
	2406	..I NUM S ETHNIC=", "_ETHNIC
	2407	"RTN","DGP TF1",24,0)
	2408	..W ETHNI C
	2409	"RTN","DGP TF1",25,0)
	2410	W ?55,"Ra ce: " D
	2411	"RTN","DGP TF1",26,0)
	2412	.I 'VADM( 12) W "" Q
	2413	"RTN","DGP TF1",27,0)
	2414	.N NODE,N UM,RACE,I
	2415	"RTN","DGP TF1",28,0)
	2416	.S I=0
	2417	"RTN","DGP TF1",29,0)
	2418	.F NUM=0: 1 S I=+$O( VADM(12,I) ) Q:'I D
	2419	"RTN","DGP TF1",30,0)
	2420	..S X=$$P TR2CODE^DG UTL4(+VADM (12,I),1,4 )
	2421	"RTN","DGP TF1",31,0)
	2422	..S RACE= $S(X="":"? ",1:X)
	2423	"RTN","DGP TF1",32,0)
	2424	..S X=$$P TR2CODE^DG UTL4(+$G(V ADM(12,I,1 )),3,4)
	2425	"RTN","DGP TF1",33,0)
	2426	..S RACE= RACE_$S(X= "":"?",1:X )
	2427	"RTN","DGP TF1",34,0)
	2428	..I NUM S RACE=","_ RACE
	2429	"RTN","DGP TF1",35,0)
	2430	..W RACE
	2431	"RTN","DGP TF1",36,0)
	2432	K VADM
	2433	"RTN","DGP TF1",37,0)
	2434	W !," Sou rce of Pay : ",$$EXTE RNAL^DILFD (45,22,,$P (B(101),U, 3))
	2435	"RTN","DGP TF1",38,0)
	2436	SEX S SEX= $P(A(0),U, 2) W ?39," Sex: ",$S (SEX="M":" MALE",SEX= "F":"FEMAL E",1:"")
	2437	"RTN","DGP TF1",39,0)
	2438	W !,"Tran s Facility : ",$P(B(1 01),U,5)_$ P(B(101),U ,6)
	2439	"RTN","DGP TF1",40,0)
	2440	DOB S DOB= $P(A(0),U, 3),Y=DOB D D^DGPTUTL W ?39," D ate of Bir th: ",Y
	2441	"RTN","DGP TF1",41,0)
	2442	CAT I DGPT FMT<2 W !, " Cat o f Ben: ",$ S($D(^DIC( 45.82,+$P( B(101),U,4 ),0)):$E($ P(^(0),U,2 ),1,26),1: "")
	2443	"RTN","DGP TF1",42,0)
	2444	W:$X>50 !
	2445	"RTN","DGP TF1",43,0)
	2446	W " Ad mit Elig: "_$S(+$P(B (101),U,8) :$P($G(^DI C(8,+$P(B( 101),U,8), 0)),U),1:" UNKNOWN") W ?50,"SCI : ",$$EXTE RNAL^DILFD (2,57.4,,$ P(A(57),U, 4))
	2447	"RTN","DGP TF1",44,0)
	2448	VIET W ! S Z=3 D Z W "Vietnam SRV: " S L =$P(A(.321 ),U,1),Z=$ S(L="Y":"Y ES",L="N": "NO",1:"UN KNOWN"),Z1 =27 D Z1
	2449	"RTN","DGP TF1",45,0)
	2450	ST S Z=4 D Z W $S('$ $FORIEN^DG ADDUTL($P( A(.11),U,1 0))!('$P(A (.11),U,10 )):" Stat e: "_$S($D (^DIC(5,+$ P(A(.11),U ,5),0)):$P (^(0),U,1) ,1:""),1:" Country: " _$$CNTRYI^ DGADDUTL($ P(A(.11),U ,10)))
	2451	"RTN","DGP TF1",46,0)
	2452	POW W !?11 ,"POW: " S L=$P(A(.5 2),U,5) W $S(L="Y":" YES",L="N" :"NO",1:"U NKNOWN")
	2453	"RTN","DGP TF1",47,0)
	2454	ZIP W ?42, $S('$$FORI EN^DGADDUT L($P(A(.11 ),U,10))!( '$P(A(.11) ,U,10)):" Zip Code : "_$P(A(. 11),U,6),1 :"Postal C ode: "_$P( A(.11),U,9 ))
	2455	"RTN","DGP TF1",48,0)
	2456	POS W !,?6 ," POW SRV : " S L=$P (A(.52),U, 6) W $E($S ($D(^DIC(2 2,+L,0)):$ P(^(0),U,1 ),1:""),1, 23)
	2457	"RTN","DGP TF1",49,0)
	2458	COU W ?45, $S('$$FORI EN^DGADDUT L($P(A(.11 ),U,10))!( '$P(A(.11) ,U,10)):" County: " _$S($D(^DI C(5,+$P(A( .11),U,5), 1,+$P(A(.1 1),U,7),0) ):$P(^(0), U,1),1:"") ,1:"Provin ce: "_$P(A (.11),U,8) )
	2459	"RTN","DGP TF1",50,0)
	2460	ION W !," Ion Rad Exp: " S L =$P(A(.321 ),U,3) W $ S(L="Y":"Y ES",L="N": "NO",1:"UN KNOWN")
	2461	"RTN","DGP TF1",51,0)
	2462	METH S L=$ P(A(.321), U,12) W:L' ="" ?38,"E xposure Me thod: ",$S (L="N":"Na gasaki/Hir oshima",L= "T":"Nucle ar Testing ",L="B":"B oth",1:"")
	2463	"RTN","DGP TF1",52,0)
	2464	AO W !," AO Exp/L oc: " S L= $P(A(.321) ,U,2) W $S (L="Y":"YE S",L="N":" NO",1:"UNK NOWN")
	2465	"RTN","DGP TF1",53,0)
	2466	S L=$P(A( .321),U,13 ) W:L'="" $S(L="V":" /VIET",L=" K":"/DMZ", L="O":"/OT HER",1:"")
	2467	"RTN","DGP TF1",54,0)
	2468	SHAD W ?40 ,"PROJ 112 /SHAD: ",$ S(A("SHAD" )=1:"YES", 1:"NO")
	2469	"RTN","DGP TF1",55,0)
	2470	MST W !," Claims MST: " S L =$P(A("MST "),U) W $S (L="Y":"YE S",L="N":" NO",L="D": "DECLINED TO ANSWER" ,1:"UNKNOW N") ; adde d 6/17/98 for MST en hancement
	2471	"RTN","DGP TF1",56,0)
	2472	NTR W ?39, " N/T R adium: " S L=A("NTR" ) W $E($S( L'="":L,1: "UNKNOWN") ,1,25)
	2473	"RTN","DGP TF1",57,0)
	2474	CV S L=$S( $P(A("CV") ,U,1)>0:1, 1:0)
	2475	"RTN","DGP TF1",58,0)
	2476	W !,"Comb at Veteran : ",$S(L:" YES",1:"NO ")
	2477	"RTN","DGP TF1",59,0)
	2478	I L S Y=$ P(A("CV"), U,2) D D^D GPTUTL W ? 45,"End Da te: ",Y
	2479	"RTN","DGP TF1",60,0)
	2480	CLV ; pwc DG5.3914 RSD SPEC# 2.6.6.2.1 101 Scree n Camp Lej eune
	2481	"RTN","DGP TF1",61,0)
	2482	; Camp Le jeune will display f rom file # 405, but w hen edited , it will file back both in PT F file #45 and PATIE NT MOVEMEN T file #40 5
	2483	"RTN","DGP TF1",62,0)
	2484	S CLV="" I $G(DGPMC A)'="" S C LV=$P($G(^ DGPM(DGPMC A,0)),"^", 29) ; CLV variable is from PA TIENT MOVE MENT file #405 (rece ived from admission)
	2485	"RTN","DGP TF1",63,0)
	2486	S DGPTF1= $D(^DGPM(" APTF",PTF) )
	2487	"RTN","DGP TF1",64,0)
	2488	W:$P($G(^ DGPT(PTF,7 0)),U,33)' ="" ?38," Camp Lej eune: "_$S ($P($G(^DG PT(PTF,70) ),U,33)="Y ":"YES",1: "NO")
	2489	"RTN","DGP TF1",65,0)
	2490	W:$P($G(^ DGPT(PTF,7 0)),U,33)= "" ?38," Camp Leje une: "_$S( CLV="Y":"Y ES",1:"NO" )
	2491	"RTN","DGP TF1",66,0)
	2492	;
	2493	"RTN","DGP TF1",67,0)
	2494	D EN^DGPT F4 K A,B Q :DGPR
	2495	"RTN","DGP TF1",68,0)
	2496	;
	2497	"RTN","DGP TF1",69,0)
	2498	JUMP F I=$ Y:1:20 W !
	2499	"RTN","DGP TF1",70,0)
	2500	G 101^DGP TFJC:DGN S (DGZM0,DG ZS0)=0
	2501	"RTN","DGP TF1",71,0)
	2502	R "Enter: <RET> fo r <MAS>,", !,"1-7 to edit,'^N' for screen N, or '^' to abort: <MAS>// " ,X:DTIME S :'$T X="^" ,DGPTOUT=" "
	2503	"RTN","DGP TF1",72,0)
	2504	G ^DGPTFM :X="",Q:X= "^"
	2505	"RTN","DGP TF1",73,0)
	2506	I X?1"^". E S DGPTSC RN=101 G ^ DGPTFJ
	2507	"RTN","DGP TF1",74,0)
	2508	G PR:X?.N &($L(X)>2)
	2509	"RTN","DGP TF1",75,0)
	2510	I X["-" S K=X,X="" F I=1:1 S J=$P(K,"," ,I) Q:J']" " I +J<8 S:J'["-" X =X_J_"," I J["-"&(+J ) I +J<+$P (J,"-",2) F L=+J:1:+ $P(J,"-",2 ) S:L<8 X= X_L_","
	2511	"RTN","DGP TF1",76,0)
	2512	I X'[",", 1234567'[X G PR
	2513	"RTN","DGP TF1",77,0)
	2514	F I=1:1 S J=$P(X,", ",I) Q:'J G:J<1!(J> 7)!(J'?1N) PR
	2515	"RTN","DGP TF1",78,0)
	2516	I X<1!(X> 7) G PR
	2517	"RTN","DGP TF1",79,0)
	2518	S (PT(1), PT(2))="", DGJUMP=X,D A=PTF,DIE= "^DGPT(",D R="[DG101" _$E("F",DG PTFE)_"]" D ^DIE
	2519	"RTN","DGP TF1",80,0)
	2520	;--
	2521	"RTN","DGP TF1",81,0)
	2522	N DGPMCA, DGPMAN D P M^DGPTUTL
	2523	"RTN","DGP TF1",82,0)
	2524	I '$G(DGA DM) S DGAD M=+^DGPT(P TF,0)
	2525	"RTN","DGP TF1",83,0)
	2526	D MT^DGPT UTL
	2527	"RTN","DGP TF1",84,0)
	2528	; pwc DG* 5.3*914 RS D SPEC# 2. 6.6.2.1 10 1 Screen C amp Lejeun e
	2529	"RTN","DGP TF1",85,0)
	2530	GET F I=.3 2,.52,57,. 521,0,.321 ,.3217,.11 ,.3 S A(I) ="" S:$D(^ DPT(DFN,I) )&('DGST) A(I)=^(I) I DGN S:$D (^DGP(45.8 4,PTF,$S(' I:10,1:I)) ) A(I)=^($ S('I:10,1: I))
	2531	"RTN","DGP TF1",86,0)
	2532	; The fol lowing lin e added fo r MST enha ncement 4/ 21/99
	2533	"RTN","DGP TF1",87,0)
	2534	S A("MST" )=$P($$GET STAT^DGMST API(DFN),U ,2,5)
	2535	"RTN","DGP TF1",88,0)
	2536	K DGNTARR N CLV ; pwc DG5.3 914 RSD S PEC# 2.6.5 .2.1 101 S creen Camp Lejeune
	2537	"RTN","DGP TF1",89,0)
	2538	S A("NTR" )=$S($$GET CUR^DGNTAP I(DFN,"DGN TARR")>0:D GNTARR("IN TRP"),1:"" )
	2539	"RTN","DGP TF1",90,0)
	2540	K DGNTARR
	2541	"RTN","DGP TF1",91,0)
	2542	F I=0,101 ,70 S B(I) ="" S:$D(^ DGPT(PTF,I )) B(I)=^( I)
	2543	"RTN","DGP TF1",92,0)
	2544	S DGDD=+B (70),DGFC= +$P(B(0),U ,3)
	2545	"RTN","DGP TF1",93,0)
	2546	S A("CV") =$$CVEDT^D GCV(DFN,$P ($G(B(0)), U,2))
	2547	"RTN","DGP TF1",94,0)
	2548	S A("SHAD ")=$$GETSH AD^DGUTL3( DFN)
	2549	"RTN","DGP TF1",95,0)
	2550	; pwc DG* 5.3*914 RS D SPEC# 2. 6.6.2.1 10 1 Screen C amp Lejeun e
	2551	"RTN","DGP TF1",96,0)
	2552	S A("CLV" )=$S($$GET CL^DGUTL3( DFN)=1:"Y" ,$$GETCL^D GUTL3(DFN) =0:"N",1:" ") ;gets from PATIE NT file fo r setting Array
	2553	"RTN","DGP TF1",97,0)
	2554	I $G(DGPM CA)'="" S CLV=$P($G( ^DGPM(DGPM CA,0)),"^" ,29) ;get 'Treated for Camp L ejeune' fr om PATIENT MOVEMENT file (#405 ) to displ ay on 101 screen
	2555	"RTN","DGP TF1",98,0)
	2556	K PT G DG PTF1
	2557	"RTN","DGP TF1",99,0)
	2558	PR W !,"En ter '^' to stop the display an d edit of data",!,"' ^N' to jum p to scree n #N (scre en # appea rs in uppe r right of screen '< N>')",!,"< RET> to co ntinue on to the nex t screen o r 1-7 to e dit:"
	2559	"RTN","DGP TF1",100,0 )
	2560	W !?10,"1 -Facility, Source of admis, Pa yment, Tra nsf facil, and Cat. of Benef", !?10,"2-Ma rital Stat , Race, Et hnicity, S ex, SCI, D OB"
	2561	"RTN","DGP TF1",101,0 )
	2562	W !?10,"3 -Agent Ora nge, Priso ner of War , Ionizing Radiation , MST, N/T Radium",! ?12,"Camp Lejeune"
	2563	"RTN","DGP TF1",102,0 )
	2564	W !?10,"4 -State, Co unty, Zip code"
	2565	"RTN","DGP TF1",103,0 )
	2566	W !?10,"5 -Discharge date, typ e & specia lty",!?10, "6-Outpati ent treat & VA Auspi ces",!?10, "7-Receivi ng Facilit y, ASIH Da ys & C&P S tatus"
	2567	"RTN","DGP TF1",104,0 )
	2568	W !,"You may also e nter any c ombination of the ab ove, separ ated by co mmas(ex:1, 3,5)",!
	2569	"RTN","DGP TF1",105,0 )
	2570	R !!,"Ent er <RET> : ",X:DTIME G WR
	2571	"RTN","DGP TF1",106,0 )
	2572	Q G Q^DGPT F
	2573	"RTN","DGP TF1",107,0 )
	2574	Q
	2575	"RTN","DGP TF1",108,0 )
	2576	Z I 'DGN S Z=$S(IOST ="C-QUME"& ($L(DGVI)' =2):Z,1:"[ "_Z_"]") W @DGVI,Z,@ DGVO
	2577	"RTN","DGP TF1",109,0 )
	2578	E W " "
	2579	"RTN","DGP TF1",110,0 )
	2580	Q
	2581	"RTN","DGP TF1",111,0 )
	2582	Z1 F I=1:1 :(Z1-$L(Z) ) S Z=Z_" "
	2583	"RTN","DGP TF1",112,0 )
	2584	W Z
	2585	"RTN","DGP TF1",113,0 )
	2586	Q
	2587	"RTN","DGP TFCLV")
	2588	0^71^B1210 1778^n/a
	2589	"RTN","DGP TFCLV",1,0 )
	2590	DGPTFCLV ; ALB/CLT - PTF CAMP L EJEUNE QUE STION;12/1 3/2017 ; 3 0 Jan 2019 2:50 PM
	2591	"RTN","DGP TFCLV",2,0 )
	2592	;;5.3;Reg istration; 914;Au g 13, 1993 ;Build 173
	2593	"RTN","DGP TFCLV",3,0 )
	2594	;
	2595	"RTN","DGP TFCLV",4,0 )
	2596	; THIS RO UTINE IS C ALLED FROM THE INPUT TEMPLATES DG101 and DG101F
	2597	"RTN","DGP TFCLV",5,0 )
	2598	PTF101 ;SE T THE CAMP LEJEUNE F IELDS IN P TF
	2599	"RTN","DGP TFCLV",6,0 )
	2600	Q:$$GETCL ^DGUTL3(DF N)'=1
	2601	"RTN","DGP TFCLV",7,0 )
	2602	N DGPTF,D GMV,DIR,DG B,X,Y
	2603	"RTN","DGP TFCLV",8,0 )
	2604	S DGPTF=P TF,DGMV=DA S:DGMV=0 DGMV=1
	2605	"RTN","DGP TFCLV",9,0 )
	2606	S DGMV=$O (^DGPM("AP TF",DGPTF, ""))
	2607	"RTN","DGP TFCLV",10, 0)
	2608	S DIR(0)= "Y",DIR("A ")="CAMP L EJEUNE EXP OSURE INDI CATED"
	2609	"RTN","DGP TFCLV",11, 0)
	2610	S DGB=$P( $G(^DGPT(D GPTF,70)), U,33) D
	2611	"RTN","DGP TFCLV",12, 0)
	2612	. I $G(DG B)'="" S D IR("B")=$S (DGB="Y":" YES",1:"NO ") Q
	2613	"RTN","DGP TFCLV",13, 0)
	2614	. I $G(DG B)="" S DI R("B")=$S( $P($G(^DGP M(DGMV,0)) ,"^",29)=" Y":"YES",1 :"NO")
	2615	"RTN","DGP TFCLV",14, 0)
	2616	. I $G(DG B)="" S $P (^DGPT(DGP TF,70),U,3 3)=$S($P(^ DGPM(DGMV, 0),U,29)=" Y":"Y",1:" N")
	2617	"RTN","DGP TFCLV",15, 0)
	2618	S DIR("?" ,1)="Was t reatment r elated to Camp Lejeu ne?"
	2619	"RTN","DGP TFCLV",16, 0)
	2620	S DIR("?" ,2)="Choos e from:"
	2621	"RTN","DGP TFCLV",17, 0)
	2622	S DIR("?" ,3)=" Y YE S"
	2623	"RTN","DGP TFCLV",18, 0)
	2624	S DIR("?" )=" N NO"
	2625	"RTN","DGP TFCLV",19, 0)
	2626	S DIR("?? ")="^D TWO Q^DGPTFCLV "
	2627	"RTN","DGP TFCLV",20, 0)
	2628	D ^DIR
	2629	"RTN","DGP TFCLV",21, 0)
	2630	I X="^" K DIR Q
	2631	"RTN","DGP TFCLV",22, 0)
	2632	I $G(Y)=1 S $P(^DGP T(DGPTF,70 ),U,33)="Y "
	2633	"RTN","DGP TFCLV",23, 0)
	2634	I $G(Y)'= 1 S $P(^DG PT(DGPTF,7 0),U,33)=" N"
	2635	"RTN","DGP TFCLV",24, 0)
	2636	K DIR
	2637	"RTN","DGP TFCLV",25, 0)
	2638	Q
	2639	"RTN","DGP TFCLV",26, 0)
	2640	PTF101F ;F EE BASIS C AMP LEJEUN E ENTRY
	2641	"RTN","DGP TFCLV",27, 0)
	2642	N DGPTF,D IR,DGB,X,Y K DIR
	2643	"RTN","DGP TFCLV",28, 0)
	2644	S DGPTF=P TF
	2645	"RTN","DGP TFCLV",29, 0)
	2646	S DIR(0)= "Y",DIR("A ")="CAMP L EJEUNE EXP OSURE INDI CATED"
	2647	"RTN","DGP TFCLV",30, 0)
	2648	S DGB=$P( $G(^DGPT(D GPTF,70)), U,33) D
	2649	"RTN","DGP TFCLV",31, 0)
	2650	. I $G(DG B)'="" S D IR("B")=$S (DGB="Y":" YES",1:"NO ") Q
	2651	"RTN","DGP TFCLV",32, 0)
	2652	. I $G(DG B)="" S DI R("B")="NO "
	2653	"RTN","DGP TFCLV",33, 0)
	2654	S DIR("?" ,1)="Was t reatment r elated to Camp Lejeu ne?"
	2655	"RTN","DGP TFCLV",34, 0)
	2656	S DIR("?" ,2)="Choos e from:"
	2657	"RTN","DGP TFCLV",35, 0)
	2658	S DIR("?" ,3)=" Y YE S"
	2659	"RTN","DGP TFCLV",36, 0)
	2660	S DIR("?" )=" N NO"
	2661	"RTN","DGP TFCLV",37, 0)
	2662	S DIR("?? ")="^D TWO Q^DGPTFCLV "
	2663	"RTN","DGP TFCLV",38, 0)
	2664	D ^DIR
	2665	"RTN","DGP TFCLV",39, 0)
	2666	I X="^" K DIR Q
	2667	"RTN","DGP TFCLV",40, 0)
	2668	I $G(Y)=1 S $P(^DGP T(DGPTF,70 ),U,33)="Y "
	2669	"RTN","DGP TFCLV",41, 0)
	2670	I $G(Y)'= 1 S $P(^DG PT(DGPTF,7 0),U,33)=" N"
	2671	"RTN","DGP TFCLV",42, 0)
	2672	K DIR
	2673	"RTN","DGP TFCLV",43, 0)
	2674	Q
	2675	"RTN","DGP TFCLV",44, 0)
	2676	TWOQ ;TWO QUESTION M ARKS HELP TEXT
	2677	"RTN","DGP TFCLV",45, 0)
	2678	W !!?3,"I f the pati ent's diag nosis is f or one or more of th e 15 Camp Lejeune"
	2679	"RTN","DGP TFCLV",46, 0)
	2680	W !?3,"co nditions o r any seco ndary cond ition rela ted to one of these 15 Camp"
	2681	"RTN","DGP TFCLV",47, 0)
	2682	W !?3,"Le jeune cond itions, en ter 'YES' or 'Y'. O therwise a nswer 'NO' or 'N'."
	2683	"RTN","DGP TFCLV",48, 0)
	2684	W !!?9,"1 .Esophagea l cancer 9. Renal toxi city"
	2685	"RTN","DGP TFCLV",49, 0)
	2686	W !?9,"2. Lung cance r 10.H epatic ste atosis"
	2687	"RTN","DGP TFCLV",50, 0)
	2688	W !?9,"3. Breast can cer 11.F emale infe rtility"
	2689	"RTN","DGP TFCLV",51, 0)
	2690	W !?9,"4. Bladder ca ncer 12.M iscarriage "
	2691	"RTN","DGP TFCLV",52, 0)
	2692	W !?9,"5. Kidney can cer 13.S cleroderma "
	2693	"RTN","DGP TFCLV",53, 0)
	2694	W !?9,"6. Leukemia 14.N eurobehavi oral effec ts"
	2695	"RTN","DGP TFCLV",54, 0)
	2696	W !?9,"7. Multiple m yeloma 15.N on-Hodgkin 's lymphom a"
	2697	"RTN","DGP TFCLV",55, 0)
	2698	W !?9,"8. Myelodyspl astic synd romes"
	2699	"RTN","DGP TFCLV",56, 0)
	2700	W !!,"Cho ose from:" ,!?3,"Y YES"
	2701	"RTN","DGP TFCLV",57, 0)
	2702	W !?3,"N NO "
	2703	"RTN","DGP TFCLV",58, 0)
	2704	Q
	2705	"RTN","DGP TFCLV",59, 0)
	2706	;
	2707	"RTN","DGP TFCLV",60, 0)
	2708	EN1(DGDA,D GDA1) ;CAL LED FROM T EMPLATE DG 501-10D
	2709	"RTN","DGP TFCLV",61, 0)
	2710	N DGJUMP, DGMOV,DA,D IE,X,Y,DR, DGM,DW,DV, DU,DP,DIFL D,DL,DLB,D IEL,DGADD, DGLAST,DGP MV S DGM=" """_",M,"_ """"
	2711	"RTN","DGP TFCLV",62, 0)
	2712	N DGCLV S DGCLV=""
	2713	"RTN","DGP TFCLV",63, 0)
	2714	K DGEXQ S DA(1)=DGD A1,DA=DGDA D CHQUES^ DGPTSPQ
	2715	"RTN","DGP TFCLV",64, 0)
	2716	I DGDA=1 D
	2717	"RTN","DGP TFCLV",65, 0)
	2718	.S DGLAST =$P(^DGPT( DGDA1,"M", 0),U,3)
	2719	"RTN","DGP TFCLV",66, 0)
	2720	.S:$P(^DG PT(DGDA1," M",1,0),U, 33)="" $P( ^DGPT(DGDA 1,"M",1,0) ,U,33)=$P( ^DGPT(DGDA 1,"M",DGLA ST,0),U,33 )
	2721	"RTN","DGP TFCLV",67, 0)
	2722	I DGDA=1 G EN1Q
	2723	"RTN","DGP TFCLV",68, 0)
	2724	I DGDA=2 D
	2725	"RTN","DGP TFCLV",69, 0)
	2726	.I $P(^DG PT(DGDA1," M",DGDA,0) ,U,33)="" D
	2727	"RTN","DGP TFCLV",70, 0)
	2728	..S DGPMV =$O(^DGPM( "APTF",DGD A1,"")),DG CLV=$P(^DG PM(DGPMV,0 ),U,29)
	2729	"RTN","DGP TFCLV",71, 0)
	2730	..Q
	2731	"RTN","DGP TFCLV",72, 0)
	2732	.Q
	2733	"RTN","DGP TFCLV",73, 0)
	2734	I DGDA'=2 ,$P(^DGPT( DGDA1,"M", DGDA,0),U, 33)'="" N DGCLV S DG CLV=$P(^DG PT(DGDA1," M",DGDA,0) ,U,33)
	2735	"RTN","DGP TFCLV",74, 0)
	2736	S:$G(DGCL V)'="" $P( ^DGPT(DGDA 1,"M",DGDA ,0),U,33)= DGCLV
	2737	"RTN","DGP TFCLV",75, 0)
	2738
	2739	"RTN","DGP TFCLV",76, 0)
	2740	EN1Q ;EXIT
	2741	"RTN","DGP TFCLV",77, 0)
	2742	Q
	2743	"RTN","DGP TFFB")
	2744	0^70^B8592 145^B83580 52
	2745	"RTN","DGP TFFB",1,0)
	2746	DGPTFFB ;A LB/JDS - F EE BASIS P TF ; 15 De c 2017 7: 24 AM
	2747	"RTN","DGP TFFB",2,0)
	2748	;;5.3;Reg istration; 914;Au g 13, 1993 ;Build 173
	2749	"RTN","DGP TFFB",3,0)
	2750	;
	2751	"RTN","DGP TFFB",4,0)
	2752	EN D LO^DG UTL F DGDU MB=0:0 K D GPTOUT D S EL Q:$D(DG PTOUT)
	2753	"RTN","DGP TFFB",5,0)
	2754	K DIPGM,D ISYS,DN,DG PTOUT,DGDU MB Q
	2755	"RTN","DGP TFFB",6,0)
	2756	;
	2757	"RTN","DGP TFFB",7,0)
	2758	SEL ; -- a sk for pt
	2759	"RTN","DGP TFFB",8,0)
	2760	W ! K DIC
	2761	"RTN","DGP TFFB",9,0)
	2762	S DIC(0)= "AEQMZ",DI C("A")="En ter Non-VA PTF Patie nt: ",DIC= "^DPT("
	2763	"RTN","DGP TFFB",10,0 )
	2764	D ^DIC K DIC I Y'>0 S DGPTOUT ="" G SELQ
	2765	"RTN","DGP TFFB",11,0 )
	2766	S (DA,DFN )=+Y D INF O
	2767	"RTN","DGP TFFB",12,0 )
	2768	;
	2769	"RTN","DGP TFFB",13,0 )
	2770	AD ; -- as k for adm date
	2771	"RTN","DGP TFFB",14,0 )
	2772	R !!,"Ent er NEW Non -VA PTF Ad mission Da te: ",X:DT IME G SELQ :(U[X)!('$ T) S %DT=" XETP" D ^% DT G AD:Y< 2000000 S DGADM=+Y D CHK G AD: 'Y
	2773	"RTN","DGP TFFB",15,0 )
	2774	;
	2775	"RTN","DGP TFFB",16,0 )
	2776	; -- crea te new PTF rec
	2777	"RTN","DGP TFFB",17,0 )
	2778	S Y=1 D R TY^DGPTUTL S Y=DGADM _"^1" D CR EATE^DGPTF CR S PTF=+ Y
	2779	"RTN","DGP TFFB",18,0 )
	2780	;CLT, ADD DEFAULT A NSWER OF " NO" TO SCR EEN 101 FE E BASIS AD MISSION ;D G5.3914
	2781	"RTN","DGP TFFB",19,0 )
	2782	S $P(^DGP T(PTF,70), U,33)="N"
	2783	"RTN","DGP TFFB",20,0 )
	2784	;
	2785	"RTN","DGP TFFB",21,0 )
	2786	; -- go t o load edi t
	2787	"RTN","DGP TFFB",22,0 )
	2788	S DGREL=$ S($D(^XUSE C("DG PTFR EL",DUZ)): 1,1:0),DGA DPR=999999 9,DGPR=0,D GST=0,DGPT FE=1 K DGD FN
	2789	"RTN","DGP TFFB",23,0 )
	2790	D INCOME^ DGPTUTL1,G ETD^DGPTF
	2791	"RTN","DGP TFFB",24,0 )
	2792	;
	2793	"RTN","DGP TFFB",25,0 )
	2794	SELQ K DGA DM,DGPTF,P OP,D0,C,DN ,PTF,DFN,D GREL,DA,DG ADPR,DGDD, DGDFN,DIC, DIE,DIK,DR ,I,L,X,Y,D GRTY,DGRTY 0
	2795	"RTN","DGP TFFB",26,0 )
	2796	Q
	2797	"RTN","DGP TFFB",27,0 )
	2798	;
	2799	"RTN","DGP TFFB",28,0 )
	2800	INFO ; -- brief PTF rec profil e for DFN pt
	2801	"RTN","DGP TFFB",29,0 )
	2802	; -- is t emplate co mpiled?
	2803	"RTN","DGP TFFB",30,0 )
	2804	S X="DGPT XB" X ^%ZO SF("TEST") K DXS G I NFOQ:'$T
	2805	"RTN","DGP TFFB",31,0 )
	2806	S IOP="HO ME" D ^%ZI S K IOP D PID^VADPT6
	2807	"RTN","DGP TFFB",32,0 )
	2808	W @IOF,?5 ,"** P TF Record Profile fo r ",$E($P( Y(0),U),1, 25)," (", VA("PID"), ") **"
	2809	"RTN","DGP TFFB",33,0 )
	2810	D HEAD^DG PTXB K DGP TX S DGPTC NT=0,DGPTM AX=$S($D(D GPTMAX):+D GPTMAX,1:1 5)
	2811	"RTN","DGP TFFB",34,0 )
	2812	; -- sort in invers e date ord er
	2813	"RTN","DGP TFFB",35,0 )
	2814	F I=0:0 S I=$O(^DGP T("B",DFN, I)) Q:'I I $D(^DGPT (I,0)) S D GPTX(99999 99.999999- $P(^(0),"^ ",2),I)=""
	2815	"RTN","DGP TFFB",36,0 )
	2816	; -- disp lay data
	2817	"RTN","DGP TFFB",37,0 )
	2818	I $D(DGPT X) F DGPTX =0:0 S DGP TX=$O(DGPT X(DGPTX)) Q:'DGPTX S DGPTCNT= DGPTCNT+1 Q:DGPTCNT> DGPTMAX F PTF=0:0 S PTF=$O(DG PTX(DGPTX, PTF)) Q:'P TF S D0=P TF K DXS D ^DGPTXB W !
	2819	"RTN","DGP TFFB",38,0 )
	2820	I DGPTCNT >DGPTMAX W !?5,"...o nly last " ,DGPTMAX," records a re display ed."
	2821	"RTN","DGP TFFB",39,0 )
	2822	I '$D(DGP TX) W !?5, " No PTF r ecords on file for p atient."
	2823	"RTN","DGP TFFB",40,0 )
	2824	INFOQ K DX S,DGPTCNT, DGPTX,VA,D 0,PTF,DGPT MAX
	2825	"RTN","DGP TFFB",41,0 )
	2826	Q
	2827	"RTN","DGP TFFB",42,0 )
	2828	;
	2829	"RTN","DGP TFFB",43,0 )
	2830	CHK ; -- c heck if ad m on date already ex ists
	2831	"RTN","DGP TFFB",44,0 )
	2832	K Y
	2833	"RTN","DGP TFFB",45,0 )
	2834	F I=0:0 S I=$O(^DGP T("B",DFN, I)) Q:'I I $D(^DGPT (I,0)),$P( DGADM,".") =$P($P(^(0 ),U,2),"." ) S Y=$P(^ (0),U,2) Q
	2835	"RTN","DGP TFFB",46,0 )
	2836	I '$D(Y) S Y=1 G CH KQ
	2837	"RTN","DGP TFFB",47,0 )
	2838	X ^DD("DD ") W !!,*7 ,"PTF #",I ," already exist for that admi ssion date (",Y,")." ,!
	2839	"RTN","DGP TFFB",48,0 )
	2840	S DIR(0)= "Y",DIR("A ")="Do you still wan t to creat e a new PT F"
	2841	"RTN","DGP TFFB",49,0 )
	2842	S DIR("?" ,1)="Answe r 'Yes' to add a new PTF recor d"
	2843	"RTN","DGP TFFB",50,0 )
	2844	S DIR("?" ,2)=" 'NO' to not add a nother PTF record"
	2845	"RTN","DGP TFFB",51,0 )
	2846	S DIR("?" )=" "
	2847	"RTN","DGP TFFB",52,0 )
	2848	S DIR("B" )="NO" D ^ DIR K DIR
	2849	"RTN","DGP TFFB",53,0 )
	2850	CHKQ Q
	2851	"RTN","DGP TFM")
	2852	0^18^B8846 9796^B8142 7420
	2853	"RTN","DGP TFM",1,0)
	2854	DGPTFM ;AL B/MTC/PLT - PTF OP-P RO-DIAG ;0 7/01/2015 8:03 AM
	2855	"RTN","DGP TFM",2,0)
	2856	;;5.3;Reg istration; *510,517, 590,594,60 6,635,683, 696,664,85 0,884,914 *;Aug 13, 1993;Build 173
	2857	"RTN","DGP TFM",3,0)
	2858	;;Per VA Directive 6402, this routine s hould not be modifie d.
	2859	"RTN","DGP TFM",4,0)
	2860	;
	2861	"RTN","DGP TFM",5,0)
	2862	K X1,M,S, P,M1,M2,M3 ,S1,S2,PS2 ,P1,P2,P1P ,P2P,SDCLY ,^TMP("PTF ",$J)
	2863	"RTN","DGP TFM",6,0)
	2864	N EFFDATE ,IMPDATE,D GMOVCNT,DG SURCNT,DGP ROCNT,DGMM ORE,DGPMOR E
	2865	"RTN","DGP TFM",7,0)
	2866	D EFFDATE ^DGPTIC10( PTF)
	2867	"RTN","DGP TFM",8,0)
	2868	S DGMOVCN T=0,DGSURC NT=0,DGPRO CNT=0
	2869	"RTN","DGP TFM",9,0)
	2870	S I=0 F I 1=1:1 S I= $O(^DGPT(P TF,"M",I)) Q:'I S D GMOVCNT=$G (DGMOVCNT) +1
	2871	"RTN","DGP TFM",10,0)
	2872	S I=0 F I 1=1:1 S I= $O(^DGPT(P TF,"S",I)) Q:'I S D GSURCNT=$G (DGSURCNT) +1
	2873	"RTN","DGP TFM",11,0)
	2874	S I=0 F I 1=1:1 S I= $O(^DGPT(P TF,"P",I)) Q:'I S D GPROCNT=$G (DGPROCNT) +1
	2875	"RTN","DGP TFM",12,0)
	2876	S I=0 F I 1=1:1:5 S I=$P($G(^D GPT(PTF,"4 01P")),U,I 1) I +I S DGPRCNT=$G (DGPRCNT)+ 1
	2877	"RTN","DGP TFM",13,0)
	2878	S DGMMORE =$G(DGSURC NT)+$G(DGP ROCNT)+$G( DGPRCNT)
	2879	"RTN","DGP TFM",14,0)
	2880	S DGPMORE =$G(DGPROC NT)+$G(DGP RCNT)
	2881	"RTN","DGP TFM",15,0)
	2882	;
	2883	"RTN","DGP TFM",16,0)
	2884	GET ;set m ,m3 local array of m ovement re cords
	2885	"RTN","DGP TFM",17,0)
	2886	S I=0 F I 1=1:1 S I= $O(^DGPT(P TF,"M",I)) Q:'I D
	2887	"RTN","DGP TFM",18,0)
	2888	. S M(I1) =^(I,0),M3 (+M(I1))=M (I1) ;,M(I 1,82)=$G(^ DGPT(PTF," M",I,82))
	2889	"RTN","DGP TFM",19,0)
	2890	. I $D(^D GPT(PTF,"M ",I,"P")) S $P(M(I1) ,U,20)=^(" P")
	2891	"RTN","DGP TFM",20,0)
	2892	. QUIT
	2893	"RTN","DGP TFM",21,0)
	2894	;sort m a rray in ch ronologica l order fo r display, not m3
	2895	"RTN","DGP TFM",22,0)
	2896	K MT D OR DER^DGPTF K MT
	2897	"RTN","DGP TFM",23,0)
	2898	D GETVAR^ DGPTFM6,CL ^SDCO21(DF N,$P(^DGPT (PTF,0),U, 2),"",.SDC LY),MOB^DG PTFM2
	2899	"RTN","DGP TFM",24,0)
	2900	I $$GETCL ^DGUTL3(DF N)=1,'$G(S DCLY(9)) S SDCLY(9)= "" ; set CLV array if SD pat ch is not released y et and vet eran is CL V eligible DG5.391 4
	2901	"RTN","DGP TFM",25,0)
	2902	S DGPC=I1 -1
	2903	"RTN","DGP TFM",26,0)
	2904	D WR ; cr eates head er
	2905	"RTN","DGP TFM",27,0)
	2906	K M1,M2,^ UTILITY($J )
	2907	"RTN","DGP TFM",28,0)
	2908	S ST=1,M2 =0
	2909	"RTN","DGP TFM",29,0)
	2910	DIAG ;
	2911	"RTN","DGP TFM",30,0)
	2912	K DGZSER, DGZPRO,DGZ SUR S DGZD IAG=1
	2913	"RTN","DGP TFM",31,0)
	2914	G PRO1:$Y >16 W !
	2915	"RTN","DGP TFM",32,0)
	2916	F J=ST:1: PM S NL=1, L5=0,L6=J D WD2,WD G PRO1:$Y>1 6 D WD3^DG PTFM8 W !
	2917	"RTN","DGP TFM",33,0)
	2918	S ST=1 G SER
	2919	"RTN","DGP TFM",34,0)
	2920	WD ;
	2921	"RTN","DGP TFM",35,0)
	2922	N DGMPOA
	2923	"RTN","DGP TFM",36,0)
	2924	D EFFDATE ^DGPTIC10( PTF)
	2925	"RTN","DGP TFM",37,0)
	2926	W !?2,"Mo vement Dia gnosis: ", $$GETLABEL ^DGPTIC10( DGPTDAT,"D ")
	2927	"RTN","DGP TFM",38,0)
	2928	;F J1=1:1 :11 I J1'= 6 S L=$P(M (J),U,J1+4 ),L1=0,L3= 1 I +L D
	2929	"RTN","DGP TFM",39,0)
	2930	D PTFICD^ DGPTFUT(50 1,PTF,+M(J ),.DGX501)
	2931	"RTN","DGP TFM",40,0)
	2932	S J1=0 F S J1=$O(D GX501(J1)) QUIT:'J1 S L=DGX50 1(J1),L1=0 ,L3=1 I +L D
	2933	"RTN","DGP TFM",41,0)
	2934	. S DGMPO A=$P(L,U,2 )
	2935	"RTN","DGP TFM",42,0)
	2936	. D:+L WD 1
	2937	"RTN","DGP TFM",43,0)
	2938	. QUIT
	2939	"RTN","DGP TFM",44,0)
	2940	K DGX501
	2941	"RTN","DGP TFM",45,0)
	2942	QUIT
	2943	"RTN","DGP TFM",46,0)
	2944	WD1 ;
	2945	"RTN","DGP TFM",47,0)
	2946	S N=$$ICD DATA^ICDXC ODE("DIAG" ,+L,EFFDAT E),M2=M2+1
	2947	"RTN","DGP TFM",48,0)
	2948	W !,?L1,$ J(M2,3)," "
	2949	"RTN","DGP TFM",49,0)
	2950	D WRITECO D^DGPTIC10 ("DIAG",+L ,EFFDATE,1 ,0,0)
	2951	"RTN","DGP TFM",50,0)
	2952	I $P(N,U, 20)=30 W:$ X>73 !," " W " (POA =",$S(DGMP OA]"":DGMP OA,1:"''") ,")"
	2953	"RTN","DGP TFM",51,0)
	2954	W $S(+N<1 !('$P(N,U, 10)):"*",1 :"")
	2955	"RTN","DGP TFM",52,0)
	2956	K ^UTILIT Y($J,"M2", M2) S ^UTI LITY($J,"M 2",M2)=+M( J+L1)_U_J1 _U_(+L)_U_ DGMPOA
	2957	"RTN","DGP TFM",53,0)
	2958	I $Y>(IOS L-4) D PGB R W @IOF,H EAD,?70 S Z="<MAS>" D Z W !
	2959	"RTN","DGP TFM",54,0)
	2960	QUIT
	2961	"RTN","DGP TFM",55,0)
	2962	WD2 ;
	2963	"RTN","DGP TFM",56,0)
	2964	N Z3
	2965	"RTN","DGP TFM",57,0)
	2966	W !?L5,"M ove #",+L6 S Z=M(L6) ,Z3=M3(+Z) W:+Z=1 " D/C" S Y=$ P(Z,U,10)\ 1 D D^DGPT UTL W " ", Y," "
	2967	"RTN","DGP TFM",58,0)
	2968	W " <",$S ($P(Z3,U,1 8)=1:"",1: "N"),"SC"_ $S($P(Z3,U ,26)="Y":" ,AO",1:"") _$S($P(Z3, U,27)="Y": ",IR",1:"" )_$S($P(Z3 ,U,28)="Y" :",SWAC",1 :"")_$S($P (Z3,U,32)= "Y":",SHAD ",1:"")_"> "
	2969	"RTN","DGP TFM",59,0)
	2970	I $D(^DIC (42.4,+$P( Z,U,2),0)) D
	2971	"RTN","DGP TFM",60,0)
	2972	. I $P(^D IC(42.4,+$ P(Z,U,2),0 ),U,2)'="" W $E($P(^ DIC(42.4,+ $P(Z,U,2), 0),U,2),1, 10)
	2973	"RTN","DGP TFM",61,0)
	2974	. E W $E ($P(^(0),U ,1),1,10) ;^(0) refe rences glo bal in lin e above
	2975	"RTN","DGP TFM",62,0)
	2976	. QUIT
	2977	"RTN","DGP TFM",63,0)
	2978	QUIT
	2979	"RTN","DGP TFM",64,0)
	2980	;
	2981	"RTN","DGP TFM",65,0)
	2982	NDG D WR S I=0 K M,M 1,M2 S M2= 0 F I1=1:1 S I=$O(^D GPT(PTF,"M ",I)) Q:I' >0 S M(I1 )=^(I,0) ; ,M(I1,82)= $G(^DGPT(P TF,"M",I,8 2))
	2983	"RTN","DGP TFM",66,0)
	2984	;sort m a rray in ch ronologica l order fo r display
	2985	"RTN","DGP TFM",67,0)
	2986	S PM=I1-1 D ORDER^D GPTF K MT G DIAG:$D( ST) G GET S ST=1
	2987	"RTN","DGP TFM",68,0)
	2988	;
	2989	"RTN","DGP TFM",69,0)
	2990	SER ;
	2991	"RTN","DGP TFM",70,0)
	2992	K DGZDIAG ,DGZPRO,DG ZSUR
	2993	"RTN","DGP TFM",71,0)
	2994	S DGZSER= 1
	2995	"RTN","DGP TFM",72,0)
	2996	;G PRO1:$ Y>19
	2997	"RTN","DGP TFM",73,0)
	2998	K S1,S2
	2999	"RTN","DGP TFM",74,0)
	3000	S S2=0 G SERV:ST G PRO
	3001	"RTN","DGP TFM",75,0)
	3002	;
	3003	"RTN","DGP TFM",76,0)
	3004	SERV ;
	3005	"RTN","DGP TFM",77,0)
	3006	;F J=ST:2 :SU S NL=1 ,L5=0,L6=J D SD2 S L 5=1,L6=J+1 D:$D(S(L6 )) SD2 D S D G PRO1:$ Y>11 D SD3 ^DGPTFM8 G PRO1:$Y>1 1 W !
	3007	"RTN","DGP TFM",78,0)
	3008	F J=ST:1: SU S NL=1, L5=0,L6=J D SD2,SD D SD3^DGPTF M8 G:(J<SU ) PRO1:$Y> 12 W !
	3009	"RTN","DGP TFM",79,0)
	3010	K DGZSER
	3011	"RTN","DGP TFM",80,0)
	3012	G PRC^DGP TFM0
	3013	"RTN","DGP TFM",81,0)
	3014	SD ;
	3015	"RTN","DGP TFM",82,0)
	3016	;F J1=1:1 :5 S L=$P( S(J),U,J1+ 7),L1=0,L3 =1 D:+L SD 1
	3017	"RTN","DGP TFM",83,0)
	3018	D PTFICD^ DGPTFUT(40 1,PTF,S(J, 1),.DGX401 )
	3019	"RTN","DGP TFM",84,0)
	3020	S J1=0 F S J1=$O(D GX401(J1)) QUIT:'J1 S L=DGX40 1(J1),L1=0 ,L3=1 D:+L SD1
	3021	"RTN","DGP TFM",85,0)
	3022	K DGX401
	3023	"RTN","DGP TFM",86,0)
	3024	QUIT
	3025	"RTN","DGP TFM",87,0)
	3026	SD1 ;
	3027	"RTN","DGP TFM",88,0)
	3028	S N=$$ICD DATA^ICDXC ODE("PROC" ,+L,EFFDAT E)
	3029	"RTN","DGP TFM",89,0)
	3030	S S2=S2+1
	3031	"RTN","DGP TFM",90,0)
	3032	W !,?L1,$ J(S2,3)," " D WRITEC OD^DGPTIC1 0("PROC",+ L,EFFDATE, 1,0,0) W $S(+N<1!(' $P(N,U,10) ):"*",1:"" )
	3033	"RTN","DGP TFM",91,0)
	3034	K S2(S2) S S2(S2)=J +L1_U_J1_U _(+L)
	3035	"RTN","DGP TFM",92,0)
	3036	I $Y>(IOS L-4) D PGB R W @IOF,H EAD,?70 S Z="<MAS>" D Z W !
	3037	"RTN","DGP TFM",93,0)
	3038	Q
	3039	"RTN","DGP TFM",94,0)
	3040	;
	3041	"RTN","DGP TFM",95,0)
	3042	SD2 ;
	3043	"RTN","DGP TFM",96,0)
	3044	S Y=+S(L6 ) D D^DGPT UTL W !?L5 ,L6,"-Surg ery date: ",Y,$$GETL ABEL^DGPTI C10(EFFDAT E,"P")
	3045	"RTN","DGP TFM",97,0)
	3046	Q
	3047	"RTN","DGP TFM",98,0)
	3048	NSR K S,S1 ,S2 S I=0 F I1=1:1 S I=$O(^DGP T(PTF,"S", I)) Q:I'>0 S S(I1)= ^(I,0),S(I 1,1)=I
	3049	"RTN","DGP TFM",99,0)
	3050	S S2=0,SU =I1-1 D WR G SERV
	3051	"RTN","DGP TFM",100,0 )
	3052	;
	3053	"RTN","DGP TFM",101,0 )
	3054	WR W @IOF, HEAD,?70 S Z="<MAS>" D Z
	3055	"RTN","DGP TFM",102,0 )
	3056	Q
	3057	"RTN","DGP TFM",103,0 )
	3058	PRO ;load 401p code before 287 1000
	3059	"RTN","DGP TFM",104,0 )
	3060	K DGZSER, DGZDIAG,DG ZSUR
	3061	"RTN","DGP TFM",105,0 )
	3062	S DGZPRO= 1
	3063	"RTN","DGP TFM",106,0 )
	3064	G:$G(DGPR CNT) PRO1: $Y>14
	3065	"RTN","DGP TFM",107,0 )
	3066	K P1P,P2P S ST=1,P2 P=0
	3067	"RTN","DGP TFM",108,0 )
	3068	G NPR:'$D (PROC)
	3069	"RTN","DGP TFM",109,0 )
	3070	;
	3071	"RTN","DGP TFM",110,0 )
	3072	PROC ; Dis play proce dures in f ield 45.01 - 45.05
	3073	"RTN","DGP TFM",111,0 )
	3074	;
	3075	"RTN","DGP TFM",112,0 )
	3076	G PRO1:$Y >14 ;D:$Y> 14 WR
	3077	"RTN","DGP TFM",113,0 )
	3078	S PROC=$S ($D(^DGPT( PTF,"401P" )):^("401P "),1:"")
	3079	"RTN","DGP TFM",114,0 )
	3080	F PR=1:1: 5 S DGPROC =$G(DGPROC )_$P(PROC, "^",PR)
	3081	"RTN","DGP TFM",115,0 )
	3082	K PR
	3083	"RTN","DGP TFM",116,0 )
	3084	W:DGPROC] "" !,"Proc edures: ", $$GETLABEL ^DGPTIC10( DGPTDAT,"P ")
	3085	"RTN","DGP TFM",117,0 )
	3086	F J1=1:1: 5 S L=$P(P ROC,"^",J1 ) I L'="" S P2P=P2P+ 1 D
	3087	"RTN","DGP TFM",118,0 )
	3088	. S N=$$I CDDATA^ICD XCODE("PRO C",+L,EFFD ATE)
	3089	"RTN","DGP TFM",119,0 )
	3090	. S L2=$S (N:$P(N,U, 2,99),1:"" )
	3091	"RTN","DGP TFM",120,0 )
	3092	. W !,$J( P2P,3)," " D WRITECO D^DGPTIC10 ("PROC",+L ,EFFDATE,1 ,0,0)
	3093	"RTN","DGP TFM",121,0 )
	3094	. W $S(+N <1!('$P(N, U,10)):"*" ,1:"")
	3095	"RTN","DGP TFM",122,0 )
	3096	. K P2P(P 2P) S P2P( P2P)=J1 W: $X>45 !
	3097	"RTN","DGP TFM",123,0 )
	3098	K DGZSER, DGZPRO,DGZ DIAG,DGZSU R
	3099	"RTN","DGP TFM",124,0 )
	3100	;
	3101	"RTN","DGP TFM",125,0 )
	3102	ENC ;G PRO 1:$Y>7,PRO 1:'$P(DGZP RF,U,3)
	3103	"RTN","DGP TFM",126,0 )
	3104	G PRO1:'$ P(DGZPRF,U ,3)
	3105	"RTN","DGP TFM",127,0 )
	3106	G PRO1:$Y >12
	3107	"RTN","DGP TFM",128,0 )
	3108	;
	3109	"RTN","DGP TFM",129,0 )
	3110	PF S PS2=0 ,J=+DGZPRF ,Y=+DGZPRF (J),DGSTRT =$S(+$P(DG ZPRF,U,4): $P(DGZPRF, U,4),1:4), DGLST=0
	3111	"RTN","DGP TFM",130,0 )
	3112	D CL^SDCO 21(DFN,+DG ZPRF(J),"" ,.SDCLY),I CDINFO^DGA PI(DFN,PTF ),XREF^DGP TFM21 ; lo ad SCI inf o and DGN' s for this service d ate
	3113	"RTN","DGP TFM",131,0 )
	3114	I $$GETCL ^DGUTL3(DF N)=1,'$G(S DCLY(9)) S SDCLY(9)= "" ; set CLV array if SD pat ch is not released y et DG5.3 914 and ve teran is C LV eligibl e
	3115	"RTN","DGP TFM",132,0 )
	3116	D D^DGPTU TL W !,J," -CPT Captu re Date/Ti me: ",Y W: ($P(DGZPRF ,U,2)-1!($ G(PGBRK))) " (cont.) "
	3117	"RTN","DGP TFM",133,0 )
	3118	I $P(DGZP RF(J),U,2) W !,?5,"R eferring o r Ordering Provider: " S L=$P( DGZPRF(J), U,2) D PRV
	3119	"RTN","DGP TFM",134,0 )
	3120	W !,?5,"R endering P rovider: " S L=$P(DG ZPRF(J),U, 3) D PRV
	3121	"RTN","DGP TFM",135,0 )
	3122	I $P(DGZP RF(J),U,5) W !,?5,"R endering L ocation: " ,$P($G(^SC ($P(DGZPRF (J),U,5),0 )),U)
	3123	"RTN","DGP TFM",136,0 )
	3124	S (L1,PGB RK)=0
	3125	"RTN","DGP TFM",137,0 )
	3126	F K=$P(DG ZPRF,U,2): 1 Q:'$D(DG ZPRF(J,K)) I '$G(DG ZPRF(J,K,9 )) S PS2=P S2+1 W !,? 2,PS2," " D CPT^DGPT UTL1 D Q: $Y+$G(DGZP RF(J,K+1,1 ))>16!($G( PGBRK))
	3127	"RTN","DGP TFM",138,0 )
	3128	.; Add 80 1 logic
	3129	"RTN","DGP TFM",139,0 )
	3130	. W !,?4 S $P(DS,"- ",21)="" W DS," Rela ted Diagno sis",$$GET LABEL^DGPT IC10(+DGZP RF(J),"D") ," ",DS
	3131	"RTN","DGP TFM",140,0 )
	3132	. F L1=DG STRT:1:11 S DGLOC=$S (L1<8:L1,1 :L1+7),CD= $P(DGZPRF( J,K),U,DGL OC) I CD D I $Y+$G( CKSCI)>16 S PGBRK=1 Q
	3133	"RTN","DGP TFM",141,0 )
	3134	. . S N=$ $ICDDATA^I CDXCODE("D IAG",CD,+D GZPRF(J)) ;,N=$S(N:$ P(N,U,2,99 ),1:"")
	3135	"RTN","DGP TFM",142,0 )
	3136	. . D WRI TECOD^DGPT IC10("DIAG ",CD,+DGZP RF(J),2,1, 8)
	3137	"RTN","DGP TFM",143,0 )
	3138	. . W $S( +N<1!('$P( N,U,10)):" *",1:"")
	3139	"RTN","DGP TFM",144,0 )
	3140	. . D CKS CI($P(DGZP RF(J,K),U, DGLOC))
	3141	"RTN","DGP TFM",145,0 )
	3142	. S PS2(P S2)=J_U_K, CD=1,DGLOC =0,DGSTRT= 4
	3143	"RTN","DGP TFM",146,0 )
	3144	I L1'=11, $S(L1<8:$P ($G(DGZPRF (J,K)),U,L 1+1,7),1:" ")_$P($G(D GZPRF(J,K) ),U,$S(L1< 8:15,1:L1+ 8),18)?."^ " S L1=11
	3145	"RTN","DGP TFM",147,0 )
	3146	I L1=11 S $P(DGZPRF ,U,1,2)=$S ($D(DGZPRF (J,K+1)):J _U_(K+1),1 :J+1_U_1), $P(DGZPRF, U,4)="",PG BRK=0
	3147	"RTN","DGP TFM",148,0 )
	3148	E S $P(D GZPRF,U,1, 2)=J_U_K,$ P(DGZPRF,U ,4)=L1+1
	3149	"RTN","DGP TFM",149,0 )
	3150	K I,K,L,L 1,CD,N,DS G PRO1
	3151	"RTN","DGP TFM",150,0 )
	3152	;
	3153	"RTN","DGP TFM",151,0 )
	3154	CKSCI(IEN) ;pri nt SCI for each Diag nosis code
	3155	"RTN","DGP TFM",152,0 )
	3156	N DGINFO Q:'$D(XREF (IEN))
	3157	"RTN","DGP TFM",153,0 )
	3158	S DGINFO= $G(^DGICD9 (46.1,(XRE F(IEN)),0) ),CKSCI=0
	3159	"RTN","DGP TFM",154,0 )
	3160	I 'DGINFO Q
	3161	"RTN","DGP TFM",155,0 )
	3162	;JMM DG5 .3914 RSD SPEC# 2.6 .5.2.3.2 < MAS> Scree n Camp Lej eune - Add 9 to FOR list below to includ e Camp Lej eune quest ion below
	3163	"RTN","DGP TFM",156,0 )
	3164	F I=3,7,1 ,2,4,5,6,8 ,9 I $D(SD CLY(I)) S L=$S(I=3:8 ,I<4:8+I,1 :7+I) D
	3165	"RTN","DGP TFM",157,0 )
	3166	.W ?45 S M=1,CKSCI= CKSCI+1
	3167	"RTN","DGP TFM",158,0 )
	3168	.W !?8
	3169	"RTN","DGP TFM",159,0 )
	3170	.;JMM DG* 5.3*914 RS D SPEC# 2. 6.5.2.3.2 <MAS> Scre en Camp Le jeune - Ad d Camp Lej eune quest ion to lis t below
	3171	"RTN","DGP TFM",160,0 )
	3172	.W $P("Tr eated for AO Conditi on^Treated for IR Co ndition^Tr eated for SC Conditi on^Exposed to SW Asi a Conditio ns^Treatme nt for MST ^Treatment for Head/ Neck CA^Re lated to C ombat^Trea tment for SHAD Condi tion^Treat ment for C amp Lejeun e",U,I)
	3173	"RTN","DGP TFM",161,0 )
	3174	.W ": ",$ S($P(DGINF O,U,($S(I< 3:I+2,I=3: 2,1:I+1))) :"YES",1:" NO"),!
	3175	"RTN","DGP TFM",162,0 )
	3176	Q ;CKSCI
	3177	"RTN","DGP TFM",163,0 )
	3178	;
	3179	"RTN","DGP TFM",164,0 )
	3180	NPR S ST=1 ,PROC=$S($ D(^DGPT(PT F,"401P")) :^("401P") ,1:"") D W R G PRO
	3181	"RTN","DGP TFM",165,0 )
	3182	;
	3183	"RTN","DGP TFM",166,0 )
	3184	NPS D WR G PF
	3185	"RTN","DGP TFM",167,0 )
	3186	;
	3187	"RTN","DGP TFM",168,0 )
	3188	DONE G EN1 ^DGPTF4
	3189	"RTN","DGP TFM",169,0 )
	3190	PRO1 ;SET MENU TYPE AND DISPLA Y MENU
	3191	"RTN","DGP TFM",170,0 )
	3192	N ICDVDT, ICPTVDT
	3193	"RTN","DGP TFM",171,0 )
	3194	I $G(PTF) '="",$G(EF FDATE)="" D EFFDATE^ DGPTIC10(P TF)
	3195	"RTN","DGP TFM",172,0 )
	3196	S (ICDVDT ,ICPTVDT)= $S($G(EFFD ATE)'="":E FFDATE,$D( PTF):$$GET DATE^ICDGT DRG(PTF),1 :DT)
	3197	"RTN","DGP TFM",173,0 )
	3198	S DGNUM=$ S($D(DGZDI AG)!($D(DG ZPRO))!($D (DGZSER))! ($D(DGZSUR )!(+DGZPRF -1'=$P(DGZ PRF,U,3))) :"MAS",1:" 701") G MA S^DGPTFJC: DGST F X=$ Y:1:(IOSL- 9) W !
	3199	"RTN","DGP TFM",174,0 )
	3200	W !! S Z= "Patient M ovements:" W Z S Z=" "_$S(DGPT FE:"M=Add PM X=Dele te PM",1:" M=Edit Tre at Spec/PM ")_" A=A dd Code D =Delete Co de V=Edit Mov" W Z
	3201	"RTN","DGP TFM",175,0 )
	3202	W ! S Z=" Surgical E pisodes:" W Z S Z=" S=Add SE Z=Delete S E O=Add C ode C=Del ete Code J=Edit SE" W Z
	3203	"RTN","DGP TFM",176,0 )
	3204	W ! S Z=" Procedure Records:" W Z S Z=" T=Add PR R=Delete P R P=Add C ode Q=Del ete Code E=Edit PR" W Z
	3205	"RTN","DGP TFM",177,0 )
	3206	W ! S Z=" 801:" W Z S Z=" I=Add 801 Y=Delete 8 01 N=Add C PT G=Del ete CPT F=Edit 801 " W Z K Z
	3207	"RTN","DGP TFM",178,0 )
	3208	W !," ^=Abo rt <RET> to Contin ue:<",DGNU M,">// " R ANS:DTIME K DGNUM
	3209	"RTN","DGP TFM",179,0 )
	3210	A S Z="^C Delete Cod e^A Add Co de^O Add C ode^P Add NOP^S Add SE^D Delet e Code^M A dd PM^X De lete PM^Z Delete SE^ J Edit SE^ Q Delete N OP^V Edit Move^"
	3211	"RTN","DGP TFM",180,0 )
	3212	S Z=Z_"T Add PR^R D elete PR^E Edit PR^I Add 801^Y Delete 80 1^N Add CP T^G Delete CPT^F Edi t 801"
	3213	"RTN","DGP TFM",181,0 )
	3214	I 'DGPTFE S $P(Z,U, 8,9)="M Ed it treat S pec/PM"
	3215	"RTN","DGP TFM",182,0 )
	3216	S X=ANS G Q^DGPTF:A NS="^" G ^ DGPTFJ:ANS ?1"^".E S (A,X)=ANS, X=$E(X,1) D IN^DGHEL P
	3217	"RTN","DGP TFM",183,0 )
	3218	I $P(^DGP T(PTF,0),U ,4),X'="", "IYNGF"[X W !,"*WA RNING: Thi s is a Fee Basis PTF record* 801 encou nters are not allowe d." H 3 G DGPTFM
	3219	"RTN","DGP TFM",184,0 )
	3220	I ANS="" S (ST,ST1) =J+1 D:$D( DGZSUR) WR G @($S($D (DGZDIAG): "NDG",$D(D GZSER):"NS R",$D(DGZP RO):"NPR", $D(DGZSUR) :"EN^DGPTF M0",+DGZPR F-1'=$P(DG ZPRF,U,3): "NPS",1:"D ONE"))
	3221	"RTN","DGP TFM",185,0 )
	3222	G HELP^DG PTFM1A:$G( %)=-1 S Z= $L(A)-1 G @(X_$S(X=" X":"",1:"^ DGPTFM1"))
	3223	"RTN","DGP TFM",186,0 )
	3224	PRV I $D(^ VA(200,L,0 )) W $P(^( 0),U) Q
	3225	"RTN","DGP TFM",187,0 )
	3226	W L Q
	3227	"RTN","DGP TFM",188,0 )
	3228	X ;
	3229	"RTN","DGP TFM",189,0 )
	3230	I 'Z S:PM =1 RC=1 G X1:PM=1 W !!,"Delete Patient m ove <1",$S (PM<3:"",1 :"-"_(PM-1 )),">: " R RC:DTIME G ^DGPTFM: RC["^"!(RC ="")
	3231	"RTN","DGP TFM",190,0 )
	3232	E S RC=$ E(A,2,99) W !
	3233	"RTN","DGP TFM",191,0 )
	3234	I +RC'=RC !('$D(M(RC ))) W !!," Enter the record # t o delete f rom the PT F file, 1" ,$S(PM<3:" ",1:"-"_(P M-1)) S Z= 0 G X
	3235	"RTN","DGP TFM",192,0 )
	3236	X1 I +M(RC )=1 W !,*7 ,"Cannot d elete disc harge move ment",! H 3 G ^DGPTF M
	3237	"RTN","DGP TFM",193,0 )
	3238	S DIE="^D GPT("_PTF_ ",""M"",", DP=45.02,D R=".01///@ ",DA(1)=PT F,DA=+M(RC ) D ^DIE K DR W " " ,RC,"-DELE TED***" H 2 G ^DGPTF M
	3239	"RTN","DGP TFM",194,0 )
	3240	Z ;
	3241	"RTN","DGP TFM",195,0 )
	3242	W @DGVI,Z ,@DGVO Q ; Writes r everse vid eo
	3243	"RTN","DGP TFM",196,0 )
	3244	EN D WR G EN^DGPTFM0
	3245	"RTN","DGP TFM",197,0 )
	3246	Q
	3247	"RTN","DGP TFM",198,0 )
	3248	;
	3249	"RTN","DGP TFM",199,0 )
	3250	PGBR N DIR ,X,Y S DIR (0)="E",DI R("A")="En ter RETURN to contin ue" D ^DIR QUIT
	3251	"RTN","DGP TFM",200,0 )
	3252	;
	3253	"RTN","DGP TFM2")
	3254	0^72^B5438 7133^B5091 6378
	3255	"RTN","DGP TFM2",1,0)
	3256	DGPTFM2 ;A LB/DWS - M ASTER PROF ESSIONAL S ERVICE ENT ER/EDIT ;6 /16/05 8:3 3am
	3257	"RTN","DGP TFM2",2,0)
	3258	;;5.3;Reg istration; *517,590, 606,635,85 0,912,914 *;Aug 13, 1993;Build 173
	3259	"RTN","DGP TFM2",3,0)
	3260	ADD ;ADD C PT RECORD
	3261	"RTN","DGP TFM2",4,0)
	3262	N DGZP S DGZP=0 S:' $D(^DGPT(P TF,"C",0)) ^(0)="^45 .06D^^"
	3263	"RTN","DGP TFM2",5,0)
	3264	S DIC="^D GPT("_PTF_ ",""C"",", DIC(0)="AE LQMXZ",DA( 1)=PTF,DLA YGO=45
	3265	"RTN","DGP TFM2",6,0)
	3266	D ^DIC K DIC,DLAYGO G ^DGPTFM :Y'>0,^DGP TFM:'$D(^D GPT(PTF,"C ",+Y))
	3267	"RTN","DGP TFM2",7,0)
	3268	S DGPSM=+ Y
	3269	"RTN","DGP TFM2",8,0)
	3270	I '$P(Y,U ,3) S DIR( "A")="Do y ou want to edit this CPT RECOR D DATE/TIM E?",DIR(0) ="Y",DIR(" B")="YES" D ^DIR G ^ DGPTFM:'Y! $D(DIRUT)
	3271	"RTN","DGP TFM2",9,0)
	3272	D MOB
	3273	"RTN","DGP TFM2",10,0 )
	3274	I $P(DGZP RF,U,3) F I=1:1:$P(D GZPRF,U,3) S:DGZPRF( I,0)=DGPSM DGZP=I
	3275	"RTN","DGP TFM2",11,0 )
	3276	K I G:'DG ZP ^DGPTFM S X="A,B" ,DGPSM=0
	3277	"RTN","DGP TFM2",12,0 )
	3278	ED G HELP^ DGPTUTL1:X '["A"&(X'[ "B")&(X'[" a")&(X'["b ") K DA
	3279	"RTN","DGP TFM2",13,0 )
	3280	S DGJUMP= X,DGPRD=+D GZPRF(DGZP ),X1="^801 "
	3281	"RTN","DGP TFM2",14,0 )
	3282	I X["A"!( X["a") D L -^DGPT(P TF) I FLAG D MOB,REQ ^DGPTFM3 G EXIT
	3283	"RTN","DGP TFM2",15,0 )
	3284	.S DA(1)= PTF,DIE="^ DGPT("_PTF _",""C""," ,(DA,REC)= DGZPRF(DGZ P,0)
	3285	"RTN","DGP TFM2",16,0 )
	3286	.S DR=".0 1;.02;.03; .05;.09/// /0",DIC(0) ="AELQZ" Q :'$$LOCK
	3287	"RTN","DGP TFM2",17,0 )
	3288	.D FMDIE S FLAG=$D( Y)>9!$D(DO UT)!'$D(DA ) Q:$D(Y)> 9!'$D(DA)
	3289	"RTN","DGP TFM2",18,0 )
	3290	.S DGPRD= +^DGPT(PTF ,"C",DGZPR F(DGZP,0), 0) Q:+DGZP RF(DGZP)=D GPRD
	3291	"RTN","DGP TFM2",19,0 )
	3292	.S DGI=0 F S DGI=$ O(^DGCPT(4 6,"C",PTF, DGI)) Q:DG I'>0 D Q :$D(Y)>9!' $D(DA)
	3293	"RTN","DGP TFM2",20,0 )
	3294	..Q:+^DGC PT(46,DGI, 1)'=+DGZPR F(DGZP) Q :$D(^(9))
	3295	"RTN","DGP TFM2",21,0 )
	3296	..S DR=". 14////"_DG PRD,(DA,RE C)=DGI,DIE ="^DGCPT(4 6," D FMDI E
	3297	"RTN","DGP TFM2",22,0 )
	3298	..I $D(Y) >9!'$D(DA) S FLAG=1
	3299	"RTN","DGP TFM2",23,0 )
	3300	..;ADD IM PDATE chec k to see i f Edit on date chang ed coding system
	3301	"RTN","DGP TFM2",24,0 )
	3302	. I $P(DG ZPRF(DGZP) ,U)<IMPDAT E,DGPRD'<I MPDATE D E N^DDIOL("P rimary Dia gnosis cha nging from ICD-9 to ICD-10. Yo u must edi t the Diag nosis.") S DGJUMP="B "
	3303	"RTN","DGP TFM2",25,0 )
	3304	. I $P(DG ZPRF(DGZP) ,U)'<IMPDA TE,DGPRD<I MPDATE D E N^DDIOL("P rimary Dia gnosis cha nging from ICD-10 to ICD-9. Yo u must edi t the Diag nosis.") S DGJUMP="B "
	3305	"RTN","DGP TFM2",26,0 )
	3306	.S $P(DGZ PRF(DGZP), U)=DGPRD
	3307	"RTN","DGP TFM2",27,0 )
	3308	JUMP I DGJ UMP["B"!(D GJUMP["b") S DGI=0 D CL^SDCO21 (DFN,DGPRD ,"",.SDCLY ) D
	3309	"RTN","DGP TFM2",28,0 )
	3310	.I $$GETC L^DGUTL3(D FN)=1,'$G( SDCLY(9)) S SDCLY(9) ="" ; se t CLV arra y if SD pa tch is not released yet and ve teran is C LV eligibl e DG5.39 14
	3311	"RTN","DGP TFM2",29,0 )
	3312	.F S DGI =$O(^DGCPT (46,"C",PT F,DGI)) Q: DGI'>0 I +^DGCPT(46 ,DGI,1)=+D GZPRF(DGZP ),'$G(^(9) ) D I $D( DUOUT) Q:' DGDIAG K DUOUT S DG I=0
	3313	"RTN","DGP TFM2",30,0 )
	3314	..S (DA,R EC)=DGI,DR =".01;",DI E="^DGCPT( 46," D GET INFO^DGPTF M21
	3315	"RTN","DGP TFM2",31,0 )
	3316	.Q:$D(DUO UT)
	3317	"RTN","DGP TFM2",32,0 )
	3318	.F D D ^DIC S A=0 Q:Y'>0 D SED Q:$D( DUOUT)
	3319	"RTN","DGP TFM2",33,0 )
	3320	..S DA=PT F,DIC="^DG CPT(46,",D IC(0)="AEL MQZ",DLAYG O=46
	3321	"RTN","DGP TFM2",34,0 )
	3322	..S DIC(" S")="D EN6 ^DGPTFJC I 'DGER"
	3323	"RTN","DGP TFM2",35,0 )
	3324	I $D(DUOU T),$G(DGDI AG) K DUOU T G JUMP
	3325	"RTN","DGP TFM2",36,0 )
	3326	I $D(DUOU T),$G(DGJU MP)["A"!($ G(DGJUMP)[ "a") S X=D GJUMP K DU OUT G ED
	3327	"RTN","DGP TFM2",37,0 )
	3328	K DR,DIE, DIC,DA,DGI ,DGJUMP,DG PRD,DLAYGO ,XREF
	3329	"RTN","DGP TFM2",38,0 )
	3330	D REQ^DGP TFM3,MOB H :RFL 2 K R FL
	3331	"RTN","DGP TFM2",39,0 )
	3332	G ^DGPTFM :'$D(DGZPR F(DGZP,0)) ,^DGPTFM:' $D(^DGPT(P TF,"C",DGZ PRF(DGZP,0 )))
	3333	"RTN","DGP TFM2",40,0 )
	3334	SET D MOB: '$D(DGZPRF ) S:'$D(DG ZP) DGZP=1 I $G(DGZP RF(DGZP,0) )="" K DGZ PRF(DGZP) G NEXP
	3335	"RTN","DGP TFM2",41,0 )
	3336	WRT G ^DGP TFM:'$D(^D GPT(PTF,"C ",DGZPRF(D GZP,0),0)) S J=DGZP W @IOF,HEA D,?68
	3337	"RTN","DGP TFM2",42,0 )
	3338	N DGNUM S Z="<"_DGZ P_">" W @D GVI,Z,@DGV O,!! S Y=+ DGZPRF(J), Z="A"
	3339	"RTN","DGP TFM2",43,0 )
	3340	D D^DGPTU TL,Z^DGPTF M5 W ?5,"C PT Record Date/Time: ",Y
	3341	"RTN","DGP TFM2",44,0 )
	3342	I $P(DGZP RF(J),U,8) '="" W ?55 ,"Visit Se rvice Cate gory: ",$P (DGZPRF(J) ,U,8)
	3343	"RTN","DGP TFM2",45,0 )
	3344	I $P(DGZP RF(J),U,2) W !,?5,"R eferring o r Ordering Provider: " D
	3345	"RTN","DGP TFM2",46,0 )
	3346	.S L=$P(D GZPRF(J),U ,2) D PRV^ DGPTFM
	3347	"RTN","DGP TFM2",47,0 )
	3348	W !,?5,"R endering P rovider: " S L=$P(DG ZPRF(J),U, 3) D PRV^D GPTFM
	3349	"RTN","DGP TFM2",48,0 )
	3350	I $P(DGZP RF(J),U,5) W !,?5,"R endering L ocation: " ,$P($G(^SC ($P(DGZPRF (J),U,5),0 )),U)
	3351	"RTN","DGP TFM2",49,0 )
	3352	W !! S Z= "B" D Z^DG PTFM5 W " Procedure s: "
	3353	"RTN","DGP TFM2",50,0 )
	3354	F K=$P(DG ZPRF,U,2): 1 Q:'$D(DG ZPRF(J,K)) I '$D(DG ZPRF(J,K,9 )) D
	3355	"RTN","DGP TFM2",51,0 )
	3356	.W ?5 D C PT^DGPTUTL 1 W ! Q:$Y >16
	3357	"RTN","DGP TFM2",52,0 )
	3358	F I=1:1:( IOSL-$Y-5) W !
	3359	"RTN","DGP TFM2",53,0 )
	3360	K I,J,K,L ,Z S DGNUM =$S($D(DGZ PRF(DGZP+1 )):DGZP+1, 1:"MAS")
	3361	"RTN","DGP TFM2",54,0 )
	3362	G 801^DGP TFJC:DGST
	3363	"RTN","DGP TFM2",55,0 )
	3364	S DIR("A" )="Enter < RET> to co ntinue, A- B to edit, 'I' to ad d an 801,"
	3365	"RTN","DGP TFM2",56,0 )
	3366	S DIR("A" )=DIR("A") _$C(10,13) _"the numb er of an 8 01 screen, ?? to lis t 801 scre ens,"
	3367	"RTN","DGP TFM2",57,0 )
	3368	S DIR("A" )=DIR("A") _$C(10,13) _"'S' for Send to PC E,"
	3369	"RTN","DGP TFM2",58,0 )
	3370	S DIR("A" )=DIR("A") _" '^N' fo r screen N , or '^' t o abort:"
	3371	"RTN","DGP TFM2",59,0 )
	3372	S DIR("?" )="^D HELP ^DGPTUTL1"
	3373	"RTN","DGP TFM2",60,0 )
	3374	S DIR(0)= "F^OU",DIR ("B")=DGNU M,DIR("??" )="^D DISP ^DGPTUTL1" D ^DIR
	3375	"RTN","DGP TFM2",61,0 )
	3376	K DIR G:$ D(DIRUT) Q ^DGPTF:X=" ^"
	3377	"RTN","DGP TFM2",62,0 )
	3378	I X?1"^". E S DGPTSC RN=801 G ^ DGPTFJ
	3379	"RTN","DGP TFM2",63,0 )
	3380	I X="MAS" S DGZP=1 G ^DGPTFM
	3381	"RTN","DGP TFM2",64,0 )
	3382	G ADD:X=" I"!(X="i") ,HELP^DGPT UTL1:X["?"
	3383	"RTN","DGP TFM2",65,0 )
	3384	I X?1N.N, $D(DGZPRF( X)) S DGZP =X G SET
	3385	"RTN","DGP TFM2",66,0 )
	3386	I X["A"!( X["B")!(X[ "a")!(X["b ") G ED
	3387	"RTN","DGP TFM2",67,0 )
	3388	I X="S"!( X="s") D P CE G WRT
	3389	"RTN","DGP TFM2",68,0 )
	3390	D HELP^DG PTUTL1 R ! !,"Enter < RET>: ",X: DTIME G WR T
	3391	"RTN","DGP TFM2",69,0 )
	3392	PCE L +^DG PT(PTF):2
	3393	"RTN","DGP TFM2",70,0 )
	3394	I '$T W ! ,"CPT Reco rd is bein g edited b y another user" H 2 Q
	3395	"RTN","DGP TFM2",71,0 )
	3396	D ICDINFO ^DGAPI(DFN ,PTF),XREF ^DGPTFM21
	3397	"RTN","DGP TFM2",72,0 )
	3398	S RES=$$D ATA2PCE^DG API1(DFN,P TF,DGZP)
	3399	"RTN","DGP TFM2",73,0 )
	3400	I RES=1 L -^DGPT(PT F) W !,"PT F Record s ent to PCE " H 2 Q
	3401	"RTN","DGP TFM2",74,0 )
	3402	W @IOF
	3403	"RTN","DGP TFM2",75,0 )
	3404	;F I=1:1 Q:'$D(^TMP ("DGPAPI", $J,"DIERR" ,$J,1,"TEX T",I)) W !,^(I)
	3405	"RTN","DGP TFM2",76,0 )
	3406	W !,"The PTF Record may not h ave been f iled in PC E due to e rrors."
	3407	"RTN","DGP TFM2",77,0 )
	3408	W !,"Pres s return t o continue ." R X:DTI ME
	3409	"RTN","DGP TFM2",78,0 )
	3410	L -^DGPT( PTF) Q
	3411	"RTN","DGP TFM2",79,0 )
	3412	NEXP S DGZ P=DGZP+1
	3413	"RTN","DGP TFM2",80,0 )
	3414	I '$D(DGZ PRF(DGZP)) W:DGZP=2 !,"NO PROF . SERVICES TO EDIT." G EXIT
	3415	"RTN","DGP TFM2",81,0 )
	3416	G SET
	3417	"RTN","DGP TFM2",82,0 )
	3418	EXIT K DGP SM H 2 S D GZP=1 G ^D GPTFM
	3419	"RTN","DGP TFM2",83,0 )
	3420	DEL ;DELET E A CPT RE CORD
	3421	"RTN","DGP TFM2",84,0 )
	3422	I '$P(DGZ PRF,U,3) G NOPROC
	3423	"RTN","DGP TFM2",85,0 )
	3424	ASK S DIR( "A")="Sele ct 801 rec ord to Del ete"
	3425	"RTN","DGP TFM2",86,0 )
	3426	S DIR(0)= "NO^1:"_$P (DGZPRF,U, 3),DIR("?? ")="^D DIS P^DGPTUTL1 "
	3427	"RTN","DGP TFM2",87,0 )
	3428	D ^DIR K DIR G ^DGP TFM:$D(DIR UT),^DGPTF M:'Y,^DGPT FM:'$D(^DG PT(PTF,"C" ,DGZPRF(Y, 0),0)) S D GZP=Y,Y=+^ (0) D D^DG PTUTL
	3429	"RTN","DGP TFM2",88,0 )
	3430	S DIR("A" )="Are you sure you want to de lete the e ntire 801 for "_Y
	3431	"RTN","DGP TFM2",89,0 )
	3432	S DIR(0)= "Y",DIR("B ")="No" D ^DIR K DIR G ^DGPTFM :'Y,^DGPTF M:'$$LOCK
	3433	"RTN","DGP TFM2",90,0 )
	3434	;patch DG 5.3912 m odifies wh ere the da te is bein g set for deletion. This allow s multiple cpt codes to be del eted from 801 in the ptf
	3435	"RTN","DGP TFM2",91,0 )
	3436	S DGI=0
	3437	"RTN","DGP TFM2",92,0 )
	3438	F S DGI= $O(^DGCPT( 46,"C",PTF ,DGI)) Q:D GI'>0 D:+ ^DGCPT(46, DGI,1)=+DG ZPRF(DGZP) &'$G(^(9))
	3439	"RTN","DGP TFM2",93,0 )
	3440	.D NOW^%D TC S (DA,R EC)=DGI,DI E="^DGCPT( 46,",DR="1 ////^S X=% " D FMDIE
	3441	"RTN","DGP TFM2",94,0 )
	3442	S DR=".09 ////1",DIE ="^DGPT("_ PTF_",""C" ",",DA=DGZ PRF(DGZP,0 )
	3443	"RTN","DGP TFM2",95,0 )
	3444	S DA(1)=P TF D ^DIE L -^DGPT(P TF)
	3445	"RTN","DGP TFM2",96,0 )
	3446	W !!,"CPT Records.. ..Deleted" H 2
	3447	"RTN","DGP TFM2",97,0 )
	3448	K DIK,DA, DGI,DGPROC ,DGPSM,DGP NUM,Y D MO B G ^DGPTF M
	3449	"RTN","DGP TFM2",98,0 )
	3450	NOPROC W !!,*7,"No procedures to delete ",! H 3 G ^DGPTFM
	3451	"RTN","DGP TFM2",99,0 )
	3452	N ;ADD CPT CODES TO CPT RECORD
	3453	"RTN","DGP TFM2",100, 0)
	3454	I '$P(DGZ PRF,U,3) W !!,"There are no 80 1 records that can b e added to .",*7 H 2 G ^DGPTFM
	3455	"RTN","DGP TFM2",101, 0)
	3456	P1 S DIR(" A")="Add t o 801 reco rd ",DIR(0 )="NO^1:"_ $P(DGZPRF, U,3)
	3457	"RTN","DGP TFM2",102, 0)
	3458	S DIR("?? ")="^D DIS P^DGPTUTL1 "
	3459	"RTN","DGP TFM2",103, 0)
	3460	D ^DIR K DIR G ^DGP TFM:'Y
	3461	"RTN","DGP TFM2",104, 0)
	3462	S DGZP=Y, DGI=0,DGPR D=+DGZPRF( DGZP) D CL ^SDCO21(DF N,DGPRD,"" ,.SDCLY)
	3463	"RTN","DGP TFM2",105, 0)
	3464	I $$GETCL ^DGUTL3(DF N)=1,'$G(S DCLY(9)) S SDCLY(9)= "" ; set CLV array if SD pat ch is not released y et and vet eran is CL V eligible DG5.391 4
	3465	"RTN","DGP TFM2",106, 0)
	3466	S DA=PTF, DIC="^DGCP T(46,",DIC (0)="AELQM Z",DLAYGO= 46,DIC("S" )="D EN6^D GPTFJC I ' DGER"
	3467	"RTN","DGP TFM2",107, 0)
	3468	D ^DIC K DIC,DLAYGO D:Y>0 SED ,MOB,REQ^D GPTFM3 K D GPRD,Y
	3469	"RTN","DGP TFM2",108, 0)
	3470	D PCE^DGP TFQWK G ^D GPTFM
	3471	"RTN","DGP TFM2",109, 0)
	3472	DC ;DELETE A CPT PRO CEDURE
	3473	"RTN","DGP TFM2",110, 0)
	3474	I $E($G(A NS),2,99)> 0 S DGPZ=+ $E(ANS,2,9 9) G QQ
	3475	"RTN","DGP TFM2",111, 0)
	3476	S DIR("A" )="Select 801 record to Delete a CPT cod e in"
	3477	"RTN","DGP TFM2",112, 0)
	3478	S DIR(0)= "NO^1:"_$P (DGZPRF,U, 3),DIR("?? ")="^D DIS P^DGPTUTL1 "
	3479	"RTN","DGP TFM2",113, 0)
	3480	D ^DIR K DIR G ^DGP TFM:$D(DIR UT),^DGPTF M:'Y,^DGPT FM:'$D(^DG PT(PTF,"C" ,DGZPRF(Y, 0),0)) S D GZP=Y,Y=+^ (0) D D^DG PTUTL
	3481	"RTN","DGP TFM2",114, 0)
	3482	F PS2=1:1 Q:'$D(DGZ PRF(DGZP,P S2)) S PS 2(PS2)=DGZ P_"^"_PS2
	3483	"RTN","DGP TFM2",115, 0)
	3484	S PS2=PS2 -1
	3485	"RTN","DGP TFM2",116, 0)
	3486	QQ S DIR(" A")="Selec t CPT code to Delete <1 - "_PS 2_">",DIR( 0)="NO^^K: X<1!(X>"_P S2_") X" D ^DIR K DI R G ^DGPTF M:$D(DIRUT ),^DGPTFM: 'Y
	3487	"RTN","DGP TFM2",117, 0)
	3488	QQA S A1=Y ,DGZP=+PS2 (A1),CPT=+ DGZPRF(DGZ P,$P(PS2(A 1),U,2))
	3489	"RTN","DGP TFM2",118, 0)
	3490	S DIR("A" )="Are you sure you want to de lete CPT c ode '"
	3491	"RTN","DGP TFM2",119, 0)
	3492	I $D(^ICP T(CPT)) D
	3493	"RTN","DGP TFM2",120, 0)
	3494	.S N=$$CP T^ICPTCOD( CPT,$$GETD ATE^ICDGTD RG(PTF))
	3495	"RTN","DGP TFM2",121, 0)
	3496	.S N=$S(N >0:$P(N,U, 2,99),1:"" )
	3497	"RTN","DGP TFM2",122, 0)
	3498	.S DIR("A ")=DIR("A" )_$P(N,U)_ " "_$P(N,U ,2)_"'"
	3499	"RTN","DGP TFM2",123, 0)
	3500	E S DIR( "A")=DIR(" A")_CPT_" UNKNOWN"
	3501	"RTN","DGP TFM2",124, 0)
	3502	S DIR(0)= "Y",DIR("B ")="No" D ^DIR K DIR G ^DGPTFM :'Y
	3503	"RTN","DGP TFM2",125, 0)
	3504	G ^DGPTFM :'$$LOCK
	3505	"RTN","DGP TFM2",126, 0)
	3506	QEL D NOW^ %DTC S DA= DGZPRF(DGZ P,$P(PS2(A 1),U,2),0) ,DR="1//// ^S X=%"
	3507	"RTN","DGP TFM2",127, 0)
	3508	S REC=DGZ PRF(DGZP,0 )
	3509	"RTN","DGP TFM2",128, 0)
	3510	S DIE="^D GCPT(46," D FMDIE K A1,DR W !! ,"CPT Code ....Delete d"
	3511	"RTN","DGP TFM2",129, 0)
	3512	I '$D(DGZ PRF(DGZP,2 )) S DR=". 09////1",D IE="^DGPT( "_PTF_","" C"",",DA=D GZPRF(DGZP ,0),DA(1)= PTF D ^DIE
	3513	"RTN","DGP TFM2",130, 0)
	3514	I $D(DGZP RF(DGZP,2) ) D PCE^DG PTFQWK
	3515	"RTN","DGP TFM2",131, 0)
	3516	L -^DGPT( PTF) W:$X> 70 ! D MOB H 2 G ^DG PTFM
	3517	"RTN","DGP TFM2",132, 0)
	3518	F D MOB S DGZP=$S($E ($G(ANS),2 ,99):+$E($ G(ANS),2,9 9),1:1) G SET
	3519	"RTN","DGP TFM2",133, 0)
	3520	MOB S (H,I ,N)=0 K DG ZPRF F M=1 :1:6 S:$D( SDCLY(M)) N=N+1
	3521	"RTN","DGP TFM2",134, 0)
	3522	F I2=1:1 S H=$O(^DG PT(PTF,"C" ,"B",H)) Q :H'>0 D
	3523	"RTN","DGP TFM2",135, 0)
	3524	.F S I=$ O(^DGPT(PT F,"C","B", H,I)) Q:I' >0 D
	3525	"RTN","DGP TFM2",136, 0)
	3526	..S DGZPR F(I2)=^DGP T(PTF,"C", I,0),DGZPR F(I2,0)=I, (K,K1)=0,F =1 D
	3527	"RTN","DGP TFM2",137, 0)
	3528	...F S K =$O(^DGCPT (46,"C",PT F,K)),L=N+ 1\2+3 Q:K' >0 I +DGZ PRF(I2)=+$ G(^DGCPT(4 6,K,1)),'$ G(^DGCPT(4 6,K,9)) D
	3529	"RTN","DGP TFM2",138, 0)
	3530	....S K1= K1+1,DGZPR F(I2,K1)=^ (0),DGZPRF (I2,K1,0)= K,F=0
	3531	"RTN","DGP TFM2",139, 0)
	3532	....F M=2 ,3,5,6,7,1 5,16,17,18 S:$P(DGZP RF(I2,K1), U,M) L=L+1
	3533	"RTN","DGP TFM2",140, 0)
	3534	....S DGZ PRF(I2,K1, 1)=L
	3535	"RTN","DGP TFM2",141, 0)
	3536	...I F,$G (DGPSM)'=D GZPRF(I2,0 ) K DGZPRF (I2) S I2= I2-1
	3537	"RTN","DGP TFM2",142, 0)
	3538	S DGZPRF= "1^1^"_(I2 -1) K F,I, K,K1,N Q
	3539	"RTN","DGP TFM2",143, 0)
	3540	SED S DR=" .14////"_D GPRD_";.16 ////"_PTF_ ";",(DA,RE C)=+Y,DIE= "^DGCPT(46 ," D GETIN FO^DGPTFM2 1 Q
	3541	"RTN","DGP TFM2",144, 0)
	3542	FMDIE ;Pro mpt user f or questio ns and fil e answers (using DIE )
	3543	"RTN","DGP TFM2",145, 0)
	3544	D ^DIE Q: $D(Y)>9 S RES=$$DEL VFILE^DGAP I1(DFN,PTF ,DGZP) K D IE,REC Q
	3545	"RTN","DGP TFM2",146, 0)
	3546	LOCK() L + ^DGPT(PTF) :2 I Q 1
	3547	"RTN","DGP TFM2",147, 0)
	3548	ERR W !,"C PT Record is being e dited by a nother use r" K DIE,R EC H 2 Q 0
	3549	"RTN","DGP TFM21")
	3550	0^73^B1562 3829^B1557 3212
	3551	"RTN","DGP TFM21",1,0 )
	3552	DGPTFM21 ; ALB/DWS - MASTER PRO FESSIONAL SERVICE EN TER/EDIT(C ONT.) ;5/2 4/05 1:04p m
	3553	"RTN","DGP TFM21",2,0 )
	3554	;;5.3;Reg istration; *635,914 *;Aug 13, 1993;Build 173
	3555	"RTN","DGP TFM21",3,0 )
	3556	GETINFO ;G ET PROCEDU RE CODE IN FORMATION
	3557	"RTN","DGP TFM21",4,0 )
	3558	N NOKILL, EXITFLAG,D GNIEN
	3559	"RTN","DGP TFM21",5,0 )
	3560	S NOKILL= 1,EXITFLG= 0,ERRFLG=0 ,DGDIAG=0
	3561	"RTN","DGP TFM21",6,0 )
	3562	D ICDINFO ^DGAPI(DFN ,PTF) ;ga ther all D GN codes f or the pat ient
	3563	"RTN","DGP TFM21",7,0 )
	3564	D XREF S DIE="^DGCP T(46,"
	3565	"RTN","DGP TFM21",8,0 )
	3566	D SDR,FMD IE^DGPTFM2 ;prompt for CPT Co de and mod ifiers
	3567	"RTN","DGP TFM21",9,0 )
	3568	I $D(Y)>9 S DUOUT=1 Q
	3569	"RTN","DGP TFM21",10, 0)
	3570	I $G(ERRF LG)=1 Q ; cannot loc k REC in D GCPT - exi t
	3571	"RTN","DGP TFM21",11, 0)
	3572	S DGDIAG= 1
	3573	"RTN","DGP TFM21",12, 0)
	3574	S DR="" F PIECE=4:1 :7,21:1:24 S:PIECE=2 4 NOKILL=0 D Q:EXIT FLG!$D(DUO UT) ;Go t hru all ex isting DGN 's in DGCP T file
	3575	"RTN","DGP TFM21",13, 0)
	3576	. S DIE=" ^DGCPT(46, " D SDR2(P IECE),FMDI E^DGPTFM2 I $D(Y)>9 S DUOUT=1 Q
	3577	"RTN","DGP TFM21",14, 0)
	3578	. I ('$$C HKDGNS(DA, PIECE))!($ D(Y)>9)!($ D(DTOUT)) S EXITFLG= 1 Q ;Prom pt w/exist ing DGN cd if it exi sts
	3579	"RTN","DGP TFM21",15, 0)
	3580	. S DR="" ,SAVDA=DA, DGNIEN=$P( ^DGCPT(46, DA,0),U,$S (PIECE<20: PIECE,1:PI ECE-6)) Q: DGNIEN=""
	3581	"RTN","DGP TFM21",16, 0)
	3582	. I '$D(X REF(DGNIEN )) D ;the IEN to be added has not yet b een define d in DGICD 9, it must be added before pro ceeding
	3583	"RTN","DGP TFM21",17, 0)
	3584	. . K DO S DIC="^DG ICD9(46.1, ",DIC(0)=" LMZ",DLAYG O=46,X=DGN IEN
	3585	"RTN","DGP TFM21",18, 0)
	3586	. . D FIL E^DICN Q:$ D(DUOUT) I Y<0 S ER RFLG=1
	3587	"RTN","DGP TFM21",19, 0)
	3588	. . I 'ER RFLG S XRE F(DGNIEN)= +Y ; setup info to b uild "B" x ref in DGI CD9 for ne w entry
	3589	"RTN","DGP TFM21",20, 0)
	3590	. I ERRFL G S EXITFL G=1 Q ;co uld not ad d new DGN ien to DGI CD9 - exit loop with error
	3591	"RTN","DGP TFM21",21, 0)
	3592	. D SCI(D GNIEN):0 S UPDTD=0,( DA,REC)=XR EF(DGNIEN) ;determin e if any S CI prompts should be done for this DGN
	3593	"RTN","DGP TFM21",22, 0)
	3594	. K ^TMP( "PTF",$J) ;Clean up TMP file to pass in fo to be f iled in 46 .1
	3595	"RTN","DGP TFM21",23, 0)
	3596	. S DIE=" ^DGICD9(46 .1,",DR="[ DG801]" ; SCI flags to be stor ed in file 46.1
	3597	"RTN","DGP TFM21",24, 0)
	3598	. ;prompt for SCI y /n and fil e in 46.1
	3599	"RTN","DGP TFM21",25, 0)
	3600	. I DR'=" " D FMDIE^ DGPTFM2 S DR="",UPDT D=1 I $D(Y )>9 S DUOU T=1 Q
	3601	"RTN","DGP TFM21",26, 0)
	3602	. I 'UPDT D D
	3603	"RTN","DGP TFM21",27, 0)
	3604	. . S ^TM P("PTF",$J ,46.1,1)=" ^"_DGNIEN
	3605	"RTN","DGP TFM21",28, 0)
	3606	. . S X=$ $DATA2PTF^ DGAPI(DFN, PTF,DGPRD) ;If there were no S CI's promp ts, stuff DGN into f ile 46.1
	3607	"RTN","DGP TFM21",29, 0)
	3608	. S DA=SA VDA
	3609	"RTN","DGP TFM21",30, 0)
	3610	K DIR,REC
	3611	"RTN","DGP TFM21",31, 0)
	3612	Q ;GETIN FO
	3613	"RTN","DGP TFM21",32, 0)
	3614	XREF ;crea te xref fo r ^TMP glo bal contai ning DGICD 9 info to have acces s via DGN IEN in loc al array X REF
	3615	"RTN","DGP TFM21",33, 0)
	3616	N SEQ,NOD E,INFO,IEN
	3617	"RTN","DGP TFM21",34, 0)
	3618	K XREF
	3619	"RTN","DGP TFM21",35, 0)
	3620	S SEQ=0
	3621	"RTN","DGP TFM21",36, 0)
	3622	F S SEQ= $O(^TMP("P TF",$J,46. 1,SEQ)) Q: 'SEQ S IN FO=^(SEQ), NODE=+INFO ,IEN=$P(IN FO,U,2),XR EF(IEN)=NO DE
	3623	"RTN","DGP TFM21",37, 0)
	3624	Q ;XREF
	3625	"RTN","DGP TFM21",38, 0)
	3626	SDR ;SET D R ARRAY CP T MODIFIER S 1 AND 2
	3627	"RTN","DGP TFM21",39, 0)
	3628	S DR=DR_" S:'$$CODM^ ICPTCOD($P (^DGCPT(46 ,D0,0),U), ,,+DGZPRF( DGZP)) Y=" "@10"";"
	3629	"RTN","DGP TFM21",40, 0)
	3630	S DR=DR_" .02;S:$P(^ DGCPT(46,D 0,0),U,2,3 )?.""^"" Y =""@10"";. 03;@10;.2/ /1;"
	3631	"RTN","DGP TFM21",41, 0)
	3632	Q ;Exit SDR
	3633	"RTN","DGP TFM21",42, 0)
	3634	SDR2(DGN) ;Set up DR var iable to p rompt for DGN Codes
	3635	"RTN","DGP TFM21",43, 0)
	3636	S DR=DGN/ 100_";"
	3637	"RTN","DGP TFM21",44, 0)
	3638	Q ;Exit SDR2
	3639	"RTN","DGP TFM21",45, 0)
	3640	CHKDGNS(D0 ,DGNPC) ;Check to see if there are any more DGN's to e dit in a P rofessiona l service instance
	3641	"RTN","DGP TFM21",46, 0)
	3642	S MORE=1 ; Default - more DGN 's to proc ess
	3643	"RTN","DGP TFM21",47, 0)
	3644	I DGNPC=4 S:$P(^DGC PT(46,D0,0 ),U,4,7)?. "^" MORE=0
	3645	"RTN","DGP TFM21",48, 0)
	3646	I DGNPC=5 S:$P(^DGC PT(46,D0,0 ),U,5,7)?. "^" MORE=0
	3647	"RTN","DGP TFM21",49, 0)
	3648	I DGNPC=6 S:$P(^DGC PT(46,D0,0 ),U,6,7)?. "^" MORE=0
	3649	"RTN","DGP TFM21",50, 0)
	3650	I DGNPC=7 S:$P(^DGC PT(46,D0,0 ),U,7)_$P( ^DGCPT(46, D0,0),U,15 ,18)?."^" MORE=0
	3651	"RTN","DGP TFM21",51, 0)
	3652	I DGNPC=2 1 S:$P(^DG CPT(46,D0, 0),U,15,18 )?."^" MOR E=0
	3653	"RTN","DGP TFM21",52, 0)
	3654	I DGNPC=2 2 S:$P(^DG CPT(46,D0, 0),U,16,18 )?."^" MOR E=0
	3655	"RTN","DGP TFM21",53, 0)
	3656	I DGNPC=2 3 S:$P(^DG CPT(46,D0, 0),U,17,18 )?."^" MOR E=0
	3657	"RTN","DGP TFM21",54, 0)
	3658	I DGNPC=2 4 S:$P(^DG CPT(46,D0, 0),U,18)?. "^" MORE=0
	3659	"RTN","DGP TFM21",55, 0)
	3660	Q MORE ; exit w/fla g
	3661	"RTN","DGP TFM21",56, 0)
	3662	SCI(IEN) Q:'$D(SD CLY) ;Pas s the ien of the DGN code bein g processe d
	3663	"RTN","DGP TFM21",57, 0)
	3664	N NODE,I, SCINUM
	3665	"RTN","DGP TFM21",58, 0)
	3666	; pwc DG* 5.3*914 RS D SPEC# 2. 6.5.2.5 & 2.6.5.2.3. 1 801 & MA S Screen C amp Lejeun e (added # 9 in loop)
	3667	"RTN","DGP TFM21",59, 0)
	3668	F I=2,8,3 :1:7,9 D ;Go thru t he SCI's
	3669	"RTN","DGP TFM21",60, 0)
	3670	. S SCINU M=$S(I=2:I +1,((I=3)! (I=4)):I-2 ,1:I-1)
	3671	"RTN","DGP TFM21",61, 0)
	3672	. I $G(SD CLY(SCINUM ,IEN))=1 Q ;If the SCI has al ready been asked for the DGN ( ien) don't ask again
	3673	"RTN","DGP TFM21",62, 0)
	3674	. S:I=6 D R=DR_"@30; "
	3675	"RTN","DGP TFM21",63, 0)
	3676	. I $D(SD CLY(SCINUM )) S DR=DR _(I/100)_" ;",(DA,D)= $G(XREF(IE N)),SDCLY( SCINUM,IEN )=1 D:I=2& $O(SDCLY(1 ))!$D(SDCL Y(1))!$D(S DCLY(2)) ;add promp t for SCI Y/N
	3677	"RTN","DGP TFM21",64, 0)
	3678	. . I I<6 S DR=DR_" S:$P(^DGIC D9(46.1,DA ,0),U,2) Y =""@30"";"
	3679	"RTN","DGP TFM21",65, 0)
	3680	K I
	3681	"RTN","DGP TFM21",66, 0)
	3682	Q ;SCI
	3683	"RTN","DGP TFM3")
	3684	0^74^B1930 8986^B1791 3974
	3685	"RTN","DGP TFM3",1,0)
	3686	DGPTFM3 ;A LB/ADL - M ASTER CPT RECORD ENT ER/EDIT PA RT 2 ;5/5/ 05 7:35am
	3687	"RTN","DGP TFM3",2,0)
	3688	;;5.3;Reg istration; *517,590, 594,635,69 6,850,914 *;Aug 13, 1993;Build 173
	3689	"RTN","DGP TFM3",3,0)
	3690	REQ ;CHECK FOR REQUI RED FIELDS IN CPT RE CORDS. RE CORDS MISS ING ONE OR MORE REQU IRED FIELD S ARE DELE TED.
	3691	"RTN","DGP TFM3",4,0)
	3692	S RFL=0 G REQQ:'$D( DGZPRF(DGZ P,0))
	3693	"RTN","DGP TFM3",5,0)
	3694	I '$P(^DG PT(PTF,"C" ,DGZPRF(DG ZP,0),0),U ,3) S DA(1 )=PTF,DA=D GPSM,DIK=" ^DGPT("_PT F_",""C"", " D G REQ Q
	3695	"RTN","DGP TFM3",6,0)
	3696	.D ^DIK K DA W !!," No CPT rec ord has be en filed b ecause no performing provider was specif ied." S RF L=1
	3697	"RTN","DGP TFM3",7,0)
	3698	S (I,FCPT )=0 D RESE Q(PTF)
	3699	"RTN","DGP TFM3",8,0)
	3700	F J=1:1 S I=$O(^DGC PT(46,"C", PTF,I)) Q: 'I D:+^DG CPT(46,I,1 )=+DGZPRF( DGZP)&'$G( ^(9))
	3701	"RTN","DGP TFM3",9,0)
	3702	.I $P(^DG CPT(46,I,0 ),U,4) S F CPT=1 Q
	3703	"RTN","DGP TFM3",10,0 )
	3704	.S DA=I,D IK="^DGCPT (46,",CPT= +^DGCPT(46 ,I,0) D ^D IK
	3705	"RTN","DGP TFM3",11,0 )
	3706	.W !!,"CP T " S N=$$ CPT^ICPTCO D(CPT,$$GE TDATE^ICDG TDRG(PTF)) W $P(N,U, 2)," ",$P( N,U,3)," n ot filed b ecause no diagnosis 1 was ente red."
	3707	"RTN","DGP TFM3",12,0 )
	3708	.S RFL=1
	3709	"RTN","DGP TFM3",13,0 )
	3710	I FCPT K FCPT,I,J,N G REQQ
	3711	"RTN","DGP TFM3",14,0 )
	3712	S DA(1)=P TF,DA=DGZP RF(DGZP,0) ,DIK="^DGP T("_PTF_", ""C"","
	3713	"RTN","DGP TFM3",15,0 )
	3714	D ^DIK K DA W !!,"N o CPT reco rd has bee n filed be cause no C PT codes w ere filed. " S RFL=1 K FCPT,I,J ,N
	3715	"RTN","DGP TFM3",16,0 )
	3716	REQQ ;D RE SEQ(PTF)
	3717	"RTN","DGP TFM3",17,0 )
	3718	Q ;REQ
	3719	"RTN","DGP TFM3",18,0 )
	3720	RESEQ(PTF) ;A s ubroutine to check i f a DGN in the DGCPT global ha s been del eted and t he other D GN's need
	3721	"RTN","DGP TFM3",19,0 )
	3722	;to be mo ved down i n sequence to fill t he "gap" i n the glob al
	3723	"RTN","DGP TFM3",20,0 )
	3724	N REC,CPT INFO,DGNAR AY
	3725	"RTN","DGP TFM3",21,0 )
	3726	S REC=0
	3727	"RTN","DGP TFM3",22,0 )
	3728	F S REC= $O(^DGCPT( 46,"C",PTF ,REC)) Q:R EC="" K D GNARAY S C PTINFO=^DG CPT(46,REC ,0) D
	3729	"RTN","DGP TFM3",23,0 )
	3730	. F J=4:1 :7,15:1:18 S DGNARAY (J)=$P(CPT INFO,U,J)
	3731	"RTN","DGP TFM3",24,0 )
	3732	. I $$CHK GAP(.DGNAR AY) D RESE QDGN(.CPTI NFO,.DGNAR AY) S ^DGC PT(46,REC, 0)=CPTINFO
	3733	"RTN","DGP TFM3",25,0 )
	3734	Q ;RESEQ
	3735	"RTN","DGP TFM3",26,0 )
	3736	CHKGAP(DGN ARAY) ;Fun ction call to determ ine if an inside DGN code has been delet ed
	3737	"RTN","DGP TFM3",27,0 )
	3738	;Back up in the DGN ARAY array until a n on-null DG N ien is f ound, then continuin g backward s,
	3739	"RTN","DGP TFM3",28,0 )
	3740	;if a nul l ien is l ocated, th at means t hat an "in side" DGN was delete d
	3741	"RTN","DGP TFM3",29,0 )
	3742	S SEQ=999 ,END=1,MIS SING=0
	3743	"RTN","DGP TFM3",30,0 )
	3744	F S SEQ= $O(DGNARAY (SEQ),-1) Q:SEQ=""!M ISSING D
	3745	"RTN","DGP TFM3",31,0 )
	3746	. I DGNAR AY(SEQ)'=" " S END=1 Q
	3747	"RTN","DGP TFM3",32,0 )
	3748	. I DGNAR AY(SEQ)="" ,END=1 S M ISSING=1
	3749	"RTN","DGP TFM3",33,0 )
	3750	Q MISSING
	3751	"RTN","DGP TFM3",34,0 )
	3752	;
	3753	"RTN","DGP TFM3",35,0 )
	3754	RESEQDGN(C PTINFO,DGN ARAY) ;Subrout ine to shi ft down DG N codes to replace a ny inside DGN's that were dele ted by the user
	3755	"RTN","DGP TFM3",36,0 )
	3756	;
	3757	"RTN","DGP TFM3",37,0 )
	3758	N I
	3759	"RTN","DGP TFM3",38,0 )
	3760	S SEQ="" K NOTNULL
	3761	"RTN","DGP TFM3",39,0 )
	3762	F S SEQ= $O(DGNARAY (SEQ)) Q:S EQ="" I D GNARAY(SEQ )'="" S NO TNULL(SEQ) =DGNARAY(S EQ)
	3763	"RTN","DGP TFM3",40,0 )
	3764	K DGNARAY S SEQ=""
	3765	"RTN","DGP TFM3",41,0 )
	3766	F I=4:1:7 ,15:1:18 S DGNARAY(I )=""
	3767	"RTN","DGP TFM3",42,0 )
	3768	F I=4:1:7 ,15:1:18 S SEQ=$O(NO TNULL(SEQ) ) Q:SEQ="" S DGNARA Y(I)=NOTNU LL(SEQ)
	3769	"RTN","DGP TFM3",43,0 )
	3770	F I=4:1:7 ,15:1:18 S $P(CPTINF O,U,I)=$G( DGNARAY(I) )
	3771	"RTN","DGP TFM3",44,0 )
	3772	K NOTNULL
	3773	"RTN","DGP TFM3",45,0 )
	3774	Q ;RESEQ DGN
	3775	"RTN","DGP TFM3",46,0 )
	3776	PF S PTF=D 0,DFN=+^DG PT(D0,0) D MOB^DGPTF M2 S PS2=0 ,J=+DGZPRF
	3777	"RTN","DGP TFM3",47,0 )
	3778	G END:'$P (DGZPRF,U, 3)
	3779	"RTN","DGP TFM3",48,0 )
	3780	LOOP S Y=+ DGZPRF(J), DGSTRT=$S( +$P(DGZPRF ,U,4):$P(D GZPRF,U,4) ,1:4),DGLS T=0
	3781	"RTN","DGP TFM3",49,0 )
	3782	D CL^SDCO 21(DFN,+DG ZPRF(J),"" ,.SDCLY),I CDINFO^DGA PI(DFN,PTF ),XREF^DGP TFM21 ; lo ad SCI inf o and DGN' s for this service d ate
	3783	"RTN","DGP TFM3",50,0 )
	3784	I $$GETCL ^DGUTL3(DF N)=1,'$G(S DCLY(9)) S SDCLY(9)= "" ; set CLV array if SD pat ch is not released y et and vet eran is CL V eligible DG5.39 14
	3785	"RTN","DGP TFM3",51,0 )
	3786	D D^DGPTU TL W !,J," -CPT Captu re Date/Ti me: ",Y W: ($P(DGZPRF ,U,2)-1!($ G(PGBRK))) " (cont.) "
	3787	"RTN","DGP TFM3",52,0 )
	3788	I $P(DGZP RF(J),U,2) W !,?5,"R eferring o r Ordering Provider: " S L=$P( DGZPRF(J), U,2) D PRV ^DGPTFM
	3789	"RTN","DGP TFM3",53,0 )
	3790	W !,?5,"R endering P rovider: " S L=$P(DG ZPRF(J),U, 3) D PRV^D GPTFM
	3791	"RTN","DGP TFM3",54,0 )
	3792	I $P(DGZP RF(J),U,5) W !,?5,"R endering L ocation: " ,$P($G(^SC ($P(DGZPRF (J),U,5),0 )),U)
	3793	"RTN","DGP TFM3",55,0 )
	3794	S (L1,PGB RK)=0
	3795	"RTN","DGP TFM3",56,0 )
	3796	N EFFDATE ,IMPDATE
	3797	"RTN","DGP TFM3",57,0 )
	3798	D EFFDATE ^DGPTIC10( PTF)
	3799	"RTN","DGP TFM3",58,0 )
	3800	N ICDLABE L S ICDLAB EL=$$GETLA BEL^DGPTIC 10(DGPTDAT ,"P")
	3801	"RTN","DGP TFM3",59,0 )
	3802	F K1=$P(D GZPRF,U,2) :1 Q:'$D(D GZPRF(J,K1 )) I '$G( DGZPRF(J,K 1,9)) D Q :$Y+$G(DGZ PRF(J,K1+1 ,1))>16!($ G(PGBRK))
	3803	"RTN","DGP TFM3",60,0 )
	3804	. S PS2=P S2+1,K=K1 W !,?2,PS2 ," " D CPT ^DGPTUTL1
	3805	"RTN","DGP TFM3",61,0 )
	3806	. W !,?4 S $P(DS,"- ",21)="" W DS," Rela ted Diagno sis",ICDLA BEL," ",DS
	3807	"RTN","DGP TFM3",62,0 )
	3808	. F L1=DG STRT:1:11 S DGLOC=$S (L1<8:L1,1 :L1+7),CD= $P(DGZPRF( J,K1),U,DG LOC) I CD D I $Y+$G (CKSCI)>16 S PGBRK=1 Q
	3809	"RTN","DGP TFM3",63,0 )
	3810	. . S N=$ $ICDDATA^I CDXCODE("D IAG",CD,EF FDATE) ;,N =$S(N:$P(N ,U,2,99),1 :"")
	3811	"RTN","DGP TFM3",64,0 )
	3812	. . S CD= $P(N,U) D WRITECOD^D GPTIC10("D IAG",CD,EF FDATE,1,1, 8) W $S(+N <1!('$P(N, U,10)):"*" ,1:"")
	3813	"RTN","DGP TFM3",65,0 )
	3814	. . D CKS CI^DGPTFM( $P(DGZPRF( J,K1),U,DG LOC))
	3815	"RTN","DGP TFM3",66,0 )
	3816	. S PS2(P S2)=J_U_K1 ,CD=1,DGLO C=0,DGSTRT =4
	3817	"RTN","DGP TFM3",67,0 )
	3818	I L1'=11, $S(L1<8:$P ($G(DGZPRF (J,K1)),U, L1+1,7),1: "")_$P($G( DGZPRF(J,K 1)),U,$S(L 1<8:15,1:L 1+8),18)?. "^" S L1=1 1
	3819	"RTN","DGP TFM3",68,0 )
	3820	I L1=11 S $P(DGZPRF ,U,1,2)=$S ($D(DGZPRF (J,K1+1)): J_U_(K1+1) ,1:J+1_U_1 ),$P(DGZPR F,U,4)="", PGBRK=0
	3821	"RTN","DGP TFM3",69,0 )
	3822	E S $P(D GZPRF,U,1, 2)=J_U_K1, $P(DGZPRF, U,4)=L1+1
	3823	"RTN","DGP TFM3",70,0 )
	3824	S J=+DGZP RF I $D(DG ZPRF(J)) D HEAD^DGPT FMO G LOOP
	3825	"RTN","DGP TFM3",71,0 )
	3826	END I $E(I OST)="C" W ! S DIR(0 )="E" D ^D IR K DIR
	3827	"RTN","DGP TFM3",72,0 )
	3828	K I,K1,L1 ,CD,N Q
	3829	"RTN","DGP TFM4")
	3830	0^19^B4925 3177^B3574 8755
	3831	"RTN","DGP TFM4",1,0)
	3832	DGPTFM4 ;A LB/MTC/ADL /PLT - PTF ENTRY/EDI T-2 ; 05 F eb 2019 9 :56 AM
	3833	"RTN","DGP TFM4",2,0)
	3834	;;5.3;Reg istration; 114,195, 397,510,56 5,775,664, 759,850,88 4,914;Au g 13, 1993 ;Build 173
	3835	"RTN","DGP TFM4",3,0)
	3836	;;Per VA Directive 6402, this routine s hould not be modifie d.
	3837	"RTN","DGP TFM4",4,0)
	3838	;
	3839	"RTN","DGP TFM4",5,0)
	3840	;;ADL;Upd ate for CS V Project; ;Mar 26, 2 003
	3841	"RTN","DGP TFM4",6,0)
	3842	;
	3843	"RTN","DGP TFM4",7,0)
	3844	S DGZM0=D GZM0+1
	3845	"RTN","DGP TFM4",8,0)
	3846	EN ;
	3847	"RTN","DGP TFM4",9,0)
	3848	N M3,M82, DGMPOA
	3849	"RTN","DGP TFM4",10,0 )
	3850	D MOB:'$D (M)
	3851	"RTN","DGP TFM4",11,0 )
	3852	S M(DGZM0 )=$S($D(M( DGZM0)):M( DGZM0),1:" ") G NEXM: M(DGZM0)=" "
	3853	"RTN","DGP TFM4",12,0 )
	3854	;CLT, Cha nge +M(DGZ M0) to DGZ M0 on next line ;DG* 5.3*914
	3855	"RTN","DGP TFM4",13,0 )
	3856	S (M3,M(D GZM0),M1)= $S($D(^DGP T(PTF,"M", DGZM0,0)): ^DGPT(PTF, "M",DGZM0, 0),1:"")
	3857	"RTN","DGP TFM4",14,0 )
	3858	S M82=$G( ^DGPT(PTF, "M",+M(DGZ M0),82))
	3859	"RTN","DGP TFM4",15,0 )
	3860	I $D(^DGP T(PTF,"M", +M(DGZM0), "P")) S $P (M(DGZM0), U,20)=^("P "),$P(M1,U ,20)=^("P" )
	3861	"RTN","DGP TFM4",16,0 )
	3862	WR S DG300 =$S($D(^DG PT(PTF,"M" ,+M(DGZM0) ,300)):^(3 00),1:"")
	3863	"RTN","DGP TFM4",17,0 )
	3864	W @IOF,HE AD,?70 S Z ="<501-"_D GZM0_">" D Z^DGPTFM I +M(DGZM0 )=1 W !,?6 2,"Dischar ge Movemen t"
	3865	"RTN","DGP TFM4",18,0 )
	3866	M S L=+$P( M1,U,10),Y =L D D^DGP TUTL W !! S Z=1 D Z W "Date of Move: " S Z=Y,Z1=20 D Z1 W "L osing Spec ialty: ",$ E($S($D(^D IC(42.4,+$ P(M1,U,2), 0)):$P(^(0 ),U,1),1:" "),1,25)
	3867	"RTN","DGP TFM4",19,0 )
	3868	W !," Leave day s: ",$P(M1 ,U,3),?44, "Pass days : ",$P(M1, U,4)
	3869	"RTN","DGP TFM4",20,0 )
	3870	W !,"Trea ted for SC Condition : ",$S($P( M3,U,18)=" Y":"Yes",1 :"No")
	3871	"RTN","DGP TFM4",21,0 )
	3872	N NL S NL =0
	3873	"RTN","DGP TFM4",22,0 )
	3874	I $P(M3,U ,31)'="" W @($S(NL#2 :"!",1:"?3 7")),"Pote ntially Re lated to C ombat: ",$ S($P(M3,U, 31)="Y":"Y es",1:"No" ) S NL=NL+ 1
	3875	"RTN","DGP TFM4",23,0 )
	3876	I $P(M3,U ,26)'="" W @($S(NL#2 :"!",1:"?3 7")),"Trea ted for AO Condition : ",$S($P( M3,U,26)=" Y":"Yes",1 :"No") S N L=NL+1
	3877	"RTN","DGP TFM4",24,0 )
	3878	I $P(M3,U ,27)'="" W @($S(NL#2 :"!",1:"?3 7")),"Trea ted for IR Condition : ",$S($P( M3,U,27)=" Y":"Yes",1 :"No") S N L=NL+1
	3879	"RTN","DGP TFM4",25,0 )
	3880	I $P(M3,U ,28)'="" W @($S(NL#2 :"!",1:"?3 7")),"Trea ted for se rvice in S W Asia: ", $S($P(M3,U ,28)="Y":" Yes",1:"No ") S NL=NL +1
	3881	"RTN","DGP TFM4",26,0 )
	3882	I $P(M3,U ,29)'="" W @($S(NL#2 :"!",1:"?3 7")),"Trea ted for MS T Conditio n: ",$S($P (M3,U,29)= "Y":"Yes", 1:"No") S NL=NL+1
	3883	"RTN","DGP TFM4",27,0 )
	3884	K DGNTARR
	3885	"RTN","DGP TFM4",28,0 )
	3886	S DGNTARR =$$GETCUR^ DGNTAPI(DF N,"DGNTARR ")
	3887	"RTN","DGP TFM4",29,0 )
	3888	I $P(M3,U ,30)="",(" ,3,4,5,"[( ","_$P($G( DGNTARR("S TAT")),U)_ ",")) S $P (M3,U,30)= "N"
	3889	"RTN","DGP TFM4",30,0 )
	3890	I $P(M3,U ,30)'="" W @($S(NL#2 :"!",1:"?3 7")),"Trea ted for HE AD/NECK CA Condition : ",$S($P( M3,U,30)=" Y":"Yes",1 :"No") S N L=NL+1
	3891	"RTN","DGP TFM4",31,0 )
	3892	I $P(M3,U ,32)'="" W @($S(NL#2 :"!",1:"?3 7")),"Trea ted for Pr oject 112/ SHAD: ",$S ($P(M3,U,3 2)="Y":"Ye s",1:"No") S NL=NL+1
	3893	"RTN","DGP TFM4",32,0 )
	3894	; pwc DG* 5.3*914 RS D SPEC# 2. 6.6.2.3 50 1 Screen C amp Lejeun e, also ad ded NL=NL+ 1 above
	3895	"RTN","DGP TFM4",33,0 )
	3896	;CLT, Cha nged Camp Lejeune da ta to come from prev ious movem ent in DGP T
	3897	"RTN","DGP TFM4",34,0 )
	3898	;global. ;DG5.39 14
	3899	"RTN","DGP TFM4",35,0 )
	3900	N DGCLVEL G,DGLAST,D GPMV,DGNDE
	3901	"RTN","DGP TFM4",36,0 )
	3902	S DGCLVEL G=$$GETCL^ DGUTL3(DFN )
	3903	"RTN","DGP TFM4",37,0 )
	3904	I DGZM0=1 ,DGCLVELG= 1 D
	3905	"RTN","DGP TFM4",38,0 )
	3906	.I $D(^XT MP("DGPTF" ,$J,"T",2, DGZM0)) S MCLV=^XTMP ("DGPTF",$ J,"T",2,DG ZM0),$P(^D GPT(PTF,"M ",DGZM0,0) ,U,33)=MCL V
	3907	"RTN","DGP TFM4",39,0 )
	3908	.W @($S(N L#2:"!",1: "?37")),"T reated for Camp Leje une: ",$S( $P(^DGPT(P TF,"M",1,0 ),U,33)="Y ":"Yes",1: "No")
	3909	"RTN","DGP TFM4",40,0 )
	3910	I DGZM0=2 ,DGCLVELG= 1 D
	3911	"RTN","DGP TFM4",41,0 )
	3912	.S DGPMV= $O(^DGPM(" APTF",PTF, ""))
	3913	"RTN","DGP TFM4",42,0 )
	3914	.I '$D(^X TMP("DGPTF ",$J,"T",2 ,DGZM0)) S MCLV=$P(^ DGPM(DGPMV ,0),U,29), $P(^DGPT(P TF,"M",2,0 ),U,33)=$P (^DGPM(DGP MV,0),U,29 )
	3915	"RTN","DGP TFM4",43,0 )
	3916	.I $D(^XT MP("DGPTF" ,$J,"T",2, DGZM0)) S MCLV=^XTMP ("DGPTF",$ J,"T",2,DG ZM0),$P(^D GPT(PTF,"M ",DGZM0,0) ,U,33)=MCL V
	3917	"RTN","DGP TFM4",44,0 )
	3918	.W @($S(N L#2:"!",1: "?37")),"T reated for Camp Leje une: ",$S( MCLV="Y":" Yes",1:"No ")
	3919	"RTN","DGP TFM4",45,0 )
	3920	I DGZM0>2 ,DGCLVELG= 1 D
	3921	"RTN","DGP TFM4",46,0 )
	3922	. I $D(^X TMP("DGPTF ",$J,"T",2 ,DGZM0)) S MCLV=^XTM P("DGPTF", $J,"T",2,D GZM0),$P(^ DGPT(PTF," M",DGZM0,0 ),U,33)=MC LV
	3923	"RTN","DGP TFM4",47,0 )
	3924	. S DGNDE ="" F S D GNDE=$O(^T MP($J,"DGP TF",DGNDE) ) Q:DGNDE= "" D
	3925	"RTN","DGP TFM4",48,0 )
	3926	. . I DGN DE=DGZM0 S MCLV=^TMP ($J,"DGPTF ",DGNDE) S $P(^DGPT( PTF,"M",DG NDE,0),U,3 3)=MCLV
	3927	"RTN","DGP TFM4",49,0 )
	3928	. I '$D(^ XTMP("DGPT F",$J,"T", 2,DGZM0)) S DGLAST=$ P(^DGPT(PT F,"M",0),U ,3) I DGZM 0=DGLAST,$ G(^TMP($J, "DGPTF"))' ="" S MCLV =$G(^TMP($ J,"DGPTF") ),$P(^DGPT (PTF,"M",D GLAST,0),U ,33)=MCLV
	3929	"RTN","DGP TFM4",50,0 )
	3930	. I $D(^X TMP("DGPTF ",$J,"T",2 ,DGZM0)) S MCLV=$G(^ XTMP("DGPT F",$J,"T", 2,DGZM0)), $P(^DGPT(P TF,"M",DGZ M0,0),U,33 )=MCLV
	3931	"RTN","DGP TFM4",51,0 )
	3932	. I $G(MC LV)'="" W @($S(NL#2: "!",1:"?37 ")),"Treat ed for Cam p Lejeune: ",$S(MCLV ="Y":"Yes" ,1:"No") K ^XTMP("D GPTF"),MCL V
	3933	"RTN","DGP TFM4",52,0 )
	3934	K NL
	3935	"RTN","DGP TFM4",53,0 )
	3936	N EFFDATE ,IMPDATE
	3937	"RTN","DGP TFM4",54,0 )
	3938	D EFFDATE ^DGPTIC10( PTF)
	3939	"RTN","DGP TFM4",55,0 )
	3940	W !! S Z= 2 D Z W " D X: ",$$GET LABEL^DGPT IC10(EFFDA TE,"D")
	3941	"RTN","DGP TFM4",56,0 )
	3942	;F I=1:1: 11 S L=$P( M1,U,I+4) I L'=""&(I '=6) D
	3943	"RTN","DGP TFM4",57,0 )
	3944	D PTFICD^ DGPTFUT(50 1,PTF,+M(D GZM0),.DGX 501)
	3945	"RTN","DGP TFM4",58,0 )
	3946	S I=0 F S I=$O(DGX 501(I)) QU IT:'I S L =DGX501(I) D
	3947	"RTN","DGP TFM4",59,0 )
	3948	. S DGMPO A=$P(L,U,2 )
	3949	"RTN","DGP TFM4",60,0 )
	3950	. S DGPTT MP=$$ICDDA TA^ICDXCOD E("DIAG",+ L,EFFDATE)
	3951	"RTN","DGP TFM4",61,0 )
	3952	. D WRITE COD^DGPTIC 10("DIAG", +L,EFFDATE ,2,1,15)
	3953	"RTN","DGP TFM4",62,0 )
	3954	. I $P(DG PTTMP,U,20 )=30 W:$X> 73 !," " W " (POA=" ,$S(DGMPOA ]"":DGMPOA ,1:"''")," )"
	3955	"RTN","DGP TFM4",63,0 )
	3956	. W $S(+D GPTTMP<1!( '$P(DGPTTM P,U,10)):" *",1:"")
	3957	"RTN","DGP TFM4",64,0 )
	3958	. I $Y>(I OSL-4) D P GBR W @IOF ,HEAD,?72 S Z="<501- "_DGZM0_"> " D Z^DGPT FM W !
	3959	"RTN","DGP TFM4",65,0 )
	3960	. QUIT
	3961	"RTN","DGP TFM4",66,0 )
	3962	K DGX501
	3963	"RTN","DGP TFM4",67,0 )
	3964	D PRN2^DG PTFM8:DG30 0]""
	3965	"RTN","DGP TFM4",68,0 )
	3966	;
	3967	"RTN","DGP TFM4",69,0 )
	3968	I $P(M1,U ,20) S DRG =$P(M1,U,2 0) W:DRG=9 98!(DRG=99 9)!((DRG=4 68!(DRG=46 9)!(DRG=47 0))&(+$P($ G(M1),U,10 )<3071001) ) *7 W !!? 14,"TRANSF ER DRG: ", DRG D
	3969	"RTN","DGP TFM4",70,0 )
	3970	. N DXD,D GDX
	3971	"RTN","DGP TFM4",71,0 )
	3972	. S DXD=$ $DRGD^ICDG TDRG(DRG," DGDX",,$P( M1,U,10)), DGDS=0
	3973	"RTN","DGP TFM4",72,0 )
	3974	. F S DG DS=$O(DGDX (DGDS)) Q: '+DGDS Q: DGDX(DGDS) =" " W !, DGDX(DGDS)
	3975	"RTN","DGP TFM4",73,0 )
	3976	JUMP K DG3 00 F I=$Y: 1:21 W !
	3977	"RTN","DGP TFM4",74,0 )
	3978	X S DGNUM= $S($D(M(DG ZM0+1)):50 1_"-"_(DGZ M0+1),1:"M AS") G 501 ^DGPTFJC:D GST
	3979	"RTN","DGP TFM4",75,0 )
	3980	W "Enter <RET> to c ontinue, 1 -2 to edit ,",!,"'M' ",$S(DGPTF E:" to add a patient movement" ,1:"to edi t Treat. S pecialty") ,", '^N' f or screen N, or '^' to abort:< ",DGNUM,"> // " R X:D TIME
	3981	"RTN","DGP TFM4",76,0 )
	3982	K DGNUM G Q:X="^",N EXM:X="",^ DGPTFJ:X?1 "^".E,M^DG PTFM1:X="M "!(X="m")
	3983	"RTN","DGP TFM4",77,0 )
	3984	X1 I X'=1, X'=2,X'="1 -2" G PR
	3985	"RTN","DGP TFM4",78,0 )
	3986	S DGCODSY S=$$CODESY S^DGPTIC10 (PTF)
	3987	"RTN","DGP TFM4",79,0 )
	3988	S DR=$S(D GPTFE:"[DG 501F-10D]" ,1:"[DG501 -10D]") I DGCODSYS=" ICD9" S DR =$S(DGPTFE :"[DG501F] ",1:"[DG50 1]")
	3989	"RTN","DGP TFM4",80,0 )
	3990	S DGJUMP= X,DIE="^DG PT(",(DA,D GPTF)=PTF, DGMOV=+M(D GZM0) D ^D IE
	3991	"RTN","DGP TFM4",81,0 )
	3992	I DR'["-1 0D" K DR,D A,DIE,DIC S DR="" X: (+M(DGZM0) =1) "S J=^ DGPT(PTF," "M"",1,0) F I=11:1:1 5 I $P(J,U ,I) S DR=D R_I_"";""" I DR'="" D
	3993	"RTN","DGP TFM4",82,0 )
	3994	. S DGJUM P=X,DIE="^ DGPT("_DGP TF_",""M"" ,",(DA(1), DGPTF)=PTF ,(DA,DGMOV )=+M(DGZM0 )
	3995	"RTN","DGP TFM4",83,0 )
	3996	. D ^DIE
	3997	"RTN","DGP TFM4",84,0 )
	3998	. QUIT
	3999	"RTN","DGP TFM4",85,0 )
	4000	K M,DR,DI E D CHK501 ^DGPTSCAN K DGPTF,DG MOV
	4001	"RTN","DGP TFM4",86,0 )
	4002	; Determi ne if NTR HISTORY (# 28.11) fil er is call ed if ques tion for
	4003	"RTN","DGP TFM4",87,0 )
	4004	; 'Treat ed for Hea d/Neck CA Condition: ' is answe red YES.
	4005	"RTN","DGP TFM4",88,0 )
	4006	; Only a NTR screen ing status of 3=PEND ING DIAGNO SIS gets F iled.
	4007	"RTN","DGP TFM4",89,0 )
	4008	I $P($G(M 3),U,30)=" Y",$P($G(D GNTARR("ST AT")),U)=3 D
	4009	"RTN","DGP TFM4",90,0 )
	4010	. S DGNTA RR=$$FILEH NC^DGNTAPI 1(DFN)
	4011	"RTN","DGP TFM4",91,0 )
	4012	. QUIT
	4013	"RTN","DGP TFM4",92,0 )
	4014	K DGNTARR
	4015	"RTN","DGP TFM4",93,0 )
	4016	;- update MT indica tor after edit movem ent
	4017	"RTN","DGP TFM4",94,0 )
	4018	N DGPMCA, DGPMAN D P M^DGPTUTL
	4019	"RTN","DGP TFM4",95,0 )
	4020	I '$G(DGA DM) S DGAD M=+^DGPT(P TF,0)
	4021	"RTN","DGP TFM4",96,0 )
	4022	D MT^DGPT UTL
	4023	"RTN","DGP TFM4",97,0 )
	4024	G EN
	4025	"RTN","DGP TFM4",98,0 )
	4026	;
	4027	"RTN","DGP TFM4",99,0 )
	4028	PR W !,"En ter '^' to stop the display an d edit of data",!,"' ^N' to jum p to scree n #N (appe ars in upp er right o f screen ' <N>'",!,"< RET> to co ntinue on to the nex t screen o r 1-2 to e dit:"
	4029	"RTN","DGP TFM4",100, 0)
	4030	W !?10,"1 -",$S(DGPT FE:"Date o f movement , Losing S pecialty, ",1:""),"L eave and P ass days", !?10,"2-IC D DIAGNOSI S CODES"
	4031	"RTN","DGP TFM4",101, 0)
	4032	W !,"You may also e nter 1-2", !
	4033	"RTN","DGP TFM4",102, 0)
	4034	R !!,"Ent er <RET>: ",X:DTIME G WR
	4035	"RTN","DGP TFM4",103, 0)
	4036	Q
	4037	"RTN","DGP TFM4",104, 0)
	4038	NEXM S DGZ M0=DGZM0+1 G ^DGPTFM :'$D(M(DGZ M0)),EN
	4039	"RTN","DGP TFM4",105, 0)
	4040	;
	4041	"RTN","DGP TFM4",106, 0)
	4042	ADD ;add m ovement re cord of fe e basis pa tent
	4043	"RTN","DGP TFM4",107, 0)
	4044	S DGZM0=$ S($D(DGZM0 ):DGZM0+1, 1:0) S L=$ S($D(^DGPT (PTF,"M",0 )):^(0),1: "^45.02DA^ ^"),L1=$P( L,U,3) F I =1:1 Q:'$D (^DGPT(PTF ,"M",L1+I) )
	4045	"RTN","DGP TFM4",108, 0)
	4046	S DA(1)=P TF,DIC="^D GPT("_DA(1 )_",""M"", ",X=L1+I,D IC(0)="LMZ QE" D ^DIC K DIC,DIE G ^DGPTFM :Y'>0
	4047	"RTN","DGP TFM4",109, 0)
	4048	S M(DGZM0 )=L1+I S X ="1-2" G X 1
	4049	"RTN","DGP TFM4",110, 0)
	4050	Q
	4051	"RTN","DGP TFM4",111, 0)
	4052	MOB S I=0 K M,M1,M2 S M2=0 F I 1=1:1 S I= $O(^DGPT(P TF,"M",I)) Q:'I S M (I1)=^(I,0 )
	4053	"RTN","DGP TFM4",112, 0)
	4054	S PM=I1-1 D ORDER^D GPTF Q
	4055	"RTN","DGP TFM4",113, 0)
	4056	Q G Q^DGPT F
	4057	"RTN","DGP TFM4",114, 0)
	4058	Z I 'DGN S Z=$S(IOST ="C-QUME"& ($L(DGVI)' =2):Z,1:"[ "_Z_"]") W @DGVI,Z,@ DGVO
	4059	"RTN","DGP TFM4",115, 0)
	4060	E W " "
	4061	"RTN","DGP TFM4",116, 0)
	4062	Q
	4063	"RTN","DGP TFM4",117, 0)
	4064	Z1 F I=1:1 :(Z1-$L(Z) ) S Z=Z_" "
	4065	"RTN","DGP TFM4",118, 0)
	4066	W Z
	4067	"RTN","DGP TFM4",119, 0)
	4068	Q
	4069	"RTN","DGP TFM4",120, 0)
	4070	R ;DELETE PROCEDURE RECORD
	4071	"RTN","DGP TFM4",121, 0)
	4072	K ^TMP($J ,"DGPTF")
	4073	"RTN","DGP TFM4",122, 0)
	4074	I '$D(^DG PT(PTF,"P" )) G NOPRO C
	4075	"RTN","DGP TFM4",123, 0)
	4076	I $O(^DGP T(PTF,"P", 0))']"" G NOPROC
	4077	"RTN","DGP TFM4",124, 0)
	4078	S DGPNUM= "" F DGPRO C=0:0 S DG PROC=$O(P( DGPROC)) Q :'DGPROC S:$D(P(DGP ROC,1)) DG PNUM=DGPNU M_","_DGPR OC
	4079	"RTN","DGP TFM4",125, 0)
	4080	S DGPNUM= DGPNUM_","
	4081	"RTN","DGP TFM4",126, 0)
	4082	ASKPRO W ! !,"Delete procedure record <", $P(DGPNUM, ",",2,99), "> : " R D GPROC:DTIM E I DGPROC [U!(DGPROC ="") K DGP NUM,DGPROC G ^DGPTFM
	4083	"RTN","DGP TFM4",127, 0)
	4084	I DGPNUM' [(","_DGPR OC_",") W !!,"Enter the record # to dele te from th e PTF file <",$P(DGP NUM,",",2, 99),">",! G ASKPRO
	4085	"RTN","DGP TFM4",128, 0)
	4086	K DA N DG J
	4087	"RTN","DGP TFM4",129, 0)
	4088	F DGJ=1:1 S DA=+$P( DGPROC,"," ,DGJ) Q:'D A S DA=$S ($D(P(DA,1 )):+P(DA,1 ),1:0) I D A S DA(1)= PTF,DIK="^ DGPT("_PTF _",""P""," D ^DIK K DA W " " ,$P(DGPROC ,",",DGJ), "-DELETED* **" H:'$P( DGPROC,"," ,DGJ+1) 2
	4089	"RTN","DGP TFM4",130, 0)
	4090	K DIK,DA, DGPROC,DGP NUM G ^DGP TFM
	4091	"RTN","DGP TFM4",131, 0)
	4092	NOPROC W ! !,*7,"No p rocedures to delete" ,! H 3 G ^ DGPTFM
	4093	"RTN","DGP TFM4",132, 0)
	4094	Q
	4095	"RTN","DGP TFM4",133, 0)
	4096	;
	4097	"RTN","DGP TFM4",134, 0)
	4098	PGBR N DIR ,X,Y S DIR (0)="E",DI R("A")="En ter RETURN to contin ue" D ^DIR QUIT
	4099	"RTN","DGP TFM4",135, 0)
	4100	;
	4101	"RTN","DGP TFMO")
	4102	0^20^B4515 9824^B4279 9242
	4103	"RTN","DGP TFMO",1,0)
	4104	DGPTFMO ;A LB/JDS/ADL ,HIOFO/FT - DGPTF PR INT TEMPLA TE ; 21 De c 2018 11 :21 AM
	4105	"RTN","DGP TFMO",2,0)
	4106	;;5.3;Reg istration; *195,397, 510,590,59 4,606,683, 729,664,85 0,884,914 *;Aug 13, 1993;Build 173
	4107	"RTN","DGP TFMO",3,0)
	4108	;;ADL;Upd ated for C SV Project ;;Mar 4, 2 003
	4109	"RTN","DGP TFMO",4,0)
	4110	;
	4111	"RTN","DGP TFMO",5,0)
	4112	; ICDEX A PIs - #574 7
	4113	"RTN","DGP TFMO",6,0)
	4114	; ICDGTDR G APIs - # 4052
	4115	"RTN","DGP TFMO",7,0)
	4116	; ICDXCOD E APIs - # 5699
	4117	"RTN","DGP TFMO",8,0)
	4118	;
	4119	"RTN","DGP TFMO",9,0)
	4120	;;ADL;Upd ated for C SV Project ;;Mar 4, 2 003
	4121	"RTN","DGP TFMO",10,0 )
	4122	;FOR PTF REPORT CAL LED FROM P RINT TEMPL ATE DGPTF
	4123	"RTN","DGP TFMO",11,0 )
	4124	;
	4125	"RTN","DGP TFMO",12,0 )
	4126	EN ;called from prin t template DGPT CENS US INQUIRY
	4127	"RTN","DGP TFMO",13,0 )
	4128	K A,B,AD, ADA,DGDD,D GDDPTR,DGL OOP,DGFC,H EAD,DGPTFE ,DGST,DGN, T,T82,DGM8 2,EFFDATE, IMPDATE,DG PTDAT
	4129	"RTN","DGP TFMO",14,0 )
	4130	F DGLOOP= 4:1:7 D ; get the se t of codes for field s 4,5,6, & 7 in 45.0 1 (401 dat a - Surger y)
	4131	"RTN","DGP TFMO",15,0 )
	4132	.K DGERRO R,DGRESULT
	4133	"RTN","DGP TFMO",16,0 )
	4134	.S DGDDPT R(DGLOOP)= ""
	4135	"RTN","DGP TFMO",17,0 )
	4136	.D FIELD^ DID(45.01, DGLOOP,,"P OINTER","D GRESULT"," DGERROR")
	4137	"RTN","DGP TFMO",18,0 )
	4138	.I '$D(DG ERROR) S D GDDPTR(DGL OOP)=$G(DG RESULT("PO INTER"))
	4139	"RTN","DGP TFMO",19,0 )
	4140	K DGERROR ,DGRESULT
	4141	"RTN","DGP TFMO",20,0 )
	4142	;
	4143	"RTN","DGP TFMO",21,0 )
	4144	F I=0:0 S I=$O(^DGP T(D0,"M",I )) Q:I'>0 I $D(^(I, 0)) S J=+$ P(^(0),U,1 0) S:'J J= 999999999 S:$D(T(J)) J=J+.01*I S T(J)=I
	4145	"RTN","DGP TFMO",22,0 )
	4146	F I=0:0 S I=$O(T(I) ) Q:I'>0 S DGM=$S($ D(^DGPT(D0 ,"M",T(I), 0)):^(0),1 :"") D:DGM ]"" WRITE
	4147	"RTN","DGP TFMO",23,0 )
	4148	;
	4149	"RTN","DGP TFMO",24,0 )
	4150	K T F I=0 :0 S I=$O( ^DGPT(D0," S",I)) Q:I '>0 D SUR
	4151	"RTN","DGP TFMO",25,0 )
	4152	S DGOP1=$ S($D(^DGPT (D0,"401P" )):^("401P "),1:"")
	4153	"RTN","DGP TFMO",26,0 )
	4154	I DGOP1]" " D HEAD:$ Y>(IOSL-10 ) G Q:'DN D PROC
	4155	"RTN","DGP TFMO",27,0 )
	4156	I $D(^DGP T(D0,"P")) D HEAD:$Y >(IOSL-10) G Q:'DN F I=0:0 S I =$O(^DGPT( D0,"P",I)) Q:I'>0 S DG601=^DG PT(D0,"P", I,0),Y=+DG 601 D D^DG PTUTL W !! ?5,"Proced ure Date: ",Y,$$GETL ABEL^DGPTI C10(EFFDAT E,"P") D 6 01
	4157	"RTN","DGP TFMO",28,0 )
	4158	S DGPT=$G (^DGPT(D0, 70)) I DGP T]"" G Q:' DN D DXLS
	4159	"RTN","DGP TFMO",29,0 )
	4160	K %,DGL,D GM,DGPT,DG OP,DGOP1,D GF,DGP,DXL S,DGICD,L1 ,S1,T,J,K, DGPR,DGN,A GE,B,DA,DA M,DFN,DGST ,DOB,DP,DR G,EXP,NO,P ,PTF,DGPTF E,SD1,SEX, TAC,TRS,DG DS,DGTD,DG PROC,DG601 ,DGPTDAT
	4161	"RTN","DGP TFMO",30,0 )
	4162	W !
	4163	"RTN","DGP TFMO",31,0 )
	4164	K T82,DGM 82,DGMPOA, DGLOOP
	4165	"RTN","DGP TFMO",32,0 )
	4166	Q
	4167	"RTN","DGP TFMO",33,0 )
	4168	WRITE D HE AD:$Y>(IOS L-12) G Q: 'DN S Y=$P (DGM,U,10) ,DGL=+$P(D GM,U,2),DG L=$S($D(^D IC(42.4,DG L,0)):^(0) ,1:""),DGL =$P(DGL,U, 1) D D^DGP TUTL
	4169	"RTN","DGP TFMO",34,0 )
	4170	; ICD-10 CALLS
	4171	"RTN","DGP TFMO",35,0 )
	4172	D EFFDATE ^DGPTIC10( D0)
	4173	"RTN","DGP TFMO",36,0 )
	4174	;
	4175	"RTN","DGP TFMO",37,0 )
	4176	W !!,"Mov ement Date : ",Y,?40, "Losing Sp ecialty: " ,$E(DGL,1, 22),!,"Lea ve Days: " ,$P(DGM,U, 3),?40,"Pa ss Days: " ,$P(DGM,U, 4)
	4177	"RTN","DGP TFMO",38,0 )
	4178	W !,"Trea ted for SC condition : ",$S($P( DGM,U,18)= 1:"Yes",1: "No")
	4179	"RTN","DGP TFMO",39,0 )
	4180	W:$P(DGM, U,31)'="" !,"Potenti ally Relat ed to Comb at: ",$S($ P(DGM,U,31 )="Y":"Yes ",1:"No")
	4181	"RTN","DGP TFMO",40,0 )
	4182	W:$P(DGM, U,26)'="" !,"Treated for AO co ndition: " ,$S($P(DGM ,U,26)="Y" :"Yes",1:" No")
	4183	"RTN","DGP TFMO",41,0 )
	4184	W:$P(DGM, U,27)'="" !,"Treated for IR co ndition: " ,$S($P(DGM ,U,27)="Y" :"Yes",1:" No")
	4185	"RTN","DGP TFMO",42,0 )
	4186	W:$P(DGM, U,28)'="" !,"Treated for servi ce in SW A sia: ",$S( $P(DGM,U,2 8)="Y":"Ye s",1:"No")
	4187	"RTN","DGP TFMO",43,0 )
	4188	W:$P(DGM, U,29)'="" !,"Treated for MST c ondition: ",$S($P(DG M,U,29)="Y ":"Yes",$P (DGM,U,29) ="N":"No", 1:"Decline d to answe r") ; adde d 6/17/98 for MST en hancement
	4189	"RTN","DGP TFMO",44,0 )
	4190	W:$P(DGM, U,30)'="" !,"Treated for HEAD/ NECK CA co ndition: " ,$S($P(DGM ,U,30)="Y" :"Yes",1:" No")
	4191	"RTN","DGP TFMO",45,0 )
	4192	W:$P(DGM, U,32)'="" !,"Treated for SHAD Condition: ",$S($P(D GM,U,32)=" Y":"Yes",1 :"No")
	4193	"RTN","DGP TFMO",46,0 )
	4194	; pwc DG* 5.3*914 RS D SPEC# 2. 6.5.2.4 50 1 Screen C amp Lejeun e
	4195	"RTN","DGP TFMO",47,0 )
	4196	W:$P(DGM, U,33)'="" !,"Treated for Camp Lejeune Co ndition: " ,$S($P(DGM ,U,33)="Y" :"Yes",1:" No")
	4197	"RTN","DGP TFMO",48,0 )
	4198	W:T(I)=1 !,"Dischar ge "
	4199	"RTN","DGP TFMO",49,0 )
	4200	S DGF="", J=0 K DG50 1
	4201	"RTN","DGP TFMO",50,0 )
	4202	D PTFICD^ DGPTFUT(50 1,D0,T(I), .DG501,1)
	4203	"RTN","DGP TFMO",51,0 )
	4204	F S J=$O (DG501(J)) Q:'J D
	4205	"RTN","DGP TFMO",52,0 )
	4206	. S DGMPO A=$P(DG501 (J),U,2) ; get POA co de
	4207	"RTN","DGP TFMO",53,0 )
	4208	. S DGPTT MP=$$ICDDA TA^ICDXCOD E("DIAG",+ $P(DG501(J ),U,1),EFF DATE)
	4209	"RTN","DGP TFMO",54,0 )
	4210	. W:DGF=" " !!?5,"DX : ",$$GETL ABEL^DGPTI C10(EFFDAT E,"D")
	4211	"RTN","DGP TFMO",55,0 )
	4212	. D WRITE COD^DGPTIC 10("DIAG", +$P(DG501( J),U,1),EF FDATE,2,1, 8)
	4213	"RTN","DGP TFMO",56,0 )
	4214	. I $P(DG PTTMP,U,20 )=30 W:$X> 73 !," " W " (POA=" ,$S(DGMPOA ]"":DGMPOA ,1:"''")," )"
	4215	"RTN","DGP TFMO",57,0 )
	4216	. W $S(+D GPTTMP<1!( '$P(DGPTTM P,U,10)):" *",1:"")
	4217	"RTN","DGP TFMO",58,0 )
	4218	. S DGF=1
	4219	"RTN","DGP TFMO",59,0 )
	4220	K DG501
	4221	"RTN","DGP TFMO",60,0 )
	4222	;-- displ ay expande d codes
	4223	"RTN","DGP TFMO",61,0 )
	4224	S DG300=$ S($D(^DGPT (D0,"M",T( I),300)):^ (300),1:"" ) I DG300] "" D HEAD: $Y>(IOSL-6 ) D PRN2^D GPTFM8 W !
	4225	"RTN","DGP TFMO",62,0 )
	4226	K DG300
	4227	"RTN","DGP TFMO",63,0 )
	4228	;Display TRANSFER D RG with de scription
	4229	"RTN","DGP TFMO",64,0 )
	4230	Q:'$D(^DG PT(D0,"M", T(I),"P")) S DGTD=+ ^("P") Q:$ P($$CODEC^ ICDEX(80,D GTD),U,1)= "-1" W !? 3,"TRANSFE R DRG: ",D GTD," - "
	4231	"RTN","DGP TFMO",65,0 )
	4232	N DXD,DGD X
	4233	"RTN","DGP TFMO",66,0 )
	4234	S DXD=$$D RGD^ICDGTD RG(DGTD,"D GDX",,$$GE TDATE^ICDG TDRG(D0)), DGDS=0
	4235	"RTN","DGP TFMO",67,0 )
	4236	F S DGDS =$O(DGDX(D GDS)) Q:'+ DGDS Q:DG DX(DGDS)=" " W !,DG DX(DGDS)
	4237	"RTN","DGP TFMO",68,0 )
	4238	Q
	4239	"RTN","DGP TFMO",69,0 )
	4240	HEAD I $E( IOST,1)="C " W *7 R X :DTIME I X =U S DN=0 Q
	4241	"RTN","DGP TFMO",70,0 )
	4242	S DC=DC+1 W @IOF,! X:$D(^UTIL ITY($J,2)) ^(2) W ! F K=1:1:IO M W "_"
	4243	"RTN","DGP TFMO",71,0 )
	4244	W !,"("_$ P(^DPT(+^D GPT(D0,0), 0),U,1)_") ",!
	4245	"RTN","DGP TFMO",72,0 )
	4246	Q
	4247	"RTN","DGP TFMO",73,0 )
	4248	SUR ;
	4249	"RTN","DGP TFMO",74,0 )
	4250	D HEAD:$Y >(IOSL-7) G Q:'DN S S1=^DGPT(D 0,"S",I,0) ,Y=+S1 D D ^DGPTUTL W !!," Da te of Surg : ",Y,?45, "Chief Sur g: "
	4251	"RTN","DGP TFMO",75,0 )
	4252	S L=";"_D GDDPTR(4), L1=";"_$P( S1,U,4)_": " W $P($P( L,L1,2),"; ",1)
	4253	"RTN","DGP TFMO",76,0 )
	4254	W !," Anesth Tec h: " S L=" ;"_DGDDPTR (6),L1=";" _$P(S1,U,6 )_":" W $P ($P(L,L1,2 ),";",1),? 45,"First Asst: "
	4255	"RTN","DGP TFMO",77,0 )
	4256	S L=";"_D GDDPTR(5), L1=";"_$P( S1,U,5)_": " W $P($P( L,L1,2),"; ",1)
	4257	"RTN","DGP TFMO",78,0 )
	4258	W !," So urce of pa y: " S L=" ;"_DGDDPTR (7),L1=";" _$P(S1,U,7 )_":" W $P ($P(L,L1,2 ),";",1)
	4259	"RTN","DGP TFMO",79,0 )
	4260	W ?46,"Su rg spec: " ,$S($D(^DI C(45.3,+$P (S1,U,3),0 )):$P(^(0) ,U,2),1:"" )
	4261	"RTN","DGP TFMO",80,0 )
	4262	W !!,?5," Surg/pro: ",$$GETLAB EL^DGPTIC1 0(EFFDATE, "P"),!?7
	4263	"RTN","DGP TFMO",81,0 )
	4264	S K=0 K D G401
	4265	"RTN","DGP TFMO",82,0 )
	4266	D PTFICD^ DGPTFUT(40 1,D0,I,.DG 401,1)
	4267	"RTN","DGP TFMO",83,0 )
	4268	F S K=$O (DG401(K)) Q:'K D
	4269	"RTN","DGP TFMO",84,0 )
	4270	. S L=$P( DG401(K),U ,1),DGPTTM P=""
	4271	"RTN","DGP TFMO",85,0 )
	4272	. I L'="" S DGPTTMP =$$ICDDATA ^ICDXCODE( "PROC",+L, EFFDATE) D
	4273	"RTN","DGP TFMO",86,0 )
	4274	.. D WRIT ECOD^DGPTI C10("PROC" ,+L,EFFDAT E,2,1,8)
	4275	"RTN","DGP TFMO",87,0 )
	4276	.. W $S(+ DGPTTMP<1! ('$P(DGPTT MP,U,10)): "*",1:"")
	4277	"RTN","DGP TFMO",88,0 )
	4278	K DG401
	4279	"RTN","DGP TFMO",89,0 )
	4280	;-- displ ay expande d codes
	4281	"RTN","DGP TFMO",90,0 )
	4282	S DG300=$ S($D(^DGPT (D0,"S",I, 300)):^(30 0),1:"") I DG300]"" D PRN3^DGP TFM8
	4283	"RTN","DGP TFMO",91,0 )
	4284	K DG300
	4285	"RTN","DGP TFMO",92,0 )
	4286	Q
	4287	"RTN","DGP TFMO",93,0 )
	4288	PROC ;
	4289	"RTN","DGP TFMO",94,0 )
	4290	S DGF="" F I=1:1:5 D:$P(DGOP1 ,U,I)'=""
	4291	"RTN","DGP TFMO",95,0 )
	4292	. S DGPTT MP=$$ICDDA TA^ICDXCOD E("PROC",+ $P(DGOP1,U ,I),EFFDAT E)
	4293	"RTN","DGP TFMO",96,0 )
	4294	. W:'DGF !!?5,"Proc edure: ",$ $GETLABEL^ DGPTIC10(E FFDATE,"P" ) S DGF=1
	4295	"RTN","DGP TFMO",97,0 )
	4296	. D WRITE COD^DGPTIC 10("PROC", +$P(DGOP1, U,I),EFFDA TE,2,1,8)
	4297	"RTN","DGP TFMO",98,0 )
	4298	. W $S(+D GPTTMP<1!( '$P(DGPTTM P,U,10)):" *",1:"")
	4299	"RTN","DGP TFMO",99,0 )
	4300	Q
	4301	"RTN","DGP TFMO",100, 0)
	4302	601 ;print the proce dures/date s from the 601 proce dure multi ple (eff. 10/1/87)
	4303	"RTN","DGP TFMO",101, 0)
	4304	K DG601 S J=0
	4305	"RTN","DGP TFMO",102, 0)
	4306	D PTFICD^ DGPTFUT(60 1,D0,I,.DG 601,1)
	4307	"RTN","DGP TFMO",103, 0)
	4308	F S J=$O (DG601(J)) Q:'J D
	4309	"RTN","DGP TFMO",104, 0)
	4310	. S DGPTT MP=$$ICDDA TA^ICDXCOD E("PROC",+ $P(DG601(J ),U,1),EFF DATE)
	4311	"RTN","DGP TFMO",105, 0)
	4312	. D WRITE COD^DGPTIC 10("PROC", +$P(DG601( J),U,1),EF FDATE,2,1, 8)
	4313	"RTN","DGP TFMO",106, 0)
	4314	. W $S(+D GPTTMP<1!( '$P(DGPTTM P,U,10)):" *",1:"")
	4315	"RTN","DGP TFMO",107, 0)
	4316	K DG601
	4317	"RTN","DGP TFMO",108, 0)
	4318	Q
	4319	"RTN","DGP TFMO",109, 0)
	4320	DXLS D HEA D:$Y>(IOSL -16)
	4321	"RTN","DGP TFMO",110, 0)
	4322	S DGPOA1= $P($G(^DGP T(D0,82)), U,1) ;POA for princi pal DX
	4323	"RTN","DGP TFMO",111, 0)
	4324	I +$P(DGP T,U,10) D
	4325	"RTN","DGP TFMO",112, 0)
	4326	. S DGPTT MP=$$ICDDA TA^ICDXCOD E("DIAG",+ $P(DGPT,U, 10),EFFDAT E),DXLS=$S (+DGPTTMP> 0:$P(DGPTT MP,U,2,99) ,1:"")
	4327	"RTN","DGP TFMO",113, 0)
	4328	. W !!?5, "PRINCIPAL DIAGNOSIS : ",$$GETL ABEL^DGPTI C10(EFFDAT E,"D")
	4329	"RTN","DGP TFMO",114, 0)
	4330	. D WRITE COD^DGPTIC 10("DIAG", +$P(DGPT,U ,10),EFFDA TE,2,1,8)
	4331	"RTN","DGP TFMO",115, 0)
	4332	. W $S(+D GPTTMP<1!( '$P(DGPTTM P,U,10)):" *",1:"")
	4333	"RTN","DGP TFMO",116, 0)
	4334	. Q:$P(DG PTTMP,U,20 )'=30 ;no t an ICD10 DX
	4335	"RTN","DGP TFMO",117, 0)
	4336	. W " ["_ $S(DGPOA1] "":DGPOA1, 1:" ")_"]" ;show POA value
	4337	"RTN","DGP TFMO",118, 0)
	4338	;
	4339	"RTN","DGP TFMO",119, 0)
	4340	I +$P(DGP T,U,11) D
	4341	"RTN","DGP TFMO",120, 0)
	4342	. S DGPTT MP=$$ICDDA TA^ICDXCOD E("DIAG",+ $P(DGPT,U, 11),EFFDAT E)
	4343	"RTN","DGP TFMO",121, 0)
	4344	. D WRITE COD^DGPTIC 10("DIAG", +$P(DGPT,U ,11),EFFDA TE,2,1,8)
	4345	"RTN","DGP TFMO",122, 0)
	4346	. W $S(+D GPTTMP<1!( '$P(DGPTTM P,U,10)):" *",1:"")
	4347	"RTN","DGP TFMO",123, 0)
	4348	. Q:$P(DG PTTMP,U,20 )'=30 ;no t an ICD10 DX
	4349	"RTN","DGP TFMO",124, 0)
	4350	. W " ["_ $S(DGPOA1] "":DGPOA1, 1:" ")_"]" ;show POA value. th ere should n't be one for old r ecords
	4351	"RTN","DGP TFMO",125, 0)
	4352	K DG701,D GPOA1 S K= 0
	4353	"RTN","DGP TFMO",126, 0)
	4354	D PTFICD^ DGPTFUT(70 1,D0,,.DG7 01,1)
	4355	"RTN","DGP TFMO",127, 0)
	4356	F S K=$O (DG701(K)) Q:'K D:$ P(DG701(K) ,U,1)>0 DS P
	4357	"RTN","DGP TFMO",128, 0)
	4358	K DG701
	4359	"RTN","DGP TFMO",129, 0)
	4360	;-- displ ay expande d code inf ormation
	4361	"RTN","DGP TFMO",130, 0)
	4362	S DG300=$ S($D(^DGPT (D0,300)): ^(300),1:" ") D:DG300 ]"" PRN2^D GPTFM8 K D G300
	4363	"RTN","DGP TFMO",131, 0)
	4364	D EN2^DGP TF4 ;calls ^DGPTFD t o get DX/O P codes an d then cal ls DGPTICD to calcul ate & stor e DRG valu e in PTF C LOSE OUT ( #45.84) fi le.
	4365	"RTN","DGP TFMO",132, 0)
	4366	Q
	4367	"RTN","DGP TFMO",133, 0)
	4368	Q Q
	4369	"RTN","DGP TFMO",134, 0)
	4370	Q1 K ^UTIL ITY(U,$J), DG1
	4371	"RTN","DGP TFMO",135, 0)
	4372	Q
	4373	"RTN","DGP TFMO",136, 0)
	4374	DT I Y W $ P("JAN^FEB ^MAR^APR^M AY^JUN^JUL ^AUG^SEP^O CT^NOV^DEC ",U,$E(Y,4 ,5))," " W :Y#100 $J( Y#100\1,2) ,"," W Y\1 0000+1700 W:Y#1 " " ,$E(Y_0,9, 10),":",$E (Y_"000",1 1,12)
	4375	"RTN","DGP TFMO",137, 0)
	4376	Q
	4377	"RTN","DGP TFMO",138, 0)
	4378	DSP ;
	4379	"RTN","DGP TFMO",139, 0)
	4380	S J=$$ICD DATA^ICDXC ODE("DIAG" ,+$P(DG701 (K),U,1),E FFDATE) D
	4381	"RTN","DGP TFMO",140, 0)
	4382	. D WRITE COD^DGPTIC 10("DIAG", +$P(DG701( K),U,1),EF FDATE,2,1, 8)
	4383	"RTN","DGP TFMO",141, 0)
	4384	. W $S(+J <1!('$P(J, U,10)):"*" ,1:"")
	4385	"RTN","DGP TFMO",142, 0)
	4386	. Q:$P(J, U,20)'=30 ;not an I CD-10 DX
	4387	"RTN","DGP TFMO",143, 0)
	4388	. W " ["_ $S($P(DG70 1(K),U,2)] "":$P(DG70 1(K),U,2), 1:" ")_"]"
	4389	"RTN","DGP TFMO",144, 0)
	4390	Q
	4391	"RTN","DGP TFQWK")
	4392	0^75^B2791 6518^B2639 3553
	4393	"RTN","DGP TFQWK",1,0 )
	4394	DGPTFQWK ; ALB/AS/PLT - QUICK/L OAD PTF DA TA ;7/21/0 5 2:44pm
	4395	"RTN","DGP TFQWK",2,0 )
	4396	;;5.3;Reg istration; *517,594, 635,729,85 0,884,914 *;Aug 13, 1993;Build 173
	4397	"RTN","DGP TFQWK",3,0 )
	4398	;;Per VA Directive 6402, this routine s hould not be modifie d.
	4399	"RTN","DGP TFQWK",4,0 )
	4400	;
	4401	"RTN","DGP TFQWK",5,0 )
	4402	S (DGPTF, DA)=PTF,DI E="^DGPT(" ,DR="[DGQW K"_$S('DGP TFE:"]",1: "F]") W !, "* editing 101 & 701 transacti ons" D ^DI E
	4403	"RTN","DGP TFQWK",6,0 )
	4404	S DGCODSY S=$$CODESY S^DGPTIC10 (PTF),(DGP TF,DA)=PTF ,DIE="^DGP T(",DR=$S( DGCODSYS=" ICD10":"[D G701-10D]" ,1:"[DG701 ]")
	4405	"RTN","DGP TFQWK",7,0 )
	4406	;used onl y for roll back icd1 0 to icd9
	4407	"RTN","DGP TFQWK",8,0 )
	4408	I DR="[DG 701]",$P($ G(^DGPT(PT F,71)),U,4 ,999)'?."^ " S DR="[D G701-10D]"
	4409	"RTN","DGP TFQWK",9,0 )
	4410	D ^DIE
	4411	"RTN","DGP TFQWK",10, 0)
	4412	;
	4413	"RTN","DGP TFQWK",11, 0)
	4414	W !,"* ed iting 501 transactio ns"
	4415	"RTN","DGP TFQWK",12, 0)
	4416	F DGM=0:0 D S501 Q: Y'>0 K DA S (DGPTF, DA)=PTF S DGMOV=+Y,D GJUMP=$S(' DGPTFE:"", 1:"1-2"),D GCODSYS=$$ CODESYS^DG PTIC10(PTF ) D S DIE ="^DGPT(" D ^DIE,CHK 501^DGPTSC AN K DGMOV
	4417	"RTN","DGP TFQWK",13, 0)
	4418	. I 'DGPT FE S DR=$S (DGCODSYS= "ICD10":"[ DG501-10D] ",1:"[DG50 1]") QUIT
	4419	"RTN","DGP TFQWK",14, 0)
	4420	. S DR=$S (DGCODSYS= "ICD10":"[ DG501F-10D ]",1:"[DG5 01F]")
	4421	"RTN","DGP TFQWK",15, 0)
	4422	. QUIT
	4423	"RTN","DGP TFQWK",16, 0)
	4424	K DIC,DA, DR,DIE,DGC ODSYS,DGXX ,DGTYPE
	4425	"RTN","DGP TFQWK",17, 0)
	4426	;
	4427	"RTN","DGP TFQWK",18, 0)
	4428	W !,"* ed iting 401 transactio ns"
	4429	"RTN","DGP TFQWK",19, 0)
	4430	F DGM=0:0 D S401 Q: Y'>0 K DA S DGSUR=+ Y,DGJUMP=" 1-2",DGCOD SYS=$$CODE SYS^DGPTIC 10(PTF),DR =$S(DGCODS YS="ICD10" :"[DG401-1 0P]",1:"[D G401]"),DI E="^DGPT(" ,(DA,DGPTF )=PTF D ^D IE,CHK401^ DGPTSCAN K DGSUR
	4431	"RTN","DGP TFQWK",20, 0)
	4432	I '$P(^DG PT(PTF,0), U,4) W !," * editing 801 transa ctions" D S801
	4433	"RTN","DGP TFQWK",21, 0)
	4434	K DIC,DA, DR,DIE
	4435	"RTN","DGP TFQWK",22, 0)
	4436	W !,"* ed iting 601 transactio ns"
	4437	"RTN","DGP TFQWK",23, 0)
	4438	F DGM=0:0 S DGZP=1 D S601 Q:Y '>0 K DA S P(DGZP,1 )=+Y,DGJUM P="1-2",DG CODSYS=$$C ODESYS^DGP TIC10(PTF) ,DR=$S(DGC ODSYS="ICD 10":"[DG60 1-10P]",1: "[DG601]") ,DIE="^DGP T(",(DA,DG PTF)=PTF D ^DIE,CHK6 01^DGPTSCA N K P
	4439	"RTN","DGP TFQWK",24, 0)
	4440	K DIC,DA, DR,DIE
	4441	"RTN","DGP TFQWK",25, 0)
	4442	I '$P(^DG PT(PTF,0), "^",4)&('D GST) W !," Updating TRANSFER DRGs" S DG ADM=$P(^DG PT(PTF,0), U,2) D SUD O1^DGPTSUD O
	4443	"RTN","DGP TFQWK",26, 0)
	4444	K DGM,DA, DGMOVENO,D IC,DIE,DR, Y,DGPTF,DG JUMP Q
	4445	"RTN","DGP TFQWK",27, 0)
	4446	;
	4447	"RTN","DGP TFQWK",28, 0)
	4448	S501 ;-- s et up 501
	4449	"RTN","DGP TFQWK",29, 0)
	4450	;set scre en transac tion ident ity
	4451	"RTN","DGP TFQWK",30, 0)
	4452	S X1="^50 1"
	4453	"RTN","DGP TFQWK",31, 0)
	4454	S DA(1)=P TF,DIC("A" )="Select 501 MOVEME NT NUMBER: ",DIC(0)= "AEQ",DIC= "^DGPT("_P TF_",""M"" ," S:'$D(^ DGPT(PTF," M",0)) ^(0 )="^45.02A I^^" D ^DI C
	4455	"RTN","DGP TFQWK",32, 0)
	4456	K DA,DIC
	4457	"RTN","DGP TFQWK",33, 0)
	4458	Q
	4459	"RTN","DGP TFQWK",34, 0)
	4460	;
	4461	"RTN","DGP TFQWK",35, 0)
	4462	S401 ;-- s et up 401
	4463	"RTN","DGP TFQWK",36, 0)
	4464	;set scre en transac tion ident ity
	4465	"RTN","DGP TFQWK",37, 0)
	4466	S X1="^40 1"
	4467	"RTN","DGP TFQWK",38, 0)
	4468	S DA(1)=P TF,DIC("A" )="Select 401 SURGER Y DATE: ", DIC(0)="AE QL",DIC="^ DGPT("_PTF _",""S""," S:'$D(^DG PT(PTF,"S" ,0)) ^(0)= "^45.01DA^ ^" D ^DIC
	4469	"RTN","DGP TFQWK",39, 0)
	4470	K DA,DIC
	4471	"RTN","DGP TFQWK",40, 0)
	4472	Q
	4473	"RTN","DGP TFQWK",41, 0)
	4474	;
	4475	"RTN","DGP TFQWK",42, 0)
	4476	S601 ;-- s et up 601
	4477	"RTN","DGP TFQWK",43, 0)
	4478	;set scre en transac tion ident ity
	4479	"RTN","DGP TFQWK",44, 0)
	4480	S X1="^60 1"
	4481	"RTN","DGP TFQWK",45, 0)
	4482	S DA(1)=P TF,DIC("A" )="Select 601 PROCED URE DATE: ",DIC(0)=" AEQL",DIC= "^DGPT("_P TF_",""P"" ," S:'$D(^ DGPT(PTF," P",0)) ^(0 )="^45.05D A^^" D ^DI C
	4483	"RTN","DGP TFQWK",46, 0)
	4484	K DA,DIC
	4485	"RTN","DGP TFQWK",47, 0)
	4486	Q
	4487	"RTN","DGP TFQWK",48, 0)
	4488	S801 ;-- s et up 801
	4489	"RTN","DGP TFQWK",49, 0)
	4490	;set scre en transac tion ident ity
	4491	"RTN","DGP TFQWK",50, 0)
	4492	S X1="^80 1"
	4493	"RTN","DGP TFQWK",51, 0)
	4494	F D D R EQ:$D(PSIE N) Q:$G(RF L)=1!(Y<0) D PCE
	4495	"RTN","DGP TFQWK",52, 0)
	4496	.S DIC("A ")="Select 801 CPT D ATE/TIME: "
	4497	"RTN","DGP TFQWK",53, 0)
	4498	.S DA(1)= PTF,DIC(0) ="AEQLZ",D IC="^DGPT( "_PTF_","" C"",",DLAY GO=45
	4499	"RTN","DGP TFQWK",54, 0)
	4500	.S:'$D(^D GPT(PTF,"C ",0)) ^(0) ="^45.06^^ " D ^DIC
	4501	"RTN","DGP TFQWK",55, 0)
	4502	.K DA,DIC ,PSIEN Q:Y '>0 S DGP RD=+Y(0),D GPSM=+Y D MOB^DGPTFM 2 I $P(DGZ PRF,U,3) F I=1:1:$P( DGZPRF,U,3 ) S:DGZPRF (I,0)=DGPS M DGZP=I
	4503	"RTN","DGP TFQWK",56, 0)
	4504	.S (DA(1) ,REC)=PTF, DIE="^DGPT ("_PTF_"," "C"",",(DA ,PSIEN)=DG ZPRF(DGZP, 0),DR=".02 ;.03;.05" D FMDIE I $D(Y)>9!$D (DTOUT) S Y=-1 Q
	4505	"RTN","DGP TFQWK",57, 0)
	4506	.S DGI=0, DR=".01;" D CL^SDCO2 1(DFN,DGPR D,"",.SDCL Y) D S Y= 1
	4507	"RTN","DGP TFQWK",58, 0)
	4508	..I $$GET CL^DGUTL3( DFN)=1,'$G (SDCLY(9)) S SDCLY(9 )="" ; s et CLV arr ay if SD p atch is no t released yet and v eteran is CLV eligib le DG5.3 914
	4509	"RTN","DGP TFQWK",59, 0)
	4510	..F S DG I=$O(^DGCP T(46,"C",P TF,DGI)) Q :DGI'>0 I +^DGCPT(4 6,DGI,1)=+ DGZPRF(DGZ P)&'$D(^(9 )) S (DA,R EC)=DGI,DR =".01;",DI E="^DGCPT( 46," D GET INFO^DGPTF M21
	4511	"RTN","DGP TFQWK",60, 0)
	4512	..F S DA =PTF,DIC=" ^DGCPT(46, ",DIC(0)=" AELQMZ",DL AYGO=46,DI C("S")="D EN6^DGPTFJ C I 'DGER" D ^DIC K DIC Q:Y'>0 D SED^DG PTFM2
	4513	"RTN","DGP TFQWK",61, 0)
	4514	..S Y=1
	4515	"RTN","DGP TFQWK",62, 0)
	4516	..Q
	4517	"RTN","DGP TFQWK",63, 0)
	4518	.Q
	4519	"RTN","DGP TFQWK",64, 0)
	4520	K DR,DIE, DIC,DA,DGI ,DGJUMP,DG PRD,DLAYGO ,RFL Q
	4521	"RTN","DGP TFQWK",65, 0)
	4522	REQ ;CHECK FOR REQUI RED FIELDS IN CPT RE CORDS. RE CORDS MISS ING ONE OR MORE REQU IRED FIELD S ARE DELE TED.
	4523	"RTN","DGP TFQWK",66, 0)
	4524	S RFL=0 I '$P(^DGPT (PTF,"C",P SIEN,0),U, 3) S DA(1) =PTF,DA=DG PSM,DIK="^ DGPT("_PTF _",""C""," D G REQQ
	4525	"RTN","DGP TFQWK",67, 0)
	4526	.D ^DIK K DA W !!," No CPT rec ords have been filed because n o performi ng provide r was spec ified." S RFL=1
	4527	"RTN","DGP TFQWK",68, 0)
	4528	S (I,FCPT )=0 D RESE Q^DGPTFM3( PTF)
	4529	"RTN","DGP TFQWK",69, 0)
	4530	F J=1:1 S I=$O(^DGC PT(46,"C", PTF,I)) Q: 'I D:+^DG CPT(46,I,1 )=DGPRD&'$ G(^(9))
	4531	"RTN","DGP TFQWK",70, 0)
	4532	.I $P(^DG CPT(46,I,0 ),U,4) S F CPT=1 Q
	4533	"RTN","DGP TFQWK",71, 0)
	4534	.S DA=I,D IK="^DGCPT (46,",CPT= +^DGCPT(46 ,I,0) D ^D IK
	4535	"RTN","DGP TFQWK",72, 0)
	4536	.W !!,"CP T " S N=$$ CPT^ICPTCO D(CPT,$$GE TDATE^ICDG TDRG(PTF)) W $P(N,U, 2)," ",$P( N,U,3)," n ot filed b ecause no diagnosis 1 was ente red."
	4537	"RTN","DGP TFQWK",73, 0)
	4538	.S RFL=2
	4539	"RTN","DGP TFQWK",74, 0)
	4540	I FCPT K FCPT,I,J,N G REQQ
	4541	"RTN","DGP TFQWK",75, 0)
	4542	S DA(1)=P TF,DA=PSIE N,DIK="^DG PT("_PTF_" ,""C"","
	4543	"RTN","DGP TFQWK",76, 0)
	4544	D ^DIK K DA W !!,"N o CPT reco rds have b een filed because no CPT codes were file d." S RFL= 1 K FCPT,I ,J,N
	4545	"RTN","DGP TFQWK",77, 0)
	4546	REQQ ;D RE SEQ^DGPTFM 3(PTF)
	4547	"RTN","DGP TFQWK",78, 0)
	4548	Q
	4549	"RTN","DGP TFQWK",79, 0)
	4550	SED S DR=" .14////"_D GPRD_";.16 ////"_PTF_ ";",DA=+Y, DIE="^DGCP T(46,"
	4551	"RTN","DGP TFQWK",80, 0)
	4552	S REC=PTF D SDR^DGP TFM21,FMDI E Q
	4553	"RTN","DGP TFQWK",81, 0)
	4554	PCE S DIR( "A")="Send record to PCE? ",DI R(0)="S^Y: YES;N:NO", DIR("B")=" NO"
	4555	"RTN","DGP TFQWK",82, 0)
	4556	D ^DIR K DIR Q:Y="N "!$D(DIRUT )
	4557	"RTN","DGP TFQWK",83, 0)
	4558	D MOB^DGP TFM2 S RES =$$DATA2PC E^DGAPI1(D FN,PTF,DGZ P)
	4559	"RTN","DGP TFQWK",84, 0)
	4560	I RES=1 L -^DGPT(PT F) W !,"PT F Record s ent to PCE " H 2 Q
	4561	"RTN","DGP TFQWK",85, 0)
	4562	W @IOF
	4563	"RTN","DGP TFQWK",86, 0)
	4564	W !,"The PTF Record may not h ave been f iled in PC E due to e rrors."
	4565	"RTN","DGP TFQWK",87, 0)
	4566	W !,"Pres s return t o continue ." R X:DTI ME
	4567	"RTN","DGP TFQWK",88, 0)
	4568	L -^DGPT( PTF) Q
	4569	"RTN","DGP TFQWK",89, 0)
	4570	FMDIE L +^ DGPT(45,RE C):2
	4571	"RTN","DGP TFQWK",90, 0)
	4572	I D ^DIE S RES=$$D ELVFILE^DG API1(DFN,P TF,DGZP) L -^DGPT(45 ,REC) Q
	4573	"RTN","DGP TFQWK",91, 0)
	4574	ERR W !,"C PT record is being e dited by a nother use r" K DIE,R EC S ERRFK G=1 H 2 Q
	4575	"RTN","DGP TFTR")
	4576	0^59^B5555 6979^B5526 0983
	4577	"RTN","DGP TFTR",1,0)
	4578	DGPTFTR ;A LB/JDS,HIO FO/FT - TR ANSMISSION OF PTF ;8 /20/15 3:4 7pm
	4579	"RTN","DGP TFTR",2,0)
	4580	;;5.3;Reg istration; 37,415,5 30,601,614 ,645,787,8 50,884,914 ;Aug 13, 1993;Buil d 173
	4581	"RTN","DGP TFTR",3,0)
	4582	;
	4583	"RTN","DGP TFTR",4,0)
	4584	; VA(200) - #10060
	4585	"RTN","DGP TFTR",5,0)
	4586	; XMB(3.9 ) - #10113
	4587	"RTN","DGP TFTR",6,0)
	4588	; VATRAN - #1011
	4589	"RTN","DGP TFTR",7,0)
	4590	; XLFDT - #10103
	4591	"RTN","DGP TFTR",8,0)
	4592	; XMA21 - #10067
	4593	"RTN","DGP TFTR",9,0)
	4594	; XMD - # 10070
	4595	"RTN","DGP TFTR",10,0 )
	4596	; %ZTLOAD - #10063
	4597	"RTN","DGP TFTR",11,0 )
	4598	;
	4599	"RTN","DGP TFTR",12,0 )
	4600	ENN ;PTF T ransmissio n [DG PTF TRANSMISSI ON VADATS]
	4601	"RTN","DGP TFTR",13,0 )
	4602	L +^DGP(4 5.83):$G(D ILOCKTM,5) I '$T W ! ,"Another user is al ready tran smitting. Please try again lat er." Q ;4 5.83 is PT F RELEASE
	4603	"RTN","DGP TFTR",14,0 )
	4604	D CEN^DGP TUTL ;find current c ensus (fil e 45.86). returns DG CN=ien,DGC N0=zero no de
	4605	"RTN","DGP TFTR",15,0 )
	4606	I '$D(DGR TY) S Y=1 D RTY^DGPT UTL ;deter mine recor d type. If Y=1, then DGRTY=1,D GRTY0="PTF ". If Y=2, then DGRT Y=2,DGRTY0 ="CENSUS"
	4607	"RTN","DGP TFTR",16,0 )
	4608	D FDT^DGP TUTL S DGF MTDT=Y ;se ts Y=29010 00
	4609	"RTN","DGP TFTR",17,0 )
	4610	;
	4611	"RTN","DGP TFTR",18,0 )
	4612	EN5 ;selec t a PTF RE LEASE date or range
	4613	"RTN","DGP TFTR",19,0 )
	4614	K DIC S D IC=45.83,D IC(0)="AZE Q",DIC("A" )="Enter S tart Date: "
	4615	"RTN","DGP TFTR",20,0 )
	4616	S DIC("S" )="I $O(^D GP(45.83,+ Y,""P"",0) ) F DGX=0: 0 S DGX=$O (^DGP(45.8 3,+Y,""P"" ,DGX)) Q:' DGX I '$P (^DGP(45.8 3,+Y,""P"" ,DGX,0),U, 2),$D(^DGP T(DGX,0)), $D(^(70)), +^(70)>290 1000,$P(^( 0),U,11)=+ DGRTY Q"
	4617	"RTN","DGP TFTR",21,0 )
	4618	S D="ANT" D IX^DIC G ENQ1:X[" ^"!(X="")
	4619	"RTN","DGP TFTR",22,0 )
	4620	I Y'>0 W !,"There a re no "_$S ($G(DGRTY) =2:"CENSUS ",1:"PTF") _" records in this d ate range to transmi t." G EN5
	4621	"RTN","DGP TFTR",23,0 )
	4622	S DGSD=+Y (0),DIC(0) ="EAZQ",DI C("S")="I Y'<DGSD"_" "_DIC("S" ),DIC("A") ="Enter Th rough Date : TODAY// ",D="ANT" D IX^DIC K DIC,D
	4623	"RTN","DGP TFTR",24,0 )
	4624	;
	4625	"RTN","DGP TFTR",25,0 )
	4626	G ENQ1:X[ "^" S DGED =$S(Y>0:+Y (0),1:DT)
	4627	"RTN","DGP TFTR",26,0 )
	4628	;call VAT RAN to get transmiss ion variab les
	4629	"RTN","DGP TFTR",27,0 )
	4630	;PTF125 s hould be a n entry in TRANSMISS ION ROUTER S (#407.7)
	4631	"RTN","DGP TFTR",28,0 )
	4632	;VATERR r eturns nul l if no er ror. 1 or 2 or 3 if can't proc ess
	4633	"RTN","DGP TFTR",29,0 )
	4634	;returns VAT array. VAT(1) & VAT(2) are receiving users
	4635	"RTN","DGP TFTR",30,0 )
	4636	;VAT("F") =message l ength (fix ed record) , VAT("V") =message l ength (var iable reco rd)
	4637	"RTN","DGP TFTR",31,0 )
	4638	S VATNAME ="PTF125" D ^VATRAN I VATERR K VATNAME,V ATERR,VAT L -^DGP(45 .83) G ENQ
	4639	"RTN","DGP TFTR",32,0 )
	4640	S DGFMT=2 D SCAN G: DGOUTX ENQ 1
	4641	"RTN","DGP TFTR",33,0 )
	4642	ENQ D SCAN ^DGPTFTR3 ;loops thr u 45.83 an d updates transmissi on date
	4643	"RTN","DGP TFTR",34,0 )
	4644	ENQ1 L -^D GP(45.83) K DGACNT,D GXM,XMDUN, XMY,DGOUTX ,DGSTCNT,D IC,DGX,DGR TY,DGRTY0, DGCN,DGCN0 ,DGPTFMT,D GFMT,DGFMT DT,DGLOGIC ,VAT,VATER R,VATNAME, DGSD,DGED, DGPTSLF
	4645	"RTN","DGP TFTR",35,0 )
	4646	Q
	4647	"RTN","DGP TFTR",36,0 )
	4648	;
	4649	"RTN","DGP TFTR",37,0 )
	4650	SCAN K DGE RR
	4651	"RTN","DGP TFTR",38,0 )
	4652	N DGY S D GY=$G(Y) D FMT^DGPTU TL S Y=$G( DGY) ;sets DGPTFMT=1 , 2 (ICD9 format) or 3 (ICD10 format)
	4653	"RTN","DGP TFTR",39,0 )
	4654	D LOG S D GCNT=1,DGD =DGSD-.01, DGTR=0,DGI D=1
	4655	"RTN","DGP TFTR",40,0 )
	4656	;DGTR=cou nter for # of messag es generat ed, DGID=c ounter for DGIDN arr ay (DGIDN( DGID)=XMZ)
	4657	"RTN","DGP TFTR",41,0 )
	4658	;DGCNT=co unter for number of lines in M ailMan mes sage. Bump ed up in D GPTRI* rou tines
	4659	"RTN","DGP TFTR",42,0 )
	4660	;DGD=rele ase date-. 01
	4661	"RTN","DGP TFTR",43,0 )
	4662	; DG5.3 614 - DGFI RST identi fies first record in a batch
	4663	"RTN","DGP TFTR",44,0 )
	4664	N DGFIRST S DGFIRST =1
	4665	"RTN","DGP TFTR",45,0 )
	4666	W !!,"Now transmitt ing ",$P(D GRTY0,U)," records.. ."
	4667	"RTN","DGP TFTR",46,0 )
	4668	W !,"Incl udes recor ds of "
	4669	"RTN","DGP TFTR",47,0 )
	4670	;
	4671	"RTN","DGP TFTR",48,0 )
	4672	DAT ;creat e a MailMa n message, transmit it and mov e on to pr ocess addi tional PTF s
	4673	"RTN","DGP TFTR",49,0 )
	4674	D:DGCNT>1 XMIT Q:$G (DGPTSLF)> 0 ;quit i f segment lengths ar e wrong
	4675	"RTN","DGP TFTR",50,0 )
	4676	S DGD=$O( ^DGP(45.83 ,DGD)) ;fi rst time t hru, DGCNT is 1, so XMIT is no t executed .
	4677	"RTN","DGP TFTR",51,0 )
	4678	I DGD>0,D GD'>DGED D SETTRAN^D GPTUTL1 Q: DGOUTX ;c reate Mail Man messag e
	4679	"RTN","DGP TFTR",52,0 )
	4680	I DGD'>0! (DGD>DGED) D BULL^DG PTFTR3 G D ATQ ;creat e/send bul letin
	4681	"RTN","DGP TFTR",53,0 )
	4682	S J=0 G P WR
	4683	"RTN","DGP TFTR",54,0 )
	4684	DATQ Q
	4685	"RTN","DGP TFTR",55,0 )
	4686	;
	4687	"RTN","DGP TFTR",56,0 )
	4688	PWR ;get t he PTF rec ord and st art proces sing it
	4689	"RTN","DGP TFTR",57,0 )
	4690	Q:$G(DGPT SLF)>0 ;q uit if seg ment lengt hs are wro ng
	4691	"RTN","DGP TFTR",58,0 )
	4692	D CEN^DGP TUTL ;chec k if censu s can be s ent
	4693	"RTN","DGP TFTR",59,0 )
	4694	S P=J,J=$ O(^DGP(45. 83,DGD,"P" ,J)) G DAT :J'>0,PWR: $P(^(J,0), U,2)
	4695	"RTN","DGP TFTR",60,0 )
	4696	I $D(^DGP T(J,0)),$P (^(0),U,11 )'=+DGRTY G PWR
	4697	"RTN","DGP TFTR",61,0 )
	4698	I $P(DGCN 0,U,3)>DT, DGRTY=1 D CEN^DGPTFT R3 G PWR:' Y
	4699	"RTN","DGP TFTR",62,0 )
	4700	S Y=$S($D (^DGPT(J,7 0)):+^(70) ,1:0) D FM T^DGPTUTL G PWR:DGPT FMT<DGFMT
	4701	"RTN","DGP TFTR",63,0 )
	4702	;LINES^DG PTFVC2 cou nts number of lines for transm ission
	4703	"RTN","DGP TFTR",64,0 )
	4704	S T1=0,T2 =9999999,Y =J,X=0 S:D GRTY=2 T2= +DGCN0_".9 ",T1=+$P(D GCN0,U,5) D LINES^DG PTFVC2 I ( DGCNT+X)>V AT("F"),'$ G(DGFIRST) S J=P G X MIT
	4705	"RTN","DGP TFTR",65,0 )
	4706	I $G(DGFI RST)=1 S D GFIRST=0
	4707	"RTN","DGP TFTR",66,0 )
	4708	K DICR S DGERR=0,DG STCNT("P", J)=DGCNT
	4709	"RTN","DGP TFTR",67,0 )
	4710	;^TMP("AE DIT",$J) & ^TMP("AER ROR",$J) a re set in DGPTAE* ro utines. Us ed to vali date data
	4711	"RTN","DGP TFTR",68,0 )
	4712	W !,$E($P (^DPT(+^DG PT(J,0),0) ,U),1,25), ?27,"(#",J ,")" S X=^ DGPT(J,0) Q:'$D(^(0) ) S DGNOD E=^(0),DGA DM=$P(DGNO DE,U,2) D
	4713	"RTN","DGP TFTR",69,0 )
	4714	. W " Ad mitted: ", $TR($$FMTE ^XLFDT(DGA DM,"5DF"), " ","0")," " K ^TMP( "AEDIT",$J ),^TMP("AE RROR",$J) S DGACNT=0
	4715	"RTN","DGP TFTR",70,0 )
	4716	. F DGZ=6 ,4 W $$GET 1^DIQ(45,J _",",DGZ)_ " "
	4717	"RTN","DGP TFTR",71,0 )
	4718	. K DGNOD E,DGZ Q
	4719	"RTN","DGP TFTR",72,0 )
	4720	I DGRTY=1 D COM
	4721	"RTN","DGP TFTR",73,0 )
	4722	I DGRTY=2 S T2=+DGC N0_".9",T1 =+$P(DGCN0 ,U,5),(PTF ,DGCI)=J D COM1
	4723	"RTN","DGP TFTR",74,0 )
	4724	I DGERR D OPEN^DGPT FTR3 ;does cleanup. deletes 45 .83 data. kills XMY, removes s egments fr om MailMan message. sends Mail man messag e to user that recor d is re-op ened.
	4725	"RTN","DGP TFTR",75,0 )
	4726	K ^TMP("A EDIT",$J)
	4727	"RTN","DGP TFTR",76,0 )
	4728	I 'DGERR W ?70," Ok ay" S DGTR =DGTR+1 G XMIT:DGCNT >VAT("F")
	4729	"RTN","DGP TFTR",77,0 )
	4730	G PWR
	4731	"RTN","DGP TFTR",78,0 )
	4732	Q
	4733	"RTN","DGP TFTR",79,0 )
	4734	;
	4735	"RTN","DGP TFTR",80,0 )
	4736	XMIT ;tran smit messa ge with PT F segments
	4737	"RTN","DGP TFTR",81,0 )
	4738	K XMY D R OUTER
	4739	"RTN","DGP TFTR",82,0 )
	4740	S XMZ=DGX MZ,^XMB(3. 9,XMZ,2,0) ="^3.92A^" _(DGCNT-1) _"^"_(DGCN T-1)_"^"_D T,DGJ=J
	4741	"RTN","DGP TFTR",83,0 )
	4742	S XMDUZ=. 5,XMDUN=$P (^VA(200,D UZ,0),U)
	4743	"RTN","DGP TFTR",84,0 )
	4744	S DGPTSLF =0 D CHECK (XMZ) ;are segment l engths cor rect?
	4745	"RTN","DGP TFTR",85,0 )
	4746	I DGPTSLF >0 Q
	4747	"RTN","DGP TFTR",86,0 )
	4748	D ENT1^XM D ;forward message, don't ask for recip ients
	4749	"RTN","DGP TFTR",87,0 )
	4750	W !,"Tran smission Q ueued" S D GIDN(DGID) =XMZ
	4751	"RTN","DGP TFTR",88,0 )
	4752	F DGK=0:0 S DGK=$O( DGSTCNT("P ",DGK)) Q: DGK'>0 D REC
	4753	"RTN","DGP TFTR",89,0 )
	4754	S DGFIRST =1
	4755	"RTN","DGP TFTR",90,0 )
	4756	K DGK S D GCNT=1,DGI D=DGID+1,J =DGJ Q:J'> 0 D SETTR AN^DGPTUTL 1 G:'DGOUT X PWR
	4757	"RTN","DGP TFTR",91,0 )
	4758	Q
	4759	"RTN","DGP TFTR",92,0 )
	4760	;
	4761	"RTN","DGP TFTR",93,0 )
	4762	REC ;updat e PTF RECO RD multipl e in PTF R ELEASE (45 .83). incl udes PTF r ecord ien, date tran smitted, & message i en
	4763	"RTN","DGP TFTR",94,0 )
	4764	;set PTF STATUS="Tr ansmitted"
	4765	"RTN","DGP TFTR",95,0 )
	4766	S DGSENFL G=""
	4767	"RTN","DGP TFTR",96,0 )
	4768	S DIE="^D GP(45.83," ,DA=DGD,DR ="10///"_D GK,DR(2,45 .831)="1// /TODAY;2// /"_XMZ D ^ DIE K DA,D R,DIE
	4769	"RTN","DGP TFTR",97,0 )
	4770	S DIE="^D GPT(",DR=" 6///3",DA= DGK D ^DIE K DA,DR,D IE
	4771	"RTN","DGP TFTR",98,0 )
	4772	K DGSENFL G
	4773	"RTN","DGP TFTR",99,0 )
	4774	Q
	4775	"RTN","DGP TFTR",100, 0)
	4776	;
	4777	"RTN","DGP TFTR",101, 0)
	4778	COM S T1=0 ,T2=999999 9 S:'$D(PT F) PTF=J S :PTF'=J PT F=J
	4779	"RTN","DGP TFTR",102, 0)
	4780	COM1 ;call ed from DG PTC1
	4781	"RTN","DGP TFTR",103, 0)
	4782	;pulls da ta from PT F (45), PA TIENT(2) a nd PTF CLO SE OUT (45 .84). Valu es are use d to build segments and do dat a validati on
	4783	"RTN","DGP TFTR",104, 0)
	4784	F K=0,70, 71,101,"40 1P" S @("D G"_K)=$S($ D(^DGPT(J, K)):^(K),1 :"")
	4785	"RTN","DGP TFTR",105, 0)
	4786	; pwc DG* 5.3*914 RS D SPEC# 2. 6.5.6 PTF TRANSMISSI ON via Mai lMan
	4787	"RTN","DGP TFTR",106, 0)
	4788	F K=10,.1 1,.3,.32,. 321,.3217, .52,57 S @ ("DG"_$S(K [".":$E(K, 2,99),1:K) )=$S($D(^D GP(45.84,J ,K)):^(K), $D(^DPT(+^ DGPT(J,0), $S(K'=10:K ,1:0))):$S (K'=10:^(K ),1:^(0)), 1:"")
	4789	"RTN","DGP TFTR",107, 0)
	4790	F K=.02,. 06 M @("DG "_$S(K["." :$E(K,2,99 ),1:K))=^D PT(+^DGPT( J,0),K)
	4791	"RTN","DGP TFTR",108, 0)
	4792	;uses dif ferent pro cessing ro utines to build segm ents and M ailMan bas ed on reco rd format.
	4793	"RTN","DGP TFTR",109, 0)
	4794	;DGPTFMT= 1 is very old record format, p erhaps bef ore ICD9 u sage (not sure).
	4795	"RTN","DGP TFTR",110, 0)
	4796	;DGPTFMT= 2 is ICD9 record for mat
	4797	"RTN","DGP TFTR",111, 0)
	4798	;DGPTFMT= 3 is ICD10 record fo rmat
	4799	"RTN","DGP TFTR",112, 0)
	4800	;DGPTR* & DGPTRI* r outines an d similar, but recor d format i s differen t.
	4801	"RTN","DGP TFTR",113, 0)
	4802	D ^DGPTFT R0:DGPTFMT =1,^DGPTR0 :DGPTFMT=2 ,^DGPTRI0: DGPTFMT=3
	4803	"RTN","DGP TFTR",114, 0)
	4804	;
	4805	"RTN","DGP TFTR",115, 0)
	4806	Q ;
	4807	"RTN","DGP TFTR",116, 0)
	4808	L -^DGP(4 5.83)
	4809	"RTN","DGP TFTR",117, 0)
	4810	F K=0,10, 701,"401P" ,101,11,3, 32,41,52,5 7,70,321,3 217,502,70 2,"02","06 " K @("DG" _K)
	4811	"RTN","DGP TFTR",118, 0)
	4812	K DGPICD1 0,DGCDR,DG T,DIC,DGAD M,DGAO,DGD OB,DGHEAD, DGJ,DGK,DG L,DGM,DGNA M,DGNT,DGO ,DGSSN,DGS UD,DGSUR,D GTD,DGX,DG XLS,E,ERR, F,G,H,I,K, L,T,W,Z,DG PROC,DGPRO CD ;** NOT E: do not kill varia bles neede d by PTF l oad/edit o ption!!!
	4813	"RTN","DGP TFTR",119, 0)
	4814	;DGPTFVC1 & DGPTFVC 2 do expan ded ptf cl ose out ed its
	4815	"RTN","DGP TFTR",120, 0)
	4816	;DGPTFVC3 does vali dation che cks for pt f addition al questio ns
	4817	"RTN","DGP TFTR",121, 0)
	4818	I $D(DGER R),DGERR<1 D ^DGPTFV C1 D:'T1 ^ DGPTFVC3
	4819	"RTN","DGP TFTR",122, 0)
	4820	I $D(DGER R),DGERR<1 D EN^DGPT FVC2
	4821	"RTN","DGP TFTR",123, 0)
	4822	Q
	4823	"RTN","DGP TFTR",124, 0)
	4824	;
	4825	"RTN","DGP TFTR",125, 0)
	4826	LOG ;calle d from PRI NT+1^DGPTF 2,CLS+1^DG PTF2,EN^DG PTFVC
	4827	"RTN","DGP TFTR",126, 0)
	4828	D LOG^DGP TFTR1:DGPT FMT=1,LOG^ DGPTR1:DGP TFMT=2,LOG ^DGPTRI1:D GPTFMT=3,C OM:$D(DGER R) ;note: COM is not called un less DGERR exists
	4829	"RTN","DGP TFTR",127, 0)
	4830	Q
	4831	"RTN","DGP TFTR",128, 0)
	4832	;
	4833	"RTN","DGP TFTR",129, 0)
	4834	;-- check for real queue if c ensus shou ld be remo ved for na tional rel ease
	4835	"RTN","DGP TFTR",130, 0)
	4836	ROUTER ;ca lled from DGPTF099,D GPTRPO
	4837	"RTN","DGP TFTR",131, 0)
	4838	;DGSDI is local or remote add ress
	4839	"RTN","DGP TFTR",132, 0)
	4840	;I $D(XMD F) then al l addressi ng restric tions are waived
	4841	"RTN","DGP TFTR",133, 0)
	4842	;XMN - Ca n't find t his variab le in Mail Man docume ntation. M ay not do anything.
	4843	"RTN","DGP TFTR",134, 0)
	4844	S XMDUZ=. 5 F DGSDI= 0:0 S DGSD I=$O(VAT(D GSDI)) Q:' DGSDI S X =VAT(DGSDI ),XMN=0,XM DF="" D IN ST^XMA21 K XMN,XMDF
	4845	"RTN","DGP TFTR",135, 0)
	4846	S XMY(DUZ )=""
	4847	"RTN","DGP TFTR",136, 0)
	4848	Q
	4849	"RTN","DGP TFTR",137, 0)
	4850	;
	4851	"RTN","DGP TFTR",138, 0)
	4852	CHECK(DGPT XMZ) ;chec k if every two lines in messag e body equ al 384 cha racters
	4853	"RTN","DGP TFTR",139, 0)
	4854	N DGPTLAS T,DGPTLOOP ,DGPTNODE, DGPTTEXT,D GPTTOT
	4855	"RTN","DGP TFTR",140, 0)
	4856	S DGPTNOD E=$G(^XMB( 3.9,DGPTXM Z,2,0))
	4857	"RTN","DGP TFTR",141, 0)
	4858	S DGPTLAS T=$P(DGPTN ODE,U,4)
	4859	"RTN","DGP TFTR",142, 0)
	4860	F DGPTLOO P=1:2:DGPT LAST D Q: $G(DGPTSLF )=1
	4861	"RTN","DGP TFTR",143, 0)
	4862	.S DGPTTO T=$L($G(^X MB(3.9,DGP TXMZ,2,DGP TLOOP,0))) +$L($G(^XM B(3.9,DGPT XMZ,2,DGPT LOOP+1,0)) )
	4863	"RTN","DGP TFTR",144, 0)
	4864	.I DGPTTO T'=384 D
	4865	"RTN","DGP TFTR",145, 0)
	4866	..S DGPTS LF=1 ;segm ent length flag
	4867	"RTN","DGP TFTR",146, 0)
	4868	..D QMSG( DGPTXMZ)
	4869	"RTN","DGP TFTR",147, 0)
	4870	..W !!,"T here is a problem wi th the seg ment lengt h of a PTF record."
	4871	"RTN","DGP TFTR",148, 0)
	4872	..W !,"Th e MailMan message nu mber is "_ DGPTXMZ_". "
	4873	"RTN","DGP TFTR",149, 0)
	4874	..W !,"Pl ease log a Remedy ti cket. Stop ping trans mission.", !
	4875	"RTN","DGP TFTR",150, 0)
	4876	Q
	4877	"RTN","DGP TFTR",151, 0)
	4878	;
	4879	"RTN","DGP TFTR",152, 0)
	4880	QMSG(DGPTM IEN) ;noti fy others about bad segment le ngth
	4881	"RTN","DGP TFTR",153, 0)
	4882	N ZTDESC, ZTDTH,ZTIO ,ZTRTN,ZTS AVE
	4883	"RTN","DGP TFTR",154, 0)
	4884	S ZTDESC= "DG PTF TR ANSMISSION VADATS",Z TDTH=$$NOW ^XLFDT(),Z TIO="",ZTR TN="SMSG^D GPTFTR"
	4885	"RTN","DGP TFTR",155, 0)
	4886	S ZTSAVE( "DGPTMIEN" )=""
	4887	"RTN","DGP TFTR",156, 0)
	4888	D ^%ZTLOA D
	4889	"RTN","DGP TFTR",157, 0)
	4890	Q
	4891	"RTN","DGP TFTR",158, 0)
	4892	;
	4893	"RTN","DGP TFTR",159, 0)
	4894	SMSG ;send MailMan m essage
	4895	"RTN","DGP TFTR",160, 0)
	4896	N DGPTTEX T,XMDUZ,XM SUB,XMTEXT ,XMY
	4897	"RTN","DGP TFTR",161, 0)
	4898	S XMSUB=" Station "_ $P($$SITE^ VASITE(),U ,3)_" has wrong PTF segment le ngth"
	4899	"RTN","DGP TFTR",162, 0)
	4900	S XMDUZ=$ S($G(DUZ)> 0:$G(DUZ), 1:.5)
	4901	"RTN","DGP TFTR",163, 0)
	4902	S DGPTTEX T(1)="The PTF record s containe d in this message ca nnot be tr ansmitted"
	4903	"RTN","DGP TFTR",164, 0)
	4904	S DGPTTEX T(2)="to A ITC due to format of the conte nt issue."
	4905	"RTN","DGP TFTR",165, 0)
	4906	S DGPTTEX T(3)=" "
	4907	"RTN","DGP TFTR",166, 0)
	4908	S DGPTTEX T(4)="Cont act the su pport help desk and report."
	4909	"RTN","DGP TFTR",167, 0)
	4910	S DGPTTEX T(5)=" "
	4911	"RTN","DGP TFTR",168, 0)
	4912	S DGPTTEX T(6)="Retr ansmission will need to be att empted onc e the tran smission"
	4913	"RTN","DGP TFTR",169, 0)
	4914	S DGPTTEX T(7)="mess age format has been corrected. "
	4915	"RTN","DGP TFTR",170, 0)
	4916	S DGPTTEX T(8)=" "
	4917	"RTN","DGP TFTR",171, 0)
	4918	S DGPTTEX T(9)="The local Mail Man messag e number i s: "_DGPTM IEN
	4919	"RTN","DGP TFTR",172, 0)
	4920	S XMTEXT= "DGPTTEXT( "
	4921	"RTN","DGP TFTR",173, 0)
	4922	S XMY(DUZ )=""
	4923	"RTN","DGP TFTR",174, 0)
	4924	S XMY(" PII ") =""
	4925	"RTN","DGP TFTR",175, 0)
	4926	D ^XMD
	4927	"RTN","DGP TFTR",176, 0)
	4928	Q
	4929	"RTN","DGP TFVC1")
	4930	0^21^B4342 5692^B4259 3524
	4931	"RTN","DGP TFVC1",1,0 )
	4932	DGPTFVC1 ; ALB/AS/ADL ,HIOFO/FT - Expanded PTF Close -Out Edits ;10/21/14 2:33pm
	4933	"RTN","DGP TFVC1",2,0 )
	4934	;;5.3;Reg istration; 52,58,79 ,114,164,4 00,342,466 ,415,493,5 12,510,544 ,629,817,8 50,884,914 ;Aug 13, 1993;Buil d 173
	4935	"RTN","DGP TFVC1",3,0 )
	4936	;;ADL;Upd ated for C SV Project ;;Mar 26, 2003
	4937	"RTN","DGP TFVC1",4,0 )
	4938	;
	4939	"RTN","DGP TFVC1",5,0 )
	4940	; XLFDT A PIs - #101 03
	4941	"RTN","DGP TFVC1",6,0 )
	4942	; ICDEX A PIs - #574 7
	4943	"RTN","DGP TFVC1",7,0 )
	4944	; ICDXCOD E APIs - # 5699
	4945	"RTN","DGP TFVC1",8,0 )
	4946	; VADPT A PIs - #100 61
	4947	"RTN","DGP TFVC1",9,0 )
	4948	;
	4949	"RTN","DGP TFVC1",10, 0)
	4950	;Called f rom Q+2^DG PTFTR. Var iable must be passed in: PTF
	4951	"RTN","DGP TFVC1",11, 0)
	4952	;Variable returned: DGERR. DGERR <-- 1 if recor d fails to pass a ch eck; DGERR <-- "" if record pa sses all c hecks
	4953	"RTN","DGP TFVC1",12, 0)
	4954	;
	4955	"RTN","DGP TFVC1",13, 0)
	4956	Q:'$D(PTF )
	4957	"RTN","DGP TFVC1",14, 0)
	4958	S DGERR=" ",DGV(701) =$S($D(^DG PT(PTF,70) ):^(70),1: ""),DGV(10 1)=^(0),DG SUFFIX=$P( DGV(101)," ^",5),DGV( "FEE")=$P( DGV(101)," ^",4),DFN= $P(DGV(101 ),"^",1)
	4959	"RTN","DGP TFVC1",15, 0)
	4960	;
	4961	"RTN","DGP TFVC1",16, 0)
	4962	I $P(DGV( 101),"^",2 )>2820700 D AO
	4963	"RTN","DGP TFVC1",17, 0)
	4964	;
	4965	"RTN","DGP TFVC1",18, 0)
	4966	I DGRTY=1 ,DGV("FEE" ) D MT
	4967	"RTN","DGP TFVC1",19, 0)
	4968	;
	4969	"RTN","DGP TFVC1",20, 0)
	4970	; DG*512, sck/Remov e 101-Mean s Test ind icator = ' U' xmit bl ock
	4971	"RTN","DGP TFVC1",21, 0)
	4972	;
	4973	"RTN","DGP TFVC1",22, 0)
	4974	; 850 - a as - hard coded ICD codes, dia gnosis val ues, diffe rent for I CD-9 and I CD-10
	4975	"RTN","DGP TFVC1",23, 0)
	4976	N SYS,EFF DATE,IMPDA TE,DGPTDAT
	4977	"RTN","DGP TFVC1",24, 0)
	4978	D EFFDATE ^DGPTIC10( $G(PTF))
	4979	"RTN","DGP TFVC1",25, 0)
	4980	S SYS=$$S YS^ICDEX(" DIAG",EFFD ATE)
	4981	"RTN","DGP TFVC1",26, 0)
	4982	I $D(^DPT (DFN,57)), $P(^(57)," ^",4)>0,SY S=1 S S0=$ P(^(57),"^ ",4),DGDX= $S(S0=1!(S 0=3):"344. 1",1:"344. 0"),DGSCI= "" F DGX=0 :0 S DGX=$ O(^DGPT(PT F,"M",DGX) ) Q:DGX'>0 S DGNODE (0)=^(DGX, 0),DGNODE= $$STR501^D GPTFUT(PTF ,DGX),DGSC I="" D SCI
	4983	"RTN","DGP TFVC1",27, 0)
	4984	I $D(^DPT (DFN,57)), $P(^(57)," ^",4)>0,SY S=30 S S0= $P(^(57)," ^",4),DGDX =$S(S0=1!( S0=3):"G82 .2",1:"G82 .5"),DGSCI ="" F DGX= 0:0 S DGX= $O(^DGPT(P TF,"M",DGX )) Q:DGX'> 0 S DGNOD E(0)=^(DGX ,0),DGNODE =$$STR501^ DGPTFUT(PT F,DGX),DGS CI="" D SC I
	4985	"RTN","DGP TFVC1",28, 0)
	4986	;
	4987	"RTN","DGP TFVC1",29, 0)
	4988	S DGDP="" ,DGDISPO=$ P(DGV(701) ,"^",6),DG RECSUF=$P( DGV(701)," ^",13)
	4989	"RTN","DGP TFVC1",30, 0)
	4990	I DGRTY=1 D
	4991	"RTN","DGP TFVC1",31, 0)
	4992	.S DGSTAT YP=$S(DGDI SPO=12!(DG DISPO=13): 30,DGDISPO =10:42,DGD ISPO=8:40, 1:"")
	4993	"RTN","DGP TFVC1",32, 0)
	4994	.I DGSTAT YP]"" D
	4995	"RTN","DGP TFVC1",33, 0)
	4996	..D NUMAC T^DGPTSUF( DGSTATYP)
	4997	"RTN","DGP TFVC1",34, 0)
	4998	..I DGANU M>0 F I=1: 1:DGANUM I DGSUFFIX= DGSUFNAM(I ) D
	4999	"RTN","DGP TFVC1",35, 0)
	5000	...I DGDI SPO'=8 I D GRECSUF=DG SUFNAM(DGA NUM) S DGD P=5 D DP
	5001	"RTN","DGP TFVC1",36, 0)
	5002	...I DGDI SPO=8 N DG ANUM,DGSUF NAM D NUMA CT^DGPTSUF (42) I DGR ECSUF=DGSU FNAM(DGANU M) S DGDP= 5 D DP
	5003	"RTN","DGP TFVC1",37, 0)
	5004	.K DGANUM ,DGSTATYP, DGSUFNAM,I
	5005	"RTN","DGP TFVC1",38, 0)
	5006	;
	5007	"RTN","DGP TFVC1",39, 0)
	5008	I DGRTY=1 S %=$P(DG V(701),"^" ,3) I %=4! (%=6)!(%=7 ) S DGDP=" " D OP I $ P(DGV(701) ,"^",5)=1 S DGERR=1 W !,"701 V A AUSPICES ",?23," va lue incons istent for discharge "
	5009	"RTN","DGP TFVC1",40, 0)
	5010	;
	5011	"RTN","DGP TFVC1",41, 0)
	5012	;If PRRTP treating specialty, must have valid PRR TP suffix
	5013	"RTN","DGP TFVC1",42, 0)
	5014	;Fee reco rds would not contai n PRRTP sp ecialties
	5015	"RTN","DGP TFVC1",43, 0)
	5016	I 'DGV("F EE"),"^25^ 26^27^28^2 9^38^39^"[ (U_$P(DGV( 701),U,2)_ U) D
	5017	"RTN","DGP TFVC1",44, 0)
	5018	.I DGSUFF IX'="PA",( DGSUFFIX'= "PB"),(DGS UFFIX'="PC "),(DGSUFF IX'="PD") D
	5019	"RTN","DGP TFVC1",45, 0)
	5020	..S DGERR =1
	5021	"RTN","DGP TFVC1",46, 0)
	5022	..W !,"10 1 SUFFIX", ?23,"value must be s et to a va lid PRRTP suffix."
	5023	"RTN","DGP TFVC1",47, 0)
	5024	;
	5025	"RTN","DGP TFVC1",48, 0)
	5026	D RACETHN C
	5027	"RTN","DGP TFVC1",49, 0)
	5028	K DGDISPO ,DGRECSUF, DGV,DGDP,D GDX,DGSCI, DGSUFFIX,D GNODE,DGX, %,S0,I,X
	5029	"RTN","DGP TFVC1",50, 0)
	5030	I DGERR H 4
	5031	"RTN","DGP TFVC1",51, 0)
	5032	Q
	5033	"RTN","DGP TFVC1",52, 0)
	5034	;
	5035	"RTN","DGP TFVC1",53, 0)
	5036	SCI ;
	5037	"RTN","DGP TFVC1",54, 0)
	5038	N EFFDATE ,IMPDATE
	5039	"RTN","DGP TFVC1",55, 0)
	5040	D EFFDATE ^DGPTIC10( PTF)
	5041	"RTN","DGP TFVC1",56, 0)
	5042	F X=1:1:2 5 I $P(DGN ODE,"^",X) S DGPTTMP =$$ICDDATA ^ICDXCODE( "DIAG",+$P (DGNODE,"^ ",X),EFFDA TE) D
	5043	"RTN","DGP TFVC1",57, 0)
	5044	. I +DGPT TMP>0&($P( DGPTTMP,U, 10)) S:$E( $P(DGPTTMP ,"^",2),1, 5)=DGDX DG SCI=10 Q:D GSCI
	5045	"RTN","DGP TFVC1",58, 0)
	5046	I 'DGSCI S DGERR=1, %=$P(DGNOD E(0),"^",1 0),X=$TR($ $FMTE^XLFD T(%,"5DF") ," ","0") W !,"501 " ,X," SCI o f ",S0,?23 ," require s an ICD D iagnosis c ode beginn ing with", !?12," or equal to " ,DGDX
	5047	"RTN","DGP TFVC1",59, 0)
	5048	Q
	5049	"RTN","DGP TFVC1",60, 0)
	5050	;
	5051	"RTN","DGP TFVC1",61, 0)
	5052	MT S DGVMT =$P(DGV(10 1),"^",10) ,DGX=999 G DGX:DGVMT ']"" I +$P (DGV(101), "^",2)<286 0700!(DGSU FFIX="BU") S DGX="X" G DGX
	5053	"RTN","DGP TFVC1",62, 0)
	5054	S DGZEC=$ P($G(^DGPT (PTF,101)) ,U,8),DGZE C=$S($D(^D IC(8,+DGZE C,0)):^(0) ,1:"") I $ P(DGZEC,U, 5)="N" S D GX="N" G D GX
	5055	"RTN","DGP TFVC1",63, 0)
	5056	S DGT=$P( DGV(701)," .") G AS:' $O(^DGMT(4 08.31,"AD" ,1,DFN,0)) S DGZ1=$$ LST^DGMTU( DFN,DGT) K :DGZ1']"" DGZ1
	5057	"RTN","DGP TFVC1",64, 0)
	5058	I DGVMT=" X" K DGX,D GVMT Q
	5059	"RTN","DGP TFVC1",65, 0)
	5060	S DGX=$S( '$D(DGZ1): "U",1:$P(D GZ1,U,4))
	5061	"RTN","DGP TFVC1",66, 0)
	5062	; Determi ne if the Pending Ad judication is for MT (C) or GMT (G)
	5063	"RTN","DGP TFVC1",67, 0)
	5064	I DGX="P" D G DGX
	5065	"RTN","DGP TFVC1",68, 0)
	5066	. I '+$P( $G(DGZ1),U ) S DGX="U " Q
	5067	"RTN","DGP TFVC1",69, 0)
	5068	. S DGX=$ $PA^DGMTUT L($P(DGZ1, U)),DGX=$S ('$D(DGX): "U",DGX="M T":"C",DGX ="GMT":"G" ,1:"U")
	5069	"RTN","DGP TFVC1",70, 0)
	5070	I DGX="A" ,$P(DGZEC, U,4)=3,$$S C^DGMTR(DF N),$$ANYSC ^DGPTSCAN( PTF) S DGX ="AS" G DG X
	5071	"RTN","DGP TFVC1",71, 0)
	5072	I DGX="A" ,"^1^3^"[( "^"_$P(DGZ EC,U,4)_"^ "),$P($G(^ DPT(DFN,.3 )),U,2)>0 S DGX="AS" G DGX
	5073	"RTN","DGP TFVC1",72, 0)
	5074	S DGX=$S( DGX="A":"A N","BCGN"[ DGX:DGX,1: "U") G AS: DGX="U" G DGX:DGX'=" N"
	5075	"RTN","DGP TFVC1",73, 0)
	5076	AS S DGZ=$ S($D(^DPT( DFN,.321)) :^(.321),1 :0) I $P(D GZ,U,2)="Y "!($P(DGZ, U,3)="Y") S DGX="AS" G DGX
	5077	"RTN","DGP TFVC1",74, 0)
	5078	; pwc DG* 5.3*914 RS D SPEC# 2. 6.5.6 PTF TRANSMISSI ON via Mai lMan
	5079	"RTN","DGP TFVC1",75, 0)
	5080	S DGZ=$S( $D(^DPT(DF N,.3217)): ^(.3217),1 :0) I $P(D GZ,U,1)="Y " S DGX="A S" G DGX
	5081	"RTN","DGP TFVC1",76, 0)
	5082	S DGZ=$S( $D(^DPT(DF N,.322)):^ (.322),1:0 ) I $P(DGZ ,U,13)="Y" S DGX="AS " G DGX
	5083	"RTN","DGP TFVC1",77, 0)
	5084	N DGNTARR S DGZ=$S( $$GETCUR^D GNTAPI(DFN ,"DGNTARR" )>0:DGNTAR R("NTR"),1 :"") I $P( DGZ,U)="Y" S DGX="AS " G DGX
	5085	"RTN","DGP TFVC1",78, 0)
	5086	S DGZ=$$G ETSTAT^DGM STAPI(DFN) I $P(DGZ, U,2)="Y" S DGX="AS" G DGX
	5087	"RTN","DGP TFVC1",79, 0)
	5088	I $P(DGZE C,U,5)="Y" ,$P(DGZEC, U,4)<4,"^2 ^15^"'[(U_ $P(DGZEC,U ,9)_U) S D GX="AS" G DGX
	5089	"RTN","DGP TFVC1",80, 0)
	5090	S DGX="AN "
	5091	"RTN","DGP TFVC1",81, 0)
	5092	DGX ;DG5. 3817/Remo ve 101-Mea ns Test in dicator = 'U' xmit b lock for F EE BASIS P TF
	5093	"RTN","DGP TFVC1",82, 0)
	5094	I DGVMT'= DGX,DGVMT' ="U" S DGE RR=1 W !," 101 ","MEA NS TEST",? 23," value ",DGVMT,$ S(DGVMT']" ":"blank", DGVMT="X": " only for admission s prior to 7/1/86 or domicilli ary use",1 :" inconsi stent with eligibili ty data")
	5095	"RTN","DGP TFVC1",83, 0)
	5096	K DGZEC,D GZ,DGZ1,DG T,DGX,DGVM T Q
	5097	"RTN","DGP TFVC1",84, 0)
	5098	;
	5099	"RTN","DGP TFVC1",85, 0)
	5100	DP I $P(DG V(701),"^" ,3)'=5 S D GERR=1 W ! ,"701 ",$E ("TYPE OF DISPOSITIO N",1,18),? 23," value inconsist ent for di scharge"
	5101	"RTN","DGP TFVC1",86, 0)
	5102	OP I $P(DG V(701),"^" ,4)=1 S DG ERR=1 W !, "701 ",$E( "OUTPATIEN T TREATMEN T",1,18),? 23," value inconsist ent for di scharge" Q :DGDP=""
	5103	"RTN","DGP TFVC1",87, 0)
	5104	I $P(DGV( 701),"^",5 )=2 S DGER R=1 W !,"7 01 VA AUSP ICES",?23, " value in consistent for disch arge"
	5105	"RTN","DGP TFVC1",88, 0)
	5106	Q
	5107	"RTN","DGP TFVC1",89, 0)
	5108	;
	5109	"RTN","DGP TFVC1",90, 0)
	5110	AO I DGPTF MT<2 D Q
	5111	"RTN","DGP TFVC1",91, 0)
	5112	.S %=$S($ D(^DGPT(PT F,101)):$P (^(101),"^ ",4),1:"")
	5113	"RTN","DGP TFVC1",92, 0)
	5114	.S %=$S($ D(^DIC(45. 82,+%,0)): $P(^(0),"^ ",1),1:"")
	5115	"RTN","DGP TFVC1",93, 0)
	5116	.S I=$S($ D(^DPT(DFN ,.321)):^( .321),1:"" )
	5117	"RTN","DGP TFVC1",94, 0)
	5118	.S:$P(I," ^",2)="Y"& (%'=6) DGE RR=1,DGV(" E")=1
	5119	"RTN","DGP TFVC1",95, 0)
	5120	.W:$D(DGV ("E")) !," 101 AGENT ORANGE",?2 3," value ",$S(DGV(" E"):"can o nly be use d with COB of '6'",1 :"is incon sistent wi th Vietnam Service a nd/or COB" )
	5121	"RTN","DGP TFVC1",96, 0)
	5122	;
	5123	"RTN","DGP TFVC1",97, 0)
	5124	N AO,AOL, TMP
	5125	"RTN","DGP TFVC1",98, 0)
	5126	S TMP=$G( ^DPT(DFN,. 321))
	5127	"RTN","DGP TFVC1",99, 0)
	5128	S AO=$S($ P(TMP,"^", 2)="Y":1,1 :0)
	5129	"RTN","DGP TFVC1",100 ,0)
	5130	S AOL=$P( TMP,"^",13 )
	5131	"RTN","DGP TFVC1",101 ,0)
	5132	Q:('AO)
	5133	"RTN","DGP TFVC1",102 ,0)
	5134	Q:(AOL'=" ")
	5135	"RTN","DGP TFVC1",103 ,0)
	5136	S DGERR=1 ,DGV("E")= 1
	5137	"RTN","DGP TFVC1",104 ,0)
	5138	W !,"101 AGENT ORAN GE LOCATIO N",?23,"va lue requir ed if expo sure to Ag ent Orange claimed"
	5139	"RTN","DGP TFVC1",105 ,0)
	5140	Q
	5141	"RTN","DGP TFVC1",106 ,0)
	5142	RACETHNC ;Rac e and ethn icity chec k
	5143	"RTN","DGP TFVC1",107 ,0)
	5144	;Ensure t hat a valu e for ethn icity and at least o ne race is on file.
	5145	"RTN","DGP TFVC1",108 ,0)
	5146	;Ensure a ll active race/ethni city value s have a v alid PTF v alue and a n
	5147	"RTN","DGP TFVC1",109 ,0)
	5148	;associat ed collect ion method . Ensure all collec tion metho ds have a
	5149	"RTN","DGP TFVC1",110 ,0)
	5150	;valid PT F value. Ignore rac e/ethnicit y entries that are i nactive or
	5151	"RTN","DGP TFVC1",111 ,0)
	5152	;invalid pointers. Note: PTF sends fir st active ethnicity and first
	5153	"RTN","DGP TFVC1",112 ,0)
	5154	;six acti ve races.
	5155	"RTN","DGP TFVC1",113 ,0)
	5156	N REF,IEN ,TYPE,TEXT ,PTRVAL,PT RMTHD,NUM, MAX
	5157	"RTN","DGP TFVC1",114 ,0)
	5158	N VALIDVA L,VALIDMTH ,VALUE,VAD M
	5159	"RTN","DGP TFVC1",115 ,0)
	5160	D DEM^VAD PT
	5161	"RTN","DGP TFVC1",116 ,0)
	5162	F REF=11, 12 D
	5163	"RTN","DGP TFVC1",117 ,0)
	5164	.I REF=12 D
	5165	"RTN","DGP TFVC1",118 ,0)
	5166	..S MAX=6
	5167	"RTN","DGP TFVC1",119 ,0)
	5168	..S TYPE= 1
	5169	"RTN","DGP TFVC1",120 ,0)
	5170	..S VALID VAL=",3,8, 9,A,B,C,D, "
	5171	"RTN","DGP TFVC1",121 ,0)
	5172	..S VALID MTH=",S,P, O,U,"
	5173	"RTN","DGP TFVC1",122 ,0)
	5174	..S TEXT= "RACE"
	5175	"RTN","DGP TFVC1",123 ,0)
	5176	.I REF=11 D
	5177	"RTN","DGP TFVC1",124 ,0)
	5178	..S MAX=1
	5179	"RTN","DGP TFVC1",125 ,0)
	5180	..S TYPE= 2
	5181	"RTN","DGP TFVC1",126 ,0)
	5182	..S TEXT= "ETHNICITY "
	5183	"RTN","DGP TFVC1",127 ,0)
	5184	..S VALID VAL=",H,N, D,U,"
	5185	"RTN","DGP TFVC1",128 ,0)
	5186	..S VALID MTH=",S,P, O,U,"
	5187	"RTN","DGP TFVC1",129 ,0)
	5188	.S NUM=1
	5189	"RTN","DGP TFVC1",130 ,0)
	5190	.S IEN=0
	5191	"RTN","DGP TFVC1",131 ,0)
	5192	.F S IEN =+$O(VADM( REF,IEN)) Q:'IEN D Q:NUM>MAX
	5193	"RTN","DGP TFVC1",132 ,0)
	5194	..S PTRVA L=+VADM(RE F,IEN)
	5195	"RTN","DGP TFVC1",133 ,0)
	5196	..S PTRMT HD=+$G(VAD M(REF,IEN, 1))
	5197	"RTN","DGP TFVC1",134 ,0)
	5198	..Q:'PTRV AL
	5199	"RTN","DGP TFVC1",135 ,0)
	5200	..Q:$$INA CTIVE^DGUT L4(PTRVAL, TYPE)
	5201	"RTN","DGP TFVC1",136 ,0)
	5202	..S NUM=N UM+1
	5203	"RTN","DGP TFVC1",137 ,0)
	5204	..S VALUE =$$PTR2COD E^DGUTL4(P TRVAL,TYPE ,4)
	5205	"RTN","DGP TFVC1",138 ,0)
	5206	..I (VALU E="")!(VAL IDVAL'[VAL UE) D Q
	5207	"RTN","DGP TFVC1",139 ,0)
	5208	...W !,"7 01 ",TEXT, ?23,"missi ng/invalid xmit valu e"
	5209	"RTN","DGP TFVC1",140 ,0)
	5210	...S DGER R=1
	5211	"RTN","DGP TFVC1",141 ,0)
	5212	..I ('PTR MTHD) D Q
	5213	"RTN","DGP TFVC1",142 ,0)
	5214	...W !,"7 01 ",TEXT, ?23,"metho d of colle ction miss ing/invali d"
	5215	"RTN","DGP TFVC1",143 ,0)
	5216	...S DGER R=1
	5217	"RTN","DGP TFVC1",144 ,0)
	5218	..S VALUE =$$PTR2COD E^DGUTL4(P TRMTHD,3,4 )
	5219	"RTN","DGP TFVC1",145 ,0)
	5220	..I (VALU E="")!(VAL IDMTH'[VAL UE) D Q
	5221	"RTN","DGP TFVC1",146 ,0)
	5222	...W !,"7 01 ",TEXT, ?23,"missi ng/invalid xmit valu e for meth od of coll ection"
	5223	"RTN","DGP TFVC1",147 ,0)
	5224	...S DGER R=1
	5225	"RTN","DGP TFVC1",148 ,0)
	5226	Q
	5227	"RTN","DGP TLMU6")
	5228	0^55^B9195 265^B83494 05
	5229	"RTN","DGP TLMU6",1,0 )
	5230	DGPTLMU6 ; ALB/MTC - PTF A/P LI ST MANAGER UTILITY C ONT. ; 24 Dec 2018 9:48 AM
	5231	"RTN","DGP TLMU6",2,0 )
	5232	;;5.3;Reg istration; *606,914 *;Aug 13, 1993;Build 173
	5233	"RTN","DGP TLMU6",3,0 )
	5234	;
	5235	"RTN","DGP TLMU6",4,0 )
	5236	DI501 ;-- this funct ion will l oad the 50 1 informat ion into t he display array
	5237	"RTN","DGP TLMU6",5,0 )
	5238	N X,Y,I,J
	5239	"RTN","DGP TLMU6",6,0 )
	5240	S I=0 F S I=$O(^DG PT(DGPTF," M",I)) Q:' I D
	5241	"RTN","DGP TLMU6",7,0 )
	5242	. S X1="" ,X=$G(^DGP T(DGPTF,"M ",I,0)) Q: X']""
	5243	"RTN","DGP TLMU6",8,0 )
	5244	. S ^TMP( "ARCPTFDI" ,$J,$$NUM^ DGPTLMU4(. NUMREC),0) =""
	5245	"RTN","DGP TLMU6",9,0 )
	5246	. S Y="Mo vement Dt :"_$S($P(X ,U,10):$$F TIME^VALM1 ($P(X,U,10 )),1:"")
	5247	"RTN","DGP TLMU6",10, 0)
	5248	. S X1=$$ SETSTR^VAL M1(Y,X1,1, 40)
	5249	"RTN","DGP TLMU6",11, 0)
	5250	. S ^TMP( "ARCPTFDI" ,$J,$$NUM^ DGPTLMU4(. NUMREC),0) =X1,X1=""
	5251	"RTN","DGP TLMU6",12, 0)
	5252	. S Y="Tr eated for SC condit :"_$S($P(X ,U,18)=1:" YES",1:"NO ")
	5253	"RTN","DGP TLMU6",13, 0)
	5254	. S X1=$$ SETSTR^VAL M1(Y,X1,1, 40)
	5255	"RTN","DGP TLMU6",14, 0)
	5256	. S Y="Tr eated for AO condit :"_$S($P(X ,U,26)=1:" YES",1:"NO ")
	5257	"RTN","DGP TLMU6",15, 0)
	5258	. S X1=$$ SETSTR^VAL M1(Y,X1,45 ,30)
	5259	"RTN","DGP TLMU6",16, 0)
	5260	. S ^TMP( "ARCPTFDI" ,$J,$$NUM^ DGPTLMU4(. NUMREC),0) =X1,X1=""
	5261	"RTN","DGP TLMU6",17, 0)
	5262	. S Y="Tr eated for IR condit :"_$S($P(X ,U,27)=1:" YES",1:"NO ")
	5263	"RTN","DGP TLMU6",18, 0)
	5264	. S X1=$$ SETSTR^VAL M1(Y,X1,1, 40)
	5265	"RTN","DGP TLMU6",19, 0)
	5266	. S Y="Tr eated for EC condit :"_$S($P(X ,U,28)=1:" YES",1:"NO ")
	5267	"RTN","DGP TLMU6",20, 0)
	5268	. ;PWC DG 5.3914 R SD SPEC# 2 .6.5.2.4 < 501> Scree n Camp Lej eune
	5269	"RTN","DGP TLMU6",21, 0)
	5270	. S X1=$$ SETSTR^VAL M1(Y,X1,45 ,30)
	5271	"RTN","DGP TLMU6",22, 0)
	5272	. S Y="Tr eated for CL condit :"_$S($P(X ,U,33)="Y" :"YES",1:" NO")
	5273	"RTN","DGP TLMU6",23, 0)
	5274	. S X1=$$ SETSTR^VAL M1(Y,X1,45 ,30)
	5275	"RTN","DGP TLMU6",24, 0)
	5276	. S ^TMP( "ARCPTFDI" ,$J,$$NUM^ DGPTLMU4(. NUMREC),0) =X1,X1=""
	5277	"RTN","DGP TLMU6",25, 0)
	5278	. S Y="Le ave Days : "_$S($P(X, U,3):$P(X, U,3),1:"")
	5279	"RTN","DGP TLMU6",26, 0)
	5280	. S X1=$$ SETSTR^VAL M1(Y,X1,1, 40)
	5281	"RTN","DGP TLMU6",27, 0)
	5282	. S Y="Pa ss Days :" _$S($P(X,U ,4):$P(X,U ,4),1:"")
	5283	"RTN","DGP TLMU6",28, 0)
	5284	. S X1=$$ SETSTR^VAL M1(Y,X1,45 ,30)
	5285	"RTN","DGP TLMU6",29, 0)
	5286	. S ^TMP( "ARCPTFDI" ,$J,$$NUM^ DGPTLMU4(. NUMREC),0) =X1,X1=""
	5287	"RTN","DGP TLMU6",30, 0)
	5288	. S Y="Lo sing Speci alty :"_$S ($P(X,U,2) :$P(^DIC(4 2.4,$P(X,U ,2),0),U), 1:"")
	5289	"RTN","DGP TLMU6",31, 0)
	5290	. S X1=$$ SETSTR^VAL M1(Y,X1,1, 75)
	5291	"RTN","DGP TLMU6",32, 0)
	5292	. S ^TMP( "ARCPTFDI" ,$J,$$NUM^ DGPTLMU4(. NUMREC),0) =X1,X1=""
	5293	"RTN","DGP TLMU6",33, 0)
	5294	.;
	5295	"RTN","DGP TLMU6",34, 0)
	5296	.;-- chec k for ICD codes
	5297	"RTN","DGP TLMU6",35, 0)
	5298	. S ^TMP( "ARCPTFDI" ,$J,$$NUM^ DGPTLMU4(. NUMREC),0) ="ICD CODE S :"
	5299	"RTN","DGP TLMU6",36, 0)
	5300	. F J=5:1 :9,11:1:15 I $P(X,U, J) D
	5301	"RTN","DGP TLMU6",37, 0)
	5302	.. S Y=$$ ICDDX^ICDC ODE($P(X,U ,J),$P(X,U ,10)),Y=$P (Y,U,2)_" - "_$P(Y,U ,4)
	5303	"RTN","DGP TLMU6",38, 0)
	5304	.. S ^TMP ("ARCPTFDI ",$J,$$NUM ^DGPTLMU4( .NUMREC),0 )=" "_Y
	5305	"RTN","DGP TLMU6",39, 0)
	5306	.;
	5307	"RTN","DGP TLMU6",40, 0)
	5308	.;-- chec k for 300 node infor mation
	5309	"RTN","DGP TLMU6",41, 0)
	5310	.;
	5311	"RTN","DGP TLMU6",42, 0)
	5312	. S X2=$G (^DGPT(DGP TF,"M",I,3 00)) I X2] "" D DI300 ^DGPTLMU4( X2)
	5313	"RTN","DGP TLMU6",43, 0)
	5314	Q
	5315	"RTN","DGP TLMU6",44, 0)
	5316	;
	5317	"RTN","DGP TLMU6",45, 0)
	5318	DI535 ;-- this funct ion will l oad the 53 5 informat ion
	5319	"RTN","DGP TLMU6",46, 0)
	5320	N Y,X,X1, DG535
	5321	"RTN","DGP TLMU6",47, 0)
	5322	S DG535=0 F S DG53 5=$O(^DGPT (DGPTF,535 ,DG535)) Q :'DG535 D
	5323	"RTN","DGP TLMU6",48, 0)
	5324	. S ^TMP( "ARCPTFDI" ,$J,$$NUM^ DGPTLMU4(. NUMREC),0) =""
	5325	"RTN","DGP TLMU6",49, 0)
	5326	. S X=$G( ^DGPT(DGPT F,535,DG53 5,0)),X1=" "
	5327	"RTN","DGP TLMU6",50, 0)
	5328	. S Y="Wa rd Movemen t Date :"_ $S($P(X,U, 10):$$FTIM E^VALM1($P (X,U,10)), 1:"")
	5329	"RTN","DGP TLMU6",51, 0)
	5330	. S X1=$$ SETSTR^VAL M1(Y,X1,1, 40)
	5331	"RTN","DGP TLMU6",52, 0)
	5332	. S Y="Lo sing Ward Specialty :"_$P(^DIC (42.4,$P(X ,U,2),0),U ,1)
	5333	"RTN","DGP TLMU6",53, 0)
	5334	. S X1=$$ SETSTR^VAL M1(Y,X1,45 ,30)
	5335	"RTN","DGP TLMU6",54, 0)
	5336	. S ^TMP( "ARCPTFDI" ,$J,$$NUM^ DGPTLMU4(. NUMREC),0) =X1,X1=""
	5337	"RTN","DGP TLMU6",55, 0)
	5338	. S Y="Le ave Days : "_$P(X,U, 3)
	5339	"RTN","DGP TLMU6",56, 0)
	5340	. S X1=$$ SETSTR^VAL M1(Y,X1,1, 40)
	5341	"RTN","DGP TLMU6",57, 0)
	5342	. S Y="Pa ss Days :" _$P(X,U,4)
	5343	"RTN","DGP TLMU6",58, 0)
	5344	. S X1=$$ SETSTR^VAL M1(Y,X1,45 ,30)
	5345	"RTN","DGP TLMU6",59, 0)
	5346	. S ^TMP( "ARCPTFDI" ,$J,$$NUM^ DGPTLMU4(. NUMREC),0) =X1,X1=""
	5347	"RTN","DGP TLMU6",60, 0)
	5348	. S Y="Lo sing Ward : "_$P(^DI C(42,$P(X, U,6),0),U)
	5349	"RTN","DGP TLMU6",61, 0)
	5350	. S X1=$$ SETSTR^VAL M1(Y,X1,1, 40)
	5351	"RTN","DGP TLMU6",62, 0)
	5352	. S ^TMP( "ARCPTFDI" ,$J,$$NUM^ DGPTLMU4(. NUMREC),0) =X1,X1=""
	5353	"RTN","DGP TLMU6",63, 0)
	5354	Q
	5355	"RTN","DGP TLMU6",64, 0)
	5356	;
	5357	"RTN","DGP TR0")
	5358	0^22^B2746 0595^B2680 1939
	5359	"RTN","DGP TR0",1,0)
	5360	DGPTR0 ;MJ K/JS/ADL/T J,HIOFO/FT - PTF TRA NSMISSION ;4/21/15 1 1:28am
	5361	"RTN","DGP TR0",2,0)
	5362	;;5.3;Reg istration; 114,247, 338,342,51 0,524,565, 678,729,66 4,850,884, 914;Aug 13, 1993;B uild 173
	5363	"RTN","DGP TR0",3,0)
	5364	;;ADL;Upd ate for CS V Project; ;Mar 27, 2 003
	5365	"RTN","DGP TR0",4,0)
	5366	;
	5367	"RTN","DGP TR0",5,0)
	5368	; ICDXCOD E APIs - # 5699
	5369	"RTN","DGP TR0",6,0)
	5370	; SDCO22 APIs - #15 79
	5371	"RTN","DGP TR0",7,0)
	5372	;
	5373	"RTN","DGP TR0",8,0)
	5374	; -- setu p control data
	5375	"RTN","DGP TR0",9,0)
	5376	; ssn
	5377	"RTN","DGP TR0",10,0)
	5378	S X=$P(DG 10,U,9),Y= $S($E(X,10 )="P":"P", 1:" ")_$E( X_" ",1,9)
	5379	"RTN","DGP TR0",11,0)
	5380	; -- adm d/t
	5381	"RTN","DGP TR0",12,0)
	5382	S X=$P($P (DG0,U,2), "."),Y=Y_$ E(X,4,5)_$ E(X,6,7)_$ E(X,2,3)_$ E($P($P(DG 0,U,2),"." ,2)_"0000" ,1,4)
	5383	"RTN","DGP TR0",13,0)
	5384	; -- faci lity #
	5385	"RTN","DGP TR0",14,0)
	5386	S L=3,X=D G0,Z=3 D E NTER S Y=Y _$E($P(X,U ,5)_" ", 1,3)
	5387	"RTN","DGP TR0",15,0)
	5388	S DGHEAD= Y,Y=" " _Y D HEAD^ DGPTR1
	5389	"RTN","DGP TR0",16,0)
	5390	;
	5391	"RTN","DGP TR0",17,0)
	5392	101 ; -- s etup 101 t ransmissio n
	5393	"RTN","DGP TR0",18,0)
	5394	; control data and name
	5395	"RTN","DGP TR0",19,0)
	5396	S Y=$S(T1 :"C",1:"N" )_"101"_DG HEAD S Y=Y _$$PTFNMFT ($P(DG10,U ))
	5397	"RTN","DGP TR0",20,0)
	5398	; source of admissi on
	5399	"RTN","DGP TR0",21,0)
	5400	S Y=Y_$S( $D(^DIC(45 .1,+DG101, 0)):$J($P( ^(0),U,1), 2),1:" ")
	5401	"RTN","DGP TR0",22,0)
	5402	; xfring fac and su ffix
	5403	"RTN","DGP TR0",23,0)
	5404	S L=3,X=D G101,Z=5 D ENTER S Y =Y_$E($P(X ,U,6)_" ",1,3)
	5405	"RTN","DGP TR0",24,0)
	5406	; source of payment
	5407	"RTN","DGP TR0",25,0)
	5408	S Y=Y_$S( "A0"[$P(DG 0,U,5):" " ,1:$J($P(D G101,U,3), 1))
	5409	"RTN","DGP TR0",26,0)
	5410	;POW Loca tion
	5411	"RTN","DGP TR0",27,0)
	5412	S Y=Y_$S( $P(DG52,U, 5)="N":1,$ P(DG52,U,5 )'="Y":3,$ P(DG52,U,6 )>0&($P(DG 52,U,6)<7) :3+$P(DG52 ,U,6),$P(D G52,U,6)>6 &($P(DG52, U,6)<9):$C ($P(DG52,U ,6)+58),1: " ")
	5413	"RTN","DGP TR0",28,0)
	5414	;marital status, se x
	5415	"RTN","DGP TR0",29,0)
	5416	S Y=Y_$S( $D(^DIC(11 ,+$P(DG10, U,5),0)):$ E(^(0),1), 1:" ")_$J( $P(DG10,U, 2),1)
	5417	"RTN","DGP TR0",30,0)
	5418	; date o f birth
	5419	"RTN","DGP TR0",31,0)
	5420	S DGDOB=$ P(DG10,U,3 )\1,Y=Y_$E (DGDOB,4,5 )_$E(DGDOB ,6,7)_(170 0+$E(DGDOB ,1,3))
	5421	"RTN","DGP TR0",32,0)
	5422	; period of service
	5423	"RTN","DGP TR0",33,0)
	5424	S DGPOS=$ S($D(^DIC( 21,+$P(DG3 2,U,3),0)) :$P(^(0),U ,3),1:"")
	5425	"RTN","DGP TR0",34,0)
	5426	I $D(^DGP M(+$O(^DGP M("APTF",J ,0)),"ODS" )),+^("ODS ") S DGPOS =6
	5427	"RTN","DGP TR0",35,0)
	5428	;-- if no n vet admi tting elig ibility ma ke POS 9
	5429	"RTN","DGP TR0",36,0)
	5430	S DGPOS=$ $CKPOS^DGP TUTL($P($G (^DGPT(PTF ,101)),U,8 ),DGPOS)
	5431	"RTN","DGP TR0",37,0)
	5432	S X=DGPOS ,Z=1,L=2 D ENTER
	5433	"RTN","DGP TR0",38,0)
	5434	; agent o range
	5435	"RTN","DGP TR0",39,0)
	5436	S G=" " S DGAO=$P(D G321,U,2) S:DGPOS=7 G=$S($P(DG 321,U)'="Y ":1,DGAO=" N":2,DGAO= "Y":3,1:4) S:(DGAO=" Y")&($P(DG 321,U,13)= "K") G=5
	5437	"RTN","DGP TR0",40,0)
	5438	; rad exp osure
	5439	"RTN","DGP TR0",41,0)
	5440	S E=" " I "^0^2^4^5 ^7^8^Z^"[( U_DGPOS_U) S DGNT=$P (DG321,U,1 2),E=$S($P (DG321,U,3 )'="Y":1,D GNT="N":2, DGNT="T":3 ,DGNT="B": 4,1:" ")
	5441	"RTN","DGP TR0",42,0)
	5442	S Y=Y_G_E K DGPOS,G ,E
	5443	"RTN","DGP TR0",43,0)
	5444	; state c ode
	5445	"RTN","DGP TR0",44,0)
	5446	S X=$S($D (^DIC(5,+$ P(DG11,U,5 ),0)):^(0) ,1:""),L=2 ,Z=3 D ENT ER0
	5447	"RTN","DGP TR0",45,0)
	5448	; county code
	5449	"RTN","DGP TR0",46,0)
	5450	S X=$S($D (^DIC(5,+$ P(DG11,U,5 ),1,+$P(DG 11,U,7),0) ):^(0),1:" "),L=3,Z=3 D ENTER0
	5451	"RTN","DGP TR0",47,0)
	5452	; zip cod e
	5453	"RTN","DGP TR0",48,0)
	5454	S X=DG11, Z=6,L=5 D ENTER
	5455	"RTN","DGP TR0",49,0)
	5456	; means t est
	5457	"RTN","DGP TR0",50,0)
	5458	S Y=Y_$S( $P(DG70,U, 26)="Y":"A S",1:$E($P (DG0,U,10) _" ",1,2) )
	5459	"RTN","DGP TR0",51,0)
	5460	; income
	5461	"RTN","DGP TR0",52,0)
	5462	I $L($P(D G101,U,7)) >6 S Y=Y_" 999999"
	5463	"RTN","DGP TR0",53,0)
	5464	E S X=DG 101,Z=7,L= 6 D ENTER0
	5465	"RTN","DGP TR0",54,0)
	5466	;MST
	5467	"RTN","DGP TR0",55,0)
	5468	S X=$$GET STAT^DGMST API(+DG0) S Y=Y_$S(X <0:"U",1:$ P(X,"^",2) )
	5469	"RTN","DGP TR0",56,0)
	5470	;Combat V et
	5471	"RTN","DGP TR0",57,0)
	5472	S X=$$CVE DT^DGCV(+D G0,$P(DG0, "^",2)) S Y=Y_$S((+X )>0:1,1:0)
	5473	"RTN","DGP TR0",58,0)
	5474	S X=$P(X, "^",2)_" " S Y =Y_$E(X,4, 5)_$E(X,6, 7)_$E(X,2, 3)
	5475	"RTN","DGP TR0",59,0)
	5476	;Project 112/SHAD
	5477	"RTN","DGP TR0",60,0)
	5478	S X=$$SHA D^SDCO22(+ DG0) S Y=Y _$S((+X)>0 :1,1:0)
	5479	"RTN","DGP TR0",61,0)
	5480	;Emergenc y Response Indicator
	5481	"RTN","DGP TR0",62,0)
	5482	S X=$$EMG RES^DGUTL( +DG0) S Y= Y_$S("^K^" [(U_X_U):X ,1:" ")
	5483	"RTN","DGP TR0",63,0)
	5484	;Country Code
	5485	"RTN","DGP TR0",64,0)
	5486	S X=$$GET 1^DIQ(779. 004,$P(DG1 1,U,10)_", ",.01),Z=1 ,L=3 D ENT ER
	5487	"RTN","DGP TR0",65,0)
	5488	;Camp Lej eune AF - RSD 2.6.5. 6 PTF TRAN SMISSION v ia MailMan DG5.391 4
	5489	"RTN","DGP TR0",66,0)
	5490	S X=$$GET CL^DGUTL3( +DG0)
	5491	"RTN","DGP TR0",67,0)
	5492	S Y=Y_$S( X=1:1,X=0: 0,1:" ")
	5493	"RTN","DGP TR0",68,0)
	5494	D FILL^DG PTR2,SAVE
	5495	"RTN","DGP TR0",69,0)
	5496	;I T1 S Y =$E(Y,1,52 )_" "_$E(Y ,54,125)
	5497	"RTN","DGP TR0",70,0)
	5498	I T1 S $E (Y,53)=" " ;sets $E( Y,53)=" " if census, but why a fter it is saved?
	5499	"RTN","DGP TR0",71,0)
	5500	;
	5501	"RTN","DGP TR0",72,0)
	5502	P401 ; -- setup 401P transacti on
	5503	"RTN","DGP TR0",73,0)
	5504	G 401:'$D (^DGPT(J," 401P"))!(T 1) S DG41= ^("401P"), Y=$S(T1:"C ",1:"N")_" 401"_DGHEA D_"P"_" "
	5505	"RTN","DGP TR0",74,0)
	5506	N EFFDATE ,IMPDATE,D GPTDAT D E FFDATE^DGP TIC10(J)
	5507	"RTN","DGP TR0",75,0)
	5508	S DG41=$S ($D(^DGPT( J,"401P")) :^("401P") ,1:"")
	5509	"RTN","DGP TR0",76,0)
	5510	S L=1 F K =1:1:5 S:' $P(DG41,U, K) DG41=$P (DG41,U,1, K-1)_U_$P( DG41,U,K+1 ,99),K=K-1 S L=L+1 Q :L=5
	5511	"RTN","DGP TR0",77,0)
	5512	F I=1:1:5 S DGPTTMP =$$ICDDATA ^ICDXCODE( "PROC",+$P (DG41,U,I) ,EFFDATE," I"),Y=Y_$S (+DGPTTMP> 0:$J($P($P (DGPTTMP,U ,2),".",1) ,2)_$E($P( $P(DGPTTMP ,U,2),".", 2)_" ",1 ,3),1:" ")_" "
	5513	"RTN","DGP TR0",78,0)
	5514	K DGPTEDT
	5515	"RTN","DGP TR0",79,0)
	5516	I $E(Y,40 )'=" " D F ILL^DGPTR2 ,SAVE
	5517	"RTN","DGP TR0",80,0)
	5518	;
	5519	"RTN","DGP TR0",81,0)
	5520	401 ; -- s etup 401 t ransaction s
	5521	"RTN","DGP TR0",82,0)
	5522	G 501:'$D (^DGPT(J," S")) K ^UT ILITY($J," S") S I=0
	5523	"RTN","DGP TR0",83,0)
	5524	SUR ;
	5525	"RTN","DGP TR0",84,0)
	5526	S I=$O(^D GPT(J,"S", I)) G 501: 'I S DGSUR =^(I,0),DG AUX=$S($D( ^DGPT(J,"S ",I,300)): ^(300),1:" ") G SUR:' DGSUR
	5527	"RTN","DGP TR0",85,0)
	5528	G SUR:DGS UR<T1!(DGS UR>T2) S D GSUD=+^(0) \1,^UTILIT Y($J,"S",D GSUD)=$S($ D(^UTILITY ($J,"S",DG SUD)):^(DG SUD),1:0)+ 1,F=$S(DGS UD<2871000 :0,1:1)
	5529	"RTN","DGP TR0",86,0)
	5530	I ^UTILIT Y($J,"S",D GSUD)>$S(F :3,1:2) D I Y'=1 S DGERR=1 Q
	5531	"RTN","DGP TR0",87,0)
	5532	.W !,"T here are m ore than " ,$S(F:"thr ee",1:"two ")," surge ries on th e same dat e"
	5533	"RTN","DGP TR0",88,0)
	5534	.S DIR(0) ="Y",DIR(" B")="YES", DIR("A")=" OK to cont inue?" D ^ DIR K DIR
	5535	"RTN","DGP TR0",89,0)
	5536	S Y=$S(T1 :"C",1:"N" )_"401"_DG HEAD_$E(DG SUD,4,5)_$ E(DGSUD,6, 7)_$E(DGSU D,2,3)_$E( $P(+DGSUR, ".",2)_"00 00",1,4)_$ S($D(^DIC( 45.3,+$P(D GSUR,U,3), 0)):$P(^(0 ),U,1),1:" ")
	5537	"RTN","DGP TR0",90,0)
	5538	S L=1,X=D GSUR F Z=4 :1:7 D ENT ER
	5539	"RTN","DGP TR0",91,0)
	5540	N EFFDATE ,IMPDATE,D GPTDAT D E FFDATE^DGP TIC10(J)
	5541	"RTN","DGP TR0",92,0)
	5542	S L=1 F K =8:1:12 S: '$P(DGSUR, U,K) DGSUR =$P(DGSUR, U,1,K-1)_U _$P(DGSUR, U,K+1,99), K=K-1 S L= L+1 Q:L=5
	5543	"RTN","DGP TR0",93,0)
	5544	F K=8:1:1 2 S DGPTTM P=$$ICDDAT A^ICDXCODE ("PROC",+$ P(DGSUR,U, K),EFFDATE ,"I"),Y=Y_ $S(+DGPTTM P>0:$J($P( $P(DGPTTMP ,U,2),".", 1),2)_$E($ P($P(DGPTT MP,U,2),". ",2)_" " ,1,3),1:" ")_" "
	5545	"RTN","DGP TR0",94,0)
	5546	;
	5547	"RTN","DGP TR0",95,0)
	5548	;-- att p hy
	5549	"RTN","DGP TR0",96,0)
	5550	S Y=Y_" "
	5551	"RTN","DGP TR0",97,0)
	5552	;-- addit ional ptf question
	5553	"RTN","DGP TR0",98,0)
	5554	;send nul l, if disc h date>ina ctive date . DG/729
	5555	"RTN","DGP TR0",99,0)
	5556	I +$P($G( ^DIC(45.88 ,1,0)),U,3 ) S DGAUX= $S((+$G(^D GPT(J,70)) <$P(^DIC(4 5.88,1,0), U,3)):DGAU X,1:"")
	5557	"RTN","DGP TR0",100,0 )
	5558	S Y=Y_$E( $P(DGAUX,U )_" ")
	5559	"RTN","DGP TR0",101,0 )
	5560	K DGAUX
	5561	"RTN","DGP TR0",102,0 )
	5562	D FILL^DG PTR2,SAVE G SUR
	5563	"RTN","DGP TR0",103,0 )
	5564	501 G 501^ DGPTR2
	5565	"RTN","DGP TR0",104,0 )
	5566	Q
	5567	"RTN","DGP TR0",105,0 )
	5568	ENTER S Y= Y_$J($P(X, U,Z),L)
	5569	"RTN","DGP TR0",106,0 )
	5570	Q
	5571	"RTN","DGP TR0",107,0 )
	5572	ENTER0 S Y =Y_$S($P(X ,U,Z)]"":$ E("000000" ,$L($P(X,U ,Z))+1,L)_ $P(X,U,Z), 1:$J($P(X, U,Z),L))
	5573	"RTN","DGP TR0",108,0 )
	5574	Q
	5575	"RTN","DGP TR0",109,0 )
	5576	SAVE ;save segment t o MailMan message an d ^TMP("AE DIT",$J), if data is valid
	5577	"RTN","DGP TR0",110,0 )
	5578	D SAVE^DG PTR2
	5579	"RTN","DGP TR0",111,0 )
	5580	Q Q
	5581	"RTN","DGP TR0",112,0 )
	5582	DGNAM S X= DGNAM I X? .E.P F I=1 :1:$L(X) S Z=$E(X,I) Q:Z="," S:Z?.P&(Z] "") X=$E(X ,1,I-1)_$E (X,I+1,$L( X)),I=I-1 Q:X'?.E.P
	5583	"RTN","DGP TR0",113,0 )
	5584	I X?.E.L D UP^DGHEL P
	5585	"RTN","DGP TR0",114,0 )
	5586	S DGNAM=X
	5587	"RTN","DGP TR0",115,0 )
	5588	Q
	5589	"RTN","DGP TR0",116,0 )
	5590	;
	5591	"RTN","DGP TR0",117,0 )
	5592	PTFNMFT(DG 10) ;this function w ill format the name of the pat ient for
	5593	"RTN","DGP TR0",118,0 )
	5594	; transmi ssion of t he 101 rec ord to Aus tin. In ad dition, th is
	5595	"RTN","DGP TR0",119,0 )
	5596	; functio n will be used by OP C so that the format will be c onsistent
	5597	"RTN","DGP TR0",120,0 )
	5598	; for OPC and PTF.
	5599	"RTN","DGP TR0",121,0 )
	5600	; INPUT : DG10 - .01 field from the patient re cord.
	5601	"RTN","DGP TR0",122,0 )
	5602	; OUTPUT : name i n the form at proper format.
	5603	"RTN","DGP TR0",123,0 )
	5604	; A = <12 - characters of last n ame padded with blan ks>
	5605	"RTN","DGP TR0",124,0 )
	5606	; B = <1 - first init ial of fis t name>
	5607	"RTN","DGP TR0",125,0 )
	5608	; C = <1 - first init ial of mid dle name>
	5609	"RTN","DGP TR0",126,0 )
	5610	; re turns :ABC <14 - cha racters>
	5611	"RTN","DGP TR0",127,0 )
	5612	N X,I
	5613	"RTN","DGP TR0",128,0 )
	5614	S DGNAM=D G10 D DGNA M
	5615	"RTN","DGP TR0",129,0 )
	5616	Q $E($P(D GNAM,",",1 )_" ",1,12 )_$J($E($P (DGNAM,"," ,2),1),1)_ $J($E($P($ P(DGNAM,", ",2)," ",2 ),1),1)
	5617	"RTN","DGP TR1")
	5618	0^66^B3156 9906^B2992 0843
	5619	"RTN","DGP TR1",1,0)
	5620	DGPTR1 ;AL B/MTC - PT F VERIFICA TION ;01 M AR 91 @080 0
	5621	"RTN","DGP TR1",2,0)
	5622	;;5.3;Reg istration; 58,247,3 38,342,423 ,415,565,6 78,696,729 ,781,664,8 17,850,914 ;Aug 13, 1993;Buil d 173
	5623	"RTN","DGP TR1",3,0)
	5624	START ;
	5625	"RTN","DGP TR1",4,0)
	5626	S T=$E(Y, 2,3),T=$S( T=40&($E(Y ,28)="P"): "P40",1:T)
	5627	"RTN","DGP TR1",5,0)
	5628	S ERR=$P( $T(@("T"_T )),";;",2, 999),W=$P( $T(@(T))," ;;",2,999) ,F=31 D L
	5629	"RTN","DGP TR1",6,0)
	5630	; DG5.3 914 with a ddition of CLV data, 101 now e xceeds 245 bytes so split 101 into 2 pie ces
	5631	"RTN","DGP TR1",7,0)
	5632	I T=10 S ERR=$P($T( T101),";;" ,2,999),W= $P($T(101) ,";;",2,99 9),F=100 D L
	5633	"RTN","DGP TR1",8,0)
	5634	I T=70 S ERR=$P($T( T701),";;" ,2,999),W= $P($T(701) ,";;",2,99 9),F=72 D L
	5635	"RTN","DGP TR1",9,0)
	5636	D @("D"_T ) Q
	5637	"RTN","DGP TR1",10,0)
	5638	K DGFILL
	5639	"RTN","DGP TR1",11,0)
	5640	Q
	5641	"RTN","DGP TR1",12,0)
	5642	;
	5643	"RTN","DGP TR1",13,0)
	5644	L ;
	5645	"RTN","DGP TR1",14,0)
	5646	N DGFOR S DGFOR=$S( $$FORIEN^D GADDUTL($P (DG11,U,10 ))<1:0,1:1 ) ;set for eign count ry flag =1 , else, se t as domes tic
	5647	"RTN","DGP TR1",15,0)
	5648	F H=1:1 S DGO=$P(W, U,H) Q:'DG O D
	5649	"RTN","DGP TR1",16,0)
	5650	. F Z=1:1 :$P(DGO,"; ",3) D
	5651	"RTN","DGP TR1",17,0)
	5652	.. S DGL= DGLOGIC(+D GO)
	5653	"RTN","DGP TR1",18,0)
	5654	.. S X=$E (Y,F)
	5655	"RTN","DGP TR1",19,0)
	5656	.. D @("E RR:"_DGL) S F=F+1
	5657	"RTN","DGP TR1",20,0)
	5658	Q
	5659	"RTN","DGP TR1",21,0)
	5660	;
	5661	"RTN","DGP TR1",22,0)
	5662	T10 ;;1:NA ME^2:SOURC E OF ADM^3 :TRANS FAC .^4:SOURCE OF PAY^5: POW^6:MARI TAL ST^7:S EX^8:DOB^9 :POS^10:VI ETNAM^11:I ON RADIATI ON^12:RESI DENCE^13:M EANS TEST^ 14:INCOME^ 15:MST^16: COMBAT VET ^17:CV END DT^18:PRO J 112/SHAD ^19:ERI^20 :COUNTRY
	5663	"RTN","DGP TR1",23,0)
	5664	;
	5665	"RTN","DGP TR1",24,0)
	5666	T101 ;;1:C AMP LEJEUN E^
	5667	"RTN","DGP TR1",25,0)
	5668	;T101 is part 2 of T10
	5669	"RTN","DGP TR1",26,0)
	5670	T70 ;;1:DT OF DISP.^ 2:DISCH BD SEC^3:TYP E OF DIS^4 :OUT TREAT ^5:VA AUS^ 6:PL OF DI S^7:REC FA C^8:ASIH D AYS^9:NOT USED^10:C& P STAT^11: PDXLS^12:O NLY DX^13: PHY MPCR
	5671	"RTN","DGP TR1",27,0)
	5672	;T701 is part 2 of T70
	5673	"RTN","DGP TR1",28,0)
	5674	T701 ;;1:P HY SPEC^2: %SC^3:LEGI ON^4:SUICI DE^5:DRUG^ 6:AXIS-IV^ 7:AXIS-V^8 :SC^9:EXP^ 10:MST^11: HNC^12:ETH NICITY^13: RACE^14:CO MBAT VET^1 5:PROJ 112 /SHAD^16:A SIH^17:CAM P LEJEUNE
	5675	"RTN","DGP TR1",29,0)
	5676	;
	5677	"RTN","DGP TR1",30,0)
	5678	T50 ;;1:DT OF MVMT^2 :LOSING BD SEC MPCR^ 3:LOSING B D SEC^4:LE AVE DAYS^5 :PASS DAYS ^6:SCI^7:D IAG^8:DOCT OR'S SSN^9 :PHY MPCR^ 10:PHY SPE C^11:DISCH ARGE STAT^ ^^^^16:LEG ION^17:SUI CIDE^18:DR UG^19:AXIS -IV^20:AXI S-V^21:SC^ 22:EXP^23: MST^24:HNC
	5679	"RTN","DGP TR1",31,0)
	5680	;
	5681	"RTN","DGP TR1",32,0)
	5682	T53 ;;1:DA TE OF PHYS ICAL MOVEM ENT^2:LOSI NG PHYSICA L MPCR^3:L OSING PHYS ICAL SPECI ALTY^4:TR SPECIALTY MPCR^5:TR SPECIALTY^ 6:LEAVE DA YS^7:PASS DAYS^8:DOC TOR'S SSN (NOT USED)
	5683	"RTN","DGP TR1",33,0)
	5684	;
	5685	"RTN","DGP TR1",34,0)
	5686	T40 ;;1:DA TE OF SURG ERY^2:SURG SPEC.^3:C AT CHIEF S URGEON^4:C AT FIRST A SS^5:ANEST . TECH.^6: SOURCE OF PAY^7:OP C ODE^8:DOCT OR'S SSN ( NOT USED)^ ^^^^13:TRA NSPLANT ST ATUS
	5687	"RTN","DGP TR1",35,0)
	5688	;
	5689	"RTN","DGP TR1",36,0)
	5690	TP40 ;;1:O P CODE
	5691	"RTN","DGP TR1",37,0)
	5692	;
	5693	"RTN","DGP TR1",38,0)
	5694	T60 ;;1:DA TE OF PROC EDURE^2:LO SING BD SE C^3:DIALYS IS TYPE^4: NUMBER OF TREATMENTS ^5:PROCEDU RE CODE
	5695	"RTN","DGP TR1",39,0)
	5696	;
	5697	"RTN","DGP TR1",40,0)
	5698	LOGIC ;;X' ?.N^X'?.A& (X'=" ")^X '=" "^X'?. N&(X'=" ") ^X'?.A&(X' =" ")^0^X' ?.N&(X'="X ")^X'=" "& (X'="P")^X ="E"^X="Y" ^X=" "^X'= "A"&(X'=" ")^(X'?.A) &(X'?.N)&( X'=" ")^(X '?.AN)&('$ P(DG0,U,4) )^((T1)&(X '=" "))!(( 'T1)&(X'?. AN)&('$P(D G0,U,4)))
	5699	"RTN","DGP TR1",41,0)
	5700	;;(X'?.AN )^'$D(DGFO R)&(X'?.N) ^'$D(DGFOR )&X'?.N&(X '="X")
	5701	"RTN","DGP TR1",42,0)
	5702	;;END
	5703	"RTN","DGP TR1",43,0)
	5704	;
	5705	"RTN","DGP TR1",44,0)
	5706	; edit ch eck# ; edi t field ; # x check preformed ; display error name #
	5707	"RTN","DGP TR1",45,0)
	5708	10 ;;6;;12 ;1^2;1;1;1 ^5;1;1;1^1 ;2;1;2^2;2 ;1;2^4;3;3 ;3^6;;3;3^ 4;4;1;4^6; 5;1;5^2;6; 1;6^2;7;1; 7^1;8;8;8^ 6;;1;9^11; 9;1;9^4;10 ;1;10^4;10 ;1;11^17;1 1;5;12^18; 11;5;12^2; 12;1;13^6; ;1;13^1;;6 ;14^2;;1;1 5^1;;1;16^ 4;;6;17^1; ;1;18^5;;1 ;19^5;;3;2 0
	5709	"RTN","DGP TR1",46,0)
	5710	;
	5711	"RTN","DGP TR1",47,0)
	5712	101 ;;4;;1 ;1^
	5713	"RTN","DGP TR1",48,0)
	5714	70 ;;1;1;1 0;1^13;2;2 ;2^1;3;1;3 ^4;4;1;4^4 ;5;1;5^6;; 1;6^4;7;3; 7^6;;3;7^4 ;8;3;8^6;9 ;1;9^1;10; 1;10^9;11; 1;11^11;11 ;2;11^6;;3 ;11^10;11; 1;11^6;;1; 12^15;;6;1 3
	5715	"RTN","DGP TR1",49,0)
	5716	;701 is p art 2 of 7 0
	5717	"RTN","DGP TR1",50,0)
	5718	701 ;;15;; 2;1^1;;3;2 ^4;;1;3^4; ;1;4^12;;1 ;5^4;;3;5^ 4;;1;6^4;; 4;7^4;;1;8 ^5;;3;9^5; ;1;10^5;;1 ;11^13;12; 2;12^13;13 ;12;13^5;; 1;14^5;;1; 15^6;;3;16 ^5;;1;17
	5719	"RTN","DGP TR1",51,0)
	5720	;
	5721	"RTN","DGP TR1",52,0)
	5722	50 ;;1;1;1 0;1^1;;6;2 ^16;3;2;3^ 1;4;3;4^1; 5;3;5^6;;1 ;6^11;7;3; 7^6;;32;7^ 6;;9;8^14; ;6;9^14;;2 ;10^6;;1;1 1^4;;1;16^ 4;;1;17^12 ;;1;18^4;; 3;18^4;;1; 19^4;;4;20 ^4;;1;21^5 ;;3;22^5;; 1;23^5;;1; 24
	5723	"RTN","DGP TR1",53,0)
	5724	;
	5725	"RTN","DGP TR1",54,0)
	5726	53 ;;1;;10 ;1^1;;6;2^ 13;;2;3^1; ;6;4^13;;2 ;5^1;;3;6^ 1;;3;7^3;; 9;8^3;;54;
	5727	"RTN","DGP TR1",55,0)
	5728	;
	5729	"RTN","DGP TR1",56,0)
	5730	40 ;;1;1;1 0;1^1;2;2; 2^11;3;1;3 ^4;4;1;4^6 ;5;1;5^4;6 ;1;6^11;7; 2;7^6;;3;7 ^3;7;2;7^6 ;;5;7^3;7; 2;7^6;;5;7 ^3;7;2;7^6 ;;5;7^3;7; 2;7^6;;5;7 ^3;7;2;7^3 ;;9;8^4;;1 ;13^3;;34;
	5731	"RTN","DGP TR1",57,0)
	5732	;
	5733	"RTN","DGP TR1",58,0)
	5734	P40 ;;8;;1 ;^3;;11;^1 1;1;2;1^6; ;3;1^3;1;2 ;1^6;;5;1^ 3;;2;1^6;; 5;1^3;;2;1 ^6;;5;1^3; ;2;1^6;;5; 1^3;;2;1^3 ;;48
	5735	"RTN","DGP TR1",59,0)
	5736	;
	5737	"RTN","DGP TR1",60,0)
	5738	60 ;;1;1;1 0;1^13;2;2 ;2^4;3;1;3 ^4;4;3;4^1 1;5;3;5^6; ;32;5^3;;4 4
	5739	"RTN","DGP TR1",61,0)
	5740	;
	5741	"RTN","DGP TR1",62,0)
	5742	ERR ;
	5743	"RTN","DGP TR1",63,0)
	5744	S DGERR=1
	5745	"RTN","DGP TR1",64,0)
	5746	W !,T,$S( T["H":" ", 1:$E(Y,4)) ," "
	5747	"RTN","DGP TR1",65,0)
	5748	W:"45"[$E (T,1) $E(Y ,31,32),"- ",$E(Y,33, 34),"-",$E (Y,35,36), "@",$E(Y,3 7,40)
	5749	"RTN","DGP TR1",66,0)
	5750	W ?25,$P( $P(ERR,U,$ P(DGO,";", 4)),":",2) ,?40,"COL. ",F," VAL UE: ",$S($ E(Y,F)=" " :"BLANK",1 :$E(Y,F))
	5751	"RTN","DGP TR1",67,0)
	5752	S I=$S('$ D(I):1,I>0 :I,1:1),^( I)=$S($D(^ UTILITY("D G",$J,T_$S (T["H":"", 1:$E(Y,4)) ,I)):^(I), 1:U) I $P( DGO,";",2) ,^(I)'[(U_ $P(DGO,";" ,2)_U) S ^ (I)=^(I)_$ P(DGO,";", 2)_U
	5753	"RTN","DGP TR1",68,0)
	5754	Q
	5755	"RTN","DGP TR1",69,0)
	5756	;
	5757	"RTN","DGP TR1",70,0)
	5758	D10 ;
	5759	"RTN","DGP TR1",71,0)
	5760	I $E(Y,66 )="Z" S (F ,H)=68,W=" 11;10;1;10 " D L
	5761	"RTN","DGP TR1",72,0)
	5762	Q
	5763	"RTN","DGP TR1",73,0)
	5764	;
	5765	"RTN","DGP TR1",74,0)
	5766	D40 Q
	5767	"RTN","DGP TR1",75,0)
	5768	DP40 Q
	5769	"RTN","DGP TR1",76,0)
	5770	D70 I "467 "'[$E(Y,43 ) S F=44,W ="4;4;1;4^ 1;5;1;5^11 ;6;1;6" D L
	5771	"RTN","DGP TR1",77,0)
	5772	Q
	5773	"RTN","DGP TR1",78,0)
	5774	D50 I "A0" [$P(DG0,U, 5)!("A4"[$ P(DG0,U,5) )!('$D(^DG PT(J,70))) S W="11;6 ;1;6",F=55 D L
	5775	"RTN","DGP TR1",79,0)
	5776	I $D(^DGP T(J,70)),$ S(T1:1,1:+ ^(70)>2871 000) S W=" 11;6;1;6", F=55 D L
	5777	"RTN","DGP TR1",80,0)
	5778	I $E(Y,4) =1 S W="9; 7;1;7",F=5 6 D L
	5779	"RTN","DGP TR1",81,0)
	5780	I I=1,'T1 S W="1;11 ;1;11",F=1 08 D L
	5781	"RTN","DGP TR1",82,0)
	5782	Q
	5783	"RTN","DGP TR1",83,0)
	5784	D53 Q
	5785	"RTN","DGP TR1",84,0)
	5786	D60 I $E(Y ,43) S F=4 4,W="1;4;3 ;4" D L
	5787	"RTN","DGP TR1",85,0)
	5788	Q
	5789	"RTN","DGP TR1",86,0)
	5790	HEAD S ERR ="1:SSN^2: ADMISSION DATE^3:FAC ILITY #",W ="8;1;1;1^ 1;1;9;1^1; 2;10;2^1;3 ;3;3^6;;3; 3",F=5,T=" HEADER" D LOG
	5791	"RTN","DGP TR1",87,0)
	5792	D L
	5793	"RTN","DGP TR1",88,0)
	5794	Q
	5795	"RTN","DGP TR1",89,0)
	5796	LOG ;place DGLOGIC i n array in order to add more l ogic tests ;DG5.36 64
	5797	"RTN","DGP TR1",90,0)
	5798	K DGLOGIC ;S DGLOGI C=$P($T(LO GIC),";;", 2)
	5799	"RTN","DGP TR1",91,0)
	5800	N LOGX,LO GI,LOGCNT, II,XX
	5801	"RTN","DGP TR1",92,0)
	5802	S LOGI=0, LOGCNT=1
	5803	"RTN","DGP TR1",93,0)
	5804	F LOGI=0: 1 S LOGX=$ P($T(LOGIC +LOGI),";; ",2) Q:LOG X="END" F II=1:1 S XX=$P(LOGX ,U,II) Q:X X="" S DG LOGIC(LOGC NT)=XX,LOG CNT=LOGCNT +1
	5805	"RTN","DGP TR1",94,0)
	5806	Q
	5807	"RTN","DGP TR1",95,0)
	5808	CEN S T=70 ,ERR=$P($T (T70),";;" ,2),W=$P($ T(70),";;" ,2,999),W= "13;9;1;9" _$P(W,"13; 9;1;9",2,9 99),F=56 D L
	5809	"RTN","DGP TR1",96,0)
	5810	S ERR=$P( $T(T701)," ;;",2),W=$ P($T(701), ";;",2,999 ),F=72 D L
	5811	"RTN","DGP TR1",97,0)
	5812	Q
	5813	"RTN","DGP TR4")
	5814	0^24^B2223 6456^B2170 8537
	5815	"RTN","DGP TR4",1,0)
	5816	DGPTR4 ;AL B/JDS/MJK/ MTC/ADL/TJ /BOK,HIOFO /FT - PTF TRANSMISSI ON ;5/11/1 5 4:52pm
	5817	"RTN","DGP TR4",2,0)
	5818	;;5.3;Reg istration; 338,423, 415,510,56 5,645,729, 664,850,88 4,914;Au g 13, 1993 ;Build 173
	5819	"RTN","DGP TR4",3,0)
	5820	;
	5821	"RTN","DGP TR4",4,0)
	5822	; ICDXCOD E APIs - # 5699
	5823	"RTN","DGP TR4",5,0)
	5824	;
	5825	"RTN","DGP TR4",6,0)
	5826	701 ; -- s etup 701 t ransaction
	5827	"RTN","DGP TR4",7,0)
	5828	S Y=$S(T1 :"C",1:"N" )_"701"_DG HEAD,DGDDX =$P(+DG70, ".")_" ",Y=Y_$ E(DGDDX,4, 5)_$E(DGDD X,6,7)_$E( DGDDX,2,3) _$E($P(+DG 70,".",2)_ "0000",1,4 )
	5829	"RTN","DGP TR4",8,0)
	5830	S X=DG70
	5831	"RTN","DGP TR4",9,0)
	5832	;replace specialty pointer (i en) with p tf code (a lpha-numer ic)
	5833	"RTN","DGP TR4",10,0)
	5834	N DGARRX, DGARRY ;DG 729
	5835	"RTN","DGP TR4",11,0)
	5836	S DGARRX= $$TSDATA^D GACT(42.4, $P(X,U,2), .DGARRY)
	5837	"RTN","DGP TR4",12,0)
	5838	S $P(X,U, 2)=$G(DGAR RY(7))
	5839	"RTN","DGP TR4",13,0)
	5840	S (L,Z)=2 D ENTER0 K DGDDX
	5841	"RTN","DGP TR4",14,0)
	5842	S X=DG70 I "467"[($ P(X,U,3)\1 ) S Y=Y_$P (X,U,3)_" " G J
	5843	"RTN","DGP TR4",15,0)
	5844	S L=1 F Z =3:1:5 D E NTER
	5845	"RTN","DGP TR4",16,0)
	5846	S Y=Y_$S( $D(^DIC(45 .6,+$P(X,U ,6),0)):$P (^(0),U,2) ,1:" "),L= 3,Z=12 D E NTER S Y=Y _$E($P(X,U ,13)_" " ,1,3)
	5847	"RTN","DGP TR4",17,0)
	5848	J S L=3,Z= 8 D ENTER0
	5849	"RTN","DGP TR4",18,0)
	5850	S Y=Y_"X" _$J($P(DG7 0,U,9),1)
	5851	"RTN","DGP TR4",19,0)
	5852	N EFFDATE ,IMPDATE,D GPTDAT D E FFDATE^DGP TIC10(J)
	5853	"RTN","DGP TR4",20,0)
	5854	S DGPTTMP =$$ICDDATA ^ICDXCODE( "DIAG",+$P (DG70,U,10 ),EFFDATE, "I")
	5855	"RTN","DGP TR4",21,0)
	5856	S DGXLS=$ S(+DGPTTMP >0&($P(DGP TTMP,U,10) ):$P(DGPTT MP,U,2),1: ""),Y=Y_$S (DGXLS["." :$J($P(DGX LS,".",1), 3)_$E($P(D GXLS,".",2 )_" ",1, 3),1:$J(DG XLS,6))_" "
	5857	"RTN","DGP TR4",22,0)
	5858	S L=$P(DG 70,U,16,24 )_U_DG71 S DG702=""
	5859	"RTN","DGP TR4",23,0)
	5860	F K=1:1:1 2 S DGPTTM P=$$ICDDAT A^ICDXCODE ("DIAG",+$ P(L,U,K),E FFDATE,"I" ) I +DGPTT MP>0&($P(D GPTTMP,U,1 0)) S DG70 2=DG702_$P (DGPTTMP,U ,2)_U
	5861	"RTN","DGP TR4",24,0)
	5862	S Y=Y_$S( DG702']"": "X",1:" ")
	5863	"RTN","DGP TR4",25,0)
	5864	; -- get phy cdr @ d/c
	5865	"RTN","DGP TR4",26,0)
	5866	S X="",Z= +$O(^DGPT( J,535,"AM" ,DG70-.000 0001)) I $ D(^DGPT(J, 535,+$O(^( Z,0)),0)) S X=^(0)
	5867	"RTN","DGP TR4",27,0)
	5868	; -- set phy cdr
	5869	"RTN","DGP TR4",28,0)
	5870	S Z=$P(X, U,16) D CD R
	5871	"RTN","DGP TR4",29,0)
	5872	; -- set phy spec
	5873	"RTN","DGP TR4",30,0)
	5874	;replace specialty pointer (i en) with p tf code (a lpha-numer ic)
	5875	"RTN","DGP TR4",31,0)
	5876	N DGARRX, DGARRY ;DG 729
	5877	"RTN","DGP TR4",32,0)
	5878	S DGARRX= $$TSDATA^D GACT(42.4, $P(X,U,2), .DGARRY)
	5879	"RTN","DGP TR4",33,0)
	5880	S $P(X,U, 2)=$G(DGAR RY(7))
	5881	"RTN","DGP TR4",34,0)
	5882	S L=2,Z=2 D ENTER0
	5883	"RTN","DGP TR4",35,0)
	5884	S X=$S($P (DG3,U)="Y ":$$RTEN($ P(DG3,U,2) ),1:"0"),L =3,Z=1 D E NTER0
	5885	"RTN","DGP TR4",36,0)
	5886	;-- addit ional ptf questions
	5887	"RTN","DGP TR4",37,0)
	5888	S DGAUX=$ S($D(^DGPT (J,300)):^ (300),1:"" )
	5889	"RTN","DGP TR4",38,0)
	5890	D ADDQUES
	5891	"RTN","DGP TR4",39,0)
	5892	K DGAUX,D GDRUG
	5893	"RTN","DGP TR4",40,0)
	5894	;-- sc,ao ,ir,ec que stions
	5895	"RTN","DGP TR4",41,0)
	5896	S X=DG70
	5897	"RTN","DGP TR4",42,0)
	5898	;-- sc
	5899	"RTN","DGP TR4",43,0)
	5900	S Y=Y_$E( $P(DG70,U, 25)_" ")
	5901	"RTN","DGP TR4",44,0)
	5902	;-- ao
	5903	"RTN","DGP TR4",45,0)
	5904	S Y=Y_$E( $P(DG70,U, 26)_" ")
	5905	"RTN","DGP TR4",46,0)
	5906	;-- ir
	5907	"RTN","DGP TR4",47,0)
	5908	S Y=Y_$E( $P(DG70,U, 27)_" ")
	5909	"RTN","DGP TR4",48,0)
	5910	;-- SW As ia conditi ons/ec
	5911	"RTN","DGP TR4",49,0)
	5912	S Y=Y_$E( $P(DG70,U, 28)_" ")
	5913	"RTN","DGP TR4",50,0)
	5914	;-- mst
	5915	"RTN","DGP TR4",51,0)
	5916	S Y=Y_$E( $P(DG70,U, 29)_" ")
	5917	"RTN","DGP TR4",52,0)
	5918	;-- Head/ Neck CA
	5919	"RTN","DGP TR4",53,0)
	5920	S Y=Y_$E( $P(DG70,U, 30)_" ")
	5921	"RTN","DGP TR4",54,0)
	5922	D ETHNIC
	5923	"RTN","DGP TR4",55,0)
	5924	D RACE
	5925	"RTN","DGP TR4",56,0)
	5926	;Combat v et
	5927	"RTN","DGP TR4",57,0)
	5928	S Y=Y_$E( $P(DG70,U, 31)_" ")
	5929	"RTN","DGP TR4",58,0)
	5930	;Project 112/SHAD
	5931	"RTN","DGP TR4",59,0)
	5932	S Y=Y_$E( $P(DG70,U, 32)_" ")
	5933	"RTN","DGP TR4",60,0)
	5934	;Camp Lej eune AF - RSD 2.6.5. 6 PTF TRAN SMISSION v ia MailMan DG5.391 4
	5935	"RTN","DGP TR4",61,0)
	5936	; 914 add ed 3 space s between SHAD and C LV for a f uture ASIH project, Bed Contro l
	5937	"RTN","DGP TR4",62,0)
	5938	S $E(Y,11 3)=$E($P(D G70,U,33)_ " ")
	5939	"RTN","DGP TR4",63,0)
	5940	D FILL^DG PTR2 ;pad to 125 cha racters
	5941	"RTN","DGP TR4",64,0)
	5942	I T1 F K= 41:1:55,65 :1:73 S $E (Y,K)=" " ;send spac es if cens us
	5943	"RTN","DGP TR4",65,0)
	5944	I T1 D CE N^DGPTR1 D :'DGERR SA VE70X Q
	5945	"RTN","DGP TR4",66,0)
	5946	I 'T1 D S AVE
	5947	"RTN","DGP TR4",67,0)
	5948	702 ;
	5949	"RTN","DGP TR4",68,0)
	5950	Q:DG702'] ""
	5951	"RTN","DGP TR4",69,0)
	5952	S Y="N702 "_$E(Y,5,4 0)
	5953	"RTN","DGP TR4",70,0)
	5954	F K=1:1:1 2 S F=$P(D G702,U,K), F=$P(F,"." ,1)_$E($P( F,".",2)_" ",1,3), F=F_$E(" ",1,7- $L(F)),Y=Y _F
	5955	"RTN","DGP TR4",71,0)
	5956	D FILL^DG PTR2 ;pad to 125 cha racters
	5957	"RTN","DGP TR4",72,0)
	5958	I 'DGERR D SAVE70X
	5959	"RTN","DGP TR4",73,0)
	5960	I DGERR'> 0 S DGACNT =DGACNT+1, ^TMP("AEDI T",$J,$E(Y ,1,4),DGAC NT)=Y
	5961	"RTN","DGP TR4",74,0)
	5962	S DG702=$ P(DG702,U, 6,9)
	5963	"RTN","DGP TR4",75,0)
	5964	Q
	5965	"RTN","DGP TR4",76,0)
	5966	;
	5967	"RTN","DGP TR4",77,0)
	5968	ENTER S Y= Y_$J($P(X, U,Z),L)
	5969	"RTN","DGP TR4",78,0)
	5970	Q
	5971	"RTN","DGP TR4",79,0)
	5972	;
	5973	"RTN","DGP TR4",80,0)
	5974	ENTER0 S Y =Y_$S($P(X ,U,Z)]"":$ E("00000", $L($P(X,U, Z))+1,L)_$ P(X,U,Z),1 :$J($P(X,U ,Z),L))
	5975	"RTN","DGP TR4",81,0)
	5976	Q
	5977	"RTN","DGP TR4",82,0)
	5978	;
	5979	"RTN","DGP TR4",83,0)
	5980	SAVE ;vali date data and save t o MailMan message & ^TMP("AEDI T",$J)
	5981	"RTN","DGP TR4",84,0)
	5982	D SAVE^DG PTR2
	5983	"RTN","DGP TR4",85,0)
	5984	Q ;
	5985	"RTN","DGP TR4",86,0)
	5986	Q
	5987	"RTN","DGP TR4",87,0)
	5988	SAVE70X ;p ad with sp aces, set 383rd char acter & sa ve to Mail Man messag e.
	5989	"RTN","DGP TR4",88,0)
	5990	N DGY1,DG Y2
	5991	"RTN","DGP TR4",89,0)
	5992	D FILL384 ^DGPTR2
	5993	"RTN","DGP TR4",90,0)
	5994	S DGY1=$E (Y,1,240), DGY2=$E(Y, 241,384)
	5995	"RTN","DGP TR4",91,0)
	5996	S ^XMB(3. 9,DGXMZ,2, DGCNT,0)=D GY1,DGCNT= DGCNT+1
	5997	"RTN","DGP TR4",92,0)
	5998	S ^XMB(3. 9,DGXMZ,2, DGCNT,0)=D GY2,DGCNT= DGCNT+1
	5999	"RTN","DGP TR4",93,0)
	6000	Q
	6001	"RTN","DGP TR4",94,0)
	6002	;
	6003	"RTN","DGP TR4",95,0)
	6004	CDR S Y=Y_ $E($P(Z,". ")_"0000", 1,4)_$E($P (Z,".",2)_ "00",1,2)
	6005	"RTN","DGP TR4",96,0)
	6006	Q
	6007	"RTN","DGP TR4",97,0)
	6008	ADDQUES ;- - addition al PTF que stions loa d records for trans 501/701
	6009	"RTN","DGP TR4",98,0)
	6010	N DGADDQ
	6011	"RTN","DGP TR4",99,0)
	6012	F DGADDQ= 2,3,4 D ; null resul ts if disc harge>inac tive date. DG/729
	6013	"RTN","DGP TR4",100,0 )
	6014	. I +$P($ G(^DIC(45. 88,DGADDQ, 0)),U,3) S $P(DGAUX, U,DGADDQ)= $S((+$G(^D GPT(J,70)) <$P(^DIC(4 5.88,DGADD Q,0),U,3)) :$P(DGAUX, U,DGADDQ), 1:"")
	6015	"RTN","DGP TR4",101,0 )
	6016	S DGDRUG= $S($D(^DIC (45.61,+$P (DGAUX,U,4 ),0)):$P(^ (0),U,2),1 :" ")
	6017	"RTN","DGP TR4",102,0 )
	6018	S Y=Y_$E( $P(DGAUX,U ,3)_" ")_$ E($P(DGAUX ,U,2)_" ") _$J($P(DGD RUG,U),4)
	6019	"RTN","DGP TR4",103,0 )
	6020	S Y=Y_$E( $P(DGAUX,U ,5)_" ")
	6021	"RTN","DGP TR4",104,0 )
	6022	S DGT=0,X =$P(DGAUX, U,6) I X]" " S DGT=1, Z=1,L=2 D ENTER0
	6023	"RTN","DGP TR4",105,0 )
	6024	I 'DGT S Y=Y_" "
	6025	"RTN","DGP TR4",106,0 )
	6026	S DGT=0,X =$P(DGAUX, U,7) I X]" " S DGT=1, Z=1,L=2 D ENTER0
	6027	"RTN","DGP TR4",107,0 )
	6028	I 'DGT S Y=Y_" "
	6029	"RTN","DGP TR4",108,0 )
	6030	Q
	6031	"RTN","DGP TR4",109,0 )
	6032	RTEN(X) ; This funct ion will r ound X to the neares t multiple of ten.
	6033	"RTN","DGP TR4",110,0 )
	6034	; 0-4 ->D OWN; 5-9-> UP
	6035	"RTN","DGP TR4",111,0 )
	6036	Q (X\10)* 10+$S(X#10 >4:10,1:0)
	6037	"RTN","DGP TR4",112,0 )
	6038	ETHNIC ;-- Ethnicity (use firs t active v alue)
	6039	"RTN","DGP TR4",113,0 )
	6040	N NODE,NU M,ETHNIC,I ,X
	6041	"RTN","DGP TR4",114,0 )
	6042	S ETHNIC= ""
	6043	"RTN","DGP TR4",115,0 )
	6044	S I=0
	6045	"RTN","DGP TR4",116,0 )
	6046	S NUM=1
	6047	"RTN","DGP TR4",117,0 )
	6048	F S I=+$ O(DG06(I)) Q:'I D Q:NUM>1
	6049	"RTN","DGP TR4",118,0 )
	6050	.S NODE=$ G(DG06(I,0 ))
	6051	"RTN","DGP TR4",119,0 )
	6052	.Q:('NODE )!('$D(^DI C(10.2,+NO DE,0)))
	6053	"RTN","DGP TR4",120,0 )
	6054	.Q:$$INAC TIVE^DGUTL 4(+NODE,2)
	6055	"RTN","DGP TR4",121,0 )
	6056	.S X=$$PT R2CODE^DGU TL4(+NODE, 2,4)
	6057	"RTN","DGP TR4",122,0 )
	6058	.S ETHNIC =$S(X="":" ",1:X)
	6059	"RTN","DGP TR4",123,0 )
	6060	.S X=$$PT R2CODE^DGU TL4(+$P(NO DE,"^",2), 3,4)
	6061	"RTN","DGP TR4",124,0 )
	6062	.S ETHNIC =ETHNIC_$S (X="":" ", 1:X)
	6063	"RTN","DGP TR4",125,0 )
	6064	.S NUM=NU M+1
	6065	"RTN","DGP TR4",126,0 )
	6066	S Y=Y_$S( ETHNIC="": " ",1:ETH NIC)
	6067	"RTN","DGP TR4",127,0 )
	6068	Q
	6069	"RTN","DGP TR4",128,0 )
	6070	RACE ;-- R ace (use f irst 6 act ive values )
	6071	"RTN","DGP TR4",129,0 )
	6072	N NODE,NU M,RACE,I,X
	6073	"RTN","DGP TR4",130,0 )
	6074	S RACE=""
	6075	"RTN","DGP TR4",131,0 )
	6076	S I=0
	6077	"RTN","DGP TR4",132,0 )
	6078	S NUM=1
	6079	"RTN","DGP TR4",133,0 )
	6080	F S I=+$ O(DG02(I)) Q:'I D Q:NUM>6
	6081	"RTN","DGP TR4",134,0 )
	6082	.S NODE=$ G(DG02(I,0 ))
	6083	"RTN","DGP TR4",135,0 )
	6084	.Q:('NODE )!('$D(^DI C(10,+NODE ,0)))
	6085	"RTN","DGP TR4",136,0 )
	6086	.Q:$$INAC TIVE^DGUTL 4(+NODE)
	6087	"RTN","DGP TR4",137,0 )
	6088	.S X=$$PT R2CODE^DGU TL4(+NODE, 1,4)
	6089	"RTN","DGP TR4",138,0 )
	6090	.S RACE=R ACE_$S(X=" ":" ",1:X)
	6091	"RTN","DGP TR4",139,0 )
	6092	.S X=$$PT R2CODE^DGU TL4(+$P(NO DE,"^",2), 3,4)
	6093	"RTN","DGP TR4",140,0 )
	6094	.S RACE=R ACE_$S(X=" ":" ",1:X)
	6095	"RTN","DGP TR4",141,0 )
	6096	.S NUM=NU M+1
	6097	"RTN","DGP TR4",142,0 )
	6098	S X="" S $P(X," ",1 2)=""
	6099	"RTN","DGP TR4",143,0 )
	6100	S RACE=$S (RACE="":" ",1:RACE )_X
	6101	"RTN","DGP TR4",144,0 )
	6102	S Y=Y_$E( RACE,1,12)
	6103	"RTN","DGP TR4",145,0 )
	6104	Q
	6105	"RTN","DGP TRI0")
	6106	0^25^B2777 7148^B2714 1499
	6107	"RTN","DGP TRI0",1,0)
	6108	DGPTRI0 ;M JK/JS/ADL/ TJ,ISF/GJW ,HIOFO/FT - PTF TRAN SMISSION ; 4/9/15 2:5 7pm
	6109	"RTN","DGP TRI0",2,0)
	6110	;;5.3;Reg istration; 850,884, 914;Aug 13, 1993;B uild 173
	6111	"RTN","DGP TRI0",3,0)
	6112	;;ADL;Upd ate for CS V Project; ;Mar 27, 2 003
	6113	"RTN","DGP TRI0",4,0)
	6114	;
	6115	"RTN","DGP TRI0",5,0)
	6116	; ICDXCOD E APIs - 5 699
	6117	"RTN","DGP TRI0",6,0)
	6118	; SDCO22 APIs - 157 9
	6119	"RTN","DGP TRI0",7,0)
	6120	; XLFSTR APIs - 101 04
	6121	"RTN","DGP TRI0",8,0)
	6122	;
	6123	"RTN","DGP TRI0",9,0)
	6124	; -- setu p control data
	6125	"RTN","DGP TRI0",10,0 )
	6126	; ssn
	6127	"RTN","DGP TRI0",11,0 )
	6128	S X=$P(DG 10,U,9),Y= $S($E(X,10 )="P":"P", 1:" ")_$E( X_" ",1,9)
	6129	"RTN","DGP TRI0",12,0 )
	6130	; -- adm d/t
	6131	"RTN","DGP TRI0",13,0 )
	6132	S X=$P($P (DG0,U,2), "."),Y=Y_$ E(X,4,5)_$ E(X,6,7)_$ E(X,2,3)_$ E($P($P(DG 0,U,2),"." ,2)_"0000" ,1,4)
	6133	"RTN","DGP TRI0",14,0 )
	6134	; -- faci lity #
	6135	"RTN","DGP TRI0",15,0 )
	6136	S L=3,X=D G0,Z=3 D E NTER S Y=Y _$E($P(X,U ,5)_" ", 1,3)
	6137	"RTN","DGP TRI0",16,0 )
	6138	S DGHEAD= Y,Y=" " _Y D HEAD^ DGPTRI1
	6139	"RTN","DGP TRI0",17,0 )
	6140	;
	6141	"RTN","DGP TRI0",18,0 )
	6142	101 ; -- s etup 101 t ransmissio n
	6143	"RTN","DGP TRI0",19,0 )
	6144	; control data and name
	6145	"RTN","DGP TRI0",20,0 )
	6146	S $E(Y,1, 30)=$S(T1: "C",1:"N") _"101"_DGH EAD
	6147	"RTN","DGP TRI0",21,0 )
	6148	S $E(Y,31 ,44)=$$PTF NMFT($P(DG 10,U))
	6149	"RTN","DGP TRI0",22,0 )
	6150	; source of admissi on - $E(Y, 45,46)
	6151	"RTN","DGP TRI0",23,0 )
	6152	S $E(Y,45 ,46)=$S($D (^DIC(45.1 ,+DG101,0) ):$J($P(^( 0),U,1),2) ,1:" ")
	6153	"RTN","DGP TRI0",24,0 )
	6154	; xfring fac and su ffix - $E( Y,47,49) & $E(Y,50,5 2)
	6155	"RTN","DGP TRI0",25,0 )
	6156	S L=3,X=D G101,Z=5 D FORMAT S $E(Y,47,49 )=DGVALUE S $E(Y,50, 52)=$E($P( X,U,6)_" ",1,3)
	6157	"RTN","DGP TRI0",26,0 )
	6158	; source of payment - $E(Y,53 )
	6159	"RTN","DGP TRI0",27,0 )
	6160	S $E(Y,53 )=$S("A0"[ $P(DG0,U,5 ):" ",1:$J ($P(DG101, U,3),1))
	6161	"RTN","DGP TRI0",28,0 )
	6162	;POW Loca tion $E(Y, 54)
	6163	"RTN","DGP TRI0",29,0 )
	6164	S $E(Y,54 )=$S($P(DG 52,U,5)="N ":1,$P(DG5 2,U,5)'="Y ":3,$P(DG5 2,U,6)>0&( $P(DG52,U, 6)<7):3+$P (DG52,U,6) ,$P(DG52,U ,6)>6&($P( DG52,U,6)< 9):$C($P(D G52,U,6)+5 8),1:" ")
	6165	"RTN","DGP TRI0",30,0 )
	6166	;marital status, se x - $E(Y,5 5) & $E(Y, 56)
	6167	"RTN","DGP TRI0",31,0 )
	6168	S $E(Y,55 ,56)=$S($D (^DIC(11,+ $P(DG10,U, 5),0)):$E( ^(0),1),1: " ")_$J($P (DG10,U,2) ,1)
	6169	"RTN","DGP TRI0",32,0 )
	6170	; date o f birth - $E(Y,57,64 )
	6171	"RTN","DGP TRI0",33,0 )
	6172	S DGDOB=$ P(DG10,U,3 )\1,$E(Y,5 7,64)=$E(D GDOB,4,5)_ $E(DGDOB,6 ,7)_(1700+ $E(DGDOB,1 ,3))
	6173	"RTN","DGP TRI0",34,0 )
	6174	S $E(Y,65 )=" " ;bla nk, not us ed
	6175	"RTN","DGP TRI0",35,0 )
	6176	; period of service - $E(Y,66 )
	6177	"RTN","DGP TRI0",36,0 )
	6178	S DGPOS=$ S($D(^DIC( 21,+$P(DG3 2,U,3),0)) :$P(^(0),U ,3),1:"")
	6179	"RTN","DGP TRI0",37,0 )
	6180	I $D(^DGP M(+$O(^DGP M("APTF",J ,0)),"ODS" )),+^("ODS ") S DGPOS =6
	6181	"RTN","DGP TRI0",38,0 )
	6182	;-- if no n vet admi tting elig ibility ma ke POS 9
	6183	"RTN","DGP TRI0",39,0 )
	6184	S DGPOS=$ $CKPOS^DGP TUTL($P($G (^DGPT(PTF ,101)),U,8 ),DGPOS)
	6185	"RTN","DGP TRI0",40,0 )
	6186	S X=DGPOS ,Z=1,L=1 D FORMAT S $E(Y,66)=D GVALUE
	6187	"RTN","DGP TRI0",41,0 )
	6188	; agent o range - $E (Y,67)
	6189	"RTN","DGP TRI0",42,0 )
	6190	S G=" " S DGAO=$P(D G321,U,2) S:DGPOS=7 G=$S($P(DG 321,U)'="Y ":1,DGAO=" N":2,DGAO= "Y":3,1:4) S:(DGAO=" Y")&($P(DG 321,U,13)= "K") G=5
	6191	"RTN","DGP TRI0",43,0 )
	6192	; rad exp osure - $E (Y,68)
	6193	"RTN","DGP TRI0",44,0 )
	6194	;patch 88 4 - use th e correct numeric co des (from the DD)
	6195	"RTN","DGP TRI0",45,0 )
	6196	S E=" " I "^0^2^4^5 ^7^8^Z^"[( U_DGPOS_U) S (E,DGNT )=$P(DG321 ,U,12)
	6197	"RTN","DGP TRI0",46,0 )
	6198	S $E(Y,67 ,68)=G_E K DGPOS,G,E
	6199	"RTN","DGP TRI0",47,0 )
	6200	; state c ode - $E(Y ,69,70)
	6201	"RTN","DGP TRI0",48,0 )
	6202	S X=$S($D (^DIC(5,+$ P(DG11,U,5 ),0)):^(0) ,1:""),L=2 ,Z=3 D FOR MAT0 S $E( Y,69,70)=D GVALUE0
	6203	"RTN","DGP TRI0",49,0 )
	6204	; county code - $E( Y,71,73)
	6205	"RTN","DGP TRI0",50,0 )
	6206	S X=$S($D (^DIC(5,+$ P(DG11,U,5 ),1,+$P(DG 11,U,7),0) ):^(0),1:" "),L=3,Z=3 D FORMAT0 S $E(Y,71 ,73)=DGVAL UE0
	6207	"RTN","DGP TRI0",51,0 )
	6208	; zip cod e - $E(Y,7 4,78)
	6209	"RTN","DGP TRI0",52,0 )
	6210	S X=DG11, Z=6,L=5 D FORMAT S $ E(Y,74,78) =DGVALUE
	6211	"RTN","DGP TRI0",53,0 )
	6212	; means t est - $E(Y ,79,80)
	6213	"RTN","DGP TRI0",54,0 )
	6214	S $E(Y,79 ,80)=$S($P (DG70,U,26 )="Y":"AS" ,1:$E($P(D G0,U,10)_" ",1,2))
	6215	"RTN","DGP TRI0",55,0 )
	6216	; income - $E(Y,81, 86)
	6217	"RTN","DGP TRI0",56,0 )
	6218	I $L($P(D G101,U,7)) >6 S $E(Y, 81,86)="99 9999"
	6219	"RTN","DGP TRI0",57,0 )
	6220	E S X=DG 101,Z=7,L= 6 D FORMAT 0 S $E(Y,8 1,86)=DGVA LUE0
	6221	"RTN","DGP TRI0",58,0 )
	6222	;MST - $E (Y,87)
	6223	"RTN","DGP TRI0",59,0 )
	6224	S X=$$GET STAT^DGMST API(+DG0) S $E(Y,87) =$S(X<0:"U ",1:$P(X," ^",2))
	6225	"RTN","DGP TRI0",60,0 )
	6226	;Combat V et $E(Y,88 ) & $E(Y,8 9,94)
	6227	"RTN","DGP TRI0",61,0 )
	6228	S X=$$CVE DT^DGCV(+D G0,$P(DG0, "^",2)) S $E(Y,88)=$ S((+X)>0:1 ,1:0)
	6229	"RTN","DGP TRI0",62,0 )
	6230	S X=$P(X, "^",2)_" " S $ E(Y,89,94) =$E(X,4,5) _$E(X,6,7) _$E(X,2,3)
	6231	"RTN","DGP TRI0",63,0 )
	6232	;Project 112/SHAD - $E(Y,95)
	6233	"RTN","DGP TRI0",64,0 )
	6234	S X=$$SHA D^SDCO22(+ DG0) S $E( Y,95)=$S(( +X)>0:1,1: 0)
	6235	"RTN","DGP TRI0",65,0 )
	6236	;Emergenc y Response Indicator - $E(Y,96 )
	6237	"RTN","DGP TRI0",66,0 )
	6238	S X=$$EMG RES^DGUTL( +DG0) S $E (Y,96)=$S( "^K^"[(U_X _U):X,1:" ")
	6239	"RTN","DGP TRI0",67,0 )
	6240	;Country Code - $E( Y,97,99)
	6241	"RTN","DGP TRI0",68,0 )
	6242	S X=$$GET 1^DIQ(779. 004,$P(DG1 1,U,10)_", ",.01),Z=1 ,L=3 D FOR MAT S $E(Y ,97,99)=DG VALUE
	6243	"RTN","DGP TRI0",69,0 )
	6244	;Camp Lej eune AF - RSD 2.6.5. 6 PTF TRAN SMISSION v ia MailMan DG5.391 4
	6245	"RTN","DGP TRI0",70,0 )
	6246	S X=$$GET CL^DGUTL3( +DG0)
	6247	"RTN","DGP TRI0",71,0 )
	6248	S Y=Y_$S( X=1:1,X=0: 0,1:" ")
	6249	"RTN","DGP TRI0",72,0 )
	6250	;[RESERVE D] - $E(Y, 101,112)
	6251	"RTN","DGP TRI0",73,0 )
	6252	;[NOT ALL OCATED] - $E(Y,113,3 84)
	6253	"RTN","DGP TRI0",74,0 )
	6254	K DGVALUE ,DGVALUE0
	6255	"RTN","DGP TRI0",75,0 )
	6256	D SAVE
	6257	"RTN","DGP TRI0",76,0 )
	6258	I T1 S Y= $E(Y,53)=" " ;resets SOURCE OF PAYMENT t o space
	6259	"RTN","DGP TRI0",77,0 )
	6260	;
	6261	"RTN","DGP TRI0",78,0 )
	6262	401 ; -- s etup 401 t ransaction s (402 and 403 are n o longer u sed. All s urgeries a re 401 seg ments.)
	6263	"RTN","DGP TRI0",79,0 )
	6264	G 501:'$D (^DGPT(J," S")) K ^UT ILITY($J," S") S I=0
	6265	"RTN","DGP TRI0",80,0 )
	6266	SUR ;
	6267	"RTN","DGP TRI0",81,0 )
	6268	S I=$O(^D GPT(J,"S", I)) G 501: 'I
	6269	"RTN","DGP TRI0",82,0 )
	6270	S DGSUR=^ DGPT(J,"S" ,I,0)
	6271	"RTN","DGP TRI0",83,0 )
	6272	G SUR:'DG SUR
	6273	"RTN","DGP TRI0",84,0 )
	6274	G SUR:DGS UR<T1!(DGS UR>T2) S D GSUD=+^(0) \1,^UTILIT Y($J,"S",D GSUD)=$S($ D(^UTILITY ($J,"S",DG SUD)):^(DG SUD),1:0)+ 1,F=$S(DGS UD<2871000 :0,1:1) ;^ (0) refere nces globa l 2 lines above
	6275	"RTN","DGP TRI0",85,0 )
	6276	;
	6277	"RTN","DGP TRI0",86,0 )
	6278	I ^UTILIT Y($J,"S",D GSUD)>$S(F :3,1:2) D I Y'=1 S DGERR=1 Q
	6279	"RTN","DGP TRI0",87,0 )
	6280	.W !,"T here are m ore than " ,$S(F:"thr ee",1:"two ")," surge ries on th e same dat e"
	6281	"RTN","DGP TRI0",88,0 )
	6282	.S DIR(0) ="Y",DIR(" B")="YES", DIR("A")=" OK to cont inue?" D ^ DIR K DIR
	6283	"RTN","DGP TRI0",89,0 )
	6284	;
	6285	"RTN","DGP TRI0",90,0 )
	6286	;header, date of su rgery foll owed by SP ECIALTY - $E(Y,41,42 )
	6287	"RTN","DGP TRI0",91,0 )
	6288	S Y=$S(T1 :"C",1:"N" )_"401"_DG HEAD_$E(DG SUD,4,5)_$ E(DGSUD,6, 7)_$E(DGSU D,2,3)_$E( $P(+DGSUR, ".",2)_"00 00",1,4)_$ S($D(^DIC( 45.3,+$P(D GSUR,U,3), 0)):$P(^(0 ),U,1),1:" ")
	6289	"RTN","DGP TRI0",92,0 )
	6290	;4 is CAT EGORY OF C HIEF SURGE ON - $E(Y, 43)
	6291	"RTN","DGP TRI0",93,0 )
	6292	;5 is CAT EGORY OF F IRST ASSIS TANT - $E( Y,44)
	6293	"RTN","DGP TRI0",94,0 )
	6294	;6 is ANE STHESIA TE CHNIQUE (P RINCIPAL) - $E(Y,45)
	6295	"RTN","DGP TRI0",95,0 )
	6296	;7 is SOU RCE OF PAY MENT - $E( Y,46)
	6297	"RTN","DGP TRI0",96,0 )
	6298	S L=1,X=D GSUR F Z=4 :1:7 D ENT ER
	6299	"RTN","DGP TRI0",97,0 )
	6300	N EFFDATE ,IMPDATE,D GPTDAT D E FFDATE^DGP TIC10(J)
	6301	"RTN","DGP TRI0",98,0 )
	6302	;operatio n codes 1 - 25 - $E( Y,47,246)
	6303	"RTN","DGP TRI0",99,0 )
	6304	N DG401CO DES,DGLOOP ,DGOCODE,D GSTRING,DG PTTMP
	6305	"RTN","DGP TRI0",100, 0)
	6306	D PTFICD^ DGPTFUT(40 1,J,I,.DG4 01CODES) ; get proced ure values
	6307	"RTN","DGP TRI0",101, 0)
	6308	S DGLOOP= 0,DGSTRING =""
	6309	"RTN","DGP TRI0",102, 0)
	6310	F S DGLO OP=$O(DG40 1CODES(DGL OOP)) Q:DG LOOP="" D
	6311	"RTN","DGP TRI0",103, 0)
	6312	.S DGPTTM P=$$ICDDAT A^ICDXCODE ("PROC",$P (DG401CODE S(DGLOOP), U,1),EFFDA TE,"I") ;c heck data
	6313	"RTN","DGP TRI0",104, 0)
	6314	.Q:+DGPTT MP'>0 ;do n't use if bad
	6315	"RTN","DGP TRI0",105, 0)
	6316	.S DGOCOD E=$P(DG401 CODES(DGLO OP),U,3) ; external v alue
	6317	"RTN","DGP TRI0",106, 0)
	6318	.S DGSTRI NG=DGSTRIN G_DGOCODE_ " " ;appen d space to pad to 8 characters
	6319	"RTN","DGP TRI0",107, 0)
	6320	S $E(Y,47 ,246)=DGST RING_$$REP EAT^XLFSTR (" ",200-$ L(DGSTRING ))
	6321	"RTN","DGP TRI0",108, 0)
	6322	;-- att p hy [NOT AC TIVATED - $E(Y,247,2 56)]
	6323	"RTN","DGP TRI0",109, 0)
	6324	S $E(Y,24 7,256)=" "
	6325	"RTN","DGP TRI0",110, 0)
	6326	;[RESERVE D - $E(Y,2 56,290)]
	6327	"RTN","DGP TRI0",111, 0)
	6328	;[NOT ALL OCATED - $ E(Y,291,38 4)]
	6329	"RTN","DGP TRI0",112, 0)
	6330	D SAVE G SUR
	6331	"RTN","DGP TRI0",113, 0)
	6332	501 G 501^ DGPTRI2
	6333	"RTN","DGP TRI0",114, 0)
	6334	Q
	6335	"RTN","DGP TRI0",115, 0)
	6336	FORMAT ;fo rmat value
	6337	"RTN","DGP TRI0",116, 0)
	6338	S DGVALUE =$J($P(X,U ,Z),L)
	6339	"RTN","DGP TRI0",117, 0)
	6340	Q
	6341	"RTN","DGP TRI0",118, 0)
	6342	FORMAT0 ;f ormat valu e with zer os
	6343	"RTN","DGP TRI0",119, 0)
	6344	S DGVALUE 0=$S($P(X, U,Z)]"":$E ("000000", $L($P(X,U, Z))+1,L)_$ P(X,U,Z),1 :$J($P(X,U ,Z),L))
	6345	"RTN","DGP TRI0",120, 0)
	6346	Q
	6347	"RTN","DGP TRI0",121, 0)
	6348	;
	6349	"RTN","DGP TRI0",122, 0)
	6350	ENTER S Y= Y_$J($P(X, U,Z),L)
	6351	"RTN","DGP TRI0",123, 0)
	6352	Q
	6353	"RTN","DGP TRI0",124, 0)
	6354	ENTER0 S Y =Y_$S($P(X ,U,Z)]"":$ E("000000" ,$L($P(X,U ,Z))+1,L)_ $P(X,U,Z), 1:$J($P(X, U,Z),L))
	6355	"RTN","DGP TRI0",125, 0)
	6356	Q
	6357	"RTN","DGP TRI0",126, 0)
	6358	SAVE ;
	6359	"RTN","DGP TRI0",127, 0)
	6360	D SAVE^DG PTRI2
	6361	"RTN","DGP TRI0",128, 0)
	6362	Q Q
	6363	"RTN","DGP TRI0",129, 0)
	6364	DGNAM S X= DGNAM I X? .E.P F I=1 :1:$L(X) S Z=$E(X,I) Q:Z="," S:Z?.P&(Z] "") X=$E(X ,1,I-1)_$E (X,I+1,$L( X)),I=I-1 Q:X'?.E.P
	6365	"RTN","DGP TRI0",130, 0)
	6366	I X?.E.L D UP^DGHEL P
	6367	"RTN","DGP TRI0",131, 0)
	6368	S DGNAM=X
	6369	"RTN","DGP TRI0",132, 0)
	6370	Q
	6371	"RTN","DGP TRI0",133, 0)
	6372	;
	6373	"RTN","DGP TRI0",134, 0)
	6374	PTFNMFT(DG 10) ;this function w ill format the name of the pat ient for
	6375	"RTN","DGP TRI0",135, 0)
	6376	; transmi ssion of t he 101 rec ord to Aus tin. In ad dition, th is
	6377	"RTN","DGP TRI0",136, 0)
	6378	; functio n will be used by OP C so that the format will be c onsistent
	6379	"RTN","DGP TRI0",137, 0)
	6380	; for OPC and PTF.
	6381	"RTN","DGP TRI0",138, 0)
	6382	; INPUT : DG10 - .01 field from the patient re cord.
	6383	"RTN","DGP TRI0",139, 0)
	6384	; OUTPUT : name i n the form at proper format.
	6385	"RTN","DGP TRI0",140, 0)
	6386	; A = <12 - characters of last n ame padded with blan ks>
	6387	"RTN","DGP TRI0",141, 0)
	6388	; B = <1 - first init ial of fis t name>
	6389	"RTN","DGP TRI0",142, 0)
	6390	; C = <1 - first init ial of mid dle name>
	6391	"RTN","DGP TRI0",143, 0)
	6392	; re turns :ABC <14 - cha racters>
	6393	"RTN","DGP TRI0",144, 0)
	6394	N X,I
	6395	"RTN","DGP TRI0",145, 0)
	6396	S DGNAM=D G10 D DGNA M
	6397	"RTN","DGP TRI0",146, 0)
	6398	Q $E($P(D GNAM,",",1 )_" ",1,12 )_$J($E($P (DGNAM,"," ,2),1),1)_ $J($E($P($ P(DGNAM,", ",2)," ",2 ),1),1)
	6399	"RTN","DGP TRI1")
	6400	0^78^B4827 6824^B4568 2125
	6401	"RTN","DGP TRI1",1,0)
	6402	DGPTRI1 ;A LB/MTC,HIO FO/FT - PT F VERIFICA TION ;07/2 1/2015 7: 14 AM
	6403	"RTN","DGP TRI1",2,0)
	6404	;;5.3;Reg istration; 850,884, 914;Aug 13, 1993;B uild 173
	6405	"RTN","DGP TRI1",3,0)
	6406	;;Updated DGPTR1 fo r ICD-10 T ransmissio n;;2/28/20 12 - 850
	6407	"RTN","DGP TRI1",4,0)
	6408	;
	6409	"RTN","DGP TRI1",5,0)
	6410	;no exter nal refere nces
	6411	"RTN","DGP TRI1",6,0)
	6412	;
	6413	"RTN","DGP TRI1",7,0)
	6414	START ; Ca lled from other DGPT RI* routin es to do d ata valida tion and d isplay err ors
	6415	"RTN","DGP TRI1",8,0)
	6416	;How this validatio n works:
	6417	"RTN","DGP TRI1",9,0)
	6418	; Y is th e segment (e.g., 101 , 401) cha racter str ing
	6419	"RTN","DGP TRI1",10,0 )
	6420	; Figure out which segment it is. Chara cters 2 & 3 will be either 10, 40, 50, 5 3, 60 or 7 0. (i.e., T)
	6421	"RTN","DGP TRI1",11,0 )
	6422	; Set ERR to a text line (e.g ., T10) wh ich has th e field or der and na me in the segment. ( e.g., 1:NA ME)
	6423	"RTN","DGP TRI1",12,0 )
	6424	; The pat ient name is the fir st field t o be check ed.
	6425	"RTN","DGP TRI1",13,0 )
	6426	; Set W t o a text l ine (e.g., 10) which has four numbers de limited by semi-colo ns for eac h "^" piec e.
	6427	"RTN","DGP TRI1",14,0 )
	6428	; Each "^ " piece co rresponds to a field in the se gment stri ng (Y). Th ere can be more than one "^" p iece
	6429	"RTN","DGP TRI1",15,0 )
	6430	; for eac h field.
	6431	"RTN","DGP TRI1",16,0 )
	6432	; Set F t o the firs t characte r of the s egment to begin chec king.
	6433	"RTN","DGP TRI1",17,0 )
	6434	; The cha racters pr ior to 31 are "Contr ol Data" v alues such as SSN an d Admissio n Date/Tim e.
	6435	"RTN","DGP TRI1",18,0 )
	6436	; DO L wh ich loops through th e various text lines such as T 10 and 10 and valida te the cha racters wi th
	6437	"RTN","DGP TRI1",19,0 )
	6438	; pattern match cod e defined in the LOG IC subrout ine.
	6439	"RTN","DGP TRI1",20,0 )
	6440	; If the pattern ma tch fails, the ERR s ubroutine is called and an err or message is writte n to the s creen.
	6441	"RTN","DGP TRI1",21,0 )
	6442	; Finally , do any D nn subrout ines which have addi tional che cks.
	6443	"RTN","DGP TRI1",22,0 )
	6444	;
	6445	"RTN","DGP TRI1",23,0 )
	6446	Q:$E(Y,2, 4)=702 ;c ome back t o?
	6447	"RTN","DGP TRI1",24,0 )
	6448	S T=$E(Y, 2,3) ;dete rmine segm ent
	6449	"RTN","DGP TRI1",25,0 )
	6450	S ERR=$P( $T(@("T"_T )),";;",2, 999),W=$P( $T(@(T))," ;;",2,999) ,F=31 D L
	6451	"RTN","DGP TRI1",26,0 )
	6452	I T=70 S ERR=$P($T( T701),";;" ,2,999),W= $P($T(701) ,";;",2,99 9),F=73 D L
	6453	"RTN","DGP TRI1",27,0 )
	6454	D @("D"_T ) Q
	6455	"RTN","DGP TRI1",28,0 )
	6456	K DGFILL
	6457	"RTN","DGP TRI1",29,0 )
	6458	Q
	6459	"RTN","DGP TRI1",30,0 )
	6460	;
	6461	"RTN","DGP TRI1",31,0 )
	6462	L ;
	6463	"RTN","DGP TRI1",32,0 )
	6464	;$P(DG11, U,10) is F ILE 2, Fie ld .1173 w hich is CO UNTRY [10P :779.004]
	6465	"RTN","DGP TRI1",33,0 )
	6466	N DGFOR S DGFOR=$S( $$FORIEN^D GADDUTL($P (DG11,U,10 ))<1:0,1:1 ) ;set for eign count ry flag =1 , else, se t as domes tic
	6467	"RTN","DGP TRI1",34,0 )
	6468	F H=1:1 S DGO=$P(W, U,H) Q:'DG O D ;fin d out how many value s in the s egment you want to v alidate
	6469	"RTN","DGP TRI1",35,0 )
	6470	. F Z=1:1 :$P(DGO,"; ",3) D ;F ind out ho w many cha racters ar e in the v alue you w ant to val idate
	6471	"RTN","DGP TRI1",36,0 )
	6472	.. S DGL= DGLOGIC(+D GO) ;get t he pattern match nee ded to che ck the cha racter(s)
	6473	"RTN","DGP TRI1",37,0 )
	6474	.. S X=$E (Y,F) ;get the chara cter to va lidate
	6475	"RTN","DGP TRI1",38,0 )
	6476	.. D @("E RR:"_DGL) ;if the ch aracter fa ils the pa ttern matc h, call ER R to displ ay a messa ge
	6477	"RTN","DGP TRI1",39,0 )
	6478	.. S F=F+ 1 ;increme nt F to ge t the next character in the se gment
	6479	"RTN","DGP TRI1",40,0 )
	6480	Q
	6481	"RTN","DGP TRI1",41,0 )
	6482	;
	6483	"RTN","DGP TRI1",42,0 )
	6484	;The Tnn lines have the SEQUE NCE #:FIEL D NAME for all of th e fields i n that seg ment.
	6485	"RTN","DGP TRI1",43,0 )
	6486	;e.g., '1 :NAME' is the patien t NAME and it is the first fie ld in the 101 segmen t. SOURCE OF ADM(ISS ION) is th e second a nd so on
	6487	"RTN","DGP TRI1",44,0 )
	6488	; 101 seg ment
	6489	"RTN","DGP TRI1",45,0 )
	6490	; PWC - a dded Camp Lejeune to end of T1 0 DG5.39 14
	6491	"RTN","DGP TRI1",46,0 )
	6492	T10 ;;1:NA ME^2:SOURC E OF ADM^3 :TRANS FAC .^4:SOURCE OF PAY^5: POW^6:MARI TAL ST^7:S EX^8:DOB^9 :POS^10:VI ETNAM^11:I ON RADIATI ON^12:RESI DENCE^13:M EANS TEST^ 14:INCOME^ 15:MST^16: COMBAT VET ^17:CV END DT^18:PRO J 112/SHAD ^19:ERI^20 :COUNTRY^2 1:CAMP LEJ EUNE
	6493	"RTN","DGP TRI1",47,0 )
	6494	; 701 seg ment (part 1)
	6495	"RTN","DGP TRI1",48,0 )
	6496	T70 ;;1:DT OF DISP.^ 2:DISCH BD SEC^3:TYP E OF DIS^4 :OUT TREAT ^5:VA AUS^ 6:PL OF DI S^7:REC FA C^8:ASIH D AYS^9:RACE ^10:C&P ST AT^11:PDXL S^12:ONLY DX^13:PHY MPCR
	6497	"RTN","DGP TRI1",49,0 )
	6498	; T701 se gment (par t 2)
	6499	"RTN","DGP TRI1",50,0 )
	6500	T701 ;;1:P HY SPEC^2: %SC^3:LEGI ON^4:SUICI DE^5:DRUG^ 6:AXIS-IV^ 7:AXIS-V^8 :SC^9:EXP^ 10:MST^11: HNC^12:ETH NICITY^13: RACE^14:CO MBAT VET^1 5:PROJ 112 /SHAD^16:A SIH^17:CAM P LEJEUNE
	6501	"RTN","DGP TRI1",51,0 )
	6502	; 501 seg ment
	6503	"RTN","DGP TRI1",52,0 )
	6504	T50 ;;1:DT OF MVMT^2 :LOSING BD SEC MPCR^ 3:LOSING B D SEC^4:LE AVE DAYS^5 :PASS DAYS ^6:SCI^7:D IAG^8:DOCT OR'S SSN^9 :PHY MPCR^ 10:PHY SPE C^11:DISCH ARGE STAT^ ^^^^16:LEG ION^17:SUI CIDE^18:DR UG^19:AXIS -IV^20:AXI S-V^21:SC^ 22:EXP^23: MST^24:HNC
	6505	"RTN","DGP TRI1",53,0 )
	6506	; 535 seg ment
	6507	"RTN","DGP TRI1",54,0 )
	6508	T53 ;;1:DA TE OF PHYS ICAL MOVEM ENT^2:LOSI NG PHYSICA L MPCR^3:L OSING PHYS ICAL SPECI ALTY^4:TR SPECIALTY MPCR^5:TR SPECIALTY^ 6:LEAVE DA YS^7:PASS DAYS
	6509	"RTN","DGP TRI1",55,0 )
	6510	; 401 seg ment
	6511	"RTN","DGP TRI1",56,0 )
	6512	T40 ;;1:DA TE OF SURG ERY^2:SURG SPEC.^3:C AT CHIEF S URGEON^4:C AT FIRST A SS^5:ANEST . TECH.^6: SOURCE OF PAY^7:OP C ODE
	6513	"RTN","DGP TRI1",57,0 )
	6514	; 601 seg ment
	6515	"RTN","DGP TRI1",58,0 )
	6516	T60 ;;1:DA TE OF PROC EDURE^2:LO SING BD SE C^3:DIALYS IS TYPE^4: NUMBER OF TREATMENTS ^5:PROCEDU RE CODE
	6517	"RTN","DGP TRI1",59,0 )
	6518	;
	6519	"RTN","DGP TRI1",60,0 )
	6520	;LOGIC is a bunch o f single o r compound pattern m atches del imited by an "^". A pattern ma tch is use d in the D GL variabl e
	6521	"RTN","DGP TRI1",61,0 )
	6522	;in the L entry poi nt above a s a post-c onditional value on the ERR su broutine. If the pat tern match fails, th en ERR is
	6523	"RTN","DGP TRI1",62,0 )
	6524	;called t o write an error mes sage on th e screen t o the user .
	6525	"RTN","DGP TRI1",63,0 )
	6526	LOGIC ;;X' ?.N^X'?.A& (X'=" ")^X '=" "^X'?. N&(X'=" ") ^X'?.A&(X' =" ")^0^X' ?.N&(X'="X ")^X'=" "& (X'="P")^X ="E"^X="Y" ^X=" "^X'= "A"&(X'=" ")^(X'?.A) &(X'?.N)&( X'=" ")^(X '?.AN)&('$ P(DG0,U,4) )^((T1)&(X '=" "))!(( 'T1)&(X'?. AN)&('$P(D G0,U,4)))
	6527	"RTN","DGP TRI1",64,0 )
	6528	;;(X'?.AN )^'$D(DGFO R)&(X'?.N) ^'$D(DGFOR )&X'?.N&(X '="X")^X'? AN&X'=""^" YNUW "']X
	6529	"RTN","DGP TRI1",65,0 )
	6530	;;END
	6531	"RTN","DGP TRI1",66,0 )
	6532	;
	6533	"RTN","DGP TRI1",67,0 )
	6534	;The foll owing nn l ines are v alues used by the L entry poin t to valid ate the da ta.
	6535	"RTN","DGP TRI1",68,0 )
	6536	;Each "^" piece con tains for numbers de limited by semi-colo ns.
	6537	"RTN","DGP TRI1",69,0 )
	6538	;The firs t number i dentifies the "^" pi ece in the LOGIC str ing to get the patte rn match t o use.
	6539	"RTN","DGP TRI1",70,0 )
	6540	;The seco nd number identifies the edit field. [ne ed to elab orate on t his more].
	6541	"RTN","DGP TRI1",71,0 )
	6542	;The thir d number i dentifies the number of charac ters in th e segment to check.
	6543	"RTN","DGP TRI1",72,0 )
	6544	;The four th number identifies the a pie ce in the Tnn string (above) t o get the field name to displa y.
	6545	"RTN","DGP TRI1",73,0 )
	6546	;i.e, in "10", the first "^" piece is 6 ;;12;1
	6547	"RTN","DGP TRI1",74,0 )
	6548	;Use the pattern ma tch in the sixth "^" of the LO GIC text l ine.
	6549	"RTN","DGP TRI1",75,0 )
	6550	;The edit field is null becau se the pat ient name cannot be edited in the PTF so ftware.
	6551	"RTN","DGP TRI1",76,0 )
	6552	;12 repre sents the first 12 c haracters of the pat ient's las t name tha t will be checked.
	6553	"RTN","DGP TRI1",77,0 )
	6554	;1 repres ents the f irst "^" p iece of th e T10 text line (i.e ., 1:NAME) . NAME is the field name that will be di splayed
	6555	"RTN","DGP TRI1",78,0 )
	6556	;in the e rror messa ge to the user.
	6557	"RTN","DGP TRI1",79,0 )
	6558	; edit ch eck# ; edi t field ; # x check preformed ; display error name #
	6559	"RTN","DGP TRI1",80,0 )
	6560	; 101 seg ment
	6561	"RTN","DGP TRI1",81,0 )
	6562	; PWC - a dded Camp Lejeune to end of 10 1 segment DG5.3914
	6563	"RTN","DGP TRI1",82,0 )
	6564	10 ;;6;;12 ;1^2;1;1;1 ^5;1;1;1^1 ;2;1;2^2;2 ;1;2^4;3;3 ;3^6;;3;3^ 4;4;1;4^6; 5;1;5^2;6; 1;6^2;7;1; 7^1;8;8;8^ 6;;1;9^11; 9;1;9^4;10 ;1;10^4;10 ;1;11^17;1 1;5;12^18; 11;5;12^2; 12;1;13^6; ;1;13^1;;6 ;14^2;;1;1 5^1;;1;16^ 4;;6;17^1; ;1;18^5;;1 ;19^5;;3;2 0^4;;1;21
	6565	"RTN","DGP TRI1",83,0 )
	6566	; 701 seg ment (part 1)
	6567	"RTN","DGP TRI1",84,0 )
	6568	70 ;;1;1;1 0;1^13;2;2 ;2^1;3;1;3 ^4;4;1;4^4 ;5;1;5^6;; 1;6^4;7;3; 7^6;;3;7^4 ;8;3;8^6;9 ;1;9^1;10; 1;10^6;11; 1;11^6;11; 2;11^6;;3; 11^6;11;1; 11^20;;1;1 1^6;;1;12^ 15;;6;13
	6569	"RTN","DGP TRI1",85,0 )
	6570	; 701 seg ment (part 2)
	6571	"RTN","DGP TRI1",86,0 )
	6572	; PWC - a dded Camp Lejeune to end of 70 1 segment DG5.3914
	6573	"RTN","DGP TRI1",87,0 )
	6574	701 ;;15;; 2;1^1;;3;2 ^6;;1;3^6; ;1;4^6;;1; 5^6;;3;5^6 ;;1;6^6;;4 ;7^4;;1;8^ 5;;3;9^5;; 1;10^5;;1; 11^13;12;2 ;12^13;13; 12;13^5;;1 ;14^5;;1;1 5^6;;3;16^ 5;;1;17
	6575	"RTN","DGP TRI1",88,0 )
	6576	; 501 seg ment
	6577	"RTN","DGP TRI1",89,0 )
	6578	50 ;;1;1;1 0;1^1;;6;2 ^16;3;2;3^ 1;4;3;4^1; 5;3;5^6;;1 ;6^11;7;3; 7^6;;197;7 ^6;;9;8^14 ;;6;9^14;; 2;10^6;;1; 11^6;;1;16 ^6;;1;17^6 ;;1;18^6;; 3;18^6;;1; 19^6;;4;20 ^6;;1;21^6 ;;3;22^5;; 1;23^6;;1; 24
	6579	"RTN","DGP TRI1",90,0 )
	6580	; 535 seg ment
	6581	"RTN","DGP TRI1",91,0 )
	6582	53 ;;1;;10 ;1^1;;6;2^ 13;;2;3^1; ;6;4^13;;2 ;5^1;;3;6^ 1;;3;7
	6583	"RTN","DGP TRI1",92,0 )
	6584	; 401 seg ment
	6585	"RTN","DGP TRI1",93,0 )
	6586	40 ;;1;1;1 0;1^1;2;2; 2^11;3;1;3 ^4;4;1;4^6 ;5;1;5^4;6 ;1;6^11;7; 2;7^6;;200 ;7
	6587	"RTN","DGP TRI1",94,0 )
	6588	; 601 seg ment
	6589	"RTN","DGP TRI1",95,0 )
	6590	60 ;;1;1;1 0;1^13;2;2 ;2^4;3;1;3 ^4;4;3;4^1 1;5;2;5^6; ;198;5
	6591	"RTN","DGP TRI1",96,0 )
	6592	;
	6593	"RTN","DGP TRI1",97,0 )
	6594	ERR S DGER R=1 ;if DG ERR>0, the segment i s not put in the mai l message or ^TMP("A EDIT")
	6595	"RTN","DGP TRI1",98,0 )
	6596	W !,T,$S( T["H":" ", 1:$E(Y,4)) ," "
	6597	"RTN","DGP TRI1",99,0 )
	6598	W:"45"[$E (T,1) $E(Y ,31,32),"- ",$E(Y,33, 34),"-",$E (Y,35,36), "@",$E(Y,3 7,40) ;wri te date of procedure /dx code
	6599	"RTN","DGP TRI1",100, 0)
	6600	W ?25,$P( $P(ERR,U,$ P(DGO,";", 4)),":",2) ,?40,"COL. ",F," VAL UE: ",$S($ E(Y,F)=" " :"BLANK",1 :$E(Y,F)) ;write fie ld name,co lumn posit ion and va lue ;; DG 5.3914 c orrected s pelling in comment
	6601	"RTN","DGP TRI1",101, 0)
	6602	S I=$S('$ D(I):1,I>0 :I,1:1),^( I)=$S($D(^ UTILITY("D G",$J,T_$S (T["H":"", 1:$E(Y,4)) ,I)):^(I), 1:U) I $P( DGO,";",2) ,^(I)'[(U_ $P(DGO,";" ,2)_U) S ^ (I)=^(I)_$ P(DGO,";", 2)_U
	6603	"RTN","DGP TRI1",102, 0)
	6604	Q
	6605	"RTN","DGP TRI1",103, 0)
	6606	;
	6607	"RTN","DGP TRI1",104, 0)
	6608	D10 ;
	6609	"RTN","DGP TRI1",105, 0)
	6610	;column 6 6 is PERIO D OF SERVI CE, "Z" in dicates Me rchant Mar ines, "10" indicates VIETNAM ( Agent Oran ge exposur e)
	6611	"RTN","DGP TRI1",106, 0)
	6612	I $E(Y,66 )="Z" S (F ,H)=68,W=" 11;10;1;10 " D L
	6613	"RTN","DGP TRI1",107, 0)
	6614	Q
	6615	"RTN","DGP TRI1",108, 0)
	6616	;
	6617	"RTN","DGP TRI1",109, 0)
	6618	D40 Q
	6619	"RTN","DGP TRI1",110, 0)
	6620	DP40 Q
	6621	"RTN","DGP TRI1",111, 0)
	6622	;
	6623	"RTN","DGP TRI1",112, 0)
	6624	D70 ;colum n 43 is TY PE OF DISP OSITION, 4 4 is OUTPA TIENT CARE STATUS ; DG5.39 14 correct ed spellin g in comme nt
	6625	"RTN","DGP TRI1",113, 0)
	6626	;In "W", 4 indicate s OUTPATIE NT TREATME NT, 5 indi cates VA A USPICES an d 6 indica tes PLACE OF DISPOSI TION
	6627	"RTN","DGP TRI1",114, 0)
	6628	Q:$E(Y,2, 4)=701
	6629	"RTN","DGP TRI1",115, 0)
	6630	I "467"'[ $E(Y,43) S F=44,W="4 ;4;1;4^1;5 ;1;5^11;6; 1;6" D L
	6631	"RTN","DGP TRI1",116, 0)
	6632	Q
	6633	"RTN","DGP TRI1",117, 0)
	6634	D50 ;$P(DG 0,U,5) is SUFFIX (Fi le 45, fie ld 5). col umn 55 is SPINAL COR D INJURY
	6635	"RTN","DGP TRI1",118, 0)
	6636	I "A0"[$P (DG0,U,5)! ("A4"[$P(D G0,U,5))!( '$D(^DGPT( J,70))) S W="11;6;1; 6",F=55 D L ;if $P(D G0,U,5) is null, thi s will exe cute
	6637	"RTN","DGP TRI1",119, 0)
	6638	I $D(^DGP T(J,70)),$ S(T1:1,1:+ ^(70)>2871 000) S W=" 11;6;1;6", F=55 D L
	6639	"RTN","DGP TRI1",120, 0)
	6640	;I $E(Y,4 )=1 S W="9 ;7;1;7",F= 56 D L
	6641	"RTN","DGP TRI1",121, 0)
	6642	; column 273 is BED STATUS (D ISCHARGE M OVEMNT ONL Y)
	6643	"RTN","DGP TRI1",122, 0)
	6644	I I=1,'T1 S W="1;11 ;1;11",F=2 73 D L
	6645	"RTN","DGP TRI1",123, 0)
	6646	Q
	6647	"RTN","DGP TRI1",124, 0)
	6648	D53 Q
	6649	"RTN","DGP TRI1",125, 0)
	6650	;column 4 3 is DIALY SIS TYPE, column 44 is NUMBER OF TREATME NTS and th e 4 in "W" is also N UMBER OF T REATMENTS
	6651	"RTN","DGP TRI1",126, 0)
	6652	D60 I $E(Y ,43) S F=4 4,W="1;4;3 ;4" D L
	6653	"RTN","DGP TRI1",127, 0)
	6654	Q
	6655	"RTN","DGP TRI1",128, 0)
	6656	;called f rom DGPTRI 0
	6657	"RTN","DGP TRI1",129, 0)
	6658	HEAD S ERR ="1:SSN^2: ADMISSION DATE^3:FAC ILITY #",W ="8;1;1;1^ 1;1;9;1^1; 2;10;2^1;3 ;3;3^6;;3; 3",F=5,T=" HEADER" D LOG
	6659	"RTN","DGP TRI1",130, 0)
	6660	D L
	6661	"RTN","DGP TRI1",131, 0)
	6662	Q
	6663	"RTN","DGP TRI1",132, 0)
	6664	LOG ;place DGLOGIC i n array in order to add more l ogic tests ;DG5.36 64 ; DG5 .3914 cor rected spe lling in c omment
	6665	"RTN","DGP TRI1",133, 0)
	6666	K DGLOGIC ;S DGLOGI C=$P($T(LO GIC),";;", 2)
	6667	"RTN","DGP TRI1",134, 0)
	6668	N LOGX,LO GI,LOGCNT, II,XX
	6669	"RTN","DGP TRI1",135, 0)
	6670	S LOGI=0, LOGCNT=1
	6671	"RTN","DGP TRI1",136, 0)
	6672	F LOGI=0: 1 S LOGX=$ P($T(LOGIC +LOGI),";; ",2) Q:LOG X="END" F II=1:1 S XX=$P(LOGX ,U,II) Q:X X="" S DG LOGIC(LOGC NT)=XX,LOG CNT=LOGCNT +1
	6673	"RTN","DGP TRI1",137, 0)
	6674	Q
	6675	"RTN","DGP TRI1",138, 0)
	6676	CEN ;calle d from 701 ^DGPTRI4
	6677	"RTN","DGP TRI1",139, 0)
	6678	S T=70,ER R=$P($T(T7 0),";;",2) ,W=$P($T(7 0),";;",2, 999),W="6; 9;1;9"_$P( W,"6;9;1;9 ",2,999),F =56 D L ;5 6 is RACE column
	6679	"RTN","DGP TRI1",140, 0)
	6680	S ERR=$P( $T(T701)," ;;",2),W=$ P($T(701), ";;",2,999 ),F=73 D L
	6681	"RTN","DGP TRI1",141, 0)
	6682	Q
	6683	"RTN","DGP TRI1",142, 0)
	6684	;
	6685	"RTN","DGP TRI1",143, 0)
	6686	DIAGPTRN(D GDIAG) ; - - icd-10 d iagnosis p attern mat ch
	6687	"RTN","DGP TRI1",144, 0)
	6688	; 1 2 3 4 5 6 7 8
	6689	"RTN","DGP TRI1",145, 0)
	6690	; - - - - - - - -
	6691	"RTN","DGP TRI1",146, 0)
	6692	; U N U . U U N U
	6693	"RTN","DGP TRI1",147, 0)
	6694	; X N N N x N
	6695	"RTN","DGP TRI1",148, 0)
	6696	; x x n n
	6697	"RTN","DGP TRI1",149, 0)
	6698	; n n
	6699	"RTN","DGP TRI1",150, 0)
	6700	N OKAY S OKAY=0
	6701	"RTN","DGP TRI1",151, 0)
	6702	I DGDIAG? 1U1N1UN1". ".4AN S OK AY=1
	6703	"RTN","DGP TRI1",152, 0)
	6704	Q OKAY
	6705	"RTN","DGP TRI1",153, 0)
	6706	TEST ;
	6707	"RTN","DGP TRI1",154, 0)
	6708	W !,"F14. ",$$DIAGP TRN("F14." )
	6709	"RTN","DGP TRI1",155, 0)
	6710	W !,"G1G. 1234 ",$$D IAGPTRN("G 1G.1234")
	6711	"RTN","DGP TRI1",156, 0)
	6712	W !,"330. ",$$DIAGP TRN("330")
	6713	"RTN","DGP TRI1",157, 0)
	6714	W !,"R54. 3XxY ",$$D IAGPTRN("R 54.3XxY")
	6715	"RTN","DGP TRI1",158, 0)
	6716	W !,"R543 XxY ",$$PR OCPTRN("R5 43XxY")
	6717	"RTN","DGP TRI1",159, 0)
	6718	W !,"10.4 4 ",$$PROC PTRN("10.4 4")
	6719	"RTN","DGP TRI1",160, 0)
	6720	W !,"3S82 B1 ",$$PRO CPTRN("3S8 2B1")
	6721	"RTN","DGP TRI1",161, 0)
	6722	W !,"G232 44X ",$$PR OCPTRN("G2 3244X")
	6723	"RTN","DGP TRI1",162, 0)
	6724	Q
	6725	"RTN","DGP TRI1",163, 0)
	6726	;
	6727	"RTN","DGP TRI1",164, 0)
	6728	PROCPTRN(D GPROC) ;IC D-10 Proce dure Code Pattern Ma tch
	6729	"RTN","DGP TRI1",165, 0)
	6730	;
	6731	"RTN","DGP TRI1",166, 0)
	6732	; 1 2 3 4 5 6 7
	6733	"RTN","DGP TRI1",167, 0)
	6734	; - - - - - - -
	6735	"RTN","DGP TRI1",168, 0)
	6736	; U U U U U U U
	6737	"RTN","DGP TRI1",169, 0)
	6738	; N N N N N N N
	6739	"RTN","DGP TRI1",170, 0)
	6740	; Z Z Z Z Z
	6741	"RTN","DGP TRI1",171, 0)
	6742	;
	6743	"RTN","DGP TRI1",172, 0)
	6744	N OKAY S OKAY=0
	6745	"RTN","DGP TRI1",173, 0)
	6746	I DGPROC? 7UN S OKAY =1
	6747	"RTN","DGP TRI1",174, 0)
	6748	Q OKAY
	6749	"RTN","DGP TRI4")
	6750	0^27^B7136 3613^B6988 6418
	6751	"RTN","DGP TRI4",1,0)
	6752	DGPTRI4 ;A LB/JDS/MJK /MTC/ADL/T J/BOK,ISF/ GJW,HIOFO/ FT - PTF T RANSMISSIO N ;5/11/15 12:24pm
	6753	"RTN","DGP TRI4",2,0)
	6754	;;5.3;Reg istration; 850,884, 914;Aug 13, 1993;B uild 173
	6755	"RTN","DGP TRI4",3,0)
	6756	;
	6757	"RTN","DGP TRI4",4,0)
	6758	; ^XMB(3. 9) - #1006 6
	6759	"RTN","DGP TRI4",5,0)
	6760	; XLFSTR APIs - 101 04
	6761	"RTN","DGP TRI4",6,0)
	6762	;
	6763	"RTN","DGP TRI4",7,0)
	6764	701 ; -- s etup 701 t ransaction
	6765	"RTN","DGP TRI4",8,0)
	6766	S Y=$$N70 1(J,T1)
	6767	"RTN","DGP TRI4",9,0)
	6768	N K
	6769	"RTN","DGP TRI4",10,0 )
	6770	;For Cens us records , send spa ces for DI SCHARGE SP ECIALTY CO DE (41-42) , TYPE OF DISPOSITIO N (43), OU TPATIENT C ARE STATUS (44),
	6771	"RTN","DGP TRI4",11,0 )
	6772	;UNDER VA AUSPICES (45), PLAC E OF DISPO SITION (46 ), RECEIVI NG FACILIT Y NUMBER ( 47-49), RE CEIVING FA CILITY
	6773	"RTN","DGP TRI4",12,0 )
	6774	;SUFFIX ( 50-52), DX LS ONLY (6 6), PHYSIC AL LOCATIO N CDR CODE (67-72) a nd PHYSICA L LOCATION CODE (73- 74)
	6775	"RTN","DGP TRI4",13,0 )
	6776	I T1 F K= 41:1:52,66 :1:74 S $E (Y,K)=" "
	6777	"RTN","DGP TRI4",14,0 )
	6778	I T1 D CE N^DGPTRI1 D:'DGERR C SAVE ;S:'D GERR ^XMB( 3.9,DGXMZ, 2,DGCNT,0) =Y,DGCNT=D GCNT+1 Q
	6779	"RTN","DGP TRI4",15,0 )
	6780	I 'T1 D S AVE
	6781	"RTN","DGP TRI4",16,0 )
	6782	;
	6783	"RTN","DGP TRI4",17,0 )
	6784	702 ;creat e 702 only if there are second ary DXs
	6785	"RTN","DGP TRI4",18,0 )
	6786	Q:$G(DGRT Y)=2 ;don 't send 70 2 for cens us record
	6787	"RTN","DGP TRI4",19,0 )
	6788	Q:$$DXLSO NLY^DGPTRN U1(J) ;DX LS only (n o secondar y diagnose s)
	6789	"RTN","DGP TRI4",20,0 )
	6790	S Y=$$N70 2(J)
	6791	"RTN","DGP TRI4",21,0 )
	6792	D SAVE^DG PTRI2
	6793	"RTN","DGP TRI4",22,0 )
	6794	Q
	6795	"RTN","DGP TRI4",23,0 )
	6796	;
	6797	"RTN","DGP TRI4",24,0 )
	6798	POA(Y) ;-- Add POA t o end of 1 01 segment with POA ;FT 3/23/1 5 - MAY NO T BE NEEDE D
	6799	"RTN","DGP TRI4",25,0 )
	6800	N DGPOA,L ,K S DGPOA =$G(^DGPT( J,82))
	6801	"RTN","DGP TRI4",26,0 )
	6802	S L=$P(DG 70,U,10)_U _$P(DG70,U ,16,24)_U_ DG71
	6803	"RTN","DGP TRI4",27,0 )
	6804	F K=1:1:1 3 S Y=Y_$S ($P(L,U,K) '="":$$POA VAL($P(DGP OA,U,K)),1 :" ") ;6/1 8/2012 sen d what is stored per call with Dorothea Garrett.
	6805	"RTN","DGP TRI4",28,0 )
	6806	Q
	6807	"RTN","DGP TRI4",29,0 )
	6808	;
	6809	"RTN","DGP TRI4",30,0 )
	6810	POAVAL(POA ) ; -- Con vert POA i ndicator t o a 1 or 0 for use i n calculat ing DRG
	6811	"RTN","DGP TRI4",31,0 )
	6812	; -- note : Transmi ssion of s pace " " i f no corre sponding D IAGNOSIS
	6813	"RTN","DGP TRI4",32,0 )
	6814	; -- see POA^DGPTFD , same log ic, differ ent return values.
	6815	"RTN","DGP TRI4",33,0 )
	6816	S POA=$G( POA)
	6817	"RTN","DGP TRI4",34,0 )
	6818	;
	6819	"RTN","DGP TRI4",35,0 )
	6820	; -- On 8 /9/2012 th e ADT SME Determined that null POA shoul d be defau lted to Ye s
	6821	"RTN","DGP TRI4",36,0 )
	6822	; Due to the fac t that the COTS PTF software w as not upl oading POA informati on.
	6823	"RTN","DGP TRI4",37,0 )
	6824	Q $S(POA= "Y":"Y",PO A="N":"N", POA="":"Y" ,POA="U":" U",POA="W" :"W",1:"Y" )
	6825	"RTN","DGP TRI4",38,0 )
	6826	;
	6827	"RTN","DGP TRI4",39,0 )
	6828	ENTER S Y= Y_$J($P(X, U,Z),L)
	6829	"RTN","DGP TRI4",40,0 )
	6830	Q
	6831	"RTN","DGP TRI4",41,0 )
	6832	;
	6833	"RTN","DGP TRI4",42,0 )
	6834	ENTER0 S Y =Y_$S($P(X ,U,Z)]"":$ E("00000", $L($P(X,U, Z))+1,L)_$ P(X,U,Z),1 :$J($P(X,U ,Z),L))
	6835	"RTN","DGP TRI4",43,0 )
	6836	Q
	6837	"RTN","DGP TRI4",44,0 )
	6838	;
	6839	"RTN","DGP TRI4",45,0 )
	6840	SAVE ;vali date data and save t o MailMan message & ^TMP("AEDI T",$J)
	6841	"RTN","DGP TRI4",46,0 )
	6842	D SAVE^DG PTRI2
	6843	"RTN","DGP TRI4",47,0 )
	6844	Q Q
	6845	"RTN","DGP TRI4",48,0 )
	6846	;
	6847	"RTN","DGP TRI4",49,0 )
	6848	CSAVE ;set s MailMan message, n ot ^TMP("A EDIT",$J)
	6849	"RTN","DGP TRI4",50,0 )
	6850	N DGY1,DG Y2
	6851	"RTN","DGP TRI4",51,0 )
	6852	D FILL^DG PTRI2 ;fil l out Y to 384 chara cters
	6853	"RTN","DGP TRI4",52,0 )
	6854	I $E(Y,2, 4)=701 S D GY1=$E(Y,1 ,240),DGY2 =$E(Y,241, 384) D
	6855	"RTN","DGP TRI4",53,0 )
	6856	.S ^XMB(3 .9,DGXMZ,2 ,DGCNT,0)= DGY1,DGCNT =DGCNT+1
	6857	"RTN","DGP TRI4",54,0 )
	6858	.S ^XMB(3 .9,DGXMZ,2 ,DGCNT,0)= DGY2,DGCNT =DGCNT+1
	6859	"RTN","DGP TRI4",55,0 )
	6860	Q
	6861	"RTN","DGP TRI4",56,0 )
	6862	CDR S Y=Y_ $E($P(Z,". ")_"0000", 1,4)_$E($P (Z,".",2)_ "00",1,2)
	6863	"RTN","DGP TRI4",57,0 )
	6864	Q
	6865	"RTN","DGP TRI4",58,0 )
	6866	RTEN(X) ; This funct ion will r ound X to the neares t multiple of ten.
	6867	"RTN","DGP TRI4",59,0 )
	6868	; 0-4 ->D OWN; 5-9-> UP
	6869	"RTN","DGP TRI4",60,0 )
	6870	Q (X\10)* 10+$S(X#10 >4:10,1:0)
	6871	"RTN","DGP TRI4",61,0 )
	6872	;
	6873	"RTN","DGP TRI4",62,0 )
	6874	ETHNIC(DGP TJ) ;Ethni city (use first acti ve value)
	6875	"RTN","DGP TRI4",63,0 )
	6876	;Input - PTF ien
	6877	"RTN","DGP TRI4",64,0 )
	6878	;Output - character string co ntaining o ne ethnici ty value a nd collect ion method
	6879	"RTN","DGP TRI4",65,0 )
	6880	N DGARRAY ,DGNODE,DG NUM,DGETHN IC,DGLOOP, DGX,DGY
	6881	"RTN","DGP TRI4",66,0 )
	6882	M DGARRAY =^DPT(+^DG PT(DGPTJ,0 ),.06) ;ge t ETHNIC m ultiple fr om File 2
	6883	"RTN","DGP TRI4",67,0 )
	6884	S (DGETHN IC,DGY)="" ,DGLOOP=0, DGNUM=1
	6885	"RTN","DGP TRI4",68,0 )
	6886	F S DGLO OP=+$O(DGA RRAY(DGLOO P)) Q:'DGL OOP D Q: DGNUM>1
	6887	"RTN","DGP TRI4",69,0 )
	6888	.S DGNODE =$G(DGARRA Y(DGLOOP,0 ))
	6889	"RTN","DGP TRI4",70,0 )
	6890	.Q:('DGNO DE)!('$D(^ DIC(10.2,+ DGNODE,0)) ) ;10.2=E THNICITY f ile
	6891	"RTN","DGP TRI4",71,0 )
	6892	.Q:$$INAC TIVE^DGUTL 4(+DGNODE, 2) ;(VALU E,TYPE) wh ere +DGNOD E=ethnicit y value an d 2=ETHNIC ITY
	6893	"RTN","DGP TRI4",72,0 )
	6894	.S DGX=$$ PTR2CODE^D GUTL4(+DGN ODE,2,4) ; (VALUE,TYP E,CODE) wh ere +DGNOD E=ethnicit y ien, 2=E THNICITY a nd 4=PTF
	6895	"RTN","DGP TRI4",73,0 )
	6896	.S DGETHN IC=$S(DGX= "":" ",1:D GX)
	6897	"RTN","DGP TRI4",74,0 )
	6898	.S DGX=$$ PTR2CODE^D GUTL4(+$P( DGNODE,"^" ,2),3,4) ; (VALUE,TYP E,CODE) wh ere $P(DGN ODE,U,2)=e thnicity i en, 3=coll ection met hod ien an d 4=PTF
	6899	"RTN","DGP TRI4",75,0 )
	6900	.S DGETHN IC=DGETHNI C_$S(DGX=" ":" ",1:DG X)
	6901	"RTN","DGP TRI4",76,0 )
	6902	.S DGNUM= DGNUM+1
	6903	"RTN","DGP TRI4",77,0 )
	6904	S DGY=DGY _$S(DGETHN IC="":" " ,1:DGETHNI C)
	6905	"RTN","DGP TRI4",78,0 )
	6906	Q DGY
	6907	"RTN","DGP TRI4",79,0 )
	6908	;
	6909	"RTN","DGP TRI4",80,0 )
	6910	RACE(DGPTJ ) ;-- Race (use firs t 6 active values)
	6911	"RTN","DGP TRI4",81,0 )
	6912	;Input - PTF ien
	6913	"RTN","DGP TRI4",82,0 )
	6914	;Output - character string co ntaining u p to six r ace and co llection m ethods
	6915	"RTN","DGP TRI4",83,0 )
	6916	N DGARRAY ,DGNODE,DG NUM,DGRACE ,DGI,DGK,D GX,DGY
	6917	"RTN","DGP TRI4",84,0 )
	6918	M DGARRAY =^DPT(+^DG PT(DGPTJ,0 ),.02) ;ge t RACE mul tiple from FILE 2
	6919	"RTN","DGP TRI4",85,0 )
	6920	S (DGRACE ,DGY)="",D GI=0,DGNUM =1
	6921	"RTN","DGP TRI4",86,0 )
	6922	F S DGI= +$O(DGARRA Y(DGI)) Q: 'DGI D Q :DGNUM>6
	6923	"RTN","DGP TRI4",87,0 )
	6924	.S DGNODE =$G(DGARRA Y(DGI,0))
	6925	"RTN","DGP TRI4",88,0 )
	6926	.Q:('DGNO DE)!('$D(^ DIC(10,+DG NODE,0))) ;10=RACE file
	6927	"RTN","DGP TRI4",89,0 )
	6928	.Q:$$INAC TIVE^DGUTL 4(+DGNODE) ;(VALUE, TYPE) wher e +DGNODE= race value and 1=RAC E (default is 1)
	6929	"RTN","DGP TRI4",90,0 )
	6930	.S DGX=$$ PTR2CODE^D GUTL4(+DGN ODE,1,4) ; (VALUE,TYP E CODE) wh ere +DGNOD E=race ien , 1=RACE a nd 4=PTF
	6931	"RTN","DGP TRI4",91,0 )
	6932	.S DGRACE =DGRACE_$S (DGX="":" ",1:DGX)
	6933	"RTN","DGP TRI4",92,0 )
	6934	.S DGX=$$ PTR2CODE^D GUTL4(+$P( DGNODE,"^" ,2),3,4) ; (VALUE,TYP E,CODE) wh ere $P(DGN ODE,U,2)=c ollection method ien , 3=COLLEC TION TYPE and 4=PTF
	6935	"RTN","DGP TRI4",93,0 )
	6936	.S DGRACE =DGRACE_$S (DGX="":" ",1:DGX)
	6937	"RTN","DGP TRI4",94,0 )
	6938	.S DGNUM= DGNUM+1
	6939	"RTN","DGP TRI4",95,0 )
	6940	S DGX="" S $P(DGX," ",12)=""
	6941	"RTN","DGP TRI4",96,0 )
	6942	S DGRACE= $S(DGRACE= "":" ",1: DGRACE)_DG X
	6943	"RTN","DGP TRI4",97,0 )
	6944	S DGY=DGY _$E(DGRACE ,1,12)
	6945	"RTN","DGP TRI4",98,0 )
	6946	Q DGY
	6947	"RTN","DGP TRI4",99,0 )
	6948	;
	6949	"RTN","DGP TRI4",100, 0)
	6950	N701(PTF,D GT1) ;crea te 701 seg ment
	6951	"RTN","DGP TRI4",101, 0)
	6952	N NODE,DF N,I,IENS,I ENS2,X
	6953	"RTN","DGP TRI4",102, 0)
	6954	N NNAME ; node name
	6955	"RTN","DGP TRI4",103, 0)
	6956	N DTM,DDD IS,TDIS,DS PEC,TYDIS, PDIS,SA,X, I,RACEA,D1 ONLY,DDATE ,SC,SHAD,D GCLV
	6957	"RTN","DGP TRI4",104, 0)
	6958	N VAA,ASI H
	6959	"RTN","DGP TRI4",105, 0)
	6960	S DGT1=$G (DGT1) ;ak a T1
	6961	"RTN","DGP TRI4",106, 0)
	6962	S NNAME=$ S(DGT1:"C7 01",1:"N70 1")
	6963	"RTN","DGP TRI4",107, 0)
	6964	S IENS=PT F_","
	6965	"RTN","DGP TRI4",108, 0)
	6966	S DFN=$$G ET1^DIQ(45 ,IENS,.01, "I"),IENS2 =DFN_","
	6967	"RTN","DGP TRI4",109, 0)
	6968	S NODE=$$ CDATA^DGPT RNU1(PTF,N NAME) ;con trol data
	6969	"RTN","DGP TRI4",110, 0)
	6970	S (DDATE, DTM)=$$DIS P^DGPTRNU( PTF) ;date of dispos ition
	6971	"RTN","DGP TRI4",111, 0)
	6972	S DDIS=$$ FDATE^DGPT RNU($P(DTM ,".",1)) ; date in MM DDYY forma t
	6973	"RTN","DGP TRI4",112, 0)
	6974	S TDIS=$$ TIME^DGPTR NU(DTM) ;t ime in HHM M format
	6975	"RTN","DGP TRI4",113, 0)
	6976	S:TDIS'?4 N TDIS="00 00" ;send zeros if t ime is bla nk
	6977	"RTN","DGP TRI4",114, 0)
	6978	S $E(NODE ,31,36)=DD IS
	6979	"RTN","DGP TRI4",115, 0)
	6980	S $E(NODE ,37,40)=TD IS
	6981	"RTN","DGP TRI4",116, 0)
	6982	S DSPEC=$ $GET1^DIQ( 45,IENS,71 ,"I") ;dis charge spe cialty (po inter to f ile #42.4)
	6983	"RTN","DGP TRI4",117, 0)
	6984	S $E(NODE ,41,42)=$$ SPEC2PTF^D GPTRNU1(DS PEC) ;PTF code
	6985	"RTN","DGP TRI4",118, 0)
	6986	S $E(NODE ,43)=$$TDI S^DGPTRNU1 (PTF) ;typ e of dispo sition
	6987	"RTN","DGP TRI4",119, 0)
	6988	S $E(NODE ,44)=$$GET 1^DIQ(45,I ENS,73,"I" ) ;outpati ent care s tatus
	6989	"RTN","DGP TRI4",120, 0)
	6990	S VAA=$$G ET1^DIQ(45 ,IENS,74," I")
	6991	"RTN","DGP TRI4",121, 0)
	6992	S $E(NODE ,45)=$S(VA A=2:2,VAA= 1:1,1:" ") ;VA auspi ces
	6993	"RTN","DGP TRI4",122, 0)
	6994	S $E(NODE ,46)=$$PDI S^DGPTRNU( PTF) ;plac e of dispo sition
	6995	"RTN","DGP TRI4",123, 0)
	6996	S $E(NODE ,47,49)=$$ GET1^DIQ(4 5,IENS,76. 1) ;receiv ing facili ty
	6997	"RTN","DGP TRI4",124, 0)
	6998	S $E(NODE ,50,52)=$$ GET1^DIQ(4 5,IENS,76. 2) ;receiv ing facili ty suffix
	6999	"RTN","DGP TRI4",125, 0)
	7000	S ASIH=$$ GET1^DIQ(4 5,IENS,77) ;asih day s
	7001	"RTN","DGP TRI4",126, 0)
	7002	S ASIH=$S (ASIH>999: 999,1:ASIH )
	7003	"RTN","DGP TRI4",127, 0)
	7004	S ASIH=$$ JUSTIFY^DG PTRNU1(ASI H,3,"0","R ")
	7005	"RTN","DGP TRI4",128, 0)
	7006	S $E(NODE ,53,55)=$S (ASIH="000 ":" ",1: ASIH) ;asi h days
	7007	"RTN","DGP TRI4",129, 0)
	7008	S $E(NODE ,56)="X" ; was race, but now is X
	7009	"RTN","DGP TRI4",130, 0)
	7010	S $E(NODE ,57)=$$GET 1^DIQ(45,I ENS,78,"I" ) ;C&P sta tus
	7011	"RTN","DGP TRI4",131, 0)
	7012	S $E(NODE ,58,64)=$$ FMTICD^DGP TRNU($$GET 1^DIQ(45,I ENS,79)) ; DXLS
	7013	"RTN","DGP TRI4",132, 0)
	7014	S $E(NODE ,65)=$$GET 1^DIQ(45,I ENS,82.01, "I") ;POA for DXLS
	7015	"RTN","DGP TRI4",133, 0)
	7016	S D1ONLY= $$DXLSONLY ^DGPTRNU1( PTF) ;DXLS only (no secondary diagnoses)
	7017	"RTN","DGP TRI4",134, 0)
	7018	S $E(NODE ,66)=$S(D1 ONLY:"X",1 :" ")
	7019	"RTN","DGP TRI4",135, 0)
	7020	;S X="",Z =+$O(^DGPT (PTF,535," AM",$P(DDA TE,".")-.0 000001)) I $D(^DGPT( PTF,535,+$ O(^(Z,0)), 0)) S X=^( 0) ;FT 4/1 /15
	7021	"RTN","DGP TRI4",136, 0)
	7022	S X="",Z= +$O(^DGPT( PTF,535,"A M",DDATE-. 0000001)) I $D(^DGPT (PTF,535,+ $O(^(Z,0)) ,0)) S X=^ (0) ;FT 4/ 1/15
	7023	"RTN","DGP TRI4",137, 0)
	7024	;S DSPEC= $$GET1^DIQ (45,IENS,7 1,"I") ;di scharge sp ecialty
	7025	"RTN","DGP TRI4",138, 0)
	7026	S $E(NODE ,67,72)=$$ FMTMPCR^DG PTRNU1($P( X,U,16)) ; physical l ocation CD R code
	7027	"RTN","DGP TRI4",139, 0)
	7028	S $E(NODE ,73,74)=$$ SPEC2PTF^D GPTRNU1($P (X,U,2)) ; physical l ocation (s pecialty)
	7029	"RTN","DGP TRI4",140, 0)
	7030	S SC=$$GE T1^DIQ(2,I ENS2,.302) ;SC perce ntage
	7031	"RTN","DGP TRI4",141, 0)
	7032	S $E(NODE ,75,77)=$$ RJ^XLFSTR( SC,"3T",0) ;pad with leading z eros
	7033	"RTN","DGP TRI4",142, 0)
	7034	S $E(NODE ,78)=" " ; Legionnair e's diseas e (not use d)
	7035	"RTN","DGP TRI4",143, 0)
	7036	S $E(NODE ,79)=" " ; suicide in dicator (n ot used)
	7037	"RTN","DGP TRI4",144, 0)
	7038	S $E(NODE ,80,83)=" " ;substan ce abuse ( not used)
	7039	"RTN","DGP TRI4",145, 0)
	7040	;position s 84-88 ar e not used with ICD- 10
	7041	"RTN","DGP TRI4",146, 0)
	7042	S X=$$GET 1^DIQ(45,I ENS,79.25, "I") ;trea ted for SC condition
	7043	"RTN","DGP TRI4",147, 0)
	7044	S $E(NODE ,89)=$S(X= "Y":"Y",X= "N":"N",1: " ")
	7045	"RTN","DGP TRI4",148, 0)
	7046	S $E(NODE ,90)=$$AO^ DGPTRNU(PT F) ;treate d for AO c ondition
	7047	"RTN","DGP TRI4",149, 0)
	7048	S $E(NODE ,91)=$$ION 2^DGPTRNU( PTF) ;trea ted for io nizing rad iation
	7049	"RTN","DGP TRI4",150, 0)
	7050	S $E(NODE ,92)=$$SWA SIA^DGPTRN U(PTF) ;tr eatment re lated to s ervice in SW Asia
	7051	"RTN","DGP TRI4",151, 0)
	7052	S $E(NODE ,93)=$$MST ^DGPTRNU(P TF) ;treat ment for/r elated to MST
	7053	"RTN","DGP TRI4",152, 0)
	7054	S $E(NODE ,94)=$$HNC ^DGPTRNU(P TF) ;treat ment for H NC
	7055	"RTN","DGP TRI4",153, 0)
	7056	S $E(NODE ,95,96)=$$ ETHNIC(PTF ) ;ethnici ty
	7057	"RTN","DGP TRI4",154, 0)
	7058	S $E(NODE ,97,108)=$ $RACE(PTF) ;Up to 6 active ent ries for R ACE INFORM ATION
	7059	"RTN","DGP TRI4",155, 0)
	7060	S X=$$GET 1^DIQ(45,I ENS,79.31, "I")
	7061	"RTN","DGP TRI4",156, 0)
	7062	S $E(NODE ,109)=$S(X ="Y":"Y",X ="N":"N",1 :" ") ;rel ated to co mbat
	7063	"RTN","DGP TRI4",157, 0)
	7064	S SHAD=$$ SHAD^DGPTR NU(PTF) ;t reatment f or shad
	7065	"RTN","DGP TRI4",158, 0)
	7066	S $E(NODE ,110)=$S(S HAD=1:"Y", SHAD=0:"N" ,1:" ") ;1 =Yes, 0=No
	7067	"RTN","DGP TRI4",159, 0)
	7068	S $E(NODE ,114)=$$CL V^DGPTRNU( PTF) ;trea tment rela ted to ser vice at Ca mp Lejeune
	7069	"RTN","DGP TRI4",160, 0)
	7070	Q NODE
	7071	"RTN","DGP TRI4",161, 0)
	7072	;
	7073	"RTN","DGP TRI4",162, 0)
	7074	N702(PTF) ;create 70 2 segment
	7075	"RTN","DGP TRI4",163, 0)
	7076	N NODE,I, IENS,DGDX, DGLOOP,DGP OA,DGSTRIN G,DGPTTMP
	7077	"RTN","DGP TRI4",164, 0)
	7078	N NNAME ; node name
	7079	"RTN","DGP TRI4",165, 0)
	7080	N DTM,DDI S,TDIS,DXC ODES,EFFDA TE,IMPDATE
	7081	"RTN","DGP TRI4",166, 0)
	7082	S IENS=PT F_","
	7083	"RTN","DGP TRI4",167, 0)
	7084	S NNAME=" N702"
	7085	"RTN","DGP TRI4",168, 0)
	7086	S NODE=$$ CDATA^DGPT RNU1(PTF,N NAME) ;con trol data
	7087	"RTN","DGP TRI4",169, 0)
	7088	S DTM=$$G ET1^DIQ(45 ,IENS,70," I") ;date/ time of di scharge
	7089	"RTN","DGP TRI4",170, 0)
	7090	S DDIS=$$ FDATE^DGPT RNU($P(DTM ,".",1)) ; date in MM DDYY forma t
	7091	"RTN","DGP TRI4",171, 0)
	7092	S TDIS=$$ TIME^DGPTR NU(DTM) ;t ime in HHM M format
	7093	"RTN","DGP TRI4",172, 0)
	7094	S:TDIS'?4 N TDIS="00 00" ;send zeros if t ime is bla nk
	7095	"RTN","DGP TRI4",173, 0)
	7096	S $E(NODE ,31,36)=DD IS
	7097	"RTN","DGP TRI4",174, 0)
	7098	S $E(NODE ,37,40)=TD IS
	7099	"RTN","DGP TRI4",175, 0)
	7100	D EFFDATE ^DGPTIC10( PTF) ;get effective date to ch eck icd ve rsion of d x codes
	7101	"RTN","DGP TRI4",176, 0)
	7102	D PTFICD^ DGPTFUT(70 1,PTF,,.DX CODES) ;ge t secondar y dx and p oa values
	7103	"RTN","DGP TRI4",177, 0)
	7104	S DGLOOP= 0,DGSTRING =""
	7105	"RTN","DGP TRI4",178, 0)
	7106	F S DGLO OP=$O(DXCO DES(DGLOOP )) Q:DGLOO P="" D ; ignore DXC ODES(0). I t is sent in 701 seg ment.
	7107	"RTN","DGP TRI4",179, 0)
	7108	.S DGPTTM P=$$ICDDAT A^ICDXCODE ("DIAG",$P (DXCODES(D GLOOP),U,1 ),EFFDATE, "I") ;get dx code in fo
	7109	"RTN","DGP TRI4",180, 0)
	7110	.I +DGPTT MP>0&($P(D GPTTMP,U,1 0)) D ;ch eck ien an d status
	7111	"RTN","DGP TRI4",181, 0)
	7112	..S DGDX= $P(DXCODES (DGLOOP),U ,3) ;dx ex ternal val ue
	7113	"RTN","DGP TRI4",182, 0)
	7114	..S DGDX= $$FMTICD^D GPTRNU(DGD X) ;remove decimal p oint
	7115	"RTN","DGP TRI4",183, 0)
	7116	..S DGDX= $$LJ^XLFST R(DGDX,7," ") ;left justify & add spaces to the ri ght to rea ch 7 chara cters
	7117	"RTN","DGP TRI4",184, 0)
	7118	..S DGPOA =$P(DXCODE S(DGLOOP), U,2) ;get poa code
	7119	"RTN","DGP TRI4",185, 0)
	7120	..S DGPOA =$S(DGPOA' ="":DGPOA, 1:" ") ;us e space, i f no POA c ode
	7121	"RTN","DGP TRI4",186, 0)
	7122	..S DGSTR ING=DGSTRI NG_DGDX_DG POA ;build string of dx and po a values
	7123	"RTN","DGP TRI4",187, 0)
	7124	S $E(NODE ,41,232)=D GSTRING_$$ REPEAT^XLF STR(" ",19 2-$L(DGSTR ING))
	7125	"RTN","DGP TRI4",188, 0)
	7126	Q NODE
	7127	"RTN","DGP TRI4",189, 0)
	7128	;
	7129	"RTN","DGP TRNU")
	7130	0^65^B5789 1113^B5575 0657
	7131	"RTN","DGP TRNU",1,0)
	7132	DGPTRNU ;I SF/GJW,HIO FO/FT - PT F TRANSMIS SION ; 24 Dec 2018 8:10 AM
	7133	"RTN","DGP TRNU",2,0)
	7134	;;5.3;Reg istration; *884,914 *;Aug 13, 1993;Build 173
	7135	"RTN","DGP TRNU",3,0)
	7136	;
	7137	"RTN","DGP TRNU",4,0)
	7138	;XLFDT - #10103
	7139	"RTN","DGP TRNU",5,0)
	7140	;
	7141	"RTN","DGP TRNU",6,0)
	7142	FDATE(DGDT ,DGDF) ;fo rmat date as MMDDYY
	7143	"RTN","DGP TRNU",7,0)
	7144	;Format o ptions
	7145	"RTN","DGP TRNU",8,0)
	7146	;1 - MMDD YY
	7147	"RTN","DGP TRNU",9,0)
	7148	;2 - MMDD YYYY
	7149	"RTN","DGP TRNU",10,0 )
	7150	N X,MON,D AY,YR,VAL
	7151	"RTN","DGP TRNU",11,0 )
	7152	S DGDF=$G (DGDF,1) ; default to 2-digit d ate
	7153	"RTN","DGP TRNU",12,0 )
	7154	S X=$$FMT E^XLFDT(DG DT,"5ZP")
	7155	"RTN","DGP TRNU",13,0 )
	7156	S MON=$P( X,"/")
	7157	"RTN","DGP TRNU",14,0 )
	7158	S DAY=$P( X,"/",2)
	7159	"RTN","DGP TRNU",15,0 )
	7160	S YR=$P(X ,"/",3)
	7161	"RTN","DGP TRNU",16,0 )
	7162	S:DGDF="Y " VAL=MON_ DAY_$E(YR, 3,4)
	7163	"RTN","DGP TRNU",17,0 )
	7164	S:DGDF=2 VAL=MON_DA Y_YR
	7165	"RTN","DGP TRNU",18,0 )
	7166	Q $S(+DGD T'>0:"",1: VAL)
	7167	"RTN","DGP TRNU",19,0 )
	7168	;
	7169	"RTN","DGP TRNU",20,0 )
	7170	TIME(DTM) ;extract t ime in HHM M format f rom date/t ime
	7171	"RTN","DGP TRNU",21,0 )
	7172	N X,Y,H,M
	7173	"RTN","DGP TRNU",22,0 )
	7174	S X=$$FMT E^XLFDT(DT M,"6F")
	7175	"RTN","DGP TRNU",23,0 )
	7176	S Y=$P(X, "@",2)
	7177	"RTN","DGP TRNU",24,0 )
	7178	S H=$P(Y, ":"),M=$P( Y,":",2)
	7179	"RTN","DGP TRNU",25,0 )
	7180	Q H_M
	7181	"RTN","DGP TRNU",26,0 )
	7182	;
	7183	"RTN","DGP TRNU",27,0 )
	7184	FMTICD(DGC ) ;format ICD code f or transmi ssion
	7185	"RTN","DGP TRNU",28,0 )
	7186	Q $TR(DGC ,".","")
	7187	"RTN","DGP TRNU",29,0 )
	7188	;
	7189	"RTN","DGP TRNU",30,0 )
	7190	;Retrieve nodes fro m PTF CLOS E OUT (#45 .84) where appropria te
	7191	"RTN","DGP TRNU",31,0 )
	7192	GETNODE(DG PTF,DGHOW, DGNODE) ;
	7193	"RTN","DGP TRNU",32,0 )
	7194	;DGHOW = 1 - use PT F CLOSE OU T node if defined, P TF otherwi se
	7195	"RTN","DGP TRNU",33,0 )
	7196	;DGHOW = 2 - use PT F file
	7197	"RTN","DGP TRNU",34,0 )
	7198	;DGHOW = 3 - use PT F CLOSE OU T record ( forced)
	7199	"RTN","DGP TRNU",35,0 )
	7200	N VAL,DFN ,COUT,IENS 45,IENS2,F LD,NODE
	7201	"RTN","DGP TRNU",36,0 )
	7202	;the fiel d numbers for the va rious STOR E(*) field s
	7203	"RTN","DGP TRNU",37,0 )
	7204	S NODE=$S (DGNODE=0: 0,DGNODE=3 2:.32,DGNO DE=321:.32 1,DGNODE=5 2:.52,1:"" )
	7205	"RTN","DGP TRNU",38,0 )
	7206	S FLD=$S( DGNODE=0:1 0,DGNODE=1 1:11,DGNOD E=52:12,DG NODE=321:1 3,DGNODE=3 2:14,DGNOD E=57:15,.3 :16,1:0)
	7207	"RTN","DGP TRNU",39,0 )
	7208	S VAL=""
	7209	"RTN","DGP TRNU",40,0 )
	7210	S IENS45= DGPTF_","
	7211	"RTN","DGP TRNU",41,0 )
	7212	S COUT=$$ GET1^DIQ(4 5,IENS45,7 .1,"I") ;c orrespondi ng entry i n PTF CLOS E OUT file
	7213	"RTN","DGP TRNU",42,0 )
	7214	S DFN=$$G ET1^DIQ(45 ,IENS45,.0 1,"I") ;ft 2/12/15
	7215	"RTN","DGP TRNU",43,0 )
	7216	I DGHOW'= 3 D
	7217	"RTN","DGP TRNU",44,0 )
	7218	.S DFN=$$ GET1^DIQ(4 5,IENS45,. 01,"I")
	7219	"RTN","DGP TRNU",45,0 )
	7220	.S IENS2= $G(DFN)_", "
	7221	"RTN","DGP TRNU",46,0 )
	7222	I DGHOW=" Y" S VAL=$ S(COUT:$$G ET1^DIQ(45 .84,COUT_" ,",FLD),1: $G(^DPT(DF N,DGNODE)) )
	7223	"RTN","DGP TRNU",47,0 )
	7224	I DGHOW=2 S VAL=$G( ^DPT(DFN,. 321))
	7225	"RTN","DGP TRNU",48,0 )
	7226	I DGHOW=3 S VAL=$$G ET1^DIQ(45 .84,COUT_" ,",FLD)
	7227	"RTN","DGP TRNU",49,0 )
	7228	Q VAL
	7229	"RTN","DGP TRNU",50,0 )
	7230	;
	7231	"RTN","DGP TRNU",51,0 )
	7232	;convenie nce routin es for com monly used nodes
	7233	"RTN","DGP TRNU",52,0 )
	7234	GET0(DGPTF ,DGHOW) ;
	7235	"RTN","DGP TRNU",53,0 )
	7236	S DGHOW=$ G(DGHOW,1)
	7237	"RTN","DGP TRNU",54,0 )
	7238	Q $$GETNO DE(DGPTF,D GHOW,0)
	7239	"RTN","DGP TRNU",55,0 )
	7240	;
	7241	"RTN","DGP TRNU",56,0 )
	7242	GET32(DGPT F,DGHOW) ;
	7243	"RTN","DGP TRNU",57,0 )
	7244	S DGHOW=$ G(DGHOW,1)
	7245	"RTN","DGP TRNU",58,0 )
	7246	Q $$GETNO DE(DGPTF,D GHOW,.32)
	7247	"RTN","DGP TRNU",59,0 )
	7248	;
	7249	"RTN","DGP TRNU",60,0 )
	7250	GET321(DGP TF,DGHOW) ;
	7251	"RTN","DGP TRNU",61,0 )
	7252	S DGHOW=$ G(DGHOW,1)
	7253	"RTN","DGP TRNU",62,0 )
	7254	Q $$GETNO DE(DGPTF,D GHOW,.321)
	7255	"RTN","DGP TRNU",63,0 )
	7256	;
	7257	"RTN","DGP TRNU",64,0 )
	7258	GET52(DGPT F,DGHOW) ;
	7259	"RTN","DGP TRNU",65,0 )
	7260	S DGHOW=$ G(DGHOW,1)
	7261	"RTN","DGP TRNU",66,0 )
	7262	Q $$GETNO DE(DGPTF,D GHOW,.52)
	7263	"RTN","DGP TRNU",67,0 )
	7264	;
	7265	"RTN","DGP TRNU",68,0 )
	7266	POW(DGPTF) ;POW stat us
	7267	"RTN","DGP TRNU",69,0 )
	7268	;returns
	7269	"RTN","DGP TRNU",70,0 )
	7270	;1 - not a POW
	7271	"RTN","DGP TRNU",71,0 )
	7272	;3 - POW, unknown
	7273	"RTN","DGP TRNU",72,0 )
	7274	;4 - POW, World War I
	7275	"RTN","DGP TRNU",73,0 )
	7276	;5 - POW, World War II (Europ e)
	7277	"RTN","DGP TRNU",74,0 )
	7278	;6 - POW, World War II (Pacif ic)
	7279	"RTN","DGP TRNU",75,0 )
	7280	;7 - POW, Korea
	7281	"RTN","DGP TRNU",76,0 )
	7282	;8 - POW, Vietnam
	7283	"RTN","DGP TRNU",77,0 )
	7284	;9 - POW, combinati on
	7285	"RTN","DGP TRNU",78,0 )
	7286	N DG52,SI ,PP,Y,VAL
	7287	"RTN","DGP TRNU",79,0 )
	7288	S DG52=$$ GET52^DGPT RNU(DGPTF)
	7289	"RTN","DGP TRNU",80,0 )
	7290	S SI=$P(D G52,U,5) ; POW status indicated ?,
	7291	"RTN","DGP TRNU",81,0 )
	7292	S Y=$P(DG 52,U,6) ;P OW period
	7293	"RTN","DGP TRNU",82,0 )
	7294	S VAL="Y"
	7295	"RTN","DGP TRNU",83,0 )
	7296	I SI="Y" D
	7297	"RTN","DGP TRNU",84,0 )
	7298	.S VAL=$S (Y=0:3,Y=2 :5,Y=3:6,Y =4:7,Y=5:8 ,Y=6:9,Y=7 :"A",Y=8:" B",1:" ")
	7299	"RTN","DGP TRNU",85,0 )
	7300	Q VAL
	7301	"RTN","DGP TRNU",86,0 )
	7302	;
	7303	"RTN","DGP TRNU",87,0 )
	7304	PDIS(DGPTF ) ;place o f disposit ion
	7305	"RTN","DGP TRNU",88,0 )
	7306	N IENS,IE NS1,X
	7307	"RTN","DGP TRNU",89,0 )
	7308	S IENS=DG PTF_","
	7309	"RTN","DGP TRNU",90,0 )
	7310	S X=$$GET 1^DIQ(45,I ENS,75,"I" ),IENS1=X_ ","
	7311	"RTN","DGP TRNU",91,0 )
	7312	Q $$GET1^ DIQ(45.6,I ENS1,2) ;P TF code
	7313	"RTN","DGP TRNU",92,0 )
	7314	;
	7315	"RTN","DGP TRNU",93,0 )
	7316	POS(DGPTF) ;period o f service
	7317	"RTN","DGP TRNU",94,0 )
	7318	N IENS45, DG32,POS1, POS,MV,ELI G
	7319	"RTN","DGP TRNU",95,0 )
	7320	S IENS45= DGPTF_","
	7321	"RTN","DGP TRNU",96,0 )
	7322	S DG32=$$ GET32^DGPT RNU(DGPTF)
	7323	"RTN","DGP TRNU",97,0 )
	7324	S POS1=$P (DG32,U,3) ;period o f service from PATIE NT file (p ointer to file #21)
	7325	"RTN","DGP TRNU",98,0 )
	7326	S POS=$$G ET1^DIQ(21 ,POS1_",", .03) ;code
	7327	"RTN","DGP TRNU",99,0 )
	7328	;Now, use the "APTF " cross-re ference on the PATIE NT MOVEMEN T (#405) f ile to loo k up
	7329	"RTN","DGP TRNU",100, 0)
	7330	;the pati ent moveme nt associa ted with t his PTF en try
	7331	"RTN","DGP TRNU",101, 0)
	7332	S MV="" S :$D(^DGPM( "APTF",PTF )) MV=$O(^ DGPM("APTF ",PTF,0))
	7333	"RTN","DGP TRNU",102, 0)
	7334	;If the p atient mov ement has ODS AT ADM ISSION set (for Oper ation Dese rt Shield) , ensure
	7335	"RTN","DGP TRNU",103, 0)
	7336	;that POS =6 (ODS). This is ne cessary be cause the POS may ha ve been se t to anoth er value
	7337	"RTN","DGP TRNU",104, 0)
	7338	;accordin g the busi ness rules .
	7339	"RTN","DGP TRNU",105, 0)
	7340	I +$$GET1 ^DIQ(405,M V_",",1150 0.01)>0 S POS=6
	7341	"RTN","DGP TRNU",106, 0)
	7342	S ELIG=$$ GET1^DIQ(4 5,IENS45,2 0.1,"I") ; admitting eligibilit y
	7343	"RTN","DGP TRNU",107, 0)
	7344	S POS=$$C KPOS^DGPTU TL(ELIG,PO S) ;update POS (to a ccount for non-vet e ligibiliti es)
	7345	"RTN","DGP TRNU",108, 0)
	7346	Q POS
	7347	"RTN","DGP TRNU",109, 0)
	7348	;
	7349	"RTN","DGP TRNU",110, 0)
	7350	MSTATUS(DG PTF) ;mari tal status
	7351	"RTN","DGP TRNU",111, 0)
	7352	N IENS45, DFN,IENS,X ,MS
	7353	"RTN","DGP TRNU",112, 0)
	7354	S IENS45= DGPTF_","
	7355	"RTN","DGP TRNU",113, 0)
	7356	S DFN=$$G ET1^DIQ(45 ,IENS45,.0 1,"I"),IEN S=DFN_","
	7357	"RTN","DGP TRNU",114, 0)
	7358	S X=$$GET 1^DIQ(2,IE NS,.05,"I" )
	7359	"RTN","DGP TRNU",115, 0)
	7360	S MS=$$GE T1^DIQ(11, X_",",2,"I ")
	7361	"RTN","DGP TRNU",116, 0)
	7362	S:MS="" M S="U"
	7363	"RTN","DGP TRNU",117, 0)
	7364	Q MS
	7365	"RTN","DGP TRNU",118, 0)
	7366	;
	7367	"RTN","DGP TRNU",119, 0)
	7368	ION(DGPTF) ;ionizing radiation (used by 101)
	7369	"RTN","DGP TRNU",120, 0)
	7370	;return v alue
	7371	"RTN","DGP TRNU",121, 0)
	7372	;1 - no c laim of ex posure
	7373	"RTN","DGP TRNU",122, 0)
	7374	;2 - clai ms exposur e, Japan
	7375	"RTN","DGP TRNU",123, 0)
	7376	;3 - clai ms exposur e, testing
	7377	"RTN","DGP TRNU",124, 0)
	7378	;4 - clai ms exposur e, both te sting and Japan
	7379	"RTN","DGP TRNU",125, 0)
	7380	;5 - clai ms exposur e, undergr ound nucle ar testing
	7381	"RTN","DGP TRNU",126, 0)
	7382	;6 - clai ms exposur e, nuclear facility
	7383	"RTN","DGP TRNU",127, 0)
	7384	;7 - clai ms exposur e, other
	7385	"RTN","DGP TRNU",128, 0)
	7386	N DG321,D GNT,DGPOS, RE,E,VPOS
	7387	"RTN","DGP TRNU",129, 0)
	7388	S DG321=$ $GET321^DG PTRNU(DGPT F)
	7389	"RTN","DGP TRNU",130, 0)
	7390	S DGNT=$P (DG321,U,1 2) ;radiat ion exposu re method
	7391	"RTN","DGP TRNU",131, 0)
	7392	S RE=$P(D G321,U,3) ;radiation exposure indicated
	7393	"RTN","DGP TRNU",132, 0)
	7394	S E=" "
	7395	"RTN","DGP TRNU",133, 0)
	7396	S DGPOS=$ $POS(DGPTF )
	7397	"RTN","DGP TRNU",134, 0)
	7398	;valid PO S for ioni zing radia tion?
	7399	"RTN","DGP TRNU",135, 0)
	7400	S VPOS=$S (DGPOS=0:1 ,DGPOS=2:1 ,DGPOS=4:1 ,DGPOS=5:1 ,DGPOS=7:1 ,DGPOS=8:1 ,DGPOS="Z" :1,1:0)
	7401	"RTN","DGP TRNU",136, 0)
	7402	D:VPOS
	7403	"RTN","DGP TRNU",137, 0)
	7404	.S E=$S(R E'="Y":1,1 :DGNT)
	7405	"RTN","DGP TRNU",138, 0)
	7406	Q E
	7407	"RTN","DGP TRNU",139, 0)
	7408	;
	7409	"RTN","DGP TRNU",140, 0)
	7410	ION2(DGPTF ) ;ionizin g radiatio n (used by 701)
	7411	"RTN","DGP TRNU",141, 0)
	7412	;returns Y(es), N(o ) or space
	7413	"RTN","DGP TRNU",142, 0)
	7414	N G
	7415	"RTN","DGP TRNU",143, 0)
	7416	S G=$$GET 1^DIQ(45,D GPTF_",",7 9.27,"I")
	7417	"RTN","DGP TRNU",144, 0)
	7418	Q $S(G="Y ":"Y",G="N ":"N",1:" ")
	7419	"RTN","DGP TRNU",145, 0)
	7420	;
	7421	"RTN","DGP TRNU",146, 0)
	7422	MST(DGPTF) ;military sexual tr auma
	7423	"RTN","DGP TRNU",147, 0)
	7424	N IENS,X, Y
	7425	"RTN","DGP TRNU",148, 0)
	7426	S IENS=DG PTF_","
	7427	"RTN","DGP TRNU",149, 0)
	7428	S Y=$$GET 1^DIQ(45,I ENS,79.29, "I")
	7429	"RTN","DGP TRNU",150, 0)
	7430	Q $S(Y="Y ":"Y",Y="N ":"N",1:" ")
	7431	"RTN","DGP TRNU",151, 0)
	7432	;
	7433	"RTN","DGP TRNU",152, 0)
	7434	HNC(DGPTF) ;treatmen t related to head/ne ck cancer (HNC)
	7435	"RTN","DGP TRNU",153, 0)
	7436	N Y,IENS
	7437	"RTN","DGP TRNU",154, 0)
	7438	S IENS=DG PTF_","
	7439	"RTN","DGP TRNU",155, 0)
	7440	S Y=$$GET 1^DIQ(45,I ENS,79.3," I")
	7441	"RTN","DGP TRNU",156, 0)
	7442	Q $S(Y="Y ":"Y",Y="N ":"N",1:" ")
	7443	"RTN","DGP TRNU",157, 0)
	7444	;
	7445	"RTN","DGP TRNU",158, 0)
	7446	SWASIA(DGP TF) ;treat ment relat ed to serv ice in SW Asia
	7447	"RTN","DGP TRNU",159, 0)
	7448	N Y,IENS
	7449	"RTN","DGP TRNU",160, 0)
	7450	S IENS=DG PTF_","
	7451	"RTN","DGP TRNU",161, 0)
	7452	S Y=$$GET 1^DIQ(45,I ENS,79.28)
	7453	"RTN","DGP TRNU",162, 0)
	7454	Q $S(Y="" :" ",1:Y)
	7455	"RTN","DGP TRNU",163, 0)
	7456	;
	7457	"RTN","DGP TRNU",164, 0)
	7458	CVS(DGPTF) ;combat v et status
	7459	"RTN","DGP TRNU",165, 0)
	7460	;returns 1=yes, 2=n o
	7461	"RTN","DGP TRNU",166, 0)
	7462	N DG0,IEN S,DFN,Y,AD ATE
	7463	"RTN","DGP TRNU",167, 0)
	7464	S DG0=$$G ET0^DGPTRN U(DGPTF)
	7465	"RTN","DGP TRNU",168, 0)
	7466	S IENS=DG PTF_","
	7467	"RTN","DGP TRNU",169, 0)
	7468	S DFN=$$G ET1^DIQ(45 ,IENS,.01, "I")
	7469	"RTN","DGP TRNU",170, 0)
	7470	S ADATE=$ P(DG0,U,2) ;admissio n date
	7471	"RTN","DGP TRNU",171, 0)
	7472	I ADATE S Y=$$CVEDT ^DGCV(DFN, ADATE)
	7473	"RTN","DGP TRNU",172, 0)
	7474	E S Y=$$ CVEDT^DGCV (DFN,ADATE )
	7475	"RTN","DGP TRNU",173, 0)
	7476	Q $S(+Y>0 :1,1:2)
	7477	"RTN","DGP TRNU",174, 0)
	7478	;
	7479	"RTN","DGP TRNU",175, 0)
	7480	CVDT(DGPTF ) ;combat vet date
	7481	"RTN","DGP TRNU",176, 0)
	7482	N DG0,IEN S,DFN,ADAT E,Y
	7483	"RTN","DGP TRNU",177, 0)
	7484	S DG0=$$G ET0^DGPTRN U(DGPTF)
	7485	"RTN","DGP TRNU",178, 0)
	7486	S IENS=DG PTF_","
	7487	"RTN","DGP TRNU",179, 0)
	7488	S DFN=$$G ET1^DIQ(45 ,IENS,.01, "I")
	7489	"RTN","DGP TRNU",180, 0)
	7490	S ADATE=+ $P(DG0,U,2 ) ;admissi on date
	7491	"RTN","DGP TRNU",181, 0)
	7492	I ADATE S Y=$$CVEDT ^DGCV(DFN, ADATE)
	7493	"RTN","DGP TRNU",182, 0)
	7494	E S Y=$$ CVEDT^DGCV (DFN)
	7495	"RTN","DGP TRNU",183, 0)
	7496	Q $S(+Y>0 :$P(Y,U,2) ,1:0)
	7497	"RTN","DGP TRNU",184, 0)
	7498	;
	7499	"RTN","DGP TRNU",185, 0)
	7500	SHAD(DGPTF ) ;SHAD/Pr oject 112
	7501	"RTN","DGP TRNU",186, 0)
	7502	N IENS,Y
	7503	"RTN","DGP TRNU",187, 0)
	7504	S IENS=DG PTF_","
	7505	"RTN","DGP TRNU",188, 0)
	7506	S Y=$$GET 1^DIQ(45,I ENS,79.32, "I")
	7507	"RTN","DGP TRNU",189, 0)
	7508	Q $S(Y="" :" ",1:Y)
	7509	"RTN","DGP TRNU",190, 0)
	7510	;
	7511	"RTN","DGP TRNU",191, 0)
	7512	CLV(DGPTF) ;Camp Lej eune Veter ans DG5.3 914
	7513	"RTN","DGP TRNU",192, 0)
	7514	;Y - yes
	7515	"RTN","DGP TRNU",193, 0)
	7516	;N - no
	7517	"RTN","DGP TRNU",194, 0)
	7518	;" " - un known or n o value
	7519	"RTN","DGP TRNU",195, 0)
	7520	N DGCLV
	7521	"RTN","DGP TRNU",196, 0)
	7522	S DGCLV=$ $GET1^DIQ( 45,DGPTF_" ,",79.33," I")
	7523	"RTN","DGP TRNU",197, 0)
	7524	Q $S(DGCL V=1:"Y",DG CLV=0:"N", 1:" ")
	7525	"RTN","DGP TRNU",198, 0)
	7526	;
	7527	"RTN","DGP TRNU",199, 0)
	7528	KATRINA(DG PTF) ;Katr ina indica tor
	7529	"RTN","DGP TRNU",200, 0)
	7530	N DFN,DG0 ,ERI
	7531	"RTN","DGP TRNU",201, 0)
	7532	S IENS=DG PTF_","
	7533	"RTN","DGP TRNU",202, 0)
	7534	S DG0=$$G ET0(DGPTF) ,DFN=+DG0
	7535	"RTN","DGP TRNU",203, 0)
	7536	S ERI=$$E MGRES^DGUT L(DFN) ;em ergency re sponse ind icator
	7537	"RTN","DGP TRNU",204, 0)
	7538	;returns "K" or " "
	7539	"RTN","DGP TRNU",205, 0)
	7540	Q $S("^K^ "[(U_ERI_U ):"K",1:" ")
	7541	"RTN","DGP TRNU",206, 0)
	7542	;
	7543	"RTN","DGP TRNU",207, 0)
	7544	MTI(DGPTF) ;means te st indicat or
	7545	"RTN","DGP TRNU",208, 0)
	7546	;return v alue
	7547	"RTN","DGP TRNU",209, 0)
	7548	;AS - SC and specia l category veterans
	7549	"RTN","DGP TRNU",210, 0)
	7550	;AN - NSC veterans
	7551	"RTN","DGP TRNU",211, 0)
	7552	;B - cat egory "B" NSC vetera ns
	7553	"RTN","DGP TRNU",212, 0)
	7554	;C - MT copay requ ired (cate gory "C" N SC veteran s)
	7555	"RTN","DGP TRNU",213, 0)
	7556	;N - non -veterans
	7557	"RTN","DGP TRNU",214, 0)
	7558	;X - not applicabl e
	7559	"RTN","DGP TRNU",215, 0)
	7560	;U - not done/comp leted
	7561	"RTN","DGP TRNU",216, 0)
	7562	;G - GMT copay req uired
	7563	"RTN","DGP TRNU",217, 0)
	7564	N VAL,IEN S,MT,AO
	7565	"RTN","DGP TRNU",218, 0)
	7566	S VAL=" "
	7567	"RTN","DGP TRNU",219, 0)
	7568	S IENS=DG PTF_","
	7569	"RTN","DGP TRNU",220, 0)
	7570	S AO=$$GE T1^DIQ(45. 84,IENS,79 .26,"I") ; treated fo r AO condi tion
	7571	"RTN","DGP TRNU",221, 0)
	7572	S MT=$$GE T1^DIQ(45. 84,IENS,10 ,"I") ;mea ns test in dicator
	7573	"RTN","DGP TRNU",222, 0)
	7574	S MT=$S(M T="":"U",1 :MT)
	7575	"RTN","DGP TRNU",223, 0)
	7576	S VAL=$S( AO="Y":"AS ",1:MT)
	7577	"RTN","DGP TRNU",224, 0)
	7578	Q VAL
	7579	"RTN","DGP TRNU",225, 0)
	7580	;
	7581	"RTN","DGP TRNU",226, 0)
	7582	AO(DGPTF) ;treated f or agent o range expo sure (used by 701)
	7583	"RTN","DGP TRNU",227, 0)
	7584	;Y - yes
	7585	"RTN","DGP TRNU",228, 0)
	7586	;N - no
	7587	"RTN","DGP TRNU",229, 0)
	7588	;" " - un known or n o value
	7589	"RTN","DGP TRNU",230, 0)
	7590	N G
	7591	"RTN","DGP TRNU",231, 0)
	7592	S G=$$GET 1^DIQ(45,D GPTF_",",7 9.26,"I")
	7593	"RTN","DGP TRNU",232, 0)
	7594	Q $S(G="Y ":"Y",G="N ":"N",1:" ")
	7595	"RTN","DGP TRNU",233, 0)
	7596	;
	7597	"RTN","DGP TRNU",234, 0)
	7598	AO2(DGPTF) ;agent or ange expos ure (used by 101)
	7599	"RTN","DGP TRNU",235, 0)
	7600	;return v alue:
	7601	"RTN","DGP TRNU",236, 0)
	7602	;1 - no c laim of se rvice in V ietnam
	7603	"RTN","DGP TRNU",237, 0)
	7604	;2 - clai ms service in Vietna m, no expo sure
	7605	"RTN","DGP TRNU",238, 0)
	7606	;3 - clai ms service in Vietna m with exp osure
	7607	"RTN","DGP TRNU",239, 0)
	7608	;4 - clai ms service in Vietna m with exp osure unkn own
	7609	"RTN","DGP TRNU",240, 0)
	7610	;5 - clai ms service in DMZ wi th exposur e
	7611	"RTN","DGP TRNU",241, 0)
	7612	;may retu rn blank
	7613	"RTN","DGP TRNU",242, 0)
	7614	N G,DGAO, DGPOS,DG32 1
	7615	"RTN","DGP TRNU",243, 0)
	7616	S DG321=$ $GET321(DG PTF)
	7617	"RTN","DGP TRNU",244, 0)
	7618	S G=" "
	7619	"RTN","DGP TRNU",245, 0)
	7620	S DGAO=$P (DG321,U,2 )
	7621	"RTN","DGP TRNU",246, 0)
	7622	S DGPOS=$ $POS^DGPTR NU(DGPTF)
	7623	"RTN","DGP TRNU",247, 0)
	7624	S:DGPOS=7 G=$S($P(D G321,U)'=" Y":1,DGAO= "N":2,DGAO ="Y":3,1:4 )
	7625	"RTN","DGP TRNU",248, 0)
	7626	;Check to see if th e exposure location was the Ko rean DMZ
	7627	"RTN","DGP TRNU",249, 0)
	7628	S:(DGAO=" Y")&($P(DG 321,U,13)= "K") G=5
	7629	"RTN","DGP TRNU",250, 0)
	7630	Q G
	7631	"RTN","DGP TRNU",251, 0)
	7632	;
	7633	"RTN","DGP TRNU",252, 0)
	7634	INCOME(DGP TF) ;incom e
	7635	"RTN","DGP TRNU",253, 0)
	7636	N INC,IEN S,LI,PAD
	7637	"RTN","DGP TRNU",254, 0)
	7638	S IENS=DG PTF_","
	7639	"RTN","DGP TRNU",255, 0)
	7640	S INC=$$G ET1^DIQ(45 ,IENS,101. 07)
	7641	"RTN","DGP TRNU",256, 0)
	7642	S:INC>999 999 INC=99 9999
	7643	"RTN","DGP TRNU",257, 0)
	7644	S LI=$L(I NC)
	7645	"RTN","DGP TRNU",258, 0)
	7646	S PAD=$S( LI=0:"0000 00",LI="Y" :"00000",L I=2:"0000" ,LI=3:"000 ",LI=4:"00 ",LI=5:"0" ,1:"")
	7647	"RTN","DGP TRNU",259, 0)
	7648	Q PAD_INC
	7649	"RTN","DGP TRNU",260, 0)
	7650	;
	7651	"RTN","DGP TRNU",261, 0)
	7652	DISP(PTF) ;date of d isposition
	7653	"RTN","DGP TRNU",262, 0)
	7654	N IENS
	7655	"RTN","DGP TRNU",263, 0)
	7656	S IENS=PT F_","
	7657	"RTN","DGP TRNU",264, 0)
	7658	Q $$GET1^ DIQ(45,IEN S,70,"I") ;discharge date
	7659	"RTN","DGP TRNU",265, 0)
	7660	;
	7661	"RTN","DGP TRNU",266, 0)
	7662	GETMPCR(DG TS) ;MPCR from speci alty
	7663	"RTN","DGP TRNU",267, 0)
	7664	N ARRY,Y ,Z,MPCR
	7665	"RTN","DGP TRNU",268, 0)
	7666	S Y=$$TS DATA^DGACT (42.4,DGTS ,.ARRY)
	7667	"RTN","DGP TRNU",269, 0)
	7668	S Z=$G(A RRY(6))
	7669	"RTN","DGP TRNU",270, 0)
	7670	I Y>0 S MPCR=$E($P (Z,".")_"0 000",1,4)_ $E($P(Z,". ",2)_"00", 1,2)
	7671	"RTN","DGP TRNU",271, 0)
	7672	E S MPC R=""
	7673	"RTN","DGP TRNU",272, 0)
	7674	Q MPCR
	7675	"RTN","DGP TRNU",273, 0)
	7676	;
	7677	"RTN","DGP TRNU",274, 0)
	7678	SPCODE(DGT S) ;
	7679	"RTN","DGP TRNU",275, 0)
	7680	N ARRY,Y, Z
	7681	"RTN","DGP TRNU",276, 0)
	7682	S Y=$$TSD ATA^DGACT( 42.4,DGTS, .ARRY)
	7683	"RTN","DGP TRNU",277, 0)
	7684	S Z=$G(AR RY(6))
	7685	"RTN","DGP TRNU",278, 0)
	7686	Q $S(Y>0: Z,1:"")
	7687	"RTN","DGP TRNU",279, 0)
	7688	;
	7689	"RTN","DGP TRNU",280, 0)
	7690	RACE(DGPTF ,DGARR) ;
	7691	"RTN","DGP TRNU",281, 0)
	7692	N IENS45, IENS,DFN
	7693	"RTN","DGP TRNU",282, 0)
	7694	N OUT,MOU T
	7695	"RTN","DGP TRNU",283, 0)
	7696	N I,NUM,M ORE,EVAL,I VAL
	7697	"RTN","DGP TRNU",284, 0)
	7698	S IENS45= DGPTF_","
	7699	"RTN","DGP TRNU",285, 0)
	7700	S DFN=$$G ET1^DIQ(45 ,IENS45,.0 1,"I"),IEN S=","_DFN_ ","
	7701	"RTN","DGP TRNU",286, 0)
	7702	;retrieve at most 6 entries, screening out those that are i nactive
	7703	"RTN","DGP TRNU",287, 0)
	7704	D LIST^DI C(2.02,IEN S,".01",,6 ,,,,"I '$$ INACTIVE^D GUTL4(Y)", ,"OUT","MO UT")
	7705	"RTN","DGP TRNU",288, 0)
	7706	S NUM=$P( OUT("DILIS T",0),U) ; number of subrecords returned
	7707	"RTN","DGP TRNU",289, 0)
	7708	S MORE=$P (OUT("DILI ST",0),U,3 ) ;anymore ?
	7709	"RTN","DGP TRNU",290, 0)
	7710	F I="Y":1 :NUM D
	7711	"RTN","DGP TRNU",291, 0)
	7712	.S EVAL=$ G(OUT("DIL IST",1,I))
	7713	"RTN","DGP TRNU",292, 0)
	7714	.S IVAL=$ G(OUT("DIL IST",2,I))
	7715	"RTN","DGP TRNU",293, 0)
	7716	.S @DGARR @(I,"IEN") =IVAL
	7717	"RTN","DGP TRNU",294, 0)
	7718	.S @DGARR @(I,"VAL") =EVAL
	7719	"RTN","DGP TRNU",295, 0)
	7720	.S @DGARR @(I,"CODE" )=$$PTR2CO DE^DGUTL4( IVAL,1,4)
	7721	"RTN","DGP TRNU",296, 0)
	7722	Q
	7723	"RTN","DGP TSPQ")
	7724	0^60^B1552 3989^B9780 118
	7725	"RTN","DGP TSPQ",1,0)
	7726	DGPTSPQ ;A LB/MTC - P TF Utility Con ; 25 Jan 2019 1:39 PM
	7727	"RTN","DGP TSPQ",2,0)
	7728	;;5.3;Reg istration; 195,397, 565,664,91 4;Aug 13 , 1993;Bui ld 173
	7729	"RTN","DGP TSPQ",3,0)
	7730	;
	7731	"RTN","DGP TSPQ",4,0)
	7732	CHQUES ;-- This func tion will determine if the pat ient has a ny of the
	7733	"RTN","DGP TSPQ",5,0)
	7734	; follo wing indic ated : AO, IR, EC, M ST, NTR, C LV
	7735	"RTN","DGP TSPQ",6,0)
	7736	; If so the array DGEXQ wil l contain:
	7737	"RTN","DGP TSPQ",7,0)
	7738	; DGE XQ(1)="" - AO
	7739	"RTN","DGP TSPQ",8,0)
	7740	; DGE XQ(2)="" - IR
	7741	"RTN","DGP TSPQ",9,0)
	7742	; DGE XQ(3)="" - SW Asia C onditions/ EC
	7743	"RTN","DGP TSPQ",10,0 )
	7744	; DGE XQ(4)="" - MST ;add ed 6/17/98 for MST e nhancement
	7745	"RTN","DGP TSPQ",11,0 )
	7746	; DGE XQ(5)="" - NTR ;tre atment for Head/Neck CA
	7747	"RTN","DGP TSPQ",12,0 )
	7748	; ;ONL Y if (#28. 11) Nose T hroat Radi um entered
	7749	"RTN","DGP TSPQ",13,0 )
	7750	; DGE XQ(6)="" - CV ;tre atment for possible combat rel ated
	7751	"RTN","DGP TSPQ",14,0 )
	7752	; ;con dition
	7753	"RTN","DGP TSPQ",15,0 )
	7754	; DGE XQ(7)="" - SHAD ;tre atment for Project 1 12/SHAD
	7755	"RTN","DGP TSPQ",16,0 )
	7756	; DGE XQ(8)="" - CLV ;RSD 2.6.5.1 C amp Lejeun e DG5.39 14
	7757	"RTN","DGP TSPQ",17,0 )
	7758	; Other wise they will be un defined.
	7759	"RTN","DGP TSPQ",18,0 )
	7760	; This ro utine is c alled from the PTF i nput templ ates.
	7761	"RTN","DGP TSPQ",19,0 )
	7762	; The f ollowing v ariables a re defined :
	7763	"RTN","DGP TSPQ",20,0 )
	7764	; DGH OLD : Move ment recor d before a ny changes been made .
	7765	"RTN","DGP TSPQ",21,0 )
	7766	; DGP TF : PTF Record Num ber.
	7767	"RTN","DGP TSPQ",22,0 )
	7768	; DGM OV : PTF Movement N umber (opt ional)
	7769	"RTN","DGP TSPQ",23,0 )
	7770	N DGHOLD, SDCLY
	7771	"RTN","DGP TSPQ",24,0 )
	7772	S DGHOLD= ^DGPT(DA(1 ),"M",DA,0 ),SDCLY=""
	7773	"RTN","DGP TSPQ",25,0 )
	7774	;-- call to determi ne if ques tions shou ld be aske d. OPC use s same
	7775	"RTN","DGP TSPQ",26,0 )
	7776	; crite ria.
	7777	"RTN","DGP TSPQ",27,0 )
	7778	; If call ed straigh t from Fil eMan, DFN won't be d efined so define it based on v alue in DA (1)
	7779	"RTN","DGP TSPQ",28,0 )
	7780	I $G(DFN) ="",$G(DA( 1))>0 S DF N=$P($G(^D GPT(DA(1), 0)),U,1)
	7781	"RTN","DGP TSPQ",29,0 )
	7782	; If call ed straigh t from Fil eMan, DGPT F won't be defined s o define i t based on value in DA(1)
	7783	"RTN","DGP TSPQ",30,0 )
	7784	I $G(DGPT F)="",$G(D A(1))>0 S DGPTF=$P($ G(^DGPT(DA (1),0)),U, 1)
	7785	"RTN","DGP TSPQ",31,0 )
	7786	;
	7787	"RTN","DGP TSPQ",32,0 )
	7788	D CL^SDCO 21(DFN,$P( DGHOLD,U,1 0),"",.SDC LY)
	7789	"RTN","DGP TSPQ",33,0 )
	7790	I $$GETCL ^DGUTL3(DF N)=1,'$D(S DCLY(9)) S SDCLY(9)= "" ;set CLV array if CLV eli gible beca use SD pat ch is not released f or SDCO21 DG5.39 14
	7791	"RTN","DGP TSPQ",34,0 )
	7792	;
	7793	"RTN","DGP TSPQ",35,0 )
	7794	;-- if sc > 50% and treated f or sc don' t ask AO/I R
	7795	"RTN","DGP TSPQ",36,0 )
	7796	;-- ADD K ILL OF SDC LY(6) TO S KIP COMBAT VETERAN Q UESTION
	7797	"RTN","DGP TSPQ",37,0 )
	7798	I $P($G(^ DGPT(DGPTF ,"M",+$G(D GMOV),0)), U,18)=1 K SDCLY(1),S DCLY(2)
	7799	"RTN","DGP TSPQ",38,0 )
	7800	;
	7801	"RTN","DGP TSPQ",39,0 )
	7802	G:'$D(SDC LY) CHQ
	7803	"RTN","DGP TSPQ",40,0 )
	7804	; AO
	7805	"RTN","DGP TSPQ",41,0 )
	7806	I $D(SDCL Y(1)) S DG EXQ(1)=""
	7807	"RTN","DGP TSPQ",42,0 )
	7808	; IR
	7809	"RTN","DGP TSPQ",43,0 )
	7810	I $D(SDCL Y(2)) S DG EXQ(2)=""
	7811	"RTN","DGP TSPQ",44,0 )
	7812	; SW Asia Condition s/EC
	7813	"RTN","DGP TSPQ",45,0 )
	7814	I $D(SDCL Y(4)) S DG EXQ(3)=""
	7815	"RTN","DGP TSPQ",46,0 )
	7816	; MST
	7817	"RTN","DGP TSPQ",47,0 )
	7818	I $D(SDCL Y(5)) S DG EXQ(4)="" ;added 6/1 7/98 for M ST enhance ment
	7819	"RTN","DGP TSPQ",48,0 )
	7820	; NTR
	7821	"RTN","DGP TSPQ",49,0 )
	7822	I $D(SDCL Y(6)) S DG EXQ(5)=""
	7823	"RTN","DGP TSPQ",50,0 )
	7824	; CV
	7825	"RTN","DGP TSPQ",51,0 )
	7826	I $D(SDCL Y(7)) S DG EXQ(6)=""
	7827	"RTN","DGP TSPQ",52,0 )
	7828	; SHAD
	7829	"RTN","DGP TSPQ",53,0 )
	7830	I $D(SDCL Y(8)) S DG EXQ(7)=""
	7831	"RTN","DGP TSPQ",54,0 )
	7832	; Camp Le jeune
	7833	"RTN","DGP TSPQ",55,0 )
	7834	I $D(SDCL Y(9)) S DG EXQ(8)="" ;RSD 2.6.5 .1 Camp Le jeune DG5 .3914
	7835	"RTN","DGP TSPQ",56,0 )
	7836	CHQ Q
	7837	"RTN","DGP TSPQ",57,0 )
	7838	;
	7839	"RTN","DGP TSPQ",58,0 )
	7840	501 ;-- Th is is the input tran sform logi c for the following questions:
	7841	"RTN","DGP TSPQ",59,0 )
	7842	; AO, I R, EC, MST , NTR
	7843	"RTN","DGP TSPQ",60,0 )
	7844	; Proce ss: Make s ure that t he conditi ons are in dicated be fore
	7845	"RTN","DGP TSPQ",61,0 )
	7846	; allowi ng data to be entere d. If the indicators are
	7847	"RTN","DGP TSPQ",62,0 )
	7848	; not pr esent and the questi on was ans wered, DGE R
	7849	"RTN","DGP TSPQ",63,0 )
	7850	; will b e set to 1 .
	7851	"RTN","DGP TSPQ",64,0 )
	7852	; INPUT : DGFLAG - Field t o check
	7853	"RTN","DGP TSPQ",65,0 )
	7854	; DGER - DGER e rror code
	7855	"RTN","DGP TSPQ",66,0 )
	7856	N DGEXQ
	7857	"RTN","DGP TSPQ",67,0 )
	7858	S DGER=0
	7859	"RTN","DGP TSPQ",68,0 )
	7860	D CHQUES
	7861	"RTN","DGP TSPQ",69,0 )
	7862	I '$D(DGE XQ(+DGFLAG )) S DGER= 1
	7863	"RTN","DGP TSPQ",70,0 )
	7864	Q
	7865	"RTN","DGP TSPQ",71,0 )
	7866	;
	7867	"RTN","DGP TSPQ",72,0 )
	7868	701 ;-- Th is is the input tran sform logi c for the following questions
	7869	"RTN","DGP TSPQ",73,0 )
	7870	; for t he <701> P TF record: AO, IR, EC, MST, N TR, CLV
	7871	"RTN","DGP TSPQ",74,0 )
	7872	; Proce ss: Check if the des ired indic ator was a nswered on a <501>.
	7873	"RTN","DGP TSPQ",75,0 )
	7874	; chang ed 6/17/98 for MST e nhancement
	7875	"RTN","DGP TSPQ",76,0 )
	7876	; INPUT DGFLAG - 1=AO, 2=IR , 3=EC, 4= MST, 5=NTR , 6=CV, 7= SHAD, 8=CL V
	7877	"RTN","DGP TSPQ",77,0 )
	7878	N I
	7879	"RTN","DGP TSPQ",78,0 )
	7880	S DGER=1
	7881	"RTN","DGP TSPQ",79,0 )
	7882	;-- loop thru <501> 's for ind icator spe cified by DGFLAG
	7883	"RTN","DGP TSPQ",80,0 )
	7884	S I=0 F S I=$O(^DG PT(DA,"M", I)) Q:'I I $P($G(^D GPT(DA,"M" ,I,0)),U,D GFLAG+25)' ="" S DGER =0 Q
	7885	"RTN","DGP TSPQ",81,0 )
	7886	Q
	7887	"RTN","DGP TSPQ",82,0 )
	7888	;
	7889	"RTN","DGP TSPQ",83,0 )
	7890	UP701 ;-- This funct ion will l oop thru t he <501> a nd determi ne if any
	7891	"RTN","DGP TSPQ",84,0 )
	7892	; of th e SC, AO, IR, EC, MS T, NTR, CV , SHAD and CLV quest ions have been
	7893	"RTN","DGP TSPQ",85,0 )
	7894	; answe red. If s o, the cor responding <701> wil l be updat ed.
	7895	"RTN","DGP TSPQ",86,0 )
	7896	; An an swer of "y es" will t ake preced ence.
	7897	"RTN","DGP TSPQ",87,0 )
	7898	;
	7899	"RTN","DGP TSPQ",88,0 )
	7900	; INPUT : DGPTF
	7901	"RTN","DGP TSPQ",89,0 )
	7902	; chang ed 6/17/98 for MST e nhancement
	7903	"RTN","DGP TSPQ",90,0 )
	7904	; RSD 2 .6.5.1 Cam p Lejeune DG5.3914
	7905	"RTN","DGP TSPQ",91,0 )
	7906	N I,DGSC, DGAO,DGIR, DGEC,DGMOV ,DGMST,DGN TR,DGCV,DG SHAD,DGCLV
	7907	"RTN","DGP TSPQ",92,0 )
	7908	S (DGSC,D GAO,DGIR,D GEC,DGMST, DGNTR,DGCV ,DGSHAD,DG CLV)="@"
	7909	"RTN","DGP TSPQ",93,0 )
	7910	;-- loop thru <501> s
	7911	"RTN","DGP TSPQ",94,0 )
	7912	S I=0 F S I=$O(^DG PT(DGPTF," M",I)) Q:' I S DGMOV =$G(^(I,0) ) I DGMOV' ="" D
	7913	"RTN","DGP TSPQ",95,0 )
	7914	.;-- sc
	7915	"RTN","DGP TSPQ",96,0 )
	7916	.I $P(DGM OV,U,18)'= "",DGSC'=1 S DGSC=$P (DGMOV,U,1 8)
	7917	"RTN","DGP TSPQ",97,0 )
	7918	.;-- ao
	7919	"RTN","DGP TSPQ",98,0 )
	7920	.I $P(DGM OV,U,26)'= "",DGAO'=" Y" S DGAO= $P(DGMOV,U ,26)
	7921	"RTN","DGP TSPQ",99,0 )
	7922	.;-- ir
	7923	"RTN","DGP TSPQ",100, 0)
	7924	.I $P(DGM OV,U,27)'= "",DGIR'=" Y" S DGIR= $P(DGMOV,U ,27)
	7925	"RTN","DGP TSPQ",101, 0)
	7926	.;-- ec
	7927	"RTN","DGP TSPQ",102, 0)
	7928	.I $P(DGM OV,U,28)'= "",DGEC'=" Y" S DGEC= $P(DGMOV,U ,28)
	7929	"RTN","DGP TSPQ",103, 0)
	7930	.;-- mst ;added 6/1 7/98 for M ST enhance ment
	7931	"RTN","DGP TSPQ",104, 0)
	7932	.I $P(DGM OV,U,29)'= "",DGMST'= "Y" S DGMS T=$P(DGMOV ,U,29)
	7933	"RTN","DGP TSPQ",105, 0)
	7934	.;-- ntr
	7935	"RTN","DGP TSPQ",106, 0)
	7936	.I $P(DGM OV,U,30)'= "",DGNTR'= "Y" S DGNT R=$P(DGMOV ,U,30)
	7937	"RTN","DGP TSPQ",107, 0)
	7938	.;-- cv
	7939	"RTN","DGP TSPQ",108, 0)
	7940	.I $P(DGM OV,U,31)'= "",DGCV'=" Y" S DGCV= $P(DGMOV,U ,31)
	7941	"RTN","DGP TSPQ",109, 0)
	7942	.;-- shad
	7943	"RTN","DGP TSPQ",110, 0)
	7944	.I $P(DGM OV,U,32)'= "",DGSHAD' ="Y" S DGS HAD=$P(DGM OV,U,32)
	7945	"RTN","DGP TSPQ",111, 0)
	7946	.;-- CLV ;RSD 2.6.5 .1 Camp Le jeune DG5 .3914
	7947	"RTN","DGP TSPQ",112, 0)
	7948	.I $P(DGM OV,U,33)'= "" S DGCLV =$P(DGMOV, U,33)
	7949	"RTN","DGP TSPQ",113, 0)
	7950	.;-- upda te <701> f ields
	7951	"RTN","DGP TSPQ",114, 0)
	7952	.; change d 6/17/98 for MST en hancement ; 12/27/17 Modified code to pr event CLV value from deleting at the 70 node level
	7953	"RTN","DGP TSPQ",115, 0)
	7954	.S DR="25 ////^S X=D GSC;26//// ^S X=DGAO; 27////^S X =DGIR;28// //^S X=DGE C;29////^S X=DGMST;3 0////^S X= DGNTR;31// //^S X=DGC V;32////^S X=DGSHAD; 33////^S X =DGCLV"
	7955	"RTN","DGP TSPQ",116, 0)
	7956	.S DIE="^ DGPT("_DGP TF_",""M"" ,",DP=45.0 2,DA(1)=DG PTF,DA=I
	7957	"RTN","DGP TSPQ",117, 0)
	7958	.D ^DIE
	7959	"RTN","DGP TSPQ",118, 0)
	7960	UPQ Q
	7961	"RTN","DGP TSPQ",119, 0)
	7962	;
	7963	"RTN","DGP TSUDO")
	7964	0^82^B3518 6657^B3146 2240
	7965	"RTN","DGP TSUDO",1,0 )
	7966	DGPTSUDO ; ALB/MTC,HI OFO/FT,WOI FO/PMK - P TF UPDATE TRANSFER D RG NODE ; 23 Jan 201 9 9:42 AM
	7967	"RTN","DGP TSUDO",2,0 )
	7968	;;5.3;Reg istration; *441,510, 478,785,85 0,884,914 *;Aug 13, 1993;Build 173
	7969	"RTN","DGP TSUDO",3,0 )
	7970	;;ADL;Upd ate for CS V Project; ;Mar 28, 2 003
	7971	"RTN","DGP TSUDO",4,0 )
	7972	;
	7973	"RTN","DGP TSUDO",5,0 )
	7974	; ICDXCOD E APIs - # 5699
	7975	"RTN","DGP TSUDO",6,0 )
	7976	; ^VA(200 ) reads - #10060
	7977	"RTN","DGP TSUDO",7,0 )
	7978	;
	7979	"RTN","DGP TSUDO",8,0 )
	7980	UTIL S ^UT ILITY($J," T",(999999 9.9999999- I))=K_"^"_ $S($D(^DIC (45.7,J,0) ):$P(^(0), "^",2),1:0 )_"^"_X_"^ ^"_$P(Y,"^ ",8)
	7981	"RTN","DGP TSUDO",9,0 )
	7982	Q
	7983	"RTN","DGP TSUDO",10, 0)
	7984	SUDO1 ;
	7985	"RTN","DGP TSUDO",11, 0)
	7986	N DGPOA,D GDXPOA
	7987	"RTN","DGP TSUDO",12, 0)
	7988	K ^UTILIT Y($J,"T"), T
	7989	"RTN","DGP TSUDO",13, 0)
	7990	F I=0:0 S I=$O(^DGP M("ATS",DF N,DGPMCA,I )) Q:I'>0 D
	7991	"RTN","DGP TSUDO",14, 0)
	7992	. S J=$O( ^DGPM("ATS ",DFN,DGPM CA,I,0)) I J D ;^(J ,0) on nex t line ref erences gl obal on th is line
	7993	"RTN","DGP TSUDO",15, 0)
	7994	.. S K=+$ O(^(J,0)) I $D(^DGPM (K,0)) S Y =^(0),X=$S ($D(^("PTF ")):$P(^(" PTF"),"^", 2),1:"") I $D(^DGPT( PTF,"M",+X ,0))!($D(^ DGPM("APHY ",+$P(Y,"^ ",14),K))) D UTIL
	7995	"RTN","DGP TSUDO",16, 0)
	7996	Q:'$D(^UT ILITY($J," T"))
	7997	"RTN","DGP TSUDO",17, 0)
	7998	VARS I '$D (^UTILITY( $J,"T")) G SUDO1
	7999	"RTN","DGP TSUDO",18, 0)
	8000	N DGNXD
	8001	"RTN","DGP TSUDO",19, 0)
	8002	S (DGPRD, DGNXD)=$O( ^UTILITY($ J,"T",0)) G Q:DGPRD' >0 S T(DGP RD)=^(DGPR D),(DGEXP, DGDMS,DGTR S,DGTLOS,D GLOS,DGDAT )=0,DGPT(7 0)=$S($D(^ DGPT(PTF,7 0)):^(70), 1:""),SEX= $P(^DPT(DF N,0),U,2), DOB=$P(^(0 ),U,3)
	8003	"RTN","DGP TSUDO",20, 0)
	8004	S (DGDX,D GNSV,DGPSV ,DGPOA,DGD XPOA)=""
	8005	"RTN","DGP TSUDO",21, 0)
	8006	N EFFDATE ,DGTEMP,IM PDATE
	8007	"RTN","DGP TSUDO",22, 0)
	8008	D EFFDATE ^DGPTIC10( PTF) S DGD AT=EFFDATE
	8009	"RTN","DGP TSUDO",23, 0)
	8010	K DGSURG, DGPROC S ( DGSURG,DGP ROC)=U
	8011	"RTN","DGP TSUDO",24, 0)
	8012	;
	8013	"RTN","DGP TSUDO",25, 0)
	8014	;-- build DGSURG ar ray
	8015	"RTN","DGP TSUDO",26, 0)
	8016	F I=0:0 S I=$O(^DGP T(PTF,"S", I)) Q:I'>0 D
	8017	"RTN","DGP TSUDO",27, 0)
	8018	. K DG401
	8019	"RTN","DGP TSUDO",28, 0)
	8020	. D PTFIC D^DGPTFUT( 401,PTF,I, .DG401)
	8021	"RTN","DGP TSUDO",29, 0)
	8022	. Q:'$O(D G401(0))
	8023	"RTN","DGP TSUDO",30, 0)
	8024	. ;S Y=+$ P(DG401,U, 16),Y=$S(' $D(DGSURG( Y)):Y,Y[". ":Y_I_1,1: Y_".0000"_ I_1),DGSUR G(Y)=""
	8025	"RTN","DGP TSUDO",31, 0)
	8026	. S Y=I/1 00000000+$ P(DG401,U, 16),DGSURG (Y)=""
	8027	"RTN","DGP TSUDO",32, 0)
	8028	. S DGLOO P=0
	8029	"RTN","DGP TSUDO",33, 0)
	8030	. F S DG LOOP=$O(DG 401(DGLOOP )) Q:'DGLO OP D
	8031	"RTN","DGP TSUDO",34, 0)
	8032	.. Q:$P(D G401(DGLOO P),U,1)=""
	8033	"RTN","DGP TSUDO",35, 0)
	8034	.. S DGPT TMP=$$ICDD ATA^ICDXCO DE("PROC", $P(DG401(D GLOOP),U,1 ),EFFDATE)
	8035	"RTN","DGP TSUDO",36, 0)
	8036	.. I +DGP TTMP>0 S D GSURG(Y)=D GSURG(Y)_$ P(DG401(DG LOOP),U,1) _U
	8037	"RTN","DGP TSUDO",37, 0)
	8038	K DG401,D GLOOP
	8039	"RTN","DGP TSUDO",38, 0)
	8040	;
	8041	"RTN","DGP TSUDO",39, 0)
	8042	;-- build DGPROC ar ray
	8043	"RTN","DGP TSUDO",40, 0)
	8044	F I=0:0 S I=$O(^DGP T(PTF,"P", I)) Q:I'>0 D
	8045	"RTN","DGP TSUDO",41, 0)
	8046	. K DG601
	8047	"RTN","DGP TSUDO",42, 0)
	8048	. D PTFIC D^DGPTFUT( 601,PTF,I, .DG601)
	8049	"RTN","DGP TSUDO",43, 0)
	8050	. Q:'$O(D G601(0))
	8051	"RTN","DGP TSUDO",44, 0)
	8052	. ;S Y=+$ P(DG601,U, 16),Y=$S(' $D(DGPROC( Y)):Y,Y[". ":Y_I_1,1: Y_".0000"_ I_1),DGPRO C(Y)=""
	8053	"RTN","DGP TSUDO",45, 0)
	8054	. S Y=I/1 00000000+$ P(DG601,U, 16),DGPROC (Y)=""
	8055	"RTN","DGP TSUDO",46, 0)
	8056	. S DGLOO P=0
	8057	"RTN","DGP TSUDO",47, 0)
	8058	. F S DG LOOP=$O(DG 601(DGLOOP )) Q:'DGLO OP D
	8059	"RTN","DGP TSUDO",48, 0)
	8060	.. Q:$P(D G601(DGLOO P),U,1)=""
	8061	"RTN","DGP TSUDO",49, 0)
	8062	.. S DGPT TMP=$$ICDD ATA^ICDXCO DE("PROC", $P(DG601(D GLOOP),U,1 ),EFFDATE)
	8063	"RTN","DGP TSUDO",50, 0)
	8064	.. I +DGP TTMP>0 S D GPROC(Y)=D GPROC(Y)_$ P(DG601(DG LOOP),U,1) _U
	8065	"RTN","DGP TSUDO",51, 0)
	8066	K DG601,D GLOOP
	8067	"RTN","DGP TSUDO",52, 0)
	8068	;
	8069	"RTN","DGP TSUDO",53, 0)
	8070	I $D(^DGP T(PTF,"401 P")),+DGPT (70),+DGPT (70)<28710 00 S X=^(" 401P") I X ]"",X'="^^ ^^" D
	8071	"RTN","DGP TSUDO",54, 0)
	8072	. F I=1:1 :5 I $P(X, U,I)]"" S DGPTTMP=$$ ICDDATA^IC DXCODE("PR OC",$P(X,U ,I),EFFDAT E) I +EFFD ATE>0 S DG PROC=DGPRO C_$P(X,U,I )_U,DG401P =1
	8073	"RTN","DGP TSUDO",55, 0)
	8074	;
	8075	"RTN","DGP TSUDO",56, 0)
	8076	SUDO2 ;
	8077	"RTN","DGP TSUDO",57, 0)
	8078	S DGNXD=$ O(^UTILITY ($J,"T",DG NXD))
	8079	"RTN","DGP TSUDO",58, 0)
	8080	G ONE:DGN XD'>0 S T( DGNXD)=^UT ILITY($J," T",DGNXD), I1=+$P(T(D GNXD),U,3) ,DGDOC=$P( T(DGNXD),U ,5),DGCLV= $P(T(DGNXD ),U,6)
	8081	"RTN","DGP TSUDO",59, 0)
	8082	F I=DGPRD ,DGNXD S L 1(I)=$P(T( I),U,2)
	8083	"RTN","DGP TSUDO",60, 0)
	8084	G:L1(DGPR D)=L1(DGNX D) SWCH
	8085	"RTN","DGP TSUDO",61, 0)
	8086	S DGPSV=$ S($D(^DIC( 42.4,+L1(D GPRD),0)): $P(^(0),U, 3),1:""),D GNSV=$S($D (^DIC(42.4 ,+L1(DGNXD ),0)):$P(^ (0),U,3),1 :"")
	8087	"RTN","DGP TSUDO",62, 0)
	8088	G:DGPSV'] ""!(DGNSV' ]"") SWCH
	8089	"RTN","DGP TSUDO",63, 0)
	8090	I "^I^SCI ^B^NH^D^RE ^"'[(U_DGP SV_U),$D(^ DGPT(PTF," M",I1,0)) D
	8091	"RTN","DGP TSUDO",64, 0)
	8092	. S DGNOD E=^(0) ;^( 0) referen ces global on line a bove
	8093	"RTN","DGP TSUDO",65, 0)
	8094	. D BLD I DGPSV'=DG NSV D DRG S DGSURG=U ,DGDX="",D GDXPOA="", DGLOS=0 I '$D(DG401P ) S DGPROC =U
	8095	"RTN","DGP TSUDO",66, 0)
	8096	SWCH ;
	8097	"RTN","DGP TSUDO",67, 0)
	8098	K DGLEV,D GPAS
	8099	"RTN","DGP TSUDO",68, 0)
	8100	S DGPRD=D GNXD,T(DGP RD)=T(DGNX D),(DGNSV, DGPSV)=""
	8101	"RTN","DGP TSUDO",69, 0)
	8102	G SUDO2
	8103	"RTN","DGP TSUDO",70, 0)
	8104	;
	8105	"RTN","DGP TSUDO",71, 0)
	8106	BLD ;
	8107	"RTN","DGP TSUDO",72, 0)
	8108	D PTFICD^ DGPTFUT(50 1,PTF,I1,. DG501)
	8109	"RTN","DGP TSUDO",73, 0)
	8110	QUIT:'$O( DG501(0))
	8111	"RTN","DGP TSUDO",74, 0)
	8112	S DGLOOP= 0 F S DGL OOP=$O(DG5 01(DGLOOP) ) Q:'DGLOO P D
	8113	"RTN","DGP TSUDO",75, 0)
	8114	. I $P(DG NODE,U,1)] "" S DGPTT MP=$$ICDDA TA^ICDXCOD E("DIAG",$ P(DG501(DG LOOP),U,1) ,EFFDATE) I +DGPTTMP >0 S DGDX= DGDX_$P(DG 501(DGLOOP ),U,1)_U,D GDXPOA=DGD XPOA_$P(DG 501(DGLOOP ),U,2)_U
	8115	"RTN","DGP TSUDO",76, 0)
	8116	K DG501,D GLOOP
	8117	"RTN","DGP TSUDO",77, 0)
	8118	;S:$L(DGD X)>200 DGD X=$P(DGDX, U,1,30)
	8119	"RTN","DGP TSUDO",78, 0)
	8120	S DGLEV=$ P(DGNODE,U ,3),DGPAS= $P(DGNODE, U,4),X1=DG NXD,X2=DGP RD D ^%DTC S X=$S(X> 0:X,1:1)-D GLEV-DGPAS ,DGLOS=DGL OS+X
	8121	"RTN","DGP TSUDO",79, 0)
	8122	N I,J,X,Y ,Z
	8123	"RTN","DGP TSUDO",80, 0)
	8124	F I=0:0 S I=$O(DGSU RG(I)) Q:I '>0!(I\1>( DGNXD\1)) D SU
	8125	"RTN","DGP TSUDO",81, 0)
	8126	I '$D(DG4 01P) F I=0 :0 S I=$O( DGPROC(I)) Q:I'>0!(( I\1)>(DGNX D\1)) D
	8127	"RTN","DGP TSUDO",82, 0)
	8128	.S X=DGPR OC(I)
	8129	"RTN","DGP TSUDO",83, 0)
	8130	.F J=1:1: 25 S Y=$P( X,U,J) Q:Y ="" D
	8131	"RTN","DGP TSUDO",84, 0)
	8132	..;Q:$L(D GPROC)>240 ; - no lo nger neede d
	8133	"RTN","DGP TSUDO",85, 0)
	8134	..S Z=U_Y _U
	8135	"RTN","DGP TSUDO",86, 0)
	8136	..S DGPRO C=DGPROC_Y _U
	8137	"RTN","DGP TSUDO",87, 0)
	8138	..S DGPRO C(J)=Y
	8139	"RTN","DGP TSUDO",88, 0)
	8140	..K DGPRO C(I)
	8141	"RTN","DGP TSUDO",89, 0)
	8142	Q
	8143	"RTN","DGP TSUDO",90, 0)
	8144	SU ;
	8145	"RTN","DGP TSUDO",91, 0)
	8146	I I<DGNXD !(DGPSV=DG NSV)!(DGPS V="S") D
	8147	"RTN","DGP TSUDO",92, 0)
	8148	.S X=DGSU RG(I)
	8149	"RTN","DGP TSUDO",93, 0)
	8150	.F J=1:1: 25 S Y=$P( X,U,J) Q:Y ="" D
	8151	"RTN","DGP TSUDO",94, 0)
	8152	..;Q:$L(D GSURG)>240 ; - no lo nger neede d
	8153	"RTN","DGP TSUDO",95, 0)
	8154	..S Z=U_Y _U
	8155	"RTN","DGP TSUDO",96, 0)
	8156	..S DGSUR G=DGSURG_Y _U
	8157	"RTN","DGP TSUDO",97, 0)
	8158	..S ICDSU RG(J)=Y
	8159	"RTN","DGP TSUDO",98, 0)
	8160	..K DGSUR G(I)
	8161	"RTN","DGP TSUDO",99, 0)
	8162	Q
	8163	"RTN","DGP TSUDO",100 ,0)
	8164	DRG ;
	8165	"RTN","DGP TSUDO",101 ,0)
	8166	S AGE=DGP RD-DOB\100 00,DGTLOS= DGTLOS+DGL OS,DRG=""
	8167	"RTN","DGP TSUDO",102 ,0)
	8168	D ^DGPTIC D
	8169	"RTN","DGP TSUDO",103 ,0)
	8170	S DGDOC=$ S($D(^VA(2 00,+DGDOC) ):DGDOC,1: "")
	8171	"RTN","DGP TSUDO",104 ,0)
	8172	N DGFDA,D GMSG
	8173	"RTN","DGP TSUDO",105 ,0)
	8174	S DGFDA(4 5.02,I1_", "_PTF_",", 20)=DRG ;transfe r drg
	8175	"RTN","DGP TSUDO",106 ,0)
	8176	S DGFDA(4 5.02,I1_", "_PTF_",", 21)=DGPSV ;losing service
	8177	"RTN","DGP TSUDO",107 ,0)
	8178	S DGFDA(4 5.02,I1_", "_PTF_",", 22)=DGNXD ;transfe r date
	8179	"RTN","DGP TSUDO",108 ,0)
	8180	S DGFDA(4 5.02,I1_", "_PTF_",", 23)=DGLOS ;los in service
	8181	"RTN","DGP TSUDO",109 ,0)
	8182	S DGFDA(4 5.02,I1_", "_PTF_",", 24)=DGDOC ;provide r
	8183	"RTN","DGP TSUDO",110 ,0)
	8184	S DGFDA(4 5.02,I1_", "_PTF_",", 25)=DGTLOS ;cumulat ive los
	8185	"RTN","DGP TSUDO",111 ,0)
	8186	I $P($G(^ DGPT(PTF," M",2,0)),U ,33)="" D
	8187	"RTN","DGP TSUDO",112 ,0)
	8188	.I $G(DGC LV)'="" S DGFDA(45.0 2,I1_","_P TF_",",33) =DGCLV ; DG5.391 4 Camp Lej eune ; onl y set if v alue exist s so to no t overlay a null in previous v alues
	8189	"RTN","DGP TSUDO",113 ,0)
	8190	D FILE^DI E("","DGFD A","DGMSG" )
	8191	"RTN","DGP TSUDO",114 ,0)
	8192	Q
	8193	"RTN","DGP TSUDO",115 ,0)
	8194	ONE ;
	8195	"RTN","DGP TSUDO",116 ,0)
	8196	S DGNXD=$ S(+$P(^DGP T(PTF,"M", 1,0),U,10) :$P(^(0),U ,10),1:DT) ,L1(DGNXD) =$P(^(0),U ,2) S:'$D( T(DGNXD)) T(DGNXD)=T (DGPRD),DG DOC=$P(T(D GNXD),U,5) ,DGCLV=$P( T(DGNXD),U ,6)
	8197	"RTN","DGP TSUDO",117 ,0)
	8198	S:$P(DGPT (70),U,3)> 5 DGEXP=1 S:$P(DGPT( 70),U,3)=4 DGDMS=1 S :$P(DGPT(7 0),U,13) D GTRS=1
	8199	"RTN","DGP TSUDO",118 ,0)
	8200	I L1(DGNX D),$D(^DIC (42.4,+L1( DGNXD),0)) S I1=1,DG PSV=$P(^(0 ),U,3),DGA DM=$P(^DGP T(PTF,0),U ,2)
	8201	"RTN","DGP TSUDO",119 ,0)
	8202	S DGNODE= $S($D(^DGP T(PTF,"M", 1,0)):^(0) ,1:""),I1= 1
	8203	"RTN","DGP TSUDO",120 ,0)
	8204	D BLD
	8205	"RTN","DGP TSUDO",121 ,0)
	8206	I $D(^DGP T("AADA",D GADM,PTF)) F I=10,11 I $P(DGPT (70),U,I) S DGDX=$P( DGPT(70),U ,I)_U_DGDX ,DGDXPOA=$ P($G(^DGPT (PTF,82)), U)_U_$G(DG DXPOA) QUI T
	8207	"RTN","DGP TSUDO",122 ,0)
	8208	D DRG,^DG PTSUD1
	8209	"RTN","DGP TSUDO",123 ,0)
	8210	Q ;
	8211	"RTN","DGP TSUDO",124 ,0)
	8212	; DG5.3 914 Camp L ejeune KIL L DGCLV va riable
	8213	"RTN","DGP TSUDO",125 ,0)
	8214	K DGCLV,D GDMS,DGDOC ,DGDX,DGEX P,DGLEV,DG LOS,DGNODE ,DGNSV,DGN XD,DGPAS,D GPRD,DGPRO C,DGPSV,DG PT,DGSURG, ICDSURG,DG TLOS,DGTRS ,DG401P,DG DXPOA,I,I1 ,I2,J,L1,T ,X,X1,X2,Y
	8215	"RTN","DGP TSUDO",126 ,0)
	8216	Q
	8217	"RTN","DGP TTS1")
	8218	0^84^B3065 5902^B2887 0180
	8219	"RTN","DGP TTS1",1,0)
	8220	DGPTTS1 ;A LB/AS/ADL/ PLT - FACI LITY TREAT ING SPECIA LTY AND 50 1 MOVEMENT S, cont. ; 6/3/15 11: 13am
	8221	"RTN","DGP TTS1",2,0)
	8222	;;5.3;Reg istration; 26,64,41 8,510,478, 850,884,91 4;Aug 13 , 1993;Bui ld 173
	8223	"RTN","DGP TTS1",3,0)
	8224	;;Per VA Directive 6402, this routine s hould not be modifie d.
	8225	"RTN","DGP TTS1",4,0)
	8226	;;ADL;Upd ate for CS V Project; ;Mar 28, 2 003
	8227	"RTN","DGP TTS1",5,0)
	8228	;
	8229	"RTN","DGP TTS1",6,0)
	8230	;build DG A array w/ patient's last treat spec of t he day as of 11:59 p m
	8231	"RTN","DGP TTS1",7,0)
	8232	;
	8233	"RTN","DGP TTS1",8,0)
	8234	LOOP ;
	8235	"RTN","DGP TTS1",9,0)
	8236	S DGNEXT= $O(^DGPM(" ATS",DFN,D GPMCA,DGPR EV))
	8237	"RTN","DGP TTS1",10,0 )
	8238	F DGNEXT= DGNEXT:0 Q :($P(DGPRE V,".")'=$P (DGNEXT,". "))!('DGNE XT) S DGN EXT=$O(^DG PM("ATS",D FN,DGPMCA, DGNEXT))
	8239	"RTN","DGP TTS1",11,0 )
	8240	S X=$O(^D GPM("ATS", DFN,DGPMCA ,DGPREV,0) ),DGA(9999 999.999999 -$E(DGPREV ,1,14))=$S ($D(^DIC(4 5.7,+X,0)) :$P(^(0)," ^",2),1:0) _"^"_$O(^D GPM("ATS", DFN,DGPMCA ,DGPREV,X, 0)) I DGNE XT>0 S DGP REV=DGNEXT G LOOP
	8241	"RTN","DGP TTS1",12,0 )
	8242	S DGPREV= 0,X=$S($D( ^DIC(42,+$ P(DGPMAN," ^",6),0)): $P(^(0),"^ ",3),1:0) I "^NH^D^" [(U_X_U)!( $P(^(0),"^ ",17)=1) D ASIH^DGPT TS2 ;p-418
	8243	"RTN","DGP TTS1",13,0 )
	8244	;
	8245	"RTN","DGP TTS1",14,0 )
	8246	LOOP1 ; -- compare s pecs betwe en mvts ; sort out x fr if spec did't cha nge
	8247	"RTN","DGP TTS1",15,0 )
	8248	S DGSAVE= DGPREV
	8249	"RTN","DGP TTS1",16,0 )
	8250	S DGPREV= $O(DGA(DGP REV)),DGNE XT=$O(DGA( DGPREV)),X =+DGA(DGPR EV) I DGNE XT S Y=+DG A(DGNEXT) I (X=Y)!(( X=70)&(Y=7 1))!((X=71 )&(Y=70)) K DGA(DGNE XT) S DGPR EV=DGSAVE I $O(DGA(D GPREV))>0 G LOOP1
	8251	"RTN","DGP TTS1",17,0 )
	8252	;
	8253	"RTN","DGP TTS1",18,0 )
	8254	; -- is m vt during adm
	8255	"RTN","DGP TTS1",19,0 )
	8256	I DGPREV< +DGPMAN!($ P(DGPREV," .")'<$S(DG DT:$P(+DGD T,"."),1:9 999999)) S (DG1,DG2) =+$P(DGA(D GPREV),"^" ,2) D DEL: $S('$D(^DG PM(DG1,"PT F")):0,1:$ P(^("PTF") ,"^",2)]"" ) G LOOPQ
	8257	"RTN","DGP TTS1",20,0 )
	8258	;
	8259	"RTN","DGP TTS1",21,0 )
	8260	; build ^ UTILITY fo r mvts who se spec ch anged
	8261	"RTN","DGP TTS1",22,0 )
	8262	S X=$S($D (^DGPM($P( DGA(DGPREV ),"^",2)," PTF")):^(" PTF"),1:"" ),^UTILITY ($J,"T",DG PREV)=$P(D GA(DGPREV) ,"^",2)_"^ "_+DGA(DGP REV)_"^"_$ P(X,"^",2) _"^"_$P(X, "^",3)_"^" _$S($D(^DG PM($P(DGA( DGPREV),"^ ",2),0)):$ P(^(0),"^" ,8),1:"")
	8263	"RTN","DGP TTS1",23,0 )
	8264	S ^UTILIT Y($J,"T",D GPREV)=^UT ILITY($J," T",DGPREV) _"^"_$S($D (^DGPM($P( DGA(DGPREV ),"^",2),0 )):$P(^(0) ,"^",29),1 :"") ;DG* 5.3*914 Ca mp Lejeune put CLV response a t 6th piec e of UTILI TY global
	8265	"RTN","DGP TTS1",24,0 )
	8266	LOOPQ I $O (DGA(DGPRE V)) G LOOP 1
	8267	"RTN","DGP TTS1",25,0 )
	8268	;
	8269	"RTN","DGP TTS1",26,0 )
	8270	; look fo r mvts in ^DGPM that have a PT F mvt # en try
	8271	"RTN","DGP TTS1",27,0 )
	8272	; but not in ^UTILI TY. If an y are foun d, delete from ^DGPT .
	8273	"RTN","DGP TTS1",28,0 )
	8274	F DGPREV= 0:0 S DGPR EV=$O(^DGP M("ATS",DF N,DGPMCA,D GPREV)) Q: DGPREV'>0 S X=$O(^D GPM("ATS", DFN,DGPMCA ,DGPREV,0) ),(DG1,DG2 )=$O(^DGPM ("ATS",DFN ,DGPMCA,DG PREV,+X,0) ) I $D(^DG PM(+DG1,"P TF")),$P(^ ("PTF"),"^ ",2)]"" D DEL
	8275	"RTN","DGP TTS1",29,0 )
	8276	;
	8277	"RTN","DGP TTS1",30,0 )
	8278	K Y S Y=+ $O(^DGPM(" APHY",DGPM CA,0)) I $ D(^DGPM(Y, 0)) S Y(0) =^(0),Y("P TF")=$S($D (^("PTF")) :^("PTF"), 1:"")
	8279	"RTN","DGP TTS1",31,0 )
	8280	I $D(Y)>1 0 S T("ADM ")=Y_"^"_$ S($D(^DIC( 45.7,+$P(Y (0),"^",9) ,0)):$P(^( 0),"^",2), 1:"")_"^^" _$P(Y("PTF "),"^",3)_ "^"_$P(Y(0 ),"^",8) K Y
	8281	"RTN","DGP TTS1",32,0 )
	8282	;
	8283	"RTN","DGP TTS1",33,0 )
	8284	S DGDEL=$ O(^UTILITY ($J,"T",0) ) ;^(DGDEL ) in next line refer ences glob al on this line
	8285	"RTN","DGP TTS1",34,0 )
	8286	I DGDEL S T(DGDEL)= ^(DGDEL),D G1=$P(T(DG DEL),"^",3 ) I DG1 S T(DGDEL)=$ P(T(DGDEL) ,U,1,2) D K DA S DI K="^DGPT(" _PTF_",""M "",",DA(1) =PTF,DA=DG 1 D ^DIK K DA S ^UTI LITY($J,"T ",DGDEL)=$ P(T(DGDEL) ,U,1,2)
	8287	"RTN","DGP TTS1",35,0 )
	8288	. N DGREC 81,DGREC82
	8289	"RTN","DGP TTS1",36,0 )
	8290	. S DGREC =$S($D(^DG PT(PTF,"M" ,DG1,0)):^ (0),1:""), DGREC81=$G (^(81)),DG REC82=$G(^ (82))
	8291	"RTN","DGP TTS1",37,0 )
	8292	. D MSG
	8293	"RTN","DGP TTS1",38,0 )
	8294	. QUIT
	8295	"RTN","DGP TTS1",39,0 )
	8296	K DGA K:$ D(T(+DGDT) ) T(DGDT)
	8297	"RTN","DGP TTS1",40,0 )
	8298	S DGAD=+D GPMAN F I= 0:0 S I=$O (^UTILITY( $J,"T",I)) Q:I'>0 S DGAD=I
	8299	"RTN","DGP TTS1",41,0 )
	8300	S DGREC1= $S($D(^DGP T(PTF,"M", 1,0)):^(0) ,1:"")
	8301	"RTN","DGP TTS1",42,0 )
	8302	S DGREC=$ S($D(^UTIL ITY($J,"T" ,DGAD)):^( DGAD),$D(T ("ADM")):T ("ADM"),1: "")
	8303	"RTN","DGP TTS1",43,0 )
	8304	I DGREC,$ D(^DGPM(+D GREC,0)) D
	8305	"RTN","DGP TTS1",44,0 )
	8306	.N DGFDA, DGMSG
	8307	"RTN","DGP TTS1",45,0 )
	8308	.S DGFDA( 405,(+DGRE C)_",",53) =1
	8309	"RTN","DGP TTS1",46,0 )
	8310	.D FILE^D IE("","DGF DA","DGMSG ")
	8311	"RTN","DGP TTS1",47,0 )
	8312	S DGREC=$ P(DGREC,U, 2)
	8313	"RTN","DGP TTS1",48,0 )
	8314	I DGDT W: 'DGREC&'$D (ZTQUEUED) !,"No Tre ating Spec ialty Tran sfers",! S I1=1,DIE= "^DGPT(",D A=PTF,DR=" 71///"_DGR EC D ^DIE: DGREC S PR =DGAD,NX=D GDT D LOL^ DGPTTS2 I $P(DGREC1, U,3,4)'=(L OL_U_LOP) S DR="3/// "_LOL_";4/ //"_LOP,I1 =1 D TD5^D GPTTS2 K D R
	8315	"RTN","DGP TTS1",49,0 )
	8316	I 'DGDT S PR=DGAD,N X=DT,I1=1 D LOL^DGPT TS2 I $P(D GREC1,U,2, 4)'=(DGREC _U_LOL_U_L OP) S DR=" 3///"_LOL_ ";4///"_LO P_$S(DGREC :";2///"_D GREC,1:"") D TD5^DGP TTS2
	8317	"RTN","DGP TTS1",50,0 )
	8318	K DGSAVE, DR,DGREC1 D ^DGPTTS2 Q
	8319	"RTN","DGP TTS1",51,0 )
	8320	;
	8321	"RTN","DGP TTS1",52,0 )
	8322	DEL Q:$D(^ UTILITY($J ,"T",(9999 999.999999 -$E(DGPREV ,1,14))))
	8323	"RTN","DGP TTS1",53,0 )
	8324	S DG1=$P( ^DGPM(DG1, "PTF"),"^" ,2) D I D GREC]"" K DA S DIK=" ^DGPT("_PT F_",""M"", ",DA(1)=PT F,DA=DG1 D ^DIK K DA
	8325	"RTN","DGP TTS1",54,0 )
	8326	. N DGREC 81,DGREC82
	8327	"RTN","DGP TTS1",55,0 )
	8328	. S DGREC =$S($D(^DG PT(PTF,"M" ,+DG1,0)): ^(0),1:"") ,DGREC81=$ G(^(81)),D GREC82=$G( ^(82))
	8329	"RTN","DGP TTS1",56,0 )
	8330	. QUIT:DG REC=""
	8331	"RTN","DGP TTS1",57,0 )
	8332	. D MSG
	8333	"RTN","DGP TTS1",58,0 )
	8334	. QUIT
	8335	"RTN","DGP TTS1",59,0 )
	8336	S DA=DG2, DR="52///@ ;53///@",D IE="^DGPM( " D ^DIE Q
	8337	"RTN","DGP TTS1",60,0 )
	8338	;
	8339	"RTN","DGP TTS1",61,0 )
	8340	MSG ;
	8341	"RTN","DGP TTS1",62,0 )
	8342	N EFFDATE ,IMPDATE,D GPTDAT
	8343	"RTN","DGP TTS1",63,0 )
	8344	D EFFDATE ^DGPTIC10( PTF)
	8345	"RTN","DGP TTS1",64,0 )
	8346	S DGMSG=" ",DGMSG81= "",DGMSG82 =""
	8347	"RTN","DGP TTS1",65,0 )
	8348	F X=5:1:1 5 I X'=10 S DGPTTMP= $$ICDDATA^ ICDXCODE(" DIAG",+$P( DGREC,U,X) ,EFFDATE), DGMSG=DGMS G_$S(+DGPT TMP>0:$P(D GPTTMP,U,2 )_", ",1:" "),DGMSG82 =DGMSG82_$ S(+DGPTTMP >0:$P(DGRE C82,U,X-4- (X>10))_", ",1:"")
	8349	"RTN","DGP TTS1",66,0 )
	8350	F X=1:1:1 5 S DGPTTM P=$$ICDDAT A^ICDXCODE ("DIAG",+$ P(DGREC81, U,X),EFFDA TE),DGMSG8 1=DGMSG81_ $S(+DGPTTM P>0:$P(DGP TTMP,U,2)_ ", ",1:"") ,DGMSG82=D GMSG82_$S( +DGPTTMP>0 :$P(DGREC8 2,U,X+10)_ ", ",1:"")
	8351	"RTN","DGP TTS1",67,0 )
	8352	QUIT:DGMS G=""&(DGMS G81="")
	8353	"RTN","DGP TTS1",68,0 )
	8354	I DGMSG=" " S DGMSG= DGMSG81 K DGMSG81
	8355	"RTN","DGP TTS1",69,0 )
	8356	S ^UTILIT Y($J,"DEL" ,DG1)=DGMS G,^(DG1,82 )=DGMSG82 S:DGMSG81] "" ^(81)=D GMSG81
	8357	"RTN","DGP TTS1",70,0 )
	8358	;-- save expanded c odes
	8359	"RTN","DGP TTS1",71,0 )
	8360	S DGMSG1= ""
	8361	"RTN","DGP TTS1",72,0 )
	8362	I $D(^DGP T(PTF,"M", +DG1,300)) S DGEX=^( 300) F X=2 :1:7 S:$P( DGEX,U,X)] "" $P(DGMS G1,U,X)=$P (DGEX,U,X)
	8363	"RTN","DGP TTS1",73,0 )
	8364	S:DGMSG1] "" ^UTILIT Y($J,300,D G1)=DGMSG1
	8365	"RTN","DGP TTS1",74,0 )
	8366	K DGMSG1
	8367	"RTN","DGP TTS1",75,0 )
	8368	S Y=$P(DG REC,U,10) X ^DD("DD" ) S DGMSG= "501 movem ent of "_$ P(^DPT(DFN ,0),U,1)_" of "_Y_" losing spe cialty "_$ P(^DIC(42. 4,$P(DGREC ,U,2),0),U ,1)_" was deleted by "_$P(^VA( 200,DUZ,0) ,U,1)_" it contained diag "_$E (DGMSG,1,1 20)
	8369	"RTN","DGP TTS1",76,0 )
	8370	S:'$D(DGP MAN) DGPMA N=^DGPM(DG PMCA,0) D MSG^DGPTMS G1
	8371	"RTN","DGP TTS1",77,0 )
	8372	K DGEX,DG MSG81,DGMS G82 Q
	8373	"RTN","DGP TTS2")
	8374	0^85^B2854 2647^B2220 0737
	8375	"RTN","DGP TTS2",1,0)
	8376	DGPTTS2 ;A LB/JDS/PLT - FACILIT Y TREATING SPECIALTY AND 501 M OVEMENTS, cont. ; 29 Jan 2019 12:19 PM
	8377	"RTN","DGP TTS2",2,0)
	8378	;;5.3;Reg istration; 549,478, 884,914; Aug 13, 19 93;Build 1 73
	8379	"RTN","DGP TTS2",3,0)
	8380	;;Per VA Directive 6402, this routine s hould not be modifie d.
	8381	"RTN","DGP TTS2",4,0)
	8382	;
	8383	"RTN","DGP TTS2",5,0)
	8384	S NX=$O(^ UTILITY($J ,"T",0)),D GDR=0 Q:NX '>0 S T(N X)=^(NX),I 2=$P(T(NX) ,U,4),B(50 1)=U
	8385	"RTN","DGP TTS2",6,0)
	8386	F I=0:0 S I=$O(^DGP T(PTF,"M", I)) Q:I'>0 D
	8387	"RTN","DGP TTS2",7,0)
	8388	.N FLD,DG FDA,DGMSG
	8389	"RTN","DGP TTS2",8,0)
	8390	.F FLD=20 :1:25 S DG FDA(45.02, I_","_PTF_ ",",FLD)=" @"
	8391	"RTN","DGP TTS2",9,0)
	8392	.D FILE^D IE("","DGF DA","DGMSG ")
	8393	"RTN","DGP TTS2",10,0 )
	8394	LOOP1 K:$D (PR) T(PR) N DGFIX S DGFIX=0,P R=NX,NX=$O (^UTILITY( $J,"T",NX) ) G Q:NX'> 0 S T(NX)= ^(NX),T(PR )=^(PR)
	8395	"RTN","DGP TTS2",11,0 )
	8396	; DG5.3 914 Camp L ejeune Ad ded DGCLV below on s everal lin es
	8397	"RTN","DGP TTS2",12,0 )
	8398	S I1=+$P( T(NX),U,3) ,I2=$S($O( ^(NX)):$P( ^(NX),U,3) ,1:0),DGDO C=$P(T(NX) ,U,5),DGCL V=$P(T(NX) ,U,6) F I= PR,NX S DG 1(I)=$P(T( I),U,2)
	8399	"RTN","DGP TTS2",13,0 )
	8400	D ADT1:I1 '>0,ONE:$P (T(PR),U,4 )'=I1,LOL
	8401	"RTN","DGP TTS2",14,0 )
	8402	S A=$S($D (^DGPT(PTF ,"M",I1,0) ):^(0),1:" ")
	8403	"RTN","DGP TTS2",15,0 )
	8404	I DGFIX'= 1,$P(A,U,1 ,4)'=(I1_U _DG1(PR)_U _LOL_U_LOP )!($P(A,U, 10)'=NX)!( $G(DGCLV)' ="") S DR= $S('A:".01 ///"_I1_"; ",1:"")_"2 ////"_DG1( PR)_";3/// "_LOL_";4/ //"_LOP_"; 10////"_NX _$S($G(DGC LV)'="":"; 33////"_DG CLV,1:"") D TD5
	8405	"RTN","DGP TTS2",16,0 )
	8406	N DGPCE33 ,DGTLAST,D GTPCE2,DGF CTY,DGLAST ,DGLSTPCE, DGPMV
	8407	"RTN","DGP TTS2",17,0 )
	8408	S DGLAST= $P(^DGPT(P TF,"M",0), U,3)
	8409	"RTN","DGP TTS2",18,0 )
	8410	S DGPMV=$ O(^DGPM("A PTF",PTF," "))
	8411	"RTN","DGP TTS2",19,0 )
	8412	I $P(T(NX ),U,6)="" S DGPCE33= $P(^DGPM(D GPMV,0),U, 29)
	8413	"RTN","DGP TTS2",20,0 )
	8414	I $P(T(NX ),U,6)'="" S DGPCE33 =$P(T(NX), U,6)
	8415	"RTN","DGP TTS2",21,0 )
	8416	S DGTPCE2 =$P(T(NX), U,2)
	8417	"RTN","DGP TTS2",22,0 )
	8418	S DGTLAST =$P(T(NX), U,4)
	8419	"RTN","DGP TTS2",23,0 )
	8420	I $G(DGTL AST)'="" S DGFCTY=$P (^DGPT(PTF ,"M",DGTLA ST,0),U,2)
	8421	"RTN","DGP TTS2",24,0 )
	8422	I $G(DGPC E33)'="",D GFIX'=1,DG TLAST=DGLA ST S ^TMP( $J,"DGPTF" )=DGPCE33, $P(^DGPT(P TF,"M",DGL AST,0),U,3 3)=DGPCE33
	8423	"RTN","DGP TTS2",25,0 )
	8424	I $G(DGTL AST)'="",D GTLAST>2,D GTPCE2=DGF CTY,DGPCE3 3'="" D
	8425	"RTN","DGP TTS2",26,0 )
	8426	. S $P(^D GPT(PTF,"M ",DGTLAST, 0),U,33)=D GPCE33
	8427	"RTN","DGP TTS2",27,0 )
	8428	. S ^TMP( $J,"DGPTF" ,DGTLAST)= DGPCE33
	8429	"RTN","DGP TTS2",28,0 )
	8430	I DGTLAST =1 D
	8431	"RTN","DGP TTS2",29,0 )
	8432	. N DGFRS T
	8433	"RTN","DGP TTS2",30,0 )
	8434	. S DGFRS T=$P(T(NX) ,U,6)
	8435	"RTN","DGP TTS2",31,0 )
	8436	. I DGFRS T'="" S $P (^DGPT(PTF ,"M",DGTLA ST,0),U,33 )=DGFRST
	8437	"RTN","DGP TTS2",32,0 )
	8438	. S DGFIX =1
	8439	"RTN","DGP TTS2",33,0 )
	8440	I $P(T(PR ),U,4)'=I1 S DR="53/ //"_I1,DA= +T(PR),DIE ="^DGPM(" D ^DIE
	8441	"RTN","DGP TTS2",34,0 )
	8442	G LOOP1
	8443	"RTN","DGP TTS2",35,0 )
	8444	;
	8445	"RTN","DGP TTS2",36,0 )
	8446	ADT1 F L +^DGPT(PTF ,"M",0):1 I $T QUIT
	8447	"RTN","DGP TTS2",37,0 )
	8448	S:'$D(^DG PT(PTF,"M" ,0)) ^DGPT (PTF,"M",0 )="^45.02A I^1^1"
	8449	"RTN","DGP TTS2",38,0 )
	8450	F I=0:0 S I=$O(^DGP T(PTF,"M", I)) Q:I'>0 S I1=I
	8451	"RTN","DGP TTS2",39,0 )
	8452	S I1=I1+1 ,J=^DGPT(P TF,"M",0), ^(0)=$P(J, U,1,2)_U_I 1_U_($P(J, U,4)+1) L -^DGPT(PTF ,"M",0)
	8453	"RTN","DGP TTS2",40,0 )
	8454	N DGFDA,D GMSG
	8455	"RTN","DGP TTS2",41,0 )
	8456	S DGFDA(4 5.02,I1_", "_PTF_",", .01)=I1
	8457	"RTN","DGP TTS2",42,0 )
	8458	D FILE^DI E("","DGFD A","DGMSG" )
	8459	"RTN","DGP TTS2",43,0 )
	8460	S T(NX)=$ P(T(NX)_"^ ^",U,1,2)_ U_I1
	8461	"RTN","DGP TTS2",44,0 )
	8462	S DA=+T(N X),DR="52/ //"_I1,DIE ="^DGPM(" D ^DIE
	8463	"RTN","DGP TTS2",45,0 )
	8464	QUIT
	8465	"RTN","DGP TTS2",46,0 )
	8466	;
	8467	"RTN","DGP TTS2",47,0 )
	8468	ONE ;delet e in one i en/save in another i en for 25 icd codes and node 3 00
	8469	"RTN","DGP TTS2",48,0 )
	8470	N DR,DGDR ,DGA,DGB,D GC
	8471	"RTN","DGP TTS2",49,0 )
	8472	S I2=$P(T (PR),U,4) QUIT:'I2
	8473	"RTN","DGP TTS2",50,0 )
	8474	S DGA="DR ",DGB="DGD R",DGC=0
	8475	"RTN","DGP TTS2",51,0 )
	8476	S J=$S($D (^DGPT(PTF ,"M",I2,0) ):^(0),1:0 ) G O1:'J S (DR,DGDR )="" F I=4 :1:15 I I' =10 S:$P(J ,U,I) @DGA =$G(@DGA)_ I_"///@;", @DGB=$G(@D GB)_I_"/// /"_$P(J,U, I)_";"
	8477	"RTN","DGP TTS2",52,0 )
	8478	S J=$G(^D GPT(PTF,"M ",I2,81)) I J]"" F I =1:1:15 I $P(J,U,I) S @DGA=$G( @DGA)_(I/1 00+81)_"// /@;",@DGB= $G(@DGB)_( I/100+81)_ "////"_$P( J,U,I)_";" S:$L(@DGB )>220 DGC= DGC+1,DGA= "DR(1,45.0 2,DGC)",DG B="DGDR(1, 45.02,DGC) "
	8479	"RTN","DGP TTS2",53,0 )
	8480	S J=$G(^D GPT(PTF,"M ",I2,82)) I J]"" F I =1:1:25 I $P(J,U,I)] "" S @DGA= $G(@DGA)_( I/100+82)_ "///@;",@D GB=$G(@DGB )_(I/100+8 2)_"////"_ $P(J,U,I)_ ";" S:$L(@ DGB)>220 D GC=DGC+1,D GA="DR(1,4 5.02,DGC)" ,DGB="DGDR (1,45.02,D GC)"
	8481	"RTN","DGP TTS2",54,0 )
	8482	S J=$S($D (^DGPT(PTF ,"M",I2,30 0)):^(300) ,1:"") I J ]"" F I=2: 1:7 I $P(J ,U,I)]"" S @DGA=$G(@ DGA)_"300. 0"_I_"///@ ;",@DGB=$G (@DGB)_"30 0.0"_I_"// //"_$P(J,U ,I)_";" S: $L(@DGB)>2 20 DGC=DGC +1,DGA="DR (1,45.02,D GC)",DGB=" DGDR(1,45. 02,DGC)"
	8483	"RTN","DGP TTS2",55,0 )
	8484	S I1=I2 D TD5:DR]"" K DR S I1 =$P(T(NX), U,3) M DR= DGDR D TD5 :DR]""
	8485	"RTN","DGP TTS2",56,0 )
	8486	QUIT
	8487	"RTN","DGP TTS2",57,0 )
	8488	;
	8489	"RTN","DGP TTS2",58,0 )
	8490	TD5 S DA=I 1,DIE="^DG PT("_PTF_" ,""M"",",D A(1)=PTF,D P=45.02 D ^DIE QUIT
	8491	"RTN","DGP TTS2",59,0 )
	8492	;
	8493	"RTN","DGP TTS2",60,0 )
	8494	LOL S DG1= $S(DGDT:DG DT,1:DT),( LOL,LOP)=0
	8495	"RTN","DGP TTS2",61,0 )
	8496	F I=DGADM :0 S I=$O( ^DGPM("APT T2",DFN,I) ) Q:I'>0!( I>DG1) S J=$O(^DGPM ("APTT2",D FN,I,0)) I $S('$D(^D GPM(J,0)): 0,$P(^(0), "^",14)=DG PMCA:1,1:0 ) S C=+$P( ^(0),"^",1 8) I C=1!( C=2)!(C=3) D LOL1
	8497	"RTN","DGP TTS2",62,0 )
	8498	QUIT
	8499	"RTN","DGP TTS2",63,0 )
	8500	;
	8501	"RTN","DGP TTS2",64,0 )
	8502	LOL1 S X2= $S(I<PR:PR ,1:I),Y=$O (^DGPM("AP TT2",DFN,I )),X1=$S(Y >PR&(Y'>NX ):+Y,Y>NX! (Y<0):NX,1 :X2) I X1> X2 D ^%DTC S Z=$S(C= 1:"LOP",1: "LOL"),@Z= @Z+X K C,X ,Y,X1,X2
	8503	"RTN","DGP TTS2",65,0 )
	8504	QUIT
	8505	"RTN","DGP TTS2",66,0 )
	8506	;
	8507	"RTN","DGP TTS2",67,0 )
	8508	ASIH S DGB DT=DGADM,D GEDT=$S(DG DT:DGDT,1: DT) D ASIH ^DGUTL2
	8509	"RTN","DGP TTS2",68,0 )
	8510	S DIE="^D GPT(",DA=P TF,DR="77/ ///"_DGREC D ^DIE
	8511	"RTN","DGP TTS2",69,0 )
	8512	K DE,DQ,D R,DA,DIE,D GBDT,DGEDT ,DGMVTP QU IT
	8513	"RTN","DGP TTS2",70,0 )
	8514	;
	8515	"RTN","DGP TTS2",71,0 )
	8516	O1 ;filing saved mov ement 25 c odes with poa and 30 0-node dat a
	8517	"RTN","DGP TTS2",72,0 )
	8518	Q:'$D(^UT ILITY($J," DEL",I2))
	8519	"RTN","DGP TTS2",73,0 )
	8520	N DR,DGA, DGB,A,B,J, J82
	8521	"RTN","DGP TTS2",74,0 )
	8522	S DR="",D GA=0,DGB=" DR"
	8523	"RTN","DGP TTS2",75,0 )
	8524	S A=^UTIL ITY($J,"DE L",I2),B=0 ,J82=$G(^( I2,82))
	8525	"RTN","DGP TTS2",76,0 )
	8526	F I=1:1 S J=$P(A,", ",I) S:J= ""&'B&$D(^ UTILITY($J ,"DEL",I2, 81)) A=^(8 1),B=1,J=$ P(A,", ",I ),I=1,J=$P (A,", ",I) QUIT:J="" S DGA=DG A+1 D
	8527	"RTN","DGP TTS2",77,0 )
	8528	. S @DGB= $G(@DGB)_$ S(DGA<11:D GA>5+DGA+4 ,1:DGA-10/ 100+81)_"/ //"_J_";"_ (DGA/100+8 2)_"////"_ $P(J82,", ",DGA)_";"
	8529	"RTN","DGP TTS2",78,0 )
	8530	. I $L(@D GB)>220 S DGB="DR(1, 45.02,"_(1 +$O(DR(1,4 5.02,99),- 1))_")"
	8531	"RTN","DGP TTS2",79,0 )
	8532	. QUIT
	8533	"RTN","DGP TTS2",80,0 )
	8534	S I1=$P(T (NX),U,3) D TD5:DR]" " K DR
	8535	"RTN","DGP TTS2",81,0 )
	8536	;-- resto re expande d codes
	8537	"RTN","DGP TTS2",82,0 )
	8538	Q:'$D(^UT ILITY($J,3 00,I2)) S DR="",DGE X=^(I2) F I=2:1:7 S: $P(DGEX,U, I)]"" DR=D R_"300.0"_ I_"////"_$ P(DGEX,U,I )_";"
	8539	"RTN","DGP TTS2",83,0 )
	8540	D TD5:DR] ""
	8541	"RTN","DGP TTS2",84,0 )
	8542	QUIT
	8543	"RTN","DGP TTS2",85,0 )
	8544	Q S T(PR)= ^UTILITY($ J,"T",PR) I $P(T(PR) ,U,4)>1 S NX=1,T(1)= "^^1" D ON E
	8545	"RTN","DGP TTS2",86,0 )
	8546	QUIT
	8547	"RTN","DGP TTS2",87,0 )
	8548	CK ; -- ch ecks for P TF# in ^DG PM and $D of the PTF in ^DGPT; Y = ifn o f adm
	8549	"RTN","DGP TTS2",88,0 )
	8550	Q:$D(^DGP T(+$P(^DGP M(Y,0),"^" ,16),0))
	8551	"RTN","DGP TTS2",89,0 )
	8552	S Y=-1 W !,"warning : A PTF r ecord does not exist for this admission - cannot e dit",!?10, "Treating Specialty. MIS pers onnel and your super visor shou ld",!?10," be notifie d."
	8553	"RTN","DGP TTS2",90,0 )
	8554	W " The PTF option , 'Establi sh PTF rec ord from P ast",!?10, "Admission ', may be used to cr eate a PTF record." Q
	8555	"RTN","DGP TTS2",91,0 )
	8556	;
	8557	"RTN","DGP TUTL")
	8558	0^57^B2362 0117^B2284 9752
	8559	"RTN","DGP TUTL",1,0)
	8560	DGPTUTL ;A LB/AS - PT F UTILITY ROUTINE ;8 /14/03 11: 35am
	8561	"RTN","DGP TUTL",2,0)
	8562	;;5.3;Reg istration; 26,114,2 34,466,544 ,850,914 ;Aug 13, 1 993;Build 173
	8563	"RTN","DGP TUTL",3,0)
	8564	D I $L(Y)' <7 S %=$E( Y,4,5)*3,Y =$E("JANFE BMARAPRMAY JUNJULAUGS EPOCTNOVDE C",%-2,%)_ " "_$S($E( Y,6,7):$J( +$E(Y,6,7) ,2)_",",1: "")_($E(Y, 1,3)+1700) _$S(Y[".": " "_$E(Y_0 ,9,10)_":" _$E(Y_"000 ",11,12),1 :"") Q
	8565	"RTN","DGP TUTL",4,0)
	8566	S Y="" Q
	8567	"RTN","DGP TUTL",5,0)
	8568	PM ;sets v ariables f rom ^DGPM global
	8569	"RTN","DGP TUTL",6,0)
	8570	S DGPMCA= $O(^DGPM(" APTF",PTF, 0)),DGPMAN =$S($D(^DG PM(+DGPMCA ,0)):^(0), 1:"") Q
	8571	"RTN","DGP TUTL",7,0)
	8572	MT ;Determ ine and st ore Means Test Indic ator
	8573	"RTN","DGP TUTL",8,0)
	8574	;-- get e ligibility code
	8575	"RTN","DGP TUTL",9,0)
	8576	S DGZEC=$ P($G(^DGPT (PTF,101)) ,U,8),DGZE C=$S($D(^D IC(8,+DGZE C,0)):^(0) ,1:"") I $ P(DGZEC,U, 5)="N" S D GX="N" G D IE
	8577	"RTN","DGP TUTL",10,0 )
	8578	;-- admit prior to 7/1/86 is an X
	8579	"RTN","DGP TUTL",11,0 )
	8580	I DGADM<2 860701 S D GX="X" G D IE
	8581	"RTN","DGP TUTL",12,0 )
	8582	;--
	8583	"RTN","DGP TUTL",13,0 )
	8584	I $D(^DGP T(PTF,101) ),$D(^DIC( 45.1,+^(10 1),0)),$P( ^(0),"^",4 ) S DGX="X " G DIE
	8585	"RTN","DGP TUTL",14,0 )
	8586	I $P(^DG( 43,1,0),U, 21),DGADM] "",$D(^DIC (42,+$P(DG PMAN,U,6), 0)),$P(^(0 ),U,3)="D" S DGX="X" G DIE
	8587	"RTN","DGP TUTL",15,0 )
	8588	S DGT=$P( $G(^DGPT(P TF,70)),". "),DGZ1=$$ LST^DGMTU( DFN,DGT) G AS:'DGZ1
	8589	"RTN","DGP TUTL",16,0 )
	8590	;-- sc < 50 %, %O n on comp, m ovements a re sc
	8591	"RTN","DGP TUTL",17,0 )
	8592	I $P(DGZE C,U,4)=3,$ $SC^DGMTR( DFN),$$ANY SC^DGPTSCA N(PTF) S D GX="AS" G DIE
	8593	"RTN","DGP TUTL",18,0 )
	8594	;-- sc <5 0 %, %0 no n-comp, no movement sc, mt =a
	8595	"RTN","DGP TUTL",19,0 )
	8596	I $P(DGZE C,U,4)=3,$ $SC^DGMTR( DFN),'$$AN YSC^DGPTSC AN(PTF),$P (DGZ1,U,4) ="A" S DGX ="AN" G DI E
	8597	"RTN","DGP TUTL",20,0 )
	8598	;-- sc, > 0% - DG5 .3544
	8599	"RTN","DGP TUTL",21,0 )
	8600	I "^1^3^" [("^"_$P(D GZEC,U,4)_ "^"),$P($G (^DPT(DFN, .3)),U,2)> 0,$P(DGZ1, U,4)="A" S DGX="AS" G DIE
	8601	"RTN","DGP TUTL",22,0 )
	8602	;
	8603	"RTN","DGP TUTL",23,0 )
	8604	S DGX=$S( '$D(DGZ1): "U",1:$P(D GZ1,U,4))
	8605	"RTN","DGP TUTL",24,0 )
	8606	; Determi ne if the Pending Ad judication is for MT (C) GMT(G)
	8607	"RTN","DGP TUTL",25,0 )
	8608	I DGX="P" D G DIE
	8609	"RTN","DGP TUTL",26,0 )
	8610	. I '+$P( $G(DGZ1),U ) S DGX="U " Q
	8611	"RTN","DGP TUTL",27,0 )
	8612	. S DGX=$ $PA^DGMTUT L($P(DGZ1, U)),DGX=$S ('$D(DGX): "U",DGX="M T":"C",DGX ="GMT":"G" ,1:"U")
	8613	"RTN","DGP TUTL",28,0 )
	8614	S DGX=$S( DGX="A":"A N","BCGN"[ DGX:DGX,1: "U") G DIE :DGX'="N"
	8615	"RTN","DGP TUTL",29,0 )
	8616	;-- AO or IR
	8617	"RTN","DGP TUTL",30,0 )
	8618	AS S DGZ=$ S($D(^DPT( DFN,.321)) :^(.321),1 :0) I $P(D GZ,U,2)="Y "!($P(DGZ, U,3)="Y") S DGX="AS" G DIE
	8619	"RTN","DGP TUTL",31,0 )
	8620	;-- EC
	8621	"RTN","DGP TUTL",32,0 )
	8622	S DGZ=$S( $D(^DPT(DF N,.322)):^ (.322),1:0 ) I $P(DGZ ,U,13)="Y" S DGX="AS " G DIE
	8623	"RTN","DGP TUTL",33,0 )
	8624	;-- NTR
	8625	"RTN","DGP TUTL",34,0 )
	8626	N DGNTARR S DGZ=$S( $$GETCUR^D GNTAPI(DFN ,"DGNTARR" )>0:DGNTAR R("NTR"),1 :"") I $P( DGZ,U)="Y" S DGX="AS " G DIE
	8627	"RTN","DGP TUTL",35,0 )
	8628	;-- MST
	8629	"RTN","DGP TUTL",36,0 )
	8630	S DGZ=$$G ETSTAT^DGM STAPI(DFN) I $P(DGZ, U,2)="Y" S DGX="AS" G DIE
	8631	"RTN","DGP TUTL",37,0 )
	8632	;pwc RSD 2.6.6.2.1 DG5.391 4 Camp Lej eune
	8633	"RTN","DGP TUTL",38,0 )
	8634	;-- CL
	8635	"RTN","DGP TUTL",39,0 )
	8636	S DGZ=$S( $D(^DPT(DF N,.3217)): ^(.3217),1 :0) I $P(D GZ,U,1)="Y " S DGX="A S" G DIE
	8637	"RTN","DGP TUTL",40,0 )
	8638	;-- if ve teran and AA or Hous ebound
	8639	"RTN","DGP TUTL",41,0 )
	8640	I $P(DGZE C,U,5)="Y" ,$P(DGZEC, U,4)<4,"^2 ^15^"'[(U_ $P(DGZEC,U ,9)_U) S D GX="AS" G DIE
	8641	"RTN","DGP TUTL",42,0 )
	8642	;
	8643	"RTN","DGP TUTL",43,0 )
	8644	I DGZEC]" " S DGX="A N" G DIE
	8645	"RTN","DGP TUTL",44,0 )
	8646	;
	8647	"RTN","DGP TUTL",45,0 )
	8648	S DGX="U" I '$D(DGL N) W !,"== => this pa tient has a blank El igibility Code"
	8649	"RTN","DGP TUTL",46,0 )
	8650	;
	8651	"RTN","DGP TUTL",47,0 )
	8652	DIE I '$D( DGBGJ) S D A=PTF,DR=" 10///"_DGX _$S('$P(^D GPT(PTF,0) ,U,3):";3/ //`"_$P($$ SITE^VASIT E,U),1:"") ,DIE="^DGP T(" D ^DIE K DGZEC,D GZ,DGZ1,DG 1,DGX,DR,D GT,DA,DIE Q
	8653	"RTN","DGP TUTL",48,0 )
	8654	I DGX'=$P (^DGPT(PTF ,0),"^",10 ) S DA=PTF ,DR="10/// "_DGX,DIE= "^DGPT(" D ^DIE
	8655	"RTN","DGP TUTL",49,0 )
	8656	K DGZEC,D GZ,DGZ1,DG 1,DGX,DGT, DR,DA,DIE Q
	8657	"RTN","DGP TUTL",50,0 )
	8658	;
	8659	"RTN","DGP TUTL",51,0 )
	8660	RTY ; -- s et rec typ e variable s
	8661	"RTN","DGP TUTL",52,0 )
	8662	; input: Y := rec type #
	8663	"RTN","DGP TUTL",53,0 )
	8664	; output: DGRTY := rec type #
	8665	"RTN","DGP TUTL",54,0 )
	8666	; DGRTY0 := name of t ype (in fu ture, may expand to 0th node)
	8667	"RTN","DGP TUTL",55,0 )
	8668	;
	8669	"RTN","DGP TUTL",56,0 )
	8670	I Y=1 S D GRTY=1,DGR TY0="PTF"
	8671	"RTN","DGP TUTL",57,0 )
	8672	I Y=2 S D GRTY=2,DGR TY0="CENSU S"
	8673	"RTN","DGP TUTL",58,0 )
	8674	Q
	8675	"RTN","DGP TUTL",59,0 )
	8676	;
	8677	"RTN","DGP TUTL",60,0 )
	8678	HANG ;
	8679	"RTN","DGP TUTL",61,0 )
	8680	R DGPTHAN G:4 K DGPT HANG Q
	8681	"RTN","DGP TUTL",62,0 )
	8682	;
	8683	"RTN","DGP TUTL",63,0 )
	8684	CEN ; -- f ind curren t active c ensus ; re turn ifn a nd 0th nod e
	8685	"RTN","DGP TUTL",64,0 )
	8686	S DGCN=$O (^DG(45.86 ,"AC",1,0) ),DGCN0=$S ($D(^DG(45 .86,+DGCN, 0)):^(0),1 :"")
	8687	"RTN","DGP TUTL",65,0 )
	8688	Q
	8689	"RTN","DGP TUTL",66,0 )
	8690	;
	8691	"RTN","DGP TUTL",67,0 )
	8692	FMT ; -- d etermine P TF record format
	8693	"RTN","DGP TUTL",68,0 )
	8694	;
	8695	"RTN","DGP TUTL",69,0 )
	8696	N IMPDATE ,EFFDATE,D GPTDAT
	8697	"RTN","DGP TUTL",70,0 )
	8698	S Z=$S($G (Y):Y,1:DT )
	8699	"RTN","DGP TUTL",71,0 )
	8700	S DGPTFMT =1 D FDT
	8701	"RTN","DGP TUTL",72,0 )
	8702	I Z>Y S D GPTFMT=2
	8703	"RTN","DGP TUTL",73,0 )
	8704	D EFFDATE ^DGPTIC10( $G(PTF))
	8705	"RTN","DGP TUTL",74,0 )
	8706	Q:IMPDATE '?7N
	8707	"RTN","DGP TUTL",75,0 )
	8708	I Z'<IMPD ATE S DGPT FMT=3 ;(IC D-10)
	8709	"RTN","DGP TUTL",76,0 )
	8710	K Z
	8711	"RTN","DGP TUTL",77,0 )
	8712	Q
	8713	"RTN","DGP TUTL",78,0 )
	8714	;
	8715	"RTN","DGP TUTL",79,0 )
	8716	FDT ; -- s et new for mat date f or testing
	8717	"RTN","DGP TUTL",80,0 )
	8718	S Y=29010 00 Q
	8719	"RTN","DGP TUTL",81,0 )
	8720	;
	8721	"RTN","DGP TUTL",82,0 )
	8722	UPDT ; -- update PTF record w/ PTF and DF N defined
	8723	"RTN","DGP TUTL",83,0 )
	8724	I '$D(^DG PT(PTF,0)) W:'$D(ZTQ UEUED) !!, *7,">>> PT F record # ",PTF," do es not exi st." G UPD TQ
	8725	"RTN","DGP TUTL",84,0 )
	8726	S X=^(0)
	8727	"RTN","DGP TUTL",85,0 )
	8728	I $P(X,U, 11)>1 W:'$ D(ZTQUEUED ) !!,*7,"> >> Record #",PTF," i s not a PT F record." G UPDTQ
	8729	"RTN","DGP TUTL",86,0 )
	8730	S DGPTFE= $P(X,U,4), (DGADM,AD) =+$P(X,U,2 ),DGST=$D( ^DGP(45.84 ,PTF))>0
	8731	"RTN","DGP TUTL",87,0 )
	8732	I DGST W: '$D(ZTQUEU ED) !!,*7, ">>> PTF r ecord #",P TF," is cl osed out. No updatin g allowed. " G UPDTQ
	8733	"RTN","DGP TUTL",88,0 )
	8734	I DGPTFE W:'$D(ZTQU EUED) !!,* 7,">>> PTF record #" ,PTF," is a fee PTF record. No updating is possibl e." G UPDT Q
	8735	"RTN","DGP TUTL",89,0 )
	8736	N DGPMCA, DGPMAN D P M
	8737	"RTN","DGP TUTL",90,0 )
	8738	I DGPMCA D:'$P(^DGP T(PTF,0),U ,5) SUF^DG PTF D LE^D GPTTS,DC^D GPTF
	8739	"RTN","DGP TUTL",91,0 )
	8740	;
	8741	"RTN","DGP TUTL",92,0 )
	8742	UPDTQ K AG E,D0,D1,DA ,DGADM,DGL AST,DGP,DG TY,DIC,DIE ,DR,DIV,DI U,DISYS,DI K,DIKLM,DI G,DIH,DI,D IW,DIWL,DI WR,DIWT,DN ,DOB,DQ,DG ,DRG,SEX,T Y,L,P1,DIS 2,DGPTFE,D GST,DGX,DF N1,DFN2,PR ,I1,TDD,AD
	8743	"RTN","DGP TUTL",93,0 )
	8744	Q
	8745	"RTN","DGP TUTL",94,0 )
	8746	;
	8747	"RTN","DGP TUTL",95,0 )
	8748	EXPL ; -- explode st ring A(inp ut) to DGA (output)
	8749	"RTN","DGP TUTL",96,0 )
	8750	N J,L S D GA=$E(A,2, 999)
	8751	"RTN","DGP TUTL",97,0 )
	8752	I DGA["-" S X=DGA,D GA="" F J= 1:1 S L=$P (X,",",J) Q:'L D EX PL1:L["-" S:L]"" DGA =DGA_L_"," Q:$P(X,", ",J+1,999) =""
	8753	"RTN","DGP TUTL",98,0 )
	8754	Q
	8755	"RTN","DGP TUTL",99,0 )
	8756	;
	8757	"RTN","DGP TUTL",100, 0)
	8758	EXPL1 ; -- explode s tring 'L' of form "1 -12" ; inp ut and out put is 'L'
	8759	"RTN","DGP TUTL",101, 0)
	8760	N I,X
	8761	"RTN","DGP TUTL",102, 0)
	8762	I $P(L,"- ")'?1N.N!( $P(L,"-",2 ,999)'?1N. N) S L="" G EXPL1Q
	8763	"RTN","DGP TUTL",103, 0)
	8764	I +L>$P(L ,"-",2) S L="" G EXP L1Q
	8765	"RTN","DGP TUTL",104, 0)
	8766	I +L=+$P( L,"-",2) S L=+L G EX PL1Q
	8767	"RTN","DGP TUTL",105, 0)
	8768	S X="" F I=+L:1:+$P (L,"-",2) Q:($L(X)+$ L(I)+1)>24 0 S X=X_I _","
	8769	"RTN","DGP TUTL",106, 0)
	8770	S L=$E(X, 1,$L(X)-1)
	8771	"RTN","DGP TUTL",107, 0)
	8772	EXPL1Q Q
	8773	"RTN","DGP TUTL",108, 0)
	8774	;
	8775	"RTN","DGP TUTL",109, 0)
	8776	CKPOS(ADEL ,DEFAULT) ;-- This f unction wi ll check t he admitti ng eligibi lity
	8777	"RTN","DGP TUTL",110, 0)
	8778	; and the POS to ma ke sure fo r Non-Vet eligibilit ies that a
	8779	"RTN","DGP TUTL",111, 0)
	8780	; 9 - Oth er or None POS is pr esent.
	8781	"RTN","DGP TUTL",112, 0)
	8782	;
	8783	"RTN","DGP TUTL",113, 0)
	8784	; INPUT - ADEL : A dmitting E ligibility (Pointer to file 8)
	8785	"RTN","DGP TUTL",114, 0)
	8786	; D EFAULT : D efault POS (optional ) (Pointer to file 2 1)
	8787	"RTN","DGP TUTL",115, 0)
	8788	; OUTPUT - POS : PO S Code. 0 - Error
	8789	"RTN","DGP TUTL",116, 0)
	8790	;
	8791	"RTN","DGP TUTL",117, 0)
	8792	N RESULT, X,Y
	8793	"RTN","DGP TUTL",118, 0)
	8794	;If DFN i s not need ed here, k ill DFN to avoid VAD PT error o ut.
	8795	"RTN","DGP TUTL",119, 0)
	8796	I $G(DFN) ="" N DFN S DFN=$G(D GSDFN) I $ G(DFN)="" K DFN
	8797	"RTN","DGP TUTL",120, 0)
	8798	D ELIG^VA DPT
	8799	"RTN","DGP TUTL",121, 0)
	8800	I $D(VAEL (1))=1 S R ESULT=$G(D EFAULT) G CKPOSQ
	8801	"RTN","DGP TUTL",122, 0)
	8802	S RESULT= 0,Y=$G(DEF AULT)
	8803	"RTN","DGP TUTL",123, 0)
	8804	I '$D(^DI C(8,+ADEL, 0)) G CKPO SQ
	8805	"RTN","DGP TUTL",124, 0)
	8806	S X=$G(^D IC(8.1,$P( $G(^DIC(8, +ADEL,0)), U,9),0))
	8807	"RTN","DGP TUTL",125, 0)
	8808	;-- if no n vet set POS to Oth er
	8809	"RTN","DGP TUTL",126, 0)
	8810	I $P(X,U, 5)="N" S R ESULT=9
	8811	"RTN","DGP TUTL",127, 0)
	8812	;-- if ve t then use default
	8813	"RTN","DGP TUTL",128, 0)
	8814	I $P(X,U, 5)="Y",Y'= "" S RESUL T=Y
	8815	"RTN","DGP TUTL",129, 0)
	8816	CKPOSQ ;
	8817	"RTN","DGP TUTL",130, 0)
	8818	Q RESULT
	8819	"RTN","DGP TUTL",131, 0)
	8820	;
	8821	"RTN","DGR ODEBR")
	8822	0^77^B6069 3332^B5543 0347
	8823	"RTN","DGR ODEBR",1,0 )
	8824	DGRODEBR ; DJH/AMA,TD M - ROM DA TA ELEMENT BUSINESS RULES ; 10 /20/10 9:5 9am
	8825	"RTN","DGR ODEBR",2,0 )
	8826	;;5.3;Reg istration; 533,572, 754,797,91 4;Aug 13 , 1993;Bui ld 173
	8827	"RTN","DGR ODEBR",3,0 )
	8828	;
	8829	"RTN","DGR ODEBR",4,0 )
	8830	;BUSINESS RULES TO BE CHECKED JUST BEFO RE FILING THE
	8831	"RTN","DGR ODEBR",5,0 )
	8832	;PATIENT DATA RETRI EVED FROM THE LAST S ITE TREATE D (LST)
	8833	"RTN","DGR ODEBR",6,0 )
	8834	;
	8835	"RTN","DGR ODEBR",7,0 )
	8836	;* DG5.3 572 chang ed "I"nter nal refere nces to "E "xternal r eferences
	8837	"RTN","DGR ODEBR",8,0 )
	8838	POW(DGDATA ,DFN,LSTDF N) ;POW ST ATUS INDIC ATED?
	8839	"RTN","DGR ODEBR",9,0 )
	8840	; DGDAT A - Data e lement arr ay from LS T, ^TMP("D GROFDA",$J )
	8841	"RTN","DGR ODEBR",10, 0)
	8842	; DF N - Pointe r to the P ATIENT (#2 ) file
	8843	"RTN","DGR ODEBR",11, 0)
	8844	; LSTDF N - Pointe r to the p atient dat a from the LST, in D GDATA
	8845	"RTN","DGR ODEBR",12, 0)
	8846	N RSPOW ;REQUEST ING SITE P OW STATUS INDICATED
	8847	"RTN","DGR ODEBR",13, 0)
	8848	N LSTPOW ;LAST SI TE TREATED POW STATU S INDICATE D
	8849	"RTN","DGR ODEBR",14, 0)
	8850	S RSPOW=$ $GET1^DIQ( 2,DFN,.525 )
	8851	"RTN","DGR ODEBR",15, 0)
	8852	S LSTPOW= $G(@DGDATA @(2,LSTDFN _",",.525, "E"))
	8853	"RTN","DGR ODEBR",16, 0)
	8854	;If eithe r of the P OW STATUS INDICATED? flags
	8855	"RTN","DGR ODEBR",17, 0)
	8856	;are "N"o , don't fi le the POW data elem ent(s)
	8857	"RTN","DGR ODEBR",18, 0)
	8858	I (RSPOW= "NO")!(LST POW="NO") D
	8859	"RTN","DGR ODEBR",19, 0)
	8860	. N FIELD
	8861	"RTN","DGR ODEBR",20, 0)
	8862	. F FIELD =.525:.001 :.528 K @D GDATA@(2,L STDFN_",", FIELD)
	8863	"RTN","DGR ODEBR",21, 0)
	8864	Q
	8865	"RTN","DGR ODEBR",22, 0)
	8866	;
	8867	"RTN","DGR ODEBR",23, 0)
	8868	AO(DGDATA, DFN,LSTDFN ) ;AGENT O RANGE EXPO SURE INDIC ATED?
	8869	"RTN","DGR ODEBR",24, 0)
	8870	; DGDAT A - Data e lement arr ay from LS T, ^TMP("D GROFDA",$J )
	8871	"RTN","DGR ODEBR",25, 0)
	8872	; DF N - Pointe r to the P ATIENT (#2 ) file
	8873	"RTN","DGR ODEBR",26, 0)
	8874	; LSTDF N - Pointe r to the p atient dat a from the LST, in D GDATA
	8875	"RTN","DGR ODEBR",27, 0)
	8876	N RSAO ;R.S. AGE NT ORANGE EXPOSURE I NDICATED
	8877	"RTN","DGR ODEBR",28, 0)
	8878	N LSTAO ;LST AGEN T ORANGE E XPOSURE IN DICATED
	8879	"RTN","DGR ODEBR",29, 0)
	8880	S RSAO=$$ GET1^DIQ(2 ,DFN,.3210 2)
	8881	"RTN","DGR ODEBR",30, 0)
	8882	S LSTAO=$ G(@DGDATA@ (2,LSTDFN_ ",",.32102 ,"E"))
	8883	"RTN","DGR ODEBR",31, 0)
	8884	;If eithe r of the A GENT ORANG E EXPOSURE INDICATED ?
	8885	"RTN","DGR ODEBR",32, 0)
	8886	;flags ar e "N"o, de lete the A O data ele ment(s)
	8887	"RTN","DGR ODEBR",33, 0)
	8888	I (RSAO=" NO")!(LSTA O="NO") D
	8889	"RTN","DGR ODEBR",34, 0)
	8890	. N FIELD
	8891	"RTN","DGR ODEBR",35, 0)
	8892	. ;added AO LOCATIO N OF EXPOS URE (2/.32 13) for DG 5.3572 DJH
	8893	"RTN","DGR ODEBR",36, 0)
	8894	. F FIELD =.32102,.3 2107,.3210 8,.32109,. 3211,.3213 K @DGDATA @(2,LSTDFN _",",FIELD )
	8895	"RTN","DGR ODEBR",37, 0)
	8896	Q
	8897	"RTN","DGR ODEBR",38, 0)
	8898	;
	8899	"RTN","DGR ODEBR",39, 0)
	8900	CLV(DGDATA ,DFN,LSTDF N) ;CAMP L EJEUNE DG 5.3914
	8901	"RTN","DGR ODEBR",40, 0)
	8902	; DGDAT A - Data e lement arr ay from LS T, ^TMP("D GROFDA",$J )
	8903	"RTN","DGR ODEBR",41, 0)
	8904	; DF N - Pointe r to the P ATIENT (#2 ) file
	8905	"RTN","DGR ODEBR",42, 0)
	8906	; LSTDF N - Pointe r to the p atient dat a from the LST, in D GDATA
	8907	"RTN","DGR ODEBR",43, 0)
	8908	N RSCL ;R.S. CAM P LEJEUNE
	8909	"RTN","DGR ODEBR",44, 0)
	8910	N LSTCL ;LST CAMP LEJEUNE
	8911	"RTN","DGR ODEBR",45, 0)
	8912	S RSCL=$$ GET1^DIQ(2 ,DFN,.3217 01)
	8913	"RTN","DGR ODEBR",46, 0)
	8914	S LSTCL=$ G(@DGDATA@ (2,LSTDFN_ ",",.32170 1,"E"))
	8915	"RTN","DGR ODEBR",47, 0)
	8916	;If eithe r of the C AMP LEJEUN E flags ar e "N"o, de lete the C L data ele ment(s)
	8917	"RTN","DGR ODEBR",48, 0)
	8918	I (RSCL=" NO")!(LSTC L="NO") D
	8919	"RTN","DGR ODEBR",49, 0)
	8920	. N FIELD
	8921	"RTN","DGR ODEBR",50, 0)
	8922	. F FIELD =.321701,. 321702,.32 1703,.3217 04 K @DGDA TA@(2,LSTD FN_",",FIE LD)
	8923	"RTN","DGR ODEBR",51, 0)
	8924	Q
	8925	"RTN","DGR ODEBR",52, 0)
	8926	;
	8927	"RTN","DGR ODEBR",53, 0)
	8928	IR(DGDATA, DFN,LSTDFN ) ;RADIATI ON EXPOSUR E INDICATE D?
	8929	"RTN","DGR ODEBR",54, 0)
	8930	; DGDAT A - Data e lement arr ay from LS T, ^TMP("D GROFDA",$J )
	8931	"RTN","DGR ODEBR",55, 0)
	8932	; DF N - Pointe r to the P ATIENT (#2 ) file
	8933	"RTN","DGR ODEBR",56, 0)
	8934	; LSTDF N - Pointe r to the p atient dat a from the LST, in D GDATA
	8935	"RTN","DGR ODEBR",57, 0)
	8936	N RSIR ;R.S. RAD IATION EXP OSURE INDI CATED
	8937	"RTN","DGR ODEBR",58, 0)
	8938	N LSTIR ;LST RADI ATION EXPO SURE INDIC ATED
	8939	"RTN","DGR ODEBR",59, 0)
	8940	S RSIR=$$ GET1^DIQ(2 ,DFN,.3210 3)
	8941	"RTN","DGR ODEBR",60, 0)
	8942	S LSTIR=$ G(@DGDATA@ (2,LSTDFN_ ",",.32103 ,"E"))
	8943	"RTN","DGR ODEBR",61, 0)
	8944	;If eithe r of the R ADIATION E XPOSURE IN DICATED
	8945	"RTN","DGR ODEBR",62, 0)
	8946	;flags ar e "N"o, de lete the I R data ele ments
	8947	"RTN","DGR ODEBR",63, 0)
	8948	I (RSIR=" NO")!(LSTI R="NO") D
	8949	"RTN","DGR ODEBR",64, 0)
	8950	. N FIELD
	8951	"RTN","DGR ODEBR",65, 0)
	8952	. F FIELD =.32103,.3 2111,.3212 K @DGDATA @(2,LSTDFN _",",FIELD )
	8953	"RTN","DGR ODEBR",66, 0)
	8954	Q
	8955	"RTN","DGR ODEBR",67, 0)
	8956	;
	8957	"RTN","DGR ODEBR",68, 0)
	8958	INC(DGDATA ,DFN,LSTDF N) ;RATED INCOMPETEN T (Y/N)
	8959	"RTN","DGR ODEBR",69, 0)
	8960	; DGDAT A - Data e lement arr ay from LS T, ^TMP("D GROFDA",$J )
	8961	"RTN","DGR ODEBR",70, 0)
	8962	; DF N - Pointe r to the P ATIENT (#2 ) file
	8963	"RTN","DGR ODEBR",71, 0)
	8964	; LSTDF N - Pointe r to the p atient dat a from the LST, in D GDATA
	8965	"RTN","DGR ODEBR",72, 0)
	8966	N RSIN ;RATED IN COMPETENT (Y/N)
	8967	"RTN","DGR ODEBR",73, 0)
	8968	N LSTIN ;LST RATE D INCOMPET ENT (Y/N)
	8969	"RTN","DGR ODEBR",74, 0)
	8970	S RSIN=$$ GET1^DIQ(2 ,DFN,.293)
	8971	"RTN","DGR ODEBR",75, 0)
	8972	S LSTIN=$ G(@DGDATA@ (2,LSTDFN_ ",",.293," E"))
	8973	"RTN","DGR ODEBR",76, 0)
	8974	;If eithe r of the R ATED INCOM PETENT
	8975	"RTN","DGR ODEBR",77, 0)
	8976	;flags ar e "N"o, de lete the I R data ele ments
	8977	"RTN","DGR ODEBR",78, 0)
	8978	I (RSIN=" NO")!(LSTI N="NO") D
	8979	"RTN","DGR ODEBR",79, 0)
	8980	. N FIELD
	8981	"RTN","DGR ODEBR",80, 0)
	8982	. F FIELD =.292,.293 K @DGDATA @(2,LSTDFN _",",FIELD )
	8983	"RTN","DGR ODEBR",81, 0)
	8984	Q
	8985	"RTN","DGR ODEBR",82, 0)
	8986	;
	8987	"RTN","DGR ODEBR",83, 0)
	8988	INE(DGDATA ,DFN,LSTDF N) ;INELIG IBLE DATA
	8989	"RTN","DGR ODEBR",84, 0)
	8990	; DGDAT A - Data e lement arr ay from LS T, ^TMP("D GROFDA",$J )
	8991	"RTN","DGR ODEBR",85, 0)
	8992	; DF N - Pointe r to the P ATIENT (#2 ) file
	8993	"RTN","DGR ODEBR",86, 0)
	8994	; LSTDF N - Pointe r to the p atient dat a from the LST, in D GDATA
	8995	"RTN","DGR ODEBR",87, 0)
	8996	;
	8997	"RTN","DGR ODEBR",88, 0)
	8998	N LSTID ; INELIGIBLE DATE
	8999	"RTN","DGR ODEBR",89, 0)
	9000	S LSTID=$ G(@DGDATA@ (2,LSTDFN_ ",",.152," E"))
	9001	"RTN","DGR ODEBR",90, 0)
	9002	;
	9003	"RTN","DGR ODEBR",91, 0)
	9004	;If no IN ELIGIBLE D ATE from L ST don't u pload inel igible fie lds.
	9005	"RTN","DGR ODEBR",92, 0)
	9006	I LSTID=" " D
	9007	"RTN","DGR ODEBR",93, 0)
	9008	. N FIELD
	9009	"RTN","DGR ODEBR",94, 0)
	9010	. F FIELD =.152,.307 ,.1651,.16 53,.1654,. 1656 K @DG DATA@(2,LS TDFN_",",F IELD)
	9011	"RTN","DGR ODEBR",95, 0)
	9012	Q
	9013	"RTN","DGR ODEBR",96, 0)
	9014	;
	9015	"RTN","DGR ODEBR",97, 0)
	9016	DOD(DGDATA ,DFN,LSTDF N) ;DATE O F DEATH
	9017	"RTN","DGR ODEBR",98, 0)
	9018	;Retrieve all DATE OF DEATH d ata elemen ts, but in stead of b eing filed ,
	9019	"RTN","DGR ODEBR",99, 0)
	9020	;they wil l be place d into a m ail messag e to the a ppropriate group.
	9021	"RTN","DGR ODEBR",100 ,0)
	9022	;
	9023	"RTN","DGR ODEBR",101 ,0)
	9024	; DGDAT A - Data e lement arr ay from LS T, ^TMP("D GROFDA",$J )
	9025	"RTN","DGR ODEBR",102 ,0)
	9026	; DF N - Pointe r to the P ATIENT (#2 ) file
	9027	"RTN","DGR ODEBR",103 ,0)
	9028	; LSTDF N - Pointe r to the p atient dat a from the LST, in D GDATA
	9029	"RTN","DGR ODEBR",104 ,0)
	9030	;
	9031	"RTN","DGR ODEBR",105 ,0)
	9032	N DGMSG,F LD
	9033	"RTN","DGR ODEBR",106 ,0)
	9034	;Only sen d messages if actual DOD is de fined (fie ld # .351) ;DG5.35 72
	9035	"RTN","DGR ODEBR",107 ,0)
	9036	I $D(@DGD ATA@(2,LST DFN_",",.3 51)) D
	9037	"RTN","DGR ODEBR",108 ,0)
	9038	. D DODMA IL^DGROMAI L(DGDATA,D FN,LSTDFN)
	9039	"RTN","DGR ODEBR",109 ,0)
	9040	. S DGMSG (1)=" "
	9041	"RTN","DGR ODEBR",110 ,0)
	9042	. S DGMSG (2)="Date of Death i nformation has been retrieved from the L ST."
	9043	"RTN","DGR ODEBR",111 ,0)
	9044	. S DGMSG (3)="This informatio n has NOT been filed into the patient's record."
	9045	"RTN","DGR ODEBR",112 ,0)
	9046	. S DGMSG (4)="A mai l message has been s ent to the Register Once mail group."
	9047	"RTN","DGR ODEBR",113 ,0)
	9048	. D EN^DD IOL(.DGMSG ) R A:5
	9049	"RTN","DGR ODEBR",114 ,0)
	9050	;Delete D oD fields from FDA a rray so th ey're not filed.
	9051	"RTN","DGR ODEBR",115 ,0)
	9052	F FLD=.35 1:.001:.35 5 K @DGDAT A@(2,LSTDF N_",",FLD) ;DG5.3 572 - add ed .355
	9053	"RTN","DGR ODEBR",116 ,0)
	9054	Q
	9055	"RTN","DGR ODEBR",117 ,0)
	9056	;
	9057	"RTN","DGR ODEBR",118 ,0)
	9058	TA(DGDATA, LSTDFN) ;T EMPORARY A DDRESS
	9059	"RTN","DGR ODEBR",119 ,0)
	9060	; DGDAT A - Data e lement arr ay from LS T, ^TMP("D GROFDA",$J )
	9061	"RTN","DGR ODEBR",120 ,0)
	9062	; LSTDF N - Pointe r to the p atient dat a from the LST, in D GDATA
	9063	"RTN","DGR ODEBR",121 ,0)
	9064	N LSTTAED ;LST TEMP ORARY ADDR ESS END DA TE (EXTERN AL)
	9065	"RTN","DGR ODEBR",122 ,0)
	9066	N LSTTAED F ;LST TEM PORARY ADD RESS END D ATE FILEMA N (DG5.3 572)
	9067	"RTN","DGR ODEBR",123 ,0)
	9068	S LSTTAED =$G(@DGDAT A@(2,LSTDF N_",",.121 8,"E"))
	9069	"RTN","DGR ODEBR",124 ,0)
	9070	;Convert External LST date t o Fileman date (DG5 .3*572)
	9071	"RTN","DGR ODEBR",125 ,0)
	9072	S X=LSTTA ED
	9073	"RTN","DGR ODEBR",126 ,0)
	9074	S %DT="RS N"
	9075	"RTN","DGR ODEBR",127 ,0)
	9076	D ^%DT
	9077	"RTN","DGR ODEBR",128 ,0)
	9078	S LSTTAED F=Y
	9079	"RTN","DGR ODEBR",129 ,0)
	9080	;If the T EMPORARY A DDRESS END DATE is l ess than t he
	9081	"RTN","DGR ODEBR",130 ,0)
	9082	;date of the query, delete th e TA data elements
	9083	"RTN","DGR ODEBR",131 ,0)
	9084	I (LSTTAE DF>0),(LST TAEDF<DT) D
	9085	"RTN","DGR ODEBR",132 ,0)
	9086	. N FIELD
	9087	"RTN","DGR ODEBR",133 ,0)
	9088	. F FIELD =.12105,.1 2111,.1211 2,.1211:.0 001:.1219 K @DGDATA@ (2,LSTDFN_ ",",FIELD)
	9089	"RTN","DGR ODEBR",134 ,0)
	9090	K X,%DT,Y
	9091	"RTN","DGR ODEBR",135 ,0)
	9092	Q
	9093	"RTN","DGR ODEBR",136 ,0)
	9094	;
	9095	"RTN","DGR ODEBR",137 ,0)
	9096	SP(DGDATA, DFN,LSTDFN ) ;SENSITI VE PATIENT
	9097	"RTN","DGR ODEBR",138 ,0)
	9098	; DGDAT A - Data e lement arr ay from LS T, ^TMP("D GROFDA",$J )
	9099	"RTN","DGR ODEBR",139 ,0)
	9100	; DF N - Pointe r to the P ATIENT (#2 ) file
	9101	"RTN","DGR ODEBR",140 ,0)
	9102	; LSTDF N - Pointe r to the p atient dat a from the LST, in D GDATA
	9103	"RTN","DGR ODEBR",141 ,0)
	9104	;
	9105	"RTN","DGR ODEBR",142 ,0)
	9106	N RSSP ;R.S. SEN SITIVE PAT IENT
	9107	"RTN","DGR ODEBR",143 ,0)
	9108	N LSTSP ;LST SENS ITIVE PATI ENT
	9109	"RTN","DGR ODEBR",144 ,0)
	9110	S RSSP=$$ GET1^DIQ(3 8.1,DFN,2)
	9111	"RTN","DGR ODEBR",145 ,0)
	9112	S LSTSP=$ G(@DGDATA@ (38.1,LSTD FN_",",2," E"))
	9113	"RTN","DGR ODEBR",146 ,0)
	9114	;
	9115	"RTN","DGR ODEBR",147 ,0)
	9116	;* Remove code dele ting Prima ry Eligibi lity Code (DG5.357 2)
	9117	"RTN","DGR ODEBR",148 ,0)
	9118	;* In all cases, de lete Patie nt Type
	9119	"RTN","DGR ODEBR",149 ,0)
	9120	K @DGDATA @(2,LSTDFN _",",391)
	9121	"RTN","DGR ODEBR",150 ,0)
	9122	;
	9123	"RTN","DGR ODEBR",151 ,0)
	9124	;If the S ENSITIVE P ATIENT fla g is recei ved from t he HEC -- OR -- if t he
	9125	"RTN","DGR ODEBR",152 ,0)
	9126	;flag is NOT receiv ed from bo th the HEC and LST, retrieve a nd file al l
	9127	"RTN","DGR ODEBR",153 ,0)
	9128	;Sensitiv e data ele ments, but NOT the f ields for the Securi ty Log fil e.
	9129	"RTN","DGR ODEBR",154 ,0)
	9130	I '((RSSP '="SENSITI VE")&(LSTS P="SENSITI VE")) D I 1
	9131	"RTN","DGR ODEBR",155 ,0)
	9132	. K @DGDA TA@(38.1)
	9133	"RTN","DGR ODEBR",156 ,0)
	9134	E D
	9135	"RTN","DGR ODEBR",157 ,0)
	9136	. ;Otherw ise (flag not receiv ed from th e HEC but is from th e LST),
	9137	"RTN","DGR ODEBR",158 ,0)
	9138	. ;send a mail mess age to the ISO and t he "Regist er Once" m ail
	9139	"RTN","DGR ODEBR",159 ,0)
	9140	. ;group that this patient is listed as Sensitive
	9141	"RTN","DGR ODEBR",160 ,0)
	9142	. D SPMAI L^DGROMAIL (DFN)
	9143	"RTN","DGR ODEBR",161 ,0)
	9144	. N DGMSG
	9145	"RTN","DGR ODEBR",162 ,0)
	9146	. S DGMSG (1)=" "
	9147	"RTN","DGR ODEBR",163 ,0)
	9148	. S DGMSG (2)="Sensi tive Patie nt informa tion has b een retrie ved from t he LST."
	9149	"RTN","DGR ODEBR",164 ,0)
	9150	. S DGMSG (3)="This informatio n has been filed int o the pati ent's reco rd."
	9151	"RTN","DGR ODEBR",165 ,0)
	9152	. S DGMSG (4)="A mai l message has been s ent to the Register Once mail group"
	9153	"RTN","DGR ODEBR",166 ,0)
	9154	. S DGMSG (5)="and t he ISO exp laining th at this in formation has been r eceived."
	9155	"RTN","DGR ODEBR",167 ,0)
	9156	. D EN^DD IOL(.DGMSG ) R A:5
	9157	"RTN","DGR ODEBR",168 ,0)
	9158	Q
	9159	"RTN","DGR ODEBR",169 ,0)
	9160	;
	9161	"RTN","DGR ODEBR",170 ,0)
	9162	SWA(DGDATA ,DFN,LSTDF N) ;SOUTHW EST ASIA C ONDITIONS
	9163	"RTN","DGR ODEBR",171 ,0)
	9164	; DGDAT A - Data e lement arr ay from LS T, ^TMP("D GROFDA",$J )
	9165	"RTN","DGR ODEBR",172 ,0)
	9166	; DF N - Pointe r to the P ATIENT (#2 ) file
	9167	"RTN","DGR ODEBR",173 ,0)
	9168	; LSTDF N - Pointe r to the p atient dat a from the LST, in D GDATA
	9169	"RTN","DGR ODEBR",174 ,0)
	9170	N RSSWA ;REQUEST ING SITE S OUTHWEST A SIA CONDIT IONS
	9171	"RTN","DGR ODEBR",175 ,0)
	9172	N LSTSWA ;LAST SI TE TREATED SOUTHWEST ASIA COND ITIONS
	9173	"RTN","DGR ODEBR",176 ,0)
	9174	S RSSWA=$ $GET1^DIQ( 2,DFN,.322 013)
	9175	"RTN","DGR ODEBR",177 ,0)
	9176	S LSTSWA= $G(@DGDATA @(2,LSTDFN _",",.3220 13,"E"))
	9177	"RTN","DGR ODEBR",178 ,0)
	9178	;If eithe r of the S OUTHWEST A SIA CONDIT IONS flags
	9179	"RTN","DGR ODEBR",179 ,0)
	9180	;are "N"o , don't fi le the SOU TWEST ASIA CONDITION data elem ent(s)
	9181	"RTN","DGR ODEBR",180 ,0)
	9182	I (RSSWA= "NO")!(LST SWA="NO") D
	9183	"RTN","DGR ODEBR",181 ,0)
	9184	. N FIELD
	9185	"RTN","DGR ODEBR",182 ,0)
	9186	. F FIELD =.322013,3 22014,3220 15 K @DGDA TA@(2,LSTD FN_",",FIE LD)
	9187	"RTN","DGR ODEBR",183 ,0)
	9188	Q
	9189	"RTN","DGR ODEBR",184 ,0)
	9190	;
	9191	"RTN","DGR ODEBR",185 ,0)
	9192	RE ;RACE A ND ETHNICI TY
	9193	"RTN","DGR ODEBR",186 ,0)
	9194	;If the R ACE AND ET HNICITY da ta not alr eady
	9195	"RTN","DGR ODEBR",187 ,0)
	9196	;populate d, file it (already the basic rule)
	9197	"RTN","DGR ODEBR",188 ,0)
	9198	Q
	9199	"RTN","DGR ODEBR",189 ,0)
	9200	;
	9201	"RTN","DGR ODEBR",190 ,0)
	9202	CA(DGDATA, LSTDFN) ;C ONFIDENTIA L ADDRESS
	9203	"RTN","DGR ODEBR",191 ,0)
	9204	; DGDAT A - Data e lement arr ay from LS T, ^TMP("D GROFDA",$J )
	9205	"RTN","DGR ODEBR",192 ,0)
	9206	; LSTDF N - Pointe r to the p atient dat a from the LST, in D GDATA
	9207	"RTN","DGR ODEBR",193 ,0)
	9208	N LSTCAAF ;LST CO NFIDENTIAL ADDRESS A CTIVE FLAG
	9209	"RTN","DGR ODEBR",194 ,0)
	9210	N LSTCAED ;LST CO NFIDENTIAL ADDRESS E ND DATE
	9211	"RTN","DGR ODEBR",195 ,0)
	9212	N LSTCAED F ;LST CON FIDENTIAL ADDRESS EN D DATE FIL EMAN (DG5 .3572)
	9213	"RTN","DGR ODEBR",196 ,0)
	9214	S LSTCAAF =$G(@DGDAT A@(2,LSTDF N_",",.141 05,"E"))
	9215	"RTN","DGR ODEBR",197 ,0)
	9216	S LSTCAED =$G(@DGDAT A@(2,LSTDF N_",",.141 8,"E"))
	9217	"RTN","DGR ODEBR",198 ,0)
	9218	;Convert LSTCAED t o Fileman format dat e for comp are (DG5. 3*572)
	9219	"RTN","DGR ODEBR",199 ,0)
	9220	S X=LSTCA ED
	9221	"RTN","DGR ODEBR",200 ,0)
	9222	S %DT="SN "
	9223	"RTN","DGR ODEBR",201 ,0)
	9224	D ^%DT
	9225	"RTN","DGR ODEBR",202 ,0)
	9226	S LSTCAED F=Y
	9227	"RTN","DGR ODEBR",203 ,0)
	9228	;If the C ONFIDENTIA L ADDRESS FLAG from the Last S ite Treate d is "N"o,
	9229	"RTN","DGR ODEBR",204 ,0)
	9230	; OR if the C.A. END DATE f rom the LS T is less than the Q uery date,
	9231	"RTN","DGR ODEBR",205 ,0)
	9232	;delete t he C.A. da ta element s
	9233	"RTN","DGR ODEBR",206 ,0)
	9234	I (LSTCAA F'="YES")! ((LSTCAEDF >0)&(LSTCA EDF<DT)) D
	9235	"RTN","DGR ODEBR",207 ,0)
	9236	. N FIELD
	9237	"RTN","DGR ODEBR",208 ,0)
	9238	. F FIELD =.1315,.14 105,.14111 :.00001:.1 4116,.1411 :.0001:.14 18 K @DGDA TA@(2,LSTD FN_",",FIE LD)
	9239	"RTN","DGR ODEBR",209 ,0)
	9240	. K @DGDA TA@(2.141)
	9241	"RTN","DGR ODEBR",210 ,0)
	9242	;Else the Confident ial Addres s informat ion will b e filed
	9243	"RTN","DGR ODEBR",211 ,0)
	9244	;and a Us er Interfa ce message will be d isplayed.
	9245	"RTN","DGR ODEBR",212 ,0)
	9246	E D
	9247	"RTN","DGR ODEBR",213 ,0)
	9248	. N DGMSG
	9249	"RTN","DGR ODEBR",214 ,0)
	9250	. N DATEF M ;DATE c onverted t o Fileman format (DG 5.3*572)
	9251	"RTN","DGR ODEBR",215 ,0)
	9252	. S DGMSG (1)=" "
	9253	"RTN","DGR ODEBR",216 ,0)
	9254	. S DGMSG (2)="Confi dential Ad dress info rmation ha s been ret rieved fro m the LST. "
	9255	"RTN","DGR ODEBR",217 ,0)
	9256	. S DGMSG (3)="This informatio n has been filed int o the pati ent's reco rd."
	9257	"RTN","DGR ODEBR",218 ,0)
	9258	. S DATE= $G(@DGDATA @(2,LSTDFN _",",.1417 ,"E"))
	9259	"RTN","DGR ODEBR",219 ,0)
	9260	. ;* Conv ert DATE t o FM forma t (DG5.3 572)
	9261	"RTN","DGR ODEBR",220 ,0)
	9262	. K X,%DT ,Y
	9263	"RTN","DGR ODEBR",221 ,0)
	9264	. S X=DAT E
	9265	"RTN","DGR ODEBR",222 ,0)
	9266	. S %DT=" SN"
	9267	"RTN","DGR ODEBR",223 ,0)
	9268	. D ^%DT
	9269	"RTN","DGR ODEBR",224 ,0)
	9270	. S DATEF M=Y
	9271	"RTN","DGR ODEBR",225 ,0)
	9272	. I DATEF M>DT D
	9273	"RTN","DGR ODEBR",226 ,0)
	9274	. . S DGM SG(4)=" NOTE: Con fidential Address St art Date i s in the f uture, "_D ATE
	9275	"RTN","DGR ODEBR",227 ,0)
	9276	. . S DGM SG(5)=" "
	9277	"RTN","DGR ODEBR",228 ,0)
	9278	. D EN^DD IOL(.DGMSG ) R A:5
	9279	"RTN","DGR ODEBR",229 ,0)
	9280	K X,%DT,Y
	9281	"RTN","DGR ODEBR",230 ,0)
	9282	Q
	9283	"RTN","DGR ODEBR",231 ,0)
	9284	;
	9285	"RTN","DGR ODEBR",232 ,0)
	9286	PA(DGDATA, LSTDFN) ;P ERMANENT A DDRESS
	9287	"RTN","DGR ODEBR",233 ,0)
	9288	; DGDAT A - Data e lement arr ay from LS T, ^TMP("D GROFDA",$J )
	9289	"RTN","DGR ODEBR",234 ,0)
	9290	; LSTDF N - Pointe r to the p atient dat a from the LST, in D GDATA
	9291	"RTN","DGR ODEBR",235 ,0)
	9292	N LSTBAI ;LST BAD ADDRESS I NDICATOR
	9293	"RTN","DGR ODEBR",236 ,0)
	9294	S LSTBAI= $G(@DGDATA @(2,LSTDFN _",",.121, "E"))
	9295	"RTN","DGR ODEBR",237 ,0)
	9296	;If the B AD ADDRESS INDICATOR from LST is NOT nul l,
	9297	"RTN","DGR ODEBR",238 ,0)
	9298	;delete t he PERMANE NT ADDRESS data elem ents
	9299	"RTN","DGR ODEBR",239 ,0)
	9300	I LSTBAI' ="" D
	9301	"RTN","DGR ODEBR",240 ,0)
	9302	. N FIELD
	9303	"RTN","DGR ODEBR",241 ,0)
	9304	. F FIELD =.1112,.11 1:.001:.11 9,.12,.121 K @DGDATA @(2,LSTDFN _",",FIELD )
	9305	"RTN","DGR ODEBR",242 ,0)
	9306	Q
	9307	"RTN","DGR ODEBR",243 ,0)
	9308	;
	9309	"RTN","DGR ODEBR",244 ,0)
	9310	RDOC(DGDAT A,DFN,LSTD FN) ;RECEN T DATE(S) OF CARE
	9311	"RTN","DGR ODEBR",245 ,0)
	9312	; DGDAT A - Data e lement arr ay from LS T, ^TMP("D GROFDA",$J )
	9313	"RTN","DGR ODEBR",246 ,0)
	9314	; DF N - Pointe r to the P ATIENT (#2 ) file
	9315	"RTN","DGR ODEBR",247 ,0)
	9316	; LSTDF N - Pointe r to the p atient dat a from the LST, in D GDATA
	9317	"RTN","DGR ODEBR",248 ,0)
	9318	N LSTRCP ;LST R ECEIVED VA CARE PREV IOUSLY?
	9319	"RTN","DGR ODEBR",249 ,0)
	9320	N LSTLOC1 ;LST M OST RECENT LOCATION OF CARE
	9321	"RTN","DGR ODEBR",250 ,0)
	9322	S LSTRCP= $G(@DGDATA @(2,LSTDFN _",",1010. 15,"E"))
	9323	"RTN","DGR ODEBR",251 ,0)
	9324	S LSTLOC1 =$G(@DGDAT A@(2,LSTDF N_",",1010 .152,"E"))
	9325	"RTN","DGR ODEBR",252 ,0)
	9326	;
	9327	"RTN","DGR ODEBR",253 ,0)
	9328	;If the R ECEIVED VA CARE PREV IOUSLY? fr om LST is not YES,
	9329	"RTN","DGR ODEBR",254 ,0)
	9330	; OR th e MOST REC ENT LOCATI ON OF CARE from LST is NULL,
	9331	"RTN","DGR ODEBR",255 ,0)
	9332	;delete a ll the RDO C fields.
	9333	"RTN","DGR ODEBR",256 ,0)
	9334	I (LSTRCP '="YES")!( LSTLOC1="" ) D
	9335	"RTN","DGR ODEBR",257 ,0)
	9336	. N FIELD
	9337	"RTN","DGR ODEBR",258 ,0)
	9338	. F FIELD =1010.15,1 010.151,10 10.152,101 0.153,1010 .154 K @DG DATA@(2,LS TDFN_",",F IELD)
	9339	"RTN","DGR ODEBR",259 ,0)
	9340	Q
	9341	"RTN","DGR ODEBR",260 ,0)
	9342	;
	9343	"RTN","DGR ODEBR",261 ,0)
	9344	MSE(DGDATA ,LSTDFN) ; MILITARY S ERVICE EPI SODES
	9345	"RTN","DGR ODEBR",262 ,0)
	9346	; DGDAT A - Data e lement arr ay from LS T, ^TMP("D GROFDA",$J )
	9347	"RTN","DGR ODEBR",263 ,0)
	9348	; LSTDF N - Pointe r to the p atient dat a from the LST, in D GDATA
	9349	"RTN","DGR ODEBR",264 ,0)
	9350	;
	9351	"RTN","DGR ODEBR",265 ,0)
	9352	;If new f ormat MSE data exist s from las t site vis ited then do
	9353	"RTN","DGR ODEBR",266 ,0)
	9354	;NOT load old forma t MSE data .
	9355	"RTN","DGR ODEBR",267 ,0)
	9356	;
	9357	"RTN","DGR ODEBR",268 ,0)
	9358	I $D(@DGD ATA@(2.321 6)) D
	9359	"RTN","DGR ODEBR",269 ,0)
	9360	.N FIELD
	9361	"RTN","DGR ODEBR",270 ,0)
	9362	.F FIELD= .324,.325, .326,.327, .328,.3285 ,.329,.329 1,.32911,. 32912,.329 13,.3292,. 3293,.3294 ,.32945,.3 295,.3296, .3297,.329 8,.3299 K @DGDATA@(2 ,LSTDFN_", ",FIELD)
	9363	"RTN","DGR ODEBR",271 ,0)
	9364	Q
	9365	"RTN","DGR OHLR")
	9366	0^76^B1936 8133^B1862 4727
	9367	"RTN","DGR OHLR",1,0)
	9368	DGROHLR ;D JH/AMA - R OM HL7 REC EIVE DRIVE RS ; 10/20 /10 10:55a m
	9369	"RTN","DGR OHLR",2,0)
	9370	;;5.3;Reg istration; 533,572, 754,797,91 4;Aug 13 , 1993;Bui ld 173
	9371	"RTN","DGR OHLR",3,0)
	9372	;
	9373	"RTN","DGR OHLR",4,0)
	9374	RCV ;Recei ve all mes sage types and route to messag e specific receiver
	9375	"RTN","DGR OHLR",5,0)
	9376	;
	9377	"RTN","DGR OHLR",6,0)
	9378	;This pro cedure is the main d river entr y point fo r receivin g all
	9379	"RTN","DGR OHLR",7,0)
	9380	;message types (ACK , QRY and ORF) for R egister On ce Messagi ng.
	9381	"RTN","DGR OHLR",8,0)
	9382	;
	9383	"RTN","DGR OHLR",9,0)
	9384	;All proc edures and functions assume th at all Vis tA HL7 env ironment
	9385	"RTN","DGR OHLR",10,0 )
	9386	;variable s are prop erly initi alized and will prod uce a fata l error if
	9387	"RTN","DGR OHLR",11,0 )
	9388	;they are missing.
	9389	"RTN","DGR OHLR",12,0 )
	9390	;
	9391	"RTN","DGR OHLR",13,0 )
	9392	;The rece ived messa ge is copi ed to a te mporary wo rk global for
	9393	"RTN","DGR OHLR",14,0 )
	9394	;processi ng. The m essage typ e is deter mined from the MSH s egment and
	9395	"RTN","DGR OHLR",15,0 )
	9396	;a receiv e processi ng procedu re specifi c to the m essage typ e is calle d.
	9397	"RTN","DGR OHLR",16,0 )
	9398	;(Ex. ORF ~R01 messa ge calls p rocedure: RCVORF). The specif ic receive
	9399	"RTN","DGR OHLR",17,0 )
	9400	;processi ng procedu re calls a message s pecific pa rse proced ure to
	9401	"RTN","DGR OHLR",18,0 )
	9402	;validate the messa ge data an d return d ata arrays for stora ge. If no
	9403	"RTN","DGR OHLR",19,0 )
	9404	;parse er rors are r eported du ring valid ation, the n the data arrays ar e
	9405	"RTN","DGR OHLR",20,0 )
	9406	;stored b y the rece ive proces sing proce dure. Con trol, alon g with any
	9407	"RTN","DGR OHLR",21,0 )
	9408	;parse va lidation e rrors, is then passe d to the m essage spe cific send
	9409	"RTN","DGR OHLR",22,0 )
	9410	;processi ng procedu res to bui ld and tra nsmit the acknowledg ment and
	9411	"RTN","DGR OHLR",23,0 )
	9412	;query re sults mess ages.
	9413	"RTN","DGR OHLR",24,0 )
	9414	;
	9415	"RTN","DGR OHLR",25,0 )
	9416	; The me ssage spec ific proce dures are as follows :
	9417	"RTN","DGR OHLR",26,0 )
	9418	;
	9419	"RTN","DGR OHLR",27,0 )
	9420	; Messag e Receiv e Procedur e Parse Procedure Send Pr ocedure
	9421	"RTN","DGR OHLR",28,0 )
	9422	; ------ - ------ ---------- - ------ ---------- ------ --------
	9423	"RTN","DGR OHLR",29,0 )
	9424	; SNDACK^ DGROHLS
	9425	"RTN","DGR OHLR",30,0 )
	9426	; ACK~R0 1 RCVACK ^DGROHLR PARSAC K^DGROHLU4 N/A
	9427	"RTN","DGR OHLR",31,0 )
	9428	; QRY~R0 2 RCVQRY ^DGROHLR PARSQR Y^DGROHLQ3 SNDORF^ DGROHLS
	9429	"RTN","DGR OHLR",32,0 )
	9430	; ORF~R0 1 RCVORF ^DGROHLR PARSOR F^DGROHLQ3 N/A
	9431	"RTN","DGR OHLR",33,0 )
	9432	;
	9433	"RTN","DGR OHLR",34,0 )
	9434	N DGCNT,D GMSGTYP,DG SEG,DGSEGC NT,DGWRK
	9435	"RTN","DGR OHLR",35,0 )
	9436	;
	9437	"RTN","DGR OHLR",36,0 )
	9438	S DGWRK=$ NA(^TMP("D GROHL7",$J ))
	9439	"RTN","DGR OHLR",37,0 )
	9440	K @DGWRK
	9441	"RTN","DGR OHLR",38,0 )
	9442	;
	9443	"RTN","DGR OHLR",39,0 )
	9444	;load wor k global w ith segmen ts
	9445	"RTN","DGR OHLR",40,0 )
	9446	F DGSEGCN T=1:1 X HL NEXT Q:HLQ UIT'>0 D
	9447	"RTN","DGR OHLR",41,0 )
	9448	. S DGCNT =0
	9449	"RTN","DGR OHLR",42,0 )
	9450	. S @DGWR K@(DGSEGCN T,DGCNT)=H LNODE
	9451	"RTN","DGR OHLR",43,0 )
	9452	. F S DG CNT=$O(HLN ODE(DGCNT) ) Q:'DGCNT D
	9453	"RTN","DGR OHLR",44,0 )
	9454	. . S @DG WRK@(DGSEG CNT,DGCNT) =HLNODE(DG CNT)
	9455	"RTN","DGR OHLR",45,0 )
	9456	;
	9457	"RTN","DGR OHLR",46,0 )
	9458	;get mess age type f rom "MSH"
	9459	"RTN","DGR OHLR",47,0 )
	9460	I $$NXTSE G^DGROHLUT (DGWRK,0,H L("FS"),.D GSEG),$G(D GSEG("TYPE "))="MSH" D
	9461	"RTN","DGR OHLR",48,0 )
	9462	. S DGMSG TYP=$P(DGS EG(9),$E(H L("ECH"),1 ),1)
	9463	"RTN","DGR OHLR",49,0 )
	9464	. ;HLMTIE NS is only required by RCVORU and RCVQRY , thus $GE T
	9465	"RTN","DGR OHLR",50,0 )
	9466	. I DGMSG TYP="" S ( DGMSGTYP,H L("MTN"))= "ORF",HLMT IENS=HLMTI EN
	9467	"RTN","DGR OHLR",51,0 )
	9468	. I DGMSG TYP=HL("MT N") D @("R CV"_DGMSGT YP_"(DGWRK ,$G(HLMTIE NS),.HL)")
	9469	"RTN","DGR OHLR",52,0 )
	9470	;
	9471	"RTN","DGR OHLR",53,0 )
	9472	;cleanup
	9473	"RTN","DGR OHLR",54,0 )
	9474	K @DGWRK
	9475	"RTN","DGR OHLR",55,0 )
	9476	Q
	9477	"RTN","DGR OHLR",56,0 )
	9478	;
	9479	"RTN","DGR OHLR",57,0 )
	9480	RCVACK(DGW RK,DGMIEN, DGHL) ;Rec eive ACK M essage Typ es (ACK~R0 1)
	9481	"RTN","DGR OHLR",58,0 )
	9482	;
	9483	"RTN","DGR OHLR",59,0 )
	9484	; Input:
	9485	"RTN","DGR OHLR",60,0 )
	9486	; DGWR K - name o f work glo bal contai ning segme nts
	9487	"RTN","DGR OHLR",61,0 )
	9488	; DGMIE N - IEN of message e ntry in fi le #773
	9489	"RTN","DGR OHLR",62,0 )
	9490	; DGH L - HL env ironment a rray
	9491	"RTN","DGR OHLR",63,0 )
	9492	;
	9493	"RTN","DGR OHLR",64,0 )
	9494	; Output :
	9495	"RTN","DGR OHLR",65,0 )
	9496	; none
	9497	"RTN","DGR OHLR",66,0 )
	9498	;
	9499	"RTN","DGR OHLR",67,0 )
	9500	N DGACK ;ACK data array
	9501	"RTN","DGR OHLR",68,0 )
	9502	N DGERR ;error ar ray
	9503	"RTN","DGR OHLR",69,0 )
	9504	N DGLIEN ;HL7 tran smission l og IEN
	9505	"RTN","DGR OHLR",70,0 )
	9506	N DGROL ;HL7 tran smssion lo g data arr ay
	9507	"RTN","DGR OHLR",71,0 )
	9508	;
	9509	"RTN","DGR OHLR",72,0 )
	9510	S ACKCODE =0
	9511	"RTN","DGR OHLR",73,0 )
	9512	D PARSACK ^DGROHLU4( DGWRK,.DGH L,.DGACK,. DGERR)
	9513	"RTN","DGR OHLR",74,0 )
	9514	I $G(DGAC K("ACKCODE "))'="AA" S ACKCODE= 1
	9515	"RTN","DGR OHLR",75,0 )
	9516	Q
	9517	"RTN","DGR OHLR",76,0 )
	9518	;
	9519	"RTN","DGR OHLR",77,0 )
	9520	RCVQRY(DGW RK,DGMIEN, DGHL) ;Rec eive QRY M essage Typ es (QRY~R0 2)
	9521	"RTN","DGR OHLR",78,0 )
	9522	;
	9523	"RTN","DGR OHLR",79,0 )
	9524	; Input:
	9525	"RTN","DGR OHLR",80,0 )
	9526	; DGWR K - name o f work glo bal contai ning segme nts
	9527	"RTN","DGR OHLR",81,0 )
	9528	; DGMIE N - IEN of message e ntry in fi le #773
	9529	"RTN","DGR OHLR",82,0 )
	9530	; DGH L - HL env ironment a rray
	9531	"RTN","DGR OHLR",83,0 )
	9532	;
	9533	"RTN","DGR OHLR",84,0 )
	9534	; Output :
	9535	"RTN","DGR OHLR",85,0 )
	9536	; none
	9537	"RTN","DGR OHLR",86,0 )
	9538	;
	9539	"RTN","DGR OHLR",87,0 )
	9540	N DGDFN,D GQRY,DGQRY ERR,DGSEGE RR
	9541	"RTN","DGR OHLR",88,0 )
	9542	;
	9543	"RTN","DGR OHLR",89,0 )
	9544	D PARSQRY ^DGROHLQ3( DGWRK,.DGH L,.DGQRY,. DGSEGERR)
	9545	"RTN","DGR OHLR",90,0 )
	9546	S DGDFN=$ $GETDFN^DG ROUT2(DGQR Y("ICN"),D GQRY("DOB" ),DGQRY("S SN"))
	9547	"RTN","DGR OHLR",91,0 )
	9548	I DGDFN'> 0 D
	9549	"RTN","DGR OHLR",92,0 )
	9550	. S DGQRY ERR="NM"
	9551	"RTN","DGR OHLR",93,0 )
	9552	. ;
	9553	"RTN","DGR OHLR",94,0 )
	9554	. ;THE IC N FROM THE MPI DOES NOT MATCH A PATIENT, SO NOTIFY THE MPI
	9555	"RTN","DGR OHLR",95,0 )
	9556	. D MPIMA IL^DGROMAI L(.DGQRY)
	9557	"RTN","DGR OHLR",96,0 )
	9558	. ;
	9559	"RTN","DGR OHLR",97,0 )
	9560	D SNDORF^ DGROHLS(.D GQRY,DGMIE N,.DGHL,DG DFN,.DGSEG ERR,.DGQRY ERR)
	9561	"RTN","DGR OHLR",98,0 )
	9562	Q
	9563	"RTN","DGR OHLR",99,0 )
	9564	;
	9565	"RTN","DGR OHLR",100, 0)
	9566	RCVORF(DGW RK,DGMIEN, DGHL) ;Rec eive ORF M essage Typ es (ORF~R0 1)
	9567	"RTN","DGR OHLR",101, 0)
	9568	;
	9569	"RTN","DGR OHLR",102, 0)
	9570	; Input:
	9571	"RTN","DGR OHLR",103, 0)
	9572	; DGWR K - name o f work glo bal contai ning segme nts, ^TMP( "DGROHL7", $J)
	9573	"RTN","DGR OHLR",104, 0)
	9574	; DGMIE N - IEN of message e ntry in fi le #773
	9575	"RTN","DGR OHLR",105, 0)
	9576	; DGH L - HL env ironment a rray
	9577	"RTN","DGR OHLR",106, 0)
	9578	;
	9579	"RTN","DGR OHLR",107, 0)
	9580	; Output :
	9581	"RTN","DGR OHLR",108, 0)
	9582	; none
	9583	"RTN","DGR OHLR",109, 0)
	9584	;
	9585	"RTN","DGR OHLR",110, 0)
	9586	N DGDATA ;patien t data arr ay to uplo ad
	9587	"RTN","DGR OHLR",111, 0)
	9588	N DGERR ;parse error arra y
	9589	"RTN","DGR OHLR",112, 0)
	9590	N DGORF ;ORF da ta array
	9591	"RTN","DGR OHLR",113, 0)
	9592	;
	9593	"RTN","DGR OHLR",114, 0)
	9594	S DGDATA= $NA(^TMP(" DGROFDA",$ J)) K @DGD ATA
	9595	"RTN","DGR OHLR",115, 0)
	9596	D PARSORF ^DGROHLQ3( DGWRK,.DGH L,.DGORF,. DGERR,.DGD ATA)
	9597	"RTN","DGR OHLR",116, 0)
	9598	;
	9599	"RTN","DGR OHLR",117, 0)
	9600	I $D(DGRO VRCK) DO
	9601	"RTN","DGR OHLR",118, 0)
	9602	. S:('$D( DGORF("PAT CH"))) DGR OVRCK=0
	9603	"RTN","DGR OHLR",119, 0)
	9604	. I ($D(D GORF("PATC H"))),(+DG ORF("PATCH ")'=572) S DGROVRCK= 0
	9605	"RTN","DGR OHLR",120, 0)
	9606	;
	9607	"RTN","DGR OHLR",121, 0)
	9608	;* QUIT c onditions
	9609	"RTN","DGR OHLR",122, 0)
	9610	Q:'$D(DGO RF)
	9611	"RTN","DGR OHLR",123, 0)
	9612	Q:(+$G(DG ORF("DFN") )'>0)
	9613	"RTN","DGR OHLR",124, 0)
	9614	Q:'$D(^DP T(DGORF("D FN"),0))
	9615	"RTN","DGR OHLR",125, 0)
	9616	Q:('$D(DG ORF("PATCH ")))
	9617	"RTN","DGR OHLR",126, 0)
	9618	;Q:(+DGOR F("PATCH") '=572)
	9619	"RTN","DGR OHLR",127, 0)
	9620	;
	9621	"RTN","DGR OHLR",128, 0)
	9622	S DFN=DGO RF("DFN")
	9623	"RTN","DGR OHLR",129, 0)
	9624	;
	9625	"RTN","DGR OHLR",130, 0)
	9626	;Get DFN at Last Si te Treated
	9627	"RTN","DGR OHLR",131, 0)
	9628	S LSTDFN= +$O(@DGDAT A@(2,""))
	9629	"RTN","DGR OHLR",132, 0)
	9630	;CHECK BU SINESS RUL ES
	9631	"RTN","DGR OHLR",133, 0)
	9632	D AO^DGRO DEBR(DGDAT A,DFN,LSTD FN) ;AG ENT ORANGE EXPOSURE
	9633	"RTN","DGR OHLR",134, 0)
	9634	D IR^DGRO DEBR(DGDAT A,DFN,LSTD FN) ;RA DIATION EX POSURE
	9635	"RTN","DGR OHLR",135, 0)
	9636	D DOD^DGR ODEBR(DGDA TA,DFN,LST DFN) ;DA TE OF DEAT H
	9637	"RTN","DGR OHLR",136, 0)
	9638	D TA^DGRO DEBR(DGDAT A,LSTDFN) ;TE MPORARY AD DRESS
	9639	"RTN","DGR OHLR",137, 0)
	9640	D SP^DGRO DEBR(DGDAT A,DFN,LSTD FN) ;SE NSITIVE PA TIENT
	9641	"RTN","DGR OHLR",138, 0)
	9642	D CA^DGRO DEBR(DGDAT A,LSTDFN) ;CO NFIDENTIAL ADDRESS
	9643	"RTN","DGR OHLR",139, 0)
	9644	D SWA^DGR ODEBR(DGDA TA,DFN,LST DFN) ;SO UTHWEST AS IA CONDITI ONS
	9645	"RTN","DGR OHLR",140, 0)
	9646	D INC^DGR ODEBR(DGDA TA,DFN,LST DFN) ;RU LED INCOMP ETENT
	9647	"RTN","DGR OHLR",141, 0)
	9648	D INE^DGR ODEBR(DGDA TA,DFN,LST DFN) ;IN ELIGIBLE
	9649	"RTN","DGR OHLR",142, 0)
	9650	D RDOC^DG RODEBR(DGD ATA,DFN,LS TDFN) ;RE CENT DATE( S) OF CARE
	9651	"RTN","DGR OHLR",143, 0)
	9652	D MSE^DGR ODEBR(DGDA TA,LSTDFN) ;MI LITARY SER VICE EPISO DES
	9653	"RTN","DGR OHLR",144, 0)
	9654	D CLV^DGR ODEBR(DGDA TA,DFN,LST DFN) ;CA MP LEJEUNE PWC DG* 5.3*914
	9655	"RTN","DGR OHLR",145, 0)
	9656	;
	9657	"RTN","DGR OHLR",146, 0)
	9658	;File the data
	9659	"RTN","DGR OHLR",147, 0)
	9660	D CONVFDA ^DGROHLR1( DFN,DGDATA )
	9661	"RTN","DGR OHLR",148, 0)
	9662	;CLEAN UP
	9663	"RTN","DGR OHLR",149, 0)
	9664	K @DGDATA
	9665	"RTN","DGR OHLR",150, 0)
	9666	Q
	9667	"RTN","DGU TL3")
	9668	0^64^B1039 6641^B9126 169
	9669	"RTN","DGU TL3",1,0)
	9670	DGUTL3 ;AL B/MTC,CKN - ELIGIBIL ITY UTILIT IES ;10/4/ 05 12:22pm
	9671	"RTN","DGU TL3",2,0)
	9672	;;5.3;Reg istration; 114,506, 653,914; Aug 13, 19 93;Build 1 73
	9673	"RTN","DGU TL3",3,0)
	9674	;
	9675	"RTN","DGU TL3",4,0)
	9676	Q
	9677	"RTN","DGU TL3",5,0)
	9678	ELIG(DFN,S OURCE,DEFA ULT) ;-- T his functi on will pr ompt for t he eligibi lity for a patient. If
	9679	"RTN","DGU TL3",6,0)
	9680	; only one eligib ility then it will b e returned without p rompting.
	9681	"RTN","DGU TL3",7,0)
	9682	;
	9683	"RTN","DGU TL3",8,0)
	9684	; INPUT : DFN - P atient
	9685	"RTN","DGU TL3",9,0)
	9686	; SOURCE - (1:PTF,2 :ADMISSION ,3:TRANSFE R)
	9687	"RTN","DGU TL3",10,0)
	9688	; DEFALUT - IEN fro m file 8.1
	9689	"RTN","DGU TL3",11,0)
	9690	; OUTPUT : IEN of file 8^Nam e
	9691	"RTN","DGU TL3",12,0)
	9692	;
	9693	"RTN","DGU TL3",13,0)
	9694	;
	9695	"RTN","DGU TL3",14,0)
	9696	N RESULT, VAEL,ALLEL ,EMP,X,DGD EF,Y
	9697	"RTN","DGU TL3",15,0)
	9698	;
	9699	"RTN","DGU TL3",16,0)
	9700	;-- get e ligibility codes
	9701	"RTN","DGU TL3",17,0)
	9702	D GETEL(D FN)
	9703	"RTN","DGU TL3",18,0)
	9704	S DGDEF=$ P($G(^DIC( 8,+$G(DEFA ULT),0)),U )
	9705	"RTN","DGU TL3",19,0)
	9706	I DGDEF'= "" S DGDEF =DEFAULT_U _DGDEF
	9707	"RTN","DGU TL3",20,0)
	9708	;
	9709	"RTN","DGU TL3",21,0)
	9710	S RESULT= "",EMP=$P( VAEL(1),U, 2),ALLEL=U _EMP
	9711	"RTN","DGU TL3",22,0)
	9712	I '$D(VAE L) G ELIGQ
	9713	"RTN","DGU TL3",23,0)
	9714	I $D(VAEL (1))=1 S R ESULT=VAEL (1) G ELIG Q
	9715	"RTN","DGU TL3",24,0)
	9716	;-- if no default s et default to primar y eligibil ity
	9717	"RTN","DGU TL3",25,0)
	9718	I DGDEF=" " S DGDEF= VAEL(1)
	9719	"RTN","DGU TL3",26,0)
	9720	;
	9721	"RTN","DGU TL3",27,0)
	9722	DISP ;-- d isplay cho ices
	9723	"RTN","DGU TL3",28,0)
	9724	W !,"THIS PATIENT H AS OTHER E NTITLED EL IGIBILITIE S:"
	9725	"RTN","DGU TL3",29,0)
	9726	W !?5,$P( VAEL(1),U, 2)
	9727	"RTN","DGU TL3",30,0)
	9728	S X="" F S X=$O(VA EL(1,X)) Q :X'>0 D
	9729	"RTN","DGU TL3",31,0)
	9730	. W !?5,$ P(VAEL(1,X ),U,2)
	9731	"RTN","DGU TL3",32,0)
	9732	. S ALLEL =ALLEL_U_$ P(VAEL(1,X ),U,2)
	9733	"RTN","DGU TL3",33,0)
	9734	;
	9735	"RTN","DGU TL3",34,0)
	9736	;-- promp t for elig ibility co des
	9737	"RTN","DGU TL3",35,0)
	9738	;
	9739	"RTN","DGU TL3",36,0)
	9740	1 W !,"ENT ER THE ELI GIBILITY F OR THIS "_ $S(SOURCE= 1:"MOVEMEN T",SOURCE= 2:"ADMISSI ON",SOURCE =3:"TRANSF ER",1:"PAT IENT")_": "_$P(DGDEF ,U,2)_"// "
	9741	"RTN","DGU TL3",37,0)
	9742	R X:DTIME
	9743	"RTN","DGU TL3",38,0)
	9744	;-- if ti meout
	9745	"RTN","DGU TL3",39,0)
	9746	G ELIGQ:' $T
	9747	"RTN","DGU TL3",40,0)
	9748	;-- if ^
	9749	"RTN","DGU TL3",41,0)
	9750	G ELIGQ:X [U
	9751	"RTN","DGU TL3",42,0)
	9752	;-- if de fault (pri mary) quit
	9753	"RTN","DGU TL3",43,0)
	9754	I X="" S RESULT=DGD EF G ELIGQ
	9755	"RTN","DGU TL3",44,0)
	9756	;-- find eligibilit y
	9757	"RTN","DGU TL3",45,0)
	9758	S X=$$UPP ER^VALM1(X )
	9759	"RTN","DGU TL3",46,0)
	9760	G DISP:X[ "?",1:ALLE L'[(U_X)
	9761	"RTN","DGU TL3",47,0)
	9762	;
	9763	"RTN","DGU TL3",48,0)
	9764	S EMP=X_$ P($P(ALLEL ,U_X,2),U) W $P($P(A LLEL,U_X,2 ),U)
	9765	"RTN","DGU TL3",49,0)
	9766	I $P(VAEL (1),U,2)=E MP S RESUL T=VAEL(1) G ELIGQ
	9767	"RTN","DGU TL3",50,0)
	9768	S X="" F S X=$O(VA EL(1,X)) Q :X'>0 D
	9769	"RTN","DGU TL3",51,0)
	9770	. I $P(VA EL(1,X),U, 2)=EMP S R ESULT=X_U_ EMP
	9771	"RTN","DGU TL3",52,0)
	9772	;
	9773	"RTN","DGU TL3",53,0)
	9774	ELIGQ ;
	9775	"RTN","DGU TL3",54,0)
	9776	K VAEL
	9777	"RTN","DGU TL3",55,0)
	9778	Q +RESULT
	9779	"RTN","DGU TL3",56,0)
	9780	;
	9781	"RTN","DGU TL3",57,0)
	9782	GETEL(DFN) ;-- This function w ill get th e eligibil ities for the patien t
	9783	"RTN","DGU TL3",58,0)
	9784	; specif ied by DFN and retur n all the active eli gibilities in the
	9785	"RTN","DGU TL3",59,0)
	9786	; ARRAY specified.
	9787	"RTN","DGU TL3",60,0)
	9788	;
	9789	"RTN","DGU TL3",61,0)
	9790	; INPUT: DFN - Pa tient
	9791	"RTN","DGU TL3",62,0)
	9792	;
	9793	"RTN","DGU TL3",63,0)
	9794	D ELIG^VA DPT
	9795	"RTN","DGU TL3",64,0)
	9796	Q
	9797	"RTN","DGU TL3",65,0)
	9798	;
	9799	"RTN","DGU TL3",66,0)
	9800	GETDEL(DFN ,START,END ) ;-- This function will scan the Eligib ility Date
	9801	"RTN","DGU TL3",67,0)
	9802	; Sensiti ve file #8 .3 for all active el igibilitie s for a da te range.
	9803	"RTN","DGU TL3",68,0)
	9804	;
	9805	"RTN","DGU TL3",69,0)
	9806	N DGI,DGJ ,DGK
	9807	"RTN","DGU TL3",70,0)
	9808	;
	9809	"RTN","DGU TL3",71,0)
	9810	S DGI=0 F S DGI=$O (^VAEL(8.3 ,"AE",DFN, DGI)) Q:DG I="" D
	9811	"RTN","DGU TL3",72,0)
	9812	. S DGJ=$ O(^VAEL(8. 3,"AE",DFN ,DGI,0)),D GK=^(DGJ)
	9813	"RTN","DGU TL3",73,0)
	9814	. I $P(DG K,U,2) S V AEL(1)=DGI _U_$P($G(^ DIC(8,DGI, 0)),U)
	9815	"RTN","DGU TL3",74,0)
	9816	. I '$P(D GK,U,2) S VAEL(1,DGI )=DGI_U_$P ($G(^DIC(8 ,DGI,0)),U )
	9817	"RTN","DGU TL3",75,0)
	9818	Q
	9819	"RTN","DGU TL3",76,0)
	9820	;
	9821	"RTN","DGU TL3",77,0)
	9822	ASKPR(DFN) ;-- This function w ill ask th e user for the prima ry eligibi lity.
	9823	"RTN","DGU TL3",78,0)
	9824	;
	9825	"RTN","DGU TL3",79,0)
	9826	N RESULT, VAEL,ALLEL ,EMP,X,DGD EF,Y
	9827	"RTN","DGU TL3",80,0)
	9828	;
	9829	"RTN","DGU TL3",81,0)
	9830	;-- get e ligibility codes
	9831	"RTN","DGU TL3",82,0)
	9832	S DEFAULT =$O(^VAEL( 8.3,"AP",D FN,0))
	9833	"RTN","DGU TL3",83,0)
	9834	S DGDEF=$ P($G(^DIC( 8,+$G(DEFA ULT),0)),U )
	9835	"RTN","DGU TL3",84,0)
	9836	I DGDEF'= "" S DGDEF =DEFAULT_U _DGDEF
	9837	"RTN","DGU TL3",85,0)
	9838	;
	9839	"RTN","DGU TL3",86,0)
	9840	S RESULT= ""
	9841	"RTN","DGU TL3",87,0)
	9842	;
	9843	"RTN","DGU TL3",88,0)
	9844	TRY W !,"P RIMARY ELI GIBILITY C ODE: "_$P( DGDEF,U,2) _"// "
	9845	"RTN","DGU TL3",89,0)
	9846	R X:DTIME
	9847	"RTN","DGU TL3",90,0)
	9848	;-- if ti meout
	9849	"RTN","DGU TL3",91,0)
	9850	G PRIMQ:' $T
	9851	"RTN","DGU TL3",92,0)
	9852	;-- if ^
	9853	"RTN","DGU TL3",93,0)
	9854	G PRIMQ:X [U
	9855	"RTN","DGU TL3",94,0)
	9856	;-- find eligibilit y
	9857	"RTN","DGU TL3",95,0)
	9858	S X=$$UPP ER^VALM1(X )
	9859	"RTN","DGU TL3",96,0)
	9860	;
	9861	"RTN","DGU TL3",97,0)
	9862	PRIMQ ;
	9863	"RTN","DGU TL3",98,0)
	9864	K VAEL
	9865	"RTN","DGU TL3",99,0)
	9866	Q +RESULT
	9867	"RTN","DGU TL3",100,0 )
	9868	;
	9869	"RTN","DGU TL3",101,0 )
	9870	BADADR(DFN ) ;does th is patient have a ba d address?
	9871	"RTN","DGU TL3",102,0 )
	9872	;
	9873	"RTN","DGU TL3",103,0 )
	9874	Q:'$G(DFN ) ""
	9875	"RTN","DGU TL3",104,0 )
	9876	Q $P($G(^ DPT(DFN,.1 1)),"^",16 )
	9877	"RTN","DGU TL3",105,0 )
	9878	;
	9879	"RTN","DGU TL3",106,0 )
	9880	DELBAI(DFN ) ;delete bad addres s indicato r
	9881	"RTN","DGU TL3",107,0 )
	9882	N FDA,IEN S
	9883	"RTN","DGU TL3",108,0 )
	9884	Q:'$G(DFN )
	9885	"RTN","DGU TL3",109,0 )
	9886	S IENS=DF N_",",FDA( 2,IENS,.12 1)="@"
	9887	"RTN","DGU TL3",110,0 )
	9888	D FILE^DI E("E","FDA ")
	9889	"RTN","DGU TL3",111,0 )
	9890	Q
	9891	"RTN","DGU TL3",112,0 )
	9892	GETSHAD(DF N) ;Get cu rrent valu e of Proj 112/SHAD f rom Patien t file.
	9893	"RTN","DGU TL3",113,0 )
	9894	; Input : DFN - P atient ien
	9895	"RTN","DGU TL3",114,0 )
	9896	; Output : Valid va lues - 1 ( Yes), 0 (N o), or nul l
	9897	"RTN","DGU TL3",115,0 )
	9898	; -1 - err or
	9899	"RTN","DGU TL3",116,0 )
	9900	Q:$G(DFN) ="" -1 ;Qu it with er ror if mis sing input parameter
	9901	"RTN","DGU TL3",117,0 )
	9902	Q $P($G(^ DPT(DFN,.3 21)),"^",1 5)
	9903	"RTN","DGU TL3",118,0 )
	9904	;
	9905	"RTN","DGU TL3",119,0 )
	9906	; pwc DG* 5.3*914 RS D SPEC# 2. 6.6.2.4 80 1 Screen
	9907	"RTN","DGU TL3",120,0 )
	9908	GETCL(DFN) ;Get curr ent value of Camp Le jeune from Patient f ile
	9909	"RTN","DGU TL3",121,0 )
	9910	; Input : DFN - P atient ien
	9911	"RTN","DGU TL3",122,0 )
	9912	; Output : Valid va lues - 1 ( Yes), 0 (N o), or nul l
	9913	"RTN","DGU TL3",123,0 )
	9914	; Suppor ted ICR #1 0061: This supports use of SVC ^VADPT to
	9915	"RTN","DGU TL3",124,0 )
	9916	; retri eve the Ca mp Lejeune Indicator .
	9917	"RTN","DGU TL3",125,0 )
	9918	Q:$G(DFN) ="" -1 ;Qu it with er ror if mis sing input parameter
	9919	"RTN","DGU TL3",126,0 )
	9920	N CLV D S VC^VADPT S CLV=$G(VA SV(15))
	9921	"RTN","DGU TL3",127,0 )
	9922	Q CLV
	9923	"RTN","VAD PT0")
	9924	0^2^B14019 831^B13625 852
	9925	"RTN","VAD PT0",1,0)
	9926	VADPT0 ;AL B/MRL/MJK, ERC,TDM - PATIENT VA RIABLE ROU TINE DRIVE R, CONT. ; 02/22/201 6
	9927	"RTN","VAD PT0",2,0)
	9928	;;5.3;Reg istration; 343,342, 415,489,49 8,528,689, 789,688,75 9,754,887, 914;Aug 13, 1993;B uild 173
	9929	"RTN","VAD PT0",3,0)
	9930	;
	9931	"RTN","VAD PT0",4,0)
	9932	;Initiali ze variabl es
	9933	"RTN","VAD PT0",5,0)
	9934	N I1,X,Y, I
	9935	"RTN","VAD PT0",6,0)
	9936	S U="^" D DT^DICRW: '$D(DT)
	9937	"RTN","VAD PT0",7,0)
	9938	S VAERR=$ S($G(DFN)= "":1,'$D(^ DPT(DFN,0) ):1,1:0)
	9939	"RTN","VAD PT0",8,0)
	9940	S Y=VAN'= 13 I Y,$D( VAROOT)'[0 ,VAROOT]"" S Y=0,VAV =VAROOT K @VAV
	9941	"RTN","VAD PT0",9,0)
	9942	I Y S:$S( VAN>9:1,'$ D(VAHOW):0 ,1:VAHOW[2 ) VAV="^UT ILITY("_"" ""_VAV_""" "_","_$J_" )"
	9943	"RTN","VAD PT0",10,0)
	9944	D @VAN
	9945	"RTN","VAD PT0",11,0)
	9946	Q K X,Y,VA C,VAS,VAV, VAW,VAN,I, VAX,VAZ Q
	9947	"RTN","VAD PT0",12,0)
	9948	;
	9949	"RTN","VAD PT0",13,0)
	9950	INIT ; -- determine #'s or nam es then in it array
	9951	"RTN","VAD PT0",14,0)
	9952	;
	9953	"RTN","VAD PT0",15,0)
	9954	S VAS="1^ 2^3^4^5^6^ 7^8^9^10^1 1^12^13^14 ^15^16^17^ 18^19^20^2 1^22^23^24 ^25^26^27^ 28^29"
	9955	"RTN","VAD PT0",16,0)
	9956	I VAN<10, $D(VAHOW), VAHOW[1 S VAS=$P($T( SS+VAN),"; ;",2)
	9957	"RTN","VAD PT0",17,0)
	9958	I $D(VAN( 1)) F I=1: 1:VAN(1) S @VAV@($P( VAS,"^",I) )=""
	9959	"RTN","VAD PT0",18,0)
	9960	Q
	9961	"RTN","VAD PT0",19,0)
	9962	;
	9963	"RTN","VAD PT0",20,0)
	9964	1 ; -- [DE M] demos
	9965	"RTN","VAD PT0",21,0)
	9966	D C1,INIT I 'VAERR D 1^VADPT1 ,13 Q
	9967	"RTN","VAD PT0",22,0)
	9968	;
	9969	"RTN","VAD PT0",23,0)
	9970	2 ; -- [OP D] other p t vars
	9971	"RTN","VAD PT0",24,0)
	9972	D C2,INIT ,2^VADPT1: 'VAERR Q
	9973	"RTN","VAD PT0",25,0)
	9974	;
	9975	"RTN","VAD PT0",26,0)
	9976	3 ; -- [AD D] current address
	9977	"RTN","VAD PT0",27,0)
	9978	D C3,INIT ,3^VADPT1: 'VAERR Q
	9979	"RTN","VAD PT0",28,0)
	9980	;
	9981	"RTN","VAD PT0",29,0)
	9982	4 ; -- [OA D] other p t vars
	9983	"RTN","VAD PT0",30,0)
	9984	D C4,INIT ,4^VADPT1: 'VAERR Q
	9985	"RTN","VAD PT0",31,0)
	9986	;
	9987	"RTN","VAD PT0",32,0)
	9988	5 ; -- [IN P] inpt da ta -v5
	9989	"RTN","VAD PT0",33,0)
	9990	D C5,INIT ,5^VADPT2: 'VAERR Q
	9991	"RTN","VAD PT0",34,0)
	9992	;
	9993	"RTN","VAD PT0",35,0)
	9994	6 ; -- [IN 5] inpt da ta v5
	9995	"RTN","VAD PT0",36,0)
	9996	D C6,INIT F I=13:1: 17 F I1=1: 1:7 S @VAV @($P(VAS," ^",I),I1)= ""
	9997	"RTN","VAD PT0",37,0)
	9998	F I=1:1:3 S @VAV@($ P(VAS,"^", 19),I)=""
	9999	"RTN","VAD PT0",38,0)
	10000	D 6^VADPT 3:'VAERR Q
	10001	"RTN","VAD PT0",39,0)
	10002	;
	10003	"RTN","VAD PT0",40,0)
	10004	7 ; -- [EL IG] elig d ata
	10005	"RTN","VAD PT0",41,0)
	10006	D C7,INIT F I=1:1:6 S @VAV@($ P(VAS,"^", 5),I)=""
	10007	"RTN","VAD PT0",42,0)
	10008	D 7^VADPT 4:'VAERR Q
	10009	"RTN","VAD PT0",43,0)
	10010	;
	10011	"RTN","VAD PT0",44,0)
	10012	8 ; -- [MB ] $ benefi ts F I=2,6 ,7,8,9 F I 1=3,4,5 S @VAV@($P(V AS,"^",I), I1)=""
	10013	"RTN","VAD PT0",45,0)
	10014	D C8,INIT D 8^VADPT 4:'VAERR Q
	10015	"RTN","VAD PT0",46,0)
	10016	;
	10017	"RTN","VAD PT0",47,0)
	10018	9 ; -- [SV C] service data
	10019	"RTN","VAD PT0",48,0)
	10020	; pwc DG* 5.3*914 RS D SPEC #2. 6.1 Storin g Camp Lej eune Infor mation in VistA Adde d VASV(15) array
	10021	"RTN","VAD PT0",49,0)
	10022	D C9,INIT F I=1:1:9 ,15 S @VAV @($P(VAS," ^",I),1)=" ",@VAV@($P (VAS,"^",I ),2)=""
	10023	"RTN","VAD PT0",50,0)
	10024	S @VAV@($ P(VAS,"^", 10),1)=""
	10025	"RTN","VAD PT0",51,0)
	10026	F I=11:1: 13 S @VAV@ ($P(VAS,"^ ",I))=0
	10027	"RTN","VAD PT0",52,0)
	10028	S @VAV@($ P(VAS,"^", 14),1)=""
	10029	"RTN","VAD PT0",53,0)
	10030	S @VAV@($ P(VAS,"^", 4),3)="",@ VAV@($P(VA S,"^",5),3 )="",@VAV@ ($P(VAS,"^ ",15),3)=" "
	10031	"RTN","VAD PT0",54,0)
	10032	F I=2,6,7 ,8 F I1=3, 4,5 S @VAV @($P(VAS," ^",I),I1)= ""
	10033	"RTN","VAD PT0",55,0)
	10034	D 9^VADPT 4:'VAERR Q
	10035	"RTN","VAD PT0",56,0)
	10036	;
	10037	"RTN","VAD PT0",57,0)
	10038	10 ; -- [R EG] regist ration dat a
	10039	"RTN","VAD PT0",58,0)
	10040	D C10,INI T D 10^VAD PT5:'VAERR Q
	10041	"RTN","VAD PT0",59,0)
	10042	;
	10043	"RTN","VAD PT0",60,0)
	10044	11 ; -- [S DE] clinic enrollmen t data
	10045	"RTN","VAD PT0",61,0)
	10046	D C11,INI T D 11^VAD PT5:'VAERR Q
	10047	"RTN","VAD PT0",62,0)
	10048	;
	10049	"RTN","VAD PT0",63,0)
	10050	12 ; -- [S DA] appt d ata
	10051	"RTN","VAD PT0",64,0)
	10052	D C12,INI T D 12^VAD PT5:'VAERR Q
	10053	"RTN","VAD PT0",65,0)
	10054	;
	10055	"RTN","VAD PT0",66,0)
	10056	13 ; -- [P ID] pt id' s
	10057	"RTN","VAD PT0",67,0)
	10058	S (VA("PI D"),VA("BI D"))="" D 13^VADPT6: 'VAERR Q
	10059	"RTN","VAD PT0",68,0)
	10060	;
	10061	"RTN","VAD PT0",69,0)
	10062	KVAR ; kil l all vadp t data
	10063	"RTN","VAD PT0",70,0)
	10064	K VAN
	10065	"RTN","VAD PT0",71,0)
	10066	C1 K ^UTIL ITY("VADM" ,$J),VADM Q:$D(VAN)
	10067	"RTN","VAD PT0",72,0)
	10068	C2 K ^UTIL ITY("VAPD" ,$J),VAPD Q:$D(VAN)
	10069	"RTN","VAD PT0",73,0)
	10070	C3 K X S:$ D(VAPA("P" )) X("P")= VAPA("P")
	10071	"RTN","VAD PT0",74,0)
	10072	S:$D(VAPA ("CD")) X( "CD")=VAPA ("CD")
	10073	"RTN","VAD PT0",75,0)
	10074	K ^UTILIT Y("VAPA",$ J),VAPA
	10075	"RTN","VAD PT0",76,0)
	10076	S:$D(X("P ")) VAPA(" P")=X("P") K X("P")
	10077	"RTN","VAD PT0",77,0)
	10078	S:$D(X("C D")) VAPA( "CD")=X("C D") K X Q: $D(VAN)
	10079	"RTN","VAD PT0",78,0)
	10080	C4 K X S:$ D(VAOA("A" )) X("A")= VAOA("A")
	10081	"RTN","VAD PT0",79,0)
	10082	K ^UTILIT Y("VAOA",$ J),VAOA
	10083	"RTN","VAD PT0",80,0)
	10084	S:$D(X("A ")) VAOA(" A")=X("A") K X Q:$D( VAN)
	10085	"RTN","VAD PT0",81,0)
	10086	C5 K ^UTIL ITY("VAIN" ,$J),VAIN Q:$D(VAN)
	10087	"RTN","VAD PT0",82,0)
	10088	C6 K X F I ="D","E"," L","M","V" I $D(VAIP (I)) S X(I )=VAIP(I)
	10089	"RTN","VAD PT0",83,0)
	10090	S Y=$S('$ D(VAIP("V" )):"VAIP", VAIP("V")' ?1A.E:"VAI P",1:VAIP( "V")) K ^U TILITY(Y,$ J),@Y
	10091	"RTN","VAD PT0",84,0)
	10092	F I="D"," E","L","M" ,"V" I $D( X(I)) S VA IP(I)=X(I)
	10093	"RTN","VAD PT0",85,0)
	10094	K X Q:$D( VAN)
	10095	"RTN","VAD PT0",86,0)
	10096	C7 K ^UTIL ITY("VAEL" ,$J),VAEL Q:$D(VAN)
	10097	"RTN","VAD PT0",87,0)
	10098	C8 K ^UTIL ITY("VAMB" ,$J),VAMB Q:$D(VAN)
	10099	"RTN","VAD PT0",88,0)
	10100	C9 K ^UTIL ITY("VASV" ,$J),VASV Q:$D(VAN)
	10101	"RTN","VAD PT0",89,0)
	10102	C10 K ^UTI LITY("VARP ",$J) Q:$D (VAN)
	10103	"RTN","VAD PT0",90,0)
	10104	C11 K ^UTI LITY("VAEN ",$J) Q:$D (VAN)
	10105	"RTN","VAD PT0",91,0)
	10106	C12 K ^UTI LITY("VASD ",$J) Q
	10107	"RTN","VAD PT0",92,0)
	10108	C13 Q
	10109	"RTN","VAD PT0",93,0)
	10110	;
	10111	"RTN","VAD PT0",94,0)
	10112	; pwc DG* 5.3*914 RS D SPEC #2. 6.1 Storin g Camp Lej eune Infor mation in VistA - ad ded CLV to SS+9
	10113	"RTN","VAD PT0",95,0)
	10114	SS ; 1^ 2 ^ 3^ 4^ 5^ 6^ 7^ 8^ 9^10^11^12 ^13^14^15^ 16^17^18^1 9^20^21^22 ^23^24^25^ 26^27^28
	10115	"RTN","VAD PT0",96,0)
	10116	;;NM^SS^D B^AG^SX^EX ^RE^RA^RP^ MS^ET^RC^P L
	10117	"RTN","VAD PT0",97,0)
	10118	;;BC^BS^F N^MN^MM^OC ^ES^WP
	10119	"RTN","VAD PT0",98,0)
	10120	;;L1^L2^L 3^CI^ST^ZP ^CO^PN^TS^ TE^Z4^CCA^ CL1^CL2^CL 3^CCI^CST^ CZP^CCO^CC S^CCE^CTY^ PR^PC^CT^C PR^CPC^CCT ^CPN
	10121	"RTN","VAD PT0",99,0)
	10122	;;L1^L2^L 3^CI^ST^ZP ^CO^PN^NM^ RE^Z4
	10123	"RTN","VAD PT0",100,0 )
	10124	;;AN^DR^T S^WL^RB^BS ^AD^AT^AF^ PT^AP
	10125	"RTN","VAD PT0",101,0 )
	10126	;;MN^TT^M D^MT^WL^RB ^DR^TS^MF^ BS^RD^PT^A N^LN^PN^NN ^DN^AP^FD
	10127	"RTN","VAD PT0",102,0 )
	10128	;;EL^PS^S C^VT^IN^TY ^CN^ES^MT
	10129	"RTN","VAD PT0",103,0 )
	10130	;;AA^HB^S S^PE^MR^SI ^DI^OR^GI
	10131	"RTN","VAD PT0",104,0 )
	10132	;;VN^AO^I R^PW^CS^S1 ^S2^S3^PH^ CV^OIF^OEF ^UNK^SHD^C LV
	10133	"RTN","VAD PT4")
	10134	0^3^B46948 271^B43698 033
	10135	"RTN","VAD PT4",1,0)
	10136	VADPT4 ;AL B/MRL,MJK, ERC,DIC,PW C - PATIEN T VARIABLE S ;12 DEC 1988 ;10/1 3/10 4:43p m
	10137	"RTN","VAD PT4",2,0)
	10138	;;5.3;Reg istration; 343,342, 528,689,68 8,790,797, 935,914; Aug 13, 19 93;Build 1 73
	10139	"RTN","VAD PT4",3,0)
	10140	7 ;Eligibi lity [ELIG ]
	10141	"RTN","VAD PT4",4,0)
	10142	F I=.15,. 3,.31,.32, .36,.361," INE","TYPE ","VET" S VAX(I)=$S( $D(^DPT(DF N,I)):^(I) ,1:"")
	10143	"RTN","VAD PT4",5,0)
	10144	S VAZ=$P( VAX(.36)," ^",1) S:$D (^DIC(8,+V AZ,0)) VAZ =VAZ_"^"_$ P(^(0),"^" ,1) S @VAV @($P(VAS," ^",1))=VAZ
	10145	"RTN","VAD PT4",6,0)
	10146	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
	10147	"RTN","VAD PT4",7,0)
	10148	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
	10149	"RTN","VAD PT4",8,0)
	10150	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
	10151	"RTN","VAD PT4",9,0)
	10152	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
	10153	"RTN","VAD PT4",10,0)
	10154	I VAZ F I =1:1:6 S @ VAV@($P(VA S,"^",5),I )="" G 71
	10155	"RTN","VAD PT4",11,0)
	10156	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
	10157	"RTN","VAD PT4",12,0)
	10158	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
	10159	"RTN","VAD PT4",13,0)
	10160	S @VAV@($ P(VAS,"^", 5),5)=$P(V AX("INE"), "^",6),@VA V@($P(VAS, "^",5),6)= $P(VAX(.3) ,"^",7)
	10161	"RTN","VAD PT4",14,0)
	10162	71 S VAZ=V AX("TYPE") S:$D(^DG( 391,+VAZ,0 )) VAZ=VAZ _"^"_$P(^( 0),"^",1) S @VAV@($P (VAS,"^",6 ))=VAZ
	10163	"RTN","VAD PT4",15,0)
	10164	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
	10165	"RTN","VAD PT4",16,0)
	10166	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 )
	10167	"RTN","VAD PT4",17,0)
	10168	Q
	10169	"RTN","VAD PT4",18,0)
	10170	;
	10171	"RTN","VAD PT4",19,0)
	10172	8 ;Monetar y Benefits [MB]
	10173	"RTN","VAD PT4",20,0)
	10174	N DGTOTVA
	10175	"RTN","VAD PT4",21,0)
	10176	S @VAV@($ P(VAS,"^", 6))=0 ; SS I no longe r supporte d
	10177	"RTN","VAD PT4",22,0)
	10178	D ALL^DGM TU21(DFN," V",DT,"I")
	10179	"RTN","VAD PT4",23,0)
	10180	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)
	10181	"RTN","VAD PT4",24,0)
	10182	S VAX=$G( ^DPT(DFN,. 362))
	10183	"RTN","VAD PT4",25,0)
	10184	S DGTOTVA =$P(VAX,U, 20)
	10185	"RTN","VAD PT4",26,0)
	10186	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)
	10187	"RTN","VAD PT4",27,0)
	10188	S I=17 S @VAV@($P(V AS,"^",9)) =$S($P(VAX ,"^",17)=" Y":1_U_$P( VAX,U,6),1 :0)
	10189	"RTN","VAD PT4",28,0)
	10190	S VAX=$G( ^DPT(DFN,. 3)) S @VAV @($P(VAS," ^",7))=$S( $P(VAX,"^" ,11)="Y":1 _U_DGTOTVA ,1:0)
	10191	"RTN","VAD PT4",29,0)
	10192	K DGDEP,D GREL,DGINC ,DGINR Q
	10193	"RTN","VAD PT4",30,0)
	10194	;
	10195	"RTN","VAD PT4",31,0)
	10196	9 ;Service informati on
	10197	"RTN","VAD PT4",32,0)
	10198	;pwc - DG 5.3914 R SD SPEC #2 .6.1 Stori ng Camp Le jeune Info rmation
	10199	"RTN","VAD PT4",33,0)
	10200	F I=.32,. 321,.3217, .3291,.52, .53 S VAX( I)=$S($D(^ DPT(DFN,I) ):^(I),1:" ")
	10201	"RTN","VAD PT4",34,0)
	10202	D:$D(^DPT (DFN,.3216 )) MSDS
	10203	"RTN","VAD PT4",35,0)
	10204	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
	10205	"RTN","VAD PT4",36,0)
	10206	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
	10207	"RTN","VAD PT4",37,0)
	10208	;Combat V et
	10209	"RTN","VAD PT4",38,0)
	10210	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
	10211	"RTN","VAD PT4",39,0)
	10212	F I=6,7,8 S @VAV@($ P(VAS,"^", I))="" F V AX(1)=1:1: 6 S @VAV@( $P(VAS,"^" ,I),VAX(1) )=""
	10213	"RTN","VAD PT4",40,0)
	10214	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
	10215	"RTN","VAD PT4",41,0)
	10216	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
	10217	"RTN","VAD PT4",42,0)
	10218	S VAX("N" )=.3291
	10219	"RTN","VAD PT4",43,0)
	10220	F I=6,7,8 I @VAV@($ P(VAS,"^", I)) S VAX( 3)=I,VAX(1 )=I-5,VAX( 4)=6 D 94
	10221	"RTN","VAD PT4",44,0)
	10222	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
	10223	"RTN","VAD PT4",45,0)
	10224	S VAX("N" )=.3215,VA Z=$$GET^DG ENOEIF(DFN ,.VAZ,1)
	10225	"RTN","VAD PT4",46,0)
	10226	;OEF/OIF
	10227	"RTN","VAD PT4",47,0)
	10228	F I=11,12 ,13 S @VAV @(I)=+$G(V AZ($P("OIF ^OEF^UNK", U,I-10),"C OUNT"))
	10229	"RTN","VAD PT4",48,0)
	10230	S VAX(2)= 11
	10231	"RTN","VAD PT4",49,0)
	10232	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
	10233	"RTN","VAD PT4",50,0)
	10234	. N Z
	10235	"RTN","VAD PT4",51,0)
	10236	. 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
	10237	"RTN","VAD PT4",52,0)
	10238	;SHAD - a dded with DG5.3688
	10239	"RTN","VAD PT4",53,0)
	10240	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 ")
	10241	"RTN","VAD PT4",54,0)
	10242	;pwc - DG 5.3914 R SD SPEC #2 .6.1 Stori ng Camp Le jeune Info rmation
	10243	"RTN","VAD PT4",55,0)
	10244	S VAX(3)= 15,VAZ=$S( $P(VAX(.32 17),U,1)=" Y":1,$P(VA X(.3217),U ,1)="N":0, 1:""),@VAV @($P(VAS,U ,VAX(3)))= VAZ I VAZ' ="" D
	10245	"RTN","VAD PT4",56,0)
	10246	. F I1=1, 2,3 S @VAV @($P(VAS,U ,VAX(3)),I 1)=$P(VAX( .3217),U,I 1+1)
	10247	"RTN","VAD PT4",57,0)
	10248	. S X=@VA V@($P(VAS, U,VAX(3)), 1),Y=X I Y ]"" X ^DD( "DD") S @V AV@($P(VAS ,U,VAX(3)) ,1)=X_"^"_ Y ;get in ternal/ext ernal date
	10249	"RTN","VAD PT4",58,0)
	10250	K I1
	10251	"RTN","VAD PT4",59,0)
	10252	Q
	10253	"RTN","VAD PT4",60,0)
	10254	;
	10255	"RTN","VAD PT4",61,0)
	10256	91 ;date f ields
	10257	"RTN","VAD PT4",62,0)
	10258	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:"")
	10259	"RTN","VAD PT4",63,0)
	10260	Q:VAX(3)= 1!(VAX(3)= 9)!(VAX(3) =10)
	10261	"RTN","VAD PT4",64,0)
	10262	;some set s of codes
	10263	"RTN","VAD PT4",65,0)
	10264	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
	10265	"RTN","VAD PT4",66,0)
	10266	I VAX(3)< 4 S X=$P(V AX(.321)," ^",12),VAZ =X D
	10267	"RTN","VAD PT4",67,0)
	10268	.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")
	10269	"RTN","VAD PT4",68,0)
	10270	.S @VAV@( $P(VAS,"^" ,3),2)=VAZ Q
	10271	"RTN","VAD PT4",69,0)
	10272	;POW, com bat locati ons
	10273	"RTN","VAD PT4",70,0)
	10274	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
	10275	"RTN","VAD PT4",71,0)
	10276	;service episodes
	10277	"RTN","VAD PT4",72,0)
	10278	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
	10279	"RTN","VAD PT4",73,0)
	10280	Q
	10281	"RTN","VAD PT4",74,0)
	10282	92 ;pointe rs to Bran ch of Serv ice (23) a nd Type Di scharge (2 5)
	10283	"RTN","VAD PT4",75,0)
	10284	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
	10285	"RTN","VAD PT4",76,0)
	10286	Q
	10287	"RTN","VAD PT4",77,0)
	10288	93 ;Purple Heart
	10289	"RTN","VAD PT4",78,0)
	10290	NEW VAFIL E,VAIENS,V AFLDS,VAAR R,VAI
	10291	"RTN","VAD PT4",79,0)
	10292	S VAFILE= 2,VAIENS=D FN_",",VAF LDS=".532; .533"
	10293	"RTN","VAD PT4",80,0)
	10294	D GETS^DI Q(VAFILE,V AIENS,VAFL DS,"IEN"," VAARR")
	10295	"RTN","VAD PT4",81,0)
	10296	F VAI=1:1 S VAFLDS( VAI)=$P(VA FLDS,";",V AI) Q:VAFL DS(VAI)="" D
	10297	"RTN","VAD PT4",82,0)
	10298	. 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) =""
	10299	"RTN","VAD PT4",83,0)
	10300	. 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") )
	10301	"RTN","VAD PT4",84,0)
	10302	Q
	10303	"RTN","VAD PT4",85,0)
	10304	94 ;more m ilitary se rvice
	10305	"RTN","VAD PT4",86,0)
	10306	N VAARR,V AIENS,VAFL DS
	10307	"RTN","VAD PT4",87,0)
	10308	S VAIENS= DFN_",",VA FLDS=".329 1"_VAX(1)
	10309	"RTN","VAD PT4",88,0)
	10310	D GETS^DI Q(2,VAIENS ,VAFLDS,"I EN","VAARR ")
	10311	"RTN","VAD PT4",89,0)
	10312	I $G(VAAR R(2,VAIENS ,VAFLDS,"I "))'="" D
	10313	"RTN","VAD PT4",90,0)
	10314	. S @VAV@ ($P(VAS,"^ ",VAX(3)), VAX(4))=$G (VAARR(2,V AIENS,VAFL DS,"I"))_" ^"_$G(VAAR R(2,VAIENS ,VAFLDS,"E "))
	10315	"RTN","VAD PT4",91,0)
	10316	Q
	10317	"RTN","VAD PT4",92,0)
	10318	;
	10319	"RTN","VAD PT4",93,0)
	10320	95 ;OEF/OI F
	10321	"RTN","VAD PT4",94,0)
	10322	N X,Y
	10323	"RTN","VAD PT4",95,0)
	10324	I VAX(3)= 1 S $P(@VA V@(VAX(2), VAX,VAX(3) ),U,2)=$$E XTERNAL^DI LFD(2.3215 ,.01,"",Z)
	10325	"RTN","VAD PT4",96,0)
	10326	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
	10327	"RTN","VAD PT4",97,0)
	10328	Q
	10329	"RTN","VAD PT4",98,0)
	10330	;
	10331	"RTN","VAD PT4",99,0)
	10332	MSDS ;Retu rns latest service e pisodes fr om ESR sou rced data
	10333	"RTN","VAD PT4",100,0 )
	10334	N BRANCH, COUNT,COMP ,DA,DONE,D TYP,EDATA, EDATE,I,SD ATE,SERVNO ,SUB
	10335	"RTN","VAD PT4",101,0 )
	10336	S COUNT=0 ,EDATE=""
	10337	"RTN","VAD PT4",102,0 )
	10338	;Clear mi litary ser vice disch arge, bran ch, start, end and n umber info
	10339	"RTN","VAD PT4",103,0 )
	10340	F I=4:1:2 0 S $P(VAX (.32),U,I) =""
	10341	"RTN","VAD PT4",104,0 )
	10342	;Clear mi litary ser vice compo nent info
	10343	"RTN","VAD PT4",105,0 )
	10344	F I=1:1:3 S $P(VAX( .3291),U,I )=""
	10345	"RTN","VAD PT4",106,0 )
	10346	;Scan bac k for thre e most rec ent servic e episodes
	10347	"RTN","VAD PT4",107,0 )
	10348	F S EDAT E=$O(^DPT( DFN,.3216, "B",EDATE) ,-1) Q:'ED ATE D Q: COUNT'<3
	10349	"RTN","VAD PT4",108,0 )
	10350	.S DA=$O( ^DPT(DFN,. 3216,"B",E DATE,0)) Q :'DA
	10351	"RTN","VAD PT4",109,0 )
	10352	.;DJS, sk ip an MSE that has F uture Disc harge Date ; DG5.39 35
	10353	"RTN","VAD PT4",110,0 )
	10354	.S EDATA= $G(^DPT(DF N,.3216,DA ,0)) Q:EDA TA=""!($P( EDATA,U,8) '="")
	10355	"RTN","VAD PT4",111,0 )
	10356	.S COUNT= COUNT+1,SD ATE=$P(EDA TA,U,2)
	10357	"RTN","VAD PT4",112,0 )
	10358	.S BRANCH =$P(EDATA, U,3),COMP= $P(EDATA,U ,4)
	10359	"RTN","VAD PT4",113,0 )
	10360	.S SERVNO =$P(EDATA, U,5),DTYP= $P(EDATA,U ,6)
	10361	"RTN","VAD PT4",114,0 )
	10362	.;SL = 4, SNL = 9 o r SNNL = 1 4
	10363	"RTN","VAD PT4",115,0 )
	10364	.S SUB=(C OUNT*5)-1
	10365	"RTN","VAD PT4",116,0 )
	10366	.S $P(VAX (.32),U,SU B)=DTYP
	10367	"RTN","VAD PT4",117,0 )
	10368	.S $P(VAX (.32),U,SU B+1)=BRANC H
	10369	"RTN","VAD PT4",118,0 )
	10370	.S $P(VAX (.32),U,SU B+2)=EDATE
	10371	"RTN","VAD PT4",119,0 )
	10372	.S $P(VAX (.32),U,SU B+3)=SDATE
	10373	"RTN","VAD PT4",120,0 )
	10374	.S $P(VAX (.32),U,SU B+4)=SERVN O
	10375	"RTN","VAD PT4",121,0 )
	10376	.S $P(VAX (.3291),U, COUNT)=COM P
	10377	"RTN","VAD PT4",122,0 )
	10378	.S:SUB=9 $P(VAX(.32 ),U,19)="Y "
	10379	"RTN","VAD PT4",123,0 )
	10380	.S:SUB=14 $P(VAX(.3 2),U,20)=" Y"
	10381	"RTN","VAD PT4",124,0 )
	10382	Q
	10383	"UP",45,45 .02,-1)
	10384	45^M
	10385	"UP",45,45 .02,0)
	10386	45.02
	10387	"VER")
	10388	8.0^22.2
	10389	"^DD",45,4 5,79.33,0)
	10390	TREATMENT FOR CAMP L EJEUNE^SX^ Y:YES;N:NO ;^70;33^Q
	10391	"^DD",45,4 5,79.33,3)
	10392	Was treatm ent relate d to Camp Lejeune?
	10393	"^DD",45,4 5,79.33,21 ,0)
	10394	^^12^12^31 80125^
	10395	"^DD",45,4 5,79.33,21 ,1,0)
	10396	If the pat ient's dia gnosis is for one or more of t he 15 Camp Lejeune
	10397	"^DD",45,4 5,79.33,21 ,2,0)
	10398	conditions or any se condary co ndition re lated to o ne of thes e 15 Camp
	10399	"^DD",45,4 5,79.33,21 ,3,0)
	10400	Lejeune co nditions, enter 'YES ' or 'Y'. Otherwise answer 'N O' or 'N'.
	10401	"^DD",45,4 5,79.33,21 ,4,0)
	10402
	10403	"^DD",45,4 5,79.33,21 ,5,0)
	10404	1. Esophageal cancer 9.R enal toxic ity
	10405	"^DD",45,4 5,79.33,21 ,6,0)
	10406	2. Lung cance r 10.H epatic ste atosis
	10407	"^DD",45,4 5,79.33,21 ,7,0)
	10408	3. Breast can cer 11.F emale infe rtility
	10409	"^DD",45,4 5,79.33,21 ,8,0)
	10410	4. Bladder ca ncer 12.M iscarriage
	10411	"^DD",45,4 5,79.33,21 ,9,0)
	10412	5. Kidney can cer 13.S cleroderma
	10413	"^DD",45,4 5,79.33,21 ,10,0)
	10414	6. Leukemia 14.N eurobehavi oral effec ts
	10415	"^DD",45,4 5,79.33,21 ,11,0)
	10416	7. Multiple m yeloma 15.N on-Hodgkin 's lymphom a
	10417	"^DD",45,4 5,79.33,21 ,12,0)
	10418	8. Myelodyspl astic synd romes
	10419	"^DD",45,4 5,79.33,"D T")
	10420	3180125
	10421	"^DD",45,4 5.02,33,0)
	10422	TREATMENT FOR CAMP L EJEUNE^SX^ Y:YES;N:NO ^0;33^S DG FLAG=8 D 5 01^DGPTSPQ K:DGER X K DGER,DGF LAG
	10423	"^DD",45,4 5.02,33,.1 )
	10424	WAS TREATM ENT RELATE D TO CAMP LEJEUNE
	10425	"^DD",45,4 5.02,33,3)
	10426	Was treatm ent relate d to Camp Lejeune?
	10427	"^DD",45,4 5.02,33,21 ,0)
	10428	^.001^12^1 2^3181221^ ^^^
	10429	"^DD",45,4 5.02,33,21 ,1,0)
	10430	If the pat ient's dia gnosis is for one or more of t he 15 Camp Lejeune
	10431	"^DD",45,4 5.02,33,21 ,2,0)
	10432	conditions or any se condary co ndition re lated to o ne of thes e 15 Camp
	10433	"^DD",45,4 5.02,33,21 ,3,0)
	10434	Lejeune co nditions, enter 'YES ' or '1'. Otherwise answer 'N O' or '0'.
	10435	"^DD",45,4 5.02,33,21 ,4,0)
	10436
	10437	"^DD",45,4 5.02,33,21 ,5,0)
	10438	1. Esophageal cancer 9.R enal toxic ity
	10439	"^DD",45,4 5.02,33,21 ,6,0)
	10440	2. Lung cance r 10.H epatic ste atosis
	10441	"^DD",45,4 5.02,33,21 ,7,0)
	10442	3. Breast can cer 11.F emale infe rtility
	10443	"^DD",45,4 5.02,33,21 ,8,0)
	10444	4. Bladder ca ncer 12.M iscarriage
	10445	"^DD",45,4 5.02,33,21 ,9,0)
	10446	5. Kidney can cer 13.S cleroderma
	10447	"^DD",45,4 5.02,33,21 ,10,0)
	10448	6. Leukemia 14.N eurobehavi oral effec ts
	10449	"^DD",45,4 5.02,33,21 ,11,0)
	10450	7. Multiple m yeloma 15.N on-Hodgkin 's lymphom a
	10451	"^DD",45,4 5.02,33,21 ,12,0)
	10452	8. Myelodyspl astic synd romes
	10453	"^DD",45,4 5.02,33,"D T")
	10454	3190121
	10455	"^DD",46.1 ,46.1,.1,0 )
	10456	TREATMENT FOR CAMP L EJEUNE^S^1 :YES;0:NO; ^0;10^Q
	10457	"^DD",46.1 ,46.1,.1,3 )
	10458	Was treatm ent relate d to Camp Lejeune?
	10459	"^DD",46.1 ,46.1,.1,2 1,0)
	10460	^^12^12^31 80125^
	10461	"^DD",46.1 ,46.1,.1,2 1,1,0)
	10462	If the pat ient's dia gnosis is for one or more of t he 15 Camp Lejeune
	10463	"^DD",46.1 ,46.1,.1,2 1,2,0)
	10464	conditions or any se condary co ndition re lated to o ne of thes e 15 Camp
	10465	"^DD",46.1 ,46.1,.1,2 1,3,0)
	10466	Lejeune co nditions, enter 'YES ' or 'Y'. Otherwise answer 'N O' or 'N'.
	10467	"^DD",46.1 ,46.1,.1,2 1,4,0)
	10468
	10469	"^DD",46.1 ,46.1,.1,2 1,5,0)
	10470	1. Esophageal cancer 9.R enal toxic ity
	10471	"^DD",46.1 ,46.1,.1,2 1,6,0)
	10472	2. Lung cance r 10.H epatic ste atosis
	10473	"^DD",46.1 ,46.1,.1,2 1,7,0)
	10474	3. Breast can cer 11.F emale infe rtility
	10475	"^DD",46.1 ,46.1,.1,2 1,8,0)
	10476	4. Bladder ca ncer 12.M iscarriage
	10477	"^DD",46.1 ,46.1,.1,2 1,9,0)
	10478	5. Kidney can cer 13.S cleroderma
	10479	"^DD",46.1 ,46.1,.1,2 1,10,0)
	10480	6. Leukemia 14.N eurobehavi oral effec ts
	10481	"^DD",46.1 ,46.1,.1,2 1,11,0)
	10482	7. Multiple m yeloma 15.N on-Hodgkin 's lymphom a
	10483	"^DD",46.1 ,46.1,.1,2 1,12,0)
	10484	8. Myelodyspl astic synd romes
	10485	"^DD",46.1 ,46.1,.1," DT")
	10486	3180125
	10487	"^DD",405, 405,29,0)
	10488	TREATMENT FOR CAMP L EJEUNE^S^Y :YES;N:NO; ^0;29^Q
	10489	"^DD",405, 405,29,1,0 )
	10490	^.1
	10491	"^DD",405, 405,29,1,1 ,0)
	10492	^^TRIGGER^ 405^103
	10493	"^DD",405, 405,29,1,1 ,1)
	10494	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(1)=$S( $D(^DGPM(D 0,"USR")): ^("USR"),1 :"") S X=$ P(Y(1),U,4 ),X=X S DI U=X K Y S X=DIV N %I ,%H,% D NO W^%DTC S X =% S DIH=$ G(^DGPM(DI V(0),"USR" )),DIV=X S $P(^("USR "),U,4)=DI V,DIH=405, DIG=103 D ^DICR
	10495	"^DD",405, 405,29,1,1 ,2)
	10496	K DIV S DI V=X,D0=DA, DIV(0)=D0 S Y(1)=$S( $D(^DGPM(D 0,"USR")): ^("USR"),1 :"") S X=$ P(Y(1),U,4 ),X=X S DI U=X K Y S X=DIV N %I ,%H,% D NO W^%DTC S X =% S DIH=$ G(^DGPM(DI V(0),"USR" )),DIV=X S $P(^("USR "),U,4)=DI V,DIH=405, DIG=103 D ^DICR
	10497	"^DD",405, 405,29,1,1 ,"%D",0)
	10498	^.101^3^3^ 3181109^^
	10499	"^DD",405, 405,29,1,1 ,"%D",1,0)
	10500	Any time t he TREATME NT FOR CAM P LEJEUNE (#29) fiel d is chang ed this
	10501	"^DD",405, 405,29,1,1 ,"%D",2,0)
	10502	trigger cr oss refere nce will s et the LAS T EDITED O N field (# 103)
	10503	"^DD",405, 405,29,1,1 ,"%D",3,0)
	10504	to the cur rent date/ time.
	10505	"^DD",405, 405,29,1,1 ,"CREATE V ALUE")
	10506	NOW
	10507	"^DD",405, 405,29,1,1 ,"DELETE V ALUE")
	10508	NOW
	10509	"^DD",405, 405,29,1,1 ,"FIELD")
	10510	LAST EDITE D ON
	10511	"^DD",405, 405,29,3)
	10512	Enter 'Y' for YES if treatment is for a Camp Lejeu ne conditi on.
	10513	"^DD",405, 405,29,21, 0)
	10514	^.001^12^1 2^3181228^ ^^^
	10515	"^DD",405, 405,29,21, 1,0)
	10516	If the pat ient's dia gnosis is for one or more of t he 15 Camp Lejeune
	10517	"^DD",405, 405,29,21, 2,0)
	10518	conditions or any se condary co ndition re lated to o ne of thes e 15 Camp
	10519	"^DD",405, 405,29,21, 3,0)
	10520	Lejeune co nditions, enter 'YES ' or 'Y'. Otherwise answer 'N O' or 'N'.
	10521	"^DD",405, 405,29,21, 4,0)
	10522
	10523	"^DD",405, 405,29,21, 5,0)
	10524	1. Esophageal cancer 9.R enal toxic ity
	10525	"^DD",405, 405,29,21, 6,0)
	10526	2. Lung cance r 10.H epatic ste atosis
	10527	"^DD",405, 405,29,21, 7,0)
	10528	3. Breast can cer 11.F emale infe rtility
	10529	"^DD",405, 405,29,21, 8,0)
	10530	4. Bladder ca ncer 12.M iscarriage
	10531	"^DD",405, 405,29,21, 9,0)
	10532	5. Kidney can cer 13.S cleroderma
	10533	"^DD",405, 405,29,21, 10,0)
	10534	6. Leukemia 14.N eurobehavi oral effec ts
	10535	"^DD",405, 405,29,21, 11,0)
	10536	7. Multiple m yeloma 15.N on-Hodgkin 's lymphom a
	10537	"^DD",405, 405,29,21, 12,0)
	10538	8. Myelodyspl astic synd romes
	10539	"^DD",405, 405,29,"DT ")
	10540	3181228
	10541	"BLD",1132 8,6)
	10542	35^
	10543	$END KID D G5.3914
	10544