source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVDCR.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 4.0 KB
Line 
1PSIVDCR ;BIR/PR-BUILD DRUG COST RPT. ;16 DEC 97 / 1:39 PM
2 ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
3SUB ;Set the sub routine call variable
4 S S=$S(I2="ALL":1,I2="NON":2,I2:3,I2["C.":4,I2["V.":5,I2["T.":6,1:1) K ^UTILITY($J),^("PSIV",$J),VA,TYPE
5 ;
6RM1 ;1 IV room
7 I I4 S V=I4 I $D(^PS(50.8,V,2)) F DAT=I7-1:0 S DAT=$O(^PS(50.8,V,2,DAT)) Q:'DAT!(DAT>I8) I $D(^(DAT,2)) S NA="" D @S
8 ;
9RMALL ;All IV rooms
10 I 'I4 F V=0:0 S V=$O(^PS(50.8,V)) Q:'V I $D(^(V,2)) F DAT=I7-1:0 S DAT=$O(^PS(50.8,V,2,DAT)) Q:'DAT!(DAT>I8) I $D(^(DAT,2)) S NA="" D @S
11 ;
12 I $D(I6) S ZTIO=I6,ZTDESC="IV DRUG COST REPORT (PRINT)",ZTRTN="W^PSIVDCR1",ZTDTH=$H F G="^UTILITY($J,","I7","I8","I2","BRIEF","SMO","PQ","I10","DUZ","I6","LCO","UCO","I15","I4" S ZTSAVE(G)=""
13 I S %ZIS="QN",IOP=I6 D ^%ZIS,^%ZTLOAD G K
14 ;
15NQ ;No queue so go print.
16 D ^PSIVDCR1 G K
171 ;All drugs or high/low cost
18 F DA=0:0 S DA=$O(^PS(50.8,V,2,DAT,2,DA)) Q:'DA I $D(^(DA,0)) D B
19 Q
202 ;Non-formulary drugs
21 F J=0:0 S NA=$O(^PS(50.8,V,2,DAT,2,"B",NA)) Q:NA="" S DA=$O(^(+$O(^(NA,0)),0)) I DA,^(DA)=1 D B
22 Q
233 ;1 drug
24 F J=0:0 S NA=$O(^PS(50.8,V,2,DAT,2,"B",NA)) Q:NA="" S DA=$O(^(NA,I2,0)) I DA,$D(^PS(50.8,V,2,DAT,2,DA,0)) D B
25 Q
264 ;IV category
27 F J=0:0 S NA=$O(^PS(50.8,V,2,DAT,2,"B",NA)) Q:NA="" F D5=0:0 S D5=$O(^PS(50.8,V,2,DAT,2,"B",NA,D5)) Q:'D5 S DA=$O(^(D5,0)) Q:'DA I $D(^PS(50.2,"AD",$P(I2,".",2),D5)),$D(^PS(50.8,V,2,DAT,2,DA,0)) D B
28 Q
295 ;VA drug class code
30 ;NOTE: Outpatient 5.6 must be installed for this feature to work.
31 F J=0:0 S NA=$O(^PS(50.8,V,2,DAT,2,"B",NA)) Q:NA="" F D5=0:0 S D5=$O(^PS(50.8,V,2,DAT,2,"B",NA,D5)) Q:'D5 S DA=$O(^(D5,0)) Q:'DA I $D(^PS(50.8,V,2,DAT,2,DA,0)) D 51
32 Q
3351 ;VA code continued
34 I I2["000" S MT=$E(I2,3,4) I $E($P(^PSDRUG(D5,0),U,2),1,2)=MT D B
35 Q:I2["000"
36 I $P(^PSDRUG(D5,0),U,2)=$P(I2,".",2) D B
37 Q
386 ;IV type A,P,H,C,S NOTE: This report cannot include patient data.
39 S TYPE=$P(I2,".",2) F DA=0:0 S DA=$O(^PS(50.8,V,2,DAT,2,DA)) Q:'DA I $D(^(DA,0)) D 61
40 Q
4161 ;IV type continued
42 F TW=0:0 S TW=$O(^PS(50.8,V,2,DAT,2,DA,3,TW)) Q:'TW I $D(^(TW,1)) S DA(1)=$O(^PS(50.8,V,2,DAT,2,DA,3,TW,"B",TYPE,0)) I DA(1) S G1=^PS(50.8,V,2,DAT,2,DA,3,TW,1,DA(1),0) D B
43 Q
44B ;Build utility by the (W)ard or (P)atient subfile of the drug subfile.
45 ;If patient data requested ($D(PQ)), build by patient, else by ward.
46 ;Note: If report is for IV type I reset B1-B4,U1-U4,C1-C4
47 ;
48 S G=^PS(50.8,V,2,DAT,2,DA,0),DRUG=$E($P(G,U),1,34),B1=$P(G,U,8),B3=$P(G,U,9),B2=$P(G,U,10),B4=$P(G,U,11),UNCOST=$P(G,U,5),UM=$P(G,U,6),U1=$P(G,U,2),U3=$P(G,U,3),U2=$P(G,U,4),U4=$P(G,U,12)
49 I $D(TYPE) S B1=$P(G1,U,8),B3=$P(G1,U,9),B2=$P(G1,U,10),B4=$P(G1,U,11),U1=$P(G1,U,2),U3=$P(G1,U,3),U2=$P(G1,U,4),U4=$P(G1,U,5)
50 S:'$D(^UTILITY($J,V,"H",DRUG,0)) ^(0)="" S J=^(0),$P(J,U)=UM,$P(J,U,20)=$P(J,U,20)+B1,$P(J,U,21)=$P(J,U,21)+B3,$P(J,U,23)=$P(J,U,23)+B4,$P(J,U,22)=$P(J,U,22)+B2,$P(J,U,5)=$P(J,U,5)+(U1-U3-U4*UNCOST),^(0)=J
51 F W=0:0 S W=$O(^PS(50.8,V,2,DAT,2,DA,3,W)) Q:'W I $D(^(W,0)) S WD=$S($D(^DIC(42,W,0)):$P(^(0),U),1:"OUTPATIENT") D:'$D(PQ) B1 I $D(PQ) F P=0:0 S P=$O(^PS(50.8,V,2,DAT,2,DA,1,P)) Q:'P I $D(^(P,0)),$P(^(0),U,5)=W S PD=$P(^DPT(P,0),U)_"/"_P D B1
52 Q
53B1 ;
54 S G=^PS(50.8,V,2,DAT,2,DA,$S($D(PQ):1,1:3),$S($D(PQ):P,1:W),0),U1=$P(G,U,2),U3=$P(G,U,3),U2=$P(G,U,4),U4=$P(G,U,$S($D(PQ):6,1:5)),C1=$P(G,U,2)*UNCOST,C3=$P(G,U,3)*UNCOST,C4=$P(G,U,$S($D(PQ):6,1:5))*UNCOST,C2=$P(G,U,4)*UNCOST
55 I $D(TYPE) Q:TW'=W S U1=$P(G1,U,2),U3=$P(G1,U,3),U2=$P(G1,U,4),U4=$P(G1,U,5),C1=$P(G1,U,2)*UNCOST,C3=$P(G1,U,3)*UNCOST,C2=$P(G1,U,4)*UNCOST,G4=$P(G1,U,5)*UNCOST
56 ;
57 S:'$D(^UTILITY($J,V,"H",DRUG,WD,$S($D(PQ):PD,1:"NO"),0)) ^(0)="" S J=^(0),$P(J,U)=$P(J,U)+(U1-U3-U4*UNCOST),$P(J,U,8)=$P(J,U,8)+U1,$P(J,U,9)=$P(J,U,9)+U3,$P(J,U,10)=$P(J,U,10)+U2,$P(J,U,11)=$P(J,U,11)+U4 D B2 S ^(0)=J
58 Q
59B2 ;
60 S $P(J,U,40)=$P(J,U,40)+C1,$P(J,U,41)=$P(J,U,41)+C3,$P(J,U,42)=$P(J,U,42)+C2,$P(J,U,43)=$P(J,U,43)+C4
61 Q
62K ;
63 S:$D(ZTQUEUED) ZTREQ="@"
64 K %ZIS,B4,B1,B2,B3,C4,C1,C2,C3,D5,DA,DAT,U4,U2,U1,U3,DRUG,G,I2,I6,I7,I8,J,MT,NA,P,PD,PQ,S,U4,U1,U2,UM,UNCOST,U3,V,VA,W,WD,TYPE,G1,TW,DA(1),I4,I15,%,%I,C,US,X,BRIEF,SMO
Note: See TracBrowser for help on using the repository browser.