LEX10CS ;ISL/KER - ICD-10 Code Set ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
;
; 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=$G(LEXD),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=$G(LEXD),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)
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=$G(LEXD) 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=$G(LEXD),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)
. 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),$G(LEXD),$G(LEXL),$G(LEXF))
TAX(X,LEXSRC,LEXDT,LEXSUB,LEXVER) ; Taxonomies
Q $$TAX^LEX10TAX($G(X),$G(LEXSRC),$G(LEXDT),$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
LEX10CS ;ISL/KER - ICD-10 Code Set ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
+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=$GET(LEXD)
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=$GET(LEXD)
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)
+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=$GET(LEXD)
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=$GET(LEXD)
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)
+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),$GET(LEXD),$GET(LEXL),$GET(LEXF))
TAX(X,LEXSRC,LEXDT,LEXSUB,LEXVER) ; Taxonomies
+1 QUIT $$TAX^LEX10TAX($GET(X),$GET(LEXSRC),$GET(LEXDT),$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
