source: IHS-VA_UTILITIES-XB/trunk/ZIBFR.m@ 1119

ZIBFR   ; IHS/ADC/GTH - LIST UCI'S FOR A GIVEN ROUTINE ; [ 10/29/2002   7:42 AM ]
        ;;4.0;XB;;Jul 20, 2009;Build 2
        ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods.
        ;
        ; Given a routine name, this routine searches all UCIs and
        ; reports the first line of the selected routine to the user.
        ;
EN      ;
        ;Q:'($ZV?1"MSM".E!($ZV?1"DSM".E))  ; Only works for MSM or DSM.;IHS/SET/GTH XB*3*9 10/29/2002
        S %=$$VERSION^%ZOSV(1) I '(%["Cache"),'(%["MSM") Q  ;IHS/SET/GTH XB*3*9 10/29/2002
        R !,"Please enter full routine name to locate: ",%ZIB("RTN NAME"):$G(DTIME,300),!
        ; G:"^"[%ZIB("RTN NAME") EX ;IHS/SET/GTH XB*3*9 10/29/2002
        G:"^"[%ZIB("RTN NAME") EXIT ;IHS/SET/GTH XB*3*9 10/29/2002
        S:%ZIB("RTN NAME")["^" %ZIB("RTN NAME")=$P(%ZIB("RTN NAME"),"^",2) ;IHS/SET/GTH XB*3*9 10/29/2002
        S %ZIB("OP SYS")=$ZV ; Set operating system.
        I %ZIB("OP SYS")["Cache" G CACHE ;IHS/SET/GTH XB*3*9 10/29/2002
        S %ZIB("CURR UCI NBR")=$P($ZU($P($ZU(0),","),$P($ZU(0),",",2)),",") ; Save current UCI nbr.
        S %ZIB("CURR VOL NBR")=$P($ZU($P($ZU(0),","),$P($ZU(0),",",2)),",",2) ; Save current VOL nbr.
        ; S:%ZIB("RTN NAME")["^" %ZIB("RTN NAME")=$P(%ZIB("RTN NAME"),"^",2) ;IHS/SET/GTH XB*3*9 10/29/2002
        D  ; Loop until last UCI of last VOLUME SET.
        . S $ZT="ZT" ; Set error trap for DSM <NOSYS>.
        . F %ZIB("VOL NBR")=0:1 Q:$ZU(1,%ZIB("VOL NBR"))!($ZU(1,%ZIB("VOL NBR"))="")  D
        .. S $ZT="ZT" ; Set error trap for DSM <NOUCI>.
        .. F %ZIB("UCI NBR")=1:1 Q:$ZU(%ZIB("UCI NBR"),%ZIB("VOL NBR"))!($ZU(%ZIB("UCI NBR"),%ZIB("VOL NBR"))="")  D
        ... Q:$E(%ZIB("RTN NAME"))="%"&(%ZIB("UCI NBR")'=1)  ; MGR routine.
        ... I %ZIB("OP SYS")?1"MSM".E D
        .... V 2:$J:%ZIB("VOL NBR")*32+%ZIB("UCI NBR"):2 ; MSM switch to next UCI.
        ... E  V 148:$J:$V(148,$J)#256+(%ZIB("VOL NBR")*32+%ZIB("UCI NBR"))*256 ; DSM switch to next UCI.
        ... S X=%ZIB("RTN NAME")
        ... X ^%ZOSF("TEST")
        ... I  D
        .... X "ZL @%ZIB(""RTN NAME"") S %ZIB(""RTN FIRST LINE"")=$T(+1)"
        .... W !!,$ZU(0),?10,"Routine - ",%ZIB("RTN NAME")," - was last saved on ",$P($P(%ZIB("RTN FIRST LINE"),"[",2),"]")
        .... W !,%ZIB("RTN FIRST LINE") ; Display first line of routine.
        I %ZIB("OP SYS")?1"MSM".E V 2:$J:%ZIB("CURR VOL NBR")*32+%ZIB("CURR UCI NBR"):2 ; Return to current UCI MSM.
        E  V 148:$J:$V(148,$J)#256+(%ZIB("CURR VOL NBR")*32+%ZIB("CURR UCI NBR"))*256) ; Return to current UCI DSM.
EXIT    ;IHS/SET/GTH XB*3*9 10/29/2002 Label EX changed to EXIT.
        KILL %ZIB
ENQ     ;
        Q
        ;Begin New Code;IHS/SET/GTH XB*3*9 10/29/2002
CACHE   ;
        S $ZT="BACK^%ETN"
        S %ZIB("CURR NSP")=$ZU(5)
        F I=1:1:$ZU(90,0) S ZIBLIST($ZU(90,2,0,I))=""
        S ZIBFUCI="" F  S ZIBFUCI=$O(ZIBLIST(ZIBFUCI)) Q:ZIBFUCI=""  D
        .I $ZU(5,ZIBFUCI)
        .S X=%ZIB("RTN NAME")
        .X "I X?1(1""%"",1A).7AN,$D(^$R(X))"
        .I  D
        ..X "ZL @%ZIB(""RTN NAME"") S %ZIB(""RTN FIRST LINE"")=$T(+1),%ZIB(""RTN SECOND LINE"")=$T(+2)"
        ..W !!,$ZU(5),?10,"Routine - ",%ZIB("RTN NAME")," - was last compiled on ",$$CDATE(%ZIB("RTN NAME"))
        ..W !,%ZIB("RTN FIRST LINE") ; Display first line of routine.
        ..W !,%ZIB("RTN SECOND LINE"),!  ; Display second line
        I $ZU(5,%ZIB("CURR NSP"))     ; Go back to original Namespace
        D EN^XBVK("ZIB")
        KILL I,X
        G EXIT
        ;
CDATE(%ZIBRTN)  ; retrieve date of last edit on Cache only
        Q $$DATE^%R(%ZIBRTN_".INT",1)
        ;
        ;End New Code;IHS/SET/GTH XB*3*9 10/29/2002
ZT      ; ERROR TRAP
        Q:$ZE["<NOSYS"!($ZE["<NOUCI")
ZTQ     ;
        ZQ
        ;