VistA-IHS-VA_UTILITIES-XB/XB.m

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