-
Notifications
You must be signed in to change notification settings - Fork 6
/
VPRJGQF.m
205 lines (205 loc) · 8.62 KB
/
VPRJGQF.m
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
VPRJCF ;KRM/CJE -- Generic Query Filter
;
; EVALAND is always called first since the default is to 'and'
; clauses together, so ERROR is newed in EVALAND.
;
EVALAND(CLAUSES,REF) ; evaluate object at global reference against filter
; AND -- return true if ALL clauses are true
N SEQ,RESULT,CLAUSE,ERROR,VALUE
S SEQ=0,RESULT=1 ;default true in case there are no clauses to evaluate
F S SEQ=$O(CLAUSES(SEQ)) Q:'SEQ M CLAUSE=CLAUSES(SEQ) S RESULT=$$EVALEXPR(.CLAUSE,REF) Q:'RESULT K CLAUSE
Q RESULT
;
EVALOR(CLAUSES,REF) ; evaluate object at global reference against filter
; OR -- return true if ANY clause is true
N SEQ,RESULT,CLAUSE
S SEQ=0,RESULT=1 ;default true in case there are no clauses to evaluate
F S SEQ=$O(CLAUSES(SEQ)) Q:'SEQ M CLAUSE=CLAUSES(SEQ) S RESULT=$$EVALEXPR(.CLAUSE,REF) Q:RESULT K CLAUSE
Q RESULT
;
EVALNOT(CLAUSES,REF) ; evaluate object at global reference against filter
; NOT -- return true if none of the clauses are true
N SEQ,RESULT,CLAUSE
S SEQ=0,RESULT=1 ;default true in case there are no clauses to evaluate
F S SEQ=$O(CLAUSES(SEQ)) Q:'SEQ M CLAUSE=CLAUSES(SEQ) S RESULT=$$EVALEXPR(.CLAUSE,REF) Q:RESULT K CLAUSE
Q 'RESULT
;
EVALEXPR(CLAUSE,REF) ; evaluate expression in a clause
; uses a global reference to handle multiple stores
; handle conjunctions / disjunctions
I CLAUSE="and" Q $$EVALAND(.CLAUSE,REF)
I CLAUSE="or" Q $$EVALOR(.CLAUSE,REF)
I CLAUSE="not" Q $$EVALNOT(.CLAUSE,REF)
;
; get the value or values to be evaluated & go to appropriate evaluator
N VALUE,DONE
; case TYPE begin
I CLAUSE("type")=1 S VALUE=$G(@REF@(CLAUSE("field"))) Q $$EVALONE
I CLAUSE("type")=2 S VALUE=$G(@REF@(CLAUSE("field"),CLAUSE("sub"))) Q $$EVALONE
I CLAUSE("type")=5 D
. N ITER S ITER="",DONE=0
. F S ITER=$O(@REF@(CLAUSE("field"),ITER)) Q:ITER="" D
. . S VALUE=$G(@REF@(CLAUSE("field"),ITER))
. . I $$EVALONE S DONE=1 Q
; Quit here if Type 5 evaluated
I $G(DONE) Q DONE
;
N INST,RSLT
S INST="",RSLT=0
; return try if -any- of the values evaluate to true
F S INST=$O(@REF@(CLAUSE("mult"),INST)) Q:'INST D Q:RSLT
. I CLAUSE("type")=3 S VALUE=$G(@REF@(CLAUSE("mult"),INST,CLAUSE("field"))) S RSLT=$$EVALONE Q
. I CLAUSE("type")=4 S VALUE=$G(@REF@(CLAUSE("mult"),INST,CLAUSE("field"),CLAUSE("sub"))) S RSLT=$$EVALONE Q
Q RSLT
;
EVALONE() ; perform operation on a single value
I CLAUSE="eq" Q (VALUE=CLAUSE("value"))
I CLAUSE="in" Q:'$L(VALUE) 0 Q $D(CLAUSE("list",VALUE))
I CLAUSE="ne" Q (VALUE'=CLAUSE("value"))
I CLAUSE="exists" Q (($L(VALUE)>0)=$G(CLAUSE("value"),1))
I CLAUSE="nin" Q:'$L(VALUE) 0 Q '$D(CLAUSE("list",VALUE))
;
I $L(VALUE),(+VALUE=VALUE),'$D(CLAUSE("asString")) G EVALNUM
EVALSTR ; use ] to evaluate string values
I CLAUSE="gt" Q (VALUE]CLAUSE("value"))
I CLAUSE="lt" Q (CLAUSE("value")]VALUE)
I CLAUSE="gte" Q:VALUE=CLAUSE("value") 1 Q (VALUE]CLAUSE("value"))
I CLAUSE="lte" Q:VALUE=CLAUSE("value") 1 Q (CLAUSE("value")]VALUE)
I CLAUSE="between" Q:(CLAUSE("low")]VALUE) 0 Q:(VALUE]CLAUSE("high")) 0 Q 1
I CLAUSE="like" Q VALUE?@CLAUSE("pattern")
I CLAUSE="ilike" Q $$LOW^XLFSTR(VALUE)?@CLAUSE("pattern")
D SETERR(106,"unsupported operator")
Q 0
;
EVALNUM ; use >,< to evaluate numeric values
I CLAUSE="gt" Q (VALUE>CLAUSE("value"))
I CLAUSE="lt" Q (VALUE<CLAUSE("value"))
I CLAUSE="gte" Q (VALUE'<CLAUSE("value"))
I CLAUSE="lte" Q (VALUE'>CLAUSE("value"))
I CLAUSE="between" Q:(VALUE<CLAUSE("low")) 0 Q:(VALUE>CLAUSE("high")) 0 Q 1
D SETERR(106,"unsupported operator")
Q 0
;
;
PARSE(IN,OUT) ; parse filter syntax
; A:argument,C:conjunction,O:operation,L:list
N LEVEL,STACK,PTR,TOKEN,ITEM,ERROR
S LEVEL=1,PTR=1,STACK(LEVEL)=1,STACK(LEVEL,"mode")="O",ERROR=0
F Q:PTR>$L(IN) S TOKEN=$E(IN,PTR) D Q:ERROR
. I TOKEN="(" D PUSH("A") Q
. I TOKEN=")" D POP Q
. I TOKEN="{" D PUSH("C") Q ; deprecated -- use paranthesis
. I TOKEN="}" D POP Q ; deprecated -- use paranthesis
. I TOKEN="[" D PUSH("L") Q
. I TOKEN="]" D POP Q
. I TOKEN="," S STACK(LEVEL)=STACK(LEVEL)+1,PTR=PTR+1 D LTRIM^VPRJCU(.IN,.PTR) Q
. I TOKEN=" " S STACK(LEVEL)=STACK(LEVEL)+1,PTR=PTR+1 D LTRIM^VPRJCU(.IN,.PTR) Q
. S ITEM=$S(TOKEN="""":$$NXTSTRF,1:$$NXTVALF) Q:ERROR ;increment PTR to next token
. I '$L(ITEM) D SETERR(106,"empty value") Q
. I STACK(LEVEL,"mode")="O"!(STACK(LEVEL,"mode")="C") D SETOPER(ITEM) Q
. I STACK(LEVEL,"mode")="A" D Q
. . I STACK(LEVEL)=1 D SETFLD(ITEM) Q
. . I STACK(LEVEL)=2 D
. . . I TOKEN="""" S @$$CURREF(LEVEL-1,"asString")=""
. . . I @$$CURREF(LEVEL-1)="between" S @$$CURREF(LEVEL-1,"low")=ITEM Q
. . . I @$$CURREF(LEVEL-1)="like" S @$$CURREF(LEVEL-1,"pattern")=$$MAKEPAT(ITEM,0) Q
. . . I @$$CURREF(LEVEL-1)="ilike" S @$$CURREF(LEVEL-1,"pattern")=$$MAKEPAT(ITEM,1) Q
. . . I @$$CURREF(LEVEL-1)="exists" S @$$CURREF(LEVEL-1,"value")=$S(ITEM="false":0,1:1) Q
. . . E S @$$CURREF(LEVEL-1,"value")=ITEM
. . I STACK(LEVEL)=3 S @$$CURREF(LEVEL-1,"high")=ITEM
. I STACK(LEVEL,"mode")="L" S @$$CURREF(LEVEL-2,"list",ITEM)="" Q
I LEVEL'=1,'ERROR D SETERR(106,"mismatch of braces")
I '$$CHKOUT(.OUT) Q
Q
PUSH(MODE) ; new stack level
I ",or,and,not,"[(","_$G(ITEM)_",") S MODE="C" ; conjunction, otherwise leave as A
S LEVEL=LEVEL+1,STACK(LEVEL)=1,STACK(LEVEL,"mode")=MODE,PTR=PTR+1
Q
POP ; remove stack level
K STACK(LEVEL) S LEVEL=LEVEL-1,PTR=PTR+1
Q
CURREF(TO,PROP,ITEM) ; Set current global reference based on stack
N LEVEL,REF
S REF="",LEVEL=1
F Q:LEVEL>TO S REF=REF_$S(LEVEL=1:"",1:",")_STACK(LEVEL),LEVEL=LEVEL+1
I $L($G(PROP)) S REF=REF_","""_PROP_""""
I $L($G(ITEM)) S REF=REF_","""_ITEM_""""
Q "OUT("_REF_")"
;
SETOPER(ITEM) ; Set operation
S ITEM=$$LOW^XLFSTR(ITEM)
I ",or,and,not,eq,ne,gt,lt,gte,lte,in,between,like,ilike,exists,nin,"[(","_ITEM_",") S @$$CURREF(LEVEL)=ITEM I 1
E D SETERR(106,"unsupported operator")
Q
SETFLD(FIELD) ; Classify the field into its type and parts
N PARTS
; TODO: consider supporting "_" in names
; case begin
; support underscore for single field only (could be replicated)
I FIELD?1(1A,1"_").AN D G XSETFLD
. S PARTS("type")=1,PARTS("field")=FIELD
I FIELD?1A.AN1"."1A.AN D G XSETFLD
. S PARTS("type")=2,PARTS("field")=$P(FIELD,"."),PARTS("sub")=$P(FIELD,".",2)
I FIELD?1A.AN1"[]."1A.AN D G XSETFLD
. S PARTS("type")=3,PARTS("mult")=$P(FIELD,"[]."),PARTS("field")=$P(FIELD,".",2)
I FIELD?1A.AN1"[]."1A.AN1"."1A.AN D G XSETFLD
. S PARTS("type")=4,PARTS("mult")=$P(FIELD,"[]."),PARTS("field")=$P(FIELD,".",2),PARTS("sub")=$P(FIELD,".",3)
; look for values in arrays
; Only allow for searching arrays in standardized persistant stores
I $D(^VPRCONFIG("store",$G(HTTPREQ("store")))),FIELD?1A.AN1"[]" D G XSETFLD
. S PARTS("type")=5,PARTS("mult")=$P(FIELD,"[]"),PARTS("field")=$P(FIELD,"[]")
; else
D SETERR(107,"unsupported field type")
; case end
XSETFLD ;
Q:ERROR
M @$$CURREF(LEVEL-1)=PARTS
Q
NXTSTRF() ; function returns the next string from IN based on PTR
; expects: IN,PTR
; may set: ERROR
N STR
D NXTSTR^VPRJCU(.IN,.PTR,.STR)
Q STR
;
NXTVALF() ; function returns the next value from IN based on PTR
; expects IN,PTR
N VAL
D NXTVAL^VPRJCU(.IN,.PTR,.VAL," ,(){}[]")
Q VAL
;
MAKEPAT(MATCH,CI) ; switch LIKE pattern into M pattern match
I '$L(MATCH) D SETERR(106,"missing LIKE argument") Q ""
;
I $G(CI) S MATCH=$$LOW^XLFSTR(MATCH) ; case insensitive match
N I,X,LAST,PATTERN
S PATTERN="",LAST=1
F S I=$F(MATCH,"%",LAST) D Q:'I Q:I>$L(MATCH)
. S X=$E(MATCH,LAST,$S(I:I-2,1:$L(MATCH))),LAST=I
. I $L(X) S PATTERN=PATTERN_"1"""_X_""""
. I $E(MATCH,I-1)="%" S PATTERN=PATTERN_".E"
Q PATTERN
;
CHKOUT(CLAUSES) ; check the output of parse for errors in initial statement
N SEQ,OK,CLAUSE
S SEQ=0,OK=1
F S SEQ=$O(CLAUSES(SEQ)) Q:'SEQ M CLAUSE=CLAUSES(SEQ) S OK=$$CHKONE(.CLAUSE) Q:'OK K CLAUSE
Q OK
;
CHKONE(CLAUSE) ; check and individual clause for errors
I ",and,or,not,"[(","_CLAUSE_",") Q $$CHKOUT(.CLAUSE)
I ",or,and,not,eq,ne,gt,lt,gte,lte,in,between,like,ilike,exists,nin,"'[(","_CLAUSE_",") D SETERR(106,"unsupported operator") Q 0
I CLAUSE="between",('$D(CLAUSE("low"))!'$D(CLAUSE("high"))) D SETERR(106,"missing low or high") Q 0
I (CLAUSE="in"!(CLAUSE="nin")),($D(CLAUSE("list"))'>1) D SETERR(106,"missing list for in operation") Q 0
I ",eq,ne,gt,lt,gte,lte,"[(","_CLAUSE_","),'$D(CLAUSE("value")) D SETERR(106,"missing value") Q 0
I (CLAUSE="like"!(CLAUSE="ilike")),'$D(CLAUSE("pattern")) D SETERR(106,"missing like pattern") Q 0
I '$D(CLAUSE("field")) D SETERR(106,"missing field") Q 0
I CLAUSE("type")=2,'$D(CLAUSE("sub")) D SETERR(106,"missing sub-field") Q 0
I CLAUSE("type")=3,'$D(CLAUSE("mult")) D SETERR(106,"missing multiple") Q 0
I CLAUSE("type")=4,('$D(CLAUSE("mult"))!'$D(CLAUSE("sub"))) D SETERR(106,"incomplete field name") Q 0
Q 1
;
SETERR(ERR,MSG) ; set error state
S ERROR=ERR
D SETERROR^VPRJRER(ERR,$G(MSG))
Q