source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOMGRP4.m@ 1765

Last change on this file since 1765 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.5 KB
Line 
1PSOMGRP4 ;BHAM ISC/JMB - DAILY MANAGEMENT IV REPORT ; 3/1/93
2 ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
3EN S DVCNT=0 F DV=0:0 S DV=$O(^PS(59,DV)) Q:'DV S DIV=DV,DVCNT=DVCNT+1
4 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
5 .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
6 .;******* WARD=.5
7 .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
8W S PG=0 I '$D(^TMP($J)) D H W !,"No data." W:$E(IOST)'="C" @IOF G K
9 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
10 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
11K K 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)
12 ;,^TMP($J),
13 K TOT,TOTNDE,TUC,TYP,WARD,WCOST,WD,WDISP,WUNITS,X,Y,ZZ
14 Q
15LINE W ! F LN=1:1:124 W "-"
16 Q
17MLINE W !?15 F LN=1:1:109 W "-"
18 Q
19DLINE W ! F LN=1:1:124 W "="
20 Q
21WARD 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
22 Q
23TYPE S DA=$O(^PS(50.8,IV,2,DAT,2,DRG,3,WD,"B",TYP,0)) Q:DA'>0
24 S COST=$P(^PS(50.8,IV,2,DAT,2,DRG,3,WD,1,DA,0),"^",2)*DRGCOST
25 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
26 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
27 K COST Q
28H 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
29 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)_" ALL DIVISIONS",!!
30 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"
31 D LINE Q
32IV 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
33 .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)
34 .S:'$D(MM(MN_"^"_TYP)) MM(MN_"^"_TYP)="0^0^"
35 .K WDISP,WCOST,WUNITS D WRT2
36 Q
37WRT2 I MN'=PRV D MON S PRV=$E(DATE,1,5)
38 W !,$E(DATE,4,5)_"-"_$E(DATE,6,7)_"-"_$E(DATE,2,3) S TOTNDE=^TMP($J,IV,DATE,0) K WDISP,WCOST,TUC,DISP
39 F TYP="P","A","H","C" S ZZ(TYP)=$S($D(^TMP($J,IV,DATE,TYP)):^(TYP),1:"") D COMPTE K PR D PRTLN1
40WDTOT S DS=WDISP,TUC=$S(DS'>0:0,1:WCOST),DISP=WDISP S IVTOT=IVTOT+WCOST,BTOT=BTOT+DISP,TYP="Z" D PRTLN1
41 Q
42COMPTE 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
43 S:DISP'>0 TUC=0 G:DISP'>0 HERE S TUC=$P(ZZ(TYP),"^")/DISP
44HERE S WDISP=$S($D(WDISP):WDISP+DISP,1:DISP),WCOST=$S($D(WCOST):WCOST+$P(ZZ(TYP),"^"),1:$P(ZZ(TYP),"^"))
45 S LO=$S($D(TOT(TYP)):TOT(TYP),1:""),$P(LO,"^")=$P(LO,"^")+$P(ZZ(TYP),"^"),$P(LO,"^",2)=$P(LO,"^",2)+DISP
46 S $P(MM(MN_"^"_TYP),"^")=$S('$D(MM(MN_"^"_TYP)):0,1:$P(MM(MN_"^"_TYP),"^"))+$P(ZZ(TYP),"^")
47 S $P(MM(MN_"^"_TYP),"^",2)=$S('$D(MM(MN_"^"_TYP)):0,1:$P(MM(MN_"^"_TYP),"^",2))+DISP
48 S TOT(TYP)=LO
49 Q
50MON K DISP,TUC,WDISP,WCOST D MLINE W !,"MONTH TOTAL" F TYP="P","A","H","C" D
51 .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))
52 .S DISP=$S($D(MM(PRV_"^"_TYP)):$P(MM(PRV_"^"_TYP),"^",2),1:0)
53 .S WDISP=$S($D(WDISP):WDISP+DISP,1:DISP),WCOST=$S($D(WCOST):WCOST+$P(MM(PRV_"^"_TYP),"^"),1:$P(MM(PRV_"^"_TYP),"^"))
54 .D PRTLN1
55 S DS=WDISP,TUC=$S(DS'>0:0,1:WCOST),DISP=WDISP,TYP="Z" D PRTLN1
56 Q
57CTOT S TUC=$S('$D(TOT(TYP)):0,$P(TOT(TYP),"^",2)<1:0,1:$P(TOT(TYP),"^")/$P(TOT(TYP),"^",2))
58 S DISP=$S($D(TOT(TYP)):$P(TOT(TYP),"^",2),1:0)
59PRTLN1 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)
60 Q
61GETEM I $D(^PS(50.8,IV,2,DAT,1,WARD,0)) S CNTNDE=^(0),X=0 D SETEM
62 I $D(^PS(50.8,IV,2,DAT,1,WARD,"R")) S CNTNDE=^("R"),X="R" D SETEM
63 Q
64SETEM F ZZ=1:1:5 S CNT(ZZ)=$P(CNTNDE,"^",ZZ+1)
65 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)
66 S CNT(1)=CNT(1)+CNT(5),$P(LO,"^")=$P(LO,"^")+$P(LO,"^",5),$P(LO,"^",5)=""
67 S ^TMP($J,IV,DAT,X)=LO Q
Note: See TracBrowser for help on using the repository browser.