- LRRP5A ; IHS/DIR/AAB - COLLECTION REPORT-PRINT 10/20/92 ; [ 07/22/2002 1:39 PM ]
- ;;5.2;LR;**1006,1013**;JUL 15, 2002
- ;
- ;;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 "-"
- S LRPAG=LRPAG+1 ;F I=1:1:80 W "-" ;IHS/ANMC/CLS 08/18/96
- 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 "-"
- S (LRTGLNAM,LRTGLORD)=1,LRPAG=LRPAG+1 ;F I=1:1:80 W "-" ;IHS/ANMC/CLS 08/18/96
- 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 !!,"Name",?20,"HRCN",!?2,"Order #",?11,"Location",?20,"Coll Sample" ;IHS/ANMC/CLS 08/18/96
- 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
- LRRP5A ; IHS/DIR/AAB - COLLECTION REPORT-PRINT 10/20/92 ; [ 07/22/2002 1:39 PM ]
- +1 ;;5.2;LR;**1006,1013**;JUL 15, 2002
- +2 ;
- +3 ;;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 ;S LRPAG=LRPAG+1 F I=1:1:80 W "-"
- +3 ;F I=1:1:80 W "-" ;IHS/ANMC/CLS 08/18/96
- SET LRPAG=LRPAG+1
- +4 WRITE !,"LAB ORDERS BY COLLECTION TYPE"
- +5 WRITE !,LRRCNAM," ORDERS ON "
- +6 WRITE LRODAT," -- SUMMARY",?62,LRDAT,?72," PAGE ",LRPAG,!
- +7 WRITE !?44,"Partially",!
- +8 WRITE "Location",?10,"Patients",?20,"Collected",?31,"Uncollected"
- +9 WRITE ?44,"Collected",!
- +10 FOR I=1:1:80
- WRITE "-"
- +11 WRITE !
- +12 QUIT
- HDR ;
- +1 ;S (LRTGLNAM,LRTGLORD)=1,LRPAG=LRPAG+1 F I=1:1:80 W "-"
- +2 ;F I=1:1:80 W "-" ;IHS/ANMC/CLS 08/18/96
- SET (LRTGLNAM,LRTGLORD)=1
- SET LRPAG=LRPAG+1
- +3 WRITE !,"LAB ORDERS BY COLLECTION TYPE"
- +4 WRITE !,LRRCNAM," ORDERS ON "
- +5 WRITE LRODAT,?(62),LRDAT,?(72)," PAGE ",LRPAG
- +6 ;W !!,"Name",?20,"SSN",!?2,"Order #",?11,"Location",?20,"Coll Sample"
- +7 ;IHS/ANMC/CLS 08/18/96
- WRITE !!,"Name",?20,"HRCN",!?2,"Order #",?11,"Location",?20,"Coll Sample"
- +8 WRITE ?34,"Tests",!
- FOR I=1:1:80
- WRITE "-"
- +9 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
