LEX10CX.m

LEX10CX ;ISL/KER - ICD-10 Cross-Over - Main ;05/23/2017

 ;;2.0;LEXICON UTILITY;**80,103**;Sep 23, 1996;Build 2

 ;               

 ; Global Variables

 ;    None

 ;               

 ; External References

 ;    $$FMADD^XLFDT       ICR  10103

 ;    $$UP^XLFSTR         ICR  10104

 ;               

 ; Local Variables NEWed or KILLed Elsewhere

 ;    None

 ;    

EN ; Suggested Code (Code and Source are unknown, interactive)

 ;

 ; Input

 ; 

 ;     None.  Interactive API.  The variable LEXSAB can

 ;     be preset to a coding system (.01 field in file 

 ;     757.03), else wise the user will be prompted for

 ;     a coding system.

 ; 

 ; Output

 ; 

 ;     X    Source - 4 piece "^" delimited string

 ;     

 ;            1  Lexicon IEN for file 757.02

 ;            2  Expression

 ;            3  Code in selected Coding System

 ;            4  Coding System nomenclature

 ;            

 ;            or null if search fails

 ;            

 ;     Y    Target - 4 piece "^" delimited string

 ;     

 ;            1  Lexicon IEN for file 757.02

 ;            2  Expression

 ;            3  ICD-10 Diagnostic Code

 ;            4  ICD-10-CM

 ;            

 ;            or -1 if search fails

 ;            

 ; Example Output:

 ; 

 ;    ICD-9 to ICD-10

 ; 

 ;       X="119899^Tobacco Use Disorder^305.1^ICD-9-CM"

 ;       Y="5003360^Nicotine Dependence, unspecified, 

 ;          Uncomplicated^F17.200^ICD-10-CM"

 ;    

 ;    SNOMED CT to ICD-10

 ;    

 ;       X="7078519^Diabetes mellitus type 2^44054006^SNOMED CT"

 ;       Y="5002666^Type 2 Diabetes Mellitus without 

 ;          Complications^E11.9^ICD-10-CM"

 ; 

 N LEX0FND,LEX0SEL,LEX0REV,LEXEFF,LEXIT,LEXERR,LEXEXP,LEXIEN,LEXLAD

 N LEXNOM,LEXSRC,LEXSRI,LEXTCOD,LEXTGT,LEXTMP,LEXTTXT,DIROUT,DIRUT

 N DTOUT,DUOUT K X,Y S (LEXIT,LEX0FND,LEX0SEL,LEX0REV)=0

 S LEXERR="Coding system not selected or specified"

 S LEXSAB=$$SAB($G(LEXSAB)) S:$L(LEXSAB)'=3 LEXSAB=$$SAB^LEX10CX4

 I $L(LEXSAB)'=3 D ERR(LEXERR) Q

 S LEXTMP=LEXSAB K LEXSAB N LEXSAB S LEXSAB=LEXTMP

 S LEXSRI=$$SRC(LEXSAB) I +LEXSRI'>0 D ERR(LEXERR) Q

 S LEXNOM=$P($G(^LEX(757.03,+LEXSRI,0)),"^",2)

 I '$L(LEXNOM) D ERR(LEXERR) Q

 S X=$$SRL^LEX10CX2(LEXSAB,.LEXSRC)

 D CX(.LEXSRC)

 Q

EN2(CODE,SYS) ; Suggested Code (Source is known, interactive)

 ;

 ; Input

 ; 

 ;     CODE   Code

 ;     SYS    Coding System Abbreviation

 ; 

 ; Output

 ; 

 ;     X      Source - 4 piece "^" delimited string

 ;     

 ;              1  Lexicon IEN for file 757.02

 ;              2  Expression

 ;              3  Code in selected Coding System

 ;              4  Coding System nomenclature

 ;            

 ;              or null if search fails

 ;            

 ;     Y      Target - 4 piece "^" delimited string

 ;     

 ;              1  Lexicon IEN for file 757.02

 ;              2  Expression

 ;              3  ICD-10 Diagnostic Code

 ;              4  ICD-10-CM

 ;            

 ;              or -1 if search fails

 ;            

 ; Example Output:

 ; 

 ;    ICD-9 to ICD-10

 ; 

 ;       X="119899^Tobacco Use Disorder^305.1^ICD-9-CM"

 ;       Y="5003360^Nicotine Dependence, unspecified, 

 ;          Uncomplicated^F17.200^ICD-10-CM"

 ;    

 ;    SNOMED CT to ICD-10

 ;    

 ;       X="7078519^Diabetes mellitus type 2^44054006^SNOMED CT"

 ;       Y="5002666^Type 2 Diabetes Mellitus without 

 ;          Complications^E11.9^ICD-10-CM"

 ; 

 N LEX0FND,LEX0SEL,LEX0REV,LEXEFF,LEXIT,LEXERR,LEXEXP,LEXIEN,LEXLAD

 N LEXNOM,LEXSRC,LEXSRI,LEXTCOD,LEXTGT,LEXTMP,LEXTTXT,DIROUT,DIRUT

 N DTOUT,DUOUT S (LEXIT,LEX0FND,LEX0SEL,LEX0REV)=0

 S LEXERR="Coding system not selected or specified" S LEXSAB=$$SAB($G(SYS))

 I $L(LEXSAB)'=3 D ERR(LEXERR) Q

 S LEXTMP=LEXSAB K LEXSAB N LEXSAB S LEXSAB=LEXTMP,LEXSRI=$$SRC(LEXSAB)

 I +LEXSRI'>0 D ERR(LEXERR) Q

 S LEXNOM=$P($G(^LEX(757.03,+LEXSRI,0)),"^",2)

 I '$L(LEXNOM) D ERR(LEXERR) Q

 S LEXERR=LEXNOM_" code not selected"

 S LEXTCOD=$G(CODE) I '$L(LEXTCOD) D ERR(LEXERR) Q

 K X,Y D SRA^LEX10CX2(LEXTCOD,LEXSAB,.LEXSRC)

 D CX(.LEXSRC)

 Q

EN3(CODE,SYS,ARY,MAX) ; Suggested Code (Code and Source are known, silent/GUI)

 ;

 ; Input

 ; 

 ;   CODE  Code (required)

 ;   SYS   Coding System Abbreviation (required)

 ;   ARY   Local Array passed by reference (required)

 ;   MAX   Maximum # of suggestions (optional, default 100)

 ; 

 ; Output

 ; 

 ;   ARY   Array, passed by reference

 ;     

 ;         ARY("X")     Input

 ;         ARY("Y",0)   Output   Number of Suggested Entries

 ;         ARY("Y",1)   Output   First Suggestion

 ;         ARY("Y",n)   Output   nth Suggestion

 ;                         

 ;         ARY("E")     Error message

 ;

 ;            Both ARY("X") and ARY("Y",#) are 4 piece "^"

 ;            delimited strings:

 ;                

 ;               1  Internal Entry Number (IEN) file 757.01

 ;               2  Expression (file 757.01, field .01)

 ;               3  Code (file 757.02, field 1)

 ;               4  Nomenclature (file 757.03, field 1)

 ;                  i.e., SNOMED CT, ICD-9-CM or ICD-10-CM

 ; 

 N LEXC,LEX0FND,LEX0SEL,LEX0REV,LEXEFF,LEXI,LEXIT,LEXERR,LEXERRT,LEXEXP,LEXIEN,LEXLAD

 N LEXNASK,LEXNASKM,LEXNOM,LEXQT,LEXSRC,LEXSRI,LEXTCOD,LEXTGT,LEXTMP,LEXTTXT,DIROUT

 N DIRUT,DTOUT,DUOUT S:+($G(MAX))'>0 MAX=100 S LEXNASK=1,LEXNASKM=+($G(MAX))

 K:+LEXNASKM'>0 LEXNASKM S LEXQT=1,LEXERRT=""

 D EN2($G(CODE),$G(SYS)) S LEXNOM=$$SRN("10D") K ARY

 S:$L(LEXERRT) ARY("E")=LEXERRT S (LEXC,LEXI)=0

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

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

 . S:$L(LEXNOM) $P(LEXT,"^",4)=LEXNOM

 . S LEXC=LEXC+1 Q:+($G(LEXNASKM))>0&(LEXC>+($G(LEXNASKM)))

 . S ARY("Y",LEXC)=LEXT,ARY("Y",0)=LEXC

 I +($G(ARY("Y",0)))'>0 D

 . S LEXSRC=$G(ARY("X"))

 . K ARY S ARY("Y",0)=0

 . S:$L(LEXSRC) ARY("X")=LEXSRC

 S:$L(LEXERRT) ARY("E")=LEXERRT

 S:$L($G(LEXNASK("X"))) ARY("X")=$G(LEXNASK("X"))

 Q

 ;

CX(LEXSRC) ; Convert to ICD-10

 S LEXNOM=$G(LEXSRC("SOURCE","SRC"))

 I '$D(LEXSRC("SOURCE")) D  Q

 . D ERR("Invalid code for coding system")

 I '$L(LEXNOM) D  Q

 . D ERR(("Invalid coding system passed "_$S($L($G(LEXNOM)):" - ",1:"")_LEXNOM))

 S LEXERR=LEXNOM_" code not selected"

 S LEXIEN=+($G(LEXSRC("SOURCE","Y")))

 I +LEXIEN'>0 D ERR((LEXERR_" (IEN) "_LEXIEN)) Q

 S LEXEXP=$P($G(LEXSRC("SOURCE","Y")),"^",2)

 I '$L(LEXEXP) D ERR((LEXERR_" (Expression) ")) Q

 S LEXERR="Invalid "_LEXNOM_" code selected"

 S LEXTCOD=$G(LEXSRC("SOURCE","SOE"))

 I '$L(LEXTCOD) D ERR((LEXERR_" (Code) "_LEXTCOD)) Q

 I '$D(^LEX(757.01,+LEXIEN,0)) D ERR((LEXERR_" (Expression) ")) Q

 S LEXERR="Invalid coding system"

 S LEXSAB=$G(LEXSRC("SOURCE","SAB"))

 I '$L(LEXSAB) D ERR((LEXERR_" (SAB) "_LEXSAB)) Q

 S LEXERR="Invalid "_LEXNOM_" code selected"

 S LEXLAD=$P($$LA^LEX10CX5(LEXTCOD,LEXSAB),".",1)

 I LEXLAD'?7N D ERR((LEXERR_" (Last Activation Date) "_LEXLAD)) Q

 S LEXEFF=$$FMADD^XLFDT(LEXLAD,3)

 S LEXERR="Invalid text for code"

 S LEXTTXT=$$UP^XLFSTR($G(LEXSRC("SOURCE","EXP")))

 I '$L(LEXTTXT) D ERR((LEXERR_" (Text) ")) Q

 D SEG^LEX10CX5(,.LEXSRC)

 I $O(LEXSRC("SEG",0))'>0 D ERR((LEXERR_" (Segments) ")) Q

 S X=$$FIND1^LEX10CX3(LEXTCOD,.LEXSRC,.LEXTGT) S:+X'>0 X=""

 I +X'>0 S X=$$FIND2^LEX10CX3(LEXTTXT,.LEXSRC,.LEXTGT) S:+X'>0 X=""

 I $G(LEXNASK)>0 D  Q

 . N LEXI,LEXC S LEXC=0 F LEXI=1:1:100 Q:'$L($G(LEXTGT(LEXI)))  D

 . . N LEXT S LEXT=$G(LEXTGT(LEXI)),LEXC=LEXC+1

 . . I +($G(LEXNASKM))>0,+LEXC>+($G(LEXNASKM)) Q

 . . S LEXNASK(LEXC)=LEXT

 . I $L($G(LEXSRC("SOURCE","Y")),"^")=3 D

 . . N LEXT,LEX4 S LEXT=$G(LEXSRC("SOURCE","Y"))

 . . S LEX4=$G(LEXSRC("SOURCE","SRC"))

 . . S:$L(LEX4) $P(LEXT,"^",4)=LEX4

 . . S LEXNASK("X")=LEXT

 . I $L($G(LEXSRC("SOURCE","Y")),"^")'=3 D

 . . N LEX1,LEX2,LEX3,LEX4,LEXT

 . . S LEX1=+($G(LEXSRC("SOURCE","EXI"))) Q:LEX1'>0

 . . S LEX2=$G(LEXSRC("SOURCE","EXP")) Q:'$L(LEX2)

 . . S LEX3=$G(LEXSRC("SOURCE","SOE")) Q:'$L(LEX3)

 . . S LEX4=$G(LEXSRC("SOURCE","SRC"))

 . . S LEXT=LEX1_"^"_LEX2_"^"_LEX3

 . . S:$L(LEX4) $P(LEXT,"^",4)=LEX4

 . . S LEXNASK("X")=LEXT

 S LEXIT=0 I +($G(X))>0 D  Q:LEXIT>0

 . N DIR K DIROUT,DIRUT,DUOUT,DTOUT D ASK^LEX10CX4(.LEXSRC,.LEXTGT)

 . I $D(DIROUT) S (LEX0FND,LEX0REV,LEX0SEL)=0,LEXIT=1

 . K:$G(LEX0FND)>0&($G(LEX0REV)>0)&('$L($G(X))) DIROUT,DIRUT,DUOUT,DTOUT

 . I $D(DIROUT)!($D(DIRUT))!($D(DUOUT))!($D(DTOUT)) D  Q

 . . S X="^",Y=-1 S:$D(DIROUT) LEXIT=1

 . D:+($G(X))>0&(+($G(Y))>0) OUT($G(X),$G(Y))

 . S:+($G(X))>0&(+($G(Y))>0) LEXIT=1

 . S:$G(LEX0FND)>0&($G(LEX0SEL)'>0) LEXIT=0

 . I +($G(X))'>0!($G(Y)=-1) S X="",Y=-1

 I $D(LEXTEST) D

 . W:'$D(LEXQT) !! D SA^LEX10CX5("LEXSRC")

 . W:'$D(LEXQT) !! D SA^LEX10CX5("LEXTGT") N LEXTEST

 I +X'>0 D

 . S X=$$FIND3^LEX10CX3(.LEXSRC,.LEXTGT) S:+X'>0 X=""

 . I $G(LEXTGT(0))=1,$L($G(LEXTGT(1))) D

 . . D X^LEX10CX4(.LEXSRC),Y^LEX10CX4(1,.LEXTGT)

 . . D:+($G(X))>0&(+($G(Y))>0) OUT($G(X),$G(Y))

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

 Q

OUT(X,Y) ; Display Output - Interactive, Positive Results only

 N LEXSI,LEXST,LEXSC,LEXSN,LEXSD,LEXTI,LEXTT,LEXTC,LEXTN

 N LEXTD,LEXL,LEXI S X=$G(X) Q:+X'>0  S Y=$G(Y) Q:+Y'>0

 S LEXSI=$P(X,"^",1) Q:LEXSI'>0  S LEXST(1)=$P(X,"^",2) Q:'$L(LEXST(1))

 S LEXSC=$P(X,"^",3) Q:'$L(LEXSC)  S LEXSN=$P(X,"^",4) Q:'$L(LEXSN)

 S LEXTI=$P(Y,"^",1) Q:LEXTI'>0  S LEXTT(1)=$P(Y,"^",2) Q:'$L(LEXTT(1))

 S LEXTC=$P(Y,"^",3) Q:'$L(LEXTC)  S LEXTN=$P(Y,"^",4) Q:'$L(LEXTN)

 S LEXSD=LEXSN_"   "_LEXSC S LEXTD=LEXTN_"  "_LEXTC

 S LEXL=$L(LEXSD)+5 S:($L(LEXTD)+5)>LEXL LEXL=$L(LEXTD)+5

 D PR^LEXU(.LEXST,(78-LEXL)),PR^LEXU(.LEXTT,(78-LEXL))

 W:'$D(LEXQT) !!," ",LEXSD,?LEXL,$G(LEXST(1))

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

 . W:$L($G(LEXST(LEXI))) !,?LEXL,$G(LEXST(LEXI))

 W:'$D(LEXQT) !," ",LEXTD,?LEXL,$G(LEXTT(1))

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

 . W:$L($G(LEXTT(LEXI))) !,?LEXL,$G(LEXTT(LEXI))

 W:'$D(LEXQT) !

 Q

ERR(X) ; Error

 Q:'$L($G(X))  W:'$D(LEXQT) !,?2,$G(X),! S:$D(LEXQT) LEXERRT=$G(X)

 Q

SAB(X) ; Resolve SAB to 3 character Abbreviation

 N LEXSAB,LEXCI,LEXCS S LEXCS=$G(X) Q:'$L(LEXCS) ""

 I LEXCS?1N.N Q:$D(^LEX(757.03,+LEXCS,0)) $E($G(^LEX(757.03,+LEXCS,0)),1,3)

 S LEXCI=$O(^LEX(757.03,"B",$$UP^XLFSTR(LEXCS),0)) Q:$D(^LEX(757.03,+LEXCI,0)) $E($G(^LEX(757.03,+LEXCI,0)),1,3)

 S LEXCI=$O(^LEX(757.03,"ASAB",$$UP^XLFSTR(LEXCS),0)) Q:$D(^LEX(757.03,+LEXCI,0)) $E($G(^LEX(757.03,+LEXCI,0)),1,3)

 S LEXCI=$O(^LEX(757.03,"C",LEXCS,0)) Q:$D(^LEX(757.03,+LEXCI,0)) $E($G(^LEX(757.03,+LEXCI,0)),1,3)

 Q ""

SRC(X) ; Resolve Source (pointer for SAB in 757.03)

 N LEXSAB,LEXCI,LEXCS S LEXCS=$G(X) Q:'$L(LEXCS) ""  S LEXSAB=$$SAB(LEXCS) Q:$L(LEXSAB)'=3 ""

 S X=$O(^LEX(757.03,"ASAB",LEXSAB,0)) S:'$D(^LEX(757.03,+X,0)) X=""

 Q X

SRN(X) ; Resolve Source (pointer for SAB in 757.03)

 N LEXNOM,LEXCI,LEXCS S LEXCS=$G(X) Q:'$L(LEXCS) ""  S LEXCI=$$SRC(LEXCS)

 Q:'$D(^LEX(757.03,+LEXCI,0)) ""  S X=$P($G(^LEX(757.03,+LEXCI,0)),"^",2)

 Q X

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LEX10CX   10950     printed  Mar 13, 2025@21:07:52                                                                                                                                                                                                    Page 2

LEX10CX   ;ISL/KER - ICD-10 Cross-Over - Main ;05/23/2017

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

 +2       ;               

 +3       ; Global Variables

 +4       ;    None

 +5       ;               

 +6       ; External References

 +7       ;    $$FMADD^XLFDT       ICR  10103

 +8       ;    $$UP^XLFSTR         ICR  10104

 +9       ;               

 +10      ; Local Variables NEWed or KILLed Elsewhere

 +11      ;    None

 +12      ;    

EN        ; Suggested Code (Code and Source are unknown, interactive)

 +1       ;

 +2       ; Input

 +3       ; 

 +4       ;     None.  Interactive API.  The variable LEXSAB can

 +5       ;     be preset to a coding system (.01 field in file 

 +6       ;     757.03), else wise the user will be prompted for

 +7       ;     a coding system.

 +8       ; 

 +9       ; Output

 +10      ; 

 +11      ;     X    Source - 4 piece "^" delimited string

 +12      ;     

 +13      ;            1  Lexicon IEN for file 757.02

 +14      ;            2  Expression

 +15      ;            3  Code in selected Coding System

 +16      ;            4  Coding System nomenclature

 +17      ;            

 +18      ;            or null if search fails

 +19      ;            

 +20      ;     Y    Target - 4 piece "^" delimited string

 +21      ;     

 +22      ;            1  Lexicon IEN for file 757.02

 +23      ;            2  Expression

 +24      ;            3  ICD-10 Diagnostic Code

 +25      ;            4  ICD-10-CM

 +26      ;            

 +27      ;            or -1 if search fails

 +28      ;            

 +29      ; Example Output:

 +30      ; 

 +31      ;    ICD-9 to ICD-10

 +32      ; 

 +33      ;       X="119899^Tobacco Use Disorder^305.1^ICD-9-CM"

 +34      ;       Y="5003360^Nicotine Dependence, unspecified, 

 +35      ;          Uncomplicated^F17.200^ICD-10-CM"

 +36      ;    

 +37      ;    SNOMED CT to ICD-10

 +38      ;    

 +39      ;       X="7078519^Diabetes mellitus type 2^44054006^SNOMED CT"

 +40      ;       Y="5002666^Type 2 Diabetes Mellitus without 

 +41      ;          Complications^E11.9^ICD-10-CM"

 +42      ; 

 +43       NEW LEX0FND,LEX0SEL,LEX0REV,LEXEFF,LEXIT,LEXERR,LEXEXP,LEXIEN,LEXLAD

 +44       NEW LEXNOM,LEXSRC,LEXSRI,LEXTCOD,LEXTGT,LEXTMP,LEXTTXT,DIROUT,DIRUT

 +45       NEW DTOUT,DUOUT

           KILL X,Y

           SET (LEXIT,LEX0FND,LEX0SEL,LEX0REV)=0

 +46       SET LEXERR="Coding system not selected or specified"

 +47       SET LEXSAB=$$SAB($GET(LEXSAB))

           if $LENGTH(LEXSAB)'=3

               SET LEXSAB=$$SAB^LEX10CX4

 +48       IF $LENGTH(LEXSAB)'=3

               DO ERR(LEXERR)

               QUIT 

 +49       SET LEXTMP=LEXSAB

           KILL LEXSAB

           NEW LEXSAB

           SET LEXSAB=LEXTMP

 +50       SET LEXSRI=$$SRC(LEXSAB)

           IF +LEXSRI'>0

               DO ERR(LEXERR)

               QUIT 

 +51       SET LEXNOM=$PIECE($GET(^LEX(757.03,+LEXSRI,0)),"^",2)

 +52       IF '$LENGTH(LEXNOM)

               DO ERR(LEXERR)

               QUIT 

 +53       SET X=$$SRL^LEX10CX2(LEXSAB,.LEXSRC)

 +54       DO CX(.LEXSRC)

 +55       QUIT 

EN2(CODE,SYS) ; Suggested Code (Source is known, interactive)

 +1       ;

 +2       ; Input

 +3       ; 

 +4       ;     CODE   Code

 +5       ;     SYS    Coding System Abbreviation

 +6       ; 

 +7       ; Output

 +8       ; 

 +9       ;     X      Source - 4 piece "^" delimited string

 +10      ;     

 +11      ;              1  Lexicon IEN for file 757.02

 +12      ;              2  Expression

 +13      ;              3  Code in selected Coding System

 +14      ;              4  Coding System nomenclature

 +15      ;            

 +16      ;              or null if search fails

 +17      ;            

 +18      ;     Y      Target - 4 piece "^" delimited string

 +19      ;     

 +20      ;              1  Lexicon IEN for file 757.02

 +21      ;              2  Expression

 +22      ;              3  ICD-10 Diagnostic Code

 +23      ;              4  ICD-10-CM

 +24      ;            

 +25      ;              or -1 if search fails

 +26      ;            

 +27      ; Example Output:

 +28      ; 

 +29      ;    ICD-9 to ICD-10

 +30      ; 

 +31      ;       X="119899^Tobacco Use Disorder^305.1^ICD-9-CM"

 +32      ;       Y="5003360^Nicotine Dependence, unspecified, 

 +33      ;          Uncomplicated^F17.200^ICD-10-CM"

 +34      ;    

 +35      ;    SNOMED CT to ICD-10

 +36      ;    

 +37      ;       X="7078519^Diabetes mellitus type 2^44054006^SNOMED CT"

 +38      ;       Y="5002666^Type 2 Diabetes Mellitus without 

 +39      ;          Complications^E11.9^ICD-10-CM"

 +40      ; 

 +41       NEW LEX0FND,LEX0SEL,LEX0REV,LEXEFF,LEXIT,LEXERR,LEXEXP,LEXIEN,LEXLAD

 +42       NEW LEXNOM,LEXSRC,LEXSRI,LEXTCOD,LEXTGT,LEXTMP,LEXTTXT,DIROUT,DIRUT

 +43       NEW DTOUT,DUOUT

           SET (LEXIT,LEX0FND,LEX0SEL,LEX0REV)=0

 +44       SET LEXERR="Coding system not selected or specified"

           SET LEXSAB=$$SAB($GET(SYS))

 +45       IF $LENGTH(LEXSAB)'=3

               DO ERR(LEXERR)

               QUIT 

 +46       SET LEXTMP=LEXSAB

           KILL LEXSAB

           NEW LEXSAB

           SET LEXSAB=LEXTMP

           SET LEXSRI=$$SRC(LEXSAB)

 +47       IF +LEXSRI'>0

               DO ERR(LEXERR)

               QUIT 

 +48       SET LEXNOM=$PIECE($GET(^LEX(757.03,+LEXSRI,0)),"^",2)

 +49       IF '$LENGTH(LEXNOM)

               DO ERR(LEXERR)

               QUIT 

 +50       SET LEXERR=LEXNOM_" code not selected"

 +51       SET LEXTCOD=$GET(CODE)

           IF '$LENGTH(LEXTCOD)

               DO ERR(LEXERR)

               QUIT 

 +52       KILL X,Y

           DO SRA^LEX10CX2(LEXTCOD,LEXSAB,.LEXSRC)

 +53       DO CX(.LEXSRC)

 +54       QUIT 

EN3(CODE,SYS,ARY,MAX) ; Suggested Code (Code and Source are known, silent/GUI)

 +1       ;

 +2       ; Input

 +3       ; 

 +4       ;   CODE  Code (required)

 +5       ;   SYS   Coding System Abbreviation (required)

 +6       ;   ARY   Local Array passed by reference (required)

 +7       ;   MAX   Maximum # of suggestions (optional, default 100)

 +8       ; 

 +9       ; Output

 +10      ; 

 +11      ;   ARY   Array, passed by reference

 +12      ;     

 +13      ;         ARY("X")     Input

 +14      ;         ARY("Y",0)   Output   Number of Suggested Entries

 +15      ;         ARY("Y",1)   Output   First Suggestion

 +16      ;         ARY("Y",n)   Output   nth Suggestion

 +17      ;                         

 +18      ;         ARY("E")     Error message

 +19      ;

 +20      ;            Both ARY("X") and ARY("Y",#) are 4 piece "^"

 +21      ;            delimited strings:

 +22      ;                

 +23      ;               1  Internal Entry Number (IEN) file 757.01

 +24      ;               2  Expression (file 757.01, field .01)

 +25      ;               3  Code (file 757.02, field 1)

 +26      ;               4  Nomenclature (file 757.03, field 1)

 +27      ;                  i.e., SNOMED CT, ICD-9-CM or ICD-10-CM

 +28      ; 

 +29       NEW LEXC,LEX0FND,LEX0SEL,LEX0REV,LEXEFF,LEXI,LEXIT,LEXERR,LEXERRT,LEXEXP,LEXIEN,LEXLAD

 +30       NEW LEXNASK,LEXNASKM,LEXNOM,LEXQT,LEXSRC,LEXSRI,LEXTCOD,LEXTGT,LEXTMP,LEXTTXT,DIROUT

 +31       NEW DIRUT,DTOUT,DUOUT

           if +($GET(MAX))'>0

               SET MAX=100

           SET LEXNASK=1

           SET LEXNASKM=+($GET(MAX))

 +32       if +LEXNASKM'>0

               KILL LEXNASKM

           SET LEXQT=1

           SET LEXERRT=""

 +33       DO EN2($GET(CODE),$GET(SYS))

           SET LEXNOM=$$SRN("10D")

           KILL ARY

 +34       if $LENGTH(LEXERRT)

               SET ARY("E")=LEXERRT

           SET (LEXC,LEXI)=0

 +35       FOR 

               SET LEXI=$ORDER(LEXNASK(LEXI))

               if +LEXI'>0

                   QUIT 

               Begin DoDot:1

 +36               NEW LEXT

                   SET LEXT=$GET(LEXNASK(LEXI))

                   if '$LENGTH(LEXT)

                       QUIT 

 +37               if $LENGTH(LEXNOM)

                       SET $PIECE(LEXT,"^",4)=LEXNOM

 +38               SET LEXC=LEXC+1

                   if +($GET(LEXNASKM))>0&(LEXC>+($GET(LEXNASKM)))

                       QUIT 

 +39               SET ARY("Y",LEXC)=LEXT

                   SET ARY("Y",0)=LEXC

               End DoDot:1

 +40       IF +($GET(ARY("Y",0)))'>0

               Begin DoDot:1

 +41               SET LEXSRC=$GET(ARY("X"))

 +42               KILL ARY

                   SET ARY("Y",0)=0

 +43               if $LENGTH(LEXSRC)

                       SET ARY("X")=LEXSRC

               End DoDot:1

 +44       if $LENGTH(LEXERRT)

               SET ARY("E")=LEXERRT

 +45       if $LENGTH($GET(LEXNASK("X")))

               SET ARY("X")=$GET(LEXNASK("X"))

 +46       QUIT 

 +47      ;

CX(LEXSRC) ; Convert to ICD-10

 +1        SET LEXNOM=$GET(LEXSRC("SOURCE","SRC"))

 +2        IF '$DATA(LEXSRC("SOURCE"))

               Begin DoDot:1

 +3                DO ERR("Invalid code for coding system")

               End DoDot:1

               QUIT 

 +4        IF '$LENGTH(LEXNOM)

               Begin DoDot:1

 +5                DO ERR(("Invalid coding system passed "_$SELECT($LENGTH($GET(LEXNOM)):" - ",1:"")_LEXNOM))

               End DoDot:1

               QUIT 

 +6        SET LEXERR=LEXNOM_" code not selected"

 +7        SET LEXIEN=+($GET(LEXSRC("SOURCE","Y")))

 +8        IF +LEXIEN'>0

               DO ERR((LEXERR_" (IEN) "_LEXIEN))

               QUIT 

 +9        SET LEXEXP=$PIECE($GET(LEXSRC("SOURCE","Y")),"^",2)

 +10       IF '$LENGTH(LEXEXP)

               DO ERR((LEXERR_" (Expression) "))

               QUIT 

 +11       SET LEXERR="Invalid "_LEXNOM_" code selected"

 +12       SET LEXTCOD=$GET(LEXSRC("SOURCE","SOE"))

 +13       IF '$LENGTH(LEXTCOD)

               DO ERR((LEXERR_" (Code) "_LEXTCOD))

               QUIT 

 +14       IF '$DATA(^LEX(757.01,+LEXIEN,0))

               DO ERR((LEXERR_" (Expression) "))

               QUIT 

 +15       SET LEXERR="Invalid coding system"

 +16       SET LEXSAB=$GET(LEXSRC("SOURCE","SAB"))

 +17       IF '$LENGTH(LEXSAB)

               DO ERR((LEXERR_" (SAB) "_LEXSAB))

               QUIT 

 +18       SET LEXERR="Invalid "_LEXNOM_" code selected"

 +19       SET LEXLAD=$PIECE($$LA^LEX10CX5(LEXTCOD,LEXSAB),".",1)

 +20       IF LEXLAD'?7N

               DO ERR((LEXERR_" (Last Activation Date) "_LEXLAD))

               QUIT 

 +21       SET LEXEFF=$$FMADD^XLFDT(LEXLAD,3)

 +22       SET LEXERR="Invalid text for code"

 +23       SET LEXTTXT=$$UP^XLFSTR($GET(LEXSRC("SOURCE","EXP")))

 +24       IF '$LENGTH(LEXTTXT)

               DO ERR((LEXERR_" (Text) "))

               QUIT 

 +25       DO SEG^LEX10CX5(,.LEXSRC)

 +26       IF $ORDER(LEXSRC("SEG",0))'>0

               DO ERR((LEXERR_" (Segments) "))

               QUIT 

 +27       SET X=$$FIND1^LEX10CX3(LEXTCOD,.LEXSRC,.LEXTGT)

           if +X'>0

               SET X=""

 +28       IF +X'>0

               SET X=$$FIND2^LEX10CX3(LEXTTXT,.LEXSRC,.LEXTGT)

               if +X'>0

                   SET X=""

 +29       IF $GET(LEXNASK)>0

               Begin DoDot:1

 +30               NEW LEXI,LEXC

                   SET LEXC=0

                   FOR LEXI=1:1:100

                       if '$LENGTH($GET(LEXTGT(LEXI)))

                           QUIT 

                       Begin DoDot:2

 +31                       NEW LEXT

                           SET LEXT=$GET(LEXTGT(LEXI))

                           SET LEXC=LEXC+1

 +32                       IF +($GET(LEXNASKM))>0

                               IF +LEXC>+($GET(LEXNASKM))

                                   QUIT 

 +33                       SET LEXNASK(LEXC)=LEXT

                       End DoDot:2

 +34               IF $LENGTH($GET(LEXSRC("SOURCE","Y")),"^")=3

                       Begin DoDot:2

 +35                       NEW LEXT,LEX4

                           SET LEXT=$GET(LEXSRC("SOURCE","Y"))

 +36                       SET LEX4=$GET(LEXSRC("SOURCE","SRC"))

 +37                       if $LENGTH(LEX4)

                               SET $PIECE(LEXT,"^",4)=LEX4

 +38                       SET LEXNASK("X")=LEXT

                       End DoDot:2

 +39               IF $LENGTH($GET(LEXSRC("SOURCE","Y")),"^")'=3

                       Begin DoDot:2

 +40                       NEW LEX1,LEX2,LEX3,LEX4,LEXT

 +41                       SET LEX1=+($GET(LEXSRC("SOURCE","EXI")))

                           if LEX1'>0

                               QUIT 

 +42                       SET LEX2=$GET(LEXSRC("SOURCE","EXP"))

                           if '$LENGTH(LEX2)

                               QUIT 

 +43                       SET LEX3=$GET(LEXSRC("SOURCE","SOE"))

                           if '$LENGTH(LEX3)

                               QUIT 

 +44                       SET LEX4=$GET(LEXSRC("SOURCE","SRC"))

 +45                       SET LEXT=LEX1_"^"_LEX2_"^"_LEX3

 +46                       if $LENGTH(LEX4)

                               SET $PIECE(LEXT,"^",4)=LEX4

 +47                       SET LEXNASK("X")=LEXT

                       End DoDot:2

               End DoDot:1

               QUIT 

 +48       SET LEXIT=0

           IF +($GET(X))>0

               Begin DoDot:1

 +49               NEW DIR

                   KILL DIROUT,DIRUT,DUOUT,DTOUT

                   DO ASK^LEX10CX4(.LEXSRC,.LEXTGT)

 +50               IF $DATA(DIROUT)

                       SET (LEX0FND,LEX0REV,LEX0SEL)=0

                       SET LEXIT=1

 +51               if $GET(LEX0FND)>0&($GET(LEX0REV)>0)&('$LENGTH($GET(X)))

                       KILL DIROUT,DIRUT,DUOUT,DTOUT

 +52               IF $DATA(DIROUT)!($DATA(DIRUT))!($DATA(DUOUT))!($DATA(DTOUT))

                       Begin DoDot:2

 +53                       SET X="^"

                           SET Y=-1

                           if $DATA(DIROUT)

                               SET LEXIT=1

                       End DoDot:2

                       QUIT 

 +54               if +($GET(X))>0&(+($GET(Y))>0)

                       DO OUT($GET(X),$GET(Y))

 +55               if +($GET(X))>0&(+($GET(Y))>0)

                       SET LEXIT=1

 +56               if $GET(LEX0FND)>0&($GET(LEX0SEL)'>0)

                       SET LEXIT=0

 +57               IF +($GET(X))'>0!($GET(Y)=-1)

                       SET X=""

                       SET Y=-1

               End DoDot:1

               if LEXIT>0

                   QUIT 

 +58       IF $DATA(LEXTEST)

               Begin DoDot:1

 +59               if '$DATA(LEXQT)

                       WRITE !!

                   DO SA^LEX10CX5("LEXSRC")

 +60               if '$DATA(LEXQT)

                       WRITE !!

                   DO SA^LEX10CX5("LEXTGT")

                   NEW LEXTEST

               End DoDot:1

 +61       IF +X'>0

               Begin DoDot:1

 +62               SET X=$$FIND3^LEX10CX3(.LEXSRC,.LEXTGT)

                   if +X'>0

                       SET X=""

 +63               IF $GET(LEXTGT(0))=1

                       IF $LENGTH($GET(LEXTGT(1)))

                           Begin DoDot:2

 +64                           DO X^LEX10CX4(.LEXSRC)

                               DO Y^LEX10CX4(1,.LEXTGT)

 +65                           if +($GET(X))>0&(+($GET(Y))>0)

                                   DO OUT($GET(X),$GET(Y))

                           End DoDot:2

               End DoDot:1

 +66       if +($GET(X))'>0

               SET X=""

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

               SET Y=-1

 +67       QUIT 

OUT(X,Y)  ; Display Output - Interactive, Positive Results only

 +1        NEW LEXSI,LEXST,LEXSC,LEXSN,LEXSD,LEXTI,LEXTT,LEXTC,LEXTN

 +2        NEW LEXTD,LEXL,LEXI

           SET X=$GET(X)

           if +X'>0

               QUIT 

           SET Y=$GET(Y)

           if +Y'>0

               QUIT 

 +3        SET LEXSI=$PIECE(X,"^",1)

           if LEXSI'>0

               QUIT 

           SET LEXST(1)=$PIECE(X,"^",2)

           if '$LENGTH(LEXST(1))

               QUIT