LRSORC ;SLC/RWF/DALISC/JBM - CRITICAL VALUE REPORT ; 8/30/87 17:25 ;
;;5.2;LAB SERVICE;**84**;Sep 27, 1994
EN ;
D OPTIONS
D:'LREND DEVICE
I LREND D END^LRSORC1A Q
D DQ
Q
OPTIONS ;
S LREDT="T-1",LREND=0 D ^LRWU3
D GAA,SORTBY:'LREND,SELPAT:'LREND,SELLOC:'LREND
Q
GAA S LRAA=0 W !
K DIR,X,Y S DIR(0)="S^Y:YES;N:NO",DIR("B")="NO"
S DIR("A")="Do you want to select accession areas (YES or NO) "
S DIR("?")="Enter 'YES' to limit report to one or more accession areas."
D ^DIR
Q:Y="N"
I ($D(DTOUT))!($D(DUOUT)) S LREND=1 Q
K DIC S DIC=68,DIC(0)="AEMQZ"
F D ^DIC Q:Y=-1 D
.S LRAA=+Y,LRAA($P(Y(0),U,11))=+Y
I ($D(DTOUT))!($D(DUOUT)) S LREND=1 Q
Q
SORTBY K DIR S DIR("B")="P",DIR("A")="Sort by PATIENT or by LOCATION"
S DIR(0)="S^P:PATIENT;L:LOCATION",DIR("?")="Choose print sorting order."
D ^DIR S:($D(DUOUT))!($D(DTOUT)) LREND=1 Q:LREND S LRSRT=Y
Q
SELPAT S LRPTS=0
K DIC S DIC="^DPT(",DIC(0)="AEMQ",DIC("A")="Select PATIENT NAME: All//"
F I=1:1 D ^DIC Q:Y=-1 S LRPTS(+Y)=$P(Y,U,2),DIC("A")="Select another PATIENT: ",LRPTS=I
S:($D(DUOUT))!($D(DTOUT)) LREND=1
Q
SELLOC S LRLCS=0
K DIC S DIC="^SC(",DIC(0)="AEMQZ",DIC("A")="Select LOCATION: All//"
F I=1:1 D ^DIC Q:Y=-1 D
.S DIC("A")="Select another LOCATION: "
.I '$L($P(Y(0),"^",2)) W !!,$P(Y,"^",2)," does not have an Abbreviation in the Hospital Location file.",! Q
.S LRLCS($P(Y(0),U,2))=+Y,LRLCS=I
.Q
S:($D(DUOUT))!($D(DTOUT)) LREND=1
I $G(LRLCS) S LRLCS("NO ABRV")=""
Q
DEVICE ;
I 'LREND D
.S %ZIS="Q" D ^%ZIS S:POP LREND=1
.I ($D(IO("Q")))&('LREND) D
..S ZTRTN="DQ^LRSORC",ZTSAVE("LR*")=""
..K IO("Q") D ^%ZTLOAD S LREND=1
Q
DQ ;
K ^TMP("LR",$J)
S:$D(ZTQUEUED) ZTREQ="@" U IO
S (LRPAG,LREND)=0,$P(LRDASH,"-",IOM)="-"
K %DT S X="N",%DT="T" D ^%DT,DD^LRX S LRDATE=Y
K %DT S X=$P(LRSDT,"."),%DT="X" D ^%DT,DD^LRX S LRSDAT=Y
K %DT S X=LREDT,%DT="X" D ^%DT,DD^LRX S LREDAT=Y
S LRHDR2="For date range: "_LREDAT_" to "_LRSDAT
D BUILD^LRSORC1
D ^LRSORC1A
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSORC 2021 printed Sep 23, 2025@19:56:10 Page 2
LRSORC ;SLC/RWF/DALISC/JBM - CRITICAL VALUE REPORT ; 8/30/87 17:25 ;
+1 ;;5.2;LAB SERVICE;**84**;Sep 27, 1994
EN ;
+1 DO OPTIONS
+2 if 'LREND
DO DEVICE
+3 IF LREND
DO END^LRSORC1A
QUIT
+4 DO DQ
+5 QUIT
OPTIONS ;
+1 SET LREDT="T-1"
SET LREND=0
DO ^LRWU3
+2 DO GAA
if 'LREND
DO SORTBY
if 'LREND
DO SELPAT
if 'LREND
DO SELLOC
+3 QUIT
GAA SET LRAA=0
WRITE !
+1 KILL DIR,X,Y
SET DIR(0)="S^Y:YES;N:NO"
SET DIR("B")="NO"
+2 SET DIR("A")="Do you want to select accession areas (YES or NO) "
+3 SET DIR("?")="Enter 'YES' to limit report to one or more accession areas."
+4 DO ^DIR
+5 if Y="N"
QUIT
+6 IF ($DATA(DTOUT))!($DATA(DUOUT))
SET LREND=1
QUIT
+7 KILL DIC
SET DIC=68
SET DIC(0)="AEMQZ"
+8 FOR
DO ^DIC
if Y=-1
QUIT
Begin DoDot:1
+9 SET LRAA=+Y
SET LRAA($PIECE(Y(0),U,11))=+Y
End DoDot:1
+10 IF ($DATA(DTOUT))!($DATA(DUOUT))
SET LREND=1
QUIT
+11 QUIT
SORTBY KILL DIR
SET DIR("B")="P"
SET DIR("A")="Sort by PATIENT or by LOCATION"
+1 SET DIR(0)="S^P:PATIENT;L:LOCATION"
SET DIR("?")="Choose print sorting order."
+2 DO ^DIR
if ($DATA(DUOUT))!($DATA(DTOUT))
SET LREND=1
if LREND
QUIT
SET LRSRT=Y
+3 QUIT
SELPAT SET LRPTS=0
+1 KILL DIC
SET DIC="^DPT("
SET DIC(0)="AEMQ"
SET DIC("A")="Select PATIENT NAME: All//"
+2 FOR I=1:1
DO ^DIC
if Y=-1
QUIT
SET LRPTS(+Y)=$PIECE(Y,U,2)
SET DIC("A")="Select another PATIENT: "
SET LRPTS=I
+3 if ($DATA(DUOUT))!($DATA(DTOUT))
SET LREND=1
+4 QUIT
SELLOC SET LRLCS=0
+1 KILL DIC
SET DIC="^SC("
SET DIC(0)="AEMQZ"
SET DIC("A")="Select LOCATION: All//"
+2 FOR I=1:1
DO ^DIC
if Y=-1
QUIT
Begin DoDot:1
+3 SET DIC("A")="Select another LOCATION: "
+4 IF '$LENGTH($PIECE(Y(0),"^",2))
WRITE !!,$PIECE(Y,"^",2)," does not have an Abbreviation in the Hospital Location file.",!
QUIT
+5 SET LRLCS($PIECE(Y(0),U,2))=+Y
SET LRLCS=I
+6 QUIT
End DoDot:1
+7 if ($DATA(DUOUT))!($DATA(DTOUT))
SET LREND=1
+8 IF $GET(LRLCS)
SET LRLCS("NO ABRV")=""
+9 QUIT
DEVICE ;
+1 IF 'LREND
Begin DoDot:1
+2 SET %ZIS="Q"
DO ^%ZIS
if POP
SET LREND=1
+3 IF ($DATA(IO("Q")))&('LREND)
Begin DoDot:2
+4 SET ZTRTN="DQ^LRSORC"
SET ZTSAVE("LR*")=""
+5 KILL IO("Q")
DO ^%ZTLOAD
SET LREND=1
End DoDot:2
End DoDot:1
+6 QUIT
DQ ;
+1 KILL ^TMP("LR",$JOB)
+2 if $DATA(ZTQUEUED)
SET ZTREQ="@"
USE IO
+3 SET (LRPAG,LREND)=0
SET $PIECE(LRDASH,"-",IOM)="-"
+4 KILL %DT
SET X="N"
SET %DT="T"
DO ^%DT
DO DD^LRX
SET LRDATE=Y
+5 KILL %DT
SET X=$PIECE(LRSDT,".")
SET %DT="X"
DO ^%DT
DO DD^LRX
SET LRSDAT=Y
+6 KILL %DT
SET X=LREDT
SET %DT="X"
DO ^%DT
DO DD^LRX
SET LREDAT=Y
+7 SET LRHDR2="For date range: "_LREDAT_" to "_LRSDAT
+8 DO BUILD^LRSORC1
+9 DO ^LRSORC1A
+10 QUIT
