ICDEXLK2 ;SLC/KER - ICD Extractor - Lookup, SBR/Ask/One/Mul ;12/19/2014
;;18.0;DRG Grouper;**57,67,82**;Oct 20, 2000;Build 21
;
; Global Variables
; ^TMP(SUB,$J SACC 2.3.2.5.1
;
; External References
; CLRMSG^DDS ICR 5846
; HLP^DDSMSG ICR 5847
; ^DIR ICR 10026
; $$DT^XLFDT ICR 10103
; $$FMADD^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed Elsewhere
; DDS,DIC,DICR,ICDCDT,ICDDIC0,ICDDICA,
; ICDDICB,ICDDICN,ICDFMT,ICDISF,ICDOFND,
; ICDOINP,ICDOREV,ICDOSEL,ICDOTIM,ICDOUPA
; ICDOUT,ICDSYS,ICDVER,ICDX,INP1,INP2
;
Q
ASK ; Ask for Selection
K X,Y N ANS S ICDOFND=+($G(ICDOFND)) Q:+ICDOFND'>0
I ICDOFND=1,DIC(0)'["E" D Q
. K X,Y D X(1,SUB) S (ICDOFND,ICDOSEL,ICDOREV)=1
. D Y($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)
I ICDOFND>1,DIC(0)'["E" D Q
. K Y S Y="-1^Selection not made" S ICDOSEL=0
S:+ICDOFND=1 ANS=$$ONE S:+ICDOFND>1 ANS=$$MUL S ICDOSEL=0
I ANS>0 D
. D X(+ANS,SUB) S ICDOSEL=1
. D Y($G(ROOT),+($G(^TMP(SUB,$J,"SEL",+ANS))),$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)
I ANS'>0 K INP,X,Y,^TMP(SUB,$J)
Q
SBR ; Space-Bar Return DIC(0) not contain "A"
N SBI,SUB,OUT,ANS,SBS K Y S Y=-1 Q:'$L($G(ROOT)) Q:ROOT="^" Q:'$L($G(FILE))
S SBI=$$RET^ICDEXLK6($G(FILE)),SUB=$TR($G(ROOT),"^(","") K:$L(SUB) ^TMP(SUB,$J) Q:+SBI'>0
S SBS=$P($G(@(ROOT_+SBI_",1)")),"^",1) Q:+SBS'>0 Q:+SBI>0&(+SBS>0)&(+($G(ICDSYS))>0)&(+($G(ICDSYS))'=+SBS)
D FND^ICDEXLK5($G(ROOT),+SBI,$G(ICDCDT),$G(ICDSYS),$G(ICDVER),0,$G(ICDOUT))
D SEL^ICDEXLK5(ROOT,0) Q:'$D(^TMP(SUB,$J,"SEL",1)) S ANS=$$ONE I ANS>0 D
. D X(1,SUB) S (ICDOFND,ICDOSEL,ICDOREV)=1
. D Y($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)
S:+Y>0&($L($P(Y,"^",2))) X=$P(Y,"^",2)
I ANS'>0 K INP,X,Y,^TMP(SUB,$J) S X="",Y="-1^No user input"
Q
ONE(X) ; One Entry Found
S:'$D(DDS) X=$$ONERS S:$D(DDS) X=$$ONESM S ICDOREV=1
Q X
ONERS(X) ; One Entry Found Roll and Scroll
N DIROUT,DIRUT,DIR,IEN,LN,LN2,ICDI,ICDPR,TEXT,TXT,TX,CT,Y S ICDOREV=1
S TEXT=$G(^TMP(SUB,$J,"SEL",1)) Q:$G(DIC(0))'["E" 1
S IEN=+TEXT,TEXT=$P(TEXT,U,2),TXT(1)=TEXT
I $G(ICDFMT)=1!($G(ICDFMT)=2) D
. K TX S TXT(1)=TEXT D PAR^ICDEX(.TXT,64) K TX2 F ICDI=2:1:8 D
. . S:$L($G(TXT(ICDI))) TX2(1)=$G(TX2(1))_" "_$G(TXT(ICDI))
. S TX(1)=$G(TXT(1)) I $D(TX2) D
. . N SP S SP=" " D PAR^ICDEX(.TX2,54) S ICDI=0
. . F S ICDI=$O(TX2(ICDI)) Q:+ICDI'>0 D
. . . N CT Q:'$L($G(TX2(ICDI)))
. . . S CT=$O(TX(" "),-1)+1 S TX(CT)=SP_$G(TX2(ICDI))
I $G(ICDFMT)'=1&($G(ICDFMT)'=2) D
. K TX N ICDI D PAR^ICDEX(.TXT,64) S ICDI=0 F S ICDI=$O(TXT(ICDI)) Q:+ICDI'>0 D
. . N CT S CT=$O(TX(" "),-1)+1 S TX(CT)=$G(TXT(ICDI))
S DIR("A",1)=" One match found",DIR("A",2)=" "
S ICDI=0 F S ICDI=$O(TX(ICDI)) Q:+ICDI'>0 D
. Q:'$L($G(TX(ICDI))) N CT S CT=$O(DIR("A"," "),-1)+1
. S DIR("A",CT)=(" "_$G(TX(ICDI)))
S CT=$O(DIR("A"," "),-1)+1,DIR("A",CT)=" ",DIR("A")=" OK? "
S DIR("B")="Yes",DIR(0)="YAO" W !
S ICDPR="" I $L($G(DICR(2,1))),$L($G(DICR(1,1))) D
. S ICDPR=DICR(1,1)_$C(34)_"B"_$C(34)_","_+IEN_")"
I $L(ICDPR),$D(@ICDPR) D Q 1
. S LN=$O(DIR("A"," "),-1) I LN>0 N LN2 F LN2=1:1:(LN-1) W !,DIR("A",LN2)
K DIROUT,DIRUT,DUOUT,DTOUT D ^DIR S:$D(DTOUT) ICDOTIM=1,Y=-1
S:$D(DUOUT) ICDOUPA=1,Y=-1 S:$D(DIROUT) ICDOUPA=2,Y=-1
Q:+Y>0 1
Q -1
ONESM(X) ; One Entry Found ScreenMan
N DIROUT,DIRUT,ANS,CODE,ICDMENU,IEN,ITEM,TEXT,VST S ICDOREV=1
S ITEM=$G(^TMP(SUB,$J,"SEL",1)) Q:'$L(ITEM) -1
S IEN=+ITEM,TEXT=$P(ITEM,U,2) S CODE=$$CODEC^ICDEX(+($G(FILE)),IEN)
S VST=$$VST^ICDEX(+($G(FILE)),IEN,ICDCDT)
I $L(CODE),$L(VST) S TEXT=CODE,TEXT=TEXT_$J(" ",(9-$L(TEXT)))_VST
Q:'$L(TEXT) -1 S ICDMENU(1)=(" "_$G(TEXT)),ICDMENU(2)=" OK? Yes// "
S ICDMENU="ICDMENU" D HLP^DDSMSG(.ICDMENU) S ICDOREV=1
R ANS:300 S X="" S:'$T ICDOTIM=1 S:'$L(ANS) ANS="Y" S:$G(ANS)["^" ICDOUPA=1
S:$G(ANS)["^^" ICDOUPA=2 S:$G(ICDOTIM)=1 X="^^" S:$G(ICDOUPA)=1 X="^"
S:$G(ICDOUPA)=2 X="^^" D CLRMSG^DDS Q:X["^" X
S ANS=$E(ANS,1) S X=$S("^Y^y^"[("^"_ANS_"^"):1,1:-1)
Q X
MUL(X) ; Multiple Entries Found
S:'$D(DDS) X=$$MULRS S:$D(DDS) X=$$MULSM
Q X
MULRS(X) ; Multiple Entries Found Roll and Scroll
Q:+($G(EXIT))>0 "^^" N ENT,EXIT,IEN,ITEM,LEN,MAX,ROOT,SEL,TEXT,TOT,Y
Q:$G(DIC(0))'["E" -1 S ROOT=$G(DIC),LEN=+($G(ICDDICN)) S:+LEN'>0 LEN=5
S (MAX,ENT,SEL,EXIT)=0,U="^",TOT=$G(^TMP(SUB,$J,"SEL",0))
S SEL=0 G:+TOT=0 MULQ W:+TOT>1 !!," ",TOT," matches found"
F ENT=1:1:TOT Q:((SEL>0)&(SEL<ENT+1)) Q:EXIT D Q:EXIT
. N ITEM,IEN,TEXT S ITEM=$G(^TMP(SUB,$J,"SEL",ENT))
. S IEN=+ITEM,TEXT=$P(ITEM,U,2) Q:'$L(TEXT)
. S MAX=ENT W:ENT#LEN=1 ! D MULRSW S:ENT=TOT ICDOREV=1
. W:ENT#LEN=0 ! S:ENT#LEN=0 SEL=$$MULRSS(MAX,ENT) S:SEL["^" EXIT=1
I ENT#LEN'=0,+SEL=0 W ! S SEL=$$MULRSS(MAX,ENT) S:SEL["^" EXIT=1
G MULQ
Q X
MULRSW ; Write Multiple Roll and Scroll
Q:+($G(IEN))'>0 Q:'$L($G(ROOT)) Q:'$L($G(TEXT))
N ICDI,IND,NR,TAB,TX2,TXT,Y,RT,LEN S (TAB,IND)=8
S RT=$$ROOT^ICDEX(ROOT)
S:+($G(ICDOUT))<3 IND=18 W !,$J(ENT,5),".",?TAB
S:$G(DIC(0))["S"&($G(IND))>7 IND=TAB
I +($G(ICDISF))'>0,$L($G(DIC("W"))) D Q
. N Y,NR D Y(ROOT,IEN,ICDCDT)
. S NR=$G(@(RT_+IEN_",0)"))
. W $P(NR,"^",1)," " X DIC("W") Q
I +($G(ICDISF))'>0,$D(DIC("W")),DIC("W")="" D Q
. W $P($G(@(RT_+IEN_",0)")),"^",1)
I +($G(ICDOUT))<3 D Q
. N ICDI,LEN S TXT(1)=TEXT D PAR^ICDEX(.TXT,64) K TX2 F ICDI=2:1:8 D
. . S:$L($G(TXT(ICDI))) TX2(1)=$G(TX2(1))_" "_$G(TXT(ICDI))
. W $G(TXT(1)) I $D(TX2) D
. . N LEN S LEN=54 S:$G(DIC(0))["S" LEN=64
. . S:$G(DIC(0))["S" IND=TAB
. . D PAR^ICDEX(.TX2,LEN) S ICDI=0
. . F S ICDI=$O(TX2(ICDI)) Q:+ICDI'>0 W !,?IND,$G(TX2(ICDI))
S TXT(1)=TEXT
D PAR^ICDEX(.TXT,64) S ICDI=0 F S ICDI=$O(TXT(ICDI)) Q:+ICDI'>0 D
. Q:'$L($G(TXT(ICDI))) W:ICDI>1 ! W ?IND,$G(TXT(ICDI))
Q
Q:+($G(EXIT))>0 "^^" N DTOUT,DUOUT,DIRUT,DIROUT,DIR,DIRB,HLP
N LAST,MAX,NEXT,RAN,X,Y S MAX=+($G(LEX)),LAST=+($G(LS)) Q:MAX=0 -1
S RAN=" Select 1-"_MAX_": ",NEXT=$O(^TMP(SUB,$J,"SEL",+LAST))
S:+NEXT>0 DIR("A")=" Press <RETURN> for more, '^' to exit, or"_RAN
S:+NEXT'>0 DIR("A")=RAN
S HLP=" Answer must be from 1 to "_MAX_", or <Return> to continue"
S DIR("PRE")="S:X[""?"" X=""??"""
S (DIR("?"),DIR("??"))="^D MULRSSH^ICDEXLK2"
S DIR(0)="NAO^1:"_MAX_":0" K DIROUT,DIRUT,DUOUT,DTOUT D ^DIR
S:$D(DTOUT) ICDOTIM=1,EXIT=1,Y=-1,X="^^" S:$D(DUOUT) ICDOUPA=1,Y=-1,X="^"
S:$D(DIROUT) ICDOUPA=2,Y=-1,X="^^" S LEX=+Y S:$D(DTOUT)!(X[U) LEX=U
Q LEX
I $L($G(HLP)) W !,$G(HLP) Q
Q
MULSM(X) ; Multiple Entries Found ScreenMan
Q:+($G(EXIT))>0 "^^" N CODE,CTR,ENT,EXIT,ICDMENU,IEN,ITEM,LEN
N MAX,ROOT,SEL,TEXT,TOT,VST,Y S ROOT=$G(DIC),(MAX,ENT,SEL,EXIT)=0
S U="^",LEN=3,TOT=$G(^TMP(SUB,$J,"SEL",0)),SEL=0 G:+TOT=0 MULQ
S CTR=0 F ENT=1:1:TOT Q:((SEL>0)&(SEL<ENT+1)) Q:EXIT D Q:EXIT
. N ITEM,IEN,TEXT,CODE,VST S ITEM=$G(^TMP(SUB,$J,"SEL",ENT))
. S IEN=+ITEM,TEXT=$P(ITEM,U,2) S CODE=$$CODEC^ICDEX(+($G(FILE)),IEN)
. S VST=$$VST^ICDEX(+($G(FILE)),IEN,ICDCDT)
. I $L(CODE),$L(VST) S TEXT=CODE,TEXT=TEXT_$J(" ",(9-$L(TEXT)))_VST
. Q:'$L(TEXT) S MAX=ENT D MULSMW S:ENT=TOT ICDOREV=1
. S:ENT#LEN=0 SEL=$$MULSMS(MAX,ENT) S:SEL["^" EXIT=1
K:$D(DUOUT) ICDMENU
I ENT#LEN'=0,+SEL=0,'EXIT D
. Q:+($G(ICDOUPA))>0 S SEL=$$MULSMS(MAX,ENT) S:SEL["^" EXIT=1
I EXIT>0 D G MULQ
. D CLRMSG^DDS K ICDMENU S:$L($G(DICR("1"))) DICR("1")="^^" S:$L($G(ICDOINP)) ICDOINP="^^"
D CLRMSG^DDS
G MULQ
MULSMW ; Write Multiple ScreenMan
Q:+($G(ENT))'>0 Q:'$L($G(TEXT)) N CTR S CTR=$O(ICDMENU(" "),-1)+1
S ICDMENU(CTR)=$J(ENT,3)_"."_" "_$G(TEXT)
Q
MULSMS(LEX,LS) ; Select Multiple ScreenMan
Q:+($G(EXIT))>0 "^^" N DIROUT,DUOUT,DTOUT,DIRUT,ANS,CTR,LAST,MAX,PMT,X
Q:'$D(ICDMENU) "^" S MAX=+($G(LEX)),LAST=+($G(LS)) Q:MAX=0 -1
S PMT=" Select 1-"_MAX_", <RETURN> for more or '^' to exit: "
S CTR=$O(ICDMENU(" "),-1)+1,ICDMENU(CTR)=PMT
S ICDMENU="ICDMENU" D HLP^DDSMSG(.ICDMENU)
K ICDMENU R ANS:300 S X="" S:'$T ICDOTIM=1,X="^^"
S:ANS["^" ICDOUPA=1,X="^" S:ANS["^^" ICDOUPA=2,X="^^" Q:X["^" X
D CLRMSG^DDS S ANS=+ANS Q:ANS'>0 "" Q:ANS>MAX "" S X=ANS
Q X
MULQ ; Quit Multiple
S X=+($G(SEL)) Q:X'>0 -1
Q X
;
INP(X,VER,CDT) ; Get User Input
Q:$G(DIC(0))'["A" "" N DIROUT,DIRUT,DUOUT,DTOUT,DIR,DIRA,DIRB,SBR,SBT,FILE,ROOT
S VER=+($G(VER)),CDT=+($G(CDT))
S FILE=$G(X) Q:"^80^80.1^"'[("^"_FILE_"^") "" S ROOT=$$ROOT^ICDEX(FILE)
S:$L($G(ICDDICB)) DIRB=ICDDICB S:$L($G(ICDDICA)) DIRA=ICDDICA
S:'$L($G(DIRA))&(FILE=80) DIRA=" Select ICD Diagnosis: "
S:'$L($G(DIRA))&(FILE=80.1) DIRA=" Select Procedure: "
S:'$L($G(DIRA)) DIRA=" Select ICD Text or Code: "
S SBT="",SBR=$$RET^ICDEXLK6($G(FILE))
I SBR>0,VER>0,CDT?7N,$L(ROOT) D
. N CODE,SYS,STA
. S CODE=$G(@(ROOT_+SBR_",0)"))
. S SYS=$P($G(@(ROOT_+SBR_",1)")),"^",1)
. S STA=$$STATCHK^ICDEX(CODE,CDT,SYS)
. S:STA'>0 SBR=0
S:+SBR>0 SBT=$$LD^ICDEX(FILE,+SBR,$G(ICDCDT))
S:$L($G(DIRB)) DIR("B")=DIRB
S:$L($G(DIRA)) DIR("A")=DIRA W:'$L($G(DIRB)) !
S DIR("PRE")="S X=$$INPRE^ICDEXLK2($G(X))"
S (DIR("?"),DIR("??"))="^D INPH^ICDEXLK2($G(FILE))"
S DIR("?")="^D INPH^ICDEXLK2($G(FILE))"
S DIR("??")="^D INPH2^ICDEXLK2($G(FILE))"
N Y S DIR(0)="FAO^0:245"
K X,DIROUT,DIRUT,DUOUT,DTOUT D ^DIR
S:$G(X)="@"&($G(Y)="") Y=$G(X)
S:$D(DTOUT) ICDOTIM=1 S:$D(DUOUT) ICDOUPA=1 S:$D(DIROUT) ICDOUPA=2
Q:$G(ICDOUPA)=1 "^" Q:$G(ICDOUPA)=2 "^^" Q:$G(ICDOTIM)>0 "^^"
I '$L(X) S (X,ICDX,INP,INP1,INP2)="",Y=-1 Q X
S:X=""&('$L($G(DIR("B")))) X="^" S:X["^"&(X'["^^") X="^" S:X["^^" X="^^" Q:X["^" X
I $E(X,1)=" ",$L(SBT),+SBR>0 S X=("`"_+SBR) Q X
W:$G(DIC(0))'["Q"&($E(X,1)'=" ")&('$D(DDS)) !
S X=$$UP^XLFSTR($$TM(Y))
Q X
INPH(X) ; Input Help
N FILE,TYPE,TMP,TXT S FILE=$G(X)
S TYPE=$S(FILE=80:"Diagnosis ",FILE=80.1:"Procedure ",1:"")
I '$L($G(TYPE)) D Q
. S TMP="Enter a term (2-245 characters in length) or a code."
. I +($G(VER))>0 S TMP=TMP_" Only active codes will be considered for selection."
. S TXT(1)=TMP D PA^ICDEXLK6(.TXT,66)
. S TMP=0 F S TMP=$O(TXT(TMP)) Q:+TMP'>0 W !,?4,$G(TXT(TMP))
S TMP="Enter a "_TYPE_"(2-245 characters in length) or a "_TYPE_"code."
I +($G(VER))>0 S TMP=TMP_" Only active "_TYPE_"codes will be considered for selection."
S TXT(1)=TMP D PA^ICDEXLK6(.TXT,66)
S TMP=0 F S TMP=$O(TXT(TMP)) Q:+TMP'>0 W !,?4,$G(TXT(TMP))
Q
INPH2(X) ; Input Help
N FILE,TYPE,TMP,TXT S FILE=$G(X)
S TYPE=$S(FILE=80:"Diagnosis ",FILE=80.1:"Procedure ",1:"")
I '$L($G(TYPE)) D Q
. S TMP="Enter a term (2-245 characters in length), a code or code fragment,"
. S TMP=TMP_" phrase, or an accent grave character (`) followed by the"
. S TMP=TMP_" IEN to select a specific entry"
. I $G(ICDDIC0)'["F" D
. . S TMP=TMP_", or press space bar and Enter/Return key to do a subsequent lookup of the same entry"
. S TMP=TMP_"." I +($G(VER))>0 D
. . S TMP=TMP_" Only active codes will be considered for selection."
. S TXT(1)=TMP D PA^ICDEXLK6(.TXT,66)
. S TMP=0 F S TMP=$O(TXT(TMP)) Q:+TMP'>0 W !,?4,$G(TXT(TMP))
S TMP="Enter a "_TYPE_"name"
S TMP=TMP_" (2-245 characters in length), a "_TYPE_"code or code fragment,"
S TMP=TMP_" one or more keywords sufficient to select a "_TYPE
S TMP=TMP_" name, or an accent grave character (`) followed by the"
S TMP=TMP_" IEN to select a specific entry"
I $G(ICDDIC0)'["F" D
. S TMP=TMP_", or press space bar and Enter/Return key to do a subsequent lookup of the same entry"
S TMP=TMP_"." I +($G(VER))>0 D
. S TMP=TMP_" Only active "_TYPE_"codes will be considered for selection."
S TXT(1)=TMP D PA^ICDEXLK6(.TXT,66)
S TMP=0 F S TMP=$O(TXT(TMP)) Q:+TMP'>0 W !,?4,$G(TXT(TMP))
Q
INPRE(X) ; Input Pre-Processing
Q:'$L($G(X)) "" N IN,IN1,IN2 S IN=$G(X)
Q:IN["??" "??" Q:IN["?" "?"
S IN1=$E(IN,1),IN2=$E(IN,2,$L(IN))
I IN1["`",IN2?1N.N,$L($G(ROOT)) D Q X
. Q:IN1="`"&(IN2?1N.N)&($D(@(ROOT_+IN2_",0)"))) S X="??"
I $L($G(ROOT)) I IN1=" ",'$L(IN2) D Q:$E(X,1)="`"!($E(X,1)="?") X
. N FI,CODE,SYS,STA,ND,SB,OUT S FI=$$FILE^ICDEX(ROOT)
. Q:+FI'>0 S SB=$$RET^ICDEXLK6($G(FILE))
. I SB>0,+($G(VER))'>0 S X="`"_+SB Q
. I SB>0,+($G(VER))>0,+($G(CDT))?7N,$L(ROOT) D
. . N CODE,SYS,STA
. . S CODE=$G(@(ROOT_+SB_",0)")) Q:'$L(CODE)
. . S SYS=$P($G(@(ROOT_+SB_",1)")),"^",1) Q:+SYS'>0
. . S STA=$$STATCHK^ICDEX(CODE,CDT,SYS)
. . S:STA'>0 SB=0 S:+SB>0 X="`"_+SB S:+SB'>0 X="??"
Q X
;
; Miscellaneous
OUT(X,Y,FMT,ARY) ; Output Array
K ARY N FILE,TERM,ROOT,IEN S ROOT=$G(X),IEN=+($G(Y)) Q:'$L(ROOT)
Q:"^ICD9(^ICD0(^"'[("^"_$E(ROOT,2,$L(ROOT))_"^")
S FILE=$$FILE^ICDEX(ROOT) Q:"^80^80.1^"'[("^"_FILE_"^")
S FMT=+($G(FMT)) S:FMT'>0 FMT=1 S:FMT>4 FMT=1 Q:'$D(@(ROOT_IEN_",0)"))
I +($G(FMT))=1!(+($G(FMT))=3) S TERM=$$SD^ICDEX(FILE,IEN,CDT)
I +($G(FMT))=2!(+($G(FMT))=4) S TERM=$$LD^ICDEX(FILE,IEN,CDT)
Q:'$L(TERM) Q:$P(TERM,"^",1)=-1 S ARY(1)=TERM Q:+($G(FMT))=1!(+($G(FMT))=3)
D:+($G(FMT))=2 PAR^ICDEX(.ARY,60) D:+($G(FMT))=4 PAR^ICDEX(.ARY,70)
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
X(SEL,SUB) ; Set X
K X N IEN S SEL=+($G(SEL)),SUB=$G(SUB) Q:'$L(SUB)
S IEN=$G(^TMP(SUB,$J,"SEL",+SEL)) Q:+IEN'>0 S X=+IEN
Q
Y(ROOT,IEN,CDT,FMT) ; Set Y
;
; Input
;
; ROOT Global Root (DIC) or File Number
; IEN Internal Entry Number
; CDT Versioning Date (default TODAY)
; FMT Format of Output
; 0 Standard Fileman Y IEN ^ CODE
; 1 Expanded Y as if DIC(0) contained a "Z"
; Output
;
; Y IEN ^ Code Fileman
;
; If DIC(0) contains "Z" or input parameter FMT > 0
;
; Y(0) 0 Node (Code) Fileman
; Y(0,0) .01 Field (Code) Fileman
; Y(0,1) $$ICDDX or $$ICDOP Non-Fileman
; Y(0,2) Long Description Non-Fileman
;
N CODE,NODE0,FILE,SHORT,FDAT,LONG,ICD10 K Y S Y=-1
S:+($G(ICDOFND))>0&(+($G(ICDOSEL))'>0) Y="-1^No selection made"
S IEN=+($G(IEN)),ROOT=$G(ROOT),CDT=+($G(CDT))
S:CDT'?7N CDT=$$DT^XLFDT S ICD10=+($$IMP^ICDEX(30))
S ROOT=$$ROOT^ICDEX(ROOT) Q:'$L(ROOT)
S FILE=$$FILE^ICDEX(ROOT) Q:+FILE'>0
S NODE0=$G(@(ROOT_+IEN_",0)")) Q:'$L(NODE0)
S CODE=$$CODEC^ICDEX(FILE,IEN) Q:'$L(CODE)
S SHORT=$$SD^ICDEX(FILE,IEN,CDT) Q:'$L(SHORT)
S FMT=+($G(FMT)) I $P(SHORT,"^",1)=-1 D Q:'$L(SHORT)
. S SHORT=$$SD^ICDEX(FILE,IEN,ICD10)
. S:$P(SHORT,"^",1)=-1 SHORT="" Q:'$L(SHORT)
. S SHORT=SHORT_" (Pending - "_$$FMTE^XLFDT($$IMP^ICDEX(30))_")"
S Y=+IEN_"^"_CODE
S:$G(DIC(0))["Z"!(+FMT>0) Y(0)=NODE0
S CODE=$P(NODE0,"^",1) Q:'$L(CODE)
S:FILE=80 FDAT=$$ICDDX^ICDEX(CODE,CDT,,"E")
S:FILE=80.1 FDAT=$$ICDOP^ICDEX(CODE,CDT,,"E")
S LONG=$$LD^ICDEX(ROOT,IEN,CDT)
S:$G(DIC(0))["Z"!(+FMT>0) Y(0,0)=CODE
S:$L(FDAT)&($L(LONG))&($G(DIC(0))["Z")!(+FMT>0) Y(0,1)=FDAT,Y(0,2)=LONG
Q
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDEXLK2 15813 printed Sep 23, 2025@19:26:45 Page 2
ICDEXLK2 ;SLC/KER - ICD Extractor - Lookup, SBR/Ask/One/Mul ;12/19/2014
+1 ;;18.0;DRG Grouper;**57,67,82**;Oct 20, 2000;Build 21
+2 ;
+3 ; Global Variables
+4 ; ^TMP(SUB,$J SACC 2.3.2.5.1
+5 ;
+6 ; External References
+7 ; CLRMSG^DDS ICR 5846
+8 ; HLP^DDSMSG ICR 5847
+9 ; ^DIR ICR 10026
+10 ; $$DT^XLFDT ICR 10103
+11 ; $$FMADD^XLFDT ICR 10103
+12 ; $$UP^XLFSTR ICR 10104
+13 ;
+14 ; Local Variables NEWed or KILLed Elsewhere
+15 ; DDS,DIC,DICR,ICDCDT,ICDDIC0,ICDDICA,
+16 ; ICDDICB,ICDDICN,ICDFMT,ICDISF,ICDOFND,
+17 ; ICDOINP,ICDOREV,ICDOSEL,ICDOTIM,ICDOUPA
+18 ; ICDOUT,ICDSYS,ICDVER,ICDX,INP1,INP2
+19 ;
+20 QUIT
ASK ; Ask for Selection
+1 KILL X,Y
NEW ANS
SET ICDOFND=+($GET(ICDOFND))
if +ICDOFND'>0
QUIT
+2 IF ICDOFND=1
IF DIC(0)'["E"
Begin DoDot:1
+3 KILL X,Y
DO X(1,SUB)
SET (ICDOFND,ICDOSEL,ICDOREV)=1
+4 DO Y($GET(ROOT),+($GET(^TMP(SUB,$JOB,"SEL",1))),$GET(ICDCDT))
+5 IF +($GET(Y))'>0
IF $LENGTH($GET(INP))
SET X=$GET(INP)
QUIT
+6 IF +($GET(Y))>0
if $GET(DIC(0))'["F"
DO SAV^ICDEXLK6(+($GET(Y)),ROOT)
End DoDot:1
QUIT
+7 IF ICDOFND>1
IF DIC(0)'["E"
Begin DoDot:1
+8 KILL Y
SET Y="-1^Selection not made"
SET ICDOSEL=0
End DoDot:1
QUIT
+9 if +ICDOFND=1
SET ANS=$$ONE
if +ICDOFND>1
SET ANS=$$MUL
SET ICDOSEL=0
+10 IF ANS>0
Begin DoDot:1
+11 DO X(+ANS,SUB)
SET ICDOSEL=1
+12 DO Y($GET(ROOT),+($GET(^TMP(SUB,$JOB,"SEL",+ANS))),$GET(ICDCDT))
+13 IF +($GET(Y))'>0
IF $LENGTH($GET(INP))
SET X=$GET(INP)
QUIT
+14 IF +($GET(Y))>0
if $GET(DIC(0))'["F"
DO SAV^ICDEXLK6(+($GET(Y)),ROOT)
End DoDot:1
+15 IF ANS'>0
KILL INP,X,Y,^TMP(SUB,$JOB)
+16 QUIT
SBR ; Space-Bar Return DIC(0) not contain "A"
+1 NEW SBI,SUB,OUT,ANS,SBS
KILL Y
SET Y=-1
if '$LENGTH($GET(ROOT))
QUIT
if ROOT="^"
QUIT
if '$LENGTH($GET(FILE))
QUIT
+2 SET SBI=$$RET^ICDEXLK6($GET(FILE))
SET SUB=$TRANSLATE($GET(ROOT),"^(","")
if $LENGTH(SUB)
KILL ^TMP(SUB,$JOB)
if +SBI'>0
QUIT
+3 SET SBS=$PIECE($GET(@(ROOT_+SBI_",1)")),"^",1)
if +SBS'>0
QUIT
if +SBI>0&(+SBS>0)&(+($GET(ICDSYS))>0)&(+($GET(ICDSYS))'=+SBS)
QUIT
+4 DO FND^ICDEXLK5($GET(ROOT),+SBI,$GET(ICDCDT),$GET(ICDSYS),$GET(ICDVER),0,$GET(ICDOUT))
+5 DO SEL^ICDEXLK5(ROOT,0)
if '$DATA(^TMP(SUB,$JOB,"SEL",1))
QUIT
SET ANS=$$ONE
IF ANS>0
Begin DoDot:1
+6 DO X(1,SUB)
SET (ICDOFND,ICDOSEL,ICDOREV)=1
+7 DO Y($GET(ROOT),+($GET(^TMP(SUB,$JOB,"SEL",1))),$GET(ICDCDT))
+8 IF +($GET(Y))'>0
IF $LENGTH($GET(INP))
SET X=$GET(INP)
QUIT
+9 IF +($GET(Y))>0
if $GET(DIC(0))'["F"
DO SAV^ICDEXLK6(+($GET(Y)),ROOT)
End DoDot:1
+10 if +Y>0&($LENGTH($PIECE(Y,"^",2)))
SET X=$PIECE(Y,"^",2)
+11 IF ANS'>0
KILL INP,X,Y,^TMP(SUB,$JOB)
SET X=""
SET Y="-1^No user input"
+12 QUIT
ONE(X) ; One Entry Found
+1 if '$DATA(DDS)
SET X=$$ONERS
if $DATA(DDS)
SET X=$$ONESM
SET ICDOREV=1
+2 QUIT X
ONERS(X) ; One Entry Found Roll and Scroll
+1 NEW DIROUT,DIRUT,DIR,IEN,LN,LN2,ICDI,ICDPR,TEXT,TXT,TX,CT,Y
SET ICDOREV=1
+2 SET TEXT=$GET(^TMP(SUB,$JOB,"SEL",1))
if $GET(DIC(0))'["E"
QUIT 1
+3 SET IEN=+TEXT
SET TEXT=$PIECE(TEXT,U,2)
SET TXT(1)=TEXT
+4 IF $GET(ICDFMT)=1!($GET(ICDFMT)=2)
Begin DoDot:1
+5 KILL TX
SET TXT(1)=TEXT
DO PAR^ICDEX(.TXT,64)
KILL TX2
FOR ICDI=2:1:8
Begin DoDot:2
+6 if $LENGTH($GET(TXT(ICDI)))
SET TX2(1)=$GET(TX2(1))_" "_$GET(TXT(ICDI))
End DoDot:2
+7 SET TX(1)=$GET(TXT(1))
IF $DATA(TX2)
Begin DoDot:2
+8 NEW SP
SET SP=" "
DO PAR^ICDEX(.TX2,54)
SET ICDI=0
+9 FOR
SET ICDI=$ORDER(TX2(ICDI))
if +ICDI'>0
QUIT
Begin DoDot:3
+10 NEW CT
if '$LENGTH($GET(TX2(ICDI)))
QUIT
+11 SET CT=$ORDER(TX(" "),-1)+1
SET TX(CT)=SP_$GET(TX2(ICDI))
End DoDot:3
End DoDot:2
End DoDot:1
+12 IF $GET(ICDFMT)'=1&($GET(ICDFMT)'=2)
Begin DoDot:1
+13 KILL TX
NEW ICDI
DO PAR^ICDEX(.TXT,64)
SET ICDI=0
FOR
SET ICDI=$ORDER(TXT(ICDI))
if +ICDI'>0
QUIT
Begin DoDot:2
+14 NEW CT
SET CT=$ORDER(TX(" "),-1)+1
SET TX(CT)=$GET(TXT(ICDI))
End DoDot:2
End DoDot:1
+15 SET DIR("A",1)=" One match found"
SET DIR("A",2)=" "
+16 SET ICDI=0
FOR
SET ICDI=$ORDER(TX(ICDI))
if +ICDI'>0
QUIT
Begin DoDot:1
+17 if '$LENGTH($GET(TX(ICDI)))
QUIT
NEW CT
SET CT=$ORDER(DIR("A"," "),-1)+1
+18 SET DIR("A",CT)=(" "_$GET(TX(ICDI)))
End DoDot:1
+19 SET CT=$ORDER(DIR("A"," "),-1)+1
SET DIR("A",CT)=" "
SET DIR("A")=" OK? "
+20 SET DIR("B")="Yes"
SET DIR(0)="YAO"
WRITE !
+21 SET ICDPR=""
IF $LENGTH($GET(DICR(2,1)))
IF $LENGTH($GET(DICR(1,1)))
Begin DoDot:1
+22 SET ICDPR=DICR(1,1)_$CHAR(34)_"B"_$CHAR(34)_","_+IEN_")"
End DoDot:1
+23 IF $LENGTH(ICDPR)
IF $DATA(@ICDPR)
Begin DoDot:1
+24 SET LN=$ORDER(DIR("A"," "),-1)
IF LN>0
NEW LN2
FOR LN2=1:1:(LN-1)
WRITE !,DIR("A",LN2)
End DoDot:1
QUIT 1
+25 KILL DIROUT,DIRUT,DUOUT,DTOUT
DO ^DIR
if $DATA(DTOUT)
SET ICDOTIM=1
SET Y=-1
+26 if $DATA(DUOUT)
SET ICDOUPA=1
SET Y=-1
if $DATA(DIROUT)
SET ICDOUPA=2
SET Y=-1
+27 if +Y>0
QUIT 1
+28 QUIT -1
ONESM(X) ; One Entry Found ScreenMan
+1 NEW DIROUT,DIRUT,ANS,CODE,ICDMENU,IEN,ITEM,TEXT,VST
SET ICDOREV=1
+2 SET ITEM=$GET(^TMP(SUB,$JOB,"SEL",1))
if '$LENGTH(ITEM)
QUIT -1
+3 SET IEN=+ITEM
SET TEXT=$PIECE(ITEM,U,2)
SET CODE=$$CODEC^ICDEX(+($GET(FILE)),IEN)
+4 SET VST=$$VST^ICDEX(+($GET(FILE)),IEN,ICDCDT)
+5 IF $LENGTH(CODE)
IF $LENGTH(VST)
SET TEXT=CODE
SET TEXT=TEXT_$JUSTIFY(" ",(9-$LENGTH(TEXT)))_VST
+6 if '$LENGTH(TEXT)
QUIT -1
SET ICDMENU(1)=(" "_$GET(TEXT))
SET ICDMENU(2)=" OK? Yes// "
+7 SET ICDMENU="ICDMENU"
DO HLP^DDSMSG(.ICDMENU)
SET ICDOREV=1
+8 READ ANS:300
SET X=""
if '$TEST
SET ICDOTIM=1
if '$LENGTH(ANS)
SET ANS="Y"
if $GET(ANS)["^"
SET ICDOUPA=1
+9 if $GET(ANS)["^^"
SET ICDOUPA=2
if $GET(ICDOTIM)=1
SET X="^^"
if $GET(ICDOUPA)=1
SET X="^"
+10 if $GET(ICDOUPA)=2
SET X="^^"
DO CLRMSG^DDS
if X["^"
QUIT X
+11 SET ANS=$EXTRACT(ANS,1)
SET X=$SELECT("^Y^y^"[("^"_ANS_"^"):1,1:-1)
+12 QUIT X
MUL(X) ; Multiple Entries Found
+1 if '$DATA(DDS)
SET X=$$MULRS
if $DATA(DDS)
SET X=$$MULSM
+2 QUIT X
MULRS(X) ; Multiple Entries Found Roll and Scroll
+1 if +($GET(EXIT))>0
QUIT "^^"
NEW ENT,EXIT,IEN,ITEM,LEN,MAX,ROOT,SEL,TEXT,TOT,Y
+2 if $GET(DIC(0))'["E"
QUIT -1
SET ROOT=$GET(DIC)
SET LEN=+($GET(ICDDICN))
if +LEN'>0
SET LEN=5
+3 SET (MAX,ENT,SEL,EXIT)=0
SET U="^"
SET TOT=$GET(^TMP(SUB,$JOB,"SEL",0))
+4 SET SEL=0
if +TOT=0
GOTO MULQ
if +TOT>1
WRITE !!," ",TOT," matches found"
+5 FOR ENT=1:1:TOT
if ((SEL>0)&(SEL<ENT+1))
QUIT
if EXIT
QUIT
Begin DoDot:1
+6 NEW ITEM,IEN,TEXT
SET ITEM=$GET(^TMP(SUB,$JOB,"SEL",ENT))
+7 SET IEN=+ITEM
SET TEXT=$PIECE(ITEM,U,2)
if '$LENGTH(TEXT)
QUIT
+8 SET MAX=ENT
if ENT#LEN=1
WRITE !
DO MULRSW
if ENT=TOT
SET ICDOREV=1
+9 if ENT#LEN=0
WRITE !
if ENT#LEN=0
SET SEL=$$MULRSS(MAX,ENT)
if SEL["^"
SET EXIT=1
End DoDot:1
if EXIT
QUIT
+10 IF ENT#LEN'=0
IF +SEL=0
WRITE !
SET SEL=$$MULRSS(MAX,ENT)
if SEL["^"
SET EXIT=1
+11 GOTO MULQ
+12 QUIT X
MULRSW ; Write Multiple Roll and Scroll
+1 if +($GET(IEN))'>0
QUIT
if '$LENGTH($GET(ROOT))
QUIT
if '$LENGTH($GET(TEXT))
QUIT
+2 NEW ICDI,IND,NR,TAB,TX2,TXT,Y,RT,LEN
SET (TAB,IND)=8
+3 SET RT=$$ROOT^ICDEX(ROOT)
+4 if +($GET(ICDOUT))<3
SET IND=18
WRITE !,$JUSTIFY(ENT,5),".",?TAB
+5 if $GET(DIC(0))["S"&($GET(IND))>7
SET IND=TAB
+6 IF +($GET(ICDISF))'>0
IF $LENGTH($GET(DIC("W")))
Begin DoDot:1
+7 NEW Y,NR
DO Y(ROOT,IEN,ICDCDT)
+8 SET NR=$GET(@(RT_+IEN_",0)"))
+9 WRITE $PIECE(NR,"^",1)," "
XECUTE DIC("W")
QUIT
End DoDot:1
QUIT
+10 IF +($GET(ICDISF))'>0
IF $DATA(DIC("W"))
IF DIC("W")=""
Begin DoDot:1
+11 WRITE $PIECE($GET(@(RT_+IEN_",0)")),"^",1)
End DoDot:1
QUIT
+12 IF +($GET(ICDOUT))<3
Begin DoDot:1
+13 NEW ICDI,LEN
SET TXT(1)=TEXT
DO PAR^ICDEX(.TXT,64)
KILL TX2
FOR ICDI=2:1:8
Begin DoDot:2
+14 if $LENGTH($GET(TXT(ICDI)))
SET TX2(1)=$GET(TX2(1))_" "_$GET(TXT(ICDI))
End DoDot:2
+15 WRITE $GET(TXT(1))
IF $DATA(TX2)
Begin DoDot:2
+16 NEW LEN
SET LEN=54
if $GET(DIC(0))["S"
SET LEN=64
+17 if $GET(DIC(0))["S"
SET IND=TAB
+18 DO PAR^ICDEX(.TX2,LEN)
SET ICDI=0
+19 FOR
SET ICDI=$ORDER(TX2(ICDI))
if +ICDI'>0
QUIT
WRITE !,?IND,$GET(TX2(ICDI))
End DoDot:2
End DoDot:1
QUIT
+20 SET TXT(1)=TEXT
+21 DO PAR^ICDEX(.TXT,64)
SET ICDI=0
FOR
SET ICDI=$ORDER(TXT(ICDI))
if +ICDI'>0
QUIT
Begin DoDot:1
+22 if '$LENGTH($GET(TXT(ICDI)))
QUIT
if ICDI>1
WRITE !
WRITE ?IND,$GET(TXT(ICDI))
End DoDot:1
+23 QUIT
+1 if +($GET(EXIT))>0
QUIT "^^"
NEW DTOUT,DUOUT,DIRUT,DIROUT,DIR,DIRB,HLP
+2 NEW LAST,MAX,NEXT,RAN,X,Y
SET MAX=+($GET(LEX))
SET LAST=+($GET(LS))
if MAX=0
QUIT -1
+3 SET RAN=" Select 1-"_MAX_": "
SET NEXT=$ORDER(^TMP(SUB,$JOB,"SEL",+LAST))
+4 if +NEXT>0
SET DIR("A")=" Press <RETURN> for more, '^' to exit, or"_RAN
+5 if +NEXT'>0
SET DIR("A")=RAN
+6 SET HLP=" Answer must be from 1 to "_MAX_", or <Return> to continue"
+7 SET DIR("PRE")="S:X[""?"" X=""??"""
+8 SET (DIR("?"),DIR("??"))="^D MULRSSH^ICDEXLK2"
+9 SET DIR(0)="NAO^1:"_MAX_":0"
KILL DIROUT,DIRUT,DUOUT,DTOUT
DO ^DIR
+10 if $DATA(DTOUT)
SET ICDOTIM=1
SET EXIT=1
SET Y=-1
SET X="^^"
if $DATA(DUOUT)
SET ICDOUPA=1
SET Y=-1
SET X="^"
+11 if $DATA(DIROUT)
SET ICDOUPA=2
SET Y=-1
SET X="^^"
SET LEX=+Y
if $DATA(DTOUT)!(X[U)
SET LEX=U
+12 QUIT LEX
+1 IF $LENGTH($GET(HLP))
WRITE !,$GET(HLP)
QUIT
+2 QUIT
MULSM(X) ; Multiple Entries Found ScreenMan
+1 if +($GET(EXIT))>0
QUIT "^^"
NEW CODE,CTR,ENT,EXIT,ICDMENU,IEN,ITEM,LEN
+2 NEW MAX,ROOT,SEL,TEXT,TOT,VST,Y
SET ROOT=$GET(DIC)
SET (MAX,ENT,SEL,EXIT)=0
+3 SET U="^"
SET LEN=3
SET TOT=$GET(^TMP(SUB,$JOB,"SEL",0))
SET SEL=0
if +TOT=0
GOTO MULQ
+4 SET CTR=0
FOR ENT=1:1:TOT
if ((SEL>0)&(SEL<ENT+1))
QUIT
if EXIT
QUIT
Begin DoDot:1
+5 NEW ITEM,IEN,TEXT,CODE,VST
SET ITEM=$GET(^TMP(SUB,$JOB,"SEL",ENT))
+6 SET IEN=+ITEM
SET TEXT=$PIECE(ITEM,U,2)
SET CODE=$$CODEC^ICDEX(+($GET(FILE)),IEN)
+7 SET VST=$$VST^ICDEX(+($GET(FILE)),IEN,ICDCDT)
+8 IF $LENGTH(CODE)
IF $LENGTH(VST)
SET TEXT=CODE
SET TEXT=TEXT_$JUSTIFY(" ",(9-$LENGTH(TEXT)))_VST
+9 if '$LENGTH(TEXT)
QUIT
SET MAX=ENT
DO MULSMW
if ENT=TOT
SET ICDOREV=1
+10 if ENT#LEN=0
SET SEL=$$MULSMS(MAX,ENT)
if SEL["^"
SET EXIT=1
End DoDot:1
if EXIT
QUIT
+11 if $DATA(DUOUT)
KILL ICDMENU
+12 IF ENT#LEN'=0
IF +SEL=0
IF 'EXIT
Begin DoDot:1
+13 if +($GET(ICDOUPA))>0
QUIT
SET SEL=$$MULSMS(MAX,ENT)
if SEL["^"
SET EXIT=1
End DoDot:1
+14 IF EXIT>0
Begin DoDot:1
+15 DO CLRMSG^DDS
KILL ICDMENU
if $LENGTH($GET(DICR("1")))
SET DICR("1")="^^"
if $LENGTH($GET(ICDOINP))
SET ICDOINP="^^"
End DoDot:1
GOTO MULQ
+16 DO CLRMSG^DDS
+17 GOTO MULQ
MULSMW ; Write Multiple ScreenMan
+1 if +($GET(ENT))'>0
QUIT
if '$LENGTH($GET(TEXT))
QUIT
NEW CTR
SET CTR=$ORDER(ICDMENU(" "),-1)+1
+2 SET ICDMENU(CTR)=$JUSTIFY(ENT,3)_"."_" "_$GET(TEXT)
+3 QUIT
MULSMS(LEX,LS) ; Select Multiple ScreenMan
+1 if +($GET(EXIT))>0
QUIT "^^"
NEW DIROUT,DUOUT,DTOUT,DIRUT,ANS,CTR,LAST,MAX,PMT,X
+2 if '$DATA(ICDMENU)
QUIT "^"
SET MAX=+($GET(LEX))
SET LAST=+($GET(LS))
if MAX=0
QUIT -1
+3 SET PMT=" Select 1-"_MAX_", <RETURN> for more or '^' to exit: "
+4 SET CTR=$ORDER(ICDMENU(" "),-1)+1
SET ICDMENU(CTR)=PMT
+5 SET ICDMENU="ICDMENU"
DO HLP^DDSMSG(.ICDMENU)
+6 KILL ICDMENU
READ ANS:300
SET X=""
if '$TEST
SET ICDOTIM=1
SET X="^^"
+7 if ANS["^"
SET ICDOUPA=1
SET X="^"
if ANS["^^"
SET ICDOUPA=2
SET X="^^"
if X["^"
QUIT X
+8 DO CLRMSG^DDS
SET ANS=+ANS
if ANS'>0
QUIT ""
if ANS>MAX
QUIT ""
SET X=ANS
+9 QUIT X
MULQ ; Quit Multiple
+1 SET X=+($GET(SEL))
if X'>0
QUIT -1
+2 QUIT X
+3 ;
INP(X,VER,CDT) ; Get User Input
+1 if $GET(DIC(0))'["A"
QUIT ""
NEW DIROUT,DIRUT,DUOUT,DTOUT,DIR,DIRA,DIRB,SBR,SBT,FILE,ROOT
+2 SET VER=+($GET(VER))
SET CDT=+($GET(CDT))
+3 SET FILE=$GET(X)
if "^80^80.1^"'[("^"_FILE_"^")
QUIT ""
SET ROOT=$$ROOT^ICDEX(FILE)
+4 if $LENGTH($GET(ICDDICB))
SET DIRB=ICDDICB
if $LENGTH($GET(ICDDICA))
SET DIRA=ICDDICA
+5 if '$LENGTH($GET(DIRA))&(FILE=80)
SET DIRA=" Select ICD Diagnosis: "
+6 if '$LENGTH($GET(DIRA))&(FILE=80.1)
SET DIRA=" Select Procedure: "
+7 if '$LENGTH($GET(DIRA))
SET DIRA=" Select ICD Text or Code: "
+8 SET SBT=""
SET SBR=$$RET^ICDEXLK6($GET(FILE))
+9 IF SBR>0
IF VER>0
IF CDT?7N
IF $LENGTH(ROOT)
Begin DoDot:1
+10 NEW CODE,SYS,STA
+11 SET CODE=$GET(@(ROOT_+SBR_",0)"))
+12 SET SYS=$PIECE($GET(@(ROOT_+SBR_",1)")),"^",1)
+13 SET STA=$$STATCHK^ICDEX(CODE,CDT,SYS)
+14 if STA'>0
SET SBR=0
End DoDot:1
+15 if +SBR>0
SET SBT=$$LD^ICDEX(FILE,+SBR,$GET(ICDCDT))
+16 if $LENGTH($GET(DIRB))
SET DIR("B")=DIRB
+17 if $LENGTH($GET(DIRA))
SET DIR("A")=DIRA
if '$LENGTH($GET(DIRB))
WRITE !
+18 SET DIR("PRE")="S X=$$INPRE^ICDEXLK2($G(X))"
+19 SET (DIR("?"),DIR("??"))="^D INPH^ICDEXLK2($G(FILE))"
+20 SET DIR("?")="^D INPH^ICDEXLK2($G(FILE))"
+21 SET DIR("??")="^D INPH2^ICDEXLK2($G(FILE))"
+22 NEW Y
SET DIR(0)="FAO^0:245"
+23 KILL X,DIROUT,DIRUT,DUOUT,DTOUT
DO ^DIR
+24 if $GET(X)="@"&($GET(Y)="")
SET Y=$GET(X)
+25 if $DATA(DTOUT)
SET ICDOTIM=1
if $DATA(DUOUT)
SET ICDOUPA=1
if $DATA(DIROUT)
SET ICDOUPA=2
+26 if $GET(ICDOUPA)=1
QUIT "^"
if $GET(ICDOUPA)=2
QUIT "^^"
if $GET(ICDOTIM)>0
QUIT "^^"
+27 IF '$LENGTH(X)
SET (X,ICDX,INP,INP1,INP2)=""
SET Y=-1
QUIT X
+28 if X=""&('$LENGTH($GET(DIR("B"))))
SET X="^"
if X["^"&(X'["^^")
SET X="^"
if X["^^"
SET X="^^"
if X["^"
QUIT X
+29 IF $EXTRACT(X,1)=" "
IF $LENGTH(SBT)
IF +SBR>0
SET X=("`"_+SBR)
QUIT X
+30 if $GET(DIC(0))'["Q"&($EXTRACT(X,1)'=" ")&('$DATA(DDS))
WRITE !
+31 SET X=$$UP^XLFSTR($$TM(Y))
+32 QUIT X
INPH(X) ; Input Help
+1 NEW FILE,TYPE,TMP,TXT
SET FILE=$GET(X)
+2 SET TYPE=$SELECT(FILE=80:"Diagnosis ",FILE=80.1:"Procedure ",1:"")
+3 IF '$LENGTH($GET(TYPE))
Begin DoDot:1
+4 SET TMP="Enter a term (2-245 characters in length) or a code."
+5 IF +($GET(VER))>0
SET TMP=TMP_" Only active codes will be considered for selection."
+6 SET TXT(1)=TMP
DO PA^ICDEXLK6(.TXT,66)
+7 SET TMP=0
FOR
SET TMP=$ORDER(TXT(TMP))
if +TMP'>0
QUIT
WRITE !,?4,$GET(TXT(TMP))
End DoDot:1
QUIT
+8 SET TMP="Enter a "_TYPE_"(2-245 characters in length) or a "_TYPE_"code."
+9 IF +($GET(VER))>0
SET TMP=TMP_" Only active "_TYPE_"codes will be considered for selection."
+10 SET TXT(1)=TMP
DO PA^ICDEXLK6(.TXT,66)
+11 SET TMP=0
FOR
SET TMP=$ORDER(TXT(TMP))
if +TMP'>0
QUIT
WRITE !,?4,$GET(TXT(TMP))
+12 QUIT
INPH2(X) ; Input Help
+1 NEW FILE,TYPE,TMP,TXT
SET FILE=$GET(X)
+2 SET TYPE=$SELECT(FILE=80:"Diagnosis ",FILE=80.1:"Procedure ",1:"")
+3 IF '$LENGTH($GET(TYPE))
Begin DoDot:1
+4 SET TMP="Enter a term (2-245 characters in length), a code or code fragment,"
+5 SET TMP=TMP_" phrase, or an accent grave character (`) followed by the"
+6 SET TMP=TMP_" IEN to select a specific entry"
+7 IF $GET(ICDDIC0)'["F"
Begin DoDot:2
+8 SET TMP=TMP_", or press space bar and Enter/Return key to do a subsequent lookup of the same entry"
End DoDot:2
+9 SET TMP=TMP_"."
IF +($GET(VER))>0
Begin DoDot:2
+10 SET TMP=TMP_" Only active codes will be considered for selection."
End DoDot:2
+11 SET TXT(1)=TMP
DO PA^ICDEXLK6(.TXT,66)
+12 SET TMP=0
FOR
SET TMP=$ORDER(TXT(TMP))
if +TMP'>0
QUIT
WRITE !,?4,$GET(TXT(TMP))
End DoDot:1
QUIT
+13 SET TMP="Enter a "_TYPE_"name"
+14 SET TMP=TMP_" (2-245 characters in length), a "_TYPE_"code or code fragment,"
+15 SET TMP=TMP_" one or more keywords sufficient to select a "_TYPE
+16 SET TMP=TMP_" name, or an accent grave character (`) followed by the"
+17 SET TMP=TMP_" IEN to select a specific entry"
+18 IF $GET(ICDDIC0)'["F"
Begin DoDot:1
+19 SET TMP=TMP_", or press space bar and Enter/Return key to do a subsequent lookup of the same entry"
End DoDot:1
+20 SET TMP=TMP_"."
IF +($GET(VER))>0
Begin DoDot:1
+21 SET TMP=TMP_" Only active "_TYPE_"codes will be considered for selection."
End DoDot:1
+22 SET TXT(1)=TMP
DO PA^ICDEXLK6(.TXT,66)
+23 SET TMP=0
FOR
SET TMP=$ORDER(TXT(TMP))
if +TMP'>0
QUIT
WRITE !,?4,$GET(TXT(TMP))
+24 QUIT
INPRE(X) ; Input Pre-Processing
+1 if '$LENGTH($GET(X))
QUIT ""
NEW IN,IN1,IN2
SET IN=$GET(X)
+2 if IN["??"
QUIT "??"
if IN["?"
QUIT "?"
+3 SET IN1=$EXTRACT(IN,1)
SET IN2=$EXTRACT(IN,2,$LENGTH(IN))
+4 IF IN1["`"
IF IN2?1N.N
IF $LENGTH($GET(ROOT))
Begin DoDot:1
+5 if IN1="`"&(IN2?1N.N)&($DATA(@(ROOT_+IN2_",0)")))
QUIT
SET X="??"
End DoDot:1
QUIT X
+6 IF $LENGTH($GET(ROOT))
IF IN1=" "
IF '$LENGTH(IN2)
Begin DoDot:1
+7 NEW FI,CODE,SYS,STA,ND,SB,OUT
SET FI=$$FILE^ICDEX(ROOT)
+8 if +FI'>0
QUIT
SET SB=$$RET^ICDEXLK6($GET(FILE))
+9 IF SB>0
IF +($GET(VER))'>0
SET X="`"_+SB
QUIT
+10 IF SB>0
IF +($GET(VER))>0
IF +($GET(CDT))?7N
IF $LENGTH(ROOT)
Begin DoDot:2
+11 NEW CODE,SYS,STA
+12 SET CODE=$GET(@(ROOT_+SB_",0)"))
if '$LENGTH(CODE)
QUIT
+13 SET SYS=$PIECE($GET(@(ROOT_+SB_",1)")),"^",1)
if +SYS'>0
QUIT
+14 SET STA=$$STATCHK^ICDEX(CODE,CDT,SYS)
+15 if STA'>0
SET SB=0
if +SB>0
SET X="`"_+SB
if +SB'>0
SET X="??"
End DoDot:2
End DoDot:1
if $EXTRACT(X,1)="`"!($EXTRACT(X,1)="?")
QUIT X
+16 QUIT X
+17 ;
+18 ; Miscellaneous
OUT(X,Y,FMT,ARY) ; Output Array
+1 KILL ARY
NEW FILE,TERM,ROOT,IEN
SET ROOT=$GET(X)
SET IEN=+($GET(Y))
if '$LENGTH(ROOT)
QUIT
+2 if "^ICD9(^ICD0(^"'[("^"_$EXTRACT(ROOT,2,$LENGTH(ROOT))_"^")
QUIT
+3 SET FILE=$$FILE^ICDEX(ROOT)
if "^80^80.1^"'[("^"_FILE_"^")
QUIT
+4 SET FMT=+($GET(FMT))
if FMT'>0
SET FMT=1
if FMT>4
SET FMT=1
if '$DATA(@(ROOT_IEN_",0)"))
QUIT
+5 IF +($GET(FMT))=1!(+($GET(FMT))=3)
SET TERM=$$SD^ICDEX(FILE,IEN,CDT)
+6 IF +($GET(FMT))=2!(+($GET(FMT))=4)
SET TERM=$$LD^ICDEX(FILE,IEN,CDT)
+7 if '$LENGTH(TERM)
QUIT
if $PIECE(TERM,"^",1)=-1
QUIT
SET ARY(1)=TERM
if +($GET(FMT))=1!(+($GET(FMT))=3)
QUIT
+8 if +($GET(FMT))=2
DO PAR^ICDEX(.ARY,60)
if +($GET(FMT))=4
DO PAR^ICDEX(.ARY,70)
+9 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
X(SEL,SUB) ; Set X
+1 KILL X
NEW IEN
SET SEL=+($GET(SEL))
SET SUB=$GET(SUB)
if '$LENGTH(SUB)
QUIT
+2 SET IEN=$GET(^TMP(SUB,$JOB,"SEL",+SEL))
if +IEN'>0
QUIT
SET X=+IEN
+3 QUIT
Y(ROOT,IEN,CDT,FMT) ; Set Y
+1 ;
+2 ; Input
+3 ;
+4 ; ROOT Global Root (DIC) or File Number
+5 ; IEN Internal Entry Number
+6 ; CDT Versioning Date (default TODAY)
+7 ; FMT Format of Output
+8 ; 0 Standard Fileman Y IEN ^ CODE
+9 ; 1 Expanded Y as if DIC(0) contained a "Z"
+10 ; Output
+11 ;
+12 ; Y IEN ^ Code Fileman
+13 ;
+14 ; If DIC(0) contains "Z" or input parameter FMT > 0
+15 ;
+16 ; Y(0) 0 Node (Code) Fileman
+17 ; Y(0,0) .01 Field (Code) Fileman
+18 ; Y(0,1) $$ICDDX or $$ICDOP Non-Fileman
+19 ; Y(0,2) Long Description Non-Fileman
+20 ;
+21 NEW CODE,NODE0,FILE,SHORT,FDAT,LONG,ICD10
KILL Y
SET Y=-1
+22 if +($GET(ICDOFND))>0&(+($GET(ICDOSEL))'>0)
SET Y="-1^No selection made"
+23 SET IEN=+($GET(IEN))
SET ROOT=$GET(ROOT)
SET CDT=+($GET(CDT))
+24 if CDT'?7N
SET CDT=$$DT^XLFDT
SET ICD10=+($$IMP^ICDEX(30))
+25 SET ROOT=$$ROOT^ICDEX(ROOT)
if '$LENGTH(ROOT)
QUIT
+26 SET FILE=$$FILE^ICDEX(ROOT)
if +FILE'>0
QUIT
+27 SET NODE0=$GET(@(ROOT_+IEN_",0)"))
if '$LENGTH(NODE0)
QUIT
+28 SET CODE=$$CODEC^ICDEX(FILE,IEN)
if '$LENGTH(CODE)
QUIT
+29 SET SHORT=$$SD^ICDEX(FILE,IEN,CDT)
if '$LENGTH(SHORT)
QUIT
+30 SET FMT=+($GET(FMT))
IF $PIECE(SHORT,"^",1)=-1
Begin DoDot:1
+31 SET SHORT=$$SD^ICDEX(FILE,IEN,ICD10)
+32 if $PIECE(SHORT,"^",1)=-1
SET SHORT=""
if '$LENGTH(SHORT)
QUIT
+33 SET SHORT=SHORT_" (Pending - "_$$FMTE^XLFDT($$IMP^ICDEX(30))_")"
End DoDot:1
if '$LENGTH(SHORT)
QUIT
+34 SET Y=+IEN_"^"_CODE
+35 if $GET(DIC(0))["Z"!(+FMT>0)
SET Y(0)=NODE0
+36 SET CODE=$PIECE(NODE0,"^",1)
if '$LENGTH(CODE)
QUIT
+37 if FILE=80
SET FDAT=$$ICDDX^ICDEX(CODE,CDT,,"E")
+38 if FILE=80.1
SET FDAT=$$ICDOP^ICDEX(CODE,CDT,,"E")
+39 SET LONG=$$LD^ICDEX(ROOT,IEN,CDT)
+40 if $GET(DIC(0))["Z"!(+FMT>0)
SET Y(0,0)=CODE
+41 if $LENGTH(FDAT)&($LENGTH(LONG))&($GET(DIC(0))["Z")!(+FMT>0)
SET Y(0,1)=FDAT
SET Y(0,2)=LONG
+42 QUIT
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
