ICDEXLK3 ;SLC/KER - ICD Extractor - Lookup, Search ;07/15/2015
;;18.0;DRG Grouper;**57,67,82**;Oct 20, 2000;Build 21
;
; 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($G(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)
;
I INP1="`",INP2?1N.N D Q:+($G(^TMP(SUB,$J,"SEL",0)))>0 +($G(^TMP(SUB,$J,"SEL",0)))
. N ICDCDT,IEN1,IEN2 S ICDCDT=$G(CDT) D IEN^ICDEXLK5
. I +($G(Y))>0 D FND^ICDEXLK5(ROOT,+($G(Y)),CDT,SYS,VER,+($G(LOR)),OUT)
. D:$O(^TMP("ICD9",$J,"FND","IEN",0))>0 SEL^ICDEXLK5(ROOT,1)
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDEXLK3 13045 printed Apr 09, 2024@20:55:51 Page 2
ICDEXLK3 ;SLC/KER - ICD Extractor - Lookup, Search ;07/15/2015
+1 ;;18.0;DRG Grouper;**57,67,82**;Oct 20, 2000;Build 21
+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($GET(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 ;
+11 IF INP1="`"
IF INP2?1N.N
Begin DoDot:1
+12 NEW ICDCDT,IEN1,IEN2
SET ICDCDT=$GET(CDT)
DO IEN^ICDEXLK5
+13 IF +($GET(Y))>0
DO FND^ICDEXLK5(ROOT,+($GET(Y)),CDT,SYS,VER,+($GET(LOR)),OUT)
+14 if $ORDER(^TMP("ICD9",$JOB,"FND","IEN",0))>0
DO SEL^ICDEXLK5(ROOT,1)
End DoDot:1
if +($GET(^TMP(SUB,$JOB,"SEL",0)))>0
QUIT +($GET(^TMP(SUB,$JOB,"SEL",0)))
+15 ;
+16 if $DATA(^TMP(SUB,$JOB))
QUIT +($GET(^TMP(SUB,$JOB,"SEL",0)))
+17 ; Exact Match
+18 IF $LENGTH(TXT)
Begin DoDot:1
+19 NEW ICDI,LOR
KILL Y,X
SET LOR=0
SET X=$$EXM^ICDEXLK5(TXT,ROOT,.Y,CDT,SYS,VER)
+20 SET ICDI=0
FOR
SET ICDI=$ORDER(Y(ICDI))
if +ICDI'>0
QUIT
Begin DoDot:2
+21 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
+22 IF $GET(DIC(0))'["A"
IF $GET(DIC(0))["O"
Begin DoDot:2
+23 NEW ENT,TXT,IEN
SET ENT=$ORDER(^TMP(SUB,$JOB,"FND",0))
if +ENT'>0
QUIT
+24 SET TXT=$GET(^TMP(SUB,$JOB,"FND",+ENT,1))
if '$LENGTH(TXT)
QUIT
SET IEN=+($PIECE(TXT,"^",1))
if +IEN'>0
QUIT
+25 KILL ^TMP(SUB,$JOB,"FND",ENT,1),^TMP(SUB,$JOB,"FND","IEN",+IEN)
+26 SET ^TMP(SUB,$JOB,"FND",1,1)=TXT
SET ^TMP(SUB,$JOB,"FND","IEN",+IEN)=""
End DoDot:2
End DoDot:1
+27 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)))
+28 ; By Code
+29 if $LENGTH(TXT)'>8&($$ISCODE(TXT,ROOT)>0)
DO CODE
+30 if +($GET(^TMP(SUB,$JOB,"SEL",0)))>0
QUIT +($GET(^TMP(SUB,$JOB,"SEL",0)))
+31 ; By Text
+32 DO TXT^ICDEXLK4
+33 QUIT +($GET(^TMP(SUB,$JOB,"SEL",0)))
+34 ;
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)
+2 QUIT
SS ; Show Select/Find Global Arrays
+1 NEW NN,NC
SET NN="^TMP(""ICD9"","_$JOB_")"
SET NC="^TMP(""ICD9"","_$JOB_","
+2 FOR
SET NN=$QUERY(@NN)
if '$LENGTH(NN)!(NN'[NC)
QUIT
Begin DoDot:1
+3 WRITE !,NN,"=",@NN
QUIT
End DoDot:1
+4 SET NN="^TMP(""ICD0"","_$JOB_")"
SET NC="^TMP(""ICD0"","_$JOB_","
+5 FOR
SET NN=$QUERY(@NN)
if '$LENGTH(NN)!(NN'[NC)
QUIT
Begin DoDot:1
+6 WRITE !,NN,"=",@NN
QUIT
End DoDot:1
+7 QUIT
WORD(X,ROOT,SYS) ; Word is contained in a Set
+1 ;
+2 ; Input
+3 ;
+4 ; X A single word (Required)
+5 ;
+6 ; ROOT Global Root/File # to Search (Optional, if
+7 ; not supplied both files 80 and 80.1 are used)
+8 ;
+9 ; ^ICD9( or 80
+10 ; ^ICD0( or 80.1
+11 ;
+12 ; SYS Coding System (Optional, if not supplied all
+13 ; coding systems for the file are used)
+14 ;
+15 ; 1 or ICD or ICD-9-CM
+16 ; 2 or ICP or ICD-9 Proc
+17 ; 30 or 10D or ICD-10-CM
+18 ; 31 or 10P or ICD-10-PCS
+19 ;
+20 ; Output (if successful)
+21 ;
+22 ; $$WORD Boolean value
+23 ;
+24 ; 1 = Word was found
+25 ;
+26 ; If ROOT is not supplied, the word was found in
+27 ; either file 80 or 80.1
+28 ;
+29 ; If SYS is not supplied, the word was found in
+30 ; the file designated by ROOT in any coding system
+31 ; in the file
+32 ;
+33 ; If both ROOT and SYS are supplied, the word was
+34 ; found in the specified coding system
+35 ;
+36 ; 0 = Word was not found
+37 ;
+38 NEW TKN
SET TKN=$GET(X)
SET X=0
if '$LENGTH(TKN)
QUIT 0
SET ROOT=$$ROOT^ICDEX($GET(ROOT))
SET SYS=$$SYS^ICDEX($GET(SYS))
+39 IF '$LENGTH(ROOT)!(ROOT'["^")!(ROOT'["(")
Begin DoDot:1
+40 NEW TRT,FI
FOR FI=80,80.1
SET TRT=$$ROOT^ICDEX(FI)
Begin DoDot:2
+41 IF +SYS'>0!('$DATA(^ICDS(+SYS)))
Begin DoDot:3
+42 NEW SYS
SET SYS=0
FOR
SET SYS=$ORDER(@(TRT_"""AD"","_SYS_")"))
if +SYS'>0
QUIT
Begin DoDot:4
+43 if $DATA(@(TRT_"""AD"","_SYS_","""_TKN_""")"))
SET X=1
End DoDot:4
End DoDot:3
+44 IF +SYS>0&('$DATA(^ICDS(+SYS)))
Begin DoDot:3
+45 if $DATA(@(TRT_"""AD"","_+SYS_","""_TKN_""")"))
SET X=1
End DoDot:3
End DoDot:2
End DoDot:1
QUIT X
+46 IF +SYS'>0!('$DATA(^ICDS(+SYS)))
Begin DoDot:1
+47 NEW SYS
SET SYS=0
FOR
SET SYS=$ORDER(@(ROOT_"""AD"","_SYS_")"))
if +SYS'>0
QUIT
Begin DoDot:2
+48 if $DATA(@(ROOT_"""AD"","_SYS_","""_TKN_""")"))
SET X=1
End DoDot:2
End DoDot:1
QUIT X
+49 if '$LENGTH(ROOT)!(ROOT'["^")!(ROOT'["(")
QUIT 0
+50 if +SYS'>0!('$DATA(^ICDS(+SYS)))
QUIT 0
+51 if $DATA(@(ROOT_"""AD"","_+SYS_","""_TKN_""")"))
SET X=1
+52 QUIT X
LS(ROOT,IEN,VDT) ; Last Status
+1 NEW EFF,HIS,STA,CDT
SET IEN=+($GET(IEN))
SET ROOT=$GET(ROOT)
SET VDT=$$CDT($GET(VDT))
+2 if +IEN'>0
QUIT "-1"
if '$LENGTH(ROOT)
QUIT "-1"
if VDT'?7N
QUIT "-1"
SET CDT=VDT+.00001
+3 SET EFF=$ORDER(@(ROOT_+IEN_",66,""B"","_CDT_")"),-1)
if EFF'?7N
QUIT "-1"
+4 SET HIS=$ORDER(@(ROOT_+IEN_",66,""B"","_EFF_","" "")"),-1)
if +HIS'>0
QUIT "-1"
+5 SET STA=$GET(@(ROOT_+IEN_",66,"_+HIS_",0)"))
if '$LENGTH(STA)
QUIT "-1"
+6 SET EFF=$PIECE(STA,"^",1)
SET STA=$PIECE(STA,"^",2)
if EFF'?7N
QUIT "-1"
if STA'?1N
QUIT "-1"
+7 SET X=STA_"^"_EFF
+8 QUIT X
LD(ROOT,IEN,VDT,VER) ; Last Description
+1 NEW EFF,LDI,LDS,CDT
SET IEN=+($GET(IEN))
SET ROOT=$GET(ROOT)
SET VDT=$$CDT($GET(VDT))
+2 if +IEN'>0
QUIT ""
if '$LENGTH(ROOT)
QUIT ""
if VDT'?7N
QUIT ""
SET CDT=VDT+.00001
+3 SET EFF=$ORDER(@(ROOT_+IEN_",68,""B"","_CDT_")"),-1)
+4 if +($GET(VER))>0&(EFF'?7N)
QUIT ""
+5 if +($GET(VER))'>0&(EFF'?7N)
SET EFF=$ORDER(@(ROOT_+IEN_",68,""B"",0)"))
+6 SET LDI=$ORDER(@(ROOT_+IEN_",68,""B"","_+EFF_","" "")"),-1)
if +LDI'>0
QUIT ""
+7 SET LDS=$$UP^XLFSTR($GET(@(ROOT_+IEN_",68,"_+LDI_",1)")))
if '$LENGTH(LDS)
QUIT ""
+8 SET X=LDS
+9 QUIT X
ISCODE(X,ROOT) ; Check if Text is a Code
+1 NEW KEY,ORG,LAS,ORD,OUT,SI,SYS
+2 SET KEY=$GET(X)
if '$LENGTH($TRANSLATE(KEY,"""",""))
QUIT 0
+3 SET ORG=$EXTRACT(KEY,1,($LENGTH(KEY)-1))_$CHAR(($ASCII($EXTRACT(KEY,$LENGTH(KEY)))-1))_"~ "
+4 SET OUT=0
SET SI=0
+5 FOR
SET SI=$ORDER(^ICDS(SI))
if +SI'>0
QUIT
Begin DoDot:1
+6 NEW ORD,RES
SET ORD=ORG
+7 SET RES=$ORDER(@(ROOT_"""ABA"","_+SI_","""_ORD_""")"))
+8 if '$LENGTH(RES)
QUIT
if $EXTRACT(RES,$LENGTH(RES))=" "
SET RES=$EXTRACT(RES,1,($LENGTH(RES)-1))
+9 IF RES=KEY
SET OUT="1^"_SI_"^"_KEY
QUIT
+10 IF $LENGTH(KEY)<$LENGTH(RES)
IF KEY=$EXTRACT(RES,1,$LENGTH(KEY))
SET OUT="1^"_SI_"^"_KEY
End DoDot:1
if +OUT>0
QUIT
+11 SET KEY=$$UP^XLFSTR($GET(X))
+12 SET ORG=$EXTRACT(KEY,1,($LENGTH(KEY)-1))_$CHAR(($ASCII($EXTRACT(KEY,$LENGTH(KEY)))-1))_"~ "
+13 SET SI=0
FOR
SET SI=$ORDER(^ICDS(SI))
if +SI'>0
QUIT
Begin DoDot:1
+14 NEW ORD,RES
SET ORD=ORG
+15 SET RES=$ORDER(@(ROOT_"""ABA"","_+SI_","""_ORD_""")"))
+16 if '$LENGTH(RES)
QUIT
if $EXTRACT(RES,$LENGTH(RES))=" "
SET RES=$EXTRACT(RES,1,($LENGTH(RES)-1))
+17 IF RES=KEY
SET OUT="1^"_SI_"^"_KEY
QUIT
+18 IF $LENGTH(KEY)<$LENGTH(RES)
IF KEY=$EXTRACT(RES,1,$LENGTH(KEY))
SET OUT="1^"_SI_"^"_KEY
End DoDot:1
if +OUT>0
QUIT
+19 if +OUT>0
QUIT OUT
+20 QUIT 0
UNQ(X,ROOT) ; Check if Text is a Unique Code
+1 ;
+2 ; Input
+3 ;
+4 ; X Input String/Code
+5 ; ROOT Global Root of file
+6 ;
+7 ; Output
+8 ;
+9 ; $$UNQ 3 Piece ^ delimited string
+10 ;
+11 ; Piece Content
+12 ; 1 String is Unique in file
+13 ; 1 if X is unique
+14 ; 0 if X is not unique
+15 ; 2 String is a Code
+16 ; 1 is a code
+17 ; 0 X is not a code
+18 ; 3 String has Multiple Entries
+19 ; 1 Yes, X occurs more than once
+20 ; 0 No, X occurs once (aka unique)
+21 ;
+22 ; or -1 if the code string X is not found
+23 ;
+24 NEW KEY,ORG,LAS,ORD,OUT,IENS,IEN,NXT,NIEN,SI,SYS
if '$LENGTH($GET(X))
QUIT -1
+25 SET KEY=$TRANSLATE($GET(X),"""","")
if '$LENGTH(KEY)
QUIT -1
+26 SET ORG=$EXTRACT(KEY,1,($LENGTH(KEY)-1))_$CHAR(($ASCII($EXTRACT(KEY,$LENGTH(KEY)))-1))_"~ "
+27 SET OUT=-1
SET (IEN,NXT,SI)=0
+28 FOR
SET SI=$ORDER(@(ROOT_"""ABA"","_+SI_")"))
if +SI'>0
QUIT
Begin DoDot:1
+29 NEW ORD
SET ORD=ORG
SET IEN=$ORDER(@(ROOT_"""ABA"","_+SI_","""_KEY_" "",0)"))
+30 SET (NXT,NIEN)=0
+31 FOR
SET ORD=$ORDER(@(ROOT_"""ABA"","_+SI_","""_ORD_""")"))
if '$LENGTH(ORD)
QUIT
if $EXTRACT(ORD,1,$LENGTH(KEY))'=KEY
QUIT
Begin DoDot:2
+32 SET NIEN=0
FOR
SET NIEN=$ORDER(@(ROOT_"""ABA"","_+SI_","""_ORD_""","_NIEN_")"))
if +NIEN'>0
QUIT
Begin DoDot:3
+33 if ORD'=(KEY_" ")
SET IENS(+NIEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
if OUT>0
QUIT
if +IEN>0
QUIT
if +NXT>0
QUIT
+34 SET (NXT,NIEN)=0
FOR
SET NIEN=$ORDER(IENS(NIEN))
if +NIEN'>0
QUIT
SET NXT=NXT+1
+35 if +IEN>0
SET $PIECE(OUT,"^",1)=1
SET $PIECE(OUT,"^",2)=1
+36 IF +IEN>0
if +NXT>0
SET $PIECE(OUT,"^",3)=1
SET $PIECE(OUT,"^",1)=0
+37 IF +($GET(OUT))'<0
FOR SI=1:1:3
SET $PIECE(OUT,"^",SI)=+($PIECE($GET(OUT),"^",SI))
+38 IF NXT>0
IF +IEN'>0
SET OUT=$SELECT(NXT>1:0,1:1)_"^0^"_$SELECT(NXT>1:1,1:0)
+39 SET X=OUT
+40 QUIT X
ISORD(X) ; Check if in $ORDER
+1 if '$LENGTH($GET(ORD))
QUIT 0
if '$LENGTH($GET(KEY))
QUIT 0
+2 if $EXTRACT($GET(ORD),1,$LENGTH($GET(KEY)))=$GET(KEY)
QUIT 1
+3 QUIT 0
CDT(X,Y) ; ICD-10 Code Set Date
+1 NEW CDT,SYS
SET CDT=$GET(X)
SET SYS=+($GET(Y))
if CDT'?7N
SET CDT=$$DT^XLFDT
+2 QUIT X
SYS(ROOT,CDT) ; System from File and Date
+1 NEW FILE,CTL,FDT,NDT,IEN,SYS
SET (NDT,SYS)=0
+2 SET FILE=$SELECT($GET(ROOT)="^ICD9(":80,$GET(ROOT)="^ICD0(":80.1,1:"")
if FILE'>0
QUIT 0
+3 SET CTL=$GET(CDT)
if CTL'?7N
QUIT 0
+4 SET IEN=0
FOR
SET IEN=$ORDER(^ICDS("F",FILE,IEN))
if +IEN'>0
QUIT
Begin DoDot:1
+5 SET FDT=$PIECE($GET(^ICDS(+IEN,0)),"^",4)
if FDT'?7N
QUIT
+6 IF FDT<(CTL+.001)
IF FDT>NDT
SET FDT=CTL
SET SYS=IEN
End DoDot:1
+7 QUIT SYS
SH ; Show TMP
+1 NEW SUB,NN,NC
SET SUB="ICD9"
if '$DATA(^TMP(SUB))
SET SUB="ICD0"
if '$DATA(^TMP(SUB))
QUIT
+2 SET NN="^TMP("""_SUB_""","_$JOB_")"
SET NC="^TMP("""_SUB_""","_$JOB_","
+3 if '$DATA(@NN)
WRITE !
if '$DATA(@NN)
QUIT
FOR
SET NN=$QUERY(@NN)
if '$LENGTH(NN)!(NN'[NC)
QUIT
WRITE !,NN,"=",@NN
+4 WRITE !
+5 QUIT
TM(X,Y) ; Trim Y
+1 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
