source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRCAPML2.m@ 1489

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

initial load of WorldVistAEHR

File size: 3.3 KB
Line 
1LRCAPML2 ;SLC/AM/DALISC/FHS - WKLD COST REP BY MAJ SCTN; 2/6/91@16:04
2 ;;5.2;LAB SERVICE;;Sep 27, 1994
3EN ;
4TOP ;
5 N LRCCNT,LRICNT,LROCNT,LRNCNT,LRACNT,LRCST,LRIST,LROST,LRNST,LRAST
6 S LRHDR="WORKLOAD COST REPORT BY MAJOR SECTION"
7 S LRHDR2="REPORT DATE RANGE: "_LRDT1_" - "_LRDT2
8 D PRTINIT^LRCAPU
9 S (LRGT,LRGTU)=0
10 S LRGTREC=$G(^TMP("LR-WL",$J,0))
11 I $L(LRGTREC) S LRGT=+$P(LRGTREC,U),LRGTU=+$P(LRGTREC,U,2)
12 I $E(IOST,1,2)="C-" W @IOF
13 D:'LRSUMM DET
14 D:'LREND SUM^LRCAPML3
15 D:'LREND PRNTMAN^LRCAPMR1
16 D:'LREND COMM^LRCAPMR2
17 Q
18DET ;Detailed section
19 F LRLDIV="AP","CP" D Q:LREND
20 . S LRHDR3=$S(LRLDIV="AP":"ANATOMIC PATHOLOGY",1:"CLINICAL PATHOLOGY")
21 . S LRIN=0
22 . F S LRIN=$O(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN)) Q:('LRIN)!(LREND) D
23 . . S LRINN=$S($L($G(^DIC(4,LRIN,0))):$P(^(0),U),1:LRIN)
24 . . S (LRIGT,LRIGTU)=0
25 . . S LRGTREC=$G(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,0))
26 . . I $L(LRGTREC) S LRIGT=+$P(LRGTREC,U),LRIGTU=+$P(LRGTREC,U,2)
27 . . D PRTDET
28 . . D:('LREND)&(LRIGTU) INSTSUM
29 Q
30PRTDET ; PRINT THE REPORT
31 D HDR^LRCAPU
32 W !,?(80-$L(LRINN)\2),LRINN,!!
33 S LRMAA=0
34 F S LRMAA=$O(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA)) Q:(LRMAA="")!($G(LREND)) D
35 . S LRLSSA=""
36 . F S LRLSSA=$O(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA)) Q:(LRLSSA)=""!(LREND) D LSS Q:LREND
37 Q:LREND
38 I $Y>(IOSL-5) D NPG^LRCAPU Q:LREND W !,?(80-$L(LRINN)\2),LRINN,!!
39 I 'LRIGTU D
40 . W !!!,"NO DATA FOR THIS INSTITUTION AND DATE RANGE",!
41 E D
42 . W !!!,"GRAND TOTAL",?52,$J(LRIGTU,7),?65,$J(LRIGT,9,2),!
43 D:($E(IOST,1,2)="C-")&('LREND) PAUSE^LRCAPU W @IOF
44 Q
45INSTSUM ;
46 S LRLAB="!!,?(80-7\2),""SUMMARY"",!,?(80-$L(LRINN)\2),LRINN,!!,""MAJOR SECTION"",?15,""LAB SUBSECTION"",?31,""UNIT COUNT"",?45,"" %"",?55,""TOTAL COST"",?70,"" %"",!"
47 D HDR^LRCAPU W @LRLAB
48 S LRMAA=""
49 F S LRMAA=$O(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA)) Q:(LRMAA="")!(LREND) D
50 . S LRLSSA=""
51 . F S LRLSSA=$O(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA)) Q:(LRLSSA="")!(LREND) D PSUM
52 I $Y>(IOSL-4) D NPG^LRCAPU Q:LREND W @LRLAB
53 W !!,"GRAND TOTAL",?31,$J(LRIGTU,7),?55,$J(LRIGT,9,2)
54 D:($E(IOST,1,2)="C-")&('LREND) PAUSE^LRCAPU W @IOF
55 Q
56PSUM ;
57 Q:LREND
58 S LRX=$G(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0))
59 Q:'$L(LRX)
60 I $Y>(IOSL-3) D NPG^LRCAPU Q:LREND W @LRLAB
61 W !,$E(LRMAN(LRMAA),1,14),?15,$E(LRLSSN(LRLSSA),1,15)
62 W ?31,$J($P(LRX,U,2),7),?45,$J($P(LRX,U,2)/LRIGTU*100,5,1)
63 W ?55,$J($P(LRX,U,1),9,2)
64 W ?70,$J($P(LRX,U)/$S(LRIGT=0:1,1:LRIGT)*100,5,1),!
65 Q
66LSS ;
67 S LRLAB="!!,""MAJOR SECTION: "",LRMAN(LRMAA),!,""LAB SUBSECTION: "",LRLSSN(LRLSSA),!!,""CODE"",?11,""PROCEDURE"",?42,""UNIT COST"",?53,""UNIT COUNT"",?65,""TOTAL COST"",?70,"" %"",!"
68 I $Y>(IOSL-7) D NPG^LRCAPU Q:LREND W !,?(80-$L(LRINN)\2),LRINN,!
69 W @LRLAB
70 S LRX=$G(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0))
71 S LRST=$P(LRX,U),LRSTU=$P(LRX,U,2)
72 S LRCC=0
73 F S LRCC=$O(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCC)) Q:(LRCC="")!(LREND) D PCC
74 Q:LREND
75 I $Y>(IOSL-4) D NPG^LRCAPU Q:LREND W !,?(80-$L(LRINN)\2),LRINN,!,@LRLAB
76 W !,?40,"SUB TOTAL",?52,$J(LRSTU,7),?65,$J(LRST,9,2)
77 Q
78PCC ;
79 S LRX=$G(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCC))
80 I $Y+3>IOSL D NPG^LRCAPU Q:LREND W !,?(80-$L(LRINN)\2),LRINN,!,@LRLAB
81 W $P(LRX,"^",4),?11,$E(LRCC,1,30),?43,$J(+$P(LRX,"^",3),6,2)_$S($P(LRX,"^",3)["*":"*",1:"")
82 W ?52,$J(+$P(LRX,"^"),7),?65,$J(+$P(LRX,"^",2),9,2)
83 W ?75,$J($P(LRX,U)/$S(LRSTU=0:1,1:LRSTU)*100,5,1),!
84 Q
Note: See TracBrowser for help on using the repository browser.