PSIVWCR ;BIR/PR-BUILD WARD COST REPORT ;22 JUL 94 / 11:32 AM
;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
SUB ;Set sub routine variable
S S=$S(I3&(I2):1,'I3&('I2):2,I3&('I2):3,1:4) S:I2["NON" S=$S(I3:5,1:6) S:I2["." S=$S('I3:7,1:8)
;
HV ;Preset sum header variables
S (TD,TC,PC)=0,ZF="TOTAL FOR WARD: ",Y=I7 X ^DD("DD") S F=Y,Y=I8 X ^DD("DD") S L=Y,H=F_" THROUGH "_L,Y=DT X ^DD("DD") S NOW=Y K ^UTILITY($J),VA
;
RM1 ;Run report for one IV room
I I4 S V=I4 I $D(^PS(50.8,V,2)) F ST=I7-1:0 S ST=$O(^PS(50.8,V,2,ST)) Q:'ST!(ST>I8) S NA="" D @S
;
RMALL ;Run report for all IV rooms
I 'I4 F V=0:0 S V=$O(^PS(50.8,V)) Q:'V I $D(^PS(50.8,V,2)) F ST=I7-1:0 S ST=$O(^PS(50.8,V,2,ST)) Q:'ST!(ST>I8) S NA="" D @S
;
QUEUE ;Queue
G:'$D(I6) W S ZTIO=I6,ZTRTN="W^PSIVWCR",ZTDTH=$H,ZTDESC="IV WARD COST REPORT"
F G="^UTILITY($J,","I7","I8","H","NOW","I3","I2","I6","PC","TD","TC","ZF","I11","I10","I4","I15" S ZTSAVE(G)=""
S %ZIS="QN",IOP=I6 D ^%ZIS,^%ZTLOAD G K
;
W ;Enter here to print report
U IO I '$D(^UTILITY($J)) D H W !,$C(7),"No data." W:$D(I6)&($Y) @IOF D ^%ZISC G K
D H S AL="" F V=0:0 D F^PSIVWCR1 S V=$O(^UTILITY($J,V)) Q:'V W !,"IV ROOM: "_$P(^PS(59.5,V,0),U),! D P^PSIVWCR1
D T^PSIVWCR1 G K
;
5 ;N 1 w
F J=0:0 S NA=$O(^PS(50.8,V,2,ST,2,"B",NA)) Q:NA="" S DA=$O(^(+$O(^(NA,0)),0)) I DA D:^(DA)=1&($D(^PS(50.8,V,2,ST,2,DA,0)))&($D(^(3,I3,0))) B
Q
6 ;N all w
F J=0:0 S NA=$O(^PS(50.8,V,2,ST,2,"B",NA)) Q:NA="" S DA=$O(^(+$O(^(NA,0)),0)) I DA,^(DA)=1,$D(^PS(50.8,V,2,ST,2,DA,0)) F I3=0:0 S I3=$O(^PS(50.8,V,2,ST,2,DA,3,I3)) Q:'I3 D B
Q
1 ;1 d 1 w
F J=0:0 S NA=$O(^PS(50.8,V,2,ST,2,"B",NA)) Q:NA="" S DA=$O(^(NA,I2,0)) I DA,$D(^PS(50.8,V,2,ST,2,DA,0)),$D(^(3,I3,0)) D B
Q
2 ;All w all d
F DA=0:0 S DA=$O(^PS(50.8,V,2,ST,2,DA)) Q:'DA I $D(^(DA,0)) F I3=0:0 S I3=$O(^PS(50.8,V,2,ST,2,DA,3,I3)) Q:'I3 I $D(^(I3,0)) D B
Q
;
3 ;1 w all d
F DA=0:0 S DA=$O(^PS(50.8,V,2,ST,2,DA)) Q:'DA I $D(^(DA,0)),$D(^(3,I3,0)) D B
Q
4 ;All w 1 d
F J=0:0 S NA=$O(^PS(50.8,V,2,ST,2,"B",NA)) Q:NA="" S DA=$O(^(NA,I2,0)) I DA F I3=0:0 S I3=$O(^PS(50.8,V,2,ST,2,DA,3,I3)) Q:'I3 D B
Q
7 ;C all WD
F J=0:0 S NA=$O(^PS(50.8,V,2,ST,2,"B",NA)) Q:NA="" F D5=0:0 S D5=$O(^PS(50.8,V,2,ST,2,"B",NA,D5)) Q:'D5 S DA=$O(^(D5,0)) Q:'DA D:I2["V." 71 I '$D(VA),$D(^PS(50.2,"AD",$P(I2,".",2),D5)) F I3=0:0 S I3=$O(^PS(50.8,V,2,ST,2,DA,3,I3)) Q:'I3 D B
Q
71 ;V C all w
S VA=1
I I2["000" S MT=$E(I2,3,4) I $E($P(^PSDRUG(D5,0),U,2),1,2)=MT F I3=0:0 S I3=$O(^PS(50.8,V,2,ST,2,DA,3,I3)) Q:'I3 D B
Q:I2["000"
I $P(^PSDRUG(D5,0),U,2)=$P(I2,".",2) F I3=0:0 S I3=$O(^PS(50.8,V,2,ST,2,DA,3,I3)) Q:'I3 D B
Q
8 ;C 1 w
F J=0:0 S NA=$O(^PS(50.8,V,2,ST,2,"B",NA)) Q:NA="" F D5=0:0 S D5=$O(^PS(50.8,V,2,ST,2,"B",NA,D5)) Q:'D5 S DA=$O(^(D5,0)) Q:'DA D:I2["V." 81 I '$D(VA),$D(^PS(50.2,"AD",$P(I2,".",2),D5)),$D(^PS(50.8,V,2,ST,2,DA,3,I3,0)) D B
Q
81 ;V C 1 w
S VA=1
I I2["000" S MT=$E(I2,3,4) I $E($P(^PSDRUG(D5,0),U,2),1,2)=MT,$D(^PS(50.8,V,2,ST,2,DA,3,I3,0)) D B
Q:I2["000"
I $P(^PSDRUG(D5,0),U,2)=$P(I2,".",2),$D(^PS(50.8,V,2,ST,2,DA,3,I3,0)) D B
Q
B ;
S G=^PS(50.8,V,2,ST,2,DA,0),G2=^PS(50.8,V,2,ST,2,DA,3,I3,0),DG=$P(G,U),CO=$P(G,U,5),UM=$P(G,U,6),UD=$P(G2,U,2),UR=$P(G2,U,3),DEST=$P(G2,U,4),UC=$P(G2,U,5)
S J=$S($D(^UTILITY($J,V,I3,DG)):^(DG),1:CO_U_UM),^(DG)=$P(J,U,1,2)_U_($P(J,U,3)+UD)_U_(UD-UR-UC*CO+$P(J,U,4))_U_($P(J,U,5)+UR)_U_($P(J,U,6)+DEST)_U_($P(J,U,7)+UC)
Q
H ;
W:$Y @IOF S PC=PC+1 W !!,?56,"WARD/DRUG USAGE REPORT:",?120,"PAGE:",?102,$J(PC,4),!,?56,H
W !?56,I11,!?56,I10,!?56,I15
W !!!?1," DRUG NAME",?38," DISPENSED",?57,"(DESTROYED)",?77,"RECYCLED",?95,"CANCELLED",?123,"DRUG COST" W !
F LN=1:1:132 W "=" W:LN=132 !
Q
K K VA,AL,%,^UTILITY($J),V,B,C,DA,NOW,DG,F,H,L,G,G2,S,J,K,LN,NA,PC,I2,I3,UR,ST,TC,TD,CO,UD,UM,W,Y,Z,G3,I7,I8,ZF,DEST,UC,I9,I10,I11 S:$D(ZTQUEUED) ZTREQ="@" Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVWCR 3875 printed Sep 23, 2025@19:41:21 Page 2
PSIVWCR ;BIR/PR-BUILD WARD COST REPORT ;22 JUL 94 / 11:32 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
SUB ;Set sub routine variable
+1 SET S=$SELECT(I3&(I2):1,'I3&('I2):2,I3&('I2):3,1:4)
if I2["NON"
SET S=$SELECT(I3:5,1:6)
if I2["."
SET S=$SELECT('I3:7,1:8)
+2 ;
HV ;Preset sum header variables
+1 SET (TD,TC,PC)=0
SET ZF="TOTAL FOR WARD: "
SET Y=I7
XECUTE ^DD("DD")
SET F=Y
SET Y=I8
XECUTE ^DD("DD")
SET L=Y
SET H=F_" THROUGH "_L
SET Y=DT
XECUTE ^DD("DD")
SET NOW=Y
KILL ^UTILITY($JOB),VA
+2 ;
RM1 ;Run report for one IV room
+1 IF I4
SET V=I4
IF $DATA(^PS(50.8,V,2))
FOR ST=I7-1:0
SET ST=$ORDER(^PS(50.8,V,2,ST))
if 'ST!(ST>I8)
QUIT
SET NA=""
DO @S
+2 ;
RMALL ;Run report for all IV rooms
+1 IF 'I4
FOR V=0:0
SET V=$ORDER(^PS(50.8,V))
if 'V
QUIT
IF $DATA(^PS(50.8,V,2))
FOR ST=I7-1:0
SET ST=$ORDER(^PS(50.8,V,2,ST))
if 'ST!(ST>I8)
QUIT
SET NA=""
DO @S
+2 ;
QUEUE ;Queue
+1 if '$DATA(I6)
GOTO W
SET ZTIO=I6
SET ZTRTN="W^PSIVWCR"
SET ZTDTH=$HOROLOG
SET ZTDESC="IV WARD COST REPORT"
+2 FOR G="^UTILITY($J,","I7","I8","H","NOW","I3","I2","I6","PC","TD","TC","ZF","I11","I10","I4","I15"
SET ZTSAVE(G)=""
+3 SET %ZIS="QN"
SET IOP=I6
DO ^%ZIS
DO ^%ZTLOAD
GOTO K
+4 ;
W ;Enter here to print report
+1 USE IO
IF '$DATA(^UTILITY($JOB))
DO H
WRITE !,$CHAR(7),"No data."
if $DATA(I6)&($Y)
WRITE @IOF
DO ^%ZISC
GOTO K
+2 DO H
SET AL=""
FOR V=0:0
DO F^PSIVWCR1
SET V=$ORDER(^UTILITY($JOB,V))
if 'V
QUIT
WRITE !,"IV ROOM: "_$PIECE(^PS(59.5,V,0),U),!
DO P^PSIVWCR1
+3 DO T^PSIVWCR1
GOTO K
+4 ;
5 ;N 1 w
+1 FOR J=0:0
SET NA=$ORDER(^PS(50.8,V,2,ST,2,"B",NA))
if NA=""
QUIT
SET DA=$ORDER(^(+$ORDER(^(NA,0)),0))
IF DA
if ^(DA)=1&($DATA(^PS(50.8,V,2,ST,2,DA,0)))&($DATA(^(3,I3,0)))
DO B
+2 QUIT
6 ;N all w
+1 FOR J=0:0
SET NA=$ORDER(^PS(50.8,V,2,ST,2,"B",NA))
if NA=""
QUIT
SET DA=$ORDER(^(+$ORDER(^(NA,0)),0))
IF DA
IF ^(DA)=1
IF $DATA(^PS(50.8,V,2,ST,2,DA,0))
FOR I3=0:0
SET I3=$ORDER(^PS(50.8,V,2,ST,2,DA,3,I3))
if 'I3
QUIT
DO B
+2 QUIT
1 ;1 d 1 w
+1 FOR J=0:0
SET NA=$ORDER(^PS(50.8,V,2,ST,2,"B",NA))
if NA=""
QUIT
SET DA=$ORDER(^(NA,I2,0))
IF DA
IF $DATA(^PS(50.8,V,2,ST,2,DA,0))
IF $DATA(^(3,I3,0))
DO B
+2 QUIT
2 ;All w all d
+1 FOR DA=0:0
SET DA=$ORDER(^PS(50.8,V,2,ST,2,DA))
if 'DA
QUIT
IF $DATA(^(DA,0))
FOR I3=0:0
SET I3=$ORDER(^PS(50.8,V,2,ST,2,DA,3,I3))
if 'I3
QUIT
IF $DATA(^(I3,0))
DO B
+2 QUIT
+3 ;
3 ;1 w all d
+1 FOR DA=0:0
SET DA=$ORDER(^PS(50.8,V,2,ST,2,DA))
if 'DA
QUIT
IF $DATA(^(DA,0))
IF $DATA(^(3,I3,0))
DO B
+2 QUIT
4 ;All w 1 d
+1 FOR J=0:0
SET NA=$ORDER(^PS(50.8,V,2,ST,2,"B",NA))
if NA=""
QUIT
SET DA=$ORDER(^(NA,I2,0))
IF DA
FOR I3=0:0
SET I3=$ORDER(^PS(50.8,V,2,ST,2,DA,3,I3))
if 'I3
QUIT
DO B
+2 QUIT
7 ;C all WD
+1 FOR J=0:0
SET NA=$ORDER(^PS(50.8,V,2,ST,2,"B",NA))
if NA=""
QUIT
FOR D5=0:0
SET D5=$ORDER(^PS(50.8,V,2,ST,2,"B",NA,D5))
if 'D5
QUIT
SET DA=$ORDER(^(D5,0))
if 'DA
QUIT
if I2["V."
DO 71
IF '$DATA(VA)
IF $DATA(^PS(50.2,"AD",$PIECE(I2,".",2),D5))
FOR I3=0:0
SET I3=$ORDER(^PS(50.8,V,2,ST,2,DA,3,I3))
if 'I3
QUIT
DO B
+2 QUIT
71 ;V C all w
+1 SET VA=1
+2 IF I2["000"
SET MT=$EXTRACT(I2,3,4)
IF $EXTRACT($PIECE(^PSDRUG(D5,0),U,2),1,2)=MT
FOR I3=0:0
SET I3=$ORDER(^PS(50.8,V,2,ST,2,DA,3,I3))
if 'I3
QUIT
DO B
+3 if I2["000"
QUIT
+4 IF $PIECE(^PSDRUG(D5,0),U,2)=$PIECE(I2,".",2)
FOR I3=0:0
SET I3=$ORDER(^PS(50.8,V,2,ST,2,DA,3,I3))
if 'I3
QUIT
DO B
+5 QUIT
8 ;C 1 w
+1 FOR J=0:0
SET NA=$ORDER(^PS(50.8,V,2,ST,2,"B",NA))
if NA=""
QUIT
FOR D5=0:0
SET D5=$ORDER(^PS(50.8,V,2,ST,2,"B",NA,D5))
if 'D5
QUIT
SET DA=$ORDER(^(D5,0))
if 'DA
QUIT
if I2["V."
DO 81
IF '$DATA(VA)
IF $DATA(^PS(50.2,"AD",$PIECE(I2,".",2),D5))
IF $DATA(^PS(50.8,V,2,ST,2,DA,3,I3,0))
DO B
+2 QUIT
81 ;V C 1 w
+1 SET VA=1
+2 IF I2["000"
SET MT=$EXTRACT(I2,3,4)
IF $EXTRACT($PIECE(^PSDRUG(D5,0),U,2),1,2)=MT
IF $DATA(^PS(50.8,V,2,ST,2,DA,3,I3,0))
DO B
+3 if I2["000"
QUIT
+4 IF $PIECE(^PSDRUG(D5,0),U,2)=$PIECE(I2,".",2)
IF $DATA(^PS(50.8,V,2,ST,2,DA,3,I3,0))
DO B
+5 QUIT
B ;
+1 SET G=^PS(50.8,V,2,ST,2,DA,0)
SET G2=^PS(50.8,V,2,ST,2,DA,3,I3,0)
SET DG=$PIECE(G,U)
SET CO=$PIECE(G,U,5)
SET UM=$PIECE(G,U,6)
SET UD=$PIECE(G2,U,2)
SET UR=$PIECE(G2,U,3)
SET DEST=$PIECE(G2,U,4)
SET UC=$PIECE(G2,U,5)
+2 SET J=$SELECT($DATA(^UTILITY($JOB,V,I3,DG)):^(DG),1:CO_U_UM)
SET ^(DG)=$PIECE(J,U,1,2)_U_($PIECE(J,U,3)+UD)_U_(UD-UR-UC*CO+$PIECE(J,U,4))_U_($PIECE(J,U,5)+UR)_U_($PIECE(J,U,6)+DEST)_U_($PIECE(J,U,7)+UC)
+3 QUIT
H ;
+1 if $Y
WRITE @IOF
SET PC=PC+1
WRITE !!,?56,"WARD/DRUG USAGE REPORT:",?120,"PAGE:",?102,$JUSTIFY(PC,4),!,?56,H
+2 WRITE !?56,I11,!?56,I10,!?56,I15
+3 WRITE !!!?1," DRUG NAME",?38," DISPENSED",?57,"(DESTROYED)",?77,"RECYCLED",?95,"CANCELLED",?123,"DRUG COST"
WRITE !
+4 FOR LN=1:1:132
WRITE "="
if LN=132
WRITE !
+5 QUIT
K KILL VA,AL,%,^UTILITY($JOB),V,B,C,DA,NOW,DG,F,H,L,G,G2,S,J,K,LN,NA,PC,I2,I3,UR,ST,TC,TD,CO,UD,UM,W,Y,Z,G3,I7,I8,ZF,DEST,UC,I9,I10,I11
if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
