LEXQL3 ;ISL/KER - Query - Lookup ICD Code ;04/21/2014
;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 1
;
;
; Global Variables
; ^ICD0("BA" ICR 4486
; ^ICD9("BA" ICR 4485
; ^TMP( SACC 2.3.2.5.1
; ^TMP("LEXQL") SACC 2.3.2.5.1
;
; External References
; $$FILE^ICDEX ICR 5747
; $$ICDDX^ICDEX ICR 5747
; $$ICDOP^ICDEX ICR 5747
; $$LEXFI^ICDEX ICR 5747
; $$LKTX^ICDEX ICR 5747
; $$ROOT^ICDEX ICR 5747
; $$DT^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
ICD(X,Y) ;
;
; Input
;
; X User input, Uppercase
; Y ICD Coding System (1, 2, 30, 31)
;
; Output
;
; TMP Global Array
;
; ^TMP("LEXQL",$J,"ADDLIST",ID)=LEXIEN_U_Menu Text
;
N LEXSUB,LEXRT,LEXFI,LEXINP,LEXVER,LEXCDT,LEXOUT,LEXPIE,LEXENT,LEXINP,LEXSYS,LEXTD
S LEXINP=$$VI($G(X)) Q:'$L(LEXINP) S LEXSYS=+($G(Y)) Q:LEXSYS'?1N.N S LEXTD=$$DT^XLFDT
S LEXRT=$$ROOT^ICDEX(LEXSYS),LEXFI=$$FILE^ICDEX(LEXRT)
I +LEXFI'>0 S LEXFI=$$FILE^ICDEX(LEXS),LEXRT=$$ROOT^ICDEX(LEXFI)
S LEXPIE=$S((LEXSYS=1)!(LEXSYS=30):4,(LEXSYS=2)!(LEXSYS=31):5,1:"") Q:LEXPIE'?1N
Q:+LEXFI'>0 Q:'$L(LEXRT) Q:+LEXSYS'>0 S LEXSUB=$TR(LEXRT,"^(","")
S LEXVER=0,LEXOUT=1,LEXCDT="" Q:'$L(LEXSUB) K:$L($G(LEXSUB)) ^TMP(LEXSUB,$J)
K ICDBYCD S X=$$LKTX^ICDEX(LEXINP,LEXRT,,LEXSYS,LEXVER,LEXOUT)
Q:+X'>0 S LEXENT=0 F S LEXENT=$O(^TMP(LEXSUB,$J,"SEL",LEXENT)) Q:+LEXENT'>0 D
. N LEXITEM,LEXIEN,LEXOK,LEXT,LEXD,LEXC,LEXD,LEXN,LEXS,LEXE,LEXDS,LEXTN,LEXTS,LEXSS,LEXDT
. S LEXITEM=$G(^TMP(LEXSUB,$J,"SEL",LEXENT)),LEXIEN=+LEXITEM,LEXD=$G(LEXVDT) S:LEXD'?7N LEXD=$G(LEXTD)
. S:LEXPIE=4 LEXT=$$ICDDX^ICDEX(LEXIEN,LEXD,LEXSYS,"I") S:LEXPIE=5 LEXT=$$ICDOP^ICDEX(LEXIEN,LEXD,LEXSYS,"I")
. S LEXC=$P(LEXT,U,2) Q:'$L(LEXC) S LEXN=$$UP^XLFSTR($P(LEXT,U,LEXPIE)),LEXS=$P(LEXT,U,10)
. Q:'$L(LEXC) Q:'$L(LEXN) Q:'$L(LEXS) S:+LEXS'>0 LEXE=$P(LEXT,U,12)
. S:LEXPIE=4&(+LEXS>0) LEXE=$P(LEXT,U,17) S:LEXPIE=5&(+LEXS>0) LEXE=$P(LEXT,U,13)
. S LEXTS=$$STY^LEXQL2(LEXC),LEXTN=+LEXTS,LEXTS=$P(LEXTS,U,2) Q:'$L(LEXTS)
. S LEXSS="" S:+LEXS'>0&($L($G(LEXE))) LEXSS="(Inactive)" S LEXDS=LEXN S:$L(LEXSS)&(LEXDS'[LEXSS) LEXDS=LEXDS_" "_LEXSS
. S LEXDT=LEXC,LEXDT=LEXDT_$J(" ",(8-$L(LEXDT)))_LEXDS S:$L(LEXTS) LEXDT=LEXDT_" ("_LEXTS_")"
. S ^TMP("LEXQL",$J,"ADDLIST",(LEXTN_" "_LEXC_" "))=LEXIEN_U_$$FT^LEXQL2(LEXC,LEXN,$TR(LEXSS,"()",""))
. S ^TMP("LEXQL",$J,"ADDLIST",(LEXTN_" "_LEXC_" "),2)=LEXIEN_U_$$FC^LEXQL2(LEXC,LEXN,$TR(LEXSS,"()",""))
K ^TMP(LEXSUB,$J) N LEXVDT
Q
VI(X) ; Verify Input
N LEX,LEXIO,LEXIC,LEXUC,LEXUO S LEX=$G(X) Q:'$L(LEX) "" Q:$L(LEX)'>1 $$UP^XLFSTR(LEX)
S LEXIC=$G(LEX),LEXIO=$E(LEX,1,($L(LEX)-1))_$C(($A($E(LEX,$L(LEX)))-1))_"~ "
S LEXUC=$$UP^XLFSTR(LEXIC),LEXUO=$$UP^XLFSTR(LEXIO)
; 80 ICD-9/10
I $E($O(^ICD9("BA",LEXIO)),1,$L(LEXIC))=LEXIC Q LEXIC
I $E($O(^ICD9("BA",LEXUO)),1,$L(LEXUC))=LEXUC Q LEXUC
; 80.1 ICD-9.10
I $E($O(^ICD0("BA",LEXIO)),1,$L(LEXIC))=LEXIC Q LEXIC
I $E($O(^ICD0("BA",LEXUO)),1,$L(LEXUC))=LEXUC Q LEXUC
Q LEX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQL3 3222 printed Sep 23, 2025@19:44:50 Page 2
LEXQL3 ;ISL/KER - Query - Lookup ICD Code ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 1
+2 ;
+3 ;
+4 ; Global Variables
+5 ; ^ICD0("BA" ICR 4486
+6 ; ^ICD9("BA" ICR 4485
+7 ; ^TMP( SACC 2.3.2.5.1
+8 ; ^TMP("LEXQL") SACC 2.3.2.5.1
+9 ;
+10 ; External References
+11 ; $$FILE^ICDEX ICR 5747
+12 ; $$ICDDX^ICDEX ICR 5747
+13 ; $$ICDOP^ICDEX ICR 5747
+14 ; $$LEXFI^ICDEX ICR 5747
+15 ; $$LKTX^ICDEX ICR 5747
+16 ; $$ROOT^ICDEX ICR 5747
+17 ; $$DT^XLFDT ICR 10103
+18 ; $$UP^XLFSTR ICR 10104
+19 ;
ICD(X,Y) ;
+1 ;
+2 ; Input
+3 ;
+4 ; X User input, Uppercase
+5 ; Y ICD Coding System (1, 2, 30, 31)
+6 ;
+7 ; Output
+8 ;
+9 ; TMP Global Array
+10 ;
+11 ; ^TMP("LEXQL",$J,"ADDLIST",ID)=LEXIEN_U_Menu Text
+12 ;
+13 NEW LEXSUB,LEXRT,LEXFI,LEXINP,LEXVER,LEXCDT,LEXOUT,LEXPIE,LEXENT,LEXINP,LEXSYS,LEXTD
+14 SET LEXINP=$$VI($GET(X))
if '$LENGTH(LEXINP)
QUIT
SET LEXSYS=+($GET(Y))
if LEXSYS'?1N.N
QUIT
SET LEXTD=$$DT^XLFDT
+15 SET LEXRT=$$ROOT^ICDEX(LEXSYS)
SET LEXFI=$$FILE^ICDEX(LEXRT)
+16 IF +LEXFI'>0
SET LEXFI=$$FILE^ICDEX(LEXS)
SET LEXRT=$$ROOT^ICDEX(LEXFI)
+17 SET LEXPIE=$SELECT((LEXSYS=1)!(LEXSYS=30):4,(LEXSYS=2)!(LEXSYS=31):5,1:"")
if LEXPIE'?1N
QUIT
+18 if +LEXFI'>0
QUIT
if '$LENGTH(LEXRT)
QUIT
if +LEXSYS'>0
QUIT
SET LEXSUB=$TRANSLATE(LEXRT,"^(","")
+19 SET LEXVER=0
SET LEXOUT=1
SET LEXCDT=""
if '$LENGTH(LEXSUB)
QUIT
if $LENGTH($GET(LEXSUB))
KILL ^TMP(LEXSUB,$JOB)
+20 KILL ICDBYCD
SET X=$$LKTX^ICDEX(LEXINP,LEXRT,,LEXSYS,LEXVER,LEXOUT)
+21 if +X'>0
QUIT
SET LEXENT=0
FOR
SET LEXENT=$ORDER(^TMP(LEXSUB,$JOB,"SEL",LEXENT))
if +LEXENT'>0
QUIT
Begin DoDot:1
+22 NEW LEXITEM,LEXIEN,LEXOK,LEXT,LEXD,LEXC,LEXD,LEXN,LEXS,LEXE,LEXDS,LEXTN,LEXTS,LEXSS,LEXDT
+23 SET LEXITEM=$GET(^TMP(LEXSUB,$JOB,"SEL",LEXENT))
SET LEXIEN=+LEXITEM
SET LEXD=$GET(LEXVDT)
if LEXD'?7N
SET LEXD=$GET(LEXTD)
+24 if LEXPIE=4
SET LEXT=$$ICDDX^ICDEX(LEXIEN,LEXD,LEXSYS,"I")
if LEXPIE=5
SET LEXT=$$ICDOP^ICDEX(LEXIEN,LEXD,LEXSYS,"I")
+25 SET LEXC=$PIECE(LEXT,U,2)
if '$LENGTH(LEXC)
QUIT
SET LEXN=$$UP^XLFSTR($PIECE(LEXT,U,LEXPIE))
SET LEXS=$PIECE(LEXT,U,10)
+26 if '$LENGTH(LEXC)
QUIT
if '$LENGTH(LEXN)
QUIT
if '$LENGTH(LEXS)
QUIT
if +LEXS'>0
SET LEXE=$PIECE(LEXT,U,12)
+27 if LEXPIE=4&(+LEXS>0)
SET LEXE=$PIECE(LEXT,U,17)
if LEXPIE=5&(+LEXS>0)
SET LEXE=$PIECE(LEXT,U,13)
+28 SET LEXTS=$$STY^LEXQL2(LEXC)
SET LEXTN=+LEXTS
SET LEXTS=$PIECE(LEXTS,U,2)
if '$LENGTH(LEXTS)
QUIT
+29 SET LEXSS=""
if +LEXS'>0&($LENGTH($GET(LEXE)))
SET LEXSS="(Inactive)"
SET LEXDS=LEXN
if $LENGTH(LEXSS)&(LEXDS'[LEXSS)
SET LEXDS=LEXDS_" "_LEXSS
+30 SET LEXDT=LEXC
SET LEXDT=LEXDT_$JUSTIFY(" ",(8-$LENGTH(LEXDT)))_LEXDS
if $LENGTH(LEXTS)
SET LEXDT=LEXDT_" ("_LEXTS_")"
+31 SET ^TMP("LEXQL",$JOB,"ADDLIST",(LEXTN_" "_LEXC_" "))=LEXIEN_U_$$FT^LEXQL2(LEXC,LEXN,$TRANSLATE(LEXSS,"()",""))
+32 SET ^TMP("LEXQL",$JOB,"ADDLIST",(LEXTN_" "_LEXC_" "),2)=LEXIEN_U_$$FC^LEXQL2(LEXC,LEXN,$TRANSLATE(LEXSS,"()",""))
End DoDot:1
+33 KILL ^TMP(LEXSUB,$JOB)
NEW LEXVDT
+34 QUIT
VI(X) ; Verify Input
+1 NEW LEX,LEXIO,LEXIC,LEXUC,LEXUO
SET LEX=$GET(X)
if '$LENGTH(LEX)
QUIT ""
if $LENGTH(LEX)'>1
QUIT $$UP^XLFSTR(LEX)
+2 SET LEXIC=$GET(LEX)
SET LEXIO=$EXTRACT(LEX,1,($LENGTH(LEX)-1))_$CHAR(($ASCII($EXTRACT(LEX,$LENGTH(LEX)))-1))_"~ "
+3 SET LEXUC=$$UP^XLFSTR(LEXIC)
SET LEXUO=$$UP^XLFSTR(LEXIO)
+4 ; 80 ICD-9/10
+5 IF $EXTRACT($ORDER(^ICD9("BA",LEXIO)),1,$LENGTH(LEXIC))=LEXIC
QUIT LEXIC
+6 IF $EXTRACT($ORDER(^ICD9("BA",LEXUO)),1,$LENGTH(LEXUC))=LEXUC
QUIT LEXUC
+7 ; 80.1 ICD-9.10
+8 IF $EXTRACT($ORDER(^ICD0("BA",LEXIO)),1,$LENGTH(LEXIC))=LEXIC
QUIT LEXIC
+9 IF $EXTRACT($ORDER(^ICD0("BA",LEXUO)),1,$LENGTH(LEXUC))=LEXUC
QUIT LEXUC
+10 QUIT LEX
