PSDDFP ;BIR/JPW-Dispense from Pharmacy w/o Green Sheet ; 8 Aug 94
;;3.0; CONTROLLED SUBSTANCES ;**16,66,69**;13 Feb 97;Build 13
;
;References to ^PSD(58.8, supported by DBIA2711
;References to ^PSD(58.81 supported by DBIA2808
;References to ^PSDRUG( supported by DBIA #221
;References to ^XUSEC("PSJ RPHARM" supported by DBIA #1095
;
I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
I '$D(^XUSEC("PSJ RPHARM",DUZ)),'$D(^XUSEC("PSD TECH ADV",DUZ)) W $C(7),!!,?9,"** Please contact your Pharmacy Coordinator for access to",!,?12,"dispense narcotic supplies.",!!,"PSJ RPHARM or PSD TECH ADV security key required.",! Q
S PSDUZ=DUZ,PSDUZN=$P($G(^VA(200,PSDUZ,0)),"^")
ASKD ;ask disp loc
S PSDS=$P(PSDSITE,U,3),PSDSN=$P(PSDSITE,U,4)
I $P(PSDSITE,U,5) S ASK=$P($G(^PSD(58.8,+PSDS,0)),U,5) G CHKD
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)"
S DIC("A")="Select Primary Dispensing Site: ",DIC("B")=PSDSN
D ^DIC K DIC G:Y<0 END
S PSDS=+Y,PSDSN=$P(Y,"^",2),ASK=$P(Y(0),"^",5)
S $P(PSDSITE,U,3)=+Y,$P(PSDSITE,U,4)=PSDSN
CHKD I '$O(^PSD(58.8,PSDS,1,0)) W !!,"There are no stocked drugs for this Pharmacy Vault!!",!! G END
DRUG ;select drug
S PSDOUT=0 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 ***"""
S DIC("S")="I '$P($G(^(7)),U,2)"
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)),"^")
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
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)
I 'NPKG!(NBKU']"") W $C(7),!!,PSDRN," is missing breakdown unit or",!,"package size data in ",PSDSN,"." D MSG G END
I EXP S Y=EXP X ^DD("DD") S EXPD=Y
;
;DAVE B (PSD*3*16 - 28APR99) Move lock of 58.8,loc,1,drg up.
F L +^PSD(58.8,+PSDS,1,+PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
S NBKU=$P(^PSD(58.8,+PSDS,1,+PSDR,0),"^",8),NPKG=+$P(^(0),"^",9)
I NBKU']"" W !!,PSDSN,"is missing narcotic breakdown unit",!,"for ",PSDRN,"." G END
I 'NPKG W !!,PSDSN,"is missing narcotic package size",!,"for ",PSDRN,"." G END
NAOU ;select NAOU
K DA,DIC S DIC=58.8,DIC(0)="QEA",DIC("A")="Select NAOU: "
S DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"""
D ^DIC K DIC G:Y<0 END S NAOU=+Y,NAOUN=$P(Y,"^",2)
QTY 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
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
ASKM I ASK D MFG I PSDOUT D MSG G END
OK 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,"
S DIR("?")="NO to select another drug or '^' to quit." D ^DIR K DIR
I $D(DIRUT) D MSG G END
I 'Y D MSG G DRUG
D ^PSDDFP1 G:'PSDOUT DRUG
END 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
K PSDDT,PSDLES,PSDOUT,PSDREC,PSDRN,PSDSN,PSDUZ,PSDUZN,QTY,TEXP,TLOT,TMFG,X,Y
I $D(PSDS),$D(PSDR) L -^PSD(58.8,+PSDS,1,+PSDR)
K PSDS,PSDR
Q
MFG 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
I Y]"",Y'=MFG S MFG=Y S $P(^PSD(58.8,+PSDS,1,+PSDR,0),"^",10)=MFG
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
I Y]"",Y'=LOT S LOT=Y S $P(^PSD(58.8,+PSDS,1,+PSDR,0),"^",11)=LOT
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
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.",!!
Q
MSG W !!,"** No action taken. **",!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDDFP 4300 printed Dec 13, 2024@01:45:29 Page 2
PSDDFP ;BIR/JPW-Dispense from Pharmacy w/o Green Sheet ; 8 Aug 94
+1 ;;3.0; CONTROLLED SUBSTANCES ;**16,66,69**;13 Feb 97;Build 13
+2 ;
+3 ;References to ^PSD(58.8, supported by DBIA2711
+4 ;References to ^PSD(58.81 supported by DBIA2808
+5 ;References to ^PSDRUG( supported by DBIA #221
+6 ;References to ^XUSEC("PSJ RPHARM" supported by DBIA #1095
+7 ;
+8 IF '$DATA(PSDSITE)
DO ^PSDSET
if '$DATA(PSDSITE)
QUIT
+9 IF '$DATA(^XUSEC("PSJ RPHARM",DUZ))
IF '$DATA(^XUSEC("PSD TECH ADV",DUZ))
WRITE $CHAR(7),!!,?9,"** Please contact your Pharmacy Coordinator for access to",!,?12,"dispense narcotic supplies.",!!,"PSJ RPHARM or PSD TECH ADV security key required.",!
QUIT
+10 SET PSDUZ=DUZ
SET PSDUZN=$PIECE($GET(^VA(200,PSDUZ,0)),"^")
ASKD ;ask disp loc
+1 SET PSDS=$PIECE(PSDSITE,U,3)
SET PSDSN=$PIECE(PSDSITE,U,4)
+2 IF $PIECE(PSDSITE,U,5)
SET ASK=$PIECE($GET(^PSD(58.8,+PSDS,0)),U,5)
GOTO CHKD
+3 KILL DIC,DA
SET DIC=58.8
SET DIC(0)="QEAZ"
SET DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S($P(^(0),""^"",2)[""M"":1,$P(^(0),""^"",2)[""S"":1,1:0)"
+4 SET DIC("A")="Select Primary Dispensing Site: "
SET DIC("B")=PSDSN
+5 DO ^DIC
KILL DIC
if Y<0
GOTO END
+6 SET PSDS=+Y
SET PSDSN=$PIECE(Y,"^",2)
SET ASK=$PIECE(Y(0),"^",5)
+7 SET $PIECE(PSDSITE,U,3)=+Y
SET $PIECE(PSDSITE,U,4)=PSDSN
CHKD IF '$ORDER(^PSD(58.8,PSDS,1,0))
WRITE !!,"There are no stocked drugs for this Pharmacy Vault!!",!!
GOTO END
DRUG ;select drug
+1 SET PSDOUT=0
WRITE !
+2 KILL DA,DIC
SET 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 ***"""
+3 SET DIC("S")="I '$P($G(^(7)),U,2)"
+4 SET DA(1)=+PSDS
SET DIC(0)="QEAMZ"
SET DIC="^PSD(58.8,"_PSDS_",1,"
DO ^DIC
KILL DIC
if Y<0
GOTO END
SET PSDR=+Y
SET PSDRN=$PIECE($GET(^PSDRUG(+PSDR,0)),"^")
+5 IF '$DATA(^PSD(58.8,+PSDS,1,+PSDR,0))
WRITE $CHAR(7),!!,?10,"** Your Dispensing Site is missing stock drug data.",!,"Please contact your Pharmacy Coordinator for assistance.",!
GOTO END
+6 SET (MFG,LOT,EXP,EXPD,NBKU,NPKG)=""
SET MFG=$PIECE(^PSD(58.8,+PSDS,1,+PSDR,0),"^",10)
SET LOT=$PIECE(^(0),"^",11)
SET EXP=$PIECE(^(0),"^",12)
SET NBKU=$PIECE(^(0),"^",8)
SET NPKG=$PIECE(^(0),"^",9)
+7 IF 'NPKG!(NBKU']"")
WRITE $CHAR(7),!!,PSDRN," is missing breakdown unit or",!,"package size data in ",PSDSN,"."
DO MSG
GOTO END
+8 IF EXP
SET Y=EXP
XECUTE ^DD("DD")
SET EXPD=Y
+9 ;
+10 ;DAVE B (PSD*3*16 - 28APR99) Move lock of 58.8,loc,1,drg up.
+11 FOR
LOCK +^PSD(58.8,+PSDS,1,+PSDR,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+12 SET NBKU=$PIECE(^PSD(58.8,+PSDS,1,+PSDR,0),"^",8)
SET NPKG=+$PIECE(^(0),"^",9)
+13 IF NBKU']""
WRITE !!,PSDSN,"is missing narcotic breakdown unit",!,"for ",PSDRN,"."
GOTO END
+14 IF 'NPKG
WRITE !!,PSDSN,"is missing narcotic package size",!,"for ",PSDRN,"."
GOTO END
NAOU ;select NAOU
+1 KILL DA,DIC
SET DIC=58.8
SET DIC(0)="QEA"
SET DIC("A")="Select NAOU: "
+2 SET DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"""
+3 DO ^DIC
KILL DIC
if Y<0
GOTO END
SET NAOU=+Y
SET NAOUN=$PIECE(Y,"^",2)
QTY KILL DA,DIR,DIRUT
SET DIR(0)="58.85,18O"
SET DIR("B")=NPKG
SET DIR("A")="QUANTITY DISPENSED ("_NBKU_"/"_NPKG_")"
DO ^DIR
KILL DIR
IF 'Y!$DATA(DIRUT)
DO MSG
GOTO END
+1 SET QTY=+Y
IF QTY>+$PIECE(^PSD(58.8,PSDS,1,PSDR,0),"^",4)
WRITE !!,"The drug balance for this drug is ",+$PIECE(^PSD(58.8,PSDS,1,PSDR,0),"^",4),".",!,"You cannot dispense ",QTY," for this drug.",!!
GOTO END
ASKM IF ASK
DO MFG
IF PSDOUT
DO MSG
GOTO END
OK WRITE !
KILL DA,DIR,DIRUT
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Is this OK? "
SET DIR("?",1)="Answer 'YES' to record dispensing this drug,"
+1 SET DIR("?")="NO to select another drug or '^' to quit."
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
DO MSG
GOTO END
+3 IF 'Y
DO MSG
GOTO DRUG
+4 DO ^PSDDFP1
if 'PSDOUT
GOTO DRUG
END KILL %,%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
+1 KILL PSDDT,PSDLES,PSDOUT,PSDREC,PSDRN,PSDSN,PSDUZ,PSDUZN,QTY,TEXP,TLOT,TMFG,X,Y
+2 IF $DATA(PSDS)
IF $DATA(PSDR)
LOCK -^PSD(58.8,+PSDS,1,+PSDR)
+3 KILL PSDS,PSDR
+4 QUIT
MFG KILL DA,DIR,DTOUT,DUOUT
SET DIR(0)="58.81,12O"
SET DIR("B")=MFG
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
SET PSDOUT=1
QUIT
+1 IF Y]""
IF Y'=MFG
SET MFG=Y
SET $PIECE(^PSD(58.8,+PSDS,1,+PSDR,0),"^",10)=MFG
+2 KILL DA,DIR,DTOUT,DUOUT
SET DIR(0)="58.81,13O"
SET DIR("B")=LOT
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
SET PSDOUT=1
QUIT
+3 IF Y]""
IF Y'=LOT
SET LOT=Y
SET $PIECE(^PSD(58.8,+PSDS,1,+PSDR,0),"^",11)=LOT
+4 KILL DA,DIR,DTOUT,DUOUT
SET DIR(0)="58.81,14O"
SET DIR("B")=EXPD
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
SET PSDOUT=1
QUIT
+5 IF Y
IF Y'=EXP
SET EXP=Y
WRITE !!,"Updating Expiration Date data..."
KILL DA,DIE,DR
SET DA=+PSDR
SET DA(1)=+PSDS
SET DIE="^PSD(58.8,"_DA(1)_",1,"
SET DR="11///"_EXP
DO ^DIE
KILL DA,DIE,DR
WRITE "done.",!!
+6 QUIT
MSG WRITE !!,"** No action taken. **",!!
+1 QUIT
