LRARCML2 ;DALISC/CKA - ARCHIVED WKLD COST REP BY MAJ SCTN; 5/22/95
;;5.2;LAB SERVICE;**59**;Aug 31, 1995
;same as LRCAPML2 except archived wkld data file
EN ;
TOP ;
N LRCCNT,LRICNT,LROCNT,LRNCNT,LRACNT,LRCST,LRIST,LROST,LRNST,LRAST
S LRHDR="ARCHIVED WORKLOAD COST REPORT BY MAJOR SECTION"
S LRHDR2="REPORT DATE RANGE: "_LRDT1_" - "_LRDT2
D PRTINIT^LRARCU
S (LRGT,LRGTU)=0
S LRGTREC=$G(^TMP("LRAR-WL",$J,0))
I $L(LRGTREC) S LRGT=+$P(LRGTREC,U),LRGTU=+$P(LRGTREC,U,2)
I $E(IOST,1,2)="C-" W @IOF
D:'LRSUMM DET
D:'LREND SUM^LRARCML3
D:'LREND PRNTMAN^LRARCMR1
D:'LREND COMM^LRARCMR2
Q
DET ;Detailed section
F LRLDIV="AP","CP" D Q:LREND
. S LRHDR3=$S(LRLDIV="AP":"ANATOMIC PATHOLOGY",1:"CLINICAL PATHOLOGY")
. S LRIN=0
. F S LRIN=$O(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN)) Q:('LRIN)!(LREND) D
. . S LRINN=$S($D(^LAR(64.19999,LRIN,0)):^(0),1:"UNDEFINED")
. . S (LRIGT,LRIGTU)=0
. . S LRGTREC=$G(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,0))
. . I $L(LRGTREC) S LRIGT=+$P(LRGTREC,U),LRIGTU=+$P(LRGTREC,U,2)
. . D PRTDET
. . D:('LREND)&(LRIGTU) INSTSUM
Q
PRTDET ; PRINT THE REPORT
D HDR^LRARCU
W !,?(80-$L(LRINN)\2),LRINN,!!
S LRMAA=""
F S LRMAA=$O(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA)) Q:(LRMAA="")!($G(LREND)) D
. S LRLSSA=""
. F S LRLSSA=$O(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA)) Q:(LRLSSA)=""!(LREND) D LSS Q:LREND
Q:LREND
I $Y>(IOSL-5) D NPG^LRARCU Q:LREND W !,?(80-$L(LRINN)\2),LRINN,!!
I 'LRIGTU D
. W !!!,"NO DATA FOR THIS INSTITUTION AND DATE RANGE",!
E D
. W !!!,"GRAND TOTAL",?52,$J(LRIGTU,7),?65,$J(LRIGT,9,2),!
D:($E(IOST,1,2)="C-")&('LREND) PAUSE^LRARCU W @IOF
Q
INSTSUM ;
S LRLAB="!!,?(80-7\2),""SUMMARY"",!,?(80-$L(LRINN)\2),LRINN,!!,""MAJOR SECTION"",?15,""LAB SUBSECTION"",?31,""UNIT COUNT"",?45,"" %"",?55,""TOTAL COST"",?70,"" %"",!"
D HDR^LRARCU W @LRLAB
S LRMAA=""
F S LRMAA=$O(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA)) Q:(LRMAA="")!(LREND) D
. S LRLSSA=""
. F S LRLSSA=$O(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA)) Q:(LRLSSA="")!(LREND) D PSUM
I $Y>(IOSL-4) D NPG^LRARCU Q:LREND W @LRLAB
W !!,"GRAND TOTAL",?31,$J(LRIGTU,7),?55,$J(LRIGT,9,2)
D:($E(IOST,1,2)="C-")&('LREND) PAUSE^LRARCU W @IOF
Q
PSUM ;
Q:LREND
S LRX=$G(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0))
Q:'$L(LRX)
I $Y>(IOSL-3) D NPG^LRARCU Q:LREND W @LRLAB
W !,$E(LRMAN(LRMAA),1,14),?15,$E(LRLSSN(LRLSSA),1,15)
W ?31,$J($P(LRX,U,2),7),?45,$J($P(LRX,U,2)/LRIGTU*100,5,1)
W ?55,$J($P(LRX,U,1),9,2)
W ?70,$J($P(LRX,U)/$S(LRIGT=0:1,1:LRIGT)*100,5,1),!
Q
LSS ;
S LRLAB="!!,""MAJOR SECTION: "",LRMAN(LRMAA),!,""LAB SUBSECTION: "",LRLSSN(LRLSSA),!!,""CODE"",?11,""PROCEDURE"",?42,""UNIT COST"",?53,""UNIT COUNT"",?65,""TOTAL COST"",?70,"" %"",!"
I $Y>(IOSL-7) D NPG^LRARCU Q:LREND W !,?(80-$L(LRINN)\2),LRINN,!
W @LRLAB
S LRX=$G(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0))
S LRST=$P(LRX,U),LRSTU=$P(LRX,U,2)
S LRCC=0
F S LRCC=$O(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCC)) Q:(LRCC="")!(LREND) D PCC
Q:LREND
I $Y>(IOSL-4) D NPG^LRARCU Q:LREND W !,?(80-$L(LRINN)\2),LRINN,!,@LRLAB
W !,?40,"SUB TOTAL",?52,$J(LRSTU,7),?65,$J(LRST,9,2)
Q
PCC ;
S LRX=$G(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCC))
I $Y+3>IOSL D NPG^LRARCU Q:LREND W !,?(80-$L(LRINN)\2),LRINN,!,@LRLAB
W $P(LRX,"^",4),?11,$E(LRCC,1,30),?43,$J(+$P(LRX,"^",3),6,2)_$S($P(LRX,"^",3)["*":"*",1:"")
W ?52,$J(+$P(LRX,"^"),7),?65,$J(+$P(LRX,"^",2),9,2)
W ?75,$J($P(LRX,U)/$S(LRSTU=0:1,1:LRSTU)*100,5,1),!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRARCML2 3578 printed Dec 13, 2024@02:09:11 Page 2
LRARCML2 ;DALISC/CKA - ARCHIVED WKLD COST REP BY MAJ SCTN; 5/22/95
+1 ;;5.2;LAB SERVICE;**59**;Aug 31, 1995
+2 ;same as LRCAPML2 except archived wkld data file
EN ;
TOP ;
+1 NEW LRCCNT,LRICNT,LROCNT,LRNCNT,LRACNT,LRCST,LRIST,LROST,LRNST,LRAST
+2 SET LRHDR="ARCHIVED WORKLOAD COST REPORT BY MAJOR SECTION"
+3 SET LRHDR2="REPORT DATE RANGE: "_LRDT1_" - "_LRDT2
+4 DO PRTINIT^LRARCU
+5 SET (LRGT,LRGTU)=0
+6 SET LRGTREC=$GET(^TMP("LRAR-WL",$JOB,0))
+7 IF $LENGTH(LRGTREC)
SET LRGT=+$PIECE(LRGTREC,U)
SET LRGTU=+$PIECE(LRGTREC,U,2)
+8 IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+9 if 'LRSUMM
DO DET
+10 if 'LREND
DO SUM^LRARCML3
+11 if 'LREND
DO PRNTMAN^LRARCMR1
+12 if 'LREND
DO COMM^LRARCMR2
+13 QUIT
DET ;Detailed section
+1 FOR LRLDIV="AP","CP"
Begin DoDot:1
+2 SET LRHDR3=$SELECT(LRLDIV="AP":"ANATOMIC PATHOLOGY",1:"CLINICAL PATHOLOGY")
+3 SET LRIN=0
+4 FOR
SET LRIN=$ORDER(^TMP("LRAR-WL",$JOB,"DIV",LRLDIV,LRIN))
if ('LRIN)!(LREND)
QUIT
Begin DoDot:2
+5 SET LRINN=$SELECT($DATA(^LAR(64.19999,LRIN,0)):^(0),1:"UNDEFINED")
+6 SET (LRIGT,LRIGTU)=0
+7 SET LRGTREC=$GET(^TMP("LRAR-WL",$JOB,"DIV",LRLDIV,LRIN,0))
+8 IF $LENGTH(LRGTREC)
SET LRIGT=+$PIECE(LRGTREC,U)
SET LRIGTU=+$PIECE(LRGTREC,U,2)
+9 DO PRTDET
+10 if ('LREND)&(LRIGTU)
DO INSTSUM
End DoDot:2
End DoDot:1
if LREND
QUIT
+11 QUIT
PRTDET ; PRINT THE REPORT
+1 DO HDR^LRARCU
+2 WRITE !,?(80-$LENGTH(LRINN)\2),LRINN,!!
+3 SET LRMAA=""
+4 FOR
SET LRMAA=$ORDER(^TMP("LRAR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA))
if (LRMAA="")!($GET(LREND))
QUIT
Begin DoDot:1
+5 SET LRLSSA=""
+6 FOR
SET LRLSSA=$ORDER(^TMP("LRAR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA))
if (LRLSSA)=""!(LREND)
QUIT
DO LSS
if LREND
QUIT
End DoDot:1
+7 if LREND
QUIT
+8 IF $Y>(IOSL-5)
DO NPG^LRARCU
if LREND
QUIT
WRITE !,?(80-$LENGTH(LRINN)\2),LRINN,!!
+9 IF 'LRIGTU
Begin DoDot:1
+10 WRITE !!!,"NO DATA FOR THIS INSTITUTION AND DATE RANGE",!
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 WRITE !!!,"GRAND TOTAL",?52,$JUSTIFY(LRIGTU,7),?65,$JUSTIFY(LRIGT,9,2),!
End DoDot:1
+13 if ($EXTRACT(IOST,1,2)="C-")&('LREND)
DO PAUSE^LRARCU
WRITE @IOF
+14 QUIT
INSTSUM ;
+1 SET LRLAB="!!,?(80-7\2),""SUMMARY"",!,?(80-$L(LRINN)\2),LRINN,!!,""MAJOR SECTION"",?15,""LAB SUBSECTION"",?31,""UNIT COUNT"",?45,"" %"",?55,""TOTAL COST"",?70,"" %"",!"
+2 DO HDR^LRARCU
WRITE @LRLAB
+3 SET LRMAA=""
+4 FOR
SET LRMAA=$ORDER(^TMP("LRAR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA))
if (LRMAA="")!(LREND)
QUIT
Begin DoDot:1
+5 SET LRLSSA=""
+6 FOR
SET LRLSSA=$ORDER(^TMP("LRAR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA))
if (LRLSSA="")!(LREND)
QUIT
DO PSUM
End DoDot:1
+7 IF $Y>(IOSL-4)
DO NPG^LRARCU
if LREND
QUIT
WRITE @LRLAB
+8 WRITE !!,"GRAND TOTAL",?31,$JUSTIFY(LRIGTU,7),?55,$JUSTIFY(LRIGT,9,2)
+9 if ($EXTRACT(IOST,1,2)="C-")&('LREND)
DO PAUSE^LRARCU
WRITE @IOF
+10 QUIT
PSUM ;
+1 if LREND
QUIT
+2 SET LRX=$GET(^TMP("LRAR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0))
+3 if '$LENGTH(LRX)
QUIT
+4 IF $Y>(IOSL-3)
DO NPG^LRARCU
if LREND
QUIT
WRITE @LRLAB
+5 WRITE !,$EXTRACT(LRMAN(LRMAA),1,14),?15,$EXTRACT(LRLSSN(LRLSSA),1,15)
+6 WRITE ?31,$JUSTIFY($PIECE(LRX,U,2),7),?45,$JUSTIFY($PIECE(LRX,U,2)/LRIGTU*100,5,1)
+7 WRITE ?55,$JUSTIFY($PIECE(LRX,U,1),9,2)
+8 WRITE ?70,$JUSTIFY($PIECE(LRX,U)/$SELECT(LRIGT=0:1,1:LRIGT)*100,5,1),!
+9 QUIT
LSS ;
+1 SET LRLAB="!!,""MAJOR SECTION: "",LRMAN(LRMAA),!,""LAB SUBSECTION: "",LRLSSN(LRLSSA),!!,""CODE"",?11,""PROCEDURE"",?42,""UNIT COST"",?53,""UNIT COUNT"",?65,""TOTAL COST"",?70,"" %"",!"
+2 IF $Y>(IOSL-7)
DO NPG^LRARCU
if LREND
QUIT
WRITE !,?(80-$LENGTH(LRINN)\2),LRINN,!
+3 WRITE @LRLAB
+4 SET LRX=$GET(^TMP("LRAR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0))
+5 SET LRST=$PIECE(LRX,U)
SET LRSTU=$PIECE(LRX,U,2)
+6 SET LRCC=0
+7 FOR
SET LRCC=$ORDER(^TMP("LRAR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCC))
if (LRCC="")!(LREND)
QUIT
DO PCC
+8 if LREND
QUIT
+9 IF $Y>(IOSL-4)
DO NPG^LRARCU
if LREND
QUIT
WRITE !,?(80-$LENGTH(LRINN)\2),LRINN,!,@LRLAB
+10 WRITE !,?40,"SUB TOTAL",?52,$JUSTIFY(LRSTU,7),?65,$JUSTIFY(LRST,9,2)
+11 QUIT
PCC ;
+1 SET LRX=$GET(^TMP("LRAR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCC))
+2 IF $Y+3>IOSL
DO NPG^LRARCU
if LREND
QUIT
WRITE !,?(80-$LENGTH(LRINN)\2),LRINN,!,@LRLAB
+3 WRITE $PIECE(LRX,"^",4),?11,$EXTRACT(LRCC,1,30),?43,$JUSTIFY(+$PIECE(LRX,"^",3),6,2)_$SELECT($PIECE(LRX,"^",3)["*":"*",1:"")
+4 WRITE ?52,$JUSTIFY(+$PIECE(LRX,"^"),7),?65,$JUSTIFY(+$PIECE(LRX,"^",2),9,2)
+5 WRITE ?75,$JUSTIFY($PIECE(LRX,U)/$SELECT(LRSTU=0:1,1:LRSTU)*100,5,1),!
+6 QUIT
