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

LRSORC1.m

Go to the documentation of this file.
LRSORC1 ;SLC/RWF/DALISC/JBM - CRITICAL VALUE REPORT ; 8/30/87  17:25 ;
 ;;5.2;LAB SERVICE;**153,344,449**;Sep 27, 1994;Build 4
EN ;
BUILD ;
 S LRPDT=LREDT-.000001
 F  S LRPDT=$O(^LRO(69,LRPDT)) Q:('LRPDT)!(LRPDT>LRSDT)!(LREND=1)  D
 .S LRLLOC=""
 .F  S LRLLOC=$O(^LRO(69,LRPDT,1,"AN",LRLLOC)) Q:LRLLOC=""  D
 ..S LRDFN=0
 ..F  S LRDFN=$O(^LRO(69,LRPDT,1,"AN",LRLLOC,LRDFN)) Q:'LRDFN  D LRIDT
 Q
LRIDT ;
 S LRIDT=0,LRSPEC=0
 F  S LRIDT=$O(^LRO(69,LRPDT,1,"AN",LRLLOC,LRDFN,LRIDT)) Q:'LRIDT  D LOOK
 Q
LOOK ;
 N LR63RLO,LR63RHI,LR63CLO,LR63CHI,LR63TLO,LR63THI,LR63DAT,PC5,LRFLAG
 K T S L0=$G(^LR(LRDFN,"CH",LRIDT,0)) Q:'$L(L0)
 S LRSPEC=$P(L0,"^",5)
 I LRAA S LRAAA=$P($P(L0,U,6)," ") Q:'$L(LRAAA)  Q:'$D(LRAA(LRAAA))#2
 S T=0,I=1
 F  S I=$O(^LR(LRDFN,"CH",LRIDT,I)) Q:LREND!(I<1)  D
 .I $P(^LR(LRDFN,"CH",LRIDT,I),U,2)["*" D
 ..S T=T+1,T(I)=^LR(LRDFN,"CH",LRIDT,I)
 ..I $G(LRFLAG)="" D
 ...I $G(^LR(LRDFN,"CH",LRIDT,"NPC"))>1,$P(T(I),U,5,12)'="" S LRFLAG=1 Q
 ...S LRFLAG=0
 I T D
 .S X=^LR(LRDFN,0)
 .S LRDPF=$P(X,U,2),DFN=$P(X,U,3)
 .I LRPTS Q:'$D(LRPTS(DFN))
 .D PT^LRX
 .S LRLOC=LRLLOC
 .;S LRLOC=$S($D(^DPT(DFN,.1)):^(.1),1:LRLLOC)
 .I LRLCS Q:'$D(LRLCS(LRLLOC))
 .S LRDAT=$P(^LR(LRDFN,"CH",LRIDT,0),U),LRSPEC=$P(^(0),U,5)
 .S LRSUB1=$S(LRSRT="P":PNM_SSN,1:LRLOC)
 .S LRSUB2=$S(LRSRT="P":LRDAT,1:PNM_SSN)
 .S LRSUB3=$S(LRSRT="P":LRLOC,1:LRDAT)
 .S LRAN=$P(L0,U,6)
 .K %DT S X=$P(L0,U),%DT="XT" D ^%DT,DD^LRX S LRSPDAT=Y
 .S ^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3,LRAN)=PNM_U_SSN_U_LRLOC_U_LRDPF_U_LRSPDAT_U_LRSPEC
 .S I=0
 .F  S I=$O(T(I)) Q:LREND!(I<1)  D
 ..S LRTX=$O(^LAB(60,"C","CH;"_I_";1",0))
 ..I LRTX>0 D
 ...S LRTST=$P(^LAB(60,LRTX,0),U),LRTVAL=$P(T(I),U)
 ...S LRCRTFLG=$P(T(I),U,2)
 ...I $G(LRFLAG) D GET63
 ...S ^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3,LRAN,"TST",I)=LRTST_U_LRTVAL_U_LRCRTFLG_U_LRSPEC_U_LRTX_U_$G(LRFLAG)_$S($G(LRFLAG):LR63DAT,1:"")
 .S C=0
 .F  S C=$O(^LR(LRDFN,"CH",LRIDT,1,C)) Q:'C  D
 ..S ^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3,LRAN,"COM",C)=^LR(LRDFN,"CH",LRIDT,1,C,0)
 Q
 ;
GET63 ; get ranges from file 63 (T(I)) if they are stored there
 S PC5=$P(T(I),U,5)
 S LR63RLO=$P(PC5,"!",2)
 S LR63RHI=$P(PC5,"!",3)
 S LR63CLO=$P(PC5,"!",4)
 S LR63CHI=$P(PC5,"!",5)
 S LR63TLO=$P(PC5,"!",11)
 S LR63THI=$P(PC5,"!",12)
 S LR63DAT=U_LR63RLO_U_LR63RHI_U_LR63CLO_U_LR63CHI_U_LR63TLO_U_LR63THI_U_$P(PC5,"!",7)
 Q