LEX10DX ;ISL/KER - ICD-9 Diagnosis ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
;
; 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
; ^DIM ICR 10016
; $$ICDDATA^ICDXCODE ICR 5699
; $$DT^XLFDT ICR 10103
;
Q
I9T(X,LEXA,LEXD,LEXL,LEXF) ; ICD-9 DX Text Lookup (Pruned)
;
; Input
; X Diagnostic Text 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 ICD)
;
; Output
;
; LEXA(0)=# ^ PI No to exceed 30
; LEXA(#)=<code ien>_"^"_<code>_"^"_<activation date>
; LEXA(#,0)=<expression ien>_"^"_<expression>
;
; Note: Second piece of LEXA(0) is the pruning
; indicator and set to "1" if pruning
; occurred
;
; See DX^LEX10DP for DX Code Lookup (Pruned)
;
K ^TMP("LEXSCH",$J),^TMP("LEXFND",$J),^TMP("LEXHIT",$J)
N DIC,LEXFIL,LEXLEN,LEXLI,LEXCDT,LEXVDT,LEXX,LEXPR,LEX
S LEXX=$G(X) Q:'$L(LEXX) S LEXCDT=$G(LEXD),LEXFIL=$G(LEXF)
S:LEXCDT'?7N LEXCDT=$G(DT) S:LEXCDT'?7N LEXCDT=$$DT^XLFDT
S LEXLEN=$G(LEXL) S:+LEXLEN'>0 LEXLEN=30 S LEXPR=0
S:'$L(LEXFIL) LEXFIL="I $$SO^LEXU(Y,""ICD"",+($G(LEXCDT)))"
S DIC("S")=LEXFIL D CONFIG^LEXSET("ICD","ICD",LEXCDT)
S (DIC("S"),^TMP("LEXSCH",$J,"FIL",0))=LEXFIL
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"
K LEX D LOOK^LEXA(LEXX,"ICD",+LEXLEN,"ICD",LEXCDT)
S:+($G(LEX("LIST",0)))=LEXLEN&($O(^TMP("LEXFND",$J,0),-1)<0) LEXPR=1
K ^TMP("LEXSCH",$J),^TMP("LEXFND",$J),^TMP("LEXHIT",$J)
S LEXLI=0 F S LEXLI=$O(LEX("LIST",LEXLI)) Q:+LEXLI'>0 D
. N LEXAI,LEXCODE,LEXEFF,LEXEIEN,LEXEXP,LEXND,LEXSI,LEXSIEN,LEXSRC
. S LEXEIEN=+($G(LEX("LIST",LEXLI)))
. Q:LEXEIEN'>0
. S LEXEXP=$G(^LEX(757.01,+LEXEIEN,0))
. S LEXSI=0,(LEXSIEN,LEXCODE,LEXEFF)=""
. F S LEXSI=$O(^LEX(757.02,"B",LEXEIEN,LEXSI)) Q:+LEXSI'>0 D
. . N LEXD,LEXH,LEXND,LEXS Q:+($G(LEXSIEN))>0 S LEXND=$G(^LEX(757.02,LEXSI,0))
. . Q:$P(LEXND,"^",3)'=1 S LEXD=$O(^LEX(757.02,LEXSI,4,"B",(LEXCDT+.001)),-1)
. . Q:LEXD'?7N S LEXH=$O(^LEX(757.02,LEXSI,4,"B",LEXD," "),-1) Q:LEXH'?1N.N
. . S LEXS=$P($G(^LEX(757.02,LEXSI,4,LEXH,0)),"^",2)
. . S:LEXS>0 LEXSIEN=LEXSI,LEXEFF=LEXD,LEXCODE=$P(LEXND,"^",2)
. I +LEXSIEN'>0,LEXEIEN>0 D
. . N LEXMC,LEXSI,LEXSA S LEXMC=$P($G(^LEX(757.01,+LEXEIEN,1)),"^",1) Q:+LEXMC'>0
. . S LEXSI=0 F S LEXSI=$O(^LEX(757.02,"AMC",LEXMC,LEXSI)) Q:+LEXSI'>0 D
. . . N LEXND,LEXH,LEXS,LEXC S LEXND=$G(^LEX(757.02,+LEXSI,0)) Q:$P(LEXND,"^",3)>2
. . . S LEXH=$O(^LEX(757.02,LEXSI,4,"B",(+($G(LEXCDT))+.001)),-1)
. . . S LEXH=$O(^LEX(757.02,LEXSI,4,"B",+LEXH," "),-1)
. . . S LEXH=$G(^LEX(757.02,LEXSI,4,+LEXH,0)) Q:$P(LEXH,"^",2)'>0
. . . Q:$P(LEXND,"^",5)'>0 S LEXC=$O(LEXSA(" "),-1)+1
. . . S LEXSA(LEXC)=(LEXSI_"^"_$P(LEXH,"^",1)),LEXSA(0)=LEXC
. . I LEXSA(0)=1,+($G(LEXSA(1)))>0,$O(LEXSA(1))'>0 D
. . . N LEXSI,LEXEI,LEXEF S LEXSI=+($G(LEXSA(1))),LEXEF=$P($G(LEXSA(1)),"^",2)
. . . S LEXEI=+($G(^LEX(757.02,+LEXSI,0))) Q:+LEXEI'>0 Q:LEXEF'?7N
. . . S LEXSIEN=LEXSI,LEXEIEN=LEXEI,LEXEFF=LEXEF
. Q:+LEXSIEN'>0 Q:LEXEFF'?7N Q:+LEXEIEN'>0
. S LEXND=$G(^LEX(757.02,LEXSIEN,0)) Q:+LEXEIEN'=+LEXND
. S LEXEXP=$G(^LEX(757.01,+LEXEIEN,0)) Q:'$L(LEXEXP)
. Q:$P($G(^LEX(757.01,+LEXEIEN,1)),"^",5)>0
. S LEXSRC=$P(LEXND,"^",3) Q:LEXSRC'=1 S LEXCODE=$P(LEXND,"^",2)
. Q:'$L(LEXCODE) S LEXAI=$O(LEXA(" "),-1)+1
. S LEXA(LEXAI)=LEXSIEN_"^"_LEXCODE_"^"_LEXEFF
. S LEXA(LEXAI,0)=LEXEIEN_"^"_LEXEXP
. S LEXA(0)=$O(LEXA(" "),-1)
S:+($G(LEXA(0)))'>0 LEXA(0)=-1 Q:+($G(LEXA(0)))'>0
K LEX S:LEXPR>0&(+($G(LEXA(0)))>0) $P(LEXA(0),"^",2)=LEXPR
Q
;
NEXT(LEXC,LEXA,LEXD) ; Next Character
;
; Input
;
; LEXC Partial Dx Code Required
; .LEXA Local Array (by Ref) Required
; LEXD Date (FM Format) Optional (Default TODAY)
;
; Output
;
; LEXA(<input>,0)= # of characters
; LEXA(<input>,<character>)=""
;
N LEX1,LEX2,LEXCDT,LEXCHK,LEXCHR,LEXCT,LEXE,LEXLEN,LEXID,LEXNC,LEXNN
N LEXOR,LEXPRE,LEXS,LEXSO S LEXC=$$TM(LEXC)
S:$L(LEXC)=3&(LEXC'[".") LEXC=LEXC_"." S (LEXID,LEXSO)=LEXC
S LEXCDT=$G(LEXD) S:LEXCDT'?7N LEXCDT=$$DT^XLFDT S LEXLEN=$L(LEXC)
Q:LEXLEN>6 "-1^Max length reached, no next character available"
I LEXLEN>1 D
. S LEXOR=$E(LEXSO,1,($L(LEXSO)-1))_$C($A($E(LEXSO,$L(LEXSO)))-1)_"~"
S:LEXLEN=1 LEXOR=$C($A(LEXSO)-1)_"~" S:LEXLEN'>0 LEXOR="/~"
S LEXCHK=0 S:LEXLEN'>0 LEXCHK=1 S:LEXLEN>0&(LEXLEN<3) LEXCHK=LEXLEN+1
S:LEXLEN=3 LEXCHK=LEXLEN+2 S:LEXLEN>3 LEXCHK=LEXLEN+1
Q:+LEXCHK'>0 "-1^Character position not specified"
S:LEXLEN=0 LEXID="<null>" S:'$L(LEXID) LEXID="<unknown>"
S LEXNN="^LEX(757.02,""ADX"","""_LEXOR_" "")"
S LEXNC="^LEX(757.02,""ADX"","""_LEXSO,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:(LEXCDT+.001)'>LEXD
. I $E(LEXC,1,$L(LEXSO))=LEXSO,$L(LEXC)'<LEXCHK D Q
. . N LEXCHR S LEXCHR=$E(LEXC,LEXCHK) Q:'$L(LEXCHR)
. . I '$D(LEXA(LEXID,LEXCHR)) D
. . . S LEXA(LEXID,LEXCHR)="",LEXCT=LEXCT+1
. . S LEXOR=$E(LEXC,1,LEXCHK)_"~"
. . S LEXNN="^LEX(757.02,""ADX"","""_LEXOR_" "")"
S:+($G(LEXCT))>0 LEXA(LEXID)=+($G(LEXCT))
Q +($G(LEXCT))
;
; Miscellaneous
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[HLEX10DX 5938 printed Apr 09, 2024@21:07:46 Page 2
LEX10DX ;ISL/KER - ICD-9 Diagnosis ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
+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 ; ^DIM ICR 10016
+11 ; $$ICDDATA^ICDXCODE ICR 5699
+12 ; $$DT^XLFDT ICR 10103
+13 ;
+14 QUIT
I9T(X,LEXA,LEXD,LEXL,LEXF) ; ICD-9 DX Text Lookup (Pruned)
+1 ;
+2 ; Input
+3 ; X Diagnostic Text 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 ICD)
+8 ;
+9 ; Output
+10 ;
+11 ; LEXA(0)=# ^ PI No to exceed 30
+12 ; LEXA(#)=<code ien>_"^"_<code>_"^"_<activation date>
+13 ; LEXA(#,0)=<expression ien>_"^"_<expression>
+14 ;
+15 ; Note: Second piece of LEXA(0) is the pruning
+16 ; indicator and set to "1" if pruning
+17 ; occurred
+18 ;
+19 ; See DX^LEX10DP for DX Code Lookup (Pruned)
+20 ;
+21 KILL ^TMP("LEXSCH",$JOB),^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB)
+22 NEW DIC,LEXFIL,LEXLEN,LEXLI,LEXCDT,LEXVDT,LEXX,LEXPR,LEX
+23 SET LEXX=$GET(X)
if '$LENGTH(LEXX)
QUIT
SET LEXCDT=$GET(LEXD)
SET LEXFIL=$GET(LEXF)
+24 if LEXCDT'?7N
SET LEXCDT=$GET(DT)
if LEXCDT'?7N
SET LEXCDT=$$DT^XLFDT
+25 SET LEXLEN=$GET(LEXL)
if +LEXLEN'>0
SET LEXLEN=30
SET LEXPR=0
+26 if '$LENGTH(LEXFIL)
SET LEXFIL="I $$SO^LEXU(Y,""ICD"",+($G(LEXCDT)))"
+27 SET DIC("S")=LEXFIL
DO CONFIG^LEXSET("ICD","ICD",LEXCDT)
+28 SET (DIC("S"),^TMP("LEXSCH",$JOB,"FIL",0))=LEXFIL
+29 SET ^TMP("LEXSCH",$JOB,"FIL",1)="Diagnosis"
+30 SET ^TMP("LEXSCH",$JOB,"DIS",0)="ICD/10D/DS4/SCC/NAN/SCT"
+31 SET ^TMP("LEXSCH",$JOB,"DIS",1)="Diagnosis"
+32 KILL LEX
DO LOOK^LEXA(LEXX,"ICD",+LEXLEN,"ICD",LEXCDT)
+33 if +($GET(LEX("LIST",0)))=LEXLEN&($ORDER(^TMP("LEXFND",$JOB,0),-1)<0)
SET LEXPR=1
+34 KILL ^TMP("LEXSCH",$JOB),^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB)
+35 SET LEXLI=0
FOR
SET LEXLI=$ORDER(LEX("LIST",LEXLI))
if +LEXLI'>0
QUIT
Begin DoDot:1
+36 NEW LEXAI,LEXCODE,LEXEFF,LEXEIEN,LEXEXP,LEXND,LEXSI,LEXSIEN,LEXSRC
+37 SET LEXEIEN=+($GET(LEX("LIST",LEXLI)))
+38 if LEXEIEN'>0
QUIT
+39 SET LEXEXP=$GET(^LEX(757.01,+LEXEIEN,0))
+40 SET LEXSI=0
SET (LEXSIEN,LEXCODE,LEXEFF)=""
+41 FOR
SET LEXSI=$ORDER(^LEX(757.02,"B",LEXEIEN,LEXSI))
if +LEXSI'>0
QUIT
Begin DoDot:2
+42 NEW LEXD,LEXH,LEXND,LEXS
if +($GET(LEXSIEN))>0
QUIT
SET LEXND=$GET(^LEX(757.02,LEXSI,0))
+43 if $PIECE(LEXND,"^",3)'=1
QUIT
SET LEXD=$ORDER(^LEX(757.02,LEXSI,4,"B",(LEXCDT+.001)),-1)
+44 if LEXD'?7N
QUIT
SET LEXH=$ORDER(^LEX(757.02,LEXSI,4,"B",LEXD," "),-1)
if LEXH'?1N.N
QUIT
+45 SET LEXS=$PIECE($GET(^LEX(757.02,LEXSI,4,LEXH,0)),"^",2)
+46 if LEXS>0
SET LEXSIEN=LEXSI
SET LEXEFF=LEXD
SET LEXCODE=$PIECE(LEXND,"^",2)
End DoDot:2
+47 IF +LEXSIEN'>0
IF LEXEIEN>0
Begin DoDot:2
+48 NEW LEXMC,LEXSI,LEXSA
SET LEXMC=$PIECE($GET(^LEX(757.01,+LEXEIEN,1)),"^",1)
if +LEXMC'>0
QUIT
+49 SET LEXSI=0
FOR
SET LEXSI=$ORDER(^LEX(757.02,"AMC",LEXMC,LEXSI))
if +LEXSI'>0
QUIT
Begin DoDot:3
+50 NEW LEXND,LEXH,LEXS,LEXC
SET LEXND=$GET(^LEX(757.02,+LEXSI,0))
if $PIECE(LEXND,"^",3)>2
QUIT
+51 SET LEXH=$ORDER(^LEX(757.02,LEXSI,4,"B",(+($GET(LEXCDT))+.001)),-1)
+52 SET LEXH=$ORDER(^LEX(757.02,LEXSI,4,"B",+LEXH," "),-1)
+53 SET LEXH=$GET(^LEX(757.02,LEXSI,4,+LEXH,0))
if $PIECE(LEXH,"^",2)'>0
QUIT
+54 if $PIECE(LEXND,"^",5)'>0
QUIT
SET LEXC=$ORDER(LEXSA(" "),-1)+1
+55 SET LEXSA(LEXC)=(LEXSI_"^"_$PIECE(LEXH,"^",1))
SET LEXSA(0)=LEXC
End DoDot:3
+56 IF LEXSA(0)=1
IF +($GET(LEXSA(1)))>0
IF $ORDER(LEXSA(1))'>0
Begin DoDot:3
+57 NEW LEXSI,LEXEI,LEXEF
SET LEXSI=+($GET(LEXSA(1)))
SET LEXEF=$PIECE($GET(LEXSA(1)),"^",2)
+58 SET LEXEI=+($GET(^LEX(757.02,+LEXSI,0)))
if +LEXEI'>0
QUIT
if LEXEF'?7N
QUIT
+59 SET LEXSIEN=LEXSI
SET LEXEIEN=LEXEI
SET LEXEFF=LEXEF
End DoDot:3
End DoDot:2
+60 if +LEXSIEN'>0
QUIT
if LEXEFF'?7N
QUIT
if +LEXEIEN'>0
QUIT
+61 SET LEXND=$GET(^LEX(757.02,LEXSIEN,0))
if +LEXEIEN'=+LEXND
QUIT
+62 SET LEXEXP=$GET(^LEX(757.01,+LEXEIEN,0))
if '$LENGTH(LEXEXP)
QUIT
+63 if $PIECE($GET(^LEX(757.01,+LEXEIEN,1)),"^",5)>0
QUIT
+64 SET LEXSRC=$PIECE(LEXND,"^",3)
if LEXSRC'=1
QUIT
SET LEXCODE=$PIECE(LEXND,"^",2)
+65 if '$LENGTH(LEXCODE)
QUIT
SET LEXAI=$ORDER(LEXA(" "),-1)+1
+66 SET LEXA(LEXAI)=LEXSIEN_"^"_LEXCODE_"^"_LEXEFF
+67 SET LEXA(LEXAI,0)=LEXEIEN_"^"_LEXEXP
+68 SET LEXA(0)=$ORDER(LEXA(" "),-1)
End DoDot:1
+69 if +($GET(LEXA(0)))'>0
SET LEXA(0)=-1
if +($GET(LEXA(0)))'>0
QUIT
+70 KILL LEX
if LEXPR>0&(+($GET(LEXA(0)))>0)
SET $PIECE(LEXA(0),"^",2)=LEXPR
+71 QUIT
+72 ;
NEXT(LEXC,LEXA,LEXD) ; Next Character
+1 ;
+2 ; Input
+3 ;
+4 ; LEXC Partial Dx Code Required
+5 ; .LEXA Local Array (by Ref) Required
+6 ; LEXD Date (FM Format) Optional (Default TODAY)
+7 ;
+8 ; Output
+9 ;
+10 ; LEXA(<input>,0)= # of characters
+11 ; LEXA(<input>,<character>)=""
+12 ;
+13 NEW LEX1,LEX2,LEXCDT,LEXCHK,LEXCHR,LEXCT,LEXE,LEXLEN,LEXID,LEXNC,LEXNN
+14 NEW LEXOR,LEXPRE,LEXS,LEXSO
SET LEXC=$$TM(LEXC)
+15 if $LENGTH(LEXC)=3&(LEXC'[".")
SET LEXC=LEXC_"."
SET (LEXID,LEXSO)=LEXC
+16 SET LEXCDT=$GET(LEXD)
if LEXCDT'?7N
SET LEXCDT=$$DT^XLFDT
SET LEXLEN=$LENGTH(LEXC)
+17 if LEXLEN>6
QUIT "-1^Max length reached, no next character available"
+18 IF LEXLEN>1
Begin DoDot:1
+19 SET LEXOR=$EXTRACT(LEXSO,1,($LENGTH(LEXSO)-1))_$CHAR($ASCII($EXTRACT(LEXSO,$LENGTH(LEXSO)))-1)_"~"
End DoDot:1
+20 if LEXLEN=1
SET LEXOR=$CHAR($ASCII(LEXSO)-1)_"~"
if LEXLEN'>0
SET LEXOR="/~"
+21 SET LEXCHK=0
if LEXLEN'>0
SET LEXCHK=1
if LEXLEN>0&(LEXLEN<3)
SET LEXCHK=LEXLEN+1
+22 if LEXLEN=3
SET LEXCHK=LEXLEN+2
if LEXLEN>3
SET LEXCHK=LEXLEN+1
+23 if +LEXCHK'>0
QUIT "-1^Character position not specified"
+24 if LEXLEN=0
SET LEXID="<null>"
if '$LENGTH(LEXID)
SET LEXID="<unknown>"
+25 SET LEXNN="^LEX(757.02,""ADX"","""_LEXOR_" "")"
+26 SET LEXNC="^LEX(757.02,""ADX"","""_LEXSO
SET LEXCT=0
+27 FOR
SET LEXNN=$QUERY(@LEXNN)
if '$LENGTH(LEXNN)!(LEXNN'[LEXNC)
QUIT
Begin DoDot:1
+28 NEW LEXC,LEXD,LEXE,LEXS,LEX1,LEX2
+29 SET LEXC=$PIECE(LEXNN,",",3)
SET LEXC=$TRANSLATE(LEXC,"""","")
SET LEXC=$$TM(LEXC)
+30 SET LEXD=+($PIECE(LEXNN,",",4))
if LEXD'?7N
QUIT
if (LEXCDT+.001)'>LEXD
QUIT
+31 IF $EXTRACT(LEXC,1,$LENGTH(LEXSO))=LEXSO
IF $LENGTH(LEXC)'<LEXCHK
Begin DoDot:2
+32 NEW LEXCHR
SET LEXCHR=$EXTRACT(LEXC,LEXCHK)
if '$LENGTH(LEXCHR)
QUIT
+33 IF '$DATA(LEXA(LEXID,LEXCHR))
Begin DoDot:3
+34 SET LEXA(LEXID,LEXCHR)=""
SET LEXCT=LEXCT+1
End DoDot:3
+35 SET LEXOR=$EXTRACT(LEXC,1,LEXCHK)_"~"
+36 SET LEXNN="^LEX(757.02,""ADX"","""_LEXOR_" "")"
End DoDot:2
QUIT
End DoDot:1
+37 if +($GET(LEXCT))>0
SET LEXA(LEXID)=+($GET(LEXCT))
+38 QUIT +($GET(LEXCT))
+39 ;
+40 ; Miscellaneous
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
