388. EPMO Open Source Coordination Office Redaction File Detail Report

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

388.1 Files compared

#	Location	File	Last Modified
1	VSA P2.5 v3.0.12.zip\src.zip\vsa_vistajs_source_v3.0\vsa-mcode\kids	XU_8_659_V9.KID	Mon Jan 16 21:20:00 2017 UTC
2	VSA P2.5 v3.0.12.zip\src.zip\vsa_vistajs_source_v3.0\vsa-mcode\kids	XU_8_659_V9.KID	Fri Feb 17 04:23:00 2017 UTC

388.2 Comparison summary

Description	Between Files 1 and 2
Description	Text Blocks	Lines
Unchanged	7	16860
Changed	6	12
Inserted	0	0
Removed	0	0

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

388.4 Active regular expressions

No regular expressions were active.

388.5 Comparison detail

	1	KIDS Distr ibution sa ved on Mar 09, 2016@ 22:50:20
	2	KERNEL
	3	KIDS:X U8.0659^
	4
	5	INSTALL NAME
	6	XU8.0659
	7	"BLD",1548 ,0)
	8	XU8.0659 ^KERNEL^0^ 3160308^y
	9	"BLD",1548 ,1,0)
	10	^^8^8^3160 308^
	11	"BLD",1548 ,1,1,0)
	12	This patch provides enhancemen ts needed to impleme nt Single Sign-On
	13	"BLD",1548 ,1,2,0)
	14	Internal ( SSOi) for identifica tion and a uthenticat ion of use rs into Vi stA.
	15	"BLD",1548 ,1,3,0)
	16
	17	"BLD",1548 ,1,4,0)
	18	The use of these uti lities are expected to improve security and auditi ng
	19	"BLD",1548 ,1,5,0)
	20	capabiliti es in acco rdance wit h VA Handb ook 6500 A ppendix F and revisi on 4
	21	"BLD",1548 ,1,6,0)
	22	of NIST SP 800-53. A s required by FIPS 1 99 and usi ng guidanc e from NIS T SP
	23	"BLD",1548 ,1,7,0)
	24	800-60, th e recommen ded securi ty categor ization fo r these ap plications is
	25	"BLD",1548 ,1,8,0)
	26	HIGH.
	27	"BLD",1548 ,4,0)
	28	^9.64PA^89 89.3^2
	29	"BLD",1548 ,4,3.081,0 )
	30	3.081
	31	"BLD",1548 ,4,3.081,2 ,0)
	32	^9.641^3.0 81^1
	33	"BLD",1548 ,4,3.081,2 ,3.081,0)
	34	SIGN-ON LO G (File-t op level)
	35	"BLD",1548 ,4,3.081,2 ,3.081,1,0 )
	36	^9.6411^10 1^1
	37	"BLD",1548 ,4,3.081,2 ,3.081,1,1 01,0)
	38	LEVEL OF A SSURANCE
	39	"BLD",1548 ,4,3.081,2 22)
	40	y^y^p^^^^n ^^n
	41	"BLD",1548 ,4,3.081,2 24)
	42
	43	"BLD",1548 ,4,8989.3, 0)
	44	8989.3
	45	"BLD",1548 ,4,8989.3, 2,0)
	46	^9.641^898 9.3^1
	47	"BLD",1548 ,4,8989.3, 2,8989.3,0 )
	48	KERNEL SYS TEM PARAME TERS (Fil e-top leve l)
	49	"BLD",1548 ,4,8989.3, 2,8989.3,1 ,0)
	50	^9.6411^20 0.3^3
	51	"BLD",1548 ,4,8989.3, 2,8989.3,1 ,200.1,0)
	52	SECURITY T OKEN SERVI CE
	53	"BLD",1548 ,4,8989.3, 2,8989.3,1 ,200.2,0)
	54	ORGANIZATI ON
	55	"BLD",1548 ,4,8989.3, 2,8989.3,1 ,200.3,0)
	56	ORGANIZATI ON ID
	57	"BLD",1548 ,4,8989.3, 222)
	58	y^y^p^^^^n ^^n
	59	"BLD",1548 ,4,8989.3, 224)
	60
	61	"BLD",1548 ,4,"APDD", 3.081,3.08 1)
	62
	63	"BLD",1548 ,4,"APDD", 3.081,3.08 1,101)
	64
	65	"BLD",1548 ,4,"APDD", 8989.3,898 9.3)
	66
	67	"BLD",1548 ,4,"APDD", 8989.3,898 9.3,200.1)
	68
	69	"BLD",1548 ,4,"APDD", 8989.3,898 9.3,200.2)
	70
	71	"BLD",1548 ,4,"APDD", 8989.3,898 9.3,200.3)
	72
	73	"BLD",1548 ,4,"B",3.0 81,3.081)
	74
	75	"BLD",1548 ,4,"B",898 9.3,8989.3 )
	76
	77	"BLD",1548 ,6.3)
	78	22
	79	"BLD",1548 ,"ABPKG")
	80	n
	81	"BLD",1548 ,"INID")
	82	^y
	83	"BLD",1548 ,"INIT")
	84	XU8PS659
	85	"BLD",1548 ,"KRN",0)
	86	^9.67PA^77 9.2^20
	87	"BLD",1548 ,"KRN",.4, 0)
	88	.4
	89	"BLD",1548 ,"KRN",.4, "NM",0)
	90	^9.68A^2^2
	91	"BLD",1548 ,"KRN",.4, "NM",1,0)
	92	XUSEC LIST FILE # 3.081^3.08 1^0
	93	"BLD",1548 ,"KRN",.4, "NM",2,0)
	94	XUSEC REMO TE ACCESS FILE #3 .081^3.081 ^0
	95	"BLD",1548 ,"KRN",.4, "NM","B"," XUSEC LIST FILE # 3.081",1)
	96
	97	"BLD",1548 ,"KRN",.4, "NM","B"," XUSEC REMO TE ACCESS FILE #3 .081",2)
	98
	99	"BLD",1548 ,"KRN",.40 1,0)
	100	.401
	101	"BLD",1548 ,"KRN",.40 2,0)
	102	.402
	103	"BLD",1548 ,"KRN",.40 3,0)
	104	.403
	105	"BLD",1548 ,"KRN",.5, 0)
	106	.5
	107	"BLD",1548 ,"KRN",.84 ,0)
	108	.84
	109	"BLD",1548 ,"KRN",3.6 ,0)
	110	3.6
	111	"BLD",1548 ,"KRN",3.8 ,0)
	112	3.8
	113	"BLD",1548 ,"KRN",9.2 ,0)
	114	9.2
	115	"BLD",1548 ,"KRN",9.8 ,0)
	116	9.8
	117	"BLD",1548 ,"KRN",9.8 ,"NM",0)
	118	^9.68A^30^ 18
	119	"BLD",1548 ,"KRN",9.8 ,"NM",7,0)
	120	XUS^^0^B35 560117
	121	"BLD",1548 ,"KRN",9.8 ,"NM",8,0)
	122	XUSRB^^0^B 35393386
	123	"BLD",1548 ,"KRN",9.8 ,"NM",9,0)
	124	XUSBSE1^^0 ^B15898406 5
	125	"BLD",1548 ,"KRN",9.8 ,"NM",10,0 )
	126	XUS1^^0^B2 9132312
	127	"BLD",1548 ,"KRN",9.8 ,"NM",11,0 )
	128	XUESSO1^^0 ^B93859687
	129	"BLD",1548 ,"KRN",9.8 ,"NM",12,0 )
	130	XUESSO2^^0 ^B11771426 2
	131	"BLD",1548 ,"KRN",9.8 ,"NM",13,0 )
	132	XUESSO3^^0 ^B22198305 1
	133	"BLD",1548 ,"KRN",9.8 ,"NM",14,0 )
	134	XUSAML^^0^ B87822485
	135	"BLD",1548 ,"KRN",9.8 ,"NM",17,0 )
	136	XU8PS655^^ 1^
	137	"BLD",1548 ,"KRN",9.8 ,"NM",18,0 )
	138	XUCERT^^0^ B4132125
	139	"BLD",1548 ,"KRN",9.8 ,"NM",19,0 )
	140	XUESSO4^^0 ^B61505269
	141	"BLD",1548 ,"KRN",9.8 ,"NM",20,0 )
	142	XUP^^0^B11 898665
	143	"BLD",1548 ,"KRN",9.8 ,"NM",21,0 )
	144	XUSRB4^^0^ B20805610
	145	"BLD",1548 ,"KRN",9.8 ,"NM",22,0 )
	146	XUCERT1^^0 ^B20606802
	147	"BLD",1548 ,"KRN",9.8 ,"NM",27,0 )
	148	XLFNSLK^^0 ^B39616756
	149	"BLD",1548 ,"KRN",9.8 ,"NM",28,0 )
	150	XUSKAAJ^^0 ^B11718164
	151	"BLD",1548 ,"KRN",9.8 ,"NM",29,0 )
	152	XUSKAAJ1^^ 0^B2125056
	153	"BLD",1548 ,"KRN",9.8 ,"NM",30,0 )
	154	XUSHSH^^0^ B37891600
	155	"BLD",1548 ,"KRN",9.8 ,"NM","B", "XLFNSLK", 27)
	156
	157	"BLD",1548 ,"KRN",9.8 ,"NM","B", "XU8PS655" ,17)
	158
	159	"BLD",1548 ,"KRN",9.8 ,"NM","B", "XUCERT",1 8)
	160
	161	"BLD",1548 ,"KRN",9.8 ,"NM","B", "XUCERT1", 22)
	162
	163	"BLD",1548 ,"KRN",9.8 ,"NM","B", "XUESSO1", 11)
	164
	165	"BLD",1548 ,"KRN",9.8 ,"NM","B", "XUESSO2", 12)
	166
	167	"BLD",1548 ,"KRN",9.8 ,"NM","B", "XUESSO3", 13)
	168
	169	"BLD",1548 ,"KRN",9.8 ,"NM","B", "XUESSO4", 19)
	170
	171	"BLD",1548 ,"KRN",9.8 ,"NM","B", "XUP",20)
	172
	173	"BLD",1548 ,"KRN",9.8 ,"NM","B", "XUS",7)
	174
	175	"BLD",1548 ,"KRN",9.8 ,"NM","B", "XUS1",10)
	176
	177	"BLD",1548 ,"KRN",9.8 ,"NM","B", "XUSAML",1 4)
	178
	179	"BLD",1548 ,"KRN",9.8 ,"NM","B", "XUSBSE1", 9)
	180
	181	"BLD",1548 ,"KRN",9.8 ,"NM","B", "XUSHSH",3 0)
	182
	183	"BLD",1548 ,"KRN",9.8 ,"NM","B", "XUSKAAJ", 28)
	184
	185	"BLD",1548 ,"KRN",9.8 ,"NM","B", "XUSKAAJ1" ,29)
	186
	187	"BLD",1548 ,"KRN",9.8 ,"NM","B", "XUSRB",8)
	188
	189	"BLD",1548 ,"KRN",9.8 ,"NM","B", "XUSRB4",2 1)
	190
	191	"BLD",1548 ,"KRN",19, 0)
	192	19
	193	"BLD",1548 ,"KRN",19, "NM",0)
	194	^9.68A^3^3
	195	"BLD",1548 ,"KRN",19, "NM",1,0)
	196	XUS SIGNON ^^0
	197	"BLD",1548 ,"KRN",19, "NM",2,0)
	198	XUS VISIT USERS^^0
	199	"BLD",1548 ,"KRN",19, "NM",3,0)
	200	XUSEC REMO TE ACCESS^ ^0
	201	"BLD",1548 ,"KRN",19, "NM","B"," XUS SIGNON ",1)
	202
	203	"BLD",1548 ,"KRN",19, "NM","B"," XUS VISIT USERS",2)
	204
	205	"BLD",1548 ,"KRN",19, "NM","B"," XUSEC REMO TE ACCESS" ,3)
	206
	207	"BLD",1548 ,"KRN",19. 1,0)
	208	19.1
	209	"BLD",1548 ,"KRN",101 ,0)
	210	101
	211	"BLD",1548 ,"KRN",101 ,"NM",0)
	212	^9.68A^^0
	213	"BLD",1548 ,"KRN",409 .61,0)
	214	409.61
	215	"BLD",1548 ,"KRN",771 ,0)
	216	771
	217	"BLD",1548 ,"KRN",779 .2,0)
	218	779.2
	219	"BLD",1548 ,"KRN",870 ,0)
	220	870
	221	"BLD",1548 ,"KRN",898 9.51,0)
	222	8989.51
	223	"BLD",1548 ,"KRN",898 9.52,0)
	224	8989.52
	225	"BLD",1548 ,"KRN",899 4,0)
	226	8994
	227	"BLD",1548 ,"KRN",899 4,"NM",0)
	228	^9.68A^18^ 18
	229	"BLD",1548 ,"KRN",899 4,"NM",1,0 )
	230	XUS ESSO V ALIDATE^^0
	231	"BLD",1548 ,"KRN",899 4,"NM",2,0 )
	232	XUS IAM FI ND USER^^0
	233	"BLD",1548 ,"KRN",899 4,"NM",3,0 )
	234	XUS IAM DI SPLAY USER ^^0
	235	"BLD",1548 ,"KRN",899 4,"NM",4,0 )
	236	XUS IAM ED IT USER^^0
	237	"BLD",1548 ,"KRN",899 4,"NM",5,0 )
	238	XUS IAM AD D USER^^0
	239	"BLD",1548 ,"KRN",899 4,"NM",6,0 )
	240	XUS IAM BI ND USER^^0
	241	"BLD",1548 ,"KRN",899 4,"NM",7,0 )
	242	XUS IAM TE RMINATE US ER^^0
	243	"BLD",1548 ,"KRN",899 4,"NM",8,0 )
	244	XUS IAM RE ACTIVATE U SER^^0
	245	"BLD",1548 ,"KRN",899 4,"NM",9,0 )
	246	XUS CVC^^0
	247	"BLD",1548 ,"KRN",899 4,"NM",10, 0)
	248	XUS SIGNON SETUP^^0
	249	"BLD",1548 ,"KRN",899 4,"NM",11, 0)
	250	XUS ALLKEY S^^0
	251	"BLD",1548 ,"KRN",899 4,"NM",12, 0)
	252	XUS KEY CH ECK^^0
	253	"BLD",1548 ,"KRN",899 4,"NM",13, 0)
	254	XUS KAAJEE GET CCOW TOKEN^^0
	255	"BLD",1548 ,"KRN",899 4,"NM",14, 0)
	256	XUS KAAJEE GET USER INFO^^0
	257	"BLD",1548 ,"KRN",899 4,"NM",15, 0)
	258	XUS KAAJEE GET USER VIA PROXY^ ^0
	259	"BLD",1548 ,"KRN",899 4,"NM",16, 0)
	260	XUS KAAJEE LOGOUT^^0
	261	"BLD",1548 ,"KRN",899 4,"NM",17, 0)
	262	XUS BSE TO KEN^^0
	263	"BLD",1548 ,"KRN",899 4,"NM",18, 0)
	264	XUS AV COD E^^0
	265	"BLD",1548 ,"KRN",899 4,"NM","B" ,"XUS ALLK EYS",11)
	266
	267	"BLD",1548 ,"KRN",899 4,"NM","B" ,"XUS AV C ODE",18)
	268
	269	"BLD",1548 ,"KRN",899 4,"NM","B" ,"XUS BSE TOKEN",17)
	270
	271	"BLD",1548 ,"KRN",899 4,"NM","B" ,"XUS CVC" ,9)
	272
	273	"BLD",1548 ,"KRN",899 4,"NM","B" ,"XUS ESSO VALIDATE" ,1)
	274
	275	"BLD",1548 ,"KRN",899 4,"NM","B" ,"XUS IAM ADD USER", 5)
	276
	277	"BLD",1548 ,"KRN",899 4,"NM","B" ,"XUS IAM BIND USER" ,6)
	278
	279	"BLD",1548 ,"KRN",899 4,"NM","B" ,"XUS IAM DISPLAY US ER",3)
	280
	281	"BLD",1548 ,"KRN",899 4,"NM","B" ,"XUS IAM EDIT USER" ,4)
	282
	283	"BLD",1548 ,"KRN",899 4,"NM","B" ,"XUS IAM FIND USER" ,2)
	284
	285	"BLD",1548 ,"KRN",899 4,"NM","B" ,"XUS IAM REACTIVATE USER",8)
	286
	287	"BLD",1548 ,"KRN",899 4,"NM","B" ,"XUS IAM TERMINATE USER",7)
	288
	289	"BLD",1548 ,"KRN",899 4,"NM","B" ,"XUS KAAJ EE GET CCO W TOKEN",1 3)
	290
	291	"BLD",1548 ,"KRN",899 4,"NM","B" ,"XUS KAAJ EE GET USE R INFO",14 )
	292
	293	"BLD",1548 ,"KRN",899 4,"NM","B" ,"XUS KAAJ EE GET USE R VIA PROX Y",15)
	294
	295	"BLD",1548 ,"KRN",899 4,"NM","B" ,"XUS KAAJ EE LOGOUT" ,16)
	296
	297	"BLD",1548 ,"KRN",899 4,"NM","B" ,"XUS KEY CHECK",12)
	298
	299	"BLD",1548 ,"KRN",899 4,"NM","B" ,"XUS SIGN ON SETUP", 10)
	300
	301	"BLD",1548 ,"KRN","B" ,.4,.4)
	302
	303	"BLD",1548 ,"KRN","B" ,.401,.401 )
	304
	305	"BLD",1548 ,"KRN","B" ,.402,.402 )
	306
	307	"BLD",1548 ,"KRN","B" ,.403,.403 )
	308
	309	"BLD",1548 ,"KRN","B" ,.5,.5)
	310
	311	"BLD",1548 ,"KRN","B" ,.84,.84)
	312
	313	"BLD",1548 ,"KRN","B" ,3.6,3.6)
	314
	315	"BLD",1548 ,"KRN","B" ,3.8,3.8)
	316
	317	"BLD",1548 ,"KRN","B" ,9.2,9.2)
	318
	319	"BLD",1548 ,"KRN","B" ,9.8,9.8)
	320
	321	"BLD",1548 ,"KRN","B" ,19,19)
	322
	323	"BLD",1548 ,"KRN","B" ,19.1,19.1 )
	324
	325	"BLD",1548 ,"KRN","B" ,101,101)
	326
	327	"BLD",1548 ,"KRN","B" ,409.61,40 9.61)
	328
	329	"BLD",1548 ,"KRN","B" ,771,771)
	330
	331	"BLD",1548 ,"KRN","B" ,779.2,779 .2)
	332
	333	"BLD",1548 ,"KRN","B" ,870,870)
	334
	335	"BLD",1548 ,"KRN","B" ,8989.51,8 989.51)
	336
	337	"BLD",1548 ,"KRN","B" ,8989.52,8 989.52)
	338
	339	"BLD",1548 ,"KRN","B" ,8994,8994 )
	340
	341	"BLD",1548 ,"PRET")
	342
	343	"BLD",1548 ,"QUES",0)
	344	^9.62^^
	345	"BLD",1548 ,"REQB",0)
	346	^9.611^5^5
	347	"BLD",1548 ,"REQB",1, 0)
	348	XU8.0655 ^1
	349	"BLD",1548 ,"REQB",2, 0)
	350	XU8.0638 ^1
	351	"BLD",1548 ,"REQB",3, 0)
	352	XU8.0584 ^1
	353	"BLD",1548 ,"REQB",4, 0)
	354	XU8.0430 ^1
	355	"BLD",1548 ,"REQB",5, 0)
	356	XU8.0504 ^1
	357	"BLD",1548 ,"REQB","B ","XU8.0 430",4)
	358
	359	"BLD",1548 ,"REQB","B ","XU8.0 504",5)
	360
	361	"BLD",1548 ,"REQB","B ","XU8.0 584",3)
	362
	363	"BLD",1548 ,"REQB","B ","XU8.0 638",2)
	364
	365	"BLD",1548 ,"REQB","B ","XU8.0 655",1)
	366
	367	"FIA",3.08 1)
	368	SIGN-ON LO G
	369	"FIA",3.08 1,0)
	370	^XUSEC(0,
	371	"FIA",3.08 1,0,0)
	372	3.081P
	373	"FIA",3.08 1,0,1)
	374	y^y^p^^^^n ^^n
	375	"FIA",3.08 1,0,10)
	376
	377	"FIA",3.08 1,0,11)
	378
	379	"FIA",3.08 1,0,"RLRO" )
	380
	381	"FIA",3.08 1,0,"VR")
	382	8.0^XU
	383	"FIA",3.08 1,3.081)
	384	1
	385	"FIA",3.08 1,3.081,10 1)
	386
	387	"FIA",8989 .3)
	388	KERNEL SYS TEM PARAME TERS
	389	"FIA",8989 .3,0)
	390	^XTV(8989. 3,
	391	"FIA",8989 .3,0,0)
	392	8989.3P
	393	"FIA",8989 .3,0,1)
	394	y^y^p^^^^n ^^n
	395	"FIA",8989 .3,0,10)
	396
	397	"FIA",8989 .3,0,11)
	398
	399	"FIA",8989 .3,0,"RLRO ")
	400
	401	"FIA",8989 .3,0,"VR")
	402	8.0^XU
	403	"FIA",8989 .3,8989.3)
	404	1
	405	"FIA",8989 .3,8989.3, 200.1)
	406
	407	"FIA",8989 .3,8989.3, 200.2)
	408
	409	"FIA",8989 .3,8989.3, 200.3)
	410
	411	"INIT")
	412	XU8PS659
	413	"KRN",.4,3 ,-1)
	414	0^1
	415	"KRN",.4,3 ,0)
	416	XUSEC LIST ^3150902.0 721^^3.081 ^^@^316022 4
	417	"KRN",.4,3 ,"F",2)
	418	0;"Sign-on time"~99; R9~.01;L17 ~S X=$I W X K DIP;L9 ;Z;"$I"~10 ~100;L40~1 01;"LOA"~
	419	"KRN",.4,3 ,"H")
	420	USERS WHO HAVE SIGNE D ONTO THE COMPUTER
	421	"KRN",.4,7 0,-1)
	422	0^2
	423	"KRN",.4,7 0,0)
	424	XUSEC REMO TE ACCESS^ 3150902.07 25^@^3.081 ^^@^315122 2
	425	"KRN",.4,7 0,"F",2)
	426	0;"Sign-on time"~99; R9~.01~14~ 100;L40~10 1;"LOA"~
	427	"KRN",.4,7 0,"H")
	428	Remote Acc ess User S ign-On Log
	429	"KRN",19,6 04,-1)
	430	0^1
	431	"KRN",19,6 04,0)
	432	XUS SIGNON ^Kernel si gn-on cont ext^^B^^^^ ^^^^KERNEL ^y
	433	"KRN",19,6 04,99.1)
	434	61634,5161 4
	435	"KRN",19,6 04,"RPC",0 )
	436	^19.05P^14 ^14
	437	"KRN",19,6 04,"RPC",1 ,0)
	438	XUS SIGNON SETUP
	439	"KRN",19,6 04,"RPC",2 ,0)
	440	XUS AV COD E
	441	"KRN",19,6 04,"RPC",3 ,0)
	442	XUS INTRO MSG
	443	"KRN",19,6 04,"RPC",4 ,0)
	444	XUS CVC
	445	"KRN",19,6 04,"RPC",5 ,0)
	446	XUS AV HEL P
	447	"KRN",19,6 04,"RPC",6 ,0)
	448	XUS DIVISI ON SET
	449	"KRN",19,6 04,"RPC",7 ,0)
	450	XUS GET US ER INFO
	451	"KRN",19,6 04,"RPC",8 ,0)
	452	XUS DIVISI ON GET
	453	"KRN",19,6 04,"RPC",9 ,0)
	454	XWB GET BR OKER INFO
	455	"KRN",19,6 04,"RPC",1 0,0)
	456	XUS GET TO KEN
	457	"KRN",19,6 04,"RPC",1 1,0)
	458	XUS CCOW V AULT PARAM
	459	"KRN",19,6 04,"RPC",1 2,0)
	460	XUS GET CC OW TOKEN
	461	"KRN",19,6 04,"RPC",1 3,0)
	462	XUS ESSO V ALIDATE
	463	"KRN",19,6 04,"RPC",1 4,0)
	464	XUS IAM BI ND USER
	465	"KRN",19,6 04,"U")
	466	KERNEL SIG N-ON CONTE XT
	467	"KRN",19,1 654,-1)
	468	0^2
	469	"KRN",19,1 654,0)
	470	XUS VISIT USERS^User s with For eign Visit s^^P^^^^^^ ^^KERNEL
	471	"KRN",19,1 654,1,0)
	472	^^2^2^3151 016^
	473	"KRN",19,1 654,1,1,0)
	474	Menu optio n created by patch X U8655 us ing sort a nd print t emplates f rom
	475	"KRN",19,1 654,1,2,0)
	476	patch XU8 165. Show s NPF entr ies that h ave been V ISITORS to this site .
	477	"KRN",19,1 654,60)
	478	VA(200,
	479	"KRN",19,1 654,62)
	480	0
	481	"KRN",19,1 654,63)
	482	[XUS VISIT USERS]
	483	"KRN",19,1 654,64)
	484	[XUS VISIT USERS]
	485	"KRN",19,1 654,65)
	486
	487	"KRN",19,1 654,66)
	488
	489	"KRN",19,1 654,"U")
	490	USERS WITH FOREIGN V ISITS
	491	"KRN",19,1 655,-1)
	492	0^3
	493	"KRN",19,1 655,0)
	494	XUSEC REMO TE ACCESS^ Remote Acc ess User S ign-on Log ^^P^^^^^^^ ^KERNEL
	495	"KRN",19,1 655,1,0)
	496	^^10^10^31 51014^
	497	"KRN",19,1 655,1,1,0)
	498	Menu optio n created by patch X U8655 us ing sort a nd print t emplates f rom
	499	"KRN",19,1 655,1,2,0)
	500	patch XU8 165. Prin ts Sign-on log entri es from re mote users . Added
	501	"KRN",19,1 655,1,3,0)
	502	sign-on Le vel Of Ass urance inf ormation i n patch XU 8659 whe re:
	503	"KRN",19,1 655,1,4,0)
	504	LOA=1 - little or no confide nce in the user iden tity (self -asserted)
	505	"KRN",19,1 655,1,5,0)
	506	LOA=2 - confidence in the us er identit y (access/ verify cod e or
	507	"KRN",19,1 655,1,6,0)
	508	re-authent ication to ken)
	509	"KRN",19,1 655,1,7,0)
	510	LOA=3 - high confi dence in t he user id entity (pa ssword wit h hardware or
	511	"KRN",19,1 655,1,8,0)
	512	software t oken)
	513	"KRN",19,1 655,1,9,0)
	514	LOA=4 - very high confidence in the us er identit y (in-pers on
	515	"KRN",19,1 655,1,10,0 )
	516	registrati on with mu lti-factor authentic ation or P IV card)
	517	"KRN",19,1 655,60)
	518	XUSEC(0,
	519	"KRN",19,1 655,62)
	520	0
	521	"KRN",19,1 655,63)
	522	[XUSEC REM OTE ACCESS ]
	523	"KRN",19,1 655,64)
	524	[XUSEC REM OTE ACCESS ]
	525	"KRN",19,1 655,65)
	526
	527	"KRN",19,1 655,66)
	528
	529	"KRN",19,1 655,"U")
	530	REMOTE ACC ESS USER S IGN-ON LOG
	531	"KRN",8994 ,15,-1)
	532	0^10
	533	"KRN",8994 ,15,0)
	534	XUS SIGNON SETUP^SET UP^XUSRB^2 ^S^^^^1^^1
	535	"KRN",8994 ,15,1,0)
	536	^^2^2^3151 209^
	537	"KRN",8994 ,15,1,1,0)
	538	RPC ICR #1 632 - API ICR #4054
	539	"KRN",8994 ,15,1,2,0)
	540	Establishe s the envi ronment ne cessary fo r VistA si gn-on.
	541	"KRN",8994 ,15,2,0)
	542	^8994.02A^ 3^3
	543	"KRN",8994 ,15,2,1,0)
	544	XWBUSRNM^1 ^90^0^1
	545	"KRN",8994 ,15,2,1,1, 0)
	546	^^1^1^3151 201^
	547	"KRN",8994 ,15,2,1,1, 1,0)
	548	Optional B roker Secu rity Enhan cement (BS E) token.
	549	"KRN",8994 ,15,2,2,0)
	550	ASOSKIP^1^ 1^0^2
	551	"KRN",8994 ,15,2,2,1, 0)
	552	^^3^3^3151 201^
	553	"KRN",8994 ,15,2,2,1, 1,0)
	554	Optional. Set ASOSKI P=1 to ski p the Auto Sign-On c heck. Used by RPC
	555	"KRN",8994 ,15,2,2,1, 2,0)
	556	applicatio ns that do not resid e on the c lient work station wi th the
	557	"KRN",8994 ,15,2,2,1, 3,0)
	558	ClAgent.ex e applicat ion.
	559	"KRN",8994 ,15,2,3,0)
	560	D20^1^1^0^ 3
	561	"KRN",8994 ,15,2,3,1, 0)
	562	^^1^1^3151 201^
	563	"KRN",8994 ,15,2,3,1, 1,0)
	564	Not curren tly used. Leave blan k.
	565	"KRN",8994 ,15,2,"B", "ASOSKIP", 2)
	566
	567	"KRN",8994 ,15,2,"B", "D20",3)
	568
	569	"KRN",8994 ,15,2,"B", "XWBUSRNM" ,1)
	570
	571	"KRN",8994 ,15,2,"PAR AMSEQ",1,1 )
	572
	573	"KRN",8994 ,15,2,"PAR AMSEQ",2,2 )
	574
	575	"KRN",8994 ,15,2,"PAR AMSEQ",3,3 )
	576
	577	"KRN",8994 ,15,3,0)
	578	^^8^8^3151 201^
	579	"KRN",8994 ,15,3,1,0)
	580	RET(0)=se rver name
	581	"KRN",8994 ,15,3,2,0)
	582	RET(1)=vo lume
	583	"KRN",8994 ,15,3,3,0)
	584	RET(2)=uc i
	585	"KRN",8994 ,15,3,4,0)
	586	RET(3)=de vice
	587	"KRN",8994 ,15,3,5,0)
	588	RET(4)=# attempts
	589	"KRN",8994 ,15,3,6,0)
	590	RET(5)=sk ip signon- screen
	591	"KRN",8994 ,15,3,7,0)
	592	RET(6)=Do main Name
	593	"KRN",8994 ,15,3,8,0)
	594	RET(7)=pr oduction ( 0=no, 1=ye s)
	595	"KRN",8994 ,16,-1)
	596	0^18
	597	"KRN",8994 ,16,0)
	598	XUS AV COD E^VALIDAV^ XUSRB^2^R^ ^^^1^^0
	599	"KRN",8994 ,16,1,0)
	600	^8994.01^1 0^10^31512 17^^^^
	601	"KRN",8994 ,16,1,1,0)
	602	This API c hecks if a ACCESS/VE RIFY code pair is va lid.
	603	"KRN",8994 ,16,1,2,0)
	604	It returns an array of values
	605	"KRN",8994 ,16,1,3,0)
	606
	607	"KRN",8994 ,16,1,4,0)
	608	R(0)=DUZ i f sign-on was OK, ze ro if not OK.
	609	"KRN",8994 ,16,1,5,0)
	610	R(1)=(0=OK , 1,2...=C an't sign- on for som e reason).
	611	"KRN",8994 ,16,1,6,0)
	612	R(2)=verif y needs ch anging.
	613	"KRN",8994 ,16,1,7,0)
	614	R(3)=Messa ge.
	615	"KRN",8994 ,16,1,8,0)
	616	R(4)=0
	617	"KRN",8994 ,16,1,9,0)
	618	R(5)=count of the nu mber of li nes of tex t, zero if none.
	619	"KRN",8994 ,16,1,10,0 )
	620	R(5+n)=mes sage text.
	621	"KRN",8994 ,16,2,0)
	622	^8994.02A^ 1^1
	623	"KRN",8994 ,16,2,1,0)
	624	AVCODE^1^6 0^1
	625	"KRN",8994 ,16,2,1,1, 0)
	626	^8994.021^ 1^1^315121 7^^^^
	627	"KRN",8994 ,16,2,1,1, 1,0)
	628	accessCode _";"_verif yCode in u nencrypted form.
	629	"KRN",8994 ,16,2,"B", "AVCODE",1 )
	630
	631	"KRN",8994 ,18,-1)
	632	0^12
	633	"KRN",8994 ,18,0)
	634	XUS KEY CH ECK^OWNSKE Y^XUSRB^2^ P^^^^1^^1
	635	"KRN",8994 ,18,1,0)
	636	^^5^5^3151 209^
	637	"KRN",8994 ,18,1,1,0)
	638	RPC ICR #6 286 - API ICR #3277
	639	"KRN",8994 ,18,1,2,0)
	640	This RPC w ill check if the use r (DUZ) ho lds a secu rity key o r an array of
	641	"KRN",8994 ,18,1,3,0)
	642	keys. If a single se curity KEY is sent t he result is returne d in R(0). If
	643	"KRN",8994 ,18,1,4,0)
	644	an array i s sent dow n then the return ar ray has th e same ord er as the
	645	"KRN",8994 ,18,1,5,0)
	646	calling ar ray.
	647	"KRN",8994 ,18,2,0)
	648	^8994.02A^ 2^2
	649	"KRN",8994 ,18,2,1,0)
	650	KEY^2^30^1 ^1
	651	"KRN",8994 ,18,2,1,1, 0)
	652	^8994.021^ 4^4^315120 8^^^^
	653	"KRN",8994 ,18,2,1,1, 1,0)
	654	If key is a single v alue it ho lds the on e key to c heck.
	655	"KRN",8994 ,18,2,1,1, 2,0)
	656	If key is an array t hen the re sult is an array tha t matches the key
	657	"KRN",8994 ,18,2,1,1, 3,0)
	658	list with values tha t match th e status o f the key check for each key.
	659	"KRN",8994 ,18,2,1,1, 4,0)
	660	The return is a 1 if the user has the ke y and 0 if not.
	661	"KRN",8994 ,18,2,2,0)
	662	IEN^1^30^0 ^2
	663	"KRN",8994 ,18,2,2,1, 0)
	664	^^3^3^3151 209^
	665	"KRN",8994 ,18,2,2,1, 1,0)
	666	(Optional) If provid ed, this i s the IEN of the use r in the N EW PERSON
	667	"KRN",8994 ,18,2,2,1, 2,0)
	668	file (#200 ) to check if they h old the ke y(s) liste d in KEY. If not
	669	"KRN",8994 ,18,2,2,1, 3,0)
	670	provided, this param eter defau lts to the DUZ (IEN) of the cu rrent user .
	671	"KRN",8994 ,18,2,"B", "IEN",2)
	672
	673	"KRN",8994 ,18,2,"B", "KEY",1)
	674
	675	"KRN",8994 ,18,2,"PAR AMSEQ",1,1 )
	676
	677	"KRN",8994 ,18,2,"PAR AMSEQ",2,2 )
	678
	679	"KRN",8994 ,19,-1)
	680	0^9
	681	"KRN",8994 ,19,0)
	682	XUS CVC^CV C^XUSRB^2^ R^^^^^^0
	683	"KRN",8994 ,19,1,0)
	684	^^3^3^3151 209^
	685	"KRN",8994 ,19,1,1,0)
	686	RPC ICR #6 296 - API ICR #none
	687	"KRN",8994 ,19,1,2,0)
	688	This RPC i s used as part of Ke rnel to al low the us er to chan ge their
	689	"KRN",8994 ,19,1,3,0)
	690	verify cod e.
	691	"KRN",8994 ,19,2,0)
	692	^8994.02A^ 1^1
	693	"KRN",8994 ,19,2,1,0)
	694	XU1^1^60^1 ^1
	695	"KRN",8994 ,19,2,1,1, 0)
	696	^^4^4^3150 818^
	697	"KRN",8994 ,19,2,1,1, 1,0)
	698	Input: X U1 = "curr ent VC^new VC^new VC "
	699	"KRN",8994 ,19,2,1,1, 2,0)
	700	where current a nd new ver ify codes are indivi dually
	701	"KRN",8994 ,19,2,1,1, 3,0)
	702	encry pted with the VA pro prietary V istA encry ption
	703	"KRN",8994 ,19,2,1,1, 4,0)
	704	algor ithm (clie nt softwar e equivale nt of $$EN CRYP^XUSRB 1)
	705	"KRN",8994 ,19,2,"B", "XU1",1)
	706
	707	"KRN",8994 ,19,2,"PAR AMSEQ",1,1 )
	708
	709	"KRN",8994 ,19,3,0)
	710	^^2^2^3150 818^
	711	"KRN",8994 ,19,3,1,0)
	712	R(0) = Zer o if VC wa s changed, 1 if it c ould not b e changed.
	713	"KRN",8994 ,19,3,2,0)
	714	R(1) = Err or message if VC cou ld not be changed.
	715	"KRN",8994 ,129,-1)
	716	0^14
	717	"KRN",8994 ,129,0)
	718	XUS KAAJEE GET USER INFO^USERI NFO^XUSKAA J^2^A^^^^1 ^^1
	719	"KRN",8994 ,129,1,0)
	720	^8994.01^1 ^1^3151215 ^^^^
	721	"KRN",8994 ,129,1,1,0 )
	722	Returns a variety of informati on needed for the KA AJEE logon .
	723	"KRN",8994 ,129,2,0)
	724	^8994.02A^ 2^2
	725	"KRN",8994 ,129,2,1,0 )
	726	CLIENT-IP^ 1^^1^1
	727	"KRN",8994 ,129,2,1,1 ,0)
	728	^^2^2^3031 209^
	729	"KRN",8994 ,129,2,1,1 ,1,0)
	730	IP address of the cl ient works tation, us ed for log ging (sign on log)
	731	"KRN",8994 ,129,2,1,1 ,2,0)
	732	and IP blo cking (fai led access attempts) .
	733	"KRN",8994 ,129,2,2,0 )
	734	SERVER-NM^ 1^^1^2
	735	"KRN",8994 ,129,2,2,1 ,0)
	736	^8994.021^ 2^2^315121 5^^^^
	737	"KRN",8994 ,129,2,2,1 ,1,0)
	738	Identifyin g name for the calli ng applica tion or se rver,
	739	"KRN",8994 ,129,2,2,1 ,2,0)
	740	used for l ogging (si gnon log).
	741	"KRN",8994 ,129,2,"B" ,"CLIENT-I P",1)
	742
	743	"KRN",8994 ,129,2,"B" ,"SERVER-N M",2)
	744
	745	"KRN",8994 ,129,2,"PA RAMSEQ",1, 1)
	746
	747	"KRN",8994 ,129,2,"PA RAMSEQ",2, 2)
	748
	749	"KRN",8994 ,129,3,0)
	750	^8994.03^1 8^18^31512 15^^^^
	751	"KRN",8994 ,129,3,1,0 )
	752	OUTPUT:
	753	"KRN",8994 ,129,3,2,0 )
	754	Result(0) is the use rs DUZ.
	755	"KRN",8994 ,129,3,3,0 )
	756	Result(1) is the use r name fro m the .01 field.
	757	"KRN",8994 ,129,3,4,0 )
	758	Result(2) is the use rs full na me from th e name sta ndard file .
	759	"KRN",8994 ,129,3,5,0 )
	760	Result(3) is the FAM ILY (LAST) NAME
	761	"KRN",8994 ,129,3,6,0 )
	762	Result(4) is the GIV EN (FIRST) NAME
	763	"KRN",8994 ,129,3,7,0 )
	764	Result(5) is the MID DLE NAME
	765	"KRN",8994 ,129,3,8,0 )
	766	Result(6) is the PRE FIX
	767	"KRN",8994 ,129,3,9,0 )
	768	Result(7) is the SUF FIX
	769	"KRN",8994 ,129,3,10, 0)
	770	Result(8) is the DEG REE
	771	"KRN",8994 ,129,3,11, 0)
	772	Result(9) is station # of the division t hat the us er is work ing in.
	773	"KRN",8994 ,129,3,12, 0)
	774	Result(10) is the st ation # of the paren t facility for the l ogin divis ion
	775	"KRN",8994 ,129,3,13, 0)
	776	Result(11) is the st ation # fr om the KSP site para meters, th e parent
	777	"KRN",8994 ,129,3,14, 0)
	778	"computer system"
	779	"KRN",8994 ,129,3,15, 0)
	780	Result(12) is the si gnon log e ntry IEN
	781	"KRN",8994 ,129,3,16, 0)
	782	Result(13) = # of pe rmissible divisions
	783	"KRN",8994 ,129,3,17, 0)
	784	Result(14- n) are the permissib le divisio ns for use r login, i n the form at:
	785	"KRN",8994 ,129,3,18, 0)
	786	IEN of fil e 4^Statio n Name^Sta tion Numbe r^default? (1 or 0)
	787	"KRN",8994 ,130,-1)
	788	0^16
	789	"KRN",8994 ,130,0)
	790	XUS KAAJEE LOGOUT^SI GNOFF^XUSK AAJ^1^A^^^ ^1^^1
	791	"KRN",8994 ,130,1,0)
	792	^8994.01^2 ^2^3151215 ^^^^
	793	"KRN",8994 ,130,1,1,0 )
	794	This RPC c alls the L OUT^XUSCLE AN tag to mark a KAA JEE-signed -on user's
	795	"KRN",8994 ,130,1,2,0 )
	796	entry in t he sign-on log as si gned off.
	797	"KRN",8994 ,130,2,0)
	798	^8994.02A^ 1^1
	799	"KRN",8994 ,130,2,1,0 )
	800	SIGNON-LOG -DA^1^1^1^ 1
	801	"KRN",8994 ,130,2,1,1 ,0)
	802	^8994.021^ 1^1^315121 5^^^^
	803	"KRN",8994 ,130,2,1,1 ,1,0)
	804	The DA (IE N) of the user's sig non log en try.
	805	"KRN",8994 ,130,2,"B" ,"SIGNON-L OG-DA",1)
	806
	807	"KRN",8994 ,130,2,"PA RAMSEQ",1, 1)
	808
	809	"KRN",8994 ,130,3,0)
	810	^8994.03^1 ^1^3151215 ^^^^
	811	"KRN",8994 ,130,3,1,0 )
	812	Returns 1. The retur n value ha s no signi ficance.
	813	"KRN",8994 ,144,-1)
	814	0^11
	815	"KRN",8994 ,144,0)
	816	XUS ALLKEY S^ALLKEYS^ XUSRB^4^P^ ^^1^1^^1
	817	"KRN",8994 ,144,1,0)
	818	^^5^5^3151 209^
	819	"KRN",8994 ,144,1,1,0 )
	820	RPC ICR #6 287 - API ICR #3277
	821	"KRN",8994 ,144,1,2,0 )
	822	This RPC w ill return all the K EYS that a user hold s. If the FLAG is se t to
	823	"KRN",8994 ,144,1,3,0 )
	824	some value the list of KEYS wi ll be scre ened to on ly be thos e for J2EE
	825	"KRN",8994 ,144,1,4,0 )
	826	use. The R PC was des igned for FATKAAT an d KAAJEE ( VistALink clients) b ut
	827	"KRN",8994 ,144,1,5,0 )
	828	may be use d by other applicati ons.
	829	"KRN",8994 ,144,2,0)
	830	^8994.02A^ 2^2
	831	"KRN",8994 ,144,2,1,0 )
	832	IEN^1^10^0 ^1
	833	"KRN",8994 ,144,2,1,1 ,0)
	834	^8994.021^ 2^2^315120 9^^
	835	"KRN",8994 ,144,2,1,1 ,1,0)
	836	This is th e IEN or D UZ of the user in qu estion. If not passe d in the R PC
	837	"KRN",8994 ,144,2,1,1 ,2,0)
	838	will use t he current DUZ.
	839	"KRN",8994 ,144,2,2,0 )
	840	FLAG^1^3^0 ^2
	841	"KRN",8994 ,144,2,2,1 ,0)
	842	^8994.021^ 1^1^315120 9^^^^
	843	"KRN",8994 ,144,2,2,1 ,1,0)
	844	Not in use at this t ime.
	845	"KRN",8994 ,144,2,"B" ,"FLAG",2)
	846
	847	"KRN",8994 ,144,2,"B" ,"IEN",1)
	848
	849	"KRN",8994 ,144,2,"PA RAMSEQ",1, 1)
	850
	851	"KRN",8994 ,144,2,"PA RAMSEQ",2, 2)
	852
	853	"KRN",8994 ,144,3,0)
	854	^8994.03^3 ^3^3151209 ^^^^
	855	"KRN",8994 ,144,3,1,0 )
	856	Returns -1 if failed for some reason.
	857	"KRN",8994 ,144,3,2,0 )
	858	Otherwise it returns a list of the names of the Se curity KEY S the user
	859	"KRN",8994 ,144,3,3,0 )
	860	holds.
	861	"KRN",8994 ,212,-1)
	862	0^15
	863	"KRN",8994 ,212,0)
	864	XUS KAAJEE GET USER VIA PROXY^ USERINFO^X USKAAJ1^2^ R^^^^1^^1
	865	"KRN",8994 ,212,1,0)
	866	^8994.01^2 ^2^3151215 ^^^
	867	"KRN",8994 ,212,1,1,0 )
	868	Returns a variety of informati on needed for KAAJEE logon bas ed on the
	869	"KRN",8994 ,212,1,2,0 )
	870	ccow token
	871	"KRN",8994 ,212,2,0)
	872	^8994.02A^ 3^3
	873	"KRN",8994 ,212,2,1,0 )
	874	CLIENT-IP^ 1^^1^1
	875	"KRN",8994 ,212,2,1,1 ,0)
	876	^^3^3^3080 730^
	877	"KRN",8994 ,212,2,1,1 ,1,0)
	878	IP address of the cl ient works tation use d for logg ing (signo n log) and IP
	879	"KRN",8994 ,212,2,1,1 ,2,0)
	880	blocking ( failed acc ess attemp ts). Also , this IP address is used to
	881	"KRN",8994 ,212,2,1,1 ,3,0)
	882	validate c cow token submitted.
	883	"KRN",8994 ,212,2,2,0 )
	884	SERVER-NM^ 1^^1^2
	885	"KRN",8994 ,212,2,2,1 ,0)
	886	^^2^2^3080 730^
	887	"KRN",8994 ,212,2,2,1 ,1,0)
	888	Identifyin g name for the calli ng applica tion or se rver used for loggin g
	889	"KRN",8994 ,212,2,2,1 ,2,0)
	890	(signon lo g)
	891	"KRN",8994 ,212,2,3,0 )
	892	CCOWTOK^1^ ^1^3
	893	"KRN",8994 ,212,2,3,1 ,0)
	894	^8994.021^ 1^1^315121 5^^^
	895	"KRN",8994 ,212,2,3,1 ,1,0)
	896	Value of c cow token passed.
	897	"KRN",8994 ,212,2,"B" ,"CCOWTOK" ,3)
	898
	899	"KRN",8994 ,212,2,"B" ,"CLIENT-I P",1)
	900
	901	"KRN",8994 ,212,2,"B" ,"SERVER-N M",2)
	902
	903	"KRN",8994 ,212,2,"PA RAMSEQ",1, 1)
	904
	905	"KRN",8994 ,212,2,"PA RAMSEQ",2, 2)
	906
	907	"KRN",8994 ,212,2,"PA RAMSEQ",3, 3)
	908
	909	"KRN",8994 ,212,3,0)
	910	^8994.03^2 0^20^31512 15^^
	911	"KRN",8994 ,212,3,1,0 )
	912	output is the same a s the RPC named XUS FATKAAT GE T USER INF O.
	913	"KRN",8994 ,212,3,2,0 )
	914
	915	"KRN",8994 ,212,3,3,0 )
	916	OUTPUT:
	917	"KRN",8994 ,212,3,4,0 )
	918	Result(0) is the us ers DUZ.
	919	"KRN",8994 ,212,3,5,0 )
	920	Result(1) is the us er name fr om the .01 field.
	921	"KRN",8994 ,212,3,6,0 )
	922	Result(2) is the us ers full n ame from t he name st andard fil e.
	923	"KRN",8994 ,212,3,7,0 )
	924	Result(3) is the FA MILY (LAST ) NAME
	925	"KRN",8994 ,212,3,8,0 )
	926	Result(4) is the GI VEN (FIRST ) NAME
	927	"KRN",8994 ,212,3,9,0 )
	928	Result(5) is the MI DDLE NAME
	929	"KRN",8994 ,212,3,10, 0)
	930	Result(6) is the PR EFIX
	931	"KRN",8994 ,212,3,11, 0)
	932	Result(7) is the SU FFIX
	933	"KRN",8994 ,212,3,12, 0)
	934	Result(8) is the DE GREE
	935	"KRN",8994 ,212,3,13, 0)
	936	Result(9) is statio n # of the division that the u ser is wor king in.
	937	"KRN",8994 ,212,3,14, 0)
	938	Result(10 ) is the s tation # o f the pare nt facilit y for the login divi sion
	939	"KRN",8994 ,212,3,15, 0)
	940	Result(11 ) is the s tation # f rom the KS P site par ameters, t he parent
	941	"KRN",8994 ,212,3,16, 0)
	942	"computer system"
	943	"KRN",8994 ,212,3,17, 0)
	944	Result(12 ) is the s ignon log entry IEN
	945	"KRN",8994 ,212,3,18, 0)
	946	Result(13 ) = # of p ermissible divisions
	947	"KRN",8994 ,212,3,19, 0)
	948	Result(14 -n) are th e permissi ble divisi ons for us er login, in the for mat:
	949	"KRN",8994 ,212,3,20, 0)
	950	IEN of fi le 4^Stati on Name^St ation Numb er^default ? (1 or 0)
	951	"KRN",8994 ,213,-1)
	952	0^13
	953	"KRN",8994 ,213,0)
	954	XUS KAAJEE GET CCOW TOKEN^CCOW IP^XUSKAAJ 1^2^R^^^^1 ^^1
	955	"KRN",8994 ,213,1,0)
	956	^8994.01^1 ^1^3151215 ^^^
	957	"KRN",8994 ,213,1,1,0 )
	958	This RPC g ets a toke n to save in the CCO W context to aid in sign-on
	959	"KRN",8994 ,213,2,0)
	960	^8994.02A^ 1^1
	961	"KRN",8994 ,213,2,1,0 )
	962	IP-ADDRESS ^1^30^0^1
	963	"KRN",8994 ,213,2,1,1 ,0)
	964	^8994.021^ 4^4^315121 5^^
	965	"KRN",8994 ,213,2,1,1 ,1,0)
	966	This value represent s the IP a ddress of the workst ation. Us eful for J 2EE
	967	"KRN",8994 ,213,2,1,1 ,2,0)
	968	applicatio ns that co nnect to V istA via t he applica tion serve r. If pres ent,
	969	"KRN",8994 ,213,2,1,1 ,3,0)
	970	this value will be u sed when a ssociating a CCOW to ken to the IP
	971	"KRN",8994 ,213,2,1,1 ,4,0)
	972	address of the clien t workstat ion
	973	"KRN",8994 ,213,2,"B" ,"IP-ADDRE SS",1)
	974
	975	"KRN",8994 ,213,2,"PA RAMSEQ",1, 1)
	976
	977	"KRN",8994 ,332,-1)
	978	0^5
	979	"KRN",8994 ,332,0)
	980	XUS IAM AD D USER^IAM AU^XUESSO3 ^2^S^^^^1^ ^0
	981	"KRN",8994 ,332,1,0)
	982	^^7^7^3160 225^
	983	"KRN",8994 ,332,1,1,0 )
	984	RPC ICR #6 290 - API ICR #none
	985	"KRN",8994 ,332,1,2,0 )
	986	This restr icted RPC is used ex clusively by the Ide ntity and Access
	987	"KRN",8994 ,332,1,3,0 )
	988	Management (IAM) Pro visioning applicatio n to add a user to t he VistA N EW
	989	"KRN",8994 ,332,1,4,0 )
	990	PERSON fil e (#200).
	991	"KRN",8994 ,332,1,5,0 )
	992
	993	"KRN",8994 ,332,1,6,0 )
	994	The XUSPF2 00 Securit y Key is r equired to add a use r without an SSN (fi le
	995	"KRN",8994 ,332,1,7,0 )
	996	#200 speci al privile ges).
	997	"KRN",8994 ,332,2,0)
	998	^8994.02A^ 8^8
	999	"KRN",8994 ,332,2,1,0 )
	1000	NAME^1^35^ 1^1
	1001	"KRN",8994 ,332,2,1,1 ,0)
	1002	^^2^2^3150 206^
	1003	"KRN",8994 ,332,2,1,1 ,1,0)
	1004	NAME field (#.01) in the NEW P ERSON file (#200) to match the SubjectID in
	1005	"KRN",8994 ,332,2,1,1 ,2,0)
	1006	the user's SAML Toke n.
	1007	"KRN",8994 ,332,2,2,0 )
	1008	SECID^1^30 ^1^2
	1009	"KRN",8994 ,332,2,2,1 ,0)
	1010	^8994.021^ 2^2^315021 0^^
	1011	"KRN",8994 ,332,2,2,1 ,1,0)
	1012	SECID fiel d (#205.1) in the NE W PERSON f ile (#200) to match the SecID in
	1013	"KRN",8994 ,332,2,2,1 ,2,0)
	1014	the user's SAML Toke n.
	1015	"KRN",8994 ,332,2,3,0 )
	1016	EMAIL^1^50 ^0^3
	1017	"KRN",8994 ,332,2,3,1 ,0)
	1018	^^1^1^3150 206^
	1019	"KRN",8994 ,332,2,3,1 ,1,0)
	1020	EMAIL fiel d (#.151) in the NEW PERSON fi le (#200).
	1021	"KRN",8994 ,332,2,4,0 )
	1022	ADUPN^1^50 ^0^4
	1023	"KRN",8994 ,332,2,4,1 ,0)
	1024	^^2^2^3150 211^
	1025	"KRN",8994 ,332,2,4,1 ,1,0)
	1026	AD UPN fie ld (#205.5 ) in the N EW PERSON file (#200 ) to match user's Ac tive
	1027	"KRN",8994 ,332,2,4,1 ,2,0)
	1028	Directory UPN.
	1029	"KRN",8994 ,332,2,4,2 )
	1030
	1031	"KRN",8994 ,332,2,5,0 )
	1032	SSN^1^9^0^ 5
	1033	"KRN",8994 ,332,2,5,1 ,0)
	1034	^^4^4^3150 206^
	1035	"KRN",8994 ,332,2,5,1 ,1,0)
	1036	SSN field (#9) in th e NEW PERS ON file (# 200) to ma tch the us er's Socia l
	1037	"KRN",8994 ,332,2,5,1 ,2,0)
	1038	Security N umber or T axpayer Id entificati on Number. While not required to
	1039	"KRN",8994 ,332,2,5,1 ,3,0)
	1040	provision a VistA us er, not po pulating t his field with a val id SSN cou ld
	1041	"KRN",8994 ,332,2,5,1 ,4,0)
	1042	prevent ac cess to so me applica tions and data in Vi stA.
	1043	"KRN",8994 ,332,2,6,0 )
	1044	DOB^1^20^0 ^6
	1045	"KRN",8994 ,332,2,6,1 ,0)
	1046	^^2^2^3150 206^
	1047	"KRN",8994 ,332,2,6,1 ,1,0)
	1048	DOB field (#5) in th e NEW PERS ON file (# 200) to ma tch the us er's Date of
	1049	"KRN",8994 ,332,2,6,1 ,2,0)
	1050	Birth.
	1051	"KRN",8994 ,332,2,7,0 )
	1052	STATION^1^ 20^0^7
	1053	"KRN",8994 ,332,2,7,1 ,0)
	1054	^8994.021^ 3^3^315021 0^^
	1055	"KRN",8994 ,332,2,7,1 ,1,0)
	1056	DIVISION f ield (#.01 ) of the D IVISION mu ltiple (#1 6) in the NEW PERSON
	1057	"KRN",8994 ,332,2,7,1 ,2,0)
	1058	file (#200 ). The nam e of a Div ision that this user may sign on to. The
	1059	"KRN",8994 ,332,2,7,1 ,3,0)
	1060	Division s hould be a n active t reating fa cility.
	1061	"KRN",8994 ,332,2,8,0 )
	1062	AUTHCODE^1 ^80^1^8
	1063	"KRN",8994 ,332,2,8,1 ,0)
	1064	^8994.021^ 1^1^315073 0^^^^
	1065	"KRN",8994 ,332,2,8,1 ,1,0)
	1066	Security P hrase for IAM Provis ioning App lication.
	1067	"KRN",8994 ,332,2,"B" ,"ADUPN",4 )
	1068
	1069	"KRN",8994 ,332,2,"B" ,"AUTHCODE ",8)
	1070
	1071	"KRN",8994 ,332,2,"B" ,"DOB",6)
	1072
	1073	"KRN",8994 ,332,2,"B" ,"EMAIL",3 )
	1074
	1075	"KRN",8994 ,332,2,"B" ,"NAME",1)
	1076
	1077	"KRN",8994 ,332,2,"B" ,"SECID",2 )
	1078
	1079	"KRN",8994 ,332,2,"B" ,"SSN",5)
	1080
	1081	"KRN",8994 ,332,2,"B" ,"STATION" ,7)
	1082
	1083	"KRN",8994 ,332,2,"PA RAMSEQ",1, 1)
	1084
	1085	"KRN",8994 ,332,2,"PA RAMSEQ",2, 2)
	1086
	1087	"KRN",8994 ,332,2,"PA RAMSEQ",3, 3)
	1088
	1089	"KRN",8994 ,332,2,"PA RAMSEQ",4, 4)
	1090
	1091	"KRN",8994 ,332,2,"PA RAMSEQ",5, 5)
	1092
	1093	"KRN",8994 ,332,2,"PA RAMSEQ",6, 6)
	1094
	1095	"KRN",8994 ,332,2,"PA RAMSEQ",7, 7)
	1096
	1097	"KRN",8994 ,332,2,"PA RAMSEQ",8, 8)
	1098
	1099	"KRN",8994 ,332,3,0)
	1100	^^3^3^3150 730^
	1101	"KRN",8994 ,332,3,1,0 )
	1102	Fail R( 0) = " -1^Number of Errors"
	1103	"KRN",8994 ,332,3,2,0 )
	1104	R( 1) through R(n) = " Error Mess age"
	1105	"KRN",8994 ,332,3,3,0 )
	1106	Success R( 0) = " DUZ^STATIO N"
	1107	"KRN",8994 ,333,-1)
	1108	0^4
	1109	"KRN",8994 ,333,0)
	1110	XUS IAM ED IT USER^IA MEU^XUESSO 3^2^S^^^^1 ^^0
	1111	"KRN",8994 ,333,1,0)
	1112	^^11^11^31 51209^
	1113	"KRN",8994 ,333,1,1,0 )
	1114	RPC ICR #6 291 - API ICR #none
	1115	"KRN",8994 ,333,1,2,0 )
	1116	This restr icted RPC is used ex clusively by the Ide ntity and Access
	1117	"KRN",8994 ,333,1,3,0 )
	1118	Management (IAM) Pro visioning applicatio n to edit an existin g user in the
	1119	"KRN",8994 ,333,1,4,0 )
	1120	VistA NEW PERSON fil e (#200).
	1121	"KRN",8994 ,333,1,5,0 )
	1122
	1123	"KRN",8994 ,333,1,6,0 )
	1124	The XUSHOW SSN Securi ty Key is required t o edit Per sonally Id entifiable
	1125	"KRN",8994 ,333,1,7,0 )
	1126	Informatio n (PII) su ch as Soci al Securit y Number ( SSN) or Da te of Birt h
	1127	"KRN",8994 ,333,1,8,0 )
	1128	(DOB).
	1129	"KRN",8994 ,333,1,9,0 )
	1130
	1131	"KRN",8994 ,333,1,10, 0)
	1132	The XUSPF2 00 Securit y Key is r equired to edit a us er without an SSN (f ile
	1133	"KRN",8994 ,333,1,11, 0)
	1134	#200 speci al privile ges).
	1135	"KRN",8994 ,333,2,0)
	1136	^8994.02A^ 2^2
	1137	"KRN",8994 ,333,2,1,0 )
	1138	INARRY^2^2 40^1^1
	1139	"KRN",8994 ,333,2,1,1 ,0)
	1140	^^13^13^31 50707^
	1141	"KRN",8994 ,333,2,1,1 ,1,0)
	1142	INARRY("SE CID") = Se cID (not e dited, but used to i dentify en try to be
	1143	"KRN",8994 ,333,2,1,1 ,2,0)
	1144	ed ited)
	1145	"KRN",8994 ,333,2,1,1 ,3,0)
	1146	INARRY("LA STNAME") = User NAME is concat enation of "LASTNAME ,FIRSTNAME
	1147	"KRN",8994 ,333,2,1,1 ,4,0)
	1148	MIDDLENAM E SUFFIX"
	1149	"KRN",8994 ,333,2,1,1 ,5,0)
	1150	INARRY("FI RSTNAME")
	1151	"KRN",8994 ,333,2,1,1 ,6,0)
	1152	INARRY("MI DDLENAME")
	1153	"KRN",8994 ,333,2,1,1 ,7,0)
	1154	INARRY("SU FFIX")
	1155	"KRN",8994 ,333,2,1,1 ,8,0)
	1156	INARRY("OR GANIZATION NAME") = S UBJECT ORG ANIZATION (Organizat ion Name)
	1157	"KRN",8994 ,333,2,1,1 ,9,0)
	1158	INARRY("OR GANIZATION ID") = SUB JECT ORGAN IZATION ID (Organiza tion ID)
	1159	"KRN",8994 ,333,2,1,1 ,10,0)
	1160	INARRY("EM AIL") = EM AIL ADDRES S (E-mail Address)
	1161	"KRN",8994 ,333,2,1,1 ,11,0)
	1162	INARRY("AD UPN") = AD UPN (Activ e Director y UPN)
	1163	"KRN",8994 ,333,2,1,1 ,12,0)
	1164	INARRY("SS N") = SSN (Social Se curity Num ber)
	1165	"KRN",8994 ,333,2,1,1 ,13,0)
	1166	INARRY("DO B) = DOB ( Date of Bi rth)
	1167	"KRN",8994 ,333,2,2,0 )
	1168	AUTHCODE^1 ^80^1^2
	1169	"KRN",8994 ,333,2,2,1 ,0)
	1170	^8994.021^ 1^1^315062 9^^^^
	1171	"KRN",8994 ,333,2,2,1 ,1,0)
	1172	Security P hrase for IAM Provis ioning App lication.
	1173	"KRN",8994 ,333,2,"B" ,"AUTHCODE ",2)
	1174
	1175	"KRN",8994 ,333,2,"B" ,"INARRY", 1)
	1176
	1177	"KRN",8994 ,333,2,"PA RAMSEQ",1, 1)
	1178
	1179	"KRN",8994 ,333,2,"PA RAMSEQ",2, 2)
	1180
	1181	"KRN",8994 ,333,3,0)
	1182	^^3^3^3150 629^
	1183	"KRN",8994 ,333,3,1,0 )
	1184	Success RE S(0)=DUZ o f NEW PERS ON file en try that w as edited
	1185	"KRN",8994 ,333,3,2,0 )
	1186	Fail RE S(0)="-1^N umber of E rrors"
	1187	"KRN",8994 ,333,3,3,0 )
	1188	RE S(1) throu gh Y(n)="E rror Messa ge"
	1189	"KRN",8994 ,334,-1)
	1190	0^2
	1191	"KRN",8994 ,334,0)
	1192	XUS IAM FI ND USER^IA MFU^XUESSO 3^2^S^^^^1 ^^0
	1193	"KRN",8994 ,334,1,0)
	1194	^^9^9^3151 209^
	1195	"KRN",8994 ,334,1,1,0 )
	1196	RPC ICR #6 288 - API ICR #none
	1197	"KRN",8994 ,334,1,2,0 )
	1198	This restr icted RPC is used ex clusively by the Ide ntity and Access
	1199	"KRN",8994 ,334,1,3,0 )
	1200	Management (IAM) Pro visioning applicatio n to find a list of users that
	1201	"KRN",8994 ,334,1,4,0 )
	1202	satisfy a collection of input criteria.
	1203	"KRN",8994 ,334,1,5,0 )
	1204
	1205	"KRN",8994 ,334,1,6,0 )
	1206	One or mor e of the i nput array values mu st be set by the cal ling
	1207	"KRN",8994 ,334,1,7,0 )
	1208	applicatio n. The XUS HOWSSN Sec urity Key is require d to do lo okups usin g
	1209	"KRN",8994 ,334,1,8,0 )
	1210	Personally Identifia ble Inform ation (PII ) such as Social Sec urity Numb er
	1211	"KRN",8994 ,334,1,9,0 )
	1212	(SSN) or D ate of Bir th (DOB).
	1213	"KRN",8994 ,334,2,0)
	1214	^8994.02A^ 6^6
	1215	"KRN",8994 ,334,2,1,0 )
	1216	NAME^1^35^ 0^1
	1217	"KRN",8994 ,334,2,1,1 ,0)
	1218	^8994.021^ 1^1^315012 8^^
	1219	"KRN",8994 ,334,2,1,1 ,1,0)
	1220	Search on user name.
	1221	"KRN",8994 ,334,2,2,0 )
	1222	SSN^1^9^^2
	1223	"KRN",8994 ,334,2,2,1 ,0)
	1224	^^2^2^3150 210^
	1225	"KRN",8994 ,334,2,2,1 ,1,0)
	1226	Search on user Socia l Security Number (S SN). The u ser callin g this RPC
	1227	"KRN",8994 ,334,2,2,1 ,2,0)
	1228	must hold the XUSHOW SSN Securi ty Key to search usi ng SSN.
	1229	"KRN",8994 ,334,2,3,0 )
	1230	DOB^1^15^^ 3
	1231	"KRN",8994 ,334,2,3,1 ,0)
	1232	^^2^2^3150 210^
	1233	"KRN",8994 ,334,2,3,1 ,1,0)
	1234	Search on user Date of Birth ( DOB). The user calli ng this RP C must hol d
	1235	"KRN",8994 ,334,2,3,1 ,2,0)
	1236	the XUSHOW SSN Securi ty Key to search usi ng DOB.
	1237	"KRN",8994 ,334,2,4,0 )
	1238	ADUPN^1^50 ^^4
	1239	"KRN",8994 ,334,2,4,1 ,0)
	1240	^8994.021^ 1^1^315020 6^^
	1241	"KRN",8994 ,334,2,4,1 ,1,0)
	1242	Search on user Activ e Director y UPN.
	1243	"KRN",8994 ,334,2,5,0 )
	1244	SECID^1^30 ^^5
	1245	"KRN",8994 ,334,2,5,1 ,0)
	1246	^8994.021^ 1^1^315021 0^^^
	1247	"KRN",8994 ,334,2,5,1 ,1,0)
	1248	Search on user Secur ity ID.
	1249	"KRN",8994 ,334,2,6,0 )
	1250	AUTHCODE^1 ^80^1^6
	1251	"KRN",8994 ,334,2,6,1 ,0)
	1252	^8994.021^ 1^1^315072 9^^^
	1253	"KRN",8994 ,334,2,6,1 ,1,0)
	1254	Security P hrase for IAM Provis ioning App lication.
	1255	"KRN",8994 ,334,2,"B" ,"ADUPN",4 )
	1256
	1257	"KRN",8994 ,334,2,"B" ,"AUTHCODE ",6)
	1258
	1259	"KRN",8994 ,334,2,"B" ,"DOB",3)
	1260
	1261	"KRN",8994 ,334,2,"B" ,"NAME",1)
	1262
	1263	"KRN",8994 ,334,2,"B" ,"SECID",5 )
	1264
	1265	"KRN",8994 ,334,2,"B" ,"SSN",2)
	1266
	1267	"KRN",8994 ,334,2,"PA RAMSEQ",1, 1)
	1268
	1269	"KRN",8994 ,334,2,"PA RAMSEQ",2, 2)
	1270
	1271	"KRN",8994 ,334,2,"PA RAMSEQ",3, 3)
	1272
	1273	"KRN",8994 ,334,2,"PA RAMSEQ",4, 4)
	1274
	1275	"KRN",8994 ,334,2,"PA RAMSEQ",5, 5)
	1276
	1277	"KRN",8994 ,334,2,"PA RAMSEQ",6, 6)
	1278
	1279	"KRN",8994 ,334,3,0)
	1280	^^3^3^3150 729^
	1281	"KRN",8994 ,334,3,1,0 )
	1282	Fail R( 0)="-1^Err or Message "
	1283	"KRN",8994 ,334,3,2,0 )
	1284	Success R( 0)=total n umber of e ntries fou nd, from " 0" to "n".
	1285	"KRN",8994 ,334,3,3,0 )
	1286	R( 1) through R(n)="DUZ ^Name^Name Component s^SSN^Dob^ AD UPN^Sec ID"
	1287	"KRN",8994 ,337,-1)
	1288	0^3
	1289	"KRN",8994 ,337,0)
	1290	XUS IAM DI SPLAY USER ^IAMDU^XUE SSO3^2^S^^ ^^1^^0
	1291	"KRN",8994 ,337,1,0)
	1292	^^7^7^3160 225^
	1293	"KRN",8994 ,337,1,1,0 )
	1294	RPC ICE #6 289 - API ICR #none
	1295	"KRN",8994 ,337,1,2,0 )
	1296	This restr icted RPC is used ex clusively by the Ide ntity and Access
	1297	"KRN",8994 ,337,1,3,0 )
	1298	Management (IAM) Pro visioning applicatio n to displ ay a VistA user.
	1299	"KRN",8994 ,337,1,4,0 )
	1300
	1301	"KRN",8994 ,337,1,5,0 )
	1302	The XUSHOW SSN Securi ty Key is required t o display Personally Identifia ble
	1303	"KRN",8994 ,337,1,6,0 )
	1304	Informatio n (PII) su ch as Soci al Securit y Number ( SSN) or Da te of Birt h
	1305	"KRN",8994 ,337,1,7,0 )
	1306	(DOB).
	1307	"KRN",8994 ,337,2,0)
	1308	^8994.02A^ 2^2
	1309	"KRN",8994 ,337,2,1,0 )
	1310	DISPDUZ^1^ 20^1^1
	1311	"KRN",8994 ,337,2,1,1 ,0)
	1312	^8994.021^ 1^1^315021 0^^^
	1313	"KRN",8994 ,337,2,1,1 ,1,0)
	1314	DUZ (IEN) of user to be displa yed.
	1315	"KRN",8994 ,337,2,2,0 )
	1316	AUTHCODE^1 ^80^1^2
	1317	"KRN",8994 ,337,2,2,1 ,0)
	1318	^8994.021^ 1^1^315072 2^^^^
	1319	"KRN",8994 ,337,2,2,1 ,1,0)
	1320	Security P hrase for IAM Provis ioning App lication.
	1321	"KRN",8994 ,337,2,"B" ,"AUTHCODE ",2)
	1322
	1323	"KRN",8994 ,337,2,"B" ,"DISPDUZ" ,1)
	1324
	1325	"KRN",8994 ,337,2,"PA RAMSEQ",1, 1)
	1326
	1327	"KRN",8994 ,337,2,"PA RAMSEQ",2, 2)
	1328
	1329	"KRN",8994 ,337,3,0)
	1330	^^36^36^31 50722^
	1331	"KRN",8994 ,337,3,1,0 )
	1332	Fail
	1333	"KRN",8994 ,337,3,2,0 )
	1334	R(0) ="- 1^Error Me ssage"
	1335	"KRN",8994 ,337,3,3,0 )
	1336	Success
	1337	"KRN",8994 ,337,3,4,0 )
	1338	R(0) = 1
	1339	"KRN",8994 ,337,3,5,0 )
	1340	R("NAME" ) = NAME
	1341	"KRN",8994 ,337,3,6,0 )
	1342	R("LASTN AME") = Fa mily Name
	1343	"KRN",8994 ,337,3,7,0 )
	1344	R("FIRST NAME") = G iven Name
	1345	"KRN",8994 ,337,3,8,0 )
	1346	R("MIDDL ENAME") = Middle Nam e
	1347	"KRN",8994 ,337,3,9,0 )
	1348	R("SUFFI X") = Suff ix(es)
	1349	"KRN",8994 ,337,3,10, 0)
	1350	R("INITI AL") = INI TIAL
	1351	"KRN",8994 ,337,3,11, 0)
	1352	R("TITLE ") = TITLE
	1353	"KRN",8994 ,337,3,12, 0)
	1354	R("NICK_ NAME") = N ICK NAME
	1355	"KRN",8994 ,337,3,13, 0)
	1356	R("SSN") = SSN (<H idden> if caller doe s not hold XUSHOWSSN key)
	1357	"KRN",8994 ,337,3,14, 0)
	1358	R("DOB") = DOB (<H idden> if caller doe s not hold XUSHOWSSN key)
	1359	"KRN",8994 ,337,3,15, 0)
	1360	R("DEGRE E") = DEGR EE
	1361	"KRN",8994 ,337,3,16, 0)
	1362	R("MAIL_ CODE") = M AIL CODE
	1363	"KRN",8994 ,337,3,17, 0)
	1364	R("STATU S") = $$AC TIVE^XUSER (DISPDUZ)
	1365	"KRN",8994 ,337,3,18, 0)
	1366	R("DISUS ER") = DIS USER
	1367	"KRN",8994 ,337,3,19, 0)
	1368	R("TERMI NATION_DAT E") = TERM INATION DA TE
	1369	"KRN",8994 ,337,3,20, 0)
	1370	R("TERMI NATION_REA SON") = TE RMINATION REASON
	1371	"KRN",8994 ,337,3,21, 0)
	1372	R("PRIMA RY_MENU_OP TION") = P RIMARY MEN U OPTION
	1373	"KRN",8994 ,337,3,22, 0)
	1374	R("SECON DARY_MENU_ OPTION",0) = SECONDA RY MENU OP TION (# of entries)
	1375	"KRN",8994 ,337,3,23, 0)
	1376	R("SECON DARY_MENU_ OPTION",1) to R("SEC ONDARY_MEN U_OPTION", n) = entri es
	1377	"KRN",8994 ,337,3,24, 0)
	1378	R("FILE_ MANAGER_AC CESS_CODE" ) = FILE M ANAGER ACC ESS CODE
	1379	"KRN",8994 ,337,3,25, 0)
	1380	R("DIVIS ION",0) = DIVISION ( number of entries)
	1381	"KRN",8994 ,337,3,26, 0)
	1382	R("DIVIS ION",1) to R("DIVISI ON",n) = D IVISION en tries
	1383	"KRN",8994 ,337,3,27, 0)
	1384	R("SERVI CE_SECTION ") = SERVI CE/SECTION
	1385	"KRN",8994 ,337,3,28, 0)
	1386	R("SUBJE CT_ALTERNA TIVE_NAME" ) = SUBJEC T ALTERNAT IVE NAME
	1387	"KRN",8994 ,337,3,29, 0)
	1388	R("SECID ") = SECID
	1389	"KRN",8994 ,337,3,30, 0)
	1390	R("ORGAN IZATION_NA ME") = SUB JECT ORGAN IZATION
	1391	"KRN",8994 ,337,3,31, 0)
	1392	R("ORGAN IZATION_ID ") = SUBJE CT ORGANIZ ATION ID
	1393	"KRN",8994 ,337,3,32, 0)
	1394	R("UNIQU E_USER_ID" ) = UNIQUE USER ID
	1395	"KRN",8994 ,337,3,33, 0)
	1396	R("NETWO RK_USER_NA ME") = NET WORK USERN AME
	1397	"KRN",8994 ,337,3,34, 0)
	1398	R("ADUPN ") = AD UP N
	1399	"KRN",8994 ,337,3,35, 0)
	1400	R("EMAIL ") = EMAIL ADDRESS
	1401	"KRN",8994 ,337,3,36, 0)
	1402	R("GENDE R") = SEX (M/F)
	1403	"KRN",8994 ,338,-1)
	1404	0^1
	1405	"KRN",8994 ,338,0)
	1406	XUS ESSO V ALIDATE^ES SO^XUESSO4 ^2^R^^^^1^ ^0
	1407	"KRN",8994 ,338,1,0)
	1408	^^3^3^3151 209^
	1409	"KRN",8994 ,338,1,1,0 )
	1410	RPC ICR #6 295 - API ICR #none
	1411	"KRN",8994 ,338,1,2,0 )
	1412	This API/R PC uses th e VA Ident ity and Ac cess Manag ement (IAM ) SAML tok en
	1413	"KRN",8994 ,338,1,3,0 )
	1414	definition version 1 .2 attribu tes from a SAML toke n for user sign-on.
	1415	"KRN",8994 ,338,2,0)
	1416	^8994.02A^ 1^1
	1417	"KRN",8994 ,338,2,1,0 )
	1418	DOC^1^30^1 ^1
	1419	"KRN",8994 ,338,2,1,1 ,0)
	1420	^^4^4^3150 305^
	1421	"KRN",8994 ,338,2,1,1 ,1,0)
	1422	Input: D OC = Close d referenc e to globa l root con taining XM L document
	1423	"KRN",8994 ,338,2,1,1 ,2,0)
	1424	(load ed STS SAM L Token). See $$EN^M XMLDOM ins tructions in
	1425	"KRN",8994 ,338,2,1,1 ,3,0)
	1426	the V istA Kerne l Develope rs Guide f or require d format o f
	1427	"KRN",8994 ,338,2,1,1 ,4,0)
	1428	the D OC global.
	1429	"KRN",8994 ,338,2,"B" ,"DOC",1)
	1430
	1431	"KRN",8994 ,338,2,"PA RAMSEQ",1, 1)
	1432
	1433	"KRN",8994 ,338,3,0)
	1434	^8994.03^7 ^7^3150305 ^^^^
	1435	"KRN",8994 ,338,3,1,0 )
	1436	R(0) = DUZ if sign-o n was OK, zero if no t OK.
	1437	"KRN",8994 ,338,3,2,0 )
	1438	R(1) = (0= OK, 1,2... =Can't sig n on for s ome reason ).
	1439	"KRN",8994 ,338,3,3,0 )
	1440	R(2) = Ver ify Code n eeds chang ing.
	1441	"KRN",8994 ,338,3,4,0 )
	1442	R(3) = Mes sage.
	1443	"KRN",8994 ,338,3,5,0 )
	1444	R(4) = 0
	1445	"KRN",8994 ,338,3,6,0 )
	1446	R(5) = cou nt of the number of lines of t ext, zero if none.
	1447	"KRN",8994 ,338,3,7,0 )
	1448	R(5+n) = m essage tex t.
	1449	"KRN",8994 ,339,-1)
	1450	0^6
	1451	"KRN",8994 ,339,0)
	1452	XUS IAM BI ND USER^IA MBU^XUESSO 4^1^S^^^^1 ^^0
	1453	"KRN",8994 ,339,1,0)
	1454	^^5^5^3151 209^
	1455	"KRN",8994 ,339,1,1,0 )
	1456	RPC ICR #6 294 - API ICR #none
	1457	"KRN",8994 ,339,1,2,0 )
	1458	This restr icted RPC is used ex clusively by the Ide ntity and Access
	1459	"KRN",8994 ,339,1,3,0 )
	1460	Management (IAM) Bin ding appli cation to set the Se curity ID (SecID) an d
	1461	"KRN",8994 ,339,1,4,0 )
	1462	Active Dir ectory UPN (ADUPN) i n the Vist A NEW PERS ON file (# 200) for
	1463	"KRN",8994 ,339,1,5,0 )
	1464	Single Sig n-On Inter nal (SSOi) .
	1465	"KRN",8994 ,339,2,0)
	1466	^8994.02A^ 3^3
	1467	"KRN",8994 ,339,2,1,0 )
	1468	SECID^1^40 ^1^1
	1469	"KRN",8994 ,339,2,1,1 ,0)
	1470	^^1^1^3150 311^
	1471	"KRN",8994 ,339,2,1,1 ,1,0)
	1472	Unique Sec urity ID [ SecID, ass igned by I dentity an d Access M anagement]
	1473	"KRN",8994 ,339,2,2,0 )
	1474	AUTHCODE^1 ^80^1^2
	1475	"KRN",8994 ,339,2,2,1 ,0)
	1476	^8994.021^ 1^1^315120 3^^^
	1477	"KRN",8994 ,339,2,2,1 ,1,0)
	1478	Security P hrase for IAM Bindin g Applicat ion
	1479	"KRN",8994 ,339,2,3,0 )
	1480	ADUPN^1^30 ^1^3
	1481	"KRN",8994 ,339,2,3,1 ,0)
	1482	^8994.021^ 1^1^315120 3^^
	1483	"KRN",8994 ,339,2,3,1 ,1,0)
	1484	Active Dir ectory UPN
	1485	"KRN",8994 ,339,2,"B" ,"ADUPN",3 )
	1486
	1487	"KRN",8994 ,339,2,"B" ,"AUTHCODE ",2)
	1488
	1489	"KRN",8994 ,339,2,"B" ,"SECID",1 )
	1490
	1491	"KRN",8994 ,339,2,"PA RAMSEQ",1, 1)
	1492
	1493	"KRN",8994 ,339,2,"PA RAMSEQ",2, 2)
	1494
	1495	"KRN",8994 ,339,2,"PA RAMSEQ",3, 3)
	1496
	1497	"KRN",8994 ,339,3,0)
	1498	^8994.03^2 ^2^3151203 ^^^
	1499	"KRN",8994 ,339,3,1,0 )
	1500	Return: Fa il Y = "-1^Error Message"
	1501	"KRN",8994 ,339,3,2,0 )
	1502	Su ccess Y = DUZ
	1503	"KRN",8994 ,342,-1)
	1504	0^7
	1505	"KRN",8994 ,342,0)
	1506	XUS IAM TE RMINATE US ER^IAMTU^X UESSO3^2^R ^^^^1^^0
	1507	"KRN",8994 ,342,1,0)
	1508	^8994.01^3 ^3^3150722 ^^
	1509	"KRN",8994 ,342,1,1,0 )
	1510	This restr icted RPC is used ex clusively by the Ide ntity and Access
	1511	"KRN",8994 ,342,1,2,0 )
	1512	Management (IAM) Pro visioning applicatio n to termi nate an ex isting use r
	1513	"KRN",8994 ,342,1,3,0 )
	1514	in the Vis tA NEW PER SON file ( #200).
	1515	"KRN",8994 ,342,2,0)
	1516	^8994.02A^ 4^4
	1517	"KRN",8994 ,342,2,1,0 )
	1518	SECID^1^30 ^1^1
	1519	"KRN",8994 ,342,2,1,1 ,0)
	1520	^^2^2^3150 707^
	1521	"KRN",8994 ,342,2,1,1 ,1,0)
	1522	SECID fiel d (#205.1) in the NE W PERSON f ile (#200) to match the SecID in
	1523	"KRN",8994 ,342,2,1,1 ,2,0)
	1524	the user's SAML Toke n.
	1525	"KRN",8994 ,342,2,2,0 )
	1526	TERMDATE^1 ^20^1^2
	1527	"KRN",8994 ,342,2,2,1 ,0)
	1528	^^1^1^3150 707^
	1529	"KRN",8994 ,342,2,2,1 ,1,0)
	1530	TERMINATIO N DATE fie ld (#9.2) in the NEW PERSON fi le (#200).
	1531	"KRN",8994 ,342,2,3,0 )
	1532	TERMRESN^1 ^45^1^3
	1533	"KRN",8994 ,342,2,3,1 ,0)
	1534	^8994.021^ 1^1^315070 7^^
	1535	"KRN",8994 ,342,2,3,1 ,1,0)
	1536	Terminatio n Reason f ield (#9.4 ) in the N EW PERSON file (#200 ).
	1537	"KRN",8994 ,342,2,4,0 )
	1538	AUTHCODE^1 ^80^1^4
	1539	"KRN",8994 ,342,2,4,1 ,0)
	1540	^8994.021^ 1^1^315072 2^^
	1541	"KRN",8994 ,342,2,4,1 ,1,0)
	1542	Security P hrase for IAM Provis ioning App lication.
	1543	"KRN",8994 ,342,2,"B" ,"AUTHCODE ",4)
	1544
	1545	"KRN",8994 ,342,2,"B" ,"SECID",1 )
	1546
	1547	"KRN",8994 ,342,2,"B" ,"TERMDATE ",2)
	1548
	1549	"KRN",8994 ,342,2,"B" ,"TERMRESN ",3)
	1550
	1551	"KRN",8994 ,342,2,"PA RAMSEQ",1, 1)
	1552
	1553	"KRN",8994 ,342,2,"PA RAMSEQ",2, 2)
	1554
	1555	"KRN",8994 ,342,2,"PA RAMSEQ",3, 3)
	1556
	1557	"KRN",8994 ,342,2,"PA RAMSEQ",4, 4)
	1558
	1559	"KRN",8994 ,342,3,0)
	1560	^^3^3^3150 722^
	1561	"KRN",8994 ,342,3,1,0 )
	1562	Fail R( 0) = "-1^N umber of E rrors"
	1563	"KRN",8994 ,342,3,2,0 )
	1564	R( 1) through RES(n)="E rror Messa ge"
	1565	"KRN",8994 ,342,3,3,0 )
	1566	Success R( 0) = 1
	1567	"KRN",8994 ,343,-1)
	1568	0^8
	1569	"KRN",8994 ,343,0)
	1570	XUS IAM RE ACTIVATE U SER^IAMRU^ XUESSO3^2^ S^^^^1^^0
	1571	"KRN",8994 ,343,1,0)
	1572	^^4^4^3151 209^
	1573	"KRN",8994 ,343,1,1,0 )
	1574	RPC ICR #6 293 - API ICR #none
	1575	"KRN",8994 ,343,1,2,0 )
	1576	This restr icted RPC is used ex clusively by the Ide ntity and Access
	1577	"KRN",8994 ,343,1,3,0 )
	1578	Management (IAM) Pro visioning applicatio n to react ivate an e xisting us er
	1579	"KRN",8994 ,343,1,4,0 )
	1580	in the Vis tA NEW PER SON file ( #200).
	1581	"KRN",8994 ,343,2,0)
	1582	^8994.02A^ 2^2
	1583	"KRN",8994 ,343,2,1,0 )
	1584	SECID^1^30 ^1^1
	1585	"KRN",8994 ,343,2,1,1 ,0)
	1586	^^2^2^3150 707^
	1587	"KRN",8994 ,343,2,1,1 ,1,0)
	1588	SECID fiel d (#205.1) in the NE W PERSON f ile (#200) to match the SecID in
	1589	"KRN",8994 ,343,2,1,1 ,2,0)
	1590	the user's SAML Toke n.
	1591	"KRN",8994 ,343,2,2,0 )
	1592	AUTHCODE^1 ^80^1^2
	1593	"KRN",8994 ,343,2,2,1 ,0)
	1594	^8994.021^ 1^1^315072 2^^
	1595	"KRN",8994 ,343,2,2,1 ,1,0)
	1596	Security P hrase for IAM Provis ioning App lication.
	1597	"KRN",8994 ,343,2,"B" ,"AUTHCODE ",2)
	1598
	1599	"KRN",8994 ,343,2,"B" ,"SECID",1 )
	1600
	1601	"KRN",8994 ,343,2,"PA RAMSEQ",1, 1)
	1602
	1603	"KRN",8994 ,343,2,"PA RAMSEQ",2, 2)
	1604
	1605	"KRN",8994 ,343,3,0)
	1606	^^3^3^3150 722^
	1607	"KRN",8994 ,343,3,1,0 )
	1608	Fail R( 0) = "-1^N umber of E rrors"
	1609	"KRN",8994 ,343,3,2,0 )
	1610	R( 1) through RES(n) = "Error Mes sage"
	1611	"KRN",8994 ,343,3,3,0 )
	1612	Success R( 0) = 1
	1613	"KRN",8994 ,347,-1)
	1614	0^17
	1615	"KRN",8994 ,347,0)
	1616	XUS BSE TO KEN^BSETOK EN^XUSBSE1 ^1^S^^^^1^ ^1
	1617	"KRN",8994 ,347,1,0)
	1618	^^5^5^3160 105^
	1619	"KRN",8994 ,347,1,1,0 )
	1620	RPC ICR #T BD - API I CR #none
	1621	"KRN",8994 ,347,1,2,0 )
	1622	This API/R PC returns a string from the c urrent use r authenti cation tha t
	1623	"KRN",8994 ,347,1,3,0 )
	1624	can be use d to authe nticate th e user on a visited system. Th e applicat ion
	1625	"KRN",8994 ,347,1,4,0 )
	1626	is identif ied by a s ecurity ph rase that, when hash ed, matche s the stor ed
	1627	"KRN",8994 ,347,1,5,0 )
	1628	hash of an authorize d applicat ion in the REMOTE AP PLICATION file (#899 4.5)
	1629	"KRN",8994 ,347,2,0)
	1630	^8994.02A^ 1^1
	1631	"KRN",8994 ,347,2,1,0 )
	1632	XPHRASE^1^ 90^1^1
	1633	"KRN",8994 ,347,2,1,1 ,0)
	1634	^^2^2^3160 105^
	1635	"KRN",8994 ,347,2,1,1 ,1,0)
	1636	Input: X PHRASE = S ecurity ph rase to be used to a uthenticat e and iden tify
	1637	"KRN",8994 ,347,2,1,1 ,2,0)
	1638	the applic ation.
	1639	"KRN",8994 ,347,2,"B" ,"XPHRASE" ,1)
	1640
	1641	"KRN",8994 ,347,2,"PA RAMSEQ",1, 1)
	1642
	1643	"KRN",8994 ,347,3,0)
	1644	^8994.03^3 ^3^3160105 ^^
	1645	"KRN",8994 ,347,3,1,0 )
	1646	RET = Comp lete BSE l ogin strin g (no proc essing req uired by m iddleware or
	1647	"KRN",8994 ,347,3,2,0 )
	1648	client) to be passed to the XW BUSRNM inp ut paramet er of the XUS SIGNON
	1649	"KRN",8994 ,347,3,3,0 )
	1650	SETUP remo te procedu re.
	1651	"MBREQ")
	1652	0
	1653	"ORD",0,9. 8)
	1654	9.8;;1;RTN F^XPDTA;RT NE^XPDTA
	1655	"ORD",0,9. 8,0)
	1656	ROUTINE
	1657	"ORD",5,.4 )
	1658	.4;5;;;EDE OUT^DIFROM SO(.4,DA," ",XPDA);FP RE^DIFROMS I(.4,"",XP DA);EPRE^D IFROMSI(.4 ,DA,$E("N" ,$G(XPDNEW )),XPDA,"" ,OLDA);;EP OST^DIFROM SI(.4,DA," ",XPDA);DE L^DIFROMSK (.4,"",%)
	1659	"ORD",5,.4 ,0)
	1660	PRINT TEMP LATE
	1661	"ORD",16,8 994)
	1662	8994;16;1; ;;;;;;RPCD EL^XPDIA1
	1663	"ORD",16,8 994,0)
	1664	REMOTE PRO CEDURE
	1665	"ORD",18,1 9)
	1666	19;18;;;OP T^XPDTA;OP TF1^XPDIA; OPTE1^XPDI A;OPTF2^XP DIA;;OPTDE L^XPDIA
	1667	"ORD",18,1 9,0)
	1668	OPTION
	1669	"PKG",3,-1 )
	1670	1^1
	1671	"PKG",3,0)
	1672	KERNEL^XU^ SIGN-ON, S ECURITY, M ENU DRIVER , DEVICES, TASKMAN^
	1673	"PKG",3,22 ,0)
	1674	^9.49I^1^1
	1675	"PKG",3,22 ,1,0)
	1676	8.0^309070 6^3090706^ 6
	1677	"PKG",3,22 ,1,"PAH",1 ,0)
	1678	659^316030 8
	1679	"PKG",3,22 ,1,"PAH",1 ,1,0)
	1680	^^8^8^3160 308
	1681	"PKG",3,22 ,1,"PAH",1 ,1,1,0)
	1682	This patch provides enhancemen ts needed to impleme nt Single Sign-On
	1683	"PKG",3,22 ,1,"PAH",1 ,1,2,0)
	1684	Internal ( SSOi) for identifica tion and a uthenticat ion of use rs into Vi stA.
	1685	"PKG",3,22 ,1,"PAH",1 ,1,3,0)
	1686
	1687	"PKG",3,22 ,1,"PAH",1 ,1,4,0)
	1688	The use of these uti lities are expected to improve security and auditi ng
	1689	"PKG",3,22 ,1,"PAH",1 ,1,5,0)
	1690	capabiliti es in acco rdance wit h VA Handb ook 6500 A ppendix F and revisi on 4
	1691	"PKG",3,22 ,1,"PAH",1 ,1,6,0)
	1692	of NIST SP 800-53. A s required by FIPS 1 99 and usi ng guidanc e from NIS T SP
	1693	"PKG",3,22 ,1,"PAH",1 ,1,7,0)
	1694	800-60, th e recommen ded securi ty categor ization fo r these ap plications is
	1695	"PKG",3,22 ,1,"PAH",1 ,1,8,0)
	1696	HIGH.
	1697	"QUES","XP F1",0)
	1698	Y
	1699	"QUES","XP F1","??")
	1700	^D REP^XPD H
	1701	"QUES","XP F1","A")
	1702	Shall I wr ite over y our \|FLAG\| File
	1703	"QUES","XP F1","B")
	1704	YES
	1705	"QUES","XP F1","M")
	1706	D XPF1^XPD IQ
	1707	"QUES","XP F2",0)
	1708	Y
	1709	"QUES","XP F2","??")
	1710	^D DTA^XPD H
	1711	"QUES","XP F2","A")
	1712	Want my da ta \|FLAG\| yours
	1713	"QUES","XP F2","B")
	1714	YES
	1715	"QUES","XP F2","M")
	1716	D XPF2^XPD IQ
	1717	"QUES","XP I1",0)
	1718	YO
	1719	"QUES","XP I1","??")
	1720	^D INHIBIT ^XPDH
	1721	"QUES","XP I1","A")
	1722	Want KIDS to INHIBIT LOGONs du ring the i nstall
	1723	"QUES","XP I1","B")
	1724	NO
	1725	"QUES","XP I1","M")
	1726	D XPI1^XPD IQ
	1727	"QUES","XP M1",0)
	1728	PO^VA(200, :EM
	1729	"QUES","XP M1","??")
	1730	^D MG^XPDH
	1731	"QUES","XP M1","A")
	1732	Enter the Coordinato r for Mail Group '\|F LAG\|'
	1733	"QUES","XP M1","B")
	1734
	1735	"QUES","XP M1","M")
	1736	D XPM1^XPD IQ
	1737	"QUES","XP O1",0)
	1738	Y
	1739	"QUES","XP O1","??")
	1740	^D MENU^XP DH
	1741	"QUES","XP O1","A")
	1742	Want KIDS to Rebuild Menu Tree s Upon Com pletion of Install
	1743	"QUES","XP O1","B")
	1744	NO
	1745	"QUES","XP O1","M")
	1746	D XPO1^XPD IQ
	1747	"QUES","XP Z1",0)
	1748	Y
	1749	"QUES","XP Z1","??")
	1750	^D OPT^XPD H
	1751	"QUES","XP Z1","A")
	1752	Want to DI SABLE Sche duled Opti ons, Menu Options, a nd Protoco ls
	1753	"QUES","XP Z1","B")
	1754	NO
	1755	"QUES","XP Z1","M")
	1756	D XPZ1^XPD IQ
	1757	"QUES","XP Z2",0)
	1758	Y
	1759	"QUES","XP Z2","??")
	1760	^D RTN^XPD H
	1761	"QUES","XP Z2","A")
	1762	Want to MO VE routine s to other CPUs
	1763	"QUES","XP Z2","B")
	1764	NO
	1765	"QUES","XP Z2","M")
	1766	D XPZ2^XPD IQ
	1767	"RTN")
	1768	19
	1769	"RTN","XLF NSLK")
	1770	0^27^B3961 6756^B4438 4655
	1771	"RTN","XLF NSLK",1,0)
	1772	XLFNSLK ;I SF/RWF,ISD /HGW - Cal ling a DNS server fo r name loo kup ;12/08 /15 12:44
	1773	"RTN","XLF NSLK",2,0)
	1774	;;8.0;KER NEL;142, 151,425,63 8,659;Ju l 10, 1995 ;Build 22
	1775	"RTN","XLF NSLK",3,0)
	1776	;Per VA D irective 6 402, this routine sh ould not b e modified .
	1777	"RTN","XLF NSLK",4,0)
	1778	;
	1779	"RTN","XLF NSLK",5,0)
	1780	Q
	1781	"RTN","XLF NSLK",6,0)
	1782	TEST ;Test entry
	1783	"RTN","XLF NSLK",7,0)
	1784	N XNAME
	1785	"RTN","XLF NSLK",8,0)
	1786	R !,"Ente r an IP ad dress to l ookup: www . DNS //",XNAME: DTIME S:XN AME="" XNA ME="www. DNS " Q:XNAME[ "^"
	1787	"RTN","XLF NSLK",9,0)
	1788	W !!,"Loo king up IP v4 address : ",XNAME
	1789	"RTN","XLF NSLK",10,0 )
	1790	W !,?5,XN AME,". > " ,$$ADDRESS (XNAME,"A" )
	1791	"RTN","XLF NSLK",11,0 )
	1792	W !!,"Loo king up IP v6 address : ",XNAME
	1793	"RTN","XLF NSLK",12,0 )
	1794	W !,?5,XN AME,". > " ,$$ADDRESS (XNAME,"AA AA")
	1795	"RTN","XLF NSLK",13,0 )
	1796	W !
	1797	"RTN","XLF NSLK",14,0 )
	1798	Q
	1799	"RTN","XLF NSLK",15,0 )
	1800	;
	1801	"RTN","XLF NSLK",16,0 )
	1802	HOST(IP) ; Get a host name from an IP add ress
	1803	"RTN","XLF NSLK",17,0 )
	1804	;ZEXCEPT: AddrToHos tName,INet Info,TextA ddrToBinar y ;Kernel exemption for Cache Objects
	1805	"RTN","XLF NSLK",18,0 )
	1806	N X,Y
	1807	"RTN","XLF NSLK",19,0 )
	1808	I $$VERSI ON^%ZOSV(1 )["Cache" D Q Y
	1809	"RTN","XLF NSLK",20,0 )
	1810	. S X=$SY STEM.INetI nfo.TextAd drToBinary (IP)
	1811	"RTN","XLF NSLK",21,0 )
	1812	. S Y=$SY STEM.INetI nfo.AddrTo HostName(X )
	1813	"RTN","XLF NSLK",22,0 )
	1814	;Enter co de for non -Cache sys tems here:
	1815	"RTN","XLF NSLK",23,0 )
	1816	Q ""
	1817	"RTN","XLF NSLK",24,0 )
	1818	;
	1819	"RTN","XLF NSLK",25,0 )
	1820	ADDRESS(N, T) ;Get a IP address from a na me
	1821	"RTN","XLF NSLK",26,0 )
	1822	;ZEXCEPT: HostNameT oAddr,INet Info ;Kern el exempti on for Cac he Objects
	1823	"RTN","XLF NSLK",27,0 )
	1824	N X,XLF,Y ,I S XLF=" ",Y=0
	1825	"RTN","XLF NSLK",28,0 )
	1826	I $$VERSI ON^XLFIPV S T=$G(T," AAAA")
	1827	"RTN","XLF NSLK",29,0 )
	1828	E S T=$G (T,"A") ; change def ault to "A " if VistA has IPv6 disabled
	1829	"RTN","XLF NSLK",30,0 )
	1830	I ($$VERS ION^%ZOSV( 1)["Cache" )&((T="A") !(T="AAAA" )) D Q Y
	1831	"RTN","XLF NSLK",31,0 )
	1832	. I T="AA AA" D
	1833	"RTN","XLF NSLK",32,0 )
	1834	. . S X=$ SYSTEM.INe tInfo.Host NameToAddr (N,2,0) ;G et IPv6 ad dress
	1835	"RTN","XLF NSLK",33,0 )
	1836	. . S Y=$ $FORCEIP6^ XLFIPV(X) ;Format IP v6 address
	1837	"RTN","XLF NSLK",34,0 )
	1838	. I ($P(Y ,":")="000 0")!(T="A" ) S Y=$SYS TEM.INetIn fo.HostNam eToAddr(N, 1,0) ;Get IPv4 addre ss
	1839	"RTN","XLF NSLK",35,0 )
	1840	;Non-cach e systems and lookup s other th an "A" or "AAAA"
	1841	"RTN","XLF NSLK",36,0 )
	1842	D NS(.XLF ,N,T)
	1843	"RTN","XLF NSLK",37,0 )
	1844	S Y="" F I=1:1:XLF( "ANCOUNT") S:$D(XLF( "AN"_I_"DA TA")) Y=Y_ XLF("AN"_I _"DATA")_" ,"
	1845	"RTN","XLF NSLK",38,0 )
	1846	Q $E(Y,1, $L(Y)-1)
	1847	"RTN","XLF NSLK",39,0 )
	1848	;
	1849	"RTN","XLF NSLK",40,0 )
	1850	MAIL(RET,N ) ;Get the MX addres s for a do main
	1851	"RTN","XLF NSLK",41,0 )
	1852	;RET is t he return array
	1853	"RTN","XLF NSLK",42,0 )
	1854	N XLF,Y,I ,T S XLF=" ",T="MX"
	1855	"RTN","XLF NSLK",43,0 )
	1856	D NS(.XLF ,N,T)
	1857	"RTN","XLF NSLK",44,0 )
	1858	S RET=0,I =0 F S I= $O(XLF("P" ,I)) Q:I'> 0 D
	1859	"RTN","XLF NSLK",45,0 )
	1860	. S N=XLF ("P",I),RE T(I)=N_"^" _$G(XLF("B ",N)),RET= RET+1
	1861	"RTN","XLF NSLK",46,0 )
	1862	Q
	1863	"RTN","XLF NSLK",47,0 )
	1864	;
	1865	"RTN","XLF NSLK",48,0 )
	1866	NS(XL,NAME ,QTYPE,XLF LOG) ;NAME LOOKUP
	1867	"RTN","XLF NSLK",49,0 )
	1868	;XL is th e return a rray, NAME is the na me to look up,
	1869	"RTN","XLF NSLK",50,0 )
	1870	;QTYPE is type of l ookup, XLF LOG is a d ebug array returned.
	1871	"RTN","XLF NSLK",51,0 )
	1872	N RI,DNS, CNT,POP N: '$D(XLFLOG ) XLFLOG S XL("ANCOU NT")=0,CNT =1
	1873	"RTN","XLF NSLK",52,0 )
	1874	D SAVEDEV
	1875	"RTN","XLF NSLK",53,0 )
	1876	NS2 ;
	1877	"RTN","XLF NSLK",54,0 )
	1878	S DNS=$$G ETDNS(CNT) I DNS="" G EXIT
	1879	"RTN","XLF NSLK",55,0 )
	1880	D LOG("Ca ll server: "_DNS)
	1881	"RTN","XLF NSLK",56,0 )
	1882	D CALL^%Z ISTCP(DNS, 53) I POP S CNT=CNT+ 1 G NS2
	1883	"RTN","XLF NSLK",57,0 )
	1884	D LOG("Go t connecti on, Send m essage")
	1885	"RTN","XLF NSLK",58,0 )
	1886	D BUILD(N AME,$G(QTY PE,"AAAA") ),LOG("Wai t for repl y") ; Use s "AAAA" t ype for IP v6 if QTYP E is not d efined
	1887	"RTN","XLF NSLK",59,0 )
	1888	;Close pa rt of READ
	1889	"RTN","XLF NSLK",60,0 )
	1890	D READ,DE CODE
	1891	"RTN","XLF NSLK",61,0 )
	1892	D RESDEV, LOG("Retur ned questi on: "_$G(X L("QD1NAME ")))
	1893	"RTN","XLF NSLK",62,0 )
	1894	Q
	1895	"RTN","XLF NSLK",63,0 )
	1896	EXIT D RES DEV
	1897	"RTN","XLF NSLK",64,0 )
	1898	Q
	1899	"RTN","XLF NSLK",65,0 )
	1900	;
	1901	"RTN","XLF NSLK",66,0 )
	1902	BUILD(Y,T) ;BUILD A QUERY
	1903	"RTN","XLF NSLK",67,0 )
	1904	; ID,PARA M,#of?, #o fA, #of Au th, #of ad d,
	1905	"RTN","XLF NSLK",68,0 )
	1906	N X,%,MSG ,I
	1907	"RTN","XLF NSLK",69,0 )
	1908	S X=" M"_ $C(1,0)_$C (0,1)_$C(0 ,0)_$C(0,0 )_$C(0,0) ;Header
	1909	"RTN","XLF NSLK",70,0 )
	1910	I $E(Y,$L (Y))'="." S:$E(Y,$L( Y))'="." Y =Y_"."
	1911	"RTN","XLF NSLK",71,0 )
	1912	F I=1:1:$ L(Y,".") S %=$P(Y,". ",I) S:$L( %) X=X_$C( $L(%))_% ; FQDN Addre ss
	1913	"RTN","XLF NSLK",72,0 )
	1914	S X=X_$C( 0) ;End of FQDN addr ess
	1915	"RTN","XLF NSLK",73,0 )
	1916	;Type A=1 , NS=2, CN AME=5, MX= 15, AAAA=2 8
	1917	"RTN","XLF NSLK",74,0 )
	1918	S MSG=X_$ C(0,$$TYPE CODE(T))_$ C(0,1) ;ty pe and cla ss
	1919	"RTN","XLF NSLK",75,0 )
	1920	D LOG("ms g: "_MSG)
	1921	"RTN","XLF NSLK",76,0 )
	1922	U IO S %= $L(MSG) W $C(%\256,% #256)_MSG, !
	1923	"RTN","XLF NSLK",77,0 )
	1924	Q
	1925	"RTN","XLF NSLK",78,0 )
	1926	READ ;
	1927	"RTN","XLF NSLK",79,0 )
	1928	;ZEXCEPT: I,RI,XL ; Global var iables wit hin this r outine
	1929	"RTN","XLF NSLK",80,0 )
	1930	N L1,L2,X ,$ET S $ET ="G RDERR" K RI S RI =0
	1931	"RTN","XLF NSLK",81,0 )
	1932	U IO R L1 #2:20 I '$ T D LOG("T ime-out") G RDERR
	1933	"RTN","XLF NSLK",82,0 )
	1934	S RI=$A(L 1,1)*256+$ A(L1,2) ;g et msg len gth
	1935	"RTN","XLF NSLK",83,0 )
	1936	F I=1:1:6 R L2#2:20 Q:'$T S XL($P("ID^ CODE^QDCOU NT^ANCOUNT ^NSCOUNT^A RCOUNT","^ ",I))=$S(I >2:$$WBN(L 2),I=2:$$B IN16(L2),1 :L2)
	1937	"RTN","XLF NSLK",84,0 )
	1938	I '$T D L OG("Time-o ut") G RDE RR
	1939	"RTN","XLF NSLK",85,0 )
	1940	D LOG("Re turn msg l ength: "_R I)
	1941	"RTN","XLF NSLK",86,0 )
	1942	F I=13:1: RI U IO R *X:20 Q:'$ T S RI(I) =X ;or use X#1 and $ A(X)
	1943	"RTN","XLF NSLK",87,0 )
	1944	RDERR ;End of read
	1945	"RTN","XLF NSLK",88,0 )
	1946	D CLOSE^% ZISTCP
	1947	"RTN","XLF NSLK",89,0 )
	1948	Q
	1949	"RTN","XLF NSLK",90,0 )
	1950	DECODE ;
	1951	"RTN","XLF NSLK",91,0 )
	1952	;ZEXCEPT: XL ;Globa l variable within th is routine
	1953	"RTN","XLF NSLK",92,0 )
	1954	N I,IX,X, Y,Z,NN,NN2 Q:RI'>7
	1955	"RTN","XLF NSLK",93,0 )
	1956	I $G(XL(" ID"))'=" M " S XL("ER R")="Bad R esponse" D LOG(XL("E RR")) Q
	1957	"RTN","XLF NSLK",94,0 )
	1958	;Decode t he header
	1959	"RTN","XLF NSLK",95,0 )
	1960	S Z=XL("C ODE"),XL(" QR")=$E(Z, 1),XL("Opc ode")=$E(Z ,2,5),XL(" AA")=$E(Z, 6),XL("TC" )=$E(Z,7), XL("RD")=$ E(Z,8),XL( "RA")=$E(Z ,9),XL("RC ODE")=$E(Z ,13,16)
	1961	"RTN","XLF NSLK",96,0 )
	1962	;The Ques tion secti on
	1963	"RTN","XLF NSLK",97,0 )
	1964	S IX=13
	1965	"RTN","XLF NSLK",98,0 )
	1966	F NN2=1:1 :XL("QDCOU NT") D QD( "QD"_NN2)
	1967	"RTN","XLF NSLK",99,0 )
	1968	F NN="AN" ,"NS","AR" I $G(XL(N N_"COUNT") ) F NN2=1: 1:XL(NN_"C OUNT") D R R(NN_NN2)
	1969	"RTN","XLF NSLK",100, 0)
	1970	Q
	1971	"RTN","XLF NSLK",101, 0)
	1972	;
	1973	"RTN","XLF NSLK",102, 0)
	1974	QD(NSP) ;D ecode the Question s ection
	1975	"RTN","XLF NSLK",103, 0)
	1976	;ZEXCEPT: IX,RI,XL ;Global va riables wi thin this routine
	1977	"RTN","XLF NSLK",104, 0)
	1978	N Y
	1979	"RTN","XLF NSLK",105, 0)
	1980	S Y="",IX =IX+$$NAME (IX,.Y,1), XL(NSP_"NA ME")=Y
	1981	"RTN","XLF NSLK",106, 0)
	1982	S XL(NSP_ "TYPE")=$$ BN(RI(IX), RI(IX+1)), IX=IX+2
	1983	"RTN","XLF NSLK",107, 0)
	1984	S XL(NSP_ "CLASS")=$ $BN(RI(IX) ,RI(IX+1)) ,IX=IX+2
	1985	"RTN","XLF NSLK",108, 0)
	1986	Q
	1987	"RTN","XLF NSLK",109, 0)
	1988	RR(NSP) ;
	1989	"RTN","XLF NSLK",110, 0)
	1990	;ZEXCEPT: IX,RI,X,X L ;Global variables within thi s routine
	1991	"RTN","XLF NSLK",111, 0)
	1992	N Y,NA
	1993	"RTN","XLF NSLK",112, 0)
	1994	S Y="",IX =IX+$$NAME (IX,.Y,1), XL(NSP_"NA ME")=Y,NA= Y
	1995	"RTN","XLF NSLK",113, 0)
	1996	S XL(NSP_ "TYPE")=$$ BN(RI(IX), RI(IX+1)), IX=IX+2
	1997	"RTN","XLF NSLK",114, 0)
	1998	S XL(NSP_ "CLASS")=$ $BN(RI(IX) ,RI(IX+1)) ,IX=IX+2
	1999	"RTN","XLF NSLK",115, 0)
	2000	S Y=RI(IX )256+RI(I X+1),Y=Y2 56+RI(IX+2 ),Y=Y*256+ RI(IX+3)
	2001	"RTN","XLF NSLK",116, 0)
	2002	S XL(NSP_ "TTL")=Y,I X=IX+4
	2003	"RTN","XLF NSLK",117, 0)
	2004	S (X,XL(N SP_"LENGTH "))=$$BN(R I(IX),RI(I X+1)),IX=I X+2 Q:X=0
	2005	"RTN","XLF NSLK",118, 0)
	2006	I XL(NSP_ "TYPE")=1 D ; IPv4 a ddress
	2007	"RTN","XLF NSLK",119, 0)
	2008	. S XL(NS P_"DATA")= RI(IX)_"." _RI(IX+1)_ "."_RI(IX+ 2)_"."_RI( IX+3),XL(" B",NA)=XL( NSP_"DATA" )
	2009	"RTN","XLF NSLK",120, 0)
	2010	I XL(NSP_ "TYPE")=28 D ; IPv6 a ddress
	2011	"RTN","XLF NSLK",121, 0)
	2012	. S XL(NS P_"DATA")= $$H1(RI(IX ))_$$H1(RI (IX+1))_": "_$$H1(RI( IX+2))_$$H 1(RI(IX+3) )_":"
	2013	"RTN","XLF NSLK",122, 0)
	2014	. S XL(NS P_"DATA")= XL(NSP_"DA TA")_$$H1( RI(IX+4))_ $$H1(RI(IX +5))_":"_$ $H1(RI(IX+ 6))_$$H1(R I(IX+7))_" :"
	2015	"RTN","XLF NSLK",123, 0)
	2016	. S XL(NS P_"DATA")= XL(NSP_"DA TA")_$$H1( RI(IX+8))_ $$H1(RI(IX +9))_":"_$ $H1(RI(IX+ 10))_$$H1( RI(IX+11)) _":"
	2017	"RTN","XLF NSLK",124, 0)
	2018	. S XL(NS P_"DATA")= XL(NSP_"DA TA")_$$H1( RI(IX+12)) _$$H1(RI(I X+13))_":" _$$H1(RI(I X+14))_$$H 1(RI(IX+15 ))
	2019	"RTN","XLF NSLK",125, 0)
	2020	. S XL("B ",NA)=XL(N SP_"DATA")
	2021	"RTN","XLF NSLK",126, 0)
	2022	I XL(NSP_ "TYPE")=15 D MX(IX) ; MX ent ry
	2023	"RTN","XLF NSLK",127, 0)
	2024	S IX=IX+X L(NSP_"LEN GTH")
	2025	"RTN","XLF NSLK",128, 0)
	2026	Q
	2027	"RTN","XLF NSLK",129, 0)
	2028	NAME(I,NM, F) ;Decode a NAME se ction
	2029	"RTN","XLF NSLK",130, 0)
	2030	;ZEXCEPT: RI ;Globa l variable within th is routine
	2031	"RTN","XLF NSLK",131, 0)
	2032	N P,T,Y,X S NM=$G(N M) S:F T=0
	2033	"RTN","XLF NSLK",132, 0)
	2034	F S X=RI (I) S:(X=0 )&F T=T+1 Q:X=0 D Q:X=0 ;Us e X as fla g to escap e recursio n.
	2035	"RTN","XLF NSLK",133, 0)
	2036	. I (X\64 )=3 S X=$$ NAME((X#64 )*256+RI(I +1)+1,.NM, 0),X=0 S:F T=T+2 Q
	2037	"RTN","XLF NSLK",134, 0)
	2038	. S NM=NM _$$PART(I+ 1,X),I=I+X +1 S:F T=T +X+1
	2039	"RTN","XLF NSLK",135, 0)
	2040	Q $G(T)
	2041	"RTN","XLF NSLK",136, 0)
	2042	;
	2043	"RTN","XLF NSLK",137, 0)
	2044	MX(IX) ;Hi de IX chan ges
	2045	"RTN","XLF NSLK",138, 0)
	2046	;ZEXCEPT: NSP,RI,XL ;Global v ariables w ithin this routine
	2047	"RTN","XLF NSLK",139, 0)
	2048	N Y S Y=$ $BN(RI(IX) ,RI(IX+1))
	2049	"RTN","XLF NSLK",140, 0)
	2050	F Q:'$D( XL("P",Y)) S Y=Y+1
	2051	"RTN","XLF NSLK",141, 0)
	2052	S XL(NSP_ "PREF")=Y, IX=IX+2
	2053	"RTN","XLF NSLK",142, 0)
	2054	S Y="",IX =IX+$$NAME (IX,.Y,1), XL(NSP_"NA ME")=Y,XL( "P",XL(NSP _"PREF"))= Y
	2055	"RTN","XLF NSLK",143, 0)
	2056	Q
	2057	"RTN","XLF NSLK",144, 0)
	2058	;
	2059	"RTN","XLF NSLK",145, 0)
	2060	BN(Z1,Z2) ;Convert t wo binary char 16 bi t number i nto ASCII number
	2061	"RTN","XLF NSLK",146, 0)
	2062	Q Z1*256+ Z2
	2063	"RTN","XLF NSLK",147, 0)
	2064	;
	2065	"RTN","XLF NSLK",148, 0)
	2066	WBN(Z1) ;C onvert two byte stri ng to a AS CII number
	2067	"RTN","XLF NSLK",149, 0)
	2068	Q $A(Z1,1 )*256+$A(Z 1,2)
	2069	"RTN","XLF NSLK",150, 0)
	2070	;
	2071	"RTN","XLF NSLK",151, 0)
	2072	H2(Z2) ;Co nvert 2 by te string to HEX
	2073	"RTN","XLF NSLK",152, 0)
	2074	N B S B=$ A(Z2,1)*25 6+$A(Z2,2)
	2075	"RTN","XLF NSLK",153, 0)
	2076	Q $$H(B)
	2077	"RTN","XLF NSLK",154, 0)
	2078	;
	2079	"RTN","XLF NSLK",155, 0)
	2080	H1(Z1) ;Co nvert deci mal number <= 256 to two digit HEX numbe r
	2081	"RTN","XLF NSLK",156, 0)
	2082	N Y S Y=$ $CNV^XLFUT L(Z1,16)
	2083	"RTN","XLF NSLK",157, 0)
	2084	Q $$RJ^XL FSTR(Y,2," 0")
	2085	"RTN","XLF NSLK",158, 0)
	2086	;
	2087	"RTN","XLF NSLK",159, 0)
	2088	H(Z1) Q $$ BASE^XLFUT L(Z1,10,16 )
	2089	"RTN","XLF NSLK",160, 0)
	2090	;
	2091	"RTN","XLF NSLK",161, 0)
	2092	BIN16(S) ; Convert tw o byte str ing to 16 bit binary
	2093	"RTN","XLF NSLK",162, 0)
	2094	N K,Y S S =$A(S,1)*2 56+$A(S,2) ,Y=""
	2095	"RTN","XLF NSLK",163, 0)
	2096	F K=0:1:1 5 S Y=(S\( 2**K)#2)_Y
	2097	"RTN","XLF NSLK",164, 0)
	2098	Q Y
	2099	"RTN","XLF NSLK",165, 0)
	2100	;
	2101	"RTN","XLF NSLK",166, 0)
	2102	PART(S,L) ;
	2103	"RTN","XLF NSLK",167, 0)
	2104	;ZEXCEPT: RI ;Globa l variable within th is routine
	2105	"RTN","XLF NSLK",168, 0)
	2106	N R,A S R ="" F A=S: 1:S+L-1 S R=R_$C(RI( A))
	2107	"RTN","XLF NSLK",169, 0)
	2108	Q R_"."
	2109	"RTN","XLF NSLK",170, 0)
	2110	;
	2111	"RTN","XLF NSLK",171, 0)
	2112	TYPECODE(T ) ;
	2113	"RTN","XLF NSLK",172, 0)
	2114	;1=A:IPv4 address,2 =NS:namese rver,5=CNA ME,15=MX:m ail exchan ge,28=AAAA :IPv6 addr ess
	2115	"RTN","XLF NSLK",173, 0)
	2116	I +T Q $S (T=1:"A",T =2:"NS",T= 5:"CNAME", T=15:"MX", T=28:"AAAA ",1:"ZZ")
	2117	"RTN","XLF NSLK",174, 0)
	2118	Q $S(T="A ":1,T="NS" :2,T="CNAM E":5,T="MX ":15,T="AA AA":28,1:1 )
	2119	"RTN","XLF NSLK",175, 0)
	2120	;
	2121	"RTN","XLF NSLK",176, 0)
	2122	CLASS(T) ;
	2123	"RTN","XLF NSLK",177, 0)
	2124	Q $S(T=1: "IN",1:"ZZ ")
	2125	"RTN","XLF NSLK",178, 0)
	2126	;
	2127	"RTN","XLF NSLK",179, 0)
	2128	GETDNS(I) ;Get the a ddress of our DNS
	2129	"RTN","XLF NSLK",180, 0)
	2130	N L S L=$ G(^XTV(898 9.3,1,"DNS "))
	2131	"RTN","XLF NSLK",181, 0)
	2132	Q $P(L,", ",I)
	2133	"RTN","XLF NSLK",182, 0)
	2134	;
	2135	"RTN","XLF NSLK",183, 0)
	2136	SW(T,H,V) ;
	2137	"RTN","XLF NSLK",184, 0)
	2138	W ?T,$J(H ,8),V
	2139	"RTN","XLF NSLK",185, 0)
	2140	Q
	2141	"RTN","XLF NSLK",186, 0)
	2142	SAVEDEV ;S ave callin g device
	2143	"RTN","XLF NSLK",187, 0)
	2144	D:'$D(IO( 0)) HOME^% ZIS D SAVD EV^%ZISUTL ("XLFNSLK" )
	2145	"RTN","XLF NSLK",188, 0)
	2146	Q
	2147	"RTN","XLF NSLK",189, 0)
	2148	RESDEV ;Re store call ing device
	2149	"RTN","XLF NSLK",190, 0)
	2150	D USE^%ZI SUTL("XLFN SLK"),RMDE V^%ZISUTL( "XLFNSLK")
	2151	"RTN","XLF NSLK",191, 0)
	2152	K IO("CLO SE")
	2153	"RTN","XLF NSLK",192, 0)
	2154	Q
	2155	"RTN","XLF NSLK",193, 0)
	2156	LOG(M,XLFL OG) ;Log D ebug messa ges
	2157	"RTN","XLF NSLK",194, 0)
	2158	;ZEXCEPT: XLFLOG ;G lobal vari able withi n this rou tine
	2159	"RTN","XLF NSLK",195, 0)
	2160	S XLFLOG= $G(XLFLOG) +1,XLFLOG( XLFLOG)=M
	2161	"RTN","XLF NSLK",196, 0)
	2162	Q
	2163	"RTN","XLF NSLK",197, 0)
	2164	;
	2165	"RTN","XU8 PS655")
	2166	1^17^^B102 640640
	2167	"RTN","XU8 PS659")
	2168	0^^B630504 06^n/a
	2169	"RTN","XU8 PS659",1,0 )
	2170	XU8PS659 ; ISD/HGW - Post-Insta ll for XU* 8*659 ;12/ 17/15 10: 49
	2171	"RTN","XU8 PS659",2,0 )
	2172	;;8.0;KER NEL;*659 *;Jul 10, 1995;Build 22
	2173	"RTN","XU8 PS659",3,0 )
	2174	;Per VA D irective 6 402, this routine sh ould not b e modified .
	2175	"RTN","XU8 PS659",4,0 )
	2176	;
	2177	"RTN","XU8 PS659",5,0 )
	2178	; Post I nstallatio n Routine for patch XU8.0659
	2179	"RTN","XU8 PS659",6,0 )
	2180	; EXTERN AL REFEREN CES
	2181	"RTN","XU8 PS659",7,0 )
	2182	; BMES ^XPDUTL 10 141
	2183	"RTN","XU8 PS659",8,0 )
	2184	; $$FI ND1^DIC
	2185	"RTN","XU8 PS659",9,0 )
	2186	; UPDA TE^DIE 205 3
	2187	"RTN","XU8 PS659",10, 0)
	2188	;
	2189	"RTN","XU8 PS659",11, 0)
	2190	MAIN ; Con trol subro utine
	2191	"RTN","XU8 PS659",12, 0)
	2192	N I,XDIR, XREF,XU8DA TA,XU8ERRX ,Y
	2193	"RTN","XU8 PS659",13, 0)
	2194	;
	2195	"RTN","XU8 PS659",14, 0)
	2196	; Delete old BSE Ex ample entr ies from R EMOTE APPL ICATION fi le (#8994. 5)
	2197	"RTN","XU8 PS659",15, 0)
	2198	S XU8DATA (1)="XUSBS E TEST1" ; Name
	2199	"RTN","XU8 PS659",16, 0)
	2200	S XU8ERRX =$$DELETE( .XU8DATA) ; Delete e xisting RE MOTE APPLI CATION ent ry
	2201	"RTN","XU8 PS659",17, 0)
	2202	S XU8DATA (1)="XUSBS E TEST2" ; Name
	2203	"RTN","XU8 PS659",18, 0)
	2204	S XU8ERRX =$$DELETE( .XU8DATA) ; Delete e xisting RE MOTE APPLI CATION ent ry
	2205	"RTN","XU8 PS659",19, 0)
	2206	S XU8DATA (1)="XUSBS E TEST3" ; Name
	2207	"RTN","XU8 PS659",20, 0)
	2208	S XU8ERRX =$$DELETE( .XU8DATA) ; Delete e xisting RE MOTE APPLI CATION ent ry
	2209	"RTN","XU8 PS659",21, 0)
	2210	;
	2211	"RTN","XU8 PS659",22, 0)
	2212	; Install IAM Provi sioning en try into t he REMOTE APPLICATIO N file (#8 994.5)
	2213	"RTN","XU8 PS659",23, 0)
	2214	S XU8DATA (1)="IAM P ROVISIONIN G" ; Name
	2215	"RTN","XU8 PS659",24, 0)
	2216	S XU8DATA (2)="XUS I AM USER PR OVISIONING " ; Contex tOption Na me
	2217	"RTN","XU8 PS659",25, 0)
	2218	S XU8DATA (3)="IAM U ser Provis ioning" ; ContextOpt ion Menu T ext
	2219	"RTN","XU8 PS659",26, 0)
	2220	S XU8DATA (4)="put b utter squa re hat" ; Security p hrase
	2221	"RTN","XU8 PS659",27, 0)
	2222	; For TYP E multiple , each ent ry should be XU8DATA (n)=CallBa ckType^Cal lBackPort^ CallBackSe rver^URLSt ring
	2223	"RTN","XU8 PS659",28, 0)
	2224	; where n is 5, 6, 7, 8 etc.
	2225	"RTN","XU8 PS659",29, 0)
	2226	S XU8DATA (5)="S^-1^ N/A^N/A"
	2227	"RTN","XU8 PS659",30, 0)
	2228	S XU8ERRX =$$OPTION( .XU8DATA) ; Create C ONTEXTOPTI ON if does n't exist
	2229	"RTN","XU8 PS659",31, 0)
	2230	D BMES^XP DUTL(XU8ER RX) ; XU8E RRX is "Su ccess mess age" or "E rror text"
	2231	"RTN","XU8 PS659",32, 0)
	2232	S XU8ERRX =$$DELETE( .XU8DATA) ; Delete e xisting RE MOTE APPLI CATION ent ry
	2233	"RTN","XU8 PS659",33, 0)
	2234	S XU8ERRX =$$CREATE( .XU8DATA) ; Create R EMOTE APPL ICATION en try
	2235	"RTN","XU8 PS659",34, 0)
	2236	D BMES^XP DUTL(XU8ER RX) ; XU8E RRX is "Su ccess mess age" or "E rror text"
	2237	"RTN","XU8 PS659",35, 0)
	2238	;
	2239	"RTN","XU8 PS659",36, 0)
	2240	; Install IAM Bindi ng entry i nto the RE MOTE APPLI CATION fil e (#8994.5 )
	2241	"RTN","XU8 PS659",37, 0)
	2242	S XU8DATA (1)="IAM B INDING" ; Name
	2243	"RTN","XU8 PS659",38, 0)
	2244	S XU8DATA (2)="XUS I AM USER BI NDING" ; C ontextOpti on Name
	2245	"RTN","XU8 PS659",39, 0)
	2246	S XU8DATA (3)="IAM U ser Bindin g App" ; C ontextOpti on Menu Te xt
	2247	"RTN","XU8 PS659",40, 0)
	2248	S XU8DATA (4)="de$lA yING55AMO) BAe29" ; S ecurity ph rase
	2249	"RTN","XU8 PS659",41, 0)
	2250	; For TYP E multiple , each ent ry should be XU8DATA (n)=CallBa ckType^Cal lBackPort^ CallBackSe rver^URLSt ring
	2251	"RTN","XU8 PS659",42, 0)
	2252	; where n is 5, 6, 7, 8 etc.
	2253	"RTN","XU8 PS659",43, 0)
	2254	S XU8DATA (5)="S^-1^ N/A^N/A"
	2255	"RTN","XU8 PS659",44, 0)
	2256	S XU8ERRX =$$OPTION( .XU8DATA) ; Create C ONTEXTOPTI ON if does n't exist
	2257	"RTN","XU8 PS659",45, 0)
	2258	D BMES^XP DUTL(XU8ER RX) ; XU8E RRX is "Su ccess mess age" or "E rror text"
	2259	"RTN","XU8 PS659",46, 0)
	2260	S XU8ERRX =$$DELETE( .XU8DATA) ; Delete e xisting RE MOTE APPLI CATION ent ry
	2261	"RTN","XU8 PS659",47, 0)
	2262	S XU8ERRX =$$CREATE( .XU8DATA) ; Create R EMOTE APPL ICATION en try
	2263	"RTN","XU8 PS659",48, 0)
	2264	D BMES^XP DUTL(XU8ER RX) ; XU8E RRX is "Su ccess mess age" or "E rror text"
	2265	"RTN","XU8 PS659",49, 0)
	2266	;
	2267	"RTN","XU8 PS659",50, 0)
	2268	; Install NUMI entr y into the REMOTE AP PLICATION file (#899 4.5)
	2269	"RTN","XU8 PS659",51, 0)
	2270	S XU8DATA (1)="NUMI" ; Name
	2271	"RTN","XU8 PS659",52, 0)
	2272	S XU8DATA (2)="WEBN NATL UTIL MGMT INTEG " ; Contex tOption Na me
	2273	"RTN","XU8 PS659",53, 0)
	2274	S XU8DATA (3)="Natio nal Utiliz ation Mgmt Integrati on" ; Cont extOption Menu Text
	2275	"RTN","XU8 PS659",54, 0)
	2276	S XU8DATA (4)="WEBN NATL UTIL MGMT INTEG " ; Securi ty phrase
	2277	"RTN","XU8 PS659",55, 0)
	2278	; For TYP E multiple , each ent ry should be XU8DATA (n)=CallBa ckType^Cal lBackPort^ CallBackSe rver^URLSt ring
	2279	"RTN","XU8 PS659",56, 0)
	2280	; where n is 5, 6, 7, 8 etc.
	2281	"RTN","XU8 PS659",57, 0)
	2282	S XU8DATA (5)="S^-1^ N/A^N/A"
	2283	"RTN","XU8 PS659",58, 0)
	2284	S XU8ERRX =$$OPTION( .XU8DATA) ; Create C ONTEXTOPTI ON if does n't exist
	2285	"RTN","XU8 PS659",59, 0)
	2286	D BMES^XP DUTL(XU8ER RX) ; XU8E RRX is "Su ccess mess age" or "E rror text"
	2287	"RTN","XU8 PS659",60, 0)
	2288	S XU8ERRX =$$DELETE( .XU8DATA) ; Delete e xisting RE MOTE APPLI CATION ent ry
	2289	"RTN","XU8 PS659",61, 0)
	2290	S XU8ERRX =$$CREATE( .XU8DATA) ; Create R EMOTE APPL ICATION en try
	2291	"RTN","XU8 PS659",62, 0)
	2292	D BMES^XP DUTL(XU8ER RX) ; XU8E RRX is "Su ccess mess age" or "E rror text"
	2293	"RTN","XU8 PS659",63, 0)
	2294	;
	2295	"RTN","XU8 PS659",64, 0)
	2296	; Install BMS entry into the REMOTE APP LICATION f ile (#8994 .5)
	2297	"RTN","XU8 PS659",65, 0)
	2298	S XU8DATA (1)="BMS" ; Name
	2299	"RTN","XU8 PS659",66, 0)
	2300	S XU8DATA (2)="WEBB BED MGMT S OLUTION" ; ContextOp tion Name
	2301	"RTN","XU8 PS659",67, 0)
	2302	S XU8DATA (3)="Bed M anagement Solution" ; ContextO ption Menu Text
	2303	"RTN","XU8 PS659",68, 0)
	2304	S XU8DATA (4)="WEBB BED MGMT S OLUTION" ; Security phrase
	2305	"RTN","XU8 PS659",69, 0)
	2306	; For TYP E multiple , each ent ry should be XU8DATA (n)=CallBa ckType^Cal lBackPort^ CallBackSe rver^URLSt ring
	2307	"RTN","XU8 PS659",70, 0)
	2308	; where n is 5, 6, 7, 8 etc.
	2309	"RTN","XU8 PS659",71, 0)
	2310	S XU8DATA (5)="S^-1^ N/A^N/A"
	2311	"RTN","XU8 PS659",72, 0)
	2312	S XU8ERRX =$$OPTION( .XU8DATA) ; Create C ONTEXTOPTI ON if does n't exist
	2313	"RTN","XU8 PS659",73, 0)
	2314	D BMES^XP DUTL(XU8ER RX) ; XU8E RRX is "Su ccess mess age" or "E rror text"
	2315	"RTN","XU8 PS659",74, 0)
	2316	S XU8ERRX =$$DELETE( .XU8DATA) ; Delete e xisting RE MOTE APPLI CATION ent ry
	2317	"RTN","XU8 PS659",75, 0)
	2318	S XU8ERRX =$$CREATE( .XU8DATA) ; Create R EMOTE APPL ICATION en try
	2319	"RTN","XU8 PS659",76, 0)
	2320	D BMES^XP DUTL(XU8ER RX) ; XU8E RRX is "Su ccess mess age" or "E rror text"
	2321	"RTN","XU8 PS659",77, 0)
	2322	;
	2323	"RTN","XU8 PS659",78, 0)
	2324	; Instal l entry in to the DIA LOG file ( #.84)
	2325	"RTN","XU8 PS659",79, 0)
	2326	;NUMBER: 30810.63 DIALOG N UMBER: 308 10.63
	2327	"RTN","XU8 PS659",80, 0)
	2328	; TYPE: GENERAL ME SSAGE PACKAGE: KERNEL
	2329	"RTN","XU8 PS659",81, 0)
	2330	; SHORT DESCRIPTIO N: STS tok en not val id.
	2331	"RTN","XU8 PS659",82, 0)
	2332	; TEXT:
	2333	"RTN","XU8 PS659",83, 0)
	2334	; Unable to sign o n using Id entity and Access Ma nagement S TS token.
	2335	"RTN","XU8 PS659",84, 0)
	2336	K XU8DATA ,XU8ERRX
	2337	"RTN","XU8 PS659",85, 0)
	2338	S XU8DATA (1)=30810. 63
	2339	"RTN","XU8 PS659",86, 0)
	2340	S XU8DATA (2)="KERNE L"
	2341	"RTN","XU8 PS659",87, 0)
	2342	S XU8DATA (3)=2 ;"GE NERAL MESS AGE"
	2343	"RTN","XU8 PS659",88, 0)
	2344	S XU8DATA (4)="STS t oken not v alid."
	2345	"RTN","XU8 PS659",89, 0)
	2346	S XU8DATA (5)="Unabl e to sign on using I dentity an d Access M anagement STS token. Try using Access/Ve rify codes ."
	2347	"RTN","XU8 PS659",90, 0)
	2348	S XU8ERRX =$$NEWDIA( .XU8DATA)
	2349	"RTN","XU8 PS659",91, 0)
	2350	D BMES^XP DUTL(XU8ER RX) ; XU8E RRX is "Su ccess mess age" or "E rror text"
	2351	"RTN","XU8 PS659",92, 0)
	2352	;
	2353	"RTN","XU8 PS659",93, 0)
	2354	; Instal l entries into KERNE L SYSTEMS PARAMETERS file (#89 89.3)
	2355	"RTN","XU8 PS659",94, 0)
	2356	K XU8DATA ,XU8ERRX
	2357	"RTN","XU8 PS659",95, 0)
	2358	S XU8DATA (1)="eauth . DNS "
	2359	"RTN","XU8 PS659",96, 0)
	2360	S XU8DATA (2)="Depar tment Of V eterans Af fairs"
	2361	"RTN","XU8 PS659",97, 0)
	2362	S XU8DATA (3)="urn:o id:2.16.84 0.1.113883 .4.349"
	2363	"RTN","XU8 PS659",98, 0)
	2364	S XU8ERRX =$$NEWKSP( .XU8DATA)
	2365	"RTN","XU8 PS659",99, 0)
	2366	D BMES^XP DUTL(XU8ER RX) ; XU8E RRX is "Su ccess mess age" or "E rror text"
	2367	"RTN","XU8 PS659",100 ,0)
	2368	;
	2369	"RTN","XU8 PS659",101 ,0)
	2370	K ^XU8P65 5("VACAA") ;Cleanup after patc h XU8655
	2371	"RTN","XU8 PS659",102 ,0)
	2372	;
	2373	"RTN","XU8 PS659",103 ,0)
	2374	Q
	2375	"RTN","XU8 PS659",104 ,0)
	2376	;
	2377	"RTN","XU8 PS659",105 ,0)
	2378	OPTION(XU8 DATA) ; Cr eate CONTE XTOPTION i f doesn't exist
	2379	"RTN","XU8 PS659",106 ,0)
	2380	N XU8ERR, XU8FDA,XU8 IEN,XU8MSG
	2381	"RTN","XU8 PS659",107 ,0)
	2382	S XU8IEN= $$FIND1^DI C(19,"","X ",XU8DATA( 2),"B")
	2383	"RTN","XU8 PS659",108 ,0)
	2384	S XU8ERR= "Error mes sage: "_XU 8IEN
	2385	"RTN","XU8 PS659",109 ,0)
	2386	I +XU8IEN >0 S XU8ER R="OPTION exists at IEN = "_XU 8IEN
	2387	"RTN","XU8 PS659",110 ,0)
	2388	I +XU8IEN =0 S XU8ER R="OPTION "_XU8DATA( 2)_" creat ed" D
	2389	"RTN","XU8 PS659",111 ,0)
	2390	. S XU8FD A(19,"?+1, ",.01)=XU8 DATA(2)
	2391	"RTN","XU8 PS659",112 ,0)
	2392	. S XU8FD A(19,"?+1, ",1)=XU8DA TA(3)
	2393	"RTN","XU8 PS659",113 ,0)
	2394	. S XU8FD A(19,"?+1, ",4)="B" ; B:Broker (Client/Se rver)
	2395	"RTN","XU8 PS659",114 ,0)
	2396	. D UPDAT E^DIE(""," XU8FDA","X U8IEN","XU 8MSG")
	2397	"RTN","XU8 PS659",115 ,0)
	2398	. I $D(XU 8MSG) S XU 8ERR=" * ERROR* " _$G(XU8MSG ("DIERR",1 ))_" Unabl e to creat e OPTION e ntry "_XU8 DATA(2)
	2399	"RTN","XU8 PS659",116 ,0)
	2400	D CLEAN^D ILF
	2401	"RTN","XU8 PS659",117 ,0)
	2402	Q XU8ERR
	2403	"RTN","XU8 PS659",118 ,0)
	2404	;
	2405	"RTN","XU8 PS659",119 ,0)
	2406	DELETE(XU8 DATA) ; De lete exist ing REMOTE APPLICATI ON entry
	2407	"RTN","XU8 PS659",120 ,0)
	2408	N DA,DIK, XU8IEN
	2409	"RTN","XU8 PS659",121 ,0)
	2410	S XU8IEN= $$FIND1^DI C(8994.5," ","X",XU8D ATA(1),"B" )
	2411	"RTN","XU8 PS659",122 ,0)
	2412	I $G(XU8I EN)>0 D
	2413	"RTN","XU8 PS659",123 ,0)
	2414	. S DIK=" ^XWB(8994. 5,",DA=XU8 IEN
	2415	"RTN","XU8 PS659",124 ,0)
	2416	. D ^DIK
	2417	"RTN","XU8 PS659",125 ,0)
	2418	. K XU8IE N
	2419	"RTN","XU8 PS659",126 ,0)
	2420	Q 1
	2421	"RTN","XU8 PS659",127 ,0)
	2422	CREATE(XU8 DATA) ; Cr eate new R EMOTE APPL ICATION en try
	2423	"RTN","XU8 PS659",128 ,0)
	2424	N XU8ERR, XU8FDA,XU8 I,XU8IEN,X U8IENS,XU8 MSG
	2425	"RTN","XU8 PS659",129 ,0)
	2426	S XU8ERR= " REMOTE APPLICATI ON entry c reated: "_ XU8DATA(1)
	2427	"RTN","XU8 PS659",130 ,0)
	2428	S XU8FDA( 8994.5,"?+ 1,",.01)=X U8DATA(1) ; NAME
	2429	"RTN","XU8 PS659",131 ,0)
	2430	S XU8FDA( 8994.5,"?+ 1,",.02)=$ $FIND1^DIC (19,"","X" ,XU8DATA(2 ),"B") ; C ONTEXTOPTI ON
	2431	"RTN","XU8 PS659",132 ,0)
	2432	S XU8FDA( 8994.5,"?+ 1,",.03)=$ $SHAHASH^X USHSH(256, XU8DATA(4) ,"B") ; AP PLICATIONC ODE
	2433	"RTN","XU8 PS659",133 ,0)
	2434	D UPDATE^ DIE("","XU 8FDA","XU8 IEN","XU8M SG")
	2435	"RTN","XU8 PS659",134 ,0)
	2436	I $D(XU8M SG) D
	2437	"RTN","XU8 PS659",135 ,0)
	2438	. S XU8ER R=" ER ROR "_$G (XU8MSG("D IERR",1))_ " Unable t o create R EMOTE APPL ICATION: " _XU8DATA(1 )
	2439	"RTN","XU8 PS659",136 ,0)
	2440	; Find th e REMOTE A PPLICATION
	2441	"RTN","XU8 PS659",137 ,0)
	2442	S XU8IENS =$$FIND1^D IC(8994.5, "","X",XU8 DATA(1),"B ")
	2443	"RTN","XU8 PS659",138 ,0)
	2444	I +XU8IEN S<1 S XU8E RR=XU8IENS Q XU8ERR
	2445	"RTN","XU8 PS659",139 ,0)
	2446	; Fill in CALLBACKT YPE multip le
	2447	"RTN","XU8 PS659",140 ,0)
	2448	S XU8I=4 F S XU8I= $O(XU8DATA (XU8I)) Q: XU8I="" D
	2449	"RTN","XU8 PS659",141 ,0)
	2450	. N XU8FD A,XU8IEN,X U8MSG,XU8T EST,XU8J,X U8FLAG
	2451	"RTN","XU8 PS659",142 ,0)
	2452	. ; Check for dupli cates (loo p through CALLBACKTY PE for thi s entry)
	2453	"RTN","XU8 PS659",143 ,0)
	2454	. S XU8J= 0 F S XU8 J=$O(^XWB( 8994.5,XU8 IENS,1,"B" ,$E(XU8DAT A(XU8I),1, 1),XU8J)) Q:(XU8J="" )!($D(XU8F LAG)) D
	2455	"RTN","XU8 PS659",144 ,0)
	2456	. . I $G( XU8DATA(XU 8I))=$G(^X WB(8994.5, XU8IENS,1, XU8J,0)) S XU8FLAG=1
	2457	"RTN","XU8 PS659",145 ,0)
	2458	. I '$D(X U8FLAG) D
	2459	"RTN","XU8 PS659",146 ,0)
	2460	. . S XU8 FDA(8994.5 1,"+2,"_XU 8IENS_",", .01)=$P(XU 8DATA(XU8I ),"^",1) ; CALLBACKT YPE
	2461	"RTN","XU8 PS659",147 ,0)
	2462	. . S XU8 FDA(8994.5 1,"+2,"_XU 8IENS_",", .02)=$P(XU 8DATA(XU8I ),"^",2) ; CALLBACKP ORT
	2463	"RTN","XU8 PS659",148 ,0)
	2464	. . S XU8 FDA(8994.5 1,"+2,"_XU 8IENS_",", .03)=$P(XU 8DATA(XU8I ),"^",3) ; CALLBACKS ERVER
	2465	"RTN","XU8 PS659",149 ,0)
	2466	. . S XU8 FDA(8994.5 1,"+2,"_XU 8IENS_",", .04)=$P(XU 8DATA(XU8I ),"^",4) ; URLSTRING
	2467	"RTN","XU8 PS659",150 ,0)
	2468	. . D UPD ATE^DIE("" ,"XU8FDA", "XU8IEN"," XU8MSG")
	2469	"RTN","XU8 PS659",151 ,0)
	2470	. . I $D( XU8MSG) D
	2471	"RTN","XU8 PS659",152 ,0)
	2472	. . . S X U8ERR=" ERROR "_$G(XU8MS G("DIERR", 1))_" Unab le to upda te REMOTE APPLICATIO N: "_XU8DA TA(1)
	2473	"RTN","XU8 PS659",153 ,0)
	2474	;
	2475	"RTN","XU8 PS659",154 ,0)
	2476	D CLEAN^D ILF
	2477	"RTN","XU8 PS659",155 ,0)
	2478	Q XU8ERR
	2479	"RTN","XU8 PS659",156 ,0)
	2480	;
	2481	"RTN","XU8 PS659",157 ,0)
	2482	NEWDIA(XU8 DATA) ; Cr eate DIALO G entry
	2483	"RTN","XU8 PS659",158 ,0)
	2484	N DA,DIK, XU8DT,XU8E RR,XU8FDA, XU8IEN,XU8 MSG
	2485	"RTN","XU8 PS659",159 ,0)
	2486	; Delete existing e ntry if it exists, b efore crea ting updat ed entry
	2487	"RTN","XU8 PS659",160 ,0)
	2488	S XU8IEN= $$FIND1^DI C(.84,""," X",XU8DATA (1),"B")
	2489	"RTN","XU8 PS659",161 ,0)
	2490	I $G(XU8I EN)>0 D
	2491	"RTN","XU8 PS659",162 ,0)
	2492	. S DIK=" ^DI(.84,", DA=XU8IEN
	2493	"RTN","XU8 PS659",163 ,0)
	2494	. D ^DIK
	2495	"RTN","XU8 PS659",164 ,0)
	2496	. K XU8IE N
	2497	"RTN","XU8 PS659",165 ,0)
	2498	S XU8ERR= " DIALOG entry cre ated: "_XU 8DATA(4)
	2499	"RTN","XU8 PS659",166 ,0)
	2500	S XU8IEN( 1)=XU8DATA (1)
	2501	"RTN","XU8 PS659",167 ,0)
	2502	S XU8FDA( .84,"+1,", .01)=XU8DA TA(1) ;IEN
	2503	"RTN","XU8 PS659",168 ,0)
	2504	S XU8FDA( .84,"+1,", 1)=XU8DATA (3) ;TYPE
	2505	"RTN","XU8 PS659",169 ,0)
	2506	S XU8FDA( .84,"+1,", 1.2)=XU8DA TA(2) ;PAC KAGE
	2507	"RTN","XU8 PS659",170 ,0)
	2508	S XU8FDA( .84,"+1,", 1.3)=XU8DA TA(4) ;SHO RT DESCRIP TION
	2509	"RTN","XU8 PS659",171 ,0)
	2510	D UPDATE^ DIE("","XU 8FDA","XU8 IEN","XU8M SG")
	2511	"RTN","XU8 PS659",172 ,0)
	2512	I $D(XU8M SG) S XU8E RR=" E RROR "_$ G(XU8MSG(" DIERR",1)) _" Unable to create DIALOG ent ry: "_XU8D ATA(4) D C LEAN^DILF Q XU8ERR
	2513	"RTN","XU8 PS659",173 ,0)
	2514	S XU8IEN= $$FIND1^DI C(.84,""," X",XU8DATA (1),"B")
	2515	"RTN","XU8 PS659",174 ,0)
	2516	I $G(XU8I EN)>0 D
	2517	"RTN","XU8 PS659",175 ,0)
	2518	. S XU8DT (1)=XU8DAT A(5) ;TEXT
	2519	"RTN","XU8 PS659",176 ,0)
	2520	. D WP^DI E(.84,XU8I EN_",",4,, "XU8DT","X U8MSG")
	2521	"RTN","XU8 PS659",177 ,0)
	2522	I $D(XU8M SG) D
	2523	"RTN","XU8 PS659",178 ,0)
	2524	. S XU8ER R=" ER ROR "_$G (XU8MSG("D IERR",1))_ " Unable t o create D IALOG entr y: "_XU8DA TA(4)
	2525	"RTN","XU8 PS659",179 ,0)
	2526	. S DIK=" ^DI(.84,", DA=XU8IEN
	2527	"RTN","XU8 PS659",180 ,0)
	2528	. D ^DIK
	2529	"RTN","XU8 PS659",181 ,0)
	2530	. K XU8IE N
	2531	"RTN","XU8 PS659",182 ,0)
	2532	D CLEAN^D ILF
	2533	"RTN","XU8 PS659",183 ,0)
	2534	Q XU8ERR
	2535	"RTN","XU8 PS659",184 ,0)
	2536	;
	2537	"RTN","XU8 PS659",185 ,0)
	2538	NEWKSP(XU8 DATA) ; Cr eate KERNE L SYSTEM P ARAMETERS entries
	2539	"RTN","XU8 PS659",186 ,0)
	2540	N DA,DIK, XU8ERR,XU8 FDA,XU8MSG
	2541	"RTN","XU8 PS659",187 ,0)
	2542	S XU8ERR= " KERNEL SYSTEM PA RAMETERS f ields popu lated: SEC URITY TOKE N SERVICE, ORGANIZAT ION, ORGAN IZATION ID "
	2543	"RTN","XU8 PS659",188 ,0)
	2544	S XU8FDA( 8989.3,"1, ",200.1)=X U8DATA(1)
	2545	"RTN","XU8 PS659",189 ,0)
	2546	S XU8FDA( 8989.3,"1, ",200.2)=X U8DATA(2)
	2547	"RTN","XU8 PS659",190 ,0)
	2548	S XU8FDA( 8989.3,"1, ",200.3)=X U8DATA(3)
	2549	"RTN","XU8 PS659",191 ,0)
	2550	D FILE^DI E("E","XU8 FDA","XU8M SG")
	2551	"RTN","XU8 PS659",192 ,0)
	2552	I $D(XU8M SG) D
	2553	"RTN","XU8 PS659",193 ,0)
	2554	. S XU8ER R=" ER ROR "_$G (XU8MSG("D IERR",1))_ " Unable t o populate KERNEL SY STEM PARAM ETERS fiel ds"
	2555	"RTN","XU8 PS659",194 ,0)
	2556	D CLEAN^D ILF
	2557	"RTN","XU8 PS659",195 ,0)
	2558	Q XU8ERR
	2559	"RTN","XU8 PS659",196 ,0)
	2560	;
	2561	"RTN","XUC ERT")
	2562	0^18^B4132 125^n/a
	2563	"RTN","XUC ERT",1,0)
	2564	XUCERT ;IS D/HGW Kern el PKI Cer tificate U tilities ; 10/01/15 14:19
	2565	"RTN","XUC ERT",2,0)
	2566	;;8.0;KER NEL;*659 *;Jul 10, 1995;Build 22
	2567	"RTN","XUC ERT",3,0)
	2568	;Per VA D irective 6 402, this routine sh ould not b e modified .
	2569	"RTN","XUC ERT",4,0)
	2570	;
	2571	"RTN","XUC ERT",5,0)
	2572	Q
	2573	"RTN","XUC ERT",6,0)
	2574	VALIDATE(D OC) ;Extri nsic Funct ion.
	2575	"RTN","XUC ERT",7,0)
	2576	;Validate the signa tures in a digitally signed XM L document which con tains an E ncryptedDa ta element and Encry ptedKey el ements.
	2577	"RTN","XUC ERT",8,0)
	2578	; Input: DOC = This s tring is e ither a cl osed refer ence to a global roo t containi ng the XML document or a filen ame
	2579	"RTN","XUC ERT",9,0)
	2580	; and pa th referen ce identif ying the X ML documen t on the h ost system . See the Kernel Dev elopers Gu ide
	2581	"RTN","XUC ERT",10,0)
	2582	; docume ntation on $$EN^MXML DOM() for detailed r equirement s for the format of the input global.
	2583	"RTN","XUC ERT",11,0)
	2584	; Return: Fail = "-1^Er ror Messag e"
	2585	"RTN","XUC ERT",12,0)
	2586	; Succes s = 1
	2587	"RTN","XUC ERT",13,0)
	2588	;
	2589	"RTN","XUC ERT",14,0)
	2590	;ZEXCEPT: %New,%XML ,Document, OpenFile,O penStream, Reader,Val idateDocum ent,class ;ObjectScr ipt
	2591	"RTN","XUC ERT",15,0)
	2592	N XUREAD, XUSIG,XUST ATUS,XUVER
	2593	"RTN","XUC ERT",16,0)
	2594	S XUREAD= $$READER^X UCERT1(DOC ) ;Read XM L document
	2595	"RTN","XUC ERT",17,0)
	2596	I $G(XURE AD)["-1^" Q XUREAD
	2597	"RTN","XUC ERT",18,0)
	2598	S XUSIG=$ $SGNTR^XUC ERT1(XUREA D) ;Find d igital sig nature
	2599	"RTN","XUC ERT",19,0)
	2600	I $G(XUSI G)["-1^" Q XUSIG
	2601	"RTN","XUC ERT",20,0)
	2602	D GETISSU E(XUSIG) ; Save subje ct of X509 certifica te (issuer of signat ure)
	2603	"RTN","XUC ERT",21,0)
	2604	S XUVER=$ $VERSION^% ZOSV() S X UVER=$P(XU VER,".",1) _"."_$P(XU VER,".",2)
	2605	"RTN","XUC ERT",22,0)
	2606	I XUVER'< 2015.2 D
	2607	"RTN","XUC ERT",23,0)
	2608	. S XUSTA TUS=$$VAL1 ^XUCERT1(X UREAD,XUSI G)
	2609	"RTN","XUC ERT",24,0)
	2610	E D
	2611	"RTN","XUC ERT",25,0)
	2612	. S XUSTA TUS=$$VAL2 ^XUCERT1(X UREAD,XUSI G)
	2613	"RTN","XUC ERT",26,0)
	2614	Q XUSTATU S
	2615	"RTN","XUC ERT",27,0)
	2616	;
	2617	"RTN","XUC ERT",28,0)
	2618	GETISSUE(S IG) ;Subro utine. Sav e X509 Cer tificate o wner to XO BDATA("XOB RPC","SAM L",ISSUER" )
	2619	"RTN","XUC ERT",29,0)
	2620	;ZEXCEPT: Encryptio n,X509GetF ield,XOBDA TA ;Object Script and environme nt variabl es
	2621	"RTN","XUC ERT",30,0)
	2622	N CERT
	2623	"RTN","XUC ERT",31,0)
	2624	S CERT=$$ CERT^XUCER T1(SIG)
	2625	"RTN","XUC ERT",32,0)
	2626	I +CERT=- 1 Q ;Cann ot get cer tificate
	2627	"RTN","XUC ERT",33,0)
	2628	S XOBDATA ("XOB RPC" ,"SAML","I SSUER")=$S ystem.Encr yption.X50 9GetField( CERT,"Subj ect")
	2629	"RTN","XUC ERT",34,0)
	2630	Q
	2631	"RTN","XUC ERT",35,0)
	2632	;
	2633	"RTN","XUC ERT",36,0)
	2634	TEST ;Subr outine. Sy stem check s to help with troub leshooting .
	2635	"RTN","XUC ERT",37,0)
	2636	;Check if Cache ver sion >= 20 15.2
	2637	"RTN","XUC ERT",38,0)
	2638	; 1234 5678901234 5678901234 5678901234 5678901234 5678901234 5678901234 5678901234 567890
	2639	"RTN","XUC ERT",39,0)
	2640	W !,"XML digital si gnature va lidation i s done dif ferently d epending o n the vers ion"
	2641	"RTN","XUC ERT",40,0)
	2642	W !,"of C ache being used on y our system :"
	2643	"RTN","XUC ERT",41,0)
	2644	W !," V ersions gr eater than or equal to 2015.2 use $$VAL1 ^XUCERT1"
	2645	"RTN","XUC ERT",42,0)
	2646	W !," V ersions le ss than 20 15.2 use $ $VAL2^XUCE RT1"
	2647	"RTN","XUC ERT",43,0)
	2648	W !," Y our Cache Version is ",$$VERSI ON^%ZOSV() ,!
	2649	"RTN","XUC ERT",44,0)
	2650	;
	2651	"RTN","XUC ERT",45,0)
	2652	;Check if PKI chain of trust to root is available (how?)
	2653	"RTN","XUC ERT",46,0)
	2654	; ** Appa rently Cac he uses Op enSSL on u nderlying server for chain of trust. Che ck OpenSSL version?
	2655	"RTN","XUC ERT",47,0)
	2656	;Check if %SuperSer ver and %T ELNET/SSL is availab le (how? w ith https? )
	2657	"RTN","XUC ERT",48,0)
	2658	; ** Is t his still needed?
	2659	"RTN","XUC ERT",49,0)
	2660	;Check if a local X .509 certi ficate is installed (how? same as %Super Server che ck?)
	2661	"RTN","XUC ERT",50,0)
	2662	; ** Not needed. Al l sites us e SSL, so they have a certific ate on the server.
	2663	"RTN","XUC ERT",51,0)
	2664	Q
	2665	"RTN","XUC ERT",52,0)
	2666	;
	2667	"RTN","XUC ERT1")
	2668	0^22^B2060 6802^n/a
	2669	"RTN","XUC ERT1",1,0)
	2670	XUCERT1 ;I SD/HGW Ker nel PKI Ce rtificate Utilities (cont) ;09 /28/15 09 :08
	2671	"RTN","XUC ERT1",2,0)
	2672	;;8.0;KER NEL;*659 *;Jul 10, 1995;Build 22
	2673	"RTN","XUC ERT1",3,0)
	2674	;Per VA D irective 6 402, this routine sh ould not b e modified .
	2675	"RTN","XUC ERT1",4,0)
	2676	;
	2677	"RTN","XUC ERT1",5,0)
	2678	Q
	2679	"RTN","XUC ERT1",6,0)
	2680	VAL1(DOC,S IG) ;Funct ion. Valid ate Docume nt (Cache 2015.2 or greater)
	2681	"RTN","XUC ERT1",7,0)
	2682	;ZEXCEPT: Document, ValidateDo cument ;Ob ject Scrip t
	2683	"RTN","XUC ERT1",8,0)
	2684	N XUDOC,X USTATUS
	2685	"RTN","XUC ERT1",9,0)
	2686	S XUDOC=D OC.Documen t ;Create the OREF
	2687	"RTN","XUC ERT1",10,0 )
	2688	I $G(XUDO C)="" Q "- 1^Failed t o import X ML documen t"
	2689	"RTN","XUC ERT1",11,0 )
	2690	S XUSTATU S=SIG.Vali dateDocume nt(XUDOC)
	2691	"RTN","XUC ERT1",12,0 )
	2692	I $G(XUST ATUS)["Fai led" Q "-1 ^Failed da ta integri ty or sign ature vali dation che ck"
	2693	"RTN","XUC ERT1",13,0 )
	2694	Q 1
	2695	"RTN","XUC ERT1",14,0 )
	2696	;
	2697	"RTN","XUC ERT1",15,0 )
	2698	VAL2(DOC,S IG) ;Funct ion. Valid ate Docume nt (Less t han Cache 2015.2)
	2699	"RTN","XUC ERT1",16,0 )
	2700	N XUSTATU S
	2701	"RTN","XUC ERT1",17,0 )
	2702	S XUSTATU S=$$CHKDAT A(DOC,SIG) ; check integrity
	2703	"RTN","XUC ERT1",18,0 )
	2704	I 'XUSTAT US Q "-1^F ailed data integrity check"
	2705	"RTN","XUC ERT1",19,0 )
	2706	S XUSTATU S=$$CHKSIG N(DOC,SIG) ; check signature is valid
	2707	"RTN","XUC ERT1",20,0 )
	2708	I 'XUSTAT US Q "-1^F ailed sign ature vali dation"
	2709	"RTN","XUC ERT1",21,0 )
	2710	Q 1
	2711	"RTN","XUC ERT1",22,0 )
	2712	;
	2713	"RTN","XUC ERT1",23,0 )
	2714	READER(DOC ) ;Functio n. Reads X ML Documen t
	2715	"RTN","XUC ERT1",24,0 )
	2716	;ZEXCEPT: %New,%XML ,OpenFile, OpenStream ,Reader,cl ass ;Objec t Script
	2717	"RTN","XUC ERT1",25,0 )
	2718	N XUIN,XU READ,XUSC
	2719	"RTN","XUC ERT1",26,0 )
	2720	S XUREAD= ##class(%X ML.Reader) .%New() ;C reate OREF instance in memory
	2721	"RTN","XUC ERT1",27,0 )
	2722	I $E(DOC) ="^" D
	2723	"RTN","XUC ERT1",28,0 )
	2724	. S XUIN= $$LOADSTRM (DOC) ;Ext ract strea m from glo bal
	2725	"RTN","XUC ERT1",29,0 )
	2726	. S XUSC= XUREAD.Ope nStream(XU IN) ;Impor t from str eam
	2727	"RTN","XUC ERT1",30,0 )
	2728	E D
	2729	"RTN","XUC ERT1",31,0 )
	2730	. S XUSC= XUREAD.Ope nFile(DOC) ;Import f rom file
	2731	"RTN","XUC ERT1",32,0 )
	2732	I $G(XUSC )'=1 Q "-1 ^"_$G(XUSC )
	2733	"RTN","XUC ERT1",33,0 )
	2734	Q XUREAD
	2735	"RTN","XUC ERT1",34,0 )
	2736	;
	2737	"RTN","XUC ERT1",35,0 )
	2738	SGNTR(READ ER) ;Funct ion. Finds digital s ignature
	2739	"RTN","XUC ERT1",36,0 )
	2740	N SIGNATU RE,STATUS
	2741	"RTN","XUC ERT1",37,0 )
	2742	D READER. Correlate( "Signature ","%XML.Se curity.Sig nature")
	2743	"RTN","XUC ERT1",38,0 )
	2744	D READER. Next(.SIGN ATURE,.STA TUS)
	2745	"RTN","XUC ERT1",39,0 )
	2746	I $G(SIGN ATURE)="" Q "-1^Fail ed to find digital s ignature"
	2747	"RTN","XUC ERT1",40,0 )
	2748	Q SIGNATU RE
	2749	"RTN","XUC ERT1",41,0 )
	2750	;
	2751	"RTN","XUC ERT1",42,0 )
	2752	CHKDATA(RE ADER,SIG) ;Function. Check int egrity of signed dat a
	2753	"RTN","XUC ERT1",43,0 )
	2754	; by comp aring comp uted diges t with inc oming dige st value
	2755	"RTN","XUC ERT1",44,0 )
	2756	N COMPUTE D
	2757	"RTN","XUC ERT1",45,0 )
	2758	S COMPUTE D=$$DIGEST CP(READER, SIG)
	2759	"RTN","XUC ERT1",46,0 )
	2760	Q COMPUTE D=$$DIGEST (SIG)
	2761	"RTN","XUC ERT1",47,0 )
	2762	;
	2763	"RTN","XUC ERT1",48,0 )
	2764	DIGESTCP(R EADER,SIG) ;Function . Compute SHA digest value
	2765	"RTN","XUC ERT1",49,0 )
	2766	;ZEXCEPT: %New,%XML ,ComputeSh a1Digest,D ocument,Ge tNode,Node Id,Writer, class
	2767	"RTN","XUC ERT1",50,0 )
	2768	N NODE,WR ITER,BITLE NGT,ISSTR, MIME,SIGNN ODE,PREFIX L,CANONTXT
	2769	"RTN","XUC ERT1",51,0 )
	2770	S NODE=RE ADER.Docum ent.GetNod e("")
	2771	"RTN","XUC ERT1",52,0 )
	2772	S NODE.No deId=$$REF NODE(READE R)
	2773	"RTN","XUC ERT1",53,0 )
	2774	S SIGNNOD E=SIG.Node Id
	2775	"RTN","XUC ERT1",54,0 )
	2776	S WRITER= ##class(%X ML.Writer) .%New()
	2777	"RTN","XUC ERT1",55,0 )
	2778	S BITLENG T=160
	2779	"RTN","XUC ERT1",56,0 )
	2780	S ISSTR=0
	2781	"RTN","XUC ERT1",57,0 )
	2782	S MIME=""
	2783	"RTN","XUC ERT1",58,0 )
	2784	Q SIG.Com puteSha1Di gest(NODE, SIGNNODE,W RITER,.PRE FIXL,BITLE NGT,ISSTR, .CANONTXT, MIME)
	2785	"RTN","XUC ERT1",59,0 )
	2786	;
	2787	"RTN","XUC ERT1",60,0 )
	2788	REFNODE(RE ADER) ;Fun ction. Get reference node whic h is Asser tion node since GetN odeById ca n't find " ID"
	2789	"RTN","XUC ERT1",61,0 )
	2790	;ZEXCEPT: NodeId,ST ATUS
	2791	"RTN","XUC ERT1",62,0 )
	2792	N ASSERTI ON
	2793	"RTN","XUC ERT1",63,0 )
	2794	D READER. Rewind()
	2795	"RTN","XUC ERT1",64,0 )
	2796	D READER. Correlate( "Assertion ","%SAML.A ssertion")
	2797	"RTN","XUC ERT1",65,0 )
	2798	D READER. Next(.ASSE RTION,.STA TUS)
	2799	"RTN","XUC ERT1",66,0 )
	2800	Q ASSERTI ON.NodeId
	2801	"RTN","XUC ERT1",67,0 )
	2802	;
	2803	"RTN","XUC ERT1",68,0 )
	2804	DIGEST(SIG NATURE) ;F unction. F ind incomi ng digest value
	2805	"RTN","XUC ERT1",69,0 )
	2806	;ZEXCEPT: DigestVal ue,GetAt,R eference,S ignedInfo
	2807	"RTN","XUC ERT1",70,0 )
	2808	N REF
	2809	"RTN","XUC ERT1",71,0 )
	2810	S REF=SIG NATURE.Sig nedInfo.Re ference.Ge tAt(1)
	2811	"RTN","XUC ERT1",72,0 )
	2812	Q REF.Dig estValue
	2813	"RTN","XUC ERT1",73,0 )
	2814	;
	2815	"RTN","XUC ERT1",74,0 )
	2816	CHKSIGN(RE ADER,SIGNA TURE) ;Fun ction. Val idate digi tal signat ure
	2817	"RTN","XUC ERT1",75,0 )
	2818	; Return value: 1 i f the sign ature was successful ly verifie d, 0 other wise.
	2819	"RTN","XUC ERT1",76,0 )
	2820	;ZEXCEPT: %New,%XML ,Canonical ize,Certif icate,Docu ment,Encry ption,GetN ode,GetXML String,Key Info,NodeI d,OutputTo String,RSA SHAVerify, SignatureV alue,Signe dInfo,Vali dateTokenR ef,Writer, X509Creden tials,clas s
	2821	"RTN","XUC ERT1",77,0 )
	2822	N BITLENG T,CAFILE,C ERT,CRLFIL E,SIGNTXT, SIGNVAL,ST ATUS
	2823	"RTN","XUC ERT1",78,0 )
	2824	S BITLENG T=256 ; (I nteger) Le ngth in bi ts of desi red hash, where 256 is SHA-256
	2825	"RTN","XUC ERT1",79,0 )
	2826	S SIGNTXT =$$SIGNTEX T(READER,S IGNATURE) ; (String) Data that was signe d
	2827	"RTN","XUC ERT1",80,0 )
	2828	S SIGNVAL =SIGNATURE .Signature Value ; (S tring) Sig nature to be verifie d
	2829	"RTN","XUC ERT1",81,0 )
	2830	S CERT=$$ CERT(SIGNA TURE) ; (S tring) X.5 09 certifi cate conta ining the RSA public key to va lidate the signature
	2831	"RTN","XUC ERT1",82,0 )
	2832	I +CERT=- 1 Q CERT
	2833	"RTN","XUC ERT1",83,0 )
	2834	;RSASHAVe rify works with Open SSL on Win dows and L inux, but crashes wi th VMS.
	2835	"RTN","XUC ERT1",84,0 )
	2836	I $$VERSI ON^%ZOSV(1 )["OpenVMS " Q 1 ;Qu it if VMS, skip sign ature vali dation
	2837	"RTN","XUC ERT1",85,0 )
	2838	S STATUS= $System.En cryption.R SASHAVerif y(BITLENGT ,SIGNTXT,S IGNVAL,CER T)
	2839	"RTN","XUC ERT1",86,0 )
	2840	Q STATUS= 1
	2841	"RTN","XUC ERT1",87,0 )
	2842	;
	2843	"RTN","XUC ERT1",88,0 )
	2844	SIGNTEXT(R EADER,SIGN ATURE) ;Fu nction. Re trieves th e SignedIn fo text
	2845	"RTN","XUC ERT1",89,0 )
	2846	;ZEXCEPT: %New,%XML ,Canonical ize,Docume nt,GetNode ,GetXMLStr ing,NodeId ,OutputToS tring,Sign edInfo,Wri ter,class ;ObjectScr ipt
	2847	"RTN","XUC ERT1",90,0 )
	2848	N NODE,PR EFARR,WRIT ER,SC
	2849	"RTN","XUC ERT1",91,0 )
	2850	S NODE=RE ADER.Docum ent.GetNod e("")
	2851	"RTN","XUC ERT1",92,0 )
	2852	S NODE.No deId=SIGNA TURE.Signe dInfo.Node Id
	2853	"RTN","XUC ERT1",93,0 )
	2854	S PREFARR ="c14n" ; signing pr efix array
	2855	"RTN","XUC ERT1",94,0 )
	2856	S WRITER= ##class(%X ML.Writer) .%New()
	2857	"RTN","XUC ERT1",95,0 )
	2858	S SC=WRIT ER.OutputT oString()
	2859	"RTN","XUC ERT1",96,0 )
	2860	S SC=WRIT ER.Canonic alize(NODE ,.PREFARR)
	2861	"RTN","XUC ERT1",97,0 )
	2862	Q WRITER. GetXMLStri ng(.SC) ; SignedInfo
	2863	"RTN","XUC ERT1",98,0 )
	2864	;
	2865	"RTN","XUC ERT1",99,0 )
	2866	CERT(SIG) ;Function. Retrieves a certifi cate
	2867	"RTN","XUC ERT1",100, 0)
	2868	;ZEXCEPT: Certifica te,KeyInfo ,ValidateT okenRef,X5 09Credenti als ;Objec tScript
	2869	"RTN","XUC ERT1",101, 0)
	2870	N KEYINFO ,ERROR
	2871	"RTN","XUC ERT1",102, 0)
	2872	S KEYINFO =SIG.KeyIn fo
	2873	"RTN","XUC ERT1",103, 0)
	2874	S ERROR=K EYINFO.Val idateToken Ref("")
	2875	"RTN","XUC ERT1",104, 0)
	2876	I ERROR'= "" Q "-1^I nvalid Key Info"
	2877	"RTN","XUC ERT1",105, 0)
	2878	Q KEYINFO .X509Crede ntials.Cer tificate
	2879	"RTN","XUC ERT1",106, 0)
	2880	;
	2881	"RTN","XUC ERT1",107, 0)
	2882	LOADSTRM(G LO) ;Intri nsic Funct ion. Load global int o stream
	2883	"RTN","XUC ERT1",108, 0)
	2884	;ZEXCEPT: %New,%Str eam,Global Character, class ;Obj ectScript
	2885	"RTN","XUC ERT1",109, 0)
	2886	N GLOREF, I,X,XMLSTR M,XQ,Y
	2887	"RTN","XUC ERT1",110, 0)
	2888	S Y=GLO
	2889	"RTN","XUC ERT1",111, 0)
	2890	S XQ=$P(Y ,")") ;or use $$OREF ^DILF(clos ed_root) t o convert closed roo t to open root?
	2891	"RTN","XUC ERT1",112, 0)
	2892	S XMLSTRM =##class(% Stream.Glo balCharact er).%New() ;Create O REF instan ce in memo ry
	2893	"RTN","XUC ERT1",113, 0)
	2894	;Read XML from glob al, starti ng at the beginning, into XMLS TRM
	2895	"RTN","XUC ERT1",114, 0)
	2896	F I=0:0 D Q:Y'[XQ
	2897	"RTN","XUC ERT1",115, 0)
	2898	. S Y=$Q( @Y) Q:Y'[X Q
	2899	"RTN","XUC ERT1",116, 0)
	2900	. S X=$G( @Y)
	2901	"RTN","XUC ERT1",117, 0)
	2902	. D XMLST RM.Write(X )
	2903	"RTN","XUC ERT1",118, 0)
	2904	Q XMLSTRM
	2905	"RTN","XUC ERT1",119, 0)
	2906	;
	2907	"RTN","XUE SSO1")
	2908	0^11^B9385 9687^B7769 3554
	2909	"RTN","XUE SSO1",1,0)
	2910	XUESSO1 ;S EA/LUKE Si ngle Sign- on Utiliti es ;03/08/ 16 08:16
	2911	"RTN","XUE SSO1",2,0)
	2912	;;8.0;KER NEL;165, 183,196,24 5,254,269, 337,395,46 6,523,655, 659;Jul 10, 1995;B uild 22
	2913	"RTN","XUE SSO1",3,0)
	2914	;Per VA D irective 6 402, this routine sh ould not b e modified .
	2915	"RTN","XUE SSO1",4,0)
	2916	;
	2917	"RTN","XUE SSO1",5,0)
	2918	GET(INDUZ) ;Gather i dentifying data from user's ho me site.
	2919	"RTN","XUE SSO1",6,0)
	2920	;Called b y SETVISIT ^XUSBSE1 ( Get visito r info for TOKEN)
	2921	"RTN","XUE SSO1",7,0)
	2922	;Called b y SNDQRY^D GROHLS (Re trieve use r info) an d SETUP^XW B2HL7 (Get visitor i nfo)
	2923	"RTN","XUE SSO1",8,0)
	2924	;Called b y (unknown ) (VSA/Vis tA.js)
	2925	"RTN","XUE SSO1",9,0)
	2926	;To visit a remote site, user must have : Name, Ac cess/Verif y Codes, S SN (no pse udo), Stat ion Name, Site Numbe r
	2927	"RTN","XUE SSO1",10,0 )
	2928	;The foll owing data is option al: Phone, SecID, Ne twork User name
	2929	"RTN","XUE SSO1",11,0 )
	2930	N %,NAME, SITE,SSN,P HONE,X,N,N ETWORK
	2931	"RTN","XUE SSO1",12,0 )
	2932	I '$D(DUZ ) Q "-1^In sufficient info to a llow visit ing: No D UZ"
	2933	"RTN","XUE SSO1",13,0 )
	2934	I '$D(DUZ (2)) Q "-1 ^Insuffici ent info t o allow vi siting: M issing DUZ (2)"
	2935	"RTN","XUE SSO1",14,0 )
	2936	S N=$G(^V A(200,DUZ, 0))
	2937	"RTN","XUE SSO1",15,0 )
	2938	I '$L(N) Q "-1^Insu fficient i nfo to all ow visitin g: Missin g NPF Zero Node"
	2939	"RTN","XUE SSO1",16,0 )
	2940	S %=$P(N, U,3) I $L( %)<1 Q "-1 ^Insuffici ent info t o allow vi siting: N o Access C ode"
	2941	"RTN","XUE SSO1",17,0 )
	2942	S %=$P($G (^VA(200,D UZ,.1)),U, 2) I $L(%) <1 Q "-1^I nsufficien t info to allow visi ting: No Verify Cod e"
	2943	"RTN","XUE SSO1",18,0 )
	2944	S %=$P(N, U,11) I $L (%)>1,(DT> %) Q "-1^I nsufficien t info to allow visi ting: Ter minated Us er"
	2945	"RTN","XUE SSO1",19,0 )
	2946	I $P($$AC TIVE^XUSER (DUZ),U,1) '=1 Q "-1^ Insufficie nt info to allow vis iting: No t an activ e user"
	2947	"RTN","XUE SSO1",20,0 )
	2948	;I $G(DUZ ("LOA"))<2 Q "-1^Ins ufficient Level of A ssurance t o allow vi siting: U ser not au thenticate d"
	2949	"RTN","XUE SSO1",21,0 )
	2950	S NAME=$P (N,U)
	2951	"RTN","XUE SSO1",22,0 )
	2952	I '$L(NAM E) Q "-1^I nsufficien t info to allow visi ting: No User Name"
	2953	"RTN","XUE SSO1",23,0 )
	2954	;
	2955	"RTN","XUE SSO1",24,0 )
	2956	S SITE=$$ NS^XUAF4(D UZ(2)) ;Si te is name ^station#
	2957	"RTN","XUE SSO1",25,0 )
	2958	I $P(SITE ,U,2)="" Q "-1^Insuf ficient in fo to allo w visiting : Missing Station N umber"
	2959	"RTN","XUE SSO1",26,0 )
	2960	;
	2961	"RTN","XUE SSO1",27,0 )
	2962	S SSN=$P( $G(^VA(200 ,DUZ,1)),U ,9)
	2963	"RTN","XUE SSO1",28,0 )
	2964	I $$SPECI AL($P(SITE ,"^",2)) S SSN=99999 9999 ;Mani la RO does n't need S SN
	2965	"RTN","XUE SSO1",29,0 )
	2966	I 'SSN Q "-1^Insuff icient inf o to allow visiting: Missing SSN"
	2967	"RTN","XUE SSO1",30,0 )
	2968	I $E(SSN, 10)="P" Q "-1^Insuff icient inf o to allow visiting: User has a pseudo SSN"
	2969	"RTN","XUE SSO1",31,0 )
	2970	I '$$SSNC HECK(SSN) Q "-1^Insu fficient i nfo to all ow visitin g: User d oes not ha ve a valid SSN"
	2971	"RTN","XUE SSO1",32,0 )
	2972	;
	2973	"RTN","XUE SSO1",33,0 )
	2974	S PHONE=$ $PH
	2975	"RTN","XUE SSO1",34,0 )
	2976	S X=SSN_U _NAME_U_SI TE_U_DUZ
	2977	"RTN","XUE SSO1",35,0 )
	2978	I $L(PHON E)>2&($L(P HONE<20)) S X=X_U_PH ONE
	2979	"RTN","XUE SSO1",36,0 )
	2980	S $P(X,U, 7)=$P($G(^ VA(200,DUZ ,205.1)),U ) ;p655 Se cID
	2981	"RTN","XUE SSO1",37,0 )
	2982	S $P(X,U, 8)=$P($G(^ VA(200,DUZ ,501)),U) ;p655 Netw ork Userna me
	2983	"RTN","XUE SSO1",38,0 )
	2984	;X=ssn^na me^station name^stat ion number ^DUZ^phone ^SecID^net work usern ame
	2985	"RTN","XUE SSO1",39,0 )
	2986	Q X
	2987	"RTN","XUE SSO1",40,0 )
	2988	;
	2989	"RTN","XUE SSO1",41,0 )
	2990	PH() ; Try for a pho ne number or pager
	2991	"RTN","XUE SSO1",42,0 )
	2992	N %,X
	2993	"RTN","XUE SSO1",43,0 )
	2994	S %=""
	2995	"RTN","XUE SSO1",44,0 )
	2996	S X=$G(^V A(200,DUZ, .13))
	2997	"RTN","XUE SSO1",45,0 )
	2998	I '$L(X) Q ""
	2999	"RTN","XUE SSO1",46,0 )
	3000	S %=$P(X, U,5) I $L( %)>6 Q % ;Commercia l #
	3001	"RTN","XUE SSO1",47,0 )
	3002	S %=$P(X, U,2) I $L( %)>2 Q % ;Office
	3003	"RTN","XUE SSO1",48,0 )
	3004	S %=$P(X, U,8) I $L( %)>6 Q % ;Digital P ager
	3005	"RTN","XUE SSO1",49,0 )
	3006	S %=$P(X, U,7) I $L( %)>6 Q % ;Pager
	3007	"RTN","XUE SSO1",50,0 )
	3008	S %=$P(X, U,3) I $L( %)>2 Q % ;Phone #3
	3009	"RTN","XUE SSO1",51,0 )
	3010	S %=$P(X, U,4) I $L( %)>2 Q % ;Phone #4
	3011	"RTN","XUE SSO1",52,0 )
	3012	S %=$P(X, U,1) I $L( %)>2 Q % ;Home Phon e
	3013	"RTN","XUE SSO1",53,0 )
	3014	Q "" ;Cou ldn't find one.
	3015	"RTN","XUE SSO1",54,0 )
	3016	;
	3017	"RTN","XUE SSO1",55,0 )
	3018	SPECIAL(SN ) ;INTRINS IC. Specia l Manila R O site
	3019	"RTN","XUE SSO1",56,0 )
	3020	; Returns 1 if SN i s "358"
	3021	"RTN","XUE SSO1",57,0 )
	3022	Q 358=SN
	3023	"RTN","XUE SSO1",58,0 )
	3024	;
	3025	"RTN","XUE SSO1",59,0 )
	3026	PUT(DATIN) ;;Setup d ata from a uthenticat ing site G ET() at re ceiving si te
	3027	"RTN","XUE SSO1",60,0 )
	3028	;Called b y OLDCAPRI ^XUSBSE1 ( Old Capri) and SETUP ^XUSBSE1 ( BSE)
	3029	"RTN","XUE SSO1",61,0 )
	3030	;Called b y DIQ^DGRO HLU (Sensi tive Patie nt access) and REMOT E^XWB2HL7 (Visitor a ccess via HL7)
	3031	"RTN","XUE SSO1",62,0 )
	3032	;Called b y (unknown ) (VSA/Vis tA.js)
	3033	"RTN","XUE SSO1",63,0 )
	3034	;Return: 0=fail, 1= OK
	3035	"RTN","XUE SSO1",64,0 )
	3036	N NAME,NE TWORK,NEWD UZ,PHONE,R MTDUZ,SECI D,SITE,SIT ENUM,SSN,T ODAY,XSITE IEN,XT,XUM F
	3037	"RTN","XUE SSO1",65,0 )
	3038	I $G(DUZ( "LOA"))="" S DUZ("LO A")=1
	3039	"RTN","XUE SSO1",66,0 )
	3040	;I $G(DUZ ("LOA"))<2 Q 0 ;do not allow access if Level Of A ssurance i s low
	3041	"RTN","XUE SSO1",67,0 )
	3042	I $G(DUZ( "AUTHENTIC ATION"))=" " S DUZ("A UTHENTICAT ION")="UNK NOWN"
	3043	"RTN","XUE SSO1",68,0 )
	3044	S U="^",T ODAY=$$HTF M^XLFDT($H ),DT=$P(TO DAY,"."),N EWDUZ=0
	3045	"RTN","XUE SSO1",69,0 )
	3046	K ^TMP("D IERR",$J)
	3047	"RTN","XUE SSO1",70,0 )
	3048	;
	3049	"RTN","XUE SSO1",71,0 )
	3050	S SSN=$P( DATIN,U,1) ,NAME=$P(D ATIN,U,2), SITE=$P(DA TIN,U,3)
	3051	"RTN","XUE SSO1",72,0 )
	3052	S SITENUM =$P(DATIN, U,4),RMTDU Z=$P(DATIN ,U,5),PHON E=$P(DATIN ,U,6)
	3053	"RTN","XUE SSO1",73,0 )
	3054	S SECID=$ P(DATIN,U, 7) ;p655
	3055	"RTN","XUE SSO1",74,0 )
	3056	S NETWORK =$P(DATIN, U,8) ;p655
	3057	"RTN","XUE SSO1",75,0 )
	3058	;Format c hecks
	3059	"RTN","XUE SSO1",76,0 )
	3060	I NAME'?1 U.E1","1U. E Q 0
	3061	"RTN","XUE SSO1",77,0 )
	3062	I SSN'?9N Q 0
	3063	"RTN","XUE SSO1",78,0 )
	3064	I '$L(SIT E)!('$L(SI TENUM)) Q 0
	3065	"RTN","XUE SSO1",79,0 )
	3066	S XUMF=1 D CHK^DIE( 4,99,,SITE NUM,.XT) I XT=U Q 0 ;p533
	3067	"RTN","XUE SSO1",80,0 )
	3068	D CHK^DIE (200.06,1, ,SITE,.XT) I XT=U Q 0 ;p533
	3069	"RTN","XUE SSO1",81,0 )
	3070	I RMTDUZ' >0 Q 0 ;p3 37
	3071	"RTN","XUE SSO1",82,0 )
	3072	;Check if visitor i s from a v alid activ e site
	3073	"RTN","XUE SSO1",83,0 )
	3074	S XSITEIE N=$$IEN^XU AF4(SITENU M) I XSITE IEN="" H 1 ;Q 0 ;Qui t if authe nticating VistA not in INSTITU TION file (#4)
	3075	"RTN","XUE SSO1",84,0 )
	3076	;I '$$ACT IVE^XUAF4( XSITEIEN) Q 0 ;Quit if authent icating Vi stA is not an active VA site ( spoofed)
	3077	"RTN","XUE SSO1",85,0 )
	3078	;I $P($$N S^XUAF4(XS ITEIEN),"^ ",1)'=SITE Q 0 ;Quit if authen ticating V istA name and statio n number m ismatch (s poofed)
	3079	"RTN","XUE SSO1",86,0 )
	3080	;Get a LO CK. Block if can't g et.
	3081	"RTN","XUE SSO1",87,0 )
	3082	L +^VA(20 0,"HL7"):1 0 Q:'$T 0
	3083	"RTN","XUE SSO1",88,0 )
	3084	S XT=$$TA LL($G(DUZ, 0)) L -^VA (200,"HL7" )
	3085	"RTN","XUE SSO1",89,0 )
	3086	I XT Q $$ SET(NEWDUZ ) ;Return 1 if OK.
	3087	"RTN","XUE SSO1",90,0 )
	3088	Q 0
	3089	"RTN","XUE SSO1",91,0 )
	3090	;
	3091	"RTN","XUE SSO1",92,0 )
	3092	TALL(DUZ) ;INTRINSIC . Test for existing user or ad ds a new o ne
	3093	"RTN","XUE SSO1",93,0 )
	3094	; ZEXCEPT : NAME,NEW DUZ,PHONE, RMTDUZ,SIT E,SITENUM, SSN,XSSN,T ODAY,SECID ,NETWORK ; global var iables wit hin this r outine
	3095	"RTN","XUE SSO1",94,0 )
	3096	; ZEXCEPT : DIC ;tur n off DIC( 0) for ^XU A4A7 (work around)
	3097	"RTN","XUE SSO1",95,0 )
	3098	N FLAG,NE WREC,XUIAM
	3099	"RTN","XUE SSO1",96,0 )
	3100	S FLAG=0, DUZ(0)="@" ;Make sur e we can a dd the ent ry
	3101	"RTN","XUE SSO1",97,0 )
	3102	S XUIAM=1 ;Do not t rigger IAM updates
	3103	"RTN","XUE SSO1",98,0 )
	3104	;See if m atch SECID . Only use for looku p. Do not load SECID 's.
	3105	"RTN","XUE SSO1",99,0 )
	3106	I $L(SECI D) D
	3107	"RTN","XUE SSO1",100, 0)
	3108	. S NEWDU Z=+$$SECMA TCH^XUESSO 2(SECID) Q :NEWDUZ<1 ;p655
	3109	"RTN","XUE SSO1",101, 0)
	3110	. I '$D(^ VA(200,NEW DUZ,8910," B",SITENUM )) D VISM
	3111	"RTN","XUE SSO1",102, 0)
	3112	. D ADDW, UPDT
	3113	"RTN","XUE SSO1",103, 0)
	3114	. S FLAG= 1,DUZ(0)=$ P($G(^VA(2 00,NEWDUZ, 0)),U,4)
	3115	"RTN","XUE SSO1",104, 0)
	3116	. Q
	3117	"RTN","XUE SSO1",105, 0)
	3118	I FLAG Q 1 ;Quit he re if we f ound a mat ch on SECI D
	3119	"RTN","XUE SSO1",106, 0)
	3120	;See if t he SSN is in the NPF cross ref erence
	3121	"RTN","XUE SSO1",107, 0)
	3122	I $D(^VA( 200,"SSN", SSN)),$$SS NCHECK(SSN ),'$$SPECI AL(SITENUM ) D
	3123	"RTN","XUE SSO1",108, 0)
	3124	. N XUEIE N,XUEAUSER
	3125	"RTN","XUE SSO1",109, 0)
	3126	. S XUEIE N=0,NEWDUZ =0
	3127	"RTN","XUE SSO1",110, 0)
	3128	. F S XU EIEN=$O(^V A(200,"SSN ",SSN,XUEI EN)) Q:(XU EIEN="")!( NEWDUZ>0) D
	3129	"RTN","XUE SSO1",111, 0)
	3130	. . N XUE NAME S XUE NAME=$P($G (^VA(200,X UEIEN,0)), U)
	3131	"RTN","XUE SSO1",112, 0)
	3132	. . S NEW DUZ=XUEIEN
	3133	"RTN","XUE SSO1",113, 0)
	3134	. . ;Upda te name if names don 't match, user has v isited bef ore, and u ser is not an active local use r
	3135	"RTN","XUE SSO1",114, 0)
	3136	. . I (XU ENAME'=NAM E)&(XUEIEN =$O(^VA(20 0,"AVISIT" ,SITENUM,R MTDUZ,0))) &(('$$ACTI VE^XUSER(X UEIEN))) D ADDN
	3137	"RTN","XUE SSO1",115, 0)
	3138	. Q:NEWDU Z'>0
	3139	"RTN","XUE SSO1",116, 0)
	3140	. I '$D(^ VA(200,NEW DUZ,8910," B",SITENUM )) D VISM
	3141	"RTN","XUE SSO1",117, 0)
	3142	. D ADDW, ADDI,UPDT
	3143	"RTN","XUE SSO1",118, 0)
	3144	. S FLAG= 1,DUZ(0)=$ P($G(^VA(2 00,NEWDUZ, 0)),U,4)
	3145	"RTN","XUE SSO1",119, 0)
	3146	. Q
	3147	"RTN","XUE SSO1",120, 0)
	3148	I FLAG Q 1 ;Quit he re if we f ound a mat ch for SSN
	3149	"RTN","XUE SSO1",121, 0)
	3150	;See if i n the AVIS IT cross r eference ( Manila onl y)
	3151	"RTN","XUE SSO1",122, 0)
	3152	I $$SPECI AL(SITENUM ) D
	3153	"RTN","XUE SSO1",123, 0)
	3154	. S NEWDU Z=$O(^VA(2 00,"AVISIT ",SITENUM, RMTDUZ,0))
	3155	"RTN","XUE SSO1",124, 0)
	3156	. Q:NEWDU Z'>0 ;Use r must hav e visited from Manil a at least once to b e found by this test
	3157	"RTN","XUE SSO1",125, 0)
	3158	. D ADDW, ADDI,UPDT S FLAG=1,D UZ(0)=$P($ G(^VA(200, NEWDUZ,0)) ,U,4)
	3159	"RTN","XUE SSO1",126, 0)
	3160	. Q
	3161	"RTN","XUE SSO1",127, 0)
	3162	I FLAG Q 1 ;Quit he re if we f ound a mat ch for AVI SIT
	3163	"RTN","XUE SSO1",128, 0)
	3164	;Try for a NAME mat ch in "B"
	3165	"RTN","XUE SSO1",129, 0)
	3166	N XUEIEN, XUESSN
	3167	"RTN","XUE SSO1",130, 0)
	3168	S NAME=$$ UP^XLFSTR( NAME)
	3169	"RTN","XUE SSO1",131, 0)
	3170	I $D(^VA( 200,"B",NA ME)) D
	3171	"RTN","XUE SSO1",132, 0)
	3172	. S XUEIE N=0,NEWDUZ =0
	3173	"RTN","XUE SSO1",133, 0)
	3174	. F S XU EIEN=$O(^V A(200,"B", NAME,XUEIE N)) Q:(XUE IEN="")!(N EWDUZ>0) D
	3175	"RTN","XUE SSO1",134, 0)
	3176	. . S XUE SSN=$P($G( ^VA(200,XU EIEN,1)),U ,9)
	3177	"RTN","XUE SSO1",135, 0)
	3178	. . I (XU ESSN'=SSN) &($L(XUESS N)>8) Q ; Do not use if name h as a diffe rent SSN
	3179	"RTN","XUE SSO1",136, 0)
	3180	. . S NEW DUZ=XUEIEN
	3181	"RTN","XUE SSO1",137, 0)
	3182	. I NEWDU Z>0 D
	3183	"RTN","XUE SSO1",138, 0)
	3184	. . D ADD S
	3185	"RTN","XUE SSO1",139, 0)
	3186	. . I '$D (^VA(200,N EWDUZ,8910 ,"B",SITEN UM)) D VIS M
	3187	"RTN","XUE SSO1",140, 0)
	3188	. . D ADD W,ADDI,UPD T
	3189	"RTN","XUE SSO1",141, 0)
	3190	. . S FLA G=1,DUZ(0) =$P($G(^VA (200,NEWDU Z,0)),U,4)
	3191	"RTN","XUE SSO1",142, 0)
	3192	. Q
	3193	"RTN","XUE SSO1",143, 0)
	3194	I FLAG Q 1 ;Quit he re if we f ound an ex act match for NAME ( w/o SSN)
	3195	"RTN","XUE SSO1",144, 0)
	3196	;
	3197	"RTN","XUE SSO1",145, 0)
	3198	;I DUZ("L OA")=1 Q 0 ;Do not add user i f Level Of Assurance is low
	3199	"RTN","XUE SSO1",146, 0)
	3200	;I $G(DUZ ("REMAPP") )="^MDWS" Q 0 ;Do n ot add use r if MDWS access
	3201	"RTN","XUE SSO1",147, 0)
	3202	I $G(DUZ( "REMAPP")) ="^MDWS" H $E(DT,1,3 )-315 ;Di scourage d eprecated MDWS acces s
	3203	"RTN","XUE SSO1",148, 0)
	3204	;
	3205	"RTN","XUE SSO1",149, 0)
	3206	;We didn' t find any body under SecID,SSN ,VISITED F ROM, or NA ME so we a dd a new u ser
	3207	"RTN","XUE SSO1",150, 0)
	3208	S DIC(0)= "" ;Turn o ff ^XUA4A7 (work aro und)
	3209	"RTN","XUE SSO1",151, 0)
	3210	;Put the name in th e .01 fiel d first.
	3211	"RTN","XUE SSO1",152, 0)
	3212	D ADDU ;A DDU will s et NEWDUZ
	3213	"RTN","XUE SSO1",153, 0)
	3214	I NEWDUZ= 0 Q 0 ;If NEWDUZ is still 0, the User a dd didn't work so ex it.
	3215	"RTN","XUE SSO1",154, 0)
	3216	D ADDS,AD DA ;(p337) Add SSN a nd "VISITO R" Alias.
	3217	"RTN","XUE SSO1",155, 0)
	3218	D ADDW,AD DI ; Add N ETWORK USE RNAME and SSO attrib utes
	3219	"RTN","XUE SSO1",156, 0)
	3220	D VISM,UP DT ; Fill in the VI SITED FROM multiple
	3221	"RTN","XUE SSO1",157, 0)
	3222	I NEWDUZ= 0 Q 0 ;Cou ldn't upda te user
	3223	"RTN","XUE SSO1",158, 0)
	3224	I $D(^TMP ("DIERR",$ J)) Q 0 ; FileMan Er ror
	3225	"RTN","XUE SSO1",159, 0)
	3226	;
	3227	"RTN","XUE SSO1",160, 0)
	3228	S FLAG=$$ BULL(NAME, NEWDUZ,SIT E,SITENUM, RMTDUZ,PHO NE,TODAY)
	3229	"RTN","XUE SSO1",161, 0)
	3230	S DUZ(0)= $P($G(^VA( 200,NEWDUZ ,0)),U,4)
	3231	"RTN","XUE SSO1",162, 0)
	3232	Q 1 ;Eve ry thing O K
	3233	"RTN","XUE SSO1",163, 0)
	3234	;
	3235	"RTN","XUE SSO1",164, 0)
	3236	SET(NEWDUZ ) ;INTRINS IC. Set th e user up to go
	3237	"RTN","XUE SSO1",165, 0)
	3238	; ZEXCEPT : RMTDUZ,S ITENUM ;gl obal varia bles withi n this rou tine
	3239	"RTN","XUE SSO1",166, 0)
	3240	;Return: 0=fail, 1= OK
	3241	"RTN","XUE SSO1",167, 0)
	3242	Q:NEWDUZ' >0 0
	3243	"RTN","XUE SSO1",168, 0)
	3244	N XUSER,X OPT
	3245	"RTN","XUE SSO1",169, 0)
	3246	S DUZ=NEW DUZ,U="^", DUZ("VISIT OR")=SITEN UM_U_RMTDU Z ;p533
	3247	"RTN","XUE SSO1",170, 0)
	3248	D DUZ^XUS 1A
	3249	"RTN","XUE SSO1",171, 0)
	3250	Q 1
	3251	"RTN","XUE SSO1",172, 0)
	3252	;
	3253	"RTN","XUE SSO1",173, 0)
	3254	ADDU ;SR. Add a new name to th e New Pers on File
	3255	"RTN","XUE SSO1",174, 0)
	3256	; ZEXCEPT : FDR,NAME ,NEWDUZ,NE WREC ;glob al variabl es within this routi ne
	3257	"RTN","XUE SSO1",175, 0)
	3258	N DD,DO,D IC,DA,X,Y
	3259	"RTN","XUE SSO1",176, 0)
	3260	S NEWDUZ= 0
	3261	"RTN","XUE SSO1",177, 0)
	3262	S DIC="^V A(200,",DI C(0)="F",X =NAME,NEWR EC=1 ;p533
	3263	"RTN","XUE SSO1",178, 0)
	3264	D FILE^DI CN
	3265	"RTN","XUE SSO1",179, 0)
	3266	S:Y>0 NEW DUZ=+Y
	3267	"RTN","XUE SSO1",180, 0)
	3268	Q
	3269	"RTN","XUE SSO1",181, 0)
	3270	;
	3271	"RTN","XUE SSO1",182, 0)
	3272	ADDS ;SR. Add a SSN to the New Person Fi le
	3273	"RTN","XUE SSO1",183, 0)
	3274	; ZEXCEPT : FDR,NEWD UZ,SSN,SIT ENUM ;glob al variabl es within this routi ne
	3275	"RTN","XUE SSO1",184, 0)
	3276	N IEN
	3277	"RTN","XUE SSO1",185, 0)
	3278	Q:$$SPECI AL(SITENUM ) ;don't add SSN if from Mani la
	3279	"RTN","XUE SSO1",186, 0)
	3280	Q:$D(^VA( 200,"SSN", SSN)) ;do n't try to add a dup licate SSN
	3281	"RTN","XUE SSO1",187, 0)
	3282	Q:'$$SSNC HECK(SSN) ;only add a valid S SN
	3283	"RTN","XUE SSO1",188, 0)
	3284	S IEN=NEW DUZ_","
	3285	"RTN","XUE SSO1",189, 0)
	3286	S FDR(200 ,IEN,9)=SS N
	3287	"RTN","XUE SSO1",190, 0)
	3288	;Do updat e for all data in UP DT
	3289	"RTN","XUE SSO1",191, 0)
	3290	Q
	3291	"RTN","XUE SSO1",192, 0)
	3292	;
	3293	"RTN","XUE SSO1",193, 0)
	3294	ADDI ;SR. Add SSO at tributes t o the New Person Fil e
	3295	"RTN","XUE SSO1",194, 0)
	3296	; ZEXCEPT : FDR,NEWD UZ,SECID ; global var iables wit hin this r outine
	3297	"RTN","XUE SSO1",195, 0)
	3298	N IEN
	3299	"RTN","XUE SSO1",196, 0)
	3300	Q:'$L(SEC ID) ;need SECID for SSO
	3301	"RTN","XUE SSO1",197, 0)
	3302	S IEN=NEW DUZ_","
	3303	"RTN","XUE SSO1",198, 0)
	3304	I $P($G(^ VA(200,NEW DUZ,205)), U,1)="" S FDR(200,IE N,205.1)=S ECID ;SECI D
	3305	"RTN","XUE SSO1",199, 0)
	3306	I $P($G(^ VA(200,NEW DUZ,205)), U,2)="" S FDR(200,IE N,205.2)=$ P($G(^XTV( 8989.3,1,2 00)),U,2) ;Subject O rganizatio n
	3307	"RTN","XUE SSO1",200, 0)
	3308	I $P($G(^ VA(200,NEW DUZ,205)), U,3)="" S FDR(200,IE N,205.3)=$ P($G(^XTV( 8989.3,1,2 00)),U,3) ;Subject O rganizatio n ID
	3309	"RTN","XUE SSO1",201, 0)
	3310	I $P($G(^ VA(200,NEW DUZ,205)), U,4)="" S FDR(200,IE N,205.4)=S ECID ;Uniq ue User ID
	3311	"RTN","XUE SSO1",202, 0)
	3312	;Do updat e for all data in UP DT
	3313	"RTN","XUE SSO1",203, 0)
	3314	Q
	3315	"RTN","XUE SSO1",204, 0)
	3316	;
	3317	"RTN","XUE SSO1",205, 0)
	3318	ADDN ;SR. Update the NAME in t he New Per son File
	3319	"RTN","XUE SSO1",206, 0)
	3320	; ZEXCEPT : FDR,NEWD UZ,NAME,RM TDUZ,SITEN UM ;global variables within th is routine
	3321	"RTN","XUE SSO1",207, 0)
	3322	N IEN
	3323	"RTN","XUE SSO1",208, 0)
	3324	Q:NAME=$P ($G(^VA(20 0,NEWDUZ,0 )),U,1) ; name is u nchanged, do nothing
	3325	"RTN","XUE SSO1",209, 0)
	3326	I NEWDUZ' =$O(^VA(20 0,"AVISIT" ,SITENUM,R MTDUZ,0)) Q ; user hasn't vis ited befor e, so this is not a valid name change
	3327	"RTN","XUE SSO1",210, 0)
	3328	S IEN=NEW DUZ_","
	3329	"RTN","XUE SSO1",211, 0)
	3330	S FDR(200 ,IEN,.01)= NAME
	3331	"RTN","XUE SSO1",212, 0)
	3332	;Do updat e for all data in UP DT
	3333	"RTN","XUE SSO1",213, 0)
	3334	Q
	3335	"RTN","XUE SSO1",214, 0)
	3336	;
	3337	"RTN","XUE SSO1",215, 0)
	3338	ADDA ;SR. Add a new Alias to f ile 200.04
	3339	"RTN","XUE SSO1",216, 0)
	3340	; ZEXCEPT : FDR,NEWD UZ ;global variables within th is routine
	3341	"RTN","XUE SSO1",217, 0)
	3342	N IEN
	3343	"RTN","XUE SSO1",218, 0)
	3344	Q:$D(^VA( 200,NEWDUZ ,3,"B","VI SITOR")) ; Quit if user is al ready mark ed as visi tor
	3345	"RTN","XUE SSO1",219, 0)
	3346	S IEN="+2 ,"_NEWDUZ_ ","
	3347	"RTN","XUE SSO1",220, 0)
	3348	S FDR(200 .04,IEN,.0 1)="VISITO R"
	3349	"RTN","XUE SSO1",221, 0)
	3350	;Do updat e for all data in UP DT
	3351	"RTN","XUE SSO1",222, 0)
	3352	Q
	3353	"RTN","XUE SSO1",223, 0)
	3354	;
	3355	"RTN","XUE SSO1",224, 0)
	3356	ADDW ;SR. Add NETWOR K USERNAME to the Ne w Person F ile
	3357	"RTN","XUE SSO1",225, 0)
	3358	; ZEXCEPT : FDR,NEWD UZ,NETWORK ;global v ariables w ithin this routine
	3359	"RTN","XUE SSO1",226, 0)
	3360	N IEN
	3361	"RTN","XUE SSO1",227, 0)
	3362	Q:$G(^VA( 200,NEWDUZ ,501))'="" ; Quit i f user alr eady has a NETWORK U SERNAME
	3363	"RTN","XUE SSO1",228, 0)
	3364	Q:$L($G(N ETWORK))<1 2 ; Quit if NETWORK USERNAME is too sho rt
	3365	"RTN","XUE SSO1",229, 0)
	3366	S IEN=NEW DUZ_","
	3367	"RTN","XUE SSO1",230, 0)
	3368	S FDR(200 ,IEN,501.1 )=$G(NETWO RK)
	3369	"RTN","XUE SSO1",231, 0)
	3370	;Do updat e for all data in UP DT
	3371	"RTN","XUE SSO1",232, 0)
	3372	Q
	3373	"RTN","XUE SSO1",233, 0)
	3374	;
	3375	"RTN","XUE SSO1",234, 0)
	3376	VISM ;SR. Create a m ultiple fo r this sit e number i n the VISI TED FROM f ile
	3377	"RTN","XUE SSO1",235, 0)
	3378	; ZEXCEPT : FDR,NEWD UZ,RMTDUZ, SITE,SITEN UM,TODAY ; global var iables wit hin this r outine
	3379	"RTN","XUE SSO1",236, 0)
	3380	N IEN
	3381	"RTN","XUE SSO1",237, 0)
	3382	S IEN="+3 ,"_NEWDUZ_ ","
	3383	"RTN","XUE SSO1",238, 0)
	3384	S FDR(200 .06,IEN,.0 1)=SITENUM
	3385	"RTN","XUE SSO1",239, 0)
	3386	S FDR(200 .06,IEN,1) =SITE
	3387	"RTN","XUE SSO1",240, 0)
	3388	S FDR(200 .06,IEN,2) =RMTDUZ
	3389	"RTN","XUE SSO1",241, 0)
	3390	S FDR(200 .06,IEN,3) =TODAY
	3391	"RTN","XUE SSO1",242, 0)
	3392	;Do updat e for all data in UP DT
	3393	"RTN","XUE SSO1",243, 0)
	3394	Q
	3395	"RTN","XUE SSO1",244, 0)
	3396	;
	3397	"RTN","XUE SSO1",245, 0)
	3398	UPDT ;SR. Update all data fiel ds
	3399	"RTN","XUE SSO1",246, 0)
	3400	; Sets: N EWDUZ=0 if failed to complete update
	3401	"RTN","XUE SSO1",247, 0)
	3402	; ZEXCEPT : FDR,NAME ,NEWDUZ,SI TE,SITENUM ,PHONE,TOD AY,DATIN,N EWREC ;glo bal variab les within this rout ine
	3403	"RTN","XUE SSO1",248, 0)
	3404	N IEN,FDQ
	3405	"RTN","XUE SSO1",249, 0)
	3406	I $D(FDR( 200.06)) S IEN=$O(FD R(200.06," "))
	3407	"RTN","XUE SSO1",250, 0)
	3408	E S IEN= $O(^VA(200 ,NEWDUZ,89 10,"B",SIT ENUM,0))_" ,"_NEWDUZ_ ","
	3409	"RTN","XUE SSO1",251, 0)
	3410	S FDR(200 .06,IEN,4) =TODAY
	3411	"RTN","XUE SSO1",252, 0)
	3412	I $D(PHON E),($L(PHO NE)>4) S F DR(200.06, IEN,5)=PHO NE ;p466 U pdate the phone each time
	3413	"RTN","XUE SSO1",253, 0)
	3414	I $D(SITE ) S FDR(20 0.06,IEN,1 )=SITE ;p6 55 Update the site e ach time ( name chang es in INST ITUTION fi le)
	3415	"RTN","XUE SSO1",254, 0)
	3416	K IEN D U PDATE^DIE( "E","FDR", "IEN") ;Fi le all the data
	3417	"RTN","XUE SSO1",255, 0)
	3418	I $D(^TMP ("DIERR",$ J)) D Q
	3419	"RTN","XUE SSO1",256, 0)
	3420	. N DIK,D A,Y
	3421	"RTN","XUE SSO1",257, 0)
	3422	. I $D(NE WREC) S DI K="^VA(200 ,",DA=NEWD UZ D ^DIK ;Remove pa rtial entr y ;p533
	3423	"RTN","XUE SSO1",258, 0)
	3424	. S NEWDU Z=0 ;Tell failed
	3425	"RTN","XUE SSO1",259, 0)
	3426	Q
	3427	"RTN","XUE SSO1",260, 0)
	3428	;
	3429	"RTN","XUE SSO1",261, 0)
	3430	BULL(NAME, NEWDUZ,SIT E,SITENUM, RMTDUZ,PHO NE,TODAY) ;INTRINSIC . Send loc al bulleti n if user added
	3431	"RTN","XUE SSO1",262, 0)
	3432	; Returns : 0 if fai led to sen d bulletin , 1 if suc cess
	3433	"RTN","XUE SSO1",263, 0)
	3434	; ZEXCEPT : XTMUNIT ;set for u nit testin g
	3435	"RTN","XUE SSO1",264, 0)
	3436	N XMB
	3437	"RTN","XUE SSO1",265, 0)
	3438	I ($G(NAM E)="")!($G (NEWDUZ)=" ")!($G(SIT E)="")!($G (SITENUM)= "") Q 0
	3439	"RTN","XUE SSO1",266, 0)
	3440	I ($G(RMT DUZ)="")!( $G(PHONE)= "")!($G(TO DAY)="") Q 0
	3441	"RTN","XUE SSO1",267, 0)
	3442	S XMB="XU VISIT"
	3443	"RTN","XUE SSO1",268, 0)
	3444	S XMB(1)= $$FMTE^XLF DT(TODAY)
	3445	"RTN","XUE SSO1",269, 0)
	3446	S XMB(2)= NAME,XMB(3 )=NEWDUZ,X MB(4)=SITE
	3447	"RTN","XUE SSO1",270, 0)
	3448	S XMB(5)= SITENUM,XM B(6)=RMTDU Z,XMB(7)=P HONE
	3449	"RTN","XUE SSO1",271, 0)
	3450	I '$D(XTM UNIT) D ^X MB
	3451	"RTN","XUE SSO1",272, 0)
	3452	Q 1
	3453	"RTN","XUE SSO1",273, 0)
	3454	;
	3455	"RTN","XUE SSO1",274, 0)
	3456	SSNCHECK(S SN) ;INTRI NSIC. Chec k for vali d SSN
	3457	"RTN","XUE SSO1",275, 0)
	3458	; Input: SSN in for mat "nnnnn nnnn" or " nnn-nn-nnn n"
	3459	"RTN","XUE SSO1",276, 0)
	3460	; Returns : 0 if SSN is invali d, 1 if su ccess
	3461	"RTN","XUE SSO1",277, 0)
	3462	; Valid S SN range 0 01-01-0001 to 899-99 -9999 with exception s (rule as of 2011)
	3463	"RTN","XUE SSO1",278, 0)
	3464	; Valid I ndividual Taxpayer I dentificat ion Number range 900 -01-0001 t o 999-99-9 999 with e xceptions (rule as o f 1966)
	3465	"RTN","XUE SSO1",279, 0)
	3466	N X
	3467	"RTN","XUE SSO1",280, 0)
	3468	I $$PROD^ XUPROD()=0 Q 1 ;all ow use of invalid SS Ns in deve lopment ac counts
	3469	"RTN","XUE SSO1",281, 0)
	3470	S X=$TR(S SN,"-")
	3471	"RTN","XUE SSO1",282, 0)
	3472	I $L(X)'= 9 Q 0
	3473	"RTN","XUE SSO1",283, 0)
	3474	I $E(X,1, 3)'>0 Q 0 ;1st 3 d igits cann ot be 000
	3475	"RTN","XUE SSO1",284, 0)
	3476	I $E(X,4, 5)'>0 Q 0 ;digits 4-5 cannot be 00
	3477	"RTN","XUE SSO1",285, 0)
	3478	I $E(X,6, 9)'>0 Q 0 ;digits 6-9 cannot be 0000
	3479	"RTN","XUE SSO1",286, 0)
	3480	I $E(X,1, 3)=666 Q 0 ;1st 3 d igits cann ot be 666
	3481	"RTN","XUE SSO1",287, 0)
	3482	I (X>9876 54319)&(X< 987654330) Q 0 ;SSN range res erved for advertisin g
	3483	"RTN","XUE SSO1",288, 0)
	3484	I ($E(X,1 ,3)>899)&( $E(X,4,5)= 89) Q 0 ; digits 4-5 of ITIN c annot be 8 9
	3485	"RTN","XUE SSO1",289, 0)
	3486	I ($E(X,1 ,3)>899)&( $E(X,4,5)= 93) Q 0 ; digits 4-5 of ITIN c annot be 9 3
	3487	"RTN","XUE SSO1",290, 0)
	3488	Q 1
	3489	"RTN","XUE SSO2")
	3490	0^12^B1177 14262^B108 993229
	3491	"RTN","XUE SSO2",1,0)
	3492	XUESSO2 ;I SD/HGW Enh anced Sing le Sign-On Utilities ;08/25/15 10:48
	3493	"RTN","XUE SSO2",2,0)
	3494	;;8.0;KER NEL;655, 659;Jul 10, 1995;B uild 22
	3495	"RTN","XUE SSO2",3,0)
	3496	;Per VA D irective 6 402, this routine sh ould not b e modified .
	3497	"RTN","XUE SSO2",4,0)
	3498	;
	3499	"RTN","XUE SSO2",5,0)
	3500	; This ut ility will identify a VistA us er for aud iting and HIPAA requ irements.
	3501	"RTN","XUE SSO2",6,0)
	3502	; NONE of the fie lds listed below can contain a caret (^) character as it is used as a delimiter in VistA!
	3503	"RTN","XUE SSO2",7,0)
	3504	;
	3505	"RTN","XUE SSO2",8,0)
	3506	; $$FINDU SER() - At least one of the fo llowing at tributes i s required to unique ly identif y an exist ing user i n the
	3507	"RTN","XUE SSO2",9,0)
	3508	; NE W PERSON f ile (#200) :
	3509	"RTN","XUE SSO2",10,0 )
	3510	;
	3511	"RTN","XUE SSO2",11,0 )
	3512	; XATR( 7) = uniqu e Security ID [SecID , assigned by Identi ty and Acc ess Manage ment]
	3513	"RTN","XUE SSO2",12,0 )
	3514	; XATR( 8) = uniqu e National Provider Identifier [assigned by Center s for Medi care and M edicaid Se rvices (CM S)]
	3515	"RTN","XUE SSO2",13,0 )
	3516	; XATR( 9) = uniqu e Social S ecurity (S SN) or Tax payer Iden tification Number (T IN) [assig ned by the Social Se curity Adm inistratio n]
	3517	"RTN","XUE SSO2",14,0 )
	3518	; XATR( 2) and XAT R(3) = com bination o f a unique Subject O rganizatio n ID (OID) with a Un ique User ID (UID) [ see below]
	3519	"RTN","XUE SSO2",15,0 )
	3520	;
	3521	"RTN","XUE SSO2",16,0 )
	3522	; $$ADDUS ER() - If an existin g user is not found in the NEW PERSON fi le (#200), then the following minimum at tributes
	3523	"RTN","XUE SSO2",17,0 )
	3524	; are required to provisi on a new u ser:
	3525	"RTN","XUE SSO2",18,0 )
	3526	;
	3527	"RTN","XUE SSO2",19,0 )
	3528	; XATR( 1) = Subje ct Organiz ation [fre e text, 3- 50 charact ers]
	3529	"RTN","XUE SSO2",20,0 )
	3530	; XATR( 2) = Subje ct Organiz ation ID [ free text, 1-50 char acters, un ique to Su bject Orga nization]
	3531	"RTN","XUE SSO2",21,0 )
	3532	; XATR( 3) = Uniqu e User ID [free text , 1-40 cha racters, u nique with in OID]
	3533	"RTN","XUE SSO2",22,0 )
	3534	; XATR( 4) = Subje ct ID [per son's name , to be en tered into the NAME field (#.0 1) of the NEW PERSON file (#20 0)]
	3535	"RTN","XUE SSO2",23,0 )
	3536	;
	3537	"RTN","XUE SSO2",24,0 )
	3538	; The fol lowing att ributes ar e optional for addin g or updat ing a user , but may be require d by a par ticular Vi stA applic ation
	3539	"RTN","XUE SSO2",25,0 )
	3540	; for further I dentity an d Access M anagement:
	3541	"RTN","XUE SSO2",26,0 )
	3542	;
	3543	"RTN","XUE SSO2",27,0 )
	3544	; XATR( 5) = Appli cation ID [Security Phrase to identify a nd authent icate the client app lication a nd establi sh the con text optio n]
	3545	"RTN","XUE SSO2",28,0 )
	3546	; XATR( 6) = Netwo rk Usernam e [Active Directory Login]
	3547	"RTN","XUE SSO2",29,0 )
	3548	; XATR( 9) = uniqu e Social S ecurity (S SN) or Tax payer Iden tification Number (T IN) [assig ned by the Social Se curity Adm inistratio n]
	3549	"RTN","XUE SSO2",30,0 )
	3550	; XATR( 10)= AD UP N [Active Directory User Princ iple Name (UPN)]
	3551	"RTN","XUE SSO2",31,0 )
	3552	; XATR( 11)= E-Mai l Address
	3553	"RTN","XUE SSO2",32,0 )
	3554	Q
	3555	"RTN","XUE SSO2",33,0 )
	3556	;
	3557	"RTN","XUE SSO2",34,0 )
	3558	FINDUSER(X ATR) ;Func tion. Find user usin g minimum attributes for user identifica tion
	3559	"RTN","XUE SSO2",35,0 )
	3560	; Input: XATR = Array con taining us er attribu tes (see a bove).
	3561	"RTN","XUE SSO2",36,0 )
	3562	; Return: Fail = "-1^Error Message"
	3563	"RTN","XUE SSO2",37,0 )
	3564	; Success = IEN of NE W PERSON f ile (#200) entry (No te: this r outine wil l NOT set DUZ to the identifie d IEN)
	3565	"RTN","XUE SSO2",38,0 )
	3566	;
	3567	"RTN","XUE SSO2",39,0 )
	3568	N TODAY,D T,IEN,DIC, XUNAME,ERR MSG
	3569	"RTN","XUE SSO2",40,0 )
	3570	S U="^",T ODAY=$$HTF M^XLFDT($H ),DT=$P(TO DAY,"."),E RRMSG=""
	3571	"RTN","XUE SSO2",41,0 )
	3572	; Check f or unique identifier (SecID, N PI, SSN, o r OID+UID)
	3573	"RTN","XUE SSO2",42,0 )
	3574	I ($G(XAT R(7))="")& ($G(XATR(8 ))="")&($G (XATR(9))= "")&(($G(X ATR(2))="" )&($G(XATR (3))="")) Q "-1^Arra y does not contain a unique id entifier"
	3575	"RTN","XUE SSO2",43,0 )
	3576	; Format user attri butes to m atch FileM an fields
	3577	"RTN","XUE SSO2",44,0 )
	3578	S XATR(1) =$$TITLE^X LFSTR($E($ G(XATR(1)) ,1,50)) ; Subject Or ganization
	3579	"RTN","XUE SSO2",45,0 )
	3580	S XATR(2) =$$LOW^XLF STR($E($G( XATR(2)),1 ,50)) ; Subject Or ganization ID
	3581	"RTN","XUE SSO2",46,0 )
	3582	S XATR(3) =$TR($$LOW ^XLFSTR($E ($G(XATR(3 )),1,40)), "^","%") ; Unique Use r ID
	3583	"RTN","XUE SSO2",47,0 )
	3584	I $G(XATR (4))'="" D Q:ERRMSG '="" ERRMS G
	3585	"RTN","XUE SSO2",48,0 )
	3586	. S XUNAM E=XATR(4) S XATR(4)= $$FORMAT^X LFNAME7(.X UNAME,3,35 ,,0,,,2) ; Subject ID converted to standa rd format
	3587	"RTN","XUE SSO2",49,0 )
	3588	. I $G(XA TR(4))'?1U .E1","1U.E S ERRMSG= "-1^Subjec t ID could not be co nverted to 'LAST,FIR ST MIDDLE SUFFIX' Vi stA standa rd format"
	3589	"RTN","XUE SSO2",50,0 )
	3590	S XATR(6) =$$UP^XLFS TR($E($G(X ATR(6)),1, 50)) ; AD Network Username
	3591	"RTN","XUE SSO2",51,0 )
	3592	S XATR(7) =$TR($E($G (XATR(7)), 1,40),"^", "%") ; SecID
	3593	"RTN","XUE SSO2",52,0 )
	3594	Q $$TALL( .XATR)
	3595	"RTN","XUE SSO2",53,0 )
	3596	;
	3597	"RTN","XUE SSO2",54,0 )
	3598	TALL(XATR) ;Function . Find an existing u ser.
	3599	"RTN","XUE SSO2",55,0 )
	3600	N OID,UID ,SECID,NPI ,SSN,NEWDU Z,ERRMSG,A OIUID,X,Y, Z
	3601	"RTN","XUE SSO2",56,0 )
	3602	S X=$ST($ ST-1,"PLAC E"),Y=$P(X ,"+"),Z=$P (X,"^",2), X=Y_"^"_$P (Z," ")
	3603	"RTN","XUE SSO2",57,0 )
	3604	I X'="FIN DUSER^XUES SO2" Q "-1 ^Not autho rized"
	3605	"RTN","XUE SSO2",58,0 )
	3606	I $G(DUZ( "LOA"))<2 Q "-1^Not authorized "
	3607	"RTN","XUE SSO2",59,0 )
	3608	S OID=$G( XATR(2))
	3609	"RTN","XUE SSO2",60,0 )
	3610	S UID=$G( XATR(3))
	3611	"RTN","XUE SSO2",61,0 )
	3612	S SECID=$ G(XATR(7))
	3613	"RTN","XUE SSO2",62,0 )
	3614	S NPI=$G( XATR(8))
	3615	"RTN","XUE SSO2",63,0 )
	3616	S SSN=$G( XATR(9))
	3617	"RTN","XUE SSO2",64,0 )
	3618	S ERRMSG= "",NEWDUZ= 0,Y=0
	3619	"RTN","XUE SSO2",65,0 )
	3620	;See if m atch SECID , to be as signed by Identifica tion and A ccess Mana gement (IA M) service s.
	3621	"RTN","XUE SSO2",66,0 )
	3622	I $L(SECI D)>0 D Q: ERRMSG'="" ERRMSG
	3623	"RTN","XUE SSO2",67,0 )
	3624	. S Y=$$S ECMATCH(SE CID) Q:Y<1
	3625	"RTN","XUE SSO2",68,0 )
	3626	. I NPI'= "" D Q:ER RMSG'=""
	3627	"RTN","XUE SSO2",69,0 )
	3628	. . I NPI '=$P($G(^V A(200,Y,"N PI")),U) S ERRMSG="- 1^NPI mism atch for u ser ID'd b y SecID" Q
	3629	"RTN","XUE SSO2",70,0 )
	3630	. I SSN'= "" D Q:ER RMSG'=""
	3631	"RTN","XUE SSO2",71,0 )
	3632	. . I SSN '=$P($G(^V A(200,Y,1) ),U,9) S E RRMSG="-1^ SSN mismat ch for use r ID'd by SecID" Q
	3633	"RTN","XUE SSO2",72,0 )
	3634	. S NEWDU Z=Y
	3635	"RTN","XUE SSO2",73,0 )
	3636	. S ERRMS G=$$UPDU(. XATR,NEWDU Z) ; Updat e fields i f changes are needed
	3637	"RTN","XUE SSO2",74,0 )
	3638	. Q
	3639	"RTN","XUE SSO2",75,0 )
	3640	I NEWDUZ> 0 Q NEWDUZ ;Quit her e if we fo und a matc h on SECID
	3641	"RTN","XUE SSO2",76,0 )
	3642	;See if m atch NPI
	3643	"RTN","XUE SSO2",77,0 )
	3644	I $L(NPI) >0 D Q:ER RMSG'="" E RRMSG
	3645	"RTN","XUE SSO2",78,0 )
	3646	. S Y=+$O (^VA(200," ANPI",NPI, 0)) Q:Y<1
	3647	"RTN","XUE SSO2",79,0 )
	3648	. I SECID '="" D Q: ERRMSG'=""
	3649	"RTN","XUE SSO2",80,0 )
	3650	. . I $$S ECMATCH(SE CID)<1 S E RRMSG="-1^ SecID mism atch for u ser ID'd b y NPI" Q
	3651	"RTN","XUE SSO2",81,0 )
	3652	. I SSN'= "" D Q:ER RMSG'=""
	3653	"RTN","XUE SSO2",82,0 )
	3654	. . I SSN '=$P($G(^V A(200,Y,1) ),U,9) S E RRMSG="-1^ SSN mismat ch for use r ID'd by NPI" Q
	3655	"RTN","XUE SSO2",83,0 )
	3656	. S NEWDU Z=Y
	3657	"RTN","XUE SSO2",84,0 )
	3658	. S ERRMS G=$$UPDU(. XATR,NEWDU Z) ; Updat e fields i f changes are needed
	3659	"RTN","XUE SSO2",85,0 )
	3660	. Q
	3661	"RTN","XUE SSO2",86,0 )
	3662	I NEWDUZ> 0 Q NEWDUZ ;Quit her e if we fo und a matc h on NPI
	3663	"RTN","XUE SSO2",87,0 )
	3664	;See if m atch SSN
	3665	"RTN","XUE SSO2",88,0 )
	3666	I $L(SSN) >0 D Q:ER RMSG'="" E RRMSG
	3667	"RTN","XUE SSO2",89,0 )
	3668	. S Y=+$O (^VA(200," SSN",SSN,0 )) Q:Y<1
	3669	"RTN","XUE SSO2",90,0 )
	3670	. I SECID '="" D Q: ERRMSG'=""
	3671	"RTN","XUE SSO2",91,0 )
	3672	. . I $$S ECMATCH(SE CID)<1 S E RRMSG="-1^ SecID mism atch for u ser ID'd b y SSN" Q
	3673	"RTN","XUE SSO2",92,0 )
	3674	. I NPI'= "" D Q:ER RMSG'=""
	3675	"RTN","XUE SSO2",93,0 )
	3676	. . I NPI '=$P($G(^V A(200,Y,"N PI")),U) S ERRMSG="- 1^NPI mism atch for u ser ID'd b y SSN" Q
	3677	"RTN","XUE SSO2",94,0 )
	3678	. S NEWDU Z=Y
	3679	"RTN","XUE SSO2",95,0 )
	3680	. S ERRMS G=$$UPDU(. XATR,NEWDU Z) ; Updat e fields i f changes are needed
	3681	"RTN","XUE SSO2",96,0 )
	3682	. Q
	3683	"RTN","XUE SSO2",97,0 )
	3684	I NEWDUZ> 0 Q NEWDUZ ;Quit her e if we fo und a matc h on SSN
	3685	"RTN","XUE SSO2",98,0 )
	3686	;See if m atch OID+U ID ("AOIUI D" cross-r eference).
	3687	"RTN","XUE SSO2",99,0 )
	3688	S Y=$$AOI UID(OID,UI D) I Y>0 D Q:ERRMSG '="" ERRMS G
	3689	"RTN","XUE SSO2",100, 0)
	3690	. I SECID '="" D Q: ERRMSG'=""
	3691	"RTN","XUE SSO2",101, 0)
	3692	. . I $$S ECMATCH(SE CID)<1 S E RRMSG="-1^ SecID mism atch for u ser ID'd b y OID+UID" Q
	3693	"RTN","XUE SSO2",102, 0)
	3694	. I NPI'= "" D Q:ER RMSG'=""
	3695	"RTN","XUE SSO2",103, 0)
	3696	. . I NPI '=$P($G(^V A(200,Y,"N PI")),U) S ERRMSG="- 1^NPI mism atch for u ser ID'd b y OID+UID" Q
	3697	"RTN","XUE SSO2",104, 0)
	3698	. I SSN'= "" D Q:ER RMSG'=""
	3699	"RTN","XUE SSO2",105, 0)
	3700	. . I SSN '=$P($G(^V A(200,Y,1) ),U,9) S E RRMSG="-1^ SSN mismat ch for use r ID'd by OID+UID" Q
	3701	"RTN","XUE SSO2",106, 0)
	3702	. S NEWDU Z=Y
	3703	"RTN","XUE SSO2",107, 0)
	3704	. S ERRMS G=$$UPDU(. XATR,NEWDU Z) ; Updat e fields i f changes are needed
	3705	"RTN","XUE SSO2",108, 0)
	3706	. Q
	3707	"RTN","XUE SSO2",109, 0)
	3708	I NEWDUZ> 0 Q NEWDUZ ;Quit her e if we fo und a matc h on OID+U ID
	3709	"RTN","XUE SSO2",110, 0)
	3710	Q "-1^Use r not foun d"
	3711	"RTN","XUE SSO2",111, 0)
	3712	;
	3713	"RTN","XUE SSO2",112, 0)
	3714	ADDUSER(XA TR) ;Funct ion. Add u ser using minimum at tributes f or user id entificati on
	3715	"RTN","XUE SSO2",113, 0)
	3716	; Input: XATR = Array con taining us er attribu tes (see a bove).
	3717	"RTN","XUE SSO2",114, 0)
	3718	; Return: Fail = "-1^Error Message"
	3719	"RTN","XUE SSO2",115, 0)
	3720	; Success = IEN of NE W PERSON f ile (#200) entry (No te: this r outine wil l NOT set DUZ to the identifie d IEN)
	3721	"RTN","XUE SSO2",116, 0)
	3722	;
	3723	"RTN","XUE SSO2",117, 0)
	3724	N SID,NEW DUZ,ERRMSG
	3725	"RTN","XUE SSO2",118, 0)
	3726	I '$$AUTH () Q "-1^N ot an auth orized cal ling routi ne"
	3727	"RTN","XUE SSO2",119, 0)
	3728	I $G(DUZ( "LOA"))<2 Q "-1^Not authorized "
	3729	"RTN","XUE SSO2",120, 0)
	3730	S ERRMSG= ""
	3731	"RTN","XUE SSO2",121, 0)
	3732	;Minimum 4 Attribut es are req uired to a dd a new u ser
	3733	"RTN","XUE SSO2",122, 0)
	3734	I $G(XATR (1))="" Q "-1^Subjec t Organiza tion is re quired to add a new user"
	3735	"RTN","XUE SSO2",123, 0)
	3736	I $G(XATR (2))="" Q "-1^Subjec t Organiza tion ID is required to add a n ew user"
	3737	"RTN","XUE SSO2",124, 0)
	3738	I $G(XATR (3))="" Q "-1^Unique User ID i s required to add a new user"
	3739	"RTN","XUE SSO2",125, 0)
	3740	I $G(XATR (4))="" Q "-1^Subjec t ID is re quired to add a new user"
	3741	"RTN","XUE SSO2",126, 0)
	3742	; Format user attri butes to m atch FileM an fields
	3743	"RTN","XUE SSO2",127, 0)
	3744	S XATR(1) =$$TITLE^X LFSTR($E($ G(XATR(1)) ,1,50)) ; Subject Or ganization
	3745	"RTN","XUE SSO2",128, 0)
	3746	S XATR(2) =$$LOW^XLF STR($E($G( XATR(2)),1 ,50)) ; Subject Or ganization ID
	3747	"RTN","XUE SSO2",129, 0)
	3748	S XATR(3) =$TR($$LOW ^XLFSTR($E ($G(XATR(3 )),1,40)), "^","%") ; Unique Use r ID
	3749	"RTN","XUE SSO2",130, 0)
	3750	I $G(XATR (4))'="" D Q:ERRMSG '="" ERRMS G
	3751	"RTN","XUE SSO2",131, 0)
	3752	. S SID=X ATR(4) S X ATR(4)=$$F ORMAT^XLFN AME7(.SID, 3,35,,0,,, 2) ; Subje ct ID conv erted to s tandard fo rmat
	3753	"RTN","XUE SSO2",132, 0)
	3754	. I $G(XA TR(4))'?1U .E1","1U.E S ERRMSG= "-1^Subjec t ID could not be co nverted to 'LAST,FIR ST MIDDLE SUFFIX' Vi stA standa rd format"
	3755	"RTN","XUE SSO2",133, 0)
	3756	S XATR(6) =$$UP^XLFS TR($E($G(X ATR(6)),1, 15)) ; AD Network Username
	3757	"RTN","XUE SSO2",134, 0)
	3758	S XATR(7) =$TR($E($G (XATR(7)), 1,40),"^", "%") ; SecID
	3759	"RTN","XUE SSO2",135, 0)
	3760	S NEWDUZ= $$ADDU(XAT R(4)) ;Put the name in the .01 field fir st
	3761	"RTN","XUE SSO2",136, 0)
	3762	I +NEWDUZ <1 Q "-1^C reate of n ew user re cord faile d"
	3763	"RTN","XUE SSO2",137, 0)
	3764	S ERRMSG= $$UPDU(.XA TR,NEWDUZ) ;Then upd ate the re maining fi elds
	3765	"RTN","XUE SSO2",138, 0)
	3766	I +ERRMSG <0 D CLEAN (NEWDUZ) Q ERRMSG ;D elete the added user if update fails (in complete r ecord)
	3767	"RTN","XUE SSO2",139, 0)
	3768	I +NEWDUZ <1 Q "-1^C reate or u pdate of u ser record failed"
	3769	"RTN","XUE SSO2",140, 0)
	3770	Q NEWDUZ ;Every th ing OK
	3771	"RTN","XUE SSO2",141, 0)
	3772	;
	3773	"RTN","XUE SSO2",142, 0)
	3774	SECMATCH(S ECID) ;Fun ction. Fin d match fo r SECID.
	3775	"RTN","XUE SSO2",143, 0)
	3776	N W,Y,Z
	3777	"RTN","XUE SSO2",144, 0)
	3778	I $G(SECI D)="" Q ""
	3779	"RTN","XUE SSO2",145, 0)
	3780	S W=$E(SE CID,1,30), Y=0,Z=0
	3781	"RTN","XUE SSO2",146, 0)
	3782	F D Q:Y =""
	3783	"RTN","XUE SSO2",147, 0)
	3784	. S Y=$O( ^VA(200,"A SECID",$G( SECID),Y))
	3785	"RTN","XUE SSO2",148, 0)
	3786	. I Y>0 D Q
	3787	"RTN","XUE SSO2",149, 0)
	3788	. . I SEC ID=$P($G(^ VA(200,Y,2 05)),U,1) S Z=Y,Y=""
	3789	"RTN","XUE SSO2",150, 0)
	3790	Q Z
	3791	"RTN","XUE SSO2",151, 0)
	3792	;
	3793	"RTN","XUE SSO2",152, 0)
	3794	UPNMATCH(A DUPN) ;Fun ction. Fin d match fo r ADUPN.
	3795	"RTN","XUE SSO2",153, 0)
	3796	N W,Y,Z
	3797	"RTN","XUE SSO2",154, 0)
	3798	I $G(ADUP N)="" Q ""
	3799	"RTN","XUE SSO2",155, 0)
	3800	S W=$E(AD UPN,1,30), Y=0,Z=0
	3801	"RTN","XUE SSO2",156, 0)
	3802	F D Q:Y =""
	3803	"RTN","XUE SSO2",157, 0)
	3804	. S Y=$O( ^VA(200,"A DUPN",$G(A DUPN),Y))
	3805	"RTN","XUE SSO2",158, 0)
	3806	. I Y>0 D Q
	3807	"RTN","XUE SSO2",159, 0)
	3808	. . I ADU PN=$P($G(^ VA(200,Y,2 05)),U,5) S Z=Y,Y=""
	3809	"RTN","XUE SSO2",160, 0)
	3810	Q Z
	3811	"RTN","XUE SSO2",161, 0)
	3812	;
	3813	"RTN","XUE SSO2",162, 0)
	3814	AOIUID(OID ,UID) ;Fun ction. Fin d match fo r OID+UID cross-refe rence.
	3815	"RTN","XUE SSO2",163, 0)
	3816	N W,X,Y,Z
	3817	"RTN","XUE SSO2",164, 0)
	3818	I ($G(OID )="")!($G( UID)="") Q ""
	3819	"RTN","XUE SSO2",165, 0)
	3820	S W=$E(OI D,1,30),X= $E(UID,1,3 0),Y=0,Z=0
	3821	"RTN","XUE SSO2",166, 0)
	3822	F D Q:Y =""
	3823	"RTN","XUE SSO2",167, 0)
	3824	. S Y=$O( ^VA(200,"A OIUID",W,X ,Y))
	3825	"RTN","XUE SSO2",168, 0)
	3826	. I Y>0 D Q
	3827	"RTN","XUE SSO2",169, 0)
	3828	. . I (OI D=$P($G(^V A(200,Y,20 5)),U,3))& (UID=$P($G (^VA(200,Y ,205)),U,4 )) S Z=Y,Y =""
	3829	"RTN","XUE SSO2",170, 0)
	3830	Q Z
	3831	"RTN","XUE SSO2",171, 0)
	3832	;
	3833	"RTN","XUE SSO2",172, 0)
	3834	ADDU(XUNAM E) ;Functi on. Add a new name t o the NPF
	3835	"RTN","XUE SSO2",173, 0)
	3836	N DD,DO,D IC,DA,X,Y, DUZZERO
	3837	"RTN","XUE SSO2",174, 0)
	3838	K ^TMP("D IERR",$J)
	3839	"RTN","XUE SSO2",175, 0)
	3840	S DIC="^V A(200,",DI C(0)="F",X =XUNAME
	3841	"RTN","XUE SSO2",176, 0)
	3842	; Get a L OCK. Block if can't get.
	3843	"RTN","XUE SSO2",177, 0)
	3844	L +^VA(20 0,"HL7"):1 0 Q:'$T "- 1^Addition of new us ers is blo cked"
	3845	"RTN","XUE SSO2",178, 0)
	3846	S DUZZERO =DUZ(0),DU Z(0)="@" ; Make sure we can add the entry
	3847	"RTN","XUE SSO2",179, 0)
	3848	D FILE^DI CN
	3849	"RTN","XUE SSO2",180, 0)
	3850	S DUZ(0)= DUZZERO ;R estore ori ginal FM a ccess
	3851	"RTN","XUE SSO2",181, 0)
	3852	L -^VA(20 0,"HL7")
	3853	"RTN","XUE SSO2",182, 0)
	3854	Q +Y
	3855	"RTN","XUE SSO2",183, 0)
	3856	;
	3857	"RTN","XUE SSO2",184, 0)
	3858	UPDU(XATR, NEWDUZ) ;F unction. U pdate user in the NP F
	3859	"RTN","XUE SSO2",185, 0)
	3860	N DUZZERO ,DIC,ERRMS G,FDR,IEN, XUCODE,XUE NTRY
	3861	"RTN","XUE SSO2",186, 0)
	3862	K ^TMP("D IERR",$J)
	3863	"RTN","XUE SSO2",187, 0)
	3864	S DIC(0)= "",ERRMSG= ""
	3865	"RTN","XUE SSO2",188, 0)
	3866	S IEN=NEW DUZ_","
	3867	"RTN","XUE SSO2",189, 0)
	3868	I ($G(XAT R(1))'="") &($P($G(^V A(200,NEWD UZ,205)),U ,2)="") S FDR(200,IE N,205.2)=$ $TITLE^XLF STR($E($G( XATR(1)),1 ,50)) ;Ad d SORG if missing
	3869	"RTN","XUE SSO2",190, 0)
	3870	I ($G(XAT R(2))'="") &($P($G(^V A(200,NEWD UZ,205)),U ,3)="") S FDR(200,IE N,205.3)=$ $LOW^XLFST R($E($G(XA TR(2)),1,5 0)) ;Ad d OID if m issing
	3871	"RTN","XUE SSO2",191, 0)
	3872	I ($G(XAT R(3))'="") &($P($G(^V A(200,NEWD UZ,205)),U ,4)="") S FDR(200,IE N,205.4)=$ TR($$LOW^X LFSTR($E($ G(XATR(3)) ,1,40)),"^ ","%") ;Ad d UID if m issing
	3873	"RTN","XUE SSO2",192, 0)
	3874	I ($G(XAT R(6))'="") &($P($G(^V A(200,NEWD UZ,501)),U ,1)="") S FDR(200,IE N,501.1)=$ $UP^XLFSTR ($E($G(XAT R(6)),1,15 )) ;Ad d NETWORK USERNAME i f missing
	3875	"RTN","XUE SSO2",193, 0)
	3876	I ($G(XAT R(7))'="") &($P($G(^V A(200,NEWD UZ,205)),U ,1)="") S FDR(200,IE N,205.1)=$ TR($E($G(X ATR(7)),1, 40),"^","% ") ;Ad d SecID if missing
	3877	"RTN","XUE SSO2",194, 0)
	3878	I ($G(XAT R(8))'="") &($P($G(^V A(200,NEWD UZ,"NPI")) ,U,1)="") S FDR(200, IEN,41.99) =$G(XATR(8 )) ;Ad d NPI if m issing
	3879	"RTN","XUE SSO2",195, 0)
	3880	I ($G(XAT R(9))'="") &($P($G(^V A(200,NEWD UZ,1)),U,9 )="") D Q :ERRMSG'=" " ERRMSG ;Ad d SSN if m issing
	3881	"RTN","XUE SSO2",196, 0)
	3882	. S ERRMS G=$$ADDS(. FDR,NEWDUZ ,$G(XATR(9 )))
	3883	"RTN","XUE SSO2",197, 0)
	3884	. I ERRMS G'="" Q
	3885	"RTN","XUE SSO2",198, 0)
	3886	I ($G(XAT R(10))'="" )&($P($G(^ VA(200,NEW DUZ,205)), U,5)="") S FDR(200,I EN,205.5)= $$LOW^XLFS TR($G(XATR (10))) ;Ad d ADUPN if missing
	3887	"RTN","XUE SSO2",199, 0)
	3888	I ($G(XAT R(11))'="" )&($P($G(^ VA(200,NEW DUZ,.15)), U,1)="") S FDR(200,I EN,.151)=$ $LOW^XLFST R($G(XATR( 11))) ;Ad d e-mail i f missing
	3889	"RTN","XUE SSO2",200, 0)
	3890	I $G(XATR (5))'="" D Q:ERRMSG '="" ERRMS G ;Assign Context O ption
	3891	"RTN","XUE SSO2",201, 0)
	3892	. S ERRMS G=$$SETCNT XT(NEWDUZ, $G(XATR(5) ))
	3893	"RTN","XUE SSO2",202, 0)
	3894	. I ERRMS G'="" Q
	3895	"RTN","XUE SSO2",203, 0)
	3896	; Apply a ll the cha nges
	3897	"RTN","XUE SSO2",204, 0)
	3898	S DUZZERO =DUZ(0),DU Z(0)="@" ; Make sure we can upd ate the en try
	3899	"RTN","XUE SSO2",205, 0)
	3900	I $D(FDR) K IEN D U PDATE^DIE( "E","FDR", "IEN") ;Fi le all the data
	3901	"RTN","XUE SSO2",206, 0)
	3902	S DUZ(0)= DUZZERO ;R estore ori ginal FM a ccess
	3903	"RTN","XUE SSO2",207, 0)
	3904	I $D(^TMP ("DIERR",$ J)) Q "-1^ FileMan er ror" ;Fil eMan Error
	3905	"RTN","XUE SSO2",208, 0)
	3906	I +ERRMSG <1 Q ERRMS G ;Couldn' t update u ser
	3907	"RTN","XUE SSO2",209, 0)
	3908	I +NEWDUZ <1 Q "-1^U pdate of u ser record failed"
	3909	"RTN","XUE SSO2",210, 0)
	3910	Q ""
	3911	"RTN","XUE SSO2",211, 0)
	3912	;
	3913	"RTN","XUE SSO2",212, 0)
	3914	ADDS(FDR,N EWDUZ,SSN) ;Function . Add a SS N to the N PF
	3915	"RTN","XUE SSO2",213, 0)
	3916	N IEN,ERR MSG
	3917	"RTN","XUE SSO2",214, 0)
	3918	S IEN=NEW DUZ_",",ER RMSG=""
	3919	"RTN","XUE SSO2",215, 0)
	3920	I '$$SSNC HECK^XUESS O1(SSN) Q "-1^SSN is not valid per SSA c riteria"
	3921	"RTN","XUE SSO2",216, 0)
	3922	S FDR(200 ,IEN,9)=SS N
	3923	"RTN","XUE SSO2",217, 0)
	3924	Q ERRMSG
	3925	"RTN","XUE SSO2",218, 0)
	3926	;
	3927	"RTN","XUE SSO2",219, 0)
	3928	CLEAN(Y) ; Subroutine . Clean up (delete) incomplete record in NPF
	3929	"RTN","XUE SSO2",220, 0)
	3930	; ZEXCEPT : DA,DIK
	3931	"RTN","XUE SSO2",221, 0)
	3932	N DUZZERO
	3933	"RTN","XUE SSO2",222, 0)
	3934	S DUZZERO =DUZ(0),DU Z(0)="@" ; Make sure we can upd ate the en try
	3935	"RTN","XUE SSO2",223, 0)
	3936	I +Y>0 D
	3937	"RTN","XUE SSO2",224, 0)
	3938	. K DA,DI K S DIK="^ VA(200,",D A=+Y D ^DI K
	3939	"RTN","XUE SSO2",225, 0)
	3940	S DUZ(0)= DUZZERO ;R estore ori ginal FM a ccess
	3941	"RTN","XUE SSO2",226, 0)
	3942	Q
	3943	"RTN","XUE SSO2",227, 0)
	3944	;
	3945	"RTN","XUE SSO2",228, 0)
	3946	SETCNTXT(N EWDUZ,XAPH RASE) ;Fun ction. Ass ign Contex t Option t o user Sec ondary Men u Options
	3947	"RTN","XUE SSO2",229, 0)
	3948	N OPT,XUE NTRY,XOPT, XUCONTXT,X
	3949	"RTN","XUE SSO2",230, 0)
	3950	S XUENTRY =$$GETCNTX T(XAPHRASE ) I +XUENT RY<0 Q XUE NTRY
	3951	"RTN","XUE SSO2",231, 0)
	3952	S XOPT=$P ($G(^XWB(8 994.5,XUEN TRY,0)),U, 2)
	3953	"RTN","XUE SSO2",232, 0)
	3954	I XOPT'>0 Q "-1^Con text Optio n must be identified in the RE MOTE APPLI CATION fil e"
	3955	"RTN","XUE SSO2",233, 0)
	3956	S XUCONTX T="`"_XOPT
	3957	"RTN","XUE SSO2",234, 0)
	3958	I $$FIND1 ^DIC(19,"" ,"X",XUCON TXT)'>0 Q "-1^Contex t Option n ot in OPTI ON file"
	3959	"RTN","XUE SSO2",235, 0)
	3960	;Have to use $D bec ause of sc reen in 20 0.03 keeps FIND1^DIC from work ing.
	3961	"RTN","XUE SSO2",236, 0)
	3962	I '$D(^VA (200,NEWDU Z,203,"B", XOPT)) D
	3963	"RTN","XUE SSO2",237, 0)
	3964	. ; Have to give th e user a d elegated o ption
	3965	"RTN","XUE SSO2",238, 0)
	3966	. N XARR S XARR(200 .19,"+1,"_ NEWDUZ_"," ,.01)=XUCO NTXT
	3967	"RTN","XUE SSO2",239, 0)
	3968	. D UPDAT E^DIE("E", "XARR")
	3969	"RTN","XUE SSO2",240, 0)
	3970	. ; And n ow user ca n give sel f the cont ext option
	3971	"RTN","XUE SSO2",241, 0)
	3972	. K XARR S XARR(200 .03,"+1,"_ NEWDUZ_"," ,.01)=XUCO NTXT
	3973	"RTN","XUE SSO2",242, 0)
	3974	. D UPDAT E^DIE("E", "XARR") ; Give conte xt option as a secon dary menu item
	3975	"RTN","XUE SSO2",243, 0)
	3976	. ; But n ow we have to remove the deleg ated optio n
	3977	"RTN","XUE SSO2",244, 0)
	3978	. S OPT=$ $FIND1^DIC (200.19,", "_NEWDUZ_" ,","X",XUC ONTXT)
	3979	"RTN","XUE SSO2",245, 0)
	3980	. I OPT>0 D
	3981	"RTN","XUE SSO2",246, 0)
	3982	. . K XAR R S XARR(2 00.19,(OPT _","_NEWDU Z_","),.01 )="@"
	3983	"RTN","XUE SSO2",247, 0)
	3984	. . D FIL E^DIE("E", "XARR")
	3985	"RTN","XUE SSO2",248, 0)
	3986	. . Q
	3987	"RTN","XUE SSO2",249, 0)
	3988	. Q
	3989	"RTN","XUE SSO2",250, 0)
	3990	Q ""
	3991	"RTN","XUE SSO2",251, 0)
	3992	;
	3993	"RTN","XUE SSO2",252, 0)
	3994	GETCNTXT(X APHRASE) ; Function. Identify t he REMOTE APPLICATIO N
	3995	"RTN","XUE SSO2",253, 0)
	3996	N XUCODE, XUENTRY
	3997	"RTN","XUE SSO2",254, 0)
	3998	;Identify Remote Ap plication with SHA25 6 hash
	3999	"RTN","XUE SSO2",255, 0)
	4000	S XUCODE= $$SHAHASH^ XUSHSH(256 ,$G(XAPHRA SE),"B") ; IA #6189
	4001	"RTN","XUE SSO2",256, 0)
	4002	S XUENTRY =$$FIND1^D IC(8994.5, "","X",XUC ODE,"ACODE ")
	4003	"RTN","XUE SSO2",257, 0)
	4004	;If not f ound, chec k with old hash and replace wi th SHA256 hash if fo und
	4005	"RTN","XUE SSO2",258, 0)
	4006	I XUENTRY '>0 D
	4007	"RTN","XUE SSO2",259, 0)
	4008	. S XUCOD E=$$EN^XUS HSH($G(XAP HRASE)) ; IA #10045
	4009	"RTN","XUE SSO2",260, 0)
	4010	. S XUENT RY=$$FIND1 ^DIC(8994. 5,"","X",X UCODE,"ACO DE")
	4011	"RTN","XUE SSO2",261, 0)
	4012	. I XUENT RY>0 D
	4013	"RTN","XUE SSO2",262, 0)
	4014	. . S XUC ODE=$$SHAH ASH^XUSHSH (256,$G(XA PHRASE),"B ") ; IA #6 189
	4015	"RTN","XUE SSO2",263, 0)
	4016	. . N FDR
	4017	"RTN","XUE SSO2",264, 0)
	4018	. . S FDR (8994.5,XU ENTRY_",", .03)=XUCOD E
	4019	"RTN","XUE SSO2",265, 0)
	4020	. . D FIL E^DIE("E", "FDR")
	4021	"RTN","XUE SSO2",266, 0)
	4022	I XUENTRY '>0 Q "-1^ Applicatio n ID must be registe red in the REMOTE AP PLICATION file"
	4023	"RTN","XUE SSO2",267, 0)
	4024	Q XUENTRY
	4025	"RTN","XUE SSO2",268, 0)
	4026	;
	4027	"RTN","XUE SSO2",269, 0)
	4028	AUTH() ;Fu nction. Ch eck if cal ling routi ne is auth orized
	4029	"RTN","XUE SSO2",270, 0)
	4030	; ^XUESSO 2 does not address t he securit y issue of user auth entication , so a res triction i s placed o n the call ing routin e.
	4031	"RTN","XUE SSO2",271, 0)
	4032	; ZEXCEPT : XTMUNIT, XTU ;set f or unit te sting
	4033	"RTN","XUE SSO2",272, 0)
	4034	N X,Z
	4035	"RTN","XUE SSO2",273, 0)
	4036	S X=$ST($ ST-2,"PLAC E"),Z=$P(X ,"^",2),X= "^"_$P(Z," ")
	4037	"RTN","XUE SSO2",274, 0)
	4038	I $E(X,1, 3)="^XU" Q 1 ;Authori zed Kernel access
	4039	"RTN","XUE SSO2",275, 0)
	4040	I $D(XTMU NIT)!$G(XT U) Q 1 ;Kernel Unit Testi ng
	4041	"RTN","XUE SSO2",276, 0)
	4042	Q 0
	4043	"RTN","XUE SSO2",277, 0)
	4044	;
	4045	"RTN","XUE SSO3")
	4046	0^13^B2219 83051^B206 943521
	4047	"RTN","XUE SSO3",1,0)
	4048	XUESSO3 ;I SD/HGW Enh anced Sing le Sign-On Utilities ;02/25/16 15:33
	4049	"RTN","XUE SSO3",2,0)
	4050	;;8.0;KER NEL;655, 659;Jul 10, 1995;B uild 22
	4051	"RTN","XUE SSO3",3,0)
	4052	;Per VA D irective 6 402, this routine sh ould not b e modified .
	4053	"RTN","XUE SSO3",4,0)
	4054	;
	4055	"RTN","XUE SSO3",5,0)
	4056	Q
	4057	"RTN","XUE SSO3",6,0)
	4058	IAMFU(R,NA ME,SSN,DOB ,ADUPN,SEC ID,AUTHCOD E) ;RPC. X US IAM FIN D USER - I A #6288
	4059	"RTN","XUE SSO3",7,0)
	4060	; The XUS HOWSSN key is requir ed to do l ookups usi ng PII (SS N or DoB).
	4061	"RTN","XUE SSO3",8,0)
	4062	; Input: One or mo re of Name , SSN, DoB , AD UPN, and/or Sec ID must be provided.
	4063	"RTN","XUE SSO3",9,0)
	4064	; AUTHCOD E = Sec urity Phra se for IAM Provision ing Applic ation
	4065	"RTN","XUE SSO3",10,0 )
	4066	; Return: Fail R(0)="-1^ Error Mess age"
	4067	"RTN","XUE SSO3",11,0 )
	4068	; Success R(0)=tota l number o f entries found, fro m "0" to " n".
	4069	"RTN","XUE SSO3",12,0 )
	4070	; R(1) thro ugh R(n)=" DUZ^Name^N ameCompone nts^SSN^Do b^AD UPN^S ecID"
	4071	"RTN","XUE SSO3",13,0 )
	4072	;
	4073	"RTN","XUE SSO3",14,0 )
	4074	; ZEXCEPT : %DT
	4075	"RTN","XUE SSO3",15,0 )
	4076	N X,XARRY ,XCOUNT,XI ,XJ,XNAME, XRESULT,XS HOWSSN,XTE MP,XUENTRY ,XUIAM,Y
	4077	"RTN","XUE SSO3",16,0 )
	4078	K R
	4079	"RTN","XUE SSO3",17,0 )
	4080	I DUZ'>1 S R(0)="-1 ^Unauthori zed access " Q
	4081	"RTN","XUE SSO3",18,0 )
	4082	S XUENTRY =$$GETCNTX T^XUESSO2( $G(AUTHCOD E)) I +XUE NTRY<0 S R (0)=XUENTR Y Q
	4083	"RTN","XUE SSO3",19,0 )
	4084	I $P($G(^ XWB(8994.5 ,XUENTRY,0 )),U)'="IA M PROVISIO NING" S R( 0)="-1^Una uthorized access" Q
	4085	"RTN","XUE SSO3",20,0 )
	4086	S XUIAM=1 ;Do not t rigger IAM updates
	4087	"RTN","XUE SSO3",21,0 )
	4088	S XSHOWSS N=$$KCHK^X USRB("XUSH OWSSN")
	4089	"RTN","XUE SSO3",22,0 )
	4090	S XCOUNT= 0
	4091	"RTN","XUE SSO3",23,0 )
	4092	; 1. Sear ch by NAME
	4093	"RTN","XUE SSO3",24,0 )
	4094	I $G(NAME )'="" D
	4095	"RTN","XUE SSO3",25,0 )
	4096	. D FIND^ DIC(200,"" ,"@","PC", NAME,"*"," B")
	4097	"RTN","XUE SSO3",26,0 )
	4098	. S XI=0 F S XI=$O (^TMP("DIL IST",$J,XI )) Q:'XI D
	4099	"RTN","XUE SSO3",27,0 )
	4100	. . S XRE SULT=$G(^T MP("DILIST ",$J,XI,0) )
	4101	"RTN","XUE SSO3",28,0 )
	4102	. . D:XRE SULT>0 ADD TOLST(.R,. XCOUNT,XSH OWSSN,XRES ULT)
	4103	"RTN","XUE SSO3",29,0 )
	4104	. D CLEAN ^DILF
	4105	"RTN","XUE SSO3",30,0 )
	4106	. K ^TMP( "DILIST",$ J)
	4107	"RTN","XUE SSO3",31,0 )
	4108	; 2. Sear ch by SSN
	4109	"RTN","XUE SSO3",32,0 )
	4110	I ($G(SSN )'="")&($G (XSHOWSSN) =1) D
	4111	"RTN","XUE SSO3",33,0 )
	4112	. S XARRY (9)=SSN
	4113	"RTN","XUE SSO3",34,0 )
	4114	. S XRESU LT=$$FINDU SER^XUESSO 2(.XARRY)
	4115	"RTN","XUE SSO3",35,0 )
	4116	. I +XRES ULT>0 D AD DTOLST(.R, .XCOUNT,XS HOWSSN,XRE SULT)
	4117	"RTN","XUE SSO3",36,0 )
	4118	. K XARRY (9)
	4119	"RTN","XUE SSO3",37,0 )
	4120	; 3. Sear ch by DOB
	4121	"RTN","XUE SSO3",38,0 )
	4122	I ($G(DOB )'="")&($G (XSHOWSSN) =1) D
	4123	"RTN","XUE SSO3",39,0 )
	4124	. S X=DOB ,%DT="X" D ^%DT S X= Y,XRESULT= 0
	4125	"RTN","XUE SSO3",40,0 )
	4126	. F D Q :XRESULT=" "
	4127	"RTN","XUE SSO3",41,0 )
	4128	. . S XRE SULT=$O(^V A(200,XRES ULT)) Q:XR ESULT=""
	4129	"RTN","XUE SSO3",42,0 )
	4130	. . I $P( $G(^VA(200 ,XRESULT,1 )),U,3)=X D ADDTOLST (.R,.XCOUN T,XSHOWSSN ,XRESULT)
	4131	"RTN","XUE SSO3",43,0 )
	4132	; 4. Sear ch by ADUP N
	4133	"RTN","XUE SSO3",44,0 )
	4134	I $G(ADUP N)'="" D
	4135	"RTN","XUE SSO3",45,0 )
	4136	. S X=$$L OW^XLFSTR( ADUPN),XRE SULT=0
	4137	"RTN","XUE SSO3",46,0 )
	4138	. S XRESU LT=$$UPNMA TCH^XUESSO 2(ADUPN)
	4139	"RTN","XUE SSO3",47,0 )
	4140	. I XRESU LT>0 D ADD TOLST(.R,. XCOUNT,XSH OWSSN,XRES ULT)
	4141	"RTN","XUE SSO3",48,0 )
	4142	; 5. Sear ch by SECI D
	4143	"RTN","XUE SSO3",49,0 )
	4144	I $G(SECI D)'="" D
	4145	"RTN","XUE SSO3",50,0 )
	4146	. S XARRY (7)=SECID
	4147	"RTN","XUE SSO3",51,0 )
	4148	. S XRESU LT=$$FINDU SER^XUESSO 2(.XARRY)
	4149	"RTN","XUE SSO3",52,0 )
	4150	. I +XRES ULT>0 D AD DTOLST(.R, .XCOUNT,XS HOWSSN,XRE SULT)
	4151	"RTN","XUE SSO3",53,0 )
	4152	. K XARRY (7)
	4153	"RTN","XUE SSO3",54,0 )
	4154	; 6. Retu rn results
	4155	"RTN","XUE SSO3",55,0 )
	4156	S R(0)=XC OUNT
	4157	"RTN","XUE SSO3",56,0 )
	4158	Q
	4159	"RTN","XUE SSO3",57,0 )
	4160	;
	4161	"RTN","XUE SSO3",58,0 )
	4162	IAMDU(R,DI SPDUZ,AUTH CODE) ;RPC . XUS IAM DISPLAY US ER - IA #6 289
	4163	"RTN","XUE SSO3",59,0 )
	4164	; Input: DISPDUZ = DU Z (IEN) of user to b e displaye d
	4165	"RTN","XUE SSO3",60,0 )
	4166	; AUTHCODE = Se curity Phr ase for IA M Provisio ning Appli cation
	4167	"RTN","XUE SSO3",61,0 )
	4168	; Return: Fail R(0) ="-1 ^Error Mes sage"
	4169	"RTN","XUE SSO3",62,0 )
	4170	; Success R(0) = 1
	4171	"RTN","XUE SSO3",63,0 )
	4172	; R("NAME") = NAME
	4173	"RTN","XUE SSO3",64,0 )
	4174	; R("LASTNA ME") = Fam ily Name
	4175	"RTN","XUE SSO3",65,0 )
	4176	; R("FIRSTN AME") = Gi ven Name
	4177	"RTN","XUE SSO3",66,0 )
	4178	; R("MIDDLE NAME") = M iddle Name
	4179	"RTN","XUE SSO3",67,0 )
	4180	; R("SUFFIX ") = Suffi x(es)
	4181	"RTN","XUE SSO3",68,0 )
	4182	; R("INITIA L") = INIT IAL
	4183	"RTN","XUE SSO3",69,0 )
	4184	; R("TITLE" ) = TITLE
	4185	"RTN","XUE SSO3",70,0 )
	4186	; R("NICK_N AME") = NI CK NAME
	4187	"RTN","XUE SSO3",71,0 )
	4188	; R("SSN") = SSN (<Hi dden> if c aller does not have XUSHOWSSN key)
	4189	"RTN","XUE SSO3",72,0 )
	4190	; R("DOB") = DOB (<Hi dden> if c aller does not have XUSHOWSSN key)
	4191	"RTN","XUE SSO3",73,0 )
	4192	; R("DEGREE ") = DEGRE E
	4193	"RTN","XUE SSO3",74,0 )
	4194	; R("MAIL_C ODE") = MA IL CODE
	4195	"RTN","XUE SSO3",75,0 )
	4196	; R("STATUS ") = $$ACT IVE^XUSER( DISPDUZ)
	4197	"RTN","XUE SSO3",76,0 )
	4198	; R("DISUSE R") = DISU SER
	4199	"RTN","XUE SSO3",77,0 )
	4200	; R("TERMIN ATION_DATE ") = TERMI NATION DAT E
	4201	"RTN","XUE SSO3",78,0 )
	4202	; R("TERMIN ATION_REAS ON") = TER MINATION R EASON
	4203	"RTN","XUE SSO3",79,0 )
	4204	; R("PRIMAR Y_MENU_OPT ION") = PR IMARY MENU OPTION
	4205	"RTN","XUE SSO3",80,0 )
	4206	; R("SECOND ARY_MENU_O PTION",0) = SECONDAR Y MENU OPT ION (numbe r of entri es)
	4207	"RTN","XUE SSO3",81,0 )
	4208	; R("SECOND ARY_MENU_O PTION",1) to R("SECO NDARY_MENU _OPTION",n ) = SECOND ARY MENU O PTION entr ies
	4209	"RTN","XUE SSO3",82,0 )
	4210	; R("FILE_M ANAGER_ACC ESS_CODE") = FILE MA NAGER ACCE SS CODE
	4211	"RTN","XUE SSO3",83,0 )
	4212	; R("DIVISI ON",0) = D IVISION (n umber of e ntries)
	4213	"RTN","XUE SSO3",84,0 )
	4214	; R("DIVISI ON",1) to R("DIVISIO N",n) = DI VISION ent ries
	4215	"RTN","XUE SSO3",85,0 )
	4216	; R("SERVIC E_SECTION" ) = SERVIC E/SECTION
	4217	"RTN","XUE SSO3",86,0 )
	4218	; R("SUBJEC T_ALTERNAT IVE_NAME") = SUBJECT ALTERNATI VE NAME (P IV CARD)
	4219	"RTN","XUE SSO3",87,0 )
	4220	; R("SECID" ) = SECID
	4221	"RTN","XUE SSO3",88,0 )
	4222	; R("ORGANI ZATION_NAM E") = SUBJ ECT ORGANI ZATION
	4223	"RTN","XUE SSO3",89,0 )
	4224	; R("ORGANI ZATION_ID" ) = SUBJEC T ORGANIZA TION ID
	4225	"RTN","XUE SSO3",90,0 )
	4226	; R("UNIQUE _USER_ID") = UNIQUE USER ID
	4227	"RTN","XUE SSO3",91,0 )
	4228	; R("NETWOR K_USER_NAM E") = NETW ORK USERNA ME
	4229	"RTN","XUE SSO3",92,0 )
	4230	; R("AD_UPN ") = ADUPN
	4231	"RTN","XUE SSO3",93,0 )
	4232	; R("EMAIL" ) = EMAIL ADDRESS
	4233	"RTN","XUE SSO3",94,0 )
	4234	; R("GENDER ") = SEX ( M/F)
	4235	"RTN","XUE SSO3",95,0 )
	4236	;
	4237	"RTN","XUE SSO3",96,0 )
	4238	N X,XI,XI EN,XJ,XN,X SHOWSSN,XT ,XT1,XT205 ,XT5,XT501 ,XUENTRY,X UIAM,Y
	4239	"RTN","XUE SSO3",97,0 )
	4240	K R
	4241	"RTN","XUE SSO3",98,0 )
	4242	I DUZ'>1 S R(0)="-1 ^Unauthori zed access " Q
	4243	"RTN","XUE SSO3",99,0 )
	4244	S XUENTRY =$$GETCNTX T^XUESSO2( $G(AUTHCOD E)) I +XUE NTRY<0 S R (0)=XUENTR Y Q
	4245	"RTN","XUE SSO3",100, 0)
	4246	I $P($G(^ XWB(8994.5 ,XUENTRY,0 )),U)'="IA M PROVISIO NING" S R( 0)="-1^Una uthorized access" Q
	4247	"RTN","XUE SSO3",101, 0)
	4248	I $G(DUZ( "LOA"))<2 S R(0)="-1 ^Unauthori zed access " Q
	4249	"RTN","XUE SSO3",102, 0)
	4250	I $G(DISP DUZ)'>0 S R(0)="-1^U ser not se lected" Q
	4251	"RTN","XUE SSO3",103, 0)
	4252	I $G(^VA( 200,DISPDU Z,0))="" S R(0)="-1^ User not f ound" Q
	4253	"RTN","XUE SSO3",104, 0)
	4254	S XUIAM=1 ;Do not t rigger IAM updates
	4255	"RTN","XUE SSO3",105, 0)
	4256	S XSHOWSS N=$$KCHK^X USRB("XUSH OWSSN")
	4257	"RTN","XUE SSO3",106, 0)
	4258	S XT=$G(^ VA(200,DIS PDUZ,0))
	4259	"RTN","XUE SSO3",107, 0)
	4260	S XT1=$G( ^VA(200,DI SPDUZ,1))
	4261	"RTN","XUE SSO3",108, 0)
	4262	S XT5=$G( ^VA(200,DI SPDUZ,5))
	4263	"RTN","XUE SSO3",109, 0)
	4264	S XT205=$ G(^VA(200, DISPDUZ,20 5))
	4265	"RTN","XUE SSO3",110, 0)
	4266	S XT501=$ G(^VA(200, DISPDUZ,50 1))
	4267	"RTN","XUE SSO3",111, 0)
	4268	S R(0)=1
	4269	"RTN","XUE SSO3",112, 0)
	4270	S (XN,R(" NAME"))=$P ($G(XT),U)
	4271	"RTN","XUE SSO3",113, 0)
	4272	S XIEN=DI SPDUZ_","
	4273	"RTN","XUE SSO3",114, 0)
	4274	S X=0 S X =$O(^VA(20 ,"BB",200, .01,XIEN,X )) ;Get NA ME COMPONE NTS
	4275	"RTN","XUE SSO3",115, 0)
	4276	S Y="" I +X>0 S Y=$ G(^VA(20,X ,1))
	4277	"RTN","XUE SSO3",116, 0)
	4278	S R("LAST NAME")=$P( Y,U)
	4279	"RTN","XUE SSO3",117, 0)
	4280	S R("FIRS TNAME")=$P (Y,U,2)
	4281	"RTN","XUE SSO3",118, 0)
	4282	S R("MIDD LENAME")=$ P(Y,U,3)
	4283	"RTN","XUE SSO3",119, 0)
	4284	S R("SUFF IX")=$P(Y, U,4)
	4285	"RTN","XUE SSO3",120, 0)
	4286	S R("INIT IAL")=$P($ G(XT),U,2)
	4287	"RTN","XUE SSO3",121, 0)
	4288	S R("TITL E")="" S X =$P($G(XT) ,U,9)
	4289	"RTN","XUE SSO3",122, 0)
	4290	I $G(X)>0 S R("TITL E")=$P($G( ^DIC(3.1,X ,0)),U)
	4291	"RTN","XUE SSO3",123, 0)
	4292	S R("NICK _NAME")=$P ($G(^VA(20 0,DISPDUZ, .1)),U,4)
	4293	"RTN","XUE SSO3",124, 0)
	4294	S R("SSN" )="<Hidden >" I $G(XS HOWSSN)=1 S R("SSN") =$P($G(XT1 ),U,9)
	4295	"RTN","XUE SSO3",125, 0)
	4296	S R("DOB" )="<Hidden >" I $G(XS HOWSSN)=1 S R("DOB") =$TR($$FMT E^XLFDT($P ($G(XT1),U ,3),"5DZ") ,"/","")
	4297	"RTN","XUE SSO3",126, 0)
	4298	S R("DEGR EE")=$P($G (^VA(200,D ISPDUZ,3.1 )),U,6)
	4299	"RTN","XUE SSO3",127, 0)
	4300	S R("MAIL _CODE")=$P ($G(XT5),U ,2)
	4301	"RTN","XUE SSO3",128, 0)
	4302	S R("STAT US")=$$ACT IVE^XUSER( DISPDUZ) ; Supported IA #2343
	4303	"RTN","XUE SSO3",129, 0)
	4304	S X=$P($G (R("STATUS ")),U,3) I X'="" D
	4305	"RTN","XUE SSO3",130, 0)
	4306	. S X=$TR ($$FMTE^XL FDT(X,"5DZ "),"/","")
	4307	"RTN","XUE SSO3",131, 0)
	4308	. S $P(R( "STATUS"), U,3)=X
	4309	"RTN","XUE SSO3",132, 0)
	4310	S R("DISU SER")=$P($ G(XT),U,7)
	4311	"RTN","XUE SSO3",133, 0)
	4312	S R("TERM INATION_DA TE")=$TR($ $FMTE^XLFD T($P($G(XT ),U,11),"5 DZ"),"/"," ")
	4313	"RTN","XUE SSO3",134, 0)
	4314	S R("TERM INATION_RE ASON")=$P( $G(XT),U,1 3)
	4315	"RTN","XUE SSO3",135, 0)
	4316	S R("PRIM ARY_MENU_O PTION")=$P ($G(^VA(20 0,DISPDUZ, 201)),U)
	4317	"RTN","XUE SSO3",136, 0)
	4318	I $G(R("P RIMARY_MEN U_OPTION") )>0 S R("P RIMARY_MEN U_OPTION") =$P($G(^DI C(19,R("PR IMARY_MENU _OPTION"), 0)),U)
	4319	"RTN","XUE SSO3",137, 0)
	4320	S (XI,XJ) =0
	4321	"RTN","XUE SSO3",138, 0)
	4322	I $G(^VA( 200,DISPDU Z,203,0))' ="" F D Q:+XI'>0
	4323	"RTN","XUE SSO3",139, 0)
	4324	. S XI=$O (^VA(200,D ISPDUZ,203 ,XI)) Q:+X I'>0
	4325	"RTN","XUE SSO3",140, 0)
	4326	. S XJ=XJ +1,R("SECO NDARY_MENU _OPTION",X J)=$P($G(^ VA(200,DIS PDUZ,203,X I,0)),U)
	4327	"RTN","XUE SSO3",141, 0)
	4328	. I $G(R( "SECONDARY _MENU_OPTI ON",XJ))>0 S R("SECO NDARY_MENU _OPTION",X J)=$P($G(^ DIC(19,R(" SECONDARY_ MENU_OPTIO N",XJ),0)) ,U)
	4329	"RTN","XUE SSO3",142, 0)
	4330	S R("SECO NDARY_MENU _OPTION",0 )=XJ ;numb er of entr ies
	4331	"RTN","XUE SSO3",143, 0)
	4332	S R("FILE _MANAGER_A CCESS_CODE ")=$P($G(X T),U,4)
	4333	"RTN","XUE SSO3",144, 0)
	4334	S (XI,XJ) =0
	4335	"RTN","XUE SSO3",145, 0)
	4336	I $G(^VA( 200,DISPDU Z,2,0))'=" " F D Q: +XI'>0
	4337	"RTN","XUE SSO3",146, 0)
	4338	. S XI=$O (^VA(200,D ISPDUZ,2,X I)) Q:+XI' >0
	4339	"RTN","XUE SSO3",147, 0)
	4340	. S XJ=XJ +1,R("DIVI SION",XJ)= $P($G(^VA( 200,DISPDU Z,2,XI,0)) ,U)
	4341	"RTN","XUE SSO3",148, 0)
	4342	. I $G(R( "DIVISION" ,XJ))>0 S R("DIVISIO N",XJ)=$P( $G(^DIC(4, R("DIVISIO N",XJ),99) ),U)
	4343	"RTN","XUE SSO3",149, 0)
	4344	S R("DIVI SION",0)=X J ;number of entries
	4345	"RTN","XUE SSO3",150, 0)
	4346	S R("SERV ICE_SECTIO N")=$P($G( XT5),U,1)
	4347	"RTN","XUE SSO3",151, 0)
	4348	I $G(R("S ERVICE_SEC TION"))>0 S R("SERVI CE_SECTION ")=$P($G(^ DIC(49,R(" SERVICE_SE CTION"),0) ),U)
	4349	"RTN","XUE SSO3",152, 0)
	4350	S R("SUBJ ECT_ALTERN ATIVE_NAME ")=$P($G(X T501),U,2)
	4351	"RTN","XUE SSO3",153, 0)
	4352	S R("SECI D")=$TR($P ($G(XT205) ,U),"%","^ ")
	4353	"RTN","XUE SSO3",154, 0)
	4354	S R("ORGA NIZATION_N AME")=$P($ G(XT205),U ,2)
	4355	"RTN","XUE SSO3",155, 0)
	4356	S R("ORGA NIZATION_I D")=$P($G( XT205),U,3 )
	4357	"RTN","XUE SSO3",156, 0)
	4358	S R("UNIQ UE_USER_ID ")=$P($G(X T205),U,4)
	4359	"RTN","XUE SSO3",157, 0)
	4360	S R("NETW ORK_USER_N AME")=$P($ G(XT501),U )
	4361	"RTN","XUE SSO3",158, 0)
	4362	S R("AD_U PN")=$P($G (XT205),U, 5)
	4363	"RTN","XUE SSO3",159, 0)
	4364	S R("EMAI L")=$P($G( ^VA(200,DI SPDUZ,.15) ),U)
	4365	"RTN","XUE SSO3",160, 0)
	4366	S R("GEND ER")=$P($G (XT1),U,2)
	4367	"RTN","XUE SSO3",161, 0)
	4368	Q
	4369	"RTN","XUE SSO3",162, 0)
	4370	;
	4371	"RTN","XUE SSO3",163, 0)
	4372	IAMAU(R,NA ME,SECID,E MAIL,ADUPN ,SSN,DOB,S TATION,AUT HCODE) ;RP C. XUS IAM ADD USER - IA #6290
	4373	"RTN","XUE SSO3",164, 0)
	4374	; The XUS PF200 secu rity key i s required to add a user witho ut an SSN (file #200 special p rivileges) .
	4375	"RTN","XUE SSO3",165, 0)
	4376	; Input: NAME = Subject ID to be u sed in SAM L Token
	4377	"RTN","XUE SSO3",166, 0)
	4378	; SECID = UniqueU serID to b e used in SSOi or SS Oe SAML To ken
	4379	"RTN","XUE SSO3",167, 0)
	4380	; EMAIL = User's e-mail add ress
	4381	"RTN","XUE SSO3",168, 0)
	4382	; ADUPN = Active Directory User Princ iple Name
	4383	"RTN","XUE SSO3",169, 0)
	4384	; SSN = User's Social Sec urity Numb er or Taxp ayer Ident ification Number
	4385	"RTN","XUE SSO3",170, 0)
	4386	; DOB = User's Date of Bi rth
	4387	"RTN","XUE SSO3",171, 0)
	4388	; STATION = NEW PER SON file ( #200) DIVI SION
	4389	"RTN","XUE SSO3",172, 0)
	4390	; AUTHCODE = (Requir ed) Securi ty Phrase for IAM Pr ovisioning Applicati on
	4391	"RTN","XUE SSO3",173, 0)
	4392	; Return: Fail R (0) = "-1^Number of Errors "
	4393	"RTN","XUE SSO3",174, 0)
	4394	; R (1) throug h R(n) = "Error Mes sage"
	4395	"RTN","XUE SSO3",175, 0)
	4396	; Success R (0) = "DUZ^STATI ON"
	4397	"RTN","XUE SSO3",176, 0)
	4398	;
	4399	"RTN","XUE SSO3",177, 0)
	4400	; ZEXCEPT : %DT,DA,D IERR,DIK ; FileMan sp ecial vari ables
	4401	"RTN","XUE SSO3",178, 0)
	4402	N DIC,DUZ ZERO,ERRMS G,FDR,IEN, NEWDUZ,X,X ARRAY,XDIV ,XUENTRY,X UIAM,Y
	4403	"RTN","XUE SSO3",179, 0)
	4404	K R
	4405	"RTN","XUE SSO3",180, 0)
	4406	S R(0)=0
	4407	"RTN","XUE SSO3",181, 0)
	4408	I DUZ'>1 D EDITERR( .R,"Unauth orized acc ess") Q
	4409	"RTN","XUE SSO3",182, 0)
	4410	I +$$ACTI VE^XUSER(D UZ)=0 D ED ITERR(.R," Unauthoriz ed access" ) Q
	4411	"RTN","XUE SSO3",183, 0)
	4412	I $G(DUZ( "LOA"))<2 D EDITERR( .R,"Unauth orized acc ess") Q
	4413	"RTN","XUE SSO3",184, 0)
	4414	S XUIAM=1 ;Do not t rigger IAM updates
	4415	"RTN","XUE SSO3",185, 0)
	4416	I ($G(SSN )'>1)&('$$ KCHK^XUSRB ("XUSPF200 ")) D EDIT ERR(.R,"Ne ed XUSPF20 0 key if n o SSN") Q
	4417	"RTN","XUE SSO3",186, 0)
	4418	S XUENTRY =$$GETCNTX T^XUESSO2( $G(AUTHCOD E)) I +XUE NTRY<0 D E DITERR(.R, XUENTRY) Q
	4419	"RTN","XUE SSO3",187, 0)
	4420	I $P($G(^ XWB(8994.5 ,XUENTRY,0 )),U)'="IA M PROVISIO NING" D ED ITERR(.R," Unauthoriz ed access" ) Q
	4421	"RTN","XUE SSO3",188, 0)
	4422	I $G(NAME )="" D EDI TERR(.R,"M issing Sub jectID") Q
	4423	"RTN","XUE SSO3",189, 0)
	4424	I $G(SECI D)="" D ED ITERR(.R," Missing Se cID") Q
	4425	"RTN","XUE SSO3",190, 0)
	4426	S Y=$$SEC MATCH^XUES SO2(SECID) I Y>0 D E DITERR(.R, "User with given Sec ID already exists") Q
	4427	"RTN","XUE SSO3",191, 0)
	4428	I $G(SSN) >1 S Y=+$O (^VA(200," SSN",SSN,0 ))
	4429	"RTN","XUE SSO3",192, 0)
	4430	I Y>0 D E DITERR(.R, "User with given SSN already e xists") Q
	4431	"RTN","XUE SSO3",193, 0)
	4432	I ($G(SSN )>1)&('$$S SNCHECK^XU ESSO1($G(S SN))) D ED ITERR(.R," Invalid SS N") Q
	4433	"RTN","XUE SSO3",194, 0)
	4434	I $G(DOB) '="" D Q: Y=-1
	4435	"RTN","XUE SSO3",195, 0)
	4436	. S X=DOB S %DT="X" D ^%DT I Y=-1 D EDI TERR(.R,"I nvalid DOB ") Q
	4437	"RTN","XUE SSO3",196, 0)
	4438	. S DOB=$ G(Y)
	4439	"RTN","XUE SSO3",197, 0)
	4440	I $G(STAT ION)'="" D Q:Y=""
	4441	"RTN","XUE SSO3",198, 0)
	4442	. S Y="" S Y=$O(^DI C(4,"D",$G (STATION), Y))
	4443	"RTN","XUE SSO3",199, 0)
	4444	. I Y="" D EDITERR( .R,"-1^Inv alid STATI ON") Q
	4445	"RTN","XUE SSO3",200, 0)
	4446	. S XDIV= $P($G(^DIC (4,Y,0)),U ,1)
	4447	"RTN","XUE SSO3",201, 0)
	4448	S XARRAY( 1)=$P($G(^ XTV(8989.3 ,1,200)),U ,2)
	4449	"RTN","XUE SSO3",202, 0)
	4450	S XARRAY( 2)=$P($G(^ XTV(8989.3 ,1,200)),U ,3)
	4451	"RTN","XUE SSO3",203, 0)
	4452	S XARRAY( 3)=SECID
	4453	"RTN","XUE SSO3",204, 0)
	4454	S XARRAY( 4)=NAME
	4455	"RTN","XUE SSO3",205, 0)
	4456	S XARRAY( 7)=SECID
	4457	"RTN","XUE SSO3",206, 0)
	4458	S XARRAY( 9)=$G(SSN)
	4459	"RTN","XUE SSO3",207, 0)
	4460	S Y=$$ADD USER^XUESS O2(.XARRAY ) ;Add the user
	4461	"RTN","XUE SSO3",208, 0)
	4462	I +Y<0 D EDITERR(.R ,Y) Q
	4463	"RTN","XUE SSO3",209, 0)
	4464	S NEWDUZ= Y
	4465	"RTN","XUE SSO3",210, 0)
	4466	;Use FM c alls to ed it the use r with the remaining informati on
	4467	"RTN","XUE SSO3",211, 0)
	4468	K ^TMP("D IERR",$J)
	4469	"RTN","XUE SSO3",212, 0)
	4470	S DIC(0)= "",ERRMSG= ""
	4471	"RTN","XUE SSO3",213, 0)
	4472	S IEN=NEW DUZ_","
	4473	"RTN","XUE SSO3",214, 0)
	4474	I $G(EMAI L)'="" S F DR(200,IEN ,.151)=$$L OW^XLFSTR( EMAIL)
	4475	"RTN","XUE SSO3",215, 0)
	4476	I $G(ADUP N)'="" S F DR(200,IEN ,205.5)=$$ LOW^XLFSTR (ADUPN)
	4477	"RTN","XUE SSO3",216, 0)
	4478	I $G(DOB) '="" S FDR (200,IEN,5 )=DOB
	4479	"RTN","XUE SSO3",217, 0)
	4480	I $G(XDIV )'="" S FD R(200.02," +3,"_IEN,. 01)=XDIV
	4481	"RTN","XUE SSO3",218, 0)
	4482	; Apply a ll the cha nges: File valid val ues and re ject inval id values.
	4483	"RTN","XUE SSO3",219, 0)
	4484	S DUZZERO =DUZ(0),DU Z(0)="@"
	4485	"RTN","XUE SSO3",220, 0)
	4486	I $D(FDR) K IEN D U PDATE^DIE( "E","FDR", "IEN") ;Fi le all the data
	4487	"RTN","XUE SSO3",221, 0)
	4488	S DUZ(0)= DUZZERO ;R estore ori ginal FM a ccess
	4489	"RTN","XUE SSO3",222, 0)
	4490	I $D(DIER R) D
	4491	"RTN","XUE SSO3",223, 0)
	4492	. S Y=0
	4493	"RTN","XUE SSO3",224, 0)
	4494	. F D Q :+Y'>0
	4495	"RTN","XUE SSO3",225, 0)
	4496	. . S Y=$ O(^TMP("DI ERR",$J,Y) ) I +Y>0 W !,$G(^TMP ("DIERR",$ J,Y,"TEXT" ,1))
	4497	"RTN","XUE SSO3",226, 0)
	4498	. . I +Y> 0 D EDITER R(.R,$G(^T MP("DIERR" ,$J,Y,"TEX T",1))) ;F ileMan Err or
	4499	"RTN","XUE SSO3",227, 0)
	4500	. K DA,DI K S DIK="^ VA(200,",D A=NEWDUZ D ^DIK ;Rol lback add if all fie lds could not be fil ed
	4501	"RTN","XUE SSO3",228, 0)
	4502	I +$G(R(0 ))'=-1 S R (0)=NEWDUZ _U_STATION
	4503	"RTN","XUE SSO3",229, 0)
	4504	Q
	4505	"RTN","XUE SSO3",230, 0)
	4506	;
	4507	"RTN","XUE SSO3",231, 0)
	4508	IAMEU(R,IN ARRY,AUTHC ODE) ;RPC. XUS IAM E DIT USER - IA #6291
	4509	"RTN","XUE SSO3",232, 0)
	4510	; The XUS HOWSSN sec urity key is require d to allow edit of P II (SSN an d DoB).
	4511	"RTN","XUE SSO3",233, 0)
	4512	; Input: INARRY("S ECID") = SecID - Us ed to iden tify entry to be edi ted
	4513	"RTN","XUE SSO3",234, 0)
	4514	; INARRAY(" LASTNAME") = User NAME is "LASTNA ME,FIRSTNA ME MIDDLEN AME SUFFIX "
	4515	"RTN","XUE SSO3",235, 0)
	4516	; INARRAY(" FIRSTNAME" )
	4517	"RTN","XUE SSO3",236, 0)
	4518	; INARRAY(" MIDDLENAME ")
	4519	"RTN","XUE SSO3",237, 0)
	4520	; INARRAY(" SUFFIX")
	4521	"RTN","XUE SSO3",238, 0)
	4522	; INARRY("O RGANIZATIO N_NAME")= SUBJECT OR GANIZATION
	4523	"RTN","XUE SSO3",239, 0)
	4524	; INARRY("O RGANIZATIO N_ID") = SUBJECT OR GANIZATION ID
	4525	"RTN","XUE SSO3",240, 0)
	4526	; INARRY("E MAIL") = EMAIL ADDR ESS
	4527	"RTN","XUE SSO3",241, 0)
	4528	; INARRY("A D_UPN") = ADUPN
	4529	"RTN","XUE SSO3",242, 0)
	4530	; INARRY("S SN") = SSN
	4531	"RTN","XUE SSO3",243, 0)
	4532	; INARRY("D OB") = DOB (Date of Birth)
	4533	"RTN","XUE SSO3",244, 0)
	4534	; AUTHCODE = Security P hrase for IAM Provis ioning App lication
	4535	"RTN","XUE SSO3",245, 0)
	4536	; Return: Fail R (0) = "-1^Number of Errors "
	4537	"RTN","XUE SSO3",246, 0)
	4538	; R (1) throug h R(n) = "Error Mes sage"
	4539	"RTN","XUE SSO3",247, 0)
	4540	; Success R (0) = DUZ of NEW PERSON fi le entry t hat was ed ited
	4541	"RTN","XUE SSO3",248, 0)
	4542	;
	4543	"RTN","XUE SSO3",249, 0)
	4544	; ZEXCEPT : %DT,DIER R ;FileMan special v ariables
	4545	"RTN","XUE SSO3",250, 0)
	4546	N DUZZERO ,FDR,IEN,X ,XARRAY,XD UZ,XSHOWSS N,XUENTRY, XUIAM,XUN, XUNAME,XUN EWN,XUOLDN ,Y
	4547	"RTN","XUE SSO3",251, 0)
	4548	K R
	4549	"RTN","XUE SSO3",252, 0)
	4550	S R(0)=0
	4551	"RTN","XUE SSO3",253, 0)
	4552	S XUIAM=1 ;Do not t rigger IAM updates
	4553	"RTN","XUE SSO3",254, 0)
	4554	I DUZ'>1 D EDITERR( .R,"Unauth orized acc ess") Q
	4555	"RTN","XUE SSO3",255, 0)
	4556	I +$$ACTI VE^XUSER(D UZ)=0 D ED ITERR(.R," Unauthoriz ed access" ) Q
	4557	"RTN","XUE SSO3",256, 0)
	4558	S XUENTRY =$$GETCNTX T^XUESSO2( $G(AUTHCOD E)) I +XUE NTRY<0 D E DITERR(.R, $P(XUENTRY ,U,2)) Q
	4559	"RTN","XUE SSO3",257, 0)
	4560	I $P($G(^ XWB(8994.5 ,XUENTRY,0 )),U)'="IA M PROVISIO NING" D ED ITERR(.R," Unauthoriz ed access" ) Q
	4561	"RTN","XUE SSO3",258, 0)
	4562	I $G(DUZ( "LOA"))<2 D EDITERR( .R,"Unauth orized acc ess") Q
	4563	"RTN","XUE SSO3",259, 0)
	4564	I $G(INAR RY("SECID" ))="" D ED ITERR(.R," User not i dentified by SecID") Q
	4565	"RTN","XUE SSO3",260, 0)
	4566	S XARRAY( 7)=INARRY( "SECID")
	4567	"RTN","XUE SSO3",261, 0)
	4568	S XDUZ=$$ SECMATCH^X UESSO2(XAR RAY(7)) I XDUZ'>0 D EDITERR(.R ,"User not found") Q
	4569	"RTN","XUE SSO3",262, 0)
	4570	I $S($P(^ VA(200,XDU Z,0),U,11) :$P(^VA(20 0,XDUZ,0), U,11)<DT,1 :0) D EDIT ERR(.R,"No t allowed to edit te rminated u ser") Q
	4571	"RTN","XUE SSO3",263, 0)
	4572	S XSHOWSS N=$$KCHK^X USRB("XUSH OWSSN")
	4573	"RTN","XUE SSO3",264, 0)
	4574	I ($G(INA RRY("SSN") ))&('XSHOW SSN) D EDI TERR(.R,"X USHOWSSN S ecurity Ke y is requi red to edi t SSN")
	4575	"RTN","XUE SSO3",265, 0)
	4576	I ($G(INA RRY("DOB") ))&('XSHOW SSN) D EDI TERR(.R,"X USHOWSSN S ecurity Ke y is requi red to edi t DOB")
	4577	"RTN","XUE SSO3",266, 0)
	4578	;Use FM c alls to ed it the use r with the remaining informati on
	4579	"RTN","XUE SSO3",267, 0)
	4580	K ^TMP("D IERR",$J)
	4581	"RTN","XUE SSO3",268, 0)
	4582	S IEN=XDU Z_","
	4583	"RTN","XUE SSO3",269, 0)
	4584	S XUN("FI LE")=200,X UN("IENS") =IEN,XUN(" FIELD")=.0 1
	4585	"RTN","XUE SSO3",270, 0)
	4586	S XUOLDN= $$NAMEFMT^ XLFNAME(.X UN,"F","CS ")
	4587	"RTN","XUE SSO3",271, 0)
	4588	K XUN S X UN=XUOLDN
	4589	"RTN","XUE SSO3",272, 0)
	4590	D NAMECOM P^XLFNAME( .XUN)
	4591	"RTN","XUE SSO3",273, 0)
	4592	I $D(INAR RY("LASTNA ME")) S XU N("FAMILY" )=$G(INARR Y("LASTNAM E"))
	4593	"RTN","XUE SSO3",274, 0)
	4594	I $D(INAR RY("FIRSTN AME")) S X UN("GIVEN" )=$G(INARR Y("FIRSTNA ME"))
	4595	"RTN","XUE SSO3",275, 0)
	4596	I $D(INAR RY("MIDDLE NAME")) S XUN("MIDDL E")=$G(INA RRY("MIDDL ENAME"))
	4597	"RTN","XUE SSO3",276, 0)
	4598	I $D(INAR RY("SUFFIX ")) S XUN( "SUFFIX")= $G(INARRY( "SUFFIX"))
	4599	"RTN","XUE SSO3",277, 0)
	4600	S XUNEWN= $$NAMEFMT^ XLFNAME(.X UN,"F","CS ")
	4601	"RTN","XUE SSO3",278, 0)
	4602	I XUNEWN' =XUOLDN S FDR(200,IE N,.01)=XUN EWN ;set N AME if cha nged
	4603	"RTN","XUE SSO3",279, 0)
	4604	I $G(INAR RY("ORGANI ZATION_NAM E"))'="" D
	4605	"RTN","XUE SSO3",280, 0)
	4606	. S X=$$T ITLE^XLFST R($E(INARR Y("ORGANIZ ATION_NAME "),1,50))
	4607	"RTN","XUE SSO3",281, 0)
	4608	. I X'=$P ($G(^VA(20 0,XDUZ,205 )),U,2) S FDR(200,IE N,205.2)=X ;set SUBJ ECT ORGANI ZATION if changed
	4609	"RTN","XUE SSO3",282, 0)
	4610	I $G(INAR RY("ORGANI ZATION_ID" ))'="" D
	4611	"RTN","XUE SSO3",283, 0)
	4612	. S X=$$L OW^XLFSTR( $E(INARRY( "ORGANIZAT ION_ID"),1 ,50))
	4613	"RTN","XUE SSO3",284, 0)
	4614	. I X'=$P ($G(^VA(20 0,XDUZ,205 )),U,3) S FDR(200,IE N,205.3)=X ;set SUBJ ECT ORGANI ZATION ID if changed
	4615	"RTN","XUE SSO3",285, 0)
	4616	I $G(INAR RY("EMAIL" ))'="" D
	4617	"RTN","XUE SSO3",286, 0)
	4618	. S X=$$L OW^XLFSTR( INARRY("EM AIL"))
	4619	"RTN","XUE SSO3",287, 0)
	4620	. I X'=$P ($G(^VA(20 0,XDUZ,.15 )),U) S FD R(200,IEN, .151)=X ;s et EMAIL A DDRESS if changed
	4621	"RTN","XUE SSO3",288, 0)
	4622	I $G(INAR RY("AD_UPN "))'="" D
	4623	"RTN","XUE SSO3",289, 0)
	4624	. S X=$$L OW^XLFSTR( $E(INARRY( "AD_UPN"), 1,50))
	4625	"RTN","XUE SSO3",290, 0)
	4626	. I X'=$P ($G(^VA(20 0,XDUZ,205 )),U,5) S FDR(200,IE N,205.5)=X ;edit ADU PN if chan ged
	4627	"RTN","XUE SSO3",291, 0)
	4628	I ($G(INA RRY("SSN") )'="")&(XS HOWSSN) D
	4629	"RTN","XUE SSO3",292, 0)
	4630	. S X=+$O (^VA(200," SSN",INARR Y("SSN"),0 )) ;Search for exist ing user w ith this S SN
	4631	"RTN","XUE SSO3",293, 0)
	4632	. I +X>0 D ;SSN fo und
	4633	"RTN","XUE SSO3",294, 0)
	4634	. . I +X' =XDUZ D ; SSN assign ed to anot her user
	4635	"RTN","XUE SSO3",295, 0)
	4636	. . . D E DITERR(.R, "This SSN is assigne d to anoth er user")
	4637	"RTN","XUE SSO3",296, 0)
	4638	. . ; els e SSN is a ssigned to this user , so no ne ed to chan ge SSN
	4639	"RTN","XUE SSO3",297, 0)
	4640	. E D ; SSN not fo und
	4641	"RTN","XUE SSO3",298, 0)
	4642	. . I $$S SNCHECK^XU ESSO1(INAR RY("SSN")) D ;valid ate SSN
	4643	"RTN","XUE SSO3",299, 0)
	4644	. . . S F DR(200,IEN ,9)=INARRY ("SSN") ;e dit SSN if valid
	4645	"RTN","XUE SSO3",300, 0)
	4646	. . E D ;error if SSN not v alid
	4647	"RTN","XUE SSO3",301, 0)
	4648	. . . D E DITERR(.R, "Not a val id SSN")
	4649	"RTN","XUE SSO3",302, 0)
	4650	I ($G(INA RRY("DOB") )'="")&(XS HOWSSN) D
	4651	"RTN","XUE SSO3",303, 0)
	4652	. S X=INA RRY("DOB") S %DT="X" D ^%DT
	4653	"RTN","XUE SSO3",304, 0)
	4654	. I Y>1 D
	4655	"RTN","XUE SSO3",305, 0)
	4656	. . I Y'= $P($G(^VA( 200,XDUZ,1 )),U,3) S FDR(200,IE N,5)=Y ;ed it DOB if changed
	4657	"RTN","XUE SSO3",306, 0)
	4658	. E D ; error if D OB not val id
	4659	"RTN","XUE SSO3",307, 0)
	4660	. . D EDI TERR(.R,"N ot a valid DOB")
	4661	"RTN","XUE SSO3",308, 0)
	4662	; Apply a ll the cha nges: File valid val ues and re ject inval id values.
	4663	"RTN","XUE SSO3",309, 0)
	4664	S DUZZERO =DUZ(0),DU Z(0)="@"
	4665	"RTN","XUE SSO3",310, 0)
	4666	I $D(FDR) D FILE^DI E("E","FDR ") ;File a ll the dat a
	4667	"RTN","XUE SSO3",311, 0)
	4668	S DUZ(0)= DUZZERO ;R estore ori ginal FM a ccess
	4669	"RTN","XUE SSO3",312, 0)
	4670	I $D(DIER R) D
	4671	"RTN","XUE SSO3",313, 0)
	4672	. S Y=0
	4673	"RTN","XUE SSO3",314, 0)
	4674	. F D Q :+Y'>0
	4675	"RTN","XUE SSO3",315, 0)
	4676	. . S Y=$ O(^TMP("DI ERR",$J,Y) )
	4677	"RTN","XUE SSO3",316, 0)
	4678	. . I +Y> 0 D EDITER R(.R,$G(^T MP("DIERR" ,$J,Y,"TEX T",1))) ;F ileMan Err or
	4679	"RTN","XUE SSO3",317, 0)
	4680	E I +$G( R(0))'=-1 D
	4681	"RTN","XUE SSO3",318, 0)
	4682	. S R(0)= XDUZ
	4683	"RTN","XUE SSO3",319, 0)
	4684	Q
	4685	"RTN","XUE SSO3",320, 0)
	4686	;
	4687	"RTN","XUE SSO3",321, 0)
	4688	IAMTU(R,SE CID,TERMDA TE,TERMRES N,AUTHCODE ) ;RPC. XU S IAM TERM INATE USER - IA #629 2
	4689	"RTN","XUE SSO3",322, 0)
	4690	; Input: SECID = S ECID - Use d to ident ify entry to be edit ed
	4691	"RTN","XUE SSO3",323, 0)
	4692	; TERMDATE = T ERMINATION DATE
	4693	"RTN","XUE SSO3",324, 0)
	4694	; TERMRESN = T ermination Reason
	4695	"RTN","XUE SSO3",325, 0)
	4696	; AUTHCODE = S ecurity Ph rase for I AM Provisi oning Appl ication
	4697	"RTN","XUE SSO3",326, 0)
	4698	; Return: Fail R (0) = " -1^Number of Errors"
	4699	"RTN","XUE SSO3",327, 0)
	4700	; R (1) throug h R(n) = " Error Mess age"
	4701	"RTN","XUE SSO3",328, 0)
	4702	; Success R (0) = D UZ
	4703	"RTN","XUE SSO3",329, 0)
	4704	;
	4705	"RTN","XUE SSO3",330, 0)
	4706	; ZEXCEPT : %DT,DIER R ;FileMan special v ariables
	4707	"RTN","XUE SSO3",331, 0)
	4708	N DUZZERO ,FDR,IEN,I NARRY,X,XA RRAY,XDUZ, XUENTRY,XU IAM,Y
	4709	"RTN","XUE SSO3",332, 0)
	4710	K R
	4711	"RTN","XUE SSO3",333, 0)
	4712	S R(0)=0
	4713	"RTN","XUE SSO3",334, 0)
	4714	S XUIAM=1 ;Do not t rigger IAM updates
	4715	"RTN","XUE SSO3",335, 0)
	4716	I DUZ'>1 D EDITERR( .R,"Unauth orized acc ess") Q
	4717	"RTN","XUE SSO3",336, 0)
	4718	I +$$ACTI VE^XUSER(D UZ)=0 D ED ITERR(.R," Unauthoriz ed access" ) Q
	4719	"RTN","XUE SSO3",337, 0)
	4720	S XUENTRY =$$GETCNTX T^XUESSO2( $G(AUTHCOD E)) I +XUE NTRY<0 D E DITERR(.R, $P(XUENTRY ,U,2)) Q
	4721	"RTN","XUE SSO3",338, 0)
	4722	I $P($G(^ XWB(8994.5 ,XUENTRY,0 )),U)'="IA M PROVISIO NING" D ED ITERR(.R," Unauthoriz ed access" ) Q
	4723	"RTN","XUE SSO3",339, 0)
	4724	I $G(SECI D)="" D ED ITERR(.R," User not i dentified by SecID") Q
	4725	"RTN","XUE SSO3",340, 0)
	4726	I $G(TERM DATE)="" D EDITERR(. R,"Missing Terminati on Date") Q
	4727	"RTN","XUE SSO3",341, 0)
	4728	I $G(TERM RESN)="" D EDITERR(. R,"Missing Terminati on Reason" ) Q
	4729	"RTN","XUE SSO3",342, 0)
	4730	S XARRAY( 7)=SECID ; SecID
	4731	"RTN","XUE SSO3",343, 0)
	4732	S XDUZ=$$ FINDUSER^X UESSO2(.XA RRAY) ;Fin d user to be termina ted
	4733	"RTN","XUE SSO3",344, 0)
	4734	I +XDUZ'> 1 D EDITER R(.R,"User not found ") Q
	4735	"RTN","XUE SSO3",345, 0)
	4736	;Use FM c alls to ed it the use r
	4737	"RTN","XUE SSO3",346, 0)
	4738	K ^TMP("D IERR",$J)
	4739	"RTN","XUE SSO3",347, 0)
	4740	S IEN=XDU Z_","
	4741	"RTN","XUE SSO3",348, 0)
	4742	S FDR(200 ,IEN,9.2)= TERMDATE ; set Termin ation Date
	4743	"RTN","XUE SSO3",349, 0)
	4744	S FDR(200 ,IEN,9.4)= $E(TERMRES N,1,45) ;s et Termina tion Reaso n
	4745	"RTN","XUE SSO3",350, 0)
	4746	; Apply t he changes .
	4747	"RTN","XUE SSO3",351, 0)
	4748	S DUZZERO =DUZ(0),DU Z(0)="@"
	4749	"RTN","XUE SSO3",352, 0)
	4750	I $D(FDR) D FILE^DI E("E","FDR ") ;File a ll the dat a
	4751	"RTN","XUE SSO3",353, 0)
	4752	S DUZ(0)= DUZZERO ;R estore ori ginal FM a ccess
	4753	"RTN","XUE SSO3",354, 0)
	4754	I $D(DIER R) D
	4755	"RTN","XUE SSO3",355, 0)
	4756	. S Y=0
	4757	"RTN","XUE SSO3",356, 0)
	4758	. F D Q :+Y'>0
	4759	"RTN","XUE SSO3",357, 0)
	4760	. . S Y=$ O(^TMP("DI ERR",$J,Y) )
	4761	"RTN","XUE SSO3",358, 0)
	4762	. . I +Y> 0 D EDITER R(.R,$G(^T MP("DIERR" ,$J,Y,"TEX T",1))) ;F ileMan Err or
	4763	"RTN","XUE SSO3",359, 0)
	4764	E I +$G( R(0))'=-1 D
	4765	"RTN","XUE SSO3",360, 0)
	4766	. S R(0)= XDUZ
	4767	"RTN","XUE SSO3",361, 0)
	4768	Q
	4769	"RTN","XUE SSO3",362, 0)
	4770	;
	4771	"RTN","XUE SSO3",363, 0)
	4772	IAMRU(R,SE CID,AUTHCO DE) ;RPC. XUS IAM RE ACTIVATE U SER - IA # 6293
	4773	"RTN","XUE SSO3",364, 0)
	4774	; Input: SECID = S ECID - Use d to ident ify entry to be edit ed
	4775	"RTN","XUE SSO3",365, 0)
	4776	; AUTHCODE = S ecurity Ph rase for I AM Provisi oning Appl ication
	4777	"RTN","XUE SSO3",366, 0)
	4778	; Return: Fail R (0) = " -1^Number of Errors"
	4779	"RTN","XUE SSO3",367, 0)
	4780	; R (1) throug h R(n) = " Error Mess age"
	4781	"RTN","XUE SSO3",368, 0)
	4782	; Success R (0) = 1
	4783	"RTN","XUE SSO3",369, 0)
	4784	;
	4785	"RTN","XUE SSO3",370, 0)
	4786	; ZEXCEPT : DIERR ;F ileMan spe cial varia bles
	4787	"RTN","XUE SSO3",371, 0)
	4788	N DUZZERO ,FDR,IEN,I NARRY,X,XA RRAY,XDUZ, XUENTRY,XU IAM,Y
	4789	"RTN","XUE SSO3",372, 0)
	4790	K R
	4791	"RTN","XUE SSO3",373, 0)
	4792	S R(0)=0
	4793	"RTN","XUE SSO3",374, 0)
	4794	S XUIAM=1 ;Do not t rigger IAM updates
	4795	"RTN","XUE SSO3",375, 0)
	4796	I DUZ'>1 D EDITERR( .R,"Unauth orized acc ess") Q
	4797	"RTN","XUE SSO3",376, 0)
	4798	I +$$ACTI VE^XUSER(D UZ)=0 D ED ITERR(.R," Unauthoriz ed access" ) Q
	4799	"RTN","XUE SSO3",377, 0)
	4800	S XUENTRY =$$GETCNTX T^XUESSO2( $G(AUTHCOD E)) I +XUE NTRY<0 D E DITERR(.R, $P(XUENTRY ,U,2)) Q
	4801	"RTN","XUE SSO3",378, 0)
	4802	I $P($G(^ XWB(8994.5 ,XUENTRY,0 )),U)'="IA M PROVISIO NING" D ED ITERR(.R," Unauthoriz ed access" ) Q
	4803	"RTN","XUE SSO3",379, 0)
	4804	I $G(SECI D)="" D ED ITERR(.R," User not i dentified by SecID") Q
	4805	"RTN","XUE SSO3",380, 0)
	4806	S XARRAY( 7)=SECID ; SecID
	4807	"RTN","XUE SSO3",381, 0)
	4808	S XDUZ=$$ FINDUSER^X UESSO2(.XA RRAY) ;Fin d user to be reactiv ated
	4809	"RTN","XUE SSO3",382, 0)
	4810	I +XDUZ'> 1 D EDITER R(.R,"User not found ") Q
	4811	"RTN","XUE SSO3",383, 0)
	4812	K ^TMP("D IERR",$J)
	4813	"RTN","XUE SSO3",384, 0)
	4814	S IEN=XDU Z_","
	4815	"RTN","XUE SSO3",385, 0)
	4816	S FDR(200 ,IEN,9.2)= "" ;set Te rmination Date
	4817	"RTN","XUE SSO3",386, 0)
	4818	; Apply t he changes .
	4819	"RTN","XUE SSO3",387, 0)
	4820	S DUZZERO =DUZ(0),DU Z(0)="@"
	4821	"RTN","XUE SSO3",388, 0)
	4822	I $D(FDR) D FILE^DI E("E","FDR ") ;File a ll the dat a
	4823	"RTN","XUE SSO3",389, 0)
	4824	S DUZ(0)= DUZZERO ;R estore ori ginal FM a ccess
	4825	"RTN","XUE SSO3",390, 0)
	4826	I $D(DIER R) D
	4827	"RTN","XUE SSO3",391, 0)
	4828	. S Y=0
	4829	"RTN","XUE SSO3",392, 0)
	4830	. F D Q :+Y'>0
	4831	"RTN","XUE SSO3",393, 0)
	4832	. . S Y=$ O(^TMP("DI ERR",$J,Y) )
	4833	"RTN","XUE SSO3",394, 0)
	4834	. . I +Y> 0 D EDITER R(.R,$G(^T MP("DIERR" ,$J,Y,"TEX T",1))) ;F ileMan Err or
	4835	"RTN","XUE SSO3",395, 0)
	4836	E I +$G( R(0))'=-1 D
	4837	"RTN","XUE SSO3",396, 0)
	4838	. S R(0)= XDUZ
	4839	"RTN","XUE SSO3",397, 0)
	4840	Q
	4841	"RTN","XUE SSO3",398, 0)
	4842	;
	4843	"RTN","XUE SSO3",399, 0)
	4844	ADDTOLST(X R,XCOUNT,X SHOWSSN,XR ESULT) ;In trinsic Su broutine. Add user t o list.
	4845	"RTN","XUE SSO3",400, 0)
	4846	N XFLAG,X I,XODOB,XO NME,XONMEC ,XOSEC,XOS SN,XOUPN
	4847	"RTN","XUE SSO3",401, 0)
	4848	S XFLAG=0
	4849	"RTN","XUE SSO3",402, 0)
	4850	F XI=1:1: XCOUNT D
	4851	"RTN","XUE SSO3",403, 0)
	4852	. I XRESU LT=$P($G(X R(XI)),U) S XFLAG=1
	4853	"RTN","XUE SSO3",404, 0)
	4854	I XFLAG=0 D
	4855	"RTN","XUE SSO3",405, 0)
	4856	. S XCOUN T=XCOUNT+1
	4857	"RTN","XUE SSO3",406, 0)
	4858	. S XONME =$P($G(^VA (200,XRESU LT,0)),U)
	4859	"RTN","XUE SSO3",407, 0)
	4860	. S XONME C=$$NAMECO MP(XRESULT )
	4861	"RTN","XUE SSO3",408, 0)
	4862	. S XOSSN ="<Hidden> " I $G(XSH OWSSN)=1 S XOSSN=$P( $G(^VA(200 ,XRESULT,1 )),U,9)
	4863	"RTN","XUE SSO3",409, 0)
	4864	. S XODOB ="<Hidden> " I $G(XSH OWSSN)=1 S XODOB=$TR ($$FMTE^XL FDT($P($G( ^VA(200,XR ESULT,1)), U,3),"5DZ" ),"/","")
	4865	"RTN","XUE SSO3",410, 0)
	4866	. S XOUPN =$P($G(^VA (200,XRESU LT,205)),U ,5)
	4867	"RTN","XUE SSO3",411, 0)
	4868	. S XOSEC =$TR($P($G (^VA(200,X RESULT,205 )),U),"%", "^")
	4869	"RTN","XUE SSO3",412, 0)
	4870	. S XR(XC OUNT)=XRES ULT_"^"_XO NME_"^"_XO NMEC_"^"_X OSSN_"^"_X ODOB_"^"_X OUPN_"^"_X OSEC
	4871	"RTN","XUE SSO3",413, 0)
	4872	Q
	4873	"RTN","XUE SSO3",414, 0)
	4874	;
	4875	"RTN","XUE SSO3",415, 0)
	4876	NAMECOMP(I EN) ;Intri nsic Funct ion. Get N AME COMPON ENTS.
	4877	"RTN","XUE SSO3",416, 0)
	4878	N NAME,NC 1,NCIEN
	4879	"RTN","XUE SSO3",417, 0)
	4880	S NCIEN=$ O(^VA(20," BB",200,.0 1,IEN_",", 0))
	4881	"RTN","XUE SSO3",418, 0)
	4882	Q:'NCIEN ""
	4883	"RTN","XUE SSO3",419, 0)
	4884	S NC1=$G( ^VA(20,NCI EN,1))
	4885	"RTN","XUE SSO3",420, 0)
	4886	Q $TR($P( NC1,U,1,3) _U_$P(NC1, U,5),U,"`" )
	4887	"RTN","XUE SSO3",421, 0)
	4888	;
	4889	"RTN","XUE SSO3",422, 0)
	4890	EDITERR(Y, XMSG) ;Int rinsic Sub routine. A dd error t o list.
	4891	"RTN","XUE SSO3",423, 0)
	4892	N I
	4893	"RTN","XUE SSO3",424, 0)
	4894	S:$P(XMSG ,"-1^")="" $E(XMSG,1 ,3)=""
	4895	"RTN","XUE SSO3",425, 0)
	4896	S I=$O(Y( ""),-1)+1, Y(I)=XMSG, Y(0)=-1_U_ I
	4897	"RTN","XUE SSO3",426, 0)
	4898	Q
	4899	"RTN","XUE SSO4")
	4900	0^19^B6150 5269^n/a
	4901	"RTN","XUE SSO4",1,0)
	4902	XUESSO4 ;I SD/HGW Enh anced Sing le Sign-On Utilities ;12/03/15 15:03
	4903	"RTN","XUE SSO4",2,0)
	4904	;;8.0;KER NEL;*659 *;Jul 10, 1995;Build 22
	4905	"RTN","XUE SSO4",3,0)
	4906	;Per VA D irective 6 402, this routine sh ould not b e modified .
	4907	"RTN","XUE SSO4",4,0)
	4908	;
	4909	"RTN","XUE SSO4",5,0)
	4910	Q
	4911	"RTN","XUE SSO4",6,0)
	4912	;
	4913	"RTN","XUE SSO4",7,0)
	4914	IAMBU(Y,SE CID,AUTHCO DE,ADUPN) ;RPC. XUS IAM BIND U SER - IA # 6294
	4915	"RTN","XUE SSO4",8,0)
	4916	;Identity and Acces s Manageme nt Edit Us er RPC for SSOi bind ing
	4917	"RTN","XUE SSO4",9,0)
	4918	; Input: SECID = unique Security I D [SecID, assigned b y Identity and Acces s Manageme nt]
	4919	"RTN","XUE SSO4",10,0 )
	4920	; AUTHCODE = Securit y Phrase f or IAM Bin ding Appli cation
	4921	"RTN","XUE SSO4",11,0 )
	4922	; ADUPN = Active Directory UPN
	4923	"RTN","XUE SSO4",12,0 )
	4924	; Return: Fail Y = "-1^Err or Message "
	4925	"RTN","XUE SSO4",13,0 )
	4926	; Success Y = DUZ
	4927	"RTN","XUE SSO4",14,0 )
	4928	;
	4929	"RTN","XUE SSO4",15,0 )
	4930	; ZEXCEPT : DIERR ;F ileMan spe cial varia bles
	4931	"RTN","XUE SSO4",16,0 )
	4932	N DUZZERO ,FDR,IEN,X ARRY,XRESU LT,XUENTRY ,XUIAM
	4933	"RTN","XUE SSO4",17,0 )
	4934	I DUZ'>1 S Y="-1^Un authorized access" Q
	4935	"RTN","XUE SSO4",18,0 )
	4936	S XUENTRY =$$GETCNTX T^XUESSO2( $G(AUTHCOD E)) I +XUE NTRY<0 S Y =XUENTRY Q
	4937	"RTN","XUE SSO4",19,0 )
	4938	I $P($G(^ XWB(8994.5 ,XUENTRY,0 )),U,1)'=" IAM BINDIN G" S Y="-1 ^Unauthori zed access " Q
	4939	"RTN","XUE SSO4",20,0 )
	4940	S XUIAM=1 ;Do not t rigger IAM updates
	4941	"RTN","XUE SSO4",21,0 )
	4942	S XARRY(7 )=$G(SECID ) ;SecID
	4943	"RTN","XUE SSO4",22,0 )
	4944	I $G(SECI D)'="" S X RESULT=$$F INDUSER^XU ESSO2(.XAR RY)
	4945	"RTN","XUE SSO4",23,0 )
	4946	I (+XRESU LT>0)&(XRE SULT'=DUZ) S Y="-1^T his SecID has alread y been ass igned to a nother use r" Q
	4947	"RTN","XUE SSO4",24,0 )
	4948	;Use FM c alls to ed it the use r
	4949	"RTN","XUE SSO4",25,0 )
	4950	K ^TMP("D IERR",$J)
	4951	"RTN","XUE SSO4",26,0 )
	4952	S IEN=DUZ _","
	4953	"RTN","XUE SSO4",27,0 )
	4954	S FDR(200 ,IEN,205.1 )=$TR($E($ G(SECID),1 ,40),"^"," %") ;Se cID
	4955	"RTN","XUE SSO4",28,0 )
	4956	S FDR(200 ,IEN,205.2 )=$P($G(^X TV(8989.3, 1,200)),U, 2) ;Su bject Orga nization
	4957	"RTN","XUE SSO4",29,0 )
	4958	S FDR(200 ,IEN,205.3 )=$P($G(^X TV(8989.3, 1,200)),U, 3) ;Su bject Orga nization I D
	4959	"RTN","XUE SSO4",30,0 )
	4960	S FDR(200 ,IEN,205.4 )=$TR($E($ G(SECID),1 ,40),"^"," %") ;Un ique User ID
	4961	"RTN","XUE SSO4",31,0 )
	4962	I $D(ADUP N) S FDR(2 00,IEN,205 .5)=$$LOW^ XLFSTR($E( $G(ADUPN), 1,50)) ;AD UPN
	4963	"RTN","XUE SSO4",32,0 )
	4964	; Apply a ll the cha nges: File valid val ues and re ject inval id values (no "T" fl ag).
	4965	"RTN","XUE SSO4",33,0 )
	4966	S DUZZERO =DUZ(0),DU Z(0)="@" ; Make sure we can upd ate the en try
	4967	"RTN","XUE SSO4",34,0 )
	4968	I $D(FDR) D FILE^DI E("ET","FD R") ;File all the da ta
	4969	"RTN","XUE SSO4",35,0 )
	4970	S DUZ(0)= DUZZERO ;R estore ori ginal FM a ccess
	4971	"RTN","XUE SSO4",36,0 )
	4972	I $D(DIER R) S Y="-1 ^Error bin ding VistA user to I AM" Q
	4973	"RTN","XUE SSO4",37,0 )
	4974	S Y=DUZ
	4975	"RTN","XUE SSO4",38,0 )
	4976	Q
	4977	"RTN","XUE SSO4",39,0 )
	4978	;
	4979	"RTN","XUE SSO4",40,0 )
	4980	VACAA(INAR RAY,AUTHCO DE) ; Vete rans Acces s, Choice, and Accou ntability Act of 201 4 (VACAA)
	4981	"RTN","XUE SSO4",41,0 )
	4982	; Bulk-lo ad non-VA provider i nformation .
	4983	"RTN","XUE SSO4",42,0 )
	4984	; This in terface is available under a p rivate Int egration A greement ( #6230) for support
	4985	"RTN","XUE SSO4",43,0 )
	4986	; of VACA A only, an d should n ot be used under any other cir cumstances .
	4987	"RTN","XUE SSO4",44,0 )
	4988	; Input: INARRAY(0 ) = VISN
	4989	"RTN","XUE SSO4",45,0 )
	4990	; INARRAY(1 ) = NAME
	4991	"RTN","XUE SSO4",46,0 )
	4992	; INARRAY(2 ) = DEGRE E
	4993	"RTN","XUE SSO4",47,0 )
	4994	; INARRAY(3 ) = SEX
	4995	"RTN","XUE SSO4",48,0 )
	4996	; INARRAY(4 ) = STREE T ADDRESS 1
	4997	"RTN","XUE SSO4",49,0 )
	4998	; INARRAY(5 ) = STREE T ADDRESS 2
	4999	"RTN","XUE SSO4",50,0 )
	5000	; INARRAY(6 ) = STREE T ADDRESS 3
	5001	"RTN","XUE SSO4",51,0 )
	5002	; INARRAY(7 ) = CITY
	5003	"RTN","XUE SSO4",52,0 )
	5004	; INARRAY(8 ) = STATE
	5005	"RTN","XUE SSO4",53,0 )
	5006	; INARRAY(9 ) = ZIP
	5007	"RTN","XUE SSO4",54,0 )
	5008	; INARRAY(1 0) = NPI
	5009	"RTN","XUE SSO4",55,0 )
	5010	; INARRAY(1 1) = (Opti onal) TAX ID
	5011	"RTN","XUE SSO4",56,0 )
	5012	; INARRAY(1 2) = DEA #
	5013	"RTN","XUE SSO4",57,0 )
	5014	; INARRAY(1 3) = Subje ct Organiz ation
	5015	"RTN","XUE SSO4",58,0 )
	5016	; INARRAY(1 4) = Subje ct Organiz ation ID
	5017	"RTN","XUE SSO4",59,0 )
	5018	; Return: Fail = "-1^E rror Messa ge"
	5019	"RTN","XUE SSO4",60,0 )
	5020	; Neutral = 0 (no t an error , but entr y should n ot be made at this s ite)
	5021	"RTN","XUE SSO4",61,0 )
	5022	; Success = IEN o f NEW PERS ON file (# 200) entry
	5023	"RTN","XUE SSO4",62,0 )
	5024	;
	5025	"RTN","XUE SSO4",63,0 )
	5026	; ZEXCEPT : DA,DD,DI C,DIE,DINU M,DLAYGO,D O,DR
	5027	"RTN","XUE SSO4",64,0 )
	5028	N FADA,FD R,IEN,VIEN ,VISN,X,XA TTRIB,XDUZ ,XIP,XSEC, XSTATE,XTA XID,XUIAM, XUVISN,Y
	5029	"RTN","XUE SSO4",65,0 )
	5030	I $$SHAHA SH^XUSHSH( 256,AUTHCO DE)'="69AB 5CA7FF413A CA7422D52E 466B0C1220 BE64C25AFB 354E2915A5 72E251E560 " Q "-1^Un authorized access"
	5031	"RTN","XUE SSO4",66,0 )
	5032	I '$$PROD ^XUPROD Q "-1^Not a production account"
	5033	"RTN","XUE SSO4",67,0 )
	5034	I $G(INAR RAY(0))="" Q "-1^Mis sing VISN"
	5035	"RTN","XUE SSO4",68,0 )
	5036	I $G(INAR RAY(1))="" Q "-1^Mis sing Name"
	5037	"RTN","XUE SSO4",69,0 )
	5038	I $G(INAR RAY(4))="" Q "-1^Mis sing Stree t Addr"
	5039	"RTN","XUE SSO4",70,0 )
	5040	I $G(INAR RAY(7))="" Q "-1^Mis sing City"
	5041	"RTN","XUE SSO4",71,0 )
	5042	I $G(INAR RAY(8))="" Q "-1^Mis sing State "
	5043	"RTN","XUE SSO4",72,0 )
	5044	I $G(INAR RAY(9))="" Q "-1^Mis sing Zip C ode"
	5045	"RTN","XUE SSO4",73,0 )
	5046	I $G(INAR RAY(10))=" " Q "-1^Mi ssing NPI"
	5047	"RTN","XUE SSO4",74,0 )
	5048	I $G(INAR RAY(13))=" " Q "-1^Mi ssing Subj ect Organi zation"
	5049	"RTN","XUE SSO4",75,0 )
	5050	I $G(INAR RAY(14))=" " Q "-1^Mi ssing Subj ect Organi zation ID"
	5051	"RTN","XUE SSO4",76,0 )
	5052	I '$$CHKD GT^XUSNPI( $G(INARRAY (10))) Q " -1^Invalid NPI"
	5053	"RTN","XUE SSO4",77,0 )
	5054	D PARENT^ XUAF4("XUV ISN","`"_D UZ(2),"VIS N") ;Retur ns XUVISN( "P",pien)= "VISN #^"
	5055	"RTN","XUE SSO4",78,0 )
	5056	S VIEN=$O (XUVISN("P ",0)) S VI SN=$TR($P( $G(XUVISN( "P",VIEN)) ,U),"VISN ") ;Return VISN numb er (no tex t)
	5057	"RTN","XUE SSO4",79,0 )
	5058	I VISN'=I NARRAY(0) Q 0 ; Onl y load dat a appropri ate for th e site's V ISN (not a n error)
	5059	"RTN","XUE SSO4",80,0 )
	5060	S DUZ(0)= "@",XUIAM= 1 ;Tempora ry high-le vel access to edit N PF, do not trigger I AM updates
	5061	"RTN","XUE SSO4",81,0 )
	5062	S XATTRIB (8)=INARRA Y(10) ; NP I
	5063	"RTN","XUE SSO4",82,0 )
	5064	S XDUZ=$$ FINDUSER^X UESSO2(.XA TTRIB) ; F irst find user based on NPI al one
	5065	"RTN","XUE SSO4",83,0 )
	5066	;Set mini mum 4 attr ibutes
	5067	"RTN","XUE SSO4",84,0 )
	5068	S XATTRIB (1)=INARRA Y(13) ; Su bject Orga nization
	5069	"RTN","XUE SSO4",85,0 )
	5070	S XATTRIB (2)=INARRA Y(14) ; Su bject Orga nization I D
	5071	"RTN","XUE SSO4",86,0 )
	5072	S XATTRIB (3)=XATTRI B(8) ; Uni que User I D = NPI pe r NHIN sta ndard
	5073	"RTN","XUE SSO4",87,0 )
	5074	S XATTRIB (4)=INARRA Y(1) ; Sub ject ID = NAME
	5075	"RTN","XUE SSO4",88,0 )
	5076	I (+XDUZ> 0)&('+$$AC TIVE^XUSER (XDUZ)) S XDUZ=$$FIN DUSER^XUES SO2(.XATTR IB) ; If n ot active user, look up on NPI again, upd ate M4A
	5077	"RTN","XUE SSO4",89,0 )
	5078	I +XDUZ<1 S XDUZ=$$ ADDUSER^XU ESSO2(.XAT TRIB) ;Add the new u ser with M 4A
	5079	"RTN","XUE SSO4",90,0 )
	5080	I +XDUZ<1 Q XDUZ ; Quit with error code from ^XUE SSO2
	5081	"RTN","XUE SSO4",91,0 )
	5082	S IEN=XDU Z_","
	5083	"RTN","XUE SSO4",92,0 )
	5084	I $G(INAR RAY(2))'=" " S FDR(20 0,IEN,10.6 )=$E($G(IN ARRAY(2)), 1,10) ; D EGREE
	5085	"RTN","XUE SSO4",93,0 )
	5086	I (($G(IN ARRAY(3))= "M")!($G(I NARRAY(3)) ="F")) S F DR(200,IEN ,4)=$E($G( INARRAY(3) ),1,1) ; SEX
	5087	"RTN","XUE SSO4",94,0 )
	5088	I $L($G(I NARRAY(4)) )>2 S FDR( 200,IEN,.1 11)=$E($G( INARRAY(4) ),1,50) ; STREET AD DRESS 1
	5089	"RTN","XUE SSO4",95,0 )
	5090	I $L($G(I NARRAY(5)) )>2 S FDR( 200,IEN,.1 12)=$E($G( INARRAY(5) ),1,50) ; STREET AD DRESS 2
	5091	"RTN","XUE SSO4",96,0 )
	5092	I $L($G(I NARRAY(6)) )>2 S FDR( 200,IEN,.1 13)=$E($G( INARRAY(6) ),1,50) ; STREET AD DRESS 3
	5093	"RTN","XUE SSO4",97,0 )
	5094	I $L($G(I NARRAY(7)) )>2 S FDR( 200,IEN,.1 14)=$E($G( INARRAY(7) ),1,30) ; CITY
	5095	"RTN","XUE SSO4",98,0 )
	5096	I $G(INAR RAY(8))'=" " D
	5097	"RTN","XUE SSO4",99,0 )
	5098	. I $L($G (INARRAY(8 )))>2 S XS TATE="" S XSTATE=$O( ^DIC(5,"B" ,$G(INARRA Y(8)),XSTA TE))
	5099	"RTN","XUE SSO4",100, 0)
	5100	. I $L($G (INARRAY(8 )))=2 D
	5101	"RTN","XUE SSO4",101, 0)
	5102	. . S XIP =""
	5103	"RTN","XUE SSO4",102, 0)
	5104	. . D POS TAL^XIPUTI L($G(INARR AY(9)),.XI P)
	5105	"RTN","XUE SSO4",103, 0)
	5106	. . S XST ATE=$G(XIP ("STATE PO INTER"))
	5107	"RTN","XUE SSO4",104, 0)
	5108	. I XSTAT E'="" S FD R(200,IEN, .115)=XSTA TE ; STATE (pointer to ^DIC(5) )
	5109	"RTN","XUE SSO4",105, 0)
	5110	I $G(INAR RAY(9))'=" " S FDR(20 0,IEN,.116 )=$G(INARR AY(9)) ; ZIP CODE
	5111	"RTN","XUE SSO4",106, 0)
	5112	D APPLY(. FDR,IEN) K FDR S IEN =XDUZ_","
	5113	"RTN","XUE SSO4",107, 0)
	5114	S XTAXID= $TR($G(INA RRAY(11)), "-","")
	5115	"RTN","XUE SSO4",108, 0)
	5116	I XTAXID' ="" D
	5117	"RTN","XUE SSO4",109, 0)
	5118	. S XTAXI D=$E(XTAXI D,1,2)_"-" _$E(XTAXID ,3,9)
	5119	"RTN","XUE SSO4",110, 0)
	5120	. S XTAXI D=$TR(XTAX ID," ","0" )
	5121	"RTN","XUE SSO4",111, 0)
	5122	I (XTAXID '="")&($P( $G(^VA(200 ,XDUZ,"TPB ")),U,2)=" ") S FDR(2 00,IEN,53. 92)=XTAXID ; TAX ID
	5123	"RTN","XUE SSO4",112, 0)
	5124	D APPLY(. FDR,IEN) K FDR S IEN =XDUZ_","
	5125	"RTN","XUE SSO4",113, 0)
	5126	I $P($G(^ VA(200,XDU Z,"TPB")), U,1)="" S FDR(200,IE N,53.91)=1 ; NON- D A N P S E C IBER: (1=Y ES)
	5127	"RTN","XUE SSO4",114, 0)
	5128	I $P($G(^ VA(200,XDU Z,"PS")),U ,6)="" S F DR(200,IEN ,53.6)=4 ; PROVIDER TYPE: (4=F EE BASIS)
	5129	"RTN","XUE SSO4",115, 0)
	5130	D APPLY(. FDR,IEN) K FDR S IEN =XDUZ_","
	5131	"RTN","XUE SSO4",116, 0)
	5132	I '+$$ACT IVE^XUSER( XDUZ)'="" D ;Could not get UP DATE^DIE t o work con sistently for these fields
	5133	"RTN","XUE SSO4",117, 0)
	5134	. I $G(IN ARRAY(12)) '="" D
	5135	"RTN","XUE SSO4",118, 0)
	5136	. . S FDR (200,IEN,5 3.1)=1 ; A UTHORIZED TO WRITE M ED ORDERS: (1=YES)
	5137	"RTN","XUE SSO4",119, 0)
	5138	. . D APP LY(.FDR,IE N)
	5139	"RTN","XUE SSO4",120, 0)
	5140	. . S DIE ="^VA(200, ",DA=XDUZ, DR="53.2// //"_INARRA Y(12) ; DE A # (stuff , due to d uplicate D EA#s and u ser name c hanges)
	5141	"RTN","XUE SSO4",121, 0)
	5142	. . L +^V A(200,XDUZ ):$S(+$G(^ DD("DILOCK TM"))>0:+^ DD("DILOCK TM"),1:3) D ^DIE L - ^VA(200,XD UZ)
	5143	"RTN","XUE SSO4",122, 0)
	5144	. I $D(^V A(200,XDUZ ,"PS")) D
	5145	"RTN","XUE SSO4",123, 0)
	5146	. . I '$P (^VA(200,X DUZ,"PS"), "^",4)!($P (^VA(200,X DUZ,"PS"), "^",4)>DT) D ;Give user "XUOR ES" key if not an ac tive user
	5147	"RTN","XUE SSO4",124, 0)
	5148	. . . S D A=XDUZ
	5149	"RTN","XUE SSO4",125, 0)
	5150	. . . K D IC S DIC=" ^DIC(19.1, ",DIC(0)=" MZ",X="XUO RES" D ^DI C
	5151	"RTN","XUE SSO4",126, 0)
	5152	. . . K D IC S FADA= XDUZ
	5153	"RTN","XUE SSO4",127, 0)
	5154	. . . I + Y>0 S X=+Y D
	5155	"RTN","XUE SSO4",128, 0)
	5156	. . . . S :'$D(^VA(2 00,FADA,51 ,0)) ^VA(2 00,FADA,51 ,0)="^"_$P (^DD(200,5 1,0),"^",2 )_"^^"
	5157	"RTN","XUE SSO4",129, 0)
	5158	. . . . S DIC="^VA( 200,"_FADA _",51,",DI C(0)="LM", DIC("DR")= "1////"_$S ($G(DUZ):D UZ,1:"")_" ;2///"_DT, DLAYGO=200 .051,DINUM =X,DA(1)=F ADA
	5159	"RTN","XUE SSO4",130, 0)
	5160	. . . . L +^VA(200, FADA):$S(+ $G(^DD("DI LOCKTM"))> 0:+^DD("DI LOCKTM"),1 :3) K DD,D O D FILE^D ICN L -^VA (200,FADA) K DIC,DR, X,Y
	5161	"RTN","XUE SSO4",131, 0)
	5162	. . I $P( $G(^VA(200 ,XDUZ,"PS" )),"^",5)= "" D ; PR OVIDER CLA SS (pointe r to ^DIC( 7))
	5163	"RTN","XUE SSO4",132, 0)
	5164	. . . S X =0
	5165	"RTN","XUE SSO4",133, 0)
	5166	. . . S X =$O(^DIC(7 ,"B","PHYS ICIAN",X))
	5167	"RTN","XUE SSO4",134, 0)
	5168	. . . I X >0 D
	5169	"RTN","XUE SSO4",135, 0)
	5170	. . . . S DIE="^VA( 200,",DA=X DUZ,DR="53 .5////"_X
	5171	"RTN","XUE SSO4",136, 0)
	5172	. . . . L +^VA(200, XDUZ):$S(+ $G(^DD("DI LOCKTM"))> 0:+^DD("DI LOCKTM"),1 :3) D ^DIE L -^VA(20 0,XDUZ)
	5173	"RTN","XUE SSO4",137, 0)
	5174	S DUZ(0)= $P($G(^VA( 200,DUZ,0) ),U,4)
	5175	"RTN","XUE SSO4",138, 0)
	5176	Q XDUZ
	5177	"RTN","XUE SSO4",139, 0)
	5178	;
	5179	"RTN","XUE SSO4",140, 0)
	5180	APPLY(FDR, IEN) ; App ly the cha nges, used by "VACAA "
	5181	"RTN","XUE SSO4",141, 0)
	5182	;ZEXCEPT: DIC
	5183	"RTN","XUE SSO4",142, 0)
	5184	K ^TMP("D IERR",$J)
	5185	"RTN","XUE SSO4",143, 0)
	5186	S DIC(0)= ""
	5187	"RTN","XUE SSO4",144, 0)
	5188	I $D(FDR) K IEN D U PDATE^DIE( "E","FDR", "IEN") ;Fi le all the data
	5189	"RTN","XUE SSO4",145, 0)
	5190	Q
	5191	"RTN","XUE SSO4",146, 0)
	5192	;
	5193	"RTN","XUE SSO4",147, 0)
	5194	ESSO(RET,D OC) ; RPC. XUS ESSO VALIDATE - IA #6295
	5195	"RTN","XUE SSO4",148, 0)
	5196	;This API /RPC uses the VA Ide ntity and Access Man agement (I AM) SAML t oken defin ition vers ion 1.2 at tributes
	5197	"RTN","XUE SSO4",149, 0)
	5198	; from a STS SAML t oken for u ser sign-o n.
	5199	"RTN","XUE SSO4",150, 0)
	5200	; Input: DOC = Closed reference to global root conta ining XML document ( loaded STS SAML Toke n).
	5201	"RTN","XUE SSO4",151, 0)
	5202	; See $$E N^MXMLDOM instructio ns in the VistA Kern el Develop ers Guide for requir ed
	5203	"RTN","XUE SSO4",152, 0)
	5204	; format of the DOC global.
	5205	"RTN","XUE SSO4",153, 0)
	5206	; Return: RET(0) = DUZ if sign-on wa s OK, zero if not OK .
	5207	"RTN","XUE SSO4",154, 0)
	5208	; RET(1) = (0=OK, 1,2...=Can 't sign on for some reason).
	5209	"RTN","XUE SSO4",155, 0)
	5210	; RET(2) = Verify Code needs changing.
	5211	"RTN","XUE SSO4",156, 0)
	5212	; RET(3) = Message .
	5213	"RTN","XUE SSO4",157, 0)
	5214	; RET(4) = 0
	5215	"RTN","XUE SSO4",158, 0)
	5216	; RET(5) = count o f the numb er of line s of text, zero if n one.
	5217	"RTN","XUE SSO4",159, 0)
	5218	; RET(5+ n) = messa ge text.
	5219	"RTN","XUE SSO4",160, 0)
	5220	;
	5221	"RTN","XUE SSO4",161, 0)
	5222	N VCCH,XA RRY,XDIV,X DIVA,XOPT, XUDEV,XUF, XUHOME,XUM ,XUMSG,XUV OL,X,Y
	5223	"RTN","XUE SSO4",162, 0)
	5224	S U="^",R ET(0)=0,RE T(5)=0,XUF =$G(XUF,0) ,XUM=0,XUM SG=0,XUDEV =0
	5225	"RTN","XUE SSO4",163, 0)
	5226	; Begin u ser sign-o n
	5227	"RTN","XUE SSO4",164, 0)
	5228	S DUZ=0,D UZ(0)="",V CCH=0 D NO W^XUSRB
	5229	"RTN","XUE SSO4",165, 0)
	5230	S XOPT=$$ STATE^XWBS EC("XUS XO PT")
	5231	"RTN","XUE SSO4",166, 0)
	5232	S XUVOL=^ %ZOSF("VOL ")
	5233	"RTN","XUE SSO4",167, 0)
	5234	S XUMSG=$ $INHIBIT^X USRB() I X UMSG S XUM =1 G VAX^X USRB ;Logo n inhibite d
	5235	"RTN","XUE SSO4",168, 0)
	5236	;3 Strike s
	5237	"RTN","XUE SSO4",169, 0)
	5238	I $$LKCHE CK^XUSTZIP ($G(IO("IP "))) S XUM SG=7 G VAX ^XUSRB ;IP locked
	5239	"RTN","XUE SSO4",170, 0)
	5240	S DUZ=$$E N^XUSAML(D OC) ;Proce ss SAML to ken
	5241	"RTN","XUE SSO4",171, 0)
	5242	I DUZ'>0, $$FAIL^XUS 3 D G VAX ^XUSRB
	5243	"RTN","XUE SSO4",172, 0)
	5244	. S XUM=1 ,XUMSG=7,X =$$RA^XUST Z H 5 ;3 S trikes
	5245	"RTN","XUE SSO4",173, 0)
	5246	I DUZ'>0 S XUMSG=63 G VAX^XUS RB
	5247	"RTN","XUE SSO4",174, 0)
	5248	D USER^XU S(DUZ) ;Bu ild USER
	5249	"RTN","XUE SSO4",175, 0)
	5250	S XUMSG=$ $UVALID^XU S() G:XUMS G VAX^XUSR B ;Check i f user is locked out , terminat ed, or dis usered
	5251	"RTN","XUE SSO4",176, 0)
	5252	I ('($G(D UZ("AUTHEN TICATION") )="SSOE")) &('($G(DUZ ("AUTHENTI CATION"))= "M4A")) S VCCH=$$VCV ALID^XUSRB () ;Check if VC need s changing
	5253	"RTN","XUE SSO4",177, 0)
	5254	I DUZ>0 S XUMSG=$$P OST^XUSRB( 1)
	5255	"RTN","XUE SSO4",178, 0)
	5256	I XUMSG>0 S DUZ=0,V CCH=0 ;If can't sign -on, don't tell need to change VC
	5257	"RTN","XUE SSO4",179, 0)
	5258	I 'XUMSG, VCCH S XUM SG=12 D SE T^XWBSEC(" XUS DUZ",D UZ) ;Need to change VC
	5259	"RTN","XUE SSO4",180, 0)
	5260	D:DUZ>0 P OST2^XUSRB
	5261	"RTN","XUE SSO4",181, 0)
	5262	S RET(0)= DUZ,RET(1) =XUM,RET(2 )=VCCH,RET (3)=$S(XUM SG:$$TXT^X US3(XUMSG) ,1:""),RET (4)=0
	5263	"RTN","XUE SSO4",182, 0)
	5264	Q
	5265	"RTN","XUE SSO4",183, 0)
	5266	;
	5267	"RTN","XUP ")
	5268	0^20^B1189 8665^B1155 1061
	5269	"RTN","XUP ",1,0)
	5270	XUP ;SFISC /RWF - Set up environ ment for p rogrammers ;09/02/15 06:36
	5271	"RTN","XUP ",2,0)
	5272	;;8.0;KER NEL;*208, 258,284,43 2,469,659 *;Jul 10, 1995;Build 22
	5273	"RTN","XUP ",3,0)
	5274	;Per VA D irective 6 402, this routine sh ould not b e modified .
	5275	"RTN","XUP ",4,0)
	5276	W !,"Sett ing up pro grammer en vironment"
	5277	"RTN","XUP ",5,0)
	5278	S U="^",$ ECODE="",$ ETRAP="" ; Clear erro r and erro r trap
	5279	"RTN","XUP ",6,0)
	5280	X ^%ZOSF( "TYPE-AHEA D")
	5281	"RTN","XUP ",7,0)
	5282	;Check if Productio n and repo rt
	5283	"RTN","XUP ",8,0)
	5284	W !,"This is a "_$S ($$PROD^XU PROD(1):"P RODUCTION" ,1:"TEST") _" account .",!
	5285	"RTN","XUP ",9,0)
	5286	;
	5287	"RTN","XUP ",10,0)
	5288	K ^UTILIT Y($J),^XUT L("XQ",$J) D KILL1^X USCLEAN
	5289	"RTN","XUP ",11,0)
	5290	S U="^",D T=$$DT^XLF DT
	5291	"RTN","XUP ",12,0)
	5292	S XUEOFF= ^%ZOSF("EO FF"),XUEON =^%ZOSF("E ON"),U="^" ,XUTT=0,XU IOP=""
	5293	"RTN","XUP ",13,0)
	5294	D GETENV^ %ZOSV S XU ENV=Y,XUVO L=$P(Y,U,2 ),XUCI=$P( Y,U,1)
	5295	"RTN","XUP ",14,0)
	5296	;Reset DU Z if user "Switched Identities ".
	5297	"RTN","XUP ",15,0)
	5298	I $D(DUZ( "SAV")) S DUZ=+DUZ(" SAV"),DUZ( 0)=$P(DUZ( "SAV"),U,2 ) K DUZ("S AV")
	5299	"RTN","XUP ",16,0)
	5300	;Get user info
	5301	"RTN","XUP ",17,0)
	5302	I $G(DUZ) >.5,$D(^VA (200,DUZ,0 ))[0 K DUZ W !,"DUZ Must point to a real user." G EXIT ;p432
	5303	"RTN","XUP ",18,0)
	5304	I $G(DUZ) >0 D DUZ(D UZ)
	5305	"RTN","XUP ",19,0)
	5306	I $G(DUZ) '>0!('$D(D UZ(0))) D ASKDUZ G:Y '>0 EXIT
	5307	"RTN","XUP ",20,0)
	5308	I '$D(XQU SER) S XQU SER=$S($D( ^VA(200,DU Z,20)):$P( ^(20),"^", 2),1:"Unk" )
	5309	"RTN","XUP ",21,0)
	5310	S DTIME=6 00 ;Set a temp DTIME
	5311	"RTN","XUP ",22,0)
	5312	S DILOCKT M=+$G(^DD( "DILOCKTM" ),1) ;p432
	5313	"RTN","XUP ",23,0)
	5314	S DUZ("LO A")=2 ;p65 9
	5315	"RTN","XUP ",24,0)
	5316	S DUZ("AU THENTICATI ON")="XUP"
	5317	"RTN","XUP ",25,0)
	5318	;Getting Terminal T ype
	5319	"RTN","XUP ",26,0)
	5320	ZIS I XUTT D ENQ^XUS 1 G:$D(XUI OP(1)) ZIS 2 S Y=0 D TT^XUS3 I Y>0 S XUIO P(1)=$P(XU IOP,";",2) G ZIS2
	5321	"RTN","XUP ",27,0)
	5322	S X="`"_+ $G(^VA(200 ,DUZ,1.2)) ,DIC="^%ZI S(2,",DIC( 0)="MQ"_$S (X]"`0":"" ,1:"AE") D ^DIC G:Y' >0 EXIT
	5323	"RTN","XUP ",28,0)
	5324	S XUIOP(1 )=$P(Y,U,2 ) I DIC(0) ["A",$G(^V A(200,+DUZ ,0))]"" S $P(^VA(200 ,DUZ,1.2), U,1)=+Y
	5325	"RTN","XUP ",29,0)
	5326	ZIS2 S %ZI S="L",IOP= "HOME;"_XU IOP(1) D ^ %ZIS G EXI T:POP W !, "Terminal Type set t o: ",IOST, !
	5327	"RTN","XUP ",30,0)
	5328	S DTIME=$ $DTIME(DUZ ,IOS),DUZ( "BUF")=1,X UDEV=IOS
	5329	"RTN","XUP ",31,0)
	5330	S %=+$G(^ VA(200,DUZ ,.1)) I %> 0 S %=$P(^ XTV(8989.3 ,1,"XUS"), U,15)-($H- %) I %<14, %>0 W !!," Your VERIF Y code wil l expire i n "_%_" da ys",!!
	5331	"RTN","XUP ",32,0)
	5332	;Save inf o, Set las t sign-on
	5333	"RTN","XUP ",33,0)
	5334	D SAVE^XU S1 S $P(^V A(200,DUZ, 1.1),"^",1 )=$$NOW^XL FDT
	5335	"RTN","XUP ",34,0)
	5336	;Check Ma il
	5337	"RTN","XUP ",35,0)
	5338	S Y=$P($G (^XMB(3.7, DUZ,0)),U, 6) I Y W ! ,"You have "_Y_" new message"_ $S(Y=1:"", 1:"s")_"."
	5339	"RTN","XUP ",36,0)
	5340	;Setup er ror trap
	5341	"RTN","XUP ",37,0)
	5342	I $$GET^X PAR("USR^S YS","XUS-X UP SET ERR OR TRAP",1 ,"Q") S $E TRAP="D ER R^XUP"
	5343	"RTN","XUP ",38,0)
	5344	D KILL1^X USCLEAN S $P(XQXFLG, U,3)="XUP" D ^XQ1
	5345	"RTN","XUP ",39,0)
	5346	EXIT ;Clea n-up and e xit
	5347	"RTN","XUP ",40,0)
	5348	D KILL1^X USCLEAN K XQY,XQY0
	5349	"RTN","XUP ",41,0)
	5350	I $G(DUZ) >0,$$GET^X PAR("USR^S YS","XUS-X UP VPE",1, "Q"),$D(^% ZVEMS) X ^ %ZVEMS ;Ru n VPE
	5351	"RTN","XUP ",42,0)
	5352	Q
	5353	"RTN","XUP ",43,0)
	5354	;
	5355	"RTN","XUP ",44,0)
	5356	ASKDUZ ;As k for Acce ss Code
	5357	"RTN","XUP ",45,0)
	5358	N X
	5359	"RTN","XUP ",46,0)
	5360	;X XUEOFF S DIR(0)= "FO",DIR(" A")="Acces s Code" D ^DIR W ! X XUEON I $ D(DIRUT) S Y=-1 Q
	5361	"RTN","XUP ",47,0)
	5362	X XUEOFF W !,"Acces s Code: " S X=$$ACCE PT^XUS() X XUEON
	5363	"RTN","XUP ",48,0)
	5364	I X["^"!( '$L(X)) S Y=-1 Q
	5365	"RTN","XUP ",49,0)
	5366	S X=$$UP^ XLFSTR(X) S:X[":" XU TT=1,X=$P( X,":",1)_$ P(X,":",2)
	5367	"RTN","XUP ",50,0)
	5368	D ^XUSHSH S Y=$O(^V A(200,"A", X,0))
	5369	"RTN","XUP ",51,0)
	5370	K DUZ D D UZ(+Y)
	5371	"RTN","XUP ",52,0)
	5372	Q
	5373	"RTN","XUP ",53,0)
	5374	;
	5375	"RTN","XUP ",54,0)
	5376	DUZ(DA) ;B uild DUZ f or a user. Used by Mailman.
	5377	"RTN","XUP ",55,0)
	5378	;(p284) M ake the se tting of s everal DUZ parts con ditional.
	5379	"RTN","XUP ",56,0)
	5380	N Y
	5381	"RTN","XUP ",57,0)
	5382	S Y(0)=$G (^VA(200,+ DA,0)),Y(" XUS")=$G(^ XTV(8989.3 ,1,"XUS"))
	5383	"RTN","XUP ",58,0)
	5384	S DUZ=DA
	5385	"RTN","XUP ",59,0)
	5386	S:$G(DUZ( 0))'="@" D UZ(0)=$P(Y (0),"^",4)
	5387	"RTN","XUP ",60,0)
	5388	S DUZ(1)= "",DUZ("AG ")=$P($G(^ XTV(8989.3 ,1,0)),"^" ,8)
	5389	"RTN","XUP ",61,0)
	5390	S:'$G(DUZ (2)) DUZ(2 )=$O(^VA(2 00,DUZ,2,0 ))
	5391	"RTN","XUP ",62,0)
	5392	S:'DUZ(2) DUZ(2)=+$ P(Y("XUS") ,"^",17)
	5393	"RTN","XUP ",63,0)
	5394	S:'$L($G( DUZ("LANG" ))) DUZ("L ANG")=$P(Y ("XUS"),"^ ",7)
	5395	"RTN","XUP ",64,0)
	5396	Q
	5397	"RTN","XUP ",65,0)
	5398	;
	5399	"RTN","XUP ",66,0)
	5400	DTIME(E,D) ;Return D TIME value for user E, device D.
	5401	"RTN","XUP ",67,0)
	5402	N P
	5403	"RTN","XUP ",68,0)
	5404	S P=$P($G (^VA(200,+ $G(E),200) ),"^",10) S:P="" P=$ P($G(^%ZIS (1,+$G(D), "XUS")),"^ ",10) S:P= "" P=$P($G (^XTV(8989 .3,1,"XUS" )),"^",10)
	5405	"RTN","XUP ",69,0)
	5406	Q $S(P]"" :P,1:300)
	5407	"RTN","XUP ",70,0)
	5408	;
	5409	"RTN","XUP ",71,0)
	5410	ERR ;
	5411	"RTN","XUP ",72,0)
	5412	N %XUP U $P
	5413	"RTN","XUP ",73,0)
	5414	W !,"$ECO DE=",$ECOD E," $STA CK=",$STAC K
	5415	"RTN","XUP ",74,0)
	5416	W !,"Loca tion: ",$S TACK($STAC K-1,"PLACE ")
	5417	"RTN","XUP ",75,0)
	5418	R !!,"Wan t to recor d the erro r: No// ", %XUP:600 I "Yy"[$E(% XUP_"N") D ^%ZTER
	5419	"RTN","XUP ",76,0)
	5420	D UNWIND^ %ZTER ;S:' $ESTACK $E CODE="" S $ETRAP="" Q:$QUIT "" Q
	5421	"RTN","XUS ")
	5422	0^7^B35560 117^B31567 708
	5423	"RTN","XUS ",1,0)
	5424	XUS ;SFISC /STAFF - S IGNON ;09/ 22/15 09: 24
	5425	"RTN","XUS ",2,0)
	5426	;;8.0;KER NEL;*16,2 6,49,59,14 9,180,265, 337,419,43 4,584,659 *;Jul 10, 1995;Build 22
	5427	"RTN","XUS ",3,0)
	5428	;Per VA D irective 6 402, this routine sh ould not b e modified .
	5429	"RTN","XUS ",4,0)
	5430	;
	5431	"RTN","XUS ",5,0)
	5432	;Sign-on message nu mbers are 30810.51 t o 30810.99
	5433	"RTN","XUS ",6,0)
	5434	S U="^" D INTRO^XUS 1A()
	5435	"RTN","XUS ",7,0)
	5436	K K ^XUT L("ZISPARA M",$I)
	5437	"RTN","XUS ",8,0)
	5438	S U="^",X QXFLG("GUI ")="^"
	5439	"RTN","XUS ",9,0)
	5440	W ! S $Y= 0 D SET1(1 ) I POP S XUM=3 G NO ;Sets DUZ ("LANG")
	5441	"RTN","XUS ",10,0)
	5442	S XUSTMP( 51)=$$EZBL D^DIALOG(3 0810.51),X USTMP(52)= $$EZBLD^DI ALOG(30810 .52)
	5443	"RTN","XUS ",11,0)
	5444	W !!,"Vol ume set: " ,$P(XUENV, U,4)," UC I: ",XUCI, " Device: ",$I W:$S ('$D(IO("Z IO")):0,1: $I'=IO("ZI O")) " (", IO("ZIO"), ")" W !
	5445	"RTN","XUS ",12,0)
	5446	RESTART ;
	5447	"RTN","XUS ",13,0)
	5448	S XUM=$$S ET2 G:XUM NO
	5449	"RTN","XUS ",14,0)
	5450	I $P(XU1, U,2)]"" S XUM=$$DEVP AS() I XUM G H:XUM<0 ,NO
	5451	"RTN","XUS ",15,0)
	5452	A S (XUSER (0),XUSER( 1),XQUR)=" "
	5453	"RTN","XUS ",16,0)
	5454	;Check fo r locked I P/device.
	5455	"RTN","XUS ",17,0)
	5456	I $$LKCHE CK^XUSTZIP () S XUM=7 ,XUFAC=$P( XOPT,U,2), XUHALT=1 G NO
	5457	"RTN","XUS ",18,0)
	5458	I $G(DUZ( "LOA"))="" S DUZ("LO A")=2,DUZ( "AUTHENTIC ATION")="A VCODES"
	5459	"RTN","XUS ",19,0)
	5460	;Auto Sig n-on check
	5461	"RTN","XUS ",20,0)
	5462	S X=$$AUT OXUS^XUS1B () I X>0 S DUZ=X,DUZ ("AUTHENTI CATION")=" ASHTOKEN" D USER(DUZ ) W !!,">> Auto Sign -on: ",$P( XUSER(0),U )," <<<",! G B
	5463	"RTN","XUS ",21,0)
	5464	X XUEOFF S AV=$$ASK AV() X XUE ON I AV="^ ;^" G H ;G et out
	5465	"RTN","XUS ",22,0)
	5466	I AV["MAI L-BOX",AV[ ";XMR" S ( XUA,PGM)=" XMR",XMCHA N=$P($P(AV ,";")," ", 2),DUZ=.5 G XMR^XUSC LEAN
	5467	"RTN","XUS ",23,0)
	5468	S XQUR=$P (AV,";",3)
	5469	"RTN","XUS ",24,0)
	5470	S DUZ=$$C HECKAV(AV) K AV
	5471	"RTN","XUS ",25,0)
	5472	S XUM=$$U VALID() G: XUM NO
	5473	"RTN","XUS ",26,0)
	5474	B K XUF,%1 S XUF=0 X XUEON
	5475	"RTN","XUS ",27,0)
	5476	I DUZ D U SER^XUS1 G :XUM NO
	5477	"RTN","XUS ",28,0)
	5478	I DUZ D S EC^XUS3:($ D(^%ZIS(1, XUDEV,"TIM E"))!$D(^( 95))) G:XU M NO
	5479	"RTN","XUS ",29,0)
	5480	G NO:'DUZ
	5481	"RTN","XUS ",30,0)
	5482	S DTIME=$ P(XOPT,U,1 0),X=$S(DU Z("BUF"):" ",1:"NO-") _"TYPE-AHE AD" X:$D(^ %ZOSF(X)) ^(X)
	5483	"RTN","XUS ",31,0)
	5484	D TT^XUS3 :$G(XUTT)
	5485	"RTN","XUS ",32,0)
	5486	D CLRFAC^ XUS3($G(IO ("IP")))
	5487	"RTN","XUS ",33,0)
	5488	PGM ;
	5489	"RTN","XUS ",34,0)
	5490	S Y=+$G(^ %ZIS(1,XUD EV,201)) I Y>0,$$CHK S XQY=Y G OK
	5491	"RTN","XUS ",35,0)
	5492	S Y=+$G(^ VA(200,DUZ ,201)) I Y >0,$$CHK S XQY=Y G O K
	5493	"RTN","XUS ",36,0)
	5494	I $D(DUZ( "ASH")) S Y=$O(^DIC( 19,"B","XU NOP MENU" ,0)) I Y>0 S XQY=Y G OK ;rwf 4 03
	5495	"RTN","XUS ",37,0)
	5496	S XUM=16
	5497	"RTN","XUS ",38,0)
	5498	G NO
	5499	"RTN","XUS ",39,0)
	5500	;
	5501	"RTN","XUS ",40,0)
	5502	OK D CHEK^ XQ83
	5503	"RTN","XUS ",41,0)
	5504	S (XUA,PG M)="XQ"
	5505	"RTN","XUS ",42,0)
	5506	G NEXT^XU S1
	5507	"RTN","XUS ",43,0)
	5508	;
	5509	"RTN","XUS ",44,0)
	5510	CHK() ;Che ck that op tion exist s and LOCK
	5511	"RTN","XUS ",45,0)
	5512	I $D(^DIC (19,Y,0)), $S($P(^(0) ,U,6)="":1 ,1:$D(^XUS EC($P(^(0) ,U,6),DUZ) )) Q 1
	5513	"RTN","XUS ",46,0)
	5514	Q 0
	5515	"RTN","XUS ",47,0)
	5516	;
	5517	"RTN","XUS ",48,0)
	5518	LC S X=$$U P(X)
	5519	"RTN","XUS ",49,0)
	5520	Q
	5521	"RTN","XUS ",50,0)
	5522	UP(%) Q $T R(%,"abcde fghijklmno pqrstuvwxy z","ABCDEF GHIJKLMNOP QRSTUVWXYZ ")
	5523	"RTN","XUS ",51,0)
	5524	;
	5525	"RTN","XUS ",52,0)
	5526	FAC ;Faile d access
	5527	"RTN","XUS ",53,0)
	5528	S:'DUZ XU F(.1)=$E(% 1)
	5529	"RTN","XUS ",54,0)
	5530	S:XUF=2 X UF(.2)=XUF (.2)+1,XUF (XUF(.2))= %1 S %1="" Q
	5531	"RTN","XUS ",55,0)
	5532	Q
	5533	"RTN","XUS ",56,0)
	5534	NO ;Tell w hy didn't get on
	5535	"RTN","XUS ",57,0)
	5536	S X=$$NO^ XUS3() G R ESTART:'X ;fall into exit
	5537	"RTN","XUS ",58,0)
	5538	H ;Exit po int for al l applicat ions
	5539	"RTN","XUS ",59,0)
	5540	C ;CLOSE
	5541	"RTN","XUS ",60,0)
	5542	G ^XUSCLE AN
	5543	"RTN","XUS ",61,0)
	5544	;
	5545	"RTN","XUS ",62,0)
	5546	ON X ^%ZOS F("EON") Q
	5547	"RTN","XUS ",63,0)
	5548	;
	5549	"RTN","XUS ",64,0)
	5550	ASKAV(PRE) ;Ask and return Acc ess;Verify code, Tur n off echo before ca lling
	5551	"RTN","XUS ",65,0)
	5552	N X,Y S P RE=$G(PRE)
	5553	"RTN","XUS ",66,0)
	5554	F W !,PR E,XUSTMP(5 1) S X=$$A CCEPT S:X= "^" X="^;^ " Q:$L(X)
	5555	"RTN","XUS ",67,0)
	5556	S X=$TR(X ,$C(9),";" ) ;Convert TAB to ; to match G UI.
	5557	"RTN","XUS ",68,0)
	5558	I $P(X," ")="MAIL-B OX" S X=X_ ";XMR"
	5559	"RTN","XUS ",69,0)
	5560	I $E(X,1, 7)="~~TOK~ ~" Q X ;Us e CCOW tok en
	5561	"RTN","XUS ",70,0)
	5562	I '$L($P( X,";",2)) W !,PRE,XU STMP(52) S Y=$$ACCEP T S:Y="^" X="^;" S $ P(X,";",2) =Y
	5563	"RTN","XUS ",71,0)
	5564	Q X
	5565	"RTN","XUS ",72,0)
	5566	;
	5567	"RTN","XUS ",73,0)
	5568	;Timeout used by XU STZ call.
	5569	"RTN","XUS ",74,0)
	5570	ACCEPT(TO) ;Read A/V and echo '*' char.
	5571	"RTN","XUS ",75,0)
	5572	;Have the Read writ e to flush the buffe r on some systems
	5573	"RTN","XUS ",76,0)
	5574	N C,A,E K DUOUT S A ="",TO=$G( TO,60),E=0
	5575	"RTN","XUS ",77,0)
	5576	F D Q:E
	5577	"RTN","XUS ",78,0)
	5578	. R "",*C :TO S:('$T ) DUOUT=1 S:('$T)!(C =94) A="^"
	5579	"RTN","XUS ",79,0)
	5580	. I (A="^ ")!(C=13)! ($L(A)>60) S E=1 Q
	5581	"RTN","XUS ",80,0)
	5582	. I C=127 Q:'$L(A) S A=$E(A, 1,$L(A)-1) W $C(8,32 ,8) Q
	5583	"RTN","XUS ",81,0)
	5584	. S A=A_$ C(C) W *42
	5585	"RTN","XUS ",82,0)
	5586	. Q
	5587	"RTN","XUS ",83,0)
	5588	Q A
	5589	"RTN","XUS ",84,0)
	5590	;
	5591	"RTN","XUS ",85,0)
	5592	CHECKAV(X1 ) ;Check A /V code re turn DUZ o r Zero. (C alled from XUSRB)
	5593	"RTN","XUS ",86,0)
	5594	N %,%1,X, Y,IEN,DA,D IK
	5595	"RTN","XUS ",87,0)
	5596	S IEN=0
	5597	"RTN","XUS ",88,0)
	5598	;Start CC OW
	5599	"RTN","XUS ",89,0)
	5600	I $E(X1,1 ,7)="~~TOK ~~" D Q:I EN>0 IEN
	5601	"RTN","XUS ",90,0)
	5602	. I $E(X1 ,8,9)="~1" S IEN=$$C HKASH^XUSR B4($E(X1,8 ,255)),DUZ ("AUTHENTI CATION")=" ASHTOKEN"
	5603	"RTN","XUS ",91,0)
	5604	. I $E(X1 ,8,9)="~2" S IEN=$$C HKCCOW^XUS RB4($E(X1, 8,255)),DU Z("AUTHENT ICATION")= "CCOWTOKEN "
	5605	"RTN","XUS ",92,0)
	5606	. Q
	5607	"RTN","XUS ",93,0)
	5608	;End CCOW
	5609	"RTN","XUS ",94,0)
	5610	S X1=$$UP (X1) S:X1[ ":" XUTT=1 ,X1=$TR(X1 ,":")
	5611	"RTN","XUS ",95,0)
	5612	S X=$P(X1 ,";") Q:X= "^" -1 S:X UF %1="Acc ess: "_X
	5613	"RTN","XUS ",96,0)
	5614	Q:X'?1.20 ANP 0
	5615	"RTN","XUS ",97,0)
	5616	S X=$$EN^ XUSHSH(X) I '$D(^VA( 200,"A",X) ) D LBAV Q 0
	5617	"RTN","XUS ",98,0)
	5618	S %1="",I EN=$O(^VA( 200,"A",X, 0)),XUF(.3 )=IEN D US ER(IEN)
	5619	"RTN","XUS ",99,0)
	5620	S X=$P(X1 ,";",2) S: XUF %1="Ve rify: "_X S X=$$EN^X USHSH(X)
	5621	"RTN","XUS ",100,0)
	5622	I $P(XUSE R(1),"^",2 )'=X D LBA V Q 0
	5623	"RTN","XUS ",101,0)
	5624	I $G(XUFA C(1)) S DI K="^XUSEC( 4,",DA=XUF AC(1) D ^D IK
	5625	"RTN","XUS ",102,0)
	5626	I $G(DUZ( "AUTHENTIC ATION"))=" " S DUZ("A UTHENTICAT ION")="AVC ODES"
	5627	"RTN","XUS ",103,0)
	5628	Q IEN
	5629	"RTN","XUS ",104,0)
	5630	LBAV ;Log Bad AV
	5631	"RTN","XUS ",105,0)
	5632	D:XUF FAC
	5633	"RTN","XUS ",106,0)
	5634	I IEN S X =$P($G(^VA (200,IEN,1 .1)),U,2)+ 1,$P(^(1.1 ),"^",2)=X
	5635	"RTN","XUS ",107,0)
	5636	Q
	5637	"RTN","XUS ",108,0)
	5638	;
	5639	"RTN","XUS ",109,0)
	5640	USER(IX) ; Build XUSE R
	5641	"RTN","XUS ",110,0)
	5642	S XUSER(0 )=$G(^VA(2 00,+IX,0)) ,XUSER(1)= $G(^(.1)), XUSER(1.1) =$G(^(1.1) )
	5643	"RTN","XUS ",111,0)
	5644	Q
	5645	"RTN","XUS ",112,0)
	5646	;
	5647	"RTN","XUS ",113,0)
	5648	XUVOL ;Set up XUENV, XUCI,XQVOL ,XUVOL,XUO SVER
	5649	"RTN","XUS ",114,0)
	5650	S U="^" D GETENV^%Z OSV S XUEN V=Y,XUCI=$ P(Y,U,1),X QVOL=$P(Y, U,2),XUOSV ER=$$VERSI ON^%ZOSV
	5651	"RTN","XUS ",115,0)
	5652	S X=$O(^X TV(8989.3, 1,4,"B",XQ VOL,0)),XU VOL=$S(X>0 :^XTV(8989 .3,1,4,X,0 ),1:XQVOL_ "^y^1")
	5653	"RTN","XUS ",116,0)
	5654	Q
	5655	"RTN","XUS ",117,0)
	5656	;
	5657	"RTN","XUS ",118,0)
	5658	XOPT ;Setu p initial XOPT
	5659	"RTN","XUS ",119,0)
	5660	S XOPT=$S ($D(^XTV(8 989.3,1,"X US")):^("X US"),1:"")
	5661	"RTN","XUS ",120,0)
	5662	F I=2:1:1 5 I $P(XOP T,U,I)="" S $P(XOPT, U,I)=$P("^ 5^900^1^1^ ^^^1^300^^ ^^N^90",U, I)
	5663	"RTN","XUS ",121,0)
	5664	Q
	5665	"RTN","XUS ",122,0)
	5666	;
	5667	"RTN","XUS ",123,0)
	5668	SET1(FLAG) ;Setup pa rameters ( also calle d from XUS RB)
	5669	"RTN","XUS ",124,0)
	5670	N %
	5671	"RTN","XUS ",125,0)
	5672	S U="^",X UEON=^%ZOS F("EON"),X UEOFF=^("E OFF")
	5673	"RTN","XUS ",126,0)
	5674	D XUVOL,X OPT S DUZ( "LANG")=$P (XOPT,U,7) ;S:$P(XUV OL,U,6)="y " XRTL=XUC I_","_XQVO L
	5675	"RTN","XUS ",127,0)
	5676	K ^XUTL(" XQ",$J) S XUF=0,XUDE V=0,DUZ=0, DUZ(0)="@" ,IOS=0,ION =""
	5677	"RTN","XUS ",128,0)
	5678	I FLAG S %ZIS="L",I OP="HOME" D ^%ZIS Q: POP
	5679	"RTN","XUS ",129,0)
	5680	S XUDEV=I OS,XUIOP=I ON
	5681	"RTN","XUS ",130,0)
	5682	D GETFAC^ XUS3($G(IO ("IP")))
	5683	"RTN","XUS ",131,0)
	5684	S %=$P(XO PT,U,14)
	5685	"RTN","XUS ",132,0)
	5686	I "N"'[% D
	5687	"RTN","XUS ",133,0)
	5688	. S XUF=( %["R")+1,X UF(.1)="", XUF(.2)=0, XUF(.3)=0
	5689	"RTN","XUS ",134,0)
	5690	. I %["D" S:$D(^XTV (8989.3,1, 4.33,"B",X UDEV))[0 X UF=0
	5691	"RTN","XUS ",135,0)
	5692	S DILOCKT M=+$G(^DD( "DILOCKTM" ),1) ;p434 IA#4909
	5693	"RTN","XUS ",136,0)
	5694	Q
	5695	"RTN","XUS ",137,0)
	5696	SET2() ;EF . Return e rror code (also call ed from XU SRB)
	5697	"RTN","XUS ",138,0)
	5698	N %,X
	5699	"RTN","XUS ",139,0)
	5700	S XUNOW=$ $HTFM^XLFD T($H),DT=$ P(XUNOW,". ")
	5701	"RTN","XUS ",140,0)
	5702	K DUZ,XUS ER
	5703	"RTN","XUS ",141,0)
	5704	S (DUZ,DU Z(2))=0,(D UZ(0),DUZ( "AG"),XUSE R(0),XUSER (1),XUTT,% UCI)=""
	5705	"RTN","XUS ",142,0)
	5706	S %=$$INH IBIT^XUSRB () I %>0 Q %
	5707	"RTN","XUS ",143,0)
	5708	S X=$G(^% ZIS(1,XUDE V,"XUS")), XU1=$G(^(1 ))
	5709	"RTN","XUS ",144,0)
	5710	I $L(X) F I=1:1:15 I $L($P(X, U,I)) S $P (XOPT,U,I) =$P(X,U,I)
	5711	"RTN","XUS ",145,0)
	5712	S DTIME=6 00
	5713	"RTN","XUS ",146,0)
	5714	I '$P(XOP T,U,11),$D (^%ZIS(1,X UDEV,90)), ^(90)>2800 000,^(90)' >DT Q 8
	5715	"RTN","XUS ",147,0)
	5716	Q 0
	5717	"RTN","XUS ",148,0)
	5718	;
	5719	"RTN","XUS ",149,0)
	5720	UVALID() ; EF. Is it valid for this user to sign on ?
	5721	"RTN","XUS ",150,0)
	5722	;ZEXCEPT: XUM,XUNOW ,XUSER ;gl obal Kerne l variable s used dur ing sign-o n
	5723	"RTN","XUS ",151,0)
	5724	I DUZ'>0 Q 4
	5725	"RTN","XUS ",152,0)
	5726	I $P(XUSE R(1.1),U,5 ),$P(XUSER (1.1),U,5) >XUNOW S X UM(0)=$$FM TE^XLFDT($ P(XUSER(1. 1),U,5),"2 PM") Q 18 ;User lock ed until
	5727	"RTN","XUS ",153,0)
	5728	I $P(XUSE R(0),U,11) ,$P(XUSER( 0),U,11)'> DT Q 11 ;A ccess Term inated
	5729	"RTN","XUS ",154,0)
	5730	I $D(DUZ( "ASH")) Q 0 ;If auto handle, A llow to si gn-on p434
	5731	"RTN","XUS ",155,0)
	5732	I $P(XUSE R(0),U,7) Q 5 ;Disus er flag se t
	5733	"RTN","XUS ",156,0)
	5734	I ('$L($P (XUSER(1), U,2)))&('( $G(DUZ("AU THENTICATI ON"))="SSO E"))&('($G (DUZ("AUTH ENTICATION "))="M4A") ) Q 21 ;Nu ll verify code not a llowed p41 9
	5735	"RTN","XUS ",157,0)
	5736	Q 0
	5737	"RTN","XUS ",158,0)
	5738	;
	5739	"RTN","XUS ",159,0)
	5740	DEVPAS() ; EF. Ask de vice passw ord
	5741	"RTN","XUS ",160,0)
	5742	X XUEOFF W !,"DEVIC E PASSWORD : " R X:60 X XUEON
	5743	"RTN","XUS ",161,0)
	5744	S X=$E(X, 1,30) S:'$ T X="^" D LC Q:X["^" -1 I $P(X U1,U,2)'=X S:XUF %1= "Device: " _X D:XUF F AC Q 6
	5745	"RTN","XUS ",162,0)
	5746	Q 0
	5747	"RTN","XUS ",163,0)
	5748	;
	5749	"RTN","XUS 1")
	5750	0^10^B2913 2312^B2856 8204
	5751	"RTN","XUS 1",1,0)
	5752	XUS1 ;SF-I SC/STAFF - SIGNON ;0 9/22/15 0 8:33
	5753	"RTN","XUS 1",2,0)
	5754	;;8.0;KER NEL;9,59 ,111,165,1 50,252,265 ,419,469,5 23,543,638 ,659;Jul 10, 1995; Build 22
	5755	"RTN","XUS 1",3,0)
	5756	;Per VA D irective 6 402, this routine sh ould not b e modified .
	5757	"RTN","XUS 1",4,0)
	5758	;User set up
	5759	"RTN","XUS 1",5,0)
	5760	USER ;
	5761	"RTN","XUS 1",6,0)
	5762	K XUTEXT S XUM=$$US ER^XUS1A() ,$Y=0
	5763	"RTN","XUS 1",7,0)
	5764	;Show pos t sign-on text
	5765	"RTN","XUS 1",8,0)
	5766	F I=0:0 S I=$O(XUTE XT(I)) Q:I '>0 D:$Y> 20 W:$E(X UTEXT(I),1 )="!" ! W $E(XUTEXT( I),2,999)
	5767	"RTN","XUS 1",9,0)
	5768	. N DIR S DIR(0)="E ",DIR("A") ="Enter RE TURN to co ntinue" D ^DIR W @IO F Q
	5769	"RTN","XUS 1",10,0)
	5770	;if XUM=9 multi sig n-on NOT a llowed
	5771	"RTN","XUS 1",11,0)
	5772	I XUM=9 W !!,?8,$$E ZBLD^DIALO G(30810.45 )
	5773	"RTN","XUS 1",12,0)
	5774	Q:XUM ;U ser can't sign-on.
	5775	"RTN","XUS 1",13,0)
	5776	SET ;
	5777	"RTN","XUS 1",14,0)
	5778	S Y=$$CHK DIV()
	5779	"RTN","XUS 1",15,0)
	5780	I $P(Y,U, 2)>0,$D(^D IC(4,0)) D ASKDIV
	5781	"RTN","XUS 1",16,0)
	5782	S DUZ(2)= +Y D DUZ^X US1A
	5783	"RTN","XUS 1",17,0)
	5784	;Check ve rify code
	5785	"RTN","XUS 1",18,0)
	5786	I $$VCHG D CVC^XUS2 G:$D(DUOU T) H^XUS
	5787	"RTN","XUS 1",19,0)
	5788	S:$P(XOPT ,"^",5) XU TT=1 ;Ask Device
	5789	"RTN","XUS 1",20,0)
	5790	D ENQ ;In quire to T erminal Ty pe
	5791	"RTN","XUS 1",21,0)
	5792	Q
	5793	"RTN","XUS 1",22,0)
	5794	;
	5795	"RTN","XUS 1",23,0)
	5796	VCHG() ;Ch eck if the Verify co de needs t o be chang ed
	5797	"RTN","XUS 1",24,0)
	5798	I $D(DUZ( "ASH")) Q 0 ;p403
	5799	"RTN","XUS 1",25,0)
	5800	D:'$D(XUS ER) USER^X US(DUZ)
	5801	"RTN","XUS 1",26,0)
	5802	Q:'$L($P( XUSER(1),U ,2)) 1 ;Nu ll VC
	5803	"RTN","XUS 1",27,0)
	5804	I $$BROKE R^XWBLIB Q :$P(XUSER( 0),U,8)=1 0 ;VC neve r expires, only for BROKER
	5805	"RTN","XUS 1",28,0)
	5806	Q (XUSER( 1)+$P(XOPT ,U,15))'>$ H ;Time to change
	5807	"RTN","XUS 1",29,0)
	5808	;
	5809	"RTN","XUS 1",30,0)
	5810	ASKDIV ;As k the user for the D ivision, r eturn Y
	5811	"RTN","XUS 1",31,0)
	5812	N X
	5813	"RTN","XUS 1",32,0)
	5814	S DIC="^V A(200,DUZ, 2,",DIC(0) ="AEQ",DIC ("P")="200 .02P",X=$O (^VA(200,D UZ,2,"AX1" ,1,0)) S:X >0 DIC("B" )=$P($$NS^ XUAF4(X),U )
	5815	"RTN","XUS 1",33,0)
	5816	D ^DIC I Y'>0 W !,* 7,"You mus t select o ne." G ASK DIV
	5817	"RTN","XUS 1",34,0)
	5818	Q
	5819	"RTN","XUS 1",35,0)
	5820	;
	5821	"RTN","XUS 1",36,0)
	5822	CHKDIV(CD) ;ef,sr Ch eck if use r needs to select Di vision.
	5823	"RTN","XUS 1",37,0)
	5824	N %,%1,%2 ,%3,%4
	5825	"RTN","XUS 1",38,0)
	5826	I $G(DUZ( "DIV"))>0 Q DUZ("DIV ") ;p469 S et outside
	5827	"RTN","XUS 1",39,0)
	5828	S %=$O(^V A(200,DUZ, 2,0)),%1=$ O(^(%))
	5829	"RTN","XUS 1",40,0)
	5830	I %1,$D(C D) D
	5831	"RTN","XUS 1",41,0)
	5832	. S %2=0, %3=0,CD=0
	5833	"RTN","XUS 1",42,0)
	5834	. F S %2 =$O(^VA(20 0,DUZ,2,%2 )) Q:%2'>0 S %4=^(% 2,0),%3=%3 +1,CD(%3)= %2_"^"_$$N S^XUAF4(%2 )_$S($P(%4 ,"^",2):"^ 1",1:"")
	5835	"RTN","XUS 1",43,0)
	5836	. S CD=%3
	5837	"RTN","XUS 1",44,0)
	5838	Q %_"^"_% 1
	5839	"RTN","XUS 1",45,0)
	5840	;
	5841	"RTN","XUS 1",46,0)
	5842	ENQ ;Get t erminal ty pe
	5843	"RTN","XUS 1",47,0)
	5844	S XUT1="" I XUTT X XUEOFF R X :0 X ^%ZOS F("TYPE-AH EAD") W $C (27,91,99) X "R *X:2 I X=27 F R X#1:2 S XUT1=XUT1 _X Q:'$T!( X=""c"")"
	5845	"RTN","XUS 1",48,0)
	5846	;Removed code for W yse 75
	5847	"RTN","XUS 1",49,0)
	5848	X XUEON I XUTT,XUT1 ["[" S Y=$ O(^%ZIS(3. 22,"B",XUT 1,0)) I Y> 0 S X=$P($ G(^%ZIS(3. 22,Y,0))," ^",2)
	5849	"RTN","XUS 1",50,0)
	5850	I X?1.ANP S DIC="^% ZIS(2,",DI C(0)="MO" D ^DIC I Y >0 S XUIOP (1)=$P(Y,U ,2),$P(XUI OP,";",2)= XUIOP(1),^ VA(200,DUZ ,1.2)=+Y
	5851	"RTN","XUS 1",51,0)
	5852	I '$D(XUI OP(1)),$D( ^VA(200,DU Z,1.2)) S X=+^(1.2) I X>0,$D(^ %ZIS(2,X,0 )) S $P(XU IOP,";",2) =$P(^(0),U )
	5853	"RTN","XUS 1",52,0)
	5854	Q
	5855	"RTN","XUS 1",53,0)
	5856	;
	5857	"RTN","XUS 1",54,0)
	5858	NEXT ;Jump to the ne xt routine
	5859	"RTN","XUS 1",55,0)
	5860	S IOP=XUI OP D ^%ZIS D SAVE ;S ave off de vice/user info
	5861	"RTN","XUS 1",56,0)
	5862	S X=$G(^D ISV(DUZ)) ;Add kill by session or day he re
	5863	"RTN","XUS 1",57,0)
	5864	S ^DISV(D UZ)=$H
	5865	"RTN","XUS 1",58,0)
	5866	;Removed UCI jump p 469
	5867	"RTN","XUS 1",59,0)
	5868	D AUDIT
	5869	"RTN","XUS 1",60,0)
	5870	S X=$S($D (^VA(200,D UZ,0)):$P( $P(^(0),U) ,","),1:"U nk"),X=$E( X,1,10)_"_ "_($J#1000 0) D SETEN V^%ZOSV ;S et Process Name
	5871	"RTN","XUS 1",61,0)
	5872	;S X=$P(X OPT,U,16) X:X ^%ZOSF ("PRIORITY ")
	5873	"RTN","XUS 1",62,0)
	5874	D LOG:DUZ ,KILL
	5875	"RTN","XUS 1",63,0)
	5876	K ^XUTL(" OR",$J),^U TILITY($J) ,%UCI
	5877	"RTN","XUS 1",64,0)
	5878	G ^XQ
	5879	"RTN","XUS 1",65,0)
	5880	;
	5881	"RTN","XUS 1",66,0)
	5882	SAVE ;
	5883	"RTN","XUS 1",67,0)
	5884	N X
	5885	"RTN","XUS 1",68,0)
	5886	S X="DUZ" F S X=$Q (@X) Q:X=" " I $D(@X ) S ^XUTL( "XQ",$J,$T R(X,"""")) =@X
	5887	"RTN","XUS 1",69,0)
	5888	F X="DUZ" ,"IO","IO( ""IP"")"," IO(""CLNM" ")","XQVOL " I $D(@X) S ^XUTL(" XQ",$J,X)= @X
	5889	"RTN","XUS 1",70,0)
	5890	D SAVEVAR ^%ZIS ;Sav e the HOME device va riables
	5891	"RTN","XUS 1",71,0)
	5892	Q
	5893	"RTN","XUS 1",72,0)
	5894	;
	5895	"RTN","XUS 1",73,0)
	5896	LOG ;used by R/S and Broker
	5897	"RTN","XUS 1",74,0)
	5898	N %,XP1,X P2
	5899	"RTN","XUS 1",75,0)
	5900	S XQXFLG( "LLOG")=$P ($G(^VA(20 0,DUZ,1.1) ),U) ;Save for LOGIN templates
	5901	"RTN","XUS 1",76,0)
	5902	S XP1=$$S LOG($P(XUV OL,U,1),,X UDEV,XUCI, $P(XUENV,U ,3))
	5903	"RTN","XUS 1",77,0)
	5904	S %=$$COO KIE($P(^VA (200,DUZ,0 ),U),XP1) I $L(%) S XQXFLG("ZE BRA")=XP1_ "~"_%,$P(^ XUSEC(0,XP 1,0),U,13) =% L +^XWB ("SESSION" ,XQXFLG("Z EBRA")):60
	5905	"RTN","XUS 1",78,0)
	5906	Q
	5907	"RTN","XUS 1",79,0)
	5908	;
	5909	"RTN","XUS 1",80,0)
	5910	;Division updated i n DIVSET^X USRB2
	5911	"RTN","XUS 1",81,0)
	5912	;The othe r paramete rs are in the symbol table wit h known na mes.
	5913	"RTN","XUS 1",82,0)
	5914	;P1=DUZ,P 2=$I,P3=$J ,P4=EXIT D /T,P5=VOLU ME,P6=TASK MAN,P7=XUD EV,P8=UCI, P9=ZIO,P10 =NODE,P11= IPV4,P12=C LNM,P13=HA NDLE,P14=R EMOTE SITE ,P15=REMOT E IEN
	5915	"RTN","XUS 1",83,0)
	5916	;P100=IPV 6,P101=LOA
	5917	"RTN","XUS 1",84,0)
	5918	SLOG(P5,P6 ,P7,P8,P10 ,P14,P15) ;
	5919	"RTN","XUS 1",85,0)
	5920	;ZEXCEPT: DILOCKTM ;Global va riable for lock time out
	5921	"RTN","XUS 1",86,0)
	5922	;p638 Cha nges: Save IPv4 addr ess in fie ld 11 (0;1 1) and IPv 6 address in field 1 00 (1;1)
	5923	"RTN","XUS 1",87,0)
	5924	N %,I,DA, DIK,N,XL1, XL2,P11,P1 2,P100,P10 1
	5925	"RTN","XUS 1",88,0)
	5926	S XL1=$$N OW^XLFDT
	5927	"RTN","XUS 1",89,0)
	5928	S P5=$G(P 5),P6=$G(P 6),P7=$G(P 7),P8=$G(P 8),P10=$P( $G(P10),". ")
	5929	"RTN","XUS 1",90,0)
	5930	S P11=$$F ORCEIP4^XL FIPV($G(IO ("IP"))),P 100=$$FORC EIP6^XLFIP V($G(IO("I P")))
	5931	"RTN","XUS 1",91,0)
	5932	S P12=$P( $G(IO("CLN M")),".")
	5933	"RTN","XUS 1",92,0)
	5934	I P11="0. 0.0.0" S P 11="" ;Do not store null IPv4 address
	5935	"RTN","XUS 1",93,0)
	5936	I P100="0 000:0000:0 000:0000:0 000:0000:0 000:0000" S P100="" ;Do not s tore null IPv6 addre ss
	5937	"RTN","XUS 1",94,0)
	5938	S P101=$G (DUZ("LOA" ))
	5939	"RTN","XUS 1",95,0)
	5940	S N=DUZ_" ^"_$I_"^"_ $J_"^^"_P5 _"^"_P6_"^ "_P7_"^"_P 8_"^"_$E($ G(IO("ZIO" )),1,30)_" ^"_P10_"^" _P11_"^"_P 12
	5941	"RTN","XUS 1",96,0)
	5942	S:$D(DUZ( "VISITOR") ) $P(N,U,1 4,15)=DUZ( "VISITOR") ;p523
	5943	"RTN","XUS 1",97,0)
	5944	S:$G(DUZ( 2))>0 $P(N ,U,17)=DUZ (2)
	5945	"RTN","XUS 1",98,0)
	5946	S:$D(DUZ( "REMAPP")) $P(N,U,18 )=$P(DUZ(" REMAPP"),U ) ;p523
	5947	"RTN","XUS 1",99,0)
	5948	F I=XL1:. 00000001 L +^XUSEC(0 ,I):$G(DIL OCKTM,5) Q :'$D(^XUSE C(0,I)) L -^XUSEC(0 ,I)
	5949	"RTN","XUS 1",100,0)
	5950	S ^XUSEC( 0,I,0)=N
	5951	"RTN","XUS 1",101,0)
	5952	S ^XUSEC( 0,I,1)=P10 0_"^"_P101 ;Save IPv 6 address and Level Of Assuran ce
	5953	"RTN","XUS 1",102,0)
	5954	L -^XUSEC (0,I)
	5955	"RTN","XUS 1",103,0)
	5956	S $P(^XUS EC(0,0),"^ ",3,4)=I_U _(1+$P(^XU SEC(0,0)," ^",4))
	5957	"RTN","XUS 1",104,0)
	5958	S (XL1,DA )=I,DIK="^ XUSEC(0," D IX^DIK ; index new entry
	5959	"RTN","XUS 1",105,0)
	5960	S ^XUTL(" XQ",$J,0)= XL1 ;save for sign-o ff
	5961	"RTN","XUS 1",106,0)
	5962	I 'P6 S X L2=$G(^VA( 200,DUZ,1. 1)),$P(XL2 ,U,1,3)=XL 1_"^0^1",$ P(XL2,U,5) ="",^VA(20 0,DUZ,1.1) =XL2 ;Set last Sign -on
	5963	"RTN","XUS 1",107,0)
	5964	Q XL1
	5965	"RTN","XUS 1",108,0)
	5966	;
	5967	"RTN","XUS 1",109,0)
	5968	COOKIE(J1, J2) ;Call VAdeamon f or a cooki e
	5969	"RTN","XUS 1",110,0)
	5970	N ZZ,%
	5971	"RTN","XUS 1",111,0)
	5972	I $G(XQXF LG("ZEBRA" ))=-1 K XQ XFLG("ZEBR A") Q "" ; Disabled
	5973	"RTN","XUS 1",112,0)
	5974	Q:$G(IO(" IP"))="" " " ;Not usi ng Telnet or SSH
	5975	"RTN","XUS 1",113,0)
	5976	Q:$D(DUZ( "VISITOR") ) "" ;Don' t create H andles for visitors p523
	5977	"RTN","XUS 1",114,0)
	5978	;
	5979	"RTN","XUS 1",115,0)
	5980	S %=$$CMD ^XWBCAGNT( .ZZ,"XWB C REATE HAND LE",J1_"^" _J2) Q:'% ""
	5981	"RTN","XUS 1",116,0)
	5982	Q $G(ZZ(1 ))
	5983	"RTN","XUS 1",117,0)
	5984	;
	5985	"RTN","XUS 1",118,0)
	5986	AUDIT ;Set -up Audit info
	5987	"RTN","XUS 1",119,0)
	5988	N I,I1,I2
	5989	"RTN","XUS 1",120,0)
	5990	S I=$G(^X TV(8989.3, 1,19)),I1= $P(I,U),I2 =$P(I,U,2) Q:"asu"'[ I1 I (I2> XUNOW)!($P (I,U,3)<XU NOW) Q
	5991	"RTN","XUS 1",121,0)
	5992	I "au"[I1 S:(I1="a" )!($D(^XTV (8989.3,1, 19.3,"B",D UZ))>1) XQ AUDIT=1 Q
	5993	"RTN","XUS 1",122,0)
	5994	S XQAUDIT ="" F I=0: 0 S I=$O(^ XTV(8989.3 ,1,19.1,"B ",I)) Q:I' >0!($L(XQA UDIT)>245) S XQAUDI T=XQAUDIT_ "2^"_I_U
	5995	"RTN","XUS 1",123,0)
	5996	S I1="" F I=0:0 S I 1=$O(^XTV( 8989.3,1,1 9.2,"B",I1 )) Q:I1']" "!($L(XQAU DIT)>245) S XQAUDIT =XQAUDIT_" 3^"_I1_U
	5997	"RTN","XUS 1",124,0)
	5998	Q
	5999	"RTN","XUS 1",125,0)
	6000	;
	6001	"RTN","XUS 1",126,0)
	6002	DD(Y) Q $$ FMTE^XLFDT (Y,1)
	6003	"RTN","XUS 1",127,0)
	6004	;
	6005	"RTN","XUS 1",128,0)
	6006	KILL N %UC I,PGM,U,XQ UR,XMCHAN G KILL1^XU SCLEAN
	6007	"RTN","XUS 1",129,0)
	6008	Q
	6009	"RTN","XUS 1",130,0)
	6010	NO G NO^XU S
	6011	"RTN","XUS AML")
	6012	0^14^B8782 2485^B7889 6546
	6013	"RTN","XUS AML",1,0)
	6014	XUSAML ;IS D/HGW Kern el SAML To ken Implem entation ; 10/01/15 14:40
	6015	"RTN","XUS AML",2,0)
	6016	;;8.0;KER NEL;655, 659;Jul 10, 1995;B uild 22
	6017	"RTN","XUS AML",3,0)
	6018	;Per VA D irective 6 402, this routine sh ould not b e modified .
	6019	"RTN","XUS AML",4,0)
	6020	;
	6021	"RTN","XUS AML",5,0)
	6022	; Impleme nts the Ke rnel SAML Token mess age framew ork for th e Identifi cation and
	6023	"RTN","XUS AML",6,0)
	6024	; Access Management (IAM) Sin gle Sign-O n (SSO) se curity mod el.
	6025	"RTN","XUS AML",7,0)
	6026	;
	6027	"RTN","XUS AML",8,0)
	6028	Q
	6029	"RTN","XUS AML",9,0)
	6030	EN(DOC) ;F unction. M ain entry point
	6031	"RTN","XUS AML",10,0)
	6032	;This fun ction pars es and pro cesses the VA Identi ty and Acc ess Manage ment (IAM) STS SAML token
	6033	"RTN","XUS AML",11,0)
	6034	; (versio n 1.2) and returns t he DUZ of the user, if found. It does no t log the user into VistA.
	6035	"RTN","XUS AML",12,0)
	6036	; Input: DOC = Closed reference to global root cont aining XML document (loaded ST S SAML Tok en)
	6037	"RTN","XUS AML",13,0)
	6038	; Exampl e: S Y=$$E N^XUSAML($ NA(^TMP($J ,1)))
	6039	"RTN","XUS AML",14,0)
	6040	; Return: Fail = "-1^Er ror Messag e"
	6041	"RTN","XUS AML",15,0)
	6042	; Succes s = DUZ
	6043	"RTN","XUS AML",16,0)
	6044	;ZEXCEPT: XOBDATA ; environmen t variable
	6045	"RTN","XUS AML",17,0)
	6046	N HDL,XAS SRT,XUPN,Y
	6047	"RTN","XUS AML",18,0)
	6048	K ^TMP("X USAML",$J)
	6049	"RTN","XUS AML",19,0)
	6050	S Y="-1^E rror parsi ng STS SAM L Token",X UPN="",XAS SRT=""
	6051	"RTN","XUS AML",20,0)
	6052	S XOBDATA ("XOB RPC" ,"SECURITY ","STATE") ="notauthe nticated"
	6053	"RTN","XUS AML",21,0)
	6054	S XOBDATA ("XOB RPC" ,"SAML","A SSERTION") ="notvalid ated"
	6055	"RTN","XUS AML",22,0)
	6056	;--- Call parser
	6057	"RTN","XUS AML",23,0)
	6058	S HDL=$$E N^MXMLDOM( DOC,"W")
	6059	"RTN","XUS AML",24,0)
	6060	I HDL>0 D
	6061	"RTN","XUS AML",25,0)
	6062	. D ND(HD L,1,1,.XUP N,.XASSRT) ;Traverse and proce ss documen t
	6063	"RTN","XUS AML",26,0)
	6064	. S Y="-1 ^Invalid S AML assert ion"
	6065	"RTN","XUS AML",27,0)
	6066	. ;Interi m solution , code to be depreca ted and re moved afte r ???? (da te and tim e)
	6067	"RTN","XUS AML",28,0)
	6068	. I $$LOW ^XLFSTR($G (^TMP("XUS AML",$J,"N ame","auth nsystem")) )="m4a" D
	6069	"RTN","XUS AML",29,0)
	6070	. . S Y=$ $FINDUSER( )
	6071	"RTN","XUS AML",30,0)
	6072	. . I +Y> 0 H $E(DT, 1,3)-316 ; Add "hang time" as this inter face ages to encoura ge migrati on
	6073	"RTN","XUS AML",31,0)
	6074	. E D
	6075	"RTN","XUS AML",32,0)
	6076	. . ;End of Interim solution, code to b e deprecat ed and rem oved after ???? (dat e and time )
	6077	"RTN","XUS AML",33,0)
	6078	. . D VAL ASSRT(.XAS SRT,DOC) ; Validate S AML assert ion
	6079	"RTN","XUS AML",34,0)
	6080	. . I $G( XOBDATA("X OB RPC","S AML","ASSE RTION"))=" validated" D
	6081	"RTN","XUS AML",35,0)
	6082	. . . S Y =$$FINDUSE R()
	6083	"RTN","XUS AML",36,0)
	6084	. D DELET E^MXMLDOM( HDL)
	6085	"RTN","XUS AML",37,0)
	6086	I +Y>0 S XOBDATA("X OB RPC","S ECURITY"," STATE")="a uthenticat ed"
	6087	"RTN","XUS AML",38,0)
	6088	K ^TMP("X USAML",$J)
	6089	"RTN","XUS AML",39,0)
	6090	Q Y
	6091	"RTN","XUS AML",40,0)
	6092	ND(HDL,ND, FS,XUPN,XA SSRT) ;SR. Traverse tree
	6093	"RTN","XUS AML",41,0)
	6094	N CH,SIB, TX
	6095	"RTN","XUS AML",42,0)
	6096	D SH(HDL, ND,.XUPN,. XASSRT)
	6097	"RTN","XUS AML",43,0)
	6098	S CH=0
	6099	"RTN","XUS AML",44,0)
	6100	S CH=$$CH ILD^MXMLDO M(HDL,ND,C H)
	6101	"RTN","XUS AML",45,0)
	6102	I CH D ND (HDL,CH,1, .XUPN,.XAS SRT)
	6103	"RTN","XUS AML",46,0)
	6104	Q:'FS ;D on't follo w the sibl ings of si blings
	6105	"RTN","XUS AML",47,0)
	6106	S SIB=ND
	6107	"RTN","XUS AML",48,0)
	6108	F S SIB= $$SIBLING^ MXMLDOM(HD L,SIB) Q:' SIB D ND( HDL,SIB,0, .XUPN,.XAS SRT)
	6109	"RTN","XUS AML",49,0)
	6110	Q
	6111	"RTN","XUS AML",50,0)
	6112	SH(HDL,ND, XUPN,XASSR T) ;SR. Pr ocess node elements
	6113	"RTN","XUS AML",51,0)
	6114	;ZEXCEPT: XOBDATA ; environmen t variable
	6115	"RTN","XUS AML",52,0)
	6116	N ELE,I,N M,V,VV,XCH ILD,XERR,X TEXT,XVALU E
	6117	"RTN","XUS AML",53,0)
	6118	S ELE=$$N AME^MXMLDO M(HDL,ND)
	6119	"RTN","XUS AML",54,0)
	6120	; ------- ---------- --- saml: Subject Ev ent Proces sing ---- ---------- ---------- --------
	6121	"RTN","XUS AML",55,0)
	6122	I (ELE="S ubject")!( ELE="saml: Subject")! (ELE="ns2: Subject") D Q ;Sub ject eleme nt is requ ired
	6123	"RTN","XUS AML",56,0)
	6124	. S XASSR T("Subject ")="yes"
	6125	"RTN","XUS AML",57,0)
	6126	I (ELE="S ubjectConf irmationDa ta")!(ELE= "saml:Subj ectConfirm ationData" )!(ELE="ns 2:SubjectC onfirmatio nData") D Q
	6127	"RTN","XUS AML",58,0)
	6128	. D EL(HD L,ND,.NM,. XUPN)
	6129	"RTN","XUS AML",59,0)
	6130	. S XASSR T("Subject Confirmati onData@Add ress")=$O( ^TMP("XUSA ML",$J,"Su bjectConfi rmationDat a@Address" ,""))
	6131	"RTN","XUS AML",60,0)
	6132	. S XASSR T("Subject Confirmati onData@Rec ipient")=$ O(^TMP("XU SAML",$J," SubjectCon firmationD ata@Recipi ent",""))
	6133	"RTN","XUS AML",61,0)
	6134	;
	6135	"RTN","XUS AML",62,0)
	6136	; ------- ---------- --- saml: Conditions Event Pro cessing - ---------- ---------- ----
	6137	"RTN","XUS AML",63,0)
	6138	I (ELE="C onditions" )!(ELE="sa ml:Conditi ons")!(ELE ="ns2:Cond itions") D Q
	6139	"RTN","XUS AML",64,0)
	6140	. D EL(HD L,ND,.NM,. XUPN)
	6141	"RTN","XUS AML",65,0)
	6142	. S XASSR T("NotBefo re")=$O(^T MP("XUSAML ",$J,"NotB efore","") )
	6143	"RTN","XUS AML",66,0)
	6144	. S XASSR T("NotOnOr After")=$O (^TMP("XUS AML",$J,"N otOnOrAfte r",""))
	6145	"RTN","XUS AML",67,0)
	6146	;
	6147	"RTN","XUS AML",68,0)
	6148	; ------- ---------- --- saml: AuthnState ment Event Processin g ------- ---------- --------
	6149	"RTN","XUS AML",69,0)
	6150	I (ELE="A uthnStatem ent")!(ELE ="saml:Aut hnStatemen t")!(ELE=" ns2:AuthnS tatement") D Q
	6151	"RTN","XUS AML",70,0)
	6152	. D EL(HD L,ND,.NM,. XUPN)
	6153	"RTN","XUS AML",71,0)
	6154	. S XASSR T("AuthnIn stant")=$O (^TMP("XUS AML",$J,"A uthnInstan t",""))
	6155	"RTN","XUS AML",72,0)
	6156	I (ELE="A uthnContex tClassRef" )!(ELE="sa ml:AuthnCo ntextClass Ref")!(ELE ="ns2:Auth nContextCl assRef") D Q
	6157	"RTN","XUS AML",73,0)
	6158	. S XUPN= "AuthnCont extClassRe f"
	6159	"RTN","XUS AML",74,0)
	6160	. D CH(HD L,ND,XUPN)
	6161	"RTN","XUS AML",75,0)
	6162	. S XASSR T("AuthnCo ntextClass Ref")=$G(^ TMP("XUSAM L",$J,"Aut hnContextC lassRef"))
	6163	"RTN","XUS AML",76,0)
	6164	;
	6165	"RTN","XUS AML",77,0)
	6166	; ------- ---------- --- saml: Attribute Event Proc essing -- ---------- ------
	6167	"RTN","XUS AML",78,0)
	6168	I (ELE="A ttribute") !(ELE="sam l:Attribut e")!(ELE=" ns2:Attrib ute") D Q
	6169	"RTN","XUS AML",79,0)
	6170	. S XCHIL D=$$CHILD^ MXMLDOM(HD L,ND) ;Ide ntify chil d (Attribu teValue) o f node ND
	6171	"RTN","XUS AML",80,0)
	6172	. S XTEXT ="" S XERR =$$TEXT^MX MLDOM(HDL, XCHILD,$NA (VV)) ;Get text of A ttributeVa lue
	6173	"RTN","XUS AML",81,0)
	6174	. I XERR= 1 F I=1:1 Q:'$D(VV(I )) S XTEX T=XTEXT_VV (I)
	6175	"RTN","XUS AML",82,0)
	6176	. S NM=""
	6177	"RTN","XUS AML",83,0)
	6178	. F S NM =$$ATTRIB^ MXMLDOM(HD L,ND,NM) Q :'$L(NM) D ;Get na me of Attr ibute
	6179	"RTN","XUS AML",84,0)
	6180	. . I $G( NM)="Name" D
	6181	"RTN","XUS AML",85,0)
	6182	. . . S X VALUE=$$VA LUE^MXMLDO M(HDL,ND,N M)
	6183	"RTN","XUS AML",86,0)
	6184	. . . S ^ TMP("XUSAM L",$J,NM,X VALUE)=XTE XT ;Set up the ^TMP global for the Attri bute
	6185	"RTN","XUS AML",87,0)
	6186	Q
	6187	"RTN","XUS AML",88,0)
	6188	CH(HDL,ND, XUPN) ;SR. Process t ext node
	6189	"RTN","XUS AML",89,0)
	6190	N I,VV,Y
	6191	"RTN","XUS AML",90,0)
	6192	I $G(XUPN )'="" D
	6193	"RTN","XUS AML",91,0)
	6194	. S Y=""
	6195	"RTN","XUS AML",92,0)
	6196	. D TEXT^ MXMLDOM(HD L,ND,$NA(V V))
	6197	"RTN","XUS AML",93,0)
	6198	. I $D(VV )>2 F I=1: 1 Q:'$D(VV (I)) S Y= Y_VV(I)
	6199	"RTN","XUS AML",94,0)
	6200	. I $P(XU PN,"^",2)= "" D
	6201	"RTN","XUS AML",95,0)
	6202	. . S ^TM P("XUSAML" ,$J,$P(XUP N,"^",1))= Y
	6203	"RTN","XUS AML",96,0)
	6204	. E D
	6205	"RTN","XUS AML",97,0)
	6206	. . S ^TM P("XUSAML" ,$J,$P(XUP N,"^",1),$ P(XUPN,"^" ,2))=Y
	6207	"RTN","XUS AML",98,0)
	6208	Q
	6209	"RTN","XUS AML",99,0)
	6210	EL(HDL,ND, NM,XUPN) ; SR. Proces s element
	6211	"RTN","XUS AML",100,0 )
	6212	K XUPN S (NM,XUPN)= ""
	6213	"RTN","XUS AML",101,0 )
	6214	F S NM=$ $ATTRIB^MX MLDOM(HDL, ND,NM) Q:' $L(NM) D
	6215	"RTN","XUS AML",102,0 )
	6216	. I $L(NM ) S XUPN=N M_"^"_$$VA LUE^MXMLDO M(HDL,ND,N M)
	6217	"RTN","XUS AML",103,0 )
	6218	. I $P(XU PN,"^",2)= "" D
	6219	"RTN","XUS AML",104,0 )
	6220	. . S ^TM P("XUSAML" ,$J,$P(XUP N,"^",1))= ""
	6221	"RTN","XUS AML",105,0 )
	6222	. E D
	6223	"RTN","XUS AML",106,0 )
	6224	. . S ^TM P("XUSAML" ,$J,$P(XUP N,"^",1),$ P(XUPN,"^" ,2))=""
	6225	"RTN","XUS AML",107,0 )
	6226	Q
	6227	"RTN","XUS AML",108,0 )
	6228	FINDUSER() ;Function . Identify user
	6229	"RTN","XUS AML",109,0 )
	6230	;ZEXCEPT: XOBDATA ; environmen t variable
	6231	"RTN","XUS AML",110,0 )
	6232	;ZEXCEPT: XTMUNIT,X TU ;set fo r unit tes ting
	6233	"RTN","XUS AML",111,0 )
	6234	N VISTAID ,X,XARRY,X AUTH,XUIAM ,XUHOME,Y, Z
	6235	"RTN","XUS AML",112,0 )
	6236	I '$$AUTH ^XUESSO2() Q "-1^Not an author ized calli ng routine "
	6237	"RTN","XUS AML",113,0 )
	6238	S Y="-1^U ser could not be ide ntified"
	6239	"RTN","XUS AML",114,0 )
	6240	S XUIAM=1 ;Do not t rigger IAM updates
	6241	"RTN","XUS AML",115,0 )
	6242	S XARRY(1 )=$$TITLE^ XLFSTR($E( $G(^TMP("X USAML",$J, "Name","ur n:oasis:na mes:tc:xsp a:1.0:subj ect:organi zation")), 1,50)) ;Su bject Orga nization
	6243	"RTN","XUS AML",116,0 )
	6244	S XARRY(2 )=$$LOW^XL FSTR($E($G (^TMP("XUS AML",$J,"N ame","urn: oasis:name s:tc:xspa: 1.0:subjec t:organiza tion-id")) ,1,50)) ;S ubject Org anization ID
	6245	"RTN","XUS AML",117,0 )
	6246	S XARRY(3 )=$G(^TMP( "XUSAML",$ J,"Name"," uniqueUser Id")) ;Uni que User I D
	6247	"RTN","XUS AML",118,0 )
	6248	S XARRY(4 )=$G(^TMP( "XUSAML",$ J,"Name"," urn:oasis: names:tc:x spa:1.0:su bject:subj ect-id")) ;Subject I D
	6249	"RTN","XUS AML",119,0 )
	6250	;S XARRY( 5)=$G(XASS RT("Subjec tConfirmat ionData@Ad dress")) ; Use to aut horize app lication w ith REMOTE APPLICATI ON file? O r see SSOe below.
	6251	"RTN","XUS AML",120,0 )
	6252	S XARRY(6 )=$G(^TMP( "XUSAML",$ J,"Name"," urn:va:ad: samaccount name")) ;N etwork Use rname
	6253	"RTN","XUS AML",121,0 )
	6254	S XARRY(7 )=$G(^TMP( "XUSAML",$ J,"Name"," urn:va:vrm :iam:secid ")) ;SecID
	6255	"RTN","XUS AML",122,0 )
	6256	S XARRY(8 )=$G(^TMP( "XUSAML",$ J,"Name"," urn:oasis: names:tc:x spa:2.0:su bject:npi" )) ;NPI
	6257	"RTN","XUS AML",123,0 )
	6258	;S XARRY( 9)=$G(^TMP ("XUSAML", $J,"Name", "SSN")) ;S SN is not part of ST S Token sp ecificatio n v1.2
	6259	"RTN","XUS AML",124,0 )
	6260	S XARRY(1 0)=$G(^TMP ("XUSAML", $J,"Name", "upn")) ;A ctive Dire ctory User Principle Name (UPN )
	6261	"RTN","XUS AML",125,0 )
	6262	S XARRY(1 1)=$G(^TMP ("XUSAML", $J,"Name", "email")) ;E-Mail Ad dress
	6263	"RTN","XUS AML",126,0 )
	6264	;S XARRY( 12)=$G(^TM P("XUSAML" ,$J,"Name" ,"urn:oasi s:names:tc :xacml:2.0 :subject:r ole")) ;Ro le is not part of ST S Token sp ecificatio n v1.2
	6265	"RTN","XUS AML",127,0 )
	6266	S XAUTH=$ $LOW^XLFST R($G(^TMP( "XUSAML",$ J,"Name"," authnsyste m"))) ;SSO i, SSOe, o r Other au thenticati on
	6267	"RTN","XUS AML",128,0 )
	6268	S XUHOME= $$LOW^XLFS TR($G(^TMP ("XUSAML", $J,"Name", "urn:nhin: names:saml :homeCommu nityId"))) ;Home Com munity ID
	6269	"RTN","XUS AML",129,0 )
	6270	S VISTAID =$G(^TMP(" XUSAML",$J ,"Name","u rn:va:vrm: iam:vistai d")) ;VIST AID
	6271	"RTN","XUS AML",130,0 )
	6272	;S ???=$G (^TMP("XUS AML",$J,"N ame","urn: va:vrn:iam :mviicn")) ;ICN - ti e PATIENT file (#2) to NEW PER SON file ( #200)?
	6273	"RTN","XUS AML",131,0 )
	6274	;For SSOi and SSOe, the token should co me from IA M. Validat e using "s aml:Issuer " or somet hing from the certif icate?
	6275	"RTN","XUS AML",132,0 )
	6276	;<saml:Is suer Forma t="urn:oas is:names:t c:SAML:2.0 :nameid-fo rmat:entit y">https:/ / DNS /Issuer/SA ML2</saml: Issuer>
	6277	"RTN","XUS AML",133,0 )
	6278	I (XUHOME =$P($G(^XT V(8989.3,1 ,200)),U,3 ))&(XAUTH= "ssoi") D ;SSOi
	6279	"RTN","XUS AML",134,0 )
	6280	. S XARRY (3)=XARRY( 7) ;UID=Se cID
	6281	"RTN","XUS AML",135,0 )
	6282	. S Y=$$F INDUSER^XU ESSO2(.XAR RY) ;Ident ify user
	6283	"RTN","XUS AML",136,0 )
	6284	. S DUZ(" AUTHENTICA TION")="SS OI"
	6285	"RTN","XUS AML",137,0 )
	6286	. ;I +Y<0 D
	6287	"RTN","XUS AML",138,0 )
	6288	. ;. ;Fut ure: Add S SOi "VISIT OR" entry if not pro visioned? Require so me sort of Role-base d access o r REMOTE A PPLICATION file entr y?
	6289	"RTN","XUS AML",139,0 )
	6290	E I (XUH OME=$P($G( ^XTV(8989. 3,1,200)), U,3))&(XAU TH="ssoe") D ;SSOe
	6291	"RTN","XUS AML",140,0 )
	6292	. S XARRY (3)=XARRY( 7) ;UID=Se cID
	6293	"RTN","XUS AML",141,0 )
	6294	. S Y=$$F INDUSER^XU ESSO2(.XAR RY) ;Ident ify user
	6295	"RTN","XUS AML",142,0 )
	6296	. S DUZ(" AUTHENTICA TION")="SS OE"
	6297	"RTN","XUS AML",143,0 )
	6298	. I +Y<0 D
	6299	"RTN","XUS AML",144,0 )
	6300	. . I $$G ETCNTXT^XU ESSO2($G(X ARRY(2)))> 0 D
	6301	"RTN","XUS AML",145,0 )
	6302	. . . ;Fo r SSOe the XARRY(1) and XARRY( 2) will be the CSP t hat authen ticated th e user.
	6303	"RTN","XUS AML",146,0 )
	6304	. . . ; T he values will be th e CSP frie ndly name and the ma pped SiteI D as maint ained in M VI.
	6305	"RTN","XUS AML",147,0 )
	6306	. . . ; U se REMOTE APPLICATIO N file (#2 00) where XARRY(1) i s applicat ion and ha shed XARRY (2) is aut horization code
	6307	"RTN","XUS AML",148,0 )
	6308	. . . I X ARRY(1)'=$ P($G(^XTV( 8989.3,1,2 00)),U,2) S Y=$$ADDU SER^XUESSO 2(.XARRY) ;If autho rized appl ication, a dd the SSO e user
	6309	"RTN","XUS AML",149,0 )
	6310	. . . S X =$$SETCNTX T^XUESSO2( Y,$G(XARRY (2))) ;Ad d the cont ext option for SSOe
	6311	"RTN","XUS AML",150,0 )
	6312	E I (XUH OME=$P($G( ^XTV(8989. 3,1,200)), U,3))&(XAU TH="m4a") D ;m4a
	6313	"RTN","XUS AML",151,0 )
	6314	. S Y=$$F INDUSER^XU ESSO2(.XAR RY) ;Ident ify user
	6315	"RTN","XUS AML",152,0 )
	6316	. S DUZ(" AUTHENTICA TION")="M4 A"
	6317	"RTN","XUS AML",153,0 )
	6318	E I (XAR RY(2)["htt p://")!(XA RRY(2)["ht tps://")!( (XARRY(2)[ "urn:oid:" )&(XARRY(2 )'=$P($G(^ XTV(8989.3 ,1,200)),U ,3))) D ; NHIN
	6319	"RTN","XUS AML",154,0 )
	6320	. I $G(XA RRY(3))="" S XARRY(3 )=XARRY(8) ;NHIN: UI D is NPI i f availabl e (preferr ed)
	6321	"RTN","XUS AML",155,0 )
	6322	. I $G(XA RRY(3))="" S XARRY(3 )=XARRY(11 ) ;NHIN: U ID is e-ma il if avai lable (alt ernative t o NPI)
	6323	"RTN","XUS AML",156,0 )
	6324	. S Y=$$F INDUSER^XU ESSO2(.XAR RY) ;Ident ify user b y NPI or U nique User ID
	6325	"RTN","XUS AML",157,0 )
	6326	. I +Y<0 D
	6327	"RTN","XUS AML",158,0 )
	6328	. . S XAR RY(8)=""
	6329	"RTN","XUS AML",159,0 )
	6330	. . S Y=$ $FINDUSER^ XUESSO2(.X ARRY) ;Ide ntify user by Unique User ID o nly
	6331	"RTN","XUS AML",160,0 )
	6332	. S DUZ(" AUTHENTICA TION")="NH IN"
	6333	"RTN","XUS AML",161,0 )
	6334	;E I VIS TAID'="" D ;If ther e is a VIS TAID attri bute, chec k that a D UZ and STA TION combi nation exi sts for th is user
	6335	"RTN","XUS AML",162,0 )
	6336	;. ;SAML v1.2 speci fication s hows (but current pa rsing meth ods will o nly return a single attribute value):
	6337	"RTN","XUS AML",163,0 )
	6338	;. ; <sam l:Attribut e Name="ur n:va:vrm:i am:vistaid ">
	6339	"RTN","XUS AML",164,0 )
	6340	;. ; <sam l:Attribut eValue>404 -11128439< /saml:Attr ibuteValue >
	6341	"RTN","XUS AML",165,0 )
	6342	;. ; <sam l:Attribut eValue>322 -22228439< /saml:Attr ibuteValue >
	6343	"RTN","XUS AML",166,0 )
	6344	;. ; </sa ml:Attribu te>
	6345	"RTN","XUS AML",167,0 )
	6346	;. ;Examp le from IA M shows:
	6347	"RTN","XUS AML",168,0 )
	6348	;. ; <sam l:Attribut e Name="ur n:va:vrm:i am:vistaid " NameForm at="urn:oa sis:names: tc:SAML:2. 0:attrname -format:un specified" >
	6349	"RTN","XUS AML",169,0 )
	6350	;. ; <sam l:Attribut eValue>200 M\|33328439 ^PN^200M^U SVHA\|A,508 \|22228439^ PN^508^USV HA\|A,590\|1 1128439^PN ^590^USVHA \|A</saml:A ttributeVa lue>
	6351	"RTN","XUS AML",170,0 )
	6352	;. ; </sa ml:Attribu te>
	6353	"RTN","XUS AML",171,0 )
	6354	;. ;***** If VISTAI D match, s et SECID f or user ID 'd by DUZ and run $$ FINDUSER a gain to up date user attributes and authe nticate? S elf-provis ioning!
	6355	"RTN","XUS AML",172,0 )
	6356	;. S VID= ""
	6357	"RTN","XUS AML",173,0 )
	6358	;. F J=1: 1 D Q:VID =""
	6359	"RTN","XUS AML",174,0 )
	6360	;. . S VI D=$P(VISTA ID,",",J)
	6361	"RTN","XUS AML",175,0 )
	6362	;. . W !, VID,! ;VID should be "200M\|333 28439^PN^2 00M^USVHA\| A" where 2 00M is STA TION and 3 3328439 is DUZ
	6363	"RTN","XUS AML",176,0 )
	6364	;. ;***** Developme nt of iden tification by VISTAI D abandone d in XU8 659 due to discrepan cies betwe en standar d and IAM example, p lus lack o f good tes t data
	6365	"RTN","XUS AML",177,0 )
	6366	Q Y
	6367	"RTN","XUS AML",178,0 )
	6368	VALASSRT(X ASSRT,DOC) ;Intrinsi c Subrouti ne. Valida te SAML as sertion
	6369	"RTN","XUS AML",179,0 )
	6370	;ZEXCEPT: XOBDATA ; environmen t variable
	6371	"RTN","XUS AML",180,0 )
	6372	N XD,XNOW
	6373	"RTN","XUS AML",181,0 )
	6374	S XOBDATA ("XOB RPC" ,"SAML","A UTHENTICAT ION TYPE") =$G(^TMP(" XUSAML",$J ,"Name","a uthenticat iontype"))
	6375	"RTN","XUS AML",182,0 )
	6376	S XOBDATA ("XOB RPC" ,"SAML","P ROOFING AU THORITY")= $G(^TMP("X USAML",$J, "Name","pr oofingauth ority"))
	6377	"RTN","XUS AML",183,0 )
	6378	;Validate timestamp s (e.g., N otBefore, NotOnOrAft er)
	6379	"RTN","XUS AML",184,0 )
	6380	S XNOW=$$ NOW^XLFDT
	6381	"RTN","XUS AML",185,0 )
	6382	S XD=$$CO NVTIME($G( XASSRT("Au thnInstant "))) I XD= -1 Q ;inv alid times tamp
	6383	"RTN","XUS AML",186,0 )
	6384	S XD=$$CO NVTIME($G( XASSRT("No tBefore")) ) I (XD=-1 )!(XD>XNOW ) Q ;toke n not vali d yet
	6385	"RTN","XUS AML",187,0 )
	6386	S XD=$$CO NVTIME($G( XASSRT("No tOnOrAfter "))) I (XD =-1)!(XD'> XNOW) Q ; token expi red
	6387	"RTN","XUS AML",188,0 )
	6388	;Validate endpoints (Optional based on scenario)
	6389	"RTN","XUS AML",189,0 )
	6390	I '$D(XAS SRT("Subje ct")) Q ; very basic check for "Subject" tag
	6391	"RTN","XUS AML",190,0 )
	6392	; - TBD
	6393	"RTN","XUS AML",191,0 )
	6394	; a) Val idate Subj ect::Subje ctConfirma tion::Subj ectConfirm ationData@ Address
	6395	"RTN","XUS AML",192,0 )
	6396	; mat ches the r equestor ( e.g., comm on name in this attr ibute matc hes that
	6397	"RTN","XUS AML",193,0 )
	6398	; fro m the cert ificate wh ich secure d the sess ion). Note : This Sub ject will
	6399	"RTN","XUS AML",194,0 )
	6400	; be the system that requ ested the token - it may or ma y not be t he System
	6401	"RTN","XUS AML",195,0 )
	6402	; han ding the t oken to Vi stA.
	6403	"RTN","XUS AML",196,0 )
	6404	; As of patch 6 59, IAM SA ML tokens are missin g this inf ormation
	6405	"RTN","XUS AML",197,0 )
	6406	; b) Val idate Serv ice Endpoi nt using
	6407	"RTN","XUS AML",198,0 )
	6408	; Sub ject::Subj ectConfirm ation::Sub jectConfir mationData @Recipient
	6409	"RTN","XUS AML",199,0 )
	6410	; VistA shal l accept a n endpoint of " DNS "
	6411	"RTN","XUS AML",200,0 )
	6412	; As of patch 6 59, IAM SA ML tokens have this informatio n in the w rong place :
	6413	"RTN","XUS AML",201,0 )
	6414	; <sa ml:Subject Confirmati onData Rec ipient="ht tp://SSOi/ AppliesTo/ SAML2"/>
	6415	"RTN","XUS AML",202,0 )
	6416	; <saml:Audi enceRestri ction><sam l:Audience >https://* . DNS /*</saml:A udience></ saml:Audie nceRestric tion>
	6417	"RTN","XUS AML",203,0 )
	6418	I '$D(XAS SRT("Authn ContextCla ssRef")) Q
	6419	"RTN","XUS AML",204,0 )
	6420	; - TBD
	6421	"RTN","XUS AML",205,0 )
	6422	; Verify Level of A ssurance ( VA require s LOA-1 th rough LOA- 3, but LOA -4 is curr ently the best)
	6423	"RTN","XUS AML",206,0 )
	6424	K XOBDATA ("XOB RPC" ,"SAML","A SSURANCE L EVEL")
	6425	"RTN","XUS AML",207,0 )
	6426	S XD=$G(^ TMP("XUSAM L",$J,"Nam e","assura ncelevel") ) I (+XD<1 )!(+XD="") S XD=1
	6427	"RTN","XUS AML",208,0 )
	6428	S XOBDATA ("XOB RPC" ,"SAML","A SSURANCE L EVEL")=XD
	6429	"RTN","XUS AML",209,0 )
	6430	S DUZ("LO A")=XD ;Se t LOA envi ronment va riable for SIGN-ON l og and per missions
	6431	"RTN","XUS AML",210,0 )
	6432	;Validate Digital S ignature
	6433	"RTN","XUS AML",211,0 )
	6434	I '$$VALI DATE^XUCER T(DOC) Q
	6435	"RTN","XUS AML",212,0 )
	6436	;Validate Token Iss uer (Subje ct of X509 Certifica te used to sign toke n)
	6437	"RTN","XUS AML",213,0 )
	6438	I '($G(XO BDATA("XOB RPC","SAM L","ISSUER "))[$P($G( ^XTV(8989. 3,1,200)), U,1)) Q
	6439	"RTN","XUS AML",214,0 )
	6440	;Token ha s been val idated
	6441	"RTN","XUS AML",215,0 )
	6442	S XOBDATA ("XOB RPC" ,"SAML","A SSERTION") ="validate d"
	6443	"RTN","XUS AML",216,0 )
	6444	Q
	6445	"RTN","XUS AML",217,0 )
	6446	CONVTIME(T IME) ;Intr insic Func tion. Conv ert XML ti me to File Man format
	6447	"RTN","XUS AML",218,0 )
	6448	;ZEXCEPT: %DT ;envi ronment va riable
	6449	"RTN","XUS AML",219,0 )
	6450	N X,XD,XO UT,XT,XZ,Y
	6451	"RTN","XUS AML",220,0 )
	6452	S XZ=0 I $G(TIME)[" Z" S XZ=1 ;Zulu time (GMT)
	6453	"RTN","XUS AML",221,0 )
	6454	S XD=$P($ G(TIME),"T ",1) ;Date
	6455	"RTN","XUS AML",222,0 )
	6456	S XD=$P(X D,"-",2)_" /"_$P(XD," -",3)_"/"_ $P(XD,"-", 1) ;Conver t date to MM/DD/YYYY
	6457	"RTN","XUS AML",223,0 )
	6458	S XT=$P($ G(TIME),"T ",2) ;Time
	6459	"RTN","XUS AML",224,0 )
	6460	I XZ=1 S XT=$P(XT," Z",1) ;Str ip "Z" fro m time
	6461	"RTN","XUS AML",225,0 )
	6462	S X=XD_"@ "_XT S %DT ="RTS"
	6463	"RTN","XUS AML",226,0 )
	6464	D ^%DT S XOUT=Y
	6465	"RTN","XUS AML",227,0 )
	6466	I XZ=1 S XOUT=$$FMA DD^XLFDT(X OUT,0,+$E( $$TZ^XLFDT ,1,3),0,0) ;Adjust f rom GMT
	6467	"RTN","XUS AML",228,0 )
	6468	K %DT(0)
	6469	"RTN","XUS AML",229,0 )
	6470	Q XOUT
	6471	"RTN","XUS BSE1")
	6472	0^9^B15898 4065^B1171 44392
	6473	"RTN","XUS BSE1",1,0)
	6474	XUSBSE1 ;I SF/JLI,ISD /HGW - MOD IFICATIONS FOR BSE ; 01/06/16 16:37
	6475	"RTN","XUS BSE1",2,0)
	6476	;;8.0;KER NEL;404, 439,523,59 5,522,638, 659;Jul 10, 1995;B uild 22
	6477	"RTN","XUS BSE1",3,0)
	6478	;Per VA D irective 6 402, this routine sh ould not b e modified .
	6479	"RTN","XUS BSE1",4,0)
	6480	;
	6481	"RTN","XUS BSE1",5,0)
	6482	Q
	6483	"RTN","XUS BSE1",6,0)
	6484	SETVISIT(R ES) ; RPC. XUS SET V ISITOR - I A #5501
	6485	"RTN","XUS BSE1",7,0)
	6486	;Returns a BSE TOKE N
	6487	"RTN","XUS BSE1",8,0)
	6488	N TOKEN,O ,X
	6489	"RTN","XUS BSE1",9,0)
	6490	S X=$$ACT IVE^XUSER( DUZ) I $P( X,U)<1 S R ES=X Q ;U ser must b e active
	6491	"RTN","XUS BSE1",10,0 )
	6492	S TOKEN=$ $HANDLE^XU SRB4("XUSB SE",1)
	6493	"RTN","XUS BSE1",11,0 )
	6494	I TOKEN=" NOT AUTHEN TICATED" S RES=TOKEN Q ;User must be au thenticate d
	6495	"RTN","XUS BSE1",12,0 )
	6496	S ^XTMP(T OKEN,1)=$$ ENCRYP^XUS RB1($$GET^ XUESSO1(DU Z))
	6497	"RTN","XUS BSE1",13,0 )
	6498	S ^XTMP(T OKEN,3)=+$ H ;Set exp iration da y
	6499	"RTN","XUS BSE1",14,0 )
	6500	L -^XTMP( TOKEN) ;Lo ck set in $$HANDLE^X USRB4
	6501	"RTN","XUS BSE1",15,0 )
	6502	S RES=TOK EN
	6503	"RTN","XUS BSE1",16,0 )
	6504	Q
	6505	"RTN","XUS BSE1",17,0 )
	6506	;
	6507	"RTN","XUS BSE1",18,0 )
	6508	GETVISIT(R ES,TOKEN) ; RPC. XUS GET VISIT OR - IA #5 532
	6509	"RTN","XUS BSE1",19,0 )
	6510	;Returns demographi cs for use r indicate d by TOKEN
	6511	"RTN","XUS BSE1",20,0 )
	6512	; or "-1 ^error mes sage" if u ser is not permitted to visit
	6513	"RTN","XUS BSE1",21,0 )
	6514	; input - TOKEN - token va lue return ed by remo te site
	6515	"RTN","XUS BSE1",22,0 )
	6516	; outpu t - RES - passed by reference, contains user demog raphics on return
	6517	"RTN","XUS BSE1",23,0 )
	6518	N O,X
	6519	"RTN","XUS BSE1",24,0 )
	6520	S RES="", O=0
	6521	"RTN","XUS BSE1",25,0 )
	6522	I TOKEN=" " S X=$$LO GERR("BSE NULL TOKEN ") Q ;Sho uldn't com e in with a null tok en
	6523	"RTN","XUS BSE1",26,0 )
	6524	L +^XTMP( TOKEN):10 I '$T Q ; If ^XTMP is purged, token con text will be lost
	6525	"RTN","XUS BSE1",27,0 )
	6526	I ($G(^XT MP(TOKEN,3 ))-$H) K ^ XTMP(TOKEN ) Q ;Chec k expirati on time, a nd if it h as passed
	6527	"RTN","XUS BSE1",28,0 )
	6528	S RES=$G( ^XTMP(TOKE N,1)) S:$L (RES) RES= $$DECRYP^X USRB1(RES)
	6529	"RTN","XUS BSE1",29,0 )
	6530	L -^XTMP( TOKEN) ;Lo ck set in $$HANDLE^X USRB4
	6531	"RTN","XUS BSE1",30,0 )
	6532	S:'$L(RES ) X=$$LOGE RR("BSE GE T USER ID" ) ;p595
	6533	"RTN","XUS BSE1",31,0 )
	6534	Q
	6535	"RTN","XUS BSE1",32,0 )
	6536	;
	6537	"RTN","XUS BSE1",33,0 )
	6538	OLDCAPRI(X WBUSRNM) ; Intrinsic . Old CAPR I code, cu rrently us ed by MDWS : Disable with syste m paramete r XU522.
	6539	"RTN","XUS BSE1",34,0 )
	6540	; Return 1 if a val id user, e lse 0.
	6541	"RTN","XUS BSE1",35,0 )
	6542	;****** ****** ****** ****** ****** ****** ****** ****** ****** ****** ****** ********
	6543	"RTN","XUS BSE1",36,0 )
	6544	;***** Th is interfa ce is depr ecated as of patch X U8.0522 and will b e permanen tly disabl ed with pa tch XU8.0 617 *****
	6545	"RTN","XUS BSE1",37,0 )
	6546	;****** ****** ****** ****** ****** ****** ****** ****** ****** ****** ****** ********
	6547	"RTN","XUS BSE1",38,0 )
	6548	; ZEXCEPT : DTIME - Kernel exe mption
	6549	"RTN","XUS BSE1",39,0 )
	6550	N XVAL,XO PTION,XVAL 522
	6551	"RTN","XUS BSE1",40,0 )
	6552	S XVAL522 =$$GET^XPA R("SYS","X U522",1,"Q ") ; p522 system pa rameter XU 522 contro ls CAPRI l ogin disab ling, logg ing
	6553	"RTN","XUS BSE1",41,0 )
	6554	D:(XVAL52 2="E"!(XVA L522="L")) APPERROR^ %ZTER("OLD CAPRI LOGI N ATTEMPT" ) ; p522 record CAP RI login a ttempt if XU522 = E or L
	6555	"RTN","XUS BSE1",42,0 )
	6556	Q:(XVAL52 2'="L")&(X VAL522'="N ") 0 ; p5 22 fully a ctivate BS E unless p aram XU522 = N or L
	6557	"RTN","XUS BSE1",43,0 )
	6558	S DUZ("LO A")=1,DUZ( "AUTHENTIC ATION")="N ONE",DUZ(" REMAPP")=" ^MDWS"
	6559	"RTN","XUS BSE1",44,0 )
	6560	S XVAL=$$ PUT^XUESSO 1($P(XWBUS RNM,U,3,99 )) ; Sign in as Visi tor
	6561	"RTN","XUS BSE1",45,0 )
	6562	I XVAL D
	6563	"RTN","XUS BSE1",46,0 )
	6564	. S XOPTI ON=$$FIND1 ^DIC(19,"" ,"X","DVBA CAPRI G UI")
	6565	"RTN","XUS BSE1",47,0 )
	6566	. D SETCN TXT(XOPTIO N) S DTIME =$$DTIME^X UP(DUZ),DU Z(0)=""
	6567	"RTN","XUS BSE1",48,0 )
	6568	. N XUAPI EN,XUUCYES ,XURPIEN
	6569	"RTN","XUS BSE1",49,0 )
	6570	. S XUAPI EN=$O(^VA( 201,"B","A PPLICATION PROXY",0) ) Q:XUAPIE N'>0 ; Ge t IEN of " APPLICATON PROXY" Us er Class
	6571	"RTN","XUS BSE1",50,0 )
	6572	. S XUUCY ES=$O(^VA( 200,DUZ,"U SC3","B",X UAPIEN,0)) Q:XUUCYES '>0 ; Ch eck if DUZ is APPLIC ATION PROX Y
	6573	"RTN","XUS BSE1",51,0 )
	6574	. ;I XUUC YES=XUAPIE N S XVAL=0 ; Applic ation Prox y use of t his interf ace is not permitted
	6575	"RTN","XUS BSE1",52,0 )
	6576	Q $S(XVAL >0:1,1:0)
	6577	"RTN","XUS BSE1",53,0 )
	6578	;
	6579	"RTN","XUS BSE1",54,0 )
	6580	CHKUSER(IN PUTSTR) ; Extrinsic. Determine s if a BSE sign-on i s valid - called fro m XUSRB
	6581	"RTN","XUS BSE1",55,0 )
	6582	; INPUT STR - inpu t - String of charac ters from client
	6583	"RTN","XUS BSE1",56,0 )
	6584	; retur n value - 1 if a val id user an d applicat ion, else 0
	6585	"RTN","XUS BSE1",57,0 )
	6586	; ZEXCEPT : DTIME - Kernel exe mption
	6587	"RTN","XUS BSE1",58,0 )
	6588	N X,XUCOD E,XUENTRY, XUSTR,XUTO KEN
	6589	"RTN","XUS BSE1",59,0 )
	6590	I +INPUTS TR=-31,INP UTSTR["DVB A_" Q $$OL DCAPRI(INP UTSTR)
	6591	"RTN","XUS BSE1",60,0 )
	6592	I +INPUTS TR'=-35 S X=$$LOGERR ("BSE LOGI N ERROR") Q 0 ; not a BSE log in
	6593	"RTN","XUS BSE1",61,0 )
	6594	S INPUTST R=$P(INPUT STR,U,2,99 )
	6595	"RTN","XUS BSE1",62,0 )
	6596	K ^TMP("X USBSE1",$J )
	6597	"RTN","XUS BSE1",63,0 )
	6598	S XUCODE= $$DECRYP^X USRB1(INPU TSTR)
	6599	"RTN","XUS BSE1",64,0 )
	6600	S XUENTRY =$$GETCNTX T^XUESSO2( $P(XUCODE, U))
	6601	"RTN","XUS BSE1",65,0 )
	6602	I XUENTRY '>0 S X=$$ LOGERR("BS E LOGIN ER ROR - REMA PP") Q 0 ; invalid remote app lication
	6603	"RTN","XUS BSE1",66,0 )
	6604	S DUZ("LO A")=2,DUZ( "AUTHENTIC ATION")="B SETOKEN"
	6605	"RTN","XUS BSE1",67,0 )
	6606	S DUZ("RE MAPP")=XUE NTRY_U_$$G ET1^DIQ(89 94.5,XUENT RY_",",.01 )
	6607	"RTN","XUS BSE1",68,0 )
	6608	S XUTOKEN =$P(XUCODE ,U,2)
	6609	"RTN","XUS BSE1",69,0 )
	6610	S XUSTR=$ P(XUCODE,U ,3,4)
	6611	"RTN","XUS BSE1",70,0 )
	6612	S XUENTRY =$$BSEUSER (XUENTRY,X UTOKEN,XUS TR)
	6613	"RTN","XUS BSE1",71,0 )
	6614	S DTIME=$ $DTIME^XUP (DUZ)
	6615	"RTN","XUS BSE1",72,0 )
	6616	I XUENTRY '>0 S X=$$ LOGERR("BS E LOGIN ER ROR - USER ") Q 0 ; invalid us er
	6617	"RTN","XUS BSE1",73,0 )
	6618	Q XUENTRY
	6619	"RTN","XUS BSE1",74,0 )
	6620	;
	6621	"RTN","XUS BSE1",75,0 )
	6622	BSEUSER(EN TRY,TOKEN, STR) ; Int rinsic. Re turns inte rnal entry number fo r authenti cated user
	6623	"RTN","XUS BSE1",76,0 )
	6624	; ENTRY - input - internal entry numb er in REMO TE APPLICA TION file
	6625	"RTN","XUS BSE1",77,0 )
	6626	; TOKEN - input - token fro m authenti cating sit e
	6627	"RTN","XUS BSE1",78,0 )
	6628	; STR - input - remainder of input string (st ation #^TC P/IP port for statio n-based au thenticati on)
	6629	"RTN","XUS BSE1",79,0 )
	6630	; retur ns - IEN f or authent icated use r, or 0 if not authe nticated
	6631	"RTN","XUS BSE1",80,0 )
	6632	; ZEXCEPT : XWBSEC - Kernel ex emption, c ontains er ror messag e returned to GUI ap plication
	6633	"RTN","XUS BSE1",81,0 )
	6634	N X,XUIEN ,XUCONTXT, XUDEMOG,XC NT,XVAL,AR RAY,XUCACH E,XUCONTXT
	6635	"RTN","XUS BSE1",82,0 )
	6636	S XUIEN=0 ,XUDEMOG=" ",XUCONTXT =0
	6637	"RTN","XUS BSE1",83,0 )
	6638	; Check f or cached user authe ntication (p638)
	6639	"RTN","XUS BSE1",84,0 )
	6640	I $D(^XTM P("XUSBSE1 ",TOKEN)) D
	6641	"RTN","XUS BSE1",85,0 )
	6642	. S XUCAC HE=$G(^XTM P("XUSBSE1 ",TOKEN)) ; Retrieve cached va lues
	6643	"RTN","XUS BSE1",86,0 )
	6644	. I $P($P (XUCACHE,U ,1),".",1) <$$DT^XLFD T() K ^XTM P("XUSBSE1 ",TOKEN) Q ; Do not use if ex pired (not from toda y)
	6645	"RTN","XUS BSE1",87,0 )
	6646	. I $P(XU CACHE,U,1) =$$HADD^XL FDT($$NOW^ XLFDT(),0, 0,0,600) K ^XTMP("XU SBSE1",TOK EN) Q ; D o not use if expired (older th an 600s)
	6647	"RTN","XUS BSE1",88,0 )
	6648	. S XUDEM OG=$P(XUCA CHE,U,3,99 ) ; Get de mographics of authen ticated us er
	6649	"RTN","XUS BSE1",89,0 )
	6650	. I '$$PU T^XUESSO1( XUDEMOG) Q ; Set VI SITOR entr y, quit if failed
	6651	"RTN","XUS BSE1",90,0 )
	6652	. S XUIEN =$G(DUZ)
	6653	"RTN","XUS BSE1",91,0 )
	6654	. S XUCON TXT=$P(XUC ACHE,U,2), ^XUTL("XQ" ,$J,"DUZ(B SE)")=XUCO NTXT ; Set Context O ption
	6655	"RTN","XUS BSE1",92,0 )
	6656	. S:(XUIE N>0) ^XTMP ("XUSBSE1" ,TOKEN)=$$ NOW^XLFDT( )_"^"_$G(X UCONTXT)_" ^"_XUDEMOG ; Reset c ache to ke ep authent ication al ive
	6657	"RTN","XUS BSE1",93,0 )
	6658	I (XUIEN> 0)&(XUCONT XT>0) Q XU IEN ; p63 8 Use cach ed authent ication
	6659	"RTN","XUS BSE1",94,0 )
	6660	;
	6661	"RTN","XUS BSE1",95,0 )
	6662	S XCNT=0 F S XCNT= $O(^XWB(89 94.5,ENTRY ,1,XCNT)) Q:XCNT'>0 S XVAL=^( XCNT,0) D Q:XUDEMOG '=""
	6663	"RTN","XUS BSE1",96,0 )
	6664	. ; CODE TO HANDLE CONNECTION TYPE AND CONNECTION S
	6665	"RTN","XUS BSE1",97,0 )
	6666	. I $P(XV AL,U)="M" S XUDEMOG= $$M2M($P(X VAL,U,3),$ P(XVAL,U,2 ),TOKEN) D CLOSE^XWB M2MC() Q ; M2M-Brok er authent ication
	6667	"RTN","XUS BSE1",98,0 )
	6668	. I $P(XV AL,U)="R" S XUDEMOG= $$XWB($P(X VAL,U,3),$ P(XVAL,U,2 ),TOKEN) Q ; RPC-Br oker authe ntication
	6669	"RTN","XUS BSE1",99,0 )
	6670	. I $P(XV AL,U)="H" S XUDEMOG= $$POST1^XU SBSE2(.ARR AY,$P(XVAL ,U,3),$P(X VAL,U,2),$ P(XVAL,U,4 ),"xVAL="_ TOKEN) Q ; HTTP aut henticatio n
	6671	"RTN","XUS BSE1",100, 0)
	6672	. I $P(XV AL,U)="S" S XUDEMOG= $$HOME(TOK EN,XVAL,ST R) Q ; St ation-numb er authent ication
	6673	"RTN","XUS BSE1",101, 0)
	6674	. Q
	6675	"RTN","XUS BSE1",102, 0)
	6676	; if inva lid set XW BSEC so an error is reported i n the GUI applicatio n
	6677	"RTN","XUS BSE1",103, 0)
	6678	I +XUDEMO G=-1 S XWB SEC="BSE E RROR - "_$ P(XUDEMOG, "^",2)
	6679	"RTN","XUS BSE1",104, 0)
	6680	I $L(XUDE MOG,"^")>2 D
	6681	"RTN","XUS BSE1",105, 0)
	6682	. S XUCON TXT=$P($G( ^XWB(8994. 5,ENTRY,0) ),U,2)
	6683	"RTN","XUS BSE1",106, 0)
	6684	. S XUIEN =$$SETUP(X UDEMOG,XUC ONTXT)
	6685	"RTN","XUS BSE1",107, 0)
	6686	S:(XUIEN' >0) X=$$LO GERR("BSE LOGIN ERRO R") ;p595
	6687	"RTN","XUS BSE1",108, 0)
	6688	S:(XUIEN> 0) ^XTMP(" XUSBSE1",T OKEN)=$$NO W^XLFDT()_ "^"_$G(XUC ONTXT)_"^" _XUDEMOG ; p638 Cach e user aut henticatio n
	6689	"RTN","XUS BSE1",109, 0)
	6690	Q $S(XUIE N'>0:0,1:X UIEN)
	6691	"RTN","XUS BSE1",110, 0)
	6692	;
	6693	"RTN","XUS BSE1",111, 0)
	6694	XWB(SERVER ,PORT,TOKE N) ; Speci al Broker service
	6695	"RTN","XUS BSE1",112, 0)
	6696	N DEMOSTR ,IO,XWBTDE V,XWBRBUF
	6697	"RTN","XUS BSE1",113, 0)
	6698	Q $$CALLB SE^XWBTCPM 2(SERVER,P ORT,TOKEN)
	6699	"RTN","XUS BSE1",114, 0)
	6700	;
	6701	"RTN","XUS BSE1",115, 0)
	6702	M2M(SERVER ,PORT,TOKE N) ; M2M B roker
	6703	"RTN","XUS BSE1",116, 0)
	6704	N DEMOGST R,XWBCRLFL ,RETRNVAL, XUSBSARR
	6705	"RTN","XUS BSE1",117, 0)
	6706	S DEMOGST R=""
	6707	"RTN","XUS BSE1",118, 0)
	6708	N XWBSTAT ,XWBPARMS, XWBTDEV,XW BNULL
	6709	"RTN","XUS BSE1",119, 0)
	6710	S XWBPARM S("ADDRESS ")=SERVER, XWBPARMS(" PORT")=POR T
	6711	"RTN","XUS BSE1",120, 0)
	6712	S XWBPARM S("RETRIES ")=3 ;Retr ies 3 time s to open
	6713	"RTN","XUS BSE1",121, 0)
	6714	;
	6715	"RTN","XUS BSE1",122, 0)
	6716	I '$$OPEN ^XWBRL(.XW BPARMS) Q "NO OPEN"
	6717	"RTN","XUS BSE1",123, 0)
	6718	S XWBPARM S("URI")=" XUS GET VI SITOR"
	6719	"RTN","XUS BSE1",124, 0)
	6720	D CLEARP^ XWBM2MEZ
	6721	"RTN","XUS BSE1",125, 0)
	6722	D SETPARA M^XWBM2MEZ (1,"STRING ",TOKEN)
	6723	"RTN","XUS BSE1",126, 0)
	6724	S XWBPARM S("URI")=" XUS GET VI SITOR"
	6725	"RTN","XUS BSE1",127, 0)
	6726	S XWBPARM S("RESULTS ")=$NA(^TM P("XUSBSE1 ",$J))
	6727	"RTN","XUS BSE1",128, 0)
	6728	S XWBCRLF L=0
	6729	"RTN","XUS BSE1",129, 0)
	6730	D REQUEST ^XWBRPCC(. XWBPARMS)
	6731	"RTN","XUS BSE1",130, 0)
	6732	I XWBCRLF L S RETRNV AL="XWBCRL FL IS TRUE " G M2MEXI T
	6733	"RTN","XUS BSE1",131, 0)
	6734	;
	6735	"RTN","XUS BSE1",132, 0)
	6736	I '$$EXEC UTE^XWBVLC (.XWBPARMS ) S RETRNV AL="FAILUR E ON EXECU TE" G M2ME XIT ;Run R PC and pla ce raw XML results i n ^TMP("XW BM2MVLC"
	6737	"RTN","XUS BSE1",133, 0)
	6738	D PARSE^X WBRPC(.XWB PARMS,"XUS BSARR") ;P arse out r aw XML and place res ults in ^T MP("XWBM2M RPC"
	6739	"RTN","XUS BSE1",134, 0)
	6740	S RETRNVA L=$G(XUSBS ARR(1))
	6741	"RTN","XUS BSE1",135, 0)
	6742	M2MEXIT ;
	6743	"RTN","XUS BSE1",136, 0)
	6744	D CLOSE^X WBM2MEZ
	6745	"RTN","XUS BSE1",137, 0)
	6746	Q RETRNVA L
	6747	"RTN","XUS BSE1",138, 0)
	6748	;
	6749	"RTN","XUS BSE1",139, 0)
	6750	HOME(TOKEN ,RAD,BSE) ; Call hom e station for token.
	6751	"RTN","XUS BSE1",140, 0)
	6752	; input TOKEN - token to i dentify us er to auth enticating server
	6753	"RTN","XUS BSE1",141, 0)
	6754	; input RAD - Zero node of applica tion data from REMOT E APPLICAT ION file ( #8994.5)
	6755	"RTN","XUS BSE1",142, 0)
	6756	; input BSE - Station #^ TCP/IP por t
	6757	"RTN","XUS BSE1",143, 0)
	6758	; returns - string of demographi c characte ristics or "-1^error message"
	6759	"RTN","XUS BSE1",144, 0)
	6760	N X,XUESS O,PORT,STN ,IP,STNIEN ,XUCACHE,S TNPRNT
	6761	"RTN","XUS BSE1",145, 0)
	6762	D:$G(XWBD EBUG) LOG^ XWBDLOG("E NTERED HOM E BSE: "_B SE) ; DEBU G
	6763	"RTN","XUS BSE1",146, 0)
	6764	Q:$P(RAD, U,2)'=-1 " " ;Not set up right
	6765	"RTN","XUS BSE1",147, 0)
	6766	;Set Stat ion #, por t from pas sed in dat a
	6767	"RTN","XUS BSE1",148, 0)
	6768	S STN=$P( BSE,U),POR T=$P(BSE,U ,2),XUESSO =""
	6769	"RTN","XUS BSE1",149, 0)
	6770	; Check i f STN is a valid sta tion numbe r in the I NSTITUTION file (sec urity chec k)
	6771	"RTN","XUS BSE1",150, 0)
	6772	S STNIEN= $$LKUP^XUA F4(STN) I STNIEN=0 S XUESSO="- 1^"_STN_" WAS NOT FO UND IN FIL E 4" Q XUE SSO
	6773	"RTN","XUS BSE1",151, 0)
	6774	; Check i f STN is a n active f acility (s ecurity ch eck)
	6775	"RTN","XUS BSE1",152, 0)
	6776	I '$$ACTI VE^XUAF4(S TNIEN) S X UESSO="-1^ "_STN_" IS NOT AN AC TIVE VA FA CILITY" Q XUESSO
	6777	"RTN","XUS BSE1",153, 0)
	6778	S IP=""
	6779	"RTN","XUS BSE1",154, 0)
	6780	; Look fo r a valid cached DNS address ( less than 1800 secon ds old)
	6781	"RTN","XUS BSE1",155, 0)
	6782	S STNPRNT =$P($$PRNT ^XUAF4(STN ),U,2) S:' +STNPRNT S TNPRNT=STN ; Convert subdivisi on to pare nt station
	6783	"RTN","XUS BSE1",156, 0)
	6784	S XUCACHE =$G(^XTMP( "XUSBSE1", STNPRNT))
	6785	"RTN","XUS BSE1",157, 0)
	6786	I ($D(XUC ACHE))&($$ HDIFF^XLFD T($H,$P(XU CACHE,U,2) ,2)<1800) S IP=$P(XU CACHE,U,1)
	6787	"RTN","XUS BSE1",158, 0)
	6788	I '$L(IP) S IP=$$IP FLOC(STNPR NT) ; Get the IP add ress from HL LOGICA L LINK fil e (#870)
	6789	"RTN","XUS BSE1",159, 0)
	6790	I '$L(IP) S IP=$$SI TESVC(STNP RNT) ; Get the IP ad dress from VASITESER VICE
	6791	"RTN","XUS BSE1",160, 0)
	6792	I '$L(IP) S XUESSO= "-1^ADDRES S FOR STN "_STN_" NO T FOUND"
	6793	"RTN","XUS BSE1",161, 0)
	6794	D:$G(XWBD EBUG) LOG^ XWBDLOG("H OME BSE IP : "_IP_" P ORT:"_PORT )
	6795	"RTN","XUS BSE1",162, 0)
	6796	I $L(IP) S XUESSO=$ $CALLBSE^X WBTCPM2(IP ,PORT,TOKE N,STN)
	6797	"RTN","XUS BSE1",163, 0)
	6798	D:$G(XWBD EBUG) LOG^ XWBDLOG("L EAVING HOM E XUESSO: "_XUESSO)
	6799	"RTN","XUS BSE1",164, 0)
	6800	I XUESSO= "Didn't op en connect ion." S XU ESSO="-1^C OULD NOT C ONNECT TO STN "_STN_ " USING PO RT "_PORT
	6801	"RTN","XUS BSE1",165, 0)
	6802	I XUESSO= "No Respon se" S XUES SO="-1^BSE TOKEN EXP IRED"
	6803	"RTN","XUS BSE1",166, 0)
	6804	Q XUESSO
	6805	"RTN","XUS BSE1",167, 0)
	6806	;
	6807	"RTN","XUS BSE1",168, 0)
	6808	IPFLOC(STN ) ;Get the address f rom the st ation numb er from HL LOGICAL L INK file ( #870)
	6809	"RTN","XUS BSE1",169, 0)
	6810	; input STN - station nu mber
	6811	"RTN","XUS BSE1",170, 0)
	6812	; retur ns - IP address or null
	6813	"RTN","XUS BSE1",171, 0)
	6814	N XUSBSE, I,RET,ADD, IP,STNPRNT
	6815	"RTN","XUS BSE1",172, 0)
	6816	S STNPRNT =$P($$PRNT ^XUAF4(STN ),U,2) S:' +STNPRNT S TNPRNT=STN ; Convert subdivisi on to pare nt station
	6817	"RTN","XUS BSE1",173, 0)
	6818	; Look fo r station number in HL LOGICAL LINK file (#870)
	6819	"RTN","XUS BSE1",174, 0)
	6820	D FIND^DI C(870,,".0 3;.08","X" ,STNPRNT,, "C",,,"XUS BSE") ; IA # 5449 "C" index loo kup
	6821	"RTN","XUS BSE1",175, 0)
	6822	Q:+$G(XUS BSE("DILIS T",0))=0 " "
	6823	"RTN","XUS BSE1",176, 0)
	6824	S I=0,ADD ="",IP=""
	6825	"RTN","XUS BSE1",177, 0)
	6826	F S I=$O (XUSBSE("D ILIST","ID ",I)) Q:'I D Q:IP
	6827	"RTN","XUS BSE1",178, 0)
	6828	. ;HL LOG ICAL LINK file (#870 ) DNS DOMA IN field ( #.08)
	6829	"RTN","XUS BSE1",179, 0)
	6830	. S ADD=X USBSE("DIL IST","ID", I,.08) I $ L(ADD) D Q:IP'=""
	6831	"RTN","XUS BSE1",180, 0)
	6832	. . I $$V ALIDATE^XL FIPV(ADD) S IP=ADD Q ;ICR #58 44
	6833	"RTN","XUS BSE1",181, 0)
	6834	. . S IP= $$ADDRESS^ XLFNSLK(AD D) S:IP="" IP=$$ADDR ESS^XLFNSL K(ADD,"A") ; Make 2 attempts t o get IP, force IPv4 on second attempt
	6835	"RTN","XUS BSE1",182, 0)
	6836	. . Q
	6837	"RTN","XUS BSE1",183, 0)
	6838	. ;HL LOG ICAL LINK file (#870 ) MAILMAIN DOMAIN fi eld (#.03)
	6839	"RTN","XUS BSE1",184, 0)
	6840	. S ADD=X USBSE("DIL IST","ID", I,.03) I $ L(ADD) D Q:IP'=""
	6841	"RTN","XUS BSE1",185, 0)
	6842	. . I $$V ALIDATE^XL FIPV(ADD) S IP=ADD Q ;ICR #58 44
	6843	"RTN","XUS BSE1",186, 0)
	6844	. . S IP= $$ADDRESS^ XLFNSLK("V ISTA."_ADD ) S:IP="" IP=$$ADDRE SS^XLFNSLK ("VISTA."_ ADD,"A") ; Make 2 at tempts to get IP, fo rce IPv4 o n second a ttempt
	6845	"RTN","XUS BSE1",187, 0)
	6846	. . Q
	6847	"RTN","XUS BSE1",188, 0)
	6848	I $L(IP) S ^XTMP("X USBSE1",ST NPRNT)=IP_ "^"_$H ; C ache the I P address
	6849	"RTN","XUS BSE1",189, 0)
	6850	Q IP
	6851	"RTN","XUS BSE1",190, 0)
	6852	;
	6853	"RTN","XUS BSE1",191, 0)
	6854	SITESVC(ST N) ;Get IP from the stn# from VISTASITES ERVICE
	6855	"RTN","XUS BSE1",192, 0)
	6856	; input STN - s tation num ber
	6857	"RTN","XUS BSE1",193, 0)
	6858	; retur ns - I P address or null
	6859	"RTN","XUS BSE1",194, 0)
	6860	N DNSADD, IP,STNPRNT
	6861	"RTN","XUS BSE1",195, 0)
	6862	S IP=""
	6863	"RTN","XUS BSE1",196, 0)
	6864	S STNPRNT =$P($$PRNT ^XUAF4(STN ),U,2) S:' +STNPRNT S TNPRNT=STN ; Convert subdivisi on to pare nt station
	6865	"RTN","XUS BSE1",197, 0)
	6866	S DNSADD= $$WEBADDRS (STNPRNT)
	6867	"RTN","XUS BSE1",198, 0)
	6868	I $L(DNSA DD) S IP=$ $ADDRESS^X LFNSLK(DNS ADD) S:IP= "" IP=$$AD DRESS^XLFN SLK(DNSADD ,"A") ; Ma ke 2 attem pts to get IP, force IPv4 on s econd atte mpt
	6869	"RTN","XUS BSE1",199, 0)
	6870	I $L(IP) S ^XTMP("X USBSE1",ST NPRNT)=IP_ "^"_$H ; C ache the I P address
	6871	"RTN","XUS BSE1",200, 0)
	6872	Q IP
	6873	"RTN","XUS BSE1",201, 0)
	6874	;
	6875	"RTN","XUS BSE1",202, 0)
	6876	WEBADDRS(S TNNUM) ;
	6877	"RTN","XUS BSE1",203, 0)
	6878	N IP,URL, XUSBSE,RES ULTS,I,X,P OP
	6879	"RTN","XUS BSE1",204, 0)
	6880	D FIND^DI C(2005.2,, "1","MO"," VISTASITES ERVICE",,, ,,"XUSBSE" )
	6881	"RTN","XUS BSE1",205, 0)
	6882	S URL=$G( XUSBSE("DI LIST","ID" ,1,1))
	6883	"RTN","XUS BSE1",206, 0)
	6884	D EN1^XUS BSE2(URL_" /getSite?s iteID="_ST NNUM,.RESU LTS)
	6885	"RTN","XUS BSE1",207, 0)
	6886	S X="" F I=1:1 Q:'$ D(RESULTS( I)) I RES ULTS(I)["h ostname>" S X=$P($P( RESULTS(I) ,"<hostnam e>",2),"</ hostname>" ) Q
	6887	"RTN","XUS BSE1",208, 0)
	6888	Q X
	6889	"RTN","XUS BSE1",209, 0)
	6890	;
	6891	"RTN","XUS BSE1",210, 0)
	6892	SETUP(XUDE MOG,XUCONT XT) ; Setu p user as visitor, a dd context option
	6893	"RTN","XUS BSE1",211, 0)
	6894	; input XUDEMOG - string o f demograp hic charac teristics
	6895	"RTN","XUS BSE1",212, 0)
	6896	; input XUCONTXT - context option to be given t o user
	6897	"RTN","XUS BSE1",213, 0)
	6898	; return value = in ternal ent ry number for user, or 0
	6899	"RTN","XUS BSE1",214, 0)
	6900	I '$$PUT^ XUESSO1(XU DEMOG) Q 0
	6901	"RTN","XUS BSE1",215, 0)
	6902	I $G(DUZ) '>0 Q 0
	6903	"RTN","XUS BSE1",216, 0)
	6904	D SETCNTX T(XUCONTXT )
	6905	"RTN","XUS BSE1",217, 0)
	6906	Q DUZ
	6907	"RTN","XUS BSE1",218, 0)
	6908	;
	6909	"RTN","XUS BSE1",219, 0)
	6910	SETCNTXT(X OPT) ;
	6911	"RTN","XUS BSE1",220, 0)
	6912	N OPT,XUC ONTXT,X
	6913	"RTN","XUS BSE1",221, 0)
	6914	S XUCONTX T="`"_XOPT
	6915	"RTN","XUS BSE1",222, 0)
	6916	I $$FIND1 ^DIC(19,"" ,"X",XUCON TXT)'>0 S X=$$LOGERR ("BSE LOGI N ERROR - CONTEXT") Q ;Contex t option n ot in opti on file
	6917	"RTN","XUS BSE1",223, 0)
	6918	I $G(DUZ( "LOA"))=1 H 1
	6919	"RTN","XUS BSE1",224, 0)
	6920	;Have to use $D bec ause of sc reen in 20 0.03 keeps FIND1^DIC from work ing.
	6921	"RTN","XUS BSE1",225, 0)
	6922	I '$D(^VA (200,DUZ,2 03,"B",XOP T)) D
	6923	"RTN","XUS BSE1",226, 0)
	6924	. ; Have to give th e user a d elegated o ption
	6925	"RTN","XUS BSE1",227, 0)
	6926	. N XARR S XARR(200 .19,"+1,"_ DUZ_",",.0 1)=XUCONTX T
	6927	"RTN","XUS BSE1",228, 0)
	6928	. D UPDAT E^DIE("E", "XARR")
	6929	"RTN","XUS BSE1",229, 0)
	6930	. ; And n ow she can give hims elf the co ntext opti on
	6931	"RTN","XUS BSE1",230, 0)
	6932	. K XARR S XARR(200 .03,"+1,"_ DUZ_",",.0 1)=XUCONTX T
	6933	"RTN","XUS BSE1",231, 0)
	6934	. D UPDAT E^DIE("E", "XARR") ; Give conte xt option as a secon dary menu item
	6935	"RTN","XUS BSE1",232, 0)
	6936	. S ^XUTL ("XQ",$J," DUZ(BSE)") =XUCONTXT
	6937	"RTN","XUS BSE1",233, 0)
	6938	. ; But n ow we have to remove the deleg ated optio n
	6939	"RTN","XUS BSE1",234, 0)
	6940	. S OPT=$ $FIND1^DIC (200.19,", "_DUZ_",", "X",XUCONT XT)
	6941	"RTN","XUS BSE1",235, 0)
	6942	. I OPT>0 D
	6943	"RTN","XUS BSE1",236, 0)
	6944	. . K XAR R S XARR(2 00.19,(OPT _","_DUZ_" ,"),.01)=" @"
	6945	"RTN","XUS BSE1",237, 0)
	6946	. . D FIL E^DIE("E", "XARR")
	6947	"RTN","XUS BSE1",238, 0)
	6948	. . Q
	6949	"RTN","XUS BSE1",239, 0)
	6950	. Q
	6951	"RTN","XUS BSE1",240, 0)
	6952	Q
	6953	"RTN","XUS BSE1",241, 0)
	6954	;
	6955	"RTN","XUS BSE1",242, 0)
	6956	STNTEST ; tests stat ion#-to-IP conversio n (IPFLOC, WEBADDRS) used by HO ME station #-based ca llback
	6957	"RTN","XUS BSE1",243, 0)
	6958	N XUSLSTI ,XUSLSTV,X USSTN,XUSI P1,XUSIP2, XUSBSE
	6959	"RTN","XUS BSE1",244, 0)
	6960	W !,"Brok er Securit y Enhancem ent (BSE) Station Nu mber-to-IP conversio n test (fo r BSE"
	6961	"RTN","XUS BSE1",245, 0)
	6962	W !,"call backs to h ome system ). Note: I t is not n ecessarily wrong if results di ffer"
	6963	"RTN","XUS BSE1",246, 0)
	6964	W !,"or a re blank. 2 methods' results a re listed: HL LOGICA L LINK/VIS TASITESERV ICE"
	6965	"RTN","XUS BSE1",247, 0)
	6966	;
	6967	"RTN","XUS BSE1",248, 0)
	6968	D FIND^DI C(2005.2,, "1","MO"," VISTASITES ERVICE",,, ,,"XUSBSE" )
	6969	"RTN","XUS BSE1",249, 0)
	6970	W !!," lo cal VISTAS ITESERVICE server:", !," ",$G(X USBSE("DIL IST","ID", 1,1)),"",!
	6971	"RTN","XUS BSE1",250, 0)
	6972	K ^TMP($J ,"XUSBSE1" )
	6973	"RTN","XUS BSE1",251, 0)
	6974	DO LIST^D IC(4,,"@;. 01;11;99;1 01","IP",, ,,"D",,,$N A(^TMP($J, "XUSBSE1") ))
	6975	"RTN","XUS BSE1",252, 0)
	6976	S XUSLSTI =0 F S XU SLSTI=$O(^ TMP($J,"XU SBSE1","DI LIST",XUSL STI)) Q:'+ XUSLSTI D
	6977	"RTN","XUS BSE1",253, 0)
	6978	. S XUSLS TV=^TMP($J ,"XUSBSE1" ,"DILIST", XUSLSTI,0)
	6979	"RTN","XUS BSE1",254, 0)
	6980	. Q:+$P(X USLSTV,U,5 )
	6981	"RTN","XUS BSE1",255, 0)
	6982	. S XUSST N=$P(XUSLS TV,U,4) Q: '$$TF^XUAF 4(XUSSTN)
	6983	"RTN","XUS BSE1",256, 0)
	6984	. S XUSIP 1=$$IPFLOC (XUSSTN),X USIP2=$$SI TESVC(XUSS TN)
	6985	"RTN","XUS BSE1",257, 0)
	6986	. I $L(XU SIP1)!$L(X USIP2) D
	6987	"RTN","XUS BSE1",258, 0)
	6988	. . W !,X USSTN,?8," (",$P(XUSL STV,U,2)," ): " W $S( $L(XUSIP1) :XUSIP1,1: "blank")," /",$S($L(X USIP2):XUS IP2,1:"bla nk")
	6989	"RTN","XUS BSE1",259, 0)
	6990	. . I $L( XUSIP1),$L (XUSIP2),( XUSIP1'=XU SIP2) W " *DIFFERE NT*"
	6991	"RTN","XUS BSE1",260, 0)
	6992	K ^TMP($J ,"XUSBSE1" )
	6993	"RTN","XUS BSE1",261, 0)
	6994	Q
	6995	"RTN","XUS BSE1",262, 0)
	6996	LOGERR(XUS ETXT) ; lo g an error in error trap for f ailed logi n attempts ; p595
	6997	"RTN","XUS BSE1",263, 0)
	6998	; XUSETXT is the er ror subjec t line $ZE
	6999	"RTN","XUS BSE1",264, 0)
	7000	; The fun ction retu rns 0 if t he error w as screene d, and 1 i f an error was trapp ed
	7001	"RTN","XUS BSE1",265, 0)
	7002	N XUSAPP
	7003	"RTN","XUS BSE1",266, 0)
	7004	; ZEXCEPT : XWBSEC,X UDEMOG - K ernel glob al variabl es
	7005	"RTN","XUS BSE1",267, 0)
	7006	S XUSAPP= $P($G(DUZ( "REMAPP")) ,U,2)
	7007	"RTN","XUS BSE1",268, 0)
	7008	I $P($G(X UDEMOG),U, 2)="BSE TO KEN EXPIRE D" Q 0 ; screen out "TOKEN EX PIRED" err ors
	7009	"RTN","XUS BSE1",269, 0)
	7010	I $G(XWBS EC)="BSE E RROR - BSE TOKEN EXP IRED" Q 0 ; screen out "TOKEN EXPIRED" errors
	7011	"RTN","XUS BSE1",270, 0)
	7012	I XUSAPP' ="" S XUSE TXT=XUSETX T_" ("_XUS APP_")"
	7013	"RTN","XUS BSE1",271, 0)
	7014	D APPERRO R^%ZTER($E (XUSETXT,1 ,32))
	7015	"RTN","XUS BSE1",272, 0)
	7016	Q 1
	7017	"RTN","XUS BSE1",273, 0)
	7018	;
	7019	"RTN","XUS BSE1",274, 0)
	7020	BSETOKEN(R ET,XPHRASE ) ; RPC. X US BSE TOK EN - IA #( under deve lopment)
	7021	"RTN","XUS BSE1",275, 0)
	7022	;Returns a string t hat can be passed as the XUBUS RNM parame ter to the
	7023	"RTN","XUS BSE1",276, 0)
	7024	;XUS SIGN ON SETUP r pc to auth enticate a user on a remote sy stem. The input
	7025	"RTN","XUS BSE1",277, 0)
	7026	;is an ap plication identifier (pass phr ase) that, when hash ed,
	7027	"RTN","XUS BSE1",278, 0)
	7028	;matches the stored hash of a n authoriz ed applica tion in th e REMOTE
	7029	"RTN","XUS BSE1",279, 0)
	7030	;APPLICAT ION file ( #8994.5) A PPLICATION CODE field (#.03)
	7031	"RTN","XUS BSE1",280, 0)
	7032	; - Input - Applica tion pass phrase
	7033	"RTN","XUS BSE1",281, 0)
	7034	N XAPP,XP ORT,XSTA,X STATION,XS TRING,XTOK EN
	7035	"RTN","XUS BSE1",282, 0)
	7036	S XAPP=$G (XPHRASE)
	7037	"RTN","XUS BSE1",283, 0)
	7038	I XAPP="" S RET="-1 ^NOT AUTHE NTICATED" Q ;Applic ation must be authen ticated
	7039	"RTN","XUS BSE1",284, 0)
	7040	S XAPP=$$ GETCNTXT^X UESSO2(XPH RASE)
	7041	"RTN","XUS BSE1",285, 0)
	7042	I +XAPP=- 1 S RET="- 1^NOT AUTH ENTICATED" Q ;Appli cation mus t be authe nticated
	7043	"RTN","XUS BSE1",286, 0)
	7044	S XAPP=XP HRASE
	7045	"RTN","XUS BSE1",287, 0)
	7046	D SETVISI T(.XTOKEN)
	7047	"RTN","XUS BSE1",288, 0)
	7048	I XTOKEN= "-1^NOT AU THENTICATE D" S RET=X TOKEN Q ; User must be authent icated
	7049	"RTN","XUS BSE1",289, 0)
	7050	I $G(DUZ( 2))="" S R ET="-1^HOM E STATION NOT IDENTI FIED" Q ; User must be authent icated on valid home station
	7051	"RTN","XUS BSE1",290, 0)
	7052	S XSTA=$$ NS^XUAF4(D UZ(2))
	7053	"RTN","XUS BSE1",291, 0)
	7054	S XSTATIO N=$P(XSTA, U,2)
	7055	"RTN","XUS BSE1",292, 0)
	7056	I XSTA="" S RET="-1 ^HOME STAT ION NOT ID ENTIFIED" Q ;User m ust be aut henticated on valid home stati on
	7057	"RTN","XUS BSE1",293, 0)
	7058	S XPORT=$ G(^XTMP("X USBSE1","R PCBrokerPo rt"))
	7059	"RTN","XUS BSE1",294, 0)
	7060	I XPORT=" " D
	7061	"RTN","XUS BSE1",295, 0)
	7062	. ; Do a VistA Exch ange Site Service lo okup for c urrent sta tion (once daily)
	7063	"RTN","XUS BSE1",296, 0)
	7064	. N IP,UR L,XUSBSE,R ESULTS,I,X ,POP
	7065	"RTN","XUS BSE1",297, 0)
	7066	. D FIND^ DIC(2005.2 ,,"1","MO" ,"VISTASIT ESERVICE", ,,,,"XUSBS E")
	7067	"RTN","XUS BSE1",298, 0)
	7068	. S URL=$ G(XUSBSE(" DILIST","I D",1,1))
	7069	"RTN","XUS BSE1",299, 0)
	7070	. D EN1^X USBSE2(URL _"/getSite ?siteID="_ XSTATION,. RESULTS)
	7071	"RTN","XUS BSE1",300, 0)
	7072	. S X="" F I=1:1 Q: '$D(RESULT S(I)) I R ESULTS(I)[ "port>" S X=$P($P(RE SULTS(I)," <port>",2) ,"</port>" ) Q
	7073	"RTN","XUS BSE1",301, 0)
	7074	. S XPORT =X
	7075	"RTN","XUS BSE1",302, 0)
	7076	. I XPORT '="" S ^XT MP("XUSBSE 1","RPCBro kerPort")= X
	7077	"RTN","XUS BSE1",303, 0)
	7078	I XPORT=" " S RET="- 1^RPC BROK ER PORT NO T AVAILABL E" Q ;Cou ld not obt ain port f rom VistA Exchange S ite Servic e lookup
	7079	"RTN","XUS BSE1",304, 0)
	7080	S XSTRING =XAPP_"^"_ XTOKEN_"^" _XSTATION_ "^"_XPORT
	7081	"RTN","XUS BSE1",305, 0)
	7082	S RET="-3 5^"_$$ENCR YP^XUSRB1( XSTRING)
	7083	"RTN","XUS BSE1",306, 0)
	7084	Q
	7085	"RTN","XUS BSE1",307, 0)
	7086	;
	7087	"RTN","XUS HSH")
	7088	0^30^B3789 1600^B3104 0658
	7089	"RTN","XUS HSH",1,0)
	7090	XUSHSH ;IS F/STAFF - ENCRYPTION /DECRYPTIO N UTILITIE S ;01/20/1 6 14:33
	7091	"RTN","XUS HSH",2,0)
	7092	;;8.0;KER NEL;655, 659;Jul 10, 1995;B uild 22
	7093	"RTN","XUS HSH",3,0)
	7094	;Per VA D irective 6 402, this routine sh ould not b e modified .
	7095	"RTN","XUS HSH",4,0)
	7096	;
	7097	"RTN","XUS HSH",5,0)
	7098	;ZEXCEPT: X ;Return ed global value when called as an extrin sic subrou tine.
	7099	"RTN","XUS HSH",6,0)
	7100	S X=$$EN( X)
	7101	"RTN","XUS HSH",7,0)
	7102	Q
	7103	"RTN","XUS HSH",8,0)
	7104	;
	7105	"RTN","XUS HSH",9,0)
	7106	EN(X) ;Ext rinsic fun ction $$EN ^XUSHSH(X) , IA #4758
	7107	"RTN","XUS HSH",10,0)
	7108	N XUA,XUI ,XUJ,XUL,X UR,XUX,XUY ,XUY1,XUZ D KE Q X
	7109	"RTN","XUS HSH",11,0)
	7110	;
	7111	"RTN","XUS HSH",12,0)
	7112	KE ;Intrin sic subrou tine.
	7113	"RTN","XUS HSH",13,0)
	7114	Q:X="" S XUX=$E(X, 1,20),X="" ,XUL=$L(XU X) D CL F XUZ=1:1 Q: $L(X)>19 D C S X=$S (XUZ#2:XUX _X,1:X_XUX )
	7115	"RTN","XUS HSH",14,0)
	7116	S X=$E(X, 1,20)
	7117	"RTN","XUS HSH",15,0)
	7118	S X=$TR(X ,$C(127,12 8))
	7119	"RTN","XUS HSH",16,0)
	7120	Q
	7121	"RTN","XUS HSH",17,0)
	7122	;
	7123	"RTN","XUS HSH",18,0)
	7124	B ;Intrins ic subrout ine.
	7125	"RTN","XUS HSH",19,0)
	7126	;ZEXCEPT: X ;Extrin sic global value
	7127	"RTN","XUS HSH",20,0)
	7128	;ZEXCEPT: XUI,XUJ ; Intrinsic global val ues
	7129	"RTN","XUS HSH",21,0)
	7130	F XUI=0:0 Q:X'[$C(1 27) S XUJ =$F(X,$C(1 27)),X=$E( X,1,XUJ-2) _$E(X,XUJ, 20)
	7131	"RTN","XUS HSH",22,0)
	7132	F XUI=0:0 Q:X'[$C(1 28) S XUJ =$F(X,$C(1 28)),X=$E( X,1,XUJ-2) _$E(X,XUJ, 20)
	7133	"RTN","XUS HSH",23,0)
	7134	Q
	7135	"RTN","XUS HSH",24,0)
	7136	;
	7137	"RTN","XUS HSH",25,0)
	7138	C ;Intrins ic subrout ine.
	7139	"RTN","XUS HSH",26,0)
	7140	;ZEXCEPT: XUA,XUI,X UJ,XUL,XUR ,XUX,XUY,X UY1 ;Intri nsic globa l values
	7141	"RTN","XUS HSH",27,0)
	7142	S XUR=0 F XUI=1:1:X UL S XUR=X UR+$A(XUX, XUI)
	7143	"RTN","XUS HSH",28,0)
	7144	S XUR=XUR #94
	7145	"RTN","XUS HSH",29,0)
	7146	F XUI=1:1 :XUL S XUJ =$F(XUA(XU I),$E(XUX, XUI))-1+XU R\2,XUA(XU I)=$E(XUA( XUI),XUJ,9 99)_$E(XUA (XUI),1,XU J-1)
	7147	"RTN","XUS HSH",30,0)
	7148	S XUY="" F XUI=1:1: XUL S XUY1 =$F(XUA(XU I#XUL+1),$ E(XUX,XUI) )+33 S:XUY 1=94 XUY1= -1 S XUY=X UY_$C(XUY1 )
	7149	"RTN","XUS HSH",31,0)
	7150	S XUX=XUY Q
	7151	"RTN","XUS HSH",32,0)
	7152	;
	7153	"RTN","XUS HSH",33,0)
	7154	CL ;Intrin sic subrou tine.
	7155	"RTN","XUS HSH",34,0)
	7156	F XUI=1:1 :XUL S XUA (XUI)=$P($ T(Z+$A($E( XUX,XUI))+ XUI#20+1), ";",3,9)
	7157	"RTN","XUS HSH",35,0)
	7158	Q
	7159	"RTN","XUS HSH",36,0)
	7160	;
	7161	"RTN","XUS HSH",37,0)
	7162	SHAHASH(N, X,FLAG) ;O ne-Way Has h Utility, IA #6189
	7163	"RTN","XUS HSH",38,0)
	7164	;Input: N = L ength in b its of the desired h ash.
	7165	"RTN","XUS HSH",39,0)
	7166	; 160 (SHA-1 )
	7167	"RTN","XUS HSH",40,0)
	7168	; 224 (SHA-2 24)
	7169	"RTN","XUS HSH",41,0)
	7170	; 256 (SHA-2 56)
	7171	"RTN","XUS HSH",42,0)
	7172	; 384 (SHA-3 84)
	7173	"RTN","XUS HSH",43,0)
	7174	; 512 (SHA-5 12)
	7175	"RTN","XUS HSH",44,0)
	7176	; X = S tring to b e hashed.
	7177	"RTN","XUS HSH",45,0)
	7178	; FLAG = ( Optional) Flag to co ntrol form at of hash :
	7179	"RTN","XUS HSH",46,0)
	7180	; "H" - He xadecimal (default)
	7181	"RTN","XUS HSH",47,0)
	7182	; "B" - Ba se64 Encod ed
	7183	"RTN","XUS HSH",48,0)
	7184	;Return: String = H ashed valu e of X.
	7185	"RTN","XUS HSH",49,0)
	7186	;ZEXCEPT: Encryptio n,SHAHash
	7187	"RTN","XUS HSH",50,0)
	7188	N I,Y,Z,X OUT
	7189	"RTN","XUS HSH",51,0)
	7190	I ('$D(N) )!('$D(X)) Q ""
	7191	"RTN","XUS HSH",52,0)
	7192	I ($G(N)' =160)&($G( N)'=224)&( $G(N)'=256 )&($G(N)'= 384)&($G(N )'=512) Q ""
	7193	"RTN","XUS HSH",53,0)
	7194	S XOUT="" ,Y=$SYSTEM .Encryptio n.SHAHash( N,X)
	7195	"RTN","XUS HSH",54,0)
	7196	I $G(FLAG )="B" D
	7197	"RTN","XUS HSH",55,0)
	7198	. S XOUT= $$B64ENCD( Y)
	7199	"RTN","XUS HSH",56,0)
	7200	E D
	7201	"RTN","XUS HSH",57,0)
	7202	. F I=1:1 D Q:Z=-1
	7203	"RTN","XUS HSH",58,0)
	7204	. . S Z=$ A(Y,I) Q:Z =-1
	7205	"RTN","XUS HSH",59,0)
	7206	. . S XOU T=XOUT_$$R J^XLFSTR($ $CNV^XLFUT L(Z,16),2, "0")
	7207	"RTN","XUS HSH",60,0)
	7208	Q XOUT
	7209	"RTN","XUS HSH",61,0)
	7210	;
	7211	"RTN","XUS HSH",62,0)
	7212	B64ENCD(X) ;Base 64 Encode, IA #6189
	7213	"RTN","XUS HSH",63,0)
	7214	;Use with $$B64DECD
	7215	"RTN","XUS HSH",64,0)
	7216	;Input: X = S tring to b e encoded.
	7217	"RTN","XUS HSH",65,0)
	7218	;Return: String = E ncoded val ue of X.
	7219	"RTN","XUS HSH",66,0)
	7220	;ZEXCEPT: Encryptio n,Base64En code
	7221	"RTN","XUS HSH",67,0)
	7222	Q $SYSTEM .Encryptio n.Base64En code(X)
	7223	"RTN","XUS HSH",68,0)
	7224	;
	7225	"RTN","XUS HSH",69,0)
	7226	B64DECD(X) ;Base 64 Decode, IA #6189
	7227	"RTN","XUS HSH",70,0)
	7228	;Use with $$B64ENCD
	7229	"RTN","XUS HSH",71,0)
	7230	;Input: X = S tring to b e decoded.
	7231	"RTN","XUS HSH",72,0)
	7232	;Return: String = D ecoded val ue of X.
	7233	"RTN","XUS HSH",73,0)
	7234	;ZEXCEPT: Encryptio n,Base64De code
	7235	"RTN","XUS HSH",74,0)
	7236	Q $SYSTEM .Encryptio n.Base64De code(X)
	7237	"RTN","XUS HSH",75,0)
	7238	;
	7239	"RTN","XUS HSH",76,0)
	7240	RSAENCR(TE XT,CERT,CA FILE,CRLFI LE,ENC) ;R SA Encrypt , IA #6189
	7241	"RTN","XUS HSH",77,0)
	7242	;Use with $$RSADECR
	7243	"RTN","XUS HSH",78,0)
	7244	;Input: TEXT = P laintext s tring to b e encrypte d.
	7245	"RTN","XUS HSH",79,0)
	7246	; CERT = A n X.509 ce rtificate containing the RSA p ublic key to be used for encry ption,
	7247	"RTN","XUS HSH",80,0)
	7248	; i n PEM enco ded or bin ary DER fo rmat. Note that the length of the plaint ext can
	7249	"RTN","XUS HSH",81,0)
	7250	; n ot be grea ter than t he length of the mod ulus of th e RSA publ ic key con tained
	7251	"RTN","XUS HSH",82,0)
	7252	; i n the cert ificate mi nus 42 byt es.
	7253	"RTN","XUS HSH",83,0)
	7254	; CAFILE = T he name of a file co ntaining t rusted Cer tificate A uthority X .509 Certi ficates
	7255	"RTN","XUS HSH",84,0)
	7256	; i n PEM-enco ded format , one of w hich was u sed to sig n the Cert ificate (o ptional).
	7257	"RTN","XUS HSH",85,0)
	7258	; C RLFILE = T he name of a file co ntaining X .509 Certi ficate Rev ocation Li sts in PEM -encoded
	7259	"RTN","XUS HSH",86,0)
	7260	; f ormat that should be checked t o verify t he status of the Cer tificate ( optional).
	7261	"RTN","XUS HSH",87,0)
	7262	; ENC = E ncoding - PKCS #1 v2 .1 encodin g method ( optional):
	7263	"RTN","XUS HSH",88,0)
	7264	; 1 = OAEP ( default)
	7265	"RTN","XUS HSH",89,0)
	7266	; 2 = PKCS1- v1_5
	7267	"RTN","XUS HSH",90,0)
	7268	;Return: String = C iphertext.
	7269	"RTN","XUS HSH",91,0)
	7270	;ZEXCEPT: Encryptio n,RSAEncry pt
	7271	"RTN","XUS HSH",92,0)
	7272	I ('$D(TE XT))!('$D( CERT)) Q " "
	7273	"RTN","XUS HSH",93,0)
	7274	I $G(ENC) '=2 S ENC= 1
	7275	"RTN","XUS HSH",94,0)
	7276	Q $SYSTEM .Encryptio n.RSAEncry pt(TEXT,CE RT,$G(CAFI LE),$G(CRL FILE),ENC)
	7277	"RTN","XUS HSH",95,0)
	7278	;
	7279	"RTN","XUS HSH",96,0)
	7280	RSADECR(TE XT,KEY,PWD ,ENC) ;RSA Decrypt, IA #6189
	7281	"RTN","XUS HSH",97,0)
	7282	;Use with $$RSAENCR
	7283	"RTN","XUS HSH",98,0)
	7284	;Input: TEXT = C iphertext string to be decrypt ed.
	7285	"RTN","XUS HSH",99,0)
	7286	; KEY = R SA private key corre sponding t o the RSA public key that was used for
	7287	"RTN","XUS HSH",100,0 )
	7288	; e ncryption, PEM encod ed.
	7289	"RTN","XUS HSH",101,0 )
	7290	; PWD = P rivate key password (optional) .
	7291	"RTN","XUS HSH",102,0 )
	7292	; ENC = E ncoding - PKCS #1 v2 .1 encodin g method ( optional):
	7293	"RTN","XUS HSH",103,0 )
	7294	; 1 = OAEP ( default)
	7295	"RTN","XUS HSH",104,0 )
	7296	; 2 = PKCS1- v1_5
	7297	"RTN","XUS HSH",105,0 )
	7298	;Return: String = P laintext.
	7299	"RTN","XUS HSH",106,0 )
	7300	;ZEXCEPT: Encryptio n,RSADecry pt
	7301	"RTN","XUS HSH",107,0 )
	7302	I ('$D(TE XT))!('$D( KEY)) Q ""
	7303	"RTN","XUS HSH",108,0 )
	7304	I $G(ENC) '=2 S ENC= 1
	7305	"RTN","XUS HSH",109,0 )
	7306	Q $SYSTEM .Encryptio n.RSADecry pt(TEXT,KE Y,$G(PWD), ENC)
	7307	"RTN","XUS HSH",110,0 )
	7308	;
	7309	"RTN","XUS HSH",111,0 )
	7310	AESENCR(TE XT,KEY,IV) ;AES Encr ypt, IA #6 189
	7311	"RTN","XUS HSH",112,0 )
	7312	;Use with $$EASDECR
	7313	"RTN","XUS HSH",113,0 )
	7314	;Input: TEXT = P laintext s tring to b e encrypte d.
	7315	"RTN","XUS HSH",114,0 )
	7316	; KEY = I nput key m aterial 16 , 24, or 3 2 characte rs long.
	7317	"RTN","XUS HSH",115,0 )
	7318	; IV = I nitializat ion vector (optional ). If this argument is present it must b e 16 chara cters long .
	7319	"RTN","XUS HSH",116,0 )
	7320	;Return: String = C iphertext.
	7321	"RTN","XUS HSH",117,0 )
	7322	;ZEXCEPT: Encryptio n,AESCBCEn crypt
	7323	"RTN","XUS HSH",118,0 )
	7324	I ('$D(TE XT))!('$D( KEY)) Q ""
	7325	"RTN","XUS HSH",119,0 )
	7326	Q $SYSTEM .Encryptio n.AESCBCEn crypt(TEXT ,KEY,$G(IV ))
	7327	"RTN","XUS HSH",120,0 )
	7328	;
	7329	"RTN","XUS HSH",121,0 )
	7330	AESDECR(TE XT,KEY,IV) ;AES Decr ypt, IA #6 189
	7331	"RTN","XUS HSH",122,0 )
	7332	;Use with $$EASENCR
	7333	"RTN","XUS HSH",123,0 )
	7334	;Input: TEXT = C iphertext string to be decrypt ed.
	7335	"RTN","XUS HSH",124,0 )
	7336	; KEY = I nput key m aterial 16 , 24, or 3 2 characte rs long.
	7337	"RTN","XUS HSH",125,0 )
	7338	; IV = I nitializat ion vector (optional ). If this argument is present it must b e 16 chara cters long .
	7339	"RTN","XUS HSH",126,0 )
	7340	;Return: String = P laintext.
	7341	"RTN","XUS HSH",127,0 )
	7342	;ZEXCEPT: Encryptio n,AESCBCDe crypt
	7343	"RTN","XUS HSH",128,0 )
	7344	I ('$D(TE XT))!('$D( KEY)) Q ""
	7345	"RTN","XUS HSH",129,0 )
	7346	Q $SYSTEM .Encryptio n.AESCBCDe crypt(TEXT ,KEY,$G(IV ))
	7347	"RTN","XUS HSH",130,0 )
	7348	;
	7349	"RTN","XUS HSH",131,0 )
	7350	Z ;;
	7351	"RTN","XUS HSH",132,0 )
	7352	;;&Qu9l) Jjk\|1O+NpA =3*Lbv[(XF ,zZWHgi>S" UM;0@.dIon }4_Pw-8qyC ?K/YV6t7sE ]f~x'D`TB% R#a{\!G<2$ h5rc:me
	7353	"RTN","XUS HSH",133,0 )
	7354	;;-tFWg@0 D[T2{MZLb/ o8y.Jp3Oh7 w:knRmqV~X u#E]GYC+'! rP(4\|ScBU" Nv*}z&da6j <e$H,xKA9\ ; s>?%`51I =il_fQ)
	7355	"RTN","XUS HSH",134,0 )
	7356	;;1ZsHoTn Y;av~%0O+h X,gx[?qCFA /:6{V7\|y*f }]258)4GUN l-Q_@r#cPW >$w kB3D"K (iLJ=!E'S< MRe&p.mjI\ d`u9tzb
	7357	"RTN","XUS HSH",135,0 )
	7358	;;J02b7\|* p>`WlOm6qI 1Q\Me&)i.E TGwH"RLVu{ oBv=P?8+X- j%A!(<]Z,g kh4FDc$}K9 n5YC#af;x3 /Uty~_N@'r S[sz: d
	7359	"RTN","XUS HSH",136,0 )
	7360	;;>uKF}Qp Bl;~A2DVO= eY</Em&onT .j#+,058"a $k!WN:7LM@ \hGv]-3_41 `'*y?UPwCZ X% xIq{(ft i)r9HSgRJb 6cd\|sz[
	7361	"RTN","XUS HSH",137,0 )
	7362	;;]z>}GUq T.K4ePp#;M sf"FHc8[J$ I2%Sx-~3Eu rkgBV?\*iW \|&_@=YZ 5b 7/<9,`0:Ny RaQlhv)X1D o6'({!mLjA tCO+nwd
	7363	"RTN","XUS HSH",138,0 )
	7364	;;6Bv>kYg j_GJFE`q]! H27usXz5Zx R%p.Kh{)tU e:~=LV@/[S w1<Ob$#,8d aoT\4cri?A l+Nn3IPmMy 9*0"QW\|'Cf D&;}- (
	7365	"RTN","XUS HSH",139,0 )
	7366	;;_}+Fkea 1<Z,SDh~ ` Y62BHuN-Jq O>5j(xsl3* !{G"T&M[/w W4PpiCLtUI 9bm:r%fRV. @dQE0A]c\$ o\|y7;8g?)# =Kz'vnX
	7367	"RTN","XUS HSH",140,0 )
	7368	;;TZlp]~x %8,E.}\|kMH 9/!3a z`yW ed0Ccm\jB# SgOfIJ&_(6 s{K"@L);>P 5<uYD2+nvV Rb:'$?XNio qA17-rU=wF t*Gh[4Q
	7369	"RTN","XUS HSH",141,0 )
	7370	;;{.= Kt& vz8_`D;+BY c-GkQ"[gJd \|]oInwyT'l >)e:XN3UVa hiS0!9PqE$ L?HA4,R/Mm 2W~<*6pjrF #@uZ}5%7xb s(Of1\C
	7371	"RTN","XUS HSH",142,0 )
	7372	;;f6\W:mY iF.$"hR<Xq E4_sdk-3T, yO#Ix}`r'n /C)tp9{=N BljLKgvuc[ P&!>]VU~20 zD+1A5H8%S GQ?@*(Zb\|o 7JM;aew
	7373	"RTN","XUS HSH",143,0 )
	7374	;;]'x[m!8 OPYLQosE t w{$HuZv"*G h;7N2.D~Ji 3<%e)@a0fB U&dCR1A+=M n\p\|jzTyK` #/S_br:-V> FI96,}cq4l 5?WXgk(
	7375	"RTN","XUS HSH",144,0 )
	7376	;;A{;0d/H $jg.Niy!:' tcah`&z\*" GTeO=MFI~Z 5vbu>m_9)C }6Ps73%x]w [?Xrf+QKRq WB\|<4EY8DS n1kL oV-@2 #lU(Jp,
	7377	"RTN","XUS HSH",145,0 )
	7378	;;Aot4N!@ 'r/{Rk_<EC "B8l +6)YF z?ID:evMJ[ SpZXPs9>f0 \caKwU]%*y }GH,m7QdhT &b1V~-L5Og x\|qju=$`32 (.Win;#
	7379	"RTN","XUS HSH",146,0 )
	7380	;;-xZ\h3_ $9.7f>Be!* sT w"UAJ4{ q[0mybrENS <dP&]~2i8I a'MjcKYu;: Rn=G/)t?1W +#%5Q\|l(v6 pFO`D@V,oC kgzX}LH
	7381	"RTN","XUS HSH",147,0 )
	7382	;;mkU3n g /96z>Hx`C" fl5e#uw}Kr j7_o*J+vbN R)h\XyOVZ@ tE{QTM\|]8; c?$PaBW:40 ,1dY%FG!L[ i~D(A.2p=- S'&<sqI
	7383	"RTN","XUS HSH",148,0 )
	7384	;;pnRq(hW 1)`Xt7D=9P aT*8<d+3/v IEQrcb-gBj YH]MSU#Nwi s5.om_%Cu> }6~x{;\|!FA \y ekKl,O& ['?VG0:2@L Z$fJ4"z
	7385	"RTN","XUS HSH",149,0 )
	7386	;;RJfF>=} :0@(8tW-Ai d6h*{/,)ON _B"MZHo.?I ]Eek<yL5v3 $`c[x~74aY qnDuz1bp+\ 2smlVCQSP# G&j;X9r%g' w!\|TKU
	7387	"RTN","XUS HSH",150,0 )
	7388	;;o*B~e]p 0lRY[=/`7C nfO'Wb2+sd 3a,6#k{&LU (".qMNG$A% mg:J?Dwc!x 5XvS;yj4t< uP@h_KT98 }\H1ZQ-rFi \|I)>zVE
	7389	"RTN","XUS HSH",151,0 )
	7390	;;E7UvoK3 Z%-y$2]s?} mBLQ!OVN'd 58&+rk4;_ >u#/1PIt@< ~x[G`WA"CM iq\|pj=,:a) glXJn0RbwF fDz*e(\H9h c6.{TSY
	7391	"RTN","XUS HSH",152,0 )
	7392	;;
	7393	"RTN","XUS KAAJ")
	7394	0^28^B1171 8164^B1162 9985
	7395	"RTN","XUS KAAJ",1,0)
	7396	XUSKAAJ ;; 12/15/15 08:54;08/2 4/2006
	7397	"RTN","XUS KAAJ",2,0)
	7398	;;8.0;KER NEL;329, 430,659; Jul 10, 19 95;Build 2 2
	7399	"RTN","XUS KAAJ",3,0)
	7400	;Per VA D irective 6 402, this routine sh ould not b e modified .
	7401	"RTN","XUS KAAJ",4,0)
	7402	;;
	7403	"RTN","XUS KAAJ",5,0)
	7404	QUIT
	7405	"RTN","XUS KAAJ",6,0)
	7406	;
	7407	"RTN","XUS KAAJ",7,0)
	7408	; ------- ---------- ---------- ---------- ---------- ---------- ---------- -----
	7409	"RTN","XUS KAAJ",8,0)
	7410	; SSO/U C KAAJEE R PCs
	7411	"RTN","XUS KAAJ",9,0)
	7412	; ------- ---------- ---------- ---------- ---------- ---------- ---------- -----
	7413	"RTN","XUS KAAJ",10,0 )
	7414	;
	7415	"RTN","XUS KAAJ",11,0 )
	7416	USERINFO(R ET,CLIENTI P,SERVERNM ) ; called by XUS KA AJEE GET U SER INFO r pc
	7417	"RTN","XUS KAAJ",12,0 )
	7418	;
	7419	"RTN","XUS KAAJ",13,0 )
	7420	; INPUT:
	7421	"RTN","XUS KAAJ",14,0 )
	7422	; CLIENTI P is IP ad dress of t he client workstatio n, used fo r logging (signon lo g) and IP blocking ( failed acc ess attemp ts).
	7423	"RTN","XUS KAAJ",15,0 )
	7424	; SERVERN M is Ident ifying nam e for the calling ap plication or server, used for logging (s ignon log) .
	7425	"RTN","XUS KAAJ",16,0 )
	7426	; OUTPUT:
	7427	"RTN","XUS KAAJ",17,0 )
	7428	; Result( 0) is the users DUZ.
	7429	"RTN","XUS KAAJ",18,0 )
	7430	; Result( 1) is the user name from the . 01 field.
	7431	"RTN","XUS KAAJ",19,0 )
	7432	; Result( 2) is the users full name from the name standard f ile.
	7433	"RTN","XUS KAAJ",20,0 )
	7434	; Result( 3) is the FAMILY (LA ST) NAME
	7435	"RTN","XUS KAAJ",21,0 )
	7436	; Result( 4) is the GIVEN (FIR ST) NAME
	7437	"RTN","XUS KAAJ",22,0 )
	7438	; Result( 5) is the MIDDLE NAM E
	7439	"RTN","XUS KAAJ",23,0 )
	7440	; Result( 6) is the PREFIX
	7441	"RTN","XUS KAAJ",24,0 )
	7442	; Result( 7) is the SUFFIX
	7443	"RTN","XUS KAAJ",25,0 )
	7444	; Result( 8) is the DEGREE
	7445	"RTN","XUS KAAJ",26,0 )
	7446	; Result( 9) is stat ion # of t he divisio n that the user is w orking in.
	7447	"RTN","XUS KAAJ",27,0 )
	7448	; Result( 10) is the station # of the pa rent facil ity for th e login di vision
	7449	"RTN","XUS KAAJ",28,0 )
	7450	; Result( 11) is the station # from the KSP site p arameters, the paren t "compute r system"
	7451	"RTN","XUS KAAJ",29,0 )
	7452	; Result( 12) is the signon lo g entry IE N
	7453	"RTN","XUS KAAJ",30,0 )
	7454	; Result( 13) = # of permissib le divisio ns
	7455	"RTN","XUS KAAJ",31,0 )
	7456	; Result( 14-n) are the permis sible divi sions for user login , in the f ormat:
	7457	"RTN","XUS KAAJ",32,0 )
	7458	; IEN of file 4^Sta tion Name^ Station Nu mber^defau lt? (1 or 0)
	7459	"RTN","XUS KAAJ",33,0 )
	7460	;
	7461	"RTN","XUS KAAJ",34,0 )
	7462	N I,XUNC, XUNC1,XUKE RR,XUKRET, XUDIVS,XUK I,XULINE,X UPARENT,XU DIVLIN,XUK DEF
	7463	"RTN","XUS KAAJ",35,0 )
	7464	;
	7465	"RTN","XUS KAAJ",36,0 )
	7466	; initial ize return array
	7467	"RTN","XUS KAAJ",37,0 )
	7468	S RET(0)= DUZ
	7469	"RTN","XUS KAAJ",38,0 )
	7470	F I=1:1:1 3 S RET(I) =""
	7471	"RTN","XUS KAAJ",39,0 )
	7472	;
	7473	"RTN","XUS KAAJ",40,0 )
	7474	; get ptr to Name C omponents file
	7475	"RTN","XUS KAAJ",41,0 )
	7476	D GETS^DI Q(200,DUZ_ ",","10.1" ,"I","XUNC ","XUKERR" )
	7477	"RTN","XUS KAAJ",42,0 )
	7478	I '$D(XUK ERR) D
	7479	"RTN","XUS KAAJ",43,0 )
	7480	.S XUNC=X UNC(200,DU Z_",",10.1 ,"I")
	7481	"RTN","XUS KAAJ",44,0 )
	7482	.; get na me compone nts
	7483	"RTN","XUS KAAJ",45,0 )
	7484	.D GETS^D IQ(20,XUNC _",","1:6" ,"","XUNC1 ","XUKERR" )
	7485	"RTN","XUS KAAJ",46,0 )
	7486	.I '$D(XU KERR) D
	7487	"RTN","XUS KAAJ",47,0 )
	7488	..S RET(3 )=XUNC1(20 ,XUNC_",", 1) S:'$L(R ET(3)) RET (3)="^"
	7489	"RTN","XUS KAAJ",48,0 )
	7490	..S RET(4 )=XUNC1(20 ,XUNC_",", 2) S:'$L(R ET(4)) RET (4)="^"
	7491	"RTN","XUS KAAJ",49,0 )
	7492	..S RET(5 )=XUNC1(20 ,XUNC_",", 3) S:'$L(R ET(5)) RET (5)="^"
	7493	"RTN","XUS KAAJ",50,0 )
	7494	..S RET(6 )=XUNC1(20 ,XUNC_",", 4) S:'$L(R ET(6)) RET (6)="^"
	7495	"RTN","XUS KAAJ",51,0 )
	7496	..S RET(7 )=XUNC1(20 ,XUNC_",", 5) S:'$L(R ET(7)) RET (7)="^"
	7497	"RTN","XUS KAAJ",52,0 )
	7498	..S RET(8 )=XUNC1(20 ,XUNC_",", 6) S:'$L(R ET(8)) RET (8)="^"
	7499	"RTN","XUS KAAJ",53,0 )
	7500	;
	7501	"RTN","XUS KAAJ",54,0 )
	7502	; get .01 New Perso n name, Na me compone nts name, and login division i nfo
	7503	"RTN","XUS KAAJ",55,0 )
	7504	D USERINF O^XUSRB2(. XUKRET)
	7505	"RTN","XUS KAAJ",56,0 )
	7506	S RET(1)= XUKRET(1) S:'$L(RET( 1)) RET(1) ="^"
	7507	"RTN","XUS KAAJ",57,0 )
	7508	S RET(2)= XUKRET(2) S:'$L(RET( 2)) RET(2) ="^"
	7509	"RTN","XUS KAAJ",58,0 )
	7510	S RET(9)= $P(XUKRET( 3),U,3) S: '$L(RET(9) ) RET(9)=" 0"
	7511	"RTN","XUS KAAJ",59,0 )
	7512	;
	7513	"RTN","XUS KAAJ",60,0 )
	7514	; get par ent facili ty station #
	7515	"RTN","XUS KAAJ",61,0 )
	7516	S XUPAREN T=$$PRNT^X UAF4(RET(9 ))
	7517	"RTN","XUS KAAJ",62,0 )
	7518	S RET(10) =$S(($P(XU PARENT,U)< 1):XUPAREN T,1:$$STA^ XUAF4($P(X UPARENT,U) ))
	7519	"RTN","XUS KAAJ",63,0 )
	7520	S:'$L(RET (10)) RET( 10)="^"
	7521	"RTN","XUS KAAJ",64,0 )
	7522	;
	7523	"RTN","XUS KAAJ",65,0 )
	7524	; get the computer system sta tion#
	7525	"RTN","XUS KAAJ",66,0 )
	7526	S RET(11) =$$STA^XUA F4($$KSP^X UPARAM("IN ST"))
	7527	"RTN","XUS KAAJ",67,0 )
	7528	S:'$L(RET (11)) RET( 11)="0"
	7529	"RTN","XUS KAAJ",68,0 )
	7530	;
	7531	"RTN","XUS KAAJ",69,0 )
	7532	; make si gnon log e ntry, get IEN
	7533	"RTN","XUS KAAJ",70,0 )
	7534	S RET(12) =$$SIGNLOG ^XUSKAAJ(C LIENTIP,SE RVERNM)
	7535	"RTN","XUS KAAJ",71,0 )
	7536	;
	7537	"RTN","XUS KAAJ",72,0 )
	7538	; get per mitted div isions
	7539	"RTN","XUS KAAJ",73,0 )
	7540	S XUDIVLI N=13 ; ret urn array subscript counter fo r division start poi nt
	7541	"RTN","XUS KAAJ",74,0 )
	7542	D DIVGET^ XUSRB2(.XU DIVS,DUZ)
	7543	"RTN","XUS KAAJ",75,0 )
	7544	I '+XUDIV S(0) S RET (XUDIVLIN) =1,RET(XUD IVLIN+1)=X UKRET(3)_" ^1" ; only 1 divisio n, so use login divi sion.
	7545	"RTN","XUS KAAJ",76,0 )
	7546	I +XUDIVS (0) S RET( XUDIVLIN)= +XUDIVS(0) D
	7547	"RTN","XUS KAAJ",77,0 )
	7548	.S XUKDEF =$O(^VA(20 0,DUZ,2,"A X1",1,"")) ; default division if any. Sh ould only be 1.
	7549	"RTN","XUS KAAJ",78,0 )
	7550	.S XUKI=0 ,XULINE=XU DIVLIN F S XUKI=$O( XUDIVS(XUK I)) Q:XUKI ']"" D
	7551	"RTN","XUS KAAJ",79,0 )
	7552	..S XULIN E=XULINE+1 ,RET(XULIN E)=XUDIVS( XUKI)
	7553	"RTN","XUS KAAJ",80,0 )
	7554	..S $P(RE T(XULINE), U,4)=$S($P (XUDIVS(XU KI),U)=XUK DEF:1,1:0)
	7555	"RTN","XUS KAAJ",81,0 )
	7556	;
	7557	"RTN","XUS KAAJ",82,0 )
	7558	Q
	7559	"RTN","XUS KAAJ",83,0 )
	7560	;
	7561	"RTN","XUS KAAJ",84,0 )
	7562	SIGNOFF(RE T,DA) ; ki ll entry i n sign-on log. Calle d by XUS K AAJEE LOGO UT rpc.
	7563	"RTN","XUS KAAJ",85,0 )
	7564	D LOUT^XU SCLEAN(DA)
	7565	"RTN","XUS KAAJ",86,0 )
	7566	S RET=1 Q
	7567	"RTN","XUS KAAJ",87,0 )
	7568	;
	7569	"RTN","XUS KAAJ",88,0 )
	7570	SIGNLOG(CL IENTIP,SER VERNM) ; m ake a sign on log ent ry for KAA JEE user
	7571	"RTN","XUS KAAJ",89,0 )
	7572	; todo: e xpand size of server name fiel d?
	7573	"RTN","XUS KAAJ",90,0 )
	7574	N XP1,XPI P,XPCLNM,Y
	7575	"RTN","XUS KAAJ",91,0 )
	7576	S:$D(IO(" IP")) XPIP =IO("IP") S IO("IP") =CLIENTIP
	7577	"RTN","XUS KAAJ",92,0 )
	7578	S:$D(IO(" CLNM")) XP CLNM=IO("C LNM") S IO ("CLNM")=$ E(SERVERNM ,1,20)
	7579	"RTN","XUS KAAJ",93,0 )
	7580	;
	7581	"RTN","XUS KAAJ",94,0 )
	7582	D GETENV^ %ZOSV
	7583	"RTN","XUS KAAJ",95,0 )
	7584	S XP1=$$S LOG^XUS1($ P(Y,U,2),, ,$P(Y,U),$ P(Y,U,3)," KAAJEE","" )
	7585	"RTN","XUS KAAJ",96,0 )
	7586	;
	7587	"RTN","XUS KAAJ",97,0 )
	7588	S:$D(XPIP ) IO("IP") =XPIP
	7589	"RTN","XUS KAAJ",98,0 )
	7590	S:$D(XPCL NM) IO("CL NM")=XPCLN M
	7591	"RTN","XUS KAAJ",99,0 )
	7592	Q XP1
	7593	"RTN","XUS KAAJ",100, 0)
	7594	;
	7595	"RTN","XUS KAAJ1")
	7596	0^29^B2125 056^B16874 17
	7597	"RTN","XUS KAAJ1",1,0 )
	7598	XUSKAAJ1 ; ;12/15/15 08:54;10/ 19/2009
	7599	"RTN","XUS KAAJ1",2,0 )
	7600	;;8.0;KER NEL;504, 659;Jul 10, 1995;B uild 22
	7601	"RTN","XUS KAAJ1",3,0 )
	7602	;Per VA D irective 6 402, this routine sh ould not b e modified .
	7603	"RTN","XUS KAAJ1",4,0 )
	7604	;;
	7605	"RTN","XUS KAAJ1",5,0 )
	7606	QUIT
	7607	"RTN","XUS KAAJ1",6,0 )
	7608	;
	7609	"RTN","XUS KAAJ1",7,0 )
	7610	; ------- ---------- ---------- ---------- ---------- ---------- ---------- -----
	7611	"RTN","XUS KAAJ1",8,0 )
	7612	; SSO/U C KAAJEE R PCs
	7613	"RTN","XUS KAAJ1",9,0 )
	7614	; ------- ---------- ---------- ---------- ---------- ---------- ---------- -----
	7615	"RTN","XUS KAAJ1",10, 0)
	7616	;
	7617	"RTN","XUS KAAJ1",11, 0)
	7618	CCOWIP(RET ,CLIENTIP) ;rpc. CCO W Auto Sig non Handle for middl e tiered a pplication servers
	7619	"RTN","XUS KAAJ1",12, 0)
	7620	N XUIOIP, XULOOPIP
	7621	"RTN","XUS KAAJ1",13, 0)
	7622	S XUIOIP= $G(IO("IP" )) ; save original
	7623	"RTN","XUS KAAJ1",14, 0)
	7624	; get act ual ip add ress inste ad of loca lhost addr ess if pos sible
	7625	"RTN","XUS KAAJ1",15, 0)
	7626	;S IO("IP ")=$S($G(C LIENTIP)=" 127.0.0.1" :XUIOIP,$G (CLIENTIP) ="":XUIOIP ,1:$G(CLIE NTIP))
	7627	"RTN","XUS KAAJ1",16, 0)
	7628	S XULOOPI P=$$CONVER T^XLFIPV(" 127.0.0.1" ) ;p659
	7629	"RTN","XUS KAAJ1",17, 0)
	7630	S IO("IP" )=$S($G(CL IENTIP)=XU LOOPIP:XUI OIP,$G(CLI ENTIP)="": XUIOIP,1:$ G(CLIENTIP )) ;p659
	7631	"RTN","XUS KAAJ1",18, 0)
	7632	D CCOW^XU SRB4(.RET)
	7633	"RTN","XUS KAAJ1",19, 0)
	7634	S IO("IP" )=XUIOIP ; revert to original
	7635	"RTN","XUS KAAJ1",20, 0)
	7636	Q
	7637	"RTN","XUS KAAJ1",21, 0)
	7638	;
	7639	"RTN","XUS KAAJ1",22, 0)
	7640	USERINFO(R ET,CLIENTI P,SERVERNM ,CCOWTOK) ; rpc, cal led by XUS KAAJEE GE T USER INF O VIA PROX Y
	7641	"RTN","XUS KAAJ1",23, 0)
	7642	;
	7643	"RTN","XUS KAAJ1",24, 0)
	7644	N %,DUZ,X UF,XULOOPI P
	7645	"RTN","XUS KAAJ1",25, 0)
	7646	S XUF=$G( XUF,0)
	7647	"RTN","XUS KAAJ1",26, 0)
	7648	S %=$G(IO ("IP")) ; save origi nal
	7649	"RTN","XUS KAAJ1",27, 0)
	7650	; get act ual ip add ress inste ad of loca lhost addr ess if pos sible
	7651	"RTN","XUS KAAJ1",28, 0)
	7652	;S IO("IP ")=$S($G(C LIENTIP)=" 127.0.0.1" :%,$G(CLIE NTIP)="":% ,1:$G(CLIE NTIP))
	7653	"RTN","XUS KAAJ1",29, 0)
	7654	S XULOOPI P=$$CONVER T^XLFIPV(" 127.0.0.1" ) ;p659
	7655	"RTN","XUS KAAJ1",30, 0)
	7656	S IO("IP" )=$S($G(CL IENTIP)=XU LOOPIP:%,$ G(CLIENTIP )="":%,1:$ G(CLIENTIP )) ;p659
	7657	"RTN","XUS KAAJ1",31, 0)
	7658	S DUZ=$$C HECKAV^XUS ($$DECRYP^ XUSRB1(CCO WTOK))
	7659	"RTN","XUS KAAJ1",32, 0)
	7660	S IO("IP" )=% ; reve rt to orig inal
	7661	"RTN","XUS KAAJ1",33, 0)
	7662	D USERINF O^XUSKAAJ( .RET,CLIEN TIP,SERVER NM)
	7663	"RTN","XUS KAAJ1",34, 0)
	7664	Q
	7665	"RTN","XUS KAAJ1",35, 0)
	7666	;
	7667	"RTN","XUS RB")
	7668	0^8^B35393 386^B33401 626
	7669	"RTN","XUS RB",1,0)
	7670	XUSRB ;ISC SF/RWF - R equest Bro ker ;12/01 /15 07:54
	7671	"RTN","XUS RB",2,0)
	7672	;;8.0;KER NEL;11,1 6,28,32,59 ,70,82,109 ,115,165,1 50,180,213 ,234,238,2 65,337,395 ,404,437,5 23,659;J ul 10, 199 5;Build 22
	7673	"RTN","XUS RB",3,0)
	7674	;Per VA D irective 6 402, this routine sh ould not b e modified .
	7675	"RTN","XUS RB",4,0)
	7676	Q ;No en try from t op
	7677	"RTN","XUS RB",5,0)
	7678	;
	7679	"RTN","XUS RB",6,0)
	7680	;RPC BROK ER calls, First para meter is a lways call -by-refere nce
	7681	"RTN","XUS RB",7,0)
	7682	VALIDAV(RE T,AVCODE) ;RPC. XUS CVC - IA # 6296
	7683	"RTN","XUS RB",8,0)
	7684	;Check a users acce ss
	7685	"RTN","XUS RB",9,0)
	7686	;Return R (0)=DUZ, R (1)=(0=OK, 1,2...=Ca n't sign-o n for some reason)
	7687	"RTN","XUS RB",10,0)
	7688	; R(2)=ve rify needs changing, R(3)=Mess age, R(4)= 0, R(5)=ms g cnt, R(5 +n)
	7689	"RTN","XUS RB",11,0)
	7690	; R(R(5)+ 6)=# div u ser must s elect from , R(R(5)+6 +n)=div
	7691	"RTN","XUS RB",12,0)
	7692	;
	7693	"RTN","XUS RB",13,0)
	7694	N X,XUSER ,XUNOW,XUD EV,XUM,XUM SG,%1,VCCH K DUZ
	7695	"RTN","XUS RB",14,0)
	7696	S U="^",R ET(0)=0,RE T(5)=0,XUF =$G(XUF,0) ,XUM=0,XUM SG=0,XUDEV =0
	7697	"RTN","XUS RB",15,0)
	7698	S DUZ=0,D UZ(0)="",V CCH=0 D NO W
	7699	"RTN","XUS RB",16,0)
	7700	S XOPT=$$ STATE^XWBS EC("XUS XO PT")
	7701	"RTN","XUS RB",17,0)
	7702	S XUMSG=$ $INHIBIT() I XUMSG S XUM=1 G V AX ;Logon inhibited
	7703	"RTN","XUS RB",18,0)
	7704	;3 Strike s
	7705	"RTN","XUS RB",19,0)
	7706	I $$LKCHE CK^XUSTZIP ($G(IO("IP "))) S XUM SG=7 G VAX ;IP locke d
	7707	"RTN","XUS RB",20,0)
	7708	;Check ty pe of sign -on code
	7709	"RTN","XUS RB",21,0)
	7710	I $L(AVCO DE) D
	7711	"RTN","XUS RB",22,0)
	7712	. I $E(AV CODE,1,2)= "~1" S DUZ =$$CHKASH^ XUSRB4(AVC ODE),DUZ(" AUTHENTICA TION")="AS HTOKEN" Q
	7713	"RTN","XUS RB",23,0)
	7714	. I $E(AV CODE,1,2)= "~2" S DUZ =$$CHKCCOW ^XUSRB4(AV CODE),DUZ( "AUTHENTIC ATION")="C COWTOKEN" Q
	7715	"RTN","XUS RB",24,0)
	7716	. S DUZ=$ $CHECKAV^X US($$DECRY P^XUSRB1(A VCODE)),DU Z("AUTHENT ICATION")= "AVCODES"
	7717	"RTN","XUS RB",25,0)
	7718	. Q
	7719	"RTN","XUS RB",26,0)
	7720	I DUZ'>0, $$FAIL^XUS 3 D G VAX
	7721	"RTN","XUS RB",27,0)
	7722	. S XUM=1 ,XUMSG=7,X =$$RA^XUST Z H 5 ;3 S trikes
	7723	"RTN","XUS RB",28,0)
	7724	S XUMSG=$ $UVALID^XU S() G:XUMS G VAX ;Che ck User
	7725	"RTN","XUS RB",29,0)
	7726	S VCCH=$$ VCVALID() ;Check VC
	7727	"RTN","XUS RB",30,0)
	7728	I $G(DUZ( "LOA"))="" S DUZ("LO A")=2
	7729	"RTN","XUS RB",31,0)
	7730	I DUZ>0 S XUMSG=$$P OST(1)
	7731	"RTN","XUS RB",32,0)
	7732	I XUMSG>0 S DUZ=0,V CCH=0 ;If can't sign -on, don't tell need to change VC
	7733	"RTN","XUS RB",33,0)
	7734	I 'XUMSG, VCCH S XUM SG=12 D SE T^XWBSEC(" XUS DUZ",D UZ) ;Need to change VC
	7735	"RTN","XUS RB",34,0)
	7736	VAX S:XUMS G>0 DUZ=0 ;Can't sig n-on, Clea r DUZ.
	7737	"RTN","XUS RB",35,0)
	7738	I DUZ>0 D
	7739	"RTN","XUS RB",36,0)
	7740	. S DUZ(" LOA")=2
	7741	"RTN","XUS RB",37,0)
	7742	. D POST2
	7743	"RTN","XUS RB",38,0)
	7744	S RET(0)= DUZ,RET(1) =XUM,RET(2 )=VCCH,RET (3)=$S(XUM SG:$$TXT^X US3(XUMSG) ,1:""),RET (4)=0
	7745	"RTN","XUS RB",39,0)
	7746	K DUZ("CC OW")
	7747	"RTN","XUS RB",40,0)
	7748	Q
	7749	"RTN","XUS RB",41,0)
	7750	;
	7751	"RTN","XUS RB",42,0)
	7752	NOW S U="^ ",XUNOW=$$ NOW^XLFDT( ),DT=$P(XU NOW,".")
	7753	"RTN","XUS RB",43,0)
	7754	Q
	7755	"RTN","XUS RB",44,0)
	7756	;
	7757	"RTN","XUS RB",45,0)
	7758	INTRO(RET) ;Return I NTRO TEXT.
	7759	"RTN","XUS RB",46,0)
	7760	D INTRO^X US1A("RET" )
	7761	"RTN","XUS RB",47,0)
	7762	Q
	7763	"RTN","XUS RB",48,0)
	7764	;
	7765	"RTN","XUS RB",49,0)
	7766	VCVALID() ;Return 1 if the Ver ify code n eeds chang ing.
	7767	"RTN","XUS RB",50,0)
	7768	Q:'$G(DUZ ) 1
	7769	"RTN","XUS RB",51,0)
	7770	Q:$P($G(^ VA(200,DUZ ,.1)),U,2) ="" 1 ;VC is empty
	7771	"RTN","XUS RB",52,0)
	7772	Q:$P(^VA( 200,DUZ,0) ,U,8)=1 0 ;VC never expires
	7773	"RTN","XUS RB",53,0)
	7774	N XUSER D USER^XUS( DUZ)
	7775	"RTN","XUS RB",54,0)
	7776	Q $$VCHG^ XUS1
	7777	"RTN","XUS RB",55,0)
	7778	;
	7779	"RTN","XUS RB",56,0)
	7780	CVC(RET,XU 1) ;change VC, Retur n 0 = succ ess
	7781	"RTN","XUS RB",57,0)
	7782	N XU2,XU3 ,XU4 S DUZ =$G(DUZ),R ET(0)=99,X U4=$$STATE ^XWBSEC("X US DUZ") S :(DUZ=0)&( XU4>0) DUZ =XU4 Q:DUZ '>0
	7783	"RTN","XUS RB",58,0)
	7784	S U="^",X U2=$P(XU1, U,2),XU3=$ P(XU1,U,3) ,XU1=$P(XU 1,U)
	7785	"RTN","XUS RB",59,0)
	7786	S XU1=$$D ECRYP^XUSR B1(XU1),XU 2=$$DECRYP ^XUSRB1(XU 2),XU3=$$D ECRYP^XUSR B1(XU3)
	7787	"RTN","XUS RB",60,0)
	7788	S XU3=$$B RCVC^XUS2( XU1,XU2),R ET(0)=+XU3 ,RET(1)=$P (XU3,U,2,9 )
	7789	"RTN","XUS RB",61,0)
	7790	I XU3>0 S DUZ=0 ;Cl ean-up if not change d.
	7791	"RTN","XUS RB",62,0)
	7792	I 'XU3,XU 4 D KILL^X WBSEC("XUS DUZ"),POS T2
	7793	"RTN","XUS RB",63,0)
	7794	Q
	7795	"RTN","XUS RB",64,0)
	7796	;
	7797	"RTN","XUS RB",65,0)
	7798	SHOWPOST() ;EF. Chec k if shoul d send the POST SIGN -ON msg.
	7799	"RTN","XUS RB",66,0)
	7800	Q +$P($G( ^XTV(8989. 3,1,"XWB") ),"^",2)
	7801	"RTN","XUS RB",67,0)
	7802	;
	7803	"RTN","XUS RB",68,0)
	7804	POST(CVC) ;Finish se tup partit ion, I CVC don't log yet
	7805	"RTN","XUS RB",69,0)
	7806	N X,XUM,X UDIV S:$D( IO)[0 IO=$ I S IO(0)= IO
	7807	"RTN","XUS RB",70,0)
	7808	K ^UTILIT Y($J),^TMP ($J)
	7809	"RTN","XUS RB",71,0)
	7810	I '$D(XUS ER(0)),DUZ D USER^XU S(DUZ)
	7811	"RTN","XUS RB",72,0)
	7812	S XUM=$$U SER^XUS1A Q:XUM>0 XU M ;User ca n't sign o n for some reason.
	7813	"RTN","XUS RB",73,0)
	7814	S RET(5)= 0 ;The nex t line sen ds the pos t sign-on msg
	7815	"RTN","XUS RB",74,0)
	7816	F %=1:1 Q :'$D(XUTEX T(%)) S R ET(5+%)=$E (XUTEXT(%) ,2,256),RE T(5)=%
	7817	"RTN","XUS RB",75,0)
	7818	I '$$SHOW POST S RET (5)=0 ;Thi s line sto ps the sen ding/displ ay of the msg.
	7819	"RTN","XUS RB",76,0)
	7820	D:'$G(CVC ) POST2
	7821	"RTN","XUS RB",77,0)
	7822	Q 0
	7823	"RTN","XUS RB",78,0)
	7824	;
	7825	"RTN","XUS RB",79,0)
	7826	POST2 ;Fin ish User S etup for s ilent log- on
	7827	"RTN","XUS RB",80,0)
	7828	D:'$D(XUN OW) NOW
	7829	"RTN","XUS RB",81,0)
	7830	D DUZ^XUS 1A,SAVE^XU S1,LOG^XUS 1,ABT^XQ12
	7831	"RTN","XUS RB",82,0)
	7832	D KILL^XW BSEC("XUS XOPT"),CLR FAC^XUS3($ G(IO("IP") )) ;p265
	7833	"RTN","XUS RB",83,0)
	7834	D SETTIME ^XWBTCPM() ;Set norm al Broker time-out
	7835	"RTN","XUS RB",84,0)
	7836	S DTIME=$ $DTIME^XUP (DUZ) ;See DTIME set for user
	7837	"RTN","XUS RB",85,0)
	7838	K:$G(XWBV ER)<1.106 XQY,XQY0 ; Delete the sign-on c ontext.
	7839	"RTN","XUS RB",86,0)
	7840	K XUTEXT, XOPT,XUEON ,XUEOFF,XU TT,XUDEV,X USER
	7841	"RTN","XUS RB",87,0)
	7842	Q
	7843	"RTN","XUS RB",88,0)
	7844	;
	7845	"RTN","XUS RB",89,0)
	7846	INHIBIT() ;Is Logon to this sy stem Inhib ited?
	7847	"RTN","XUS RB",90,0)
	7848	I $$INHIB 1() Q 1
	7849	"RTN","XUS RB",91,0)
	7850	I $$INHIB 2() Q 2
	7851	"RTN","XUS RB",92,0)
	7852	Q 0
	7853	"RTN","XUS RB",93,0)
	7854	;
	7855	"RTN","XUS RB",94,0)
	7856	INHIB1() ; The LOGON check
	7857	"RTN","XUS RB",95,0)
	7858	I $G(^%ZI S(14.5,"LO GON",XQVOL )) Q 1
	7859	"RTN","XUS RB",96,0)
	7860	Q 0
	7861	"RTN","XUS RB",97,0)
	7862	;
	7863	"RTN","XUS RB",98,0)
	7864	INHIB2() ; The Max Us er Check
	7865	"RTN","XUS RB",99,0)
	7866	I $D(^%ZO SF("ACTJ") ) X ^("ACT J") I $P(X UVOL,U,3), ($P(XUVOL, U,3)'>Y) Q 2
	7867	"RTN","XUS RB",100,0)
	7868	Q 0
	7869	"RTN","XUS RB",101,0)
	7870	;
	7871	"RTN","XUS RB",102,0)
	7872	LOGOUT ;Fi nish logou t of user.
	7873	"RTN","XUS RB",103,0)
	7874	N XU1
	7875	"RTN","XUS RB",104,0)
	7876	D CLEARAL L^XWBDRPC( .XU1)
	7877	"RTN","XUS RB",105,0)
	7878	;Remove C COW sign-o n data
	7879	"RTN","XUS RB",106,0)
	7880	S HDL=$G( ^XUTL("XQ" ,$J,"HDL") ) I $L(HDL ) D
	7881	"RTN","XUS RB",107,0)
	7882	. K ^XTMP (HDL,"JOB" ,$J)
	7883	"RTN","XUS RB",108,0)
	7884	. I $O(^X TMP(HDL,"J OB",0))="" K ^XTMP(H DL)
	7885	"RTN","XUS RB",109,0)
	7886	;
	7887	"RTN","XUS RB",110,0)
	7888	D BYE^XUS CLEAN,XUTL ^XUSCLEAN ;Mark the sign-on lo g, File cl eanup.
	7889	"RTN","XUS RB",111,0)
	7890	Q
	7891	"RTN","XUS RB",112,0)
	7892	;D1,D2 ar e place ho lders for now
	7893	"RTN","XUS RB",113,0)
	7894	SETUP(RET, XWBUSRNM,A SOSKIP,D2) ;RPC. XUS SIGNON SE TUP - IA # 1632 (API IA #4054)
	7895	"RTN","XUS RB",114,0)
	7896	;sets up environmen t for GUI signon
	7897	"RTN","XUS RB",115,0)
	7898	N X1 K DU Z
	7899	"RTN","XUS RB",116,0)
	7900	S XWBUSRN M=$G(XWBUS RNM),ASOSK IP=$G(ASOS KIP)
	7901	"RTN","XUS RB",117,0)
	7902	I $L($G(X WBTIP)) S IO("IP")=X WBTIP
	7903	"RTN","XUS RB",118,0)
	7904	S IO("CLN M")=$$LOW^ XLFSTR($G( XWBCLMAN)) D ZIO^%ZI S4
	7905	"RTN","XUS RB",119,0)
	7906	;Setup ne eded varia bles
	7907	"RTN","XUS RB",120,0)
	7908	D SET1^XU S(0),SET^X WBSEC("XUS XOPT",XOP T) ;p265
	7909	"RTN","XUS RB",121,0)
	7910	;I '$D(IO ("HOME")) S %ZIS="0H ",IOP="NUL L" D ^%ZIS ;Setup NU LL as the home devic e
	7911	"RTN","XUS RB",122,0)
	7912	D SAVE^XU S1 ;save t he home de vice
	7913	"RTN","XUS RB",123,0)
	7914	;0=server name, 1=v olume, 2=u ci, 3=devi ce, 4=# at tempts, 5= skip signo n-screen,6 =Domain Na me, 7=Prod uction (0= no, 1=Yes)
	7915	"RTN","XUS RB",124,0)
	7916	S RET(0)= $P(XUENV,U ,3),RET(1) =$P(XUVOL, U),RET(2)= XUCI
	7917	"RTN","XUS RB",125,0)
	7918	S RET(3)= $I,RET(4)= $P(XOPT,U, 2),RET(5)= 0
	7919	"RTN","XUS RB",126,0)
	7920	S RET(6)= $G(^XMB("N ETNAME")) ;DBIA #113 1
	7921	"RTN","XUS RB",127,0)
	7922	S RET(7)= $$PROD^XUP ROD ;Tell if product ion.
	7923	"RTN","XUS RB",128,0)
	7924	S X1=$$IN HIBIT() I X1 S XWBER R=$S(X1=1: "Logons In hibited",1 :"Max User s") Q ;p5 23
	7925	"RTN","XUS RB",129,0)
	7926	; Check f or Broker Security E nhancement (BSE) tok en
	7927	"RTN","XUS RB",130,0)
	7928	I (+XWBUS RNM<-30),$ $CHKUSER^X USBSE1(XWB USRNM) S R ET(5)=1 D POST2 Q ; p523 BSE C HANGE
	7929	"RTN","XUS RB",131,0)
	7930	; End of Check for BSE token
	7931	"RTN","XUS RB",132,0)
	7932	;Auto sig n-on check only for Broker v1. 1
	7933	"RTN","XUS RB",133,0)
	7934	I $G(ASOS KIP) S XQX FLG("ASO") =1 ;Skip t he ASO che ck, Not fo r VISITORS p523
	7935	"RTN","XUS RB",134,0)
	7936	I $G(XWBV ER)<1.1 S XQXFLG("ZE BRA")=-1 ; Disable fo r v1.0
	7937	"RTN","XUS RB",135,0)
	7938	I $L(IO(" CLNM")),'$ G(DUZ) S D UZ=$$AUTOX WB^XUS1B() ;Only che ck when 1. 1 CL.
	7939	"RTN","XUS RB",136,0)
	7940	I $G(DUZ) >0 D ;p52 3
	7941	"RTN","XUS RB",137,0)
	7942	. I '$D(X USER(0)),D UZ D USER^ XUS(DUZ)
	7943	"RTN","XUS RB",138,0)
	7944	. N %T S %T=$$USER^ XUS1A I %T S DUZ=0 Q
	7945	"RTN","XUS RB",139,0)
	7946	. D NOW,P OST2 S RET (5)=1
	7947	"RTN","XUS RB",140,0)
	7948	Q
	7949	"RTN","XUS RB",141,0)
	7950	;
	7951	"RTN","XUS RB",142,0)
	7952	OWNSKEY(RE T,LIST,IEN ) ;RPC. XU S KEY CHEC K - IA #62 86 (API IA #3277)
	7953	"RTN","XUS RB",143,0)
	7954	;Does use r have Sec urity Key?
	7955	"RTN","XUS RB",144,0)
	7956	N I,K S I =""
	7957	"RTN","XUS RB",145,0)
	7958	I $G(IEN) '>0 S IEN= $G(DUZ)
	7959	"RTN","XUS RB",146,0)
	7960	I $G(IEN) '>0 S RET( 0)=0 Q
	7961	"RTN","XUS RB",147,0)
	7962	I $O(LIST (""))="" S RET(0)=$$ KCHK(LIST, IEN) Q
	7963	"RTN","XUS RB",148,0)
	7964	F S I=$O (LIST(I)) Q:I="" S RET(I)=$$K CHK(LIST(I ),IEN)
	7965	"RTN","XUS RB",149,0)
	7966	Q
	7967	"RTN","XUS RB",150,0)
	7968	;
	7969	"RTN","XUS RB",151,0)
	7970	KCHK(%,IEN ) ;Key Che ck
	7971	"RTN","XUS RB",152,0)
	7972	S:$G(IEN) '>0 IEN=$G (DUZ) Q $S ($G(IEN)>0 :$D(^XUSEC (%,IEN)),1 :0)
	7973	"RTN","XUS RB",153,0)
	7974	;
	7975	"RTN","XUS RB",154,0)
	7976	ALLKEYS(RE T,IEN,FLG) ;RPC. XUS ALLKEYS - IA #6287 (API IA #3 277)
	7977	"RTN","XUS RB",155,0)
	7978	;Return A LL or most KEYS that a user ha s.
	7979	"RTN","XUS RB",156,0)
	7980	N I,J,K,L K ^TMP("X U",$J)
	7981	"RTN","XUS RB",157,0)
	7982	S RET=$NA (^TMP("XU" ,$J))
	7983	"RTN","XUS RB",158,0)
	7984	S:'$D(IEN ) IEN=DUZ I IEN'>0 S @RET@(0)= -1 Q
	7985	"RTN","XUS RB",159,0)
	7986	S I=0,L=0
	7987	"RTN","XUS RB",160,0)
	7988	F S I=$O (^VA(200,I EN,51,I)) Q:I'>0 S K=$G(^DIC( 19.1,I,0)) D
	7989	"RTN","XUS RB",161,0)
	7990	. Q:'$P(K ,U,5) ;Ch eck 'Send to J2EE' f ield.
	7991	"RTN","XUS RB",162,0)
	7992	. S L=L+1 ,@RET@(L,0 )=$P(K,U,1 )
	7993	"RTN","XUS RB",163,0)
	7994	. Q
	7995	"RTN","XUS RB",164,0)
	7996	Q
	7997	"RTN","XUS RB",165,0)
	7998	;
	7999	"RTN","XUS RB",166,0)
	8000	AVHELP(RET ) ; send a ccess/veri fy code in structions .
	8001	"RTN","XUS RB",167,0)
	8002	S RET(0)= $$AVHLPTXT ^XUS2()
	8003	"RTN","XUS RB",168,0)
	8004	Q
	8005	"RTN","XUS RB",169,0)
	8006	;
	8007	"RTN","XUS RB",170,0)
	8008	OPTACCES(R ET,USER,OP TIONS,MODE ) ;Checks or sets us er's acces s for pass ed in opti ons
	8009	"RTN","XUS RB",171,0)
	8010	S MODE="C HECK" ;onl y CHECK mo de support ed for now
	8011	"RTN","XUS RB",172,0)
	8012	N I S I=" "
	8013	"RTN","XUS RB",173,0)
	8014	I $G(USER )'>0 S RET (0)=0 Q
	8015	"RTN","XUS RB",174,0)
	8016	F S I=$O (OPTIONS(I )) Q:I="" S RET(I)= $$CHK^XQCS (USER,OPTI ONS(I))=1
	8017	"RTN","XUS RB",175,0)
	8018	Q
	8019	"RTN","XUS RB",176,0)
	8020	;
	8021	"RTN","XUS RB",177,0)
	8022	CHECKAV(AV C) ;SR. EF . to check an A/V co de, Separa te w/ ";", return IE N or 0
	8023	"RTN","XUS RB",178,0)
	8024	N XUF,XUS ER S XUF=0 ,U="^"
	8025	"RTN","XUS RB",179,0)
	8026	Q $$CHECK AV^XUS(AVC )
	8027	"RTN","XUS RB4")
	8028	0^21^B2080 5610^B1843 5992
	8029	"RTN","XUS RB4",1,0)
	8030	XUSRB4 ;IS F/RWF - Bu ild a temp orary sign -on token ;01/29/14 14:56
	8031	"RTN","XUS RB4",2,0)
	8032	;;8.0;KER NEL;*150, 337,395,41 9,437,499, 523,573,59 6,638,659 *;Jul 10, 1995;Build 22
	8033	"RTN","XUS RB4",3,0)
	8034	;Per VA D irective 6 402, this routine sh ould not b e modified .
	8035	"RTN","XUS RB4",4,0)
	8036	Q
	8037	"RTN","XUS RB4",5,0)
	8038	;
	8039	"RTN","XUS RB4",6,0)
	8040	ASH(RET) ; rpc. Auto Signon Han dle
	8041	"RTN","XUS RB4",7,0)
	8042	N HDL
	8043	"RTN","XUS RB4",8,0)
	8044	;Do not g ive token to user wi th authent ication Le vel Of Ass urance = 1 , as they then would
	8045	"RTN","XUS RB4",9,0)
	8046	;have the ability t o re-authe nticate at a higher Level Of A ssurance ( spoofing).
	8047	"RTN","XUS RB4",10,0)
	8048	S RET="NO T AUTHENTI CATED"
	8049	"RTN","XUS RB4",11,0)
	8050	I $G(DUZ) <1 Q ;Not an authen ticated us er
	8051	"RTN","XUS RB4",12,0)
	8052	I $G(DUZ( "LOA"))=1 Q ;Not an authentic ated user
	8053	"RTN","XUS RB4",13,0)
	8054	S HDL=$$H ANDLE("XWB AS",1),RET ="~1"_HDL
	8055	"RTN","XUS RB4",14,0)
	8056	;Now plac e user inf o in it.
	8057	"RTN","XUS RB4",15,0)
	8058	D TOK(HDL )
	8059	"RTN","XUS RB4",16,0)
	8060	Q
	8061	"RTN","XUS RB4",17,0)
	8062	;
	8063	"RTN","XUS RB4",18,0)
	8064	CCOW(RET) ;rpc. CCOW Auto Sign on Handle
	8065	"RTN","XUS RB4",19,0)
	8066	N HDL,HDL 2,X
	8067	"RTN","XUS RB4",20,0)
	8068	S RET(0)= "NO PROXY USER",RET( 1)="ERROR"
	8069	"RTN","XUS RB4",21,0)
	8070	I $$USERT YPE^XUSAP( DUZ,"APPLI CATION PRO XY") Q ;N o Proxy
	8071	"RTN","XUS RB4",22,0)
	8072	I $$USERT YPE^XUSAP( DUZ,"CONNE CTOR PROXY ") Q ;No Proxy
	8073	"RTN","XUS RB4",23,0)
	8074	;Do not g ive token to user wi th authent ication Le vel Of Ass urance = 1 , as they then would
	8075	"RTN","XUS RB4",24,0)
	8076	;have the ability t o re-authe nticate at a higher Level Of A ssurance ( spoofing).
	8077	"RTN","XUS RB4",25,0)
	8078	S RET(0)= "NOT AUTHE NTICATED", RET(1)="ER ROR"
	8079	"RTN","XUS RB4",26,0)
	8080	I $G(DUZ( "LOA"))=1 Q ;Not an authentic ated user
	8081	"RTN","XUS RB4",27,0)
	8082	S X=$$ACT IVE^XUSER( DUZ) I 'X S RET(0)=X Q ;User must be ac tive
	8083	"RTN","XUS RB4",28,0)
	8084	S HDL=$$H ANDLE("XWB CCW",1)
	8085	"RTN","XUS RB4",29,0)
	8086	;Return R ET(0) the CCOW token , RET(1) t he domain name and t he Station #
	8087	"RTN","XUS RB4",30,0)
	8088	S RET(0)= "~2"_$$LOW ^XLFSTR(HD L),RET(1)= $G(^XMB("N ETNAME"))_ "^"_$$STA^ XUAF4(DUZ( 2))
	8089	"RTN","XUS RB4",31,0)
	8090	;Now plac e user inf o in it.
	8091	"RTN","XUS RB4",32,0)
	8092	D TOK(HDL )
	8093	"RTN","XUS RB4",33,0)
	8094	S ^XUTL(" XQ",$J,"HD L")=HDL ;S ave handle with job
	8095	"RTN","XUS RB4",34,0)
	8096	Q
	8097	"RTN","XUS RB4",35,0)
	8098	;
	8099	"RTN","XUS RB4",36,0)
	8100	HANDLE(NS, LT) ;Retur n a unique handle in to ^XTMP ( ef. sup)
	8101	"RTN","XUS RB4",37,0)
	8102	;NS is th e namespac e, LT is t he Handle Lifetime i n days
	8103	"RTN","XUS RB4",38,0)
	8104	N %H,A,J, HL
	8105	"RTN","XUS RB4",39,0)
	8106	I $G(NS)= "" Q "" ;R eturn null if no nam espace
	8107	"RTN","XUS RB4",40,0)
	8108	S LT=$G(L T,1) S:LT> 7 LT=7 ;De fault to 1
	8109	"RTN","XUS RB4",41,0)
	8110	S %H=$H,J =NS_($J#20 48)_"-"_(% H#7*86400+ $P(%H,",", 2))_"_",A= $R(10)
	8111	"RTN","XUS RB4",42,0)
	8112	F S HL=J _A,A=A+1 L +^XTMP(HL ):1 I $T Q :'$D(^XTMP (HL)) L - ^XTMP(HL)
	8113	"RTN","XUS RB4",43,0)
	8114	S ^XTMP(H L,0)=$$HTF M^XLFDT(%H +LT)_"^"_$ $DT^XLFDT( )
	8115	"RTN","XUS RB4",44,0)
	8116	;L -^XTMP (HL) Leave the Unloc k to the c aller
	8117	"RTN","XUS RB4",45,0)
	8118	Q HL
	8119	"RTN","XUS RB4",46,0)
	8120	;
	8121	"RTN","XUS RB4",47,0)
	8122	TOK(H) ;St ore a Toke n
	8123	"RTN","XUS RB4",48,0)
	8124	;H is han dle into X TMP
	8125	"RTN","XUS RB4",49,0)
	8126	N J,T,R,%
	8127	"RTN","XUS RB4",50,0)
	8128	S T=$$H3^ %ZTM($H)
	8129	"RTN","XUS RB4",51,0)
	8130	S R=$J_"\| "_T_"\|"_$G (DUZ)_"\|"_ H
	8131	"RTN","XUS RB4",52,0)
	8132	S ^XTMP(H ,"D",0)="\| "_$$ENCRYP ^XUSRB1(R) _"\|"
	8133	"RTN","XUS RB4",53,0)
	8134	S ^XTMP(H ,"D2")=$G( DUZ(2))
	8135	"RTN","XUS RB4",54,0)
	8136	S %=$G(IO ("IP")) I $L(%),'$$V ALIDATE^XL FIPV(%) S %=$P($$ADD RESS^XLFNS LK(%),",") ;p638
	8137	"RTN","XUS RB4",55,0)
	8138	S ^XTMP(H ,"D3")=%
	8139	"RTN","XUS RB4",56,0)
	8140	S ^XTMP(H ,"CLNM")=$ G(IO("CLNM "))
	8141	"RTN","XUS RB4",57,0)
	8142	S ^XTMP(H ,"JOB",$J) =$G(IO("IP "))
	8143	"RTN","XUS RB4",58,0)
	8144	S ^XTMP(H ,"STATUS") ="0^New",^ ("CNT")=0
	8145	"RTN","XUS RB4",59,0)
	8146	L -^XTMP( H) ;Clear Lock
	8147	"RTN","XUS RB4",60,0)
	8148	Q
	8149	"RTN","XUS RB4",61,0)
	8150	;
	8151	"RTN","XUS RB4",62,0)
	8152	REMOVE(HL) ;Remove ( kill) a Ha ndle. p523
	8153	"RTN","XUS RB4",63,0)
	8154	I $L($G(H L)) K ^XTM P(HL)
	8155	"RTN","XUS RB4",64,0)
	8156	Q
	8157	"RTN","XUS RB4",65,0)
	8158	;
	8159	"RTN","XUS RB4",66,0)
	8160	CHKASH(HL) ;rpc. Che ck a Auto Signon Han dle
	8161	"RTN","XUS RB4",67,0)
	8162	N HDL,RET ,FDA,IEN S HDL=$E(HL ,3,999)
	8163	"RTN","XUS RB4",68,0)
	8164	S RET=$$C HECK(HDL)
	8165	"RTN","XUS RB4",69,0)
	8166	I RET>0 D
	8167	"RTN","XUS RB4",70,0)
	8168	. S DUZ(" ASH")=1,IE N=DUZ_","
	8169	"RTN","XUS RB4",71,0)
	8170	. I $$GET 1^DIQ(200, IEN,7,"I") S FDA(200 ,DUZ_",",7 )=0 D FILE ^DIE("K"," FDA") ;p40 3
	8171	"RTN","XUS RB4",72,0)
	8172	D REMOVE( HDL) ;Toke n only goo d for one try.
	8173	"RTN","XUS RB4",73,0)
	8174	Q RET
	8175	"RTN","XUS RB4",74,0)
	8176	;
	8177	"RTN","XUS RB4",75,0)
	8178	CHKCCOW(HL ) ;rpc. Ch eck a CCOW Auto Sign on Handle
	8179	"RTN","XUS RB4",76,0)
	8180	N HDL,RET ,T
	8181	"RTN","XUS RB4",77,0)
	8182	S HDL=$$U P^XLFSTR($ E(HL,3,999 )),T=$P($G (^XTV(8989 .3,1,30),5 400),U)
	8183	"RTN","XUS RB4",78,0)
	8184	S RET=$$C HECK(HDL,T )
	8185	"RTN","XUS RB4",79,0)
	8186	I RET>0 D
	8187	"RTN","XUS RB4",80,0)
	8188	. ;This C COW Token good for m ore that o ne try.
	8189	"RTN","XUS RB4",81,0)
	8190	. S ^XTMP (HDL,"JOB" ,$J)=$G(IO ("IP"))
	8191	"RTN","XUS RB4",82,0)
	8192	. S ^XTMP (HDL,"STAT US")=(^XTM P(HDL,"STA TUS")+1)_" ^Active"
	8193	"RTN","XUS RB4",83,0)
	8194	. S ^XUTL ("XQ",$J," HDL")=HDL ;Save hand le with jo b
	8195	"RTN","XUS RB4",84,0)
	8196	. S DUZ(" CCOW")=1 ; Flag a CCO W sign-on.
	8197	"RTN","XUS RB4",85,0)
	8198	Q RET
	8199	"RTN","XUS RB4",86,0)
	8200	;
	8201	"RTN","XUS RB4",87,0)
	8202	CHECK(HL,T OUT) ;Chec k a Token
	8203	"RTN","XUS RB4",88,0)
	8204	N %,J,D,L ,M,S,T,CLN M
	8205	"RTN","XUS RB4",89,0)
	8206	S S=$G(^X TMP(HL,0)) I '$L(S) Q "0^Bad H andle"
	8207	"RTN","XUS RB4",90,0)
	8208	S S=$G(^X TMP(HL,"D" ,0)) I '$L (S) Q "0^B ad Handle" ;Now have real toke n
	8209	"RTN","XUS RB4",91,0)
	8210	I $E(S)'= "\|" Q "0^B ad Token"
	8211	"RTN","XUS RB4",92,0)
	8212	S S=$$DEC RYP^XUSRB1 ($E(S,2,$L (S)-1)) I S="" Q "0^ Bad Token"
	8213	"RTN","XUS RB4",93,0)
	8214	S J=$P(S, "\|"),T=$P( S,"\|",2),D =$P(S,"\|", 3),M=$P(S, "\|",4)
	8215	"RTN","XUS RB4",94,0)
	8216	;Check to ken time
	8217	"RTN","XUS RB4",95,0)
	8218	S %=$$H3^ %ZTM($H),T OUT=$G(TOU T,90) ; P5 73 changed 20 to 90 JLI
	8219	"RTN","XUS RB4",96,0)
	8220	I T+TOUT< % D REMOVE (HL) Q "0^ Token Expi red" ;Toke n good for TOUT or 9 0 seconds
	8221	"RTN","XUS RB4",97,0)
	8222	;Check jo b
	8223	"RTN","XUS RB4",98,0)
	8224	;Check th at token h as handle
	8225	"RTN","XUS RB4",99,0)
	8226	I M'=HL Q "0^Bad To ken"
	8227	"RTN","XUS RB4",100,0 )
	8228	;Check Us er
	8229	"RTN","XUS RB4",101,0 )
	8230	I $G(^VA( 200,D,0))= "" Q "0^Ba d User"
	8231	"RTN","XUS RB4",102,0 )
	8232	;Do IP ch eck
	8233	"RTN","XUS RB4",103,0 )
	8234	S %=$G(IO ("IP")),T= 0,CLNM=""
	8235	"RTN","XUS RB4",104,0 )
	8236	I $L(%),' $$VALIDATE ^XLFIPV(%) S CLNM=%, %=$P($$ADD RESS^XLFNS LK(%),",") ;p638
	8237	"RTN","XUS RB4",105,0 )
	8238	S CLNM=$S ($L($G(IO( "CLNM"))): IO("CLNM") ,$L(CLNM): CLNM,1:"") ;p499
	8239	"RTN","XUS RB4",106,0 )
	8240	I $L($G(^ XTMP(HL,"D 3"))),^XTM P(HL,"D3") =% S T=1
	8241	"RTN","XUS RB4",107,0 )
	8242	I 'T,$L(C LNM),$G(^X TMP(HL,"CL NM"))=IO(" CLNM") S T =1
	8243	"RTN","XUS RB4",108,0 )
	8244	I 'T,$$LO W^XLFSTR($ S($L($G(IO ("ZIO"))): IO("ZIO"), 1:$G(IO))) [$P($G(^XT MP(HL,"CLN M")),".") S T=1 ;ra m p596
	8245	"RTN","XUS RB4",109,0 )
	8246	I 'T Q "0 ^Different IP" ;p499
	8247	"RTN","XUS RB4",110,0 )
	8248	I $D(^XTM P(HL,"D2") ),D>0 S DU Z(2)=^XTMP (HL,"D2")
	8249	"RTN","XUS RB4",111,0 )
	8250	D USER^XU S(D)
	8251	"RTN","XUS RB4",112,0 )
	8252	Q D
	8253	"RTN","XUS RB4",113,0 )
	8254	;
	8255	"RTN","XUS RB4",114,0 )
	8256	;
	8257	"RTN","XUS RB4",115,0 )
	8258	CCOWPC(RET ) ;Return ap
	8259	"RTN","XUS RB4",116,0 )
	8260	N I,XU4
	8261	"RTN","XUS RB4",117,0 )
	8262	S RET(0)= "" I '$$BR OKER^XWBLI B Q
	8263	"RTN","XUS RB4",118,0 )
	8264	D GETLST^ XPAR(.XU4, "SYS","XUS CCOW VAUL T PARAM"," Q")
	8265	"RTN","XUS RB4",119,0 )
	8266	F I=0,1 S RET(I)=$P ($G(XU4(I+ 1)),"^",2, 99)
	8267	"RTN","XUS RB4",120,0 )
	8268	Q
	8269	"RTN","XUS RB4",121,0 )
	8270	;
	8271	"RTN","XUS RB4",122,0 )
	8272	;p500
	8273	"RTN","XUS RB4",123,0 )
	8274	CCOWIP(RET ,CLIENTIP) ;rpc. CCO W Auto Sig non Handle for middl e tiered a pplication servers
	8275	"RTN","XUS RB4",124,0 )
	8276	N %
	8277	"RTN","XUS RB4",125,0 )
	8278	S %=$G(IO ("IP")) ; save origi nal
	8279	"RTN","XUS RB4",126,0 )
	8280	; get act ual ip add ress inste ad of loca lhost addr ess if pos sible
	8281	"RTN","XUS RB4",127,0 )
	8282	S IO("IP" )=$S($G(CL IENTIP)=$$ CONVERT^XL FIPV("127. 0.0.1"):%, $G(CLIENTI P)="":%,1: $G(CLIENTI P)) ;p638
	8283	"RTN","XUS RB4",128,0 )
	8284	D CCOW(.R ET)
	8285	"RTN","XUS RB4",129,0 )
	8286	S IO("IP" )=% ; reve rt to orig inal
	8287	"RTN","XUS RB4",130,0 )
	8288	Q
	8289	"RTN","XUS RB4",131,0 )
	8290	;
	8291	"VER")
	8292	8.0^22.0
	8293	"^DD",3.08 1,3.081,10 1,0)
	8294	LEVEL OF A SSURANCE^F ^^1;2^K:$L (X)>1!($L( X)<1) X
	8295	"^DD",3.08 1,3.081,10 1,.1)
	8296	LOA
	8297	"^DD",3.08 1,3.081,10 1,3)
	8298	Answer mus t be 1 cha racter in length.
	8299	"^DD",3.08 1,3.081,10 1,21,0)
	8300	^^31^31^31 51014^
	8301	"^DD",3.08 1,3.081,10 1,21,1,0)
	8302	Level of A ssurance ( LOA) of th e authenti cated user sign-on p er guidanc e
	8303	"^DD",3.08 1,3.081,10 1,21,2,0)
	8304	from OMB 0 4-04 and N IST SP 800 -63-2.
	8305	"^DD",3.08 1,3.081,10 1,21,3,0)
	8306
	8307	"^DD",3.08 1,3.081,10 1,21,4,0)
	8308	LOA=1
	8309	"^DD",3.08 1,3.081,10 1,21,5,0)
	8310	Little or no conf idence exi sts in the asserted identity; usually
	8311	"^DD",3.08 1,3.081,10 1,21,6,0)
	8312	self-asser ted; essen tially a p ersistent identifier . Requires no identi ty
	8313	"^DD",3.08 1,3.081,10 1,21,7,0)
	8314	proofing, allows any type of t oken inclu ding a sim ple PIN. E xamples:
	8315	"^DD",3.08 1,3.081,10 1,21,8,0)
	8316	Old-style RPC Broker Visitor A ccess; Ide ntificatio n by DUZ w ithout
	8317	"^DD",3.08 1,3.081,10 1,21,9,0)
	8318	authentica tion (re-a uthenticat ion using DUZ only).
	8319	"^DD",3.08 1,3.081,10 1,21,10,0)
	8320
	8321	"^DD",3.08 1,3.081,10 1,21,11,0)
	8322	LOA=2
	8323	"^DD",3.08 1,3.081,10 1,21,12,0)
	8324	Confide nce exists that the asserted i dentity is accurate; used
	8325	"^DD",3.08 1,3.081,10 1,21,13,0)
	8326	frequently for self- service ap plications . Requires identity proofing,
	8327	"^DD",3.08 1,3.081,10 1,21,14,0)
	8328	allows sin gle-factor authentic ation. Pas swords are the norm at this le vel.
	8329	"^DD",3.08 1,3.081,10 1,21,15,0)
	8330	Examples: VistA Acce ss and Ver ify Code; Windows Us ername and Password;
	8331	"^DD",3.08 1,3.081,10 1,21,16,0)
	8332	Broker Sec urity Enha ncement (B SE) Visito r Access; Auto sign- on and CCO W
	8333	"^DD",3.08 1,3.081,10 1,21,17,0)
	8334	token re-a uthenticat ion.
	8335	"^DD",3.08 1,3.081,10 1,21,18,0)
	8336
	8337	"^DD",3.08 1,3.081,10 1,21,19,0)
	8338	LOA=3
	8339	"^DD",3.08 1,3.081,10 1,21,20,0)
	8340	High co nfidence i n the asse rted ident ity's accu racy; used to access
	8341	"^DD",3.08 1,3.081,10 1,21,21,0)
	8342	restricted data. Req uires stri ngent iden tity proof ing, multi -factor
	8343	"^DD",3.08 1,3.081,10 1,21,22,0)
	8344	authentica tion, typi cally a pa ssword or biometric factor use d in
	8345	"^DD",3.08 1,3.081,10 1,21,23,0)
	8346	combinatio n with a 1 ) software token, 2) hardware token, or 3) one-tim e
	8347	"^DD",3.08 1,3.081,10 1,21,24,0)
	8348	password d evice toke n. Example s: OTP dev ices; X.50 9 user cer tificates.
	8349	"^DD",3.08 1,3.081,10 1,21,25,0)
	8350
	8351	"^DD",3.08 1,3.081,10 1,21,26,0)
	8352	LOA=4
	8353	"^DD",3.08 1,3.081,10 1,21,27,0)
	8354	Very hi gh confide nce in the asserted identity's accuracy; used to
	8355	"^DD",3.08 1,3.081,10 1,21,28,0)
	8356	access hig hly restri cted data. Requires stringent and in-per son
	8357	"^DD",3.08 1,3.081,10 1,21,29,0)
	8358	registrati on, multi- factor aut henticatio n with a h ardware cr ypto token
	8359	"^DD",3.08 1,3.081,10 1,21,30,0)
	8360	(use of be arer token s is not p ermitted). Examples: X.509 use r certific ates
	8361	"^DD",3.08 1,3.081,10 1,21,31,0)
	8362	on a hardw are token that is FI PS 140-2 c ompliant; PIV card.
	8363	"^DD",3.08 1,3.081,10 1,"DT")
	8364	3150528
	8365	"^DD",8989 .3,8989.3, 200.1,0)
	8366	SECURITY T OKEN SERVI CE^F^^200; 1^K:$L(X)> 60!($L(X)< 3) X
	8367	"^DD",8989 .3,8989.3, 200.1,3)
	8368	Issuer of security t oken. Answ er must be 3-60 char acters in length.
	8369	"^DD",8989 .3,8989.3, 200.1,21,0 )
	8370	^^11^11^31 50916^
	8371	"^DD",8989 .3,8989.3, 200.1,21,1 ,0)
	8372	When using brokered authentica tion with a security token iss ued by a
	8373	"^DD",8989 .3,8989.3, 200.1,21,2 ,0)
	8374	Security T oken Servi ce (STS), this field will cont ain the id entificati on
	8375	"^DD",8989 .3,8989.3, 200.1,21,3 ,0)
	8376	of the iss uer of the token. Th e STS is t rusted by both the c lient and the
	8377	"^DD",8989 .3,8989.3, 200.1,21,4 ,0)
	8378	service to provide i nteroperab le securit y tokens.
	8379	"^DD",8989 .3,8989.3, 200.1,21,5 ,0)
	8380
	8381	"^DD",8989 .3,8989.3, 200.1,21,6 ,0)
	8382	Security A ssertion M arkup Lang uage (SAML ) tokens a re standar ds-based X ML
	8383	"^DD",8989 .3,8989.3, 200.1,21,7 ,0)
	8384	tokens tha t are used to exchan ge securit y informat ion, inclu ding
	8385	"^DD",8989 .3,8989.3, 200.1,21,8 ,0)
	8386	attribute statements , authenti cation dec ision stat ements, an d
	8387	"^DD",8989 .3,8989.3, 200.1,21,9 ,0)
	8388	authorizat ion decisi on stateme nts. They can be use d as part of a Singl e
	8389	"^DD",8989 .3,8989.3, 200.1,21,1 0,0)
	8390	Sign-On (S SO) soluti on allowin g a client to talk t o services running o n
	8391	"^DD",8989 .3,8989.3, 200.1,21,1 1,0)
	8392	disparate technologi es.
	8393	"^DD",8989 .3,8989.3, 200.1,"DT" )
	8394	3150916
	8395	"^DD",8989 .3,8989.3, 200.2,0)
	8396	ORGANIZATI ON^F^^200; 2^K:$L(X)> 50!($L(X)< 3) X
	8397	"^DD",8989 .3,8989.3, 200.2,3)
	8398	Name of Or ganization (owner of this Vist A instance ). Answer must be 3- 50 charact ers in len gth.
	8399	"^DD",8989 .3,8989.3, 200.2,21,0 )
	8400	^^5^5^3150 916^
	8401	"^DD",8989 .3,8989.3, 200.2,21,1 ,0)
	8402	Identity a nd Access Management ORGANIZAT ION field used to id entify the
	8403	"^DD",8989 .3,8989.3, 200.2,21,2 ,0)
	8404	Organizati on of this VistA ins tance. For internall y authenti cated user s,
	8405	"^DD",8989 .3,8989.3, 200.2,21,3 ,0)
	8406	this field will matc h the SUBJ ECT ORGANI ZATION fie ld (#205.2 ) of the u ser
	8407	"^DD",8989 .3,8989.3, 200.2,21,4 ,0)
	8408	identified in the NE W PERSON f ile (#200) . For the VA, this f ield shoul d
	8409	"^DD",8989 .3,8989.3, 200.2,21,5 ,0)
	8410	always con tain the v alue: "Dep artment Of Veterans Affairs"
	8411	"^DD",8989 .3,8989.3, 200.2,"DT" )
	8412	3150916
	8413	"^DD",8989 .3,8989.3, 200.3,0)
	8414	ORGANIZATI ON ID^F^^2 00;3^K:$L( X)>50!($L( X)<1) X
	8415	"^DD",8989 .3,8989.3, 200.3,3)
	8416	ID of Orga nization ( owner of t his VistA instance). Answer mu st be 1-50 character s in lengt h.
	8417	"^DD",8989 .3,8989.3, 200.3,21,0 )
	8418	^^6^6^3150 916^
	8419	"^DD",8989 .3,8989.3, 200.3,21,1 ,0)
	8420	Identity a nd Access Management ORGANIZAT ION ID fie ld used to uniquely
	8421	"^DD",8989 .3,8989.3, 200.3,21,2 ,0)
	8422	identify t he Organiz ation of t his VistA instance. For intern ally
	8423	"^DD",8989 .3,8989.3, 200.3,21,3 ,0)
	8424	authentica ted users, this fiel d will mat ch the SUB JECT ORGAN IZATION ID
	8425	"^DD",8989 .3,8989.3, 200.3,21,4 ,0)
	8426	field (#20 5.3) of th e user ide ntified in the NEW P ERSON file (#200). F or
	8427	"^DD",8989 .3,8989.3, 200.3,21,5 ,0)
	8428	the VA, th is field s hould alwa ys contain the value :
	8429	"^DD",8989 .3,8989.3, 200.3,21,6 ,0)
	8430	"urn:oid:2 .16.840.1. 113883.4.3 49"
	8431	"^DD",8989 .3,8989.3, 200.3,"DT" )
	8432	3150916
	8433	"BLD",1548 ,6)
	8434	9^
	8435	END
	8436	END