- PSOMGRP1 ;BHAM ISC/JMB - DAILY MANAGEMENT PRESCRIPTION COUNTS REPORT ; 4/1/93
- ;;7.0;OUTPATIENT PHARMACY;**14,444**;DEC 1997;Build 34
- EN S (CNT,PG)=0 D:ANS="A" PRI D:ANS="S" DV W:ANS="S" @IOF Q
- ENQ S CNT=0 S PSOELSE=ANS I ANS="A" D PRI,PRI^PSOMGRP2,PRI^PSOMGRP3
- I PSOELSE'="A" S PG=0 D DV S (CNT,PG)=0 D EN^PSOMGRP2 S (CNT,PG)=0 D EN^PSOMGRP3
- K PSOELSE D ^PSOMGRP4 Q
- RPT W:CNT @IOF S PG=PG+1,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",!?56,"PRESCRIPTION COUNTS",?112,"PAGE ",PG
- W !!?40,"FROM "_$E(SDT,4,5)_"-"_$E(SDT,6,7)_"-"_$E(SDT,2,3),?60,"TO "_$E(EDT,4,5)_"-"_$E(EDT,6,7)_"-"_$E(EDT,2,3)_" "_$S('PRT:"DIVISION: "_$P(^PS(59,DIV,0),"^"),1:"ALL DIVISIONS")
- W !!?9 F K=1:1:15 W $J($P("^^^TOT^30^60^90^>90^EQ^^TOT^TOT^MED^RX/^EQ FL/","^",K),8)
- W !,"DATE",?9 F K=1:1:15 W $J($P("CAT A^CAT C^OTH^CAT^DAY^DAY^DAY^DAY^FLS^METH^RX^EQ FL^REQ^REQ^REQ","^",K),8)
- W ! F K=1:1:129 W "="
- Q
- PRI S T1="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0",CNT=0,PG=0 F DIV=0:0 S DIV=$O(^PS(59,DIV)) Q:'DIV D DV
- D TOT
- Q
- DV S (BEG,PRT)=0 D RPT S S1(DIV)="0^0^0^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^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^0^0^0^0"
- .W !,$E(PDATE,4,5)_"-"_$E(PDATE,6,8)_"-"_$E(PDATE,2,3),?9
- .D:$G(^PS(59.12,PDATE,1,DIV,0))'=DIV_"^0^0^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 W:RUN="A"&(ANS="S") @IOF
- Q
- LN F K=2:1:16 W $J(+$P($G(^PS(59.12,PDATE,1,DIV,0)),"^",K),8) D
- .S $P(M1(DVMN),"^",K)=$P(M1(DVMN),"^",K)+$P($G(^PS(59.12,PDATE,1,DIV,0)),"^",K)
- .S $P(S1(DIV),"^",K)=$P(S1(DIV),"^",K)+$P($G(^PS(59.12,PDATE,1,DIV,0)),"^",K) S:$D(T1) $P(T1,"^",K)=$P(T1,"^",K)+$P($G(^PS(59.12,PDATE,1,DIV,0)),"^",K)
- Q
- MON ;PRINT MONTHLY TOTALS
- W !?9 F K=1:1:15 W $J("-------",8)
- W !,"MON TOTAL",?9 F K=2:1:14 W $J($P(M1(PRV),"^",K),8)
- W $J($S($P(M1(PRV),"^",12)=0!($P(M1(PRV),"^",14)=0):0,1:$P(M1(PRV),"^",12)/$P(M1(PRV),"^",14)),8,2)
- W $J($S($P(M1(PRV),"^",13)=0!($P(M1(PRV),"^",14)=0):0,1:$P(M1(PRV),"^",13)/$P(M1(PRV),"^",14)),8,2)
- Q
- SUB ;PRINT SUB TOTALS
- I 'PRT D MON W !?9 F K=1:1:15 W $J("=======",8)
- W !,$S('PRT:"DIV TOTAL",1:$E($P(^PS(59,DIV,0),"^"),1,8)),?9 F K=2:1:14 W $J($P(S1(DIV),"^",K),8)
- W $J($S($P(S1(DIV),"^",12)=0!($P(S1(DIV),"^",14)=0):0,1:$P(S1(DIV),"^",12)/$P(S1(DIV),"^",14)),8,2)
- W $J($S($P(S1(DIV),"^",13)=0!($P(S1(DIV),"^",14)=0):0,1:$P(S1(DIV),"^",13)/$P(S1(DIV),"^",14)),8,2)
- 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 !?9 F K=1:1:15 W $J("=======",8)
- W !,"GR TOTAL",?9 F K=2:1:14 W $J($P(T1,"^",K),8)
- W $J($S($P(T1,"^",12)=0!($P(T1,"^",14)=0):0,1:$P(T1,"^",12)/$P(T1,"^",14)),8,2)
- W $J($S($P(T1,"^",13)=0!($P(T1,"^",14)=0):0,1:$P(T1,"^",13)/$P(T1,"^",14)),8,2)
- 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[HPSOMGRP1 3157 printed Feb 18, 2025@23:57:36 Page 2
- PSOMGRP1 ;BHAM ISC/JMB - DAILY MANAGEMENT PRESCRIPTION COUNTS REPORT ; 4/1/93
- +1 ;;7.0;OUTPATIENT PHARMACY;**14,444**;DEC 1997;Build 34
- EN SET (CNT,PG)=0
- if ANS="A"
- DO PRI
- if ANS="S"
- DO DV
- if ANS="S"
- WRITE @IOF
- QUIT
- ENQ SET CNT=0
- SET PSOELSE=ANS
- IF ANS="A"
- DO PRI
- DO PRI^PSOMGRP2
- DO PRI^PSOMGRP3
- +1 IF PSOELSE'="A"
- SET PG=0
- DO DV
- SET (CNT,PG)=0
- DO EN^PSOMGRP2
- SET (CNT,PG)=0
- DO EN^PSOMGRP3
- +2 KILL PSOELSE
- DO ^PSOMGRP4
- QUIT
- RPT if CNT
- WRITE @IOF
- SET PG=PG+1
- 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",!?56,"PRESCRIPTION COUNTS",?112,"PAGE ",PG
- +1 WRITE !!?40,"FROM "_$EXTRACT(SDT,4,5)_"-"_$EXTRACT(SDT,6,7)_"-"_$EXTRACT(SDT,2,3),?60,"TO "_$EXTRACT(EDT,4,5)_"-"_$EXTRACT(EDT,6,7)_"-"_$EXTRACT(EDT,2,3)_" "_$SELECT('PRT:"DIVISION: "_$PIECE(^PS(59,DIV,0),"^"),1:"ALL DIVISIONS")
- +2 WRITE !!?9
- FOR K=1:1:15
- WRITE $JUSTIFY($PIECE("^^^TOT^30^60^90^>90^EQ^^TOT^TOT^MED^RX/^EQ FL/","^",K),8)
- +3 WRITE !,"DATE",?9
- FOR K=1:1:15
- WRITE $JUSTIFY($PIECE("CAT A^CAT C^OTH^CAT^DAY^DAY^DAY^DAY^FLS^METH^RX^EQ FL^REQ^REQ^REQ","^",K),8)
- +4 WRITE !
- FOR K=1:1:129
- WRITE "="
- +5 QUIT
- PRI SET T1="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
- SET CNT=0
- SET PG=0
- FOR DIV=0:0
- SET DIV=$ORDER(^PS(59,DIV))
- if 'DIV
- QUIT
- DO DV
- +1 DO TOT
- +2 QUIT
- DV SET (BEG,PRT)=0
- DO RPT
- SET S1(DIV)="0^0^0^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^0^0^0^0"
- SET BEG=1
- 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^0"
- +2 WRITE !,$EXTRACT(PDATE,4,5)_"-"_$EXTRACT(PDATE,6,8)_"-"_$EXTRACT(PDATE,2,3),?9
- +3 if $GET(^PS(59.12,PDATE,1,DIV,0))'=DIV_"^0^0^0^0^0^0^0^^0^0^0^0^0^0^0^0^0"
- DO LN
- End DoDot:1
- +4 IF ANS="S"
- WRITE !!!?17,"FINISHED PRINTING ON: "
- DO NOW^%DTC
- SET Y=%
- XECUTE ^DD("DD")
- WRITE Y
- if RUN="A"&(ANS="S")
- WRITE @IOF
- +5 QUIT
- LN FOR K=2:1:16
- WRITE $JUSTIFY(+$PIECE($GET(^PS(59.12,PDATE,1,DIV,0)),"^",K),8)
- Begin DoDot:1
- +1 SET $PIECE(M1(DVMN),"^",K)=$PIECE(M1(DVMN),"^",K)+$PIECE($GET(^PS(59.12,PDATE,1,DIV,0)),"^",K)
- +2 SET $PIECE(S1(DIV),"^",K)=$PIECE(S1(DIV),"^",K)+$PIECE($GET(^PS(59.12,PDATE,1,DIV,0)),"^",K)
- if $DATA(T1)
- SET $PIECE(T1,"^",K)=$PIECE(T1,"^",K)+$PIECE($GET(^PS(59.12,PDATE,1,DIV,0)),"^",K)
- End DoDot:1
- +3 QUIT
- MON ;PRINT MONTHLY TOTALS
- +1 WRITE !?9
- FOR K=1:1:15
- WRITE $JUSTIFY("-------",8)
- +2 WRITE !,"MON TOTAL",?9
- FOR K=2:1:14
- WRITE $JUSTIFY($PIECE(M1(PRV),"^",K),8)
- +3 WRITE $JUSTIFY($SELECT($PIECE(M1(PRV),"^",12)=0!($PIECE(M1(PRV),"^",14)=0):0,1:$PIECE(M1(PRV),"^",12)/$PIECE(M1(PRV),"^",14)),8,2)
- +4 WRITE $JUSTIFY($SELECT($PIECE(M1(PRV),"^",13)=0!($PIECE(M1(PRV),"^",14)=0):0,1:$PIECE(M1(PRV),"^",13)/$PIECE(M1(PRV),"^",14)),8,2)
- +5 QUIT
- SUB ;PRINT SUB TOTALS
- +1 IF 'PRT
- DO MON
- WRITE !?9
- FOR K=1:1:15
- WRITE $JUSTIFY("=======",8)
- +2 WRITE !,$SELECT('PRT:"DIV TOTAL",1:$EXTRACT($PIECE(^PS(59,DIV,0),"^"),1,8)),?9
- FOR K=2:1:14
- WRITE $JUSTIFY($PIECE(S1(DIV),"^",K),8)
- +3 WRITE $JUSTIFY($SELECT($PIECE(S1(DIV),"^",12)=0!($PIECE(S1(DIV),"^",14)=0):0,1:$PIECE(S1(DIV),"^",12)/$PIECE(S1(DIV),"^",14)),8,2)
- +4 WRITE $JUSTIFY($SELECT($PIECE(S1(DIV),"^",13)=0!($PIECE(S1(DIV),"^",14)=0):0,1:$PIECE(S1(DIV),"^",13)/$PIECE(S1(DIV),"^",14)),8,2)
- +5 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 !?9
- FOR K=1:1:15
- WRITE $JUSTIFY("=======",8)
- +3 WRITE !,"GR TOTAL",?9
- FOR K=2:1:14
- WRITE $JUSTIFY($PIECE(T1,"^",K),8)
- +4 WRITE $JUSTIFY($SELECT($PIECE(T1,"^",12)=0!($PIECE(T1,"^",14)=0):0,1:$PIECE(T1,"^",12)/$PIECE(T1,"^",14)),8,2)
- +5 WRITE $JUSTIFY($SELECT($PIECE(T1,"^",13)=0!($PIECE(T1,"^",14)=0):0,1:$PIECE(T1,"^",13)/$PIECE(T1,"^",14)),8,2)
- +6 WRITE !!!?17,"FINISHED PRINTING ON: "
- DO NOW^%DTC
- SET Y=%
- XECUTE ^DD("DD")
- WRITE Y
- if RUN'="A"
- WRITE @IOF
- +7 QUIT