PSAOP1 ;BIR/LTL-Outpatient Dispensing (Single Drug) & (All Drugs) ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**64**; 10/24/97;Build 4
;PSAOP,PSAOP1,PSAOP2, & PSAOP4 gathers Outpatient dispensing data.
;PSAOP3 calls this routine to stuff Outpatient dispensing data in
;#58.81 and update 58.8 balance. It is called by PSAOP, PSAOP2,
;PSAOP3, & PSAOP4.
;
N DIC,PSAD,PSAT,PSAB,X
;Get transaction number
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 DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSAD D ^DIC
L -^PSD(58.81,0) K DLAYGO,DINUM
;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)
S $P(^PSD(58.8,+PSALOC,1,+PSADRUG,0),U,4)=$P($G(^(0)),U,4)-PSA(3)
EDO S:'$D(^PSD(58.8,+PSALOC,1,+PSADRUG,5,0)) ^(0)="^58.801A^^"
;If no monthly activity data yet,
I '$D(^PSD(58.8,+PSALOC,1,+PSADRUG,5,+$E(PSA(2),1,5)*100,0)) D
.;Set up current month's node with beginning balance.
.S DIC="^PSD(58.8,+PSALOC,1,+PSADRUG,5,",DIC(0)="L",DIC("DR")="1////"_$G(PSAB),(X,DINUM)=$E(PSA(2),1,5)*100,DA(2)=PSALOC,DA(1)=PSADRUG,DLAYGO=58.8 D ^DIC K DIC,DINUM,DLAYGO
.;Set up last month's node with ending balance.
.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////"_$G(PSAB) D ^DIE K DIE
;Stuff the Total Dispensed with itself+new dispensing data.
S DIE="^PSD(58.8,"_+PSALOC_",1,"_+PSADRUG_",5,",DR="9////^S X=$P($G(^(0)),U,6)+PSA(3)",DA=$E(PSA(2),1,5)*100,DA(2)=PSALOC,DA(1)=PSADRUG D ^DIE K DA
L -^PSD(58.8,+PSALOC,1,+PSADRUG,0)
;Update transaction
S DIE="^PSD(58.81,",DR="1////6;2////^S X=PSALOC;3///^S X=PSA(2);4////^S X=PSADRUG;5////^S X=PSA(3);9////^S X=$G(PSAB)",DA=PSAD
D ^DIE K DIE,DA,DR
;Update Activity
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)=PSAD
S DA(2)=PSALOC,DA(1)=PSADRUG,DLAYGO=58.8 D ^DIC K DIC,DA,DINUM,DLAYGO
END Q
TMP ;TMP("PSA",$J)
N DIC,PSAD,PSAT,PSAB,X
;Get transaction number
F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
FIND1 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 FIND1
S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSAD D ^DIC
L -^PSD(58.81,0) K DLAYGO,DINUM
;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)
S $P(^PSD(58.8,+PSALOC,1,+PSADRUG,0),U,4)=$P($G(^(0)),U,4)-PSA(3)
S:'$D(^PSD(58.8,+PSALOC,1,+PSADRUG,5,0)) ^(0)="^58.801A^^"
;;If no monthly activity data yet,
I '$D(^PSD(58.8,+PSALOC,1,+PSADRUG,5,+$E(PSA(2),1,5)*100,0)) D
.;Set up current month's node with beginning balance.
.S DIC="^PSD(58.8,+PSALOC,1,+PSADRUG,5,",DIC(0)="L",DIC("DR")="1////"_$G(PSAB),(X,DINUM)=$E(PSA(2),1,5)*100,DA(2)=PSALOC,DA(1)=PSADRUG,DLAYGO=58.8 D ^DIC K DIC,DINUM,DLAYGO
.;Set up last month's node with ending balance.
.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////"_$G(PSAB) D ^DIE K DIE
;Stuff the Total Dispensed with itself+new dispensing data.
S DIE="^PSD(58.8,+PSALOC,1,+PSADRUG,5,",DR="9////^S X=$P($G(^(0)),U,6)+PSA(3)",DA=$E(PSA(2),1,5)*100,DA(2)=PSALOC,DA(1)=PSADRUG D ^DIE K DA
L -^PSD(58.8,+PSALOC,1,+PSADRUG,0)
;Update transaction
S DIE="^PSD(58.81,",DR="1////6;2////^S X=PSALOC;3///^S X=PSA(2);4////^S X=PSADRUG;5////^S X=PSA(3);9////^S X=$G(PSAB)",DA=PSAD
D ^DIE K DIE,DA,DR
;Update Activity
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)=PSAD
S DA(2)=PSALOC,DA(1)=PSADRUG,DLAYGO=58.8 D ^DIC K DA,DIC,DINUM,DLAYGO
K ^TMP("PSA",$J,PSADRUG)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAOP1 4324 printed Sep 23, 2025@19:25:52 Page 2
PSAOP1 ;BIR/LTL-Outpatient Dispensing (Single Drug) & (All Drugs) ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**64**; 10/24/97;Build 4
+2 ;PSAOP,PSAOP1,PSAOP2, & PSAOP4 gathers Outpatient dispensing data.
+3 ;PSAOP3 calls this routine to stuff Outpatient dispensing data in
+4 ;#58.81 and update 58.8 balance. It is called by PSAOP, PSAOP2,
+5 ;PSAOP3, & PSAOP4.
+6 ;
+7 NEW DIC,PSAD,PSAT,PSAB,X
+8 ;Get transaction number
+9 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 DIC="^PSD(58.81,"
SET DIC(0)="L"
SET DLAYGO=58.81
SET (DINUM,X)=PSAD
DO ^DIC
+2 LOCK -^PSD(58.81,0)
KILL DLAYGO,DINUM
+3 ;Get date + current balance + update balance
+4 FOR
LOCK +^PSD(58.8,+PSALOC,1,+PSADRUG,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+5 SET PSAB=$PIECE($GET(^PSD(58.8,+PSALOC,1,+PSADRUG,0)),U,4)
+6 SET $PIECE(^PSD(58.8,+PSALOC,1,+PSADRUG,0),U,4)=$PIECE($GET(^(0)),U,4)-PSA(3)
EDO if '$DATA(^PSD(58.8,+PSALOC,1,+PSADRUG,5,0))
SET ^(0)="^58.801A^^"
+1 ;If no monthly activity data yet,
+2 IF '$DATA(^PSD(58.8,+PSALOC,1,+PSADRUG,5,+$EXTRACT(PSA(2),1,5)*100,0))
Begin DoDot:1
+3 ;Set up current month's node with beginning balance.
+4 SET DIC="^PSD(58.8,+PSALOC,1,+PSADRUG,5,"
SET DIC(0)="L"
SET DIC("DR")="1////"_$GET(PSAB)
SET (X,DINUM)=$EXTRACT(PSA(2),1,5)*100
SET DA(2)=PSALOC
SET DA(1)=PSADRUG
SET DLAYGO=58.8
DO ^DIC
KILL DIC,DINUM,DLAYGO
+5 ;Set up last month's node with ending balance.
+6 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
+7 SET DIE="^PSD(58.8,+PSALOC,1,+PSADRUG,5,"
SET DA(2)=PSALOC
SET DA(1)=PSADRUG
+8 SET DR="3////"_$GET(PSAB)
DO ^DIE
KILL DIE
End DoDot:1
+9 ;Stuff the Total Dispensed with itself+new dispensing data.
+10 SET DIE="^PSD(58.8,"_+PSALOC_",1,"_+PSADRUG_",5,"
SET DR="9////^S X=$P($G(^(0)),U,6)+PSA(3)"
SET DA=$EXTRACT(PSA(2),1,5)*100
SET DA(2)=PSALOC
SET DA(1)=PSADRUG
DO ^DIE
KILL DA
+11 LOCK -^PSD(58.8,+PSALOC,1,+PSADRUG,0)
+12 ;Update transaction
+13 SET DIE="^PSD(58.81,"
SET DR="1////6;2////^S X=PSALOC;3///^S X=PSA(2);4////^S X=PSADRUG;5////^S X=PSA(3);9////^S X=$G(PSAB)"
SET DA=PSAD
+14 DO ^DIE
KILL DIE,DA,DR
+15 ;Update Activity
+16 if '$DATA(^PSD(58.8,+PSALOC,1,+PSADRUG,4,0))
SET ^(0)="^58.800119PA^^"
+17 SET DIC="^PSD(58.8,+PSALOC,1,+PSADRUG,4,"
SET DIC(0)="L"
SET (X,DINUM)=PSAD
+18 SET DA(2)=PSALOC
SET DA(1)=PSADRUG
SET DLAYGO=58.8
DO ^DIC
KILL DIC,DA,DINUM,DLAYGO
END QUIT
TMP ;TMP("PSA",$J)
+1 NEW DIC,PSAD,PSAT,PSAB,X
+2 ;Get transaction number
+3 FOR
LOCK +^PSD(58.81,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
FIND1 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 FIND1
+1 SET DIC="^PSD(58.81,"
SET DIC(0)="L"
SET DLAYGO=58.81
SET (DINUM,X)=PSAD
DO ^DIC
+2 LOCK -^PSD(58.81,0)
KILL DLAYGO,DINUM
+3 ;Get date + current balance + update balance
+4 FOR
LOCK +^PSD(58.8,+PSALOC,1,+PSADRUG,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+5 SET PSAB=$PIECE($GET(^PSD(58.8,+PSALOC,1,+PSADRUG,0)),U,4)
+6 SET $PIECE(^PSD(58.8,+PSALOC,1,+PSADRUG,0),U,4)=$PIECE($GET(^(0)),U,4)-PSA(3)
+7 if '$DATA(^PSD(58.8,+PSALOC,1,+PSADRUG,5,0))
SET ^(0)="^58.801A^^"
+8 ;;If no monthly activity data yet,
+9 IF '$DATA(^PSD(58.8,+PSALOC,1,+PSADRUG,5,+$EXTRACT(PSA(2),1,5)*100,0))
Begin DoDot:1
+10 ;Set up current month's node with beginning balance.
+11 SET DIC="^PSD(58.8,+PSALOC,1,+PSADRUG,5,"
SET DIC(0)="L"
SET DIC("DR")="1////"_$GET(PSAB)
SET (X,DINUM)=$EXTRACT(PSA(2),1,5)*100
SET DA(2)=PSALOC
SET DA(1)=PSADRUG
SET DLAYGO=58.8
DO ^DIC
KILL DIC,DINUM,DLAYGO
+12 ;Set up last month's node with ending balance.
+13 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
+14 SET DIE="^PSD(58.8,"_+PSALOC_",1,"_+PSADRUG_",5,"
SET DA(2)=PSALOC
SET DA(1)=PSADRUG
+15 SET DR="3////"_$GET(PSAB)
DO ^DIE
KILL DIE
End DoDot:1
+16 ;Stuff the Total Dispensed with itself+new dispensing data.
+17 SET DIE="^PSD(58.8,+PSALOC,1,+PSADRUG,5,"
SET DR="9////^S X=$P($G(^(0)),U,6)+PSA(3)"
SET DA=$EXTRACT(PSA(2),1,5)*100
SET DA(2)=PSALOC
SET DA(1)=PSADRUG
DO ^DIE
KILL DA
+18 LOCK -^PSD(58.8,+PSALOC,1,+PSADRUG,0)
+19 ;Update transaction
+20 SET DIE="^PSD(58.81,"
SET DR="1////6;2////^S X=PSALOC;3///^S X=PSA(2);4////^S X=PSADRUG;5////^S X=PSA(3);9////^S X=$G(PSAB)"
SET DA=PSAD
+21 DO ^DIE
KILL DIE,DA,DR
+22 ;Update Activity
+23 if '$DATA(^PSD(58.8,+PSALOC,1,+PSADRUG,4,0))
SET ^(0)="^58.800119PA^^"
+24 SET DIC="^PSD(58.8,"_+PSALOC_",1,"_+PSADRUG_",4,"
SET DIC(0)="L"
SET (X,DINUM)=PSAD
+25 SET DA(2)=PSALOC
SET DA(1)=PSADRUG
SET DLAYGO=58.8
DO ^DIC
KILL DA,DIC,DINUM,DLAYGO
+26 KILL ^TMP("PSA",$JOB,PSADRUG)
+27 QUIT
