source: cprs/branches/tmg-cprs/m_files/TMGDIS0.m@ 1009

Last change on this file since 1009 was 796, checked in by Kevin Toppenberg, 15 years ago

Initial upload
File size: 9.0 KB
Line 
1TMGDIS0 ;TMG/kst/Custom DIS0, non-interactive SEARCH, IF STATEMENT AND MULTIPLE COMBO'S ;5/13/10 ; 5/16/10 10:01pm
2 ;;1.0;TMG-LIB;**1**;01/01/06
3 ;-----Prior header below -------------
4 ;SFISC/GFT-SEARCH, IF STATEMENT AND MULTIPLE COMBO'S ;30JAN2005
5 ;;22.0;VA FileMan;**144**;Mar 30, 1999;Build 5
6 ;
7DIS0(TMGINFO,TMGOUT,TMGBYROOT) ;
8 ;"Purpose: Provide an API interface for the classic Fileman console search
9 ;"Input: TMGINFO -- PASS BY REFERENCE. This is pre-defined search terms. Format:
10 ;" TMGINFO("FILE") -- File name or number to be used for search
11 ;" TMGINFO(1,...) -- Search condition 1 (corresponds to 'A' in console)
12 ;" TMGINFO(2,...) -- Search condition 2 (corresponds to 'B' in console)
13 ;" TMGINFO("LOGIC-IF")=(OPTIONAL) Logic string that would be normally
14 ;" entered at 'IF: ' prompt
15 ;" e.g. "1&2", or "A&B", or "AB" <--- all the same
16 ;" Default is logic string ANDing all search terms.
17 ;" TMGINFO("LOGIC-OR",1)=(OPTIONAL) Logic string that would be normally
18 ;" entered at 'OR: ' prompt
19 ;" TMGINFO("LOGIC-OR",#)=(OPTIONAL) Logic string that would be normally
20 ;" entered at 'OR: ' prompt. #=2,3,4... For multiple
21 ;" lines of OR logic
22 ;" NOTE: Fileman console labels search terms as "A","B","C",...
23 ;" But the above numbering system uses "1","2","3",...
24 ;" When entering in logic strings, one may use either letters
25 ;" or numbers. A=1, B=2 etc. Note that Fileman allows AB to
26 ;" mean the same as A&B. This is not possible with numbers.
27 ;" ...
28 ;" --DETAILS ON SEARCH CONDITION----
29 ;" TMGINFO(n,"FLD") -- The Fileman field name or number to seach in
30 ;" TMGINFO(n,"COND") -- The condition: "=,>,<,[,?,NULL" Prefix ' or - to negate
31 ;" TMGINFO(n,"VALUE") -- the value to search for
32 ;" TMGOUT --An OUT PARAMETER. Prior values killed. Format:
33 ;" TMGOUT(FILENUM,IEN)=""
34 ;" TMGOUT(FILENUM,IEN)=""
35 ;" TMGOUT(FILENUM,IEN)=""
36 ;" TMGBYROOT -- (Optional) If 1, then TMGOUT is treated as a variable NAME (root)
37 ;" i.e. @TMGOUT@(FILENUM,IEN)=""
38 ;"Globally-Scoped variables uses: O,DC,DA (and probably others)
39 ;"Results: 1 if OK, or -1^Error Message
40 ;
41 ;"WRITE !
42 NEW TMGRESULT SET TMGRESULT=1 ;"Default to success
43 NEW R,N,DL,DE,DJ ;"WAS KILL initially
44 NEW P,LOGIC,NLOG
45 NEW DU
46 SET O=0
47 SET E=$DATA(DC(2)) ;"E>0 IF MORE THAN ONE SRCH TERM
48 SET N="IF: A// "
49 SET DE=$SELECT(E:"IF: ",1:N)
50 NEW TMGLMODE SET TMGLMODE=1 ;"1="LOGIC-IF" 2=LOGIC-OR
51 NEW TMGLORN SET TMGLORN=0 ;"Logic OR line number
52 SET DL=0
53 SET C=","
54R ;"WRITE !,DE
55 KILL DV
56 IF TMGLMODE=1 DO
57 . SET X=$GET(INFO("LOGIC-IF"))
58 . IF X'="" QUIT
59 . NEW I SET I=0
60 . FOR SET I=$ORDER(INFO(I)) QUIT:+I'>0 SET X=X_$CHAR(I+64)
61 . SET INFO("LOGIC-IF")=X
62 ELSE DO
63 . SET TMGLORN=TMGLORN+1
64 . SET X=$GET(INFO("LOGIC-OR",TMGLORN))
65 IF X'="" GOTO R2
66 ;"READ X:DTIME SET:'$T DTOUT=1 GOTO Q:X[U!'$T
67 SET DV=1,DU=X
68 GOTO 1:DL
69 SET DQ="TYPE '^' TO EXIT"
70 SET Y="^1^"
71 SET DL=1
72 ;"GOTO BAD:E
73 IF E="" DO GOTO TMGDONE
74 . SET TMGRESULT="-1^Bad/absent logic string."
75 DO ASKQ(.DC,.DV,.DU)
76 GOTO L
77 ;
78R2 SET Y=U,P=0,DU="",D=""
79 SET DL=DL+1
80P ;"PARSE LOGIC STRING
81 SET LOGIC=X,LOGN=0
82 FOR QUIT:(LOGIC="")!(+TMGRESULT=-1) DO
83 . SET DV=0
84 . IF +LOGIC>0 DO
85 . . SET (DV,DQ)=+LOGIC
86 . . SET LOGIC=$EXTRACT($LENGTH(DQ)+1,9999)
87 . ELSE DO
88 . . SET DQ=$EXTRACT(LOGIC,1)
89 . . SET LOGIC=$EXTRACT(LOGIC,2,9999)
90 . . IF DQ?.A SET DV=$ASCII(DQ)-64
91 . IF (DV>0)&($DATA(DC(DV))>0) DO QUIT
92 . . SET LOGN=LOGN+1
93 . . DO ASKQ(.DC,.DV,.DU)
94 . . SET TMGRESULT=$$CHK(DV)
95 . IF "&+ "[DQ QUIT
96 . IF ((DU="")&("'-"[DQ)) SET DU="'" QUIT
97 . SET TMGRESULT="-1^Bad entry '"_DQ_"' found in logic phrase '"_X_"'"
98 IF LOGN'>0 SET TMGRESULT="-1^No valid logic terms found in '"_X_"'"
99 IF +TMGRESULT=-1 GOTO TMGDONE
100 GOTO L
101 ;
102 ;"BAD DO
103 ;" . IF DQ?."?" DO QUIT
104 ;" . . DO BLD^DIALOG($SELECT($DATA(DC(2)):8004.2,1:8004.1))
105 ;" . . DO MSG^DIALOG("WH") ;HELP depending on whether there is a CONDITION B
106 ;" . WRITE " <",DQ,">??"
107 ;" WRITE !!
108 ;" KILL DJ(DL),DE(DL)
109 ;" SET DL=DL-1
110 ;" GOTO R
111 ;
112ASKQ(DC,DV,DU) ;"-------------
113 NEW J,%,I
114 SET J=DC(DV)
115 SET %=J["?."" """
116 SET I=J["^'"+(DU["'")#2
117 IF J["W^" DO QUIT
118 . SET DV(DV)=$SELECT(I:2-%,1:%+%+1)
119 . IF % SET DC(DV)=$EXTRACT(J,1,$LENGTH(J)-5)_"="""""
120 IF $PIECE(J,U)[C SET DV(DV)=J?.E1",.01^".E&%+(I+%#2)
121 QUIT
122 ;
123CHK(DV) ;Check search term
124 ;"Result: 1 if OK, -1^ErrorMessage
125 NEW %
126 NEW RSLT SET RSLT=1 ;"Default to success
127 SET %=$F(Y,U_DV)
128 IF % DO GOTO CKDN ;"Was BAD
129 . SET %=$PIECE($EXTRACT(Y,%),U,1)'=DU
130 . SET DQ=""""_DQ_""" AND """_$EXTRACT("'",%)_DQ_""" IS "_$PIECE("REDUNDANT^CONTRADICTORY",U,%+1)
131 . SET RSLT="-1^"_DQ
132 SET %=1
133 SET Y=Y_DV_DU_U
134 SET DU=""
135 SET J=$PIECE(DC(DV),U,1)
136 IF J'[C GOTO CKDN ;"WAS P
137 FOR Z=2:1 IF $PIECE(J,C,Z,99)'[C SET J=$PIECE(J,C,1,Z-1)_C QUIT
138 IF J=D DO
139 . DO SAMEQ ;"result in %
140 . IF %=1 SET DJ(DL,DV)=DX(DV)
141 SET D=J,DJ=DV
142 ;"IF %>0 GOTO P
143 IF %'>0 DO GOTO CKDN
144 . SET RSLT="-1^Error checking search term #"_DV
145CKDN QUIT RSLT
146 ;"Q GOTO Q^DIS2
147 ;
148SAMEQ ;----
149 IF (J<0),$PIECE(DY(-J),U,3)="" QUIT
150 ;"NOTE!!!: Answer to question below FORCED TO BE 'YES' FOR NOW. Later figure how to specify in INFO array
151 ;"WRITE !?8,"CONDITION -"_$C(DV+64)_"- WILL APPLY TO THE SAME MULTIPLE AS CONDITION -"_$C(DJ+64)_"-",!?8,"...OK"
152 ;"DO YN^DICN
153 SET %=1 ;"FORCE 'YES' answer
154 QUIT
155 ;
156 ;-----------------
157L SET P=O
158 SET DL(DL)=Y
159 SET DE="OR: "
160 SET TMGLMODE=2 ;"OR mode
161 FOR %=2:1 SET X=$PIECE(Y,U,%) QUIT:X="" DO
162 . SET O=O+1
163 . NEW S SET S=$SELECT($DATA(DJ(DL,+X)):" together with ",1:" and ")
164 . SET ^UTILITY($J,O,0)=$SELECT(%>2:S,O=1:"",1:" Or ")_$PIECE("not ",U,X["'")_O(+X)
165 ;"WRITE:$X>18 !
166 ;"WRITE " "
167 ;"FOR %=P+1:1 Q:'$DATA(^UTILITY($J,%,0)) DO
168 ;". SET X=^(0)
169 ;". IF $LENGTH(X)+$X>77 WRITE !?13
170 ;". WRITE " "_$PIECE(X,U)
171 ;". IF $PIECE(X,U,2)'="" WRITE " ("_$PIECE(X,U,2)_")"
172 SET DV=0
173DV SET DV=$ORDER(DV(DV))
174 IF DV="" SET DV=-1
175 ;"GOTO:DV'>0 R:E,1
176 IF (DV'>0)&E GOTO R ;"Go back and ask for OR" logic phrase
177 IF (DV'>0) GOTO 1
178 IF $DATA(DJ(DL,DV)) GOTO DV
179 SET I=$PIECE(DC(DV),U,1),D=DK,DN=0
180 SET Y="DO YOU WANT THIS SEARCH SPECIFICATION TO BE CONSIDERED TRUE FOR CONDITION -"_$C(DV+64)_"-"
181G SET DN=DN+1
182 SET P=$PIECE(I,C,1)
183 SET I=$PIECE(I,C,2,99)
184 IF P["W" GOTO W
185 IF I="" GOTO DV
186 IF P<0 DO GOTO G:'$PIECE(J,U,3)
187 . SET J=DY(-P)
188 . SET D=+J
189 . SET R=" '"_$PIECE(^DIC(D,0),U,1)_"' ENTRIES "
190 ELSE DO
191 . SET D=+$PIECE(^DD(D,P,0),U,2),R=" '"_$ORDER(^DD(D,0,"NM",0))_"' MULTIPLES "
192HOW ;
193 ;"NOTE!!! -- I am forcing answers to be the default ones for now. Later figure out how to
194 ;" specify pre-defined answers in the INFO array
195 ;"
196 ;"WRITE !!,Y,!?8,"1) WHEN AT LEAST ONE OF THE"_R_"SATISFIES IT"
197 ;"WRITE !?8,"2) WHEN ALL OF THE"_R_"SATISFY IT" SET X=2
198 ;"IF DV(DV) DO
199 ;". WRITE !?8,"3) WHEN ALL OF THE"_R_"SATISFY IT,",!?16,"OR WHEN THERE ARE NO"_R
200 ;". SET X=3
201 ;"WRITE !?4,"CHOOSE 1-"_X_": "
202 IF DV(DV)>1 DO
203 . ;"WRITE 3
204 . SET %1=3
205 ELSE DO
206 . ;"WRITE 1
207 . SET %1=1
208 ;"READ "// ",%:DTIME,!
209 ;"SET:'$T DTOUT=1 SET:%="" %=%1
210 SET %=%1 ;"//KT
211 KILL %1
212 ;"GOTO Q:%=U!'$T
213 ;"GOTO HOW:%>X!'%
214 IF %>1 DO
215 . SET DE(DL,DV,DN)=%
216 . SET O=O+1
217 . SET ^UTILITY($J,O,0)=" for all"_R_$PIECE(", or when no"_R_"exist",U,%>2)
218 GOTO G
219 ;
220W IF DV(DV)-2 DO GOTO DV
221 . SET DE(DL,DV,DN)=DV(DV)
222 ;"NOTE!!! I am setting the answer to the question below to the default value.
223 ;" Later figure out how to pass predefined answer in INFO array from programmer
224 ;"WRITE !!,Y,!?7,"WHEN THERE IS NO '"_$PIECE(^DD(D,+P,0),U,1)_"' TEXT AT ALL"
225 SET %=1
226 ;"DO YN^DICN
227 ;"GOTO Q:%<0
228 ;"GOTO W:'%
229 SET DE(DL,DV,DN)=4-%
230 GOTO DV
231 ;
2321 KILL DX,Y ;"removed O from kill
233 DO DIS1^TMGDIS1 ;"Sets TMGRESULT, WAS GOTO ^DIS1
234 GOTO TMGDONE
235 ;
236TMGDONE ;
237 QUIT
Note: See TracBrowser for help on using the repository browser.