source: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMFFDB.m

Last change on this file was 636, checked in by George Lilly, 15 years ago

WorldVistAEHR overlayed on FOIAVistA

File size: 7.7 KB
Line 
1PXRMFFDB ;SLC/PKR - Function finding data structure builder. ;06/22/2006
2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
3 ;
4 ;===========================================
5BASE2(NUM) ;Convert a base 10 integer to base 2.
6 N BD,BIN
7 S BIN=""
8 F Q:NUM=0 D
9 . S BD=$S((NUM\2)=(NUM/2):0,1:1)
10 . S BIN=BD_BIN,NUM=NUM\2
11 Q BIN
12 ;
13 ;===========================================
14CRESLOG(NUM,FLIST,RESLOG) ;Check the resolution logic to see if
15 ;it can be made true solely by function findings. If that is the case
16 ;warn the user. Called by BLDRESLS^PXRMLOGX
17 N AGEFI,BP,FI,FF,FFL,IND,JND,KND,LE,LEN,LND,NFF,NTC,SEXFI,TEMP,VALUE
18 S (AGEFI,SEXFI)=0
19 S NFF=0
20 F IND=1:1:NUM D
21 . S JND=$P(FLIST,";",IND)
22 . I +JND=JND S FI(JND)=0 Q
23 . I JND["FF" S NFF=NFF+1,FF=$P(JND,"FF",2),FFL(NFF)=FF
24 I NFF=0 Q
25 ;Generate and test all combinations of true and false FFs.
26 S VALUE=0
27 S NTC=$$PWR^XLFMTH(2,NFF)-1
28 F IND=1:1:NTC Q:VALUE D
29 . S BIN=$$BASE2(IND)
30 . S LEN=$L(BIN)
31 . S LE=NFF-LEN
32 .;Fill in the values for the implied preceeding 0s.
33 . F JND=1:1:LE S KND=FFL(JND),FF(KND)=0
34 . S LND=0
35 . F JND=LE+1:1:NFF D
36 .. S KND=FFL(JND),LND=LND+1
37 .. S FF(KND)=$E(BIN,LND)
38 . I @RESLOG
39 . S VALUE=$T
40 I VALUE D
41 . N RESLSTR
42 . S RESLSTR=RESLOG
43 . F IND=1:1:NUM D
44 .. S JND=$P(FLIST,";",IND)
45 .. S TEMP=$S(JND["FF":"FF("_$P(JND,"FF",2)_")",1:"FI("_JND_")")
46 .. S RESLOG=$$STRREP^PXRMUTIL(RESLOG,TEMP,@TEMP)
47 . S RESLOG=$$STRREP^PXRMUTIL(RESLOG,"AGE",AGEFI)
48 . S RESLOG=$$STRREP^PXRMUTIL(RESLOG,"SEX",SEXFI)
49 . W !!,"Warning - your resolution logic can be satisfied by function findings only."
50 . W !,"If this happens it will not be possible to calculate a resolution date and"
51 . W !,"the reminder will not be resolved. Here is a case where the logic evaluates"
52 . W !,"to true:"
53 . W !,RESLSTR
54 . W !,RESLOG
55 . W !
56 Q
57 ;
58 ;=============================================================
59FFBUILD(X,DA) ;Given a function finding logical string build the data
60 ;structure. This is called by a new-style cross-reference after
61 ;the function string has passed the input transform so we don't need
62 ;to validate the elements.
63 ;Do not execute as part of a verify fields.
64 I $G(DIUTIL)="VERIFY FIELDS" Q
65 ;Do not execute as part of exchange.
66 I $G(PXRMEXCH) Q
67 N FDA,FUNNUM,FUNP,IENB,IENS,IND,JND,L2,L3,LEN,LIST,LOGIC,OPER,MSG
68 N PFSTACK,REPL,RS,TEMP,TS,XS
69 S IENB=DA_","_DA(1)_","
70 S OPER="!&<>='"
71 S XS=$$PSPACE(X)
72 D POSTFIX^PXRMSTAC(XS,OPER,.PFSTACK)
73 S (FUNNUM,L2)=0
74 F IND=1:1:PFSTACK(0) D
75 . S TEMP=PFSTACK(IND)
76 . I $D(^PXRMD(802.4,"B",TEMP)) D
77 .. S FUNP=$O(^PXRMD(802.4,"B",TEMP,""))
78 .. S FUNNUM=FUNNUM+1,L2=L2+1
79 .. S IENS="+"_L2_","_IENB
80 .. S FDA(811.9255,IENS,.01)=FUNNUM
81 .. S FDA(811.9255,IENS,.02)=FUNP
82 .. S IND=IND+1
83 .. S LIST=$TR(PFSTACK(IND),"~"," ")
84 .. S REPL(FUNNUM)=TEMP_"("_LIST_")"_U_"FN("_FUNNUM_")"
85 .. S L3=L2
86 .. S LEN=$L(LIST,",")
87 .. F JND=1:1:LEN D
88 ... S L3=L3+1
89 ... S IENS="+"_L3_",+"_L2_","_IENB
90 ... S TS=$P(LIST,",",JND)
91 ... S TS=$TR(TS,"""","")
92 ... S FDA(811.9256,IENS,.01)=TS
93 .. S L2=L3
94 ;Build the logic string
95 S LOGIC=X
96 F IND=1:1:FUNNUM D
97 . S TS=$P(REPL(IND),U,1)
98 . S RS=$P(REPL(IND),U,2)
99 . S LOGIC=$$STRREP^PXRMUTIL(LOGIC,TS,RS)
100 S FDA(811.925,IENB,10)=LOGIC
101 D UPDATE^DIE("","FDA","IENB","MSG")
102 I $D(MSG) D
103 . W !,"The update failed, UPDATE^DIE returned the following error message:"
104 . D AWRITE^PXRMUTIL("MSG")
105 Q
106 ;
107 ;=============================================================
108FFKILL(X,DA) ;This is the kill logic for the function string.
109 ;Do not execute as part of a verify fields.
110 I $G(DIUTIL)="VERIFY FIELDS" Q
111 ;Do not execute as part of exchange.
112 I $G(PXRMEXCH) Q
113 K ^PXD(811.9,DA(1),25,DA,5),^PXD(811.9,DA(1),25,DA,10)
114 Q
115 ;
116 ;=============================================================
117ISGRV(VAR) ;Return true if VAR is a global reminder variable.
118 I VAR="PXRMAGE" Q 1
119 I VAR="PXRMDOB" Q 1
120 I VAR="PXRMLAD" Q 1
121 I VAR="PXRMSEX" Q 1
122 Q 0
123 ;
124 ;=============================================================
125ISSTR(STRING) ;Return true if STRING really is a string and it is not
126 ;executable Mumps code.
127 N VALID,X
128 S VALID=0
129 ;Valid strings are "text" or because of $P ,"text" or ",U".
130 I $E(STRING,1)="""",$E(STRING,$L(STRING))="""" S VALID=1
131 I 'VALID,$E(STRING,1)=",",$E(STRING,2)="""",$E(STRING,$L(STRING))="""" S VALID=1
132 I 'VALID,STRING=",U" S VALID=1
133 I 'VALID Q VALID
134 S X=STRING
135 D ^DIM
136 S VALID=$S($D(X)=0:1,1:0)
137 Q VALID
138 ;
139 ;=============================================================
140PSPACE(OPR) ;OPR is an operand in a function finding, if some portion
141 ;of OPR is a string translate a space into "~" so it is preserved.
142 N END,START,TNS,TS
143 S START=$F(OPR,"""")
144 I START=0 Q OPR
145 S END=$F(OPR,"""",START)-2
146 S TS=$E(OPR,START,END)
147 S TNS=$TR(TS," ","~")
148 S OPR=$$STRREP^PXRMUTIL(OPR,TS,TNS)
149 Q OPR
150 ;
151 ;=============================================================
152VFFORM(TEMP,X) ;Make sure the function has a valid form, i.e., function
153 ;followed by an argument list.
154 N DONE,LP,RP,START,VALID
155 S DONE=0,VALID=1,START=0
156 F Q:DONE D
157 . S START=$F(X,TEMP,START)
158 . I START=0 S DONE=1 Q
159 . S LP=$E(X,START)
160 . I LP'="(" S VALID=0,DONE=1 Q
161 . S START=$F(X,")",START)
162 . S RP=$E(X,START-1)
163 . I RP'=")" S VALID=0
164 I 'VALID D
165 . N TEXT
166 . S TEXT="Function "_TEMP_" must be followed by an argument list!"
167 . D EN^DDIOL(.TEXT)
168 Q VALID
169 ;
170 ;=============================================================
171VFINDING(X,DAI) ;Make sure a finding number is a valid member of the
172 ;definition finding multiple. Input transform for function
173 ;finding finding number.
174 ;Do not execute as part of a verify fields.
175 I $G(DIUTIL)="VERIFY FIELDS" Q 1
176 ;Do not execute as part of exchange.
177 I $G(PXRMEXCH) Q 1
178 I '$D(DAI) Q 1
179 ;If X is not numeric it is not a finding number.
180 I +X'=X Q 1
181 I $D(^PXD(811.9,DAI,20,X,0)) Q 1
182 E D Q 0
183 . N TEXT
184 . S TEXT="Finding number "_X_" does not exist!"
185 . D EN^DDIOL(TEXT)
186 ;
187 ;=============================================================
188VFSTRING(FFSTRING,DA) ;Make sure a function finding string is valid.
189 ;The elements can be functions, operators, and numbers.
190 ;Do not execute as part of a verify fields.
191 I $G(DIUTIL)="VERIFY FIELDS" Q 1
192 ;Do not execute as part of exchange.
193 I $G(PXRMEXCH) Q 1
194 I '$D(DA) Q 1
195 N DAI,DATE,FUNIEN,IND,LIST,MFUN,OPER,PFSTACK,TEMP,TEXT,VALID
196 S DAI=DA(1)
197 S OPER="!&<>='"
198 ;Define the allowed M functions.
199 S MFUN("$P")=""
200 D POSTFIX^PXRMSTAC(FFSTRING,OPER,.PFSTACK)
201 S VALID=1
202 F IND=1:1:PFSTACK(0) Q:'VALID D
203 . S TEMP=PFSTACK(IND)
204 . I $D(^PXRMD(802.4,"B",TEMP)) D Q
205 .. S VALID=$$VFFORM(TEMP,X)
206 .. I 'VALID Q
207 .. S FUNIEN=$O(^PXRMD(802.4,"B",TEMP,""))
208 .. S IND=IND+1
209 .. S LIST=$G(PFSTACK(IND))
210 .. S VALID=$$VLIST(LIST,DAI,TEMP,FUNIEN)
211 .;Check for operator
212 . I OPER[TEMP Q
213 .;Check for number
214 . I TEMP=+TEMP Q
215 .;Check for allowed M function.
216 . I $D(MFUN(TEMP)) Q
217 .;Check for a global reminder variable
218 . I $$ISGRV(TEMP) Q
219 .;Check for a non-executable string.
220 . I $$ISSTR(TEMP) Q
221 . S VALID=0
222 . S TEXT=TEMP_" is not a valid Function Finding element!"
223 . D EN^DDIOL(TEXT)
224 I VALID D
225 . N X
226 . S X="I "_FFSTRING
227 . D ^DIM
228 . I $D(X)=0 S VALID=0
229 I 'VALID D
230 . S TEMP=FFSTRING_" is not a valid function string"
231 . D EN^DDIOL(TEMP)
232 Q VALID
233 ;
234 ;=============================================================
235VLIST(LIST,DAI,FUNCTION,FUNIEN) ;Make sure the function argument list
236 ;is valid.
237 N AT,IND,LEN,PATTERN,VALID,X
238 S LEN=$L(LIST,",")
239 I LEN=0 D Q 0
240 . N TEXT
241 . S TEXT="The argument list is not defined!"
242 . D EN^DDIOL(TEXT)
243 S PATTERN=$P(^PXRMD(802.4,FUNIEN,0),U,5)
244 S VALID=$S(LIST?@PATTERN:1,1:0)
245 I 'VALID D Q 0
246 . N TEXT
247 . S TEXT="Argument list "_LIST_" is not correct for function "_$P(^PXRMD(802.4,FUNIEN,0),U,1)
248 . D EN^DDIOL(TEXT)
249 F IND=1:1:LEN D
250 . S X=$P(LIST,",",IND)
251 . S AT=$$ARGTYPE^PXRMFFAT(FUNCTION,IND)
252 . I AT="U" S VALID=0 Q
253 . I AT="F",'$$VFINDING(X,DAI) S VALID=0
254 Q VALID
255 ;
Note: See TracBrowser for help on using the repository browser.