PSAPSI1 ;BIR/LTL-IV Dispensing (Single Drug) & (All Drugs) ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**64**; 10/24/97;Build 4
;This routine places the IV data into files 58.8 and 58.81. It is called
;by PSAPSI, PSAPSI2, AND PSAPSI3.
;
N DIC,PSAD,PSAT
S (PSA(4),PSA(6))=0 F S PSA(4)=$O(^TMP("PSA",$J,PSADRUG,PSA(4))) Q:'PSA(4) S PSA(6)=PSA(6)+1
;get transaction numbers
F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
FIND S PSAD=$P(^PSD(58.81,0),U,3)+1 I $D(^PSD(58.81,PSAD)) S $P(^PSD(58.81,0),U,3)=$P(^PSD(58.81,0),U,3)+1 G FIND
S PSAT=PSAD,DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81
F PSAD=PSAT:1:(PSAT+(PSA(6)-1)) S (DINUM,X)=PSAD D ^DIC
L -^PSD(58.81,0) K DIC,DINUM,DLAYGO
;loop thru array
LUP S PSA(4)=0 F S PSA(4)=$O(^TMP("PSA",$J,PSADRUG,PSA(4))) Q:'PSA(4) S PSA=$G(^TMP("PSA",$J,PSADRUG,PSA(4))) S:$P($G(^PSD(58.8,PSALOC,1,PSADRUG,6)),U,4) PSA=PSA/$P($G(^(6)),U,4) D LUP1
K ^TMP("PSA",$J,PSADRUG)
Q
LUP1 ;get date + current balance + update balance
F L +^PSD(58.8,PSALOC,1,PSADRUG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
S PSAB=$P($G(^PSD(58.8,PSALOC,1,PSADRUG,0)),U,4)
G:'$G(PSA(7)) EDO
S $P(^PSD(58.8,PSALOC,1,PSADRUG,0),U,4)=$P($G(^(0)),U,4)-PSA
EDO L -^PSD(58.8,PSALOC,1,PSADRUG,0)
S:'$D(^PSD(58.8,PSALOC,1,PSADRUG,5,0)) ^(0)="^58.801A^^"
I '$D(^PSD(58.8,PSALOC,1,PSADRUG,5,+$E(PSA(4),1,5)*100,0)) D
.S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,",DIC(0)="L",DIC("DR")="1////^S X=$G(PSAB)",(X,DINUM)=$E(PSA(4),1,5)*100,DA(2)=PSALOC,DA(1)=PSADRUG,DLAYGO=58.8 D ^DIC K DIC,DINUM,DLAYGO
.S X="T-1M" D ^%DT S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,",DIC(0)="L",(X,DINUM)=$E(Y,1,5)*100,DA(2)=PSALOC,DA(1)=PSADRUG,DLAYGO=58.8 D ^DIC K DIC,DINUM,DLAYGO S DA=+Y
.S DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,",DA(2)=PSALOC,DA(1)=PSADRUG
.S DR="3////^S X=$G(PSAB)" D ^DIE K DIE
S DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,",DR="9////^S X=$P($G(^(0)),U,6)+PSA",DA=$E(PSA(4),1,5)*100,DA(2)=PSALOC,DA(1)=PSADRUG D ^DIE K DA
;update transaction
S DIE="^PSD(58.81,",DR="1////15;2////^S X=PSALOC;3///^S X=PSA(4);4////^S X=PSADRUG;5////^S X=PSA;9////^S X=$G(PSAB)",DA=PSAT
D ^DIE K DIE,DA,PSAB
S:'$D(^PSD(58.8,PSALOC,1,PSADRUG,4,0)) ^(0)="^58.800119PA^^"
S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",4,",DIC(0)="L",(X,DINUM)=PSAT
S DA(2)=PSALOC,DA(1)=PSADRUG,DLAYGO=58.8 D ^DIC K DA,DIC,DINUM,DLAYGO
S DIE="^PSD(58.8,"_PSALOC_",1,",DA(1)=PSALOC,DA=PSADRUG,DR="24////^S X=PSA(4)_"",""_$G(PSAW(1))" D ^DIE S PSAT=PSAT+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAPSI1 2513 printed Oct 16, 2024@17:51:04 Page 2
PSAPSI1 ;BIR/LTL-IV Dispensing (Single Drug) & (All Drugs) ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**64**; 10/24/97;Build 4
+2 ;This routine places the IV data into files 58.8 and 58.81. It is called
+3 ;by PSAPSI, PSAPSI2, AND PSAPSI3.
+4 ;
+5 NEW DIC,PSAD,PSAT
+6 SET (PSA(4),PSA(6))=0
FOR
SET PSA(4)=$ORDER(^TMP("PSA",$JOB,PSADRUG,PSA(4)))
if 'PSA(4)
QUIT
SET PSA(6)=PSA(6)+1
+7 ;get transaction numbers
+8 FOR
LOCK +^PSD(58.81,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
FIND SET PSAD=$PIECE(^PSD(58.81,0),U,3)+1
IF $DATA(^PSD(58.81,PSAD))
SET $PIECE(^PSD(58.81,0),U,3)=$PIECE(^PSD(58.81,0),U,3)+1
GOTO FIND
+1 SET PSAT=PSAD
SET DIC="^PSD(58.81,"
SET DIC(0)="L"
SET DLAYGO=58.81
+2 FOR PSAD=PSAT:1:(PSAT+(PSA(6)-1))
SET (DINUM,X)=PSAD
DO ^DIC
+3 LOCK -^PSD(58.81,0)
KILL DIC,DINUM,DLAYGO
+4 ;loop thru array
LUP SET PSA(4)=0
FOR
SET PSA(4)=$ORDER(^TMP("PSA",$JOB,PSADRUG,PSA(4)))
if 'PSA(4)
QUIT
SET PSA=$GET(^TMP("PSA",$JOB,PSADRUG,PSA(4)))
if $PIECE($GET(^PSD(58.8,PSALOC,1,PSADRUG,6)),U,4)
SET PSA=PSA/$PIECE($GET(^(6)),U,4)
DO LUP1
+1 KILL ^TMP("PSA",$JOB,PSADRUG)
+2 QUIT
LUP1 ;get date + current balance + update balance
+1 FOR
LOCK +^PSD(58.8,PSALOC,1,PSADRUG,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+2 SET PSAB=$PIECE($GET(^PSD(58.8,PSALOC,1,PSADRUG,0)),U,4)
+3 if '$GET(PSA(7))
GOTO EDO
+4 SET $PIECE(^PSD(58.8,PSALOC,1,PSADRUG,0),U,4)=$PIECE($GET(^(0)),U,4)-PSA
EDO LOCK -^PSD(58.8,PSALOC,1,PSADRUG,0)
+1 if '$DATA(^PSD(58.8,PSALOC,1,PSADRUG,5,0))
SET ^(0)="^58.801A^^"
+2 IF '$DATA(^PSD(58.8,PSALOC,1,PSADRUG,5,+$EXTRACT(PSA(4),1,5)*100,0))
Begin DoDot:1
+3 SET DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,"
SET DIC(0)="L"
SET DIC("DR")="1////^S X=$G(PSAB)"
SET (X,DINUM)=$EXTRACT(PSA(4),1,5)*100
SET DA(2)=PSALOC
SET DA(1)=PSADRUG
SET DLAYGO=58.8
DO ^DIC
KILL DIC,DINUM,DLAYGO
+4 SET X="T-1M"
DO ^%DT
SET DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,"
SET DIC(0)="L"
SET (X,DINUM)=$EXTRACT(Y,1,5)*100
SET DA(2)=PSALOC
SET DA(1)=PSADRUG
SET DLAYGO=58.8
DO ^DIC
KILL DIC,DINUM,DLAYGO
SET DA=+Y
+5 SET DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,"
SET DA(2)=PSALOC
SET DA(1)=PSADRUG
+6 SET DR="3////^S X=$G(PSAB)"
DO ^DIE
KILL DIE
End DoDot:1
+7 SET DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,"
SET DR="9////^S X=$P($G(^(0)),U,6)+PSA"
SET DA=$EXTRACT(PSA(4),1,5)*100
SET DA(2)=PSALOC
SET DA(1)=PSADRUG
DO ^DIE
KILL DA
+8 ;update transaction
+9 SET DIE="^PSD(58.81,"
SET DR="1////15;2////^S X=PSALOC;3///^S X=PSA(4);4////^S X=PSADRUG;5////^S X=PSA;9////^S X=$G(PSAB)"
SET DA=PSAT
+10 DO ^DIE
KILL DIE,DA,PSAB
+11 if '$DATA(^PSD(58.8,PSALOC,1,PSADRUG,4,0))
SET ^(0)="^58.800119PA^^"
+12 SET DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",4,"
SET DIC(0)="L"
SET (X,DINUM)=PSAT
+13 SET DA(2)=PSALOC
SET DA(1)=PSADRUG
SET DLAYGO=58.8
DO ^DIC
KILL DA,DIC,DINUM,DLAYGO
+14 SET DIE="^PSD(58.8,"_PSALOC_",1,"
SET DA(1)=PSALOC
SET DA=PSADRUG
SET DR="24////^S X=PSA(4)_"",""_$G(PSAW(1))"
DO ^DIE
SET PSAT=PSAT+1
+15 QUIT
