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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSORC1 2387 printed Dec 13, 2024@02:20:32 Page 2
LRSORC1 ;SLC/RWF/DALISC/JBM - CRITICAL VALUE REPORT ; 8/30/87 17:25 ;
+1 ;;5.2;LAB SERVICE;**153,344,449**;Sep 27, 1994;Build 4
EN ;
BUILD ;
+1 SET LRPDT=LREDT-.000001
+2 FOR
SET LRPDT=$ORDER(^LRO(69,LRPDT))
if ('LRPDT)!(LRPDT>LRSDT)!(LREND=1)
QUIT
Begin DoDot:1
+3 SET LRLLOC=""
+4 FOR
SET LRLLOC=$ORDER(^LRO(69,LRPDT,1,"AN",LRLLOC))
if LRLLOC=""
QUIT
Begin DoDot:2
+5 SET LRDFN=0
+6 FOR
SET LRDFN=$ORDER(^LRO(69,LRPDT,1,"AN",LRLLOC,LRDFN))
if 'LRDFN
QUIT
DO LRIDT
End DoDot:2
End DoDot:1
+7 QUIT
LRIDT ;
+1 SET LRIDT=0
SET LRSPEC=0
+2 FOR
SET LRIDT=$ORDER(^LRO(69,LRPDT,1,"AN",LRLLOC,LRDFN,LRIDT))
if 'LRIDT
QUIT
DO LOOK
+3 QUIT
LOOK ;
+1 NEW LR63RLO,LR63RHI,LR63CLO,LR63CHI,LR63TLO,LR63THI,LR63DAT,PC5,LRFLAG
+2 KILL T
SET L0=$GET(^LR(LRDFN,"CH",LRIDT,0))
if '$LENGTH(L0)
QUIT
+3 SET LRSPEC=$PIECE(L0,"^",5)
+4 IF LRAA
SET LRAAA=$PIECE($PIECE(L0,U,6)," ")
if '$LENGTH(LRAAA)
QUIT
if '$DATA(LRAA(LRAAA))#2
QUIT
+5 SET T=0
SET I=1
+6 FOR
SET I=$ORDER(^LR(LRDFN,"CH",LRIDT,I))
if LREND!(I<1)
QUIT
Begin DoDot:1
+7 IF $PIECE(^LR(LRDFN,"CH",LRIDT,I),U,2)["*"
Begin DoDot:2
+8 SET T=T+1
SET T(I)=^LR(LRDFN,"CH",LRIDT,I)
+9 IF $GET(LRFLAG)=""
Begin DoDot:3
+10 IF $GET(^LR(LRDFN,"CH",LRIDT,"NPC"))>1
IF $PIECE(T(I),U,5,12)'=""
SET LRFLAG=1
QUIT
+11 SET LRFLAG=0
End DoDot:3
End DoDot:2
End DoDot:1
+12 IF T
Begin DoDot:1
+13 SET X=^LR(LRDFN,0)
+14 SET LRDPF=$PIECE(X,U,2)
SET DFN=$PIECE(X,U,3)
+15 IF LRPTS
if '$DATA(LRPTS(DFN))
QUIT
+16 DO PT^LRX
+17 SET LRLOC=LRLLOC
+18 ;S LRLOC=$S($D(^DPT(DFN,.1)):^(.1),1:LRLLOC)
+19 IF LRLCS
if '$DATA(LRLCS(LRLLOC))
QUIT
+20 SET LRDAT=$PIECE(^LR(LRDFN,"CH",LRIDT,0),U)
SET LRSPEC=$PIECE(^(0),U,5)
+21 SET LRSUB1=$SELECT(LRSRT="P":PNM_SSN,1:LRLOC)
+22 SET LRSUB2=$SELECT(LRSRT="P":LRDAT,1:PNM_SSN)
+23 SET LRSUB3=$SELECT(LRSRT="P":LRLOC,1:LRDAT)
+24 SET LRAN=$PIECE(L0,U,6)
+25 KILL %DT
SET X=$PIECE(L0,U)
SET %DT="XT"
DO ^%DT
DO DD^LRX
SET LRSPDAT=Y
+26 SET ^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3,LRAN)=PNM_U_SSN_U_LRLOC_U_LRDPF_U_LRSPDAT_U_LRSPEC
+27 SET I=0
+28 FOR
SET I=$ORDER(T(I))
if LREND!(I<1)
QUIT
Begin DoDot:2
+29 SET LRTX=$ORDER(^LAB(60,"C","CH;"_I_";1",0))
+30 IF LRTX>0
Begin DoDot:3
+31 SET LRTST=$PIECE(^LAB(60,LRTX,0),U)
SET LRTVAL=$PIECE(T(I),U)
+32 SET LRCRTFLG=$PIECE(T(I),U,2)
+33 IF $GET(LRFLAG)
DO GET63
+34 SET ^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3,LRAN,"TST",I)=LRTST_U_LRTVAL_U_LRCRTFLG_U_LRSPEC_U_LRTX_U_$GET(LRFLAG)_$SELECT($GET(LRFLAG):LR63DAT,1:"")
End DoDot:3
End DoDot:2
+35 SET C=0
+36 FOR
SET C=$ORDER(^LR(LRDFN,"CH",LRIDT,1,C))
if 'C
QUIT
Begin DoDot:2
+37 SET ^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3,LRAN,"COM",C)=^LR(LRDFN,"CH",LRIDT,1,C,0)
End DoDot:2
End DoDot:1
+38 QUIT
+39 ;
GET63 ; get ranges from file 63 (T(I)) if they are stored there
+1 SET PC5=$PIECE(T(I),U,5)
+2 SET LR63RLO=$PIECE(PC5,"!",2)
+3 SET LR63RHI=$PIECE(PC5,"!",3)
+4 SET LR63CLO=$PIECE(PC5,"!",4)
+5 SET LR63CHI=$PIECE(PC5,"!",5)
+6 SET LR63TLO=$PIECE(PC5,"!",11)
+7 SET LR63THI=$PIECE(PC5,"!",12)
+8 SET LR63DAT=U_LR63RLO_U_LR63RHI_U_LR63CLO_U_LR63CHI_U_LR63TLO_U_LR63THI_U_$PIECE(PC5,"!",7)
+9 QUIT
