LRSORD1A ;DALISC/DRH - LRSORC Continued ;07-22-93
;;5.2;LAB SERVICE;**201,344,449**;Sep 27, 1994;Build 4
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
....W !,$E(PNM,1,23),?25,SSN W:LRDPF=2 " ",LRLOC,?50,$E(LRAN,1,14)
....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,23),?25,SSN W:LRDPF=2 " ",LRLOC,?50,$E(LRAN,1,14)
..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))
.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
..W !,$E(PNM,1,23),?25,SSN W:LRDPF=2 " ",LRLOC,?50,$E(LRAN,1,14)
..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 4301 printed Nov 22, 2024@17:30:39 Page 2
LRSORD1A ;DALISC/DRH - LRSORC Continued ;07-22-93
+1 ;;5.2;LAB SERVICE;**201,344,449**;Sep 27, 1994;Build 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 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 WRITE !,$EXTRACT(PNM,1,23),?25,SSN
if LRDPF=2
WRITE " ",LRLOC,?50,$EXTRACT(LRAN,1,14)
+23 WRITE ?63,LRSPDAT
+24 WRITE !," ",LRSPEC
+25 DO PRNTST
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+26 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 WRITE !,$EXTRACT(PNM,1,23),?25,SSN
if LRDPF=2
WRITE " ",LRLOC,?50,$EXTRACT(LRAN,1,14)
+10 WRITE ?63,LRSPDAT
End DoDot:2
+11 if LREND
QUIT
+12 SET LRTX=$PIECE(LRTREC,U,5)
+13 SET LRFLAG=$PIECE(LRTREC,U,6)
+14 SET LRREF=$GET(^LAB(60,LRTX,1,LRSPNUM,0))
+15 SET LRRLO=$SELECT(LRFLAG:$PIECE(LRTREC,U,7),1:$PIECE(LRREF,U,2))
+16 SET LRRHI=$SELECT(LRFLAG:$PIECE(LRTREC,U,8),1:$PIECE(LRREF,U,3))
+17 SET LRCLO=$SELECT(LRFLAG:$PIECE(LRTREC,U,9),1:$PIECE(LRREF,U,4))
+18 SET LRCHI=$SELECT(LRFLAG:$PIECE(LRTREC,U,10),1:$PIECE(LRREF,U,5))
+19 SET LRTLO=$SELECT(LRFLAG:$PIECE(LRTREC,U,11),1:$PIECE(LRREF,U,11))
+20 SET LRTHI=$SELECT(LRFLAG:$PIECE(LRTREC,U,12),1:$PIECE(LRREF,U,12))
+21 FOR VAR="LRRLO","LRRHI","LRCLO","LRCHI"
IF @VAR=""
SET @VAR="none"
+22 ;
+23 SET LRTST=$PIECE($GET(^LAB(60,LRTX,.1)),U)
+24 IF 'LRTST
SET LRTST=$EXTRACT($PIECE(^LAB(60,LRTX,0),U),1,10)
+25 ;I 'LRTST S LRTST=$E($P(^LAB(60,LRTX,0),U),1,10)
+26 ;S LRCHNG=LRTST D CHNCASE^LRSORA2 S LRTST=LRCHNG
+27 WRITE !,?2,$EXTRACT(LRTST,1,7),?12,$JUSTIFY(LRTVAL,6)
+28 WRITE ?19,$SELECT(LRFLAG:$PIECE(LRTREC,U,13),1:$EXTRACT($PIECE(LRREF,U,7),1,10)),?28,LRCRTFLG
+29 IF 'LRTLO
IF ('LRTHI)
DO RANGE
+30 IF LRTLO
WRITE ?32,"Ther: ",LRTLO,"-"
+31 IF LRTHI
WRITE LRTHI
DO CRITICL
End DoDot:1
+32 IF '$ORDER(^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3,LRAN,"COM",0))
WRITE !
+33 IF '$TEST
DO COM
+34 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 WRITE !,$EXTRACT(PNM,1,23),?25,SSN
if LRDPF=2
WRITE " ",LRLOC,?50,$EXTRACT(LRAN,1,14)
+8 WRITE ?63,LRSPDAT
+9 ;W !,PNM,?35,SSN W:LRDPF=2 " ",LRLOC,?60,LRAN
+10 ;D HDR
+11 WRITE !,"COMMENT(S): "
End DoDot:2
+12 if LREND
QUIT
+13 WRITE ?12,^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3,LRAN,"COM",C),!
End DoDot:1
+14 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
