LEX10DBT ;ISL/KER - ICD-10 Diagnosis Lookup by Text ;11/30/2016
;;2.0;LEXICON UTILITY;**80,110**;Sep 23, 1996;Build 6
;
; Global Variables
; ^TMP("LEXDX" SACC 2.3.2.5.1
; ^TMP("LEXFND" SACC 2.3.2.5.1
; ^TMP("LEXHIT" SACC 2.3.2.5.1
; ^TMP("LEXSCH" SACC 2.3.2.5.1
;
; External References
; $$DT^XLFDT ICR 10103
; $$FMDIFF^XLFDT ICR 10103
; $$NOW^XLFDT ICR 10103
;
Q
I10T(X,LEXA,LEXD,LEXL,LEXF) ; Lookup by Text, Return Pruned List
K ^TMP("LEXSCH",$J),^TMP("LEXFND",$J),^TMP("LEXHIT",$J)
N DIC,LEXCT,LEXFIL,LEXLEN,LEXLI,LEXCDT,LEXVDT,LEXX,LEXPR,LEXPRL
N LEXFND,LEXTOT,LEXPFL,LEXLV,LEXGV,LEXBG1,LEXEND,LEXBG2,LEXELP
S LEXA(0)="-1" S LEXX=$G(X) Q:'$L(LEXX)
S (LEXCDT,LEXVDT)=$G(LEXD),LEXFIL=$G(LEXF)
S LEXLEN=1,LEXPR=0
S LEXPRL=$G(LEXL) S:LEXPRL="" LEXPRL=30
K ^TMP("LEXSCH",$J) D CONFIG^LEXSET("10D","10D")
S ^TMP("LEXSCH",$J,"FIL",1)="Diagnosis"
S ^TMP("LEXSCH",$J,"DIS",0)="ICD/10D/DS4/SCC/NAN/SCT"
S ^TMP("LEXSCH",$J,"DIS",1)="Diagnosis"
S ^TMP("LEXSCH",$J,"ADF",0)=1,LEXVDT=LEXCDT
I LEXCDT'?7N D
. S (DIC("S"),LEXFIL)="I $L($$D10^LEX10CS(+Y))",^TMP("LEXSCH",$J,"FIL",0)=LEXFIL
. S ^TMP("LEXSCH",$J,"FIL",1)="Unversioned Diagnosis"
. S ^TMP("LEXSCH",$J,"APP",0)=1 K ^TMP("LEXSCH",$J,"VDT") S LEXVDT=LEXCDT
. S ^TMP("LEXSCH",$J,"DIS",0)="10D"
. S ^TMP("LEXSCH",$J,"DIS",1)="ICD-10 Diagnosis"
;S:'$L(LEXFIL) LEXFIL="I $$SO^LEXU(Y,""10D"",+($G(LEXVDT)))"
K LEX D LOOK^LEXA(LEXX,"10D",LEXLEN,"10D",LEXVDT)
S LEXLV=+($G(LEX("LIST",0)))
S LEXGV=$O(^TMP("LEXFND",$J,0),-1)
S:+($G(LEX("LIST",0)))=LEXLEN&($O(^TMP("LEXFND",$J,0),-1)<0) LEXPR=1
S LEXA(0)="-1^No matches found" Q:LEX=0
;S LEXA(0)="-1^Too many matches, please refine search" Q:+LEX>+LEXLEN
S LEXA(0)=-1
N LEXO,LEXN K ^TMP("LEXDX",$J)
S LEXCT=0 S LEXN=0 F S LEXN=$O(LEX("LIST",LEXN)) Q:+LEXN'>0 D
. N LEXX,LEXIEN S LEXX=LEX("LIST",LEXN),LEXIEN=$P(LEXX,"^",1) D ADDDX
S LEXO="" F S LEXO=$O(^TMP("LEXFND",$J,LEXO)) Q:'$L(LEXO) D
. N LEXIEN S LEXIEN=0 F S LEXIEN=$O(^TMP("LEXFND",$J,LEXO,LEXIEN)) Q:+LEXIEN'>0 D
. . Q:+LEXO'<0 D ADDDX
K ^TMP("LEXSCH",$J),^TMP("LEXFND",$J),^TMP("LEXHIT",$J)
S LEXFND=+($G(LEXCT))
D REDUCE^LEX10DU(LEXPRL)
D ARY^LEX10DU
S LEXTOT=+($O(LEXA(" "),-1))
S:LEXTOT>0&(LEXTOT<LEXFND) $P(LEXA(0),"^",2)=1
K ^TMP("LEXDX",$J)
Q
ADDDX ; Add DX
Q:+($G(LEXIEN))'>0 Q:'$D(^LEX(757.01,+($G(LEXIEN)),0))
N LEXSO,LEXSTA,LEXEIEN,LEXSIEN,LEXSEFF S LEXSO=$$D10ONE^LEXU(+LEXIEN,LEXVDT)
S:'$L(LEXSO)&($G(LEXCDT)'?7N) LEXSO=$$D10^LEX10CS(+LEXIEN) Q:'$L(LEXSO)
S LEXSTA=$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,30)
Q:$G(LEXCDT)?7N&(+LEXSTA'>0) S LEXSIEN=$P(LEXSTA,"^",2)
S LEXSEFF=$P($P(LEXSTA,"^",3),".",1) Q:$G(LEXCDT)?7N&(LEXSEFF'?7N)
Q:+($P($G(^LEX(757.02,+LEXSIEN,0)),"^",5))'>0
S LEXEIEN=+($G(^LEX(757.02,+LEXSIEN,0))) Q:LEXEIEN'?1N.N
Q:$P($G(^LEX(757.01,+LEXEIEN,1)),"^",5)>0
S ^TMP("LEXDX",$J,(LEXSO_" "))=LEXSIEN_"^"_LEXSEFF
S LEXCT=LEXCT+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEX10DBT 3060 printed Apr 09, 2024@21:11:28 Page 2
LEX10DBT ;ISL/KER - ICD-10 Diagnosis Lookup by Text ;11/30/2016
+1 ;;2.0;LEXICON UTILITY;**80,110**;Sep 23, 1996;Build 6
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXDX" SACC 2.3.2.5.1
+5 ; ^TMP("LEXFND" SACC 2.3.2.5.1
+6 ; ^TMP("LEXHIT" SACC 2.3.2.5.1
+7 ; ^TMP("LEXSCH" SACC 2.3.2.5.1
+8 ;
+9 ; External References
+10 ; $$DT^XLFDT ICR 10103
+11 ; $$FMDIFF^XLFDT ICR 10103
+12 ; $$NOW^XLFDT ICR 10103
+13 ;
+14 QUIT
I10T(X,LEXA,LEXD,LEXL,LEXF) ; Lookup by Text, Return Pruned List
+1 KILL ^TMP("LEXSCH",$JOB),^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB)
+2 NEW DIC,LEXCT,LEXFIL,LEXLEN,LEXLI,LEXCDT,LEXVDT,LEXX,LEXPR,LEXPRL
+3 NEW LEXFND,LEXTOT,LEXPFL,LEXLV,LEXGV,LEXBG1,LEXEND,LEXBG2,LEXELP
+4 SET LEXA(0)="-1"
SET LEXX=$GET(X)
if '$LENGTH(LEXX)
QUIT
+5 SET (LEXCDT,LEXVDT)=$GET(LEXD)
SET LEXFIL=$GET(LEXF)
+6 SET LEXLEN=1
SET LEXPR=0
+7 SET LEXPRL=$GET(LEXL)
if LEXPRL=""
SET LEXPRL=30
+8 KILL ^TMP("LEXSCH",$JOB)
DO CONFIG^LEXSET("10D","10D")
+9 SET ^TMP("LEXSCH",$JOB,"FIL",1)="Diagnosis"
+10 SET ^TMP("LEXSCH",$JOB,"DIS",0)="ICD/10D/DS4/SCC/NAN/SCT"
+11 SET ^TMP("LEXSCH",$JOB,"DIS",1)="Diagnosis"
+12 SET ^TMP("LEXSCH",$JOB,"ADF",0)=1
SET LEXVDT=LEXCDT
+13 IF LEXCDT'?7N
Begin DoDot:1
+14 SET (DIC("S"),LEXFIL)="I $L($$D10^LEX10CS(+Y))"
SET ^TMP("LEXSCH",$JOB,"FIL",0)=LEXFIL
+15 SET ^TMP("LEXSCH",$JOB,"FIL",1)="Unversioned Diagnosis"
+16 SET ^TMP("LEXSCH",$JOB,"APP",0)=1
KILL ^TMP("LEXSCH",$JOB,"VDT")
SET LEXVDT=LEXCDT
+17 SET ^TMP("LEXSCH",$JOB,"DIS",0)="10D"
+18 SET ^TMP("LEXSCH",$JOB,"DIS",1)="ICD-10 Diagnosis"
End DoDot:1
+19 ;S:'$L(LEXFIL) LEXFIL="I $$SO^LEXU(Y,""10D"",+($G(LEXVDT)))"
+20 KILL LEX
DO LOOK^LEXA(LEXX,"10D",LEXLEN,"10D",LEXVDT)
+21 SET LEXLV=+($GET(LEX("LIST",0)))
+22 SET LEXGV=$ORDER(^TMP("LEXFND",$JOB,0),-1)
+23 if +($GET(LEX("LIST",0)))=LEXLEN&($ORDER(^TMP("LEXFND",$JOB,0),-1)<0)
SET LEXPR=1
+24 SET LEXA(0)="-1^No matches found"
if LEX=0
QUIT
+25 ;S LEXA(0)="-1^Too many matches, please refine search" Q:+LEX>+LEXLEN
+26 SET LEXA(0)=-1
+27 NEW LEXO,LEXN
KILL ^TMP("LEXDX",$JOB)
+28 SET LEXCT=0
SET LEXN=0
FOR
SET LEXN=$ORDER(LEX("LIST",LEXN))
if +LEXN'>0
QUIT
Begin DoDot:1
+29 NEW LEXX,LEXIEN
SET LEXX=LEX("LIST",LEXN)
SET LEXIEN=$PIECE(LEXX,"^",1)
DO ADDDX
End DoDot:1
+30 SET LEXO=""
FOR
SET LEXO=$ORDER(^TMP("LEXFND",$JOB,LEXO))
if '$LENGTH(LEXO)
QUIT
Begin DoDot:1
+31 NEW LEXIEN
SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^TMP("LEXFND",$JOB,LEXO,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:2
+32 if +LEXO'<0
QUIT
DO ADDDX
End DoDot:2
End DoDot:1
+33 KILL ^TMP("LEXSCH",$JOB),^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB)
+34 SET LEXFND=+($GET(LEXCT))
+35 DO REDUCE^LEX10DU(LEXPRL)
+36 DO ARY^LEX10DU
+37 SET LEXTOT=+($ORDER(LEXA(" "),-1))
+38 if LEXTOT>0&(LEXTOT<LEXFND)
SET $PIECE(LEXA(0),"^",2)=1
+39 KILL ^TMP("LEXDX",$JOB)
+40 QUIT
ADDDX ; Add DX
+1 if +($GET(LEXIEN))'>0
QUIT
if '$DATA(^LEX(757.01,+($GET(LEXIEN)),0))
QUIT
+2 NEW LEXSO,LEXSTA,LEXEIEN,LEXSIEN,LEXSEFF
SET LEXSO=$$D10ONE^LEXU(+LEXIEN,LEXVDT)
+3 if '$LENGTH(LEXSO)&($GET(LEXCDT)'?7N)
SET LEXSO=$$D10^LEX10CS(+LEXIEN)
if '$LENGTH(LEXSO)
QUIT
+4 SET LEXSTA=$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,30)
+5 if $GET(LEXCDT)?7N&(+LEXSTA'>0)
QUIT
SET LEXSIEN=$PIECE(LEXSTA,"^",2)
+6 SET LEXSEFF=$PIECE($PIECE(LEXSTA,"^",3),".",1)
if $GET(LEXCDT)?7N&(LEXSEFF'?7N)
QUIT
+7 if +($PIECE($GET(^LEX(757.02,+LEXSIEN,0)),"^",5))'>0
QUIT
+8 SET LEXEIEN=+($GET(^LEX(757.02,+LEXSIEN,0)))
if LEXEIEN'?1N.N
QUIT
+9 if $PIECE($GET(^LEX(757.01,+LEXEIEN,1)),"^",5)>0
QUIT
+10 SET ^TMP("LEXDX",$JOB,(LEXSO_" "))=LEXSIEN_"^"_LEXSEFF
+11 SET LEXCT=LEXCT+1
+12 QUIT
