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

Last change on this file since 1562 was 642, checked in by Sam Habiel, 15 years ago

Modified directory structure; moved routines.

File size: 3.2 KB
RevLine 
[641]1ZIBFR ; IHS/ADC/GTH - LIST UCI'S FOR A GIVEN ROUTINE ; [ 10/29/2002 7:42 AM ]
2 ;;4.0;XB;;Jul 20, 2009;Build 2
3 ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods.
4 ;
5 ; Given a routine name, this routine searches all UCIs and
6 ; reports the first line of the selected routine to the user.
7 ;
8EN ;
9 ;Q:'($ZV?1"MSM".E!($ZV?1"DSM".E)) ; Only works for MSM or DSM.;IHS/SET/GTH XB*3*9 10/29/2002
10 S %=$$VERSION^%ZOSV(1) I '(%["Cache"),'(%["MSM") Q ;IHS/SET/GTH XB*3*9 10/29/2002
11 R !,"Please enter full routine name to locate: ",%ZIB("RTN NAME"):$G(DTIME,300),!
12 ; G:"^"[%ZIB("RTN NAME") EX ;IHS/SET/GTH XB*3*9 10/29/2002
13 G:"^"[%ZIB("RTN NAME") EXIT ;IHS/SET/GTH XB*3*9 10/29/2002
14 S:%ZIB("RTN NAME")["^" %ZIB("RTN NAME")=$P(%ZIB("RTN NAME"),"^",2) ;IHS/SET/GTH XB*3*9 10/29/2002
15 S %ZIB("OP SYS")=$ZV ; Set operating system.
16 I %ZIB("OP SYS")["Cache" G CACHE ;IHS/SET/GTH XB*3*9 10/29/2002
17 S %ZIB("CURR UCI NBR")=$P($ZU($P($ZU(0),","),$P($ZU(0),",",2)),",") ; Save current UCI nbr.
18 S %ZIB("CURR VOL NBR")=$P($ZU($P($ZU(0),","),$P($ZU(0),",",2)),",",2) ; Save current VOL nbr.
19 ; S:%ZIB("RTN NAME")["^" %ZIB("RTN NAME")=$P(%ZIB("RTN NAME"),"^",2) ;IHS/SET/GTH XB*3*9 10/29/2002
20 D ; Loop until last UCI of last VOLUME SET.
21 . S $ZT="ZT" ; Set error trap for DSM <NOSYS>.
22 . F %ZIB("VOL NBR")=0:1 Q:$ZU(1,%ZIB("VOL NBR"))!($ZU(1,%ZIB("VOL NBR"))="") D
23 .. S $ZT="ZT" ; Set error trap for DSM <NOUCI>.
24 .. F %ZIB("UCI NBR")=1:1 Q:$ZU(%ZIB("UCI NBR"),%ZIB("VOL NBR"))!($ZU(%ZIB("UCI NBR"),%ZIB("VOL NBR"))="") D
25 ... Q:$E(%ZIB("RTN NAME"))="%"&(%ZIB("UCI NBR")'=1) ; MGR routine.
26 ... I %ZIB("OP SYS")?1"MSM".E D
27 .... V 2:$J:%ZIB("VOL NBR")*32+%ZIB("UCI NBR"):2 ; MSM switch to next UCI.
28 ... E V 148:$J:$V(148,$J)#256+(%ZIB("VOL NBR")*32+%ZIB("UCI NBR"))*256 ; DSM switch to next UCI.
29 ... S X=%ZIB("RTN NAME")
30 ... X ^%ZOSF("TEST")
31 ... I D
32 .... X "ZL @%ZIB(""RTN NAME"") S %ZIB(""RTN FIRST LINE"")=$T(+1)"
33 .... W !!,$ZU(0),?10,"Routine - ",%ZIB("RTN NAME")," - was last saved on ",$P($P(%ZIB("RTN FIRST LINE"),"[",2),"]")
34 .... W !,%ZIB("RTN FIRST LINE") ; Display first line of routine.
35 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.
36 E V 148:$J:$V(148,$J)#256+(%ZIB("CURR VOL NBR")*32+%ZIB("CURR UCI NBR"))*256) ; Return to current UCI DSM.
37EXIT ;IHS/SET/GTH XB*3*9 10/29/2002 Label EX changed to EXIT.
38 KILL %ZIB
39ENQ ;
40 Q
41 ;Begin New Code;IHS/SET/GTH XB*3*9 10/29/2002
42CACHE ;
43 S $ZT="BACK^%ETN"
44 S %ZIB("CURR NSP")=$ZU(5)
45 F I=1:1:$ZU(90,0) S ZIBLIST($ZU(90,2,0,I))=""
46 S ZIBFUCI="" F S ZIBFUCI=$O(ZIBLIST(ZIBFUCI)) Q:ZIBFUCI="" D
47 .I $ZU(5,ZIBFUCI)
48 .S X=%ZIB("RTN NAME")
49 .X "I X?1(1""%"",1A).7AN,$D(^$R(X))"
50 .I D
51 ..X "ZL @%ZIB(""RTN NAME"") S %ZIB(""RTN FIRST LINE"")=$T(+1),%ZIB(""RTN SECOND LINE"")=$T(+2)"
52 ..W !!,$ZU(5),?10,"Routine - ",%ZIB("RTN NAME")," - was last compiled on ",$$CDATE(%ZIB("RTN NAME"))
53 ..W !,%ZIB("RTN FIRST LINE") ; Display first line of routine.
54 ..W !,%ZIB("RTN SECOND LINE"),! ; Display second line
55 I $ZU(5,%ZIB("CURR NSP")) ; Go back to original Namespace
56 D EN^XBVK("ZIB")
57 KILL I,X
58 G EXIT
59 ;
60CDATE(%ZIBRTN) ; retrieve date of last edit on Cache only
61 Q $$DATE^%R(%ZIBRTN_".INT",1)
62 ;
63 ;End New Code;IHS/SET/GTH XB*3*9 10/29/2002
64ZT ; ERROR TRAP
65 Q:$ZE["<NOSYS"!($ZE["<NOUCI")
66ZTQ ;
67 ZQ
68 ;
Note: See TracBrowser for help on using the repository browser.