LRCAPAM9 ;DALISC/FHS - RCS 14-4 REPORT LMIP SUPPLEMENT PAGE PRINT ;5/10/93
;;5.2;LAB SERVICE;**201**;Sep 27, 1994
EN ;
PRNTSUM ;
S LRMT=0
F S LRMT=$O(^TMP($J,"LMIP",LRMT)) Q:LRMT<1 S LRMTP=$$FMTE^XLFDT(LRMT,"1D") 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-" 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[HLRCAPAM9 2121 printed Sep 23, 2025@19:48:23 Page 2
LRCAPAM9 ;DALISC/FHS - RCS 14-4 REPORT LMIP SUPPLEMENT PAGE PRINT ;5/10/93
+1 ;;5.2;LAB SERVICE;**201**;Sep 27, 1994
EN ;
PRNTSUM ;
+1 SET LRMT=0
+2 FOR
SET LRMT=$ORDER(^TMP($JOB,"LMIP",LRMT))
if LRMT<1
QUIT
SET LRMTP=$$FMTE^XLFDT(LRMT,"1D")
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-"
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
