Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LEX10DBC

LEX10DBC.m

Go to the documentation of this file.
  1. LEX10DBC ;ISL/KER - ICD-10 Diagnosis Lookup by Code ;11/16/2016
  1. ;;2.0;LEXICON UTILITY;**80,110**;Sep 23, 1996;Build 6
  1. ;
  1. ; Global Variables
  1. ; ^TMP("LEXDX") SACC 2.3.2.5.1
  1. ;
  1. ; External References
  1. ; ^DIM ICR 10016
  1. ; $$DT^XLFDT ICR 10103
  1. ;
  1. I10C(LEXC,LEXA,LEXD,LEXN,LEXF) ; Lookup by Code, Return Pruned List
  1. ;
  1. ; Input
  1. ; LEXC ICD-10 DX Code Required
  1. ; .LEXA Local Array (by Ref) Required
  1. ; LEXD Date (FM Format) Optional (Default TODAY)
  1. ; LEXL Maximum to Return Optional (Default = 30)
  1. ; LEXF Filter Optional (Default 10D)
  1. ;
  1. ; Output
  1. ;
  1. ; Code is found:
  1. ;
  1. ; LEXA(0)=# ^ PI No to exceed lenght where possible
  1. ; LEXA(#)=<code ien>_"^"_<code>_"^"_<activation date>
  1. ; LEXA(#,0)=<expression ien>_"^"_<expression>
  1. ;
  1. ; No Code, Category is Returned:
  1. ;
  1. ; LEXA(#)=<NULL>_"^"_<category>_"^"_<activation date> ^
  1. ; <number of codes in the category>
  1. ; LEXA(#,0)=<NULL>_"^"_<category name>
  1. ;
  1. ; Note: Second piece of LEXA(0) is the pruning
  1. ; indicator and set to "1" if pruning
  1. ; occurred
  1. ;
  1. ; See WD^LEX10DP for DX Text Lookup by Keywords (Pruned)
  1. ;
  1. K ^TMP("LEXDX",$J),LEXA N LEXSO,LEXCDT,LEXCT,LEXFIL,LEXNUM,LEXUSE
  1. N LEXFND,LEXTOT S LEXSO=$G(LEXC),LEXCDT=$G(LEXD),LEXNUM=+($G(LEXN))
  1. S LEXFIL=$G(LEXF) S LEXUSE=0 Q:'$L(LEXSO)
  1. S:$L(LEXSO)=3&(LEXSO'[".") LEXSO=LEXSO_"."
  1. S LEXA(0)=-1
  1. S:'$L(LEXFIL) LEXFIL="I $$SO^LEXU(Y,""10D"",+($G(LEXVDT)))"
  1. S:LEXNUM'>0 LEXNUM=30 S (LEXFND,LEXCT)=$$FIND(LEXSO,LEXCDT,LEXFIL)
  1. D REDUCE^LEX10DU(LEXNUM) D ARY^LEX10DU
  1. S LEXTOT=+($O(LEXA(" "),-1))
  1. S:LEXTOT>0&(LEXTOT<LEXFND) $P(LEXA(0),"^",2)=1
  1. K ^TMP("LEXDX",$J)
  1. Q
  1. ; Code Search
  1. FIND(LEXC,LEXD,LEXF) ; Find All Codes
  1. N LEX1,LEX2,LEXVDT,LEXCT,LEXFIL,LEXLEN,LEXNC,LEXNN,LEXOR,LEXPRE
  1. S LEXFIL=$G(LEXF) S:'$L(LEXFIL) LEXFIL="I 1"
  1. S LEXSO=$G(LEXC),LEXVDT=$G(LEXD)
  1. S LEXOR=$E(LEXSO,1,($L(LEXSO)-1))_$C($A($E(LEXSO,$L(LEXSO)))-1)_"~"
  1. S LEXNN="^LEX(757.02,""ADX"","""_LEXOR_" "")"
  1. S LEXNC="^LEX(757.02,""ADX"","""_LEXSO
  1. S (LEXPRE,LEXLEN,LEXCT)=0
  1. F S LEXNN=$Q(@LEXNN) Q:'$L(LEXNN)!(LEXNN'[LEXNC) D
  1. . N LEXC,LEXD,LEXE,LEXS,LEX1,LEX2
  1. . S LEXC=$P(LEXNN,",",3),LEXC=$TR(LEXC,"""",""),LEXC=$$TM(LEXC)
  1. . S LEXD=+($P(LEXNN,",",4)) Q:LEXD'?7N Q:LEXVDT?7N&((LEXVDT+.001)'>LEXD)
  1. . S LEXS=+($P(LEXNN,",",5)) Q:LEXS'?1N I LEXS="0" D Q:LEXS'=1
  1. . . I LEXVDT?7N,(LEXVDT+.001)>+($G(LEXD)) D
  1. . . . S:$D(^TMP("LEXDX",$J,(LEXC_" "))) LEXCT=LEXCT-1 K ^TMP("LEXDX",$J,(LEXC_" "))
  1. . S LEX1=+($P(LEXNN,",",6)) Q:LEX1'?1N.N Q:LEX1'>0
  1. . Q:$P($G(^LEX(757.02,+LEX1,0)),"^",5)'>0
  1. . S LEXE=+($G(^LEX(757.02,+LEX1,0))) Q:LEXE'?1N.N Q:LEXE'>0
  1. . Q:$$SCR(LEXFIL,LEXE)'>0
  1. . S LEX2=+($P(LEXNN,",",7)) Q:LEX1'?1N.N Q:LEX2'>0
  1. . Q:$P($G(^LEX(757.01,+LEXE,1)),"^",5)>0
  1. . S:$L(LEXC)>LEXLEN LEXPRE=LEXLEN,LEXLEN=$L(LEXC)
  1. . S:LEXPRE=0 LEXPRE=$L(LEXC) S:$L(LEXC)=(LEXLEN-1) LEXPRE=$L(LEXC)
  1. . S LEXCT=LEXCT+1,^TMP("LEXDX",$J,(LEXC_" "))=LEX1_"^"_LEXD
  1. Q LEXCT
  1. ;
  1. ; Miscellaneous
  1. SCR(X,Y) ; Screen
  1. S Y=+($G(Y)) Q:+Y'>0 0 Q:'$D(^LEX(757.01,+Y,0)) 0
  1. N LEXFIL S LEXFIL=$G(X) Q:'$L(LEXFIL) 1 D ^DIM Q:'$D(X) 1
  1. X LEXFIL S X=$T
  1. Q X
  1. TM(X,Y) ; Trim Character Y - Default " "
  1. S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" "
  1. F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
  1. F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
  1. Q X