- LRRP8C ;DALISC/TNN/J0 - WKLD STATS REPORT BY SHIFT ; 4/9/93
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- W !!,"ENTRY POINT IS AT EN^LRRP8." H 3 QUIT
- ;
- PRINT ;
- W:$E(IOST,1,2)="C-" @IOF
- S LRGCNT=+$G(^TMP("LR",$J,0))
- I 'LRGCNT W !," *** NO DATA FOR THIS REPORT ***",! Q
- D:LRRPT=1 DET Q:LREND
- D SUM Q:LREND
- D PRNTMAN^LRCAPMR1 Q:LREND
- D COMM^LRCAPMR2 Q:LREND
- Q
- DET ;
- S LRA=0
- F S LRA=$O(^TMP("LR",$J,"AA",LRA)) Q:('LRA)!(LREND) D
- . S LRANAM=$P($G(^LRO(68,LRA,0)),U)
- . D HDR^LRCAPU
- . W !,"Accession Area: ",LRANAM,!
- . S LRACNT=+$G(^TMP("LR",$J,"AA",LRA,0))
- . I 'LRACNT W !," *** NO DATA FOR THIS ACCESSION AREA ***",! Q
- . S LRSHFT=0
- . F S LRSHFT=$O(LRST(LRSHFT)) Q:('LRSHFT)!(LREND) D
- . . S LRCONT=0 D SHFTHDR S LRCONT=1
- . . S LRSCNT=+$G(^TMP("LR",$J,"AA",LRA,"SHFT",LRSHFT,0))
- . . I 'LRSCNT W !," *** NO DATA FOR THIS SHIFT ***",! Q
- . . S LRCAPNAM=""
- . . F S LRCAPNAM=$O(^TMP("LR",$J,"AA",LRA,"SHFT",LRSHFT,"CCN",LRCAPNAM)) Q:(LRCAPNAM="")!(LREND) D
- . . . S LRREC=$G(^TMP("LR",$J,"AA",LRA,"SHFT",LRSHFT,"CCN",LRCAPNAM,0))
- . . . S LRCCNT=+LRREC,LRCAPNUM=$P(LRREC,U,2)
- . . . S LRPCT=(LRCCNT/LRSCNT)*100
- . . . I $Y+7>IOSL D
- . . . . D NPG^LRCAPU Q:LREND
- . . . . W !,"Accession Area: ",LRANAM," (cont.)",!
- . . . . D SHFTHDR
- . . . Q:LREND
- . . . W $J(LRCCNT,7),?10,$E(LRCAPNAM,1,30),?42,LRCAPNUM
- . . . W ?53,$J(LRPCT,6,2),"%",!
- . . Q:LREND
- . . W "Shift subtotal: ",$J(LRSCNT,8),!
- . Q:LREND
- . D AASUM
- . Q:LREND
- . D:$E(IOST,1,2)="C-" PAUSE^LRCAPU Q:LREND W @IOF
- Q
- AASUM ;*** Accession Area summary ***
- D NPG^LRCAPU Q:LREND W !,"Accession Area: ",LRANAM," (cont.)",!
- I LRSTFLG=1 D
- . W !
- . S LRSHFT=0
- . F S LRSHFT=$O(LRST(LRSHFT)) Q:('LRSHFT)!(LREND) D
- . . S LRSCNT=+$G(^TMP("LR",$J,"AA",LRA,"SHFT",LRSHFT,0))
- . . S LRPCT=(LRSCNT/LRACNT)*100
- . . W "Shift#",LRSHFT,": ",$J(LRPCT,6,2)
- . . W "% of ",LRANAM," total.",!
- . W !
- S LRCONT=0 D ACCHDR S LRCONT=1
- S LRCAPNAM=""
- F S LRCAPNAM=$O(^TMP("LR",$J,"AA",LRA,"CCN",LRCAPNAM)) Q:(LRCAPNAM="")!(LREND) D
- . S LRREC=$G(^TMP("LR",$J,"AA",LRA,"CCN",LRCAPNAM,0))
- . S LRCCNT=+LRREC,LRCAPNUM=$P(LRREC,U,2)
- . S LRPCT=(LRCCNT/LRACNT)*100
- . I $Y+5>IOSL D
- . . D NPG^LRCAPU Q:LREND
- . . W !,"Accession Area: ",LRANAM," (cont.)",!
- . . D ACCHDR
- . Q:LREND
- . W $J(LRCCNT,7),?10,$E(LRCAPNAM,1,30),?42,LRCAPNUM
- . W ?53,$J(LRPCT,6,2),"%",!
- Q:LREND
- W !,LRANAM," subtotal: ",$J(LRACNT,8),!
- Q
- SUM ;
- D HDR^LRCAPU
- S LRCONT=0 D SUMHDR S LRCONT=1
- S LRA=0
- F S LRA=$O(^TMP("LR",$J,"AA",LRA)) Q:('LRA)!(LREND) D
- . S LRANAM=$P($G(^LRO(68,LRA,0)),U)
- . S LRACNT=+$G(^TMP("LR",$J,"AA",LRA,0))
- . S LRPCT=(LRACNT/LRGCNT)*100
- . I $Y+7>IOSL D
- . . D NPG^LRCAPU Q:LREND
- . . D SUMHDR
- . Q:LREND
- . W $J(LRACNT,8),?10,LRANAM,?42,$J(LRPCT,6,2),"% of grand total.",!
- Q:LREND
- W !,"Grand Total: ",$J(LRGCNT,8),!
- D:$E(IOST,1,2)="C-" PAUSE^LRCAPU Q:LREND W @IOF
- Q
- SHFTHDR ;
- I LRSTFLG=1 D
- . W !!,"SHIFT#",LRSHFT," FROM: ",$P(LRST(LRSHFT),"^")," Hours TO: "
- . W $P(LRST(LRSHFT),"^",2)," Hours." W:LRCONT " (cont.)" W !
- E D
- . W !!,"TIME RANGE FROM: ",$P(LRST(LRSHFT),"^")," Hours TO: "
- . W $P(LRST(LRSHFT),"^",2)," Hours." W:LRCONT " (cont.)" W !
- W !," Count Procedure Name Code "
- W "Percent of shift subtotal",!
- W $E(LRDSHS,1,80),!
- Q
- ACCHDR ;
- W !,"Total count for each type of WKLD code:" W:LRCONT " (cont.)" W !
- W !," Count Procedure Name Code "
- W "Pct of Acc. area subtotal",!
- W $E(LRDSHS,1,80),!
- Q
- SUMHDR ;
- W !,"Summary by Accession Area:" W:LRCONT " (cont.)" W !
- W !," Count Accession Area "
- W "Percent of grand total",!
- W $E(LRDSHS,1,80),!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRRP8C 3732 printed Feb 18, 2025@23:45:59 Page 2
- LRRP8C ;DALISC/TNN/J0 - WKLD STATS REPORT BY SHIFT ; 4/9/93
- +1 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +2 WRITE !!,"ENTRY POINT IS AT EN^LRRP8."
- HANG 3
- QUIT
- +3 ;
- PRINT ;
- +1 if $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- +2 SET LRGCNT=+$GET(^TMP("LR",$JOB,0))
- +3 IF 'LRGCNT
- WRITE !," *** NO DATA FOR THIS REPORT ***",!
- QUIT
- +4 if LRRPT=1
- DO DET
- if LREND
- QUIT
- +5 DO SUM
- if LREND
- QUIT
- +6 DO PRNTMAN^LRCAPMR1
- if LREND
- QUIT
- +7 DO COMM^LRCAPMR2
- if LREND
- QUIT
- +8 QUIT
- DET ;
- +1 SET LRA=0
- +2 FOR
- SET LRA=$ORDER(^TMP("LR",$JOB,"AA",LRA))
- if ('LRA)!(LREND)
- QUIT
- Begin DoDot:1
- +3 SET LRANAM=$PIECE($GET(^LRO(68,LRA,0)),U)
- +4 DO HDR^LRCAPU
- +5 WRITE !,"Accession Area: ",LRANAM,!
- +6 SET LRACNT=+$GET(^TMP("LR",$JOB,"AA",LRA,0))
- +7 IF 'LRACNT
- WRITE !," *** NO DATA FOR THIS ACCESSION AREA ***",!
- QUIT
- +8 SET LRSHFT=0
- +9 FOR
- SET LRSHFT=$ORDER(LRST(LRSHFT))
- if ('LRSHFT)!(LREND)
- QUIT
- Begin DoDot:2
- +10 SET LRCONT=0
- DO SHFTHDR
- SET LRCONT=1
- +11 SET LRSCNT=+$GET(^TMP("LR",$JOB,"AA",LRA,"SHFT",LRSHFT,0))
- +12 IF 'LRSCNT
- WRITE !," *** NO DATA FOR THIS SHIFT ***",!
- QUIT
- +13 SET LRCAPNAM=""
- +14 FOR
- SET LRCAPNAM=$ORDER(^TMP("LR",$JOB,"AA",LRA,"SHFT",LRSHFT,"CCN",LRCAPNAM))
- if (LRCAPNAM="")!(LREND)
- QUIT
- Begin DoDot:3
- +15 SET LRREC=$GET(^TMP("LR",$JOB,"AA",LRA,"SHFT",LRSHFT,"CCN",LRCAPNAM,0))
- +16 SET LRCCNT=+LRREC
- SET LRCAPNUM=$PIECE(LRREC,U,2)
- +17 SET LRPCT=(LRCCNT/LRSCNT)*100
- +18 IF $Y+7>IOSL
- Begin DoDot:4
- +19 DO NPG^LRCAPU
- if LREND
- QUIT
- +20 WRITE !,"Accession Area: ",LRANAM," (cont.)",!
- +21 DO SHFTHDR
- End DoDot:4
- +22 if LREND
- QUIT
- +23 WRITE $JUSTIFY(LRCCNT,7),?10,$EXTRACT(LRCAPNAM,1,30),?42,LRCAPNUM
- +24 WRITE ?53,$JUSTIFY(LRPCT,6,2),"%",!
- End DoDot:3
- +25 if LREND
- QUIT
- +26 WRITE "Shift subtotal: ",$JUSTIFY(LRSCNT,8),!
- End DoDot:2
- +27 if LREND
- QUIT
- +28 DO AASUM
- +29 if LREND
- QUIT
- +30 if $EXTRACT(IOST,1,2)="C-"
- DO PAUSE^LRCAPU
- if LREND
- QUIT
- WRITE @IOF
- End DoDot:1
- +31 QUIT
- AASUM ;*** Accession Area summary ***
- +1 DO NPG^LRCAPU
- if LREND
- QUIT
- WRITE !,"Accession Area: ",LRANAM," (cont.)",!
- +2 IF LRSTFLG=1
- Begin DoDot:1
- +3 WRITE !
- +4 SET LRSHFT=0
- +5 FOR
- SET LRSHFT=$ORDER(LRST(LRSHFT))
- if ('LRSHFT)!(LREND)
- QUIT
- Begin DoDot:2
- +6 SET LRSCNT=+$GET(^TMP("LR",$JOB,"AA",LRA,"SHFT",LRSHFT,0))
- +7 SET LRPCT=(LRSCNT/LRACNT)*100
- +8 WRITE "Shift#",LRSHFT,": ",$JUSTIFY(LRPCT,6,2)
- +9 WRITE "% of ",LRANAM," total.",!
- End DoDot:2
- +10 WRITE !
- End DoDot:1
- +11 SET LRCONT=0
- DO ACCHDR
- SET LRCONT=1
- +12 SET LRCAPNAM=""
- +13 FOR
- SET LRCAPNAM=$ORDER(^TMP("LR",$JOB,"AA",LRA,"CCN",LRCAPNAM))
- if (LRCAPNAM="")!(LREND)
- QUIT
- Begin DoDot:1
- +14 SET LRREC=$GET(^TMP("LR",$JOB,"AA",LRA,"CCN",LRCAPNAM,0))
- +15 SET LRCCNT=+LRREC
- SET LRCAPNUM=$PIECE(LRREC,U,2)
- +16 SET LRPCT=(LRCCNT/LRACNT)*100
- +17 IF $Y+5>IOSL
- Begin DoDot:2
- +18 DO NPG^LRCAPU
- if LREND
- QUIT
- +19 WRITE !,"Accession Area: ",LRANAM," (cont.)",!
- +20 DO ACCHDR
- End DoDot:2
- +21 if LREND
- QUIT
- +22 WRITE $JUSTIFY(LRCCNT,7),?10,$EXTRACT(LRCAPNAM,1,30),?42,LRCAPNUM
- +23 WRITE ?53,$JUSTIFY(LRPCT,6,2),"%",!
- End DoDot:1
- +24 if LREND
- QUIT
- +25 WRITE !,LRANAM," subtotal: ",$JUSTIFY(LRACNT,8),!
- +26 QUIT
- SUM ;
- +1 DO HDR^LRCAPU
- +2 SET LRCONT=0
- DO SUMHDR
- SET LRCONT=1
- +3 SET LRA=0
- +4 FOR
- SET LRA=$ORDER(^TMP("LR",$JOB,"AA",LRA))
- if ('LRA)!(LREND)
- QUIT
- Begin DoDot:1
- +5 SET LRANAM=$PIECE($GET(^LRO(68,LRA,0)),U)
- +6 SET LRACNT=+$GET(^TMP("LR",$JOB,"AA",LRA,0))
- +7 SET LRPCT=(LRACNT/LRGCNT)*100
- +8 IF $Y+7>IOSL
- Begin DoDot:2
- +9 DO NPG^LRCAPU
- if LREND
- QUIT
- +10 DO SUMHDR
- End DoDot:2
- +11 if LREND
- QUIT
- +12 WRITE $JUSTIFY(LRACNT,8),?10,LRANAM,?42,$JUSTIFY(LRPCT,6,2),"% of grand total.",!
- End DoDot:1
- +13 if LREND
- QUIT
- +14 WRITE !,"Grand Total: ",$JUSTIFY(LRGCNT,8),!
- +15 if $EXTRACT(IOST,1,2)="C-"
- DO PAUSE^LRCAPU
- if LREND
- QUIT
- WRITE @IOF
- +16 QUIT
- SHFTHDR ;
- +1 IF LRSTFLG=1
- Begin DoDot:1
- +2 WRITE !!,"SHIFT#",LRSHFT," FROM: ",$PIECE(LRST(LRSHFT),"^")," Hours TO: "
- +3 WRITE $PIECE(LRST(LRSHFT),"^",2)," Hours."
- if LRCONT
- WRITE " (cont.)"
- WRITE !
- End DoDot:1
- +4 IF '$TEST
- Begin DoDot:1
- +5 WRITE !!,"TIME RANGE FROM: ",$PIECE(LRST(LRSHFT),"^")," Hours TO: "
- +6 WRITE $PIECE(LRST(LRSHFT),"^",2)," Hours."
- if LRCONT
- WRITE " (cont.)"
- WRITE !
- End DoDot:1
- +7 WRITE !," Count Procedure Name Code "
- +8 WRITE "Percent of shift subtotal",!
- +9 WRITE $EXTRACT(LRDSHS,1,80),!
- +10 QUIT
- ACCHDR ;
- +1 WRITE !,"Total count for each type of WKLD code:"
- if LRCONT
- WRITE " (cont.)"
- WRITE !
- +2 WRITE !," Count Procedure Name Code "
- +3 WRITE "Pct of Acc. area subtotal",!
- +4 WRITE $EXTRACT(LRDSHS,1,80),!
- +5 QUIT
- SUMHDR ;
- +1 WRITE !,"Summary by Accession Area:"
- if LRCONT
- WRITE " (cont.)"
- WRITE !
- +2 WRITE !," Count Accession Area "
- +3 WRITE "Percent of grand total",!
- +4 WRITE $EXTRACT(LRDSHS,1,80),!
- +5 QUIT