LRARCAM8 ;DALISC/CKA - ARCHIVED RCS 14-4 REPORT LMIP PAGE PRINT ;5/25/95
;;5.2;LAB SERVICE;**59**;Aug 31, 1995
;same as LRCAPAM8 except archived wkld file
EN ;
PRNTSUM ;
N LRDSHS,LRHDR
S $P(LRDSHS,"-",245)="-"
S LRMT=0,LRPRD=$$DTF^LRAFUNC1($$NOW^LRAFUNC1)
F S LRMT=$O(^TMP($J,"LMIP",LRMT)) Q:LRMT<1 S LRMTP=$$DTF^LRAFUNC1(LRMT) D Q:$G(LR("Q"))
.W !,"LMIP 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="Pathology Laboratory Medicine Service Workload Summary"
.W !!,?(132-$L(LRHDR)\2),LRHDR,!
.W !!,"LINE SECTION",?28,"In-patient",?40,"Out-patient"
.W ?53,"Non-patient",?70,"Total",?77,"Quality",?87,"Total"
.W ?99,"Referred",?113,"Tests",!
.W "No.",?30,"Tests",?43,"Tests",?54,"""Other"""
.W ?70,"Tests",?77,"Control",?86,"On-site",?101,"Tests"
.W ?111,"Performed",?124,"Stat",!
.W ?55,"Tests",?67,"(Orderable)",?87,"Tests"
.W ?98,"(Send Outs)",?112,"On-site",?124,"Tests",!
.W $E(LRDSHS,1,132),!
.W "LMIP Data Number",?28," #5 ",?40," #6 "
.W ?53," #7 ",?66," #1 ",?86," #2 "
.W ?95," #4 ",?111," #3 ",?122," #8 ",!
.W $E(LRDSHS,1,132),!
.D PRNTNAM
SUP ;
D ^LRARCAM9
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 ?28,$J($P(LRREC,U),10),?40,$J($P(LRREC,U,2),11)
W ?53,$J($P(LRREC,U,3),11),?66,$J($P(LRREC,U,4),9)
W ?77,$J($P(LRREC,U,5),7),?86,$J($P(LRREC,U,6),7)
W ?95,$J($P(LRREC,U,7),14),?111,$J($P(LRREC,U,8),9)
W ?122,$J($P(LRREC,U,9),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=1:1:9 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[HLRARCAM8 2802 printed Dec 13, 2024@02:08:59 Page 2
LRARCAM8 ;DALISC/CKA - ARCHIVED RCS 14-4 REPORT LMIP PAGE PRINT ;5/25/95
+1 ;;5.2;LAB SERVICE;**59**;Aug 31, 1995
+2 ;same as LRCAPAM8 except archived wkld file
EN ;
PRNTSUM ;
+1 NEW LRDSHS,LRHDR
+2 SET $PIECE(LRDSHS,"-",245)="-"
+3 SET LRMT=0
SET LRPRD=$$DTF^LRAFUNC1($$NOW^LRAFUNC1)
+4 FOR
SET LRMT=$ORDER(^TMP($JOB,"LMIP",LRMT))
if LRMT<1
QUIT
SET LRMTP=$$DTF^LRAFUNC1(LRMT)
Begin DoDot:1
+5 WRITE !,"LMIP REPORT printed ",LRPRD
+6 WRITE !,LRHD0
+7 WRITE ?((132-($LENGTH(LRMTP)+$LENGTH($PIECE(LRDA,U,2)))\2)),$PIECE(LRDA,U,2)_" "_LRMTP
+8 SET LRPG=LRPG+1
WRITE ?122,"Page ",LRPG,!
+9 SET LRHDR="Pathology Laboratory Medicine Service Workload Summary"
+10 WRITE !!,?(132-$LENGTH(LRHDR)\2),LRHDR,!
+11 WRITE !!,"LINE SECTION",?28,"In-patient",?40,"Out-patient"
+12 WRITE ?53,"Non-patient",?70,"Total",?77,"Quality",?87,"Total"
+13 WRITE ?99,"Referred",?113,"Tests",!
+14 WRITE "No.",?30,"Tests",?43,"Tests",?54,"""Other"""
+15 WRITE ?70,"Tests",?77,"Control",?86,"On-site",?101,"Tests"
+16 WRITE ?111,"Performed",?124,"Stat",!
+17 WRITE ?55,"Tests",?67,"(Orderable)",?87,"Tests"
+18 WRITE ?98,"(Send Outs)",?112,"On-site",?124,"Tests",!
+19 WRITE $EXTRACT(LRDSHS,1,132),!
+20 WRITE "LMIP Data Number",?28," #5 ",?40," #6 "
+21 WRITE ?53," #7 ",?66," #1 ",?86," #2 "
+22 WRITE ?95," #4 ",?111," #3 ",?122," #8 ",!
+23 WRITE $EXTRACT(LRDSHS,1,132),!
+24 DO PRNTNAM
End DoDot:1
if $GET(LR("Q"))
QUIT
SUP ;
+1 DO ^LRARCAM9
+2 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 ?28,$JUSTIFY($PIECE(LRREC,U),10),?40,$JUSTIFY($PIECE(LRREC,U,2),11)
+2 WRITE ?53,$JUSTIFY($PIECE(LRREC,U,3),11),?66,$JUSTIFY($PIECE(LRREC,U,4),9)
+3 WRITE ?77,$JUSTIFY($PIECE(LRREC,U,5),7),?86,$JUSTIFY($PIECE(LRREC,U,6),7)
+4 WRITE ?95,$JUSTIFY($PIECE(LRREC,U,7),14),?111,$JUSTIFY($PIECE(LRREC,U,8),9)
+5 WRITE ?122,$JUSTIFY($PIECE(LRREC,U,9),7),!
+6 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=1:1:9
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
