PSIVDCR ;BIR/PR-BUILD DRUG COST RPT. ;16 DEC 97 / 1:39 PM
;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
SUB ;Set the sub routine call variable
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
;
RM1 ;1 IV room
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
;
RMALL ;All IV rooms
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
;
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)=""
I S %ZIS="QN",IOP=I6 D ^%ZIS,^%ZTLOAD G K
;
NQ ;No queue so go print.
D ^PSIVDCR1 G K
1 ;All drugs or high/low cost
F DA=0:0 S DA=$O(^PS(50.8,V,2,DAT,2,DA)) Q:'DA I $D(^(DA,0)) D B
Q
2 ;Non-formulary drugs
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
Q
3 ;1 drug
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
Q
4 ;IV category
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
Q
5 ;VA drug class code
;NOTE: Outpatient 5.6 must be installed for this feature to work.
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
Q
51 ;VA code continued
I I2["000" S MT=$E(I2,3,4) I $E($P(^PSDRUG(D5,0),U,2),1,2)=MT D B
Q:I2["000"
I $P(^PSDRUG(D5,0),U,2)=$P(I2,".",2) D B
Q
6 ;IV type A,P,H,C,S NOTE: This report cannot include patient data.
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
Q
61 ;IV type continued
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
Q
B ;Build utility by the (W)ard or (P)atient subfile of the drug subfile.
;If patient data requested ($D(PQ)), build by patient, else by ward.
;Note: If report is for IV type I reset B1-B4,U1-U4,C1-C4
;
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)
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)
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
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
Q
B1 ;
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
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
;
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
Q
B2 ;
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
Q
K ;
S:$D(ZTQUEUED) ZTREQ="@"
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVDCR 4138 printed Dec 13, 2024@02:04 Page 2
PSIVDCR ;BIR/PR-BUILD DRUG COST RPT. ;16 DEC 97 / 1:39 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
SUB ;Set the sub routine call variable
+1 SET S=$SELECT(I2="ALL":1,I2="NON":2,I2:3,I2["C.":4,I2["V.":5,I2["T.":6,1:1)
KILL ^UTILITY($JOB),^("PSIV",$JOB),VA,TYPE
+2 ;
RM1 ;1 IV room
+1 IF I4
SET V=I4
IF $DATA(^PS(50.8,V,2))
FOR DAT=I7-1:0
SET DAT=$ORDER(^PS(50.8,V,2,DAT))
if 'DAT!(DAT>I8)
QUIT
IF $DATA(^(DAT,2))
SET NA=""
DO @S
+2 ;
RMALL ;All IV rooms
+1 IF 'I4
FOR V=0:0
SET V=$ORDER(^PS(50.8,V))
if 'V
QUIT
IF $DATA(^(V,2))
FOR DAT=I7-1:0
SET DAT=$ORDER(^PS(50.8,V,2,DAT))
if 'DAT!(DAT>I8)
QUIT
IF $DATA(^(DAT,2))
SET NA=""
DO @S
+2 ;
+3 IF $DATA(I6)
SET ZTIO=I6
SET ZTDESC="IV DRUG COST REPORT (PRINT)"
SET ZTRTN="W^PSIVDCR1"
SET ZTDTH=$HOROLOG
FOR G="^UTILITY($J,","I7","I8","I2","BRIEF","SMO","PQ","I10","DUZ","I6","LCO","UCO","I15","I4"
SET ZTSAVE(G)=""
+4 IF $TEST
SET %ZIS="QN"
SET IOP=I6
DO ^%ZIS
DO ^%ZTLOAD
GOTO K
+5 ;
NQ ;No queue so go print.
+1 DO ^PSIVDCR1
GOTO K
1 ;All drugs or high/low cost
+1 FOR DA=0:0
SET DA=$ORDER(^PS(50.8,V,2,DAT,2,DA))
if 'DA
QUIT
IF $DATA(^(DA,0))
DO B
+2 QUIT
2 ;Non-formulary drugs
+1 FOR J=0:0
SET NA=$ORDER(^PS(50.8,V,2,DAT,2,"B",NA))
if NA=""
QUIT
SET DA=$ORDER(^(+$ORDER(^(NA,0)),0))
IF DA
IF ^(DA)=1
DO B
+2 QUIT
3 ;1 drug
+1 FOR J=0:0
SET NA=$ORDER(^PS(50.8,V,2,DAT,2,"B",NA))
if NA=""
QUIT
SET DA=$ORDER(^(NA,I2,0))
IF DA
IF $DATA(^PS(50.8,V,2,DAT,2,DA,0))
DO B
+2 QUIT
4 ;IV category
+1 FOR J=0:0
SET NA=$ORDER(^PS(50.8,V,2,DAT,2,"B",NA))
if NA=""
QUIT
FOR D5=0:0
SET D5=$ORDER(^PS(50.8,V,2,DAT,2,"B",NA,D5))
if 'D5
QUIT
SET DA=$ORDER(^(D5,0))
if 'DA
QUIT
IF $DATA(^PS(50.2,"AD",$PIECE(I2,".",2),D5))
IF $DATA(^PS(50.8,V,2,DAT,2,DA,0))
DO B
+2 QUIT
5 ;VA drug class code
+1 ;NOTE: Outpatient 5.6 must be installed for this feature to work.
+2 FOR J=0:0
SET NA=$ORDER(^PS(50.8,V,2,DAT,2,"B",NA))
if NA=""
QUIT
FOR D5=0:0
SET D5=$ORDER(^PS(50.8,V,2,DAT,2,"B",NA,D5))
if 'D5
QUIT
SET DA=$ORDER(^(D5,0))
if 'DA
QUIT
IF $DATA(^PS(50.8,V,2,DAT,2,DA,0))
DO 51
+3 QUIT
51 ;VA code continued
+1 IF I2["000"
SET MT=$EXTRACT(I2,3,4)
IF $EXTRACT($PIECE(^PSDRUG(D5,0),U,2),1,2)=MT
DO B
+2 if I2["000"
QUIT
+3 IF $PIECE(^PSDRUG(D5,0),U,2)=$PIECE(I2,".",2)
DO B
+4 QUIT
6 ;IV type A,P,H,C,S NOTE: This report cannot include patient data.
+1 SET TYPE=$PIECE(I2,".",2)
FOR DA=0:0
SET DA=$ORDER(^PS(50.8,V,2,DAT,2,DA))
if 'DA
QUIT
IF $DATA(^(DA,0))
DO 61
+2 QUIT
61 ;IV type continued
+1 FOR TW=0:0
SET TW=$ORDER(^PS(50.8,V,2,DAT,2,DA,3,TW))
if 'TW
QUIT
IF $DATA(^(TW,1))
SET DA(1)=$ORDER(^PS(50.8,V,2,DAT,2,DA,3,TW,"B",TYPE,0))
IF DA(1)
SET G1=^PS(50.8,V,2,DAT,2,DA,3,TW,1,DA(1),0)
DO B
+2 QUIT
B ;Build utility by the (W)ard or (P)atient subfile of the drug subfile.
+1 ;If patient data requested ($D(PQ)), build by patient, else by ward.
+2 ;Note: If report is for IV type I reset B1-B4,U1-U4,C1-C4
+3 ;
+4 SET G=^PS(50.8,V,2,DAT,2,DA,0)
SET DRUG=$EXTRACT($PIECE(G,U),1,34)
SET B1=$PIECE(G,U,8)
SET B3=$PIECE(G,U,9)
SET B2=$PIECE(G,U,10)
SET B4=$PIECE(G,U,11)
SET UNCOST=$PIECE(G,U,5)
SET UM=$PIECE(G,U,6)
SET U1=$PIECE(G,U,2)
SET U3=$PIECE(G,U,3)
SET U2=$PIECE(G,U,4)
SET U4=$PIECE(G,U,12)
+5 IF $DATA(TYPE)
SET B1=$PIECE(G1,U,8)
SET B3=$PIECE(G1,U,9)
SET B2=$PIECE(G1,U,10)
SET B4=$PIECE(G1,U,11)
SET U1=$PIECE(G1,U,2)
SET U3=$PIECE(G1,U,3)
SET U2=$PIECE(G1,U,4)
SET U4=$PIECE(G1,U,5)
+6 if '$DATA(^UTILITY($JOB,V,"H",DRUG,0))
SET ^(0)=""
SET J=^(0)
SET $PIECE(J,U)=UM
SET $PIECE(J,U,20)=$PIECE(J,U,20)+B1
SET $PIECE(J,U,21)=$PIECE(J,U,21)+B3
SET $PIECE(J,U,23)=$PIECE(J,U,23)+B4
SET $PIECE(J,U,22)=$PIECE(J,U,22)+B2
SET $PIECE(J,U,5)=$PIECE(J,U,5)+(U1-U3-U4*UNCOST)
SET ^(0)=J
+7 FOR W=0:0
SET W=$ORDER(^PS(50.8,V,2,DAT,2,DA,3,W))
if 'W
QUIT
IF $DATA(^(W,0))
SET WD=$SELECT($DATA(^DIC(42,W,0)):$PIECE(^(0),U),1:"OUTPATIENT")
if '$DATA(PQ)
DO B1
IF $DATA(PQ)
FOR P=0:0
SET P=$ORDER(^PS(50.8,V,2,DAT,2,DA,1,P))
if 'P
QUIT
IF $DATA(^(P,0))
IF $PIECE(^(0),U,5)=W
SET PD=$PIECE(^DPT(P,0),U)_"/"_P
DO B1
+8 QUIT
B1 ;
+1 SET G=^PS(50.8,V,2,DAT,2,DA,$SELECT($DATA(PQ):1,1:3),$SELECT($DATA(PQ):P,1:W),0)
SET U1=$PIECE(G,U,2)
SET U3=$PIECE(G,U,3)
SET U2=$PIECE(G,U,4)
SET U4=$PIECE(G,U,$SELECT($DATA(PQ):6,1:5))
SET C1=$PIECE(G,U,2)*UNCOST
SET C3=$PIECE(G,U,3)*UNCOST
SET C4=$PIECE(G,U,$SELECT($DATA(PQ):6,1:5))*UNCOST
SET C2=$PIECE(G,U,4)*UNCOST
+2 IF $DATA(TYPE)
if TW'=W
QUIT
SET U1=$PIECE(G1,U,2)
SET U3=$PIECE(G1,U,3)
SET U2=$PIECE(G1,U,4)
SET U4=$PIECE(G1,U,5)
SET C1=$PIECE(G1,U,2)*UNCOST
SET C3=$PIECE(G1,U,3)*UNCOST
SET C2=$PIECE(G1,U,4)*UNCOST
SET G4=$PIECE(G1,U,5)*UNCOST
+3 ;
+4 if '$DATA(^UTILITY($JOB,V,"H",DRUG,WD,$SELECT($DATA(PQ)
SET ^(0)=""
SET J=^(0)
SET $PIECE(J,U)=$PIECE(J,U)+(U1-U3-U4*UNCOST)
SET $PIECE(J,U,8)=$PIECE(J,U,8)+U1
SET $PIECE(J,U,9)=$PIECE(J,U,9)+U3
SET $PIECE(J,U,10)=$PIECE(J,U,10)+U2
SET $PIECE(J,U,11)=$PIECE(J,U,11)+U4
DO B2
SET ^(0)=J
+5 QUIT
B2 ;
+1 SET $PIECE(J,U,40)=$PIECE(J,U,40)+C1
SET $PIECE(J,U,41)=$PIECE(J,U,41)+C3
SET $PIECE(J,U,42)=$PIECE(J,U,42)+C2
SET $PIECE(J,U,43)=$PIECE(J,U,43)+C4
+2 QUIT
K ;
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 KILL %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
