- LRARCAM9 ;DALISC/CKA - ARCHIVED RCS 14-4 REPORT LMIP SUPPLEMENT PAGE PRINT ;5/23/95
- ;;5.2;LAB SERVICE;**59**;Aug 31, 1995
- ;same as LRCAPAM9 except archived wkld file
- EN ;
- PRNTSUM ;
- S LRMT=0
- F S LRMT=$O(^TMP($J,"LMIP",LRMT)) Q:LRMT<1 S LRMTP=$$DTF^LRAFUNC1(LRMT) D Q:$G(LR("Q"))
- .W !,"LMIP SUPPLEMENTAL REPORT printed ",LRPRD
- .W !,LRHD0
- .W ?((132-($L(LRMTP)+$L($P(LRDA,U,2)))\2)),$P(LRDA,U,2)_" "_LRMTP
- .S LRPG=LRPG+1 W ?122,"Page ",LRPG,!
- .S LRHDR="Supplemental Pathology Laboratory Medicine Service Workload"
- .W !!,?(132-$L(LRHDR)\2),LRHDR,!
- .W !!,?32,"STD/Rep",?44,"Manual"
- .W ?56,"Micro",?68,"Micro",?80,"In-Pat",?92,"Others",!
- .W ?58,"In",?69,"Out",?80,"Stats",!
- .W $E(LRDSHS,1,132),!
- .D PRNTNAM
- Q
- PRNTNAM ;
- N LRRCNT,LRREC,LRLARE
- S LRRCNT=0
- W !,"Anatomic Pathology Division",!,$E(LRDSHS,1,27),!
- S LRLARE=0
- F S LRLARE=$O(^TMP($J,"LMIP",LRMT,"AP",LRLARE)) Q:LRLARE="" D
- .S LRREC=$G(^TMP($J,"LMIP",LRMT,"AP",LRLARE))
- .S LRRCNT=LRRCNT+1
- .W LRRCNT,?6,LRLARE
- .D PRNTREC
- .W !
- ;Write AP subtotals
- S LRLARE="AP subtotal"
- S LRREC=$G(^TMP($J,"LMIP",LRMT,"AP",0))
- W ?6,LRLARE
- D PRNTREC
- ;
- W !!,"Clinical Pathology Division",!,$E(LRDSHS,1,27),!
- S LRLARE=0
- F S LRLARE=$O(^TMP($J,"LMIP",LRMT,"CP",LRLARE)) Q:LRLARE="" D
- .S LRREC=$G(^TMP($J,"LMIP",LRMT,"CP",LRLARE))
- .S LRRCNT=LRRCNT+1
- .W LRRCNT,?6,LRLARE
- .D PRNTREC
- .W !
- ;Write CP subtotals
- S LRLARE="CP subtotal"
- S LRREC=$G(^TMP($J,"LMIP",LRMT,"CP",0))
- W ?6,LRLARE
- D PRNTREC
- ;Write grand totals
- W !
- W $E(LRDSHS,1,132),!
- S LRRCNT=LRRCNT+1,LRLARE="GRAND TOTAL"
- D EDIT1
- S LRREC=$G(^TMP($J,"LMIP",LRMT,"TOT-AP/CP"))
- W ?6,LRLARE
- D PRNTREC
- I $E(IOST,1,2)="C-",'$G(LR("Q")) D M^LRU Q:$G(LR("Q"))
- W @IOF
- Q
- PRNTREC ;
- W ?31,$J($P(LRREC,U,12),7),?43,$J($P(LRREC,U,13),7)
- W ?55,$J($P(LRREC,U,14),7),?67,$J($P(LRREC,U,15),7)
- W ?79,$J($P(LRREC,U,16),7),?91,$J($P(LRREC,U,17),7)
- Q
- EDIT1 ;
- N I,LRAPSUB,LRCAPSUB,LRGTOT
- S LRAPSUB=$G(^TMP($J,"LMIP",LRMT,"AP",0))
- S LRCPSUB=$G(^TMP($J,"LMIP",LRMT,"CP",0))
- F I=12:1:17 D
- . S LRGTOT=$P(LRAPSUB,U,I)+$P(LRCPSUB,U,I)
- . S $P(^TMP($J,"LMIP",LRMT,"TOT-AP/CP"),U,I)=LRGTOT
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRARCAM9 2185 printed Mar 13, 2025@21:13:21 Page 2
- LRARCAM9 ;DALISC/CKA - ARCHIVED RCS 14-4 REPORT LMIP SUPPLEMENT PAGE PRINT ;5/23/95
- +1 ;;5.2;LAB SERVICE;**59**;Aug 31, 1995
- +2 ;same as LRCAPAM9 except archived wkld file
- EN ;
- PRNTSUM ;
- +1 SET LRMT=0
- +2 FOR
- SET LRMT=$ORDER(^TMP($JOB,"LMIP",LRMT))
- if LRMT<1
- QUIT
- SET LRMTP=$$DTF^LRAFUNC1(LRMT)
- Begin DoDot:1
- +3 WRITE !,"LMIP SUPPLEMENTAL REPORT printed ",LRPRD
- +4 WRITE !,LRHD0
- +5 WRITE ?((132-($LENGTH(LRMTP)+$LENGTH($PIECE(LRDA,U,2)))\2)),$PIECE(LRDA,U,2)_" "_LRMTP
- +6 SET LRPG=LRPG+1
- WRITE ?122,"Page ",LRPG,!
- +7 SET LRHDR="Supplemental Pathology Laboratory Medicine Service Workload"
- +8 WRITE !!,?(132-$LENGTH(LRHDR)\2),LRHDR,!
- +9 WRITE !!,?32,"STD/Rep",?44,"Manual"
- +10 WRITE ?56,"Micro",?68,"Micro",?80,"In-Pat",?92,"Others",!
- +11 WRITE ?58,"In",?69,"Out",?80,"Stats",!
- +12 WRITE $EXTRACT(LRDSHS,1,132),!
- +13 DO PRNTNAM
- End DoDot:1
- if $GET(LR("Q"))
- QUIT
- +14 QUIT
- PRNTNAM ;
- +1 NEW LRRCNT,LRREC,LRLARE
- +2 SET LRRCNT=0
- +3 WRITE !,"Anatomic Pathology Division",!,$EXTRACT(LRDSHS,1,27),!
- +4 SET LRLARE=0
- +5 FOR
- SET LRLARE=$ORDER(^TMP($JOB,"LMIP",LRMT,"AP",LRLARE))
- if LRLARE=""
- QUIT
- Begin DoDot:1
- +6 SET LRREC=$GET(^TMP($JOB,"LMIP",LRMT,"AP",LRLARE))
- +7 SET LRRCNT=LRRCNT+1
- +8 WRITE LRRCNT,?6,LRLARE
- +9 DO PRNTREC
- +10 WRITE !
- End DoDot:1
- +11 ;Write AP subtotals
- +12 SET LRLARE="AP subtotal"
- +13 SET LRREC=$GET(^TMP($JOB,"LMIP",LRMT,"AP",0))
- +14 WRITE ?6,LRLARE
- +15 DO PRNTREC
- +16 ;
- +17 WRITE !!,"Clinical Pathology Division",!,$EXTRACT(LRDSHS,1,27),!
- +18 SET LRLARE=0
- +19 FOR
- SET LRLARE=$ORDER(^TMP($JOB,"LMIP",LRMT,"CP",LRLARE))
- if LRLARE=""
- QUIT
- Begin DoDot:1
- +20 SET LRREC=$GET(^TMP($JOB,"LMIP",LRMT,"CP",LRLARE))
- +21 SET LRRCNT=LRRCNT+1
- +22 WRITE LRRCNT,?6,LRLARE
- +23 DO PRNTREC
- +24 WRITE !
- End DoDot:1
- +25 ;Write CP subtotals
- +26 SET LRLARE="CP subtotal"
- +27 SET LRREC=$GET(^TMP($JOB,"LMIP",LRMT,"CP",0))
- +28 WRITE ?6,LRLARE
- +29 DO PRNTREC
- +30 ;Write grand totals
- +31 WRITE !
- +32 WRITE $EXTRACT(LRDSHS,1,132),!
- +33 SET LRRCNT=LRRCNT+1
- SET LRLARE="GRAND TOTAL"
- +34 DO EDIT1
- +35 SET LRREC=$GET(^TMP($JOB,"LMIP",LRMT,"TOT-AP/CP"))
- +36 WRITE ?6,LRLARE
- +37 DO PRNTREC
- +38 IF $EXTRACT(IOST,1,2)="C-"
- IF '$GET(LR("Q"))
- DO M^LRU
- if $GET(LR("Q"))
- QUIT
- +39 WRITE @IOF
- +40 QUIT
- PRNTREC ;
- +1 WRITE ?31,$JUSTIFY($PIECE(LRREC,U,12),7),?43,$JUSTIFY($PIECE(LRREC,U,13),7)
- +2 WRITE ?55,$JUSTIFY($PIECE(LRREC,U,14),7),?67,$JUSTIFY($PIECE(LRREC,U,15),7)
- +3 WRITE ?79,$JUSTIFY($PIECE(LRREC,U,16),7),?91,$JUSTIFY($PIECE(LRREC,U,17),7)
- +4 QUIT
- EDIT1 ;
- +1 NEW I,LRAPSUB,LRCAPSUB,LRGTOT
- +2 SET LRAPSUB=$GET(^TMP($JOB,"LMIP",LRMT,"AP",0))
- +3 SET LRCPSUB=$GET(^TMP($JOB,"LMIP",LRMT,"CP",0))
- +4 FOR I=12:1:17
- Begin DoDot:1
- +5 SET LRGTOT=$PIECE(LRAPSUB,U,I)+$PIECE(LRCPSUB,U,I)
- +6 SET $PIECE(^TMP($JOB,"LMIP",LRMT,"TOT-AP/CP"),U,I)=LRGTOT
- End DoDot:1
- +7 QUIT
