Produced by Araxis Merge on 8/29/2018 2:55:43 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.
# | Location | File | Last Modified |
---|---|---|---|
1 | EPIP.zip\PSD_3.0_84_Aug_2018 | EPIP_Remediation_Plan_(PSD_3.0_84).doc | Tue Aug 28 12:23:02 2018 UTC |
2 | EPIP.zip\PSD_3.0_84_Aug_2018 | EPIP_Remediation_Plan_(PSD_3.0_84).doc | Tue Aug 28 12:42:08 2018 UTC |
Description | Between Files 1 and 2 |
|
---|---|---|
Text Blocks | Lines | |
Unchanged | 4 | 1996 |
Changed | 3 | 6 |
Inserted | 0 | 0 |
Removed | 0 | 0 |
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 |
No regular expressions were active.
1 | EPIP_Remed iation_Pla nExisting Product In take Progr am (EPIP) | |
2 | Patch PSD* 3.0*84 | |
3 | Remediatio n Plan | |
4 | ||
5 | Department of Vetera ns Affairs | |
6 | August 201 8 | |
7 | Version 2. 0 | |
8 | Revision H istory | |
9 | DateVersio nDescripti onAuthor08 /01/20182. 0Updates t hroughoutE PIP Projec t Team04/0 3/20181.0I nitial (dr aft) versi onEPIP Pro ject TeamT able of Co ntents | |
10 | 11. | |
11 | Introducti on | |
12 | ||
13 | ||
14 | 12. | |
15 | Purpose | |
16 | ||
17 | ||
18 | 13. | |
19 | Patch Desc ription | |
20 | ||
21 | ||
22 | 23.1. | |
23 | Business E pics and S ub-Epics | |
24 | ||
25 | ||
26 | 24. | |
27 | Points of Contact | |
28 | ||
29 | ||
30 | 25. | |
31 | Code Remed iation | |
32 | ||
33 | ||
34 | 35.1. | |
35 | Standards and Conven tions | |
36 | ||
37 | ||
38 | 35.2. | |
39 | Review and Analysis | |
40 | ||
41 | ||
42 | 35.3. | |
43 | Coding Cha nges | |
44 | ||
45 | ||
46 | 36. | |
47 | Testing | |
48 | ||
49 | ||
50 | 36.1. | |
51 | Test Plan | |
52 | ||
53 | ||
54 | 46.2. | |
55 | Test Envir onment | |
56 | ||
57 | ||
58 | 46.3. | |
59 | Test Readi ness Revie w | |
60 | ||
61 | ||
62 | 46.4. | |
63 | Testing Ph ases | |
64 | ||
65 | ||
66 | 46.4.1. | |
67 | Unit Testi ng | |
68 | ||
69 | ||
70 | 46.4.2. | |
71 | Component Integratio n and Syst ems Testin g (CI/ST) | |
72 | ||
73 | ||
74 | 46.4.3. | |
75 | Functional Testing | |
76 | ||
77 | ||
78 | 56.4.4. | |
79 | Regression Testing | |
80 | ||
81 | ||
82 | 56.4.5. | |
83 | Section 50 8 Complian ce Testing | |
84 | ||
85 | ||
86 | 57. | |
87 | Documentat ion Remedi ation | |
88 | ||
89 | ||
90 | 57.1. | |
91 | User Guide s | |
92 | ||
93 | ||
94 | 57.2. | |
95 | Installati on Guides | |
96 | ||
97 | ||
98 | 67.3. | |
99 | Technical Manuals | |
100 | ||
101 | ||
102 | 67.4. | |
103 | Operations Manuals | |
104 | ||
105 | ||
106 | 68. | |
107 | Project Re porting | |
108 | ||
109 | ||
110 | 69. | |
111 | Project Sc hedule | |
112 | ||
113 | ||
114 | 610. | |
115 | Deployment | |
116 | ||
117 | ||
118 | 611. | |
119 | Sustainmen t Requirem ents | |
120 | ||
121 | ||
122 | 612. | |
123 | Maintenanc e and Know ledge Tran sfer | |
124 | ||
125 | ||
126 | 7Appendix A: | |
127 | XINDEX Lis ting for M UMPS Code Changes | |
128 | ||
129 | ||
130 | 8Appendix B: | |
131 | Source Cod e Changes | |
132 | ||
133 | ||
134 | ||
135 | ||
136 | Introducti on | |
137 | The Depart ment of Ve terans Aff airs (VA) currently utilizes t he Veteran s Health I nformation Systems a nd Technol ogy Archit ecture (Vi stA) suite of applic ations to provide cl inical, fi nancial, i nfrastruct ure, and m anagement tools. The process o f advancin g “Class 3 ” field-de veloped Vi stA softwa re to “Cla ss 1” nati onally-dis tributed s tatus is r eferred to as the Ex isting Pro duct Intak e Program (EPIP). Th e VA’s goa l is to su pplement o ngoing act ivities as sociated w ith evalua ting and a dvancing f ield-devel oped softw are to a s tate that meets nati onal stand ards and f acilitates release f or Veteran s Health A dministrat ion (VHA)- wide use. | |
138 | Purpose | |
139 | The purpos e of this document i s to fully describe the remedi ation plan to be use d for the successful remediati on of the intake pro duct code to be depl oyed as pa tch PSD*3. 0*84. This patch add resses the following NSRs: | |
140 | NSR2017110 1 Controll ed Substan ce Narcoti c Count In put | |
141 | This NSR h as been im plemented locally at the VA He alth Care Systems in Fargo ND, Sioux Fal ls SD, For t Meade SD , Minneapo lis MN, an d St. Clou d MN. | |
142 | NSR2017111 1 Pharmacy Activity Report Sch ed II Meds | |
143 | This NSR h as been im plemented locally at the VA Me dical Cent er in Milw aukee WI. | |
144 | This docum ent addres ses the sc hedule, co de remedia tion, test ing, docum entation, and delive ry of this remediati on effort. | |
145 | Patch Desc ription | |
146 | PSD*3.0*84 provides the follow ing enhanc ements to VistA: | |
147 | Enhances t he Outpati ent Rx’s [ PSD OUTPAT IENT] opti on in the Pharmacist Menu [PSD TRANSACTI ON MENU] t o require users to e nter the c urrent on- hand narco tic medica tion count without s eeing the VistA comp uted count . The exis ting optio n displays the VistA narcotic medication count wit hout askin g users to enter the actual on -hand coun t, which d oes not en sure that an actual count was performed to confirm that the number sho wn in Vist A matches the true c ount. The modificati on ensures that an a ctual coun t is perfo rmed and c ompares th e user's i nput again st current VistA tot als. If th e balances entered b y the user do not ma tch the Vi stA count after thre e attempts , then an | |
148 | e-mail mes sage is se nt to the new CS BAL ANCE DISCR EPANCY mai l group fo r further investigat ion. The m ail group is populat ed by each site with pharmacy supervisor s who can address ba lance disc repancies. | |
149 | During the post-inst allation p hase, rout ine PSD84P checks to see if th ere is a p re-existin g CS BALAN CE DISCREP ANCY mail group. If it does no t exist, t he routine creates t he new mai l group an d displays an on-scr een confir mation. Ro utine PSD8 4P is dele ted automa tically at the end o f patch in stallation . | |
150 | This modif ication se rves as a failsafe a gainst nar cotic dive rsion. | |
151 | Enhances t he "Daily Activity L og (in lie u of VA FO RM 10-2320 )" [PSD DA ILY LOG] o ption in t he Product ion Report s [PSD PRO DUCTION RE PORTS] men u and the "Daily Act ivity Log (in lieu o f VA FORM 10-2320)" [PSD DAILY LOG TECH] option in the Techn ician (CS Pharmacy) Menu [PSD PHARM TECH ] to group all Sched ule II dru gs under o ne group n ame. The e xisting op tion allow s a user t o print al l activity using the [^ALL] gr oup select ion or req uires a us er to manu ally input the name of each in dividual d rug in the group eve ry time a Daily Acti vity Log r eport is r un. Manual ly inputti ng this in formation is a signi ficant tim e burden a nd increas es the pos sibility o f data ent ry mistake s. This en hancement allows the user to e nter one g roup name [^ALL CII DRUGS] tha t selects all Schedu le II drug s instead of requiri ng entry o f individu al drug na mes. This group name must be t yped in fu ll; there is no shor tcut or au to-complet e. | |
152 | This modif ication en sures a mo re accurat e report, thereby he lping to m onitor for drug dive rsion patt erns and a iding staf f in troub leshooting when the electronic supply co unt does n ot match t he number of items o n-hand. | |
153 | Business E pics and S ub-Epics | |
154 | The Busine ss Epics a nd Sub-Epi cs for the NSRs addr essed in t his remedi ation are: | |
155 | NSR2017110 1 Controll ed Substan ce Narcoti c Count In put | |
156 | BUSINESS E PIC 948795 : Narcotic Count - F or Pharmac y supervis ors who ar e responsi ble for pr eventing n arcotics d iversion, a capabili ty to forc e users to enter the current n arcotic co unt on han d when usi ng the Out patient RX option [P SD OUTPATI ENT] withi n the Cont rolled Sub stances pa ckage befo re they se e the Vist A computed count, th at then co mpares the user ente red count to the Vis tA compute d count. U nlike the current ap proach whi ch simply displays t he current narcotic count on h and to the user, our process e nsures tha t an actua l count wa s performe d and aler ts others after seve ral failed counts ar e entered so that th e discrepa ncy can be investiga ted. | |
157 | NSR2017111 1 Pharmacy Activity Report Sch ed II Meds | |
158 | BUSINESS E PIC 951126 : Schedule II Drug A ctivity Re port - For Pharmacy supervisor s who moni tor Schedu le II drug s to ident ify narcot ics divers ion patter ns, a modi fication t o the sele ction crit eria for t he Daily A ctivity Lo g that all ows me to select all Schedule II drugs b y entering one group name. Unl ike the cu rrent proc ess which forces me to enter e ach Schedu le II drug manually, our proce ss saves s taff time and reduce s human er ror associ ated with manual inp ut. | |
159 | Points of Contact | |
160 | The VA Poi nt of Cont act (POC) for NSR201 71101 Cont rolled Sub stance Nar cotic Coun t Input an d NSR20171 111 Pharma cy Activit y Report S ched II Me ds is Robe rt Silverm an ( HYPE R LINK "PII " PII
|
|
161 | Code Remed iation | |
162 | Leidos wil l review a nd analyze the intak e product code for c ompliance with codin g standard s, pointer s, shared tables, de pendencies , and any interferen ce with Vi stA system s. | |
163 | Standards and Conven tions | |
164 | Leidos wil l referenc e the http ://go. DNS /sacc webs ite for ap plicable d ocuments a nd will ad here to VA standards to comple te the ana lysis of t his intake product. The output of the VA XINDEX ut ility will be used t o analyze the MUMPS source cod e and docu ment the a ffected ro utines (se e Appendix A). | |
165 | The MUMPS coding sta ndards web site http: //71.174.6 2.16/Demo/ AnnoStd wi ll also be used to e nsure that the remed iated code conforms to VA stan dards. | |
166 | Review and Analysis | |
167 | Review and analysis of this in take produ ct involve s two part s: 1) veri fication t hat the so urce code changes sp ecified in this docu ment provi de the des ired effec t, and 2) verificati on that th e source c ode change s do not a dversely a ffect any other Vist A or CPRS functional ity. | |
168 | Testing wi ll be perf ormed to v alidate th at the int ended effe ct of thes e products is implem ented, and that no o ther VistA or CPRS G raphical U ser Interf ace (GUI) functional ity is adv ersely aff ected. | |
169 | Coding Cha nges | |
170 | The coding changes r equired fo r NSR20171 101 Contro lled Subst ance Narco tic Count Input are in the fol lowing MUM PS routine s: | |
171 | Modified r outines: P SDOPT | |
172 | New routin es: PSDNBA L, PSD84P | |
173 | The coding changes f or NSR2017 1111 Pharm acy Activi ty Report Sched II M eds are in the follo wing MUMPS routines: | |
174 | Modified r outines: P SDACT, PSD ACT1 | |
175 | New routin es: None | |
176 | A detailed analysis of the cod ing change s is provi ded in App endix B. | |
177 | Testing | |
178 | Leidos wil l perform all testin g-related activities to ensure that the remediated code meet s the expe ctations o f the VA b usiness ow ner. | |
179 | Test Plan | |
180 | Leidos wil l configur e the test environme nt, provid e code mod ifications and end-t o-end test ing, and d eliver app licable te sting docu mentation, following Veteran-f ocused Int egration P rocess (VI P) guideli nes. | |
181 | The Leidos developer will modi fy the sof tware purs uant to th e VA stand ards defin ed in the Standards and Conven tions sect ion of thi s document , and will conduct f ull unit t esting of the functi onality an d verify p erformance of all so ftware cod e before i t is relea sed to Lei dos SQA. S QA will th en perform all appli cable test ing types as describ ed in the Testing Ph ases secti on of this document. The devel oper and S QA will re solve prob lems and a ddress iss ues as the y arise du ring testi ng and wil l document issues us ing the Ra tional Tea m Concert (RTC) defe ct trackin g tool. | |
182 | Test Envir onment | |
183 | Within fiv e working days of ap proval of this Remed iation Pla n, the dev eloper wil l configur e the deve lopment/te st environ ment on an Austin In formation Technology Center (A ITC) serve r or other VA-approv ed develop ment/test environmen t used for this inta ke product and insta ll the rem ediated Ke rnel Insta llation an d Distribu tion Syste m (KIDS) b uild or ho st file. T he environ ment will be restore d to its o riginal ba seline sta te by the VistA syst em adminis trator aft er develop ment testi ng is comp leted, fol lowed by i nstallatio n of the r emediated software. | |
184 | Upon notif ication fr om the dev eloper of test envir onment rea diness, SQ A will com mence with planned t esting act ivities. T he SQA tes t executio n and repo rting docu mentation will resid e in the R ational Qu ality Mana ger (QM) “ EPIP” Proj ect. In or der to per form testi ng of this VistA mod ification, the follo wing tools will be l everaged: Rational Q M, Reflect ions emula tor, CPRS GUI v31A ( 1.0.31.116 ), and Sna gIt. | |
185 | Test Readi ness Revie w | |
186 | Leidos wil l conduct a Test Rea diness Rev iew (TRR) at the con clusion of unit test ing to ver ify the co ntents of the softwa re to be t ested, the test sche dule, test environme nts, test participan ts, and as sociated l ogistics. Leidos wil l provide an agenda prior to t he TRR and written m inutes aft er complet ion of the TRR, in a ccordance with the P erformance Work Stat ement (PWS ). | |
187 | Testing Ph ases | |
188 | Leidos wil l perform developmen t and SQA testing ac tivities i n phases, and will p rovide all required testing do cumentatio n. | |
189 | Unit Testi ng | |
190 | The develo per will c onduct uni t testing of individ ual units of source code to de termine if they are fit for us e. | |
191 | Component Integratio n and Syst ems Testin g (CI/ST) | |
192 | Component integratio n and syst ems testin g will be conducted by SQA to ensure tha t connecti vity to th e VistA ap plication exists and is functi oning norm ally. SQA will recor d Passed/F ailed outc omes and c apture dis played con tent to do cument the system te sting effo rt. | |
193 | Functional Testing | |
194 | Functional testing w ill be per formed by SQA to tes t the code modificat ions. This testing w ill ensure that the software f unctionali ty is in a lignment w ith the Go vernment F urnished I nformation . SQA will record Pa ssed/Faile d outcomes and captu re display ed content to docume nt the fun ctional te sting effo rt. | |
195 | Regression Testing | |
196 | Regression testing w ill be per formed by SQA to ens ure that t he remedia ted code d oes not in troduce er rors to ex isting fun ctionality . The regr ession tes t framewor k will be kept up-to -date with manual te st cases a nd test sc ripts defi ning the i nputs and expected o utcomes. S QA will re cord Passe d/Failed o utcomes an d capture displayed content to document the regres sion testi ng effort. | |
197 | Section 50 8 Complian ce Testing | |
198 | Section 50 8 testing will be pe rformed on VistA and CPRS code when new user inter face chang es are int roduced by the devel oper. The VA-recomme nded Assis tive Techn ology tool , JAWS, wi ll be used to conduc t the 508 testing. T est result s and rela ted docume ntation wi ll be subm itted to t he VA Sect ion 508 te am in acco rdance wit h the VA 5 08 testing requireme nts. Defec ts found d uring test ing will b e assessed and remed iated by t he develop er. | |
199 | Documentat ion Remedi ation | |
200 | Leidos wil l review e xisting VA documenta tion for p ossible im pact as a result of this remed iation eff ort, and w ill make u pdates whe re applica ble. | |
201 | To determi ne the exi sting VA d ocumentati on that re quires mod ification, Leidos wi ll conduct a thoroug h review o f the docu ments curr ently avai lable from the VA So ftware Doc ument Libr ary (VDL) located at https://w ww. DNS /vdl/. Key word searc hes using terms rele vant to th is remedia tion effor t will be used to id entify doc uments tha t might be impacted; those doc uments wil l then be reviewed i n their en tirety for any neede d revision s. | |
202 | The follow ing sectio ns outline the VDL d ocuments t o be revis ed for thi s remediat ion. | |
203 | User Guide s | |
204 | The follow ing User G uides will be update d in the V DL: | |
205 | Controlled Substance s (CS) Pha rmacist's User Manua l | |
206 | Controlled Substance s (CS) Sup ervisor's User Manua l | |
207 | Installati on Guides | |
208 | The Nation al Patch M odule Patc h Descript ion docume nt for thi s remediat ion will p rovide the procedure for insta lling the KIDS packa ge or host file into the VA Pr e-Producti on environ ments. The refore, no Installat ion Guides will be u pdated. | |
209 | Technical Manuals | |
210 | The follow ing Techni cal Manual will be u pdated in the VDL: | |
211 | Controlled Substance s (CS) Tec hnical Man ual | |
212 | Operations Manuals | |
213 | No Operati ons Manual s require revision a s a result of this m odificatio n. | |
214 | Project Re porting | |
215 | Leidos wil l provide interim pr ogress upd ates durin g daily Sc rum calls and weekly managemen t calls wi th VA repr esentative s. | |
216 | Project Sc hedule | |
217 | Leidos wil l follow t he Scrum A gile metho dology for software developmen t. It is a nticipated that this patch wil l require five 2-wee k sprints. | |
218 | Deployment | |
219 | Leidos wil l create a KIDS pack age or hos t file con taining th e software changes n ecessary t o fulfill the requir ements for this reme diation ef fort. The new build, along wit h all rela ted docume ntation, w ill be del ivered to the Contra cting Offi ce Represe ntative (C OR) for ac ceptance. If accepte d, these d eliverable s can then be releas ed for nat ional VA c onsumption ; otherwis e, Leidos will corre ct any def ects found and repea t the nece ssary reme diation ac tivities. | |
220 | Sustainmen t Requirem ents | |
221 | Leidos wil l provide maintenanc e support for 90 day s to the V A to suppo rt the fin al Class 1 product a fter it is nationall y released . | |
222 | Maintenanc e and Know ledge Tran sfer | |
223 | To facilit ate contin uous proce ss improve ment, Leid os will de liver Spri nt Review and Retros pective sl ides and a Lessons L earned Rep ort to VA upon compl etion of t he final s print. | |
224 | XINDEX Lis ting for M UMPS Code Changes | |
225 | The XINDEX tool is t he standar d tool use d by the V A to analy ze MUMPS s ource code . Followin g is a lis ting of th e results of the XIN DEX analys is of the affected r outines. | |
226 | V. A. C R O S S R E F E R E N C E R 7.3 | |
227 | [2008 V A Standard s & Conven tions] | |
228 | UC I: VISTA C PU: ROU Jul 26, 2 018@18:27: 46 | |
229 | The BUILD file Data Dictionari es are bei ng process ed. | |
230 | The option and funct ion files are being processed. | |
231 | Routines a re being p rocessed. | |
232 | Routines: 5 Faux Ro utines: 0 | |
233 | PSD84P PSDACT PSDACT1 PSDNBAL PSDOPT | |
234 | --- CROSS REFERENCIN G --- | |
235 | Compiled l ist of Err ors and Wa rnings Jul 26, 20 18@18:27:4 6 page 1 | |
236 | No errors or warning s to repor t | |
237 | --- END -- - | |
238 | Source Cod e Changes | |
239 | This appen dix displa ys the Vis tA code be fore and a fter the u pdates req uired for this code modificati on were im plemented. The follo wing routi nes were a ffected: | |
240 | Modified r outines: P SDACT, PSD ACT1, PSDO PT | |
241 | New routin es: PSDNBA L, PSD84P | |
242 | PSDACT | |
243 | Before: | |
244 | PSDACT ;BI R/BJW-Prin t Daily Ac tivity Log ; 3 Feb 9 8 | |
245 | ;;3.0; CO NTROLLED S UBSTANCES ;**8**;13 Feb 97 | |
246 | ;**Y2K co mpliance** ,"P" added to date i nput strin g | |
247 | I '$D(PSD SITE) D ^P SDSET Q:'$ D(PSDSITE) | |
248 | I '$D(^XU SEC("PSJ R PHARM",DUZ ))&('$D(^X USEC("PSD TECH",DUZ) )) W !!,"C ontact you r Pharmacy Coordinat or for acc ess to dis play the d aily CS ac tivity.",! !,"PSJ RPH ARM or PSD TECH secu rity key r equired.", ! Q | |
249 | ASKD ;ask disp locat ion | |
250 | S PSDS=$P (PSDSITE,U ,3),PSDSN= $P(PSDSITE ,U,4) | |
251 | G:$P(PSDS ITE,U,5) C HKD | |
252 | K DIC,DA S DIC=58.8 ,DIC(0)="Q EAZ",DIC(" S")="I $P( ^(0),""^"" ,3)=+PSDSI TE,$S($P(^ (0),""^"", 2)[""M"":1 ,$P(^(0)," "^"",2)["" S"":1,1:0) " | |
253 | S DIC("A" )="Select Primary Di spensing S ite: " | |
254 | S DIC("B" )=$P(PSDSI TE,U,4) | |
255 | D ^DIC K DIC G:Y<0 END | |
256 | S PSDS=+Y ,PSDSN=$P( Y,"^",2),$ P(PSDSITE, U,3)=+Y,$P (PSDSITE,U ,4)=PSDSN | |
257 | CHKD I '$O (^PSD(58.8 ,PSDS,1,0) ) W !!,"Th ere are no CS stocke d drugs fo r your dis pensing va ult.",!! G END | |
258 | DRUG ;ask drug | |
259 | W !!,?5," You may se lect a sin gle drug, several dr ugs,",!,?5 ,"or enter ^ALL to s elect all drugs.",!! | |
260 | W ! K DA, DIC | |
261 | F S DIC( "W")="W:$P (^PSDRUG(Y ,0),""^"", 9) "" N/F" " I $P(^PS D(58.8,PSD S,1,Y,0)," "^"",14)]" """,$P(^(0 ),""^"",14 )'>DT W $C (7),"" *** INACTIVE ***""",DA( 1)=+PSDS,D IC(0)="QEA M",DIC="^P SD(58.8,"_ PSDS_",1," D ^DIC K DIC Q:Y<0 D | |
262 | .S PSDRG( +Y)="" | |
263 | I '$D(PSD RG)&(X'="^ ALL") G EN D | |
264 | I X="^ALL " S ALL=1 | |
265 | DATE W ! K %DT S %DT ="AEPTX",% DT("A")="S tart with Date: " D ^%DT I Y<0 G END | |
266 | S PSDSD=Y D D^DIQ S PSDATE=Y, %DT("A")=" End with D ate: " D ^ %DT I Y<0 G END | |
267 | I Y<PSDSD W !!,"The ending da te of the range must be later than the s tarting da te." G DAT E | |
268 | S PSDED=Y D D^DIQ S PSDATE=PS DATE_"^"_Y ,PSDSD=PSD SD-.00001 | |
269 | S:'$P(PSD ED,".",2) PSDED=PSDE D+.99999 | |
270 | W !!,"Thi s report i s designed for a 132 column fo rmat.",!," You may qu eue this r eport to p rint at a later time .",!! | |
271 | DEV ;sel d evice | |
272 | S Y=$P($G (^PSD(58.8 ,+PSDS,2)) ,"^",9),C= $P(^DD(58. 8,24,0),"^ ",2) D Y^D IQ S PSDEV =Y | |
273 | W ! K %ZI S,IOP,IO(" Q"),POP S %ZIS="QM", %ZIS("B")= PSDEV D ^% ZIS I POP W !!,"NO D EVICE SELE CTED OR RE PORT PRINT ED!!",! G END | |
274 | I $D(IO(" Q")) K IO( "Q"),ZTIO, ZTSAVE,ZTD TH,ZTSK S PSDIO=ION, ZTIO="",ZT RTN="START ^PSDACT1", ZTDESC="CS PHARM Com pile Daily Activity Log" D SAV E,^%ZTLOAD ,HOME^%ZIS K ZTSK G END | |
275 | U IO G ST ART^PSDACT 1 | |
276 | END ; | |
277 | D KVAR^VA DPT | |
278 | K %,%DT,% H,%I,%ZIS, ACT,ALL,BF WD,C,DA,DA TE,DIC,DIR ,DIROUT,DI RUT,DTOUT, DUOUT,LN,M FG,NAOU,NO DE,NQTY,NU M | |
279 | K PAT,PG, PHARM,POP, PSD,PSDA,P SDATE,PSDE D,PSDEV,PS DIO,PSDOUT ,PSDPN,PSD R,PSDRG,PS DRGN,PSDS, PSDSD,PSDS N,PSDUZ,PS DUZN,RX,TE XT,TYP,QTY ,TYPE,X,Y, VA("BID"), VA("PID") | |
280 | K ^TMP("P SDACT",$J) ,ZTDESC,ZT DTH,ZTIO,Z TRTN,ZTSAV E,ZTSK | |
281 | D ^%ZISC S:$D(ZTQUE UED) ZTREQ ="@" | |
282 | Q | |
283 | SAVE ;sets variables for queue ing | |
284 | S (ZTSAVE ("PSDS"),Z TSAVE("PSD SN"),ZTSAV E("PSDSD") ,ZTSAVE("P SDED"),ZTS AVE("PSDAT E"),ZTSAVE ("PSDIO")) ="" | |
285 | S:$D(ALL) ZTSAVE("A LL")="" S: $D(PSDRG) ZTSAVE("PS DRG(")="" | |
286 | Q | |
287 | Q | |
288 | After: | |
289 | PSDACT ;BI R/BJW-Prin t Daily Ac tivity Log ; 3 Feb 9 8 | |
290 | ;;3.0;CON TROLLED SU BSTANCES ; **8,84**;1 3 Feb 97;B UILD 1 | |
291 | ;**Y2K co mpliance** ,"P" added to date i nput strin g | |
292 | I '$D(PSD SITE) D ^P SDSET Q:'$ D(PSDSITE) | |
293 | I '$D(^XU SEC("PSJ R PHARM",DUZ ))&('$D(^X USEC("PSD TECH",DUZ) )) W !!,"C ontact you r Pharmacy Coordinat or for acc ess to dis play the d aily CS ac tivity.",! !,"PSJ RPH ARM or PSD TECH secu rity key r equired.", ! Q | |
294 | ASKD ;ask disp locat ion | |
295 | S PSDS=$P (PSDSITE,U ,3),PSDSN= $P(PSDSITE ,U,4) | |
296 | G:$P(PSDS ITE,U,5) C HKD | |
297 | K DIC,DA S DIC=58.8 ,DIC(0)="Q EAZ",DIC(" S")="I $P( ^(0),""^"" ,3)=+PSDSI TE,$S($P(^ (0),""^"", 2)[""M"":1 ,$P(^(0)," "^"",2)["" S"":1,1:0) " | |
298 | S DIC("A" )="Select Primary Di spensing S ite: " | |
299 | S DIC("B" )=$P(PSDSI TE,U,4) | |
300 | D ^DIC K DIC G:Y<0 END | |
301 | S PSDS=+Y ,PSDSN=$P( Y,"^",2),$ P(PSDSITE, U,3)=+Y,$P (PSDSITE,U ,4)=PSDSN | |
302 | CHKD I '$O (^PSD(58.8 ,PSDS,1,0) ) W !!,"Th ere are no CS stocke d drugs fo r your dis pensing va ult.",!! G END | |
303 | DRUG ;ask drug | |
304 | W !!,?5," You may se lect a sin gle drug, several dr ugs,",!,?5 ,"or enter ^ALL to s elect all drugs.",!! | |
305 | W ?5,"You may also enter ^ALL CII DRUGS to select all",!,?5 ,"schedule 2 control led substa nces.",!! ;rtw NSR 2 0171111 | |
306 | W ! K DA, DIC | |
307 | F S DIC( "W")="W:$P (^PSDRUG(Y ,0),""^"", 9) "" N/F" " I $P(^PS D(58.8,PSD S,1,Y,0)," "^"",14)]" """,$P(^(0 ),""^"",14 )'>DT W $C (7),"" *** INACTIVE ***""",DA( 1)=+PSDS,D IC(0)="QEA M",DIC="^P SD(58.8,"_ PSDS_",1," D ^DIC K DIC Q:Y<0 D | |
308 | .S PSDRG( +Y)="" | |
309 | ;I '$D(PS DRG)&(X'=" ^ALL") G E ND ;rtw re m'd NSR201 71111 | |
310 | I '$D(PSD RG)&(X'="^ ALL")&(X'= "^ALL CII DRUGS") G END ;rtw r eplacement NSR201711 11 | |
311 | N PSDALL | |
312 | I X="^ALL " S ALL=1 | |
313 | I X="^ALL CII DRUGS " S PSDALL =1 ;;rtw a dd NSR2017 1111 | |
314 | DATE W ! K %DT S %DT ="AEPTX",% DT("A")="S tart with Date: " D ^%DT I Y<0 G END | |
315 | S PSDSD=Y D D^DIQ S PSDATE=Y, %DT("A")=" End with D ate: " D ^ %DT I Y<0 G END | |
316 | I Y<PSDSD W !!,"The ending da te of the range must be later than the s tarting da te." G DAT E | |
317 | S PSDED=Y D D^DIQ S PSDATE=PS DATE_"^"_Y ,PSDSD=PSD SD-.00001 | |
318 | S:'$P(PSD ED,".",2) PSDED=PSDE D+.99999 | |
319 | W !!,"Thi s report i s designed for a 132 column fo rmat.",!," You may qu eue this r eport to p rint at a later time .",!! | |
320 | DEV ;sel d evice | |
321 | S Y=$P($G (^PSD(58.8 ,+PSDS,2)) ,"^",9),C= $P(^DD(58. 8,24,0),"^ ",2) D Y^D IQ S PSDEV =Y | |
322 | W ! K %ZI S,IOP,IO(" Q"),POP S %ZIS="QM", %ZIS("B")= PSDEV D ^% ZIS I POP W !!,"NO D EVICE SELE CTED OR RE PORT PRINT ED!!",! G END | |
323 | I $D(IO(" Q")) K IO( "Q"),ZTIO, ZTSAVE,ZTD TH,ZTSK S PSDIO=ION, ZTIO="",ZT RTN="START ^PSDACT1", ZTDESC="CS PHARM Com pile Daily Activity Log" D SAV E,^%ZTLOAD ,HOME^%ZIS K ZTSK G END | |
324 | U IO G ST ART^PSDACT 1 | |
325 | END ; | |
326 | D KVAR^VA DPT | |
327 | K %,%DT,% H,%I,%ZIS, ACT,ALL,BF WD,C,DA,DA TE,DIC,DIR ,DIROUT,DI RUT,DTOUT, DUOUT,LN,M FG,NAOU,NO DE,NQTY,NU M | |
328 | K PAT,PG, PHARM,POP, PSD,PSDA,P SDATE,PSDE D,PSDEV,PS DIO,PSDOUT ,PSDPN,PSD R,PSDRG,PS DRGN,PSDS, PSDSD,PSDS N,PSDUZ,PS DUZN,RX,TE XT,TYP,QTY ,TYPE,X,Y, VA("BID"), VA("PID") | |
329 | K ^TMP("P SDACT",$J) ,ZTDESC,ZT DTH,ZTIO,Z TRTN,ZTSAV E,ZTSK | |
330 | D ^%ZISC S:$D(ZTQUE UED) ZTREQ ="@" | |
331 | Q | |
332 | SAVE ;sets variables for queue ing | |
333 | S (ZTSAVE ("PSDS"),Z TSAVE("PSD SN"),ZTSAV E("PSDSD") ,ZTSAVE("P SDED"),ZTS AVE("PSDAT E"),ZTSAVE ("PSDIO")) ="" | |
334 | S:$D(ALL) ZTSAVE("A LL")="" S: $D(PSDRG) ZTSAVE("PS DRG(")="" | |
335 | S:$D(PSDA LL) ZTSAVE ("PSDALL") ="" ;rtw a dd NSR2017 1111 | |
336 | Q | |
337 | PSDACT1 | |
338 | Before: | |
339 | PSDACT1 ;B IR/JPW,BJW -Print Dai ly Activit y Log (con t'd) ; 17 Jun 98 | |
340 | ;;3.0; CO NTROLLED S UBSTANCES ;**10,14,3 0,65**;13 Feb 97;Bui ld 5 | |
341 | ;Referenc e to ^PRC( 442 suppor ted by IA #682 | |
342 | ;Referenc e to ^PRCS (410 suppo rted by IA #198 | |
343 | ;Referenc e to ^PSDR UG( suppor ted by IA #221 | |
344 | ;Referenc e to ^PSRX ( supporte d by IA #9 86 | |
345 | ;Referenc e to ^DD(5 8.81 suppo rted by IA #10154 | |
346 | ;Referenc e to PSD(5 8.8 suppor ted by DBI A # 2711 | |
347 | ;Referenc e to PSD(5 8.81 suppo rted by DB IA # 2808 | |
348 | ;Referenc es to PSD( 58.84 supp orted by I A # 3485 | |
349 | ;modified for nois: tua-0498-3 2173,new c ode added to t6 | |
350 | ;op v.7 c hg the sta tus loc in file 52 | |
351 | START ;ent ry for com pile | |
352 | K ^TMP("P SDACT",$J) | |
353 | I $D(ALL) F PSDR=0: 0 S PSDR=$ O(^PSD(58. 8,+PSDS,1, PSDR)) Q:' PSDR I $D (^PSD(58.8 ,+PSDS,1,P SDR,0)) S PSDRG(+PSD R)="" | |
354 | F PSD=PSD SD:0 S PSD =$O(^PSD(5 8.81,"ACT" ,PSD)) Q:' PSD!(PSD>P SDED) F PS DR=0:0 S P SDR=$O(^PS D(58.81,"A CT",PSD,PS DS,PSDR)) Q:'PSDR D | |
355 | .Q:'$D(PS DRG(PSDR)) | |
356 | .F TYP=0: 0 S TYP=$O (^PSD(58.8 1,"ACT",PS D,PSDS,PSD R,TYP)) Q: 'TYP!(TYP= 12) F PSDA =0:0 S PSD A=$O(^PSD( 58.81,"ACT ",PSD,PSDS ,PSDR,TYP, PSDA)) Q:' PSDA D SE T | |
357 | G:$D(ZTQU EUED) PRTQ UE G PRINT ^PSDACT2 | |
358 | END ; | |
359 | D KVAR^VA DPT | |
360 | K %,%DT,% H,%I,%ZIS, ACT,ALL,BF WD,C,DA,DA TE,DIC,DIR ,DIROUT,DI RUT,DTOUT, DUOUT,LN,M FG,NAOU,NO DE,NQTY,NU M | |
361 | K PAT,PG, PHARM,POP, PSD,PSDA,P SDATE,PSDE D,PSDEV,PS DIO,PSDOUT ,PSDPN,PSD R,PSDRG,PS DRGN,PSDS, PSDSD,PSDS N,PSDUZ,PS DUZN,RX,TE XT,TYP,QTY ,TYPE,X,Y, VA("BID"), VA("PID") | |
362 | K ^TMP("P SDACT",$J) ,ZTDESC,ZT DTH,ZTIO,Z TRTN,ZTSAV E,ZTSK | |
363 | D ^%ZISC S:$D(ZTQUE UED) ZTREQ ="@" | |
364 | Q | |
365 | SET ;sets data | |
366 | ;Dave B ( PSD*3*14) Disregard if type is 15. | |
367 | Q:'$D(^PS D(58.81,PS DA,0)) Q:T YP=5 Q:TYP =15 S NODE =^(0),QTY= $P(NODE,"^ ",6),BFWD= $P(NODE,"^ ",10) | |
368 | S PSDRGN= $S($P($G(^ PSDRUG(PSD R,0)),"^") ]"":$P(^(0 ),"^"),1:" ZZ/"_PSDR_ " NAME MIS SING") | |
369 | S PSDUZ=$ S(TYP=3:+$ P($G(^PSD( 58.81,PSDA ,1)),"^",1 4),TYP=4:+ $P($G(^PSD (58.81,PSD A,1)),"^", 14),TYP=13 :+$P($G(^P SD(58.81,P SDA,5)),"^ ",2),TYP=1 4:+$P($G(^ PSD(58.81, PSDA,4))," ^",2),1:+$ P(NODE,"^" ,7)) | |
370 | S:TYP=2 P SDUZ=$S(+$ P($G(^PSD( 58.81,PSDA ,1)),"^"): +$P($G(^(1 )),"^"),1: +$P(NODE," ^",7)) | |
371 | S PSDUZN= $P($G(^VA( 200,+PSDUZ ,0)),"^"), PSDUZN=$S( PSDUZN]"": $E($P(PSDU ZN,",",2)) _$E(PSDUZN ),1:"**") | |
372 | I TYP=1 D T1 G TMP | |
373 | I TYP=2 D T2 G TMP | |
374 | I TYP=3 Q :'$D(^PSD( 58.81,PSDA ,3)) D T3 G TMP | |
375 | Q:TYP=4 | |
376 | I TYP=6 Q :'$D(^PSD( 58.81,PSDA ,6)) D T6 G TMP | |
377 | I TYP=7 D T7 G TMP | |
378 | I TYP=9 D T9 G TMP | |
379 | I TYP=11 D T11 G TM P | |
380 | I TYP=13 Q:'$D(^PSD (58.81,PSD A,5)) D T1 3 G TMP | |
381 | I TYP=14 Q:'$D(^PSD (58.81,PSD A,4)) D T1 4 G TMP | |
382 | I TYP=16 D T16 G TM P | |
383 | I TYP>18 D TOTH | |
384 | TMP ; | |
385 | S PSDUZN= $P($G(^VA( 200,+PSDUZ ,0)),"^"), PSDUZN=$S( PSDUZN]"": $E($P(PSDU ZN,",",2)) _$E(PSDUZN ),1:"**") | |
386 | ;PSD*3*30 (Dave B - Identify person wit h more tha n just **) | |
387 | I $G(PSDU ZN)="**" S PSDUZ=$P( $G(^PSD(58 .81,PSDA,0 )),"^",7), PSDUZN=$P( $G(^VA(200 ,+PSDUZ,0) ),"^"),PSD UZN=$S(PSD UZN]"":$E( $P(PSDUZN, ",",2))_$E (PSDUZN),1 :"**") | |
388 | S ^TMP("P SDACT",$J, PSDRGN,PSD ,TYP,PSDA) =BFWD_"^"_ NUM_"^"_TE XT_"^"_QTY _"^"_PSDUZ N I $D(PSD RTS) S ^TM P("PSDACT" ,$J,PSDRGN ,PSD,TYP,P SDA)=^TMP( "PSDACT",$ J,PSDRGN,P SD,TYP,PSD A)_"^1" | |
389 | K PSDRTS Q | |
390 | T1 S NUM=" ***",TEXT= "RECEIPT I NTO PHARMA CY" | |
391 | I $P($G(^ PSD(58.81, PSDA,8))," ^")]"" S N UM=$P($G(^ PSD(58.81, PSDA,8))," ^") Q | |
392 | I +$P(NOD E,"^",9) S NUM=+$P(N ODE,"^",9) ,NUM=$P($G (^PRC(442, NUM,0)),"^ ") Q | |
393 | I +$P(NOD E,"^",8) S NUM=+$P(N ODE,"^",8) ,NUM=$P($G (^PRCS(410 ,NUM,0))," ^") Q | |
394 | Q | |
395 | T2 S QTY=- QTY,NUM="D ISP",NAOU= +$P(NODE," ^",18) S:N AOU NAOU=$ P($G(^PSD( 58.8,+NAOU ,0)),"^") S TEXT=$S( NAOU]"":NA OU,1:"DISP ENSED FROM PHARMACY" ) | |
396 | I +$P(NOD E,"^",17) S NUM="GS # "_$P(NOD E,"^",17) | |
397 | Q | |
398 | T3 S NUM=" GS # ",TEX T="RETURNE D TO STOCK " | |
399 | I +$P(NOD E,"^",17) S NUM=NUM_ $P(NODE,"^ ",17) | |
400 | ;PSD*3*30 (Dave B - more prec ise infor on RTS) | |
401 | I $G(NUM) ="GS # " D | |
402 | .S RX=$P( $G(^PSD(58 .81,PSDA,6 )),"^"),RX NUM=$P($G( ^PSD(58.81 ,PSDA,6)), "^",5) | |
403 | .S PAT=$P ($G(^PSRX( RX,0)),"^" ,2) I PAT S DFN=PAT D PID^VADP T6 S Y=PAT ,C=$P(^DD( 58.81,73,0 ),"^",2) D Y^DIQ S T EXT=Y_"("_ VA("BID")_ ")" K DFN, VA("BID"), VA("PID") | |
404 | .S NUM="R X # "_$G(R XNUM)_" (" _$S($P($G( ^PSD(58.81 ,PSDA,6)), U,2):"R"_$ P($G(^(6)) ,U,2),$P($ G(^(6)),U, 4):"P"_$P( $G(^(6)),U ,4),1:"O") _")" | |
405 | .S QTY=$P (^PSD(58.8 1,PSDA,3), "^",2),BFW D=$P(^PSD( 58.81,PSDA ,0),"^",10 ),PSDRTS=1 Q | |
406 | I $G(PSDR TS)=1 Q | |
407 | S QTY=$P( ^PSD(58.81 ,PSDA,3)," ^",2),BFWD =$P(^(3)," ^",7) | |
408 | Q | |
409 | T6 S QTY=- QTY,NUM="R X # ",TEXT ="OUTPATIE NT RX" N R XNUM | |
410 | S RX=+$P( ^PSD(58.81 ,PSDA,6)," ^"),RXNUM= $S($P(^(6) ,"^",5)]"" :$P(^(6)," ^",5),$P($ G(^PSRX(RX ,0)),"^")] "":$P(^(0) ,"^"),1:"U NKNOWN"),N UM=NUM_RXN UM | |
411 | S NUM=NUM _" ("_$S($ P($G(^PSD( 58.81,PSDA ,6)),U,2): "R"_$P($G( ^(6)),U,2) ,$P($G(^(6 )),U,4):"P "_$P($G(^( 6)),U,4),1 :"O")_")" | |
412 | S PAT=+$P ($G(^PSRX( RX,0)),"^" ,2) | |
413 | S PSDRXIN =RX D VER^ PSDOPT | |
414 | ;W !,TEXT ," ",RXNUM | |
415 | S TEXT=$S ('$O(^PSRX ("B",RXNUM ,0)):"RX D ELETED",$G (PSDSTA)=1 3:"RX DELE TED",1:"UN KNOWN") | |
416 | ;W !,TEXT | |
417 | K PSDSTA, PSOVR,PSDR XIN | |
418 | I PAT S D FN=PAT D P ID^VADPT6 D | |
419 | .K C S Y= PAT,C=$P(^ DD(58.81,7 3,0),"^",2 ) D Y^DIQ S TEXT=Y_" ("_VA("BI D")_")" K DFN,VA("BI D"),VA("PI D") | |
420 | Q | |
421 | T7 S NUM=" GS # ",TEX T="CANCEL UNVERIFIED ORDER",QT Y=0 | |
422 | I +$P(NOD E,"^",17) S NUM=NUM_ $P(NODE,"^ ",17) | |
423 | Q | |
424 | T9 S NUM=" ADJ",TEXT= $S($D(^PSD (58.81,+PS DA,9)):$P( NODE,"^",1 6),1:"ADJU STMENT") | |
425 | I $P(NODE ,"^",16)]" " S TEXT=$ P(NODE,"^" ,16) | |
426 | I $D(^PSD (58.81,PSD A,3)) S NU M="DEST # "_$P(^(3), "^",8),TEX T="HOLDING FOR DESTR UCTION" | |
427 | Q | |
428 | T11 S NUM= "***",TEXT ="INITIALI ZE BALANCE AT SETUP" | |
429 | Q | |
430 | T13 S NUM= "GS # ",TE XT="CANCEL VERIFIED ORDER" | |
431 | I +$P(NOD E,"^",17) S NUM=NUM_ $P(NODE,"^ ",17) | |
432 | S QTY=$P( ^PSD(58.81 ,PSDA,5)," ^",3),BFWD =$P(^(5)," ^",5) | |
433 | Q | |
434 | T14 S NUM= "GS # ",TE XT="EDIT V ERIFIED OR DER" | |
435 | I +$P(NOD E,"^",17) S NUM=NUM_ $P(NODE,"^ ",17) | |
436 | S:$D(^PSD (58.81,PSD A,8)) TEXT ="EDIT VER IFIED INVO ICE",NUM=$ P(^PSD(58. 81,PSDA,8) ,"^",1) ; <*65-RJS> | |
437 | S QTY=$P( ^PSD(58.81 ,PSDA,4)," ^",4),BFWD =$P(^(4)," ^",7) | |
438 | Q | |
439 | T16 S NUM= "TRV",TEXT ="TRANSFER TO VAULT" | |
440 | Q | |
441 | TOTH ;Type = 19,20,2 1,22 | |
442 | S NUM="IN V",TEXT=$G (^PSD(58.8 4,+TYP,0)) ,QTY="" | |
443 | Q | |
444 | PRTQUE ;qu eues print after com pile | |
445 | K ZTSAVE, ZTIO S ZTI O=PSDIO,ZT RTN="PRINT ^PSDACT2", ZTDESC="CS PHARM Pri nt Daily A ctivity Lo g",ZTDTH=$ H,ZTSAVE(" ^TMP(""PSD ACT"",$J," )="",ZTSAV E("PSDSN") ="",ZTSAVE ("PSDATE") ="" | |
446 | D ^%ZTLOA D K ZTSK G END | |
447 | After: | |
448 | PSDACT1 ;B IR/JPW,BJW -Print Dai ly Activit y Log (con t'd) ; 17 Jun 98 | |
449 | ;;3.0;CON TROLLED SU BSTANCES ; **10,14,30 ,65,84**;1 3 Feb 97;B uild 5 | |
450 | ;Referenc e to ^PRC( 442 suppor ted by IA #682 | |
451 | ;Referenc e to ^PRCS (410 suppo rted by IA #198 | |
452 | ;Referenc e to ^PSDR UG( suppor ted by IA #221 | |
453 | ;Referenc e to ^PSRX ( supporte d by IA #9 86 | |
454 | ;Referenc e to ^DD(5 8.81 suppo rted by IA #10154 | |
455 | ;Referenc e to PSD(5 8.8 suppor ted by DBI A # 2711 | |
456 | ;Referenc e to PSD(5 8.81 suppo rted by DB IA # 2808 | |
457 | ;Referenc es to PSD( 58.84 supp orted by I A # 3485 | |
458 | ;modified for nois: tua-0498-3 2173,new c ode added to t6 | |
459 | ;op v.7 c hg the sta tus loc in file 52 | |
460 | START ;ent ry for com pile | |
461 | K ^TMP("P SDACT",$J) | |
462 | I $D(ALL) F PSDR=0: 0 S PSDR=$ O(^PSD(58. 8,+PSDS,1, PSDR)) Q:' PSDR I $D (^PSD(58.8 ,+PSDS,1,P SDR,0)) S PSDRG(+PSD R)="" | |
463 | I $D(PSDA LL) F PSDR =0:0 S PSD R=$O(^PSD( 58.8,+PSDS ,1,PSDR)) Q:'PSDR D ;rtw add ed NSR2017 1111 | |
464 | . I $D(^P SD(58.8,+P SDS,1,PSDR ,0)) I $P( ^PSDRUG(+P SDR,0),U,3 )["2" S PS DRG(+PSDR) ="" ;rtw a dded NSR20 171111 | |
465 | F PSD=PSD SD:0 S PSD =$O(^PSD(5 8.81,"ACT" ,PSD)) Q:' PSD!(PSD>P SDED) F PS DR=0:0 S P SDR=$O(^PS D(58.81,"A CT",PSD,PS DS,PSDR)) Q:'PSDR D | |
466 | .Q:'$D(PS DRG(PSDR)) | |
467 | .F TYP=0: 0 S TYP=$O (^PSD(58.8 1,"ACT",PS D,PSDS,PSD R,TYP)) Q: 'TYP!(TYP= 12) F PSDA =0:0 S PSD A=$O(^PSD( 58.81,"ACT ",PSD,PSDS ,PSDR,TYP, PSDA)) Q:' PSDA D SE T | |
468 | G:$D(ZTQU EUED) PRTQ UE G PRINT ^PSDACT2 | |
469 | END ; | |
470 | D KVAR^VA DPT | |
471 | K %,%DT,% H,%I,%ZIS, ACT,ALL,BF WD,C,DA,DA TE,DIC,DIR ,DIROUT,DI RUT,DTOUT, DUOUT,LN,M FG,NAOU,NO DE,NQTY,NU M | |
472 | K PAT,PG, PHARM,POP, PSD,PSDA,P SDATE,PSDE D,PSDEV,PS DIO,PSDOUT ,PSDPN,PSD R,PSDRG,PS DRGN,PSDS, PSDSD,PSDS N,PSDUZ,PS DUZN,RX,TE XT,TYP,QTY ,TYPE,X,Y, VA("BID"), VA("PID") | |
473 | K ^TMP("P SDACT",$J) ,ZTDESC,ZT DTH,ZTIO,Z TRTN,ZTSAV E,ZTSK | |
474 | K PSDALL ;rtw added NSR201711 11 | |
475 | D ^%ZISC S:$D(ZTQUE UED) ZTREQ ="@" | |
476 | Q | |
477 | SET ;sets data | |
478 | ;Dave B ( PSD*3*14) Disregard if type is 15. | |
479 | Q:'$D(^PS D(58.81,PS DA,0)) Q:T YP=5 Q:TYP =15 S NODE =^(0),QTY= $P(NODE,"^ ",6),BFWD= $P(NODE,"^ ",10) | |
480 | S PSDRGN= $S($P($G(^ PSDRUG(PSD R,0)),"^") ]"":$P(^(0 ),"^"),1:" ZZ/"_PSDR_ " NAME MIS SING") | |
481 | S PSDUZ=$ S(TYP=3:+$ P($G(^PSD( 58.81,PSDA ,1)),"^",1 4),TYP=4:+ $P($G(^PSD (58.81,PSD A,1)),"^", 14),TYP=13 :+$P($G(^P SD(58.81,P SDA,5)),"^ ",2),TYP=1 4:+$P($G(^ PSD(58.81, PSDA,4))," ^",2),1:+$ P(NODE,"^" ,7)) | |
482 | S:TYP=2 P SDUZ=$S(+$ P($G(^PSD( 58.81,PSDA ,1)),"^"): +$P($G(^(1 )),"^"),1: +$P(NODE," ^",7)) | |
483 | S PSDUZN= $P($G(^VA( 200,+PSDUZ ,0)),"^"), PSDUZN=$S( PSDUZN]"": $E($P(PSDU ZN,",",2)) _$E(PSDUZN ),1:"**") | |
484 | I TYP=1 D T1 G TMP | |
485 | I TYP=2 D T2 G TMP | |
486 | I TYP=3 Q :'$D(^PSD( 58.81,PSDA ,3)) D T3 G TMP | |
487 | Q:TYP=4 | |
488 | I TYP=6 Q :'$D(^PSD( 58.81,PSDA ,6)) D T6 G TMP | |
489 | I TYP=7 D T7 G TMP | |
490 | I TYP=9 D T9 G TMP | |
491 | I TYP=11 D T11 G TM P | |
492 | I TYP=13 Q:'$D(^PSD (58.81,PSD A,5)) D T1 3 G TMP | |
493 | I TYP=14 Q:'$D(^PSD (58.81,PSD A,4)) D T1 4 G TMP | |
494 | I TYP=16 D T16 G TM P | |
495 | I TYP>18 D TOTH | |
496 | TMP ; | |
497 | S PSDUZN= $P($G(^VA( 200,+PSDUZ ,0)),"^"), PSDUZN=$S( PSDUZN]"": $E($P(PSDU ZN,",",2)) _$E(PSDUZN ),1:"**") | |
498 | ;PSD*3*30 (Dave B - Identify person wit h more tha n just **) | |
499 | I $G(PSDU ZN)="**" S PSDUZ=$P( $G(^PSD(58 .81,PSDA,0 )),"^",7), PSDUZN=$P( $G(^VA(200 ,+PSDUZ,0) ),"^"),PSD UZN=$S(PSD UZN]"":$E( $P(PSDUZN, ",",2))_$E (PSDUZN),1 :"**") | |
500 | S ^TMP("P SDACT",$J, PSDRGN,PSD ,TYP,PSDA) =BFWD_"^"_ NUM_"^"_TE XT_"^"_QTY _"^"_PSDUZ N I $D(PSD RTS) S ^TM P("PSDACT" ,$J,PSDRGN ,PSD,TYP,P SDA)=^TMP( "PSDACT",$ J,PSDRGN,P SD,TYP,PSD A)_"^1" | |
501 | K PSDRTS Q | |
502 | T1 S NUM=" ***",TEXT= "RECEIPT I NTO PHARMA CY" | |
503 | I $P($G(^ PSD(58.81, PSDA,8))," ^")]"" S N UM=$P($G(^ PSD(58.81, PSDA,8))," ^") Q | |
504 | I +$P(NOD E,"^",9) S NUM=+$P(N ODE,"^",9) ,NUM=$P($G (^PRC(442, NUM,0)),"^ ") Q | |
505 | I +$P(NOD E,"^",8) S NUM=+$P(N ODE,"^",8) ,NUM=$P($G (^PRCS(410 ,NUM,0))," ^") Q | |
506 | Q | |
507 | T2 S QTY=- QTY,NUM="D ISP",NAOU= +$P(NODE," ^",18) S:N AOU NAOU=$ P($G(^PSD( 58.8,+NAOU ,0)),"^") S TEXT=$S( NAOU]"":NA OU,1:"DISP ENSED FROM PHARMACY" ) | |
508 | I +$P(NOD E,"^",17) S NUM="GS # "_$P(NOD E,"^",17) | |
509 | Q | |
510 | T3 S NUM=" GS # ",TEX T="RETURNE D TO STOCK " | |
511 | I +$P(NOD E,"^",17) S NUM=NUM_ $P(NODE,"^ ",17) | |
512 | ;PSD*3*30 (Dave B - more prec ise infor on RTS) | |
513 | I $G(NUM) ="GS # " D | |
514 | .S RX=$P( $G(^PSD(58 .81,PSDA,6 )),"^"),RX NUM=$P($G( ^PSD(58.81 ,PSDA,6)), "^",5) | |
515 | .S PAT=$P ($G(^PSRX( RX,0)),"^" ,2) I PAT S DFN=PAT D PID^VADP T6 S Y=PAT ,C=$P(^DD( 58.81,73,0 ),"^",2) D Y^DIQ S T EXT=Y_"("_ VA("BID")_ ")" K DFN, VA("BID"), VA("PID") | |
516 | .S NUM="R X # "_$G(R XNUM)_" (" _$S($P($G( ^PSD(58.81 ,PSDA,6)), U,2):"R"_$ P($G(^(6)) ,U,2),$P($ G(^(6)),U, 4):"P"_$P( $G(^(6)),U ,4),1:"O") _")" | |
517 | .S QTY=$P (^PSD(58.8 1,PSDA,3), "^",2),BFW D=$P(^PSD( 58.81,PSDA ,0),"^",10 ),PSDRTS=1 Q | |
518 | I $G(PSDR TS)=1 Q | |
519 | S QTY=$P( ^PSD(58.81 ,PSDA,3)," ^",2),BFWD =$P(^(3)," ^",7) | |
520 | Q | |
521 | T6 S QTY=- QTY,NUM="R X # ",TEXT ="OUTPATIE NT RX" N R XNUM | |
522 | S RX=+$P( ^PSD(58.81 ,PSDA,6)," ^"),RXNUM= $S($P(^(6) ,"^",5)]"" :$P(^(6)," ^",5),$P($ G(^PSRX(RX ,0)),"^")] "":$P(^(0) ,"^"),1:"U NKNOWN"),N UM=NUM_RXN UM | |
523 | S NUM=NUM _" ("_$S($ P($G(^PSD( 58.81,PSDA ,6)),U,2): "R"_$P($G( ^(6)),U,2) ,$P($G(^(6 )),U,4):"P "_$P($G(^( 6)),U,4),1 :"O")_")" | |
524 | S PAT=+$P ($G(^PSRX( RX,0)),"^" ,2) | |
525 | S PSDRXIN =RX D VER^ PSDOPT | |
526 | ;W !,TEXT ," ",RXNUM | |
527 | S TEXT=$S ('$O(^PSRX ("B",RXNUM ,0)):"RX D ELETED",$G (PSDSTA)=1 3:"RX DELE TED",1:"UN KNOWN") | |
528 | ;W !,TEXT | |
529 | K PSDSTA, PSOVR,PSDR XIN | |
530 | I PAT S D FN=PAT D P ID^VADPT6 D | |
531 | .K C S Y= PAT,C=$P(^ DD(58.81,7 3,0),"^",2 ) D Y^DIQ S TEXT=Y_" ("_VA("BI D")_")" K DFN,VA("BI D"),VA("PI D") | |
532 | Q | |
533 | T7 S NUM=" GS # ",TEX T="CANCEL UNVERIFIED ORDER",QT Y=0 | |
534 | I +$P(NOD E,"^",17) S NUM=NUM_ $P(NODE,"^ ",17) | |
535 | Q | |
536 | T9 S NUM=" ADJ",TEXT= $S($D(^PSD (58.81,+PS DA,9)):$P( NODE,"^",1 6),1:"ADJU STMENT") | |
537 | I $P(NODE ,"^",16)]" " S TEXT=$ P(NODE,"^" ,16) | |
538 | I $D(^PSD (58.81,PSD A,3)) S NU M="DEST # "_$P(^(3), "^",8),TEX T="HOLDING FOR DESTR UCTION" | |
539 | Q | |
540 | T11 S NUM= "***",TEXT ="INITIALI ZE BALANCE AT SETUP" | |
541 | Q | |
542 | T13 S NUM= "GS # ",TE XT="CANCEL VERIFIED ORDER" | |
543 | I +$P(NOD E,"^",17) S NUM=NUM_ $P(NODE,"^ ",17) | |
544 | S QTY=$P( ^PSD(58.81 ,PSDA,5)," ^",3),BFWD =$P(^(5)," ^",5) | |
545 | Q | |
546 | T14 S NUM= "GS # ",TE XT="EDIT V ERIFIED OR DER" | |
547 | I +$P(NOD E,"^",17) S NUM=NUM_ $P(NODE,"^ ",17) | |
548 | S:$D(^PSD (58.81,PSD A,8)) TEXT ="EDIT VER IFIED INVO ICE",NUM=$ P(^PSD(58. 81,PSDA,8) ,"^",1) ; <*65-RJS> | |
549 | S QTY=$P( ^PSD(58.81 ,PSDA,4)," ^",4),BFWD =$P(^(4)," ^",7) | |
550 | Q | |
551 | T16 S NUM= "TRV",TEXT ="TRANSFER TO VAULT" | |
552 | Q | |
553 | TOTH ;Type = 19,20,2 1,22 | |
554 | S NUM="IN V",TEXT=$G (^PSD(58.8 4,+TYP,0)) ,QTY="" | |
555 | Q | |
556 | PRTQUE ;qu eues print after com pile | |
557 | K ZTSAVE, ZTIO S ZTI O=PSDIO,ZT RTN="PRINT ^PSDACT2", ZTDESC="CS PHARM Pri nt Daily A ctivity Lo g",ZTDTH=$ H,ZTSAVE(" ^TMP(""PSD ACT"",$J," )="",ZTSAV E("PSDSN") ="",ZTSAVE ("PSDATE") ="" | |
558 | D ^%ZTLOA D K ZTSK G END | |
559 | PSDOPT | |
560 | Before: | |
561 | PSDOPT ;BI R/JPW,LTL, BJW - Outp atient Rx Entry ;2/5 /04 12:15p m | |
562 | ;;3.0;CON TROLLED SU BSTANCES;* *10,11,15, 21,30,39,4 8,62,69,71 ,79**;13 F eb 97;Buil d 20 | |
563 | ;Referenc e to ^PSDR UG( suppor ted by DBI A #221 | |
564 | ;Referenc es to ^PSD (58.8 are covered by DBIA #271 1 | |
565 | ;Referenc es to file 58.81 are covered b y DBIA #28 08 | |
566 | ;Referenc e to PSRX( supported by DBIA # 986 | |
567 | ;Referenc e to PSOFU NC support ed by DBIA #981 | |
568 | ;Line Tag FINAL^PSO LSET suppo rted by DB IA #982 | |
569 | ; | |
570 | ;mod.for nois:tua-0 498-32173, askp,bc1;v er | |
571 | ;enhancem ent for Ou tpat V7 st atus code of 12,13,1 4,15 in as kp | |
572 | ; | |
573 | ;further modificati ons relate d to the d eletion of | |
574 | ;refills made in Ap ril 1999 | |
575 | ; | |
576 | ;PSD*3*39 Kill all variables | |
577 | D PSDKLL^ PSDOPT2 | |
578 | I '$D(PSD SITE) D ^P SDSET Q:'$ D(PSDSITE) | |
579 | I '$D(^XU SEC("PSJ R PHARM",DUZ )),'$D(^XU SEC("PSD T ECH ADV",D UZ)) W !!, "Please co ntact your Pharmacy Coordinato r for acce ss",!,"to log Outpat ient Presc riptions. Either the PSJ RPHAR M",!,"or P SD TECH AD V security key requi red.",!! Q | |
580 | I $P($G(^ VA(200,DUZ ,20)),U,4) ']"" N XQH S XQH="PS D ESIG" D EN^XQH G E ND | |
581 | N X,X1 D SIG^XUSESI G I X1="" G END | |
582 | N LN S (P SDOUT,NEW) =0,PSDUZ=D UZ,$P(LN," -",80)="", Y=DT | |
583 | X ^DD("DD ") S RPDT= Y | |
584 | ASKD ;ask disp site | |
585 | S PSDS=$P (PSDSITE,U ,3),PSDSN= $P(PSDSITE ,U,4) | |
586 | G:$P(PSDS ITE,U,5) C HKD | |
587 | K DIC,DA S DIC=58.8 ,DIC(0)="Q EAZ",DIC(" S")="I $P( ^(0),""^"" ,3)=+PSDSI TE,$S($P(^ (0),""^"", 2)[""M"":1 ,$P(^(0)," "^"",2)["" S"":1,1:0) ,$S('$D(^( ""I"")):1, +^(""I"")> DT:1,'^("" I""):1,1:0 )" | |
588 | S DIC("A" )="Select Primary Di spensing S ite: ",DIC ("B")=$P(P SDSITE,U,4 ) | |
589 | W ! D ^DI C K DIC G: Y<0 END | |
590 | S PSDS=+Y ,PSDSN=$P( Y,"^",2),$ P(PSDSITE, U,3)=+Y,$P (PSDSITE,U ,4)=PSDSN | |
591 | CHKD I '$O (^PSD(58.8 ,PSDS,1,0) ) W !!,"Th ere are no stocked d rugs for t his Pharma cy Vault!! ",!! G END | |
592 | ASKPH ;ask releasing RPH | |
593 | S DIC="^V A(200,",DI C(0)="QEAM ",DIC("S") ="I $D(^XU SEC(""PSOR PH"",+Y))" | |
594 | S DIC("A" )="Please identify P harmacist for Outpat ient Relea se: " | |
595 | S:$D(^XUS EC("PSORPH ",DUZ)) DI C("B")=$P( $G(^VA(200 ,DUZ,0)),U ) | |
596 | W ! D ^DI C K DIC G: Y<1 END S PSDRPH=+Y | |
597 | ASKP ;ask rx # | |
598 | K PSDSEL, PSDPOST,PS DREL | |
599 | ;PSD*3*30 (Dave Blo cker ) Loc k the scri pt node | |
600 | I $G(PSDR X)'="" L - ^PSRX(PSDR X) | |
601 | W ! K DIR ,NEW,PSDRX ,PSDRXIN,R XNUM S PSD OUT=0 S DI R("A")="En ter/Wand P RESCRIPTIO N number" | |
602 | S DIR("?" )="^D HELP ^PSODISP", DIR(0)="F^ 1:35" D ^D IR K DIR | |
603 | G:$D(DTOU T)!($D(DUO UT)) END G :X="" ASKP H | |
604 | S X=$$UP^ XLFSTR(X) | |
605 | I X'["-" D S PSDRX =$G(PSDRXI N) | |
606 | .S PSDRX= 0 F S PSD RX=$O(^PSR X("B",X,PS DRX)) Q:'P SDRX S PS DRXIN=PSDR X D VER | |
607 | I X'["-", '$G(PSDRX) !('$D(^PSR X(+$G(PSDR X),0))) W !,"INVALID PRESCRIPT ION NUMBER " G ASKP | |
608 | ; | |
609 | ;PSD*3*30 - lock th e script | |
610 | I X'["-" L +^PSRX(P SDRX):5 I '$T W !!," Sorry, som eone else is editing this pres cription. Please try again lat er." K PSD RX G ASKP | |
611 | ; | |
612 | ;DAVE B ( PSD*3*15) Show previ ous postin gs | |
613 | I X'["-" I $G(PSOVR )=1,$G(PSD STA)=12!($ G(PSDSTA)= 13)!($G(PS DSTA)=14)! ($G(PSDSTA )=15)!($G( PSDSTA)=11 ) S PSDXXX =X D CHKRF I $G(PSDN EXT)=1 G A SKP | |
614 | ;<JD *62 | |
615 | ; | |
616 | S PSD(1)= X,DIC="^DI C(4,",DR=9 9,DA=+$P($ G(^XMB(1,1 ,"XUS")),U ,17) | |
617 | K DIQ S D IQ="PSD" D EN^DIQ1 S X=PSD(1) K DIC,DR,D IQ | |
618 | I X["-",$ P(X,"-")'= PSD(4,DA,9 9) K DA,PS D W !?7,$C (7)," INVA LID STATIO N NUMBER ! !",! G ASK P | |
619 | K DA,PSD | |
620 | I X["-" S PSDRX=$P( X,"-",2) I (PSDRX'?1 N.N.1U) W !?7,$C(7), " INVALID PRESCRIPTI ON NUMBER" G ASKP | |
621 | I X["-" I '$D(^PSRX (+$G(PSDRX ),0))!($G( PSDRX)']"" ) W !?7,$C (7)," NON- EXISTENT P RESCRIPTIO N" G ASKP | |
622 | ; | |
623 | I X["-",$ D(^PSRX(PS DRX,0)) S PSDRXIN=+P SDRX D VER I PSOVR=1 ,$G(PSDSTA )=12!($G(P SDSTA)=13) !($G(PSDST A)=14)!($G (PSDSTA)=1 5) D CHKRF I $G(PSDN EXT)=1 G A SKP | |
624 | I X["-" L +^PSRX(PS DRX):5 I ' $T W !!,"S orry, some one else i s editing this presc ription. P lease try again late r." K PSDR X G ASKP | |
625 | ; | |
626 | ; (PSD*3* 21) Check for transm ission sta tus for ba rcode entr y | |
627 | ; | |
628 | G:$D(^PSR X(PSDRX,0) ) BC1 | |
629 | W !?7,$C( 7)," IMPRO PER BARCOD E FORMAT" G ASKP | |
630 | BC1 ; | |
631 | S PSDRXIN =+PSDRX D VER | |
632 | I $G(PSDS TA)=13!(+$ P($G(^PSRX (+PSDRX,0) ),"^",2)=0 ) W !?7,$C (7)," PRES CRIPTION H AS BEEN DE LETED." G ASKP | |
633 | I $G(PSDS TA),$S($G( PSDSTA)=2: 0,$G(PSDST A)=5:0,$G( PSDSTA)=11 :0,$G(PSDS TA)=12:0,$ G(PSDSTA)= 14:0,$G(PS DSTA)=15:0 ,1:1) D K J,RX0,RX2 ,ST,ST0 G ASKP | |
634 | .S RX0=$G (^PSRX(+PS DRX,0)),RX 2=^PSRX(+P SDRX,2),J= PSDRX S $P (RX0,"^",1 5)=$G(PSDS TA) D ^PSO FUNC | |
635 | .W !!,$C( 7)," Statu s of ",ST, " is not a ppropriate for selec tion." | |
636 | K PSDSTA, PSOVR,PSDR XIN | |
637 | S RXNUM=$ P($G(^PSRX (+PSDRX,0) ),U),PSDR= +$P($G(^(0 )),U,6),DF N=+$P($G(^ (0)),U,2), QTY=$P($G( ^(0)),U,7) ,PSDRN=$P( $G(^PSDRUG (PSDR,0)), "^") | |
638 | N C S Y=D FN,C=$P(^D D(58.81,73 ,0),U,2) D Y^DIQ S P ATN=Y | |
639 | D PID^VAD PT6 | |
640 | I '$D(^PS D(58.8,+PS DS,1,PSDR, 0)) W !!,P SDRN," is not curren tly stocke d in ",PSD SN,".",!!, "** No act ion taken. **",!! G END | |
641 | I $D(^PSD (58.81,"AO P",PSDRX)) D ^PSDOPT 2 I PSDOUT D MSG G E ND | |
642 | G ^PSDOPT 0 | |
643 | CHK ;displ ays and ch ecks if ok | |
644 | CLLDIR I $ D(PSDSEL(" OR")) S DI R(0)="S^1: Original;" ,CNT=1 | |
645 | I $D(PSDS EL("RF")) D | |
646 | .S X1=0 F S X1=$O( PSDSEL("RF ",X1)) Q:X 1="" D | |
647 | ..I $D(PS DRET("RF", X1)),(PSDR ET("RF",X1 )\1)=$P(PS DSEL("RF", X1),"^") D RTSDTC^PS DOPT2 Q | |
648 | ..I $D(PS DRET("RF", X1)),PSDRE T("RF",X1) <$P(PSDSEL ("RF",X1), "^") D CLL DIR2 Q | |
649 | ..I '$D(P SDRET("RF" ,X1)) D CL LDIR2 Q | |
650 | ..Q | |
651 | I $D(PSDS EL("PR")) D | |
652 | .S X1=0 F S X1=$O( PSDSEL("PR ",X1)) Q:X 1="" I '$ D(PSDRET(" PR",X1)) S CNT=$G(CN T)+1,DIR(0 )=$S($G(CN T)=1:"S^1: Partial #" _X1,1:DIR( 0)_CNT_":P artial #"_ X1)_" ("_$ P(PSDSEL(" PR",X1),"^ ",2)_");" | |
653 | I $G(DIR( 0))'="" D | |
654 | .K PSDERR D ^DIR I $D(DIRUT) S PSDERR=1 Q | |
655 | .S PSDA=$ E(Y(0)) | |
656 | Q:$D(PSDE RR) | |
657 | Q:'$D(Y(0 )) I PSDA= "O" S DAT= $P($G(^PSR X(PSDRX,2) ),U,2),PSD POST=$P(PS DSEL("OR") ,"^",3),PS DREL=$P(PS DSEL("OR") ,"^",4) G PROCESS | |
658 | I PSDA="R " S XX=$P( Y(0),"#",2 ),XXX=$P(X X," ",1),D AT=$P($G(P SDSEL("RF" ,XXX)),"^" ,1),QTY=$P (PSDSEL("R F",XXX),U, 2),PSDPOST =$P(PSDSEL ("RF",XXX) ,U,3),PSDR EL=$P(PSDS EL("RF",XX X),U,4) G PROCESS | |
659 | I PSDA="P " S XX=$P( Y(0),"#",2 ),XXX=$P(X X," ",1),D AT=$P($G(P SDSEL("PR" ,XXX)),"^" ,1),QTY=$P (PSDSEL("P R",XXX),U, 2),PSDPOST =$P(PSDSEL ("PR",XXX) ,U,3),PSDR EL=$P(PSDS EL("PR",XX X),U,4) G PROCESS | |
660 | W !,"Erro r somewher e" G ASKP | |
661 | PROCESS ;p rocess sel ection | |
662 | I PSDA'=" O" S PSDFL NO=XXX ;fi ll number | |
663 | I PSDA="O " S NEW=1, (NEW(1),NE W(2))=0 ;O riginal | |
664 | I PSDA="R " S NEW(1) =XXX,(NEW, NEW(2))=0 ;Refill | |
665 | I PSDA="P " S NEW(2) =XXX,(NEW, NEW(1))=0 ;Partial | |
666 | S X=0 F S X=$O(^PS RX(PSDRX,4 ,X)) Q:X'> 0 S STATUS =$P($G(^PS RX(PSDRX,4 ,X,0)),"^" ,4),NUMBER =$P($G(^PS RX(PSDRX,4 ,X,0)),"^" ,3) I $G(S TATUS)'=3 D | |
667 | .I NUMBER =0,$G(NEW) =1,$G(NEW( 1))=0 D CM OPMSG | |
668 | .I NUMBER =$G(NEW(1) ),$G(NEW)= 0,PSDA'="P ",'$D(PSDR ET("RF",NU MBER)) D C MOPMSG | |
669 | I $G(PSDO UT)=1 G AS KP | |
670 | ; | |
671 | D:PSDA="O " PSDORIG^ PSDOPT1 D: PSDA="R" P SDRFL^PSDO PT1 D:PSDA ="P" PSDPR TL^PSDOPT1 | |
672 | I $G(PSDO UT)=1 G AS KP | |
673 | I $G(PSDP OST)=1,$G( PSDREL)="" W !,"This fill has already be en posted. ",$C(7) G ASKP | |
674 | I $G(PSDR EL)'="",$G (PSDPOST)' >0 W !,"Th is fill ha s already been relea sed.",$C(7 ) | |
675 | I $G(PSDR EL)'="",$G (PSDPOST)> 0 W !,"Thi s fill has already b een posted & release d, no furt her action required. ",$C(7) G ASKP | |
676 | D DISPLAY G:PSDOUT END | |
677 | K DA,DIR, DIRUT S DI R(0)="YA", DIR("B")=" YES",DIR(" A")="Is th is OK? " | |
678 | S DIR("?" ,1)="Answe r 'YES' to log this RX transac tion in yo ur CS vaul t,",DIR("? ")="answer 'NO' to r eselect a prescripti on, or '^' to quit." | |
679 | D ^DIR K DIR I Y<1 D MSG G:$D (DIRUT) EN D G:Y<1 AS KP | |
680 | D ^PSDOPT 1 G ASKP | |
681 | END K %,%H ,%I,BAL,C, CNT,DA,DAT ,DD,DFN,DI C,DIE,DIK, DINUM,DIR, DIROUT,DIR UT,DLAYGO, DO,DR,JJ,L N,NEW,NODE ,NODE6 D F INAL^PSOLS ET | |
682 | I $G(PSDR X)'="" L - ^PSRX(PSDR X) | |
683 | K PATN,PH ARM,PHARMN ,PRF,PSDA, PSDATE,PSD OUT,PSDR,P SDRN,PSDRP H,PSDRX,PS DS,PSDSN,P SDT,PSDUZ, PSOCSUB,QT Y,RF,RPDT, RXNUM,X,Y | |
684 | D KVAR^VA DPT K VA(" PID"),VA(" BID") | |
685 | Q | |
686 | CHKEY ;che ck if user has acces s | |
687 | I '$D(^XU SEC("PSJ R PHARM",DUZ )) D S PS DOUT=1 | |
688 | .W !!?12, "** You ha ve no acce ss to rele ase this p rescriptio n." | |
689 | .W !?15," The PSJ RP HARM secur ity key is required. **",! | |
690 | Q | |
691 | CLLDIR2 S CNT=$G(CNT )+1,DIR(0) =$S($G(CNT )=1:"S^1:R efill #"_X 1,1:DIR(0) _CNT_":Ref ill #"_X1) _";" | |
692 | Q | |
693 | DISPLAY ;d isp data | |
694 | W !!,?20, "View Cont rolled Sub stances Rx # ",RXNUM ,!,?28,RPD T,!,LN,!! | |
695 | W "Locati on: ",?10, PSDSN,?55 | |
696 | S PSDRN(1 )=$S(NEW:" Original", $G(NEW(1)) :"Refill # "_NEW(1),1 :"Partial #"_$G(NEW( 2))) W PSD RN(1) | |
697 | W !,"Drug : ",?10,PS DRN,?55,"Q uantity: " ,QTY | |
698 | ; | |
699 | ;DAVE B ( PSD*3*15) check for Non-numeri c quantity | |
700 | I QTY'?.N W !,"The Quantity i s not stri ctly numer ic. This w ill cause the new ba lance to b e",!,"calc ulated inc orrectly." ,! | |
701 | W !,"Pati ent: ",?10 ,PATN_" (" _VA("BID") _")",?55,P SDRN(1)," Date: ",?6 5,$E(DAT,4 ,5)_"/"_$E (DAT,6,7)_ "/"_$E(DAT ,2,3),! | |
702 | S BAL=+$P ($G(^PSD(5 8.8,+PSDS, 1,PSDR,0)) ,"^",4) I QTY>BAL W !!,?5,"You r balance is ",BAL," .",!,?5,"Y ou may not dispense lower than your bala nce.",!! D MSG S PSD OUT=1 Q | |
703 | W !!,?15, "Old Balan ce: ",BAL, ?40,"New B alance: ", BAL-QTY,!! | |
704 | Q | |
705 | MSG W $C(7 ),!!,"No a ction take n. This tr ansaction has not be en recorde d.",!! | |
706 | Q | |
707 | VER ;Curre nt Outpati ent Versio n, and Rx status add ed 6/17/98 | |
708 | K PSDSTA S PSDHOLDX =$G(X) S P SOVR=$$VER SION^XPDUT L("PSO") S X=$G(PSDH OLDX) K PS DHOLDX S P SOVR=$S($G (PSOVR)>6: 1,1:0) | |
709 | I $G(PSDR XIN) S PSD STA=$S(PSO VR:$P($G(^ PSRX(PSDRX IN,"STA")) ,"^"),1:$P ($G(^PSRX( PSDRXIN,0) ),"^",15)) | |
710 | Q | |
711 | CHKRF ;Dav e B (PSD*3 *30) if it s deleted, show stat us. | |
712 | W !,"This RX has a status of '"_$S(PSDS TA=11:"EXP IRED",PSDS TA=12:"DIS CONTINUED" ,PSDSTA=13 :"DELETED" ,PSDSTA=14 :"DISCONTI NUED BY PR OVIDER",PS DSTA=15:"D ISCONTINUE D (EDIT)", 1:"Unknown Procedure ")_$S(PSDS TA=12:"'." ,1:"', no action can be taken. ") | |
713 | ;< JD*62 | |
714 | I $O(^PSR X(PSDRX,"A ",0))>0 W !!,"Below is a list of actions taken on the prescr iption.",! !,"DATE/TI ME",?22,"P ERSON",?45 ,"ACTIVITY ",! F X=1: 1:53 W "=" F X=1:1:( IOM-1) W " =" | |
715 | S X3=0 F S X3=$O(^ PSRX(PSDRX ,"A",X3)) Q:X3="" S DATA=$G(^ PSRX(PSDRX ,"A",X3,0) ),Y=$P(DAT A,"^",1) X ^DD("DD") S DATE=Y, X=$P(DATA, "^",2) D | |
716 | .I $G(X)' ="" S ACTI VITY=$$EXT ERNAL^DILF D(52.3,.02 ,,X) | |
717 | .S DELDUZ =$$EXTERNA L^DILFD(52 .3,.03,,$P (DATA,"^", 3)) S DELD UZ=$S($G(D ELDUZ)="": "Unknown ( "_$P(DATA, "^",3)_")" ,1:DELDUZ) | |
718 | .K DELREA S S DELREA S=$P(DATA, "^",5) | |
719 | .W !,DATE ,?22,DELDU Z,?45,ACTI VITY I $G( DELREAS)'= "" W !,"Co mment: ",$ G(DELREAS) | |
720 | I $G(PSDS TA)'=12 S PSDNEXT=1 Q | |
721 | ASK12 R !, "Do you wi sh to cont inue? NO / / ",AN:DTI ME S:AN="" AN="N" | |
722 | I "YyNn"' [AN W !,"A nswer 'N'o , and you will promp ted for an other pres cription." G ASK12 | |
723 | I "nN"[AN S PSDNEXT =1 Q | |
724 | K PSDNEXT | |
725 | Q | |
726 | CMOPMSG W !,?10,"Thi s is a CMO P fill and has been transmitte d, dispens ed or ",!? 10,"retran smitted.", ! S PSDOUT =1 Q | |
727 | KLLALL ;Ki ll all | |
728 | After: | |
729 | PSDOPT ;BI R/JPW,LTL, BJW - Outp atient Rx Entry ;2/5 /04 12:15p m | |
730 | ;;3.0;CON TROLLED SU BSTANCES;* *10,11,15, 21,30,39,4 8,62,69,71 ,79,84**;1 3 Feb 97;B uild 20 | |
731 | ;Referenc e to ^PSDR UG( suppor ted by DBI A #221 | |
732 | ;Referenc es to ^PSD (58.8 are covered by DBIA #271 1 | |
733 | ;Referenc es to file 58.81 are covered b y DBIA #28 08 | |
734 | ;Referenc e to PSRX( supported by DBIA # 986 | |
735 | ;Referenc e to PSOFU NC support ed by DBIA #981 | |
736 | ;Line Tag FINAL^PSO LSET suppo rted by DB IA #982 | |
737 | ; | |
738 | ;mod.for nois:tua-0 498-32173, askp,bc1;v er | |
739 | ;enhancem ent for Ou tpat V7 st atus code of 12,13,1 4,15 in as kp | |
740 | ; | |
741 | ;further modificati ons relate d to the d eletion of | |
742 | ;refills made in Ap ril 1999 | |
743 | ; | |
744 | ;PSD*3*39 Kill all variables | |
745 | D PSDKLL^ PSDOPT2 | |
746 | I '$D(PSD SITE) D ^P SDSET Q:'$ D(PSDSITE) | |
747 | I '$D(^XU SEC("PSJ R PHARM",DUZ )),'$D(^XU SEC("PSD T ECH ADV",D UZ)) W !!, "Please co ntact your Pharmacy Coordinato r for acce ss",!,"to log Outpat ient Presc riptions. Either the PSJ RPHAR M",!,"or P SD TECH AD V security key requi red.",!! Q | |
748 | I $P($G(^ VA(200,DUZ ,20)),U,4) ']"" N XQH S XQH="PS D ESIG" D EN^XQH G E ND | |
749 | N X,X1 D SIG^XUSESI G I X1="" G END | |
750 | N LN S (P SDOUT,NEW) =0,PSDUZ=D UZ,$P(LN," -",80)="", Y=DT | |
751 | X ^DD("DD ") S RPDT= Y | |
752 | ASKD ;ask disp site | |
753 | S PSDS=$P (PSDSITE,U ,3),PSDSN= $P(PSDSITE ,U,4) | |
754 | G:$P(PSDS ITE,U,5) C HKD | |
755 | K DIC,DA S DIC=58.8 ,DIC(0)="Q EAZ",DIC(" S")="I $P( ^(0),""^"" ,3)=+PSDSI TE,$S($P(^ (0),""^"", 2)[""M"":1 ,$P(^(0)," "^"",2)["" S"":1,1:0) ,$S('$D(^( ""I"")):1, +^(""I"")> DT:1,'^("" I""):1,1:0 )" | |
756 | S DIC("A" )="Select Primary Di spensing S ite: ",DIC ("B")=$P(P SDSITE,U,4 ) | |
757 | W ! D ^DI C K DIC G: Y<0 END | |
758 | S PSDS=+Y ,PSDSN=$P( Y,"^",2),$ P(PSDSITE, U,3)=+Y,$P (PSDSITE,U ,4)=PSDSN | |
759 | CHKD I '$O (^PSD(58.8 ,PSDS,1,0) ) W !!,"Th ere are no stocked d rugs for t his Pharma cy Vault!! ",!! G END | |
760 | ASKPH ;ask releasing RPH | |
761 | S DIC="^V A(200,",DI C(0)="QEAM ",DIC("S") ="I $D(^XU SEC(""PSOR PH"",+Y))" | |
762 | S DIC("A" )="Please identify P harmacist for Outpat ient Relea se: " | |
763 | S:$D(^XUS EC("PSORPH ",DUZ)) DI C("B")=$P( $G(^VA(200 ,DUZ,0)),U ) | |
764 | W ! D ^DI C K DIC G: Y<1 END S PSDRPH=+Y | |
765 | ASKP ;ask rx # | |
766 | K PSDSEL, PSDPOST,PS DREL | |
767 | ;PSD*3*30 (Dave Blo cker ) Loc k the scri pt node | |
768 | I $G(PSDR X)'="" L - ^PSRX(PSDR X) | |
769 | W ! K DIR ,NEW,PSDRX ,PSDRXIN,R XNUM S PSD OUT=0 S DI R("A")="En ter/Wand P RESCRIPTIO N number" | |
770 | S DIR("?" )="^D HELP ^PSODISP", DIR(0)="F^ 1:35" D ^D IR K DIR | |
771 | G:$D(DTOU T)!($D(DUO UT)) END G :X="" ASKP H | |
772 | S X=$$UP^ XLFSTR(X) | |
773 | I X'["-" D S PSDRX =$G(PSDRXI N) | |
774 | .S PSDRX= 0 F S PSD RX=$O(^PSR X("B",X,PS DRX)) Q:'P SDRX S PS DRXIN=PSDR X D VER | |
775 | I X'["-", '$G(PSDRX) !('$D(^PSR X(+$G(PSDR X),0))) W !,"INVALID PRESCRIPT ION NUMBER " G ASKP | |
776 | ; | |
777 | ;PSD*3*30 - lock th e script | |
778 | I X'["-" L +^PSRX(P SDRX):5 I '$T W !!," Sorry, som eone else is editing this pres cription. Please try again lat er." K PSD RX G ASKP | |
779 | ; | |
780 | ;DAVE B ( PSD*3*15) Show previ ous postin gs | |
781 | I X'["-" I $G(PSOVR )=1,$G(PSD STA)=12!($ G(PSDSTA)= 13)!($G(PS DSTA)=14)! ($G(PSDSTA )=15)!($G( PSDSTA)=11 ) S PSDXXX =X D CHKRF I $G(PSDN EXT)=1 G A SKP | |
782 | ;<JD *62 | |
783 | ; | |
784 | S PSD(1)= X,DIC="^DI C(4,",DR=9 9,DA=+$P($ G(^XMB(1,1 ,"XUS")),U ,17) | |
785 | K DIQ S D IQ="PSD" D EN^DIQ1 S X=PSD(1) K DIC,DR,D IQ | |
786 | I X["-",$ P(X,"-")'= PSD(4,DA,9 9) K DA,PS D W !?7,$C (7)," INVA LID STATIO N NUMBER ! !",! G ASK P | |
787 | K DA,PSD | |
788 | I X["-" S PSDRX=$P( X,"-",2) I (PSDRX'?1 N.N.1U) W !?7,$C(7), " INVALID PRESCRIPTI ON NUMBER" G ASKP | |
789 | I X["-" I '$D(^PSRX (+$G(PSDRX ),0))!($G( PSDRX)']"" ) W !?7,$C (7)," NON- EXISTENT P RESCRIPTIO N" G ASKP | |
790 | ; | |
791 | I X["-",$ D(^PSRX(PS DRX,0)) S PSDRXIN=+P SDRX D VER I PSOVR=1 ,$G(PSDSTA )=12!($G(P SDSTA)=13) !($G(PSDST A)=14)!($G (PSDSTA)=1 5) D CHKRF I $G(PSDN EXT)=1 G A SKP | |
792 | I X["-" L +^PSRX(PS DRX):5 I ' $T W !!,"S orry, some one else i s editing this presc ription. P lease try again late r." K PSDR X G ASKP | |
793 | ; | |
794 | ; (PSD*3* 21) Check for transm ission sta tus for ba rcode entr y | |
795 | ; | |
796 | G:$D(^PSR X(PSDRX,0) ) BC1 | |
797 | W !?7,$C( 7)," IMPRO PER BARCOD E FORMAT" G ASKP | |
798 | BC1 ; | |
799 | S PSDRXIN =+PSDRX D VER | |
800 | I $G(PSDS TA)=13!(+$ P($G(^PSRX (+PSDRX,0) ),"^",2)=0 ) W !?7,$C (7)," PRES CRIPTION H AS BEEN DE LETED." G ASKP | |
801 | I $G(PSDS TA),$S($G( PSDSTA)=2: 0,$G(PSDST A)=5:0,$G( PSDSTA)=11 :0,$G(PSDS TA)=12:0,$ G(PSDSTA)= 14:0,$G(PS DSTA)=15:0 ,1:1) D K J,RX0,RX2 ,ST,ST0 G ASKP | |
802 | .S RX0=$G (^PSRX(+PS DRX,0)),RX 2=^PSRX(+P SDRX,2),J= PSDRX S $P (RX0,"^",1 5)=$G(PSDS TA) D ^PSO FUNC | |
803 | .W !!,$C( 7)," Statu s of ",ST, " is not a ppropriate for selec tion." | |
804 | K PSDSTA, PSOVR,PSDR XIN | |
805 | S RXNUM=$ P($G(^PSRX (+PSDRX,0) ),U),PSDR= +$P($G(^(0 )),U,6),DF N=+$P($G(^ (0)),U,2), QTY=$P($G( ^(0)),U,7) ,PSDRN=$P( $G(^PSDRUG (PSDR,0)), "^") | |
806 | N C S Y=D FN,C=$P(^D D(58.81,73 ,0),U,2) D Y^DIQ S P ATN=Y | |
807 | D PID^VAD PT6 | |
808 | I '$D(^PS D(58.8,+PS DS,1,PSDR, 0)) W !!,P SDRN," is not curren tly stocke d in ",PSD SN,".",!!, "** No act ion taken. **",!! G END | |
809 | I $D(^PSD (58.81,"AO P",PSDRX)) D ^PSDOPT 2 I PSDOUT D MSG G E ND | |
810 | G ^PSDOPT 0 | |
811 | CHK ;displ ays and ch ecks if ok | |
812 | CLLDIR I $ D(PSDSEL(" OR")) S DI R(0)="S^1: Original;" ,CNT=1 | |
813 | I $D(PSDS EL("RF")) D | |
814 | .S X1=0 F S X1=$O( PSDSEL("RF ",X1)) Q:X 1="" D | |
815 | ..I $D(PS DRET("RF", X1)),(PSDR ET("RF",X1 )\1)=$P(PS DSEL("RF", X1),"^") D RTSDTC^PS DOPT2 Q | |
816 | ..I $D(PS DRET("RF", X1)),PSDRE T("RF",X1) <$P(PSDSEL ("RF",X1), "^") D CLL DIR2 Q | |
817 | ..I '$D(P SDRET("RF" ,X1)) D CL LDIR2 Q | |
818 | ..Q | |
819 | I $D(PSDS EL("PR")) D | |
820 | .S X1=0 F S X1=$O( PSDSEL("PR ",X1)) Q:X 1="" I '$ D(PSDRET(" PR",X1)) S CNT=$G(CN T)+1,DIR(0 )=$S($G(CN T)=1:"S^1: Partial #" _X1,1:DIR( 0)_CNT_":P artial #"_ X1)_" ("_$ P(PSDSEL(" PR",X1),"^ ",2)_");" | |
821 | I $G(DIR( 0))'="" D | |
822 | .K PSDERR D ^DIR I $D(DIRUT) S PSDERR=1 Q | |
823 | .S PSDA=$ E(Y(0)) | |
824 | Q:$D(PSDE RR) | |
825 | Q:'$D(Y(0 )) I PSDA= "O" S DAT= $P($G(^PSR X(PSDRX,2) ),U,2),PSD POST=$P(PS DSEL("OR") ,"^",3),PS DREL=$P(PS DSEL("OR") ,"^",4) G PROCESS | |
826 | I PSDA="R " S XX=$P( Y(0),"#",2 ),XXX=$P(X X," ",1),D AT=$P($G(P SDSEL("RF" ,XXX)),"^" ,1),QTY=$P (PSDSEL("R F",XXX),U, 2),PSDPOST =$P(PSDSEL ("RF",XXX) ,U,3),PSDR EL=$P(PSDS EL("RF",XX X),U,4) G PROCESS | |
827 | I PSDA="P " S XX=$P( Y(0),"#",2 ),XXX=$P(X X," ",1),D AT=$P($G(P SDSEL("PR" ,XXX)),"^" ,1),QTY=$P (PSDSEL("P R",XXX),U, 2),PSDPOST =$P(PSDSEL ("PR",XXX) ,U,3),PSDR EL=$P(PSDS EL("PR",XX X),U,4) G PROCESS | |
828 | W !,"Erro r somewher e" G ASKP | |
829 | PROCESS ;p rocess sel ection | |
830 | I PSDA'=" O" S PSDFL NO=XXX ;fi ll number | |
831 | I PSDA="O " S NEW=1, (NEW(1),NE W(2))=0 ;O riginal | |
832 | I PSDA="R " S NEW(1) =XXX,(NEW, NEW(2))=0 ;Refill | |
833 | I PSDA="P " S NEW(2) =XXX,(NEW, NEW(1))=0 ;Partial | |
834 | S X=0 F S X=$O(^PS RX(PSDRX,4 ,X)) Q:X'> 0 S STATUS =$P($G(^PS RX(PSDRX,4 ,X,0)),"^" ,4),NUMBER =$P($G(^PS RX(PSDRX,4 ,X,0)),"^" ,3) I $G(S TATUS)'=3 D | |
835 | .I NUMBER =0,$G(NEW) =1,$G(NEW( 1))=0 D CM OPMSG | |
836 | .I NUMBER =$G(NEW(1) ),$G(NEW)= 0,PSDA'="P ",'$D(PSDR ET("RF",NU MBER)) D C MOPMSG | |
837 | I $G(PSDO UT)=1 G AS KP | |
838 | ; | |
839 | D:PSDA="O " PSDORIG^ PSDOPT1 D: PSDA="R" P SDRFL^PSDO PT1 D:PSDA ="P" PSDPR TL^PSDOPT1 | |
840 | I $G(PSDO UT)=1 G AS KP | |
841 | I $G(PSDP OST)=1,$G( PSDREL)="" W !,"This fill has already be en posted. ",$C(7) G ASKP | |
842 | I $G(PSDR EL)'="",$G (PSDPOST)' >0 W !,"Th is fill ha s already been relea sed.",$C(7 ) | |
843 | I $G(PSDR EL)'="",$G (PSDPOST)> 0 W !,"Thi s fill has already b een posted & release d, no furt her action required. ",$C(7) G ASKP | |
844 | D DISPLAY G:PSDOUT END | |
845 | I $G(PSDQU IT) K PSDQ UIT G ASKP ;RTW | |
846 | K DA,DIR, DIRUT S DI R(0)="YA", DIR("B")=" YES",DIR(" A")="Is th is OK? " | |
847 | S DIR("?" ,1)="Answe r 'YES' to log this RX transac tion in yo ur CS vaul t,",DIR("? ")="answer 'NO' to r eselect a prescripti on, or '^' to quit." | |
848 | D ^DIR K DIR I Y<1 D MSG G:$D (DIRUT) EN D G:Y<1 AS KP | |
849 | D ^PSDOPT 1 G ASKP | |
850 | END K %,%H ,%I,BAL,C, CNT,DA,DAT ,DD,DFN,DI C,DIE,DIK, DINUM,DIR, DIROUT,DIR UT,DLAYGO, DO,DR,JJ,L N,NEW,NODE ,NODE6 D F INAL^PSOLS ET | |
851 | I $G(PSDR X)'="" L - ^PSRX(PSDR X) | |
852 | K PATN,PH ARM,PHARMN ,PRF,PSDA, PSDATE,PSD OUT,PSDQUI T,PSDR,PSD RN,PSDRPH, PSDRX,PSDS ,PSDSN,PSD T,PSDUZ,PS OCSUB,QTY, RF,RPDT,RX NUM,X,Y | |
853 | D KVAR^VA DPT K VA(" PID"),VA(" BID") | |
854 | Q | |
855 | CHKEY ;che ck if user has acces s | |
856 | I '$D(^XU SEC("PSJ R PHARM",DUZ )) D S PS DOUT=1 | |
857 | .W !!?12, "** You ha ve no acce ss to rele ase this p rescriptio n." | |
858 | .W !?15," The PSJ RP HARM secur ity key is required. **",! | |
859 | Q | |
860 | CLLDIR2 S CNT=$G(CNT )+1,DIR(0) =$S($G(CNT )=1:"S^1:R efill #"_X 1,1:DIR(0) _CNT_":Ref ill #"_X1) _";" | |
861 | Q | |
862 | DISPLAY ;d isp data | |
863 | W !!,?20, "View Cont rolled Sub stances Rx # ",RXNUM ,!,?28,RPD T,!,LN,!! | |
864 | W "Locati on: ",?10, PSDSN,?55 | |
865 | S PSDRN(1 )=$S(NEW:" Original", $G(NEW(1)) :"Refill # "_NEW(1),1 :"Partial #"_$G(NEW( 2))) W PSD RN(1) | |
866 | W !,"Drug : ",?10,PS DRN,?55,"Q uantity: " ,QTY | |
867 | ; | |
868 | ;DAVE B ( PSD*3*15) check for Non-numeri c quantity | |
869 | I QTY'?.N W !,"The Quantity i s not stri ctly numer ic. This w ill cause the new ba lance to b e",!,"calc ulated inc orrectly." ,! | |
870 | W !,"Pati ent: ",?10 ,PATN_" (" _VA("BID") _")",?55,P SDRN(1)," Date: ",?6 5,$E(DAT,4 ,5)_"/"_$E (DAT,6,7)_ "/"_$E(DAT ,2,3),! | |
871 | S BAL=+$P ($G(^PSD(5 8.8,+PSDS, 1,PSDR,0)) ,"^",4) I QTY>BAL W !!,?5,"You r balance is ",BAL," .",!,?5,"Y ou may not dispense lower than your bala nce.",!! D MSG S PSD OUT=1 Q | |
872 | N PSDOUT | |
873 | D ^PSDNBA L ;RTW NSR 20171101 | |
874 | I PSDOUT= 1 S PSDQUI T=PSDOUT D MSG Q ;R TW NSR2017 1101 | |
875 | W !!,?15, "Old Balan ce: ",BAL, ?40,"New B alance: ", BAL-QTY,!! | |
876 | Q | |
877 | MSG W $C(7 ),!!,"No a ction take n. This tr ansaction has not be en recorde d.",!! | |
878 | Q | |
879 | VER ;Curre nt Outpati ent Versio n, and Rx status add ed 6/17/98 | |
880 | K PSDSTA S PSDHOLDX =$G(X) S P SOVR=$$VER SION^XPDUT L("PSO") S X=$G(PSDH OLDX) K PS DHOLDX S P SOVR=$S($G (PSOVR)>6: 1,1:0) | |
881 | I $G(PSDR XIN) S PSD STA=$S(PSO VR:$P($G(^ PSRX(PSDRX IN,"STA")) ,"^"),1:$P ($G(^PSRX( PSDRXIN,0) ),"^",15)) | |
882 | Q | |
883 | CHKRF ;Dav e B (PSD*3 *30) if it s deleted, show stat us. | |
884 | W !,"This RX has a status of '"_$S(PSDS TA=11:"EXP IRED",PSDS TA=12:"DIS CONTINUED" ,PSDSTA=13 :"DELETED" ,PSDSTA=14 :"DISCONTI NUED BY PR OVIDER",PS DSTA=15:"D ISCONTINUE D (EDIT)", 1:"Unknown Procedure ")_$S(PSDS TA=12:"'." ,1:"', no action can be taken. ") | |
885 | ;< JD*62 | |
886 | I $O(^PSR X(PSDRX,"A ",0))>0 W !!,"Below is a list of actions taken on the prescr iption.",! !,"DATE/TI ME",?22,"P ERSON",?45 ,"ACTIVITY ",! F X=1: 1:53 W "=" F X=1:1:( IOM-1) W " =" | |
887 | S X3=0 F S X3=$O(^ PSRX(PSDRX ,"A",X3)) Q:X3="" S DATA=$G(^ PSRX(PSDRX ,"A",X3,0) ),Y=$P(DAT A,"^",1) X ^DD("DD") S DATE=Y, X=$P(DATA, "^",2) D | |
888 | .I $G(X)' ="" S ACTI VITY=$$EXT ERNAL^DILF D(52.3,.02 ,,X) | |
889 | .S DELDUZ =$$EXTERNA L^DILFD(52 .3,.03,,$P (DATA,"^", 3)) S DELD UZ=$S($G(D ELDUZ)="": "Unknown ( "_$P(DATA, "^",3)_")" ,1:DELDUZ) | |
890 | .K DELREA S S DELREA S=$P(DATA, "^",5) | |
891 | .W !,DATE ,?22,DELDU Z,?45,ACTI VITY I $G( DELREAS)'= "" W !,"Co mment: ",$ G(DELREAS) | |
892 | I $G(PSDS TA)'=12 S PSDNEXT=1 Q | |
893 | ASK12 R !, "Do you wi sh to cont inue? NO / / ",AN:DTI ME S:AN="" AN="N" | |
894 | I "YyNn"' [AN W !,"A nswer 'N'o , and you will promp ted for an other pres cription." G ASK12 | |
895 | I "nN"[AN S PSDNEXT =1 Q | |
896 | K PSDNEXT | |
897 | Q | |
898 | CMOPMSG W !,?10,"Thi s is a CMO P fill and has been transmitte d, dispens ed or ",!? 10,"retran smitted.", ! S PSDOUT =1 Q | |
899 | KLLALL ;Ki ll all | |
900 | PSDNBAL (N ew) | |
901 | PSDNBAL ;E PIP/RTW - Ask CS Rem aining Bal ance ;29 A ug 94 | |
902 | ;;3.0;CON TROLLED SU BSTANCES N ARCOTIC BA LANCE;**84 **;13 Feb 97;Build 8 | |
903 | ; ICR# TY PE DESCRIP TION | |
904 | ;----- -- ----- ---- ---------- ---------- ---------- -- | |
905 | ;10026 Su pport ^DIR | |
906 | ;4986 Sup port ^%DTC | |
907 | ;1140 Sup port ^XMD | |
908 | ;-------- ---------- ---------- ---------- ---------- ---------- ---------- - | |
909 | S PSDTRY= 1 | |
910 | ENTER ; | |
911 | S PSDOUT= 0 | |
912 | S DIR(0)= "N" | |
913 | S DIR("A" )=" Enter the remain ing balanc e (^ to qu it)" | |
914 | S DIR("T" )=DTIME | |
915 | S DIR("?" ,1)="Enter The remai ning Balan ce on hand " | |
916 | S DIR("?" ,2)="The s ystem will compare a gainst the database. " | |
917 | S DIR("?" ,3)="You w ill have 3 tries to complete b efore a me ssage is s ent" | |
918 | S DIR("?" ,4)="to th e CS BALAN CE DISCREP ANCY mail group" | |
919 | S DIR("?" )=" " | |
920 | D ^DIR K DIR S PSDA NS=Y I $D( DIRUT) S P SDOUT=1 G EXIT | |
921 | S PSDQDB= (BAL-QTY) | |
922 | W:PSDANS= PSDQDB !!, "Balance c onfirmed, Thank you ",! ;RTW | |
923 | S PSDQCHO =$S(PSDANS =PSDQDB:"E XIT",1:"PS DATMPT") | |
924 | D @PSDQCH O | |
925 | Q | |
926 | EXIT ; | |
927 | K PSDTRY, PSDQCHO,PS DANS,PSDQD B,PSDPHN,X MDUZ,XMY,X MSUB,XMZ,P SDWANS,PSD RN | |
928 | K ^TMP($J ,"MSG") | |
929 | Q | |
930 | ;; | |
931 | PSDATMPT I PSDTRY=1 D MESS1 S PSDTRY=PSD TRY+1 G EN TER | |
932 | I PSDTRY= 2 D MESS2 S PSDTRY=P SDTRY+1 G ENTER | |
933 | I PSDTRY= 3 D MESG | |
934 | Q | |
935 | MESS1 W !! ,"Sorry th e remainin g balance you entere d does not match the balance", !,"on reco rd in the CS package .",!!,"Ple ase check to ensure you have d ispensed t he right d rug and",! ," dispens ed the cor rect quant ity.",! | |
936 | Q | |
937 | MESS2 W !! ,"This wil l be the l ast entry in the rem aining bal ance check .",!!,"If the entry still does not match a message will be s ent to the ",!,"appro priate per son for re view." | |
938 | W " You m ay proceed if you ha ve dispens ed the",!, "correct d rug in the correct q uantity. T hank you." ,! | |
939 | Q | |
940 | MESG ;Ask comment an d send mes sage | |
941 | S DIR(0)= "F" | |
942 | S DIR("A" )="Enter a comment ( ^ to quit) " | |
943 | S DIR("T" )=DTIME | |
944 | S DIR("?" ,1)="Enter comment w ith any co ncerns abo ut the bal ance discr epancy." | |
945 | S DIR("?" ,2)="You a re limited to 245 ch aracters." | |
946 | S DIR("?" )=" " | |
947 | D ^DIR K DIR S PSDW ANS=Y I $D (DIRUT) G EXIT | |
948 | K XMTEXT | |
949 | S XMSUB=" Possible C S Balance Remaining Discrepanc y" | |
950 | S XMY(DUZ )="" ;To U ser | |
951 | S XMY("G. CS BALANCE DISCREPAN CY")="" ; | |
952 | S ^TMP($J ,"MSG","B" ,1)="There were thre e failed a ttempts to enter the current r emaining b alance for the follo wing drug. " | |
953 | S ^TMP($J ,"MSG","B" ,2)=" " | |
954 | S ^TMP($J ,"MSG","B" ,3)=" Drug : "_PSDRN | |
955 | S ^TMP($J ,"MSG","B" ,4)=" Rx # : "_RXNUM | |
956 | S ^TMP($J ,"MSG","B" ,5)=" Rx Q ty : "_QTY | |
957 | S ^TMP($J ,"MSG","B" ,6)="Balan ce Entered : "_PSDAN S | |
958 | S ^TMP($J ,"MSG","B" ,7)="Balan ce in Vist A : "_PSDQ DB | |
959 | N Y,DIFRO M | |
960 | D NOW^%DT C S Y=% X ^DD("DD") | |
961 | S ^TMP($J ,"MSG","B" ,8)=" Time : "_Y | |
962 | S XMDUZ=. 5 | |
963 | S PSDPHN= $P(^VA(200 ,DUZ,0),"^ ",1) | |
964 | S ^TMP($J ,"MSG","B" ,9)=" Phar macist : " _PSDPHN | |
965 | S ^TMP($J ,"MSG","B" ,10)=" Com ment : "_P SDWANS | |
966 | S ^TMP($J ,"MSG","B" ,11)=" " | |
967 | S ^TMP($J ,"MSG","B" ,12)="Than k you for checking o n this pos sible disc repancy." ; | |
968 | S XMTEXT= "^TMP($J," "MSG"",""B ""," | |
969 | D ^XMD | |
970 | W:$D(XMZ) !!,"Messa ge sent to the CS BA LANCE DISC REPANCY Ma il Group", !!," You e ntered a r emaining b alance of ",PSDANS | |
971 | D EXIT | |
972 | Q | |
973 | PSD84P (Ne w) | |
974 | PSD84P ;EP IP/RTW - P SD CONTROL SUBSTANCE WARNING P OST INSTAL L ; 05/074 /18 18:46p m | |
975 | ;;3.0;CON TROLLED SU BSTANCES ; **84**;13 Feb 97;BUI LD 1 | |
976 | ; ICR# Ty pe Descrip tion | |
977 | ;----- -- -- ------- ---------- ---------- ---------- | |
978 | ;10111 Su p FM looku p on file 3.8 using ^DIC API | |
979 | ; | |
980 | MAILGRP ;N eed to che ck for a p re existin g mail gro up called CS BALANCE DISCREPAN CY if it e xists do n othing. | |
981 | N PSDMG,P SDMSG,PSDN IEN,PSDRX | |
982 | S PSDMG=$ $FIND1^DIC (3.8,"","X ","CS BALA NCE DISCRE PANCY","", "","") | |
983 | D:'PSDMG | |
984 | . N PSDMG RP,PSDDESC R,PSDTYPE, PSDORG,MSG ,FDA2,FDA, PSDIEN | |
985 | . S PSDMG RP="CS BAL ANCE DISCR EPANCY",PS DTYPE="PR" ,PSDORG=". 5" | |
986 | . S PSDDE SCR(1)="Ph armacy Sup ervisors G roup for r eporting N arcotic Ba lance Disc repancies" | |
987 | . S FDA(3 .8,"+1,",. 01)=PSDMGR P | |
988 | . S FDA(3 .8,"+1,",4 )=PSDTYPE | |
989 | . S FDA(3 .8,"+1,",5 )=PSDORG | |
990 | . D UPDAT E^DIE(""," FDA","FDAI EN","MSG") | |
991 | . S PSDNI EN=$O(^XMB (3.8,"B"," CS BALANCE DISCREPAN CY",0)) | |
992 | . S PSDMS G(1)="Phar macy Super visors Gro up for rep orting Nar cotic Bala nce Discre pancies" | |
993 | . D WP^DI E(3.8,PSDN IEN_",",3, ,"PSDMSG") | |
994 | . K FDA,F DAIEN | |
995 | I $D(MSG) D Q | |
996 | . S PSDRX ="Mail Gro up Creatio n Failed. The follow ing error message wa s returned :" | |
997 | . W ! | |
998 | . D MES^X PDUTL(PSDR X) | |
999 | S PSDRX=" Mail Group created s uccessfull y." | |
1000 | D MES^XPD UTL(PSDRX) | |
1001 | Q |
Araxis Merge (but not the data content of this report) is Copyright © 1993-2016 Araxis Ltd (www.araxis.com). All rights reserved.