LEX10CX ;ISL/KER - ICD-10 Cross-Over - Main ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
;
; 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 PAR^LEX10CX4(.LEXST,(78-LEXL)),PAR^LEX10CX4(.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
LEX10CX ;ISL/KER - ICD-10 Cross-Over - Main ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
+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
+4 SET LEXSC=$PIECE(X,"^",3)
IF '$LENGTH(LEXSC)
QUIT
SET LEXSN=$PIECE(X,"^",4)
IF '$LENGTH(LEXSN)
QUIT
+5 SET LEXTI=$PIECE(Y,"^",1)
IF LEXTI'>0
QUIT
SET LEXTT(1)=$PIECE(Y,"^",2)
IF '$LENGTH(LEXTT(1))
QUIT
+6 SET LEXTC=$PIECE(Y,"^",3)
IF '$LENGTH(LEXTC)
QUIT
SET LEXTN=$PIECE(Y,"^",4)
IF '$LENGTH(LEXTN)
QUIT
+7 SET LEXSD=LEXSN_" "_LEXSC
SET LEXTD=LEXTN_" "_LEXTC
+8 SET LEXL=$LENGTH(LEXSD)+5
IF ($LENGTH(LEXTD)+5)>LEXL
SET LEXL=$LENGTH(LEXTD)+5
+9 DO PAR^LEX10CX4(.LEXST,(78-LEXL))
DO PAR^LEX10CX4(.LEXTT,(78-LEXL))
+10 IF '$DATA(LEXQT)
WRITE !!," ",LEXSD,?LEXL,$GET(LEXST(1))
+11 SET LEXI=1
FOR
SET LEXI=$ORDER(LEXST(LEXI))
IF +LEXI'>0
QUIT
Begin DoDot:1
+12 IF $LENGTH($GET(LEXST(LEXI)))
WRITE !,?LEXL,$GET(LEXST(LEXI))
End DoDot:1
+13 IF '$DATA(LEXQT)
WRITE !," ",LEXTD,?LEXL,$GET(LEXTT(1))
+14 SET LEXI=1
FOR
SET LEXI=$ORDER(LEXTT(LEXI))
IF +LEXI'>0
QUIT
Begin DoDot:1
+15 IF $LENGTH($GET(LEXTT(LEXI)))
WRITE !,?LEXL,$GET(LEXTT(LEXI))
End DoDot:1
+16 IF '$DATA(LEXQT)
WRITE !
+17 QUIT
ERR(X) ; Error
+1 IF '$LENGTH($GET(X))
QUIT
IF '$DATA(LEXQT)
WRITE !,?2,$GET(X),!
IF $DATA(LEXQT)
SET LEXERRT=$GET(X)
+2 QUIT
SAB(X) ; Resolve SAB to 3 character Abbreviation
+1 NEW LEXSAB,LEXCI,LEXCS
SET LEXCS=$GET(X)
IF '$LENGTH(LEXCS)
QUIT ""
+2 IF LEXCS?1N.N
IF $DATA(^LEX(757.03,+LEXCS,0))
QUIT $EXTRACT($GET(^LEX(757.03,+LEXCS,0)),1,3)
+3 SET LEXCI=$ORDER(^LEX(757.03,"B",$$UP^XLFSTR(LEXCS),0))
IF $DATA(^LEX(757.03,+LEXCI,0))
QUIT $EXTRACT($GET(^LEX(757.03,+LEXCI,0)),1,3)
+4 SET LEXCI=$ORDER(^LEX(757.03,"ASAB",$$UP^XLFSTR(LEXCS),0))
IF $DATA(^LEX(757.03,+LEXCI,0))
QUIT $EXTRACT($GET(^LEX(757.03,+LEXCI,0)),1,3)
+5 SET LEXCI=$ORDER(^LEX(757.03,"C",LEXCS,0))
IF $DATA(^LEX(757.03,+LEXCI,0))
QUIT $EXTRACT($GET(^LEX(757.03,+LEXCI,0)),1,3)
+6 QUIT ""
SRC(X) ; Resolve Source (pointer for SAB in 757.03)
+1 NEW LEXSAB,LEXCI,LEXCS
SET LEXCS=$GET(X)
IF '$LENGTH(LEXCS)
QUIT ""
SET LEXSAB=$$SAB(LEXCS)
IF $LENGTH(LEXSAB)'=3
QUIT ""
+2 SET X=$ORDER(^LEX(757.03,"ASAB",LEXSAB,0))
IF '$DATA(^LEX(757.03,+X,0))
SET X=""
+3 QUIT X
SRN(X) ; Resolve Source (pointer for SAB in 757.03)
+1 NEW LEXNOM,LEXCI,LEXCS
SET LEXCS=$GET(X)
IF '$LENGTH(LEXCS)
QUIT ""
SET LEXCI=$$SRC(LEXCS)
+2 IF '$DATA(^LEX(757.03,+LEXCI,0))
QUIT ""
SET X=$PIECE($GET(^LEX(757.03,+LEXCI,0)),"^",2)
+3 QUIT X
