- PSOMGMN4 ;BHAM ISC/JMB - MONTHLY MANAGEMENT IV REPORT ; 3/1/93
- ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
- EN S DVCNT=0 F DV=0:0 S DV=$O(^PS(59,DV)) Q:'DV S DIV=DV,DVCNT=DVCNT+1
- S (BEG,PG)=0 K ^TMP($J) F IV=0:0 S IV=$O(^PS(50.8,IV)) Q:'IV I $D(^PS(50.8,IV,2)) F DAT=SDT-1:0 S DAT=$O(^PS(50.8,IV,2,DAT)) Q:'DAT!(DAT>EDT) D
- .I $D(^PS(50.8,IV,2,DAT,1)) F WARD=0:0 S WARD=$O(^PS(50.8,IV,2,DAT,1,WARD)) Q:'WARD D GETEM:WARD=.5
- .;******* WARD=.5
- .I $D(^PS(50.8,IV,2,DAT,2)) F DRG=0:0 S DRG=$O(^PS(50.8,IV,2,DAT,2,DRG)) Q:'DRG I $D(^(DRG,0)) S DRGCOST=$P(^(0),"^",5) D WARD
- W S PG=0 I '$D(^TMP($J)) D H W !,"No data." W:$E(IOST)'="C" @IOF G K
- K TOT S (BTOT,IVTOT)=0 F IV=0:0 S IV=$O(^TMP($J,IV)) Q:'IV D IV W ! D DLINE W !,"GRAND TOTAL: " F TYP="P","A","H","C" S PR="" D CTOT
- W ?101,$J(BTOT,8,0),?111,$J(IVTOT,13,2),!!!?17,"FINISHED PRINTING ON: " D NOW^%DTC S Y=% X ^DD("DD") W Y W:RUN="A" @IOF K ZTSK D ^%ZISC
- K K ^TMP($J),BTOT,C,CCOL,CNT,CNTNDE,D,DA,DAT,DISP,DRG,DRGCOST,DS,EDT,I6,IV,IVTOT,JJ,LN,LO,DATE,PG,SDT,TCOL
- ;,^TMP($J),
- K TOT,TOTNDE,TUC,TYP,WARD,WCOST,WD,WDISP,WUNITS,X,Y,ZZ
- Q
- LINE W ! F LN=1:1:124 W "-"
- Q
- MLINE W !?15 F LN=1:1:109 W "-"
- Q
- DLINE W ! F LN=1:1:124 W "="
- Q
- WARD I $D(^PS(50.8,IV,2,DAT,2,DRG,3)) F WD=0:0 S WD=$O(^PS(50.8,IV,2,DAT,2,DRG,3,WD)) Q:'WD I WD=.5,$D(^(WD,1)),'$D(^DIC(42,WD,0)) F TYP="P","A","H","S","C" D TYPE
- Q
- TYPE S DA=$O(^PS(50.8,IV,2,DAT,2,DRG,3,WD,"B",TYP,0)) Q:DA'>0
- S COST=$P(^PS(50.8,IV,2,DAT,2,DRG,3,WD,1,DA,0),"^",2)*DRGCOST
- S:TYP="S" LO=$S($D(^TMP($J,IV,DAT,"P")):^("P"),1:"") S:TYP'="S" LO=$S($D(^TMP($J,IV,DAT,TYP)):^(TYP),1:"") S $P(LO,"^")=$P(LO,"^")+COST
- S:TYP="S" ^TMP($J,IV,DAT,"P")=LO F TT=1:1:2 S:TYP'="S" ^TMP($J,IV,DAT,TYP)=LO F TT=1:1:2
- K COST Q
- H S PG=PG+1 U IO W @IOF 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",!?55,"INTRAVENOUS ADMIXTURE",?117,"PAGE ",PG
- W !!?45,"FROM "_$E(SDT,4,5)_"/"_$E(SDT,2,3),?60,"TO "_$E(EDT,4,5)_"/"_$E(EDT,2,3)_" ALL DIVISIONS",!!
- W !!?24,"PIGGYBKS & SYRS",?47,"L. V. P",?71,"T. P. N.",?87,"CHEMOTHERAPY",?110,"PER DATE",!?7,"DATE",?24,"TOT AVG CST",?44,"TOT AVG CST",?66,"TOT AVG CST",?85,"TOT AVG CST",?106,"TOT TOT CST"
- D LINE Q
- IV D H S DATE="",BEG=0 F JJ=0:0 S DATE=$O(^TMP($J,IV,DATE)) D:DATE="" MON Q:DATE="" D:$Y+6>IOSL H D
- .S MN=$E(DATE,1,5) S:'BEG PRV=$E(DATE,1,5),BEG=1 S:MN'=PRV&('$D(MM(PRV_"^P"))) PRV=$E(DATE,1,5)
- .S:'$D(MM(MN_"^"_TYP)) MM(MN_"^"_TYP)="0^0^"
- .K WDISP,WCOST,WUNITS D WRT2
- Q
- WRT2 I MN'=PRV D MON S PRV=$E(DATE,1,5)
- S TOTNDE=^TMP($J,IV,DATE,0) K WDISP,WCOST,TUC,DISP
- F TYP="P","A","H","C" S ZZ(TYP)=$S($D(^TMP($J,IV,DATE,TYP)):^(TYP),1:"") D COMPTE
- WDTOT S DS=WDISP,TUC=$S(DS'>0:0,1:WCOST),DISP=WDISP S IVTOT=IVTOT+WCOST,BTOT=BTOT+DISP,TYP="Z"
- Q
- COMPTE S DISP=$P(TOTNDE,"^",$S(TYP="P":1,TYP="A":2,TYP="H":3,TYP="C":4,1:5)) I +$P(ZZ(TYP),"^")'>0 S TUC=0 G HERE
- S:DISP'>0 TUC=0 G:DISP'>0 HERE S TUC=$P(ZZ(TYP),"^")/DISP
- HERE S WDISP=$S($D(WDISP):WDISP+DISP,1:DISP),WCOST=$S($D(WCOST):WCOST+$P(ZZ(TYP),"^"),1:$P(ZZ(TYP),"^"))
- S LO=$S($D(TOT(TYP)):TOT(TYP),1:""),$P(LO,"^")=$P(LO,"^")+$P(ZZ(TYP),"^"),$P(LO,"^",2)=$P(LO,"^",2)+DISP
- S $P(MM(MN_"^"_TYP),"^")=$S('$D(MM(MN_"^"_TYP)):0,1:$P(MM(MN_"^"_TYP),"^"))+$P(ZZ(TYP),"^")
- S $P(MM(MN_"^"_TYP),"^",2)=$S('$D(MM(MN_"^"_TYP)):0,1:$P(MM(MN_"^"_TYP),"^",2))+DISP
- S TOT(TYP)=LO
- Q
- MON K DISP,TUC,WDISP,WCOST W !,$E(PRV,4,5)_"/"_$E(PRV,2,3) F TYP="P","A","H","C" D
- .S TUC=$S('$D(MM(PRV_"^"_TYP)):0,$P(MM(PRV_"^"_TYP),"^",2)<1:0,1:$P(MM(PRV_"^"_TYP),"^")/$P(MM(PRV_"^"_TYP),"^",2))
- .S DISP=$S($D(MM(PRV_"^"_TYP)):$P(MM(PRV_"^"_TYP),"^",2),1:0)
- .S WDISP=$S($D(WDISP):WDISP+DISP,1:DISP),WCOST=$S($D(WCOST):WCOST+$P(MM(PRV_"^"_TYP),"^"),1:$P(MM(PRV_"^"_TYP),"^"))
- .D PRTLN1
- S DS=WDISP,TUC=$S(DS'>0:0,1:WCOST),DISP=WDISP,TYP="Z" D PRTLN1
- Q
- CTOT S TUC=$S('$D(TOT(TYP)):0,$P(TOT(TYP),"^",2)<1:0,1:$P(TOT(TYP),"^")/$P(TOT(TYP),"^",2))
- S DISP=$S($D(TOT(TYP)):$P(TOT(TYP),"^",2),1:0)
- PRTLN1 S TCOL=$S(TYP="P":20,TYP="A":40,TYP="H":62,TYP="C":73,1:102),CCOL=$S(TYP="P":27,TYP="A":40,TYP="H":62,TYP="C":73,1:112) W ?TCOL,$J(DISP,7,0),?CCOL,$J(TUC,12,2)
- Q
- GETEM I $D(^PS(50.8,IV,2,DAT,1,WARD,0)) S CNTNDE=^(0),X=0 D SETEM
- I $D(^PS(50.8,IV,2,DAT,1,WARD,"R")) S CNTNDE=^("R"),X="R" D SETEM
- Q
- SETEM F ZZ=1:1:5 S CNT(ZZ)=$P(CNTNDE,"^",ZZ+1)
- S LO=$S($D(^TMP($J,IV,DAT,X)):^(X),1:"") F ZZ=1:1:5 S $P(LO,"^",ZZ)=$P(LO,"^",ZZ)+CNT(ZZ)
- S CNT(1)=CNT(1)+CNT(5),$P(LO,"^")=$P(LO,"^")+$P(LO,"^",5),$P(LO,"^",5)=""
- S ^TMP($J,IV,DAT,X)=LO Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOMGMN4 4547 printed Feb 18, 2025@23:57:32 Page 2
- PSOMGMN4 ;BHAM ISC/JMB - MONTHLY MANAGEMENT IV REPORT ; 3/1/93
- +1 ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
- EN SET DVCNT=0
- FOR DV=0:0
- SET DV=$ORDER(^PS(59,DV))
- if 'DV
- QUIT
- SET DIV=DV
- SET DVCNT=DVCNT+1
- +1 SET (BEG,PG)=0
- KILL ^TMP($JOB)
- FOR IV=0:0
- SET IV=$ORDER(^PS(50.8,IV))
- if 'IV
- QUIT
- IF $DATA(^PS(50.8,IV,2))
- FOR DAT=SDT-1:0
- SET DAT=$ORDER(^PS(50.8,IV,2,DAT))
- if 'DAT!(DAT>EDT)
- QUIT
- Begin DoDot:1
- +2 IF $DATA(^PS(50.8,IV,2,DAT,1))
- FOR WARD=0:0
- SET WARD=$ORDER(^PS(50.8,IV,2,DAT,1,WARD))
- if 'WARD
- QUIT
- if WARD=.5
- DO GETEM
- +3 ;******* WARD=.5
- +4 IF $DATA(^PS(50.8,IV,2,DAT,2))
- FOR DRG=0:0
- SET DRG=$ORDER(^PS(50.8,IV,2,DAT,2,DRG))
- if 'DRG
- QUIT
- IF $DATA(^(DRG,0))
- SET DRGCOST=$PIECE(^(0),"^",5)
- DO WARD
- End DoDot:1
- W SET PG=0
- IF '$DATA(^TMP($JOB))
- DO H
- WRITE !,"No data."
- if $EXTRACT(IOST)'="C"
- WRITE @IOF
- GOTO K
- +1 KILL TOT
- SET (BTOT,IVTOT)=0
- FOR IV=0:0
- SET IV=$ORDER(^TMP($JOB,IV))
- if 'IV
- QUIT
- DO IV
- WRITE !
- DO DLINE
- WRITE !,"GRAND TOTAL: "
- FOR TYP="P","A","H","C"
- SET PR=""
- DO CTOT
- +2 WRITE ?101,$JUSTIFY(BTOT,8,0),?111,$JUSTIFY(IVTOT,13,2),!!!?17,"FINISHED PRINTING ON: "
- DO NOW^%DTC
- SET Y=%
- XECUTE ^DD("DD")
- WRITE Y
- if RUN="A"
- WRITE @IOF
- KILL ZTSK
- DO ^%ZISC
- K KILL ^TMP($JOB),BTOT,C,CCOL,CNT,CNTNDE,D,DA,DAT,DISP,DRG,DRGCOST,DS,EDT,I6,IV,IVTOT,JJ,LN,LO,DATE,PG,SDT,TCOL
- +1 ;,^TMP($J),
- +2 KILL TOT,TOTNDE,TUC,TYP,WARD,WCOST,WD,WDISP,WUNITS,X,Y,ZZ
- +3 QUIT
- LINE WRITE !
- FOR LN=1:1:124
- WRITE "-"
- +1 QUIT
- MLINE WRITE !?15
- FOR LN=1:1:109
- WRITE "-"
- +1 QUIT
- DLINE WRITE !
- FOR LN=1:1:124
- WRITE "="
- +1 QUIT
- WARD IF $DATA(^PS(50.8,IV,2,DAT,2,DRG,3))
- FOR WD=0:0
- SET WD=$ORDER(^PS(50.8,IV,2,DAT,2,DRG,3,WD))
- if 'WD
- QUIT
- IF WD=.5
- IF $DATA(^(WD,1))
- IF '$DATA(^DIC(42,WD,0))
- FOR TYP="P","A","H","S","C"
- DO TYPE
- +1 QUIT
- TYPE SET DA=$ORDER(^PS(50.8,IV,2,DAT,2,DRG,3,WD,"B",TYP,0))
- if DA'>0
- QUIT
- +1 SET COST=$PIECE(^PS(50.8,IV,2,DAT,2,DRG,3,WD,1,DA,0),"^",2)*DRGCOST
- +2 if TYP="S"
- SET LO=$SELECT($DATA(^TMP($JOB,IV,DAT,"P")):^("P"),1:"")
- if TYP'="S"
- SET LO=$SELECT($DATA(^TMP($JOB,IV,DAT,TYP)):^(TYP),1:"")
- SET $PIECE(LO,"^")=$PIECE(LO,"^")+COST
- +3 if TYP="S"
- SET ^TMP($JOB,IV,DAT,"P")=LO
- FOR TT=1:1:2
- if TYP'="S"
- SET ^TMP($JOB,IV,DAT,TYP)=LO
- FOR TT=1:1:2
- +4 KILL COST
- QUIT
- H SET PG=PG+1
- USE IO
- WRITE @IOF
- 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",!?55,"INTRAVENOUS ADMIXTURE",?117,"PAGE ",PG
- +1 WRITE !!?45,"FROM "_$EXTRACT(SDT,4,5)_"/"_$EXTRACT(SDT,2,3),?60,"TO "_$EXTRACT(EDT,4,5)_"/"_$EXTRACT(EDT,2,3)_" ALL DIVISIONS",!!
- +2 WRITE !!?24,"PIGGYBKS & SYRS",?47,"L. V. P",?71,"T. P. N.",?87,"CHEMOTHERAPY",?110,"PER DATE",!?7,"DATE",?24,"TOT AVG CST",?44,"TOT AVG CST",?66,"TOT AVG CST",?85,"TOT AVG CST",?106,"TOT TOT CST"
- +3 DO LINE
- QUIT
- IV DO H
- SET DATE=""
- SET BEG=0
- FOR JJ=0:0
- SET DATE=$ORDER(^TMP($JOB,IV,DATE))
- if DATE=""
- DO MON
- if DATE=""
- QUIT
- if $Y+6>IOSL
- DO H
- Begin DoDot:1
- +1 SET MN=$EXTRACT(DATE,1,5)
- if 'BEG
- SET PRV=$EXTRACT(DATE,1,5)
- SET BEG=1
- if MN'=PRV&('$DATA(MM(PRV_"^P")))
- SET PRV=$EXTRACT(DATE,1,5)
- +2 if '$DATA(MM(MN_"^"_TYP))
- SET MM(MN_"^"_TYP)="0^0^"
- +3 KILL WDISP,WCOST,WUNITS
- DO WRT2
- End DoDot:1
- +4 QUIT
- WRT2 IF MN'=PRV
- DO MON
- SET PRV=$EXTRACT(DATE,1,5)
- +1 SET TOTNDE=^TMP($JOB,IV,DATE,0)
- KILL WDISP,WCOST,TUC,DISP
- +2 FOR TYP="P","A","H","C"
- SET ZZ(TYP)=$SELECT($DATA(^TMP($JOB,IV,DATE,TYP)):^(TYP),1:"")
- DO COMPTE
- WDTOT SET DS=WDISP
- SET TUC=$SELECT(DS'>0:0,1:WCOST)
- SET DISP=WDISP
- SET IVTOT=IVTOT+WCOST
- SET BTOT=BTOT+DISP
- SET TYP="Z"
- +1 QUIT
- COMPTE SET DISP=$PIECE(TOTNDE,"^",$SELECT(TYP="P":1,TYP="A":2,TYP="H":3,TYP="C":4,1:5))
- IF +$PIECE(ZZ(TYP),"^")'>0
- SET TUC=0
- GOTO HERE
- +1 if DISP'>0
- SET TUC=0
- if DISP'>0
- GOTO HERE
- SET TUC=$PIECE(ZZ(TYP),"^")/DISP
- HERE SET WDISP=$SELECT($DATA(WDISP):WDISP+DISP,1:DISP)
- SET WCOST=$SELECT($DATA(WCOST):WCOST+$PIECE(ZZ(TYP),"^"),1:$PIECE(ZZ(TYP),"^"))
- +1 SET LO=$SELECT($DATA(TOT(TYP)):TOT(TYP),1:"")
- SET $PIECE(LO,"^")=$PIECE(LO,"^")+$PIECE(ZZ(TYP),"^")
- SET $PIECE(LO,"^",2)=$PIECE(LO,"^",2)+DISP
- +2 SET $PIECE(MM(MN_"^"_TYP),"^")=$SELECT('$DATA(MM(MN_"^"_TYP)):0,1:$PIECE(MM(MN_"^"_TYP),"^"))+$PIECE(ZZ(TYP),"^")
- +3 SET $PIECE(MM(MN_"^"_TYP),"^",2)=$SELECT('$DATA(MM(MN_"^"_TYP)):0,1:$PIECE(MM(MN_"^"_TYP),"^",2))+DISP
- +4 SET TOT(TYP)=LO
- +5 QUIT
- MON KILL DISP,TUC,WDISP,WCOST
- WRITE !,$EXTRACT(PRV,4,5)_"/"_$EXTRACT(PRV,2,3)
- FOR TYP="P","A","H","C"
- Begin DoDot:1
- +1 SET TUC=$SELECT('$DATA(MM(PRV_"^"_TYP)):0,$PIECE(MM(PRV_"^"_TYP),"^",2)<1:0,1:$PIECE(MM(PRV_"^"_TYP),"^")/$PIECE(MM(PRV_"^"_TYP),"^",2))
- +2 SET DISP=$SELECT($DATA(MM(PRV_"^"_TYP)):$PIECE(MM(PRV_"^"_TYP),"^",2),1:0)
- +3 SET WDISP=$SELECT($DATA(WDISP):WDISP+DISP,1:DISP)
- SET WCOST=$SELECT($DATA(WCOST):WCOST+$PIECE(MM(PRV_"^"_TYP),"^"),1:$PIECE(MM(PRV_"^"_TYP),"^"))
- +4 DO PRTLN1
- End DoDot:1
- +5 SET DS=WDISP
- SET TUC=$SELECT(DS'>0:0,1:WCOST)
- SET DISP=WDISP
- SET TYP="Z"
- DO PRTLN1
- +6 QUIT
- CTOT SET TUC=$SELECT('$DATA(TOT(TYP)):0,$PIECE(TOT(TYP),"^",2)<1:0,1:$PIECE(TOT(TYP),"^")/$PIECE(TOT(TYP),"^",2))
- +1 SET DISP=$SELECT($DATA(TOT(TYP)):$PIECE(TOT(TYP),"^",2),1:0)
- PRTLN1 SET TCOL=$SELECT(TYP="P":20,TYP="A":40,TYP="H":62,TYP="C":73,1:102)
- SET CCOL=$SELECT(TYP="P":27,TYP="A":40,TYP="H":62,TYP="C":73,1:112)
- WRITE ?TCOL,$JUSTIFY(DISP,7,0),?CCOL,$JUSTIFY(TUC,12,2)
- +1 QUIT
- GETEM IF $DATA(^PS(50.8,IV,2,DAT,1,WARD,0))
- SET CNTNDE=^(0)
- SET X=0
- DO SETEM
- +1 IF $DATA(^PS(50.8,IV,2,DAT,1,WARD,"R"))
- SET CNTNDE=^("R")
- SET X="R"
- DO SETEM
- +2 QUIT
- SETEM FOR ZZ=1:1:5
- SET CNT(ZZ)=$PIECE(CNTNDE,"^",ZZ+1)
- +1 SET LO=$SELECT($DATA(^TMP($JOB,IV,DAT,X)):^(X),1:"")
- FOR ZZ=1:1:5
- SET $PIECE(LO,"^",ZZ)=$PIECE(LO,"^",ZZ)+CNT(ZZ)
- +2 SET CNT(1)=CNT(1)+CNT(5)
- SET $PIECE(LO,"^")=$PIECE(LO,"^")+$PIECE(LO,"^",5)
- SET $PIECE(LO,"^",5)=""
- +3 SET ^TMP($JOB,IV,DAT,X)=LO
- QUIT