source: FOIAVistA/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDDFP.m@ 868

Last change on this file since 868 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.0 KB
Line 
1PSDDFP ;BIR/JPW-Dispense from Pharmacy w/o Green Sheet ; 8 Aug 94
2 ;;3.0; CONTROLLED SUBSTANCES ;**16,66**;13 Feb 97;Build 3
3 ;
4 ;References to ^PSD(58.8, supported by DBIA2711
5 ;References to ^PSDRUG( supported by DBIA #221
6 ;References to ^XUSEC("PSJ RPHARM" supported by DBIA #1095
7 ;
8 I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
9 I '$D(^XUSEC("PSJ RPHARM",DUZ)) W $C(7),!!,?9,"** Please contact your Pharmacy Coordinator for access to",!,?12,"dispense narcotic supplies.",!!,"PSJ RPHARM security key required.",! Q
10 S PSDUZ=DUZ,PSDUZN=$P($G(^VA(200,PSDUZ,0)),"^")
11ASKD ;ask disp loc
12 S PSDS=$P(PSDSITE,U,3),PSDSN=$P(PSDSITE,U,4)
13 I $P(PSDSITE,U,5) S ASK=$P($G(^PSD(58.8,+PSDS,0)),U,5) G CHKD
14 K DIC,DA S DIC=58.8,DIC(0)="QEAZ",DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S($P(^(0),""^"",2)[""M"":1,$P(^(0),""^"",2)[""S"":1,1:0)"
15 S DIC("A")="Select Primary Dispensing Site: ",DIC("B")=PSDSN
16 D ^DIC K DIC G:Y<0 END
17 S PSDS=+Y,PSDSN=$P(Y,"^",2),ASK=$P(Y(0),"^",5)
18 S $P(PSDSITE,U,3)=+Y,$P(PSDSITE,U,4)=PSDSN
19CHKD I '$O(^PSD(58.8,PSDS,1,0)) W !!,"There are no stocked drugs for this Pharmacy Vault!!",!! G END
20DRUG ;select drug
21 S PSDOUT=0 W !
22 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 ***"""
23 S DIC("S")="I '$P($G(^(7)),U,2)"
24 S DA(1)=+PSDS,DIC(0)="QEAMZ",DIC="^PSD(58.8,"_PSDS_",1," D ^DIC K DIC G:Y<0 END S PSDR=+Y,PSDRN=$P($G(^PSDRUG(+PSDR,0)),"^")
25 I '$D(^PSD(58.8,+PSDS,1,+PSDR,0)) W $C(7),!!,?10,"** Your Dispensing Site is missing stock drug data.",!,"Please contact your Pharmacy Coordinator for assistance.",! G END
26 S (MFG,LOT,EXP,EXPD,NBKU,NPKG)="",MFG=$P(^PSD(58.8,+PSDS,1,+PSDR,0),"^",10),LOT=$P(^(0),"^",11),EXP=$P(^(0),"^",12),NBKU=$P(^(0),"^",8),NPKG=$P(^(0),"^",9)
27 I 'NPKG!(NBKU']"") W $C(7),!!,PSDRN," is missing breakdown unit or",!,"package size data in ",PSDSN,"." D MSG G END
28 I EXP S Y=EXP X ^DD("DD") S EXPD=Y
29 ;
30 ;DAVE B (PSD*3*16 - 28APR99) Move lock of 58.8,loc,1,drg up.
31 F L +^PSD(58.8,+PSDS,1,+PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
32 S NBKU=$P(^PSD(58.8,+PSDS,1,+PSDR,0),"^",8),NPKG=+$P(^(0),"^",9)
33 I NBKU']"" W !!,PSDSN,"is missing narcotic breakdown unit",!,"for ",PSDRN,"." G END
34 I 'NPKG W !!,PSDSN,"is missing narcotic package size",!,"for ",PSDRN,"." G END
35NAOU ;select NAOU
36 K DA,DIC S DIC=58.8,DIC(0)="QEA",DIC("A")="Select NAOU: "
37 S DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"""
38 D ^DIC K DIC G:Y<0 END S NAOU=+Y,NAOUN=$P(Y,"^",2)
39QTY K DA,DIR,DIRUT S DIR(0)="58.85,18O",DIR("B")=NPKG,DIR("A")="QUANTITY DISPENSED ("_NBKU_"/"_NPKG_")" D ^DIR K DIR I 'Y!$D(DIRUT) D MSG G END
40 S QTY=+Y I QTY>+$P(^PSD(58.8,PSDS,1,PSDR,0),"^",4) W !!,"The drug balance for this drug is ",+$P(^PSD(58.8,PSDS,1,PSDR,0),"^",4),".",!,"You cannot dispense ",QTY," for this drug.",!! G END
41ASKM I ASK D MFG I PSDOUT D MSG G END
42OK W ! K DA,DIR,DIRUT S DIR(0)="Y",DIR("B")="YES",DIR("A")="Is this OK? ",DIR("?",1)="Answer 'YES' to record dispensing this drug,"
43 S DIR("?")="NO to select another drug or '^' to quit." D ^DIR K DIR
44 I $D(DIRUT) D MSG G END
45 I 'Y D MSG G DRUG
46 D ^PSDDFP1 G:'PSDOUT DRUG
47END K %,%DT,%H,%I,ASK,BAL,DA,DIC,DIE,DIK,DINUM,DIR,DIROUT,DIRUT,DLAYGO,DR,DTOUT,DUOUT,EDIT,EXP,EXPD,LOT,MFG,NAOU,NAOUN,NBKU,NPKG,OK
48 K PSDDT,PSDLES,PSDOUT,PSDREC,PSDRN,PSDSN,PSDUZ,PSDUZN,QTY,TEXP,TLOT,TMFG,X,Y
49 I $D(PSDS),$D(PSDR) L -^PSD(58.8,+PSDS,1,+PSDR)
50 K PSDS,PSDR
51 Q
52MFG K DA,DIR,DTOUT,DUOUT S DIR(0)="58.81,12O",DIR("B")=MFG D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) S PSDOUT=1 Q
53 I Y]"",Y'=MFG S MFG=Y S $P(^PSD(58.8,+PSDS,1,+PSDR,0),"^",10)=MFG
54 K DA,DIR,DTOUT,DUOUT S DIR(0)="58.81,13O",DIR("B")=LOT D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) S PSDOUT=1 Q
55 I Y]"",Y'=LOT S LOT=Y S $P(^PSD(58.8,+PSDS,1,+PSDR,0),"^",11)=LOT
56 K DA,DIR,DTOUT,DUOUT S DIR(0)="58.81,14O",DIR("B")=EXPD D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) S PSDOUT=1 Q
57 I Y,Y'=EXP S EXP=Y W !!,"Updating Expiration Date data..." K DA,DIE,DR S DA=+PSDR,DA(1)=+PSDS,DIE="^PSD(58.8,"_DA(1)_",1,",DR="11///"_EXP D ^DIE K DA,DIE,DR W "done.",!!
58 Q
59MSG W !!,"** No action taken. **",!!
60 Q
Note: See TracBrowser for help on using the repository browser.