source: IHS-VA_UTILITIES-XB/ZIBRSEL.m@ 641

Last change on this file since 641 was 641, checked in by Sam Habiel, 14 years ago

Initial commit of XB, move away from sf.net.
Includes kids file and documentation.
File size: 2.7 KB
Line 
1ZIBRSEL ; IHS/ADC/GTH - NONINTERACTIVE ROUTINE SELECT ; [ 10/29/2002 7:42 AM ]
2 ;;4.0;XB;;Jul 20, 2009;Build 2
3 ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
4 ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods.
5 ;
6 ; Return the number of selected routines set into the
7 ; indicated variable.
8 ;
9 ; E.g.:
10 ; I '$$RSEL^ZIBRSEL("B-BZZZZZZZ","ARRAY(") W "NONE SELECTED" Q
11 ;
12 ; If routines exists in the list or range, their name will
13 ; be returned as the last subscript of indicated variable in
14 ; the 2nd parameter. The default is ^TMP("ZIBRSEL",$J,
15 ;
16 ; If routine B exists, then node ^TMP("ZIBRSEL",$J,"B") will
17 ; be null.
18 ;
19 ; It is the programmer's responsibility to ensure the name
20 ; of the array is correctly formed.
21 ;
22 ; Variables used:
23 ; X = String indicating list or range of routines.
24 ; Y = String indicating variable into which to set the
25 ; selected routines. Default = ^TMP("ZIBRSEL",$J,
26 ; F = First routine, if range.
27 ; L = Last routine, if range.
28 ; N = Number of routines returned.
29 ; Q = Quote character.
30 ;
31 Q
32 ;
33RSEL(X,Y) ;PEP - Select a list or range of routines, return in Y, # sel in N.
34 I '$L($G(X)) Q "NO ROUTINES SPECIFIED IN PARAMETER"
35 NEW F,L,N,O,Q
36 ; S O=$P(^%ZOSF("OS"),"-",1) ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
37 ;S O=$P(^%ZOSF("OS"),"^",1) ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err. ;IHS/SET/GTH XB*3*9 10/29/2002
38 ;I O["MSM" S O="MSM" ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err. ;IHS/SET/GTH XB*3*9 10/29/2002
39 ;E S O="unknown" ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err. ;IHS/SET/GTH XB*3*9 10/29/2002
40 ;I '$L($T(@O)) Q "OPERATING SYSTEM '"_O_"' NOT SUPPORTED." ;IHS/SET/GTH XB*3*9 10/29/2002
41 S O=$$VERSION^%ZOSV(1),O=$P(O," ") ;IHS/SET/GTH XB*3*9 10/29/2002
42 I '(O["Cache"),'(O["MSM") Q "OPERATING SYSTEM '"_O_"' NOT SUPPORTED." ;IHS/SET/GTH XB*3*9 10/29/2002
43 I '$L($G(Y)) KILL ^TMP("ZIBRSEL",$J) S Y="^TMP(""ZIBRSEL"","_$J_","
44 S F=$P(X,"-"),L=$P(X,"-",2),N=0,Q=""""
45 I '(F]"") Q 0
46 I F["*" S F=$P(F,"*"),L="*",X=$P(X,"*")
47 ;D @O ;IHS/SET/GTH XB*3*9 10/29/2002
48 D DIR ;IHS/SET/GTH XB*3*9 10/29/2002
49 Q N
50 ;
51DIR ; Check the directory ;IHS/SET/GTH XB*3*9 10/29/2002
52MSM ; Micronetics Standard MUMPS.
53 ;I F]"",$D(^ (F)) S N=N+1,@(Y_Q_F_Q_")")="" ;IHS/SET/GTH XB*3*9 10/29/2002
54 I F]"",$D(^$R(F)) S N=N+1,@(Y_Q_F_Q_")")="" ;IHS/SET/GTH XB*3*9 10/29/2002
55 I L="*" D Q
56 . ; F S F=$O(^ (F)) Q:F=""!('(X=$E(F,1,$L(X)))) S N=N+1,@(Y_Q_F_Q_")")="" ;IHS/SET/GTH XB*3*9 10/29/2002
57 . F S F=$O(^$R(F)) Q:F=""!('(X=$E(F,1,$L(X)))) S N=N+1,@(Y_Q_F_Q_")")="" ;IHS/SET/GTH XB*3*9 10/29/2002
58 .Q
59 ; F S F=$O(^ (F)) Q:F=""!(F]L) S N=N+1,@(Y_Q_F_Q_")")="" Q:L="" ;IHS/SET/GTH XB*3*9 10/29/2002
60 F S F=$O(^$R(F)) Q:F=""!(F]L) S N=N+1,@(Y_Q_F_Q_")")="" Q:L="" ;IHS/SET/GTH XB*3*9 10/29/2002
61 Q
62 ;
Note: See TracBrowser for help on using the repository browser.