LRSORD1A ;VA/DALISC/DRH - LRSORC Continued ;JUL 06, 2010 3:14 PM
;;5.2;LAB SERVICE;**201,344,1027**;NOV 01, 1997
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)
....;----- BEGIN IHS MODIFICSTIONS LR*5.2*1018 IHS TESTING CHANGE
....S LRSPEC=$P(LRPREC,U,6)
....S LRSPEC=$S(LRSPEC'="":$P(^LAB(61,$P(LRPREC,U,6),0),U),1:"UNKNOWN")
....;----- END IHS MODIFICATIONS
....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 !,$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,23),?25,SSN W:LRDPF=2 " ",LRLOC,?50,$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))
.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,$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 !,$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 ;
D LABHDR^BLRUTIL2 ; IHS/OIT/MKK - LR*5.2*1027 -- Put Institution's Name in Header
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
LRSORD1A ;VA/DALISC/DRH - LRSORC Continued ;JUL 06, 2010 3:14 PM
+1 ;;5.2;LAB SERVICE;**201,344,1027**;NOV 01, 1997
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 SET PNM=$PIECE(LRPREC,U)
SET SSN=$PIECE(LRPREC,U,2)
SET LRLOC=$PIECE(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 ;S LRSPEC=$P(^LAB(61,$P(LRPREC,U,6),0),U)
+15 ;----- BEGIN IHS MODIFICSTIONS LR*5.2*1018 IHS TESTING CHANGE
+16 SET LRSPEC=$PIECE(LRPREC,U,6)
+17 SET LRSPEC=$SELECT(LRSPEC'="":$PIECE(^LAB(61,$PIECE(LRPREC,U,6),0),U),1:"UNKNOWN")
+18 ;----- END IHS MODIFICATIONS
+19 SET LRSPNUM=$PIECE(LRPREC,U,6)
+20 SET LRSPDAT=$PIECE(LRPREC,U,5)
+21 IF ($Y>(IOSL-8))
IF $EXTRACT(IOST,1,2)="C-"
DO WAIT
IF LREND
QUIT
WRITE @IOF
DO HDR
+22 ;S PNM1=$P(PNM,","),PNM2=$P(PNM,",",2)
+23 ;S LRCHNG=PNM1 D CHNCASE^LRSORA2 S PNM1=LRCHNG
+24 ;S LRCHNG=PNM2 D CHNCASE^LRSORA2 S PNM2=LRCHNG
+25 ;S PNM=PNM1_","_PNM2
+26 ;S LRCHNG=LRSPEC D CHNCASE^LRSORA2 S LRSPEC=LRCHNG
+27 ;W !,$E(PNM,1,23),?25,SSN W:LRDPF=2 " ",LRLOC,?50,$E(LRAN,1,14)
+28 ;IHS/ANMC/CLS 08/18/96
WRITE !,$EXTRACT(PNM,1,23),?25,HRCN
IF LRDPF=2
WRITE " ",LRLOC,?50,$EXTRACT(LRAN,1,14)
+29 WRITE ?63,LRSPDAT
+30 WRITE !," ",LRSPEC
+31 DO PRNTST
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+32 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,23),?25,SSN W:LRDPF=2 " ",LRLOC,?50,$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 LRRLO=$SELECT(LRFLAG:$PIECE(LRTREC,U,7),1:$PIECE(LRREF,U,2))
+17 SET LRRHI=$SELECT(LRFLAG:$PIECE(LRTREC,U,8),1:$PIECE(LRREF,U,3))
+18 SET LRCLO=$SELECT(LRFLAG:$PIECE(LRTREC,U,9),1:$PIECE(LRREF,U,4))
+19 SET LRCHI=$SELECT(LRFLAG:$PIECE(LRTREC,U,10),1:$PIECE(LRREF,U,5))
+20 SET LRTLO=$SELECT(LRFLAG:$PIECE(LRTREC,U,11),1:$PIECE(LRREF,U,11))
+21 SET LRTHI=$SELECT(LRFLAG:$PIECE(LRTREC,U,12),1:$PIECE(LRREF,U,12))
+22 FOR VAR="LRRLO","LRRHI","LRCLO","LRCHI"
IF @VAR=""
SET @VAR="none"
+23 ;
+24 SET LRTST=$PIECE($GET(^LAB(60,LRTX,.1)),U)
+25 IF 'LRTST
SET LRTST=$EXTRACT($PIECE(^LAB(60,LRTX,0),U),1,10)
+26 ;I 'LRTST S LRTST=$E($P(^LAB(60,LRTX,0),U),1,10)
+27 ;S LRCHNG=LRTST D CHNCASE^LRSORA2 S LRTST=LRCHNG
+28 WRITE !,?2,$EXTRACT(LRTST,1,7),?12,$JUSTIFY(LRTVAL,6)
+29 WRITE ?19,$EXTRACT($PIECE(LRREF,U,7),1,10),?28,LRCRTFLG
+30 IF 'LRTLO
IF ('LRTHI)
DO RANGE
+31 IF LRTLO
WRITE ?32,"Ther: ",LRTLO,"-"
+32 IF LRTHI
WRITE LRTHI
DO CRITICL
End DoDot:1
+33 IF '$ORDER(^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3,LRAN,"COM",0))
WRITE !
+34 IF '$TEST
DO COM
+35 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,23),?25,SSN W:LRDPF=2 " ",LRLOC,?50,$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 ; IHS/OIT/MKK - LR*5.2*1027 -- Put Institution's Name in Header
DO LABHDR^BLRUTIL2
+2 SET LRPAG=LRPAG+1
+3 WRITE "SPECIAL REPORT: Search for Abnormal and Critical Results "
+4 WRITE LRDATE,?65,"Pg ",LRPAG,!,LRHDR2,!
+5 DO LRGLIN^LRX
+6 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
