source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMFFDB.m@ 619

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

initial load of WorldVistAEHR
File size: 7.8 KB
RevLine 
[613]1PXRMFFDB ;SLC/PKR - Function finding data structure builder. ;10/31/2007
2 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
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 ;Note this will work for the entire function string.
143 N DONE,END,START,TNS,TS
144 S DONE=0,END=1
145 F Q:DONE D
146 . S START=$F(OPR,"""",END)
147 . I START=0 S DONE=1 Q
148 . S END=$F(OPR,"""",START)
149 . S TS=$E(OPR,START,END-2)
150 . S TNS=$TR(TS," ","~")
151 . S OPR=$$STRREP^PXRMUTIL(OPR,TS,TNS)
152 Q OPR
153 ;
154 ;=============================================================
155VFFORM(TEMP,X) ;Make sure the function has a valid form, i.e., function
156 ;followed by an argument list.
157 N DONE,LP,RP,START,VALID
158 S DONE=0,VALID=1,START=0
159 F Q:DONE D
160 . S START=$F(X,TEMP,START)
161 . I START=0 S DONE=1 Q
162 . S LP=$E(X,START)
163 . I LP'="(" S VALID=0,DONE=1 Q
164 . S START=$F(X,")",START)
165 . S RP=$E(X,START-1)
166 . I RP'=")" S VALID=0
167 I 'VALID D
168 . N TEXT
169 . S TEXT="Function "_TEMP_" must be followed by an argument list!"
170 . D EN^DDIOL(.TEXT)
171 Q VALID
172 ;
173 ;=============================================================
174VFINDING(X,DAI) ;Make sure a finding number is a valid member of the
175 ;definition finding multiple. Input transform for function
176 ;finding finding number.
177 ;Do not execute as part of a verify fields.
178 I $G(DIUTIL)="VERIFY FIELDS" Q 1
179 ;Do not execute as part of exchange.
180 I $G(PXRMEXCH) Q 1
181 I '$D(DAI) Q 1
182 ;If X is not numeric it is not a finding number.
183 I +X'=X Q 1
184 I $D(^PXD(811.9,DAI,20,X,0)) Q 1
185 E D Q 0
186 . N TEXT
187 . S TEXT="Finding number "_X_" does not exist!"
188 . D EN^DDIOL(TEXT)
189 ;
190 ;=============================================================
191VFSTRING(FFSTRING,DA) ;Make sure a function finding string is valid.
192 ;The elements can be functions, operators, and numbers.
193 ;Do not execute as part of a verify fields.
194 I $G(DIUTIL)="VERIFY FIELDS" Q 1
195 ;Do not execute as part of exchange.
196 I $G(PXRMEXCH) Q 1
197 I '$D(DA) Q 1
198 N DAI,DATE,FUNIEN,IND,LIST,MFUN,OPER,PFSTACK,TEMP,TEXT,VALID
199 S DAI=DA(1)
200 S OPER="!&-+<>='"
201 ;Define the allowed M functions.
202 S MFUN("$P")=""
203 D POSTFIX^PXRMSTAC(FFSTRING,OPER,.PFSTACK)
204 S VALID=1
205 F IND=1:1:PFSTACK(0) Q:'VALID D
206 . S TEMP=PFSTACK(IND)
207 . I $D(^PXRMD(802.4,"B",TEMP)) D Q
208 .. S VALID=$$VFFORM(TEMP,X)
209 .. I 'VALID Q
210 .. S FUNIEN=$O(^PXRMD(802.4,"B",TEMP,""))
211 .. S IND=IND+1
212 .. S LIST=$G(PFSTACK(IND))
213 .. S VALID=$$VLIST(LIST,DAI,TEMP,FUNIEN)
214 .;Check for operator
215 . I OPER[TEMP Q
216 .;Check for number
217 . I TEMP=+TEMP Q
218 .;Check for allowed M function.
219 . I $D(MFUN(TEMP)) Q
220 .;Check for a global reminder variable
221 . I $$ISGRV(TEMP) Q
222 .;Check for a non-executable string.
223 . I $$ISSTR(TEMP) Q
224 . S VALID=0
225 . S TEXT=TEMP_" is not a valid Function Finding element!"
226 . D EN^DDIOL(TEXT)
227 I VALID D
228 . N X
229 . S X="I "_FFSTRING
230 . D ^DIM
231 . I $D(X)=0 S VALID=0
232 I 'VALID D
233 . S TEMP=FFSTRING_" is not a valid function string"
234 . D EN^DDIOL(TEMP)
235 Q VALID
236 ;
237 ;=============================================================
238VLIST(LIST,DAI,FUNCTION,FUNIEN) ;Make sure the function argument list
239 ;is valid.
240 N AT,IND,LEN,PATTERN,VALID,X
241 S LEN=$L(LIST,",")
242 I LEN=0 D Q 0
243 . N TEXT
244 . S TEXT="The argument list is not defined!"
245 . D EN^DDIOL(TEXT)
246 S PATTERN=$P(^PXRMD(802.4,FUNIEN,0),U,5)
247 S VALID=$S(LIST?@PATTERN:1,1:0)
248 I 'VALID D Q 0
249 . N TEXT
250 . S TEXT="Argument list "_LIST_" is not correct for function "_$P(^PXRMD(802.4,FUNIEN,0),U,1)
251 . D EN^DDIOL(TEXT)
252 F IND=1:1:LEN D
253 . S X=$P(LIST,",",IND)
254 . S AT=$$ARGTYPE^PXRMFFAT(FUNCTION,IND)
255 . I AT="U" S VALID=0 Q
256 . I AT="F",'$$VFINDING(X,DAI) S VALID=0
257 Q VALID
258 ;
Note: See TracBrowser for help on using the repository browser.