Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRSORC

LRSORC.m

Go to the documentation of this file.
  1. LRSORC ;SLC/RWF/DALISC/JBM - CRITICAL VALUE REPORT ; 8/30/87 17:25 ;
  1. ;;5.2;LAB SERVICE;**84**;Sep 27, 1994
  1. EN ;
  1. D OPTIONS
  1. D:'LREND DEVICE
  1. I LREND D END^LRSORC1A Q
  1. D DQ
  1. Q
  1. OPTIONS ;
  1. S LREDT="T-1",LREND=0 D ^LRWU3
  1. D GAA,SORTBY:'LREND,SELPAT:'LREND,SELLOC:'LREND
  1. Q
  1. GAA S LRAA=0 W !
  1. K DIR,X,Y S DIR(0)="S^Y:YES;N:NO",DIR("B")="NO"
  1. S DIR("A")="Do you want to select accession areas (YES or NO) "
  1. S DIR("?")="Enter 'YES' to limit report to one or more accession areas."
  1. D ^DIR
  1. Q:Y="N"
  1. I ($D(DTOUT))!($D(DUOUT)) S LREND=1 Q
  1. K DIC S DIC=68,DIC(0)="AEMQZ"
  1. F D ^DIC Q:Y=-1 D
  1. .S LRAA=+Y,LRAA($P(Y(0),U,11))=+Y
  1. I ($D(DTOUT))!($D(DUOUT)) S LREND=1 Q
  1. Q
  1. SORTBY K DIR S DIR("B")="P",DIR("A")="Sort by PATIENT or by LOCATION"
  1. S DIR(0)="S^P:PATIENT;L:LOCATION",DIR("?")="Choose print sorting order."
  1. D ^DIR S:($D(DUOUT))!($D(DTOUT)) LREND=1 Q:LREND S LRSRT=Y
  1. Q
  1. SELPAT S LRPTS=0
  1. K DIC S DIC="^DPT(",DIC(0)="AEMQ",DIC("A")="Select PATIENT NAME: All//"
  1. F I=1:1 D ^DIC Q:Y=-1 S LRPTS(+Y)=$P(Y,U,2),DIC("A")="Select another PATIENT: ",LRPTS=I
  1. S:($D(DUOUT))!($D(DTOUT)) LREND=1
  1. Q
  1. SELLOC S LRLCS=0
  1. K DIC S DIC="^SC(",DIC(0)="AEMQZ",DIC("A")="Select LOCATION: All//"
  1. F I=1:1 D ^DIC Q:Y=-1 D
  1. .S DIC("A")="Select another LOCATION: "
  1. .I '$L($P(Y(0),"^",2)) W !!,$P(Y,"^",2)," does not have an Abbreviation in the Hospital Location file.",! Q
  1. .S LRLCS($P(Y(0),U,2))=+Y,LRLCS=I
  1. .Q
  1. S:($D(DUOUT))!($D(DTOUT)) LREND=1
  1. I $G(LRLCS) S LRLCS("NO ABRV")=""
  1. Q
  1. DEVICE ;
  1. I 'LREND D
  1. .S %ZIS="Q" D ^%ZIS S:POP LREND=1
  1. .I ($D(IO("Q")))&('LREND) D
  1. ..S ZTRTN="DQ^LRSORC",ZTSAVE("LR*")=""
  1. ..K IO("Q") D ^%ZTLOAD S LREND=1
  1. Q
  1. DQ ;
  1. K ^TMP("LR",$J)
  1. S:$D(ZTQUEUED) ZTREQ="@" U IO
  1. S (LRPAG,LREND)=0,$P(LRDASH,"-",IOM)="-"
  1. K %DT S X="N",%DT="T" D ^%DT,DD^LRX S LRDATE=Y
  1. K %DT S X=$P(LRSDT,"."),%DT="X" D ^%DT,DD^LRX S LRSDAT=Y
  1. K %DT S X=LREDT,%DT="X" D ^%DT,DD^LRX S LREDAT=Y
  1. S LRHDR2="For date range: "_LREDAT_" to "_LRSDAT
  1. D BUILD^LRSORC1
  1. D ^LRSORC1A
  1. QUIT