LEXQL ;ISL/KER - Query - Lookup Code ;05/23/2017
;;2.0;LEXICON UTILITY;**62,80,86,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^DIC(81.3, ICR 4492
; ^ICPT( ICR 4489
; ^ICPT("BA") ICR 4489
; ^TMP("LEXQL") SACC 2.3.2.5.1
;
; External References
; ^DIR ICR 10026
; $$ICDDX^ICDEX ICR 5747
; $$ICDOP^ICDEX ICR 5747
; $$ROOT^ICDEX ICR 5747
; $$CODEABA^ICDEX ICR 5747
; $$CPT^ICPTCOD ICR 1995
; $$MOD^ICPTMOD ICR 1996
; $$DT^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
N DIR,DIRB,DIROUT,DIRUT,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,DTOUT,DUOUT,LEX,LEXC,LEXCOM,LEXCT,LEXCTY,LEXD,LEXDS,LEXDT,LEXE,LEXENT,LEXFD
N LEXFI,LEXI,LEXIEN,LEXIN,LEXIT,LEXIX,LEXKEY,LEXL,LEXLAST,LEXLEN,LEXMAX,LEXN,LEXNM,LEXO,LEXOC,LEXRTN,LEXS,LEXSEL,LEXSO,LEXSS,LEXSTR,LEXT
N LEXT1,LEXT2,LEXT3,LEXTAG,LEXTD,LEXTMP,LEXTN,LEXTOT,LEXTQ,LEXTS,LEXTTT,LEXTY,LEXUSR,LEXV,LEXVAL,LEXX,Y
K ^TMP("LEXQL",$J) S X=$$SO K ^TMP("LEXQL",$J)
Q
SO(X) ; Select a Code
;
; Input None
;
; Output X - "^" delimited string
; 1 - IEN
; 2 - Global Root
; 3 - File #
; 4 - Coding System (if available)
; 5 - Code
; 6 - Short Name
;
; or "^" if no code is found/selected
;
K ^TMP("LEXQL",$J) Q:+($G(LEXEXIT))>0 "^^" N DIR,DIROUT,DIRUT,DTOUT,DUOUT,DIRB,LEXTD,Y,LEX,LEXIT
S LEXTD=$G(LEXVDT) S:LEXTD'?7N LEXTD=$$DT^XLFDT S LEXIT=0
S DIR(0)="FAO^1:30",DIR("A")=" Select a Code: "
S DIRB=$$RET^LEXQD("LEXQL","SO",+($G(DUZ)),"Select a Code") S:$L(DIRB) DIR("B")=DIRB
S DIR("PRE")="S:'$L(X)&($L($G(DIR(""B"")))) X=$G(DIR(""B"")) S X=$TR($$UP^XLFSTR(X),""#"""""",""""),X=$$VSO^LEXQL2(X) S X=$$SEL^LEXQL(X)"
S (DIR("?"),DIR("??"))="^D SOH^LEXQL" D ^DIR S X=$TR(X,"#""",""),Y=$TR(Y,"#""","")
I X="^^"!($D(DTOUT))!(+($G(LEXEXIT))) K ^TMP("LEXQL",$J) Q "^^"
I '$D(^TMP("LEXQL",$J,"X")) S:$L(Y)&(Y=$P(DIRB,U,4)) ^TMP("LEXQL",$J,"X")=DIRB
S:$D(DIROUT)!($D(DIRUT))!($D(DTOUT))!($D(DUOUT)) X="^" Q:$E(X,1)="^" X
S X="" S:$L($G(^TMP("LEXQL",$J,"X"))) X=$G(^TMP("LEXQL",$J,"X"))
S LEX=$P(X,U,5) D:$L(LEX) SAV^LEXQD("LEXQL","SO",+($G(DUZ)),"Select a Code",LEX) K ^TMP("LEXQL",$J)
Q X
SOH ; Select a Code Help
W !," Enter a code from either:",!
W !," ICD-9 Diagnosis file #80 4-7 Characters"
W !," ICD-9 Procedure file #80.1 3-5 Characters"
W !," ICD-10 Diagnosis file #80 4-8 Characters"
W !," ICD-10 Procedure file #80.1 7 Characters"
W !," CPT/HCPCS Procedure file #81 5 Characters"
W !," CPT Modifier file #81.3 2 Characters",!
W !," Or enter keywords, 2-30 characters, to search for in"
W !," the above files.",!
Q
SOGD(X) ; Select a Code Global/Data
N LEX,LEXTD S LEX=$G(X) Q:'$L(LEX) "^" S LEXTD=$$DT^XLFDT
; 80 ICD-9
Q:$$CODEABA^ICDEX(X,80,1)>0 ($TR($$ROOT^ICDEX(80),"^","")_"^"_$$ICDDX^ICDEX(X,LEXTD,1,"E"))
Q:$$CODEABA^ICDEX($$UP^XLFSTR(X),80,1)>0 ($TR($$ROOT^ICDEX(80),"^","")_"^"_$$ICDDX^ICDEX($$UP^XLFSTR(X),LEXTD,1,"E"))
; 80 ICD-10
Q:$$CODEABA^ICDEX(X,80,30)>0 ($TR($$ROOT^ICDEX(80),"^","")_"^"_$$ICDDX^ICDEX(X,LEXTD,30,"E"))
Q:$$CODEABA^ICDEX($$UP^XLFSTR(X),80,30)>0 ($TR($$ROOT^ICDEX(80),"^","")_"^"_$$ICDDX^ICDEX($$UP^XLFSTR(X),LEXTD,30,"E"))
; 80.1 ICD-9
Q:$$CODEABA^ICDEX(X,80.1,2)>0 ($TR($$ROOT^ICDEX(80.1),"^","")_"^"_$$ICDOP^ICDEX(X,LEXTD,2,"E"))
Q:$$CODEABA^ICDEX($$UP^XLFSTR(X),80.1,2)>0 ($TR($$ROOT^ICDEX(80.1),"^","")_"^"_$$ICDOP^ICDEX($$UP^XLFSTR(X),LEXTD,2,"E"))
; 80.1 ICD-10
Q:$$CODEABA^ICDEX(X,80.1,31)>0 ($TR($$ROOT^ICDEX(80.1),"^","")_"^"_$$ICDOP^ICDEX(X,LEXTD,31,"E"))
Q:$$CODEABA^ICDEX($$UP^XLFSTR(X),80.1,31)>0 ($TR($$ROOT^ICDEX(80.1),"^","")_"^"_$$ICDOP^ICDEX($$UP^XLFSTR(X),LEXTD,31,"E"))
; 81 CPT
Q:$D(^ICPT("BA",(X_" "))) ("ICPT("_"^"_$$CPT^ICPTCOD(X,$G(LEXTD)))
Q:$D(^ICPT("BA",($$UP^XLFSTR(X)_" "))) ("ICPT("_"^"_$$CPT^ICPTCOD($$UP^XLFSTR(X),$G(LEXTD)))
; 81.3 CPT Modifier
Q:$D(^DIC(81.3,"BA",(X_" "))) ("DIC(81.3,"_"^"_$$MOD^ICPTMOD(X,"E",$G(LEXTD)))
Q:$D(^DIC(81.3,"BA",($$UP^XLFSTR(X)_" "))) ("DIC(81.3,"_"^"_$$MOD^ICPTMOD($$UP^XLFSTR(X),"E",$G(LEXTD)))
Q ""
;
SEL(X) ; Select from List
Q:'$L($G(X)) "" Q:$G(X)["^" $G(X) Q:$G(X)["?" "??" K ^TMP("LEXQL",$J) D ADD^LEXQL2($G(X)) Q:'$D(^TMP("LEXQL",$J)) "??" D ASK
K ^TMP("LEXQL",$J) Q:+($G(LEXEXIT))>0 "^^" Q:+X'>0 "??" I +($G(X))>0 S ^TMP("LEXQL",$J,"X")=X,X=+($P($G(X),"^",4))
Q X
ASK ; Ask for Selection
K X N LEXTOT S LEXTOT=+($G(^TMP("LEXQL",$J,0))) S:+LEXTOT'>0 X="^" Q:+LEXTOT'>0 K X
S:+LEXTOT=1 X=$$ONE Q:+LEXTOT=1 S:+LEXTOT>1 X=$$MUL
Q
ONE(X) ; One Entry Found
Q:+($G(LEXEXIT))>0 "^^" N LEXT1,LEXT2,LEXT3,LEX,LEXC,LEXCT,LEXIEN,LEXX,DIR,Y,DTOUT,DUOUT,DIROUT,DIRUT
S LEXT1=$G(^TMP("LEXQL",$J,1)),LEXCT=$$CT(LEXT1),LEXIEN=+LEXT1,LEXT1=$P(LEXT1,U,2),LEXT2=$G(^TMP("LEXQL",$J,1,2))
S:$L(LEXT1)&($L(LEXT2)) LEXT1=LEXT1_" "_LEXT2 S (LEXT3,LEX(1))=LEXT1
S LEXX=LEXIEN_U_$$FI(LEXT3)_U_LEXCT D PR^LEXU(.LEX,64)
S DIR("A",1)=" One code found",DIR("A",2)=" ",DIR("A",3)=" "_$G(LEX(1)),LEXC=3
S:$L($G(LEX(2))) LEXC=LEXC+1,DIR("A",LEXC)=" "_$G(LEX(2))
S LEXC=LEXC+1,DIR("A",LEXC)=" ",LEXC=LEXC+1,DIR("A")=" OK? (Yes/No) ",DIR("B")="Yes",DIR(0)="YAO" W !
D ^DIR S:X["^^"!($D(DTOUT)) LEXEXIT=1,X="^^" I X["^^"!(+($G(LEXEXIT))>0)!($D(DIROUT)) K ^TMP("LEXQL",$J) S LEXEXIT=1 Q "^^"
S X=$S(+Y>0:$$X(1),1:-1)
Q X
MUL(X) ; Multiple Entries Found
Q:+($G(LEXEXIT))>0 "^^" N LEXIEN,LEXENT,LEXT1,LEXTTT,LEXMAX,LEXI,LEXSS,LEXIT,LEXSTR,Y S (LEXMAX,LEXI,LEXSS,LEXIT)=0 S U="^"
S LEXTTT=$G(^TMP("LEXQL",$J,0)),LEXSS=0 G:+LEXTTT=0 MULQ W ! W:+LEXTTT>1 !," ",LEXTTT," matches found"
F LEXI=1:1:LEXTTT Q:((LEXSS>0)&(LEXSS<LEXI+1)) Q:LEXIT D Q:LEXIT
. S LEXENT=$G(^TMP("LEXQL",$J,LEXI)) S LEXSTR=$P(LEXENT,U,1) Q:'$L(LEXSTR) S LEXMAX=LEXI W:LEXI#5=1 ! D MULW
. W:LEXI#5=0 ! S:LEXI#5=0 LEXSS=$$MULS(LEXMAX,LEXI) S:LEXSS["^" LEXIT=1
I LEXI#5'=0,+LEXSS=0 W ! S LEXSS=$$MULS(LEXMAX,LEXI) S:LEXSS["^" LEXIT=1
G MULQ
Q X
MULW ; Write Multiple
N LEXT1,LEXT2,LEXT3,LEXIEN,LEX S LEXT1=$P(LEXENT,U,2),LEXT2=$G(^TMP("LEXQL",$J,LEXI,2)),LEXCT=$$CT(LEXT1),LEXIEN=+LEXENT
K LEX S:$L(LEXT1)&($L(LEXT2)) LEXT1=LEXT1_" "_LEXT2
S (LEXT3,LEX(1))=LEXT1 D PR^LEXU(.LEX,63)
W !,$J(LEXI,5),". ",$G(LEX(1)) F LEXT1=2:1:5 S LEXT2=$G(LEX(LEXT1)) W:$L(LEXT2) !," ",LEXT2
Q
MULS(LEXS,LEXI) ; Select Multiple
Q:+($G(LEXEXIT))>0 "^^" N X,Y,LEXMAX,LEXLAST,DIR,DIRB,DTOUT,DUOUT,DIRUT,DIROUT,LEXTQ S LEXMAX=+($G(LEXS)),LEXLAST=+($G(LEXI)) Q:LEXMAX=0 -1
S:+($O(^TMP("LEXQL",$J,+LEXLAST)))>0 DIR("A")=" Press <RETURN> for more, '^' to exit, or Select 1-"_LEXMAX_": "
S:+($O(^TMP("LEXQL",$J,+LEXLAST)))'>0 DIR("A")=" Select 1-"_LEXMAX_": "
S LEXTQ=" Answer must be from 1 to "_LEXMAX_", or <Return> to continue"
S DIR("PRE")="S:X[""?"" X=""??""",(DIR("?"),DIR("??"))="^D MULSH^LEXQL"
S DIR(0)="NAO^1:"_LEXMAX_":0" D ^DIR S:X["^^"!($D(DTOUT)) LEXEXIT=1,X="^^" I X["^^"!(+($G(LEXEXIT))>0) K ^TMP("LEXQL",$J) Q "^^"
S LEXS=+Y S:$D(DTOUT)!(X[U) LEXS=U K DIR
Q LEXS
MULSH ; Select Multiple Help
I $L($G(LEXTQ)) W !,$G(LEXTQ) Q
Q
MULQ ; Quit Multiple
Q:+LEXSS'>0 -1 S X=-1 S:+($G(LEXIT))'>0 X=$$X(+LEXSS)
Q X
;
; Miscellaneous
X(X) ; Set X
N LEXCT,LEXFI,LEXIEN,LEXSEL,LEXT1,LEXT2,LEXT3 S LEXSEL=+($G(X))
S LEXT1=$G(^TMP("LEXQL",$J,+($G(LEXSEL)))),LEXT2=$G(^TMP("LEXQL",$J,+($G(LEXSEL)),2))
S LEXT3=LEXT1 S:$L(LEXT2) LEXT3=LEXT3_" "_LEXT2 S LEXCT=$$CT(LEXT3),LEXFI=$$FI(LEXT3)
S LEXIEN=+LEXT1 S X=$$UP^XLFSTR((LEXIEN_U_LEXFI_U_LEXCT))
Q X
CT(X) ; Code and Text
S X=$G(X) N LEXIEN,LEXC,LEXN,LEXT S LEXIEN=+X Q:+LEXIEN'>0 "" S LEXT=$P(X,U,2) Q:'$L(LEXT) ""
I LEXT["ICD-9 Dx"!(LEXT["ICD-9 Diag") D
. S LEXN=$$ICDDX^ICDEX(LEXIEN,$G(LEXVDT),1,"I"),LEXC=$P(LEXN,"^",2),LEXN=$P(LEXN,"^",4)
I LEXT["ICD-9 Op"!(LEXT["ICD-9 Proc") D
. S LEXN=$$ICDOP^ICDEX(LEXIEN,$G(LEXVDT),2,"I"),LEXC=$P(LEXN,"^",2),LEXN=$P(LEXN,"^",5)
I LEXT["ICD-10 Dx"!(LEXT["ICD-10 Diag") D
. S LEXN=$$ICDDX^ICDEX(LEXIEN,$G(LEXVDT),30,"I"),LEXC=$P(LEXN,"^",2),LEXN=$P(LEXN,"^",4)
I LEXT["ICD-10 Op"!(LEXT["ICD-10 Proc") D
. S LEXN=$$ICDOP^ICDEX(LEXIEN,$G(LEXVDT),31,"I"),LEXC=$P(LEXN,"^",2),LEXN=$P(LEXN,"^",5)
I LEXT["CPT-4"!(LEXT["CPT P")!(LEXT["HCPCS") D
. S LEXC=$P($G(^ICPT(+LEXIEN,0)),U,1),LEXN=$P($$CPT^ICPTCOD(LEXC,$G(LEXVDT)),U,3)
I LEXT["CPT Mod" D
. S LEXC=$P($G(^DIC(81.3,+LEXIEN,0)),U,1),LEXN=$P($$MOD^ICPTMOD(LEXIEN,"I",$G(LEXVDT)),U,3)
S X="" S:$L($G(LEXC))&($L($G(LEXN))) X=LEXC_U_LEXN
Q X
FI(X) ; File
S X=$G(X)
Q:X["ICD-9 Dx"!(X["ICD-9 Diag") ($TR($$ROOT^ICDEX(80),"^","")_"^80^1")
Q:X["ICD-9 Op"!(X["ICD-9 Proc") ($TR($$ROOT^ICDEX(80.1),"^","")_"^80.1^2")
Q:X["ICD-10 Dx"!(X["ICD-10 Diag") ($TR($$ROOT^ICDEX(80),"^","")_"^80^30")
Q:X["ICD-10 Op"!(X["ICD-10 Proc") ($TR($$ROOT^ICDEX(80.1),"^","")_"^80.1^31")
Q:X["CPT-4"!(X["CPT Proc") "ICPT(^81^3" Q:X["HCPCS" "ICPT(^81^4"
Q:X["CPT Mod" "DIC(81.3,^81.3^"
Q ""
SHO ; Show TMP
N LEXNN,LEXNC S LEXNN="^TMP(""LEXQL"","_$J_")",LEXNC="^TMP(""LEXQL"","_$J_","
W ! F S LEXNN=$Q(@LEXNN) Q:'$L(LEXNN)!(LEXNN'[LEXNC) W !,LEXNN,"=",@LEXNN
W !
Q
; Miscellaneous
CL ; Clear
K LEXVDT,LEXEXIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQL 9612 printed Sep 23, 2025@19:44:48 Page 2
LEXQL ;ISL/KER - Query - Lookup Code ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**62,80,86,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^DIC(81.3, ICR 4492
+5 ; ^ICPT( ICR 4489
+6 ; ^ICPT("BA") ICR 4489
+7 ; ^TMP("LEXQL") SACC 2.3.2.5.1
+8 ;
+9 ; External References
+10 ; ^DIR ICR 10026
+11 ; $$ICDDX^ICDEX ICR 5747
+12 ; $$ICDOP^ICDEX ICR 5747
+13 ; $$ROOT^ICDEX ICR 5747
+14 ; $$CODEABA^ICDEX ICR 5747
+15 ; $$CPT^ICPTCOD ICR 1995
+16 ; $$MOD^ICPTMOD ICR 1996
+17 ; $$DT^XLFDT ICR 10103
+18 ; $$UP^XLFSTR ICR 10104
+19 ;
+20 NEW DIR,DIRB,DIROUT,DIRUT,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,DTOUT,DUOUT,LEX,LEXC,LEXCOM,LEXCT,LEXCTY,LEXD,LEXDS,LEXDT,LEXE,LEXENT,LEXFD
+21 NEW LEXFI,LEXI,LEXIEN,LEXIN,LEXIT,LEXIX,LEXKEY,LEXL,LEXLAST,LEXLEN,LEXMAX,LEXN,LEXNM,LEXO,LEXOC,LEXRTN,LEXS,LEXSEL,LEXSO,LEXSS,LEXSTR,LEXT
+22 NEW LEXT1,LEXT2,LEXT3,LEXTAG,LEXTD,LEXTMP,LEXTN,LEXTOT,LEXTQ,LEXTS,LEXTTT,LEXTY,LEXUSR,LEXV,LEXVAL,LEXX,Y
+23 KILL ^TMP("LEXQL",$JOB)
SET X=$$SO
KILL ^TMP("LEXQL",$JOB)
+24 QUIT
SO(X) ; Select a Code
+1 ;
+2 ; Input None
+3 ;
+4 ; Output X - "^" delimited string
+5 ; 1 - IEN
+6 ; 2 - Global Root
+7 ; 3 - File #
+8 ; 4 - Coding System (if available)
+9 ; 5 - Code
+10 ; 6 - Short Name
+11 ;
+12 ; or "^" if no code is found/selected
+13 ;
+14 KILL ^TMP("LEXQL",$JOB)
if +($GET(LEXEXIT))>0
QUIT "^^"
NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,DIRB,LEXTD,Y,LEX,LEXIT
+15 SET LEXTD=$GET(LEXVDT)
if LEXTD'?7N
SET LEXTD=$$DT^XLFDT
SET LEXIT=0
+16 SET DIR(0)="FAO^1:30"
SET DIR("A")=" Select a Code: "
+17 SET DIRB=$$RET^LEXQD("LEXQL","SO",+($GET(DUZ)),"Select a Code")
if $LENGTH(DIRB)
SET DIR("B")=DIRB
+18 SET DIR("PRE")="S:'$L(X)&($L($G(DIR(""B"")))) X=$G(DIR(""B"")) S X=$TR($$UP^XLFSTR(X),""#"""""",""""),X=$$VSO^LEXQL2(X) S X=$$SEL^LEXQL(X)"
+19 SET (DIR("?"),DIR("??"))="^D SOH^LEXQL"
DO ^DIR
SET X=$TRANSLATE(X,"#""","")
SET Y=$TRANSLATE(Y,"#""","")
+20 IF X="^^"!($DATA(DTOUT))!(+($GET(LEXEXIT)))
KILL ^TMP("LEXQL",$JOB)
QUIT "^^"
+21 IF '$DATA(^TMP("LEXQL",$JOB,"X"))
if $LENGTH(Y)&(Y=$PIECE(DIRB,U,4))
SET ^TMP("LEXQL",$JOB,"X")=DIRB
+22 if $DATA(DIROUT)!($DATA(DIRUT))!($DATA(DTOUT))!($DATA(DUOUT))
SET X="^"
if $EXTRACT(X,1)="^"
QUIT X
+23 SET X=""
if $LENGTH($GET(^TMP("LEXQL",$JOB,"X")))
SET X=$GET(^TMP("LEXQL",$JOB,"X"))
+24 SET LEX=$PIECE(X,U,5)
if $LENGTH(LEX)
DO SAV^LEXQD("LEXQL","SO",+($GET(DUZ)),"Select a Code",LEX)
KILL ^TMP("LEXQL",$JOB)
+25 QUIT X
SOH ; Select a Code Help
+1 WRITE !," Enter a code from either:",!
+2 WRITE !," ICD-9 Diagnosis file #80 4-7 Characters"
+3 WRITE !," ICD-9 Procedure file #80.1 3-5 Characters"
+4 WRITE !," ICD-10 Diagnosis file #80 4-8 Characters"
+5 WRITE !," ICD-10 Procedure file #80.1 7 Characters"
+6 WRITE !," CPT/HCPCS Procedure file #81 5 Characters"
+7 WRITE !," CPT Modifier file #81.3 2 Characters",!
+8 WRITE !," Or enter keywords, 2-30 characters, to search for in"
+9 WRITE !," the above files.",!
+10 QUIT
SOGD(X) ; Select a Code Global/Data
+1 NEW LEX,LEXTD
SET LEX=$GET(X)
if '$LENGTH(LEX)
QUIT "^"
SET LEXTD=$$DT^XLFDT
+2 ; 80 ICD-9
+3 if $$CODEABA^ICDEX(X,80,1)>0
QUIT ($TRANSLATE($$ROOT^ICDEX(80),"^","")_"^"_$$ICDDX^ICDEX(X,LEXTD,1,"E"))
+4 if $$CODEABA^ICDEX($$UP^XLFSTR(X),80,1)>0
QUIT ($TRANSLATE($$ROOT^ICDEX(80),"^","")_"^"_$$ICDDX^ICDEX($$UP^XLFSTR(X),LEXTD,1,"E"))
+5 ; 80 ICD-10
+6 if $$CODEABA^ICDEX(X,80,30)>0
QUIT ($TRANSLATE($$ROOT^ICDEX(80),"^","")_"^"_$$ICDDX^ICDEX(X,LEXTD,30,"E"))
+7 if $$CODEABA^ICDEX($$UP^XLFSTR(X),80,30)>0
QUIT ($TRANSLATE($$ROOT^ICDEX(80),"^","")_"^"_$$ICDDX^ICDEX($$UP^XLFSTR(X),LEXTD,30,"E"))
+8 ; 80.1 ICD-9
+9 if $$CODEABA^ICDEX(X,80.1,2)>0
QUIT ($TRANSLATE($$ROOT^ICDEX(80.1),"^","")_"^"_$$ICDOP^ICDEX(X,LEXTD,2,"E"))
+10 if $$CODEABA^ICDEX($$UP^XLFSTR(X),80.1,2)>0
QUIT ($TRANSLATE($$ROOT^ICDEX(80.1),"^","")_"^"_$$ICDOP^ICDEX($$UP^XLFSTR(X),LEXTD,2,"E"))
+11 ; 80.1 ICD-10
+12 if $$CODEABA^ICDEX(X,80.1,31)>0
QUIT ($TRANSLATE($$ROOT^ICDEX(80.1),"^","")_"^"_$$ICDOP^ICDEX(X,LEXTD,31,"E"))
+13 if $$CODEABA^ICDEX($$UP^XLFSTR(X),80.1,31)>0
QUIT ($TRANSLATE($$ROOT^ICDEX(80.1),"^","")_"^"_$$ICDOP^ICDEX($$UP^XLFSTR(X),LEXTD,31,"E"))
+14 ; 81 CPT
+15 if $DATA(^ICPT("BA",(X_" ")))
QUIT ("ICPT("_"^"_$$CPT^ICPTCOD(X,$GET(LEXTD)))
+16 if $DATA(^ICPT("BA",($$UP^XLFSTR(X)_" ")))
QUIT ("ICPT("_"^"_$$CPT^ICPTCOD($$UP^XLFSTR(X),$GET(LEXTD)))
+17 ; 81.3 CPT Modifier
+18 if $DATA(^DIC(81.3,"BA",(X_" ")))
QUIT ("DIC(81.3,"_"^"_$$MOD^ICPTMOD(X,"E",$GET(LEXTD)))
+19 if $DATA(^DIC(81.3,"BA",($$UP^XLFSTR(X)_" ")))
QUIT ("DIC(81.3,"_"^"_$$MOD^ICPTMOD($$UP^XLFSTR(X),"E",$GET(LEXTD)))
+20 QUIT ""
+21 ;
SEL(X) ; Select from List
+1 if '$LENGTH($GET(X))
QUIT ""
if $GET(X)["^"
QUIT $GET(X)
if $GET(X)["?"
QUIT "??"
KILL ^TMP("LEXQL",$JOB)
DO ADD^LEXQL2($GET(X))
if '$DATA(^TMP("LEXQL",$JOB))
QUIT "??"
DO ASK
+2 KILL ^TMP("LEXQL",$JOB)
if +($GET(LEXEXIT))>0
QUIT "^^"
if +X'>0
QUIT "??"
IF +($GET(X))>0
SET ^TMP("LEXQL",$JOB,"X")=X
SET X=+($PIECE($GET(X),"^",4))
+3 QUIT X
ASK ; Ask for Selection
+1 KILL X
NEW LEXTOT
SET LEXTOT=+($GET(^TMP("LEXQL",$JOB,0)))
if +LEXTOT'>0
SET X="^"
if +LEXTOT'>0
QUIT
KILL X
+2 if +LEXTOT=1
SET X=$$ONE
if +LEXTOT=1
QUIT
if +LEXTOT>1
SET X=$$MUL
+3 QUIT
ONE(X) ; One Entry Found
+1 if +($GET(LEXEXIT))>0
QUIT "^^"
NEW LEXT1,LEXT2,LEXT3,LEX,LEXC,LEXCT,LEXIEN,LEXX,DIR,Y,DTOUT,DUOUT,DIROUT,DIRUT
+2 SET LEXT1=$GET(^TMP("LEXQL",$JOB,1))
SET LEXCT=$$CT(LEXT1)
SET LEXIEN=+LEXT1
SET LEXT1=$PIECE(LEXT1,U,2)
SET LEXT2=$GET(^TMP("LEXQL",$JOB,1,2))
+3 if $LENGTH(LEXT1)&($LENGTH(LEXT2))
SET LEXT1=LEXT1_" "_LEXT2
SET (LEXT3,LEX(1))=LEXT1
+4 SET LEXX=LEXIEN_U_$$FI(LEXT3)_U_LEXCT
DO PR^LEXU(.LEX,64)
+5 SET DIR("A",1)=" One code found"
SET DIR("A",2)=" "
SET DIR("A",3)=" "_$GET(LEX(1))
SET LEXC=3
+6 if $LENGTH($GET(LEX(2)))
SET LEXC=LEXC+1
SET DIR("A",LEXC)=" "_$GET(LEX(2))
+7 SET LEXC=LEXC+1
SET DIR("A",LEXC)=" "
SET LEXC=LEXC+1
SET DIR("A")=" OK? (Yes/No) "
SET DIR("B")="Yes"
SET DIR(0)="YAO"
WRITE !
+8 DO ^DIR
if X["^^"!($DATA(DTOUT))
SET LEXEXIT=1
SET X="^^"
IF X["^^"!(+($GET(LEXEXIT))>0)!($DATA(DIROUT))
KILL ^TMP("LEXQL",$JOB)
SET LEXEXIT=1
QUIT "^^"
+9 SET X=$SELECT(+Y>0:$$X(1),1:-1)
+10 QUIT X
MUL(X) ; Multiple Entries Found
+1 if +($GET(LEXEXIT))>0
QUIT "^^"
NEW LEXIEN,LEXENT,LEXT1,LEXTTT,LEXMAX,LEXI,LEXSS,LEXIT,LEXSTR,Y
SET (LEXMAX,LEXI,LEXSS,LEXIT)=0
SET U="^"
+2 SET LEXTTT=$GET(^TMP("LEXQL",$JOB,0))
SET LEXSS=0
if +LEXTTT=0
GOTO MULQ
WRITE !
if +LEXTTT>1
WRITE !," ",LEXTTT," matches found"
+3 FOR LEXI=1:1:LEXTTT
if ((LEXSS>0)&(LEXSS<LEXI+1))
QUIT
if LEXIT
QUIT
Begin DoDot:1
+4 SET LEXENT=$GET(^TMP("LEXQL",$JOB,LEXI))
SET LEXSTR=$PIECE(LEXENT,U,1)
if '$LENGTH(LEXSTR)
QUIT
SET LEXMAX=LEXI
if LEXI#5=1
WRITE !
DO MULW
+5 if LEXI#5=0
WRITE !
if LEXI#5=0
SET LEXSS=$$MULS(LEXMAX,LEXI)
if LEXSS["^"
SET LEXIT=1
End DoDot:1
if LEXIT
QUIT
+6 IF LEXI#5'=0
IF +LEXSS=0
WRITE !
SET LEXSS=$$MULS(LEXMAX,LEXI)
if LEXSS["^"
SET LEXIT=1
+7 GOTO MULQ
+8 QUIT X
MULW ; Write Multiple
+1 NEW LEXT1,LEXT2,LEXT3,LEXIEN,LEX
SET LEXT1=$PIECE(LEXENT,U,2)
SET LEXT2=$GET(^TMP("LEXQL",$JOB,LEXI,2))
SET LEXCT=$$CT(LEXT1)
SET LEXIEN=+LEXENT
+2 KILL LEX
if $LENGTH(LEXT1)&($LENGTH(LEXT2))
SET LEXT1=LEXT1_" "_LEXT2
+3 SET (LEXT3,LEX(1))=LEXT1
DO PR^LEXU(.LEX,63)
+4 WRITE !,$JUSTIFY(LEXI,5),". ",$GET(LEX(1))
FOR LEXT1=2:1:5
SET LEXT2=$GET(LEX(LEXT1))
if $LENGTH(LEXT2)
WRITE !," ",LEXT2
+5 QUIT
MULS(LEXS,LEXI) ; Select Multiple
+1 if +($GET(LEXEXIT))>0
QUIT "^^"
NEW X,Y,LEXMAX,LEXLAST,DIR,DIRB,DTOUT,DUOUT,DIRUT,DIROUT,LEXTQ
SET LEXMAX=+($GET(LEXS))
SET LEXLAST=+($GET(LEXI))
if LEXMAX=0
QUIT -1
+2 if +($ORDER(^TMP("LEXQL",$JOB,+LEXLAST)))>0
SET DIR("A")=" Press <RETURN> for more, '^' to exit, or Select 1-"_LEXMAX_": "
+3 if +($ORDER(^TMP("LEXQL",$JOB,+LEXLAST)))'>0
SET DIR("A")=" Select 1-"_LEXMAX_": "
+4 SET LEXTQ=" Answer must be from 1 to "_LEXMAX_", or <Return> to continue"
+5 SET DIR("PRE")="S:X[""?"" X=""??"""
SET (DIR("?"),DIR("??"))="^D MULSH^LEXQL"
+6 SET DIR(0)="NAO^1:"_LEXMAX_":0"
DO ^DIR
if X["^^"!($DATA(DTOUT))
SET LEXEXIT=1
SET X="^^"
IF X["^^"!(+($GET(LEXEXIT))>0)
KILL ^TMP("LEXQL",$JOB)
QUIT "^^"
+7 SET LEXS=+Y
if $DATA(DTOUT)!(X[U)
SET LEXS=U
KILL DIR
+8 QUIT LEXS
MULSH ; Select Multiple Help
+1 IF $LENGTH($GET(LEXTQ))
WRITE !,$GET(LEXTQ)
QUIT
+2 QUIT
MULQ ; Quit Multiple
+1 if +LEXSS'>0
QUIT -1
SET X=-1
if +($GET(LEXIT))'>0
SET X=$$X(+LEXSS)
+2 QUIT X
+3 ;
+4 ; Miscellaneous
X(X) ; Set X
+1 NEW LEXCT,LEXFI,LEXIEN,LEXSEL,LEXT1,LEXT2,LEXT3
SET LEXSEL=+($GET(X))
+2 SET LEXT1=$GET(^TMP("LEXQL",$JOB,+($GET(LEXSEL))))
SET LEXT2=$GET(^TMP("LEXQL",$JOB,+($GET(LEXSEL)),2))
+3 SET LEXT3=LEXT1
if $LENGTH(LEXT2)
SET LEXT3=LEXT3_" "_LEXT2
SET LEXCT=$$CT(LEXT3)
SET LEXFI=$$FI(LEXT3)
+4 SET LEXIEN=+LEXT1
SET X=$$UP^XLFSTR((LEXIEN_U_LEXFI_U_LEXCT))
+5 QUIT X
CT(X) ; Code and Text
+1 SET X=$GET(X)
NEW LEXIEN,LEXC,LEXN,LEXT
SET LEXIEN=+X
if +LEXIEN'>0
QUIT ""
SET LEXT=$PIECE(X,U,2)
if '$LENGTH(LEXT)
QUIT ""
+2 IF LEXT["ICD-9 Dx"!(LEXT["ICD-9 Diag")
Begin DoDot:1
+3 SET LEXN=$$ICDDX^ICDEX(LEXIEN,$GET(LEXVDT),1,"I")
SET LEXC=$PIECE(LEXN,"^",2)
SET LEXN=$PIECE(LEXN,"^",4)
End DoDot:1
+4 IF LEXT["ICD-9 Op"!(LEXT["ICD-9 Proc")
Begin DoDot:1
+5 SET LEXN=$$ICDOP^ICDEX(LEXIEN,$GET(LEXVDT),2,"I")
SET LEXC=$PIECE(LEXN,"^",2)
SET LEXN=$PIECE(LEXN,"^",5)
End DoDot:1
+6 IF LEXT["ICD-10 Dx"!(LEXT["ICD-10 Diag")
Begin DoDot:1
+7 SET LEXN=$$ICDDX^ICDEX(LEXIEN,$GET(LEXVDT),30,"I")
SET LEXC=$PIECE(LEXN,"^",2)
SET LEXN=$PIECE(LEXN,"^",4)
End DoDot:1
+8 IF LEXT["ICD-10 Op"!(LEXT["ICD-10 Proc")
Begin DoDot:1
+9 SET LEXN=$$ICDOP^ICDEX(LEXIEN,$GET(LEXVDT),31,"I")
SET LEXC=$PIECE(LEXN,"^",2)
SET LEXN=$PIECE(LEXN,"^",5)
End DoDot:1
+10 IF LEXT["CPT-4"!(LEXT["CPT P")!(LEXT["HCPCS")
Begin DoDot:1
+11 SET LEXC=$PIECE($GET(^ICPT(+LEXIEN,0)),U,1)
SET LEXN=$PIECE($$CPT^ICPTCOD(LEXC,$GET(LEXVDT)),U,3)
End DoDot:1
+12 IF LEXT["CPT Mod"
Begin DoDot:1
+13 SET LEXC=$PIECE($GET(^DIC(81.3,+LEXIEN,0)),U,1)
SET LEXN=$PIECE($$MOD^ICPTMOD(LEXIEN,"I",$GET(LEXVDT)),U,3)
End DoDot:1
+14 SET X=""
if $LENGTH($GET(LEXC))&($LENGTH($GET(LEXN)))
SET X=LEXC_U_LEXN
+15 QUIT X
FI(X) ; File
+1 SET X=$GET(X)
+2 if X["ICD-9 Dx"!(X["ICD-9 Diag")
QUIT ($TRANSLATE($$ROOT^ICDEX(80),"^","")_"^80^1")
+3 if X["ICD-9 Op"!(X["ICD-9 Proc")
QUIT ($TRANSLATE($$ROOT^ICDEX(80.1),"^","")_"^80.1^2")
+4 if X["ICD-10 Dx"!(X["ICD-10 Diag")
QUIT ($TRANSLATE($$ROOT^ICDEX(80),"^","")_"^80^30")
+5 if X["ICD-10 Op"!(X["ICD-10 Proc")
QUIT ($TRANSLATE($$ROOT^ICDEX(80.1),"^","")_"^80.1^31")
+6 if X["CPT-4"!(X["CPT Proc")
QUIT "ICPT(^81^3"
if X["HCPCS"
QUIT "ICPT(^81^4"
+7 if X["CPT Mod"
QUIT "DIC(81.3,^81.3^"
+8 QUIT ""
SHO ; Show TMP
+1 NEW LEXNN,LEXNC
SET LEXNN="^TMP(""LEXQL"","_$JOB_")"
SET LEXNC="^TMP(""LEXQL"","_$JOB_","
+2 WRITE !
FOR
SET LEXNN=$QUERY(@LEXNN)
if '$LENGTH(LEXNN)!(LEXNN'[LEXNC)
QUIT
WRITE !,LEXNN,"=",@LEXNN
+3 WRITE !
+4 QUIT
+5 ; Miscellaneous
CL ; Clear
+1 KILL LEXVDT,LEXEXIT
+2 QUIT
