LEX10CX3 ;ISL/KER - ICD-10 Cross-Over - Target (find) ;05/23/2017
;;2.0;LEXICON UTILITY;**80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^TMP("LEXFND") SACC 2.3.2.5.1
; ^TMP("LEXHIT") SACC 2.3.2.5.1
; ^TMP("LEXSCH") SACC 2.3.2.5.1
; ^TMP("LEXTMP") SACC 2.3.2.5.1
;
; External References
; $$CODEC^ICDEX ICR 5747
; $$DT^XLFDT ICR 10103
; $$FMADD^XLFDT ICR 10103
; $$LA^ICDEX ICR 5747
; $$OD^ICDEX ICR 5747
; $$UP^XLFSTR ICR 10104
; $$VLTD^ICDEX ICR 5747
; ^DIC ICR 10006
;
; Local Variables NEWed or KILLed Elsewhere
; LEX0FND NEWed in LEX10CX
;
FIND1(X,LEXSRC,LEXTGT) ; Find ICD-10 Codes based on Text Lookup
;
; Input
;
; X Input Code
; LEXSRC Local Array Source Code (passed by reference)
; LEXTGT Local Array Target ICD-10 (passed by reference)
;
; Output
;
; X Number if ICD-10 Dx Codes found
;
; LEXSRC Local Array ICD-9 (passed by reference)
; LEXTGT Local Array (passed by reference)
;
; LEXTGT(0) = Number of ICD-10 Codes found
; LEXTGT(n) = Three piece "^" delimited string
; 1 Pointer to Expression file
; 2 Expression
; 3 ICD-10 Code
;
N DIC,DO,LEX,LEXCTR,LEXAI,LEXICDD,LEXIIEN,LEXMAX,LEXO,LEXOK
N LEXP,LEXS,LEXSO,LEXTD,LEXU,LEXU1,LEXUI,LEXVDT,LEXX,LEXXC,LEXXE
N LEXXI,LEXXT,Y S LEXMAX=+($G(LEXNASKM)) K DIC,DO,^TMP("LEXSCH",$J)
K ^TMP("LEXHIT",$J),^TMP("LEXFND",$J),^TMP("LEXTMP",$J,"FIND1")
Q:+($G(LEXSRC(0)))'>0 -1 S LEXSO=$G(X)
S LEXICDD=$$FMADD^XLFDT($$IMPDATE^LEXU("10D"),3)
S LEXTD=$$DT^XLFDT S:LEXTD>LEXICDD LEXICDD=LEXTD
S LEXAI=0 F S LEXAI=$O(LEXSRC(LEXAI)) Q:+LEXAI'>0 D
. N LEXX,X,Y,DIC,LEXVDT,LEXXI,LEXXC,LEXXE,LEXU1,LEXUI,LEXOK
. S LEXVDT=$G(LEXICDD)
. S (LEXX,X)=$G(LEXSRC(LEXAI)) Q:'$L(X)
. D CONFIG^LEXSET("10D","10D",LEXVDT)
. S ^TMP("LEXSCH",$J,"DIS",0)="10D"
. S DIC("S")="I $L($$ONE^LEXU(+Y,+($G(LEXVDT)),""10D""))"
. S ^TMP("LEXSCH",$J,"FIL",0)=DIC("S")
. K LEX D LOOK^LEXA(LEXX,"LEX",100,"10D",$G(LEXVDT))
. S:$O(LEX("LIST",0))>0 LEX0FND=1
. S LEXU1=$$UP^XLFSTR($G(^LEX(757.01,+($G(LEX("LIST",1))),0)))
. S LEXUI=$$UP^XLFSTR(LEXX)
. I LEXU1=LEXUI S LEXOK=0 D Q:LEXOK
. . N LEXXE,LEXXC,LEXIIEN S LEXXE=$G(LEX("LIST",1))
. . S LEXXC=$$EC(+LEXXE,"10D") Q:'$L(LEXXC) S LEXOK=1
. . S ^TMP("LEXTMP",$J,"FIND1","SO",(LEXXC_" "))=LEXXE
. S LEXUI=$TR(LEXUI,"~`!@#$%^&*()_-+={}|[]\;':"",./<>?"," ")
. S LEXOK=0 S LEXXI=0 F S LEXXI=$O(LEX("LIST",LEXXI)) Q:+LEXXI'>0 D
. . N LEXU,LEXXE,LEXXC,LEXIIEN,LEXS,LEXP S LEXXE=$G(LEX("LIST",LEXXI))
. . S LEXXC=$$EC(+LEXXE,"10D") Q:'$L(LEXXC)
. . S LEXU=$$UP^XLFSTR($G(^LEX(757.01,+LEXXE,0)))
. . S LEXU=$TR(LEXU,"~`!@#$%^&*()_-+={}|[]\;':"",./<>?"," ")
. . F LEXP=1:1 S LEXS=$P(LEXUI," ",LEXP) Q:'$L(LEXS) D
. . . S LEXS=$$TM(LEXS) Q:'$L(LEXS)
. . . F Q:LEXU'[LEXS S LEXU=$P(LEXU,LEXS,1)_" "_$P(LEXU,LEXS,2,4000)
. . S LEXU=$$TM(LEXU) I '$L(LEXU) D
. . . S LEXXC=$$EC(+LEXXE,"10D") Q:'$L(LEXXC) S LEXOK=1
. . . S ^TMP("LEXTMP",$J,"FIND1","SO",(LEXXC_" "))=LEXXE
. Q:LEXOK S LEXXI=0 F S LEXXI=$O(LEX("LIST",LEXXI)) Q:+LEXXI'>0 D
. . N LEXXE,LEXXC,LEXIIEN
. . S LEXXE=$G(LEX("LIST",LEXXI))
. . S LEXXC=$$EC(+LEXXE,"10D") Q:'$L(LEXXC)
. . S ^TMP("LEXTMP",$J,"FIND1","SO",(LEXXC_" "))=LEXXE
K LEX,LEXTGT S LEXCTR=0,LEXO=0,LEXXC=""
F S LEXXC=$O(^TMP("LEXTMP",$J,"FIND1","SO",LEXXC)) Q:'$L(LEXXC) D
. N LEXXE,LEXXT,LEXXI
. S LEXXE=$G(^TMP("LEXTMP",$J,"FIND1","SO",LEXXC))
. Q:'$L(LEXXE) Q:+LEXXE'>0 S LEXXT=$P(LEXXE,"^",2)
. S:LEXXT["(ICD-10-CM " LEXXT=$P(LEXXT," (ICD-10-CM ",1)
. S LEXXI=$O(LEXTGT(" "),-1)+1,LEXCTR=LEXCTR+1
. I +($G(LEXMAX))>0,LEXCTR>+($G(LEXMAX)) Q
. S LEXTGT(LEXXI)=+LEXXE_"^"_LEXXT_"^"_$TR(LEXXC," ","")
. S (LEXO,LEXTGT(0))=LEXXI
K ^TMP("LEXTMP",$J,"FIND1","SO")
K ^TMP("LEXSCH",$J),^TMP("LEXHIT",$J),^TMP("LEXFND",$J)
S X=+($G(LEXO)) S:X'>0 X=""
Q X
FIND2(X,LEXSRC,LEXTGT) ; Find by margin
;
; Input Same as $$FIND1
;
; Output Same as $$FIND1
;
N LEXCO,LEXCT,LEXCTR,LEXCTL,LEXF,LEXHI,LEXI,LEXICDD,LEXIEN,LEXKEY
N LEXLA,LEXLO,LEXMAX,LEXMX,LEXOR,LEXORD,LEXSEG,LEXSG,LEXSI,LEXSO
N LEXTD,LEXTX,LEXX S (LEXOR,LEXX)=$G(X),LEXOR=$$UP^XLFSTR(LEXOR)
S LEXICDD=$$FMADD^XLFDT($$IMPDATE^LEXU("10D"),3)
S LEXTD=$$DT^XLFDT S:LEXTD>LEXICDD LEXICDD=LEXTD
S LEXSI=0,LEXMAX=+($G(LEXNASKM)) I $O(LEXSRC("SEG",0))'>0 D
. N LEXSEG D SEGS^LEX10CX5(LEXX,1,.LEXSEG)
. S LEXI=0 F S LEXI=$O(LEXSEG(LEXI)) Q:+LEXI'>0 D
. . N LEXSG S LEXSG=$G(LEXSEG(LEXI)) Q:'$L(LEXSG)
. . S LEXSI=$O(LEXSRC("SEG"," "),-1)+1
. . S LEXSRC("SEG",LEXSI)=LEXSG
I $O(LEXSRC("SEG",0))'>0 K LEXTGT Q -1
S LEXKEY=$G(LEXSRC("SEG",1)) I '$L(LEXKEY) K LEXTGT Q -1
K ^TMP("LEXTMP",$J,"FIND2") D FIND2B
I '$D(^TMP("LEXTMP",$J,"FIND2")),+($G(LEXSI))>2 D
. K ^TMP("LEXTMP",$J,"FIND2")
. S LEXKEY=$G(LEXSRC("SEG",2))
. D:$L(LEXKEY) FIND2B D:'$L(LEXKEY) FIND2C
S LEXLO=$O(^TMP("LEXTMP",$J,"FIND2","B",0))
S LEXHI=$O(^TMP("LEXTMP",$J,"FIND2","B"," "),-1)
S LEXMX=$O(LEXSRC("SEG"," "),-1)
S LEXCO=LEXMX S:LEXMX>0 LEXCO=$P(((LEXMX/5)*4),".",1)
S:LEXMX>0 LEXLO=$P((LEXMX/3),".",1)
S:LEXLO'<LEXCO LEXLO=LEXCO-1 S LEXF=0,LEXCTR=0
F S LEXF=$O(^TMP("LEXTMP",$J,"FIND2","B",LEXF)) Q:+LEXF'>0 D
. Q:LEXF<LEXCO N LEXI S LEXI=0
. F S LEXI=$O(^TMP("LEXTMP",$J,"FIND2","B",LEXF,LEXI)) Q:+LEXI'>0 D
. . N LEXN,LEXT S LEXN=$O(LEXTGT(" "),-1)+1
. . S LEXT=$G(^TMP("LEXTMP",$J,"FIND2",LEXI,LEXF))
. . Q:'$L(LEXT) S LEXCTR=LEXCTR+1
. . I +($G(LEXMAX))>0,LEXCTR>+($G(LEXNASKM)) Q
. . S LEXTGT(LEXN)=LEXT,LEXTGT(0)=LEXN
S X=$G(LEXTGT(0)) S:+X'>0 X=""
Q X
FIND2B ; Find by margin based on Keyword #n
N LEXORD S LEXORD=LEXKEY
F S LEXORD=$$OD^ICDEX(80,LEXORD,30) Q:$P(LEXORD,"^",1)'=LEXKEY D
. N LEXIEN,LEXLA,LEXTX,LEXSO,LEXF,LEXI,LEXSGI,LEXMX
. S LEXIEN=$P(LEXORD,"^",2) Q:+LEXIEN'>0
. S LEXLA=$$LA^ICDEX(80,LEXIEN,LEXICDD)
. Q:LEXLA'?7N S LEXLA=$$FMADD^XLFDT(LEXLA,1)
. S LEXTX=$$UP^XLFSTR($$VLTD^ICDEX(LEXIEN,LEXLA))
. S LEXSO=$$CODEC^ICDEX(80,LEXIEN)
. S LEXF=0,LEXMX=$O(LEXSRC("SEG"," "),-1)
. F LEXSGI=1:1:LEXMX D
. . N LEXSG,LEXCT Q:$G(LEXSRC("SEG",1))=LEXKEY
. . S LEXSG=$$UP^XLFSTR($G(LEXSRC("SEG",LEXSGI))) Q:'$L(LEXSG)
. . S LEXCT=$$RN^LEX10CX5(LEXSG,LEXTX) I LEXCT>0 S LEXF=LEXF+1 Q
. . S LEXCT=$$TY^LEX10CX5(LEXOR,LEXTX) I LEXCT>0 S LEXF=LEXF+1 Q
. . I LEXTX[LEXSG S LEXF=LEXF+1
. ;I $G(LEXX)["WITHOUT" S:LEXTX'["WITHOUT"&(LEXTX["WITH ") LEXF=0
. I LEXF>0 D
. . N LEXT,LEXSTA,LEXSI,LEXEI,LEXEX S LEXT=""
. . S LEXSTA=$$STATCHK^LEXSRC2(LEXSO,LEXICDD,,"10D")
. . S LEXSI=$P(LEXSTA,"^",2),LEXEI=$P($G(^LEX(757.02,+LEXSI,0)),"^",1)
. . S LEXEX=$P($G(^LEX(757.01,+LEXEI,0)),"^",1)
. . S:LEXEI>0&($L(LEXEX)) LEXT=LEXEI_"^"_LEXEX_"^"_LEXSO
. . I $L(LEXT) D
. . . S ^TMP("LEXTMP",$J,"FIND2",LEXEI,LEXF)=LEXT
. . . S ^TMP("LEXTMP",$J,"FIND2","B",LEXF,LEXEI)=""
Q
FIND2C ; Find by margin based on single Keyword
Q:'$L($G(LEXSRC("SEG",1))) Q:$O(LEXSRC("SEG",1))>1
N LEXORD S (LEXORD,LEXKEY)=$G(LEXSRC("SEG",1))
F S LEXORD=$$OD^ICDEX(80,LEXORD,30) Q:$P(LEXORD,"^",1)'=LEXKEY D
. N LEXIEN,LEXLA,LEXTX,LEXSO,LEXF,LEXI,LEXSGI,LEXMX
. S LEXIEN=$P(LEXORD,"^",2) Q:+LEXIEN'>0
. S LEXLA=$$LA^ICDEX(80,LEXIEN,LEXICDD)
. Q:LEXLA'?7N S LEXLA=$$FMADD^XLFDT(LEXLA,1)
. S LEXTX=$$UP^XLFSTR($$VLTD^ICDEX(LEXIEN,LEXLA))
. S LEXSO=$$CODEC^ICDEX(80,LEXIEN) S LEXF=1
. I LEXF>0 D
. . N LEXT,LEXSTA,LEXSI,LEXEI,LEXEX S LEXT=""
. . S LEXSTA=$$STATCHK^LEXSRC2(LEXSO,LEXICDD,,"10D")
. . S LEXSI=$P(LEXSTA,"^",2),LEXEI=$P($G(^LEX(757.02,+LEXSI,0)),"^",1)
. . S LEXEX=$P($G(^LEX(757.01,+LEXEI,0)),"^",1)
. . S:LEXEI>0&($L(LEXEX)) LEXT=LEXEI_"^"_LEXEX_"^"_LEXSO
. . I $L(LEXT) D
. . . S ^TMP("LEXTMP",$J,"FIND2",LEXEI,LEXF)=LEXT
. . . S ^TMP("LEXTMP",$J,"FIND2","B",LEXF,LEXEI)=""
Q
;
FIND3(LEXSRC,LEXA) ; Source Array from Lookup
;
; Input
;
; LEXSRC Local Array Source Code (passed by reference)
; LEXA Local Array Target ICD-10 (passed by reference)
;
; Output Same as $$FIND1
;
N DIC,DO,LEXCDT,LEXEFF,LEXEX,LEXH,LEXHDR1,LEXHDR2,LEXI,LEXSRCC,LEXSRCS
N LEXSRCT,LEXIEN,LEXILA,LEXLA,LEXNOM,LEXQUIET,LEXS,LEXSO,LEXSRI,LEXSTA
N LEXTD,LEXTX,LEXVDT,X,Y S LEXSRCC=$G(LEXSRC("SOURCE","SOE"))
S LEXSRCS=$G(LEXSRC("SOURCE","SRC")),LEXSRCT=$G(LEXSRC("SOURCE","EXP"))
K LEXHDR1,LEXHDR2 S (LEXHDR1,LEXHDR2,LEXHDR2(1))="",LEXQUIET=1
I $G(LEX0FND)'>0 D
. S:$O(LEXSRC(0))>0 LEXHDR1(1)="Unable to suggest an ICD-10 code.",LEXHDR2=""
. S:$L(LEXSRCC)&($L(LEXSRCS)) LEXHDR1(1)="Unable to suggest an ICD-10 code, search for an acceptable ICD-10",LEXHDR1(2)="code for "_LEXSRCS_" code "_LEXSRCC
I $G(LEX0FND)>0 D
. S:$O(LEXSRC(0))>0 LEXHDR1(1)="No suggestions were selected, select an acceptable ICD-10 code.",LEXHDR2=""
. S:$L(LEXSRCC)&($L(LEXSRCS)) LEXHDR1(1)="No suggestions were selected, select an acceptable ICD-10 code",LEXHDR1(2)="for "_LEXSRCS_" code "_LEXSRCC
S:$L(LEXSRCC)&($L(LEXSRCS))&($L(LEXSRCT)) LEXHDR2(1)=LEXSRCT
D:$L(LEXHDR2(1)) PR^LEXU(.LEXHDR2,60)
W:$L($G(LEXHDR1(1))) !!," ",$G(LEXHDR1(1))
W:$L($G(LEXHDR1(2))) !," ",$G(LEXHDR1(2))
W:$L($G(LEXHDR2(1))) !!," ",$G(LEXHDR2(1))
W:$L($G(LEXHDR2(2))) !," ",$G(LEXHDR2(2))
W:$L($G(LEXHDR2(3))) !," ",$G(LEXHDR2(3))
S LEXCDT=$$FMADD^XLFDT($$IMPDATE^LEXU("10D"),3)
S LEXTD=$$DT^XLFDT S:LEXTD>LEXCDT LEXCDT=LEXTD
S LEXSAB="10D",LEXSRI=$O(^LEX(757.03,"ASAB",LEXSAB,0))
Q:+LEXSRI'>0!('$D(^LEX(757.03,+LEXSRI,0))) -1
S LEXNOM=$P($G(^LEX(757.03,+LEXSRI,0)),"^",2) Q:'$L(LEXNOM) -1
K LEXA S DIC("A")=" Enter "_LEXNOM_" code or text: "
S DIC("S")="I $$SO^LEXU(Y,"""_LEXSAB_""",+($G(LEXCDT)))"
K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J),^TMP("LEXSCH",$J)
D CONFIG^LEXSET(LEXSAB,LEXSAB,LEXCDT)
S ^TMP("LEXSCH",$J,"DIS",0)=LEXSAB
S ^TMP("LEXSCH",$J,"FIL",0)=DIC("S")
S DIC(0)="AEQMZ",DIC="^LEX(757.01," K X
D ^DIC Q:+Y'>0 -1 S X="" I +Y>0 D
. K LEXA N LEXY,LEXIEN,LEXEX,LEXSO S LEXY=Y,Y=-1,LEXIEN=+LEXY
. S LEXEX=$P($G(^LEX(757.01,+LEXIEN,0)),"^",1) Q:'$L(LEXEX)
. S LEXSO=$$SO^LEX10CX5(LEXIEN,LEXSAB,LEXCDT) Q:'$L(LEXSO)
. S LEXA(1)=LEXIEN_"^"_LEXEX_"^"_LEXSO,LEXA(0)=1,Y=$G(LEXY)
K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J),^TMP("LEXSCH",$J)
S X="" S:+($G(LEXA(0)))>0 X=+($G(LEXA(0))) K LEXVDT
Q X
;
; Miscellaneous
EC(X,Y) ; Expression Code for SAB
N LEXC,LEXE,LEXN,LEXS,LEXSAB,LEXSRC
S LEXE=+($G(X)) Q:'$D(^LEX(757.01,+LEXE,0)) ""
Q:'$D(^LEX(757.02,"B",+LEXE)) ""
S LEXSAB=$G(Y) Q:'$L(LEXSAB) ""
S LEXSRC=$O(^LEX(757.03,"ASAB",LEXSAB,0))
I +LEXSRC'>0,LEXSAB?1N.N D
. S:$D(^LEX(757.03,+LEXSAB,0)) LEXSRC=+LEXSAB
Q:+LEXSRC'>0 "" S LEXC="",LEXS=0
F S LEXS=$O(^LEX(757.02,"B",LEXE,LEXS)) Q:+LEXS'>0 D
. Q:$L(LEXC) N LEXN S LEXN=$G(^LEX(757.02,+LEXS,0))
. Q:$P(LEXN,"^",3)'=LEXSRC
. Q:$P(LEXN,"^",5)'=1 S LEXC=$P(LEXN,"^",2)
S X=LEXC
Q X
TM(X,Y) ; Trim Y
S X=$G(X),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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEX10CX3 11353 printed Apr 09, 2024@21:10:57 Page 2
LEX10CX3 ;ISL/KER - ICD-10 Cross-Over - Target (find) ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXFND") SACC 2.3.2.5.1
+5 ; ^TMP("LEXHIT") SACC 2.3.2.5.1
+6 ; ^TMP("LEXSCH") SACC 2.3.2.5.1
+7 ; ^TMP("LEXTMP") SACC 2.3.2.5.1
+8 ;
+9 ; External References
+10 ; $$CODEC^ICDEX ICR 5747
+11 ; $$DT^XLFDT ICR 10103
+12 ; $$FMADD^XLFDT ICR 10103
+13 ; $$LA^ICDEX ICR 5747
+14 ; $$OD^ICDEX ICR 5747
+15 ; $$UP^XLFSTR ICR 10104
+16 ; $$VLTD^ICDEX ICR 5747
+17 ; ^DIC ICR 10006
+18 ;
+19 ; Local Variables NEWed or KILLed Elsewhere
+20 ; LEX0FND NEWed in LEX10CX
+21 ;
FIND1(X,LEXSRC,LEXTGT) ; Find ICD-10 Codes based on Text Lookup
+1 ;
+2 ; Input
+3 ;
+4 ; X Input Code
+5 ; LEXSRC Local Array Source Code (passed by reference)
+6 ; LEXTGT Local Array Target ICD-10 (passed by reference)
+7 ;
+8 ; Output
+9 ;
+10 ; X Number if ICD-10 Dx Codes found
+11 ;
+12 ; LEXSRC Local Array ICD-9 (passed by reference)
+13 ; LEXTGT Local Array (passed by reference)
+14 ;
+15 ; LEXTGT(0) = Number of ICD-10 Codes found
+16 ; LEXTGT(n) = Three piece "^" delimited string
+17 ; 1 Pointer to Expression file
+18 ; 2 Expression
+19 ; 3 ICD-10 Code
+20 ;
+21 NEW DIC,DO,LEX,LEXCTR,LEXAI,LEXICDD,LEXIIEN,LEXMAX,LEXO,LEXOK
+22 NEW LEXP,LEXS,LEXSO,LEXTD,LEXU,LEXU1,LEXUI,LEXVDT,LEXX,LEXXC,LEXXE
+23 NEW LEXXI,LEXXT,Y
SET LEXMAX=+($GET(LEXNASKM))
KILL DIC,DO,^TMP("LEXSCH",$JOB)
+24 KILL ^TMP("LEXHIT",$JOB),^TMP("LEXFND",$JOB),^TMP("LEXTMP",$JOB,"FIND1")
+25 if +($GET(LEXSRC(0)))'>0
QUIT -1
SET LEXSO=$GET(X)
+26 SET LEXICDD=$$FMADD^XLFDT($$IMPDATE^LEXU("10D"),3)
+27 SET LEXTD=$$DT^XLFDT
if LEXTD>LEXICDD
SET LEXICDD=LEXTD
+28 SET LEXAI=0
FOR
SET LEXAI=$ORDER(LEXSRC(LEXAI))
if +LEXAI'>0
QUIT
Begin DoDot:1
+29 NEW LEXX,X,Y,DIC,LEXVDT,LEXXI,LEXXC,LEXXE,LEXU1,LEXUI,LEXOK
+30 SET LEXVDT=$GET(LEXICDD)
+31 SET (LEXX,X)=$GET(LEXSRC(LEXAI))
if '$LENGTH(X)
QUIT
+32 DO CONFIG^LEXSET("10D","10D",LEXVDT)
+33 SET ^TMP("LEXSCH",$JOB,"DIS",0)="10D"
+34 SET DIC("S")="I $L($$ONE^LEXU(+Y,+($G(LEXVDT)),""10D""))"
+35 SET ^TMP("LEXSCH",$JOB,"FIL",0)=DIC("S")
+36 KILL LEX
DO LOOK^LEXA(LEXX,"LEX",100,"10D",$GET(LEXVDT))
+37 if $ORDER(LEX("LIST",0))>0
SET LEX0FND=1
+38 SET LEXU1=$$UP^XLFSTR($GET(^LEX(757.01,+($GET(LEX("LIST",1))),0)))
+39 SET LEXUI=$$UP^XLFSTR(LEXX)
+40 IF LEXU1=LEXUI
SET LEXOK=0
Begin DoDot:2
+41 NEW LEXXE,LEXXC,LEXIIEN
SET LEXXE=$GET(LEX("LIST",1))
+42 SET LEXXC=$$EC(+LEXXE,"10D")
if '$LENGTH(LEXXC)
QUIT
SET LEXOK=1
+43 SET ^TMP("LEXTMP",$JOB,"FIND1","SO",(LEXXC_" "))=LEXXE
End DoDot:2
if LEXOK
QUIT
+44 SET LEXUI=$TRANSLATE(LEXUI,"~`!@#$%^&*()_-+={}|[]\;':"",./<>?"," ")
+45 SET LEXOK=0
SET LEXXI=0
FOR
SET LEXXI=$ORDER(LEX("LIST",LEXXI))
if +LEXXI'>0
QUIT
Begin DoDot:2
+46 NEW LEXU,LEXXE,LEXXC,LEXIIEN,LEXS,LEXP
SET LEXXE=$GET(LEX("LIST",LEXXI))
+47 SET LEXXC=$$EC(+LEXXE,"10D")
if '$LENGTH(LEXXC)
QUIT
+48 SET LEXU=$$UP^XLFSTR($GET(^LEX(757.01,+LEXXE,0)))
+49 SET LEXU=$TRANSLATE(LEXU,"~`!@#$%^&*()_-+={}|[]\;':"",./<>?"," ")
+50 FOR LEXP=1:1
SET LEXS=$PIECE(LEXUI," ",LEXP)
if '$LENGTH(LEXS)
QUIT
Begin DoDot:3
+51 SET LEXS=$$TM(LEXS)
if '$LENGTH(LEXS)
QUIT
+52 FOR
if LEXU'[LEXS
QUIT
SET LEXU=$PIECE(LEXU,LEXS,1)_" "_$PIECE(LEXU,LEXS,2,4000)
End DoDot:3
+53 SET LEXU=$$TM(LEXU)
IF '$LENGTH(LEXU)
Begin DoDot:3
+54 SET LEXXC=$$EC(+LEXXE,"10D")
if '$LENGTH(LEXXC)
QUIT
SET LEXOK=1
+55 SET ^TMP("LEXTMP",$JOB,"FIND1","SO",(LEXXC_" "))=LEXXE
End DoDot:3
End DoDot:2
+56 if LEXOK
QUIT
SET LEXXI=0
FOR
SET LEXXI=$ORDER(LEX("LIST",LEXXI))
if +LEXXI'>0
QUIT
Begin DoDot:2
+57 NEW LEXXE,LEXXC,LEXIIEN
+58 SET LEXXE=$GET(LEX("LIST",LEXXI))
+59 SET LEXXC=$$EC(+LEXXE,"10D")
if '$LENGTH(LEXXC)
QUIT
+60 SET ^TMP("LEXTMP",$JOB,"FIND1","SO",(LEXXC_" "))=LEXXE
End DoDot:2
End DoDot:1
+61 KILL LEX,LEXTGT
SET LEXCTR=0
SET LEXO=0
SET LEXXC=""
+62 FOR
SET LEXXC=$ORDER(^TMP("LEXTMP",$JOB,"FIND1","SO",LEXXC))
if '$LENGTH(LEXXC)
QUIT
Begin DoDot:1
+63 NEW LEXXE,LEXXT,LEXXI
+64 SET LEXXE=$GET(^TMP("LEXTMP",$JOB,"FIND1","SO",LEXXC))
+65 if '$LENGTH(LEXXE)
QUIT
if +LEXXE'>0
QUIT
SET LEXXT=$PIECE(LEXXE,"^",2)
+66 if LEXXT["(ICD-10-CM "
SET LEXXT=$PIECE(LEXXT," (ICD-10-CM ",1)
+67 SET LEXXI=$ORDER(LEXTGT(" "),-1)+1
SET LEXCTR=LEXCTR+1
+68 IF +($GET(LEXMAX))>0
IF LEXCTR>+($GET(LEXMAX))
QUIT
+69 SET LEXTGT(LEXXI)=+LEXXE_"^"_LEXXT_"^"_$TRANSLATE(LEXXC," ","")
+70 SET (LEXO,LEXTGT(0))=LEXXI
End DoDot:1
+71 KILL ^TMP("LEXTMP",$JOB,"FIND1","SO")
+72 KILL ^TMP("LEXSCH",$JOB),^TMP("LEXHIT",$JOB),^TMP("LEXFND",$JOB)
+73 SET X=+($GET(LEXO))
if X'>0
SET X=""
+74 QUIT X
FIND2(X,LEXSRC,LEXTGT) ; Find by margin
+1 ;
+2 ; Input Same as $$FIND1
+3 ;
+4 ; Output Same as $$FIND1
+5 ;
+6 NEW LEXCO,LEXCT,LEXCTR,LEXCTL,LEXF,LEXHI,LEXI,LEXICDD,LEXIEN,LEXKEY
+7 NEW LEXLA,LEXLO,LEXMAX,LEXMX,LEXOR,LEXORD,LEXSEG,LEXSG,LEXSI,LEXSO
+8 NEW LEXTD,LEXTX,LEXX
SET (LEXOR,LEXX)=$GET(X)
SET LEXOR=$$UP^XLFSTR(LEXOR)
+9 SET LEXICDD=$$FMADD^XLFDT($$IMPDATE^LEXU("10D"),3)
+10 SET LEXTD=$$DT^XLFDT
if LEXTD>LEXICDD
SET LEXICDD=LEXTD
+11 SET LEXSI=0
SET LEXMAX=+($GET(LEXNASKM))
IF $ORDER(LEXSRC("SEG",0))'>0
Begin DoDot:1
+12 NEW LEXSEG
DO SEGS^LEX10CX5(LEXX,1,.LEXSEG)
+13 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXSEG(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+14 NEW LEXSG
SET LEXSG=$GET(LEXSEG(LEXI))
if '$LENGTH(LEXSG)
QUIT
+15 SET LEXSI=$ORDER(LEXSRC("SEG"," "),-1)+1
+16 SET LEXSRC("SEG",LEXSI)=LEXSG
End DoDot:2
End DoDot:1
+17 IF $ORDER(LEXSRC("SEG",0))'>0
KILL LEXTGT
QUIT -1
+18 SET LEXKEY=$GET(LEXSRC("SEG",1))
IF '$LENGTH(LEXKEY)
KILL LEXTGT
QUIT -1
+19 KILL ^TMP("LEXTMP",$JOB,"FIND2")
DO FIND2B
+20 IF '$DATA(^TMP("LEXTMP",$JOB,"FIND2"))
IF +($GET(LEXSI))>2
Begin DoDot:1
+21 KILL ^TMP("LEXTMP",$JOB,"FIND2")
+22 SET LEXKEY=$GET(LEXSRC("SEG",2))
+23 if $LENGTH(LEXKEY)
DO FIND2B
if '$LENGTH(LEXKEY)
DO FIND2C
End DoDot:1
+24 SET LEXLO=$ORDER(^TMP("LEXTMP",$JOB,"FIND2","B",0))
+25 SET LEXHI=$ORDER(^TMP("LEXTMP",$JOB,"FIND2","B"," "),-1)
+26 SET LEXMX=$ORDER(LEXSRC("SEG"," "),-1)
+27 SET LEXCO=LEXMX
if LEXMX>0
SET LEXCO=$PIECE(((LEXMX/5)*4),".",1)
+28 if LEXMX>0
SET LEXLO=$PIECE((LEXMX/3),".",1)
+29 if LEXLO'<LEXCO
SET LEXLO=LEXCO-1
SET LEXF=0
SET LEXCTR=0
+30 FOR
SET LEXF=$ORDER(^TMP("LEXTMP",$JOB,"FIND2","B",LEXF))
if +LEXF'>0
QUIT
Begin DoDot:1
+31 if LEXF<LEXCO
QUIT
NEW LEXI
SET LEXI=0
+32 FOR
SET LEXI=$ORDER(^TMP("LEXTMP",$JOB,"FIND2","B",LEXF,LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+33 NEW LEXN,LEXT
SET LEXN=$ORDER(LEXTGT(" "),-1)+1
+34 SET LEXT=$GET(^TMP("LEXTMP",$JOB,"FIND2",LEXI,LEXF))
+35 if '$LENGTH(LEXT)
QUIT
SET LEXCTR=LEXCTR+1
+36 IF +($GET(LEXMAX))>0
IF LEXCTR>+($GET(LEXNASKM))
QUIT
+37 SET LEXTGT(LEXN)=LEXT
SET LEXTGT(0)=LEXN
End DoDot:2
End DoDot:1
+38 SET X=$GET(LEXTGT(0))
if +X'>0
SET X=""
+39 QUIT X
FIND2B ; Find by margin based on Keyword #n
+1 NEW LEXORD
SET LEXORD=LEXKEY
+2 FOR
SET LEXORD=$$OD^ICDEX(80,LEXORD,30)
if $PIECE(LEXORD,"^",1)'=LEXKEY
QUIT
Begin DoDot:1
+3 NEW LEXIEN,LEXLA,LEXTX,LEXSO,LEXF,LEXI,LEXSGI,LEXMX
+4 SET LEXIEN=$PIECE(LEXORD,"^",2)
if +LEXIEN'>0
QUIT
+5 SET LEXLA=$$LA^ICDEX(80,LEXIEN,LEXICDD)
+6 if LEXLA'?7N
QUIT
SET LEXLA=$$FMADD^XLFDT(LEXLA,1)
+7 SET LEXTX=$$UP^XLFSTR($$VLTD^ICDEX(LEXIEN,LEXLA))
+8 SET LEXSO=$$CODEC^ICDEX(80,LEXIEN)
+9 SET LEXF=0
SET LEXMX=$ORDER(LEXSRC("SEG"," "),-1)
+10 FOR LEXSGI=1:1:LEXMX
Begin DoDot:2
+11 NEW LEXSG,LEXCT
if $GET(LEXSRC("SEG",1))=LEXKEY
QUIT
+12 SET LEXSG=$$UP^XLFSTR($GET(LEXSRC("SEG",LEXSGI)))
if '$LENGTH(LEXSG)
QUIT
+13 SET LEXCT=$$RN^LEX10CX5(LEXSG,LEXTX)
IF LEXCT>0
SET LEXF=LEXF+1
QUIT
+14 SET LEXCT=$$TY^LEX10CX5(LEXOR,LEXTX)
IF LEXCT>0
SET LEXF=LEXF+1
QUIT
+15 IF LEXTX[LEXSG
SET LEXF=LEXF+1
End DoDot:2
+16 ;I $G(LEXX)["WITHOUT" S:LEXTX'["WITHOUT"&(LEXTX["WITH ") LEXF=0
+17 IF LEXF>0
Begin DoDot:2
+18 NEW LEXT,LEXSTA,LEXSI,LEXEI,LEXEX
SET LEXT=""
+19 SET LEXSTA=$$STATCHK^LEXSRC2(LEXSO,LEXICDD,,"10D")
+20 SET LEXSI=$PIECE(LEXSTA,"^",2)
SET LEXEI=$PIECE($GET(^LEX(757.02,+LEXSI,0)),"^",1)
+21 SET LEXEX=$PIECE($GET(^LEX(757.01,+LEXEI,0)),"^",1)
+22 if LEXEI>0&($LENGTH(LEXEX))
SET LEXT=LEXEI_"^"_LEXEX_"^"_LEXSO
+23 IF $LENGTH(LEXT)
Begin DoDot:3
+24 SET ^TMP("LEXTMP",$JOB,"FIND2",LEXEI,LEXF)=LEXT
+25 SET ^TMP("LEXTMP",$JOB,"FIND2","B",LEXF,LEXEI)=""
End DoDot:3
End DoDot:2
End DoDot:1
+26 QUIT
FIND2C ; Find by margin based on single Keyword
+1 if '$LENGTH($GET(LEXSRC("SEG",1)))
QUIT
if $ORDER(LEXSRC("SEG",1))>1
QUIT
+2 NEW LEXORD
SET (LEXORD,LEXKEY)=$GET(LEXSRC("SEG",1))
+3 FOR
SET LEXORD=$$OD^ICDEX(80,LEXORD,30)
if $PIECE(LEXORD,"^",1)'=LEXKEY
QUIT
Begin DoDot:1
+4 NEW LEXIEN,LEXLA,LEXTX,LEXSO,LEXF,LEXI,LEXSGI,LEXMX
+5 SET LEXIEN=$PIECE(LEXORD,"^",2)
if +LEXIEN'>0
QUIT
+6 SET LEXLA=$$LA^ICDEX(80,LEXIEN,LEXICDD)
+7 if LEXLA'?7N
QUIT
SET LEXLA=$$FMADD^XLFDT(LEXLA,1)
+8 SET LEXTX=$$UP^XLFSTR($$VLTD^ICDEX(LEXIEN,LEXLA))
+9 SET LEXSO=$$CODEC^ICDEX(80,LEXIEN)
SET LEXF=1
+10 IF LEXF>0
Begin DoDot:2
+11 NEW LEXT,LEXSTA,LEXSI,LEXEI,LEXEX
SET LEXT=""
+12 SET LEXSTA=$$STATCHK^LEXSRC2(LEXSO,LEXICDD,,"10D")
+13 SET LEXSI=$PIECE(LEXSTA,"^",2)
SET LEXEI=$PIECE($GET(^LEX(757.02,+LEXSI,0)),"^",1)
+14 SET LEXEX=$PIECE($GET(^LEX(757.01,+LEXEI,0)),"^",1)
+15 if LEXEI>0&($LENGTH(LEXEX))
SET LEXT=LEXEI_"^"_LEXEX_"^"_LEXSO
+16 IF $LENGTH(LEXT)
Begin DoDot:3
+17 SET ^TMP("LEXTMP",$JOB,"FIND2",LEXEI,LEXF)=LEXT
+18 SET ^TMP("LEXTMP",$JOB,"FIND2","B",LEXF,LEXEI)=""
End DoDot:3
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
FIND3(LEXSRC,LEXA) ; Source Array from Lookup
+1 ;
+2 ; Input
+3 ;
+4 ; LEXSRC Local Array Source Code (passed by reference)
+5 ; LEXA Local Array Target ICD-10 (passed by reference)
+6 ;
+7 ; Output Same as $$FIND1
+8 ;
+9 NEW DIC,DO,LEXCDT,LEXEFF,LEXEX,LEXH,LEXHDR1,LEXHDR2,LEXI,LEXSRCC,LEXSRCS
+10 NEW LEXSRCT,LEXIEN,LEXILA,LEXLA,LEXNOM,LEXQUIET,LEXS,LEXSO,LEXSRI,LEXSTA
+11 NEW LEXTD,LEXTX,LEXVDT,X,Y
SET LEXSRCC=$GET(LEXSRC("SOURCE","SOE"))
+12 SET LEXSRCS=$GET(LEXSRC("SOURCE","SRC"))
SET LEXSRCT=$GET(LEXSRC("SOURCE","EXP"))
+13 KILL LEXHDR1,LEXHDR2
SET (LEXHDR1,LEXHDR2,LEXHDR2(1))=""
SET LEXQUIET=1
+14 IF $GET(LEX0FND)'>0
Begin DoDot:1
+15 if $ORDER(LEXSRC(0))>0
SET LEXHDR1(1)="Unable to suggest an ICD-10 code."
SET LEXHDR2=""
+16 if $LENGTH(LEXSRCC)&($LENGTH(LEXSRCS))
SET LEXHDR1(1)="Unable to suggest an ICD-10 code, search for an acceptable ICD-10"
SET LEXHDR1(2)="code for "_LEXSRCS_" code "_LEXSRCC
End DoDot:1
+17 IF $GET(LEX0FND)>0
Begin DoDot:1
+18 if $ORDER(LEXSRC(0))>0
SET LEXHDR1(1)="No suggestions were selected, select an acceptable ICD-10 code."
SET LEXHDR2=""
+19 if $LENGTH(LEXSRCC)&($LENGTH(LEXSRCS))
SET LEXHDR1(1)="No suggestions were selected, select an acceptable ICD-10 code"
SET LEXHDR1(2)="for "_LEXSRCS_" code "_LEXSRCC
End DoDot:1
+20 if $LENGTH(LEXSRCC)&($LENGTH(LEXSRCS))&($LENGTH(LEXSRCT))
SET LEXHDR2(1)=LEXSRCT
+21 if $LENGTH(LEXHDR2(1))
DO PR^LEXU(.LEXHDR2,60)
+22 if $LENGTH($GET(LEXHDR1(1)))
WRITE !!," ",$GET(LEXHDR1(1))
+23 if $LENGTH($GET(LEXHDR1(2)))
WRITE !," ",$GET(LEXHDR1(2))
+24 if $LENGTH($GET(LEXHDR2(1)))
WRITE !!," ",$GET(LEXHDR2(1))
+25 if $LENGTH($GET(LEXHDR2(2)))
WRITE !," ",$GET(LEXHDR2(2))
+26 if $LENGTH($GET(LEXHDR2(3)))
WRITE !," ",$GET(LEXHDR2(3))
+27 SET LEXCDT=$$FMADD^XLFDT($$IMPDATE^LEXU("10D"),3)
+28 SET LEXTD=$$DT^XLFDT
if LEXTD>LEXCDT
SET LEXCDT=LEXTD
+29 SET LEXSAB="10D"
SET LEXSRI=$ORDER(^LEX(757.03,"ASAB",LEXSAB,0))
+30 if +LEXSRI'>0!('$DATA(^LEX(757.03,+LEXSRI,0)))
QUIT -1
+31 SET LEXNOM=$PIECE($GET(^LEX(757.03,+LEXSRI,0)),"^",2)
if '$LENGTH(LEXNOM)
QUIT -1
+32 KILL LEXA
SET DIC("A")=" Enter "_LEXNOM_" code or text: "
+33 SET DIC("S")="I $$SO^LEXU(Y,"""_LEXSAB_""",+($G(LEXCDT)))"
+34 KILL ^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB),^TMP("LEXSCH",$JOB)
+35 DO CONFIG^LEXSET(LEXSAB,LEXSAB,LEXCDT)
+36 SET ^TMP("LEXSCH",$JOB,"DIS",0)=LEXSAB
+37 SET ^TMP("LEXSCH",$JOB,"FIL",0)=DIC("S")
+38 SET DIC(0)="AEQMZ"
SET DIC="^LEX(757.01,"
KILL X
+39 DO ^DIC
if +Y'>0
QUIT -1
SET X=""
IF +Y>0
Begin DoDot:1
+40 KILL LEXA
NEW LEXY,LEXIEN,LEXEX,LEXSO
SET LEXY=Y
SET Y=-1
SET LEXIEN=+LEXY
+41 SET LEXEX=$PIECE($GET(^LEX(757.01,+LEXIEN,0)),"^",1)
if '$LENGTH(LEXEX)
QUIT
+42 SET LEXSO=$$SO^LEX10CX5(LEXIEN,LEXSAB,LEXCDT)
if '$LENGTH(LEXSO)
QUIT
+43 SET LEXA(1)=LEXIEN_"^"_LEXEX_"^"_LEXSO
SET LEXA(0)=1
SET Y=$GET(LEXY)
End DoDot:1
+44 KILL ^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB),^TMP("LEXSCH",$JOB)
+45 SET X=""
if +($GET(LEXA(0)))>0
SET X=+($GET(LEXA(0)))
KILL LEXVDT
+46 QUIT X
+47 ;
+48 ; Miscellaneous
EC(X,Y) ; Expression Code for SAB
+1 NEW LEXC,LEXE,LEXN,LEXS,LEXSAB,LEXSRC
+2 SET LEXE=+($GET(X))
if '$DATA(^LEX(757.01,+LEXE,0))
QUIT ""
+3 if '$DATA(^LEX(757.02,"B",+LEXE))
QUIT ""
+4 SET LEXSAB=$GET(Y)
if '$LENGTH(LEXSAB)
QUIT ""
+5 SET LEXSRC=$ORDER(^LEX(757.03,"ASAB",LEXSAB,0))
+6 IF +LEXSRC'>0
IF LEXSAB?1N.N
Begin DoDot:1
+7 if $DATA(^LEX(757.03,+LEXSAB,0))
SET LEXSRC=+LEXSAB
End DoDot:1
+8 if +LEXSRC'>0
QUIT ""
SET LEXC=""
SET LEXS=0
+9 FOR
SET LEXS=$ORDER(^LEX(757.02,"B",LEXE,LEXS))
if +LEXS'>0
QUIT
Begin DoDot:1
+10 if $LENGTH(LEXC)
QUIT
NEW LEXN
SET LEXN=$GET(^LEX(757.02,+LEXS,0))
+11 if $PIECE(LEXN,"^",3)'=LEXSRC
QUIT
+12 if $PIECE(LEXN,"^",5)'=1
QUIT
SET LEXC=$PIECE(LEXN,"^",2)
End DoDot:1
+13 SET X=LEXC
+14 QUIT X
TM(X,Y) ; Trim Y
+1 SET X=$GET(X)
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
