PSOMGMN3 ;BHAM ISC/JMB - MONTHLY MANAGEMENT PRESCRIPTION COSTS REPORT ;3/19/93
;;7.0;OUTPATIENT PHARMACY;**14,175**;DEC 1997
EN S (CNT,PG)=0,(T1,T2)="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^" D:ANS="A" PRI I ANS="S" S (S1(DIV),S2(DIV))="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^" D DV
Q
RPT ;HEADER
S PG=PG+1 W:CNT @IOF S CNT=CNT+1 U IO W !!?30,"O U T P A T I E N T P H A R M A C Y M A N A G E M E N T R E P O R T",!?57,"PRESCRIPTION COSTS",?123,"PAGE ",PG
W !!?45,"FROM "_$E(SDT,4,5)_"/"_$E(SDT,2,3),?60,"TO "_$E(EDT,4,5)_"/"_$E(EDT,2,3)_" "_$S('PRT:"DIVISION: "_$P(^PS(59,DIV,0),"^"),1:"ALL DIVISIONS")
W !! F K=1:1:10 W $J($P("^AVG^AVG^AVG^AVG COST^AVG^TOT^TOT^TOT^AVG PARTIC","^",K),13)
W !,"DATE",?13 F K=1:1:9 W $J($P("STAFF^FEE^RX^PER EQ FL^METH^RX^METH^PART PHARM^PHARM RX","^",K),13)
W ! F K=1:1:131 W "-"
Q
PRI S T2="0^0^0^0^0^0^0^0^0^0^0^0^0^0.0",T3="0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00",(PG,QTMREQ,QTCST)=0 F DIV=0:0 S DIV=$O(^PS(59,DIV)) Q:'DIV S (S1(DIV),S2(DIV))="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^",QCST=0,QMREQ=0 D DV
D TOT^PSOMGM31 Q
DV S (BEG,PRT)=0 D RPT S S3(DIV)="0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00" F PDATE=SDT-1:0 S PDATE=$O(^PS(59.12,PDATE)) D:$Y+6>IOSL RPT D:'PDATE!(PDATE>EDT) SUB^PSOMGM31 Q:'PDATE!(PDATE>EDT) D
.S DVMN=DIV_"^"_$E(PDATE,1,5)
.I 'BEG S PRV=DIV_"^"_$E(PDATE,1,5),M1(DVMN)="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0",M2(DVMN)="0^0^0^0^0^0^0^0^0^0^0^0^0^0",M3(DVMN)="0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00",BEG=1
.I DVMN'=PRV D MON S PRV=DIV_"^"_$E(PDATE,1,5),M1(DVMN)="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0",M2(DVMN)="0^0^0^0^0^0^0^0^0^0^0^0^0^0",M3(DVMN)="0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00"
.Q:'$G(^PS(59.12,PDATE,3,DIV,0))
.D LN
I QTR W !!,"QUARTER "_QTR_" OUTPATIENT PRESCRIPTION COSTS/PATIENT = $"_$FN($S(QCST=0!(QMREQ=0):0,1:QCST/QMREQ),"",2)
E W !!,"QUARTERLY OUTPATIENT PRESCRIPTION COST/PATIENT NOT AVAILABLE"
I ANS="S" W !!!?17,"FINISHED PRINTING ON: " D NOW^%DTC S Y=% X ^DD("DD") W Y,@IOF
Q
LN F K=4:1:10 S $P(M3(DVMN),"^",K)=$P(M3(DVMN),"^",K)+$P(^PS(59.12,PDATE,3,DIV,0),"^",K),$P(S3(DIV),"^",K)=$P(S3(DIV),"^",K)+$P(^PS(59.12,PDATE,3,DIV,0),"^",K) S:$D(T3) $P(T3,"^",K)=$P(T3,"^",K)+$P(^PS(59.12,PDATE,3,DIV,0),"^",K)
S AVGST=$P(^PS(59.12,PDATE,3,DIV,0),"^",2)*$P(^PS(59.12,PDATE,2,DIV,0),"^",4),$P(M3(DVMN),"^",2)=$P(M3(DVMN),"^",2)+AVGST,$P(S3(DIV),"^",2)=$P(S3(DIV),"^",2)+AVGST S:$D(T3) $P(T3,"^",2)=$P(T3,"^",2)+AVGST K AVGST
S AVGFEE=$P(^PS(59.12,PDATE,3,DIV,0),"^",3)*$P(^PS(59.12,PDATE,2,DIV,0),"^",3),$P(M3(DVMN),"^",3)=$P(M3(DVMN),"^",3)+AVGFEE,$P(S3(DIV),"^",3)=$P(S3(DIV),"^",3)+AVGFEE S:$D(T3) $P(T3,"^",3)=$P(T3,"^",3)+AVGFEE K AVGFEE
F K=10,11,12 S $P(M1(DVMN),"^",K)=$P(M1(DVMN),"^",K)+$P(^PS(59.12,PDATE,1,DIV,0),"^",K),$P(S1(DIV),"^",K)=$P(S1(DIV),"^",K)+$P(^PS(59.12,PDATE,1,DIV,0),"^",K),$P(T1,"^",K)=$P(T1,"^",K)+$P(^PS(59.12,PDATE,1,DIV,0),"^",K)
F K=3,4,13 S $P(M2(DVMN),"^",K)=$P(M2(DVMN),"^",K)+$P(^PS(59.12,PDATE,2,DIV,0),"^",K),$P(S2(DIV),"^",K)=$P(S2(DIV),"^",K)+$P(^PS(59.12,PDATE,2,DIV,0),"^",K),$P(T2,"^",K)=$P(T2,"^",K)+$P(^PS(59.12,PDATE,2,DIV,0),"^",K)
I QTR,$E(PDATE,1,3)=$E(SDT,1,3),$E(PDATE,4,5)'<Q1&($E(PDATE,4,5)'>Q2) S QMREQ=+$G(QMREQ)+$P(^PS(59.12,PDATE,1,DIV,0),"^",14),QCST=+$G(QCST)+$P(^PS(59.12,PDATE,3,DIV,0),"^",7) D
.S QTMREQ=+$G(QTMREQ)+$P(^PS(59.12,PDATE,1,DIV,0),"^",14),QTCST=+$G(QTCST)+$P(^PS(59.12,PDATE,3,DIV,0),"^",7)
Q
MON ;PRINT MONTHLY TOTALS
W !,$E($P(PRV,"^",2),4,5)_"/"_$E($P(PRV,"^",2),2,3),?13,$J($FN($S($P(M2(PRV),"^",4)=0!($P(M3(PRV),"^",2)=0):0,1:$P(M3(PRV),"^",2)/$P(M2(PRV),"^",4)),"",2),13)
W $J($FN($S($P(M2(PRV),"^",3)=0!($P(M3(PRV),"^",3)=0):0,1:$P(M3(PRV),"^",3)/$P(M2(PRV),"^",3)),"",2),13),$J($FN($S($P(M3(PRV),"^",7)=0!($P(M1(PRV),"^",12)=0):0,1:($P(M3(PRV),"^",7)/$P(M1(PRV),"^",12))),"",2),13)
W $J($FN($S($P(M3(PRV),"^",7)=0!($P(M1(PRV),"^",10)=0):0,1:$P(M3(PRV),"^",7)/$P(M1(PRV),"^",10)),"",2),13),$J($FN($S($P(M3(PRV),"^",8)=0!($P(M1(PRV),"^",11)=0):0,1:$P(M3(PRV),"^",8)/$P(M1(PRV),"^",11)),"",2),13)
W $J($FN($P(M3(PRV),"^",7),"",2),13),$J($FN($P(M3(PRV),"^",8),"",2),13),$J($FN($P(M3(PRV),"^",9),"",2),13),$J($FN($S($P(M3(PRV),"^",9)=0!($P(M2(PRV),"^",13)=0):0,1:$P(M3(PRV),"^",9)/$P(M2(PRV),"^",13)),"",2),13)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOMGMN3 4267 printed Nov 22, 2024@17:41:04 Page 2
PSOMGMN3 ;BHAM ISC/JMB - MONTHLY MANAGEMENT PRESCRIPTION COSTS REPORT ;3/19/93
+1 ;;7.0;OUTPATIENT PHARMACY;**14,175**;DEC 1997
EN SET (CNT,PG)=0
SET (T1,T2)="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^"
if ANS="A"
DO PRI
IF ANS="S"
SET (S1(DIV),S2(DIV))="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^"
DO DV
+1 QUIT
RPT ;HEADER
+1 SET PG=PG+1
if CNT
WRITE @IOF
SET CNT=CNT+1
USE IO
WRITE !!?30,"O U T P A T I E N T P H A R M A C Y M A N A G E M E N T R E P O R T",!?57,"PRESCRIPTION COSTS",?123,"PAGE ",PG
+2 WRITE !!?45,"FROM "_$EXTRACT(SDT,4,5)_"/"_$EXTRACT(SDT,2,3),?60,"TO "_$EXTRACT(EDT,4,5)_"/"_$EXTRACT(EDT,2,3)_" "_$SELECT('PRT:"DIVISION: "_$PIECE(^PS(59,DIV,0),"^"),1:"ALL DIVISIONS")
+3 WRITE !!
FOR K=1:1:10
WRITE $JUSTIFY($PIECE("^AVG^AVG^AVG^AVG COST^AVG^TOT^TOT^TOT^AVG PARTIC","^",K),13)
+4 WRITE !,"DATE",?13
FOR K=1:1:9
WRITE $JUSTIFY($PIECE("STAFF^FEE^RX^PER EQ FL^METH^RX^METH^PART PHARM^PHARM RX","^",K),13)
+5 WRITE !
FOR K=1:1:131
WRITE "-"
+6 QUIT
PRI SET T2="0^0^0^0^0^0^0^0^0^0^0^0^0^0.0"
SET T3="0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00"
SET (PG,QTMREQ,QTCST)=0
FOR DIV=0:0
SET DIV=$ORDER(^PS(59,DIV))
if 'DIV
QUIT
SET (S1(DIV),S2(DIV))="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^"
SET QCST=0
SET QMREQ=0
DO DV
+1 DO TOT^PSOMGM31
QUIT
DV SET (BEG,PRT)=0
DO RPT
SET S3(DIV)="0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00"
FOR PDATE=SDT-1:0
SET PDATE=$ORDER(^PS(59.12,PDATE))
if $Y+6>IOSL
DO RPT
if 'PDATE!(PDATE>EDT)
DO SUB^PSOMGM31
if 'PDATE!(PDATE>EDT)
QUIT
Begin DoDot:1
+1 SET DVMN=DIV_"^"_$EXTRACT(PDATE,1,5)
+2 IF 'BEG
SET PRV=DIV_"^"_$EXTRACT(PDATE,1,5)
SET M1(DVMN)="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
SET M2(DVMN)="0^0^0^0^0^0^0^0^0^0^0^0^0^0"
SET M3(DVMN)="0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00"
SET BEG=1
+3 IF DVMN'=PRV
DO MON
SET PRV=DIV_"^"_$EXTRACT(PDATE,1,5)
SET M1(DVMN)="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
SET M2(DVMN)="0^0^0^0^0^0^0^0^0^0^0^0^0^0"
SET M3(DVMN)="0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00"
+4 if '$GET(^PS(59.12,PDATE,3,DIV,0))
QUIT
+5 DO LN
End DoDot:1
+6 IF QTR
WRITE !!,"QUARTER "_QTR_" OUTPATIENT PRESCRIPTION COSTS/PATIENT = $"_$FNUMBER($SELECT(QCST=0!(QMREQ=0):0,1:QCST/QMREQ),"",2)
+7 IF '$TEST
WRITE !!,"QUARTERLY OUTPATIENT PRESCRIPTION COST/PATIENT NOT AVAILABLE"
+8 IF ANS="S"
WRITE !!!?17,"FINISHED PRINTING ON: "
DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
WRITE Y,@IOF
+9 QUIT
LN FOR K=4:1:10
SET $PIECE(M3(DVMN),"^",K)=$PIECE(M3(DVMN),"^",K)+$PIECE(^PS(59.12,PDATE,3,DIV,0),"^",K)
SET $PIECE(S3(DIV),"^",K)=$PIECE(S3(DIV),"^",K)+$PIECE(^PS(59.12,PDATE,3,DIV,0),"^",K)
if $DATA(T3)
SET $PIECE(T3,"^",K)=$PIECE(T3,"^",K)+$PIECE(^PS(59.12,PDATE,3,DIV,0),"^",K)
+1 SET AVGST=$PIECE(^PS(59.12,PDATE,3,DIV,0),"^",2)*$PIECE(^PS(59.12,PDATE,2,DIV,0),"^",4)
SET $PIECE(M3(DVMN),"^",2)=$PIECE(M3(DVMN),"^",2)+AVGST
SET $PIECE(S3(DIV),"^",2)=$PIECE(S3(DIV),"^",2)+AVGST
if $DATA(T3)
SET $PIECE(T3,"^",2)=$PIECE(T3,"^",2)+AVGST
KILL AVGST
+2 SET AVGFEE=$PIECE(^PS(59.12,PDATE,3,DIV,0),"^",3)*$PIECE(^PS(59.12,PDATE,2,DIV,0),"^",3)
SET $PIECE(M3(DVMN),"^",3)=$PIECE(M3(DVMN),"^",3)+AVGFEE
SET $PIECE(S3(DIV),"^",3)=$PIECE(S3(DIV),"^",3)+AVGFEE
if $DATA(T3)
SET $PIECE(T3,"^",3)=$PIECE(T3,"^",3)+AVGFEE
KILL AVGFEE
+3 FOR K=10,11,12
SET $PIECE(M1(DVMN),"^",K)=$PIECE(M1(DVMN),"^",K)+$PIECE(^PS(59.12,PDATE,1,DIV,0),"^",K)
SET $PIECE(S1(DIV),"^",K)=$PIECE(S1(DIV),"^",K)+$PIECE(^PS(59.12,PDATE,1,DIV,0),"^",K)
SET $PIECE(T1,"^",K)=$PIECE(T1,"^",K)+$PIECE(^PS(59.12,PDATE,1,DIV,0),"^",K)
+4 FOR K=3,4,13
SET $PIECE(M2(DVMN),"^",K)=$PIECE(M2(DVMN),"^",K)+$PIECE(^PS(59.12,PDATE,2,DIV,0),"^",K)
SET $PIECE(S2(DIV),"^",K)=$PIECE(S2(DIV),"^",K)+$PIECE(^PS(59.12,PDATE,2,DIV,0),"^",K)
SET $PIECE(T2,"^",K)=$PIECE(T2,"^",K)+$PIECE(^PS(59.12,PDATE,2,DIV,0),"^",K)
+5 IF QTR
IF $EXTRACT(PDATE,1,3)=$EXTRACT(SDT,1,3)
IF $EXTRACT(PDATE,4,5)'<Q1&($EXTRACT(PDATE,4,5)'>Q2)
SET QMREQ=+$GET(QMREQ)+$PIECE(^PS(59.12,PDATE,1,DIV,0),"^",14)
SET QCST=+$GET(QCST)+$PIECE(^PS(59.12,PDATE,3,DIV,0),"^",7)
Begin DoDot:1
+6 SET QTMREQ=+$GET(QTMREQ)+$PIECE(^PS(59.12,PDATE,1,DIV,0),"^",14)
SET QTCST=+$GET(QTCST)+$PIECE(^PS(59.12,PDATE,3,DIV,0),"^",7)
End DoDot:1
+7 QUIT
MON ;PRINT MONTHLY TOTALS
+1 WRITE !,$EXTRACT($PIECE(PRV,"^",2),4,5)_"/"_$EXTRACT($PIECE(PRV,"^",2),2,3),?13,$JUSTIFY($FNUMBER($SELECT($PIECE(M2(PRV),"^",4)=0!($PIECE(M3(PRV),"^",2)=0):0,1:$PIECE(M3(PRV),"^",2)/$PIECE(M2(PRV),"^",4)),"",2),13)
+2 WRITE $JUSTIFY($FNUMBER($SELECT($PIECE(M2(PRV),"^",3)=0!($PIECE(M3(PRV),"^",3)=0):0,1:$PIECE(M3(PRV),"^",3)/$PIECE(M2(PRV),"^",3)),"",2),13),$JUSTIFY(...
... $FNUMBER($SELECT($PIECE(M3(PRV),"^",7)=0!($PIECE(M1(PRV),"^",12)=0):0,1:($PIECE(M3(PRV),"^",7)/$PIECE(M1(PRV),"^",12))),"",2),13)
+3 WRITE $JUSTIFY($FNUMBER($SELECT($PIECE(M3(PRV),"^",7)=0!($PIECE(M1(PRV),"^",10)=0):0,1:$PIECE(M3(PRV),"^",7)/$PIECE(M1(PRV),"^",10)),"",2),13),$JUSTIFY(...
... $FNUMBER($SELECT($PIECE(M3(PRV),"^",8)=0!($PIECE(M1(PRV),"^",11)=0):0,1:$PIECE(M3(PRV),"^",8)/$PIECE(M1(PRV),"^",11)),"",2),13)
+4 WRITE $JUSTIFY($FNUMBER($PIECE(M3(PRV),"^",7),"",2),13),$JUSTIFY($FNUMBER($PIECE(M3(PRV),"^",8),"",2),13),$JUSTIFY($FNUMBER(...
... $PIECE(M3(PRV),"^",9),"",2),13),$JUSTIFY($FNUMBER($SELECT($PIECE(M3(PRV),"^",9)=0!($PIECE(M2(PRV),"^",13)=0):0,1:$PIECE(M3(PRV),"^",9)/$PIECE(M2(PRV),"^",13)),"",2),13)
+5 QUIT
