- LRCAPAM8 ;DALISC/J0 - RCS 14-4 REPORT LMIP PAGE PRINT ;5/10/93
- ;;5.2;LAB SERVICE;**201**;Sep 27, 1994
- EN ;
- PRNTSUM ;
- N LRDSHS,LRHDR
- S $P(LRDSHS,"-",245)="-"
- S LRMT=0,LRPRD=$TR($$FMTE^XLFDT($$NOW^XLFDT,"1M"),"@"," ")
- F S LRMT=$O(^TMP($J,"LMIP",LRMT)) Q:LRMT<1 S LRMTP=$$FMTE^XLFDT(LRMT,"1D") 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 ^LRCAPAM9
- 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 ?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[HLRCAPAM8 2750 printed Feb 18, 2025@23:38:35 Page 2
- LRCAPAM8 ;DALISC/J0 - RCS 14-4 REPORT LMIP PAGE PRINT ;5/10/93
- +1 ;;5.2;LAB SERVICE;**201**;Sep 27, 1994
- EN ;
- PRNTSUM ;
- +1 NEW LRDSHS,LRHDR
- +2 SET $PIECE(LRDSHS,"-",245)="-"
- +3 SET LRMT=0
- SET LRPRD=$TRANSLATE($$FMTE^XLFDT($$NOW^XLFDT,"1M"),"@"," ")
- +4 FOR
- SET LRMT=$ORDER(^TMP($JOB,"LMIP",LRMT))
- if LRMT<1
- QUIT
- SET LRMTP=$$FMTE^XLFDT(LRMT,"1D")
- 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 ^LRCAPAM9
- +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-"
- 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