LRSORC1 ;SLC/RWF/DALISC/JBM - CRITICAL VALUE REPORT ;JUL 06, 2010 3:14 PM;
;;5.2;LAB SERVICE;**153,344,1027**;NOV 01, 1997
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 LRSUB1=$S(LRSRT="P":PNM_HRCN,1:LRLOC) ;IHS/ANMC/CLS 08/18/96
.; S LRSUB2=$S(LRSRT="P":LRDAT,1:PNM_SSN)
.S LRSUB2=$S(LRSRT="P":LRDAT,1:PNM_HRCN) ;IHS/ANMC/CLS 08/18/96
.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 ^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3,LRAN)=PNM_U_HRCN_U_LRLOC_U_LRDPF_U_LRSPDAT_U_LRSPEC ;IHS/ANMC/CLS 08/18/96
.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
Q
LRSORC1 ;SLC/RWF/DALISC/JBM - CRITICAL VALUE REPORT ;JUL 06, 2010 3:14 PM;
+1 ;;5.2;LAB SERVICE;**153,344,1027**;NOV 01, 1997
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 ; S LRSUB1=$S(LRSRT="P":PNM_SSN,1:LRLOC)
+22 ;IHS/ANMC/CLS 08/18/96
SET LRSUB1=$SELECT(LRSRT="P":PNM_HRCN,1:LRLOC)
+23 ; S LRSUB2=$S(LRSRT="P":LRDAT,1:PNM_SSN)
+24 ;IHS/ANMC/CLS 08/18/96
SET LRSUB2=$SELECT(LRSRT="P":LRDAT,1:PNM_HRCN)
+25 SET LRSUB3=$SELECT(LRSRT="P":LRLOC,1:LRDAT)
+26 SET LRAN=$PIECE(L0,U,6)
+27 KILL %DT
SET X=$PIECE(L0,U)
SET %DT="XT"
DO ^%DT
DO DD^LRX
SET LRSPDAT=Y
+28 ; S ^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3,LRAN)=PNM_U_SSN_U_LRLOC_U_LRDPF_U_LRSPDAT_U_LRSPEC
+29 ;IHS/ANMC/CLS 08/18/96
SET ^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3,LRAN)=PNM_U_HRCN_U_LRLOC_U_LRDPF_U_LRSPDAT_U_LRSPEC
+30 SET I=0
+31 FOR
SET I=$ORDER(T(I))
IF LREND!(I<1)
QUIT
Begin DoDot:2
+32 SET LRTX=$ORDER(^LAB(60,"C","CH;"_I_";1",0))
+33 IF LRTX>0
Begin DoDot:3
+34 SET LRTST=$PIECE(^LAB(60,LRTX,0),U)
SET LRTVAL=$PIECE(T(I),U)
+35 SET LRCRTFLG=$PIECE(T(I),U,2)
+36 IF $GET(LRFLAG)
DO GET63
+37 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
+38 SET C=0
+39 FOR
SET C=$ORDER(^LR(LRDFN,"CH",LRIDT,1,C))
IF 'C
QUIT
Begin DoDot:2
+40 SET ^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3,LRAN,"COM",C)=^LR(LRDFN,"CH",LRIDT,1,C,0)
End DoDot:2
End DoDot:1
+41 QUIT
+42 ;
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
+9 QUIT
