PSDDWK2 ;BIR/JPW-Pharm Dispensing Worksheet (cont'd) ; 21 Jun 93
;;3.0; CONTROLLED SUBSTANCES ;**66**;13 Feb 97;Build 3
PROC ;ver/proc req ord
D CHK Q:PSDLES
S TECH=$S($P($G(^PSD(58.85,PSDN,0)),"^",16):$P(^(0),"^",16),ACT="P":DUZ,1:"") I PSDT="" D NOW^%DTC S PSDT=+%
DISPN ;assign dsp #s
G:$P($G(^PSD(58.85,PSDN,0)),"^",15) EDIT S FLAG=0,ORDS=$S(NEW:ORDS,1:PSDS),PSDAGN=$S(NEW:PSDAGN,1:PSDAG)
I PSDAGN W !!,"Assigning Pharmacy Dispensing #...",! D AUTO Q:PSDOUT G EDIT
ASKN K DIR,DIRUT S DIR(0)="N^1:999999999:0",DIR("A")="PHARMACY DISPENSING #",DIR("?")="Enter your narcotic control number for this order." D ^DIR K DIR
I $D(DIRUT) W !!,"This order cannot be processed without a dispensing number.",!!,"Press <RET> to continue" R X:DTIME Q
I +$O(^PSD(58.81,"D",Y,0)) W !!,"The number "_Y_" has previously been used as a dispensing number.",!,"Please select another number.",!! G ASKN
S PSDPN=Y
EDIT ;edit/add ord
S BAL=0 W !!,"PHARMACY DISPENSING # ",PSDPN,!
K PSDREC I +$P($G(^PSD(58.85,PSDN,0)),"^",8) S PSDREC=$P(^(0),"^",8)
W !!,"Accessing the order...",! D:'$D(PSDREC) ADD D:ACT="V" SUB
W !,"Updating the transaction..."
D UPDATE^PSDDWK3,MSG1
Q
ADD ;find entry number
F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
FIND S PSDREC=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSDREC)) S $P(^PSD(58.81,0),"^",3)=PSDREC G FIND
K DIC,DLAYGO S DIC(0)="L",(DIC,DLAYGO)=58.81,(X,DINUM)=PSDREC D ^DIC K DIC,DINUM,DLAYGO
L -^PSD(58.81,0)
Q
AUTO ;select next available disp #
K MSG I '$P($G(^PSD(58.8,+ORDS,2)),"^",4) S MSG=1 D MSG Q
I $P($G(^PSD(58.8,+ORDS,2)),"^",3)'>$P($G(^PSD(58.8,+ORDS,2)),"^",4) S MSG=0 D MSG Q
F L +^PSD(58.8,+ORDS,2):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
ADDN S PSDPN=$P($G(^PSD(58.8,+ORDS,2)),"^",4)
I +$O(^PSD(58.81,"D",PSDPN,0)) S $P(^PSD(58.8,+ORDS,2),"^",4)=PSDPN+1 G ADDN
S $P(^PSD(58.8,+ORDS,2),"^",4)=PSDPN+1
L -^PSD(58.8,+ORDS,2)
Q
MSG ;prints message
W $C(7),!!," Contact your Pharmacy Co-ordinator.",!," Your ""Dispensing #'s"" range has "_$S(MSG:"not been defined.",1:"been exceeded.") S PSDOUT=1
MSG1 W !!,"Press <RET> to continue" R X:DTIME
I '$T!(X["^") S PSDOUT=1
Q
SUB ;sub qty from dsp site
F L +^PSD(58.8,ORDS,1,PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
D NOW^%DTC S PSDT=+%
S BAL=$P(^PSD(58.8,ORDS,1,PSDR,0),"^",4),$P(^(0),"^",4)=$P(^(0),"^",4)-QTY
L -^PSD(58.8,ORDS,1,PSDR,0)
W !!,"Old Balance : ",BAL,?35,"New Balance :",BAL-QTY,!!
Q
CHK ;check for valid bal
S PSDLES=0 D:QTY>$P(^PSD(58.8,ORDS,1,PSDR,0),"^",4) Q:PSDLES
.W $C(7),!!,"=> The drug balance is "_+$P(^PSD(58.8,ORDS,1,PSDR,0),"^",4)_". You cannot dispense "_QTY_" for this drug.",!,?5,"This order remains "_$P($G(^PSD(58.82,STAT,0)),"^")_".",! S PSDLES=1
.D MSG1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDDWK2 2772 printed Nov 22, 2024@16:55:47 Page 2
PSDDWK2 ;BIR/JPW-Pharm Dispensing Worksheet (cont'd) ; 21 Jun 93
+1 ;;3.0; CONTROLLED SUBSTANCES ;**66**;13 Feb 97;Build 3
PROC ;ver/proc req ord
+1 DO CHK
if PSDLES
QUIT
+2 SET TECH=$SELECT($PIECE($GET(^PSD(58.85,PSDN,0)),"^",16):$PIECE(^(0),"^",16),ACT="P":DUZ,1:"")
IF PSDT=""
DO NOW^%DTC
SET PSDT=+%
DISPN ;assign dsp #s
+1 if $PIECE($GET(^PSD(58.85,PSDN,0)),"^",15)
GOTO EDIT
SET FLAG=0
SET ORDS=$SELECT(NEW:ORDS,1:PSDS)
SET PSDAGN=$SELECT(NEW:PSDAGN,1:PSDAG)
+2 IF PSDAGN
WRITE !!,"Assigning Pharmacy Dispensing #...",!
DO AUTO
if PSDOUT
QUIT
GOTO EDIT
ASKN KILL DIR,DIRUT
SET DIR(0)="N^1:999999999:0"
SET DIR("A")="PHARMACY DISPENSING #"
SET DIR("?")="Enter your narcotic control number for this order."
DO ^DIR
KILL DIR
+1 IF $DATA(DIRUT)
WRITE !!,"This order cannot be processed without a dispensing number.",!!,"Press <RET> to continue"
READ X:DTIME
QUIT
+2 IF +$ORDER(^PSD(58.81,"D",Y,0))
WRITE !!,"The number "_Y_" has previously been used as a dispensing number.",!,"Please select another number.",!!
GOTO ASKN
+3 SET PSDPN=Y
EDIT ;edit/add ord
+1 SET BAL=0
WRITE !!,"PHARMACY DISPENSING # ",PSDPN,!
+2 KILL PSDREC
IF +$PIECE($GET(^PSD(58.85,PSDN,0)),"^",8)
SET PSDREC=$PIECE(^(0),"^",8)
+3 WRITE !!,"Accessing the order...",!
if '$DATA(PSDREC)
DO ADD
if ACT="V"
DO SUB
+4 WRITE !,"Updating the transaction..."
+5 DO UPDATE^PSDDWK3
DO MSG1
+6 QUIT
ADD ;find entry number
+1 FOR
LOCK +^PSD(58.81,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
FIND SET PSDREC=$PIECE(^PSD(58.81,0),"^",3)+1
IF $DATA(^PSD(58.81,PSDREC))
SET $PIECE(^PSD(58.81,0),"^",3)=PSDREC
GOTO FIND
+1 KILL DIC,DLAYGO
SET DIC(0)="L"
SET (DIC,DLAYGO)=58.81
SET (X,DINUM)=PSDREC
DO ^DIC
KILL DIC,DINUM,DLAYGO
+2 LOCK -^PSD(58.81,0)
+3 QUIT
AUTO ;select next available disp #
+1 KILL MSG
IF '$PIECE($GET(^PSD(58.8,+ORDS,2)),"^",4)
SET MSG=1
DO MSG
QUIT
+2 IF $PIECE($GET(^PSD(58.8,+ORDS,2)),"^",3)'>$PIECE($GET(^PSD(58.8,+ORDS,2)),"^",4)
SET MSG=0
DO MSG
QUIT
+3 FOR
LOCK +^PSD(58.8,+ORDS,2):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
ADDN SET PSDPN=$PIECE($GET(^PSD(58.8,+ORDS,2)),"^",4)
+1 IF +$ORDER(^PSD(58.81,"D",PSDPN,0))
SET $PIECE(^PSD(58.8,+ORDS,2),"^",4)=PSDPN+1
GOTO ADDN
+2 SET $PIECE(^PSD(58.8,+ORDS,2),"^",4)=PSDPN+1
+3 LOCK -^PSD(58.8,+ORDS,2)
+4 QUIT
MSG ;prints message
+1 WRITE $CHAR(7),!!," Contact your Pharmacy Co-ordinator.",!," Your ""Dispensing #'s"" range has "_$SELECT(MSG:"not been defined.",1:"been exceeded.")
SET PSDOUT=1
MSG1 WRITE !!,"Press <RET> to continue"
READ X:DTIME
+1 IF '$TEST!(X["^")
SET PSDOUT=1
+2 QUIT
SUB ;sub qty from dsp site
+1 FOR
LOCK +^PSD(58.8,ORDS,1,PSDR,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+2 DO NOW^%DTC
SET PSDT=+%
+3 SET BAL=$PIECE(^PSD(58.8,ORDS,1,PSDR,0),"^",4)
SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)-QTY
+4 LOCK -^PSD(58.8,ORDS,1,PSDR,0)
+5 WRITE !!,"Old Balance : ",BAL,?35,"New Balance :",BAL-QTY,!!
+6 QUIT
CHK ;check for valid bal
+1 SET PSDLES=0
if QTY>$PIECE(^PSD(58.8,ORDS,1,PSDR,0),"^",4)
Begin DoDot:1
+2 WRITE $CHAR(7),!!,"=> The drug balance is "_+$PIECE(^PSD(58.8,ORDS,1,PSDR,0),"^",4)_". You cannot dispense "_QTY_" for this drug.",!,?5,"This order remains "_$PIECE($GET(^PSD(58.82,STAT,0)),"^")_".",!
SET PSDLES=1
+3 DO MSG1
End DoDot:1
if PSDLES
QUIT
