LREXPD ;SLC/RWF-EXPLODE A LRTEST LIST ;2/5/91 13:15
;;5.2;LAB SERVICE;**153,201,221**;Sep 27, 1994
;LRTEST IS LIST OF TEST's, LREXPD IS EXECUTE CODE TO SET OTHER VAR.
S S1=0,J=0 S:'$D(LRTSTS)#2 LRTSTS=0
F I=1:1 S X=$P(LRTEST,U,I) Q:X<1 D TREE
K LREXPD,S1,J1 Q
TREE I '$D(^LAB(60,X,0)) Q ;BAD LRTEST NUMBER
I $P(^LAB(60,X,0),U,5)]"" Q:$D(^TMP("LR",$J,"T",X)) S LRTSTS=LRTSTS+1,LRORD(LRTSTS)=X,^TMP("LR",$J,"T",X)=^LAB(60,X,0) X:$D(LREXPD) LREXPD Q ;ADD TO LIST
Q:'$D(^LAB(60,X,2,0)) Q:$O(^(0))<1 Q:$D(S1("A",X)) ;NOT A PANEL
S S1=S1+1,S1(S1)=X,J1(S1)=J,S1("A",X)=""
S J=0 F S J=$O(^LAB(60,S1(S1),2,J)) Q:J<1 S X=+^(J,0) D TREE
S J=J1(S1),X=S1(S1),S1=S1-1
Q
EXP ;Get the list of tests for this ACC. from LRGVG1
N I,N,IX
K LRTEST,LRNAME,LRSM60 S LRALERT=$S($G(LROUTINE):LROUTINE,1:9),N=0,I=0,IX=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0))
F S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I)) Q:I<.5 I $G(^(I,0)) S X=^(0) D
. S N=N+1,LRTEST(N)=I,LRTEST(N,"P")=$P(X,U,9)_U_$$NLT^LRVER1(I)_"!"
. S LRAL=$P($G(^(0)),U,2) I LRAL,LRAL<LRALERT S LRALERT=LRAL
K LRAL S LRNTN=N F I=1:1:N S:$D(^LAB(60,+LRTEST(I),0)) LRTEST(I)=LRTEST(I)_U_^(0),LRNAME(I)=$P(LRTEST(I),U,2),LRNAME(I,+LRTEST(I))="" S:$G(^(1,IX,3)) LRSM60(+$P(LRTEST(I),";",2))=^(3)
K IX N X1,X S X=$P($H,","),X(1)=$P($H,",",2),I=0 F S I=$O(LRSM60(I)) Q:'I S X1=X-LRSM60(I)_","_X(1),LRSM60(I)=9999999-$$HTFM^XLFDT(X1)
Q
EX1 ;;Expand the list of tests to edit.
Q:'$D(LRTEST(T1)) S X=LRTEST(T1),^TMP("LR",$J,"VTO",+X)=$P($P(X,U,6),";",2)
S ^TMP("LR",$J,"VTO",+X,"P")=$G(LRTEST(T1,"P")),S1=0,J=0 D EX2 K S1,J
Q
EX2 ;from LRDIST
S LRSUB=$P(X,U,6) I $D(^LAB(60,+X,4)),$P(^(4),"^",2) S LRCFL=LRCFL_$P(^(4),"^",2)_U
I $L(LRSUB) S S2=$P(LRSUB,";",2) D:'$D(^TMP("LR",$J,"TMP",S2)) ORD Q
S S1=S1+1,S1(S1)=X,S1(S1,1)=J
S J=0 F S J=$O(^LAB(60,+S1(S1),2,J)) Q:J<1 S Y=+^(J,0),X=Y_U_^LAB(60,Y,0) D EX2
S X=S1(S1),J=S1(S1,1),S1=S1-1
Q
ORD S LRNX=LRNX+1,LRORD(LRNX)=S2,^TMP("LR",$J,"TMP",S2)=+X
S ^TMP("LR",$J,"TMP",S2,"P")=$G(LRTEST(T1))_U_$$RNLT^LRVER1(+X)
S:$P(X,U,18) LRM(S2)=+X,LRMX(+X)="" Q
;LRNX is set by caller
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLREXPD 2127 printed Oct 16, 2024@18:15:29 Page 2
LREXPD ;SLC/RWF-EXPLODE A LRTEST LIST ;2/5/91 13:15
+1 ;;5.2;LAB SERVICE;**153,201,221**;Sep 27, 1994
+2 ;LRTEST IS LIST OF TEST's, LREXPD IS EXECUTE CODE TO SET OTHER VAR.
+3 SET S1=0
SET J=0
if '$DATA(LRTSTS)#2
SET LRTSTS=0
+4 FOR I=1:1
SET X=$PIECE(LRTEST,U,I)
if X<1
QUIT
DO TREE
+5 KILL LREXPD,S1,J1
QUIT
TREE ;BAD LRTEST NUMBER
IF '$DATA(^LAB(60,X,0))
QUIT
+1 ;ADD TO LIST
IF $PIECE(^LAB(60,X,0),U,5)]""
if $DATA(^TMP("LR",$JOB,"T",X))
QUIT
SET LRTSTS=LRTSTS+1
SET LRORD(LRTSTS)=X
SET ^TMP("LR",$JOB,"T",X)=^LAB(60,X,0)
if $DATA(LREXPD)
XECUTE LREXPD
QUIT
+2 ;NOT A PANEL
if '$DATA(^LAB(60,X,2,0))
QUIT
if $ORDER(^(0))<1
QUIT
if $DATA(S1("A",X))
QUIT
+3 SET S1=S1+1
SET S1(S1)=X
SET J1(S1)=J
SET S1("A",X)=""
+4 SET J=0
FOR
SET J=$ORDER(^LAB(60,S1(S1),2,J))
if J<1
QUIT
SET X=+^(J,0)
DO TREE
+5 SET J=J1(S1)
SET X=S1(S1)
SET S1=S1-1
+6 QUIT
EXP ;Get the list of tests for this ACC. from LRGVG1
+1 NEW I,N,IX
+2 KILL LRTEST,LRNAME,LRSM60
SET LRALERT=$SELECT($GET(LROUTINE):LROUTINE,1:9)
SET N=0
SET I=0
SET IX=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0))
+3 FOR
SET I=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I))
if I<.5
QUIT
IF $GET(^(I,0))
SET X=^(0)
Begin DoDot:1
+4 SET N=N+1
SET LRTEST(N)=I
SET LRTEST(N,"P")=$PIECE(X,U,9)_U_$$NLT^LRVER1(I)_"!"
+5 SET LRAL=$PIECE($GET(^(0)),U,2)
IF LRAL
IF LRAL<LRALERT
SET LRALERT=LRAL
End DoDot:1
+6 KILL LRAL
SET LRNTN=N
FOR I=1:1:N
if $DATA(^LAB(60,+LRTEST(I),0))
SET LRTEST(I)=LRTEST(I)_U_^(0)
SET LRNAME(I)=$PIECE(LRTEST(I),U,2)
SET LRNAME(I,+LRTEST(I))=""
if $GET(^(1,IX,3))
SET LRSM60(+$PIECE(LRTEST(I),";",2))=^(3)
+7 KILL IX
NEW X1,X
SET X=$PIECE($HOROLOG,",")
SET X(1)=$PIECE($HOROLOG,",",2)
SET I=0
FOR
SET I=$ORDER(LRSM60(I))
if 'I
QUIT
SET X1=X-LRSM60(I)_","_X(1)
SET LRSM60(I)=9999999-$$HTFM^XLFDT(X1)
+8 QUIT
EX1 ;;Expand the list of tests to edit.
+1 if '$DATA(LRTEST(T1))
QUIT
SET X=LRTEST(T1)
SET ^TMP("LR",$JOB,"VTO",+X)=$PIECE($PIECE(X,U,6),";",2)
+2 SET ^TMP("LR",$JOB,"VTO",+X,"P")=$GET(LRTEST(T1,"P"))
SET S1=0
SET J=0
DO EX2
KILL S1,J
+3 QUIT
EX2 ;from LRDIST
+1 SET LRSUB=$PIECE(X,U,6)
IF $DATA(^LAB(60,+X,4))
IF $PIECE(^(4),"^",2)
SET LRCFL=LRCFL_$PIECE(^(4),"^",2)_U
+2 IF $LENGTH(LRSUB)
SET S2=$PIECE(LRSUB,";",2)
if '$DATA(^TMP("LR",$JOB,"TMP",S2))
DO ORD
QUIT
+3 SET S1=S1+1
SET S1(S1)=X
SET S1(S1,1)=J
+4 SET J=0
FOR
SET J=$ORDER(^LAB(60,+S1(S1),2,J))
if J<1
QUIT
SET Y=+^(J,0)
SET X=Y_U_^LAB(60,Y,0)
DO EX2
+5 SET X=S1(S1)
SET J=S1(S1,1)
SET S1=S1-1
+6 QUIT
ORD SET LRNX=LRNX+1
SET LRORD(LRNX)=S2
SET ^TMP("LR",$JOB,"TMP",S2)=+X
+1 SET ^TMP("LR",$JOB,"TMP",S2,"P")=$GET(LRTEST(T1))_U_$$RNLT^LRVER1(+X)
+2 if $PIECE(X,U,18)
SET LRM(S2)=+X
SET LRMX(+X)=""
QUIT
+3 ;LRNX is set by caller
+4 QUIT
