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

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

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1ARJTDDK5 ;PUG/TOAD-FileMan Search "Free-Text" MUMPS Fields ;7/8/02 10:24
2 ;;22.0;VA FileMan;;Mar 30, 1999;
3 ;
4 ; table of contents:
5 ; TEXT - find "free-text" MUMPS fields
6 ; LIKELY - function to guess if this is such a field
7 ; FEEDBACK - report finds & allow escape
8 ; TEST - test TEXT with alternation in pattern match
9 ;
10 ; input:
11 ; .CONTAINS(string)="" to search any line containing the string
12 ; FIND = optional. special search, e.g., "DSM"
13 ;
14 ; output:
15 ; .EXIT = 1 if search interrupted
16 ; report to current device
17 ;
18 ;
19TEXT(CONTAINS,FIND,EXIT) ; subroutine: find "free-text" MUMPS fields
20 ;
21 ; calls:
22 ; $$LIKELY - guess whether each field is likely to be one
23 ; FEEDBACK - report finds & allow escape
24 ; SEARCHNS^ARJTDDK3 - search N fields in 1 file or subfile
25 ;
26 ; TEXT.1. BUILD LIST OF "FREE-TEXT" MUMPS FIELDS
27 ;
28 W !!,"Building list of ""free-text"" MUMPS fields..."
29 K ^TMP("DIDUF",$J) ; clear master list array
30 S EXIT=0 ; not interrupted yet
31 N SEARCHED S SEARCHED=0
32 N FOUND S FOUND=0
33 N FILE S FILE=0 F S FILE=$O(^DD(FILE)) Q:'FILE D Q:EXIT
34 . N FIELD S FIELD=0 F S FIELD=$O(^DD(FILE,FIELD)) Q:'FIELD D Q:EXIT
35 . . S SEARCHED=SEARCHED+1
36 . . N NODE S NODE=$G(^DD(FILE,FIELD,0))
37 . . N POS S POS=$P(NODE,U,4)
38 . . Q:$E($P(POS,";",2))'="E" ; $extract, not $piece
39 . . N FLDNAME S FLDNAME=$P(NODE,U)
40 . . N TYPE S TYPE=$E($P(NODE,U,2))
41 . . I TYPE="R" S TYPE=$E($P(NODE,U,2),2) ; R = required
42 . . Q:TYPE'="F"&(TYPE'="M") ; only want free text or "M"
43 . . ; M is not a real field type, but several fields use it to mean MUMPS
44 . . Q:'$$LIKELY(FLDNAME,FILE,FIELD)
45 . . S FOUND=FOUND+1
46 . . S ^TMP("DIDUF",$J,FILE,FIELD)=""
47 . . D FEEDBACK(FILE,FIELD,FLDNAME,TYPE,.EXIT)
48 N FENTITY S FENTITY="""free-text"" MUMPS field"
49 D RESULTS^ARJTDDKU(EXIT,SEARCHED,FOUND,"Build","field","checked",FENTITY)
50 I EXIT K ^TMP("DIDUF",$J)
51 ;
52 ; TEXT.2. TRAVERSE LIST OF FILES & SUBFILES, RUNNING A SEARCH ON EACH
53 ;
54 W !!,"Now searching the data in those ""free-text"" MUMPS fields..."
55 S (SEARCHED,FOUND)=0 ; reset counters for the search
56 N ARJTLIST ; list of fields within each file or subfile/report
57 N FILE S FILE=0 F S FILE=$O(^TMP("DIDUF",$J,FILE)) Q:'FILE D Q:EXIT
58 . K ARJTLIST M ARJTLIST(FILE)=^TMP("DIDUF",$J,FILE)
59 . ; search each DD #
60 . D SEARCHNS^ARJTDDK3("ARJTLIST",.CONTAINS,FIND,.SEARCHED,.FOUND,.EXIT)
61 K ^TMP("DIDUF",$J)
62 D RESULTS^ARJTDDKU(EXIT,SEARCHED,FOUND,"Search","value","checked")
63 W !!!,"End of report. Have a nice day."
64 ;
65 QUIT ; end of TEXT
66 ;
67 ;
68LIKELY(NAME,FILE,FIELD) ; function: flag likely fields
69 ;
70 ; input:
71 ; NAME - name of field
72 ; FILE - file DD #
73 ; FIELD - field DD #
74 ; called by: EXTRACT
75 ;
76 I NAME["CODE" Q 1
77 I NAME["ACTION" Q 1
78 I NAME["LOGIC" Q 1
79 I NAME["DIR(0)" Q 1
80 I NAME["DIR(?)" Q 1
81 I NAME["DIR(??)" Q 1
82 I NAME["DR {DIE}" Q 1
83 I $G(^DD(FILE,FIELD,3))["MUMPS" Q 1 ; 'Help'-Prompt attribute (3)
84 I $G(^DD(FILE,FIELD,21,1,0))["MUMPS" Q 1 ; Description attribute (21)
85 Q 0
86 ;
87 ;
88FEEDBACK(FILE,FIELD,FLDNAME,TYPE,EXIT) ; subroutine: report finds & allow escape
89 ;
90 ; input:
91 ; FILE = file #
92 ; FIELD = field #
93 ; FLDNAME = name of field
94 ; TYPE = field's data type
95 ; output: .EXIT = 1 if interrupted
96 ; called by: EXTRACT
97 ;
98 N FILENAME S FILENAME=$O(^DD(FILE,0,"NM",""))
99 I FILENAME="" S FILENAME=$P($G(^DIC(FILE,0)),U) ; for Function file (.7)
100 W !,FILE," ",?10,FILENAME," "
101 W ?40,FIELD," ",?50,FLDNAME,?79,TYPE
102 N READ R READ:0 S EXIT=READ=U
103 QUIT ; end of FEEDBACK
104 ;
105 ;
106TEST ; test TEXT with DO command
107 ;
108 ; calls:
109 ; ^%ZOSF("PRIINQ") - return current process priority
110 ; TEXT - search all "free-text" MUMPS fields
111 ; ^%ZOSF("PRIORITY") - lower & raise priority
112 ;
113 W !!,"Testing TEXT^ARJTDDK5 with DO command."
114 W !!,"Lowering priority for duration of search.",!
115 N ARJTPRI,Y X ^%ZOSF("PRIINQ") S ARJTPRI=Y
116 N X S X=1 X ^%ZOSF("PRIORITY")
117 D TEXT("D","D")
118 S X=ARJTPRI X ^%ZOSF("PRIORITY")
119 W !!,"Priority restored."
120 QUIT ; end of TEST
121 ;
Note: See TracBrowser for help on using the repository browser.