- 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 Feb 18, 2025@23:35:04 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