43. EPMO Open Source Coordination Office Redaction File Detail Report

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

43.1 Files compared

#	Location	File	Last Modified
1	C:\AraxisMergeCompare\Pri_un\MPDU\Patches	PSO_7_545.KID	Mon May 6 12:14:16 2019 UTC
2	C:\AraxisMergeCompare\Pri_re\MPDU\MPDU\Patches	PSO_7_545.KID	Tue May 7 18:40:02 2019 UTC

43.2 Comparison summary

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

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

43.4 Active regular expressions

No regular expressions were active.

43.5 Comparison detail

	1	KIDS Distr ibution sa ved on Mar 01, 2019@ 11:49:16
	2	PSO7545
	3	KIDS:P SO7.0545 ^
	4
	5	INSTALL NAME
	6	PSO7.054 5
	7	"BLD",1038 7,0)
	8	PSO7.054 5^OUTPATIE NT PHARMAC Y^0^319030 1^y
	9	"BLD",1038 7,1,0)
	10	^^149^149^ 3190227^
	11	"BLD",1038 7,1,1,0)
	12	The Clinic al Ancilla ry Service s (CAS) - Medication Permissio n/Dispensi ng
	13	"BLD",1038 7,1,2,0)
	14	Updates (M PDU) proje ct provide s the abil ity to sup port multi ple DEA
	15	"BLD",1038 7,1,3,0)
	16	Numbers fo r a user.
	17	"BLD",1038 7,1,4,0)
	18
	19	"BLD",1038 7,1,5,0)
	20	This patch PSO7545 is part o f a group of patches for this enhancemen t
	21	"BLD",1038 7,1,6,0)
	22	and must b e installe d after co mpletion o f installa tion of pa tches
	23	"BLD",1038 7,1,7,0)
	24	XU8688 a nd PSO75 29. The fo llowing ot her patche s for this enhanceme nt
	25	"BLD",1038 7,1,8,0)
	26	will be re leased in the future and inclu des: XU8 689, OR3 506,
	27	"BLD",1038 7,1,9,0)
	28	PSJ5372, OR3488 and OR34 99.
	29	"BLD",1038 7,1,10,0)
	30
	31	"BLD",1038 7,1,11,0)
	32	This patch PSO7545 has the f ollowing e nhancement s:
	33	"BLD",1038 7,1,12,0)
	34
	35	"BLD",1038 7,1,13,0)
	36	1. The opt ions Add N ew Provide rs [PSO PR OVIDER ADD ] and Edit Provider
	37	"BLD",1038 7,1,14,0)
	38	[PSO PR OVIDER EDI T] have be en modifie d with the following :
	39	"BLD",1038 7,1,15,0)
	40	a. The following existing f ields have been hidd en and wil l not be
	41	"BLD",1038 7,1,16,0)
	42	avai lable for editing:
	43	"BLD",1038 7,1,17,0)
	44	Pres criber DEA # (field #53.2)
	45	"BLD",1038 7,1,18,0)
	46	Pres criber DEA expiratio n date (fi eld #747.4 4)
	47	"BLD",1038 7,1,19,0)
	48	Pres criber Det ox/Maint # (field #5 3.11)
	49	"BLD",1038 7,1,20,0)
	50
	51	"BLD",1038 7,1,21,0)
	52	b. Allo w Multiple DEA Numbe rs to be a ssociated to a Provi der.
	53	"BLD",1038 7,1,22,0)
	54
	55	"BLD",1038 7,1,23,0)
	56	c. Add/ Edit/Remov e/Confirm DEA Number Informati on for Non -VA Provid ers.
	57	"BLD",1038 7,1,24,0)
	58
	59	"BLD",1038 7,1,25,0)
	60	2. The opt ion Patien t Prescrip tion Proce ssing [PSO LM BACKDO OR ORDERS] has
	61	"BLD",1038 7,1,26,0)
	62	been mo dified wit h the foll owing:
	63	"BLD",1038 7,1,27,0)
	64	a. To a llow the s election o f a DEA nu mber when placing an order for
	65	"BLD",1038 7,1,28,0)
	66	Cont rolled Sub stance (CS ) drug.
	67	"BLD",1038 7,1,29,0)
	68	b. To e nsure the Provider i s authoriz ed to pres cribe a sp ecific CS
	69	"BLD",1038 7,1,30,0)
	70	drug .
	71	"BLD",1038 7,1,31,0)
	72
	73	"BLD",1038 7,1,32,0)
	74	3. The PIV Card Cert ificate Ex piration A lert messa ge has bee n changed from
	75	"BLD",1038 7,1,33,0)
	76	"DEA ce rtificate expired. R enew your certificat e." to
	77	"BLD",1038 7,1,34,0)
	78	"Rx pro cessed: PI V Card Cer t Expired - NO ACTIO N REQ".
	79	"BLD",1038 7,1,35,0)
	80
	81	"BLD",1038 7,1,36,0)
	82	4. The PIV Card Cert ificate Re voked Aler t message has been c hanged
	83	"BLD",1038 7,1,37,0)
	84	from " Med orders (s) DCed. Cert revok ed. Contac t Pharm." to
	85	"BLD",1038 7,1,38,0)
	86	"Rx NOT processed : PIV Card Certifica te Revoked ".
	87	"BLD",1038 7,1,39,0)
	88
	89	"BLD",1038 7,1,40,0)
	90	5. Add Rem inder to T M function for Contr olled Subs tances tha t this
	91	"BLD",1038 7,1,41,0)
	92	prescri ption cann ot later b e converte d to a mai ntenance p rescriptio n.
	93	"BLD",1038 7,1,42,0)
	94
	95	"BLD",1038 7,1,43,0)
	96	6. A new m enu ePCS D EA Utility Functions [PSO EPCS UTILITY F UNCTIONS] has
	97	"BLD",1038 7,1,44,0)
	98	been tr ansported in this pa tch with t he followi ng options :
	99	"BLD",1038 7,1,45,0)
	100
	101	"BLD",1038 7,1,46,0)
	102	6.1 DEA E xpiration Date Repor t [PSO EPC S EXPIRE D ATE REPORT ]
	103	"BLD",1038 7,1,47,0)
	104	6.2 Print Prescribe rs with Pr ivileges [ PSO EPCS P RIVS]
	105	"BLD",1038 7,1,48,0)
	106	6.3 Print DISUSER P rescribers with Priv ileges [PS O EPCS DIS USER PRIVS ]
	107	"BLD",1038 7,1,49,0)
	108	6.4 Print PSDRPH Ke y Holders [PSO EPCS PSDRPH]
	109	"BLD",1038 7,1,50,0)
	110	6.5 Print Setting P arameters Privileges [PSO EPCS SET PARMS ]
	111	"BLD",1038 7,1,51,0)
	112	6.6 Print Audits fo r Prescrib er Editing [PSO EPCS PRINT EDI T AUDIT]
	113	"BLD",1038 7,1,52,0)
	114	6.7 Chang es to DEA Prescribin g Privileg es Report [PSO EPCS LOGICAL
	115	"BLD",1038 7,1,53,0)
	116	ACCES S REPORT]
	117	"BLD",1038 7,1,54,0)
	118	6.8 Alloc ation Audi t of PSDRP H Key Repo rt [PSO EP CS PHARMAC IST ACC
	119	"BLD",1038 7,1,55,0)
	120	REPOR T]
	121	"BLD",1038 7,1,56,0)
	122	6.9 Enter /Edit EPCS Access Re ports Para meters [PS O EPCS ACC ESS REPORT
	123	"BLD",1038 7,1,57,0)
	124	PARAM ]
	125	"BLD",1038 7,1,58,0)
	126	6.10 Allow VA Number if DEA Nu mber Expir ed [PSO EP CS EXPIRED DEA
	127	"BLD",1038 7,1,59,0)
	128	FAILO VER]
	129	"BLD",1038 7,1,60,0)
	130	6.11 Set P harmacy Op erating Mo de [PSO VA MC MBM PHA RMACY MODE ]
	131	"BLD",1038 7,1,61,0)
	132	6.12 Edit Facility D EA# and Ex piration D ate [PSO E PCS EDIT D EA# AND
	133	"BLD",1038 7,1,62,0)
	134	XDATE ]
	135	"BLD",1038 7,1,63,0)
	136
	137	"BLD",1038 7,1,64,0)
	138	7. Item 6. 10 above, 'Allow VA Number if DEA Number Expired' option wil l
	139	"BLD",1038 7,1,65,0)
	140	allow s ites to tu rn off the existing expired DE A number " fail over"
	141	"BLD",1038 7,1,66,0)
	142	functio nality so that the r enewal of DEA regist rations ca n be enfor ced
	143	"BLD",1038 7,1,67,0)
	144	while a llowing ot her sites to maintai n the "fai l over" fu nctionalit y.
	145	"BLD",1038 7,1,68,0)
	146	This pa rameter is also acce ssible fro m menu 'Ge neral Para meter Tool s',
	147	"BLD",1038 7,1,69,0)
	148	option 'Edit Para meter Valu es' [XPAR EDIT PARAM ETER], at the packag e
	149	"BLD",1038 7,1,70,0)
	150	level a nd the sys tem level.
	151	"BLD",1038 7,1,71,0)
	152
	153	"BLD",1038 7,1,72,0)
	154	Note - The post-i nstall rou tine will set this p arameter t o 1 ("Yes" ) at
	155	"BLD",1038 7,1,73,0)
	156	the system level to allow the "Fail Over " function ality.
	157	"BLD",1038 7,1,74,0)
	158
	159	"BLD",1038 7,1,75,0)
	160	8. Item 6. 11 above, 'Set Pharm acy Operat ing Mode' option wil l allow Me ds
	161	"BLD",1038 7,1,76,0)
	162	by Mail (MBM) sit es to turn off the w arning mes sages when using the
	163	"BLD",1038 7,1,77,0)
	164	EPCS GU I executab le on sele cting a pr ovider who does not have a CPR S
	165	"BLD",1038 7,1,78,0)
	166	account .
	167	"BLD",1038 7,1,79,0)
	168	Also, w ith MBM mo de on, bac kdoor phar macy will be able to edit the DEA
	169	"BLD",1038 7,1,80,0)
	170	informa tion regar dless of t he Provide r Type.
	171	"BLD",1038 7,1,81,0)
	172	This pa rameter is also acce ssible fro m menu 'Ge neral Para meter Tool s',
	173	"BLD",1038 7,1,82,0)
	174	option 'Edit Para meter Valu es', at th e package level and the system
	175	"BLD",1038 7,1,83,0)
	176	level.
	177	"BLD",1038 7,1,84,0)
	178
	179	"BLD",1038 7,1,85,0)
	180	Note - The post-i nstall rou tine will set this p arameter t o "VAMC" a t
	181	"BLD",1038 7,1,86,0)
	182	the packag e level.
	183	"BLD",1038 7,1,87,0)
	184
	185	"BLD",1038 7,1,88,0)
	186	9. Item 6. 9 above, ' Enter/Edit EPCS Acce ss Reports Parameter s' option,
	187	"BLD",1038 7,1,89,0)
	188	provide s the abil ity to con figure the delivery locations of 'Task
	189	"BLD",1038 7,1,90,0)
	190	Changes to DEA Pr escribing Privileges Report' a nd 'Task A llocation
	191	"BLD",1038 7,1,91,0)
	192	Audit o f PSDRPH K ey Report' so that th e report c an be deli vered to t he
	193	"BLD",1038 7,1,92,0)
	194	appropr iate devic e and/or i ndividuals .
	195	"BLD",1038 7,1,93,0)
	196
	197	"BLD",1038 7,1,94,0)
	198	It prov ides the f ollowing X PAR parame ter select ions:
	199	"BLD",1038 7,1,95,0)
	200
	201	"BLD",1038 7,1,96,0)
	202	Selec t one of t he followi ng:
	203	"BLD",1038 7,1,97,0)
	204
	205	"BLD",1038 7,1,98,0)
	206	1 PSOEPCS LO GICAL ACC REPORT DEV
	207	"BLD",1038 7,1,99,0)
	208	2 PSOEPCS LO GICAL ACC RPT EMAIL
	209	"BLD",1038 7,1,100,0)
	210	3 PSOEPCS PH ARM ACC RP T DEVICE
	211	"BLD",1038 7,1,101,0)
	212	4 PSOEPCS PH ARM ACC RE PORT EMAIL
	213	"BLD",1038 7,1,102,0)
	214
	215	"BLD",1038 7,1,103,0)
	216	Select parameter to edit:
	217	"BLD",1038 7,1,104,0)
	218
	219	"BLD",1038 7,1,105,0)
	220	These parameters are also accessible from the menu 'Gene ral Parame ter
	221	"BLD",1038 7,1,106,0)
	222	Tools' , option ' Edit Param eter Value s'.
	223	"BLD",1038 7,1,107,0)
	224
	225	"BLD",1038 7,1,108,0)
	226
	227	"BLD",1038 7,1,109,0)
	228	10. The Co py and Ren ew ListMan actions h ave been m odified to ensure th at
	229	"BLD",1038 7,1,110,0)
	230	the DE A # that i s in the o riginal pr escription has the c redentials to
	231	"BLD",1038 7,1,111,0)
	232	write CS orders.
	233	"BLD",1038 7,1,112,0)
	234
	235	"BLD",1038 7,1,113,0)
	236
	237	"BLD",1038 7,1,114,0)
	238	11. The fo llowing op tions are sent in th is patch a s a standa lone optio n:
	239	"BLD",1038 7,1,115,0)
	240	a. 'Al locate/De- allocate o f PSDRPH K ey' [PSO E PCS PSDRPH KEY] has been
	241	"BLD",1038 7,1,116,0)
	242	se nt in this patch. On ly users w ho hold th e PSDRPH k ey, have b een
	243	"BLD",1038 7,1,117,0)
	244	de legated th e PSDRPH k ey, or hol d the XUMG R key can use this
	245	"BLD",1038 7,1,118,0)
	246	op tion.
	247	"BLD",1038 7,1,119,0)
	248	b. 'Ta sk Changes to DEA Pr escribing Privileges Report' [ PSO EPCS
	249	"BLD",1038 7,1,120,0)
	250	LO GICAL ACCE SS]. It'll support m ultiple de livery opt ions so th at
	251	"BLD",1038 7,1,121,0)
	252	th e appropri ate people have acce ss to the report.
	253	"BLD",1038 7,1,122,0)
	254
	255	"BLD",1038 7,1,123,0)
	256	c. 'Ta sk Allocat ion Audit of PSDRPH Key Report ' [PSO EPC S PSDRPH
	257	"BLD",1038 7,1,124,0)
	258	AU DIT]. It'l l support multiple d elivery op tions so t hat the
	259	"BLD",1038 7,1,125,0)
	260	ap propriate people hav e access t o the repo rt.
	261	"BLD",1038 7,1,126,0)
	262
	263	"BLD",1038 7,1,127,0)
	264	Note - The post- install ro utine will replace e xisting sc heduled ta sks
	265	"BLD",1038 7,1,128,0)
	266	XU EPCS L OGICAL ACC ESS and XU EPCS PSDR PH AUDIT w ith new ta sks
	267	"BLD",1038 7,1,129,0)
	268	PSO EPCS LOGICAL AC CESS and P SO EPCS PS DRPH AUDIT . Options XU
	269	"BLD",1038 7,1,130,0)
	270	EPCS LOGI CAL ACCESS and XU EP CS PSDRPH AUDIT are marked as
	271	"BLD",1038 7,1,131,0)
	272	Out-Of-Or der by pat ch XU868 9 as part of this pr oject.
	273	"BLD",1038 7,1,132,0)
	274
	275	"BLD",1038 7,1,133,0)
	276
	277	"BLD",1038 7,1,134,0)
	278	Note: Rout ine PSOHLE XP has bee n modified .
	279	"BLD",1038 7,1,135,0)
	280	The mail messa ge that ge nerates wh en the fac ility DEA # is about to
	281	"BLD",1038 7,1,136,0)
	282	expi re in opti on Expire Prescripti ons [PSO E XPIRE PRES CRIPTIONS] has
	283	"BLD",1038 7,1,137,0)
	284	been modified to referen ce the opt ion, 'Edit Facility DEA# and
	285	"BLD",1038 7,1,138,0)
	286	Expi ration Dat e' [PSO EP CS EDIT DE A# AND XDA TE].
	287	"BLD",1038 7,1,139,0)
	288
	289	"BLD",1038 7,1,140,0)
	290	Note: The following routines h ave been m odified to use calls $$DEA^XUS ER,
	291	"BLD",1038 7,1,141,0)
	292	$$DE TOX^XUSER and $$PRXD T^XUSER to replace w here ever the NEW PE RSON
	293	"BLD",1038 7,1,142,0)
	294	file (#200) fi elds DEA# (#53.2), D ETOX/MAINT ENANCE ID NUMBER
	295	"BLD",1038 7,1,143,0)
	296	(#53 .11) and D EA EXPIRAT ION DATE ( #747.44) a re referen ced.
	297	"BLD",1038 7,1,144,0)
	298
	299	"BLD",1038 7,1,145,0)
	300	PSOE RXR1
	301	"BLD",1038 7,1,146,0)
	302	PSOE RXA0
	303	"BLD",1038 7,1,147,0)
	304	PSOC LUTL
	305	"BLD",1038 7,1,148,0)
	306	PSOH LDS1
	307	"BLD",1038 7,1,149,0)
	308	PSOC PTRI
	309	"BLD",1038 7,4,0)
	310	^9.64PA^^
	311	"BLD",1038 7,6.3)
	312	21
	313	"BLD",1038 7,"ABPKG")
	314	n
	315	"BLD",1038 7,"INID")
	316	^y
	317	"BLD",1038 7,"INIT")
	318	EN^PSO7P54 5
	319	"BLD",1038 7,"KRN",0)
	320	^9.67PA^77 9.2^20
	321	"BLD",1038 7,"KRN",.4 ,0)
	322	.4
	323	"BLD",1038 7,"KRN",.4 ,"NM",0)
	324	^9.68A^4^4
	325	"BLD",1038 7,"KRN",.4 ,"NM",1,0)
	326	PSO DEA PR IVS PRINT FILE #2 00^200^0
	327	"BLD",1038 7,"KRN",.4 ,"NM",2,0)
	328	PSO DEA DI SUSER PRIV S PRINT FILE #200 ^200^0
	329	"BLD",1038 7,"KRN",.4 ,"NM",3,0)
	330	PSO DEA PS DRPH PRINT FILE # 200^200^0
	331	"BLD",1038 7,"KRN",.4 ,"NM",4,0)
	332	PSO DEA SE T PARMS PR INT FIL E #200^200 ^0
	333	"BLD",1038 7,"KRN",.4 ,"NM","B", "PSO DEA D ISUSER PRI VS PRINT FILE #20 0",2)
	334
	335	"BLD",1038 7,"KRN",.4 ,"NM","B", "PSO DEA P RIVS PRINT FILE # 200",1)
	336
	337	"BLD",1038 7,"KRN",.4 ,"NM","B", "PSO DEA P SDRPH PRIN T FILE #200",3)
	338
	339	"BLD",1038 7,"KRN",.4 ,"NM","B", "PSO DEA S ET PARMS P RINT FI LE #200",4 )
	340
	341	"BLD",1038 7,"KRN",.4 01,0)
	342	.401
	343	"BLD",1038 7,"KRN",.4 01,"NM",0)
	344	^9.68A^4^4
	345	"BLD",1038 7,"KRN",.4 01,"NM",1, 0)
	346	PSO DEA DI V SORT FILE #200^ 200^0
	347	"BLD",1038 7,"KRN",.4 01,"NM",2, 0)
	348	PSO DEA DI SUSER2 SOR T FILE #200^200^0
	349	"BLD",1038 7,"KRN",.4 01,"NM",3, 0)
	350	PSO DEA PS DRPH SORT FILE #2 00^200^0
	351	"BLD",1038 7,"KRN",.4 01,"NM",4, 0)
	352	PSO DEA SE T PARMS SO RT FILE #200^200^ 0
	353	"BLD",1038 7,"KRN",.4 01,"NM","B ","PSO DEA DISUSER2 SORT FI LE #200",2 )
	354
	355	"BLD",1038 7,"KRN",.4 01,"NM","B ","PSO DEA DIV SORT FILE #2 00",1)
	356
	357	"BLD",1038 7,"KRN",.4 01,"NM","B ","PSO DEA PSDRPH SO RT FILE #200",3)
	358
	359	"BLD",1038 7,"KRN",.4 01,"NM","B ","PSO DEA SET PARMS SORT F ILE #200", 4)
	360
	361	"BLD",1038 7,"KRN",.4 02,0)
	362	.402
	363	"BLD",1038 7,"KRN",.4 03,0)
	364	.403
	365	"BLD",1038 7,"KRN",.5 ,0)
	366	.5
	367	"BLD",1038 7,"KRN",.8 4,0)
	368	.84
	369	"BLD",1038 7,"KRN",3. 6,0)
	370	3.6
	371	"BLD",1038 7,"KRN",3. 8,0)
	372	3.8
	373	"BLD",1038 7,"KRN",9. 2,0)
	374	9.2
	375	"BLD",1038 7,"KRN",9. 8,0)
	376	9.8
	377	"BLD",1038 7,"KRN",9. 8,"NM",0)
	378	^9.68A^26^ 24
	379	"BLD",1038 7,"KRN",9. 8,"NM",1,0 )
	380	PSODIR^^0^ B149063676
	381	"BLD",1038 7,"KRN",9. 8,"NM",3,0 )
	382	PSOPRVW^^0 ^B11155666 4
	383	"BLD",1038 7,"KRN",9. 8,"NM",4,0 )
	384	PSOCLUTL^^ 0^B3002988 7
	385	"BLD",1038 7,"KRN",9. 8,"NM",5,0 )
	386	PSOERXR1^^ 0^B3323666 4
	387	"BLD",1038 7,"KRN",9. 8,"NM",6,0 )
	388	PSOERXA0^^ 0^B3301299 2
	389	"BLD",1038 7,"KRN",9. 8,"NM",7,0 )
	390	PSOHLDS1^^ 0^B4899608 8
	391	"BLD",1038 7,"KRN",9. 8,"NM",8,0 )
	392	PSOPRVW1^^ 0^B1037737 25
	393	"BLD",1038 7,"KRN",9. 8,"NM",9,0 )
	394	PSORN52C^^ 0^B6918955 7
	395	"BLD",1038 7,"KRN",9. 8,"NM",10, 0)
	396	PSOPKIV1^^ 0^B1043733 58
	397	"BLD",1038 7,"KRN",9. 8,"NM",11, 0)
	398	PSOHLSN1^^ 0^B7345828 5
	399	"BLD",1038 7,"KRN",9. 8,"NM",12, 0)
	400	PSOORED1^^ 0^B7855780 4
	401	"BLD",1038 7,"KRN",9. 8,"NM",13, 0)
	402	PSOORFI5^^ 0^B7951510 0
	403	"BLD",1038 7,"KRN",9. 8,"NM",14, 0)
	404	PSOORNE3^^ 0^B6951454 7
	405	"BLD",1038 7,"KRN",9. 8,"NM",16, 0)
	406	PSOOTMRX^^ 0^B2630919 9
	407	"BLD",1038 7,"KRN",9. 8,"NM",17, 0)
	408	PSOORNE5^^ 0^B5473710 0
	409	"BLD",1038 7,"KRN",9. 8,"NM",18, 0)
	410	PSONEW^^0^ B33684914
	411	"BLD",1038 7,"KRN",9. 8,"NM",19, 0)
	412	PSOCPTRI^^ 0^B3057995 3
	413	"BLD",1038 7,"KRN",9. 8,"NM",20, 0)
	414	PSORENW0^^ 0^B8527639 6
	415	"BLD",1038 7,"KRN",9. 8,"NM",21, 0)
	416	PSODEARP^^ 0^B4894318 2
	417	"BLD",1038 7,"KRN",9. 8,"NM",22, 0)
	418	PSODEART^^ 0^B1490559 99
	419	"BLD",1038 7,"KRN",9. 8,"NM",23, 0)
	420	PSODEAME^^ 0^B1983575 93
	421	"BLD",1038 7,"KRN",9. 8,"NM",24, 0)
	422	PSODEAED^^ 0^B1679850
	423	"BLD",1038 7,"KRN",9. 8,"NM",25, 0)
	424	PSOHLEXP^^ 0^B2403705 8
	425	"BLD",1038 7,"KRN",9. 8,"NM",26, 0)
	426	PSOUTIL^^0 ^B14656583 2
	427	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSOCLUTL ",4)
	428
	429	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSOCPTRI ",19)
	430
	431	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSODEAED ",24)
	432
	433	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSODEAME ",23)
	434
	435	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSODEARP ",21)
	436
	437	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSODEART ",22)
	438
	439	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSODIR", 1)
	440
	441	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSOERXA0 ",6)
	442
	443	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSOERXR1 ",5)
	444
	445	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSOHLDS1 ",7)
	446
	447	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSOHLEXP ",25)
	448
	449	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSOHLSN1 ",11)
	450
	451	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSONEW", 18)
	452
	453	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSOORED1 ",12)
	454
	455	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSOORFI5 ",13)
	456
	457	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSOORNE3 ",14)
	458
	459	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSOORNE5 ",17)
	460
	461	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSOOTMRX ",16)
	462
	463	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSOPKIV1 ",10)
	464
	465	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSOPRVW" ,3)
	466
	467	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSOPRVW1 ",8)
	468
	469	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSORENW0 ",20)
	470
	471	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSORN52C ",9)
	472
	473	"BLD",1038 7,"KRN",9. 8,"NM","B" ,"PSOUTIL" ,26)
	474
	475	"BLD",1038 7,"KRN",19 ,0)
	476	19
	477	"BLD",1038 7,"KRN",19 ,"NM",0)
	478	^9.68A^17^ 16
	479	"BLD",1038 7,"KRN",19 ,"NM",1,0)
	480	PSO EPCS U TILITY FUN CTIONS^^0
	481	"BLD",1038 7,"KRN",19 ,"NM",2,0)
	482	PSO EPCS E XPIRE DATE REPORT^^0
	483	"BLD",1038 7,"KRN",19 ,"NM",3,0)
	484	PSO EPCS P RIVS^^0
	485	"BLD",1038 7,"KRN",19 ,"NM",4,0)
	486	PSO EPCS D ISUSER PRI VS^^0
	487	"BLD",1038 7,"KRN",19 ,"NM",5,0)
	488	PSO EPCS P SDRPH^^0
	489	"BLD",1038 7,"KRN",19 ,"NM",6,0)
	490	PSO EPCS S ET PARMS^^ 0
	491	"BLD",1038 7,"KRN",19 ,"NM",7,0)
	492	PSO EPCS P RINT EDIT AUDIT^^0
	493	"BLD",1038 7,"KRN",19 ,"NM",8,0)
	494	PSO EPCS L OGICAL ACC ESS REPORT ^^0
	495	"BLD",1038 7,"KRN",19 ,"NM",9,0)
	496	PSO EPCS P HARMACIST ACC REPORT ^^0
	497	"BLD",1038 7,"KRN",19 ,"NM",10,0 )
	498	PSO EPCS A CCESS REPO RT PARAM^^ 0
	499	"BLD",1038 7,"KRN",19 ,"NM",11,0 )
	500	PSO EPCS E XPIRED DEA FAILOVER^ ^0
	501	"BLD",1038 7,"KRN",19 ,"NM",12,0 )
	502	PSO VAMC M BM PHARMAC Y MODE^^0
	503	"BLD",1038 7,"KRN",19 ,"NM",13,0 )
	504	PSO EPCS E DIT DEA# A ND XDATE^^ 0
	505	"BLD",1038 7,"KRN",19 ,"NM",15,0 )
	506	PSO EPCS L OGICAL ACC ESS^^0
	507	"BLD",1038 7,"KRN",19 ,"NM",16,0 )
	508	PSO EPCS P SDRPH AUDI T^^0
	509	"BLD",1038 7,"KRN",19 ,"NM",17,0 )
	510	PSO EPCS P SDRPH KEY^ ^0
	511	"BLD",1038 7,"KRN",19 ,"NM","B", "PSO EPCS ACCESS REP ORT PARAM" ,10)
	512
	513	"BLD",1038 7,"KRN",19 ,"NM","B", "PSO EPCS DISUSER PR IVS",4)
	514
	515	"BLD",1038 7,"KRN",19 ,"NM","B", "PSO EPCS EDIT DEA# AND XDATE" ,13)
	516
	517	"BLD",1038 7,"KRN",19 ,"NM","B", "PSO EPCS EXPIRE DAT E REPORT", 2)
	518
	519	"BLD",1038 7,"KRN",19 ,"NM","B", "PSO EPCS EXPIRED DE A FAILOVER ",11)
	520
	521	"BLD",1038 7,"KRN",19 ,"NM","B", "PSO EPCS LOGICAL AC CESS",15)
	522
	523	"BLD",1038 7,"KRN",19 ,"NM","B", "PSO EPCS LOGICAL AC CESS REPOR T",8)
	524
	525	"BLD",1038 7,"KRN",19 ,"NM","B", "PSO EPCS PHARMACIST ACC REPOR T",9)
	526
	527	"BLD",1038 7,"KRN",19 ,"NM","B", "PSO EPCS PRINT EDIT AUDIT",7)
	528
	529	"BLD",1038 7,"KRN",19 ,"NM","B", "PSO EPCS PRIVS",3)
	530
	531	"BLD",1038 7,"KRN",19 ,"NM","B", "PSO EPCS PSDRPH",5)
	532
	533	"BLD",1038 7,"KRN",19 ,"NM","B", "PSO EPCS PSDRPH AUD IT",16)
	534
	535	"BLD",1038 7,"KRN",19 ,"NM","B", "PSO EPCS PSDRPH KEY ",17)
	536
	537	"BLD",1038 7,"KRN",19 ,"NM","B", "PSO EPCS SET PARMS" ,6)
	538
	539	"BLD",1038 7,"KRN",19 ,"NM","B", "PSO EPCS UTILITY FU NCTIONS",1 )
	540
	541	"BLD",1038 7,"KRN",19 ,"NM","B", "PSO VAMC MBM PHARMA CY MODE",1 2)
	542
	543	"BLD",1038 7,"KRN",19 .1,0)
	544	19.1
	545	"BLD",1038 7,"KRN",10 1,0)
	546	101
	547	"BLD",1038 7,"KRN",10 1,"NM",0)
	548	^9.68A^5^5
	549	"BLD",1038 7,"KRN",10 1,"NM",1,0 )
	550	PSODEAME A CCEPT AND SAVE^^0
	551	"BLD",1038 7,"KRN",10 1,"NM",2,0 )
	552	PSODEAME C OPY TO VIS TA^^0
	553	"BLD",1038 7,"KRN",10 1,"NM",3,0 )
	554	PSODEAME E DIT VISTA VALUES^^0
	555	"BLD",1038 7,"KRN",10 1,"NM",4,0 )
	556	PSODEAME M ENU^^0
	557	"BLD",1038 7,"KRN",10 1,"NM",5,0 )
	558	PSODEAME Q UIT AND RE JECT^^0
	559	"BLD",1038 7,"KRN",10 1,"NM","B" ,"PSODEAME ACCEPT AN D SAVE",1)
	560
	561	"BLD",1038 7,"KRN",10 1,"NM","B" ,"PSODEAME COPY TO V ISTA",2)
	562
	563	"BLD",1038 7,"KRN",10 1,"NM","B" ,"PSODEAME EDIT VIST A VALUES", 3)
	564
	565	"BLD",1038 7,"KRN",10 1,"NM","B" ,"PSODEAME MENU",4)
	566
	567	"BLD",1038 7,"KRN",10 1,"NM","B" ,"PSODEAME QUIT AND REJECT",5)
	568
	569	"BLD",1038 7,"KRN",40 9.61,0)
	570	409.61
	571	"BLD",1038 7,"KRN",40 9.61,"NM", 0)
	572	^9.68A^1^1
	573	"BLD",1038 7,"KRN",40 9.61,"NM", 1,0)
	574	PSO DEA NU MBER MANAG EMENT^^0
	575	"BLD",1038 7,"KRN",40 9.61,"NM", "B","PSO D EA NUMBER MANAGEMENT ",1)
	576
	577	"BLD",1038 7,"KRN",77 1,0)
	578	771
	579	"BLD",1038 7,"KRN",77 9.2,0)
	580	779.2
	581	"BLD",1038 7,"KRN",87 0,0)
	582	870
	583	"BLD",1038 7,"KRN",89 89.51,0)
	584	8989.51
	585	"BLD",1038 7,"KRN",89 89.51,"NM" ,0)
	586	^9.68A^11^ 6
	587	"BLD",1038 7,"KRN",89 89.51,"NM" ,1,0)
	588	PSO VAMC M BM PHARMAC Y MODE^^0
	589	"BLD",1038 7,"KRN",89 89.51,"NM" ,7,0)
	590	PSOEPCS EX PIRED DEA FAILOVER^^ 0
	591	"BLD",1038 7,"KRN",89 89.51,"NM" ,8,0)
	592	PSOEPCS LO GICAL ACC REPORT DEV ^^0
	593	"BLD",1038 7,"KRN",89 89.51,"NM" ,9,0)
	594	PSOEPCS LO GICAL ACC RPT EMAIL^ ^0
	595	"BLD",1038 7,"KRN",89 89.51,"NM" ,10,0)
	596	PSOEPCS PH ARM ACC RE PORT EMAIL ^^0
	597	"BLD",1038 7,"KRN",89 89.51,"NM" ,11,0)
	598	PSOEPCS PH ARM ACC RP T DEVICE^^ 0
	599	"BLD",1038 7,"KRN",89 89.51,"NM" ,"B","PSO VAMC MBM P HARMACY MO DE",1)
	600
	601	"BLD",1038 7,"KRN",89 89.51,"NM" ,"B","PSOE PCS EXPIRE D DEA FAIL OVER",7)
	602
	603	"BLD",1038 7,"KRN",89 89.51,"NM" ,"B","PSOE PCS LOGICA L ACC REPO RT DEV",8)
	604
	605	"BLD",1038 7,"KRN",89 89.51,"NM" ,"B","PSOE PCS LOGICA L ACC RPT EMAIL",9)
	606
	607	"BLD",1038 7,"KRN",89 89.51,"NM" ,"B","PSOE PCS PHARM ACC REPORT EMAIL",10 )
	608
	609	"BLD",1038 7,"KRN",89 89.51,"NM" ,"B","PSOE PCS PHARM ACC RPT DE VICE",11)
	610
	611	"BLD",1038 7,"KRN",89 89.52,0)
	612	8989.52
	613	"BLD",1038 7,"KRN",89 94,0)
	614	8994
	615	"BLD",1038 7,"KRN","B ",.4,.4)
	616
	617	"BLD",1038 7,"KRN","B ",.401,.40 1)
	618
	619	"BLD",1038 7,"KRN","B ",.402,.40 2)
	620
	621	"BLD",1038 7,"KRN","B ",.403,.40 3)
	622
	623	"BLD",1038 7,"KRN","B ",.5,.5)
	624
	625	"BLD",1038 7,"KRN","B ",.84,.84)
	626
	627	"BLD",1038 7,"KRN","B ",3.6,3.6)
	628
	629	"BLD",1038 7,"KRN","B ",3.8,3.8)
	630
	631	"BLD",1038 7,"KRN","B ",9.2,9.2)
	632
	633	"BLD",1038 7,"KRN","B ",9.8,9.8)
	634
	635	"BLD",1038 7,"KRN","B ",19,19)
	636
	637	"BLD",1038 7,"KRN","B ",19.1,19. 1)
	638
	639	"BLD",1038 7,"KRN","B ",101,101)
	640
	641	"BLD",1038 7,"KRN","B ",409.61,4 09.61)
	642
	643	"BLD",1038 7,"KRN","B ",771,771)
	644
	645	"BLD",1038 7,"KRN","B ",779.2,77 9.2)
	646
	647	"BLD",1038 7,"KRN","B ",870,870)
	648
	649	"BLD",1038 7,"KRN","B ",8989.51, 8989.51)
	650
	651	"BLD",1038 7,"KRN","B ",8989.52, 8989.52)
	652
	653	"BLD",1038 7,"KRN","B ",8994,899 4)
	654
	655	"BLD",1038 7,"QDEF")
	656	^^^^NO^^^^ NO^^NO
	657	"BLD",1038 7,"QUES",0 )
	658	^9.62^^
	659	"BLD",1038 7,"REQB",0 )
	660	^9.611^10^ 9
	661	"BLD",1038 7,"REQB",2 ,0)
	662	XU8.0689 ^2
	663	"BLD",1038 7,"REQB",3 ,0)
	664	PSO7.018 4^2
	665	"BLD",1038 7,"REQB",4 ,0)
	666	PSO7.032 3^2
	667	"BLD",1038 7,"REQB",5 ,0)
	668	PSO7.043 4^2
	669	"BLD",1038 7,"REQB",6 ,0)
	670	PSO7.045 0^2
	671	"BLD",1038 7,"REQB",7 ,0)
	672	PSO7.046 2^2
	673	"BLD",1038 7,"REQB",8 ,0)
	674	PSO7.051 7^2
	675	"BLD",1038 7,"REQB",9 ,0)
	676	PSO7.051 8^2
	677	"BLD",1038 7,"REQB",1 0,0)
	678	PSO7.052 7^2
	679	"BLD",1038 7,"REQB"," B","PSO7. 0184",3)
	680
	681	"BLD",1038 7,"REQB"," B","PSO7. 0323",4)
	682
	683	"BLD",1038 7,"REQB"," B","PSO7. 0434",5)
	684
	685	"BLD",1038 7,"REQB"," B","PSO7. 0450",6)
	686
	687	"BLD",1038 7,"REQB"," B","PSO7. 0462",7)
	688
	689	"BLD",1038 7,"REQB"," B","PSO7. 0517",8)
	690
	691	"BLD",1038 7,"REQB"," B","PSO7. 0518",9)
	692
	693	"BLD",1038 7,"REQB"," B","PSO7. 0527",10)
	694
	695	"BLD",1038 7,"REQB"," B","XU8.0 689",2)
	696
	697	"INIT")
	698	EN^PSO7P54 5
	699	"KRN",.4,5 681,-1)
	700	0^1
	701	"KRN",.4,5 681,0)
	702	PSO DEA PR IVS PRINT^ 3181119.08 46^@^200^^ @^3190222
	703	"KRN",.4,5 681,"%D",0 )
	704	^^2^2^3181 119^^
	705	"KRN",.4,5 681,"%D",1 ,0)
	706	This is a print temp late for t he DEA EPC S project. This pri nts user's
	707	"KRN",.4,5 681,"%D",2 ,0)
	708	NAME, SCHE DULESs, VA #, DUZ and DEA#.
	709	"KRN",.4,5 681,"F",1)
	710	.01;L30~0; "DUZ"~53.2 ;L11~53.3; L11~"SCHED ULE II: "; C10~55.1;X ;C30~"SCHE DULE II NO N: ";C10~5 5.2;X;C30~ "SCHEDULE III: ";C10 ~55.3;X;C3 0~
	711	"KRN",.4,5 681,"F",2)
	712	"SCHEDULE III NON: " ;C10~55.4; X;C30~"SCH EDULE IV: ";C10~55.5 ;X;C30~"SC HEDULE V: ";C10~55.6 ;X;C30~
	713	"KRN",.4,5 681,"H")
	714	PRESCRIBER S WITH PRI VILEGES
	715	"KRN",.4,5 682,-1)
	716	0^2
	717	"KRN",.4,5 682,0)
	718	PSO DEA DI SUSER PRIV S PRINT^31 81119.0917 ^@^200^^@^ 3190222
	719	"KRN",.4,5 682,"%D",0 )
	720	^^2^2^3181 119^^^
	721	"KRN",.4,5 682,"%D",1 ,0)
	722	This is a print temp late for t he DEA EPC S project. This pri nts user's
	723	"KRN",.4,5 682,"%D",2 ,0)
	724	NAME, SCHE DULESs, TE RMINATION DATE, DUZ and DEA#.
	725	"KRN",.4,5 682,"F",1)
	726	.01;L30~0; "DUZ"~53.2 ;L11~9.2;L 11~"SCHEDU LE II: ";C 10~55.1;X; C30~"SCHED ULE II NON : ";C10~55 .2;X;C30~" SCHEDULE I II: ";C10~ 55.3;X;C30 ~
	727	"KRN",.4,5 682,"F",2)
	728	"SCHEDULE III NON: " ;C10~55.4; X;C30~"SCH EDULE IV: ";C10~55.5 ;X;C30~"SC HEDULE V: ";C10~55.6 ;X;C30~
	729	"KRN",.4,5 682,"H")
	730	DISUSER PR ESCRIBERS WITH PRIVI LEGES
	731	"KRN",.4,5 683,-1)
	732	0^3
	733	"KRN",.4,5 683,0)
	734	PSO DEA PS DRPH PRINT ^3181119.0 933^@^200^ ^@^3190222
	735	"KRN",.4,5 683,"%D",0 )
	736	^^2^2^3181 119^
	737	"KRN",.4,5 683,"%D",1 ,0)
	738	This print template is for the DEA ePCS project an d prints n ame, duz,
	739	"KRN",.4,5 683,"%D",2 ,0)
	740	security k eys, and w ho assigne d key.
	741	"KRN",.4,5 683,"F",1)
	742	.01;C1;L25 ~0;C27;L10 ;"DUZ"~51, 1;C39;L23~ 51,2;C64;L 12~
	743	"KRN",.4,5 683,"H")
	744	PSDRPH KEY HOLDERS
	745	"KRN",.4,5 684,-1)
	746	0^4
	747	"KRN",.4,5 684,0)
	748	PSO DEA SE T PARMS PR INT^318111 9.0938^@^2 00^^@^3190 222
	749	"KRN",.4,5 684,"%D",0 )
	750	^^2^2^3181 119^
	751	"KRN",.4,5 684,"%D",1 ,0)
	752	This is a print temp late for t he DEA EPC S project. This prin ts user's
	753	"KRN",.4,5 684,"%D",2 ,0)
	754	name, DUZ, GIVEN BY, and DATE GIVEN.
	755	"KRN",.4,5 684,"F",1)
	756	.01;C1;L25 ~0;C27;L10 ;"DUZ"~51, 1;C39;L23~ 51,2;C64;L 12~
	757	"KRN",.4,5 684,"H")
	758	USERS RESP ONSIBLE FO R SETTING PARAMETERS
	759	"KRN",.401 ,450006,-1 )
	760	0^1
	761	"KRN",.401 ,450006,0)
	762	PSO DEA DI V SORT^318 1119.0951^ @^200^^@^3 190222
	763	"KRN",.401 ,450006,2, 0)
	764	^.4014^2^2
	765	"KRN",.401 ,450006,2, 1,0)
	766	200.02^^DI VISION^".0 1^^^^^^4
	767	"KRN",.401 ,450006,2, 1,1,0)
	768	^.40141^1^ 1
	769	"KRN",.401 ,450006,2, 1,1,1,0)
	770	200^2
	771	"KRN",.401 ,450006,2, 1,1,"B",20 0,1)
	772
	773	"KRN",.401 ,450006,2, 1,"CM")
	774	S Y(1)=$S( $D(^VA(200 ,D0,2,D1,0 )):^(0),1: "") S X=$P ($G(^DIC(4 ,+$P(Y(1), U,1),0)),U ) I D1>0 S DISX(1)=X
	775	"KRN",.401 ,450006,2, 1,"F")
	776	?z^@
	777	"KRN",.401 ,450006,2, 1,"GET")
	778	S Y(1)=$S( $D(^VA(200 ,D0,2,D1,0 )):^(0),1: "") S X=$P ($G(^DIC(4 ,+$P(Y(1), U,1),0)),U ) I D1>0 S DISX(1)=X
	779	"KRN",.401 ,450006,2, 1,"QCON")
	780	I 1
	781	"KRN",.401 ,450006,2, 1,"T")
	782	z^
	783	"KRN",.401 ,450006,2, 1,"TXT")
	784	All DIVISI ON (includ es null va lues)
	785	"KRN",.401 ,450006,2, 2,0)
	786	200^.01^NA ME^^^^^^^4
	787	"KRN",.401 ,450006,2, 2,"GET")
	788	S DISX(2)= $P($G(^VA( 200,D0,0)) ,U)
	789	"KRN",.401 ,450006,2, 2,"IX")
	790	^VA(200,"B ",^VA(200, ^2
	791	"KRN",.401 ,450006,2, 2,"QCON")
	792	I DISX(2)' =""
	793	"KRN",.401 ,450006,2, 2,"SER")
	794	0^0
	795	"KRN",.401 ,450006,2, 2,"TXT")
	796	NAME not null
	797	"KRN",.401 ,450006,2, "B",200,2)
	798
	799	"KRN",.401 ,450006,2, "B",200.02 ,1)
	800
	801	"KRN",.401 ,450006,"% D",0)
	802	^.4012^5^5 ^3121214^^ ^^
	803	"KRN",.401 ,450006,"% D",1,0)
	804	This sort template i s for the DEA EPCS p roject. T his suppor ts the
	805	"KRN",.401 ,450006,"% D",2,0)
	806	report for Prescribe rs with Co ntrolled S ubstance P rivileges. This
	807	"KRN",.401 ,450006,"% D",3,0)
	808	templates will sort on file #2 00, by div isions and by user.
	809	"KRN",.401 ,450006,"% D",4,0)
	810
	811	"KRN",.401 ,450006,"% D",5,0)
	812
	813	"KRN",.401 ,450007,-1 )
	814	0^2
	815	"KRN",.401 ,450007,0)
	816	PSO DEA DI SUSER2 SOR T^3181119. 1014^@^200 ^^@^319022 2
	817	"KRN",.401 ,450007,2, 0)
	818	^.4014^3^3
	819	"KRN",.401 ,450007,2, 1,0)
	820	200.02^^DI VISION^".0 1^^^^^^4
	821	"KRN",.401 ,450007,2, 1,1,0)
	822	^.40141^1^ 1
	823	"KRN",.401 ,450007,2, 1,1,1,0)
	824	200^2
	825	"KRN",.401 ,450007,2, 1,1,"B",20 0,1)
	826
	827	"KRN",.401 ,450007,2, 1,"CM")
	828	S Y(1)=$S( $D(^VA(200 ,D0,2,D1,0 )):^(0),1: "") S X=$P ($G(^DIC(4 ,+$P(Y(1), U,1),0)),U ) I D1>0 S DISX(1)=X
	829	"KRN",.401 ,450007,2, 1,"F")
	830	?z^@
	831	"KRN",.401 ,450007,2, 1,"GET")
	832	S Y(1)=$S( $D(^VA(200 ,D0,2,D1,0 )):^(0),1: "") S X=$P ($G(^DIC(4 ,+$P(Y(1), U,1),0)),U ) I D1>0 S DISX(1)=X
	833	"KRN",.401 ,450007,2, 1,"QCON")
	834	I 1
	835	"KRN",.401 ,450007,2, 1,"T")
	836	z^
	837	"KRN",.401 ,450007,2, 1,"TXT")
	838	All DIVISI ON (includ es null va lues)
	839	"KRN",.401 ,450007,2, 2,0)
	840	200^9.2^TE RMINATION DATE^-^^^^ ^^1
	841	"KRN",.401 ,450007,2, 2,"F")
	842	?z^@
	843	"KRN",.401 ,450007,2, 2,"GET")
	844	S DISX(2)= $P($G(^VA( 200,D0,0)) ,U,11)
	845	"KRN",.401 ,450007,2, 2,"QCON")
	846	I 1
	847	"KRN",.401 ,450007,2, 2,"SER")
	848	0.0000^0.0 000
	849	"KRN",.401 ,450007,2, 2,"T")
	850	z^
	851	"KRN",.401 ,450007,2, 2,"TXT")
	852	All TERMIN ATION DATE (includes null valu es)
	853	"KRN",.401 ,450007,2, 3,0)
	854	200^.01^NA ME^^^^^^^4
	855	"KRN",.401 ,450007,2, 3,"GET")
	856	S DISX(3)= $P($G(^VA( 200,D0,0)) ,U)
	857	"KRN",.401 ,450007,2, 3,"IX")
	858	^VA(200,"B ",^VA(200, ^2
	859	"KRN",.401 ,450007,2, 3,"QCON")
	860	I DISX(3)' =""
	861	"KRN",.401 ,450007,2, 3,"SER")
	862	0^0
	863	"KRN",.401 ,450007,2, 3,"TXT")
	864	NAME not null
	865	"KRN",.401 ,450007,2, "B",200,2)
	866
	867	"KRN",.401 ,450007,2, "B",200,3)
	868
	869	"KRN",.401 ,450007,2, "B",200.02 ,1)
	870
	871	"KRN",.401 ,450007,"% D",0)
	872	^.4012^4^4 ^3121214^^ ^^
	873	"KRN",.401 ,450007,"% D",1,0)
	874	This sort template i s for the DEA EPCS p roject. T his templa te will so rt
	875	"KRN",.401 ,450007,"% D",2,0)
	876	on file #2 00, by Div ision and Terminatio n Date.
	877	"KRN",.401 ,450007,"% D",3,0)
	878
	879	"KRN",.401 ,450007,"% D",4,0)
	880
	881	"KRN",.401 ,450008,-1 )
	882	0^3
	883	"KRN",.401 ,450008,0)
	884	PSO DEA PS DRPH SORT^ 3181119.10 25^@^200^^ @^3190222
	885	"KRN",.401 ,450008,2, 0)
	886	^.4014^3^3
	887	"KRN",.401 ,450008,2, 1,0)
	888	200.051^^K EY^@".01^^ ^^^^4
	889	"KRN",.401 ,450008,2, 1,1,0)
	890	^.40141^1^ 1
	891	"KRN",.401 ,450008,2, 1,1,1,0)
	892	200^51
	893	"KRN",.401 ,450008,2, 1,1,"B",20 0,1)
	894
	895	"KRN",.401 ,450008,2, 1,"CM")
	896	S Y(1)=$S( $D(^VA(200 ,D0,51,D1, 0)):^(0),1 :"") S X=$ P($G(^DIC( 19.1,+$P(Y (1),U,1),0 )),U) I D1 >0 S DISX( 1)=X
	897	"KRN",.401 ,450008,2, 1,"F")
	898	PSDRPGz^PS DRPH
	899	"KRN",.401 ,450008,2, 1,"GET")
	900	S Y(1)=$S( $D(^VA(200 ,D0,51,D1, 0)):^(0),1 :"") S X=$ P($G(^DIC( 19.1,+$P(Y (1),U,1),0 )),U) I D1 >0 S DISX( 1)=X
	901	"KRN",.401 ,450008,2, 1,"IX")
	902	^VA(200,"A B",^VA(200 ,^2
	903	"KRN",.401 ,450008,2, 1,"PTRIX")
	904	^DIC(19.1, "B",
	905	"KRN",.401 ,450008,2, 1,"QCON")
	906	I DISX(1)= "PSDRPH"
	907	"KRN",.401 ,450008,2, 1,"T")
	908	PSDRPH^PSD RPH
	909	"KRN",.401 ,450008,2, 1,"TXT")
	910	KEY equals PSDRPH
	911	"KRN",.401 ,450008,2, 2,0)
	912	200.02^^DI VISION^".0 1^^^^^^4
	913	"KRN",.401 ,450008,2, 2,1,0)
	914	^.40141^1^ 1
	915	"KRN",.401 ,450008,2, 2,1,1,0)
	916	200^2
	917	"KRN",.401 ,450008,2, 2,1,"B",20 0,1)
	918
	919	"KRN",.401 ,450008,2, 2,"CM")
	920	S Y(1)=$S( $D(^VA(200 ,D0,2,D1,0 )):^(0),1: "") S X=$P ($G(^DIC(4 ,+$P(Y(1), U,1),0)),U ) I D1>0 S DISX(2)=X
	921	"KRN",.401 ,450008,2, 2,"F")
	922	?z^@
	923	"KRN",.401 ,450008,2, 2,"GET")
	924	S Y(1)=$S( $D(^VA(200 ,D0,2,D1,0 )):^(0),1: "") S X=$P ($G(^DIC(4 ,+$P(Y(1), U,1),0)),U ) I D1>0 S DISX(2)=X
	925	"KRN",.401 ,450008,2, 2,"QCON")
	926	I 1
	927	"KRN",.401 ,450008,2, 2,"T")
	928	z^
	929	"KRN",.401 ,450008,2, 2,"TXT")
	930	All DIVISI ON (includ es null va lues)
	931	"KRN",.401 ,450008,2, 3,0)
	932	200^.01^NA ME^^^^^^^4
	933	"KRN",.401 ,450008,2, 3,"GET")
	934	S DISX(3)= $P($G(^VA( 200,D0,0)) ,U)
	935	"KRN",.401 ,450008,2, 3,"IX")
	936	^VA(200,"B ",^VA(200, ^2
	937	"KRN",.401 ,450008,2, 3,"QCON")
	938	I DISX(3)' =""
	939	"KRN",.401 ,450008,2, 3,"SER")
	940	0^0
	941	"KRN",.401 ,450008,2, 3,"TXT")
	942	NAME not null
	943	"KRN",.401 ,450008,2, "B",200,3)
	944
	945	"KRN",.401 ,450008,2, "B",200.02 ,2)
	946
	947	"KRN",.401 ,450008,2, "B",200.05 1,1)
	948
	949	"KRN",.401 ,450008,"% D",0)
	950	^.4012^4^4 ^3130228^^ ^^
	951	"KRN",.401 ,450008,"% D",1,0)
	952	This sort template i s for the ePCS DEA p roject wil l sort by security k ey
	953	"KRN",.401 ,450008,"% D",2,0)
	954	'PSDRPH' a nd Divisio n.. This sort templ ate will b e used for report to identify
	955	"KRN",.401 ,450008,"% D",3,0)
	956	individual s that hol d this key s.
	957	"KRN",.401 ,450008,"% D",4,0)
	958
	959	"KRN",.401 ,450009,-1 )
	960	0^4
	961	"KRN",.401 ,450009,0)
	962	PSO DEA SE T PARMS SO RT^3181119 .1314^@^20 0^^@^31902 22
	963	"KRN",.401 ,450009,2, 0)
	964	^.4014^2^2
	965	"KRN",.401 ,450009,2, 1,0)
	966	200.051^^K EY^@".01^^ ^^^^4
	967	"KRN",.401 ,450009,2, 1,1,0)
	968	^.40141^1^ 1
	969	"KRN",.401 ,450009,2, 1,1,1,0)
	970	200^51
	971	"KRN",.401 ,450009,2, 1,1,"B",20 0,1)
	972
	973	"KRN",.401 ,450009,2, 1,"CM")
	974	S Y(1)=$S( $D(^VA(200 ,D0,51,D1, 0)):^(0),1 :"") S X=$ P($G(^DIC( 19.1,+$P(Y (1),U,1),0 )),U) I D1 >0 S DISX( 1)=X
	975	"KRN",.401 ,450009,2, 1,"F")
	976	XUEPCSEDIS z^XUEPCSED IT
	977	"KRN",.401 ,450009,2, 1,"GET")
	978	S Y(1)=$S( $D(^VA(200 ,D0,51,D1, 0)):^(0),1 :"") S X=$ P($G(^DIC( 19.1,+$P(Y (1),U,1),0 )),U) I D1 >0 S DISX( 1)=X
	979	"KRN",.401 ,450009,2, 1,"IX")
	980	^VA(200,"A B",^VA(200 ,^2
	981	"KRN",.401 ,450009,2, 1,"PTRIX")
	982	^DIC(19.1, "B",
	983	"KRN",.401 ,450009,2, 1,"QCON")
	984	I DISX(1)= "XUEPCSEDI T"
	985	"KRN",.401 ,450009,2, 1,"T")
	986	XUEPCSEDIT ^XUEPCSEDI T
	987	"KRN",.401 ,450009,2, 1,"TXT")
	988	KEY equals XUEPCSEDI T
	989	"KRN",.401 ,450009,2, 2,0)
	990	200^.01^NA ME^^^^^^^4
	991	"KRN",.401 ,450009,2, 2,"GET")
	992	S DISX(2)= $P($G(^VA( 200,D0,0)) ,U)
	993	"KRN",.401 ,450009,2, 2,"IX")
	994	^VA(200,"B ",^VA(200, ^2
	995	"KRN",.401 ,450009,2, 2,"QCON")
	996	I DISX(2)' =""
	997	"KRN",.401 ,450009,2, 2,"SER")
	998	0^0
	999	"KRN",.401 ,450009,2, 2,"TXT")
	1000	NAME not null
	1001	"KRN",.401 ,450009,2, "B",200,2)
	1002
	1003	"KRN",.401 ,450009,2, "B",200.05 1,1)
	1004
	1005	"KRN",.401 ,450009,"% D",0)
	1006	^.4012^3^3 ^3121213^^ ^^
	1007	"KRN",.401 ,450009,"% D",1,0)
	1008	This sort template i s for the ePCS DEA p roject wil l sort by security k ey
	1009	"KRN",.401 ,450009,"% D",2,0)
	1010	'XUEPCSEDI T'. This sort templ ate will b e used for report to identify
	1011	"KRN",.401 ,450009,"% D",3,0)
	1012	individual s responsi ble for se tting ePCS parameter s.
	1013	"KRN",19,2 921830,-1)
	1014	0^2
	1015	"KRN",19,2 921830,0)
	1016	PSO EPCS E XPIRE DATE REPORT^DE A Expirati on Date Re port^^R^^^ ^^^^^OUTPA TIENT PHAR MACY
	1017	"KRN",19,2 921830,1,0 )
	1018	^^23^23^31 81116^
	1019	"KRN",19,2 921830,1,1 ,0)
	1020	This optio n can be u sed to pri nt the DEA Expiratio n Date for all activ e
	1021	"KRN",19,2 921830,1,2 ,0)
	1022	users.
	1023	"KRN",19,2 921830,1,3 ,0)
	1024	It provide s the foll owing crit eria to ch eck the DE A expirati on status:
	1025	"KRN",19,2 921830,1,4 ,0)
	1026
	1027	"KRN",19,2 921830,1,5 ,0)
	1028
	1029	"KRN",19,2 921830,1,6 ,0)
	1030	Report req uires 132 Columns
	1031	"KRN",19,2 921830,1,7 ,0)
	1032
	1033	"KRN",19,2 921830,1,8 ,0)
	1034	Selec t one of t he followi ng:
	1035	"KRN",19,2 921830,1,9 ,0)
	1036
	1037	"KRN",19,2 921830,1,1 0,0)
	1038	A Active
	1039	"KRN",19,2 921830,1,1 1,0)
	1040	D DISUSERed
	1041	"KRN",19,2 921830,1,1 2,0)
	1042	B Both
	1043	"KRN",19,2 921830,1,1 3,0)
	1044
	1045	"KRN",19,2 921830,1,1 4,0)
	1046	CPRS Syste m Access: Active
	1047	"KRN",19,2 921830,1,1 5,0)
	1048
	1049	"KRN",19,2 921830,1,1 6,0)
	1050	Selec t one of t he followi ng:
	1051	"KRN",19,2 921830,1,1 7,0)
	1052
	1053	"KRN",19,2 921830,1,1 8,0)
	1054	E EXPIRED
	1055	"KRN",19,2 921830,1,1 9,0)
	1056	N NO EXP DAT E
	1057	"KRN",19,2 921830,1,2 0,0)
	1058	3 <30-DAYS
	1059	"KRN",19,2 921830,1,2 1,0)
	1060	9 <90-DAYS
	1061	"KRN",19,2 921830,1,2 2,0)
	1062
	1063	"KRN",19,2 921830,1,2 3,0)
	1064	Expiration Date Stat us:
	1065	"KRN",19,2 921830,25)
	1066	EN^PSODEAR P
	1067	"KRN",19,2 921830,"U" )
	1068	DEA EXPIRA TION DATE REPORT
	1069	"KRN",19,2 921831,-1)
	1070	0^3
	1071	"KRN",19,2 921831,0)
	1072	PSO EPCS P RIVS^Print Prescribe rs with Pr ivileges^^ P^^^^^^^^O UTPATIENT PHARMACY
	1073	"KRN",19,2 921831,1,0 )
	1074	^19.06^3^3 ^3181120^^ ^
	1075	"KRN",19,2 921831,1,1 ,0)
	1076	This optio n is for t he DEA ePC S project and will p rint all a ctive user s
	1077	"KRN",19,2 921831,1,2 ,0)
	1078	who have p rivileges to any of the SCHEDU LEs II thr ough V and who have a
	1079	"KRN",19,2 921831,1,3 ,0)
	1080	DEA# or VA #. This o ption prin ts the NAM E, SCHEDUL ES, VA#, D UZ and DEA #.
	1081	"KRN",19,2 921831,60)
	1082	VA(200,
	1083	"KRN",19,2 921831,62)
	1084	0
	1085	"KRN",19,2 921831,63)
	1086	[PSO DEA P RIVS PRINT ]
	1087	"KRN",19,2 921831,64)
	1088	[PSO DEA D IV SORT]
	1089	"KRN",19,2 921831,69)
	1090	I $$VUSER2 ^PSODEART( D0,1)
	1091	"KRN",19,2 921831,"U" )
	1092	PRINT PRES CRIBERS WI TH PRIVILE
	1093	"KRN",19,2 921832,-1)
	1094	0^4
	1095	"KRN",19,2 921832,0)
	1096	PSO EPCS D ISUSER PRI VS^Print D ISUSER Pre scribers w ith Privil eges^^P^^^ ^^^^^OUTPA TIENT PHAR MACY
	1097	"KRN",19,2 921832,1,0 )
	1098	^^4^4^3181 116^
	1099	"KRN",19,2 921832,1,1 ,0)
	1100	This optio n is for t he DEA ePC S project and will p rint all D ISUSER use rs
	1101	"KRN",19,2 921832,1,2 ,0)
	1102	who have p rivileges to any of the SCHEDU LEs II thr ough V and who have a
	1103	"KRN",19,2 921832,1,3 ,0)
	1104	DEA# or VA #. This o ption prin ts the NAM E, SCHEDUL ESs, VA#, DUZ,
	1105	"KRN",19,2 921832,1,4 ,0)
	1106	TERMINATIO N DATE and DEA#.
	1107	"KRN",19,2 921832,60)
	1108	VA(200,
	1109	"KRN",19,2 921832,62)
	1110	0
	1111	"KRN",19,2 921832,63)
	1112	[PSO DEA D ISUSER PRI VS PRINT]
	1113	"KRN",19,2 921832,64)
	1114	[PSO DEA D ISUSER2 SO RT]
	1115	"KRN",19,2 921832,69)
	1116	I $$VUSER2 ^PSODEART( D0,0)
	1117	"KRN",19,2 921832,"U" )
	1118	PRINT DISU SER PRESCR IBERS WITH
	1119	"KRN",19,2 921833,-1)
	1120	0^5
	1121	"KRN",19,2 921833,0)
	1122	PSO EPCS P SDRPH^Prin t PSDRPH K ey Holders ^^P^^^^^^^ ^OUTPATIEN T PHARMACY
	1123	"KRN",19,2 921833,1,0 )
	1124	^^4^4^3181 116^
	1125	"KRN",19,2 921833,1,1 ,0)
	1126	This optio n is for t he DEA ePC S project and will p rint all a ctive user s
	1127	"KRN",19,2 921833,1,2 ,0)
	1128	holding th e PSDRPH k ey. This r eport will sort by d ivision an d within
	1129	"KRN",19,2 921833,1,3 ,0)
	1130	division i t sorts by name. Th is report will print name, duz , person w ho
	1131	"KRN",19,2 921833,1,4 ,0)
	1132	assigned k ey and dat e assigned .
	1133	"KRN",19,2 921833,60)
	1134	VA(200,
	1135	"KRN",19,2 921833,62)
	1136	0
	1137	"KRN",19,2 921833,63)
	1138	[PSO DEA P SDRPH PRIN T]
	1139	"KRN",19,2 921833,64)
	1140	[PSO DEA P SDRPH SORT ]
	1141	"KRN",19,2 921833,69)
	1142	I $$ACTIVE ^XUSER(D0)
	1143	"KRN",19,2 921833,"U" )
	1144	PRINT PSDR PH KEY HOL DERS
	1145	"KRN",19,2 921834,-1)
	1146	0^6
	1147	"KRN",19,2 921834,0)
	1148	PSO EPCS S ET PARMS^P rint Setti ng Paramet ers Privil eges^^P^^^ ^^^^^OUTPA TIENT PHAR MACY
	1149	"KRN",19,2 921834,1,0 )
	1150	^^3^3^3181 116^
	1151	"KRN",19,2 921834,1,1 ,0)
	1152	This optio n is for t he DEA ePC S project and will p rint all a ctive user s
	1153	"KRN",19,2 921834,1,2 ,0)
	1154	holding th e XUEPCSED IT key. Th is report will ident ify indivi duals
	1155	"KRN",19,2 921834,1,3 ,0)
	1156	responsibl e for sett ing the pa rameters.
	1157	"KRN",19,2 921834,60)
	1158	VA(200,
	1159	"KRN",19,2 921834,62)
	1160	0
	1161	"KRN",19,2 921834,63)
	1162	[PSO DEA S ET PARMS P RINT]
	1163	"KRN",19,2 921834,64)
	1164	[PSO DEA S ET PARMS S ORT]
	1165	"KRN",19,2 921834,69)
	1166	I $$ACTIVE ^XUSER(D0)
	1167	"KRN",19,2 921834,"U" )
	1168	PRINT SETT ING PARAME TERS PRIVI
	1169	"KRN",19,2 921835,-1)
	1170	0^7
	1171	"KRN",19,2 921835,0)
	1172	PSO EPCS P RINT EDIT AUDIT^Prin t Audits f or Prescri ber Editin g^^R^^^^^^ ^^OUTPATIE NT PHARMAC Y
	1173	"KRN",19,2 921835,1,0 )
	1174	^19.06^3^3 ^3181121^^
	1175	"KRN",19,2 921835,1,1 ,0)
	1176	This optio n provides the abili ty to prin t informat ion relate d to the
	1177	"KRN",19,2 921835,1,2 ,0)
	1178	editing of prescribe r informat ion relate d to elect ronic Pres cribing of
	1179	"KRN",19,2 921835,1,3 ,0)
	1180	Controlled Substance s.
	1181	"KRN",19,2 921835,25)
	1182	PRINT^PSOD EAED
	1183	"KRN",19,2 921835,"U" )
	1184	PRINT AUDI TS FOR PRE SCRIBER ED
	1185	"KRN",19,2 921836,-1)
	1186	0^8
	1187	"KRN",19,2 921836,0)
	1188	PSO EPCS L OGICAL ACC ESS REPORT ^Changes t o DEA Pres cribing Pr ivileges R eport^^R^^ ^^^^^^^^1^ 1
	1189	"KRN",19,2 921836,1,0 )
	1190	^^5^5^3181 116^
	1191	"KRN",19,2 921836,1,1 ,0)
	1192	This is an on-demand report op tion that will print the setti ng or
	1193	"KRN",19,2 921836,1,2 ,0)
	1194	change to DEA prescr ibing priv ileges rel ated to is suance of controlled
	1195	"KRN",19,2 921836,1,3 ,0)
	1196	substance prescripti on. It'll prompt for a date ra nge and wi ll print d ata
	1197	"KRN",19,2 921836,1,4 ,0)
	1198	that has b een modifi ed. The da ta is retr ieved from the XUEPC S DATA fil e
	1199	"KRN",19,2 921836,1,5 ,0)
	1200	(#8991.6).
	1201	"KRN",19,2 921836,15)
	1202	K PSORPT
	1203	"KRN",19,2 921836,20)
	1204	S PSORPT=1
	1205	"KRN",19,2 921836,25)
	1206	ODRPT^PSOD EART
	1207	"KRN",19,2 921836,"U" )
	1208	CHANGES TO DEA PRESC RIBING PRI
	1209	"KRN",19,2 921837,-1)
	1210	0^9
	1211	"KRN",19,2 921837,0)
	1212	PSO EPCS P HARMACIST ACC REPORT ^Allocatio n Audit of PSDRPH Ke y Report^^ R^^^^^^^^O UTPATIENT PHARMACY^^ 1^1
	1213	"KRN",19,2 921837,1,0 )
	1214	^^4^4^3181 116^
	1215	"KRN",19,2 921837,1,1 ,0)
	1216	This is an on-demand report op tion that will print the alloc ation of t he
	1217	"KRN",19,2 921837,1,2 ,0)
	1218	PSDRPH key . It'll pr ompt for a date rang e and will print the allocatio n of
	1219	"KRN",19,2 921837,1,3 ,0)
	1220	the PSDRPH key data that has b een modifi ed. The da ta is retr ieved from the
	1221	"KRN",19,2 921837,1,4 ,0)
	1222	XUEPCS PSD RPH AUDIT file (#899 1.7).
	1223	"KRN",19,2 921837,15)
	1224	K PSORPT
	1225	"KRN",19,2 921837,20)
	1226	S PSORPT=2
	1227	"KRN",19,2 921837,25)
	1228	ODRPT^PSOD EART
	1229	"KRN",19,2 921837,"U" )
	1230	ALLOCATION AUDIT OF PSDRPH KEY
	1231	"KRN",19,2 921838,-1)
	1232	0^10
	1233	"KRN",19,2 921838,0)
	1234	PSO EPCS A CCESS REPO RT PARAM^E nter/Edit EPCS Acces s Reports Parameters ^^R^^^^^^^ ^OUTPATIEN T PHARMACY
	1235	"KRN",19,2 921838,1,0 )
	1236	^^8^8^3181 207^
	1237	"KRN",19,2 921838,1,1 ,0)
	1238	This optio n will hel p the site s to setup the print er device and the em ail
	1239	"KRN",19,2 921838,1,2 ,0)
	1240	group rela ted to the following options:
	1241	"KRN",19,2 921838,1,3 ,0)
	1242
	1243	"KRN",19,2 921838,1,4 ,0)
	1244
	1245	"KRN",19,2 921838,1,5 ,0)
	1246	1 PSOEPCS PH ARM ACC RP T DEVICE
	1247	"KRN",19,2 921838,1,6 ,0)
	1248	2 PSOEPCS PH ARM ACC RE PORT EMAIL
	1249	"KRN",19,2 921838,1,7 ,0)
	1250	3 PSOEPCS LO GICAL ACC REPORT DEV
	1251	"KRN",19,2 921838,1,8 ,0)
	1252	4 PSOEPCS LO GICAL ACC RPT EMAIL
	1253	"KRN",19,2 921838,25)
	1254	PARAM^PSOD EART
	1255	"KRN",19,2 921838,"U" )
	1256	ENTER/EDIT EPCS ACCE SS REPORTS
	1257	"KRN",19,2 921839,-1)
	1258	0^11
	1259	"KRN",19,2 921839,0)
	1260	PSO EPCS E XPIRED DEA FAILOVER^ Allow VA N umber if D EA Number Expired^^R ^^^^^^^^OU TPATIENT P HARMACY
	1261	"KRN",19,2 921839,1,0 )
	1262	^^3^3^3181 116^
	1263	"KRN",19,2 921839,1,1 ,0)
	1264	This optio n will all ow the sit es to turn off the e xpired DEA number "f ail
	1265	"KRN",19,2 921839,1,2 ,0)
	1266	over" func tionality so that th e renewal of a provi der's expi red DEA
	1267	"KRN",19,2 921839,1,3 ,0)
	1268	number can be enforc ed.
	1269	"KRN",19,2 921839,25)
	1270	FAIL^PSODE ART
	1271	"KRN",19,2 921839,"U" )
	1272	ALLOW VA N UMBER IF D EA NUMBER
	1273	"KRN",19,2 921840,-1)
	1274	0^12
	1275	"KRN",19,2 921840,0)
	1276	PSO VAMC M BM PHARMAC Y MODE^Set Pharmacy Operating Mode^^R^^^ ^^^^^OUTPA TIENT PHAR MACY
	1277	"KRN",19,2 921840,1,0 )
	1278	^^3^3^3181 116^
	1279	"KRN",19,2 921840,1,1 ,0)
	1280	This optio n will all ow sites t o turn off the warni ng message confirmat ion
	1281	"KRN",19,2 921840,1,2 ,0)
	1282	prompt ass ociated wi th selecti ng a provi der withou t a CPRS a ccount for
	1283	"KRN",19,2 921840,1,3 ,0)
	1284	Meds by Ma il sites r unning Vis tA as thei r pharmacy package.
	1285	"KRN",19,2 921840,25)
	1286	MBM^PSODEA RT
	1287	"KRN",19,2 921840,"U" )
	1288	SET PHARMA CY OPERATI NG MODE
	1289	"KRN",19,2 921841,-1)
	1290	0^13
	1291	"KRN",19,2 921841,0)
	1292	PSO EPCS E DIT DEA# A ND XDATE^E dit Facili ty DEA# an d Expirati on Date^^E ^^^^^^^^OU TPATIENT P HARMACY
	1293	"KRN",19,2 921841,1,0 )
	1294	^^2^2^3181 116^
	1295	"KRN",19,2 921841,1,1 ,0)
	1296	This optio n is for t he DEA ePC S project and will a llow users to edit t he
	1297	"KRN",19,2 921841,1,2 ,0)
	1298	facility D EA# and Ex piration D ate in Ins titution f ile (#4).
	1299	"KRN",19,2 921841,30)
	1300	DIC(4,
	1301	"KRN",19,2 921841,31)
	1302	AEMQ
	1303	"KRN",19,2 921841,50)
	1304	DIC(4,
	1305	"KRN",19,2 921841,51)
	1306	52;52.1
	1307	"KRN",19,2 921841,"U" )
	1308	EDIT FACIL ITY DEA# A ND EXPIRAT
	1309	"KRN",19,2 921842,-1)
	1310	0^1
	1311	"KRN",19,2 921842,0)
	1312	PSO EPCS U TILITY FUN CTIONS^ePC S DEA Util ity Functi ons^^M^^^^ ^^^^OUTPAT IENT PHARM ACY
	1313	"KRN",19,2 921842,1,0 )
	1314	^19.06^2^2 ^3181207^^ ^^
	1315	"KRN",19,2 921842,1,1 ,0)
	1316	This optio n is for t he DEA ePC S project. This is t he main me nu to prin t
	1317	"KRN",19,2 921842,1,2 ,0)
	1318	all report s and util ity functi ons.
	1319	"KRN",19,2 921842,10, 0)
	1320	^19.01IP^2 4^12
	1321	"KRN",19,2 921842,10, 12,0)
	1322	2921840^11 ^11
	1323	"KRN",19,2 921842,10, 12,"^")
	1324	PSO VAMC M BM PHARMAC Y MODE
	1325	"KRN",19,2 921842,10, 14,0)
	1326	2921833^4^ 4
	1327	"KRN",19,2 921842,10, 14,"^")
	1328	PSO EPCS P SDRPH
	1329	"KRN",19,2 921842,10, 15,0)
	1330	2921834^5^ 5
	1331	"KRN",19,2 921842,10, 15,"^")
	1332	PSO EPCS S ET PARMS
	1333	"KRN",19,2 921842,10, 16,0)
	1334	2921831^2^ 2
	1335	"KRN",19,2 921842,10, 16,"^")
	1336	PSO EPCS P RIVS
	1337	"KRN",19,2 921842,10, 17,0)
	1338	2921841^12 ^12
	1339	"KRN",19,2 921842,10, 17,"^")
	1340	PSO EPCS E DIT DEA# A ND XDATE
	1341	"KRN",19,2 921842,10, 18,0)
	1342	2921835^6^ 6
	1343	"KRN",19,2 921842,10, 18,"^")
	1344	PSO EPCS P RINT EDIT AUDIT
	1345	"KRN",19,2 921842,10, 19,0)
	1346	2921832^3^ 3
	1347	"KRN",19,2 921842,10, 19,"^")
	1348	PSO EPCS D ISUSER PRI VS
	1349	"KRN",19,2 921842,10, 20,0)
	1350	2921836^7^ 7
	1351	"KRN",19,2 921842,10, 20,"^")
	1352	PSO EPCS L OGICAL ACC ESS REPORT
	1353	"KRN",19,2 921842,10, 21,0)
	1354	2921837^8^ 8
	1355	"KRN",19,2 921842,10, 21,"^")
	1356	PSO EPCS P HARMACIST ACC REPORT
	1357	"KRN",19,2 921842,10, 22,0)
	1358	2921830^1^ 1
	1359	"KRN",19,2 921842,10, 22,"^")
	1360	PSO EPCS E XPIRE DATE REPORT
	1361	"KRN",19,2 921842,10, 23,0)
	1362	2921839^10 ^10
	1363	"KRN",19,2 921842,10, 23,"^")
	1364	PSO EPCS E XPIRED DEA FAILOVER
	1365	"KRN",19,2 921842,10, 24,0)
	1366	2921838^9^ 9
	1367	"KRN",19,2 921842,10, 24,"^")
	1368	PSO EPCS A CCESS REPO RT PARAM
	1369	"KRN",19,2 921842,99)
	1370	64989,4130 4
	1371	"KRN",19,2 921842,161 3)
	1372	EPCS MGR
	1373	"KRN",19,2 921842,"U" )
	1374	EPCS DEA U TILITY FUN CTIONS
	1375	"KRN",19,2 921844,-1)
	1376	0^15
	1377	"KRN",19,2 921844,0)
	1378	PSO EPCS L OGICAL ACC ESS^Task C hanges to DEA Prescr ibing Priv ileges Rep ort^^R^^^^ ^^^^OUTPAT IENT PHARM ACY
	1379	"KRN",19,2 921844,1,0 )
	1380	^19.06^6^6 ^3190301^^ ^^
	1381	"KRN",19,2 921844,1,1 ,0)
	1382	This optio n is for t he DEA ePC S project and will p rint the s etting or
	1383	"KRN",19,2 921844,1,2 ,0)
	1384	change to DEA prescr ibing priv ileges rel ated to is suance of controlled
	1385	"KRN",19,2 921844,1,3 ,0)
	1386	substance prescripti on. The r eport will only prin t data fro m the
	1387	"KRN",19,2 921844,1,4 ,0)
	1388	previous d ay and wit h data tha t has been modified. The data is retrie ved
	1389	"KRN",19,2 921844,1,5 ,0)
	1390	from file #8991.6. This optio n should b e schedule d to run o n a daily
	1391	"KRN",19,2 921844,1,6 ,0)
	1392	basis.
	1393	"KRN",19,2 921844,25)
	1394	RPT1^PSODE ART
	1395	"KRN",19,2 921844,200 .9)
	1396	y
	1397	"KRN",19,2 921844,"U" )
	1398	TASK CHANG ES TO DEA PRESCRIBIN
	1399	"KRN",19,2 921845,-1)
	1400	0^16
	1401	"KRN",19,2 921845,0)
	1402	PSO EPCS P SDRPH AUDI T^Task All ocation Au dit of PSD RPH Key Re port^^R^^^ ^^^^^OUTPA TIENT PHAR MACY
	1403	"KRN",19,2 921845,1,0 )
	1404	^19.06^4^4 ^3190122^^ ^
	1405	"KRN",19,2 921845,1,1 ,0)
	1406	This optio n is for t he DEA ePC S project and will p rint the a llocation of
	1407	"KRN",19,2 921845,1,2 ,0)
	1408	the PSDRPH key. The report wi ll only pr int data f rom the pr evious day and
	1409	"KRN",19,2 921845,1,3 ,0)
	1410	with data that has b een modifi ed. The r eport prin ts data fo r the arch ive
	1411	"KRN",19,2 921845,1,4 ,0)
	1412	file #8991 .7. This option sho uld be sch eduled to run on a d aily basis .
	1413	"KRN",19,2 921845,25)
	1414	RPT2^PSODE ART
	1415	"KRN",19,2 921845,200 .9)
	1416	y
	1417	"KRN",19,2 921845,"U" )
	1418	TASK ALLOC ATION AUDI T OF PSDRP
	1419	"KRN",19,2 921846,-1)
	1420	0^17
	1421	"KRN",19,2 921846,0)
	1422	PSO EPCS P SDRPH KEY^ Allocate/D e-Allocate of PSDRPH Key^^R^^^ ^^^^^OUTPA TIENT PHAR MACY
	1423	"KRN",19,2 921846,1,0 )
	1424	^^2^2^3181 130^
	1425	"KRN",19,2 921846,1,1 ,0)
	1426	This optio n is for t he DEA ePC S project and will a llow users to alloca te
	1427	"KRN",19,2 921846,1,2 ,0)
	1428	or de-allo cate the P SDRPH key.
	1429	"KRN",19,2 921846,25)
	1430	PSDKEY^PSO DEART
	1431	"KRN",19,2 921846,"U" )
	1432	ALLOCATE/D E-ALLOCATE OF PSDRPH
	1433	"KRN",101, 8147,-1)
	1434	0^1
	1435	"KRN",101, 8147,0)
	1436	PSODEAME A CCEPT AND SAVE^ACCEP T AND SAVE CHANGES^^ A^^^^^^^^O UTPATIENT PHARMACY
	1437	"KRN",101, 8147,20)
	1438	D ACTIONA^ PSODEAME
	1439	"KRN",101, 8147,99)
	1440	64971,5227 5
	1441	"KRN",101, 8148,-1)
	1442	0^2
	1443	"KRN",101, 8148,0)
	1444	PSODEAME C OPY TO VIS TA^COPY DO J/DEA VALU ES TO VIST A^^A^^^^^^ ^^OUTPATIE NT PHARMAC Y
	1445	"KRN",101, 8148,20)
	1446	D ACTIONC^ PSODEAME
	1447	"KRN",101, 8148,99)
	1448	64971,5240 9
	1449	"KRN",101, 8149,-1)
	1450	0^3
	1451	"KRN",101, 8149,0)
	1452	PSODEAME E DIT VISTA VALUES^EDI T VISTA VA LUES^^A^^^ ^^^^^OUTPA TIENT PHAR MACY
	1453	"KRN",101, 8149,4)
	1454	^^^E
	1455	"KRN",101, 8149,20)
	1456	D ACTIONE^ PSODEAME
	1457	"KRN",101, 8149,99)
	1458	64971,5251 3
	1459	"KRN",101, 8150,-1)
	1460	0^5
	1461	"KRN",101, 8150,0)
	1462	PSODEAME Q UIT AND RE JECT^QUIT AND REJECT CHANGES^^ A^^^^^^^^O UTPATIENT PHARMACY
	1463	"KRN",101, 8150,20)
	1464	D ACTIONX^ PSODEAME
	1465	"KRN",101, 8150,99)
	1466	64971,5262 4
	1467	"KRN",101, 8151,-1)
	1468	0^4
	1469	"KRN",101, 8151,0)
	1470	PSODEAME M ENU^MENU^^ M^^^^^^^^O UTPATIENT PHARMACY
	1471	"KRN",101, 8151,4)
	1472	39^2
	1473	"KRN",101, 8151,10,0)
	1474	^101.01PA^ 4^4
	1475	"KRN",101, 8151,10,1, 0)
	1476	8148^C^1^
	1477	"KRN",101, 8151,10,1, "^")
	1478	PSODEAME C OPY TO VIS TA
	1479	"KRN",101, 8151,10,2, 0)
	1480	8149^E^2^
	1481	"KRN",101, 8151,10,2, "^")
	1482	PSODEAME E DIT VISTA VALUES
	1483	"KRN",101, 8151,10,3, 0)
	1484	8147^A^3^
	1485	"KRN",101, 8151,10,3, "^")
	1486	PSODEAME A CCEPT AND SAVE
	1487	"KRN",101, 8151,10,4, 0)
	1488	8150^X^4^
	1489	"KRN",101, 8151,10,4, "^")
	1490	PSODEAME Q UIT AND RE JECT
	1491	"KRN",101, 8151,26)
	1492	D SHOW^VAL M
	1493	"KRN",101, 8151,99)
	1494	64972,4525 1
	1495	"KRN",409. 61,790,-1)
	1496	0^1
	1497	"KRN",409. 61,790,0)
	1498	PSO DEA NU MBER MANAG EMENT^1^^8 0^4^20^0^1 ^^PSODEAME MENU^DEA NUMBER MAN AGEMENT^1^ ^1
	1499	"KRN",409. 61,790,1)
	1500	^VALM HIDD EN ACTIONS
	1501	"KRN",409. 61,790,"CO L",0)
	1502	^409.621^3 ^3
	1503	"KRN",409. 61,790,"CO L",1,0)
	1504	NAME^2^17^ NAME^^0
	1505	"KRN",409. 61,790,"CO L",2,0)
	1506	DOJ/DEA VA LUE^20^29^ DOJ/DEA VA LUE^^0
	1507	"KRN",409. 61,790,"CO L",3,0)
	1508	LOCAL VALU E^50^30^LO CAL VALUE^ ^0
	1509	"KRN",409. 61,790,"CO L","AIDENT ",0,1)
	1510
	1511	"KRN",409. 61,790,"CO L","AIDENT ",0,2)
	1512
	1513	"KRN",409. 61,790,"CO L","AIDENT ",0,3)
	1514
	1515	"KRN",409. 61,790,"CO L","B","DO J/DEA VALU E",2)
	1516
	1517	"KRN",409. 61,790,"CO L","B","LO CAL VALUE" ,3)
	1518
	1519	"KRN",409. 61,790,"CO L","B","NA ME",1)
	1520
	1521	"KRN",409. 61,790,"FN L")
	1522	D EXIT^PSO DEAME
	1523	"KRN",409. 61,790,"HD R")
	1524	D HDR^PSOD EAME
	1525	"KRN",409. 61,790,"HL P")
	1526	D HELP^PSO DEAME
	1527	"KRN",409. 61,790,"IN IT")
	1528	D INIT^PSO DEAME
	1529	"KRN",8989 .5,301777, 0)
	1530	170;DIC(9. 4,^PSO VAM C MBM PHAR MACY MODE^ 2
	1531	"KRN",8989 .5,301777, 1)
	1532	VAMC
	1533	"KRN",8989 .5,301779, 0)
	1534	170;DIC(9. 4,^PSO VAM C MBM PHAR MACY MODE^ 1
	1535	"KRN",8989 .5,301779, 1)
	1536	V
	1537	"KRN",8989 .5,301783, 0)
	1538	170;DIC(9. 4,^PSOEPCS EXPIRED D EA FAILOVE R^1
	1539	"KRN",8989 .5,301783, 1)
	1540	Y
	1541	"KRN",8989 .51,865,-1 )
	1542	0^1
	1543	"KRN",8989 .51,865,0)
	1544	PSO VAMC M BM PHARMAC Y MODE^Set Pharmacy Operation Mode^0
	1545	"KRN",8989 .51,865,1)
	1546	S^V:VAMC;M :MBM^Pharm acy Operat ing Mode S election, VAMC OR MB M
	1547	"KRN",8989 .51,865,20 ,0)
	1548	^8989.512^ 4^4^318120 7^^
	1549	"KRN",8989 .51,865,20 ,1,0)
	1550	Choose Pha rmacy Oper ating Mode as VAMC t o utilize business r ules
	1551	"KRN",8989 .51,865,20 ,2,0)
	1552	appropriat e to the t raditional VA pharma cy setting .
	1553	"KRN",8989 .51,865,20 ,3,0)
	1554	Choose Pha rmacy Oper ating Mode as MBM to utilize b usiness ru les specif ic
	1555	"KRN",8989 .51,865,20 ,4,0)
	1556	for the Me ds by Mail pharmacy setting.
	1557	"KRN",8989 .51,865,30 ,0)
	1558	^8989.513I ^2^2
	1559	"KRN",8989 .51,865,30 ,1,0)
	1560	1^9.4
	1561	"KRN",8989 .51,865,30 ,2,0)
	1562	2^4.2
	1563	"KRN",8989 .51,866,-1 )
	1564	0^7
	1565	"KRN",8989 .51,866,0)
	1566	PSOEPCS EX PIRED DEA FAILOVER^A llow VA Nu mber if DE A Number E xpired^0
	1567	"KRN",8989 .51,866,1)
	1568	Y^^YES = a llow provi der with e xpired DEA # to order CS with a VA#
	1569	"KRN",8989 .51,866,2)
	1570	D FOM^PSOD EART
	1571	"KRN",8989 .51,866,20 ,0)
	1572	^^6^6^3181 119^
	1573	"KRN",8989 .51,866,20 ,1,0)
	1574	Entering a value of YES will a llow a pro vider with an expire d DEA numb er
	1575	"KRN",8989 .51,866,20 ,2,0)
	1576	to be able to prescr ibe contro lled subst ances base d on their VA number .
	1577	"KRN",8989 .51,866,20 ,3,0)
	1578	Entering a value of NO will no t allow a provider w ith an exp ired DEA
	1579	"KRN",8989 .51,866,20 ,4,0)
	1580	number to be able to prescribe controlle d substanc es. A prov ider witho ut a
	1581	"KRN",8989 .51,866,20 ,5,0)
	1582	DEA number will stil l be able to prescri be control led substa nces if th ey
	1583	"KRN",8989 .51,866,20 ,6,0)
	1584	have a VA number ent ered in Vi stA.
	1585	"KRN",8989 .51,866,30 ,0)
	1586	^8989.513I ^1^1
	1587	"KRN",8989 .51,866,30 ,1,0)
	1588	1^4.2
	1589	"KRN",8989 .51,867,-1 )
	1590	0^8
	1591	"KRN",8989 .51,867,0)
	1592	PSOEPCS LO GICAL ACC REPORT DEV ^Device fo r Logical Access Rep ort^0^^Sel ect device for logic al access report
	1593	"KRN",8989 .51,867,1)
	1594	P^3.5^Ente r a device from the Device fil e for ePCS logical a ccess repo rt output.
	1595	"KRN",8989 .51,867,20 ,0)
	1596	^^1^1^3181 207^
	1597	"KRN",8989 .51,867,20 ,1,0)
	1598	It will se t the devi ce for the logical a ccess repo rt output.
	1599	"KRN",8989 .51,867,30 ,0)
	1600	^8989.513I ^1^1
	1601	"KRN",8989 .51,867,30 ,1,0)
	1602	1^4.2
	1603	"KRN",8989 .51,868,-1 )
	1604	0^9
	1605	"KRN",8989 .51,868,0)
	1606	PSOEPCS LO GICAL ACC RPT EMAIL^ Email Grou p for Logi cal Access Report^0^ ^Select Lo gical Acce ss Report Email Grou p
	1607	"KRN",8989 .51,868,1)
	1608	P^3.8^Ente r a mail g roup for t he ePCS lo gical acce ss report output.
	1609	"KRN",8989 .51,868,20 ,0)
	1610	^8989.512^ 1^1^318120 7^^
	1611	"KRN",8989 .51,868,20 ,1,0)
	1612	It will se t the emai l group fo r the logi cal access report ou tput.
	1613	"KRN",8989 .51,868,30 ,0)
	1614	^8989.513I ^1^1
	1615	"KRN",8989 .51,868,30 ,1,0)
	1616	1^4.2
	1617	"KRN",8989 .51,869,-1 )
	1618	0^11
	1619	"KRN",8989 .51,869,0)
	1620	PSOEPCS PH ARM ACC RP T DEVICE^D evice for Pharmacist access re port^0^^Se lect devic e for Phar macist Acc Report
	1621	"KRN",8989 .51,869,1)
	1622	P^3.5^Ente r a device from the Device fil e for phar macist acc report
	1623	"KRN",8989 .51,869,20 ,0)
	1624	^^1^1^3181 207^
	1625	"KRN",8989 .51,869,20 ,1,0)
	1626	It will se t the devi ce for the Pharmacis t Access R eport outp ut.
	1627	"KRN",8989 .51,869,30 ,0)
	1628	^8989.513I ^1^1
	1629	"KRN",8989 .51,869,30 ,1,0)
	1630	1^4.2
	1631	"KRN",8989 .51,870,-1 )
	1632	0^10
	1633	"KRN",8989 .51,870,0)
	1634	PSOEPCS PH ARM ACC RE PORT EMAIL ^Email Gro up for Pha rmacist Ac cess Repor t^0^^Selec t Pharmaci st Acc Rep ort Email Group
	1635	"KRN",8989 .51,870,1)
	1636	P^3.8^Ente r a mail g roup for P harmacist Access Rep ort
	1637	"KRN",8989 .51,870,20 ,0)
	1638	^8989.512^ 1^1^318120 7^^
	1639	"KRN",8989 .51,870,20 ,1,0)
	1640	It will se t the emai l group fo r the Phar macist Acc ess Report .
	1641	"KRN",8989 .51,870,30 ,0)
	1642	^8989.513I ^1^1
	1643	"KRN",8989 .51,870,30 ,1,0)
	1644	1^4.2
	1645	"MBREQ")
	1646	0
	1647	"ORD",5,.4 )
	1648	.4;5;;;EDE OUT^DIFROM SO(.4,DA," ",XPDA);FP RE^DIFROMS I(.4,"",XP DA);EPRE^D IFROMSI(.4 ,DA,$E("N" ,$G(XPDNEW )),XPDA,"" ,OLDA);;EP OST^DIFROM SI(.4,DA," ",XPDA);DE L^DIFROMSK (.4,"",%)
	1649	"ORD",5,.4 ,0)
	1650	PRINT TEMP LATE
	1651	"ORD",6,.4 01)
	1652	.401;6;;;E DEOUT^DIFR OMSO(.401, DA,"",XPDA );FPRE^DIF ROMSI(.401 ,"",XPDA); EPRE^DIFRO MSI(.401,D A,$E("N",$ G(XPDNEW)) ,XPDA,"",O LDA);;EPOS T^DIFROMSI (.401,DA," ",XPDA);DE L^DIFROMSK (.401,"",% )
	1653	"ORD",6,.4 01,0)
	1654	SORT TEMPL ATE
	1655	"ORD",15,1 01)
	1656	101;15;;;P RO^XPDTA;P ROF1^XPDIA ;PROE1^XPD IA;PROF2^X PDIA;;PROD EL^XPDIA
	1657	"ORD",15,1 01,0)
	1658	PROTOCOL
	1659	"ORD",17,4 09.61)
	1660	409.61;17; 1;;;;LME1^ XPDIA1;;;L MDEL^XPDIA 1
	1661	"ORD",17,4 09.61,0)
	1662	LIST TEMPL ATE
	1663	"ORD",18,1 9)
	1664	19;18;;;OP T^XPDTA;OP TF1^XPDIA; OPTE1^XPDI A;OPTF2^XP DIA;;OPTDE L^XPDIA
	1665	"ORD",18,1 9,0)
	1666	OPTION
	1667	"ORD",20,8 989.51)
	1668	8989.51;20 ;;;PAR1E1^ XPDTA2;PAR 1F1^XPDIA3 ;PAR1E1^XP DIA3;PAR1F 2^XPDIA3;; PAR1DEL^XP DIA3(%)
	1669	"ORD",20,8 989.51,0)
	1670	PARAMETER DEFINITION
	1671	"PKG",170, -1)
	1672	1^1
	1673	"PKG",170, 0)
	1674	OUTPATIENT PHARMACY^ PSO^OUTPAT IENT LABEL S, PROFILE , INVENTOR Y, PRESCRI PTIONS
	1675	"PKG",170, 20,0)
	1676	^9.402P^^
	1677	"PKG",170, 22,0)
	1678	^9.49I^1^1
	1679	"PKG",170, 22,1,0)
	1680	7.0^297121 6^2981113^ 1
	1681	"PKG",170, 22,1,"PAH" ,1,0)
	1682	545^319030 1
	1683	"PKG",170, 22,1,"PAH" ,1,1,0)
	1684	^^149^149^ 3190301
	1685	"PKG",170, 22,1,"PAH" ,1,1,1,0)
	1686	The Clinic al Ancilla ry Service s (CAS) - Medication Permissio n/Dispensi ng
	1687	"PKG",170, 22,1,"PAH" ,1,1,2,0)
	1688	Updates (M PDU) proje ct provide s the abil ity to sup port multi ple DEA
	1689	"PKG",170, 22,1,"PAH" ,1,1,3,0)
	1690	Numbers fo r a user.
	1691	"PKG",170, 22,1,"PAH" ,1,1,4,0)
	1692
	1693	"PKG",170, 22,1,"PAH" ,1,1,5,0)
	1694	This patch PSO7545 is part o f a group of patches for this enhancemen t
	1695	"PKG",170, 22,1,"PAH" ,1,1,6,0)
	1696	and must b e installe d after co mpletion o f installa tion of pa tches
	1697	"PKG",170, 22,1,"PAH" ,1,1,7,0)
	1698	XU8688 a nd PSO75 29. The fo llowing ot her patche s for this enhanceme nt
	1699	"PKG",170, 22,1,"PAH" ,1,1,8,0)
	1700	will be re leased in the future and inclu des: XU8 689, OR3 506,
	1701	"PKG",170, 22,1,"PAH" ,1,1,9,0)
	1702	PSJ5372, OR3488 and OR34 99.
	1703	"PKG",170, 22,1,"PAH" ,1,1,10,0)
	1704
	1705	"PKG",170, 22,1,"PAH" ,1,1,11,0)
	1706	This patch PSO7545 has the f ollowing e nhancement s:
	1707	"PKG",170, 22,1,"PAH" ,1,1,12,0)
	1708
	1709	"PKG",170, 22,1,"PAH" ,1,1,13,0)
	1710	1. The opt ions Add N ew Provide rs [PSO PR OVIDER ADD ] and Edit Provider
	1711	"PKG",170, 22,1,"PAH" ,1,1,14,0)
	1712	[PSO PR OVIDER EDI T] have be en modifie d with the following :
	1713	"PKG",170, 22,1,"PAH" ,1,1,15,0)
	1714	a. The following existing f ields have been hidd en and wil l not be
	1715	"PKG",170, 22,1,"PAH" ,1,1,16,0)
	1716	avai lable for editing:
	1717	"PKG",170, 22,1,"PAH" ,1,1,17,0)
	1718	Pres criber DEA # (field #53.2)
	1719	"PKG",170, 22,1,"PAH" ,1,1,18,0)
	1720	Pres criber DEA expiratio n date (fi eld #747.4 4)
	1721	"PKG",170, 22,1,"PAH" ,1,1,19,0)
	1722	Pres criber Det ox/Maint # (field #5 3.11)
	1723	"PKG",170, 22,1,"PAH" ,1,1,20,0)
	1724
	1725	"PKG",170, 22,1,"PAH" ,1,1,21,0)
	1726	b. Allo w Multiple DEA Numbe rs to be a ssociated to a Provi der.
	1727	"PKG",170, 22,1,"PAH" ,1,1,22,0)
	1728
	1729	"PKG",170, 22,1,"PAH" ,1,1,23,0)
	1730	c. Add/ Edit/Remov e/Confirm DEA Number Informati on for Non -VA Provid ers.
	1731	"PKG",170, 22,1,"PAH" ,1,1,24,0)
	1732
	1733	"PKG",170, 22,1,"PAH" ,1,1,25,0)
	1734	2. The opt ion Patien t Prescrip tion Proce ssing [PSO LM BACKDO OR ORDERS] has
	1735	"PKG",170, 22,1,"PAH" ,1,1,26,0)
	1736	been mo dified wit h the foll owing:
	1737	"PKG",170, 22,1,"PAH" ,1,1,27,0)
	1738	a. To a llow the s election o f a DEA nu mber when placing an order for
	1739	"PKG",170, 22,1,"PAH" ,1,1,28,0)
	1740	Cont rolled Sub stance (CS ) drug.
	1741	"PKG",170, 22,1,"PAH" ,1,1,29,0)
	1742	b. To e nsure the Provider i s authoriz ed to pres cribe a sp ecific CS
	1743	"PKG",170, 22,1,"PAH" ,1,1,30,0)
	1744	drug .
	1745	"PKG",170, 22,1,"PAH" ,1,1,31,0)
	1746
	1747	"PKG",170, 22,1,"PAH" ,1,1,32,0)
	1748	3. The PIV Card Cert ificate Ex piration A lert messa ge has bee n changed from
	1749	"PKG",170, 22,1,"PAH" ,1,1,33,0)
	1750	"DEA ce rtificate expired. R enew your certificat e." to
	1751	"PKG",170, 22,1,"PAH" ,1,1,34,0)
	1752	"Rx pro cessed: PI V Card Cer t Expired - NO ACTIO N REQ".
	1753	"PKG",170, 22,1,"PAH" ,1,1,35,0)
	1754
	1755	"PKG",170, 22,1,"PAH" ,1,1,36,0)
	1756	4. The PIV Card Cert ificate Re voked Aler t message has been c hanged
	1757	"PKG",170, 22,1,"PAH" ,1,1,37,0)
	1758	from " Med orders (s) DCed. Cert revok ed. Contac t Pharm." to
	1759	"PKG",170, 22,1,"PAH" ,1,1,38,0)
	1760	"Rx NOT processed : PIV Card Certifica te Revoked ".
	1761	"PKG",170, 22,1,"PAH" ,1,1,39,0)
	1762
	1763	"PKG",170, 22,1,"PAH" ,1,1,40,0)
	1764	5. Add Rem inder to T M function for Contr olled Subs tances tha t this
	1765	"PKG",170, 22,1,"PAH" ,1,1,41,0)
	1766	prescri ption cann ot later b e converte d to a mai ntenance p rescriptio n.
	1767	"PKG",170, 22,1,"PAH" ,1,1,42,0)
	1768
	1769	"PKG",170, 22,1,"PAH" ,1,1,43,0)
	1770	6. A new m enu ePCS D EA Utility Functions [PSO EPCS UTILITY F UNCTIONS] has
	1771	"PKG",170, 22,1,"PAH" ,1,1,44,0)
	1772	been tr ansported in this pa tch with t he followi ng options :
	1773	"PKG",170, 22,1,"PAH" ,1,1,45,0)
	1774
	1775	"PKG",170, 22,1,"PAH" ,1,1,46,0)
	1776	6.1 DEA E xpiration Date Repor t [PSO EPC S EXPIRE D ATE REPORT ]
	1777	"PKG",170, 22,1,"PAH" ,1,1,47,0)
	1778	6.2 Print Prescribe rs with Pr ivileges [ PSO EPCS P RIVS]
	1779	"PKG",170, 22,1,"PAH" ,1,1,48,0)
	1780	6.3 Print DISUSER P rescribers with Priv ileges [PS O EPCS DIS USER PRIVS ]
	1781	"PKG",170, 22,1,"PAH" ,1,1,49,0)
	1782	6.4 Print PSDRPH Ke y Holders [PSO EPCS PSDRPH]
	1783	"PKG",170, 22,1,"PAH" ,1,1,50,0)
	1784	6.5 Print Setting P arameters Privileges [PSO EPCS SET PARMS ]
	1785	"PKG",170, 22,1,"PAH" ,1,1,51,0)
	1786	6.6 Print Audits fo r Prescrib er Editing [PSO EPCS PRINT EDI T AUDIT]
	1787	"PKG",170, 22,1,"PAH" ,1,1,52,0)
	1788	6.7 Chang es to DEA Prescribin g Privileg es Report [PSO EPCS LOGICAL
	1789	"PKG",170, 22,1,"PAH" ,1,1,53,0)
	1790	ACCES S REPORT]
	1791	"PKG",170, 22,1,"PAH" ,1,1,54,0)
	1792	6.8 Alloc ation Audi t of PSDRP H Key Repo rt [PSO EP CS PHARMAC IST ACC
	1793	"PKG",170, 22,1,"PAH" ,1,1,55,0)
	1794	REPOR T]
	1795	"PKG",170, 22,1,"PAH" ,1,1,56,0)
	1796	6.9 Enter /Edit EPCS Access Re ports Para meters [PS O EPCS ACC ESS REPORT
	1797	"PKG",170, 22,1,"PAH" ,1,1,57,0)
	1798	PARAM ]
	1799	"PKG",170, 22,1,"PAH" ,1,1,58,0)
	1800	6.10 Allow VA Number if DEA Nu mber Expir ed [PSO EP CS EXPIRED DEA
	1801	"PKG",170, 22,1,"PAH" ,1,1,59,0)
	1802	FAILO VER]
	1803	"PKG",170, 22,1,"PAH" ,1,1,60,0)
	1804	6.11 Set P harmacy Op erating Mo de [PSO VA MC MBM PHA RMACY MODE ]
	1805	"PKG",170, 22,1,"PAH" ,1,1,61,0)
	1806	6.12 Edit Facility D EA# and Ex piration D ate [PSO E PCS EDIT D EA# AND
	1807	"PKG",170, 22,1,"PAH" ,1,1,62,0)
	1808	XDATE ]
	1809	"PKG",170, 22,1,"PAH" ,1,1,63,0)
	1810
	1811	"PKG",170, 22,1,"PAH" ,1,1,64,0)
	1812	7. Item 6. 10 above, 'Allow VA Number if DEA Number Expired' option wil l
	1813	"PKG",170, 22,1,"PAH" ,1,1,65,0)
	1814	allow s ites to tu rn off the existing expired DE A number " fail over"
	1815	"PKG",170, 22,1,"PAH" ,1,1,66,0)
	1816	functio nality so that the r enewal of DEA regist rations ca n be enfor ced
	1817	"PKG",170, 22,1,"PAH" ,1,1,67,0)
	1818	while a llowing ot her sites to maintai n the "fai l over" fu nctionalit y.
	1819	"PKG",170, 22,1,"PAH" ,1,1,68,0)
	1820	This pa rameter is also acce ssible fro m menu 'Ge neral Para meter Tool s',
	1821	"PKG",170, 22,1,"PAH" ,1,1,69,0)
	1822	option 'Edit Para meter Valu es' [XPAR EDIT PARAM ETER], at the packag e
	1823	"PKG",170, 22,1,"PAH" ,1,1,70,0)
	1824	level a nd the sys tem level.
	1825	"PKG",170, 22,1,"PAH" ,1,1,71,0)
	1826
	1827	"PKG",170, 22,1,"PAH" ,1,1,72,0)
	1828	Note - The post-i nstall rou tine will set this p arameter t o 1 ("Yes" ) at
	1829	"PKG",170, 22,1,"PAH" ,1,1,73,0)
	1830	the system level to allow the "Fail Over " function ality.
	1831	"PKG",170, 22,1,"PAH" ,1,1,74,0)
	1832
	1833	"PKG",170, 22,1,"PAH" ,1,1,75,0)
	1834	8. Item 6. 11 above, 'Set Pharm acy Operat ing Mode' option wil l allow Me ds
	1835	"PKG",170, 22,1,"PAH" ,1,1,76,0)
	1836	by Mail (MBM) sit es to turn off the w arning mes sages when using the
	1837	"PKG",170, 22,1,"PAH" ,1,1,77,0)
	1838	EPCS GU I executab le on sele cting a pr ovider who does not have a CPR S
	1839	"PKG",170, 22,1,"PAH" ,1,1,78,0)
	1840	account .
	1841	"PKG",170, 22,1,"PAH" ,1,1,79,0)
	1842	Also, w ith MBM mo de on, bac kdoor phar macy will be able to edit the DEA
	1843	"PKG",170, 22,1,"PAH" ,1,1,80,0)
	1844	informa tion regar dless of t he Provide r Type.
	1845	"PKG",170, 22,1,"PAH" ,1,1,81,0)
	1846	This pa rameter is also acce ssible fro m menu 'Ge neral Para meter Tool s',
	1847	"PKG",170, 22,1,"PAH" ,1,1,82,0)
	1848	option 'Edit Para meter Valu es', at th e package level and the system
	1849	"PKG",170, 22,1,"PAH" ,1,1,83,0)
	1850	level.
	1851	"PKG",170, 22,1,"PAH" ,1,1,84,0)
	1852
	1853	"PKG",170, 22,1,"PAH" ,1,1,85,0)
	1854	Note - The post-i nstall rou tine will set this p arameter t o "VAMC" a t
	1855	"PKG",170, 22,1,"PAH" ,1,1,86,0)
	1856	the packag e level.
	1857	"PKG",170, 22,1,"PAH" ,1,1,87,0)
	1858
	1859	"PKG",170, 22,1,"PAH" ,1,1,88,0)
	1860	9. Item 6. 9 above, ' Enter/Edit EPCS Acce ss Reports Parameter s' option,
	1861	"PKG",170, 22,1,"PAH" ,1,1,89,0)
	1862	provide s the abil ity to con figure the delivery locations of 'Task
	1863	"PKG",170, 22,1,"PAH" ,1,1,90,0)
	1864	Changes to DEA Pr escribing Privileges Report' a nd 'Task A llocation
	1865	"PKG",170, 22,1,"PAH" ,1,1,91,0)
	1866	Audit o f PSDRPH K ey Report' so that th e report c an be deli vered to t he
	1867	"PKG",170, 22,1,"PAH" ,1,1,92,0)
	1868	appropr iate devic e and/or i ndividuals .
	1869	"PKG",170, 22,1,"PAH" ,1,1,93,0)
	1870
	1871	"PKG",170, 22,1,"PAH" ,1,1,94,0)
	1872	It prov ides the f ollowing X PAR parame ter select ions:
	1873	"PKG",170, 22,1,"PAH" ,1,1,95,0)
	1874
	1875	"PKG",170, 22,1,"PAH" ,1,1,96,0)
	1876	Selec t one of t he followi ng:
	1877	"PKG",170, 22,1,"PAH" ,1,1,97,0)
	1878
	1879	"PKG",170, 22,1,"PAH" ,1,1,98,0)
	1880	1 PSOEPCS LO GICAL ACC REPORT DEV
	1881	"PKG",170, 22,1,"PAH" ,1,1,99,0)
	1882	2 PSOEPCS LO GICAL ACC RPT EMAIL
	1883	"PKG",170, 22,1,"PAH" ,1,1,100,0 )
	1884	3 PSOEPCS PH ARM ACC RP T DEVICE
	1885	"PKG",170, 22,1,"PAH" ,1,1,101,0 )
	1886	4 PSOEPCS PH ARM ACC RE PORT EMAIL
	1887	"PKG",170, 22,1,"PAH" ,1,1,102,0 )
	1888
	1889	"PKG",170, 22,1,"PAH" ,1,1,103,0 )
	1890	Select parameter to edit:
	1891	"PKG",170, 22,1,"PAH" ,1,1,104,0 )
	1892
	1893	"PKG",170, 22,1,"PAH" ,1,1,105,0 )
	1894	These parameters are also accessible from the menu 'Gene ral Parame ter
	1895	"PKG",170, 22,1,"PAH" ,1,1,106,0 )
	1896	Tools' , option ' Edit Param eter Value s'.
	1897	"PKG",170, 22,1,"PAH" ,1,1,107,0 )
	1898
	1899	"PKG",170, 22,1,"PAH" ,1,1,108,0 )
	1900
	1901	"PKG",170, 22,1,"PAH" ,1,1,109,0 )
	1902	10. The Co py and Ren ew ListMan actions h ave been m odified to ensure th at
	1903	"PKG",170, 22,1,"PAH" ,1,1,110,0 )
	1904	the DE A # that i s in the o riginal pr escription has the c redentials to
	1905	"PKG",170, 22,1,"PAH" ,1,1,111,0 )
	1906	write CS orders.
	1907	"PKG",170, 22,1,"PAH" ,1,1,112,0 )
	1908
	1909	"PKG",170, 22,1,"PAH" ,1,1,113,0 )
	1910
	1911	"PKG",170, 22,1,"PAH" ,1,1,114,0 )
	1912	11. The fo llowing op tions are sent in th is patch a s a standa lone optio n:
	1913	"PKG",170, 22,1,"PAH" ,1,1,115,0 )
	1914	a. 'Al locate/De- allocate o f PSDRPH K ey' [PSO E PCS PSDRPH KEY] has been
	1915	"PKG",170, 22,1,"PAH" ,1,1,116,0 )
	1916	se nt in this patch. On ly users w ho hold th e PSDRPH k ey, have b een
	1917	"PKG",170, 22,1,"PAH" ,1,1,117,0 )
	1918	de legated th e PSDRPH k ey, or hol d the XUMG R key can use this
	1919	"PKG",170, 22,1,"PAH" ,1,1,118,0 )
	1920	op tion.
	1921	"PKG",170, 22,1,"PAH" ,1,1,119,0 )
	1922	b. 'Ta sk Changes to DEA Pr escribing Privileges Report' [ PSO EPCS
	1923	"PKG",170, 22,1,"PAH" ,1,1,120,0 )
	1924	LO GICAL ACCE SS]. It'll support m ultiple de livery opt ions so th at
	1925	"PKG",170, 22,1,"PAH" ,1,1,121,0 )
	1926	th e appropri ate people have acce ss to the report.
	1927	"PKG",170, 22,1,"PAH" ,1,1,122,0 )
	1928
	1929	"PKG",170, 22,1,"PAH" ,1,1,123,0 )
	1930	c. 'Ta sk Allocat ion Audit of PSDRPH Key Report ' [PSO EPC S PSDRPH
	1931	"PKG",170, 22,1,"PAH" ,1,1,124,0 )
	1932	AU DIT]. It'l l support multiple d elivery op tions so t hat the
	1933	"PKG",170, 22,1,"PAH" ,1,1,125,0 )
	1934	ap propriate people hav e access t o the repo rt.
	1935	"PKG",170, 22,1,"PAH" ,1,1,126,0 )
	1936
	1937	"PKG",170, 22,1,"PAH" ,1,1,127,0 )
	1938	Note - The post- install ro utine will replace e xisting sc heduled ta sks
	1939	"PKG",170, 22,1,"PAH" ,1,1,128,0 )
	1940	XU EPCS L OGICAL ACC ESS and XU EPCS PSDR PH AUDIT w ith new ta sks
	1941	"PKG",170, 22,1,"PAH" ,1,1,129,0 )
	1942	PSO EPCS LOGICAL AC CESS and P SO EPCS PS DRPH AUDIT . Options XU
	1943	"PKG",170, 22,1,"PAH" ,1,1,130,0 )
	1944	EPCS LOGI CAL ACCESS and XU EP CS PSDRPH AUDIT are marked as
	1945	"PKG",170, 22,1,"PAH" ,1,1,131,0 )
	1946	Out-Of-Or der by pat ch XU868 9 as part of this pr oject.
	1947	"PKG",170, 22,1,"PAH" ,1,1,132,0 )
	1948
	1949	"PKG",170, 22,1,"PAH" ,1,1,133,0 )
	1950
	1951	"PKG",170, 22,1,"PAH" ,1,1,134,0 )
	1952	Note: Rout ine PSOHLE XP has bee n modified .
	1953	"PKG",170, 22,1,"PAH" ,1,1,135,0 )
	1954	The mail messa ge that ge nerates wh en the fac ility DEA # is about to
	1955	"PKG",170, 22,1,"PAH" ,1,1,136,0 )
	1956	expi re in opti on Expire Prescripti ons [PSO E XPIRE PRES CRIPTIONS] has
	1957	"PKG",170, 22,1,"PAH" ,1,1,137,0 )
	1958	been modified to referen ce the opt ion, 'Edit Facility DEA# and
	1959	"PKG",170, 22,1,"PAH" ,1,1,138,0 )
	1960	Expi ration Dat e' [PSO EP CS EDIT DE A# AND XDA TE].
	1961	"PKG",170, 22,1,"PAH" ,1,1,139,0 )
	1962
	1963	"PKG",170, 22,1,"PAH" ,1,1,140,0 )
	1964	Note: The following routines h ave been m odified to use calls $$DEA^XUS ER,
	1965	"PKG",170, 22,1,"PAH" ,1,1,141,0 )
	1966	$$DE TOX^XUSER and $$PRXD T^XUSER to replace w here ever the NEW PE RSON
	1967	"PKG",170, 22,1,"PAH" ,1,1,142,0 )
	1968	file (#200) fi elds DEA# (#53.2), D ETOX/MAINT ENANCE ID NUMBER
	1969	"PKG",170, 22,1,"PAH" ,1,1,143,0 )
	1970	(#53 .11) and D EA EXPIRAT ION DATE ( #747.44) a re referen ced.
	1971	"PKG",170, 22,1,"PAH" ,1,1,144,0 )
	1972
	1973	"PKG",170, 22,1,"PAH" ,1,1,145,0 )
	1974	PSOE RXR1
	1975	"PKG",170, 22,1,"PAH" ,1,1,146,0 )
	1976	PSOE RXA0
	1977	"PKG",170, 22,1,"PAH" ,1,1,147,0 )
	1978	PSOC LUTL
	1979	"PKG",170, 22,1,"PAH" ,1,1,148,0 )
	1980	PSOH LDS1
	1981	"PKG",170, 22,1,"PAH" ,1,1,149,0 )
	1982	PSOC PTRI
	1983	"QUES","XP F1",0)
	1984	Y
	1985	"QUES","XP F1","??")
	1986	^D REP^XPD H
	1987	"QUES","XP F1","A")
	1988	Shall I wr ite over y our \|FLAG\| File
	1989	"QUES","XP F1","B")
	1990	YES
	1991	"QUES","XP F1","M")
	1992	D XPF1^XPD IQ
	1993	"QUES","XP F2",0)
	1994	Y
	1995	"QUES","XP F2","??")
	1996	^D DTA^XPD H
	1997	"QUES","XP F2","A")
	1998	Want my da ta \|FLAG\| yours
	1999	"QUES","XP F2","B")
	2000	YES
	2001	"QUES","XP F2","M")
	2002	D XPF2^XPD IQ
	2003	"QUES","XP I1",0)
	2004	YO
	2005	"QUES","XP I1","??")
	2006	^D INHIBIT ^XPDH
	2007	"QUES","XP I1","A")
	2008	Want KIDS to INHIBIT LOGONs du ring the i nstall
	2009	"QUES","XP I1","B")
	2010	NO
	2011	"QUES","XP I1","M")
	2012	D XPI1^XPD IQ
	2013	"QUES","XP M1",0)
	2014	PO^VA(200, :EM
	2015	"QUES","XP M1","??")
	2016	^D MG^XPDH
	2017	"QUES","XP M1","A")
	2018	Enter the Coordinato r for Mail Group '\|F LAG\|'
	2019	"QUES","XP M1","B")
	2020
	2021	"QUES","XP M1","M")
	2022	D XPM1^XPD IQ
	2023	"QUES","XP O1",0)
	2024	Y
	2025	"QUES","XP O1","??")
	2026	^D MENU^XP DH
	2027	"QUES","XP O1","A")
	2028	Want KIDS to Rebuild Menu Tree s Upon Com pletion of Install
	2029	"QUES","XP O1","B")
	2030	NO
	2031	"QUES","XP O1","M")
	2032	D XPO1^XPD IQ
	2033	"QUES","XP Z1",0)
	2034	Y
	2035	"QUES","XP Z1","??")
	2036	^D OPT^XPD H
	2037	"QUES","XP Z1","A")
	2038	Want to DI SABLE Sche duled Opti ons, Menu Options, a nd Protoco ls
	2039	"QUES","XP Z1","B")
	2040	NO
	2041	"QUES","XP Z1","M")
	2042	D XPZ1^XPD IQ
	2043	"QUES","XP Z2",0)
	2044	Y
	2045	"QUES","XP Z2","??")
	2046	^D RTN^XPD H
	2047	"QUES","XP Z2","A")
	2048	Want to MO VE routine s to other CPUs
	2049	"QUES","XP Z2","B")
	2050	NO
	2051	"QUES","XP Z2","M")
	2052	D XPZ2^XPD IQ
	2053	"RTN")
	2054	25
	2055	"RTN","PSO 7P545")
	2056	0^^B323088 0
	2057	"RTN","PSO 7P545",1,0 )
	2058	PSO7P545 ; MHA - Post Install r outine for patch PSO 7545 ;12 /3/2018
	2059	"RTN","PSO 7P545",2,0 )
	2060	;;7.0;OUT PATIENT PH ARMACY;5 45;DEC 1 997;Build 21
	2061	"RTN","PSO 7P545",3,0 )
	2062	Q
	2063	"RTN","PSO 7P545",4,0 )
	2064	EN ;
	2065	"RTN","PSO 7P545",5,0 )
	2066	D PUT^XPA R("PKG","P SO VAMC MB M PHARMACY MODE",1," V")
	2067	"RTN","PSO 7P545",6,0 )
	2068	D PUT^XPA R("SYS","P SOEPCS EXP IRED DEA F AILOVER",1 ,1)
	2069	"RTN","PSO 7P545",7,0 )
	2070	;
	2071	"RTN","PSO 7P545",8,0 )
	2072	N BY,ENTR Y,ERR,ROOT ,WHEN,DUZ
	2073	"RTN","PSO 7P545",9,0 )
	2074	S DUZ=.5
	2075	"RTN","PSO 7P545",10, 0)
	2076	;
	2077	"RTN","PSO 7P545",11, 0)
	2078	; Check t o see if P SO EPCS PS DRPH AUDIT is alread y schedule d.
	2079	"RTN","PSO 7P545",12, 0)
	2080	K ROOT D OPTSTAT^XU TMOPT("PSO EPCS PSDR PH AUDIT", .ROOT)
	2081	"RTN","PSO 7P545",13, 0)
	2082	I $D(ROOT (1)),$P(RO OT(1),"^", 2)'="",$P( ROOT(1),"^ ",3)'="" G CONT1
	2083	"RTN","PSO 7P545",14, 0)
	2084	;
	2085	"RTN","PSO 7P545",15, 0)
	2086	; Change from XU EP CS PSDRPH AUDIT to P SO EPCS PS DRPH AUDIT
	2087	"RTN","PSO 7P545",16, 0)
	2088	K ROOT D OPTSTAT^XU TMOPT("XU EPCS PSDRP H AUDIT",. ROOT)
	2089	"RTN","PSO 7P545",17, 0)
	2090	I $D(ROOT (1)) F ENT RY=1:1:ROO T D
	2091	"RTN","PSO 7P545",18, 0)
	2092	. I $P(RO OT(ENTRY), "^",2)="" Q
	2093	"RTN","PSO 7P545",19, 0)
	2094	. I $P(RO OT(ENTRY), "^",3)="" Q
	2095	"RTN","PSO 7P545",20, 0)
	2096	. S WHEN= $P(ROOT(EN TRY),"^",2 ),BY=$P(RO OT(ENTRY), "^",3)
	2097	"RTN","PSO 7P545",21, 0)
	2098	. D RESCH ^XUTMOPT(" PSO EPCS P SDRPH AUDI T",WHEN,"" ,BY,"L",.E RR)
	2099	"RTN","PSO 7P545",22, 0)
	2100	. D RESCH ^XUTMOPT(" XU EPCS PS DRPH AUDIT ","@",""," @","",.ERR )
	2101	"RTN","PSO 7P545",23, 0)
	2102	CONT1 ;
	2103	"RTN","PSO 7P545",24, 0)
	2104	;
	2105	"RTN","PSO 7P545",25, 0)
	2106	; Check t o see if P SO EPCS LO GICAL ACCE SS is alre ady schedu led.
	2107	"RTN","PSO 7P545",26, 0)
	2108	K ROOT D OPTSTAT^XU TMOPT("PSO EPCS LOGI CAL ACCESS ",.ROOT)
	2109	"RTN","PSO 7P545",27, 0)
	2110	I $D(ROOT (1)),$P(RO OT(1),"^", 2)'="",$P( ROOT(1),"^ ",3)'="" G CONT2
	2111	"RTN","PSO 7P545",28, 0)
	2112	;
	2113	"RTN","PSO 7P545",29, 0)
	2114	; Change from XU EP CS LOGICAL ACCESS to PSO EPCS LOGICAL AC CESS
	2115	"RTN","PSO 7P545",30, 0)
	2116	K ROOT D OPTSTAT^XU TMOPT("XU EPCS LOGIC AL ACCESS" ,.ROOT)
	2117	"RTN","PSO 7P545",31, 0)
	2118	I $D(ROOT (1)) F ENT RY=1:1:ROO T D
	2119	"RTN","PSO 7P545",32, 0)
	2120	. I $P(RO OT(ENTRY), "^",2)="" Q
	2121	"RTN","PSO 7P545",33, 0)
	2122	. I $P(RO OT(ENTRY), "^",3)="" Q
	2123	"RTN","PSO 7P545",34, 0)
	2124	. S WHEN= $P(ROOT(EN TRY),"^",2 ),BY=$P(RO OT(ENTRY), "^",3)
	2125	"RTN","PSO 7P545",35, 0)
	2126	. D RESCH ^XUTMOPT(" PSO EPCS L OGICAL ACC ESS",WHEN, "",BY,"L", .ERR)
	2127	"RTN","PSO 7P545",36, 0)
	2128	. D RESCH ^XUTMOPT(" XU EPCS LO GICAL ACCE SS","@","" ,"@","",.E RR)
	2129	"RTN","PSO 7P545",37, 0)
	2130	CONT2 ;
	2131	"RTN","PSO 7P545",38, 0)
	2132	Q
	2133	"RTN","PSO CLUTL")
	2134	0^4^B30029 887
	2135	"RTN","PSO CLUTL",1,0 )
	2136	PSOCLUTL ; BHAM ISC/D MA - utili ties for c lozapine r eporting s ystem ; 12 /22/92
	2137	"RTN","PSO CLUTL",2,0 )
	2138	;;7.0;OUT PATIENT PH ARMACY;2 8,56,122,2 22,268,545 ;DEC 199 7;Build 21
	2139	"RTN","PSO CLUTL",3,0 )
	2140	;External reference ^YSCL(603 .01 suppor ted by DBI A 2697
	2141	"RTN","PSO CLUTL",4,0 )
	2142	;External reference ^PS(55 su pported by DBIA 2228
	2143	"RTN","PSO CLUTL",5,0 )
	2144	;
	2145	"RTN","PSO CLUTL",6,0 )
	2146	REG ; regi ster patie nt
	2147	"RTN","PSO CLUTL",7,0 )
	2148	S DIC=55, DLAYGO=55, DIC(0)="AE QL",DIC("A ")="Select patient t o register : " D ^DIC K DIC G E ND:Y<0 S P SO1=+Y,PSO NAME=$P(^D PT(PSO1,0) ,"^") K DL AYGO
	2149	"RTN","PSO CLUTL",8,0 )
	2150	D:$P($G(^ PS(55,PSO1 ,0)),"^",6 )'=2 EN^PS OHLUP(PSO1 )
	2151	"RTN","PSO CLUTL",9,0 )
	2152	I '$D(^YS CL(603.01, "C",PSO1)) W !!,PSON AME_" has not been a uthorized for Clozap ine",!,"by the NCCC in Dallas. Contact the NCCC i n Dallas f or authori zation." D OVER G:'$ G(%) REG S JADOVER=" "
	2153	"RTN","PSO CLUTL",10, 0)
	2154	I $P($G(^ PS(55,PSO1 ,"SAND")), "^")]"" S PSO4=^("SA ND") W !!, PSONAME_" is already registere d with num ber "_$P(P SO4,"^"),! !,"Use the edit opti on to chan ge registr ation data , or",!,"c ontact you r supervis or",! G RE G
	2155	"RTN","PSO CLUTL",11, 0)
	2156	NUMBER S D IR(0)="55, 53" D ^DIR S PSO2=Y K DIR I $D (DIRUT) W !,"Not reg istered",! D END G R EG
	2157	"RTN","PSO CLUTL",12, 0)
	2158	I $D(^PS( 55,"ASAND1 ",PSO2)),$ O(^(PSO2,0 ))'=PSO1 W !,PSO2," is already assigned to ",$P(^D PT(+$O(^(0 )),0),"^") W !,"Plea se contact your supe rvisor" D END G REG
	2159	"RTN","PSO CLUTL",13, 0)
	2160	I '$D(JAD OVER),'$D( ^YSCL(603. 01,"B",PSO 2)) W !!," The NCCC i n Dallas h as not aut horized "_ PSO2_" for useage",! ,"at this facility. Contact t he NCCC in Dallas fo r authoriz ation." D OVER G:'$G (%) END
	2161	"RTN","PSO CLUTL",14, 0)
	2162	S DIR("A" )="Pre-tre atment or Active tre atment? ", DIR(0)="S^ P:PRE-TREA TMENT;A:AC TIVE TREAT MENT;",DIR ("?")="Is this patie nt new to the Clozap ine progra m, or has s/he been receiving treatment? " D ^DIR K DIR S PSO 3=Y
	2163	"RTN","PSO CLUTL",15, 0)
	2164	I $D(DIRU T) W !!,"N ot registe red" R X:1 0 K X G EN D
	2165	"RTN","PSO CLUTL",16, 0)
	2166	PHY S DIC= "^VA(200," ,DIC(0)="A EQMZ",DIC( "A")="Prov ider respo nsible: ", DIC("S")=" I $G(^VA(2 00,+Y,""PS ""))]""""" D ^DIC K DIC I Y<0 W !!,"Not registered ",!! R X:1 0 K X G EN D
	2167	"RTN","PSO CLUTL",17, 0)
	2168	;*545
	2169	"RTN","PSO CLUTL",18, 0)
	2170	I $$PRDEA ^XUSER(+Y) ']"" W !!, "Only prov iders with DEA numbe rs entered in the Ne w Person", !,"file ca n register patients in this pr ogram.",!! G PHY
	2171	"RTN","PSO CLUTL",19, 0)
	2172	S PSO4=+Y K DIR,DIR UT,DUOUT,D TOUT
	2173	"RTN","PSO CLUTL",20, 0)
	2174	S DIR("A" ,1)="OK to register "_PSONAME_ " with num ber "_PSO2 ,DIR("A")= "as a"_$S( 'PSO3:" ne w",1:"n on going")_" patient in this prog ram "
	2175	"RTN","PSO CLUTL",21, 0)
	2176	S DIR(0)= "Y",DIR("B ")="NO" D ^DIR K DIR I Y=0 G E ND
	2177	"RTN","PSO CLUTL",22, 0)
	2178	SAVE S DA= PSO1,DIE=5 5,DR="53// //"_PSO2_" ;54////"_P SO3_";57// //"_PSO4_" ;56////0;5 8////"_DT L +^PS(55, DA):$S(+$G (^DD("DILO CKTM"))>0: +^DD("DILO CKTM"),1:3 ) I '$T W !!,$C(7)," Patient "_ PSONAME_" is being e dited by a nother use r! Try La ter." G EN D
	2179	"RTN","PSO CLUTL",23, 0)
	2180	D ^DIE L -^PS(55,DA )
	2181	"RTN","PSO CLUTL",24, 0)
	2182	END K %,%Y ,C,D,D0,DA ,DI,DQ,DFN ,DIC,DIE,D R,PSO,PSO1 ,PSO2,PSO3 ,PSO4,PSOC ,PSOLN,PSO NAME,PSONO ,PSOT,R,VA ERR,XMDUZ, XMSUB,XMTE XT,Y,^TMP( $J),^TMP(" PSO",$J) Q
	2183	"RTN","PSO CLUTL",25, 0)
	2184	Q
	2185	"RTN","PSO CLUTL",26, 0)
	2186	;
	2187	"RTN","PSO CLUTL",27, 0)
	2188	FACILITY ; Enter faci lity DEA n umber to s et up cloz apine syst em
	2189	"RTN","PSO CLUTL",28, 0)
	2190	;this ent ry point i s no longe r used. t his functi onality wa s taken ov er
	2191	"RTN","PSO CLUTL",29, 0)
	2192	;by the m ental heal th package with the release of YS5.011 8
	2193	"RTN","PSO CLUTL",30, 0)
	2194	;W ! S DI C=59,DIC(0 )="AEQM",D IC("A")="S elect site to partic ipate in c lozapine p rogram : " D ^DIC G END:Y<0
	2195	"RTN","PSO CLUTL",31, 0)
	2196	;S DIE=DI C,DA=+Y,DR ="1R;2R;" L +^PS(59, DA) D ^DIE L -^PS(59 ,DA) G FAC ILITY
	2197	"RTN","PSO CLUTL",32, 0)
	2198	Q
	2199	"RTN","PSO CLUTL",33, 0)
	2200	;
	2201	"RTN","PSO CLUTL",34, 0)
	2202	AGAIN ; re -enter pat ient - new number, s tatus and provider
	2203	"RTN","PSO CLUTL",35, 0)
	2204	S DIC=55, DIC(0)="AE QM",DIC("A ")="Select clozapine patient : " D ^DIC K DIC G EN D:Y<0 S DA =+Y,PSO1=D A,PSONAME= $P(^DPT(DA ,0),"^")
	2205	"RTN","PSO CLUTL",36, 0)
	2206	I $P($G(^ PS(55,DA," SAND")),"^ ")="" W !, PSONAME_" is not reg istered. Use the re gister opt ion." G AG AIN
	2207	"RTN","PSO CLUTL",37, 0)
	2208	I '$D(^YS CL(603.01, "C",PSO1)) W !!,PSON AME_" has not been a uthorized for Clozap ine",!,"by the NCCC in Dallas. Contact the NCCC i n Dallas f or authori zation." D OVER G:'$ G(%) AGAIN S JADOVER =""
	2209	"RTN","PSO CLUTL",38, 0)
	2210	S DIR(0)= "55,53" D ^DIR G END :$D(DIRUT) S PSO2=Y I $D(^PS(5 5,"ASAND1" ,PSO2)),$O (^(PSO2,0) )'=PSO1 W !,PSO2," a lready ass igned to " ,$P(^DPT($ O(^(0)),0) ,"^") G EN D
	2211	"RTN","PSO CLUTL",39, 0)
	2212	I '$D(JAD OVER),'$D( ^YSCL(603. 01,"B",PSO 2)) W !!," The NCCC i n Dallas h as not aut horized "_ PSO2_" for usage",!, "at this f acility. Contact th e NCCC in Dallas for authoriza tion." D O VER G:'$G( %) END
	2213	"RTN","PSO CLUTL",40, 0)
	2214	S PSO3=$P (^PS(55,DA ,"SAND")," ^",2)
	2215	"RTN","PSO CLUTL",41, 0)
	2216	W !,$P(^D D(55,54,0) ,"^")_": " _$S(PSO3=" A":"ACTIVE TREATMENT ",PSO3="D" :"DISCONTI NUED",PSO3 ="H":"TREA TMENT ON H OLD",1:"PR E-TREATMEN T")
	2217	"RTN","PSO CLUTL",42, 0)
	2218	PHY1 ;
	2219	"RTN","PSO CLUTL",43, 0)
	2220	S PSO4=$P (^PS(55,DA ,"SAND")," ^",5),DIR( 0)="55,57" D ^DIR G END:$D(DIR UT) I Y S PSO4=+Y
	2221	"RTN","PSO CLUTL",44, 0)
	2222	;*545
	2223	"RTN","PSO CLUTL",45, 0)
	2224	I $$PRDEA ^XUSER(PSO 4)="" W !! ,"Only pro viders wit h DEA numb ers entere d in the N ew Person" ,!,"file c an registe r patients in this p rogram.",! ! G PHY1
	2225	"RTN","PSO CLUTL",46, 0)
	2226	G SAVE
	2227	"RTN","PSO CLUTL",47, 0)
	2228	;
	2229	"RTN","PSO CLUTL",48, 0)
	2230	OVER ;allo w registra tion of pa tients and clozapine numbers n ot yet aut horized by the NCCC.
	2231	"RTN","PSO CLUTL",49, 0)
	2232	K DIR W ! S DIR("A" )="Do you want to ov er-ride th is warning ",DIR(0)=" Y",DIR("B" )="No" D ^ DIR
	2233	"RTN","PSO CLUTL",50, 0)
	2234	I Y D S %=1
	2235	"RTN","PSO CLUTL",51, 0)
	2236	.Q S YSC LDATA(1)=" An over-ri de was aut horize at "_$G(DUZ(2 ))_" for " _$S($D(PSO NAME):PSON AME,1:$G(P SO2))_" by "_$P($G(^ VA(200,DUZ ,0)),"^")
	2237	"RTN","PSO CLUTL",52, 0)
	2238	.S %H=$H D YMD^%DTC S XMDUN=" NCC LOGGER ",XMDUZ=.5 ,XMSUB=$G( DUZ(2))_" NCC ENROLL ER ("_X_%_ ")",XMTEXT ="YSCLDATA (",XMY("G. CLOZAPINE ROLL-UP@ D O M A IN . EXT ")=""
	2239	"RTN","PSO CLUTL",53, 0)
	2240	.D ^XMD K XMDUN,XMD UZ,XMER,XM REC,XRG,XM SUB,XMTEXT ,XMY,XMZ,Y SCLDATA
	2241	"RTN","PSO CLUTL",54, 0)
	2242	K DIR,DIR UT,DUOUT Q
	2243	"RTN","PSO CPTRI")
	2244	0^19^B3057 9953
	2245	"RTN","PSO CPTRI",1,0 )
	2246	PSOCPTRI ; BHAM ISC/C PM,RTR - S UPPORT FOR CHAMPUS R X BILLING ;14-AUG-96
	2247	"RTN","PSO CPTRI",2,0 )
	2248	;;7.0;OUT PATIENT PH ARMACY;1 0,55,184,5 45;DEC 1 997;Build 21
	2249	"RTN","PSO CPTRI",3,0 )
	2250	;External reference to ^PSDRU G supporte d by DBIA 221
	2251	"RTN","PSO CPTRI",4,0 )
	2252	;
	2253	"RTN","PSO CPTRI",5,0 )
	2254	;
	2255	"RTN","PSO CPTRI",6,0 )
	2256	TRANS(ORIG ,REF,PSOV) ; Extract Rx inform ation for transmissi on to FI
	2257	"RTN","PSO CPTRI",7,0 )
	2258	; Input: ORIG - - Pointer to the rx in file # 52
	2259	"RTN","PSO CPTRI",8,0 )
	2260	; REF - - Pointer to the re fill in fi le #52.1
	2261	"RTN","PSO CPTRI",9,0 )
	2262	; (This i s 0 if we are billin g the orig inal fill)
	2263	"RTN","PSO CPTRI",10, 0)
	2264	; PSOV - - Passed by referen ce. This array will be used
	2265	"RTN","PSO CPTRI",11, 0)
	2266	; to retu rn the out put (descr ibed below ).
	2267	"RTN","PSO CPTRI",12, 0)
	2268	; Output: PSOE - - This is normally 1, or -1 i f the NDC cannot
	2269	"RTN","PSO CPTRI",13, 0)
	2270	; be dete rmined.
	2271	"RTN","PSO CPTRI",14, 0)
	2272	;
	2273	"RTN","PSO CPTRI",15, 0)
	2274	;
	2275	"RTN","PSO CPTRI",16, 0)
	2276	; Des cription o f output v ariables t o be passe d to billi ng:
	2277	"RTN","PSO CPTRI",17, 0)
	2278	;
	2279	"RTN","PSO CPTRI",18, 0)
	2280	; PSOV(" NDC") NDC # fr om the DRU G (#50) fi le
	2281	"RTN","PSO CPTRI",19, 0)
	2282	; PSOV(" DIV") Pharmacy (in file #59) dispe nsing the rx
	2283	"RTN","PSO CPTRI",20, 0)
	2284	; PSOV(" FDT") Rx Fill Date
	2285	"RTN","PSO CPTRI",21, 0)
	2286	; Last fill, fiel d #101, or
	2287	"RTN","PSO CPTRI",22, 0)
	2288	; Dispe nsed, fiel d #25
	2289	"RTN","PSO CPTRI",23, 0)
	2290	; PSOV(" RX#") Prescrip tion numbe r, field # .01
	2291	"RTN","PSO CPTRI",24, 0)
	2292	; PSOV(" QTY") Quantity , field #7
	2293	"RTN","PSO CPTRI",25, 0)
	2294	; PSOV(" SUP") Days Sup ply, field #8
	2295	"RTN","PSO CPTRI",26, 0)
	2296	; PSOV(" ISS") Issue Da te, field #1
	2297	"RTN","PSO CPTRI",27, 0)
	2298	; PSOV(" #REF") # Refill s, field # 9
	2299	"RTN","PSO CPTRI",28, 0)
	2300	; PSOV(" COMP") 2 if man ufactured in Pharmac y, else 1
	2301	"RTN","PSO CPTRI",29, 0)
	2302	; PSOV(" DEA") DEA numb er from "P S" node in File 200
	2303	"RTN","PSO CPTRI",30, 0)
	2304	;
	2305	"RTN","PSO CPTRI",31, 0)
	2306	N PSOE,PS ORX S PSOE =1
	2307	"RTN","PSO CPTRI",32, 0)
	2308	;
	2309	"RTN","PSO CPTRI",33, 0)
	2310	S PSORX(0 )=$G(^PSRX (ORIG,0)), PSORX(2)=$ G(^(2)),PS ORX(3)=$G( ^(3))
	2311	"RTN","PSO CPTRI",34, 0)
	2312	S:$G(REF) PSORX("RE F")=$G(^PS RX(ORIG,1, REF,0))
	2313	"RTN","PSO CPTRI",35, 0)
	2314	I PSORX(0 )="" S PSO E=-1 G TRA NSQ
	2315	"RTN","PSO CPTRI",36, 0)
	2316	;
	2317	"RTN","PSO CPTRI",37, 0)
	2318	S PSOV("R X#")=$P(PS ORX(0),"^" ) ; prescr iption num ber
	2319	"RTN","PSO CPTRI",38, 0)
	2320	; - first check for a valid N DC #
	2321	"RTN","PSO CPTRI",39, 0)
	2322	S PSOV("N DC")=$P($G (^PSDRUG(+ $P(PSORX(0 ),"^",6),2 )),"^",4)
	2323	"RTN","PSO CPTRI",40, 0)
	2324	I +PSOV(" NDC")=0 S PSOE=-1 G TRANSQ
	2325	"RTN","PSO CPTRI",41, 0)
	2326	;
	2327	"RTN","PSO CPTRI",42, 0)
	2328	; - extra ct everyth ing else
	2329	"RTN","PSO CPTRI",43, 0)
	2330	S PSOV("D IV")=$S($P ($G(PSORX( "REF")),"^ ",9):$P(PS ORX("REF") ,"^",9),1: $P(PSORX(2 ),"^",9)) ; p harmacy di vision
	2331	"RTN","PSO CPTRI",44, 0)
	2332	S PSOV("F DT")=$S($G (REF):$E($ P(PSORX("R EF"),"^"), 1,7),1:$E( $P(PSORX(2 ),"^",2),1 ,7))
	2333	"RTN","PSO CPTRI",45, 0)
	2334	I PSOV("F DT")="" S PSOV("FDT" )=$S($P(PS ORX(3),"^" ):$P(PSORX (3),"^"),1 :$P(PSORX( 2),"^",5))
	2335	"RTN","PSO CPTRI",46, 0)
	2336	;
	2337	"RTN","PSO CPTRI",47, 0)
	2338	S PSOV("Q TY")=$S($P ($G(PSORX( "REF")),"^ ",4)'="":$ P(PSORX("R EF"),"^",4 ),1:$P(PSO RX(0),"^", 7)) ; quantit y
	2339	"RTN","PSO CPTRI",48, 0)
	2340	S PSOV("S UP")=$S($P ($G(PSORX( "REF")),"^ ",10)'="": $P(PSORX(" REF"),"^", 10),1:$P(P SORX(0),"^ ",8)) ; days supply
	2341	"RTN","PSO CPTRI",49, 0)
	2342	S PSOV("I SS")=$P(PS ORX(0),"^" ,13) ; date rx written
	2343	"RTN","PSO CPTRI",50, 0)
	2344	S PSOV("# REF")=$P(P SORX(0),"^ ",9) ; # refil ls authori zed
	2345	"RTN","PSO CPTRI",51, 0)
	2346	;
	2347	"RTN","PSO CPTRI",52, 0)
	2348	N PSOX S PSOX=+$P(P SORX(0),"^ ",6) S PSO V("COMP")= $P($G(^PSD RUG(PSOX,0 )),"^",3) S PSOV("CO MP")=$S(PS OV("COMP") [0:2,1:1) ; Compound drug
	2349	"RTN","PSO CPTRI",53, 0)
	2350	;
	2351	"RTN","PSO CPTRI",54, 0)
	2352	;*545 - g et DEA#
	2353	"RTN","PSO CPTRI",55, 0)
	2354	S PSOV("D EA")=$S($P (PSORX(0), "^",4):$$G DEA(+$P(PS ORX(0),"^" ,4)),1:"")
	2355	"RTN","PSO CPTRI",56, 0)
	2356	;
	2357	"RTN","PSO CPTRI",57, 0)
	2358	;
	2359	"RTN","PSO CPTRI",58, 0)
	2360	TRANSQ Q P SOE
	2361	"RTN","PSO CPTRI",59, 0)
	2362	;
	2363	"RTN","PSO CPTRI",60, 0)
	2364	;
	2365	"RTN","PSO CPTRI",61, 0)
	2366	LABEL(RX,P SOLAP,PSOS ITE,DUZ,PS OTRAMT) ; Print the label.
	2367	"RTN","PSO CPTRI",62, 0)
	2368	; Input: RX -- Poin ter to the prescript ion in fil e #52
	2369	"RTN","PSO CPTRI",63, 0)
	2370	; PSOLAP -- Labe l printer
	2371	"RTN","PSO CPTRI",64, 0)
	2372	; PSOSITE -- Poin ter to the Pharmacy in file #5 9
	2373	"RTN","PSO CPTRI",65, 0)
	2374	; DUZ -- Poin ter to the use in fi le #200
	2375	"RTN","PSO CPTRI",66, 0)
	2376	; PSOTRAMT -- Amou nt to be p aid
	2377	"RTN","PSO CPTRI",67, 0)
	2378	;
	2379	"RTN","PSO CPTRI",68, 0)
	2380	;
	2381	"RTN","PSO CPTRI",69, 0)
	2382	Q:PSOLAP[ "LAT-TERM"
	2383	"RTN","PSO CPTRI",70, 0)
	2384	Q:'$D(^PS RX(RX,0))
	2385	"RTN","PSO CPTRI",71, 0)
	2386	Q:'$D(^PS (59,PSOSIT E,0))
	2387	"RTN","PSO CPTRI",72, 0)
	2388	N CT,II,I II,NOW,RXF F,X,Y,PSOS YS,PSOPAR, PSOBARS,PD UZ,PSOBAR0 ,PSOBAR1,R EPRINT,PSO CHAMP,PSHR X,DIQUIET
	2389	"RTN","PSO CPTRI",73, 0)
	2390	S DIQUIET =1 D DT^DI CRW
	2391	"RTN","PSO CPTRI",74, 0)
	2392	I '$G(DT) S DT=$$DT ^XLFDT
	2393	"RTN","PSO CPTRI",75, 0)
	2394	S:$P($G(^ PSRX(RX,"S TA")),"^") '=3 REPRIN T=""
	2395	"RTN","PSO CPTRI",76, 0)
	2396	D:$P($G(^ PSRX(RX,"S TA")),"^") =3
	2397	"RTN","PSO CPTRI",77, 0)
	2398	.S RXFF=0 F II=0:0 S II=$O(^P SRX(RX,1,I I)) Q:'II S RXFF=II
	2399	"RTN","PSO CPTRI",78, 0)
	2400	.K DIE S DIE="^PSRX (",DA=RX,D R=$S('RXFF :"22///"_D T_";",1:"" )_"100///" _0_";101// /"_$S('RXF F:DT,1:+$P ($G(^PSRX( RX,1,+$G(R XFF),0))," ^")) D ^DI E K DIE
	2401	"RTN","PSO CPTRI",79, 0)
	2402	.S PSHRX= RX D EN^PS OHLSN1(RX, "OE","","R x removed from CHAMP US billing hold","A" ) S RX=PSH RX
	2403	"RTN","PSO CPTRI",80, 0)
	2404	.K ^PSRX( "AH",+$P($ G(^PSRX(RX ,"H")),"^" ),RX) S ^P SRX(DA,"H" )=""
	2405	"RTN","PSO CPTRI",81, 0)
	2406	.D NOW^%D TC S NOW=%
	2407	"RTN","PSO CPTRI",82, 0)
	2408	.S III=0 F CT=0:0 S CT=$O(^PS RX(RX,"A", CT)) Q:'CT S III=CT
	2409	"RTN","PSO CPTRI",83, 0)
	2410	.S III=II I+1,^PSRX( RX,"A",0)= "^52.3DA^" _III_"^"_I II
	2411	"RTN","PSO CPTRI",84, 0)
	2412	.S ^PSRX( RX,"A",III ,0)=NOW_"^ "_"U"_"^"_ +$G(DUZ)_" ^"_$S(RXFF <6:RXFF,1: (RXFF+1))_ "^"_"Rx re moved from CHAMPUS b illing hol d"
	2413	"RTN","PSO CPTRI",85, 0)
	2414	;
	2415	"RTN","PSO CPTRI",86, 0)
	2416	IO S %ZIS= "",IOP=PSO LAP D ^%ZI S I POP H 5 G IO
	2417	"RTN","PSO CPTRI",87, 0)
	2418	N PSOIOS S PSOIOS=I OS D DEVBA R^PSOBMST
	2419	"RTN","PSO CPTRI",88, 0)
	2420	S PSOSYS= $G(^PS(59, PSOSITE,1) )
	2421	"RTN","PSO CPTRI",89, 0)
	2422	S PSOPAR= $G(^PS(59, PSOSITE,1) ),PDUZ=DUZ
	2423	"RTN","PSO CPTRI",90, 0)
	2424	S PPL=RX
	2425	"RTN","PSO CPTRI",91, 0)
	2426	S PSOCHAM P=1
	2427	"RTN","PSO CPTRI",92, 0)
	2428	S PSOBARS =PSOBAR1]" "&(PSOBAR0 ]"")&($P(P SOPAR,"^", 19))
	2429	"RTN","PSO CPTRI",93, 0)
	2430	D DQ^PSOL BL
	2431	"RTN","PSO CPTRI",94, 0)
	2432	D ^%ZISC
	2433	"RTN","PSO CPTRI",95, 0)
	2434	;
	2435	"RTN","PSO CPTRI",96, 0)
	2436	Q
	2437	"RTN","PSO CPTRI",97, 0)
	2438	;
	2439	"RTN","PSO CPTRI",98, 0)
	2440	;
	2441	"RTN","PSO CPTRI",99, 0)
	2442	CHK(ORIG,R EF) ; Shou ld this rx be billed to the CH AMPUS Fisc al Interme diary?
	2443	"RTN","PSO CPTRI",100 ,0)
	2444	; Input: ORIG - - Pointer to the rx in file # 52
	2445	"RTN","PSO CPTRI",101 ,0)
	2446	; REF - - Pointer to the re fill in fi le #52.1, or
	2447	"RTN","PSO CPTRI",102 ,0)
	2448	; 0 for t he origina l fill
	2449	"RTN","PSO CPTRI",103 ,0)
	2450	; Output: PSOB - - 0 => Th e rx shoul d not be b illed
	2451	"RTN","PSO CPTRI",104 ,0)
	2452	; 1 => Th e rx may b e billed.
	2453	"RTN","PSO CPTRI",105 ,0)
	2454	;
	2455	"RTN","PSO CPTRI",106 ,0)
	2456	N PSOB
	2457	"RTN","PSO CPTRI",107 ,0)
	2458	;
	2459	"RTN","PSO CPTRI",108 ,0)
	2460	; - ignor e CHAMPUS billing fo r certain RX Patient Statuses
	2461	"RTN","PSO CPTRI",109 ,0)
	2462	I $P($G(^ PS(53,+$P( $G(^PSRX(+ $G(ORIG),0 )),"^",3), 0)),"^",8) G CHKQ
	2463	"RTN","PSO CPTRI",110 ,0)
	2464	;
	2465	"RTN","PSO CPTRI",111 ,0)
	2466	S PSOB=1
	2467	"RTN","PSO CPTRI",112 ,0)
	2468	;
	2469	"RTN","PSO CPTRI",113 ,0)
	2470	CHKQ Q +$G (PSOB)
	2471	"RTN","PSO CPTRI",114 ,0)
	2472	;
	2473	"RTN","PSO CPTRI",115 ,0)
	2474	DEV ;Get d evices
	2475	"RTN","PSO CPTRI",116 ,0)
	2476	N PSOTRIO N
	2477	"RTN","PSO CPTRI",117 ,0)
	2478	S PSOTRIO N=ION
	2479	"RTN","PSO CPTRI",118 ,0)
	2480	I $G(PSOL AP)]"",$G( PSOLAP)'=I ON Q
	2481	"RTN","PSO CPTRI",119 ,0)
	2482	DEVA W ! S %ZIS("B") ="",%ZIS=" MNQ",%ZIS( "A")="Sele ct LABEL D EVICE: " D ^%ZIS I P OP!($E(IOS T)'["P") W !,"Label Printer de vice must be selecte d!",! G DE VA
	2483	"RTN","PSO CPTRI",120 ,0)
	2484	S PSOLAP= ION
	2485	"RTN","PSO CPTRI",121 ,0)
	2486	N PSOIOS S PSOIOS=I OS D DEVBA R^PSOBMST
	2487	"RTN","PSO CPTRI",122 ,0)
	2488	S PSOBARS =PSOBAR1]" "&(PSOBAR0 ]"")&($P($ G(PSOPAR), "^",10))
	2489	"RTN","PSO CPTRI",123 ,0)
	2490	D ^%ZISC S ION=PSOT RION Q
	2491	"RTN","PSO CPTRI",124 ,0)
	2492	;
	2493	"RTN","PSO CPTRI",125 ,0)
	2494	EXM ;Edit Champus Bi lling Exem ption fiel d
	2495	"RTN","PSO CPTRI",126 ,0)
	2496	I '$D(PSO PAR) D ^PS OLSET G EX M
	2497	"RTN","PSO CPTRI",127 ,0)
	2498	W ! K DIC S DIC="^P S(53,",DIC (0)="AEQMZ " D ^DIC K DIC I Y<0 !($D(DTOUT ))!($D(DUO UT)) G EXM Q
	2499	"RTN","PSO CPTRI",128 ,0)
	2500	W ! K DIE S DA=+Y,D IE="^PS(53 ,",DR=16 D ^DIE
	2501	"RTN","PSO CPTRI",129 ,0)
	2502	EXMQ K DIE ,DIC,Y
	2503	"RTN","PSO CPTRI",130 ,0)
	2504	Q
	2505	"RTN","PSO CPTRI",131 ,0)
	2506	RESDIR ;Re set DIR ju st in case
	2507	"RTN","PSO CPTRI",132 ,0)
	2508	S DIR("A" )="LABEL: QUEUE"_$S( $P(PSOPAR, "^",23):"/ HOLD",1:"" )_$S($P(PS OPAR,"^",2 4):"/SUSPE ND",1:"")_ $S($P(PSOP AR,"^",26) :"/LABEL", 1:"")_" or '^' to by pass "
	2509	"RTN","PSO CPTRI",133 ,0)
	2510	S DIR("?" ,1)="Enter 'Q' to qu eue labels to print" ,DIR("?")= "Enter '^' to bypass label fun ctions",DI R("?",4)=" Enter 'S' to suspend labels to print lat er"
	2511	"RTN","PSO CPTRI",134 ,0)
	2512	S DIR("?" ,2)="Enter 'H' to ho ld label u ntil Rx ca n be fille d",DIR("?" ,3)="Enter 'P' for R x profile"
	2513	"RTN","PSO CPTRI",135 ,0)
	2514	S:$P(PSOP AR,"^",26) DIR("?",5 )="Enter ' L' to prin t labels w ithout que uing"
	2515	"RTN","PSO CPTRI",136 ,0)
	2516	Q
	2517	"RTN","PSO CPTRI",137 ,0)
	2518	;
	2519	"RTN","PSO CPTRI",138 ,0)
	2520	GDEA(IEN) ;
	2521	"RTN","PSO CPTRI",139 ,0)
	2522	N DEA
	2523	"RTN","PSO CPTRI",140 ,0)
	2524	I $T(PRDE A^XUSER)]" " S DEA=$$ PRDEA^XUSE R(IEN) ;DB IA2343
	2525	"RTN","PSO CPTRI",141 ,0)
	2526	E S DEA= $$GET1^DIQ (200,IEN_" ,",53.2)
	2527	"RTN","PSO CPTRI",142 ,0)
	2528	Q DEA
	2529	"RTN","PSO CPTRI",143 ,0)
	2530	;
	2531	"RTN","PSO DEAED")
	2532	0^24^B1679 850
	2533	"RTN","PSO DEAED",1,0 )
	2534	PSODEAED ; JLI/FO-OAK LAND-RPC t o handle e pcs data c hanges ;08 /24/12 11 :56
	2535	"RTN","PSO DEAED",2,0 )
	2536	;;7.0;OUT PATIENT PH ARMACY;5 45;DEC 1 997;Build 21
	2537	"RTN","PSO DEAED",3,0 )
	2538	;External reference to XUEPCS DATA file (#8991.6) is suppor ted by DBI A 7015
	2539	"RTN","PSO DEAED",4,0 )
	2540	;
	2541	"RTN","PSO DEAED",5,0 )
	2542	PRINT ; pr int audit logs as in dicated
	2543	"RTN","PSO DEAED",6,0 )
	2544	NEW DIR,I ,VAL,X,Y,B Y,DIC,FLDS ,L
	2545	"RTN","PSO DEAED",7,0 )
	2546	SET DIR(0 )="S^"
	2547	"RTN","PSO DEAED",8,0 )
	2548	FOR I=1:1 :6 SET X=$ T(SORTTYPE +I),DIR(0) =DIR(0)_$S ELECT(I>1: ";",1:"")_ I_":"_$PIE CE(X,";",3 ),VAL(I)=$ PIECE(X,"; ",4)
	2549	"RTN","PSO DEAED",9,0 )
	2550	SET DIR(" A")="SORT BY" DO ^DI R IF +$GET (Y)'>0 QUI T
	2551	"RTN","PSO DEAED",10, 0)
	2552	SET BY=VA L(+Y),FLDS =".06,.01, .02,.03,.0 4,.05",DIC =8991.6,L= "" DO EN1^ DIP
	2553	"RTN","PSO DEAED",11, 0)
	2554	QUIT
	2555	"RTN","PSO DEAED",12, 0)
	2556	;
	2557	"RTN","PSO DEAED",13, 0)
	2558	SORTTYPE ; specifies sort type s for sele ction
	2559	"RTN","PSO DEAED",14, 0)
	2560	;;Sort by Edited By then Date /time;.02, .06,.01
	2561	"RTN","PSO DEAED",15, 0)
	2562	;;Sort by Edited By then User Edited;.0 2,.01,.06
	2563	"RTN","PSO DEAED",16, 0)
	2564	;;Sort by Date/time then Edit ed By;.06, .02,.01
	2565	"RTN","PSO DEAED",17, 0)
	2566	;;Sort by Date/time then User Edited;.0 6,.01,.02
	2567	"RTN","PSO DEAED",18, 0)
	2568	;;Sort by User Edit ed then Ed ited By;.0 1,.02,.06
	2569	"RTN","PSO DEAED",19, 0)
	2570	;;Sort by User Edit ed then Da te;.01,.06 ,.02
	2571	"RTN","PSO DEAED",20, 0)
	2572	; .0 1 . 02 .06
	2573	"RTN","PSO DEAED",21, 0)
	2574	; User Ed ited, Edit ed by, Dat e/Time Edi ted
	2575	"RTN","PSO DEAME")
	2576	0^23^B1983 57593
	2577	"RTN","PSO DEAME",1,0 )
	2578	PSODEAME ; ALB/BI - D EA MANUAL ENTRY ;05/ 15/2018
	2579	"RTN","PSO DEAME",2,0 )
	2580	;;7.0;OUT PATIENT PH ARMACY;5 45;DEC 1 997;Build 21
	2581	"RTN","PSO DEAME",3,0 )
	2582	;External reference to DEA NU MBERS file (#8991.9) is suppor ted by DBI A 7002
	2583	"RTN","PSO DEAME",4,0 )
	2584	;External reference to sub-fi le NEW DEA #S (#200. 5321) is s upported b y DBIA 700 0
	2585	"RTN","PSO DEAME",5,0 )
	2586	Q
	2587	"RTN","PSO DEAME",6,0 )
	2588	;
	2589	"RTN","PSO DEAME",7,0 )
	2590	EN(DEATXT) ; -- main entry poi nt for PSO DEA NUMBE R MANAGEME NT
	2591	"RTN","PSO DEAME",8,0 )
	2592	N CN,FG,R ESPONSE,SC ,FG,GETS,D NDEAIEN,PO P,VALMBCK, VALMCNT,VA LMSG
	2593	"RTN","PSO DEAME",9,0 )
	2594	D CONVNAM E^PSODEAUT (.CN)
	2595	"RTN","PSO DEAME",10, 0)
	2596	S DNDEAIE N=$O(^XTV( 8991.9,"B" ,DEATXT,0) )
	2597	"RTN","PSO DEAME",11, 0)
	2598	S RESPONS E=0
	2599	"RTN","PSO DEAME",12, 0)
	2600	S SC=$$WS GET^PSODEA UT(.FG,DEA TXT)
	2601	"RTN","PSO DEAME",13, 0)
	2602	I 'SC S R ESPONSE=SC W "*"_S C_"*",! G ENX
	2603	"RTN","PSO DEAME",14, 0)
	2604	D EN^VALM ("PSO DEA NUMBER MAN AGEMENT")
	2605	"RTN","PSO DEAME",15, 0)
	2606	ENX ; -- Cleanup an d Exit
	2607	"RTN","PSO DEAME",16, 0)
	2608	S DNDEAIE N=$O(^XTV( 8991.9,"B" ,DEATXT,0) ) S:DNDEAI EN RESPONS E=DNDEAIEN
	2609	"RTN","PSO DEAME",17, 0)
	2610	Q RESPONS E
	2611	"RTN","PSO DEAME",18, 0)
	2612	;
	2613	"RTN","PSO DEAME",19, 0)
	2614	HDR ; -- h eader code
	2615	"RTN","PSO DEAME",20, 0)
	2616	;S VALMHD R(1)="This is a test header fo r PSO DEA NUMBER MAN AGEMENT."
	2617	"RTN","PSO DEAME",21, 0)
	2618	;S VALMHD R(2)="This is the se cond line"
	2619	"RTN","PSO DEAME",22, 0)
	2620	Q
	2621	"RTN","PSO DEAME",23, 0)
	2622	;
	2623	"RTN","PSO DEAME",24, 0)
	2624	INIT ; -- Build the List Array
	2625	"RTN","PSO DEAME",25, 0)
	2626	N LINE,DL INE,CNAME, DS,DSTMP,D TRESULT,NA ME,BAC
	2627	"RTN","PSO DEAME",26, 0)
	2628	S DNDEAIE N=$O(^XTV( 8991.9,"B" ,DEATXT,0) )
	2629	"RTN","PSO DEAME",27, 0)
	2630	D:'$D(GET S) GETS^PS ODEAUT(DND EAIEN,.GET S)
	2631	"RTN","PSO DEAME",28, 0)
	2632	; Special State Pro cessing
	2633	"RTN","PSO DEAME",29, 0)
	2634	N XSTATE, XIP
	2635	"RTN","PSO DEAME",30, 0)
	2636	D POSTAL^ XIPUTIL($G (FG("zipCo de")),.XIP )
	2637	"RTN","PSO DEAME",31, 0)
	2638	S XSTATE= $G(XIP("ST ATE"))
	2639	"RTN","PSO DEAME",32, 0)
	2640	I XSTATE' ="" S FG(" state")=XS TATE ; Poi nter to th e State Fi le #5.
	2641	"RTN","PSO DEAME",33, 0)
	2642	;
	2643	"RTN","PSO DEAME",34, 0)
	2644	S LINE=1
	2645	"RTN","PSO DEAME",35, 0)
	2646	;
	2647	"RTN","PSO DEAME",36, 0)
	2648	S NAME="n ame",DLINE =""
	2649	"RTN","PSO DEAME",37, 0)
	2650	S CNAME=$ S($D(CN(NA ME)):CN(NA ME),1:NAME )
	2651	"RTN","PSO DEAME",38, 0)
	2652	S DSTMP=$ S(FG(NAME) '=$G(GETS( 1.1)):"**" ,1:"")
	2653	"RTN","PSO DEAME",39, 0)
	2654	S DLINE=$ $SETFLD^VA LM1(CNAME_ ":",DLINE, "NAME")
	2655	"RTN","PSO DEAME",40, 0)
	2656	S DLINE=$ $SETFLD^VA LM1(FG(NAM E)_DSTMP,D LINE,"DOJ/ DEA VALUE" )
	2657	"RTN","PSO DEAME",41, 0)
	2658	S DLINE=$ $SETFLD^VA LM1($G(GET S(1.1)),DL INE,"LOCAL VALUE")
	2659	"RTN","PSO DEAME",42, 0)
	2660	D SET^VAL M10(LINE,D LINE) S LI NE=LINE+1
	2661	"RTN","PSO DEAME",43, 0)
	2662	;
	2663	"RTN","PSO DEAME",44, 0)
	2664	S NAME="a ddress1",D LINE=""
	2665	"RTN","PSO DEAME",45, 0)
	2666	S CNAME=$ S($D(CN(NA ME)):CN(NA ME),1:NAME )
	2667	"RTN","PSO DEAME",46, 0)
	2668	S DSTMP=$ S(FG(NAME) '=$G(GETS( 1.2)):"**" ,1:"")
	2669	"RTN","PSO DEAME",47, 0)
	2670	S DLINE=$ $SETFLD^VA LM1(CNAME_ ":",DLINE, "NAME")
	2671	"RTN","PSO DEAME",48, 0)
	2672	S DLINE=$ $SETFLD^VA LM1(FG(NAM E)_DSTMP,D LINE,"DOJ/ DEA VALUE" )
	2673	"RTN","PSO DEAME",49, 0)
	2674	S DLINE=$ $SETFLD^VA LM1($G(GET S(1.2)),DL INE,"LOCAL VALUE")
	2675	"RTN","PSO DEAME",50, 0)
	2676	D SET^VAL M10(LINE,D LINE) S LI NE=LINE+1
	2677	"RTN","PSO DEAME",51, 0)
	2678	;
	2679	"RTN","PSO DEAME",52, 0)
	2680	S NAME="a ddress2",D LINE=""
	2681	"RTN","PSO DEAME",53, 0)
	2682	S CNAME=$ S($D(CN(NA ME)):CN(NA ME),1:NAME )
	2683	"RTN","PSO DEAME",54, 0)
	2684	S DSTMP=$ S(FG(NAME) '=$G(GETS( 1.3)):"**" ,1:"")
	2685	"RTN","PSO DEAME",55, 0)
	2686	S DLINE=$ $SETFLD^VA LM1(CNAME_ ":",DLINE, "NAME")
	2687	"RTN","PSO DEAME",56, 0)
	2688	S DLINE=$ $SETFLD^VA LM1(FG(NAM E)_DSTMP,D LINE,"DOJ/ DEA VALUE" )
	2689	"RTN","PSO DEAME",57, 0)
	2690	S DLINE=$ $SETFLD^VA LM1($G(GET S(1.3)),DL INE,"LOCAL VALUE")
	2691	"RTN","PSO DEAME",58, 0)
	2692	D SET^VAL M10(LINE,D LINE) S LI NE=LINE+1
	2693	"RTN","PSO DEAME",59, 0)
	2694	;
	2695	"RTN","PSO DEAME",60, 0)
	2696	S NAME="a ddress3",D LINE=""
	2697	"RTN","PSO DEAME",61, 0)
	2698	S CNAME=$ S($D(CN(NA ME)):CN(NA ME),1:NAME )
	2699	"RTN","PSO DEAME",62, 0)
	2700	S DSTMP=$ S(FG(NAME) '=$G(GETS( 1.4)):"**" ,1:"")
	2701	"RTN","PSO DEAME",63, 0)
	2702	S DLINE=$ $SETFLD^VA LM1(CNAME_ ":",DLINE, "NAME")
	2703	"RTN","PSO DEAME",64, 0)
	2704	S DLINE=$ $SETFLD^VA LM1(FG(NAM E)_DSTMP,D LINE,"DOJ/ DEA VALUE" )
	2705	"RTN","PSO DEAME",65, 0)
	2706	S DLINE=$ $SETFLD^VA LM1($G(GET S(1.4)),DL INE,"LOCAL VALUE")
	2707	"RTN","PSO DEAME",66, 0)
	2708	D SET^VAL M10(LINE,D LINE) S LI NE=LINE+1
	2709	"RTN","PSO DEAME",67, 0)
	2710	;
	2711	"RTN","PSO DEAME",68, 0)
	2712	S NAME="c ity",DLINE =""
	2713	"RTN","PSO DEAME",69, 0)
	2714	S CNAME=$ S($D(CN(NA ME)):CN(NA ME),1:NAME )
	2715	"RTN","PSO DEAME",70, 0)
	2716	S DSTMP=$ S(FG(NAME) '=$G(GETS( 1.5)):"**" ,1:"")
	2717	"RTN","PSO DEAME",71, 0)
	2718	S DLINE=$ $SETFLD^VA LM1(CNAME_ ":",DLINE, "NAME")
	2719	"RTN","PSO DEAME",72, 0)
	2720	S DLINE=$ $SETFLD^VA LM1(FG(NAM E)_DSTMP,D LINE,"DOJ/ DEA VALUE" )
	2721	"RTN","PSO DEAME",73, 0)
	2722	S DLINE=$ $SETFLD^VA LM1($G(GET S(1.5)),DL INE,"LOCAL VALUE")
	2723	"RTN","PSO DEAME",74, 0)
	2724	D SET^VAL M10(LINE,D LINE) S LI NE=LINE+1
	2725	"RTN","PSO DEAME",75, 0)
	2726	;
	2727	"RTN","PSO DEAME",76, 0)
	2728	S NAME="s tate",DLIN E=""
	2729	"RTN","PSO DEAME",77, 0)
	2730	S CNAME=$ S($D(CN(NA ME)):CN(NA ME),1:NAME )
	2731	"RTN","PSO DEAME",78, 0)
	2732	S DSTMP=$ S(FG(NAME) '=$G(GETS( 1.6)):"**" ,1:"")
	2733	"RTN","PSO DEAME",79, 0)
	2734	S DLINE=$ $SETFLD^VA LM1(CNAME_ ":",DLINE, "NAME")
	2735	"RTN","PSO DEAME",80, 0)
	2736	S DLINE=$ $SETFLD^VA LM1(FG(NAM E)_DSTMP,D LINE,"DOJ/ DEA VALUE" )
	2737	"RTN","PSO DEAME",81, 0)
	2738	S DLINE=$ $SETFLD^VA LM1($G(GET S(1.6)),DL INE,"LOCAL VALUE")
	2739	"RTN","PSO DEAME",82, 0)
	2740	D SET^VAL M10(LINE,D LINE) S LI NE=LINE+1
	2741	"RTN","PSO DEAME",83, 0)
	2742	;
	2743	"RTN","PSO DEAME",84, 0)
	2744	S NAME="z ipCode",DL INE=""
	2745	"RTN","PSO DEAME",85, 0)
	2746	S CNAME=$ S($D(CN(NA ME)):CN(NA ME),1:NAME )
	2747	"RTN","PSO DEAME",86, 0)
	2748	S DSTMP=$ S(FG(NAME) '=$G(GETS( 1.7)):"**" ,1:"")
	2749	"RTN","PSO DEAME",87, 0)
	2750	S DLINE=$ $SETFLD^VA LM1(CNAME_ ":",DLINE, "NAME")
	2751	"RTN","PSO DEAME",88, 0)
	2752	S DLINE=$ $SETFLD^VA LM1(FG(NAM E)_DSTMP,D LINE,"DOJ/ DEA VALUE" )
	2753	"RTN","PSO DEAME",89, 0)
	2754	S DLINE=$ $SETFLD^VA LM1($G(GET S(1.7)),DL INE,"LOCAL VALUE")
	2755	"RTN","PSO DEAME",90, 0)
	2756	D SET^VAL M10(LINE,D LINE) S LI NE=LINE+1
	2757	"RTN","PSO DEAME",91, 0)
	2758	;
	2759	"RTN","PSO DEAME",92, 0)
	2760	S NAME="b usinessAct ivityCode" ,DLINE=""
	2761	"RTN","PSO DEAME",93, 0)
	2762	S CNAME=$ S($D(CN(NA ME)):CN(NA ME),1:NAME )
	2763	"RTN","PSO DEAME",94, 0)
	2764	S DSTMP=$ S(FG(NAME) _$G(FG("bu sinessActi vitySubcod e"))'=$G(G ETS(.02)): "**",1:"")
	2765	"RTN","PSO DEAME",95, 0)
	2766	S DLINE=$ $SETFLD^VA LM1(CNAME_ ":",DLINE, "NAME")
	2767	"RTN","PSO DEAME",96, 0)
	2768	S DLINE=$ $SETFLD^VA LM1(FG(NAM E)_$G(FG(" businessAc tivitySubc ode"))_DST MP,DLINE," DOJ/DEA VA LUE")
	2769	"RTN","PSO DEAME",97, 0)
	2770	S DLINE=$ $SETFLD^VA LM1($G(GET S(.02)),DL INE,"LOCAL VALUE")
	2771	"RTN","PSO DEAME",98, 0)
	2772	D SET^VAL M10(LINE,D LINE) S LI NE=LINE+1
	2773	"RTN","PSO DEAME",99, 0)
	2774	;
	2775	"RTN","PSO DEAME",100 ,0)
	2776	S NAME="t ype",DLINE =""
	2777	"RTN","PSO DEAME",101 ,0)
	2778	S CNAME=$ S($D(CN(NA ME)):CN(NA ME),1:NAME )
	2779	"RTN","PSO DEAME",102 ,0)
	2780	S DSTMP=$ S(FG(NAME) '=$G(GETS( .07)):"**" ,1:"")
	2781	"RTN","PSO DEAME",103 ,0)
	2782	S DLINE=$ $SETFLD^VA LM1(CNAME_ ":",DLINE, "NAME")
	2783	"RTN","PSO DEAME",104 ,0)
	2784	S DLINE=$ $SETFLD^VA LM1(FG(NAM E)_DSTMP,D LINE,"DOJ/ DEA VALUE" )
	2785	"RTN","PSO DEAME",105 ,0)
	2786	S DLINE=$ $SETFLD^VA LM1($G(GET S(.07)),DL INE,"LOCAL VALUE")
	2787	"RTN","PSO DEAME",106 ,0)
	2788	D SET^VAL M10(LINE,D LINE) S LI NE=LINE+1
	2789	"RTN","PSO DEAME",107 ,0)
	2790	;
	2791	"RTN","PSO DEAME",108 ,0)
	2792	S NAME="d eaNumber", DLINE=""
	2793	"RTN","PSO DEAME",109 ,0)
	2794	S CNAME=$ S($D(CN(NA ME)):CN(NA ME),1:NAME )
	2795	"RTN","PSO DEAME",110 ,0)
	2796	S DSTMP=$ S(FG(NAME) '=$G(GETS( .01)):"**" ,1:"")
	2797	"RTN","PSO DEAME",111 ,0)
	2798	S DLINE=$ $SETFLD^VA LM1(CNAME_ ":",DLINE, "NAME")
	2799	"RTN","PSO DEAME",112 ,0)
	2800	S DLINE=$ $SETFLD^VA LM1(FG(NAM E)_DSTMP,D LINE,"DOJ/ DEA VALUE" )
	2801	"RTN","PSO DEAME",113 ,0)
	2802	S DLINE=$ $SETFLD^VA LM1($G(GET S(.01)),DL INE,"LOCAL VALUE")
	2803	"RTN","PSO DEAME",114 ,0)
	2804	D SET^VAL M10(LINE,D LINE) S LI NE=LINE+1
	2805	"RTN","PSO DEAME",115 ,0)
	2806	;
	2807	"RTN","PSO DEAME",116 ,0)
	2808	; DETOX N UMBER DISP LAY
	2809	"RTN","PSO DEAME",117 ,0)
	2810	S BAC=$G( FG("busine ssActivity Code"))_$G (FG("busin essActivit ySubcode") )
	2811	"RTN","PSO DEAME",118 ,0)
	2812	S DLINE=" "
	2813	"RTN","PSO DEAME",119 ,0)
	2814	S DSTMP=$ S($$DETOXC HK^PSODEAU T(BAC):"X" _$E(FG(NAM E),2,9),1: "")
	2815	"RTN","PSO DEAME",120 ,0)
	2816	S DSTMP=D STMP_$S(DS TMP'=$G(GE TS(.03)):" **",1:"")
	2817	"RTN","PSO DEAME",121 ,0)
	2818	S DLINE=$ $SETFLD^VA LM1("DETOX NUMBER:", DLINE,"NAM E")
	2819	"RTN","PSO DEAME",122 ,0)
	2820	S DLINE=$ $SETFLD^VA LM1(DSTMP, DLINE,"DOJ /DEA VALUE ")
	2821	"RTN","PSO DEAME",123 ,0)
	2822	S DLINE=$ $SETFLD^VA LM1($G(GET S(.03)),DL INE,"LOCAL VALUE")
	2823	"RTN","PSO DEAME",124 ,0)
	2824	D SET^VAL M10(LINE,D LINE) S LI NE=LINE+1
	2825	"RTN","PSO DEAME",125 ,0)
	2826	;
	2827	"RTN","PSO DEAME",126 ,0)
	2828	S NAME="e xpirationD ate",DLINE =""
	2829	"RTN","PSO DEAME",127 ,0)
	2830	S CNAME=$ S($D(CN(NA ME)):CN(NA ME),1:NAME )
	2831	"RTN","PSO DEAME",128 ,0)
	2832	D DT^DILF ("E",FG(NA ME),.DTRES ULT)
	2833	"RTN","PSO DEAME",129 ,0)
	2834	S:$D(DTRE SULT(0)) D STMP=$S(DT RESULT(0)' =$G(GETS(. 04)):"**", 1:"")
	2835	"RTN","PSO DEAME",130 ,0)
	2836	S DLINE=$ $SETFLD^VA LM1(CNAME_ ":",DLINE, "NAME")
	2837	"RTN","PSO DEAME",131 ,0)
	2838	S DLINE=$ $SETFLD^VA LM1(DTRESU LT(0)_DSTM P,DLINE,"D OJ/DEA VAL UE")
	2839	"RTN","PSO DEAME",132 ,0)
	2840	S DLINE=$ $SETFLD^VA LM1($G(GET S(.04)),DL INE,"LOCAL VALUE")
	2841	"RTN","PSO DEAME",133 ,0)
	2842	D SET^VAL M10(LINE,D LINE) S LI NE=LINE+1
	2843	"RTN","PSO DEAME",134 ,0)
	2844	;
	2845	"RTN","PSO DEAME",135 ,0)
	2846	S NAME="d rugSchedul e",DLINE=" "
	2847	"RTN","PSO DEAME",136 ,0)
	2848	S DS=$G(F G("drugSch edule"))
	2849	"RTN","PSO DEAME",137 ,0)
	2850	;
	2851	"RTN","PSO DEAME",138 ,0)
	2852	; SCHEDUL E II NARCO TIC
	2853	"RTN","PSO DEAME",139 ,0)
	2854	S DLINE=$ $SETFLD^VA LM1("SCH I I NARC:",D LINE,"NAME ")
	2855	"RTN","PSO DEAME",140 ,0)
	2856	S DSTMP=$ S(DS["22N" :"YES",(DS ["2"&(DS'[ "2N")):"YE S",1:"NO")
	2857	"RTN","PSO DEAME",141 ,0)
	2858	S DSTMP=D STMP_$S(DS TMP'=$G(GE TS(2.1)):" **",1:"")
	2859	"RTN","PSO DEAME",142 ,0)
	2860	S DLINE=$ $SETFLD^VA LM1(DSTMP, DLINE,"DOJ /DEA VALUE ")
	2861	"RTN","PSO DEAME",143 ,0)
	2862	S DLINE=$ $SETFLD^VA LM1($G(GET S(2.1)),DL INE,"LOCAL VALUE")
	2863	"RTN","PSO DEAME",144 ,0)
	2864	D SET^VAL M10(LINE,D LINE) S LI NE=LINE+1
	2865	"RTN","PSO DEAME",145 ,0)
	2866	;
	2867	"RTN","PSO DEAME",146 ,0)
	2868	; SCHEDUL E II NON-N ARCOTIC
	2869	"RTN","PSO DEAME",147 ,0)
	2870	S DLINE=$ $SETFLD^VA LM1("SCH I I NON-NARC :",DLINE," NAME")
	2871	"RTN","PSO DEAME",148 ,0)
	2872	S DSTMP=$ S(DS["2N": "YES",1:"N O")
	2873	"RTN","PSO DEAME",149 ,0)
	2874	S DSTMP=D STMP_$S(DS TMP'=$G(GE TS(2.2)):" **",1:"")
	2875	"RTN","PSO DEAME",150 ,0)
	2876	S DLINE=$ $SETFLD^VA LM1(DSTMP, DLINE,"DOJ /DEA VALUE ")
	2877	"RTN","PSO DEAME",151 ,0)
	2878	S DLINE=$ $SETFLD^VA LM1($G(GET S(2.2)),DL INE,"LOCAL VALUE")
	2879	"RTN","PSO DEAME",152 ,0)
	2880	D SET^VAL M10(LINE,D LINE) S LI NE=LINE+1
	2881	"RTN","PSO DEAME",153 ,0)
	2882	;
	2883	"RTN","PSO DEAME",154 ,0)
	2884	; SCHEDUL E III NARC OTIC
	2885	"RTN","PSO DEAME",155 ,0)
	2886	S DLINE=$ $SETFLD^VA LM1("SCH I II NARC:", DLINE,"NAM E")
	2887	"RTN","PSO DEAME",156 ,0)
	2888	S DSTMP=$ S(DS["33N" :"YES",DS[ "3"&(DS'[" 3N"):"YES" ,1:"NO")
	2889	"RTN","PSO DEAME",157 ,0)
	2890	S DSTMP=D STMP_$S(DS TMP'=$G(GE TS(2.3)):" **",1:"")
	2891	"RTN","PSO DEAME",158 ,0)
	2892	S DLINE=$ $SETFLD^VA LM1(DSTMP, DLINE,"DOJ /DEA VALUE ")
	2893	"RTN","PSO DEAME",159 ,0)
	2894	S DLINE=$ $SETFLD^VA LM1($G(GET S(2.3)),DL INE,"LOCAL VALUE")
	2895	"RTN","PSO DEAME",160 ,0)
	2896	D SET^VAL M10(LINE,D LINE) S LI NE=LINE+1
	2897	"RTN","PSO DEAME",161 ,0)
	2898	;
	2899	"RTN","PSO DEAME",162 ,0)
	2900	; SCHEDUL E III NON- NARCOTIC
	2901	"RTN","PSO DEAME",163 ,0)
	2902	S DLINE=$ $SETFLD^VA LM1("SCH I II NON-NAR C:",DLINE, "NAME")
	2903	"RTN","PSO DEAME",164 ,0)
	2904	S DSTMP=$ S(DS["3N": "YES",1:"N O")
	2905	"RTN","PSO DEAME",165 ,0)
	2906	S DSTMP=D STMP_$S(DS TMP'=$G(GE TS(2.4)):" **",1:"")
	2907	"RTN","PSO DEAME",166 ,0)
	2908	S DLINE=$ $SETFLD^VA LM1(DSTMP, DLINE,"DOJ /DEA VALUE ")
	2909	"RTN","PSO DEAME",167 ,0)
	2910	S DLINE=$ $SETFLD^VA LM1($G(GET S(2.4)),DL INE,"LOCAL VALUE")
	2911	"RTN","PSO DEAME",168 ,0)
	2912	D SET^VAL M10(LINE,D LINE) S LI NE=LINE+1
	2913	"RTN","PSO DEAME",169 ,0)
	2914	;
	2915	"RTN","PSO DEAME",170 ,0)
	2916	; SCHEDUL E IV
	2917	"RTN","PSO DEAME",171 ,0)
	2918	S DLINE=$ $SETFLD^VA LM1("SCH I V:",DLINE, "NAME")
	2919	"RTN","PSO DEAME",172 ,0)
	2920	S DSTMP=$ S(DS["4":" YES",1:"NO ")
	2921	"RTN","PSO DEAME",173 ,0)
	2922	S DSTMP=D STMP_$S(DS TMP'=$G(GE TS(2.5)):" **",1:"")
	2923	"RTN","PSO DEAME",174 ,0)
	2924	S DLINE=$ $SETFLD^VA LM1(DSTMP, DLINE,"DOJ /DEA VALUE ")
	2925	"RTN","PSO DEAME",175 ,0)
	2926	S DLINE=$ $SETFLD^VA LM1($G(GET S(2.5)),DL INE,"LOCAL VALUE")
	2927	"RTN","PSO DEAME",176 ,0)
	2928	D SET^VAL M10(LINE,D LINE) S LI NE=LINE+1
	2929	"RTN","PSO DEAME",177 ,0)
	2930	;
	2931	"RTN","PSO DEAME",178 ,0)
	2932	; SCHEDUL E V
	2933	"RTN","PSO DEAME",179 ,0)
	2934	S DLINE=$ $SETFLD^VA LM1("SCH V :",DLINE," NAME")
	2935	"RTN","PSO DEAME",180 ,0)
	2936	S DSTMP=$ S(DS["5":" YES",1:"NO ") ; SCHED ULE V
	2937	"RTN","PSO DEAME",181 ,0)
	2938	S DSTMP=D STMP_$S(DS TMP'=$G(GE TS(2.6)):" **",1:"")
	2939	"RTN","PSO DEAME",182 ,0)
	2940	S DLINE=$ $SETFLD^VA LM1(DSTMP, DLINE,"DOJ /DEA VALUE ")
	2941	"RTN","PSO DEAME",183 ,0)
	2942	S DLINE=$ $SETFLD^VA LM1($G(GET S(2.6)),DL INE,"LOCAL VALUE")
	2943	"RTN","PSO DEAME",184 ,0)
	2944	D SET^VAL M10(LINE,D LINE) S LI NE=LINE+1
	2945	"RTN","PSO DEAME",185 ,0)
	2946	;
	2947	"RTN","PSO DEAME",186 ,0)
	2948	S NAME="p rocessedDa te",DLINE= ""
	2949	"RTN","PSO DEAME",187 ,0)
	2950	S CNAME=$ S($D(CN(NA ME)):CN(NA ME),1:NAME )
	2951	"RTN","PSO DEAME",188 ,0)
	2952	D DT^DILF ("E",FG(NA ME),.DTRES ULT)
	2953	"RTN","PSO DEAME",189 ,0)
	2954	S:$D(DTRE SULT(0)) D STMP=$S(DT RESULT(0)' =$G(GETS(1 0.3)):"**" ,1:"")
	2955	"RTN","PSO DEAME",190 ,0)
	2956	S DLINE=$ $SETFLD^VA LM1(CNAME_ ":",DLINE, "NAME")
	2957	"RTN","PSO DEAME",191 ,0)
	2958	S DLINE=$ $SETFLD^VA LM1(DTRESU LT(0)_DSTM P,DLINE,"D OJ/DEA VAL UE")
	2959	"RTN","PSO DEAME",192 ,0)
	2960	S DLINE=$ $SETFLD^VA LM1($G(GET S(10.3)),D LINE,"LOCA L VALUE")
	2961	"RTN","PSO DEAME",193 ,0)
	2962	D SET^VAL M10(LINE,D LINE) S LI NE=LINE+1
	2963	"RTN","PSO DEAME",194 ,0)
	2964	;
	2965	"RTN","PSO DEAME",195 ,0)
	2966	S VALMCNT =LINE-1
	2967	"RTN","PSO DEAME",196 ,0)
	2968	Q
	2969	"RTN","PSO DEAME",197 ,0)
	2970	;
	2971	"RTN","PSO DEAME",198 ,0)
	2972	HELP ; -- help code
	2973	"RTN","PSO DEAME",199 ,0)
	2974	N X
	2975	"RTN","PSO DEAME",200 ,0)
	2976	S X="?" D DISP^XQOR M1 W !!
	2977	"RTN","PSO DEAME",201 ,0)
	2978	Q
	2979	"RTN","PSO DEAME",202 ,0)
	2980	;
	2981	"RTN","PSO DEAME",203 ,0)
	2982	EXIT ; -- exit code
	2983	"RTN","PSO DEAME",204 ,0)
	2984	Q
	2985	"RTN","PSO DEAME",205 ,0)
	2986	;
	2987	"RTN","PSO DEAME",206 ,0)
	2988	EXPND ; -- expand co de
	2989	"RTN","PSO DEAME",207 ,0)
	2990	Q
	2991	"RTN","PSO DEAME",208 ,0)
	2992	;
	2993	"RTN","PSO DEAME",209 ,0)
	2994	ACTIONA ; -- Perfor m Action A : ACCEPT A ND SAVE CH ANGES
	2995	"RTN","PSO DEAME",210 ,0)
	2996	N FDA ; FileMa n Data Arr ay used to insert da ta into fi le #8991.9
	2997	"RTN","PSO DEAME",211 ,0)
	2998	N DNDEAIE N ; The IE N for the entry in t he DEA NUM BERS FILE #8991.9
	2999	"RTN","PSO DEAME",212 ,0)
	3000	N IENROOT ; Variab le for the IEN being returned from the ^ DIE call.
	3001	"RTN","PSO DEAME",213 ,0)
	3002	N IENS ; ENTRY IEN VALUE
	3003	"RTN","PSO DEAME",214 ,0)
	3004	N MSGROOT ; Messag e Root for the error messages from the ^ DIE call.
	3005	"RTN","PSO DEAME",215 ,0)
	3006	I '$D(GET S) S VALMS G="NOTHING TO SAVE", VALMBCK="R " Q
	3007	"RTN","PSO DEAME",216 ,0)
	3008	S:$G(GETS (.01))'="" DNDEAIEN= $O(^XTV(89 91.9,"B",G ETS(.01),0 ))
	3009	"RTN","PSO DEAME",217 ,0)
	3010	S IENS=$S ($G(DNDEAI EN):$G(DND EAIEN)_"," ,1:"+1,")
	3011	"RTN","PSO DEAME",218 ,0)
	3012	D FULL^VA LM1
	3013	"RTN","PSO DEAME",219 ,0)
	3014	D CLEAN^V ALM10
	3015	"RTN","PSO DEAME",220 ,0)
	3016	S FDA(1,8 991.9,IENS ,1.1)=GETS (1.1) ; NAME
	3017	"RTN","PSO DEAME",221 ,0)
	3018	S FDA(1,8 991.9,IENS ,1.2)=GETS (1.2) ; ADDRESS 1
	3019	"RTN","PSO DEAME",222 ,0)
	3020	S FDA(1,8 991.9,IENS ,1.3)=GETS (1.3) ; ADDRESS 2
	3021	"RTN","PSO DEAME",223 ,0)
	3022	S FDA(1,8 991.9,IENS ,1.4)=GETS (1.4) ; ADDRESS 3
	3023	"RTN","PSO DEAME",224 ,0)
	3024	S FDA(1,8 991.9,IENS ,1.5)=GETS (1.5) ; CITY
	3025	"RTN","PSO DEAME",225 ,0)
	3026	S FDA(1,8 991.9,IENS ,1.6)=GETS (1.6) ; STATE
	3027	"RTN","PSO DEAME",226 ,0)
	3028	S FDA(1,8 991.9,IENS ,1.7)=GETS (1.7) ; ZIP CODE
	3029	"RTN","PSO DEAME",227 ,0)
	3030	S FDA(1,8 991.9,IENS ,.02)=GETS (.02) ; BUSINESS A CTIVITY CO DE AND SUB CODE
	3031	"RTN","PSO DEAME",228 ,0)
	3032	S FDA(1,8 991.9,IENS ,.07)=GETS (.07) ; TYPE
	3033	"RTN","PSO DEAME",229 ,0)
	3034	S FDA(1,8 991.9,IENS ,.01)=GETS (.01) ; DEA NUMBER
	3035	"RTN","PSO DEAME",230 ,0)
	3036	I GETS(.0 3)'="" D C LEARDTX(NP IEN) ; REMOVE DET OX NUMBERS FROM OTHE R DEA NUMB ERS
	3037	"RTN","PSO DEAME",231 ,0)
	3038	S FDA(1,8 991.9,IENS ,.03)=GETS (.03) ; DETOX NUMB ER
	3039	"RTN","PSO DEAME",232 ,0)
	3040	S FDA(1,8 991.9,IENS ,.04)=GETS (.04) ; EXPIRATION DATE
	3041	"RTN","PSO DEAME",233 ,0)
	3042	S FDA(1,8 991.9,IENS ,2.1)=GETS (2.1) ; SCHEDULE I I NARCOTIC
	3043	"RTN","PSO DEAME",234 ,0)
	3044	S FDA(1,8 991.9,IENS ,2.2)=GETS (2.2) ; SCHEDULE I I NON-NARC OTIC
	3045	"RTN","PSO DEAME",235 ,0)
	3046	S FDA(1,8 991.9,IENS ,2.3)=GETS (2.3) ; SCHEDULE I II NARCOTI C
	3047	"RTN","PSO DEAME",236 ,0)
	3048	S FDA(1,8 991.9,IENS ,2.4)=GETS (2.4) ; SCHEDULE I II NON-NAR COTIC
	3049	"RTN","PSO DEAME",237 ,0)
	3050	S FDA(1,8 991.9,IENS ,2.5)=GETS (2.5) ; SCHEDULE I V
	3051	"RTN","PSO DEAME",238 ,0)
	3052	S FDA(1,8 991.9,IENS ,2.6)=GETS (2.6) ; SCHEDULE V
	3053	"RTN","PSO DEAME",239 ,0)
	3054	S FDA(1,8 991.9,IENS ,10.2)="N" ; LAST UPDAT ED DATE/TI ME
	3055	"RTN","PSO DEAME",240 ,0)
	3056	S FDA(1,8 991.9,IENS ,10.3)=GET S(10.3) ; LAST DOJ U PDATE
	3057	"RTN","PSO DEAME",241 ,0)
	3058	D UPDATE^ DIE("E","F DA(1)","IE NROOT","MS GROOT")
	3059	"RTN","PSO DEAME",242 ,0)
	3060	I $D(MSGR OOT) D ACT IONAM G AC TIONAX
	3061	"RTN","PSO DEAME",243 ,0)
	3062	S DNDEAIE N=$S($D(IE NROOT(1)): IENROOT(1) ,1:IENS)
	3063	"RTN","PSO DEAME",244 ,0)
	3064	S FDA(2,8 991.9,DNDE AIEN_",",1 0.1)=DUZ D FILE^DIE( "","FDA(2) ","MSGROOT ")
	3065	"RTN","PSO DEAME",245 ,0)
	3066	ACTIONAX ; -- Retur n here to end cleanl y.
	3067	"RTN","PSO DEAME",246 ,0)
	3068	S VALMBCK ="Q"
	3069	"RTN","PSO DEAME",247 ,0)
	3070	Q
	3071	"RTN","PSO DEAME",248 ,0)
	3072	;
	3073	"RTN","PSO DEAME",249 ,0)
	3074	ACTIONAM ; -- Provi de filing error mess ge and pau se.
	3075	"RTN","PSO DEAME",250 ,0)
	3076	N DIR
	3077	"RTN","PSO DEAME",251 ,0)
	3078	W !!,"* The infor mation cou ld not be filed *" ,!
	3079	"RTN","PSO DEAME",252 ,0)
	3080	W:$D(MSGR OOT("DIERR ",1,"TEXT" ,1)) MSGRO OT("DIERR" ,1,"TEXT", 1),!
	3081	"RTN","PSO DEAME",253 ,0)
	3082	S DIR(0)= "E" D ^DIR W !
	3083	"RTN","PSO DEAME",254 ,0)
	3084	Q
	3085	"RTN","PSO DEAME",255 ,0)
	3086	;
	3087	"RTN","PSO DEAME",256 ,0)
	3088	ACTIONC ; -- Perfor m Action C : COPY DOJ /DEA VALUE S TO VISTA
	3089	"RTN","PSO DEAME",257 ,0)
	3090	N SC
	3091	"RTN","PSO DEAME",258 ,0)
	3092	D DEACOPY (.FG)
	3093	"RTN","PSO DEAME",259 ,0)
	3094	D CLEAN^V ALM10
	3095	"RTN","PSO DEAME",260 ,0)
	3096	D INIT
	3097	"RTN","PSO DEAME",261 ,0)
	3098	S VALMBCK ="R"
	3099	"RTN","PSO DEAME",262 ,0)
	3100	Q
	3101	"RTN","PSO DEAME",263 ,0)
	3102	;
	3103	"RTN","PSO DEAME",264 ,0)
	3104	ACTIONE ; -- Perfor m Action E : EDIT VIS TA VALUES
	3105	"RTN","PSO DEAME",265 ,0)
	3106	N DIRUT,D IR,X,Y
	3107	"RTN","PSO DEAME",266 ,0)
	3108	I '$D(GET S) S VALMS G="NOTHING TO EDIT", VALMBCK="R " Q
	3109	"RTN","PSO DEAME",267 ,0)
	3110	D FULL^VA LM1
	3111	"RTN","PSO DEAME",268 ,0)
	3112	D CLEAN^V ALM10
	3113	"RTN","PSO DEAME",269 ,0)
	3114	;
	3115	"RTN","PSO DEAME",270 ,0)
	3116	; DETOX
	3117	"RTN","PSO DEAME",271 ,0)
	3118	N CDETOX, NDETOX,GET S03
	3119	"RTN","PSO DEAME",272 ,0)
	3120	D:GETS(.0 7)="INDIVI DUAL"
	3121	"RTN","PSO DEAME",273 ,0)
	3122	. S GETS0 3=GETS(.03 )
	3123	"RTN","PSO DEAME",274 ,0)
	3124	. S CDETO X=$$GETDND TX^PSODEAU T(NPIEN)
	3125	"RTN","PSO DEAME",275 ,0)
	3126	. K DTOUT ,DUOUT,DIR S DIR(0)= "FO^9:9^K: '$$DEANUM^ PSODEAUT(X ) X",DIR(" A")="DETOX ",DIR("B") =GETS(.03)
	3127	"RTN","PSO DEAME",276 ,0)
	3128	. S DIR(" ?")="Respo nse must c ontain 2 l etters and 7 numbers in the nu meric form at of a DE A number." D ^DIR
	3129	"RTN","PSO DEAME",277 ,0)
	3130	. Q:$D(DT OUT)!($D(D UOUT))
	3131	"RTN","PSO DEAME",278 ,0)
	3132	. S NDETO X=Y
	3133	"RTN","PSO DEAME",279 ,0)
	3134	. I X="@" S GETS(.0 3)=$$UP^XL FSTR(NDETO X) Q
	3135	"RTN","PSO DEAME",280 ,0)
	3136	. I CDETO X="" S GET S(.03)=$$U P^XLFSTR(N DETOX) Q
	3137	"RTN","PSO DEAME",281 ,0)
	3138	. I CDETO X'=""&(NDE TOX'="")&( CDETOX'=ND ETOX) D
	3139	"RTN","PSO DEAME",282 ,0)
	3140	.. K DTOU T,DUOUT,DI R S DIR(0) ="Y"
	3141	"RTN","PSO DEAME",283 ,0)
	3142	.. S DIR( "A",1)="DE TOX NUMBER : "_CDETOX _" already exists fo r this pro vider."
	3143	"RTN","PSO DEAME",284 ,0)
	3144	.. S DIR( "A",2)="Do you want to replace the exist ing DETOX number?"
	3145	"RTN","PSO DEAME",285 ,0)
	3146	.. S DIR( "A")="Ente r Yes or N o:"
	3147	"RTN","PSO DEAME",286 ,0)
	3148	.. D ^DIR I '($D(DT OUT)!($D(D UOUT))) D
	3149	"RTN","PSO DEAME",287 ,0)
	3150	... I 'Y S GETS(.03 )=$$UP^XLF STR(GETS03 )
	3151	"RTN","PSO DEAME",288 ,0)
	3152	... I Y S GETS(.03) =$$UP^XLFS TR(NDETOX)
	3153	"RTN","PSO DEAME",289 ,0)
	3154	G:$D(DTOU T)!($D(DUO UT)) ACTIO NEX
	3155	"RTN","PSO DEAME",290 ,0)
	3156	K DTOUT,D UOUT
	3157	"RTN","PSO DEAME",291 ,0)
	3158	;
	3159	"RTN","PSO DEAME",292 ,0)
	3160	; EXPIRAT ION DATE
	3161	"RTN","PSO DEAME",293 ,0)
	3162	D DT^DILF ("E",GETS( .04),.DTRE SULT)
	3163	"RTN","PSO DEAME",294 ,0)
	3164	K DTOUT,D UOUT,DIR S DIR(0)="D ^::EX",DIR ("A")="EXP IRATION DA TE" S:$D(D TRESULT(0) ) DIR("B") =DTRESULT( 0) D ^DIR
	3165	"RTN","PSO DEAME",295 ,0)
	3166	G:$D(DTOU T)!($D(DUO UT)) ACTIO NEX D DT^D ILF("E",Y( 0),.DTRESU LT) S GETS (.04)=DTRE SULT(0)
	3167	"RTN","PSO DEAME",296 ,0)
	3168	;
	3169	"RTN","PSO DEAME",297 ,0)
	3170	; SCHEDUL E II NARCO TIC
	3171	"RTN","PSO DEAME",298 ,0)
	3172	K DTOUT,D UOUT,DIR S DIR(0)="Y ",DIR("A") ="SCHEDULE II NARCOT IC",DIR("B ")=$S(GETS (2.1)="YES ":"YES",1: "NO") D ^D IR
	3173	"RTN","PSO DEAME",299 ,0)
	3174	G:$D(DTOU T)!($D(DUO UT)) ACTIO NEX S GETS (2.1)=$S(Y =1:"YES",1 :"NO")
	3175	"RTN","PSO DEAME",300 ,0)
	3176	;
	3177	"RTN","PSO DEAME",301 ,0)
	3178	; SCHEDUL E II NON-N ARCOTIC
	3179	"RTN","PSO DEAME",302 ,0)
	3180	K DTOUT,D UOUT,DIR S DIR(0)="Y ",DIR("A") ="SCHEDULE II NON-NA RCOTIC",DI R("B")=$S( GETS(2.2)= "YES":"YES ",1:"NO") D ^DIR
	3181	"RTN","PSO DEAME",303 ,0)
	3182	G:$D(DTOU T)!($D(DUO UT)) ACTIO NEX S GETS (2.2)=$S(Y =1:"YES",1 :"NO")
	3183	"RTN","PSO DEAME",304 ,0)
	3184	;
	3185	"RTN","PSO DEAME",305 ,0)
	3186	; SCHEDUL E III NARC OTIC
	3187	"RTN","PSO DEAME",306 ,0)
	3188	K DTOUT,D UOUT,DIR S DIR(0)="Y ",DIR("A") ="SCHEDULE III NARCO TIC",DIR(" B")=$S(GET S(2.3)="YE S":"YES",1 :"NO") D ^ DIR
	3189	"RTN","PSO DEAME",307 ,0)
	3190	G:$D(DTOU T)!($D(DUO UT)) ACTIO NEX S GETS (2.3)=$S(Y =1:"YES",1 :"NO")
	3191	"RTN","PSO DEAME",308 ,0)
	3192	;
	3193	"RTN","PSO DEAME",309 ,0)
	3194	; SCHEDUL E III NON- NARCOTIC
	3195	"RTN","PSO DEAME",310 ,0)
	3196	K DTOUT,D UOUT,DIR S DIR(0)="Y ",DIR("A") ="SCHEDULE III NON-N ARCOTIC",D IR("B")=$S (GETS(2.4) ="YES":"YE S",1:"NO") D ^DIR
	3197	"RTN","PSO DEAME",311 ,0)
	3198	G:$D(DTOU T)!($D(DUO UT)) ACTIO NEX S GETS (2.4)=$S(Y =1:"YES",1 :"NO")
	3199	"RTN","PSO DEAME",312 ,0)
	3200	;
	3201	"RTN","PSO DEAME",313 ,0)
	3202	; SCHEDUL E IV
	3203	"RTN","PSO DEAME",314 ,0)
	3204	K DTOUT,D UOUT,DIR S DIR(0)="Y ",DIR("A") ="SCHEDULE IV",DIR(" B")=$S(GET S(2.5)="YE S":"YES",1 :"NO") D ^ DIR
	3205	"RTN","PSO DEAME",315 ,0)
	3206	G:$D(DTOU T)!($D(DUO UT)) ACTIO NEX S GETS (2.5)=$S(Y =1:"YES",1 :"NO")
	3207	"RTN","PSO DEAME",316 ,0)
	3208	;
	3209	"RTN","PSO DEAME",317 ,0)
	3210	; SCHEDUL E V
	3211	"RTN","PSO DEAME",318 ,0)
	3212	K DTOUT,D UOUT,DIR S DIR(0)="Y ",DIR("A") ="SCHEDULE V",DIR("B ")=$S(GETS (2.6)="YES ":"YES",1: "NO") D ^D IR
	3213	"RTN","PSO DEAME",319 ,0)
	3214	G:$D(DTOU T)!($D(DUO UT)) ACTIO NEX S GETS (2.6)=$S(Y =1:"YES",1 :"NO")
	3215	"RTN","PSO DEAME",320 ,0)
	3216	;
	3217	"RTN","PSO DEAME",321 ,0)
	3218	ACTIONEX ; -- ACTIO NE Clean E xit Point
	3219	"RTN","PSO DEAME",322 ,0)
	3220	K DIRUT,D IR
	3221	"RTN","PSO DEAME",323 ,0)
	3222	D INIT
	3223	"RTN","PSO DEAME",324 ,0)
	3224	S VALMBCK ="R"
	3225	"RTN","PSO DEAME",325 ,0)
	3226	Q
	3227	"RTN","PSO DEAME",326 ,0)
	3228	;
	3229	"RTN","PSO DEAME",327 ,0)
	3230	ACTIONX ; -- Perfor m Action X : QUIT AND REJECT CH ANGES
	3231	"RTN","PSO DEAME",328 ,0)
	3232	D FULL^VA LM1
	3233	"RTN","PSO DEAME",329 ,0)
	3234	D CLEAN^V ALM10
	3235	"RTN","PSO DEAME",330 ,0)
	3236	S VALMBCK ="Q"
	3237	"RTN","PSO DEAME",331 ,0)
	3238	Q
	3239	"RTN","PSO DEAME",332 ,0)
	3240	;
	3241	"RTN","PSO DEAME",333 ,0)
	3242	DEACOPY(FG ) ; -- Pri vate Subro utine to C opy import data in t he GETS Ar ray
	3243	"RTN","PSO DEAME",334 ,0)
	3244	; POSTAL^ XIPUTL use d in agree ment with Integratio n Agreemen t: 3618
	3245	"RTN","PSO DEAME",335 ,0)
	3246	;
	3247	"RTN","PSO DEAME",336 ,0)
	3248	; INPUT: FG ;Web Servi ce Respons e Global
	3249	"RTN","PSO DEAME",337 ,0)
	3250	;
	3251	"RTN","PSO DEAME",338 ,0)
	3252	; VARIABL ES:
	3253	"RTN","PSO DEAME",339 ,0)
	3254	N DS ;Single drug sched ule field as sent fr om the VA DOJ Web Se rvice.
	3255	"RTN","PSO DEAME",340 ,0)
	3256	N XIP ;Used to calculate the state from a zi p code.
	3257	"RTN","PSO DEAME",341 ,0)
	3258	N XSTATE ;Used to calculate the state from a zi p code.
	3259	"RTN","PSO DEAME",342 ,0)
	3260	N BAC ;Busines s Activity Code
	3261	"RTN","PSO DEAME",343 ,0)
	3262	;
	3263	"RTN","PSO DEAME",344 ,0)
	3264	S DS=$G(F G("drugSch edule"))
	3265	"RTN","PSO DEAME",345 ,0)
	3266	S GETS(.0 1)=$G(FG(" deaNumber" ))
	3267	"RTN","PSO DEAME",346 ,0)
	3268	S BAC=$G( FG("busine ssActivity Code"))_$G (FG("busin essActivit ySubcode") )
	3269	"RTN","PSO DEAME",347 ,0)
	3270	S GETS(.0 2)=BAC ; P ointer to file #8991 .8
	3271	"RTN","PSO DEAME",348 ,0)
	3272	S GETS(.0 3)=$S($$GE TDNDTX^PSO DEAUT(NPIE N)'="":"", $$DETOXCHK ^PSODEAUT( BAC):"X"_$ E($G(FG("d eaNumber") ),2,9),1:" ") ; DETO X NUMBER
	3273	"RTN","PSO DEAME",349 ,0)
	3274	D DT^DILF ("E",$G(FG ("expirati onDate")), .DTRESULT)
	3275	"RTN","PSO DEAME",350 ,0)
	3276	S GETS(.0 4)=$G(DTRE SULT(0))
	3277	"RTN","PSO DEAME",351 ,0)
	3278	S GETS(.0 7)=$G(FG(" type"))
	3279	"RTN","PSO DEAME",352 ,0)
	3280	S GETS(1. 1)=$G(FG(" name"))
	3281	"RTN","PSO DEAME",353 ,0)
	3282	S GETS(1. 2)=$G(FG(" address1") )
	3283	"RTN","PSO DEAME",354 ,0)
	3284	S GETS(1. 3)=$G(FG(" address2") )
	3285	"RTN","PSO DEAME",355 ,0)
	3286	S GETS(1. 4)=$G(FG(" address3") )
	3287	"RTN","PSO DEAME",356 ,0)
	3288	S GETS(1. 5)=$G(FG(" city"))
	3289	"RTN","PSO DEAME",357 ,0)
	3290	;
	3291	"RTN","PSO DEAME",358 ,0)
	3292	; Special State Pro cessing
	3293	"RTN","PSO DEAME",359 ,0)
	3294	S GETS(1. 6)=$G(FG(" state"))
	3295	"RTN","PSO DEAME",360 ,0)
	3296	D POSTAL^ XIPUTIL($G (FG("zipCo de")),.XIP )
	3297	"RTN","PSO DEAME",361 ,0)
	3298	S XSTATE= $G(XIP("ST ATE"))
	3299	"RTN","PSO DEAME",362 ,0)
	3300	I XSTATE' ="" S GETS (1.6)=XSTA TE ; Point er to the State File #5.
	3301	"RTN","PSO DEAME",363 ,0)
	3302	;
	3303	"RTN","PSO DEAME",364 ,0)
	3304	S GETS(1. 7)=$G(FG(" zipCode"))
	3305	"RTN","PSO DEAME",365 ,0)
	3306	;
	3307	"RTN","PSO DEAME",366 ,0)
	3308	S GETS(2. 1)=$S(DS[" 22N":"YES" ,(DS["2"&( DS'["2N")) :"YES",1:" NO") ; SCH EDULE II N ARCOTIC
	3309	"RTN","PSO DEAME",367 ,0)
	3310	S GETS(2. 2)=$S(DS[" 2N":"YES", 1:"NO") ; SCHEDULE I I NON-NARC OTIC
	3311	"RTN","PSO DEAME",368 ,0)
	3312	S GETS(2. 3)=$S(DS[" 33N":"YES" ,(DS["3"&( DS'["3N")) :"YES",1:" NO") ; SCH EDULE III NARCOTIC
	3313	"RTN","PSO DEAME",369 ,0)
	3314	S GETS(2. 4)=$S(DS[" 3N":"YES", 1:"NO") ; SCHEDULE I II NON-NAR COTIC
	3315	"RTN","PSO DEAME",370 ,0)
	3316	S GETS(2. 5)=$S(DS[" 4":"YES",1 :"NO") ; S CHEDULE IV
	3317	"RTN","PSO DEAME",371 ,0)
	3318	S GETS(2. 6)=$S(DS[" 5":"YES",1 :"NO") ; S CHEDULE V
	3319	"RTN","PSO DEAME",372 ,0)
	3320	;
	3321	"RTN","PSO DEAME",373 ,0)
	3322	D DT^DILF ("E",%DT,. DTRESULT)
	3323	"RTN","PSO DEAME",374 ,0)
	3324	S GETS(10 .2)=$G(DTR ESULT(0)) ; LAST UP DATED DATE /TIME
	3325	"RTN","PSO DEAME",375 ,0)
	3326	D DT^DILF ("E",$G(FG ("processe dDate")),. DTRESULT)
	3327	"RTN","PSO DEAME",376 ,0)
	3328	S GETS(10 .3)=$G(DTR ESULT(0)) ; LAST DO J UPDATE D ATE/TIME
	3329	"RTN","PSO DEAME",377 ,0)
	3330	S GETS(10 .1)=DUZ
	3331	"RTN","PSO DEAME",378 ,0)
	3332	Q
	3333	"RTN","PSO DEAME",379 ,0)
	3334	;
	3335	"RTN","PSO DEAME",380 ,0)
	3336	CLEARDTX(N PIEN) ; R EMOVE DETO X NUMBERS FROM ALL O F A PROVID ERS DEA NU MBERS
	3337	"RTN","PSO DEAME",381 ,0)
	3338	N DNDEAIE N,FDA,NPDE AIEN
	3339	"RTN","PSO DEAME",382 ,0)
	3340	S NPDEAIE N=0 F S N PDEAIEN=$O (^VA(200,N PIEN,"PS4" ,NPDEAIEN) ) Q:'NPDEA IEN D
	3341	"RTN","PSO DEAME",383 ,0)
	3342	. S DNDEA IEN=$$GET1 ^DIQ(200.5 321,NPDEAI EN_","_NPI EN_",",.03 ,"I")
	3343	"RTN","PSO DEAME",384 ,0)
	3344	. K FDA S FDA(1,899 1.9,DNDEAI EN_",",.03 )="@" D UP DATE^DIE(" ","FDA(1)" ) K FDA
	3345	"RTN","PSO DEAME",385 ,0)
	3346	Q
	3347	"RTN","PSO DEARP")
	3348	0^21^B4894 3182
	3349	"RTN","PSO DEARP",1,0 )
	3350	PSODEARP ; ALB/BI - D EA EXPIRAT ION DATE R EPORT ;06/ 15/2018
	3351	"RTN","PSO DEARP",2,0 )
	3352	;;7.0;OUT PATIENT PH ARMACY;5 45;DEC 1 997;Build 21
	3353	"RTN","PSO DEARP",3,0 )
	3354	;External reference to DEA NU MBERS file (#8991.9) is suppor ted by DBI A 7002
	3355	"RTN","PSO DEARP",4,0 )
	3356	;External reference to sub-fi le NEW DEA #'S (#200 .5321) is supported by DBIA 70 00
	3357	"RTN","PSO DEARP",5,0 )
	3358	Q
	3359	"RTN","PSO DEARP",6,0 )
	3360	;
	3361	"RTN","PSO DEARP",7,0 )
	3362	EN ; Main Routine E ntry Point
	3363	"RTN","PSO DEARP",8,0 )
	3364	N DIROUT, DTOUT,DUOU T,PSOQ,PSO PAGE,POP,P SHEADER,PS CPRSSA,PSO EDS,PSOSCR
	3365	"RTN","PSO DEARP",9,0 )
	3366	S PSOPAGE =0
	3367	"RTN","PSO DEARP",10, 0)
	3368	W !!,"Rep ort requir es 132 Col umns"
	3369	"RTN","PSO DEARP",11, 0)
	3370	S PSOQ=0 ; quit flag
	3371	"RTN","PSO DEARP",12, 0)
	3372	;
	3373	"RTN","PSO DEARP",13, 0)
	3374	S PSHEADE R="DEA EXP IRATION RE PORT - I ncludes: "
	3375	"RTN","PSO DEARP",14, 0)
	3376	;
	3377	"RTN","PSO DEARP",15, 0)
	3378	; Input Q uestions
	3379	"RTN","PSO DEARP",16, 0)
	3380	;
	3381	"RTN","PSO DEARP",17, 0)
	3382	; CPRS Sy stem Acces s {Active, DISUSERed , or Both}
	3383	"RTN","PSO DEARP",18, 0)
	3384	S DIR(0)= "S^A:Activ e;D:DISUSE Red;B:Both ",DIR("A") ="CPRS Sys tem Access " D ^DIR Q :$D(DUOUT) !$D(DTOUT) !$D(DIROUT )
	3385	"RTN","PSO DEARP",19, 0)
	3386	S PSCPRSS A=Y,PSHEAD ER=PSHEADE R_$S(Y="A" :"Active U sers ",Y=" D":"DISUSE R ",Y="B": "Active, D ISUSER, ", 1:"")_"and "
	3387	"RTN","PSO DEARP",20, 0)
	3388	;
	3389	"RTN","PSO DEARP",21, 0)
	3390	; Expirat ion Date S tatus {EXP IRED, NO E XP DATE, < 30-DAYS, < 90-DAYS}
	3391	"RTN","PSO DEARP",22, 0)
	3392	S DIR(0)= "S^E:EXPIR ED;N:NO EX P DATE;3:< 30-DAYS;9: <90-DAYS", DIR("A")=" Expiration Date Stat us" D ^DIR Q:$D(DUOU T)!$D(DTOU T)!$D(DIRO UT)
	3393	"RTN","PSO DEARP",23, 0)
	3394	S PSOEDS= Y,PSHEADER =PSHEADER_ $S(Y="E":" EXPIRED.", Y="N":"NO EXPIRATION DATE.",Y= "3":"Expir ed/Expirin g within n ext 30 day s.",Y="9": "Expired/E xpiring wi thin next 90 days.", 1:"")
	3395	"RTN","PSO DEARP",24, 0)
	3396	;
	3397	"RTN","PSO DEARP",25, 0)
	3398	D DEVICE Q:PSOQ ; Print to device
	3399	"RTN","PSO DEARP",26, 0)
	3400	D RUN(PSH EADER,PSCP RSSA,PSOED S) Q:PSOQ ; Run Report
	3401	"RTN","PSO DEARP",27, 0)
	3402	Q
	3403	"RTN","PSO DEARP",28, 0)
	3404	;
	3405	"RTN","PSO DEARP",29, 0)
	3406	DEVICE ; Request De vice Infor mation
	3407	"RTN","PSO DEARP",30, 0)
	3408	N %ZIS,IO P,ZTSK,ZTR TN,ZTIO,ZT DESC,ZTSAV E,POP,RTN, VAR
	3409	"RTN","PSO DEARP",31, 0)
	3410	K IO("Q")
	3411	"RTN","PSO DEARP",32, 0)
	3412	S %ZIS="Q M"
	3413	"RTN","PSO DEARP",33, 0)
	3414	W ! D ^%Z IS
	3415	"RTN","PSO DEARP",34, 0)
	3416	I POP S P SOQ=1 Q
	3417	"RTN","PSO DEARP",35, 0)
	3418	S PSOSCR= $S($E($G(I OST),1,2)= "C-":1,1:0 )
	3419	"RTN","PSO DEARP",36, 0)
	3420	I $D(IO(" Q")) D S PSOQ=1
	3421	"RTN","PSO DEARP",37, 0)
	3422	. S RTN=$ P($T(+1)," ",1)
	3423	"RTN","PSO DEARP",38, 0)
	3424	. S ZTRTN ="RUN^"_RT N_"(PSHEAD ER,PSCPRSS A,PSOEDS)"
	3425	"RTN","PSO DEARP",39, 0)
	3426	. S ZTIO= ION
	3427	"RTN","PSO DEARP",40, 0)
	3428	. S ZTSAV E("PS*")=" "
	3429	"RTN","PSO DEARP",41, 0)
	3430	. S ZTDES C="DEA EXP IRATION RE PORT"
	3431	"RTN","PSO DEARP",42, 0)
	3432	. D ^%ZTL OAD
	3433	"RTN","PSO DEARP",43, 0)
	3434	. W !,$S( $D(ZTSK):" REQUEST QU EUED TASK= "_ZTSK,1:" REQUEST CA NCELLED")
	3435	"RTN","PSO DEARP",44, 0)
	3436	. D HOME^ %ZIS
	3437	"RTN","PSO DEARP",45, 0)
	3438	U IO
	3439	"RTN","PSO DEARP",46, 0)
	3440	Q
	3441	"RTN","PSO DEARP",47, 0)
	3442	;
	3443	"RTN","PSO DEARP",48, 0)
	3444	COMPILE(PS CPRSSA,PSO EDS) ; -- Compile t he report lines into the sort global
	3445	"RTN","PSO DEARP",49, 0)
	3446	N DEAIEN, DEATXT,PSC OUNT1,PSOL INE,PSOTD
	3447	"RTN","PSO DEARP",50, 0)
	3448	S PSCOUNT 1=0
	3449	"RTN","PSO DEARP",51, 0)
	3450	S DEATXT= "" F S DE ATXT=$O(^X TV(8991.9, "B",DEATXT )) Q:DEATX T="" D
	3451	"RTN","PSO DEARP",52, 0)
	3452	. S DEAIE N=$O(^XTV( 8991.9,"B" ,DEATXT,0) ) Q:'DEAIE N
	3453	"RTN","PSO DEARP",53, 0)
	3454	. S NPIEN =$O(^VA(20 0,"PS4",DE ATXT,0)) Q :'NPIEN
	3455	"RTN","PSO DEARP",54, 0)
	3456	. K TMP,P SODNOBJ D GETS^DIQ(8 991.9,DEAI EN_",","** ","","TMP" ,"MSG") M PSODNOBJ=T MP(8991.9, DEAIEN_"," )
	3457	"RTN","PSO DEARP",55, 0)
	3458	. K TMP,P SONPOBJ D GETS^DIQ(2 00,NPIEN_" ,","**","" ,"TMP","MS G") M PSON POBJ=TMP(2 00,NPIEN_" ,")
	3459	"RTN","PSO DEARP",56, 0)
	3460	. S PSONP OBJ(9.2)=$ $GET1^DIQ( 200,NPIEN_ ",",9.2,"I "),PSONPOB J(9.2)=$$F MTE^XLFDT( PSONPOBJ(9 .2),"5DZ")
	3461	"RTN","PSO DEARP",57, 0)
	3462	. S PSONP OBJ(202)=$ $GET1^DIQ( 200,NPIEN_ ",",202,"I "),PSONPOB J(202)=$$F MTE^XLFDT( PSONPOBJ(2 02),"5DZ")
	3463	"RTN","PSO DEARP",58, 0)
	3464	. S PSODN OBJ(.04)=$ $GET1^DIQ( 8991.9,DEA IEN_",",.0 4,"I"),PSO DNOBJ(.04) =$$FMTE^XL FDT(PSODNO BJ(.04),"5 DZ")
	3465	"RTN","PSO DEARP",59, 0)
	3466	. Q:'$$TE ST(.PSODNO BJ,.PSONPO BJ,PSCPRSS A,PSOEDS,N PIEN)
	3467	"RTN","PSO DEARP",60, 0)
	3468	. S PSOLI NE=""
	3469	"RTN","PSO DEARP",61, 0)
	3470	. S PSOLI NE=PSOLINE _$$LJ^XLFS TR(PSONPOB J(9.2),"12 T")_" " ; TERMI NATION DAT E #2 00, #9. 2
	3471	"RTN","PSO DEARP",62, 0)
	3472	. S PSOLI NE=PSOLINE _$$LJ^XLFS TR(PSODNOB J(1.1),"33 T")_" " ; NAME #8 991.9, #1. 1
	3473	"RTN","PSO DEARP",63, 0)
	3474	. S PSOLI NE=PSOLINE _$$LJ^XLFS TR(PSODNOB J(.01),"9T ")_" " ; DEA #8 991.9, #.0 1
	3475	"RTN","PSO DEARP",64, 0)
	3476	. S PSOLI NE=PSOLINE _$$LJ^XLFS TR(PSODNOB J(.04),"12 T")_" " ; DEA E xpiration Date #8 991.9, #.0 4
	3477	"RTN","PSO DEARP",65, 0)
	3478	. S PSOLI NE=PSOLINE _$$LJ^XLFS TR(PSONPOB J(202),"12 T")_" " ; LAST SIGN-ON #2 00, #20 2
	3479	"RTN","PSO DEARP",66, 0)
	3480	. S PSOLI NE=PSOLINE _$$LJ^XLFS TR(PSONPOB J(8),"23T" )_" " ; TITLE #2 00, #8
	3481	"RTN","PSO DEARP",67, 0)
	3482	. S PSOLI NE=PSOLINE _$$LJ^XLFS TR(PSONPOB J(29),"16T ")_" " ; SERVI CE/SECTION #2 00, #29
	3483	"RTN","PSO DEARP",68, 0)
	3484	. S PSCOU NT1=PSCOUN T1+1
	3485	"RTN","PSO DEARP",69, 0)
	3486	. S PSOTD =$S(PSONPO BJ(9.2):PS ONPOBJ(9.2 ),1:1)
	3487	"RTN","PSO DEARP",70, 0)
	3488	. S ^TMP( $J,"PSODEA RP",PSOTD, PSODNOBJ(1 .1),PSCOUN T1,1)=PSOL INE
	3489	"RTN","PSO DEARP",71, 0)
	3490	. ;
	3491	"RTN","PSO DEARP",72, 0)
	3492	. S PSOLI NE="REMARK S: "_$$LJ^ XLFSTR(PSO NPOBJ(53.9 ),"120T") ; REMAR KS FIELD #2 00, #53 .9
	3493	"RTN","PSO DEARP",73, 0)
	3494	. S ^TMP( $J,"PSODEA RP",PSOTD, PSODNOBJ(1 .1),PSCOUN T1,2)=PSOL INE
	3495	"RTN","PSO DEARP",74, 0)
	3496	. ;
	3497	"RTN","PSO DEARP",75, 0)
	3498	. S PSOLI NE="" ; BLANK LINE
	3499	"RTN","PSO DEARP",76, 0)
	3500	. S ^TMP( $J,"PSODEA RP",PSOTD, PSODNOBJ(1 .1),PSCOUN T1,3)=PSOL INE
	3501	"RTN","PSO DEARP",77, 0)
	3502	Q
	3503	"RTN","PSO DEARP",78, 0)
	3504	;
	3505	"RTN","PSO DEARP",79, 0)
	3506	RUN(PSHEAD ER,PSCPRSS A,PSOEDS) ; Run Rep ort
	3507	"RTN","PSO DEARP",80, 0)
	3508	N PSCOUNT 2,PSOTD,PS ONAME
	3509	"RTN","PSO DEARP",81, 0)
	3510	K ^TMP($J ,"PSODEARP ") ; Clear the tempo rary accum ulator
	3511	"RTN","PSO DEARP",82, 0)
	3512	D COMPILE (PSCPRSSA, PSOEDS)
	3513	"RTN","PSO DEARP",83, 0)
	3514	U IO
	3515	"RTN","PSO DEARP",84, 0)
	3516	D HDR(PSH EADER)
	3517	"RTN","PSO DEARP",85, 0)
	3518	I '$D(^TM P($J,"PSOD EARP")) W "There is no Data to Print",!
	3519	"RTN","PSO DEARP",86, 0)
	3520	S PSOTD=0 F S PSOT D=$O(^TMP( $J,"PSODEA RP",PSOTD) ) Q:+PSOTD =0 Q:PSOQ D
	3521	"RTN","PSO DEARP",87, 0)
	3522	. S PSONA ME="" F S PSONAME=$ O(^TMP($J, "PSODEARP" ,PSOTD,PSO NAME)) Q:P SONAME="" Q:PSOQ D
	3523	"RTN","PSO DEARP",88, 0)
	3524	.. S PSCO UNT2=0 F S PSCOUNT2 =$O(^TMP($ J,"PSODEAR P",PSOTD,P SONAME,PSC OUNT2)) Q: +PSCOUNT2= 0 Q:PSOQ D
	3525	"RTN","PSO DEARP",89, 0)
	3526	... W ^TM P($J,"PSOD EARP",PSOT D,PSONAME, PSCOUNT2,1 ),! D CHKP (PSHEADER) Q:PSOQ
	3527	"RTN","PSO DEARP",90, 0)
	3528	... W ^TM P($J,"PSOD EARP",PSOT D,PSONAME, PSCOUNT2,2 ),! D CHKP (PSHEADER) Q:PSOQ
	3529	"RTN","PSO DEARP",91, 0)
	3530	... W ^TM P($J,"PSOD EARP",PSOT D,PSONAME, PSCOUNT2,3 ),! D CHKP (PSHEADER) Q:PSOQ
	3531	"RTN","PSO DEARP",92, 0)
	3532	Q:PSOQ
	3533	"RTN","PSO DEARP",93, 0)
	3534	I 'PSOSCR W !,@IOF
	3535	"RTN","PSO DEARP",94, 0)
	3536	D ^%ZISC
	3537	"RTN","PSO DEARP",95, 0)
	3538	K ^TMP($J ,"PSODEARP ") ; Clear the tempo rary accum ulator
	3539	"RTN","PSO DEARP",96, 0)
	3540	I PSOSCR K DIR("A") S DIR(0)= "E" D ^DIR
	3541	"RTN","PSO DEARP",97, 0)
	3542	Q
	3543	"RTN","PSO DEARP",98, 0)
	3544	;
	3545	"RTN","PSO DEARP",99, 0)
	3546	HDR(PSHEAD ER) ; Rep ort header
	3547	"RTN","PSO DEARP",100 ,0)
	3548	N PSOI
	3549	"RTN","PSO DEARP",101 ,0)
	3550	S PSOPAGE =PSOPAGE+1
	3551	"RTN","PSO DEARP",102 ,0)
	3552	W @IOF,PS HEADER,?(I OM-36),"Re port Date: ",$$FMTE^ XLFDT(DT," 5DZ")," Page: ",PS OPAGE
	3553	"RTN","PSO DEARP",103 ,0)
	3554	W !,$$TIT LES
	3555	"RTN","PSO DEARP",104 ,0)
	3556	W ! F PSO I=1:1:$S($ G(IOM):IOM ,1:130) W "-"
	3557	"RTN","PSO DEARP",105 ,0)
	3558	W !
	3559	"RTN","PSO DEARP",106 ,0)
	3560	Q
	3561	"RTN","PSO DEARP",107 ,0)
	3562	;
	3563	"RTN","PSO DEARP",108 ,0)
	3564	CHKP(PSHEA DER) ; Ch eck for En d Of Page
	3565	"RTN","PSO DEARP",109 ,0)
	3566	I $Y>(IOS L-4) D:PSO SCR Q:PSO Q D HDR(P SHEADER)
	3567	"RTN","PSO DEARP",110 ,0)
	3568	. N X,Y,D TOUT,DUOUT ,DIRUT,DIR
	3569	"RTN","PSO DEARP",111 ,0)
	3570	. U IO(0) S DIR(0)= "E" D ^DIR S:$D(DIRU T) PSOQ=2
	3571	"RTN","PSO DEARP",112 ,0)
	3572	. U IO
	3573	"RTN","PSO DEARP",113 ,0)
	3574	Q
	3575	"RTN","PSO DEARP",114 ,0)
	3576	;
	3577	"RTN","PSO DEARP",115 ,0)
	3578	TITLES() ; -- Creat e the head er TITLES.
	3579	"RTN","PSO DEARP",116 ,0)
	3580	N TITLES
	3581	"RTN","PSO DEARP",117 ,0)
	3582	S TITLES= ""
	3583	"RTN","PSO DEARP",118 ,0)
	3584	S TITLES= TITLES_$$L J^XLFSTR(" TERM DATE" ,"12T")_" " ; TERMINAT ION DATE #200, #9.2
	3585	"RTN","PSO DEARP",119 ,0)
	3586	S TITLES= TITLES_$$L J^XLFSTR(" NAME","33T ")_" " ; NAME #8991 .9, #1.1
	3587	"RTN","PSO DEARP",120 ,0)
	3588	S TITLES= TITLES_$$L J^XLFSTR(" DEA","9T") _" " ; DEA #8991 .9, #.01
	3589	"RTN","PSO DEARP",121 ,0)
	3590	S TITLES= TITLES_$$L J^XLFSTR(" DEA EXP DT ","12T")_" " ; DEA Expi ration Dat e #8991 .9, #.04
	3591	"RTN","PSO DEARP",122 ,0)
	3592	S TITLES= TITLES_$$L J^XLFSTR(" LAST SIGN- ON","12T") _" " ; LAST SIG N-ON #200, #202
	3593	"RTN","PSO DEARP",123 ,0)
	3594	S TITLES= TITLES_$$L J^XLFSTR(" TITLE","23 T")_" " ; TITLE #200, #8
	3595	"RTN","PSO DEARP",124 ,0)
	3596	S TITLES= TITLES_$$L J^XLFSTR(" SERVICE/SE CTION","16 T")_" " ; SERVICE/ SECTION #200, #29
	3597	"RTN","PSO DEARP",125 ,0)
	3598	Q TITLES
	3599	"RTN","PSO DEARP",126 ,0)
	3600	;
	3601	"RTN","PSO DEARP",127 ,0)
	3602	TEST(PSODN OBJ,PSONPO BJ,PSCPRSS A,PSOEDS,N PIEN) ; - - Perform the reques ted test f or screeni ng critera
	3603	"RTN","PSO DEARP",128 ,0)
	3604	N DEAEXPD T D DT^DIL F("",PSODN OBJ(.04),. DEAEXPDT)
	3605	"RTN","PSO DEARP",129 ,0)
	3606	N RESP S RESP=0
	3607	"RTN","PSO DEARP",130 ,0)
	3608	;
	3609	"RTN","PSO DEARP",131 ,0)
	3610	; Provide r Active a nd DEA is expired.
	3611	"RTN","PSO DEARP",132 ,0)
	3612	I ((PSCPR SSA="A")!( PSCPRSSA=" B")),PSOED S="E",(PSO NPOBJ(7)'= "YES"),PSO DNOBJ(.04) '="",DEAEX PDT<$$FMAD D^XLFDT(DT ,-0) Q 1
	3613	"RTN","PSO DEARP",133 ,0)
	3614	;
	3615	"RTN","PSO DEARP",134 ,0)
	3616	; Provide r Active a nd does no t have a D EA expirat ion date.
	3617	"RTN","PSO DEARP",135 ,0)
	3618	I ((PSCPR SSA="A")!( PSCPRSSA=" B")),PSOED S="N",(PSO NPOBJ(7)'= "YES"),PSO DNOBJ(.04) ="" Q 1
	3619	"RTN","PSO DEARP",136 ,0)
	3620	;
	3621	"RTN","PSO DEARP",137 ,0)
	3622	; Provide r Active a nd DEA is not expire d, but wil l expire i n the next 30 days.
	3623	"RTN","PSO DEARP",138 ,0)
	3624	I ((PSCPR SSA="A")!( PSCPRSSA=" B")),PSOED S="3",(PSO NPOBJ(7)'= "YES"),PSO DNOBJ(.04) '="",DEAEX PDT<$$FMAD D^XLFDT(DT ,30) Q 1
	3625	"RTN","PSO DEARP",139 ,0)
	3626	;
	3627	"RTN","PSO DEARP",140 ,0)
	3628	; Provide r Active a nd DEA is not expire d, but wil l expire i n the next 90 days.
	3629	"RTN","PSO DEARP",141 ,0)
	3630	I ((PSCPR SSA="A")!( PSCPRSSA=" B")),PSOED S="9",(PSO NPOBJ(7)'= "YES"),PSO DNOBJ(.04) '="",DEAEX PDT<$$FMAD D^XLFDT(DT ,90) Q 1
	3631	"RTN","PSO DEARP",142 ,0)
	3632	;
	3633	"RTN","PSO DEARP",143 ,0)
	3634	; Provide r disusere d and DEA is expired .
	3635	"RTN","PSO DEARP",144 ,0)
	3636	I ((PSCPR SSA="D")!( PSCPRSSA=" B")),PSOED S="E",PSON POBJ(7)="Y ES",PSODNO BJ(.04)'=" ",DEAEXPDT <$$FMADD^X LFDT(DT,-0 ) Q 1
	3637	"RTN","PSO DEARP",145 ,0)
	3638	;
	3639	"RTN","PSO DEARP",146 ,0)
	3640	; Provide r disusere d and does not have a DEA expi ration dat e.
	3641	"RTN","PSO DEARP",147 ,0)
	3642	I ((PSCPR SSA="D")!( PSCPRSSA=" B")),PSOED S="N",PSON POBJ(7)="Y ES",PSODNO BJ(.04)="" Q 1
	3643	"RTN","PSO DEARP",148 ,0)
	3644	;
	3645	"RTN","PSO DEARP",149 ,0)
	3646	; Provide r disusere d and DEA is not exp ired, but will expir e in the n ext 30 day s.
	3647	"RTN","PSO DEARP",150 ,0)
	3648	I ((PSCPR SSA="D")!( PSCPRSSA=" B")),PSOED S="3",PSON POBJ(7)="Y ES",PSODNO BJ(.04)'=" ",DEAEXPDT <$$FMADD^X LFDT(DT,30 ) Q 1
	3649	"RTN","PSO DEARP",151 ,0)
	3650	;
	3651	"RTN","PSO DEARP",152 ,0)
	3652	; Provide r disusere d and DEA is not exp ired, but will expir e in the n ext 90 day s.
	3653	"RTN","PSO DEARP",153 ,0)
	3654	I ((PSCPR SSA="D")!( PSCPRSSA=" B")),PSOED S="9",PSON POBJ(7)="Y ES",PSODNO BJ(.04)'=" ",DEAEXPDT <$$FMADD^X LFDT(DT,90 ) Q 1
	3655	"RTN","PSO DEARP",154 ,0)
	3656	;
	3657	"RTN","PSO DEARP",155 ,0)
	3658	Q RESP
	3659	"RTN","PSO DEART")
	3660	0^22^B1490 55999
	3661	"RTN","PSO DEART",1,0 )
	3662	PSODEART ; FO-OAKAND/ REM - EPCS Utilities and Repor ts; [5/7/0 2 5:53am] ;08/06/201 2
	3663	"RTN","PSO DEART",2,0 )
	3664	;;7.0;OUT PATIENT PH ARMACY;5 45;DEC 1 997;Build 21
	3665	"RTN","PSO DEART",3,0 )
	3666	;External reference to DEA NU MBERS file (#8991.9) is suppor ted by DBI A 7002
	3667	"RTN","PSO DEART",4,0 )
	3668	;External reference to XUEPCS DATA file (#8991.6) is suppor ted by DBI A 7015
	3669	"RTN","PSO DEART",5,0 )
	3670	;External reference to XUEPCS PSDRPH AU DIT file ( #8991.7) i s supporte d by DBIA 7016
	3671	"RTN","PSO DEART",6,0 )
	3672	;
	3673	"RTN","PSO DEART",7,0 )
	3674	Q
	3675	"RTN","PSO DEART",8,0 )
	3676	;
	3677	"RTN","PSO DEART",9,0 )
	3678	PRESCBR(PS OSD0) ;cal led from p rint optio n - PSO EP CS PRIVS
	3679	"RTN","PSO DEART",10, 0)
	3680	;PSOSD0 i s D0
	3681	"RTN","PSO DEART",11, 0)
	3682	; screeni ng for pre scribers w ith DEA# o r VA#
	3683	"RTN","PSO DEART",12, 0)
	3684	N PSOSPS
	3685	"RTN","PSO DEART",13, 0)
	3686	S PSOSPS= $G(^VA(200 ,PSOSD0,"P S"))
	3687	"RTN","PSO DEART",14, 0)
	3688	Q:($$PRDE A^XUSER(PS OSD0))!($P (PSOSPS,U, 3)'="") 1
	3689	"RTN","PSO DEART",15, 0)
	3690	Q 0
	3691	"RTN","PSO DEART",16, 0)
	3692	;
	3693	"RTN","PSO DEART",17, 0)
	3694	PRIVS(PSOS D0) ;calle d from pri nt option - PSO EPCS PRIVS
	3695	"RTN","PSO DEART",18, 0)
	3696	;PSOSD0 i s D0
	3697	"RTN","PSO DEART",19, 0)
	3698	;user wit h controll ed substan ce privile ges?
	3699	"RTN","PSO DEART",20, 0)
	3700	;based on 6 sub-sch edules, PS 3 node, pi eces 1-6
	3701	"RTN","PSO DEART",21, 0)
	3702	N PSOSPS3
	3703	"RTN","PSO DEART",22, 0)
	3704	S PSOSPS3 =$$PRSCH^X USER(PSOSD 0)
	3705	"RTN","PSO DEART",23, 0)
	3706	Q:($P(PSO SPS3,U,1,6 )[1) 1 ; y es, if at least one explicit Y es
	3707	"RTN","PSO DEART",24, 0)
	3708	Q:($P(PSO SPS3,U,1,6 )[0) 0 ; n o, if expl icit No
	3709	"RTN","PSO DEART",25, 0)
	3710	Q 1 ; def ault, when all NULL
	3711	"RTN","PSO DEART",26, 0)
	3712	;
	3713	"RTN","PSO DEART",27, 0)
	3714	XT30(PSOSD 0,ACT) ;ca lled from print opti on - PSO E PCS XDATE EXPIRES
	3715	"RTN","PSO DEART",28, 0)
	3716	;chk user ACTIVE,wi th DEA# an d xdate ex pires in 3 0 days
	3717	"RTN","PSO DEART",29, 0)
	3718	;PSOSD0=I EN, ACT=(1 or 0) act ive user o f not
	3719	"RTN","PSO DEART",30, 0)
	3720	N XDT,DT3 0,DEA,CNT
	3721	"RTN","PSO DEART",31, 0)
	3722	S CNT=0
	3723	"RTN","PSO DEART",32, 0)
	3724	S XDT=$$P RXDT^XUSER (PSOSD0),D T30=$$FMAD D^XLFDT(DT ,30),DEA=$ $PRDEA^XUS ER(PSOSD0)
	3725	"RTN","PSO DEART",33, 0)
	3726	I (DEA'=" "),(XDT'>D T30),(XDT' <DT) S CNT =CNT+1
	3727	"RTN","PSO DEART",34, 0)
	3728	I ACT D
	3729	"RTN","PSO DEART",35, 0)
	3730	.I $$ACTI VE^XUSER(P SOSD0) S C NT=CNT+1
	3731	"RTN","PSO DEART",36, 0)
	3732	I 'ACT D
	3733	"RTN","PSO DEART",37, 0)
	3734	.I '$$ACT IVE^XUSER( PSOSD0) S CNT=CNT+1
	3735	"RTN","PSO DEART",38, 0)
	3736	I CNT=2 Q 1
	3737	"RTN","PSO DEART",39, 0)
	3738	Q 0
	3739	"RTN","PSO DEART",40, 0)
	3740	;
	3741	"RTN","PSO DEART",41, 0)
	3742	RPT1 ;ePCS report - setting or modifing to logical access co ntrols.
	3743	"RTN","PSO DEART",42, 0)
	3744	;called f rom option - PSO EPC S LOGICAL ACCESS
	3745	"RTN","PSO DEART",43, 0)
	3746	;Only run s if data has change d from pre vious day.
	3747	"RTN","PSO DEART",44, 0)
	3748	;FLG=reco rds exist for previo us day.
	3749	"RTN","PSO DEART",45, 0)
	3750	;Generate report & Mail messa ge to PSDM GR key hol ders
	3751	"RTN","PSO DEART",46, 0)
	3752	N BDT,LD, EDT,FLG,DE V,FN,ZZ,ZP R,FSP,RHD, RT,PSORPT, OPT,X1,X2, FE S PSORP T=1 D INIT
	3753	"RTN","PSO DEART",47, 0)
	3754	D NOW^%DT C S X1=X,X 2="-1" D C ^%DTC S (B DT,LD)=X,E DT=X_".999 999" ;Get the previo us day dat e
	3755	"RTN","PSO DEART",48, 0)
	3756	F S LD=$ O(^XTV(FN, "DT",LD)) Q:LD=""!(F LG=1) D
	3757	"RTN","PSO DEART",49, 0)
	3758	. S:LD<ED T FLG=1
	3759	"RTN","PSO DEART",50, 0)
	3760	D:$G(ZPR) AUTPRT D GMAIL
	3761	"RTN","PSO DEART",51, 0)
	3762	EXIT K ^TM P(ZZ,$J),^ XTMP(ZZ,$J )
	3763	"RTN","PSO DEART",52, 0)
	3764	D ^%ZISC S:$D(ZTQUE UED) ZTREQ ="@"
	3765	"RTN","PSO DEART",53, 0)
	3766	Q
	3767	"RTN","PSO DEART",54, 0)
	3768	;
	3769	"RTN","PSO DEART",55, 0)
	3770	RPT2 ;ePCS report - allocation history f or PSDRPH key
	3771	"RTN","PSO DEART",56, 0)
	3772	;called f rom option - PSO DEA PSDRPH AU DIT
	3773	"RTN","PSO DEART",57, 0)
	3774	;Only run s if data has change d from pre vious day.
	3775	"RTN","PSO DEART",58, 0)
	3776	;FLG=reco rds exist for previo us day
	3777	"RTN","PSO DEART",59, 0)
	3778	;Generate report & Mail messa ge to PSDM GR key hol ders
	3779	"RTN","PSO DEART",60, 0)
	3780	N BDT,ST, EDT,FLG,DE V,FN,ZZ,ZP R,RHD,RT,P SORPT,OPT, X1,X2,FE S PSORPT=2 D INIT Q:' FN
	3781	"RTN","PSO DEART",61, 0)
	3782	D NOW^%DT C S X1=X,X 2="-1" D C ^%DTC S (B DT,ST)=X,E DT=X_".999 999" ;Get the previo us day dat e
	3783	"RTN","PSO DEART",62, 0)
	3784	F S ST=$ O(^XTV(FN, "DT",ST)) Q:ST=""!(F LG=1) D
	3785	"RTN","PSO DEART",63, 0)
	3786	. S:ST<ED T FLG=1
	3787	"RTN","PSO DEART",64, 0)
	3788	D:$G(ZPR) AUTPRT D GMAIL
	3789	"RTN","PSO DEART",65, 0)
	3790	D EXIT
	3791	"RTN","PSO DEART",66, 0)
	3792	Q
	3793	"RTN","PSO DEART",67, 0)
	3794	;
	3795	"RTN","PSO DEART",68, 0)
	3796	PSDKEY ;Al located/de -allocate the PSDRPH key optio n
	3797	"RTN","PSO DEART",69, 0)
	3798	;called f rom option - PSO EPC S PSDRPH K EY
	3799	"RTN","PSO DEART",70, 0)
	3800	N PSOBOSS ,PSODA,PSO KEY,PSORET ,PSONAME,Z Z,OK,NOW,I EN,MSG,INP UT,NOW,DA
	3801	"RTN","PSO DEART",71, 0)
	3802	S PSOKEY= $$LKUP^XPD KEY("PSDRP H")
	3803	"RTN","PSO DEART",72, 0)
	3804	I PSOKEY= "" W !,"PS DRPH key d oes not ex ist" Q
	3805	"RTN","PSO DEART",73, 0)
	3806	S PSOBOSS =0
	3807	"RTN","PSO DEART",74, 0)
	3808	;PSDRPH K EY check - delegate & holders
	3809	"RTN","PSO DEART",75, 0)
	3810	S:$D(^VA( 200,DUZ,52 ,PSOKEY)) PSOBOSS=2
	3811	"RTN","PSO DEART",76, 0)
	3812	S:(DUZ(0) ["@"!($D(^ XUSEC("XUM GR",DUZ))) !($D(^XUSE C("PSDRPH" ,DUZ)))) P SOBOSS=1
	3813	"RTN","PSO DEART",77, 0)
	3814	I 'PSOBOS S W !,"You don't hav e privileg es. See y our packag e coordina tor or sit e manager. " Q
	3815	"RTN","PSO DEART",78, 0)
	3816	K DIC S D IC="^VA(20 0,",DIC(0) ="AEMQZ",D IC("A")="E nter User Name: " D ^DIC Q:Y<0
	3817	"RTN","PSO DEART",79, 0)
	3818	I PSOBOSS =2,(DUZ=+Y ) W !!,$C( 7),"==> So rry, you c an't give yourself k eys. See your IRM s taff." Q
	3819	"RTN","PSO DEART",80, 0)
	3820	S PSODA=+ Y,PSONAME= $P(Y,U,2)
	3821	"RTN","PSO DEART",81, 0)
	3822	D OWNSKEY ^XUSRB(.ZZ ,"PSDRPH", PSODA) S P SORET=ZZ(0 ) ;chk if user had k ey
	3823	"RTN","PSO DEART",82, 0)
	3824	S OK=$$AS K(PSORET,P SONAME) I 'OK W !,"N othing don e..." Q
	3825	"RTN","PSO DEART",83, 0)
	3826	;De-alloc ate key
	3827	"RTN","PSO DEART",84, 0)
	3828	I PSORET K DIK S DI K="^VA(200 ,PSODA,51, ",DA(1)=PS ODA,DA=PSO KEY D ^DIK
	3829	"RTN","PSO DEART",85, 0)
	3830	;Allocate key
	3831	"RTN","PSO DEART",86, 0)
	3832	I 'PSORET S FDA(200 .051,"+1," _PSODA_"," ,.01)="PSD RPH" D UPD ATE^DIE("E ","FDA","I EN","MSG")
	3833	"RTN","PSO DEART",87, 0)
	3834	;Set and record aud it data
	3835	"RTN","PSO DEART",88, 0)
	3836	S NOW=$P( $$HTE^XLFD T($H),":", 1,2)
	3837	"RTN","PSO DEART",89, 0)
	3838	S INPUT=" `"_PSODA_" ^"_"`"_$G( DUZ)_"^"_$ S(PSORET:0 ,1:1) D RE CORD(INPUT ,NOW)
	3839	"RTN","PSO DEART",90, 0)
	3840	Q
	3841	"RTN","PSO DEART",91, 0)
	3842	;
	3843	"RTN","PSO DEART",92, 0)
	3844	ASK(TYPE,N AME,DELEG) ;Ask user if Alloca te/De-allo cate or De legate/Un- delegate - returns y /n
	3845	"RTN","PSO DEART",93, 0)
	3846	;TYPE - f lag weathe r Allocate /De-alloca te or Dele gate/Un-de legate
	3847	"RTN","PSO DEART",94, 0)
	3848	;Name - u ser's name
	3849	"RTN","PSO DEART",95, 0)
	3850	N DIR,Y
	3851	"RTN","PSO DEART",96, 0)
	3852	S DELEG=$ G(DELEG,"" )
	3853	"RTN","PSO DEART",97, 0)
	3854	I DELEG S DIR("A")= $S(TYPE=1: "Un-delega te",1:"Del egate")_" PSDRPH for "_NAME
	3855	"RTN","PSO DEART",98, 0)
	3856	I 'DELEG S DIR("A") =$S(TYPE=1 :"De-alloc ate",1:"Al locate")_" PSDRPH fo r "_NAME
	3857	"RTN","PSO DEART",99, 0)
	3858	S DIR("B" )="Y"
	3859	"RTN","PSO DEART",100 ,0)
	3860	S DIR(0)= "Y" D ^DIR
	3861	"RTN","PSO DEART",101 ,0)
	3862	Q Y
	3863	"RTN","PSO DEART",102 ,0)
	3864	RECORD(LIN E,NOW) ;Re cord the e dited data into audi t file #89 91.7
	3865	"RTN","PSO DEART",103 ,0)
	3866	N FDA,VAL UE,IEN,MSG ,I
	3867	"RTN","PSO DEART",104 ,0)
	3868	F I=1:1:3 S VALUE=$ P(LINE,U,I ),FDA(8991 .7,"+1,",( I/100))=VA LUE
	3869	"RTN","PSO DEART",105 ,0)
	3870	S FDA(899 1.7,"+1,", .04)=NOW
	3871	"RTN","PSO DEART",106 ,0)
	3872	D UPDATE^ DIE("E","F DA","IEN", "MSG")
	3873	"RTN","PSO DEART",107 ,0)
	3874	Q
	3875	"RTN","PSO DEART",108 ,0)
	3876	;
	3877	"RTN","PSO DEART",109 ,0)
	3878	VUSER1(PSO SD0,ACT) ; called fro m option - PSO EPCS DISUSER EX P DATE,PSO EPCS EXP DATE
	3879	"RTN","PSO DEART",110 ,0)
	3880	;chk user ACTIVE, w ith DEA# a nd null DE A Exp Date
	3881	"RTN","PSO DEART",111 ,0)
	3882	;PSOSD0=I EN, ACT=(1 or 0) act ive user o r not
	3883	"RTN","PSO DEART",112 ,0)
	3884	N CNT
	3885	"RTN","PSO DEART",113 ,0)
	3886	S CNT=0
	3887	"RTN","PSO DEART",114 ,0)
	3888	I $$PRDEA ^XUSER(PSO SD0)'="" S CNT=CNT+1
	3889	"RTN","PSO DEART",115 ,0)
	3890	I $$PRXDT ^XUSER(PSO SD0)="" S CNT=CNT+1
	3891	"RTN","PSO DEART",116 ,0)
	3892	I ACT D
	3893	"RTN","PSO DEART",117 ,0)
	3894	.I $$ACTI VE^XUSER(P SOSD0) S C NT=CNT+1
	3895	"RTN","PSO DEART",118 ,0)
	3896	I 'ACT D
	3897	"RTN","PSO DEART",119 ,0)
	3898	.I '$$ACT IVE^XUSER( PSOSD0) S CNT=CNT+1
	3899	"RTN","PSO DEART",120 ,0)
	3900	I CNT=3 Q 1
	3901	"RTN","PSO DEART",121 ,0)
	3902	Q 0
	3903	"RTN","PSO DEART",122 ,0)
	3904	;
	3905	"RTN","PSO DEART",123 ,0)
	3906	VUSER2(PSO SD0,ACT) ; called fro m option - PSO EPCS PRIVS,PSO EPCS DISUS ER PRIVS
	3907	"RTN","PSO DEART",124 ,0)
	3908	;chk user ACTIVE, w ith DEA# o r VA# with privilage s - sch II -V
	3909	"RTN","PSO DEART",125 ,0)
	3910	;PSOSD0=I EN, ACT=(1 or 0) act ive user o r not
	3911	"RTN","PSO DEART",126 ,0)
	3912	N CNT
	3913	"RTN","PSO DEART",127 ,0)
	3914	S CNT=0
	3915	"RTN","PSO DEART",128 ,0)
	3916	I $$PRESC BR^PSODEAR T(PSOSD0) S CNT=CNT+ 1
	3917	"RTN","PSO DEART",129 ,0)
	3918	I $$PRIVS ^PSODEART( PSOSD0) S CNT=CNT+1
	3919	"RTN","PSO DEART",130 ,0)
	3920	I ACT D
	3921	"RTN","PSO DEART",131 ,0)
	3922	.I $$ACTI VE^XUSER(P SOSD0) S C NT=CNT+1
	3923	"RTN","PSO DEART",132 ,0)
	3924	I 'ACT D
	3925	"RTN","PSO DEART",133 ,0)
	3926	.I '$$ACT IVE^XUSER( PSOSD0) S CNT=CNT+1
	3927	"RTN","PSO DEART",134 ,0)
	3928	I CNT=3 Q CNT
	3929	"RTN","PSO DEART",135 ,0)
	3930	Q 0
	3931	"RTN","PSO DEART",136 ,0)
	3932	;
	3933	"RTN","PSO DEART",137 ,0)
	3934	INIT ;
	3935	"RTN","PSO DEART",138 ,0)
	3936	S ZZ="PSO DEA",$P(FS P," ",25)= ""
	3937	"RTN","PSO DEART",139 ,0)
	3938	S FLG=0,F N=$S(PSORP T=1:8991.6 ,1:8991.7)
	3939	"RTN","PSO DEART",140 ,0)
	3940	S RHD=$S( PSORPT=1:" SETTING OR CHANGES T O DEA PRES CRIBING PR IVILEGES", 1:"PSDRPH KEY AUDIT LIST")
	3941	"RTN","PSO DEART",141 ,0)
	3942	S OPT=$S( PSORPT=1:" PSO EPCS L OGICAL ACC ESS",1:"PS O EPCS PHA RMACIST AC CESS")
	3943	"RTN","PSO DEART",142 ,0)
	3944	S ZPR=$$G ET^XPAR("S YS",$S(PSO RPT=1:"PSO EPCS LOGIC AL ACC REP ORT DEV",1 :"PSOEPCS PHARM ACC RPT DEVICE ",1:""),1, "I")
	3945	"RTN","PSO DEART",143 ,0)
	3946	S RT=$$NO W^XLFDT
	3947	"RTN","PSO DEART",144 ,0)
	3948	K ^XTMP(Z Z,$J),^TMP (ZZ,$J)
	3949	"RTN","PSO DEART",145 ,0)
	3950	Q
	3951	"RTN","PSO DEART",146 ,0)
	3952	;
	3953	"RTN","PSO DEART",147 ,0)
	3954	GMAIL ;
	3955	"RTN","PSO DEART",148 ,0)
	3956	N LC,ND,D AT,ARR,I,J ,P1,P2,P3, P4,P5,P6,R T,XTV,DV D INIT
	3957	"RTN","PSO DEART",149 ,0)
	3958	S LD=BDT F S LD=$O (^XTV(FN," DT",LD)) Q:'LD!(LD> EDT) D
	3959	"RTN","PSO DEART",150 ,0)
	3960	. S ND=0 F S ND=$O (^XTV(FN," DT",LD,ND) ) Q:'ND D
	3961	"RTN","PSO DEART",151 ,0)
	3962	.. Q:'$D( ^XTV(FN,ND ,0))
	3963	"RTN","PSO DEART",152 ,0)
	3964	.. S DAT= ^XTV(FN,ND ,0)
	3965	"RTN","PSO DEART",153 ,0)
	3966	.. S IEN= $P(DAT,"^" )
	3967	"RTN","PSO DEART",154 ,0)
	3968	.. S DV=$ O(^VA(200, IEN,2,0)) S:'DV DV=9 99999
	3969	"RTN","PSO DEART",155 ,0)
	3970	.. S ^XTM P(ZZ,$J,DV ,LD,ND)=""
	3971	"RTN","PSO DEART",156 ,0)
	3972	.. S:$O(^ VA(200,IEN ,2,DV)) ^X TMP(ZZ,$J, "Z",IEN)=" "
	3973	"RTN","PSO DEART",157 ,0)
	3974	SMAIL ;
	3975	"RTN","PSO DEART",158 ,0)
	3976	S XMSUB=" PSO EPCS " _$S(PSORPT =1:"LOGICA L",1:"PHAR MACIST")_" ACCESS RE PORT",XMDU Z=.5
	3977	"RTN","PSO DEART",159 ,0)
	3978	S LC=1,^T MP(ZZ,$J,L C)=RHD,$E( ^TMP(ZZ,$J ,LC),60)=$ $UP^XLFSTR ($$FMTE^XL FDT(RT,"M" )),LC=LC+1
	3979	"RTN","PSO DEART",160 ,0)
	3980	I '$D(^XT MP(ZZ,$J)) D G MGRP
	3981	"RTN","PSO DEART",161 ,0)
	3982	. S ^TMP( ZZ,$J,LC)= "",LC=LC+1
	3983	"RTN","PSO DEART",162 ,0)
	3984	. S ^TMP( ZZ,$J,LC)= " ******* ** NO MATCHING DATA ******** *",LC=LC+1
	3985	"RTN","PSO DEART",163 ,0)
	3986	. S ^TMP( ZZ,$J,LC)= "",LC=LC+1
	3987	"RTN","PSO DEART",164 ,0)
	3988	I PSORPT= 1 D
	3989	"RTN","PSO DEART",165 ,0)
	3990	. S ^TMP( ZZ,$J,LC)= "NAME",$E( ^TMP(ZZ,$J ,LC),28)=" EDITED BY" ,$E(^TMP(Z Z,$J,LC),5 5)="FIELD EDITED",LC =LC+1
	3991	"RTN","PSO DEART",166 ,0)
	3992	E D
	3993	"RTN","PSO DEART",167 ,0)
	3994	. S ^TMP( ZZ,$J,LC)= "NAME",$E( ^TMP(ZZ,$J ,LC),48)=" ALLOCATION ",LC=LC+1
	3995	"RTN","PSO DEART",168 ,0)
	3996	. S $E(^T MP(ZZ,$J,L C),24)="ED ITED BY",$ E(^TMP(ZZ, $J,LC),48) ="STATUS", $E(^TMP(ZZ ,$J,LC),60 )="DATE/TI ME EDITED" ,LC=LC+1
	3997	"RTN","PSO DEART",169 ,0)
	3998	S $P(^TMP (ZZ,$J,LC) ,"-",79)=" ",LC=LC+1
	3999	"RTN","PSO DEART",170 ,0)
	4000	S DV="" F S DV=$O( ^XTMP(ZZ,$ J,DV)) Q:' DV D
	4001	"RTN","PSO DEART",171 ,0)
	4002	. K ARR
	4003	"RTN","PSO DEART",172 ,0)
	4004	. S ^TMP( ZZ,$J,LC)= "",LC=LC+1
	4005	"RTN","PSO DEART",173 ,0)
	4006	. S ^TMP( ZZ,$J,LC)= "Division: "_$S(DV=9 99999:"NO DIVISION", 1:$$GET1^D IQ(4,DV,.0 1)),LEN=$L (^TMP(ZZ,$ J,LC))+1,L C=LC+1
	4007	"RTN","PSO DEART",174 ,0)
	4008	. S $P(^T MP(ZZ,$J,L C),"-",LEN )="",LC=LC +1
	4009	"RTN","PSO DEART",175 ,0)
	4010	. S LD=0 F S LD=$O (^XTMP(ZZ, $J,DV,LD)) Q:'LD D
	4011	"RTN","PSO DEART",176 ,0)
	4012	.. S ND=0 F S ND=$ O(^XTMP(ZZ ,$J,DV,LD, ND)) Q:'ND D BMAIL
	4013	"RTN","PSO DEART",177 ,0)
	4014	. S J=0 F S J=$O(A RR(J)) Q:' J D:$D(^X TMP(ZZ,$J, "Z",J)) MF T
	4015	"RTN","PSO DEART",178 ,0)
	4016	MGRP ;
	4017	"RTN","PSO DEART",179 ,0)
	4018	N XMY,MDU Z
	4019	"RTN","PSO DEART",180 ,0)
	4020	I PSORPT= 1 S DEV=$$ GET^XPAR(" SYS","PSOE PCS LOGICA L ACC RPT EMAIL",1," E")
	4021	"RTN","PSO DEART",181 ,0)
	4022	E S DEV= $$GET^XPAR ("SYS","PS OEPCS PHAR M ACC REPO RT EMAIL", 1,"E")
	4023	"RTN","PSO DEART",182 ,0)
	4024	I DEV]"" S XMY("G." _DEV)=""
	4025	"RTN","PSO DEART",183 ,0)
	4026	E D
	4027	"RTN","PSO DEART",184 ,0)
	4028	. S MDUZ= 0
	4029	"RTN","PSO DEART",185 ,0)
	4030	. I $D(^X USEC("PSDM GR")) D
	4031	"RTN","PSO DEART",186 ,0)
	4032	.. F S M DUZ=$O(^XU SEC("PSDMG R",MDUZ)) Q:MDUZ'>0 S XMY(MDU Z)=""
	4033	"RTN","PSO DEART",187 ,0)
	4034	S:'$O(XMY (0)) XMY(D UZ)=""
	4035	"RTN","PSO DEART",188 ,0)
	4036	S XMTEXT= "^TMP(ZZ,$ J," N DIFR OM D ^XMD K XMDUZ,XM TEXT,XMSUB
	4037	"RTN","PSO DEART",189 ,0)
	4038	Q
	4039	"RTN","PSO DEART",190 ,0)
	4040	;
	4041	"RTN","PSO DEART",191 ,0)
	4042	BMAIL ;
	4043	"RTN","PSO DEART",192 ,0)
	4044	S DAT=^XT V(FN,ND,0) ,IEN=$P(DA T,"^"),ARR (IEN)=""
	4045	"RTN","PSO DEART",193 ,0)
	4046	D GETS^DI Q(FN,ND,". 01;.02;.04 ;.05","E", "XTV")
	4047	"RTN","PSO DEART",194 ,0)
	4048	D GETS^DI Q(FN,ND,". 03","IE"," XTV")
	4049	"RTN","PSO DEART",195 ,0)
	4050	S P1=$G(X TV(FN,ND_" ,",.01,"E" ))_FSP
	4051	"RTN","PSO DEART",196 ,0)
	4052	S P2=$G(X TV(FN,ND_" ,",.02,"E" ))_FSP
	4053	"RTN","PSO DEART",197 ,0)
	4054	S FE=$G(X TV(FN,ND_" ,",.03,"I" ))
	4055	"RTN","PSO DEART",198 ,0)
	4056	I PSORPT= 1 S P3=$P( $G(^DD($S( FE>50:200, 1:8991.9), FE,0)),U)
	4057	"RTN","PSO DEART",199 ,0)
	4058	I PSORPT= 2 S P3=$G( XTV(FN,ND_ ",",.03,"E "))_FSP
	4059	"RTN","PSO DEART",200 ,0)
	4060	S P4=$G(X TV(FN,ND_" ,",.04,"E" ))
	4061	"RTN","PSO DEART",201 ,0)
	4062	S P5=$G(X TV(FN,ND_" ,",.05,"E" ))
	4063	"RTN","PSO DEART",202 ,0)
	4064	I PSORPT= 1 D
	4065	"RTN","PSO DEART",203 ,0)
	4066	. I $L(P4 )=7 S Y=P4 D DT^DIO2 S P4=Y,Y= P5 D DT^DI O2 S P5=Y
	4067	"RTN","PSO DEART",204 ,0)
	4068	. I $L(P4 )<7 D
	4069	"RTN","PSO DEART",205 ,0)
	4070	.. S P4=$ S($G(XTV(F N,ND_",",. 04,"E"))=" True":1,$G (XTV(FN,ND _",",.04," E"))="Fals e":0,1:$G( XTV(FN,ND_ ",",.04,"E ")))
	4071	"RTN","PSO DEART",206 ,0)
	4072	.. S P5=$ S($G(XTV(F N,ND_",",. 05,"E"))=" True":1,$G (XTV(FN,ND _",",.05," E"))="Fals e":0,1:$G( XTV(FN,ND_ ",",.05,"E ")))_$S(FE >50:" (#20 0)",1:"")
	4073	"RTN","PSO DEART",207 ,0)
	4074	. S ^TMP( ZZ,$J,LC)= $E(P1,1,28 )_$E(P2,1, 26)_$E(P3_ FSP,1,24), LC=LC+1
	4075	"RTN","PSO DEART",208 ,0)
	4076	. S ^TMP( ZZ,$J,LC)= " ORIGIN AL DATA: " _P4,LC=LC+ 1
	4077	"RTN","PSO DEART",209 ,0)
	4078	. S ^TMP( ZZ,$J,LC)= " EDIT ED DATA: " _P5,LC=LC+ 1
	4079	"RTN","PSO DEART",210 ,0)
	4080	E S ^TMP (ZZ,$J,LC) =$E(P1,1,2 2)_" "_$E( P2,1,22)_" "_$E(P3,1 ,12)_" "_P 4,LC=LC+1
	4081	"RTN","PSO DEART",211 ,0)
	4082	Q
	4083	"RTN","PSO DEART",212 ,0)
	4084	;
	4085	"RTN","PSO DEART",213 ,0)
	4086	MFT ;
	4087	"RTN","PSO DEART",214 ,0)
	4088	S ^TMP(ZZ ,$J,LC)="" ,LC=LC+1
	4089	"RTN","PSO DEART",215 ,0)
	4090	S ^TMP(ZZ ,$J,LC)="* *Note: Thi s user is defined un der these divisions" ,LEN=$L(^T MP(ZZ,$J,L C))+1,LC=L C+1
	4091	"RTN","PSO DEART",216 ,0)
	4092	S $P(^TMP (ZZ,$J,LC) ,"-",LEN)= "",LC=LC+1
	4093	"RTN","PSO DEART",217 ,0)
	4094	S (DAT,ND )=0 F S N D=$O(^VA(2 00,J,2,ND) ) Q:'ND D
	4095	"RTN","PSO DEART",218 ,0)
	4096	. S DAT=D AT+1 S:DAT =1 ^TMP(ZZ ,$J,LC)=$$ GET1^DIQ(2 00,J,.01) S $E(^TMP( ZZ,$J,LC), 32)=$$GET1 ^DIQ(4,ND, .01),LC=LC +1
	4097	"RTN","PSO DEART",219 ,0)
	4098	Q
	4099	"RTN","PSO DEART",220 ,0)
	4100	;
	4101	"RTN","PSO DEART",221 ,0)
	4102	ODRPT ;
	4103	"RTN","PSO DEART",222 ,0)
	4104	;ePCS on demand rep ort - sett ing or mod ifing to l ogical acc ess contro ls/allocat ion histor y for PSDR PH key
	4105	"RTN","PSO DEART",223 ,0)
	4106	;called f rom option - PSO EPC S LOGICAL ACCESS/PSO EPCS PSDR PH AUDIT
	4107	"RTN","PSO DEART",224 ,0)
	4108	;provide a date ran ge
	4109	"RTN","PSO DEART",225 ,0)
	4110	N BDT,EDT ,FLG,ST,FN ,ZZ,POD,RH D,RT,OPT,P SOION D IN IT K %DT,D TOUT
	4111	"RTN","PSO DEART",226 ,0)
	4112	W ! S %DT (0)=-DT,%D T("A")="Be ginning Da te: ",%DT= "APE" D ^% DT I Y<0!( $D(DTOUT)) G EXIT
	4113	"RTN","PSO DEART",227 ,0)
	4114	S POD=1,( %DT(0),BDT )=Y
	4115	"RTN","PSO DEART",228 ,0)
	4116	W ! S %DT ("A")="End ing Date: " D ^%DT I Y<0!($D(D TOUT)) G E XIT
	4117	"RTN","PSO DEART",229 ,0)
	4118	S EDT=Y_" .9999"
	4119	"RTN","PSO DEART",230 ,0)
	4120	S ST=BDT, FLG=0 F S ST=$O(^XT V(FN,"DT", ST)) Q:ST= ""!(FLG=1) D
	4121	"RTN","PSO DEART",231 ,0)
	4122	. S:ST<E DT FLG=1
	4123	"RTN","PSO DEART",232 ,0)
	4124	I FLG=0 W !!?18," **** NO DATA T O PRINT ******** " H 2 G EX IT
	4125	"RTN","PSO DEART",233 ,0)
	4126	K IOP,%ZI S S PSOION =ION,%ZIS= "MQ" D ^%Z IS I POP S IOP=PSOIO N D ^%ZIS G EXIT
	4127	"RTN","PSO DEART",234 ,0)
	4128	AUTPRT ;
	4129	"RTN","PSO DEART",235 ,0)
	4130	N DV,ND,D AT,IEN
	4131	"RTN","PSO DEART",236 ,0)
	4132	K ^XTMP(Z Z,$J)
	4133	"RTN","PSO DEART",237 ,0)
	4134	S LD=BDT F S LD=$O (^XTV(FN," DT",LD)) Q:'LD!(LD> EDT) D
	4135	"RTN","PSO DEART",238 ,0)
	4136	. S ND=0 F S ND=$O (^XTV(FN," DT",LD,ND) ) Q:'ND D
	4137	"RTN","PSO DEART",239 ,0)
	4138	.. Q:'$D( ^XTV(FN,ND ,0))
	4139	"RTN","PSO DEART",240 ,0)
	4140	.. S DAT= ^XTV(FN,ND ,0)
	4141	"RTN","PSO DEART",241 ,0)
	4142	.. S IEN= $P(DAT,"^" )
	4143	"RTN","PSO DEART",242 ,0)
	4144	.. S DV=$ O(^VA(200, IEN,2,0)) S:'DV DV=9 99999
	4145	"RTN","PSO DEART",243 ,0)
	4146	.. S ^XTM P(ZZ,$J,DV ,LD,ND)=""
	4147	"RTN","PSO DEART",244 ,0)
	4148	.. S:$O(^ VA(200,IEN ,2,DV)) ^X TMP(ZZ,$J, "Z",IEN)=" "
	4149	"RTN","PSO DEART",245 ,0)
	4150	I $G(ZPR) !$D(IO("Q" )) D G EX IT
	4151	"RTN","PSO DEART",246 ,0)
	4152	. N ZTRTN ,ZTDESC,ZT IO,ZTSAVE, ZTDTH,ZTSK ,ZTREQ,ZTQ UEUED
	4153	"RTN","PSO DEART",247 ,0)
	4154	. S ZTIO= ZPR,ZTDTH= $H,ZTRTN=" OEN^PSODEA RT",ZTDESC =OPT,ZTSAV E(BDT)="", ZTSAVE(EDT )=""
	4155	"RTN","PSO DEART",248 ,0)
	4156	. D ^%ZTL OAD W:$D(Z TSK) !,"Re port is Qu eued to pr int !!"
	4157	"RTN","PSO DEART",249 ,0)
	4158	OEN ;
	4159	"RTN","PSO DEART",250 ,0)
	4160	U IO
	4161	"RTN","PSO DEART",251 ,0)
	4162	N PAGE,LI NE,LEN,XTV ,ARR,I,J,R HD,HCL,FSP ,RDT,DV,FE
	4163	"RTN","PSO DEART",252 ,0)
	4164	S RHD=$S( PSORPT=1:" SETTING OR CHANGES T O DEA PRES CRIBING PR IVILEGES", 1:"PSDRPH KEY AUDIT LIST")
	4165	"RTN","PSO DEART",253 ,0)
	4166	S HCL=(80 -$L(RHD))\ 2,RDT=$$FM TE^XLFDT($ $NOW^XLFDT ,"1M")
	4167	"RTN","PSO DEART",254 ,0)
	4168	S PAGE=1, $P(LINE,"- ",79)="",$ P(FSP," ", 25)=""
	4169	"RTN","PSO DEART",255 ,0)
	4170	D HD
	4171	"RTN","PSO DEART",256 ,0)
	4172	I '$D(^XT MP(ZZ,$J)) D G QT
	4173	"RTN","PSO DEART",257 ,0)
	4174	. W !!," * ******** NO M ATCHING DA TA ** *******" ,!!
	4175	"RTN","PSO DEART",258 ,0)
	4176	S DV="" F S DV=$O( ^XTMP(ZZ,$ J,DV)) Q:' DV D G:$ D(DIRUT) Q T
	4177	"RTN","PSO DEART",259 ,0)
	4178	. K ARR S LEN="Divi sion: "_$S (DV=999999 :"NO DIVIS ION",1:$$G ET1^DIQ(4, DV,.01))
	4179	"RTN","PSO DEART",260 ,0)
	4180	. W !!,LE N,! F I=1: 1:$L(LEN) W "-"
	4181	"RTN","PSO DEART",261 ,0)
	4182	. S LD=0 F S LD=$O (^XTMP(ZZ, $J,DV,LD)) Q:'LD D Q:$D(DIRU T)
	4183	"RTN","PSO DEART",262 ,0)
	4184	.. S ND=0 F S ND=$ O(^XTMP(ZZ ,$J,DV,LD, ND)) Q:'ND D Q:$D( DIRUT)
	4185	"RTN","PSO DEART",263 ,0)
	4186	... S DAT =^XTV(FN,N D,0),IEN=$ P(DAT,"^") ,FE=$P(DAT ,"^",3)
	4187	"RTN","PSO DEART",264 ,0)
	4188	... D GET S^DIQ(FN,N D,".01;.02 ;.03;.04;. 05;.06","E ","XTV")
	4189	"RTN","PSO DEART",265 ,0)
	4190	... S ARR (IEN)=""
	4191	"RTN","PSO DEART",266 ,0)
	4192	... I PSO RPT=1 D
	4193	"RTN","PSO DEART",267 ,0)
	4194	.... W !, $E($G(XTV( FN,ND_",", .01,"E"))_ FSP,1,25), ?28,$E($G( XTV(FN,ND_ ",",.02,"E "))_FSP,1, 25),?55,$E ($P($G(^DD ($S(FE>50: 200,1:8991 .9),FE,0)) ,U)_FSP,1, 24)
	4195	"RTN","PSO DEART",268 ,0)
	4196	.... W !, ?3,"ORIGIN AL DATA: "
	4197	"RTN","PSO DEART",269 ,0)
	4198	.... I FE =.04 S Y=$ P(DAT,"^", 4) D DT^DI O2
	4199	"RTN","PSO DEART",270 ,0)
	4200	.... I FE '=.04 W $S ($G(XTV(FN ,ND_",",.0 4,"E"))="T rue":1,$G( XTV(FN,ND_ ",",.04,"E "))="False ":0,1:$G(X TV(FN,ND_" ,",.04,"E" )))
	4201	"RTN","PSO DEART",271 ,0)
	4202	.... W !, ?3," EDIT ED DATA: "
	4203	"RTN","PSO DEART",272 ,0)
	4204	.... I FE =.04 S Y=$ P(DAT,"^", 5) D DT^DI O2
	4205	"RTN","PSO DEART",273 ,0)
	4206	.... I FE '=.04 W $S ($G(XTV(FN ,ND_",",.0 5,"E"))="T rue":1,$G( XTV(FN,ND_ ",",.05,"E "))="False ":0,1:$G(X TV(FN,ND_" ,",.05,"E" )))_$S(FE> 50:" (#200 )",1:"")
	4207	"RTN","PSO DEART",274 ,0)
	4208	... I PSO RPT'=1 W ! ,$G(XTV(FN ,ND_",",.0 1,"E")),?2 4,$G(XTV(F N,ND_",",. 02,"E")),? 48,$G(XTV( FN,ND_",", .03,"E")), ?61,$G(XTV (FN,ND_"," ,.04,"E"))
	4209	"RTN","PSO DEART",275 ,0)
	4210	... S ARR (IEN)=""
	4211	"RTN","PSO DEART",276 ,0)
	4212	... D:($Y +4)>IOSL H D
	4213	"RTN","PSO DEART",277 ,0)
	4214	. S J=0 F S J=$O(A RR(J)) Q:' J D:$D(^X TMP(ZZ,$J, "Z",J)) FT
	4215	"RTN","PSO DEART",278 ,0)
	4216	QT ;
	4217	"RTN","PSO DEART",279 ,0)
	4218	K DIR,DTO UT,DUOUT,D IRUT
	4219	"RTN","PSO DEART",280 ,0)
	4220	D EXIT
	4221	"RTN","PSO DEART",281 ,0)
	4222	Q
	4223	"RTN","PSO DEART",282 ,0)
	4224	;
	4225	"RTN","PSO DEART",283 ,0)
	4226	HD ;
	4227	"RTN","PSO DEART",284 ,0)
	4228	I PAGE>1, $E(IOST)=" C" S DIR(0 )="E",DIR( "A")=" Pre ss Return to Continu e or ^ to Exit" D ^D IR K DIR
	4229	"RTN","PSO DEART",285 ,0)
	4230	Q:$D(DIRU T)
	4231	"RTN","PSO DEART",286 ,0)
	4232	W @IOF
	4233	"RTN","PSO DEART",287 ,0)
	4234	I $G(POD) D
	4235	"RTN","PSO DEART",288 ,0)
	4236	. W !,?HC L,RHD,!,"F or the Per iod: " S Y =BDT D DT^ DIO2
	4237	"RTN","PSO DEART",289 ,0)
	4238	. W " to " S Y=$E(E DT,1,7) D DT^DIO2 W " Run Date: " S Y=DT D DT^ DIO2 W ?72 ,"Page "_P AGE,! S PA GE=PAGE+1
	4239	"RTN","PSO DEART",290 ,0)
	4240	E W !,RH D,?50,RDT, ?72,"Page "_PAGE,! S PAGE=PAGE +1
	4241	"RTN","PSO DEART",291 ,0)
	4242	I PSORPT= 1 W !,"NAM E",?28,"ED ITED BY",? 55,"FIELD EDITED"
	4243	"RTN","PSO DEART",292 ,0)
	4244	I PSORPT= 2 W !,"NAM E",?48,"AL LOCATION", !,?24,"EDI TED BY",?4 8,"STATUS" ,?61,"DATE /TIME EDIT ED"
	4245	"RTN","PSO DEART",293 ,0)
	4246	W !,LINE
	4247	"RTN","PSO DEART",294 ,0)
	4248	Q
	4249	"RTN","PSO DEART",295 ,0)
	4250	;
	4251	"RTN","PSO DEART",296 ,0)
	4252	FT ;
	4253	"RTN","PSO DEART",297 ,0)
	4254	S LEN="** Note: This user is d efined und er these d ivisions"
	4255	"RTN","PSO DEART",298 ,0)
	4256	W !!,LEN
	4257	"RTN","PSO DEART",299 ,0)
	4258	W ! F I=1 :1:$L(LEN) W "-"
	4259	"RTN","PSO DEART",300 ,0)
	4260	S (DAT,ND )=0 F S N D=$O(^VA(2 00,J,2,ND) ) Q:'ND D
	4261	"RTN","PSO DEART",301 ,0)
	4262	. S DAT=D AT+1 W ! W :DAT=1 $$G ET1^DIQ(20 0,J,.01) W ?32,$$GET 1^DIQ(4,ND ,.01)
	4263	"RTN","PSO DEART",302 ,0)
	4264	I $E(IOST )="C" S DI R(0)="E" D ^DIR
	4265	"RTN","PSO DEART",303 ,0)
	4266	Q
	4267	"RTN","PSO DEART",304 ,0)
	4268	;
	4269	"RTN","PSO DEART",305 ,0)
	4270	PARAM ;All ow user to edit para meters
	4271	"RTN","PSO DEART",306 ,0)
	4272	N DIR,Y
	4273	"RTN","PSO DEART",307 ,0)
	4274	S VALMBCK ="R" D FUL L^VALM1
	4275	"RTN","PSO DEART",308 ,0)
	4276	F D Q:' Y
	4277	"RTN","PSO DEART",309 ,0)
	4278	.S DIR(0) ="SO^1:PSO EPCS LOGIC AL ACC REP ORT DEV;2: PSOEPCS LO GICAL ACC RPT EMAIL; 3:PSOEPCS PHARM ACC RPT DEVICE ;4:PSOEPCS PHARM ACC REPORT EM AIL"
	4279	"RTN","PSO DEART",310 ,0)
	4280	.S DIR("A ")="Select parameter to edit"
	4281	"RTN","PSO DEART",311 ,0)
	4282	.D ^DIR Q :'Y
	4283	"RTN","PSO DEART",312 ,0)
	4284	.D EDITPA R^XPAREDIT (Y(0))
	4285	"RTN","PSO DEART",313 ,0)
	4286	Q
	4287	"RTN","PSO DEART",314 ,0)
	4288	;
	4289	"RTN","PSO DEART",315 ,0)
	4290	FAIL ;
	4291	"RTN","PSO DEART",316 ,0)
	4292	D EDITPAR ^XPAREDIT( "PSOEPCS E XPIRED DEA FAILOVER" )
	4293	"RTN","PSO DEART",317 ,0)
	4294	Q
	4295	"RTN","PSO DEART",318 ,0)
	4296	;
	4297	"RTN","PSO DEART",319 ,0)
	4298	MBM ;
	4299	"RTN","PSO DEART",320 ,0)
	4300	D EDITPAR ^XPAREDIT( "PSO VAMC MBM PHARMA CY MODE")
	4301	"RTN","PSO DEART",321 ,0)
	4302	Q
	4303	"RTN","PSO DEART",322 ,0)
	4304	;
	4305	"RTN","PSO DEART",323 ,0)
	4306	FOM ;
	4307	"RTN","PSO DEART",324 ,0)
	4308	Q:'$D(DIR ("B"))
	4309	"RTN","PSO DEART",325 ,0)
	4310	I DIR("B" )="YES",Y= 0 D
	4311	"RTN","PSO DEART",326 ,0)
	4312	. W !!,"* ******** ****** **** W ARNING * ******** ****** ****** *******"
	4313	"RTN","PSO DEART",327 ,0)
	4314	. W !,"A value of N O prevents providers with an e xpired DEA number fr om prescri bing"
	4315	"RTN","PSO DEART",328 ,0)
	4316	. W !,"co ntrolled s ubstances. A provid er without a DEA num ber will s till be ab le to"
	4317	"RTN","PSO DEART",329 ,0)
	4318	. W !,"pr escribe co ntrolled s ubstances if they ha ve a VA nu mber enter ed in Vist A.",!
	4319	"RTN","PSO DEART",330 ,0)
	4320	Q
	4321	"RTN","PSO DEART",331 ,0)
	4322	;
	4323	"RTN","PSO DIR")
	4324	0^1^B14906 3676
	4325	"RTN","PSO DIR",1,0)
	4326	PSODIR ;BH AM ISC/SAB - asks da ta for rx order entr y ; 9/17/0 7 5:03pm
	4327	"RTN","PSO DIR",2,0)
	4328	;;7.0;OUT PATIENT PH ARMACY;3 7,46,111,1 17,146,164 ,211,264,2 75,391,372 ,416,422,5 04,545;D EC 1997;Bu ild 21
	4329	"RTN","PSO DIR",3,0)
	4330	;External reference PSDRUG( s upported b y DBIA 221
	4331	"RTN","PSO DIR",4,0)
	4332	;External reference PS(50.7 s upported b y DBIA 222 3
	4333	"RTN","PSO DIR",5,0)
	4334	;External reference to VA(200 is suppor ted by DBI A 10060
	4335	"RTN","PSO DIR",6,0)
	4336	;External reference to DEA NU MBERS file (#8991.9) is suppor ted by DBI A 7002
	4337	"RTN","PSO DIR",7,0)
	4338	;External reference to sub-fi le NEW DEA #'S (#200 .5321) is supported by DBIA 70 00
	4339	"RTN","PSO DIR",8,0)
	4340	;-------- ---------- ---------- ---------- ---------- ---------- ------
	4341	"RTN","PSO DIR",9,0)
	4342	;
	4343	"RTN","PSO DIR",10,0)
	4344	PROV(PSODI R) ;
	4345	"RTN","PSO DIR",11,0)
	4346	PROVEN ; E ntry point for faile d lookup
	4347	"RTN","PSO DIR",12,0)
	4348	K DIC,X,Y S:$G(PSOF DR)&($G(OR 0)) DIC("B ")=$P(^VA( 200,$P($G( OR0),"^",5 ),0),"^")
	4349	"RTN","PSO DIR",13,0)
	4350	I '$D(PSO DIR("CS")) ,$D(PSODRU G("DEA")) D
	4351	"RTN","PSO DIR",14,0)
	4352	.N DEA S PSODIR("CS ")=0 F DEA =1:1 Q:$E( PSODRUG("D EA"),DEA)= "" I $E(+ PSODRUG("D EA"),DEA)> 1,$E(+PSOD RUG("DEA") ,DEA)<6 S PSODIR("CS ")=1
	4353	"RTN","PSO DIR",15,0)
	4354	I $G(PSOD IR("PROVID ER"))]"" S PSODIR("O LD VAL")=P SODIR("PRO VIDER")
	4355	"RTN","PSO DIR",16,0)
	4356	S DIC="^V A(200,",DI C(0)="QEAM ",PSODIR(" FIELD")=0
	4357	"RTN","PSO DIR",17,0)
	4358	S DIC("W" )="W "" "",$P($G (^(""PS"") ),""^"",9) "
	4359	"RTN","PSO DIR",18,0)
	4360	S DIC("A" )="PROVIDE R: ",DIC(" S")="I $D( ^(""PS"")) ,$P(^(""PS ""),""^"") ,$S('$P(^( ""PS""),"" ^"",4):1,1 :$P(^(""PS ""),""^"", 4)'<DT)"
	4361	"RTN","PSO DIR",19,0)
	4362	I $G(PSOT PBFG),$G(P SOFROM)="N EW" S DIC( "S")=DIC(" S")_",$P($ G(^(""TPB" ")),""^"") ,$P($G(^(" "TPB""))," "^"",5)=0"
	4363	"RTN","PSO DIR",20,0)
	4364	S:$G(PSOR X("PROVIDE R NAME"))] "" DIC("B" )=PSORX("P ROVIDER NA ME")
	4365	"RTN","PSO DIR",21,0)
	4366	D ^DIC K DIC
	4367	"RTN","PSO DIR",22,0)
	4368	I X[U,$L( X)>1 D:'$G (PSOEDIT) JUMP G PRO VX
	4369	"RTN","PSO DIR",23,0)
	4370	I $D(DTOU T)!$D(DUOU T) S PSODI R("DFLG")= 1 G PROVX
	4371	"RTN","PSO DIR",24,0)
	4372	I '$G(SPE ED),Y=-1 G PROVEN
	4373	"RTN","PSO DIR",25,0)
	4374	Q:$G(SPEE D)&(Y=-1)
	4375	"RTN","PSO DIR",26,0)
	4376	;*211; AD D CHECK FO R DEA# or VA#
	4377	"RTN","PSO DIR",27,0)
	4378	I $D(CLOZ PAT) N NDE A,SDEA S S DEA=$$DRGS CH() S NDE A=$$SDEA^X USER(0,+Y, SDEA) I ND EA=1 D G PROVEN
	4379	"RTN","PSO DIR",28,0)
	4380	.W $C(7), !!,"Provid er must ha ve a valid DEA# or V A# to writ e prescrip tions for this drug. ",!
	4381	"RTN","PSO DIR",29,0)
	4382	;*545; DE A/VA selec tion
	4383	"RTN","PSO DIR",30,0)
	4384	I $$DETOX ^PSSOPKI($ G(PSODRUG( "IEN"))) N DETX S DE TX="" D G :'$L(DETX) PROVEN
	4385	"RTN","PSO DIR",31,0)
	4386	. S DETX= $$DETOX^XU SER(+Y) I '$L(DETX) W $C(7),!! ,"Provider must have a DETOX# to order t his drug." ,! Q
	4387	"RTN","PSO DIR",32,0)
	4388	. S PSORX ("DETX")=D ETX
	4389	"RTN","PSO DIR",33,0)
	4390	I $P($G(P SODIR("CS" )),"^",1) N PROVDEA ,PSOPROVD D G:$G(PR OVDEA)="" PROVEN
	4391	"RTN","PSO DIR",34,0)
	4392	.S PSOPRO VD=+Y S PR OVDEA=$$SL DEA(PSOPRO VD,.PSORX)
	4393	"RTN","PSO DIR",35,0)
	4394	I $D(CLOZ PAT),'$D(^ XUSEC("YSC L AUTHORIZ ED",+Y)) D G PROVEN
	4395	"RTN","PSO DIR",36,0)
	4396	.W $C(7), !!,"Provid er must ho ld YSCL AU THORIZED k ey to writ e prescrip tions for clozapine. ",!
	4397	"RTN","PSO DIR",37,0)
	4398	I '$G(PSO DRUG("IEN" )),'$G(PSO RENW("DRUG IEN")) G NODRUG
	4399	"RTN","PSO DIR",38,0)
	4400	NODRUG S P SODIR("PRO VIDER")=+Y
	4401	"RTN","PSO DIR",39,0)
	4402	S (PSODIR ("PROVIDER NAME"),PS ORX("PROVI DER NAME") )=$P(Y,"^" ,2)
	4403	"RTN","PSO DIR",40,0)
	4404	I $G(PSOD IR("OLD VA L"))'=+Y K PSODIR("G ENERIC PRO VIDER"),PS ODIR("COSI GNING PROV IDER")
	4405	"RTN","PSO DIR",41,0)
	4406	I $G(PSOD IR("OLD VA L"))'=$G(P SODIR("PRO VIDER")),$ P(Y,"^",2) ="PROVIDER ,OTHER"!($ P(Y,"^",2) ="PROVIDER ,OUTSIDE") D GENERIC
	4407	"RTN","PSO DIR",42,0)
	4408	I $P(^VA( 200,PSODIR ("PROVIDER "),"PS")," ^",7),$P(^ ("PS"),"^" ,8) D COSI GN
	4409	"RTN","PSO DIR",43,0)
	4410	I $G(PSOD IR("COSIGN ING PROVID ER")),'$P( ^VA(200,PS ODIR("PROV IDER"),"PS "),"^",7) K PSODIR(" COSIGNING PROVIDER")
	4411	"RTN","PSO DIR",44,0)
	4412	PROVX K X, Y
	4413	"RTN","PSO DIR",45,0)
	4414	Q
	4415	"RTN","PSO DIR",46,0)
	4416	;
	4417	"RTN","PSO DIR",47,0)
	4418	DRGSCH() ; determine the drug schedule
	4419	"RTN","PSO DIR",48,0)
	4420	N ND3,SCH
	4421	"RTN","PSO DIR",49,0)
	4422	S SCH="", ND3=$P($G( ^PSDRUG(PS ODRUG("IEN "),"ND")), "^",3) S:+ ND3 SCH=$$ GET1^DIQ(5 0.68,ND3,1 9,"I")
	4423	"RTN","PSO DIR",50,0)
	4424	I +SCH>0! ($G(PSODRU G("DEA"))= "") Q SCH
	4425	"RTN","PSO DIR",51,0)
	4426	I "^4^5^" [+PSODRUG( "DEA") Q + PSODRUG("D EA")
	4427	"RTN","PSO DIR",52,0)
	4428	Q $S($G(P SODRUG("DE A"))["A":+ PSODRUG("D EA"),1:+PS ODRUG("DEA ")_"n")
	4429	"RTN","PSO DIR",53,0)
	4430	;
	4431	"RTN","PSO DIR",54,0)
	4432	GENERIC ;
	4433	"RTN","PSO DIR",55,0)
	4434	K DIR,DIC ,PSODIR("G ENERIC PRO VIDER")
	4435	"RTN","PSO DIR",56,0)
	4436	S DIR(0)= "52,30"
	4437	"RTN","PSO DIR",57,0)
	4438	D DIR G:P SODIR("DFL G")!PSODIR ("FIELD") GENERICX
	4439	"RTN","PSO DIR",58,0)
	4440	S PSODIR( "GENERIC P ROVIDER")= Y
	4441	"RTN","PSO DIR",59,0)
	4442	GENERICX K X,Y
	4443	"RTN","PSO DIR",60,0)
	4444	Q
	4445	"RTN","PSO DIR",61,0)
	4446	;
	4447	"RTN","PSO DIR",62,0)
	4448	COSIGN ;
	4449	"RTN","PSO DIR",63,0)
	4450	K DIC
	4451	"RTN","PSO DIR",64,0)
	4452	I '$G(PSO DIR("COSIG NING PROVI DER")),$P( $G(RX3),"^ ",3) S PSO DIR("COSIG NING PROVI DER")=$P(R X3,"^",3) G COSIGN1
	4453	"RTN","PSO DIR",65,0)
	4454	I $P($G(R X3),"^",3) ,$P($G(RX3 ),"^",3)'= $P(^VA(200 ,PSODIR("P ROVIDER"), "PS"),"^", 8) D
	4455	"RTN","PSO DIR",66,0)
	4456	.W !!,"Pr evious Co- Signing Pr ovider: "_ $P(^VA(200 ,$P(RX3,"^ ",3),0),"^ ")
	4457	"RTN","PSO DIR",67,0)
	4458	.S PSODIR ("COSIGNIN G PROVIDER ")=$S($P(R X3,"^",3)' =PSODIR("C OSIGNING P ROVIDER"): PSODIR("CO SIGNING PR OVIDER"),1 :$P(^VA(20 0,PSODIR(" PROVIDER") ,"PS"),"^" ,8))
	4459	"RTN","PSO DIR",68,0)
	4460	COSIGN1 S DIC(0)="QE AM",DIC="^ VA(200,",D IC("B")=$S ($G(PSODIR ("COSIGNIN G PROVIDER ")):$P(^VA (200,PSODI R("COSIGNI NG PROVIDE R"),0),"^" ),1:$P(^VA (200,PSODI R("PROVIDE R"),"PS"), "^",8))
	4461	"RTN","PSO DIR",69,0)
	4462	S DIC("S" )="I $D(^( ""PS"")),$ P(^(""PS"" ),""^""),$ S('$P(^("" PS""),""^" ",4):1,1:$ P(^(""PS"" ),""^"",4) '<DT)"
	4463	"RTN","PSO DIR",70,0)
	4464	S DIC("W" )="W "" "",$P(^( ""PS""),"" ^"",9)",DI C("S")=DIC ("S")_",'$ P(^(""PS"" ),""^"",7) "
	4465	"RTN","PSO DIR",71,0)
	4466	S DIC("A" )="COSIGNI NG PROVIDE R: " D ^DI C K DIC
	4467	"RTN","PSO DIR",72,0)
	4468	I $D(DTOU T)!$D(DUOU T) S PSODI R("DFLG")= 1 G COSIGN X
	4469	"RTN","PSO DIR",73,0)
	4470	S:+Y>0 PS ODIR("COSI GNING PROV IDER")=+Y G:Y<0 COSI GN
	4471	"RTN","PSO DIR",74,0)
	4472	COSIGNX K X,Y
	4473	"RTN","PSO DIR",75,0)
	4474	Q
	4475	"RTN","PSO DIR",76,0)
	4476	DOSE(PSODI R) ;add do sing info
	4477	"RTN","PSO DIR",77,0)
	4478	N PSODOSN W S PSODOS NW=1
	4479	"RTN","PSO DIR",78,0)
	4480	D DOSE1^P SOORED5(.P SODIR)
	4481	"RTN","PSO DIR",79,0)
	4482	EX K PSODO SE,PSOSCH, DOSE,DOOR, SCH,VERB,N OUN,DOSEOR ,ENT,PSORT E,DRUA,DIR ,X,Y,DIRUT ,RTE,ERTE, DD,INS1,SI NS1
	4483	"RTN","PSO DIR",80,0)
	4484	Q
	4485	"RTN","PSO DIR",81,0)
	4486	INS(PSODIR ) ;patient instructi ons
	4487	"RTN","PSO DIR",82,0)
	4488	N DA
	4489	"RTN","PSO DIR",83,0)
	4490	K INS1,DD ,DIR,DIRUT S D=0 F S D=$O(PSO DIR("SIG", D)) Q:'D S DD=$G(DD )+1
	4491	"RTN","PSO DIR",84,0)
	4492	I $G(DD)= 1 S PSODIR ("INS")=$G (PSODIR("S IG",1)) G INSD
	4493	"RTN","PSO DIR",85,0)
	4494	;PSO727 5 remove c heck for P SOINSFL ju st check f or multi l ine sig
	4495	"RTN","PSO DIR",86,0)
	4496	I $G(DD)> 1 D G EX
	4497	"RTN","PSO DIR",87,0)
	4498	.K ^TMP($ J) S D=0 F S D=$O(P SODIR("SIG ",D)) Q:'D S ^TMP($ J,"SIG",D, 0)=PSODIR( "SIG",D)
	4499	"RTN","PSO DIR",88,0)
	4500	.S DWPK=2 ,DWLW=80,D IC="^TMP($ J,""SIG"", " D EN^DIW E K PSODIR ("SIG")
	4501	"RTN","PSO DIR",89,0)
	4502	.S D=0 F S D=$O(^T MP($J,"SIG ",D)) Q:'D S PSODIR ("SIG",D)= ^TMP($J,"S IG",D,0)
	4503	"RTN","PSO DIR",90,0)
	4504	.D EN^PSO FSIG(.PSOD IR,1) K DW LW,D,DWPK, ^TMP($J)
	4505	"RTN","PSO DIR",91,0)
	4506	I $G(PSOI NSFL)=0 G INSD
	4507	"RTN","PSO DIR",92,0)
	4508	I $G(PSOF DR),$G(ORD ),$P($G(^P S(52.41,+$ G(ORD),"EX T")),"^")' ="" G INSD
	4509	"RTN","PSO DIR",93,0)
	4510	I $G(PSOD IR("INS")) ']"",$G(^P S(50.7,PSO DRUG("OI") ,"INS"))]" ",'$D(PSOD IR("FLD",1 14)) S (DI R("B"),PSO OEINS)=^PS (50.7,PSOD RUG("OI"), "INS") G I NSD ;*422
	4511	"RTN","PSO DIR",94,0)
	4512	S (DIR("B "),PSOOEIN S)=$G(PSOD IR("SIG",1 )) ;*422
	4513	"RTN","PSO DIR",95,0)
	4514	INSD S DIR (0)="52,11 4" S:$G(PS ODIR("INS" ))]"" DIR( "B")=PSODI R("INS")
	4515	"RTN","PSO DIR",96,0)
	4516	D DIR
	4517	"RTN","PSO DIR",97,0)
	4518	I $G(PSOD IR("DFLG") ) S (PSODI R("INS"),P SODIR("SIG "),PSODIR( "SIG",1))= $G(PSOOEIN S),PSODIR( "SINS")=$G (PSOOSINS) D EN^PSOF SIG(.PSODI R,0)
	4519	"RTN","PSO DIR",98,0)
	4520	G:$G(PSOD IR("DFLG") )!(PSODIR( "FIELD")) EX
	4521	"RTN","PSO DIR",99,0)
	4522	I X'="",X '="@" S PS ODIR("INS" )=Y D SIG^ PSOHELP G INSD:'$D(X )
	4523	"RTN","PSO DIR",100,0 )
	4524	I $G(INS1 )]"" D EN^ DDIOL($E(I NS1,2,9999 999)) S (P SODIR("SIG ",1),PSODI R("SIG"))= $E(INS1,2, 9999999)
	4525	"RTN","PSO DIR",101,0 )
	4526	I X="@" S PSODELINS =1 D DELIN S^PSOHELP3 I $G(PSOD ELINS) S ( PSODIR("FL D",114),PS ODIR("FLD" ,114.1))=" " K PSODIR ("INS"),PS ODIR("SIG" ),PSODIR(" SINS") ;* 422
	4527	"RTN","PSO DIR",102,0 )
	4528	D EN^PSOF SIG(.PSODI R,1) I $O( SIG(0)) S SIGOK=1
	4529	"RTN","PSO DIR",103,0 )
	4530	G EX
	4531	"RTN","PSO DIR",104,0 )
	4532	Q
	4533	"RTN","PSO DIR",105,0 )
	4534	SINS(PSODI R) ;other lang. pati ent instru ctions
	4535	"RTN","PSO DIR",106,0 )
	4536	K SINS1,D IR
	4537	"RTN","PSO DIR",107,0 )
	4538	S DIR(0)= "52,114.1" S:$G(PSOD IR("SINS") )]"" DIR(" B")=PSODIR ("SINS")
	4539	"RTN","PSO DIR",108,0 )
	4540	I $G(PSOD IR("SINS") )']"",$G(^ PS(50.7,PS ODRUG("OI" ),"INS1")) ]"",'$D(PS ODIR("FLD" ,114)),$G( PSOOEINS)] "" S (DIR( "B"),PSOOS INS)=^PS(5 0.7,PSODRU G("OI"),"I NS1")
	4541	"RTN","PSO DIR",109,0 )
	4542	D DIR I $ G(PSODIR(" DFLG")) S (PSODIR("I NS"),PSODI R("SIG"),P SODIR("SIG ",1))=$G(P SOOEINS),P SODIR("SIN S")=$G(PSO OSINS) D E N^PSOFSIG( .PSODIR,0) G EX
	4543	"RTN","PSO DIR",110,0 )
	4544	I X'="",X '="@" S PS ODIR("SINS ")=Y D SSI G^PSOHELP
	4545	"RTN","PSO DIR",111,0 )
	4546	I $G(SINS 1)]"" D EN ^DDIOL($E( SINS1,2,99 99999)) S PSODIR("SI NS")=$E(SI NS1,2,9999 999)
	4547	"RTN","PSO DIR",112,0 )
	4548	I X="@" S PSODELINS =2 D DELIN S^PSOHELP3 I $G(PSOD ELINS) S ( PSODIR("FL D",114),PS ODIR("FLD" ,114.1))=" " K PSODIR ("INS"),PS ODIR("SIG" ),PSODIR(" SINS") D E N^PSOFSIG( .PSODIR,1) ;*422
	4549	"RTN","PSO DIR",113,0 )
	4550	G EX
	4551	"RTN","PSO DIR",114,0 )
	4552	Q
	4553	"RTN","PSO DIR",115,0 )
	4554	;
	4555	"RTN","PSO DIR",116,0 )
	4556	DIR ;
	4557	"RTN","PSO DIR",117,0 )
	4558	S PSODIR( "FIELD")=0
	4559	"RTN","PSO DIR",118,0 )
	4560	G:$G(DIR( 0))']"" DI RX
	4561	"RTN","PSO DIR",119,0 )
	4562	D ^DIR K DIR,DIE,DI C,DA
	4563	"RTN","PSO DIR",120,0 )
	4564	I $D(DUOU T)!($D(DTO UT))!($D(D IROUT)),$L ($G(X))'>1 S PSODIR( "DFLG")=1 G DIRX
	4565	"RTN","PSO DIR",121,0 )
	4566	I X[U,$L( X)>1 D:'$G (PSOEDIT) JUMP
	4567	"RTN","PSO DIR",122,0 )
	4568	DIRX K DIR UT,DTOUT,D UOUT,DIROU T,PSOX
	4569	"RTN","PSO DIR",123,0 )
	4570	Q
	4571	"RTN","PSO DIR",124,0 )
	4572	;
	4573	"RTN","PSO DIR",125,0 )
	4574	JUMP ;
	4575	"RTN","PSO DIR",126,0 )
	4576	I $G(PSOE DIT)!($G(O R0)) S PSO DIR("DFLG" )=1 Q
	4577	"RTN","PSO DIR",127,0 )
	4578	S X=$P(X, "^",2),DIC ="^DD(52," ,DIC(0)="Q M" D ^DIC K DIC
	4579	"RTN","PSO DIR",128,0 )
	4580	I Y=-1 S PSODIR("FI ELD")=$G(P SODIR("FLD ")) G JUMP X
	4581	"RTN","PSO DIR",129,0 )
	4582	I $G(PSON EW1)=0 D J UMP^PSONEW 1 G JUMPX
	4583	"RTN","PSO DIR",130,0 )
	4584	I $G(PSOR EF1)=0 D J UMP^PSOREF 1 G JUMPX
	4585	"RTN","PSO DIR",131,0 )
	4586	I $G(PSON EW3)=0 D J UMP^PSONEW 3 G JUMPX
	4587	"RTN","PSO DIR",132,0 )
	4588	I $G(PSOR ENW3)=0 D JUMP^PSORE NW3 G JUMP X
	4589	"RTN","PSO DIR",133,0 )
	4590	JUMPX S X= "^"_X
	4591	"RTN","PSO DIR",134,0 )
	4592	Q
	4593	"RTN","PSO DIR",135,0 )
	4594	;
	4595	"RTN","PSO DIR",136,0 )
	4596	;*545; DE A selectio n
	4597	"RTN","PSO DIR",137,0 )
	4598	SLDEA(PROV IEN,PSORX) ;
	4599	"RTN","PSO DIR",138,0 )
	4600	N DA,SDEA ,VA,NDEA,D CNT,DLOOP, DEARY,Y,DE ASEL S DEA SEL=""
	4601	"RTN","PSO DIR",139,0 )
	4602	S DA(1)=P ROVIEN,SDE A=$$DRGSCH ^PSODIR(), VA=$P($G(^ VA(200,PRO VIEN,"PS") ),U,3)
	4603	"RTN","PSO DIR",140,0 )
	4604	D DEALIST (.DEARY,PR OVIEN,SDEA )
	4605	"RTN","PSO DIR",141,0 )
	4606	;no DEA#/ VA#
	4607	"RTN","PSO DIR",142,0 )
	4608	I $P(DEAR Y(0),U)=0& ('$L(VA)) D WM1 Q ""
	4609	"RTN","PSO DIR",143,0 )
	4610	;no DEA# then use V A#
	4611	"RTN","PSO DIR",144,0 )
	4612	I $P(DEAR Y(0),U)=0& ($L(VA)) Q $$USEVA(P ROVIEN,VA, .PSORX)
	4613	"RTN","PSO DIR",145,0 )
	4614	;DEA# is expired, c heck Failo ver flag
	4615	"RTN","PSO DIR",146,0 )
	4616	I $P(DEAR Y(0),U)=$P (DEARY(0), U,3),'$L(V A) D WM2 Q DEASEL
	4617	"RTN","PSO DIR",147,0 )
	4618	I $P(DEAR Y(0),U)=$P (DEARY(0), U,3) S DEA SEL=$$FAIL OVER(.DEAR Y,VA) Q DE ASEL
	4619	"RTN","PSO DIR",148,0 )
	4620	I $P(DEAR Y(0),U)=1& ($P(DEARY( 0),U,2))=1 &($D(DEARY (2))) S Y= 1 D DISP3( $P(DEARY(2 ,1),U),Y,. PSORX) Q P SORX("RXDE A")
	4621	"RTN","PSO DIR",149,0 )
	4622	I $D(DEAR Y(3))&('$D (DEARY(2)) ) D Q ""
	4623	"RTN","PSO DIR",150,0 )
	4624	. W !,"Pr ovider not authorize d to write Federal S chedule "_ SDEA_" pre scriptions ."
	4625	"RTN","PSO DIR",151,0 )
	4626	. W !,"Pl ease conta ct the pro vider.",!
	4627	"RTN","PSO DIR",152,0 )
	4628	I $P(DEAR Y(0),U,1)> 1 W !,"Thi s provider has multi ple DEA re gistration s." W !,"P lease sele ct the cor rect DEA n umber for the prescr iption bei ng entered "
	4629	"RTN","PSO DIR",153,0 )
	4630	I $D(DEAR Y(1)) S DL OOP=0 F S DLOOP=$O( DEARY(1,DL OOP)) Q:'D LOOP D
	4631	"RTN","PSO DIR",154,0 )
	4632	. W !,"* "_$P($G(D EARY(1,DLO OP)),U,2) W:$L($P($G (DEARY(1,D LOOP)),U,3 )) "-"_$P( $G(DEARY(1 ,DLOOP)),U ,3) W " "_$P($G(DE ARY(1,DLOO P)),U,4)_" Expire d: "_$P($G (DEARY(1,D LOOP)),U,6 )
	4633	"RTN","PSO DIR",155,0 )
	4634	I $D(DEAR Y(3)) S DL OOP=0 F S DLOOP=$O( DEARY(3,DL OOP)) Q:'D LOOP D Q
	4635	"RTN","PSO DIR",156,0 )
	4636	. W !,"* "_$P($G(D EARY(3,DLO OP)),U,2) W:$L($P($G (DEARY(3,D LOOP)),U,3 )) "-"_$P( $G(DEARY(3 ,DLOOP)),U ,3)
	4637	"RTN","PSO DIR",157,0 )
	4638	. W " " _$P($G(DEA RY(3,DLOOP )),U,4)_" Not Va lid for Sc hedule: "_ SDEA
	4639	"RTN","PSO DIR",158,0 )
	4640	S (DCNT,D LOOP)=0 F S DLOOP=$ O(DEARY(2, DLOOP)) Q: 'DLOOP D
	4641	"RTN","PSO DIR",159,0 )
	4642	. S DCNT= DCNT+1 W ! ,DCNT_". " _$P($G(DEA RY(2,DLOOP )),U,2) W: $L($P($G(D EARY(2,DLO OP)),U,3)) "-"_$P($G (DEARY(2,D LOOP)),U,3 ) W " "_ $P($G(DEAR Y(2,DLOOP) ),U,4)
	4643	"RTN","PSO DIR",160,0 )
	4644	I $G(DCNT )=0 Q ""
	4645	"RTN","PSO DIR",161,0 )
	4646	S DEASEL= $$DDIR(DCN T)
	4647	"RTN","PSO DIR",162,0 )
	4648	Q DEASEL
	4649	"RTN","PSO DIR",163,0 )
	4650	;
	4651	"RTN","PSO DIR",164,0 )
	4652	DDIR(DCNT) ;
	4653	"RTN","PSO DIR",165,0 )
	4654	N DIR,Y,D EASEL
	4655	"RTN","PSO DIR",166,0 )
	4656	K DIRUT S DIR(0)="N O^1:"_DCNT ,DIR("A")= "Choose",D IR("?",1)= "Select a choice fro m the list above" D ^DIR K DI R
	4657	"RTN","PSO DIR",167,0 )
	4658	I $D(DIRU T)!(Y<1) K DIRUT,DTO UT,DUOUT Q ""
	4659	"RTN","PSO DIR",168,0 )
	4660	I $G(FLOV )=1 D INDI SP(PROVIEN ,DEARY(Y), .PSORX) Q DEASEL
	4661	"RTN","PSO DIR",169,0 )
	4662	S DEASEL= $P(DEARY(2 ,Y),U,1)
	4663	"RTN","PSO DIR",170,0 )
	4664	D DISP3($ P(DEARY(2, Y),U,1),Y, .PSORX)
	4665	"RTN","PSO DIR",171,0 )
	4666	Q DEASEL
	4667	"RTN","PSO DIR",172,0 )
	4668	;
	4669	"RTN","PSO DIR",173,0 )
	4670	FAILOVER(D EARY,VA) ; check fail over flag, if expire d DEA, use VA schedu le
	4671	"RTN","PSO DIR",174,0 )
	4672	N FLOV,ND EA,DCNT
	4673	"RTN","PSO DIR",175,0 )
	4674	S FLOV=$$ GET^XPAR(" SYS","PSOE PCS EXPIRE D DEA FAIL OVER",1,"I "),DCNT=0
	4675	"RTN","PSO DIR",176,0 )
	4676	I 'FLOV D WM2 Q ""
	4677	"RTN","PSO DIR",177,0 )
	4678	S NDEA=$$ SDEA^XUSER (0,PROVIEN ,SDEA)
	4679	"RTN","PSO DIR",178,0 )
	4680	I NDEA=1! (NDEA=2) D WM2 Q ""
	4681	"RTN","PSO DIR",179,0 )
	4682	S DCNT=DC NT+1 W !," "_DCNT_". "_VA_" (VA#)" S D EARY(DCNT) =NDEA
	4683	"RTN","PSO DIR",180,0 )
	4684	I $D(DEAR Y(1)) S DL OOP=0 F S DLOOP=$O( DEARY(1,DL OOP)) Q:'D LOOP D
	4685	"RTN","PSO DIR",181,0 )
	4686	.W !,"* " _$P($G(DEA RY(1,DLOOP )),U,2) W: $L($P($G(D EARY(1,DLO OP)),U,3)) "-"_$P($G (DEARY(1,D LOOP)),U,3 ) W " "_ $P($G(DEAR Y(1,DLOOP) ),U,4)_" Expired: "_$P($G(D EARY(1,DLO OP)),U,6)
	4687	"RTN","PSO DIR",182,0 )
	4688	Q $$DDIR( DCNT)
	4689	"RTN","PSO DIR",183,0 )
	4690	;
	4691	"RTN","PSO DIR",184,0 )
	4692	DISP3(IEN, ARYSEL,PSO RX) ;displ ays dea#,d etox#,addr ess
	4693	"RTN","PSO DIR",185,0 )
	4694	N DA,DIC, DR,DISPFLD ,DISPVAL,D ISPTXT,RES ,DERR,ARYS EL
	4695	"RTN","PSO DIR",186,0 )
	4696	S DA=IEN, ARYSEL=Y
	4697	"RTN","PSO DIR",187,0 )
	4698	S DIC="^X TV(8991.9, "
	4699	"RTN","PSO DIR",188,0 )
	4700	S DR=".01 "_$S($$GET 1^DIQ(50,P SODRUG("IE N"),.01,"E ")["BUPREN ":";.03",1 :"")_";1.2 :1.7"
	4701	"RTN","PSO DIR",189,0 )
	4702	K ^UTILIT Y("DIQ1",$ J)
	4703	"RTN","PSO DIR",190,0 )
	4704	D EN^DIQ1
	4705	"RTN","PSO DIR",191,0 )
	4706	W !
	4707	"RTN","PSO DIR",192,0 )
	4708	I $D(^UTI LITY("DIQ1 ",$J)) D
	4709	"RTN","PSO DIR",193,0 )
	4710	. S DISPF LD=0 F S DISPFLD=$O (^UTILITY( "DIQ1",$J, 8991.9,DA, DISPFLD)) Q:'DISPFLD D
	4711	"RTN","PSO DIR",194,0 )
	4712	.. S DISP VAL=$G(^UT ILITY("DIQ 1",$J,8991 .9,DA,DISP FLD))
	4713	"RTN","PSO DIR",195,0 )
	4714	.. I DISP FLD=.01,$P (DEARY(2,A RYSEL),U,3 )]"" S DIS PVAL=DISPV AL_"-"_$P( DEARY(2,AR YSEL),U,3)
	4715	"RTN","PSO DIR",196,0 )
	4716	.. I DISP FLD=.03 S DISPVAL=$$ DETOX^XUSE R(PROVIEN)
	4717	"RTN","PSO DIR",197,0 )
	4718	.. K RES, DERR
	4719	"RTN","PSO DIR",198,0 )
	4720	.. D FIEL D^DID(8991 .9,DISPFLD ,"","LABEL ","RES","D ERR")
	4721	"RTN","PSO DIR",199,0 )
	4722	.. I '$D( RES) Q
	4723	"RTN","PSO DIR",200,0 )
	4724	.. S DISP TXT=$G(RES ("LABEL")) _": "_DISP VAL
	4725	"RTN","PSO DIR",201,0 )
	4726	.. W !," "_DISPTXT
	4727	"RTN","PSO DIR",202,0 )
	4728	W ! I $G( PSOEDIT)!( $G(ZZCOPY) ) W !,"Pre ss Return to continu e: ",$C(7) R X:$S($D (DTIME):DT IME,1:300)
	4729	"RTN","PSO DIR",203,0 )
	4730	S PSORX(" RXDEA")=$P (DEARY(2,A RYSEL),U,2 )
	4731	"RTN","PSO DIR",204,0 )
	4732	S:$P(DEAR Y(2,ARYSEL ),U,3)]"" PSORX("RXD EA")=PSORX ("RXDEA")_ "-"_$P(DEA RY(2,ARYSE L),U,3)
	4733	"RTN","PSO DIR",205,0 )
	4734	S DEASEL= PSORX("RXD EA")
	4735	"RTN","PSO DIR",206,0 )
	4736	Q DEASEL
	4737	"RTN","PSO DIR",207,0 )
	4738	;
	4739	"RTN","PSO DIR",208,0 )
	4740	USEVA(PROV IEN,VA,PSO RX) ;Use V A# only wh en provide r has no d ea#
	4741	"RTN","PSO DIR",209,0 )
	4742	N INN,IN, XUEXDT,DEA SEL,NODEA S DEASEL=" "
	4743	"RTN","PSO DIR",210,0 )
	4744	S NODEA=$ G(^VA(200, PROVIEN,"P S"))
	4745	"RTN","PSO DIR",211,0 )
	4746	I "34"[+$ P(NODEA,U, 6) D WM1 Q DEASEL
	4747	"RTN","PSO DIR",212,0 )
	4748	S NODEA=$ G(^VA(200, PROVIEN,"P S3"))
	4749	"RTN","PSO DIR",213,0 )
	4750	I NODEA=" "!(NODEA'[ 1) D WM1 Q DEASEL
	4751	"RTN","PSO DIR",214,0 )
	4752	S IN=$S(S DEA=2:1,SD EA="2n":2, SDEA=3:3,S DEA="3n":4 ,SDEA="4": 5,1:6)
	4753	"RTN","PSO DIR",215,0 )
	4754	I '$P(NOD EA,U,IN) D WM1 Q DEA SEL
	4755	"RTN","PSO DIR",216,0 )
	4756	S INN=+DU Z(2),IN=$P ($G(^DIC(4 ,INN,"DEA" )),U) ;sig ned-in Ins t.
	4757	"RTN","PSO DIR",217,0 )
	4758	I '$L(IN) D
	4759	"RTN","PSO DIR",218,0 )
	4760	. N XU1 D PARENT^XU AF4("XU1", "`"_INN,"P ARENT FACI LITY")
	4761	"RTN","PSO DIR",219,0 )
	4762	. S INN=$ O(XU1("P", "")) I INN S IN=$P($ G(^DIC(4,I NN,"DEA")) ,U)
	4763	"RTN","PSO DIR",220,0 )
	4764	. Q
	4765	"RTN","PSO DIR",221,0 )
	4766	I INN S X UEXDT=$P($ G(^DIC(4,I NN,"DEA")) ,U,2) ;che ck FACILIT Y DEA EXPI RATION DAT E
	4767	"RTN","PSO DIR",222,0 )
	4768	S XUEXDT= $G(XUEXDT)
	4769	"RTN","PSO DIR",223,0 )
	4770	I $L(VA), $L(IN),$L( XUEXDT),XU EXDT'<DT S (DEARY,DE ASEL)=IN_" -"_VA
	4771	"RTN","PSO DIR",224,0 )
	4772	I DEASEL= "" D WM1 Q DEASEL
	4773	"RTN","PSO DIR",225,0 )
	4774	D INDISP( PROVIEN,DE ARY,.PSORX )
	4775	"RTN","PSO DIR",226,0 )
	4776	S DEASEL= PSORX("RXD EA")
	4777	"RTN","PSO DIR",227,0 )
	4778	Q DEASEL
	4779	"RTN","PSO DIR",228,0 )
	4780	;
	4781	"RTN","PSO DIR",229,0 )
	4782	WM1 ;warni ng message
	4783	"RTN","PSO DIR",230,0 )
	4784	W !,"Prov ider must have a cur rent DEA# or VA# to write pres criptions for this d rug.",!
	4785	"RTN","PSO DIR",231,0 )
	4786	Q
	4787	"RTN","PSO DIR",232,0 )
	4788	;
	4789	"RTN","PSO DIR",233,0 )
	4790	WM2 ;
	4791	"RTN","PSO DIR",234,0 )
	4792	W !,"The provider's DEA# on f ile has Ex pired and must be up dated.",!
	4793	"RTN","PSO DIR",235,0 )
	4794	Q
	4795	"RTN","PSO DIR",236,0 )
	4796	;
	4797	"RTN","PSO DIR",237,0 )
	4798	INDISP(PRO VIEN,DEARY ,PSORX) ;d isplays in stitutiona l dea#va#, address o f institut ion
	4799	"RTN","PSO DIR",238,0 )
	4800	W !!,"DEA NUMBER: " _DEARY
	4801	"RTN","PSO DIR",239,0 )
	4802	I $G(PSOR X("DETX")) ]"" W !,"D ETOX NUMBE R: "_PSORX ("DETX")
	4803	"RTN","PSO DIR",240,0 )
	4804	W !,""_$$ GET1^DIQ(4 ,DUZ(2),4. 01)," "_$$ GET1^DIQ(4 ,DUZ(2),4. 02)
	4805	"RTN","PSO DIR",241,0 )
	4806	W !,""_$$ GET1^DIQ(4 ,DUZ(2),4. 03)_","_$$ GET1^DIQ(4 ,DUZ(2),4. 04)_" "_$ $GET1^DIQ( 4,DUZ(2),4 .05)
	4807	"RTN","PSO DIR",242,0 )
	4808	W ! I $G( PSOEDIT)!( $G(ZZCOPY) ) W !,"Pre ss Return to continu e: ",$C(7) R X:$S($D (DTIME):DT IME,1:300)
	4809	"RTN","PSO DIR",243,0 )
	4810	S (DEASEL ,PSORX("RX DEA"))=DEA RY
	4811	"RTN","PSO DIR",244,0 )
	4812	Q DEASEL
	4813	"RTN","PSO DIR",245,0 )
	4814	DEALIST(RE T,NPIEN,SD EA) ; -- returns th e DEA list
	4815	"RTN","PSO DIR",246,0 )
	4816	; INPUT: NPIEN - N EW PERSON FILE #200 INTERNAL E NTRY NUMBE R
	4817	"RTN","PSO DIR",247,0 )
	4818	;
	4819	"RTN","PSO DIR",248,0 )
	4820	; OUTPUT: RET - A S TRING OF D EA INFORMA TION DELIM ITED BY TH E "^".
	4821	"RTN","PSO DIR",249,0 )
	4822	; RET *** KILLED BY THIS RPC ***
	4823	"RTN","PSO DIR",250,0 )
	4824	; RET(0)=TO TCNT^NEXPC NT^EXPCNT - Count of DEA Numbe rs for a p rovider, c ount of ex pired DEA numbers fo r provider .
	4825	"RTN","PSO DIR",251,0 )
	4826	; RET(1,n) - Expired DEA Number s
	4827	"RTN","PSO DIR",252,0 )
	4828	; RET(2,n) - Active D EA Numbers
	4829	"RTN","PSO DIR",253,0 )
	4830	; RET(3,n) - Not allo wed to wri te that sc hedule
	4831	"RTN","PSO DIR",254,0 )
	4832	; 1 - DEA IEN
	4833	"RTN","PSO DIR",255,0 )
	4834	; 2 - DEA NUMBER
	4835	"RTN","PSO DIR",256,0 )
	4836	; 3 - IND IVIDUAL DE A SUFFIX
	4837	"RTN","PSO DIR",257,0 )
	4838	; 4 - STA TE
	4839	"RTN","PSO DIR",258,0 )
	4840	; 5 - DET OX NUMBER
	4841	"RTN","PSO DIR",259,0 )
	4842	; 6 - EXP IRATION DA TE EXTERNA L: FROM TH E DEA NUMB ERS FILE ( #8991.9), FIELD EXPI RATION DAT E (#.04)
	4843	"RTN","PSO DIR",260,0 )
	4844	; 7 - EXP IRATION DA TE INTERNA L: FROM TH E DEA NUMB ERS FILE ( #8991.9), FIELD EXPI RATION DAT E (#.04)
	4845	"RTN","PSO DIR",261,0 )
	4846	;
	4847	"RTN","PSO DIR",262,0 )
	4848	N CNT,DND EADAT,DNDE AIEN,FAIL, IENS,NPDEA DAT,NPDEAI EN,EXPDATE I,EXPCNT,N ODE1,DIFF, DNDEANUM,E XPFLG K RE T S EXPCNT =0
	4849	"RTN","PSO DIR",263,0 )
	4850	S CNT(1)= 0,CNT(2)=0 ,CNT(3)=0
	4851	"RTN","PSO DIR",264,0 )
	4852	S NPDEAIE N=0 F CNT= 1:1 S NPDE AIEN=$O(^V A(200,NPIE N,"PS4",NP DEAIEN)) Q :'+NPDEAIE N D
	4853	"RTN","PSO DIR",265,0 )
	4854	. S EXPFL G=0
	4855	"RTN","PSO DIR",266,0 )
	4856	. S IENS= NPDEAIEN_" ,"_NPIEN_" ,"
	4857	"RTN","PSO DIR",267,0 )
	4858	. K NPDEA DAT D GETS ^DIQ(200.5 321,IENS," **","","NP DEADAT") Q :'$D(NPDEA DAT)
	4859	"RTN","PSO DIR",268,0 )
	4860	. S DNDEA IEN=$$GET1 ^DIQ(200.5 321,IENS,. 03,"I") Q: 'DNDEAIEN
	4861	"RTN","PSO DIR",269,0 )
	4862	. K DNDEA DAT D GETS ^DIQ(8991. 9,DNDEAIEN ,"**",""," DNDEADAT") Q:'$D(DND EADAT)
	4863	"RTN","PSO DIR",270,0 )
	4864	. ;
	4865	"RTN","PSO DIR",271,0 )
	4866	. S EXPDA TEI=$$GET1 ^DIQ(8991. 9,DNDEAIEN ,.04,"I"), DIFF=$$FMD IFF^XLFDT( DT,EXPDATE I,1)
	4867	"RTN","PSO DIR",272,0 )
	4868	. I DIFF> 366 S EXPC NT=EXPCNT+ 1,CNT(1)=C NT(1)+1 Q
	4869	"RTN","PSO DIR",273,0 )
	4870	. I EXPDA TEI,EXPDAT EI<DT S EX PCNT=EXPCN T+1,NODE1= 1,CNT(1)=C NT(1)+1,EX PFLG=1 ; Expired DEA Counte r
	4871	"RTN","PSO DIR",274,0 )
	4872	. S DNDEA NUM=$$GET1 ^DIQ(200.5 321,IENS,. 01,"E")
	4873	"RTN","PSO DIR",275,0 )
	4874	. S NDEA= $$SDEA^XUS ER(0,NPIEN ,SDEA,DNDE ANUM) ; Check to verify sc hedule per missions
	4875	"RTN","PSO DIR",276,0 )
	4876	. I EXPFL G'=1!(NDEA =2) S NODE 1=3,CNT(3) =CNT(3)+1
	4877	"RTN","PSO DIR",277,0 )
	4878	. I EXPDA TEI,'(EXPD ATEI<DT),( NDEA'=2),( NDEA'=1),( EXPFLG'=1) S NODE1=2 ,CNT(2)=CN T(2)+1
	4879	"RTN","PSO DIR",278,0 )
	4880	. S RET(N ODE1,CNT(N ODE1))=""
	4881	"RTN","PSO DIR",279,0 )
	4882	. S RET(N ODE1,CNT(N ODE1))=RET (NODE1,CNT (NODE1))_D NDEAIEN_"^ " ; DEA IEN
	4883	"RTN","PSO DIR",280,0 )
	4884	. S RET(N ODE1,CNT(N ODE1))=RET (NODE1,CNT (NODE1))_N PDEADAT(20 0.5321,IEN S,.01)_"^" ; NEW PERS ON DEA NUM BER
	4885	"RTN","PSO DIR",281,0 )
	4886	. S RET(N ODE1,CNT(N ODE1))=RET (NODE1,CNT (NODE1))_N PDEADAT(20 0.5321,IEN S,.02)_"^" ; INDIVIDU AL DEA SUF FIX
	4887	"RTN","PSO DIR",282,0 )
	4888	. S RET(N ODE1,CNT(N ODE1))=RET (NODE1,CNT (NODE1))_D NDEADAT(89 91.9,DNDEA IEN_",",1. 6)_"^" ; STATE
	4889	"RTN","PSO DIR",283,0 )
	4890	. S RET(N ODE1,CNT(N ODE1))=RET (NODE1,CNT (NODE1))_D NDEADAT(89 91.9,DNDEA IEN_",",.0 3)_"^" ; DETOX NU MBER
	4891	"RTN","PSO DIR",284,0 )
	4892	. S RET(N ODE1,CNT(N ODE1))=RET (NODE1,CNT (NODE1))_D NDEADAT(89 91.9,DNDEA IEN_",",.0 4)_"^" ; EXPIRATI ON DATE EX TERNAL
	4893	"RTN","PSO DIR",285,0 )
	4894	. S RET(N ODE1,CNT(N ODE1))=RET (NODE1,CNT (NODE1))_E XPDATEI_"^ " ; EXPIRATI ON DATE IN TERNAL
	4895	"RTN","PSO DIR",286,0 )
	4896	S RET(0)= (CNT-1)_"^ "_(CNT(2)+ CNT(3))_"^ "_CNT(1)
	4897	"RTN","PSO DIR",287,0 )
	4898	Q
	4899	"RTN","PSO DIR",288,0 )
	4900	;
	4901	"RTN","PSO ERXA0")
	4902	0^6^B33012 992
	4903	"RTN","PSO ERXA0",1,0 )
	4904	PSOERXA0 ; ALB/BWF - eRx Utilit ies/RPC's ; 8/3/2016 5:14pm
	4905	"RTN","PSO ERXA0",2,0 )
	4906	;;7.0;OUT PATIENT PH ARMACY;4 67,545;D EC 1997;Bu ild 21
	4907	"RTN","PSO ERXA0",3,0 )
	4908	;
	4909	"RTN","PSO ERXA0",4,0 )
	4910	Q
	4911	"RTN","PSO ERXA0",5,0 )
	4912	; All par ameters ar e optional , however at least o ne needs t o be passe d in for p rocessing to be suce ssful.
	4913	"RTN","PSO ERXA0",6,0 )
	4914	; NDCUPN - This is the NDC/UP N for the drug (opti onal)
	4915	"RTN","PSO ERXA0",7,0 )
	4916	; DGDESC - Drug des cription ( optional)
	4917	"RTN","PSO ERXA0",8,0 )
	4918	DRGMTCH(PS ORES,NDCUP N,DGDESC) ;
	4919	"RTN","PSO ERXA0",9,0 )
	4920	N VAPRID, NDCUPNT,ND CUPNV,NDCU XREF,NUIEN ,NDCERR,PS MIEN,NDCER R,PSDRG,PS DRGCNT,PSD GLST,I
	4921	"RTN","PSO ERXA0",10, 0)
	4922	S (PSORES ,NDCERR)=0
	4923	"RTN","PSO ERXA0",11, 0)
	4924	I $G(DGDE SC)]"" D
	4925	"RTN","PSO ERXA0",12, 0)
	4926	.S DGDESC =$$UP^XLFS TR(DGDESC)
	4927	"RTN","PSO ERXA0",13, 0)
	4928	.I $D(^PS DRUG("B",D GDESC)) D
	4929	"RTN","PSO ERXA0",14, 0)
	4930	..S (PSDR G,PSDRGCNT )=0 F S P SDRG=$O(^P SDRUG("B", DGDESC,PSD RG)) Q:'PS DRG D
	4931	"RTN","PSO ERXA0",15, 0)
	4932	...I '$$A CTIVE(PSDR G)!('$$OUT PAT(PSDRG) )!($$INVCO MP(PSDRG)) !($$CS(PSD RG)) Q
	4933	"RTN","PSO ERXA0",16, 0)
	4934	...S PSDR GCNT=PSDRG CNT+1,PSDG LST(PSDRG) =""
	4935	"RTN","PSO ERXA0",17, 0)
	4936	..I PSDRG CNT>1 S PS ORES="0^Mo re than on e possible drug matc h found. P harmacist review req uired."
	4937	"RTN","PSO ERXA0",18, 0)
	4938	..I PSDRG CNT=1 S PS MIEN=$O(^P SDRUG("B", DGDESC,0)) ,PSORES=PS MIEN_U_$$G ET1^DIQ(50 ,PSMIEN,.0 1,"E") Q
	4939	"RTN","PSO ERXA0",19, 0)
	4940	.I $D(^PS NDF(50.68, "B",DGDESC )) S VAPRI D=$O(^PSND F(50.68,"B ",DGDESC,0 )) Q
	4941	"RTN","PSO ERXA0",20, 0)
	4942	.; is it possible t o have mor e than one drug or v a product match here ? .01 fiel ds are uni que!
	4943	"RTN","PSO ERXA0",21, 0)
	4944	; direct match in D RUG file
	4945	"RTN","PSO ERXA0",22, 0)
	4946	I $P(PSOR ES,U)>1 Q
	4947	"RTN","PSO ERXA0",23, 0)
	4948	; direct match in V A PRODUCT file
	4949	"RTN","PSO ERXA0",24, 0)
	4950	I $G(VAPR ID) D VAPR ID(.PSORES ,VAPRID) I $P(PSORES ,U) Q
	4951	"RTN","PSO ERXA0",25, 0)
	4952	I $G(NDCU PN)']"",$P (PSORES,U, 2)]"" Q
	4953	"RTN","PSO ERXA0",26, 0)
	4954	; check t he NDC/UPN if passed in
	4955	"RTN","PSO ERXA0",27, 0)
	4956	I $G(NDCU PN)]"" D
	4957	"RTN","PSO ERXA0",28, 0)
	4958	.S NDCUPN T=$P(NDCUP N,U),NDCUP NV=$P(NDCU PN,U,2),ND CUXREF=$S( NDCUPNT="N ":"NDC",ND CUPNT="U": "UPN",1:"" )
	4959	"RTN","PSO ERXA0",29, 0)
	4960	.; if NDC is less t han 12 in length, pa d front wi th zeros u ntil a len gth of 12 is achieve d.
	4961	"RTN","PSO ERXA0",30, 0)
	4962	.I NDCUPN T="N",$L(N DCUPNV)<12 D
	4963	"RTN","PSO ERXA0",31, 0)
	4964	..F I=1:1 :12-$L(NDC UPNV) S ND CUPNV=0_ND CUPNV
	4965	"RTN","PSO ERXA0",32, 0)
	4966	.S NUIEN= $O(^PSNDF( 50.67,NDCU XREF,NDCUP NV,0)) I ' NUIEN S ND CERR=1 Q
	4967	"RTN","PSO ERXA0",33, 0)
	4968	.S VAPRID =$$GET1^DI Q(50.67,NU IEN,5,"I")
	4969	"RTN","PSO ERXA0",34, 0)
	4970	.I VAPRID D VAPRID( .PSORES,VA PRID)
	4971	"RTN","PSO ERXA0",35, 0)
	4972	I $P(PSOR ES,U) Q
	4973	"RTN","PSO ERXA0",36, 0)
	4974	I $G(NDCE RR) S PSOR ES="0^NDC/ UPN match not found. " Q
	4975	"RTN","PSO ERXA0",37, 0)
	4976	I $P(PSOR ES,U)=0 S PSORES="0^ No matches found."
	4977	"RTN","PSO ERXA0",38, 0)
	4978	Q
	4979	"RTN","PSO ERXA0",39, 0)
	4980	VAPRID(PSO RES,VAPID) I '$G(VAP RID) S PSO RES="0^No VA PRODUCT associate d with thi s NDC/UPN. " Q
	4981	"RTN","PSO ERXA0",40, 0)
	4982	N VAPMTCH ,VAPCNT,VA PDRG,PSODR G
	4983	"RTN","PSO ERXA0",41, 0)
	4984	S (VAPMTC H,VAPCNT)= 0 F S VAP MTCH=$O(^P SDRUG("APR ",VAPRID,V APMTCH)) Q :'VAPMTCH D
	4985	"RTN","PSO ERXA0",42, 0)
	4986	.; ONLY G ET MEDICAT IONS FOR O UTPATIENT USE, AND A RE NOT MAR KED INACTI VE
	4987	"RTN","PSO ERXA0",43, 0)
	4988	.I '$$OUT PAT(VAPMTC H)!('$$ACT IVE(VAPMTC H))!($$INV COMP(VAPMT CH))!($$CS (VAPMTCH)) Q
	4989	"RTN","PSO ERXA0",44, 0)
	4990	.S VAPDRG (VAPMTCH)= "",VAPCNT= VAPCNT+1
	4991	"RTN","PSO ERXA0",45, 0)
	4992	I VAPCNT= 1 S PSODRG =$O(VAPDRG (0)),PSORE S=PSODRG_U _$$GET1^DI Q(50,PSODR G,.01,"E") Q
	4993	"RTN","PSO ERXA0",46, 0)
	4994	I VAPCNT> 1 S PSORES ="0^Multip le matched drugs fou nd. Pharma cist revie w required ." Q
	4995	"RTN","PSO ERXA0",47, 0)
	4996	Q
	4997	"RTN","PSO ERXA0",48, 0)
	4998	; active drug check
	4999	"RTN","PSO ERXA0",49, 0)
	5000	ACTIVE(DIE N) ;
	5001	"RTN","PSO ERXA0",50, 0)
	5002	N INACTDT
	5003	"RTN","PSO ERXA0",51, 0)
	5004	S INACTDT =$P($G(^PS DRUG(DIEN, "I")),U) I INACTDT,I NACTDT<DT Q 0
	5005	"RTN","PSO ERXA0",52, 0)
	5006	Q 1
	5007	"RTN","PSO ERXA0",53, 0)
	5008	; check t o see if t his is dru g is marke d for outp atient use
	5009	"RTN","PSO ERXA0",54, 0)
	5010	OUTPAT(DIE N) ;
	5011	"RTN","PSO ERXA0",55, 0)
	5012	I $P($G(^ PSDRUG(DIE N,2)),U,3) ["O" Q 1
	5013	"RTN","PSO ERXA0",56, 0)
	5014	Q 0
	5015	"RTN","PSO ERXA0",57, 0)
	5016	; check t o see if t he drug is investiga tional or compond
	5017	"RTN","PSO ERXA0",58, 0)
	5018	INVCOMP(DI EN) ;
	5019	"RTN","PSO ERXA0",59, 0)
	5020	N X
	5021	"RTN","PSO ERXA0",60, 0)
	5022	S X=$P($G (^PSDRUG(D IEN,0)),U, 3)
	5023	"RTN","PSO ERXA0",61, 0)
	5024	; if a su pply, not controlled substance
	5025	"RTN","PSO ERXA0",62, 0)
	5026	I X="S" Q 0
	5027	"RTN","PSO ERXA0",63, 0)
	5028	I X["I"!( X["0")!(X[ "M") Q 1
	5029	"RTN","PSO ERXA0",64, 0)
	5030	Q 0
	5031	"RTN","PSO ERXA0",65, 0)
	5032	CS(DIEN) ;
	5033	"RTN","PSO ERXA0",66, 0)
	5034	N X
	5035	"RTN","PSO ERXA0",67, 0)
	5036	S X=$P($G (^PSDRUG(D IEN,0)),U, 3)
	5037	"RTN","PSO ERXA0",68, 0)
	5038	I X["S" Q 0
	5039	"RTN","PSO ERXA0",69, 0)
	5040	I X]"",+X <6 Q 1
	5041	"RTN","PSO ERXA0",70, 0)
	5042	Q 0
	5043	"RTN","PSO ERXA0",71, 0)
	5044	CHKSTR() ;
	5045	"RTN","PSO ERXA0",72, 0)
	5046	Q
	5047	"RTN","PSO ERXA0",73, 0)
	5048	TPRVMTCH ;
	5049	"RTN","PSO ERXA0",74, 0)
	5050	N X,Y,TRE S
	5051	"RTN","PSO ERXA0",75, 0)
	5052	S X="" F S X=$O(^V A(200,"PS1 ",X)) Q:X= "" D
	5053	"RTN","PSO ERXA0",76, 0)
	5054	.S Y=0 F S Y=$O(^V A(200,"PS1 ",X,Y)) Q: 'Y D
	5055	"RTN","PSO ERXA0",77, 0)
	5056	..K TRES D PRVMTCH( .TRES,"",X ) I $P(TRE S,U)=0 W ! ,TRES_" "_ X Q
	5057	"RTN","PSO ERXA0",78, 0)
	5058	..I $P(TR ES,U) W !, X,?20,$$GE T1^DIQ(200 ,Y,.01,"E" )
	5059	"RTN","PSO ERXA0",79, 0)
	5060	Q
	5061	"RTN","PSO ERXA0",80, 0)
	5062	; Match p rovider gi ven NPI, D EA, or pro vider name .
	5063	"RTN","PSO ERXA0",81, 0)
	5064	; NPI - N PI value f or the pro vider
	5065	"RTN","PSO ERXA0",82, 0)
	5066	; DEA - P roviders' DEA number
	5067	"RTN","PSO ERXA0",83, 0)
	5068	; CS - co ntrolled s ubstance ( 1-yes, 0 o r "" - no)
	5069	"RTN","PSO ERXA0",84, 0)
	5070	PRVMTCH(PS ORES,NPI,D EA,CS) ;
	5071	"RTN","PSO ERXA0",85, 0)
	5072	N NPIEN,M ATCH,VAL,N VAL,INDEX, NPCNT,NPLI ST,DEACNT, SRCH,DEACN T,DEAMTCH, NDMTCH,DEA IEN
	5073	"RTN","PSO ERXA0",86, 0)
	5074	N DEACHK
	5075	"RTN","PSO ERXA0",87, 0)
	5076	S (PSORES ,MATCH)=0
	5077	"RTN","PSO ERXA0",88, 0)
	5078	S NPI=$G( NPI,""),DE A=$G(DEA," ")
	5079	"RTN","PSO ERXA0",89, 0)
	5080	I NPI="", DEA="" S P SORES="0^N PI and DEA # missing. " Q
	5081	"RTN","PSO ERXA0",90, 0)
	5082	I $G(CS), DEA="" S P SORES="0^D EA # must be provide d with con trolled su bstances." Q
	5083	"RTN","PSO ERXA0",91, 0)
	5084	I $G(CS), NPI="" S P SORES="0^N PI must be provided with contr olled subs tances." Q
	5085	"RTN","PSO ERXA0",92, 0)
	5086	I $G(CS), '$D(^VA(20 0,"ANPI",N PI)) S PSO RES="0^NPI # does not exist in this syste m." Q
	5087	"RTN","PSO ERXA0",93, 0)
	5088	I $G(CS), '$D(^VA(20 0,"PS1",DE A)) S PSOR ES="0^DEA# does not exist in t his system ." Q
	5089	"RTN","PSO ERXA0",94, 0)
	5090	I '$G(CS) ,NPI="" D Q
	5091	"RTN","PSO ERXA0",95, 0)
	5092	.I DEA="" S PSORES= "0^Missing DEA numbe r." Q
	5093	"RTN","PSO ERXA0",96, 0)
	5094	.I '$D(^V A(200,"PS1 ",DEA)) S PSORES="0^ DEA# does not exist at this lo cation." Q
	5095	"RTN","PSO ERXA0",97, 0)
	5096	.S (DEACH K,DEACNT)= 0 F S DEA CHK=$O(^VA (200,"PS1" ,DEA,DEACH K)) Q:'DEA CHK D
	5097	"RTN","PSO ERXA0",98, 0)
	5098	..S DEACN T=$G(DEACN T)+1
	5099	"RTN","PSO ERXA0",99, 0)
	5100	.I DEACNT >1 S PSORE S="0^Multi ple DEA ma tches foun d." Q
	5101	"RTN","PSO ERXA0",100 ,0)
	5102	.I DEACNT =1 S DEAIE N=$O(^VA(2 00,"PS1",D EA,0))
	5103	"RTN","PSO ERXA0",101 ,0)
	5104	.I '$$MED AUTH(DEAIE N) S PSORE S="0^DEA m atch, not authorized to write medication orders." Q
	5105	"RTN","PSO ERXA0",102 ,0)
	5106	.S PSORES =DEAIEN_U_ $$GET1^DIQ (200,DEAIE N,.01,"E")
	5107	"RTN","PSO ERXA0",103 ,0)
	5108	I '$D(^VA (200,"ANPI ",NPI)) S PSORES="0^ No matchin g NPI." Q
	5109	"RTN","PSO ERXA0",104 ,0)
	5110	; get a l ist of pro viders tha t match th e NPI#
	5111	"RTN","PSO ERXA0",105 ,0)
	5112	S (NPIEN, NPCNT)=0 F S NPIEN= $O(^VA(200 ,"ANPI",NP I,NPIEN)) Q:'NPIEN D
	5113	"RTN","PSO ERXA0",106 ,0)
	5114	.S NPLIST (NPIEN)="" ,NPCNT=$G( NPCNT)+1
	5115	"RTN","PSO ERXA0",107 ,0)
	5116	; no matc hes
	5117	"RTN","PSO ERXA0",108 ,0)
	5118	I '$D(NPL IST) S PSO RES="0^Cou ld not mat ch provide d NPI." Q
	5119	"RTN","PSO ERXA0",109 ,0)
	5120	I '$G(CS) ,NPCNT>1 S PSORES="0 ^Multiple provider m atches fou nd." Q
	5121	"RTN","PSO ERXA0",110 ,0)
	5122	I NPCNT=0 S PSORES= "0^No NPI match foun d." Q
	5123	"RTN","PSO ERXA0",111 ,0)
	5124	I '$G(CS) ,NPCNT=1 D Q
	5125	"RTN","PSO ERXA0",112 ,0)
	5126	.S NDMTCH =$O(NPLIST (0))
	5127	"RTN","PSO ERXA0",113 ,0)
	5128	.I '$$MED AUTH(NDMTC H) S PSORE S="0^NPI m atch found , not auth orized to write medi cation ord ers." Q
	5129	"RTN","PSO ERXA0",114 ,0)
	5130	.S PSORES =NDMTCH_U_ $$GET1^DIQ (200,$O(NP LIST(0)),. 01,"E")
	5131	"RTN","PSO ERXA0",115 ,0)
	5132	; if this is a cont rolled sub stance, we must matc h both the NPI and t he DEA#
	5133	"RTN","PSO ERXA0",116 ,0)
	5134	S (SRCH,D EACNT)=0 F S SRCH=$ O(NPLIST(S RCH)) Q:'S RCH D
	5135	"RTN","PSO ERXA0",117 ,0)
	5136	.I '$D(^V A(200,"PS1 ",DEA,SRCH )) Q
	5137	"RTN","PSO ERXA0",118 ,0)
	5138	.S DEAMTC H(SRCH)="" ,DEACNT=$G (DEACNT)+1
	5139	"RTN","PSO ERXA0",119 ,0)
	5140	I DEACNT> 1 S PSORES ="0^Multip le DEA mat ches found ." Q
	5141	"RTN","PSO ERXA0",120 ,0)
	5142	I DEACNT= 0 S PSORES ="0^NPI ma tch, DEA m ismatch." Q
	5143	"RTN","PSO ERXA0",121 ,0)
	5144	S NDMTCH= $O(DEAMTCH (0))
	5145	"RTN","PSO ERXA0",122 ,0)
	5146	I '$$MEDA UTH(NDMTCH ) S PSORES ="0^NPI/DE A match, n ot authori zed to wri te medicat ion orders ." Q
	5147	"RTN","PSO ERXA0",123 ,0)
	5148	I NDMTCH S PSORES=N DMTCH_U_$$ GET1^DIQ(2 00,NDMTCH, .01,"E") Q
	5149	"RTN","PSO ERXA0",124 ,0)
	5150	S PSORES= "0^Matchin g procedur e complete d with no results."
	5151	"RTN","PSO ERXA0",125 ,0)
	5152	Q
	5153	"RTN","PSO ERXA0",126 ,0)
	5154	; ensure the dea# i s active
	5155	"RTN","PSO ERXA0",127 ,0)
	5156	DEACTIVE(U SER) ;
	5157	"RTN","PSO ERXA0",128 ,0)
	5158	N EXPDT
	5159	"RTN","PSO ERXA0",129 ,0)
	5160	;*545
	5161	"RTN","PSO ERXA0",130 ,0)
	5162	S EXPDT=$ $PRXDT^XUS ER(USER)
	5163	"RTN","PSO ERXA0",131 ,0)
	5164	I EXPDT,E XPDT<DT Q 0
	5165	"RTN","PSO ERXA0",132 ,0)
	5166	Q 1
	5167	"RTN","PSO ERXA0",133 ,0)
	5168	; check t o ensure t he provide r is autho rized to w rite med o rders
	5169	"RTN","PSO ERXA0",134 ,0)
	5170	MEDAUTH(US ER) ;
	5171	"RTN","PSO ERXA0",135 ,0)
	5172	Q $$GET1^ DIQ(200,US ER,53.1,"I ")
	5173	"RTN","PSO ERXR1")
	5174	0^5^B33236 664
	5175	"RTN","PSO ERXR1",1,0 )
	5176	PSOERXR1 ; ALB/BWF - eRx Provid er Display /actions ; 8/3/2016 5:14pm
	5177	"RTN","PSO ERXR1",2,0 )
	5178	;;7.0;OUT PATIENT PH ARMACY;4 67,520,527 ,545;DEC 1997;Buil d 21
	5179	"RTN","PSO ERXR1",3,0 )
	5180	;
	5181	"RTN","PSO ERXR1",4,0 )
	5182	EN ; -- ma in entry p oint for P SO ERX HOL DING QUEUE
	5183	"RTN","PSO ERXR1",5,0 )
	5184	D EN^VALM ("PSO ERX PROVIDER V ALIDATION" )
	5185	"RTN","PSO ERXR1",6,0 )
	5186	Q
	5187	"RTN","PSO ERXR1",7,0 )
	5188	;
	5189	"RTN","PSO ERXR1",8,0 )
	5190	HDR ; -- h eader code
	5191	"RTN","PSO ERXR1",9,0 )
	5192	S VALMHDR (1)="eRx P atient: "_ $$GET1^DIQ (52.49,PSO IEN,.04,"E ")
	5193	"RTN","PSO ERXR1",10, 0)
	5194	S VALMHDR (2)="eRx R eference # : "_$$GET1 ^DIQ(52.49 ,PSOIEN,.0 1,"E")
	5195	"RTN","PSO ERXR1",11, 0)
	5196	I $G(VALM BCK)="R" D INIT
	5197	"RTN","PSO ERXR1",12, 0)
	5198	Q
	5199	"RTN","PSO ERXR1",13, 0)
	5200	;
	5201	"RTN","PSO ERXR1",14, 0)
	5202	INIT ;
	5203	"RTN","PSO ERXR1",15, 0)
	5204	Q:'$G(PSO IEN)
	5205	"RTN","PSO ERXR1",16, 0)
	5206	N LINE,PA RVDAT,EXPI EN,EXPIENS ,EXPNM,EXP DOB,EXPSSN ,EXPADD,EX PGEN,EXPCT Y,EXPST,EX PZIP,HFIEN ,EXPHPH,CP IEN,EXPCPH ,LINETXT
	5207	"RTN","PSO ERXR1",17, 0)
	5208	N EXPADD1 ,EXPADD2,E XPAGNT,EXP DEA,EXPFN, EXPLIC,EXP NPI,EXPSUP ER,EXPWPH, FNIEN,MANV AL,PRVDAT, VAPADD1,VA PADD2,VAPC IT,DEAEXP
	5209	"RTN","PSO ERXR1",18, 0)
	5210	N VAPDEA, VAPFAX,VAP IENS,VAPLI C,VAPNM,VA PNPI,VAPRO V,VAPRVIEN ,VAPST,VAP TEL,VAPZIP ,WPIEN,SEP LN,VAPDEAE X,VALBY,VA LDTTM,NFIR ST
	5211	"RTN","PSO ERXR1",19, 0)
	5212	N NLOOP,A GENTARY,TL OOP,TFIRST ,SUPERARY, SIEN,TYPE, VALUE,PRFA X,PRTEL,IE NS
	5213	"RTN","PSO ERXR1",20, 0)
	5214	S LINE=0, LINETXT=""
	5215	"RTN","PSO ERXR1",21, 0)
	5216	S EXPIEN= $$GET1^DIQ (52.49,PSO IEN,2.1,"I ")
	5217	"RTN","PSO ERXR1",22, 0)
	5218	S EXPIENS =EXPIEN_", "
	5219	"RTN","PSO ERXR1",23, 0)
	5220	D GETS^DI Q(52.48,EX PIENS,"**" ,"E","PRVD AT")
	5221	"RTN","PSO ERXR1",24, 0)
	5222	S EXPNM=$ G(PRVDAT(5 2.48,EXPIE NS,.01,"E" ))
	5223	"RTN","PSO ERXR1",25, 0)
	5224	S EXPNPI= $G(PRVDAT( 52.48,EXPI ENS,1.5,"E "))
	5225	"RTN","PSO ERXR1",26, 0)
	5226	S EXPDEA= $G(PRVDAT( 52.48,EXPI ENS,1.6,"E "))
	5227	"RTN","PSO ERXR1",27, 0)
	5228	S EXPLIC= $G(PRVDAT( 52.48,EXPI ENS,1.8,"E "))
	5229	"RTN","PSO ERXR1",28, 0)
	5230	S EXPAGNT =$G(PRVDAT (52.48,EXP IENS,5.1," E")) I $L( EXPAGNT) S EXPAGNT=E XPAGNT_", "_$G(PRVDA T(52.48,EX PIENS,5.2, "E"))_" "_ $G(PRVDAT( 52.48,EXPI ENS,5.3,"E "))
	5231	"RTN","PSO ERXR1",29, 0)
	5232	S EXPSUPE R=$$GET1^D IQ(52.49,P SOIEN,2.6, "E")
	5233	"RTN","PSO ERXR1",30, 0)
	5234	S EXPADD1 =$G(PRVDAT (52.48,EXP IENS,4.1," E"))
	5235	"RTN","PSO ERXR1",31, 0)
	5236	S EXPADD2 =$G(PRVDAT (52.48,EXP IENS,4.2," E"))
	5237	"RTN","PSO ERXR1",32, 0)
	5238	S EXPCTY= $G(PRVDAT( 52.48,EXPI ENS,4.3,"E "))
	5239	"RTN","PSO ERXR1",33, 0)
	5240	S EXPST=$ G(PRVDAT(5 2.48,EXPIE NS,4.4,"E" ))
	5241	"RTN","PSO ERXR1",34, 0)
	5242	S EXPZIP= $G(PRVDAT( 52.48,EXPI ENS,4.5,"E ")),EXPZIP =$E(EXPZIP ,1,5)
	5243	"RTN","PSO ERXR1",35, 0)
	5244	S WPIEN=$ O(^PS(52.4 8,EXPIEN,3 ,"C","WP", 0))
	5245	"RTN","PSO ERXR1",36, 0)
	5246	; home ph one
	5247	"RTN","PSO ERXR1",37, 0)
	5248	; fax num ber
	5249	"RTN","PSO ERXR1",38, 0)
	5250	S SIEN=0
	5251	"RTN","PSO ERXR1",39, 0)
	5252	F S SIEN =$O(^PS(52 .48,EXPIEN ,3,SIEN)) Q:'SIEN D
	5253	"RTN","PSO ERXR1",40, 0)
	5254	.S IENS=S IEN_","_EX PIEN_","
	5255	"RTN","PSO ERXR1",41, 0)
	5256	.S TYPE=$ $GET1^DIQ( 52.483,IEN S,.02)
	5257	"RTN","PSO ERXR1",42, 0)
	5258	.S VALUE= $$GET1^DIQ (52.483,IE NS,.01)
	5259	"RTN","PSO ERXR1",43, 0)
	5260	.I TYPE=" FAX" S PRF AX=VALUE
	5261	"RTN","PSO ERXR1",44, 0)
	5262	.I TYPE=" TELEPHONE" S PRTEL=V ALUE
	5263	"RTN","PSO ERXR1",45, 0)
	5264	S LINE=LI NE+1 D SET ^VALM10(LI NE,"eRx Pr ovider: "_ $E(EXPNM,1 ,50))
	5265	"RTN","PSO ERXR1",46, 0)
	5266	S LINE=LI NE+1 D SET ^VALM10(LI NE,"Addres s: "_$E(EX PADD1,1,50 ))
	5267	"RTN","PSO ERXR1",47, 0)
	5268	S LINE=LI NE+1 D SET ^VALM10(LI NE," "_$E(EX PADD2,1,50 ))
	5269	"RTN","PSO ERXR1",48, 0)
	5270	S LINE=LI NE+1 D SET ^VALM10(LI NE," "_EXPCT Y_", "_EXP ST_" "_EXP ZIP)
	5271	"RTN","PSO ERXR1",49, 0)
	5272	S LINE=LI NE+1
	5273	"RTN","PSO ERXR1",50, 0)
	5274	;/BLB/ PS O7.0520 moved NPI and DEA to own line - BEGIN CH ANGE
	5275	"RTN","PSO ERXR1",51, 0)
	5276	D ADDITEM ^PSOERX1A( .LINETXT," NPI: ",EXP NPI,1,40)
	5277	"RTN","PSO ERXR1",52, 0)
	5278	D SET^VAL M10(LINE,L INETXT) S LINETXT=""
	5279	"RTN","PSO ERXR1",53, 0)
	5280	S LINE=LI NE+1
	5281	"RTN","PSO ERXR1",54, 0)
	5282	D ADDITEM ^PSOERX1A( .LINETXT," DEA: ",EXP DEA,1,40)
	5283	"RTN","PSO ERXR1",55, 0)
	5284	;/BLB/ - END CHANGE
	5285	"RTN","PSO ERXR1",56, 0)
	5286	D SET^VAL M10(LINE,L INETXT) S LINETXT=""
	5287	"RTN","PSO ERXR1",57, 0)
	5288	S LINE=LI NE+1
	5289	"RTN","PSO ERXR1",58, 0)
	5290	D ADDITEM ^PSOERX1A( .LINETXT," State Lic: ",EXPLIC, 1,46)
	5291	"RTN","PSO ERXR1",59, 0)
	5292	D SET^VAL M10(LINE,L INETXT) S LINETXT=""
	5293	"RTN","PSO ERXR1",60, 0)
	5294	S LINE=LI NE+1
	5295	"RTN","PSO ERXR1",61, 0)
	5296	D ADDITEM ^PSOERX1A( .LINETXT," Tel: ",$G( PRTEL),1,2 6)
	5297	"RTN","PSO ERXR1",62, 0)
	5298	D ADDITEM ^PSOERX1A( .LINETXT," Fax: ",$G( PRFAX),28, 26)
	5299	"RTN","PSO ERXR1",63, 0)
	5300	D SET^VAL M10(LINE,L INETXT) S LINETXT=""
	5301	"RTN","PSO ERXR1",64, 0)
	5302	;/BLB/ PS O7.0520 MOVED AGEN T/SUPERVIS OR TO OWN LINE - BEG IN CHANGE
	5303	"RTN","PSO ERXR1",65, 0)
	5304	S LINE=LI NE+1
	5305	"RTN","PSO ERXR1",66, 0)
	5306	;/BLB/ PS O7.0527 - BEGIN CH ANGE - REM OVE BLANK LINES FROM AGENT/SUP ERVISOR
	5307	"RTN","PSO ERXR1",67, 0)
	5308	I $L($G(E XPAGNT)) D
	5309	"RTN","PSO ERXR1",68, 0)
	5310	.D TXT2AR Y^PSOERXD1 (.AGENTARY ,EXPAGNT,, 65)
	5311	"RTN","PSO ERXR1",69, 0)
	5312	.S NFIRST =$O(AGENTA RY(0))
	5313	"RTN","PSO ERXR1",70, 0)
	5314	.S NLOOP= 0 F S NLO OP=$O(AGEN TARY(NLOOP )) Q:'NLOO P D
	5315	"RTN","PSO ERXR1",71, 0)
	5316	..S LINE= LINE+1 D S ET^VALM10( LINE,$S(NL OOP=NFIRST :"Agent: " ,1:" ")_$G (AGENTARY( NLOOP)))
	5317	"RTN","PSO ERXR1",72, 0)
	5318	.S LINE=L INE+1
	5319	"RTN","PSO ERXR1",73, 0)
	5320	I $L($G(E XPSUPER)) D
	5321	"RTN","PSO ERXR1",74, 0)
	5322	.D TXT2AR Y^PSOERXD1 (.SUPERARY ,EXPSUPER, ,65)
	5323	"RTN","PSO ERXR1",75, 0)
	5324	.S TFIRST =$O(SUPERA RY(0))
	5325	"RTN","PSO ERXR1",76, 0)
	5326	.S TLOOP= 0 F S TLO OP=$O(SUPE RARY(TLOOP )) Q:'TLOO P D
	5327	"RTN","PSO ERXR1",77, 0)
	5328	..S LINE= LINE+1 D S ET^VALM10( LINE,$S(TL OOP=TFIRST :"Supervis or: ",1:" ")_$G(SUPE RARY(TLOOP )))
	5329	"RTN","PSO ERXR1",78, 0)
	5330	.S LINE=L INE+1
	5331	"RTN","PSO ERXR1",79, 0)
	5332	I '$L($G( EXPAGNT)) D
	5333	"RTN","PSO ERXR1",80, 0)
	5334	.S LINE=L INE+1
	5335	"RTN","PSO ERXR1",81, 0)
	5336	.D SET^VA LM10(LINE, "Agent: ")
	5337	"RTN","PSO ERXR1",82, 0)
	5338	I '$L($G( EXPSUPER)) D
	5339	"RTN","PSO ERXR1",83, 0)
	5340	.S LINE=L INE+1
	5341	"RTN","PSO ERXR1",84, 0)
	5342	.D SET^VA LM10(LINE, "Superviso r: ")
	5343	"RTN","PSO ERXR1",85, 0)
	5344	;/BLB/ - END CHANGE *527
	5345	"RTN","PSO ERXR1",86, 0)
	5346	S LINE=LI NE+1
	5347	"RTN","PSO ERXR1",87, 0)
	5348	D SET^VAL M10(LINE,L INETXT) S LINETXT=""
	5349	"RTN","PSO ERXR1",88, 0)
	5350	S $P(SEPL N,"-",80)= "-" D SET^ VALM10(LIN E,SEPLN)
	5351	"RTN","PSO ERXR1",89, 0)
	5352	; vista p atient inf ormation
	5353	"RTN","PSO ERXR1",90, 0)
	5354	S VAPRVIE N=$$GET1^D IQ(52.49,P SOIEN,2.3, "I")
	5355	"RTN","PSO ERXR1",91, 0)
	5356	; INITIAL IZE variab les
	5357	"RTN","PSO ERXR1",92, 0)
	5358	S (VAPNM, VAPADD1,VA PADD2,VAPC IT,VAPST,V APZIP,VAPN PI,VAPDEA, VAPLIC,VAP TEL,VAPFAX )=""
	5359	"RTN","PSO ERXR1",93, 0)
	5360	S MANVAL= $$GET1^DIQ (52.49,PSO IEN,1.3,"I ")
	5361	"RTN","PSO ERXR1",94, 0)
	5362	S VALBY=$ $GET1^DIQ( 52.49,PSOI EN,1.8,"E" )
	5363	"RTN","PSO ERXR1",95, 0)
	5364	S VALDTTM =$$GET1^DI Q(52.49,PS OIEN,1.9," E")
	5365	"RTN","PSO ERXR1",96, 0)
	5366	S LINE=LI NE+1 D SET ^VALM10(LI NE,"Status : "_$S(MAN VAL:"VALID ATED ("_VA LBY_" - "_ VALDTTM_") ",1:"NOT V ALIDATED") )
	5367	"RTN","PSO ERXR1",97, 0)
	5368	I 'VAPRVI EN S LINE= LINE+1 D S ET^VALM10( LINE,"PROV IDER NOT M ATCHED")
	5369	"RTN","PSO ERXR1",98, 0)
	5370	I VAPRVIE N D
	5371	"RTN","PSO ERXR1",99, 0)
	5372	.S VAPIEN S=VAPRVIEN _","
	5373	"RTN","PSO ERXR1",100 ,0)
	5374	.; 41.99 - NPI, 53. 2 - DEA, 5 4.2 - STAT E LICENSIN G DEA NUMB ER, .132 - OFFICE PH ONE, .136 - FAX
	5375	"RTN","PSO ERXR1",101 ,0)
	5376	.D GETS^D IQ(200,VAP IENS_","," .01;.111;. 112;.113;. 114;.115;. 116;.132;. 136;41.99; 53.2;54.2" ,"IE","VAP ROV")
	5377	"RTN","PSO ERXR1",102 ,0)
	5378	.S VAPNM= $G(VAPROV( 200,VAPIEN S,.01,"E") )
	5379	"RTN","PSO ERXR1",103 ,0)
	5380	.S VAPADD 1=$G(VAPRO V(200,VAPI ENS,.111," E"))
	5381	"RTN","PSO ERXR1",104 ,0)
	5382	.S VAPADD 2=$G(VAPRO V(200,VAPI ENS,.112," E"))
	5383	"RTN","PSO ERXR1",105 ,0)
	5384	.S VAPCIT =$G(VAPROV (200,VAPIE NS,.114,"E "))
	5385	"RTN","PSO ERXR1",106 ,0)
	5386	.S VAPST= $G(VAPROV( 200,VAPIEN S,.115,"E" ))
	5387	"RTN","PSO ERXR1",107 ,0)
	5388	.S VAPZIP =$G(VAPROV (200,VAPIE NS,.116,"E "))
	5389	"RTN","PSO ERXR1",108 ,0)
	5390	.S VAPNPI =$G(VAPROV (200,VAPIE NS,41.99," E"))
	5391	"RTN","PSO ERXR1",109 ,0)
	5392	.;*545
	5393	"RTN","PSO ERXR1",110 ,0)
	5394	.S VAPDEA =$$PRDEA^X USER(VAPIE NS)
	5395	"RTN","PSO ERXR1",111 ,0)
	5396	.S VAPDEA EX=$$PRXDT ^XUSER(VAP IENS) I VA PDEAEX,VAP DEAEX<DT S DEAEXP=1
	5397	"RTN","PSO ERXR1",112 ,0)
	5398	.S VAPLIC =$G(VAPROV (200,VAPIE NS,54.2,"E "))
	5399	"RTN","PSO ERXR1",113 ,0)
	5400	.S VAPTEL =$G(VAPROV (200,VAPIE NS,.132,"E "))
	5401	"RTN","PSO ERXR1",114 ,0)
	5402	.S VAPFAX =$G(VAPROV (200,VAPIE NS,.136,"E "))
	5403	"RTN","PSO ERXR1",115 ,0)
	5404	.S MANVAL =$$GET1^DI Q(52.49,PS OIEN,1.3," I")
	5405	"RTN","PSO ERXR1",116 ,0)
	5406	.S LINE=L INE+1 D SE T^VALM10(L INE,"Vista Provider: "_VAPNM)
	5407	"RTN","PSO ERXR1",117 ,0)
	5408	.S LINE=L INE+1 D SE T^VALM10(L INE,"Addre ss: "_$S($ L(VAPADD1) :VAPADD1,1 :"No stree t address on file.") )
	5409	"RTN","PSO ERXR1",118 ,0)
	5410	.I $L(VAP ADD2) S LI NE=LINE+1 D SET^VALM 10(LINE," "_ VAPADD2)
	5411	"RTN","PSO ERXR1",119 ,0)
	5412	.S LINE=L INE+1 D SE T^VALM10(L INE," "_VAPC IT_", "_VA PST_" "_VA PZIP)
	5413	"RTN","PSO ERXR1",120 ,0)
	5414	.S LINE=L INE+1
	5415	"RTN","PSO ERXR1",121 ,0)
	5416	.D ADDITE M^PSOERX1A (.LINETXT, "NPI: ",VA PNPI,1,26)
	5417	"RTN","PSO ERXR1",122 ,0)
	5418	.D ADDITE M^PSOERX1A (.LINETXT, "DEA: ",VA PDEA_$S($G (DEAEXP):" (Expired) ",1:""),28 ,26)
	5419	"RTN","PSO ERXR1",123 ,0)
	5420	.D SET^VA LM10(LINE, LINETXT) S LINETXT=" "
	5421	"RTN","PSO ERXR1",124 ,0)
	5422	.S LINE=L INE+1
	5423	"RTN","PSO ERXR1",125 ,0)
	5424	.D ADDITE M^PSOERX1A (.LINETXT, "Tel: ",VA PTEL,1,26)
	5425	"RTN","PSO ERXR1",126 ,0)
	5426	.D ADDITE M^PSOERX1A (.LINETXT, "Fax: ",VA PFAX,28,26 )
	5427	"RTN","PSO ERXR1",127 ,0)
	5428	.D SET^VA LM10(LINE, LINETXT) S LINETXT=" "
	5429	"RTN","PSO ERXR1",128 ,0)
	5430	S LINE=LI NE+1 D SET ^VALM10(LI NE,"")
	5431	"RTN","PSO ERXR1",129 ,0)
	5432	S VALMCNT =LINE
	5433	"RTN","PSO ERXR1",130 ,0)
	5434	S EDTYP=" PR"
	5435	"RTN","PSO ERXR1",131 ,0)
	5436	Q
	5437	"RTN","PSO ERXR1",132 ,0)
	5438	HELP ; -- help code
	5439	"RTN","PSO ERXR1",133 ,0)
	5440	S X="?" D DISP^XQOR M1 W !!
	5441	"RTN","PSO ERXR1",134 ,0)
	5442	Q
	5443	"RTN","PSO ERXR1",135 ,0)
	5444	;
	5445	"RTN","PSO ERXR1",136 ,0)
	5446	EXIT ; -- exit code
	5447	"RTN","PSO ERXR1",137 ,0)
	5448	K EDTYP,@ VALMAR
	5449	"RTN","PSO ERXR1",138 ,0)
	5450	Q
	5451	"RTN","PSO ERXR1",139 ,0)
	5452	;
	5453	"RTN","PSO ERXR1",140 ,0)
	5454	EXPND ; -- expand co de
	5455	"RTN","PSO ERXR1",141 ,0)
	5456	Q
	5457	"RTN","PSO HLDS1")
	5458	0^7^B48996 088
	5459	"RTN","PSO HLDS1",1,0 )
	5460	PSOHLDS1 ; BIR/LC,PWC -Build HL7 Segments for Automa ted Interf ace ; 2/5/ 10 10:01am
	5461	"RTN","PSO HLDS1",2,0 )
	5462	;;7.0;OUT PATIENT PH ARMACY;1 56,232,255 ,200,305,3 36,351,434 ,545;DEC 1997;Buil d 21
	5463	"RTN","PSO HLDS1",3,0 )
	5464	;HLFNC supp. by DBIA 10 106
	5465	"RTN","PSO HLDS1",4,0 )
	5466	;PSNAPIS supp. by DBIA 25 31
	5467	"RTN","PSO HLDS1",5,0 )
	5468	;VASITE supp. by DBIA 10 112
	5469	"RTN","PSO HLDS1",6,0 )
	5470	;VADPT supp. by DBIA 10 061
	5471	"RTN","PSO HLDS1",7,0 )
	5472	;EN^DIQ1 supp. by DBIA 10 0
	5473	"RTN","PSO HLDS1",8,0 )
	5474	;EN^VAFHL ZTA supp. by DBIA 75 8
	5475	"RTN","PSO HLDS1",9,0 )
	5476	;PSDRUG supp. by DBIA 22 1
	5477	"RTN","PSO HLDS1",10, 0)
	5478	;PS(50.60 7 supp. by DBIA 22 21
	5479	"RTN","PSO HLDS1",11, 0)
	5480	;PS(55 supp. by DBIA 22 28
	5481	"RTN","PSO HLDS1",12, 0)
	5482	;DPT supp. by DBIA 30 97
	5483	"RTN","PSO HLDS1",13, 0)
	5484	;SC supp. by DBIA 10 040
	5485	"RTN","PSO HLDS1",14, 0)
	5486	;VA(200 supp. by DBIA 10 060
	5487	"RTN","PSO HLDS1",15, 0)
	5488	;SCMSVUT5 supp. by DBIA 43 47
	5489	"RTN","PSO HLDS1",16, 0)
	5490	;BLDPID^V AFCQRY sup p. by DBIA 3630
	5491	"RTN","PSO HLDS1",17, 0)
	5492	;MAKEIT^V AFHLU sup p. by DBIA 4346
	5493	"RTN","PSO HLDS1",18, 0)
	5494	;
	5495	"RTN","PSO HLDS1",19, 0)
	5496	;*232 all ow for Do Not Mail
	5497	"RTN","PSO HLDS1",20, 0)
	5498	;*255 mov e NTEPMI t o PSOHLDS4 . fix "MP " node tes t to '=""
	5499	"RTN","PSO HLDS1",21, 0)
	5500	;*305 sen d Notice of Privacy Practices in NTE9 - Modified to NTE9 as NTE8 alre ady exist
	5501	"RTN","PSO HLDS1",22, 0)
	5502	;
	5503	"RTN","PSO HLDS1",23, 0)
	5504	START ;
	5505	"RTN","PSO HLDS1",24, 0)
	5506	D GETDATA
	5507	"RTN","PSO HLDS1",25, 0)
	5508	D PID(.PS I),PV1(.PS I),PV2(.PS I),IAM^PSO HLDS4(.PSI ),ORC^PSOH LDS4(.PSI)
	5509	"RTN","PSO HLDS1",26, 0)
	5510	D NTE^PSO HLDS2,RXE^ PSOHLDS2(. PSI),RXD^P SOHLDS2(.P SI)
	5511	"RTN","PSO HLDS1",27, 0)
	5512	D NTEPMI^ PSOHLDS4(. PSI),NTE9^ PSOHLDS2(. PSI),RXR^P SOHLDS2(.P SI) ; *255
	5513	"RTN","PSO HLDS1",28, 0)
	5514	; clean u p data set by GETDAT A
	5515	"RTN","PSO HLDS1",29, 0)
	5516	K EBY,EBY 1,EFDT,EXD T,FDT,PVDR ,PVDR1,CSI NER,CSINER 1,SITE,SIT ADD,SITPHN
	5517	"RTN","PSO HLDS1",30, 0)
	5518	K VPHARMI D,VPHARM,D EAID,MW,QT Y,DASPLY,O LAN,OTHLAN ,PRIORDT,R FRM,NFLD,W ARN
	5519	"RTN","PSO HLDS1",31, 0)
	5520	K PSOXN,P SOXN2,PSND 1,PSND2,PR ODUCT,PSOP ROD,UNIT,V ANAME,DISP DT,PSONDC
	5521	"RTN","PSO HLDS1",32, 0)
	5522	K DRUG
	5523	"RTN","PSO HLDS1",33, 0)
	5524	Q
	5525	"RTN","PSO HLDS1",34, 0)
	5526	GETDATA ; this is th e place to set all d ata needed for sever al segment s
	5527	"RTN","PSO HLDS1",35, 0)
	5528	I $G(FP)= "F"&('$G(F PN)) D ;original
	5529	"RTN","PSO HLDS1",36, 0)
	5530	. S FDT=$ P(^PSRX(IR XN,2),"^", 2),VPHARMI D=$P(^(2), "^",10),DI SPDT=$P(^( 2),"^",5), EXDT=$P(^( 2),"^",6), PSONDC=$P( ^(2),"^",7 )
	5531	"RTN","PSO HLDS1",37, 0)
	5532	. S PVDR= $P(^PSRX(I RXN,0),"^" ,4),QTY=$P (^(0),"^", 7),DASPLY= $P(^(0),"^ ",8),MW=$P (^(0),"^", 11),EBY=$P (^(0),"^", 16)
	5533	"RTN","PSO HLDS1",38, 0)
	5534	I $G(FP)= "F"&($G(FP N)) D ; refill
	5535	"RTN","PSO HLDS1",39, 0)
	5536	. S FDT=$ P(^PSRX(IR XN,1,FPN,0 ),"^"),MW= $P(^(0),"^ ",2),QTY=$ P(^(0),"^" ,4),DASPLY =$P(^(0)," ^",10),DIS PDT=$P(^(0 ),"^",19), EXDT=$S($P (^(0),"^", 15):$P(^(0 ),"^",15), 1:$P(^PSRX (IRXN,2)," ^",6))
	5537	"RTN","PSO HLDS1",40, 0)
	5538	. S VPHAR MID=$S($P( ^PSRX(IRXN ,1,FPN,0), "^",5)'="" :$P(^(0)," ^",5),1:$P (^PSRX(IRX N,2),"^",1 0))
	5539	"RTN","PSO HLDS1",41, 0)
	5540	. S EBY=$ S($P(^PSRX (IRXN,1,FP N,0),"^",5 ):$P(^(0), "^",5),1:$ P(^(0),"^" ,7)),PVDR= $P(^(0),"^ ",17),PSON DC=$S($P($ G(^PSRX(IR XN,1,FPN,1 )),"^",3): $P(^(1),"^ ",3),1:$P( ^PSRX(IRXN ,2),"^",7) )
	5541	"RTN","PSO HLDS1",42, 0)
	5542	I $G(FP)= "P"&($G(FP N)) D ;pa rtial
	5543	"RTN","PSO HLDS1",43, 0)
	5544	. S FDT=$ P(^PSRX(IR XN,"P",FPN ,0),"^"),M W=$P(^(0), "^",2),QTY =$P(^(0)," ^",4),DASP LY=$P(^(0) ,"^",10),D ISPDT=FDT, PVDR=$P(^( 0),"^",17) ,EXDT=$P(^ PSRX(IRXN, 2),"^",6)
	5545	"RTN","PSO HLDS1",44, 0)
	5546	. S EBY=$ S($P(^PSRX (IRXN,"P", FPN,0),"^" ,5):$P(^(0 ),"^",5),1 :$P(^(0)," ^",7)),VPH ARMID=$S($ P(^(0),"^" ,5)'="":$P (^(0),"^", 5),1:$P(^P SRX(IRXN,2 ),"^",10)) ,PVDR=$P(^ PSRX(IRXN, "P",FPN,0) ,"^",17)
	5547	"RTN","PSO HLDS1",45, 0)
	5548	. S PSOND C=$S($P(^P SRX(IRXN," P",FPN,0), "^",12):$P (^(0),"^", 12),1:$P(^ PSRX(IRXN, 2),"^",7))
	5549	"RTN","PSO HLDS1",46, 0)
	5550	S EFDT=$P (^PSRX(IRX N,2),"^",2 ) S:$G(EFD T) EFDT=$$ HLDATE^HLF NC(EFDT,"D T")
	5551	"RTN","PSO HLDS1",47, 0)
	5552	S ISDT=$P (^PSRX(IRX N,0),"^",1 3) S:$G(IS DT) ISDT=$ $HLDATE^HL FNC(ISDT," DT")
	5553	"RTN","PSO HLDS1",48, 0)
	5554	;*545
	5555	"RTN","PSO HLDS1",49, 0)
	5556	S DEAID=$ $PRDEA^XUS ER(PVDR)
	5557	"RTN","PSO HLDS1",50, 0)
	5558	K DIC,X,Y S DIC="^V A(200,",DI C(0)="N,Z" ,X=VPHARMI D D ^DIC
	5559	"RTN","PSO HLDS1",51, 0)
	5560	S VPHARM= $S(+Y:$$HL NAME^HLFNC ($P(Y,"^", 2)),1:"""" "") K DIC, X,Y
	5561	"RTN","PSO HLDS1",52, 0)
	5562	K DIC,X,Y S DIC="^V A(200,",DI C(0)="N,Z" ,X=EBY D ^ DIC
	5563	"RTN","PSO HLDS1",53, 0)
	5564	S EBY1=$S (+Y:$$HLNA ME^HLFNC($ P(Y,"^",2) ),1:"""""" ) K DIC,X, Y
	5565	"RTN","PSO HLDS1",54, 0)
	5566	K DIC,X,Y S DIC="^V A(200,",DI C(0)="N,Z" ,X=PVDR D ^DIC
	5567	"RTN","PSO HLDS1",55, 0)
	5568	S PVDR1=$ S(+Y:$$HLN AME^HLFNC( $P(Y,"^",2 )),1:""""" ") K DIC,X ,Y
	5569	"RTN","PSO HLDS1",56, 0)
	5570	S PRIORDT =$P(^PSRX( IRXN,3),"^ ",4),PRIOR DT=$$HLDAT E^HLFNC(PR IORDT,"DT" )
	5571	"RTN","PSO HLDS1",57, 0)
	5572	S FDT=$$H LDATE^HLFN C(FDT,"DT" )
	5573	"RTN","PSO HLDS1",58, 0)
	5574	S:$G(DISP DT) DISPDT =$$HLDATE^ HLFNC(DISP DT,"DT")
	5575	"RTN","PSO HLDS1",59, 0)
	5576	S:$G(EXDT ) EXDT=$$H LDATE^HLFN C(EXDT,"DT ")
	5577	"RTN","PSO HLDS1",60, 0)
	5578	S FIN=$P( ^PSRX(IRXN ,"OR1"),"^ ",5)
	5579	"RTN","PSO HLDS1",61, 0)
	5580	K DIC,X,Y S DIC="^V A(200,",DI C(0)="N,Z" ,X=FIN D ^ DIC
	5581	"RTN","PSO HLDS1",62, 0)
	5582	S FIN1=$S (+Y:$$HLNA ME^HLFNC($ P(Y,"^",2) ),1:"""""" ) K DIC,X, Y
	5583	"RTN","PSO HLDS1",63, 0)
	5584	S SITE=$S ($D(^PS(59 ,PSOSITE,0 )):^(0),1: "")
	5585	"RTN","PSO HLDS1",64, 0)
	5586	S PSZIP=$ P(SITE,"^" ,5) S PSOH ZIP=$S(PSZ IP["-":PSZ IP,1:$E(PS ZIP,1,5)_$ S($E(PSZIP ,6,9)]"":" -"_$E(PSZI P,6,9),1:" "))
	5587	"RTN","PSO HLDS1",65, 0)
	5588	S CLN=+$P (^PSRX(IRX N,0),"^",5 ),CLN1=$S( $D(^SC(CLN ,0)):$P(^( 0),"^",1), 1:"UNKNOWN ")
	5589	"RTN","PSO HLDS1",66, 0)
	5590	S CSINER= $P(^PSRX(I RXN,3),"^" ,3)
	5591	"RTN","PSO HLDS1",67, 0)
	5592	K DIC,X,Y S DIC="^V A(200,",DI C(0)="N,Z" ,X=CSINER D ^DIC
	5593	"RTN","PSO HLDS1",68, 0)
	5594	S CSINER1 =$S(+Y:$$H LNAME^HLFN C($P(Y,"^" ,2)),1:""" """) K DIC ,X,Y
	5595	"RTN","PSO HLDS1",69, 0)
	5596	D 6^VADPT
	5597	"RTN","PSO HLDS1",70, 0)
	5598	S X=$S($D (^PS(55,DF N,0)):^(0) ,1:""),CAP =$P(X,"^", 2)
	5599	"RTN","PSO HLDS1",71, 0)
	5600	D MW(X,.M W,.MP) ;PSO*232
	5601	"RTN","PSO HLDS1",72, 0)
	5602	I (($P(^P SRX(IRXN," STA"),"^") >0)&($P(^( "STA"),"^" )'=2)&('$G (PSODBQ))) !'$G(^PSRX (IRXN,"IB" )) S COPAY ="NO COPAY "
	5603	"RTN","PSO HLDS1",73, 0)
	5604	E S COPA Y="COPAY"
	5605	"RTN","PSO HLDS1",74, 0)
	5606	S NURSE=$ S($P($G(^D PT(DFN,"NH C")),"^")= "Y":1,$P($ G(^PS(55,D FN,40)),"^ "):1,1:0)
	5607	"RTN","PSO HLDS1",75, 0)
	5608	S DATE=$$ HLDATE^HLF NC(FDT) D NOW^%DTC S NOW=$$HLD ATE^HLFNC( %,"TS")
	5609	"RTN","PSO HLDS1",76, 0)
	5610	S OLAN=$P ($G(^PS(55 ,DFN,"LAN" )),"^",2), OTLAN="N" I OLAN=2 S OTLAN="Y"
	5611	"RTN","PSO HLDS1",77, 0)
	5612	S CSUB1=$ $GET1^DIQ( 50,IDGN_", ",3),CSUB= "N" I $E(C SUB1,1)>1& ($E(CSUB1, 1)<6) S CS UB="Y"
	5613	"RTN","PSO HLDS1",78, 0)
	5614	S SCTALK= +$G(^PS(55 ,"ASTALK", $P(^PSRX(I RXN,0),"^" ,2)))
	5615	"RTN","PSO HLDS1",79, 0)
	5616	K DIC,DR, DIQ S DA=$ P($$SITE^V ASITE(),"^ ") I DA D
	5617	"RTN","PSO HLDS1",80, 0)
	5618	.K PSOINS T S DIC=4, DIQ(0)="I" ,DR=99,DIQ ="PSOINST" D EN^DIQ1
	5619	"RTN","PSO HLDS1",81, 0)
	5620	.S PSOINS T=PSOINST( 4,DA,99,"I ") K DIC,D A,DR,DIQ,P SOINST(4)
	5621	"RTN","PSO HLDS1",82, 0)
	5622	S DRUG=$$ ZZ^PSOSUTL (IRXN),DEA =$P(^PSDRU G(IDGN,0), "^",3),WAR N=$P($G(^( 0)),"^",8)
	5623	"RTN","PSO HLDS1",83, 0)
	5624	S PSND1=$ P($G(^PSDR UG(IDGN,"N D")),"^"), PSND2=$P($ G(^("ND")) ,"^",2),PS ND3=$P($G( ^("ND"))," ^",3)
	5625	"RTN","PSO HLDS1",84, 0)
	5626	K PSOXN,P SOXN2,PSOP ROD
	5627	"RTN","PSO HLDS1",85, 0)
	5628	I PSND1,P SND3 D
	5629	"RTN","PSO HLDS1",86, 0)
	5630	.S PSOPRO D=$$PROD2^ PSNAPIS(PS ND1,PSND3) ,VANAME=$P ($G(PSOPRO D),"^",1)
	5631	"RTN","PSO HLDS1",87, 0)
	5632	.I $T(^PS NAPIS)]"" S PSOXN=$$ DFSU^PSNAP IS(PSND1,P SND3),UNIT =$P($G(PSO XN),"^",6) S PSOXN=$ P($G(PSOXN ),"^",5) S PSOXN2=$$ PROD2^PSNA PIS(PSND1, PSND3) Q
	5633	"RTN","PSO HLDS1",88, 0)
	5634	.S PSOXN2 =$G(^PSNDF (PSND1,5,P SND3,2))
	5635	"RTN","PSO HLDS1",89, 0)
	5636	.S PRODUC T=$G(^PSND F(PSND1,5, PSND3,0))
	5637	"RTN","PSO HLDS1",90, 0)
	5638	.I $G(PRO DUCT)'="" S PSOXN=+$ P($G(^PSND F(PSND1,2, +$P(PRODUC T,"^",2),3 ,+$P(PRODU CT,"^",3), 4,+$P(PROD UCT,"^",4) ,0)),"^"), UNIT=$P($G (^PS(50.60 7,PSOXN,0) ),"^")
	5639	"RTN","PSO HLDS1",91, 0)
	5640	S NFLD=0, UU="" F S UU=$O(^PS RX(IRXN,1, UU)) Q:UU= "" S:$D(^ PSRX(IRXN, 1,UU,0)) N FLD=NFLD+1
	5641	"RTN","PSO HLDS1",92, 0)
	5642	S NRFL=$P (^PSRX(IRX N,0),"^",9 ),RFRM=(NR FL-NFLD)
	5643	"RTN","PSO HLDS1",93, 0)
	5644	Q
	5645	"RTN","PSO HLDS1",94, 0)
	5646	PID(PSI) ; patient ID segment
	5647	"RTN","PSO HLDS1",95, 0)
	5648	Q:'$D(DFN )!$D(PAS)
	5649	"RTN","PSO HLDS1",96, 0)
	5650	S HLFS=HL 1("FS"),HL ECH=HL1("E CH"),HLQ=H L1("Q"),HL VER=HL1("V ER")
	5651	"RTN","PSO HLDS1",97, 0)
	5652	K PSPID,P SPID1
	5653	"RTN","PSO HLDS1",98, 0)
	5654	D BLDPID^ VAFCQRY(DF N,"","3,4, 5,7,8,11,1 3",.PSPID, .HL1,.ERR)
	5655	"RTN","PSO HLDS1",99, 0)
	5656	; put PID in format needed fo r segment parser
	5657	"RTN","PSO HLDS1",100 ,0)
	5658	S PSPID=P SPID(1) K PSPID(1)
	5659	"RTN","PSO HLDS1",101 ,0)
	5660	S (X,Y)=1 F S X=+$ O(PSPID(X) ) Q:'X S PSPID(Y)=P SPID(X),Y= Y+1 K PSPI D(X)
	5661	"RTN","PSO HLDS1",102 ,0)
	5662	;parse PI D into ind ividual fi elds
	5663	"RTN","PSO HLDS1",103 ,0)
	5664	K PRSEPID D SEGPRSE ^SCMSVUT5( "PSPID","P RSEPID",HL 1("FS"))
	5665	"RTN","PSO HLDS1",104 ,0)
	5666	; parse a ddress int o individu al compone nts
	5667	"RTN","PSO HLDS1",105 ,0)
	5668	K ADDSEQ D SEQPRSE^ SCMSVUT5($ NA(PRSEPID (11)),"ADD SEQ",HL1(" ECH"))
	5669	"RTN","PSO HLDS1",106 ,0)
	5670	; build Z TA (Tempor ary Addres s)
	5671	"RTN","PSO HLDS1",107 ,0)
	5672	K X2 S X2 =$$EN^VAFH LZTA(DFN," 1,2,3,4,5, 6,7,",1)
	5673	"RTN","PSO HLDS1",108 ,0)
	5674	; parse X 2 (ZTA) in to individ ual fields if temp a dd. exists
	5675	"RTN","PSO HLDS1",109 ,0)
	5676	D:'$$CHKT EMP^PSOBAI (DFN)
	5677	"RTN","PSO HLDS1",110 ,0)
	5678	. N BADA S BADA=$$C HKRX^PSOBA I(IRXN)
	5679	"RTN","PSO HLDS1",111 ,0)
	5680	. I $P(BA DA,"^"),'$ P(BADA,"^" ,2),ADDSEQ (1,7)'["VA B" S BADA= $$GET1^DIQ (2,DFN_"," ,.121,"I") S:BADA AD DSEQ(1,7)= "VAB"_BADA
	5681	"RTN","PSO HLDS1",112 ,0)
	5682	D:$$CHKTE MP^PSOBAI( DFN)
	5683	"RTN","PSO HLDS1",113 ,0)
	5684	. K PRSEZ TA D SEGPR SE^SCMSVUT 5("X2","PR SEZTA",HL1 ("FS"))
	5685	"RTN","PSO HLDS1",114 ,0)
	5686	. ; parse temporary address i nto indivi dual compo nents
	5687	"RTN","PSO HLDS1",115 ,0)
	5688	. K TMPAD D D SEQPRS E^SCMSVUT5 ($NA(PRSEZ TA(5)),"TM PADD",HL1( "ECH"))
	5689	"RTN","PSO HLDS1",116 ,0)
	5690	. ; add t emporary a ddress as next repit ition in P ID segment
	5691	"RTN","PSO HLDS1",117 ,0)
	5692	. S SPOT= 1+$O(ADDSE Q(""),-1)
	5693	"RTN","PSO HLDS1",118 ,0)
	5694	. M ADDSE Q(SPOT)=TM PADD(1)
	5695	"RTN","PSO HLDS1",119 ,0)
	5696	. S ADDSE Q(SPOT,7)= "C"
	5697	"RTN","PSO HLDS1",120 ,0)
	5698	. S ADDSE Q(SPOT,9)= PRSEZTA(6)
	5699	"RTN","PSO HLDS1",121 ,0)
	5700	. S ADDSE Q(SPOT,12, 1)=PRSEZTA (3)
	5701	"RTN","PSO HLDS1",122 ,0)
	5702	. S ADDSE Q(SPOT,12, 2)=PRSEZTA (4)
	5703	"RTN","PSO HLDS1",123 ,0)
	5704	. ;move a ddress seq uence back into pars e PID segm ent
	5705	"RTN","PSO HLDS1",124 ,0)
	5706	; rebuild PID segme nt
	5707	"RTN","PSO HLDS1",125 ,0)
	5708	K PRSEPID (11) M PRS EPID(11)=A DDSEQ
	5709	"RTN","PSO HLDS1",126 ,0)
	5710	K PSPID1 D MAKEIT^V AFHLU("PID ",.PRSEPID ,.PSPID1,. PSPID1)
	5711	"RTN","PSO HLDS1",127 ,0)
	5712	;put rebu ilt PID in to format used by $$ EN^VAFCQRY
	5713	"RTN","PSO HLDS1",128 ,0)
	5714	K PSPID S PSPID(1)= PSPID1
	5715	"RTN","PSO HLDS1",129 ,0)
	5716	S X=0,Y=2 F S X=+$ O(PSPID1(X )) Q:'X S PSPID(Y)= PSPID1(X) S Y=Y+1
	5717	"RTN","PSO HLDS1",130 ,0)
	5718	S CNT=0 F I=1:1 Q:' $D(PSPID(I )) D
	5719	"RTN","PSO HLDS1",131 ,0)
	5720	. I I=1 S ^TMP("PSO ",$J,PSI)= PSPID(I) Q
	5721	"RTN","PSO HLDS1",132 ,0)
	5722	. S CNT=C NT+1 S ^TM P("PSO",$J ,PSI,CNT)= PSPID(I)
	5723	"RTN","PSO HLDS1",133 ,0)
	5724	S PSI=PSI +1
	5725	"RTN","PSO HLDS1",134 ,0)
	5726	S PAS=1
	5727	"RTN","PSO HLDS1",135 ,0)
	5728	K PSPID,P SPID1,PRSE PID,PRSEZT A,SPOT,TMP ADD,ADDSEQ
	5729	"RTN","PSO HLDS1",136 ,0)
	5730	Q
	5731	"RTN","PSO HLDS1",137 ,0)
	5732	PV1(PSI) ; patient vi sit segmen t
	5733	"RTN","PSO HLDS1",138 ,0)
	5734	Q:'$D(DFN )!$D(PAS1)
	5735	"RTN","PSO HLDS1",139 ,0)
	5736	N PV1 ;h ardcoded t o letter O for Outpa tient (Pat ient class )
	5737	"RTN","PSO HLDS1",140 ,0)
	5738	S PV1="PV 1"_FS_FS_" O"_FS
	5739	"RTN","PSO HLDS1",141 ,0)
	5740	S ^TMP("P SO",$J,PSI )=PV1
	5741	"RTN","PSO HLDS1",142 ,0)
	5742	S PSI=PSI +1,PAS1=1
	5743	"RTN","PSO HLDS1",143 ,0)
	5744	Q
	5745	"RTN","PSO HLDS1",144 ,0)
	5746	PV2(PSI) ; patient vi sit segmen t (additio nal inform ation)
	5747	"RTN","PSO HLDS1",145 ,0)
	5748	;PATIENT STATUS AND COPAY
	5749	"RTN","PSO HLDS1",146 ,0)
	5750	Q:'$D(DFN )!$D(PAS2)
	5751	"RTN","PSO HLDS1",147 ,0)
	5752	N PV2 S P V2=""
	5753	"RTN","PSO HLDS1",148 ,0)
	5754	S $P(PV2, "\|",24)=$P ($G(^PS(53 ,+$P($G(^P SRX(IRXN,0 )),"^",3), 0)),"^",2) _"~"_COPAY _FS
	5755	"RTN","PSO HLDS1",149 ,0)
	5756	S ^TMP("P SO",$J,PSI )="PV2\|"_P V2
	5757	"RTN","PSO HLDS1",150 ,0)
	5758	S PSI=PSI +1,PAS2=1
	5759	"RTN","PSO HLDS1",151 ,0)
	5760	Q
	5761	"RTN","PSO HLDS1",152 ,0)
	5762	;
	5763	"RTN","PSO HLDS1",153 ,0)
	5764	MW(PS55,MW ,MP) ;Retu rn Mail/Wi ndow and M P expanded text ;PSO*232
	5765	"RTN","PSO HLDS1",154 ,0)
	5766	I MW="W"! (MW="") D ;* 255
	5767	"RTN","PSO HLDS1",155 ,0)
	5768	. S MP=$S ($P($G(^PS RX(IRXN,"M P")),"^")' ="":$P(^(" MP"),"^"), 1:"""""")
	5769	"RTN","PSO HLDS1",156 ,0)
	5770	. S MW="W INDOW"
	5771	"RTN","PSO HLDS1",157 ,0)
	5772	I MW="M" D
	5773	"RTN","PSO HLDS1",158 ,0)
	5774	. S MP="" """"
	5775	"RTN","PSO HLDS1",159 ,0)
	5776	. S PS55= $P(PS55,"^ ",3)
	5777	"RTN","PSO HLDS1",160 ,0)
	5778	. S MW=$S (PS55=1:"C ERTIFIED M AIL",PS55= 2:"DO NOT MAIL",1:"R EGULAR MAI L")
	5779	"RTN","PSO HLDS1",161 ,0)
	5780	Q
	5781	"RTN","PSO HLEXP")
	5782	0^25^B2403 7058
	5783	"RTN","PSO HLEXP",1,0 )
	5784	PSOHLEXP ; BIR/RTR-Au to expire prescripti ons ; 10/1 0/07 11:16 am
	5785	"RTN","PSO HLEXP",2,0 )
	5786	;;7.0;OUT PATIENT PH ARMACY;1 0,22,36,73 ,148,257,3 91,505,545 ;DEC 199 7;Build 21
	5787	"RTN","PSO HLEXP",3,0 )
	5788	;
	5789	"RTN","PSO HLEXP",4,0 )
	5790	;External reference to ^PS(59 .7 support ed by DBIA 694
	5791	"RTN","PSO HLEXP",5,0 )
	5792	;External reference to STATUS ^ORQOR2 is supported by DBIA 3 458
	5793	"RTN","PSO HLEXP",6,0 )
	5794	;External reference s to LOCK1 ^ORX2 and UNLK1^ORX2 are suppo rted by DB IA 867
	5795	"RTN","PSO HLEXP",7,0 )
	5796	EN N PSOEX RX,PSOEXCO M,PSOEXSTS ,SUSD,PSOE XSTA,ZZDT, ZZEDT,IFN, NODE,RF,PI FN,PSUSD,P RFDT,PDA,P SDTEST,ORN ,CPRSDC
	5797	"RTN","PSO HLEXP",8,0 )
	5798	I '$G(DT) S DT=$$DT ^XLFDT
	5799	"RTN","PSO HLEXP",9,0 )
	5800	S X1=DT,X 2=-1 D C^% DTC S ZZED T=X
	5801	"RTN","PSO HLEXP",10, 0)
	5802	S ZZDT=$P ($G(^PS(59 .7,1,49.99 )),"^",8) I +ZZDT=0 S X1=DT,X2 =-2 D C^%D TC S ZZDT= X
	5803	"RTN","PSO HLEXP",11, 0)
	5804	F S ZZDT =$O(^PSRX( "AG",ZZDT) ) Q:ZZDT>Z ZEDT Q:ZZ DT="" D E N1
	5805	"RTN","PSO HLEXP",12, 0)
	5806	D FACDEA
	5807	"RTN","PSO HLEXP",13, 0)
	5808	Q
	5809	"RTN","PSO HLEXP",14, 0)
	5810	EN1 F PSOE XRX=0:0 S PSOEXRX=$O (^PSRX("AG ",ZZDT,PSO EXRX)) Q:' PSOEXRX D :$D(^PSRX( PSOEXRX,0) )
	5811	"RTN","PSO HLEXP",15, 0)
	5812	.N CPRSDC ,CPRSSTA
	5813	"RTN","PSO HLEXP",16, 0)
	5814	.S CPRSDC =",1,7,12, 13,"
	5815	"RTN","PSO HLEXP",17, 0)
	5816	.S ORN=$P ($G(^PSRX( PSOEXRX,"O R1")),"^", 2),CPRSSTA =""
	5817	"RTN","PSO HLEXP",18, 0)
	5818	.I ORN S CPRSSTA=+$ $STATUS^OR QOR2(ORN) I CPRSSTA= 0 S ORN=""
	5819	"RTN","PSO HLEXP",19, 0)
	5820	.Q:$P($G( ^PSRX(PSOE XRX,2)),"^ ",6)'=ZZDT
	5821	"RTN","PSO HLEXP",20, 0)
	5822	.K CMOP S DA=PSOEXR X I DA D ^ PSOCMOPA ;*257 ;SET UP CMOP() ARRAY
	5823	"RTN","PSO HLEXP",21, 0)
	5824	.S DA=$O( ^PS(52.5," B",PSOEXRX ,0))
	5825	"RTN","PSO HLEXP",22, 0)
	5826	.I DA S S USD=$P($G( ^PS(52.5,D A,0)),"^", 2) I SUSD, $P($G(^(0) ),"^",3) S DIK="^PS( 52.5," D ^ DIK K DIK
	5827	"RTN","PSO HLEXP",23, 0)
	5828	.I $D(^PS (52.4,PSOE XRX,0)) S DIK="^PS(5 2.4,",DA=P SOEXRX D ^ DIK K DIK
	5829	"RTN","PSO HLEXP",24, 0)
	5830	.I $G(^PS RX(PSOEXRX ,"H"))]"" K:$P(^PSRX (PSOEXRX," H"),"^") ^ PSRX("AH", $P(^PSRX(P SOEXRX,"H" ),"^"),PSO EXRX) S ^P SRX(PSOEXR X,"H")=""
	5831	"RTN","PSO HLEXP",25, 0)
	5832	.S PSOEXS TA=$P($G(^ PSRX(PSOEX RX,"STA")) ,"^")
	5833	"RTN","PSO HLEXP",26, 0)
	5834	.I PSOEXS TA=13 D Q
	5835	"RTN","PSO HLEXP",27, 0)
	5836	..I 'ORN D EN^PSOHD R("PRES",P SOEXRX)
	5837	"RTN","PSO HLEXP",28, 0)
	5838	.I PSOEXS TA=12!(PSO EXSTA=14)! (PSOEXSTA= 15) I ORN, CPRSDC'[(" ,"_CPRSSTA _",") D
	5839	"RTN","PSO HLEXP",29, 0)
	5840	..D EN^PS OHLSN1(PSO EXRX,"OD", "","","A")
	5841	"RTN","PSO HLEXP",30, 0)
	5842	..I ORN S CPRSSTA=+ $$STATUS^O RQOR2(ORN)
	5843	"RTN","PSO HLEXP",31, 0)
	5844	.I PSOEXS TA=11 I OR N,CPRSDC'[ (","_CPRSS TA_",") D
	5845	"RTN","PSO HLEXP",32, 0)
	5846	..S $P(^P SRX(PSOEXR X,0),"^",1 9)=1
	5847	"RTN","PSO HLEXP",33, 0)
	5848	..D EN^PS OHLSN1(PSO EXRX,"SC", "ZE","Pres cription i s expired" )
	5849	"RTN","PSO HLEXP",34, 0)
	5850	.I PSOEXS TA>9&(PSOE XSTA'=16) Q
	5851	"RTN","PSO HLEXP",35, 0)
	5852	.S $P(^PS RX(PSOEXRX ,"STA"),"^ ")=11
	5853	"RTN","PSO HLEXP",36, 0)
	5854	.D REVERS E^PSOBPSU1 (PSOEXRX,0 ,"DE",5,"R X EXPIRED" )
	5855	"RTN","PSO HLEXP",37, 0)
	5856	.S (PIFN, PSUSD,PRFD T)=0 F S PIFN=$O(^P SRX(PSOEXR X,1,PIFN)) Q:'PIFN S PSUSD=PI FN,PRFDT=+ $P($G(^PSR X(PSOEXRX, 1,PIFN,0)) ,"^")
	5857	"RTN","PSO HLEXP",38, 0)
	5858	.S ORN=$P ($G(^PSRX( PSOEXRX,"O R1")),"^", 2)
	5859	"RTN","PSO HLEXP",39, 0)
	5860	.I $G(PSU SD) I '$P( $G(^PSRX(P SOEXRX,1,P SUSD,0))," ^",18) S P SDTEST=0 D I 'PSDTE ST K ^PSRX (PSOEXRX,1 ,PSUSD),^P SRX("AD",P RFDT,PSOEX RX,PSUSD), ^PSRX(PSOE XRX,1,"B", PRFDT,PSUS D) D NSET
	5861	"RTN","PSO HLEXP",40, 0)
	5862	..D REVER SE^PSOBPSU 1(PSOEXRX, PSUSD,"DE" ,5,"RX EXP IRED")
	5863	"RTN","PSO HLEXP",41, 0)
	5864	..F PDA=0 :0 S PDA=$ O(^PSRX(PS OEXRX,"L", PDA)) Q:'P DA I $P($ G(^PSRX(PS OEXRX,"L", PDA,0)),"^ ",2)=PSUSD S PSDTEST =1
	5865	"RTN","PSO HLEXP",42, 0)
	5866	..I $G(CM OP(CMOP("L ")))="",". L.X."[("." _$G(CMOP(" S"))_".") S PSDTEST= 1
	5867	"RTN","PSO HLEXP",43, 0)
	5868	..N PSOOR L
	5869	"RTN","PSO HLEXP",44, 0)
	5870	..S PSOOR L=$$LOCK1^ ORX2(ORN) S:'PSOORL PSDTEST=1 I PSOORL D UNLK1^ORX 2(ORN)
	5871	"RTN","PSO HLEXP",45, 0)
	5872	..N PDA0
	5873	"RTN","PSO HLEXP",46, 0)
	5874	..;S PDAQ =0
	5875	"RTN","PSO HLEXP",47, 0)
	5876	..F PDA=0 :0 S PDA=$ O(^PSRX(PS OEXRX,4,PD A)) Q:'PDA D
	5877	"RTN","PSO HLEXP",48, 0)
	5878	...S PDA0 =$G(^PSRX( PSOEXRX,4, PDA,0))
	5879	"RTN","PSO HLEXP",49, 0)
	5880	...I $P(P DA0,"^",3) =PSUSD S P SDTEST=1 ;*257
	5881	"RTN","PSO HLEXP",50, 0)
	5882	..;Q:'PDA Q
	5883	"RTN","PSO HLEXP",51, 0)
	5884	..;S PSDT EST=1
	5885	"RTN","PSO HLEXP",52, 0)
	5886	.I 'ORN D EN^PSOHDR ("PRES",PS OEXRX) Q
	5887	"RTN","PSO HLEXP",53, 0)
	5888	.I CPRSDC [(","_CPRS STA_",") D EN^PSOHDR ("PRES",PS OEXRX) Q
	5889	"RTN","PSO HLEXP",54, 0)
	5890	.S $P(^PS RX(PSOEXRX ,0),"^",19 )=1
	5891	"RTN","PSO HLEXP",55, 0)
	5892	.S PSOEXC OM="Prescr iption pas t expirati on date" D EN^PSOHLS N1(PSOEXRX ,"SC","ZE" ,PSOEXCOM)
	5893	"RTN","PSO HLEXP",56, 0)
	5894	S DIE=59. 7,DA=1,DR= "49.95///" _ZZDT D ^D IE K DIE,D A,DR
	5895	"RTN","PSO HLEXP",57, 0)
	5896	Q
	5897	"RTN","PSO HLEXP",58, 0)
	5898	NSET ;
	5899	"RTN","PSO HLEXP",59, 0)
	5900	N PSONM,P SONMX
	5901	"RTN","PSO HLEXP",60, 0)
	5902	S PSONM=" " F PSONMX =0:0 S PSO NMX=$O(^PS RX(PSOEXRX ,1,PSONMX) ) Q:'PSONM X S PSONM =PSONMX
	5903	"RTN","PSO HLEXP",61, 0)
	5904	S ^PSRX(P SOEXRX,1,0 )="^52.1DA ^"_$G(PSON M)_"^"_$G( PSONM)
	5905	"RTN","PSO HLEXP",62, 0)
	5906	Q
	5907	"RTN","PSO HLEXP",63, 0)
	5908	SETUP ;
	5909	"RTN","PSO HLEXP",64, 0)
	5910	K %DT,DIC ,DTOUT S D IC(0)="XZM ",DIC="^DI C(19.2,",X ="PSO EXPI RE PRESCRI PTIONS" D ^DIC
	5911	"RTN","PSO HLEXP",65, 0)
	5912	I +Y>0 D EDIT^XUTMO PT("PSO EX PIRE PRESC RIPTIONS") K DIC,Y,X Q
	5913	"RTN","PSO HLEXP",66, 0)
	5914	D RESCH^X UTMOPT("PS O EXPIRE P RESCRIPTIO NS","","", "24H","L") ,EDIT^XUTM OPT("PSO E XPIRE PRES CRIPTIONS" ) K DIC,Y, X
	5915	"RTN","PSO HLEXP",67, 0)
	5916	OUT Q
	5917	"RTN","PSO HLEXP",68, 0)
	5918	FACDEA ;3 91- Checks and notif ies PSDMGR group whe n facility DEA is ab out to exp ire. 505 - Modified test mess age; *545 - XU to PS O
	5919	"RTN","PSO HLEXP",69, 0)
	5920	N DIV,INA CT,SITE,DE A,DEAXDT,X MDUZ,XMY,X MTEXT,XMSU B,USR,TEXT
	5921	"RTN","PSO HLEXP",70, 0)
	5922	S DIV=0 F S DIV=$O (^PS(59,DI V)) Q:'DIV D
	5923	"RTN","PSO HLEXP",71, 0)
	5924	.S INACT= $P($G(^PS( 59,DIV,"I" )),"^") I INACT,DT>I NACT Q
	5925	"RTN","PSO HLEXP",72, 0)
	5926	.S SITE=$ P($G(^PS(5 9,DIV,"INI ")),"^") I SITE="" Q
	5927	"RTN","PSO HLEXP",73, 0)
	5928	.I '$$ACT IVE^XUAF4( SITE) Q
	5929	"RTN","PSO HLEXP",74, 0)
	5930	.S DEA=$$ WHAT^XUAF4 (SITE,52) I DEA="" Q
	5931	"RTN","PSO HLEXP",75, 0)
	5932	.S DEAXDT =$$GET1^DI Q(4,SITE,5 2.1,"I") I '+DEAXDT Q
	5933	"RTN","PSO HLEXP",76, 0)
	5934	.I $$FMDI FF^XLFDT(D EAXDT,DT)> 30 Q
	5935	"RTN","PSO HLEXP",77, 0)
	5936	.S DIV(SI TE)=DEA_"^ "_DEAXDT
	5937	"RTN","PSO HLEXP",78, 0)
	5938	S SITE=0 F S SITE= $O(DIV(SIT E)) Q:'SIT E D
	5939	"RTN","PSO HLEXP",79, 0)
	5940	.K TEXT
	5941	"RTN","PSO HLEXP",80, 0)
	5942	.S DEAXDT =$P(DIV(SI TE),"^",2)
	5943	"RTN","PSO HLEXP",81, 0)
	5944	.S TEXT(1 )=""
	5945	"RTN","PSO HLEXP",82, 0)
	5946	.S TEXT(2 )="The ins titutional (facility ) DEA Numb er for"
	5947	"RTN","PSO HLEXP",83, 0)
	5948	.S TEXT(3 )=$$GET1^D IQ(4,SITE, .01,"I")_" (Institut ion File # 4 IEN = "_ SITE_")"
	5949	"RTN","PSO HLEXP",84, 0)
	5950	.S TEXT(4 )=$S($$FMD IFF^XLFDT( DEAXDT,DT) <0:"expire d on ",1:" is about t o expire o n ")_$$GET 1^DIQ(4,SI TE,52.1,"E ")
	5951	"RTN","PSO HLEXP",85, 0)
	5952	.S TEXT(5 )=""
	5953	"RTN","PSO HLEXP",86, 0)
	5954	.S TEXT(6 )="Please update the Instituti onal DEA e xpiration date using option "
	5955	"RTN","PSO HLEXP",87, 0)
	5956	.S TEXT(7 )="Edit Fa cility DEA # and Expi ration Dat e [PSO EPC S EDIT DEA # AND XDAT E]. "
	5957	"RTN","PSO HLEXP",88, 0)
	5958	.S XMTEXT ="TEXT(",X MSUB="Inst itutional DEA Number "_$S($$FM DIFF^XLFDT (DEAXDT,DT )<0:"has e xpired",1: "is about to expire" ),XMDUZ=.5
	5959	"RTN","PSO HLEXP",89, 0)
	5960	.S USR="" F S USR= $O(^XUSEC( "PSDMGR",U SR)) Q:USR ="" S XMY (USR)=""
	5961	"RTN","PSO HLEXP",90, 0)
	5962	.D ^XMD
	5963	"RTN","PSO HLEXP",91, 0)
	5964	Q
	5965	"RTN","PSO HLSN1")
	5966	0^11^B7345 8285
	5967	"RTN","PSO HLSN1",1,0 )
	5968	PSOHLSN1 ; BIR/RTR - Send order info to O ERR from f ile 52 ;10 /10/94
	5969	"RTN","PSO HLSN1",2,0 )
	5970	;;7.0;OUT PATIENT PH ARMACY;1 ,10,24,27, 55,46,71,1 01,99,121, 139,157,18 1,143,235, 239,292,22 5,296,323, 545;DEC 1997;Build 21
	5971	"RTN","PSO HLSN1",3,0 )
	5972	;Ref #50. 606-DBIA 2 174
	5973	"RTN","PSO HLSN1",4,0 )
	5974	;#50.607- 2221
	5975	"RTN","PSO HLSN1",5,0 )
	5976	;#50.7-22 23
	5977	"RTN","PSO HLSN1",6,0 )
	5978	;#51.2-22 26
	5979	"RTN","PSO HLSN1",7,0 )
	5980	;#50-221
	5981	"RTN","PSO HLSN1",8,0 )
	5982	;PSNDF-21 95
	5983	"RTN","PSO HLSN1",9,0 )
	5984	;EN^PSSUT IL1-3179
	5985	"RTN","PSO HLSN1",10, 0)
	5986	;
	5987	"RTN","PSO HLSN1",11, 0)
	5988	EN(PSRXIEN ,STAT,PSST AT,COMM,PS NOO) ;
	5989	"RTN","PSO HLSN1",12, 0)
	5990	N COUNT,D FN,J,LIMIT ,NAME,NULL FLDS,PSDIE N,PSFLAG,P SND1,PSND2 ,PSND3,PRO DUCT,UNIT, POIPTR,PSO HINST,PODO SE,PODOSEN M,PSROUTE, RTNAME,SEG MENT,CCC,B BB,CSCOUNT ,PPTR,MSG, PSOHSTRT,P SOHSTOP,PS OHISSD,PSO RTLP,ZRXFL AG,RXE2FLA G,RXE2ONLY ,PSODFN,ED UZ
	5991	"RTN","PSO HLSN1",13, 0)
	5992	N PSOCDDU Z,DA,FSIG, BSIG,PSHRX ,PSHORX,PS NOOTX,ZPRE ,PSOZSTAT, CCCX,PSOCP S,PSOICD
	5993	"RTN","PSO HLSN1",14, 0)
	5994	K FIELD
	5995	"RTN","PSO HLSN1",15, 0)
	5996	I $G(STAT )="" Q
	5997	"RTN","PSO HLSN1",16, 0)
	5998	I STAT="C R"!(STAT=" DR")!(STAT ="HR")!(ST AT="OC")!( STAT="OD") !(STAT="OH ")!(STAT=" Z@")!(STAT ="RP") S P SOZSTAT=ST AT D DELP^ PSOHLSN S STAT=PSOZS TAT G SKIP
	5999	"RTN","PSO HLSN1",17, 0)
	6000	I STAT="S C" I $G(PS STAT)="ZE" !($G(PSSTA T)="HD")!( $G(PSSTAT) ="DC") S P SOZSTAT=ST AT D DELP^ PSOHLSN S STAT=PSOZS TAT
	6001	"RTN","PSO HLSN1",18, 0)
	6002	SKIP ;
	6003	"RTN","PSO HLSN1",19, 0)
	6004	I $G(STAT )="SC",$G( PSSTAT)="Z E",$P($G(^ PSRX(+$G(P SRXIEN),0) ),"^",19)= 2 Q
	6005	"RTN","PSO HLSN1",20, 0)
	6006	I $G(STAT )="RP" S S TAT="OD",P SSTAT="RP"
	6007	"RTN","PSO HLSN1",21, 0)
	6008	S COUNT=0 ,NULLFLDS= "F JJ=0:1: LIMIT S FI ELD(JJ)="" """
	6009	"RTN","PSO HLSN1",22, 0)
	6010	I '$D(^PS RX(PSRXIEN ,0)) Q
	6011	"RTN","PSO HLSN1",23, 0)
	6012	I ($G(STA T)="SC"&($ G(PSSTAT)= "ZE"))!($G (STAT)="OC ")!($G(STA T)="OD") I $D(^PS(52 .41,"AQ",P SRXIEN)) D EN^PSOHDR ("PRES",PS RXIEN) Q
	6013	"RTN","PSO HLSN1",24, 0)
	6014	I STAT'=" SN",STAT'= "ZC",'$P($ G(^PSRX(PS RXIEN,"OR1 ")),"^",2) Q
	6015	"RTN","PSO HLSN1",25, 0)
	6016	I $G(STAT )="SC",$G( PSSTAT)="Z E" S $P(^P SRX(PSRXIE N,0),"^",1 9)=2
	6017	"RTN","PSO HLSN1",26, 0)
	6018	D INIT
	6019	"RTN","PSO HLSN1",27, 0)
	6020	S COUNT=1 ,(ZRXFLAG, RXE2FLAG,R XE2ONLY)=0 D PID,PV1 ,ORC
	6021	"RTN","PSO HLSN1",28, 0)
	6022	I $G(STAT )="Z@" G N CM
	6023	"RTN","PSO HLSN1",29, 0)
	6024	I $G(STAT )="OK"!($G (STAT)="SN ")!($G(STA T)="ZC")!( $G(STAT)=" XX")!($G(S TAT)="SC") !($G(STAT) ="RO") D R XO,RXE,RXR ,ZRX,DG1,Z SC,ZCL G N CM
	6025	"RTN","PSO HLSN1",30, 0)
	6026	I $G(STAT )="SC",$G( PSSTAT)="C M" D RXO,R XE,RXR,ZRX ,DG1,ZSC,Z CL
	6027	"RTN","PSO HLSN1",31, 0)
	6028	I '$G(RXE 2FLAG) S R XE2ONLY=1 D RXE,SEGP ARX^PSOHLS N
	6029	"RTN","PSO HLSN1",32, 0)
	6030	I '$G(ZRX FLAG) D ZR X
	6031	"RTN","PSO HLSN1",33, 0)
	6032	NCM D SEND
	6033	"RTN","PSO HLSN1",34, 0)
	6034	K PSRXIEN Q
	6035	"RTN","PSO HLSN1",35, 0)
	6036	INIT K ^UT ILITY("DIQ 1",$J),DIQ S DA=$P($ $SITE^VASI TE(),"^") I $G(DA) S DIC=4,DIQ (0)="I",DR ="99" D EN ^DIQ1 S PS OHINST=$G( ^UTILITY(" DIQ1",$J,4 ,DA,99,"I" )) K ^UTIL ITY("DIQ1" ,$J),DA,DR ,DIQ,DIC
	6037	"RTN","PSO HLSN1",36, 0)
	6038	S MSG(1)= "MSH\|^~\&\| PHARMACY\|" _$G(PSOHIN ST)_"\|\|\|\|\| "_$S($G(PS OMSORR):"O RR",1:"ORM ")
	6039	"RTN","PSO HLSN1",37, 0)
	6040	Q
	6041	"RTN","PSO HLSN1",38, 0)
	6042	PID S LIMI T=5 X NULL FLDS
	6043	"RTN","PSO HLSN1",39, 0)
	6044	S DFN=+$P (^PSRX(PSR XIEN,0),"^ ",2) D DEM ^VADPT S N AME=$G(VAD M(1)) K VA DM
	6045	"RTN","PSO HLSN1",40, 0)
	6046	S FIELD(0 )="PID"
	6047	"RTN","PSO HLSN1",41, 0)
	6048	S FIELD(3 )=DFN
	6049	"RTN","PSO HLSN1",42, 0)
	6050	S FIELD(5 )=NAME
	6051	"RTN","PSO HLSN1",43, 0)
	6052	D SEG Q
	6053	"RTN","PSO HLSN1",44, 0)
	6054	DG1 D DG1^ PSOHLSN2
	6055	"RTN","PSO HLSN1",45, 0)
	6056	Q
	6057	"RTN","PSO HLSN1",46, 0)
	6058	PV1 ;
	6059	"RTN","PSO HLSN1",47, 0)
	6060	S LIMIT=1 9 X NULLFL DS
	6061	"RTN","PSO HLSN1",48, 0)
	6062	S FIELD(0 )="PV1"
	6063	"RTN","PSO HLSN1",49, 0)
	6064	S FIELD(2 )="O"
	6065	"RTN","PSO HLSN1",50, 0)
	6066	S:$P(^PSR X(PSRXIEN, 0),"^",5) FIELD(3)=$ P(^(0),"^" ,5)
	6067	"RTN","PSO HLSN1",51, 0)
	6068	D SEG Q
	6069	"RTN","PSO HLSN1",52, 0)
	6070	ORC ;
	6071	"RTN","PSO HLSN1",53, 0)
	6072	D ORC^PSO HLSN3
	6073	"RTN","PSO HLSN1",54, 0)
	6074	Q
	6075	"RTN","PSO HLSN1",55, 0)
	6076	;
	6077	"RTN","PSO HLSN1",56, 0)
	6078	RXO ;
	6079	"RTN","PSO HLSN1",57, 0)
	6080	S LIMIT=1 X NULLFLD S
	6081	"RTN","PSO HLSN1",58, 0)
	6082	S FIELD(0 )="RXO"
	6083	"RTN","PSO HLSN1",59, 0)
	6084	S PPTR=+$ P($G(^PSRX (PSRXIEN," OR1")),"^" )
	6085	"RTN","PSO HLSN1",60, 0)
	6086	S FIELD(1 )=$S('PPTR :"^^^^^",1 :"^^^"_PPT R_"^"_$P($ G(^PS(50.7 ,PPTR,0)), "^")_" "_$ P($G(^PS(5 0.606,+$P( $G(^(0))," ^",2),0)), "^")_"^99P SP")
	6087	"RTN","PSO HLSN1",61, 0)
	6088	D SEG Q
	6089	"RTN","PSO HLSN1",62, 0)
	6090	;
	6091	"RTN","PSO HLSN1",63, 0)
	6092	RXE ;
	6093	"RTN","PSO HLSN1",64, 0)
	6094	S RXE2FLA G=1
	6095	"RTN","PSO HLSN1",65, 0)
	6096	S LIMIT=$ S('$G(RXE2 ONLY):26,1 :2) X NULL FLDS
	6097	"RTN","PSO HLSN1",66, 0)
	6098	S FIELD(0 )="RXE"
	6099	"RTN","PSO HLSN1",67, 0)
	6100	S (PSOHST RT,PSOHSTO P)="" S X= $P($G(^PSR X(PSRXIEN, 2)),"^",2) I X S PSO HSTRT=$$FM THL7^XLFDT (X)
	6101	"RTN","PSO HLSN1",68, 0)
	6102	I '$G(DT) S DT=$$DT ^XLFDT
	6103	"RTN","PSO HLSN1",69, 0)
	6104	S X=$S($P ($G(^PSRX( PSRXIEN,3) ),"^",5):$ P($G(^(3)) ,"^",5),$G (STAT)="OD "!($G(STAT )="OC"):$G (DT),$P($G (^(2)),"^" ,6):$P($G( ^(2)),"^", 6),1:$G(DT )) I X S P SOHSTOP=$$ FMTHL7^XLF DT(X)
	6105	"RTN","PSO HLSN1",70, 0)
	6106	K X N PSO MZT,MMZZ,M MZZT S MMZ ZT=1 F MMZ Z=0:0 S MM ZZ=$O(^PSR X(PSRXIEN, 6,MMZZ)) Q :'MMZZ D: $D(^(MMZZ, 0))
	6107	"RTN","PSO HLSN1",71, 0)
	6108	.S FIELD( 1,MMZZT)=$ S($P($G(^P SRX(PSRXIE N,6,MMZZ,0 )),"^",2): $$ESC^ORHL ESC($P($G( ^(0)),"^") )_"\T\"_$P ($G(^PS(50 .607,+$P($ G(^(0)),"^ ",3),0))," ^")_"\T\"_ $P($G(^PSR X(PSRXIEN, 6,MMZZ,0)) ,"^",2)_"\ T\"_$P($G( ^(0)),"^", 4),1:"")
	6109	"RTN","PSO HLSN1",72, 0)
	6110	.S FIELD( 1,MMZZT)=F IELD(1,MMZ ZT)_"^"_$$ ESC^ORHLES C($P($G(^P SRX(PSRXIE N,6,MMZZ,0 )),"^",8))
	6111	"RTN","PSO HLSN1",73, 0)
	6112	.I $P($G( FIELD(1,MM ZZT)),"^") '="" F PSO MZT=1,3 I $E($P(FIEL D(1,MMZZT) ,"\T\",PSO MZT),1)=". " S $P(FIE LD(1,MMZZT ),"\T\",PS OMZT)="0"_ $P(FIELD(1 ,MMZZT),"\ T\",PSOMZT )
	6113	"RTN","PSO HLSN1",74, 0)
	6114	.S FIELD( 1,MMZZT)=$ G(FIELD(1, MMZZT))_"^ "_$$DUR(PS RXIEN,MMZZ )_"^^^^^"_ $S($P($G(F IELD(1,MMZ ZT)),"^")' ="":$P($G( FIELD(1,MM ZZT)),"\T\ ")_$P($G(F IELD(1,MMZ ZT)),"\T\" ,2),1:$P($ G(^PSRX(PS RXIEN,6,MM ZZ,0)),"^" ))
	6115	"RTN","PSO HLSN1",75, 0)
	6116	.S FIELD( 1,MMZZT)=$ G(FIELD(1, MMZZT))_"^ "_$P($G(^P SRX(PSRXIE N,6,MMZZ,0 )),"^",6)
	6117	"RTN","PSO HLSN1",76, 0)
	6118	.I $O(^PS RX(PSRXIEN ,6,MMZZ)) S FIELD(1, MMZZT)=$G( FIELD(1,MM ZZT))_"~"
	6119	"RTN","PSO HLSN1",77, 0)
	6120	.S MMZZT= MMZZT+1
	6121	"RTN","PSO HLSN1",78, 0)
	6122	S $P(FIEL D(1,1),"^" ,4)=$G(PSO HSTRT),$P( FIELD(1,$S (MMZZT>1:M MZZT-1,1:1 )),"^",5)= $G(PSOHSTO P)
	6123	"RTN","PSO HLSN1",79, 0)
	6124	S PSFLAG= 0,PSDIEN=+ $P(^PSRX(P SRXIEN,0), "^",6),PSN D1=$P($G(^ PSDRUG(PSD IEN,"ND")) ,"^"),PSND 2=$P($G(^( "ND")),"^" ,2),PSND3= $P($G(^("N D")),"^",3 ) I PSND1, PSND3 S PS FLAG=1
	6125	"RTN","PSO HLSN1",80, 0)
	6126	S FIELD(2 )=$S(PSFLA G:PSND1_". "_PSND3_"^ "_$$ESC^OR HLESC(PSND 2)_"^"_"99 NDF",1:"^^ ")_"^"_PSD IEN_"^"_$$ ESC^ORHLES C($P($G(^P SDRUG(PSDI EN,0)),"^" ))_"^"_"99 PSD"
	6127	"RTN","PSO HLSN1",81, 0)
	6128	Q:$G(RXE2 ONLY)
	6129	"RTN","PSO HLSN1",82, 0)
	6130	I PSFLAG D
	6131	"RTN","PSO HLSN1",83, 0)
	6132	.I $T(^PS NAPIS)]"" S PSOXN=$$ DFSU^PSNAP IS(PSND1,P SND3) S FI ELD(5)="^^ ^"_$P($G(P SOXN),"^", 5)_"^"_$$E SC^ORHLESC ($P($G(PSO XN),"^",6) )_"^"_"99P SU" K PSOX N Q
	6133	"RTN","PSO HLSN1",84, 0)
	6134	.S PRODUC T=$G(^PSND F(PSND1,5, PSND3,0)) S UNIT=$P( $G(^PSNDF( PSND1,2,+$ P(PRODUCT, "^",2),3,+ $P(PRODUCT ,"^",3),4, +$P(PRODUC T,"^",4),0 )),"^")
	6135	"RTN","PSO HLSN1",85, 0)
	6136	.S FIELD( 5)="^^^"_U NIT_"^"_$$ ESC^ORHLES C($P($G(^P S(50.607,+ UNIT,0))," ^"))_"^"_" 99PSU"
	6137	"RTN","PSO HLSN1",86, 0)
	6138	S POIPTR= $P($G(^PSR X(PSRXIEN, "OR1")),"^ ") I POIPT R S PODOSE =$P($G(^PS (50.7,POIP TR,0)),"^" ,2),PODOSE NM=$P($G(^ PS(50.606, +PODOSE,0) ),"^")
	6139	"RTN","PSO HLSN1",87, 0)
	6140	I POIPTR S FIELD(6) ="^^^"_$G( PODOSE)_"^ "_$$ESC^OR HLESC($G(P ODOSENM))_ "^"_"99PSF "
	6141	"RTN","PSO HLSN1",88, 0)
	6142	S FIELD(1 0)=$P(^PSR X(PSRXIEN, 0),"^",7)
	6143	"RTN","PSO HLSN1",89, 0)
	6144	S FIELD(1 2)=$P(^PSR X(PSRXIEN, 0),"^",9)
	6145	"RTN","PSO HLSN1",90, 0)
	6146	;*545 - s et RXE wit h the sele cted DEA#
	6147	"RTN","PSO HLSN1",91, 0)
	6148	I $G(PSRX IEN),$D(^T MP("PSORXN ",$J,PSRXI EN,"DEA")) S FIELD(1 3)=^TMP("P SORXN",$J, PSRXIEN,"D EA")
	6149	"RTN","PSO HLSN1",92, 0)
	6150	S FIELD(1 4)=$P(^PSR X(PSRXIEN, 0),"^",4)
	6151	"RTN","PSO HLSN1",93, 0)
	6152	S FIELD(1 5)=$P(^PSR X(PSRXIEN, 0),"^")
	6153	"RTN","PSO HLSN1",94, 0)
	6154	S FIELD(2 2)=$P(^PSR X(PSRXIEN, 0),"^",8)
	6155	"RTN","PSO HLSN1",95, 0)
	6156	K MMZZ S MMZZ=$$EN^ PSSUTIL1(P SDIEN) S F IELD(25)=$ S($E($P(MM ZZ,"\|"),1) =".":"0",1 :"")_$P(MM ZZ,"\|"),FI ELD(26)=$P (MMZZ,"\|", 2)
	6157	"RTN","PSO HLSN1",96, 0)
	6158	N PLIM,PV AR,PVAR1,S UBCOUNT D SEGPARX^PS OHLSN
	6159	"RTN","PSO HLSN1",97, 0)
	6160	;
	6161	"RTN","PSO HLSN1",98, 0)
	6162	I $O(^PSR X(PSRXIEN, "PRC",0)) D
	6163	"RTN","PSO HLSN1",99, 0)
	6164	.S COUNT= COUNT+1,CC C=$O(^PSRX (PSRXIEN," PRC",0))
	6165	"RTN","PSO HLSN1",100 ,0)
	6166	.S MSG(CO UNT)="NTE\| 6\|\|"_$$ESC ^ORHLESC($ G(^PSRX(PS RXIEN,"PRC ",CCC,0)))
	6167	"RTN","PSO HLSN1",101 ,0)
	6168	.S CSCOUN T=1 F CCC= CCC:0 S CC C=$O(^PSRX (PSRXIEN," PRC",CCC)) Q:'CCC S MSG(COUNT ,CSCOUNT)= $$ESC^ORHL ESC($G(^PS RX(PSRXIEN ,"PRC",CCC ,0))),CSCO UNT=CSCOUN T+1
	6169	"RTN","PSO HLSN1",102 ,0)
	6170	I $O(^PSR X(PSRXIEN, "INS1",0)) D
	6171	"RTN","PSO HLSN1",103 ,0)
	6172	.S COUNT= COUNT+1,CC C=$O(^PSRX (PSRXIEN," INS1",0))
	6173	"RTN","PSO HLSN1",104 ,0)
	6174	.S MSG(CO UNT)="NTE\| 7\|L\|"_$$ES C^ORHLESC( $G(^PSRX(P SRXIEN,"IN S1",CCC,0) ))
	6175	"RTN","PSO HLSN1",105 ,0)
	6176	.S CCCX=1 F S CCC= $O(^PSRX(P SRXIEN,"IN S1",CCC)) Q:'CCC I $D(^PSRX(P SRXIEN,"IN S1",CCC,0) ) S MSG(CO UNT,CCCX)= $$ESC^ORHL ESC($G(^(0 ))) S CCCX =CCCX+1
	6177	"RTN","PSO HLSN1",106 ,0)
	6178	S COUNT=C OUNT+1
	6179	"RTN","PSO HLSN1",107 ,0)
	6180	I $P($G(^ PSRX(PSRXI EN,"SIG")) ,"^",2) D Q
	6181	"RTN","PSO HLSN1",108 ,0)
	6182	.D FSIG^P SOUTLA("R" ,PSRXIEN,2 38) S MSG( COUNT)="NT E\|21\|\|"_$S ($G(FSIG(1 ))'="":$$E SC^ORHLESC ($G(FSIG(1 ))),1:"No SIG availa ble") I $O (FSIG(1)) F CCC=1:0 S CCC=$O(F SIG(CCC)) Q:'CCC S MSG(COUNT, (CCC-1))=$ $ESC^ORHLE SC($G(FSIG (CCC)))
	6183	"RTN","PSO HLSN1",109 ,0)
	6184	I '$P($G( ^PSRX(PSRX IEN,"SIG") ),"^",2) D Q
	6185	"RTN","PSO HLSN1",110 ,0)
	6186	.D EN3^PS OUTLA1(PSR XIEN,238) S MSG(COUN T)="NTE\|21 \|\|"_$S($G( BSIG(1))'= "":$$ESC^O RHLESC($G( BSIG(1))), 1:"No SIG available" ) I $O(BSI G(1)) F CC C=1:0 S CC C=$O(BSIG( CCC)) Q:'C CC S MSG( COUNT,(CCC -1))=$$ESC ^ORHLESC($ G(BSIG(CCC )))
	6187	"RTN","PSO HLSN1",111 ,0)
	6188	Q
	6189	"RTN","PSO HLSN1",112 ,0)
	6190	;
	6191	"RTN","PSO HLSN1",113 ,0)
	6192	RXR ;
	6193	"RTN","PSO HLSN1",114 ,0)
	6194	F PSORTLP =0:0 S PSO RTLP=$O(^P SRX(PSRXIE N,6,PSORTL P)) Q:'PSO RTLP D
	6195	"RTN","PSO HLSN1",115 ,0)
	6196	.S LIMIT= 1 X NULLFL DS
	6197	"RTN","PSO HLSN1",116 ,0)
	6198	.S FIELD( 0)="RXR"
	6199	"RTN","PSO HLSN1",117 ,0)
	6200	.S PSROUT E=$P($G(^P SRX(PSRXIE N,6,PSORTL P,0)),"^", 7) I PSROU TE,$D(^PS( 51.2,PSROU TE,0)) S RTNAME=$P( ^PS(51.2,P SROUTE,0), "^")
	6201	"RTN","PSO HLSN1",118 ,0)
	6202	.S FIELD( 1)="^^^"_$ G(PSROUTE) _"^"_$G(RT NAME)_"^"_ "99PSR"
	6203	"RTN","PSO HLSN1",119 ,0)
	6204	.D SEG
	6205	"RTN","PSO HLSN1",120 ,0)
	6206	Q
	6207	"RTN","PSO HLSN1",121 ,0)
	6208	;
	6209	"RTN","PSO HLSN1",122 ,0)
	6210	ZCL D ZCL^ PSOHLSN2
	6211	"RTN","PSO HLSN1",123 ,0)
	6212	Q
	6213	"RTN","PSO HLSN1",124 ,0)
	6214	ZSC D ZSC^ PSOHLSN2
	6215	"RTN","PSO HLSN1",125 ,0)
	6216	Q
	6217	"RTN","PSO HLSN1",126 ,0)
	6218	;
	6219	"RTN","PSO HLSN1",127 ,0)
	6220	ZRX ;
	6221	"RTN","PSO HLSN1",128 ,0)
	6222	S ZRXFLAG =1
	6223	"RTN","PSO HLSN1",129 ,0)
	6224	S LIMIT=6 X NULLFLD S
	6225	"RTN","PSO HLSN1",130 ,0)
	6226	S FIELD(0 )="ZRX"
	6227	"RTN","PSO HLSN1",131 ,0)
	6228	S ZPRE=$P ($G(^PSRX( PSRXIEN,"O R1")),"^", 3) I ZPRE S FIELD(1) =$P($G(^PS RX(ZPRE,"O R1")),"^", 2)
	6229	"RTN","PSO HLSN1",132 ,0)
	6230	I '$G(FIE LD(1)),$G( PSORDEDT) S FIELD(1) =$P($G(^PS (52.41,$G( PSORDEDT), 0)),"^")
	6231	"RTN","PSO HLSN1",133 ,0)
	6232	S FIELD(2 )=$G(PSNOO )
	6233	"RTN","PSO HLSN1",134 ,0)
	6234	I $G(STAT )="SN"!($G (STAT)="RO ") S FIELD (3)=$S($G( STAT)="RO" !($G(PSOED IT)):"E",$ G(PSOOPT)= 3:"R",1:"N ")
	6235	"RTN","PSO HLSN1",135 ,0)
	6236	S FIELD(4 )=$P(^PSRX (PSRXIEN,0 ),"^",11)
	6237	"RTN","PSO HLSN1",136 ,0)
	6238	S PSOCDDU Z=$S($G(PS OROPCH)="P ATCH":$P($ G(^PSRX(PS RXIEN,"OR1 ")),"^",5) ,$G(PSOHUI OR)&($P($G (^PSRX(PSR XIEN,"EXT" )),"^")'=" "):+$G(PSO CANRC),1:$ G(DUZ))
	6239	"RTN","PSO HLSN1",137 ,0)
	6240	I $G(PSOC DDUZ) S FI ELD(5)=PSO CDDUZ_"^"_ $P($G(^VA( 200,PSOCDD UZ,0)),"^" )_"^"_"99N P"
	6241	"RTN","PSO HLSN1",138 ,0)
	6242	I $G(STAT )="ZD",$G( PSODISPP) S FIELD(6) ="P"
	6243	"RTN","PSO HLSN1",139 ,0)
	6244	D SEG Q
	6245	"RTN","PSO HLSN1",140 ,0)
	6246	SEG S SEGM ENT="" F J =0:1:LIMIT S SEGMENT =$S(SEGMEN T="":FIELD (J),1:SEGM ENT_"\|"_FI ELD(J))
	6247	"RTN","PSO HLSN1",141 ,0)
	6248	S COUNT=C OUNT+1,MSG (COUNT)=SE GMENT
	6249	"RTN","PSO HLSN1",142 ,0)
	6250	Q
	6251	"RTN","PSO HLSN1",143 ,0)
	6252	SEND D:$G( PSRXIEN)&( $T(EN^PSOH DR)]"")&($ G(PSOSSMES )'="CPRSUP ") K FIEL D D MSG^XQ OR("PS EVS END OR",.M SG) Q
	6253	"RTN","PSO HLSN1",144 ,0)
	6254	.I $G(STA T)="ZC"!($ G(STAT)="U C")!($G(ST AT)="UD")! ($G(STAT)= "UH")!($G( STAT)="UR" )!($G(STAT )="DE")!($ G(STAT)="Z D")!($G(ST AT)="SN")! ($G(STAT)= "Z@") Q
	6255	"RTN","PSO HLSN1",145 ,0)
	6256	.I $G(STA T)="SC",$G (PSSTAT)=" ZZ" Q
	6257	"RTN","PSO HLSN1",146 ,0)
	6258	.D EN^PSO HDR("PRES" ,PSRXIEN)
	6259	"RTN","PSO HLSN1",147 ,0)
	6260	;
	6261	"RTN","PSO HLSN1",148 ,0)
	6262	NOO ;
	6263	"RTN","PSO HLSN1",149 ,0)
	6264	I $G(PSNO O)="" S PS NOOTX="" Q
	6265	"RTN","PSO HLSN1",150 ,0)
	6266	S PSNOOTX =$S(PSNOO= "W":"Writt en",PSNOO= "V":"Verba l",PSNOO=" P":"Teleph oned",PSNO O="S":"Ser vice Corre ction",PSN OO="X":"Re jected",PS NOO="D":"D uplicate", PSNOO="I": "Policy",P SNOO="E":" Physician Entered",P SNOO="A":" Auto DC",1 :"") Q
	6267	"RTN","PSO HLSN1",151 ,0)
	6268	Q
	6269	"RTN","PSO HLSN1",152 ,0)
	6270	;
	6271	"RTN","PSO HLSN1",153 ,0)
	6272	DUR(PSODX1 ,PSODX2) ;
	6273	"RTN","PSO HLSN1",154 ,0)
	6274	N PSODX,P SODX4,PSOD X5,PSODX6, PSODX7 S P SODX=$P($G (^PSRX(PSO DX1,6,PSOD X2,0)),"^" ,5)
	6275	"RTN","PSO HLSN1",155 ,0)
	6276	I 'PSODX Q PSODX
	6277	"RTN","PSO HLSN1",156 ,0)
	6278	S PSODX4= $L(PSODX), PSODX5=$E( PSODX,PSOD X4)
	6279	"RTN","PSO HLSN1",157 ,0)
	6280	S PSODX=$ S(PSODX5?1 A:PSODX,1: PSODX_"D")
	6281	"RTN","PSO HLSN1",158 ,0)
	6282	S PSODX6= $L(PSODX)
	6283	"RTN","PSO HLSN1",159 ,0)
	6284	S PSODX7= $E(PSODX,P SODX6)_$E( PSODX,1,(P SODX6-1))
	6285	"RTN","PSO HLSN1",160 ,0)
	6286	Q PSODX7
	6287	"RTN","PSO HLSN1",161 ,0)
	6288	Q
	6289	"RTN","PSO NEW")
	6290	0^18^B3368 4914
	6291	"RTN","PSO NEW",1,0)
	6292	PSONEW ;BI R/SAB - ne w rx order main driv er ;07/26/ 96
	6293	"RTN","PSO NEW",2,0)
	6294	;;7.0;OUT PATIENT PH ARMACY;1 1,27,32,46 ,94,130,26 8,225,251, 379,390,41 7,313,411, 545;DEC 1997;Build 21
	6295	"RTN","PSO NEW",3,0)
	6296	;External reference to UL^PSS LOCK suppo rted by DB IA 2789
	6297	"RTN","PSO NEW",4,0)
	6298	;External reference to $$L^PS SLOCK supp orted by D BIA 2789
	6299	"RTN","PSO NEW",5,0)
	6300	;External reference to ^VA(20 0 supporte d by DBIA 224
	6301	"RTN","PSO NEW",6,0)
	6302	;External reference to ^XUSEC ( supporte d by DBIA 10076
	6303	"RTN","PSO NEW",7,0)
	6304	;External reference to ^ORX1 supported by DBIA 21 86
	6305	"RTN","PSO NEW",8,0)
	6306	;External reference to ^ORX2 supported by DBIA 86 7
	6307	"RTN","PSO NEW",9,0)
	6308	;External reference to ^TIUED IT support ed by DBIA 2410
	6309	"RTN","PSO NEW",10,0)
	6310	;External reference to ^DD("D ILOCKTM" s upported b y DBIA 999
	6311	"RTN","PSO NEW",11,0)
	6312	;-------- ---------- ---------- ---------- ---------- ---------- -----
	6313	"RTN","PSO NEW",12,0)
	6314	OERR ;back door new r x for v7
	6315	"RTN","PSO NEW",13,0)
	6316	K PSOREED T,COPY,SPE ED,PSOEDIT ,DUR,DRET, PSOTITRX,P SOMTFLG N PSOCKCON,P SODAOC
	6317	"RTN","PSO NEW",14,0)
	6318	S PSOPLCK =$$L^PSSLO CK(PSODFN, 0) I '$G(P SOPLCK) D LOCK^PSOOR CPY S VALM SG=$S($P($ G(PSOPLCK) ,"^",2)'=" ":$P($G(PS OPLCK),"^" ,2)_" is w orking on this patie nt.",1:"An other pers on is ente ring order s for this patient." ) K PSOPLC K S VALMBC K="" Q
	6319	"RTN","PSO NEW",15,0)
	6320	K PSOPLCK S X=PSODF N_";DPT(" D LK^ORX2 I 'Y S VAL MSG="Anoth er person is enterin g orders f or this pa tient.",VA LMBCK="" D UL^PSSLOC K(PSODFN) Q
	6321	"RTN","PSO NEW",16,0)
	6322	AGAIN N VA LMCNT K PS ODRUG,PSOC OU,PSOCOUU ,PSONOOR,P SORX("FN") ,PSORX("DF LG"),PSOQU IT,POERR S PSORX("DF LG")=0
	6323	"RTN","PSO NEW",17,0)
	6324	W ! D HLD HDR^PSOLMU TL S (PSON EW("QFLG") ,PSONEW("D FLG"),PSOQ UIT)=0,PSO FROM="NEW" ,PSONOEDT= 1
	6325	"RTN","PSO NEW",18,0)
	6326	K ORD D F ULL^VALM1, ^PSONEW1 ; Continue order entr y
	6327	"RTN","PSO NEW",19,0)
	6328	I PSONEW( "QFLG") G END
	6329	"RTN","PSO NEW",20,0)
	6330	I PSONEW( "DFLG") W !,$C(7),"R X DELETED" ,! S:$G(PO ERR) POERR ("DFLG")=1 ,VALMBCK=" Q" G END
	6331	"RTN","PSO NEW",21,0)
	6332	D:$P($G(P SOPAR),"^" ,7)=1 AUTO ^PSONRXN I $P($G(PSO PAR),"^",7 )'=1 S PSO X=PSONEW(" RX #") D C HECK^PSONR XN
	6333	"RTN","PSO NEW",22,0)
	6334	I PSONEW( "DFLG")!PS ONEW("QFLG ") D DEL S :$G(POERR) POERR("DF LG")=1,VAL MBCK="R" G END
	6335	"RTN","PSO NEW",23,0)
	6336	D NOOR I PSONEW("DF LG") D DEL G END
	6337	"RTN","PSO NEW",24,0)
	6338	D ^PSONEW 2 I PSONEW ("DFLG") D DEL S:$G( POERR) POE RR("DFLG") =1,VALMBCK ="R" G END ; Asks if correct
	6339	"RTN","PSO NEW",25,0)
	6340	G:$G(PSOR X("FN")) E ND
	6341	"RTN","PSO NEW",26,0)
	6342	D EN^PSON 52(.PSONEW ) ; Files entry in F ile 52
	6343	"RTN","PSO NEW",27,0)
	6344	D NPSOSD^ PSOUTIL(.P SONEW) ; A dds newly added rx t o PSOSD ar ray
	6345	"RTN","PSO NEW",28,0)
	6346	S VALMBCK ="R"
	6347	"RTN","PSO NEW",29,0)
	6348	;
	6349	"RTN","PSO NEW",30,0)
	6350	; - Possi ble Titrat ion prescr iption
	6351	"RTN","PSO NEW",31,0)
	6352	I $G(PSON EW("IRXN") ) D MARK^P SOOTMRX(PS ONEW("IRXN "),0)
	6353	"RTN","PSO NEW",32,0)
	6354	;
	6355	"RTN","PSO NEW",33,0)
	6356	END D EOJ ; Clean up
	6357	"RTN","PSO NEW",34,0)
	6358	I '$G(PSO RX("FN")) W ! K DIR, DIRUT,DUOU T,DTOUT S DIR(0)="Y" ,DIR("B")= "YES",DIR( "A")="Anot her New Or der for "_ PSORX("NAM E") D ^DIR K DIR,DIR UT,DUOUT,D TOUT I Y K PSONEW,PS DRUG,ORD G AGAIN
	6359	"RTN","PSO NEW",35,0)
	6360	D ^PSOBUI LD,BLD^PSO ORUT1 S X= PSODFN_";D PT(" D ULK ^ORX2 D UL ^PSSLOCK(P SODFN)
	6361	"RTN","PSO NEW",36,0)
	6362	D RV^PSOO RFL
	6363	"RTN","PSO NEW",37,0)
	6364	S VALMBCK ="R" K PSO RX("FN") Q
	6365	"RTN","PSO NEW",38,0)
	6366	;-------- ---------- ---------- ---------- ---------- ---------- ------
	6367	"RTN","PSO NEW",39,0)
	6368	DEL ;
	6369	"RTN","PSO NEW",40,0)
	6370	W !,$C(7) ,"RX DELET ED",!
	6371	"RTN","PSO NEW",41,0)
	6372	I $P($G(P SOPAR),"^" ,7)=1 D
	6373	"RTN","PSO NEW",42,0)
	6374	. S DIE=" ^PS(59,",D A=PSOSITE, PSOY=$O(PS ONEW("OLD LAST RX#", ""))
	6375	"RTN","PSO NEW",43,0)
	6376	. S PSOX= PSONEW("OL D LAST RX# ",PSOY)
	6377	"RTN","PSO NEW",44,0)
	6378	. L +^PS( 59,+PSOSIT E,PSOY):$S (+$G(^DD(" DILOCKTM") )>0:+^DD(" DILOCKTM") ,1:3)
	6379	"RTN","PSO NEW",45,0)
	6380	. S DR=$S (PSOY=8:"2 003////"_P SOX,PSOY=3 :"1002.1// //"_PSOX,1 :"2003//// "_PSOX)
	6381	"RTN","PSO NEW",46,0)
	6382	. D:PSOX< $P(^PS(59, +PSOSITE,P SOY),"^",3 ) ^DIE K D IE,X,Y
	6383	"RTN","PSO NEW",47,0)
	6384	. L -^PS( 59,+PSOSIT E,PSOY)
	6385	"RTN","PSO NEW",48,0)
	6386	. K PSOX, PSOY Q
	6387	"RTN","PSO NEW",49,0)
	6388	EOJ ;
	6389	"RTN","PSO NEW",50,0)
	6390	I $D(PSON EW("RX #") ) L -^PSRX ("B",PSONE W("RX #")) ; +Lock s et in PSON RXN
	6391	"RTN","PSO NEW",51,0)
	6392	K PSONOED T,PSONEW,P SODRUG,ANQ DATA,LSI,C ,MAX,MIN,N DF,REF,SIG ,SER,PSOFL AG,PSOHI,P SOLO,PSONO OR,PSOCOUU ,PSOCOU,PS ORX("EDIT" ),ZNEW
	6393	"RTN","PSO NEW",52,0)
	6394	D CLEAN^P SOVER1
	6395	"RTN","PSO NEW",53,0)
	6396	K ^TMP("P SORXDC",$J ),RORD,ACO M,ACNT,CRI T,DEF,F1,G G,I1,IEN,I NDT,LAST,M SG,NIEN,ST A,DUR,DRET ,PSOPRC,PS ORX("RXDEA "),PSORX(" DETX") ;*5 45
	6397	"RTN","PSO NEW",54,0)
	6398	S (ZRXN,R XN)=$O(^TM P("PSORXN" ,$J,0)) I RXN D
	6399	"RTN","PSO NEW",55,0)
	6400	.S RXN1=^ TMP("PSORX N",$J,RXN) D EN^PSOH LSN1(RXN,$ P(RXN1,"^" ),$P(RXN1, "^",2),"", $P(RXN1,"^ ",3))
	6401	"RTN","PSO NEW",56,0)
	6402	.I $P(^PS RX(RXN,"ST A"),"^")=5 D EN^PSOH LSN1(RXN," SC","ZS"," ")
	6403	"RTN","PSO NEW",57,0)
	6404	.;saves d rug allerg y order ch ks pso73 90
	6405	"RTN","PSO NEW",58,0)
	6406	.I $D(^TM P("PSODAOC ",$J)) D
	6407	"RTN","PSO NEW",59,0)
	6408	..S RXN=Z RXN,PSODAO C="Rx Back door "_$S( $P(^PSRX(R XN,"STA"), "^")=4:"NO N-VERIFIED ",1:"")_" NEW Order Acceptance _OP",ZNEW= 1
	6409	"RTN","PSO NEW",60,0)
	6410	.D DAOC
	6411	"RTN","PSO NEW",61,0)
	6412	K ZRXN,RX N,RXN1,^TM P("PSORXN" ,$J),^TMP( "PSODAOC", $J),RET,PS ODAOC,ZNEW
	6413	"RTN","PSO NEW",62,0)
	6414	I $G(PSON OTE) D FUL L^VALM1,MA IN^TIUEDIT (3,.TIUDA, PSODFN,"", "","","",1 )
	6415	"RTN","PSO NEW",63,0)
	6416	K PSONOTE ,PSOCKCON, ZZCOPY
	6417	"RTN","PSO NEW",64,0)
	6418	Q
	6419	"RTN","PSO NEW",65,0)
	6420	NOOR ;asks nature of order
	6421	"RTN","PSO NEW",66,0)
	6422	N PSONOOD F
	6423	"RTN","PSO NEW",67,0)
	6424	S PSONOOD F=0
	6425	"RTN","PSO NEW",68,0)
	6426	I $G(OR0) D G NOOR X ;front d oor
	6427	"RTN","PSO NEW",69,0)
	6428	.S PSOI=$ S($G(PSOSI GFL):1,$G( PSODRUG("O I"))'=$P(O R0,"^",8): 1,1:0) I ' PSOI S PSO NOOR="" D: $D(^XUSEC( "PSORPH",D UZ)) COUN Q ;NoO $P (OR0,"^",7 )
	6429	"RTN","PSO NEW",70,0)
	6430	.S PSONOO DF=1
	6431	"RTN","PSO NEW",71,0)
	6432	.D DIR I $D(DIRUT) S PSONEW(" DFLG")=1 Q
	6433	"RTN","PSO NEW",72,0)
	6434	.S PSONOO R=Y D:$D(^ XUSEC("PSO RPH",DUZ)) COUN K DI R,DTOUT,DT OUT,DIRUT
	6435	"RTN","PSO NEW",73,0)
	6436	;backdoor order
	6437	"RTN","PSO NEW",74,0)
	6438	D DIR I $ D(DIRUT) S PSONEW("D FLG")=1,VA LMBCK="Q" Q
	6439	"RTN","PSO NEW",75,0)
	6440	S PSONOOR =Y K DIK,D A,DIE,DR,P SOI,DIR,DU OUT,DTOUT, DIRUT
	6441	"RTN","PSO NEW",76,0)
	6442	G:'$D(^XU SEC("PSORP H",DUZ)) N OORX
	6443	"RTN","PSO NEW",77,0)
	6444	COUN ;pati ent counse ling
	6445	"RTN","PSO NEW",78,0)
	6446	G:$G(PSOR X("EDIT")) &('$G(PSOS IGFL)) NOO RX K DIR,D UOUT,DTOUT ,DIRUT
	6447	"RTN","PSO NEW",79,0)
	6448	S DIR("B" )="NO",DIR (0)="52,41 " D ^DIR S PSOCOU=$S (Y:Y,1:0)
	6449	"RTN","PSO NEW",80,0)
	6450	I $D(DIRU T)!('PSOCO U) S PSOCO UU=0 D:'$G (SPEED) PR ONTE Q
	6451	"RTN","PSO NEW",81,0)
	6452	K:'$G(PSO COU) PSOCO UU K DIR,D UOUT,DTOUT ,DIRUT I Y S DIR(0)= "52,42",DI R("B")="NO " D ^DIR S PSOCOUU=$ S(Y:Y,1:0)
	6453	"RTN","PSO NEW",82,0)
	6454	PRONTE K P SONOTE,DIR ,DIRUT,DUO UT
	6455	"RTN","PSO NEW",83,0)
	6456	I $T(MAIN ^TIUEDIT)] "",'$G(SPE ED) D K D IR,DIRUT,D UOUT
	6457	"RTN","PSO NEW",84,0)
	6458	.S DIR(0) ="Y",DIR(" B")="No",D IR("A")="D o you want to enter a Progress Note",DIR ("A",1)="" D ^DIR K DIR
	6459	"RTN","PSO NEW",85,0)
	6460	.S PSONOT E=+Y Q ;I 'Y!($D(DI RUT)) Q
	6461	"RTN","PSO NEW",86,0)
	6462	NOORX K X, Y,DIR,DUOU T,DTOUT,DI RUT
	6463	"RTN","PSO NEW",87,0)
	6464	Q
	6465	"RTN","PSO NEW",88,0)
	6466	DIR ;ask n ature of o rder
	6467	"RTN","PSO NEW",89,0)
	6468	K DIR,DTO UT,DTOUT,D IRUT I $T( NA^ORX1)]" " D Q
	6469	"RTN","PSO NEW",90,0)
	6470	.S PSONOO R=$$NA^ORX 1($S($G(PS ONOODF)!($ G(PSONOBCK )):"S",1:" W"),0,"B", "Nature of Order",0, "WPSDIVR"_ $S(+$G(^VA (200,DUZ," PS")):"E", 1:""))
	6471	"RTN","PSO NEW",91,0)
	6472	.I +PSONO OR S (Y,PS ONOOR)=$P( PSONOOR,"^ ",3) Q
	6473	"RTN","PSO NEW",92,0)
	6474	.S DIRUT= 1 K PSONOO R
	6475	"RTN","PSO NEW",93,0)
	6476	I $D(PSON OOR) S DF= PSONOOR,PS ONODF=$S(D F="E":"PRO VIDER ENTE RED",DF="V ":"VERBAL" ,DF="P":"T ELEPHONE", DF="D":"DU PLICATE",D F="S":"SER VICE CORRE CTED",DF=" I":"POLICY ",DF="R":" SERVICE RE JECTED",1: "WRITTEN")
	6477	"RTN","PSO NEW",94,0)
	6478	K DIR,DTO UT,DTOUT,D IRUT S DIR ("A")="Nat ure of Ord er: ",DIR( "B")=$S($D (PSONOOR): PSONODF,1: "WRITTEN")
	6479	"RTN","PSO NEW",95,0)
	6480	S DIR(0)= "SA^W:WRIT TEN;V:VERB AL;P:TELEP HONE;S:SER VICE CORRE CTED;D:DUP LICATE;I:P OLICY;R:SE RVICE REJE CTED"_$S(+ $G(^VA(200 ,DUZ,"PS") ):";E:PROV IDER ENTER ED",1:"")
	6481	"RTN","PSO NEW",96,0)
	6482	D ^DIR K DF,PSONODF Q:$D(DIRU T) S PSON OOR=Y
	6483	"RTN","PSO NEW",97,0)
	6484	DIRX Q
	6485	"RTN","PSO NEW",98,0)
	6486	;
	6487	"RTN","PSO NEW",99,0)
	6488	NOORE(PSON EW) ;entry point for renew
	6489	"RTN","PSO NEW",100,0 )
	6490	D NOOR I $D(DIRUT) S PSONEW(" DFLG")=1 Q
	6491	"RTN","PSO NEW",101,0 )
	6492	S PSONEW( "NOO")=PSO NOOR
	6493	"RTN","PSO NEW",102,0 )
	6494	Q
	6495	"RTN","PSO NEW",103,0 )
	6496	DAOC ;adds all backd oor order checks to file 100.0 5.
	6497	"RTN","PSO NEW",104,0 )
	6498	D ^PSONEW OC K ^TMP( "PSODAOC", $J),PSRDI
	6499	"RTN","PSO NEW",105,0 )
	6500	Q
	6501	"RTN","PSO ORED1")
	6502	0^12^B7855 7804
	6503	"RTN","PSO ORED1",1,0 )
	6504	PSOORED1 ; ISC-BHAM/S AB - edit orders fro m backdoor ;5/10/07 8:25am
	6505	"RTN","PSO ORED1",2,0 )
	6506	;;7.0;OUT PATIENT PH ARMACY;5 ,23,46,78, 114,117,13 1,146,223, 148,244,24 9,268,206, 313,444,42 2,545;DE C 1997;Bui ld 21
	6507	"RTN","PSO ORED1",3,0 )
	6508	;External reference ^PS(55 su pported by DBIA 2228
	6509	"RTN","PSO ORED1",4,0 )
	6510	;External reference ^PS(50.7 supported by DBIA 22 23
	6511	"RTN","PSO ORED1",5,0 )
	6512	;
	6513	"RTN","PSO ORED1",6,0 )
	6514	;*244 cal l to remov e DC'd Rx' s from Rx ien string s
	6515	"RTN","PSO ORED1",7,0 )
	6516	;
	6517	"RTN","PSO ORED1",8,0 )
	6518	EN(PSORENW ) ;
	6519	"RTN","PSO ORED1",9,0 )
	6520	N LST,ORD ,ORN K VAL MBCK,PSORX ("FN") S P SOAC=1,(PS ORX("QFLG" ),PSORX("D FLG"))=0 ; D DREN^PSO ORNW2,INIT
	6521	"RTN","PSO ORED1",10, 0)
	6522	D INIT
	6523	"RTN","PSO ORED1",11, 0)
	6524	D @$S($P( PSOPAR,"^" ,7):"AUTO^ PSONRXN",1 :"MANUAL^P SONRXN")
	6525	"RTN","PSO ORED1",12, 0)
	6526	I '$D(PSO NEW("RX #" )),'$P(PSO PAR,"^",7) D PAUSE^V ALM1 K VAL MSG,PSONEW ("QFLG") S VALMBCK=" Q" Q
	6527	"RTN","PSO ORED1",13, 0)
	6528	I '$D(PSO NEW("RX #" )) K VALMS G D DEL^PS ONEW,PAUSE ^VALM1 S V ALMBCK="Q" Q
	6529	"RTN","PSO ORED1",14, 0)
	6530	S PSORENW ("RX #")=P SONEW("RX #") I '$P( PSOPAR,"^" ,7) D Q:$ G(PSONEW(" DFLG"))!($ G(PSONEW(" QFLG")))
	6531	"RTN","PSO ORED1",15, 0)
	6532	.S PSOX=P SORENW("RX #") D CHE CK^PSONRXN
	6533	"RTN","PSO ORED1",16, 0)
	6534	I $G(PSON EW("DFLG") )!$G(PSONE W("QFLG")) D DEL^PSO NEW,PAUSE^ VALM1 S VA LMBCK="Q" K PSORENW Q
	6535	"RTN","PSO ORED1",17, 0)
	6536	D EN^PSOO RNE1(.PSOR ENW) I '$G (PSORX("FN ")) D:$P($ G(PSOPAR), "^",7)=1 S VALMBCK= "Q" Q
	6537	"RTN","PSO ORED1",18, 0)
	6538	.S DIE="^ PS(59,",DA =PSOSITE,P SOY=$O(PSO NEW("OLD L AST RX#"," ")),PSOX=P SONEW("OLD LAST RX#" ,PSOY)
	6539	"RTN","PSO ORED1",19, 0)
	6540	.L +^PS(5 9,+PSOSITE ,PSOY):$S( +$G(^DD("D ILOCKTM")) >0:+^DD("D ILOCKTM"), 1:3)
	6541	"RTN","PSO ORED1",20, 0)
	6542	.S DR=$S( PSOY=8:"20 03////"_PS OX,PSOY=3: "1002.1/// /"_PSOX,1: "2003////" _PSOX)
	6543	"RTN","PSO ORED1",21, 0)
	6544	.D:PSOX<$ P(^PS(59,+ PSOSITE,PS OY),"^",3) ^DIE K DI E,X,Y L -^ PS(59,+PSO SITE,PSOY)
	6545	"RTN","PSO ORED1",22, 0)
	6546	.I $D(PSO NEW("RX #" )) L -^PSR X("B",PSON EW("RX #") )
	6547	"RTN","PSO ORED1",23, 0)
	6548	.K PSOX,P SOY Q
	6549	"RTN","PSO ORED1",24, 0)
	6550	Q:$G(COPY )
	6551	"RTN","PSO ORED1",25, 0)
	6552	TRY S $P(^ PSRX(PSORE NW("OIRXN" ),"STA")," ^")=15,DA= PSORENW("O IRXN")
	6553	"RTN","PSO ORED1",26, 0)
	6554	S $P(^PSR X(DA,3),"^ ",5)=DT,$P (^PSRX(DA, 3),"^",10) =$P(^PSRX( DA,3),"^")
	6555	"RTN","PSO ORED1",27, 0)
	6556	D REVERSE ^PSOBPSU1( DA,,"DC",7 ),CAN^PSOT PCAN(DA)
	6557	"RTN","PSO ORED1",28, 0)
	6558	D RMP^PSO CAN3 ;*244
	6559	"RTN","PSO ORED1",29, 0)
	6560	;cancel/d iscontinue action
	6561	"RTN","PSO ORED1",30, 0)
	6562	S PHARM=" ",STAT="RP ",COMM="Pr escription discontin ued due to editing." D EN^PSOH LSN1(DA,ST AT,PHARM,C OMM,PSONOO R) K STAT, PHARM,COMM
	6563	"RTN","PSO ORED1",31, 0)
	6564	S ACOM="D iscontinue d due to e diting. Ne w Rx creat ed "_$P(^P SRX(PSOREN W("IRXN"), 0),"^")_". "
	6565	"RTN","PSO ORED1",32, 0)
	6566	I $G(^PSR X(DA,"H")) ]"" D
	6567	"RTN","PSO ORED1",33, 0)
	6568	.I $P(^PS RX(DA,"STA "),"^")=3! ($P(^("STA "),"^")=16 ) D
	6569	"RTN","PSO ORED1",34, 0)
	6570	..S DIE=5 2,DR="22// /"_$P(^PSR X(DA,3),"^ ") D ^DIE S ACOM="Di scontinued due to ed iting whil e on hold. " K:$P(^P SRX(DA,"H" ),"^") ^PS RX("AH",$P (^PSRX(DA, "H"),"^"), DA)
	6571	"RTN","PSO ORED1",35, 0)
	6572	..S ^PSRX (DA,"H")=" "
	6573	"RTN","PSO ORED1",36, 0)
	6574	S RXDA=DA ,(DA,SUSDA )=$O(^PS(5 2.5,"B",RX DA,0)) D:D A
	6575	"RTN","PSO ORED1",37, 0)
	6576	.S SUSD=$ P($G(^PS(5 2.5,DA,0)) ,"^",2)
	6577	"RTN","PSO ORED1",38, 0)
	6578	.S:+$G(^P S(52.5,DA, "P"))'=1 A COM="Disco ntinued du e to editi ng while s uspended."
	6579	"RTN","PSO ORED1",39, 0)
	6580	.I $O(^PS RX(RXDA,1, 0)) S DA=R XDA D:'$G( ^PS(52.5,+ SUSDA,"P") ) REF^PSOC AN2
	6581	"RTN","PSO ORED1",40, 0)
	6582	.S DA=SUS DA,DIK="^P S(52.5," D ^DIK K DI K
	6583	"RTN","PSO ORED1",41, 0)
	6584	K SUSD,SU SDA S DA=R XDA,RXREF= 0,PSODFN=+ $P(^PSRX(D A,0),"^",2 ) D
	6585	"RTN","PSO ORED1",42, 0)
	6586	.S ACNT=0 F SUB=0:0 S SUB=$O( ^PSRX(DA," A",SUB)) Q :'SUB S A CNT=SUB
	6587	"RTN","PSO ORED1",43, 0)
	6588	.S RFCNT= 0 F RF=0:0 S RF=$O(^ PSRX(DA,1, RF)) Q:'RF S RFCNT= RF S:RF>5 RFCNT=RF+1
	6589	"RTN","PSO ORED1",44, 0)
	6590	.D NOW^%D TC S ^PSRX (DA,"A",0) ="^52.3DA^ "_(ACNT+1) _"^"_(ACNT +1),^PSRX( DA,"A",ACN T+1,0)=%_" ^C^"_DUZ_" ^"_RFCNT_" ^"_$G(ACOM )
	6591	"RTN","PSO ORED1",45, 0)
	6592	.I $G(PSO OIFLG),'$G (PSOMRFLG) S $P(^PSR X(DA,"A",A CNT+1,1)," ^")="Pharm acy Ordera ble Item E dited."
	6593	"RTN","PSO ORED1",46, 0)
	6594	.I '$G(PS OOIFLG),$G (PSOMRFLG) S $P(^PSR X(DA,"A",A CNT+1,1)," ^")="Medic ation Rout e/Schedule Edited."
	6595	"RTN","PSO ORED1",47, 0)
	6596	.I $G(PSO OIFLG),$G( PSOMRFLG) S $P(^PSRX (DA,"A",AC NT+1,1),"^ ")="Pharma cy Orderab le Item an d Medicati on Route/S chedule Ed ited."
	6597	"RTN","PSO ORED1",48, 0)
	6598	.S REA="C " D EXP^PS OHELP1
	6599	"RTN","PSO ORED1",49, 0)
	6600	I $G(^PS( 52.4,DA,0) )]"" S PSC DA=DA,DIK= "^PS(52.4, " D ^DIK S DA=PSCDA K DIK,PSCD A
	6601	"RTN","PSO ORED1",50, 0)
	6602	Q
	6603	"RTN","PSO ORED1",51, 0)
	6604	INS K X,QU IT,Y,DIR,D IRUT,DUOUT ,DTOUT,DIC ,INSDEL,UP MI,^TMP($J ,"INS1")
	6605	"RTN","PSO ORED1",52, 0)
	6606	I '$O(^PS RX(PSORXED ("IRXN"),6 ,0)),'$O(P SORXED("DO SE",0)) D UPMI Q:$G( QUIT) ;G INS1
	6607	"RTN","PSO ORED1",53, 0)
	6608	I $G(^PSR X(PSORXED( "IRXN"),"I NS"))]"" S PSORXED(" FLD",114)= ^PSRX(PSOR XED("IRXN" ),"INS") K UPMI G IN S1
	6609	"RTN","PSO ORED1",54, 0)
	6610	K DD,GG F I=0:0 S I =$O(^PSRX( PSORXED("I RXN"),"INS 1",I)) Q:' I S DD=$G (DD)+1
	6611	"RTN","PSO ORED1",55, 0)
	6612	I $G(DD)= 1 S PSORXE D("FLD",11 4)=^PSRX(P SORXED("IR XN"),"INS1 ",$O(^PSRX (PSORXED(" IRXN"),"IN S1",0)),0) K UPMI,DD G INS1
	6613	"RTN","PSO ORED1",56, 0)
	6614	I $O(^PSR X(PSORXED( "IRXN"),"I NS1",0)) D G INSX
	6615	"RTN","PSO ORED1",57, 0)
	6616	.F I=0:0 S I=$O(^PS RX(PSORXED ("IRXN")," INS1",I)) Q:'I S ^T MP($J,"INS 1",I,0)=^P SRX(PSORXE D("IRXN"), "INS1",I,0 )
	6617	"RTN","PSO ORED1",58, 0)
	6618	.S ^TMP($ J,"INS1",0 )=^PSRX(PS ORXED("IRX N"),"INS1" ,0)
	6619	"RTN","PSO ORED1",59, 0)
	6620	.S DIC="^ TMP($J,""I NS1"",",DW PK=2,DWLW= 80 D EN^DI WE I $G(X) ="^" K ^TM P($J,"INS1 ") Q
	6621	"RTN","PSO ORED1",60, 0)
	6622	.I '$O(^T MP($J,"INS 1",0)) S I NSDEL=1
	6623	"RTN","PSO ORED1",61, 0)
	6624	.S D=0 F S D=$O(^P SRX(PSORXE D("IRXN"), "INS1",D)) Q:'D S P SORXED("SI G",D)=^PSR X(PSORXED( "IRXN"),"I NS1",D,0)
	6625	"RTN","PSO ORED1",62, 0)
	6626	INS1 K Y,D IR,DIRUT,D UOUT,DTOUT ,DIC,X
	6627	"RTN","PSO ORED1",63, 0)
	6628	I $G(PSOR XED("IRXN" )) S:'$D(P SOOEINS) P SOOEINS=$G (^PSRX(PSO RXED("IRXN "),"INS")) S:'$D(PSO OSINS) PSO OSINS=$G(^ PSRX(PSORX ED("IRXN") ,"INSS")) ;*422
	6629	"RTN","PSO ORED1",64, 0)
	6630	I $G(UPMI ) K UPMI I $G(^PS(50 .7,PSODRUG ("OI"),"IN S"))]"" S PSORXED("F LD",114)=^ PS(50.7,PS ODRUG("OI" ),"INS")
	6631	"RTN","PSO ORED1",65, 0)
	6632	S:$G(PSOR XED("FLD", 114))]"" D IR("B")=PS ORXED("FLD ",114)
	6633	"RTN","PSO ORED1",66, 0)
	6634	S DIR("?" )="Enter Q uick codes or Free T ext",DIR(0 )="52,114" D ^DIR
	6635	"RTN","PSO ORED1",67, 0)
	6636	I $D(DTOU T)!($D(DUO UT)) K PSO RXED("FLD" ,114),PSOR XED("FLD", 114.1) S ( PSORXED("I NS"),PSORX ED("SIG",1 ))=$G(PSOO EINS) S:$P ($G(^PS(55 ,PSODFN,"L AN")),"^") PSORXED(" SINS")=$G( PSOOSINS) D EN^PSOFS IG(.PSORXE D,1) G INS Q ;*422
	6637	"RTN","PSO ORED1",68, 0)
	6638	I $G(PSOR XED("DFLG" )) S (PSOR XED("SIG") ,PSORXED(" INS"))=$G( PSOOEINS), PSORXED("S INS")=$G(P SOOSINS) K PSORXED(" SIG") D EN ^PSOFSIG(. PSONEW,1) G INSQ ;* 422
	6639	"RTN","PSO ORED1",69, 0)
	6640	S PSODELI NS=0 I X=" @" S PSODE LINS=1 D D ELINS^PSOH ELP3 ;*422
	6641	"RTN","PSO ORED1",70, 0)
	6642	I '$G(PSO DELINS),($ G(X)="@"!( $G(X)="")) S (X,INS1 ,PSORXED(" INS"))=$G( PSOOEINS) ;*422
	6643	"RTN","PSO ORED1",71, 0)
	6644	I $G(PSOD ELINS) S ( INS1,PSORX ED("FLD",1 14),PSORXE D("FLD",11 4.1))="" K PSORXED(" INS"),PSOR XED("SIG") ,PSORXED(" SINS") ;* 422
	6645	"RTN","PSO ORED1",72, 0)
	6646	I X'="",X '="@" D SI G^PSOHELP G INS1:'$D (X)
	6647	"RTN","PSO ORED1",73, 0)
	6648	I $G(INS1 )]"" W " ( "_$E(INS1, 2,9999999) _")"
	6649	"RTN","PSO ORED1",74, 0)
	6650	S:$G(INS1 )]"" (PSOR XED("INS") ,PSORXED(" SIG",1),PS ORXED("FLD ",114))=$E (INS1,2,99 99999) D E N^PSOFSIG( .PSORXED)
	6651	"RTN","PSO ORED1",75, 0)
	6652	I $G(PSOD ELINS) G I NSQ
	6653	"RTN","PSO ORED1",76, 0)
	6654	INSX I '$P ($G(^PS(55 ,PSODFN,"L AN")),"^") G INSQ
	6655	"RTN","PSO ORED1",77, 0)
	6656	K DIR
	6657	"RTN","PSO ORED1",78, 0)
	6658	I $G(^PSR X(PSORXED( "IRXN"),"I NSS"))]"" S PSORXED( "SINS")=^P SRX(PSORXE D("IRXN"), "INSS")
	6659	"RTN","PSO ORED1",79, 0)
	6660	D SINS^PS ODIR(.PSOR XED) ;*422
	6661	"RTN","PSO ORED1",80, 0)
	6662	I $G(PSOR XED("DFLG" )) K PSORX ED("FLD",1 14) S PSOR XED("INS") =$G(PSOOEI NS) S:$P($ G(^PS(55,P SODFN,"LAN ")),"^") P SORXED("SI NS")=$G(PS OOSINS) D EN^PSOFSIG (.PSORXED, 1) G INSQ ;*422
	6663	"RTN","PSO ORED1",81, 0)
	6664	S:$G(PSOR XED("SINS" ))]"" PSOR XED("FLD", 114.1)=$G( PSORXED("S INS")) ;* 422
	6665	"RTN","PSO ORED1",82, 0)
	6666	S PSOINSC H=$$INSCHK ^PSOHELP3( .PSORXED) ;*422
	6667	"RTN","PSO ORED1",83, 0)
	6668	G:PSOINSC H INS1 ;* 422
	6669	"RTN","PSO ORED1",84, 0)
	6670	INSQ K DIR UT,DUOUT,D TOUT,DIR,X ,Y,DIC,DWP K,PSOOEINS ,PSOOSINS, PSODELINS
	6671	"RTN","PSO ORED1",85, 0)
	6672	Q
	6673	"RTN","PSO ORED1",86, 0)
	6674	INIT ;setu p psorenw array
	6675	"RTN","PSO ORED1",87, 0)
	6676	S PSORENW ("RX0")=^P SRX(PSOREN W("IRXN"), 0),PSORENW ("RX2")=^( 2),PSORENW ("RX3")=^( 3),PSORENW ("STA")=^( "STA"),PSO RENW("TN") =$G(^("TN" ))
	6677	"RTN","PSO ORED1",88, 0)
	6678	I $G(PSOS IGFL),$G(P SORX("SIG" ))]"" S PS ORENW("SIG ")=PSORX(" SIG"),SIGO K=0
	6679	"RTN","PSO ORED1",89, 0)
	6680	E D
	6681	"RTN","PSO ORED1",90, 0)
	6682	.I '$P($G (^PSRX(PSO RENW("IRXN "),"SIG")) ,"^",2) S PSORENW("S IG")=$P($G (^("SIG")) ,"^")
	6683	"RTN","PSO ORED1",91, 0)
	6684	.E D
	6685	"RTN","PSO ORED1",92, 0)
	6686	..S SIGOK =1 Q:$O(SI G(0))
	6687	"RTN","PSO ORED1",93, 0)
	6688	..S D=0 F I=0:0 S D =D+1,I=$O( ^PSRX(PSOR ENW("IRXN" ),"SIG1",I )) Q:'I S SIG(D)=^P SRX(PSOREN W("IRXN"), "SIG1",I,0 )
	6689	"RTN","PSO ORED1",94, 0)
	6690	..K PSOX1 ,D
	6691	"RTN","PSO ORED1",95, 0)
	6692	S PSORENW ("OIRXN")= PSORENW("I RXN")
	6693	"RTN","PSO ORED1",96, 0)
	6694	S PSORENW ("PROVIDER ")=$S($G(P SORENW("PR OVIDER")): PSORENW("P ROVIDER"), 1:$P(PSORE NW("RX0"), "^",4))
	6695	"RTN","PSO ORED1",97, 0)
	6696	S (PSOREN W("PROVIDE R NAME"),P SORX("PROV IDER NAME" ))=$P($G(^ VA(200,PSO RENW("PROV IDER"),0)) ,"^")
	6697	"RTN","PSO ORED1",98, 0)
	6698	;*545 get dea#
	6699	"RTN","PSO ORED1",99, 0)
	6700	S PSORENW ("DEA")=$$ RXDEA^PSOU TIL(PSOREN W("IRXN"))
	6701	"RTN","PSO ORED1",100 ,0)
	6702	I $P($G(^ VA(200,PSO RENW("PROV IDER"),"PS ")),"^",7) ,$P($G(^(" PS")),"^", 8) S PSORE NW("COSIGN ING PROVID ER")=$P($G (^("PS")), "^",8)
	6703	"RTN","PSO ORED1",101 ,0)
	6704	S PSORENW ("CLINIC") =$S($G(PSO RENW("CLIN IC")):PSOR ENW("CLINI C"),1:$P(P SORENW("RX 0"),"^",5) )
	6705	"RTN","PSO ORED1",102 ,0)
	6706	S PSORENW ("REMARKS" )="New Ord er Created by "_$S($ G(COPY)&(' $G(PSOEDIT )):"copyin g",1:"edit ing")_" Rx # "_$P(PS ORENW("RX0 "),"^")_". "
	6707	"RTN","PSO ORED1",103 ,0)
	6708	;
	6709	"RTN","PSO ORED1",104 ,0)
	6710	; - Maint enance Dos e Rx Remar ks field
	6711	"RTN","PSO ORED1",105 ,0)
	6712	I $G(PSOM TFLG) S PS ORENW("REM ARKS")="Ma intenance Rx created from Titr ation Rx# "_$P(PSORE NW("RX0"), "^")_"."
	6713	"RTN","PSO ORED1",106 ,0)
	6714	;
	6715	"RTN","PSO ORED1",107 ,0)
	6716	S PSORENW ("COSIGNER ")=$S($G(P SORENW("CO SIGNER")): PSORENW("C OSIGNER"), $P(PSORENW ("RX3"),"^ ",3):$P(PS ORENW("RX3 "),"^",3), 1:"")
	6717	"RTN","PSO ORED1",108 ,0)
	6718	K:PSORENW ("COSIGNER ")="" PSOR ENW("COSIG NER")
	6719	"RTN","PSO ORED1",109 ,0)
	6720	S PSORENW ("PSODFN") =$P(PSOREN W("RX0")," ^",2)
	6721	"RTN","PSO ORED1",110 ,0)
	6722	S PSORENW ("ORX #")= $P(PSORENW ("RX0"),"^ ")
	6723	"RTN","PSO ORED1",111 ,0)
	6724	S:$G(PSOD RUG("IEN") ) PSORENW( "DRUG IEN" )=PSODRUG( "IEN")
	6725	"RTN","PSO ORED1",112 ,0)
	6726	;*545 get detox #
	6727	"RTN","PSO ORED1",113 ,0)
	6728	I $$DETOX ^PSSOPKI($ G(PSORENW( "DRUG IEN" ))) S PSOR ENW("DETX" )=$$PRVDET OX^PSOUTIL (PSORENW(" PROVIDER") )
	6729	"RTN","PSO ORED1",114 ,0)
	6730	I $G(PSOR ENW("DAYS SUPPLY")) G QTY
	6731	"RTN","PSO ORED1",115 ,0)
	6732	S PSORENW ("DAYS SUP PLY")=$S($ D(CLOZPAT) :7,1:$P(PS ORENW("RX0 "),"^",8))
	6733	"RTN","PSO ORED1",116 ,0)
	6734	QTY S PSOR ENW("QTY") =$S($G(PSO RENW("QTY" )):PSORENW ("QTY"),1: $P(PSORENW ("RX0"),"^ ",7))
	6735	"RTN","PSO ORED1",117 ,0)
	6736	RFN S PSOR ENW("# OF REFILLS")= $S($D(CLOZ PAT):0,$G( PSORENW("# OF REFILL S")):PSORE NW("# OF R EFILLS"),1 :$P(PSOREN W("RX0")," ^",9))
	6737	"RTN","PSO ORED1",118 ,0)
	6738	S (PSOID, Y,PSORENW( "FILL DATE "),PSORENW ("ISSUE DA TE"))=DT
	6739	"RTN","PSO ORED1",119 ,0)
	6740	;
	6741	"RTN","PSO ORED1",120 ,0)
	6742	; - Maint enance Rx Fill Date is set wit h Next Pos sible Fill from Titr ation Rx
	6743	"RTN","PSO ORED1",121 ,0)
	6744	I $G(PSOM TFLG),$P($ G(PSORENW( "RX3")),"^ ",2)>DT S PSORENW("F ILL DATE") =$P(PSOREN W("RX3")," ^",2)
	6745	"RTN","PSO ORED1",122 ,0)
	6746	;
	6747	"RTN","PSO ORED1",123 ,0)
	6748	S:PSORENW ("CLINIC") PSORX("CL INIC")=$P( ^SC(+PSORE NW("CLINIC "),0),"^")
	6749	"RTN","PSO ORED1",124 ,0)
	6750	S PSORENW ("PATIENT STATUS")=$ S($G(PSORE NW("PATIEN T STATUS") ):PSORENW( "PATIENT S TATUS"),'$ P(PSORENW( "RX0"),"^" ,3):$G(^PS (55,PSOREN W("PSODFN" ),"PS")),1 :$P(PSOREN W("RX0")," ^",3))
	6751	"RTN","PSO ORED1",125 ,0)
	6752	S PSORENW ("PTST NOD E")=$G(^PS (53,PSOREN W("PATIENT STATUS"), 0))
	6753	"RTN","PSO ORED1",126 ,0)
	6754	S PSDAYS= $S($G(PSOR ENW("DAYS SUPPLY")): PSORENW("D AYS SUPPLY "),'$P(PSO RENW("RX0" ),"^",8):$ P(PSORENW( "PTST NODE "),"^",3), 1:$P(PSORE NW("RX0"), "^",8))
	6755	"RTN","PSO ORED1",127 ,0)
	6756	I $G(PSOD RUG("IEN") ) S DREN=P SODRUG("IE N"),POERR= 1 D DRG^PS OORDRG K P OERR
	6757	"RTN","PSO ORED1",128 ,0)
	6758	D:$G(PSOR ENW("# OF REFILLS")) ']"" RF
	6759	"RTN","PSO ORED1",129 ,0)
	6760	;
	6761	"RTN","PSO ORED1",130 ,0)
	6762	; - Maint enance Rx # of Refil ls adjustm ent
	6763	"RTN","PSO ORED1",131 ,0)
	6764	I $G(PSOM TFLG),$G(P SORENW("# OF REFILLS "))>0 S PS ORENW("# O F REFILLS" )=PSORENW( "# OF REFI LLS")-1
	6765	"RTN","PSO ORED1",132 ,0)
	6766	;
	6767	"RTN","PSO ORED1",133 ,0)
	6768	S PSORENW ("MAIL/WIN DOW")=$S($ G(PSORENW( "MAIL/WIND OW"))]"":P SORENW("MA IL/WINDOW" ),1:$P(PSO RENW("RX0" ),"^",11))
	6769	"RTN","PSO ORED1",134 ,0)
	6770	S PSORX(" MAIL/WINDO W")=$S(PSO RENW("MAIL /WINDOW")= "W":"WINDO W",1:"MAIL ")
	6771	"RTN","PSO ORED1",135 ,0)
	6772	S PSORENW ("COPIES") =$S($G(PSO RENW("COPI ES")):PSOR ENW("COPIE S"),$P(PSO RENW("RX0" ),"^",18): $P(PSORENW ("RX0"),"^ ",18),1:1)
	6773	"RTN","PSO ORED1",136 ,0)
	6774	S PSORENW ("CLERK CO DE")=DUZ
	6775	"RTN","PSO ORED1",137 ,0)
	6776	S:$G(PSOR X("CLERK C ODE"))']"" PSORX("CL ERK CODE") =$P($G(^VA (200,DUZ,0 )),"^")
	6777	"RTN","PSO ORED1",138 ,0)
	6778	Q:$D(COPY ) S PSORE NW("ENT")= 0
	6779	"RTN","PSO ORED1",139 ,0)
	6780	K PSORENW ("ENT") F I=0:0 S I= $O(PSORENW ("DOSE",I) ) Q:'I S PSORENW("E NT")=$G(PS ORENW("ENT "))+1
	6781	"RTN","PSO ORED1",140 ,0)
	6782	I $O(^TMP ($J,"INS1" ,0)) D
	6783	"RTN","PSO ORED1",141 ,0)
	6784	.K PSORXE D("SIG"),D D
	6785	"RTN","PSO ORED1",142 ,0)
	6786	.F I=0:0 S I=$O(^TM P($J,"INS1 ",I)) Q:'I S PSOREN W("SIG",I) =^TMP($J," INS1",I,0)
	6787	"RTN","PSO ORED1",143 ,0)
	6788	.K ^TMP($ J,"INS1")
	6789	"RTN","PSO ORED1",144 ,0)
	6790	I $G(^PSR X(PSORENW( "IRXN"),"I NS"))]"" S PSORENW(" INS")=^PSR X(PSORENW( "IRXN"),"I NS")
	6791	"RTN","PSO ORED1",145 ,0)
	6792	I $G(^PSR X(PSORENW( "IRXN"),"I NSS"))]"" S PSORENW( "SINS")=^P SRX(PSOREN W("IRXN"), "INSS")
	6793	"RTN","PSO ORED1",146 ,0)
	6794	I '$G(PSO RENW("ENT" )),'$G(PSO SIGFL) D D OLST1^PSOO RED3(.PSOR ENW) S PSO RENW("ENT" )=+$G(OLEN T)
	6795	"RTN","PSO ORED1",147 ,0)
	6796	Q
	6797	"RTN","PSO ORED1",148 ,0)
	6798	RF ;# of r efills
	6799	"RTN","PSO ORED1",149 ,0)
	6800	; Retriev ing the Ma ximum Numb er of Refi lls allowe d
	6801	"RTN","PSO ORED1",150 ,0)
	6802	S PSORENW ("# OF REF ILLS")=$$M AXNUMRF^PS OUTIL(+$G( PSODRUG("I EN")),PSDA YS,+$G(PSO RENW("PATI ENT STATUS ")),.CLOZP AT)
	6803	"RTN","PSO ORED1",151 ,0)
	6804	Q
	6805	"RTN","PSO ORED1",152 ,0)
	6806	UPMI ;add dosing dat a for pre- poe rxs
	6807	"RTN","PSO ORED1",153 ,0)
	6808	W !! K PS ONEW("DFLG "),DIR,DIR UT,DTOUT,D UOUT S DIR (0)="Y",DI R("B")="No ",DIR("A") ="Dosing I nstruction s Are Miss ing!! Do Y ou Want to Add Them"
	6809	"RTN","PSO ORED1",154 ,0)
	6810	D ^DIR I 'Y!($D(DIR UT)) S QUI T=1 K DIR, DIRUT,DUOT ,DUOUT Q
	6811	"RTN","PSO ORED1",155 ,0)
	6812	S UPMI=1, EDTHLD=$G( PSORX("EDI T")) K PSO RX("EDIT")
	6813	"RTN","PSO ORED1",156 ,0)
	6814	D DOSE1^P SOORED5(.P SORXED) S (PSORXED,P SORX("EDIT "))=EDTHLD K EDTHLD I $G(PSONE W("DFLG")) S QUIT=1
	6815	"RTN","PSO ORED1",157 ,0)
	6816	Q
	6817	"RTN","PSO ORFI5")
	6818	0^13^B7951 5100
	6819	"RTN","PSO ORFI5",1,0 )
	6820	PSOORFI5 ; BIR/SJA-fi nish cprs orders ; 8 /27/08 4:4 7pm
	6821	"RTN","PSO ORFI5",2,0 )
	6822	;;7.0;OUT PATIENT PH ARMACY;2 25,315,266 ,391,372,4 16,504,505 ,545;DEC 1997;Buil d 21
	6823	"RTN","PSO ORFI5",3,0 )
	6824	;External reference s UL^PSSLO CK support ed by DBIA 2789
	6825	"RTN","PSO ORFI5",4,0 )
	6826	;External reference to ^DPT s upported b y DBIA 100 35
	6827	"RTN","PSO ORFI5",5,0 )
	6828	;
	6829	"RTN","PSO ORFI5",6,0 )
	6830	FLG W ! K MEDP,MEDA, POERR("DFL G"),DIR D KQ S PSOSO RT="FLAGGE D^FLAGGED"
	6831	"RTN","PSO ORFI5",7,0 )
	6832	N SECSORT S SECSORT =$$DIR^PSO ORFI6("FL: FLAGGED"," FLAGGED") Q:SECSORT= U
	6833	"RTN","PSO ORFI5",8,0 )
	6834	S LG=0,PA TA=0 F S LG=$O(^PS( 52.41,"AD" ,LG)) Q:'L G!($G(POER R("QFLG")) ) F PSOD= 0:0 S PSOD =$O(^PS(52 .41,"AD",L G,PSOPINST ,PSOD)) Q: 'PSOD!($G( POERR("QFL G"))) D
	6835	"RTN","PSO ORFI5",9,0 )
	6836	.Q:'$D(^P S(52.41,PS OD,0))!('$ P($G(^PS(5 2.41,PSOD, 0)),"^",23 ))
	6837	"RTN","PSO ORFI5",10, 0)
	6838	.Q:$G(PAT ($P(^PS(52 .41,PSOD,0 ),"^",2))) =$P(^PS(52 .41,PSOD,0 ),"^",2) S PAT=$P(^ PS(52.41,P SOD,0),"^" ,2)
	6839	"RTN","PSO ORFI5",11, 0)
	6840	.I PAT'=P ATA K PSOR X("DOSING OFF") I $O (PSORX("PS OL",0))!($ D(RXRS)) D LBL^PSOOR FIN
	6841	"RTN","PSO ORFI5",12, 0)
	6842	.D LK I $ G(POERR("Q FLG")) K P OERR("QFLG ") S PSOLK =1,PAT(PAT )=PAT Q
	6843	"RTN","PSO ORFI5",13, 0)
	6844	.I $$CHK^ PSODPT(PAT _"^"_$P($G (^DPT(PAT, 0)),"^"),1 ,1)<0 S PS OLK=1,PAT( PAT)=PAT S X=PAT D U LP K PSOQF LG,PSOQQ Q
	6845	"RTN","PSO ORFI5",14, 0)
	6846	.S (PSODF N,Y)=PAT_" ^"_$P($G(^ DPT(PAT,0) ),"^"),PAT A=PAT
	6847	"RTN","PSO ORFI5",15, 0)
	6848	.I SECSOR T'=0,'$$CH KFLTR^PSOO RFI6(PSOD, SECSORT) Q
	6849	"RTN","PSO ORFI5",16, 0)
	6850	.D:'$G(ME DA) PROFIL E^PSOORFI2 S Y=PSODF N I $G(MED P) D SPL D OERR^PSOR X1 S PSOFI N=1 D QU S X=PSOPTLO K D KLLP,U LP,KLL Q
	6851	"RTN","PSO ORFI5",17, 0)
	6852	.D SDFN D POST^PSOO RFI1 I $G( PSOQFLG)!( $G(PSOQUIT )) S:$G(PS OQUIT) POE RR("QFLG") =1 S:$G(PS OQFLG) PAT (PAT)=PAT S X=PAT D ULP K PSOQ FLG Q
	6853	"RTN","PSO ORFI5",18, 0)
	6854	.S PAT(PA T)=PAT
	6855	"RTN","PSO ORFI5",19, 0)
	6856	.F ORD=0: 0 S ORD=$O (^PS(52.41 ,"AOR",PAT ,PSOPINST, ORD)) Q:'O RD!($G(POE RR("QFLG") ))!($G(PSO QQ)) D
	6857	"RTN","PSO ORFI5",20, 0)
	6858	..I SECSO RT'=0,'$$C HKFLTR^PSO ORFI6(ORD, SECSORT) Q
	6859	"RTN","PSO ORFI5",21, 0)
	6860	..I $P($G (^PS(52.41 ,ORD,0))," ^",23) D P P,LK1,ORD^ PSOORFIN
	6861	"RTN","PSO ORFI5",22, 0)
	6862	.S X=PAT D ULP K PS OQQ
	6863	"RTN","PSO ORFI5",23, 0)
	6864	I $O(PSOR X("PSOL",0 ))!($D(RXR S)) D LBL^ PSOORFIN
	6865	"RTN","PSO ORFI5",24, 0)
	6866	I $G(PSOQ UIT) K PSO QUIT D EX G ^PSOORFI N
	6867	"RTN","PSO ORFI5",25, 0)
	6868	G EX
	6869	"RTN","PSO ORFI5",26, 0)
	6870	;
	6871	"RTN","PSO ORFI5",27, 0)
	6872	SUP W ! K MEDP,MEDA, POERR("DFL G"),DIR D KQ S PSOSO RT="SUPPLY ^SUPPLY"
	6873	"RTN","PSO ORFI5",28, 0)
	6874	N SECSORT S SECSORT =$$DIR^PSO ORFI6("SU: SUPPLY","S UPPLY") Q: SECSORT=U
	6875	"RTN","PSO ORFI5",29, 0)
	6876	S LG=0,PA TA=0 F S LG=$O(^PS( 52.41,"AD" ,LG)) Q:'L G!($G(POER R("QFLG")) ) F PSOD= 0:0 S PSOD =$O(^PS(52 .41,"AD",L G,PSOPINST ,PSOD)) Q: 'PSOD!($G( POERR("QFL G"))) D
	6877	"RTN","PSO ORFI5",30, 0)
	6878	.Q:'$D(^P S(52.41,PS OD,0))!('$ $ISSUPPLY^ PSOORFI6(P SOD))
	6879	"RTN","PSO ORFI5",31, 0)
	6880	.I SECSOR T'=0,'$$CH KFLTR^PSOO RFI6(PSOD, SECSORT) Q
	6881	"RTN","PSO ORFI5",32, 0)
	6882	.Q:$G(PAT ($P(^PS(52 .41,PSOD,0 ),"^",2))) =$P(^PS(52 .41,PSOD,0 ),"^",2) S PAT=$P(^ PS(52.41,P SOD,0),"^" ,2)
	6883	"RTN","PSO ORFI5",33, 0)
	6884	.I PAT'=P ATA K PSOR X("DOSING OFF") I $O (PSORX("PS OL",0))!($ D(RXRS)) D LBL^PSOOR FIN
	6885	"RTN","PSO ORFI5",34, 0)
	6886	.D LK I $ G(POERR("Q FLG")) K P OERR("QFLG ") S PSOLK =1,PAT(PAT )=PAT Q
	6887	"RTN","PSO ORFI5",35, 0)
	6888	.I $$CHK^ PSODPT(PAT _"^"_$P($G (^DPT(PAT, 0)),"^"),1 ,1)<0 S PS OLK=1,PAT( PAT)=PAT S X=PAT D U LP K PSOQF LG,PSOQQ Q
	6889	"RTN","PSO ORFI5",36, 0)
	6890	.S (PSODF N,Y)=PAT_" ^"_$P($G(^ DPT(PAT,0) ),"^"),PAT A=PAT
	6891	"RTN","PSO ORFI5",37, 0)
	6892	.D:'$G(ME DA) PROFIL E^PSOORFI2 S Y=PSODF N I $G(MED P) D SPL D OERR^PSOR X1 S PSOFI N=1 D QU S X=PSOPTLO K D KLLP,U LP,KLL Q
	6893	"RTN","PSO ORFI5",38, 0)
	6894	.D SDFN D POST^PSOO RFI1 I $G( PSOQFLG)!( $G(PSOQUIT )) S:$G(PS OQUIT) POE RR("QFLG") =1 S:$G(PS OQFLG) PAT (PAT)=PAT S X=PAT D ULP K PSOQ FLG Q
	6895	"RTN","PSO ORFI5",39, 0)
	6896	.S PAT(PA T)=PAT
	6897	"RTN","PSO ORFI5",40, 0)
	6898	.F ORD=0: 0 S ORD=$O (^PS(52.41 ,"AOR",PAT ,PSOPINST, ORD)) Q:'O RD!($G(POE RR("QFLG") ))!($G(PSO QQ)) D
	6899	"RTN","PSO ORFI5",41, 0)
	6900	..Q:$P($G (^PS(52.41 ,ORD,0))," ^",23)
	6901	"RTN","PSO ORFI5",42, 0)
	6902	..Q:'$$IS SUPPLY^PSO ORFI6(ORD)
	6903	"RTN","PSO ORFI5",43, 0)
	6904	..I SECSO RT'=0,'$$C HKFLTR^PSO ORFI6(ORD, SECSORT) Q
	6905	"RTN","PSO ORFI5",44, 0)
	6906	..D PP,LK 1,ORD^PSOO RFIN
	6907	"RTN","PSO ORFI5",45, 0)
	6908	.S X=PAT D ULP K PS OQQ
	6909	"RTN","PSO ORFI5",46, 0)
	6910	I $O(PSOR X("PSOL",0 ))!($D(RXR S)) D LBL^ PSOORFIN
	6911	"RTN","PSO ORFI5",47, 0)
	6912	I $G(PSOQ UIT) K PSO QUIT D EX G ^PSOORFI N
	6913	"RTN","PSO ORFI5",48, 0)
	6914	G EX
	6915	"RTN","PSO ORFI5",49, 0)
	6916	Q
	6917	"RTN","PSO ORFI5",50, 0)
	6918	PRI ; Call ed from PS OORFIN due to it's r outine siz e.
	6919	"RTN","PSO ORFI5",51, 0)
	6920	K DIR S P SOSORT="PR IORITY"
	6921	"RTN","PSO ORFI5",52, 0)
	6922	S DIR("A" )="Select Priority", DIR(0)="SB M^S:STAT;E :EMERGENCY ;R:ROUTINE ",DIR("B") ="ROUTINE"
	6923	"RTN","PSO ORFI5",53, 0)
	6924	D ^DIR G: $D(DIRUT) EX S PSOSO RT=PSOSORT _"^"_Y,PSR T=Y
	6925	"RTN","PSO ORFI5",54, 0)
	6926	N SECSORT S SECSORT =$$DIR^PSO ORFI6("PR: PRIORITY", Y) Q:SECSO RT=U
	6927	"RTN","PSO ORFI5",55, 0)
	6928	S LG=0,PA TA=0 F S LG=$O(^PS( 52.41,"AD" ,LG)) Q:'L G!($G(POER R("QFLG")) ) F PSOD= 0:0 S PSOD =$O(^PS(52 .41,"AD",L G,PSOPINST ,PSOD)) Q: 'PSOD!($G( POERR("QFL G"))) D
	6929	"RTN","PSO ORFI5",56, 0)
	6930	.Q:$P($G( ^PS(52.41, PSOD,0))," ^",23)
	6931	"RTN","PSO ORFI5",57, 0)
	6932	.Q:$G(PAT ($P(^PS(52 .41,PSOD,0 ),"^",2))) =$P(^PS(52 .41,PSOD,0 ),"^",2) S PAT=$P(^ PS(52.41,P SOD,0),"^" ,2)
	6933	"RTN","PSO ORFI5",58, 0)
	6934	.;PSO72 66
	6935	"RTN","PSO ORFI5",59, 0)
	6936	.I PAT'=P ATA K PSOR X("DOSING OFF") D LB L^PSOORFIN
	6937	"RTN","PSO ORFI5",60, 0)
	6938	.I '$O(^P S(52.41,"A P",PAT,PSR T,0)) S PS OLK=1,PAT( PAT)=PAT Q
	6939	"RTN","PSO ORFI5",61, 0)
	6940	.D PRI^PS OORFI2 I $ G(PSZFIN) S PSOLK=1, PAT(PAT)=P AT Q
	6941	"RTN","PSO ORFI5",62, 0)
	6942	.D LK I $ G(POERR("Q FLG")) K P OERR("QFLG ") S PSOLK =1,PAT(PAT )=PAT Q
	6943	"RTN","PSO ORFI5",63, 0)
	6944	.I $$CHK^ PSODPT(PAT _"^"_$P($G (^DPT(PAT, 0)),"^"),1 ,1)<0 S PS OLK=1,PAT( PAT)=PAT S X=PAT D U LP Q
	6945	"RTN","PSO ORFI5",64, 0)
	6946	.S (PSODF N,Y)=PAT_" ^"_$P($G(^ DPT(PAT,0) ),"^"),PAT A=PAT
	6947	"RTN","PSO ORFI5",65, 0)
	6948	.I SECSOR T'=0,'$$CH KFLTR^PSOO RFI6(PSOD, SECSORT) Q
	6949	"RTN","PSO ORFI5",66, 0)
	6950	.D:'$G(ME DA) PROFIL E^PSOORFI2 S Y=PSODF N I $G(MED P) D SPL D OERR^PSOR X1 S PSOFI N=1 D QU S X=PSOPTLO K D KLLP,U LP,KLL Q
	6951	"RTN","PSO ORFI5",67, 0)
	6952	.D SDFN D POST^PSOO RFI1 I $G( PSOQFLG)!( $G(PSOQUIT )) S:$G(PS OQUIT) POE RR("QFLG") =1 S:$G(PS OQFLG) PAT (PAT)=PAT S X=PAT D ULP K PSOQ FLG Q
	6953	"RTN","PSO ORFI5",68, 0)
	6954	.D PP S O RD=0 D @PS RT S PAT(P AT)=PAT
	6955	"RTN","PSO ORFI5",69, 0)
	6956	.S X=PAT D ULP
	6957	"RTN","PSO ORFI5",70, 0)
	6958	;PSO726 6
	6959	"RTN","PSO ORFI5",71, 0)
	6960	D LBL^PSO ORFIN
	6961	"RTN","PSO ORFI5",72, 0)
	6962	I $G(PSOQ UIT) K PSO QUIT D EX G ^PSOORFI N
	6963	"RTN","PSO ORFI5",73, 0)
	6964	EX D EX^PS OORFI1
	6965	"RTN","PSO ORFI5",74, 0)
	6966	Q
	6967	"RTN","PSO ORFI5",75, 0)
	6968	LK D LOCK^ PSOORFI1
	6969	"RTN","PSO ORFI5",76, 0)
	6970	Q
	6971	"RTN","PSO ORFI5",77, 0)
	6972	LK1 D LOCK 1^PSOORFI1 Q
	6973	"RTN","PSO ORFI5",78, 0)
	6974	QU I $G(PS OQUIT) S P OERR("QFLG ")=1 K PSO QUIT
	6975	"RTN","PSO ORFI5",79, 0)
	6976	S:$G(PSOQ FLG) PAT(P AT)=PAT
	6977	"RTN","PSO ORFI5",80, 0)
	6978	Q
	6979	"RTN","PSO ORFI5",81, 0)
	6980	ULP K PSOR X("MAIL/WI NDOW"),PSO RX("METHOD OF PICK-U P")
	6981	"RTN","PSO ORFI5",82, 0)
	6982	D CLEAN^P SOVER1
	6983	"RTN","PSO ORFI5",83, 0)
	6984	I '$G(X) Q
	6985	"RTN","PSO ORFI5",84, 0)
	6986	D UL^PSSL OCK(X) Q
	6987	"RTN","PSO ORFI5",85, 0)
	6988	KLL K PSOP TLOK
	6989	"RTN","PSO ORFI5",86, 0)
	6990	Q
	6991	"RTN","PSO ORFI5",87, 0)
	6992	KLLP K PSO NOLCK
	6993	"RTN","PSO ORFI5",88, 0)
	6994	Q
	6995	"RTN","PSO ORFI5",89, 0)
	6996	SPL D SPL^ PSOORFI4
	6997	"RTN","PSO ORFI5",90, 0)
	6998	Q
	6999	"RTN","PSO ORFI5",91, 0)
	7000	SDFN S PSO DFN=+$G(PS ODFN)
	7001	"RTN","PSO ORFI5",92, 0)
	7002	Q
	7003	"RTN","PSO ORFI5",93, 0)
	7004	PP D PP^PS OORFI4
	7005	"RTN","PSO ORFI5",94, 0)
	7006	Q
	7007	"RTN","PSO ORFI5",95, 0)
	7008	KQ K PSOQU IT,POERR(" QFLG")
	7009	"RTN","PSO ORFI5",96, 0)
	7010	Q
	7011	"RTN","PSO ORFI5",97, 0)
	7012	S D S^PSOO RFI2 ; Pro cess STAT priority
	7013	"RTN","PSO ORFI5",98, 0)
	7014	Q
	7015	"RTN","PSO ORFI5",99, 0)
	7016	;
	7017	"RTN","PSO ORFI5",100 ,0)
	7018	E D E^PSOO RFI2 ; Pro cess EMERG ENCY prior ity
	7019	"RTN","PSO ORFI5",101 ,0)
	7020	Q
	7021	"RTN","PSO ORFI5",102 ,0)
	7022	;
	7023	"RTN","PSO ORFI5",103 ,0)
	7024	R D R^PSOO RFI2 ; Pro cess ROUTI NE priorit y
	7025	"RTN","PSO ORFI5",104 ,0)
	7026	Q
	7027	"RTN","PSO ORFI5",105 ,0)
	7028	;
	7029	"RTN","PSO ORFI5",106 ,0)
	7030	LMDISP(ORD ) ; Backdo or ListMan ager Displ ay of Flag /Unflag In formation
	7031	"RTN","PSO ORFI5",107 ,0)
	7032	N FLAG
	7033	"RTN","PSO ORFI5",108 ,0)
	7034	K FLAGLIN E S ORD=+$ G(ORD) I ' ORD Q
	7035	"RTN","PSO ORFI5",109 ,0)
	7036	;
	7037	"RTN","PSO ORFI5",110 ,0)
	7038	I '$G(^PS (52.41,ORD ,"FLG")) Q
	7039	"RTN","PSO ORFI5",111 ,0)
	7040	D GETS^DI Q(52.41,OR D,"33;34;3 5;36;37;38 ","IE","FL AG")
	7041	"RTN","PSO ORFI5",112 ,0)
	7042	S L1="Fla gged by "_ $E(FLAG(52 .41,ORD_", ",34,"E"), 1,30)_" on "_$$FMTE^ XLFDT(FLAG (52.41,ORD _",",33,"I "),2)_": "
	7043	"RTN","PSO ORFI5",113 ,0)
	7044	S LEN=80- $L(L1),L1= L1_$E(FLAG (52.41,ORD _",",35,"E "),1,LEN), L2=$E(FLAG (52.41,ORD _",",35,"E "),LEN+1,9 99)
	7045	"RTN","PSO ORFI5",114 ,0)
	7046	S IEN=IEN +1,^TMP("P SOPO",$J,I EN,0)=L1,F LAGLINE(IE N)=7
	7047	"RTN","PSO ORFI5",115 ,0)
	7048	I L2'="" S IEN=IEN+ 1,^TMP("PS OPO",$J,IE N,0)=L2
	7049	"RTN","PSO ORFI5",116 ,0)
	7050	I FLAG(52 .41,ORD_", ",36,"I")' ="" D
	7051	"RTN","PSO ORFI5",117 ,0)
	7052	. S L1="U nflagged b y "_$E(FLA G(52.41,OR D_",",37," E"),1,30)_ " on "_$$F MTE^XLFDT( FLAG(52.41 ,ORD_",",3 6,"I"),2)_ ": "
	7053	"RTN","PSO ORFI5",118 ,0)
	7054	. S LEN=8 0-$L(L1),L 1=L1_$E(FL AG(52.41,O RD_",",38, "E"),1,LEN ),L2=$E(FL AG(52.41,O RD_",",38, "E"),LEN+1 ,999)
	7055	"RTN","PSO ORFI5",119 ,0)
	7056	. S IEN=I EN+1,^TMP( "PSOPO",$J ,IEN,0)=L1 ,FLAGLINE( IEN)=9
	7057	"RTN","PSO ORFI5",120 ,0)
	7058	. I L2'=" " S IEN=IE N+1,^TMP(" PSOPO",$J, IEN,0)=L2
	7059	"RTN","PSO ORFI5",121 ,0)
	7060	S IEN=IEN +1,^TMP("P SOPO",$J,I EN,0)=" "
	7061	"RTN","PSO ORFI5",122 ,0)
	7062	Q
	7063	"RTN","PSO ORFI5",123 ,0)
	7064	;
	7065	"RTN","PSO ORFI5",124 ,0)
	7066	CS ; Digit ally Signe d CS - PSO 7391
	7067	"RTN","PSO ORFI5",125 ,0)
	7068	K DIR N P SOCSRT S D IR("A")="R oute",DIR( 0)="SBM^W: WINDOW;M:M AIL;B:BOTH ;E:EXIT",D IR("B")="B OTH" D ^DI R
	7069	"RTN","PSO ORFI5",126 ,0)
	7070	Q:$D(DIRU T)!(Y="E")
	7071	"RTN","PSO ORFI5",127 ,0)
	7072	S PSOCSRT =$S(Y="B": 1,1:Y)
	7073	"RTN","PSO ORFI5",128 ,0)
	7074	W !!,"Sel ect a sche dule(s)"
	7075	"RTN","PSO ORFI5",129 ,0)
	7076	K DIR S P SOSORT="DI GITALLY SI GNED"
	7077	"RTN","PSO ORFI5",130 ,0)
	7078	S DIR("A" )="Select Schedule(s )",DIR(0)= "S^1:SCHED ULE II;2:S CHEDULES I II - V;3:S CHEDULES I I - V;4:NO N-CS+SCHED ULES III - V;5:NON-C S ONLY;E:E XIT",DIR(" B")=3
	7079	"RTN","PSO ORFI5",131 ,0)
	7080	D ^DIR G: $D(DIRUT)! (Y="E") EX S PSOSORT =PSOSORT_" ^"_Y,PSRT= Y
	7081	"RTN","PSO ORFI5",132 ,0)
	7082	N SECSORT S SECSORT =$$DIR^PSO ORFI6("CS: CONTROLLED SUBSTANCE S",Y) Q:SE CSORT=U
	7083	"RTN","PSO ORFI5",133 ,0)
	7084	N PDEA,OR 0 S LG=0,P ATA=0 F S LG=$O(^PS (52.41,"AD ",LG)) Q:' LG!($G(POE RR("QFLG") )) F PSOD =0:0 S PSO D=$O(^PS(5 2.41,"AD", LG,PSOPINS T,PSOD)) Q :'PSOD!($G (POERR("QF LG"))) D
	7085	"RTN","PSO ORFI5",134 ,0)
	7086	.Q:'$D(^P S(52.41,PS OD,0))
	7087	"RTN","PSO ORFI5",135 ,0)
	7088	.S OR0=^P S(52.41,PS OD,0)
	7089	"RTN","PSO ORFI5",136 ,0)
	7090	.;PSO75 05 - still quit if t he order i s flagged, but now o nly look f or digital signature if the se lection do es not ask for non c ontolled s ubstances
	7091	"RTN","PSO ORFI5",137 ,0)
	7092	.Q:$P(OR0 ,"^",23)
	7093	"RTN","PSO ORFI5",138 ,0)
	7094	.S PDEA=0 D PDEA Q: 'PDEA!(PDE A'=PSRT)
	7095	"RTN","PSO ORFI5",139 ,0)
	7096	.;PSO75 05 moved d igitally s igned chec k after th e DEA chec k
	7097	"RTN","PSO ORFI5",140 ,0)
	7098	.I PSRT<4 ,'$P(OR0," ^",24) Q
	7099	"RTN","PSO ORFI5",141 ,0)
	7100	.I 'PSOCS RT,PSOCSRT '=$P(OR0," ^",17) Q
	7101	"RTN","PSO ORFI5",142 ,0)
	7102	.Q:$G(PAT ($P(OR0,"^ ",2)))=$P( OR0,"^",2) S PAT=$P (OR0,"^",2 )
	7103	"RTN","PSO ORFI5",143 ,0)
	7104	.I PAT'=P ATA K PSOR X("DOSING OFF") I $O (PSORX("PS OL",0))!($ D(RXRS)) D LBL^PSOOR FIN
	7105	"RTN","PSO ORFI5",144 ,0)
	7106	.D LK I $ G(POERR("Q FLG")) K P OERR("QFLG ") S PSOLK =1,PAT(PAT )=PAT Q
	7107	"RTN","PSO ORFI5",145 ,0)
	7108	.I $$CHK^ PSODPT(PAT _"^"_$P($G (^DPT(PAT, 0)),"^"),1 ,1)<0 S PS OLK=1,PAT( PAT)=PAT S X=PAT D U LP K PSOQF LG,PSOQQ Q
	7109	"RTN","PSO ORFI5",146 ,0)
	7110	.S (PSODF N,Y)=PAT_" ^"_$P($G(^ DPT(PAT,0) ),"^"),PAT A=PAT
	7111	"RTN","PSO ORFI5",147 ,0)
	7112	.I SECSOR T'=0,'$$CH KFLTR^PSOO RFI6(PSOD, SECSORT) Q
	7113	"RTN","PSO ORFI5",148 ,0)
	7114	.D:'$G(ME DA) PROFIL E^PSOORFI2 S Y=PSODF N I $G(MED P) D SPL D OERR^PSOR X1 S PSOFI N=1 D QU S X=PSOPTLO K D KLLP,U LP,KLL Q
	7115	"RTN","PSO ORFI5",149 ,0)
	7116	.D SDFN D POST^PSOO RFI1 I $G( PSOQFLG)!( $G(PSOQUIT )) S:$G(PS OQUIT) POE RR("QFLG") =1 S:$G(PS OQFLG) PAT (PAT)=PAT S X=PAT D ULP K PSOQ FLG Q
	7117	"RTN","PSO ORFI5",150 ,0)
	7118	.S PAT(PA T)=PAT
	7119	"RTN","PSO ORFI5",151 ,0)
	7120	.F ORD=0: 0 S ORD=$O (^PS(52.41 ,"AOR",PAT ,PSOPINST, ORD)) Q:'O RD!($G(POE RR("QFLG") ))!($G(PSO QQ)) D
	7121	"RTN","PSO ORFI5",152 ,0)
	7122	..Q:'$D(^ PS(52.41,O RD,0))
	7123	"RTN","PSO ORFI5",153 ,0)
	7124	..S OR0=^ PS(52.41,O RD,0)
	7125	"RTN","PSO ORFI5",154 ,0)
	7126	..;PSO*50 5 - Move t he check f or digital ly signed, so non-cs substance s will be shown if s elected as sort crit eria
	7127	"RTN","PSO ORFI5",155 ,0)
	7128	..Q:$P(OR 0,U,23)
	7129	"RTN","PSO ORFI5",156 ,0)
	7130	..I SECSO RT'=0,'$$C HKFLTR^PSO ORFI6(ORD, SECSORT) Q
	7131	"RTN","PSO ORFI5",157 ,0)
	7132	..I 'PSOC SRT,PSOCSR T'=$P(OR0, "^",17) Q
	7133	"RTN","PSO ORFI5",158 ,0)
	7134	..Q:$P(OR 0,"^",3)=" DC"!($P(OR 0,"^",3)=" DE")
	7135	"RTN","PSO ORFI5",159 ,0)
	7136	..S PDEA= 0 D PDEA Q :'PDEA!(PD EA'=PSRT)
	7137	"RTN","PSO ORFI5",160 ,0)
	7138	..I PSRT< 4,'$P(OR0, "^",24) Q
	7139	"RTN","PSO ORFI5",161 ,0)
	7140	..D PP,LK 1,ORD^PSOO RFIN
	7141	"RTN","PSO ORFI5",162 ,0)
	7142	.S X=PAT D ULP K PS OQQ
	7143	"RTN","PSO ORFI5",163 ,0)
	7144	I $O(PSOR X("PSOL",0 ))!($D(RXR S)) D LBL^ PSOORFIN
	7145	"RTN","PSO ORFI5",164 ,0)
	7146	I $G(PSOQ UIT) K PSO QUIT D EX G ^PSOORFI N
	7147	"RTN","PSO ORFI5",165 ,0)
	7148	G EX
	7149	"RTN","PSO ORFI5",166 ,0)
	7150	;
	7151	"RTN","PSO ORFI5",167 ,0)
	7152	PDEA ;
	7153	"RTN","PSO ORFI5",168 ,0)
	7154	I +$P(OR0 ,"^",9) S PDEA=$P($G (^PSDRUG($ P(OR0,"^", 9),0)),"^" ,3),PDEA=$ S(PDEA[2:1 ,PDEA[3!(P DEA[4)!(PD EA[5):2,1: 0)
	7155	"RTN","PSO ORFI5",169 ,0)
	7156	E S PDEA =$$OIDEA^P SSUTLA1($P (OR0,"^",8 ),"O")
	7157	"RTN","PSO ORFI5",170 ,0)
	7158	; PSO75 05 - addin g checks f or new sor t criteria
	7159	"RTN","PSO ORFI5",171 ,0)
	7160	; PDEA=0 OR 2, cove rs non-cs and schedu le 3-5
	7161	"RTN","PSO ORFI5",172 ,0)
	7162	I (PDEA=0 )!(PDEA=2) ,PSRT=4 S PDEA=4 Q
	7163	"RTN","PSO ORFI5",173 ,0)
	7164	I PDEA=0, PSRT=5 S P DEA=5 Q
	7165	"RTN","PSO ORFI5",174 ,0)
	7166	; PSO75 05 end
	7167	"RTN","PSO ORFI5",175 ,0)
	7168	I PDEA,PS RT=3 S PDE A=3
	7169	"RTN","PSO ORFI5",176 ,0)
	7170	Q
	7171	"RTN","PSO ORFI5",177 ,0)
	7172	;
	7173	"RTN","PSO ORFI5",178 ,0)
	7174	PRV(PROV,D RG,ORN) ;
	7175	"RTN","PSO ORFI5",179 ,0)
	7176	N DETN,DE A,I,LBL,VA DD,SPC
	7177	"RTN","PSO ORFI5",180 ,0)
	7178	I PROV="" Q
	7179	"RTN","PSO ORFI5",181 ,0)
	7180	;*545 - s how DEA la bel only, get the st ored DEA#
	7181	"RTN","PSO ORFI5",182 ,0)
	7182	S:$L($G(P SORX("RXDE A"))) DEA= PSORX("RXD EA")
	7183	"RTN","PSO ORFI5",183 ,0)
	7184	I '$L($G( DEA)) S DE A=$S($G(PS ONEW("OIRX N")):$$RXD EA^PSOUTIL (PSONEW("O IRXN")),$G (ORN):$$RX DEA^PSOUTI L(,ORN),1: $$DEA^XUSE R(0,PROV)) S:DEA]"" PSORX("RXD EA")=DEA
	7185	"RTN","PSO ORFI5",184 ,0)
	7186	S:$L($G(P SORX("DETX "))) DETN= PSORX("DET X")
	7187	"RTN","PSO ORFI5",185 ,0)
	7188	S LBL="DE A#: " I $G (ADDS) S L BL=" "_LBL
	7189	"RTN","PSO ORFI5",186 ,0)
	7190	I DRG,$$D ETOX^PSSOP KI(DRG),'$ L($G(DETN) ) S DETN=$ S($G(ORN): $$RXDETOX^ PSOUTIL(,O RN),1:$$DE TOX^XUSER( PROV))
	7191	"RTN","PSO ORFI5",187 ,0)
	7192	S $P(SPC, " ",($S($G (ADDS):30, 1:33)-$L(D EA)))=" "
	7193	"RTN","PSO ORFI5",188 ,0)
	7194	I (DEA'=" ")!($G(DET N)'="") S IEN=IEN+1, $E(^TMP("P SOPO",$J,I EN,0),16)= LBL_DEA_$S ($G(DETN)] "":SPC_"DE TOX#: "_$G (DETN),1:" ")
	7195	"RTN","PSO ORFI5",189 ,0)
	7196	I $G(ORN) D PRVAD^P SOPKIV2 I $G(VADD(1) )]"" D
	7197	"RTN","PSO ORFI5",190 ,0)
	7198	.S IEN=IE N+1,^TMP(" PSOPO",$J, IEN,0)=$S( $G(ADDS):" ",1:"")_" Sit e Address: "_VADD(1)
	7199	"RTN","PSO ORFI5",191 ,0)
	7200	.S:VADD(2 )'="" IEN= IEN+1,^TMP ("PSOPO",$ J,IEN,0)=$ S($G(ADDS) :" ",1:"") _" "_VADD( 2) S:VADD( 3)'="" IEN =IEN+1,^TM P("PSOPO", $J,IEN,0)= $S($G(ADDS ):" ",1:"" )_" "_VADD (3)
	7201	"RTN","PSO ORFI5",192 ,0)
	7202	Q
	7203	"RTN","PSO ORFI5",193 ,0)
	7204	;
	7205	"RTN","PSO ORNE3")
	7206	0^14^B6951 4547
	7207	"RTN","PSO ORNE3",1,0 )
	7208	PSOORNE3 ; ISC-BHAM/S AB - displ ay pending orders fr om backdoo r ;2/3/05 1:59pm
	7209	"RTN","PSO ORNE3",2,0 )
	7210	;;7.0;OUT PATIENT PH ARMACY;1 1,9,39,59, 46,103,124 ,139,152,1 94,391,313 ,444,504,5 45;DEC 1 997;Build 21
	7211	"RTN","PSO ORNE3",3,0 )
	7212	;Ext ref to ^SC (Fi le #44) (D BIA 10040) ,^PSXOPUTL (DBIA 220 0)
	7213	"RTN","PSO ORNE3",4,0 )
	7214	;^PS(50.6 06 (DBIA 2 174),^PS(5 0.7 DBIA 2 223),^PS(5 5,DBIA 222 8)
	7215	"RTN","PSO ORNE3",5,0 )
	7216	;^PSDRUG (DBIA 221)
	7217	"RTN","PSO ORNE3",6,0 )
	7218	K ^TMP("P SOPO",$J) S ORD=$P(P SOLST(ORN) ,"^",2) D ORD^PSOORF IN Q
	7219	"RTN","PSO ORNE3",7,0 )
	7220	S PSODRUG ("OI")=$P( OR0,"^",8) ,PSODRUG(" OIN")=$P(^ PS(50.7,$P (OR0,"^",8 ),0),"^")
	7221	"RTN","PSO ORNE3",8,0 )
	7222	I $P($G(O R0),"^",9) S DREN=$P (OR0,"^",9 ) S POERR= 1 D DRG^PS OORDRG K P OERR ;D PO ST^PSODRG
	7223	"RTN","PSO ORNE3",9,0 )
	7224	I '$P(OR0 ,"^",9) D DREN^PSOOR NW2
	7225	"RTN","PSO ORNE3",10, 0)
	7226	S PSONEW( "# OF REFI LLS")=$P(O R0,"^",11)
	7227	"RTN","PSO ORNE3",11, 0)
	7228	S (Y,PSON EW("ISSUE DATE"))=$S ($G(PSONEW ("ISSUE DA TE")):PSON EW("ISSUE DATE"),1:$ E($P(OR0," ^",6),1,7) ) X ^DD("D D")
	7229	"RTN","PSO ORNE3",12, 0)
	7230	S PSONEW( "CLERK COD E")=$P(OR0 ,"^",4),PS ORX("CLERK CODE")=$P (^VA(200,$ P(OR0,"^", 4),0),"^")
	7231	"RTN","PSO ORNE3",13, 0)
	7232	S (PSONEW ("DFLG"),P SONEW("QFL G"))=0,PSO DFN=$P(OR0 ,"^",2)
	7233	"RTN","PSO ORNE3",14, 0)
	7234	I '$G(PSO MTFLG) S P SONEW("QTY ")=$S($G(P SONEW("QTY ")):PSONEW ("QTY"),1: $P(OR0,"^" ,10))
	7235	"RTN","PSO ORNE3",15, 0)
	7236	S PSONEW( "MAIL/WIND OW")=$S($P (OR0,"^",1 7)]"":$P(O R0,"^",17) ,1:"W")
	7237	"RTN","PSO ORNE3",16, 0)
	7238	S:$G(PSON EW("CLINIC "))']"" PS ONEW("CLIN IC")=$P(OR 0,"^",13)
	7239	"RTN","PSO ORNE3",17, 0)
	7240	S:$G(PSOR X("CLINIC" ))']"" PSO RX("CLINIC ")=$S($D(^ SC(+$P(OR0 ,"^",13),0 )):$P(^SC( $P(OR0,"^" ,13),0),"^ "),1:"")
	7241	"RTN","PSO ORNE3",18, 0)
	7242	S PSONEW( "CLERK COD E")=$P(OR0 ,"^",4),PS ONEW("PROV IDER")=$P( OR0,"^",5) ,PSONEW("P ROVIDER NA ME")=$P(^V A(200,$P(O R0,"^",5), 0),"^")
	7243	"RTN","PSO ORNE3",19, 0)
	7244	S PSONEW( "PATIENT S TATUS")=$S (+$G(^PS(5 5,PSODFN," PS")):+$G( ^PS(55,PSO DFN,"PS")) ,1:"")
	7245	"RTN","PSO ORNE3",20, 0)
	7246	S PSONEW( "DAYS SUPP LY")=$S(+$ G(^PS(55,P SODFN,"PS" ))&($P(^PS (53,+$G(^P S(55,PSODF N,"PS")),0 ),"^",3)): $P(^PS(53, +$G(^PS(55 ,PSODFN,"P S")),0),"^ ",3),1:30)
	7247	"RTN","PSO ORNE3",21, 0)
	7248	S IEN=0 D OBX^PSOOR FI1,DIN^PS ONFI(PSODR UG("OI"),$ S($G(PSODR UG("IEN")) :PSODRUG(" IEN"),1:"" )) ;Setup for N/F & DIN indica tor
	7249	"RTN","PSO ORNE3",22, 0)
	7250	S IEN=IEN +1,^TMP("P SOPO",$J,I EN,0)="* ( 1) Orderab le Item: " _$P(^PS(50 .7,PSODRUG ("OI"),0), "^")_" "_$ P(^PS(50.6 06,$P(^(0) ,"^",2),0) ,"^")_NFIO
	7251	"RTN","PSO ORNE3",23, 0)
	7252	S:NFIO["D IN" NFIO=I EN_","_($L (^TMP("PSO PO",$J,IEN ,0))-4)
	7253	"RTN","PSO ORNE3",24, 0)
	7254	K LST S I EN=IEN+1,^ TMP("PSOPO ",$J,IEN,0 )=" (2) D rug: "_$S( $G(PSODRUG ("NAME"))] "":PSODRUG ("NAME")_N FID,1:"No Dispense D rug Select ed")
	7255	"RTN","PSO ORNE3",25, 0)
	7256	S:NFID["D IN" NFID=I EN_","_($L (^TMP("PSO PO",$J,IEN ,0))-4)
	7257	"RTN","PSO ORNE3",26, 0)
	7258	S IEN=IEN +1,^TMP("P SOPO",$J,I EN,0)=" ( 3) Patient Status: " _$P($G(^PS (53,PSONEW ("PATIENT STATUS"),0 )),"^")
	7259	"RTN","PSO ORNE3",27, 0)
	7260	S IEN=IEN +1,(PSOID, Y)=$E($P(O R0,"^",6), 1,7) X ^DD ("DD") S ^ TMP("PSOPO ",$J,IEN,0 )=" (4) Issue Date: "_Y
	7261	"RTN","PSO ORNE3",28, 0)
	7262	S (Y,PSON EW("FILL D ATE"))=$E( $P(OR0,"^" ,6),1,7) X ^DD("DD") S PSONEW( "FILL DATE ")=Y,^TMP( "PSOPO",$J ,IEN,0)=^T MP("PSOPO" ,$J,IEN,0) _" (5) F ill Date: "_Y
	7263	"RTN","PSO ORNE3",29, 0)
	7264	S IEN=IEN +1,^TMP("P SOPO",$J,I EN,0)=" Instru ctions:" S TY=3 D IN ST^PSOORFI 1
	7265	"RTN","PSO ORNE3",30, 0)
	7266	S IEN=IEN +1,^TMP("P SOPO",$J,I EN,0)=" ( 6) Possi ble SIG: " D:$G(PSON EW("SIG")) ']"" SIG^P SOORFI1 S: $G(PSONEW( "SIG"))]"" IEN=IEN+1 ,^TMP("PSO PO",$J,IEN ,0)=$G(PSO NEW("SIG") ),IEN=IEN+ 1,^TMP("PS OPO",$J,IE N,0)=PSOER R("SIG")
	7267	"RTN","PSO ORNE3",31, 0)
	7268	S IEN=IEN +1,^TMP("P SOPO",$J,I EN,0)=" ( 7) Days Supply: " _$S($G(PSO NEW("DAYS SUPPLY")): PSONEW("DA YS SUPPLY" ),+$G(^PS( 55,PSODFN, "PS"))&($P (^PS(53,+$ G(^PS(55,P SODFN,"PS" )),0),"^", 3)):$P(^PS (53,+$G(^P S(55,PSODF N,"PS")),0 ),"^",3),1 :"")
	7269	"RTN","PSO ORNE3",32, 0)
	7270	S ^TMP("P SOPO",$J,I EN,0)=^TMP ("PSOPO",$ J,IEN,0)_" (8) QTY: "_$P (OR0,"^",1 0)
	7271	"RTN","PSO ORNE3",33, 0)
	7272	S IEN=IEN +1,^TMP("P SOPO",$J,I EN,0)=" ( 9) # of Refills: " _$P(OR0,"^ ",11)_$E(" ",$L($P( OR0,"^",11 ))+1,2)_" (10) Rout ing: "_$S( $G(PSONEW( "MAIL/WIND OW"))="M": "MAIL",1:" WINDOW")
	7273	"RTN","PSO ORNE3",34, 0)
	7274	S IEN=IEN +1,^TMP("P SOPO",$J,I EN,0)=" (1 1) Clinic: " _PSORX("CL INIC")
	7275	"RTN","PSO ORNE3",35, 0)
	7276	S $P(RN," ",32)=" " ,IEN=IEN+1 ,^TMP("PSO PO",$J,IEN ,0)=" (12) Pro vider: "_P SONEW("PRO VIDER NAME ")_$E(RN,$ L(PSONEW(" PROVIDER N AME"))+1,3 2)_" (13) Copies: "_$S($G(PS ONEW("COPI ES")):PSON EW("COPIES "),1:1) K RN
	7277	"RTN","PSO ORNE3",36, 0)
	7278	I $P(^VA( 200,$S($G( PSONEW("PR OVIDER")): PSONEW("PR OVIDER"),1 :$P(OR0,"^ ",5)),"PS" ),"^",7)&( $P(^("PS") ,"^",8)) S IEN=IEN+1 ,PSONEW("C OSIGNING P ROVIDER")= $P(^("PS") ,"^",8) D
	7279	"RTN","PSO ORNE3",37, 0)
	7280	.S ^TMP(" PSOPO",$J, IEN,0)=" Cos- Provider: "_$P(^VA(2 00,+$G(PSO NEW("COSIG NING PROVI DER")),0), "^")
	7281	"RTN","PSO ORNE3",38, 0)
	7282	S IEN=IEN +1,^TMP("P SOPO",$J,I EN,0)=" P rovider Co mments:" S TY=2 D IN ST^PSOORFI 1
	7283	"RTN","PSO ORNE3",39, 0)
	7284	S IEN=IEN +1,^TMP("P SOPO",$J,I EN,0)=" (1 4) Remarks: "
	7285	"RTN","PSO ORNE3",40, 0)
	7286	I $G(PSON EW("REMARK S"))]"" D
	7287	"RTN","PSO ORNE3",41, 0)
	7288	.F SG=1:1 :$L(PSONEW ("REMARKS" )) S:$L(^T MP("PSOPO" ,$J,IEN,0) _" "_$P(PS ONEW("REMA RKS")," ", SG))>80 IE N=IEN+1,$P (^TMP("PSO PO",$J,IEN ,0)," ",20 )=" " D
	7289	"RTN","PSO ORNE3",42, 0)
	7290	..S:$P(PS ONEW("REMA RKS")," ", SG)'="" ^T MP("PSOPO" ,$J,IEN,0) =$G(^TMP(" PSOPO",$J, IEN,0))_" "_$P(PSONE W("REMARKS ")," ",SG)
	7291	"RTN","PSO ORNE3",43, 0)
	7292	S $P(RN," ",35)=" " ,IEN=IEN+1 ,^TMP("PSO PO",$J,IEN ,0)=" En try By: "_ $P(^VA(200 ,$P(OR0,"^ ",4),0),"^ ")_$E(RN,$ L($P(^VA(2 00,$P(OR0, "^",4),0), "^"))+1,35 )
	7293	"RTN","PSO ORNE3",44, 0)
	7294	S Y=$P(OR 0,"^",12) X ^DD("DD" ) S ^TMP(" PSOPO",$J, IEN,0)=^TM P("PSOPO", $J,IEN,0)_ "Entry Dat e: "_$E($P (OR0,"^",1 2),4,5)_"/ "_$E($P(OR 0,"^",12), 6,7)_"/"_$ E($P(OR0," ^",12),2,3 )_" "_$P(Y ,"@",2) K RN
	7295	"RTN","PSO ORNE3",45, 0)
	7296	G ^PSOLMP O
	7297	"RTN","PSO ORNE3",46, 0)
	7298	Q
	7299	"RTN","PSO ORNE3",47, 0)
	7300	DSPL ;back door
	7301	"RTN","PSO ORNE3",48, 0)
	7302	K ^TMP("P SOPO",$J) D DIN^PSON FI(PSODRUG ("OI"),$S( $G(PSODRUG ("IEN")):P SODRUG("IE N"),1:"")) ;NFI
	7303	"RTN","PSO ORNE3",49, 0)
	7304	I $D(RX0) ,$D(PSODRU G("IEN")) D
	7305	"RTN","PSO ORNE3",50, 0)
	7306	.I PSODRU G("IEN")=$ P(RX0,"^", 6)!($P(PSL ST,",",2)) D RST
	7307	"RTN","PSO ORNE3",51, 0)
	7308	S IEN=0,I EN=IEN+1,^ TMP("PSOPO ",$J,IEN,0 )=" O rderable I tem: "_$P( ^PS(50.7,P SODRUG("OI "),0),"^") _" "_$P(^P S(50.606,$ P(^(0),"^" ,2),0),"^" )_NFIO
	7309	"RTN","PSO ORNE3",52, 0)
	7310	S:NFIO["D IN" NFIO=I EN_","_($L (^TMP("PSO PO",$J,IEN ,0))-4)
	7311	"RTN","PSO ORNE3",53, 0)
	7312	I $G(PSOD RUG("NAME" ))]"" D G PST
	7313	"RTN","PSO ORNE3",54, 0)
	7314	.S IEN=IE N+1,^TMP(" PSOPO",$J, IEN,0)=" (1)"_$S($D (^PSDRUG(" AQ",PSODRU G("IEN"))) :" CM OP ",1:" " )_"Drug: " _PSODRUG(" NAME")_NFI D
	7315	"RTN","PSO ORNE3",55, 0)
	7316	.S:NFID[" DIN" NFID= IEN_","_($ L(^TMP("PS OPO",$J,IE N,0))-4)
	7317	"RTN","PSO ORNE3",56, 0)
	7318	S IEN=IEN +1,^TMP("P SOPO",$J,I EN,0)=" ( 1) Drug: N o Dispense Drug Sele cted"
	7319	"RTN","PSO ORNE3",57, 0)
	7320	PST S:$G(P SODRUG("TR ADE NAME") )]"" IEN=I EN+1,^TMP( "PSOPO",$J ,IEN,0)=" T rade Name: "_$S($G(P SODRUG("TR ADE NAME") )]"":PSODR UG("TRADE NAME"),1:" ")
	7321	"RTN","PSO ORNE3",58, 0)
	7322	S IEN=IEN +1,^TMP("P SOPO",$J,I EN,0)=" ( 2) Patient Status: " _$P($G(^PS (53,PSONEW ("PATIENT STATUS"),0 )),"^")
	7323	"RTN","PSO ORNE3",59, 0)
	7324	I $G(PSOI D) S Y=PSO ID X ^DD(" DD") S PSO NEW("ISSUE DATE")=Y
	7325	"RTN","PSO ORNE3",60, 0)
	7326	S IEN=IEN +1,^TMP("P SOPO",$J,I EN,0)=" ( 3) Iss ue Date: " _PSONEW("I SSUE DATE" )
	7327	"RTN","PSO ORNE3",61, 0)
	7328	S Y=PSONE W("FILL DA TE") X ^DD ("DD") S ^ TMP("PSOPO ",$J,IEN,0 )=^TMP("PS OPO",$J,IE N,0)_" ( 4) Fill Da te: "_Y
	7329	"RTN","PSO ORNE3",62, 0)
	7330	D DOSE^PS OBKDED
	7331	"RTN","PSO ORNE3",63, 0)
	7332	I $G(PSOR XED("IRXN" )),'$G(PSO SIGFL) S R XN=PSORXED ("IRXN") D :'$G(COPY) INST1^PSO ORNE5 K RX N
	7333	"RTN","PSO ORNE3",64, 0)
	7334	S IEN=IEN +1,^TMP("P SOPO",$J,I EN,0)=" SIG:"
	7335	"RTN","PSO ORNE3",65, 0)
	7336	I $G(SIGO K),$O(SIG( 0)) D SIG G DSP
	7337	"RTN","PSO ORNE3",66, 0)
	7338	I $D(PSOC OPY),$G(PS ONEW("SIG" ))']"" D S IG G DSP
	7339	"RTN","PSO ORNE3",67, 0)
	7340	I $G(PSOS IGFL),$G(P SONEW("SIG "))']"" D SIG G DSP
	7341	"RTN","PSO ORNE3",68, 0)
	7342	D:$G(PSON EW("SIG")) ]""
	7343	"RTN","PSO ORNE3",69, 0)
	7344	.S X=PSON EW("SIG") D SIGONE^P SOHELP S S IG=$E($G(I NS1),2,250 )
	7345	"RTN","PSO ORNE3",70, 0)
	7346	.F SG=1:1 :$L(SIG) S :$L(^TMP(" PSOPO",$J, IEN,0)_" " _$P(SIG," ",SG))>80 IEN=IEN+1, $P(^TMP("P SOPO",$J,I EN,0)," ", 21)=" " S: $P(SIG," " ,SG)'="" ^ TMP("PSOPO ",$J,IEN,0 )=$G(^TMP( "PSOPO",$J ,IEN,0))_" "_$P(SIG, " ",SG)
	7347	"RTN","PSO ORNE3",71, 0)
	7348	DSP S IEN= IEN+1,^TMP ("PSOPO",$ J,IEN,0)=" (7) D ays Supply : "_PSONEW ("DAYS SUP PLY")_$S($ L(PSONEW(" DAYS SUPPL Y"))=1:" " ,1:"")
	7349	"RTN","PSO ORNE3",72, 0)
	7350	I '$D(PSO NEW("FLD") ),$D(RX0), '$G(PSOMTF LG) S PSON EW("QTY")= $S($G(PSON EW("QTY")) :PSONEW("Q TY"),1:$P( RX0,"^",7) )
	7351	"RTN","PSO ORNE3",73, 0)
	7352	;if sched PSONEW("F LD") not d ef. qty re set
	7353	"RTN","PSO ORNE3",74, 0)
	7354	;if qty P SONEW("FLD ")=7, qty NOT reset
	7355	"RTN","PSO ORNE3",75, 0)
	7356	S ^TMP("P SOPO",$J,I EN,0)=^TMP ("PSOPO",$ J,IEN,0)_" (8) QTY "_$S($G(PS ODRUG("UNI T"))]"":" ("_PSODRUG ("UNIT")_" )",1:" ( ) ")_": "_PS ONEW("QTY" )
	7357	"RTN","PSO ORNE3",76, 0)
	7358	I $P($G(^ PSDRUG(+$G (PSODRUG(" IEN")),5)) ,"^")]"" D
	7359	"RTN","PSO ORNE3",77, 0)
	7360	.S $P(RN, " ",79)=" ",IEN=IEN+ 1
	7361	"RTN","PSO ORNE3",78, 0)
	7362	.S ^TMP(" PSOPO",$J, IEN,0)=$E( RN,$L("QTY DSP MSG: "_$P(^PSDR UG(PSODRUG ("IEN"),5) ,"^"))+1,7 9)_"QTY DS P MSG: "_$ P(^PSDRUG( PSODRUG("I EN"),5),"^ ") K RN
	7363	"RTN","PSO ORNE3",79, 0)
	7364	S IEN=IEN +1,^TMP("P SOPO",$J,I EN,0)=" ( 9) # of Refills: " _PSONEW("# OF REFILL S")_$S($L( PSONEW("# OF REFILLS "))=1:" ", 1:"")_" (1 0) Routin g: "_$S($G (PSONEW("M AIL/WINDOW "))="M":"M AIL",1:"WI NDOW")
	7365	"RTN","PSO ORNE3",80, 0)
	7366	S IEN=IEN +1,^TMP("P SOPO",$J,I EN,0)=" (1 1) Clinic: " _$S($G(PSO NEW("CLINI C")):$P(^S C(PSONEW(" CLINIC"),0 ),"^"),1:" ")
	7367	"RTN","PSO ORNE3",81, 0)
	7368	S $P(RN," ",31)=" " ,IEN=IEN+1 ,^TMP("PSO PO",$J,IEN ,0)=" (12) Pro vider: "_P SONEW("PRO VIDER NAME ")_$E(RN,$ L(PSONEW(" PROVIDER N AME"))+1,3 1)_"(13) Copies: " _$S($G(PSO NEW("COPIE S")):PSONE W("COPIES" ),1:1) K R N
	7369	"RTN","PSO ORNE3",82, 0)
	7370	;*545 DEA /Detox exi st then di splay
	7371	"RTN","PSO ORNE3",83, 0)
	7372	I '$L($G( PSORX("RXD EA")))&($L ($G(PSONEW ("DEA")))) S PSORX(" RXDEA")=PS ONEW("DEA" )
	7373	"RTN","PSO ORNE3",84, 0)
	7374	I '$L($G( PSORX("DET X")))&($L( $G(PSONEW( "DETX")))) S PSORX(" DETX")=PSO NEW("DETX" )
	7375	"RTN","PSO ORNE3",85, 0)
	7376	I $L($G(P SORX("RXDE A"))) S IE N=IEN+1,^T MP("PSOPO" ,$J,IEN,0) =" DE A#: "_PSOR X("RXDEA") D
	7377	"RTN","PSO ORNE3",86, 0)
	7378	. I $L($G (PSORX("DE TX"))) S ^ TMP("PSOPO ",$J,IEN,0 )=^TMP("PS OPO",$J,IE N,0)_" DETOX#: "_ PSORX("DET X")
	7379	"RTN","PSO ORNE3",87, 0)
	7380	I $G(PKI) ,+$G(PSODR UG("DEA")) >1,+$G(PSO DRUG("DEA" ))<6 D PRV ^PSOORFI5( $G(PSONEW( "PROVIDER" )),$G(PSOD RUG("IEN") ),$P(OR0," ^"))
	7381	"RTN","PSO ORNE3",88, 0)
	7382	I $G(PSON EW("COSIGN ING PROVID ER"))]"" S IEN=IEN+1 ,^TMP("PSO PO",$J,IEN ,0)=" Cos-Pro vider: "_$ P(^VA(200, PSONEW("CO SIGNING PR OVIDER"),0 ),"^")
	7383	"RTN","PSO ORNE3",89, 0)
	7384	S IEN=IEN +1,^TMP("P SOPO",$J,I EN,0)=" (1 4) Remarks:"
	7385	"RTN","PSO ORNE3",90, 0)
	7386	I $G(PSON EW("REMARK S"))]"" D
	7387	"RTN","PSO ORNE3",91, 0)
	7388	.F SG=1:1 :$L(PSONEW ("REMARKS" )) S:$L(^T MP("PSOPO" ,$J,IEN,0) _" "_$P(PS ONEW("REMA RKS")," ", SG))>80 IE N=IEN+1,$P (^TMP("PSO PO",$J,IEN ,0)," ",21 )=" " D
	7389	"RTN","PSO ORNE3",92, 0)
	7390	..S:$P(PS ONEW("REMA RKS")," ", SG)'="" ^T MP("PSOPO" ,$J,IEN,0) =$G(^TMP(" PSOPO",$J, IEN,0))_" "_$P(PSONE W("REMARKS ")," ",SG)
	7391	"RTN","PSO ORNE3",93, 0)
	7392	I $G(PSOR XED("IRXN" )),'$G(PSO SIGFL) S R XN=PSORXED ("IRXN") D :'$G(COPY) PC1^PSOOR NE5 K RXN
	7393	"RTN","PSO ORNE3",94, 0)
	7394	S $P(RN," ",35)=" " ,IEN=IEN+1 ,^TMP("PSO PO",$J,IEN ,0)=" En try By: "_ $P(^VA(200 ,DUZ,0),"^ ")_$E(RN,$ L($P(^VA(2 00,DUZ,0), "^"))+1,35 )
	7395	"RTN","PSO ORNE3",95, 0)
	7396	D NOW^%DT C S PSONEW ("LOGIN DA TE")=% K % ,X S Y=PSO NEW("LOGIN DATE") X ^DD("DD")
	7397	"RTN","PSO ORNE3",96, 0)
	7398	S ^TMP("P SOPO",$J,I EN,0)=^TMP ("PSOPO",$ J,IEN,0)_" Entry Date : "_$P(Y," @")_" "_$P (Y,"@",2) K RN,PSOFD R
	7399	"RTN","PSO ORNE3",97, 0)
	7400	S (VALMCN T,PSOPF)=I EN Q
	7401	"RTN","PSO ORNE3",98, 0)
	7402	SIG ;
	7403	"RTN","PSO ORNE3",99, 0)
	7404	D SIG^PSO ORNE6 Q
	7405	"RTN","PSO ORNE3",100 ,0)
	7406	CMOP ;
	7407	"RTN","PSO ORNE3",101 ,0)
	7408	K PSXZ S X="PSXOPUT L" X ^%ZOS F("TEST") K X I D
	7409	"RTN","PSO ORNE3",102 ,0)
	7410	.S DA=RXN D ^PSXOPU TL K DA,PS OCMOP
	7411	"RTN","PSO ORNE3",103 ,0)
	7412	.S PSOCMO P=$S($G(PS XZ(PSXZ("L ")))=0!($G (PSXZ(PSXZ ("L")))=2) :"Transmit ted",$G(PS XZ(PSXZ("L ")))=1:"Re leased",$G (PSXZ(PSXZ ("L")))=3: "Not Dispe nsed",1:"" )
	7413	"RTN","PSO ORNE3",104 ,0)
	7414	.I $G(PSX Z(PSXZ("L" )))=3 F LB L=0:0 S LB L=$O(^PSRX (RXN,"L",L BL)) Q:'LB L I $P(^P SRX(RXN,"L ",LBL,0)," ^",2)=PSXZ ("L"),'$P( ^(0),"^",5 ),$P(^(0), "^",3)'["I NTERACTION " S PSOCMO P="Local"
	7415	"RTN","PSO ORNE3",105 ,0)
	7416	.K PSXZ
	7417	"RTN","PSO ORNE3",106 ,0)
	7418	Q
	7419	"RTN","PSO ORNE3",107 ,0)
	7420	RST ;
	7421	"RTN","PSO ORNE3",108 ,0)
	7422	S PSODRUG ("IEN")=$P (RX0,"^",6 ),PSODRUG( "OI")=$P(^ PSDRUG(($P (RX0,"^",6 )),2),"^")
	7423	"RTN","PSO ORNE3",109 ,0)
	7424	S PSODRUG ("NAME")=$ P(^PSDRUG( ($P(RX0,"^ ",6)),0)," ^")
	7425	"RTN","PSO ORNE3",110 ,0)
	7426	Q
	7427	"RTN","PSO ORNE3",111 ,0)
	7428	RMK ;
	7429	"RTN","PSO ORNE3",112 ,0)
	7430	I $P(RX3, "^",7)]"" D
	7431	"RTN","PSO ORNE3",113 ,0)
	7432	.F SG=1:1 :$L($P(RX3 ,"^",7)) S :$L(^TMP(" PSOAO",$J, IEN,0)_" " _$P($P(RX3 ,"^",7)," ",SG))>80 IEN=IEN+1, $P(^TMP("P SOAO",$J,I EN,0)," ", 21)=" " D
	7433	"RTN","PSO ORNE3",114 ,0)
	7434	..S:$P($P (RX3,"^",7 )," ",SG)' ="" ^TMP(" PSOAO",$J, IEN,0)=$G( ^TMP("PSOA O",$J,IEN, 0))_" "_$P ($P(RX3,"^ ",7)," ",S G)
	7435	"RTN","PSO ORNE3",115 ,0)
	7436	Q
	7437	"RTN","PSO ORNE5")
	7438	0^17^B5473 7100
	7439	"RTN","PSO ORNE5",1,0 )
	7440	PSOORNE5 ; BIR/SAB - display or ders from backdoor c on't ;5/10 /07 8:29am
	7441	"RTN","PSO ORNE5",2,0 )
	7442	;;7.0;OUT PATIENT PH ARMACY;1 1,27,32,46 ,78,99,117 ,131,146,1 71,180,210 ,222,268,2 06,225,391 ,444,504,5 45;DEC 1 997;Build 21
	7443	"RTN","PSO ORNE5",3,0 )
	7444	;External reference to ^PSDRU G supporte d by DBIA 221
	7445	"RTN","PSO ORNE5",4,0 )
	7446	;External reference s L and UL ^PSSLOCK s upported b y DBIA 278 9
	7447	"RTN","PSO ORNE5",5,0 )
	7448	;External reference to ^PS(51 .2 support ed by DBIA 2226
	7449	"RTN","PSO ORNE5",6,0 )
	7450	;External reference to ^PS(50 .607 suppo rted by DB IA 2221
	7451	"RTN","PSO ORNE5",7,0 )
	7452	;External reference ^PS(55 su pported by DBIA 2228
	7453	"RTN","PSO ORNE5",8,0 )
	7454	;called f rom PSOORN E2
	7455	"RTN","PSO ORNE5",9,0 )
	7456	;PSO*210 add call t o WORDWRAP api
	7457	"RTN","PSO ORNE5",10, 0)
	7458	;
	7459	"RTN","PSO ORNE5",11, 0)
	7460	PEN ;pendi ng orders
	7461	"RTN","PSO ORNE5",12, 0)
	7462	K ^TMP("P SOPO",$J), PSORX("ISS UE DATE"), PSORX("FIL L DATE") S ORSV=ORD, ORD=$P(PSO LST(ORN)," ^",2)
	7463	"RTN","PSO ORNE5",13, 0)
	7464	I $P($G(^ PS(52.41,O RD,0)),"^" ,3)="DC"!( $P($G(^(0) ),"^",3)=" DE") S VAL MBCK="R" Q
	7465	"RTN","PSO ORNE5",14, 0)
	7466	I $G(PSOD FN)'=$P($G (^PS(52.41 ,ORD,0))," ^",2) S VA LMBCK="" Q
	7467	"RTN","PSO ORNE5",15, 0)
	7468	I $G(PSOT PBFG) N PS OTPPEN,PSO TPPEX S PS OTPPEN=ORD ,PSOTPPEX= 0 D VOPNR^ PSOTPCAN I PSOTPPEX K PSOTPPEX ,PSOTPPEN S VALMBCK= "R" Q
	7469	"RTN","PSO ORNE5",16, 0)
	7470	K PSOTPPE X,PSOTPPEN
	7471	"RTN","PSO ORNE5",17, 0)
	7472	I '$G(PSO FIN) S PSO PLCK=$$L^P SSLOCK(PSO DFN,0) I ' $G(PSOPLCK ) S VALMSG =$S($P($G( PSOPLCK)," ^",2)'="": $P($G(PSOP LCK),"^",2 )_" is wor king on th is patient .",1:"Anot her person is enteri ng orders for this p atient."), VALMBCK="" K PSOPLCK Q
	7473	"RTN","PSO ORNE5",18, 0)
	7474	K PSOPLCK
	7475	"RTN","PSO ORNE5",19, 0)
	7476	S PSODRG= +$P($G(^PS (52.41,ORD ,0)),"^",9 ) I $G(^PS DRUG(PSODR G,"I"))]"" ,DT>$G(^(" I")) S VAL MSG="This Drug has b een Inacti vated."
	7477	"RTN","PSO ORNE5",20, 0)
	7478	I $P($G(^ PS(52.41,O RD,0)),"^" ,24) S PSO ACT=$S($D( ^XUSEC("PS DRPH",DUZ) ):"DEFX",$ D(^XUSEC(" PSORPH",DU Z)):"F",$P ($G(PSOPAR ),"^",2):" F",1:"")
	7479	"RTN","PSO ORNE5",21, 0)
	7480	E S PSOA CT=$S($D(^ XUSEC("PSO RPH",DUZ)) :"DEFX",'$ D(^XUSEC(" PSORPH",DU Z))&($P($G (PSOPAR)," ^",2)):"F" ,1:"")
	7481	"RTN","PSO ORNE5",22, 0)
	7482	K PSOMSG
	7483	"RTN","PSO ORNE5",23, 0)
	7484	OK S PAT=P SODFN,PSOR NSV=ORN,PS ORNLT=PSLS T D ORD^PS OORFIN S P SLST=PSORN LT,ORD=ORS V,ORN=PSOR NSV K ORSV ,PSORNSV,P SORNLT,PSO DRUG S VAL MBCK="R"
	7485	"RTN","PSO ORNE5",24, 0)
	7486	K ORCHK,O RDRG,PSOFD R,SIGOK,PS ONEW,PSORX ("ISSUE DA TE"),PSORX ("FILL DAT E"),PSORX( "FN")
	7487	"RTN","PSO ORNE5",25, 0)
	7488	K:'$G(MED P) PAT
	7489	"RTN","PSO ORNE5",26, 0)
	7490	D CLEAN^P SOVER1
	7491	"RTN","PSO ORNE5",27, 0)
	7492	I '$G(PSO FIN) D UL^ PSSLOCK(PS ODFN)
	7493	"RTN","PSO ORNE5",28, 0)
	7494	Q
	7495	"RTN","PSO ORNE5",29, 0)
	7496	RXNCHK S P SOY=$O(PSO NEW("OLD L AST RX#"," ")) I PSOY ="" D AUTO ^PSONRXN Q
	7497	"RTN","PSO ORNE5",30, 0)
	7498	S PSONRXN ("TYPE")=$ S('+$G(^PS (59,+PSOSI TE,2)):8,P SODRUG("DE A")["A"&(+ $G(^PS(59, +PSOSITE,2 ))):3,1:8)
	7499	"RTN","PSO ORNE5",31, 0)
	7500	S PSONEW( "QFLG")=0 I PSOY'=PS ONRXN("TYP E"),$P($G( PSOPAR),"^ ",7)=1 D
	7501	"RTN","PSO ORNE5",32, 0)
	7502	.S DIE="^ PS(59,",DA =PSOSITE,P SOX=PSONEW ("OLD LAST RX#",PSOY )
	7503	"RTN","PSO ORNE5",33, 0)
	7504	.L +^PS(5 9,+PSOSITE ,PSOY):$S( +$G(^DD("D ILOCKTM")) >0:+^DD("D ILOCKTM"), 1:3)
	7505	"RTN","PSO ORNE5",34, 0)
	7506	.S DR=$S( PSOY=8:"20 03////"_PS OX,PSOY=3: "1002.1/// /"_PSOX,1: "2003////" _PSOX)
	7507	"RTN","PSO ORNE5",35, 0)
	7508	.D:PSOX<$ P(^PS(59,+ PSOSITE,PS OY),"^",3) ^DIE K DI E,X,Y L -^ PS(59,+PSO SITE,PSOY)
	7509	"RTN","PSO ORNE5",36, 0)
	7510	.L +^PS(5 9,+PSOSITE ,PSONRXN(" TYPE")):$S (+$G(^DD(" DILOCKTM") )>0:+^DD(" DILOCKTM") ,1:3)
	7511	"RTN","PSO ORNE5",37, 0)
	7512	.S PSOX1= ^PS(59,+PS OSITE,PSON RXN("TYPE" )),PSONRXN ("LO")=$P( PSOX1,"^")
	7513	"RTN","PSO ORNE5",38, 0)
	7514	.S PSONRX N("HI")=$P (PSOX1,"^" ,2),PSOI=$ P(PSOX1,"^ ",3),PSONE W("OLD LAS T RX#",PSO NRXN("TYPE "))=PSOI
	7515	"RTN","PSO ORNE5",39, 0)
	7516	.S:PSOI<P SONRXN("LO ") PSOI=PS ONRXN("LO" )
	7517	"RTN","PSO ORNE5",40, 0)
	7518	.D LOOP2 I PSONEW(" QFLG") L - ^PS(59,+PS OSITE,PSON RXN("TYPE" )),-^PSRX( "B",PSOI) Q
	7519	"RTN","PSO ORNE5",41, 0)
	7520	.K DIC,DI E,DA S DIE =59,DA=PSO SITE
	7521	"RTN","PSO ORNE5",42, 0)
	7522	.S DR=$S( PSONRXN("T YPE")=8:"2 003////"_P SOI,PSONRX N("TYPE")= 3:"1002.1/ ///"_PSOI, 1:"2003/// /"_PSOI)
	7523	"RTN","PSO ORNE5",43, 0)
	7524	.S PSONEW ("RX #")=P SOI D ^DIE K DIE,DIC ,DR,DA L - ^PS(59,+PS OSITE,PSON RXN("TYPE" ))
	7525	"RTN","PSO ORNE5",44, 0)
	7526	.K PSOX1, PSONRXN,PS OI,X,Y
	7527	"RTN","PSO ORNE5",45, 0)
	7528	Q
	7529	"RTN","PSO ORNE5",46, 0)
	7530	LOOP2 F S PSOI=PSOI +1 D:PSOI> PSONRXN("H I") FATAL^ PSONRXN Q: '$D(^PSRX( "B",PSOI)) !PSONEW("Q FLG")
	7531	"RTN","PSO ORNE5",47, 0)
	7532	L +^PSRX( "B",PSOI): $S(+$G(^DD ("DILOCKTM "))>0:+^DD ("DILOCKTM "),1:3) I $D(^PSRX(" B",PSOI))! '$T G LOOP 2
	7533	"RTN","PSO ORNE5",48, 0)
	7534	L -^PSRX( "B",PSOI)
	7535	"RTN","PSO ORNE5",49, 0)
	7536	Q
	7537	"RTN","PSO ORNE5",50, 0)
	7538	RDSPL ;
	7539	"RTN","PSO ORNE5",51, 0)
	7540	; Retriev ing the Ma ximum Numb er of Refi lls allowe d
	7541	"RTN","PSO ORNE5",52, 0)
	7542	N MAXRF S MAXRF=$$M AXNUMRF^PS OUTIL(+$G( PSODRUG("I EN")),+$G( PSONEW("DA YS SUPPLY" )),+$G(PSO NEW("PATIE NT STATUS" )),.CLOZPA T)
	7543	"RTN","PSO ORNE5",53, 0)
	7544	S (PSONEW ("# OF REF ILLS"),PSO NEW("N# RE F"))=$S(($ G(PSONEW(" # OF REFIL LS"))'="") &($G(PSONE W("# OF RE FILLS"))'> MAXRF):PSO NEW("# OF REFILLS"), 1:MAXRF)
	7545	"RTN","PSO ORNE5",54, 0)
	7546	Q
	7547	"RTN","PSO ORNE5",55, 0)
	7548	;
	7549	"RTN","PSO ORNE5",56, 0)
	7550	GET ;
	7551	"RTN","PSO ORNE5",57, 0)
	7552	I $P(PSOD RUG0,"^",3 )["2" S (A CTREF,ACTR EN)=0 Q
	7553	"RTN","PSO ORNE5",58, 0)
	7554	S (ACTREF ,ACTREN)=1
	7555	"RTN","PSO ORNE5",59, 0)
	7556	;refills
	7557	"RTN","PSO ORNE5",60, 0)
	7558	I ST S AC TREF=0
	7559	"RTN","PSO ORNE5",61, 0)
	7560	I '$P(PSO PAR,"^",11 ),$G(^PSDR UG(PSODRG, "I"))]"",D T>$G(^("I" )) S ACTRE F=0,VALMSG ="Inactive Drug, Non Refillabl e!"
	7561	"RTN","PSO ORNE5",62, 0)
	7562	S PSORFRM =$P(RX0,"^ ",9) F PSO J=0:0 S PS OJ=$O(^PSR X(RXN,1,PS OJ)) Q:'PS OJ S PSOR FRM=PSORFR M-1
	7563	"RTN","PSO ORNE5",63, 0)
	7564	S:PSORFRM <0 PSORFRM =0 S:PSORF RM=0 ACTRE F=0
	7565	"RTN","PSO ORNE5",64, 0)
	7566	I $G(RXFL (RXN))]"", '$P(PSOPAR ,"^",6) S ACTREF=0
	7567	"RTN","PSO ORNE5",65, 0)
	7568	I $P(PSOD RUG0,"^",3 )["A"&($P( PSODRUG0," ^",3)'["B" )!($P(PSOD RUG0,"^",3 )["F")!($P (PSODRUG0, "^",3)[1)! ($P(PSODRU G0,"^",3)[ 2) S ACTRE F=0
	7569	"RTN","PSO ORNE5",66, 0)
	7570	;renews
	7571	"RTN","PSO ORNE5",67, 0)
	7572	I $P(PSOP AR,"^",4)= 0 S ACTREN =0 Q
	7573	"RTN","PSO ORNE5",68, 0)
	7574	I $P($G(^ PSDRUG(PSO DRG,2)),"^ ",3)'["O" S ACTREN=0
	7575	"RTN","PSO ORNE5",69, 0)
	7576	I $G(^PSD RUG(PSODRG ,"I"))]"", DT>$G(^("I ")) S ACTR EN=0,VALMS G="This Dr ug has bee n Inactiva ted."
	7577	"RTN","PSO ORNE5",70, 0)
	7578	I '$P($G( ^PSDRUG(PS ODRG,2))," ^"),'$P($G (^PSRX(RXN ,"OR1"))," ^") S ACTR EN=0,VALMS G="Drug mu st be Matc hed to an Orderable Item!"
	7579	"RTN","PSO ORNE5",71, 0)
	7580	I ($P(PSO DRUG0,"^", 3)["W")!($ P(PSODRUG0 ,"^",3)[1) !($P(PSODR UG0,"^",3) [2) S ACTR EN=0
	7581	"RTN","PSO ORNE5",72, 0)
	7582	I $D(^PS( 53,+$P(RX0 ,"^",3),0) ),'$P(^(0) ,"^",5) S ACTREN=0
	7583	"RTN","PSO ORNE5",73, 0)
	7584	S PSOLC=$ P(RX0,"^") ,PSOLC=$E( PSOLC,$L(P SOLC)) I $ A(PSOLC)'< 90 S ACTRE N=0
	7585	"RTN","PSO ORNE5",74, 0)
	7586	I ST,ST'= 2,ST'=5,ST '=6,ST'=11 ,ST'=12 S ACTREN=0
	7587	"RTN","PSO ORNE5",75, 0)
	7588	K PSORFRM ,PSOLC,PSO DRG,PSODRU G0
	7589	"RTN","PSO ORNE5",76, 0)
	7590	Q
	7591	"RTN","PSO ORNE5",77, 0)
	7592	INST ;form ats instru ction from front doo r
	7593	"RTN","PSO ORNE5",78, 0)
	7594	D INST^PS OORNE6 Q
	7595	"RTN","PSO ORNE5",79, 0)
	7596	PC ;displa ys provide r comments
	7597	"RTN","PSO ORNE5",80, 0)
	7598	D PC^PSOO RNE6 Q
	7599	"RTN","PSO ORNE5",81, 0)
	7600	INST1 ;for mats instr uction fro m front do or
	7601	"RTN","PSO ORNE5",82, 0)
	7602	D INST1^P SOORNE6 Q
	7603	"RTN","PSO ORNE5",83, 0)
	7604	PC1 ;displ ays provid er comment s
	7605	"RTN","PSO ORNE5",84, 0)
	7606	D PC1^PSO ORNE6 Q
	7607	"RTN","PSO ORNE5",85, 0)
	7608	DOSE ;disp lays dosin g instruct ion for bo th simple and comple x backdoor Rxs.
	7609	"RTN","PSO ORNE5",86, 0)
	7610	I '$O(^PS RX(RXN,6,0 )) S IEN= IEN+1,^TMP ("PSOAO",$ J,IEN,0)=" (3) Dosage : " Q
	7611	"RTN","PSO ORNE5",87, 0)
	7612	S DS=1 F I=0:0 S I= $O(^PSRX(R XN,6,I)) Q :'I S DOS E=^PSRX(RX N,6,I,0) D
	7613	"RTN","PSO ORNE5",88, 0)
	7614	.I '$P(DO SE,"^",2), $P(DOSE,"^ ",9)]"" S IEN=IEN+1, ^TMP("PSOA O",$J,IEN, 0)=" Verb: "_$P (DOSE,"^", 9)
	7615	"RTN","PSO ORNE5",89, 0)
	7616	.I $G(DS) =1 S IEN=I EN+1,^TMP( "PSOAO",$J ,IEN,0)=" (3)"
	7617	"RTN","PSO ORNE5",90, 0)
	7618	.D DOSE1 S PSORXED( "ENT")=$G( PSORXED("E NT"))+1
	7619	"RTN","PSO ORNE5",91, 0)
	7620	K DOSE,I
	7621	"RTN","PSO ORNE5",92, 0)
	7622	Q
	7623	"RTN","PSO ORNE5",93, 0)
	7624	DOSE1 ;
	7625	"RTN","PSO ORNE5",94, 0)
	7626	I $G(DS)= 1 S ^TMP(" PSOAO",$J, IEN,0)=^TM P("PSOAO", $J,IEN,0)_ " *Dosage: " _$S($E($P( DOSE,"^"), 1)="."&($P (DOSE,"^", 2)):"0",1: "")_$P(DOS E,"^")_$S( $P(DOSE,"^ ",3)]"":" ("_$P(^PS( 50.607,$P( DOSE,"^",3 ),0),"^")_ ")",1:"") K DS G DU
	7627	"RTN","PSO ORNE5",95, 0)
	7628	S IEN=IEN +1,^TMP("P SOAO",$J,I EN,0)=" *Dosage: " _$S($E($P( DOSE,"^"), 1)="."&($P (DOSE,"^", 2)):"0",1: "")_$P(DOS E,"^")_$S( $P(DOSE,"^ ",3)]"":" ("_$P(^PS( 50.607,$P( DOSE,"^",3 ),0),"^")_ ")",1:"")
	7629	"RTN","PSO ORNE5",96, 0)
	7630	DU I '$P(D OSE,"^",2) ,$P($G(^PS (55,PSODFN ,"LAN"))," ^") S IEN= IEN+1,^TMP ("PSOAO",$ J,IEN,0)=" Oth. La ng. Dosage : "_$G(^PS RX(RXN,6,I ,1))
	7631	"RTN","PSO ORNE5",97, 0)
	7632	I $P(DOSE ,"^",2),$P (DOSE,"^", 9)]"" D
	7633	"RTN","PSO ORNE5",98, 0)
	7634	.S IEN=IE N+1,^TMP(" PSOAO",$J, IEN,0)=" Verb: "_$P(DOSE, "^",9)
	7635	"RTN","PSO ORNE5",99, 0)
	7636	.S IEN=IE N+1,^TMP(" PSOAO",$J, IEN,0)=" Dispen se Units: "_$S($E($P (DOSE,"^", 2),1)=".": "0",1:"")_ $P(DOSE,"^ ",2)
	7637	"RTN","PSO ORNE5",100 ,0)
	7638	.S IEN=IE N+1,^TMP(" PSOAO",$J, IEN,0)=" Noun: "_$P(DOSE, "^",4)
	7639	"RTN","PSO ORNE5",101 ,0)
	7640	I $P(DOSE ,"^",7) S IEN=IEN+1, ^TMP("PSOA O",$J,IEN, 0)=" *R oute: "_$P (^PS(51.2, $P(DOSE,"^ ",7),0),"^ ")
	7641	"RTN","PSO ORNE5",102 ,0)
	7642	S IEN=IEN +1,^TMP("P SOAO",$J,I EN,0)=" *S chedule: " _$P(DOSE," ^",8)
	7643	"RTN","PSO ORNE5",103 ,0)
	7644	I $P(DOSE ,"^",5)]"" D
	7645	"RTN","PSO ORNE5",104 ,0)
	7646	.S DUR=$S ($E($P(DOS E,"^",5),1 )'?.N:$E($ P(DOSE,"^" ,5),2,99)_ $E($P(DOSE ,"^",5),1) ,1:$P(DOSE ,"^",5))
	7647	"RTN","PSO ORNE5",105 ,0)
	7648	.S IEN=IE N+1,^TMP(" PSOAO",$J, IEN,0)=" * Duration: "_DUR_" (" _$S($P(DOS E,"^",5)[" M":"MINUTE S",$P(DOSE ,"^",5)["H ":"HOURS", $P(DOSE,"^ ",5)["L":" MONTHS",$P (DOSE,"^", 5)["W":"WE EKS",1:"DA YS")_")" K DUR
	7649	"RTN","PSO ORNE5",106 ,0)
	7650	I $P(DOSE ,"^",6)]"" S IEN=IEN +1,^TMP("P SOAO",$J,I EN,0)=" *Conj unction: " _$S($P(DOS E,"^",6)=" A":"AND",$ P(DOSE,"^" ,6)="T":"T HEN",$P(DO SE,"^",6)= "X":"EXCEP T",1:"")
	7651	"RTN","PSO ORNE5",107 ,0)
	7652	Q
	7653	"RTN","PSO ORNE5",108 ,0)
	7654	INS ;patie nt instruc tions ;PSO* 210
	7655	"RTN","PSO ORNE5",109 ,0)
	7656	I $G(^PSR X(RXN,"INS "))]"",'$O (^PSRX(RXN ,"INS1",0) ) D K SG G SPINS
	7657	"RTN","PSO ORNE5",110 ,0)
	7658	.S PSORXE D("SIG",1) =^PSRX(RXN ,"INS")
	7659	"RTN","PSO ORNE5",111 ,0)
	7660	.D WORDWR AP^PSOUTLA 2(^PSRX(RX N,"INS"),. IEN,$NA(^T MP("PSOAO" ,$J)),21)
	7661	"RTN","PSO ORNE5",112 ,0)
	7662	;
	7663	"RTN","PSO ORNE5",113 ,0)
	7664	I $O(^PSR X(RXN,"INS 1",0)) D
	7665	"RTN","PSO ORNE5",114 ,0)
	7666	.S T=0 F S T=$O(^P SRX(RXN,"I NS1",T)) Q :'T D
	7667	"RTN","PSO ORNE5",115 ,0)
	7668	.. S (PSO RXED("SIG" ,T),MIG)=^ PSRX(RXN," INS1",T,0)
	7669	"RTN","PSO ORNE5",116 ,0)
	7670	.. D WORD WRAP^PSOUT LA2(MIG,.I EN,$NA(^TM P("PSOAO", $J)),21)
	7671	"RTN","PSO ORNE5",117 ,0)
	7672	SPINS K T, SG,MIG
	7673	"RTN","PSO ORNE5",118 ,0)
	7674	I $P($G(^ PS(55,PSOD FN,"LAN")) ,"^") S IE N=IEN+1,^T MP("PSOAO" ,$J,IEN,0) =" Other Pat. Instr uc: "_$S($ G(^PSRX(RX N,"INSS")) ]"":^PSRX( RXN,"INSS" ),1:"")
	7675	"RTN","PSO ORNE5",119 ,0)
	7676	Q
	7677	"RTN","PSO ORNE5",120 ,0)
	7678	SV S VALMS G="Pre-POE Rx. Pleas e Compare Dosing Fie lds with S IG!"
	7679	"RTN","PSO ORNE5",121 ,0)
	7680	Q
	7681	"RTN","PSO ORNE5",122 ,0)
	7682	PRV ;
	7683	"RTN","PSO ORNE5",123 ,0)
	7684	N DETN,DE A,I,LBL,VA DD,SPC,ORN S ORN=ORD
	7685	"RTN","PSO ORNE5",124 ,0)
	7686	S DEA=$$R XDEA^PSOUT IL(+$G(RXN ))
	7687	"RTN","PSO ORNE5",125 ,0)
	7688	;*545 - s how only D EA label
	7689	"RTN","PSO ORNE5",126 ,0)
	7690	S LBL=" D EA#: "
	7691	"RTN","PSO ORNE5",127 ,0)
	7692	I $$DETOX ^PSSOPKI($ P(RX0,"^", 6)) S DETN =$$RXDETOX ^PSOUTIL(+ $G(RXN))
	7693	"RTN","PSO ORNE5",128 ,0)
	7694	S $P(SPC, " ",(28-$L (DEA)))=" "
	7695	"RTN","PSO ORNE5",129 ,0)
	7696	I (DEA'=" ")!($G(DET N)'="") S IEN=IEN+1, $E(^TMP("P SOAO",$J,I EN,0),16)= LBL_DEA_$S ($G(DETN)] "":SPC_"DE TOX#: "_$G (DETN),1:" ")
	7697	"RTN","PSO ORNE5",130 ,0)
	7698	D PRVAD^P SOPKIV2
	7699	"RTN","PSO ORNE5",131 ,0)
	7700	I $G(VADD (1))]"" D
	7701	"RTN","PSO ORNE5",132 ,0)
	7702	.S IEN=IE N+1,^TMP(" PSOAO",$J, IEN,0)=" Site Address: "_VADD(1)
	7703	"RTN","PSO ORNE5",133 ,0)
	7704	.S:VADD(2 )'="" IEN= IEN+1,^TMP ("PSOAO",$ J,IEN,0)=" "_VADD(2 ) S:VADD(3 )'="" IEN= IEN+1,^TMP ("PSOAO",$ J,IEN,0)=" "_VADD(3 )
	7705	"RTN","PSO ORNE5",134 ,0)
	7706	Q
	7707	"RTN","PSO OTMRX")
	7708	0^16^B2630 9199
	7709	"RTN","PSO OTMRX",1,0 )
	7710	PSOOTMRX ; BIR/MFR - Titration/ Maintenanc e Dose Pre scription ;10/17/96
	7711	"RTN","PSO OTMRX",2,0 )
	7712	;;7.0;OUT PATIENT PH ARMACY;3 13,505,517 ,545;DEC 1997;Buil d 21
	7713	"RTN","PSO OTMRX",3,0 )
	7714	;External reference to ULK^OR X2 support ed by DBIA 867
	7715	"RTN","PSO OTMRX",4,0 )
	7716	;External reference to UL^PSS LOCK suppo rted by DB IA 2789
	7717	"RTN","PSO OTMRX",5,0 )
	7718	;
	7719	"RTN","PSO OTMRX",6,0 )
	7720	TIMTRX ; T itration/M aintenance Dose Rx H idden Acti on Entry P oint
	7721	"RTN","PSO OTMRX",7,0 )
	7722	N PSOMTFL G,PSOTITRX ,PSORXIEN, LASTDOSE,B EFLST,DOSE INFO,DEA,L AB
	7723	"RTN","PSO OTMRX",8,0 )
	7724	S PSORXIE N=$P(PSOLS T(ORN),"^" ,2)
	7725	"RTN","PSO OTMRX",9,0 )
	7726	;
	7727	"RTN","PSO OTMRX",10, 0)
	7728	; - Rx al ready mark ed Mainten ance
	7729	"RTN","PSO OTMRX",11, 0)
	7730	I $$TITRX ^PSOUTL(PS ORXIEN)="m " D Q
	7731	"RTN","PSO OTMRX",12, 0)
	7732	. S VALMS G="Prescri ption alre ady marked as 'Maint enance Rx' .",VALMBCK ="R" W $C( 7)
	7733	"RTN","PSO OTMRX",13, 0)
	7734	;
	7735	"RTN","PSO OTMRX",14, 0)
	7736	; - Rx al ready spli t into Mai ntenance R x
	7737	"RTN","PSO OTMRX",15, 0)
	7738	I $P($G(^ PSRX(PSORX IEN,"TIT") ),"^",2) D Q
	7739	"RTN","PSO OTMRX",16, 0)
	7740	. S VALMS G="A Maint enance Rx already ex ists for t his Rx ("_ $$GET1^DIQ (52,$P($G( ^PSRX(PSOR XIEN,"TIT" )),"^",2), .01)_")"
	7741	"RTN","PSO OTMRX",17, 0)
	7742	. S VALMB CK="R" W $ C(7)
	7743	"RTN","PSO OTMRX",18, 0)
	7744	;
	7745	"RTN","PSO OTMRX",19, 0)
	7746	; - Rx wa s Digitall y Signed
	7747	"RTN","PSO OTMRX",20, 0)
	7748	I $$GET1^ DIQ(52,PSO RXIEN,310, "I") D Q
	7749	"RTN","PSO OTMRX",21, 0)
	7750	. S VALMS G="Rx was digitally signed and cannot be converted .",VALMBCK ="R" W $C( 7)
	7751	"RTN","PSO OTMRX",22, 0)
	7752	;
	7753	"RTN","PSO OTMRX",23, 0)
	7754	; - No TH EN conjunc tion for t he last do se
	7755	"RTN","PSO OTMRX",24, 0)
	7756	I '$$LTHE N^PSOUTL(P SORXIEN) D Q
	7757	"RTN","PSO OTMRX",25, 0)
	7758	. S VALMS G="A Titra tion Rx mu st have a THEN conju nction.",V ALMBCK="R" W $C(7)
	7759	"RTN","PSO OTMRX",26, 0)
	7760	;
	7761	"RTN","PSO OTMRX",27, 0)
	7762	; - Rx is not ACTIV E
	7763	"RTN","PSO OTMRX",28, 0)
	7764	I $$GET1^ DIQ(52,PSO RXIEN,100, "I")'=0 D Q
	7765	"RTN","PSO OTMRX",29, 0)
	7766	. S VALMS G="Prescri ption is n ot ACTIVE. ",VALMBCK= "R" W $C(7 )
	7767	"RTN","PSO OTMRX",30, 0)
	7768	;
	7769	"RTN","PSO OTMRX",31, 0)
	7770	; - Rx NO T released
	7771	"RTN","PSO OTMRX",32, 0)
	7772	I '$$RXRL DT^PSOBPSU T(PSORXIEN ,0) D Q
	7773	"RTN","PSO OTMRX",33, 0)
	7774	. S VALMS G="Prescri ption must be RELEAS ED first." ,VALMBCK=" R" W $C(7)
	7775	"RTN","PSO OTMRX",34, 0)
	7776	;
	7777	"RTN","PSO OTMRX",35, 0)
	7778	; - Rx al ready has refills
	7779	"RTN","PSO OTMRX",36, 0)
	7780	I $O(^PSR X(PSORXIEN ,1,0)) D Q
	7781	"RTN","PSO OTMRX",37, 0)
	7782	. S VALMS G="Prescri ption has previously been refi lled.",VAL MBCK="R" W $C(7)
	7783	"RTN","PSO OTMRX",38, 0)
	7784	;
	7785	"RTN","PSO OTMRX",39, 0)
	7786	; - Rx al ready has refills
	7787	"RTN","PSO OTMRX",40, 0)
	7788	I '$$GET1 ^DIQ(52,PS ORXIEN,9) D Q
	7789	"RTN","PSO OTMRX",41, 0)
	7790	. S VALMS G="There a re no refi lls availa ble for th is Rx.",VA LMBCK="R" W $C(7)
	7791	"RTN","PSO OTMRX",42, 0)
	7792	;
	7793	"RTN","PSO OTMRX",43, 0)
	7794	; - Rx no t been mar ked as Tit ration
	7795	"RTN","PSO OTMRX",44, 0)
	7796	I '$P($G( ^PSRX(PSOR XIEN,"TIT" )),"^",3) D Q
	7797	"RTN","PSO OTMRX",45, 0)
	7798	. S VALMS G="Rx has not been m arked as T itration", VALMBCK="R " W $C(7)
	7799	"RTN","PSO OTMRX",46, 0)
	7800	;
	7801	"RTN","PSO OTMRX",47, 0)
	7802	;/BLB/ PS O7517 - Enhanced f unctionali ty to prev ent conver sion of CS rx's to m aintenance
	7803	"RTN","PSO OTMRX",48, 0)
	7804	I $$NDF(P SORXIEN)!( $$CSRX^PSO SPMUT(PSOR XIEN)) D Q
	7805	"RTN","PSO OTMRX",49, 0)
	7806	.S VALMSG ="Rx is a controlled substance and canno t be conve rted.",VAL MBCK="R" W $C(7)
	7807	"RTN","PSO OTMRX",50, 0)
	7808	;
	7809	"RTN","PSO OTMRX",51, 0)
	7810	S PSOMTFL G=1,PSOTIT RX=PSORXIE N
	7811	"RTN","PSO OTMRX",52, 0)
	7812	D COPY^PS OORCPY K P SOMTFLG,PS OTITRX
	7813	"RTN","PSO OTMRX",53, 0)
	7814	;
	7815	"RTN","PSO OTMRX",54, 0)
	7816	Q
	7817	"RTN","PSO OTMRX",55, 0)
	7818	;
	7819	"RTN","PSO OTMRX",56, 0)
	7820	MARKTIT ; Mark Rx as 'Titratio n' Hidden Action Ent ry Point
	7821	"RTN","PSO OTMRX",57, 0)
	7822	N PSORXIE N,CHECK
	7823	"RTN","PSO OTMRX",58, 0)
	7824	S PSORXIE N=$P(PSOLS T(ORN),"^" ,2)
	7825	"RTN","PSO OTMRX",59, 0)
	7826	S CHECK=$ $CHECK(PSO RXIEN)
	7827	"RTN","PSO OTMRX",60, 0)
	7828	I 'CHECK D Q
	7829	"RTN","PSO OTMRX",61, 0)
	7830	. S VALMB CK="R",VAL MSG=$P(CHE CK,"^",2) W $C(7)
	7831	"RTN","PSO OTMRX",62, 0)
	7832	;
	7833	"RTN","PSO OTMRX",63, 0)
	7834	I $G(PSOR XIEN) D MA RK(PSORXIE N,1)
	7835	"RTN","PSO OTMRX",64, 0)
	7836	Q
	7837	"RTN","PSO OTMRX",65, 0)
	7838	;
	7839	"RTN","PSO OTMRX",66, 0)
	7840	END ;
	7841	"RTN","PSO OTMRX",67, 0)
	7842	Q
	7843	"RTN","PSO OTMRX",68, 0)
	7844	;
	7845	"RTN","PSO OTMRX",69, 0)
	7846	MARK(PSORX IEN,REFRES H) ; Mark a non-refi llable Rx as Titrati on
	7847	"RTN","PSO OTMRX",70, 0)
	7848	N CHECK,D IR,PTLOCK, X,Y,DFN,CO MM
	7849	"RTN","PSO OTMRX",71, 0)
	7850	;
	7851	"RTN","PSO OTMRX",72, 0)
	7852	I '$$CHEC K(PSORXIEN ) Q
	7853	"RTN","PSO OTMRX",73, 0)
	7854	;
	7855	"RTN","PSO OTMRX",74, 0)
	7856	D FULL^VA LM1
	7857	"RTN","PSO OTMRX",75, 0)
	7858	W !
	7859	"RTN","PSO OTMRX",76, 0)
	7860	;*545 - d isplaying notificati on
	7861	"RTN","PSO OTMRX",77, 0)
	7862	I $$NDF(P SORXIEN)!( $$CSRX^PSO SPMUT(PSOR XIEN)) D
	7863	"RTN","PSO OTMRX",78, 0)
	7864	.W !,"NOT E: Marking this cont rolled sub stance Rx as a Titra tion presc ription wi ll" W !,"p revent ref ills and r enewals."
	7865	"RTN","PSO OTMRX",79, 0)
	7866	.W !,"You will not be able to convert t he Rx to a maintenan ce prescri ption by t he" W !,"T R Hidden A ction."
	7867	"RTN","PSO OTMRX",80, 0)
	7868	S DIR("A" )="Do you want to "_ $S($$TITRX ^PSOUTL(PS ORXIEN)="t ":"UN",1:" ")_"MARK t his Rx as 'Titration '? "
	7869	"RTN","PSO OTMRX",81, 0)
	7870	I $$TITRX ^PSOUTL(PS ORXIEN)'=" t" S (DIR( "?"),DIR(" ??"))="^D TITHLP^PSO OTMRX"
	7871	"RTN","PSO OTMRX",82, 0)
	7872	S DIR(0)= "YA" D ^DI R I Y'>0 D UNLK S VA LMBCK="R" Q
	7873	"RTN","PSO OTMRX",83, 0)
	7874	;
	7875	"RTN","PSO OTMRX",84, 0)
	7876	W !!,"Upd ating..."
	7877	"RTN","PSO OTMRX",85, 0)
	7878	I '$P($G( ^PSRX(PSOR XIEN,"TIT" )),"^",3) D
	7879	"RTN","PSO OTMRX",86, 0)
	7880	. S $P(^P SRX(PSORXI EN,"TIT"), "^",3)=1,C OMM="MARKE D as Titra tion"
	7881	"RTN","PSO OTMRX",87, 0)
	7882	E D
	7883	"RTN","PSO OTMRX",88, 0)
	7884	. S $P(^P SRX(PSORXI EN,"TIT"), "^",3)="", COMM="UNMA RKED as Ti tration"
	7885	"RTN","PSO OTMRX",89, 0)
	7886	. I ($D(^ PSRX(PSORX IEN,"TIT") )=1),$TR($ G(^PSRX(PS ORXIEN,"TI T")),"^"," ")="" D
	7887	"RTN","PSO OTMRX",90, 0)
	7888	. . K ^PS RX(PSORXIE N,"TIT") ; Clea ning up th e "TIT" su bscript
	7889	"RTN","PSO OTMRX",91, 0)
	7890	D RXACT^P SOBPSU2(PS ORXIEN,,CO MM,"E")
	7891	"RTN","PSO OTMRX",92, 0)
	7892	H 1 W "OK "
	7893	"RTN","PSO OTMRX",93, 0)
	7894	;
	7895	"RTN","PSO OTMRX",94, 0)
	7896	; PSORXED is necess ary to per form a REF RESH only
	7897	"RTN","PSO OTMRX",95, 0)
	7898	I $G(REFR ESH) N PSO RXED S PSO RXED=1 D A CT^PSOORNE 2 S VALMBC K="R"
	7899	"RTN","PSO OTMRX",96, 0)
	7900	;
	7901	"RTN","PSO OTMRX",97, 0)
	7902	Q
	7903	"RTN","PSO OTMRX",98, 0)
	7904	;
	7905	"RTN","PSO OTMRX",99, 0)
	7906	UNLK ; Unl ocks the P atient/Rx
	7907	"RTN","PSO OTMRX",100 ,0)
	7908	S X=PSODF N_";DPT(" D ULK^ORX2
	7909	"RTN","PSO OTMRX",101 ,0)
	7910	D UL^PSSL OCK(PSODFN )
	7911	"RTN","PSO OTMRX",102 ,0)
	7912	Q
	7913	"RTN","PSO OTMRX",103 ,0)
	7914	;
	7915	"RTN","PSO OTMRX",104 ,0)
	7916	CHECK(PSOR XIEN) ; Ch ecks if Rx is eligib le to be M arked as T itration/M aintenance
	7917	"RTN","PSO OTMRX",105 ,0)
	7918	N MSG
	7919	"RTN","PSO OTMRX",106 ,0)
	7920	S MSG=""
	7921	"RTN","PSO OTMRX",107 ,0)
	7922	; - Rx al ready mark ed as Mai ntenance
	7923	"RTN","PSO OTMRX",108 ,0)
	7924	I $$TITRX ^PSOUTL(PS ORXIEN)="m " D Q ("0 ^"_MSG)
	7925	"RTN","PSO OTMRX",109 ,0)
	7926	. S MSG=" Prescripti on already marked as 'Maintena nce Rx'."
	7927	"RTN","PSO OTMRX",110 ,0)
	7928	;
	7929	"RTN","PSO OTMRX",111 ,0)
	7930	; - No TH EN conjunc tion for t he last do se
	7931	"RTN","PSO OTMRX",112 ,0)
	7932	I '$$LTHE N^PSOUTL(P SORXIEN) D Q ("0^"_ MSG)
	7933	"RTN","PSO OTMRX",113 ,0)
	7934	. S MSG=" A TITRATIO N Rx must have a THE N conjunct ion."
	7935	"RTN","PSO OTMRX",114 ,0)
	7936	;
	7937	"RTN","PSO OTMRX",115 ,0)
	7938	;
	7939	"RTN","PSO OTMRX",116 ,0)
	7940	; - Rx is not ACTIV E or SUSPE NDED
	7941	"RTN","PSO OTMRX",117 ,0)
	7942	I $$GET1^ DIQ(52,PSO RXIEN,100, "I")'=0,$$ GET1^DIQ(5 2,PSORXIEN ,100,"I")' =5 D Q (" 0^"_MSG)
	7943	"RTN","PSO OTMRX",118 ,0)
	7944	. S MSG=" Prescripti on must be ACTIVE or SUSPENDED ."
	7945	"RTN","PSO OTMRX",119 ,0)
	7946	;
	7947	"RTN","PSO OTMRX",120 ,0)
	7948	Q 1
	7949	"RTN","PSO OTMRX",121 ,0)
	7950	;
	7951	"RTN","PSO OTMRX",122 ,0)
	7952	TITHLP ; H elp Text f or Mark Rx as Titrat ion/Mainte nance prom pt
	7953	"RTN","PSO OTMRX",123 ,0)
	7954	W !?5,"An swer YES i f this is a Titratio n to Maint enance pre scription. "
	7955	"RTN","PSO OTMRX",124 ,0)
	7956	W !?5,"Ac tions such as Renewa l (includi ng from CP RS), Refil l, and Cop y"
	7957	"RTN","PSO OTMRX",125 ,0)
	7958	W !?5,"ar e not allo wed on pre scriptions marked as Titration ."
	7959	"RTN","PSO OTMRX",126 ,0)
	7960	W !?5,"Ho wever, you will be a ble to cre ate a Main tenance Rx from this Rx"
	7961	"RTN","PSO OTMRX",127 ,0)
	7962	W !?5,"up on refill request vi a the TR ( Convert Ti tration Rx ) hidden a ction."
	7963	"RTN","PSO OTMRX",128 ,0)
	7964	Q
	7965	"RTN","PSO OTMRX",129 ,0)
	7966	NDF(PSORXI EN) ;PATCH PSO7505 - 1:YES 0 :NO checks the cs fe deral sche dule field of the va product f ile
	7967	"RTN","PSO OTMRX",130 ,0)
	7968	N DRGIEN
	7969	"RTN","PSO OTMRX",131 ,0)
	7970	S DRGIEN= $$GET1^DIQ (52,PSORXI EN,6,"I") I 'DRGIEN Q 0
	7971	"RTN","PSO OTMRX",132 ,0)
	7972	Q $$CSDS^ PSOSIGDS(D RGIEN)
	7973	"RTN","PSO PKIV1")
	7974	0^10^B1043 73358
	7975	"RTN","PSO PKIV1",1,0 )
	7976	PSOPKIV1 ; BHAM ISC/M HA - valid ate PKI ce rt. ; 05/0 9/2002 8: 15 am
	7977	"RTN","PSO PKIV1",2,0 )
	7978	;;7.0;OUT PATIENT PH ARMACY;1 31,146,223 ,148,249,3 91,426,462 ,545;DEC 1997;Buil d 21
	7979	"RTN","PSO PKIV1",3,0 )
	7980	;Ref. to ^ORDEA is supported by DBIA 57 09
	7981	"RTN","PSO PKIV1",4,0 )
	7982	;Ref. to ^ORB suppo rted by DB IA 1362
	7983	"RTN","PSO PKIV1",5,0 )
	7984	;Ref. to ^XUSSPKI s upported b y DBIA 353 9
	7985	"RTN","PSO PKIV1",6,0 )
	7986	;*545 - R eplaced 'C ertificate expired' with 'Rx p rocessed: PIV Card C ert Expire d - NO ACT ION REQ'
	7987	"RTN","PSO PKIV1",7,0 )
	7988	;*545 - R eplaced 'C ertificate revoked' with 'Rx N OT process ed: PIV Ca rd Certifi cate Revok ed'
	7989	"RTN","PSO PKIV1",8,0 )
	7990	CER ;
	7991	"RTN","PSO PKIV1",9,0 )
	7992	N PKIRT
	7993	"RTN","PSO PKIV1",10, 0)
	7994	D VERIFY( .PKIRT,ORD )
	7995	"RTN","PSO PKIV1",11, 0)
	7996	S PKI=+PK IRT I PKI= 1!(PKI=898 02020) D Q
	7997	"RTN","PSO PKIV1",12, 0)
	7998	. S PKI1= 1,VALMSG=" Digitally Signed Ord er",PKIE=" Processing "_VALMSG
	7999	"RTN","PSO PKIV1",13, 0)
	8000	. I PKI=8 9802020 S PKIE=PKIE_ ": "_$P($T (@($E(PKI, 7,8))),";; ",2)
	8001	"RTN","PSO PKIV1",14, 0)
	8002	I PKI<2 S VALMSG=$P (PKIRT,"^" ,2) Q
	8003	"RTN","PSO PKIV1",15, 0)
	8004	S PKI1=$S (PKI>89802 014&(PKI<8 9802020)!( (PKI>89802 020)&(PKI< 89802031)) :2,1:1)
	8005	"RTN","PSO PKIV1",16, 0)
	8006	S PKIE="D igital Sig nature Fai led: "_$P( $T(@($E(PK I,7,8)))," ;;",2)
	8007	"RTN","PSO PKIV1",17, 0)
	8008	I PKI1=2 D
	8009	"RTN","PSO PKIV1",18, 0)
	8010	.S VALMSG ="Signatur e Failed: "_$P($T(@( $E(PKI,7,8 ))),";;",2 )
	8011	"RTN","PSO PKIV1",19, 0)
	8012	.S PKIE=P KIE_" - Or der Auto D iscontinue d"
	8013	"RTN","PSO PKIV1",20, 0)
	8014	S:$L(PKIE )>80 PKIE= $E(PKIE,1, 80)
	8015	"RTN","PSO PKIV1",21, 0)
	8016	Q
	8017	"RTN","PSO PKIV1",22, 0)
	8018	L1 ;
	8019	"RTN","PSO PKIV1",23, 0)
	8020	S PKID=1, IEN=IEN+1, ^TMP($S($G (ST)=1:"PS OAO",1:"PS OPO"),$J,I EN,0)=PKIE
	8021	"RTN","PSO PKIV1",24, 0)
	8022	Q
	8023	"RTN","PSO PKIV1",25, 0)
	8024	ERR(ER) ;
	8025	"RTN","PSO PKIV1",26, 0)
	8026	Q:'ER
	8027	"RTN","PSO PKIV1",27, 0)
	8028	N ERM S E RM=$P($T(@ ($E(ER,7,8 ))),";;",2 ) I ERM]"" Q "Signat ure Failed : "_ERM
	8029	"RTN","PSO PKIV1",28, 0)
	8030	Q ""
	8031	"RTN","PSO PKIV1",29, 0)
	8032	REA ;
	8033	"RTN","PSO PKIV1",30, 0)
	8034	D KV^PSOV ER1
	8035	"RTN","PSO PKIV1",31, 0)
	8036	W ! S DIR ("A")="Ent er Overrid e Reason " ,DIR(0)="F ^5:70",DIR ("?")="Fre e text rea son must b e entered, should be between 5 to 70 cha racters an d must not contain e mbedded up -arrow, e. g. Spoke w ith the Pr ovider."
	8037	"RTN","PSO PKIV1",32, 0)
	8038	S:$G(PKIR )]"" DIR(" B")=PKIR D ^DIR S:'$ D(DIRUT) P KIR=Y
	8039	"RTN","PSO PKIV1",33, 0)
	8040	I $D(DIRU T) K PKIR I $D(OR0) S:$P(OR0," ^",3)="RNW " PSONEW(" QFLG")=1 S :$P(OR0,"^ ",3)="NW" PSORX("DFL G")=1
	8041	"RTN","PSO PKIV1",34, 0)
	8042	D KV^PSOV ER1 K Y Q
	8043	"RTN","PSO PKIV1",35, 0)
	8044	ACT(DA) ;
	8045	"RTN","PSO PKIV1",36, 0)
	8046	Q:'DA
	8047	"RTN","PSO PKIV1",37, 0)
	8048	N I,J D A R
	8049	"RTN","PSO PKIV1",38, 0)
	8050	S ^PSRX(D A,"A",0)=" ^52.3DA^"_ J_"^"_J,^P SRX(DA,"A" ,J,0)=%_"^ K^"_DUZ_"^ 0^INVALID PKI CERT. "_PKI
	8051	"RTN","PSO PKIV1",39, 0)
	8052	S ^PSRX(D A,"A",J,2, 1,0)=PKIR, ^PSRX(DA," A",J,2,0)= "^52.34A^1 ^1"
	8053	"RTN","PSO PKIV1",40, 0)
	8054	K PKIR Q
	8055	"RTN","PSO PKIV1",41, 0)
	8056	;
	8057	"RTN","PSO PKIV1",42, 0)
	8058	AR ;
	8059	"RTN","PSO PKIV1",43, 0)
	8060	S (I,J)=0 F S I=$O (^PSRX(DA, "A",I)) Q: 'I S J=I
	8061	"RTN","PSO PKIV1",44, 0)
	8062	S J=J+1 D NOW^%DTC Q
	8063	"RTN","PSO PKIV1",45, 0)
	8064	DCP ;
	8065	"RTN","PSO PKIV1",46, 0)
	8066	Q:'$D(^PS (52.41,ORD ,0)) N PK IOR,PKIORM
	8067	"RTN","PSO PKIV1",47, 0)
	8068	K ^PS(52. 41,"AOR",$ P(^PS(52.4 1,ORD,0)," ^",2),+$P( $G(^PS(52. 41,ORD,"IN I")),"^"), ORD),^PS(5 2.41,"AD", $P(^PS(52. 41,ORD,0), "^",12),+$ P($G(^PS(5 2.41,ORD," INI")),"^" ),ORD)
	8069	"RTN","PSO PKIV1",48, 0)
	8070	S $P(^PS( 52.41,ORD, 0),"^",3)= "DC"
	8071	"RTN","PSO PKIV1",49, 0)
	8072	S PKIE=$P (PKIE," - ")_" - "_P KI,$P(^PS( 52.41,ORD, 4),"^")=PK IE
	8073	"RTN","PSO PKIV1",50, 0)
	8074	S PKIOR=$ E(PKI,7,8)
	8075	"RTN","PSO PKIV1",51, 0)
	8076	S PKIORM= $S(PKIOR=1 6:"16:Orde r has been modified. Resubmit or contact Pharmacy. ",PKIOR=17 :"17:PIV C ertificate revoked. Resubmit o r contact Pharmacy." ,1:PKIE)
	8077	"RTN","PSO PKIV1",52, 0)
	8078	D EN^PSOH LSN($P(^PS (52.41,ORD ,0),"^")," OC",PKIORM ,"A")
	8079	"RTN","PSO PKIV1",53, 0)
	8080	D ^PSOPKI V2
	8081	"RTN","PSO PKIV1",54, 0)
	8082	Q
	8083	"RTN","PSO PKIV1",55, 0)
	8084	;
	8085	"RTN","PSO PKIV1",56, 0)
	8086	DCV ;
	8087	"RTN","PSO PKIV1",57, 0)
	8088	W ! D KV^ PSOVER1 K PKIR S DIR (0)="Y",DI R("B")="N" ,DIR("A",1 )="Digital ly signed Schedule I I Rx canno t be delet ed, it can only be D /Ced."
	8089	"RTN","PSO PKIV1",58, 0)
	8090	S DIR("A" )="Are you sure you want to D/ C this Rx: " D ^DIR, KV^PSOVER1
	8091	"RTN","PSO PKIV1",59, 0)
	8092	I 'Y S VA LMSG="No A ction Take n!",VALMBC K="R" Q
	8093	"RTN","PSO PKIV1",60, 0)
	8094	S:'$D(INC OM) INCOM= "DCed by P harmacy fo r PKI" S D IR("B")=IN COM
	8095	"RTN","PSO PKIV1",61, 0)
	8096	;
	8097	"RTN","PSO PKIV1",62, 0)
	8098	W ! S DIR ("A")="Rea son for D/ Cing",DIR( 0)="F^5:75 ",DIR("?") ="Reason m ust be ent ered and s hould be 5 to 75 cha racters an d must not contain e mbedded up arrow"
	8099	"RTN","PSO PKIV1",63, 0)
	8100	D ^DIR I $D(DIRUT) D KV^PSOVE R1 S VALMS G="No Acti on Taken!" ,VALMBCK=" R" Q
	8101	"RTN","PSO PKIV1",64, 0)
	8102	S PKIR=Y D KV^PSOVE R1
	8103	"RTN","PSO PKIV1",65, 0)
	8104	DCV0 Q:'$D (^PS(52.4, DA,0))
	8105	"RTN","PSO PKIV1",66, 0)
	8106	S $P(^PSR X(DA,"STA" ),"^")=12, $P(^PSRX(D A,3),"^",5 )=DT
	8107	"RTN","PSO PKIV1",67, 0)
	8108	D REVERSE ^PSOBPSU1( DA,,"DC",7 ),CAN^PSOT PCAN(DA) N I,J D AR
	8109	"RTN","PSO PKIV1",68, 0)
	8110	S ^PSRX(D A,"A",J,0) =%_"^C^"_D UZ_"^0^Dis continued during ver ification"
	8111	"RTN","PSO PKIV1",69, 0)
	8112	S J=J+1 D ADR
	8113	"RTN","PSO PKIV1",70, 0)
	8114	N PKIX S PKIX=DA D EN^PSOHLSN 1(DA,"OD", "",PKIR,PS ONOOR)
	8115	"RTN","PSO PKIV1",71, 0)
	8116	S DA=PKIX S DIK="^P S(52.4," D ^DIK K DI K
	8117	"RTN","PSO PKIV1",72, 0)
	8118	Q
	8119	"RTN","PSO PKIV1",73, 0)
	8120	;
	8121	"RTN","PSO PKIV1",74, 0)
	8122	DCV1 N PKI R,PSONOOR, DA S DA=PS ONV,PKIR=$ P($G(PKIE) ,"-")_" - "_PKI,PSON OOR="A" D DCV0
	8123	"RTN","PSO PKIV1",75, 0)
	8124	Q
	8125	"RTN","PSO PKIV1",76, 0)
	8126	ADR ;
	8127	"RTN","PSO PKIV1",77, 0)
	8128	S ^PSRX(D A,"A",0)=" ^52.3DA^"_ J_"^"_J
	8129	"RTN","PSO PKIV1",78, 0)
	8130	S ^PSRX(D A,"A",J,0) =%_"^K^"_D UZ_"^0^Dig itally sig ned"
	8131	"RTN","PSO PKIV1",79, 0)
	8132	S ^PSRX(D A,"A",J,2, 1,0)=$S($G (PKIR)]"": PKIR,1:"Di gitally si gned order Discontin ued"),^PSR X(DA,"A",J ,2,0)="^52 .34A^1^1"
	8133	"RTN","PSO PKIV1",80, 0)
	8134	Q
	8135	"RTN","PSO PKIV1",81, 0)
	8136	RV ;
	8137	"RTN","PSO PKIV1",82, 0)
	8138	N TY,T,T1 ,T2,MIG,SG
	8139	"RTN","PSO PKIV1",83, 0)
	8140	S (T,T2)= 0
	8141	"RTN","PSO PKIV1",84, 0)
	8142	F S T=$O (^PS(52.41 ,ORD,"OBX" ,T)) Q:'T D
	8143	"RTN","PSO PKIV1",85, 0)
	8144	.S T1=0,$ P(TY(T2)," ",23)=" "
	8145	"RTN","PSO PKIV1",86, 0)
	8146	.F S T1= $O(^PS(52. 41,ORD,"OB X",T,2,T1) ) Q:'T1 D
	8147	"RTN","PSO PKIV1",87, 0)
	8148	..S MIG=^ PS(52.41,O RD,"OBX",T ,2,T1,0)
	8149	"RTN","PSO PKIV1",88, 0)
	8150	..F SG=1: 1:$L(MIG," ") S:$L(T Y(T2)_" "_ $P(MIG," " ,SG))>80 T 2=T2+1,$P( TY(T2)," " ,23)=" " S TY(T2)=$G (TY(T2))_" "_$P(MIG, " ",SG)
	8151	"RTN","PSO PKIV1",89, 0)
	8152	.S T2=T2+ 4
	8153	"RTN","PSO PKIV1",90, 0)
	8154	Q
	8155	"RTN","PSO PKIV1",91, 0)
	8156	;
	8157	"RTN","PSO PKIV1",92, 0)
	8158	VERIFY(RET ,PSIEN) ;Verif y PKI Data
	8159	"RTN","PSO PKIV1",93, 0)
	8160	;PSIEN = IEN of fil e 52.41 ;O RIFN;ACTIO N - NOTE: if no ACTI ON then 1 (new order ) is assum ed
	8161	"RTN","PSO PKIV1",94, 0)
	8162	;Returned values: " 1" if digi tal signat ure verifi es
	8163	"RTN","PSO PKIV1",95, 0)
	8164	; " -1^error m essage" if DS fails during ini tial param eter check ing
	8165	"RTN","PSO PKIV1",96, 0)
	8166	; " 898020xx^m essage" if DS fails during ver ification
	8167	"RTN","PSO PKIV1",97, 0)
	8168	;
	8169	"RTN","PSO PKIV1",98, 0)
	8170	N PSO0,DF N,PSIG,I,I NFO,INF1,D EA,INST,HA SH,DATE
	8171	"RTN","PSO PKIV1",99, 0)
	8172	I $G(PSIE N)="" S RE T="-1^Inva lid order number" Q
	8173	"RTN","PSO PKIV1",100 ,0)
	8174	K ^TMP("P SOPKIDATA" ,$J)
	8175	"RTN","PSO PKIV1",101 ,0)
	8176	S PSO0=$G (^PS(52.41 ,PSIEN,0))
	8177	"RTN","PSO PKIV1",102 ,0)
	8178	S ^TMP("P SOPKIDATA" ,$J,"ISSUA NCE DATE", 1)=$$FMTE^ XLFDT($P($ P(PSO0,"^" ,6),"."))
	8179	"RTN","PSO PKIV1",103 ,0)
	8180	;patient inf
	8181	"RTN","PSO PKIV1",104 ,0)
	8182	S DFN=$P( PSO0,"^",2 ) D DEM^VA DPT,ADD^VA DPT
	8183	"RTN","PSO PKIV1",105 ,0)
	8184	S ^TMP("P SOPKIDATA" ,$J,"PATIE NT NAME",2 )=VADM(1)
	8185	"RTN","PSO PKIV1",106 ,0)
	8186	S ^TMP("P SOPKIDATA" ,$J,"PATIE NT ADDRESS ",3)=VAPA( 1)_"^"_VAP A(2)_"^"_V APA(3)_"^" _VAPA(4)_" ^"_$P(VAPA (5),"^")_" ^"_$P(VAPA (5),"^",2) _"^"_VAPA( 6)_"^"_VAP A(7)
	8187	"RTN","PSO PKIV1",107 ,0)
	8188	S ^TMP("P SOPKIDATA" ,$J,"QUANT ITY",5)=$P (PSO0,"^", 10)
	8189	"RTN","PSO PKIV1",108 ,0)
	8190	K ^TMP($J ,"ORDEA")
	8191	"RTN","PSO PKIV1",109 ,0)
	8192	D ARCHIVE ^ORDEA(+PS O0)
	8193	"RTN","PSO PKIV1",110 ,0)
	8194	;POS DOSE
	8195	"RTN","PSO PKIV1",111 ,0)
	8196	N J,INF0, INF1,PSIG
	8197	"RTN","PSO PKIV1",112 ,0)
	8198	S J=0 F S J=$O(^PS (52.41,PSI EN,1,J)) Q :'J D
	8199	"RTN","PSO PKIV1",113 ,0)
	8200	.S INF0=$ G(^PS(52.4 1,PSIEN,9, J,0)),INF1 =$G(^PS(52 .41,PSIEN, 1,J,1))
	8201	"RTN","PSO PKIV1",114 ,0)
	8202	.S PSIG=I NF0_"\|"_$P (INF1,"^") _"\|"_$S($E ($P(INF1," ^",2))="L" :"M"_$E($P (INF1,"^", 2),2,99),1 :$P(INF1," ^",2))_"\|" _$P(INF1," ^",6)_"\|"_ $P(INF1,"^ ",8)
	8203	"RTN","PSO PKIV1",115 ,0)
	8204	.S ^TMP(" PSOPKIDATA ",$J,"DIRE CTIONS",6, J)=PSIG
	8205	"RTN","PSO PKIV1",116 ,0)
	8206	I +$P(PSO 0,"^",9),+ $P(PSO0,"^ ",25) S ^T MP("PSOPKI DATA",$J," DRUG NAME" ,4)=$$GET1 ^DIQ(50,$P (PSO0,"^", 9),.01)
	8207	"RTN","PSO PKIV1",117 ,0)
	8208	S DEA=$P( $G(^TMP($J ,"ORDEA",+ PSO0,2))," ^")
	8209	"RTN","PSO PKIV1",118 ,0)
	8210	S ^TMP("P SOPKIDATA" ,$J,"PROVI DER NAME", 8)=$$GET1^ DIQ(200,$P (PSO0,"^", 5),.01)
	8211	"RTN","PSO PKIV1",119 ,0)
	8212	I $D(^TMP ($J,"ORDEA ",+PSO0,3) ) S ^TMP(" PSOPKIDATA ",$J,"PROV IDER ADDRE SS",9)=$P( ^(3),"^",2 ,6)
	8213	"RTN","PSO PKIV1",120 ,0)
	8214	E D INST AD
	8215	"RTN","PSO PKIV1",121 ,0)
	8216	K ^TMP($J ,"ORDEA")
	8217	"RTN","PSO PKIV1",122 ,0)
	8218	D KVA^VAD PT
	8219	"RTN","PSO PKIV1",123 ,0)
	8220	S ^TMP("P SOPKIDATA" ,$J,"DEA N UMBER",10) =DEA
	8221	"RTN","PSO PKIV1",124 ,0)
	8222	S ^TMP("P SOPKIDATA" ,$J,"ORDER NUMBER",1 1)=$P(PSO0 ,"^")
	8223	"RTN","PSO PKIV1",125 ,0)
	8224	S HASH=$$ HASHRTN^OR DEA($P(PSO 0,"^"))
	8225	"RTN","PSO PKIV1",126 ,0)
	8226	I '$L(HAS H) S RET=" -1^Order h as no PKI Hash" G VQ T
	8227	"RTN","PSO PKIV1",127 ,0)
	8228	S DATE=$$ FMTE^XLFDT ($P($P(PSO 0,"^",6)," ."))
	8229	"RTN","PSO PKIV1",128 ,0)
	8230	I '$L(DAT E) S RET=" -1^No date associate d with ord er" G VQT
	8231	"RTN","PSO PKIV1",129 ,0)
	8232	I +$P($P( ^OR(100,+P SO0,8,$O(^ OR(100,+PS O0,8,999), -1),0),"^" ,6),".") S ^TMP("PSO PKIDATA",$ J,"ISSUANC E DATE",1) =$$FMTE^XL FDT($P($P( ^OR(100,+P SO0,8,$O(^ OR(100,+PS O0,8,999), -1),0),"^" ,6),".")) ;PSO746 2
	8233	"RTN","PSO PKIV1",130 ,0)
	8234	S RET=$$V ERIFY^XUSS PKI(HASH,$ NA(^TMP("P SOPKIDATA" ,$J)))
	8235	"RTN","PSO PKIV1",131 ,0)
	8236	I RET="OK "!(RET["No error fou nd for thi s certific ate or cha in") S RET =1 G VQT
	8237	"RTN","PSO PKIV1",132 ,0)
	8238	N ECD S E CD=898020
	8239	"RTN","PSO PKIV1",133 ,0)
	8240	I RET[ECD S RET=$P( RET,"^",2) G VQT
	8241	"RTN","PSO PKIV1",134 ,0)
	8242	I RET["no t time-val id" S RET= ECD_"20" G VQT
	8243	"RTN","PSO PKIV1",135 ,0)
	8244	I RET["ha s been rev oked" S RE T=ECD_"17" G VQT
	8245	"RTN","PSO PKIV1",136 ,0)
	8246	I RET["do es not hav e a valid signature" S RET=ECD _"22" G VQ T
	8247	"RTN","PSO PKIV1",137 ,0)
	8248	I RET["no t properly time-nest ed" S RET= ECD_"23" G VQT
	8249	"RTN","PSO PKIV1",138 ,0)
	8250	I RET["no t valid in its propo sed usage" S RET=ECD _"24" G VQ T
	8251	"RTN","PSO PKIV1",139 ,0)
	8252	I RET["ba sed on an untrusted root" S RE T=ECD_"25" G VQT
	8253	"RTN","PSO PKIV1",140 ,0)
	8254	I RET["ce rtificates in the ce rtificate chain is u nknown" S RET=ECD_"2 6" G VQT
	8255	"RTN","PSO PKIV1",141 ,0)
	8256	I RET["au thority th at the ori ginal cert ificate ha d certifie d" S RET=E CD_"27" G VQT
	8257	"RTN","PSO PKIV1",142 ,0)
	8258	I RET["ce rtificate chain is n ot complet e" S RET=E CD_"28" G VQT
	8259	"RTN","PSO PKIV1",143 ,0)
	8260	I RET["th is chain d id not hav e a valid signature" S RET=ECD _"29" G VQ T
	8261	"RTN","PSO PKIV1",144 ,0)
	8262	I RET["no t valid fo r this usa ge" S RET= ECD_"30" G VQT
	8263	"RTN","PSO PKIV1",145 ,0)
	8264	VQT ;
	8265	"RTN","PSO PKIV1",146 ,0)
	8266	K ^TMP("P SOPKIDATA" ,$J)
	8267	"RTN","PSO PKIV1",147 ,0)
	8268	Q
	8269	"RTN","PSO PKIV1",148 ,0)
	8270	;
	8271	"RTN","PSO PKIV1",149 ,0)
	8272	INSTAD ;
	8273	"RTN","PSO PKIV1",150 ,0)
	8274	S INST=$P ($G(^PS(52 .41,PSIEN, "INI")),"^ ")
	8275	"RTN","PSO PKIV1",151 ,0)
	8276	D GETS^DI Q(4,INST," .01;1.01;1 .02;1.03;1 .04;.02"," E","VADR")
	8277	"RTN","PSO PKIV1",152 ,0)
	8278	S VADD(1) =$G(VADR(4 ,INST_",", .01,"E")), VADD(2)=$G (VADR(4,IN ST_",",1.0 1,"E")),VA DD(3)=$G(V ADR(4,INST _",",1.02, "E"))
	8279	"RTN","PSO PKIV1",153 ,0)
	8280	S VADD(4) =$G(VADR(4 ,INST_",", 1.03,"E")) ,VADD(5)=$ G(VADR(4,I NST_",",.0 2,"E")),VA DD(6)=$G(V ADR(4,INST _",",1.04, "E"))
	8281	"RTN","PSO PKIV1",154 ,0)
	8282	S ^TMP("P SOPKIDATA" ,$J,"PROVI DER ADDRES S",9)=VADD (1)_"^"_VA DD(2)_"^"_ VADD(3)_"^ "_VADD(4)_ "^"_VADD(5 )_"^"_VADD (6)
	8283	"RTN","PSO PKIV1",155 ,0)
	8284	Q
	8285	"RTN","PSO PKIV1",156 ,0)
	8286	;
	8287	"RTN","PSO PKIV1",157 ,0)
	8288	HSHCHK(ARE T,PNP) ;Co mpares dig itally sig ned archiv ed data in file #101 .52 agains t data in OP pending file #52. 41
	8289	"RTN","PSO PKIV1",158 ,0)
	8290	;PSO739 1/JAM
	8291	"RTN","PSO PKIV1",159 ,0)
	8292	;Input - PNP - Pen ding file IEN
	8293	"RTN","PSO PKIV1",160 ,0)
	8294	;
	8295	"RTN","PSO PKIV1",161 ,0)
	8296	;Output - returns 1 if the ar chived dat a matches the pendin g file
	8297	"RTN","PSO PKIV1",162 ,0)
	8298	; 0 if initia l paramete r checking fails
	8299	"RTN","PSO PKIV1",163 ,0)
	8300	; -1 if compar ison fails ; and retu rn array w ith failed items
	8301	"RTN","PSO PKIV1",164 ,0)
	8302	;
	8303	"RTN","PSO PKIV1",165 ,0)
	8304	N DFN,PND 0,DRGNM,DE A,DETOX,DF N,J,I,INST ,NAM,SIGFL ,DOSE,DOSE P,DOSEX,DF RM,TMP,VAD D,VADR,INF 0,INF1,ASI G,PSIG,ORP ,ND
	8305	"RTN","PSO PKIV1",166 ,0)
	8306	I $G(PNP) ="" S ARET =0 Q ARET
	8307	"RTN","PSO PKIV1",167 ,0)
	8308	S PND0=$G (^PS(52.41 ,PNP,0)) I PND0="" S ARET=0 Q ARET
	8309	"RTN","PSO PKIV1",168 ,0)
	8310	S ORP=$P( PND0,"^") I ORP="" S ARET=0 Q ARET
	8311	"RTN","PSO PKIV1",169 ,0)
	8312	;get arch ived data from CPRS
	8313	"RTN","PSO PKIV1",170 ,0)
	8314	K ^TMP($J ,"ORDEA")
	8315	"RTN","PSO PKIV1",171 ,0)
	8316	D ARCHIVE ^ORDEA(ORP )
	8317	"RTN","PSO PKIV1",172 ,0)
	8318	I '$D(^TM P($J,"ORDE A")) S ARE T=0 Q ARET
	8319	"RTN","PSO PKIV1",173 ,0)
	8320	F I=1:1:5 S TMP(I)= $G(^TMP($J ,"ORDEA",O RP,I))
	8321	"RTN","PSO PKIV1",174 ,0)
	8322	I $P($P(P ND0,"^",6) ,".")'=$P( TMP(1),"^" ,2) S ARET =-1,ARET(" ISSUANCE D ATE")=$P(T MP(1),"^", 2)_"^"_$P( $P(PND0,"^ ",6),".")
	8323	"RTN","PSO PKIV1",175 ,0)
	8324	S DRGNM=$ $GET1^DIQ( 50,$P(PND0 ,"^",9),.0 1)
	8325	"RTN","PSO PKIV1",176 ,0)
	8326	I DRGNM'= $P(TMP(1), "^",3) S A RET=-1,ARE T("DRUG NA ME")=$P(TM P(1),"^",3 )_"^"_DRGN M
	8327	"RTN","PSO PKIV1",177 ,0)
	8328	I $P(PND0 ,"^",10)'= $P(TMP(1), "^",6) S A RET=-1,ARE T("QTY PRE SCRIBED")= $P(TMP(1), "^",6)_"^" _$P(PND0," ^",10)
	8329	"RTN","PSO PKIV1",178 ,0)
	8330	;provider info
	8331	"RTN","PSO PKIV1",179 ,0)
	8332	S INST=$P ($G(^PS(52 .41,PNP,"I NI")),"^")
	8333	"RTN","PSO PKIV1",180 ,0)
	8334	;*545
	8335	"RTN","PSO PKIV1",181 ,0)
	8336	S DEA=$$R XDEA^PSOUT IL(,ORP)
	8337	"RTN","PSO PKIV1",182 ,0)
	8338	I DEA'=$P (TMP(2),"^ ") S ARET= -1,ARET("D EA #")=$P( TMP(2),"^" )_"^"_DEA
	8339	"RTN","PSO PKIV1",183 ,0)
	8340	S NAM=$$G ET1^DIQ(20 0,$P(PND0, "^",5),.01 ) I NAM'=$ P(TMP(2)," ^",3) S AR ET=-1,ARET ("PROVIDER NAME")=$P (TMP(2),"^ ",3)_"^"_N AM
	8341	"RTN","PSO PKIV1",184 ,0)
	8342	;patient inf
	8343	"RTN","PSO PKIV1",185 ,0)
	8344	S DFN=$P( PND0,"^",2 ) D DEM^VA DPT,ADD^VA DPT
	8345	"RTN","PSO PKIV1",186 ,0)
	8346	I VADM(1) '=$P(TMP(4 ),"^") S A RET=-1,ARE T("PATIENT NAME")=$P (TMP(4),"^ ")_"^"_VAD M(1)
	8347	"RTN","PSO PKIV1",187 ,0)
	8348	I VAPA(1) '=$P(TMP(5 ),"^") S A RET=-1,ARE T("PATIENT ADDRESS # 1")=$P(TMP (5),"^")_" ^"_VAPA(1)
	8349	"RTN","PSO PKIV1",188 ,0)
	8350	I VAPA(2) '=$P(TMP(5 ),"^",2) S ARET=-1,A RET("PATIE NT ADDRESS #2")=$P(T MP(5),"^", 2)_"^"_VAP A(2)
	8351	"RTN","PSO PKIV1",189 ,0)
	8352	I VAPA(3) '=$P(TMP(5 ),"^",3) S ARET=-1,A RET("PATIE NT ADDRESS #3")=$P(T MP(5),"^", 3)_"^"_VAP A(3)
	8353	"RTN","PSO PKIV1",190 ,0)
	8354	I VAPA(4) '=$P(TMP(5 ),"^",4) S ARET=-1,A RET("PATIE NT CITY")= $P(TMP(5), "^",4)_"^" _VAPA(4)
	8355	"RTN","PSO PKIV1",191 ,0)
	8356	I $P(VAPA (5),"^",2) '=$P(TMP(5 ),"^",5) S ARET=-1,A RET("PATIE NT STATE") =$P(TMP(5) ,"^",5)_"^ "_$P(VAPA( 5),"^",2)
	8357	"RTN","PSO PKIV1",192 ,0)
	8358	I VAPA(6) '=$P(TMP(5 ),"^",6) S ARET=-1,A RET("PATIE NT ZIP+4") =$P(TMP(5) ,"^",6)_"^ "_VAPA(6)
	8359	"RTN","PSO PKIV1",193 ,0)
	8360	;sig
	8361	"RTN","PSO PKIV1",194 ,0)
	8362	M ASIG=^T MP($J,"ORD EA",ORP,6)
	8363	"RTN","PSO PKIV1",195 ,0)
	8364	S I=0 F S I=$O(^PS (52.41,PNP ,1,I)) Q:' I D
	8365	"RTN","PSO PKIV1",196 ,0)
	8366	.S INF0=$ G(^PS(52.4 1,PNP,9,I, 0)),INF1=$ G(^PS(52.4 1,PNP,1,I, 1))
	8367	"RTN","PSO PKIV1",197 ,0)
	8368	.S PSIG(I )=INF0_"\|" _$P(INF1," ^")_"\|"_$P (INF1,"^", 2)_"\|"_$P( INF1,"^",6 )_"\|"_$P(I NF1,"^",8)
	8369	"RTN","PSO PKIV1",198 ,0)
	8370	S I=0 F S I=$O(ASI G(I)) Q:'I I ASIG(I )'=$G(PSIG (I)) S ND= "SIG #"_I, ARET=-1 S ARET(ND)=A SIG(I)_"^" _$G(PSIG(I ))
	8371	"RTN","PSO PKIV1",199 ,0)
	8372	D KVA^VAD PT
	8373	"RTN","PSO PKIV1",200 ,0)
	8374	K ^TMP($J ,"ORDEA")
	8375	"RTN","PSO PKIV1",201 ,0)
	8376	Q $S($G(A RET):ARET, 1:1)
	8377	"RTN","PSO PKIV1",202 ,0)
	8378	;
	8379	"RTN","PSO PKIV1",203 ,0)
	8380	ALERT ;
	8381	"RTN","PSO PKIV1",204 ,0)
	8382	; ORN=76 - Notifica tion ID (i fn from OE /RR Notifi cations fi le #100.9 )
	8383	"RTN","PSO PKIV1",205 ,0)
	8384	; ORBDFN= Patient DF N from Pat ient file #2
	8385	"RTN","PSO PKIV1",206 ,0)
	8386	; ORNUM=O rder ifn f rom Order file #100
	8387	"RTN","PSO PKIV1",207 ,0)
	8388	; ORBADUZ =Provider DUZ - Arra y of notif ication re cipients r equested b y the call ing packag e.
	8389	"RTN","PSO PKIV1",208 ,0)
	8390	; ORBPMSG =Message t ext
	8391	"RTN","PSO PKIV1",209 ,0)
	8392	; ORBPDAT A=This is an identif ier of the package e ntry which the notif ication is based on.
	8393	"RTN","PSO PKIV1",210 ,0)
	8394	; For radi ology: Rad /Nuc Med e xam/case i fn's(forma t: exam_if n;case_ifn )
	8395	"RTN","PSO PKIV1",211 ,0)
	8396	; For cons ults: the IEN of th e consult in file 12 3
	8397	"RTN","PSO PKIV1",212 ,0)
	8398	N PSOX S PSOX=1
	8399	"RTN","PSO PKIV1",213 ,0)
	8400	S PSOX(+$ P(OR0,"^", 5))=""
	8401	"RTN","PSO PKIV1",214 ,0)
	8402	D EN^ORB3 (76,PSODFN ,$P(OR0,"^ "),.PSOX," PIV certif icate expi red. Renew your cert ificate.", "")
	8403	"RTN","PSO PKIV1",215 ,0)
	8404	Q
	8405	"RTN","PSO PKIV1",216 ,0)
	8406	;
	8407	"RTN","PSO PKIV1",217 ,0)
	8408	00 ;;Order Text is b lank;;
	8409	"RTN","PSO PKIV1",218 ,0)
	8410	01 ;;DEA # missing;;
	8411	"RTN","PSO PKIV1",219 ,0)
	8412	02 ;;Drug Schedule m issing;;
	8413	"RTN","PSO PKIV1",220 ,0)
	8414	03 ;;DEA # not valid ;;
	8415	"RTN","PSO PKIV1",221 ,0)
	8416	04 ;;Valid Certifica te not fou nd;;
	8417	"RTN","PSO PKIV1",222 ,0)
	8418	05 ;;Could n't load C SP;;
	8419	"RTN","PSO PKIV1",223 ,0)
	8420	06 ;;Smart card Read er not fou nd;;
	8421	"RTN","PSO PKIV1",224 ,0)
	8422	07 ;;Certi ficate wit h DEA # no t found;;
	8423	"RTN","PSO PKIV1",225 ,0)
	8424	08 ;;Certi ficate not valid for schedule; ;
	8425	"RTN","PSO PKIV1",226 ,0)
	8426	10 ;;Crypt o Error (c ontact IRM );;
	8427	"RTN","PSO PKIV1",227 ,0)
	8428	15 ;;Corru pted (Deco de failure );;
	8429	"RTN","PSO PKIV1",228 ,0)
	8430	16 ;;Corru pted (Hash mismatch) ;;
	8431	"RTN","PSO PKIV1",229 ,0)
	8432	17 ;;Rx NO T processe d: PIV Car d Certific ate Revoke d;;
	8433	"RTN","PSO PKIV1",230 ,0)
	8434	18 ;;Verif ication fa ilure;;
	8435	"RTN","PSO PKIV1",231 ,0)
	8436	19 ;;Befor e Cert eff ective dat e;;
	8437	"RTN","PSO PKIV1",232 ,0)
	8438	20 ;;Rx pr ocessed: P IV Card Ce rt Expired - NO ACTI ON REQ;;
	8439	"RTN","PSO PKIV1",233 ,0)
	8440	21 ;;No Ce rt with a valid date found;;
	8441	"RTN","PSO PKIV1",234 ,0)
	8442	22 ;;Signa ture Check failed (I nvalid Sig nature);;
	8443	"RTN","PSO PKIV1",235 ,0)
	8444	23 ;;CERT_ IS_NOT_TIM E_NESTED;;
	8445	"RTN","PSO PKIV1",236 ,0)
	8446	24 ;;CERT_ IS_NOT_VAL ID_FOR_USA GE;;
	8447	"RTN","PSO PKIV1",237 ,0)
	8448	25 ;;CERT_ IS_UNTRUST ED_ROOT;;
	8449	"RTN","PSO PKIV1",238 ,0)
	8450	26 ;;CERT_ REVOCATION _STATUS_UN KNOWN;;
	8451	"RTN","PSO PKIV1",239 ,0)
	8452	27 ;;CERT_ IS_CYCLIC; ;
	8453	"RTN","PSO PKIV1",240 ,0)
	8454	28 ;;CERT_ IS_PARTIAL _CHAIN;;
	8455	"RTN","PSO PKIV1",241 ,0)
	8456	29 ;;CERT_ CTL_IS_NOT _SIGNATURE _VALID;;
	8457	"RTN","PSO PKIV1",242 ,0)
	8458	30 ;;CERT_ CTL_IS_NOT _VALID_FOR _USAGE;;
	8459	"RTN","PSO PRVW")
	8460	0^3^B11155 6664
	8461	"RTN","PSO PRVW",1,0)
	8462	PSOPRVW ;B IR/SAB,MHA -enter/edi t/view pro vider ; 2/ 9/07 10:39 am
	8463	"RTN","PSO PRVW",2,0)
	8464	;;7.0;OUT PATIENT PH ARMACY;1 1,146,153, 263,268,26 4,398,391, 450,545; DEC 1997;B uild 21
	8465	"RTN","PSO PRVW",3,0)
	8466	;Ref. to ^VA(200 su pp. by IA 224
	8467	"RTN","PSO PRVW",4,0)
	8468	;Ref. to ^DIC(7 sup p. by IA 4 91
	8469	"RTN","PSO PRVW",5,0)
	8470	;Ref. to $$NPI^XUS NPI supp. by IA 4532
	8471	"RTN","PSO PRVW",6,0)
	8472	;External reference to sub-fi le NEW DEA #'S (#200 .5321) is supported by DBIA 70 00
	8473	"RTN","PSO PRVW",7,0)
	8474	;External reference to DEA NU MBERS file (#8991.9) is suppor ted by DBI A 7002
	8475	"RTN","PSO PRVW",8,0)
	8476	;
	8477	"RTN","PSO PRVW",9,0)
	8478	START W ! S DIC("A") ="Select P rovider: " ,DIC("S")= "I $D(^VA( 200,+Y,""P S""))",DIC ="^VA(200, ",DIC(0)=" AEQMZ" D ^ DIC G:"^"[ X EX G:Y<0 START K D IC S PRNO= +Y
	8479	"RTN","PSO PRVW",10,0 )
	8480	W @IOF,"N ame: "_$P( ^VA(200,PR NO,0),U) G :$$CHKP ST ART
	8481	"RTN","PSO PRVW",11,0 )
	8482	I +$P(^VA (200,PRNO, "PS"),U,4) ,$P(^("PS" ),U,4)'>DT W ?40,$C( 7),"* * * INACTIVE A S OF ",$E( $P(^("PS") ,U,4),4,5) ,"/",$E($P (^("PS"),U ,4),6,7)," /",$E($P(^ ("PS"),U,4 ),2,3)," * * *" G:$$ CHKP START
	8483	"RTN","PSO PRVW",12,0 )
	8484	;W !,"SSN #: " S T=$ S($P(^VA(2 00,PRNO,1) ,U,9)]"":$ P(^(1),U,9 ),1:"") W: T $E(T,1,3 ),"-",$E(T ,4,5),"-", $E(T,6,9)
	8485	"RTN","PSO PRVW",13,0 )
	8486	W !,"Init ials: "_$P (^VA(200,P RNO,0),U,2 ) G:$$CHKP START
	8487	"RTN","PSO PRVW",14,0 )
	8488	W !,"NON- VA Prescri ber: " G:$ $CHKP STAR T
	8489	"RTN","PSO PRVW",15,0 )
	8490	I $P($G(^ VA(200,PRN O,"TPB")), U)]"" W $S ($P(^("TPB "),U):"Yes ",1:"No") G:$$CHKP S TART
	8491	"RTN","PSO PRVW",16,0 )
	8492	W ?40,"Ta x ID: "_$P ($G(^VA(20 0,PRNO,"TP B")),U,2) G:$$CHKP S TART
	8493	"RTN","PSO PRVW",17,0 )
	8494	W !,"Excl usionary C heck Perfo rmed: " W :$P($G(^VA (200,PRNO, "TPB")),U, 3)]"" $S($ P(^("TPB") ,U,3):"Yes ",1:"No") G:$$CHKP S TART
	8495	"RTN","PSO PRVW",18,0 )
	8496	W ?40,"Da te Exclusi onary List Checked: " G:$$CHKP START
	8497	"RTN","PSO PRVW",19,0 )
	8498	S Y=$P($G (^VA(200,P RNO,"TPB") ),U,4) I Y W $E(Y,4, 5)_"/"_$E( Y,6,7)_"/" _$E(Y,2,3) G:$$CHKP START
	8499	"RTN","PSO PRVW",20,0 )
	8500	W !,"On E xclusionar y List: " W:$P($G(^V A(200,PRNO ,"TPB")),U ,5)]"" $S( $P(^("TPB" ),U,5):"Ye s",1:"No") G:$$CHKP START
	8501	"RTN","PSO PRVW",21,0 )
	8502	W !,"Excl usionary C hecked By: "
	8503	"RTN","PSO PRVW",22,0 )
	8504	W:$P($G(^ VA(200,PRN O,"TPB")), U,6) $P($G (^VA(200,$ P(^("TPB") ,U,6),0)), U) G:$$CHK P START
	8505	"RTN","PSO PRVW",23,0 )
	8506	W !,"Auth orized to Write Orde rs: "_$S($ P(^VA(200, PRNO,"PS") ,U):"Yes", 1:"No") G: $$CHKP STA RT
	8507	"RTN","PSO PRVW",24,0 )
	8508	W !,"Requ ires Cosig ner: "_$S( $P(^("PS") ,U,7):"Yes ",1:"No"), ?40 G:$$C HKP START I $P(^("P S"),U,7),$ D(^VA(200, +$P(^("PS" ),U,8),0)) W !,"Usua l Cosigner : "_$P(^(0 ),U) G:$$C HKP START
	8509	"RTN","PSO PRVW",25,0 )
	8510	N NPDEAIE N,DNDEAIEN ,EXIT
	8511	"RTN","PSO PRVW",26,0 )
	8512	;
	8513	"RTN","PSO PRVW",27,0 )
	8514	W ! G:$$C HKP START
	8515	"RTN","PSO PRVW",28,0 )
	8516	N SET,SET ARRAY,LINE S SET=0
	8517	"RTN","PSO PRVW",29,0 )
	8518	S NPDEAIE N=0 F S N PDEAIEN=$O (^VA(200,P RNO,"PS4", NPDEAIEN)) Q:'+NPDEA IEN D
	8519	"RTN","PSO PRVW",30,0 )
	8520	. S SET=S ET+1,LINE= 0
	8521	"RTN","PSO PRVW",31,0 )
	8522	. S DNDEA IEN=$P(^VA (200,PRNO, "PS4",NPDE AIEN,0),U, 3) Q:'DNDE AIEN
	8523	"RTN","PSO PRVW",32,0 )
	8524	. S LINE= LINE+1,SET ARRAY(SET, LINE)="DEA #: "_$P(^X TV(8991.9, DNDEAIEN,0 ),U,1)
	8525	"RTN","PSO PRVW",33,0 )
	8526	. S:$P(^V A(200,PRNO ,"PS4",NPD EAIEN,0),U ,2)'="" SE TARRAY(SET ,LINE)=SET ARRAY(SET, LINE)_"-"_ $P(^VA(200 ,PRNO,"PS4 ",NPDEAIEN ,0),U,2)
	8527	"RTN","PSO PRVW",34,0 )
	8528	. S LINE= LINE+1,SET ARRAY(SET, LINE)="DEA Expiratio n Date: " S T=+$P(^X TV(8991.9, DNDEAIEN,0 ),U,4) S:T SETARRAY( SET,LINE)= SETARRAY(S ET,LINE)_$ $FMTE^XLFD T(T)
	8529	"RTN","PSO PRVW",35,0 )
	8530	. S:$P(^X TV(8991.9, DNDEAIEN,0 ),U,3)'="" LINE=LINE +1,SETARRA Y(SET,LINE )="Detox/M aintenance ID#: "_$P (^XTV(8991 .9,DNDEAIE N,0),U,3)
	8531	"RTN","PSO PRVW",36,0 )
	8532	. N SCHNO DE S SCHNO DE=$G(^XTV (8991.9,DN DEAIEN,2)) D:SCHNODE '=""
	8533	"RTN","PSO PRVW",37,0 )
	8534	.. S LINE =LINE+1,SE TARRAY(SET ,LINE)=" SCHEDU LE II NARC OTIC: "_$S ($P(SCHNOD E,U,1):"YE S",1:"NO")
	8535	"RTN","PSO PRVW",38,0 )
	8536	.. S LINE =LINE+1,SE TARRAY(SET ,LINE)=" SCHEDULE I I NON-NARC OTIC: "_$S ($P(SCHNOD E,U,2):"YE S",1:"NO")
	8537	"RTN","PSO PRVW",39,0 )
	8538	.. S LINE =LINE+1,SE TARRAY(SET ,LINE)=" SCHEDUL E III NARC OTIC: "_$S ($P(SCHNOD E,U,3):"YE S",1:"NO")
	8539	"RTN","PSO PRVW",40,0 )
	8540	.. S LINE =LINE+1,SE TARRAY(SET ,LINE)=" S CHEDULE II I NON-NARC OTIC: "_$S ($P(SCHNOD E,U,4):"YE S",1:"NO")
	8541	"RTN","PSO PRVW",41,0 )
	8542	.. S LINE =LINE+1,SE TARRAY(SET ,LINE)=" SCHEDUL E IV: "_$S ($P(SCHNOD E,U,5):"YE S",1:"NO")
	8543	"RTN","PSO PRVW",42,0 )
	8544	.. S LINE =LINE+1,SE TARRAY(SET ,LINE)=" SCHEDU LE V: "_$S ($P(SCHNOD E,U,6):"YE S",1:"NO")
	8545	"RTN","PSO PRVW",43,0 )
	8546	. S:'$D( SETARRAY(S ET,9)) SET ARRAY(SET, 9)=""
	8547	"RTN","PSO PRVW",44,0 )
	8548	;
	8549	"RTN","PSO PRVW",45,0 )
	8550	S EXIT=0
	8551	"RTN","PSO PRVW",46,0 )
	8552	F SET=1:2 :$O(SETARR AY(100),-1 ) G:EXIT=1 START D
	8553	"RTN","PSO PRVW",47,0 )
	8554	. W ! I $ $CHKP S EX IT=1 Q
	8555	"RTN","PSO PRVW",48,0 )
	8556	. F LINE= 1:1:9 Q:EX IT D
	8557	"RTN","PSO PRVW",49,0 )
	8558	.. W SETA RRAY(SET,L INE),?40,$ G(SETARRAY (SET+1,LIN E)),! I $$ CHKP S EXI T=1 Q
	8559	"RTN","PSO PRVW",50,0 )
	8560	K SETARRA Y,SET,LINE
	8561	"RTN","PSO PRVW",51,0 )
	8562	;
	8563	"RTN","PSO PRVW",52,0 )
	8564	W ! G:$$C HKP START
	8565	"RTN","PSO PRVW",53,0 )
	8566	W !,"Clas s: " S PRC LS=+$P(^VA (200,PRNO, "PS"),U,5) ,PRCLS=$S( PRCLS>0&$D (^DIC(7,PR CLS,0)):$P (^(0),U),1 :"") W PRC LS,?40,"VA #: "_$P(^ VA(200,PRN O,"PS"),U, 3) G:$$CHK P START
	8567	"RTN","PSO PRVW",54,0 )
	8568	W !," Typ e: " S T=+ $P(^("PS") ,U,6),L=$P (^DD(200,5 3.6,0),U,3 )_";"_T_": Unknown" F I=1:1 I $ P($P(L,";" ,I),":",1) =T W $P($P (L,";",I), ":",2) Q
	8569	"RTN","PSO PRVW",55,0 )
	8570	G:$$CHKP START
	8571	"RTN","PSO PRVW",56,0 )
	8572	N NPI S N PI=$P($$NP I^XUSNPI(" Individual _ID",PRNO) ,U) W ?40, "NPI#: "_$ S(NPI>0:+N PI,1:"") G :$$CHKP ST ART
	8573	"RTN","PSO PRVW",57,0 )
	8574	W !,"Rema rks: "_$P( ^VA(200,PR NO,"PS"),U ,9) G:$$CH KP START W !,"Synony m(s): "_$ S($P($G(^V A(200,PRNO ,.1)),U,4) ]"":$P(^(. 1),U,4)_", ",1:"")_$S ($P(^(0),U ,2)]"":" " _$P(^(0),U ,2),1:"") G:$$CHKP S TART
	8575	"RTN","PSO PRVW",58,0 )
	8576	W !,"Serv ice/Sectio n: "
	8577	"RTN","PSO PRVW",59,0 )
	8578	S PSOSSDA =$G(DA) I $P($G(^VA( 200,PRNO,5 )),U) K DI Q S DIC="^ DIC(49,",D A=$P(^VA(2 00,PRNO,5) ,U),DR=.01 ,DIQ="PSOS ECT",DIQ(0 )="E" D EN ^DIQ1 W $G (PSOSECT(4 9,DA,.01," E")) S DA= $G(PSOSSDA ) K DR,DIC ,DIQ,PSOSS DA,PSOSECT G:$$CHKP START
	8579	"RTN","PSO PRVW",60,0 )
	8580	I $TR($G( ^VA(200,PR NO,.11)),U ,"")="" G NUM
	8581	"RTN","PSO PRVW",61,0 )
	8582	W ! G:$$C HKP START
	8583	"RTN","PSO PRVW",62,0 )
	8584	W !,"Addr ess: ",?10 ,$P(^VA(20 0,PRNO,.11 ),U) G:$$C HKP START W:$P(^(.11 ),U,2)'="" !?10,$P(^ (.11),U,2) G:$$CHKP START W:$P (^(.11),U, 3)'="" !?1 0,$P(^(.11 ),U,3) G:$ $CHKP STAR T
	8585	"RTN","PSO PRVW",63,0 )
	8586	W !?10,$P (^VA(200,P RNO,.11),U ,4) W:$P(^ (.11),U,4) ]"" ", " S STAT=+$P( $G(^(.11)) ,U,5) W $S ($D(^DIC(5 ,STAT,0)): $P(^(0),U) ,1:"")_" "_$P(^VA(2 00,PRNO,.1 1),U,6) G: $$CHKP STA RT
	8587	"RTN","PSO PRVW",64,0 )
	8588	NUM G:'$D( ^VA(200,PR NO,.13)) S TART
	8589	"RTN","PSO PRVW",65,0 )
	8590	W !,"Phon e: "_$P (^VA(200,P RNO,.13),U ),! G:$$CH KP START W:$P(^(.13 ),U,2)]"" "Office: ",$P(^(.1 3),U,2),! G:$$CHKP S TART
	8591	"RTN","PSO PRVW",66,0 )
	8592	W:$P(^VA( 200,PRNO,. 13),U,3)]" " "Phone # 3: "_$P(^( .13),U,3), ?40 W:$P(^ (.13),U,7) ]"" "Voice Pager #: "_$P(^(.1 3),U,7) W ! G:$$CHKP START
	8593	"RTN","PSO PRVW",67,0 )
	8594	W:$P(^VA( 200,PRNO,. 13),U,4)]" " "Phone # 4: "_$P(^( .13),U,4), ?40 W:$P(^ (.13),U,8) ]"" "Digit al Pager#: "_$P(^(.1 3),U,8) G: $$CHKP STA RT
	8595	"RTN","PSO PRVW",68,0 )
	8596	W:$P(^VA( 200,PRNO,. 13),U,6)]" " !,"Fax # : "_$P( ^(.13),U,6 ) G:$$CHKP START
	8597	"RTN","PSO PRVW",69,0 )
	8598	W:$P($G(^ VA(200,PRN O,.14)),U) ]"" !,"Roo m Loc: "_$ P(^(.14),U ) G:$$CHKP START
	8599	"RTN","PSO PRVW",70,0 )
	8600	G START
	8601	"RTN","PSO PRVW",71,0 )
	8602	EX K DIC,D IE,DA,DR,D 0,PRNO,PRC LS,STAT,T, Y,X,L,LF,I ,DIR,DIROU T,DUOUT,DT OUT,DIRUT, %,%Y,%W,%Z ,C,DDH,DI, DIH,DLAYGO ,DQ,X1,XMD T,XMN
	8603	"RTN","PSO PRVW",72,0 )
	8604	Q
	8605	"RTN","PSO PRVW",73,0 )
	8606	ASK ;edit providers
	8607	"RTN","PSO PRVW",74,0 )
	8608	K DIR,DTO UT,DUOUT,D IROUT,DIRU T,FMG,FMGO ,FMGX,MSG, EXIT S EXI T=0
	8609	"RTN","PSO PRVW",75,0 )
	8610	W ! S DI C("A")="Se lect Provi der: ",(DI C,DIE)=200 ,DIC(0)="A EQMZ" D ^D IC G:"^"[X EX G:Y<0 ASK S (FAD A,DA)=+Y
	8611	"RTN","PSO PRVW",76,0 )
	8612	I '$D(^VA (200,DA,"P S")) G NPR V
	8613	"RTN","PSO PRVW",77,0 )
	8614	ASK1 S EXI T=0 W @IOF ,?25,"Prov ider: "_$P (^VA(200,D A,0),U),! G:$$CHKP Q X
	8615	"RTN","PSO PRVW",78,0 )
	8616	S DR="TPB " D EN^DIQ
	8617	"RTN","PSO PRVW",79,0 )
	8618	N PSOGETS ,PSOGETSF, NPDEASUF
	8619	"RTN","PSO PRVW",80,0 )
	8620	D GETS^DI Q(200,DA," 53.1;53.3; 53.4;53.5; 53.6;53.7; 53.8;53.9" ,"RN","PSO GETS")
	8621	"RTN","PSO PRVW",81,0 )
	8622	S PSOGETS F="" F S PSOGETSF=$ O(PSOGETS( 200,DA_"," ,PSOGETSF) ) Q:PSOGET SF="" D G:EXIT QX
	8623	"RTN","PSO PRVW",82,0 )
	8624	. W !,?2, PSOGETSF_" : "_PSOGET S(200,DA_" ,",PSOGETS F) I $$CHK P S EXIT=1 Q
	8625	"RTN","PSO PRVW",83,0 )
	8626	K PSOGETS N NPDEAIE N,DNDEAIEN
	8627	"RTN","PSO PRVW",84,0 )
	8628	;
	8629	"RTN","PSO PRVW",85,0 )
	8630	W ! G:$$C HKP QX
	8631	"RTN","PSO PRVW",86,0 )
	8632	N SET,SET ARRAY,LINE S SET=0
	8633	"RTN","PSO PRVW",87,0 )
	8634	S NPDEAIE N=0 F S N PDEAIEN=$O (^VA(200,D A,"PS4",NP DEAIEN)) Q :'+NPDEAIE N D
	8635	"RTN","PSO PRVW",88,0 )
	8636	. S SET=S ET+1,LINE= 0
	8637	"RTN","PSO PRVW",89,0 )
	8638	. S DNDEA IEN=$P(^VA (200,DA,"P S4",NPDEAI EN,0),U,3) Q:'DNDEAI EN
	8639	"RTN","PSO PRVW",90,0 )
	8640	. S NPDEA SUF=$P(^VA (200,DA,"P S4",NPDEAI EN,0),U,2)
	8641	"RTN","PSO PRVW",91,0 )
	8642	. D GETS^ DIQ(8991.9 ,DNDEAIEN, ".01;.03;. 04","R","P SOGETS")
	8643	"RTN","PSO PRVW",92,0 )
	8644	. S PSOGE TSF="" F S PSOGETSF =$O(PSOGET S(8991.9,D NDEAIEN_", ",PSOGETSF )) Q:PSOGE TSF="" D
	8645	"RTN","PSO PRVW",93,0 )
	8646	.. S LINE =LINE+1,SE TARRAY(SET ,LINE)=" "_PSOGETSF _": "_PSOG ETS(8991.9 ,DNDEAIEN_ ",",PSOGET SF)
	8647	"RTN","PSO PRVW",94,0 )
	8648	.. I NPDE ASUF'="",P SOGETSF="D EA NUMBER" S SETARR AY(SET,LIN E)=SETARRA Y(SET,LINE )_"-"_NPDE ASUF
	8649	"RTN","PSO PRVW",95,0 )
	8650	. K PSOGE TS D GETS^ DIQ(8991.9 ,DNDEAIEN, "2.1;2.2;2 .3;2.4;2.5 ;2.6",""," PSOGETS")
	8651	"RTN","PSO PRVW",96,0 )
	8652	. S LINE= LINE+1,SET ARRAY(SET, LINE)=" SCHEDUL E II NARCO TIC: "_PSO GETS(8991. 9,DNDEAIEN _",",2.1)
	8653	"RTN","PSO PRVW",97,0 )
	8654	. S LINE= LINE+1,SET ARRAY(SET, LINE)=" S CHEDULE II NON-NARCO TIC: "_PSO GETS(8991. 9,DNDEAIEN _",",2.2)
	8655	"RTN","PSO PRVW",98,0 )
	8656	. S LINE= LINE+1,SET ARRAY(SET, LINE)=" SCHEDULE III NARCO TIC: "_PSO GETS(8991. 9,DNDEAIEN _",",2.3)
	8657	"RTN","PSO PRVW",99,0 )
	8658	. S LINE= LINE+1,SET ARRAY(SET, LINE)=" SC HEDULE III NON-NARCO TIC: "_PSO GETS(8991. 9,DNDEAIEN _",",2.4)
	8659	"RTN","PSO PRVW",100, 0)
	8660	. S LINE= LINE+1,SET ARRAY(SET, LINE)=" SCHEDULE IV: "_PSO GETS(8991. 9,DNDEAIEN _",",2.5)
	8661	"RTN","PSO PRVW",101, 0)
	8662	. S LINE= LINE+1,SET ARRAY(SET, LINE)=" SCHEDUL E V: "_PSO GETS(8991. 9,DNDEAIEN _",",2.6)
	8663	"RTN","PSO PRVW",102, 0)
	8664	;
	8665	"RTN","PSO PRVW",103, 0)
	8666	S EXIT=0
	8667	"RTN","PSO PRVW",104, 0)
	8668	F SET=1:2 :$O(SETARR AY(100),-1 ) Q:EXIT D
	8669	"RTN","PSO PRVW",105, 0)
	8670	. W ! S:$ $CHKP EXIT =1 Q:EXIT
	8671	"RTN","PSO PRVW",106, 0)
	8672	. F LINE= 1:1:9 S:$$ CHKP EXIT= 1 Q:EXIT D
	8673	"RTN","PSO PRVW",107, 0)
	8674	.. W SETA RRAY(SET,L INE),?40,$ G(SETARRAY (SET+1,LIN E)),!
	8675	"RTN","PSO PRVW",108, 0)
	8676	K SETARRA Y,SET,LINE
	8677	"RTN","PSO PRVW",109, 0)
	8678	G:EXIT QX
	8679	"RTN","PSO PRVW",110, 0)
	8680	;
	8681	"RTN","PSO PRVW",111, 0)
	8682	D GETS^DI Q(200,DA_" ,",".111:. 116;.131:. 138;.141", "","FMG"," MSG")
	8683	"RTN","PSO PRVW",112, 0)
	8684	N FLDCNT
	8685	"RTN","PSO PRVW",113, 0)
	8686	S EXIT=0
	8687	"RTN","PSO PRVW",114, 0)
	8688	F FMGX=.1 11,.112,.1 13 G:EXIT QX D
	8689	"RTN","PSO PRVW",115, 0)
	8690	. I FMG(2 00,DA_",", FMGX)'="" W !,$$GET1 ^DID(200,F MGX,,"LABE L")_": "_F MG(200,DA_ ",",FMGX) I $$CHKP S EXIT=1 Q
	8691	"RTN","PSO PRVW",116, 0)
	8692	S FLDCNT= 0 F FMGX=. 114,.115,. 116 G:EXIT QX D
	8693	"RTN","PSO PRVW",117, 0)
	8694	. I FMG(2 00,DA_",", FMGX)'="" S FLDCNT=F LDCNT+1 W: (FLDCNT#2) ! W:'(FLD CNT#2) ?41 W $E($$GE T1^DID(200 ,FMGX,,"LA BEL")_": " _FMG(200,D A_",",FMGX ),1,39) I '(FLDCNT#2 ) I $$CHKP S EXIT=1 Q
	8695	"RTN","PSO PRVW",118, 0)
	8696	W ! G:$$C HKP QX
	8697	"RTN","PSO PRVW",119, 0)
	8698	S FLDCNT= 0 F FMGX=. 132,.133,. 134,.135,. 136,.137,. 138 G:EXIT QX D
	8699	"RTN","PSO PRVW",120, 0)
	8700	. I FMG(2 00,DA_",", FMGX)'="" S FLDCNT=F LDCNT+1 W: (FLDCNT#2) ! W:'(FLD CNT#2) ?41 W $E($$GE T1^DID(200 ,FMGX,,"LA BEL")_": " _FMG(200,D A_",",FMGX ),1,39) I '(FLDCNT#2 ) I $$CHKP S EXIT=1 Q
	8701	"RTN","PSO PRVW",121, 0)
	8702	W ! G:$$C HKP QX
	8703	"RTN","PSO PRVW",122, 0)
	8704	F FMGX=.1 41 G:EXIT QX D
	8705	"RTN","PSO PRVW",123, 0)
	8706	. I FMG(2 00,DA_",", FMGX)'="" W !,$$GET1 ^DID(200,F MGX,,"LABE L")_": "_F MG(200,DA_ ",",FMGX) I $$CHKP S EXIT=1 Q
	8707	"RTN","PSO PRVW",124, 0)
	8708	W ! G:$$C HKP QX
	8709	"RTN","PSO PRVW",125, 0)
	8710	;
	8711	"RTN","PSO PRVW",126, 0)
	8712	K DIC,Y
	8713	"RTN","PSO PRVW",127, 0)
	8714	EDT W ! L +^VA(200,D A):$S(+$G( ^DD("DILOC KTM"))>0:+ ^DD("DILOC KTM"),1:3)
	8715	"RTN","PSO PRVW",128, 0)
	8716	I '$T W $ C(7),!!,"P rovider Da ta is Bein g Edited b y Another User!",! G QX
	8717	"RTN","PSO PRVW",129, 0)
	8718	N RTPB S RTPB=$G(^V A(200,DA," TPB"))
	8719	"RTN","PSO PRVW",130, 0)
	8720	S DR="53. 91" D ^DIE I $D(Y)!$ D(DTOUT) G QX
	8721	"RTN","PSO PRVW",131, 0)
	8722	I 'X,$G(P SOTPBFG) G QX
	8723	"RTN","PSO PRVW",132, 0)
	8724	I X S DR= "53.92R;53 .93R;53.94 R;53.95R"
	8725	"RTN","PSO PRVW",133, 0)
	8726	E S DR=" 53.92;53.9 3;53.94;53 .95"
	8727	"RTN","PSO PRVW",134, 0)
	8728	S DR=DR_" ;D:X MS^PS OPRVW",DIE ("NO^")="O UTOK" D ^D IE K DIE(" NO^")
	8729	"RTN","PSO PRVW",135, 0)
	8730	I '$D(^VA (200,DA,"T PB")),$G(P SOTPBFG) G QX
	8731	"RTN","PSO PRVW",136, 0)
	8732	I $D(Y)!$ D(DTOUT) D :$P($G(^VA (200,DA,"T PB")),U,3) G QX
	8733	"RTN","PSO PRVW",137, 0)
	8734	.I RTPB=" "!('$P(RTP B,U,3)) S DR="53.96/ ///"_DUZ D ^DIE
	8735	"RTN","PSO PRVW",138, 0)
	8736	I $P($G(^ VA(200,DA, "TPB")),U, 3) D
	8737	"RTN","PSO PRVW",139, 0)
	8738	.I RTPB=" "!('$P(RTP B,U,3)) S DR="53.96/ ///"_DUZ D ^DIE
	8739	"RTN","PSO PRVW",140, 0)
	8740	N PSORTPB S PSORTPB =$G(^VA(20 0,DA,"TPB" ))
	8741	"RTN","PSO PRVW",141, 0)
	8742	I $P(PSOR TPB,U,4)'= $P(RTPB,U, 4)!($P(PSO RTPB,U,5)' =$P(RTPB,U ,5)) D
	8743	"RTN","PSO PRVW",142, 0)
	8744	.S DR="53 .96////"_D UZ D ^DIE
	8745	"RTN","PSO PRVW",143, 0)
	8746	G:$G(PSOT PBFG) QX
	8747	"RTN","PSO PRVW",144, 0)
	8748	ED1 S DR= "53.1"
	8749	"RTN","PSO PRVW",145, 0)
	8750	S DIE("NO ^")="BACKO UTOK" D ^D IE I $D(Y) !$D(DTOUT) G QX
	8751	"RTN","PSO PRVW",146, 0)
	8752	D DEAEDT^ PSOPRVW1(D A)
	8753	"RTN","PSO PRVW",147, 0)
	8754	D VANUMED T(DA)
	8755	"RTN","PSO PRVW",148, 0)
	8756	S DR="53. 4:53.6;D D R1^PSOPRVW "
	8757	"RTN","PSO PRVW",149, 0)
	8758	S DR(1,20 0,1)="D DR 1^PSOPRVW" ;Just a place hold er PSO7.0 450
	8759	"RTN","PSO PRVW",150, 0)
	8760	S DIE("NO ^")="BACKO UTOK" D ^D IE K DIE(" NO^") S FA DA=DA D:'$ D(Y) KEY
	8761	"RTN","PSO PRVW",151, 0)
	8762	QX K FADA, RTPB,PSORT PB L -^VA( 200,DA) Q: $G(PSOTPBF G) K DR,D IC,DIQ G:+ $G(VADA) A DD G ASK
	8763	"RTN","PSO PRVW",152, 0)
	8764	Q
	8765	"RTN","PSO PRVW",153, 0)
	8766	G:'$D(^VA (200,DA,"T PB")) ED1
	8767	"RTN","PSO PRVW",154, 0)
	8768	ADD ;add n ew provide rs (kernel 7)
	8769	"RTN","PSO PRVW",155, 0)
	8770	W !
	8771	"RTN","PSO PRVW",156, 0)
	8772	S VADA=$$ ADD^XUSERN EW("53.91; S:'X Y=""@ 2"";53.92R ;53.93R;53 .94R;53.95 R;D:X MS^P SOPRVW;@2; 53.1;D DEA EDT^PSOPRV W1(DA);53. 3;53.4;53. 5;53.6;53. 7;S:'X Y=" "@1"";53.8 ;@1;53.9;. 111:.116;. 131:.134;. 136;.141")
	8773	"RTN","PSO PRVW",157, 0)
	8774	S (FADA,D A)=+VADA,( DIC,DIE)=" ^VA(200,"
	8775	"RTN","PSO PRVW",158, 0)
	8776	I VADA>0, $P(VADA,U, 3),$P($G(^ VA(200,DA, "TPB")),U) D
	8777	"RTN","PSO PRVW",159, 0)
	8778	.S DR="53 .96////"_D UZ D ^DIE
	8779	"RTN","PSO PRVW",160, 0)
	8780	I VADA>0, '$P(VADA,U ,3) S DIC( 0)="AEQMZ" G:'$D(^VA (200,+VADA ,"PS")) NP RV G:$D(^V A(200,+VAD A,"PS")) A SK1
	8781	"RTN","PSO PRVW",161, 0)
	8782	D:VADA>0 KEY K DIK, DIC,Y,X,VA DA,VA,DEA Q:$G(PSOTP BFG) K DA G EX
	8783	"RTN","PSO PRVW",162, 0)
	8784	Q
	8785	"RTN","PSO PRVW",163, 0)
	8786	NPRV W ! S DIR("A",1 )=$P(^VA(2 00,DA,0),U )_" is NOT currently indicated as being a provider .",DIR("A" )="Do you want to ma ke "_$P(^V A(200,DA,0 ),U)_" a p rovider? ( Y/N): ",DI R(0)="SA^1 :YES;0:NO" ,DIR("B")= "NO"
	8787	"RTN","PSO PRVW",164, 0)
	8788	S DIR("?" ,1)="Answe r with '1' or 'Yes' if "_$P(^V A(200,DA,0 ),U)_" is to become a provider ",DIR("?") ="otherwis e press re turn for ' No' and re -enter nam e." D ^DIR G:$D(DTOU T) EX
	8789	"RTN","PSO PRVW",165, 0)
	8790	G:'Y!($D( DIRUT))&(' +$G(VADA)) ASK G:'$P (+$G(VADA) ,U,3)&('Y) ADD
	8791	"RTN","PSO PRVW",166, 0)
	8792	G EDT
	8793	"RTN","PSO PRVW",167, 0)
	8794	Q
	8795	"RTN","PSO PRVW",168, 0)
	8796	KEY I $D(^ VA(200,DA, "PS")) D
	8797	"RTN","PSO PRVW",169, 0)
	8798	.I '$P(^V A(200,DA," PS"),U,4)! ($P(^("PS" ),U,4)>DT) S PSOPDA= DA K DIC S DIC="^DIC (19.1,",DI C(0)="MZ", X="PROVIDE R" D ^DIC K DIC S DA =PSOPDA K PSOPDA I + Y>0 S X=+Y D
	8799	"RTN","PSO PRVW",170, 0)
	8800	..S:'$D(^ VA(200,FAD A,51,0)) ^ VA(200,FAD A,51,0)=U_ $P(^DD(200 ,51,0),U,2 )_"^^"
	8801	"RTN","PSO PRVW",171, 0)
	8802	..S DIC=" ^VA(200,"_ FADA_",51, ",DIC(0)=" LM",DIC("D R")="1//// "_$S($G(DU Z):DUZ,1:" ")_";2///" _DT,DLAYGO =200.051,D INUM=X,DA( 1)=FADA
	8803	"RTN","PSO PRVW",172, 0)
	8804	..L +^VA( 200,FADA): $S(+$G(^DD ("DILOCKTM "))>0:+^DD ("DILOCKTM "),1:3) K DD,DO D FI LE^DICN L -^VA(200,F ADA) K DIC ,DR,X,Y
	8805	"RTN","PSO PRVW",173, 0)
	8806	Q
	8807	"RTN","PSO PRVW",174, 0)
	8808	MS ;
	8809	"RTN","PSO PRVW",175, 0)
	8810	W !!,$C(7 ),"This pr ovider wil l not be s electable during TPB medicatio n order en try!!",!
	8811	"RTN","PSO PRVW",176, 0)
	8812	Q
	8813	"RTN","PSO PRVW",177, 0)
	8814	DR1 ;Added for proce ssing of J UMP correc tly PSO7. 0450
	8815	"RTN","PSO PRVW",178, 0)
	8816	I X'?1N!( X'>0)!(X'< 6) Q
	8817	"RTN","PSO PRVW",179, 0)
	8818	I X'=4 D Q
	8819	"RTN","PSO PRVW",180, 0)
	8820	. S (DR,D R(1),DR(1, 200,1))="D DR1^PSOPR VW;S Y=""@ 1"";53.1;5 3.21;53.11 ;53.3;53.4 ;53.5;53.6 ;@1;53.7;I 'X S Y="" @2"";53.8; @2;53.9;.1 11:.116;.1 31:.134;.1 36;.137;.1 38;.141" ;_";53.1;5 3.21;53.11 ;53.3:53.6 "
	8821	"RTN","PSO PRVW",181, 0)
	8822	S (DR,DR( 1),DR(1,20 0,1))="D D R1^PSOPRVW ;S Y=""@1" ";53.1;53. 21;53.11;5 3.3;53.4;5 3.5;53.6;@ 1;29;8932. 1;53.7;I ' X S Y=""@2 "";53.8;@2 ;53.9;.111 :.116;.131 :.134;.136 ;.137;.138 ;.141" ;_ ";53.1;53. 21;53.11;5 3.3:53.6"
	8823	"RTN","PSO PRVW",182, 0)
	8824	Q
	8825	"RTN","PSO PRVW",183, 0)
	8826	;
	8827	"RTN","PSO PRVW",184, 0)
	8828	CHKP() ; Check for End Of Pag e
	8829	"RTN","PSO PRVW",185, 0)
	8830	N X,Y,DTO UT,DUOUT,D IRUT,DIR,R ESPONSE S RESPONSE=0
	8831	"RTN","PSO PRVW",186, 0)
	8832	I $Y>(IOS L-4) W ! S DIR(0)="E " D ^DIR S :$D(DIRUT) RESPONSE= 1 W @IOF
	8833	"RTN","PSO PRVW",187, 0)
	8834	Q RESPONS E
	8835	"RTN","PSO PRVW",188, 0)
	8836	;
	8837	"RTN","PSO PRVW",189, 0)
	8838	VANUMEDT(D A) ; -- Co de used to add/edit/ delete the VA Number
	8839	"RTN","PSO PRVW",190, 0)
	8840	N ACNT,DI E,DIR,DR,X ,Y
	8841	"RTN","PSO PRVW",191, 0)
	8842	S DIR(0)= "200,53.3" D ^DIR
	8843	"RTN","PSO PRVW",192, 0)
	8844	I $G(X)=" @" D Q
	8845	"RTN","PSO PRVW",193, 0)
	8846	. S DIR(" A")="DO YO U STILL WA NT TO DELE TE THIS VA NUMBER"
	8847	"RTN","PSO PRVW",194, 0)
	8848	. S ACNT= 0
	8849	"RTN","PSO PRVW",195, 0)
	8850	. S ACNT= ACNT+1,DIR ("A",ACNT) ="Removing the VA nu mber does not affect previousl y written prescripti ons."
	8851	"RTN","PSO PRVW",196, 0)
	8852	. I '$$NP DEACNT^PSO PRVW1(DA) D
	8853	"RTN","PSO PRVW",197, 0)
	8854	.. S ACNT =ACNT+1,DI R("A",ACNT )="There a re no DEA# 's on file for this provider. The provi der will n o"
	8855	"RTN","PSO PRVW",198, 0)
	8856	.. S ACNT =ACNT+1,DI R("A",ACNT )="longer be able to prescribe controlle d substanc es at the VA via CPR S"
	8857	"RTN","PSO PRVW",199, 0)
	8858	.. S ACNT =ACNT+1,DI R("A",ACNT )="or pape r prescrip tions."
	8859	"RTN","PSO PRVW",200, 0)
	8860	. S ACNT= ACNT+1,DIR ("A",ACNT) =" "
	8861	"RTN","PSO PRVW",201, 0)
	8862	. S DIR(0 )="Y" D ^D IR
	8863	"RTN","PSO PRVW",202, 0)
	8864	. I Y=1 S DIE="^VA( 200,",DR=" 53.3///@" D ^DIE Q
	8865	"RTN","PSO PRVW",203, 0)
	8866	S DIE="^V A(200,",DR ="53.3///" _X D ^DIE
	8867	"RTN","PSO PRVW",204, 0)
	8868	Q
	8869	"RTN","PSO PRVW1")
	8870	0^8^B10377 3725
	8871	"RTN","PSO PRVW1",1,0 )
	8872	PSOPRVW1 ; BIR/BI,MHA -enter/edi t/view pro vider ; 11 /9/2018
	8873	"RTN","PSO PRVW1",2,0 )
	8874	;;7.0;OUT PATIENT PH ARMACY;5 45;DEC 1 997;Build 21
	8875	"RTN","PSO PRVW1",3,0 )
	8876	;External reference to sub-fi le NEW DEA #'S (#200 .5321) is supported by DBIA 70 00
	8877	"RTN","PSO PRVW1",4,0 )
	8878	;External reference to DEA NU MBERS file (#8991.9) is suppor ted by DBI A 7002
	8879	"RTN","PSO PRVW1",5,0 )
	8880	;
	8881	"RTN","PSO PRVW1",6,0 )
	8882	Q
	8883	"RTN","PSO PRVW1",7,0 )
	8884	WS(X,DIIEN S) ; -- L ink the NE W PERSON F ILE #200 D EA pointer to the DE A NUMBERS FILE #8991 .9 record.
	8885	"RTN","PSO PRVW1",8,0 )
	8886	N DNDEAIE N,DA,DR,FD A
	8887	"RTN","PSO PRVW1",9,0 )
	8888	Q:$G(X)=" " Q:$L(DI IENS,",")' =3
	8889	"RTN","PSO PRVW1",10, 0)
	8890	S DNDEAIE N=$$EN^PSO DEAME(X)
	8891	"RTN","PSO PRVW1",11, 0)
	8892	I +DNDEAI EN D
	8893	"RTN","PSO PRVW1",12, 0)
	8894	. S FDA(2 ,200.5321, DIIENS,.03 )=+DNDEAIE N
	8895	"RTN","PSO PRVW1",13, 0)
	8896	. D UPDAT E^DIE(""," FDA(2)")
	8897	"RTN","PSO PRVW1",14, 0)
	8898	Q
	8899	"RTN","PSO PRVW1",15, 0)
	8900	;
	8901	"RTN","PSO PRVW1",16, 0)
	8902	INS(X) ; -- Check f or an Inst itutional DEA Number
	8903	"RTN","PSO PRVW1",17, 0)
	8904	N DNDEAIE N,TYPE
	8905	"RTN","PSO PRVW1",18, 0)
	8906	Q:$G(X)=" " 0
	8907	"RTN","PSO PRVW1",19, 0)
	8908	S DNDEAIE N=$O(^XTV( 8991.9,"B" ,X,0)) Q:' DNDEAIEN 0
	8909	"RTN","PSO PRVW1",20, 0)
	8910	S TYPE=$$ GET1^DIQ(8 991.9,DNDE AIEN,.07)
	8911	"RTN","PSO PRVW1",21, 0)
	8912	I TYPE="I NSTITUTION AL" Q 1
	8913	"RTN","PSO PRVW1",22, 0)
	8914	Q 0
	8915	"RTN","PSO PRVW1",23, 0)
	8916	;
	8917	"RTN","PSO PRVW1",24, 0)
	8918	NULL(X,DII ENS) ; -- Check for an User E xit withou t using th e Copy fun ction.
	8919	"RTN","PSO PRVW1",25, 0)
	8920	N DNDEAIE N,DA,DR,FD A,DQ,DP,DM ,DL,DK
	8921	"RTN","PSO PRVW1",26, 0)
	8922	Q:$G(X)=" " 0
	8923	"RTN","PSO PRVW1",27, 0)
	8924	S DNDEAIE N=$O(^XTV( 8991.9,"B" ,X,0))
	8925	"RTN","PSO PRVW1",28, 0)
	8926	I '+DNDEA IEN D Q 1
	8927	"RTN","PSO PRVW1",29, 0)
	8928	. S DA=$P (DIIENS,", ",1),DA(1) =$P(DIIENS ,",",2)
	8929	"RTN","PSO PRVW1",30, 0)
	8930	. S DIE=" ^VA(200,"_ DA(1)_","" PS4"","
	8931	"RTN","PSO PRVW1",31, 0)
	8932	. S DR=". 01///@" D ^DIE
	8933	"RTN","PSO PRVW1",32, 0)
	8934	Q 0
	8935	"RTN","PSO PRVW1",33, 0)
	8936	;
	8937	"RTN","PSO PRVW1",34, 0)
	8938	DEAEDT(NPI EN) ; -- Code to us e the DEA API to dow nload and update DOJ /DEA Infor mation
	8939	"RTN","PSO PRVW1",35, 0)
	8940	I '$G(NPI EN) Q
	8941	"RTN","PSO PRVW1",36, 0)
	8942	N %,%DT,C NT,DA,DIIE NS,DIE,D,D I,DIC,DIR, DIRUT,DNDE AIEN,DNDEA TXT,DR,D0, NPDEAIEN,N PDEALST,NP DEATXT,X,Y ,SAVEX
	8943	"RTN","PSO PRVW1",37, 0)
	8944	N DK,DL,D M,DP,DQ
	8945	"RTN","PSO PRVW1",38, 0)
	8946	;
	8947	"RTN","PSO PRVW1",39, 0)
	8948	; Check V AMC/MbM mo de
	8949	"RTN","PSO PRVW1",40, 0)
	8950	; If VAMC mode only allow for FEE BASIS and C & A provider types.
	8951	"RTN","PSO PRVW1",41, 0)
	8952	N VAMCMBM F D MBM^PS ODEAUT(.VA MCMBMF)
	8953	"RTN","PSO PRVW1",42, 0)
	8954	N PROVTYP E S PROVTY PE=$$GET1^ DIQ(200,NP IEN,53.6," I")
	8955	"RTN","PSO PRVW1",43, 0)
	8956	I VAMCMBM F=0&((PROV TYPE'=3)&( PROVTYPE'= 4)) Q
	8957	"RTN","PSO PRVW1",44, 0)
	8958	;
	8959	"RTN","PSO PRVW1",45, 0)
	8960	S NPDEALS T(0)=0
	8961	"RTN","PSO PRVW1",46, 0)
	8962	S NPDEAIE N=0 F CNT= 1:1 S NPDE AIEN=$O(^V A(200,NPIE N,"PS4",NP DEAIEN)) Q :'NPDEAIEN D
	8963	"RTN","PSO PRVW1",47, 0)
	8964	. S NPDEA LST(CNT)=$ $GET1^DIQ( 200.5321,N PDEAIEN_", "_NPIEN_", ",.01)
	8965	"RTN","PSO PRVW1",48, 0)
	8966	. S $P(NP DEALST(CNT ),U,2)=$$G ET1^DIQ(20 0.5321,NPD EAIEN_","_ NPIEN_",", .02)
	8967	"RTN","PSO PRVW1",49, 0)
	8968	. S $P(NP DEALST(CNT ),U,3)=$$G ET1^DIQ(20 0.5321,NPD EAIEN_","_ NPIEN_",", .03,"I")
	8969	"RTN","PSO PRVW1",50, 0)
	8970	. S $P(NP DEALST(CNT ),U,4)=NPD EAIEN_","_ NPIEN_","
	8971	"RTN","PSO PRVW1",51, 0)
	8972	. S:$P(NP DEALST(CNT ),U,3) $P( NPDEALST(C NT),U,5)=$ $GET1^DIQ( 8991.9,$P( NPDEALST(C NT),U,3)_" ,",1.6)
	8973	"RTN","PSO PRVW1",52, 0)
	8974	. S:$P(NP DEALST(CNT ),U,3) $P( NPDEALST(C NT),U,6)=$ $GET1^DIQ( 8991.9,$P( NPDEALST(C NT),U,3)_" ,",.03)
	8975	"RTN","PSO PRVW1",53, 0)
	8976	. S NPDEA LST("B",$P (NPDEALST( CNT),U,1)) =NPDEALST( CNT)
	8977	"RTN","PSO PRVW1",54, 0)
	8978	. S NPDEA LST(0)=CNT
	8979	"RTN","PSO PRVW1",55, 0)
	8980	W !!,"DEA NUMBERS", !
	8981	"RTN","PSO PRVW1",56, 0)
	8982	F CNT=1:1 :NPDEALST( 0) D
	8983	"RTN","PSO PRVW1",57, 0)
	8984	. W $E(" ",1,5-$ L(CNT)),CN T," - ",$P (NPDEALST( CNT),U,1)
	8985	"RTN","PSO PRVW1",58, 0)
	8986	. W:$P(NP DEALST(CNT ),U,2)'="" "-",$P(NP DEALST(CNT ),U,2)
	8987	"RTN","PSO PRVW1",59, 0)
	8988	. W " ",$ P(NPDEALST (CNT),U,5)
	8989	"RTN","PSO PRVW1",60, 0)
	8990	. W:$P(NP DEALST(CNT ),U,6)'="" " Contai ns Detox # ",$P(NPDE ALST(CNT), U,6)
	8991	"RTN","PSO PRVW1",61, 0)
	8992	. W:$O(NP DEALST(CNT )) !
	8993	"RTN","PSO PRVW1",62, 0)
	8994	K DIRUT,D IR S DIR(0 )="FO^1:9^ K:'$$DEAED TST^PSOPRV W1(X,.NPDE ALST,NPIEN ) X"
	8995	"RTN","PSO PRVW1",63, 0)
	8996	S DIR("A" ,1)=" "
	8997	"RTN","PSO PRVW1",64, 0)
	8998	S DIR("A" ,2)="SELEC T an exist ing entry to edit,"
	8999	"RTN","PSO PRVW1",65, 0)
	9000	S DIR("A" ,3)="Type a DEA numb er (e.g., AA1234563) to begin a new entr y,"
	9001	"RTN","PSO PRVW1",66, 0)
	9002	S DIR("A" )="or type '@' to de lete an ex isting ent ry."
	9003	"RTN","PSO PRVW1",67, 0)
	9004	S DIR("?" ,1)="Selec t a choice from the list above or,"
	9005	"RTN","PSO PRVW1",68, 0)
	9006	S DIR("?" ,2)="Enter a New DEA Number."
	9007	"RTN","PSO PRVW1",69, 0)
	9008	S DIR("?" ,3)="Or ty pe '@' to delete an existing e ntry."
	9009	"RTN","PSO PRVW1",70, 0)
	9010	S DIR("?" )="DEA NUM BERS must be valid, 2 letters and 7 numb ers."
	9011	"RTN","PSO PRVW1",71, 0)
	9012	D ^DIR S: X="@" DIRU T=0 I $G(D IRUT) G DE AEDTX
	9013	"RTN","PSO PRVW1",72, 0)
	9014	S SAVEX=X
	9015	"RTN","PSO PRVW1",73, 0)
	9016	I '$D(NPD EALST(X))& ('$D(NPDEA LST("B",X) )) D
	9017	"RTN","PSO PRVW1",74, 0)
	9018	. S:'$D(^ VA(200,NPI EN,"PS4",0 )) ^VA(200 ,NPIEN,"PS 4",0)="^20 0.5321^^0"
	9019	"RTN","PSO PRVW1",75, 0)
	9020	. S DIIEN S=$O(^VA(2 00,NPIEN," PS4",999), -1)+1_","_ NPIEN_","
	9021	"RTN","PSO PRVW1",76, 0)
	9022	. S DA=$P (DIIENS,", ",1),DA(1) =$P(DIIENS ,",",2)
	9023	"RTN","PSO PRVW1",77, 0)
	9024	. S DIE=" ^VA(200,"_ DA(1)_","" PS4"","
	9025	"RTN","PSO PRVW1",78, 0)
	9026	. S DR=". 01///"_X D ^DIE
	9027	"RTN","PSO PRVW1",79, 0)
	9028	S X=SAVEX
	9029	"RTN","PSO PRVW1",80, 0)
	9030	I $D(NPDE ALST(X)) D
	9031	"RTN","PSO PRVW1",81, 0)
	9032	. S DNDEA TXT=$P(NPD EALST(X),U ,1)
	9033	"RTN","PSO PRVW1",82, 0)
	9034	. S DNDEA IEN=$P(NPD EALST(X),U ,3)
	9035	"RTN","PSO PRVW1",83, 0)
	9036	. S DIIEN S=$P(NPDEA LST(X),U,4 )
	9037	"RTN","PSO PRVW1",84, 0)
	9038	I $D(NPDE ALST("B",X )) D
	9039	"RTN","PSO PRVW1",85, 0)
	9040	. S DNDEA TXT=$P(NPD EALST("B", X),U,1)
	9041	"RTN","PSO PRVW1",86, 0)
	9042	. S DNDEA IEN=$P(NPD EALST("B", X),U,3)
	9043	"RTN","PSO PRVW1",87, 0)
	9044	. S DIIEN S=$P(NPDEA LST("B",X) ,U,4)
	9045	"RTN","PSO PRVW1",88, 0)
	9046	S X=SAVEX
	9047	"RTN","PSO PRVW1",89, 0)
	9048	I X="@",$ $DELDEA(.N PDEALST) G DEAEDTX
	9049	"RTN","PSO PRVW1",90, 0)
	9050	I X="@" G DEAEDTX
	9051	"RTN","PSO PRVW1",91, 0)
	9052	S NPDEATX T=$$GET1^D IQ(200.532 1,DIIENS,. 01)
	9053	"RTN","PSO PRVW1",92, 0)
	9054	D WS^PSOP RVW1(NPDEA TXT,DIIENS )
	9055	"RTN","PSO PRVW1",93, 0)
	9056	I $$NULL^ PSOPRVW1(N PDEATXT,DI IENS) G DE AEDTX
	9057	"RTN","PSO PRVW1",94, 0)
	9058	I '$$INS^ PSOPRVW1(N PDEATXT) G DEAEDTX
	9059	"RTN","PSO PRVW1",95, 0)
	9060	S DA=$P(D IIENS,",", 1),DA(1)=$ P(DIIENS," ,",2)
	9061	"RTN","PSO PRVW1",96, 0)
	9062	S DIE="^V A(200,"_DA (1)_",""PS 4"",",DR=" .02R" D ^D IE
	9063	"RTN","PSO PRVW1",97, 0)
	9064	I '$D(DA) ,$D(DNDEAT XT),DNDEAI EN,'$D(^VA (200,"PS4" ,DNDEATXT) ) D
	9065	"RTN","PSO PRVW1",98, 0)
	9066	. K FDA S FDA(1,899 1.9,DNDEAI EN_",",.06 )=0 D UPDA TE^DIE("", "FDA(1)") K FDA
	9067	"RTN","PSO PRVW1",99, 0)
	9068	DEAEDTX ; Subroutine Exit Tag
	9069	"RTN","PSO PRVW1",100 ,0)
	9070	W !! D IN PUSE(NPIEN )
	9071	"RTN","PSO PRVW1",101 ,0)
	9072	Q
	9073	"RTN","PSO PRVW1",102 ,0)
	9074	;
	9075	"RTN","PSO PRVW1",103 ,0)
	9076	DEAEDTST(X ,NPDEALST, NPIEN) ; -- Input T ransform f or the DEA EDT Tag.
	9077	"RTN","PSO PRVW1",104 ,0)
	9078	N DIR,DND EAIEN,FG,I NST,LNAME, RESPONSE S RESPONSE= 0
	9079	"RTN","PSO PRVW1",105 ,0)
	9080	I X="@" S RESPONSE= 1 G DEAEDT SX
	9081	"RTN","PSO PRVW1",106 ,0)
	9082	I $D(NPDE ALST(X)) S RESPONSE= 1 G DEAEDT SX
	9083	"RTN","PSO PRVW1",107 ,0)
	9084	I '$$DEAN UM^PSODEAU T(X) S RES PONSE=0 D G DEAEDTS X
	9085	"RTN","PSO PRVW1",108 ,0)
	9086	. D EN^DD IOL($C(7)_ "DEA numbe r is inval id. Pleas e check th e number e ntered.")
	9087	"RTN","PSO PRVW1",109 ,0)
	9088	. S RESPO NSE=0
	9089	"RTN","PSO PRVW1",110 ,0)
	9090	I '$$DEAN UMFL^PSODE AUT(X) S R ESPONSE=0 G DEAEDTSX
	9091	"RTN","PSO PRVW1",111 ,0)
	9092	S DNDEAIE N=$O(^XTV( 8991.9,"B" ,X,0)),INS T=$$GET1^D IQ(8991.9, DNDEAIEN,. 07,"I")
	9093	"RTN","PSO PRVW1",112 ,0)
	9094	I INST'=1 ,$D(X),$D( NPIEN),$D( ^VA(200,"P S4",X)),$O (^(X,0))'= NPIEN D G DEAEDTSX
	9095	"RTN","PSO PRVW1",113 ,0)
	9096	. D EN^DD IOL($C(7)_ "Provider DEA number is alread y associat ed to anot her profil e.")
	9097	"RTN","PSO PRVW1",114 ,0)
	9098	. D EN^DD IOL($C(7)_ "Please ch eck the nu mber enter ed.")
	9099	"RTN","PSO PRVW1",115 ,0)
	9100	. S RESPO NSE=0
	9101	"RTN","PSO PRVW1",116 ,0)
	9102	S RESPONS E=$$WSGET^ PSODEAUT(. FG,X) I 'R ESPONSE W !!,"*** "_ $P(RESPONS E,U,2)_" * **" S RESP ONSE=0 G D EAEDTSX
	9103	"RTN","PSO PRVW1",117 ,0)
	9104	;
	9105	"RTN","PSO PRVW1",118 ,0)
	9106	; Test fo r name mat ch, provid e an optio n to rejec t.
	9107	"RTN","PSO PRVW1",119 ,0)
	9108	S LNAME=$ $GET1^DIQ( 200,NPIEN, .01)
	9109	"RTN","PSO PRVW1",120 ,0)
	9110	I $P(FG(" name"),"," ,1)'=$P(LN AME,",",1) D
	9111	"RTN","PSO PRVW1",121 ,0)
	9112	. W !!,"D OJ NAME: ",FG("nam e")
	9113	"RTN","PSO PRVW1",122 ,0)
	9114	. W !,"VI STA NAME: ",LNAME,!
	9115	"RTN","PSO PRVW1",123 ,0)
	9116	. S DIR(0 )="Y"
	9117	"RTN","PSO PRVW1",124 ,0)
	9118	. S DIR(" A",1)="The last name s don't ma tch."
	9119	"RTN","PSO PRVW1",125 ,0)
	9120	. S DIR(" A")="Do yo u really w ant to con tinue"
	9121	"RTN","PSO PRVW1",126 ,0)
	9122	. D ^DIR I Y'=1 S R ESPONSE=0
	9123	"RTN","PSO PRVW1",127 ,0)
	9124	;
	9125	"RTN","PSO PRVW1",128 ,0)
	9126	DEAEDTSX ; Subroutin e Exit Tag
	9127	"RTN","PSO PRVW1",129 ,0)
	9128	Q RESPONS E
	9129	"RTN","PSO PRVW1",130 ,0)
	9130	;
	9131	"RTN","PSO PRVW1",131 ,0)
	9132	INPUSE(NPI EN) ; -- Subroutine to set th e DEA NUMB ER "USE FO R INPATIEN T ORDERS?" flag.
	9133	"RTN","PSO PRVW1",132 ,0)
	9134	N CNT,DEA CNT,DIR,DI RUT,DNDEAI EN,FDA,MUL TIP,NPDEAI EN,NPDEALS T,UFIO,UFI OCNTY,UFIO CNTN,X,XSA VE,Y S UFI OCNTY=0,UF IOCNTN=0
	9135	"RTN","PSO PRVW1",133 ,0)
	9136	;
	9137	"RTN","PSO PRVW1",134 ,0)
	9138	I '$O(^VA (200,NPIEN ,"PS4",0)) Q
	9139	"RTN","PSO PRVW1",135 ,0)
	9140	;
	9141	"RTN","PSO PRVW1",136 ,0)
	9142	; Loop th rough the DEA number s in the N EW PERSON FILE #200
	9143	"RTN","PSO PRVW1",137 ,0)
	9144	S CNT=0,D EACNT=0,NP DEAIEN=0 F S NPDEAI EN=$O(^VA( 200,NPIEN, "PS4",NPDE AIEN)) Q:' NPDEAIEN D
	9145	"RTN","PSO PRVW1",138 ,0)
	9146	. ;
	9147	"RTN","PSO PRVW1",139 ,0)
	9148	. ; Get t he DEA NUM BER IEN fr om the poi nter in th e NEW PERS ON FILE
	9149	"RTN","PSO PRVW1",140 ,0)
	9150	. S DNDEA IEN=$$GET1 ^DIQ(200.5 321,NPDEAI EN_","_NPI EN_",",.03 ,"I") Q:'D NDEAIEN
	9151	"RTN","PSO PRVW1",141 ,0)
	9152	. ;
	9153	"RTN","PSO PRVW1",142 ,0)
	9154	. ; Test for an INS TITUTIONAL DEA; egno re INSTITI ONAL DEA N umbers
	9155	"RTN","PSO PRVW1",143 ,0)
	9156	. Q:$$GET 1^DIQ(8991 .9,DNDEAIE N,.07,"I") '=2
	9157	"RTN","PSO PRVW1",144 ,0)
	9158	. ;
	9159	"RTN","PSO PRVW1",145 ,0)
	9160	. ; Load the New Pe rson Dea L ist (NPDEA LST)
	9161	"RTN","PSO PRVW1",146 ,0)
	9162	. ; Piece : 1 - DEA NUMBER
	9163	"RTN","PSO PRVW1",147 ,0)
	9164	. ; 2 - DEA POINTER; P OINTER TO DEA NUMBER S FILE (#8 991.9)
	9165	"RTN","PSO PRVW1",148 ,0)
	9166	. ; 3 - USE FOR INPATI ENT ORDERS ? flag fro m the DEA NUMBERS FI LE (#8991. 9)
	9167	"RTN","PSO PRVW1",149 ,0)
	9168	. S CNT=C NT+1
	9169	"RTN","PSO PRVW1",150 ,0)
	9170	. S $P(NP DEALST(CNT ),U,1)=$$G ET1^DIQ(20 0.5321,NPD EAIEN_","_ NPIEN,.01)
	9171	"RTN","PSO PRVW1",151 ,0)
	9172	. S $P(NP DEALST(CNT ),U,2)=DND EAIEN
	9173	"RTN","PSO PRVW1",152 ,0)
	9174	. S UFIO= $$GET1^DIQ (8991.9,DN DEAIEN,.06 ),$P(NPDEA LST(CNT),U ,3)=$S(UFI O="YES":"Y ES",1:"NO" )
	9175	"RTN","PSO PRVW1",153 ,0)
	9176	. S:UFIO= "YES" UFIO CNTY=UFIOC NTY+1
	9177	"RTN","PSO PRVW1",154 ,0)
	9178	. S:UFIO' ="YES" UFI OCNTN=UFIO CNTN+1
	9179	"RTN","PSO PRVW1",155 ,0)
	9180	. S DEACN T=CNT
	9181	"RTN","PSO PRVW1",156 ,0)
	9182	Q:DEACNT= 0
	9183	"RTN","PSO PRVW1",157 ,0)
	9184	;
	9185	"RTN","PSO PRVW1",158 ,0)
	9186	I DEACNT= 1,$P(NPDEA LST(1),U,3 )="YES" Q
	9187	"RTN","PSO PRVW1",159 ,0)
	9188	I DEACNT= 1,$P(NPDEA LST(1),U,3 )'="YES" D Q
	9189	"RTN","PSO PRVW1",160 ,0)
	9190	. K FDA S FDA(1,899 1.9,$P(NPD EALST(1),U ,2)_",",.0 6)=1 D UPD ATE^DIE("" ,"FDA(1)") K FDA
	9191	"RTN","PSO PRVW1",161 ,0)
	9192	;
	9193	"RTN","PSO PRVW1",162 ,0)
	9194	; Write t he list to the scree n, identif ying the c urrent DEA NUMBER to "USE FOR INPATIENT ORDERS?"
	9195	"RTN","PSO PRVW1",163 ,0)
	9196	W "USE FO R INPATIEN T ORDERS", !
	9197	"RTN","PSO PRVW1",164 ,0)
	9198	S CNT=0 F S CNT=$O (NPDEALST( CNT)) Q:'C NT D
	9199	"RTN","PSO PRVW1",165 ,0)
	9200	. W $E(" ",1,5-$ L(CNT)),CN T," - ",$P (NPDEALST( CNT),U,1), " - "_$P(N PDEALST(CN T),U,3)
	9201	"RTN","PSO PRVW1",166 ,0)
	9202	. W:$O(NP DEALST(CNT )) !
	9203	"RTN","PSO PRVW1",167 ,0)
	9204	;
	9205	"RTN","PSO PRVW1",168 ,0)
	9206	IPSLOOP ; Loop to pr event the user from existing w ithout sel ecting a D EA number for inpati ent usage.
	9207	"RTN","PSO PRVW1",169 ,0)
	9208	; Set up the user i nterface p rompt to s elect the "ONE" DEA NUMBER to be used fo r inpatien t orders.
	9209	"RTN","PSO PRVW1",170 ,0)
	9210	; If ther e are more than one DEA NUMBER currently and none selected, make it a required r esponse.
	9211	"RTN","PSO PRVW1",171 ,0)
	9212	; If ther e are more than one DEA NUMBER currently selected, make it a required response.
	9213	"RTN","PSO PRVW1",172 ,0)
	9214	; If ther e is only one DEA NU MBER, make it a requ ired respo nse, and d efault to 1.
	9215	"RTN","PSO PRVW1",173 ,0)
	9216	K DIRUT,D IR S DIR(0 )="F"_$S(U FIOCNTY=0: "",UFIOCNT Y>1:"",DEA CNT=1:"",1 :"O")_"^1: 9^K:'$D(NP DEALST(X)) X"
	9217	"RTN","PSO PRVW1",174 ,0)
	9218	S DIR("A" )="SELECT a DEA NUMB ER to chan ge the ent ry for INP ATIENT USA GE"
	9219	"RTN","PSO PRVW1",175 ,0)
	9220	S:DEACNT= 1 DIR("B") =1
	9221	"RTN","PSO PRVW1",176 ,0)
	9222	S DIR("?" ,1)="Selec t a choice from the list above ."
	9223	"RTN","PSO PRVW1",177 ,0)
	9224	S DIR("?" )="Must be a numeric value fro m the list above."
	9225	"RTN","PSO PRVW1",178 ,0)
	9226	D ^DIR
	9227	"RTN","PSO PRVW1",179 ,0)
	9228	I UFIOCNT Y=0,((X="^ ")!(X="^^" )) W !!,"T HERE MUST BE ONE DEA SELECTED FOR INPATI ENT ORDERS ." G IPSLO OP
	9229	"RTN","PSO PRVW1",180 ,0)
	9230	I UFIOCNT Y>1,((X="^ ")!(X="^^" )) W !!,"T HERE CAN B E ONLY ONE DEA SELEC TED FOR IN PATIENT OR DERS." G I PSLOOP
	9231	"RTN","PSO PRVW1",181 ,0)
	9232	I $G(DIRU T) W ! Q
	9233	"RTN","PSO PRVW1",182 ,0)
	9234	W !
	9235	"RTN","PSO PRVW1",183 ,0)
	9236	S XSAVE=X
	9237	"RTN","PSO PRVW1",184 ,0)
	9238	;
	9239	"RTN","PSO PRVW1",185 ,0)
	9240	; Set up the FDA ar ray; marki ng the sel ected DEA NUMBER equ al to YES( 1) and the other DEA NUMBERS e qual to NO (0)
	9241	"RTN","PSO PRVW1",186 ,0)
	9242	S CNT=0,M ULTIP=0 F S CNT=$O( NPDEALST(C NT)) Q:'CN T D
	9243	"RTN","PSO PRVW1",187 ,0)
	9244	. I CNT=X SAVE S FDA (1,8991.9, $P(NPDEALS T(CNT),U,2 )_",",.06) =1 Q
	9245	"RTN","PSO PRVW1",188 ,0)
	9246	. I $P(NP DEALST(CNT ),U,3)="YE S" D
	9247	"RTN","PSO PRVW1",189 ,0)
	9248	.. S MULT IP=MULTIP+ 1
	9249	"RTN","PSO PRVW1",190 ,0)
	9250	.. W !,"D EA # "_$P( NPDEALST(C NT),U,1)_" is alread y flagged as ""Use f or Inpatie nt Orders" "."
	9251	"RTN","PSO PRVW1",191 ,0)
	9252	.. S FDA( 1,8991.9,$ P(NPDEALST (CNT),U,2) _",",.06)= 0
	9253	"RTN","PSO PRVW1",192 ,0)
	9254	;
	9255	"RTN","PSO PRVW1",193 ,0)
	9256	; Ask the user to v erify the "Update". Apply the FDA array for a "YE S" respons e.
	9257	"RTN","PSO PRVW1",194 ,0)
	9258	K DIRUT,D IR
	9259	"RTN","PSO PRVW1",195 ,0)
	9260	I MULTIP D
	9261	"RTN","PSO PRVW1",196 ,0)
	9262	. S DIR(0 )="Y",DIR( "B")="YES"
	9263	"RTN","PSO PRVW1",197 ,0)
	9264	. S DIR(" A",1)="The previous DEA # will no longer be flagge d as ""Use for Inpat ient Order s""."
	9265	"RTN","PSO PRVW1",198 ,0)
	9266	. S DIR(" A")="Do yo u want to proceed wi th this ch ange"
	9267	"RTN","PSO PRVW1",199 ,0)
	9268	. D ^DIR
	9269	"RTN","PSO PRVW1",200 ,0)
	9270	I Y=1 D U PDATE^DIE( "","FDA(1) ")
	9271	"RTN","PSO PRVW1",201 ,0)
	9272	I 'MULTIP D UPDATE^ DIE("","FD A(1)")
	9273	"RTN","PSO PRVW1",202 ,0)
	9274	;
	9275	"RTN","PSO PRVW1",203 ,0)
	9276	; Re-Disp lay the ch anges.
	9277	"RTN","PSO PRVW1",204 ,0)
	9278	W !
	9279	"RTN","PSO PRVW1",205 ,0)
	9280	N NPDEATX T S NPDEAI EN=0 F S NPDEAIEN=$ O(^VA(200, NPIEN,"PS4 ",NPDEAIEN )) Q:'NPDE AIEN D
	9281	"RTN","PSO PRVW1",206 ,0)
	9282	. S DNDEA IEN=$$GET1 ^DIQ(200.5 321,NPDEAI EN_","_NPI EN_",",.03 ,"I") Q:'D NDEAIEN
	9283	"RTN","PSO PRVW1",207 ,0)
	9284	. Q:$$GET 1^DIQ(8991 .9,DNDEAIE N,.07,"I") '=2
	9285	"RTN","PSO PRVW1",208 ,0)
	9286	. S NPDEA TXT=$$GET1 ^DIQ(200.5 321,NPDEAI EN_","_NPI EN,.01)
	9287	"RTN","PSO PRVW1",209 ,0)
	9288	. S UFIO= $$GET1^DIQ (8991.9,DN DEAIEN,.06 )
	9289	"RTN","PSO PRVW1",210 ,0)
	9290	. W " ",NPDE ATXT," - " _$S(UFIO=" YES":"YES" ,1:"NO"),!
	9291	"RTN","PSO PRVW1",211 ,0)
	9292	Q
	9293	"RTN","PSO PRVW1",212 ,0)
	9294	;
	9295	"RTN","PSO PRVW1",213 ,0)
	9296	DELDEA(NPD EALST) ; - - Code use d to add/e dit/delete the VA Nu mber
	9297	"RTN","PSO PRVW1",214 ,0)
	9298	N ACNT,D, DA,DEATYPE ,DI,DIC,DI E,DIE1,DIE DA,DIEL,DI ETMP,DIEXR EF,DIFLD,D IR,DNDEAIE N
	9299	"RTN","PSO PRVW1",215 ,0)
	9300	N DNDETOX ,DR,NPDEAC NT,NPDEATX T,RESPONSE ,VANUMBER, X,Y,SELECT ED
	9301	"RTN","PSO PRVW1",216 ,0)
	9302	S RESPONS E=0
	9303	"RTN","PSO PRVW1",217 ,0)
	9304	K DIRUT,D IR S DIR(0 )="NO^1:"_ NPDEALST(0 )_":0^"
	9305	"RTN","PSO PRVW1",218 ,0)
	9306	S DIR("A" ,1)=" "
	9307	"RTN","PSO PRVW1",219 ,0)
	9308	S DIR("A" )="Select a choice f rom the li st for DEL ETION."
	9309	"RTN","PSO PRVW1",220 ,0)
	9310	S DIR("?" )="Enter a number fr om the lis t above."
	9311	"RTN","PSO PRVW1",221 ,0)
	9312	D ^DIR I $G(DIRUT) G DELDEAQ
	9313	"RTN","PSO PRVW1",222 ,0)
	9314	S SELECTE D=X
	9315	"RTN","PSO PRVW1",223 ,0)
	9316	S DIIENS= $P(NPDEALS T(SELECTED ),"^",4)
	9317	"RTN","PSO PRVW1",224 ,0)
	9318	I $L(DIIE NS,",")'=3 G DELDEAQ
	9319	"RTN","PSO PRVW1",225 ,0)
	9320	S NPDEACN T=$$NPDEAC NT($P(DIIE NS,",",2))
	9321	"RTN","PSO PRVW1",226 ,0)
	9322	S VANUMBE R=$$GET1^D IQ(200,$P( DIIENS,"," ,2),53.3)
	9323	"RTN","PSO PRVW1",227 ,0)
	9324	S NPDEATX T=$$GET1^D IQ(200.532 1,DIIENS,. 01)
	9325	"RTN","PSO PRVW1",228 ,0)
	9326	S DNDEAIE N=$$GET1^D IQ(200.532 1,DIIENS,. 03,"I")
	9327	"RTN","PSO PRVW1",229 ,0)
	9328	S DNDETOX =$$GET1^DI Q(8991.9,D NDEAIEN,.0 3)
	9329	"RTN","PSO PRVW1",230 ,0)
	9330	S DEATYPE =$$GET1^DI Q(8991.9,D NDEAIEN,.0 7,"I")
	9331	"RTN","PSO PRVW1",231 ,0)
	9332	S DA=$P(D IIENS,",", 1),DA(1)=$ P(DIIENS," ,",2)
	9333	"RTN","PSO PRVW1",232 ,0)
	9334	S DIR("A" )="DO YOU STILL WANT TO DELETE THIS DEA NUMBER"
	9335	"RTN","PSO PRVW1",233 ,0)
	9336	S ACNT=0
	9337	"RTN","PSO PRVW1",234 ,0)
	9338	S ACNT=AC NT+1,DIR(" A",ACNT)=" "
	9339	"RTN","PSO PRVW1",235 ,0)
	9340	S ACNT=AC NT+1,DIR(" A",ACNT)=" Removing t he DEA num ber does n ot affect previously written p rescriptio ns."
	9341	"RTN","PSO PRVW1",236 ,0)
	9342	I VANUMBE R="",NPDEA CNT=1 D
	9343	"RTN","PSO PRVW1",237 ,0)
	9344	. S ACNT= ACNT+1,DIR ("A",ACNT) ="This is the only D EA number on file fo r this pro vider. The provider will no"
	9345	"RTN","PSO PRVW1",238 ,0)
	9346	. S ACNT= ACNT+1,DIR ("A",ACNT) ="longer b e able to prescribe controlled substance s at the V A via CPRS or paper"
	9347	"RTN","PSO PRVW1",239 ,0)
	9348	. S ACNT= ACNT+1,DIR ("A",ACNT) ="prescrip tions."
	9349	"RTN","PSO PRVW1",240 ,0)
	9350	I DNDETOX '="" D
	9351	"RTN","PSO PRVW1",241 ,0)
	9352	. S ACNT= ACNT+1,DIR ("A",ACNT) ="This DEA # contain s Detox # "_DNDETOX_ ". To main tain the D etox #,"
	9353	"RTN","PSO PRVW1",242 ,0)
	9354	. S ACNT= ACNT+1,DIR ("A",ACNT) ="please a dd it to a nother DEA # on the provider's profile."
	9355	"RTN","PSO PRVW1",243 ,0)
	9356	S ACNT=AC NT+1,DIR(" A",ACNT)=" "
	9357	"RTN","PSO PRVW1",244 ,0)
	9358	S DIR(0)= "Y" D ^DIR K DIR G:Y '=1 DELDEA Q
	9359	"RTN","PSO PRVW1",245 ,0)
	9360	S DIE="^V A(200,"_DA (1)_",""PS 4"",",DR=" .01///@" D ^DIE K DI E,DR,DA
	9361	"RTN","PSO PRVW1",246 ,0)
	9362	I DEATYPE =2 S DA=DN DEAIEN,DIK ="^XTV(899 1.9," D ^D IK K DIK,D A
	9363	"RTN","PSO PRVW1",247 ,0)
	9364	S RESPONS E=1
	9365	"RTN","PSO PRVW1",248 ,0)
	9366	DELDEAQ ; -- Common Exit Poin t
	9367	"RTN","PSO PRVW1",249 ,0)
	9368	Q RESPONS E
	9369	"RTN","PSO PRVW1",250 ,0)
	9370	;
	9371	"RTN","PSO PRVW1",251 ,0)
	9372	NPDEACNT(N PIEN) ; -- Function used to co unt the nu mber of DE A numbers for a prov ider.
	9373	"RTN","PSO PRVW1",252 ,0)
	9374	N NPDEAIE N,NPDEACNT
	9375	"RTN","PSO PRVW1",253 ,0)
	9376	S NPDEAIE N=0 F NPDE ACNT=0:1 S NPDEAIEN= $O(^VA(200 ,NPIEN,"PS 4",NPDEAIE N)) Q:+NPD EAIEN=0
	9377	"RTN","PSO PRVW1",254 ,0)
	9378	Q NPDEACN T
	9379	"RTN","PSO RENW0")
	9380	0^20^B8527 6396
	9381	"RTN","PSO RENW0",1,0 )
	9382	PSORENW0 ; IHS/DSD/JC M-renew ma in driver continuati on ;2/8/06 8:40am
	9383	"RTN","PSO RENW0",2,0 )
	9384	;;7.0;OUT PATIENT PH ARMACY;1 1,27,32,59 ,64,46,71, 96,100,130 ,237,206,2 51,375,379 ,372,411,5 18,545;D EC 1997;Bu ild 21
	9385	"RTN","PSO RENW0",3,0 )
	9386	;External reference to ^PS(50 .7 support ed by DBIA 2223
	9387	"RTN","PSO RENW0",4,0 )
	9388	;External reference to ^PSDRU G( support ed by DBIA 221
	9389	"RTN","PSO RENW0",5,0 )
	9390	;External reference to PSOL^P SSLOCK sup ported by DBIA 2789
	9391	"RTN","PSO RENW0",6,0 )
	9392	;External reference to PSOUL^ PSSLOCK su pported by DBIA 2789
	9393	"RTN","PSO RENW0",7,0 )
	9394	;
	9395	"RTN","PSO RENW0",8,0 )
	9396	;PSO*237 was not ad ding to Cl ozapine Ov erride fil e, fix
	9397	"RTN","PSO RENW0",9,0 )
	9398	PROCESS ;
	9399	"RTN","PSO RENW0",10, 0)
	9400	D ^PSOREN W1
	9401	"RTN","PSO RENW0",11, 0)
	9402	D INST2^P SORENW
	9403	"RTN","PSO RENW0",12, 0)
	9404	I $D(PSOR X("BAR COD E")),PSODF N'=PSORENW ("PSODFN") D NEWPT
	9405	"RTN","PSO RENW0",13, 0)
	9406	S PSORENW ("DFLG")=0 ,PSORENW(" FILL DATE" )=PSORNW(" FILL DATE" )
	9407	"RTN","PSO RENW0",14, 0)
	9408	I $G(PSOR NW("MAIL/W INDOW"))]" " S PSOREN W("MAIL/WI NDOW")=PSO RNW("MAIL/ WINDOW")
	9409	"RTN","PSO RENW0",15, 0)
	9410	W !!,"Now Renewing Rx # "_PSO RENW("ORX #")_" Dr ug: "_$P($ G(^PSDRUG( +$G(PSOREN W("DRUG IE N")),0))," ^"),! H 2
	9411	"RTN","PSO RENW0",16, 0)
	9412	D CHECK G :PSORENW(" DFLG") PRO CESSX
	9413	"RTN","PSO RENW0",17, 0)
	9414	D FILDATE
	9415	"RTN","PSO RENW0",18, 0)
	9416	D DRUG G: PSORENW("D FLG")!PSOR X("DFLG") PROCESSX
	9417	"RTN","PSO RENW0",19, 0)
	9418	D RXN G:P SORENW("DF LG") PROCE SSX
	9419	"RTN","PSO RENW0",20, 0)
	9420	D STOP^PS ORENW1,OER R^PSORENW1 :$G(PSOFDR )
	9421	"RTN","PSO RENW0",21, 0)
	9422	DSPL K PSO EDT,PSOLM D DSPLY^PS ORENW3 G:P SORENW("DF LG") PROCE SSX
	9423	"RTN","PSO RENW0",22, 0)
	9424	S PSORENW ("QFLG")=0 D:'$G(PSO FDR) EDIT
	9425	"RTN","PSO RENW0",23, 0)
	9426	G:PSORENW ("DFLG")!$ G(PSORX("F N")) PROCE SSX
	9427	"RTN","PSO RENW0",24, 0)
	9428	G:'$G(PSO RX("FN"))& ('$G(PSORE NW("QFLG") )) DSPL
	9429	"RTN","PSO RENW0",25, 0)
	9430	D:$D(^XUS EC("PSORPH ",DUZ))!(' $P(PSOPAR, "^",2)) VE R1^PSOORNE 4(.PSORENW ) I PSOREN W("DFLG")= 1 G PROCES SX
	9431	"RTN","PSO RENW0",26, 0)
	9432	I $G(NEWD OSE),PSORE NW("ENT")> 0 K NEWDOS E G DSPL
	9433	"RTN","PSO RENW0",27, 0)
	9434	D EN^PSOR N52(.PSORE NW)
	9435	"RTN","PSO RENW0",28, 0)
	9436	D RNPSOSD ^PSOUTIL
	9437	"RTN","PSO RENW0",29, 0)
	9438	D CAN,DCO RD^PSONEW2
	9439	"RTN","PSO RENW0",30, 0)
	9440	S BBRN="" ,BBRN1=$O( ^PSRX("B", PSORENW("N RX #"),BBR N)) I $P($ G(^PSRX(BB RN1,0)),"^ ",11)["W" S BINGCRT= "Y",BINGRT E="W"
	9441	"RTN","PSO RENW0",31, 0)
	9442	;PSO*237 add to Clo zapine Ove rride file
	9443	"RTN","PSO RENW0",32, 0)
	9444	ANQ I $G(A NQDATA)]"" D NOW^%DT C G:$D(^PS (52.52,"B" ,%)) ANQ D
	9445	"RTN","PSO RENW0",33, 0)
	9446	. K DD,DO S DIC="^P S(52.52,", DIC(0)="L" ,DLAYGO=52 .52,X=%
	9447	"RTN","PSO RENW0",34, 0)
	9448	. D FILE^ DICN K DIC ,DLAYGO,DD ,DO,DA,DR
	9449	"RTN","PSO RENW0",35, 0)
	9450	. N PS52 S (PS52,DA )=+Y,DIE=" ^PS(52.52, ",DR="1/// /"_PSORENW ("IRXN")
	9451	"RTN","PSO RENW0",36, 0)
	9452	. D ^DIE K DIE,DA,D R
	9453	"RTN","PSO RENW0",37, 0)
	9454	. S $P(^P S(52.52,PS 52,0),"^", 3,6)=ANQDA TA
	9455	"RTN","PSO RENW0",38, 0)
	9456	. K ANQDA TA,X,Y,%,A NQREM
	9457	"RTN","PSO RENW0",39, 0)
	9458	;
	9459	"RTN","PSO RENW0",40, 0)
	9460	PROCESSX N PSORWRIT I PSORENW( "DFLG")!$G (PSORX("DF LG")) S PS OBBCLK=1 W :'$G(POERR ) !,$C(7), "RENEWED R X DELETED" ,! S PSOWR IT=1,PSORE RR=1 D
	9461	"RTN","PSO RENW0",41, 0)
	9462	.D:$P($G( PSOLST(+$G (ORN))),"^ ",2) PSOUL ^PSSLOCK($ P(PSOLST(O RN),"^",2) ) S POERR( "DFLG")=1 D CLEAN^PS OVER1 D
	9463	"RTN","PSO RENW0",42, 0)
	9464	..W !! K DIR S DIR( 0)="E",DIR ("?")="Pre ss Return to continu e",DIR("A" )="Press R eturn to C ontinue" D ^DIR K DI R,DTOUT,DU OUT S VALM BCK="Q"
	9465	"RTN","PSO RENW0",43, 0)
	9466	D:$G(PSOR ENW("OLD F ILL DATE") )]"" SUSDA TEK^PSOUTI L(.PSORENW )
	9467	"RTN","PSO RENW0",44, 0)
	9468	K PRC,PHI ,PSOQUIT,B BRN,BBRN1, PSORENW,PS ODRUG,PSOR X("PROVIDE R NAME"),P SORX("CLIN IC"),PSORX ("FN"),PSO RX("RXDEA" ),PSORX("D ETX") ;*54 5
	9469	"RTN","PSO RENW0",45, 0)
	9470	K PSOEDT, PSOLM S:$G (PSORENW(" FROM"))="" (PSORENW( "DFLG"),PS ORENW("QFL G"))=0
	9471	"RTN","PSO RENW0",46, 0)
	9472	D CLEAN^P SOVER1
	9473	"RTN","PSO RENW0",47, 0)
	9474	Q
	9475	"RTN","PSO RENW0",48, 0)
	9476	;
	9477	"RTN","PSO RENW0",49, 0)
	9478	CHECK ;
	9479	"RTN","PSO RENW0",50, 0)
	9480	I '$D(PSO RX("BAR CO DE")),PSOR ENW("PSODF N")'=PSODF N D G CHE CKX
	9481	"RTN","PSO RENW0",51, 0)
	9482	.W !!,?5, $C(7),"Can 't renew R x # "_$P(P SORENW("RX 0"),"^")_" , it is no t for this patient." S PSORENW ("DFLG")=1
	9483	"RTN","PSO RENW0",52, 0)
	9484	.S:$G(POE RR) VALMSG ="Can't re new Rx # " _$P(PSOREN W("RX0")," ^")_", not for this patient.", VALMBCK="R "
	9485	"RTN","PSO RENW0",53, 0)
	9486	;Invalid dosage che ck
	9487	"RTN","PSO RENW0",54, 0)
	9488	N PSOOCPR X,PSOOLPF, PSOOLPD,PS ONOSIG S P SOOCPRX=PS ORENW("OIR XN") D CDO SE
	9489	"RTN","PSO RENW0",55, 0)
	9490	I PSOOLPF !(PSONOSIG ) D G CHE CKX
	9491	"RTN","PSO RENW0",56, 0)
	9492	.S PSOREN W("DFLG")= 1
	9493	"RTN","PSO RENW0",57, 0)
	9494	.W !!,$C( 7),"Cannot renew Rx # "_$P(PSO RENW("RX0" ),"^")_$S( PSOOLPF:", invalid d osage of " _$G(PSOOLP D),1:", Mi ssing Sig" )
	9495	"RTN","PSO RENW0",58, 0)
	9496	.S:$G(POE RR) VALMSG ="Cannot r enew Rx # "_$P(PSORE NW("RX0"), "^")_$S(PS OOLPF:", i nvalid Dos age of "_$ G(PSOOLPD) ,1:", Miss ing Sig") S VALMBCK= "R"
	9497	"RTN","PSO RENW0",59, 0)
	9498	.I '$G(PS ORNSPD) W ! K DIR S DIR(0)="E" ,DIR("?")= "Press Ret urn to con tinue",DIR ("A")="Pre ss Return to Continu e" D ^DIR K DIR
	9499	"RTN","PSO RENW0",60, 0)
	9500	.I $G(PSO RNSPD) W !
	9501	"RTN","PSO RENW0",61, 0)
	9502	;
	9503	"RTN","PSO RENW0",62, 0)
	9504	N PSOS S (PSOS,PSOX ,PSOY)="" K ACOM,DIR ,DIRUT,DIR UT,DUOUT N DRG
	9505	"RTN","PSO RENW0",63, 0)
	9506	I $G(PSOS D) F S PS OS=$O(PSOS D(PSOS)) Q :PSOS="" F S PSOX= $O(PSOSD(P SOS,PSOX)) Q:PSOX']" "!(PSORENW ("DFLG")) I PSORENW ("OIRXN")= +PSOSD(PSO S,PSOX) S PSOY=PSOSD (PSOS,PSOX ) I $TR($P (PSOY,"^", 3),"B")]"" D K ACOM ,DIR,DIRUT ,DIRUT,DUO UT
	9507	"RTN","PSO RENW0",64, 0)
	9508	. S PSORE NW("DFLG") =1
	9509	"RTN","PSO RENW0",65, 0)
	9510	. W !,$C( 7),"Cannot renew Rx # ",$P(PSO RENW("RX0" ),"^")
	9511	"RTN","PSO RENW0",66, 0)
	9512	. S PSORE A=$P(PSOY, "^",3),PSO STAT=+PSOR ENW("STA")
	9513	"RTN","PSO RENW0",67, 0)
	9514	. D STATU S^PSOUTIL( PSOREA,PSO STAT) K PS OREA,PSOST AT
	9515	"RTN","PSO RENW0",68, 0)
	9516	.I $G(ACO M)]"" D
	9517	"RTN","PSO RENW0",69, 0)
	9518	..S DRG=$ P(^PSDRUG( $P(^PSRX(P SORENW("OI RXN"),0)," ^",6),0)," ^")
	9519	"RTN","PSO RENW0",70, 0)
	9520	..W ! S D IR(0)="Y", DIR("A",1) ="Do you w ant to Dis continue t his Pendin g Order",D IR("A")="f or "_DRG,D IR("B")="N o"
	9521	"RTN","PSO RENW0",71, 0)
	9522	..D ^DIR I 'Y!($D(D IRUT)) Q
	9523	"RTN","PSO RENW0",72, 0)
	9524	..D NOOR^ PSOCAN4 Q: $D(DIRUT) D DE^PSOO RFI2
	9525	"RTN","PSO RENW0",73, 0)
	9526	.Q
	9527	"RTN","PSO RENW0",74, 0)
	9528	I PSOY="" ,'$G(PSOOR RNW) D
	9529	"RTN","PSO RENW0",75, 0)
	9530	.W !,$C(7 ),"Cannot renew Rx # ",$P(PSOR ENW("RX0") ,"^")," la ter Rx exi sts." S PS ORENW("DFL G")=1
	9531	"RTN","PSO RENW0",76, 0)
	9532	.S:$G(POE RR) VALMSG ="Cannot r enew Rx # "_$P(PSORE NW("RX0"), "^")_" lat er Rx exis ts.",VALMB CK="R"
	9533	"RTN","PSO RENW0",77, 0)
	9534	K PSOX,PS OY G:PSORE NW("DFLG") CHECKX
	9535	"RTN","PSO RENW0",78, 0)
	9536	;
	9537	"RTN","PSO RENW0",79, 0)
	9538	I $A($E(P SORENW("OR X #"),$L(P SORENW("OR X #"))))'< 90 D Q
	9539	"RTN","PSO RENW0",80, 0)
	9540	. W !,$C( 7),"Cannot renew Rx # "_PSOREN W("ORX #") _", Max nu mber of re newals rea ched."
	9541	"RTN","PSO RENW0",81, 0)
	9542	.S:$G(POE RR)!('$G(S PEED)) (AC OM,VALMSG) ="Cannot r enew Rx # "_PSORENW( "ORX #")_" , Max numb er reached .",VALMBCK ="R"
	9543	"RTN","PSO RENW0",82, 0)
	9544	. S PSORE NW("DFLG") =1
	9545	"RTN","PSO RENW0",83, 0)
	9546	.I $G(OR0 )]"" D
	9547	"RTN","PSO RENW0",84, 0)
	9548	..S DRG=$ P(^PSDRUG( $P(^PSRX(P SORENW("OI RXN"),0)," ^",6),0)," ^")
	9549	"RTN","PSO RENW0",85, 0)
	9550	..W ! S D IR(0)="Y", DIR("A",1) ="Do you w ant to Dis continue t his Pendin g Order",D IR("A")="f or "_DRG,D IR("B")="N o"
	9551	"RTN","PSO RENW0",86, 0)
	9552	..D ^DIR I 'Y!($D(D IRUT)) Q
	9553	"RTN","PSO RENW0",87, 0)
	9554	..D NOOR^ PSOCAN4 Q: $D(DIRUT) D DE^PSOO RFI2
	9555	"RTN","PSO RENW0",88, 0)
	9556	.K ACOM Q
	9557	"RTN","PSO RENW0",89, 0)
	9558	D CHKDIV G:PSORENW( "DFLG") CH ECKX
	9559	"RTN","PSO RENW0",90, 0)
	9560	;
	9561	"RTN","PSO RENW0",91, 0)
	9562	D CHKPRV^ PSOUTIL
	9563	"RTN","PSO RENW0",92, 0)
	9564	CHECKX Q
	9565	"RTN","PSO RENW0",93, 0)
	9566	;
	9567	"RTN","PSO RENW0",94, 0)
	9568	CHKDIV ;
	9569	"RTN","PSO RENW0",95, 0)
	9570	G:$P(PSOR ENW("RX2") ,"^",9)=+P SOSITE CHK DIVX
	9571	"RTN","PSO RENW0",96, 0)
	9572	W !?5,$C( 7),"RX # " ,$P(PSOREN W("RX0")," ^")," is f or (",$P(^ PS(59,$P(P SORENW("RX 2"),"^",9) ,0),"^")," ) division ."
	9573	"RTN","PSO RENW0",97, 0)
	9574	I '$P($G( PSOSYS),"^ ",2) S PSO RENW("DFLG ")=1 G CHK DIVX
	9575	"RTN","PSO RENW0",98, 0)
	9576	D:$P($G(P SOSYS),"^" ,3) DIR
	9577	"RTN","PSO RENW0",99, 0)
	9578	CHKDIVX Q
	9579	"RTN","PSO RENW0",100 ,0)
	9580	;
	9581	"RTN","PSO RENW0",101 ,0)
	9582	DRUG ;
	9583	"RTN","PSO RENW0",102 ,0)
	9584	K PSOY
	9585	"RTN","PSO RENW0",103 ,0)
	9586	S PSOY=PS ORENW("DRU G IEN"),PS OY(0)=^PSD RUG(PSOY,0 ),PSORENWD =1
	9587	"RTN","PSO RENW0",104 ,0)
	9588	I '$P($G( ^PSDRUG(PS OY,2)),"^" ) D Q:$G( PSORX("DFL G"))
	9589	"RTN","PSO RENW0",105 ,0)
	9590	.I $P($G( ^PSRX(PSOR ENW("OIRXN "),"OR1")) ,"^") S PS ODRUG("OI" )=$P(^PSRX (PSORENW(" OIRXN"),"O R1"),"^"), PSODRUG("O IN")=$P(^P S(50.7,+^( "OR1"),0), "^") Q
	9591	"RTN","PSO RENW0",106 ,0)
	9592	.W !!,"Ca nnot Renew !! No Pha rmacy Orde rable Item !" S VALMS G="Cannot Renew!! N o Pharmacy Orderable Item!",PS ORX("DFLG" )=1
	9593	"RTN","PSO RENW0",107 ,0)
	9594	D SET^PSO DRG
	9595	"RTN","PSO RENW0",108 ,0)
	9596	D POST^PS ODRG D:'PS ORX("DFLG" ) DOSCK^PS ODOSUT("R" ) S:$G(PSO RX("DFLG") ) PSORENW( "DFLG")=1 ;remove or der checks for v7. d o allergy checks onl y
	9597	"RTN","PSO RENW0",109 ,0)
	9598	S PSONOOR =PSORENW(" NOO")
	9599	"RTN","PSO RENW0",110 ,0)
	9600	K PSORX(" INTERVENE" )
	9601	"RTN","PSO RENW0",111 ,0)
	9602	S:$D(PSON EW("STATUS ")) PSOREN W("STATUS" )=PSONEW(" STATUS")
	9603	"RTN","PSO RENW0",112 ,0)
	9604	K PSOY,PS ONEW("STAT US"),PSORE NWD
	9605	"RTN","PSO RENW0",113 ,0)
	9606	Q
	9607	"RTN","PSO RENW0",114 ,0)
	9608	;
	9609	"RTN","PSO RENW0",115 ,0)
	9610	RXN ;
	9611	"RTN","PSO RENW0",116 ,0)
	9612	K PSOX
	9613	"RTN","PSO RENW0",117 ,0)
	9614	S PSOX=$E (PSORENW(" ORX #"),$L (PSORENW(" ORX #")))
	9615	"RTN","PSO RENW0",118 ,0)
	9616	S PSORENW ("NRX #")= $S(PSOX?1N :PSORENW(" ORX #")_"A ",1:$E(PSO RENW("ORX #"),1,$L(P SORENW("OR X #"))-1)_ $C($A(PSOX )+1))
	9617	"RTN","PSO RENW0",119 ,0)
	9618	RETRY I $O (^PSRX("B" ,PSORENW(" NRX #"),0) ) D G:'$G (PSORENW(" DFLG")) RE TRY
	9619	"RTN","PSO RENW0",120 ,0)
	9620	.W:$A($E( PSORENW("N RX #"),$L( PSORENW("O RX #"))))' =90 !,"Rx # "_PSOREN W("NRX #") _" is alre ady on fil e."
	9621	"RTN","PSO RENW0",121 ,0)
	9622	.S:$G(PSO FDR) VALMS G="Rx # "_ PSORENW("N RX #")_" i s already on file."
	9623	"RTN","PSO RENW0",122 ,0)
	9624	.I $A($E( PSORENW("N RX #"),$L( PSORENW("O RX #"))))= 90 D
	9625	"RTN","PSO RENW0",123 ,0)
	9626	..W !,"Rx # "_PSORE NW("NRX #" )_" is alr eady on fi le. Cannot renew Rx #"_PSORENW ("ORX #")_ ".",!,"A n ew Rx must be entere d.",!
	9627	"RTN","PSO RENW0",124 ,0)
	9628	..S:$G(PS OFDR) VALM SG="Rx # " _PSORENW(" NRX #")_" is already on file. Cannot ren ew Rx #"_P SORENW("OR X #")_". A new Rx mu st be ente red."
	9629	"RTN","PSO RENW0",125 ,0)
	9630	..K DIR S DIR(0)="E ",DIR("?") ="Press Re turn to co ntinue",DI R("A")="Pr ess Return to Contin ue" D ^DIR K DIR
	9631	"RTN","PSO RENW0",126 ,0)
	9632	..S:$G(PO ERR)!($G(P SOFDR)) VA LMSG="Cann ot renew R x # "_PSOR ENW("ORX # ")_", Max number rea ched.",VAL MBCK="R" S PSORENW(" DFLG")=1
	9633	"RTN","PSO RENW0",127 ,0)
	9634	.S PSOX=$ E(PSORENW( "NRX #"),$ L(PSORENW( "NRX #")))
	9635	"RTN","PSO RENW0",128 ,0)
	9636	.S PSOREN W("NRX #") =$S(PSOX?1 N:PSORENW( "NRX #")_" A",1:$E(PS ORENW("NRX #"),1,$L( PSORENW("N RX #"))-1) _$C($A(PSO X)+1))
	9637	"RTN","PSO RENW0",129 ,0)
	9638	RXNX K PSO X
	9639	"RTN","PSO RENW0",130 ,0)
	9640	Q
	9641	"RTN","PSO RENW0",131 ,0)
	9642	;
	9643	"RTN","PSO RENW0",132 ,0)
	9644	FILDATE ;
	9645	"RTN","PSO RENW0",133 ,0)
	9646	S PSORENW ("IRXN")=P SORENW("OI RXN")
	9647	"RTN","PSO RENW0",134 ,0)
	9648	D NEXT^PS OUTIL(.PSO RENW)
	9649	"RTN","PSO RENW0",135 ,0)
	9650	I PSORENW ("FILL DAT E")<$P(PSO RENW("RX3" ),"^",2) D
	9651	"RTN","PSO RENW0",136 ,0)
	9652	.D RENFDT ^PSOUTIL(. PSORENW)
	9653	"RTN","PSO RENW0",137 ,0)
	9654	.I PSOREN W("FILL DA TE")<DT,PS ORENW("FIL L DATE")<P SORNW("FIL L DATE") S (Y,PSOREN W("FILL DA TE"))=DT X ^DD("DD") S PSORX(" FILL DATE" )=Y K Y
	9655	"RTN","PSO RENW0",138 ,0)
	9656	K PSORENW ("IRXN")
	9657	"RTN","PSO RENW0",139 ,0)
	9658	Q
	9659	"RTN","PSO RENW0",140 ,0)
	9660	;
	9661	"RTN","PSO RENW0",141 ,0)
	9662	EDIT ;
	9663	"RTN","PSO RENW0",142 ,0)
	9664	K DIR,X,Y
	9665	"RTN","PSO RENW0",143 ,0)
	9666	S DIR(0)= "Y",DIR("B ")=$S($G(D UZ("AG"))' ="I":"Y",$ G(PSEXDT): "Y",1:"N")
	9667	"RTN","PSO RENW0",144 ,0)
	9668	S DIR("A" )="Edit re newed Rx " ,DIR("?")= "Answer YE S to edit the renewe d Rx, NO n ot to."
	9669	"RTN","PSO RENW0",145 ,0)
	9670	D ^DIR K DIR S:$D(D IRUT) PSOR ENW("DFLG" )=1
	9671	"RTN","PSO RENW0",146 ,0)
	9672	G:PSORENW ("DFLG") E DITX
	9673	"RTN","PSO RENW0",147 ,0)
	9674	K PSOQUIT ,PSORX("FN ") I Y S P SORNALL=1 D INIT^PSO RENW3,EN^P SOORNE4(.P SORENW) K PSORNALL S :$G(PSOQUI T) PSORENW ("DFLG")=1 I '$G(PSO RX("FN")) D FULL^VAL M1 Q
	9675	"RTN","PSO RENW0",148 ,0)
	9676	Q:$G(PSOR X("FN"))
	9677	"RTN","PSO RENW0",149 ,0)
	9678	EDITX S PS OEDT=1,VAL MBCK="Q" K X,Y,DIRUT ,DTOUT,DUO UT S PSORE NW("QFLG") =1
	9679	"RTN","PSO RENW0",150 ,0)
	9680	Q
	9681	"RTN","PSO RENW0",151 ,0)
	9682	;
	9683	"RTN","PSO RENW0",152 ,0)
	9684	DELETE ;
	9685	"RTN","PSO RENW0",153 ,0)
	9686	K DA,DIK
	9687	"RTN","PSO RENW0",154 ,0)
	9688	S DA=$O(^ PS(52.5,"B ",PSORENW( "OIRXN"),0 )),DIK="^P S(52.5,"
	9689	"RTN","PSO RENW0",155 ,0)
	9690	D ^DIK K DIK,DIC
	9691	"RTN","PSO RENW0",156 ,0)
	9692	Q
	9693	"RTN","PSO RENW0",157 ,0)
	9694	;
	9695	"RTN","PSO RENW0",158 ,0)
	9696	CAN ;
	9697	"RTN","PSO RENW0",159 ,0)
	9698	K REA,DA, MSG
	9699	"RTN","PSO RENW0",160 ,0)
	9700	S REA="C" ,DA=PSOREN W("OIRXN")
	9701	"RTN","PSO RENW0",161 ,0)
	9702	S MSG="Re newed"_$S( $G(PSOFDR) :" from CP RS",1:"")
	9703	"RTN","PSO RENW0",162 ,0)
	9704	S PSCAN(P SORENW("OR X #"))=DA_ "^C"
	9705	"RTN","PSO RENW0",163 ,0)
	9706	D CAN^PSO CAN
	9707	"RTN","PSO RENW0",164 ,0)
	9708	K REA,DA, MSG,PSCAN
	9709	"RTN","PSO RENW0",165 ,0)
	9710	Q
	9711	"RTN","PSO RENW0",166 ,0)
	9712	;
	9713	"RTN","PSO RENW0",167 ,0)
	9714	DIR ;
	9715	"RTN","PSO RENW0",168 ,0)
	9716	S DIR(0)= "Y",DIR("A ")="CONTIN UE ",DIR(" B")="N"
	9717	"RTN","PSO RENW0",169 ,0)
	9718	S DIR("?" )="Answer YES to Con tinue, NO to bypass"
	9719	"RTN","PSO RENW0",170 ,0)
	9720	D ^DIR K DIR
	9721	"RTN","PSO RENW0",171 ,0)
	9722	S:$D(DIRU T)!('Y) PS ORENW("DFL G")=1
	9723	"RTN","PSO RENW0",172 ,0)
	9724	DIRX K DIR UT,DTOUT,D UOUT,X,Y
	9725	"RTN","PSO RENW0",173 ,0)
	9726	Q
	9727	"RTN","PSO RENW0",174 ,0)
	9728	NEWPT ;
	9729	"RTN","PSO RENW0",175 ,0)
	9730	S PSOQFLG =0 N PSODF N
	9731	"RTN","PSO RENW0",176 ,0)
	9732	S PSODFN= PSORENW("P SODFN")
	9733	"RTN","PSO RENW0",177 ,0)
	9734	D ^PSOPTP ST I PSOQF LG S PSORE NW("DFLG") =1,PSOQFLG =0 G NEWPT X
	9735	"RTN","PSO RENW0",178 ,0)
	9736	D PROFILE ^PSOREF1
	9737	"RTN","PSO RENW0",179 ,0)
	9738	NEWPTX Q
	9739	"RTN","PSO RENW0",180 ,0)
	9740	;
	9741	"RTN","PSO RENW0",181 ,0)
	9742	EN(PSORENW ) ; Entry Poi nt for Bat ch Barcode Option
	9743	"RTN","PSO RENW0",182 ,0)
	9744	S PSORENR X=$G(PSOBB C("OIRXN") )
	9745	"RTN","PSO RENW0",183 ,0)
	9746	I $G(PSOR ENRX) D PS OL^PSSLOCK (PSORENRX) I '$G(PSO MSG) D K DIR,PSOMSG W ! S DIR ("A")="Pre ss Return to continu e",DIR(0)= "E",DIR("? ")="Press Return to continue" D ^DIR K D IR W ! Q
	9747	"RTN","PSO RENW0",184 ,0)
	9748	.I $P($G( PSOMSG),"^ ",2)'="" W $C(7),!!, $P(PSOMSG, "^",2) Q
	9749	"RTN","PSO RENW0",185 ,0)
	9750	.W $C(7), !!,"Anothe r person i s editing Rx "_$P($G (^PSRX(PSO RENRX,0)), "^")
	9751	"RTN","PSO RENW0",186 ,0)
	9752	K PSOMSG, PSOBBCLK S PSOBARCD= 1 D PROCES S K PSOBAR CD
	9753	"RTN","PSO RENW0",187 ,0)
	9754	D KLIB^PS ORENW1
	9755	"RTN","PSO RENW0",188 ,0)
	9756	I $G(PSOR ENRX),$G(P SOBBCLK) D PSOUL^PSS LOCK(PSORE NRX)
	9757	"RTN","PSO RENW0",189 ,0)
	9758	K PSORENR X,PSOBBCLK
	9759	"RTN","PSO RENW0",190 ,0)
	9760	Q
	9761	"RTN","PSO RENW0",191 ,0)
	9762	CDOSE ;Val idate Dosa ge field o n Renewal, Copy, Edi t
	9763	"RTN","PSO RENW0",192 ,0)
	9764	;PSOOCPRX must be s et to inte rnal Rx nu mber
	9765	"RTN","PSO RENW0",193 ,0)
	9766	Q:'$G(PSO OCPRX)
	9767	"RTN","PSO RENW0",194 ,0)
	9768	N PSOOLP, PSOOKZ
	9769	"RTN","PSO RENW0",195 ,0)
	9770	S PSOOLP= "",(PSOOLP F,PSONOSIG )=0 F S P SOOLP=$O(^ PSRX(PSOOC PRX,6,PSOO LP)) Q:PSO OLP=""!(PS OOLPF) I $P($G(^PSR X(PSOOCPRX ,6,PSOOLP, 0)),"^")[" 0.." S PSO OLPD=$P($G (^(0)),"^" ),PSOOLPF= 1
	9771	"RTN","PSO RENW0",196 ,0)
	9772	Q:PSOOLPF
	9773	"RTN","PSO RENW0",197 ,0)
	9774	S PSOOKZ= 0
	9775	"RTN","PSO RENW0",198 ,0)
	9776	I $P($G(^ PSRX(PSOOC PRX,"SIG") ),"^",2) S PSOOLP="" F S PSOO LP=$O(^PSR X(PSOOCPRX ,"SIG1",PS OOLP)) Q:P SOOLP=""!( PSOOKZ) I $G(^PSRX( PSOOCPRX," SIG1",PSOO LP,0))'="" S PSOOKZ= 1
	9777	"RTN","PSO RENW0",199 ,0)
	9778	I '$P($G( ^PSRX(PSOO CPRX,"SIG" )),"^",2), $P($G(^("S IG")),"^") '="" S PSO OKZ=1
	9779	"RTN","PSO RENW0",200 ,0)
	9780	I 'PSOOKZ S PSONOSI G=1
	9781	"RTN","PSO RENW0",201 ,0)
	9782	Q
	9783	"RTN","PSO RENW0",202 ,0)
	9784	;
	9785	"RTN","PSO RN52C")
	9786	0^9^B69189 557
	9787	"RTN","PSO RN52C",1,0 )
	9788	PSORN52C ; BIR/SAB-fi les renewa l entries con't ;08/ 09/93
	9789	"RTN","PSO RN52C",2,0 )
	9790	;;7.0;OUT PATIENT PH ARMACY;1 ,7,11,27,4 6,75,87,10 0,111,124, 117,131,14 6,148,200, 225,251,38 7,379,391, 545;DEC 1997;Build 21
	9791	"RTN","PSO RN52C",3,0 )
	9792	;External reference s PSOL and PSOUL^PSS LOCK suppo rted by DB IA 2789
	9793	"RTN","PSO RN52C",4,0 )
	9794	S DIC="^P SRX(",DLAY GO=52,DIC( 0)="L",X=P SOX("NRX # ") K DD,DO
	9795	"RTN","PSO RN52C",5,0 )
	9796	D FILE^DI CN S PSOX( "IRXN")=+Y K DLAYGO, X,Y,DIC,DD ,DO
	9797	"RTN","PSO RN52C",6,0 )
	9798	D:+$G(DGI ) TECH^PSO DGDGP ; L +^PSRX(PSO X("IRXN")) :0
	9799	"RTN","PSO RN52C",7,0 )
	9800	D:$G(^TMP ("PSODAI", $J,0))
	9801	"RTN","PSO RN52C",8,0 )
	9802	.S $P(^PS RX(PSOX("I RXN"),3)," ^",6)=1
	9803	"RTN","PSO RN52C",9,0 )
	9804	.I $O(^TM P("PSODAI" ,$J,0)) S DAI=0 F S DAI=$O(^T MP("PSODAI ",$J,DAI)) Q:'DAI D
	9805	"RTN","PSO RN52C",10, 0)
	9806	..S:'$D(^ PSRX(PSOX( "IRXN"),"D AI",0)) ^P SRX(PSOX(" IRXN"),"DA I",0)="^52 .03^^" S ^ PSRX(PSOX( "IRXN"),"D AI",DAI,0) =^TMP("PSO DAI",$J,DA I,0)
	9807	"RTN","PSO RN52C",11, 0)
	9808	..S $P(^P SRX(PSOX(" IRXN"),"DA I",0),"^", 3)=+$P(^PS RX(PSOX("I RXN"),"DAI ",0),"^",3 )+1,$P(^(0 ),"^",4)=+ $P(^(0),"^ ",4)+1
	9809	"RTN","PSO RN52C",12, 0)
	9810	.K ^TMP(" PSODAI",$J ),DAI
	9811	"RTN","PSO RN52C",13, 0)
	9812	S PSORN52 (PSOX("IRX N"),0)=PSO X("NRX0"), PSORN52(PS OX("IRXN") ,2)=PSOX(" NRX2"),PSO RN52(PSOX( "IRXN"),3) =PSOX("NRX 3")
	9813	"RTN","PSO RN52C",14, 0)
	9814	S PSORN52 (PSOX("IRX N"),"EPH") =PSOX("EPH ")
	9815	"RTN","PSO RN52C",15, 0)
	9816	S:'$G(PSO X("ENT")) PSORN52(PS OX("IRXN") ,"SIG")=PS OX("SIG")
	9817	"RTN","PSO RN52C",16, 0)
	9818	I '$D(^XU SEC("PSORP H",DUZ)),$ $DS^PSSDSA PI&(+$G(^T MP("PSODOS F",$J,0))) S PSOX("S TA")=1
	9819	"RTN","PSO RN52C",17, 0)
	9820	S PSORN52 (PSOX("IRX N"),"STA") =PSOX("STA ")
	9821	"RTN","PSO RN52C",18, 0)
	9822	S:$G(PSOX ("TN"))]"" PSORN52(P SOX("IRXN" ),"TN")=PS OX("TN")
	9823	"RTN","PSO RN52C",19, 0)
	9824	I $G(PSOX ("METHOD O F PICK-UP" ))]"",PSOX ("FILL DAT E")'>DT S PSORN52(PS OX("IRXN") ,"MP")=PSO X("METHOD OF PICK-UP ")
	9825	"RTN","PSO RN52C",20, 0)
	9826	S PSORN52 (PSOX("IRX N"),"TYPE" )=0
	9827	"RTN","PSO RN52C",21, 0)
	9828	S PSOX1=" " F S PSO X1=$O(PSOR N52(PSOX(" IRXN"),PSO X1)) Q:PSO X1="" S ^ PSRX(PSOX( "IRXN"),PS OX1)=$G(PS ORN52(PSOX ("IRXN"),P SOX1))
	9829	"RTN","PSO RN52C",22, 0)
	9830	I $O(SIG( 0)) D G E NT
	9831	"RTN","PSO RN52C",23, 0)
	9832	.S II=0 F I=0:0 S I =$O(SIG(I) ) Q:'I S ^PSRX(PSOX ("IRXN")," SIG1",I,0) =SIG(I),II =II+1
	9833	"RTN","PSO RN52C",24, 0)
	9834	.S ^PSRX( PSOX("IRXN "),"SIG1", 0)="^52.04 A^"_II_"^" _II,$P(^PS RX(PSOX("I RXN"),"SIG "),"^",2)= 1 K I,II
	9835	"RTN","PSO RN52C",25, 0)
	9836	.S $P(^PS RX(PSOX("I RXN"),"SIG "),"^",2)= 1
	9837	"RTN","PSO RN52C",26, 0)
	9838	ENT S ^PSR X(PSOX("IR XN"),"POE" )=1,^PSRX( PSOX("IRXN "),"INS")= $G(PSOX("I NS"))
	9839	"RTN","PSO RN52C",27, 0)
	9840	I $G(OR0) ,$P(OR0,"^ ",24) S ^P SRX(PSOX(" IRXN"),"PK I")=1 D AC LOG
	9841	"RTN","PSO RN52C",28, 0)
	9842	I $P($G(P SOX("CS")) ,"^"),'+$P ($G(^PSRX( PSOX("IRXN "),"PKI")) ,"^") S $P (^PSRX(PSO X("IRXN"), "PKI"),"^" ,2)=1
	9843	"RTN","PSO RN52C",29, 0)
	9844	I $G(PSOX ("SIG",1)) ]"",'$O(PS OX("SIG",1 )) S ^PSRX (PSOX("IRX N"),"INS1" ,1,0)=PSOX ("SIG",1), ^PSRX(PSOX ("IRXN")," INS1",0)=" ^52.0115^1 ^1^"_DT_"^ ^"
	9845	"RTN","PSO RN52C",30, 0)
	9846	I $O(^PSR X(PSOX("OI RXN"),"INS 1",0)) D
	9847	"RTN","PSO RN52C",31, 0)
	9848	.F D=0:0 S D=$O(^PS RX(PSOX("O IRXN"),"IN S1",D)) Q: 'D S ^PSR X(PSOX("IR XN"),"INS1 ",D,0)=^PS RX(PSOX("O IRXN"),"IN S1",D,0)
	9849	"RTN","PSO RN52C",32, 0)
	9850	.S ^PSRX( PSOX("IRXN "),"INS1", 0)=^PSRX(P SOX("OIRXN "),"INS1", 0)
	9851	"RTN","PSO RN52C",33, 0)
	9852	TNT F I=1: 1:PSOX("EN T") S ^PSR X(PSOX("IR XN"),6,I,0 )=PSOX("DO SE",I)_"^" _$G(PSOX(" DOSE ORDER ED",I))_"^ "_$G(PSOX( "UNITS",I) )_"^"_$G(P SOX("NOUN" ,I))_"^" D
	9853	"RTN","PSO RN52C",34, 0)
	9854	.S ^PSRX( PSOX("IRXN "),6,I,0)= ^PSRX(PSOX ("IRXN"),6 ,I,0)_$G(P SOX("DURAT ION",I))_" ^"_$G(PSOX ("CONJUNCT ION",I))_" ^"_$G(PSOX ("ROUTE",I ))_"^"_$G( PSOX("SCHE DULE",I))_ "^"_$G(PSO X("VERB",I ))
	9855	"RTN","PSO RN52C",35, 0)
	9856	.I $G(PSO X("ODOSE", I))]"" S ^ PSRX(PSOX( "IRXN"),6, I,1)=PSOX( "ODOSE",I)
	9857	"RTN","PSO RN52C",36, 0)
	9858	S:$G(PSOX ("ENT")) ^ PSRX(PSOX( "IRXN"),6, 0)="^52.01 13^"_PSOX( "ENT")_"^" _PSOX("ENT ")
	9859	"RTN","PSO RN52C",37, 0)
	9860	Q
	9861	"RTN","PSO RN52C",38, 0)
	9862	ORC ;
	9863	"RTN","PSO RN52C",39, 0)
	9864	D MARK^PS OTPCAN
	9865	"RTN","PSO RN52C",40, 0)
	9866	K PSORDED T,GG,PSOHD ,PSOID,PTS T,PTDY,PTR F,RFCNT,RN ,SEG1,SIG, SIGOK,DIC
	9867	"RTN","PSO RN52C",41, 0)
	9868	K ST0,STA ,STP,STR,J J,LSI,MM,O RDG,ORIG,P HARMST,PSC AN,PSCNT,P SOI,GMRAL, DIC,DIE,HD R,IEN,NAME D KVA^VAD PT
	9869	"RTN","PSO RN52C",42, 0)
	9870	I $G(PSOF DR) D
	9871	"RTN","PSO RN52C",43, 0)
	9872	.I $G(PKI 1)=1,$G(PK IR)]"" D A CT^PSOPKIV 1(PSOX("IR XN"))
	9873	"RTN","PSO RN52C",44, 0)
	9874	.S $P(^PS RX(PSOX("I RXN"),"OR1 "),"^",2)= $P(OR0,"^" ),^PSRX("A PL",$P(OR0 ,"^"),PSOX ("IRXN"))= ""
	9875	"RTN","PSO RN52C",45, 0)
	9876	.I $P($G( ^PS(52.41, +$G(ORD)," EXT")),"^" )="" I $G( PSOSIGFL)! ($G(PSODRU G("OI"))'= $P(OR0,"^" ,8)) K:'$G (PSOPRC) P RC K PHI
	9877	"RTN","PSO RN52C",46, 0)
	9878	.I $O(PRC (0)) S T=0 F S T=$O (PRC(T)) Q :'T S ^PS RX(PSOX("I RXN"),"PRC ",T,0)=PRC (T),^PSRX( PSOX("IRXN "),"PRC",0 )="^^"_T_" ^"_T_"^"_D T_"^"
	9879	"RTN","PSO RN52C",47, 0)
	9880	.I $O(PHI (0)) S T=0 F S T=$O (PHI(T)) Q :'T S ^PS RX(PSOX("I RXN"),"PI" ,T,0)=PHI( T),^PSRX(P SOX("IRXN" ),"PI",0)= "^^"_T_"^" _T_"^"_DT_ "^"
	9881	"RTN","PSO RN52C",48, 0)
	9882	.I $G(PSO SIGFL)!($G (PSODRUG(" OI"))'=$P( OR0,"^",8) ) D S PSO I=1 Q
	9883	"RTN","PSO RN52C",49, 0)
	9884	..S POERR ("PLACER") =$P(^PS(52 .41,ORD,0) ,"^"),PSOR DEDT=ORD
	9885	"RTN","PSO RN52C",50, 0)
	9886	..K ^PS(5 2.41,"AOR" ,PSODFN,+$ P($G(^PS(5 2.41,ORD," INI")),"^" ),ORD)
	9887	"RTN","PSO RN52C",51, 0)
	9888	..S DA=OR D,DIK="^PS (52.41," D ^DIK
	9889	"RTN","PSO RN52C",52, 0)
	9890	..S $P(^P SRX(PSOX(" IRXN"),"OR 1"),"^")=$ G(PSODRUG( "OI"))
	9891	"RTN","PSO RN52C",53, 0)
	9892	.E S $P( ^PSRX(PSOX ("IRXN")," OR1"),"^") =$P(OR0,"^ ",8)
	9893	"RTN","PSO RN52C",54, 0)
	9894	.D PSOUL^ PSSLOCK(OR D_"S") S D IK="^PS(52 .41,",DA=O RD D ^DIK K DIK,DA
	9895	"RTN","PSO RN52C",55, 0)
	9896	I $G(PSOX ("OIRXN")) ,'$G(COPY) S $P(^PSR X(PSOX("IR XN"),"OR1" ),"^",3)=P SOX("OIRXN "),$P(^PSR X(PSOX("OI RXN"),"OR1 "),"^",4)= PSOX("IRXN "),^PSRX(" AQ",PSOX(" IRXN"),PSO X("OIRXN") )="" K PRC
	9897	"RTN","PSO RN52C",56, 0)
	9898	I $O(PRC( 0)) S T=0 F S T=$O( PRC(T)) Q: 'T S ^PSR X(PSOX("IR XN"),"PRC" ,T,0)=PRC( T),^PSRX(P SOX("IRXN" ),"PRC",0) ="^^"_T_"^ "_T_"^"_DT _"^"
	9899	"RTN","PSO RN52C",57, 0)
	9900	I $O(PHI( 0)) S T=0 F S T=$O( PHI(T)) Q: 'T S ^PSR X(PSOX("IR XN"),"PI", T,0)=PHI(T ),^PSRX(PS OX("IRXN") ,"PI",0)=" ^^"_T_"^"_ T_"^"_DT_" ^"
	9901	"RTN","PSO RN52C",58, 0)
	9902	S $P(^PSR X(PSOX("IR XN"),"OR1" ),"^",5)=D UZ
	9903	"RTN","PSO RN52C",59, 0)
	9904	S $P(^PSR X(PSOX("IR XN"),"OR1" ),"^",8)=$ $NOW^XLFDT D
	9905	"RTN","PSO RN52C",60, 0)
	9906	. N DA,DI K S DA=PSO X("IRXN"), DIK="^PSRX (",DIK(1)= 38.3 D EN1 ^DIK K DIK ,DA
	9907	"RTN","PSO RN52C",61, 0)
	9908	S PHARMST ="",$P(^PS RX(PSOX("I RXN"),"OR1 "),"^")=$G (PSODRUG(" OI"))
	9909	"RTN","PSO RN52C",62, 0)
	9910	S RXN=PSO X("IRXN") D SAVE
	9911	"RTN","PSO RN52C",63, 0)
	9912	S STAT=$S ($G(OR0)]" "&('$G(PSO I)):"SC",$ G(PSOI):"R O",1:"SN") S PHARMST =$S('$G(PS ORX("VERIF Y")):"CM", 1:"IP") ;D EN^PSOHLS N1(RXN,STA T,PHARMST, "",PSONOOR )
	9913	"RTN","PSO RN52C",64, 0)
	9914	S ^TMP("P SORXN",$J, RXN)=STAT_ "^"_PHARMS T_"^"_PSON OOR D PSOL ^PSSLOCK(R XN)
	9915	"RTN","PSO RN52C",65, 0)
	9916	;*545 - s tore the s elected DE A#
	9917	"RTN","PSO RN52C",66, 0)
	9918	I $G(PSOR X("RXDEA") )]"" S ^TM P("PSORXN" ,$J,RXN,"D EA")=PSORX ("RXDEA")
	9919	"RTN","PSO RN52C",67, 0)
	9920	D RESTORE K PSORDED T,PHI,PRC, STAT,COMM, PSOI,OR2,O R1,PHARMST ,RXN,DRG,S TA,ACT,OCX R,OCXD1,OC XDT,OCXI
	9921	"RTN","PSO RN52C",68, 0)
	9922	Q
	9923	"RTN","PSO RN52C",69, 0)
	9924	BBRX ;buil d bingo bo ard Rx arr ay; called by PSON52 ,PSOR52,PS ORN52
	9925	"RTN","PSO RN52C",70, 0)
	9926	I $G(BBRX (1))']"" S BBRX(1)=P SOX("IRXN" )_"," Q
	9927	"RTN","PSO RN52C",71, 0)
	9928	F PSOX1=0 :0 S PSOX1 =$O(BBRX(P SOX1)) Q:' PSOX1 S P SOX2=PSOX1
	9929	"RTN","PSO RN52C",72, 0)
	9930	I $L(BBRX (PSOX2))+$ L(PSOX("IR XN"))<220 S BBRX(PSO X2)=BBRX(P SOX2)_PSOX ("IRXN")_" ,"
	9931	"RTN","PSO RN52C",73, 0)
	9932	E S BBRX (PSOX2+1)= PSOX("IRXN ")_","
	9933	"RTN","PSO RN52C",74, 0)
	9934	Q
	9935	"RTN","PSO RN52C",75, 0)
	9936	SAVE ;this module wi ll be used to save P SO arrays
	9937	"RTN","PSO RN52C",76, 0)
	9938	K ^TMP("P SOLST",$J) F I=0:0 S I=$O(PSOL ST(I)) Q:' I S ^TMP( "PSOLST",$ J,I,0)=PSO LST(I)
	9939	"RTN","PSO RN52C",77, 0)
	9940	K ^TMP("P SOSD",$J) S (STA,DRG )="" F S STA=$O(PSO SD(STA)) Q :STA="" F S DRG=$O (PSOSD(STA ,DRG)) Q:D RG="" S ^ TMP("PSOSD ",$J,STA,D RG)=PSOSD( STA,DRG)
	9941	"RTN","PSO RN52C",78, 0)
	9942	I $G(PSOS D) S ^TMP( "PSOSD",$J ,0)=PSOSD
	9943	"RTN","PSO RN52C",79, 0)
	9944	I $G(PSOD RUG("NAME" ))]"" K ^T MP("PSODRU G",$J) S S TA="" F S STA=$O(P SODRUG(STA )) Q:STA=" " D
	9945	"RTN","PSO RN52C",80, 0)
	9946	.Q:STA="B AD"
	9947	"RTN","PSO RN52C",81, 0)
	9948	.S ^TMP(" PSODRUG",$ J,STA)=PSO DRUG(STA)
	9949	"RTN","PSO RN52C",82, 0)
	9950	I $G(PSOX ("# OF REF ILLS"))]"" K ^TMP("P SOX",$J),^ TMP("PSORE NW",$J),^T MP("PSONEW ",$J),^TMP ("PSORXED" ,$J) D
	9951	"RTN","PSO RN52C",83, 0)
	9952	.S STA="" F S STA= $O(PSOX(ST A)) Q:STA= "" S ^TMP ("PSOX",$J ,STA)=$G(P SOX(STA)) D
	9953	"RTN","PSO RN52C",84, 0)
	9954	..I STA=" OLD LAST R X#",$O(PSO X(STA,"")) K ^TMP("P SOX",$J,ST A) S ^TMP( "PSOX",$J, STA,$O(PSO X(STA,"")) )=PSOX(STA ,$O(PSOX(S TA,""))) D Q
	9955	"RTN","PSO RN52C",85, 0)
	9956	...I $O(P SONEW(STA, "")) S ^TM P("PSONEW" ,$J,STA,$O (PSONEW(ST A,"")))=PS ONEW(STA,$ O(PSONEW(S TA,"")))
	9957	"RTN","PSO RN52C",86, 0)
	9958	...I $O(P SORENW(STA ,"")) S ^T MP("PSOREN W",$J,STA, $O(PSORENW (STA,""))) =PSORENW(S TA,$O(PSOR ENW(STA,"" )))
	9959	"RTN","PSO RN52C",87, 0)
	9960	...I $O(P SORXED(STA ,"")) S ^T MP("PSORXE D",$J,STA, $O(PSORXED (STA,""))) =PSORXED(S TA,$O(PSOR XED(STA,"" )))
	9961	"RTN","PSO RN52C",88, 0)
	9962	..F ACT=" PSORENW"," PSONEW","P SORXED" I $G(@(ACT_" ("""_STA_" "")"))]"" S ^TMP(ACT ,$J,STA)=@ (ACT_"(""" _STA_""")" )
	9963	"RTN","PSO RN52C",89, 0)
	9964	K PSOPTPS T,PSOSD,PS ONEW,PSOLS T,PSORENW, PSORXED,PS ODRUG
	9965	"RTN","PSO RN52C",90, 0)
	9966	Q
	9967	"RTN","PSO RN52C",91, 0)
	9968	RESTORE ;t his module restore s aved array s
	9969	"RTN","PSO RN52C",92, 0)
	9970	S STA=0 F S STA=$O (^TMP("PSO LST",$J,ST A)) Q:'STA S PSOLST (STA)=^TMP ("PSOLST", $J,STA,0)
	9971	"RTN","PSO RN52C",93, 0)
	9972	I $G(^TMP ("PSOSD",$ J,0)) S PS OSD=$G(^TM P("PSOSD", $J,0))
	9973	"RTN","PSO RN52C",94, 0)
	9974	S (STA,DR G)="" F S STA=$O(^T MP("PSOSD" ,$J,STA)) Q:STA="" F S DRG=$ O(^TMP("PS OSD",$J,ST A,DRG)) Q: DRG="" S PSOSD(STA, DRG)=^TMP( "PSOSD",$J ,STA,DRG)
	9975	"RTN","PSO RN52C",95, 0)
	9976	S STA="" F S STA=$ O(^TMP("PS ODRUG",$J, STA)) Q:ST A="" S PS ODRUG(STA) =^TMP("PSO DRUG",$J,S TA)
	9977	"RTN","PSO RN52C",96, 0)
	9978	S STA="" F ACT="PSO X","PSOREN W","PSONEW ","PSORXED " D:$O(^TM P(ACT,$J,S TA))]""
	9979	"RTN","PSO RN52C",97, 0)
	9980	.F S STA =$O(^TMP(A CT,$J,STA) ) Q:STA="" I STA'=" OLD LAST R X#" S @(AC T_"("""_ST A_""")")=^ TMP(ACT,$J ,STA)
	9981	"RTN","PSO RN52C",98, 0)
	9982	I $O(^TMP ("PSOX",$J ,"OLD LAST RX#","")) S PSOX("O LD LAST RX #",$O(^TMP ("PSOX",$J ,"OLD LAST RX#","")) )=^TMP("PS OX",$J,"OL D LAST RX# ",$O(^TMP( "PSOX",$J, "OLD LAST RX#","")))
	9983	"RTN","PSO RN52C",99, 0)
	9984	I $O(^TMP ("PSONEW", $J,"OLD LA ST RX#","" )) S PSONE W("OLD LAS T RX#",$O( ^TMP("PSON EW",$J,"OL D LAST RX# ","")))=^T MP("PSONEW ",$J,"OLD LAST RX#", $O(^TMP("P SONEW",$J, "OLD LAST RX#","")))
	9985	"RTN","PSO RN52C",100 ,0)
	9986	I $O(^TMP ("PSORENW" ,$J,"OLD L AST RX#"," ")) S PSOR ENW("OLD L AST RX#",$ O(^TMP("PS ORENW",$J, "OLD LAST RX#",""))) =^TMP("PSO RENW",$J," OLD LAST R X#",$O(^TM P("PSORENW ",$J,"OLD LAST RX#", "")))
	9987	"RTN","PSO RN52C",101 ,0)
	9988	I $O(^TMP ("PSORXED" ,$J,"OLD L AST RX#"," ")) S PSOR XED("OLD L AST RX#",$ O(^TMP("PS ORXED",$J, "OLD LAST RX#",""))) =^TMP("PSO RXED",$J," OLD LAST R X#",$O(^TM P("PSORXED ",$J,"OLD LAST RX#", "")))
	9989	"RTN","PSO RN52C",102 ,0)
	9990	K ^TMP("P SOSD",$J), ^TMP("PSOD RUG",$J),^ TMP("PSOX" ,$J),^TMP( "PSORENW", $J),^TMP(" PSONEW",$J ),^TMP("PS ORXED",$J) ,^TMP("PSO LST",$J)
	9991	"RTN","PSO RN52C",103 ,0)
	9992	Q
	9993	"RTN","PSO RN52C",104 ,0)
	9994	;
	9995	"RTN","PSO RN52C",105 ,0)
	9996	ACLOG ;act ivity log (digitally signed CS orders)
	9997	"RTN","PSO RN52C",106 ,0)
	9998	N DTTM,CN T,OCNT,XX
	9999	"RTN","PSO RN52C",107 ,0)
	10000	D NOW^%DT C S DTTM=%
	10001	"RTN","PSO RN52C",108 ,0)
	10002	S CNT=0 F XX=0:0 S XX=$O(^PSR X(PSOX("IR XN"),"A",X X)) Q:'XX S CNT=XX
	10003	"RTN","PSO RN52C",109 ,0)
	10004	S OCNT=CN T
	10005	"RTN","PSO RN52C",110 ,0)
	10006	I $G(PSOC SP("NAME") )'=PSODRUG ("NAME") S CNT=CNT+1 ,^PSRX(PSO X("IRXN"), "A",CNT,0) =DTTM_"^K^ "_DUZ_"^0^ NAME: "_PS OCSP("NAME ")
	10007	"RTN","PSO RN52C",111 ,0)
	10008	S XX=0 F S XX=$O(P SOCSP("DOS E",XX)) Q: 'XX I PSO CSP("DOSE" ,XX)'=$G(P SORENW("DO SE",XX)) D
	10009	"RTN","PSO RN52C",112 ,0)
	10010	.S CNT=CN T+1,^PSRX( PSOX("IRXN "),"A",CNT ,0)=DTTM_" ^K^"_DUZ_" ^0^DOSAGE: "_PSOCSP( "DOSE",XX)
	10011	"RTN","PSO RN52C",113 ,0)
	10012	S XX=0 F S XX=$O(P SOCSP("DOS E ORDERED" ,XX)) Q:'X X I PSOCS P("DOSE OR DERED",XX) '=$G(PSORE NW("DOSE O RDERED",XX )) D
	10013	"RTN","PSO RN52C",114 ,0)
	10014	.S CNT=CN T+1,^PSRX( PSOX("IRXN "),"A",CNT ,0)=DTTM_" ^K^"_DUZ_" ^0^DISPENS E UNITS: " _PSOCSP("D OSE ORDERE D",XX)
	10015	"RTN","PSO RN52C",115 ,0)
	10016	I $G(PSOC SP("ISSUE DATE"))'=P SORENW("IS SUE DATE") S CNT=CNT +1,^PSRX(P SOX("IRXN" ),"A",CNT, 0)=DTTM_"^ K^"_DUZ_"^ 0^ISSUE DA TE: "_$$FM TE^XLFDT(P SOCSP("ISS UE DATE"))
	10017	"RTN","PSO RN52C",116 ,0)
	10018	I $G(PSOC SP("DAYS S UPPLY"))'= PSORENW("D AYS SUPPLY ") S CNT=C NT+1,^PSRX (PSOX("IRX N"),"A",CN T,0)=DTTM_ "^K^"_DUZ_ "^0^DAYS S UPPLY: "_P SOCSP("DAY S SUPPLY")
	10019	"RTN","PSO RN52C",117 ,0)
	10020	I $G(PSOC SP("QTY")) '=PSORENW( "QTY") S C NT=CNT+1,^ PSRX(PSOX( "IRXN"),"A ",CNT,0)=D TTM_"^K^"_ DUZ_"^0^QT Y: "_PSOCS P("QTY")
	10021	"RTN","PSO RN52C",118 ,0)
	10022	I $G(PSOC SP("# OF R EFILLS"))' =PSORENW(" # OF REFIL LS") S CNT =CNT+1,^PS RX(PSOX("I RXN"),"A", CNT,0)=DTT M_"^K^"_DU Z_"^0^# OF REFILLS: "_PSOCSP(" # OF REFIL LS")
	10023	"RTN","PSO RN52C",119 ,0)
	10024	I '$$SUBS CRIB^ORDEA ($P(OR0,"^ "),PSOX("I RXN")) S C NT=CNT+1,^ PSRX(PSOX( "IRXN"),"A ",CNT,0)=D TTM_"^K^"_ DUZ_"^0^OR DER DEA AR CHIVE INFO file entr y failure"
	10025	"RTN","PSO RN52C",120 ,0)
	10026	I OCNT'=C NT S ^PSRX (PSOX("IRX N"),"A",0) ="^52.3DA^ "_CNT_"^"_ CNT
	10027	"RTN","PSO RN52C",121 ,0)
	10028	Q
	10029	"RTN","PSO RN52C",122 ,0)
	10030	;
	10031	"RTN","PSO UTIL")
	10032	0^26^B1465 65832
	10033	"RTN","PSO UTIL",1,0)
	10034	PSOUTIL ;I HS/DSD/JCM - outpati ent pharma cy utility routine ; 12/28/15 4 :01pm
	10035	"RTN","PSO UTIL",2,0)
	10036	;;7.0;OUT PATIENT PH ARMACY;6 4,456,444, 469,504,54 5;DEC 19 97;Build 2 1
	10037	"RTN","PSO UTIL",3,0)
	10038	;External reference $$MXDAYSU P^PSSUTIL1 supported by DBIA 6 229
	10039	"RTN","PSO UTIL",4,0)
	10040	;External reference to ^ORDEA is suppor ted by DBI A 5709
	10041	"RTN","PSO UTIL",5,0)
	10042	;
	10043	"RTN","PSO UTIL",6,0)
	10044	Q
	10045	"RTN","PSO UTIL",7,0)
	10046	;
	10047	"RTN","PSO UTIL",8,0)
	10048	NPSOSD(PSO RX) ; Entr y point to add newly added rx to patient s PSOSD ar ray
	10049	"RTN","PSO UTIL",9,0)
	10050	S STA="AC TIVE^NON-V ERIFIED^R^ HOLD^NON-V ERIFIED^AC TIVE^^^^^^ ACTIVE^DIS CONTINUE^^ DISCONTINU E^DISCONTI NUE^HOLD"
	10051	"RTN","PSO UTIL",10,0 )
	10052	S STAT=$P (STA,"^",$ P(^PSRX(PS ORX("IRXN" ),"STA")," ^")+1)
	10053	"RTN","PSO UTIL",11,0 )
	10054	I $D(PSOS D(STAT,PSO DRUG("NAME "))),$P(PS OSD(STAT,P SODRUG("NA ME")),"^", 2)<10 D
	10055	"RTN","PSO UTIL",12,0 )
	10056	. S PSOSD (STAT,PSOD RUG("NAME" )_"^"_PSOR X("IRXN")) =PSORX("IR XN")_"^"_$ P($G(^PSRX (PSORX("IR XN"),"STA" )),"^")_"^ ^^"_PSODRU G("VA CLAS S")_"^"_$P (^PSRX(PSO RX("IRXN") ,0),"^",9) _"^"_PSODR UG("NDF")_ "^"_$P(^PS RX(PSORX(" IRXN"),0), "^",8)_"^1 "
	10057	"RTN","PSO UTIL",13,0 )
	10058	E S PSOS D(STAT,PSO DRUG("NAME "))=PSORX( "IRXN")_"^ "_$P($G(^P SRX(PSORX( "IRXN"),"S TA")),"^") _"^^^"_PSO DRUG("VA C LASS")_"^" _$P(^PSRX( PSORX("IRX N"),0),"^" ,9)_"^"_PS ODRUG("NDF ")_"^"_$P( ^PSRX(PSOR X("IRXN"), 0),"^",8)_ "^1"
	10059	"RTN","PSO UTIL",14,0 )
	10060	S PSOSD=$ S($G(PSOSD )]"":PSOSD +1,1:1),^T MP("PS",$J ,STAT,PSOD RUG("NAME" ))=1
	10061	"RTN","PSO UTIL",15,0 )
	10062	Q
	10063	"RTN","PSO UTIL",16,0 )
	10064	;
	10065	"RTN","PSO UTIL",17,0 )
	10066	RNPSOSD ;u pdate PSOS D array fo r renewals
	10067	"RTN","PSO UTIL",18,0 )
	10068	S STA="AC TIVE^NON-V ERIFIED^R^ HOLD^NON-V ERIFIED^AC TIVE^^^^^^ ACTIVE^DIS CONTINUE^^ DISCONTINU E^DISCONTI NUE^HOLD"
	10069	"RTN","PSO UTIL",19,0 )
	10070	S STAT=$P (STA,"^",$ P(^PSRX(PS ORENW("OIR XN"),"STA" ),"^")+1)
	10071	"RTN","PSO UTIL",20,0 )
	10072	I $D(PSOS D(STAT,PSO DRUG("NAME ")_"^"_PSO RENW("OIRX N"))) D
	10073	"RTN","PSO UTIL",21,0 )
	10074	. S PSOSD (STAT,PSOD RUG("NAME" )_"^"_PSOR ENW("IRXN" ))=PSOSD(S TAT,PSODRU G("NAME")_ "^"_PSOREN W("OIRXN") ),$P(PSOSD (STAT,PSOD RUG("NAME" )_"^"_PSOR ENW("IRXN" )),"^",2)= $P($G(^PSR X(PSORENW( "IRXN"),"S TA")),"^")
	10075	"RTN","PSO UTIL",22,0 )
	10076	. S $P(PS OSD(STAT,P SODRUG("NA ME")_"^"_P SORENW("IR XN")),"^", 6)=$P(^PSR X(PSORENW( "IRXN"),0) ,"^",9)
	10077	"RTN","PSO UTIL",23,0 )
	10078	. K PSOSD (STAT,PSOD RUG("NAME" )_"^"_PSOR ENW("OIRXN ")) Q
	10079	"RTN","PSO UTIL",24,0 )
	10080	E D
	10081	"RTN","PSO UTIL",25,0 )
	10082	.S $P(PSO SD(STAT,PS ODRUG("NAM E")),"^")= PSORENW("I RXN"),$P(P SOSD(STAT, PSODRUG("N AME")),"^" ,2)=$P($G( ^PSRX(PSOR ENW("IRXN" ),"STA")), "^")
	10083	"RTN","PSO UTIL",26,0 )
	10084	.S $P(PSO SD(STAT,PS ODRUG("NAM E")),"^",6 )=$P(^PSRX (PSORENW(" IRXN"),0), "^",9)
	10085	"RTN","PSO UTIL",27,0 )
	10086	.S ^TMP(" PS",$J,STA T,PSODRUG( "NAME"))=1
	10087	"RTN","PSO UTIL",28,0 )
	10088	Q
	10089	"RTN","PSO UTIL",29,0 )
	10090	;
	10091	"RTN","PSO UTIL",30,0 )
	10092	PROV(PSORE NW) ;calle d from pso ornew
	10093	"RTN","PSO UTIL",31,0 )
	10094	CHKPRV ;ch eck inacti ve provide rs and cos inging pro viders cal led from P SORENW (re new rx)
	10095	"RTN","PSO UTIL",32,0 )
	10096	N OK
	10097	"RTN","PSO UTIL",33,0 )
	10098	I '$D(^VA (200,PSORE NW("PROVID ER"),0)) D I 'OK G: PSORENW("D FLG") CHKP RVX
	10099	"RTN","PSO UTIL",34,0 )
	10100	.W !,$C(7 ),"Provide r not in N ew Person File .. Yo u must sel ect a new provider"
	10101	"RTN","PSO UTIL",35,0 )
	10102	.S PSODIR ("FIELD")= 0 K PSOREN W("PROVIDE R") D PROV ^PSODIR(.P SORENW)
	10103	"RTN","PSO UTIL",36,0 )
	10104	.S:$G(PSO RENW("PROV IDER"))']" " PSORENW( "DFLG")=1
	10105	"RTN","PSO UTIL",37,0 )
	10106	;
	10107	"RTN","PSO UTIL",38,0 )
	10108	I '$G(^VA (200,PSORE NW("PROVID ER"),"PS") ) D G:PS ORENW("DFL G") CHKPRV X
	10109	"RTN","PSO UTIL",39,0 )
	10110	.I $$ISSP LY(),$D(^X USEC("ORSU PPLY",PSOR ENW("PROVI DER"))) S OK=1 Q
	10111	"RTN","PSO UTIL",40,0 )
	10112	.S OK=0 W !,$C(7),$ P(^VA(200, PSORENW("P ROVIDER"), 0),"^")_" is not a V alid provi der .. You must sele ct a new p rovider"
	10113	"RTN","PSO UTIL",41,0 )
	10114	.S PSODIR ("FIELD")= 0 K PSOREN W("PROVIDE R") D PROV ^PSODIR(.P SORENW)
	10115	"RTN","PSO UTIL",42,0 )
	10116	.S:$G(PSO RENW("PROV IDER"))']" " PSORENW( "DFLG")=1
	10117	"RTN","PSO UTIL",43,0 )
	10118	;
	10119	"RTN","PSO UTIL",44,0 )
	10120	K PSOX S PSOX=$P($G (^VA(200,P SORENW("PR OVIDER")," PS")),"^", 4)
	10121	"RTN","PSO UTIL",45,0 )
	10122	I PSOX,PS OX<DT D G:PSORENW( "DFLG") CH KPRVX
	10123	"RTN","PSO UTIL",46,0 )
	10124	.W !,$C(7 ),$P(^VA(2 00,PSORENW ("PROVIDER "),0),"^") _" is inac tive as a provider . . You must select a new provid er"
	10125	"RTN","PSO UTIL",47,0 )
	10126	.S PSODIR ("FIELD")= 0 K PSOREN W("PROVIDE R") D PROV ^PSODIR(.P SORENW)
	10127	"RTN","PSO UTIL",48,0 )
	10128	.I $G(PSO RENW("PROV IDER"))']" " S PSOREN W("DFLG")= 1
	10129	"RTN","PSO UTIL",49,0 )
	10130	;
	10131	"RTN","PSO UTIL",50,0 )
	10132	I '$D(PSO RENW("COSI GNING PROV IDER")),$D (PSORENW(" COSIGNER") ) K PSOX S PSOX=$P(^ VA(200,PSO RENW("COSI GNER"),"PS "),"^",4) I PSOX,PSO X<DT D
	10133	"RTN","PSO UTIL",51,0 )
	10134	.W !,$C(7 ),"Inactiv e Cosignin g Provider .. You mu st select a new cosi gner"
	10135	"RTN","PSO UTIL",52,0 )
	10136	.S PSODIR ("FIELD")= 0,PSODIR(" PROVIDER") =$S($D(PSO RENW("PROV IDER")):PS ORENW("PRO VIDER"),1: PSORENW("P ROVIDER"))
	10137	"RTN","PSO UTIL",53,0 )
	10138	.D COSIGN ^PSODIR I '$D(PSODIR ("COSIGNIN G PROVIDER ")) S PSOR ENW("DFLG" )=1
	10139	"RTN","PSO UTIL",54,0 )
	10140	.S PSOREN W("COSIGNI NG PROVIDE R")=PSODIR ("COSIGNIN G PROVIDER ")
	10141	"RTN","PSO UTIL",55,0 )
	10142	;
	10143	"RTN","PSO UTIL",56,0 )
	10144	CHKPRVX K PSODIR,PSO X
	10145	"RTN","PSO UTIL",57,0 )
	10146	Q
	10147	"RTN","PSO UTIL",58,0 )
	10148	;
	10149	"RTN","PSO UTIL",59,0 )
	10150	NEXT(PSOX) ;
	10151	"RTN","PSO UTIL",60,0 )
	10152	S PSOX("R X0")=^PSRX (PSOX("IRX N"),0)
	10153	"RTN","PSO UTIL",61,0 )
	10154	S PSOX("R X2")=^PSRX (PSOX("IRX N"),2)
	10155	"RTN","PSO UTIL",62,0 )
	10156	S PSOX("R X3")=^PSRX (PSOX("IRX N"),3)
	10157	"RTN","PSO UTIL",63,0 )
	10158	S PSOX1=$ P(PSOX("RX 2"),"^",2)
	10159	"RTN","PSO UTIL",64,0 )
	10160	I '$O(^PS RX(PSOX("I RXN"),1,0) ) D G NEX TX
	10161	"RTN","PSO UTIL",65,0 )
	10162	. S $P(PS OX("RX3"), "^")=PSOX1 ,X1=PSOX1
	10163	"RTN","PSO UTIL",66,0 )
	10164	. S X2=$P (PSOX("RX0 "),"^",8)- 10\1
	10165	"RTN","PSO UTIL",67,0 )
	10166	. D C^%DT C
	10167	"RTN","PSO UTIL",68,0 )
	10168	. S:'$P(P SOX("RX3") ,"^",8) $P (PSOX("RX3 "),"^",2)= X
	10169	"RTN","PSO UTIL",69,0 )
	10170	. K X Q
	10171	"RTN","PSO UTIL",70,0 )
	10172	;
	10173	"RTN","PSO UTIL",71,0 )
	10174	S PSOY2=0
	10175	"RTN","PSO UTIL",72,0 )
	10176	F PSOY=0: 0 S PSOY=$ O(^PSRX(PS OX("IRXN") ,1,PSOY)) Q:'PSOY S PSOY1=PSO Y,PSOY2=PS OY2+1
	10177	"RTN","PSO UTIL",73,0 )
	10178	S PSOY=^P SRX(PSOX(" IRXN"),1,P SOY1,0)
	10179	"RTN","PSO UTIL",74,0 )
	10180	S PSOX2=$ P(PSOY,"^" )
	10181	"RTN","PSO UTIL",75,0 )
	10182	S $P(PSOX ("RX3"),"^ ")=PSOX2,X 1=PSOX2
	10183	"RTN","PSO UTIL",76,0 )
	10184	S X2=$P(P SOX("RX0") ,"^",8)-10 \1
	10185	"RTN","PSO UTIL",77,0 )
	10186	D C^%DTC S PSOY3=X
	10187	"RTN","PSO UTIL",78,0 )
	10188	S X1=PSOX 1,X2=(PSOY 2+1)*$P(PS OX("RX0"), "^",8)-10\ 1
	10189	"RTN","PSO UTIL",79,0 )
	10190	D C^%DTC S PSOY4=X
	10191	"RTN","PSO UTIL",80,0 )
	10192	S $P(PSOX ("RX3"),"^ ",2)=$S(PS OY3<PSOY4: PSOY4,1:PS OY3)
	10193	"RTN","PSO UTIL",81,0 )
	10194	NEXTX ;
	10195	"RTN","PSO UTIL",82,0 )
	10196	K X,PSOX1 ,PSOX2,PSO Y,PSOY1,PS OY2,PSOY3, PSOY4
	10197	"RTN","PSO UTIL",83,0 )
	10198	Q
	10199	"RTN","PSO UTIL",84,0 )
	10200	;
	10201	"RTN","PSO UTIL",85,0 )
	10202	SUSDATE(PS OX) ;
	10203	"RTN","PSO UTIL",86,0 )
	10204	S PSOX("O LD FILL DA TE")=PSOX( "FILL DATE ")
	10205	"RTN","PSO UTIL",87,0 )
	10206	S PSORX(" OLD FILL D ATE")=PSOR X("FILL DA TE")
	10207	"RTN","PSO UTIL",88,0 )
	10208	S PSOX("F ILL DATE") =$P(PSOX(" RX3"),"^", 2)
	10209	"RTN","PSO UTIL",89,0 )
	10210	I $O(^PS( 52.5,"B",P SOX("IRXN" ),0)),'$G( ^PS(52.5,+ $O(^PS(52. 5,"B",PSOX ("IRXN"),0 )),"P")) S PSOX("FIL L DATE")=$ P(PSOX("RX 3"),"^")
	10211	"RTN","PSO UTIL",90,0 )
	10212	S Y=PSOX( "FILL DATE ")
	10213	"RTN","PSO UTIL",91,0 )
	10214	X ^DD("DD ") S PSORX ("FILL DAT E")=Y K Y
	10215	"RTN","PSO UTIL",92,0 )
	10216	Q
	10217	"RTN","PSO UTIL",93,0 )
	10218	;
	10219	"RTN","PSO UTIL",94,0 )
	10220	SUSDATEK(P SOX) ;
	10221	"RTN","PSO UTIL",95,0 )
	10222	S PSOX("F ILL DATE") =PSOX("OLD FILL DATE ")
	10223	"RTN","PSO UTIL",96,0 )
	10224	I $G(PSOR X("OLD FIL L DATE"))= "",$G(PSOR ENW("OLD F ILL DATE") ) S Y=PSOR ENW("OLD F ILL DATE") D DD^%DT S PSORX("O LD FILL DA TE")=Y K Y
	10225	"RTN","PSO UTIL",97,0 )
	10226	S PSORX(" FILL DATE" )=PSORX("O LD FILL DA TE")
	10227	"RTN","PSO UTIL",98,0 )
	10228	K PSOX("O LD FILL DA TE"),PSORX ("OLD FILL DATE")
	10229	"RTN","PSO UTIL",99,0 )
	10230	Q
	10231	"RTN","PSO UTIL",100, 0)
	10232	;
	10233	"RTN","PSO UTIL",101, 0)
	10234	STATUS(PSO REA,PSOSTA T) ;
	10235	"RTN","PSO UTIL",102, 0)
	10236	S DSMSG=" Cannot "_$ S($G(PSOOP T)=3:"rene w",1:"refi ll")_" Rx. " S:$G(OR 0) ACOM=DS MSG
	10237	"RTN","PSO UTIL",103, 0)
	10238	I PSOREA[ "A" W:$G(S PEED) ", I nactive Dr ug.",! D
	10239	"RTN","PSO UTIL",104, 0)
	10240	.S:$G(POE RR)&('$G(S PEED)) VAL MSG=DSMSG_ "Inactive Drug.",VAL MBCK="R" W :'$G(POERR ) !," Inac tive Drug"
	10241	"RTN","PSO UTIL",105, 0)
	10242	.S:$G(OR0 ) ACOM=ACO M_" Inacti ve Drug."
	10243	"RTN","PSO UTIL",106, 0)
	10244	I PSOREA[ "M" W:$G(S PEED) ", D rug no lon ger used b y Outpatie nt.",! D
	10245	"RTN","PSO UTIL",107, 0)
	10246	.S:$G(POE RR)&('$G(S PEED)) VAL MSG=DSMSG_ "Drug no l onger used by Outpat ient.",VAL MBCK="R" W :'$G(POERR ) !," Drug no longer used by O utpatient. "
	10247	"RTN","PSO UTIL",108, 0)
	10248	.S:$G(OR0 ) ACOM=ACO M_" Drug n o longer u sed by Out patient."
	10249	"RTN","PSO UTIL",109, 0)
	10250	;
	10251	"RTN","PSO UTIL",110, 0)
	10252	I PSOREA[ "B" W:$G(S PEED) ", N arcotic Dr ug." D
	10253	"RTN","PSO UTIL",111, 0)
	10254	.W:'$G(PO ERR) !,"Na rcotic Dru g" S:$G(PO ERR)&('$G( SPEED)) VA LMSG=DSMSG _"Narcotic Drug.",VA LMBCK="R"
	10255	"RTN","PSO UTIL",112, 0)
	10256	.S:$G(OR0 ) ACOM=ACO M_" Narcot ic Drug."
	10257	"RTN","PSO UTIL",113, 0)
	10258	;
	10259	"RTN","PSO UTIL",114, 0)
	10260	I PSOREA[ "C" W:$G(S PEED) ", N on-Renewab le Drug." D
	10261	"RTN","PSO UTIL",115, 0)
	10262	.W:'$G(PO ERR) !,"No n-Renewabl e Drug" S: $G(POERR)& ('$G(SPEED )) VALMSG= DSMSG_"Non -Renewable Drug.",VA LMBCK="R"
	10263	"RTN","PSO UTIL",116, 0)
	10264	.S:$G(OR0 ) ACOM=ACO M_" Non-Re newable Dr ug."
	10265	"RTN","PSO UTIL",117, 0)
	10266	;
	10267	"RTN","PSO UTIL",118, 0)
	10268	I PSOREA[ "D" W:$G(S PEED) ", N on-Renewab le Patient Status." D
	10269	"RTN","PSO UTIL",119, 0)
	10270	.W:'$G(PO ERR) !,"No n-Renewabl e Patient Status" S: $G(POERR)& ('$G(SPEED )) VALMSG= DSMSG_"Non -Renewable Patient S tatus.",VA LMBCK="R"
	10271	"RTN","PSO UTIL",120, 0)
	10272	.S:$G(OR0 ) ACOM=ACO M_" Non-Re newable Pa tient Stat us."
	10273	"RTN","PSO UTIL",121, 0)
	10274	;
	10275	"RTN","PSO UTIL",122, 0)
	10276	I PSOREA[ "E" W:$G(S PEED) ", N on-Verifie d Rx." D
	10277	"RTN","PSO UTIL",123, 0)
	10278	.W:'$G(PO ERR) !,"No n-Verified Rx" S:$G( POERR)&('$ G(SPEED)) VALMSG=DSM SG_"Non-Ve rified Rx. ",VALMBCK= "R"
	10279	"RTN","PSO UTIL",124, 0)
	10280	.S:$G(OR0 ) ACOM=ACO M_" Non-Ve rified Rx. "
	10281	"RTN","PSO UTIL",125, 0)
	10282	;
	10283	"RTN","PSO UTIL",126, 0)
	10284	I PSOREA[ "F" W:$G(S PEED) ", M aximum of 26 Renewal s." D
	10285	"RTN","PSO UTIL",127, 0)
	10286	.W:'$G(PO ERR) !,"Ma ximum of 2 6 Renewals " S:$G(POE RR)&('$G(S PEED)) VAL MSG=DSMSG_ "Maximum o f 26 Renew als.",VALM BCK="R"
	10287	"RTN","PSO UTIL",128, 0)
	10288	.S:$G(OR0 ) ACOM=ACO M_" Maximu m of 26 Re newals."
	10289	"RTN","PSO UTIL",129, 0)
	10290	;
	10291	"RTN","PSO UTIL",130, 0)
	10292	I PSOREA[ "G",PSOREA '["B" W:$G (SPEED) ", No more r efills lef t." W:'$G( POERR) !," No more re fills left " S:$G(POE RR)&('$G(S PEED)) VAL MSG=DSMSG_ "No more r efills lef t.",VALMBC K="R"
	10293	"RTN","PSO UTIL",131, 0)
	10294	;
	10295	"RTN","PSO UTIL",132, 0)
	10296	I PSOREA[ "Z" D
	10297	"RTN","PSO UTIL",133, 0)
	10298	. S:PSOST AT=4 PSOST AT=1
	10299	"RTN","PSO UTIL",134, 0)
	10300	. S PSOA= ";"_PSOSTA T,PSOB=$P( ^DD(52,100 ,0),"^",3) ,PSOA=$F(P SOB,PSOA), PSOA=$P($E (PSOB,PSOA ,999),";", 1)
	10301	"RTN","PSO UTIL",135, 0)
	10302	. W:$G(SP EED) ", Rx is in "_$ P(PSOA,":" ,2)_" stat us."
	10303	"RTN","PSO UTIL",136, 0)
	10304	. W:'$G(P OERR)&('$G (SPEED)) ! ,"Rx is in "_$P(PSOA ,":",2)_" status"
	10305	"RTN","PSO UTIL",137, 0)
	10306	.S:$G(POE RR)&($G(VA LMSG)']"") &('$G(SPEE D)) VALMSG =DSMSG_"Rx is in "_$ P(PSOA,":" ,2)_" stat us.",VALMB CK="R"
	10307	"RTN","PSO UTIL",138, 0)
	10308	. K PSOA, PSOB
	10309	"RTN","PSO UTIL",139, 0)
	10310	. Q
	10311	"RTN","PSO UTIL",140, 0)
	10312	I $G(SPEE D) K DIR S DIR(0)="E ",DIR("A") ="Press Re turn to Co ntinue" D ^DIR K DIR UT,DUOUT,D TOUT,DIR
	10313	"RTN","PSO UTIL",141, 0)
	10314	Q
	10315	"RTN","PSO UTIL",142, 0)
	10316	ACP I $P(^ PSRX(PSOX( "IRXN"),0) ,"^",11)=" W",$G(^("I B")) S ^PS RX("ACP",$ P(^PSRX(PS OX("IRXN") ,0),"^",2) ,$P(^(2)," ^",2),0,PS OX("IRXN") )=""
	10317	"RTN","PSO UTIL",143, 0)
	10318	Q
	10319	"RTN","PSO UTIL",144, 0)
	10320	;
	10321	"RTN","PSO UTIL",145, 0)
	10322	RENFDT(PSO X) ;gets t he correct fill date
	10323	"RTN","PSO UTIL",146, 0)
	10324	S PSOX("O LD FILL DA TE")=PSOX( "FILL DATE ")
	10325	"RTN","PSO UTIL",147, 0)
	10326	S PSORX(" OLD FILL D ATE")=PSOR X("FILL DA TE")
	10327	"RTN","PSO UTIL",148, 0)
	10328	S PSOX("F ILL DATE") =$P(PSOX(" RX3"),"^", 2)
	10329	"RTN","PSO UTIL",149, 0)
	10330	N RXY,LBL ,SUPN,LBP, RF,RFN,RFD
	10331	"RTN","PSO UTIL",150, 0)
	10332	S RXY=PSO X("IRXN"), RFN=0
	10333	"RTN","PSO UTIL",151, 0)
	10334	I '$O(^PS RX(RXY,1,0 )) D GFDT G SDTX
	10335	"RTN","PSO UTIL",152, 0)
	10336	F RF=0:0 S RF=$O(^P SRX(RXY,1, RF)) Q:'RF S RFN=RF
	10337	"RTN","PSO UTIL",153, 0)
	10338	S RF=^PSR X(RXY,1,RF N,0) D GFD T
	10339	"RTN","PSO UTIL",154, 0)
	10340	I PSOX("F ILL DATE") <DT,PSOX(" FILL DATE" )<PSORNW(" FILL DATE" ) S PSOX(" FILL DATE" )=DT
	10341	"RTN","PSO UTIL",155, 0)
	10342	SDTX ;
	10343	"RTN","PSO UTIL",156, 0)
	10344	S Y=PSOX( "FILL DATE ")
	10345	"RTN","PSO UTIL",157, 0)
	10346	X ^DD("DD ") S PSORX ("FILL DAT E")=Y K Y
	10347	"RTN","PSO UTIL",158, 0)
	10348	Q
	10349	"RTN","PSO UTIL",159, 0)
	10350	GFDT ;
	10351	"RTN","PSO UTIL",160, 0)
	10352	I 'RFN,$P (^PSRX(RXY ,2),"^",13 ) Q
	10353	"RTN","PSO UTIL",161, 0)
	10354	I RFN,$P( RF,"^",18) Q
	10355	"RTN","PSO UTIL",162, 0)
	10356	F LBL=0:0 S LBL=$O( ^PSRX(RXY, "L",LBL)) Q:'LBL I $P(^PSRX(R XY,"L",LBL ,0),"^",2) =RFN S LBP =1 Q
	10357	"RTN","PSO UTIL",163, 0)
	10358	Q:$G(LBP)
	10359	"RTN","PSO UTIL",164, 0)
	10360	S SUPN=$O (^PS(52.5, "B",RXY,0) )
	10361	"RTN","PSO UTIL",165, 0)
	10362	I SUPN,$P ($G(^PS(52 .5,SUPN,0) ),"^",7)=" L"!($P($G( ^(0)),"^", 7)="X") Q
	10363	"RTN","PSO UTIL",166, 0)
	10364	S:RFN RFD =$E($P(RF, "^"),1,7) S:'RFN RFD =$P(PSOX(" RX3"),"^")
	10365	"RTN","PSO UTIL",167, 0)
	10366	I SUPN,RF D,$D(^PS(5 2.5,"C",RF D,SUPN)),$ G(^PS(52.5 ,SUPN,"P") )=1 Q
	10367	"RTN","PSO UTIL",168, 0)
	10368	S PSOX("F ILL DATE") =$P(PSOX(" RX3"),"^")
	10369	"RTN","PSO UTIL",169, 0)
	10370	Q
	10371	"RTN","PSO UTIL",170, 0)
	10372	;
	10373	"RTN","PSO UTIL",171, 0)
	10374	ISSPLY() ; is the dru g a supply item
	10375	"RTN","PSO UTIL",172, 0)
	10376	;assumes the existe nce of the PSODRUG a rray
	10377	"RTN","PSO UTIL",173, 0)
	10378	I $G(PSOD RUG("DEA") )="" Q 0
	10379	"RTN","PSO UTIL",174, 0)
	10380	I $G(PSOD RUG("VA CL ASS"))="" Q 0
	10381	"RTN","PSO UTIL",175, 0)
	10382	I PSODRUG ("VA CLASS ")?1"XA".E !(PSODRUG( "VA CLASS" )?1"XX".E) !(PSODRUG( "VA CLASS" )="DX900"& (PSODRUG(" DEA")["S") ) Q 1
	10383	"RTN","PSO UTIL",176, 0)
	10384	Q 0
	10385	"RTN","PSO UTIL",177, 0)
	10386	;
	10387	"RTN","PSO UTIL",178, 0)
	10388	DAYSUP(DRU G,RXARR,RC LQTY) ; Ad justs DAYS SUPPLY an d QUANTITY based on the maximu m allowed
	10389	"RTN","PSO UTIL",179, 0)
	10390	; Input: DRUG - D RUG file ( #50) IEN
	10391	"RTN","PSO UTIL",180, 0)
	10392	; RXARR - A rray conta ining pres cription i nformation
	10393	"RTN","PSO UTIL",181, 0)
	10394	; RVWQTY - R e-calculat e Quantity (1: YES / 0: NO)
	10395	"RTN","PSO UTIL",182, 0)
	10396	;Output: RXARR - A rray with "DAYS SUPP LY" and "Q TY" values modified
	10397	"RTN","PSO UTIL",183, 0)
	10398	;
	10399	"RTN","PSO UTIL",184, 0)
	10400	; - Inval id Dispens e Drug
	10401	"RTN","PSO UTIL",185, 0)
	10402	I '$D(^PS DRUG(+$G(D RUG),0))!' $D(RXARR) Q
	10403	"RTN","PSO UTIL",186, 0)
	10404	N MXDAYSU P,RXDAYSUP ,RXQTY,NEW QTY
	10405	"RTN","PSO UTIL",187, 0)
	10406	S MXDAYSU P=$$MXDAYS UP^PSSUTIL 1(DRUG)
	10407	"RTN","PSO UTIL",188, 0)
	10408	S RXDAYSU P=+$G(RXAR R("DAYS SU PPLY"))
	10409	"RTN","PSO UTIL",189, 0)
	10410	I RXDAYSU P>MXDAYSUP D
	10411	"RTN","PSO UTIL",190, 0)
	10412	. W !!,"T he current DAYS SUPP LY value ( ",RXDAYSUP ,") exceed s the Maxi mum allowe d"
	10413	"RTN","PSO UTIL",191, 0)
	10414	. W !,"fo r ",$$GET1 ^DIQ(50,DR UG,.01)," (",MXDAYSU P,") and w ill be res et.",$C(7)
	10415	"RTN","PSO UTIL",192, 0)
	10416	. S RXARR ("DAYS SUP PLY")=MXDA YSUP
	10417	"RTN","PSO UTIL",193, 0)
	10418	. S RXQTY =+$G(RXARR ("QTY"))
	10419	"RTN","PSO UTIL",194, 0)
	10420	. I $G(RC LQTY),RXQT Y,RCLQTY'= RXQTY D
	10421	"RTN","PSO UTIL",195, 0)
	10422	. . S NEW QTY=((RXQT Y*MXDAYSUP )/RXDAYSUP )+.5\1
	10423	"RTN","PSO UTIL",196, 0)
	10424	. . W !!, "The Quant ity was ch anged from ",RXQTY," to ",NEWQ TY,"."
	10425	"RTN","PSO UTIL",197, 0)
	10426	. . S RXA RR("QTY")= NEWQTY
	10427	"RTN","PSO UTIL",198, 0)
	10428	. W !!,"P lease, rev iew the mo dified ord er before accepting it."
	10429	"RTN","PSO UTIL",199, 0)
	10430	. W ! N D IR S DIR(0 )="E",DIR( "A")="Pres s Return t o continue " D ^DIR
	10431	"RTN","PSO UTIL",200, 0)
	10432	Q
	10433	"RTN","PSO UTIL",201, 0)
	10434	;
	10435	"RTN","PSO UTIL",202, 0)
	10436	MAXNUMRF(D RUG,DAYSUP ,PTST,CLOZ PAT) ; Ret urns the M aximum Num ber of Ref ills Allow ed
	10437	"RTN","PSO UTIL",203, 0)
	10438	; Input: DRUG - DRUG file (#50) IEN
	10439	"RTN","PSO UTIL",204, 0)
	10440	; DAYSUP - Number of DAYS SUPP LY per fil l
	10441	"RTN","PSO UTIL",205, 0)
	10442	; PTST - RX PATIEN T STATUES (#53) IEN
	10443	"RTN","PSO UTIL",206, 0)
	10444	; CLOZPAT - Clozapine Indicator Variable (used thro ughout PSO )
	10445	"RTN","PSO UTIL",207, 0)
	10446	;Output: MAXNUMRF - Maximum N umber of R efills
	10447	"RTN","PSO UTIL",208, 0)
	10448	;
	10449	"RTN","PSO UTIL",209, 0)
	10450	N MAXNUMR F,DEAHDLG, CSDRUG,MAX PTST
	10451	"RTN","PSO UTIL",210, 0)
	10452	; - Inval id Drug or DAYS SUPP LY value
	10453	"RTN","PSO UTIL",211, 0)
	10454	I '$D(^PS DRUG(+$G(D RUG),0)),' $G(DAYSUP) Q 0
	10455	"RTN","PSO UTIL",212, 0)
	10456	;
	10457	"RTN","PSO UTIL",213, 0)
	10458	; - Calcu lating Max imum for C lozapine D rug
	10459	"RTN","PSO UTIL",214, 0)
	10460	I $D(CLOZ PAT) Q $S( CLOZPAT=2& (DAYSUP=14 ):1,CLOZPA T=2&(DAYSU P=7):3,CLO ZPAT=1&(DA YSUP=7):1, 1:0)
	10461	"RTN","PSO UTIL",215, 0)
	10462	;
	10463	"RTN","PSO UTIL",216, 0)
	10464	; - Non-R efillable Drugs base d on DEA S PECIAL HDL G field
	10465	"RTN","PSO UTIL",217, 0)
	10466	S DEAHDLG =""
	10467	"RTN","PSO UTIL",218, 0)
	10468	I $G(DRUG ) S DEAHDL G=$$GET1^D IQ(50,DRUG ,3) I DEAH DLG["A"&(D EAHDLG'["B ")!(DEAHDL G["F")!(DE AHDLG[1)!( DEAHDLG[2) Q 0
	10469	"RTN","PSO UTIL",219, 0)
	10470	S CSDRUG= 0 I (DEAHD LG[3)!(DEA HDLG[4)!(D EAHDLG[5) S CSDRUG=1
	10471	"RTN","PSO UTIL",220, 0)
	10472	;
	10473	"RTN","PSO UTIL",221, 0)
	10474	; - The M aximum Num ber of Ref ills Calcu lation is different for up to 90 Days Su pply Vs. A bove 90 Da ys Supply
	10475	"RTN","PSO UTIL",222, 0)
	10476	I $G(CSDR UG) D
	10477	"RTN","PSO UTIL",223, 0)
	10478	. I DAYSU P'>90 D
	10479	"RTN","PSO UTIL",224, 0)
	10480	. . S MAX NUMRF=$S(D AYSUP<60:5 ,DAYSUP'<6 0&(DAYSUP' >89):2,DAY SUP=90:1,1 :0)
	10481	"RTN","PSO UTIL",225, 0)
	10482	. E D
	10483	"RTN","PSO UTIL",226, 0)
	10484	. . S MAX NUMRF=182\ DAYSUP-1
	10485	"RTN","PSO UTIL",227, 0)
	10486	E D
	10487	"RTN","PSO UTIL",228, 0)
	10488	. I DAYSU P'>90 D
	10489	"RTN","PSO UTIL",229, 0)
	10490	. . S MAX NUMRF=$S(D AYSUP<60:1 1,DAYSUP'< 60&(DAYSUP '>89):5,DA YSUP=90:3, 1:0)
	10491	"RTN","PSO UTIL",230, 0)
	10492	. E D
	10493	"RTN","PSO UTIL",231, 0)
	10494	. . S MAX NUMRF=365\ DAYSUP-1
	10495	"RTN","PSO UTIL",232, 0)
	10496	;
	10497	"RTN","PSO UTIL",233, 0)
	10498	; - Adjus ting Maxim um based R x Patient Status
	10499	"RTN","PSO UTIL",234, 0)
	10500	I $G(PTST ) S MAXPTS T=$$GET1^D IQ(53,PTST ,4) I MAXN UMRF>MAXPT ST S MAXNU MRF=MAXPTS T
	10501	"RTN","PSO UTIL",235, 0)
	10502	;
	10503	"RTN","PSO UTIL",236, 0)
	10504	Q MAXNUMR F
	10505	"RTN","PSO UTIL",237, 0)
	10506	;
	10507	"RTN","PSO UTIL",238, 0)
	10508	BADADDFL(R XIEN) ; In dicate whe ther an Rx should be flagged w ith a Bad Address
	10509	"RTN","PSO UTIL",239, 0)
	10510	; Input: RXIEN - Rx IEN (# 52) to be checked
	10511	"RTN","PSO UTIL",240, 0)
	10512	;Output: BADADDFL - 1: Rx Fla gged for B ad Address / 0: Rx N OT Flagged Bad Addre ss
	10513	"RTN","PSO UTIL",241, 0)
	10514	N BADADDF L,LSTLBLSQ ,LSTLBLTX
	10515	"RTN","PSO UTIL",242, 0)
	10516	S BADADDF L=0
	10517	"RTN","PSO UTIL",243, 0)
	10518	I '$G(^PS RX(+$G(RXI EN),0)) Q BADADDFL
	10519	"RTN","PSO UTIL",244, 0)
	10520	S LSTLBLS Q=$O(^PSRX (+RXIEN,"L ",9999),-1 )
	10521	"RTN","PSO UTIL",245, 0)
	10522	I LSTLBLS Q D
	10523	"RTN","PSO UTIL",246, 0)
	10524	. S LSTLB LTX=$G(^PS RX(+RXIEN, "L",LSTLBL SQ,0)) I L STLBLTX["( BAD ADDRES S)" S BADA DDFL=1
	10525	"RTN","PSO UTIL",247, 0)
	10526	Q BADADDF L
	10527	"RTN","PSO UTIL",248, 0)
	10528	;
	10529	"RTN","PSO UTIL",249, 0)
	10530	PRVDETOX(P RVIEN) ; R eturns the Provider DETOX#, if available and not n ot expired
	10531	"RTN","PSO UTIL",250, 0)
	10532	; Input: (r) PRVIEN - Provi der IEN (P ointer to VA PERSON file (#200 ))
	10533	"RTN","PSO UTIL",251, 0)
	10534	;Output: PRVDET OX - Provi der Detox #
	10535	"RTN","PSO UTIL",252, 0)
	10536	N PRVDETO X
	10537	"RTN","PSO UTIL",253, 0)
	10538	S PRVDETO X=$$DETOX^ XUSER(PRVI EN) I PRVD ETOX?1"X"1 A7N Q PRVD ETOX
	10539	"RTN","PSO UTIL",254, 0)
	10540	Q ""
	10541	"RTN","PSO UTIL",255, 0)
	10542	;
	10543	"RTN","PSO UTIL",256, 0)
	10544	RXDEA(RXIE N,ORIEN) ; Returns t he Provide r DEA# ass ociated wi th the Pre scription/ CPRS Order (At least one of RX IEN or ORI EN is requ ired)
	10545	"RTN","PSO UTIL",257, 0)
	10546	; Input: (o) RXIEN - Prescrip tion IEN ( Pointer to the PRESC RIPTION fi le (#52))
	10547	"RTN","PSO UTIL",258, 0)
	10548	; (o) ORIEN - CPRS Ord er IEN (Po inter to O RDER file (#100))
	10549	"RTN","PSO UTIL",259, 0)
	10550	;Output: RXDEA - Provider DEA# asso ciated wit h the Pres cription
	10551	"RTN","PSO UTIL",260, 0)
	10552	N RXDEA
	10553	"RTN","PSO UTIL",261, 0)
	10554	I $G(RXIE N) S ORIEN =+$$GET1^D IQ(52,RXIE N,39.3,"I" )
	10555	"RTN","PSO UTIL",262, 0)
	10556	I $G(ORIE N) K ^TMP( $J,"ORDEA" ) D ARCHIV E^ORDEA(OR IEN) S RXD EA=$P($G(^ TMP($J,"OR DEA",ORIEN ,2)),"^",1 ) K ^TMP($ J,"ORDEA")
	10557	"RTN","PSO UTIL",263, 0)
	10558	Q $G(RXDE A)
	10559	"RTN","PSO UTIL",264, 0)
	10560	;
	10561	"RTN","PSO UTIL",265, 0)
	10562	RXDETOX(RX IEN,ORIEN) ; Returns the Provi der DETOX# associate d with the Prescript ion/CPRS O rder (At l east one o f RXIEN or ORIEN is required)
	10563	"RTN","PSO UTIL",266, 0)
	10564	; Input: (o) RXIEN - Prescr iption IEN (Pointer to the PRE SCRIPTION file (#52) )
	10565	"RTN","PSO UTIL",267, 0)
	10566	; (o) ORIEN - CPRS O rder IEN ( Pointer to the ORDER file (#10 0))
	10567	"RTN","PSO UTIL",268, 0)
	10568	;Output: RXDETO X - Provid er DETOX# associated with the Prescripti on
	10569	"RTN","PSO UTIL",269, 0)
	10570	N RXDETOX
	10571	"RTN","PSO UTIL",270, 0)
	10572	I $G(RXIE N) S ORIEN =+$$GET1^D IQ(52,RXIE N,39.3,"I" )
	10573	"RTN","PSO UTIL",271, 0)
	10574	I $G(ORIE N) K ^TMP( $J,"ORDEA" ) D ARCHIV E^ORDEA(OR IEN) S RXD ETOX=$P($G (^TMP($J," ORDEA",ORI EN,2)),"^" ,2) K ^TMP ($J,"ORDEA ")
	10575	"RTN","PSO UTIL",272, 0)
	10576	Q $G(RXDE TOX)
	10577	"RTN","PSO UTIL",273, 0)
	10578	;
	10579	"RTN","PSO UTIL",274, 0)
	10580	CHKRXPRV(R XIEN,PRVIE N) ; Check if the Pr ovider can be assign ed to a sp ecific Pre scription (Used for Rx Copy, R x Renewal, etc.)
	10581	"RTN","PSO UTIL",275, 0)
	10582	; Input: (r) RXIEN - Prescri ption IEN (Pointer t o the PRES CRIPTION f ile (#52))
	10583	"RTN","PSO UTIL",276, 0)
	10584	; (o) PRVIEN - Provide r IEN (Poi nter to th e NEW PERS ON file (# 200))
	10585	"RTN","PSO UTIL",277, 0)
	10586	;Output: $CHKRXPRV - 1: YES / 0: NO^Sh ort Reason (Listman) ^Long Reas on (Write to screen)
	10587	"RTN","PSO UTIL",278, 0)
	10588	N CHKRXPR V,DRUGIEN, CLOZDRUG,D RUGDEA,REA SON
	10589	"RTN","PSO UTIL",279, 0)
	10590	I '$D(^PS RX(+$G(RXI EN),0)) Q "0^Prescri ption not found^Pres cription n ot found"
	10591	"RTN","PSO UTIL",280, 0)
	10592	I '$G(PRV IEN) S PRV IEN=$$GET1 ^DIQ(52,RX IEN,4,"I")
	10593	"RTN","PSO UTIL",281, 0)
	10594	I '$D(^VA (200,+$G(P RVIEN),0)) Q "0^Prov ider not f ound^Provi der not fo und"
	10595	"RTN","PSO UTIL",282, 0)
	10596	S DRUGIEN =$$GET1^DI Q(52,RXIEN ,6,"I") I 'DRUGIEN Q "0^Invali d Dispense Drug^Inva lid Dispen se Drug"
	10597	"RTN","PSO UTIL",283, 0)
	10598	S CLOZDRU G=$S($D(^P SDRUG("ACL OZ",DRUGIE N)):1,1:0)
	10599	"RTN","PSO UTIL",284, 0)
	10600	I CLOZDRU G,'$D(^XUS EC("YSCL A UTHORIZED" ,PRVIEN)) Q "0^Provi der does n ot hold YS CL AUTHORI ZED key^Pr ovider on the Rx doe s not hold the YSCL AUTHORIZED key requi red for cl ozapine pr escription s."
	10601	"RTN","PSO UTIL",285, 0)
	10602	S DRUGDEA =$$DRUGSCH D(DRUGIEN)
	10603	"RTN","PSO UTIL",286, 0)
	10604	I DRUGDEA '="" S REA SON="" D I REASON'= "" Q REASO N
	10605	"RTN","PSO UTIL",287, 0)
	10606	. N PRVDE A
	10607	"RTN","PSO UTIL",288, 0)
	10608	. S PRVDE A=$P($$SDE A^XUSER(0, PRVIEN,DRU GDEA,$$RXD EA^PSOUTIL (RXIEN))," ^") ;*545
	10609	"RTN","PSO UTIL",289, 0)
	10610	. I $L(PR VDEA)<3 D
	10611	"RTN","PSO UTIL",290, 0)
	10612	. . I PRV DEA=2 S RE ASON="0^Pr ovider not authorize d to write Schedule "_DRUGDEA_ " Rx^Provi der is not authorize d to write Federal S chedule "_ DRUGDEA_" prescripti ons" Q
	10613	"RTN","PSO UTIL",291, 0)
	10614	. . S REA SON="0^Pro vider must have a va lid DEA# o r VA# for this Rx^Pr ovider doe s not have a valid D EA# or VA# required for this R x"
	10615	"RTN","PSO UTIL",292, 0)
	10616	I $$DETOX ^PSSOPKI(D RUGIEN),$$ PRVDETOX^P SOUTIL(PRV IEN)="" Q "0^Provide r must hav e a valid DETOX# for this Rx^P rovider do es not hav e a valid DETOX# req uired for this Rx"
	10617	"RTN","PSO UTIL",293, 0)
	10618	Q 1
	10619	"RTN","PSO UTIL",294, 0)
	10620	;
	10621	"RTN","PSO UTIL",295, 0)
	10622	DRUGSCHD(D RUGIEN) ; Return Dru g DEA Sche dule or "" (blank) f or non-con trolled su bstances
	10623	"RTN","PSO UTIL",296, 0)
	10624	; Input: (r) DRUGIE N - Dispen se Drug IE N (Pointer to the DR UG file (# 50))
	10625	"RTN","PSO UTIL",297, 0)
	10626	;Output: $DRUGSCHD - DEA Sc hedule or "" (blank) for non-c ontrolled substances
	10627	"RTN","PSO UTIL",298, 0)
	10628	N NDFSCHD ,DRUGDEA,N DFIEN
	10629	"RTN","PSO UTIL",299, 0)
	10630	S NDFSCHD ="",DRUGDE A=$$GET1^D IQ(50,DRUG IEN,3)
	10631	"RTN","PSO UTIL",300, 0)
	10632	S NDFIEN= +$$GET1^DI Q(50,DRUGI EN,22,"I") I NDFIEN S NDFSCHD= $$GET1^DIQ (50.68,NDF IEN,19,"I" )
	10633	"RTN","PSO UTIL",301, 0)
	10634	I +NDFIEN >0!(DRUGDE A="") Q $S ('NDFSCHD: "",1:NDFSC HD)
	10635	"RTN","PSO UTIL",302, 0)
	10636	I "^2^3^" [+DRUGDEA Q $S(DRUGD EA["A":+DR UGDEA,1:+D RUGDEA_"n" )
	10637	"RTN","PSO UTIL",303, 0)
	10638	I "^4^5^" [+DRUGDEA Q +DRUGDEA
	10639	"RTN","PSO UTIL",304, 0)
	10640	Q ""
	10641	"VER")
	10642	8.0^22.2
	10643	END
	10644	END