PSDNDES.m

PSDNDES ;BIR/JPW-Dispense from Pharmacy w/o Green Sheet ; 8 Aug 94

 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97

 I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)

 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

 S PSDUZ=DUZ,PSDUZN=$P($G(^VA(200,PSDUZ,0)),"^")

TEST ;to be reworked for narcotic disp equipment

 W !!,"For now this option is the same as dispense w/o green sheet.",!!

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 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

 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,PSDR,PSDREC,PSDRN,PSDS,PSDSN,PSDUZ,PSDUZN,QTY,TEXP,TLOT,TMFG,X,Y

 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

PSDNDES   ;BIR/JPW-Dispense from Pharmacy w/o Green Sheet ; 8 Aug 94

 +1       ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97

 +2        IF '$DATA(PSDSITE)

               DO ^PSDSET

               IF '$DATA(PSDSITE)

                   QUIT 

 +3        IF '$DATA(^XUSEC("PSJ RPHARM",DUZ))

               WRITE $CHAR(7),!!,?9,"** Please contact your Pharmacy Coordinator for access to",!,?12,"dispense narcotic supplies.  PSJ RPHARM security key required.",!

               QUIT 

 +4        SET PSDUZ=DUZ

           SET PSDUZN=$PIECE($GET(^VA(200,PSDUZ,0)),"^")

TEST      ;to be reworked for narcotic disp equipment

 +1        WRITE !!,"For now this option is the same as dispense w/o green sheet.",!!

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 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)),"^")

 +4        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

 +5        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)

 +6        IF 'NPKG!(NBKU']"")

               WRITE $CHAR(7),!!,PSDRN," is missing breakdown unit or",!,"package size data in ",PSDSN,"."

               DO MSG

               GOTO END

 +7        IF EXP

               SET Y=EXP

               XECUTE ^DD("DD")

               SET EXPD=Y

 +8        SET NBKU=$PIECE(^PSD(58.8,+PSDS,1,+PSDR,0),"^",8)

           SET NPKG=+$PIECE(^(0),"^",9)

 +9        IF NBKU']""

               WRITE !!,PSDSN,"is missing narcotic breakdown unit",!,"for ",PSDRN,"."

               GOTO END

 +10       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,PSDR,PSDREC,PSDRN,PSDS,PSDSN,PSDUZ,PSDUZN,QTY,TEXP,TLOT,TMFG,X,Y

 +2        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