44. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 5/13/2019 2:40:18 PM Central 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.

44.1 Files compared

#	Location	File	Last Modified
1	C:\AraxisMergeCompare\Pri_un\MPDU\Patches	XU_8_689.KID	Mon May 6 12:14:13 2019 UTC
2	C:\AraxisMergeCompare\Pri_re\MPDU\MPDU\Patches	XU_8_689.KID	Tue May 7 13:23:06 2019 UTC

44.2 Comparison summary

Description	Between Files 1 and 2
Description	Text Blocks	Lines
Unchanged	9	4760
Changed	8	16
Inserted	0	0
Removed	0	0

44.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

44.4 Active regular expressions

No regular expressions were active.

44.5 Comparison detail

	1	KIDS Distr ibution sa ved on Feb 28, 2019@ 15:05:15
	2	XU8689
	3	KIDS:X U8.0689^
	4
	5	INSTALL NAME
	6	XU8.0689
	7	"BLD",1035 0,0)
	8	XU8.0689 ^KERNEL^0^ 3190228^y
	9	"BLD",1035 0,1,0)
	10	^^59^59^31 90208^
	11	"BLD",1035 0,1,1,0)
	12	The Clinic al Ancilla ry Service s (CAS) - Medication Permissio n/Dispensi ng
	13	"BLD",1035 0,1,2,0)
	14	Updates (M PDU) proje ct provide s the abil ity to sup port multi ple DEA
	15	"BLD",1035 0,1,3,0)
	16	Numbers fo r a user.
	17	"BLD",1035 0,1,4,0)
	18
	19	"BLD",1035 0,1,5,0)
	20	This patch XU8689 is part of a group o f patches for this e nhancement
	21	"BLD",1035 0,1,6,0)
	22	and must b e installe d after co mpletion o f installa tion of pa tches
	23	"BLD",1035 0,1,7,0)
	24	XU8688 a nd PSO75 29. The fo llowing ot her patche s for this enhanceme nt
	25	"BLD",1035 0,1,8,0)
	26	will be re leased in the future and inclu des: OR3 506, PSO7 545,
	27	"BLD",1035 0,1,9,0)
	28	PSJ5372, OR3488 and OR34 99.
	29	"BLD",1035 0,1,10,0)
	30
	31	"BLD",1035 0,1,11,0)
	32	This patch XU8689 has the fo llowing en hancements :
	33	"BLD",1035 0,1,12,0)
	34
	35	"BLD",1035 0,1,13,0)
	36	1. The opt ion 'Alloc ation of S ecurity Ke ys' [XUKEY DEALL], 'D e-ALLOCATI ON
	37	"BLD",1035 0,1,14,0)
	38	OF SECURIT Y KEYS' [X QKEYDEALL] has been modified t o prevent the alloca tion
	39	"BLD",1035 0,1,15,0)
	40	or de-allo cation of the PSDRPH key. The allocation of PSDRPH is only
	41	"BLD",1035 0,1,16,0)
	42	permitted through a pathway th at is audi table by u sing the o ption
	43	"BLD",1035 0,1,17,0)
	44	'Allocate/ De-allocat e of PSDRP H Key' [PS O EPCS PSD RPH KEY], which is
	45	"BLD",1035 0,1,18,0)
	46	transporte d in patch PSO7545 as part o f this pro ject.
	47	"BLD",1035 0,1,19,0)
	48
	49	"BLD",1035 0,1,20,0)
	50	This patch also modi fies the I NTEGRATION CONTROL R EGISTRATIO NS (ICR)
	51	"BLD",1035 0,1,21,0)
	52	#2343 line tags DEA, DETOX, SD EA, VDA an d adds new line tags PRDEA, PR XDT
	53	"BLD",1035 0,1,22,0)
	54	and PRSCH.
	55	"BLD",1035 0,1,23,0)
	56
	57	"BLD",1035 0,1,24,0)
	58	The follow ing routin es have be en modifie d to use t he new App lication
	59	"BLD",1035 0,1,25,0)
	60	Program In terface (A PI) $$PRDE A^XUSER wh erever the DEA# fiel d (#53.2) of
	61	"BLD",1035 0,1,26,0)
	62	the NEW PE RSON file (#200) is referenced .
	63	"BLD",1035 0,1,27,0)
	64
	65	"BLD",1035 0,1,28,0)
	66	XUPSPRA
	67	"BLD",1035 0,1,29,0)
	68	XUSNPIX1
	69	"BLD",1035 0,1,30,0)
	70
	71	"BLD",1035 0,1,31,0)
	72	Note:
	73	"BLD",1035 0,1,32,0)
	74	A pre-inst all routin e (PRE^XU8 P689) will delete FI ELD EDITED field (#. 03)
	75	"BLD",1035 0,1,33,0)
	76	of the XUE PCS DATA F ILE (#8991 .6). A mod ified copy of this f ield will
	77	"BLD",1035 0,1,34,0)
	78	re-install ed by this patch.
	79	"BLD",1035 0,1,35,0)
	80
	81	"BLD",1035 0,1,36,0)
	82	As part of this proj ect the fo llowing XU EPCS Kern el namespa ce options
	83	"BLD",1035 0,1,37,0)
	84	are moved over to PS O EPCS Out patient Ph armacy nam espace, th erefore th e
	85	"BLD",1035 0,1,38,0)
	86	post-insta ll routine will mark the follo wing XU EP CS name sp ace option s
	87	"BLD",1035 0,1,39,0)
	88	as ""PLACE D OUT OF O RDER BY XU 8689".
	89	"BLD",1035 0,1,40,0)
	90
	91	"BLD",1035 0,1,41,0)
	92	Print DEA Expiration Date Null [XU EPCS EXP DATE]
	93	"BLD",1035 0,1,42,0)
	94	Print DISU SER DEA Ex piration D ate Null [XU EPCS D ISUSER EXP DATE]
	95	"BLD",1035 0,1,43,0)
	96	Print DEA Expiration Date Expi res 30 day s [XU EPCS XDATE EXP IRES]
	97	"BLD",1035 0,1,44,0)
	98	Print DISU SER DEA Ex piration D ate Expire s 30 days [XU EPCS D ISUSER XDA TE
	99	"BLD",1035 0,1,45,0)
	100	EXPI RES]
	101	"BLD",1035 0,1,46,0)
	102	Print Pres cribers wi th Privile ges [XU EP CS PRIVS]
	103	"BLD",1035 0,1,47,0)
	104	Print DISU SER Prescr ibers with Privilege s [XU EPCS DISUSER P RIVS]
	105	"BLD",1035 0,1,48,0)
	106	Print PSDR PH Key Hol ders [XU E PCS PSDRPH ]
	107	"BLD",1035 0,1,49,0)
	108	Print Sett ing Parame ters Privi leges [XU EPCS SET P ARMS]
	109	"BLD",1035 0,1,50,0)
	110	Print Audi ts for Pre scriber Ed iting [XU EPCS PRINT EDIT AUDI T]
	111	"BLD",1035 0,1,51,0)
	112	Task Chang es to DEA Prescribin g Privileg es Report [XU EPCS L OGICAL ACC ESS]
	113	"BLD",1035 0,1,52,0)
	114	Task Alloc ation Audi t of PSDRP H Key Repo rt [XU EPC S PSDRPH A UDIT]
	115	"BLD",1035 0,1,53,0)
	116	Allocate/D e-Allocate of PSDRPH Key [XU E PCS PSDRPH KEY]
	117	"BLD",1035 0,1,54,0)
	118	Edit Facil ity DEA# a nd Expirat ion Date [ XU EPCS ED IT DEA# AN D XDATE]
	119	"BLD",1035 0,1,55,0)
	120	ePCS Edit Prescriber Data [XU EPCS EDIT DATA]
	121	"BLD",1035 0,1,56,0)
	122	ePCS DEA U tility Fun ctions [XU EPCS UTIL ITY FUNCTI ONS]
	123	"BLD",1035 0,1,57,0)
	124
	125	"BLD",1035 0,1,58,0)
	126	The routin e XU8P689 will be au tomaticall y deleted from your system
	127	"BLD",1035 0,1,59,0)
	128	upon compl etion of t he install ation.
	129	"BLD",1035 0,4,0)
	130	^9.64PA^89 91.6^1
	131	"BLD",1035 0,4,8991.6 ,0)
	132	8991.6
	133	"BLD",1035 0,4,8991.6 ,2,0)
	134	^9.641^899 1.6^1
	135	"BLD",1035 0,4,8991.6 ,2,8991.6, 0)
	136	XUEPCS DAT A (File-t op level)
	137	"BLD",1035 0,4,8991.6 ,2,8991.6, 1,0)
	138	^9.6411^.0 3^1
	139	"BLD",1035 0,4,8991.6 ,2,8991.6, 1,.03,0)
	140	FIELD EDIT ED
	141	"BLD",1035 0,4,8991.6 ,222)
	142	y^y^p^^^^n ^^n
	143	"BLD",1035 0,4,8991.6 ,224)
	144
	145	"BLD",1035 0,4,"APDD" ,8991.6,89 91.6)
	146
	147	"BLD",1035 0,4,"APDD" ,8991.6,89 91.6,.03)
	148
	149	"BLD",1035 0,4,"B",89 91.6,8991. 6)
	150
	151	"BLD",1035 0,6.3)
	152	28
	153	"BLD",1035 0,"ABPKG")
	154	n
	155	"BLD",1035 0,"INI")
	156	PRE^XU8P68 9
	157	"BLD",1035 0,"INID")
	158	^y^y
	159	"BLD",1035 0,"INIT")
	160	POST^XU8P6 89
	161	"BLD",1035 0,"KRN",0)
	162	^9.67PA^77 9.2^20
	163	"BLD",1035 0,"KRN",.4 ,0)
	164	.4
	165	"BLD",1035 0,"KRN",.4 01,0)
	166	.401
	167	"BLD",1035 0,"KRN",.4 02,0)
	168	.402
	169	"BLD",1035 0,"KRN",.4 03,0)
	170	.403
	171	"BLD",1035 0,"KRN",.5 ,0)
	172	.5
	173	"BLD",1035 0,"KRN",.8 4,0)
	174	.84
	175	"BLD",1035 0,"KRN",3. 6,0)
	176	3.6
	177	"BLD",1035 0,"KRN",3. 8,0)
	178	3.8
	179	"BLD",1035 0,"KRN",9. 2,0)
	180	9.2
	181	"BLD",1035 0,"KRN",9. 8,0)
	182	9.8
	183	"BLD",1035 0,"KRN",9. 8,"NM",0)
	184	^9.68A^9^4
	185	"BLD",1035 0,"KRN",9. 8,"NM",6,0 )
	186	XUSER^^0^B 215823182
	187	"BLD",1035 0,"KRN",9. 8,"NM",7,0 )
	188	XQ6^^0^B23 032498
	189	"BLD",1035 0,"KRN",9. 8,"NM",8,0 )
	190	XUPSPRA^^0 ^B1135275
	191	"BLD",1035 0,"KRN",9. 8,"NM",9,0 )
	192	XUSNPIX1^^ 0^B1721282 81
	193	"BLD",1035 0,"KRN",9. 8,"NM","B" ,"XQ6",7)
	194
	195	"BLD",1035 0,"KRN",9. 8,"NM","B" ,"XUPSPRA" ,8)
	196
	197	"BLD",1035 0,"KRN",9. 8,"NM","B" ,"XUSER",6 )
	198
	199	"BLD",1035 0,"KRN",9. 8,"NM","B" ,"XUSNPIX1 ",9)
	200
	201	"BLD",1035 0,"KRN",19 ,0)
	202	19
	203	"BLD",1035 0,"KRN",19 ,"NM",0)
	204	^9.68A^^0
	205	"BLD",1035 0,"KRN",19 .1,0)
	206	19.1
	207	"BLD",1035 0,"KRN",10 1,0)
	208	101
	209	"BLD",1035 0,"KRN",40 9.61,0)
	210	409.61
	211	"BLD",1035 0,"KRN",77 1,0)
	212	771
	213	"BLD",1035 0,"KRN",77 9.2,0)
	214	779.2
	215	"BLD",1035 0,"KRN",87 0,0)
	216	870
	217	"BLD",1035 0,"KRN",89 89.51,0)
	218	8989.51
	219	"BLD",1035 0,"KRN",89 89.51,"NM" ,0)
	220	^9.68A^^0
	221	"BLD",1035 0,"KRN",89 89.52,0)
	222	8989.52
	223	"BLD",1035 0,"KRN",89 94,0)
	224	8994
	225	"BLD",1035 0,"KRN","B ",.4,.4)
	226
	227	"BLD",1035 0,"KRN","B ",.401,.40 1)
	228
	229	"BLD",1035 0,"KRN","B ",.402,.40 2)
	230
	231	"BLD",1035 0,"KRN","B ",.403,.40 3)
	232
	233	"BLD",1035 0,"KRN","B ",.5,.5)
	234
	235	"BLD",1035 0,"KRN","B ",.84,.84)
	236
	237	"BLD",1035 0,"KRN","B ",3.6,3.6)
	238
	239	"BLD",1035 0,"KRN","B ",3.8,3.8)
	240
	241	"BLD",1035 0,"KRN","B ",9.2,9.2)
	242
	243	"BLD",1035 0,"KRN","B ",9.8,9.8)
	244
	245	"BLD",1035 0,"KRN","B ",19,19)
	246
	247	"BLD",1035 0,"KRN","B ",19.1,19. 1)
	248
	249	"BLD",1035 0,"KRN","B ",101,101)
	250
	251	"BLD",1035 0,"KRN","B ",409.61,4 09.61)
	252
	253	"BLD",1035 0,"KRN","B ",771,771)
	254
	255	"BLD",1035 0,"KRN","B ",779.2,77 9.2)
	256
	257	"BLD",1035 0,"KRN","B ",870,870)
	258
	259	"BLD",1035 0,"KRN","B ",8989.51, 8989.51)
	260
	261	"BLD",1035 0,"KRN","B ",8989.52, 8989.52)
	262
	263	"BLD",1035 0,"KRN","B ",8994,899 4)
	264
	265	"BLD",1035 0,"QDEF")
	266	^^^^NO^^^^ NO^^NO
	267	"BLD",1035 0,"QUES",0 )
	268	^9.62^^
	269	"BLD",1035 0,"REQB",0 )
	270	^9.611^4^4
	271	"BLD",1035 0,"REQB",1 ,0)
	272	XU8.0688 ^2
	273	"BLD",1035 0,"REQB",2 ,0)
	274	XU8.0642 ^2
	275	"BLD",1035 0,"REQB",3 ,0)
	276	XU8.0551 ^2
	277	"BLD",1035 0,"REQB",4 ,0)
	278	XU8.0548 ^2
	279	"BLD",1035 0,"REQB"," B","XU8.0 548",4)
	280
	281	"BLD",1035 0,"REQB"," B","XU8.0 551",3)
	282
	283	"BLD",1035 0,"REQB"," B","XU8.0 642",2)
	284
	285	"BLD",1035 0,"REQB"," B","XU8.0 688",1)
	286
	287	"FIA",8991 .6)
	288	XUEPCS DAT A
	289	"FIA",8991 .6,0)
	290	^XTV(8991. 6,
	291	"FIA",8991 .6,0,0)
	292	8991.6P
	293	"FIA",8991 .6,0,1)
	294	y^y^p^^^^n ^^n
	295	"FIA",8991 .6,0,10)
	296
	297	"FIA",8991 .6,0,11)
	298
	299	"FIA",8991 .6,0,"RLRO ")
	300
	301	"FIA",8991 .6,0,"VR")
	302	8.0^XU
	303	"FIA",8991 .6,8991.6)
	304	1
	305	"FIA",8991 .6,8991.6, .03)
	306
	307	"INI")
	308	PRE^XU8P68 9
	309	"INIT")
	310	POST^XU8P6 89
	311	"MBREQ")
	312	0
	313	"PKG",173, -1)
	314	1^1
	315	"PKG",173, 0)
	316	KERNEL^XU^ SIGN-ON, S ECURITY, M ENU DRIVER , DEVICES, TASKMAN^
	317	"PKG",173, 20,0)
	318	^9.402P^2^ 2
	319	"PKG",173, 20,1,0)
	320	200^^XDRM2 00N
	321	"PKG",173, 20,1,1)
	322
	323	"PKG",173, 20,2,0)
	324	2^^RGDRM03
	325	"PKG",173, 20,2,1)
	326
	327	"PKG",173, 20,"B",2,2 )
	328
	329	"PKG",173, 20,"B",200 ,1)
	330
	331	"PKG",173, 22,0)
	332	^9.49I^1^1
	333	"PKG",173, 22,1,0)
	334	8.0^295070 3^2951015^ 1
	335	"PKG",173, 22,1,"PAH" ,1,0)
	336	689^319022 8
	337	"PKG",173, 22,1,"PAH" ,1,1,0)
	338	^^59^59^31 90228
	339	"PKG",173, 22,1,"PAH" ,1,1,1,0)
	340	The Clinic al Ancilla ry Service s (CAS) - Medication Permissio n/Dispensi ng
	341	"PKG",173, 22,1,"PAH" ,1,1,2,0)
	342	Updates (M PDU) proje ct provide s the abil ity to sup port multi ple DEA
	343	"PKG",173, 22,1,"PAH" ,1,1,3,0)
	344	Numbers fo r a user.
	345	"PKG",173, 22,1,"PAH" ,1,1,4,0)
	346
	347	"PKG",173, 22,1,"PAH" ,1,1,5,0)
	348	This patch XU8689 is part of a group o f patches for this e nhancement
	349	"PKG",173, 22,1,"PAH" ,1,1,6,0)
	350	and must b e installe d after co mpletion o f installa tion of pa tches
	351	"PKG",173, 22,1,"PAH" ,1,1,7,0)
	352	XU8688 a nd PSO75 29. The fo llowing ot her patche s for this enhanceme nt
	353	"PKG",173, 22,1,"PAH" ,1,1,8,0)
	354	will be re leased in the future and inclu des: OR3 506, PSO7 545,
	355	"PKG",173, 22,1,"PAH" ,1,1,9,0)
	356	PSJ5372, OR3488 and OR34 99.
	357	"PKG",173, 22,1,"PAH" ,1,1,10,0)
	358
	359	"PKG",173, 22,1,"PAH" ,1,1,11,0)
	360	This patch XU8689 has the fo llowing en hancements :
	361	"PKG",173, 22,1,"PAH" ,1,1,12,0)
	362
	363	"PKG",173, 22,1,"PAH" ,1,1,13,0)
	364	1. The opt ion 'Alloc ation of S ecurity Ke ys' [XUKEY DEALL], 'D e-ALLOCATI ON
	365	"PKG",173, 22,1,"PAH" ,1,1,14,0)
	366	OF SECURIT Y KEYS' [X QKEYDEALL] has been modified t o prevent the alloca tion
	367	"PKG",173, 22,1,"PAH" ,1,1,15,0)
	368	or de-allo cation of the PSDRPH key. The allocation of PSDRPH is only
	369	"PKG",173, 22,1,"PAH" ,1,1,16,0)
	370	permitted through a pathway th at is audi table by u sing the o ption
	371	"PKG",173, 22,1,"PAH" ,1,1,17,0)
	372	'Allocate/ De-allocat e of PSDRP H Key' [PS O EPCS PSD RPH KEY], which is
	373	"PKG",173, 22,1,"PAH" ,1,1,18,0)
	374	transporte d in patch PSO7545 as part o f this pro ject.
	375	"PKG",173, 22,1,"PAH" ,1,1,19,0)
	376
	377	"PKG",173, 22,1,"PAH" ,1,1,20,0)
	378	This patch also modi fies the I NTEGRATION CONTROL R EGISTRATIO NS (ICR)
	379	"PKG",173, 22,1,"PAH" ,1,1,21,0)
	380	#2343 line tags DEA, DETOX, SD EA, VDA an d adds new line tags PRDEA, PR XDT
	381	"PKG",173, 22,1,"PAH" ,1,1,22,0)
	382	and PRSCH.
	383	"PKG",173, 22,1,"PAH" ,1,1,23,0)
	384
	385	"PKG",173, 22,1,"PAH" ,1,1,24,0)
	386	The follow ing routin es have be en modifie d to use t he new App lication
	387	"PKG",173, 22,1,"PAH" ,1,1,25,0)
	388	Program In terface (A PI) $$PRDE A^XUSER wh erever the DEA# fiel d (#53.2) of
	389	"PKG",173, 22,1,"PAH" ,1,1,26,0)
	390	the NEW PE RSON file (#200) is referenced .
	391	"PKG",173, 22,1,"PAH" ,1,1,27,0)
	392
	393	"PKG",173, 22,1,"PAH" ,1,1,28,0)
	394	XUPSPRA
	395	"PKG",173, 22,1,"PAH" ,1,1,29,0)
	396	XUSNPIX1
	397	"PKG",173, 22,1,"PAH" ,1,1,30,0)
	398
	399	"PKG",173, 22,1,"PAH" ,1,1,31,0)
	400	Note:
	401	"PKG",173, 22,1,"PAH" ,1,1,32,0)
	402	A pre-inst all routin e (PRE^XU8 P689) will delete FI ELD EDITED field (#. 03)
	403	"PKG",173, 22,1,"PAH" ,1,1,33,0)
	404	of the XUE PCS DATA F ILE (#8991 .6). A mod ified copy of this f ield will
	405	"PKG",173, 22,1,"PAH" ,1,1,34,0)
	406	re-install ed by this patch.
	407	"PKG",173, 22,1,"PAH" ,1,1,35,0)
	408
	409	"PKG",173, 22,1,"PAH" ,1,1,36,0)
	410	As part of this proj ect the fo llowing XU EPCS Kern el namespa ce options
	411	"PKG",173, 22,1,"PAH" ,1,1,37,0)
	412	are moved over to PS O EPCS Out patient Ph armacy nam espace, th erefore th e
	413	"PKG",173, 22,1,"PAH" ,1,1,38,0)
	414	post-insta ll routine will mark the follo wing XU EP CS name sp ace option s
	415	"PKG",173, 22,1,"PAH" ,1,1,39,0)
	416	as ""PLACE D OUT OF O RDER BY XU 8689".
	417	"PKG",173, 22,1,"PAH" ,1,1,40,0)
	418
	419	"PKG",173, 22,1,"PAH" ,1,1,41,0)
	420	Print DEA Expiration Date Null [XU EPCS EXP DATE]
	421	"PKG",173, 22,1,"PAH" ,1,1,42,0)
	422	Print DISU SER DEA Ex piration D ate Null [XU EPCS D ISUSER EXP DATE]
	423	"PKG",173, 22,1,"PAH" ,1,1,43,0)
	424	Print DEA Expiration Date Expi res 30 day s [XU EPCS XDATE EXP IRES]
	425	"PKG",173, 22,1,"PAH" ,1,1,44,0)
	426	Print DISU SER DEA Ex piration D ate Expire s 30 days [XU EPCS D ISUSER XDA TE
	427	"PKG",173, 22,1,"PAH" ,1,1,45,0)
	428	EXPI RES]
	429	"PKG",173, 22,1,"PAH" ,1,1,46,0)
	430	Print Pres cribers wi th Privile ges [XU EP CS PRIVS]
	431	"PKG",173, 22,1,"PAH" ,1,1,47,0)
	432	Print DISU SER Prescr ibers with Privilege s [XU EPCS DISUSER P RIVS]
	433	"PKG",173, 22,1,"PAH" ,1,1,48,0)
	434	Print PSDR PH Key Hol ders [XU E PCS PSDRPH ]
	435	"PKG",173, 22,1,"PAH" ,1,1,49,0)
	436	Print Sett ing Parame ters Privi leges [XU EPCS SET P ARMS]
	437	"PKG",173, 22,1,"PAH" ,1,1,50,0)
	438	Print Audi ts for Pre scriber Ed iting [XU EPCS PRINT EDIT AUDI T]
	439	"PKG",173, 22,1,"PAH" ,1,1,51,0)
	440	Task Chang es to DEA Prescribin g Privileg es Report [XU EPCS L OGICAL ACC ESS]
	441	"PKG",173, 22,1,"PAH" ,1,1,52,0)
	442	Task Alloc ation Audi t of PSDRP H Key Repo rt [XU EPC S PSDRPH A UDIT]
	443	"PKG",173, 22,1,"PAH" ,1,1,53,0)
	444	Allocate/D e-Allocate of PSDRPH Key [XU E PCS PSDRPH KEY]
	445	"PKG",173, 22,1,"PAH" ,1,1,54,0)
	446	Edit Facil ity DEA# a nd Expirat ion Date [ XU EPCS ED IT DEA# AN D XDATE]
	447	"PKG",173, 22,1,"PAH" ,1,1,55,0)
	448	ePCS Edit Prescriber Data [XU EPCS EDIT DATA]
	449	"PKG",173, 22,1,"PAH" ,1,1,56,0)
	450	ePCS DEA U tility Fun ctions [XU EPCS UTIL ITY FUNCTI ONS]
	451	"PKG",173, 22,1,"PAH" ,1,1,57,0)
	452
	453	"PKG",173, 22,1,"PAH" ,1,1,58,0)
	454	The routin e XU8P689 will be au tomaticall y deleted from your system
	455	"PKG",173, 22,1,"PAH" ,1,1,59,0)
	456	upon compl etion of t he install ation.
	457	"QUES","XP F1",0)
	458	Y
	459	"QUES","XP F1","??")
	460	^D REP^XPD H
	461	"QUES","XP F1","A")
	462	Shall I wr ite over y our \|FLAG\| File
	463	"QUES","XP F1","B")
	464	YES
	465	"QUES","XP F1","M")
	466	D XPF1^XPD IQ
	467	"QUES","XP F2",0)
	468	Y
	469	"QUES","XP F2","??")
	470	^D DTA^XPD H
	471	"QUES","XP F2","A")
	472	Want my da ta \|FLAG\| yours
	473	"QUES","XP F2","B")
	474	YES
	475	"QUES","XP F2","M")
	476	D XPF2^XPD IQ
	477	"QUES","XP I1",0)
	478	YO
	479	"QUES","XP I1","??")
	480	^D INHIBIT ^XPDH
	481	"QUES","XP I1","A")
	482	Want KIDS to INHIBIT LOGONs du ring the i nstall
	483	"QUES","XP I1","B")
	484	NO
	485	"QUES","XP I1","M")
	486	D XPI1^XPD IQ
	487	"QUES","XP M1",0)
	488	PO^VA(200, :EM
	489	"QUES","XP M1","??")
	490	^D MG^XPDH
	491	"QUES","XP M1","A")
	492	Enter the Coordinato r for Mail Group '\|F LAG\|'
	493	"QUES","XP M1","B")
	494
	495	"QUES","XP M1","M")
	496	D XPM1^XPD IQ
	497	"QUES","XP O1",0)
	498	Y
	499	"QUES","XP O1","??")
	500	^D MENU^XP DH
	501	"QUES","XP O1","A")
	502	Want KIDS to Rebuild Menu Tree s Upon Com pletion of Install
	503	"QUES","XP O1","B")
	504	NO
	505	"QUES","XP O1","M")
	506	D XPO1^XPD IQ
	507	"QUES","XP Z1",0)
	508	Y
	509	"QUES","XP Z1","??")
	510	^D OPT^XPD H
	511	"QUES","XP Z1","A")
	512	Want to DI SABLE Sche duled Opti ons, Menu Options, a nd Protoco ls
	513	"QUES","XP Z1","B")
	514	NO
	515	"QUES","XP Z1","M")
	516	D XPZ1^XPD IQ
	517	"QUES","XP Z2",0)
	518	Y
	519	"QUES","XP Z2","??")
	520	^D RTN^XPD H
	521	"QUES","XP Z2","A")
	522	Want to MO VE routine s to other CPUs
	523	"QUES","XP Z2","B")
	524	NO
	525	"QUES","XP Z2","M")
	526	D XPZ2^XPD IQ
	527	"RTN")
	528	5
	529	"RTN","XQ6 ")
	530	0^7^B23032 498
	531	"RTN","XQ6 ",1,0)
	532	XQ6 ;SEA/A MF,SLC/CJS - BULK KEY DISTRIBUT ION ;2/14/ 95 12:47
	533	"RTN","XQ6 ",2,0)
	534	;;8.0;KER NEL;*689 *;Jul 10, 1995;Build 28
	535	"RTN","XQ6 ",3,0)
	536	EN1 S XQAL =1,XQDA=0 G INIT ; E NTRY POINT TO ACTIVA TE KEY (XU KEYALL)
	537	"RTN","XQ6 ",4,0)
	538	EN2 S XQAL =0,XQDA=0 G INIT ; D E-ALLOCATE ACTIVE KE Y (XUKEYDE ALL)
	539	"RTN","XQ6 ",5,0)
	540	EN3 S XQAL =1,XQDA=1 G INIT ; D ELEGATE KE YS (XQKEYD EL)
	541	"RTN","XQ6 ",6,0)
	542	EN4 S XQAL =0,XQDA=1 ;REMOVE DE LEGATED KE YS (XQKEYR DEL)
	543	"RTN","XQ6 ",7,0)
	544	INIT ;
	545	"RTN","XQ6 ",8,0)
	546	K XQKEY,X QHOLD S (X QKEY(0),XQ HOLD(0),XQ BOSS)=0
	547	"RTN","XQ6 ",9,0)
	548	KEY ;
	549	"RTN","XQ6 ",10,0)
	550	S:'$D(XQD A) XQDA=0 S XQBOSS=0 S:(DUZ(0) ="@"!($D(^ XUSEC("XUM GR",DUZ))) ) XQBOSS=1
	551	"RTN","XQ6 ",11,0)
	552	I 'XQBOSS ,$O(^VA(20 0,DUZ,52,0 ))'>0 W !, "You've no thing to a llocate. See your p ackage coo rdinator o r site man ager." G O UT
	553	"RTN","XQ6 ",12,0)
	554	W !!,$S($ O(XQKEY(0) )>0:"Anoth er",XQAL&X QDA:"Deleg ate",XQAL: "Allocate" ,'XQAL&XQD A:"Remove delegated" ,1:"De-all ocate")," key: " R X :DTIME S:' $T X=U G:X [U OUT
	555	"RTN","XQ6 ",13,0)
	556	;*689 - m odified th e allocati on/delegat ion of the PSDRPH ke y
	557	"RTN","XQ6 ",14,0)
	558	I 'XQDA,X ="PSDRPH" D G OUT
	559	"RTN","XQ6 ",15,0)
	560	.W !,"The PSDRPH ke y cannot b e allocate d / de-all ocated by this optio n."
	561	"RTN","XQ6 ",16,0)
	562	.W !,"Ple ase use th e option ' Allocate/D e-Allocate of PSDRPH Key'."
	563	"RTN","XQ6 ",17,0)
	564	I '$L(X) G:($O(XQKE Y(0))'>0) OUT G HOLD ER
	565	"RTN","XQ6 ",18,0)
	566	I X["?" S XQH="XQKE YALLOCATE- KEY" D:X=" ?" EN^XQH D:X="??" L STKEY^XQ6A D:X="???" KEYFIL^XQ 6A G KEY
	567	"RTN","XQ6 ",19,0)
	568	S XQM=0 S :"-"[$E(X, 1) X=$E(X, 2,999),XQM =1
	569	"RTN","XQ6 ",20,0)
	570	S DIC=19. 1,DIC(0)=" EZM" S:'XQ BOSS DIC(" S")="I $D( ^VA(200,DU Z,52,+Y,0) )" D ^DIC K DIC I Y< 0 W " ??", *7 G KEY
	571	"RTN","XQ6 ",21,0)
	572	I XQM W $ S($D(XQKEY (+Y)):" D eleted fro m current list",1:$C (7)_" ?? Key not on list") K XQKEY(+Y) G KEY
	573	"RTN","XQ6 ",22,0)
	574	S XQKEY(+ Y)="" I $D (^DIC(19.1 ,+Y,3,0)), $P(^(0),U, 4)>0 D MOR E
	575	"RTN","XQ6 ",23,0)
	576	G KEY
	577	"RTN","XQ6 ",24,0)
	578	;
	579	"RTN","XQ6 ",25,0)
	580	MORE ;Hand les subord inate or e xploding k eys
	581	"RTN","XQ6 ",26,0)
	582	W !!,"The re are sub ordinate k eys, do yo u wish to add them" S %=2 D YN ^DICN I %= -1!(%=2) Q
	583	"RTN","XQ6 ",27,0)
	584	I %=0 W ! !,"If you answer 'YE S', the su bordinate keys will be listed and added. " G MORE
	585	"RTN","XQ6 ",28,0)
	586	F XQI=0:0 S XQI=$O( ^DIC(19.1, +Y,3,XQI)) Q:XQI'>0 S XQJ=+^( XQI,0),XQK EY(XQJ)="" W !,$P(^D IC(19.1,XQ J,0),"^"), " ",$P(^( 0),U,2)
	587	"RTN","XQ6 ",29,0)
	588	Q
	589	"RTN","XQ6 ",30,0)
	590	HOLDER ;Co ntinue in next routi ne
	591	"RTN","XQ6 ",31,0)
	592	G HOLDER^ XQ6A
	593	"RTN","XQ6 ",32,0)
	594	;
	595	"RTN","XQ6 ",33,0)
	596	OUT K %,DA ,DIC,DIE,D R,XMDUZ,XQ BOSS,XQKEY ,XQAL,XQHO LD,XQI,XQJ ,XQK,XQDA, XQSBNFDT,X QH,XQM,XQN M,X,Y
	597	"RTN","XQ6 ",34,0)
	598	Q
	599	"RTN","XQ6 ",35,0)
	600	SHOW ;Show the users of a part icular key
	601	"RTN","XQ6 ",36,0)
	602	K ^TMP($J ) S XQL=1, DIC="^DIC( 19.1,",DIC (0)="AEQMZ ",DIC("A") =" Which key? " W ! D ^DIC I Y'>0 K DI C,XQL Q
	603	"RTN","XQ6 ",37,0)
	604	S XQKEY=$ P(Y,U,2) I '$D(^XUSE C(XQKEY)) W !!,"Ther e are no h olders of this key." K DIC,XQK EY Q
	605	"RTN","XQ6 ",38,0)
	606	W @IOF,?1 5,"Current holders o f the key ",XQKEY,!!
	607	"RTN","XQ6 ",39,0)
	608	S %=0 F X QI=0:0 S % =$O(^XUSEC (XQKEY,%)) Q:%="" I $D(^VA(20 0,+%,0)) S ^TMP($J,$ P(^VA(200, +%,0),U))= ""
	609	"RTN","XQ6 ",40,0)
	610	S %="" F XQI=1:1 S %=$O(^TMP( $J,%)) Q:% ="" W !,% D:'(XQI#1 6) PAUSE Q :X[U
	611	"RTN","XQ6 ",41,0)
	612	K ^TMP($J ),%,DIC,XQ I,XQL,XQKE Y
	613	"RTN","XQ6 ",42,0)
	614	Q
	615	"RTN","XQ6 ",43,0)
	616	PAUSE ;Hol d the scre en
	617	"RTN","XQ6 ",44,0)
	618	W !!?5,"H it RETURN to continu e or '^' t o stop: " R X:DTIME S:'$T X=U
	619	"RTN","XQ6 ",45,0)
	620	I X'[U,XQ L W @IOF,? 15,"Curren t holders of the key ",XQKEY,! !
	621	"RTN","XQ6 ",46,0)
	622	Q
	623	"RTN","XQ6 ",47,0)
	624	LIST ;List all the k eys of a g iven user
	625	"RTN","XQ6 ",48,0)
	626	K ^TMP($J ) S XQL=0, DIC="^VA(2 00,",DIC(0 )="AEQMZ", DIC("A")=" User's name: " W ! D ^DIC I Y'>0 K DI C Q
	627	"RTN","XQ6 ",49,0)
	628	S %=$P(Y, U,2),XQUSE R=$P(%,"," ,2)_" "_$P (%,","),XQ U=+Y
	629	"RTN","XQ6 ",50,0)
	630	I $D(^VA( 200,XQU,52 ,0)),$P(^( 0),U,2)["2 00.051" S $P(^(0),U, 2)="200.05 2PA" D MES S ;This co rrects a K v7 problem can be re moved afte r Kv8
	631	"RTN","XQ6 ",51,0)
	632	S %=0 F X QI=0:1 S % =$O(^VA(20 0,XQU,51," B",%)) Q:% ="" S:$D( ^DIC(19.1, %,0)) ^TMP ($J,$P(^DI C(19.1,%,0 ),U))=""
	633	"RTN","XQ6 ",52,0)
	634	W @IOF S XQK=5 I XQ I=0 W !!,X QUSER," do es not cur rently hol d any keys ."
	635	"RTN","XQ6 ",53,0)
	636	I XQI>0 W !!,XQUSER ," current ly holds:" ,! S %="" F XQI=0:1 S %=$O(^TM P($J,%)) Q :%="" W:' (XQI#XQK) ! W ?(XQI# XQK*16),%
	637	"RTN","XQ6 ",54,0)
	638	K ^TMP($J ) S %=0 F XQI=0:1 S %=$O(^VA(2 00,XQU,52, "B",%)) Q: %="" S:$D (^DIC(19.1 ,%,0)) ^TM P($J,$P(^D IC(19.1,%, 0),U))=""
	639	"RTN","XQ6 ",55,0)
	640	I XQI>0 W !!!,XQUSE R," may de legate the following keys:",! S %="" F X QI=0:1 S % =$O(^TMP($ J,%)) Q:%= "" W:'(XQ I#XQK) ! W ?(XQI#XQK *16),%
	641	"RTN","XQ6 ",56,0)
	642	K ^TMP($J ),%,DIC,XQ I,XQK,XQL, XQU,XQUSER
	643	"RTN","XQ6 ",57,0)
	644	Q
	645	"RTN","XQ6 ",58,0)
	646	;
	647	"RTN","XQ6 ",59,0)
	648	ATOD ;Conv ert all of a users a llocated k eys to del egated key s
	649	"RTN","XQ6 ",60,0)
	650	S DIC="^V A(200,",DI C(0)="AEQM Z",DIC("A" )=" User' s name: " W ! D ^DIC I Y'>0 K DIC Q
	651	"RTN","XQ6 ",61,0)
	652	S %=$P(Y, U,2),XQUSE R=$P(%,"," ,2)_" "_$P (%,","),XQ U=+Y
	653	"RTN","XQ6 ",62,0)
	654	S %=$P($G (^VA(200,X QU,51,0)), U,4) I %'> 0 W !!,XQU SER," does not hold any keys t o transfer ." K XQUSE R,XQU,Y G ATOD
	655	"RTN","XQ6 ",63,0)
	656	I $D(^VA( 200,XQU,52 ,0)),$P(^( 0),U,4)>0 W !!,XQUSE R," alread y has some delegated keys." S DIR(0)="YA ",DIR("A") =" Shall I merge the two sets? Y/N ",DIR ("B")="N" D ^DIR I Y =0!$D(DIRU T) K DIR,D IRUT,XQUSE R,XQU,Y G ATOD
	657	"RTN","XQ6 ",64,0)
	658	S %X="^VA (200,"_XQU _",51,",%Y ="^VA(200, "_XQU_",52 ," D %XY^% RCR
	659	"RTN","XQ6 ",65,0)
	660	S $P(^VA( 200,XQU,52 ,0),U,2)=" 200.052PA"
	661	"RTN","XQ6 ",66,0)
	662	S DIK="^V A(200,"_XQ U_",52,",D IK(1)=".01 ^B",DA=52, DA(1)=XQU D ENALL^DI K
	663	"RTN","XQ6 ",67,0)
	664	K %,%X,%Y ,DA,DIC,DI K,DIR,XQU, XQUSER,X,Y
	665	"RTN","XQ6 ",68,0)
	666	Q
	667	"RTN","XQ6 ",69,0)
	668	;
	669	"RTN","XQ6 ",70,0)
	670	MESS ;Corr ect proble ms with ke y cross-re ferences f rom 7.0 %R CR above.
	671	"RTN","XQ6 ",71,0)
	672	S DA(1)=X QU F XQFIL =51,52 D
	673	"RTN","XQ6 ",72,0)
	674	.K ^VA(20 0,DA(1),XQ FIL,"B")
	675	"RTN","XQ6 ",73,0)
	676	.S DA=0,D IK="^VA(20 0,"_DA(1)_ ","_XQFIL_ ","
	677	"RTN","XQ6 ",74,0)
	678	.F S DA= $O(^VA(200 ,DA(1),XQF IL,DA)) Q: DA'=+DA D IX^DIK
	679	"RTN","XQ6 ",75,0)
	680	.Q
	681	"RTN","XQ6 ",76,0)
	682	K DA,DIC, DIK,XQDUZ, XQFIL
	683	"RTN","XQ6 ",77,0)
	684	Q
	685	"RTN","XU8 P689")
	686	0^^B158431 4
	687	"RTN","XU8 P689",1,0)
	688	XU8P689 ;A LB/MA - Pa tch XU86 89 Pre/Pos t init ;12 /05/18
	689	"RTN","XU8 P689",2,0)
	690	;;8.0;KER NEL;*689 *;May 17, 2012;Build 28
	691	"RTN","XU8 P689",3,0)
	692	Q
	693	"RTN","XU8 P689",4,0)
	694	PRE ;
	695	"RTN","XU8 P689",5,0)
	696	;Deletes FIELD EDIT ED (#.03) of XUEPCS DATA FILE (#8991.6). A modifie d copy is sent in th is patch
	697	"RTN","XU8 P689",6,0)
	698	N DIK,DA S DIK="^DD (8991.6,", DA=.03,DA( 1)=8991.6 D ^DIK
	699	"RTN","XU8 P689",7,0)
	700	Q
	701	"RTN","XU8 P689",8,0)
	702	;
	703	"RTN","XU8 P689",9,0)
	704	POST ;The listed XU EPCS optio ns are pla ced out of order as they are m oved over to PSO nam espace
	705	"RTN","XU8 P689",10,0 )
	706	D BMES^XP DUTL("...P lacing XU EPCS UTILI TY FUNCTIO NS menu op tions out of order.. .")
	707	"RTN","XU8 P689",11,0 )
	708	N XUOO,AA ,I S XUOO= "PLACED OU T OF ORDER BY XU86 89"
	709	"RTN","XU8 P689",12,0 )
	710	F I=1:1:1 4 S AA=$P( $T(OO+I)," ;;",2) Q:A A="" D OU T^XPDMENU( AA,XUOO)
	711	"RTN","XU8 P689",13,0 )
	712	Q
	713	"RTN","XU8 P689",14,0 )
	714	;
	715	"RTN","XU8 P689",15,0 )
	716	;
	717	"RTN","XU8 P689",16,0 )
	718	OO ;
	719	"RTN","XU8 P689",17,0 )
	720	;;XU EPCS EXP DATE
	721	"RTN","XU8 P689",18,0 )
	722	;;XU EPCS DISUSER E XP DATE
	723	"RTN","XU8 P689",19,0 )
	724	;;XU EPCS XDATE EXP IRES
	725	"RTN","XU8 P689",20,0 )
	726	;;XU EPCS DISUSER X DATE EXPIR ES
	727	"RTN","XU8 P689",21,0 )
	728	;;XU EPCS PRIVS
	729	"RTN","XU8 P689",22,0 )
	730	;;XU EPCS DISUSER P RIVS
	731	"RTN","XU8 P689",23,0 )
	732	;;XU EPCS PSDRPH
	733	"RTN","XU8 P689",24,0 )
	734	;;XU EPCS SET PARMS
	735	"RTN","XU8 P689",25,0 )
	736	;;XU EPCS PRINT EDI T AUDIT
	737	"RTN","XU8 P689",26,0 )
	738	;;XU EPCS LOGICAL A CCESS
	739	"RTN","XU8 P689",27,0 )
	740	;;XU EPCS PSDRPH AU DIT
	741	"RTN","XU8 P689",28,0 )
	742	;;XU EPCS PSDRPH KE Y
	743	"RTN","XU8 P689",29,0 )
	744	;;XU EPCS EDIT DEA# AND XDATE
	745	"RTN","XU8 P689",30,0 )
	746	;;XU EPCS EDIT DATA
	747	"RTN","XUP SPRA")
	748	0^8^B11352 75
	749	"RTN","XUP SPRA",1,0)
	750	XUPSPRA ;A LB/CMC - B uild PRA s egment;Aug 6, 2010
	751	"RTN","XUP SPRA",2,0)
	752	;;8.0;KER NEL;551, 689;Jul 10, 1995;B uild 28
	753	"RTN","XUP SPRA",3,0)
	754	;;Per VA Directive 6402, this routine s hould not be modifie d.
	755	"RTN","XUP SPRA",4,0)
	756	;
	757	"RTN","XUP SPRA",5,0)
	758	EN(XUPSIEN ,XUPSSTR,H L) ;
	759	"RTN","XUP SPRA",6,0)
	760	;XUPSIEN - New Pers on Interna l Entry Nu mber
	761	"RTN","XUP SPRA",7,0)
	762	;XUPSSTR - sequence numbers w hich shoul d be used, only fiel d 6 for DE A# at this point use d
	763	"RTN","XUP SPRA",8,0)
	764	;HL - hl7 array var iables
	765	"RTN","XUP SPRA",9,0)
	766	;RETURN: PRA segme nt returne d or -1^er ror messag e
	767	"RTN","XUP SPRA",10,0 )
	768	;
	769	"RTN","XUP SPRA",11,0 )
	770	N XUPSREC ,NUM
	771	"RTN","XUP SPRA",12,0 )
	772	I XUPSIEN =""!(XUPSS TR="")!('$ D(HL)) S X UPSREC="-1 ^Missing P arameters" G QUIT ;m issing par ameter
	773	"RTN","XUP SPRA",13,0 )
	774	S $P(XUPS REC,HL("FS "),1)="PRA " ;sequenc e 1 set to segment t ype
	775	"RTN","XUP SPRA",14,0 )
	776	;DEA# FIE LD 6
	777	"RTN","XUP SPRA",15,0 )
	778	;S NUM=$P ($G(^VA(20 0,XUPSIEN, "PS")),"^" ,2)
	779	"RTN","XUP SPRA",16,0 )
	780	S NUM=$$P RDEA^XUSER (XUPSIEN)
	781	"RTN","XUP SPRA",17,0 )
	782	I NUM="" S NUM=HL(" Q")
	783	"RTN","XUP SPRA",18,0 )
	784	S $P(XUPS REC,HL("FS "),7)=NUM
	785	"RTN","XUP SPRA",19,0 )
	786	QUIT Q XUP SREC
	787	"RTN","XUS ER")
	788	0^6^B21582 3182
	789	"RTN","XUS ER",1,0)
	790	XUSER ;ISP /RFR - A c ommon set of user fu nctions ;0 6/09/15 1 0:51
	791	"RTN","XUS ER",2,0)
	792	;;8.0;KER NEL;75,9 7,99,150,2 26,267,288 ,330,370,3 73,580,609 ,642,689 ;Jul 10, 1 995;Build 28
	793	"RTN","XUS ER",3,0)
	794	;Per VA D irective 6 402, this routine sh ould not b e modified .
	795	"RTN","XUS ER",4,0)
	796	;Covered under DBIA #2343
	797	"RTN","XUS ER",5,0)
	798	Q
	799	"RTN","XUS ER",6,0)
	800	LOOKUP(XUF ) ;Do a us er lookup
	801	"RTN","XUS ER",7,0)
	802	;Paramete r, "Q" to NOT ask OK .
	803	"RTN","XUS ER",8,0)
	804	;Paramete r, "A" Don 't select current us ers who ha ve a termi nation
	805	"RTN","XUS ER",9,0)
	806	; dat e prior to today's d ate
	807	"RTN","XUS ER",10,0)
	808	N DIC,XUD A,DIR,Y
	809	"RTN","XUS ER",11,0)
	810	LK1 S DIC= "^VA(200," ,DIC(0)="A EMQZ" D ^D IC S XUDA= Y G:Y'>0 L KX
	811	"RTN","XUS ER",12,0)
	812	S Y=$P(Y( 0),"^",11) I Y>0,Y<D T W !?15," This user was termin ated on ", $$FMTE^XLF DT(Y) I $G (XUF)["A" S XUDA=-1 G LK1
	813	"RTN","XUS ER",13,0)
	814	G:$G(XUF) ["Q" LKX
	815	"RTN","XUS ER",14,0)
	816	S DIR(0)= "Y",DIR("A ")=" Is "_ $P(XUDA,U, 2)_" the o ne you wan t",DIR("B" )="YES" D ^DIR
	817	"RTN","XUS ER",15,0)
	818	I Y'=1 S XUDA=-1 G: '$D(DIRUT) LK1
	819	"RTN","XUS ER",16,0)
	820	;
	821	"RTN","XUS ER",17,0)
	822	LKX Q XUDA
	823	"RTN","XUS ER",18,0)
	824	;
	825	"RTN","XUS ER",19,0)
	826	ACTIVE(XUD A) ;Get if a user is active.
	827	"RTN","XUS ER",20,0)
	828	N %,X1,X2
	829	"RTN","XUS ER",21,0)
	830	S X1=$G(^ VA(200,+$G (XUDA),0)) ,X2=$S(X1= "":"",1:0)
	831	"RTN","XUS ER",22,0)
	832	I $L($P(X 1,U,3)) S X2="1^"_$S ($L($P($G( ^VA(200,XU DA,.1)),U, 2)):"ACTIV E",1:"NEW" )
	833	"RTN","XUS ER",23,0)
	834	S:$P(X1,U ,7)=1 X2=" 0^DISUSER"
	835	"RTN","XUS ER",24,0)
	836	S:X2["ACT IVE" $P(X2 ,U,3)=$P($ G(^VA(200, XUDA,1.1)) ,U) ;Retur n last sig n-on
	837	"RTN","XUS ER",25,0)
	838	S %=$P(X1 ,U,11) I % >0,%'>DT S X2="0^TER MINATED^"_ %
	839	"RTN","XUS ER",26,0)
	840	Q X2
	841	"RTN","XUS ER",27,0)
	842	;
	843	"RTN","XUS ER",28,0)
	844	BULL ;Call ed from bu lletin in DD of file #200 for 'Sub Alt N ame' fld.
	845	"RTN","XUS ER",29,0)
	846	;This wil l find use rs with PS DMGR keys and setup the XMY ar ray for
	847	"RTN","XUS ER",30,0)
	848	;bulletin recipient s. p580 RE M
	849	"RTN","XUS ER",31,0)
	850	; ZEXCEPT : XMY - Ke rnel exemp tion
	851	"RTN","XUS ER",32,0)
	852	N PSD,I
	853	"RTN","XUS ER",33,0)
	854	S PSD=$$F IND1^DIC(1 9.1,"","MX ","PSDMGR" ,"","","PS DERR") Q:P SD'>0
	855	"RTN","XUS ER",34,0)
	856	S I=0 F S I=$O(^VA (200,"AB", PSD,I)) Q: I'>0 S XM Y(I)=""
	857	"RTN","XUS ER",35,0)
	858	Q
	859	"RTN","XUS ER",36,0)
	860	;
	861	"RTN","XUS ER",37,0)
	862	PROVIDER(X UDA,XUF) ; See if use r qualifie s as a CPR S provider
	863	"RTN","XUS ER",38,0)
	864	;XUDA = I EN of Reco rd in New Person Fil e
	865	"RTN","XUS ER",39,0)
	866	;XUF = Fl ag to cont rol proces sing
	867	"RTN","XUS ER",40,0)
	868	; 0 or not pas sed, do no t include Visitors
	869	"RTN","XUS ER",41,0)
	870	; 1 include Vi sitors
	871	"RTN","XUS ER",42,0)
	872	N %,X1,X2 ,XUORES
	873	"RTN","XUS ER",43,0)
	874	;Test to see if XUD A Passed:
	875	"RTN","XUS ER",44,0)
	876	I '$D(XUD A) Q ""
	877	"RTN","XUS ER",45,0)
	878	;
	879	"RTN","XUS ER",46,0)
	880	;Test for valid IEN :
	881	"RTN","XUS ER",47,0)
	882	S X1=$G(^ VA(200,+$G (XUDA),0)) ,X2=$S(X1= "":"",1:1) Q:X2="" " "
	883	"RTN","XUS ER",48,0)
	884	;
	885	"RTN","XUS ER",49,0)
	886	;See if u ser has XU ORES Secur ity Key:
	887	"RTN","XUS ER",50,0)
	888	S XUORES= $D(^XUSEC( "XUORES",X UDA))
	889	"RTN","XUS ER",51,0)
	890	;
	891	"RTN","XUS ER",52,0)
	892	;Test for Access Co de:
	893	"RTN","XUS ER",53,0)
	894	I $P(X1,U ,3)]"" Q 1
	895	"RTN","XUS ER",54,0)
	896	;
	897	"RTN","XUS ER",55,0)
	898	;Test for a Termina tion Date not in the Future
	899	"RTN","XUS ER",56,0)
	900	;AND Not owner of X UORES Secu rity Key:
	901	"RTN","XUS ER",57,0)
	902	S %=$P(X1 ,U,11) I % >0,%'>DT,' XUORES Q " 0^TERMINAT ED^"_%
	903	"RTN","XUS ER",58,0)
	904	;
	905	"RTN","XUS ER",59,0)
	906	;Test if user has X UORES Secu rity key:
	907	"RTN","XUS ER",60,0)
	908	I XUORES Q 1
	909	"RTN","XUS ER",61,0)
	910	;
	911	"RTN","XUS ER",62,0)
	912	;Tests fo r Visitors :
	913	"RTN","XUS ER",63,0)
	914	I +$G(XUF ),$D(^VA(2 00,"BB","V ISITOR",XU DA)) Q 1
	915	"RTN","XUS ER",64,0)
	916	I $D(^VA( 200,"BB"," VISITOR",X UDA)) Q "0 ^VISITOR"
	917	"RTN","XUS ER",65,0)
	918	;
	919	"RTN","XUS ER",66,0)
	920	;Default:
	921	"RTN","XUS ER",67,0)
	922	Q "0^NOT A PROVIDER "
	923	"RTN","XUS ER",68,0)
	924	;
	925	"RTN","XUS ER",69,0)
	926	DEA(FG,IEN ,RXDEA) ;s r. ef. Ret urn users DEA # or F acility DE A_"-"_user VA# or nu ll
	927	"RTN","XUS ER",70,0)
	928	;ICR #234 3
	929	"RTN","XUS ER",71,0)
	930	;If FG is 1: DEA# o r VA#
	931	"RTN","XUS ER",72,0)
	932	;Fee Basi s, C&A pro viders onl y return D EA# or nul l - p609/R EM
	933	"RTN","XUS ER",73,0)
	934	;Add XDT= DEA expira tion date. If XDT un populated, its expir ed. - p609 /REM
	935	"RTN","XUS ER",74,0)
	936	;If a DEA # is passe d in RXDEA , check if that # ha s all the credential s.
	937	"RTN","XUS ER",75,0)
	938	N DEA,FB, IN,INN,N,N 1,XDT,VA,F AIL,I,J,K, RET
	939	"RTN","XUS ER",76,0)
	940	S IEN=$G( IEN,DUZ),I NN=+DUZ(2) S:'$G(FG) FG="" S:' $D(RXDEA) RXDEA=""
	941	"RTN","XUS ER",77,0)
	942	S N=$G(^V A(200,IEN, "PS"))
	943	"RTN","XUS ER",78,0)
	944	S VA=$P(N ,U,3)
	945	"RTN","XUS ER",79,0)
	946	I $P(N,U, 6)=4!($P(N ,U,6)=3) S FB=1 ;Fe e Basis or C&A prov ider -p609
	947	"RTN","XUS ER",80,0)
	948	S RET=""
	949	"RTN","XUS ER",81,0)
	950	I $L(RXDE A)>1 D Q: RET]"" RXD EA Q ""
	951	"RTN","XUS ER",82,0)
	952	. S I=$O( ^VA(200,IE N,"PS4","B ",$P(RXDEA ,"-"),0)) D:I
	953	"RTN","XUS ER",83,0)
	954	.. S J=$P ($G(^VA(20 0,IEN,"PS4 ",I,0)),"^ ",3) D:J
	955	"RTN","XUS ER",84,0)
	956	... S XDT =$P($G(^XT V(8991.9,J ,0)),"^",4 ) Q:'XDT
	957	"RTN","XUS ER",85,0)
	958	... I XDT '<DT S RET =RXDEA
	959	"RTN","XUS ER",86,0)
	960	S J=0 F S J=$O(^VA (200,IEN," PS4",J)) Q :'J D Q: $L(RET)
	961	"RTN","XUS ER",87,0)
	962	. S NP=1, K=$P($G(^V A(200,IEN, "PS4",J,0) ),"^",3) D :K
	963	"RTN","XUS ER",88,0)
	964	.. I $P($ G(^XTV(899 1.9,K,0)), "^",6)=1 D
	965	"RTN","XUS ER",89,0)
	966	... S XDT =$P($G(^XT V(8991.9,K ,0)),"^",4 )
	967	"RTN","XUS ER",90,0)
	968	... I 'XD T S RET="Q " Q
	969	"RTN","XUS ER",91,0)
	970	... I XDT '<DT S RET =$P(^VA(20 0,IEN,"PS4 ",J,0),"^" )
	971	"RTN","XUS ER",92,0)
	972	... I XDT <DT S RET= "E"
	973	"RTN","XUS ER",93,0)
	974	Q:RET="Q" ""
	975	"RTN","XUS ER",94,0)
	976	Q:$L(RET) >6 RET
	977	"RTN","XUS ER",95,0)
	978	Q:$G(FB) ""
	979	"RTN","XUS ER",96,0)
	980	Q:$G(FG) VA
	981	"RTN","XUS ER",97,0)
	982	;*689 - p revent fai lover
	983	"RTN","XUS ER",98,0)
	984	S FAIL=$$ GET^XPAR(" SYS","PSOE PCS EXPIRE D DEA FAIL OVER",1,"I ")
	985	"RTN","XUS ER",99,0)
	986	I FAIL=0, RET="E" Q ""
	987	"RTN","XUS ER",100,0)
	988	S IN=$P($ G(^DIC(4,I NN,"DEA")) ,U) ;Check signed-in Inst.
	989	"RTN","XUS ER",101,0)
	990	I '$L(IN) D
	991	"RTN","XUS ER",102,0)
	992	. N XU1 D PARENT^XU AF4("XU1", "`"_INN,"P ARENT FACI LITY")
	993	"RTN","XUS ER",103,0)
	994	. S INN=$ O(XU1("P", "")) I INN S IN=$P($ G(^DIC(4,I NN,"DEA")) ,U)
	995	"RTN","XUS ER",104,0)
	996	. Q
	997	"RTN","XUS ER",105,0)
	998	N XUEXDT I INN S XU EXDT=$P($G (^DIC(4,IN N,"DEA")), U,2) ;chec k DEA EXPI RATION DAT E
	999	"RTN","XUS ER",106,0)
	1000	S XUEXDT= $G(XUEXDT)
	1001	"RTN","XUS ER",107,0)
	1002	I $L(VA), $L(IN),$L( XUEXDT),XU EXDT'<DT Q IN_"-"_VA ;check DE A EXPIRATI ON DATE
	1003	"RTN","XUS ER",108,0)
	1004	Q ""
	1005	"RTN","XUS ER",109,0)
	1006	;
	1007	"RTN","XUS ER",110,0)
	1008	DETOX(IEN) ;*689 - R eturns the Detox # f rom file 8 991.9/200 - p580/REM
	1009	"RTN","XUS ER",111,0)
	1010	;ICR #234 3
	1011	"RTN","XUS ER",112,0)
	1012	;Return D etox# - va lid detox# and DEA X date is va lid
	1013	"RTN","XUS ER",113,0)
	1014	;Return n ull - if n o detox or the DEA X date is un populated
	1015	"RTN","XUS ER",114,0)
	1016	;Return D EA Expirat ion Date - valid det ox# but ex pired DEA Xdate
	1017	"RTN","XUS ER",115,0)
	1018	;IEN is u sed to loo kup user i n file #20 0
	1019	"RTN","XUS ER",116,0)
	1020	Q:'IEN ""
	1021	"RTN","XUS ER",117,0)
	1022	N DET,XDT ,N,N1,I,NP ,J,AR1,AR2 ,AR3,AR4,V DEA S (N,N P,VDEA)=0, DET=""
	1023	"RTN","XUS ER",118,0)
	1024	S I=0 F S I=$O(^VA (200,IEN," PS4",I)) Q :'I D
	1025	"RTN","XUS ER",119,0)
	1026	.S NP=1,J =$$GET1^DI Q(200.5321 ,I_","_IEN ,.03,"I") Q:'J D
	1027	"RTN","XUS ER",120,0)
	1028	.. Q:$$GE T1^DIQ(899 1.9,J,.07, "I")=1
	1029	"RTN","XUS ER",121,0)
	1030	.. S XDT= $$GET1^DIQ (8991.9,J, .04,"I") Q :'XDT
	1031	"RTN","XUS ER",122,0)
	1032	.. S DET= $$GET1^DIQ (8991.9,J, .03)
	1033	"RTN","XUS ER",123,0)
	1034	.. S N=N+ 1
	1035	"RTN","XUS ER",124,0)
	1036	.. I XDT< DT,$L(DET) S:N=1 AR4 (XDT)="" S AR3(99999 99-XDT,DET )="" Q
	1037	"RTN","XUS ER",125,0)
	1038	.. S:XDT' <DT VDEA=1
	1039	"RTN","XUS ER",126,0)
	1040	.. Q:'$L( DET)
	1041	"RTN","XUS ER",127,0)
	1042	.. I $$GE T1^DIQ(899 1.9,J,.06, "I")=1 S A R1(9999999 -XDT,DET)= ""
	1043	"RTN","XUS ER",128,0)
	1044	.. E S A R2(9999999 -XDT,DET)= ""
	1045	"RTN","XUS ER",129,0)
	1046	S I="",I= $O(AR1(I)) Q:I $O(AR 1(I,""))
	1047	"RTN","XUS ER",130,0)
	1048	S I="",I= $O(AR2(I)) Q:I $O(AR 2(I,""))
	1049	"RTN","XUS ER",131,0)
	1050	;I VDEA,N S I="",I= $O(AR3(I)) Q:I $O(AR 3(I,""))
	1051	"RTN","XUS ER",132,0)
	1052	S I="",I= $O(AR3(I)) Q:I $O(AR 3(I,""))
	1053	"RTN","XUS ER",133,0)
	1054	S I="",I= $O(AR4(I)) Q:I I
	1055	"RTN","XUS ER",134,0)
	1056	Q:NP ""
	1057	"RTN","XUS ER",135,0)
	1058	S N=$G(^V A(200,IEN, "PS")),N1= $G(^VA(200 ,IEN,"QAR" ))
	1059	"RTN","XUS ER",136,0)
	1060	S DET=$P( N,U,11),XD T=$P(N1,U, 9)
	1061	"RTN","XUS ER",137,0)
	1062	I $L(DET) ,$L(XDT),X DT'<DT Q D ET
	1063	"RTN","XUS ER",138,0)
	1064	I $L(DET) ,$L(XDT),X DT<DT Q XD T
	1065	"RTN","XUS ER",139,0)
	1066	Q ""
	1067	"RTN","XUS ER",140,0)
	1068	;
	1069	"RTN","XUS ER",141,0)
	1070	SDEA(FG,IE N,PSDEA,ID EA) ;valid ation for new DEA re gulations p580-JC(CP RS)
	1071	"RTN","XUS ER",142,0)
	1072	;ICR #234 3
	1073	"RTN","XUS ER",143,0)
	1074	;Returns: DEA#, 1, 2, or 4^ex piration d ate
	1075	"RTN","XUS ER",144,0)
	1076	;IEN is u sed to loo kup user i n file #20 0
	1077	"RTN","XUS ER",145,0)
	1078	;PSDEA is the DEA s chedule
	1079	"RTN","XUS ER",146,0)
	1080	;IDEA is the DEA# o r an "I" f or Inpatie nt use to check for schedule
	1081	"RTN","XUS ER",147,0)
	1082	;*689
	1083	"RTN","XUS ER",148,0)
	1084	N DEA,N,N 3,I,J,K,A, E,FOVR,XDT ,Y,VA,FB
	1085	"RTN","XUS ER",149,0)
	1086	S N=$G(^V A(200,IEN, "PS")),VA= $P(N,U,3), (DEA,N3,E, FB)=""
	1087	"RTN","XUS ER",150,0)
	1088	I $P(N,U, 6)=4!($P(N ,U,6)=3) S FB=1
	1089	"RTN","XUS ER",151,0)
	1090	S IDEA=$G (IDEA),FG= $G(FG),IEN =$G(IEN),P SDEA=$G(PS DEA)
	1091	"RTN","XUS ER",152,0)
	1092	I $G(PSDE A)="" Q 1
	1093	"RTN","XUS ER",153,0)
	1094	S FOVR=$$ GET^XPAR(" SYS","PSOE PCS EXPIRE D DEA FAIL OVER",1,"I ")
	1095	"RTN","XUS ER",154,0)
	1096	I $L(IDEA ),$L(IDEA, "-")=2,$P( IDEA,"-",2 )=VA G CVA
	1097	"RTN","XUS ER",155,0)
	1098	I '$L(IDE A),'$O(^VA (200,IEN," PS4",0)) G CVA
	1099	"RTN","XUS ER",156,0)
	1100	I '$L(IDE A) D G:$L (N3) SCHK Q:E E Q 1
	1101	"RTN","XUS ER",157,0)
	1102	. S J=0 F S J=$O(^ VA(200,IEN ,"PS4",J)) Q:'J D Q:$L(N3)
	1103	"RTN","XUS ER",158,0)
	1104	.. S K=$P ($G(^VA(20 0,IEN,"PS4 ",J,0)),"^ ",3) D:K
	1105	"RTN","XUS ER",159,0)
	1106	... S N=$ G(^XTV(899 1.9,K,0))
	1107	"RTN","XUS ER",160,0)
	1108	... S XDT =$P(N,"^", 4) Q:'XDT
	1109	"RTN","XUS ER",161,0)
	1110	... I $P( N,"^",6)=1 S DEA=$P( N,"^") D
	1111	"RTN","XUS ER",162,0)
	1112	.... I XD T'<DT S N3 =$G(^XTV(8 991.9,K,2) ) Q
	1113	"RTN","XUS ER",163,0)
	1114	.... I 'F OVR,XDT<DT S Y=XDT X ^DD("DD") S E=4_"^" _Y Q
	1115	"RTN","XUS ER",164,0)
	1116	.... Q:FB
	1117	"RTN","XUS ER",165,0)
	1118	.... Q:'$ L(VA)
	1119	"RTN","XUS ER",166,0)
	1120	.... D GV A S:DEA["- " N3=$G(^V A(200,IEN, "PS3"))
	1121	"RTN","XUS ER",167,0)
	1122	I $G(IDEA )="I" S DE A=$$DEA(0, IEN) I DEA ["-" S N3= $G(^VA(200 ,IEN,"PS3" )) G SCHK
	1123	"RTN","XUS ER",168,0)
	1124	I $L(IDEA )>1 S DEA= $P(IDEA,"- ")
	1125	"RTN","XUS ER",169,0)
	1126	Q:$G(DEA) ="" 1
	1127	"RTN","XUS ER",170,0)
	1128	S N=$O(^X TV(8991.9, "B",DEA,0) )
	1129	"RTN","XUS ER",171,0)
	1130	Q:'N 1
	1131	"RTN","XUS ER",172,0)
	1132	S XDT=$P( $G(^XTV(89 91.9,N,0)) ,"^",4) Q: 'XDT 1
	1133	"RTN","XUS ER",173,0)
	1134	I XDT'<DT S N3=$G(^ XTV(8991.9 ,N,2)) G S CHK
	1135	"RTN","XUS ER",174,0)
	1136	I 'FOVR,X DT<DT S Y= XDT X ^DD( "DD") Q 4_ "^"_Y
	1137	"RTN","XUS ER",175,0)
	1138	CVA ;
	1139	"RTN","XUS ER",176,0)
	1140	Q:FB 1
	1141	"RTN","XUS ER",177,0)
	1142	Q:'$L(VA) 1
	1143	"RTN","XUS ER",178,0)
	1144	D GVA S:D EA["-" N3= $G(^VA(200 ,IEN,"PS3" ))
	1145	"RTN","XUS ER",179,0)
	1146	Q:$G(DEA) ="" 1
	1147	"RTN","XUS ER",180,0)
	1148	SCHK ;
	1149	"RTN","XUS ER",181,0)
	1150	I $G(N3)= ""!(N3'[1) Q 2
	1151	"RTN","XUS ER",182,0)
	1152	F I=1:1:6 S A(I)=$P (N3,"^",I)
	1153	"RTN","XUS ER",183,0)
	1154	I PSDEA=2 Q $S('A(1 ):2,1:DEA)
	1155	"RTN","XUS ER",184,0)
	1156	I PSDEA=" 2n" Q $S(' A(2):2,1:D EA)
	1157	"RTN","XUS ER",185,0)
	1158	I PSDEA=3 Q $S('A(3 ):2,1:DEA)
	1159	"RTN","XUS ER",186,0)
	1160	I PSDEA=" 3n" Q $S(' A(4):2,1:D EA)
	1161	"RTN","XUS ER",187,0)
	1162	I PSDEA=4 Q $S('A(5 ):2,1:DEA)
	1163	"RTN","XUS ER",188,0)
	1164	I PSDEA=5 Q $S('A(6 ):2,1:DEA)
	1165	"RTN","XUS ER",189,0)
	1166	Q DEA
	1167	"RTN","XUS ER",190,0)
	1168	;
	1169	"RTN","XUS ER",191,0)
	1170	GVA ;
	1171	"RTN","XUS ER",192,0)
	1172	N IN,INN S INN=+DUZ (2)
	1173	"RTN","XUS ER",193,0)
	1174	S IN=$P($ G(^DIC(4,I NN,"DEA")) ,U) ;Check signed-in Inst.
	1175	"RTN","XUS ER",194,0)
	1176	I '$L(IN) D
	1177	"RTN","XUS ER",195,0)
	1178	. N XU1 D PARENT^XU AF4("XU1", "`"_INN,"P ARENT FACI LITY")
	1179	"RTN","XUS ER",196,0)
	1180	. S INN=$ O(XU1("P", "")) I INN S IN=$P($ G(^DIC(4,I NN,"DEA")) ,U)
	1181	"RTN","XUS ER",197,0)
	1182	. Q
	1183	"RTN","XUS ER",198,0)
	1184	N XUEXDT I INN S XU EXDT=$P($G (^DIC(4,IN N,"DEA")), U,2) ;chec k DEA EXPI RATION DAT E
	1185	"RTN","XUS ER",199,0)
	1186	S XUEXDT= $G(XUEXDT)
	1187	"RTN","XUS ER",200,0)
	1188	I $L(VA), $L(IN),$L( XUEXDT),XU EXDT'<DT S DEA=IN_"- "_VA ;chec k DEA EXPI RATION DAT E
	1189	"RTN","XUS ER",201,0)
	1190	Q
	1191	"RTN","XUS ER",202,0)
	1192	;
	1193	"RTN","XUS ER",203,0)
	1194	VDEA(RETUR N,IEN) ;I SP/RFR - V erify a pr ovider is properly c onfigured for ePCS
	1195	"RTN","XUS ER",204,0)
	1196	;PARAMETE RS: IEN - Internal E ntry Numbe r in the N EW PERSON file (#200 )
	1197	"RTN","XUS ER",205,0)
	1198	; RETURN - Referen ce to an a rray in wh ich text e xplaining
	1199	"RTN","XUS ER",206,0)
	1200	; deficie ncies and listing pr escribable schedules
	1201	"RTN","XUS ER",207,0)
	1202	; is plac ed, with e ach defici ency and t he list of
	1203	"RTN","XUS ER",208,0)
	1204	; schedul es on a se parate nod e
	1205	"RTN","XUS ER",209,0)
	1206	;RETURN: 1 - Provid er is prop erly confi gured for ePCS
	1207	"RTN","XUS ER",210,0)
	1208	; 0 - Provid er is not properly c onfigured for ePCS
	1209	"RTN","XUS ER",211,0)
	1210	N STATUS, DEA,RETVAL ,DATE,NODE A
	1211	"RTN","XUS ER",212,0)
	1212	S RETVAL= 1,STATUS=$ $ACTIVE(IE N)
	1213	"RTN","XUS ER",213,0)
	1214	I STATUS= "" S RETUR N("User ac count does not exist .")="",RET VAL=0
	1215	"RTN","XUS ER",214,0)
	1216	I STATUS= 0 S RETURN ("User can not sign o n.")="",RE TVAL=0
	1217	"RTN","XUS ER",215,0)
	1218	I +STATUS =0,($P(STA TUS,U,2)'= "") S RETU RN("User a ccount sta tus: "_$P( STATUS,U,2 ))="",RETV AL=0
	1219	"RTN","XUS ER",216,0)
	1220	Q:STATUS= "" RETVAL
	1221	"RTN","XUS ER",217,0)
	1222	I '$D(^XU SEC("ORES" ,IEN)) D
	1223	"RTN","XUS ER",218,0)
	1224	. S RETUR N("Does no t hold the ORES secu rity key." )="",RETVA L=0
	1225	"RTN","XUS ER",219,0)
	1226	I +$P($G( ^VA(200,IE N,"PS")),U ,1)'=1 D
	1227	"RTN","XUS ER",220,0)
	1228	. S RETUR N("Is not authorized to write medication orders.") ="",RETVAL =0
	1229	"RTN","XUS ER",221,0)
	1230	I $P($G(^ VA(200,IEN ,"PS")),U, 2)'="" D
	1231	"RTN","XUS ER",222,0)
	1232	. N DATE
	1233	"RTN","XUS ER",223,0)
	1234	. S DATE= +$P($G(^VA (200,IEN," QAR")),U,9 )
	1235	"RTN","XUS ER",224,0)
	1236	. I DATE= 0 S RETURN ("Has a DE A number w ith no exp iration da te.")="",R ETVAL=0,NO DEA=1
	1237	"RTN","XUS ER",225,0)
	1238	. I DATE> 0,(DATE<=D T) S RETUR N("Has an expired DE A number." )="",RETVA L=0,NODEA= 1
	1239	"RTN","XUS ER",226,0)
	1240	I $P($G(^ VA(200,IEN ,"PS")),U, 2)="" D
	1241	"RTN","XUS ER",227,0)
	1242	. S NODEA =1
	1243	"RTN","XUS ER",228,0)
	1244	. I $P($G (^VA(200,I EN,"PS")), U,3)="" D
	1245	"RTN","XUS ER",229,0)
	1246	. . S RET URN("Has n either a D EA number nor a VA n umber.")=" ",RETVAL=0
	1247	"RTN","XUS ER",230,0)
	1248	I +$G(NOD EA),($P($G (^VA(200,I EN,"PS")), U,3)'="") S RETVAL=1
	1249	"RTN","XUS ER",231,0)
	1250	S DATE=+$ P($G(^VA(2 00,IEN,"PS ")),U,4)
	1251	"RTN","XUS ER",232,0)
	1252	I DATE>0, (DATE<=DT) D
	1253	"RTN","XUS ER",233,0)
	1254	. S RETUR N("Is no l onger able to write medication orders (i nactive da te).")="", RETVAL=0
	1255	"RTN","XUS ER",234,0)
	1256	I $D(^VA( 200,IEN,"P S3")) D
	1257	"RTN","XUS ER",235,0)
	1258	. N NODE
	1259	"RTN","XUS ER",236,0)
	1260	. S NODE= $$STRIP^XL FSTR(^VA(2 00,IEN,"PS 3"),U),NOD E=$$STRIP^ XLFSTR(NOD E,0)
	1261	"RTN","XUS ER",237,0)
	1262	. I $G(NO DE)="" S R ETURN("Is not permit ted to pre scribe any schedules .")="",RET VAL=0 Q
	1263	"RTN","XUS ER",238,0)
	1264	. I $G(NO DE)'="" D
	1265	"RTN","XUS ER",239,0)
	1266	. . N PIE CE,SCHED,S PEC,ASCHED
	1267	"RTN","XUS ER",240,0)
	1268	. . S SPE C("SCHEDUL E ")=""
	1269	"RTN","XUS ER",241,0)
	1270	. . S ASC HED=1
	1271	"RTN","XUS ER",242,0)
	1272	. . F PIE CE=1:1:6 D
	1273	"RTN","XUS ER",243,0)
	1274	. . . I + $P(^VA(200 ,IEN,"PS3" ),U,PIECE) >0 D
	1275	"RTN","XUS ER",244,0)
	1276	. . . . N LABEL,ERR OR
	1277	"RTN","XUS ER",245,0)
	1278	. . . . S LABEL=$$R EPLACE^XLF STR($$GET1 ^DID(200," 55."_PIECE ,,"LABEL", ,"ERROR"), .SPEC)
	1279	"RTN","XUS ER",246,0)
	1280	. . . . S :$G(LABEL) ="" LABEL= "Unknown f ield #55." _PIECE
	1281	"RTN","XUS ER",247,0)
	1282	. . . . S SCHED=$S( $G(SCHED)' ="":SCHED_ U,1:"")_LA BEL
	1283	"RTN","XUS ER",248,0)
	1284	. . . I + $P(^VA(200 ,IEN,"PS3" ),U,PIECE) =0 S ASCHE D=0
	1285	"RTN","XUS ER",249,0)
	1286	. . I ASC HED=1 S RE TURN("Is p ermitted t o prescrib e all sche dules.")=" "
	1287	"RTN","XUS ER",250,0)
	1288	. . I ASC HED=0 D
	1289	"RTN","XUS ER",251,0)
	1290	. . . N D ELIMIT,IND EX,TEXT
	1291	"RTN","XUS ER",252,0)
	1292	. . . S D ELIMIT=", "
	1293	"RTN","XUS ER",253,0)
	1294	. . . F I NDEX=1:1:$ L(SCHED,U) D
	1295	"RTN","XUS ER",254,0)
	1296	. . . . S :INDEX=$L( SCHED,U) D ELIMIT=" a nd "
	1297	"RTN","XUS ER",255,0)
	1298	. . . . S TEXT=$S($ G(TEXT)'=" ":TEXT_DEL IMIT,1:"") _$P(SCHED, U,INDEX)
	1299	"RTN","XUS ER",256,0)
	1300	. . . S R ETURN("Is permitted to prescri be schedul e"_$S($L(S CHED,U)>1: "s",1:"")_ " "_TEXT_" .")=""
	1301	"RTN","XUS ER",257,0)
	1302	;*689
	1303	"RTN","XUS ER",258,0)
	1304	I '$D(^VA (200,IEN," PS3")) S R ETURN("Is not permit ted to pre scribe any schedules .")="",RET VAL=0
	1305	"RTN","XUS ER",259,0)
	1306	Q RETVAL
	1307	"RTN","XUS ER",260,0)
	1308	;
	1309	"RTN","XUS ER",261,0)
	1310	VDEADNM(RE TURN,NPIEN ) ;ISP/RF R - Verify a provide r is prope rly config ured for e PCS
	1311	"RTN","XUS ER",262,0)
	1312	;PARAMETE RS: NPIEN - Interna l Entry Nu mber in th e NEW PERS ON file (# 200)
	1313	"RTN","XUS ER",263,0)
	1314	; RETURN - Referen ce to an a rray in wh ich text e xplaining
	1315	"RTN","XUS ER",264,0)
	1316	; deficie ncies and listing pr escribable schedules
	1317	"RTN","XUS ER",265,0)
	1318	; is plac ed, with e ach defici ency and t he list of
	1319	"RTN","XUS ER",266,0)
	1320	; schedul es on a se parate nod e
	1321	"RTN","XUS ER",267,0)
	1322	;RETURN: 1 - Provid er is prop erly confi gured for ePCS
	1323	"RTN","XUS ER",268,0)
	1324	; 0 - Provid er is not properly c onfigured for ePCS
	1325	"RTN","XUS ER",269,0)
	1326	N CNT,NPD EAIEN,DNDE AIEN,DNDEA TXT,NPDEAL ST,X,Y,DEA ,RETVAL,US ING
	1327	"RTN","XUS ER",270,0)
	1328	S RETVAL= 1,USING=""
	1329	"RTN","XUS ER",271,0)
	1330	S NPDEALS T(0)=0
	1331	"RTN","XUS ER",272,0)
	1332	S NPDEAIE N=0 F S N PDEAIEN=$O (^VA(200,N PIEN,"PS4" ,NPDEAIEN) ) Q:'NPDEA IEN D
	1333	"RTN","XUS ER",273,0)
	1334	. S NPDEA LST(0)=NPD EALST(0)+1
	1335	"RTN","XUS ER",274,0)
	1336	. S NPDEA LST(NPDEAL ST(0))=$$G ET1^DIQ(20 0.5321,NPD EAIEN_","_ NPIEN_",", .01)
	1337	"RTN","XUS ER",275,0)
	1338	. S $P(NP DEALST(NPD EALST(0)), U,2)=$$GET 1^DIQ(200. 5321,NPDEA IEN_","_NP IEN_",",.0 2)
	1339	"RTN","XUS ER",276,0)
	1340	. S $P(NP DEALST(NPD EALST(0)), U,3)=$$GET 1^DIQ(200. 5321,NPDEA IEN_","_NP IEN_",",.0 3,"I")
	1341	"RTN","XUS ER",277,0)
	1342	. S $P(NP DEALST(NPD EALST(0)), U,4)=NPDEA IEN_","_NP IEN_","
	1343	"RTN","XUS ER",278,0)
	1344	. S:$P(NP DEALST(NPD EALST(0)), U,3) $P(NP DEALST(NPD EALST(0)), U,5)=$$GET 1^DIQ(8991 .9,$P(NPDE ALST(NPDEA LST(0)),U, 3)_",",1.6 )
	1345	"RTN","XUS ER",279,0)
	1346	. S NPDEA LST("B",$P (NPDEALST( NPDEALST(0 )),U,1))=N PDEALST(NP DEALST(0))
	1347	"RTN","XUS ER",280,0)
	1348	I NPDEALS T(0)=0 S R ETVAL=0 G VDEADNX
	1349	"RTN","XUS ER",281,0)
	1350	I NPDEALS T(0)=1 D G VDEADNX
	1351	"RTN","XUS ER",282,0)
	1352	. S USING =$P(NPDEAL ST(1),U,1)
	1353	"RTN","XUS ER",283,0)
	1354	. S DNDEA IEN=$P(NPD EALST(1),U ,3)
	1355	"RTN","XUS ER",284,0)
	1356	. I 'DNDE AIEN S RET URN("No li nk to the DEA NUMBER S FILE.")= "",RETVAL= 0
	1357	"RTN","XUS ER",285,0)
	1358	. S RETVA L=$$VDEADN A(.RETURN, NPIEN,DNDE AIEN)
	1359	"RTN","XUS ER",286,0)
	1360	W !!,"Thi s provider has multi ple DEA re gistration s.",!
	1361	"RTN","XUS ER",287,0)
	1362	W "Please select th e DEA numb er you wis h to check :",!!
	1363	"RTN","XUS ER",288,0)
	1364	F CNT=1:1 :NPDEALST( 0) D
	1365	"RTN","XUS ER",289,0)
	1366	. W $E(" ",1,5-$ L(CNT)),CN T," - ",$P (NPDEALST( CNT),U,1)
	1367	"RTN","XUS ER",290,0)
	1368	. W:$P(NP DEALST(CNT ),U,2)'="" "-",$P(NP DEALST(CNT ),U,2)
	1369	"RTN","XUS ER",291,0)
	1370	. W " ",$ P(NPDEALST (CNT),U,5)
	1371	"RTN","XUS ER",292,0)
	1372	. W:$O(NP DEALST(CNT )) !
	1373	"RTN","XUS ER",293,0)
	1374	K DIRUT,D IR S DIR(0 )="F^1:2^K :'$D(NPDEA LST(X))!(X =0) X"
	1375	"RTN","XUS ER",294,0)
	1376	S DIR("A" )="Choose 1 - "_NPDE ALST(0)
	1377	"RTN","XUS ER",295,0)
	1378	S DIR("A" ,1)=" "
	1379	"RTN","XUS ER",296,0)
	1380	S DIR("?" )="Select a choice f rom the li st above."
	1381	"RTN","XUS ER",297,0)
	1382	D ^DIR
	1383	"RTN","XUS ER",298,0)
	1384	W !!
	1385	"RTN","XUS ER",299,0)
	1386	I $G(DIRU T) S RETVA L=0 G VDEA DNX
	1387	"RTN","XUS ER",300,0)
	1388	I '$G(X) S RETVAL=0 G VDEADNX
	1389	"RTN","XUS ER",301,0)
	1390	S USING=$ P(NPDEALST (X),U,1)
	1391	"RTN","XUS ER",302,0)
	1392	S DNDEAIE N=$P(NPDEA LST(X),U,3 )
	1393	"RTN","XUS ER",303,0)
	1394	I 'DNDEAI EN S RETUR N("No link to the DE A NUMBERS FILE.")="" ,RETVAL=0 Q RETVAL
	1395	"RTN","XUS ER",304,0)
	1396	S RETVAL= $$VDEADNA( .RETURN,NP IEN,DNDEAI EN)
	1397	"RTN","XUS ER",305,0)
	1398	VDEADNX ; -- Common Quit Poin t.
	1399	"RTN","XUS ER",306,0)
	1400	Q RETVAL_ "^"_USING
	1401	"RTN","XUS ER",307,0)
	1402	;
	1403	"RTN","XUS ER",308,0)
	1404	VDEADNA(RE TURN,NPIEN ,DNDEAIEN) ; -- ENT RY POINT f or a singl e DEA Numb er
	1405	"RTN","XUS ER",309,0)
	1406	N DATE,DE LIMIT,DNDE ATXT,INDEX ,NODEA,RET VAL,SCH,ST ATUS,USING
	1407	"RTN","XUS ER",310,0)
	1408	S RETVAL= 1
	1409	"RTN","XUS ER",311,0)
	1410	I +$G(NPI EN)=0 S RE TVAL=0 Q R ETVAL
	1411	"RTN","XUS ER",312,0)
	1412	I +$G(DND EAIEN)=0 S RETVAL=0 Q RETVAL
	1413	"RTN","XUS ER",313,0)
	1414	S DNDEATX T=$$GET1^D IQ(8991.9, DNDEAIEN,. 01)
	1415	"RTN","XUS ER",314,0)
	1416	I '$D(^VA (200,NPIEN ,"PS4","B" ,DNDEATXT) ) S RETURN ("User isn 't linked to the DEA Number.") ="" S RETV AL=0 Q RET VAL
	1417	"RTN","XUS ER",315,0)
	1418	S USING=" Using DEA # "_DNDEAT XT_","
	1419	"RTN","XUS ER",316,0)
	1420	S STATUS= $$ACTIVE^X USER(NPIEN )
	1421	"RTN","XUS ER",317,0)
	1422	I STATUS= "" S RETUR N("User ac count does not exist .")="",RET VAL=0
	1423	"RTN","XUS ER",318,0)
	1424	I STATUS= 0 S RETURN ("User can not sign o n.")="",RE TVAL=0
	1425	"RTN","XUS ER",319,0)
	1426	I +STATUS =0,($P(STA TUS,U,2)'= "") S RETU RN("User a ccount sta tus: "_$P( STATUS,U,2 ))="",RETV AL=0
	1427	"RTN","XUS ER",320,0)
	1428	Q:STATUS= "" RETVAL
	1429	"RTN","XUS ER",321,0)
	1430	I '$D(^XU SEC("ORES" ,NPIEN)) D
	1431	"RTN","XUS ER",322,0)
	1432	. S RETUR N("Does no t hold the ORES secu rity key." )="",RETVA L=0
	1433	"RTN","XUS ER",323,0)
	1434	I $$GET1^ DIQ(200,NP IEN,53.1," I")'=1 D
	1435	"RTN","XUS ER",324,0)
	1436	. S RETUR N("Is not authorized to write medication orders.") ="",RETVAL =0
	1437	"RTN","XUS ER",325,0)
	1438	I $$GET1^ DIQ(8991.9 ,DNDEAIEN, .01)'="" D
	1439	"RTN","XUS ER",326,0)
	1440	. S DATE= +$$GET1^DI Q(8991.9,D NDEAIEN,.0 4,"I")
	1441	"RTN","XUS ER",327,0)
	1442	. I DATE= 0 S RETURN ("Has a DE A number w ith no exp iration da te.")="",R ETVAL=0,NO DEA=1
	1443	"RTN","XUS ER",328,0)
	1444	. I DATE> 0,(DATE<=D T) S RETUR N("Has an expired DE A number." )="",RETVA L=0,NODEA= 1
	1445	"RTN","XUS ER",329,0)
	1446	I $$GET1^ DIQ(8991.9 ,DNDEAIEN, .01)="" D
	1447	"RTN","XUS ER",330,0)
	1448	. S NODEA =1
	1449	"RTN","XUS ER",331,0)
	1450	. I $$GET 1^DIQ(200, NPIEN,53.3 )="" D
	1451	"RTN","XUS ER",332,0)
	1452	.. S RETU RN("Has ne ither a DE A number n or a VA nu mber.")="" ,RETVAL=0
	1453	"RTN","XUS ER",333,0)
	1454	I +$G(NOD EA),$$GET1 ^DIQ(200,N PIEN,53.3) '="" S RET VAL=1
	1455	"RTN","XUS ER",334,0)
	1456	S DATE=+$ $GET1^DIQ( 200,NPIEN, 53.4,"I")
	1457	"RTN","XUS ER",335,0)
	1458	I DATE>0, DATE<=DT S RETURN("I s no longe r able to write medi cation ord ers (inact ive date). ")="",RETV AL=0
	1459	"RTN","XUS ER",336,0)
	1460	S SCH("2" )=$$GET1^D IQ(8991.9, DNDEAIEN,2 .1,"I"),SC H("2N")=$$ GET1^DIQ(8 991.9,DNDE AIEN,2.2," I")
	1461	"RTN","XUS ER",337,0)
	1462	S SCH("3" )=$$GET1^D IQ(8991.9, DNDEAIEN,2 .3,"I"),SC H("3N")=$$ GET1^DIQ(8 991.9,DNDE AIEN,2.4," I")
	1463	"RTN","XUS ER",338,0)
	1464	S SCH("4" )=$$GET1^D IQ(8991.9, DNDEAIEN,2 .5,"I"),SC H("5")=$$G ET1^DIQ(89 91.9,DNDEA IEN,2.6,"I ")
	1465	"RTN","XUS ER",339,0)
	1466	I SCH("2" )+SCH("2N" )+SCH("3") +SCH("3N") +SCH("4")+ SCH("5")=0 S RETURN( "Is not pe rmitted to prescribe any sched ules.")="" ,RETVAL=0 Q RETVAL
	1467	"RTN","XUS ER",340,0)
	1468	I SCH("2" )+SCH("2N" )+SCH("3") +SCH("3N") +SCH("4")+ SCH("5")=6 S RETURN( "Is permit ted to pre scribe all schedules .")="",RET VAL=1 Q RE TVAL
	1469	"RTN","XUS ER",341,0)
	1470	S SCH("TO TAL")=""
	1471	"RTN","XUS ER",342,0)
	1472	S:SCH("2" ) SCH("TOT AL")=SCH(" TOTAL")_"I I NARCOTIC ^"
	1473	"RTN","XUS ER",343,0)
	1474	S:SCH("2N ") SCH("TO TAL")=SCH( "TOTAL")_" II NON-NAR COTIC^"
	1475	"RTN","XUS ER",344,0)
	1476	S:SCH("3" ) SCH("TOT AL")=SCH(" TOTAL")_"I II NARCOTI C^"
	1477	"RTN","XUS ER",345,0)
	1478	S:SCH("3N ") SCH("TO TAL")=SCH( "TOTAL")_" III NON-NA RCOTIC^"
	1479	"RTN","XUS ER",346,0)
	1480	S:SCH("4" ) SCH("TOT AL")=SCH(" TOTAL")_"I V^"
	1481	"RTN","XUS ER",347,0)
	1482	S:SCH("5" ) SCH("TOT AL")=SCH(" TOTAL")_"V ^"
	1483	"RTN","XUS ER",348,0)
	1484	S DELIMIT =", "
	1485	"RTN","XUS ER",349,0)
	1486	S SCH("TE XT")=""
	1487	"RTN","XUS ER",350,0)
	1488	F INDEX=1 :1:($L(SCH ("TOTAL"), U)-1) D
	1489	"RTN","XUS ER",351,0)
	1490	. S:INDEX =($L(SCH(" TOTAL"),U) -1) DELIMI T=$S(($L(S CH("TOTAL" ),U)-1)=2: " and ",1: ", and ")
	1491	"RTN","XUS ER",352,0)
	1492	. S SCH(" TEXT")=$S( SCH("TEXT" )'="":SCH( "TEXT")_DE LIMIT,1:"" )_$P(SCH(" TOTAL"),U, INDEX)
	1493	"RTN","XUS ER",353,0)
	1494	S RETURN( "Is permit ted to pre scribe sch edule"_$S( ($L(SCH("T OTAL"),U)- 1)>1:"s",1 :"")_" "_S CH("TEXT") _".")=""
	1495	"RTN","XUS ER",354,0)
	1496	Q RETVAL
	1497	"RTN","XUS ER",355,0)
	1498	;
	1499	"RTN","XUS ER",356,0)
	1500	DIV4(XUROO T,XUDUZ) ; Return the Divisions that this user is a ssigned to .
	1501	"RTN","XUS ER",357,0)
	1502	;Returns 0 - no ins titution f or user, 1 - institu tion for u ser
	1503	"RTN","XUS ER",358,0)
	1504	;XUROOT i s passed b y referenc e.
	1505	"RTN","XUS ER",359,0)
	1506	N %,%1 S: $G(XUDUZ)= "" XUDUZ=D UZ S (%,%1 )=0
	1507	"RTN","XUS ER",360,0)
	1508	F S %=$O (^VA(200,X UDUZ,2,%)) Q:%'>0 S XUROOT(%) =$P($G(^(% ,0)),U,2), %1=1
	1509	"RTN","XUS ER",361,0)
	1510	Q %1
	1511	"RTN","XUS ER",362,0)
	1512	;
	1513	"RTN","XUS ER",363,0)
	1514	NAME(IEN,F L) ;Return the full name from Name Compo nents file
	1515	"RTN","XUS ER",364,0)
	1516	N NA S NA ("FILE")=2 00,NA("FIE LD")=.01,N A("IENS")= IEN
	1517	"RTN","XUS ER",365,0)
	1518	S FL=$G(F L,"G") ;Va lid are Fa mly or Giv en
	1519	"RTN","XUS ER",366,0)
	1520	S:"FG"'[F L FL="G"
	1521	"RTN","XUS ER",367,0)
	1522	Q $$NAMEF MT^XLFNAME (.NA,FL,"C MDP")
	1523	"RTN","XUS ER",368,0)
	1524	;
	1525	"RTN","XUS ER",369,0)
	1526	HL7(IEN) ; Return a H L7 name fr om the com ponents fi le
	1527	"RTN","XUS ER",370,0)
	1528	N NA S NA ("FILE")=2 00,NA("FIE LD")=.01,N A("IENS")= IEN
	1529	"RTN","XUS ER",371,0)
	1530	Q $$HLNAM E^XLFNAME( .NA,"","~" )
	1531	"RTN","XUS ER",372,0)
	1532	;
	1533	"RTN","XUS ER",373,0)
	1534	SCR200() ; Whole File Screen lo gic for fi le 200
	1535	"RTN","XUS ER",374,0)
	1536	; ZEXCEPT : DIC,DIND EX - Kerne l exemptio n
	1537	"RTN","XUS ER",375,0)
	1538	;
	1539	"RTN","XUS ER",376,0)
	1540	; Test to see if Fi leMan can "talk" to the user, IA# 4577
	1541	"RTN","XUS ER",377,0)
	1542	I $G(DIC( 0))'["E" Q 1
	1543	"RTN","XUS ER",378,0)
	1544	;
	1545	"RTN","XUS ER",379,0)
	1546	; Test to see if in dex being searched i s SSN, IA# 4578
	1547	"RTN","XUS ER",380,0)
	1548	I $G(DIND EX)'="SSN" Q 1
	1549	"RTN","XUS ER",381,0)
	1550	;
	1551	"RTN","XUS ER",382,0)
	1552	; Test fo r Security Key
	1553	"RTN","XUS ER",383,0)
	1554	I $G(DUZ) ,$D(^XUSEC ("XUSHOWSS N",DUZ)) Q 1
	1555	"RTN","XUS ER",384,0)
	1556	;
	1557	"RTN","XUS ER",385,0)
	1558	; Default - None of the above is TRUE
	1559	"RTN","XUS ER",386,0)
	1560	Q 0
	1561	"RTN","XUS ER",387,0)
	1562	;
	1563	"RTN","XUS ER",388,0)
	1564	PRDEA(IEN) ;*689
	1565	"RTN","XUS ER",389,0)
	1566	Q:'$D(IEN ) ""
	1567	"RTN","XUS ER",390,0)
	1568	N J,K,NP, RET S RET= "",NP=0
	1569	"RTN","XUS ER",391,0)
	1570	S J=0 F S J=$O(^VA (200,IEN," PS4",J)) Q :'J D Q: $L(RET)
	1571	"RTN","XUS ER",392,0)
	1572	. S NP=1, K=$$GET1^D IQ(200.532 1,J_","_IE N_",",.03, "I") D:K
	1573	"RTN","XUS ER",393,0)
	1574	.. I $$GE T1^DIQ(899 1.9,K,.06, "I") S RET =$$GET1^DI Q(8991.9,K ,.01)
	1575	"RTN","XUS ER",394,0)
	1576	Q:NP RET
	1577	"RTN","XUS ER",395,0)
	1578	Q $$GET1^ DIQ(200,IE N,53.2)
	1579	"RTN","XUS ER",396,0)
	1580	;
	1581	"RTN","XUS ER",397,0)
	1582	PRXDT(IEN) ;*689
	1583	"RTN","XUS ER",398,0)
	1584	Q:'$D(IEN ) ""
	1585	"RTN","XUS ER",399,0)
	1586	N J,K,NP, RET S RET= "",NP=0
	1587	"RTN","XUS ER",400,0)
	1588	S J=0 F S J=$O(^VA (200,IEN," PS4",J)) Q :'J D Q: $L(RET)
	1589	"RTN","XUS ER",401,0)
	1590	. S NP=1, K=$$GET1^D IQ(200.532 1,J_","_IE N_",",.03, "I") D:K
	1591	"RTN","XUS ER",402,0)
	1592	.. I $$GE T1^DIQ(899 1.9,K,.06, "I") S RET =$$GET1^DI Q(8991.9,K ,.04,"I")
	1593	"RTN","XUS ER",403,0)
	1594	Q:NP RET
	1595	"RTN","XUS ER",404,0)
	1596	Q $$GET1^ DIQ(200,IE N,747.44," I")
	1597	"RTN","XUS ER",405,0)
	1598	;
	1599	"RTN","XUS ER",406,0)
	1600	PRSCH(IEN) ;*689
	1601	"RTN","XUS ER",407,0)
	1602	Q:'$D(IEN ) ""
	1603	"RTN","XUS ER",408,0)
	1604	N J,K,NP, RET S RET= "",NP=0
	1605	"RTN","XUS ER",409,0)
	1606	S J=0 F S J=$O(^VA (200,IEN," PS4",J)) Q :'J D Q: $L(RET)
	1607	"RTN","XUS ER",410,0)
	1608	. S NP=1, K=$$GET1^D IQ(200.532 1,J_","_IE N_",",.03, "I") D:K
	1609	"RTN","XUS ER",411,0)
	1610	.. I $$GE T1^DIQ(899 1.9,K,.06, "I") S RET =$G(^XTV(8 991.9,K,2) )
	1611	"RTN","XUS ER",412,0)
	1612	Q:NP RET
	1613	"RTN","XUS ER",413,0)
	1614	Q $G(^VA( 200,IEN,"P S3"))
	1615	"RTN","XUS ER",414,0)
	1616	;
	1617	"RTN","XUS NPIX1")
	1618	0^9^B17212 8281
	1619	"RTN","XUS NPIX1",1,0 )
	1620	XUSNPIX1 ; OAK_BP/CMW - NPI EXT RACT REPOR T ;7/9/08 18:18
	1621	"RTN","XUS NPIX1",2,0 )
	1622	;;8.0;KER NEL;438, 452,453,48 1,528,548, 689; Jul 10, 1995; Build 28
	1623	"RTN","XUS NPIX1",3,0 )
	1624	;;Per VA Directive 6402, this routine s hould not be modifie d.
	1625	"RTN","XUS NPIX1",4,0 )
	1626	;
	1627	"RTN","XUS NPIX1",5,0 )
	1628	; Direct access to ^IBE(350.9 , fields . 02, 1.05, 19;.02, 19 ;1.01, 19; 1.02, 19;1 .03, 19;,1 .04, 19;1. 05 authori zed by
	1629	"RTN","XUS NPIX1",6,0 )
	1630	; Integra tion Agree ment #4964 .
	1631	"RTN","XUS NPIX1",7,0 )
	1632	;
	1633	"RTN","XUS NPIX1",8,0 )
	1634	;
	1635	"RTN","XUS NPIX1",9,0 )
	1636	; NPI Ext ract Repor t
	1637	"RTN","XUS NPIX1",10, 0)
	1638	;
	1639	"RTN","XUS NPIX1",11, 0)
	1640	; Input p arameter: N/A
	1641	"RTN","XUS NPIX1",12, 0)
	1642	;
	1643	"RTN","XUS NPIX1",13, 0)
	1644	; Other r elevant va riables:
	1645	"RTN","XUS NPIX1",14, 0)
	1646	; XUSRT N="XUSNPIX 1" (curren t routine name, used for ^XTMP and ^TMP
	1647	"RTN","XUS NPIX1",15, 0)
	1648	; sto rage subsc ript)
	1649	"RTN","XUS NPIX1",16, 0)
	1650	; Storage Global:
	1651	"RTN","XUS NPIX1",17, 0)
	1652	; ^XTMP ("XUSNPIX1 ",0) = Pie ce 1^Piece 2^Piece 3 ^Piece 4^P iece 5^Pie ce 6
	1653	"RTN","XUS NPIX1",18, 0)
	1654	; wh ere:
	1655	"RTN","XUS NPIX1",19, 0)
	1656	; Pi ece 1 => P urge Date - 1 year i n future
	1657	"RTN","XUS NPIX1",20, 0)
	1658	; Pi ece 2 => C reate Date - Today
	1659	"RTN","XUS NPIX1",21, 0)
	1660	; Pi ece 3 => D escription
	1661	"RTN","XUS NPIX1",22, 0)
	1662	; Pi ece 4 => L ast Date C ompiled
	1663	"RTN","XUS NPIX1",23, 0)
	1664	; Pi ece 5 => $ H last run start tim e
	1665	"RTN","XUS NPIX1",24, 0)
	1666	; Pi ece 6 => $ H last run completio n time
	1667	"RTN","XUS NPIX1",25, 0)
	1668	;
	1669	"RTN","XUS NPIX1",26, 0)
	1670	; ^XTMP ("XUSNPIX1 ",1) = DAT A
	1671	"RTN","XUS NPIX1",27, 0)
	1672	;
	1673	"RTN","XUS NPIX1",28, 0)
	1674	; XUSNPI = > Unique N PI of entr y
	1675	"RTN","XUS NPIX1",29, 0)
	1676	; LDT => L ast Date R un, VA Fil eman Forma t
	1677	"RTN","XUS NPIX1",30, 0)
	1678	;
	1679	"RTN","XUS NPIX1",31, 0)
	1680	; Entry P oint - TAS KMAN => Ru n report i n backgrou nd using T ASKMAN
	1681	"RTN","XUS NPIX1",32, 0)
	1682	;
	1683	"RTN","XUS NPIX1",33, 0)
	1684	Q
	1685	"RTN","XUS NPIX1",34, 0)
	1686	;
	1687	"RTN","XUS NPIX1",35, 0)
	1688	TASKMAN ;T ASKMAN ENT RY POINT
	1689	"RTN","XUS NPIX1",36, 0)
	1690	; Process Report
	1691	"RTN","XUS NPIX1",37, 0)
	1692	N XUSRTN, DTTM,XUSPR OD,XUSVER, INSMAIL,XU SNP2P,XUST MP
	1693	"RTN","XUS NPIX1",38, 0)
	1694	;
	1695	"RTN","XUS NPIX1",39, 0)
	1696	; Check f or require d variable s
	1697	"RTN","XUS NPIX1",40, 0)
	1698	I $G(U)=" "!($G(DT)= "") G EXIT
	1699	"RTN","XUS NPIX1",41, 0)
	1700	S XUSRTN= "XUSNPIX1"
	1701	"RTN","XUS NPIX1",42, 0)
	1702	S DTTM=$$ HTE^XLFDT( $H,"2")
	1703	"RTN","XUS NPIX1",43, 0)
	1704	; Check t o see if r eport is i n use
	1705	"RTN","XUS NPIX1",44, 0)
	1706	L +^XTMP( XUSRTN):5 I '$T G EX IT
	1707	"RTN","XUS NPIX1",45, 0)
	1708	;
	1709	"RTN","XUS NPIX1",46, 0)
	1710	;Reset Su mmary Scra tch Global s
	1711	"RTN","XUS NPIX1",47, 0)
	1712	K ^TMP("X USNPIXS",$ J)
	1713	"RTN","XUS NPIX1",48, 0)
	1714	K ^TMP("X USNPIXT",$ J)
	1715	"RTN","XUS NPIX1",49, 0)
	1716	;
	1717	"RTN","XUS NPIX1",50, 0)
	1718	; Initial ize variab les
	1719	"RTN","XUS NPIX1",51, 0)
	1720	D INIT(XU SRTN)
	1721	"RTN","XUS NPIX1",52, 0)
	1722	;
	1723	"RTN","XUS NPIX1",53, 0)
	1724	; Pull St ation(Inst itution) d ata
	1725	"RTN","XUS NPIX1",54, 0)
	1726	D INST(XU SRTN,XUSVE R,.INSMAIL )
	1727	"RTN","XUS NPIX1",55, 0)
	1728	;
	1729	"RTN","XUS NPIX1",56, 0)
	1730	;Process New Person File
	1731	"RTN","XUS NPIX1",57, 0)
	1732	D PROC1(X USRTN,XUSP ROD,XUSVER ,DTTM,INSM AIL)
	1733	"RTN","XUS NPIX1",58, 0)
	1734	;
	1735	"RTN","XUS NPIX1",59, 0)
	1736	; Process Instituti on File
	1737	"RTN","XUS NPIX1",60, 0)
	1738	D ENT^XUS NPIX2(XUSP ROD,XUSVER )
	1739	"RTN","XUS NPIX1",61, 0)
	1740	;
	1741	"RTN","XUS NPIX1",62, 0)
	1742	; Process Non VA Fi le
	1743	"RTN","XUS NPIX1",63, 0)
	1744	D ENT^XUS NPIX3(XUSP ROD,XUSVER )
	1745	"RTN","XUS NPIX1",64, 0)
	1746	;
	1747	"RTN","XUS NPIX1",65, 0)
	1748	; Send su mmary mess age
	1749	"RTN","XUS NPIX1",66, 0)
	1750	D SMAIL^X USNPIX5("X USNPIXT",X USPROD,XUS VER,DTTM)
	1751	"RTN","XUS NPIX1",67, 0)
	1752	;
	1753	"RTN","XUS NPIX1",68, 0)
	1754	;Standard EXIT poin t
	1755	"RTN","XUS NPIX1",69, 0)
	1756	EXIT ;
	1757	"RTN","XUS NPIX1",70, 0)
	1758	K DTTM,XU SVER,XUSHD R,XUSPROD, INSMAIL
	1759	"RTN","XUS NPIX1",71, 0)
	1760	;
	1761	"RTN","XUS NPIX1",72, 0)
	1762	;Kill off Scratch G lobals
	1763	"RTN","XUS NPIX1",73, 0)
	1764	K ^TMP("X USNPIXS",$ J)
	1765	"RTN","XUS NPIX1",74, 0)
	1766	K ^TMP("X USNPIXT",$ J)
	1767	"RTN","XUS NPIX1",75, 0)
	1768	K ^TMP("X USNPIXU",$ J)
	1769	"RTN","XUS NPIX1",76, 0)
	1770	K ^TMP("P 2P")
	1771	"RTN","XUS NPIX1",77, 0)
	1772	; Log Run Completio n Time
	1773	"RTN","XUS NPIX1",78, 0)
	1774	S $P(^XTM P(XUSRTN,0 ),U,6)=$H
	1775	"RTN","XUS NPIX1",79, 0)
	1776	L -^XTMP( XUSRTN)
	1777	"RTN","XUS NPIX1",80, 0)
	1778	;
	1779	"RTN","XUS NPIX1",81, 0)
	1780	Q
	1781	"RTN","XUS NPIX1",82, 0)
	1782	;
	1783	"RTN","XUS NPIX1",83, 0)
	1784	INIT(XUSRT N) ; check /init vari ables
	1785	"RTN","XUS NPIX1",84, 0)
	1786	N XUSDESC ,IBSIEN,ZN 19,P2PVAL
	1787	"RTN","XUS NPIX1",85, 0)
	1788	; Set to NEXT relea se version from NPM
	1789	"RTN","XUS NPIX1",86, 0)
	1790	; Update the build number her e.
	1791	"RTN","XUS NPIX1",87, 0)
	1792	S XUSVER= "548.14" ; last pa tch to upd ate the st ructure of the data extract (X U8.0548)
	1793	"RTN","XUS NPIX1",88, 0)
	1794	;
	1795	"RTN","XUS NPIX1",89, 0)
	1796	; Get pro duction/te st account flag
	1797	"RTN","XUS NPIX1",90, 0)
	1798	S XUSPROD =$S($$PROD ^XUPROD(1) :"PROD",1: "TEST")
	1799	"RTN","XUS NPIX1",91, 0)
	1800	;
	1801	"RTN","XUS NPIX1",92, 0)
	1802	; Reset T emporary S cratch Glo bal
	1803	"RTN","XUS NPIX1",93, 0)
	1804	D INIT^XU SNPIXU
	1805	"RTN","XUS NPIX1",94, 0)
	1806	K ^TMP(XU SRTN)
	1807	"RTN","XUS NPIX1",95, 0)
	1808	S XUSDESC ="NPI EXTR ACT TYPE 1 - Do Not Delete"
	1809	"RTN","XUS NPIX1",96, 0)
	1810	S ^XTMP(X USRTN,0)=( DT+10000)_ U_DT_U_XUS DESC_U_DT_ U_$H
	1811	"RTN","XUS NPIX1",97, 0)
	1812	; Generat e TMP BCBS Array
	1813	"RTN","XUS NPIX1",98, 0)
	1814	D BCBSID^ XUSNPIXU
	1815	"RTN","XUS NPIX1",99, 0)
	1816	D P2PBASE ^XUSNPIXU( .XUSTMP) ; XUSTMP arr ay used fo r Type 1 a nd 2 VA
	1817	"RTN","XUS NPIX1",100 ,0)
	1818	Q
	1819	"RTN","XUS NPIX1",101 ,0)
	1820	;
	1821	"RTN","XUS NPIX1",102 ,0)
	1822	MAILTO(XMY ) ;sets th e MailMan recipients based on need (XU8 .0548)
	1823	"RTN","XUS NPIX1",103 ,0)
	1824	;
	1825	"RTN","XUS NPIX1",104 ,0)
	1826	;When you don't wan t data to go out to Austin's F SC but you need it t o
	1827	"RTN","XUS NPIX1",105 ,0)
	1828	;stay wit hin the Vi stA's Mail Man for in ternal tes ting, comm ent out se tting
	1829	"RTN","XUS NPIX1",106 ,0)
	1830	;the XMY( "XXX@Q-NPS . DOM A IN . EXT ) array an d add your own MailM an address that
	1831	"RTN","XUS NPIX1",107 ,0)
	1832	;is prese nt in the VistA acco unt your a re on. An example o f an email address
	1833	"RTN","XUS NPIX1",108 ,0)
	1834	;for test ing purpos es is belo w.
	1835	"RTN","XUS NPIX1",109 ,0)
	1836	;
	1837	"RTN","XUS NPIX1",110 ,0)
	1838	;S XMY("T JERNAGEL.S TEVE@ V sID . DNS D O M A I N . E XT ")="" ; fo r testing only
	1839	"RTN","XUS NPIX1",111 ,0)
	1840	;S XMY("T JERNAGEL.S TEVE@CHEY6 5. DNS D O M A IN . E XT ")="" ;for CHEY65 te sting only
	1841	"RTN","XUS NPIX1",112 ,0)
	1842	;S XMY("N ULL.RODGER _B@ V sID . DNS D O M A I N . E XT ")="" ; fo r testing only
	1843	"RTN","XUS NPIX1",113 ,0)
	1844	;S XMY("N ULL.RODGER @CHEY65. DNS D O M A IN . E XT ")="" ; fo r CHEY65 t esting onl y
	1845	"RTN","XUS NPIX1",114 ,0)
	1846	;S XMY("W HITE.DARLE NE@ V sID . DNS D O M A I N . E XT ")="" ; fo r testing only
	1847	"RTN","XUS NPIX1",115 ,0)
	1848	;S XMY("W HITE.DARLE NE@CHEY65. DNS D O M A IN . E XT ")="" ; fo r CHEY65 t esting onl y
	1849	"RTN","XUS NPIX1",116 ,0)
	1850	;
	1851	"RTN","XUS NPIX1",117 ,0)
	1852	;When you want data to go out to Austin 's FSC gro up, uncomm ent this l ine.
	1853	"RTN","XUS NPIX1",118 ,0)
	1854	S XMY("XX X@Q-NPS. DOM A IN . EXT ")="" ;uncomment to run fo r live ***
	1855	"RTN","XUS NPIX1",119 ,0)
	1856	Q
	1857	"RTN","XUS NPIX1",120 ,0)
	1858	;
	1859	"RTN","XUS NPIX1",121 ,0)
	1860	INST(XUSRT N,XUSVER,I NSMAIL) ;P ull statio n and Inst itution in fo
	1861	"RTN","XUS NPIX1",122 ,0)
	1862	N INST,SI NFO,DIC4
	1863	"RTN","XUS NPIX1",123 ,0)
	1864	; Pull si te info
	1865	"RTN","XUS NPIX1",124 ,0)
	1866	S SINFO=$ $SITE^VASI TE
	1867	"RTN","XUS NPIX1",125 ,0)
	1868	; Station Number
	1869	"RTN","XUS NPIX1",126 ,0)
	1870	S SITE=$P (SINFO,U,3 )
	1871	"RTN","XUS NPIX1",127 ,0)
	1872	; Institu tion
	1873	"RTN","XUS NPIX1",128 ,0)
	1874	S INST=$P (SINFO,U)
	1875	"RTN","XUS NPIX1",129 ,0)
	1876	;
	1877	"RTN","XUS NPIX1",130 ,0)
	1878	; Get ins titution m ailing add ress
	1879	"RTN","XUS NPIX1",131 ,0)
	1880	I INST D
	1881	"RTN","XUS NPIX1",132 ,0)
	1882	. S DIC4= $G(^DIC(4, INST,4))
	1883	"RTN","XUS NPIX1",133 ,0)
	1884	. S XUSNP (7)=$P(DIC 4,U)
	1885	"RTN","XUS NPIX1",134 ,0)
	1886	. S XUSNP (8)=$P(DIC 4,U,2)
	1887	"RTN","XUS NPIX1",135 ,0)
	1888	. S XUSNP (9)=$P(DIC 4,U,3)
	1889	"RTN","XUS NPIX1",136 ,0)
	1890	. S XUSNP (10)=$P(DI C4,U,4)
	1891	"RTN","XUS NPIX1",137 ,0)
	1892	. I XUSNP (10) S XUS NP(10)=$P( $G(^DIC(5, XUSNP(10), 0)),U,2)
	1893	"RTN","XUS NPIX1",138 ,0)
	1894	. S XUSNP (11)=$P(DI C4,U,5)
	1895	"RTN","XUS NPIX1",139 ,0)
	1896	. S INSMA IL=XUSNP(7 )_U_XUSNP( 8)_U_XUSNP (9)_U_XUSN P(10)_U_XU SNP(11)
	1897	"RTN","XUS NPIX1",140 ,0)
	1898	S XUSHDR= "Station: "_SITE_U_X USNP(9)_U_ XUSNP(10)_ U_XUSNP(11 )_U_"TYPE 1"_U_XUSVE R
	1899	"RTN","XUS NPIX1",141 ,0)
	1900	;
	1901	"RTN","XUS NPIX1",142 ,0)
	1902	Q
	1903	"RTN","XUS NPIX1",143 ,0)
	1904	;
	1905	"RTN","XUS NPIX1",144 ,0)
	1906	PROC1(XUSR TN,XUSPROD ,XUSVER,DT TM,INSMAIL ) ;Process all New P erson reco rds
	1907	"RTN","XUS NPIX1",145 ,0)
	1908	N XUSNPI, XUSDT,XUSN EW,XUSI,XU SDATA,XUSV A0,XUSVA0, XUSVA1,XUS NAME,XUSDO B,XUSDIV,X USSTL,XUSS TLN,XUSOPN
	1909	"RTN","XUS NPIX1",146 ,0)
	1910	N XUSPER, XUSSPC,XUS TAX,XUSTAX ID,XUSIZE, NPIEN,DIC4 ,SPDIV,VA1 2,VA13,COU NT,MSGCNT, MAXSIZE,TO TREC,XUSEO L
	1911	"RTN","XUS NPIX1",147 ,0)
	1912	N FND,XUS USCT,XUSUS C1,I
	1913	"RTN","XUS NPIX1",148 ,0)
	1914	;
	1915	"RTN","XUS NPIX1",149 ,0)
	1916	; Set to 300000 for live
	1917	"RTN","XUS NPIX1",150 ,0)
	1918	S MAXSIZE =300000
	1919	"RTN","XUS NPIX1",151 ,0)
	1920	;
	1921	"RTN","XUS NPIX1",152 ,0)
	1922	; Set end of line c haracter
	1923	"RTN","XUS NPIX1",153 ,0)
	1924	S XUSEOL= "~~"
	1925	"RTN","XUS NPIX1",154 ,0)
	1926	;
	1927	"RTN","XUS NPIX1",155 ,0)
	1928	; set cou nter
	1929	"RTN","XUS NPIX1",156 ,0)
	1930	S COUNT=1 ,(TOTREC,M SGCNT,XUSI ZE)=0
	1931	"RTN","XUS NPIX1",157 ,0)
	1932	;
	1933	"RTN","XUS NPIX1",158 ,0)
	1934	; Loop th rough NEW PERSON NPI records N PI cross r ef
	1935	"RTN","XUS NPIX1",159 ,0)
	1936	S XUSNPI= 0
	1937	"RTN","XUS NPIX1",160 ,0)
	1938	F S XUSN PI=$O(^VA( 200,"ANPI" ,XUSNPI)) Q:'XUSNPI D
	1939	"RTN","XUS NPIX1",161 ,0)
	1940	. S NPIEN =$O(^VA(20 0,"ANPI",X USNPI,""))
	1941	"RTN","XUS NPIX1",162 ,0)
	1942	. ;
	1943	"RTN","XUS NPIX1",163 ,0)
	1944	. ; Init columns
	1945	"RTN","XUS NPIX1",164 ,0)
	1946	. ;F XUSI =1:1:29 S XUSNP(XUSI )=""
	1947	"RTN","XUS NPIX1",165 ,0)
	1948	. F XUSI= 1:1:33 S X USNP(XUSI) =""
	1949	"RTN","XUS NPIX1",166 ,0)
	1950	. S XUSNP (1)=XUSNPI S XUSDATA 1=XUSNP(1)
	1951	"RTN","XUS NPIX1",167 ,0)
	1952	. ;
	1953	"RTN","XUS NPIX1",168 ,0)
	1954	. S XUSVA 0=$G(^VA(2 00,NPIEN,0 ))
	1955	"RTN","XUS NPIX1",169 ,0)
	1956	. S XUSVA 1=$G(^VA(2 00,NPIEN,1 ))
	1957	"RTN","XUS NPIX1",170 ,0)
	1958	. S XUSNA ME=$P(XUSV A0,U)
	1959	"RTN","XUS NPIX1",171 ,0)
	1960	. ;
	1961	"RTN","XUS NPIX1",172 ,0)
	1962	. ; Break name into component s
	1963	"RTN","XUS NPIX1",173 ,0)
	1964	. I XUSNA ME'="" D
	1965	"RTN","XUS NPIX1",174 ,0)
	1966	. . S XLF NC=XUSNAME D FORMAT^ XLFNAME7(. XLFNC,,,,0 )
	1967	"RTN","XUS NPIX1",175 ,0)
	1968	. . S XUS NP(2)=XLFN C("GIVEN") ,XUSNP(3)= XLFNC("MID DLE"),XUSN P(4)=XLFNC ("FAMILY")
	1969	"RTN","XUS NPIX1",176 ,0)
	1970	. . I XLF NC("SUFFIX ")'="" S X USNP(4)=XU SNP(4)_" " _XLFNC("SU FFIX")
	1971	"RTN","XUS NPIX1",177 ,0)
	1972	. . K XLF NC
	1973	"RTN","XUS NPIX1",178 ,0)
	1974	. S XUSDA TA1=XUSDAT A1_U_XUSNP (2)_U_XUSN P(3)_U_XUS NP(4)
	1975	"RTN","XUS NPIX1",179 ,0)
	1976	. ;
	1977	"RTN","XUS NPIX1",180 ,0)
	1978	. S XUSNP (5)=1 ;typ e
	1979	"RTN","XUS NPIX1",181 ,0)
	1980	. S XUSDO B=$P(XUSVA 1,U,3)
	1981	"RTN","XUS NPIX1",182 ,0)
	1982	. ; dob f ormatted a s mm/dd/yy yy
	1983	"RTN","XUS NPIX1",183 ,0)
	1984	. I XUSDO B D
	1985	"RTN","XUS NPIX1",184 ,0)
	1986	. . S XUS NP(6)=$$FM TE^XLFDT(X USDOB,5)
	1987	"RTN","XUS NPIX1",185 ,0)
	1988	. S XUSDA TA1=XUSDAT A1_U_XUSNP (5)_U_XUSN P(6)
	1989	"RTN","XUS NPIX1",186 ,0)
	1990	. ;
	1991	"RTN","XUS NPIX1",187 ,0)
	1992	. ; Offic e Phone nu mber
	1993	"RTN","XUS NPIX1",188 ,0)
	1994	. S XUSOP N=$P($G(^V A(200,NPIE N,.13)),U, 2)
	1995	"RTN","XUS NPIX1",189 ,0)
	1996	. ;I XUSO PN'="" S X USNP(17)=X USOPN
	1997	"RTN","XUS NPIX1",190 ,0)
	1998	. I XUSOP N'="" S XU SNP(18)=XU SOPN
	1999	"RTN","XUS NPIX1",191 ,0)
	2000	. ;
	2001	"RTN","XUS NPIX1",192 ,0)
	2002	. ; Servi cing Provi der Addres s
	2003	"RTN","XUS NPIX1",193 ,0)
	2004	. S (XUSD IV)=0
	2005	"RTN","XUS NPIX1",194 ,0)
	2006	. ; Loop through Di vision mul tiple
	2007	"RTN","XUS NPIX1",195 ,0)
	2008	. F S XU SDIV=$O(^V A(200,NPIE N,2,XUSDIV )) Q:'XUSD IV D
	2009	"RTN","XUS NPIX1",196 ,0)
	2010	. . S DIC 4=$G(^DIC( 4,XUSDIV,4 ))
	2011	"RTN","XUS NPIX1",197 ,0)
	2012	. . S XUS NP(13)=$P( DIC4,U)
	2013	"RTN","XUS NPIX1",198 ,0)
	2014	. . S XUS NP(14)=$P( DIC4,U,2)
	2015	"RTN","XUS NPIX1",199 ,0)
	2016	. . S XUS NP(15)=$P( DIC4,U,3)
	2017	"RTN","XUS NPIX1",200 ,0)
	2018	. . S XUS NP(16)=$P( DIC4,U,4)
	2019	"RTN","XUS NPIX1",201 ,0)
	2020	. . I XUS NP(16) S X USNP(16)=$ P($G(^DIC( 5,XUSNP(16 ),0)),U,2)
	2021	"RTN","XUS NPIX1",202 ,0)
	2022	. . S XUS NP(17)=$P( DIC4,U,5)
	2023	"RTN","XUS NPIX1",203 ,0)
	2024	. . S XUS STA(XUSDIV )=$P($G(^D IC(4,XUSDI V,99)),U)
	2025	"RTN","XUS NPIX1",204 ,0)
	2026	. . S SPA DR(XUSDIV) =XUSNP(13) _U_XUSNP(1 4)_U_XUSNP (15)_U_XUS NP(16)_U_X USNP(17)_U _XUSNP(18)
	2027	"RTN","XUS NPIX1",205 ,0)
	2028	. ;
	2029	"RTN","XUS NPIX1",206 ,0)
	2030	. ; If no divisions found
	2031	"RTN","XUS NPIX1",207 ,0)
	2032	. I '$D(S PADR) D
	2033	"RTN","XUS NPIX1",208 ,0)
	2034	. . S XUS STA(9999)= "N/A",SPAD R(9999)=XU SNP(13)_U_ XUSNP(14)_ U_XUSNP(15 )_U_XUSNP( 16)_U_XUSN P(17)_U_XU SNP(18)
	2035	"RTN","XUS NPIX1",209 ,0)
	2036	. ;
	2037	"RTN","XUS NPIX1",210 ,0)
	2038	. ; Degre e
	2039	"RTN","XUS NPIX1",211 ,0)
	2040	. S XUSNP (19)=$P($G (^VA(200,N PIEN,3.1)) ,U,6)
	2041	"RTN","XUS NPIX1",212 ,0)
	2042	. ; Degre e Code (pl ace holder , currentl y empty)
	2043	"RTN","XUS NPIX1",213 ,0)
	2044	. S XUSNP (20)=""
	2045	"RTN","XUS NPIX1",214 ,0)
	2046	. ;
	2047	"RTN","XUS NPIX1",215 ,0)
	2048	. ; get p rimary spe cialty
	2049	"RTN","XUS NPIX1",216 ,0)
	2050	. S XUSPE R=0
	2051	"RTN","XUS NPIX1",217 ,0)
	2052	. F S XU SPER=$O(^V A(200,NPIE N,"USC1"," B",XUSPER) ) Q:'XUSPE R D
	2053	"RTN","XUS NPIX1",218 ,0)
	2054	. . S XUS SPC=$P($G( ^USC(8932. 1,XUSPER,0 )),U,9)
	2055	"RTN","XUS NPIX1",219 ,0)
	2056	. . ;S XU STAX=$P($G (^USC(8932 .1,XUSPER, 0)),U,7)
	2057	"RTN","XUS NPIX1",220 ,0)
	2058	. . I XUS SPC'="" D
	2059	"RTN","XUS NPIX1",221 ,0)
	2060	. . . ;I XUSNP(20)= "" S XUSNP (20)=XUSSP C Q
	2061	"RTN","XUS NPIX1",222 ,0)
	2062	. . . ;S XUSNP(20)= XUSNP(20)_ ";"_XUSSPC
	2063	"RTN","XUS NPIX1",223 ,0)
	2064	. . . I X USNP(21)=" " S XUSNP( 21)=XUSSPC Q
	2065	"RTN","XUS NPIX1",224 ,0)
	2066	. . . S X USNP(21)=X USNP(21)_" ;"_XUSSPC
	2067	"RTN","XUS NPIX1",225 ,0)
	2068	. . . Q
	2069	"RTN","XUS NPIX1",226 ,0)
	2070	. . Q
	2071	"RTN","XUS NPIX1",227 ,0)
	2072	. ;get ta xonomy (pr imary and all second aries)
	2073	"RTN","XUS NPIX1",228 ,0)
	2074	. N XUSCL ASS,XUSEXP DT ; ptr to Person class, ex piration d ate
	2075	"RTN","XUS NPIX1",229 ,0)
	2076	. S XUSPE R=0
	2077	"RTN","XUS NPIX1",230 ,0)
	2078	. K ^XTMP ("USC1",$J )
	2079	"RTN","XUS NPIX1",231 ,0)
	2080	. F S XU SPER=$O(^V A(200,NPIE N,"USC1"," AD",XUSPER )) Q:'XUSP ER D
	2081	"RTN","XUS NPIX1",232 ,0)
	2082	. . S XUS USC1=""
	2083	"RTN","XUS NPIX1",233 ,0)
	2084	. . F S XUSUSC1=$O (^VA(200,N PIEN,"USC1 ","AD",XUS PER,XUSUSC 1)) Q:XUSU SC1="" D
	2085	"RTN","XUS NPIX1",234 ,0)
	2086	. . . S X USCLASS=$P ($G(^VA(20 0,NPIEN,"U SC1",XUSUS C1,0)),U), XUSEXPDT=$ P($G(^VA(2 00,NPIEN," USC1",XUSU SC1,0)),U, 3)
	2087	"RTN","XUS NPIX1",235 ,0)
	2088	. . . S ^ XTMP("USC1 ",$J,XUSUS C1)=XUSEXP DT_U_XUSCL ASS
	2089	"RTN","XUS NPIX1",236 ,0)
	2090	. . . Q
	2091	"RTN","XUS NPIX1",237 ,0)
	2092	. . Q
	2093	"RTN","XUS NPIX1",238 ,0)
	2094	. ;find p rimary tax onomy code
	2095	"RTN","XUS NPIX1",239 ,0)
	2096	. S XUSUS C1="",FND= 0,XUSUSCT= ""
	2097	"RTN","XUS NPIX1",240 ,0)
	2098	. F S XU SUSC1=$O(^ XTMP("USC1 ",$J,XUSUS C1),-1) Q: XUSUSC1="" !(FND=1) D
	2099	"RTN","XUS NPIX1",241 ,0)
	2100	. . I $P( $G(^XTMP(" USC1",$J,X USUSC1)),U )'="" Q ; not ac tive, expi ration dt exists
	2101	"RTN","XUS NPIX1",242 ,0)
	2102	. . S XUS CLASS=$P($ G(^XTMP("U SC1",$J,XU SUSC1)),U, 2)
	2103	"RTN","XUS NPIX1",243 ,0)
	2104	. . I XUS CLASS="" Q
	2105	"RTN","XUS NPIX1",244 ,0)
	2106	. . S XUS NP(22)=$P( $G(^USC(89 32.1,XUSCL ASS,0)),U, 7),FND=1,X USUSCT=XUS USC1
	2107	"RTN","XUS NPIX1",245 ,0)
	2108	. . Q
	2109	"RTN","XUS NPIX1",246 ,0)
	2110	. I $D(^X TMP("USC1" ,$J))&$G(X USUSCT) K ^XTMP("USC 1",$J,XUSU SCT) ;remo ve the act ive taxono my code
	2111	"RTN","XUS NPIX1",247 ,0)
	2112	. S XUSUS C1=""
	2113	"RTN","XUS NPIX1",248 ,0)
	2114	. F S XU SUSC1=$O(^ XTMP("USC1 ",$J,XUSUS C1)) Q:XUS USC1="" D
	2115	"RTN","XUS NPIX1",249 ,0)
	2116	. . S XUS CLASS=$P($ G(^XTMP("U SC1",$J,XU SUSC1)),U, 2)
	2117	"RTN","XUS NPIX1",250 ,0)
	2118	. . I XUS CLASS="" Q
	2119	"RTN","XUS NPIX1",251 ,0)
	2120	. . S XUS TAX=$P($G( ^USC(8932. 1,XUSCLASS ,0)),U,7)
	2121	"RTN","XUS NPIX1",252 ,0)
	2122	. . I XUS TAX'="" D
	2123	"RTN","XUS NPIX1",253 ,0)
	2124	. . . ;
	2125	"RTN","XUS NPIX1",254 ,0)
	2126	. . . I X USNP(23)=" " S XUSNP( 23)=XUSTAX Q
	2127	"RTN","XUS NPIX1",255 ,0)
	2128	. . . ;
	2129	"RTN","XUS NPIX1",256 ,0)
	2130	. . . ; * ** Start ^ XU8.0548 - RBN ***
	2131	"RTN","XUS NPIX1",257 ,0)
	2132	. . . ;
	2133	"RTN","XUS NPIX1",258 ,0)
	2134	. . . ;S XUSNP(23)= XUSNP(23)_ ";"_XUSTAX
	2135	"RTN","XUS NPIX1",259 ,0)
	2136	. . . S:( XUSNP(23)' [XUSTAX&(X USTAX'=XUS NP(22))) X USNP(23)=X USNP(23)_" ;"_XUSTAX
	2137	"RTN","XUS NPIX1",260 ,0)
	2138	. . . ;
	2139	"RTN","XUS NPIX1",261 ,0)
	2140	. . . ; * ** End ^XU 8.0548 - RBN ***
	2141	"RTN","XUS NPIX1",262 ,0)
	2142	. . . ;
	2143	"RTN","XUS NPIX1",263 ,0)
	2144	. ;
	2145	"RTN","XUS NPIX1",264 ,0)
	2146	. ; Tax I D
	2147	"RTN","XUS NPIX1",265 ,0)
	2148	. S XUSTA XID=$P($G( ^VA(200,NP IEN,"TPB") ),U,2)
	2149	"RTN","XUS NPIX1",266 ,0)
	2150	. I XUSTA XID="" S X USTAXID=$P ($G(^VA(20 0,NPIEN,1) ),U,9)
	2151	"RTN","XUS NPIX1",267 ,0)
	2152	. ;S XUSN P(22)=XUST AXID
	2153	"RTN","XUS NPIX1",268 ,0)
	2154	. S XUSNP (24)=XUSTA XID
	2155	"RTN","XUS NPIX1",269 ,0)
	2156	. ;
	2157	"RTN","XUS NPIX1",270 ,0)
	2158	. ;S XUSD ATA2=XUSNP (17)_U_XUS NP(18)_U_X USNP(19)_U _XUSNP(20) _U_XUSNP(2 1)_U_XUSNP (22)
	2159	"RTN","XUS NPIX1",271 ,0)
	2160	. S XUSDA TA2=XUSNP( 19)_U_XUSN P(20)_U_XU SNP(21)_U_ XUSNP(22)_ U_XUSNP(23 )_U_XUSNP( 24)
	2161	"RTN","XUS NPIX1",272 ,0)
	2162	. ;
	2163	"RTN","XUS NPIX1",273 ,0)
	2164	. ; Medic are Part A /B
	2165	"RTN","XUS NPIX1",274 ,0)
	2166	. ;S XUSN P(23)=6708 99
	2167	"RTN","XUS NPIX1",275 ,0)
	2168	. ;S XUSN P(24)="VA" _$E(SITE+1 0000,2,5)
	2169	"RTN","XUS NPIX1",276 ,0)
	2170	. S XUSNP (25)=67089 9
	2171	"RTN","XUS NPIX1",277 ,0)
	2172	. S XUSNP (26)="VA"_ $E(SITE+10 000,2,5)
	2173	"RTN","XUS NPIX1",278 ,0)
	2174	. ;
	2175	"RTN","XUS NPIX1",279 ,0)
	2176	. ; State License
	2177	"RTN","XUS NPIX1",280 ,0)
	2178	. S XUSST L=0
	2179	"RTN","XUS NPIX1",281 ,0)
	2180	. F S XU SSTL=$O(^V A(200,NPIE N,"PS1",XU SSTL)) Q:' XUSSTL D
	2181	"RTN","XUS NPIX1",282 ,0)
	2182	. . S XUS STLN=$P($G (^VA(200,N PIEN,"PS1" ,XUSSTL,0) ),U,2)
	2183	"RTN","XUS NPIX1",283 ,0)
	2184	. . I XUS STLN'="" D
	2185	"RTN","XUS NPIX1",284 ,0)
	2186	. . . ;I XUSNP(25)= "" S XUSNP (25)=XUSST LN Q
	2187	"RTN","XUS NPIX1",285 ,0)
	2188	. . . ;S XUSNP(25)= XUSNP(25)_ ";"_XUSSTL N
	2189	"RTN","XUS NPIX1",286 ,0)
	2190	. . . I X USNP(27)=" " S XUSNP( 27)=XUSSTL N Q
	2191	"RTN","XUS NPIX1",287 ,0)
	2192	. . . ;S XUSNP(27)= XUSNP(27)_ ";"_XUSSTL N
	2193	"RTN","XUS NPIX1",288 ,0)
	2194	. ;S XUSN P(28)=$P($ G(^VA(200, NPIEN,"PS" )),U,2)
	2195	"RTN","XUS NPIX1",289 ,0)
	2196	. ; *689 - DEA #
	2197	"RTN","XUS NPIX1",290 ,0)
	2198	. S XUSNP (28)=$$PRD EA^XUSER(N PIEN)
	2199	"RTN","XUS NPIX1",291 ,0)
	2200	. ;
	2201	"RTN","XUS NPIX1",292 ,0)
	2202	. ;S XUSD ATA2=XUSDA TA2_U_XUSN P(23)_U_XU SNP(24)_U_ XUSNP(25)_ U_XUSNP(26 )
	2203	"RTN","XUS NPIX1",293 ,0)
	2204	. S XUSDA TA2=XUSDAT A2_U_XUSNP (25)_U_XUS NP(26)_U_X USNP(27)_U _XUSNP(28)
	2205	"RTN","XUS NPIX1",294 ,0)
	2206	. ;
	2207	"RTN","XUS NPIX1",295 ,0)
	2208	. ; Add l ogic for S TATUS and CREATION/T ERMINATION DATE from file #200
	2209	"RTN","XUS NPIX1",296 ,0)
	2210	. S XUSNP (29)="",XU SNP(30)=""
	2211	"RTN","XUS NPIX1",297 ,0)
	2212	. S XUSNP (29)=$P($G (^VA(200,N PIEN,0)),U ,11)
	2213	"RTN","XUS NPIX1",298 ,0)
	2214	. I $G(XU SNP(29))'= "" S XUSNP (30)=$$FMT E^XLFDT(XU SNP(29),5) ,XUSNP(29) ="TERMINAT ED"
	2215	"RTN","XUS NPIX1",299 ,0)
	2216	. I $G(XU SNP(29))=" " S XUSNP( 29)=$P($G( ^VA(200,NP IEN,1)),U, 7),XUSNP(3 0)=$$FMTE^ XLFDT(XUSN P(29),5),X USNP(29)=" ACTIVE"
	2217	"RTN","XUS NPIX1",300 ,0)
	2218	. ;
	2219	"RTN","XUS NPIX1",301 ,0)
	2220	. S XUSDA TA2=XUSDAT A2_U_XUSNP (29)_U_XUS NP(30)
	2221	"RTN","XUS NPIX1",302 ,0)
	2222	. ;
	2223	"RTN","XUS NPIX1",303 ,0)
	2224	. ; Get B CBS Payer ID Array
	2225	"RTN","XUS NPIX1",304 ,0)
	2226	. K XUSBX ID
	2227	"RTN","XUS NPIX1",305 ,0)
	2228	. D PRACI D^XUSNPIXU (NPIEN,.XU SBXID)
	2229	"RTN","XUS NPIX1",306 ,0)
	2230	. ;
	2231	"RTN","XUS NPIX1",307 ,0)
	2232	. ; Save entry to ^ TMP and up date count
	2233	"RTN","XUS NPIX1",308 ,0)
	2234	. N XUSB, XUSB1
	2235	"RTN","XUS NPIX1",309 ,0)
	2236	. S XUSDI V=0
	2237	"RTN","XUS NPIX1",310 ,0)
	2238	. F S XU SDIV=$O(SP ADR(XUSDIV )) Q:'XUSD IV D
	2239	"RTN","XUS NPIX1",311 ,0)
	2240	. . ;
	2241	"RTN","XUS NPIX1",312 ,0)
	2242	. . ; Pay to Provid er Address NP7-12
	2243	"RTN","XUS NPIX1",313 ,0)
	2244	. . I $D( XUSTMP("P2 P",XUSDIV) ) D
	2245	"RTN","XUS NPIX1",314 ,0)
	2246	. . . S $ P(XUSDATA1 ,U,7)=$P($ G(^IBE(350 .9,1,19,$G (XUSTMP("P 2P",XUSDIV )),0)),U,2 )
	2247	"RTN","XUS NPIX1",315 ,0)
	2248	. . . S $ P(XUSDATA1 ,U,8)=$P($ G(^IBE(350 .9,1,19,$G (XUSTMP("P 2P",XUSDIV )),1)),U,1 )
	2249	"RTN","XUS NPIX1",316 ,0)
	2250	. . . S $ P(XUSDATA1 ,U,9)=$P($ G(^IBE(350 .9,1,19,$G (XUSTMP("P 2P",XUSDIV )),1)),U,2 )
	2251	"RTN","XUS NPIX1",317 ,0)
	2252	. . . S $ P(XUSDATA1 ,U,10)=$P( $G(^IBE(35 0.9,1,19,$ G(XUSTMP(" P2P",XUSDI V)),1)),U, 3)
	2253	"RTN","XUS NPIX1",318 ,0)
	2254	. . . S $ P(XUSDATA1 ,U,11)=$P( $G(^IBE(35 0.9,1,19,$ G(XUSTMP(" P2P",XUSDI V)),1)),U, 4)
	2255	"RTN","XUS NPIX1",319 ,0)
	2256	. . . I $ P(XUSDATA1 ,U,11)?1N. N S $P(XUS DATA1,U,11 )=$P($G(^D IC(5,$P(XU SDATA1,U,1 1),0)),U,2 )
	2257	"RTN","XUS NPIX1",320 ,0)
	2258	. . . S $ P(XUSDATA1 ,U,12)=$P( $G(^IBE(35 0.9,1,19,$ G(XUSTMP(" P2P",XUSDI V)),1)),U, 5)
	2259	"RTN","XUS NPIX1",321 ,0)
	2260	. . . Q
	2261	"RTN","XUS NPIX1",322 ,0)
	2262	. . I '$D (XUSTMP("P 2P",XUSDIV )) D
	2263	"RTN","XUS NPIX1",323 ,0)
	2264	. . . I ' $D(XUSTMP( "P2P","DEF AULT")) D Q
	2265	"RTN","XUS NPIX1",324 ,0)
	2266	. . . . F I=7:1:12 S $P(XUSDA TA1,U,I)=" "
	2267	"RTN","XUS NPIX1",325 ,0)
	2268	. . . N X USDEF
	2269	"RTN","XUS NPIX1",326 ,0)
	2270	. . . S X USDEF=$G(X USTMP("P2P ","DEFAULT "))
	2271	"RTN","XUS NPIX1",327 ,0)
	2272	. . . S $ P(XUSDATA1 ,U,7)=$P($ G(^IBE(350 .9,1,19,XU SDEF,0)),U ,2)
	2273	"RTN","XUS NPIX1",328 ,0)
	2274	. . . S $ P(XUSDATA1 ,U,8)=$P($ G(^IBE(350 .9,1,19,XU SDEF,1)),U ,1)
	2275	"RTN","XUS NPIX1",329 ,0)
	2276	. . . S $ P(XUSDATA1 ,U,9)=$P($ G(^IBE(350 .9,1,19,XU SDEF,1)),U ,2)
	2277	"RTN","XUS NPIX1",330 ,0)
	2278	. . . S $ P(XUSDATA1 ,U,10)=$P( $G(^IBE(35 0.9,1,19,X USDEF,1)), U,3)
	2279	"RTN","XUS NPIX1",331 ,0)
	2280	. . . S $ P(XUSDATA1 ,U,11)=$P( $G(^IBE(35 0.9,1,19,X USDEF,1)), U,4)
	2281	"RTN","XUS NPIX1",332 ,0)
	2282	. . . I $ P(XUSDATA1 ,U,11)?1N. N S $P(XUS DATA1,U,11 )=$P($G(^D IC(5,$P(XU SDATA1,U,1 1),0)),U,2 )
	2283	"RTN","XUS NPIX1",333 ,0)
	2284	. . . S $ P(XUSDATA1 ,U,12)=$P( $G(^IBE(35 0.9,1,19,X USDEF,1)), U,5)
	2285	"RTN","XUS NPIX1",334 ,0)
	2286	. . . Q
	2287	"RTN","XUS NPIX1",335 ,0)
	2288	. . ;
	2289	"RTN","XUS NPIX1",336 ,0)
	2290	. . S COU NT=COUNT+1 ,TOTREC=TO TREC+1
	2291	"RTN","XUS NPIX1",337 ,0)
	2292	. . S ^TM P(XUSRTN,$ J,COUNT)=X USDATA1_U_ SPADR(XUSD IV)_U_XUSD ATA2_U_XUS STA(XUSDIV )_U_XUSEOL
	2293	"RTN","XUS NPIX1",338 ,0)
	2294	. . S XUS IZE=XUSIZE +$L(^TMP(X USRTN,$J,C OUNT))
	2295	"RTN","XUS NPIX1",339 ,0)
	2296	. . ; Che ck BCBS Id array
	2297	"RTN","XUS NPIX1",340 ,0)
	2298	. . I $D( XUSBXID) D
	2299	"RTN","XUS NPIX1",341 ,0)
	2300	. . . S X USB=""
	2301	"RTN","XUS NPIX1",342 ,0)
	2302	. . . F S XUSB=$O( XUSBXID(XU SB)) Q:XUS B="" D
	2303	"RTN","XUS NPIX1",343 ,0)
	2304	. . . . S XUSB1=$G( XUSBXID(XU SB)) I XUS B1'="" S X USB1="^"_X USB1 ;add p528
	2305	"RTN","XUS NPIX1",344 ,0)
	2306	. . . . S COUNT=COU NT+1,TOTRE C=TOTREC+1
	2307	"RTN","XUS NPIX1",345 ,0)
	2308	. . . . S ^TMP(XUSR TN,$J,COUN T)=XUSDATA 1_U_SPADR( XUSDIV)_U_ XUSDATA2_U _XUSSTA(XU SDIV)_U_$$ TRIM^XLFST R(XUSB)_XU SB1_U_XUSE OL ;add _X USB1 p 528
	2309	"RTN","XUS NPIX1",346 ,0)
	2310	. . . . S XUSIZE=XU SIZE+$L(^T MP(XUSRTN, $J,COUNT))
	2311	"RTN","XUS NPIX1",347 ,0)
	2312	. K XUSNP ,XUSDATA1, XUSDATA2,X USDATA3,SP ADR,XUSBXI D,CNT,XUSS TA
	2313	"RTN","XUS NPIX1",348 ,0)
	2314	. I XUSIZ E>MAXSIZE D
	2315	"RTN","XUS NPIX1",349 ,0)
	2316	. . D EOF (XUSRTN)
	2317	"RTN","XUS NPIX1",350 ,0)
	2318	. . D EMA IL^XUSNPIX 5(XUSRTN) ;transmitt ing extrac t data via MailMan
	2319	"RTN","XUS NPIX1",351 ,0)
	2320	. . K ^TM P(XUSRTN,$ J)
	2321	"RTN","XUS NPIX1",352 ,0)
	2322	. . S ^TM P("XUSNPIX S",$J,1,MS GCNT)="1^" _(COUNT-2)
	2323	"RTN","XUS NPIX1",353 ,0)
	2324	. . S ^TM P(XUSRTN,$ J,1)=XUSHD R
	2325	"RTN","XUS NPIX1",354 ,0)
	2326	. . S COU NT=1,XUSIZ E=0
	2327	"RTN","XUS NPIX1",355 ,0)
	2328	D EOF(XUS RTN)
	2329	"RTN","XUS NPIX1",356 ,0)
	2330	;
	2331	"RTN","XUS NPIX1",357 ,0)
	2332	; Send th e last mes sage (if i t has reco rds)
	2333	"RTN","XUS NPIX1",358 ,0)
	2334	I $G(COUN T)>1 D
	2335	"RTN","XUS NPIX1",359 ,0)
	2336	.D EMAIL^ XUSNPIX5(X USRTN) ;tr ansmitting extract d ata via Ma ilMan
	2337	"RTN","XUS NPIX1",360 ,0)
	2338	.K ^TMP(X USRTN,$J)
	2339	"RTN","XUS NPIX1",361 ,0)
	2340	.S ^TMP(" XUSNPIXS", $J,1,MSGCN T)="1^"_(C OUNT-2)
	2341	"RTN","XUS NPIX1",362 ,0)
	2342	;
	2343	"RTN","XUS NPIX1",363 ,0)
	2344	; Set sum mary total s
	2345	"RTN","XUS NPIX1",364 ,0)
	2346	S ^XTMP(" XUSNPIXT", 0)=(DT+100 00)_U_DT_U _"NPI EXTR ACT SUMMAR Y TOTALS"_ U_DT_U_$H
	2347	"RTN","XUS NPIX1",365 ,0)
	2348	S ^XTMP(" XUSNPIXT", "H")=$P(XU SHDR,U,1,4 )
	2349	"RTN","XUS NPIX1",366 ,0)
	2350	S ^XTMP(" XUSNPIXT", 1)=MSGCNT_ U_TOTREC_U _DTTM
	2351	"RTN","XUS NPIX1",367 ,0)
	2352	K INSMAIL ,SITE
	2353	"RTN","XUS NPIX1",368 ,0)
	2354	Q
	2355	"RTN","XUS NPIX1",369 ,0)
	2356	;
	2357	"RTN","XUS NPIX1",370 ,0)
	2358	EOF(XUSRTN ) ;
	2359	"RTN","XUS NPIX1",371 ,0)
	2360	Q:COUNT=1
	2361	"RTN","XUS NPIX1",372 ,0)
	2362	S MSGCNT= MSGCNT+1
	2363	"RTN","XUS NPIX1",373 ,0)
	2364	S ^TMP(XU SRTN,$J,1) =XUSHDR_U_ "Message N umber: "_M SGCNT_U_"L ine Count: "_COUNT_U _DTTM_U_$G (XUSPROD)_ U_XUSEOL
	2365	"RTN","XUS NPIX1",374 ,0)
	2366	S COUNT=C OUNT+1
	2367	"RTN","XUS NPIX1",375 ,0)
	2368	S ^TMP(XU SRTN,$J,CO UNT)="END OF FILE"_U _XUSEOL
	2369	"RTN","XUS NPIX1",376 ,0)
	2370	Q
	2371	"VER")
	2372	8.0^22.2
	2373	"^DD",8991 .6,8991.6, .03,0)
	2374	FIELD EDIT ED^RF^^0;3 ^K:$L(X)>1 0!($L(X)<1 ) X
	2375	"^DD",8991 .6,8991.6, .03,3)
	2376	Enter the field numb er 1 to 10 character s.
	2377	"^DD",8991 .6,8991.6, .03,21,0)
	2378	^^3^3^3190 107^
	2379	"^DD",8991 .6,8991.6, .03,21,1,0 )
	2380	This field contains the field number (#5 5.1-55.6) in NEW PER SON file
	2381	"^DD",8991 .6,8991.6, .03,21,2,0 )
	2382	(#200) or the field number (#2 .1-2.6 and #.04) in DEA NUMBER S (#8991.9 )
	2383	"^DD",8991 .6,8991.6, .03,21,3,0 )
	2384	that was e dited.
	2385	"^DD",8991 .6,8991.6, .03,"DT")
	2386	3190107
	2387	END
	2388	END