source: FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAS5.m@ 1800

LEXAS5 ; ISL Look-up Check Input (SPLIT)          ; 09-23-96
 ;;2.0;LEXICON UTILITY;;Sep 23, 1996
 ;
 ;
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