source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXTOLKN.m@ 1739

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

initial load of WorldVistAEHR
File size: 3.3 KB
RevLine 
[613]1LEXTOLKN ; ISL Parse term into words ; 01-31-97
2 ;;2.0;LEXICON UTILITY;**4**;Sep 23, 1996;Build 1
3 ;
4 ; Returns ^TMP("LEXTKN",$J,#,WORD) containing words
5 ;
6 ; If LEXIDX is set, then the Excluded Words file is used to
7 ; selectively exclude words from the indexing process. If
8 ; LEXLOOK is set, then the Excluded Words file is used to
9 ; selectively exclude words from the look-up process. If
10 ; LEXIDX and LEXLOOK do not exist then all words are parsed
11 ; parsed.
12 ;
13PT ; Entry point where DA is defined and X is unknown
14 Q:'$D(DA) S X=^LEX(757.01,DA,0)
15PTX ; Entry point to parse string (X must exist)
16 N LEXOK,LEXTOKS,LEXTOKS2,LEXTOKI,LEXTOKW,LEXTOLKN
17 N LEXOKC,LEXOKN,LEXOKP
18 K ^TMP("LEXTKN",$J)
19 Q:'$L($G(X)) S LEXTOKS=$TR(X,"-"," ")
20 ; Remove leading blanks from string
21 F LEXOKP=1:1:$L(LEXTOKS) Q:$E(LEXTOKS,LEXOKP)'[" "
22 S LEXTOKS=$E(LEXTOKS,LEXOKP,$L(LEXTOKS))
23 ; Remove trailing blanks from string
24 F LEXOKP=$L(LEXTOKS):-1:1 Q:$E(LEXTOKS,LEXOKP)'[" "
25 S LEXTOKS=$E(LEXTOKS,1,LEXOKP)
26 ; Remove Punctuation (less slashes)
27 S LEXTOKS=$TR(LEXTOKS,"?`~!@#$%^&*()_-+={}[]\:;,<>"," ")
28 ; Conditionally remove slashes
29 S:$D(LEXIDX) LEXTOKS=$TR(LEXTOKS,"/"," ")
30 S LEXTOKS=$TR(LEXTOKS,".","")
31 S LEXTOKS=$TR(LEXTOKS,"""","")
32 ; Swtich to UPPERCASE (lower case is not specified by LEXLOW)
33 S:'$D(LEXLOW) LEXTOKS=$$UP^XLFSTR(LEXTOKS)
34 ; Store in temporary array (based on space character)
35 S LEXOKC=0 F LEXTOKI=1:1:$L(LEXTOKS," ") D
36 . N LEXTOKW S LEXTOKW=$P(LEXTOKS," ",LEXTOKI) Q:LEXTOKW=""
37 . I LEXTOKW'["/" D
38 . . S LEXOKC=LEXOKC+1,LEXTOLKN(LEXOKC)=LEXTOKW
39 . . S LEXTOLKN(0)=LEXOKC
40 . I LEXTOKW["/"&('$D(^LEX(757.05,"B",LEXTOKW))) D Q ; PCH 4
41 . . N LEXP S LEXP=0 F S LEXP=LEXP+1 Q:$P(LEXTOKW,"/",LEXP)="" D
42 . . . S LEXOKC=LEXOKC+1,LEXTOLKN(LEXOKC)=$P(LEXTOKW,"/",LEXP)
43 . . . S LEXTOLKN(0)=LEXOKC
44 . I LEXTOKW["/"&($D(^LEX(757.05,"B",LEXTOKW))) D
45 . . N LEXOKR S LEXOKR=$O(^LEX(757.05,"B",LEXTOKW,0))
46 . . I $P($G(^LEX(757.05,LEXOKR,0)),U,3)="R" D
47 . . . S LEXOKC=LEXOKC+1,LEXTOLKN(LEXOKC)=LEXTOKW
48 . . . S LEXTOLKN(0)=LEXOKC
49 K LEXOKC,LEXOKR
50 I +($G(LEXTOLKN(0)))=0 K LEXTOLKN S ^TMP("LEXTKN",$J,0)=0 G EXIT
51 S LEXTOKW="",LEXOKN=0 F LEXTOKI=1:1:LEXTOLKN(0) D
52 . S LEXTOKW=$G(LEXTOLKN(LEXTOKI))
53 . ; Remove leading blanks
54 . F LEXOKP=1:1:$L(LEXTOKW) Q:$E(LEXTOKW,LEXOKP)'[" "
55 . S LEXTOKW=$E(LEXTOKW,LEXOKP,$L(LEXTOKW))
56 . ; Remove trailing blanks
57 . F LEXOKP=$L(LEXTOKW):-1:1 Q:$E(LEXTOKW,LEXOKP)'[" "
58 . S LEXTOKW=$E(LEXTOKW,1,LEXOKP)
59 . ; Leading numerics or Zero
60 . ;I +LEXTOKW>0 S LEXTOKW="" Q
61 . I $A($E(LEXTOKW,1))=48 S LEXTOKW="" Q
62 . ; Apostrophies and spaces
63 . S LEXTOKW=$TR(LEXTOKW,"'",""),LEXTOKW=$TR(LEXTOKW," ","")
64 . ; Numeric only
65 . ;S LEXOK=0 F LEXOKP=1:1:$L(LEXTOKW) S:$E(LEXTOKW,LEXOKP)?1U LEXOK=1 Q:LEXOK=1
66 . ;I 'LEXOK S LEXTOKW="" Q
67 . I $D(LEXIDX) D
68 . . I LEXTOKW'="" S:$D(^LEX(757.04,"ACTION",LEXTOKW,"I")) LEXTOKW=""
69 . . I LEXTOKW'="" S:$D(^LEX(757.04,"ACTION",LEXTOKW,"B")) LEXTOKW=""
70 . I $D(LEXLOOK) D
71 . . I LEXTOKW'="" S:$D(^LEX(757.04,"ACTION",LEXTOKW,"L")) LEXTOKW=""
72 . . I LEXTOKW'="" S:$D(^LEX(757.04,"ACTION",LEXTOKW,"B")) LEXTOKW=""
73 . I $D(LEXOKN),$D(LEXTOKW),LEXTOKW'="" D
74 . . S LEXOKN=+(LEXOKN)+1,^TMP("LEXTKN",$J,LEXOKN,LEXTOKW)=""
75 . S LEXTOKW=""
76 S ^TMP("LEXTKN",$J,0)=LEXOKN
77EXIT ; Clean up and quit
78 K LEXOK,LEXTOKI,LEXOKN,LEXOKP,LEXOKR,LEXTOKS,LEXTOKS2,LEXTOKW,LEXTOLKN
79 Q
Note: See TracBrowser for help on using the repository browser.