XB.m

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

 ;

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

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      ;

MENU      ;

 +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