Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LEX10CX3

LEX10CX3.m

Go to the documentation of this file. 
  1. LEX10CX3 ;ISL/KER - ICD-10 Cross-Over - Target (find) ;04/21/2014
  1.  ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
  1.  ;               
  1.  ; Global Variables
  1.  ;    ^TMP("LEXFND")      SACC 2.3.2.5.1
  1.  ;    ^TMP("LEXHIT")      SACC 2.3.2.5.1
  1.  ;    ^TMP("LEXSCH")      SACC 2.3.2.5.1
  1.  ;    ^TMP("LEXTMP")      SACC 2.3.2.5.1
  1.  ;               
  1.  ; External References
  1.  ;    $$CODEC^ICDEX       ICR   5747
  1.  ;    $$DT^XLFDT          ICR  10103
  1.  ;    $$FMADD^XLFDT       ICR  10103
  1.  ;    $$LA^ICDEX          ICR   5747
  1.  ;    $$OD^ICDEX          ICR   5747
  1.  ;    $$UP^XLFSTR         ICR  10104
  1.  ;    $$VLTD^ICDEX        ICR   5747
  1.  ;    ^DIC                ICR  10006
  1.  ;               
  1.  ; Local Variables NEWed or KILLed Elsewhere
  1.  ;     LEX0FND NEWed in LEX10CX
  1.  ;               
  1. FIND1(X,LEXSRC,LEXTGT) ; Find ICD-10 Codes based on Text Lookup
  1.  ;
  1.  ; Input
  1.  ; 
  1.  ;     X        Input Code
  1.  ;     LEXSRC   Local Array Source Code (passed by reference)
  1.  ;     LEXTGT   Local Array Target ICD-10 (passed by reference)
  1.  ; 
  1.  ; Output
  1.  ; 
  1.  ;     X        Number if ICD-10 Dx Codes found
  1.  ;              
  1.  ;     LEXSRC   Local Array ICD-9 (passed by reference)
  1.  ;     LEXTGT   Local Array (passed by reference)
  1.  ; 
  1.  ;                LEXTGT(0) = Number of ICD-10 Codes found
  1.  ;                LEXTGT(n) = Three piece "^" delimited string
  1.  ;                               1  Pointer to Expression file
  1.  ;                               2  Expression
  1.  ;                               3  ICD-10 Code
  1.  ; 
  1.  N DIC,DO,LEX,LEXCTR,LEXAI,LEXICDD,LEXIIEN,LEXMAX,LEXO,LEXOK
  1.  N LEXP,LEXS,LEXSO,LEXTD,LEXU,LEXU1,LEXUI,LEXVDT,LEXX,LEXXC,LEXXE
  1.  N LEXXI,LEXXT,Y S LEXMAX=+($G(LEXNASKM)) K DIC,DO,^TMP("LEXSCH",$J)
  1.  K ^TMP("LEXHIT",$J),^TMP("LEXFND",$J),^TMP("LEXTMP",$J,"FIND1")
  1.  Q:+($G(LEXSRC(0)))'>0 -1  S LEXSO=$G(X)
  1.  S LEXICDD=$$FMADD^XLFDT($$IMPDATE^LEXU("10D"),3)
  1.  S LEXTD=$$DT^XLFDT S:LEXTD>LEXICDD LEXICDD=LEXTD
  1.  S LEXAI=0 F  S LEXAI=$O(LEXSRC(LEXAI)) Q:+LEXAI'>0  D
  1.  . N LEXX,X,Y,DIC,LEXVDT,LEXXI,LEXXC,LEXXE,LEXU1,LEXUI,LEXOK
  1.  . S LEXVDT=$G(LEXICDD)
  1.  . S (LEXX,X)=$G(LEXSRC(LEXAI)) Q:'$L(X)
  1.  . D CONFIG^LEXSET("10D","10D",LEXVDT)
  1.  . S ^TMP("LEXSCH",$J,"DIS",0)="10D"
  1.  . S DIC("S")="I $L($$ONE^LEXU(+Y,+($G(LEXVDT)),""10D""))"
  1.  . S ^TMP("LEXSCH",$J,"FIL",0)=DIC("S")
  1.  . K LEX D LOOK^LEXA(LEXX,"LEX",100,"10D",$G(LEXVDT))
  1.  . S:$O(LEX("LIST",0))>0 LEX0FND=1
  1.  . S LEXU1=$$UP^XLFSTR($G(^LEX(757.01,+($G(LEX("LIST",1))),0)))
  1.  . S LEXUI=$$UP^XLFSTR(LEXX)
  1.  . I LEXU1=LEXUI S LEXOK=0 D  Q:LEXOK
  1.  . . N LEXXE,LEXXC,LEXIIEN S LEXXE=$G(LEX("LIST",1))
  1.  . . S LEXXC=$$EC(+LEXXE,"10D") Q:'$L(LEXXC)  S LEXOK=1
  1.  . . S ^TMP("LEXTMP",$J,"FIND1","SO",(LEXXC_" "))=LEXXE
  1.  . S LEXUI=$TR(LEXUI,"~`!@#$%^&*()_-+={}|[]\;':"",./<>?"," ")
  1.  . S LEXOK=0 S LEXXI=0 F  S LEXXI=$O(LEX("LIST",LEXXI)) Q:+LEXXI'>0  D
  1.  . . N LEXU,LEXXE,LEXXC,LEXIIEN,LEXS,LEXP S LEXXE=$G(LEX("LIST",LEXXI))
  1.  . . S LEXXC=$$EC(+LEXXE,"10D") Q:'$L(LEXXC)
  1.  . . S LEXU=$$UP^XLFSTR($G(^LEX(757.01,+LEXXE,0)))
  1.  . . S LEXU=$TR(LEXU,"~`!@#$%^&*()_-+={}|[]\;':"",./<>?"," ")
  1.  . . F LEXP=1:1 S LEXS=$P(LEXUI," ",LEXP) Q:'$L(LEXS)  D
  1.  . . . S LEXS=$$TM(LEXS) Q:'$L(LEXS)
  1.  . . . F  Q:LEXU'[LEXS  S LEXU=$P(LEXU,LEXS,1)_" "_$P(LEXU,LEXS,2,299)
  1.  . . S LEXU=$$TM(LEXU) I '$L(LEXU) D
  1.  . . . S LEXXC=$$EC(+LEXXE,"10D") Q:'$L(LEXXC)  S LEXOK=1
  1.  . . . S ^TMP("LEXTMP",$J,"FIND1","SO",(LEXXC_" "))=LEXXE
  1.  . Q:LEXOK  S LEXXI=0 F  S LEXXI=$O(LEX("LIST",LEXXI)) Q:+LEXXI'>0  D
  1.  . . N LEXXE,LEXXC,LEXIIEN
  1.  . . S LEXXE=$G(LEX("LIST",LEXXI))
  1.  . . S LEXXC=$$EC(+LEXXE,"10D") Q:'$L(LEXXC)
  1.  . . S ^TMP("LEXTMP",$J,"FIND1","SO",(LEXXC_" "))=LEXXE
  1.  K LEX,LEXTGT S LEXCTR=0,LEXO=0,LEXXC=""
  1.  F  S LEXXC=$O(^TMP("LEXTMP",$J,"FIND1","SO",LEXXC)) Q:'$L(LEXXC)  D
  1.  . N LEXXE,LEXXT,LEXXI
  1.  . S LEXXE=$G(^TMP("LEXTMP",$J,"FIND1","SO",LEXXC))
  1.  . Q:'$L(LEXXE)   Q:+LEXXE'>0  S LEXXT=$P(LEXXE,"^",2)
  1.  . S:LEXXT["(ICD-10-CM " LEXXT=$P(LEXXT," (ICD-10-CM ",1)
  1.  . S LEXXI=$O(LEXTGT(" "),-1)+1,LEXCTR=LEXCTR+1
  1.  . I +($G(LEXMAX))>0,LEXCTR>+($G(LEXMAX)) Q
  1.  . S LEXTGT(LEXXI)=+LEXXE_"^"_LEXXT_"^"_$TR(LEXXC," ","")
  1.  . S (LEXO,LEXTGT(0))=LEXXI
  1.  K ^TMP("LEXTMP",$J,"FIND1","SO")
  1.  K ^TMP("LEXSCH",$J),^TMP("LEXHIT",$J),^TMP("LEXFND",$J)
  1.  S X=+($G(LEXO)) S:X'>0 X=""
  1.  Q X
  1. FIND2(X,LEXSRC,LEXTGT) ; Find by margin
  1.  ;
  1.  ; Input        Same as $$FIND1
  1.  ; 
  1.  ; Output       Same as $$FIND1
  1.  ; 
  1.  N LEXCO,LEXCT,LEXCTR,LEXCTL,LEXF,LEXHI,LEXI,LEXICDD,LEXIEN,LEXKEY
  1.  N LEXLA,LEXLO,LEXMAX,LEXMX,LEXOR,LEXORD,LEXSEG,LEXSG,LEXSI,LEXSO
  1.  N LEXTD,LEXTX,LEXX S (LEXOR,LEXX)=$G(X),LEXOR=$$UP^XLFSTR(LEXOR)
  1.  S LEXICDD=$$FMADD^XLFDT($$IMPDATE^LEXU("10D"),3)
  1.  S LEXTD=$$DT^XLFDT S:LEXTD>LEXICDD LEXICDD=LEXTD
  1.  S LEXSI=0,LEXMAX=+($G(LEXNASKM)) I $O(LEXSRC("SEG",0))'>0 D
  1.  . N LEXSEG D SEGS^LEX10CX5(LEXX,1,.LEXSEG)
  1.  . S LEXI=0 F  S LEXI=$O(LEXSEG(LEXI)) Q:+LEXI'>0  D
  1.  . . N LEXSG S LEXSG=$G(LEXSEG(LEXI)) Q:'$L(LEXSG)
  1.  . . S LEXSI=$O(LEXSRC("SEG"," "),-1)+1
  1.  . . S LEXSRC("SEG",LEXSI)=LEXSG
  1.  I $O(LEXSRC("SEG",0))'>0 K LEXTGT Q -1
  1.  S LEXKEY=$G(LEXSRC("SEG",1)) I '$L(LEXKEY) K LEXTGT Q -1
  1.  K ^TMP("LEXTMP",$J,"FIND2") D FIND2B
  1.  I '$D(^TMP("LEXTMP",$J,"FIND2")),+($G(LEXSI))>2 D
  1.  . K ^TMP("LEXTMP",$J,"FIND2")
  1.  . S LEXKEY=$G(LEXSRC("SEG",2))
  1.  . D:$L(LEXKEY) FIND2B D:'$L(LEXKEY) FIND2C
  1.  S LEXLO=$O(^TMP("LEXTMP",$J,"FIND2","B",0))
  1.  S LEXHI=$O(^TMP("LEXTMP",$J,"FIND2","B"," "),-1)
  1.  S LEXMX=$O(LEXSRC("SEG"," "),-1)
  1.  S LEXCO=LEXMX S:LEXMX>0 LEXCO=$P(((LEXMX/5)*4),".",1)
  1.  S:LEXMX>0 LEXLO=$P((LEXMX/3),".",1)
  1.  S:LEXLO'<LEXCO LEXLO=LEXCO-1 S LEXF=0,LEXCTR=0
  1.  F  S LEXF=$O(^TMP("LEXTMP",$J,"FIND2","B",LEXF)) Q:+LEXF'>0  D
  1.  . Q:LEXF<LEXCO  N LEXI S LEXI=0
  1.  . F  S LEXI=$O(^TMP("LEXTMP",$J,"FIND2","B",LEXF,LEXI)) Q:+LEXI'>0  D
  1.  . . N LEXN,LEXT S LEXN=$O(LEXTGT(" "),-1)+1
  1.  . . S LEXT=$G(^TMP("LEXTMP",$J,"FIND2",LEXI,LEXF))
  1.  . . Q:'$L(LEXT)  S LEXCTR=LEXCTR+1
  1.  . . I +($G(LEXMAX))>0,LEXCTR>+($G(LEXNASKM)) Q
  1.  . . S LEXTGT(LEXN)=LEXT,LEXTGT(0)=LEXN
  1.  S X=$G(LEXTGT(0)) S:+X'>0 X=""
  1.  Q X
  1. FIND2B ;   Find by margin based on Keyword #n
  1.  N LEXORD S LEXORD=LEXKEY
  1.  F  S LEXORD=$$OD^ICDEX(80,LEXORD,30) Q:$P(LEXORD,"^",1)'=LEXKEY  D
  1.  . N LEXIEN,LEXLA,LEXTX,LEXSO,LEXF,LEXI,LEXSGI,LEXMX
  1.  . S LEXIEN=$P(LEXORD,"^",2) Q:+LEXIEN'>0
  1.  . S LEXLA=$$LA^ICDEX(80,LEXIEN,LEXICDD)
  1.  . Q:LEXLA'?7N  S LEXLA=$$FMADD^XLFDT(LEXLA,1)
  1.  . S LEXTX=$$UP^XLFSTR($$VLTD^ICDEX(LEXIEN,LEXLA))
  1.  . S LEXSO=$$CODEC^ICDEX(80,LEXIEN)
  1.  . S LEXF=0,LEXMX=$O(LEXSRC("SEG"," "),-1)
  1.  . F LEXSGI=1:1:LEXMX D
  1.  . . N LEXSG,LEXCT Q:$G(LEXSRC("SEG",1))=LEXKEY
  1.  . . S LEXSG=$$UP^XLFSTR($G(LEXSRC("SEG",LEXSGI))) Q:'$L(LEXSG)
  1.  . . S LEXCT=$$RN^LEX10CX5(LEXSG,LEXTX) I LEXCT>0 S LEXF=LEXF+1 Q
  1.  . . S LEXCT=$$TY^LEX10CX5(LEXOR,LEXTX) I LEXCT>0 S LEXF=LEXF+1 Q
  1.  . . I LEXTX[LEXSG S LEXF=LEXF+1
  1.  . ;I $G(LEXX)["WITHOUT" S:LEXTX'["WITHOUT"&(LEXTX["WITH ") LEXF=0
  1.  . I LEXF>0 D
  1.  . . N LEXT,LEXSTA,LEXSI,LEXEI,LEXEX S LEXT=""
  1.  . . S LEXSTA=$$STATCHK^LEXSRC2(LEXSO,LEXICDD,,"10D")
  1.  . . S LEXSI=$P(LEXSTA,"^",2),LEXEI=$P($G(^LEX(757.02,+LEXSI,0)),"^",1)
  1.  . . S LEXEX=$P($G(^LEX(757.01,+LEXEI,0)),"^",1)
  1.  . . S:LEXEI>0&($L(LEXEX)) LEXT=LEXEI_"^"_LEXEX_"^"_LEXSO
  1.  . . I $L(LEXT) D
  1.  . . . S ^TMP("LEXTMP",$J,"FIND2",LEXEI,LEXF)=LEXT
  1.  . . . S ^TMP("LEXTMP",$J,"FIND2","B",LEXF,LEXEI)=""
  1.  Q
  1. FIND2C ;   Find by margin based on single Keyword
  1.  Q:'$L($G(LEXSRC("SEG",1)))  Q:$O(LEXSRC("SEG",1))>1
  1.  N LEXORD S (LEXORD,LEXKEY)=$G(LEXSRC("SEG",1))
  1.  F  S LEXORD=$$OD^ICDEX(80,LEXORD,30) Q:$P(LEXORD,"^",1)'=LEXKEY  D
  1.  . N LEXIEN,LEXLA,LEXTX,LEXSO,LEXF,LEXI,LEXSGI,LEXMX
  1.  . S LEXIEN=$P(LEXORD,"^",2) Q:+LEXIEN'>0
  1.  . S LEXLA=$$LA^ICDEX(80,LEXIEN,LEXICDD)
  1.  . Q:LEXLA'?7N  S LEXLA=$$FMADD^XLFDT(LEXLA,1)
  1.  . S LEXTX=$$UP^XLFSTR($$VLTD^ICDEX(LEXIEN,LEXLA))
  1.  . S LEXSO=$$CODEC^ICDEX(80,LEXIEN) S LEXF=1
  1.  . I LEXF>0 D
  1.  . . N LEXT,LEXSTA,LEXSI,LEXEI,LEXEX S LEXT=""
  1.  . . S LEXSTA=$$STATCHK^LEXSRC2(LEXSO,LEXICDD,,"10D")
  1.  . . S LEXSI=$P(LEXSTA,"^",2),LEXEI=$P($G(^LEX(757.02,+LEXSI,0)),"^",1)
  1.  . . S LEXEX=$P($G(^LEX(757.01,+LEXEI,0)),"^",1)
  1.  . . S:LEXEI>0&($L(LEXEX)) LEXT=LEXEI_"^"_LEXEX_"^"_LEXSO
  1.  . . I $L(LEXT) D
  1.  . . . S ^TMP("LEXTMP",$J,"FIND2",LEXEI,LEXF)=LEXT
  1.  . . . S ^TMP("LEXTMP",$J,"FIND2","B",LEXF,LEXEI)=""
  1.  Q
  1.  ;
  1. FIND3(LEXSRC,LEXA) ; Source Array from Lookup
  1.  ;
  1.  ; Input
  1.  ; 
  1.  ;     LEXSRC   Local Array Source Code (passed by reference)
  1.  ;     LEXA     Local Array Target ICD-10 (passed by reference)
  1.  ; 
  1.  ; Output       Same as $$FIND1
  1.  ; 
  1.  N DIC,DO,LEXCDT,LEXEFF,LEXEX,LEXH,LEXHDR1,LEXHDR2,LEXI,LEXSRCC,LEXSRCS
  1.  N LEXSRCT,LEXIEN,LEXILA,LEXLA,LEXNOM,LEXQUIET,LEXS,LEXSO,LEXSRI,LEXSTA
  1.  N LEXTD,LEXTX,LEXVDT,X,Y S LEXSRCC=$G(LEXSRC("SOURCE","SOE"))
  1.  S LEXSRCS=$G(LEXSRC("SOURCE","SRC")),LEXSRCT=$G(LEXSRC("SOURCE","EXP"))
  1.  K LEXHDR1,LEXHDR2 S (LEXHDR1,LEXHDR2,LEXHDR2(1))="",LEXQUIET=1
  1.  I $G(LEX0FND)'>0 D
  1.  . S:$O(LEXSRC(0))>0 LEXHDR1(1)="Unable to suggest an ICD-10 code.",LEXHDR2=""
  1.  . 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
  1.  I $G(LEX0FND)>0 D
  1.  . S:$O(LEXSRC(0))>0 LEXHDR1(1)="No suggestions were selected, select an acceptable ICD-10 code.",LEXHDR2=""
  1.  . S:$L(LEXSRCC)&($L(LEXSRCS)) LEXHDR1(1)="No suggestions were selected, select an acceptable ICD-10 code",LEXHDR1(2)="for "_LEXSRCS_" code "_LEXSRCC
  1.  S:$L(LEXSRCC)&($L(LEXSRCS))&($L(LEXSRCT)) LEXHDR2(1)=LEXSRCT
  1.  D:$L(LEXHDR2(1)) PAR^LEX10CX4(.LEXHDR2,60)
  1.  W:$L($G(LEXHDR1(1))) !!," ",$G(LEXHDR1(1))
  1.  W:$L($G(LEXHDR1(2))) !," ",$G(LEXHDR1(2))
  1.  W:$L($G(LEXHDR2(1))) !!,"   ",$G(LEXHDR2(1))
  1.  W:$L($G(LEXHDR2(2))) !,"   ",$G(LEXHDR2(2))
  1.  W:$L($G(LEXHDR2(3))) !,"   ",$G(LEXHDR2(3))
  1.  S LEXCDT=$$FMADD^XLFDT($$IMPDATE^LEXU("10D"),3)
  1.  S LEXTD=$$DT^XLFDT S:LEXTD>LEXCDT LEXCDT=LEXTD
  1.  S LEXSAB="10D",LEXSRI=$O(^LEX(757.03,"ASAB",LEXSAB,0))
  1.  Q:+LEXSRI'>0!('$D(^LEX(757.03,+LEXSRI,0))) -1
  1.  S LEXNOM=$P($G(^LEX(757.03,+LEXSRI,0)),"^",2) Q:'$L(LEXNOM) -1
  1.  K LEXA S DIC("A")=" Enter "_LEXNOM_" code or text:  "
  1.  S DIC("S")="I $$SO^LEXU(Y,"""_LEXSAB_""",+($G(LEXCDT)))"
  1.  K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J),^TMP("LEXSCH",$J)
  1.  D CONFIG^LEXSET(LEXSAB,LEXSAB,LEXCDT)
  1.  S ^TMP("LEXSCH",$J,"DIS",0)=LEXSAB
  1.  S ^TMP("LEXSCH",$J,"FIL",0)=DIC("S")
  1.  S DIC(0)="AEQMZ",DIC="^LEX(757.01," K X
  1.  D ^DIC Q:+Y'>0 -1 S X="" I +Y>0 D
  1.  . K LEXA N LEXY,LEXIEN,LEXEX,LEXSO S LEXY=Y,Y=-1,LEXIEN=+LEXY
  1.  . S LEXEX=$P($G(^LEX(757.01,+LEXIEN,0)),"^",1) Q:'$L(LEXEX)
  1.  . S LEXSO=$$SO^LEX10CX5(LEXIEN,LEXSAB,LEXCDT) Q:'$L(LEXSO)
  1.  . S LEXA(1)=LEXIEN_"^"_LEXEX_"^"_LEXSO,LEXA(0)=1,Y=$G(LEXY)
  1.  K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J),^TMP("LEXSCH",$J)
  1.  S X="" S:+($G(LEXA(0)))>0 X=+($G(LEXA(0))) K LEXVDT
  1.  Q X
  1.  ;
  1.  ; Miscellaneous
  1. EC(X,Y) ;   Expression Code for SAB
  1.  N LEXC,LEXE,LEXN,LEXS,LEXSAB,LEXSRC
  1.  S LEXE=+($G(X)) Q:'$D(^LEX(757.01,+LEXE,0)) ""
  1.  Q:'$D(^LEX(757.02,"B",+LEXE)) ""
  1.  S LEXSAB=$G(Y) Q:'$L(LEXSAB) ""
  1.  S LEXSRC=$O(^LEX(757.03,"ASAB",LEXSAB,0))
  1.  I +LEXSRC'>0,LEXSAB?1N.N D
  1.  . S:$D(^LEX(757.03,+LEXSAB,0)) LEXSRC=+LEXSAB
  1.  Q:+LEXSRC'>0 ""  S LEXC="",LEXS=0
  1.  F  S LEXS=$O(^LEX(757.02,"B",LEXE,LEXS)) Q:+LEXS'>0  D
  1.  . Q:$L(LEXC)  N LEXN S LEXN=$G(^LEX(757.02,+LEXS,0))
  1.  . Q:$P(LEXN,"^",3)'=LEXSRC
  1.  . Q:$P(LEXN,"^",5)'=1  S LEXC=$P(LEXN,"^",2)
  1.  S X=LEXC
  1.  Q X
  1. TM(X,Y) ;   Trim Y
  1.  S X=$G(X),Y=$G(Y) S:'$L(Y) Y=" "
  1.  F  Q:$E(X,1)'=Y  S X=$E(X,2,$L(X))
  1.  F  Q:$E(X,$L(X))'=Y  S X=$E(X,1,($L(X)-1))
  1.  Q X