PSDDWK3 ;BIR/JPW-Pharm Dispensing Worksheet (cont'd) ; 24 Aug 93
;;3.0; CONTROLLED SUBSTANCES ;**16,66**;13 Feb 97;Build 3
;
;References to ^PSD(58.8, supported by DBIA2711
;References to ^PSD(58.81 are supported by DBIA2808
;
UPDATE ;set zero node in 58.81 - ien^type^disp^disp date^drug^qty^^^^bal.fwd^stat^^mfg^lot#^exp.date^^disp#^naou^^req#
I $D(XRTL) D T0^%ZOSV
S STAT=$S(ACT="V":3,1:2) I DUZ'=PSDBY,$D(^XUSEC("PSJ RPHARM",DUZ)),ACT="V" S TECH=PSDBY,PSDBY=DUZ
;
;DAVE B (PSD*3*16) Locking more nodes
F L +^PSD(58.81,PSDREC,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
F L +^PSD(58.8,ORDS,1,PSDR):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
S ^PSD(58.81,PSDREC,0)=PSDREC_"^2^"_ORDS_"^"_$S(ACT="V":PSDT,1:"")_"^"_PSDR_"^"_QTY_"^^^^"_BAL_"^"_STAT_"^^"_MFG_"^"_LOT_"^"_EXP_"^^"_PSDPN_"^"_NAOU_"^^"_REQ
;set the 1, 2 and CS nodes in 58.81 and update xrefs - (1) proc.by^disp.date^^^tech^req.date^ordered by, (1.5) ordered by pharm, (2) comments, (CS) cs.trans
S ^PSD(58.81,PSDREC,1)=PSDBY_"^^^^"_TECH_"^"_REQDT_"^"_ORD
S $P(^PSD(58.81,PSDREC,"CS"),"^",1)=1
S:$P($G(^PSD(58.85,PSDN,2)),U,2) $P(^PSD(58.81,PSDREC,"CS"),U,6)=1
S:ACT="P" $P(^PSD(58.81,PSDREC,1),"^",2)=PSDT
S:PSDUZA ^PSD(58.81,PSDREC,1.5)=PSDUZA
S $P(^PSD(58.81,PSDREC,9),U)=$P($G(^PSD(58.85,PSDN,2)),U,3)
I $D(^PSD(58.85,PSDN,1,0)) S ^PSD(58.81,PSDREC,2,0)=^PSD(58.85,PSDN,1,0) D
.F WORD=0:0 S WORD=$O(^PSD(58.85,PSDN,1,WORD)) Q:'WORD S ^PSD(58.81,PSDREC,2,WORD,0)=^PSD(58.85,PSDN,1,WORD,0)
K DA,DIK S DA=PSDREC,DIK="^PSD(58.81," D IX^DIK K DA,DIK
;update vault
W "vault activity..."
I '$D(^PSD(58.8,ORDS,1,PSDR,4,0)) S ^(0)="^58.800119PA^^"
I '$D(^PSD(58.8,ORDS,1,PSDR,4,PSDREC,0)) K DA,DIC,DD,DO S DIC(0)="L",DLAYGO=58.8,DIC="^PSD(58.8,"_ORDS_",1,"_PSDR_",4,",DA(2)=ORDS,DA(1)=PSDR,(X,DINUM)=PSDREC D FILE^DICN K DA,DIC,DINUM,DD,DO
MON ;monthly summary data
I '$D(^PSD(58.8,ORDS,1,PSDR,5,0)) S ^(0)="^58.801A^^"
I '$D(^PSD(58.8,ORDS,1,PSDR,5,$E(DT,1,5)*100,0)) K DIC S DIC="^PSD(58.8,"_ORDS_",1,"_PSDR_",5,",DIC(0)="LM",DLAYGO=58.8,(X,DINUM)=$E(DT,1,5)*100,DA(2)=ORDS,DA(1)=PSDR D ^DIC K DIC,DA,DINUM,DLAYGO
K DA,DIE,DR S DIE="^PSD(58.8,"_ORDS_",1,"_PSDR_",5,",DA(2)=ORDS,DA(1)=PSDR,DA=$E(DT,1,5)*100,DR="9////^S X=$P($G(^(0)),""^"",6)+QTY" D ^DIE K DA,DIE,DR
;update the entry in 58.85
W "worksheet..."
K DA,DIE,DR S DA=PSDN,DIE=58.85,DR="18////"_QTY_";16////"_PSDPN_";6////"_STAT_";Q;I X'=3 S Y=7;15////"_PSDT_";7////"_PSDREC_";17////"_TECH D ^DIE K DA,DIE,DR
;update the order in 58.8
W "order..."
K DA,DIE,DR S DA=REQ,DA(1)=PSDR,DA(2)=NAOU,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",3,"
S DR="2////"_ORDS_";4////"_PSDBY_";10////"_STAT_";Q;I X'=3 S Y=7;14////"_PSDT_";7////"_MFG_";8////"_LOT_";9////"_EXP_";16////"_PSDPN_";17////"_PSDREC_";19////"_QTY D ^DIE K DA,DIE,DR
W "done.",!!,"This order is now "_$P($G(^PSD(58.82,+STAT,0)),"^")_".",!
I $D(XRT0) S XRTN=$T(+0) D T1^%ZOSV
;
;DAVE B (PSD*3*16) unlock locked nodes
L -^PSD(58.81,PSDREC,0)
L -^PSD(58.8,ORDS,1,PSDR)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDDWK3 3016 printed Nov 22, 2024@16:55:48 Page 2
PSDDWK3 ;BIR/JPW-Pharm Dispensing Worksheet (cont'd) ; 24 Aug 93
+1 ;;3.0; CONTROLLED SUBSTANCES ;**16,66**;13 Feb 97;Build 3
+2 ;
+3 ;References to ^PSD(58.8, supported by DBIA2711
+4 ;References to ^PSD(58.81 are supported by DBIA2808
+5 ;
UPDATE ;set zero node in 58.81 - ien^type^disp^disp date^drug^qty^^^^bal.fwd^stat^^mfg^lot#^exp.date^^disp#^naou^^req#
+1 IF $DATA(XRTL)
DO T0^%ZOSV
+2 SET STAT=$SELECT(ACT="V":3,1:2)
IF DUZ'=PSDBY
IF $DATA(^XUSEC("PSJ RPHARM",DUZ))
IF ACT="V"
SET TECH=PSDBY
SET PSDBY=DUZ
+3 ;
+4 ;DAVE B (PSD*3*16) Locking more nodes
+5 FOR
LOCK +^PSD(58.81,PSDREC,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+6 FOR
LOCK +^PSD(58.8,ORDS,1,PSDR):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+7 SET ^PSD(58.81,PSDREC,0)=PSDREC_"^2^"_ORDS_"^"_$SELECT(ACT="V":PSDT,1:"")_"^"_PSDR_"^"_QTY_"^^^^"_BAL_"^"_STAT_"^^"_MFG_"^"_LOT_"^"_EXP_"^^"_PSDPN_"^"_NAOU_"^^"_REQ
+8 ;set the 1, 2 and CS nodes in 58.81 and update xrefs - (1) proc.by^disp.date^^^tech^req.date^ordered by, (1.5) ordered by pharm, (2) comments, (CS) cs.trans
+9 SET ^PSD(58.81,PSDREC,1)=PSDBY_"^^^^"_TECH_"^"_REQDT_"^"_ORD
+10 SET $PIECE(^PSD(58.81,PSDREC,"CS"),"^",1)=1
+11 if $PIECE($GET(^PSD(58.85,PSDN,2)),U,2)
SET $PIECE(^PSD(58.81,PSDREC,"CS"),U,6)=1
+12 if ACT="P"
SET $PIECE(^PSD(58.81,PSDREC,1),"^",2)=PSDT
+13 if PSDUZA
SET ^PSD(58.81,PSDREC,1.5)=PSDUZA
+14 SET $PIECE(^PSD(58.81,PSDREC,9),U)=$PIECE($GET(^PSD(58.85,PSDN,2)),U,3)
+15 IF $DATA(^PSD(58.85,PSDN,1,0))
SET ^PSD(58.81,PSDREC,2,0)=^PSD(58.85,PSDN,1,0)
Begin DoDot:1
+16 FOR WORD=0:0
SET WORD=$ORDER(^PSD(58.85,PSDN,1,WORD))
if 'WORD
QUIT
SET ^PSD(58.81,PSDREC,2,WORD,0)=^PSD(58.85,PSDN,1,WORD,0)
End DoDot:1
+17 KILL DA,DIK
SET DA=PSDREC
SET DIK="^PSD(58.81,"
DO IX^DIK
KILL DA,DIK
+18 ;update vault
+19 WRITE "vault activity..."
+20 IF '$DATA(^PSD(58.8,ORDS,1,PSDR,4,0))
SET ^(0)="^58.800119PA^^"
+21 IF '$DATA(^PSD(58.8,ORDS,1,PSDR,4,PSDREC,0))
KILL DA,DIC,DD,DO
SET DIC(0)="L"
SET DLAYGO=58.8
SET DIC="^PSD(58.8,"_ORDS_",1,"_PSDR_",4,"
SET DA(2)=ORDS
SET DA(1)=PSDR
SET (X,DINUM)=PSDREC
DO FILE^DICN
KILL DA,DIC,DINUM,DD,DO
MON ;monthly summary data
+1 IF '$DATA(^PSD(58.8,ORDS,1,PSDR,5,0))
SET ^(0)="^58.801A^^"
+2 IF '$DATA(^PSD(58.8,ORDS,1,PSDR,5,$EXTRACT(DT,1,5)*100,0))
KILL DIC
SET DIC="^PSD(58.8,"_ORDS_",1,"_PSDR_",5,"
SET DIC(0)="LM"
SET DLAYGO=58.8
SET (X,DINUM)=$EXTRACT(DT,1,5)*100
SET DA(2)=ORDS
SET DA(1)=PSDR
DO ^DIC
KILL DIC,DA,DINUM,DLAYGO
+3 KILL DA,DIE,DR
SET DIE="^PSD(58.8,"_ORDS_",1,"_PSDR_",5,"
SET DA(2)=ORDS
SET DA(1)=PSDR
SET DA=$EXTRACT(DT,1,5)*100
SET DR="9////^S X=$P($G(^(0)),""^"",6)+QTY"
DO ^DIE
KILL DA,DIE,DR
+4 ;update the entry in 58.85
+5 WRITE "worksheet..."
+6 KILL DA,DIE,DR
SET DA=PSDN
SET DIE=58.85
SET DR="18////"_QTY_";16////"_PSDPN_";6////"_STAT_";Q;I X'=3 S Y=7;15////"_PSDT_";7////"_PSDREC_";17////"_TECH
DO ^DIE
KILL DA,DIE,DR
+7 ;update the order in 58.8
+8 WRITE "order..."
+9 KILL DA,DIE,DR
SET DA=REQ
SET DA(1)=PSDR
SET DA(2)=NAOU
SET DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",3,"
+10 SET DR="2////"_ORDS_";4////"_PSDBY_";10////"_STAT_";Q;I X'=3 S Y=7;14////"_PSDT_";7////"_MFG_";8////"_LOT_";9////"_EXP_";16////"_PSDPN_";17////"_PSDREC_";19////"_QTY
DO ^DIE
KILL DA,DIE,DR
+11 WRITE "done.",!!,"This order is now "_$PIECE($GET(^PSD(58.82,+STAT,0)),"^")_".",!
+12 IF $DATA(XRT0)
SET XRTN=$TEXT(+0)
DO T1^%ZOSV
+13 ;
+14 ;DAVE B (PSD*3*16) unlock locked nodes
+15 LOCK -^PSD(58.81,PSDREC,0)
+16 LOCK -^PSD(58.8,ORDS,1,PSDR)
+17 QUIT
