source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMCOND.m@ 794

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

initial load of FOIAVistA 6/30/08 version

File size: 7.4 KB
Line 
1PXRMCOND ; SLC/PKR - Routines for evaluating conditions. ;06/01/2007
2 ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
3 ;
4 ;============================================================
5CASESEN(X,DA,FILENUM) ;
6 ;Called by xref on condition case sensitive field in 811.5 and 811.9.
7 N COND,GBL
8 S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
9 S GBL=GBL_DA(1)_",20,"_DA_",3)"
10 S COND=$P(@GBL,U,1)
11 D SICOND(COND,.DA,FILENUM)
12 Q
13 ;
14 ;============================================================
15COND(CASESEN,ICOND,VSLIST,VA) ;Evaluate the condition.
16 N CONVAL,IND,JND,NSTAR,SUB,TEMP,V,VSTAR
17 S CONVAL=""
18 ;If there is no condition return true.
19 I $L($G(ICOND))=0 Q 1
20 S NSTAR=0
21 F IND=1:1 S SUB=$P(VSLIST,";",IND) Q:SUB="" D
22 . I SUB["*" S NSTAR=NSTAR+1,VSTAR(NSTAR)=$L(SUB,",")_U_SUB
23 S V=$G(VA("VALUE"))
24 I 'CASESEN S V=$$UP^XLFSTR(V)
25 ;Move all non "*" elements of VA into V.
26 I VSLIST'="" D MV(VSLIST,CASESEN,.V,.VA)
27 I NSTAR=0 X ICOND S CONVAL=$T
28 I NSTAR>0 S CONVAL=$$STARCOND(CASESEN,ICOND,.V,.VA,NSTAR,.VSTAR)
29 Q CONVAL
30 ;
31 ;============================================================
32KICOND(X,DA,FILENUM) ;
33 ;Do not execute as part of a verify fields.
34 I $G(DIUTIL)="VERIFY FIELDS" Q
35 ;Do not execute as part of exchange.
36 I $G(PXRMEXCH) Q
37 S FILENUM=$G(FILENUM)
38 I FILENUM=811.5 K ^PXRMD(811.5,DA(1),20,DA,10),^PXRMD(811.5,DA(1),20,DA,11)
39 I FILENUM=811.9 K ^PXD(811.9,DA(1),20,DA,10),^PXD(811.9,DA(1),20,DA,11)
40 Q
41 ;
42 ;============================================================
43MV(VSLIST,CASESEN,V,VA) ;Move the elements of VA included in VSLIST
44 ;into V and uppercase if necessary.
45 N IND,NE,RV,RVA,SUB
46 S NE=$L(VSLIST,";")-1
47 F IND=1:1:NE D
48 . S SUB=$P(VSLIST,";",IND)
49 . I SUB["*" Q
50 . S RV="V("_SUB_")",RVA="VA("_SUB_")"
51 .;If VA(SUB) does not exist skip it.
52 . I '$D(@RVA) Q
53 . S @RV=$S('CASESEN:$$UP^XLFSTR(@RVA),1:@RVA)
54 Q
55 ;
56 ;============================================================
57RECSUB(IND,V,VA,NSTAR,VSTAR,NM,VM,CASESEN,ICOND,CONVAL) ;Called recursively,
58 ;first substitutes V array elements with "*" in subscript with a
59 ;replacement value. Once all have been replaced test condition and
60 ;quit if true. If not true continue until all combinations have been
61 ;tested.
62 N JND,RV,RVA,VSUB,VASUB
63 F JND=1:1:NM(IND) Q:CONVAL D
64 . S VASUB=VM(IND,JND)
65 . S RVA="VA("_VASUB_")"
66 . S SUB=$P(VSTAR(IND),U,2)
67 . S RV="V("_SUB_")"
68 . S @RV=$S('CASESEN:$$UP^XLFSTR(@RVA),1:@RVA)
69 . I IND<NSTAR D RECSUB(IND+1,.V,.VA,NSTAR,.VSTAR,.NM,.VM,CASESEN,ICOND,.CONVAL)
70 . I IND=NSTAR X ICOND S CONVAL=$T
71 ;If there were no substitutions to make, make sure the condition is
72 ;evaluated.
73 I 'CONVAL,IND=NSTAR,NM(IND)=0 X ICOND S CONVAL=$T
74 Q
75 ;
76 ;============================================================
77SCPAR(FINDPA,CASESEN,COND,UCIFS,ICOND,VSLIST) ;Set the Condition parameters.
78 N CONDS
79 S CONDS=$G(FINDPA(3))
80 S COND=$P(CONDS,U,1)
81 ;Even if there is no condition UCIFS could be used for status search.
82 S UCIFS=$P(CONDS,U,3)
83 I COND="" Q
84 S CASESEN=$P(CONDS,U,2)
85 I CASESEN="" S CASESEN=1
86 S ICOND=FINDPA(10),VSLIST=FINDPA(11)
87 Q
88 ;
89 ;============================================================
90SICOND(X,DA,FILENUM) ;Set the internal condition field. Wrap all V() in $G.
91 ;Called by xref on condition field in 811.5 and 811.9.
92 I X="" Q
93 ;Do not execute as part of a verify fields.
94 I $G(DIUTIL)="VERIFY FIELDS" Q
95 ;Do not execute as part of exchange.
96 I $G(PXRMEXCH) Q
97 N CASESEN,GBL,ICOND,IND,SE,SS,SUB,SUBLIST,TEMP,VSLIST,VWSUB,XUP
98 S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
99 S GBL=GBL_DA(1)_",20,"_DA_",3)"
100 S CASESEN=$P(@GBL,U,2)
101 I CASESEN="" S CASESEN=1
102 ;Find each V("sub") entry.
103 S XUP=$$UP^XLFSTR(X)
104 I 'CASESEN S (ICOND,X)=XUP
105 I CASESEN S ICOND=$$STRREP^PXRMUTIL(X,"v(","V(")
106 S SS=1,VSLIST=""
107 F S SS=$F(XUP,"V(",SS) Q:SS=0 D
108 . S SE=$F(X,")",SS)
109 . S SUB=$E(X,SS,SE-2)
110 . I $D(SUBLIST(SUB)) Q
111 . S SUBLIST(SUB)=""
112 . S VSLIST=VSLIST_SUB_";"
113 . S VWSUB="V("_SUB_")"
114 . S TEMP="$G("_VWSUB_")"
115 . S ICOND=$$STRREP^PXRMUTIL(ICOND,VWSUB,TEMP)
116 I FILENUM=811.5 S ^PXRMD(811.5,DA(1),20,DA,10)=ICOND,^PXRMD(811.5,DA(1),20,DA,11)=VSLIST
117 I FILENUM=811.9 S ^PXD(811.9,DA(1),20,DA,10)=ICOND,^PXD(811.9,DA(1),20,DA,11)=VSLIST
118 Q
119 ;
120 ;============================================================
121STARCOND(CASESEN,ICOND,V,VA,NSTAR,VSTAR) ;Execute a star condition,
122 ;look for any replacements for the * subscripts that will make the
123 ;Condition true.
124 N CONVAL,IND,JND,KND,MATCH,NEWV,NM,NVA,ORV,REF,SUB,SUBL,TCOND,TEMP
125 N VASUB,VSSUB,VM
126 ;Build a list of the subscripts in VA.
127 S NVA=0,REF="VA"
128 F S REF=$Q(@REF) Q:REF="" D
129 . S SUB=$P(REF,"(",2)
130 . S SUB=$P(SUB,")",1)
131 . S SUBL=$L(SUB,",")
132 . S NVA=NVA+1,VASUB(NVA)=SUBL_U_SUB
133 ;Build a list of replacements for the * subscripts.
134 F IND=1:1:NSTAR D
135 . S NM=0
136 . S VSSUB=$P(VSTAR(IND),U,2)
137 . S SUBL=+VSTAR(IND)
138 . F JND=1:1:NVA D
139 .. I +VASUB(JND)'=SUBL Q
140 .. S SUB=$P(VASUB(JND),U,2)
141 .. S MATCH=1
142 .. F KND=1:1:SUBL D
143 ... S TEMP=$P(VSSUB,",",KND)
144 ... I TEMP["*" Q
145 ... I $P(SUB,",",KND)'=TEMP S MATCH=0,KND=SUBL
146 .. I MATCH S NM=NM+1,VM(IND,NM)=SUB
147 . S NM(IND)=NM
148 S CONVAL=0
149 F IND=1:1:NSTAR Q:CONVAL D RECSUB(IND,.V,.VA,NSTAR,.VSTAR,.NM,.VM,CASESEN,ICOND,.CONVAL)
150 Q CONVAL
151 ;
152 ;============================================================
153VCOND(X) ;
154 ;Input transform on Condition field.
155 ;Do not execute as part of exchange.
156 I $G(PXRMEXCH) Q 1
157 ;The CONDITION must start with "I ".
158 S X=$$UP^XLFSTR(X)
159 I $E(X,1,2)'="I " D Q 0
160 . S X=""
161 . D EN^DDIOL("CONDITION must start with ""I"" followed by a single space")
162 ;The CONDITION cannot contain "^".
163 I X["^" D Q 0
164 . S X=""
165 . D EN^DDIOL("CONDITION cannot contain ""^""")
166 ;The CONDITION cannot contain "@".
167 I X["@" D Q 0
168 . S X=""
169 . D EN^DDIOL("CONDITION cannot contain ""@""")
170 ;The rest of the condition can only contain spaces if they are in
171 ;a string.
172 N COND,TEMP,VALID
173 S COND=$E(X,3,$L(X))
174 S VALID=$S(COND[" ":$$VSPACE(COND),1:1)
175 I VALID S VALID=$S(COND["V(":$$VSUB(COND),1:1)
176 I VALID D
177 . D ^DIM
178 . I '$D(X) D
179 .. D EN^DDIOL("Not a valid MUMPS string")
180 .. S VALID=0
181 Q VALID
182 ;
183 ;============================================================
184VSPACE(COND) ;Make sure all spaces in the condition that come after
185 ;the beginning I are inside a quoted string.
186 N CHAR,IND,IQ,JND,LQ,NIQ,NQP,NSP,QP,SP,SPACE,VALID
187 S VALID=1
188 S (LQ,NQP,NSP)=0
189 F IND=1:1:$L(COND) D
190 . S CHAR=$E(COND,IND)
191 . I CHAR="""" D
192 .. I LQ S NQP=NQP+1,QP(NQP)=LQ_U_IND,LQ=0
193 .. E S LQ=IND
194 . I CHAR=" " S NSP=NSP+1,SP(NSP)=IND
195 S NIQ=0
196 F IND=1:1:NSP D
197 . S SPACE=SP(NSP)
198 . S IQ=0
199 . F JND=1:1:NQP D
200 .. I SPACE>$P(QP(JND),U,1),SPACE<$P(QP(JND),U,2) S IQ=1,JND=NQP Q
201 . S NIQ=$S(IQ:0,1:1)
202 . I NIQ S IND=NSP Q
203 I NIQ D
204 . D EN^DDIOL("No spaces are allowed except in quoted strings!")
205 . S VALID=0
206 Q VALID
207 ;
208 ;============================================================
209VSUB(COND) ;Make sure all V subscripts are quoted strings, numbers
210 ;or quoted * strings.
211 N IND,RP,SS,SUB,SUBL,VALID
212 S (SS,VALID)=1
213 F S SS=$F(COND,"V(",SS) Q:('VALID)!(SS=0) D
214 . S RP=$F(COND,")",SS)-2
215 . I RP=-2 D Q
216 .. N TEXT
217 .. S TEXT=$E(COND,SS-2,$L(COND))_" is missing a "")"""
218 .. D EN^DDIOL(TEXT)
219 .. S VALID=0
220 . S SUBL=$E(COND,SS,RP)
221 . F IND=1:1:$L(SUBL,",") D
222 .. S SUB=$P(SUBL,",",IND)
223 ..;Check for a number.
224 .. I SUB=+SUB Q
225 ..;Check for a wildcard, must be in quotes any number of * allowed.
226 .. I SUB?1"""1"*"."*"""" Q
227 .. ;Check for first and last character = to a ".
228 .. I ($E(SUB,1)'="""")!($E(SUB,$L(SUB))'="""") S VALID=0
229 I 'VALID D EN^DDIOL("All V subscripts must be quoted strings, numbers or *!")
230 Q VALID
231 ;
Note: See TracBrowser for help on using the repository browser.