- 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 Feb 18, 2025@23:16:59 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