LEX10CX4.m

LEX10CX4 ;ISL/KER - ICD-10 Cross-Over - Ask ;04/21/2014

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

 ;               

 ; Global Variables

 ;    ^UTILITY($J         ICR  10011

 ;               

 ; External References

 ;    ^DIC                ICR  10006

 ;    ^DIR                ICR  10026

 ;    ^DIWP               ICR  10011

 ;    $$UP^XLFSTR         ICR  10104

 ;               

 ; Local Variables NEWed or KILLed Elsewhere

 ;     LEX0FND,LEX0REV,LEX0SEL NEWed in LEX10CX

 ;               

ASK(LEXA,LEXB) ;   Ask for Selection

 N LEXSRCO,LEXSRTX,LEXSRNM,LEXANS,LEXFND,LEXI,LEXIND,LEXLEN,LEXT

 S Y=-1,LEXFND=+($G(LEXB(0))) Q:LEXFND'>0  S LEX0FND=1

 S LEXSRCO=$G(LEXA("SOURCE","SOE"))

 S LEXSRTX=$$UP^XLFSTR($G(LEXA("SOURCE","EXP")))

 S LEXSRNM=$G(LEXA("SOURCE","SRC"))

 W ! I $L($G(LEXSRTX)),$L($G(LEXSRCO)) D

 . W !," ",LEXSRNM," ",LEXSRCO

 . N LEXIND,LEXLEN,LEXT,LEXI S LEXIND=18,LEXT(1)=LEXSRTX

 . D PAR(.LEXT,50) W ?22," ",$G(LEXT(1))

 . S LEXI=1 F  S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0  D

 . . N LEXTX2 S LEXTX2=$$TM($G(LEXT(LEXI))) Q:'$L(LEXTX2)

 . . W !,?23,LEXTX2

 S:+LEXFND=1 LEXANS=$$ONE S:+LEXFND>1 LEXANS=$$MUL

 I LEXANS>0 D  S:+($G(X))'>0 X="" S:+($G(Y))'>0 Y=-1 Q

 . S X="",Y=-1 D X(.LEXA),Y(LEXANS,.LEXB)

 . Q:+($G(X))>0&(+($G(Y))>0)  S X="",Y=-1

 I LEXANS'>0 K X,Y,LEXB S X="",Y=-1

 Q

ONE(X) ;     One Entry Found - Needs LEXB

 N LEXIEN,LEXLN,LEXSO,LEXTEXT N DIR

 N LEXTXT,Y S LEXTEXT=$G(LEXB(1)),LEXIEN=+LEXTEXT

 S LEXSO=$P(LEXTEXT,U,2),LEXTEXT=$P(LEXTEXT,U,3)

 S LEXTXT(1)=LEXSO_"   "_LEXTEXT D PAR(.LEXTXT,64)

 S DIR("A",1)=" One ICD-10 suggestion found",DIR("A",2)=" "

 S DIR("A",3)="     "_$G(LEXTXT(1)),LEXLN=3

 I $L($G(LEXTXT(2))) S LEXLN=LEXLN+1 D

 . S DIR("A",LEXLN)="                     "_$G(LEXTXT(2))

 S LEXLN=LEXLN+1,DIR("A",LEXLN)=" ",LEXLN=LEXLN+1

 S DIR("A")="   OK?  ",DIR("B")="Yes",DIR(0)="YAO" W !

 D ^DIR S LEX0REV=1 S:+Y>0 LEX0SEL=1 Q:+Y>0 1

 Q:X["^^"!($D(DTOUT)) "^^" Q:X["^" "^"

 Q -1

MUL(X) ;     Multiple Entries Found - Needs LEXB

 N LEXENT,LEXIEN,LEXIT,LEXITEM,LEXLEN,LEXMAX,LEXMAT,LEXN,LEXSEL

 N LEXSO,LEXTEXT,LEXTOT,Y S LEXLEN=+($G(LEXN))

 S:+LEXLEN'>4 LEXLEN=5  N LEXN

 S (LEXMAX,LEXENT,LEXSEL,LEXIT)=0

 S U="^",LEXTOT=$G(LEXB(0))

 S LEXSEL=0 G:+LEXTOT=0 MULQ

 S LEXMAT=LEXTOT_" ICD-10 suggestion"_$S(+LEXTOT>1:"s",1:"")_" found"

 W:+LEXTOT>0 !!," ",LEXMAT

 F LEXENT=1:1:LEXTOT Q:LEXIT  D  Q:LEXIT

 . I ((LEXSEL>0)&(LEXSEL<LEXENT+1)) S LEXIT=1 Q

 . N LEXITEM,LEXIEN,LEXTEXT,LEXSO

 . S LEXITEM=$G(LEXB(LEXENT))

 . S LEXIEN=+LEXITEM,LEXSO=$P(LEXITEM,U,3)

 . S LEXTEXT=$P(LEXITEM,U,2) Q:+LEXIEN'>0

 . Q:'$L(LEXSO)  Q:'$L(LEXTEXT)

 . S LEXMAX=LEXENT W:LEXENT#LEXLEN=1 ! D MULW

 . S:LEXMAX=LEXTOT LEX0REV=1

 . W:LEXENT#LEXLEN=0 !

 . S:LEXENT#LEXLEN=0 LEXSEL=$$MULS(LEXMAX,LEXENT)

 . S:LEXSEL["^" LEXIT=1

 I LEXENT#LEXLEN'=0,+LEXSEL=0 D

 . W ! S LEXSEL=$$MULS(LEXMAX,LEXENT)

 . S:LEXSEL["^" LEXIT=1

 G MULQ

 Q X

MULW ;       Write Multiple - Needs LEXENT,LEXIEN,LEXSO,LEXTXT

 Q:+($G(LEXENT))'>0  Q:+($G(LEXIEN))'>0

 Q:'$L($G(LEXTEXT))  Q:'$L($G(LEXSO))

 N LEXI,LEXIND,LEXTAB,LEXTXT,LEXTX2

 S LEXTAB=8,LEXIND=18

 W !,$J(LEXENT,5),".",?LEXTAB,LEXSO

 S LEXTXT(1)=LEXTEXT D PAR(.LEXTXT,54)

 W ?LEXIND,$G(LEXTXT(1))

 S LEXI=1 F  S LEXI=$O(LEXTXT(LEXI)) Q:+LEXI'>0  D

 . N LEXTX2 S LEXTX2=$$TM($G(LEXTXT(LEXI))) Q:'$L(LEXTX2)

 . W !,?LEXIND,LEXTX2

 Q

MULS(X,Y) ;       Select Multiple - Needs LEXB, Uses LEXIT,LEXTOT

 N DIR,DIRB,LEXHLP,LEXLAST,LEXMAX

 N LEXNEXT,LEXRAN,LEXS,LEXENT,Y Q:+($G(LEXIT))>0 "^^"

 S LEXS=$G(X),LEXENT=$G(Y) N X

 S LEXMAX=+($G(LEXS)),LEXLAST=+($G(LEXENT))

 Q:LEXMAX=0 -1  S LEXRAN=" Select 1-"_LEXMAX_":  "

 S LEXNEXT=$O(LEXB(+LEXLAST)) I +LEXNEXT>0 D

 . S DIR("A")=" Press <RETURN> for more, "

 . S DIR("A")=DIR("A")_"'^' to exit, or"_LEXRAN

 S:+LEXNEXT'>0 DIR("A")=LEXRAN

 S LEXHLP="    Answer must be from 1 to "_LEXMAX

 S LEXHLP=LEXHLP_", or <Return> to continue"

 S DIR("PRE")="S:X[""?"" X=""??"""

 S (DIR("?"),DIR("??"))="^D MULSH^ICDEXLK2"

 S DIR(0)="NAO^1:"_LEXMAX_":0" D ^DIR

 S:X["^"&(LEXENT=+($G(LEXTOT))) (X,Y)="^^^"

 S:X["^^"!($D(DTOUT)) LEXIT=1,X="^^"

 I X["^^"!(+($G(LEXIT))>0) Q "^^"

 S LEXS=+Y S:$D(DTOUT)!(X[U) LEXS=U

 K DIR N LEXIT,LEXTOT

 S:+LEXS>0&($D(LEXB(+LEXS))) LEX0SEL=1

 Q LEXS

MULSH ;       Select Multiple Help

 I $L($G(LEXHLP)) W !,$G(LEXHLP) Q

 Q

MULQ ;       Quit Multiple

 Q:+LEXSEL'>0 -1  S X=+LEXSEL

 Q X

 ; 

 ; Miscellaneous

PAR(LEXC,LEXL) ;   Parse Array

 N %,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,LEXIEN,I,X,Z

 K ^UTILITY($J,"W") Q:'$D(LEXC)  S LEXL=+($G(LEXL))

 S:+LEXL'>0 LEXL=79 S DIWL=1,DIWF="C"_+LEXL S LEXIEN=0

 F  S LEXIEN=$O(LEXC(LEXIEN)) Q:+LEXIEN=0  D

 . S X=$G(LEXC(LEXIEN)) D ^DIWP

 K LEXC S LEXIEN=0

 F  S LEXIEN=$O(^UTILITY($J,"W",1,LEXIEN)) Q:+LEXIEN=0  D

 . S LEXC(LEXIEN)=$$TM($G(^UTILITY($J,"W",1,LEXIEN,0))," ")

 K ^UTILITY($J,"W")

 Q

TM(X,Y) ;   Trim Y

 S Y=$G(Y) S:'$L(Y) Y=" "

 F  Q:$E(X,1)'=Y  S X=$E(X,2,$L(X))

 F  Q:$E(X,$L(X))'=Y  S X=$E(X,1,($L(X)-1))

 Q X

X(LEXA) ;   Set X

 N LEXEXP,LEXCOD,LEXNOM,LEXIEN K X S X=""

 S LEXEXP=$G(LEXA("SOURCE","EXP")) Q:'$L(LEXEXP)

 S LEXCOD=$G(LEXA("SOURCE","SOE")) Q:'$L(LEXCOD)

 S LEXNOM=$G(LEXA("SOURCE","SRC")) Q:'$L(LEXNOM)

 S LEXIEN=+($G(LEXA("SOURCE","Y"))) Q:'$L(LEXIEN)

 Q:+LEXIEN'>0  S X=LEXIEN_"^"_LEXEXP_"^"_LEXCOD_"^"_LEXNOM

 Q

Y(LEX,LEXB) ;   Set Y

 N LEXEXP,LEXCOD,LEXNOM,LEXIEN,LEXDAT

 N LEXDAT,LEXEIEN,LEXEX,LEXICDD,LEXSO,LEXSTA,LEXTD

 K Y S Y=-1 S LEX=+($G(LEX)),LEXDAT=$G(LEXB(+LEX))

 S LEXEXP=$P(LEXDAT,"^",2) Q:'$L(LEXEXP)

 S LEXCOD=$P(LEXDAT,"^",3) Q:'$L(LEXCOD)

 S LEXNOM="ICD-10-CM"

 S LEXIEN=+($P(LEXDAT,"^",1)) Q:'$L(LEXIEN)

 Q:+LEXIEN'>0  S Y=LEXIEN_"^"_LEXEXP_"^"_LEXCOD_"^"_LEXNOM

 Q

SAB(X) ;   Select Coding System

 N DIC,DIROUT,DIRUT,DTOUT,DUOUT,LEXB,Y

 S DIC="^LEX(757.03,",DIC(0)="AEQM"

 S DIC("A")=" Select a Coding System:  "

 S LEXB=$P($G(^LEX(757.03,1,0)),"^",2) S:$L(LEXB) DIC("B")=LEXB

 S DIC("W")="N LEX1,LEX2 S LEX1=$P($G(^LEX(757.03,+Y,0)),U,2),"

 S DIC("W")=DIC("W")_"LEX2=$P($G(^LEX(757.03,+Y,0)),U,3) "

 S DIC("W")=DIC("W")_"S:$L(LEX2,"","")>2 LEX2=$P(LEX2,"","",1,"

 S DIC("W")=DIC("W")_"($L(LEX2,"","")-1)) W "" "",LEX1"

 S DIC("W")=DIC("W")_"_$J("" "",(12-$L(LEX1)))_""  ""_LEX2"

 S DIC("S")="I $E($P($G(^LEX(757.03,+Y,0)),""^"",1),1,3)'=""10D"""

 S DIC("W")="W ""   "",$P($G(^LEX(757.03,+Y,0)),U,2)"

 K X D ^DIC Q:X["^"!($D(DTOUT))!($D(DUOUT)) "^"

 S LEXB=$E($P($G(^LEX(757.03,+Y,0)),"^",1),1,3) Q:$L(LEXB)'=3 "^"

 Q:'$D(^LEX(757.03,"ASAB",LEXB)) "^"  S X=LEXB

 Q X

LEX10CX4  ;ISL/KER - ICD-10 Cross-Over - Ask ;04/21/2014

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

 +2       ;               

 +3       ; Global Variables

 +4       ;    ^UTILITY($J         ICR  10011

 +5       ;               

 +6       ; External References

 +7       ;    ^DIC                ICR  10006

 +8       ;    ^DIR                ICR  10026

 +9       ;    ^DIWP               ICR  10011

 +10      ;    $$UP^XLFSTR         ICR  10104

 +11      ;               

 +12      ; Local Variables NEWed or KILLed Elsewhere

 +13      ;     LEX0FND,LEX0REV,LEX0SEL NEWed in LEX10CX

 +14      ;               

ASK(LEXA,LEXB) ;   Ask for Selection

 +1        NEW LEXSRCO,LEXSRTX,LEXSRNM,LEXANS,LEXFND,LEXI,LEXIND,LEXLEN,LEXT

 +2        SET Y=-1

           SET LEXFND=+($GET(LEXB(0)))

           IF LEXFND'>0

               QUIT 

           SET LEX0FND=1

 +3        SET LEXSRCO=$GET(LEXA("SOURCE","SOE"))

 +4        SET LEXSRTX=$$UP^XLFSTR($GET(LEXA("SOURCE","EXP")))

 +5        SET LEXSRNM=$GET(LEXA("SOURCE","SRC"))

 +6        WRITE !

           IF $LENGTH($GET(LEXSRTX))

               IF $LENGTH($GET(LEXSRCO))

                   Begin DoDot:1

 +7                    WRITE !," ",LEXSRNM," ",LEXSRCO

 +8                    NEW LEXIND,LEXLEN,LEXT,LEXI

                       SET LEXIND=18

                       SET LEXT(1)=LEXSRTX

 +9                    DO PAR(.LEXT,50)

                       WRITE ?22," ",$GET(LEXT(1))

 +10                   SET LEXI=1

                       FOR 

                           SET LEXI=$ORDER(LEXT(LEXI))

                           IF +LEXI'>0

                               QUIT 

                           Begin DoDot:2

 +11                           NEW LEXTX2

                               SET LEXTX2=$$TM($GET(LEXT(LEXI)))

                               IF '$LENGTH(LEXTX2)

                                   QUIT 

 +12                           WRITE !,?23,LEXTX2

                           End DoDot:2

                   End DoDot:1

 +13       IF +LEXFND=1

               SET LEXANS=$$ONE

           IF +LEXFND>1

               SET LEXANS=$$MUL

 +14       IF LEXANS>0

               Begin DoDot:1

 +15               SET X=""

                   SET Y=-1

                   DO X(.LEXA)

                   DO Y(LEXANS,.LEXB)

 +16               IF +($GET(X))>0&(+($GET(Y))>0)

                       QUIT 

                   SET X=""

                   SET Y=-1

               End DoDot:1

               IF +($GET(X))'>0

                   SET X=""

               IF +($GET(Y))'>0

                   SET Y=-1

               QUIT 

 +17       IF LEXANS'>0

               KILL X,Y,LEXB

               SET X=""

               SET Y=-1

 +18       QUIT 

ONE(X)    ;     One Entry Found - Needs LEXB

 +1        NEW LEXIEN,LEXLN,LEXSO,LEXTEXT

           NEW DIR

 +2        NEW LEXTXT,Y

           SET LEXTEXT=$GET(LEXB(1))

           SET LEXIEN=+LEXTEXT

 +3        SET LEXSO=$PIECE(LEXTEXT,U,2)

           SET LEXTEXT=$PIECE(LEXTEXT,U,3)

 +4        SET LEXTXT(1)=LEXSO_"   "_LEXTEXT

           DO PAR(.LEXTXT,64)

 +5        SET DIR("A",1)=" One ICD-10 suggestion found"

           SET DIR("A",2)=" "

 +6        SET DIR("A",3)="     "_$GET(LEXTXT(1))

           SET LEXLN=3

 +7        IF $LENGTH($GET(LEXTXT(2)))

               SET LEXLN=LEXLN+1

               Begin DoDot:1

 +8                SET DIR("A",LEXLN)="                     "_$GET(LEXTXT(2))

               End DoDot:1

 +9        SET LEXLN=LEXLN+1

           SET DIR("A",LEXLN)=" "

           SET LEXLN=LEXLN+1

 +10       SET DIR("A")="   OK?  "

           SET DIR("B")="Yes"

           SET DIR(0)="YAO"

           WRITE !

 +11       DO ^DIR

           SET LEX0REV=1

           IF +Y>0

               SET LEX0SEL=1

           IF +Y>0

               QUIT 1

 +12       IF X["^^"!($DATA(DTOUT))

               QUIT "^^"

           IF X["^"

               QUIT "^"

 +13       QUIT -1

MUL(X)    ;     Multiple Entries Found - Needs LEXB

 +1        NEW LEXENT,LEXIEN,LEXIT,LEXITEM,LEXLEN,LEXMAX,LEXMAT,LEXN,LEXSEL

 +2        NEW LEXSO,LEXTEXT,LEXTOT,Y

           SET LEXLEN=+($GET(LEXN))

 +3        IF +LEXLEN'>4

               SET LEXLEN=5

           NEW LEXN

 +4        SET (LEXMAX,LEXENT,LEXSEL,LEXIT)=0

 +5        SET U="^"

           SET LEXTOT=$GET(LEXB(0))

 +6        SET LEXSEL=0

           IF +LEXTOT=0

               GOTO MULQ

 +7        SET LEXMAT=LEXTOT_" ICD-10 suggestion"_$SELECT(+LEXTOT>1:"s",1:"")_" found"

 +8        IF +LEXTOT>0

               WRITE !!," ",LEXMAT

 +9        FOR LEXENT=1:1:LEXTOT

               IF LEXIT

                   QUIT 

               Begin DoDot:1

 +10               IF ((LEXSEL>0)&(LEXSEL<LEXENT+1))

                       SET LEXIT=1

                       QUIT 

 +11               NEW LEXITEM,LEXIEN,LEXTEXT,LEXSO

 +12               SET LEXITEM=$GET(LEXB(LEXENT))

 +13               SET LEXIEN=+LEXITEM

                   SET LEXSO=$PIECE(LEXITEM,U,3)

 +14               SET LEXTEXT=$PIECE(LEXITEM,U,2)

                   IF +LEXIEN'>0

                       QUIT 

 +15               IF '$LENGTH(LEXSO)

                       QUIT 

                   IF '$LENGTH(LEXTEXT)

                       QUIT 

 +16               SET LEXMAX=LEXENT

                   IF LEXENT#LEXLEN=1

                       WRITE !

                   DO MULW

 +17               IF LEXMAX=LEXTOT

                       SET LEX0REV=1

 +18               IF LEXENT#LEXLEN=0

                       WRITE !

 +19               IF LEXENT#LEXLEN=0

                       SET LEXSEL=$$MULS(LEXMAX,LEXENT)

 +20               IF LEXSEL["^"

                       SET LEXIT=1

               End DoDot:1

               IF LEXIT

                   QUIT 

 +21       IF LEXENT#LEXLEN'=0

               IF +LEXSEL=0

                   Begin DoDot:1

 +22                   WRITE !

                       SET LEXSEL=$$MULS(LEXMAX,LEXENT)

 +23                   IF LEXSEL["^"

                           SET LEXIT=1

                   End DoDot:1

 +24       GOTO MULQ

 +25       QUIT X

MULW      ;       Write Multiple - Needs LEXENT,LEXIEN,LEXSO,LEXTXT

 +1        IF +($GET(LEXENT))'>0

               QUIT 

           IF +($GET(LEXIEN))'>0

               QUIT 

 +2        IF '$LENGTH($GET(LEXTEXT))

               QUIT 

           IF '$LENGTH($GET(LEXSO))

               QUIT 

 +3        NEW LEXI,LEXIND,LEXTAB,LEXTXT,LEXTX2

 +4        SET LEXTAB=8

           SET LEXIND=18

 +5        WRITE !,$JUSTIFY(LEXENT,5),".",?LEXTAB,LEXSO

 +6        SET LEXTXT(1)=LEXTEXT

           DO PAR(.LEXTXT,54)

 +7        WRITE ?LEXIND,$GET(LEXTXT(1))

 +8        SET LEXI=1

           FOR 

               SET LEXI=$ORDER(LEXTXT(LEXI))

               IF +LEXI'>0

                   QUIT 

               Begin DoDot:1

 +9                NEW LEXTX2

                   SET LEXTX2=$$TM($GET(LEXTXT(LEXI)))

                   IF '$LENGTH(LEXTX2)

                       QUIT 

 +10               WRITE !,?LEXIND,LEXTX2

               End DoDot:1

 +11       QUIT 

MULS(X,Y) ;       Select Multiple - Needs LEXB, Uses LEXIT,LEXTOT

 +1        NEW DIR,DIRB,LEXHLP,LEXLAST,LEXMAX

 +2        NEW LEXNEXT,LEXRAN,LEXS,LEXENT,Y

           IF +($GET(LEXIT))>0

               QUIT "^^"

 +3        SET LEXS=$GET(X)

           SET LEXENT=$GET(Y)

           NEW X

 +4        SET LEXMAX=+($GET(LEXS))

           SET LEXLAST=+($GET(LEXENT))

 +5        IF LEXMAX=0

               QUIT -1

           SET LEXRAN=" Select 1-"_LEXMAX_":  "

 +6        SET LEXNEXT=$ORDER(LEXB(+LEXLAST))

           IF +LEXNEXT>0

               Begin DoDot:1

 +7                SET DIR("A")=" Press <RETURN> for more, "

 +8                SET DIR("A")=DIR("A")_"'^' to exit, or"_LEXRAN

               End DoDot:1

 +9        IF +LEXNEXT'>0

               SET DIR("A")=LEXRAN

 +10       SET LEXHLP="    Answer must be from 1 to "_LEXMAX

 +11       SET LEXHLP=LEXHLP_", or <Return> to continue"

 +12       SET DIR("PRE")="S:X[""?"" X=""??"""

 +13       SET (DIR("?"),DIR("??"))="^D MULSH^ICDEXLK2"

 +14       SET DIR(0)="NAO^1:"_LEXMAX_":0"

           DO ^DIR

 +15       IF X["^"&(LEXENT=+($GET(LEXTOT)))

               SET (X,Y)="^^^"

 +16       IF X["^^"!($DATA(DTOUT))

               SET LEXIT=1

               SET X="^^"

 +17       IF X["^^"!(+($GET(LEXIT))>0)

               QUIT "^^"

 +18       SET LEXS=+Y

           IF $DATA(DTOUT)!(X[U)

               SET LEXS=U

 +19       KILL DIR

           NEW LEXIT,LEXTOT

 +20       IF +LEXS>0&($DATA(LEXB(+LEXS)))

               SET LEX0SEL=1

 +21       QUIT LEXS

MULSH     ;       Select Multiple Help

 +1        IF $LENGTH($GET(LEXHLP))

               WRITE !,$GET(LEXHLP)

               QUIT 

 +2        QUIT 

MULQ      ;       Quit Multiple

 +1        IF +LEXSEL'>0

               QUIT -1

           SET X=+LEXSEL

 +2        QUIT X

 +3       ; 

 +4       ; Miscellaneous

PAR(LEXC,LEXL) ;   Parse Array

 +1        NEW %,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,LEXIEN,I,X,Z

 +2        KILL ^UTILITY($JOB,"W")

           IF '$DATA(LEXC)

               QUIT 

           SET LEXL=+($GET(LEXL))

 +3        IF +LEXL'>0

               SET LEXL=79

           SET DIWL=1

           SET DIWF="C"_+LEXL

           SET LEXIEN=0

 +4        FOR 

               SET LEXIEN=$ORDER(LEXC(LEXIEN))

               IF +LEXIEN=0

                   QUIT 

               Begin DoDot:1

 +5                SET X=$GET(LEXC(LEXIEN))

                   DO ^DIWP

               End DoDot:1

 +6        KILL LEXC

           SET LEXIEN=0

 +7        FOR 

               SET LEXIEN=$ORDER(^UTILITY($JOB,"W",1,LEXIEN))

               IF +LEXIEN=0

                   QUIT 

               Begin DoDot:1

 +8                SET LEXC(LEXIEN)=$$TM($GET(^UTILITY($JOB,"W",1,LEXIEN,0))," ")

               End DoDot:1

 +9        KILL ^UTILITY($JOB,"W")

 +10       QUIT 

TM(X,Y)   ;   Trim Y

 +1        SET Y=$GET(Y)

           IF '$LENGTH(Y)

               SET Y=" "

 +2        FOR 

               IF $EXTRACT(X,1)'=Y

                   QUIT 

               SET X=$EXTRACT(X,2,$LENGTH(X))

 +3        FOR 

               IF $EXTRACT(X,$LENGTH(X))'=Y

                   QUIT 

               SET X=$EXTRACT(X,1,($LENGTH(X)-1))

 +4        QUIT X

X(LEXA)   ;   Set X

 +1        NEW LEXEXP,LEXCOD,LEXNOM,LEXIEN

           KILL X

           SET X=""

 +2        SET LEXEXP=$GET(LEXA("SOURCE","EXP"))

           IF '$LENGTH(LEXEXP)

               QUIT 

 +3        SET LEXCOD=$GET(LEXA("SOURCE","SOE"))

           IF '$LENGTH(LEXCOD)

               QUIT 

 +4        SET LEXNOM=$GET(LEXA("SOURCE","SRC"))

           IF '$LENGTH(LEXNOM)

               QUIT 

 +5        SET LEXIEN=+($GET(LEXA("SOURCE","Y")))

           IF '$LENGTH(LEXIEN)

               QUIT 

 +6        IF +LEXIEN'>0

               QUIT 

           SET X=LEXIEN_"^"_LEXEXP_"^"_LEXCOD_"^"_LEXNOM

 +7        QUIT 

Y(LEX,LEXB) ;   Set Y

 +1        NEW LEXEXP,LEXCOD,LEXNOM,LEXIEN,LEXDAT

 +2        NEW LEXDAT,LEXEIEN,LEXEX,LEXICDD,LEXSO,LEXSTA,LEXTD

 +3        KILL Y

           SET Y=-1

           SET LEX=+($GET(LEX))

           SET LEXDAT=$GET(LEXB(+LEX))

 +4        SET LEXEXP=$PIECE(LEXDAT,"^",2)

           IF '$LENGTH(LEXEXP)

               QUIT 

 +5        SET LEXCOD=$PIECE(LEXDAT,"^",3)

           IF '$LENGTH(LEXCOD)

               QUIT 

 +6        SET LEXNOM="ICD-10-CM"

 +7        SET LEXIEN=+($PIECE(LEXDAT,"^",1))

           IF '$LENGTH(LEXIEN)

               QUIT 

 +8        IF +LEXIEN'>0

               QUIT 

           SET Y=LEXIEN_"^"_LEXEXP_"^"_LEXCOD_"^"_LEXNOM

 +9        QUIT 

SAB(X)    ;   Select Coding System

 +1        NEW DIC,DIROUT,DIRUT,DTOUT,DUOUT,LEXB,Y

 +2        SET DIC="^LEX(757.03,"

           SET DIC(0)="AEQM"

 +3        SET DIC("A")=" Select a Coding System:  "

 +4        SET LEXB=$PIECE($GET(^LEX(757.03,1,0)),"^",2)

           IF $LENGTH(LEXB)

               SET DIC("B")=LEXB

 +5        SET DIC("W")="N LEX1,LEX2 S LEX1=$P($G(^LEX(757.03,+Y,0)),U,2),"

 +6        SET DIC("W")=DIC("W")_"LEX2=$P($G(^LEX(757.03,+Y,0)),U,3) "

 +7        SET DIC("W")=DIC("W")_"S:$L(LEX2,"","")>2 LEX2=$P(LEX2,"","",1,"

 +8        SET DIC("W")=DIC("W")_"($L(LEX2,"","")-1)) W "" "",LEX1"

 +9        SET DIC("W")=DIC("W")_"_$J("" "",(12-$L(LEX1)))_""  ""_LEX2"

 +10       SET DIC("S")="I $E($P($G(^LEX(757.03,+Y,0)),""^"",1),1,3)'=""10D"""

 +11       SET DIC("W")="W ""   "",$P($G(^LEX(757.03,+Y,0)),U,2)"

 +12       KILL X

           DO ^DIC

           IF X["^"!($DATA(DTOUT))!($DATA(DUOUT))

               QUIT "^"

 +13       SET LEXB=$EXTRACT($PIECE($GET(^LEX(757.03,+Y,0)),"^",1),1,3)

           IF $LENGTH(LEXB)'=3

               QUIT "^"

 +14       IF '$DATA(^LEX(757.03,"ASAB",LEXB))

               QUIT "^"

           SET X=LEXB

 +15       QUIT X