- 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 Feb 18, 2025@23:35:01 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