LRSORD1A ;DALISC/DRH - LRSORC Continued ;APR 2, 2025@13:34
;;5.2;LAB SERVICE;**201,344,449,585**;Sep 27, 1994;Build 18
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
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 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
....;LR*5.2*585: ADJUSTED TRUNCATION OF LRAN FROM 14 TO 16 CHARACTERS. MOVED LRSDAT TO LINE BELOW.
....W !,$E(PNM,1,23),?25,SSN W:LRDPF=2 " ",LRLOC,?50,$E(LRAN,1,16)
....W ?63
....W !," ",LRSPDAT," ",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
..; LR*5.2*585: ADJUSTED THE TRUNCATION OF LRAN FROM 14 TO 16 CHARACTERS AND SHIFTED LRSPDAT TO LINE BELOW.
..W !,$E(PNM,1,23),?25,SSN W:LRDPF=2 " ",LRLOC,?50,$E(LRAN,1,16)
..W ?63," "
..W !," ",LRSPDAT
.Q:LREND
.S LRTX=$P(LRTREC,U,5)
.S LRFLAG=$P(LRTREC,U,6)
.S LRREF=$G(^LAB(60,LRTX,1,LRSPNUM,0))
.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,7),?12,$J(LRTVAL,6)
.W ?19,$S(LRFLAG:$P(LRTREC,U,13),1:$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
..; LR*5.2*585: ADJUSTED THE TRUNCATION OF LRAN FROM 14 TO 16 CHARACTERS AND SHIFTED LRSPDAT TO LINE BELOW.
..W !,$E(PNM,1,23),?25,SSN W:LRDPF=2 " ",LRLOC,?50,$E(LRAN,1,16)
..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: Search for Abnormal and Critical Results "
W LRDATE,?65,"Pg ",LRPAG,!,LRHDR2,!
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSORD1A 4660 printed Sep 23, 2025@19:56:15 Page 2
LRSORD1A ;DALISC/DRH - LRSORC Continued ;APR 2, 2025@13:34
+1 ;;5.2;LAB SERVICE;**201,344,449,585**;Sep 27, 1994;Build 18
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 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 SET PNM=$PIECE(LRPREC,U)
SET SSN=$PIECE(LRPREC,U,2)
SET LRLOC=$PIECE(LRPREC,U,3)
+13 SET LRSPEC=$PIECE(^LAB(61,$PIECE(LRPREC,U,6),0),U)
+14 SET LRSPNUM=$PIECE(LRPREC,U,6)
+15 SET LRSPDAT=$PIECE(LRPREC,U,5)
+16 IF ($Y>(IOSL-8))
if $EXTRACT(IOST,1,2)="C-"
DO WAIT
if LREND
QUIT
WRITE @IOF
DO HDR
+17 ;S PNM1=$P(PNM,","),PNM2=$P(PNM,",",2)
+18 ;S LRCHNG=PNM1 D CHNCASE^LRSORA2 S PNM1=LRCHNG
+19 ;S LRCHNG=PNM2 D CHNCASE^LRSORA2 S PNM2=LRCHNG
+20 ;S PNM=PNM1_","_PNM2
+21 ;S LRCHNG=LRSPEC D CHNCASE^LRSORA2 S LRSPEC=LRCHNG
+22 ;LR*5.2*585: ADJUSTED TRUNCATION OF LRAN FROM 14 TO 16 CHARACTERS. MOVED LRSDAT TO LINE BELOW.
+23 WRITE !,$EXTRACT(PNM,1,23),?25,SSN
if LRDPF=2
WRITE " ",LRLOC,?50,$EXTRACT(LRAN,1,16)
+24 WRITE ?63
+25 WRITE !," ",LRSPDAT," ",LRSPEC
+26 DO PRNTST
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+27 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 ; LR*5.2*585: ADJUSTED THE TRUNCATION OF LRAN FROM 14 TO 16 CHARACTERS AND SHIFTED LRSPDAT TO LINE BELOW.
+10 WRITE !,$EXTRACT(PNM,1,23),?25,SSN
if LRDPF=2
WRITE " ",LRLOC,?50,$EXTRACT(LRAN,1,16)
+11 WRITE ?63," "
+12 WRITE !," ",LRSPDAT
End DoDot:2
+13 if LREND
QUIT
+14 SET LRTX=$PIECE(LRTREC,U,5)
+15 SET LRFLAG=$PIECE(LRTREC,U,6)
+16 SET LRREF=$GET(^LAB(60,LRTX,1,LRSPNUM,0))
+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,7),?12,$JUSTIFY(LRTVAL,6)
+30 WRITE ?19,$SELECT(LRFLAG:$PIECE(LRTREC,U,13),1:$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 ; LR*5.2*585: ADJUSTED THE TRUNCATION OF LRAN FROM 14 TO 16 CHARACTERS AND SHIFTED LRSPDAT TO LINE BELOW.
+8 WRITE !,$EXTRACT(PNM,1,23),?25,SSN
if LRDPF=2
WRITE " ",LRLOC,?50,$EXTRACT(LRAN,1,16)
+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 WRITE "SPECIAL REPORT: Search for Abnormal and Critical Results "
+3 WRITE LRDATE,?65,"Pg ",LRPAG,!,LRHDR2,!
+4 DO LRGLIN^LRX
+5 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
