source: WorldVistAEHR/trunk/r/DRUG_ACCOUNTABILITY-PSA/PSARWS.m@ 701

Last change on this file since 701 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1PSARWS ;BIR/LTL,JMB-Collects Ward Stock Data ;7/23/97
2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,64**; 10/24/97;Build 4
3 ;This routine gathers AR/WS dispensing data. It is called by PSGWUAS.
4 ;
5 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=""
6 ;get date dispensed,site(aou),drug,qty
7 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
8 .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"))
9 .S PSADRUG=$O(^PSI(58.5,"AMIS",PSA,PSADT,PSA(1),PSASIT,PSADRUG))
10 .;drug stocked by any primary DA location?
11 .Q:'PSADRUG!('$O(^PSD(58.8,"C",+PSADRUG,0)))
12 .S (PSAPS,PSADA)=0
13 .;If the location is active, the drug is tracked, & it is tracked in an
14 .;inpatient site, set the PSADA(PSAPS) array.
15 .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
16 .Q:'PSAPS
17 .S PSAQTY=$O(^PSI(58.5,"AMIS",PSA,PSADT,PSA(1),PSASIT,PSADRUG,0))
18 .S:PSA(1)="R" PSAQTY=-PSAQTY
19 .;drug stocked by only one DA location
20 .I PSAPS=1 S ^TMP("PSAR",$J,PSADRUG,PSADA(PSAPS))=PSAQTY+$G(^TMP("PSAR",$J,PSADRUG,PSADA(PSAPS))) Q
21 .;more than one, check site
22 .;
23 .;Dave B (PSA*3*3)
24 .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))
25COUNT G:'$O(^TMP("PSAR",$J,"")) END S PSAPS(1)=0
26 F PSA=0:1 S PSA=$O(^TMP("PSAR",$J,PSA)) Q:'PSA S PSAPS(1)=$G(PSAPS(1))+1
27 ;get transaction numbers
28 F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
29FIND 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
30 S PSAT=PSAD,DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(PSA,PSA(1))=""
31 F PSAD=PSAT:1:(PSAT+PSAPS(1)-1) S (DINUM,X)=PSAD D ^DIC
32 L -^PSD(58.81,0) K DIC,DINUM,DLAYGO
33 ;loop thru array
34 F S PSA=$O(^TMP("PSAR",$J,PSA)) Q:'PSA D
35 .S PSALOC=$O(^TMP("PSAR",$J,PSA,0))
36 .S PSAB(1)=$G(^TMP("PSAR",$J,PSA,PSALOC))
37 .;get date + current balance + update balance
38 .F L +^PSD(58.8,+PSALOC,1,+PSA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
39 .D NOW^%DTC
40 .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 %
41 .L -^PSD(58.8,+PSALOC,1,+PSA,0)
42 .;update monthly activity multiple
43 .S:'$D(^PSD(58.8,+PSALOC,1,+PSA,5,0)) ^(0)="^58.801A^^"
44 .I '$D(^PSD(58.8,+PSALOC,1,+PSA,5,$E(DT,1,5)*100,0)) D
45 ..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
46 ..S X="T-1M" D ^%DT S (X,DINUM)=$E(Y,1,5)*100 D ^DIC K DINUM
47 ..S DIE=DIC,DA=+Y,DR="3////^S X=$G(PSAB)" D ^DIE K DIE,DA
48 .S DIE="^PSD(58.8,+PSALOC,1,+PSA,5,",DA(2)=PSALOC,DA(1)=PSA
49 .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)"
50 .D ^DIE K DIE,DA
51 .;update transaction
52 .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
53 .D ^DIE
54 .S:'$D(^PSD(58.8,+PSALOC,1,+PSA,4,0)) ^(0)="^58.800119PA^^"
55 .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
56END K ^TMP("PSAR",$J)
57 Q
Note: See TracBrowser for help on using the repository browser.