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

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

initial load of WorldVistAEHR

File size: 5.3 KB
Line 
1ARJTDIM4 ;SFISC/JFW,GFT,TOAD-FileMan: M Syntax Checker, Commands ;5/26/2004 21:16
2 ;;3.0T1;OPENVISTA;;Jun 20, 2004
3 ;
4 ; I do not like calling ADD from within $$GLVN, but don't have time now to redo
5 ; $$GLVN into a subroutine. This routine also needs extensive commenting.
6 ;
7 ; Change History:
8 ; 2004 05 26 WV/TOAD: added ADD to file found search elements, and changed
9 ; GLVN to record extended global references if code "[]" passed.
10 ; commented GLVN.
11 ;
12BK ; BREAK and QUIT (B^ARJTDIM and Q^ARJTDIM)
13 I %ARG]"" S %=%ARG D ^ARJTDIM1 G ER:%ERR
14 G GC^ARJTDIM
15 ;
16CL ; CLOSE (C^ARJTDIM)
17 G ER:%ERR I %ARG]"" F %Z=0:0 D S S %=%A D ^ARJTDIM1 G:%ARG=""!%ERR GC^ARJTDIM
18 G GC^ARJTDIM
19 ;
20IX ; IF and XECUTE (I^ARJTDIM and X^ARJTDIM)
21 G GC^ARJTDIM:%ARG=""!%ERR D S S %L=":" D S1 I %C=%L S %=%A1 D ^ARJTDIM1 G ER:%A1=""!%ERR
22 S %=%A D ^ARJTDIM1 G IX
23 ;
24 ;
25ST ; SET and MERGE (S^ARJTDIM and M^ARJTDIM)
26 ; Inputs: %ARG = argument list remaining to parse
27 ; %COM = abbreviated commandword
28 ; %COM(1) = postcond
29 ; %END = full argument list
30 ; %ERR = whether we've encountered an error
31 ; %I = # chars into overall line to parse
32 ; %LAST = full line to parse
33 ; %X = unparsed part of line remaining
34 ;
35 ; if we've run out of args or have an error, we're done in ST
36 G GC^ARJTDIM:%ARG=""!%ERR
37 ;
38 D S ; extract next argument
39 G ER:%ERR!(%A=""&(%C=",")) ; bad if error or comma without argument
40 ;
41 I %A?1"@".E S %=%A D ^ARJTDIM1 G ST ; handle argument indirection
42 ;
43 S %L="=" D S1 ; split the argument at the "="
44 G ER:(%A="")!(%A1="") ; both setleft & setright must be present
45 ;
46 G ER:%COM="M"&'$$GLVN(%A1) ; for MERGE, setright better be a glvn
47 ;
48 I %A="ZTIO",%A1="IO" S FOUND("ZTIO=IO")=""
49 ;
50 I %A="DIC(0)" D ; search for DIC(0)["T"
51 . I %A1["T" S FOUND("DIC(0)","T")="" ; intentionally loose check
52 ;
53 S %=%A1 D ^ARJTDIM1 G ER:%ERR ; ensure setright is a valid expr
54 ;
55 ; if it's a set many, deal with that in STM
56 I %A?1"(".E1")" S %A=$E(%A,2,$L(%A)-1) G ER:%COM="M",STM
57 ;
58 D VV ; make sure setleft is valid
59 G ST ; go handle next argument in arglist
60 ;
61STM ; SET (x,y)=... (ST) -- ()s have been stripped
62 G ST:%ERR!(%A="") ; we're done in STM if error or no more setleft
63 G ER:%A?1",".E ; we need a setleft before the 1st comma
64 ;
65 S %L="," D S1 ; separate the first setleft from the list
66 G ER:%ERR!(%C=%L&(%A1="")) ; bad if error or trailing comma
67 D VV ; make sure current setleft is valid
68 S %A=%A1 G STM ; go handle rest of setlist
69 ;
70 ;
71RD ; READ (R^ARJTDIM)
72 G GC^ARJTDIM:%ARG=""!%ERR D S G ER:%ERR!(%C=","&(%A=""))
73 I "!#?"[$E(%A,1) S %I=0 D FRM G RD
74 I %A?1"""".E G ER:$P(%A,"""",3)'="" S %=%A D ^ARJTDIM1 G RD
75 I %A?1"*".E S %A=$E(%A,2,999)
76 I $E(%A)="^","^TMP^XTMP^"'[$P(%A,"(") G ER
77 F %L=":","#" D G ER:%ERR
78 . D S1 Q:%ERR
79 . I %A="" S %ERR=1 Q
80 . I %A1="",%C=%L S %ERR=1 Q
81 . S %=%A1 D ^ARJTDIM1
82 D VV G ER:%ERR,RD
83 ;
84WR ; WRITE (W^ARJTDIM)
85 G GC^ARJTDIM:%ARG=""!%ERR D S G ER:%ERR!(%A=""&(%C=","))
86 I "!#?/"[$E(%A) S %I=0 D FRM G WR
87 S:%A?1"*".E %A=$E(%A,2,999) S %=%A D ^ARJTDIM1 G WR
88 ;
89FRM ; format (RD and WR)
90 S %I=%I+1,%C=$E(%A,%I) Q:%C="" G FRM:"!#"[%C
91 S %=$E(%A,%I+1,999) I %]"",%C="?" D ^ARJTDIM1 Q
92 I %C="/",%COM="W" S:%?1"?".E %="A"_$E(%,2,999) I %?1AN.E D ^ARJTDIM1 Q
93 S %ERR=1 Q
94 ;
95S ; split at first comma: end of first argument (*)
96 ; returns %A = next argument to parse
97 ; %ARG = remaining unparsed arguments
98 ; %C = next character
99 ; %ERR = whether there was an error
100 ; %I = # chars into argument list
101 S (%A,%C)="" Q:%ERR S (%ERR,%I)=0
102INC D %INC D QT:%C="""",P:%C="(" Q:%ERR G OUT:","[%C,INC
103QT D %INC Q:%C="""" G QT:%C]"" S %ERR=1 Q
104P S %P=1 F %J=0:0 D %INC D QT:%C="""" S %P=%P+$S(%C="(":1,%C=")":-1,1:0) Q:'%P I %C="" S %ERR=1 Q
105 Q
106OUT S %A=$E(%ARG,1,%I-1),%ARG=$E(%ARG,%I+1,999) Q
107%INC S %I=%I+1,%C=$E(%ARG,%I) Q
108 ;
109 ;
110S1 ; split at first instance of %L (*)
111 ; returns %A = setleft
112 ; %A1 = setright (part of argument remaining unparsed)
113 ; %C = "="
114 ; %ERR = whether there was an error
115 ; %I = # chars into argument (incl "=")
116 ; %L = "="
117 S (%A1,%C)="" Q:%ERR S (%ERR,%I)=0
118INCR D %INC1 D QT1:%C="""",P1:%C="(" Q:%ERR G OUT1:%L[%C,INCR
119OUT1 S %A1=$E(%A,%I+1,999),%A=$E(%A,1,%I-1) Q
120QT1 D %INC1 Q:%C="""" G QT1:%C]"" S %ERR=1 Q
121P1 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
122 Q
123%INC1 S %I=%I+1,%C=$E(%A,%I) Q
124 ;
125 ;
126VV ; glvn or setleft (ST, STM, and RD)
127 S %=%A Q:%ERR
128 I %]"",$$GLVN(%)=0 D
129 .I %COM'="S" S %ERR=1 Q
130 .I %["(",(%?1"$P".E)!(%?1"$E".E) Q
131 .I %="$X"!(%="$Y") Q
132 .I %="$D"!(%="$DEVICE")!(%="$K")!(%="$KEY")!(%="$EC")!(%="$ECODE")!(%="$ET")!(%="$ETRAP") S %ERR=1 Q ; SAC
133 .S %ERR=1
134 D ^ARJTDIM1:'%ERR Q
135 ;
136GLVN(%) ; glvn (not counting subscript syntax) (ST, VV)
137 I %?.1"^"1U.UN Q 1 ; e.g., ^TMP or X
138 I %?.1"^"1U.UN1"("1.E1")" Q 1 ; e.g., ^TMP(1) or X(1)
139 I %?.1"^"1"%".UN Q 1 ; e.g., ^%ZTSK or %X
140 I %?.1"^"1"%".UN1"("1.E1")" Q 1 ; e.g., ^%ZTSK(1) or %X(1)
141 I %?1"^("1.E1")" Q 1 ; e.g., ^(1)
142 I %?1"^$"1.U1"("1.E1")" Q 1 ; e.g., ^$JOB(1)
143 I %?1"@"1.E Q 1 ; e.g., @X
144 I %?1"^["1.E1"]"1.E D ADD("^[]",.FOUND) ; recorded extended global refs found
145 Q 0
146 ;
147ADD(ELEMENT,FOUND) ; record element found (GLVN)
148 ; Input: ELEMENT = code for element found, e.g., "F".
149 ; Output: .FOUND(ELEMENT) = increment # times found
150 S FOUND=1
151 S FOUND(ELEMENT)=$G(FOUND(ELEMENT))+1
152 Q ; end of ADD
153 ;
154ER G ER^ARJTDIM
Note: See TracBrowser for help on using the repository browser.