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