LEXAMD2.m

LEXAMD2 ;ISL/KER - Look-up Check Modifiers ;04/21/2014

 ;;2.0;LEXICON UTILITY;**6,80**;Sep 23, 1996;Build 10

 Q

CHKMOD ; Check Modifiers

 S LEXE=+($G(LEXE)) Q:'$D(^LEX(757.01,LEXE,0))

 N LEXC,LEXMDOK,LEXM,LEXI S (LEXI,LEXC)=0

 F  S LEXC=$O(^LEX(757.01,"APAR",LEXE,LEXC)) Q:+LEXC=0  D

 . S LEXMDOK=1 D CHKTKNS(LEXC) Q:'LEXMDOK

 . S LEXI=LEXI+1,LEXM(0)=LEXI,LEXM(LEXI)=LEXC

 I +($G(LEXM(0)))=1 D

 . Q:+($G(LEXM(1)))=0  Q:'$L($G(^LEX(757.01,+($G(LEXM(1))),0)))

 . S LEXE=+($G(LEXM(1))),LEXOK=1

 Q

CHKTKNS(LEXE) ; Check tolkens

 N LEXM S LEXM=+($G(^LEX(757.01,LEXE,1))) Q:LEXM=0

 N LEXI,LEXOE,LEXC,LEXD S LEXOE=LEXE,LEXI=1

 F  S LEXI=$O(LEXTKN(LEXI)) Q:+LEXI=0!('LEXMDOK)  D  Q:'LEXMDOK

 . N LEXT,LEXE S LEXT=LEXTKN(LEXI),LEXE=0,LEXMDOK=0

 . S LEXC=$$UP(^LEX(757.01,LEXOE,0))

 . S LEXD=$$UP(^LEX(757.01,LEXOE,2))

 . I LEXD[LEXT S LEXMDOK=1 Q

 . I LEXC[LEXT S LEXMDOK=1 Q

 . I $L(LEXT),$D(^LEX(757.01,LEXOE,5,"B",LEXT)) S LEXMDOK=1 Q

 . I $L(LEXT),$E($O(^LEX(757.01,LEXOE,5,"B",($E(LEXT,1,($L(LEXT)-1))_$C($A($E(LEXT,$L(LEXT)))-1)_"~"))),1,$L(LEXT))=LEXT S LEXMDOK=1 Q

 Q

UP(X) Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")

LEXAMD2   ;ISL/KER - Look-up Check Modifiers ;04/21/2014

 +1       ;;2.0;LEXICON UTILITY;**6,80**;Sep 23, 1996;Build 10

 +2        QUIT 

CHKMOD    ; Check Modifiers

 +1        SET LEXE=+($GET(LEXE))

           IF '$DATA(^LEX(757.01,LEXE,0))

               QUIT 

 +2        NEW LEXC,LEXMDOK,LEXM,LEXI

           SET (LEXI,LEXC)=0

 +3        FOR 

               SET LEXC=$ORDER(^LEX(757.01,"APAR",LEXE,LEXC))

               IF +LEXC=0

                   QUIT 

               Begin DoDot:1

 +4                SET LEXMDOK=1

                   DO CHKTKNS(LEXC)

                   IF 'LEXMDOK

                       QUIT 

 +5                SET LEXI=LEXI+1

                   SET LEXM(0)=LEXI

                   SET LEXM(LEXI)=LEXC

               End DoDot:1

 +6        IF +($GET(LEXM(0)))=1

               Begin DoDot:1

 +7                IF +($GET(LEXM(1)))=0

                       QUIT 

                   IF '$LENGTH($GET(^LEX(757.01,+($GET(LEXM(1))),0)))

                       QUIT 

 +8                SET LEXE=+($GET(LEXM(1)))

                   SET LEXOK=1

               End DoDot:1

 +9        QUIT 

CHKTKNS(LEXE) ; Check tolkens

 +1        NEW LEXM

           SET LEXM=+($GET(^LEX(757.01,LEXE,1)))

           IF LEXM=0

               QUIT 

 +2        NEW LEXI,LEXOE,LEXC,LEXD

           SET LEXOE=LEXE

           SET LEXI=1

 +3        FOR 

               SET LEXI=$ORDER(LEXTKN(LEXI))

               IF +LEXI=0!('LEXMDOK)

                   QUIT 

               Begin DoDot:1

 +4                NEW LEXT,LEXE

                   SET LEXT=LEXTKN(LEXI)

                   SET LEXE=0

                   SET LEXMDOK=0

 +5                SET LEXC=$$UP(^LEX(757.01,LEXOE,0))

 +6                SET LEXD=$$UP(^LEX(757.01,LEXOE,2))

 +7                IF LEXD[LEXT

                       SET LEXMDOK=1

                       QUIT 

 +8                IF LEXC[LEXT

                       SET LEXMDOK=1

                       QUIT 

 +9                IF $LENGTH(LEXT)

                       IF $DATA(^LEX(757.01,LEXOE,5,"B",LEXT))

                           SET LEXMDOK=1

                           QUIT 

 +10               IF $LENGTH(LEXT)

                       IF $EXTRACT($ORDER(^LEX(757.01,LEXOE,5,"B",($EXTRACT(LEXT,1,($LENGTH(LEXT)-1))_$CHAR($ASCII($EXTRACT(LEXT,$LENGTH(LEXT)))-1)_"~"))),1,$LENGTH(LEXT))=LEXT

                           SET LEXMDOK=1

                           QUIT 

               End DoDot:1

               IF 'LEXMDOK

                   QUIT 

 +11       QUIT 

UP(X)      QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")