- PSOCOST ;BHAM ISC/SAB - ROUTINE TO GENERATE MONTHLY DRUG COST REPORT ; 08/19/92 8:19
- ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
- K ^TMP($J) S (ALL,TF,TQ,TC,PG)=0
- MN S %DT("A")="Enter Month/Year: ",%DT="AQEP" D ^%DT G:"^"[X END G:Y'>0 MN S (MONTH,MON)=$E(Y,1,5)_"00",MN=MON+32
- MN1 R !,"Select a Drug or ^ALL for all drugs: ",X:DTIME G:"^"[X END I "^AL"'[$E(X,1,3) G DRG
- MN2 S DIR("A")="Select Minimum Total number of Refills: ",DIR("B")=0,DIR(0)="N^0:50:0",DIR("?")="ENTER A NUMBER FOR MINIMUM REFILLS or PRESS RETURN FOR A MINIMUM OF ZERO (0)."
- D ^DIR G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) END S RF=Y
- MN3 S DIR("A")="Select Minimum Total Cost: ",DIR("B")=0,DIR(0)="N^0:9999:2",DIR("?")="ENTER MINIMUM COST OF DRUG or PRESS RETURN FOR A MINIMUM COST OF ZERO (0)."
- D ^DIR G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) END S MC=Y
- S ALL=1 D DEV I $G(PSQ)!$D(ZTSK) K ZTSK G END
- G LK
- DRG ;DRUG CHOICE
- S DIC(0)="QME",DIC="^PSDRUG(" D ^DIC G:"^"[X END G:Y<0 MN1 S DRG=+Y,DRUG=$P(^PSDRUG(DRG,0),"^") D DEV I $G(PSQ)!$D(ZTSK) K ZTSK G END
- G:'$D(^PSCST(MON)) DAY
- DRG1 F DIV=0:0 S DIV=$O(^PSCST(MON,"V",DIV)) Q:'DIV I $D(^PSCST(MON,"V",DIV,"D",DRG,0)) D NF,STO
- Q:$G(DAY) D HDR,PRI,GR
- END W ! W:$E(IOST)'["C" @IOF D ^%ZISC K PSQ,DAY,^TMP($J),DIR,DUOUT,DTOUT,DIRUT,DIROUT,DIV,SUB,DIV,ZDIV,MONTH,TF,PG,TQ,TC,MC,RF,X,MN,Y,DRG,DIC,%DT,DRUG,MON,ALL,G,D,I S:$D(ZTQUEUED) ZTREQ="@"
- Q
- NF S DRUG=$S($D(^PSDRUG(DRG,0)):$P(^PSDRUG(DRG,0),"^"),1:"UNKNOWN")
- S:'$D(^TMP($J,DIV,DRUG)) ^TMP($J,DIV,DRUG)="0^0^0"
- S $P(^TMP($J,DIV,DRUG),"^")=($P(^PSCST(MON,"V",DIV,"D",DRG,0),"^",2)+$P(^(0),"^",3))+$P(^TMP($J,DIV,DRUG),"^")
- S $P(^TMP($J,DIV,DRUG),"^",2)=$P(^PSCST(MON,"V",DIV,"D",DRG,0),"^",4)+$P(^TMP($J,DIV,DRUG),"^",2)
- S $P(^TMP($J,DIV,DRUG),"^",3)=$P(^PSCST(MON,"V",DIV,"D",DRG,0),"^",5)+$P(^TMP($J,DIV,DRUG),"^",3)_"^"_$S($P(^PSDRUG(DRG,0),"^",9):"*** N/F ***",1:"")
- Q
- HDR ;REPORT HEADER
- S Y=MONTH X ^DD("DD")
- S PG=PG+1 U IO W @IOF,!?50,"MONTHLY DRUG COST REPORT FOR "_Y,?115,"PAGE: "_PG,!?50,$S(ALL:"MINIMUM REFILLS OF "_RF_" AT A MINIMUM COST OF $"_MC,1:"FOR "_DRUG)
- W !!,"DIVISION",?53,"TOTAL",?82,"TOTAL",?97,"TOTAL",!?5,"DRUG",?53,"FILLED",?81,"QUANITY",?98,"COST",?125,"N/F",! F I=1:1:132 W "-"
- Q
- PRI ;OUTPUT DATA
- I '$D(^TMP($J)) U IO W !!?50,">>>>> NO DRUG COST INFORMATION FOUND <<<<<" Q
- S ZDIV=99 F I=0:0 S DIV=$O(^TMP($J,DIV)) Q:'DIV S DV=$P(^PS(59,DIV,0),"^") D DG
- Q
- DG S DRG="" F T=0:0 S DRG=$O(^TMP($J,DIV,DRG)) Q:DRG="" D:$Y+4>IOSL HDR W:DIV'=ZDIV !,DV W !?5,DRG,?50,$J($P(^TMP($J,DIV,DRG),"^"),7),?80,$J($P(^(DRG),"^",3),7),?95,$J($P(^(DRG),"^",2),7),?120,$P(^(DRG),"^",4) S ZDIV=DIV D:'ALL GT
- D:ALL SUB
- Q
- DEV K %ZIS,IOP,ZTSK,POP S PSOION=ION,%ZIS="QM" D ^%ZIS K %ZIS I POP S PSQ=1,IOP=PSOION D ^%ZIS K IOP,PSOION Q
- I $G(IOM)<132 W $C(7),!!,"PRINTOUT MUST BE 132 COLUMNS !!",!! G DEV
- K PSOION I $D(IO("Q")) S ZTDESC="Option to print Outpatient Pharmacy's monthly drug cost report",ZTRTN=$S('ALL:"DRG1^PSOCOST",1:"LK^PSOCOST") F G="ALL","MON","MN","DRG","DRUG","RF","MC","TF","TQ","TC","PG","MONTH" S:$D(@G) ZTSAVE(G)=""
- I K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !,"REPORT IS QUEUED TO PRINT !",! Q
- Q
- LK ;PRINT ALL DRUGS
- G:'$D(^PSCST(MON)) DAY
- LK1 F DIV=0:0 S DIV=$O(^PSCST(MON,"V",DIV)) Q:'DIV F DRG=0:0 S DRG=$O(^PSCST(MON,"V",DIV,"D",DRG)) Q:'DRG I $P(^PSCST(MON,"V",DIV,"D",DRG,0),"^",3)'<RF,$P(^(0),"^",4)'<MC D NF,STO
- Q:$G(DAY) D HDR,PRI F I=0:0 S I=$O(SUB(I)) Q:'I S TF=$P(SUB(I),"^")+TF,TQ=$P(SUB(I),"^",3)+TQ,TC=$P(SUB(I),"^",2)+TC
- D GR G END
- Q
- SUB ;DIVISIONAL SUB-TOTALS
- Q:'$D(^TMP($J))
- D:$Y+4>IOSL HDR W !?47,"----------",?77,"----------",?92,"----------",!?20,"SUB-TOTALS",?50,$J($P(SUB(ZDIV),"^"),7),?80,$J($P(SUB(ZDIV),"^",3),7),?95,$J($P(SUB(ZDIV),"^",2),7),!
- Q
- GR Q:'$D(^TMP($J)) D:$Y+4>IOSL HDR W !?47,"==========",?77,"==========",?92,"==========",!?20,"GRAND TOTALS",?50,$J(TF,7),?80,$J(TQ,7),?95,$J(TC,7)
- Q
- STO S:'$D(SUB(DIV)) SUB(DIV)="0^0^0"
- S $P(SUB(DIV),"^")=$P(^PSCST(MON,"V",DIV,"D",DRG,0),"^",2)+$P(^(0),"^",3)+$P(SUB(DIV),"^"),$P(SUB(DIV),"^",2)=$P(^(0),"^",4)+$P(SUB(DIV),"^",2),$P(SUB(DIV),"^",3)=$P(^(0),"^",5)+$P(SUB(DIV),"^",3)
- Q
- GT S TF=$P(SUB(DIV),"^")+TF,TQ=$P(SUB(DIV),"^",3)+TQ,TC=$P(SUB(DIV),"^",2)+TC
- Q
- DAY ;Computes daily totals
- S DAY=1 F S MON=$O(^PSCST(MON)) Q:'MON!(MON>MN) D @$S(ALL:"LK1",1:"DRG1")
- D:'ALL HDR,PRI,GR
- D:ALL
- .D HDR,PRI F I=0:0 S I=$O(SUB(I)) Q:'I S TF=$P(SUB(I),"^")+TF,TQ=$P(SUB(I),"^",3)+TQ,TC=$P(SUB(I),"^",2)+TC
- .D GR
- G END
- Q
- PSOCOST ;BHAM ISC/SAB - ROUTINE TO GENERATE MONTHLY DRUG COST REPORT ; 08/19/92 8:19
- +1 ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
- +2 KILL ^TMP($JOB)
- SET (ALL,TF,TQ,TC,PG)=0
- MN SET %DT("A")="Enter Month/Year: "
- SET %DT="AQEP"
- DO ^%DT
- IF "^"[X
- GOTO END
- IF Y'>0
- GOTO MN
- SET (MONTH,MON)=$EXTRACT(Y,1,5)_"00"
- SET MN=MON+32
- MN1 READ !,"Select a Drug or ^ALL for all drugs: ",X:DTIME
- IF "^"[X
- GOTO END
- IF "^AL"'[$EXTRACT(X,1,3)
- GOTO DRG
- MN2 SET DIR("A")="Select Minimum Total number of Refills: "
- SET DIR("B")=0
- SET DIR(0)="N^0:50:0"
- SET DIR("?")="ENTER A NUMBER FOR MINIMUM REFILLS or PRESS RETURN FOR A MINIMUM OF ZERO (0)."
- +1 DO ^DIR
- IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
- GOTO END
- SET RF=Y
- MN3 SET DIR("A")="Select Minimum Total Cost: "
- SET DIR("B")=0
- SET DIR(0)="N^0:9999:2"
- SET DIR("?")="ENTER MINIMUM COST OF DRUG or PRESS RETURN FOR A MINIMUM COST OF ZERO (0)."
- +1 DO ^DIR
- IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
- GOTO END
- SET MC=Y
- +2 SET ALL=1
- DO DEV
- IF $GET(PSQ)!$DATA(ZTSK)
- KILL ZTSK
- GOTO END
- +3 GOTO LK
- DRG ;DRUG CHOICE
- +1 SET DIC(0)="QME"
- SET DIC="^PSDRUG("
- DO ^DIC
- IF "^"[X
- GOTO END
- IF Y<0
- GOTO MN1
- SET DRG=+Y
- SET DRUG=$PIECE(^PSDRUG(DRG,0),"^")
- DO DEV
- IF $GET(PSQ)!$DATA(ZTSK)
- KILL ZTSK
- GOTO END
- +2 IF '$DATA(^PSCST(MON))
- GOTO DAY
- DRG1 FOR DIV=0:0
- SET DIV=$ORDER(^PSCST(MON,"V",DIV))
- IF 'DIV
- QUIT
- IF $DATA(^PSCST(MON,"V",DIV,"D",DRG,0))
- DO NF
- DO STO
- +1 IF $GET(DAY)
- QUIT
- DO HDR
- DO PRI
- DO GR
- END WRITE !
- IF $EXTRACT(IOST)'["C"
- WRITE @IOF
- DO ^%ZISC
- KILL PSQ,DAY,^TMP($JOB),DIR,DUOUT,DTOUT,DIRUT,DIROUT,DIV,SUB,DIV,ZDIV,MONTH,TF,PG,TQ,TC,MC,RF,X,MN,Y,DRG,DIC,%DT,DRUG,MON,ALL,G,D,I
- IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +1 QUIT
- NF SET DRUG=$SELECT($DATA(^PSDRUG(DRG,0)):$PIECE(^PSDRUG(DRG,0),"^"),1:"UNKNOWN")
- +1 IF '$DATA(^TMP($JOB,DIV,DRUG))
- SET ^TMP($JOB,DIV,DRUG)="0^0^0"
- +2 SET $PIECE(^TMP($JOB,DIV,DRUG),"^")=($PIECE(^PSCST(MON,"V",DIV,"D",DRG,0),"^",2)+$PIECE(^(0),"^",3))+$PIECE(^TMP($JOB,DIV,DRUG),"^")
- +3 SET $PIECE(^TMP($JOB,DIV,DRUG),"^",2)=$PIECE(^PSCST(MON,"V",DIV,"D",DRG,0),"^",4)+$PIECE(^TMP($JOB,DIV,DRUG),"^",2)
- +4 SET $PIECE(^TMP($JOB,DIV,DRUG),"^",3)=$PIECE(^PSCST(MON,"V",DIV,"D",DRG,0),"^",5)+$PIECE(^TMP($JOB,DIV,DRUG),"^",3)_"^"_$SELECT($PIECE(^PSDRUG(DRG,0),"^",9):"*** N/F ***",1:"")
- +5 QUIT
- HDR ;REPORT HEADER
- +1 SET Y=MONTH
- XECUTE ^DD("DD")
- +2 SET PG=PG+1
- USE IO
- WRITE @IOF,!?50,"MONTHLY DRUG COST REPORT FOR "_Y,?115,"PAGE: "_PG,!?50,$SELECT(ALL:"MINIMUM REFILLS OF "_RF_" AT A MINIMUM COST OF $"_MC,1:"FOR "_DRUG)
- +3 WRITE !!,"DIVISION",?53,"TOTAL",?82,"TOTAL",?97,"TOTAL",!?5,"DRUG",?53,"FILLED",?81,"QUANITY",?98,"COST",?125,"N/F",!
- FOR I=1:1:132
- WRITE "-"
- +4 QUIT
- PRI ;OUTPUT DATA
- +1 IF '$DATA(^TMP($JOB))
- USE IO
- WRITE !!?50,">>>>> NO DRUG COST INFORMATION FOUND <<<<<"
- QUIT
- +2 SET ZDIV=99
- FOR I=0:0
- SET DIV=$ORDER(^TMP($JOB,DIV))
- IF 'DIV
- QUIT
- SET DV=$PIECE(^PS(59,DIV,0),"^")
- DO DG
- +3 QUIT
- DG SET DRG=""
- FOR T=0:0
- SET DRG=$ORDER(^TMP($JOB,DIV,DRG))
- IF DRG=""
- QUIT
- IF $Y+4>IOSL
- DO HDR
- IF DIV'=ZDIV
- WRITE !,DV
- WRITE !?5,DRG,?50,$JUSTIFY($PIECE(^TMP($JOB,DIV,DRG),"^"),7),?80,$JUSTIFY($PIECE(^(DRG),"^",3),7),?95,$JUSTIFY($PIECE(^(DRG),"^",2),7),?120,$PIECE(^(DRG),"^",4)
- SET ZDIV=DIV
- IF 'ALL
- DO GT
- +1 IF ALL
- DO SUB
- +2 QUIT
- DEV KILL %ZIS,IOP,ZTSK,POP
- SET PSOION=ION
- SET %ZIS="QM"
- DO ^%ZIS
- KILL %ZIS
- IF POP
- SET PSQ=1
- SET IOP=PSOION
- DO ^%ZIS
- KILL IOP,PSOION
- QUIT
- +1 IF $GET(IOM)<132
- WRITE $CHAR(7),!!,"PRINTOUT MUST BE 132 COLUMNS !!",!!
- GOTO DEV
- +2 KILL PSOION
- IF $DATA(IO("Q"))
- SET ZTDESC="Option to print Outpatient Pharmacy's monthly drug cost report"
- SET ZTRTN=$SELECT('ALL:"DRG1^PSOCOST",1:"LK^PSOCOST")
- FOR G="ALL","MON","MN","DRG","DRUG","RF","MC","TF","TQ","TC","PG","MONTH"
- IF $DATA(@G)
- SET ZTSAVE(G)=""
- +3 IF $TEST
- KILL IO("Q")
- DO ^%ZTLOAD
- IF $DATA(ZTSK)
- WRITE !,"REPORT IS QUEUED TO PRINT !",!
- QUIT
- +4 QUIT
- LK ;PRINT ALL DRUGS
- +1 IF '$DATA(^PSCST(MON))
- GOTO DAY
- LK1 FOR DIV=0:0
- SET DIV=$ORDER(^PSCST(MON,"V",DIV))
- IF 'DIV
- QUIT
- FOR DRG=0:0
- SET DRG=$ORDER(^PSCST(MON,"V",DIV,"D",DRG))
- IF 'DRG
- QUIT
- IF $PIECE(^PSCST(MON,"V",DIV,"D",DRG,0),"^",3)'<RF
- IF $PIECE(^(0),"^",4)'<MC
- DO NF
- DO STO
- +1 IF $GET(DAY)
- QUIT
- DO HDR
- DO PRI
- FOR I=0:0
- SET I=$ORDER(SUB(I))
- IF 'I
- QUIT
- SET TF=$PIECE(SUB(I),"^")+TF
- SET TQ=$PIECE(SUB(I),"^",3)+TQ
- SET TC=$PIECE(SUB(I),"^",2)+TC
- +2 DO GR
- GOTO END
- +3 QUIT
- SUB ;DIVISIONAL SUB-TOTALS
- +1 IF '$DATA(^TMP($JOB))
- QUIT
- +2 IF $Y+4>IOSL
- DO HDR
- WRITE !?47,"----------",?77,"----------",?92,"----------",!?20,"SUB-TOTALS",?50,$JUSTIFY($PIECE(SUB(ZDIV),"^"),7),?80,$JUSTIFY($PIECE(SUB(ZDIV),"^",3),7),?95,$JUSTIFY($PIECE(SUB(ZDIV),"^",2),7),!
- +3 QUIT
- GR IF '$DATA(^TMP($JOB))
- QUIT
- IF $Y+4>IOSL
- DO HDR
- WRITE !?47,"==========",?77,"==========",?92,"==========",!?20,"GRAND TOTALS",?50,$JUSTIFY(TF,7),?80,$JUSTIFY(TQ,7),?95,$JUSTIFY(TC,7)
- +1 QUIT
- STO IF '$DATA(SUB(DIV))
- SET SUB(DIV)="0^0^0"
- +1 SET $PIECE(SUB(DIV),"^")=$PIECE(^PSCST(MON,"V",DIV,"D",DRG,0),"^",2)+$PIECE(^(0),"^",3)+$PIECE(SUB(DIV),"^")
- SET $PIECE(SUB(DIV),"^",2)=$PIECE(^(0),"^",4)+$PIECE(SUB(DIV),"^",2)
- SET $PIECE(SUB(DIV),"^",3)=$PIECE(^(0),"^",5)+$PIECE(SUB(DIV),"^",3)
- +2 QUIT
- GT SET TF=$PIECE(SUB(DIV),"^")+TF
- SET TQ=$PIECE(SUB(DIV),"^",3)+TQ
- SET TC=$PIECE(SUB(DIV),"^",2)+TC
- +1 QUIT
- DAY ;Computes daily totals
- +1 SET DAY=1
- FOR
- SET MON=$ORDER(^PSCST(MON))
- IF 'MON!(MON>MN)
- QUIT
- DO @$SELECT(ALL:"LK1",1:"DRG1")
- +2 IF 'ALL
- DO HDR
- DO PRI
- DO GR
- +3 IF ALL
- Begin DoDot:1
- +4 DO HDR
- DO PRI
- FOR I=0:0
- SET I=$ORDER(SUB(I))
- IF 'I
- QUIT
- SET TF=$PIECE(SUB(I),"^")+TF
- SET TQ=$PIECE(SUB(I),"^",3)+TQ
- SET TC=$PIECE(SUB(I),"^",2)+TC
- +5 DO GR
- End DoDot:1
- +6 GOTO END
- +7 QUIT
