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

LEX10DBT.m

Go to the documentation of this file.
  1. LEX10DBT ;ISL/KER - ICD-10 Diagnosis Lookup by Text ;11/30/2016
  1. ;;2.0;LEXICON UTILITY;**80,110**;Sep 23, 1996;Build 6
  1. ;
  1. ; Global Variables
  1. ; ^TMP("LEXDX" SACC 2.3.2.5.1
  1. ; ^TMP("LEXFND" SACC 2.3.2.5.1
  1. ; ^TMP("LEXHIT" SACC 2.3.2.5.1
  1. ; ^TMP("LEXSCH" SACC 2.3.2.5.1
  1. ;
  1. ; External References
  1. ; $$DT^XLFDT ICR 10103
  1. ; $$FMDIFF^XLFDT ICR 10103
  1. ; $$NOW^XLFDT ICR 10103
  1. ;
  1. Q
  1. I10T(X,LEXA,LEXD,LEXL,LEXF) ; Lookup by Text, Return Pruned List
  1. K ^TMP("LEXSCH",$J),^TMP("LEXFND",$J),^TMP("LEXHIT",$J)
  1. N DIC,LEXCT,LEXFIL,LEXLEN,LEXLI,LEXCDT,LEXVDT,LEXX,LEXPR,LEXPRL
  1. N LEXFND,LEXTOT,LEXPFL,LEXLV,LEXGV,LEXBG1,LEXEND,LEXBG2,LEXELP
  1. S LEXA(0)="-1" S LEXX=$G(X) Q:'$L(LEXX)
  1. S (LEXCDT,LEXVDT)=$G(LEXD),LEXFIL=$G(LEXF)
  1. S LEXLEN=1,LEXPR=0
  1. S LEXPRL=$G(LEXL) S:LEXPRL="" LEXPRL=30
  1. K ^TMP("LEXSCH",$J) D CONFIG^LEXSET("10D","10D")
  1. S ^TMP("LEXSCH",$J,"FIL",1)="Diagnosis"
  1. S ^TMP("LEXSCH",$J,"DIS",0)="ICD/10D/DS4/SCC/NAN/SCT"
  1. S ^TMP("LEXSCH",$J,"DIS",1)="Diagnosis"
  1. S ^TMP("LEXSCH",$J,"ADF",0)=1,LEXVDT=LEXCDT
  1. I LEXCDT'?7N D
  1. . S (DIC("S"),LEXFIL)="I $L($$D10^LEX10CS(+Y))",^TMP("LEXSCH",$J,"FIL",0)=LEXFIL
  1. . S ^TMP("LEXSCH",$J,"FIL",1)="Unversioned Diagnosis"
  1. . S ^TMP("LEXSCH",$J,"APP",0)=1 K ^TMP("LEXSCH",$J,"VDT") S LEXVDT=LEXCDT
  1. . S ^TMP("LEXSCH",$J,"DIS",0)="10D"
  1. . S ^TMP("LEXSCH",$J,"DIS",1)="ICD-10 Diagnosis"
  1. ;S:'$L(LEXFIL) LEXFIL="I $$SO^LEXU(Y,""10D"",+($G(LEXVDT)))"
  1. K LEX D LOOK^LEXA(LEXX,"10D",LEXLEN,"10D",LEXVDT)
  1. S LEXLV=+($G(LEX("LIST",0)))
  1. S LEXGV=$O(^TMP("LEXFND",$J,0),-1)
  1. S:+($G(LEX("LIST",0)))=LEXLEN&($O(^TMP("LEXFND",$J,0),-1)<0) LEXPR=1
  1. S LEXA(0)="-1^No matches found" Q:LEX=0
  1. ;S LEXA(0)="-1^Too many matches, please refine search" Q:+LEX>+LEXLEN
  1. S LEXA(0)=-1
  1. N LEXO,LEXN K ^TMP("LEXDX",$J)
  1. S LEXCT=0 S LEXN=0 F S LEXN=$O(LEX("LIST",LEXN)) Q:+LEXN'>0 D
  1. . N LEXX,LEXIEN S LEXX=LEX("LIST",LEXN),LEXIEN=$P(LEXX,"^",1) D ADDDX
  1. S LEXO="" F S LEXO=$O(^TMP("LEXFND",$J,LEXO)) Q:'$L(LEXO) D
  1. . N LEXIEN S LEXIEN=0 F S LEXIEN=$O(^TMP("LEXFND",$J,LEXO,LEXIEN)) Q:+LEXIEN'>0 D
  1. . . Q:+LEXO'<0 D ADDDX
  1. K ^TMP("LEXSCH",$J),^TMP("LEXFND",$J),^TMP("LEXHIT",$J)
  1. S LEXFND=+($G(LEXCT))
  1. D REDUCE^LEX10DU(LEXPRL)
  1. D ARY^LEX10DU
  1. S LEXTOT=+($O(LEXA(" "),-1))
  1. S:LEXTOT>0&(LEXTOT<LEXFND) $P(LEXA(0),"^",2)=1
  1. K ^TMP("LEXDX",$J)
  1. Q
  1. ADDDX ; Add DX
  1. Q:+($G(LEXIEN))'>0 Q:'$D(^LEX(757.01,+($G(LEXIEN)),0))
  1. N LEXSO,LEXSTA,LEXEIEN,LEXSIEN,LEXSEFF S LEXSO=$$D10ONE^LEXU(+LEXIEN,LEXVDT)
  1. S:'$L(LEXSO)&($G(LEXCDT)'?7N) LEXSO=$$D10^LEX10CS(+LEXIEN) Q:'$L(LEXSO)
  1. S LEXSTA=$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,30)
  1. Q:$G(LEXCDT)?7N&(+LEXSTA'>0) S LEXSIEN=$P(LEXSTA,"^",2)
  1. S LEXSEFF=$P($P(LEXSTA,"^",3),".",1) Q:$G(LEXCDT)?7N&(LEXSEFF'?7N)
  1. Q:+($P($G(^LEX(757.02,+LEXSIEN,0)),"^",5))'>0
  1. S LEXEIEN=+($G(^LEX(757.02,+LEXSIEN,0))) Q:LEXEIEN'?1N.N
  1. Q:$P($G(^LEX(757.01,+LEXEIEN,1)),"^",5)>0
  1. S ^TMP("LEXDX",$J,(LEXSO_" "))=LEXSIEN_"^"_LEXSEFF
  1. S LEXCT=LEXCT+1
  1. Q