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