LRGP2.m

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