source: cprs/branches/tmg-cprs/m_files/TMGPSSDE.m

Last change on this file was 796, checked in by Kevin Toppenberg, 14 years ago

Initial upload
File size: 14.1 KB
Line 
1TMGPSSDE ;TMG/kst/Custom version of PSSDEE ;03/25/06
2 ;;1.0;TMG-LIB;**1**;04/25/04
3
4PSSDEE ;BIR/WRT-MASTER DRUG ENTER/EDIT ROUTINE ;01/21/00
5 ;;1.0;PHARMACY DATA MANAGEMENT;**3,5,15,16,20,22,28,32,34,33,38,57,47,68,61**;9/30/97
6
7 ;"*****************************************************************
8 ;"* Custom version of code by Kevin Toppenberg, MD
9 ;"* to allow customization of the code.
10 ;"*
11 ;"*****************************************************************
12
13 ;"Reference to REACT1^PSNOUT supported by DBIA #2080
14 ;"Reference to $$UP^XLFSTR(X) supported by DBIA #10104
15 ;"Reference to $$PSJDF^PSNAPIS(P1,P3) supported by DBIA #2531
16 ;
17BEGIN set PSSFLAG=0
18 do ^PSSDEE2 ;"kill vars
19 set PSSZ=1
20 F PSSXX=1:1 do quit:PSSFLAG
21 . kill DA
22 . do ASK ;" ask users all questions
23DONE do ^PSSDEE2 ;" kill vars
24 kill PSSFLAG
25 quit
26 ;
27 ;"=================================================================
28ASK W !
29 set DIC="^PSDRUG("
30 set DIC(0)="QEALMNTV" ;"query/echo/ask/learn=OK/multIndex/IntNumOK/T->searchAllIndexes/verify
31 set DLAYGO=50 ;"force allowing adding record to file 50
32 set DIC("T")="" ;"present every match to the lookup value
33 do ^DIC
34 kill DIC
35 if Y<0 set PSSFLAG=1 quit
36 ;
37 set (FLG1,FLG2,FLG3,FLG4,FLG5,FLG6,FLG7,FLAG,FLGKY,FLGOI)=0
38 kill ^TMP($J,"ADD")
39 kill ^TMP($J,"SOL")
40 ;
41 set DA=+Y
42 set DISPDRG=DA
43 L +^PSDRUG(DISPDRG):0
44 if '$T W !,$C(7),"Another person is editing this one." quit
45 set PSSHUIDG=1
46 set PSSNEW=$P(Y,"^",3)
47 do USE
48 do NOPE
49 do COMMON
50 do DEA
51 do MF
52 kill PSSHUIDG
53 do DRG^PSSHUIDG(DISPDRG,PSSNEW)
54 L -^PSDRUG(DISPDRG)
55 kill FLG3,PSSNEW
56 quit
57 ;
58 ;"=================================================================
59COMMON set DIE="^PSDRUG("
60 set DR="[PSSCOMMON]"
61 do ^DIE
62 quit:$data(Y)!($data(DTOUT))
63 W:'$data(Y) !,"PRICE PER DISPENSE UNIT: "
64 S:'$data(^PSDRUG(DA,660)) $P(^PSDRUG(DA,660),"^",6)=""
65 W:'$data(Y) $P(^PSDRUG(DA,660),"^",6)
66 do DEA
67 do CK
68 do ASKND
69 do OIKILL^PSSDEE1
70 do COMMON1
71 quit
72 ;
73COMMON1 W !,"Just a reminder...you are editing ",$P(^PSDRUG(DISPDRG,0),"^"),"."
74 set (PSSVVDA,DA)=DISPDRG
75 do DOSN^PSSDOS
76 set DA=PSSVVDA
77 kill PSSVVDA
78 do USE
79 do APP
80 do ORDITM^PSSDEE1
81 quit
82 ;
83CK do DSPY^PSSDEE1
84 set FLGNDF=0
85 quit
86 ;
87ASKND set %=-1
88 if $data(^XUSEC("PSNMGR",DUZ)) do
89 . do MESSAGE^PSSDEE1
90 . W !!,"Do you wish to match/rematch to NATIONAL DRUG file"
91 . set %=1
92 . S:FLGMTH=1 %=2
93 . do YN^DICN
94 if %=0 W !,"If you answer ""yes"", you will attempt to match to NDF." G ASKND
95 if %=2 kill X,Y quit
96 if %<0 kill X,Y quit
97 if %=1 do
98 . do RSET^PSSDEE1
99 . do EN1^PSSUTIL(DISPDRG,1)
100 . set X="PSNOUT"
101 . X ^%ZOSF("TEST")
102 . if do
103 . . do REACT1^PSNOUT
104 . . set DA=DISPDRG
105 . . if $data(^PSDRUG(DA,"ND")),$P(^PSDRUG(DA,"ND"),"^",2)]"" do ONE
106 quit
107 ;
108ONE set PSNP=$G(^PSDRUG(DA,"I"))
109 if PSNP,PSNP<DT quit
110 W !,"You have just VERIFIED this match and MERGED the entry."
111 do CKDF
112 do EN2^PSSUTIL(DISPDRG,1)
113 S:'$data(OLDDF) OLDDF=""
114 if OLDDF'=NEWDF do
115 . set FLGNDF=1
116 . do WR
117 quit
118 ;
119CKDF set NWND=^PSDRUG(DA,"ND")
120 set NWPC1=$P(NWND,"^",1)
121 set NWPC3=$P(NWND,"^",3)
122 set DA=NWPC1
123 set K=NWPC3
124 set X=$$PSJDF^PSNAPIS(DA,K)
125 set NEWDF=$P(X,"^",2)
126 set DA=DISPDRG
127 N PSSK
128 do PKIND^PSSDDUT2
129 quit
130 ;
131NOPE set ZAPFLG=0
132 if '$data(^PSDRUG(DA,"ND")),$data(^PSDRUG(DA,2)),$P(^PSDRUG(DA,2),"^",1)']"" do DFNULL
133 if '$data(^PSDRUG(DA,"ND")),'$data(^PSDRUG(DA,2)) do DFNULL
134 if $data(^PSDRUG(DA,"ND")),$P(^PSDRUG(DA,"ND"),"^",2)']"",$data(^PSDRUG(DA,2)),$P(^PSDRUG(DA,2),"^",1)']"" do DFNULL
135 quit
136 ;
137DFNULL set OLDDF=""
138 set ZAPFLG=1
139 quit
140 ;
141ZAPIT if $data(ZAPFLG),ZAPFLG=1,FLGNDF=1,OLDDF'=NEWDF do CKIV^PSSDEE1
142 quit
143 ;
144APP W !!,"MARK THIS DRUG AND EDIT IT FOR: "
145 do CHOOSE
146 quit
147 ;
148CHOOSE if $data(^XUSEC("PSORPH",DUZ))!($data(^XUSEC("PSXCMOPMGR",DUZ))) W !,"O - Outpatient" set FLG1=1
149 if $data(^XUSEC("PSJU MGR",DUZ)) W !,"U - Unit Dose" set FLG2=1
150 if $data(^XUSEC("PSJI MGR",DUZ)) W !,"I - IV" set FLG3=1
151 if $data(^XUSEC("PSGWMGR",DUZ)) W !,"W - Ward Stock" set FLG4=1
152 if $data(^XUSEC("PSAMGR",DUZ))!($data(^XUSEC("PSA ORDERS",DUZ))) W !,"D - Drug Accountability" set FLG5=1
153 if $data(^XUSEC("PSDMGR",DUZ)) W !,"C - Controlled Substances" set FLG6=1
154 if $data(^XUSEC("PSORPH",DUZ)) W !,"X - Non-VA Med" set FLG7=1
155 if FLG1,FLG2,FLG3,FLG4,FLG5,FLG6 set FLAG=1
156 if FLAG W !,"A - ALL"
157 W !
158 if 'FLG1,'FLG2,'FLG3,'FLG4,'FLG5,'FLG6,'FLG7 do quit
159 . W !,"You do not have the proper keys to continue. Sorry, this concludes your editing session.",!
160 . set FLGKY=1
161 . kill DIRUT,X
162 if FLGKY'=1 D
163 . kill DIR
164 . set DIR(0)="FO^1:30"
165 . set DIR("A")="Enter your choice(s) separated by commas "
166 . F do ^DIR quit:$$CHECK($$UP^XLFSTR(X))
167 . set PSSANS=X
168 . set PSSANS=$$UP^XLFSTR(PSSANS)
169 . do BRANCH
170 . do BRANCH1
171 quit
172 ;
173CHECK(X) ;" Validates Application Use response
174 N CHECK,I,C
175 set CHECK=1 if X=""!(Y["^")!($data(DIRUT)) quit CHECK
176 F I=1:1:$L(X,",") D
177 . set C=$P(X,",",I) W !?43,C," - "
178 . if C="O",FLG1 W "Outpatient" quit
179 . if C="U",FLG2 W "Unit Dose" quit
180 . if C="I",FLG3 W "IV" quit
181 . if C="W",FLG4 W "Ward Stock" quit
182 . if C="D",FLG5 W "Drug Accountability" quit
183 . if C="C",FLG6 W "Controlled Substances" quit
184 . if C="X",FLG7 W "Non-VA Med" quit
185 . W "Invalid Entry",$C(7) set CHECK=0
186 quit CHECK
187 ;
188BRANCH D:PSSANS["O" OP
189 D:PSSANS["U" UD
190 D:PSSANS["I" IV
191 D:PSSANS["W" WS
192 D:PSSANS["D" DACCT
193 D:PSSANS["C" CS
194 D:PSSANS["X" NVM
195 quit
196 ;
197BRANCH1 if FLAG,PSSANS["A" do
198 . do OP
199 . do UD
200 . do IV
201 . do WS
202 . do DACCT
203 . do CS
204 . do NVM
205 quit
206 ;
207OP if FLG1 D
208 . W !,"** You are NOW editing OUTPATIENT fields. **"
209 . set PSIUDA=DA
210 . set PSIUX="O^Outpatient Pharmacy"
211 . do ^PSSGIU
212 . if %=1 D
213 . . set DIE="^PSDRUG(",DR="[PSSOP]"
214 . . do ^DIE
215 . . kill DIR
216 . . do OPEI
217 . . do ASKCMOP
218 . . set X="PSOCLO1"
219 . . X ^%ZOSF("TEST")
220 . . if do ASKCLOZ set FLGOI=1
221 if FLG1 do CKCMOP
222 quit
223 ;
224CKCMOP if $P($G(^PSDRUG(DISPDRG,2)),"^",3)'["O" do
225 . S:$data(^PSDRUG(DISPDRG,3)) $P(^PSDRUG(DISPDRG,3),"^",1)=0
226 . K:$data(^PSDRUG("AQ",DISPDRG)) ^PSDRUG("AQ",DISPDRG)
227 . set DA=DISPDRG
228 . do ^PSSREF
229 quit
230 ;
231UD if FLG2 do
232 . W !,"** You are NOW editing UNIT DOSE fields. **"
233 . set PSIUDA=DA
234 . set PSIUX="U^Unit Dose"
235 . do ^PSSGIU
236 . if %=1 do
237 . . set DIE="^PSDRUG("
238 . . set DR="62.05;212.2"
239 . . do ^DIE
240 . . set DIE="^PSDRUG("
241 . . set DR="212"
242 . . set DR(2,50.0212)=".01;1"
243 . . do ^DIE
244 . . set FLGOI=1
245 quit
246 ;
247IV if FLG3
248 W !,"** You are NOW editing IV fields. **"
249 S (PSIUDA,PSSDA)=DA
250 set PSIUX="I^IV"
251 do ^PSSGIU
252 if %=1 do IV1 set FLGOI=1
253 quit
254 ;
255IV1 kill PSSIVOUT ;"This variable controls the selection process loop.
256 W !,"Edit Additives or Solutions: "
257 kill DIR
258 set DIR(0)="SO^A:ADDITIVES;S:SOLUTIONS;"
259 do ^DIR
260 quit:$data(DIRUT)
261 set PSSASK=Y(0)
262 D:PSSASK="ADDITIVES" ENA^PSSVIDRG
263 D:PSSASK="SOLUTIONS" ENS^PSSVIDRG
264 if '$data(PSSIVOUT) G IV1
265 kill PSSIVOUT
266 quit
267 ;
268WS if FLG4
269 W !,"** You are NOW editing WARD STOCK fields. **"
270 set DIE="^PSDRUG("
271 set DR="300;301;302"
272 do ^DIE
273 quit
274 ;
275DACCT if FLG5
276 W !,"** You are NOW editing DRUG ACCOUNTABILITY fields. **"
277 set DIE="^PSDRUG("
278 set DR="441"
279 do ^DIE
280 set DIE="^PSDRUG("
281 set DR="9"
282 set DR(2,50.1)="1;2;400;401;402;403;404;405"
283 do ^DIE
284 quit
285 ;
286CS if FLG6
287 W !,"** You are NOW Marking/Unmarking for CONTROLLED SUBS. **"
288 set PSIUDA=DA
289 set PSIUX="N^Controlled Substances"
290 do ^PSSGIU
291 quit
292 ;
293NVM if FLG7
294 W !,"** You are NOW Marking/Unmarking for NON-VA MEDS. **"
295 set PSIUDA=DA
296 set PSIUX="X^Non-VA Med"
297 do ^PSSGIU
298 quit
299 ;
300ASKCMOP if $data(^XUSEC("PSXCMOPMGR",DUZ)) do
301 . W !!,"Do you wish to mark to transmit to CMOP? "
302 . kill DIR
303 . set DIR(0)="Y"
304 . set DIR("?")="If you answer ""yes"", you will attempt to mark this drug to transmit to CMOP."
305 do ^DIR
306 if "Nn"[X kill X,Y,DIRUT quit
307 if "Yy"[X do
308 . set PSXFL=0
309 . do TEXT^PSSMARK
310 . H 7
311 . N PSXUDA
312 . S (PSXUM,PSXUDA)=DA
313 . set PSXLOC=$P(^PSDRUG(DA,0),"^")
314 . set PSXGOOD=0
315 . set PSXF=0
316 . set PSXBT=0
317 . do BLD^PSSMARK
318 . do PICK2^PSSMARK
319 . set DA=PSXUDA
320 quit
321 ;
322ASKCLOZ W !!,"Do you wish to mark/unmark as a LAB MONITOR or CLOZAPINE DRUG? "
323 kill DIR
324 set DIR(0)="Y"
325 set DIR("?")="If you answer ""yes"", you will have the opportunity to edit LAB MONITOR or CLOZAPINE fields."
326 do ^DIR
327 if "Nn"[X kill X,Y,DIRUT quit
328 if "Yy"[X set NFLAG=0 do MONCLOZ
329 quit
330 ;
331MONCLOZ kill PSSAST
332 do FLASH
333 W !,"Mark/Unmark for Lab Monitor or Clozapine: "
334 kill DIR
335 set DIR(0)="S^L:LAB MONITOR;C:CLOZAPINE;"
336 do ^DIR
337 quit:$data(DIRUT)
338 set PSSAST=Y(0)
339 D:PSSAST="LAB MONITOR" ^PSSLAB
340 D:PSSAST="CLOZAPINE" CLOZ
341 quit
342 ;
343FLASH kill LMFLAG,CLFALG,WHICH
344 set WHICH=$P($G(^PSDRUG(DISPDRG,"CLOZ1")),"^")
345 set LMFLAG=0
346 set CLFLAG=0
347 if WHICH="PSOCLO1" set CLFLAG=1
348 if WHICH'="PSOCLO1" S:WHICH'="" LMFLAG=1
349 quit
350 ;
351CLOZ quit:NFLAG
352 quit:$data(DTOUT)
353 quit:$data(DIRUT)
354 quit:$data(DUOUT)
355 W !,"** You are NOW editing CLOZAPINE fields. **"
356 do ^PSSCLDRG
357 quit
358 ;
359USE kill PACK
360 set PACK=""
361 S:$P($G(^PSDRUG(DISPDRG,"PSG")),"^",2)]"" PACK="W"
362 if $data(^PSDRUG(DISPDRG,2)) set PACK=PACK_$P(^PSDRUG(DISPDRG,2),"^",3)
363 if PACK'="" D
364 . W $C(7) N XX W !! F XX=1:1:79 W "*"
365 . W !,"This entry is marked for the following PHARMACY packages: "
366 . do USE1
367 quit
368 ;
369USE1 W:PACK["O" !," Outpatient"
370 W:PACK["U" !," Unit Dose"
371 W:PACK["I" !," IV"
372 W:PACK["W" !," Ward Stock"
373 W:PACK["D" !," Drug Accountability"
374 W:PACK["N" !," Controlled Substances"
375 W:PACK["X" !," Non-VA Med"
376 W:'$data(PACK) !," NONE"
377 if PACK'["O",PACK'["U",PACK'["I",PACK'["W",PACK'["D",PACK'["N",PACK'["X" W !," NONE"
378 quit
379 ;
380WR if ^XMB("NETNAME")'["CMOP-" do
381 . if OLDDF="" quit
382 . W !,"The dosage form has changed from "_OLDDF_" to "_NEWDF_" due to",!
383 . w "matching/rematching to NDF.",!
384 . w "You will need to rematch to Orderable Item.",!
385 quit
386PRIMDRG if $data(^PS(59.7,1,20)),$P(^PS(59.7,1,20),"^",1)=4!($P(^PS(59.7,1,20),"^",1)=4.5) do
387 . if $data(^PSDRUG(DISPDRG,2)) do
388 . . set VAR=$P(^PSDRUG(DISPDRG,2),"^",3)
389 . . if VAR["U"!(VAR["I") do
390 . . . do PRIM1
391 quit
392 ;
393PRIM1 W !!,"You need to match this drug to ""PRIMARY DRUG"" file as well.",!
394 set DIE="^PSDRUG(",DR="64"
395 set DA=DISPDRG
396 do ^DIE
397 kill VAR
398 quit
399 ;
400MF if $P($G(^PS(59.7,1,80)),"^",2)>1 if $data(^PSDRUG(DISPDRG,2)) DO
401 . set PSSOR=$P(^PSDRUG(DISPDRG,2),"^",1)
402 . if PSSOR]"" DO
403 . . DO EN^PSSPOIDT(PSSOR)
404 . . DO EN2^PSSHL1(PSSOR,"MUP")
405 quit
406 ;
407MFA if $P($G(^PS(59.7,1,80)),"^",2)>1 do
408 . set PSSOR=$P(^PS(52.6,ENTRY,0),"^",11)
409 . set PSSDD=$P(^PS(52.6,ENTRY,0),"^",2)
410 . if PSSOR]"" do
411 . . do EN^PSSPOIDT(PSSOR)
412 . . do EN2^PSSHL1(PSSOR,"MUP")
413 . . do MFDD
414 quit
415 ;
416MFS if $P($G(^PS(59.7,1,80)),"^",2)>1 do
417 . set PSSOR=$P(^PS(52.7,ENTRY,0),"^",11)
418 . set PSSDD=$P(^PS(52.7,ENTRY,0),"^",2)
419 . if PSSOR]"" do
420 . . do EN^PSSPOIDT(PSSOR)
421 . . do EN2^PSSHL1(PSSOR,"MUP")
422 . . do MFDD
423 quit
424 ;
425MFDD if $data(^PSDRUG(PSSDD,2)) do
426 . set PSSOR=$P(^PSDRUG(PSSDD,2),"^",1)
427 . if PSSOR]"" do
428 . . do EN^PSSPOIDT(PSSOR)
429 . . do EN2^PSSHL1(PSSOR,"MUP")
430 quit
431 ;
432OPEI if $data(^PSDRUG(DISPDRG,"ND")),$P(^PSDRUG(DISPDRG,"ND"),"^",10)]"" do
433 . set DIE="^PSDRUG("
434 . set DR="28"
435 . set DA=DISPDRG
436 . do ^DIE
437 quit
438 ;
439DEA ;
440 if $P($G(^PSDRUG(DISPDRG,3)),"^")=1,($P(^PSDRUG(DISPDRG,0),"^",3)[1!($P(^(0),"^",3)[2)) do DSH
441 quit
442 ;
443DSH W !!,"****************************************************************************"
444 W !,"This entry contains a ""1"" or a ""2"" in the ""DEA, SPECIAL HDLG""",!
445 w "field, therefore this item has been UNMARKED for CMOP transmission."
446 W !,"****************************************************************************",!
447 S $P(^PSDRUG(DISPDRG,3),"^")=0
448 kill ^PSDRUG("AQ",DISPDRG)
449 set DA=DISPDRG
450 N %
451 do ^PSSREF
452 quit
Note: See TracBrowser for help on using the repository browser.