PSDDWK ;BIR/JPW-Pharm Dispensing Worksheet ;6 July 94
;;3.0; CONTROLLED SUBSTANCES ;**59,69**;13 Feb 97;Build 13
;References to ^PSD(58.8, supported by DBIA2711
;References to ^PSDRUG( supported by DBIA #221
;
I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
S OK=$S($D(^XUSEC("PSJ RPHARM",DUZ)):1,$D(^XUSEC("PSJ PHARM TECH",DUZ)):1,$D(^XUSEC("PSD TECH ADV",DUZ)):1,1:0)
I 'OK W $C(7),!!,?9,"** Please contact your Pharmacy Coordinator for access to",!,?12,"process/dispense narcotic supplies.",!!,"PSJ RPHARM, PSJ PHARM TECH or PSD TECH ADV security key required.",! K OK Q
I $P($G(^VA(200,DUZ,20)),U,4)']"" N XQH S XQH="PSD ESIG" D EN^XQH Q
I '$O(^PSD(58.85,0)) W $C(7),!!,"There are no pending request orders.",!! Q
S (PSDNO,NOFLAG)=0
ASKD ;ask dispensing location
S PSDS=$P(PSDSITE,U,3),PSDSN=$P(PSDSITE,U,4)
I $P(PSDSITE,U,5) S OKD=1,NODED=^PSD(58.8,+PSDS,0) G SETD
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
;set PSDS=disp.site,PSDM=ask mfg/lot#/exp.date,SITE=inpat.site,PSDAG=auto gen.disp.#s,PSDRG=using form 10-179,PSDGS=print green sheet
S PSDS=+Y,PSDSN=$P(Y,"^",2),NODED=Y(0)
S $P(PSDSITE,U,3)=+Y,$P(PSDSITE,U,4)=PSDSN
SETD S PSDM=+$P(NODED,"^",5),PSDAG=+$P($G(^PSD(58.8,+PSDS,2)),"^")
S PSDRG=+$P($G(^PSD(58.8,+PSDS,2)),"^",5),PSDGS=+$P($G(^PSD(58.8,+PSDS,2)),"^",6)
I '$D(^PSD(58.85,"AW",+PSDS)) D MSG G END
ASKM ;ask method of dispensing - by worksheet or individual request
K DA,DIR,DIRUT S DIR(0)="SOB^W:Worksheet;R:Individual Request",DIR("A")="Dispensing Method"
S DIR("?",1)="Enter 'W' to dispense by last worksheet printed, enter 'R' to",DIR("?")="dispense by individual request, or '^' to quit"
D ^DIR K DIR G:$D(DIRUT) END S ANS=Y
S PSDOUT=0 N X,X1 D SIG^XUSESIG G:X1="" END D:ANS="R" REQ D:ANS="W" WK
I 'NOFLAG D MSG
END K %,%H,%I,%ZIS,ACT,ALL,ANS,BAL,CNT,COMM,DA,DIC,DIE,DIR,DIROUT,DIRUT,DIWF,DIWL,DIWR,DR,DTOUT,DUOUT,EXP,EXPD,FLAG
K LN,LOOP,LOT,MFG,MSG,NAOU,NAOUN,NBKU,NEW,NODE,NODED,NOFLAG,NPKG,NSITE,OK,OKD,ORD,ORDN,ORDS,ORDSN,PAT,PSDLCK
K PRT,PSD,PSDAG,PSDAGN,PSDBY,PSDBYN,PSDDT,PSDG,PSDGS,PSDGSN,PSDIO,PSDLES,PSDM,PSDMN,PSDN,PSDNA,PSDNO,PSDOUT,PSDPN
K PSDR,PSDRN,PSDREC,PSDRG,PSDRGN,PSDRN,PSDS,PSDSN,PSDT,PSDUZA,QTY,REQ,REQD,REQDT,SITE,STAT,TECH,TEXT,WORD,X,Y
Q
WK ;compile worksheet dispensing data
W !!,"Accessing worksheet information..."
F PSD=0:0 S PSD=$O(^PSD(58.85,"AW",+PSDS,PSD)) Q:('PSD)!(PSDOUT) D
.F PSDN=0:0 S PSDN=$O(^PSD(58.85,"AW",+PSDS,PSD,PSDN)) Q:('PSDN)!(PSDOUT) I $D(^PSD(58.85,PSDN,0)) D SET Q:PSDLCK D:STAT<3&($D(^PSD(58.8,+$G(ORDS),1,+$G(PSDR)))) ^PSDDWK1,PSDLCK Q:PSDOUT ;; PSD*3*59 ADDED PSDLCK
Q
REQ ;dispense by individual request
W !!,"Accessing worksheet information..."
F PSD=0:0 S PSD=$O(^PSD(58.85,"AW",+PSDS,PSD)) Q:'PSD F PSDN=0:0 S PSDN=$O(^PSD(58.85,"AW",+PSDS,PSD,PSDN)) Q:'PSDN I $D(^PSD(58.85,PSDN,0)),$P(^(0),"^",7)<3 S NOFLAG=1
Q:'NOFLAG
K DA,DIC W ! S DIC=58.85,DIC(0)="QEA",DIC("A")="Select Request #: ",DIC("S")="I $P(^(0),""^"",2)=+PSDS,$P(^(0),""^"",7)<3" D ^DIC K DIC Q:Y<0 S PSDN=+Y D SET
I PSDLCK W !!,"This request is currently being processed by ",$P(^VA(200,$P(^XTMP("PSDLCK",PSDN,0),"^",3),0),"^") G REQ ;; PSD*3*59 LOCK MESSAGE
I STAT>2 W !!,"The status of this request is "_$P($G(^PSD(58.82,STAT,0)),"^")_".",!,"You cannot edit this request using this option.",! G REQ
D ^PSDDWK1,PSDLCK Q:PSDOUT ;; PSD*3*59 ADDED PSDLCK
G REQ
SET ;sets data for display/editing
Q:'$D(^PSD(58.85,PSDN,0)) S NODE=^(0),(NSITE,PSDMN,PSDAGN,PSDRGN,PSDGSN)=0
;; PSD*3*59 LOCK RECORD
S PSDLCK=0
S STAT=+$P(NODE,"^",7) Q:STAT>2 S PSDRN=+$P(NODE,"^",5)
L +^PSD(58.85,PSDN):0
S:'$T PSDLCK=1 Q:PSDLCK
S ^XTMP("PSDLCK",PSDN,0)=$$FMADD^XLFDT(DT,1,0,0,0)_"^"_DT_"^"_DUZ ;; END PSD*3*59
S NAOU=+$P(NODE,"^",3),NAOUN=$S($P($G(^PSD(58.8,NAOU,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_NAOU)
S PSDR=+$P(NODE,"^",4),PSDRN=$S($P($G(^PSDRUG(PSDR,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSDR)
S ORDS=+$P(NODE,"^",2),ORDSN=$P($G(^PSD(58.8,+ORDS,0)),"^")
S PSDUZA=+$P(NODE,"^",19)
S REQ=+$P(NODE,"^",5),REQDT=$P(NODE,"^",18) I REQDT S Y=$E(REQDT,1,7) X ^DD("DD") S REQD=Y
S QTY=$S($P(NODE,"^",17):$P(NODE,"^",17),1:$P(NODE,"^",6)),PSDPN=$P(NODE,"^",15),PSDT=$P(NODE,"^",14) I PSDT S Y=$E(PSDT,1,7) X ^DD("DD") S PSDDT=Y
S ORD=+$P(NODE,"^",12),ORDN=$P($G(^VA(200,+ORD,0)),"^"),PSDBY=+$P(NODE,"^",13),PSDBYN="" I PSDBY S PSDBYN=$P($G(^VA(200,PSDBY,0)),"^")
S PAT=$P($G(^PSD(58.85,PSDN,2)),U,3)
I $D(^XUSEC("PSJ RPHARM",DUZ)),'PSDBY S PSDBY=DUZ,PSDBYN=$P($G(^VA(200,PSDBY,0)),"^")
S (MFG,LOT,EXP,EXPD,NBKU,NPKG)=""
I $D(^PSD(58.8,+ORDS,1,PSDR,0)) S MFG=$P(^(0),"^",10),LOT=$P(^(0),"^",11),EXP=$P(^(0),"^",12),NBKU=$P(^(0),"^",8),NPKG=+$P(^(0),"^",9) I EXP S Y=EXP X ^DD("DD") S EXPD=Y
Q
MSG W $C(7),!!,"There are no pending CS requests for ",PSDSN,".",!
W !,"Press <RET> to return to the menu" R X:DTIME W !!
Q
PSDLCK ;; PSD*3*59 CLEAR LOCKS FOR THIS ORDER
L -^PSD(58.85,PSDN)
K ^XTMP("PSDLCK",PSDN),STAT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDDWK 5147 printed Oct 16, 2024@17:46:25 Page 2
PSDDWK ;BIR/JPW-Pharm Dispensing Worksheet ;6 July 94
+1 ;;3.0; CONTROLLED SUBSTANCES ;**59,69**;13 Feb 97;Build 13
+2 ;References to ^PSD(58.8, supported by DBIA2711
+3 ;References to ^PSDRUG( supported by DBIA #221
+4 ;
+5 IF '$DATA(PSDSITE)
DO ^PSDSET
if '$DATA(PSDSITE)
QUIT
+6 SET OK=$SELECT($DATA(^XUSEC("PSJ RPHARM",DUZ)):1,$DATA(^XUSEC("PSJ PHARM TECH",DUZ)):1,$DATA(^XUSEC("PSD TECH ADV",DUZ)):1,1:0)
+7 IF 'OK
WRITE $CHAR(7),!!,?9,"** Please contact your Pharmacy Coordinator for access to",!,?12,"process/dispense narcotic supplies.",!!,"PSJ RPHARM, PSJ PHARM TECH or PSD TECH ADV security key required.",!
KILL OK
QUIT
+8 IF $PIECE($GET(^VA(200,DUZ,20)),U,4)']""
NEW XQH
SET XQH="PSD ESIG"
DO EN^XQH
QUIT
+9 IF '$ORDER(^PSD(58.85,0))
WRITE $CHAR(7),!!,"There are no pending request orders.",!!
QUIT
+10 SET (PSDNO,NOFLAG)=0
ASKD ;ask dispensing location
+1 SET PSDS=$PIECE(PSDSITE,U,3)
SET PSDSN=$PIECE(PSDSITE,U,4)
+2 IF $PIECE(PSDSITE,U,5)
SET OKD=1
SET NODED=^PSD(58.8,+PSDS,0)
GOTO SETD
+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=disp.site,PSDM=ask mfg/lot#/exp.date,SITE=inpat.site,PSDAG=auto gen.disp.#s,PSDRG=using form 10-179,PSDGS=print green sheet
+7 SET PSDS=+Y
SET PSDSN=$PIECE(Y,"^",2)
SET NODED=Y(0)
+8 SET $PIECE(PSDSITE,U,3)=+Y
SET $PIECE(PSDSITE,U,4)=PSDSN
SETD SET PSDM=+$PIECE(NODED,"^",5)
SET PSDAG=+$PIECE($GET(^PSD(58.8,+PSDS,2)),"^")
+1 SET PSDRG=+$PIECE($GET(^PSD(58.8,+PSDS,2)),"^",5)
SET PSDGS=+$PIECE($GET(^PSD(58.8,+PSDS,2)),"^",6)
+2 IF '$DATA(^PSD(58.85,"AW",+PSDS))
DO MSG
GOTO END
ASKM ;ask method of dispensing - by worksheet or individual request
+1 KILL DA,DIR,DIRUT
SET DIR(0)="SOB^W:Worksheet;R:Individual Request"
SET DIR("A")="Dispensing Method"
+2 SET DIR("?",1)="Enter 'W' to dispense by last worksheet printed, enter 'R' to"
SET DIR("?")="dispense by individual request, or '^' to quit"
+3 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
SET ANS=Y
+4 SET PSDOUT=0
NEW X,X1
DO SIG^XUSESIG
if X1=""
GOTO END
if ANS="R"
DO REQ
if ANS="W"
DO WK
+5 IF 'NOFLAG
DO MSG
END KILL %,%H,%I,%ZIS,ACT,ALL,ANS,BAL,CNT,COMM,DA,DIC,DIE,DIR,DIROUT,DIRUT,DIWF,DIWL,DIWR,DR,DTOUT,DUOUT,EXP,EXPD,FLAG
+1 KILL LN,LOOP,LOT,MFG,MSG,NAOU,NAOUN,NBKU,NEW,NODE,NODED,NOFLAG,NPKG,NSITE,OK,OKD,ORD,ORDN,ORDS,ORDSN,PAT,PSDLCK
+2 KILL PRT,PSD,PSDAG,PSDAGN,PSDBY,PSDBYN,PSDDT,PSDG,PSDGS,PSDGSN,PSDIO,PSDLES,PSDM,PSDMN,PSDN,PSDNA,PSDNO,PSDOUT,PSDPN
+3 KILL PSDR,PSDRN,PSDREC,PSDRG,PSDRGN,PSDRN,PSDS,PSDSN,PSDT,PSDUZA,QTY,REQ,REQD,REQDT,SITE,STAT,TECH,TEXT,WORD,X,Y
+4 QUIT
WK ;compile worksheet dispensing data
+1 WRITE !!,"Accessing worksheet information..."
+2 FOR PSD=0:0
SET PSD=$ORDER(^PSD(58.85,"AW",+PSDS,PSD))
if ('PSD)!(PSDOUT)
QUIT
Begin DoDot:1
+3 ;; PSD*3*59 ADDED PSDLCK
FOR PSDN=0:0
SET PSDN=$ORDER(^PSD(58.85,"AW",+PSDS,PSD,PSDN))
if ('PSDN)!(PSDOUT)
QUIT
IF $DATA(^PSD(58.85,PSDN,0))
DO SET
if PSDLCK
QUIT
if STAT<3&($DATA(^PSD(58.8,+$GET(ORDS),1,+$GET(PSDR))))
DO ^PSDDWK1
DO PSDLCK
if PSDOUT
QUIT
End DoDot:1
+4 QUIT
REQ ;dispense by individual request
+1 WRITE !!,"Accessing worksheet information..."
+2 FOR PSD=0:0
SET PSD=$ORDER(^PSD(58.85,"AW",+PSDS,PSD))
if 'PSD
QUIT
FOR PSDN=0:0
SET PSDN=$ORDER(^PSD(58.85,"AW",+PSDS,PSD,PSDN))
if 'PSDN
QUIT
IF $DATA(^PSD(58.85,PSDN,0))
IF $PIECE(^(0),"^",7)<3
SET NOFLAG=1
+3 if 'NOFLAG
QUIT
+4 KILL DA,DIC
WRITE !
SET DIC=58.85
SET DIC(0)="QEA"
SET DIC("A")="Select Request #: "
SET DIC("S")="I $P(^(0),""^"",2)=+PSDS,$P(^(0),""^"",7)<3"
DO ^DIC
KILL DIC
if Y<0
QUIT
SET PSDN=+Y
DO SET
+5 ;; PSD*3*59 LOCK MESSAGE
IF PSDLCK
WRITE !!,"This request is currently being processed by ",$PIECE(^VA(200,$PIECE(^XTMP("PSDLCK",PSDN,0),"^",3),0),"^")
GOTO REQ
+6 IF STAT>2
WRITE !!,"The status of this request is "_$PIECE($GET(^PSD(58.82,STAT,0)),"^")_".",!,"You cannot edit this request using this option.",!
GOTO REQ
+7 ;; PSD*3*59 ADDED PSDLCK
DO ^PSDDWK1
DO PSDLCK
if PSDOUT
QUIT
+8 GOTO REQ
SET ;sets data for display/editing
+1 if '$DATA(^PSD(58.85,PSDN,0))
QUIT
SET NODE=^(0)
SET (NSITE,PSDMN,PSDAGN,PSDRGN,PSDGSN)=0
+2 ;; PSD*3*59 LOCK RECORD
+3 SET PSDLCK=0
+4 SET STAT=+$PIECE(NODE,"^",7)
if STAT>2
QUIT
SET PSDRN=+$PIECE(NODE,"^",5)
+5 LOCK +^PSD(58.85,PSDN):0
+6 if '$TEST
SET PSDLCK=1
if PSDLCK
QUIT
+7 ;; END PSD*3*59
SET ^XTMP("PSDLCK",PSDN,0)=$$FMADD^XLFDT(DT,1,0,0,0)_"^"_DT_"^"_DUZ
+8 SET NAOU=+$PIECE(NODE,"^",3)
SET NAOUN=$SELECT($PIECE($GET(^PSD(58.8,NAOU,0)),"^")]"":$PIECE(^(0),"^"),1:"ZZ/"_NAOU)
+9 SET PSDR=+$PIECE(NODE,"^",4)
SET PSDRN=$SELECT($PIECE($GET(^PSDRUG(PSDR,0)),"^")]"":$PIECE(^(0),"^"),1:"ZZ/"_PSDR)
+10 SET ORDS=+$PIECE(NODE,"^",2)
SET ORDSN=$PIECE($GET(^PSD(58.8,+ORDS,0)),"^")
+11 SET PSDUZA=+$PIECE(NODE,"^",19)
+12 SET REQ=+$PIECE(NODE,"^",5)
SET REQDT=$PIECE(NODE,"^",18)
IF REQDT
SET Y=$EXTRACT(REQDT,1,7)
XECUTE ^DD("DD")
SET REQD=Y
+13 SET QTY=$SELECT($PIECE(NODE,"^",17):$PIECE(NODE,"^",17),1:$PIECE(NODE,"^",6))
SET PSDPN=$PIECE(NODE,"^",15)
SET PSDT=$PIECE(NODE,"^",14)
IF PSDT
SET Y=$EXTRACT(PSDT,1,7)
XECUTE ^DD("DD")
SET PSDDT=Y
+14 SET ORD=+$PIECE(NODE,"^",12)
SET ORDN=$PIECE($GET(^VA(200,+ORD,0)),"^")
SET PSDBY=+$PIECE(NODE,"^",13)
SET PSDBYN=""
IF PSDBY
SET PSDBYN=$PIECE($GET(^VA(200,PSDBY,0)),"^")
+15 SET PAT=$PIECE($GET(^PSD(58.85,PSDN,2)),U,3)
+16 IF $DATA(^XUSEC("PSJ RPHARM",DUZ))
IF 'PSDBY
SET PSDBY=DUZ
SET PSDBYN=$PIECE($GET(^VA(200,PSDBY,0)),"^")
+17 SET (MFG,LOT,EXP,EXPD,NBKU,NPKG)=""
+18 IF $DATA(^PSD(58.8,+ORDS,1,PSDR,0))
SET MFG=$PIECE(^(0),"^",10)
SET LOT=$PIECE(^(0),"^",11)
SET EXP=$PIECE(^(0),"^",12)
SET NBKU=$PIECE(^(0),"^",8)
SET NPKG=+$PIECE(^(0),"^",9)
IF EXP
SET Y=EXP
XECUTE ^DD("DD")
SET EXPD=Y
+19 QUIT
MSG WRITE $CHAR(7),!!,"There are no pending CS requests for ",PSDSN,".",!
+1 WRITE !,"Press <RET> to return to the menu"
READ X:DTIME
WRITE !!
+2 QUIT
PSDLCK ;; PSD*3*59 CLEAR LOCKS FOR THIS ORDER
+1 LOCK -^PSD(58.85,PSDN)
+2 KILL ^XTMP("PSDLCK",PSDN),STAT
+3 QUIT
