PSDRF1 ;B'ham ISC/JPW,LTL - File Dispensing Info ; 13 Dec 93
;;3.0; CONTROLLED SUBSTANCES ;**66**;13 Feb 97;Build 3
UPDAT I $G(PSDPN) F JJ=0:0 S JJ=$O(^PSD(58.8,"F",PSDPN,NAOU,PSDR,JJ)) Q:'JJ S ORD=+JJ
;$S(WQTY:18,CQTY:9,1:17) S:PSDTYP=9 QTY=CQTY-OQTY
W ?40,"Recording transaction... "
D UPDATE W "done."
END ;kill variables
K %,%DT,%H,%I,BAL,CQTY,DA,DIC,DIE,DIK,DINUM,DLAYGO,DR,JJ,LQTY,NAOUN,NODE,NUR2,OK,ORD
K PSD,PSDER,PSDREC,PSDRN,PSDT,PSDTN,QTY,WQTY,X,Y
Q
UPDATE ;update 58.8 and 58.81
;updating drug balance in 58.8
F L +^PSD(58.8,NAOU,1,PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
D NOW^%DTC S (PSDTN,PSDT)=+%
S BAL=$P(^PSD(58.8,NAOU,1,PSDR,0),"^",4),$P(^(0),"^",4)=$P(^(0),"^",4)-PSDQ
L -^PSD(58.8,NAOU,1,PSDR,0)
;update order balance
;I $G(ORD),$D(^PSD(58.8,NAOU,1,PSDR,3,ORD,0)),PSDTYP'=9 S $P(^(0),"^",22)=$P(^(0),"^",22)-PSDQ,DA=+$P(^(0),"^",17) D:$P(^(0),"^",22)=0 K DA,DIE,DR
;.K DIE,DR S DIE="^PSD(58.81,",DR="10////12;11////1" D ^DIE K DA,DIE,DR
;.K DA,DIE,DR S DIE="^PSD(58.8,"_NAOU_",1,"_PSDR_",3,",DA=+ORD,DA(1)=+PSDR,DA(2)=+NAOU,DR="10////12;11////1" D ^DIE K DA,DIE,DR
ADD ;find entry number in 58.81
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,DLAYGO
L -^PSD(58.81,0)
EDIT ;edit new transaction in 58.81
S ^PSD(58.81,PSDREC,0)=PSDREC_"^"_PSDTYP_"^"_NAOU_"^"_PSDT_"^"_PSDR_"^"_$S(PSDTYP=9:-PSDQ,1:PSDQ)_"^"_$G(NUR1)_"^^^"_BAL_"^^^^^^"_$S(PSDTYP=9:$G(PSDRE),1:"")_"^"_$G(PSDPN)_"^"_NAOU_"^^"_$G(ORD)
S ^PSD(58.81,PSDREC,9)=$G(PAT)_"^"_NUR1_"^"_OQTY_"^"_$G(WQTY)_"^"_$G(LQTY)_"^"_$G(NUR2)_"^"_BAL
;S:PATL ^PSD(58.81,PSDREC,9.5)=PATL
S ^PSD(58.81,PSDREC,"CS")=1
K DA,DIK S DA=PSDREC,DIK="^PSD(58.81," D IX^DIK K DA,DIK
I PSDTYP'=17 D ERR
Q
ERR ;err log update
F L +^PSD(58.89,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
FIND9 S PSDER=$P(^PSD(58.89,0),"^",3)+1 I $D(^PSD(58.89,PSDER)) S $P(^PSD(58.89,0),"^",3)=PSDER G FIND9
K DIC,DLAYGO S DIC(0)="L",(DIC,DLAYGO)=58.89,(X,DINUM)=PSDER D ^DIC K DIC,DLAYGO
L -^PSD(58.89,0)
EDIT9 ;edit error log
K DA,DIE,DR S DA=PSDER,DIE=58.89,DR="1////"_PSDREC_";2////"_PSDT_";6////"_NAOU D ^DIE K DA,DIE,DR
S PHARM1=NUR1,QTY=PSDQ
S:$G(NAOUN)']"" NAOUN=$P($G(^PSD(58.8,NAOU,0)),U) D ^PSDRFM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDRF1 2416 printed Nov 22, 2024@16:58:44 Page 2
PSDRF1 ;B'ham ISC/JPW,LTL - File Dispensing Info ; 13 Dec 93
+1 ;;3.0; CONTROLLED SUBSTANCES ;**66**;13 Feb 97;Build 3
UPDAT IF $GET(PSDPN)
FOR JJ=0:0
SET JJ=$ORDER(^PSD(58.8,"F",PSDPN,NAOU,PSDR,JJ))
if 'JJ
QUIT
SET ORD=+JJ
+1 ;$S(WQTY:18,CQTY:9,1:17) S:PSDTYP=9 QTY=CQTY-OQTY
+2 WRITE ?40,"Recording transaction... "
+3 DO UPDATE
WRITE "done."
END ;kill variables
+1 KILL %,%DT,%H,%I,BAL,CQTY,DA,DIC,DIE,DIK,DINUM,DLAYGO,DR,JJ,LQTY,NAOUN,NODE,NUR2,OK,ORD
+2 KILL PSD,PSDER,PSDREC,PSDRN,PSDT,PSDTN,QTY,WQTY,X,Y
+3 QUIT
UPDATE ;update 58.8 and 58.81
+1 ;updating drug balance in 58.8
+2 FOR
LOCK +^PSD(58.8,NAOU,1,PSDR,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+3 DO NOW^%DTC
SET (PSDTN,PSDT)=+%
+4 SET BAL=$PIECE(^PSD(58.8,NAOU,1,PSDR,0),"^",4)
SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)-PSDQ
+5 LOCK -^PSD(58.8,NAOU,1,PSDR,0)
+6 ;update order balance
+7 ;I $G(ORD),$D(^PSD(58.8,NAOU,1,PSDR,3,ORD,0)),PSDTYP'=9 S $P(^(0),"^",22)=$P(^(0),"^",22)-PSDQ,DA=+$P(^(0),"^",17) D:$P(^(0),"^",22)=0 K DA,DIE,DR
+8 ;.K DIE,DR S DIE="^PSD(58.81,",DR="10////12;11////1" D ^DIE K DA,DIE,DR
+9 ;.K DA,DIE,DR S DIE="^PSD(58.8,"_NAOU_",1,"_PSDR_",3,",DA=+ORD,DA(1)=+PSDR,DA(2)=+NAOU,DR="10////12;11////1" D ^DIE K DA,DIE,DR
ADD ;find entry number in 58.81
+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,DLAYGO
+2 LOCK -^PSD(58.81,0)
EDIT ;edit new transaction in 58.81
+1 SET ^PSD(58.81,PSDREC,0)=PSDREC_"^"_PSDTYP_"^"_NAOU_"^"_PSDT_"^"_PSDR_"^"_$SELECT(PSDTYP=9:-PSDQ,1:PSDQ)_"^"_$GET(NUR1)_"^^^"_BAL_"^^^^^^"_$SELECT(PSDTYP=9:$GET(PSDRE),1:"")_"^"_$GET(PSDPN)_"^"_NAOU_"^^"_$GET(ORD)
+2 SET ^PSD(58.81,PSDREC,9)=$GET(PAT)_"^"_NUR1_"^"_OQTY_"^"_$GET(WQTY)_"^"_$GET(LQTY)_"^"_$GET(NUR2)_"^"_BAL
+3 ;S:PATL ^PSD(58.81,PSDREC,9.5)=PATL
+4 SET ^PSD(58.81,PSDREC,"CS")=1
+5 KILL DA,DIK
SET DA=PSDREC
SET DIK="^PSD(58.81,"
DO IX^DIK
KILL DA,DIK
+6 IF PSDTYP'=17
DO ERR
+7 QUIT
ERR ;err log update
+1 FOR
LOCK +^PSD(58.89,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
FIND9 SET PSDER=$PIECE(^PSD(58.89,0),"^",3)+1
IF $DATA(^PSD(58.89,PSDER))
SET $PIECE(^PSD(58.89,0),"^",3)=PSDER
GOTO FIND9
+1 KILL DIC,DLAYGO
SET DIC(0)="L"
SET (DIC,DLAYGO)=58.89
SET (X,DINUM)=PSDER
DO ^DIC
KILL DIC,DLAYGO
+2 LOCK -^PSD(58.89,0)
EDIT9 ;edit error log
+1 KILL DA,DIE,DR
SET DA=PSDER
SET DIE=58.89
SET DR="1////"_PSDREC_";2////"_PSDT_";6////"_NAOU
DO ^DIE
KILL DA,DIE,DR
+2 SET PHARM1=NUR1
SET QTY=PSDQ
+3 if $GET(NAOUN)']""
SET NAOUN=$PIECE($GET(^PSD(58.8,NAOU,0)),U)
DO ^PSDRFM
+4 QUIT
