- 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 Jan 18, 2025@03:21:13 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