LEX10DBC ;ISL/KER - ICD-10 Diagnosis Lookup by Code ;11/16/2016
;;2.0;LEXICON UTILITY;**80,110**;Sep 23, 1996;Build 6
;
; Global Variables
; ^TMP("LEXDX") SACC 2.3.2.5.1
;
; External References
; ^DIM ICR 10016
; $$DT^XLFDT ICR 10103
;
I10C(LEXC,LEXA,LEXD,LEXN,LEXF) ; Lookup by Code, Return Pruned List
;
; Input
; LEXC ICD-10 DX Code Required
; .LEXA Local Array (by Ref) Required
; LEXD Date (FM Format) Optional (Default TODAY)
; LEXL Maximum to Return Optional (Default = 30)
; LEXF Filter Optional (Default 10D)
;
; Output
;
; Code is found:
;
; LEXA(0)=# ^ PI No to exceed lenght where possible
; LEXA(#)=<code ien>_"^"_<code>_"^"_<activation date>
; LEXA(#,0)=<expression ien>_"^"_<expression>
;
; No Code, Category is Returned:
;
; LEXA(#)=<NULL>_"^"_<category>_"^"_<activation date> ^
; <number of codes in the category>
; LEXA(#,0)=<NULL>_"^"_<category name>
;
; Note: Second piece of LEXA(0) is the pruning
; indicator and set to "1" if pruning
; occurred
;
; See WD^LEX10DP for DX Text Lookup by Keywords (Pruned)
;
K ^TMP("LEXDX",$J),LEXA N LEXSO,LEXCDT,LEXCT,LEXFIL,LEXNUM,LEXUSE
N LEXFND,LEXTOT S LEXSO=$G(LEXC),LEXCDT=$G(LEXD),LEXNUM=+($G(LEXN))
S LEXFIL=$G(LEXF) S LEXUSE=0 Q:'$L(LEXSO)
S:$L(LEXSO)=3&(LEXSO'[".") LEXSO=LEXSO_"."
S LEXA(0)=-1
S:'$L(LEXFIL) LEXFIL="I $$SO^LEXU(Y,""10D"",+($G(LEXVDT)))"
S:LEXNUM'>0 LEXNUM=30 S (LEXFND,LEXCT)=$$FIND(LEXSO,LEXCDT,LEXFIL)
D REDUCE^LEX10DU(LEXNUM) D ARY^LEX10DU
S LEXTOT=+($O(LEXA(" "),-1))
S:LEXTOT>0&(LEXTOT<LEXFND) $P(LEXA(0),"^",2)=1
K ^TMP("LEXDX",$J)
Q
; Code Search
FIND(LEXC,LEXD,LEXF) ; Find All Codes
N LEX1,LEX2,LEXVDT,LEXCT,LEXFIL,LEXLEN,LEXNC,LEXNN,LEXOR,LEXPRE
S LEXFIL=$G(LEXF) S:'$L(LEXFIL) LEXFIL="I 1"
S LEXSO=$G(LEXC),LEXVDT=$G(LEXD)
S LEXOR=$E(LEXSO,1,($L(LEXSO)-1))_$C($A($E(LEXSO,$L(LEXSO)))-1)_"~"
S LEXNN="^LEX(757.02,""ADX"","""_LEXOR_" "")"
S LEXNC="^LEX(757.02,""ADX"","""_LEXSO
S (LEXPRE,LEXLEN,LEXCT)=0
F S LEXNN=$Q(@LEXNN) Q:'$L(LEXNN)!(LEXNN'[LEXNC) D
. N LEXC,LEXD,LEXE,LEXS,LEX1,LEX2
. S LEXC=$P(LEXNN,",",3),LEXC=$TR(LEXC,"""",""),LEXC=$$TM(LEXC)
. S LEXD=+($P(LEXNN,",",4)) Q:LEXD'?7N Q:LEXVDT?7N&((LEXVDT+.001)'>LEXD)
. S LEXS=+($P(LEXNN,",",5)) Q:LEXS'?1N I LEXS="0" D Q:LEXS'=1
. . I LEXVDT?7N,(LEXVDT+.001)>+($G(LEXD)) D
. . . S:$D(^TMP("LEXDX",$J,(LEXC_" "))) LEXCT=LEXCT-1 K ^TMP("LEXDX",$J,(LEXC_" "))
. S LEX1=+($P(LEXNN,",",6)) Q:LEX1'?1N.N Q:LEX1'>0
. Q:$P($G(^LEX(757.02,+LEX1,0)),"^",5)'>0
. S LEXE=+($G(^LEX(757.02,+LEX1,0))) Q:LEXE'?1N.N Q:LEXE'>0
. Q:$$SCR(LEXFIL,LEXE)'>0
. S LEX2=+($P(LEXNN,",",7)) Q:LEX1'?1N.N Q:LEX2'>0
. Q:$P($G(^LEX(757.01,+LEXE,1)),"^",5)>0
. S:$L(LEXC)>LEXLEN LEXPRE=LEXLEN,LEXLEN=$L(LEXC)
. S:LEXPRE=0 LEXPRE=$L(LEXC) S:$L(LEXC)=(LEXLEN-1) LEXPRE=$L(LEXC)
. S LEXCT=LEXCT+1,^TMP("LEXDX",$J,(LEXC_" "))=LEX1_"^"_LEXD
Q LEXCT
;
; Miscellaneous
SCR(X,Y) ; Screen
S Y=+($G(Y)) Q:+Y'>0 0 Q:'$D(^LEX(757.01,+Y,0)) 0
N LEXFIL S LEXFIL=$G(X) Q:'$L(LEXFIL) 1 D ^DIM Q:'$D(X) 1
X LEXFIL S X=$T
Q X
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[HLEX10DBC 3503 printed Oct 16, 2024@18:04:10 Page 2
LEX10DBC ;ISL/KER - ICD-10 Diagnosis Lookup by Code ;11/16/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 ;
+6 ; External References
+7 ; ^DIM ICR 10016
+8 ; $$DT^XLFDT ICR 10103
+9 ;
I10C(LEXC,LEXA,LEXD,LEXN,LEXF) ; Lookup by Code, Return Pruned List
+1 ;
+2 ; Input
+3 ; LEXC ICD-10 DX Code Required
+4 ; .LEXA Local Array (by Ref) Required
+5 ; LEXD Date (FM Format) Optional (Default TODAY)
+6 ; LEXL Maximum to Return Optional (Default = 30)
+7 ; LEXF Filter Optional (Default 10D)
+8 ;
+9 ; Output
+10 ;
+11 ; Code is found:
+12 ;
+13 ; LEXA(0)=# ^ PI No to exceed lenght where possible
+14 ; LEXA(#)=<code ien>_"^"_<code>_"^"_<activation date>
+15 ; LEXA(#,0)=<expression ien>_"^"_<expression>
+16 ;
+17 ; No Code, Category is Returned:
+18 ;
+19 ; LEXA(#)=<NULL>_"^"_<category>_"^"_<activation date> ^
+20 ; <number of codes in the category>
+21 ; LEXA(#,0)=<NULL>_"^"_<category name>
+22 ;
+23 ; Note: Second piece of LEXA(0) is the pruning
+24 ; indicator and set to "1" if pruning
+25 ; occurred
+26 ;
+27 ; See WD^LEX10DP for DX Text Lookup by Keywords (Pruned)
+28 ;
+29 KILL ^TMP("LEXDX",$JOB),LEXA
NEW LEXSO,LEXCDT,LEXCT,LEXFIL,LEXNUM,LEXUSE
+30 NEW LEXFND,LEXTOT
SET LEXSO=$GET(LEXC)
SET LEXCDT=$GET(LEXD)
SET LEXNUM=+($GET(LEXN))
+31 SET LEXFIL=$GET(LEXF)
SET LEXUSE=0
if '$LENGTH(LEXSO)
QUIT
+32 if $LENGTH(LEXSO)=3&(LEXSO'[".")
SET LEXSO=LEXSO_"."
+33 SET LEXA(0)=-1
+34 if '$LENGTH(LEXFIL)
SET LEXFIL="I $$SO^LEXU(Y,""10D"",+($G(LEXVDT)))"
+35 if LEXNUM'>0
SET LEXNUM=30
SET (LEXFND,LEXCT)=$$FIND(LEXSO,LEXCDT,LEXFIL)
+36 DO REDUCE^LEX10DU(LEXNUM)
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
+41 ; Code Search
FIND(LEXC,LEXD,LEXF) ; Find All Codes
+1 NEW LEX1,LEX2,LEXVDT,LEXCT,LEXFIL,LEXLEN,LEXNC,LEXNN,LEXOR,LEXPRE
+2 SET LEXFIL=$GET(LEXF)
if '$LENGTH(LEXFIL)
SET LEXFIL="I 1"
+3 SET LEXSO=$GET(LEXC)
SET LEXVDT=$GET(LEXD)
+4 SET LEXOR=$EXTRACT(LEXSO,1,($LENGTH(LEXSO)-1))_$CHAR($ASCII($EXTRACT(LEXSO,$LENGTH(LEXSO)))-1)_"~"
+5 SET LEXNN="^LEX(757.02,""ADX"","""_LEXOR_" "")"
+6 SET LEXNC="^LEX(757.02,""ADX"","""_LEXSO
+7 SET (LEXPRE,LEXLEN,LEXCT)=0
+8 FOR
SET LEXNN=$QUERY(@LEXNN)
if '$LENGTH(LEXNN)!(LEXNN'[LEXNC)
QUIT
Begin DoDot:1
+9 NEW LEXC,LEXD,LEXE,LEXS,LEX1,LEX2
+10 SET LEXC=$PIECE(LEXNN,",",3)
SET LEXC=$TRANSLATE(LEXC,"""","")
SET LEXC=$$TM(LEXC)
+11 SET LEXD=+($PIECE(LEXNN,",",4))
if LEXD'?7N
QUIT
if LEXVDT?7N&((LEXVDT+.001)'>LEXD)
QUIT
+12 SET LEXS=+($PIECE(LEXNN,",",5))
if LEXS'?1N
QUIT
IF LEXS="0"
Begin DoDot:2
+13 IF LEXVDT?7N
IF (LEXVDT+.001)>+($GET(LEXD))
Begin DoDot:3
+14 if $DATA(^TMP("LEXDX",$JOB,(LEXC_" ")))
SET LEXCT=LEXCT-1
KILL ^TMP("LEXDX",$JOB,(LEXC_" "))
End DoDot:3
End DoDot:2
if LEXS'=1
QUIT
+15 SET LEX1=+($PIECE(LEXNN,",",6))
if LEX1'?1N.N
QUIT
if LEX1'>0
QUIT
+16 if $PIECE($GET(^LEX(757.02,+LEX1,0)),"^",5)'>0
QUIT
+17 SET LEXE=+($GET(^LEX(757.02,+LEX1,0)))
if LEXE'?1N.N
QUIT
if LEXE'>0
QUIT
+18 if $$SCR(LEXFIL,LEXE)'>0
QUIT
+19 SET LEX2=+($PIECE(LEXNN,",",7))
if LEX1'?1N.N
QUIT
if LEX2'>0
QUIT
+20 if $PIECE($GET(^LEX(757.01,+LEXE,1)),"^",5)>0
QUIT
+21 if $LENGTH(LEXC)>LEXLEN
SET LEXPRE=LEXLEN
SET LEXLEN=$LENGTH(LEXC)
+22 if LEXPRE=0
SET LEXPRE=$LENGTH(LEXC)
if $LENGTH(LEXC)=(LEXLEN-1)
SET LEXPRE=$LENGTH(LEXC)
+23 SET LEXCT=LEXCT+1
SET ^TMP("LEXDX",$JOB,(LEXC_" "))=LEX1_"^"_LEXD
End DoDot:1
+24 QUIT LEXCT
+25 ;
+26 ; Miscellaneous
SCR(X,Y) ; Screen
+1 SET Y=+($GET(Y))
if +Y'>0
QUIT 0
if '$DATA(^LEX(757.01,+Y,0))
QUIT 0
+2 NEW LEXFIL
SET LEXFIL=$GET(X)
if '$LENGTH(LEXFIL)
QUIT 1
DO ^DIM
if '$DATA(X)
QUIT 1
+3 XECUTE LEXFIL
SET X=$TEST
+4 QUIT X
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
