ZIBFR.m

ZIBFR ; IHS/ADC/GTH - LIST UCI'S FOR A GIVEN ROUTINE ; [ 10/29/2002   7:42 AM ]

 ;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997

 ; 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

 ;

ZIBFR     ; IHS/ADC/GTH - LIST UCI'S FOR A GIVEN ROUTINE ; [ 10/29/2002   7:42 AM ]

 +1       ;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997

 +2       ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods.

 +3       ;

 +4       ; Given a routine name, this routine searches all UCIs and

 +5       ; reports the first line of the selected routine to the user.

 +6       ;

EN        ;

 +1       ;Q:'($ZV?1"MSM".E!($ZV?1"DSM".E))  ; Only works for MSM or DSM.;IHS/SET/GTH XB*3*9 10/29/2002

 +2       ;IHS/SET/GTH XB*3*9 10/29/2002

           SET %=$$VERSION^%ZOSV(1)

           IF '(%["Cache")

               IF '(%["MSM")

                   QUIT 

 +3        READ !,"Please enter full routine name to locate: ",%ZIB("RTN NAME"):$GET(DTIME,300),!

 +4       ; G:"^"[%ZIB("RTN NAME") EX ;IHS/SET/GTH XB*3*9 10/29/2002

 +5       ;IHS/SET/GTH XB*3*9 10/29/2002

           IF "^"[%ZIB("RTN NAME")

               GOTO EXIT

 +6       ;IHS/SET/GTH XB*3*9 10/29/2002

           IF %ZIB("RTN NAME")["^"

               SET %ZIB("RTN NAME")=$PIECE(%ZIB("RTN NAME"),"^",2)

 +7       ; Set operating system.

           SET %ZIB("OP SYS")=$ZV

 +8       ;IHS/SET/GTH XB*3*9 10/29/2002

           IF %ZIB("OP SYS")["Cache"

               GOTO CACHE

 +9       ; Save current UCI nbr.

           SET %ZIB("CURR UCI NBR")=$PIECE($ZU($PIECE($ZU(0),","),$PIECE($ZU(0),",",2)),",")

 +10      ; Save current VOL nbr.

           SET %ZIB("CURR VOL NBR")=$PIECE($ZU($PIECE($ZU(0),","),$PIECE($ZU(0),",",2)),",",2)

 +11      ; S:%ZIB("RTN NAME")["^" %ZIB("RTN NAME")=$P(%ZIB("RTN NAME"),"^",2) ;IHS/SET/GTH XB*3*9 10/29/2002

 +12      ; Loop until last UCI of last VOLUME SET.

           Begin DoDot:1

 +13      ; Set error trap for DSM <NOSYS>.

               SET $ZT="ZT"

 +14           FOR %ZIB("VOL NBR")=0:1

                   IF $ZU(1,%ZIB("VOL NBR"))!($ZU(1,%ZIB("VOL NBR"))="")

                       QUIT 

                   Begin DoDot:2

 +15      ; Set error trap for DSM <NOUCI>.

                       SET $ZT="ZT"

 +16                   FOR %ZIB("UCI NBR")=1:1

                           IF $ZU(%ZIB("UCI NBR"),%ZIB("VOL NBR"))!($ZU(%ZIB("UCI NBR"),%ZIB("VOL NBR"))="")

                               QUIT 

                           Begin DoDot:3

 +17      ; MGR routine.

                               IF $EXTRACT(%ZIB("RTN NAME"))="%"&(%ZIB("UCI NBR")'=1)

                                   QUIT 

 +18                           IF %ZIB("OP SYS")?1"MSM".E

                                   Begin DoDot:4

 +19      ; MSM switch to next UCI.

                                       VIEW 2:$JOB:%ZIB("VOL NBR")*32+%ZIB("UCI NBR"):2

                                   End DoDot:4

 +20      ; DSM switch to next UCI.

                              IF '$TEST

                                   VIEW 148:$JOB:$VIEW(148,$JOB)#256+(%ZIB("VOL NBR")*32+%ZIB("UCI NBR"))*256

 +21                           SET X=%ZIB("RTN NAME")

 +22                           XECUTE ^%ZOSF("TEST")

 +23                          IF $TEST

                                   Begin DoDot:4

 +24                                   XECUTE "ZL @%ZIB(""RTN NAME"") S %ZIB(""RTN FIRST LINE"")=$T(+1)"

 +25                                   WRITE !!,$ZU(0),?10,"Routine - ",%ZIB("RTN NAME")," - was last saved on ",$PIECE($PIECE(%ZIB("RTN FIRST LINE"),"[",2),"]")

 +26      ; Display first line of routine.

                                       WRITE !,%ZIB("RTN FIRST LINE")

                                   End DoDot:4

                           End DoDot:3

                   End DoDot:2

           End DoDot:1

 +27      ; Return to current UCI MSM.

           IF %ZIB("OP SYS")?1"MSM".E

               VIEW 2:$JOB:%ZIB("CURR VOL NBR")*32+%ZIB("CURR UCI NBR"):2

 +28      ; Return to current UCI DSM.

          IF '$TEST

               VIEW 148:$JOB:$VIEW(148,$JOB)#256+(%ZIB("CURR VOL NBR")*32+%ZIB("CURR UCI NBR"))*256)

EXIT      ;IHS/SET/GTH XB*3*9 10/29/2002 Label EX changed to EXIT.

 +1        KILL %ZIB

ENQ       ;

 +1        QUIT 

 +2       ;Begin New Code;IHS/SET/GTH XB*3*9 10/29/2002

CACHE     ;

 +1        SET $ZT="BACK^%ETN"

 +2        SET %ZIB("CURR NSP")=$ZU(5)

 +3        FOR I=1:1:$ZU(90,0)

               SET ZIBLIST($ZU(90,2,0,I))=""

 +4        SET ZIBFUCI=""

           FOR 

               SET ZIBFUCI=$ORDER(ZIBLIST(ZIBFUCI))

               IF ZIBFUCI=""

                   QUIT 

               Begin DoDot:1

 +5                IF $ZU(5,ZIBFUCI)

 +6                SET X=%ZIB("RTN NAME")

 +7                XECUTE "I X?1(1""%"",1A).7AN,$D(^$R(X))"

 +8               IF $TEST

                       Begin DoDot:2

 +9                        XECUTE "ZL @%ZIB(""RTN NAME"") S %ZIB(""RTN FIRST LINE"")=$T(+1),%ZIB(""RTN SECOND LINE"")=$T(+2)"

 +10                       WRITE !!,$ZU(5),?10,"Routine - ",%ZIB("RTN NAME")," - was last compiled on ",$$CDATE(%ZIB("RTN NAME"))

 +11      ; Display first line of routine.

                           WRITE !,%ZIB("RTN FIRST LINE")

 +12      ; Display second line

                           WRITE !,%ZIB("RTN SECOND LINE"),!

                       End DoDot:2

               End DoDot:1

 +13      ; Go back to original Namespace

           IF $ZU(5,%ZIB("CURR NSP"))

 +14       DO EN^XBVK("ZIB")

 +15       KILL I,X

 +16       GOTO EXIT

 +17      ;

CDATE(%ZIBRTN) ; retrieve date of last edit on Cache only

 +1        QUIT $$DATE^%R(%ZIBRTN_".INT",1)

 +2       ;

 +3       ;End New Code;IHS/SET/GTH XB*3*9 10/29/2002

ZT        ; ERROR TRAP

 +1        IF $ZE["<NOSYS"!($ZE["<NOUCI")

               QUIT 

ZTQ       ;

 +1 

*** ERROR ***

 +2       ;