- 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 Feb 18, 2025@23:40:37 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
