- 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 Feb 18, 2025@23:29:32 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