source: WorldVistAEHR/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDTRV.m

Last change on this file was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1PSDTRV ;BIR/JPW-Transfer CS Drugs between Vaults ; 10 Aug 94
2 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
3 I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
4 I '$D(^XUSEC("PSJ RPHARM",DUZ)) W $C(7),!!,?9,"** Please contact your Pharmacy Coordinator for access to transfer",!,?12,"controlled substances between dispensing sites.",!!,"PSJ RPHARM security key required.",! Q
5 I $P($G(^VA(200,DUZ,20)),U,4)']"" N XQH S XQH="PSD ESIG" D EN^XQH Q
6 S PSDUZ=DUZ,PSDUZN=$P($G(^VA(200,PSDUZ,0)),"^")
7 N X,X1 D SIG^XUSESIG G:X1="" END
8FROM ;select FROM disp site
9 S (ADD,PSDOUT)=0
10 K DA,DIC W ! S DIC=58.8,DIC(0)="QEA",DIC("A")="Transfer from Dispensing Site: ",DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S($P(^(0),""^"",2)=""M"":1,$P(^(0),""^"",2)=""S"":1,1:0)"
11 D ^DIC K DIC G:Y<0 END S PSDS=+Y,PSDSN=$P(Y,"^",2)
12DRUG ;select drug
13 I '$O(^PSD(58.8,PSDS,1,0)) W !!,"There are no CS stocked drugs for your dispensing vault.",!! S PSDOUT=1 G END
14 W ! K DA,DIC S DIC("W")="W:$P(^PSDRUG(Y,0),""^"",9) "" N/F"" I $P(^PSD(58.8,PSDS,1,Y,0),""^"",14)]"""",$P(^(0),""^"",14)'>DT W $C(7),"" *** INACTIVE ***"""
15 S DIC("A")="Select DRUG From "_PSDSN_": "
16 S DA(1)=+PSDS,DIC(0)="QEAM",DIC="^PSD(58.8,"_PSDS_",1," D ^DIC K DIC
17 I ($D(DTOUT))!($D(DUOUT)) S PSDOUT=1 G END
18 I Y<0,'PSDOUT G FROM
19 S PSDR=+Y,PSDRN=$P($G(^PSDRUG(PSDR,0)),"^"),QTY=+$P($G(^PSD(58.8,PSDS,1,PSDR,0)),"^",4),NBKU=$P(^(0),"^",8),NPKG=$P(^(0),"^",9),MFG=$P(^(0),"^",10),LOT=$P(^(0),"^",11),EXP=$P(^(0),"^",12)
20 I 'QTY W $C(7),!!,PSDRN," has a zero balance.",!,"Please select another drug to transfer.",!! G DRUG
21QTY ;enter quantity
22 W !!,?5,"Breakdown Unit: ",NBKU,?35,"Package Size: ",NPKG,!
23 K DIR,DA S DIR(0)="NO^1:"_QTY_":0"
24 S DIR("A")="Enter Quantity to Transfer"
25 S DIR("?")="Answer with a whole number between 1 and "_QTY
26 D ^DIR K DIR
27 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT) D MSG G END
28 S TQTY=+Y
29TO ;transfer TO disp site (not restricted to inpat site)
30 K DA,DIC W ! S DIC=58.8,DIC(0)="QEA",DIC("A")="Transfer to Dispensing Site: ",DIC("S")="I $S($P(^(0),""^"",2)=""M"":1,$P(^(0),""^"",2)=""S"":1,1:0)"
31 D ^DIC K DIC G:Y<0 END S VAULT=+Y,VAULTN=$P(Y,"^",2)
32CHK I VAULT=PSDS W $C(7),!!,?5,"** NOT ALLOWED to transfer out of and into SAME Dispensing Site! **" G END
33 I '$D(^PSD(58.8,VAULT,1,PSDR,0)) W $C(7),!!,?5,"** ",VAULTN," does not stock ",PSDRN,"! **",! D ADD G:PSDOUT END G ASK
34 I $P(^PSD(58.8,VAULT,1,PSDR,0),"^",8)'=NBKU W $C(7),!!,"** The Narcotic Breakdown Unit does not match." D MSG G END
35ASK ;ask ok
36 W !!,"Transferring: ",TQTY," (",NBKU,")",!,"From: ",PSDSN," To: ",VAULTN,!!
37 K DIR,DIRUT S DIR(0)="Y",DIR("A")="Is this OK",DIR("B")="NO"
38 S DIR("?")="Answer 'YES' to post this transfer, 'NO' or '^' to quit."
39 D ^DIR K DIR I 'Y!$D(DIRUT) D MSG G END
40 D:ADD ADD1 D ^PSDTRV1 G:'PSDOUT DRUG
41END K %,%H,%I,ADD,BAL,CNT,DA,DD,DIC,DIE,DINUM,DIR,DIROUT,DIRUT,DLAYGO,DO,DR,DTOUT,DUOUT,EXP,JJ,LOT,MFG,NBKU,NPKG,PSDT,PSDLES,PSDOUT,PSDR,PSDREC,PSDRN,PSDS,PSDSN
42 K PSDUZ,PSDUZN,QTY,RDT,TEMP,TQTY,VAULT,VAULTN,X,XMDUZ,XMSUB,XMTEXT,XMY,Y
43 Q
44MSG W $C(7),!!,"No action taken.",!!
45 Q
46ADD ;ask to add drug
47 K DIR,DIRUT S DIR(0)="Y",DIR("A")="Do you want to continue"
48 S DIR("?")="Answer 'YES' to continue with this transfer, 'NO' or '^' to quit."
49 D ^DIR K DIR I 'Y!$D(DIRUT) D MSG S PSDOUT=1 Q
50 S ADD=1
51 Q
52ADD1 ;add drug
53 Q:$D(^PSD(58.8,VAULT,1,PSDR,0))
54 S:'$D(^PSD(58.8,VAULT,1,0)) ^PSD(58.8,VAULT,1,0)="^58.8001IP^^"
55 K DA,DIC,DD,DO S DIC(0)="L",DIC="^PSD(58.8,"_+VAULT_",1,",DA(1)=+VAULT,(X,DINUM)=+PSDR D FILE^DICN K DA,DIC
Note: See TracBrowser for help on using the repository browser.