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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCOST 4505 printed Nov 22, 2024@17:35:37 Page 2
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
