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

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