PSOMGMN2 ;BHAM ISC/JMB - MONTHLY MANAGEMENT TYPE OF PRESCRIPTIONS REPORT ; 1/30/93
;;7.0;OUTPATIENT PHARMACY;**14**;DEC 1997
EN S (CNT,PG)=0 D:ANS="A" PRI I ANS="S" S S1(DIV)=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",!?52,"TYPE OF PRESCRIPTIONS FILLED",?124,"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:11 W $J($P("^^^FEE^^^TOT^^^WD^PARTIC","^",K),10)
W $J("% OF FEE",12),!,"DATE",?10 F K=1:1:10 W $J($P("FEE^STAFF^& STAFF^NEW^REFILL^FILLS^WD^MAIL^& MAIL^PHARM","^",K),10)
W $J("FL BY VA",12),$J("INVEST",10),! F K=1:1:132 W "-"
Q
PRI S T2="0^0^0^0^0^0^0^0^0^0^0^0^0^0.0",(PG,T1)=0 F DIV=0:0 S DIV=$O(^PS(59,DIV)) Q:'DIV S S1(DIV)=0 D DV
D TOT Q
DV S (BEG,PRT)=0 D RPT S S2(DIV)="0^0^0^0^0^0^0^0^0^0^0^0^0^0.0" F PDATE=SDT-1:0 S PDATE=$O(^PS(59.12,PDATE)) D:$Y+6>IOSL RPT D:'PDATE!(PDATE>EDT) SUB Q:'PDATE!(PDATE>EDT) D
.S DVMN=DIV_"^"_$E(PDATE,1,5) S:'BEG PRV=DIV_"^"_$E(PDATE,1,5),M1(DVMN)="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",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",M2(DVMN)="0^0^0^0^0^0^0^0^0^0^0^0^0^0"
.Q:'$G(^PS(59.12,PDATE,2,DIV,0))
.D:$G(^PS(59.12,PDATE,2,DIV,0))'=DIV_"^0^0^0^0^0^0^0^0^0^0^0^0^0^0" LN
I ANS="S" W !!!?17,"FINISHED PRINTING ON: " D NOW^%DTC S Y=% X ^DD("DD") W Y,@IOF
Q
LN F K=3,4,5,6,7,8,9,10,11,13,14 S $P(M2(DVMN),"^",K)=$P(M2(DVMN),"^",K)+$P(^PS(59.12,PDATE,2,DIV,0),"^",K) D
.S $P(S2(DIV),"^",K)=$P(S2(DIV),"^",K)+$P(^PS(59.12,PDATE,2,DIV,0),"^",K) S:$D(T2) $P(T2,"^",K)=$P(T2,"^",K)+$P(^PS(59.12,PDATE,2,DIV,0),"^",K)
S $P(S1(DIV),"^",17)=$P(S1(DIV),"^",17)+$P(^PS(59.12,PDATE,1,DIV,0),"^",17),$P(M1(DVMN),"^",17)=$P(M1(DVMN),"^",17)+$P(^PS(59.12,PDATE,1,DIV,0),"^",17)
Q
MON ;PRINT MONTHLY TOTALS
W !,$E($P(PRV,"^",2),4,5)_"/"_$E($P(PRV,"^",2),2,3),?10 F K=3,4,5,6,7,8,9,10,11,13 W $J($P(M2(PRV),"^",K),10)
W $J($FN($S($P(M2(PRV),"^",3)=0&($P(M2(PRV),"^",13))=0:0,$P(M2(PRV),"^",3)=0:100,$P(M2(PRV),"^",13)=0:0,1:($P(M2(PRV),"^",3)/($P(M2(PRV),"^",3)+$P(M2(PRV),"^",13)))*100),"",1),12)
W $J($P(M1(PRV),"^",17),10)
Q
SUB ;PRINT SUB TOTALS
I 'PRT D MON W !?10 F K=1:1:10 W $J("=======",10)
W:'PRT $J("=======",12),$J("=======",10) W !,$S('PRT:"DIV TOTAL",1:$E($P(^PS(59,DIV,0),"^"),1,8)),?10 F K=3,4,5,6,7,8,9,10,11,13 W $J($P(S2(DIV),"^",K),10)
W $J($FN($S($P(S2(DIV),"^",3)=0&($P(S2(DIV),"^",13))=0:0,$P(S2(DIV),"^",3)=0:100,$P(S2(DIV),"^",13)=0:0,1:($P(S2(DIV),"^",3)/($P(S2(DIV),"^",3)+$P(S2(DIV),"^",13)))*100),"",1),12)
W $J($P(S1(DIV),"^",17),10)
;W:RUN=2&(ANS="S") @IOF
Q
TOT ;PRINT GRAND TOTALS
S PRT=1 D RPT F DIV=0:0 S DIV=$O(^PS(59,DIV)) Q:'DIV D SUB
W !!?10 F K=1:1:10 W $J("=======",10)
W $J("=======",12),$J("=======",10),!,"GR TOTAL",?10 F K=3,4,5,6,7,8,9,10,11,13 W $J($P(T2,"^",K),10)
W $J($FN($S($P(T2,"^",3)=0&($P(T2,"^",13)=0):0,$P(T2,"^",3)=0:100,$P(T2,"^",13)=0:0,1:($P(T2,"^",3)/($P(T2,"^",3)+$P(T2,"^",13)))*100),"",1),12)
W:ANS="A" $J($P(T1,"^",17),10) W:ANS="S" $J($P(S1(DIV),"^",17),10)
W !!!?17,"FINISHED PRINTING ON: " D NOW^%DTC S Y=% X ^DD("DD") W Y W:RUN'="A" @IOF
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOMGMN2 3331 printed Dec 13, 2024@02:31:05 Page 2
PSOMGMN2 ;BHAM ISC/JMB - MONTHLY MANAGEMENT TYPE OF PRESCRIPTIONS REPORT ; 1/30/93
+1 ;;7.0;OUTPATIENT PHARMACY;**14**;DEC 1997
EN SET (CNT,PG)=0
if ANS="A"
DO PRI
IF ANS="S"
SET S1(DIV)=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",!?52,"TYPE OF PRESCRIPTIONS FILLED",?124,"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:11
WRITE $JUSTIFY($PIECE("^^^FEE^^^TOT^^^WD^PARTIC","^",K),10)
+4 WRITE $JUSTIFY("% OF FEE",12),!,"DATE",?10
FOR K=1:1:10
WRITE $JUSTIFY($PIECE("FEE^STAFF^& STAFF^NEW^REFILL^FILLS^WD^MAIL^& MAIL^PHARM","^",K),10)
+5 WRITE $JUSTIFY("FL BY VA",12),$JUSTIFY("INVEST",10),!
FOR K=1:1:132
WRITE "-"
+6 QUIT
PRI SET T2="0^0^0^0^0^0^0^0^0^0^0^0^0^0.0"
SET (PG,T1)=0
FOR DIV=0:0
SET DIV=$ORDER(^PS(59,DIV))
if 'DIV
QUIT
SET S1(DIV)=0
DO DV
+1 DO TOT
QUIT
DV SET (BEG,PRT)=0
DO RPT
SET S2(DIV)="0^0^0^0^0^0^0^0^0^0^0^0^0^0.0"
FOR PDATE=SDT-1:0
SET PDATE=$ORDER(^PS(59.12,PDATE))
if $Y+6>IOSL
DO RPT
if 'PDATE!(PDATE>EDT)
DO SUB
if 'PDATE!(PDATE>EDT)
QUIT
Begin DoDot:1
+1 SET DVMN=DIV_"^"_$EXTRACT(PDATE,1,5)
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"
SET M2(DVMN)="0^0^0^0^0^0^0^0^0^0^0^0^0^0"
SET BEG=1
+2 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"
SET M2(DVMN)="0^0^0^0^0^0^0^0^0^0^0^0^0^0"
+3 if '$GET(^PS(59.12,PDATE,2,DIV,0))
QUIT
+4 if $GET(^PS(59.12,PDATE,2,DIV,0))'=DIV_"^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
DO LN
End DoDot:1
+5 IF ANS="S"
WRITE !!!?17,"FINISHED PRINTING ON: "
DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
WRITE Y,@IOF
+6 QUIT
LN FOR K=3,4,5,6,7,8,9,10,11,13,14
SET $PIECE(M2(DVMN),"^",K)=$PIECE(M2(DVMN),"^",K)+$PIECE(^PS(59.12,PDATE,2,DIV,0),"^",K)
Begin DoDot:1
+1 SET $PIECE(S2(DIV),"^",K)=$PIECE(S2(DIV),"^",K)+$PIECE(^PS(59.12,PDATE,2,DIV,0),"^",K)
if $DATA(T2)
SET $PIECE(T2,"^",K)=$PIECE(T2,"^",K)+$PIECE(^PS(59.12,PDATE,2,DIV,0),"^",K)
End DoDot:1
+2 SET $PIECE(S1(DIV),"^",17)=$PIECE(S1(DIV),"^",17)+$PIECE(^PS(59.12,PDATE,1,DIV,0),"^",17)
SET $PIECE(M1(DVMN),"^",17)=$PIECE(M1(DVMN),"^",17)+$PIECE(^PS(59.12,PDATE,1,DIV,0),"^",17)
+3 QUIT
MON ;PRINT MONTHLY TOTALS
+1 WRITE !,$EXTRACT($PIECE(PRV,"^",2),4,5)_"/"_$EXTRACT($PIECE(PRV,"^",2),2,3),?10
FOR K=3,4,5,6,7,8,9,10,11,13
WRITE $JUSTIFY($PIECE(M2(PRV),"^",K),10)
+2 WRITE $JUSTIFY($FNUMBER($SELECT($PIECE(M2(PRV),"^",3)=0&($PIECE(M2(PRV),"^",13))=0:0,$PIECE(M2(PRV),"^",3)=0:100,$PIECE(M2(PRV),"^",13)=0:0,1:($PIECE(M2(PRV),"^",3)/($PIECE(M2(PRV),"^",3)+$PIECE(M2(PRV),"^",13)))*100),"",1),12)
+3 WRITE $JUSTIFY($PIECE(M1(PRV),"^",17),10)
+4 QUIT
SUB ;PRINT SUB TOTALS
+1 IF 'PRT
DO MON
WRITE !?10
FOR K=1:1:10
WRITE $JUSTIFY("=======",10)
+2 if 'PRT
WRITE $JUSTIFY("=======",12),$JUSTIFY("=======",10)
WRITE !,$SELECT('PRT:"DIV TOTAL",1:$EXTRACT($PIECE(^PS(59,DIV,0),"^"),1,8)),?10
FOR K=3,4,5,6,7,8,9,10,11,13
WRITE $JUSTIFY($PIECE(S2(DIV),"^",K),10)
+3 WRITE $JUSTIFY($FNUMBER($SELECT($PIECE(S2(DIV),"^",3)=0&($PIECE(S2(DIV),"^",13))=0:0,$PIECE(S2(DIV),"^",3)=0:100,$PIECE(S2(DIV),"^",13)=0:0,1:($PIECE(S2(DIV),"^",3)/($PIECE(S2(DIV),"^",3)+$PIECE(S2(DIV),"^",13)))*100),"",1),12)
+4 WRITE $JUSTIFY($PIECE(S1(DIV),"^",17),10)
+5 ;W:RUN=2&(ANS="S") @IOF
+6 QUIT
TOT ;PRINT GRAND TOTALS
+1 SET PRT=1
DO RPT
FOR DIV=0:0
SET DIV=$ORDER(^PS(59,DIV))
if 'DIV
QUIT
DO SUB
+2 WRITE !!?10
FOR K=1:1:10
WRITE $JUSTIFY("=======",10)
+3 WRITE $JUSTIFY("=======",12),$JUSTIFY("=======",10),!,"GR TOTAL",?10
FOR K=3,4,5,6,7,8,9,10,11,13
WRITE $JUSTIFY($PIECE(T2,"^",K),10)
+4 WRITE $JUSTIFY($FNUMBER($SELECT($PIECE(T2,"^",3)=0&($PIECE(T2,"^",13)=0):0,$PIECE(T2,"^",3)=0:100,$PIECE(T2,"^",13)=0:0,1:($PIECE(T2,"^",3)/($PIECE(T2,"^",3)+$PIECE(T2,"^",13)))*100),"",1),12)
+5 if ANS="A"
WRITE $JUSTIFY($PIECE(T1,"^",17),10)
if ANS="S"
WRITE $JUSTIFY($PIECE(S1(DIV),"^",17),10)
+6 WRITE !!!?17,"FINISHED PRINTING ON: "
DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
WRITE Y
if RUN'="A"
WRITE @IOF
+7 QUIT
