184 lines
5.4 KiB
Mathematica
184 lines
5.4 KiB
Mathematica
XB ; IHS/ADC/GTH - UTILITY MENU ; [ 04/28/2003 9:38 AM ]
|
|
;;4.0;XB;;Jul 20, 2009;Build 2
|
|
;
|
|
; SEE ROUTINE XB1 FOR FURTHER DOCUMENTATION AND THE MENU
|
|
; OPTIONS.
|
|
;
|
|
; This routine lists available utilities in the form of a
|
|
; menu with a brief description of what the utility does.
|
|
; New utilities may be added to this routine by adding the
|
|
; appropriate ";;" entries to the bottom of routine XB1.
|
|
;
|
|
START ;
|
|
I '$D(^%ZOSF("TEST"))!('$D(^%ZOSF("TRAP"))) W !!,"Missing ^%ZOSF nodes!",! Q
|
|
S X="%ZIS"
|
|
D RCHK
|
|
I XBFAIL D EOJ Q
|
|
D ^XBKSET
|
|
S X="XBRPTL"
|
|
D RCHK
|
|
S:XBFAIL XBNH=""
|
|
S XBLBL="M",XBQ=0
|
|
F D MENU Q:XBQ
|
|
D EOJ
|
|
Q
|
|
;
|
|
MENU ;
|
|
D LIST
|
|
W !!,"Choose: "
|
|
R XBY:$G(DTIME,999)
|
|
S:XBY="^" XBY=""
|
|
I XBY["?" D HELP Q
|
|
I XBY="" S XBQ=1 Q
|
|
I XBY'=+XBY D LETTERS
|
|
I XBY'<1,XBY'>(XBI-1) D OPTION D:XBP="P" PAUSE S XBP="" Q
|
|
W *7
|
|
Q
|
|
;
|
|
HELP ;
|
|
I XBY="?" D Q
|
|
. S XBH=""
|
|
. D LIST
|
|
. KILL XBH
|
|
. W !!,"To get help on a non-menu option enter '?n' where n is the option number.",!
|
|
. D PAUSE
|
|
.Q
|
|
I XBY?1"?"1N.N S XBY=$P(XBY,"?",2) I XBY,XBY'>(XBI-1) D D PAUSE Q
|
|
. I $D(XBNH) W !!,"No help available. Routine ^XBRPTL not in UCI.",! Q
|
|
. KILL ^UTILITY($J)
|
|
. S XBX=$P($T(@XBLBL+XBY^XB1),";;",3)
|
|
. I XBX W !!,"No help available for menus." Q
|
|
. I XBX?1"!".E W !!,"No help available for executable code :",!,"[",$E(XBX,2,99),"]." Q
|
|
. S XBX=$P(XBX,"^",2),X=XBX
|
|
. D RCHK
|
|
. I XBFAIL W !!,"No help available. Routine ^",XBX," not in ",$S($E(XBX)="%":"MGR",1:"UCI"),".",! Q
|
|
. S %=$$RSEL^ZIBRSEL(XBX,"^UTILITY($J,")
|
|
. D EN^XBRPTL
|
|
. KILL ^UTILITY($J)
|
|
.Q
|
|
W *7
|
|
Q
|
|
;
|
|
LIST ; List menu options.
|
|
KILL XBTBL
|
|
;W !!?5,$P($T(XB+1),";",4)," v ",$$CV^XBFUNC("XB");IHS/SET/GTH XB*3*9 10/29/2002
|
|
W !!?5,$P($T(XB+1),";",4)," v ",$$VERSION^XPDUTL("XB") ;IHS/SET/GTH XB*3*9 10/29/2002
|
|
W !!?5,$P($T(@XBLBL^XB1),";;",2),!
|
|
F XBI=1:1 S XBX=$T(@XBLBL+XBI^XB1) Q:$E(XBX)'=" " S XBY=$P(XBX,";;",3),XBX=$P(XBX,";;",2) D
|
|
. S X=$$UP^XLFSTR(XBX)
|
|
. S XBTBL(X)=XBI_"^"_XBX
|
|
. W !,XBI,?5,XBX," ",$S($D(XBH):$S(XBY:"[menu]",1:XBY),1:$S(XBY:"[menu]",1:""))
|
|
.Q
|
|
Q
|
|
;
|
|
LETTERS ;
|
|
KILL XBC
|
|
S XBY=$$UP^XLFSTR(XBY)
|
|
I $D(XBTBL(XBY)) S XBY=XBTBL(XBY) Q
|
|
S XBC=0,X=XBY
|
|
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)
|
|
W !
|
|
I XBC=0 S XBY=0 Q
|
|
I XBC=1 S XBY=$P(XBC(1),"^",1) Q
|
|
F I=1:1:XBC W !,I," ",$P(XBC(I),"^",2)
|
|
W !!,"Which one? "
|
|
R XBY:$G(DTIME,999)
|
|
I XBY]"",$D(XBC(XBY)) W " ",$P(XBC(XBY),"^",2) S XBY=$P(XBC(XBY),"^",1) Q
|
|
W *7
|
|
S XBY=0
|
|
Q
|
|
;
|
|
OPTION ;
|
|
S XBX=$T(@XBLBL+XBY^XB1),XBP=$P(XBX,";;",4),XBX=$P(XBX,";;",3)
|
|
I XBX D RECURSE Q
|
|
W !
|
|
I XBX?1"!".E S XBX=$E(XBX,2,250)
|
|
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
|
|
S X="TRAP^XB",@^%ZOSF("TRAP")
|
|
; D ^XBNEW("CALL^XB:XBX;DT;DTIME;U;DUZ") ;IHS/SET/GTH XB*3*9 10/29/2002
|
|
D EN^XBNEW("CALL^XB","XBX;DT;DTIME;U;DUZ") ;IHS/SET/GTH XB*3*9 10/29/2002
|
|
Q
|
|
;
|
|
CALL ;
|
|
S IOP=$I
|
|
D ^%ZIS
|
|
X XBX
|
|
U 0
|
|
Q
|
|
;
|
|
RECURSE ;
|
|
I $L(XBLBL)>6 W !,"Maximum menu depth exceeded." S XBQ=1 Q
|
|
S XBLBL=XBLBL_XBX
|
|
W !
|
|
F D MENU Q:XBQ
|
|
S XBQ=0,XBLBL=$E(XBLBL,1,$L(XBLBL)-1)
|
|
W !
|
|
Q
|
|
;
|
|
TRAP ; ERROR TRAP
|
|
W !!,"The following error has occurred: ",$$Z^ZIBNSSV("ERROR"),!
|
|
D:XBP="" PAUSE
|
|
Q
|
|
;
|
|
PAUSE ;EP
|
|
Q:'(IO=IO(0))
|
|
Q:'($E(IOST,1,2)="C-")
|
|
S Y=$$DIR^XBDIR("EO")
|
|
S:$D(DUOUT) XBQ=1
|
|
Q
|
|
;
|
|
CHECK ; CHECK XB OPTION ROUTINES (EXECUTED FROM ^XB MENU OPTION)
|
|
W !,"Patch ",$$PATS," is the highest XB/ZIB patch installed." ;IHS/SET/GTH XB*3*9 10/29/2002
|
|
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
|
|
. I X'?.8UN1"^"1.8UN,X'?.8UN1"^"1"%"1.7UN S XBII(4,XBII)=$P($T(M+XBII^XB1),";;",2,9) Q
|
|
. S X=$P(X,"^",2)
|
|
. D RCHK
|
|
. I XBFAIL S XBII($S($E(X)'="%":1,$E(X,2,4)="ZIB":2,1:3),X)=""
|
|
.Q
|
|
I '$O(XBII(0)) W !,"All options seem to be ok.",! KILL XBII Q
|
|
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
|
|
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
|
|
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
|
|
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)
|
|
W !
|
|
KILL XBII
|
|
Q
|
|
;
|
|
RCHK ;EP - Check Existence of Routine in X
|
|
S XBRTN=X,XUSLNT=1
|
|
; I $E(XBRTN)="%" X ^%ZOSF("UCI") S XBUCI=Y,%UCI="MGR" D 2^%XUCI ; IHS/SET/GTH XB*3*9 10/29/2002
|
|
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
|
|
S X=XBRTN
|
|
X ^%ZOSF("TEST")
|
|
S XBFAIL='$T
|
|
; I $E(XBRTN)="%" S %UCI=XBUCI D 2^%XUCI ; IHS/SET/GTH XB*3*9 10/29/2002
|
|
I ^%ZOSF("OS")["MSM",$E(XBRTN)="%" S %UCI=XBUCI D 2^%XUCI ; IHS/SET/GTH XB*3*9 10/29/2002
|
|
W:XBFAIL !!,"Routine ",XBRTN," missing!"
|
|
S X=XBRTN
|
|
KILL XUSLNT
|
|
Q
|
|
;
|
|
EOJ ;
|
|
D ^XBKTMP,EN^XBVK("XB")
|
|
KILL ^UTILITY($J)
|
|
KILL DIRUT,DTOUT,DUOUT
|
|
KILL X,Y
|
|
Q
|
|
;
|
|
OSNO ;EP
|
|
W $C(7),!,"Sorry...",!,"Operating System '",$P(^%ZOSF("OS"),"^",1),"' is not supported."
|
|
I $$DIR^XBDIR("EO","Press RETURN") ;IHS/SET/GTH XB*3*9 10/29/2002
|
|
Q
|
|
;
|
|
;Begin New Code;IHS/SET/GTH XB*3*9 10/29/2002
|
|
PATS() ;Display patches installed for XB.
|
|
NEW I,P,V
|
|
S I=$O(^DIC(9.4,"C","XB",0))
|
|
Q:'I "??"
|
|
S V=$O(^DIC(9.4,I,22,"B",$P($T(+2),";",3),0))
|
|
Q:'V "??"
|
|
S P=0
|
|
F %=0:0 S %=$O(^DIC(9.4,I,22,V,"PAH",%)) Q:'% I $P(^(%,0),"^",1)>P S P=$P(^(0),"^",1)
|
|
Q P
|
|
;End New Code;IHS/SET/GTH XB*3*9 10/29/2002
|