- 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 Mar 13, 2025@20:50:15 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
