LEX10DBR ;ISL/KER - ICD-10 Diagnosis Lookup by Root ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
;
; Global Variables
; ^LEX(757.033) N/A
; ^TMP("LEXDX") SACC 2.3.2.5.1
; ^TMP("LEXSCH") Suggest SACC 2.3.2.5.1
;
; External References
; $$ICDDX^ICDEX ICR 5747
; $$LD^ICDEX ICR 5747
; $$SD^ICDEX ICR 5747
;
Q
MAJ(X,LEXA,LEXVDT) ; Lookup by Root, Major Categories (3 digit/decimal)
K ^TMP("LEXSCH",$J) N LEXC,LEXO,LEXT,LEXCT,LEXFND,LEXTOT S LEXCT=0
D GETCAT($G(X),$G(LEXVDT)),GETCOD($G(X),$G(LEXVDT)) S LEXFND=+($G(LEXCT))
D ARY^LEX10DU S LEXC=+($O(LEXA(" "),-1)) S:LEXC'>0 LEXC=-1 S LEXA(0)=LEXC
K ^TMP("LEXSCH",$J) S:LEXC>0 $P(LEXA(0),"^",2)=1
Q
GETCAT(X,LEXVDT) ; Get Categories
N LEXC,LEXCTL,LEXO S LEXC=$E(X,1,2) Q:$L(LEXC)'=2 S (LEXCTL,LEXO)=LEXC,LEXO=LEXO_" "
F S LEXO=$O(^LEX(757.033,"AFRAG",30,LEXO)) Q:'$L(LEXO)!($E(LEXO,1,$L(LEXCTL))'=LEXCTL) D
. N LEXQ,LEXE,LEXI,LEXNE,LEXNI,LEXN,LEXIS,LEXCN,LEX
. S LEXQ=$TR(LEXO," ","")
. S:$L(LEXQ)=3&(LEXQ'[".") LEXQ=LEXQ_"."
. Q:$L(LEXQ)'=4
. S LEXE=$P($O(^LEX(757.033,"AFRAG",30,(LEXQ_" ")," "),-1),".",1)
. Q:LEXE'?7N I $P($G(LEXVDT),".",1)?7N Q:LEXE>LEXVDT
. S LEXI=$O(^LEX(757.033,"AFRAG",30,(LEXQ_" "),LEXE," "),-1)
. S LEXNE=$O(^LEX(757.033,+LEXI,2,"B",(LEXVDT+.0001)),-1)
. S LEXNI=$O(^LEX(757.033,+LEXI,2,"B",+LEXNE," "),-1)
. I LEXNI'>0 D Q:LEXNI'>0
. . S LEXNE=$O(^LEX(757.033,+LEXI,2,"B",9999999),-1)
. . S LEXNI=$O(^LEX(757.033,+LEXI,2,"B",+LEXNE," "),-1)
. S LEXN=$G(^LEX(757.033,LEXI,2,LEXNI,1)) Q:'$L(LEXN)
. S LEXCN=$$CODES^LEX10DU(LEXQ),LEX="^"_LEXE_"^"_LEXN
. S:+LEXCN>0 $P(LEX,"^",4)=+LEXCN
. S ^TMP("LEXDX",$J,(LEXQ_" "))=LEX S LEXCT=LEXCT+1
Q
GETCOD(X,LEXVDT) ; Get Codes
N LEXC,LEXCTL,LEXO S LEXC=$E(X,1,2) Q:$L(LEXC)'=2 S (LEXCTL,LEXO)=LEXC,LEXO=LEXO_" "
F S LEXO=$O(^LEX(757.02,"ADX",LEXO)) Q:'$L(LEXO)!($E(LEXO,1,$L(LEXCTL))'=LEXCTL) D
. N LEXQ,LEXE,LEXI,LEXN,LEXSTA,LEX,LEXT
. S LEXQ=$TR(LEXO," ","") S:$L(LEXQ)=3&(LEXQ'[".") LEXQ=LEXQ_"." Q:$L(LEXQ)'=4
. S LEXSTA=$$STATCHK^LEXSRC2(LEXQ,$G(LEXVDT),,30) Q:+LEXSTA'>0
. S LEXE=$P(LEXSTA,"^",3),LEXI=$P(LEXSTA,"^",2) Q:+LEXI'>0
. S LEXT=+($G(^LEX(757.02,+LEXI,0))) Q:+LEXT'>0
. Q:LEXE'?7N I $P($G(LEXVDT),".",1)?7N Q:LEXE>LEXVDT
. S LEXN=$P($G(^LEX(757.01,+LEXT,0)),"^",1) Q:'$L(LEXN)
. S ^TMP("LEXDX",$J,(LEXQ_" "))=LEXI_"^"_LEXE_"^"_LEXN S LEXCT=LEXCT+1
Q
ST ;
N LEXNN,LEXNC
S LEXNN="^TMP(""LEXSCH"","_$J_")",LEXNC="^TMP(""LEXSCH"","_$J_","
F S LEXNN=$Q(@LEXNN) Q:'$L(LEXNN)!(LEXNN'[LEXNC) D
. W !,LEXNN,"=",@LEXNN
Q
TM(X,Y) ; Trim Character Y - Default " "
S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" "
F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
Q X
LEX10DBR ;ISL/KER - ICD-10 Diagnosis Lookup by Root ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.033) N/A
+5 ; ^TMP("LEXDX") SACC 2.3.2.5.1
+6 ; ^TMP("LEXSCH") Suggest SACC 2.3.2.5.1
+7 ;
+8 ; External References
+9 ; $$ICDDX^ICDEX ICR 5747
+10 ; $$LD^ICDEX ICR 5747
+11 ; $$SD^ICDEX ICR 5747
+12 ;
+13 QUIT
MAJ(X,LEXA,LEXVDT) ; Lookup by Root, Major Categories (3 digit/decimal)
+1 KILL ^TMP("LEXSCH",$JOB)
NEW LEXC,LEXO,LEXT,LEXCT,LEXFND,LEXTOT
SET LEXCT=0
+2 DO GETCAT($GET(X),$GET(LEXVDT))
DO GETCOD($GET(X),$GET(LEXVDT))
SET LEXFND=+($GET(LEXCT))
+3 DO ARY^LEX10DU
SET LEXC=+($ORDER(LEXA(" "),-1))
IF LEXC'>0
SET LEXC=-1
SET LEXA(0)=LEXC
+4 KILL ^TMP("LEXSCH",$JOB)
IF LEXC>0
SET $PIECE(LEXA(0),"^",2)=1
+5 QUIT
GETCAT(X,LEXVDT) ; Get Categories
+1 NEW LEXC,LEXCTL,LEXO
SET LEXC=$EXTRACT(X,1,2)
IF $LENGTH(LEXC)'=2
QUIT
SET (LEXCTL,LEXO)=LEXC
SET LEXO=LEXO_" "
+2 FOR
SET LEXO=$ORDER(^LEX(757.033,"AFRAG",30,LEXO))
IF '$LENGTH(LEXO)!($EXTRACT(LEXO,1,$LENGTH(LEXCTL))'=LEXCTL)
QUIT
Begin DoDot:1
+3 NEW LEXQ,LEXE,LEXI,LEXNE,LEXNI,LEXN,LEXIS,LEXCN,LEX
+4 SET LEXQ=$TRANSLATE(LEXO," ","")
+5 IF $LENGTH(LEXQ)=3&(LEXQ'[".")
SET LEXQ=LEXQ_"."
+6 IF $LENGTH(LEXQ)'=4
QUIT
+7 SET LEXE=$PIECE($ORDER(^LEX(757.033,"AFRAG",30,(LEXQ_" ")," "),-1),".",1)
+8 IF LEXE'?7N
QUIT
IF $PIECE($GET(LEXVDT),".",1)?7N
IF LEXE>LEXVDT
QUIT
+9 SET LEXI=$ORDER(^LEX(757.033,"AFRAG",30,(LEXQ_" "),LEXE," "),-1)
+10 SET LEXNE=$ORDER(^LEX(757.033,+LEXI,2,"B",(LEXVDT+.0001)),-1)
+11 SET LEXNI=$ORDER(^LEX(757.033,+LEXI,2,"B",+LEXNE," "),-1)
+12 IF LEXNI'>0
Begin DoDot:2
+13 SET LEXNE=$ORDER(^LEX(757.033,+LEXI,2,"B",9999999),-1)
+14 SET LEXNI=$ORDER(^LEX(757.033,+LEXI,2,"B",+LEXNE," "),-1)
End DoDot:2
IF LEXNI'>0
QUIT
+15 SET LEXN=$GET(^LEX(757.033,LEXI,2,LEXNI,1))
IF '$LENGTH(LEXN)
QUIT
+16 SET LEXCN=$$CODES^LEX10DU(LEXQ)
SET LEX="^"_LEXE_"^"_LEXN
+17 IF +LEXCN>0
SET $PIECE(LEX,"^",4)=+LEXCN
+18 SET ^TMP("LEXDX",$JOB,(LEXQ_" "))=LEX
SET LEXCT=LEXCT+1
End DoDot:1
+19 QUIT
GETCOD(X,LEXVDT) ; Get Codes
+1 NEW LEXC,LEXCTL,LEXO
SET LEXC=$EXTRACT(X,1,2)
IF $LENGTH(LEXC)'=2
QUIT
SET (LEXCTL,LEXO)=LEXC
SET LEXO=LEXO_" "
+2 FOR
SET LEXO=$ORDER(^LEX(757.02,"ADX",LEXO))
IF '$LENGTH(LEXO)!($EXTRACT(LEXO,1,$LENGTH(LEXCTL))'=LEXCTL)
QUIT
Begin DoDot:1
+3 NEW LEXQ,LEXE,LEXI,LEXN,LEXSTA,LEX,LEXT
+4 SET LEXQ=$TRANSLATE(LEXO," ","")
IF $LENGTH(LEXQ)=3&(LEXQ'[".")
SET LEXQ=LEXQ_"."
IF $LENGTH(LEXQ)'=4
QUIT
+5 SET LEXSTA=$$STATCHK^LEXSRC2(LEXQ,$GET(LEXVDT),,30)
IF +LEXSTA'>0
QUIT
+6 SET LEXE=$PIECE(LEXSTA,"^",3)
SET LEXI=$PIECE(LEXSTA,"^",2)
IF +LEXI'>0
QUIT
+7 SET LEXT=+($GET(^LEX(757.02,+LEXI,0)))
IF +LEXT'>0
QUIT
+8 IF LEXE'?7N
QUIT
IF $PIECE($GET(LEXVDT),".",1)?7N
IF LEXE>LEXVDT
QUIT
+9 SET LEXN=$PIECE($GET(^LEX(757.01,+LEXT,0)),"^",1)
IF '$LENGTH(LEXN)
QUIT
+10 SET ^TMP("LEXDX",$JOB,(LEXQ_" "))=LEXI_"^"_LEXE_"^"_LEXN
SET LEXCT=LEXCT+1
End DoDot:1
+11 QUIT
ST ;
+1 NEW LEXNN,LEXNC
+2 SET LEXNN="^TMP(""LEXSCH"","_$JOB_")"
SET LEXNC="^TMP(""LEXSCH"","_$JOB_","
+3 FOR
SET LEXNN=$QUERY(@LEXNN)
IF '$LENGTH(LEXNN)!(LEXNN'[LEXNC)
QUIT
Begin DoDot:1
+4 WRITE !,LEXNN,"=",@LEXNN
End DoDot:1
+5 QUIT
TM(X,Y) ; Trim Character Y - Default " "
+1 SET X=$GET(X)
IF X=""
QUIT X
SET Y=$GET(Y)
IF '$LENGTH(Y)
SET Y=" "
+2 FOR
IF $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+3 FOR
IF $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+4 QUIT X
