ICDEXLK3.m

ICDEXLK3 ;SLC/KER - ICD Extractor - Lookup, Search ;04/21/2014

 ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 7

 ;               

 ; Global Variables

 ;    ^ICDS(              N/A

 ;    ^ICDS("F"           N/A

 ;    ^TMP(ID,$J,         SACC 2.3.2.5.1

 ;               

 ; External References

 ;    $$DT^XLFDT          ICR  10103

 ;    $$UP^XLFSTR         ICR  10104

 ;               

 ; Local Variables Newed or Killed by calling application

 ;     DIC(0)    Fileman Lookup Parameters

 ;  

LK(TXT,ROOT,CDT,SYS,VER,OUT) ; Lookup - Versioned

 ;

 ; Input 

 ; 

 ;   TXT    Text to Search for (Required)

 ;   

 ;             Diagnosis or Procedure Code

 ;             Diagnosis or Procedure Descriptive Text

 ;             

 ;   ROOT   Global Root/File # to Search (Fileman DIC, Required)

 ;   

 ;             ^ICD9(

 ;             ^ICD0(

 ;             

 ;   CDT    Date (default = TODAY) (Optional)

 ;   

 ;   SYS    Coding System (Optional but encouraged)

 ;   

 ;              1      ICD-9-CM

 ;              2      ICD-9 Proc

 ;             30      ICD-10-CM

 ;             31      ICD-10-PCS

 ;

 ;   VER    Versioned Lookup

 ;   

 ;             0  No, include all codes, active and inactive

 ;             1  Yes, include only Active codes for date CDT

 ;

 ;   OUT    Output Format

 ;   

 ;             1  Fileman, Code and Short Text (default)

 ;             

 ;                250.00    DMII CMP NT ST UNCNTR

 ;                

 ;             2  Fileman, Code and Description

 ;             

 ;                250.00    DIABETES MELLITUS NO MENTION OF

 ;                          COMPLICATION, TYPE II OR UNSPECIFIED

 ;                          TYPE, NOT STATED AS UNCONTROLLED

 ;                          

 ;             3  Lexicon, Short Text and Code

 ;             

 ;                DMII CMP NT ST UNCNTR (250.00)

 ;                

 ;             4  Lexicon, Description and Code

 ;             

 ;                DIABETES MELLITUS NO MENTION OF 

 ;                COMPLICATION, TYPE II OR UNSPECIFIED TYPE,

 ;                NOT STATED AS UNCONTROLLED (250.00)

 ;             

 ; Output (if successful)

 ; 

 ;   $$LK  Number of entries found

 ;   

 ;   Global Array of entries found:

 ; 

 ;      ^TMP(ID,$J,"SEL")

 ;      ^TMP(ID,$J,"SEL",0)=# of entries

 ;      ^TMP(ID,$J,"SEL",#)=IEN^Display Text

 ;   

 ;         where ID is a package namespaced subscript:

 ;        

 ;           ICD9 - for the Diagnosis file #80

 ;           ICD0 - for the Operations/Procedure file #80.1

 ;               

 ; Local Variables used but Newed or Killed Elsewhere

 ; 

 ;     DIC(0)

 ;     

 Q $$LK2

 Q

CD(TXT,ROOT,CDT,SYS,VER,OUT) ; Lookup Code - Versioned

 N ICDBYCD S ICDBYCD="" S TXT=$$TM(TXT)

 Q $$LK2

 Q

LK2() ; Lookup - Part 2

 N FILE,IEN,INP1,INP2,KEY,SUB,NUM,NXT,OK,ORD,SEQ,TDT,VCC,VCD,VDS,VSD,VST,PR,PARS,LOR,VII,VNM,Y

 S TXT=$$TM($TR($G(TXT),"#"," ")) Q:'$L(TXT) 0  S ROOT=$$ROOT^ICDEX(ROOT) Q:'$L(ROOT) 0

 S FILE=$$FILE^ICDEX(ROOT) Q:"^80^80.1^"'[("^"_FILE_"^") 0

 S SUB=$TR(ROOT,"^(","") Q:'$L(SUB) 0  K ^TMP(SUB,$J) S CDT=$$CDT($G(CDT))

 S SYS=$S($L($G(SYS)):$$SYS^ICDEX($G(SYS)),1:""),VER=+($G(VER))

 S:+($G(SYS))'>0&(CDT?7N)&(+VER>0) SYS=$$SYS(ROOT,CDT)

 S:$D(^ICDS(+SYS,0))&(+VER>0) CDT=$$DTBR^ICDEX(CDT,,+($G(SYS)))

 S OUT=$G(OUT) S:+OUT'>0 OUT=1 S:+OUT>4 OUT=1

 S INP1=$E(TXT,1),INP2=$E($G(TXT),2,245)

 Q:$D(^TMP(SUB,$J)) +($G(^TMP(SUB,$J,"SEL",0)))

 ;   Exact Match

 I $L(TXT) D

 . N ICDI,LOR K Y,X S LOR=0,X=$$EXM^ICDEXLK5(TXT,ROOT,.Y,CDT,SYS,VER)

 . S ICDI=0 F  S ICDI=$O(Y(ICDI)) Q:+ICDI'>0  D

 . . N IEN S IEN=+($G(Y(ICDI))) Q:+IEN'>0  D FND^ICDEXLK5(ROOT,IEN,CDT,SYS,VER,+($G(LOR)),OUT)

 . I $G(DIC(0))'["A",$G(DIC(0))["O" D

 . . N ENT,TXT,IEN S ENT=$O(^TMP(SUB,$J,"FND",0)) Q:+ENT'>0

 . . S TXT=$G(^TMP(SUB,$J,"FND",+ENT,1)) Q:'$L(TXT)  S IEN=+($P(TXT,"^",1)) Q:+IEN'>0

 . . K ^TMP(SUB,$J,"FND",ENT,1),^TMP(SUB,$J,"FND","IEN",+IEN)

 . . S ^TMP(SUB,$J,"FND",1,1)=TXT,^TMP(SUB,$J,"FND","IEN",+IEN)=""

 I $G(DIC(0))["X" D SEL^ICDEXLK5(ROOT,+($G(LOR))) Q:+($G(^TMP(SUB,$J,"SEL",0)))>0 +($G(^TMP(SUB,$J,"SEL",0)))

 ;   By Code

 D:$L(TXT)'>8&($$ISCODE(TXT,ROOT)>0) CODE

 Q:+($G(^TMP(SUB,$J,"SEL",0)))>0 +($G(^TMP(SUB,$J,"SEL",0)))

 ;   By Text

 D TXT^ICDEXLK4

 Q +($G(^TMP(SUB,$J,"SEL",0)))

 ;

CODE ;   Lookup by Code (Requires TXT and ROOT)

 Q:'$L($G(TXT))  Q:'$L($G(ROOT))  Q:$L(TXT)>8  Q:$G(DIC(0))["B"

 Q:$$ISCODE($G(TXT),$G(ROOT))'>0

 S CDT=$$CDT($G(CDT)) N KEY,ORD,PRV,EROOT

 S KEY=TXT,PRV=+($G(^TMP(SUB,$J,"SEL",0)))

 S ORD=$E(KEY,1,($L(KEY)-1))_$C(($A($E(KEY,$L(KEY)))-1))_"~ "

 S EROOT=ROOT_"""BA""," S:+($G(SYS))>0&($D(@(ROOT_"""ABA"","_+($G(SYS))_")"))) EROOT=ROOT_"""ABA"","_+($G(SYS))_","

 F  S ORD=$O(@(EROOT_""""_ORD_""")")) Q:'$$ISORD  D

 . S IEN=0 I $G(DIC(0))["X",ORD'=KEY Q

 . F  S IEN=$O(@(EROOT_""""_ORD_""","_+IEN_")")) Q:+IEN'>0  D

 . . N STA S STA=1 S:VER>0 STA=$$LS(ROOT,IEN,CDT)

 . . Q:+($G(VER))>0&(+STA'>0)

 . . I $G(DIC(0))'["A",$G(DIC(0))["O",ORD=KEY S CNT=CNT+1 Q:CNT>1

 . . D FND^ICDEXLK5(ROOT,IEN,CDT,$G(SYS),$G(VER),1,OUT)

 I '$D(^TMP(SUB,$J,"FND","IEN")) D

 . S KEY=$$UP^XLFSTR(TXT),PRV=+($G(^TMP(SUB,$J,"SEL",0)))

 . S ORD=$E(KEY,1,($L(KEY)-1))_$C(($A($E(KEY,$L(KEY)))-1))_"~ "

 . S EROOT=ROOT_"""BA""," S:+($G(SYS))>0&($D(@(ROOT_"""ABA"","_+($G(SYS))_")"))) EROOT=ROOT_"""ABA"","_+($G(SYS))_","

 . F  S ORD=$O(@(EROOT_""""_ORD_""")")) Q:'$$ISORD  D

 . . S IEN=0 I $G(DIC(0))["X",ORD'=KEY Q

 . . F  S IEN=$O(@(EROOT_""""_ORD_""","_+IEN_")")) Q:+IEN'>0  D

 . . . N STA S STA=1 S:VER>0 STA=$$LS(ROOT,IEN,CDT)

 . . . Q:+($G(VER))>0&(+STA'>0)

 . . . I $G(DIC(0))'["A",$G(DIC(0))["O",ORD=KEY S CNT=CNT+1 Q:CNT>1

 . . . D FND^ICDEXLK5(ROOT,IEN,CDT,$G(SYS),$G(VER),1,OUT)

 D SEL^ICDEXLK5(ROOT,1)

 Q

 S STA=1 S:VER>0 STA=$$LS^ICDEXLK3(ROOT,IEN,CDT)

 Q:+($G(VER))>0&(+STA'>0)

 ;                    

 ; Miscellaneous

TOK(X) ;   Parse Text into Tokens

 K PARS D PAR^ICDTOKN($G(X),.PARS,1)

 Q

TOKEN(X,ROOT,SYS,ARY) ;   Parse Text into Tokens

 D TOKEN^ICDTOKN($G(X),$G(ROOT),$G(SYS),.ARY)

 Q

SS ;   Show Select/Find Global Arrays

 N NN,NC S NN="^TMP(""ICD9"","_$J_")",NC="^TMP(""ICD9"","_$J_","

 F  S NN=$Q(@NN) Q:'$L(NN)!(NN'[NC)  D

 . W !,NN,"=",@NN Q

 S NN="^TMP(""ICD0"","_$J_")",NC="^TMP(""ICD0"","_$J_","

 F  S NN=$Q(@NN) Q:'$L(NN)!(NN'[NC)  D

 . W !,NN,"=",@NN Q

 Q

WORD(X,ROOT,SYS) ;   Word is contained in a Set

 ;

 ; Input 

 ; 

 ;   X      A single word (Required)

 ;   

 ;   ROOT   Global Root/File # to Search (Optional, if 

 ;          not supplied both files 80 and 80.1 are used)

 ;   

 ;             ^ICD9(   or 80

 ;             ^ICD0(   or 80.1

 ;             

 ;   SYS    Coding System  (Optional, if not supplied all

 ;          coding systems for the file are used)

 ;   

 ;              1  or  ICD  or  ICD-9-CM

 ;              2  or  ICP  or  ICD-9 Proc

 ;             30  or  10D  or  ICD-10-CM

 ;             31  or  10P  or  ICD-10-PCS

 ;

 ; Output (if successful)

 ; 

 ;   $$WORD  Boolean value

 ;   

 ;           1 = Word was found

 ;           

 ;               If ROOT is not supplied, the word was found in 

 ;               either file 80 or 80.1

 ;               

 ;               If SYS is not supplied, the word was found in 

 ;               the file designated by ROOT in any coding system

 ;               in the file

 ;               

 ;               If both ROOT and SYS are supplied, the word was

 ;               found in the specified coding system

 ;               

 ;           0 = Word was not found

 ;           

 N TKN S TKN=$G(X),X=0 Q:'$L(TKN) 0  S ROOT=$$ROOT^ICDEX($G(ROOT)),SYS=$$SYS^ICDEX($G(SYS))

 I '$L(ROOT)!(ROOT'["^")!(ROOT'["(") D  Q X

 . N TRT,FI F FI=80,80.1 S TRT=$$ROOT^ICDEX(FI) D

 . . I +SYS'>0!('$D(^ICDS(+SYS))) D

 . . . N SYS S SYS=0 F  S SYS=$O(@(TRT_"""AD"","_SYS_")")) Q:+SYS'>0  D

 . . . . S:$D(@(TRT_"""AD"","_SYS_","""_TKN_""")")) X=1

 . . I +SYS>0&('$D(^ICDS(+SYS))) D

 . . . S:$D(@(TRT_"""AD"","_+SYS_","""_TKN_""")")) X=1

 I +SYS'>0!('$D(^ICDS(+SYS))) D  Q X

 . N SYS S SYS=0 F  S SYS=$O(@(ROOT_"""AD"","_SYS_")")) Q:+SYS'>0  D

 . . S:$D(@(ROOT_"""AD"","_SYS_","""_TKN_""")")) X=1

 Q:'$L(ROOT)!(ROOT'["^")!(ROOT'["(") 0

 Q:+SYS'>0!('$D(^ICDS(+SYS))) 0

 S:$D(@(ROOT_"""AD"","_+SYS_","""_TKN_""")")) X=1

 Q X

LS(ROOT,IEN,VDT) ;   Last Status

 N EFF,HIS,STA,CDT S IEN=+($G(IEN)),ROOT=$G(ROOT),VDT=$$CDT($G(VDT))

 Q:+IEN'>0 "-1"  Q:'$L(ROOT) "-1"  Q:VDT'?7N "-1"  S CDT=VDT+.00001

 S EFF=$O(@(ROOT_+IEN_",66,""B"","_CDT_")"),-1) Q:EFF'?7N "-1"

 S HIS=$O(@(ROOT_+IEN_",66,""B"","_EFF_","" "")"),-1) Q:+HIS'>0 "-1"

 S STA=$G(@(ROOT_+IEN_",66,"_+HIS_",0)")) Q:'$L(STA) "-1"

 S EFF=$P(STA,"^",1),STA=$P(STA,"^",2) Q:EFF'?7N "-1"  Q:STA'?1N "-1"

 S X=STA_"^"_EFF

 Q X

LD(ROOT,IEN,VDT,VER) ;   Last Description

 N EFF,LDI,LDS,CDT S IEN=+($G(IEN)),ROOT=$G(ROOT),VDT=$$CDT($G(VDT))

 Q:+IEN'>0 ""  Q:'$L(ROOT) ""  Q:VDT'?7N ""  S CDT=VDT+.00001

 S EFF=$O(@(ROOT_+IEN_",68,""B"","_CDT_")"),-1)

 Q:+($G(VER))>0&(EFF'?7N) ""

 S:+($G(VER))'>0&(EFF'?7N) EFF=$O(@(ROOT_+IEN_",68,""B"",0)"))

 S LDI=$O(@(ROOT_+IEN_",68,""B"","_+EFF_","" "")"),-1) Q:+LDI'>0 ""

 S LDS=$$UP^XLFSTR($G(@(ROOT_+IEN_",68,"_+LDI_",1)"))) Q:'$L(LDS) ""

 S X=LDS

 Q X

ISCODE(X,ROOT) ;   Check if Text is a Code

 N KEY,ORG,LAS,ORD,OUT,SI,SYS

 S KEY=$G(X) Q:'$L($TR(KEY,"""","")) 0

 S ORG=$E(KEY,1,($L(KEY)-1))_$C(($A($E(KEY,$L(KEY)))-1))_"~ "

 S OUT=0,SI=0

 F  S SI=$O(^ICDS(SI)) Q:+SI'>0  D  Q:+OUT>0

 . N ORD,RES S ORD=ORG

 . S RES=$O(@(ROOT_"""ABA"","_+SI_","""_ORD_""")"))

 . Q:'$L(RES)  S:$E(RES,$L(RES))=" " RES=$E(RES,1,($L(RES)-1))

 . I RES=KEY S OUT="1^"_SI_"^"_KEY Q

 . I $L(KEY)<$L(RES),KEY=$E(RES,1,$L(KEY)) S OUT="1^"_SI_"^"_KEY

 S KEY=$$UP^XLFSTR($G(X))

 S ORG=$E(KEY,1,($L(KEY)-1))_$C(($A($E(KEY,$L(KEY)))-1))_"~ "

 S SI=0 F  S SI=$O(^ICDS(SI)) Q:+SI'>0  D  Q:+OUT>0

 . N ORD,RES S ORD=ORG

 . S RES=$O(@(ROOT_"""ABA"","_+SI_","""_ORD_""")"))

 . Q:'$L(RES)  S:$E(RES,$L(RES))=" " RES=$E(RES,1,($L(RES)-1))

 . I RES=KEY S OUT="1^"_SI_"^"_KEY Q

 . I $L(KEY)<$L(RES),KEY=$E(RES,1,$L(KEY)) S OUT="1^"_SI_"^"_KEY

 Q:+OUT>0 OUT

 Q 0

UNQ(X,ROOT) ;   Check if Text is a Unique Code

 ;

 ; Input

 ; 

 ;   X      Input String/Code

 ;   ROOT   Global Root of file

 ;   

 ; Output

 ; 

 ;   $$UNQ  3 Piece ^ delimited string

 ;   

 ;             Piece  Content

 ;             1      String is Unique in file

 ;                       1 if X is unique

 ;                       0 if X is not unique

 ;             2      String is a Code

 ;                       1 is a code

 ;                       0 X is not a code

 ;             3      String has Multiple Entries

 ;                       1 Yes, X occurs more than once

 ;                       0 No, X occurs once (aka unique)

 ;             

 ;          or -1 if the code string X is not found

 ;

 N KEY,ORG,LAS,ORD,OUT,IENS,IEN,NXT,NIEN,SI,SYS Q:'$L($G(X)) -1

 S KEY=$TR($G(X),"""","") Q:'$L(KEY) -1

 S ORG=$E(KEY,1,($L(KEY)-1))_$C(($A($E(KEY,$L(KEY)))-1))_"~ "

 S OUT=-1,(IEN,NXT,SI)=0

 F  S SI=$O(@(ROOT_"""ABA"","_+SI_")")) Q:+SI'>0  D  Q:OUT>0  Q:+IEN>0  Q:+NXT>0

 . N ORD S ORD=ORG S IEN=$O(@(ROOT_"""ABA"","_+SI_","""_KEY_" "",0)"))

 . S (NXT,NIEN)=0

 . F  S ORD=$O(@(ROOT_"""ABA"","_+SI_","""_ORD_""")")) Q:'$L(ORD)  Q:$E(ORD,1,$L(KEY))'=KEY  D

 . . S NIEN=0 F  S NIEN=$O(@(ROOT_"""ABA"","_+SI_","""_ORD_""","_NIEN_")")) Q:+NIEN'>0  D

 . . . S:ORD'=(KEY_" ") IENS(+NIEN)=""

 S (NXT,NIEN)=0 F  S NIEN=$O(IENS(NIEN)) Q:+NIEN'>0  S NXT=NXT+1

 S:+IEN>0 $P(OUT,"^",1)=1,$P(OUT,"^",2)=1

 I +IEN>0 S:+NXT>0 $P(OUT,"^",3)=1,$P(OUT,"^",1)=0

 I +($G(OUT))'<0 F SI=1:1:3 S $P(OUT,"^",SI)=+($P($G(OUT),"^",SI))

 I NXT>0,+IEN'>0 S OUT=$S(NXT>1:0,1:1)_"^0^"_$S(NXT>1:1,1:0)

 S X=OUT

 Q X

ISORD(X) ;   Check if in $ORDER

 Q:'$L($G(ORD)) 0  Q:'$L($G(KEY)) 0

 Q:$E($G(ORD),1,$L($G(KEY)))=$G(KEY) 1

 Q 0

CDT(X,Y) ;   ICD-10 Code Set Date

 N CDT,SYS S CDT=$G(X),SYS=+($G(Y)) S:CDT'?7N CDT=$$DT^XLFDT

 Q X

SYS(ROOT,CDT) ;   System from File and Date

 N FILE,CTL,FDT,NDT,IEN,SYS S (NDT,SYS)=0

 S FILE=$S($G(ROOT)="^ICD9(":80,$G(ROOT)="^ICD0(":80.1,1:"") Q:FILE'>0 0

 S CTL=$G(CDT) Q:CTL'?7N 0

 S IEN=0 F  S IEN=$O(^ICDS("F",FILE,IEN)) Q:+IEN'>0  D

 . S FDT=$P($G(^ICDS(+IEN,0)),"^",4) Q:FDT'?7N

 . I FDT<(CTL+.001),FDT>NDT S FDT=CTL,SYS=IEN

 Q SYS

SH ;   Show TMP

 N SUB,NN,NC S SUB="ICD9" S:'$D(^TMP(SUB)) SUB="ICD0" Q:'$D(^TMP(SUB))

 S NN="^TMP("""_SUB_""","_$J_")",NC="^TMP("""_SUB_""","_$J_","

 W:'$D(@NN) ! Q:'$D(@NN)  F  S NN=$Q(@NN) Q:'$L(NN)!(NN'[NC)  W !,NN,"=",@NN

 W !

 Q

TM(X,Y) ;   Trim Y

 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

ICDEXLK3  ;SLC/KER - ICD Extractor - Lookup, Search ;04/21/2014

 +1       ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 7

 +2       ;               

 +3       ; Global Variables

 +4       ;    ^ICDS(              N/A

 +5       ;    ^ICDS("F"           N/A

 +6       ;    ^TMP(ID,$J,         SACC 2.3.2.5.1

 +7       ;               

 +8       ; External References

 +9       ;    $$DT^XLFDT          ICR  10103

 +10      ;    $$UP^XLFSTR         ICR  10104

 +11      ;               

 +12      ; Local Variables Newed or Killed by calling application

 +13      ;     DIC(0)    Fileman Lookup Parameters

 +14      ;  

LK(TXT,ROOT,CDT,SYS,VER,OUT) ; Lookup - Versioned

 +1       ;

 +2       ; Input 

 +3       ; 

 +4       ;   TXT    Text to Search for (Required)

 +5       ;   

 +6       ;             Diagnosis or Procedure Code

 +7       ;             Diagnosis or Procedure Descriptive Text

 +8       ;             

 +9       ;   ROOT   Global Root/File # to Search (Fileman DIC, Required)

 +10      ;   

 +11      ;             ^ICD9(

 +12      ;             ^ICD0(

 +13      ;             

 +14      ;   CDT    Date (default = TODAY) (Optional)

 +15      ;   

 +16      ;   SYS    Coding System (Optional but encouraged)

 +17      ;   

 +18      ;              1      ICD-9-CM

 +19      ;              2      ICD-9 Proc

 +20      ;             30      ICD-10-CM

 +21      ;             31      ICD-10-PCS

 +22      ;

 +23      ;   VER    Versioned Lookup

 +24      ;   

 +25      ;             0  No, include all codes, active and inactive

 +26      ;             1  Yes, include only Active codes for date CDT

 +27      ;

 +28      ;   OUT    Output Format

 +29      ;   

 +30      ;             1  Fileman, Code and Short Text (default)

 +31      ;             

 +32      ;                250.00    DMII CMP NT ST UNCNTR

 +33      ;                

 +34      ;             2  Fileman, Code and Description

 +35      ;             

 +36      ;                250.00    DIABETES MELLITUS NO MENTION OF

 +37      ;                          COMPLICATION, TYPE II OR UNSPECIFIED

 +38      ;                          TYPE, NOT STATED AS UNCONTROLLED

 +39      ;                          

 +40      ;             3  Lexicon, Short Text and Code

 +41      ;             

 +42      ;                DMII CMP NT ST UNCNTR (250.00)

 +43      ;                

 +44      ;             4  Lexicon, Description and Code

 +45      ;             

 +46      ;                DIABETES MELLITUS NO MENTION OF 

 +47      ;                COMPLICATION, TYPE II OR UNSPECIFIED TYPE,

 +48      ;                NOT STATED AS UNCONTROLLED (250.00)

 +49      ;             

 +50      ; Output (if successful)

 +51      ; 

 +52      ;   $$LK  Number of entries found

 +53      ;   

 +54      ;   Global Array of entries found:

 +55      ; 

 +56      ;      ^TMP(ID,$J,"SEL")

 +57      ;      ^TMP(ID,$J,"SEL",0)=# of entries

 +58      ;      ^TMP(ID,$J,"SEL",#)=IEN^Display Text

 +59      ;   

 +60      ;         where ID is a package namespaced subscript:

 +61      ;        

 +62      ;           ICD9 - for the Diagnosis file #80

 +63      ;           ICD0 - for the Operations/Procedure file #80.1

 +64      ;               

 +65      ; Local Variables used but Newed or Killed Elsewhere

 +66      ; 

 +67      ;     DIC(0)

 +68      ;     

 +69       QUIT $$LK2

 +70       QUIT 

CD(TXT,ROOT,CDT,SYS,VER,OUT) ; Lookup Code - Versioned

 +1        NEW ICDBYCD

           SET ICDBYCD=""

           SET TXT=$$TM(TXT)

 +2        QUIT $$LK2

 +3        QUIT 

LK2()     ; Lookup - Part 2

 +1        NEW FILE,IEN,INP1,INP2,KEY,SUB,NUM,NXT,OK,ORD,SEQ,TDT,VCC,VCD,VDS,VSD,VST,PR,PARS,LOR,VII,VNM,Y

 +2        SET TXT=$$TM($TRANSLATE($GET(TXT),"#"," "))

           IF '$LENGTH(TXT)

               QUIT 0

           SET ROOT=$$ROOT^ICDEX(ROOT)

           IF '$LENGTH(ROOT)

               QUIT 0

 +3        SET FILE=$$FILE^ICDEX(ROOT)

           IF "^80^80.1^"'[("^"_FILE_"^")

               QUIT 0

 +4        SET SUB=$TRANSLATE(ROOT,"^(","")

           IF '$LENGTH(SUB)

               QUIT 0

           KILL ^TMP(SUB,$JOB)

           SET CDT=$$CDT($GET(CDT))

 +5        SET SYS=$SELECT($LENGTH($GET(SYS)):$$SYS^ICDEX($GET(SYS)),1:"")

           SET VER=+($GET(VER))

 +6        IF +($GET(SYS))'>0&(CDT?7N)&(+VER>0)

               SET SYS=$$SYS(ROOT,CDT)

 +7        IF $DATA(^ICDS(+SYS,0))&(+VER>0)

               SET CDT=$$DTBR^ICDEX(CDT,,+($GET(SYS)))

 +8        SET OUT=$GET(OUT)

           IF +OUT'>0

               SET OUT=1

           IF +OUT>4

               SET OUT=1

 +9        SET INP1=$EXTRACT(TXT,1)

           SET INP2=$EXTRACT($GET(TXT),2,245)

 +10       IF $DATA(^TMP(SUB,$JOB))

               QUIT +($GET(^TMP(SUB,$JOB,"SEL",0)))

 +11      ;   Exact Match

 +12       IF $LENGTH(TXT)

               Begin DoDot:1

 +13               NEW ICDI,LOR

                   KILL Y,X

                   SET LOR=0

                   SET X=$$EXM^ICDEXLK5(TXT,ROOT,.Y,CDT,SYS,VER)

 +14               SET ICDI=0

                   FOR 

                       SET ICDI=$ORDER(Y(ICDI))

                       IF +ICDI'>0

                           QUIT 

                       Begin DoDot:2

 +15                       NEW IEN

                           SET IEN=+($GET(Y(ICDI)))

                           IF +IEN'>0

                               QUIT 

                           DO FND^ICDEXLK5(ROOT,IEN,CDT,SYS,VER,+($GET(LOR)),OUT)

                       End DoDot:2

 +16               IF $GET(DIC(0))'["A"

                       IF $GET(DIC(0))["O"

                           Begin DoDot:2

 +17                           NEW ENT,TXT,IEN

                               SET ENT=$ORDER(^TMP(SUB,$JOB,"FND",0))

                               IF +ENT'>0

                                   QUIT 

 +18                           SET TXT=$GET(^TMP(SUB,$JOB,"FND",+ENT,1))

                               IF '$LENGTH(TXT)

                                   QUIT 

                               SET IEN=+($PIECE(TXT,"^",1))

                               IF +IEN'>0

                                   QUIT 

 +19                           KILL ^TMP(SUB,$JOB,"FND",ENT,1),^TMP(SUB,$JOB,"FND","IEN",+IEN)

 +20                           SET ^TMP(SUB,$JOB,"FND",1,1)=TXT

                               SET ^TMP(SUB,$JOB,"FND","IEN",+IEN)=""

                           End DoDot:2

               End DoDot:1

 +21       IF $GET(DIC(0))["X"

               DO SEL^ICDEXLK5(ROOT,+($GET(LOR)))

               IF +($GET(^TMP(SUB,$JOB,"SEL",0)))>0

                   QUIT +($GET(^TMP(SUB,$JOB,"SEL",0)))

 +22      ;   By Code

 +23       IF $LENGTH(TXT)'>8&($$ISCODE(TXT,ROOT)>0)

               DO CODE

 +24       IF +($GET(^TMP(SUB,$JOB,"SEL",0)))>0

               QUIT +($GET(^TMP(SUB,$JOB,"SEL",0)))

 +25      ;   By Text

 +26       DO TXT^ICDEXLK4

 +27       QUIT +($GET(^TMP(SUB,$JOB,"SEL",0)))

 +28      ;

CODE      ;   Lookup by Code (Requires TXT and ROOT)

 +1        IF '$LENGTH($GET(TXT))

               QUIT 

           IF '$LENGTH($GET(ROOT))

               QUIT 

           IF $LENGTH(TXT)>8

               QUIT 

           IF $GET(DIC(0))["B"

               QUIT 

 +2        IF $$ISCODE($GET(TXT),$GET(ROOT))'>0

               QUIT 

 +3        SET CDT=$$CDT($GET(CDT))

           NEW KEY,ORD,PRV,EROOT

 +4        SET KEY=TXT

           SET PRV=+($GET(^TMP(SUB,$JOB,"SEL",0)))

 +5        SET ORD=$EXTRACT(KEY,1,($LENGTH(KEY)-1))_$CHAR(($ASCII($EXTRACT(KEY,$LENGTH(KEY)))-1))_"~ "

 +6        SET EROOT=ROOT_"""BA"","

           IF +($GET(SYS))>0&($DATA(@(ROOT_"""ABA"","_+($GET(SYS))_")")))

               SET EROOT=ROOT_"""ABA"","_+($GET(SYS))_","

 +7        FOR 

               SET ORD=$ORDER(@(EROOT_""""_ORD_""")"))

               IF '$$ISORD

                   QUIT 

               Begin DoDot:1

 +8                SET IEN=0

                   IF $GET(DIC(0))["X"

                       IF ORD'=KEY

                           QUIT 

 +9                FOR 

                       SET IEN=$ORDER(@(EROOT_""""_ORD_""","_+IEN_")"))

                       IF +IEN'>0

                           QUIT 

                       Begin DoDot:2

 +10                       NEW STA

                           SET STA=1

                           IF VER>0

                               SET STA=$$LS(ROOT,IEN,CDT)

 +11                       IF +($GET(VER))>0&(+STA'>0)

                               QUIT 

 +12                       IF $GET(DIC(0))'["A"

                               IF $GET(DIC(0))["O"

                                   IF ORD=KEY

                                       SET CNT=CNT+1

                                       IF CNT>1

                                           QUIT 

 +13                       DO FND^ICDEXLK5(ROOT,IEN,CDT,$GET(SYS),$GET(VER),1,OUT)

                       End DoDot:2

               End DoDot:1

 +14       IF '$DATA(^TMP(SUB,$JOB,"FND","IEN"))

               Begin DoDot:1

 +15               SET KEY=$$UP^XLFSTR(TXT)

                   SET PRV=+($GET(^TMP(SUB,$JOB,"SEL",0)))

 +16               SET ORD=$EXTRACT(KEY,1,($LENGTH(KEY)-1))_$CHAR(($ASCII($EXTRACT(KEY,$LENGTH(KEY)))-1))_"~ "

 +17               SET EROOT=ROOT_"""BA"","

                   IF +($GET(SYS))>0&($DATA(@(ROOT_"""ABA"","_+($GET(SYS))_")")))

                       SET EROOT=ROOT_"""ABA"","_+($GET(SYS))_","

 +18               FOR 

                       SET ORD=$ORDER(@(EROOT_""""_ORD_""")"))

                       IF '$$ISORD

                           QUIT 

                       Begin DoDot:2

 +19                       SET IEN=0

                           IF $GET(DIC(0))["X"

                               IF ORD'=KEY

                                   QUIT 

 +20                       FOR 

                               SET IEN=$ORDER(@(EROOT_""""_ORD_""","_+IEN_")"))

                               IF +IEN'>0

                                   QUIT 

                               Begin DoDot:3

 +21                               NEW STA

                                   SET STA=1

                                   IF VER>0

                                       SET STA=$$LS(ROOT,IEN,CDT)

 +22                               IF +($GET(VER))>0&(+STA'>0)

                                       QUIT 

 +23                               IF $GET(DIC(0))'["A"

                                       IF $GET(DIC(0))["O"

                                           IF ORD=KEY

                                               SET CNT=CNT+1

                                               IF CNT>1

                                                   QUIT 

 +24                               DO FND^ICDEXLK5(ROOT,IEN,CDT,$GET(SYS),$GET(VER),1,OUT)

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +25       DO SEL^ICDEXLK5(ROOT,1)

 +26       QUIT 

 +27       SET STA=1

           IF VER>0

               SET STA=$$LS^ICDEXLK3(ROOT,IEN,CDT)

 +28       IF +($GET(VER))>0&(+STA'>0)

               QUIT 

 +29      ;                    

 +30      ; Miscellaneous

TOK(X)    ;   Parse Text into Tokens

 +1        KILL PARS

           DO PAR^ICDTOKN($GET(X),.PARS,1)

 +2        QUIT 

TOKEN(X,ROOT,SYS,ARY) ;   Parse Text into Tokens

 +1        DO TOKEN^ICDTOKN($GET(X),$GET(ROOT),$GET(SYS),.ARY)