- LEXAS5 ;ISL/KER - Look-up Check Input (SPLIT) ;04/21/2014
- ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
- ;
- ; Global Variables
- ; ^LEX( N/A
- ;
- ; External References
- ; $$UP^XLFSTR ICR 10103
- ;
- 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
- LEXAS5 ;ISL/KER - Look-up Check Input (SPLIT) ;04/21/2014
- +1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
- +2 ;
- +3 ; Global Variables
- +4 ; ^LEX( N/A
- +5 ;
- +6 ; External References
- +7 ; $$UP^XLFSTR ICR 10103
- +8 ;
- SPLIT(LEXX) ; 2 tolkens/no space
- +1 ;
- +2 ; LEXI Incremental counter
- +3 ; LEXOK Flag - tolken found
- +4 ; LEXF First segment
- +5 ; LEXFR Remainder of First segment
- +6 ; LEXTT 2 Tolkens
- +7 ; LEXP1 First piece
- +8 ; LEXP2 Second piect
- +9 ; LEXX Value returned
- +10 ;
- +11 IF $DATA(^LEX(757.01,"ASL",LEXX))
- QUIT LEXX
- +12 IF $LENGTH(LEXX)<6
- QUIT LEXX
- +13 NEW LEXF,LEXFR,LEXTT,LEXP1,LEXP2
- +14 ;
- +15 SET LEXF=$$FS(LEXX)
- +16 SET LEXFR=""
- IF $LENGTH($GET(LEXF))
- SET LEXFR=$$FR(LEXX,.LEXF)
- +17 SET (LEXTT,LEXP1,LEXP2)=""
- +18 SET LEXP1=LEXF
- +19 ;S:$L(LEXF)>2 LEXP1=$$REP(LEXF)
- +20 IF LEXP1=""
- GOTO END
- +21 IF $LENGTH(LEXFR)>3
- SET LEXP2=LEXFR
- +22 IF LEXP2=""
- GOTO END
- +23 SET LEXTT=LEXP1_"^"_LEXP2
- END ; Resolve first to a string, second to a tolken
- +1 KILL LEXKEY
- IF $GET(LEXTT)'["^"
- QUIT LEXX
- +2 IF $LENGTH(LEXTT)
- SET LEXX=LEXTT
- QUIT LEXX
- FS(LEXX) ; First segment
- +1 NEW LEXN,LEXE,LEXF,LEXT,LEXI,LEXOK
- SET LEXN=$$TRIM^LEXAS6(LEXX)
- SET LEXOK=0
- +2 IF '$LENGTH(LEXN)
- QUIT LEXX
- +3 FOR LEXI=2:1:$LENGTH(LEXN)
- Begin DoDot:1
- +4 SET LEXF=$EXTRACT(LEXX,1,LEXI)
- IF $LENGTH(LEXF)>2
- IF $DATA(^LEX(757.01,"ASL",LEXF))
- SET LEXX=LEXF
- SET LEXOK=1
- QUIT
- +5 NEW LEXFI
- FOR LEXFI="757.04","757.041","757.05"
- Begin DoDot:2
- +6 IF '$LENGTH(LEXF)
- QUIT
- IF '$LENGTH($PIECE(LEXX,LEXF,2))
- QUIT
- +7 IF $DATA(^LEX(LEXFI,"B",LEXF))
- Begin DoDot:3
- +8 IF $DATA(^LEX(757.01,"AWRD",$PIECE(LEXX,LEXF,2)))
- SET LEXX=LEXF
- SET LEXOK=1
- QUIT
- End DoDot:3
- End DoDot:2
- End DoDot:1
- IF LEXOK
- QUIT
- +9 QUIT LEXX
- REP(LEXX) ; Replacement
- +1 NEW LEXR
- IF '$DATA(^LEX(757.05,"B",LEXX))
- QUIT LEXX
- +2 SET LEXR=$ORDER(^LEX(757.05,"B",LEXX,0))
- IF '$DATA(^LEX(757.05,LEXR,0))
- QUIT LEXX
- +3 IF $PIECE(^LEX(757.05,LEXR,0),"^",3)="R"
- SET LEXX=$PIECE(^LEX(757.05,LEXR,0),"^",2)
- +4 QUIT LEXX
- FR(LEXX,LEXF) ; Remainder of first segment
- +1 NEW LEXFR,LEXN,LEXOK
- SET LEXFR=$PIECE(LEXX,LEXF,2)
- +2 IF $LENGTH(LEXFR)
- IF '$DATA(^LEX(757.01,"AWRD",LEXFR))
- Begin DoDot:1
- +3 NEW LEXI,LEXT
- SET LEXT=LEXFR
- SET LEXOK=0
- FOR LEXI=1:1:$LENGTH(LEXFR)
- Begin DoDot:2
- +4 SET LEXT=$EXTRACT(LEXFR,LEXI,$LENGTH(LEXFR))
- +5 IF $DATA(^LEX(757.01,"AWRD",LEXT))
- Begin DoDot:3
- +6 SET LEXFR=LEXT
- SET LEXOK=1
- +7 IF $PIECE(LEXX,LEXFR,1)'=""
- IF $DATA(^LEX(757.01,"ASL",$PIECE(LEXX,LEXFR,1)))
- SET LEXF=$PIECE(LEXX,LEXFR,1)
- End DoDot:3
- End DoDot:2
- IF LEXOK
- QUIT
- End DoDot:1
- +8 IF $LENGTH(LEXFR)
- IF '$DATA(^LEX(757.01,"AWRD",LEXFR))
- SET LEXFR=$$COMP(LEXF,LEXFR)
- +9 IF '$LENGTH(LEXFR)
- QUIT ""
- +10 IF '$DATA(^LEX(757.01,"AWRD",LEXFR))
- IF $LENGTH(LEXFR)>4
- Begin DoDot:1
- +11 SET LEXN=$EXTRACT(LEXFR,1,4)
- +12 IF $LENGTH(LEXN)
- IF $DATA(^LEX(757.01,"AWRD",LEXN))
- SET LEXFR=LEXN
- End DoDot:1
- +13 IF $LENGTH(LEXFR)
- IF $DATA(^LEX(757.01,"AWRD",LEXFR))
- SET LEXX=LEXFR
- QUIT LEXX
- +14 IF $LENGTH(LEXFR)
- IF '$DATA(^LEX(757.01,"AWRD",LEXFR))
- SET LEXX=""
- QUIT LEXX
- +15 IF '$LENGTH(LEXFR)
- SET LEXX=""
- +16 QUIT LEXX
- COMP(LEXF,LEXS) ; Compare first segment to second segment
- +1 NEW LEXN,LEXT,LEXO
- SET LEXO=LEXS
- +2 SET LEXN=$$TP^LEXAS6(LEXO)
- +3 IF $DATA(^LEX(757.01,"AWRD",LEXN))
- IF +($$CHK(LEXF,LEXN))
- SET LEXS=LEXN
- QUIT LEXS
- +4 SET LEXT=$$SHIFT^LEXAS3(LEXO)
- +5 IF $DATA(^LEX(757.01,"AWRD",LEXT))
- IF +($$CHK(LEXF,LEXT))
- SET LEXS=LEXT
- QUIT LEXS
- +6 SET LEXN=$$TP^LEXAS6(LEXN)
- +7 IF $DATA(^LEX(757.01,"AWRD",LEXN))
- IF +($$CHK(LEXF,LEXN))
- SET LEXS=LEXN
- QUIT LEXS
- +8 SET LEXN=$$ONE^LEXAS2(LEXN)
- +9 IF $LENGTH(LEXN)>3
- IF $DATA(^LEX(757.01,"AWRD",LEXN))
- IF +($$CHK(LEXF,LEXN))
- SET LEXS=LEXN
- QUIT LEXS
- +10 QUIT ""
- CHK(LEX1,LEX2) ; Check first segment used with second segment
- +1 IF '$LENGTH($GET(LEX1))!('$LENGTH($GET(LEX1)))
- QUIT 0
- +2 IF '$DATA(^LEX(757.01,"ASL",LEX1))!('$DATA(^LEX(757.01,"ASL",LEX2)))
- QUIT 0
- +3 NEW LEXF1,LEXF2,LEXO,LEXC,LEXS,LEXOK
- SET LEXOK=0
- +4 SET LEXF1=$ORDER(^LEX(757.01,"ASL",LEX1,0))
- +5 SET LEXF2=$ORDER(^LEX(757.01,"ASL",LEX2,0))
- +6 IF LEXF1<LEXF2
- SET LEXO=$$SCH^LEXAS6(LEX1)
- SET LEXC=LEX2
- SET LEXS=LEX1
- +7 IF LEXF1'<LEXF2
- SET LEXO=$$SCH^LEXAS6(LEX2)
- SET LEXC=LEX1
- SET LEXS=LEX2
- +8 FOR
- SET LEXO=$ORDER(^LEX(757.01,"AWRD",LEXO))
- IF LEXO=""!(LEXO'[LEXS)!(LEXOK)
- QUIT
- Begin DoDot:1
- +9 NEW LEXR
- SET LEXR=0
- +10 FOR
- SET LEXR=$ORDER(^LEX(757.01,"AWRD",LEXO,LEXR))
- IF +LEXR=0!(LEXOK)
- QUIT
- Begin DoDot:2
- +11 NEW LEXE
- SET LEXE=$$UP^XLFSTR($GET(^LEX(757.01,LEXR,0)))
- +12 IF LEXE[(" "_$$UP^XLFSTR(LEXC))
- SET LEXOK=1
- QUIT
- +13 IF $EXTRACT(LEXE,1,$LENGTH(LEXC))=$$UP^XLFSTR(LEXC)
- SET LEXOK=1
- End DoDot:2
- End DoDot:1
- +14 SET LEX1=LEXOK
- +15 QUIT LEX1
