source: IHS-VA_UTILITIES-XB/trunk/XB.m@ 1657

Last change on this file since 1657 was 642, checked in by Sam Habiel, 15 years ago

Modified directory structure; moved routines.

File size: 5.4 KB
Line 
1XB ; IHS/ADC/GTH - UTILITY MENU ; [ 04/28/2003 9:38 AM ]
2 ;;4.0;XB;;Jul 20, 2009;Build 2
3 ;
4 ; SEE ROUTINE XB1 FOR FURTHER DOCUMENTATION AND THE MENU
5 ; OPTIONS.
6 ;
7 ; This routine lists available utilities in the form of a
8 ; menu with a brief description of what the utility does.
9 ; New utilities may be added to this routine by adding the
10 ; appropriate ";;" entries to the bottom of routine XB1.
11 ;
12START ;
13 I '$D(^%ZOSF("TEST"))!('$D(^%ZOSF("TRAP"))) W !!,"Missing ^%ZOSF nodes!",! Q
14 S X="%ZIS"
15 D RCHK
16 I XBFAIL D EOJ Q
17 D ^XBKSET
18 S X="XBRPTL"
19 D RCHK
20 S:XBFAIL XBNH=""
21 S XBLBL="M",XBQ=0
22 F D MENU Q:XBQ
23 D EOJ
24 Q
25 ;
26MENU ;
27 D LIST
28 W !!,"Choose: "
29 R XBY:$G(DTIME,999)
30 S:XBY="^" XBY=""
31 I XBY["?" D HELP Q
32 I XBY="" S XBQ=1 Q
33 I XBY'=+XBY D LETTERS
34 I XBY'<1,XBY'>(XBI-1) D OPTION D:XBP="P" PAUSE S XBP="" Q
35 W *7
36 Q
37 ;
38HELP ;
39 I XBY="?" D Q
40 . S XBH=""
41 . D LIST
42 . KILL XBH
43 . W !!,"To get help on a non-menu option enter '?n' where n is the option number.",!
44 . D PAUSE
45 .Q
46 I XBY?1"?"1N.N S XBY=$P(XBY,"?",2) I XBY,XBY'>(XBI-1) D D PAUSE Q
47 . I $D(XBNH) W !!,"No help available. Routine ^XBRPTL not in UCI.",! Q
48 . KILL ^UTILITY($J)
49 . S XBX=$P($T(@XBLBL+XBY^XB1),";;",3)
50 . I XBX W !!,"No help available for menus." Q
51 . I XBX?1"!".E W !!,"No help available for executable code :",!,"[",$E(XBX,2,99),"]." Q
52 . S XBX=$P(XBX,"^",2),X=XBX
53 . D RCHK
54 . I XBFAIL W !!,"No help available. Routine ^",XBX," not in ",$S($E(XBX)="%":"MGR",1:"UCI"),".",! Q
55 . S %=$$RSEL^ZIBRSEL(XBX,"^UTILITY($J,")
56 . D EN^XBRPTL
57 . KILL ^UTILITY($J)
58 .Q
59 W *7
60 Q
61 ;
62LIST ; List menu options.
63 KILL XBTBL
64 ;W !!?5,$P($T(XB+1),";",4)," v ",$$CV^XBFUNC("XB");IHS/SET/GTH XB*3*9 10/29/2002
65 W !!?5,$P($T(XB+1),";",4)," v ",$$VERSION^XPDUTL("XB") ;IHS/SET/GTH XB*3*9 10/29/2002
66 W !!?5,$P($T(@XBLBL^XB1),";;",2),!
67 F XBI=1:1 S XBX=$T(@XBLBL+XBI^XB1) Q:$E(XBX)'=" " S XBY=$P(XBX,";;",3),XBX=$P(XBX,";;",2) D
68 . S X=$$UP^XLFSTR(XBX)
69 . S XBTBL(X)=XBI_"^"_XBX
70 . W !,XBI,?5,XBX," ",$S($D(XBH):$S(XBY:"[menu]",1:XBY),1:$S(XBY:"[menu]",1:""))
71 .Q
72 Q
73 ;
74LETTERS ;
75 KILL XBC
76 S XBY=$$UP^XLFSTR(XBY)
77 I $D(XBTBL(XBY)) S XBY=XBTBL(XBY) Q
78 S XBC=0,X=XBY
79 F S X=$O(XBTBL(X)) Q:X=""!($E(X,1,$L(XBY))'=XBY) S XBC=XBC+1,XBC(XBC)=+XBTBL(X)_"^"_$P(XBTBL(X),"^",2)
80 W !
81 I XBC=0 S XBY=0 Q
82 I XBC=1 S XBY=$P(XBC(1),"^",1) Q
83 F I=1:1:XBC W !,I," ",$P(XBC(I),"^",2)
84 W !!,"Which one? "
85 R XBY:$G(DTIME,999)
86 I XBY]"",$D(XBC(XBY)) W " ",$P(XBC(XBY),"^",2) S XBY=$P(XBC(XBY),"^",1) Q
87 W *7
88 S XBY=0
89 Q
90 ;
91OPTION ;
92 S XBX=$T(@XBLBL+XBY^XB1),XBP=$P(XBX,";;",4),XBX=$P(XBX,";;",3)
93 I XBX D RECURSE Q
94 W !
95 I XBX?1"!".E S XBX=$E(XBX,2,250)
96 E S X=$P(XBX,"^",2),XBX="D "_XBX D RCHK I XBFAIL W "Routine ",X," not in ",$S($E(X)="%":"MGR!",1:"UCI!") Q
97 S X="TRAP^XB",@^%ZOSF("TRAP")
98 ; D ^XBNEW("CALL^XB:XBX;DT;DTIME;U;DUZ") ;IHS/SET/GTH XB*3*9 10/29/2002
99 D EN^XBNEW("CALL^XB","XBX;DT;DTIME;U;DUZ") ;IHS/SET/GTH XB*3*9 10/29/2002
100 Q
101 ;
102CALL ;
103 S IOP=$I
104 D ^%ZIS
105 X XBX
106 U 0
107 Q
108 ;
109RECURSE ;
110 I $L(XBLBL)>6 W !,"Maximum menu depth exceeded." S XBQ=1 Q
111 S XBLBL=XBLBL_XBX
112 W !
113 F D MENU Q:XBQ
114 S XBQ=0,XBLBL=$E(XBLBL,1,$L(XBLBL)-1)
115 W !
116 Q
117 ;
118TRAP ; ERROR TRAP
119 W !!,"The following error has occurred: ",$$Z^ZIBNSSV("ERROR"),!
120 D:XBP="" PAUSE
121 Q
122 ;
123PAUSE ;EP
124 Q:'(IO=IO(0))
125 Q:'($E(IOST,1,2)="C-")
126 S Y=$$DIR^XBDIR("EO")
127 S:$D(DUOUT) XBQ=1
128 Q
129 ;
130CHECK ; CHECK XB OPTION ROUTINES (EXECUTED FROM ^XB MENU OPTION)
131 W !,"Patch ",$$PATS," is the highest XB/ZIB patch installed." ;IHS/SET/GTH XB*3*9 10/29/2002
132 F XBII=1:1 S X=$T(M+XBII^XB1) Q:X="" I $P(X,";;",1)=" " S X=$P(X,";;",3) I X'=+X,X'?1"!".E D
133 . I X'?.8UN1"^"1.8UN,X'?.8UN1"^"1"%"1.7UN S XBII(4,XBII)=$P($T(M+XBII^XB1),";;",2,9) Q
134 . S X=$P(X,"^",2)
135 . D RCHK
136 . I XBFAIL S XBII($S($E(X)'="%":1,$E(X,2,4)="ZIB":2,1:3),X)=""
137 .Q
138 I '$O(XBII(0)) W !,"All options seem to be ok.",! KILL XBII Q
139 I $D(XBII(1)) W !,"The following routines are not in this UCI:" S X="" F S X=$O(XBII(1,X)) Q:X="" W !?3,X
140 I $D(XBII(2)) W !,"The following ZIB* routines must be moved to MGR as % routines:" S X="" F S X=$O(XBII(2,X)) Q:X="" W !?3,X
141 I $D(XBII(3)) W !,"The following % routines are not in ",$S($$VERSION^%ZOSF(1)["Cache":"this Namespace",1:"MGR"),":" S X="" F S X=$O(XBII(3,X)) Q:X="" W !?3,X ;IHS/SET/GTH XB*3*9 10/29/2002
142 I $D(XBII(4)) W !,"The following options have invalid routine names:" S X="" F S X=$O(XBII(4,X)) Q:X="" W !?3,XBII(4,X)
143 W !
144 KILL XBII
145 Q
146 ;
147RCHK ;EP - Check Existence of Routine in X
148 S XBRTN=X,XUSLNT=1
149 ; I $E(XBRTN)="%" X ^%ZOSF("UCI") S XBUCI=Y,%UCI="MGR" D 2^%XUCI ; IHS/SET/GTH XB*3*9 10/29/2002
150 I ^%ZOSF("OS")["MSM",$E(XBRTN)="%" X ^%ZOSF("UCI") S XBUCI=Y,%UCI="MGR" D 2^%XUCI ; IHS/SET/GTH XB*3*9 10/29/2002
151 S X=XBRTN
152 X ^%ZOSF("TEST")
153 S XBFAIL='$T
154 ; I $E(XBRTN)="%" S %UCI=XBUCI D 2^%XUCI ; IHS/SET/GTH XB*3*9 10/29/2002
155 I ^%ZOSF("OS")["MSM",$E(XBRTN)="%" S %UCI=XBUCI D 2^%XUCI ; IHS/SET/GTH XB*3*9 10/29/2002
156 W:XBFAIL !!,"Routine ",XBRTN," missing!"
157 S X=XBRTN
158 KILL XUSLNT
159 Q
160 ;
161EOJ ;
162 D ^XBKTMP,EN^XBVK("XB")
163 KILL ^UTILITY($J)
164 KILL DIRUT,DTOUT,DUOUT
165 KILL X,Y
166 Q
167 ;
168OSNO ;EP
169 W $C(7),!,"Sorry...",!,"Operating System '",$P(^%ZOSF("OS"),"^",1),"' is not supported."
170 I $$DIR^XBDIR("EO","Press RETURN") ;IHS/SET/GTH XB*3*9 10/29/2002
171 Q
172 ;
173 ;Begin New Code;IHS/SET/GTH XB*3*9 10/29/2002
174PATS() ;Display patches installed for XB.
175 NEW I,P,V
176 S I=$O(^DIC(9.4,"C","XB",0))
177 Q:'I "??"
178 S V=$O(^DIC(9.4,I,22,"B",$P($T(+2),";",3),0))
179 Q:'V "??"
180 S P=0
181 F %=0:0 S %=$O(^DIC(9.4,I,22,V,"PAH",%)) Q:'% I $P(^(%,0),"^",1)>P S P=$P(^(0),"^",1)
182 Q P
183 ;End New Code;IHS/SET/GTH XB*3*9 10/29/2002
Note: See TracBrowser for help on using the repository browser.