ICDEXLK5 ;SLC/KER - ICD Extractor - Lookup, EXM/IEN/List ;07/15/2015
;;18.0;DRG Grouper;**57,67,82**;Oct 20, 2000;Build 21
;
; Global Variables
; ^ICDS( N/A
; ^TMP(SUB,$J SACC 2.3.2.5.1
;
; External References
; $$MIX^LEXXM ICR 5781
; $$DT^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
; Marked Items
; $T(MIX^LEXXM)
;
; Local Variables Newed or Killed by calling application
; DIC(0) Fileman Lookup Parameters
; DIC("S") Fileman Screen
;
; Local Variables Newed or Killed Elsewhere
; ICDBYCD Sort by Code
; ICDCDT Code Set Date
; ICDOUT Format of display
; ICDVDT Date to use during lookup
; ICDSYS Coding System
; ICDVER Versioned Lookup
; ICDDICS Screen
; INP2 User Input (processed)
; LOUD Output to Screen
;
Q
EXM(TXT,ROOT,Y,CDT,SYS,VER) ; Lookup Exact Match
;
; Input TXT Text/Code for search (Required)
; ROOT Global Root (Required)
; .Y Output array passed by reference (Required)
; CDT Date
; SYS Coding System
; VER Versioned Search
;
; Output $$EM Number of Exact Matches Found
; Y(n) Array of Exact Matches
;
N EXM,KEY,ORD,ICDI,IEN,NUM,ORG,EROOT S ORG=$G(TXT) Q:'$L($G(ORG)) 0
Q:'$L($TR(ORG,"""","")) 0 S ROOT=$G(ROOT) Q:'$L($G(ROOT)) 0
S SYS=+($G(SYS)),VER=+($G(VER))
S CDT=$$CDT^ICDEXLK3($G(CDT),SYS)
; Exact Match Case Sensitive Code
S KEY=ORG,KEY=ORG S ORD=$E(KEY,1,($L(KEY)-1))_$C(($A($E(KEY,$L(KEY)))-1))_"~ "
S EROOT=ROOT_"""BA""," S:+SYS>0&($D(@(ROOT_"""ABA"","_+SYS_")"))) EROOT=ROOT_"""ABA"","_+SYS_","
F S ORD=$O(@(EROOT_""""_ORD_""")")) Q:'$$ISORD D
. S IEN=0 F S IEN=$O(@(EROOT_""""_ORD_""","_+IEN_")")) Q:+IEN'>0 D
. . N VAL,STA S STA=1
. . S:VER>0 STA=$$LS^ICDEXLK3(ROOT,IEN,CDT)
. . Q:+($G(VER))>0&(+STA'>0)
. . S VAL=$P($G(@(ROOT_+IEN_",0)")),"^",1)
. . Q:VAL'=ORG S EXM(IEN)="",LOR=1
; Exact Match Code
I $O(EXM(0))'>0 D
. S KEY=$$UP^XLFSTR(ORG),KEY=ORG S ORD=$E(KEY,1,($L(KEY)-1))_$C(($A($E(KEY,$L(KEY)))-1))_"~ "
. S EROOT=ROOT_"""BA""," S:+SYS>0&($D(@(ROOT_"""ABA"","_+SYS_")"))) EROOT=ROOT_"""ABA"","_+SYS_","
. F S ORD=$O(@(EROOT_""""_ORD_""")")) Q:'$$ISORD D
. . S IEN=0 F S IEN=$O(@(EROOT_""""_ORD_""","_+IEN_")")) Q:+IEN'>0 D
. . . N VAL,STA S STA=1 S:VER>0 STA=$$LS^ICDEXLK3(ROOT,IEN,CDT)
. . . Q:+($G(VER))>0&(+STA'>0)
. . . S VAL=$P($G(@(ROOT_+IEN_",0)")),"^",1)
. . . Q:VAL'=ORG S EXM(IEN)="",LOR=1
; Exact Match Text
I $O(EXM(0))'>0 D
. N TI,TOK,KI,KEY,PARS,ORD,EROOT,IEN
. Q:$D(ICDBYCD) S KEY=$$UP^XLFSTR($G(ORG)) K PARS D TOKEN^ICDEXLK3(KEY,ROOT,SYS,.PARS)
. S (KI,TI)=0,(KEY,TOK)="" F S TI=$O(PARS(TI)) Q:+TI'>0 D
. . S TOK=$G(PARS(TI)) S:$E(TOK,1)?1U&($L(TOK)>$L(KEY)) KEY=$G(TOK),KI=TI
. K PARS(+($G(KI))) Q:$L(KEY)'>1
. S ORD=$E(KEY,1,($L(KEY)-1))_$C(($A($E(KEY,$L(KEY)))-1))_"~"
. S EROOT=ROOT_"""D""," S:+SYS>0&($D(@(ROOT_"""AD"","_+SYS_")"))) EROOT=ROOT_"""AD"","_+SYS_","
. I $G(DIC(0))["X",$O(@(EROOT_""""_ORD_""")"))'=KEY Q
. S IEN=0 F S IEN=$O(@(EROOT_""""_KEY_""","_+IEN_")")) Q:+IEN'>0 D
. . N VAL,STA S STA=1 S:VER>0 STA=$$LS^ICDEXLK3(ROOT,IEN,CDT)
. . Q:+($G(VER))>0&(+STA'>0)
. . S VAL=$$LD^ICDEXLK3(ROOT,IEN,CDT,VER)
. . Q:$$UP^XLFSTR(VAL)'=$$UP^XLFSTR(ORG)
. . S EXM(IEN)="",LOR=0
S (X,IEN)=0 F S IEN=$O(EXM(IEN)) Q:+IEN'>0 D
. N ICDI S ICDI=$O(Y(" "),-1)+1,Y(ICDI)=IEN,(X,Y(0))=ICDI
Q X
IEN ; Lookup by IEN
K Y S ICDOFND=0,Y=-1 Q:'$L(INP2) Q:INP2'?1N.N Q:+INP2'>0 Q:'$L(ROOT) Q:+FILE'>0
N XX,VDES,UDES,IEN,SNAME,ICS,INAME,STA,ORG S IEN=INP2 Q:'$D(@(ROOT_+IEN_",0)"))
S ORG="`"_IEN,VDES=$$LD^ICDEX(FILE,IEN,ICDCDT),UDES=$$LD^ICDEX(FILE,IEN,9999999)
S ICS=$$CSI^ICDEX(FILE,IEN),XX=VDES,(SNAME,INAME)=$$SYS^ICDEX(ICS,,"E")
S:$L($G(ICDSYS)) SNAME=$$SYS^ICDEX($G(ICDSYS),,"E")
S STA=$$LS^ICDEX(FILE,IEN,$G(ICDCDT))
I $L($G(ICDSYS))>0,ICS>0,$G(ICDSYS)'=ICS D Q
. K X,Y S X="" S:$L($G(ORG)) X=$G(ORG) S Y=-1,ICDOFND=0 Q
. S X=UDES,Y="-1^IEN "_IEN_" is not of the "_SNAME_" coding system"
I +($G(ICDVER))>0,STA'>0 D Q
. K X,Y S X="" S:$L($G(ORG)) X=$G(ORG) S Y=-1,ICDOFND=0 Q
. S X=UDES,Y="-1^IEN "_IEN_" is not active on "_$$FMTE^XLFDT($G(ICDCDT),"5Z")
I +($G(ICDVER))'>0,$E(XX,1,2)="-1",$L(UDES),$E(UDES,1,2)'="-1" S XX=UDES
W:$D(LOUD)&($G(DIC(0))["E")&($E(XX,1,2)'="-1") " ",XX
D FND(ROOT,IEN,ICDCDT,$G(ICS),$G(ICDVER),+($G(LOR)),$G(ICDOUT))
D SEL(ROOT,1) I +($G(^TMP(SUB,$J,"SEL",1)))>0 D
. S ICDOFND=1 N ANS S ANS=$$ONE^ICDEXLK2
. I ANS'>0 D Q
. . S ICDOFND=0,X=""
. . ;+($G(^TMP(SUB,$J,"SEL",1)))
. . S Y=-1 K ^TMP(SUB,$J,"SEL") Q
. D X^ICDEXLK2(1,SUB) S (ICDOFND,ICDOSEL,ICDOREV)=1
. D Y^ICDEXLK2($G(ROOT),+($G(^TMP(SUB,$J,"SEL",1))),$G(ICDCDT))
. I +($G(Y))'>0,$L($G(INP)) S X=$G(INP) Q
. I +($G(Y))>0 D:$G(DIC(0))'["F" SAV^ICDEXLK6(+($G(Y)),ROOT)
K ^TMP(SUB,$J,"SEL")
Q
;
FND(ROOT,IEN,CDT,SYS,VER,LOR,OUT) ; Add Item to Found List
;
; Input
;
; ROOT Global Root
; IEN Internal Entry Number
; CDT Date
; SYS Coding System
; VER Versioned Search
; LOR List Order
; 0 List by Text Length
; 1 List by Code Number
; OUT Output Format
; 1 Fileman, code and short text
; 2 Fileman, code and description
; 3 Lexicon, short text and code
; 4 Lexicon, description and code
;
; Output
;
; ^TMP(ID,$J,"FND")
; ^TMP(ID,$J,"FND",LEN,SEQ)=IEN ^ Display Text
; ^TMP(ID,$J,"FND","IEN",<ien>)=""
;
; where
;
; ID is a package namespaced subscript:
;
; ICD9 - for file #80 searches
; ICD0 - for file #80.1 searches
;
; LEN is a number assigned based string length
; SEQ is a unique sequence number for length
;
; Uses DIC("S") to screen output
;
N CC,CODE,CTR,FILE,SEQ,SCREEN,SHORT,LONG,STATUS,STA,SUB,TEXT,TERM,TYP,NUM,Y
S SYS=+($G(SYS)),VER=+($G(VER)) S (Y,IEN)=+($G(IEN)) Q:+IEN'>0
S ROOT=$$ROOT^ICDEX($G(ROOT)),FILE=$$FILE^ICDEX(ROOT)
S SUB=$TR(ROOT,"^("),SCREEN=$$SCREEN Q:'SCREEN Q:+FILE'>0
S CODE=$P($G(@(ROOT_+IEN_",0)")),"^",1) Q:'$L(CODE)
S:'$L($G(CDT)) CDT=$$DT^XLFDT S LOR=+($G(LOR))
S STA=1 I +VER>0 S STA=$$STATCHK^ICDEX(CODE,CDT,SYS) Q:+($G(STA))'>0
Q:'$L(SUB) Q:$D(^TMP(SUB,$J,"FND","IEN",+IEN))
S TYP=$P($G(^ICDS(+SYS,0)),"^",1),TERM=""
S OUT=$G(OUT) S:+OUT'>0 OUT=1 S:+OUT>4 OUT=1
I +($G(OUT))=1!(+($G(OUT))=3) S TERM=$$SD^ICDEX(FILE,IEN,CDT)
I +($G(OUT))=2!(+($G(OUT))=4) D
. S TERM=$$LD^ICDEX(FILE,IEN,CDT) Q:$P(TERM,"^",1)=-1
. I +($G(OUT))=4,$L($T(MIX^LEXXM)) S TERM=$$MIX^LEXXM(TERM)
I VER'>0,($P(TERM,"^",1)=-1!('$L(TERM))) D
. N TDT S TDT=$O(@(ROOT_IEN_",67,""B"","_+($G(CDT))_")")) Q:$E(TDT,1,7)'?7N
. I +($G(OUT))=1!(+($G(OUT))=3) S TERM=$$SD^ICDEX(FILE,IEN,TDT)
. I +($G(OUT))=2!(+($G(OUT))=4) S TERM=$$LD^ICDEX(FILE,IEN,TDT)
. I +($G(OUT))=4,$P(TERM,"^",1)'=-1,$L($T(MIX^LEXXM)) S TERM=$$MIX^LEXXM(TERM)
. S:$P(TERM,"^",1)=-1 TERM="" Q:'$L(TERM)
. S:TDT?7N TERM=TERM_" ("_$$FMTE^XLFDT(TDT,"5ZM")_")"
S:$P(TERM,"^",1)=-1 TERM="" Q:'$L(TERM) S NUM=$$NUM^ICDEX(CODE)
S CODE=CODE_$J(" ",(10-$L(CODE))) S CC=""
S:FILE=80 CC=$$VCC^ICDEX(IEN,CDT),CC=$$CC(+CC)
S STATUS=$O(@(ROOT_+IEN_",66,""B"","_(+CDT+.000001)_")"),-1)
S STATUS=$O(@(ROOT_+IEN_",66,""B"","_+STATUS_","" "")"),-1)
S STATUS=$P($G(@(ROOT_+IEN_",66,"_+STATUS_",0)")),"^",2)
S STATUS=$$ST(STATUS)
S:$G(OUT)'?1N OUT=$G(OUT) S:+OUT'>0 OUT=1 S:+OUT>4 OUT=4
I +($G(OUT))=1!(+($G(OUT))=2) D
. S:$G(DIC(0))'["S" TEXT=CODE_TERM_CC_STATUS
. S:$G(DIC(0))["S" TEXT=TERM_CC_STATUS
I +($G(OUT))=3!(+($G(OUT))=4) D
. S CODE=$$TM(CODE),TEXT=TERM_CC_STATUS
. Q:$G(DIC(0))["S"
. S:$L(TYP) TEXT=TEXT_" ("_TYP_" "_CODE_")"
. S:'$L(TYP) TEXT=TEXT_" ("_CODE_")"
S SEQ=246-$L(TERM) S:LOR>0 SEQ=NUM
S CTR=$O(^TMP(SUB,$J,"FND",+SEQ," "),-1)+1
S ^TMP(SUB,$J,"FND",+SEQ,CTR)=IEN_"^"_TEXT
S ^TMP(SUB,$J,"FND","IEN",+IEN)=""
Q
SEL(ROOT,LOR) ; Add Items to Selection List
;
; Input
;
; ROOT Global Root/File # (Required)
; LOR List Order
; 0 List by Text Length
; 1 List by Code Number
;
; Output
;
; ^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
;
; Uses ^TMP(NAME,$J,"FND") (Optional)
; Kills ^TMP(NAME,$J,"FND")
;
N CTR,FILE,SEQ,SUB,TEXT S ROOT=$$ROOT^ICDEX($G(ROOT)),LOR=+($G(LOR))
S FILE=$$FILE^ICDEX(ROOT),SUB=$TR(ROOT,"^(") K ^TMP(SUB,$J,"SEL")
Q:+FILE'>0 Q:'$L(SUB) K ^TMP(SUB,$J,"SEL")
I +($G(LOR))'>0 D
. S SEQ=" " F S SEQ=$O(^TMP(SUB,$J,"FND",SEQ),-1) Q:+SEQ'>0 D SEL2
I +($G(LOR))>0 D
. S SEQ=0 F S SEQ=$O(^TMP(SUB,$J,"FND",SEQ)) Q:+SEQ'>0 D SEL2
K ^TMP(SUB,$J,"FND")
Q
SEL2 ; Add Items to Selection List (part 2)
N ICDI S ICDI=0 F S ICDI=$O(^TMP(SUB,$J,"FND",+SEQ,ICDI)) Q:+ICDI'>0 D
. N CTR,TEXT S TEXT=$G(^TMP(SUB,$J,"FND",+SEQ,ICDI))
. Q:'$L(TEXT) Q:+TEXT'>0 Q:'$L($P(TEXT,"^",2))
. S CTR=$O(^TMP(SUB,$J,"SEL"," "),-1)+1
. S ^TMP(SUB,$J,"SEL",CTR)=TEXT,^TMP(SUB,$J,"SEL",0)=CTR
Q
;
; Miscellaneous
SH ; Display 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
SCREEN(X) ; Screen Entries - Boolean Truth Value
Q:+($G(Y))'>0 1 Q:'$L($G(ROOT)) 1 N ICDNR,ICDO,ICDS,ICDY
S ICDY=+($G(Y)),ROOT=$$ROOT^ICDEX($G(ROOT)) Q:'$L(ROOT) 1
S ICDS=$G(ICDDICS) Q:'$L(ICDS) 1 S Y=+($G(ICDY))
S ICDNR=$D(@(ROOT_+Y_",0)")) X ICDS S ICDO=$T
Q:'ICDO 0
Q 1
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
CC(X) ; CC
Q:+($G(X))=1 " (CC)"
Q:+($G(X))=2 " (Major CC)"
Q ""
ST(X) ; Status indicators
Q:$G(X)?1N&(+$G(X)'>0) " (Inactive)"
Q:$G(X)'?1N&(+$G(X)'>0) " (Pending)"
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[HICDEXLK5 10622 printed Sep 23, 2025@19:26:48 Page 2
ICDEXLK5 ;SLC/KER - ICD Extractor - Lookup, EXM/IEN/List ;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 ; ^TMP(SUB,$J SACC 2.3.2.5.1
+6 ;
+7 ; External References
+8 ; $$MIX^LEXXM ICR 5781
+9 ; $$DT^XLFDT ICR 10103
+10 ; $$FMTE^XLFDT ICR 10103
+11 ; $$UP^XLFSTR ICR 10104
+12 ;
+13 ; Marked Items
+14 ; $T(MIX^LEXXM)
+15 ;
+16 ; Local Variables Newed or Killed by calling application
+17 ; DIC(0) Fileman Lookup Parameters
+18 ; DIC("S") Fileman Screen
+19 ;
+20 ; Local Variables Newed or Killed Elsewhere
+21 ; ICDBYCD Sort by Code
+22 ; ICDCDT Code Set Date
+23 ; ICDOUT Format of display
+24 ; ICDVDT Date to use during lookup
+25 ; ICDSYS Coding System
+26 ; ICDVER Versioned Lookup
+27 ; ICDDICS Screen
+28 ; INP2 User Input (processed)
+29 ; LOUD Output to Screen
+30 ;
+31 QUIT
EXM(TXT,ROOT,Y,CDT,SYS,VER) ; Lookup Exact Match
+1 ;
+2 ; Input TXT Text/Code for search (Required)
+3 ; ROOT Global Root (Required)
+4 ; .Y Output array passed by reference (Required)
+5 ; CDT Date
+6 ; SYS Coding System
+7 ; VER Versioned Search
+8 ;
+9 ; Output $$EM Number of Exact Matches Found
+10 ; Y(n) Array of Exact Matches
+11 ;
+12 NEW EXM,KEY,ORD,ICDI,IEN,NUM,ORG,EROOT
SET ORG=$GET(TXT)
if '$LENGTH($GET(ORG))
QUIT 0
+13 if '$LENGTH($TRANSLATE(ORG,"""",""))
QUIT 0
SET ROOT=$GET(ROOT)
if '$LENGTH($GET(ROOT))
QUIT 0
+14 SET SYS=+($GET(SYS))
SET VER=+($GET(VER))
+15 SET CDT=$$CDT^ICDEXLK3($GET(CDT),SYS)
+16 ; Exact Match Case Sensitive Code
+17 SET KEY=ORG
SET KEY=ORG
SET ORD=$EXTRACT(KEY,1,($LENGTH(KEY)-1))_$CHAR(($ASCII($EXTRACT(KEY,$LENGTH(KEY)))-1))_"~ "
+18 SET EROOT=ROOT_"""BA"","
if +SYS>0&($DATA(@(ROOT_"""ABA"","_+SYS_")")))
SET EROOT=ROOT_"""ABA"","_+SYS_","
+19 FOR
SET ORD=$ORDER(@(EROOT_""""_ORD_""")"))
if '$$ISORD
QUIT
Begin DoDot:1
+20 SET IEN=0
FOR
SET IEN=$ORDER(@(EROOT_""""_ORD_""","_+IEN_")"))
if +IEN'>0
QUIT
Begin DoDot:2
+21 NEW VAL,STA
SET STA=1
+22 if VER>0
SET STA=$$LS^ICDEXLK3(ROOT,IEN,CDT)
+23 if +($GET(VER))>0&(+STA'>0)
QUIT
+24 SET VAL=$PIECE($GET(@(ROOT_+IEN_",0)")),"^",1)
+25 if VAL'=ORG
QUIT
SET EXM(IEN)=""
SET LOR=1
End DoDot:2
End DoDot:1
+26 ; Exact Match Code
+27 IF $ORDER(EXM(0))'>0
Begin DoDot:1
+28 SET KEY=$$UP^XLFSTR(ORG)
SET KEY=ORG
SET ORD=$EXTRACT(KEY,1,($LENGTH(KEY)-1))_$CHAR(($ASCII($EXTRACT(KEY,$LENGTH(KEY)))-1))_"~ "
+29 SET EROOT=ROOT_"""BA"","
if +SYS>0&($DATA(@(ROOT_"""ABA"","_+SYS_")")))
SET EROOT=ROOT_"""ABA"","_+SYS_","
+30 FOR
SET ORD=$ORDER(@(EROOT_""""_ORD_""")"))
if '$$ISORD
QUIT
Begin DoDot:2
+31 SET IEN=0
FOR
SET IEN=$ORDER(@(EROOT_""""_ORD_""","_+IEN_")"))
if +IEN'>0
QUIT
Begin DoDot:3
+32 NEW VAL,STA
SET STA=1
if VER>0
SET STA=$$LS^ICDEXLK3(ROOT,IEN,CDT)
+33 if +($GET(VER))>0&(+STA'>0)
QUIT
+34 SET VAL=$PIECE($GET(@(ROOT_+IEN_",0)")),"^",1)
+35 if VAL'=ORG
QUIT
SET EXM(IEN)=""
SET LOR=1
End DoDot:3
End DoDot:2
End DoDot:1
+36 ; Exact Match Text
+37 IF $ORDER(EXM(0))'>0
Begin DoDot:1
+38 NEW TI,TOK,KI,KEY,PARS,ORD,EROOT,IEN
+39 if $DATA(ICDBYCD)
QUIT
SET KEY=$$UP^XLFSTR($GET(ORG))
KILL PARS
DO TOKEN^ICDEXLK3(KEY,ROOT,SYS,.PARS)
+40 SET (KI,TI)=0
SET (KEY,TOK)=""
FOR
SET TI=$ORDER(PARS(TI))
if +TI'>0
QUIT
Begin DoDot:2
+41 SET TOK=$GET(PARS(TI))
if $EXTRACT(TOK,1)?1U&($LENGTH(TOK)>$LENGTH(KEY))
SET KEY=$GET(TOK)
SET KI=TI
End DoDot:2
+42 KILL PARS(+($GET(KI)))
if $LENGTH(KEY)'>1
QUIT
+43 SET ORD=$EXTRACT(KEY,1,($LENGTH(KEY)-1))_$CHAR(($ASCII($EXTRACT(KEY,$LENGTH(KEY)))-1))_"~"
+44 SET EROOT=ROOT_"""D"","
if +SYS>0&($DATA(@(ROOT_"""AD"","_+SYS_")")))
SET EROOT=ROOT_"""AD"","_+SYS_","
+45 IF $GET(DIC(0))["X"
IF $ORDER(@(EROOT_""""_ORD_""")"))'=KEY
QUIT
+46 SET IEN=0
FOR
SET IEN=$ORDER(@(EROOT_""""_KEY_""","_+IEN_")"))
if +IEN'>0
QUIT
Begin DoDot:2
+47 NEW VAL,STA
SET STA=1
if VER>0
SET STA=$$LS^ICDEXLK3(ROOT,IEN,CDT)
+48 if +($GET(VER))>0&(+STA'>0)
QUIT
+49 SET VAL=$$LD^ICDEXLK3(ROOT,IEN,CDT,VER)
+50 if $$UP^XLFSTR(VAL)'=$$UP^XLFSTR(ORG)
QUIT
+51 SET EXM(IEN)=""
SET LOR=0
End DoDot:2
End DoDot:1
+52 SET (X,IEN)=0
FOR
SET IEN=$ORDER(EXM(IEN))
if +IEN'>0
QUIT
Begin DoDot:1
+53 NEW ICDI
SET ICDI=$ORDER(Y(" "),-1)+1
SET Y(ICDI)=IEN
SET (X,Y(0))=ICDI
End DoDot:1
+54 QUIT X
IEN ; Lookup by IEN
+1 KILL Y
SET ICDOFND=0
SET Y=-1
if '$LENGTH(INP2)
QUIT
if INP2'?1N.N
QUIT
if +INP2'>0
QUIT
if '$LENGTH(ROOT)
QUIT
if +FILE'>0
QUIT
+2 NEW XX,VDES,UDES,IEN,SNAME,ICS,INAME,STA,ORG
SET IEN=INP2
if '$DATA(@(ROOT_+IEN_",0)"))
QUIT
+3 SET ORG="`"_IEN
SET VDES=$$LD^ICDEX(FILE,IEN,ICDCDT)
SET UDES=$$LD^ICDEX(FILE,IEN,9999999)
+4 SET ICS=$$CSI^ICDEX(FILE,IEN)
SET XX=VDES
SET (SNAME,INAME)=$$SYS^ICDEX(ICS,,"E")
+5 if $LENGTH($GET(ICDSYS))
SET SNAME=$$SYS^ICDEX($GET(ICDSYS),,"E")
+6 SET STA=$$LS^ICDEX(FILE,IEN,$GET(ICDCDT))
+7 IF $LENGTH($GET(ICDSYS))>0
IF ICS>0
IF $GET(ICDSYS)'=ICS
Begin DoDot:1
+8 KILL X,Y
SET X=""
if $LENGTH($GET(ORG))
SET X=$GET(ORG)
SET Y=-1
SET ICDOFND=0
QUIT
+9 SET X=UDES
SET Y="-1^IEN "_IEN_" is not of the "_SNAME_" coding system"
End DoDot:1
QUIT
+10 IF +($GET(ICDVER))>0
IF STA'>0
Begin DoDot:1
+11 KILL X,Y
SET X=""
if $LENGTH($GET(ORG))
SET X=$GET(ORG)
SET Y=-1
SET ICDOFND=0
QUIT
+12 SET X=UDES
SET Y="-1^IEN "_IEN_" is not active on "_$$FMTE^XLFDT($GET(ICDCDT),"5Z")
End DoDot:1
QUIT
+13 IF +($GET(ICDVER))'>0
IF $EXTRACT(XX,1,2)="-1"
IF $LENGTH(UDES)
IF $EXTRACT(UDES,1,2)'="-1"
SET XX=UDES
+14 if $DATA(LOUD)&($GET(DIC(0))["E")&($EXTRACT(XX,1,2)'="-1")
WRITE " ",XX
+15 DO FND(ROOT,IEN,ICDCDT,$GET(ICS),$GET(ICDVER),+($GET(LOR)),$GET(ICDOUT))
+16 DO SEL(ROOT,1)
IF +($GET(^TMP(SUB,$JOB,"SEL",1)))>0
Begin DoDot:1
+17 SET ICDOFND=1
NEW ANS
SET ANS=$$ONE^ICDEXLK2
+18 IF ANS'>0
Begin DoDot:2
+19 SET ICDOFND=0
SET X=""
+20 ;+($G(^TMP(SUB,$J,"SEL",1)))
+21 SET Y=-1
KILL ^TMP(SUB,$JOB,"SEL")
QUIT
End DoDot:2
QUIT
+22 DO X^ICDEXLK2(1,SUB)
SET (ICDOFND,ICDOSEL,ICDOREV)=1
+23 DO Y^ICDEXLK2($GET(ROOT),+($GET(^TMP(SUB,$JOB,"SEL",1))),$GET(ICDCDT))
+24 IF +($GET(Y))'>0
IF $LENGTH($GET(INP))
SET X=$GET(INP)
QUIT
+25 IF +($GET(Y))>0
if $GET(DIC(0))'["F"
DO SAV^ICDEXLK6(+($GET(Y)),ROOT)
End DoDot:1
+26 KILL ^TMP(SUB,$JOB,"SEL")
+27 QUIT
+28 ;
FND(ROOT,IEN,CDT,SYS,VER,LOR,OUT) ; Add Item to Found List
+1 ;
+2 ; Input
+3 ;
+4 ; ROOT Global Root
+5 ; IEN Internal Entry Number
+6 ; CDT Date
+7 ; SYS Coding System
+8 ; VER Versioned Search
+9 ; LOR List Order
+10 ; 0 List by Text Length
+11 ; 1 List by Code Number
+12 ; OUT Output Format
+13 ; 1 Fileman, code and short text
+14 ; 2 Fileman, code and description
+15 ; 3 Lexicon, short text and code
+16 ; 4 Lexicon, description and code
+17 ;
+18 ; Output
+19 ;
+20 ; ^TMP(ID,$J,"FND")
+21 ; ^TMP(ID,$J,"FND",LEN,SEQ)=IEN ^ Display Text
+22 ; ^TMP(ID,$J,"FND","IEN",<ien>)=""
+23 ;
+24 ; where
+25 ;
+26 ; ID is a package namespaced subscript:
+27 ;
+28 ; ICD9 - for file #80 searches
+29 ; ICD0 - for file #80.1 searches
+30 ;
+31 ; LEN is a number assigned based string length
+32 ; SEQ is a unique sequence number for length
+33 ;
+34 ; Uses DIC("S") to screen output
+35 ;
+36 NEW CC,CODE,CTR,FILE,SEQ,SCREEN,SHORT,LONG,STATUS,STA,SUB,TEXT,TERM,TYP,NUM,Y
+37 SET SYS=+($GET(SYS))
SET VER=+($GET(VER))
SET (Y,IEN)=+($GET(IEN))
if +IEN'>0
QUIT
+38 SET ROOT=$$ROOT^ICDEX($GET(ROOT))
SET FILE=$$FILE^ICDEX(ROOT)
+39 SET SUB=$TRANSLATE(ROOT,"^(")
SET SCREEN=$$SCREEN
if 'SCREEN
QUIT
if +FILE'>0
QUIT
+40 SET CODE=$PIECE($GET(@(ROOT_+IEN_",0)")),"^",1)
if '$LENGTH(CODE)
QUIT
+41 if '$LENGTH($GET(CDT))
SET CDT=$$DT^XLFDT
SET LOR=+($GET(LOR))
+42 SET STA=1
IF +VER>0
SET STA=$$STATCHK^ICDEX(CODE,CDT,SYS)
if +($GET(STA))'>0
QUIT
+43 if '$LENGTH(SUB)
QUIT
if $DATA(^TMP(SUB,$JOB,"FND","IEN",+IEN))
QUIT
+44 SET TYP=$PIECE($GET(^ICDS(+SYS,0)),"^",1)
SET TERM=""
+45 SET OUT=$GET(OUT)
if +OUT'>0
SET OUT=1
if +OUT>4
SET OUT=1
+46 IF +($GET(OUT))=1!(+($GET(OUT))=3)
SET TERM=$$SD^ICDEX(FILE,IEN,CDT)
+47 IF +($GET(OUT))=2!(+($GET(OUT))=4)
Begin DoDot:1
+48 SET TERM=$$LD^ICDEX(FILE,IEN,CDT)
if $PIECE(TERM,"^",1)=-1
QUIT
+49 IF +($GET(OUT))=4
IF $LENGTH($TEXT(MIX^LEXXM))
SET TERM=$$MIX^LEXXM(TERM)
End DoDot:1
+50 IF VER'>0
IF ($PIECE(TERM,"^",1)=-1!('$LENGTH(TERM)))
Begin DoDot:1
+51 NEW TDT
SET TDT=$ORDER(@(ROOT_IEN_",67,""B"","_+($GET(CDT))_")"))
if $EXTRACT(TDT,1,7)'?7N
QUIT
+52 IF +($GET(OUT))=1!(+($GET(OUT))=3)
SET TERM=$$SD^ICDEX(FILE,IEN,TDT)
+53 IF +($GET(OUT))=2!(+($GET(OUT))=4)
SET TERM=$$LD^ICDEX(FILE,IEN,TDT)
+54 IF +($GET(OUT))=4
IF $PIECE(TERM,"^",1)'=-1
IF $LENGTH($TEXT(MIX^LEXXM))
SET TERM=$$MIX^LEXXM(TERM)
+55 if $PIECE(TERM,"^",1)=-1
SET TERM=""
if '$LENGTH(TERM)
QUIT
+56 if TDT?7N
SET TERM=TERM_" ("_$$FMTE^XLFDT(TDT,"5ZM")_")"
End DoDot:1
+57 if $PIECE(TERM,"^",1)=-1
SET TERM=""
if '$LENGTH(TERM)
QUIT
SET NUM=$$NUM^ICDEX(CODE)
+58 SET CODE=CODE_$JUSTIFY(" ",(10-$LENGTH(CODE)))
SET CC=""
+59 if FILE=80
SET CC=$$VCC^ICDEX(IEN,CDT)
SET CC=$$CC(+CC)
+60 SET STATUS=$ORDER(@(ROOT_+IEN_",66,""B"","_(+CDT+.000001)_")"),-1)
+61 SET STATUS=$ORDER(@(ROOT_+IEN_",66,""B"","_+STATUS_","" "")"),-1)
+62 SET STATUS=$PIECE($GET(@(ROOT_+IEN_",66,"_+STATUS_",0)")),"^",2)
+63 SET STATUS=$$ST(STATUS)
+64 if $GET(OUT)'?1N
SET OUT=$GET(OUT)
if +OUT'>0
SET OUT=1
if +OUT>4
SET OUT=4
+65 IF +($GET(OUT))=1!(+($GET(OUT))=2)
Begin DoDot:1
+66 if $GET(DIC(0))'["S"
SET TEXT=CODE_TERM_CC_STATUS
+67 if $GET(DIC(0))["S"
SET TEXT=TERM_CC_STATUS
End DoDot:1
+68 IF +($GET(OUT))=3!(+($GET(OUT))=4)
Begin DoDot:1
+69 SET CODE=$$TM(CODE)
SET TEXT=TERM_CC_STATUS
+70 if $GET(DIC(0))["S"
QUIT
+71 if $LENGTH(TYP)
SET TEXT=TEXT_" ("_TYP_" "_CODE_")"
+72 if '$LENGTH(TYP)
SET TEXT=TEXT_" ("_CODE_")"
End DoDot:1
+73 SET SEQ=246-$LENGTH(TERM)
if LOR>0
SET SEQ=NUM
+74 SET CTR=$ORDER(^TMP(SUB,$JOB,"FND",+SEQ," "),-1)+1
+75 SET ^TMP(SUB,$JOB,"FND",+SEQ,CTR)=IEN_"^"_TEXT
+76 SET ^TMP(SUB,$JOB,"FND","IEN",+IEN)=""
+77 QUIT
SEL(ROOT,LOR) ; Add Items to Selection List
+1 ;
+2 ; Input
+3 ;
+4 ; ROOT Global Root/File # (Required)
+5 ; LOR List Order
+6 ; 0 List by Text Length
+7 ; 1 List by Code Number
+8 ;
+9 ; Output
+10 ;
+11 ; ^TMP(ID,$J,"SEL")
+12 ; ^TMP(ID,$J,"SEL",0)=# of entries
+13 ; ^TMP(ID,$J,"SEL",#)=IEN^Display Text
+14 ;
+15 ; where ID is a package namespaced subscript:
+16 ;
+17 ; ICD9 - for the Diagnosis file #80
+18 ; ICD0 - for the Operations/Procedure file #80.1
+19 ;
+20 ; Uses ^TMP(NAME,$J,"FND") (Optional)
+21 ; Kills ^TMP(NAME,$J,"FND")
+22 ;
+23 NEW CTR,FILE,SEQ,SUB,TEXT
SET ROOT=$$ROOT^ICDEX($GET(ROOT))
SET LOR=+($GET(LOR))
+24 SET FILE=$$FILE^ICDEX(ROOT)
SET SUB=$TRANSLATE(ROOT,"^(")
KILL ^TMP(SUB,$JOB,"SEL")
+25 if +FILE'>0
QUIT
if '$LENGTH(SUB)
QUIT
KILL ^TMP(SUB,$JOB,"SEL")
+26 IF +($GET(LOR))'>0
Begin DoDot:1
+27 SET SEQ=" "
FOR
SET SEQ=$ORDER(^TMP(SUB,$JOB,"FND",SEQ),-1)
if +SEQ'>0
QUIT
DO SEL2
End DoDot:1
+28 IF +($GET(LOR))>0
Begin DoDot:1
+29 SET SEQ=0
FOR
SET SEQ=$ORDER(^TMP(SUB,$JOB,"FND",SEQ))
if +SEQ'>0
QUIT
DO SEL2
End DoDot:1
+30 KILL ^TMP(SUB,$JOB,"FND")
+31 QUIT
SEL2 ; Add Items to Selection List (part 2)
+1 NEW ICDI
SET ICDI=0
FOR
SET ICDI=$ORDER(^TMP(SUB,$JOB,"FND",+SEQ,ICDI))
if +ICDI'>0
QUIT
Begin DoDot:1
+2 NEW CTR,TEXT
SET TEXT=$GET(^TMP(SUB,$JOB,"FND",+SEQ,ICDI))
+3 if '$LENGTH(TEXT)
QUIT
if +TEXT'>0
QUIT
if '$LENGTH($PIECE(TEXT,"^",2))
QUIT
+4 SET CTR=$ORDER(^TMP(SUB,$JOB,"SEL"," "),-1)+1
+5 SET ^TMP(SUB,$JOB,"SEL",CTR)=TEXT
SET ^TMP(SUB,$JOB,"SEL",0)=CTR
End DoDot:1
+6 QUIT
+7 ;
+8 ; Miscellaneous
SH ; Display TMP
+1 NEW SUB,NN,NC
+2 SET SUB="ICD9"
if '$DATA(^TMP(SUB))
SET SUB="ICD0"
if '$DATA(^TMP(SUB))
QUIT
+3 SET NN="^TMP("""_SUB_""","_$JOB_")"
SET NC="^TMP("""_SUB_""","_$JOB_","
+4 if '$DATA(@NN)
WRITE !
if '$DATA(@NN)
QUIT
FOR
SET NN=$QUERY(@NN)
if '$LENGTH(NN)!(NN'[NC)
QUIT
WRITE !,NN,"=",@NN
+5 WRITE !
+6 QUIT
SCREEN(X) ; Screen Entries - Boolean Truth Value
+1 if +($GET(Y))'>0
QUIT 1
if '$LENGTH($GET(ROOT))
QUIT 1
NEW ICDNR,ICDO,ICDS,ICDY
+2 SET ICDY=+($GET(Y))
SET ROOT=$$ROOT^ICDEX($GET(ROOT))
if '$LENGTH(ROOT)
QUIT 1
+3 SET ICDS=$GET(ICDDICS)
if '$LENGTH(ICDS)
QUIT 1
SET Y=+($GET(ICDY))
+4 SET ICDNR=$DATA(@(ROOT_+Y_",0)"))
XECUTE ICDS
SET ICDO=$TEST
+5 if 'ICDO
QUIT 0
+6 QUIT 1
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
CC(X) ; CC
+1 if +($GET(X))=1
QUIT " (CC)"
+2 if +($GET(X))=2
QUIT " (Major CC)"
+3 QUIT ""
ST(X) ; Status indicators
+1 if $GET(X)?1N&(+$GET(X)'>0)
QUIT " (Inactive)"
+2 if $GET(X)'?1N&(+$GET(X)'>0)
QUIT " (Pending)"
+3 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
