PSARWS ;BIR/LTL,JMB-Collects Ward Stock Data ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,64**; 10/24/97;Build 4
;This routine gathers AR/WS dispensing data. It is called by PSGWUAS.
;
N D0,DR,DA,DIC,DIE,DLAYGO,PSA,PSAB,PSAD,PSADT,PSASIT,PSAT,PSADRUG,PSALOC,PSAQTY,PSADA,PSADAL,PSAPS,X,Y S (PSAPS,PSA)=0,PSADA=""
;get date dispensed,site(aou),drug,qty
F S PSA=$O(^PSI(58.5,"AMIS",PSA)),(PSADT,PSA(1),PSASIT,PSADRUG,PSAQTY)="" Q:'PSA S PSADT=$O(^PSI(58.5,"AMIS",PSA,PSADT)) Q:'PSADT S PSA(1)=$O(^PSI(58.5,"AMIS",PSA,PSADT,PSA(1))) Q:PSA(1)']"" D
.S PSASIT=$O(^PSI(58.5,"AMIS",PSA,PSADT,PSA(1),PSASIT)) Q:'PSASIT!('$P($G(^PS(59.4,+$G(^PSI(58.1,+PSASIT,"SITE")),0)),U,26)) S PSASIT(1)=$G(^PSI(58.1,PSASIT,"SITE"))
.S PSADRUG=$O(^PSI(58.5,"AMIS",PSA,PSADT,PSA(1),PSASIT,PSADRUG))
.;drug stocked by any primary DA location?
.Q:'PSADRUG!('$O(^PSD(58.8,"C",+PSADRUG,0)))
.S (PSAPS,PSADA)=0
.;If the location is active, the drug is tracked, & it is tracked in an
.;inpatient site, set the PSADA(PSAPS) array.
.F S PSADA=$O(^PSD(58.8,"C",+PSADRUG,PSADA)) Q:'PSADA I $G(^PSD(58.8,+PSADA,"I"))="",$P($G(^PSD(58.8,+PSADA,0)),U,2)="P",+$P($G(^PSD(58.8,+PSADA,0)),U,3) S PSAPS=PSAPS+1,PSADA(PSAPS)=PSADA
.Q:'PSAPS
.S PSAQTY=$O(^PSI(58.5,"AMIS",PSA,PSADT,PSA(1),PSASIT,PSADRUG,0))
.S:PSA(1)="R" PSAQTY=-PSAQTY
.;drug stocked by only one DA location
.I PSAPS=1 S ^TMP("PSAR",$J,PSADRUG,PSADA(PSAPS))=PSAQTY+$G(^TMP("PSAR",$J,PSADRUG,PSADA(PSAPS))) Q
.;more than one, check site
.;
.;Dave B (PSA*3*3)
.S (PSAPS,PSAPS(1))=0 F S PSAPS(1)=$O(PSADA(PSAPS(1))) Q:'PSAPS(1) S PSADA=PSADA(PSAPS(1)) I $D(^PSD(58.8,"ASITE",+PSASIT(1),"P",PSADA)) S ^TMP("PSAR",$J,PSADRUG,PSADA)=PSAQTY+$G(^TMP("PSAR",$J,PSADRUG,PSADA))
COUNT G:'$O(^TMP("PSAR",$J,"")) END S PSAPS(1)=0
F PSA=0:1 S PSA=$O(^TMP("PSAR",$J,PSA)) Q:'PSA S PSAPS(1)=$G(PSAPS(1))+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,(PSA,PSA(1))=""
F PSAD=PSAT:1:(PSAT+PSAPS(1)-1) S (DINUM,X)=PSAD D ^DIC
L -^PSD(58.81,0) K DIC,DINUM,DLAYGO
;loop thru array
F S PSA=$O(^TMP("PSAR",$J,PSA)) Q:'PSA D
.S PSALOC=$O(^TMP("PSAR",$J,PSA,0))
.S PSAB(1)=$G(^TMP("PSAR",$J,PSA,PSALOC))
.;get date + current balance + update balance
.F L +^PSD(58.8,+PSALOC,1,+PSA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
.D NOW^%DTC
.S PSADT=+$E(%,1,12),PSAB=+$P($G(^PSD(58.8,+PSALOC,1,+PSA,0)),U,4),$P(^PSD(58.8,+PSALOC,1,+PSA,0),U,4)=PSAB-PSAB(1) K %
.L -^PSD(58.8,+PSALOC,1,+PSA,0)
.;update monthly activity multiple
.S:'$D(^PSD(58.8,+PSALOC,1,+PSA,5,0)) ^(0)="^58.801A^^"
.I '$D(^PSD(58.8,+PSALOC,1,+PSA,5,$E(DT,1,5)*100,0)) D
..S DIC="^PSD(58.8,+PSALOC,1,+PSA,5,",DIC(0)="L",DIC("DR")="1////^S X=$G(PSAB)",(X,DINUM)=$E(DT,1,5)*100,DA(2)=PSALOC,DA(1)=PSA,DLAYGO=58.8 D ^DIC K DIC("DR"),DINUM,DLAYGO
..S X="T-1M" D ^%DT S (X,DINUM)=$E(Y,1,5)*100 D ^DIC K DINUM
..S DIE=DIC,DA=+Y,DR="3////^S X=$G(PSAB)" D ^DIE K DIE,DA
.S DIE="^PSD(58.8,+PSALOC,1,+PSA,5,",DA(2)=PSALOC,DA(1)=PSA
.S DA=$E(DT,1,5)*100,DR="9////^S X=$P($G(^PSD(58.8,+PSALOC,1,+PSA,5,+$E(DT,1,5)*100,0)),U,6)+PSAB(1)"
.D ^DIE K DIE,DA
.;update transaction
.S DIE="^PSD(58.81,",DR="1////2;2////^S X=PSALOC;3///^S X=PSADT;4////^S X=PSA;5////^S X=$G(PSAB(1));9////^S X=PSAB",DA=PSAT
.D ^DIE
.S:'$D(^PSD(58.8,+PSALOC,1,+PSA,4,0)) ^(0)="^58.800119PA^^"
.S DIC="^PSD(58.8,+PSALOC,1,+PSA,4,",DIC(0)="L",(X,DINUM)=PSAT,DA(2)=PSALOC,DA(1)=PSA,DLAYGO=58.8 D ^DIC K DA,DIC,DINUM,DLAYGO S PSAT=PSAT+1
END K ^TMP("PSAR",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSARWS 3723 printed Sep 23, 2025@19:26:40 Page 2
PSARWS ;BIR/LTL,JMB-Collects Ward Stock Data ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,64**; 10/24/97;Build 4
+2 ;This routine gathers AR/WS dispensing data. It is called by PSGWUAS.
+3 ;
+4 NEW D0,DR,DA,DIC,DIE,DLAYGO,PSA,PSAB,PSAD,PSADT,PSASIT,PSAT,PSADRUG,PSALOC,PSAQTY,PSADA,PSADAL,PSAPS,X,Y
SET (PSAPS,PSA)=0
SET PSADA=""
+5 ;get date dispensed,site(aou),drug,qty
+6 FOR
SET PSA=$ORDER(^PSI(58.5,"AMIS",PSA))
SET (PSADT,PSA(1),PSASIT,PSADRUG,PSAQTY)=""
if 'PSA
QUIT
SET PSADT=$ORDER(^PSI(58.5,"AMIS",PSA,PSADT))
if 'PSADT
QUIT
SET PSA(1)=$ORDER(^PSI(58.5,"AMIS",PSA,PSADT,PSA(1)))
if PSA(1)']""
QUIT
Begin DoDot:1
+7 SET PSASIT=$ORDER(^PSI(58.5,"AMIS",PSA,PSADT,PSA(1),PSASIT))
if 'PSASIT!('$PIECE($GET(^PS(59.4,+$GET(^PSI(58.1,+PSASIT,"SITE")),0)),U,26))
QUIT
SET PSASIT(1)=$GET(^PSI(58.1,PSASIT,"SITE"))
+8 SET PSADRUG=$ORDER(^PSI(58.5,"AMIS",PSA,PSADT,PSA(1),PSASIT,PSADRUG))
+9 ;drug stocked by any primary DA location?
+10 if 'PSADRUG!('$ORDER(^PSD(58.8,"C",+PSADRUG,0)))
QUIT
+11 SET (PSAPS,PSADA)=0
+12 ;If the location is active, the drug is tracked, & it is tracked in an
+13 ;inpatient site, set the PSADA(PSAPS) array.
+14 FOR
SET PSADA=$ORDER(^PSD(58.8,"C",+PSADRUG,PSADA))
if 'PSADA
QUIT
IF $GET(^PSD(58.8,+PSADA,"I"))=""
IF $PIECE($GET(^PSD(58.8,+PSADA,0)),U,2)="P"
IF +$PIECE($GET(^PSD(58.8,+PSADA,0)),U,3)
SET PSAPS=PSAPS+1
SET PSADA(PSAPS)=PSADA
+15 if 'PSAPS
QUIT
+16 SET PSAQTY=$ORDER(^PSI(58.5,"AMIS",PSA,PSADT,PSA(1),PSASIT,PSADRUG,0))
+17 if PSA(1)="R"
SET PSAQTY=-PSAQTY
+18 ;drug stocked by only one DA location
+19 IF PSAPS=1
SET ^TMP("PSAR",$JOB,PSADRUG,PSADA(PSAPS))=PSAQTY+$GET(^TMP("PSAR",$JOB,PSADRUG,PSADA(PSAPS)))
QUIT
+20 ;more than one, check site
+21 ;
+22 ;Dave B (PSA*3*3)
+23 SET (PSAPS,PSAPS(1))=0
FOR
SET PSAPS(1)=$ORDER(PSADA(PSAPS(1)))
if 'PSAPS(1)
QUIT
SET PSADA=PSADA(PSAPS(1))
IF $DATA(^PSD(58.8,"ASITE",+PSASIT(1),"P",PSADA))
SET ^TMP("PSAR",$JOB,PSADRUG,PSADA)=PSAQTY+$GET(^TMP("PSAR",$JOB,PSADRUG,PSADA))
End DoDot:1
COUNT if '$ORDER(^TMP("PSAR",$JOB,""))
GOTO END
SET PSAPS(1)=0
+1 FOR PSA=0:1
SET PSA=$ORDER(^TMP("PSAR",$JOB,PSA))
if 'PSA
QUIT
SET PSAPS(1)=$GET(PSAPS(1))+1
+2 ;get transaction numbers
+3 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
SET (PSA,PSA(1))=""
+2 FOR PSAD=PSAT:1:(PSAT+PSAPS(1)-1)
SET (DINUM,X)=PSAD
DO ^DIC
+3 LOCK -^PSD(58.81,0)
KILL DIC,DINUM,DLAYGO
+4 ;loop thru array
+5 FOR
SET PSA=$ORDER(^TMP("PSAR",$JOB,PSA))
if 'PSA
QUIT
Begin DoDot:1
+6 SET PSALOC=$ORDER(^TMP("PSAR",$JOB,PSA,0))
+7 SET PSAB(1)=$GET(^TMP("PSAR",$JOB,PSA,PSALOC))
+8 ;get date + current balance + update balance
+9 FOR
LOCK +^PSD(58.8,+PSALOC,1,+PSA,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+10 DO NOW^%DTC
+11 SET PSADT=+$EXTRACT(%,1,12)
SET PSAB=+$PIECE($GET(^PSD(58.8,+PSALOC,1,+PSA,0)),U,4)
SET $PIECE(^PSD(58.8,+PSALOC,1,+PSA,0),U,4)=PSAB-PSAB(1)
KILL %
+12 LOCK -^PSD(58.8,+PSALOC,1,+PSA,0)
+13 ;update monthly activity multiple
+14 if '$DATA(^PSD(58.8,+PSALOC,1,+PSA,5,0))
SET ^(0)="^58.801A^^"
+15 IF '$DATA(^PSD(58.8,+PSALOC,1,+PSA,5,$EXTRACT(DT,1,5)*100,0))
Begin DoDot:2
+16 SET DIC="^PSD(58.8,+PSALOC,1,+PSA,5,"
SET DIC(0)="L"
SET DIC("DR")="1////^S X=$G(PSAB)"
SET (X,DINUM)=$EXTRACT(DT,1,5)*100
SET DA(2)=PSALOC
SET DA(1)=PSA
SET DLAYGO=58.8
DO ^DIC
KILL DIC("DR"),DINUM,DLAYGO
+17 SET X="T-1M"
DO ^%DT
SET (X,DINUM)=$EXTRACT(Y,1,5)*100
DO ^DIC
KILL DINUM
+18 SET DIE=DIC
SET DA=+Y
SET DR="3////^S X=$G(PSAB)"
DO ^DIE
KILL DIE,DA
End DoDot:2
+19 SET DIE="^PSD(58.8,+PSALOC,1,+PSA,5,"
SET DA(2)=PSALOC
SET DA(1)=PSA
+20 SET DA=$EXTRACT(DT,1,5)*100
SET DR="9////^S X=$P($G(^PSD(58.8,+PSALOC,1,+PSA,5,+$E(DT,1,5)*100,0)),U,6)+PSAB(1)"
+21 DO ^DIE
KILL DIE,DA
+22 ;update transaction
+23 SET DIE="^PSD(58.81,"
SET DR="1////2;2////^S X=PSALOC;3///^S X=PSADT;4////^S X=PSA;5////^S X=$G(PSAB(1));9////^S X=PSAB"
SET DA=PSAT
+24 DO ^DIE
+25 if '$DATA(^PSD(58.8,+PSALOC,1,+PSA,4,0))
SET ^(0)="^58.800119PA^^"
+26 SET DIC="^PSD(58.8,+PSALOC,1,+PSA,4,"
SET DIC(0)="L"
SET (X,DINUM)=PSAT
SET DA(2)=PSALOC
SET DA(1)=PSA
SET DLAYGO=58.8
DO ^DIC
KILL DA,DIC,DINUM,DLAYGO
SET PSAT=PSAT+1
End DoDot:1
END KILL ^TMP("PSAR",$JOB)
+1 QUIT
