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

LEXQL3.m

Go to the documentation of this file.
  1. LEXQL3 ;ISL/KER - Query - Lookup ICD Code ;04/21/2014
  1. ;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 1
  1. ;
  1. ;
  1. ; Global Variables
  1. ; ^ICD0("BA" ICR 4486
  1. ; ^ICD9("BA" ICR 4485
  1. ; ^TMP( SACC 2.3.2.5.1
  1. ; ^TMP("LEXQL") SACC 2.3.2.5.1
  1. ;
  1. ; External References
  1. ; $$FILE^ICDEX ICR 5747
  1. ; $$ICDDX^ICDEX ICR 5747
  1. ; $$ICDOP^ICDEX ICR 5747
  1. ; $$LEXFI^ICDEX ICR 5747
  1. ; $$LKTX^ICDEX ICR 5747
  1. ; $$ROOT^ICDEX ICR 5747
  1. ; $$DT^XLFDT ICR 10103
  1. ; $$UP^XLFSTR ICR 10104
  1. ;
  1. ICD(X,Y) ;
  1. ;
  1. ; Input
  1. ;
  1. ; X User input, Uppercase
  1. ; Y ICD Coding System (1, 2, 30, 31)
  1. ;
  1. ; Output
  1. ;
  1. ; TMP Global Array
  1. ;
  1. ; ^TMP("LEXQL",$J,"ADDLIST",ID)=LEXIEN_U_Menu Text
  1. ;
  1. N LEXSUB,LEXRT,LEXFI,LEXINP,LEXVER,LEXCDT,LEXOUT,LEXPIE,LEXENT,LEXINP,LEXSYS,LEXTD
  1. S LEXINP=$$VI($G(X)) Q:'$L(LEXINP) S LEXSYS=+($G(Y)) Q:LEXSYS'?1N.N S LEXTD=$$DT^XLFDT
  1. S LEXRT=$$ROOT^ICDEX(LEXSYS),LEXFI=$$FILE^ICDEX(LEXRT)
  1. I +LEXFI'>0 S LEXFI=$$FILE^ICDEX(LEXS),LEXRT=$$ROOT^ICDEX(LEXFI)
  1. S LEXPIE=$S((LEXSYS=1)!(LEXSYS=30):4,(LEXSYS=2)!(LEXSYS=31):5,1:"") Q:LEXPIE'?1N
  1. Q:+LEXFI'>0 Q:'$L(LEXRT) Q:+LEXSYS'>0 S LEXSUB=$TR(LEXRT,"^(","")
  1. S LEXVER=0,LEXOUT=1,LEXCDT="" Q:'$L(LEXSUB) K:$L($G(LEXSUB)) ^TMP(LEXSUB,$J)
  1. K ICDBYCD S X=$$LKTX^ICDEX(LEXINP,LEXRT,,LEXSYS,LEXVER,LEXOUT)
  1. Q:+X'>0 S LEXENT=0 F S LEXENT=$O(^TMP(LEXSUB,$J,"SEL",LEXENT)) Q:+LEXENT'>0 D
  1. . N LEXITEM,LEXIEN,LEXOK,LEXT,LEXD,LEXC,LEXD,LEXN,LEXS,LEXE,LEXDS,LEXTN,LEXTS,LEXSS,LEXDT
  1. . S LEXITEM=$G(^TMP(LEXSUB,$J,"SEL",LEXENT)),LEXIEN=+LEXITEM,LEXD=$G(LEXVDT) S:LEXD'?7N LEXD=$G(LEXTD)
  1. . S:LEXPIE=4 LEXT=$$ICDDX^ICDEX(LEXIEN,LEXD,LEXSYS,"I") S:LEXPIE=5 LEXT=$$ICDOP^ICDEX(LEXIEN,LEXD,LEXSYS,"I")
  1. . S LEXC=$P(LEXT,U,2) Q:'$L(LEXC) S LEXN=$$UP^XLFSTR($P(LEXT,U,LEXPIE)),LEXS=$P(LEXT,U,10)
  1. . Q:'$L(LEXC) Q:'$L(LEXN) Q:'$L(LEXS) S:+LEXS'>0 LEXE=$P(LEXT,U,12)
  1. . S:LEXPIE=4&(+LEXS>0) LEXE=$P(LEXT,U,17) S:LEXPIE=5&(+LEXS>0) LEXE=$P(LEXT,U,13)
  1. . S LEXTS=$$STY^LEXQL2(LEXC),LEXTN=+LEXTS,LEXTS=$P(LEXTS,U,2) Q:'$L(LEXTS)
  1. . S LEXSS="" S:+LEXS'>0&($L($G(LEXE))) LEXSS="(Inactive)" S LEXDS=LEXN S:$L(LEXSS)&(LEXDS'[LEXSS) LEXDS=LEXDS_" "_LEXSS
  1. . S LEXDT=LEXC,LEXDT=LEXDT_$J(" ",(8-$L(LEXDT)))_LEXDS S:$L(LEXTS) LEXDT=LEXDT_" ("_LEXTS_")"
  1. . S ^TMP("LEXQL",$J,"ADDLIST",(LEXTN_" "_LEXC_" "))=LEXIEN_U_$$FT^LEXQL2(LEXC,LEXN,$TR(LEXSS,"()",""))
  1. . S ^TMP("LEXQL",$J,"ADDLIST",(LEXTN_" "_LEXC_" "),2)=LEXIEN_U_$$FC^LEXQL2(LEXC,LEXN,$TR(LEXSS,"()",""))
  1. K ^TMP(LEXSUB,$J) N LEXVDT
  1. Q
  1. VI(X) ; Verify Input
  1. N LEX,LEXIO,LEXIC,LEXUC,LEXUO S LEX=$G(X) Q:'$L(LEX) "" Q:$L(LEX)'>1 $$UP^XLFSTR(LEX)
  1. S LEXIC=$G(LEX),LEXIO=$E(LEX,1,($L(LEX)-1))_$C(($A($E(LEX,$L(LEX)))-1))_"~ "
  1. S LEXUC=$$UP^XLFSTR(LEXIC),LEXUO=$$UP^XLFSTR(LEXIO)
  1. ; 80 ICD-9/10
  1. I $E($O(^ICD9("BA",LEXIO)),1,$L(LEXIC))=LEXIC Q LEXIC
  1. I $E($O(^ICD9("BA",LEXUO)),1,$L(LEXUC))=LEXUC Q LEXUC
  1. ; 80.1 ICD-9.10
  1. I $E($O(^ICD0("BA",LEXIO)),1,$L(LEXIC))=LEXIC Q LEXIC
  1. I $E($O(^ICD0("BA",LEXUO)),1,$L(LEXUC))=LEXUC Q LEXUC
  1. Q LEX