8. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 6/12/2018 11:43:22 AM Eastern Daylight Time. See www.araxis.com for information about Merge. This report uses XHTML and CSS2, and is best viewed with a modern standards-compliant browser. For optimum results when printing this report, use landscape orientation and enable printing of background images and colours in your browser.

8.1 Files compared

#	Location	File	Last Modified
1	VPR_1_7.zip\VPR_1_7	VPR_1_7_V3.KID	Tue Jun 5 13:37:50 2018 UTC
2	VPR_1_7.zip\VPR_1_7	VPR_1_7_V3.KID	Fri Jun 8 18:04:48 2018 UTC

8.2 Comparison summary

Description	Between Files 1 and 2
Description	Text Blocks	Lines
Unchanged	5	5816
Changed	4	8
Inserted	0	0
Removed	0	0

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

8.4 Active regular expressions

No regular expressions were active.

8.5 Comparison detail

	1	KIDS Distr ibution sa ved on Apr 06, 2018@ 10:58:50
	2	VPR17 V3 -- 4/6/20 18
	3	KIDS:V PR1.07^
	4
	5	INSTALL NAME
	6	VPR1.07
	7	"BLD",9471 ,0)
	8	VPR1.07^ VIRTUAL PA TIENT RECO RD^0^31804 06^y
	9	"BLD",9471 ,4,0)
	10	^9.64PA^^
	11	"BLD",9471 ,6.3)
	12	3
	13	"BLD",9471 ,"ABPKG")
	14	n
	15	"BLD",9471 ,"INIT")
	16	POST^VPRPA TCH
	17	"BLD",9471 ,"KRN",0)
	18	^9.67PA^77 9.2^20
	19	"BLD",9471 ,"KRN",.4, 0)
	20	.4
	21	"BLD",9471 ,"KRN",.40 1,0)
	22	.401
	23	"BLD",9471 ,"KRN",.40 2,0)
	24	.402
	25	"BLD",9471 ,"KRN",.40 3,0)
	26	.403
	27	"BLD",9471 ,"KRN",.5, 0)
	28	.5
	29	"BLD",9471 ,"KRN",.84 ,0)
	30	.84
	31	"BLD",9471 ,"KRN",3.6 ,0)
	32	3.6
	33	"BLD",9471 ,"KRN",3.8 ,0)
	34	3.8
	35	"BLD",9471 ,"KRN",9.2 ,0)
	36	9.2
	37	"BLD",9471 ,"KRN",9.8 ,0)
	38	9.8
	39	"BLD",9471 ,"KRN",9.8 ,"NM",0)
	40	^9.68A^8^8
	41	"BLD",9471 ,"KRN",9.8 ,"NM",1,0)
	42	VPRDLRO^^0 ^B28036256
	43	"BLD",9471 ,"KRN",9.8 ,"NM",2,0)
	44	VPRDVSIT^^ 0^B1060243 78
	45	"BLD",9471 ,"KRN",9.8 ,"NM",3,0)
	46	VPRDJ04^^0 ^B48510921
	47	"BLD",9471 ,"KRN",9.8 ,"NM",4,0)
	48	VPRDPT^^0^ B114535256
	49	"BLD",9471 ,"KRN",9.8 ,"NM",5,0)
	50	VPRDJ00^^0 ^B75961021
	51	"BLD",9471 ,"KRN",9.8 ,"NM",6,0)
	52	VPRDGMRC^^ 0^B1505345 8
	53	"BLD",9471 ,"KRN",9.8 ,"NM",7,0)
	54	VPRDJ03^^0 ^B54129495
	55	"BLD",9471 ,"KRN",9.8 ,"NM",8,0)
	56	VPRPATCH^^ 0^B532746
	57	"BLD",9471 ,"KRN",9.8 ,"NM","B", "VPRDGMRC" ,6)
	58
	59	"BLD",9471 ,"KRN",9.8 ,"NM","B", "VPRDJ00", 5)
	60
	61	"BLD",9471 ,"KRN",9.8 ,"NM","B", "VPRDJ03", 7)
	62
	63	"BLD",9471 ,"KRN",9.8 ,"NM","B", "VPRDJ04", 3)
	64
	65	"BLD",9471 ,"KRN",9.8 ,"NM","B", "VPRDLRO", 1)
	66
	67	"BLD",9471 ,"KRN",9.8 ,"NM","B", "VPRDPT",4 )
	68
	69	"BLD",9471 ,"KRN",9.8 ,"NM","B", "VPRDVSIT" ,2)
	70
	71	"BLD",9471 ,"KRN",9.8 ,"NM","B", "VPRPATCH" ,8)
	72
	73	"BLD",9471 ,"KRN",19, 0)
	74	19
	75	"BLD",9471 ,"KRN",19. 1,0)
	76	19.1
	77	"BLD",9471 ,"KRN",101 ,0)
	78	101
	79	"BLD",9471 ,"KRN",409 .61,0)
	80	409.61
	81	"BLD",9471 ,"KRN",771 ,0)
	82	771
	83	"BLD",9471 ,"KRN",779 .2,0)
	84	779.2
	85	"BLD",9471 ,"KRN",870 ,0)
	86	870
	87	"BLD",9471 ,"KRN",898 9.51,0)
	88	8989.51
	89	"BLD",9471 ,"KRN",898 9.52,0)
	90	8989.52
	91	"BLD",9471 ,"KRN",899 4,0)
	92	8994
	93	"BLD",9471 ,"KRN","B" ,.4,.4)
	94
	95	"BLD",9471 ,"KRN","B" ,.401,.401 )
	96
	97	"BLD",9471 ,"KRN","B" ,.402,.402 )
	98
	99	"BLD",9471 ,"KRN","B" ,.403,.403 )
	100
	101	"BLD",9471 ,"KRN","B" ,.5,.5)
	102
	103	"BLD",9471 ,"KRN","B" ,.84,.84)
	104
	105	"BLD",9471 ,"KRN","B" ,3.6,3.6)
	106
	107	"BLD",9471 ,"KRN","B" ,3.8,3.8)
	108
	109	"BLD",9471 ,"KRN","B" ,9.2,9.2)
	110
	111	"BLD",9471 ,"KRN","B" ,9.8,9.8)
	112
	113	"BLD",9471 ,"KRN","B" ,19,19)
	114
	115	"BLD",9471 ,"KRN","B" ,19.1,19.1 )
	116
	117	"BLD",9471 ,"KRN","B" ,101,101)
	118
	119	"BLD",9471 ,"KRN","B" ,409.61,40 9.61)
	120
	121	"BLD",9471 ,"KRN","B" ,771,771)
	122
	123	"BLD",9471 ,"KRN","B" ,779.2,779 .2)
	124
	125	"BLD",9471 ,"KRN","B" ,870,870)
	126
	127	"BLD",9471 ,"KRN","B" ,8989.51,8 989.51)
	128
	129	"BLD",9471 ,"KRN","B" ,8989.52,8 989.52)
	130
	131	"BLD",9471 ,"KRN","B" ,8994,8994 )
	132
	133	"BLD",9471 ,"QUES",0)
	134	^9.62^^
	135	"BLD",9471 ,"REQB",0)
	136	^9.611^2^2
	137	"BLD",9471 ,"REQB",1, 0)
	138	VPR1.05^ 2
	139	"BLD",9471 ,"REQB",2, 0)
	140	GMRC3.08 0^2
	141	"BLD",9471 ,"REQB","B ","GMRC3. 080",2)
	142
	143	"BLD",9471 ,"REQB","B ","VPR1.0 5",1)
	144
	145	"INIT")
	146	POST^VPRPA TCH
	147	"MBREQ")
	148	0
	149	"PKG",571, -1)
	150	1^1
	151	"PKG",571, 0)
	152	VIRTUAL PA TIENT RECO RD^VPR^Uti lities to manage a v irtual cop y of the p atient rec ord
	153	"PKG",571, 20,0)
	154	^9.402P^^
	155	"PKG",571, 22,0)
	156	^9.49I^1^1
	157	"PKG",571, 22,1,0)
	158	1.0^311080 4^3110901^ 1
	159	"PKG",571, 22,1,"PAH" ,1,0)
	160	7^3180406
	161	"QUES","XP F1",0)
	162	Y
	163	"QUES","XP F1","??")
	164	^D REP^XPD H
	165	"QUES","XP F1","A")
	166	Shall I wr ite over y our \|FLAG\| File
	167	"QUES","XP F1","B")
	168	YES
	169	"QUES","XP F1","M")
	170	D XPF1^XPD IQ
	171	"QUES","XP F2",0)
	172	Y
	173	"QUES","XP F2","??")
	174	^D DTA^XPD H
	175	"QUES","XP F2","A")
	176	Want my da ta \|FLAG\| yours
	177	"QUES","XP F2","B")
	178	YES
	179	"QUES","XP F2","M")
	180	D XPF2^XPD IQ
	181	"QUES","XP I1",0)
	182	YO
	183	"QUES","XP I1","??")
	184	^D INHIBIT ^XPDH
	185	"QUES","XP I1","A")
	186	Want KIDS to INHIBIT LOGONs du ring the i nstall
	187	"QUES","XP I1","B")
	188	NO
	189	"QUES","XP I1","M")
	190	D XPI1^XPD IQ
	191	"QUES","XP M1",0)
	192	PO^VA(200, :EM
	193	"QUES","XP M1","??")
	194	^D MG^XPDH
	195	"QUES","XP M1","A")
	196	Enter the Coordinato r for Mail Group '\|F LAG\|'
	197	"QUES","XP M1","B")
	198
	199	"QUES","XP M1","M")
	200	D XPM1^XPD IQ
	201	"QUES","XP O1",0)
	202	Y
	203	"QUES","XP O1","??")
	204	^D MENU^XP DH
	205	"QUES","XP O1","A")
	206	Want KIDS to Rebuild Menu Tree s Upon Com pletion of Install
	207	"QUES","XP O1","B")
	208	NO
	209	"QUES","XP O1","M")
	210	D XPO1^XPD IQ
	211	"QUES","XP Z1",0)
	212	Y
	213	"QUES","XP Z1","??")
	214	^D OPT^XPD H
	215	"QUES","XP Z1","A")
	216	Want to DI SABLE Sche duled Opti ons, Menu Options, a nd Protoco ls
	217	"QUES","XP Z1","B")
	218	NO
	219	"QUES","XP Z1","M")
	220	D XPZ1^XPD IQ
	221	"QUES","XP Z2",0)
	222	Y
	223	"QUES","XP Z2","??")
	224	^D RTN^XPD H
	225	"QUES","XP Z2","A")
	226	Want to MO VE routine s to other CPUs
	227	"QUES","XP Z2","B")
	228	NO
	229	"QUES","XP Z2","M")
	230	D XPZ2^XPD IQ
	231	"RTN")
	232	8
	233	"RTN","VPR DGMRC")
	234	0^6^B15053 458
	235	"RTN","VPR DGMRC",1,0 )
	236	VPRDGMRC ; SLC/MKB -- Consult e xtract ;8/ 2/11 15:2 9
	237	"RTN","VPR DGMRC",2,0 )
	238	;;1.0;VIR TUAL PATIE NT RECORD; *1,4,5,7 *;Sep 01, 2011;Build 3
	239	"RTN","VPR DGMRC",3,0 )
	240	;;Per VHA Directive 2004-038, this rout ine should not be mo dified.
	241	"RTN","VPR DGMRC",4,0 )
	242	;
	243	"RTN","VPR DGMRC",5,0 )
	244	; Externa l Referenc es DBIA#
	245	"RTN","VPR DGMRC",6,0 )
	246	; ------- ---------- -- -----
	247	"RTN","VPR DGMRC",7,0 )
	248	; ^VA(200 10060
	249	"RTN","VPR DGMRC",8,0 )
	250	; GMRCAPI 6082
	251	"RTN","VPR DGMRC",9,0 )
	252	; GMRCGUI B 2980
	253	"RTN","VPR DGMRC",10, 0)
	254	; GMRCSLM 1,^TMP("GM RCR",$J) 2740
	255	"RTN","VPR DGMRC",11, 0)
	256	; XUAF4 2171
	257	"RTN","VPR DGMRC",12, 0)
	258	;
	259	"RTN","VPR DGMRC",13, 0)
	260	; ------- ----- Get consults f rom VistA ---------- --
	261	"RTN","VPR DGMRC",14, 0)
	262	;
	263	"RTN","VPR DGMRC",15, 0)
	264	EN(DFN,BEG ,END,MAX,I FN) ; -- f ind patien t's consul ts
	265	"RTN","VPR DGMRC",16, 0)
	266	N VPRN,VP RX,VPRITM K ^TMP("GM RCR",$J,"C S")
	267	"RTN","VPR DGMRC",17, 0)
	268	S DFN=+$G (DFN) Q:DF N<1
	269	"RTN","VPR DGMRC",18, 0)
	270	S BEG=$G( BEG,141010 1),END=$G( END,414101 5),MAX=$G( MAX,9999)
	271	"RTN","VPR DGMRC",19, 0)
	272	;
	273	"RTN","VPR DGMRC",20, 0)
	274	D OER^GMR CSLM1(DFN, "",BEG,END ,"")
	275	"RTN","VPR DGMRC",21, 0)
	276	S VPRN=0 F S VPRN= $O(^TMP("G MRCR",$J," CS",VPRN)) Q:VPRN<1! (VPRN>MAX) S VPRX=$ G(^(VPRN,0 )) Q:$E(VP RX)="<" D
	277	"RTN","VPR DGMRC",22, 0)
	278	. I $G(IF N),IFN'=+V PRX Q
	279	"RTN","VPR DGMRC",23, 0)
	280	. K VPRIT M D EN1(+V PRX,.VPRIT M),XML(.VP RITM)
	281	"RTN","VPR DGMRC",24, 0)
	282	K ^TMP("G MRCR",$J," CS"),^TMP( "VPRTEXT", $J)
	283	"RTN","VPR DGMRC",25, 0)
	284	Q
	285	"RTN","VPR DGMRC",26, 0)
	286	;
	287	"RTN","VPR DGMRC",27, 0)
	288	EN1(ID,CON S) ; -- re turn a con sult in CO NS("attrib ute")=valu e
	289	"RTN","VPR DGMRC",28, 0)
	290	; Exp ects DFN, VPRX=^TMP( "GMRCR",$J ,"CS",VPRN ,0) [from EN]
	291	"RTN","VPR DGMRC",29, 0)
	292	N VPRD,X0 ,VPRJ,X,VP RTIU
	293	"RTN","VPR DGMRC",30, 0)
	294	K CONS,^T MP("VPRTEX T",$J)
	295	"RTN","VPR DGMRC",31, 0)
	296	S CONS("i d")=ID,CON S("request ed")=$P(VP RX,U,2)
	297	"RTN","VPR DGMRC",32, 0)
	298	S CONS("s tatus")=$P (VPRX,U,3) ,CONS("ser vice")=$P( VPRX,U,4)
	299	"RTN","VPR DGMRC",33, 0)
	300	S CONS("p rocedure") =$P(VPRX,U ,5),CONS(" name")=$P( VPRX,U,7)
	301	"RTN","VPR DGMRC",34, 0)
	302	I $P(VPRX ,U,6)="*" S CONS("re sult")="SI GNIFICANT FINDINGS"
	303	"RTN","VPR DGMRC",35, 0)
	304	S CONS("o rderID")=$ P(VPRX,U,8 ),CONS("ty pe")=$P(VP RX,U,9)
	305	"RTN","VPR DGMRC",36, 0)
	306	;D DOCLIS T^GMRCGUIB (.VPRD,ID) S X0=$G(V PRD(0)) ;= ^GMR(123,I D,0)
	307	"RTN","VPR DGMRC",37, 0)
	308	D GET^GMR CAPI(.VPRD ,ID) S X0= $G(VPRD(0) ) ;=^GMR(1 23,ID,0)
	309	"RTN","VPR DGMRC",38, 0)
	310	S X=$P(X0 ,U,9) S:$L (X) CONS(" urgency")= X
	311	"RTN","VPR DGMRC",39, 0)
	312	S X=$P(X0 ,U,14) S:X CONS("pro vider")=X_ U_$P($G(^V A(200,X,0) ),U)_U_$$P ROVSPC^VPR D(X)
	313	"RTN","VPR DGMRC",40, 0)
	314	I $O(VPRD (20,0)) D
	315	"RTN","VPR DGMRC",41, 0)
	316	. S X=$NA (^TMP("VPR TEXT",$J," reason"))
	317	"RTN","VPR DGMRC",42, 0)
	318	. S VPRJ= 0 F S VPR J=$O(VPRD( 20,VPRJ)) Q:VPRJ<1 S @X@(VPRJ )=$G(VPRD( 20,VPRJ,0) )
	319	"RTN","VPR DGMRC",43, 0)
	320	. S CONS( "reason")= X
	321	"RTN","VPR DGMRC",44, 0)
	322	I $D(VPRD (30))!$D(V PRD(30.1)) D
	323	"RTN","VPR DGMRC",45, 0)
	324	. S X=$G( VPRD(30.1) ),$P(X,U,2 )=""
	325	"RTN","VPR DGMRC",46, 0)
	326	. S:$D(VP RD(30)) $P (X,U,2)=VP RD(30)
	327	"RTN","VPR DGMRC",47, 0)
	328	. S:$L(X) CONS("pro vDx")=X
	329	"RTN","VPR DGMRC",48, 0)
	330	S VPRJ=0 F S VPRJ= $O(VPRD(50 ,VPRJ)) Q: VPRJ<1 S X=$G(VPRD( 50,VPRJ)) D
	331	"RTN","VPR DGMRC",49, 0)
	332	. N Y S Y =$$INFO^VP RDTIU(+X) Q:Y<1 ;dr aft or ret racted
	333	"RTN","VPR DGMRC",50, 0)
	334	. S CONS( "document" ,VPRJ)=Y
	335	"RTN","VPR DGMRC",51, 0)
	336	. S:$G(VP RTEXT) CON S("documen t",VPRJ,"c ontent")=$ $TEXT^VPRD TIU(X)
	337	"RTN","VPR DGMRC",52, 0)
	338	S X=$P(X0 ,U,21),CON S("facilit y")=$S(X:$ $STA^XUAF4 (X)_U_$P($ $NS^XUAF4( X),U),1:$$ FAC^VPRD)
	339	"RTN","VPR DGMRC",53, 0)
	340	Q
	341	"RTN","VPR DGMRC",54, 0)
	342	;
	343	"RTN","VPR DGMRC",55, 0)
	344	; ------- ----- Retu rn data to middle ti er ------- -----
	345	"RTN","VPR DGMRC",56, 0)
	346	;
	347	"RTN","VPR DGMRC",57, 0)
	348	XML(CONS) ; -- Retur n patient consult as XML
	349	"RTN","VPR DGMRC",58, 0)
	350	; as <el ement code ='123' dis playName=' ABC' />
	351	"RTN","VPR DGMRC",59, 0)
	352	N ATT,X,Y ,I,J,NAMES
	353	"RTN","VPR DGMRC",60, 0)
	354	D ADD("<c onsult>") S VPRTOTL= $G(VPRTOTL )+1
	355	"RTN","VPR DGMRC",61, 0)
	356	S ATT="" F S ATT=$ O(CONS(ATT )) Q:ATT=" " D D:$L (Y) ADD(Y)
	357	"RTN","VPR DGMRC",62, 0)
	358	. S NAMES =$S(ATT="d ocument":" id^localTi tle^nation alTitle^vu id",ATT="p rovider":" code^name^ "_$$PROVTA GS^VPRD,AT T="provDx" :"code^nam e^system", 1:"code^na me")_"^Z"
	359	"RTN","VPR DGMRC",63, 0)
	360	. I $O(CO NS(ATT,0)) D S Y="" Q ;multi ples
	361	"RTN","VPR DGMRC",64, 0)
	362	.. D ADD( "<"_ATT_"s >")
	363	"RTN","VPR DGMRC",65, 0)
	364	.. S I=0 F S I=$O( CONS(ATT,I )) Q:I<1 D
	365	"RTN","VPR DGMRC",66, 0)
	366	... S X=$ G(CONS(ATT ,I)),Y="<" _ATT_" "_$ $LOOP
	367	"RTN","VPR DGMRC",67, 0)
	368	... S X=$ G(CONS(ATT ,I,"conten t")) I '$L (X) S Y=Y_ "/>" D ADD (Y) Q
	369	"RTN","VPR DGMRC",68, 0)
	370	... S Y=Y _">" D ADD (Y)
	371	"RTN","VPR DGMRC",69, 0)
	372	... S Y=" <content x ml:space=' preserve'> " D ADD(Y)
	373	"RTN","VPR DGMRC",70, 0)
	374	... S J=0 F S J=$O (@X@(J)) Q :J<1 S Y= $$ESC^VPRD (@X@(J)) D ADD(Y)
	375	"RTN","VPR DGMRC",71, 0)
	376	... D ADD ("</conten t>"),ADD(" </"_ATT_"> ")
	377	"RTN","VPR DGMRC",72, 0)
	378	.. D ADD( "</"_ATT_" s>")
	379	"RTN","VPR DGMRC",73, 0)
	380	. S X=$G( CONS(ATT)) ,Y="" Q:'$ L(X)
	381	"RTN","VPR DGMRC",74, 0)
	382	. I ATT=" reason" D S Y="" Q
	383	"RTN","VPR DGMRC",75, 0)
	384	.. S Y="< reason xml :space='pr eserve'>" D ADD(Y)
	385	"RTN","VPR DGMRC",76, 0)
	386	.. S J=0 F S J=$O( @X@(J)) Q: J<1 S Y=$ $ESC^VPRD( @X@(J)) D ADD(Y)
	387	"RTN","VPR DGMRC",77, 0)
	388	.. D ADD( "</reason> ")
	389	"RTN","VPR DGMRC",78, 0)
	390	. I X'["^ " S Y="<"_ ATT_" valu e='"_$$ESC ^VPRD(X)_" ' />" Q
	391	"RTN","VPR DGMRC",79, 0)
	392	. I $L(X) >1 S Y="<" _ATT_" "_$ $LOOP_"/>"
	393	"RTN","VPR DGMRC",80, 0)
	394	D ADD("</ consult>")
	395	"RTN","VPR DGMRC",81, 0)
	396	Q
	397	"RTN","VPR DGMRC",82, 0)
	398	;
	399	"RTN","VPR DGMRC",83, 0)
	400	LOOP() ; - - build su b-items st ring from NAMES and X
	401	"RTN","VPR DGMRC",84, 0)
	402	N STR,P,T AG S STR=" "
	403	"RTN","VPR DGMRC",85, 0)
	404	F P=1:1 S TAG=$P(NA MES,U,P) Q :TAG="Z" I $L($P(X, U,P)) S ST R=STR_TAG_ "='"_$$ESC ^VPRD($P(X ,U,P))_"' "
	405	"RTN","VPR DGMRC",86, 0)
	406	Q STR
	407	"RTN","VPR DGMRC",87, 0)
	408	;
	409	"RTN","VPR DGMRC",88, 0)
	410	ADD(X) ; A dd a line @VPR@(n)=X
	411	"RTN","VPR DGMRC",89, 0)
	412	S VPRI=$G (VPRI)+1
	413	"RTN","VPR DGMRC",90, 0)
	414	S @VPR@(V PRI)=X
	415	"RTN","VPR DGMRC",91, 0)
	416	Q
	417	"RTN","VPR DJ00")
	418	0^5^B75961 021
	419	"RTN","VPR DJ00",1,0)
	420	VPRDJ00 ;S LC/MKB -- Patient de mographics ;8/11/11 15:29
	421	"RTN","VPR DJ00",2,0)
	422	;;1.0;VIR TUAL PATIE NT RECORD; 2,7;Se p 01, 2011 ;Build 3
	423	"RTN","VPR DJ00",3,0)
	424	;;Per VHA Directive 2004-038, this rout ine should not be mo dified.
	425	"RTN","VPR DJ00",4,0)
	426	;
	427	"RTN","VPR DJ00",5,0)
	428	; Externa l Referenc es DBIA#
	429	"RTN","VPR DJ00",6,0)
	430	; ------- ---------- -- -----
	431	"RTN","VPR DJ00",7,0)
	432	; ^AUPNVS IT 2028
	433	"RTN","VPR DJ00",8,0)
	434	; ^DPT 10035
	435	"RTN","VPR DJ00",9,0)
	436	; ^VA(200 10060
	437	"RTN","VPR DJ00",10,0 )
	438	; DGCV 4156
	439	"RTN","VPR DJ00",11,0 )
	440	; DGMSTAP I 2716
	441	"RTN","VPR DJ00",12,0 )
	442	; DGNTAPI 3457
	443	"RTN","VPR DJ00",13,0 )
	444	; DGPFAPI 3860
	445	"RTN","VPR DJ00",14,0 )
	446	; DGRPDB 4807
	447	"RTN","VPR DJ00",15,0 )
	448	; DIC 2051
	449	"RTN","VPR DJ00",16,0 )
	450	; DIQ 2056
	451	"RTN","VPR DJ00",17,0 )
	452	; MPIF001 2701
	453	"RTN","VPR DJ00",18,0 )
	454	; SCAPMC 1916
	455	"RTN","VPR DJ00",19,0 )
	456	; SDUTL3 1252
	457	"RTN","VPR DJ00",20,0 )
	458	; VADPT 10061
	459	"RTN","VPR DJ00",21,0 )
	460	; VAFCTFU 1 2990
	461	"RTN","VPR DJ00",22,0 )
	462	; VASITE 10112
	463	"RTN","VPR DJ00",23,0 )
	464	; XUAF4 2171
	465	"RTN","VPR DJ00",24,0 )
	466	;
	467	"RTN","VPR DJ00",25,0 )
	468	; All tag s expect D FN, VPRID, [VPRSTART , VPRSTOP, VPRMAX, V PRTEXT]
	469	"RTN","VPR DJ00",26,0 )
	470	;
	471	"RTN","VPR DJ00",27,0 )
	472	DPT1 ; -- Demographi cs [VPRSTA RT,VPRSTOP ,VPRMAX,VP RID not cu rrently us ed here]
	473	"RTN","VPR DJ00",28,0 )
	474	N PAT,SYS S SYS=$$S ITE^VASITE
	475	"RTN","VPR DJ00",29,0 )
	476	D DEM,SVC ,PRF,ATC,S UPP,ALIAS, FAC,PC
	477	"RTN","VPR DJ00",30,0 )
	478	I $D(PAT) >9 D ADD^V PRDJ("PAT" )
	479	"RTN","VPR DJ00",31,0 )
	480	Q
	481	"RTN","VPR DJ00",32,0 )
	482	;
	483	"RTN","VPR DJ00",33,0 )
	484	DEM ;-demo graphic da ta
	485	"RTN","VPR DJ00",34,0 )
	486	N VADM,VA ,VAERR,X
	487	"RTN","VPR DJ00",35,0 )
	488	S X=+$$GE TICN^MPIF0 01(DFN) S: X>1 PAT("i cn")=X
	489	"RTN","VPR DJ00",36,0 )
	490	D DEM^VAD PT S X=VAD M(1),PAT(" fullName") =X
	491	"RTN","VPR DJ00",37,0 )
	492	S PAT("fa milyName") =$P(X,",") ,PAT("give nNames")=$ P(X,",",2, 99)
	493	"RTN","VPR DJ00",38,0 )
	494	S PAT("ss n")=$P(VAD M(2),U),PA T("localId ")=DFN
	495	"RTN","VPR DJ00",39,0 )
	496	S PAT("ui d")=$$SETU ID^VPRUTIL S("patient ",DFN,DFN)
	497	"RTN","VPR DJ00",40,0 )
	498	S:$D(VA(" BID")) PAT ("briefId" )=$E(X)_VA ("BID")
	499	"RTN","VPR DJ00",41,0 )
	500	S X=+$P($ P(VADM(3), U),"."),PA T("dateOfB irth")=$$J SONDT^VPRU TILS(X)
	501	"RTN","VPR DJ00",42,0 )
	502	S X=$P(VA DM(5),U),P AT("gender Code")="ur n:va:pat-g ender:"_X, PAT("gende rName")=$$ NAME(X,"ge nder")
	503	"RTN","VPR DJ00",43,0 )
	504	S X=+$P($ P(VADM(6), U),".") S: X PAT("die d")=$$JSON DT^VPRUTIL S(X)
	505	"RTN","VPR DJ00",44,0 )
	506	S X=$$GET 1^DIQ(38.1 ,DFN_",",2 ,"I") S:$L (X) PAT("s ensitive") =$$BOOL(X)
	507	"RTN","VPR DJ00",45,0 )
	508	S X=+VADM (9) S:X PA T("religio nCode")="u rn:va:pat- religion:" _X,PAT("re ligionName ")=$$NAME( X,"religio n")
	509	"RTN","VPR DJ00",46,0 )
	510	S X=$P(VA DM(10),U,2 ) I $L(X) D ;PAT("m aritalStat us")=$E(X)
	511	"RTN","VPR DJ00",47,0 )
	512	. S X=$E( X),X=$S(X= "S":"L",X= "N":"S",1: X)
	513	"RTN","VPR DJ00",48,0 )
	514	. S PAT(" maritalSta tuses",1," code")="ur n:va:pat-m aritalStat us:"_X
	515	"RTN","VPR DJ00",49,0 )
	516	. S PAT(" maritalSta tuses",1," name")=$$N AME(X,"mar italStatus ")
	517	"RTN","VPR DJ00",50,0 )
	518	I VADM(11 ) D
	519	"RTN","VPR DJ00",51,0 )
	520	. N I S I =0
	521	"RTN","VPR DJ00",52,0 )
	522	. F S I= $O(VADM(11 ,I)) Q:I<1 S X=+VAD M(11,I),PA T("ethnici ties",X,"e thnicity") =$$GET1^DI Q(2.06,X_" ,"_DFN_"," ,".01:3")
	523	"RTN","VPR DJ00",53,0 )
	524	I VADM(12 ) D
	525	"RTN","VPR DJ00",54,0 )
	526	. N I S I =0
	527	"RTN","VPR DJ00",55,0 )
	528	. F S I= $O(VADM(12 ,I)) Q:I<1 S X=+VAD M(12,I),PA T("races", X,"race")= $$GET1^DIQ (2.02,X_", "_DFN_",", ".01:3")
	529	"RTN","VPR DJ00",56,0 )
	530	I $G(VADM (13)) D
	531	"RTN","VPR DJ00",57,0 )
	532	. N I S I =+$O(VADM( 13,0)),X=$ P($G(VADM( 13,I)),U,2 )
	533	"RTN","VPR DJ00",58,0 )
	534	. S I=$$F IND1^DIC(. 85,,"X",X)
	535	"RTN","VPR DJ00",59,0 )
	536	. S PAT(" languageCo de")=$$GET 1^DIQ(.85, I_",",.02)
	537	"RTN","VPR DJ00",60,0 )
	538	. S PAT(" languageNa me")=X
	539	"RTN","VPR DJ00",61,0 )
	540	Q
	541	"RTN","VPR DJ00",62,0 )
	542	SVC ;-serv ice data
	543	"RTN","VPR DJ00",63,0 )
	544	N VAEL,VA SV,VAERR,X ,Y,I,AO,IR ,PGF,HNC,M ST,CV
	545	"RTN","VPR DJ00",64,0 )
	546	D 7^VADPT
	547	"RTN","VPR DJ00",65,0 )
	548	S PAT("ve teran","is Vet")=VAEL (4)
	549	"RTN","VPR DJ00",66,0 )
	550	S PAT("ve teran","se rviceConne cted")=$$B OOL(+VAEL( 3))
	551	"RTN","VPR DJ00",67,0 )
	552	S:VAEL(3) PAT("vete ran","serv iceConnect ionPercent ")=+$P(VAE L(3),U,2)
	553	"RTN","VPR DJ00",68,0 )
	554	S X=+$G(^ DPT(DFN,"L R")) S:X P AT("vetera n","lrdfn" )=X
	555	"RTN","VPR DJ00",69,0 )
	556	S:VAEL(2) PAT("serv icePeriod" )=$P(VAEL( 2),U,2)
	557	"RTN","VPR DJ00",70,0 )
	558	I VAEL(1) D
	559	"RTN","VPR DJ00",71,0 )
	560	. S PAT(" eligibilit y",+VAEL(1 ),"name")= $P(VAEL(1) ,U,2)
	561	"RTN","VPR DJ00",72,0 )
	562	. S PAT(" eligibilit y",+VAEL(1 ),"primary ")="1",I=0
	563	"RTN","VPR DJ00",73,0 )
	564	. F S I= $O(VAEL(1, I)) Q:I<1 S PAT("el igibility" ,I)=$P(VAE L(1,I),U,2 )
	565	"RTN","VPR DJ00",74,0 )
	566	S:$L(VAEL (8)) PAT(" eligibilit yStatus")= $P(VAEL(8) ,U,2)
	567	"RTN","VPR DJ00",75,0 )
	568	S:$L(VAEL (9)) PAT(" meansTest" )=$P(VAEL( 9),U,2)
	569	"RTN","VPR DJ00",76,0 )
	570	;
	571	"RTN","VPR DJ00",77,0 )
	572	; exposur es
	573	"RTN","VPR DJ00",78,0 )
	574	S AO=VASV (2),IR=VAS V(3)
	575	"RTN","VPR DJ00",79,0 )
	576	S PGF=VAS V(11)!VASV (12)!VASV( 13) ;OIF/O EF
	577	"RTN","VPR DJ00",80,0 )
	578	S X=$$GET CUR^DGNTAP I(DFN,"HNC "),X=+($G( HNC("STAT" )))
	579	"RTN","VPR DJ00",81,0 )
	580	S HNC=$S( X=4:1,X=5: 1,X=1:0,X= 6:0,1:"")
	581	"RTN","VPR DJ00",82,0 )
	582	S X=$P($$ GETSTAT^DG MSTAPI(DFN ),U,2),MST =$S(X="Y": 1,X="N":0, 1:"")
	583	"RTN","VPR DJ00",83,0 )
	584	S X=$$CVE DT^DGCV(DF N),CV=$S(+ X<0:"",+X= 0:0,$P(X,U ,3):1,1:0)
	585	"RTN","VPR DJ00",84,0 )
	586	S X=AO_U_ IR_U_PGF_U _HNC_U_MST _U_CV
	587	"RTN","VPR DJ00",85,0 )
	588	F P=1:1:6 S I=$P(X, U,P),$P(X, U,P)=$S(I: "Yes",I=0: "No",1:"Un known")
	589	"RTN","VPR DJ00",86,0 )
	590	S NM="age nt-orange^ ionizing-r adiation^s w-asia^hea d-neck-can cer^mst^co mbat-vet"
	591	"RTN","VPR DJ00",87,0 )
	592	F P=1:1:6 S PAT("ex posures",P ,"uid")="u rn:va:"_$P (NM,U,P)_" :"_$E($P(X ,U,P)),PAT ("exposure s",P,"name ")=$P(X,U, P)
	593	"RTN","VPR DJ00",88,0 )
	594	;
	595	"RTN","VPR DJ00",89,0 )
	596	; rated d isabilitie s [DGRPDB]
	597	"RTN","VPR DJ00",90,0 )
	598	N VPRDIS, DIS
	599	"RTN","VPR DJ00",91,0 )
	600	D RDIS^DG RPDB(DFN,. VPRDIS)
	601	"RTN","VPR DJ00",92,0 )
	602	S I=0 F S I=$O(VPR DIS(I)) Q: I<1 D
	603	"RTN","VPR DJ00",93,0 )
	604	. S DIS=V PRDIS(I) ; ien^%^sc
	605	"RTN","VPR DJ00",94,0 )
	606	. S PAT(" disability ",I,"name" )=$$GET1^D IQ(31,+DIS _",",.01)
	607	"RTN","VPR DJ00",95,0 )
	608	. S PAT(" disability ",I,"sc")= +$P(DIS,U, 3)
	609	"RTN","VPR DJ00",96,0 )
	610	. S PAT(" disability ",I,"disPe rcent")=+$ P(DIS,U,2)
	611	"RTN","VPR DJ00",97,0 )
	612	. S PAT(" disability ",I,"vaCod e")=+$$GET 1^DIQ(31,+ DIS_",",2)
	613	"RTN","VPR DJ00",98,0 )
	614	Q
	615	"RTN","VPR DJ00",99,0 )
	616	PRF ;-pati ent record flags
	617	"RTN","VPR DJ00",100, 0)
	618	N VPRPF,I ,NAME,TEXT
	619	"RTN","VPR DJ00",101, 0)
	620	Q:'$$GETA CT^DGPFAPI (DFN,"VPRP F")
	621	"RTN","VPR DJ00",102, 0)
	622	S I=0 F S I=$O(VPR PF(I)) Q:I <1 D
	623	"RTN","VPR DJ00",103, 0)
	624	. S NAME= $P(VPRPF(I ,"FLAG"),U ,2)
	625	"RTN","VPR DJ00",104, 0)
	626	. M TEXT= VPRPF(I,"N ARR")
	627	"RTN","VPR DJ00",105, 0)
	628	. S PAT(" flags",I," name")=NAM E
	629	"RTN","VPR DJ00",106, 0)
	630	. S PAT(" flags",I," text")=$$S TRING^VPRD (.TEXT)
	631	"RTN","VPR DJ00",107, 0)
	632	Q
	633	"RTN","VPR DJ00",108, 0)
	634	ATC ;-addr ess & tele com
	635	"RTN","VPR DJ00",109, 0)
	636	N VAPA,I, X,P,NM
	637	"RTN","VPR DJ00",110, 0)
	638	S VAPA("P ")="" D AD D^VADPT ;p ermanent a ddress
	639	"RTN","VPR DJ00",111, 0)
	640	S:$L(VAPA (1)) PAT(" addresses" ,1,"street Line1")=VA PA(1)
	641	"RTN","VPR DJ00",112, 0)
	642	S X=VAPA( 2) I $L(X) ,$L(VAPA(3 )) S X=X_" "_VAPA(3)
	643	"RTN","VPR DJ00",113, 0)
	644	S:$L(X) P AT("addres ses",1,"st reetLine2" )=X
	645	"RTN","VPR DJ00",114, 0)
	646	S:$L(VAPA (4)) PAT(" addresses" ,1,"city") =VAPA(4)
	647	"RTN","VPR DJ00",115, 0)
	648	S X=$P(VA PA(5),U,2) S:$L(X) P AT("addres ses",1,"st ateProvinc e")=X
	649	"RTN","VPR DJ00",116, 0)
	650	S X=$P(VA PA(11),U,2 ) S:$L(X) PAT("addre sses",1,"p ostalCode" )=X
	651	"RTN","VPR DJ00",117, 0)
	652	;
	653	"RTN","VPR DJ00",118, 0)
	654	; X=home^ cell^work phones
	655	"RTN","VPR DJ00",119, 0)
	656	S X=$$FOR MAT(VAPA(8 ))_U_$$FOR MAT($$GET1 ^DIQ(2,DFN _",",.134) )_U_$$FORM AT($$GET1^ DIQ(2,DFN_ ",",.132))
	657	"RTN","VPR DJ00",120, 0)
	658	S NM="H^M C^WP" F P= 1:1:3 I $L ($P(X,U,P) ) D
	659	"RTN","VPR DJ00",121, 0)
	660	. S I=$P( NM,U,P),PA T("telecom s",P,"usag eCode")=I
	661	"RTN","VPR DJ00",122, 0)
	662	. S PAT(" telecoms", P,"usageNa me")=$S(I= "WP":"work place",I= "MC":"mobi le contact ",1:"home address")
	663	"RTN","VPR DJ00",123, 0)
	664	. S PAT(" telecoms", P,"telecom ")=$P(X,U, P)
	665	"RTN","VPR DJ00",124, 0)
	666	Q
	667	"RTN","VPR DJ00",125, 0)
	668	SUPP ;-sup port conta cts
	669	"RTN","VPR DJ00",126, 0)
	670	N VAOA,A, I,X,TYPE,S
	671	"RTN","VPR DJ00",127, 0)
	672	S S=0 F A ="",1 K VA OA D
	673	"RTN","VPR DJ00",128, 0)
	674	. S:A VAO A("A")=A D OAD^VADPT Q:'$L($G( VAOA(9)))
	675	"RTN","VPR DJ00",129, 0)
	676	. S S=S+1 ,TYPE=$S(A =1:"ECON^E mergency C ontact",1: "NOK^Next of Kin")
	677	"RTN","VPR DJ00",130, 0)
	678	. S PAT(" supports", S,"contact TypeCode") ="urn:va:p at-contact :"_$P(TYPE ,U)
	679	"RTN","VPR DJ00",131, 0)
	680	. S PAT(" supports", S,"contact TypeName") =$P(TYPE,U ,2)
	681	"RTN","VPR DJ00",132, 0)
	682	. S:$L(VA OA(9)) PAT ("supports ",S,"name" )=VAOA(9)
	683	"RTN","VPR DJ00",133, 0)
	684	. S:$L(VA OA(10)) PA T("support s",S,"rela tionship") =VAOA(10)
	685	"RTN","VPR DJ00",134, 0)
	686	. S:$L(VA OA(1)) PAT ("supports ",S,"addre sses",1,"s treetLine1 ")=VAOA(1)
	687	"RTN","VPR DJ00",135, 0)
	688	. S X=VAO A(2) I $L( X),$L(VAOA (3)) S X=X _" "_VAOA( 3)
	689	"RTN","VPR DJ00",136, 0)
	690	. S:$L(X) PAT("supp orts",S,"a ddresses", 1,"streetL ine2")=X
	691	"RTN","VPR DJ00",137, 0)
	692	. S:$L(VA OA(4)) PAT ("supports ",S,"addre sses",1,"c ity")=VAOA (4)
	693	"RTN","VPR DJ00",138, 0)
	694	. S X=$P( VAOA(5),U, 2) S:$L(X) PAT("supp orts",S,"a ddresses", 1,"statePr ovince")=X
	695	"RTN","VPR DJ00",139, 0)
	696	. S X=$P( VAOA(11),U ,2) S:$L(X ) PAT("sup ports",S," addresses" ,1,"postal Code")=X
	697	"RTN","VPR DJ00",140, 0)
	698	. S I=$S( A=1:.33011 ,1:.21011) ,X=$$FORMA T(VAOA(8)) _U_U_$$FOR MAT($$GET1 ^DIQ(2,DFN _",",I))
	699	"RTN","VPR DJ00",141, 0)
	700	. ; X=hom e^cell^wor k phones
	701	"RTN","VPR DJ00",142, 0)
	702	. S NM="H ^MC^WP" F P=1:1:3 I $L($P(X,U, P)) D
	703	"RTN","VPR DJ00",143, 0)
	704	.. S I=$P (NM,U,P),P AT("suppor ts",S,"tel ecomList", P,"usageCo de")=I
	705	"RTN","VPR DJ00",144, 0)
	706	.. S PAT( "supports" ,S,"teleco mList",P," usageName" )=$S(I="WP ":"work pl ace",I="MC ":"mobile contact",1 :"home add ress")
	707	"RTN","VPR DJ00",145, 0)
	708	.. S PAT( "supports" ,S,"teleco mList",P," telecom")= $P(X,U,P)
	709	"RTN","VPR DJ00",146, 0)
	710	Q
	711	"RTN","VPR DJ00",147, 0)
	712	ALIAS ;-ot her names used
	713	"RTN","VPR DJ00",148, 0)
	714	N I,X
	715	"RTN","VPR DJ00",149, 0)
	716	S I=0 F S I=$O(^DP T(DFN,.01, I)) Q:I<1 S X=$P($G (^(I,0)),U ) D
	717	"RTN","VPR DJ00",150, 0)
	718	. S PAT(" aliases",I ,"fullName ")=X
	719	"RTN","VPR DJ00",151, 0)
	720	. S PAT(" aliases",I ,"familyNa me")=$P(X, ",")
	721	"RTN","VPR DJ00",152, 0)
	722	. S PAT(" aliases",I ,"givenNam es")=$P(X, ",",2,99)
	723	"RTN","VPR DJ00",153, 0)
	724	Q
	725	"RTN","VPR DJ00",154, 0)
	726	FAC ;-trea ting facil ities [see FACLIST^O RWCIRN]
	727	"RTN","VPR DJ00",155, 0)
	728	N IFN S D FN=+$G(DFN ) Q:DFN<1
	729	"RTN","VPR DJ00",156, 0)
	730	N VPRY,HO ME,LAST,I, X,IEN,VASI TE
	731	"RTN","VPR DJ00",157, 0)
	732	S X=$$ALL ^VASITE ;V ASITE(stn# )=stn# for all local
	733	"RTN","VPR DJ00",158, 0)
	734	I $L($T(T FL^VAFCTFU 1)) D TFL^ VAFCTFU1(. VPRY,DFN)
	735	"RTN","VPR DJ00",159, 0)
	736	S HOME=+$ P($G(^DPT( DFN,"MPI") ),U,3) ;ho me facilit y
	737	"RTN","VPR DJ00",160, 0)
	738	I $P($G(V PRY(1)),U) <0 D ;not setup
	739	"RTN","VPR DJ00",161, 0)
	740	. S X=$O( ^AUPNVSIT( "AA",DFN,0 )),LAST=$S (X:9999999 -$P(X,".") ,1:"")
	741	"RTN","VPR DJ00",162, 0)
	742	. S X=$$S ITE^VASITE
	743	"RTN","VPR DJ00",163, 0)
	744	. S VPRY( 1)=$P(X,U, 3)_U_$P(X, U,2)_U_LAS T_U_$$GET1 ^DIQ(4,+X_ ",",60)
	745	"RTN","VPR DJ00",164, 0)
	746	S I=0 F S I=$O(VPR Y(I)) Q:I< 1 D
	747	"RTN","VPR DJ00",165, 0)
	748	. S X=VPR Y(I) Q:$P( X,U)="" ; unknown
	749	"RTN","VPR DJ00",166, 0)
	750	. S IEN=+ $$IEN^XUAF 4($P(X,U))
	751	"RTN","VPR DJ00",167, 0)
	752	. I +X=77 6!(+X=200) S $P(X,U, 2)="DEPT. OF DEFENSE "
	753	"RTN","VPR DJ00",168, 0)
	754	. S PAT(" facilities ",I,"code" )=$P(X,U) ;stn#
	755	"RTN","VPR DJ00",169, 0)
	756	. S PAT(" facilities ",I,"name" )=$P(X,U,2 ) ;name
	757	"RTN","VPR DJ00",170, 0)
	758	. S:IEN=H OME PAT("f acilities" ,I,"homeSi te")="true "
	759	"RTN","VPR DJ00",171, 0)
	760	. S:$L($P (X,U,3)) P AT("facili ties",I,"l atestDate" )=$$JSONDT ^VPRUTILS( $P($P(X,U, 3),"."))
	761	"RTN","VPR DJ00",172, 0)
	762	. I $D(VA SITE(+X)) D
	763	"RTN","VPR DJ00",173, 0)
	764	.. S PAT( "facilitie s",I,"loca lPatientId ")=DFN
	765	"RTN","VPR DJ00",174, 0)
	766	.. S PAT( "facilitie s",I,"syst emId")=VPR SYS
	767	"RTN","VPR DJ00",175, 0)
	768	Q
	769	"RTN","VPR DJ00",176, 0)
	770	PC ;-prima ry care as signments
	771	"RTN","VPR DJ00",177, 0)
	772	N X,I,VPR T,PRV,POS
	773	"RTN","VPR DJ00",178, 0)
	774	S X=$$OUT PTPR^SDUTL 3(DFN) I X D
	775	"RTN","VPR DJ00",179, 0)
	776	. S PAT(" pcProvider Uid")=$$SE TUID^VPRUT ILS("user" ,,+X)
	777	"RTN","VPR DJ00",180, 0)
	778	. S PAT(" pcProvider Name")=$P( X,U,2)
	779	"RTN","VPR DJ00",181, 0)
	780	S X=$$OUT PTTM^SDUTL 3(DFN) I X D
	781	"RTN","VPR DJ00",182, 0)
	782	. S PAT(" pcTeamUid" )=$$SETUID ^VPRUTILS( "team",,+X )
	783	"RTN","VPR DJ00",183, 0)
	784	. S PAT(" pcTeamName ")=$$GET1^ DIQ(404.51 ,+X_",",.0 1)
	785	"RTN","VPR DJ00",184, 0)
	786	. S X=$$P RTM^SCAPMC (+X,,,,.VP RT) Q:'X
	787	"RTN","VPR DJ00",185, 0)
	788	. S (I,PR V)=0 F S PRV=+$O(@V PRT@("SCPR ",PRV)) Q: PRV<1 D
	789	"RTN","VPR DJ00",186, 0)
	790	.. S POS= $O(@VPRT@( "SCPR",PRV ,0)),I=I+1
	791	"RTN","VPR DJ00",187, 0)
	792	.. S PAT( "pcTeamMem bers",I,"u id")=$$SET UID^VPRUTI LS("user", ,PRV)
	793	"RTN","VPR DJ00",188, 0)
	794	.. S PAT( "pcTeamMem bers",I,"n ame")=$P($ G(^VA(200, PRV,0)),U)
	795	"RTN","VPR DJ00",189, 0)
	796	.. S PAT( "pcTeamMem bers",I,"p osition")= $$GET1^DIQ (404.57,PO S_",",.01)
	797	"RTN","VPR DJ00",190, 0)
	798	I $G(^DPT (DFN,.105) ) S PAT("i npatient") ="true"
	799	"RTN","VPR DJ00",191, 0)
	800	Q
	801	"RTN","VPR DJ00",192, 0)
	802	;
	803	"RTN","VPR DJ00",193, 0)
	804	FORMAT(X) ; -- enfor ce (xxx)xx x-xxxx pho ne format
	805	"RTN","VPR DJ00",194, 0)
	806	S X=$G(X) I X?1"("3 N1")"3N1"- "4N.E Q X
	807	"RTN","VPR DJ00",195, 0)
	808	N P,N,I,Y S P=""
	809	"RTN","VPR DJ00",196, 0)
	810	F I=1:1:$ L(X) S N=$ E(X,I) I N =+N S P=P_ N
	811	"RTN","VPR DJ00",197, 0)
	812	S:$L(P)<1 0 P=$E("00 00000000", 1,10-$L(P) )_P
	813	"RTN","VPR DJ00",198, 0)
	814	S Y=$S(P: "("_$E(P,1 ,3)_")"_$E (P,4,6)_"- "_$E(P,7,1 0),1:"")
	815	"RTN","VPR DJ00",199, 0)
	816	Q Y
	817	"RTN","VPR DJ00",200, 0)
	818	;
	819	"RTN","VPR DJ00",201, 0)
	820	NAME(CODE, SET) ; -- Return exp anded name for code set
	821	"RTN","VPR DJ00",202, 0)
	822	N Y S Y=" ",CODE=$G( CODE)
	823	"RTN","VPR DJ00",203, 0)
	824	I $G(SET) ="gender" S Y=$S(COD E="F":"Fem ale",CODE= "M":"Male" ,1:"Unknow n")
	825	"RTN","VPR DJ00",204, 0)
	826	I $G(SET) ="maritalS tatus" S Y =$S(CODE=" D":"Divorc ed",CODE=" M":"Marrie d",CODE="W ":"Widowed ",CODE="L" :"Legally Separated" ,CODE="S": "Never Mar ried",1:"U nknown")
	827	"RTN","VPR DJ00",205, 0)
	828	I $G(SET) ="religion " S Y=$$GE T1^DIQ(13, CODE_",",. 01)
	829	"RTN","VPR DJ00",206, 0)
	830	Q Y
	831	"RTN","VPR DJ00",207, 0)
	832	;
	833	"RTN","VPR DJ00",208, 0)
	834	BOOL(X) ;
	835	"RTN","VPR DJ00",209, 0)
	836	Q $S(X>0: "true",1:" false")
	837	"RTN","VPR DJ03")
	838	0^7^B54129 495
	839	"RTN","VPR DJ03",1,0)
	840	VPRDJ03 ;S LC/MKB -- Consults,C linProcedu res,CLiO ; 6/25/12 1 6:11
	841	"RTN","VPR DJ03",2,0)
	842	;;1.0;VIR TUAL PATIE NT RECORD; 2,7;Se p 01, 2011 ;Build 3
	843	"RTN","VPR DJ03",3,0)
	844	;;Per VHA Directive 2004-038, this rout ine should not be mo dified.
	845	"RTN","VPR DJ03",4,0)
	846	;
	847	"RTN","VPR DJ03",5,0)
	848	; Externa l Referenc es DBIA#
	849	"RTN","VPR DJ03",6,0)
	850	; ------- ---------- -- -----
	851	"RTN","VPR DJ03",7,0)
	852	; ^SC 10040
	853	"RTN","VPR DJ03",8,0)
	854	; ^TIU(89 25.1 5677
	855	"RTN","VPR DJ03",9,0)
	856	; ^VA(200 10060
	857	"RTN","VPR DJ03",10,0 )
	858	; %DT 10003
	859	"RTN","VPR DJ03",11,0 )
	860	; DILFD 2055
	861	"RTN","VPR DJ03",12,0 )
	862	; DIQ 2056
	863	"RTN","VPR DJ03",13,0 )
	864	; GMRCAPI 6082
	865	"RTN","VPR DJ03",14,0 )
	866	; GMRCGUI B 2980
	867	"RTN","VPR DJ03",15,0 )
	868	; GMRCSLM 1,^TMP("GM RCR" 2740
	869	"RTN","VPR DJ03",16,0 )
	870	; MCARUTL 3 3280
	871	"RTN","VPR DJ03",17,0 )
	872	; MDPS1,^ TMP("MDHSP " 4230
	873	"RTN","VPR DJ03",18,0 )
	874	; ORX8 2467
	875	"RTN","VPR DJ03",19,0 )
	876	; TIULQ 2693
	877	"RTN","VPR DJ03",20,0 )
	878	; TIUSRVL O 2834
	879	"RTN","VPR DJ03",21,0 )
	880	; XLFSTR 10104
	881	"RTN","VPR DJ03",22,0 )
	882	; XUAF4 2171
	883	"RTN","VPR DJ03",23,0 )
	884	;
	885	"RTN","VPR DJ03",24,0 )
	886	; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
	887	"RTN","VPR DJ03",25,0 )
	888	;
	889	"RTN","VPR DJ03",26,0 )
	890	GMRC1(ID) ; -- consu lt/request VPRX=^TMP ("GMRCR",$ J,"CS",VPR N,0)
	891	"RTN","VPR DJ03",27,0 )
	892	N CONS,OR DER,VPRD,X 0,X,VPRJ,V PRTIU,NT,V PRSN
	893	"RTN","VPR DJ03",28,0 )
	894	S CONS("l ocalId")=+ VPRX,CONS( "uid")=$$S ETUID^VPRU TILS("cons ult",DFN,+ VPRX)
	895	"RTN","VPR DJ03",29,0 )
	896	S CONS("d ateTime")= $$JSONDT^V PRUTILS($P (VPRX,U,2) )
	897	"RTN","VPR DJ03",30,0 )
	898	S CONS("s tatusName" )=$P(VPRX, U,3),CONS( "service") =$P(VPRX,U ,4)
	899	"RTN","VPR DJ03",31,0 )
	900	S CONS("c onsultProc edure")=$P (VPRX,U,5)
	901	"RTN","VPR DJ03",32,0 )
	902	I $P(VPRX ,U,6)="*" S CONS("in terpretati on")="SIGN IFICANT FI NDINGS"
	903	"RTN","VPR DJ03",33,0 )
	904	S CONS("t ypeName")= $P(VPRX,U, 7),CONS("c ategory")= $P(VPRX,U, 9)
	905	"RTN","VPR DJ03",34,0 )
	906	S ORDER=+ $P(VPRX,U, 8),CONS("o rderName") =$P($$OI^O RX8(ORDER) ,U,2)
	907	"RTN","VPR DJ03",35,0 )
	908	S CONS("o rderUid")= $$SETUID^V PRUTILS("o rder",DFN, ORDER)
	909	"RTN","VPR DJ03",36,0 )
	910	;D DOCLIS T^GMRCGUIB (.VPRD,+VP RX) S X0=$ G(VPRD(0)) ;=^GMR(12 3,ID,0)
	911	"RTN","VPR DJ03",37,0 )
	912	D GET^GMR CAPI(.VPRD ,+VPRX) S X0=$G(VPRD (0)) ;=^GM R(123,ID,0 )
	913	"RTN","VPR DJ03",38,0 )
	914	S X=$P(X0 ,U,9) S:$L (X) CONS(" urgency")= X
	915	"RTN","VPR DJ03",39,0 )
	916	S X=+$P(X 0,U,14) I X D ;orde ring provi der
	917	"RTN","VPR DJ03",40,0 )
	918	. S CONS( "providerU id")=$$SET UID^VPRUTI LS("user", ,X)
	919	"RTN","VPR DJ03",41,0 )
	920	. S CONS( "providerN ame")=$P($ G(^VA(200, X,0)),U)
	921	"RTN","VPR DJ03",42,0 )
	922	I $O(VPRD (20,0)) M VPRSN=VPRD (20) S CON S("reason" )=$$STRING ^VPRD(.VPR SN)
	923	"RTN","VPR DJ03",43,0 )
	924	I $D(VPRD (30))!$D(V PRD(30.1)) D
	925	"RTN","VPR DJ03",44,0 )
	926	. S:$D(VP RD(30)) CO NS("provis ionalDx"," name")=VPR D(30)
	927	"RTN","VPR DJ03",45,0 )
	928	. S:$D(VP RD(30.1)) CONS("prov isionalDx" ,"code")=$ P(VPRD(30. 1),U),CONS ("provisio nalDx","sy stem")=$P( VPRD(30.1) ,U,3)
	929	"RTN","VPR DJ03",46,0 )
	930	S VPRJ=0 F S VPRJ= $O(VPRD(50 ,VPRJ)) Q: VPRJ<1 S X=$G(VPRD( 50,VPRJ)) D
	931	"RTN","VPR DJ03",47,0 )
	932	. Q:'$D(@ (U_$P(X,"; ",2)_+X_") ")) ;text deleted
	933	"RTN","VPR DJ03",48,0 )
	934	. S CONS( "results", VPRJ,"uid" )=$$SETUID ^VPRUTILS( "document" ,DFN,+X)
	935	"RTN","VPR DJ03",49,0 )
	936	. D EXTRA CT^TIULQ(+ X,"VPRTIU" ,,.01)
	937	"RTN","VPR DJ03",50,0 )
	938	. S CONS( "results", VPRJ,"loca lTitle")=$ G(VPRTIU(+ X,.01,"E") )
	939	"RTN","VPR DJ03",51,0 )
	940	. S NT=$$ GET1^DIQ(8 925.1,+$G( VPRTIU(+X, .01,"I"))_ ",",1501)
	941	"RTN","VPR DJ03",52,0 )
	942	. S:$L(NT ) CONS("re sults",VPR J,"nationa lTitle")=N T
	943	"RTN","VPR DJ03",53,0 )
	944	S X=$P(X0 ,U,21),X=$ S(X:$$STA^ XUAF4(X)_U _$P($$NS^X UAF4(X),U) ,1:$$FAC^V PRD)
	945	"RTN","VPR DJ03",54,0 )
	946	D FACILIT Y^VPRUTILS (X,"CONS")
	947	"RTN","VPR DJ03",55,0 )
	948	D ADD^VPR DJ("CONS", "consult")
	949	"RTN","VPR DJ03",56,0 )
	950	Q
	951	"RTN","VPR DJ03",57,0 )
	952	;
	953	"RTN","VPR DJ03",58,0 )
	954	MDPS1(DFN, BEG,END,MA X) ; -- pe rform CP s earch (sco pe variabl es)
	955	"RTN","VPR DJ03",59,0 )
	956	N MCARCOD E,MCARDT,M CARPROC,MC ESKEY,MCES SEC,MCFILE ,MDC,MDIMG ,RES
	957	"RTN","VPR DJ03",60,0 )
	958	S BEG=$G( BEG,141010 1),END=$G( END,414101 5),MAX=$G( MAX,9999)
	959	"RTN","VPR DJ03",61,0 )
	960	K ^TMP("M DHSP",$J) S RES=""
	961	"RTN","VPR DJ03",62,0 )
	962	D EN1^MDP S1(.RES,DF N,BEG,END, MAX,"",0) ;RES=^TMP( "MDHSP",$J )
	963	"RTN","VPR DJ03",63,0 )
	964	Q
	965	"RTN","VPR DJ03",64,0 )
	966	;
	967	"RTN","VPR DJ03",65,0 )
	968	MC1(ID) ; -- clinica l procedur e VPRX=^TM P("MDHSP", $J,VPRN)
	969	"RTN","VPR DJ03",66,0 )
	970	N X,Y,%DT ,DATE,RTN, GBL,CONS,T IUN,VPRD,X 0,PROC,VPR T,LOC,FAC
	971	"RTN","VPR DJ03",67,0 )
	972	S RTN=$P( VPRX,U,3,4 ) Q:RTN="P RPRO^MDPS4 " ;skip n on-CP item s
	973	"RTN","VPR DJ03",68,0 )
	974	S X=$P(VP RX,U,6),%D T="TXS" D ^%DT Q:Y'> 0 S DATE= Y
	975	"RTN","VPR DJ03",69,0 )
	976	S GBL=+$P (VPRX,U,2) _";"_$S(RT N="PR702^M DPS1":"MDD (702,",1:$ $ROOT^VPRD MC(DFN,$P( VPRX,U,11) ,DATE))
	977	"RTN","VPR DJ03",70,0 )
	978	Q:'GBL I $G(ID),ID '=GBL Q ;unknow n, or not requested
	979	"RTN","VPR DJ03",71,0 )
	980	;
	981	"RTN","VPR DJ03",72,0 )
	982	S CONS=+$ P(VPRX,U,1 3) D:CONS DOCLIST^GM RCGUIB(.VP RD,CONS) S X0=$G(VPR D(0)) ;=^G MR(123,ID, 0)
	983	"RTN","VPR DJ03",73,0 )
	984	S TIUN=+$ P(VPRX,U,1 4) S:TIUN TIUN=TIUN_ U_$$RESOLV E^TIUSRVLO (TIUN)
	985	"RTN","VPR DJ03",74,0 )
	986	S PROC("l ocalId")=G BL,PROC("c ategory")= "CP"
	987	"RTN","VPR DJ03",75,0 )
	988	S PROC("u id")=$$SET UID^VPRUTI LS("proced ure",DFN,G BL)
	989	"RTN","VPR DJ03",76,0 )
	990	S PROC("n ame")=$P(V PRX,U),PRO C("dateTim e")=$$JSON DT^VPRUTIL S(DATE)
	991	"RTN","VPR DJ03",77,0 )
	992	S X=$P(VP RX,U,7) S: $L(X) PROC ("interpre tation")=X
	993	"RTN","VPR DJ03",78,0 )
	994	S PROC("k ind")="Pro cedure"
	995	"RTN","VPR DJ03",79,0 )
	996	I CONS,X0 D
	997	"RTN","VPR DJ03",80,0 )
	998	. N VPRJ S PROC("re quested")= $$JSONDT^V PRUTILS(+X 0)
	999	"RTN","VPR DJ03",81,0 )
	1000	. S PROC( "consultUi d")=$$SETU ID^VPRUTIL S("consult ",DFN,CONS )
	1001	"RTN","VPR DJ03",82,0 )
	1002	. S PROC( "orderUid" )=$$SETUID ^VPRUTILS( "order",DF N,+$P(X0,U ,3))
	1003	"RTN","VPR DJ03",83,0 )
	1004	. S PROC( "statusNam e")=$$EXTE RNAL^DILFD (123,8,,$P (X0,U,12))
	1005	"RTN","VPR DJ03",84,0 )
	1006	. S VPRJ= 0 F S VPR J=$O(VPRD( 50,VPRJ)) Q:VPRJ<1 S X=+$G(VP RD(50,VPRJ )) D
	1007	"RTN","VPR DJ03",85,0 )
	1008	.. D NOTE (X)
	1009	"RTN","VPR DJ03",86,0 )
	1010	.. S:'TIU N TIUN=X_U _$$RESOLVE ^TIUSRVLO( X)
	1011	"RTN","VPR DJ03",87,0 )
	1012	I TIUN D
	1013	"RTN","VPR DJ03",88,0 )
	1014	. S X=$P( TIUN,U,5) I X D
	1015	"RTN","VPR DJ03",89,0 )
	1016	.. S PROC ("provider s",1,"prov iderUid")= $$SETUID^V PRUTILS("u ser",,+X)
	1017	"RTN","VPR DJ03",90,0 )
	1018	.. S PROC ("provider s",1,"prov iderName") =$P(X,";", 3)
	1019	"RTN","VPR DJ03",91,0 )
	1020	. S:$P(TI UN,U,11) P ROC("hasIm ages")="tr ue"
	1021	"RTN","VPR DJ03",92,0 )
	1022	. K VPRT D EXTRACT^ TIULQ(+TIU N,"VPRT",, ".03;.05;1 211",,,"I" )
	1023	"RTN","VPR DJ03",93,0 )
	1024	. S X=+$G (VPRT(+TIU N,.03,"I") ),PROC("en counterUid ")=$$SETUI D^VPRUTILS ("visit",D FN,X)
	1025	"RTN","VPR DJ03",94,0 )
	1026	. S LOC=+ $G(VPRT(+T IUN,1211," I")) I LOC S LOC=LOC _U_$P($G(^ SC(LOC,0)) ,U)
	1027	"RTN","VPR DJ03",95,0 )
	1028	. E S X= $P(TIUN,U, 6) S:$L(X) LOC=+$O(^ SC("B",X,0 ))_U_X
	1029	"RTN","VPR DJ03",96,0 )
	1030	. S:LOC P ROC("locat ionUid")=$ $SETUID^VP RUTILS("lo cation",,+ LOC),PROC( "locationN ame")=$P(L OC,U,2),FA C=$$FAC^VP RD(+LOC)
	1031	"RTN","VPR DJ03",97,0 )
	1032	. I '$D(P ROC("statu sName")) S X=+$G(VPR T(+TIUN,.0 5,"I")),PR OC("status Name")=$S( X<6:"PARTI AL RESULTS ",1:"COMPL ETE")
	1033	"RTN","VPR DJ03",98,0 )
	1034	. I '$G(P ROC("resul ts",+TIUN) ) D NOTE(+ TIUN)
	1035	"RTN","VPR DJ03",99,0 )
	1036	; if no c onsult or note/visit ...
	1037	"RTN","VPR DJ03",100, 0)
	1038	S:'$D(PRO C("statusN ame")) PRO C("statusN ame")="COM PLETE"
	1039	"RTN","VPR DJ03",101, 0)
	1040	I '$D(FAC ) S X=$P(X 0,U,21),FA C=$S(X:$$S TA^XUAF4(X )_U_$P($$N S^XUAF4(X) ,U),1:$$FA C^VPRD)
	1041	"RTN","VPR DJ03",102, 0)
	1042	D FACILIT Y^VPRUTILS (FAC,"PROC ")
	1043	"RTN","VPR DJ03",103, 0)
	1044	D ADD^VPR DJ("PROC", "procedure ")
	1045	"RTN","VPR DJ03",104, 0)
	1046	Q
	1047	"RTN","VPR DJ03",105, 0)
	1048	;
	1049	"RTN","VPR DJ03",106, 0)
	1050	NOTE(DA) ; -- add TI U note inf o
	1051	"RTN","VPR DJ03",107, 0)
	1052	N VPRT,NT ,TEXT
	1053	"RTN","VPR DJ03",108, 0)
	1054	D EXTRACT ^TIULQ(DA, "VPRT",,.0 1)
	1055	"RTN","VPR DJ03",109, 0)
	1056	S PROC("r esults",DA ,"uid")=$$ SETUID^VPR UTILS("doc ument",+$G (DFN),DA)
	1057	"RTN","VPR DJ03",110, 0)
	1058	S PROC("r esults",DA ,"localTit le")=$G(VP RT(DA,.01, "E"))
	1059	"RTN","VPR DJ03",111, 0)
	1060	S NT=$$GE T1^DIQ(892 5.1,+$G(VP RT(DA,.01, "I"))_",", 1501)
	1061	"RTN","VPR DJ03",112, 0)
	1062	S:$L(NT) PROC("resu lts",DA,"n ationalTit le")=NT
	1063	"RTN","VPR DJ03",113, 0)
	1064	Q
	1065	"RTN","VPR DJ03",114, 0)
	1066	;
	1067	"RTN","VPR DJ03",115, 0)
	1068	MDC1(ID) ; -- clinic al observa tion
	1069	"RTN","VPR DJ03",116, 0)
	1070	N GUID,CL IO,VPRC,VP RT,LOC,FAC ,I,X,Y
	1071	"RTN","VPR DJ03",117, 0)
	1072	S GUID=$G (ID) Q:GUI D="" ;inv alid GUID
	1073	"RTN","VPR DJ03",118, 0)
	1074	D QRYOBS^ VPRDMDC("V PRC",GUID) Q:'$D(VPR C) ;doesn 't exist
	1075	"RTN","VPR DJ03",119, 0)
	1076	Q:$L($G(V PRC("PAREN T_ID","E") )) ;PAREN T also in list
	1077	"RTN","VPR DJ03",120, 0)
	1078	;
	1079	"RTN","VPR DJ03",121, 0)
	1080	S CLIO("l ocalId")=G UID,CLIO(" uid")=$$SE TUID^VPRUT ILS("obs", DFN,GUID)
	1081	"RTN","VPR DJ03",122, 0)
	1082	S X=$G(VP RC("TERM_I D","I")) S :X CLIO("t ypeVuid")= "urn:va:vu id:"_X
	1083	"RTN","VPR DJ03",123, 0)
	1084	S CLIO("t ypeCode")= "urn:va:cl ioterminol ogy:"_$G(V PRC("TERM_ ID","GUID" ))
	1085	"RTN","VPR DJ03",124, 0)
	1086	S CLIO("t ypeName")= $G(VPRC("T ERM_ID","E "))
	1087	"RTN","VPR DJ03",125, 0)
	1088	S CLIO("r esult")=$G (VPRC("SVA LUE","E"))
	1089	"RTN","VPR DJ03",126, 0)
	1090	S X=$G(VP RC("UNIT_I D","ABBV") ) S:$L(X) CLIO("unit s")=X
	1091	"RTN","VPR DJ03",127, 0)
	1092	S X=$G(VP RC("ENTERE D_DATE_TIM E","I")),C LIO("enter ed")=$$JSO NDT^VPRUTI LS(X)
	1093	"RTN","VPR DJ03",128, 0)
	1094	S X=$G(VP RC("OBSERV ED_DATE_TI ME","I")), CLIO("obse rved")=$$J SONDT^VPRU TILS(X)
	1095	"RTN","VPR DJ03",129, 0)
	1096	D QRYTYPE S^VPRDMDC( "VPRT")
	1097	"RTN","VPR DJ03",130, 0)
	1098	F I=3,5 S X=$G(VPRT (I,"XML")) I $L($G(V PRC(X,"E") )) D
	1099	"RTN","VPR DJ03",131, 0)
	1100	. S Y=VPR T(I,"NAME" ),Y=$S(Y=" LOCATION": "bodySite" ,1:$$LOW^X LFSTR(Y))
	1101	"RTN","VPR DJ03",132, 0)
	1102	. S CLIO( Y_"Code")= VPRC(X,"I" ),CLIO(Y_" Name")=VPR C(X,"E")
	1103	"RTN","VPR DJ03",133, 0)
	1104	F I=4,6,7 S X=$G(VP RT(I,"XML" )) I $L($G (VPRC(X,"E "))) D
	1105	"RTN","VPR DJ03",134, 0)
	1106	. S CLIO( "qualifier s",I,"type ")=$$LOW^X LFSTR(VPRT (I,"NAME") )
	1107	"RTN","VPR DJ03",135, 0)
	1108	. S CLIO( "qualifier s",I,"code ")=VPRC(X, "I")
	1109	"RTN","VPR DJ03",136, 0)
	1110	. S CLIO( "qualifier s",I,"name ")=VPRC(X, "E")
	1111	"RTN","VPR DJ03",137, 0)
	1112	S X=$G(VP RC("RANGE" ,"E")) I $ L(X) D
	1113	"RTN","VPR DJ03",138, 0)
	1114	. S Y=$S( X="Out of Bounds Low ":"<",X="O ut of Boun ds High":" >",1:$E(X) )
	1115	"RTN","VPR DJ03",139, 0)
	1116	. S CLIO( "interpret ationCode" )="urn:hl7 :observati on-interpr etation:"_ Y
	1117	"RTN","VPR DJ03",140, 0)
	1118	. S CLIO( "interpret ationName" )=$S(X="<" :"Low off scale",X=" >":"High o ff scale", 1:X)
	1119	"RTN","VPR DJ03",141, 0)
	1120	; X=$G(VP RC("STATUS ","E")) S: $L(X) CLIO ("resultSt atus")=$S( X="unverif ied":"acti ve",1:"com plete")
	1121	"RTN","VPR DJ03",142, 0)
	1122	I $D(VPRC ("SUPP_PAG E")) D ;a dd set inf o
	1123	"RTN","VPR DJ03",143, 0)
	1124	. S CLIO( "setID")=$ G(VPRC("SU PP_PAGE"," GUID"))
	1125	"RTN","VPR DJ03",144, 0)
	1126	. S CLIO( "setName") =$G(VPRC(" SUPP_PAGE" ,"DISPLAY_ NAME"))
	1127	"RTN","VPR DJ03",145, 0)
	1128	. S X=$G( VPRC("SUPP _PAGE","TY PE")) S:$L (X) CLIO(" setType")= X
	1129	"RTN","VPR DJ03",146, 0)
	1130	. S X=$G( VPRC("SUPP _PAGE","AC TIVATED_DA TE_TIME")) S:X CLIO( "setStart" )=$$JSONDT ^VPRUTILS( X)
	1131	"RTN","VPR DJ03",147, 0)
	1132	. S X=$G( VPRC("SUPP _PAGE","DE ACTIVATED_ DATE_TIME" )) S:X CLI O("setStop ")=$$JSOND T^VPRUTILS (X)
	1133	"RTN","VPR DJ03",148, 0)
	1134	S CLIO("s tatusCode" )="urn:va: observatio n-status:c omplete",C LIO("statu sName")="c omplete"
	1135	"RTN","VPR DJ03",149, 0)
	1136	S LOC=$G( VPRC("HOSP ITAL_LOCAT ION_ID","I ")),FAC=$$ FAC^VPRD(L OC)
	1137	"RTN","VPR DJ03",150, 0)
	1138	S CLIO("l ocationUid ")=$$SETUI D^VPRUTILS ("location ",,LOC)
	1139	"RTN","VPR DJ03",151, 0)
	1140	S CLIO("l ocationNam e")=$G(VPR C("HOSPITA L_LOCATION _ID","E"))
	1141	"RTN","VPR DJ03",152, 0)
	1142	D FACILIT Y^VPRUTILS (FAC,"CLIO ")
	1143	"RTN","VPR DJ03",153, 0)
	1144	S X=$G(VP RC("COMMEN T","E")) S :$L(X) CLI O("comment ")=X
	1145	"RTN","VPR DJ03",154, 0)
	1146	D ADD^VPR DJ("CLIO", "obs")
	1147	"RTN","VPR DJ03",155, 0)
	1148	Q
	1149	"RTN","VPR DJ04")
	1150	0^3^B48510 921
	1151	"RTN","VPR DJ04",1,0)
	1152	VPRDJ04 ;S LC/MKB -- Appointmen ts,Visits ;6/25/12 16:11
	1153	"RTN","VPR DJ04",2,0)
	1154	;;1.0;VIR TUAL PATIE NT RECORD; 2,5,7; Sep 01, 20 11;Build 3
	1155	"RTN","VPR DJ04",3,0)
	1156	;;Per VHA Directive 2004-038, this rout ine should not be mo dified.
	1157	"RTN","VPR DJ04",4,0)
	1158	;
	1159	"RTN","VPR DJ04",5,0)
	1160	; Externa l Referenc es DBIA#
	1161	"RTN","VPR DJ04",6,0)
	1162	; ------- ---------- -- -----
	1163	"RTN","VPR DJ04",7,0)
	1164	; ^AUPNVS IT 2028
	1165	"RTN","VPR DJ04",8,0)
	1166	; ^DGS(41 .1 3796
	1167	"RTN","VPR DJ04",9,0)
	1168	; ^DIC(42 10039
	1169	"RTN","VPR DJ04",10,0 )
	1170	; ^SC 10040
	1171	"RTN","VPR DJ04",11,0 )
	1172	; ^VA(200 10060
	1173	"RTN","VPR DJ04",12,0 )
	1174	; DIQ 2056
	1175	"RTN","VPR DJ04",13,0 )
	1176	; ICPTCOD 1995
	1177	"RTN","VPR DJ04",14,0 )
	1178	; PXAPI,^ TMP("PXKEN C",$J 1894
	1179	"RTN","VPR DJ04",15,0 )
	1180	; SDAMA30 1 4433
	1181	"RTN","VPR DJ04",16,0 )
	1182	; XLFDT 10103
	1183	"RTN","VPR DJ04",17,0 )
	1184	; XLFSTR 10104
	1185	"RTN","VPR DJ04",18,0 )
	1186	; XUAF4 2171
	1187	"RTN","VPR DJ04",19,0 )
	1188	;
	1189	"RTN","VPR DJ04",20,0 )
	1190	; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
	1191	"RTN","VPR DJ04",21,0 )
	1192	;
	1193	"RTN","VPR DJ04",22,0 )
	1194	SDAM1 ; -- appointme nt ^TMP($J ,"SDAMA301 ",DFN,VPRD T)
	1195	"RTN","VPR DJ04",23,0 )
	1196	N NODE,HL OC,APPT,X, STS,CLS,FA C,SV,PRV
	1197	"RTN","VPR DJ04",24,0 )
	1198	S NODE=$G (^TMP($J," SDAMA301", DFN,VPRDT) )
	1199	"RTN","VPR DJ04",25,0 )
	1200	;
	1201	"RTN","VPR DJ04",26,0 )
	1202	S HLOC=$P (NODE,U,2) ,X="A;"_VP RDT_";"_+H LOC
	1203	"RTN","VPR DJ04",27,0 )
	1204	I $L($G(I D)),$P(ID, ";",1,3)'= X Q
	1205	"RTN","VPR DJ04",28,0 )
	1206	S APPT("l ocalId")=X ,APPT("uid ")=$$SETUI D^VPRUTILS ("appointm ent",DFN,X )
	1207	"RTN","VPR DJ04",29,0 )
	1208	S X=$P(NO DE,U,10),A PPT("typeC ode")=$P(X ,";"),APPT ("typeName ")=$P(X,"; ",2)
	1209	"RTN","VPR DJ04",30,0 )
	1210	S STS=$P( NODE,U,3), CLS=$S($E( STS)="I":" I",1:"O")
	1211	"RTN","VPR DJ04",31,0 )
	1212	S APPT("d ateTime")= $$JSONDT^V PRUTILS(VP RDT)
	1213	"RTN","VPR DJ04",32,0 )
	1214	S:$L($P(N ODE,U,6)) APPT("comm ent")=$P(N ODE,U,6)
	1215	"RTN","VPR DJ04",33,0 )
	1216	S:$P(NODE ,U,9) APPT ("checkIn" )=$$JSONDT ^VPRUTILS( $P(NODE,U, 9))
	1217	"RTN","VPR DJ04",34,0 )
	1218	S:$P(NODE ,U,11) APP T("checkOu t")=$$JSON DT^VPRUTIL S($P(NODE, U,11))
	1219	"RTN","VPR DJ04",35,0 )
	1220	I $L(ID," ;")>3 S AP PT("reason Name")=$P( ID,";",4), PRV=+$P(ID ,";",5) ;f rom SDAM e vent
	1221	"RTN","VPR DJ04",36,0 )
	1222	S FAC=$$F AC^VPRD(+H LOC) D FAC ILITY^VPRU TILS(FAC," APPT") I H LOC D
	1223	"RTN","VPR DJ04",37,0 )
	1224	. S APPT( "locationN ame")=$P(H LOC,";",2)
	1225	"RTN","VPR DJ04",38,0 )
	1226	. S APPT( "locationU id")=$$SET UID^VPRUTI LS("locati on",,+HLOC )
	1227	"RTN","VPR DJ04",39,0 )
	1228	. S X=$$A MIS^VPRDVS IT(+$P(NOD E,U,13))
	1229	"RTN","VPR DJ04",40,0 )
	1230	. S:$L(X) APPT("sto pCodeUid") ="urn:va:s top-code:" _$P(X,U),A PPT("stopC odeName")= $P(X,U,2)
	1231	"RTN","VPR DJ04",41,0 )
	1232	. S SV=$$ GET1^DIQ(4 4,+HLOC_", ",9.5,"I")
	1233	"RTN","VPR DJ04",42,0 )
	1234	. I SV S APPT("serv ice")=$$SE RV^VPRDSDA M(SV)
	1235	"RTN","VPR DJ04",43,0 )
	1236	. ;find d efault pro vider
	1237	"RTN","VPR DJ04",44,0 )
	1238	. S:'$G(P RV) PRV=+$ $GET1^DIQ( 44,+HLOC_" ,",16,"I") I 'PRV D
	1239	"RTN","VPR DJ04",45,0 )
	1240	.. N VPRP ,I,FIRST
	1241	"RTN","VPR DJ04",46,0 )
	1242	.. D GETS ^DIQ(44,+H LOC_",","2 600*","I", "VPRP")
	1243	"RTN","VPR DJ04",47,0 )
	1244	.. S FIRS T=$O(VPRP( 44.1,"")), I=""
	1245	"RTN","VPR DJ04",48,0 )
	1246	.. F S I =$O(VPRP(4 4.1,I)) Q: I="" I $G (VPRP(44.1 ,I,.02,"I" )) S PRV=$ G(VPRP(44. 1,I,.01,"I ")) Q
	1247	"RTN","VPR DJ04",49,0 )
	1248	.. I 'PRV ,FIRST S P RV=$G(VPRP (44.1,FIRS T,.01,"I") )
	1249	"RTN","VPR DJ04",50,0 )
	1250	I $G(PRV) S APPT("p roviders", 1,"provide rUid")=$$S ETUID^VPRU TILS("user ",,PRV),AP PT("provid ers",1,"pr oviderName ")=$P($G(^ VA(200,PRV ,0)),U)
	1251	"RTN","VPR DJ04",51,0 )
	1252	I $G(SV) S APPT("su mmary")="$ {"_APPT("s ervice")_" }:"_$P(HLO C,";",2)
	1253	"RTN","VPR DJ04",52,0 )
	1254	S APPT("p atientClas sCode")="u rn:va:pati ent-class: "_$S(CLS=" I":"IMP",1 :"AMB")
	1255	"RTN","VPR DJ04",53,0 )
	1256	S APPT("p atientClas sName")=$S (CLS="I":" Inpatient" ,1:"Ambula tory")
	1257	"RTN","VPR DJ04",54,0 )
	1258	S APPT("c ategoryCod e")="urn:v a:encounte r-category :OV",APPT( "categoryN ame")="Out patient Vi sit"
	1259	"RTN","VPR DJ04",55,0 )
	1260	S APPT("a ppointment Status")=$ P(STS,";", 2)
	1261	"RTN","VPR DJ04",56,0 )
	1262	D ADD^VPR DJ("APPT", "appointme nt")
	1263	"RTN","VPR DJ04",57,0 )
	1264	Q
	1265	"RTN","VPR DJ04",58,0 )
	1266	;
	1267	"RTN","VPR DJ04",59,0 )
	1268	DGS ; sche duled admi ssions [fr om APPOINT M^VPRDJ0]
	1269	"RTN","VPR DJ04",60,0 )
	1270	S VPRA=0 F S VPRA= $O(^DGS(41 .1,"B",DFN ,VPRA)) Q: VPRA<1 D Q:VPRI'<V PRMAX
	1271	"RTN","VPR DJ04",61,0 )
	1272	. S VPRX= $G(^DGS(41 .1,VPRA,0) )
	1273	"RTN","VPR DJ04",62,0 )
	1274	. I $L($G (ID)),+$P( ID,";",2)= +$P(VPRX,U ,2) D DGS1 (VPRA) Q
	1275	"RTN","VPR DJ04",63,0 )
	1276	. Q:$P(VP RX,U,13) Q:$P(VPRX, U,17) ;ca ncelled or admitted
	1277	"RTN","VPR DJ04",64,0 )
	1278	. S X=$P( VPRX,U,2) Q:X<VPRSTA RT!(X>VPRS TOP) ;out of date r ange
	1279	"RTN","VPR DJ04",65,0 )
	1280	. D DGS1( VPRA)
	1281	"RTN","VPR DJ04",66,0 )
	1282	Q
	1283	"RTN","VPR DJ04",67,0 )
	1284	;
	1285	"RTN","VPR DJ04",68,0 )
	1286	DGS1(IFN) ; -- sched uled admis sion
	1287	"RTN","VPR DJ04",69,0 )
	1288	N ADM,X0, DATE,HLOC, FAC,SV,X
	1289	"RTN","VPR DJ04",70,0 )
	1290	S X0=$G(^ DGS(41.1,+ $G(IFN),0) ) Q:X0="" ;deleted
	1291	"RTN","VPR DJ04",71,0 )
	1292	;
	1293	"RTN","VPR DJ04",72,0 )
	1294	S DATE=+$ P(X0,U,2), HLOC=+$G(^ DIC(42,+$P (X0,U,8),4 4))
	1295	"RTN","VPR DJ04",73,0 )
	1296	S X="H;"_ DATE,ADM(" localId")= X,ADM("uid ")=$$SETUI D^VPRUTILS ("appointm ent",DFN,X )
	1297	"RTN","VPR DJ04",74,0 )
	1298	S ADM("da teTime")=$ $JSONDT^VP RUTILS(DAT E)
	1299	"RTN","VPR DJ04",75,0 )
	1300	S FAC=$$F AC^VPRD(+H LOC) D FAC ILITY^VPRU TILS(FAC," ADM") I HL OC D
	1301	"RTN","VPR DJ04",76,0 )
	1302	. S HLOC= +HLOC_";"_ $P($G(^SC( +HLOC,0)), U)
	1303	"RTN","VPR DJ04",77,0 )
	1304	. S ADM(" uid")=ADM( "uid")_";" _+HLOC
	1305	"RTN","VPR DJ04",78,0 )
	1306	. S ADM(" locationNa me")=$P(HL OC,";",2)
	1307	"RTN","VPR DJ04",79,0 )
	1308	. S ADM(" locationUi d")=$$SETU ID^VPRUTIL S("locatio n",,+HLOC)
	1309	"RTN","VPR DJ04",80,0 )
	1310	. S X=$$G ET1^DIQ(44 ,+HLOC_"," ,8,"I"),X= $$AMIS^VPR DVSIT(X)
	1311	"RTN","VPR DJ04",81,0 )
	1312	. S:$L(X) ADM("stop CodeUid")= "urn:va:st op-code:"_ $P(X,U),AD M("stopCod eName")=$P (X,U,2)
	1313	"RTN","VPR DJ04",82,0 )
	1314	. S SV=$$ GET1^DIQ(4 4,+HLOC_", ",9.5,"I")
	1315	"RTN","VPR DJ04",83,0 )
	1316	. I SV S ADM("servi ce")=$$SER V^VPRDSDAM (SV)
	1317	"RTN","VPR DJ04",84,0 )
	1318	I $G(SV) S ADM("sum mary")="${ "_ADM("ser vice")_"}: "_$P(HLOC, ";",2)
	1319	"RTN","VPR DJ04",85,0 )
	1320	S X=+$P(X 0,U,5) I X D
	1321	"RTN","VPR DJ04",86,0 )
	1322	. S ADM(" providers" ,1,"provid erUid")=$$ SETUID^VPR UTILS("use r",,X)
	1323	"RTN","VPR DJ04",87,0 )
	1324	. S ADM(" providers" ,1,"provid erName")=$ P($G(^VA(2 00,X,0)),U )
	1325	"RTN","VPR DJ04",88,0 )
	1326	S ADM("pa tientClass Code")="ur n:va:patie nt-class:I MP",ADM("p atientClas sName")="I npatient"
	1327	"RTN","VPR DJ04",89,0 )
	1328	S ADM("ca tegoryCode ")="urn:va :encounter -category: AD",ADM("c ategoryNam e")="Admis sion"
	1329	"RTN","VPR DJ04",90,0 )
	1330	S ADM("ap pointmentS tatus")=$S ($P(X0,U,1 7):"ADMITT ED",$P(X0, U,13):"CAN CELLED",1: "SCHEDULED ")
	1331	"RTN","VPR DJ04",91,0 )
	1332	D ADD^VPR DJ("ADM"," appointmen t")
	1333	"RTN","VPR DJ04",92,0 )
	1334	Q
	1335	"RTN","VPR DJ04",93,0 )
	1336	;
	1337	"RTN","VPR DJ04",94,0 )
	1338	VSIT1(ID) ; -- visit
	1339	"RTN","VPR DJ04",95,0 )
	1340	N VST,X0, X15,X,FAC, LOC,CATG,A MIS,INPT,D A
	1341	"RTN","VPR DJ04",96,0 )
	1342	I $G(ID)? 1"H"1.N D ADM^VPRDJ0 4A(ID) Q
	1343	"RTN","VPR DJ04",97,0 )
	1344	D ENCEVEN T^PXAPI(ID )
	1345	"RTN","VPR DJ04",98,0 )
	1346	;
	1347	"RTN","VPR DJ04",99,0 )
	1348	S X0=$G(^ TMP("PXKEN C",$J,ID," VST",ID,0) ),X15=$G(^ (150))
	1349	"RTN","VPR DJ04",100, 0)
	1350	Q:$P(X15, U,3)'="P" Q:$P(X0,U ,12) ;Q:$ P(X0,U,7)= "E" ;prim ary, not h istorical or child
	1351	"RTN","VPR DJ04",101, 0)
	1352	I $P(X0,U ,7)="H" D ADM^VPRDJ0 4A(ID,+X0) Q
	1353	"RTN","VPR DJ04",102, 0)
	1354	S VST("lo calId")=ID ,VST("uid" )=$$SETUID ^VPRUTILS( "visit",DF N,ID)
	1355	"RTN","VPR DJ04",103, 0)
	1356	S VST("da teTime")=$ $JSONDT^VP RUTILS(+X0 )
	1357	"RTN","VPR DJ04",104, 0)
	1358	S:$P(X0,U ,18) VST(" checkOut") =$$JSONDT^ VPRUTILS($ P(X0,U,18) )
	1359	"RTN","VPR DJ04",105, 0)
	1360	S FAC=+$P (X0,U,6),C ATG=$P(X0, U,7),LOC=+ $P(X0,U,22 )
	1361	"RTN","VPR DJ04",106, 0)
	1362	S:FAC X=$ $STA^XUAF4 (FAC)_U_$P ($$NS^XUAF 4(FAC),U)
	1363	"RTN","VPR DJ04",107, 0)
	1364	S:'FAC X= $$FAC^VPRD (LOC) D FA CILITY^VPR UTILS(X,"V ST")
	1365	"RTN","VPR DJ04",108, 0)
	1366	S X=$S(CA TG="H":"AD ",CATG="C" :"CR",CATG ="T":"TC", CATG="N":" U",CATG="R ":"NH","D^ X"[CATG:"O ",1:"OV")
	1367	"RTN","VPR DJ04",109, 0)
	1368	S VST("ca tegoryCode ")="urn:va :encounter -category: "_X
	1369	"RTN","VPR DJ04",110, 0)
	1370	S VST("ca tegoryName ")=$S(X="A D":"Admiss ion",X="CR ":"Chart R eview",X=" TC":"Phone Contact", X="U":"Unk nown",X="N H":"Nursin g Home",X= "O":"Other ",1:"Outpa tient Visi t")
	1371	"RTN","VPR DJ04",111, 0)
	1372	S INPT=$P (X15,U,2) S:INPT="" INPT=$S("H ^I^R^D"[CA TG:1,1:0)
	1373	"RTN","VPR DJ04",112, 0)
	1374	S X=$$CPT ^VPRDVSIT( ID) S:X VS T("typeNam e")=$P($$C PT^ICPTCOD (X),U,3)
	1375	"RTN","VPR DJ04",113, 0)
	1376	I 'X S VS T("typeNam e")=$S('IN PT&LOC:$P( $G(^SC(LOC ,0)),U)_" VISIT",1:$ $CATG^VPRD VSIT(CATG) )
	1377	"RTN","VPR DJ04",114, 0)
	1378	S VST("pa tientClass Code")="ur n:va:patie nt-class:" _$S(INPT:" IMP",1:"AM B")
	1379	"RTN","VPR DJ04",115, 0)
	1380	S VST("pa tientClass Name")=$S( INPT:"Inpa tient",1:" Ambulatory ")
	1381	"RTN","VPR DJ04",116, 0)
	1382	S X=$P(X0 ,U,8) S:X AMIS=$$AMI S^VPRDVSIT (X) I LOC D
	1383	"RTN","VPR DJ04",117, 0)
	1384	. N L0 S L0=$G(^SC( LOC,0))
	1385	"RTN","VPR DJ04",118, 0)
	1386	. I 'X S AMIS=$$AMI S^VPRDVSIT ($P(L0,U,7 ))
	1387	"RTN","VPR DJ04",119, 0)
	1388	. S VST(" locationUi d")=$$SETU ID^VPRUTIL S("locatio n",,+LOC)
	1389	"RTN","VPR DJ04",120, 0)
	1390	. S VST(" locationNa me")=$P(L0 ,U)
	1391	"RTN","VPR DJ04",121, 0)
	1392	. S X=$$S ERV^VPRDVS IT($P(L0,U ,20)) Q:X= ""
	1393	"RTN","VPR DJ04",122, 0)
	1394	. S:$L(X) VST("serv ice")=X,VS T("summary ")="${"_VS T("service ")_"}:"_$P (L0,U)
	1395	"RTN","VPR DJ04",123, 0)
	1396	S:$D(AMIS ) VST("sto pCodeUid") ="urn:va:s top-code:" _$P(AMIS,U ),VST("sto pCodeName" )=$P(AMIS, U,2)
	1397	"RTN","VPR DJ04",124, 0)
	1398	S X=$$POV ^VPRDVSIT( ID) I $L(X ) D
	1399	"RTN","VPR DJ04",125, 0)
	1400	. N SYS S SYS=$P(X, U,3),SYS=$ $LOW^XLFST R(SYS)
	1401	"RTN","VPR DJ04",126, 0)
	1402	. S VST(" reasonUid" )=$$SETNCS ^VPRUTILS( SYS,$P(X,U )),VST("re asonName") =$P(X,U,2)
	1403	"RTN","VPR DJ04",127, 0)
	1404	; provide r(s)
	1405	"RTN","VPR DJ04",128, 0)
	1406	S DA=0 F S DA=$O(^ TMP("PXKEN C",$J,ID," PRV",DA)) Q:DA<1 S X0=$G(^(DA ,0)) D
	1407	"RTN","VPR DJ04",129, 0)
	1408	. I $P(X0 ,U,4)="P" D PROV("VS T",DA,+X0, "P",1) Q ;primary
	1409	"RTN","VPR DJ04",130, 0)
	1410	. D PROV( "VST",DA,+ X0,"S") ;secondary
	1411	"RTN","VPR DJ04",131, 0)
	1412	K ^TMP("P XKENC",$J, ID)
	1413	"RTN","VPR DJ04",132, 0)
	1414	; note(s)
	1415	"RTN","VPR DJ04",133, 0)
	1416	D TIU^VPR DJ04A(ID,. VST)
	1417	"RTN","VPR DJ04",134, 0)
	1418	D ADD^VPR DJ("VST"," visit")
	1419	"RTN","VPR DJ04",135, 0)
	1420	Q
	1421	"RTN","VPR DJ04",136, 0)
	1422	;
	1423	"RTN","VPR DJ04",137, 0)
	1424	PROV(ARR,I ,IEN,ROLE, PRIM) ; -- add provi ders
	1425	"RTN","VPR DJ04",138, 0)
	1426	S @ARR@(" providers" ,I,"provid erUid")=$$ SETUID^VPR UTILS("use r",,+IEN)
	1427	"RTN","VPR DJ04",139, 0)
	1428	S @ARR@(" providers" ,I,"provid erName")=$ P($G(^VA(2 00,+IEN,0) ),U)
	1429	"RTN","VPR DJ04",140, 0)
	1430	S @ARR@(" providers" ,I,"role") =ROLE
	1431	"RTN","VPR DJ04",141, 0)
	1432	S:$G(PRIM ) @ARR@("p roviders", I,"primary ")="true"
	1433	"RTN","VPR DJ04",142, 0)
	1434	Q
	1435	"RTN","VPR DJ04",143, 0)
	1436	;
	1437	"RTN","VPR DJ04",144, 0)
	1438	NAME(IEN) ; -- Retur n a string 'name' fo r the visi t
	1439	"RTN","VPR DJ04",145, 0)
	1440	N Y,X0,LO C,DATE
	1441	"RTN","VPR DJ04",146, 0)
	1442	S X0=$G(^ AUPNVSIT(+ $G(IEN),0) ),Y=""
	1443	"RTN","VPR DJ04",147, 0)
	1444	S DATE=+X 0,LOC=+$P( X0,U,22) S :LOC LOC=$ P($G(^SC(L OC,0)),U)_ " "
	1445	"RTN","VPR DJ04",148, 0)
	1446	S Y=LOC_$ $FMTE^XLFD T(DATE,"1D ") ;Mon DD , YYYY
	1447	"RTN","VPR DJ04",149, 0)
	1448	Q Y
	1449	"RTN","VPR DLRO")
	1450	0^1^B28036 256
	1451	"RTN","VPR DLRO",1,0)
	1452	VPRDLRO ;S LC/MKB -- Lab extrac t by order /panel ;8/ 2/11 15:2 9
	1453	"RTN","VPR DLRO",2,0)
	1454	;;1.0;VIR TUAL PATIE NT RECORD; 2,5,7; Sep 01, 20 11;Build 3
	1455	"RTN","VPR DLRO",3,0)
	1456	;;Per VHA Directive 2004-038, this rout ine should not be mo dified.
	1457	"RTN","VPR DLRO",4,0)
	1458	;
	1459	"RTN","VPR DLRO",5,0)
	1460	; Externa l Referenc es DBIA#
	1461	"RTN","VPR DLRO",6,0)
	1462	; ------- ---------- -- -----
	1463	"RTN","VPR DLRO",7,0)
	1464	; ^DPT 10035
	1465	"RTN","VPR DLRO",8,0)
	1466	; ^LAB(60 10054
	1467	"RTN","VPR DLRO",9,0)
	1468	; ^LR 525
	1469	"RTN","VPR DLRO",10,0 )
	1470	; ^ORD(10 0.98) 873
	1471	"RTN","VPR DLRO",11,0 )
	1472	; ^VA(200 ) 10060
	1473	"RTN","VPR DLRO",12,0 )
	1474	; DIQ 2056
	1475	"RTN","VPR DLRO",13,0 )
	1476	; LR7OR1, ^TMP("LRRR ",$J) 2503
	1477	"RTN","VPR DLRO",14,0 )
	1478	; LR7OU1 2955
	1479	"RTN","VPR DLRO",15,0 )
	1480	; LRPXAPI U 4246
	1481	"RTN","VPR DLRO",16,0 )
	1482	; ORQ1,^T MP("ORR",$ J) 3154
	1483	"RTN","VPR DLRO",17,0 )
	1484	; ORQ12,^ TMP("ORGOT IT",$J) 5704
	1485	"RTN","VPR DLRO",18,0 )
	1486	; ORX8 24 67,3071
	1487	"RTN","VPR DLRO",19,0 )
	1488	; XUAF4 2171
	1489	"RTN","VPR DLRO",20,0 )
	1490	;
	1491	"RTN","VPR DLRO",21,0 )
	1492	; ------- ----- Get data from VistA ---- --------
	1493	"RTN","VPR DLRO",22,0 )
	1494	;
	1495	"RTN","VPR DLRO",23,0 )
	1496	EN(DFN,BEG ,END,MAX,I FN) ; -- f ind a pati ent's lab orders
	1497	"RTN","VPR DLRO",24,0 )
	1498	N ORLIST, ORDG,ORFLG ,ORIGVIEW, ORDER,VPRN ,VPRITM,VP RCNT,LRDFN
	1499	"RTN","VPR DLRO",25,0 )
	1500	S DFN=+$G (DFN) Q:DF N<1 ;inva lid patien t
	1501	"RTN","VPR DLRO",26,0 )
	1502	S BEG=$G( BEG,141010 1),END=$G( END,414101 5),MAX=$G( MAX,9999)
	1503	"RTN","VPR DLRO",27,0 )
	1504	S LRDFN=$ G(^DPT(DFN ,"LR"))
	1505	"RTN","VPR DLRO",28,0 )
	1506	;
	1507	"RTN","VPR DLRO",29,0 )
	1508	; get one lab order 's results
	1509	"RTN","VPR DLRO",30,0 )
	1510	I $G(IFN) D G ENQ
	1511	"RTN","VPR DLRO",31,0 )
	1512	. N ORLST S ORLST=0 ,ORLIST=$H
	1513	"RTN","VPR DLRO",32,0 )
	1514	. S ORIGV IEW=2 ;get original view of or der
	1515	"RTN","VPR DLRO",33,0 )
	1516	. D GET^O RQ12(+IFN, ORLIST,1) S VPRN=ORL ST
	1517	"RTN","VPR DLRO",34,0 )
	1518	. D EN1(V PRN,.VPRIT M),XML(.VP RITM)
	1519	"RTN","VPR DLRO",35,0 )
	1520	. K ^TMP( "ORGOTIT", $J)
	1521	"RTN","VPR DLRO",36,0 )
	1522	;
	1523	"RTN","VPR DLRO",37,0 )
	1524	; get [al l] lab ord ers with r esults
	1525	"RTN","VPR DLRO",38,0 )
	1526	S ORDG=$G (FILTER("t ype"),"LAB "),ORDG=+$ O(^ORD(100 .98,"B",OR DG,0))
	1527	"RTN","VPR DLRO",39,0 )
	1528	S ORFLG=6 ;searc h by Relea sed Orders
	1529	"RTN","VPR DLRO",40,0 )
	1530	S ORIGVIE W=2 ;get o riginal vi ew of orde r
	1531	"RTN","VPR DLRO",41,0 )
	1532	D EN^ORQ1 (DFN_";DPT (",ORDG,OR FLG,,BEG,E ND,1) S VP RCNT=0
	1533	"RTN","VPR DLRO",42,0 )
	1534	S VPRN=0 F S VPRN= $O(^TMP("O RR",$J,ORL IST,VPRN)) Q:VPRN<1 S ORDER=$ G(^(VPRN)) D Q:VPRC NT'<MAX
	1535	"RTN","VPR DLRO",43,0 )
	1536	. I $P($P (ORDER,U), ";",2)>1 Q ;skip or der action s
	1537	"RTN","VPR DLRO",44,0 )
	1538	. I $P(OR DER,U,7)'= "comp" Q ;complet ed only -- want resu lts
	1539	"RTN","VPR DLRO",45,0 )
	1540	. K VPRIT M D EN1(VP RN,.VPRITM ) Q:'$D(VP RITM)
	1541	"RTN","VPR DLRO",46,0 )
	1542	. D XML(. VPRITM) S VPRCNT=VPR CNT+1
	1543	"RTN","VPR DLRO",47,0 )
	1544	ENQ ; end
	1545	"RTN","VPR DLRO",48,0 )
	1546	K ^TMP("O RR",$J),^T MP("VPRTEX T",$J),^TM P("LRRR",$ J,DFN)
	1547	"RTN","VPR DLRO",49,0 )
	1548	Q
	1549	"RTN","VPR DLRO",50,0 )
	1550	;
	1551	"RTN","VPR DLRO",51,0 )
	1552	EN1(NUM,OR D) ; -- re turn an or der in ORD ("attribut e")=value
	1553	"RTN","VPR DLRO",52,0 )
	1554	; from E N: expects ^TMP("ORR ",$J,ORLIS T,VPRN),LR DFN
	1555	"RTN","VPR DLRO",53,0 )
	1556	N ORPK,X0 ,IFN,OI,VP RSUB,VPRID T,LR0,X,I, VPRL,VPRT
	1557	"RTN","VPR DLRO",54,0 )
	1558	K ORD,^TM P("VPRTEXT ",$J)
	1559	"RTN","VPR DLRO",55,0 )
	1560	S X0=$G(^ TMP("ORR", $J,ORLIST, NUM)),IFN= +X0
	1561	"RTN","VPR DLRO",56,0 )
	1562	S ORPK=$$ PKGID^ORX8 (+IFN) Q:' ORPK
	1563	"RTN","VPR DLRO",57,0 )
	1564	S ORD("id ")=IFN,ORD ("labOrder ID")=ORPK
	1565	"RTN","VPR DLRO",58,0 )
	1566	S OI=$$OI ^ORX8(+IFN ),ORD("nam e")=$P(OI, U,2)
	1567	"RTN","VPR DLRO",59,0 )
	1568	S ORD("or der")=+IFN _U_$P(OI,U ,2)
	1569	"RTN","VPR DLRO",60,0 )
	1570	;
	1571	"RTN","VPR DLRO",61,0 )
	1572	K ^TMP("L RRR",$J,DF N) D RR^LR 7OR1(DFN,O RPK)
	1573	"RTN","VPR DLRO",62,0 )
	1574	S VPRSUB= $O(^TMP("L RRR",$J,DF N,"")) Q:V PRSUB="" Q:"CH^MI"' [VPRSUB
	1575	"RTN","VPR DLRO",63,0 )
	1576	S VPRIDT= $O(^TMP("L RRR",$J,DF N,VPRSUB,0 )) Q:VPRID T<1 Q:'$O (^(VPRIDT, 0))
	1577	"RTN","VPR DLRO",64,0 )
	1578	; I $G(ID ),$P(ID,"; ",1,3)'=$P ($P(X,U,3) ,";",1,3) Q ;single order/spe cimen
	1579	"RTN","VPR DLRO",65,0 )
	1580	S ORD("ty pe")=VPRSU B,ORD("sta tus")="com pleted"
	1581	"RTN","VPR DLRO",66,0 )
	1582	S ORD("co llected")= 9999999-VP RIDT
	1583	"RTN","VPR DLRO",67,0 )
	1584	S LR0=$G( ^LR(LRDFN, VPRSUB,VPR IDT,0))
	1585	"RTN","VPR DLRO",68,0 )
	1586	S X=$P(LR 0,U,3) I V PRSUB="MI" ,'X S ORD( "status")= "incomplet e"
	1587	"RTN","VPR DLRO",69,0 )
	1588	S ORD("re sulted")=X ,X=+$P(LR0 ,U,5) I X D ;specim en
	1589	"RTN","VPR DLRO",70,0 )
	1590	. N IENS, VPRY S IEN S=X_","
	1591	"RTN","VPR DLRO",71,0 )
	1592	. D GETS^ DIQ(61,IEN S,".01:2", ,"VPRY")
	1593	"RTN","VPR DLRO",72,0 )
	1594	. S ORD(" specimen") =$G(VPRY(6 1,IENS,2)) _U_$G(VPRY (61,IENS,. 01)) ;SNOM ED^name
	1595	"RTN","VPR DLRO",73,0 )
	1596	. S ORD(" sample")=$ $GET1^DIQ( 61,X_",",4 .1) ;name
	1597	"RTN","VPR DLRO",74,0 )
	1598	S ORD("gr oupName")= $P(LR0,U,6 ),X=+$P(LR 0,U,14)
	1599	"RTN","VPR DLRO",75,0 )
	1600	S:X ORD(" facility") =$$STA^XUA F4(X)_U_$P ($$NS^XUAF 4(X),U)
	1601	"RTN","VPR DLRO",76,0 )
	1602	I 'X S OR D("facilit y")=$$FAC^ VPRD ;loca l stn#^nam e
	1603	"RTN","VPR DLRO",77,0 )
	1604	S I=$S(VP RSUB="CH": 10,1:7),X= +$P(LR0,U, I)
	1605	"RTN","VPR DLRO",78,0 )
	1606	S:X ORD(" provider") =X_U_$P($G (^VA(200,X ,0)),U)_U_ $$PROVSPC^ VPRD(X)
	1607	"RTN","VPR DLRO",79,0 )
	1608	;
	1609	"RTN","VPR DLRO",80,0 )
	1610	K VPRT D EXPAND^LR7 OU1(+$P(OI ,U,3),.VPR T) ;get in dividual t ests
	1611	"RTN","VPR DLRO",81,0 )
	1612	S VPRL=0 F S VPRL= $O(^TMP("L RRR",$J,DF N,VPRSUB,V PRIDT,VPRL )) Q:VPRL< 1 S X=$G( ^(VPRL)) D
	1613	"RTN","VPR DLRO",82,0 )
	1614	. Q:'$D(V PRT(+X)) ;test not in order/p anel
	1615	"RTN","VPR DLRO",83,0 )
	1616	. S:VPRSU B="CH" ORD ("value",V PRL)=$$CH( X)
	1617	"RTN","VPR DLRO",84,0 )
	1618	. S:VPRSU B="MI" ORD ("value",V PRL)=$$MI( X)
	1619	"RTN","VPR DLRO",85,0 )
	1620	I $D(^TMP ("LRRR",$J ,DFN,VPRSU B,VPRIDT," N")) K CMM T M CMMT=^ ("N") S OR D("comment ")=$$STRIN G^VPRD(.CM MT)
	1621	"RTN","VPR DLRO",86,0 )
	1622	Q
	1623	"RTN","VPR DLRO",87,0 )
	1624	;
	1625	"RTN","VPR DLRO",88,0 )
	1626	CH(X0) ; - - return a Chemistry result as :
	1627	"RTN","VPR DLRO",89,0 )
	1628	; id^te st^result^ interpreta tion^units ^low^high^ loinc^vuid ^performin gLab
	1629	"RTN","VPR DLRO",90,0 )
	1630	; Expec ts X0=^TMP ("LRRR",$J ,DFN,"CH", VPRIDT,VPR L),LRDFN
	1631	"RTN","VPR DLRO",91,0 )
	1632	N P,X,Y,N ODE,LOINC
	1633	"RTN","VPR DLRO",92,0 )
	1634	S P=$$LRD N^LRPXAPIU (+X0) ;get LR node# for test
	1635	"RTN","VPR DLRO",93,0 )
	1636	S NODE=$G (^LR(LRDFN ,"CH",VPRI DT,P))
	1637	"RTN","VPR DLRO",94,0 )
	1638	S X=$P($G (^LAB(60,+ X0,0)),U)
	1639	"RTN","VPR DLRO",95,0 )
	1640	S Y="CH;" _VPRIDT_"; "_P_U_X_U_ $P(X0,U,2, 4)
	1641	"RTN","VPR DLRO",96,0 )
	1642	S X=$P(X0 ,U,5) I $L (X),X["-" S X=$TR(X, "- ","^"), $P(Y,U,6,7 )=X
	1643	"RTN","VPR DLRO",97,0 )
	1644	S X=$P($P (NODE,U,3) ,"!",3) S: X LOINC=$$ GET1^DIQ(9 5.3,X_",", .01)
	1645	"RTN","VPR DLRO",98,0 )
	1646	S:$G(LOIN C) $P(Y,U, 8,9)=LOINC _U_$$VUID^ VPRD(+LOIN C,95.3)
	1647	"RTN","VPR DLRO",99,0 )
	1648	S X=+$P(N ODE,U,9) S :X $P(Y,U, 10)=$$NAME ^XUAF4(X) ;performin g lab
	1649	"RTN","VPR DLRO",100, 0)
	1650	Q Y
	1651	"RTN","VPR DLRO",101, 0)
	1652	;
	1653	"RTN","VPR DLRO",102, 0)
	1654	MI(X0) ; - - return a Microbiol ogy result as:
	1655	"RTN","VPR DLRO",103, 0)
	1656	; id^te st^result^ interpreta tion^units
	1657	"RTN","VPR DLRO",104, 0)
	1658	; Expec ts X0=^TMP ("LRRR",$J ,DFN,"MI", VPRIDT,VPR L)
	1659	"RTN","VPR DLRO",105, 0)
	1660	N Y S Y=" "
	1661	"RTN","VPR DLRO",106, 0)
	1662	S:$L($P(X 0,U))>1 Y= "MI;"_VPRI DT_";"_VPR L_U_$P(X0, U,1,4)
	1663	"RTN","VPR DLRO",107, 0)
	1664	Q Y
	1665	"RTN","VPR DLRO",108, 0)
	1666	;
	1667	"RTN","VPR DLRO",109, 0)
	1668	; ------- ----- Retu rn data to middle ti er ------- -----
	1669	"RTN","VPR DLRO",110, 0)
	1670	;
	1671	"RTN","VPR DLRO",111, 0)
	1672	XML(LAB) ; -- Return result as XML in @V PR@(#)
	1673	"RTN","VPR DLRO",112, 0)
	1674	N ATT,X,Y ,I,J,P,NAM ES,TAG
	1675	"RTN","VPR DLRO",113, 0)
	1676	D ADD("<p anel>") S VPRTOTL=$G (VPRTOTL)+ 1
	1677	"RTN","VPR DLRO",114, 0)
	1678	S ATT="" F S ATT=$ O(LAB(ATT) ) Q:ATT="" D D:$L( Y) ADD(Y)
	1679	"RTN","VPR DLRO",115, 0)
	1680	. I $O(LA B(ATT,0)) D S Y="" Q
	1681	"RTN","VPR DLRO",116, 0)
	1682	.. D ADD( "<"_ATT_"s >")
	1683	"RTN","VPR DLRO",117, 0)
	1684	.. I ATT= "value" S NAMES="id^ test^resul t^interpre tation^uni ts^low^hig h^loinc^vu id^perform ingLab^Z"
	1685	"RTN","VPR DLRO",118, 0)
	1686	.. E S N AMES="code ^name^Z"
	1687	"RTN","VPR DLRO",119, 0)
	1688	.. S I=0 F S I=$O( LAB(ATT,I) ) Q:I<1 D
	1689	"RTN","VPR DLRO",120, 0)
	1690	... S X=$ G(LAB(ATT, I)),Y="<"_ ATT_" "_$$ LOOP_"/>" D ADD(Y)
	1691	"RTN","VPR DLRO",121, 0)
	1692	.. D ADD( "</"_ATT_" s>")
	1693	"RTN","VPR DLRO",122, 0)
	1694	. S X=$G( LAB(ATT)), Y="" Q:'$L (X)
	1695	"RTN","VPR DLRO",123, 0)
	1696	. I ATT=" comment" S Y="<"_ATT _" xml:spa ce='preser ve'>"_$$ES C^VPRD(X)_ "</"_ATT_" >" Q
	1697	"RTN","VPR DLRO",124, 0)
	1698	. I X'["^ " S Y="<"_ ATT_" valu e='"_$$ESC ^VPRD(X)_" ' />" Q
	1699	"RTN","VPR DLRO",125, 0)
	1700	. S NAMES ="code^nam e"_$S(ATT= "provider" :U_$$PROVT AGS^VPRD,1 :"")_"^Z"
	1701	"RTN","VPR DLRO",126, 0)
	1702	. I $L(X) >1 S Y="<" _ATT_" "_$ $LOOP_"/>"
	1703	"RTN","VPR DLRO",127, 0)
	1704	D ADD("</ panel>")
	1705	"RTN","VPR DLRO",128, 0)
	1706	Q
	1707	"RTN","VPR DLRO",129, 0)
	1708	;
	1709	"RTN","VPR DLRO",130, 0)
	1710	LOOP() ; - - build su b-items st ring from NAMES and X
	1711	"RTN","VPR DLRO",131, 0)
	1712	N STR,P,T AG S STR=" "
	1713	"RTN","VPR DLRO",132, 0)
	1714	F P=1:1 S TAG=$P(NA MES,U,P) Q :TAG="Z" I $L($P(X, U,P)) S ST R=STR_TAG_ "='"_$$ESC ^VPRD($P(X ,U,P))_"' "
	1715	"RTN","VPR DLRO",133, 0)
	1716	Q STR
	1717	"RTN","VPR DLRO",134, 0)
	1718	;
	1719	"RTN","VPR DLRO",135, 0)
	1720	ADD(X) ; - - Add a li ne @VPR@(n )=X
	1721	"RTN","VPR DLRO",136, 0)
	1722	S VPRI=$G (VPRI)+1
	1723	"RTN","VPR DLRO",137, 0)
	1724	S @VPR@(V PRI)=X
	1725	"RTN","VPR DLRO",138, 0)
	1726	Q
	1727	"RTN","VPR DPT")
	1728	0^4^B11453 5256
	1729	"RTN","VPR DPT",1,0)
	1730	VPRDPT ;SL C/MKB -- P atient dem ographics extract ;8 /11/11 15 :29
	1731	"RTN","VPR DPT",2,0)
	1732	;;1.0;VIR TUAL PATIE NT RECORD; *1,4,5,7 *;Sep 01, 2011;Build 3
	1733	"RTN","VPR DPT",3,0)
	1734	;;Per VHA Directive 2004-038, this rout ine should not be mo dified.
	1735	"RTN","VPR DPT",4,0)
	1736	;
	1737	"RTN","VPR DPT",5,0)
	1738	; Externa l Referenc es DBIA#
	1739	"RTN","VPR DPT",6,0)
	1740	; ------- ---------- -- -----
	1741	"RTN","VPR DPT",7,0)
	1742	; ^AUPNVS IT 2028
	1743	"RTN","VPR DPT",8,0)
	1744	; ^DGSL(3 8.1 767
	1745	"RTN","VPR DPT",9,0)
	1746	; ^DIC(4 10090
	1747	"RTN","VPR DPT",10,0)
	1748	; ^DIC(31 733
	1749	"RTN","VPR DPT",11,0)
	1750	; ^DIC(42 72 3,10039
	1751	"RTN","VPR DPT",12,0)
	1752	; ^DPT 3581,559 7,10035
	1753	"RTN","VPR DPT",13,0)
	1754	; ^VA(200 10060
	1755	"RTN","VPR DPT",14,0)
	1756	; DGCV 4156
	1757	"RTN","VPR DPT",15,0)
	1758	; DGMSTAP I 2716
	1759	"RTN","VPR DPT",16,0)
	1760	; DGNTAPI 3457
	1761	"RTN","VPR DPT",17,0)
	1762	; DGPFAPI 3860
	1763	"RTN","VPR DPT",18,0)
	1764	; DGRPDB 4807
	1765	"RTN","VPR DPT",19,0)
	1766	; DIC 2051
	1767	"RTN","VPR DPT",20,0)
	1768	; DILFD 2055
	1769	"RTN","VPR DPT",21,0)
	1770	; DIQ 2056
	1771	"RTN","VPR DPT",22,0)
	1772	; MPIF001 2701
	1773	"RTN","VPR DPT",23,0)
	1774	; SCAPMC 1916
	1775	"RTN","VPR DPT",24,0)
	1776	; SCAPMCA 2848
	1777	"RTN","VPR DPT",25,0)
	1778	; SDUTL3 1252
	1779	"RTN","VPR DPT",26,0)
	1780	; VADPT 10061
	1781	"RTN","VPR DPT",27,0)
	1782	; VAFCTFU 1 2990
	1783	"RTN","VPR DPT",28,0)
	1784	; VASITE 10112
	1785	"RTN","VPR DPT",29,0)
	1786	; XUAF4 2171
	1787	"RTN","VPR DPT",30,0)
	1788	;
	1789	"RTN","VPR DPT",31,0)
	1790	; ------- ----- Get data from VistA ---- --------
	1791	"RTN","VPR DPT",32,0)
	1792	;
	1793	"RTN","VPR DPT",33,0)
	1794	EN(DFN,BEG ,END,MAX,I D) ; -- fi nd current patient d emographic s
	1795	"RTN","VPR DPT",34,0)
	1796	; [BEG,EN D,MAX,ID n ot current ly used]
	1797	"RTN","VPR DPT",35,0)
	1798	S DFN=+$G (DFN) Q:DF N<1 ;inva lid patien t
	1799	"RTN","VPR DPT",36,0)
	1800	N PAT,SYS S SYS=$$S ITE^VASITE
	1801	"RTN","VPR DPT",37,0)
	1802	D DEM,SVC ,PRF,ATC,S UPP,ALIAS, FAC,INPT,P C
	1803	"RTN","VPR DPT",38,0)
	1804	I $D(PAT) >9 D XML(. PAT)
	1805	"RTN","VPR DPT",39,0)
	1806	Q
	1807	"RTN","VPR DPT",40,0)
	1808	;
	1809	"RTN","VPR DPT",41,0)
	1810	DEM ;-demo graphic da ta
	1811	"RTN","VPR DPT",42,0)
	1812	N VADM,VA ,VAERR,X
	1813	"RTN","VPR DPT",43,0)
	1814	S X=+$$GE TICN^MPIF0 01(DFN) S: X>1 PAT("i cn")=X
	1815	"RTN","VPR DPT",44,0)
	1816	D DEM^VAD PT S X=VAD M(1),PAT(" fullName") =X
	1817	"RTN","VPR DPT",45,0)
	1818	S PAT("fa milyName") =$P(X,",") ,PAT("give nNames")=$ P(X,",",2, 99)
	1819	"RTN","VPR DPT",46,0)
	1820	S PAT("ss n")=$P(VAD M(2),U),PA T("id")=DF N
	1821	"RTN","VPR DPT",47,0)
	1822	S:$D(VA(" BID")) PAT ("bid")=$E (X)_VA("BI D")
	1823	"RTN","VPR DPT",48,0)
	1824	S PAT("do b")=+$P($P (VADM(3),U ),".")
	1825	"RTN","VPR DPT",49,0)
	1826	S PAT("ge nder")=$P( VADM(5),U)
	1827	"RTN","VPR DPT",50,0)
	1828	S PAT("lr dfn")=+$G( ^DPT(DFN," LR"))
	1829	"RTN","VPR DPT",51,0)
	1830	S X=+$P($ P(VADM(6), U),".") S: X PAT("die d")=X
	1831	"RTN","VPR DPT",52,0)
	1832	S X=$$GET 1^DIQ(38.1 ,DFN_",",2 ,"I") S:$L (X) PAT("s ensitive") =X
	1833	"RTN","VPR DPT",53,0)
	1834	S X=+VADM (9) S:X PA T("religio n")=X
	1835	"RTN","VPR DPT",54,0)
	1836	S X=$P(VA DM(10),U,2 ) S:$L(X) PAT("marit alStatus") =$E(X)
	1837	"RTN","VPR DPT",55,0)
	1838	I VADM(11 ) D
	1839	"RTN","VPR DPT",56,0)
	1840	. N I S I =0
	1841	"RTN","VPR DPT",57,0)
	1842	. F S I= $O(VADM(11 ,I)) Q:I<1 S X=+VAD M(11,I),PA T("ethnici ty",X)=$$G ET1^DIQ(2. 06,X_","_D FN_",",".0 1:3")
	1843	"RTN","VPR DPT",58,0)
	1844	I VADM(12 ) D
	1845	"RTN","VPR DPT",59,0)
	1846	. N I S I =0
	1847	"RTN","VPR DPT",60,0)
	1848	. F S I= $O(VADM(12 ,I)) Q:I<1 S X=+VAD M(12,I),PA T("race",X )=$$GET1^D IQ(2.02,X_ ","_DFN_", ",".01:3")
	1849	"RTN","VPR DPT",61,0)
	1850	I $G(VADM (13)) D
	1851	"RTN","VPR DPT",62,0)
	1852	. N I S I =+$O(VADM( 13,0)),X=$ P($G(VADM( 13,I)),U,2 )
	1853	"RTN","VPR DPT",63,0)
	1854	. S I=$$F IND1^DIC(. 85,,"X",X)
	1855	"RTN","VPR DPT",64,0)
	1856	. S PAT(" language") =$$GET1^DI Q(.85,I_", ",.02)_U_X
	1857	"RTN","VPR DPT",65,0)
	1858	Q
	1859	"RTN","VPR DPT",66,0)
	1860	SVC ;-serv ice data
	1861	"RTN","VPR DPT",67,0)
	1862	N VAEL,VA SV,VAERR,X ,Y,I,AO,IR ,PGF,HNC,M ST,CV
	1863	"RTN","VPR DPT",68,0)
	1864	D 7^VADPT
	1865	"RTN","VPR DPT",69,0)
	1866	S PAT("ve teran")=VA EL(4)
	1867	"RTN","VPR DPT",70,0)
	1868	S PAT("sc ")=+VAEL(3 ) S:VAEL(3 ) PAT("scP ercent")=+ $P(VAEL(3) ,U,2)
	1869	"RTN","VPR DPT",71,0)
	1870	S:VAEL(2) PAT("serv icePeriod" )=$P(VAEL( 2),U,2)
	1871	"RTN","VPR DPT",72,0)
	1872	I VAEL(1) D
	1873	"RTN","VPR DPT",73,0)
	1874	. S PAT(" eligibilit y",+VAEL(1 ))=$P(VAEL (1),U,2)_" ^1",I=0
	1875	"RTN","VPR DPT",74,0)
	1876	. F S I= $O(VAEL(1, I)) Q:I<1 S PAT("el igibility" ,I)=$P(VAE L(1,I),U,2 )
	1877	"RTN","VPR DPT",75,0)
	1878	S:$L(VAEL (8)) PAT(" eligibilit yStatus")= $P(VAEL(8) ,U,2)
	1879	"RTN","VPR DPT",76,0)
	1880	S:$L(VAEL (9)) PAT(" meansTest" )=$P(VAEL( 9),U,2)
	1881	"RTN","VPR DPT",77,0)
	1882	;
	1883	"RTN","VPR DPT",78,0)
	1884	; exposur es
	1885	"RTN","VPR DPT",79,0)
	1886	S AO=VASV (2),IR=VAS V(3)
	1887	"RTN","VPR DPT",80,0)
	1888	S PGF=VAS V(11)!VASV (12)!VASV( 13) ;OIF/O EF
	1889	"RTN","VPR DPT",81,0)
	1890	S X=$$GET CUR^DGNTAP I(DFN,"HNC "),X=+($G( HNC("STAT" )))
	1891	"RTN","VPR DPT",82,0)
	1892	S HNC=$S( X=4:1,X=5: 1,X=1:0,X= 6:0,1:"")
	1893	"RTN","VPR DPT",83,0)
	1894	S X=$P($$ GETSTAT^DG MSTAPI(DFN ),U,2),MST =$S(X="Y": 1,X="N":0, 1:"")
	1895	"RTN","VPR DPT",84,0)
	1896	S X=$$CVE DT^DGCV(DF N),CV=$S(+ X<0:"",+X= 0:0,$P(X,U ,3):1,1:0)
	1897	"RTN","VPR DPT",85,0)
	1898	S PAT("ex posures")= AO_U_IR_U_ PGF_U_HNC_ U_MST_U_CV
	1899	"RTN","VPR DPT",86,0)
	1900	;
	1901	"RTN","VPR DPT",87,0)
	1902	; rated d isabilitie s [DGRPDB]
	1903	"RTN","VPR DPT",88,0)
	1904	N VPRDIS, DIS,NM,DX
	1905	"RTN","VPR DPT",89,0)
	1906	D RDIS^DG RPDB(DFN,. VPRDIS)
	1907	"RTN","VPR DPT",90,0)
	1908	S I=0 F S I=$O(VPR DIS(I)) Q: I<1 D
	1909	"RTN","VPR DPT",91,0)
	1910	. S DIS=V PRDIS(I)
	1911	"RTN","VPR DPT",92,0)
	1912	. S NM=$$ GET1^DIQ(3 1,+DIS_"," ,.01),DX=$ $GET1^DIQ( 31,+DIS_", ",2)
	1913	"RTN","VPR DPT",93,0)
	1914	. S PAT(" disability ",+DX)=NM_ U_$P(DIS,U ,3)_U_$P(D IS,U,2) ;n ame^sc^%
	1915	"RTN","VPR DPT",94,0)
	1916	Q
	1917	"RTN","VPR DPT",95,0)
	1918	PRF ;-pati ent record flags
	1919	"RTN","VPR DPT",96,0)
	1920	N VPRPF,I ,NAME,TEXT
	1921	"RTN","VPR DPT",97,0)
	1922	Q:'$$GETA CT^DGPFAPI (DFN,"VPRP F")
	1923	"RTN","VPR DPT",98,0)
	1924	S I=0 F S I=$O(VPR PF(I)) Q:I <1 D
	1925	"RTN","VPR DPT",99,0)
	1926	. S NAME= $P(VPRPF(I ,"FLAG"),U ,2)
	1927	"RTN","VPR DPT",100,0 )
	1928	. M TEXT= VPRPF(I,"N ARR")
	1929	"RTN","VPR DPT",101,0 )
	1930	. S PAT(" flag",I)=N AME_U_$$ST RING^VPRD( .TEXT)
	1931	"RTN","VPR DPT",102,0 )
	1932	Q
	1933	"RTN","VPR DPT",103,0 )
	1934	ATC ;-addr ess & tele com
	1935	"RTN","VPR DPT",104,0 )
	1936	N VAPA,I, X
	1937	"RTN","VPR DPT",105,0 )
	1938	S VAPA("P ")="" D AD D^VADPT ;p ermanent a ddress
	1939	"RTN","VPR DPT",106,0 )
	1940	S X="" F I=1:1:4 S X=X_VAPA(I )_U
	1941	"RTN","VPR DPT",107,0 )
	1942	S X=X_$P( VAPA(5),U, 2)_U_$P(VA PA(11),U,2 )
	1943	"RTN","VPR DPT",108,0 )
	1944	S PAT("ad dress")=X ;street1^s t2^st3^cit y^state^zi p
	1945	"RTN","VPR DPT",109,0 )
	1946	S X=$$FOR MAT(VAPA(8 ))_U_$$FOR MAT($$GET1 ^DIQ(2,DFN _",",.134) )_U_$$FORM AT($$GET1^ DIQ(2,DFN_ ",",.132))
	1947	"RTN","VPR DPT",110,0 )
	1948	S PAT("te lecom")=X ;home^cell ^work phon es
	1949	"RTN","VPR DPT",111,0 )
	1950	Q
	1951	"RTN","VPR DPT",112,0 )
	1952	SUPP ;-sup port conta cts
	1953	"RTN","VPR DPT",113,0 )
	1954	N VAOA,A, I,X,TYPE
	1955	"RTN","VPR DPT",114,0 )
	1956	F A="",1 K VAOA D
	1957	"RTN","VPR DPT",115,0 )
	1958	. S:A VAO A("A")=A D OAD^VADPT Q:'$L($G( VAOA(9)))
	1959	"RTN","VPR DPT",116,0 )
	1960	. S TYPE= $S(A=1:"EC ON",1:"NOK ")
	1961	"RTN","VPR DPT",117,0 )
	1962	. S PAT(" support",T YPE)=VAOA( 9)_U_VAOA( 10) ;name^ relationsh ip
	1963	"RTN","VPR DPT",118,0 )
	1964	. S X="" F I=1:1:4 S X=X_VAOA (I)_U
	1965	"RTN","VPR DPT",119,0 )
	1966	. S X=X_$ P(VAOA(5), U,2)_U_$P( VAOA(11),U ,2)
	1967	"RTN","VPR DPT",120,0 )
	1968	. S PAT(" support",T YPE,"addre ss")=X ;st reet1^st2^ st3^city^s tate^zip
	1969	"RTN","VPR DPT",121,0 )
	1970	. S I=$S( A=1:.33011 ,1:.21011) ,X=$$FORMA T(VAOA(8)) _U_U_$$FOR MAT($$GET1 ^DIQ(2,DFN _",",I))
	1971	"RTN","VPR DPT",122,0 )
	1972	. S PAT(" support",T YPE,"telec om")=X ;ho me^cell^wo rk phones
	1973	"RTN","VPR DPT",123,0 )
	1974	Q
	1975	"RTN","VPR DPT",124,0 )
	1976	ALIAS ;-ot her names used
	1977	"RTN","VPR DPT",125,0 )
	1978	N I,X
	1979	"RTN","VPR DPT",126,0 )
	1980	S I=0 F S I=$O(^DP T(DFN,.01, I)) Q:I<1 S X=$P($G (^(I,0)),U ) D
	1981	"RTN","VPR DPT",127,0 )
	1982	. S PAT(" alias",I)= X_U_$P(X," ,")_U_$P(X ,",",2,99)
	1983	"RTN","VPR DPT",128,0 )
	1984	Q
	1985	"RTN","VPR DPT",129,0 )
	1986	FORMAT(X) ; -- enfor ce (xxx)xx x-xxxx pho ne format
	1987	"RTN","VPR DPT",130,0 )
	1988	S X=$G(X) I X?1"("3 N1")"3N1"- "4N.E Q X
	1989	"RTN","VPR DPT",131,0 )
	1990	N P,N,I,Y S P=""
	1991	"RTN","VPR DPT",132,0 )
	1992	F I=1:1:$ L(X) S N=$ E(X,I) I N =+N S P=P_ N
	1993	"RTN","VPR DPT",133,0 )
	1994	S:$L(P)<1 0 P=$E("00 00000000", 1,10-$L(P) )_P
	1995	"RTN","VPR DPT",134,0 )
	1996	S Y=$S(P: "("_$E(P,1 ,3)_")"_$E (P,4,6)_"- "_$E(P,7,1 0),1:"")
	1997	"RTN","VPR DPT",135,0 )
	1998	Q Y
	1999	"RTN","VPR DPT",136,0 )
	2000	FAC ;-trea ting facil ities [see FACLIST^O RWCIRN]
	2001	"RTN","VPR DPT",137,0 )
	2002	N IFN S D FN=+$G(DFN ) Q:DFN<1
	2003	"RTN","VPR DPT",138,0 )
	2004	N VPRY,HO ME,LAST,I, X,IEN
	2005	"RTN","VPR DPT",139,0 )
	2006	I $L($T(T FL^VAFCTFU 1)) D TFL^ VAFCTFU1(. VPRY,DFN)
	2007	"RTN","VPR DPT",140,0 )
	2008	S HOME=+$ P($G(^DPT( DFN,"MPI") ),U,3) ;ho me facilit y
	2009	"RTN","VPR DPT",141,0 )
	2010	I $P($G(V PRY(1)),U) <0 D Q ; not setup
	2011	"RTN","VPR DPT",142,0 )
	2012	. S X=$O( ^AUPNVSIT( "AA",DFN,0 )),LAST=$S (X:9999999 -$P(X,".") ,1:"")
	2013	"RTN","VPR DPT",143,0 )
	2014	. S X=$$S ITE^VASITE
	2015	"RTN","VPR DPT",144,0 )
	2016	. S PAT(" facility", +X)=$P(X,U ,3)_U_$P(X ,U,2)_U_LA ST_U_$$GET 1^DIQ(4,+X _",",60)
	2017	"RTN","VPR DPT",145,0 )
	2018	S I=0 F S I=$O(VPR Y(I)) Q:I< 1 D
	2019	"RTN","VPR DPT",146,0 )
	2020	. S X=VPR Y(I) Q:$P( X,U)="" ; unknown
	2021	"RTN","VPR DPT",147,0 )
	2022	. S IEN=+ $$IEN^XUAF 4($P(X,U))
	2023	"RTN","VPR DPT",148,0 )
	2024	. I +X=77 6!(+X=200) S $P(X,U, 2)="DEPT. OF DEFENSE "
	2025	"RTN","VPR DPT",149,0 )
	2026	. S PAT(" facility", IEN)=$P(X, U,1,2)_U_$ P($P(X,U,3 ),".")
	2027	"RTN","VPR DPT",150,0 )
	2028	. ; = stn # ^ name ^ last date ^ VistA d omain
	2029	"RTN","VPR DPT",151,0 )
	2030	. S $P(PA T("facilit y",IEN),U, 4)=$$GET1^ DIQ(4,IEN_ ",",60)
	2031	"RTN","VPR DPT",152,0 )
	2032	. I IEN=H OME S $P(P AT("facili ty",IEN),U ,5)=1
	2033	"RTN","VPR DPT",153,0 )
	2034	Q
	2035	"RTN","VPR DPT",154,0 )
	2036	INPT ;-cur rent inpt status
	2037	"RTN","VPR DPT",155,0 )
	2038	N ADM,X,V AIN,VAERR, HLOC,SVC
	2039	"RTN","VPR DPT",156,0 )
	2040	S ADM=+$G (^DPT(DFN, .105)) I A DM D
	2041	"RTN","VPR DPT",157,0 )
	2042	. D INP^V ADPT S PAT ("admitted ")=ADM_U_+ VAIN(7)
	2043	"RTN","VPR DPT",158,0 )
	2044	. S PAT(" ward")=VAI N(4),PAT(" roomBed")= VAIN(5)
	2045	"RTN","VPR DPT",159,0 )
	2046	. S HLOC= +$G(^DIC(4 2,+VAIN(4) ,44)),SVC= $P($G(^(0) ),U,3)
	2047	"RTN","VPR DPT",160,0 )
	2048	. S PAT(" location") =HLOC_U_$P (VAIN(4),U ,2)
	2049	"RTN","VPR DPT",161,0 )
	2050	. S:$L(SV C) PAT("lo cSvc")=SVC _U_$$EXTER NAL^DILFD( 42,.03,,SV C)
	2051	"RTN","VPR DPT",162,0 )
	2052	. S PAT(" specialty" )=VAIN(3)
	2053	"RTN","VPR DPT",163,0 )
	2054	. S PAT(" attending" )=VAIN(11)
	2055	"RTN","VPR DPT",164,0 )
	2056	. S X=$$F AC^VPRD(HL OC),PAT("s ite")=X
	2057	"RTN","VPR DPT",165,0 )
	2058	S PAT("in patient")= $S(ADM:"tr ue",1:"fal se")
	2059	"RTN","VPR DPT",166,0 )
	2060	Q
	2061	"RTN","VPR DPT",167,0 )
	2062	ZPC ;-prim ary care [ not used: GETALL not returning team memb ers]
	2063	"RTN","VPR DPT",168,0 )
	2064	N TEAM,VP RPC,VPRI,V PRTM,PCPR, FAC,X,ST
	2065	"RTN","VPR DPT",169,0 )
	2066	S TEAM=$$ INSTPCTM^S CAPMC(DFN) Q:'TEAM ;teamIEN^n ame^instIE N^name
	2067	"RTN","VPR DPT",170,0 )
	2068	S PAT("pc Team")=$P( TEAM,U,1,2 )
	2069	"RTN","VPR DPT",171,0 )
	2070	D GETALL^ SCAPMCA(DF N,,.VPRPC)
	2071	"RTN","VPR DPT",172,0 )
	2072	S VPRI=+$ O(@VPRPC@( DFN,"TM",+ TEAM,0)),V PRTM=$G(^( VPRI))
	2073	"RTN","VPR DPT",173,0 )
	2074	S:$P(VPRT M,U,4) PAT ("pcAssign ed")=$P(VP RTM,U,4)
	2075	"RTN","VPR DPT",174,0 )
	2076	S PCPR=$G (@VPRPC@(D FN,"PCPR", 1)) I PCPR D
	2077	"RTN","VPR DPT",175,0 )
	2078	. S PAT(" pcProvider ")=$P(PCPR ,U,1,2)_U_ $$PROVSPC^ VPRD(+PCPR )
	2079	"RTN","VPR DPT",176,0 )
	2080	. S FAC=$ P(TEAM,U,3 ,4) S:FAC< 1 FAC=$$SI TE^VASITE
	2081	"RTN","VPR DPT",177,0 )
	2082	. S X=$$P ADD^XUAF4( +FAC) ;str eet^city^s t^zip
	2083	"RTN","VPR DPT",178,0 )
	2084	. S ST=$$ GET1^DIQ(4 ,+FAC_",", .02) S:ST= "" ST=$P(X ,U,3) ;get state nam e
	2085	"RTN","VPR DPT",179,0 )
	2086	. S PAT(" pcProvider ","address ")=$P(X,U) _"^^^"_$P( X,U,2)_U_S T_U_$P(X,U ,4)
	2087	"RTN","VPR DPT",180,0 )
	2088	; get tea m members
	2089	"RTN","VPR DPT",181,0 )
	2090	S VPRI=0 F S VPRI= $O(@VPRPC@ (DFN,"TM", +VPRTM,+$P (VPRTM,U,3 ),"POS",VP RI)) Q:VPR I<1 I +$G (^(VPRI))' =$P(PCPR,U ,3) D
	2091	"RTN","VPR DPT",182,0 )
	2092	. S I=+$O (@VPRPC@(D FN,"TM",+V PRTM,+$P(V PRTM,U,3), "POS",VPRI ,"PROV",0) ),X=$G(^(I )) Q:X=""
	2093	"RTN","VPR DPT",183,0 )
	2094	. S POS=$ S($L($P(X, U,8)):$P(X ,U,8),1:$P (X,U,4))
	2095	"RTN","VPR DPT",184,0 )
	2096	. S PAT(" pcTeamMemb er",I)=$P( X,U,1,2)_U _POS_U_$$P ROVSPC^VPR D(+X)
	2097	"RTN","VPR DPT",185,0 )
	2098	K @VPRPC
	2099	"RTN","VPR DPT",186,0 )
	2100	Q
	2101	"RTN","VPR DPT",187,0 )
	2102	;
	2103	"RTN","VPR DPT",188,0 )
	2104	PC ;-prima ry care
	2105	"RTN","VPR DPT",189,0 )
	2106	N TEAM,X, VPRT,PRV,P OS,FAC,ST, I
	2107	"RTN","VPR DPT",190,0 )
	2108	S TEAM=$$ INSTPCTM^S CAPMC(DFN) I TEAM D ;PC teamI EN^name^in stIEN^name
	2109	"RTN","VPR DPT",191,0 )
	2110	. S PAT(" pcTeam")=$ P(TEAM,U,1 ,2)
	2111	"RTN","VPR DPT",192,0 )
	2112	. S X=$$T MPT^SCAPMC (DFN,,,.VP RT) I X S I=0 F S I =$O(@VPRT@ (I)) Q:I<1 I +$G(@V PRT@(I))=+ TEAM S PAT ("pcAssign ed")=$P(@V PRT@(I),U, 4) Q
	2113	"RTN","VPR DPT",193,0 )
	2114	. K @VPRT ,VPRT,X
	2115	"RTN","VPR DPT",194,0 )
	2116	. S X=$$P RTM^SCAPMC (+TEAM,,,, .VPRT) Q:' X
	2117	"RTN","VPR DPT",195,0 )
	2118	. S (I,PR V)=0 F S PRV=+$O(@V PRT@("SCPR ",PRV)) Q: PRV<1 D
	2119	"RTN","VPR DPT",196,0 )
	2120	.. S POS= $O(@VPRT@( "SCPR",PRV ,0))
	2121	"RTN","VPR DPT",197,0 )
	2122	.. S X=PR V_U_$P($G( ^VA(200,PR V,0)),U)
	2123	"RTN","VPR DPT",198,0 )
	2124	.. S POS= $$GET1^DIQ (404.57,PO S_",",.01)
	2125	"RTN","VPR DPT",199,0 )
	2126	.. S I=I+ 1,PAT("pcT eamMember" ,I)=X_U_PO S_U_$$PROV SPC^VPRD(+ X)
	2127	"RTN","VPR DPT",200,0 )
	2128	. K @VPRT ,VPRT,X
	2129	"RTN","VPR DPT",201,0 )
	2130	S X=$$OUT PTPR^SDUTL 3(DFN) I X D
	2131	"RTN","VPR DPT",202,0 )
	2132	. S PAT(" pcProvider ")=X_U_$$P ROVSPC^VPR D(+X)
	2133	"RTN","VPR DPT",203,0 )
	2134	. S FAC=$ P(TEAM,U,3 ,4) S:FAC< 1 FAC=$$SI TE^VASITE
	2135	"RTN","VPR DPT",204,0 )
	2136	. S X=$$P ADD^XUAF4( +FAC) ;str eet^city^s t^zip
	2137	"RTN","VPR DPT",205,0 )
	2138	. S ST=$$ GET1^DIQ(4 ,+FAC_",", .02) S:ST= "" ST=$P(X ,U,3) ;get state nam e
	2139	"RTN","VPR DPT",206,0 )
	2140	. S PAT(" pcProvider ","address ")=$P(X,U) _"^^^"_$P( X,U,2)_U_S T_U_$P(X,U ,4)
	2141	"RTN","VPR DPT",207,0 )
	2142	Q
	2143	"RTN","VPR DPT",208,0 )
	2144	;
	2145	"RTN","VPR DPT",209,0 )
	2146	; ------- ----- Retu rn data to middle ti er ------- -----
	2147	"RTN","VPR DPT",210,0 )
	2148	;
	2149	"RTN","VPR DPT",211,0 )
	2150	XML(ITEM) ; -- Retur n patient data as XM L in @VPR@ (n)
	2151	"RTN","VPR DPT",212,0 )
	2152	; as <ele ment code= '123' disp layName='A BC' />
	2153	"RTN","VPR DPT",213,0 )
	2154	N ATT,X,Y ,NAMES,I,I D
	2155	"RTN","VPR DPT",214,0 )
	2156	D ADD("<p atient>") S VPRTOTL= $G(VPRTOTL )+1
	2157	"RTN","VPR DPT",215,0 )
	2158	S ATT="" F S ATT=$ O(ITEM(ATT )) Q:ATT=" " D D:$L (Y) ADD(Y)
	2159	"RTN","VPR DPT",216,0 )
	2160	. S X=$G( ITEM(ATT)) ,NAMES=$$L ABELS(ATT) ,Y=""
	2161	"RTN","VPR DPT",217,0 )
	2162	. I ATT=" pcProvider " D Q
	2163	"RTN","VPR DPT",218,0 )
	2164	.. S Y="< "_ATT_" "_ $$LOOP_">" D ADD(Y)
	2165	"RTN","VPR DPT",219,0 )
	2166	.. S X=$G (ITEM(ATT, "address") ) I $L(X) D ADDR(X)
	2167	"RTN","VPR DPT",220,0 )
	2168	.. D ADD( "</"_ATT_" >") S Y=""
	2169	"RTN","VPR DPT",221,0 )
	2170	. ;
	2171	"RTN","VPR DPT",222,0 )
	2172	. I $L($O (ITEM(ATT, ""))) D Q ;multipl es
	2173	"RTN","VPR DPT",223,0 )
	2174	.. S ID=$ S($E(ATT,$ L(ATT))="s ":ATT_"es" ,$E(ATT,$L (ATT))="y" :$E(ATT,1, $L(ATT)-1) _"ies",1:A TT_"s")
	2175	"RTN","VPR DPT",224,0 )
	2176	.. D ADD( "<"_ID_">" )
	2177	"RTN","VPR DPT",225,0 )
	2178	.. S I="" F S I=$O (ITEM(ATT, I)) Q:I="" D
	2179	"RTN","VPR DPT",226,0 )
	2180	... S X=I TEM(ATT,I) ,Y="<"_ATT _" "
	2181	"RTN","VPR DPT",227,0 )
	2182	... I ATT ="support" D S Y="" Q
	2183	"RTN","VPR DPT",228,0 )
	2184	.... S Y= Y_"contact Type='"_I_ "' "_$$LOO P_">" D AD D(Y)
	2185	"RTN","VPR DPT",229,0 )
	2186	.... S X= $G(ITEM(AT T,I,"addre ss")) I $L (X) D ADDR (X)
	2187	"RTN","VPR DPT",230,0 )
	2188	.... S X= $G(ITEM(AT T,I,"telec om")) I $L (X) D PHON E(X)
	2189	"RTN","VPR DPT",231,0 )
	2190	.... D AD D("</suppo rt>")
	2191	"RTN","VPR DPT",232,0 )
	2192	... I ATT ="disabili ty" S Y=Y_ "vaCode='" _I_"' "
	2193	"RTN","VPR DPT",233,0 )
	2194	... S Y=Y _$$LOOP_"/ >" D ADD(Y )
	2195	"RTN","VPR DPT",234,0 )
	2196	.. D ADD( "</"_ID_"> ") S Y=""
	2197	"RTN","VPR DPT",235,0 )
	2198	. ;
	2199	"RTN","VPR DPT",236,0 )
	2200	. I ATT=" exposures" D:X["1" S Y="" Q
	2201	"RTN","VPR DPT",237,0 )
	2202	.. S I=0, Y="<exposu res>" D AD D(Y)
	2203	"RTN","VPR DPT",238,0 )
	2204	.. F ID=" AO","IR"," PG","HNC", "MST","CV" S I=I+1 I $P(X,U,I) S Y="<exp osure valu e='"_ID_"' />" D ADD (Y)
	2205	"RTN","VPR DPT",239,0 )
	2206	.. D ADD( "</exposur es>")
	2207	"RTN","VPR DPT",240,0 )
	2208	. ;
	2209	"RTN","VPR DPT",241,0 )
	2210	. I ATT=" address" D ADDR(X) S Y="" Q
	2211	"RTN","VPR DPT",242,0 )
	2212	. I ATT=" telecom" D PHONE(X) S Y="" Q
	2213	"RTN","VPR DPT",243,0 )
	2214	. ;
	2215	"RTN","VPR DPT",244,0 )
	2216	. Q:X="" ;no data
	2217	"RTN","VPR DPT",245,0 )
	2218	. I X'["^ " S Y="<"_ ATT_" valu e='"_$$ESC ^VPRD(X)_" ' />" Q
	2219	"RTN","VPR DPT",246,0 )
	2220	. I $L(X) >1 S Y="<" _ATT_" "_$ $LOOP_"/>"
	2221	"RTN","VPR DPT",247,0 )
	2222	D ADD("</ patient>")
	2223	"RTN","VPR DPT",248,0 )
	2224	Q
	2225	"RTN","VPR DPT",249,0 )
	2226	;
	2227	"RTN","VPR DPT",250,0 )
	2228	ADDR(X) ; -- XML add ress node from X=str eet1^st2^s t3^city^st ate^zip
	2229	"RTN","VPR DPT",251,0 )
	2230	N I,Y Q:$ L(X)'>5 ; no data
	2231	"RTN","VPR DPT",252,0 )
	2232	S Y="<add ress"
	2233	"RTN","VPR DPT",253,0 )
	2234	F I=1,2,3 I $L($P(X ,U,I)) S Y =Y_" stree tLine"_I_" ='"_$$ESC^ VPRD($P(X, U,I))_"'"
	2235	"RTN","VPR DPT",254,0 )
	2236	I $L($P(X ,U,4)) S Y =Y_" city= '"_$$ESC^V PRD($P(X,U ,4))_"'"
	2237	"RTN","VPR DPT",255,0 )
	2238	I $L($P(X ,U,5)) S Y =Y_" state Province=' "_$P(X,U,5 )_"'"
	2239	"RTN","VPR DPT",256,0 )
	2240	I $L($P(X ,U,6)) S Y =Y_" posta lCode='"_$ P(X,U,6)_" '"
	2241	"RTN","VPR DPT",257,0 )
	2242	S Y=Y_" / >" D ADD(Y )
	2243	"RTN","VPR DPT",258,0 )
	2244	Q
	2245	"RTN","VPR DPT",259,0 )
	2246	;
	2247	"RTN","VPR DPT",260,0 )
	2248	PHONE(X) ; -- XML te lecom node from X=ho me^cell^wo rk numbers
	2249	"RTN","VPR DPT",261,0 )
	2250	N I,Y Q:$ L(X)'>2 ; no data
	2251	"RTN","VPR DPT",262,0 )
	2252	D ADD("<t elecomList >")
	2253	"RTN","VPR DPT",263,0 )
	2254	I $L($P(X ,U,1)) S Y ="<telecom usageType ='H' value ='"_$P(X,U ,1)_"' />" D ADD(Y)
	2255	"RTN","VPR DPT",264,0 )
	2256	I $L($P(X ,U,2)) S Y ="<telecom usageType ='MC' valu e='"_$P(X, U,2)_"' /> " D ADD(Y)
	2257	"RTN","VPR DPT",265,0 )
	2258	I $L($P(X ,U,3)) S Y ="<telecom usageType ='WP' valu e='"_$P(X, U,3)_"' /> " D ADD(Y)
	2259	"RTN","VPR DPT",266,0 )
	2260	D ADD("</ telecomLis t>")
	2261	"RTN","VPR DPT",267,0 )
	2262	Q
	2263	"RTN","VPR DPT",268,0 )
	2264	;
	2265	"RTN","VPR DPT",269,0 )
	2266	LOOP() ; - - build su b-items st ring from NAMES and X
	2267	"RTN","VPR DPT",270,0 )
	2268	N STR,P,T AG S STR=" "
	2269	"RTN","VPR DPT",271,0 )
	2270	F P=1:1 S TAG=$P(NA MES,U,P) Q :TAG="Z" I $L($P(X, U,P)) S ST R=STR_TAG_ "='"_$$ESC ^VPRD($P(X ,U,P))_"' "
	2271	"RTN","VPR DPT",272,0 )
	2272	Q STR
	2273	"RTN","VPR DPT",273,0 )
	2274	;
	2275	"RTN","VPR DPT",274,0 )
	2276	ADD(X) ; A dd a line @VPR@(n)=X
	2277	"RTN","VPR DPT",275,0 )
	2278	S VPRI=$G (VPRI)+1
	2279	"RTN","VPR DPT",276,0 )
	2280	S @VPR@(V PRI)=X
	2281	"RTN","VPR DPT",277,0 )
	2282	Q
	2283	"RTN","VPR DPT",278,0 )
	2284	;
	2285	"RTN","VPR DPT",279,0 )
	2286	LABELS(X) ; -- retur n string o f attribut e labels f or element X
	2287	"RTN","VPR DPT",280,0 )
	2288	N Y S Y=" code^name^ Z"
	2289	"RTN","VPR DPT",281,0 )
	2290	I X="pcPr ovider" S Y="code^na me^"_$$PRO VTAGS^VPRD _"^Z"
	2291	"RTN","VPR DPT",282,0 )
	2292	I X="supp ort" S Y=" name^relat ionship^Z"
	2293	"RTN","VPR DPT",283,0 )
	2294	I X="elig ibility" S Y="name^p rimary^Z"
	2295	"RTN","VPR DPT",284,0 )
	2296	I X="disa bility" S Y="printNa me^sc^scPe rcent^Z"
	2297	"RTN","VPR DPT",285,0 )
	2298	I X="alia s" S Y="fu llName^fam ilyName^gi venNames^Z "
	2299	"RTN","VPR DPT",286,0 )
	2300	I X="flag " S Y="nam e^text^Z"
	2301	"RTN","VPR DPT",287,0 )
	2302	I X="faci lity" S Y= "code^name ^latestDat e^domain^h omeSite^Z"
	2303	"RTN","VPR DPT",288,0 )
	2304	I X="pcTe amMember" S Y="code^ name^role^ "_$$PROVTA GS^VPRD_"^ Z"
	2305	"RTN","VPR DPT",289,0 )
	2306	I X="ethn icity"!(X= "race") S Y="value^Z "
	2307	"RTN","VPR DPT",290,0 )
	2308	I X="admi tted" S Y= "id^date^Z "
	2309	"RTN","VPR DPT",291,0 )
	2310	Q Y
	2311	"RTN","VPR DVSIT")
	2312	0^2^B10602 4378
	2313	"RTN","VPR DVSIT",1,0 )
	2314	VPRDVSIT ; SLC/MKB -- Visit/Enc ounter ext ract ;8/2/ 11 15:29
	2315	"RTN","VPR DVSIT",2,0 )
	2316	;;1.0;VIR TUAL PATIE NT RECORD; 1,2,4,5, 7;Sep 01 , 2011;Bui ld 3
	2317	"RTN","VPR DVSIT",3,0 )
	2318	;;Per VHA Directive 2004-038, this rout ine should not be mo dified.
	2319	"RTN","VPR DVSIT",4,0 )
	2320	;
	2321	"RTN","VPR DVSIT",5,0 )
	2322	; Externa l Referenc es DBIA#
	2323	"RTN","VPR DVSIT",6,0 )
	2324	; ------- ---------- -- -----
	2325	"RTN","VPR DVSIT",7,0 )
	2326	; ^AUPNVS IT 2028
	2327	"RTN","VPR DVSIT",8,0 )
	2328	; ^DIC(40 .7 557
	2329	"RTN","VPR DVSIT",9,0 )
	2330	; ^DIC(42 10039
	2331	"RTN","VPR DVSIT",10, 0)
	2332	; ^DIC(45 .7 1154
	2333	"RTN","VPR DVSIT",11, 0)
	2334	; ^DPT( 10035
	2335	"RTN","VPR DVSIT",12, 0)
	2336	; ^SC 10040
	2337	"RTN","VPR DVSIT",13, 0)
	2338	; ^VA(200 10060
	2339	"RTN","VPR DVSIT",14, 0)
	2340	; DGPTFAP I 3157
	2341	"RTN","VPR DVSIT",15, 0)
	2342	; DIC 2051
	2343	"RTN","VPR DVSIT",16, 0)
	2344	; DILFD 2055
	2345	"RTN","VPR DVSIT",17, 0)
	2346	; DIQ 2056
	2347	"RTN","VPR DVSIT",18, 0)
	2348	; ICDEX 5747
	2349	"RTN","VPR DVSIT",19, 0)
	2350	; ICPTCOD 1995
	2351	"RTN","VPR DVSIT",20, 0)
	2352	; PXAPI,^ TMP("PXKEN C",$J 1894
	2353	"RTN","VPR DVSIT",21, 0)
	2354	; SDOE 2546
	2355	"RTN","VPR DVSIT",22, 0)
	2356	; VADPT 10061
	2357	"RTN","VPR DVSIT",23, 0)
	2358	; VADPT2 325
	2359	"RTN","VPR DVSIT",24, 0)
	2360	; XUAF4 2171
	2361	"RTN","VPR DVSIT",25, 0)
	2362	;
	2363	"RTN","VPR DVSIT",26, 0)
	2364	; ------- ----- Get encounter( s) from Vi stA ------ ------
	2365	"RTN","VPR DVSIT",27, 0)
	2366	;
	2367	"RTN","VPR DVSIT",28, 0)
	2368	EN(DFN,BEG ,END,MAX,I D) ; -- fi nd patient 's visits and appoin tments
	2369	"RTN","VPR DVSIT",29, 0)
	2370	N VPRCNT, VPRITM,VPR DT,VPRLOC, VPRDA
	2371	"RTN","VPR DVSIT",30, 0)
	2372	S DFN=+$G (DFN) Q:DF N<1
	2373	"RTN","VPR DVSIT",31, 0)
	2374	S BEG=$G( BEG,141010 1),END=$G( END,414101 5),MAX=$G( MAX,9999)
	2375	"RTN","VPR DVSIT",32, 0)
	2376	;
	2377	"RTN","VPR DVSIT",33, 0)
	2378	; get one visit
	2379	"RTN","VPR DVSIT",34, 0)
	2380	I $G(ID) D EN1(ID,. VPRITM),XM L(.VPRITM) G ENQ
	2381	"RTN","VPR DVSIT",35, 0)
	2382	;
	2383	"RTN","VPR DVSIT",36, 0)
	2384	; -- get all visits
	2385	"RTN","VPR DVSIT",37, 0)
	2386	I END,END '["." S EN D=END_".24 " ;assume end of day
	2387	"RTN","VPR DVSIT",38, 0)
	2388	S VPRCNT= 0
	2389	"RTN","VPR DVSIT",39, 0)
	2390	;F S IDX =$Q(@IDX,- 1) Q:DFN'= $P(IDX,"," ,2) Q:$P( IDX,",",3) <BEG I $P (IDX,",",5 )["P" D
	2391	"RTN","VPR DVSIT",40, 0)
	2392	S VPRDT=E ND F S VP RDT=$O(^AU PNVSIT("AE T",DFN,VPR DT),-1) Q :VPRDT<BEG D Q:VPR CNT'<MAX
	2393	"RTN","VPR DVSIT",41, 0)
	2394	. S VPRLO C=0 F S V PRLOC=$O(^ AUPNVSIT(" AET",DFN,V PRDT,VPRLO C)) Q:VPRL OC<1 D
	2395	"RTN","VPR DVSIT",42, 0)
	2396	.. S VPRD A=0 F S V PRDA=$O(^A UPNVSIT("A ET",DFN,VP RDT,VPRLOC ,"P",VPRDA )) Q:VPRDA <1 D
	2397	"RTN","VPR DVSIT",43, 0)
	2398	... K VPR ITM D EN1( VPRDA,.VPR ITM) Q:'$D (VPRITM)
	2399	"RTN","VPR DVSIT",44, 0)
	2400	... D XML (.VPRITM) S VPRCNT=V PRCNT+1
	2401	"RTN","VPR DVSIT",45, 0)
	2402	ENQ ; end
	2403	"RTN","VPR DVSIT",46, 0)
	2404	K ^TMP("V PRTEXT",$J )
	2405	"RTN","VPR DVSIT",47, 0)
	2406	Q
	2407	"RTN","VPR DVSIT",48, 0)
	2408	;
	2409	"RTN","VPR DVSIT",49, 0)
	2410	ENAA(DFN,B EG,END,MAX ,ID) ; -- find patie nt's visit s and appo intments [ AA]
	2411	"RTN","VPR DVSIT",50, 0)
	2412	N IDT,DA, VPRCNT,VPR ITM
	2413	"RTN","VPR DVSIT",51, 0)
	2414	S DFN=+$G (DFN) Q:DF N<1
	2415	"RTN","VPR DVSIT",52, 0)
	2416	S BEG=$G( BEG,141010 1),END=$G( END,414101 5),MAX=$G( MAX,9999)
	2417	"RTN","VPR DVSIT",53, 0)
	2418	I $G(ID) D EN1(ID,. VPRITM),XM L(.VPRITM) Q ;one v isit
	2419	"RTN","VPR DVSIT",54, 0)
	2420	D IDT S V PRCNT=0
	2421	"RTN","VPR DVSIT",55, 0)
	2422	S IDT=BEG F S IDT= $O(^AUPNVS IT("AA",DF N,IDT)) Q: IDT<1!(IDT >END) D Q:VPRCNT'< MAX
	2423	"RTN","VPR DVSIT",56, 0)
	2424	. S DA=0 F S DA=$O (^AUPNVSIT ("AA",DFN, IDT,DA)) Q :DA<1 D
	2425	"RTN","VPR DVSIT",57, 0)
	2426	.. K VPRI TM D EN1(D A,.VPRITM) Q:'$D(VPR ITM)
	2427	"RTN","VPR DVSIT",58, 0)
	2428	.. D XML( .VPRITM) S VPRCNT=VP RCNT+1
	2429	"RTN","VPR DVSIT",59, 0)
	2430	Q
	2431	"RTN","VPR DVSIT",60, 0)
	2432	IDT ; -- i nvert BEG and END da tes for vi sit format :
	2433	"RTN","VPR DVSIT",61, 0)
	2434	; IDT=(9 999999-$P( VDT,"."))_ "."_$P(VDT ,".",2)
	2435	"RTN","VPR DVSIT",62, 0)
	2436	N X S X=B EG
	2437	"RTN","VPR DVSIT",63, 0)
	2438	S BEG=(99 99999-$P(E ND,"."))
	2439	"RTN","VPR DVSIT",64, 0)
	2440	S END=(99 99999-$P(X ,"."))_".2 359"
	2441	"RTN","VPR DVSIT",65, 0)
	2442	Q
	2443	"RTN","VPR DVSIT",66, 0)
	2444	;
	2445	"RTN","VPR DVSIT",67, 0)
	2446	EN1(IEN,VS T) ; -- re turn a vis it in VST( "attribute ")=value
	2447	"RTN","VPR DVSIT",68, 0)
	2448	N X0,X15, X,DATE,FAC ,LOC,CATG, INPT,DA
	2449	"RTN","VPR DVSIT",69, 0)
	2450	K VST,^TM P("VPRTEXT ",$J)
	2451	"RTN","VPR DVSIT",70, 0)
	2452	S IEN=+$G (IEN) Q:IE N<1 ;inva lid
	2453	"RTN","VPR DVSIT",71, 0)
	2454	D ENCEVEN T^PXAPI(IE N)
	2455	"RTN","VPR DVSIT",72, 0)
	2456	S X0=$G(^ TMP("PXKEN C",$J,IEN, "VST",IEN, 0)),X15=$G (^(150))
	2457	"RTN","VPR DVSIT",73, 0)
	2458	Q:$P(X15, U,3)'="P" ;Q:$P(X0, U,7)="E" ;want prim ary, not h istorical
	2459	"RTN","VPR DVSIT",74, 0)
	2460	I $P(X0,U ,7)="H" D ADM(IEN,+X 0,.VST) Q
	2461	"RTN","VPR DVSIT",75, 0)
	2462	S VST("id ")=IEN,VST ("dateTime ")=+X0,DAT E=+X0
	2463	"RTN","VPR DVSIT",76, 0)
	2464	S FAC=+$P (X0,U,6),C ATG=$P(X0, U,7),LOC=+ $P(X0,U,22 )
	2465	"RTN","VPR DVSIT",77, 0)
	2466	S:FAC VST ("facility ")=$$STA^X UAF4(FAC)_ U_$P($$NS^ XUAF4(FAC) ,U)
	2467	"RTN","VPR DVSIT",78, 0)
	2468	S:'FAC VS T("facilit y")=$$FAC^ VPRD(LOC)
	2469	"RTN","VPR DVSIT",79, 0)
	2470	S VST("se rviceCateg ory")=CATG _U_$$CATG( CATG)
	2471	"RTN","VPR DVSIT",80, 0)
	2472	S VST("vi sitString" )=LOC_";"_ DATE_";"_C ATG
	2473	"RTN","VPR DVSIT",81, 0)
	2474	S INPT=$P (X15,U,2) S:INPT="" INPT=$S("H ^I^R^D"[CA TG:1,1:0)
	2475	"RTN","VPR DVSIT",82, 0)
	2476	S X=$$CPT (IEN) S:X VST("type" )=$P($$CPT ^ICPTCOD(X ),U,2,3)
	2477	"RTN","VPR DVSIT",83, 0)
	2478	I 'X S VS T("type")= U_$S('INPT &LOC:$P($G (^SC(LOC,0 )),U)_" VI SIT",1:$$C ATG(CATG))
	2479	"RTN","VPR DVSIT",84, 0)
	2480	S VST("pa tientClass ")=$S(INPT :"IMP",1:" AMB")
	2481	"RTN","VPR DVSIT",85, 0)
	2482	S:INPT VS T("admissi on")=$$ADM VT(DATE) ; get relate d mvt# if inpt visit /data
	2483	"RTN","VPR DVSIT",86, 0)
	2484	S X=$P(X0 ,U,8) S:X VST("stopC ode")=$$AM IS(X) I LO C D
	2485	"RTN","VPR DVSIT",87, 0)
	2486	. N L0 S L0=$G(^SC( LOC,0))
	2487	"RTN","VPR DVSIT",88, 0)
	2488	. I 'X S VST("stopC ode")=$$AM IS($P(L0,U ,7))
	2489	"RTN","VPR DVSIT",89, 0)
	2490	. S VST(" location") =$P(L0,U), VST("servi ce")=$$SER V($P(L0,U, 20))
	2491	"RTN","VPR DVSIT",90, 0)
	2492	. S X=$P( L0,U,18) S :X VST("cr editStopCo de")=$$AMI S(X)
	2493	"RTN","VPR DVSIT",91, 0)
	2494	S VST("re ason")=$$P OV(IEN,DAT E)
	2495	"RTN","VPR DVSIT",92, 0)
	2496	; provide r(s), incl uding taxo nomy/speci alty info
	2497	"RTN","VPR DVSIT",93, 0)
	2498	S DA=0 F S DA=$O(^ TMP("PXKEN C",$J,IEN, "PRV",DA)) Q:DA<1 S X0=$G(^(D A,0)) D
	2499	"RTN","VPR DVSIT",94, 0)
	2500	. S VST(" provider", DA)=+X0_U_ $P($G(^VA( 200,+X0,0) ),U)_$S($P (X0,U,4)=" P":"^P^1", 1:"^S^")_U _$$PROVSPC ^VPRD(+X0)
	2501	"RTN","VPR DVSIT",95, 0)
	2502	; cpt(s)
	2503	"RTN","VPR DVSIT",96, 0)
	2504	S DA=0 F S DA=$O(^ TMP("PXKEN C",$J,IEN, "CPT",DA)) Q:DA<1 S X0=$G(^(D A,0)) D
	2505	"RTN","VPR DVSIT",97, 0)
	2506	. S VST(" cpt",DA)=$ P($$CPT^IC PTCOD(+X0) ,U,2,3)
	2507	"RTN","VPR DVSIT",98, 0)
	2508	; icd(s)
	2509	"RTN","VPR DVSIT",99, 0)
	2510	S DA=0 F S DA=$O(^ TMP("PXKEN C",$J,IEN, "POV",DA)) Q:DA<1 S X0=$G(^(D A,0)) D
	2511	"RTN","VPR DVSIT",100 ,0)
	2512	. S VST(" icd",DA)=$ $ICD(+X0,D ATE)_U_$$E XTERNAL^DI LFD(900001 0.07,.04,, $P(X0,U,4) )_U_$S($L( $P(X0,U,12 )):$P(X0,U ,12),1:"U" )
	2513	"RTN","VPR DVSIT",101 ,0)
	2514	; note(s)
	2515	"RTN","VPR DVSIT",102 ,0)
	2516	D TIU(IEN )
	2517	"RTN","VPR DVSIT",103 ,0)
	2518	K ^TMP("P XKENC",$J, IEN)
	2519	"RTN","VPR DVSIT",104 ,0)
	2520	Q
	2521	"RTN","VPR DVSIT",105 ,0)
	2522	;
	2523	"RTN","VPR DVSIT",106 ,0)
	2524	TIU(VISIT) ; -- add notes to V ST("docume nt")
	2525	"RTN","VPR DVSIT",107 ,0)
	2526	N X,Y,I,V PRX,LT,NT, DA,CNT,VPR Y
	2527	"RTN","VPR DVSIT",108 ,0)
	2528	D FIND^DI C(8925,,.0 1,"QX",+$G (VISIT),," V",,,"VPRX ")
	2529	"RTN","VPR DVSIT",109 ,0)
	2530	S Y="",(I ,CNT)=0
	2531	"RTN","VPR DVSIT",110 ,0)
	2532	F S I=$O (VPRX("DIL IST",1,I)) Q:I<1 D
	2533	"RTN","VPR DVSIT",111 ,0)
	2534	. S DA=$G (VPRX("DIL IST",2,I))
	2535	"RTN","VPR DVSIT",112 ,0)
	2536	. S Y=$$I NFO^VPRDTI U(+DA) Q:Y <1 ;draft or retrac ted
	2537	"RTN","VPR DVSIT",113 ,0)
	2538	. S CNT=C NT+1,VST(" document", CNT)=Y
	2539	"RTN","VPR DVSIT",114 ,0)
	2540	. S:$G(VP RTEXT) VST ("document ",CNT,"con tent")=$$T EXT^VPRDTI U(DA)
	2541	"RTN","VPR DVSIT",115 ,0)
	2542	Q
	2543	"RTN","VPR DVSIT",116 ,0)
	2544	;
	2545	"RTN","VPR DVSIT",117 ,0)
	2546	POV(VISIT, VDT) ; -- return the primary P urpose of Visit as I CD^Provide rNarrative
	2547	"RTN","VPR DVSIT",118 ,0)
	2548	N DA,Y,X, X0,ICD S Y =""
	2549	"RTN","VPR DVSIT",119 ,0)
	2550	S DA=0 F S DA=$O(^ TMP("PXKEN C",$J,VISI T,"POV",DA )) Q:DA<1 S X0=$G(^ (DA,0)) I $P(X0,U,12 )="P" D Q :$L(Y)
	2551	"RTN","VPR DVSIT",120 ,0)
	2552	. S X=+$P (X0,U,4),I CD=$$ICD(+ X0,$G(VDT) )
	2553	"RTN","VPR DVSIT",121 ,0)
	2554	. S Y=ICD _U_$$EXTER NAL^DILFD( 9000010.07 ,.04,,X)
	2555	"RTN","VPR DVSIT",122 ,0)
	2556	Q Y
	2557	"RTN","VPR DVSIT",123 ,0)
	2558	;
	2559	"RTN","VPR DVSIT",124 ,0)
	2560	ICD(IEN,DA TE) ; -- r eturn code ^descripti on^system for ICD co de, or "^^ " if error
	2561	"RTN","VPR DVSIT",125 ,0)
	2562	N X0,VPRX ,N,I,X,Y
	2563	"RTN","VPR DVSIT",126 ,0)
	2564	S IEN=+$G (IEN),DATE =+$G(DATE, DT)
	2565	"RTN","VPR DVSIT",127 ,0)
	2566	S Y=$$COD EC^ICDEX(8 0,IEN),X=$ $VLTD^ICDE X(IEN,DATE )
	2567	"RTN","VPR DVSIT",128 ,0)
	2568	I $L(X) S Y=Y_U_X
	2569	"RTN","VPR DVSIT",129 ,0)
	2570	E S Y=Y_ U_$$VSTD^I CDEX(IEN,D ATE)
	2571	"RTN","VPR DVSIT",130 ,0)
	2572	S X=$$CSI ^ICDEX(80, IEN),$P(Y, U,3)=$$SAB ^ICDEX(X)
	2573	"RTN","VPR DVSIT",131 ,0)
	2574	Q Y
	2575	"RTN","VPR DVSIT",132 ,0)
	2576	;
	2577	"RTN","VPR DVSIT",133 ,0)
	2578	CPT(VISIT) ; -- Retu rn CPT cod e of encou nter type
	2579	"RTN","VPR DVSIT",134 ,0)
	2580	N DA,Y,X, X0 S Y=""
	2581	"RTN","VPR DVSIT",135 ,0)
	2582	S DA=0 F S DA=$O(^ TMP("PXKEN C",$J,VISI T,"CPT",DA )) Q:DA<1 S X0=$G(^ (DA,0)) D Q:$L(Y)
	2583	"RTN","VPR DVSIT",136 ,0)
	2584	. S X=$P( X0,U) I X? 1"992"2N S Y=X Q
	2585	"RTN","VPR DVSIT",137 ,0)
	2586	Q Y
	2587	"RTN","VPR DVSIT",138 ,0)
	2588	;
	2589	"RTN","VPR DVSIT",139 ,0)
	2590	AMIS(X) ; -- return the AMIS c ode^name o f Credit S top X
	2591	"RTN","VPR DVSIT",140 ,0)
	2592	N Y,X0 S Y=""
	2593	"RTN","VPR DVSIT",141 ,0)
	2594	S X0=$G(^ DIC(40.7,+ $G(X),0)) S:$L(X0) Y =$P(X0,U,2 )_U_$P(X0, U)
	2595	"RTN","VPR DVSIT",142 ,0)
	2596	Q Y
	2597	"RTN","VPR DVSIT",143 ,0)
	2598	;
	2599	"RTN","VPR DVSIT",144 ,0)
	2600	CATG(X) ; -- Return name of vi sit Servic e Category code X
	2601	"RTN","VPR DVSIT",145 ,0)
	2602	N Y S Y=" "
	2603	"RTN","VPR DVSIT",146 ,0)
	2604	I X="A" S Y="AMBULA TORY"
	2605	"RTN","VPR DVSIT",147 ,0)
	2606	I X="H" S Y="HOSPIT ALIZATION"
	2607	"RTN","VPR DVSIT",148 ,0)
	2608	I X="I" S Y="IN HOS PITAL"
	2609	"RTN","VPR DVSIT",149 ,0)
	2610	I X="C" S Y="CHART REVIEW"
	2611	"RTN","VPR DVSIT",150 ,0)
	2612	I X="T" S Y="TELECO MMUNICATIO NS"
	2613	"RTN","VPR DVSIT",151 ,0)
	2614	I X="N" S Y="NOT FO UND"
	2615	"RTN","VPR DVSIT",152 ,0)
	2616	I X="S" S Y="DAY SU RGERY"
	2617	"RTN","VPR DVSIT",153 ,0)
	2618	I X="O" S Y="OBSERV ATION"
	2619	"RTN","VPR DVSIT",154 ,0)
	2620	I X="E" S Y="EVENT (HISTORICA L)"
	2621	"RTN","VPR DVSIT",155 ,0)
	2622	I X="R" S Y="NURSIN G HOME"
	2623	"RTN","VPR DVSIT",156 ,0)
	2624	I X="D" S Y="DAILY HOSPITALIZ ATION DATA "
	2625	"RTN","VPR DVSIT",157 ,0)
	2626	I X="X" S Y="ANCILL ARY PACKAG E DAILY DA TA"
	2627	"RTN","VPR DVSIT",158 ,0)
	2628	Q Y
	2629	"RTN","VPR DVSIT",159 ,0)
	2630	;
	2631	"RTN","VPR DVSIT",160 ,0)
	2632	SERV(FTS) ; -- Retur n #42.4 Se rvice for a Facility Treating Specialty
	2633	"RTN","VPR DVSIT",161 ,0)
	2634	N Y S Y=" ",FTS=+$G( FTS)
	2635	"RTN","VPR DVSIT",162 ,0)
	2636	S Y=$$GET 1^DIQ(45.7 ,FTS_","," 1:3","E")
	2637	"RTN","VPR DVSIT",163 ,0)
	2638	Q Y
	2639	"RTN","VPR DVSIT",164 ,0)
	2640	;
	2641	"RTN","VPR DVSIT",165 ,0)
	2642	ADMVT( D NS T) ; -- re turn movem ent# for r elated adm ission
	2643	"RTN","VPR DVSIT",166 ,0)
	2644	N VADMVT, VAERR
	2645	"RTN","VPR DVSIT",167 ,0)
	2646	D ADM^VAD PT2
	2647	"RTN","VPR DVSIT",168 ,0)
	2648	Q VADMVT
	2649	"RTN","VPR DVSIT",169 ,0)
	2650	;
	2651	"RTN","VPR DVSIT",170 ,0)
	2652	ADM(IEN,DA TE,ADM) ; -- return an admissi on in ADM( "attribute ")=value
	2653	"RTN","VPR DVSIT",171 ,0)
	2654	N D NS T,VADMVT,V AIP,VAIN,V AERR,HLOC, ICD,I K AD M
	2655	"RTN","VPR DVSIT",172 ,0)
	2656	S IEN=+$G (IEN),DATE =+$G(DATE) Q:IEN<1 Q:DATE<1
	2657	"RTN","VPR DVSIT",173 ,0)
	2658	S D NS T=DATE D A DM^VADPT2 Q:VADMVT<1
	2659	"RTN","VPR DVSIT",174 ,0)
	2660	I VADMVT= $G(^DPT(DF N,.105)) D INPT Q ; current in patient
	2661	"RTN","VPR DVSIT",175 ,0)
	2662	S VAIP("E ")=VADMVT D IN5^VADP T Q:'$G(VA IP(1)) ;d eleted
	2663	"RTN","VPR DVSIT",176 ,0)
	2664	S ADM("id ")=IEN,ADM ("patientC lass")="IM P",ADM("ad mission")= $G(VAIP(13 ))
	2665	"RTN","VPR DVSIT",177 ,0)
	2666	; ADM("ad mitType")= $P($G(VAIP (4)),U,2)
	2667	"RTN","VPR DVSIT",178 ,0)
	2668	S DATE=+$ G(VAIP(13, 1)),(ADM(" dateTime") ,ADM("arri valDateTim e"))=DATE, I=0
	2669	"RTN","VPR DVSIT",179 ,0)
	2670	S X=$G(VA IP(7)) S:X I=I+1,ADM ("provider ",I)=X_"^P ^1"_U_$$PR OVSPC^VPRD (+X) ;prim ary
	2671	"RTN","VPR DVSIT",180 ,0)
	2672	S X=$G(VA IP(18)) S: X I=I+1,AD M("provide r",I)=X_"^ A^"_U_$$PR OVSPC^VPRD (+X) ;atte nding
	2673	"RTN","VPR DVSIT",181 ,0)
	2674	S ADM("sp ecialty")= $P($G(VAIP (8)),U,2)
	2675	"RTN","VPR DVSIT",182 ,0)
	2676	S X=$$SER V(+$G(VAIP (8))),ADM( "service") =X,ADM("pt f")=VAIP(1 2)
	2677	"RTN","VPR DVSIT",183 ,0)
	2678	S ICD=$$P OV(IEN,DAT E) S:'ICD ICD=$$PTF( DFN,VAIP(1 2),DATE) ; PTF>ICD
	2679	"RTN","VPR DVSIT",184 ,0)
	2680	S ADM("re ason")=ICD _U_$G(VAIP (9)) ;ICD code^descr iption^sys tem^Dx tex t
	2681	"RTN","VPR DVSIT",185 ,0)
	2682	S HLOC=+$ G(^DIC(42, +$G(VAIP(5 )),44))
	2683	"RTN","VPR DVSIT",186 ,0)
	2684	S:HLOC AD M("locatio n")=$P($G( ^SC(HLOC,0 )),U)
	2685	"RTN","VPR DVSIT",187 ,0)
	2686	S ADM("fa cility")=$ $FAC^VPRD( +HLOC),ADM ("roomBed" )=$P(VAIP( 6),U,2)
	2687	"RTN","VPR DVSIT",188 ,0)
	2688	S ADM("se rviceCateg ory")="H^H OSPITALIZA TION"
	2689	"RTN","VPR DVSIT",189 ,0)
	2690	S X=$$CPT (IEN),ADM( "type")=$S (X:$P($$CP T^ICPTCOD( X),U,2,3), 1:U_$$CATG ("H"))
	2691	"RTN","VPR DVSIT",190 ,0)
	2692	I $G(VAIP (17)) D
	2693	"RTN","VPR DVSIT",191 ,0)
	2694	. S ADM(" departureD ateTime")= +$G(VAIP(1 7,1))
	2695	"RTN","VPR DVSIT",192 ,0)
	2696	. ; ADM(" dispositio n")=$G(VAI P(17,3)) ; Discharge Mvt Type
	2697	"RTN","VPR DVSIT",193 ,0)
	2698	S ADM("vi sitString" )=HLOC_";" _DATE_";H"
	2699	"RTN","VPR DVSIT",194 ,0)
	2700	D TIU(IEN ) ;notes/s ummary
	2701	"RTN","VPR DVSIT",195 ,0)
	2702	Q
	2703	"RTN","VPR DVSIT",196 ,0)
	2704	;
	2705	"RTN","VPR DVSIT",197 ,0)
	2706	INPT ; -- return cur rent admis sion in AD M("attribu te")=value [from ADM ]
	2707	"RTN","VPR DVSIT",198 ,0)
	2708	K D NS T D INP^VA DPT Q:$G(V AIN(1))<1
	2709	"RTN","VPR DVSIT",199 ,0)
	2710	S ADM("id ")=IEN,ADM ("patientC lass")="IM P",ADM("ad mission")= VAIN(1)
	2711	"RTN","VPR DVSIT",200 ,0)
	2712	; ADM("ad mitType")= $P($G(VAIN (8)),U,2)
	2713	"RTN","VPR DVSIT",201 ,0)
	2714	S DATE=+$ G(VAIN(7)) ,(ADM("dat eTime"),AD M("arrival DateTime") )=DATE,I=0
	2715	"RTN","VPR DVSIT",202 ,0)
	2716	S X=$G(VA IN(2)) S:X I=I+1,ADM ("provider ",I)=X_"^P ^1"_U_$$PR OVSPC^VPRD (+X) ;prim ary
	2717	"RTN","VPR DVSIT",203 ,0)
	2718	S X=$G(VA IN(11)) S: X I=I+1,AD M("provide r",I)=X_"^ A^"_U_$$PR OVSPC^VPRD (+X) ;atte nding
	2719	"RTN","VPR DVSIT",204 ,0)
	2720	S ADM("sp ecialty")= $P($G(VAIN (3)),U,2)
	2721	"RTN","VPR DVSIT",205 ,0)
	2722	S X=$$SER V(+$G(VAIN (3))),ADM( "service") =X,ADM("pt f")=VAIN(1 0)
	2723	"RTN","VPR DVSIT",206 ,0)
	2724	S ICD=$$P OV(IEN,DAT E) S:'ICD ICD=$$PTF( DFN,VAIN(1 0),DATE) ; PTF>ICD
	2725	"RTN","VPR DVSIT",207 ,0)
	2726	S ADM("re ason")=ICD _U_$G(VAIN (9)) ;ICD code^descr iption^sys tem^Dx tex t
	2727	"RTN","VPR DVSIT",208 ,0)
	2728	S HLOC=+$ G(^DIC(42, +$G(VAIN(4 )),44))
	2729	"RTN","VPR DVSIT",209 ,0)
	2730	S:HLOC AD M("locatio n")=$P($G( ^SC(HLOC,0 )),U)
	2731	"RTN","VPR DVSIT",210 ,0)
	2732	S ADM("fa cility")=$ $FAC^VPRD( +HLOC),ADM ("roomBed" )=VAIN(5)
	2733	"RTN","VPR DVSIT",211 ,0)
	2734	S ADM("se rviceCateg ory")="H^H OSPITALIZA TION"
	2735	"RTN","VPR DVSIT",212 ,0)
	2736	S X=$$CPT (IEN),ADM( "type")=$S (X:$P($$CP T^ICPTCOD( X),U,2,3), 1:U_$$CATG ("H"))
	2737	"RTN","VPR DVSIT",213 ,0)
	2738	; ADM("vi sitString" )=HLOC_";" _DATE_";H"
	2739	"RTN","VPR DVSIT",214 ,0)
	2740	D TIU(IEN ) ;notes/s ummary
	2741	"RTN","VPR DVSIT",215 ,0)
	2742	Q
	2743	"RTN","VPR DVSIT",216 ,0)
	2744	;
	2745	"RTN","VPR DVSIT",217 ,0)
	2746	PTF(DFN,PT F,DATE) ; -- return ICD code^d escription ^system fo r a PTF re cord
	2747	"RTN","VPR DVSIT",218 ,0)
	2748	N VPRPTF, X0,Y
	2749	"RTN","VPR DVSIT",219 ,0)
	2750	D:$G(PTF) RPC^DGPTF API(.VPRPT F,+PTF) I $G(VPRPTF( 0))<0 Q "^ ^"
	2751	"RTN","VPR DVSIT",220 ,0)
	2752	S Y=$P($G (VPRPTF(1) ),U,3),DAT E=+$G(DATE ,DT)
	2753	"RTN","VPR DVSIT",221 ,0)
	2754	S X0=$$IC DDX^ICDEX( Y,DATE,,"E ") I X0<0 Q "^^"
	2755	"RTN","VPR DVSIT",222 ,0)
	2756	S Y=$P(X0 ,U,2)_U_$P (X0,U,4) ;I CD Code^Dx name
	2757	"RTN","VPR DVSIT",223 ,0)
	2758	S $P(Y,U, 3)=$$SAB^I CDEX($P(X0 ,U,20)) ;c oding syst em
	2759	"RTN","VPR DVSIT",224 ,0)
	2760	Q Y
	2761	"RTN","VPR DVSIT",225 ,0)
	2762	;
	2763	"RTN","VPR DVSIT",226 ,0)
	2764	ENC(IEN,EN C) ; -- re turn an en counter in ENC("attr ibute")=va lue
	2765	"RTN","VPR DVSIT",227 ,0)
	2766	N X0,DATE ,HLOC,TYPE ,STS,X,Y K ENC
	2767	"RTN","VPR DVSIT",228 ,0)
	2768	S IEN=+$G (IEN) Q:IE N<1 ;inva lid ien
	2769	"RTN","VPR DVSIT",229 ,0)
	2770	S ENC("id ")="E"_IEN ,X0=$$GETO E^SDOE(IEN ) ;^SCE(IE N,0) node
	2771	"RTN","VPR DVSIT",230 ,0)
	2772	S DATE=+X 0,ENC("dat eTime")=DA TE
	2773	"RTN","VPR DVSIT",231 ,0)
	2774	S HLOC=+$ P(X0,U,4) I HLOC D
	2775	"RTN","VPR DVSIT",232 ,0)
	2776	. S HLOC= HLOC_U_$P( $G(^SC(HLO C,0)),U)
	2777	"RTN","VPR DVSIT",233 ,0)
	2778	. S ENC(" location") =$P(HLOC,U ,2)
	2779	"RTN","VPR DVSIT",234 ,0)
	2780	. S X=$$G ET1^DIQ(44 ,+HLOC_"," ,9.5,"I")
	2781	"RTN","VPR DVSIT",235 ,0)
	2782	. I X S E NC("servic e")=$$SERV (X)
	2783	"RTN","VPR DVSIT",236 ,0)
	2784	S ENC("fa cility")=$ $FAC^VPRD( +HLOC)
	2785	"RTN","VPR DVSIT",237 ,0)
	2786	S STS=$$E XTERNAL^DI LFD(409.68 ,.12,,$P(X 0,U,12))
	2787	"RTN","VPR DVSIT",238 ,0)
	2788	S X=$S(ST S?1"INP".E :"IMP",1:" AMB"),ENC( "patientCl ass")=X,TY PE=$E(X)
	2789	"RTN","VPR DVSIT",239 ,0)
	2790	S ENC("ty pe")=U_$S( HLOC:$P(HL OC,U,2)_" VISIT",1:$ $CATG(TYPE ))
	2791	"RTN","VPR DVSIT",240 ,0)
	2792	S ENC("se rviceCateg ory")=TYPE _U_$$CATG( TYPE)
	2793	"RTN","VPR DVSIT",241 ,0)
	2794	S ENC("vi sitString" )=+HLOC_"; "_DATE_";" _TYPE
	2795	"RTN","VPR DVSIT",242 ,0)
	2796	Q
	2797	"RTN","VPR DVSIT",243 ,0)
	2798	;
	2799	"RTN","VPR DVSIT",244 ,0)
	2800	; ------- ----- Retu rn data to middle ti er ------- -----
	2801	"RTN","VPR DVSIT",245 ,0)
	2802	;
	2803	"RTN","VPR DVSIT",246 ,0)
	2804	XML(VISIT) ; -- Retu rn patient visit as XML
	2805	"RTN","VPR DVSIT",247 ,0)
	2806	N ATT,X,Y ,NAMES,I,J
	2807	"RTN","VPR DVSIT",248 ,0)
	2808	D ADD("<v isit>") S VPRTOTL=$G (VPRTOTL)+ 1
	2809	"RTN","VPR DVSIT",249 ,0)
	2810	S ATT="" F S ATT=$ O(VISIT(AT T)) Q:ATT= "" D D:$ L(Y) ADD(Y )
	2811	"RTN","VPR DVSIT",250 ,0)
	2812	. I $O(VI SIT(ATT,0) ) D S Y=" " Q ;mult iples
	2813	"RTN","VPR DVSIT",251 ,0)
	2814	.. D ADD( "<"_ATT_"s >")
	2815	"RTN","VPR DVSIT",252 ,0)
	2816	.. S I=0 F S I=$O( VISIT(ATT, I)) Q:I<1 D
	2817	"RTN","VPR DVSIT",253 ,0)
	2818	... S X=$ G(VISIT(AT T,I)),NAME S=""
	2819	"RTN","VPR DVSIT",254 ,0)
	2820	... I ATT ="document " S NAMES= "id^localT itle^natio nalTitle^v uid^Z"
	2821	"RTN","VPR DVSIT",255 ,0)
	2822	... I ATT ="provider " S NAMES= "code^name ^role^prim ary^"_$$PR OVTAGS^VPR D_"^Z"
	2823	"RTN","VPR DVSIT",256 ,0)
	2824	... I ATT ="cpt" S N AMES="code ^name^Z"
	2825	"RTN","VPR DVSIT",257 ,0)
	2826	... I ATT ="icd" S N AMES="code ^name^syst em^narrati ve^ranking ^Z"
	2827	"RTN","VPR DVSIT",258 ,0)
	2828	... S Y=" <"_ATT_" " _$$LOOP ;_ "/>" D ADD (Y)
	2829	"RTN","VPR DVSIT",259 ,0)
	2830	... S X=$ G(VISIT(AT T,I,"conte nt")) I '$ L(X) S Y=Y _"/>" D AD D(Y) Q
	2831	"RTN","VPR DVSIT",260 ,0)
	2832	... S Y=Y _">" D ADD (Y)
	2833	"RTN","VPR DVSIT",261 ,0)
	2834	... S Y=" <content x ml:space=' preserve'> " D ADD(Y)
	2835	"RTN","VPR DVSIT",262 ,0)
	2836	... S J=0 F S J=$O (@X@(J)) Q :J<1 S Y= $$ESC^VPRD (@X@(J)) D ADD(Y)
	2837	"RTN","VPR DVSIT",263 ,0)
	2838	... D ADD ("</conten t>"),ADD(" </"_ATT_"> ")
	2839	"RTN","VPR DVSIT",264 ,0)
	2840	.. D ADD( "</"_ATT_" s>")
	2841	"RTN","VPR DVSIT",265 ,0)
	2842	. S X=$G( VISIT(ATT) ),Y="" Q:' $L(X)
	2843	"RTN","VPR DVSIT",266 ,0)
	2844	. S NAMES ="code^nam e^"_$S(ATT ="reason": "system^na rrative^", 1:"")_"Z"
	2845	"RTN","VPR DVSIT",267 ,0)
	2846	. I X'["^ " S Y="<"_ ATT_" valu e='"_$$ESC ^VPRD(X)_" ' />" Q
	2847	"RTN","VPR DVSIT",268 ,0)
	2848	. I $L(X) >1 S Y="<" _ATT_" "_$ $LOOP_"/>"
	2849	"RTN","VPR DVSIT",269 ,0)
	2850	D ADD("</ visit>")
	2851	"RTN","VPR DVSIT",270 ,0)
	2852	Q
	2853	"RTN","VPR DVSIT",271 ,0)
	2854	;
	2855	"RTN","VPR DVSIT",272 ,0)
	2856	LOOP() ; - - build su b-items st ring from NAMES and X
	2857	"RTN","VPR DVSIT",273 ,0)
	2858	N STR,P,T AG S STR=" "
	2859	"RTN","VPR DVSIT",274 ,0)
	2860	F P=1:1 S TAG=$P(NA MES,U,P) Q :TAG="Z" I $L($P(X, U,P)) S ST R=STR_TAG_ "='"_$$ESC ^VPRD($P(X ,U,P))_"' "
	2861	"RTN","VPR DVSIT",275 ,0)
	2862	Q STR
	2863	"RTN","VPR DVSIT",276 ,0)
	2864	;
	2865	"RTN","VPR DVSIT",277 ,0)
	2866	ADD(X) ; - - Add a li ne @VPR@(n )=X
	2867	"RTN","VPR DVSIT",278 ,0)
	2868	S VPRI=$G (VPRI)+1
	2869	"RTN","VPR DVSIT",279 ,0)
	2870	S @VPR@(V PRI)=X
	2871	"RTN","VPR DVSIT",280 ,0)
	2872	Q
	2873	"RTN","VPR PATCH")
	2874	0^8^B53274 6
	2875	"RTN","VPR PATCH",1,0 )
	2876	VPRPATCH ; SLC/MKB -- VPR patch post inst all ;8/14/ 13 11:22
	2877	"RTN","VPR PATCH",2,0 )
	2878	;;1.0;VIR TUAL PATIE NT RECORD; 7;Sep 01, 2011;B uild 3
	2879	"RTN","VPR PATCH",3,0 )
	2880	;;Per VHA Directive 2004-038, this rout ine should not be mo dified.
	2881	"RTN","VPR PATCH",4,0 )
	2882	;
	2883	"RTN","VPR PATCH",5,0 )
	2884	; Externa l Referenc es DBIA#
	2885	"RTN","VPR PATCH",6,0 )
	2886	; ------- ---------- -- -----
	2887	"RTN","VPR PATCH",7,0 )
	2888	; XPAR 2263
	2889	"RTN","VPR PATCH",8,0 )
	2890	;
	2891	"RTN","VPR PATCH",9,0 )
	2892	;
	2893	"RTN","VPR PATCH",10, 0)
	2894	PRE ; -- p re init
	2895	"RTN","VPR PATCH",11, 0)
	2896	Q
	2897	"RTN","VPR PATCH",12, 0)
	2898	;
	2899	"RTN","VPR PATCH",13, 0)
	2900	POST ; -- post init
	2901	"RTN","VPR PATCH",14, 0)
	2902	N P,N S P =+$P($G(XP DNM),"*",3 ) I P D ; update ver sion#
	2903	"RTN","VPR PATCH",15, 0)
	2904	. S N="1. "_$S(P<10: "0",1:"")_ P
	2905	"RTN","VPR PATCH",16, 0)
	2906	. D PUT^X PAR("PKG", "VPR VERSI ON",1,N)
	2907	"RTN","VPR PATCH",17, 0)
	2908	Q
	2909	"VER")
	2910	8.0^22.2
	2911	END
	2912	END