LRARCTS1 ; IHS/DIR/AAB - PRINT TREATING SPECIALTY ARCHIVED WKLD REPORT ; [ 6/1/95 ]
;;5.2;LR;**1002**;JUN 01, 1998
;;5.2;LAB SERVICE;**59**;Aug 31, 1995
;same as LRCAPTS1 except archived wkld file
EN ; called by LRARCPTS
TOP ;
S LRPAGE=0
W:$E(IOST)="C" @IOF ;Clear the 'WORKING' dots
D:'LRSUMM PRN
D:('LREND)&(LRGTU) SUMM
Q
PRN ; PRINT THE REPORT
S LRLAB="!!!,""TREATING SPECIALTY"_$S($D(LRPTF):" (PTF)",1:"")_" : "",LRTS,!!,""CODE"",?11,""PROCEDURE"",?42,""UNIT COST"",?53,""UNIT COUNT"",?65,""TOTAL COST"""
D HDR
I LRGTU=0 D:$Y>(IOSL-6) PG Q:LREND W !!!,"NO DATA FOR THIS INSTITUTION AND DATE RANGE",!! D:$E(IOST)="C" WAIT Q:LREND W @IOF Q
S LRTS=0
F S LRTS=$O(^TMP($J,"LRAR-WL",LRTS)) Q:(LRTS="")!(LREND) D TS
Q:LREND
D:$Y>(IOSL-6) PG Q:LREND
W !!,"GRAND TOTAL",?52,$J(LRGTU,7),?65,$J(LRGT,9,2)
D:$E(IOST)="C" WAIT Q:LREND W @IOF
Q
SUMM ;
S LRLAB="!!,?"_(IOM-7\2)_",""SUMMARY"",!!!,""TREATING SPECIALTY"","_$S($D(LRPTF):""" (PTF) """,1:""" """)_",?31,""UNIT COUNT"",?45,"" %"",?55,""TOTAL COST"",?70,"" %"",!"
D HDR
W @LRLAB
S LRTS=""
F S LRTS=$O(^TMP($J,"LRAR-WL",LRTS)) Q:LRTS=""!(LREND) D PSUM
Q:LREND
D:$Y>(IOSL-6) PG Q:LREND
W !!,"GRAND TOTAL",?31,$J(LRGTU,7),?55,$J(LRGT,9,2)
D:$E(IOST)="C" WAIT Q:LREND W @IOF
Q
PSUM ;
Q:'$D(^TMP($J,"LRAR-WL",LRTS,0))#2 S LRX=^(0)
D:$Y>(IOSL-6) PG Q:LREND
W !,$E(LRTS,1,30),?31,$J($P(LRX,U,2),7)
W ?45,$J($S(LRGTU:$P(LRX,U,2)/LRGTU,1:0)*100,5,1),?55,$J($P(LRX,U,1),9,2)
W ?70,$J($P(LRX,U)/$S(LRGT=0:1,1:LRGT)*100,5,1)
Q
TS ;
D:$Y>(IOSL-6) PG Q:LREND W @LRLAB
S (LRSTU,LRST,LRCC)=0
F S LRCC=$O(^TMP($J,"LRAR-WL",LRTS,LRCC)) Q:(LRCC="")!(LREND) D PCC
Q:LREND
S:$D(^TMP($J,"LRAR-WL",LRTS,0))#2 LRST=$P(^(0),"^"),LRSTU=$P(^(0),"^",2)
D:$Y>(IOSL-6) PG Q:LREND
W !!,?40,"SUB TOTAL",?52,$J(LRSTU,7),?65,$J(LRST,9,2)
Q
PCC ;
S LRX="" S:$D(^TMP($J,"LRAR-WL",LRTS,LRCC))#2 LRX=^(LRCC)
D:$Y>(IOSL-6) PG Q:LREND
W !,$P(LRX,U,4),?11,$E(LRCC,1,30),?44,$J(+$P(LRX,U,3),5,2)
W ?52,$J(+$P(LRX,U),7),?65,$J(+$P(LRX,U,2),9,2)
Q
PG ;
I $E(IOST)="C" D WAIT Q:LREND
W @IOF D HDR W @LRLAB
Q
WAIT ;
R !,"PRESS RETURN TO CONTINUE, ""^"" TO QUIT. ",LRANS:DTIME
I ('$T)!(LRANS["^") S LREND=1 Q
G:LRANS["?" WAIT W @IOF
Q
HDR ;
S LRPAGE=LRPAGE+1
W !!,?((IOM-34)\2),"TREATING SPECIALTY ARCHIVED WORKLOAD REPORT"
W !!,?((IOM-$L(LRINN))\2),LRINN,?(IOM-10),"PAGE ",LRPAGE
W !!,?((IOM-(23+$L(LRDT1)+$L(LRDT2)))\2),"REPORT DATE RANGE: "
W LRDT1," - ",LRDT2
Q
LRARCTS1 ; IHS/DIR/AAB - PRINT TREATING SPECIALTY ARCHIVED WKLD REPORT ; [ 6/1/95 ]
+1 ;;5.2;LR;**1002**;JUN 01, 1998
+2 ;;5.2;LAB SERVICE;**59**;Aug 31, 1995
+3 ;same as LRCAPTS1 except archived wkld file
EN ; called by LRARCPTS
TOP ;
+1 SET LRPAGE=0
+2 ;Clear the 'WORKING' dots
IF $EXTRACT(IOST)="C"
WRITE @IOF
+3 IF 'LRSUMM
DO PRN
+4 IF ('LREND)&(LRGTU)
DO SUMM
+5 QUIT
PRN ; PRINT THE REPORT
+1 SET LRLAB="!!!,""TREATING SPECIALTY"_$SELECT($DATA(LRPTF):" (PTF)",1:"")_" : "",LRTS,!!,""CODE"",?11,""PROCEDURE"",?42,""UNIT COST"",?53,""UNIT COUNT"",?65,""TOTAL COST"""
+2 DO HDR
+3 IF LRGTU=0
IF $Y>(IOSL-6)
DO PG
IF LREND
QUIT
WRITE !!!,"NO DATA FOR THIS INSTITUTION AND DATE RANGE",!!
IF $EXTRACT(IOST)="C"
DO WAIT
IF LREND
QUIT
WRITE @IOF
QUIT
+4 SET LRTS=0
+5 FOR
SET LRTS=$ORDER(^TMP($JOB,"LRAR-WL",LRTS))
IF (LRTS="")!(LREND)
QUIT
DO TS
+6 IF LREND
QUIT
+7 IF $Y>(IOSL-6)
DO PG
IF LREND
QUIT
+8 WRITE !!,"GRAND TOTAL",?52,$JUSTIFY(LRGTU,7),?65,$JUSTIFY(LRGT,9,2)
+9 IF $EXTRACT(IOST)="C"
DO WAIT
IF LREND
QUIT
WRITE @IOF
+10 QUIT
SUMM ;
+1 SET LRLAB="!!,?"_(IOM-7\2)_",""SUMMARY"",!!!,""TREATING SPECIALTY"","_$SELECT($DATA(LRPTF):""" (PTF) """,1:""" """)_",?31,""UNIT COUNT"",?45,"" %"",?55,""TOTAL COST"",?70,"" %"",!"
+2 DO HDR
+3 WRITE @LRLAB
+4 SET LRTS=""
+5 FOR
SET LRTS=$ORDER(^TMP($JOB,"LRAR-WL",LRTS))
IF LRTS=""!(LREND)
QUIT
DO PSUM
+6 IF LREND
QUIT
+7 IF $Y>(IOSL-6)
DO PG
IF LREND
QUIT
+8 WRITE !!,"GRAND TOTAL",?31,$JUSTIFY(LRGTU,7),?55,$JUSTIFY(LRGT,9,2)
+9 IF $EXTRACT(IOST)="C"
DO WAIT
IF LREND
QUIT
WRITE @IOF
+10 QUIT
PSUM ;
+1 IF '$DATA(^TMP($JOB,"LRAR-WL",LRTS,0))#2
QUIT
SET LRX=^(0)
+2 IF $Y>(IOSL-6)
DO PG
IF LREND
QUIT
+3 WRITE !,$EXTRACT(LRTS,1,30),?31,$JUSTIFY($PIECE(LRX,U,2),7)
+4 WRITE ?45,$JUSTIFY($SELECT(LRGTU:$PIECE(LRX,U,2)/LRGTU,1:0)*100,5,1),?55,$JUSTIFY($PIECE(LRX,U,1),9,2)
+5 WRITE ?70,$JUSTIFY($PIECE(LRX,U)/$SELECT(LRGT=0:1,1:LRGT)*100,5,1)
+6 QUIT
TS ;
+1 IF $Y>(IOSL-6)
DO PG
IF LREND
QUIT
WRITE @LRLAB
+2 SET (LRSTU,LRST,LRCC)=0
+3 FOR
SET LRCC=$ORDER(^TMP($JOB,"LRAR-WL",LRTS,LRCC))
IF (LRCC="")!(LREND)
QUIT
DO PCC
+4 IF LREND
QUIT
+5 IF $DATA(^TMP($JOB,"LRAR-WL",LRTS,0))#2
SET LRST=$PIECE(^(0),"^")
SET LRSTU=$PIECE(^(0),"^",2)
+6 IF $Y>(IOSL-6)
DO PG
IF LREND
QUIT
+7 WRITE !!,?40,"SUB TOTAL",?52,$JUSTIFY(LRSTU,7),?65,$JUSTIFY(LRST,9,2)
+8 QUIT
PCC ;
+1 SET LRX=""
IF $DATA(^TMP($JOB,"LRAR-WL",LRTS,LRCC))#2
SET LRX=^(LRCC)
+2 IF $Y>(IOSL-6)
DO PG
IF LREND
QUIT
+3 WRITE !,$PIECE(LRX,U,4),?11,$EXTRACT(LRCC,1,30),?44,$JUSTIFY(+$PIECE(LRX,U,3),5,2)
+4 WRITE ?52,$JUSTIFY(+$PIECE(LRX,U),7),?65,$JUSTIFY(+$PIECE(LRX,U,2),9,2)
+5 QUIT
PG ;
+1 IF $EXTRACT(IOST)="C"
DO WAIT
IF LREND
QUIT
+2 WRITE @IOF
DO HDR
WRITE @LRLAB
+3 QUIT
WAIT ;
+1 READ !,"PRESS RETURN TO CONTINUE, ""^"" TO QUIT. ",LRANS:DTIME
+2 IF ('$TEST)!(LRANS["^")
SET LREND=1
QUIT
+3 IF LRANS["?"
GOTO WAIT
WRITE @IOF
+4 QUIT
HDR ;
+1 SET LRPAGE=LRPAGE+1
+2 WRITE !!,?((IOM-34)\2),"TREATING SPECIALTY ARCHIVED WORKLOAD REPORT"
+3 WRITE !!,?((IOM-$LENGTH(LRINN))\2),LRINN,?(IOM-10),"PAGE ",LRPAGE
+4 WRITE !!,?((IOM-(23+$LENGTH(LRDT1)+$LENGTH(LRDT2)))\2),"REPORT DATE RANGE: "
+5 WRITE LRDT1," - ",LRDT2
+6 QUIT
