LRGP2 ;SLC/CJS/RWF/DALOI/FHS-COMMON PARTS TO INSTRUMENT GROUP VERIFY/CHECK ;2/5/91 13:23
;;5.2;LAB SERVICE;**1004,1013,1031**;NOV 1, 1997
;
;;VA LR Patch(s): 153,221,263,290
;
Q
;
;
EXPLODE ; from LRGP1, LRVR
N %,C,DIC,DIR,DIRUT,DIROUT,DUOUT,LREND,LRI,LRTEST,LRX,I,X,Y
I $G(LRORDR)'="P" K ^TMP("LR",$J)
S LRCFL="",LRI=0 S:'$D(LRNX) LRNX=0
F S LRI=$O(^LRO(68.2,LRLL,10,LRPROF,1,LRI)) Q:LRI<1 I $D(^(LRI,0))#2 D
. S LRI(0)=$G(^LRO(68.2,LRLL,10,LRPROF,1,LRI,0))
. S LRX=$P(LRI(0),"^") K LRTEST
. I '$P(LRI(0),U,3) D EX6(LRX)
. S:'$D(^TMP("LR",$J,"VTO",LRX))#2 ^(LRX)=""
K LRVTS S LRVTS=11,LRI=0 D
. F S LRI=+$O(^TMP("LR",$J,"T",LRI)) Q:LRI<1 S X=^(LRI) D
. . S LRVTS($P(X,";",2))=LRI,LRVTS=LRVTS+1
. . S ^TMP("LR",$J,"VTO",LRI)=$P(X,";",2)
Q:$G(LRORDR)="P"
EX3 ;
G:$G(LREND) STOP
;
K DIR,DIRUT,DIROUT,DUOUT,X,Y
S DIR(0)="YO",DIR("A")="Would you like to see the test list",DIR("B")="No"
D ^DIR
I $S($G(DIRUT):1,$G(LREND):1,1:0) K ^TMP("LR",$J),LRVTS Q
I Y=1 D
. W @IOF,!,"The ("_$P(^LRO(68.2,LRLL,0),U)_") ["_$P(^LRO(68.2,LRLL,10,LRPROF,0),U)_"] Profile has"
. D LIST
;
K DIR
S DIR("A",1)=" "
S DIR("A")="Do you wish to modify the test list"
S DIR("?")="i.e. would you like to add or subtract ATOMIC tests?"
S DIR("B")="NO"
S DIR(0)="Y" D ^DIR
I $D(DIRUT) S LREND=1 G STOP
I Y=1 D EX1 G:'$G(LREND) EX3
STOP I $G(LREND) K ^TMP("LR",$J),LRVTS S LREND=0 Q
EX2 ;
K LRVTS,DIC
S LRVTS=11,LRI=0,C=0
F S LRI=$O(^TMP("LR",$J,"T",LRI)) Q:LRI<1 D
. S X=^TMP("LR",$J,"T",LRI),LRVTS($P(X,";",2))=LRI
. S LRVTS=LRVTS+1
. S ^TMP("LR",$J,"VTO",LRI)=$P(X,";",2)
. S C=C+1
. I $P($G(^LAB(60,LRI,4)),U,2) S LRCFL=LRCFL_$P(^(4),U,2)_U
S (X,X1)=0 F S X=$O(^TMP("LR",$J,"VTO",X)) Q:X<1 S X1=X1+1
I C>0 W !,"You have selected ",X1," tests to work with."
I C<1 D
. W !,$C(7),">> Please check the PROFILE you have selected."
. W !,">> At least one should be build name only = no "
K ^TMP("LR",$J,"T")
Q
;
EX1 ;
K DIR
S DIR("A")="Do you want to add ATOMIC test(s) to this panel",DIR("B")="NO"
D ^DIR
I $D(DIRUT) S LREND=1 Q
I Y=1 D
. K LRVTS,DIC
. S DIC("A")="Select ATOMIC test(s) you wish to add: ",DIC="^LAB(60,",DIC(0)="AEMOQZ" ; ,DIC("S")="I $G(^(.2))"
. F D ^DIC Q:Y<1 K LRTEST D EX6(+Y)
. W @IOF,!?5,"The List now has" D LIST
EX4 ;
K DIR
S DIR("A",1)=" "
S DIR("A")="Do you wish to exclude ATOMIC tests in this panel"
S DIR("B")="NO",DIR(0)="YO"
D ^DIR
I $D(DIRUT) S LREND=1 Q
I Y=1 D
. N LREXCL,%
. W !!,$$CJ^XLFSTR("Tests removed from this panel will not be included for review or editing.",IOM),!!
. K DIC
. S LREXCL="",DIC("A")="Select ATOMIC test(s) you wish to exclude: ",DIC="^LAB(60,",DIC(0)="AEMOQ"
. S DIC("S")="I $D(^TMP(""LR"",$J,""T"",Y))"
. F D ^DIC Q:Y<1 D
. . S X1=$P(^TMP("LR",$J,"T",+Y),";",2)
. . I X1 K LRVTS(X1)
. . K ^TMP("LR",$J,"VTO",+Y),^TMP("LR",$J,"T",+Y) S LREXCL(+Y)=$P(Y,U,2) D
. . .N I,X
. . .S I=0 F S I=$O(^LAB(60,+Y,2,0)) Q:I<1 I $D(^(I,0)) S X=+^(0) D
. . . . I X K ^TMP("LR",$J,"VTO",X),^TMP("LR",$J,"T",X) S LREXCL(X)=$P($G(^LAB(60,X,0)),U)
. I $O(LREXCL(0)) D
. . N I
. . W @IOF,!,"Excluding" S I=0 F S I=$O(LREXCL(I)) Q:I<1 W !,LREXCL(I) K LRVTS(I) H 2
Q
;
LIST ;
N LRI,DIR,DUOUT,X
W " the following tests: "
S LRI=0,DIR(0)="E"
F S LRI=$O(^TMP("LR",$J,"VTO",LRI)) Q:LRI<1!($D(DUOUT)) D
. W !,?10,$P($G(^LAB(60,LRI,0)),U)
. I $Y>(IOSL-4) W ! D ^DIR W @IOF I $D(DIRUT) S LREND=1
Q
;
;
YESNO ;
W !
N DIR
S DIR("B")=$S($G(%)=1:"Yes",$G(%)=2:"No",1:"")
S DIR(0)="Y" D ^DIR S %=Y
Q
;
;
EX6(LRX) ;Expand test list
S (T1,LRTEST)=LRX,LRTEST(T1)=LRX_U_$G(^LAB(60,T1,0))
S LRTEST(T1,"P")=LRTEST
D ^LREXPD
S:'$D(^TMP("LR",$J,"VTO",LRX))#2 ^(LRX)=""
Q
LRGP2 ;SLC/CJS/RWF/DALOI/FHS-COMMON PARTS TO INSTRUMENT GROUP VERIFY/CHECK ;2/5/91 13:23
+1 ;;5.2;LAB SERVICE;**1004,1013,1031**;NOV 1, 1997
+2 ;
+3 ;;VA LR Patch(s): 153,221,263,290
+4 ;
+5 QUIT
+6 ;
+7 ;
EXPLODE ; from LRGP1, LRVR
+1 NEW %,C,DIC,DIR,DIRUT,DIROUT,DUOUT,LREND,LRI,LRTEST,LRX,I,X,Y
+2 IF $GET(LRORDR)'="P"
KILL ^TMP("LR",$JOB)
+3 SET LRCFL=""
SET LRI=0
IF '$DATA(LRNX)
SET LRNX=0
+4 FOR
SET LRI=$ORDER(^LRO(68.2,LRLL,10,LRPROF,1,LRI))
IF LRI<1
QUIT
IF $DATA(^(LRI,0))#2
Begin DoDot:1
+5 SET LRI(0)=$GET(^LRO(68.2,LRLL,10,LRPROF,1,LRI,0))
+6 SET LRX=$PIECE(LRI(0),"^")
KILL LRTEST
+7 IF '$PIECE(LRI(0),U,3)
DO EX6(LRX)
+8 IF '$DATA(^TMP("LR",$JOB,"VTO",LRX))#2
SET ^(LRX)=""
End DoDot:1
+9 KILL LRVTS
SET LRVTS=11
SET LRI=0
Begin DoDot:1
+10 FOR
SET LRI=+$ORDER(^TMP("LR",$JOB,"T",LRI))
IF LRI<1
QUIT
SET X=^(LRI)
Begin DoDot:2
+11 SET LRVTS($PIECE(X,";",2))=LRI
SET LRVTS=LRVTS+1
+12 SET ^TMP("LR",$JOB,"VTO",LRI)=$PIECE(X,";",2)
End DoDot:2
End DoDot:1
+13 IF $GET(LRORDR)="P"
QUIT
EX3 ;
+1 IF $GET(LREND)
GOTO STOP
+2 ;
+3 KILL DIR,DIRUT,DIROUT,DUOUT,X,Y
+4 SET DIR(0)="YO"
SET DIR("A")="Would you like to see the test list"
SET DIR("B")="No"
+5 DO ^DIR
+6 IF $SELECT($GET(DIRUT):1,$GET(LREND):1,1:0)
KILL ^TMP("LR",$JOB),LRVTS
QUIT
+7 IF Y=1
Begin DoDot:1
+8 WRITE @IOF,!,"The ("_$PIECE(^LRO(68.2,LRLL,0),U)_") ["_$PIECE(^LRO(68.2,LRLL,10,LRPROF,0),U)_"] Profile has"
+9 DO LIST
End DoDot:1
+10 ;
+11 KILL DIR
+12 SET DIR("A",1)=" "
+13 SET DIR("A")="Do you wish to modify the test list"
+14 SET DIR("?")="i.e. would you like to add or subtract ATOMIC tests?"
+15 SET DIR("B")="NO"
+16 SET DIR(0)="Y"
DO ^DIR
+17 IF $DATA(DIRUT)
SET LREND=1
GOTO STOP
+18 IF Y=1
DO EX1
IF '$GET(LREND)
GOTO EX3
STOP IF $GET(LREND)
KILL ^TMP("LR",$JOB),LRVTS
SET LREND=0
QUIT
EX2 ;
+1 KILL LRVTS,DIC
+2 SET LRVTS=11
SET LRI=0
SET C=0
+3 FOR
SET LRI=$ORDER(^TMP("LR",$JOB,"T",LRI))
IF LRI<1
QUIT
Begin DoDot:1
+4 SET X=^TMP("LR",$JOB,"T",LRI)
SET LRVTS($PIECE(X,";",2))=LRI
+5 SET LRVTS=LRVTS+1
+6 SET ^TMP("LR",$JOB,"VTO",LRI)=$PIECE(X,";",2)
+7 SET C=C+1
+8 IF $PIECE($GET(^LAB(60,LRI,4)),U,2)
SET LRCFL=LRCFL_$PIECE(^(4),U,2)_U
End DoDot:1
+9 SET (X,X1)=0
FOR
SET X=$ORDER(^TMP("LR",$JOB,"VTO",X))
IF X<1
QUIT
SET X1=X1+1
+10 IF C>0
WRITE !,"You have selected ",X1," tests to work with."
+11 IF C<1
Begin DoDot:1
+12 WRITE !,$CHAR(7),">> Please check the PROFILE you have selected."
+13 WRITE !,">> At least one should be build name only = no "
End DoDot:1
+14 KILL ^TMP("LR",$JOB,"T")
+15 QUIT
+16 ;
EX1 ;
+1 KILL DIR
+2 SET DIR("A")="Do you want to add ATOMIC test(s) to this panel"
SET DIR("B")="NO"
+3 DO ^DIR
+4 IF $DATA(DIRUT)
SET LREND=1
QUIT
+5 IF Y=1
Begin DoDot:1
+6 KILL LRVTS,DIC
+7 ; ,DIC("S")="I $G(^(.2))"
SET DIC("A")="Select ATOMIC test(s) you wish to add: "
SET DIC="^LAB(60,"
SET DIC(0)="AEMOQZ"
+8 FOR
DO ^DIC
IF Y<1
QUIT
KILL LRTEST
DO EX6(+Y)
+9 WRITE @IOF,!?5,"The List now has"
DO LIST
End DoDot:1
EX4 ;
+1 KILL DIR
+2 SET DIR("A",1)=" "
+3 SET DIR("A")="Do you wish to exclude ATOMIC tests in this panel"
+4 SET DIR("B")="NO"
SET DIR(0)="YO"
+5 DO ^DIR
+6 IF $DATA(DIRUT)
SET LREND=1
QUIT
+7 IF Y=1
Begin DoDot:1
+8 NEW LREXCL,%
+9 WRITE !!,$$CJ^XLFSTR("Tests removed from this panel will not be included for review or editing.",IOM),!!
+10 KILL DIC
+11 SET LREXCL=""
SET DIC("A")="Select ATOMIC test(s) you wish to exclude: "
SET DIC="^LAB(60,"
SET DIC(0)="AEMOQ"
+12 SET DIC("S")="I $D(^TMP(""LR"",$J,""T"",Y))"
+13 FOR
DO ^DIC
IF Y<1
QUIT
Begin DoDot:2
+14 SET X1=$PIECE(^TMP("LR",$JOB,"T",+Y),";",2)
+15 IF X1
KILL LRVTS(X1)
+16 KILL ^TMP("LR",$JOB,"VTO",+Y),^TMP("LR",$JOB,"T",+Y)
SET LREXCL(+Y)=$PIECE(Y,U,2)
Begin DoDot:3
+17 NEW I,X
+18 SET I=0
FOR
SET I=$ORDER(^LAB(60,+Y,2,0))
IF I<1
QUIT
IF $DATA(^(I,0))
SET X=+^(0)
Begin DoDot:4
+19 IF X
KILL ^TMP("LR",$JOB,"VTO",X),^TMP("LR",$JOB,"T",X)
SET LREXCL(X)=$PIECE($GET(^LAB(60,X,0)),U)
End DoDot:4
End DoDot:3
End DoDot:2
+20 IF $ORDER(LREXCL(0))
Begin DoDot:2
+21 NEW I
+22 WRITE @IOF,!,"Excluding"
SET I=0
FOR
SET I=$ORDER(LREXCL(I))
IF I<1
QUIT
WRITE !,LREXCL(I)
KILL LRVTS(I)
HANG 2
End DoDot:2
End DoDot:1
+23 QUIT
+24 ;
LIST ;
+1 NEW LRI,DIR,DUOUT,X
+2 WRITE " the following tests: "
+3 SET LRI=0
SET DIR(0)="E"
+4 FOR
SET LRI=$ORDER(^TMP("LR",$JOB,"VTO",LRI))
IF LRI<1!($DATA(DUOUT))
QUIT
Begin DoDot:1
+5 WRITE !,?10,$PIECE($GET(^LAB(60,LRI,0)),U)
+6 IF $Y>(IOSL-4)
WRITE !
DO ^DIR
WRITE @IOF
IF $DATA(DIRUT)
SET LREND=1
End DoDot:1
+7 QUIT
+8 ;
+9 ;
YESNO ;
+1 WRITE !
+2 NEW DIR
+3 SET DIR("B")=$SELECT($GET(%)=1:"Yes",$GET(%)=2:"No",1:"")
+4 SET DIR(0)="Y"
DO ^DIR
SET %=Y
+5 QUIT
+6 ;
+7 ;
EX6(LRX) ;Expand test list
+1 SET (T1,LRTEST)=LRX
SET LRTEST(T1)=LRX_U_$GET(^LAB(60,T1,0))
+2 SET LRTEST(T1,"P")=LRTEST
+3 DO ^LREXPD
+4 IF '$DATA(^TMP("LR",$JOB,"VTO",LRX))#2
SET ^(LRX)=""
+5 QUIT
