LRSORC1A ;VA/DALISC/DRH - LRSORC Continued ;07-22-93
;;5.2;LAB SERVICE;**1031**;NOV 1, 1997
;
;;VA LR Patch(s): 201,344,351,384
;
INIT ;
S U="^"
D CONTROL
Q
CONTROL ;
D SORT
Q
SORT ;
W:$E(IOST,1,2)="C-" @IOF
W:$E(IOST,1,2)="P-" !
D HDR
D PRINT
D:'LREND SUMMARY
D END
Q
SUMMARY ;
I ($Y>(IOSL-7)) D:$E(IOST,1,2)="C-" WAIT Q:LREND W @IOF D HDR
F I=$Y:1:(IOSL-6) W !
W ?20,"END OF SPECIAL REPORT"
Q
END ;
D:($E(IOST,1,2)="C-")&('LREND) WAIT
W @IOF D:'$D(ZTQUEUED) ^%ZISC
K ^TMP("LR",$J)
K ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK,ZTQUEUED,%ZIS,POP,%H,%DT,DTOUT,DUOUT
K DIR,DIC,I,T,C,X,Y,L0,SEX,AGE,DFN,DOB,PNM,SSN,VA("BID"),VA("PID"),VAERR
K LRAA,LRAD,LRDFN,LRDPF,LREND,LRFAN,LRIDT,LRLAN,LRLCS,LRSUB1,LRSUB2
K LRLLOC,LRTX,LRTST,LRTVAL,LRCRTFLG,LRAN,LRSRT,LRPAG,LRDATE,LRDASH,LRDAT
K LRLOC,LRPTS,LREDT,LRPDT,LRSDT,LRTREC,LRPREC,LREDAT,LRSDAT,LRSPDAT
K LRWRD,LRHDR2,LRSUB3,LRAAA
K HRCN ;IHS/ANMC/CLS 08/18/96
Q
PRINT ;
S LRSUB1=""
I $O(^TMP("LR",$J,LRSUB1))="" W !!?30,"NO MATCHING DATA FOUND",!! Q
F S LRSUB1=$O(^TMP("LR",$J,LRSUB1)) Q:(LRSUB1="")!(LREND) D
.S LRSUB2=""
.F S LRSUB2=$O(^TMP("LR",$J,LRSUB1,LRSUB2)) Q:(LRSUB2="")!(LREND) D
..S LRSUB3=""
..F S LRSUB3=$O(^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3)) Q:(LRSUB3="")!(LREND) D
...S LRAN=""
...F S LRAN=$O(^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3,LRAN)) Q:(LRAN="")!(LREND) D
....S LRPREC=^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3,LRAN)
....S LRDPF=$P(LRPREC,U,4)
....; S PNM=$P(LRPREC,U),SSN=$P(LRPREC,U,2),LRLOC=$P(LRPREC,U,3)
....S PNM=$P(LRPREC,U),HRCN=$P(LRPREC,U,2),LRLOC=$P(LRPREC,U,3) ;IHS/ANMC/CLS 08/18/96
....S LRSPEC=$P(^LAB(61,$P(LRPREC,U,6),0),U)
....S LRSPNUM=$P(LRPREC,U,6)
....S LRSPDAT=$P(LRPREC,U,5)
....I ($Y>(IOSL-8)) D:$E(IOST,1,2)="C-" WAIT Q:LREND W @IOF D HDR
....;S PNM1=$P(PNM,","),PNM2=$P(PNM,",",2)
....;S LRCHNG=PNM1 D CHNCASE^LRSORA2 S PNM1=LRCHNG
....;S LRCHNG=PNM2 D CHNCASE^LRSORA2 S PNM2=LRCHNG
....;S PNM=PNM1_","_PNM2
....;S LRCHNG=LRSPEC D CHNCASE^LRSORA2 S LRSPEC=LRCHNG
....; W !,$E(PNM,1,22),?23,$E(SSN,1,11) W:LRDPF=2 ?35,$E(LRLOC,1,12),?48,$E(LRAN,1,14)
....W !,$E(PNM,1,23),?25,HRCN W:LRDPF=2 " ",LRLOC,?50,$E(LRAN,1,14) ;IHS/ANMC/CLS 08/18/96
....W ?63,LRSPDAT
....W !," ",LRSPEC
....D PRNTST
Q
PRNTST ;
N LRRLO,LRRHI,LRCLO,LRCHI,LRTLO,LRTHI,LRFLAG,VAR
S I=""
F S I=$O(^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3,LRAN,"TST",I)) Q:(I="")!(LREND) D
.S LRTREC=^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3,LRAN,"TST",I)
.S LRTST=$P(LRTREC,U),LRTVAL=$P(LRTREC,U,2),LRCRTFLG=$P(LRTREC,U,3)
.I ($Y>(IOSL-7)) D
..D CONT D:$E(IOST,1,2)="C-" WAIT Q:LREND
..W @IOF D HDR
..; W !,$E(PNM,1,22),?23,$E(SSN,1,11) W:LRDPF=2 ?35,$E(LRLOC,1,12),?48,$E(LRAN,1,14)
..W !,$E(PNM,1,23),?25,HRCN W:LRDPF=2 " ",LRLOC,?50,$E(LRAN,1,14) ;IHS/ANMC/CLS 08/18/96
..W ?63,LRSPDAT
.Q:LREND
.S LRTX=$P(LRTREC,U,5)
.S LRFLAG=$P(LRTREC,U,6)
.S LRREF=$G(^LAB(60,LRTX,1,LRSPNUM,0))
.; set ranges LRFLAG on - from file 63 LRFLAG off - from file 60
.S LRRLO=$S(LRFLAG:$P(LRTREC,U,7),1:$P(LRREF,U,2))
.S LRRHI=$S(LRFLAG:$P(LRTREC,U,8),1:$P(LRREF,U,3))
.S LRCLO=$S(LRFLAG:$P(LRTREC,U,9),1:$P(LRREF,U,4))
.S LRCHI=$S(LRFLAG:$P(LRTREC,U,10),1:$P(LRREF,U,5))
.S LRTLO=$S(LRFLAG:$P(LRTREC,U,11),1:$P(LRREF,U,11))
.S LRTHI=$S(LRFLAG:$P(LRTREC,U,12),1:$P(LRREF,U,12))
.F VAR="LRRLO","LRRHI","LRCLO","LRCHI" I @VAR="" S @VAR="none"
.;
.S LRTST=$P($G(^LAB(60,LRTX,.1)),U)
.I LRTST="" S LRTST=$E($P(^LAB(60,LRTX,0),U),1,10)
.;I 'LRTST S LRTST=$E($P(^LAB(60,LRTX,0),U),1,10)
.;S LRCHNG=LRTST D CHNCASE^LRSORA2 S LRTST=LRCHNG
.W !,?2,$E(LRTST,1,9),?12,$J(LRTVAL,6)
.W ?19,$E($P(LRREF,U,7),1,10),?28,LRCRTFLG
. I 'LRTLO,('LRTHI) D RANGE
. I LRTLO W ?32,"Ther: ",LRTLO,"-"
. I LRTHI W LRTHI D CRITICL
I '$O(^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3,LRAN,"COM",0)) W !
E D COM
Q
COM ;Print comments on specimen
W !,"COMMENT(S): "
S C=""
F S C=$O(^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3,LRAN,"COM",C)) Q:(C="")!(LREND) D
.I ($Y>(IOSL-7)) D
..D CONT D:$E(IOST,1,2)="C-" WAIT Q:LREND
..W @IOF D HDR
..; W !,$E(PNM,1,22),?23,$E(SSN,1,11) W:LRDPF=2 ?35,$E(LRLOC,1,12),?48,$E(LRAN,1,14)
..W !,$E(PNM,1,23),?25,HRCN W:LRDPF=2 " ",LRLOC,?50,$E(LRAN,1,14) ;IHS/ANMC/CLS 08/18/96
..W ?63,LRSPDAT
..;W !,PNM,?35,SSN W:LRDPF=2 " ",LRLOC,?60,LRAN
..;D HDR
..W !,"COMMENT(S): "
.Q:LREND
.W ?12,^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3,LRAN,"COM",C),!
Q
HDR ;
S LRPAG=LRPAG+1
; W "SPECIAL REPORT: SEARCHING FOR CRITICAL FLAGS "
; W LRDATE,?65,"Pg ",LRPAG,!,LRHDR2,!
;
; ----- BEGIN IHS/OIT/MKK LR*5.2*1025 MODIFICATION
D LABHDR^BLRUTIL2 ; Institution Name & Address in Header
NEW STR,PGLEN
S STR=$$CJ^XLFSTR("SPECIAL REPORT: SEARCHING FOR CRITICAL FLAGS",IOM)
S PGLEN=$L("Pg "_LRPAG)
S $E(STR,IOM-(PGLEN+2))="Pg "_LRPAG
S STR=$$TRIM^XLFSTR(STR,"R"," ") ; Trim trailing spaces
;
W STR,!,$$CJ^XLFSTR(LRHDR2,IOM),!
W $$CJ^XLFSTR("Print Date: "_$$HTE^XLFDT($H,"2DZ"),IOM),!
; ----- END IHS/OIT/MKK LR*5.2*1025 MODIFICATION
;
D LRGLIN^LRX
Q
RANGE ;
W ?31,"Ref. Range: ",LRRLO,"-",LRRHI
D CRITICL
Q
CRITICL ;
W ?57,"Critical: ",LRCLO,"-",LRCHI
Q
WAIT ;
K DIR S DIR(0)="E" D ^DIR
S:($D(DTOUT))!($D(DUOUT)) LREND=1
Q
CONT W !?10,"CONTINUED NEXT PAGE",! Q
LRSORC1A ;VA/DALISC/DRH - LRSORC Continued ;07-22-93
+1 ;;5.2;LAB SERVICE;**1031**;NOV 1, 1997
+2 ;
+3 ;;VA LR Patch(s): 201,344,351,384
+4 ;
INIT ;
+1 SET U="^"
+2 DO CONTROL
+3 QUIT
CONTROL ;
+1 DO SORT
+2 QUIT
SORT ;
+1 IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+2 IF $EXTRACT(IOST,1,2)="P-"
WRITE !
+3 DO HDR
+4 DO PRINT
+5 IF 'LREND
DO SUMMARY
+6 DO END
+7 QUIT
SUMMARY ;
+1 IF ($Y>(IOSL-7))
IF $EXTRACT(IOST,1,2)="C-"
DO WAIT
IF LREND
QUIT
WRITE @IOF
DO HDR
+2 FOR I=$Y:1:(IOSL-6)
WRITE !
+3 WRITE ?20,"END OF SPECIAL REPORT"
+4 QUIT
END ;
+1 IF ($EXTRACT(IOST,1,2)="C-")&('LREND)
DO WAIT
+2 WRITE @IOF
IF '$DATA(ZTQUEUED)
DO ^%ZISC
+3 KILL ^TMP("LR",$JOB)
+4 KILL ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK,ZTQUEUED,%ZIS,POP,%H,%DT,DTOUT,DUOUT
+5 KILL DIR,DIC,I,T,C,X,Y,L0,SEX,AGE,DFN,DOB,PNM,SSN,VA("BID"),VA("PID"),VAERR
+6 KILL LRAA,LRAD,LRDFN,LRDPF,LREND,LRFAN,LRIDT,LRLAN,LRLCS,LRSUB1,LRSUB2
+7 KILL LRLLOC,LRTX,LRTST,LRTVAL,LRCRTFLG,LRAN,LRSRT,LRPAG,LRDATE,LRDASH,LRDAT
+8 KILL LRLOC,LRPTS,LREDT,LRPDT,LRSDT,LRTREC,LRPREC,LREDAT,LRSDAT,LRSPDAT
+9 KILL LRWRD,LRHDR2,LRSUB3,LRAAA
+10 ;IHS/ANMC/CLS 08/18/96
KILL HRCN
+11 QUIT
PRINT ;
+1 SET LRSUB1=""
+2 IF $ORDER(^TMP("LR",$JOB,LRSUB1))=""
WRITE !!?30,"NO MATCHING DATA FOUND",!!
QUIT
+3 FOR
SET LRSUB1=$ORDER(^TMP("LR",$JOB,LRSUB1))
IF (LRSUB1="")!(LREND)
QUIT
Begin DoDot:1
+4 SET LRSUB2=""
+5 FOR
SET LRSUB2=$ORDER(^TMP("LR",$JOB,LRSUB1,LRSUB2))
IF (LRSUB2="")!(LREND)
QUIT
Begin DoDot:2
+6 SET LRSUB3=""
+7 FOR
SET LRSUB3=$ORDER(^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3))
IF (LRSUB3="")!(LREND)
QUIT
Begin DoDot:3
+8 SET LRAN=""
+9 FOR
SET LRAN=$ORDER(^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3,LRAN))
IF (LRAN="")!(LREND)
QUIT
Begin DoDot:4
+10 SET LRPREC=^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3,LRAN)
+11 SET LRDPF=$PIECE(LRPREC,U,4)
+12 ; S PNM=$P(LRPREC,U),SSN=$P(LRPREC,U,2),LRLOC=$P(LRPREC,U,3)
+13 ;IHS/ANMC/CLS 08/18/96
SET PNM=$PIECE(LRPREC,U)
SET HRCN=$PIECE(LRPREC,U,2)
SET LRLOC=$PIECE(LRPREC,U,3)
+14 SET LRSPEC=$PIECE(^LAB(61,$PIECE(LRPREC,U,6),0),U)
+15 SET LRSPNUM=$PIECE(LRPREC,U,6)
+16 SET LRSPDAT=$PIECE(LRPREC,U,5)
+17 IF ($Y>(IOSL-8))
IF $EXTRACT(IOST,1,2)="C-"
DO WAIT
IF LREND
QUIT
WRITE @IOF
DO HDR
+18 ;S PNM1=$P(PNM,","),PNM2=$P(PNM,",",2)
+19 ;S LRCHNG=PNM1 D CHNCASE^LRSORA2 S PNM1=LRCHNG
+20 ;S LRCHNG=PNM2 D CHNCASE^LRSORA2 S PNM2=LRCHNG
+21 ;S PNM=PNM1_","_PNM2
+22 ;S LRCHNG=LRSPEC D CHNCASE^LRSORA2 S LRSPEC=LRCHNG
+23 ; W !,$E(PNM,1,22),?23,$E(SSN,1,11) W:LRDPF=2 ?35,$E(LRLOC,1,12),?48,$E(LRAN,1,14)
+24 ;IHS/ANMC/CLS 08/18/96
WRITE !,$EXTRACT(PNM,1,23),?25,HRCN
IF LRDPF=2
WRITE " ",LRLOC,?50,$EXTRACT(LRAN,1,14)
+25 WRITE ?63,LRSPDAT
+26 WRITE !," ",LRSPEC
+27 DO PRNTST
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+28 QUIT
PRNTST ;
+1 NEW LRRLO,LRRHI,LRCLO,LRCHI,LRTLO,LRTHI,LRFLAG,VAR
+2 SET I=""
+3 FOR
SET I=$ORDER(^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3,LRAN,"TST",I))
IF (I="")!(LREND)
QUIT
Begin DoDot:1
+4 SET LRTREC=^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3,LRAN,"TST",I)
+5 SET LRTST=$PIECE(LRTREC,U)
SET LRTVAL=$PIECE(LRTREC,U,2)
SET LRCRTFLG=$PIECE(LRTREC,U,3)
+6 IF ($Y>(IOSL-7))
Begin DoDot:2
+7 DO CONT
IF $EXTRACT(IOST,1,2)="C-"
DO WAIT
IF LREND
QUIT
+8 WRITE @IOF
DO HDR
+9 ; W !,$E(PNM,1,22),?23,$E(SSN,1,11) W:LRDPF=2 ?35,$E(LRLOC,1,12),?48,$E(LRAN,1,14)
+10 ;IHS/ANMC/CLS 08/18/96
WRITE !,$EXTRACT(PNM,1,23),?25,HRCN
IF LRDPF=2
WRITE " ",LRLOC,?50,$EXTRACT(LRAN,1,14)
+11 WRITE ?63,LRSPDAT
End DoDot:2
+12 IF LREND
QUIT
+13 SET LRTX=$PIECE(LRTREC,U,5)
+14 SET LRFLAG=$PIECE(LRTREC,U,6)
+15 SET LRREF=$GET(^LAB(60,LRTX,1,LRSPNUM,0))
+16 ; set ranges LRFLAG on - from file 63 LRFLAG off - from file 60
+17 SET LRRLO=$SELECT(LRFLAG:$PIECE(LRTREC,U,7),1:$PIECE(LRREF,U,2))
+18 SET LRRHI=$SELECT(LRFLAG:$PIECE(LRTREC,U,8),1:$PIECE(LRREF,U,3))
+19 SET LRCLO=$SELECT(LRFLAG:$PIECE(LRTREC,U,9),1:$PIECE(LRREF,U,4))
+20 SET LRCHI=$SELECT(LRFLAG:$PIECE(LRTREC,U,10),1:$PIECE(LRREF,U,5))
+21 SET LRTLO=$SELECT(LRFLAG:$PIECE(LRTREC,U,11),1:$PIECE(LRREF,U,11))
+22 SET LRTHI=$SELECT(LRFLAG:$PIECE(LRTREC,U,12),1:$PIECE(LRREF,U,12))
+23 FOR VAR="LRRLO","LRRHI","LRCLO","LRCHI"
IF @VAR=""
SET @VAR="none"
+24 ;
+25 SET LRTST=$PIECE($GET(^LAB(60,LRTX,.1)),U)
+26 IF LRTST=""
SET LRTST=$EXTRACT($PIECE(^LAB(60,LRTX,0),U),1,10)
+27 ;I 'LRTST S LRTST=$E($P(^LAB(60,LRTX,0),U),1,10)
+28 ;S LRCHNG=LRTST D CHNCASE^LRSORA2 S LRTST=LRCHNG
+29 WRITE !,?2,$EXTRACT(LRTST,1,9),?12,$JUSTIFY(LRTVAL,6)
+30 WRITE ?19,$EXTRACT($PIECE(LRREF,U,7),1,10),?28,LRCRTFLG
+31 IF 'LRTLO
IF ('LRTHI)
DO RANGE
+32 IF LRTLO
WRITE ?32,"Ther: ",LRTLO,"-"
+33 IF LRTHI
WRITE LRTHI
DO CRITICL
End DoDot:1
+34 IF '$ORDER(^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3,LRAN,"COM",0))
WRITE !
+35 IF '$TEST
DO COM
+36 QUIT
COM ;Print comments on specimen
+1 WRITE !,"COMMENT(S): "
+2 SET C=""
+3 FOR
SET C=$ORDER(^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3,LRAN,"COM",C))
IF (C="")!(LREND)
QUIT
Begin DoDot:1
+4 IF ($Y>(IOSL-7))
Begin DoDot:2
+5 DO CONT
IF $EXTRACT(IOST,1,2)="C-"
DO WAIT
IF LREND
QUIT
+6 WRITE @IOF
DO HDR
+7 ; W !,$E(PNM,1,22),?23,$E(SSN,1,11) W:LRDPF=2 ?35,$E(LRLOC,1,12),?48,$E(LRAN,1,14)
+8 ;IHS/ANMC/CLS 08/18/96
WRITE !,$EXTRACT(PNM,1,23),?25,HRCN
IF LRDPF=2
WRITE " ",LRLOC,?50,$EXTRACT(LRAN,1,14)
+9 WRITE ?63,LRSPDAT
+10 ;W !,PNM,?35,SSN W:LRDPF=2 " ",LRLOC,?60,LRAN
+11 ;D HDR
+12 WRITE !,"COMMENT(S): "
End DoDot:2
+13 IF LREND
QUIT
+14 WRITE ?12,^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3,LRAN,"COM",C),!
End DoDot:1
+15 QUIT
HDR ;
+1 SET LRPAG=LRPAG+1
+2 ; W "SPECIAL REPORT: SEARCHING FOR CRITICAL FLAGS "
+3 ; W LRDATE,?65,"Pg ",LRPAG,!,LRHDR2,!
+4 ;
+5 ; ----- BEGIN IHS/OIT/MKK LR*5.2*1025 MODIFICATION
+6 ; Institution Name & Address in Header
DO LABHDR^BLRUTIL2
+7 NEW STR,PGLEN
+8 SET STR=$$CJ^XLFSTR("SPECIAL REPORT: SEARCHING FOR CRITICAL FLAGS",IOM)
+9 SET PGLEN=$LENGTH("Pg "_LRPAG)
+10 SET $EXTRACT(STR,IOM-(PGLEN+2))="Pg "_LRPAG
+11 ; Trim trailing spaces
SET STR=$$TRIM^XLFSTR(STR,"R"," ")
+12 ;
+13 WRITE STR,!,$$CJ^XLFSTR(LRHDR2,IOM),!
+14 WRITE $$CJ^XLFSTR("Print Date: "_$$HTE^XLFDT($HOROLOG,"2DZ"),IOM),!
+15 ; ----- END IHS/OIT/MKK LR*5.2*1025 MODIFICATION
+16 ;
+17 DO LRGLIN^LRX
+18 QUIT
RANGE ;
+1 WRITE ?31,"Ref. Range: ",LRRLO,"-",LRRHI
+2 DO CRITICL
+3 QUIT
CRITICL ;
+1 WRITE ?57,"Critical: ",LRCLO,"-",LRCHI
+2 QUIT
WAIT ;
+1 KILL DIR
SET DIR(0)="E"
DO ^DIR
+2 IF ($DATA(DTOUT))!($DATA(DUOUT))
SET LREND=1
+3 QUIT
CONT WRITE !?10,"CONTINUED NEXT PAGE",!
QUIT
