source: cprs/branches/tmg-cprs/m_files/TMGPSSDEE.m@ 859

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

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