91 lines
3.4 KiB
Mathematica
91 lines
3.4 KiB
Mathematica
LEXAS5 ; ISL Look-up Check Input (SPLIT) ; 09-23-96
|
|
;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
|
|
;
|
|
;
|
|
SPLIT(LEXX) ; 2 tolkens/no space
|
|
;
|
|
; LEXI Incremental counter
|
|
; LEXOK Flag - tolken found
|
|
; LEXF First segment
|
|
; LEXFR Remainder of First segment
|
|
; LEXTT 2 Tolkens
|
|
; LEXP1 First piece
|
|
; LEXP2 Second piect
|
|
; LEXX Value returned
|
|
;
|
|
Q:$D(^LEX(757.01,"ASL",LEXX)) LEXX
|
|
Q:$L(LEXX)<6 LEXX
|
|
N LEXF,LEXFR,LEXTT,LEXP1,LEXP2
|
|
;
|
|
S LEXF=$$FS(LEXX)
|
|
S LEXFR="" S:$L($G(LEXF)) LEXFR=$$FR(LEXX,.LEXF)
|
|
S (LEXTT,LEXP1,LEXP2)=""
|
|
S LEXP1=LEXF
|
|
;S:$L(LEXF)>2 LEXP1=$$REP(LEXF)
|
|
G:LEXP1="" END
|
|
S:$L(LEXFR)>3 LEXP2=LEXFR
|
|
G:LEXP2="" END
|
|
S LEXTT=LEXP1_"^"_LEXP2
|
|
END ; Resolve first to a string, second to a tolken
|
|
K LEXKEY Q:$G(LEXTT)'["^" LEXX
|
|
S:$L(LEXTT) LEXX=LEXTT Q LEXX
|
|
FS(LEXX) ; First segment
|
|
N LEXN,LEXE,LEXF,LEXT,LEXI,LEXOK S LEXN=$$TRIM^LEXAS6(LEXX),LEXOK=0
|
|
Q:'$L(LEXN) LEXX
|
|
F LEXI=2:1:$L(LEXN) D Q:LEXOK
|
|
. S LEXF=$E(LEXX,1,LEXI) I $L(LEXF)>2,$D(^LEX(757.01,"ASL",LEXF)) S LEXX=LEXF,LEXOK=1 Q
|
|
. N LEXFI F LEXFI="757.04","757.041","757.05" D
|
|
. . Q:'$L(LEXF) Q:'$L($P(LEXX,LEXF,2))
|
|
. . I $D(^LEX(LEXFI,"B",LEXF)) D
|
|
. . . I $D(^LEX(757.01,"AWRD",$P(LEXX,LEXF,2))) S LEXX=LEXF,LEXOK=1 Q
|
|
Q LEXX
|
|
REP(LEXX) ; Replacement
|
|
N LEXR Q:'$D(^LEX(757.05,"B",LEXX)) LEXX
|
|
S LEXR=$O(^LEX(757.05,"B",LEXX,0)) Q:'$D(^LEX(757.05,LEXR,0)) LEXX
|
|
I $P(^LEX(757.05,LEXR,0),"^",3)="R" S LEXX=$P(^LEX(757.05,LEXR,0),"^",2)
|
|
Q LEXX
|
|
FR(LEXX,LEXF) ; Remainder of first segment
|
|
N LEXFR,LEXN,LEXOK S LEXFR=$P(LEXX,LEXF,2)
|
|
I $L(LEXFR),'$D(^LEX(757.01,"AWRD",LEXFR)) D
|
|
. N LEXI,LEXT S LEXT=LEXFR,LEXOK=0 F LEXI=1:1:$L(LEXFR) D Q:LEXOK
|
|
. . S LEXT=$E(LEXFR,LEXI,$L(LEXFR))
|
|
. . I $D(^LEX(757.01,"AWRD",LEXT)) D
|
|
. . . S LEXFR=LEXT,LEXOK=1
|
|
. . . I $P(LEXX,LEXFR,1)'="",$D(^LEX(757.01,"ASL",$P(LEXX,LEXFR,1))) S LEXF=$P(LEXX,LEXFR,1)
|
|
I $L(LEXFR),'$D(^LEX(757.01,"AWRD",LEXFR)) S LEXFR=$$COMP(LEXF,LEXFR)
|
|
Q:'$L(LEXFR) ""
|
|
I '$D(^LEX(757.01,"AWRD",LEXFR)),$L(LEXFR)>4 D
|
|
. S LEXN=$E(LEXFR,1,4)
|
|
. I $L(LEXN),$D(^LEX(757.01,"AWRD",LEXN)) S LEXFR=LEXN
|
|
I $L(LEXFR),$D(^LEX(757.01,"AWRD",LEXFR)) S LEXX=LEXFR Q LEXX
|
|
I $L(LEXFR),'$D(^LEX(757.01,"AWRD",LEXFR)) S LEXX="" Q LEXX
|
|
I '$L(LEXFR) S LEXX=""
|
|
Q LEXX
|
|
COMP(LEXF,LEXS) ; Compare first segment to second segment
|
|
N LEXN,LEXT,LEXO S LEXO=LEXS
|
|
S LEXN=$$TP^LEXAS6(LEXO)
|
|
I $D(^LEX(757.01,"AWRD",LEXN)),+($$CHK(LEXF,LEXN)) S LEXS=LEXN Q LEXS
|
|
S LEXT=$$SHIFT^LEXAS3(LEXO)
|
|
I $D(^LEX(757.01,"AWRD",LEXT)),+($$CHK(LEXF,LEXT)) S LEXS=LEXT Q LEXS
|
|
S LEXN=$$TP^LEXAS6(LEXN)
|
|
I $D(^LEX(757.01,"AWRD",LEXN)),+($$CHK(LEXF,LEXN)) S LEXS=LEXN Q LEXS
|
|
S LEXN=$$ONE^LEXAS2(LEXN)
|
|
I $L(LEXN)>3,$D(^LEX(757.01,"AWRD",LEXN)),+($$CHK(LEXF,LEXN)) S LEXS=LEXN Q LEXS
|
|
Q ""
|
|
CHK(LEX1,LEX2) ; Check first segment used with second segment
|
|
I '$L($G(LEX1))!('$L($G(LEX1))) Q 0
|
|
I '$D(^LEX(757.01,"ASL",LEX1))!('$D(^LEX(757.01,"ASL",LEX2))) Q 0
|
|
N LEXF1,LEXF2,LEXO,LEXC,LEXS,LEXOK S LEXOK=0
|
|
S LEXF1=$O(^LEX(757.01,"ASL",LEX1,0))
|
|
S LEXF2=$O(^LEX(757.01,"ASL",LEX2,0))
|
|
S:LEXF1<LEXF2 LEXO=$$SCH^LEXAS6(LEX1),LEXC=LEX2,LEXS=LEX1
|
|
S:LEXF1'<LEXF2 LEXO=$$SCH^LEXAS6(LEX2),LEXC=LEX1,LEXS=LEX2
|
|
F S LEXO=$O(^LEX(757.01,"AWRD",LEXO)) Q:LEXO=""!(LEXO'[LEXS)!(LEXOK) D
|
|
. N LEXR S LEXR=0
|
|
. F S LEXR=$O(^LEX(757.01,"AWRD",LEXO,LEXR)) Q:+LEXR=0!(LEXOK) D
|
|
. . N LEXE S LEXE=$$UP^XLFSTR($G(^LEX(757.01,LEXR,0)))
|
|
. . I LEXE[(" "_$$UP^XLFSTR(LEXC)) S LEXOK=1 Q
|
|
. . I $E(LEXE,1,$L(LEXC))=$$UP^XLFSTR(LEXC) S LEXOK=1
|
|
S LEX1=LEXOK
|
|
Q LEX1
|