LRRP5A ;DALISC/JBM - COLLECTION REPORT-PRINT ;10/20/92
;;5.2;LAB SERVICE;**201**;Sep 27, 1994
EN ;
PRINT ;
W:$E(IOST,1,2)="C-" @IOF
I LRRPT=1 D
.D DET
.Q:LREND
.D:$E(IOST,1,2)="C-" PAUSE Q:LREND W @IOF
Q:LREND
D SUM Q:LREND
W !!?23,"*** END OF REPORT ***"
Q
DET ;
F I=1:1:80 S $P(LRBLANK," ",80)=" "
D HDR
S LRPAT="",LRPATCNT=0
F S LRPAT=$O(^TMP($J,"PAT",LRPAT)) Q:(LRPAT="")!(LREND) D
.S LRSSN=""
.F S LRSSN=$O(^TMP($J,"PAT",LRPAT,LRSSN)) Q:(LRSSN="")!(LREND) D
..S LRLCNT=0 K LRBUF
..S LRORD="",LRPATCNT=LRPATCNT+1,LRTGLNAM=1
..F S LRORD=$O(^TMP($J,"PAT",LRPAT,LRSSN,LRORD)) Q:(LRORD="")!(LREND) D
...S LRCS1="",LRTGLORD=1
...F S LRCS1=$O(^TMP($J,"PAT",LRPAT,LRSSN,LRORD,LRCS1)) Q:(LRCS1="")!(LREND) D
....S LRLOC=$P(^TMP($J,"PAT",LRPAT,LRSSN,LRORD,LRCS1,0),U,2)
....S LRCLCTD=$P(^TMP($J,"PAT",LRPAT,LRSSN,LRORD,LRCS1,0),U,3)
....I LRTGLNAM D
.....S LRLCNT=LRLCNT+1,LRBUF(LRLCNT)=$E(LRPAT_LRBLANK,1,18)_" "_LRSSN
.....S LRTGLNAM=0
....S LRLCNT=LRLCNT+1
....I LRTGLORD D
.....S LRBUF(LRLCNT)=" "_$E(LRORD_LRBLANK,1,9)
.....S LRTGLORD=0
....E S LRBUF(LRLCNT)=$E(LRBLANK,1,11)
....S LRBUF(LRLCNT)=LRBUF(LRLCNT)_$E(LRLOC_LRBLANK,1,7)_" "
....S LRBUF(LRLCNT)=LRBUF(LRLCNT)_$E(LRCS1_LRBLANK,1,10)_" "_LRCLCTD
....S LRTAB="",LRTN=0
....F S LRTN=$O(^TMP($J,"PAT",LRPAT,LRSSN,LRORD,LRCS1,LRTN)) Q:(LRTN="")!(LREND) D
.....S LRTST=$E((^TMP($J,"PAT",LRPAT,LRSSN,LRORD,LRCS1,LRTN)_" "),1,10)
.....I $L(LRBUF(LRLCNT))>70 D
......S LRLCNT=LRLCNT+1,LRBUF(LRLCNT)=""
......S LRTAB=$E(LRBLANK,1,22)
.....S LRBUF(LRLCNT)=LRBUF(LRLCNT)_LRTAB_LRTST
.....S LRTAB=" "
..D PRNTBUF
..Q:LREND
Q:LREND
I ($Y>(IOSL-7)) D:$E(IOST,1,2)="C-" PAUSE Q:LREND W @IOF D HDR
F I=$Y:1:(IOSL-6) W !
W "NUMBER OF PATIENTS LISTED : ",LRPATCNT
Q
PRNTBUF ;
I ((LRLCNT+$Y)>(IOSL-6))&($Y>7) D
.D:$E(IOST,1,2)="C-" PAUSE Q:LREND
.W @IOF D HDR
Q:LREND
F L=1:1:LRLCNT Q:LREND D
.I ($Y>(IOSL-6)) D
..D:$E(IOST,1,2)="C-" PAUSE Q:LREND W @IOF D HDR
..W !,$E(LRPAT,1,18),?20,LRSSN,?35,"*CONT*"
.Q:LREND
.W !,LRBUF(L)
Q:LREND
W !
Q
SUM ;
N LRN,LRC,LRU,LRP,LRREC,LRLOC,LRGN,LRGC,LRGU,LRGP,I
S (LRGN,LRGC,LRGU,LRGP)=0
D SUMHDR
S LRLOC=""
F S LRLOC=$O(^TMP($J,"LOCTOT",LRLOC)) Q:(LRLOC="")!(LREND) D
.S LRREC=$G(^TMP($J,"LOCTOT",LRLOC,0))
.Q:'$L(LRREC)
.S LRN=+$P(LRREC,U),LRC=+$P(LRREC,U,2)
.S LRU=+$P(LRREC,U,3),LRP=+$P(LRREC,U,4)
.S LRGN=LRGN+LRN,LRGC=LRGC+LRC,LRGU=LRGU+LRU,LRGP=LRGP+LRP
.I ($Y>(IOSL-6)) D
..D:$E(IOST,1,2)="C-" PAUSE Q:LREND W @IOF D SUMHDR
.Q:LREND
.W LRLOC,?10,$J(LRN,8),?20,$J(LRC,9),?31,$J(LRU,11),?44,$J(LRP,11),!
Q:LREND
F I=1:1:80 W "-"
W !
W "TOTAL",?10,$J(LRGN,8),?20,$J(LRGC,9)
W ?31,$J(LRGU,11),?44,$J(LRGP,11),!
Q
SUMHDR ;
N I
S LRPAG=LRPAG+1 F I=1:1:80 W "-"
W !,"LAB ORDERS BY COLLECTION TYPE"
W !,LRRCNAM," ORDERS ON "
W LRODAT," -- SUMMARY",?62,LRDAT,?72," PAGE ",LRPAG,!
W !?44,"Partially",!
W "Location",?10,"Patients",?20,"Collected",?31,"Uncollected"
W ?44,"Collected",!
F I=1:1:80 W "-"
W !
Q
HDR ;
S (LRTGLNAM,LRTGLORD)=1,LRPAG=LRPAG+1 F I=1:1:80 W "-"
W !,"LAB ORDERS BY COLLECTION TYPE"
W !,LRRCNAM," ORDERS ON "
W LRODAT,?(62),LRDAT,?(72)," PAGE ",LRPAG
W !!,"Name",?20,"SSN",!?2,"Order #",?11,"Location",?20,"Coll Sample"
W ?34,"Tests",! F I=1:1:80 W "-"
Q
PAUSE ;
K DIR S DIR(0)="E" D ^DIR
S:($D(DTOUT)#2)!($D(DUOUT)#2)!($D(DIRUT)#2) LREND=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRRP5A 3483 printed Apr 09, 2024@21:20:43 Page 2
LRRP5A ;DALISC/JBM - COLLECTION REPORT-PRINT ;10/20/92
+1 ;;5.2;LAB SERVICE;**201**;Sep 27, 1994
EN ;
PRINT ;
+1 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+2 IF LRRPT=1
Begin DoDot:1
+3 DO DET
+4 if LREND
QUIT
+5 if $EXTRACT(IOST,1,2)="C-"
DO PAUSE
if LREND
QUIT
WRITE @IOF
End DoDot:1
+6 if LREND
QUIT
+7 DO SUM
if LREND
QUIT
+8 WRITE !!?23,"*** END OF REPORT ***"
+9 QUIT
DET ;
+1 FOR I=1:1:80
SET $PIECE(LRBLANK," ",80)=" "
+2 DO HDR
+3 SET LRPAT=""
SET LRPATCNT=0
+4 FOR
SET LRPAT=$ORDER(^TMP($JOB,"PAT",LRPAT))
if (LRPAT="")!(LREND)
QUIT
Begin DoDot:1
+5 SET LRSSN=""
+6 FOR
SET LRSSN=$ORDER(^TMP($JOB,"PAT",LRPAT,LRSSN))
if (LRSSN="")!(LREND)
QUIT
Begin DoDot:2
+7 SET LRLCNT=0
KILL LRBUF
+8 SET LRORD=""
SET LRPATCNT=LRPATCNT+1
SET LRTGLNAM=1
+9 FOR
SET LRORD=$ORDER(^TMP($JOB,"PAT",LRPAT,LRSSN,LRORD))
if (LRORD="")!(LREND)
QUIT
Begin DoDot:3
+10 SET LRCS1=""
SET LRTGLORD=1
+11 FOR
SET LRCS1=$ORDER(^TMP($JOB,"PAT",LRPAT,LRSSN,LRORD,LRCS1))
if (LRCS1="")!(LREND)
QUIT
Begin DoDot:4
+12 SET LRLOC=$PIECE(^TMP($JOB,"PAT",LRPAT,LRSSN,LRORD,LRCS1,0),U,2)
+13 SET LRCLCTD=$PIECE(^TMP($JOB,"PAT",LRPAT,LRSSN,LRORD,LRCS1,0),U,3)
+14 IF LRTGLNAM
Begin DoDot:5
+15 SET LRLCNT=LRLCNT+1
SET LRBUF(LRLCNT)=$EXTRACT(LRPAT_LRBLANK,1,18)_" "_LRSSN
+16 SET LRTGLNAM=0
End DoDot:5
+17 SET LRLCNT=LRLCNT+1
+18 IF LRTGLORD
Begin DoDot:5
+19 SET LRBUF(LRLCNT)=" "_$EXTRACT(LRORD_LRBLANK,1,9)
+20 SET LRTGLORD=0
End DoDot:5
+21 IF '$TEST
SET LRBUF(LRLCNT)=$EXTRACT(LRBLANK,1,11)
+22 SET LRBUF(LRLCNT)=LRBUF(LRLCNT)_$EXTRACT(LRLOC_LRBLANK,1,7)_" "
+23 SET LRBUF(LRLCNT)=LRBUF(LRLCNT)_$EXTRACT(LRCS1_LRBLANK,1,10)_" "_LRCLCTD
+24 SET LRTAB=""
SET LRTN=0
+25 FOR
SET LRTN=$ORDER(^TMP($JOB,"PAT",LRPAT,LRSSN,LRORD,LRCS1,LRTN))
if (LRTN="")!(LREND)
QUIT
Begin DoDot:5
+26 SET LRTST=$EXTRACT((^TMP($JOB,"PAT",LRPAT,LRSSN,LRORD,LRCS1,LRTN)_" "),1,10)
+27 IF $LENGTH(LRBUF(LRLCNT))>70
Begin DoDot:6
+28 SET LRLCNT=LRLCNT+1
SET LRBUF(LRLCNT)=""
+29 SET LRTAB=$EXTRACT(LRBLANK,1,22)
End DoDot:6
+30 SET LRBUF(LRLCNT)=LRBUF(LRLCNT)_LRTAB_LRTST
+31 SET LRTAB=" "
End DoDot:5
End DoDot:4
End DoDot:3
+32 DO PRNTBUF
+33 if LREND
QUIT
End DoDot:2
End DoDot:1
+34 if LREND
QUIT
+35 IF ($Y>(IOSL-7))
if $EXTRACT(IOST,1,2)="C-"
DO PAUSE
if LREND
QUIT
WRITE @IOF
DO HDR
+36 FOR I=$Y:1:(IOSL-6)
WRITE !
+37 WRITE "NUMBER OF PATIENTS LISTED : ",LRPATCNT
+38 QUIT
PRNTBUF ;
+1 IF ((LRLCNT+$Y)>(IOSL-6))&($Y>7)
Begin DoDot:1
+2 if $EXTRACT(IOST,1,2)="C-"
DO PAUSE
if LREND
QUIT
+3 WRITE @IOF
DO HDR
End DoDot:1
+4 if LREND
QUIT
+5 FOR L=1:1:LRLCNT
if LREND
QUIT
Begin DoDot:1
+6 IF ($Y>(IOSL-6))
Begin DoDot:2
+7 if $EXTRACT(IOST,1,2)="C-"
DO PAUSE
if LREND
QUIT
WRITE @IOF
DO HDR
+8 WRITE !,$EXTRACT(LRPAT,1,18),?20,LRSSN,?35,"*CONT*"
End DoDot:2
+9 if LREND
QUIT
+10 WRITE !,LRBUF(L)
End DoDot:1
+11 if LREND
QUIT
+12 WRITE !
+13 QUIT
SUM ;
+1 NEW LRN,LRC,LRU,LRP,LRREC,LRLOC,LRGN,LRGC,LRGU,LRGP,I
+2 SET (LRGN,LRGC,LRGU,LRGP)=0
+3 DO SUMHDR
+4 SET LRLOC=""
+5 FOR
SET LRLOC=$ORDER(^TMP($JOB,"LOCTOT",LRLOC))
if (LRLOC="")!(LREND)
QUIT
Begin DoDot:1
+6 SET LRREC=$GET(^TMP($JOB,"LOCTOT",LRLOC,0))
+7 if '$LENGTH(LRREC)
QUIT
+8 SET LRN=+$PIECE(LRREC,U)
SET LRC=+$PIECE(LRREC,U,2)
+9 SET LRU=+$PIECE(LRREC,U,3)
SET LRP=+$PIECE(LRREC,U,4)
+10 SET LRGN=LRGN+LRN
SET LRGC=LRGC+LRC
SET LRGU=LRGU+LRU
SET LRGP=LRGP+LRP
+11 IF ($Y>(IOSL-6))
Begin DoDot:2
+12 if $EXTRACT(IOST,1,2)="C-"
DO PAUSE
if LREND
QUIT
WRITE @IOF
DO SUMHDR
End DoDot:2
+13 if LREND
QUIT
+14 WRITE LRLOC,?10,$JUSTIFY(LRN,8),?20,$JUSTIFY(LRC,9),?31,$JUSTIFY(LRU,11),?44,$JUSTIFY(LRP,11),!
End DoDot:1
+15 if LREND
QUIT
+16 FOR I=1:1:80
WRITE "-"
+17 WRITE !
+18 WRITE "TOTAL",?10,$JUSTIFY(LRGN,8),?20,$JUSTIFY(LRGC,9)
+19 WRITE ?31,$JUSTIFY(LRGU,11),?44,$JUSTIFY(LRGP,11),!
+20 QUIT
SUMHDR ;
+1 NEW I
+2 SET LRPAG=LRPAG+1
FOR I=1:1:80
WRITE "-"
+3 WRITE !,"LAB ORDERS BY COLLECTION TYPE"
+4 WRITE !,LRRCNAM," ORDERS ON "
+5 WRITE LRODAT," -- SUMMARY",?62,LRDAT,?72," PAGE ",LRPAG,!
+6 WRITE !?44,"Partially",!
+7 WRITE "Location",?10,"Patients",?20,"Collected",?31,"Uncollected"
+8 WRITE ?44,"Collected",!
+9 FOR I=1:1:80
WRITE "-"
+10 WRITE !
+11 QUIT
HDR ;
+1 SET (LRTGLNAM,LRTGLORD)=1
SET LRPAG=LRPAG+1
FOR I=1:1:80
WRITE "-"
+2 WRITE !,"LAB ORDERS BY COLLECTION TYPE"
+3 WRITE !,LRRCNAM," ORDERS ON "
+4 WRITE LRODAT,?(62),LRDAT,?(72)," PAGE ",LRPAG
+5 WRITE !!,"Name",?20,"SSN",!?2,"Order #",?11,"Location",?20,"Coll Sample"
+6 WRITE ?34,"Tests",!
FOR I=1:1:80
WRITE "-"
+7 QUIT
PAUSE ;
+1 KILL DIR
SET DIR(0)="E"
DO ^DIR
+2 if ($DATA(DTOUT)#2)!($DATA(DUOUT)#2)!($DATA(DIRUT)#2)
SET LREND=1
+3 QUIT
