source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/ARJTDIM3.m@ 1042

Last change on this file since 1042 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 5.4 KB
Line 
1ARJTDIM3 ;SFISC/JFW,GFT,TOAD-FileMan: M Syntax Checker, Commands ;7/19/02 16:29
2 ;;1.0T5;ZZD ANALYSIS TOOL;;Jul 20, 2000
3 ;
4DG ; DO and GET (D^ARJTDIM and G^ARJTDIM)
5 G GC^ARJTDIM:%ARG=""!%ERR D PARS G ER:%ERR
6 S %L=":" D PARS1 G ER:%ERR
7 I %C=%L G ER:%A1="" S %=%A1 D ^ARJTDIM1
8 I $E(%A)="&" D ; although disallowed, capture external reference
9 . N REF S REF=$E(%A,1,$F(%A,"(")-2)
10 . I REF="" S REF=$E(%A,1,$F(%A,",")-2)
11 . I REF="" S REF=%A
12 . I REF[".",$P(REF,".",2)'="" S REF=$P(REF,".",2)
13 . D DSM("&",REF,FIND,.FOUND)
14 I %A["@^" S %=%A D ^ARJTDIM1 G DG
15 I %A["(",$E(%A)'="@",$E($P(%A,"^",2))'="@" D G ER:%ERR
16 . I %COM'="D" S %ERR=1 Q
17 . S %=%A
18 . I %'?.E1"(".E1")" S %ERR=1 Q
19 . S %C=$P(%,"("),%C1=$P(%C,"^",2,999),%I=$F(%,"(")-1
20 . I %C=""!(%C?.E1"^") S %ERR=1 Q
21 . I %C1]"",%C1'?1U.7AN,%C1'?1"%".7AN S %ERR=1 Q
22 . S %C=$P(%C,"^") I %C]"",%C'?1U.7AN,%C'?1"%".7AN,%C'?1.8N S %ERR=1 Q
23 . Q:$E(%,%I,%I+1)="()"
24 . S (%(-1,2),%(-1,3))=0,%N=1,%(0,0)="P^",(%(0,1),%(0,2),%(0,3))=0
25 . D GG^ARJTDIM1
26 E D LABEL(0)
27 G DG
28 ;
29LABEL(OFFSET) ; labelref, entryref, and $TEXT argument (DG and TEXT^ARJTDIM1)
30 S %L="^" D PARS1 Q:%ERR ; split the argument at the ^
31 I %C=%L D Q:%ERR ; if the arg starts with ^
32 . I $E(%A1)="%",$E(%A1,2)'="Z","^%DT^%DTC^%RCR^%XUCI^"'[(U_%A1_U) D
33 . . D DSM(,%A1,FIND,.FOUND)
34 . S:%A1=""!($E(%A1)="^") %ERR=1 ; ^ alone or ^^anything are bad
35 . S %=%A1 D VV ; validate the name
36 . D ^ARJTDIM1 ; handle parameter list?
37 S %=%A D VV:%'=+%&'OFFSET
38 D ^ARJTDIM1
39 Q
40 ;
41KL ; KILL, LOCK, and NEW (K^ARJTDIM and LK)
42 D PARS G ER:%ERR
43 I %A="",%C="," G ER
44 I %A?1"^"1UP.UN,%COM'="L" G ER
45 I %A?1"(".E1")" D G KL
46 . S %ARG("E")=$L(%ARG)
47 . S %A=$E(%A,2,$L(%A)-1) S %ARG=%A_$S(%ARG]"":","_%ARG,1:"")
48 S %=%A I %COM="L","+-"[$E(%A) S $E(%A)=""
49 I %COM="N",'$$LNAME(%) G ER
50 I %COM="K",$D(%ARG("E")),'$$LNAME(%) G ER
51 I $D(%ARG("E")),$L(%ARG)'>%ARG("E") K %ARG("E")
52 D VV,^ARJTDIM1 G GC^ARJTDIM:%ARG=""!%ERR
53 G KL
54 ;
55LK ; LOCK (L^ARJTDIM)
56 S %A=%ARG,%L=":" S:"+-"[$E(%A) %A=$E(%A,2,999) D PARS1
57 I %C=%L G ER:%A1="" S %=%A1 D ^ARJTDIM1
58 S %ARG=%A G GC^ARJTDIM:%A="",KL
59 ;
60HN ; HANG (H^ARJTDIM)
61 S %=%ARG D ^ARJTDIM1 G GC^ARJTDIM
62 ;
63OP ; OPEN and USE (O^ARJTDIM and U^ARJTDIM)
64 G GC^ARJTDIM:%ARG=""!%ERR
65 D PARS G ER:%ERR!(%C=","&(%A=""))
66 G US:%COM="U"
67 ;
68 S %L=":" D PARS1
69 S %A2=%A,%A=%A1 S:%C=%L&(%A="") %ERR=1 D PARS1 G ER:%ERR!(%C=%L&(%A1=""))
70 ;
71 F %L="%A1","%A2" S %=@%L D ^ARJTDIM1 G OP:%ERR
72 G OP
73 ;
74US S %L=":" D PARS1 G ER:%C=%L&(%A1="")
75 I %A'="IO",%A'="IO(0)" D DSM(,"USE",FIND,.FOUND)
76 S %=%A D ^ARJTDIM1
77 S %A=%A1 D PARS1 G ER:%C]""
78 G OP
79 ;
80FR ; FOR (F^ARJTDIM)
81 S %L="=",%A=%ARG D PARS1 G ER:%ERR!(%A1="")!(%A="") S %ARG=%A1
82 S %=%A G ER:%A?1"^".E D VV,^ARJTDIM1 G ER:%ERR
83FR1 G GC^ARJTDIM:%ARG=""!%ERR D PARS
84 S %L=":" F %A=%A,%A1 D PARS1 G ER:%ERR!(%A=""&(%C=%L)) S %=%A D ^ARJTDIM1
85 I %A1]"" S %=%A1 D ^ARJTDIM1
86 G FR1
87 ;
88 ; this chunk, called usually at PARS, parses & extract the next argument
89 ; In/Output:
90 ; %ARG = command argument buffer
91 ; %C = current character
92 ; %ERR = 1 if there's an error
93 ; %I = current character position
94 ; Output:
95 ; %A = next argument
96 ; Called by: DG, KL, OP, FR1
97 ;
98 S (%A,%C)="" Q:%ERR S (%ERR,%I)=0 ; entry
99 F D Q:","[%C!%ERR ; main loop: advance to next top-level ","
100 . D %INC
101 . I %C="""" D Q:%ERR ; skip over strlit
102 . . F D %INC Q:%C="""" I %C="" S %ERR=1 Q
103 . I %C="(" D Q:%ERR ; skip over ()s
104 . . N %P S %P=1
105 . . N %J F %J=0:0 D Q:'%P!%ERR
106 . . . D %INC
107 . . . I %C="""" D Q:%ERR ; skip over strlit
108 . . . . F D %INC Q:%C="""" I %C="" S %ERR=1 Q ; work on this
109 . . . S %P=%P+$S(%C="(":1,%C=")":-1,1:0) Q:'%P
110 . . . I %C="" S %ERR=1
111 I '%ERR D
112 . S %A=$E(%ARG,1,%I-1)
113 . S %ARG=$E(%ARG,%I+1,999)
114 Q
115 ;
116PARS S (%A,%C)="" Q:%ERR S (%ERR,%I)=0 ; entry
117INC D %INC D QT:%C="""",PARAN:%C="(" Q:%ERR G OUT:","[%C,INC ; main loop
118QT D %INC Q:%C="""" G QT:%C]"" S %ERR=1 Q ; skip over strlit
119PARAN S %P=1 F %J=0:0 D Q:'%P!%ERR ; skip over ()s
120 . D %INC D QT:%C=""""
121 . S %P=%P+$S(%C="(":1,%C=")":-1,1:0) Q:'%P
122 . I %C="" S %ERR=1
123 Q
124OUT S %A=$E(%ARG,1,%I-1),%ARG=$E(%ARG,%I+1,999) Q ; set output & quit
125%INC S %I=%I+1,%C=$E(%ARG,%I) Q ; advance 1 character
126 ;
127 ;
128PARS1 S (%A1,%C)="" Q:%ERR S (%ERR,%I)=0
129INCR D %INC1 D QT1:%C="""",PARAN1:%C="(" Q:%ERR=1 G OUT1:%L[%C,INCR
130OUT1 S %A1=$E(%A,%I+1,999),%A=$E(%A,1,%I-1) Q
131QT1 D %INC1 Q:%C="""" G QT1:%C]"" S %ERR=1 Q
132PARAN1 S %P=1 F %J=0:0 D %INC1 D QT1:%C="""" S %P=%P+$S(%C="(":1,%C=")":-1,1:0) Q:'%P I %C="" S %ERR=1 Q
133 Q
134%INC1 S %I=%I+1,%C=$E(%A,%I) Q
135 ;
136 ;
137VV ; variable, label, or routine name (LABEL, KL, and FR)
138 I '%ERR,%]"",%'["@",%'?1U.UN,%'?1U.UN1"(".E1")",%'?1"%".UN1"(".E1")",%'?1"%".UN,%'?1"^"1U.UN1"(".E1")",%'?1"^%".UN1"(".E1")",%'?1"^(".E1")",%'?1"^"1U.UN S %ERR=1
139 S:%["?@" %ERR=1 Q
140 ;
141LNAME(%) ; lname (KL)
142 I %?1A.7UN!(%?1"%".7UN) Q 1
143 I %?1"@".E Q 1
144 Q 0
145 ;
146ADD(ELEMENT,FOUND) ; record element found
147 ; Input: ELEMENT = code for element found, e.g., "F".
148 ; Output: .FOUND(ELEMENT) = increment # times found
149 S FOUND(ELEMENT)=$G(FOUND(ELEMENT))+1
150 Q ; end of DSM
151 ;
152DSM(ABBREV,ELEMENT,FIND,FOUND) ; record DSM-specific element found
153 ; Input:
154 ; ABBREV = code for element found, e.g., "V"
155 ; ELEMENT = name of element found, e.g., "VIEW".
156 ; Output:
157 ; .FOUND(ABBREV) = increment # times found
158 ; .FOUND("DSM",ELEMENT) = ditto
159 I $G(ABBREV)'="" D ADD(ABBREV,.FOUND)
160 I FIND["DSM" D
161 . S FOUND=1
162 . S FOUND("DSM",ELEMENT)=$G(FOUND("DSM",ELEMENT))+1
163 Q ; end of DSM
164 ;
165ER G ER^ARJTDIM
Note: See TracBrowser for help on using the repository browser.