source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRGP2.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1LRGP2 ;SLC/CJS/RWF/DALOI/FHS-COMMON PARTS TO INSTRUMENT GROUP VERIFY/CHECK ;2/5/91 13:23
2 ;;5.2;LAB SERVICE;**153,221,263,290**;Sep 27, 1994
3 Q
4 ;
5 ;
6EXPLODE ; from LRGP1, LRVR
7 N %,C,DIC,DIR,DIRUT,DIROUT,DUOUT,LREND,LRI,LRTEST,LRX,I,X,Y
8 I $G(LRORDR)'="P" K ^TMP("LR",$J)
9 S LRCFL="",LRI=0 S:'$D(LRNX) LRNX=0
10 F S LRI=$O(^LRO(68.2,LRLL,10,LRPROF,1,LRI)) Q:LRI<1 I $D(^(LRI,0))#2 D
11 . S LRI(0)=$G(^LRO(68.2,LRLL,10,LRPROF,1,LRI,0))
12 . S LRX=$P(LRI(0),"^") K LRTEST
13 . I '$P(LRI(0),U,3) D EX6(LRX)
14 . S:'$D(^TMP("LR",$J,"VTO",LRX))#2 ^(LRX)=""
15 K LRVTS S LRVTS=11,LRI=0 D
16 . F S LRI=+$O(^TMP("LR",$J,"T",LRI)) Q:LRI<1 S X=^(LRI) D
17 . . S LRVTS($P(X,";",2))=LRI,LRVTS=LRVTS+1
18 . . S ^TMP("LR",$J,"VTO",LRI)=$P(X,";",2)
19 Q:$G(LRORDR)="P"
20EX3 ;
21 G:$G(LREND) STOP
22 ;
23 K DIR,DIRUT,DIROUT,DUOUT,X,Y
24 S DIR(0)="YO",DIR("A")="Would you like to see the test list",DIR("B")="No"
25 D ^DIR
26 I $S($G(DIRUT):1,$G(LREND):1,1:0) K ^TMP("LR",$J),LRVTS Q
27 I Y=1 D
28 . W @IOF,!,"The ("_$P(^LRO(68.2,LRLL,0),U)_") ["_$P(^LRO(68.2,LRLL,10,LRPROF,0),U)_"] Profile has"
29 . D LIST
30 ;
31 K DIR
32 S DIR("A",1)=" "
33 S DIR("A")="Do you wish to modify the test list"
34 S DIR("?")="i.e. would you like to add or subtract ATOMIC tests?"
35 S DIR("B")="NO"
36 S DIR(0)="Y" D ^DIR
37 I $D(DIRUT) S LREND=1 G STOP
38 I Y=1 D EX1 G:'$G(LREND) EX3
39STOP I $G(LREND) K ^TMP("LR",$J),LRVTS S LREND=0 Q
40EX2 ;
41 K LRVTS,DIC
42 S LRVTS=11,LRI=0,C=0
43 F S LRI=$O(^TMP("LR",$J,"T",LRI)) Q:LRI<1 D
44 . S X=^TMP("LR",$J,"T",LRI),LRVTS($P(X,";",2))=LRI
45 . S LRVTS=LRVTS+1
46 . S ^TMP("LR",$J,"VTO",LRI)=$P(X,";",2)
47 . S C=C+1
48 . I $P($G(^LAB(60,LRI,4)),U,2) S LRCFL=LRCFL_$P(^(4),U,2)_U
49 S (X,X1)=0 F S X=$O(^TMP("LR",$J,"VTO",X)) Q:X<1 S X1=X1+1
50 I C>0 W !,"You have selected ",X1," tests to work with."
51 I C<1 D
52 . W !,$C(7),">> Please check the PROFILE you have selected."
53 . W !,">> At least one should be build name only = no "
54 K ^TMP("LR",$J,"T")
55 Q
56 ;
57EX1 ;
58 K DIR
59 S DIR("A")="Do you want to add ATOMIC test(s) to this panel",DIR("B")="NO"
60 D ^DIR
61 I $D(DIRUT) S LREND=1 Q
62 I Y=1 D
63 . K LRVTS,DIC
64 . S DIC("A")="Select ATOMIC test(s) you wish to add: ",DIC="^LAB(60,",DIC(0)="AEMOQZ" ; ,DIC("S")="I $G(^(.2))"
65 . F D ^DIC Q:Y<1 K LRTEST D EX6(+Y)
66 . W @IOF,!?5,"The List now has" D LIST
67EX4 ;
68 K DIR
69 S DIR("A",1)=" "
70 S DIR("A")="Do you wish to exclude ATOMIC tests in this panel"
71 S DIR("B")="NO",DIR(0)="YO"
72 D ^DIR
73 I $D(DIRUT) S LREND=1 Q
74 I Y=1 D
75 . N LREXCL,%
76 . W !!,$$CJ^XLFSTR("Tests removed from this panel will not be included for review or editing.",IOM),!!
77 . K DIC
78 . S LREXCL="",DIC("A")="Select ATOMIC test(s) you wish to exclude: ",DIC="^LAB(60,",DIC(0)="AEMOQ"
79 . S DIC("S")="I $D(^TMP(""LR"",$J,""T"",Y))"
80 . F D ^DIC Q:Y<1 D
81 . . S X1=$P(^TMP("LR",$J,"T",+Y),";",2)
82 . . I X1 K LRVTS(X1)
83 . . K ^TMP("LR",$J,"VTO",+Y),^TMP("LR",$J,"T",+Y) S LREXCL(+Y)=$P(Y,U,2) D
84 . . .N I,X
85 . . .S I=0 F S I=$O(^LAB(60,+Y,2,0)) Q:I<1 I $D(^(I,0)) S X=+^(0) D
86 . . . . I X K ^TMP("LR",$J,"VTO",X),^TMP("LR",$J,"T",X) S LREXCL(X)=$P($G(^LAB(60,X,0)),U)
87 . I $O(LREXCL(0)) D
88 . . N I
89 . . W @IOF,!,"Excluding" S I=0 F S I=$O(LREXCL(I)) Q:I<1 W !,LREXCL(I) K LRVTS(I) H 2
90 Q
91 ;
92LIST ;
93 N LRI,DIR,DUOUT,X
94 W " the following tests: "
95 S LRI=0,DIR(0)="E"
96 F S LRI=$O(^TMP("LR",$J,"VTO",LRI)) Q:LRI<1!($D(DUOUT)) D
97 . W !,?10,$P($G(^LAB(60,LRI,0)),U)
98 . I $Y>(IOSL-4) W ! D ^DIR W @IOF I $D(DIRUT) S LREND=1
99 Q
100 ;
101 ;
102YESNO ;
103 W !
104 N DIR
105 S DIR("B")=$S($G(%)=1:"Yes",$G(%)=2:"No",1:"")
106 S DIR(0)="Y" D ^DIR S %=Y
107 Q
108 ;
109 ;
110EX6(LRX) ;Expand test list
111 S (T1,LRTEST)=LRX,LRTEST(T1)=LRX_U_$G(^LAB(60,T1,0))
112 S LRTEST(T1,"P")=LRTEST
113 D ^LREXPD
114 S:'$D(^TMP("LR",$J,"VTO",LRX))#2 ^(LRX)=""
115 Q
Note: See TracBrowser for help on using the repository browser.