- LEX10DBR ;ISL/KER - ICD-10 Diagnosis Lookup by Root ;04/21/2014
- ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
- ;
- ; 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEX10DBR 2861 printed Mar 13, 2025@21:07:57 Page 2
- LEX10DBR ;ISL/KER - ICD-10 Diagnosis Lookup by Root ;04/21/2014
- +1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
- +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
