- LEX10CS ;ISL/KER - ICD-10 Code Set ;11/16/2016
- ;;2.0;LEXICON UTILITY;**80,110**;Sep 23, 1996;Build 6
- ;
- ; Global Variables
- ; ^LEX(757.033 N/A
- ; ^TMP("LEXDX") SACC 2.3.2.5.1
- ;
- ; External References
- ; $$DTBR^ICDEX ICR 5747
- ; $$ICDOP^ICDEX ICR 5747
- ; $$LD^ICDEX ICR 5747
- ; $$DT^XLFDT ICR 10103
- ;
- ICDSRCH(X,LEXDATA,LEXD,LEXL,LEXF) ; ICD Diagnosis Search
- ;
- ; Input
- ;
- ; X Search Text (Required)
- ; .LEXDATA Local Array (by Ref, Required)
- ; LEXD Search Date (Optional,Default TODAY)
- ; LEXL List Length (Optional, Default 30)
- ; LEXF Filter (Optional, Default 10D)
- ;
- ; LEXDATA() Output Array of codes
- ;
- ; LEXDATA(0)=# found ^ Pruning Indicator
- ; LEXDATA(1)=CODE ^ date
- ; LEXDATA(1,"IDL")=ICD-9/10 Description, Long
- ; LEXDATA(1,"IDL",1)=ICD-9/10 IEN ^ date
- ; LEXDATA(1,"IDS")=ICD-9/10 Description, Short
- ; LEXDATA(1,"IDS",1)=ICD-9/10 IEN ^ date
- ; LEXDATA(1,"LEX")=Lexicon Description
- ; LEXDATA(1,"LEX",1)=Expression IEN ^ date
- ; LEXDATA(1,"SYN",1)=Synonym #1
- ; LEXDATA(1,"SYN",m)=Synonym #m
- ; LEXDATA(n,0)=
- ;
- ; Category or Subcategory
- ; LEXDATA(n,0)=Category Code
- ; LEXDATA(n,"CAT")=Category Name
- ;
- ; $$ICDSRCH
- ;
- ; A variable defining success/error conditions
- ;
- ; Positive number for success
- ;
- ; Negative number for error or condition
- ;
- ; "-1^No codes found"
- ; "-2^Too many items found, please refine search"
- ;
- K LEXDATA
- N LEX,LEXX,LEXVDT,LEXCS,LEXFI,LEXFIL,LEXLEN,LEXTMP,LEXOK,LEXOUT,LEXTOT
- N LEXPR,ICD10,LEXINC S LEXX=$$UP^XLFSTR($G(X))
- Q:'$L(LEXX) "-1^No search string passed"
- S ICD10=$$IMPDATE^LEXU("10D") I $L(LEXX)'>2 D Q X
- . S X="-1^Invalid search string passed, minimum of 3 characters"
- S LEXVDT=$P($G(LEXD),".",1),LEXFIL=$G(LEXF) I LEXVDT'<ICD10 D Q X
- . S LEXCS=30,X=$$DIAGSRCH($G(LEXX),.LEXDATA,LEXVDT,$G(LEXL),$G(LEXF))
- S LEXLEN=$G(LEXL) S:+LEXLEN'>0 LEXLEN=30
- S:'$L(LEXFIL) LEXFIL="I $$SO^LEXU(Y,""ICD"",+($G(LEXVDT)))"
- K LEXOUT S LEXCS=1 D I9T^LEX10DX(LEXX,.LEXOUT,LEXVDT,LEXLEN,LEXFIL)
- S LEXTOT=$G(LEXOUT(0)),LEXPR=+($P($G(LEXTOT),"^",2)),LEXTOT=+LEXTOT
- S LEXFI=80 D DXARY^LEX10DU K LEX,LEXOUT S:+LEXTOT'>0 LEXOUT="-1^No codes found"
- I +LEXTOT>0&(LEXPR>0) D
- . S LEXOUT="-2^Too many items found, please refine search"
- S:+LEXTOT>0&(LEXPR'>0) LEXOUT=LEXTOT S X=LEXOUT
- Q X
- ;
- DIAGSRCH(X,LEXDATA,LEXD,LEXL,LEXF) ; ICD-10 Diagnosis Search
- ;
- ; Input
- ;
- ; X Search Text (Required)
- ; .LEXDATA Local Array (by Ref, Required)
- ; LEXD Search Date (Optional, Default TODAY)
- ; LEXL List Length (Optional, Default 30)
- ; LEXF Filter (Optional, Default 10D - must be executable M code)
- ;
- ; Output
- ;
- ; LEXDATA() Output Array of codes/categories found
- ;
- ; LEXDATA(0)=# found ^ Pruning Indicator
- ;
- ; Code
- ; LEXDATA(1)=CODE ^ date
- ; LEXDATA(1,"IDL")=ICD-9/10 Description, Long
- ; LEXDATA(1,"IDL",1)=ICD-9/10 IEN ^ date
- ; LEXDATA(1,"IDS")=ICD-9/10 Description, Short
- ; LEXDATA(1,"IDS",1)=ICD-9/10 IEN ^ date
- ; LEXDATA(1,"LEX")=Lexicon Description
- ; LEXDATA(1,"LEX",1)=Expression IEN ^ date
- ; LEXDATA(1,"SYN",1)=Synonym #1
- ; LEXDATA(1,"SYN",m)=Synonym #m
- ; LEXDATA(1,"MENU")=Menu Text
- ; LEXDATA(1,"MSG")=Message (unversioned only)
- ; LEXDATA(n,0)=
- ;
- ; Category or Subcategory
- ; LEXDATA(n,0)=Category Code
- ; LEXDATA(n,"CAT")=Category Name
- ;
- ; $$DIAGSRCH
- ;
- ; A variable defining success/error conditions
- ;
- ; Positive number for success
- ;
- ; Negative number for error or condition
- ;
- ; "-1^No codes found"
- ; "-2^Too many items found, please refine search"
- ;
- K LEXDATA,^TMP("LEXDX",$J)
- N LEX,LEXX,LEXVDT,LEXFI,LEXFIL,LEXLEN,LEXTMP,LEXOK,LEXOUT
- N LEXTOT,LEXPR,LEXCS,LEXTLX,LEXIS,LEXINC
- N ICDVDT,ICDSYS,ICDFMT
- S X=$G(X) F Q:$E(X,$L(X))'="+" S X=$E(X,1,($L(X)-1))
- S LEXX=$$UP^XLFSTR($G(X)),LEXVDT=$P($G(LEXD),".",1),LEXCS=30,LEXFIL=$G(LEXF)
- Q:'$L(LEXX) "-1^No search string passed"
- Q:$L(LEXX)'>1 "-1^Invalid search string passed"
- I $L(LEXX)=2,LEXX?1A.1N D MAJ^LEX10DBR($$UP^XLFSTR(LEXX),.LEXOUT,LEXVDT) G OUT
- S LEXLEN=$G(LEXL) S:+LEXLEN'>0 LEXLEN=30 S:+LEXLEN'>7 LEXLEN=8
- S LEXIS=$$ISCAT^LEX10DU(LEXX)
- ; Input is a category with no categories
- ; and code exceeds max, expand the max
- I +LEXIS>0,+($P(LEXIS,"^",2))'>0,+($P(LEXIS,"^",3))>LEXLEN S LEXLEN=99999
- S:'$L(LEXFIL)&(LEXVDT?7N) LEXFIL="I $$SO^LEXU(Y,""10D"",+($G(LEXVDT)))"
- S:'$L(LEXFIL)&(LEXVDT'?7N) LEXFIL="I $L($$D10^LEX10CS(+Y))"
- S LEXTMP=LEXX S:$L(LEXTMP)=3&(LEXTMP'[".") LEXTMP=LEXTMP_"."
- S LEXOK=0 I $L(LEXTMP)>3,$L(LEXTMP)'>8,LEXTMP["." D
- . N LEXTK S:$D(^LEX(757.02,"ADX",(LEXTMP_" "))) LEXOK=1 Q:LEXOK
- . S:$O(^LEX(757.02,"ADX",(LEXTMP_" ")))[LEXTMP LEXOK=1 Q:LEXOK
- . S LEXTK=$$WDS(LEXTMP) S:$E(LEXTMP,1,4)'?1A2N1"."&(LEXTK'>0) LEXOK=-1
- . S:$E(LEXTMP,1,4)?1A2N1"."&(LEXTK'>0) LEXOK=-1
- K LEXOUT Q:LEXOK<0 "-1^Search string does not appear to be a code or text"
- I LEXOK D I10C^LEX10DBC(LEXTMP,.LEXOUT,LEXVDT,LEXLEN,LEXFIL)
- I 'LEXOK D I10T^LEX10DBT(LEXX,.LEXOUT,LEXVDT,LEXLEN,LEXFIL)
- OUT ; Out Array
- K ^TMP("LEXDX",$J) I +($G(LEXOUT(0)))=-1 Q LEXOUT(0)
- I +($G(LEXOUT(0)))=-2 Q -2_U_"final pruned list exceeds specified limit"
- S LEXTOT=$G(LEXOUT(0)),LEXPR=+($P($G(LEXTOT),"^",2)),LEXTOT=+LEXTOT
- S LEXTLX=$G(LEXOUT(0)) S LEXFI=80 D DXARY^LEX10DU
- S LEXOUT=LEXTLX
- S:+LEXTLX>0&(+LEXTLX=+($G(LEXDATA(0)))) LEXDATA(0)=LEXTLX
- S:+LEXTOT'>0 LEXOUT="-1^No codes found"
- S X=LEXOUT
- Q X
- WDS(X) ; Words in String
- S X=$G(X) Q:'$L(X) 0 K ^TMP("LEXTKN",$J) D PTX^LEXTOKN
- N LEXI,LEXT,LEXC S (LEXI,LEXC)=0 F S LEXI=$O(^TMP("LEXTKN",$J,LEXI)) Q:+LEXI'>0 D
- . S LEXT="" F S LEXT=$O(^TMP("LEXTKN",$J,LEXI,LEXT)) Q:'$L(LEXT) D
- . . S:$D(^LEX(757.01,"AWRD",LEXT)) LEXC=LEXC+1
- S X=LEXC K ^TMP("LEXTKN",$J)
- Q X
- ;
- PCSDIG(X,LEXD) ; Return ICD-10 Codes Expanding On Input
- ;
- ; Input
- ;
- ; X Search code (partial, Required)
- ; LEXD Search Date (Optional, Default TODAY)
- ;
- ; Output
- ;
- ; LEXDATA() Output Array containing the characters found
- ;
- ; LEXDATA("NEXLEV",<next character>,"DESC")= Description
- ;
- ; Output based on user input of "00P"
- ;
- ; LEXPCDAT("NEXLEV",0,"DESC")="Brain"
- ; LEXPCDAT("NEXLEV",6,"DESC")="Cerebral Ventricle"
- ; LEXPCDAT("NEXLEV","E","DESC")="Cranial Nerve"
- ; LEXPCDAT("NEXLEV","U","DESC")="Spinal Canal"
- ; LEXPCDAT("NEXLEV","V",DESC)="Spinal Cord"
- ;
- ; Output based on user input of "03120A1"
- ;
- ; LEXPCDAT("PCSDESC")="BYPASS INNOMINATE ARTERY TO
- ; LEFT UPPER ARM ARTERY ITH AUTOLOGOUS ARTERIAL
- ; TISSUE, OPEN APPROACH"
- ; LEXPCDAT("STATUS")="1^Date"
- ;
- ; $$PCSDIG "1" - If input code fragment is valid or null
- ; "0" - If input code fragment is invalid
- ;
- K LEXPCDAT
- N LEX,LEXI,LEXII,LEXCTL,LEXPCS,LEXEXIT,LEXLEN,LEXNXT,LEXCD,LELXI
- S:$L($G(X)) X=$$UP^XLFSTR(X) S:$L($G(LEXD)) LEXD=$P($G(LEXD),".",1)
- I $D(X),X'?."",('$D(^LEX(757.033,"B","10P"_X))) Q 0
- S:'$D(X) LEXLEN=0,X=""
- S:$D(X) LEXLEN=$L(X)
- I LEXLEN>6 G PCSALL
- S (LEXI,LEXEXIT)=0
- F S LEXI=$O(^LEX(757.033,"AFRAG",LEXI)) Q:'LEXI!LEXEXIT D
- . S:$D(^LEX(757.03,"ASAB","10P",LEXI)) LEXEXIT=1,LEXII=LEXI
- S LEXCTL=X,LEXPCS=X_" ",LEXEXIT=0
- F S LEXPCS=$O(^LEX(757.033,"AFRAG",LEXII,LEXPCS)) Q:'$D(LEXPCS)!LEXEXIT D
- . I X'=$E(LEXPCS,1,LEXLEN)!(LEXPCS="") S LEXEXIT=1 Q
- . N LEXOK S LEXOK=$$PCSOK(LEXPCS,$G(LEXD)) Q:LEXOK'>0
- . S LEXNXT=$E(LEXPCS,LEXLEN+1)
- . I '$D(LEXPCDAT("NEXLEV",LEXNXT,"DESC")) D
- . . N LEXF,LEXFA
- . . S LEXI="",LEXI=$O(^LEX(757.033,"B",("10P"_X_LEXNXT),LEXI))
- . . S LEXF=$$FIN^LEX10PR(LEXI,$G(LEXD),.LEXFA)
- . . S:$L($G(LEXFA(2))) LEXPCDAT("NEXLEV",LEXNXT,"DESC")=$G(LEXFA(2))
- . . S:$L($G(LEXFA(3))) LEXPCDAT("NEXLEV",LEXNXT,"META","Definition")=$G(LEXFA(3))
- . . S:$L($G(LEXFA(4))) LEXPCDAT("NEXLEV",LEXNXT,"META","Explanation")=$G(LEXFA(4))
- . . S LEXF=0 F S LEXF=$O(LEXFA(5,LEXF)) Q:+LEXF'>0 D
- . . . S:$L($G(LEXFA(5,+LEXF))) LEXPCDAT("NEXLEV",LEXNXT,"META","Includes/Examples",LEXF)=$G(LEXFA(5,+LEXF))
- . S LEXPCS=LEXCTL_LEXNXT_"~ "
- S LEXPCDAT=1
- Q 1
- PCSALL ; Return PCS data for full 7 digit code
- N LEXLD,LEXA S LEXD=$P($G(LEXD),".",1) S:LEXD'?7N LEXD=$G(DT)
- S:LEXD'?7N LEXD=$$DT^XLFDT S LEXD=$$DTBR^ICDEX(LEXD,0,31)
- S LEXCD=$$ICDOP^ICDEX(X,LEXD,31,"E")
- I $P(LEXCD,"^",1)="-1" Q 0
- S:$P(LEXCD,"^",10)>0 LEXPCDAT("STATUS")=$P(LEXCD,"^",10)_"^"_$P(LEXCD,"^",13)
- S:$P(LEXCD,"^",10)'>0 LEXPCDAT("STATUS")=$P(LEXCD,"^",10)_"^"_$P(LEXCD,"^",12)
- S LEXLD=$$LD^ICDEX(80.1,+LEXCD,LEXD,.LEXA)
- S LEXPCDAT("PCSDESC")=$G(LEXA(1))
- Q 1
- PCSOK(X,LEXD) ; PCS data is OK
- N LEXF,LEXO,LEXC,LEXN,LEXI,LEXS,LEXK S (LEXC,LEXF)=$TR($G(X)," ","") Q:'$L(LEXC) 0
- S X=0,LEXD=$P($G(LEXD),".",1),LEXI=$$IMPDATE^LEXU(31) S:+LEXI>+LEXD LEXD=LEXI
- S LEXO=$E(LEXF,1,($L(LEXF)-1))_$C($A($E(LEXF,$L(LEXF)))-1)_"~ "
- F S LEXO=$O(^LEX(757.02,"APR",LEXO)) Q:'$L(LEXO) Q:$E(LEXO,1,$L(LEXC))'=LEXC D Q:X>0
- . N LEXEF S LEXEF=$O(^LEX(757.02,"APR",LEXO,(LEXD+.001)),-1) Q:'$L(LEXEF)
- . S:'$D(^LEX(757.02,"APR",LEXO,LEXEF,0)) X=1
- Q X
- ;
- CODELIST(X,LEXSPEC,LEXSUB,LEXD,LEXL,LEXF) ;
- ; NOTE: Routine split due to SACC Limits on size, see LEX10CS2
- Q $$CODELIST^LEX10CS2($G(X),$G(LEXSPEC),$G(LEXSUB),$P($G(LEXD),".",1),$G(LEXL),$G(LEXF))
- TAX(X,LEXSRC,LEXDT,LEXSUB,LEXVER) ; Taxonomies
- Q $$TAX^LEX10TAX($G(X),$G(LEXSRC),$P($G(LEXDT),".",1),$G(LEXSUB),$G(LEXVER))
- D10(LEX) ; Get One Code (unversioned)
- N LEXA,LEXCD,LEXEF,LEXIEN,LEXSAB,LEXSIEN,LEXVDT
- S LEXVDT="",LEXSAB="10D",LEXIEN=$G(LEX) Q:+($G(LEXIEN))'>0 ""
- Q:$P($G(^LEX(757.01,LEXIEN,1)),"^",5)>0 ""
- S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"B",LEXIEN,LEXSIEN)) Q:+LEXSIEN'>0 D
- . N LEXEF,LEXCD Q:'$D(^LEX(757.02,"ASRC",LEXSAB,LEXSIEN))
- . Q:$P($G(^LEX(757.02,LEXSIEN,0)),"^",7)'>0
- . S LEXCD=$P($G(^LEX(757.02,+LEXSIEN,0)),"^",2) Q:'$L(LEXCD)
- . S LEXEF=$O(^LEX(757.02,LEXSIEN,4,"B",(9999999+.001)),-1) Q:'$L(LEXEF)
- . S LEXA(LEXEF,LEXCD)=""
- S LEXEF=$O(LEXA((9999999+.001)),-1) Q:'$L(LEXEF) ""
- S LEX=$O(LEXA(LEXEF,""),-1) Q:'$L(LEX) ""
- Q LEX
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEX10CS 10559 printed Jan 18, 2025@03:04:14 Page 2
- LEX10CS ;ISL/KER - ICD-10 Code Set ;11/16/2016
- +1 ;;2.0;LEXICON UTILITY;**80,110**;Sep 23, 1996;Build 6
- +2 ;
- +3 ; Global Variables
- +4 ; ^LEX(757.033 N/A
- +5 ; ^TMP("LEXDX") SACC 2.3.2.5.1
- +6 ;
- +7 ; External References
- +8 ; $$DTBR^ICDEX ICR 5747
- +9 ; $$ICDOP^ICDEX ICR 5747
- +10 ; $$LD^ICDEX ICR 5747
- +11 ; $$DT^XLFDT ICR 10103
- +12 ;
- ICDSRCH(X,LEXDATA,LEXD,LEXL,LEXF) ; ICD Diagnosis Search
- +1 ;
- +2 ; Input
- +3 ;
- +4 ; X Search Text (Required)
- +5 ; .LEXDATA Local Array (by Ref, Required)
- +6 ; LEXD Search Date (Optional,Default TODAY)
- +7 ; LEXL List Length (Optional, Default 30)
- +8 ; LEXF Filter (Optional, Default 10D)
- +9 ;
- +10 ; LEXDATA() Output Array of codes
- +11 ;
- +12 ; LEXDATA(0)=# found ^ Pruning Indicator
- +13 ; LEXDATA(1)=CODE ^ date
- +14 ; LEXDATA(1,"IDL")=ICD-9/10 Description, Long
- +15 ; LEXDATA(1,"IDL",1)=ICD-9/10 IEN ^ date
- +16 ; LEXDATA(1,"IDS")=ICD-9/10 Description, Short
- +17 ; LEXDATA(1,"IDS",1)=ICD-9/10 IEN ^ date
- +18 ; LEXDATA(1,"LEX")=Lexicon Description
- +19 ; LEXDATA(1,"LEX",1)=Expression IEN ^ date
- +20 ; LEXDATA(1,"SYN",1)=Synonym #1
- +21 ; LEXDATA(1,"SYN",m)=Synonym #m
- +22 ; LEXDATA(n,0)=
- +23 ;
- +24 ; Category or Subcategory
- +25 ; LEXDATA(n,0)=Category Code
- +26 ; LEXDATA(n,"CAT")=Category Name
- +27 ;
- +28 ; $$ICDSRCH
- +29 ;
- +30 ; A variable defining success/error conditions
- +31 ;
- +32 ; Positive number for success
- +33 ;
- +34 ; Negative number for error or condition
- +35 ;
- +36 ; "-1^No codes found"
- +37 ; "-2^Too many items found, please refine search"
- +38 ;
- +39 KILL LEXDATA
- +40 NEW LEX,LEXX,LEXVDT,LEXCS,LEXFI,LEXFIL,LEXLEN,LEXTMP,LEXOK,LEXOUT,LEXTOT
- +41 NEW LEXPR,ICD10,LEXINC
- SET LEXX=$$UP^XLFSTR($GET(X))
- +42 if '$LENGTH(LEXX)
- QUIT "-1^No search string passed"
- +43 SET ICD10=$$IMPDATE^LEXU("10D")
- IF $LENGTH(LEXX)'>2
- Begin DoDot:1
- +44 SET X="-1^Invalid search string passed, minimum of 3 characters"
- End DoDot:1
- QUIT X
- +45 SET LEXVDT=$PIECE($GET(LEXD),".",1)
- SET LEXFIL=$GET(LEXF)
- IF LEXVDT'<ICD10
- Begin DoDot:1
- +46 SET LEXCS=30
- SET X=$$DIAGSRCH($GET(LEXX),.LEXDATA,LEXVDT,$GET(LEXL),$GET(LEXF))
- End DoDot:1
- QUIT X
- +47 SET LEXLEN=$GET(LEXL)
- if +LEXLEN'>0
- SET LEXLEN=30
- +48 if '$LENGTH(LEXFIL)
- SET LEXFIL="I $$SO^LEXU(Y,""ICD"",+($G(LEXVDT)))"
- +49 KILL LEXOUT
- SET LEXCS=1
- DO I9T^LEX10DX(LEXX,.LEXOUT,LEXVDT,LEXLEN,LEXFIL)
- +50 SET LEXTOT=$GET(LEXOUT(0))
- SET LEXPR=+($PIECE($GET(LEXTOT),"^",2))
- SET LEXTOT=+LEXTOT
- +51 SET LEXFI=80
- DO DXARY^LEX10DU
- KILL LEX,LEXOUT
- if +LEXTOT'>0
- SET LEXOUT="-1^No codes found"
- +52 IF +LEXTOT>0&(LEXPR>0)
- Begin DoDot:1
- +53 SET LEXOUT="-2^Too many items found, please refine search"
- End DoDot:1
- +54 if +LEXTOT>0&(LEXPR'>0)
- SET LEXOUT=LEXTOT
- SET X=LEXOUT
- +55 QUIT X
- +56 ;
- DIAGSRCH(X,LEXDATA,LEXD,LEXL,LEXF) ; ICD-10 Diagnosis Search
- +1 ;
- +2 ; Input
- +3 ;
- +4 ; X Search Text (Required)
- +5 ; .LEXDATA Local Array (by Ref, Required)
- +6 ; LEXD Search Date (Optional, Default TODAY)
- +7 ; LEXL List Length (Optional, Default 30)
- +8 ; LEXF Filter (Optional, Default 10D - must be executable M code)
- +9 ;
- +10 ; Output
- +11 ;
- +12 ; LEXDATA() Output Array of codes/categories found
- +13 ;
- +14 ; LEXDATA(0)=# found ^ Pruning Indicator
- +15 ;
- +16 ; Code
- +17 ; LEXDATA(1)=CODE ^ date
- +18 ; LEXDATA(1,"IDL")=ICD-9/10 Description, Long
- +19 ; LEXDATA(1,"IDL",1)=ICD-9/10 IEN ^ date
- +20 ; LEXDATA(1,"IDS")=ICD-9/10 Description, Short
- +21 ; LEXDATA(1,"IDS",1)=ICD-9/10 IEN ^ date
- +22 ; LEXDATA(1,"LEX")=Lexicon Description
- +23 ; LEXDATA(1,"LEX",1)=Expression IEN ^ date
- +24 ; LEXDATA(1,"SYN",1)=Synonym #1
- +25 ; LEXDATA(1,"SYN",m)=Synonym #m
- +26 ; LEXDATA(1,"MENU")=Menu Text
- +27 ; LEXDATA(1,"MSG")=Message (unversioned only)
- +28 ; LEXDATA(n,0)=
- +29 ;
- +30 ; Category or Subcategory
- +31 ; LEXDATA(n,0)=Category Code
- +32 ; LEXDATA(n,"CAT")=Category Name
- +33 ;
- +34 ; $$DIAGSRCH
- +35 ;
- +36 ; A variable defining success/error conditions
- +37 ;
- +38 ; Positive number for success
- +39 ;
- +40 ; Negative number for error or condition
- +41 ;
- +42 ; "-1^No codes found"
- +43 ; "-2^Too many items found, please refine search"
- +44 ;
- +45 KILL LEXDATA,^TMP("LEXDX",$JOB)
- +46 NEW LEX,LEXX,LEXVDT,LEXFI,LEXFIL,LEXLEN,LEXTMP,LEXOK,LEXOUT
- +47 NEW LEXTOT,LEXPR,LEXCS,LEXTLX,LEXIS,LEXINC
- +48 NEW ICDVDT,ICDSYS,ICDFMT
- +49 SET X=$GET(X)
- FOR
- if $EXTRACT(X,$LENGTH(X))'="+"
- QUIT
- SET X=$EXTRACT(X,1,($LENGTH(X)-1))
- +50 SET LEXX=$$UP^XLFSTR($GET(X))
- SET LEXVDT=$PIECE($GET(LEXD),".",1)
- SET LEXCS=30
- SET LEXFIL=$GET(LEXF)
- +51 if '$LENGTH(LEXX)
- QUIT "-1^No search string passed"
- +52 if $LENGTH(LEXX)'>1
- QUIT "-1^Invalid search string passed"
- +53 IF $LENGTH(LEXX)=2
- IF LEXX?1A.1N
- DO MAJ^LEX10DBR($$UP^XLFSTR(LEXX),.LEXOUT,LEXVDT)
- GOTO OUT
- +54 SET LEXLEN=$GET(LEXL)
- if +LEXLEN'>0
- SET LEXLEN=30
- if +LEXLEN'>7
- SET LEXLEN=8
- +55 SET LEXIS=$$ISCAT^LEX10DU(LEXX)
- +56 ; Input is a category with no categories
- +57 ; and code exceeds max, expand the max
- +58 IF +LEXIS>0
- IF +($PIECE(LEXIS,"^",2))'>0
- IF +($PIECE(LEXIS,"^",3))>LEXLEN
- SET LEXLEN=99999
- +59 if '$LENGTH(LEXFIL)&(LEXVDT?7N)
- SET LEXFIL="I $$SO^LEXU(Y,""10D"",+($G(LEXVDT)))"
- +60 if '$LENGTH(LEXFIL)&(LEXVDT'?7N)
- SET LEXFIL="I $L($$D10^LEX10CS(+Y))"
- +61 SET LEXTMP=LEXX
- if $LENGTH(LEXTMP)=3&(LEXTMP'[".")
- SET LEXTMP=LEXTMP_"."
- +62 SET LEXOK=0
- IF $LENGTH(LEXTMP)>3
- IF $LENGTH(LEXTMP)'>8
- IF LEXTMP["."
- Begin DoDot:1
- +63 NEW LEXTK
- if $DATA(^LEX(757.02,"ADX",(LEXTMP_" ")))
- SET LEXOK=1
- if LEXOK
- QUIT
- +64 if $ORDER(^LEX(757.02,"ADX",(LEXTMP_" ")))[LEXTMP
- SET LEXOK=1
- if LEXOK
- QUIT
- +65 SET LEXTK=$$WDS(LEXTMP)
- if $EXTRACT(LEXTMP,1,4)'?1A2N1"."&(LEXTK'>0)
- SET LEXOK=-1
- +66 if $EXTRACT(LEXTMP,1,4)?1A2N1"."&(LEXTK'>0)
- SET LEXOK=-1
- End DoDot:1
- +67 KILL LEXOUT
- if LEXOK<0
- QUIT "-1^Search string does not appear to be a code or text"
- +68 IF LEXOK
- DO I10C^LEX10DBC(LEXTMP,.LEXOUT,LEXVDT,LEXLEN,LEXFIL)
- +69 IF 'LEXOK
- DO I10T^LEX10DBT(LEXX,.LEXOUT,LEXVDT,LEXLEN,LEXFIL)
- OUT ; Out Array
- +1 KILL ^TMP("LEXDX",$JOB)
- IF +($GET(LEXOUT(0)))=-1
- QUIT LEXOUT(0)
- +2 IF +($GET(LEXOUT(0)))=-2
- QUIT -2_U_"final pruned list exceeds specified limit"
- +3 SET LEXTOT=$GET(LEXOUT(0))
- SET LEXPR=+($PIECE($GET(LEXTOT),"^",2))
- SET LEXTOT=+LEXTOT
- +4 SET LEXTLX=$GET(LEXOUT(0))
- SET LEXFI=80
- DO DXARY^LEX10DU
- +5 SET LEXOUT=LEXTLX
- +6 if +LEXTLX>0&(+LEXTLX=+($GET(LEXDATA(0))))
- SET LEXDATA(0)=LEXTLX
- +7 if +LEXTOT'>0
- SET LEXOUT="-1^No codes found"
- +8 SET X=LEXOUT
- +9 QUIT X
- WDS(X) ; Words in String
- +1 SET X=$GET(X)
- if '$LENGTH(X)
- QUIT 0
- KILL ^TMP("LEXTKN",$JOB)
- DO PTX^LEXTOKN
- +2 NEW LEXI,LEXT,LEXC
- SET (LEXI,LEXC)=0
- FOR
- SET LEXI=$ORDER(^TMP("LEXTKN",$JOB,LEXI))
- if +LEXI'>0
- QUIT
- Begin DoDot:1
- +3 SET LEXT=""
- FOR
- SET LEXT=$ORDER(^TMP("LEXTKN",$JOB,LEXI,LEXT))
- if '$LENGTH(LEXT)
- QUIT
- Begin DoDot:2
- +4 if $DATA(^LEX(757.01,"AWRD",LEXT))
- SET LEXC=LEXC+1
- End DoDot:2
- End DoDot:1
- +5 SET X=LEXC
- KILL ^TMP("LEXTKN",$JOB)
- +6 QUIT X
- +7 ;
- PCSDIG(X,LEXD) ; Return ICD-10 Codes Expanding On Input
- +1 ;
- +2 ; Input
- +3 ;
- +4 ; X Search code (partial, Required)
- +5 ; LEXD Search Date (Optional, Default TODAY)
- +6 ;
- +7 ; Output
- +8 ;
- +9 ; LEXDATA() Output Array containing the characters found
- +10 ;
- +11 ; LEXDATA("NEXLEV",<next character>,"DESC")= Description
- +12 ;
- +13 ; Output based on user input of "00P"
- +14 ;
- +15 ; LEXPCDAT("NEXLEV",0,"DESC")="Brain"
- +16 ; LEXPCDAT("NEXLEV",6,"DESC")="Cerebral Ventricle"
- +17 ; LEXPCDAT("NEXLEV","E","DESC")="Cranial Nerve"
- +18 ; LEXPCDAT("NEXLEV","U","DESC")="Spinal Canal"
- +19 ; LEXPCDAT("NEXLEV","V",DESC)="Spinal Cord"
- +20 ;
- +21 ; Output based on user input of "03120A1"
- +22 ;
- +23 ; LEXPCDAT("PCSDESC")="BYPASS INNOMINATE ARTERY TO
- +24 ; LEFT UPPER ARM ARTERY ITH AUTOLOGOUS ARTERIAL
- +25 ; TISSUE, OPEN APPROACH"
- +26 ; LEXPCDAT("STATUS")="1^Date"
- +27 ;
- +28 ; $$PCSDIG "1" - If input code fragment is valid or null
- +29 ; "0" - If input code fragment is invalid
- +30 ;
- +31 KILL LEXPCDAT
- +32 NEW LEX,LEXI,LEXII,LEXCTL,LEXPCS,LEXEXIT,LEXLEN,LEXNXT,LEXCD,LELXI
- +33 if $LENGTH($GET(X))
- SET X=$$UP^XLFSTR(X)
- if $LENGTH($GET(LEXD))
- SET LEXD=$PIECE($GET(LEXD),".",1)
- +34 IF $DATA(X)
- IF X'?.""
- IF ('$DATA(^LEX(757.033,"B","10P"_X)))
- QUIT 0
- +35 if '$DATA(X)
- SET LEXLEN=0
- SET X=""
- +36 if $DATA(X)
- SET LEXLEN=$LENGTH(X)
- +37 IF LEXLEN>6
- GOTO PCSALL
- +38 SET (LEXI,LEXEXIT)=0
- +39 FOR
- SET LEXI=$ORDER(^LEX(757.033,"AFRAG",LEXI))
- if 'LEXI!LEXEXIT
- QUIT
- Begin DoDot:1
- +40 if $DATA(^LEX(757.03,"ASAB","10P",LEXI))
- SET LEXEXIT=1
- SET LEXII=LEXI
- End DoDot:1
- +41 SET LEXCTL=X
- SET LEXPCS=X_" "
- SET LEXEXIT=0
- +42 FOR
- SET LEXPCS=$ORDER(^LEX(757.033,"AFRAG",LEXII,LEXPCS))
- if '$DATA(LEXPCS)!LEXEXIT
- QUIT
- Begin DoDot:1
- +43 IF X'=$EXTRACT(LEXPCS,1,LEXLEN)!(LEXPCS="")
- SET LEXEXIT=1
- QUIT
- +44 NEW LEXOK
- SET LEXOK=$$PCSOK(LEXPCS,$GET(LEXD))
- if LEXOK'>0
- QUIT
- +45 SET LEXNXT=$EXTRACT(LEXPCS,LEXLEN+1)
- +46 IF '$DATA(LEXPCDAT("NEXLEV",LEXNXT,"DESC"))
- Begin DoDot:2
- +47 NEW LEXF,LEXFA
- +48 SET LEXI=""
- SET LEXI=$ORDER(^LEX(757.033,"B",("10P"_X_LEXNXT),LEXI))
- +49 SET LEXF=$$FIN^LEX10PR(LEXI,$GET(LEXD),.LEXFA)
- +50 if $LENGTH($GET(LEXFA(2)))
- SET LEXPCDAT("NEXLEV",LEXNXT,"DESC")=$GET(LEXFA(2))
- +51 if $LENGTH($GET(LEXFA(3)))
- SET LEXPCDAT("NEXLEV",LEXNXT,"META","Definition")=$GET(LEXFA(3))
- +52 if $LENGTH($GET(LEXFA(4)))
- SET LEXPCDAT("NEXLEV",LEXNXT,"META","Explanation")=$GET(LEXFA(4))
- +53 SET LEXF=0
- FOR
- SET LEXF=$ORDER(LEXFA(5,LEXF))
- if +LEXF'>0
- QUIT
- Begin DoDot:3
- +54 if $LENGTH($GET(LEXFA(5,+LEXF)))
- SET LEXPCDAT("NEXLEV",LEXNXT,"META","Includes/Examples",LEXF)=$GET(LEXFA(5,+LEXF))
- End DoDot:3
- End DoDot:2
- +55 SET LEXPCS=LEXCTL_LEXNXT_"~ "
- End DoDot:1
- +56 SET LEXPCDAT=1
- +57 QUIT 1
- PCSALL ; Return PCS data for full 7 digit code
- +1 NEW LEXLD,LEXA
- SET LEXD=$PIECE($GET(LEXD),".",1)
- if LEXD'?7N
- SET LEXD=$GET(DT)
- +2 if LEXD'?7N
- SET LEXD=$$DT^XLFDT
- SET LEXD=$$DTBR^ICDEX(LEXD,0,31)
- +3 SET LEXCD=$$ICDOP^ICDEX(X,LEXD,31,"E")
- +4 IF $PIECE(LEXCD,"^",1)="-1"
- QUIT 0
- +5 if $PIECE(LEXCD,"^",10)>0
- SET LEXPCDAT("STATUS")=$PIECE(LEXCD,"^",10)_"^"_$PIECE(LEXCD,"^",13)
- +6 if $PIECE(LEXCD,"^",10)'>0
- SET LEXPCDAT("STATUS")=$PIECE(LEXCD,"^",10)_"^"_$PIECE(LEXCD,"^",12)
- +7 SET LEXLD=$$LD^ICDEX(80.1,+LEXCD,LEXD,.LEXA)
- +8 SET LEXPCDAT("PCSDESC")=$GET(LEXA(1))
- +9 QUIT 1
- PCSOK(X,LEXD) ; PCS data is OK
- +1 NEW LEXF,LEXO,LEXC,LEXN,LEXI,LEXS,LEXK
- SET (LEXC,LEXF)=$TRANSLATE($GET(X)," ","")
- if '$LENGTH(LEXC)
- QUIT 0
- +2 SET X=0
- SET LEXD=$PIECE($GET(LEXD),".",1)
- SET LEXI=$$IMPDATE^LEXU(31)
- if +LEXI>+LEXD
- SET LEXD=LEXI
- +3 SET LEXO=$EXTRACT(LEXF,1,($LENGTH(LEXF)-1))_$CHAR($ASCII($EXTRACT(LEXF,$LENGTH(LEXF)))-1)_"~ "
- +4 FOR
- SET LEXO=$ORDER(^LEX(757.02,"APR",LEXO))
- if '$LENGTH(LEXO)
- QUIT
- if $EXTRACT(LEXO,1,$LENGTH(LEXC))'=LEXC
- QUIT
- Begin DoDot:1
- +5 NEW LEXEF
- SET LEXEF=$ORDER(^LEX(757.02,"APR",LEXO,(LEXD+.001)),-1)
- if '$LENGTH(LEXEF)
- QUIT
- +6 if '$DATA(^LEX(757.02,"APR",LEXO,LEXEF,0))
- SET X=1
- End DoDot:1
- if X>0
- QUIT
- +7 QUIT X
- +8 ;
- CODELIST(X,LEXSPEC,LEXSUB,LEXD,LEXL,LEXF) ;
- +1 ; NOTE: Routine split due to SACC Limits on size, see LEX10CS2
- +2 QUIT $$CODELIST^LEX10CS2($GET(X),$GET(LEXSPEC),$GET(LEXSUB),$PIECE($GET(LEXD),".",1),$GET(LEXL),$GET(LEXF))
- TAX(X,LEXSRC,LEXDT,LEXSUB,LEXVER) ; Taxonomies
- +1 QUIT $$TAX^LEX10TAX($GET(X),$GET(LEXSRC),$PIECE($GET(LEXDT),".",1),$GET(LEXSUB),$GET(LEXVER))
- D10(LEX) ; Get One Code (unversioned)
- +1 NEW LEXA,LEXCD,LEXEF,LEXIEN,LEXSAB,LEXSIEN,LEXVDT
- +2 SET LEXVDT=""
- SET LEXSAB="10D"
- SET LEXIEN=$GET(LEX)
- if +($GET(LEXIEN))'>0
- QUIT ""
- +3 if $PIECE($GET(^LEX(757.01,LEXIEN,1)),"^",5)>0
- QUIT ""
- +4 SET LEXSIEN=0
- FOR
- SET LEXSIEN=$ORDER(^LEX(757.02,"B",LEXIEN,LEXSIEN))
- if +LEXSIEN'>0
- QUIT
- Begin DoDot:1
- +5 NEW LEXEF,LEXCD
- if '$DATA(^LEX(757.02,"ASRC",LEXSAB,LEXSIEN))
- QUIT
- +6 if $PIECE($GET(^LEX(757.02,LEXSIEN,0)),"^",7)'>0
- QUIT
- +7 SET LEXCD=$PIECE($GET(^LEX(757.02,+LEXSIEN,0)),"^",2)
- if '$LENGTH(LEXCD)
- QUIT
- +8 SET LEXEF=$ORDER(^LEX(757.02,LEXSIEN,4,"B",(9999999+.001)),-1)
- if '$LENGTH(LEXEF)
- QUIT
- +9 SET LEXA(LEXEF,LEXCD)=""
- End DoDot:1
- +10 SET LEXEF=$ORDER(LEXA((9999999+.001)),-1)
- if '$LENGTH(LEXEF)
- QUIT ""
- +11 SET LEX=$ORDER(LEXA(LEXEF,""),-1)
- if '$LENGTH(LEX)
- QUIT ""
- +12 QUIT LEX