source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/ARJTDDK3.m@ 1361

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

initial load of WorldVistAEHR
File size: 7.6 KB
Line 
1ARJTDDK3 ;PUG/TOAD-FileMan Search All MUMPS Fields ;7/8/02 10:43
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;
4 ; table of contents:
5 ; SEARCHNS - search N fields in every entry in 1 file or subfile
6 ; WALK - recursively traverse all entries in a file or subfile
7 ; TITLE - convert a string to Title Case
8 ; CONTAINS - function: does code contain what we're looking for
9 ;
10 ; calls:
11 ; CHECK^ARJTDIM = to search each value (MUMPS code)
12 ;
13 ; input:
14 ; .CONTAINS(string)="" to search any line containing the string
15 ; FIND = optional. special search, e.g., "DSM"
16 ;
17 ; output: report to current device
18 ; .EXIT = 1 if search interrupted
19 ; report to current device
20 ;
21 ;
22SEARCHNS(LIST,CONTAINS,FIND,COUNT,MATCHES,EXIT) ; search N fields in 1 file or subfile
23 ;
24 ; input: .LIST(file #,field #)="" --> fields to search
25 ; in/output:
26 ; .COUNT = # of field values checked
27 ; .MATCHES = # instances found
28 ; calls:
29 ; $$TITLE - convert test to Title Case
30 ; WALK - recursively traverse all entries in file/subfile
31 ; called by: MUMPS^ARJTDDKM, TEXT^ARJTDDK5
32 ;
33 ; table of contents:
34 ; 1. Build File Code
35 ; 2. Build Field Code
36 ; 3. Search (Sub)File
37 ;
38 ;
39 ; 1. BUILD FILE CODE
40 ;
41 ; 1.1. Trace DD's ancestry
42 N DD S DD=$O(@LIST@(0)) ; ID file/subfile to search
43 Q:'DD ; we need a starting DD #
44 Q:'$D(DD) ; it needs to be a real file or subfile
45 N LEVEL S LEVEL=1 ; default to top-level file
46 N PARENT ; parent of each DD entry ("" for top-level files)
47 ;
48 F D Q:'PARENT ; trace back through ancestry
49 . ;
50 . ; get subscript info for lower level after 1st loop
51 . I LEVEL>1 D
52 . . N FIELD S FIELD=+$O(^DD(DD,"B",DD(LEVEL-1,"NM"),0))
53 . . S DD(LEVEL-1,"FD")=FIELD
54 . . S DD(LEVEL-1,"SUB")=+$P($G(^DD(DD,FIELD,0)),U,4)
55 . ;
56 . ; get basic info for current level
57 . S DD(LEVEL)=DD ; add current DD level to ancestry
58 . S DD(LEVEL,"NM")=$O(^DD(DD,0,"NM","")) ; get DD level's name
59 . I DD(LEVEL,"NM")="" S DD(LEVEL,"NM")=$P($G(^DIC(LEVEL,0)),U) ; for .7
60 . S PARENT=$G(^DD(DD,0,"UP")) Q:'PARENT ; does this DD have a parent
61 . S LEVEL=LEVEL+1 ; parent adds a level of depth to ancestry
62 . ;
63 . S DD=PARENT ; next pass let's investigate the parent
64 ;
65 ; 1.2. Build top-level code
66 ;
67 N ROOT S ROOT=$G(^DIC(DD,0,"GL")) Q:ROOT="" ; file root
68 N IEN S ROOT(1)=ROOT_"IEN(1)" ; top-level IEN
69 N ADVANCE
70 S ADVANCE(1)="S IEN(1)=$O("_ROOT(1)_"))" ; build traverse code
71 N NAME S NAME=$$TITLE(DD(LEVEL,"NM"))_" ("_DD_")"
72 W !,"Now searching "
73 I LEVEL=1 D
74 . W NAME," file (",$P($G(@(ROOT_"0)")),U,4)," entries)..."
75 ;
76 ; 1.3. Append subfile code
77 ;
78 N DEPTH S DEPTH=1 ; already handled top level above
79 F DD=LEVEL-1:-1:1 D ; handle remaining levels
80 . S NAME=NAME_"/"_$$TITLE(DD(DD,"NM"))_" ("_DD(DD)_")" ; extend name
81 . S DEPTH=DEPTH+1 ; one level deeper
82 . S ROOT(DEPTH)=ROOT(DEPTH-1)_","_DD(DD,"SUB")_",IEN("_DEPTH_")"
83 . S ADVANCE(DEPTH)="S IEN("_DEPTH_")=$O("_ROOT(DEPTH)_"))"
84 I DEPTH>1 W NAME," subfile..."
85 ;
86 ;
87 ; 2. BUILD FIELD CODE
88 ;
89 N FLDCNT S FLDCNT=0 ; how many fields will we be searching?
90 N NODE ; list of nodes containing the fields
91 N FIELD ; list of fields to search
92 S FIELD=0 F S FIELD=$O(@LIST@(DD(1),FIELD)) Q:'FIELD D
93 . N FIELDEF S FIELDEF=$G(^DD(DD(1),FIELD,0)) Q:FIELDEF="" ; field DD
94 . S NAME(FIELD)=$$TITLE($P(FIELDEF,U)) ; save off name of field
95 . Q:$P(FIELDEF,U,2) ; subfiles have subfile# in 2nd piece
96 . S FLDCNT=FLDCNT+1 ; we'll definitely search this field
97 . N HOME S HOME=$P(FIELDEF,U,4) ; node;place of field
98 . S NODE=ROOT(DEPTH)_","_+HOME_")" ; build root to fetch node
99 . S NODE="$G("_NODE_")" ; protect against undefined errors
100 . I '$D(NODE(+HOME)) D ; if we haven't already handled this node
101 . . S NODE(+HOME,"GET")="S NODE("_+HOME_")="_NODE ; build get code
102 . ;
103 . N GET
104 . N PLACE S PLACE=$P(HOME,";",2) ; place to fetch
105 . I PLACE D ; $Piece fields have a numeric place
106 . . S GET="S VALUE=$P(NODE("_+HOME_"),U,"_PLACE_")" ; build get code
107 . E D ; $Extract fields have E#,#
108 . . N FIRST S FIRST=+$P($P(PLACE,";"),"E",2) ; first position
109 . . N LAST S LAST=$P(PLACE,",",2) ; last position
110 . . S GET="S VALUE=$E(NODE("_+HOME_"),"_FIRST_","_LAST_")" ; get code
111 . S FIELD(FIELD,"GET")=GET
112 Q:'FLDCNT
113 ;
114 ;
115 ; 3. SEARCH (SUB)FILE
116 ;
117 N IENS S IENS(0)="" ; array for "incrementing" IEN String
118 S COUNT=+$G(COUNT) ; count of entries searched
119 S MATCHES=+$G(MATCHES) ; count of entries searched
120 D WALK(1) ; traverse file/subfile starting at top level
121 ;
122 QUIT ; end of SEARCHNS
123 ;
124 ;
125WALK(LEVEL) ; Recursively Traverse All Entries in a File or Subfile
126 ;
127 ; Each call traverses one level.
128 ; When the leaf level is reached, each entry is searched.
129 ; Called only by SEARCHNS.
130 ;
131 K IENS(LEVEL) ; clear the IENS for this level
132 S IEN(LEVEL)=0 F X ADVANCE(LEVEL) Q:'IEN(LEVEL) D Q:EXIT ; traverse
133 . S IENS(LEVEL)=IENS(LEVEL-1)_"/"_IEN(LEVEL) ; set up IENS for this record
134 . I LEVEL'=DEPTH D WALK(LEVEL+1) Q ; traverse children of internals
135 . ;
136 . ; otherwise, we're at a leaf level, so...
137 . ; load needed nodes into locals
138 . S NODE="" F S NODE=$O(NODE(NODE)) Q:NODE="" X NODE(NODE,"GET")
139 . ;
140 . S FIELD=0 F S FIELD=$O(FIELD(FIELD)) Q:'FIELD D Q:EXIT
141 . . S COUNT=COUNT+1
142 . . I '(COUNT#1000) W "." N READ R READ:0 S EXIT=READ=U Q:EXIT
143 . . X FIELD(FIELD,"GET") ; fetch field value for each entry
144 . . Q:'$$CONTAINS(VALUE,.CONTAINS) ; skip those that clearly don't match
145 . . ;
146 . . N ZZDCOM ; clear array of commands & special elements found
147 . . D CHECK^ARJTDIM(VALUE,FIND,.ZZDCOM) ; parse line
148 . . Q:'ZZDCOM ; skip lines that don't match
149 . . S MATCHES=MATCHES+1 ; this is a match
150 . . ; S COUNT=0 ; reset count to postpone printing a dot
151 . . ;
152 . . ; display match
153 . . ; match #, file/subfile path, field
154 . . W !!,MATCHES_". "_NAME_"/"_NAME(FIELD)_" ("_FIELD_"): "
155 . . ; entry
156 . . S $E(IENS(LEVEL))="" ; strip leading "/"
157 . . N ENTRY S ENTRY="Entry # "_IENS(LEVEL)
158 . . I 80-$X<$L(ENTRY) W ! ; keep IEN string to right
159 . . W $J(ENTRY,80-$X) ; IEN string of record
160 . . ; field value
161 . . F Q:VALUE="" W !?10,$E(VALUE,1,70) S $E(VALUE,1,70)="" ; value
162 . . N READ R READ:0 S EXIT=READ=U
163 ;
164 Q
165 ;
166TITLE(%STRING) ; Convert a string to Title Case
167 ;
168 ; create return value (which will be Title Case) from STRING
169 N %UPPER S %UPPER="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
170 N %LOWER S %LOWER="abcdefghijklmnopqrstuvwxyz"
171 N %TITLE S %TITLE=$G(%STRING)
172 ;
173 ; create parse string in which most punctuation are spaces
174 N %REPLACE S %REPLACE="!""#$%&'()*+,-./:;<=>?@[\]^_`{|}~"
175 N %WITH S %WITH=" "
176 N %PARSE S %PARSE=$TR(%STRING,%REPLACE,%WITH)
177 ;
178 ; traverse " "-pieces of parse string, clearing as we go
179 N %PIECE ; each " "-piece
180 N %LENGTH ; length of each " "-piece
181 N %FROM,%TO S %FROM=1 ; character positions of each " "-piece
182 N %COUNT F %COUNT=1:1:$L(%PARSE," ") D
183 . S %PIECE=$P(%PARSE," ") ; examine the leading " "-piece
184 . S %LENGTH=$L(%PIECE) ; measure it
185 . S %TO=%FROM+%LENGTH-1 ; map its position back to %TITLE
186 . ;
187 . ; handle contractions specially--don't capitalize
188 . I %LENGTH=1,$E(%TITLE,%FROM-1)="'",$E(%TITLE,%FROM-2)?1A D
189 . . S %PIECE=$TR(%PIECE,%UPPER,%LOWER)
190 . E D ; otherwise, follow the normal rules
191 . . S $E(%PIECE)=$TR($E(%PIECE),%LOWER,%UPPER) ; capitalize 1st char
192 . . S $E(%PIECE,2,$L(%PIECE))=$TR($E(%PIECE,2,$L(%PIECE)),%UPPER,%LOWER)
193 . S $E(%TITLE,%FROM,%TO)=%PIECE ; overlay converted piece on %TITLE
194 . ;
195 . S $E(%PARSE,1,%LENGTH+1)="" ; clear the leading " "-piece
196 . S %FROM=%TO+2 ; compute location of 1st character of next " "-piece
197 ;
198 Q %TITLE ; return the Title-Cased string
199 ;
200 ;
201CONTAINS(CODE,CONTAINS) ; function: does code contain what we're looking for
202 N DOES I $D(CONTAINS)#2 S DOES=CODE[CONTAINS Q DOES
203 I $D(CONTAINS)>9 D Q DOES
204 . N SUB S SUB=""
205 . F S SUB=$O(CONTAINS(SUB)) Q:SUB="" S DOES=CODE[SUB Q:DOES
206 Q 0
207 ;
Note: See TracBrowser for help on using the repository browser.