source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAS5.m@ 1261

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

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1LEXAS5 ; ISL Look-up Check Input (SPLIT) ; 09-23-96
2 ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
3 ;
4 ;
5SPLIT(LEXX) ; 2 tolkens/no space
6 ;
7 ; LEXI Incremental counter
8 ; LEXOK Flag - tolken found
9 ; LEXF First segment
10 ; LEXFR Remainder of First segment
11 ; LEXTT 2 Tolkens
12 ; LEXP1 First piece
13 ; LEXP2 Second piect
14 ; LEXX Value returned
15 ;
16 Q:$D(^LEX(757.01,"ASL",LEXX)) LEXX
17 Q:$L(LEXX)<6 LEXX
18 N LEXF,LEXFR,LEXTT,LEXP1,LEXP2
19 ;
20 S LEXF=$$FS(LEXX)
21 S LEXFR="" S:$L($G(LEXF)) LEXFR=$$FR(LEXX,.LEXF)
22 S (LEXTT,LEXP1,LEXP2)=""
23 S LEXP1=LEXF
24 ;S:$L(LEXF)>2 LEXP1=$$REP(LEXF)
25 G:LEXP1="" END
26 S:$L(LEXFR)>3 LEXP2=LEXFR
27 G:LEXP2="" END
28 S LEXTT=LEXP1_"^"_LEXP2
29END ; Resolve first to a string, second to a tolken
30 K LEXKEY Q:$G(LEXTT)'["^" LEXX
31 S:$L(LEXTT) LEXX=LEXTT Q LEXX
32FS(LEXX) ; First segment
33 N LEXN,LEXE,LEXF,LEXT,LEXI,LEXOK S LEXN=$$TRIM^LEXAS6(LEXX),LEXOK=0
34 Q:'$L(LEXN) LEXX
35 F LEXI=2:1:$L(LEXN) D Q:LEXOK
36 . S LEXF=$E(LEXX,1,LEXI) I $L(LEXF)>2,$D(^LEX(757.01,"ASL",LEXF)) S LEXX=LEXF,LEXOK=1 Q
37 . N LEXFI F LEXFI="757.04","757.041","757.05" D
38 . . Q:'$L(LEXF) Q:'$L($P(LEXX,LEXF,2))
39 . . I $D(^LEX(LEXFI,"B",LEXF)) D
40 . . . I $D(^LEX(757.01,"AWRD",$P(LEXX,LEXF,2))) S LEXX=LEXF,LEXOK=1 Q
41 Q LEXX
42REP(LEXX) ; Replacement
43 N LEXR Q:'$D(^LEX(757.05,"B",LEXX)) LEXX
44 S LEXR=$O(^LEX(757.05,"B",LEXX,0)) Q:'$D(^LEX(757.05,LEXR,0)) LEXX
45 I $P(^LEX(757.05,LEXR,0),"^",3)="R" S LEXX=$P(^LEX(757.05,LEXR,0),"^",2)
46 Q LEXX
47FR(LEXX,LEXF) ; Remainder of first segment
48 N LEXFR,LEXN,LEXOK S LEXFR=$P(LEXX,LEXF,2)
49 I $L(LEXFR),'$D(^LEX(757.01,"AWRD",LEXFR)) D
50 . N LEXI,LEXT S LEXT=LEXFR,LEXOK=0 F LEXI=1:1:$L(LEXFR) D Q:LEXOK
51 . . S LEXT=$E(LEXFR,LEXI,$L(LEXFR))
52 . . I $D(^LEX(757.01,"AWRD",LEXT)) D
53 . . . S LEXFR=LEXT,LEXOK=1
54 . . . I $P(LEXX,LEXFR,1)'="",$D(^LEX(757.01,"ASL",$P(LEXX,LEXFR,1))) S LEXF=$P(LEXX,LEXFR,1)
55 I $L(LEXFR),'$D(^LEX(757.01,"AWRD",LEXFR)) S LEXFR=$$COMP(LEXF,LEXFR)
56 Q:'$L(LEXFR) ""
57 I '$D(^LEX(757.01,"AWRD",LEXFR)),$L(LEXFR)>4 D
58 . S LEXN=$E(LEXFR,1,4)
59 . I $L(LEXN),$D(^LEX(757.01,"AWRD",LEXN)) S LEXFR=LEXN
60 I $L(LEXFR),$D(^LEX(757.01,"AWRD",LEXFR)) S LEXX=LEXFR Q LEXX
61 I $L(LEXFR),'$D(^LEX(757.01,"AWRD",LEXFR)) S LEXX="" Q LEXX
62 I '$L(LEXFR) S LEXX=""
63 Q LEXX
64COMP(LEXF,LEXS) ; Compare first segment to second segment
65 N LEXN,LEXT,LEXO S LEXO=LEXS
66 S LEXN=$$TP^LEXAS6(LEXO)
67 I $D(^LEX(757.01,"AWRD",LEXN)),+($$CHK(LEXF,LEXN)) S LEXS=LEXN Q LEXS
68 S LEXT=$$SHIFT^LEXAS3(LEXO)
69 I $D(^LEX(757.01,"AWRD",LEXT)),+($$CHK(LEXF,LEXT)) S LEXS=LEXT Q LEXS
70 S LEXN=$$TP^LEXAS6(LEXN)
71 I $D(^LEX(757.01,"AWRD",LEXN)),+($$CHK(LEXF,LEXN)) S LEXS=LEXN Q LEXS
72 S LEXN=$$ONE^LEXAS2(LEXN)
73 I $L(LEXN)>3,$D(^LEX(757.01,"AWRD",LEXN)),+($$CHK(LEXF,LEXN)) S LEXS=LEXN Q LEXS
74 Q ""
75CHK(LEX1,LEX2) ; Check first segment used with second segment
76 I '$L($G(LEX1))!('$L($G(LEX1))) Q 0
77 I '$D(^LEX(757.01,"ASL",LEX1))!('$D(^LEX(757.01,"ASL",LEX2))) Q 0
78 N LEXF1,LEXF2,LEXO,LEXC,LEXS,LEXOK S LEXOK=0
79 S LEXF1=$O(^LEX(757.01,"ASL",LEX1,0))
80 S LEXF2=$O(^LEX(757.01,"ASL",LEX2,0))
81 S:LEXF1<LEXF2 LEXO=$$SCH^LEXAS6(LEX1),LEXC=LEX2,LEXS=LEX1
82 S:LEXF1'<LEXF2 LEXO=$$SCH^LEXAS6(LEX2),LEXC=LEX1,LEXS=LEX2
83 F S LEXO=$O(^LEX(757.01,"AWRD",LEXO)) Q:LEXO=""!(LEXO'[LEXS)!(LEXOK) D
84 . N LEXR S LEXR=0
85 . F S LEXR=$O(^LEX(757.01,"AWRD",LEXO,LEXR)) Q:+LEXR=0!(LEXOK) D
86 . . N LEXE S LEXE=$$UP^XLFSTR($G(^LEX(757.01,LEXR,0)))
87 . . I LEXE[(" "_$$UP^XLFSTR(LEXC)) S LEXOK=1 Q
88 . . I $E(LEXE,1,$L(LEXC))=$$UP^XLFSTR(LEXC) S LEXOK=1
89 S LEX1=LEXOK
90 Q LEX1
Note: See TracBrowser for help on using the repository browser.