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
