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

LEX10CS.m

Go to the documentation of this file.
  1. LEX10CS ;ISL/KER - ICD-10 Code Set ;11/16/2016
  1. ;;2.0;LEXICON UTILITY;**80,110**;Sep 23, 1996;Build 6
  1. ;
  1. ; Global Variables
  1. ; ^LEX(757.033 N/A
  1. ; ^TMP("LEXDX") SACC 2.3.2.5.1
  1. ;
  1. ; External References
  1. ; $$DTBR^ICDEX ICR 5747
  1. ; $$ICDOP^ICDEX ICR 5747
  1. ; $$LD^ICDEX ICR 5747
  1. ; $$DT^XLFDT ICR 10103
  1. ;
  1. ICDSRCH(X,LEXDATA,LEXD,LEXL,LEXF) ; ICD Diagnosis Search
  1. ;
  1. ; Input
  1. ;
  1. ; X Search Text (Required)
  1. ; .LEXDATA Local Array (by Ref, Required)
  1. ; LEXD Search Date (Optional,Default TODAY)
  1. ; LEXL List Length (Optional, Default 30)
  1. ; LEXF Filter (Optional, Default 10D)
  1. ;
  1. ; LEXDATA() Output Array of codes
  1. ;
  1. ; LEXDATA(0)=# found ^ Pruning Indicator
  1. ; LEXDATA(1)=CODE ^ date
  1. ; LEXDATA(1,"IDL")=ICD-9/10 Description, Long
  1. ; LEXDATA(1,"IDL",1)=ICD-9/10 IEN ^ date
  1. ; LEXDATA(1,"IDS")=ICD-9/10 Description, Short
  1. ; LEXDATA(1,"IDS",1)=ICD-9/10 IEN ^ date
  1. ; LEXDATA(1,"LEX")=Lexicon Description
  1. ; LEXDATA(1,"LEX",1)=Expression IEN ^ date
  1. ; LEXDATA(1,"SYN",1)=Synonym #1
  1. ; LEXDATA(1,"SYN",m)=Synonym #m
  1. ; LEXDATA(n,0)=
  1. ;
  1. ; Category or Subcategory
  1. ; LEXDATA(n,0)=Category Code
  1. ; LEXDATA(n,"CAT")=Category Name
  1. ;
  1. ; $$ICDSRCH
  1. ;
  1. ; A variable defining success/error conditions
  1. ;
  1. ; Positive number for success
  1. ;
  1. ; Negative number for error or condition
  1. ;
  1. ; "-1^No codes found"
  1. ; "-2^Too many items found, please refine search"
  1. ;
  1. K LEXDATA
  1. N LEX,LEXX,LEXVDT,LEXCS,LEXFI,LEXFIL,LEXLEN,LEXTMP,LEXOK,LEXOUT,LEXTOT
  1. N LEXPR,ICD10,LEXINC S LEXX=$$UP^XLFSTR($G(X))
  1. Q:'$L(LEXX) "-1^No search string passed"
  1. S ICD10=$$IMPDATE^LEXU("10D") I $L(LEXX)'>2 D Q X
  1. . S X="-1^Invalid search string passed, minimum of 3 characters"
  1. S LEXVDT=$P($G(LEXD),".",1),LEXFIL=$G(LEXF) I LEXVDT'<ICD10 D Q X
  1. . S LEXCS=30,X=$$DIAGSRCH($G(LEXX),.LEXDATA,LEXVDT,$G(LEXL),$G(LEXF))
  1. S LEXLEN=$G(LEXL) S:+LEXLEN'>0 LEXLEN=30
  1. S:'$L(LEXFIL) LEXFIL="I $$SO^LEXU(Y,""ICD"",+($G(LEXVDT)))"
  1. K LEXOUT S LEXCS=1 D I9T^LEX10DX(LEXX,.LEXOUT,LEXVDT,LEXLEN,LEXFIL)
  1. S LEXTOT=$G(LEXOUT(0)),LEXPR=+($P($G(LEXTOT),"^",2)),LEXTOT=+LEXTOT
  1. S LEXFI=80 D DXARY^LEX10DU K LEX,LEXOUT S:+LEXTOT'>0 LEXOUT="-1^No codes found"
  1. I +LEXTOT>0&(LEXPR>0) D
  1. . S LEXOUT="-2^Too many items found, please refine search"
  1. S:+LEXTOT>0&(LEXPR'>0) LEXOUT=LEXTOT S X=LEXOUT
  1. Q X
  1. ;
  1. DIAGSRCH(X,LEXDATA,LEXD,LEXL,LEXF) ; ICD-10 Diagnosis Search
  1. ;
  1. ; Input
  1. ;
  1. ; X Search Text (Required)
  1. ; .LEXDATA Local Array (by Ref, Required)
  1. ; LEXD Search Date (Optional, Default TODAY)
  1. ; LEXL List Length (Optional, Default 30)
  1. ; LEXF Filter (Optional, Default 10D - must be executable M code)
  1. ;
  1. ; Output
  1. ;
  1. ; LEXDATA() Output Array of codes/categories found
  1. ;
  1. ; LEXDATA(0)=# found ^ Pruning Indicator
  1. ;
  1. ; Code
  1. ; LEXDATA(1)=CODE ^ date
  1. ; LEXDATA(1,"IDL")=ICD-9/10 Description, Long
  1. ; LEXDATA(1,"IDL",1)=ICD-9/10 IEN ^ date
  1. ; LEXDATA(1,"IDS")=ICD-9/10 Description, Short
  1. ; LEXDATA(1,"IDS",1)=ICD-9/10 IEN ^ date
  1. ; LEXDATA(1,"LEX")=Lexicon Description
  1. ; LEXDATA(1,"LEX",1)=Expression IEN ^ date
  1. ; LEXDATA(1,"SYN",1)=Synonym #1
  1. ; LEXDATA(1,"SYN",m)=Synonym #m
  1. ; LEXDATA(1,"MENU")=Menu Text
  1. ; LEXDATA(1,"MSG")=Message (unversioned only)
  1. ; LEXDATA(n,0)=
  1. ;
  1. ; Category or Subcategory
  1. ; LEXDATA(n,0)=Category Code
  1. ; LEXDATA(n,"CAT")=Category Name
  1. ;
  1. ; $$DIAGSRCH
  1. ;
  1. ; A variable defining success/error conditions
  1. ;
  1. ; Positive number for success
  1. ;
  1. ; Negative number for error or condition
  1. ;
  1. ; "-1^No codes found"
  1. ; "-2^Too many items found, please refine search"
  1. ;
  1. K LEXDATA,^TMP("LEXDX",$J)
  1. N LEX,LEXX,LEXVDT,LEXFI,LEXFIL,LEXLEN,LEXTMP,LEXOK,LEXOUT
  1. N LEXTOT,LEXPR,LEXCS,LEXTLX,LEXIS,LEXINC
  1. N ICDVDT,ICDSYS,ICDFMT
  1. S X=$G(X) F Q:$E(X,$L(X))'="+" S X=$E(X,1,($L(X)-1))
  1. S LEXX=$$UP^XLFSTR($G(X)),LEXVDT=$P($G(LEXD),".",1),LEXCS=30,LEXFIL=$G(LEXF)
  1. Q:'$L(LEXX) "-1^No search string passed"
  1. Q:$L(LEXX)'>1 "-1^Invalid search string passed"
  1. I $L(LEXX)=2,LEXX?1A.1N D MAJ^LEX10DBR($$UP^XLFSTR(LEXX),.LEXOUT,LEXVDT) G OUT
  1. S LEXLEN=$G(LEXL) S:+LEXLEN'>0 LEXLEN=30 S:+LEXLEN'>7 LEXLEN=8
  1. S LEXIS=$$ISCAT^LEX10DU(LEXX)
  1. ; Input is a category with no categories
  1. ; and code exceeds max, expand the max
  1. I +LEXIS>0,+($P(LEXIS,"^",2))'>0,+($P(LEXIS,"^",3))>LEXLEN S LEXLEN=99999
  1. S:'$L(LEXFIL)&(LEXVDT?7N) LEXFIL="I $$SO^LEXU(Y,""10D"",+($G(LEXVDT)))"
  1. S:'$L(LEXFIL)&(LEXVDT'?7N) LEXFIL="I $L($$D10^LEX10CS(+Y))"
  1. S LEXTMP=LEXX S:$L(LEXTMP)=3&(LEXTMP'[".") LEXTMP=LEXTMP_"."
  1. S LEXOK=0 I $L(LEXTMP)>3,$L(LEXTMP)'>8,LEXTMP["." D
  1. . N LEXTK S:$D(^LEX(757.02,"ADX",(LEXTMP_" "))) LEXOK=1 Q:LEXOK
  1. . S:$O(^LEX(757.02,"ADX",(LEXTMP_" ")))[LEXTMP LEXOK=1 Q:LEXOK
  1. . S LEXTK=$$WDS(LEXTMP) S:$E(LEXTMP,1,4)'?1A2N1"."&(LEXTK'>0) LEXOK=-1
  1. . S:$E(LEXTMP,1,4)?1A2N1"."&(LEXTK'>0) LEXOK=-1
  1. K LEXOUT Q:LEXOK<0 "-1^Search string does not appear to be a code or text"
  1. I LEXOK D I10C^LEX10DBC(LEXTMP,.LEXOUT,LEXVDT,LEXLEN,LEXFIL)
  1. I 'LEXOK D I10T^LEX10DBT(LEXX,.LEXOUT,LEXVDT,LEXLEN,LEXFIL)
  1. OUT ; Out Array
  1. K ^TMP("LEXDX",$J) I +($G(LEXOUT(0)))=-1 Q LEXOUT(0)
  1. I +($G(LEXOUT(0)))=-2 Q -2_U_"final pruned list exceeds specified limit"
  1. S LEXTOT=$G(LEXOUT(0)),LEXPR=+($P($G(LEXTOT),"^",2)),LEXTOT=+LEXTOT
  1. S LEXTLX=$G(LEXOUT(0)) S LEXFI=80 D DXARY^LEX10DU
  1. S LEXOUT=LEXTLX
  1. S:+LEXTLX>0&(+LEXTLX=+($G(LEXDATA(0)))) LEXDATA(0)=LEXTLX
  1. S:+LEXTOT'>0 LEXOUT="-1^No codes found"
  1. S X=LEXOUT
  1. Q X
  1. WDS(X) ; Words in String
  1. S X=$G(X) Q:'$L(X) 0 K ^TMP("LEXTKN",$J) D PTX^LEXTOKN
  1. N LEXI,LEXT,LEXC S (LEXI,LEXC)=0 F S LEXI=$O(^TMP("LEXTKN",$J,LEXI)) Q:+LEXI'>0 D
  1. . S LEXT="" F S LEXT=$O(^TMP("LEXTKN",$J,LEXI,LEXT)) Q:'$L(LEXT) D
  1. . . S:$D(^LEX(757.01,"AWRD",LEXT)) LEXC=LEXC+1
  1. S X=LEXC K ^TMP("LEXTKN",$J)
  1. Q X
  1. ;
  1. PCSDIG(X,LEXD) ; Return ICD-10 Codes Expanding On Input
  1. ;
  1. ; Input
  1. ;
  1. ; X Search code (partial, Required)
  1. ; LEXD Search Date (Optional, Default TODAY)
  1. ;
  1. ; Output
  1. ;
  1. ; LEXDATA() Output Array containing the characters found
  1. ;
  1. ; LEXDATA("NEXLEV",<next character>,"DESC")= Description
  1. ;
  1. ; Output based on user input of "00P"
  1. ;
  1. ; LEXPCDAT("NEXLEV",0,"DESC")="Brain"
  1. ; LEXPCDAT("NEXLEV",6,"DESC")="Cerebral Ventricle"
  1. ; LEXPCDAT("NEXLEV","E","DESC")="Cranial Nerve"
  1. ; LEXPCDAT("NEXLEV","U","DESC")="Spinal Canal"
  1. ; LEXPCDAT("NEXLEV","V",DESC)="Spinal Cord"
  1. ;
  1. ; Output based on user input of "03120A1"
  1. ;
  1. ; LEXPCDAT("PCSDESC")="BYPASS INNOMINATE ARTERY TO
  1. ; LEFT UPPER ARM ARTERY ITH AUTOLOGOUS ARTERIAL
  1. ; TISSUE, OPEN APPROACH"
  1. ; LEXPCDAT("STATUS")="1^Date"
  1. ;
  1. ; $$PCSDIG "1" - If input code fragment is valid or null
  1. ; "0" - If input code fragment is invalid
  1. ;
  1. K LEXPCDAT
  1. N LEX,LEXI,LEXII,LEXCTL,LEXPCS,LEXEXIT,LEXLEN,LEXNXT,LEXCD,LELXI
  1. S:$L($G(X)) X=$$UP^XLFSTR(X) S:$L($G(LEXD)) LEXD=$P($G(LEXD),".",1)
  1. I $D(X),X'?."",('$D(^LEX(757.033,"B","10P"_X))) Q 0
  1. S:'$D(X) LEXLEN=0,X=""
  1. S:$D(X) LEXLEN=$L(X)
  1. I LEXLEN>6 G PCSALL
  1. S (LEXI,LEXEXIT)=0
  1. F S LEXI=$O(^LEX(757.033,"AFRAG",LEXI)) Q:'LEXI!LEXEXIT D
  1. . S:$D(^LEX(757.03,"ASAB","10P",LEXI)) LEXEXIT=1,LEXII=LEXI
  1. S LEXCTL=X,LEXPCS=X_" ",LEXEXIT=0
  1. F S LEXPCS=$O(^LEX(757.033,"AFRAG",LEXII,LEXPCS)) Q:'$D(LEXPCS)!LEXEXIT D
  1. . I X'=$E(LEXPCS,1,LEXLEN)!(LEXPCS="") S LEXEXIT=1 Q
  1. . N LEXOK S LEXOK=$$PCSOK(LEXPCS,$G(LEXD)) Q:LEXOK'>0
  1. . S LEXNXT=$E(LEXPCS,LEXLEN+1)
  1. . I '$D(LEXPCDAT("NEXLEV",LEXNXT,"DESC")) D
  1. . . N LEXF,LEXFA
  1. . . S LEXI="",LEXI=$O(^LEX(757.033,"B",("10P"_X_LEXNXT),LEXI))
  1. . . S LEXF=$$FIN^LEX10PR(LEXI,$G(LEXD),.LEXFA)
  1. . . S:$L($G(LEXFA(2))) LEXPCDAT("NEXLEV",LEXNXT,"DESC")=$G(LEXFA(2))
  1. . . S:$L($G(LEXFA(3))) LEXPCDAT("NEXLEV",LEXNXT,"META","Definition")=$G(LEXFA(3))
  1. . . S:$L($G(LEXFA(4))) LEXPCDAT("NEXLEV",LEXNXT,"META","Explanation")=$G(LEXFA(4))
  1. . . S LEXF=0 F S LEXF=$O(LEXFA(5,LEXF)) Q:+LEXF'>0 D
  1. . . . S:$L($G(LEXFA(5,+LEXF))) LEXPCDAT("NEXLEV",LEXNXT,"META","Includes/Examples",LEXF)=$G(LEXFA(5,+LEXF))
  1. . S LEXPCS=LEXCTL_LEXNXT_"~ "
  1. S LEXPCDAT=1
  1. Q 1
  1. PCSALL ; Return PCS data for full 7 digit code
  1. N LEXLD,LEXA S LEXD=$P($G(LEXD),".",1) S:LEXD'?7N LEXD=$G(DT)
  1. S:LEXD'?7N LEXD=$$DT^XLFDT S LEXD=$$DTBR^ICDEX(LEXD,0,31)
  1. S LEXCD=$$ICDOP^ICDEX(X,LEXD,31,"E")
  1. I $P(LEXCD,"^",1)="-1" Q 0
  1. S:$P(LEXCD,"^",10)>0 LEXPCDAT("STATUS")=$P(LEXCD,"^",10)_"^"_$P(LEXCD,"^",13)
  1. S:$P(LEXCD,"^",10)'>0 LEXPCDAT("STATUS")=$P(LEXCD,"^",10)_"^"_$P(LEXCD,"^",12)
  1. S LEXLD=$$LD^ICDEX(80.1,+LEXCD,LEXD,.LEXA)
  1. S LEXPCDAT("PCSDESC")=$G(LEXA(1))
  1. Q 1
  1. PCSOK(X,LEXD) ; PCS data is OK
  1. N LEXF,LEXO,LEXC,LEXN,LEXI,LEXS,LEXK S (LEXC,LEXF)=$TR($G(X)," ","") Q:'$L(LEXC) 0
  1. S X=0,LEXD=$P($G(LEXD),".",1),LEXI=$$IMPDATE^LEXU(31) S:+LEXI>+LEXD LEXD=LEXI
  1. S LEXO=$E(LEXF,1,($L(LEXF)-1))_$C($A($E(LEXF,$L(LEXF)))-1)_"~ "
  1. F S LEXO=$O(^LEX(757.02,"APR",LEXO)) Q:'$L(LEXO) Q:$E(LEXO,1,$L(LEXC))'=LEXC D Q:X>0
  1. . N LEXEF S LEXEF=$O(^LEX(757.02,"APR",LEXO,(LEXD+.001)),-1) Q:'$L(LEXEF)
  1. . S:'$D(^LEX(757.02,"APR",LEXO,LEXEF,0)) X=1
  1. Q X
  1. ;
  1. CODELIST(X,LEXSPEC,LEXSUB,LEXD,LEXL,LEXF) ;
  1. ; NOTE: Routine split due to SACC Limits on size, see LEX10CS2
  1. Q $$CODELIST^LEX10CS2($G(X),$G(LEXSPEC),$G(LEXSUB),$P($G(LEXD),".",1),$G(LEXL),$G(LEXF))
  1. TAX(X,LEXSRC,LEXDT,LEXSUB,LEXVER) ; Taxonomies
  1. Q $$TAX^LEX10TAX($G(X),$G(LEXSRC),$P($G(LEXDT),".",1),$G(LEXSUB),$G(LEXVER))
  1. D10(LEX) ; Get One Code (unversioned)
  1. N LEXA,LEXCD,LEXEF,LEXIEN,LEXSAB,LEXSIEN,LEXVDT
  1. S LEXVDT="",LEXSAB="10D",LEXIEN=$G(LEX) Q:+($G(LEXIEN))'>0 ""
  1. Q:$P($G(^LEX(757.01,LEXIEN,1)),"^",5)>0 ""
  1. S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"B",LEXIEN,LEXSIEN)) Q:+LEXSIEN'>0 D
  1. . N LEXEF,LEXCD Q:'$D(^LEX(757.02,"ASRC",LEXSAB,LEXSIEN))
  1. . Q:$P($G(^LEX(757.02,LEXSIEN,0)),"^",7)'>0
  1. . S LEXCD=$P($G(^LEX(757.02,+LEXSIEN,0)),"^",2) Q:'$L(LEXCD)
  1. . S LEXEF=$O(^LEX(757.02,LEXSIEN,4,"B",(9999999+.001)),-1) Q:'$L(LEXEF)
  1. . S LEXA(LEXEF,LEXCD)=""
  1. S LEXEF=$O(LEXA((9999999+.001)),-1) Q:'$L(LEXEF) ""
  1. S LEX=$O(LEXA(LEXEF,""),-1) Q:'$L(LEX) ""
  1. Q LEX