LEXQL2 ;ISL/KER - Query - Lookup Code (Build List) ;05/23/2017
;;2.0;LEXICON UTILITY;**62,80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^DIC(81.3, ICR 4492
; ^ICD0("BA" ICR 4486
; ^ICD9("BA" ICR 4485
; ^ICPT( ICR 4489
; ^ICPT("BA" ICR 4489
; ^TMP("LEXQL") SACC 2.3.2.5.1
;
; External References
; $$CODEABA^ICDEX ICR 5747
; $$ROOT^ICDEX ICR 5747
; $$DT^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
ADD(X) ; Add to List
N LEXIN,LEXINU,LEXO,LEXCO,LEXCT,LEXCS,LEXTO,LEXTT,LEXOC,LEXCT,LEXTY,LEXTD,LEXTMP
N LEXKEY,LEXLEN,LEXRT,LEXSO,LEXTKNS S LEXTD=$$DT^XLFDT,U="^"
S LEXIN=$G(X),LEXINU=$$UP^XLFSTR($$TM($G(LEXIN))) K LEXTKNS S LEXTTK=$$TOKN(LEXINU)
S LEXLEN=$O(LEXTKNS(" "),-1)
F LEXTMP="~","!","@","#","$","%","&","*","(",")","_","+","`","-","="," " S LEXSO=$P(LEXIN,LEXTMP,1)
F LEXTMP="[","]","{","}",";","'","\",":","|",",","/","?","<",">" S LEXSO=$P(LEXSO,LEXTMP,1)
S:+LEXLEN'>0 LEXLEN=$L(LEXSO)
S LEXKEY=$O(LEXTKNS(LEXLEN,""),-1) S:'$L(LEXKEY) LEXKEY=LEXSO S LEXKEY=$TR(LEXKEY,"#","") Q:'$L(LEXKEY)
K LEXTKNS(+LEXLEN,LEXKEY) S:+LEXTTK>0 LEXTTK=LEXTTK-1
S LEXTT=LEXKEY
S LEXTO=$E(LEXKEY,1,($L(LEXKEY)-1))_$C(($A($E(LEXKEY,$L(LEXKEY)))-1))_"~"
S LEXCT=$TR(LEXSO,"#","")
S LEXCO=$E(LEXSO,1,($L(LEXSO)-1))_$C(($A($E(LEXSO,$L(LEXSO)))-1))_"~"
; ICD-10 DX
S LEXRT=$$ROOT^ICDEX(80),LEXCS=30
I ($L(LEXTT)>2&$$OK(LEXTT,LEXRT,"AD",LEXCS))!($L(LEXCT)>2&($$OK(LEXCT,LEXRT,"ABA",LEXCS))) D
. S LEXTY=1 D ICD^LEXQL3($G(LEXINU),LEXCS)
; ICD-10 PR
S LEXRT=$$ROOT^ICDEX(80.1),LEXCS=31
I ($L(LEXTT)>2&$$OK(LEXTT,LEXRT,"AD",LEXCS))!($L(LEXCT)>2&($$OK(LEXCT,LEXRT,"ABA",LEXCS))) D
. S LEXTY=2 D ICD^LEXQL3($G(LEXINU),LEXCS)
; ICD-9 DX
S LEXRT=$$ROOT^ICDEX(80),LEXCS=1
I ($L(LEXTT)>2&$$OK(LEXTT,LEXRT,"AD",LEXCS))!($L(LEXCT)>2&($$OK(LEXCT,LEXRT,"ABA",LEXCS))) D
. S LEXTY=3 D ICD^LEXQL3($G(LEXINU),LEXCS)
; ICD-9 PR
S LEXRT=$$ROOT^ICDEX(80.1),LEXCS=2
I ($L(LEXTT)>2&$$OK(LEXTT,LEXRT,"AD",LEXCS))!($L(LEXCT)>2&($$OK(LEXCT,LEXRT,"ABA",LEXCS))) D
. S LEXTY=4 D ICD^LEXQL3($G(LEXINU),LEXCS)
; CPT/HCPCS
I ($L(LEXTT)>2&$$OK(LEXTT,"^ICPT(","C"))!($L(LEXCT)>2&($$OK(LEXCT,"^ICPT(","BA"))) D
. S LEXTY=5 D CP^LEXQL4
; CPT MOD
I ($L(LEXCT)>0&($$OK(LEXCT,"^DIC(81.3,","BA"))) D
. S LEXTY=6 D CM^LEXQL4
; Re-Order List
N LEXCT,LEXO,LEXT1,LEXT2,LEX S LEXO="" F S LEXO=$O(^TMP("LEXQL",$J,"ADDLIST",LEXO)) Q:'$L(LEXO) D
. K LEX N LEXT1,LEXT2 S LEXT1=$$TM($G(^TMP("LEXQL",$J,"ADDLIST",LEXO)))
. S LEXT2=$$TM($G(^TMP("LEXQL",$J,"ADDLIST",LEXO,2))) Q:'$L(LEXT2)
. I $L(LEXT2) K LEX S LEX(1)=LEXT2 D PR^LEXU(.LEX,70) Q:'$L($G(LEX(1)))
. S LEXCT=+($G(LEXCT))+1 K ^TMP("LEXQL",$J,+LEXCT)
. S ^TMP("LEXQL",$J,+LEXCT)=$G(LEX(1)),^TMP("LEXQL",$J,0)=+LEXCT
. S:$L($G(LEX(2))) ^TMP("LEXQL",$J,+LEXCT,2)=$G(LEX(2))
K ^TMP("LEXQL",$J,"ADDLIST")
Q
;
; Miscellaneous
VSO(X) ; Verify Input
N LEX,LEXIO,LEXIC,LEXUC,LEXUO S LEX=$G(X) Q:'$L(LEX) "" Q:$L(LEX)'>1 $$UP^XLFSTR(LEX)
S LEXIC=$G(LEX),LEXIO=$E(LEX,1,($L(LEX)-1))_$C(($A($E(LEX,$L(LEX)))-1))_"~ "
S LEXUC=$$UP^XLFSTR(LEXIC),LEXUO=$$UP^XLFSTR(LEXIO)
; 80 ICD-9/10
I $E($O(^ICD9("BA",LEXIO)),1,$L(LEXIC))=LEXIC Q LEXIC
I $E($O(^ICD9("BA",LEXUO)),1,$L(LEXUC))=LEXUC Q LEXUC
; 80.1 ICD-9.10
I $E($O(^ICD0("BA",LEXIO)),1,$L(LEXIC))=LEXIC Q LEXIC
I $E($O(^ICD0("BA",LEXUO)),1,$L(LEXUC))=LEXUC Q LEXUC
; 81 CPT
I $E($O(^ICPT("BA",LEXIO)),1,$L(LEXIC))=LEXIC Q LEXIC
I $E($O(^ICPT("BA",LEXUO)),1,$L(LEXUC))=LEXUC Q LEXUC
; 81.3 CPT Modifier
I $E($O(^DIC(81.3,"BA",LEXIO)),1,$L(LEXIC))=LEXIC Q LEXIC
I $E($O(^DIC(81.3,"BA",LEXUO)),1,$L(LEXUC))=LEXUC Q LEXUC
Q LEX
SD(X) ; Short Date
Q $TR($$FMTE^XLFDT(+($G(X)),"5DZ"),"@"," ")
FT(X,Y,LEX) ; Format Text First
N LEXT,LEXC,LEXD,LEXS S LEXC=$G(X),LEXD=$G(Y),LEXS=$G(LEX) S LEXC=$G(LEXC) Q:'$L(LEXC) ""
S LEXT=$P($$STY(LEXC),U,2) Q:'$L(LEXT) S LEXD=$G(LEXD) Q:'$L(LEXD) ""
S LEXS=$G(LEXS),LEXT=$G(LEXT) S:$L(LEXD)&($L(LEXS)) LEXD=LEXD_" ("_LEXS_")" N LEXO
S LEXO=LEXC S LEXO=LEXO_$J(" ",(9-$L(LEXO)))_$E(LEXD,1,54)
S LEXO=LEXO_$J(" ",(63-$L(LEXO)))_LEXT S X=LEXO
Q X
FC(X,Y,LEX) ; Format Code First
N LEXO,LEXT,LEXC,LEXD,LEXS S LEXC=$G(X),LEXD=$G(Y),LEXS=$G(LEX) Q:'$L(LEXC) ""
S LEXT=$P($$STY(LEXC),"^",2) Q:'$L(LEXT) "" Q:'$L(LEXD) ""
S LEXS=$G(LEX),LEXO=LEXT_" "_LEXC_" ",LEXO=LEXO_$J(" ",(19-$L(LEXO))),LEXO=LEXO_" "_LEXD
S:$L(LEXS)&(LEXO'[LEXS) LEXO=$E(LEXO,1,56)_" ("_LEXS_")" S X=LEXO
Q X
STY(X) ; Short Type
N LEXSO S LEXSO=$G(X) Q:$L(LEXSO)'>1 ""
Q:$$CODEABA^ICDEX(LEXSO,80,30)>0 "1^ICD-10 Dx"
Q:$$CODEABA^ICDEX(LEXSO,80.1,31)>0 "2^ICD-10 Op"
Q:$$CODEABA^ICDEX(LEXSO,80,1)>0 "3^ICD-9 Dx"
Q:$$CODEABA^ICDEX(LEXSO,80.1,2)>0 "4^ICD-9 Op"
Q:$D(^ICPT("BA",(LEXSO_" "))) "5^CPT-4/HCPCS"
Q:$D(^DIC(81.3,"BA",(LEXSO_" "))) "6^CPT Mod"
Q ""
LTY(X) ; Long Type
N LEXSO,LEX S LEXSO=$G(X) Q:$L(LEXSO)'>1 ""
Q:$$CODEABA^ICDEX(LEXSO,80,30)>0 "1^ICD-10 Diagnosis Code"
Q:$$CODEABA^ICDEX(LEXSO,80.1,31)>0 "2^ICD-10 Procedure Code"
Q:$$CODEABA^ICDEX(LEXSO,80,1)>0 "3^ICD-9 Diagnosis Code"
Q:$$CODEABA^ICDEX(LEXSO,80.1,2)>0 "4^ICD-9 Procedure Code"
S LEX=$O(^ICPT("BA",(LEXSO_" "),0)) I LEX>0 D Q:LEX["^" LEX
. N LEXS S LEXS=$P($G(^ICPT(+LEX,0)),"^",6)
. I LEXS="C" S LEX="5^CPT Procedure Code" Q
. I LEXS="H" S LEX="6^HCPCS Procedure Code" Q
. I LEXSO?5N S LEX="5^CPT Procedure Code" Q
. S LEX="6^HCPCS Procedure Code"
Q:$D(^DIC(81.3,"BA",(LEXSO_" "))) "7^CPT Modifier Code"
Q ""
DS(X) ; Trim Dubble Space Character
S X=$G(X) Q:X'[" " X F Q:X'[" " S X=$P(X," ",1)_" "_$P(X," ",2,4000)
Q X
TM(X,Y) ; Trim Character Y - Default " "
S X=$G(X) Q:X="" X 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
OK(X,Y,LEX,LEXS) ; User Input is Ok
N LEXIX,LEXX,LEXO,LEXCT,LEXNX,LEXROOT
S (LEXCT,LEXX)=$TR($G(X),"#","") Q:$L(LEXX)'>0 0 S LEXROOT=$G(Y),LEXIX=$G(LEX),LEXS=+($G(LEXS))
Q:'$L(LEXROOT) 0 Q:"^D^AD^BA^ABA^C^"'[("^"_LEXIX_"^") 0
S LEXO=$E(LEXX,1,($L(LEXX)-1))_$C(($A($E(LEXX,$L(LEXX)))-1))_"~"
S:+LEXS'>0 LEXNX=$O(@(LEXROOT_""""_LEXIX_""","""_LEXO_""")"))
S:+LEXS>0 LEXNX=$O(@(LEXROOT_""""_LEXIX_""","_+LEXS_","""_LEXO_""")"))
Q:$E(LEXNX,1,$L(LEXCT))=LEXCT 1
Q 0
TOKN(X) ; Parse Tolkens
N LEXX,LEXBEG,LEXEND,LEXCHR,LEXTTK,LEXTKN,LEXNOT K LEXTKNS S LEXX=$G(X),LEXBEG=1,LEXTTK=0
S LEXNOT="^AND^THE^THEN^FOR^FROM^OTHER^THAN^WITH^THEIR^SOME^THIS^" F LEXEND=1:1:$L(LEXX)+1 D
. S LEXCHR=$E(LEXX,LEXEND) I "~!@#$%&*()_+`-=[]{};'\:|,./?<> """[LEXCHR D
. . S LEXTKN=$E(LEXX,LEXBEG,LEXEND-1),LEXBEG=LEXEND+1 I $L(LEXTKN)>2,$L(LEXTKN)<31,LEXNOT'[LEXTKN D
. . . S:'$D(LEXTKNS($L(LEXTKN),LEXTKN)) LEXTTK=+($G(LEXTTK))+1
. . . S LEXTKNS($L(LEXTKN),LEXTKN)=""
S X=+($G(LEXTTK))
Q X
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQL2 7179 printed Sep 23, 2025@19:44:49 Page 2
LEXQL2 ;ISL/KER - Query - Lookup Code (Build List) ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**62,80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^DIC(81.3, ICR 4492
+5 ; ^ICD0("BA" ICR 4486
+6 ; ^ICD9("BA" ICR 4485
+7 ; ^ICPT( ICR 4489
+8 ; ^ICPT("BA" ICR 4489
+9 ; ^TMP("LEXQL") SACC 2.3.2.5.1
+10 ;
+11 ; External References
+12 ; $$CODEABA^ICDEX ICR 5747
+13 ; $$ROOT^ICDEX ICR 5747
+14 ; $$DT^XLFDT ICR 10103
+15 ; $$FMTE^XLFDT ICR 10103
+16 ; $$UP^XLFSTR ICR 10104
+17 ;
ADD(X) ; Add to List
+1 NEW LEXIN,LEXINU,LEXO,LEXCO,LEXCT,LEXCS,LEXTO,LEXTT,LEXOC,LEXCT,LEXTY,LEXTD,LEXTMP
+2 NEW LEXKEY,LEXLEN,LEXRT,LEXSO,LEXTKNS
SET LEXTD=$$DT^XLFDT
SET U="^"
+3 SET LEXIN=$GET(X)
SET LEXINU=$$UP^XLFSTR($$TM($GET(LEXIN)))
KILL LEXTKNS
SET LEXTTK=$$TOKN(LEXINU)
+4 SET LEXLEN=$ORDER(LEXTKNS(" "),-1)
+5 FOR LEXTMP="~","!","@","#","$","%","&","*","(",")","_","+","`","-","="," "
SET LEXSO=$PIECE(LEXIN,LEXTMP,1)
+6 FOR LEXTMP="[","]","{","}",";","'","\",":","|",",","/","?","<",">"
SET LEXSO=$PIECE(LEXSO,LEXTMP,1)
+7 if +LEXLEN'>0
SET LEXLEN=$LENGTH(LEXSO)
+8 SET LEXKEY=$ORDER(LEXTKNS(LEXLEN,""),-1)
if '$LENGTH(LEXKEY)
SET LEXKEY=LEXSO
SET LEXKEY=$TRANSLATE(LEXKEY,"#","")
if '$LENGTH(LEXKEY)
QUIT
+9 KILL LEXTKNS(+LEXLEN,LEXKEY)
if +LEXTTK>0
SET LEXTTK=LEXTTK-1
+10 SET LEXTT=LEXKEY
+11 SET LEXTO=$EXTRACT(LEXKEY,1,($LENGTH(LEXKEY)-1))_$CHAR(($ASCII($EXTRACT(LEXKEY,$LENGTH(LEXKEY)))-1))_"~"
+12 SET LEXCT=$TRANSLATE(LEXSO,"#","")
+13 SET LEXCO=$EXTRACT(LEXSO,1,($LENGTH(LEXSO)-1))_$CHAR(($ASCII($EXTRACT(LEXSO,$LENGTH(LEXSO)))-1))_"~"
+14 ; ICD-10 DX
+15 SET LEXRT=$$ROOT^ICDEX(80)
SET LEXCS=30
+16 IF ($LENGTH(LEXTT)>2&$$OK(LEXTT,LEXRT,"AD",LEXCS))!($LENGTH(LEXCT)>2&($$OK(LEXCT,LEXRT,"ABA",LEXCS)))
Begin DoDot:1
+17 SET LEXTY=1
DO ICD^LEXQL3($GET(LEXINU),LEXCS)
End DoDot:1
+18 ; ICD-10 PR
+19 SET LEXRT=$$ROOT^ICDEX(80.1)
SET LEXCS=31
+20 IF ($LENGTH(LEXTT)>2&$$OK(LEXTT,LEXRT,"AD",LEXCS))!($LENGTH(LEXCT)>2&($$OK(LEXCT,LEXRT,"ABA",LEXCS)))
Begin DoDot:1
+21 SET LEXTY=2
DO ICD^LEXQL3($GET(LEXINU),LEXCS)
End DoDot:1
+22 ; ICD-9 DX
+23 SET LEXRT=$$ROOT^ICDEX(80)
SET LEXCS=1
+24 IF ($LENGTH(LEXTT)>2&$$OK(LEXTT,LEXRT,"AD",LEXCS))!($LENGTH(LEXCT)>2&($$OK(LEXCT,LEXRT,"ABA",LEXCS)))
Begin DoDot:1
+25 SET LEXTY=3
DO ICD^LEXQL3($GET(LEXINU),LEXCS)
End DoDot:1
+26 ; ICD-9 PR
+27 SET LEXRT=$$ROOT^ICDEX(80.1)
SET LEXCS=2
+28 IF ($LENGTH(LEXTT)>2&$$OK(LEXTT,LEXRT,"AD",LEXCS))!($LENGTH(LEXCT)>2&($$OK(LEXCT,LEXRT,"ABA",LEXCS)))
Begin DoDot:1
+29 SET LEXTY=4
DO ICD^LEXQL3($GET(LEXINU),LEXCS)
End DoDot:1
+30 ; CPT/HCPCS
+31 IF ($LENGTH(LEXTT)>2&$$OK(LEXTT,"^ICPT(","C"))!($LENGTH(LEXCT)>2&($$OK(LEXCT,"^ICPT(","BA")))
Begin DoDot:1
+32 SET LEXTY=5
DO CP^LEXQL4
End DoDot:1
+33 ; CPT MOD
+34 IF ($LENGTH(LEXCT)>0&($$OK(LEXCT,"^DIC(81.3,","BA")))
Begin DoDot:1
+35 SET LEXTY=6
DO CM^LEXQL4
End DoDot:1
+36 ; Re-Order List
+37 NEW LEXCT,LEXO,LEXT1,LEXT2,LEX
SET LEXO=""
FOR
SET LEXO=$ORDER(^TMP("LEXQL",$JOB,"ADDLIST",LEXO))
if '$LENGTH(LEXO)
QUIT
Begin DoDot:1
+38 KILL LEX
NEW LEXT1,LEXT2
SET LEXT1=$$TM($GET(^TMP("LEXQL",$JOB,"ADDLIST",LEXO)))
+39 SET LEXT2=$$TM($GET(^TMP("LEXQL",$JOB,"ADDLIST",LEXO,2)))
if '$LENGTH(LEXT2)
QUIT
+40 IF $LENGTH(LEXT2)
KILL LEX
SET LEX(1)=LEXT2
DO PR^LEXU(.LEX,70)
if '$LENGTH($GET(LEX(1)))
QUIT
+41 SET LEXCT=+($GET(LEXCT))+1
KILL ^TMP("LEXQL",$JOB,+LEXCT)
+42 SET ^TMP("LEXQL",$JOB,+LEXCT)=$GET(LEX(1))
SET ^TMP("LEXQL",$JOB,0)=+LEXCT
+43 if $LENGTH($GET(LEX(2)))
SET ^TMP("LEXQL",$JOB,+LEXCT,2)=$GET(LEX(2))
End DoDot:1
+44 KILL ^TMP("LEXQL",$JOB,"ADDLIST")
+45 QUIT
+46 ;
+47 ; Miscellaneous
VSO(X) ; Verify Input
+1 NEW LEX,LEXIO,LEXIC,LEXUC,LEXUO
SET LEX=$GET(X)
if '$LENGTH(LEX)
QUIT ""
if $LENGTH(LEX)'>1
QUIT $$UP^XLFSTR(LEX)
+2 SET LEXIC=$GET(LEX)
SET LEXIO=$EXTRACT(LEX,1,($LENGTH(LEX)-1))_$CHAR(($ASCII($EXTRACT(LEX,$LENGTH(LEX)))-1))_"~ "
+3 SET LEXUC=$$UP^XLFSTR(LEXIC)
SET LEXUO=$$UP^XLFSTR(LEXIO)
+4 ; 80 ICD-9/10
+5 IF $EXTRACT($ORDER(^ICD9("BA",LEXIO)),1,$LENGTH(LEXIC))=LEXIC
QUIT LEXIC
+6 IF $EXTRACT($ORDER(^ICD9("BA",LEXUO)),1,$LENGTH(LEXUC))=LEXUC
QUIT LEXUC
+7 ; 80.1 ICD-9.10
+8 IF $EXTRACT($ORDER(^ICD0("BA",LEXIO)),1,$LENGTH(LEXIC))=LEXIC
QUIT LEXIC
+9 IF $EXTRACT($ORDER(^ICD0("BA",LEXUO)),1,$LENGTH(LEXUC))=LEXUC
QUIT LEXUC
+10 ; 81 CPT
+11 IF $EXTRACT($ORDER(^ICPT("BA",LEXIO)),1,$LENGTH(LEXIC))=LEXIC
QUIT LEXIC
+12 IF $EXTRACT($ORDER(^ICPT("BA",LEXUO)),1,$LENGTH(LEXUC))=LEXUC
QUIT LEXUC
+13 ; 81.3 CPT Modifier
+14 IF $EXTRACT($ORDER(^DIC(81.3,"BA",LEXIO)),1,$LENGTH(LEXIC))=LEXIC
QUIT LEXIC
+15 IF $EXTRACT($ORDER(^DIC(81.3,"BA",LEXUO)),1,$LENGTH(LEXUC))=LEXUC
QUIT LEXUC
+16 QUIT LEX
SD(X) ; Short Date
+1 QUIT $TRANSLATE($$FMTE^XLFDT(+($GET(X)),"5DZ"),"@"," ")
FT(X,Y,LEX) ; Format Text First
+1 NEW LEXT,LEXC,LEXD,LEXS
SET LEXC=$GET(X)
SET LEXD=$GET(Y)
SET LEXS=$GET(LEX)
SET LEXC=$GET(LEXC)
if '$LENGTH(LEXC)
QUIT ""
+2 SET LEXT=$PIECE($$STY(LEXC),U,2)
if '$LENGTH(LEXT)
QUIT
SET LEXD=$GET(LEXD)
if '$LENGTH(LEXD)
QUIT ""
+3 SET LEXS=$GET(LEXS)
SET LEXT=$GET(LEXT)
if $LENGTH(LEXD)&($LENGTH(LEXS))
SET LEXD=LEXD_" ("_LEXS_")"
NEW LEXO
+4 SET LEXO=LEXC
SET LEXO=LEXO_$JUSTIFY(" ",(9-$LENGTH(LEXO)))_$EXTRACT(LEXD,1,54)
+5 SET LEXO=LEXO_$JUSTIFY(" ",(63-$LENGTH(LEXO)))_LEXT
SET X=LEXO
+6 QUIT X
FC(X,Y,LEX) ; Format Code First
+1 NEW LEXO,LEXT,LEXC,LEXD,LEXS
SET LEXC=$GET(X)
SET LEXD=$GET(Y)
SET LEXS=$GET(LEX)
if '$LENGTH(LEXC)
QUIT ""
+2 SET LEXT=$PIECE($$STY(LEXC),"^",2)
if '$LENGTH(LEXT)
QUIT ""
if '$LENGTH(LEXD)
QUIT ""
+3 SET LEXS=$GET(LEX)
SET LEXO=LEXT_" "_LEXC_" "
SET LEXO=LEXO_$JUSTIFY(" ",(19-$LENGTH(LEXO)))
SET LEXO=LEXO_" "_LEXD
+4 if $LENGTH(LEXS)&(LEXO'[LEXS)
SET LEXO=$EXTRACT(LEXO,1,56)_" ("_LEXS_")"
SET X=LEXO
+5 QUIT X
STY(X) ; Short Type
+1 NEW LEXSO
SET LEXSO=$GET(X)
if $LENGTH(LEXSO)'>1
QUIT ""
+2 if $$CODEABA^ICDEX(LEXSO,80,30)>0
QUIT "1^ICD-10 Dx"
+3 if $$CODEABA^ICDEX(LEXSO,80.1,31)>0
QUIT "2^ICD-10 Op"
+4 if $$CODEABA^ICDEX(LEXSO,80,1)>0
QUIT "3^ICD-9 Dx"
+5 if $$CODEABA^ICDEX(LEXSO,80.1,2)>0
QUIT "4^ICD-9 Op"
+6 if $DATA(^ICPT("BA",(LEXSO_" ")))
QUIT "5^CPT-4/HCPCS"
+7 if $DATA(^DIC(81.3,"BA",(LEXSO_" ")))
QUIT "6^CPT Mod"
+8 QUIT ""
LTY(X) ; Long Type
+1 NEW LEXSO,LEX
SET LEXSO=$GET(X)
if $LENGTH(LEXSO)'>1
QUIT ""
+2 if $$CODEABA^ICDEX(LEXSO,80,30)>0
QUIT "1^ICD-10 Diagnosis Code"
+3 if $$CODEABA^ICDEX(LEXSO,80.1,31)>0
QUIT "2^ICD-10 Procedure Code"
+4 if $$CODEABA^ICDEX(LEXSO,80,1)>0
QUIT "3^ICD-9 Diagnosis Code"
+5 if $$CODEABA^ICDEX(LEXSO,80.1,2)>0
QUIT "4^ICD-9 Procedure Code"
+6 SET LEX=$ORDER(^ICPT("BA",(LEXSO_" "),0))
IF LEX>0
Begin DoDot:1
+7 NEW LEXS
SET LEXS=$PIECE($GET(^ICPT(+LEX,0)),"^",6)
+8 IF LEXS="C"
SET LEX="5^CPT Procedure Code"
QUIT
+9 IF LEXS="H"
SET LEX="6^HCPCS Procedure Code"
QUIT
+10 IF LEXSO?5N
SET LEX="5^CPT Procedure Code"
QUIT
+11 SET LEX="6^HCPCS Procedure Code"
End DoDot:1
if LEX["^"
QUIT LEX
+12 if $DATA(^DIC(81.3,"BA",(LEXSO_" ")))
QUIT "7^CPT Modifier Code"
+13 QUIT ""
DS(X) ; Trim Dubble Space Character
+1 SET X=$GET(X)
if X'[" "
QUIT X
FOR
if X'[" "
QUIT
SET X=$PIECE(X," ",1)_" "_$PIECE(X," ",2,4000)
+2 QUIT X
TM(X,Y) ; Trim Character Y - Default " "
+1 SET X=$GET(X)
if X=""
QUIT X
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
OK(X,Y,LEX,LEXS) ; User Input is Ok
+1 NEW LEXIX,LEXX,LEXO,LEXCT,LEXNX,LEXROOT
+2 SET (LEXCT,LEXX)=$TRANSLATE($GET(X),"#","")
if $LENGTH(LEXX)'>0
QUIT 0
SET LEXROOT=$GET(Y)
SET LEXIX=$GET(LEX)
SET LEXS=+($GET(LEXS))
+3 if '$LENGTH(LEXROOT)
QUIT 0
if "^D^AD^BA^ABA^C^"'[("^"_LEXIX_"^")
QUIT 0
+4 SET LEXO=$EXTRACT(LEXX,1,($LENGTH(LEXX)-1))_$CHAR(($ASCII($EXTRACT(LEXX,$LENGTH(LEXX)))-1))_"~"
+5 if +LEXS'>0
SET LEXNX=$ORDER(@(LEXROOT_""""_LEXIX_""","""_LEXO_""")"))
+6 if +LEXS>0
SET LEXNX=$ORDER(@(LEXROOT_""""_LEXIX_""","_+LEXS_","""_LEXO_""")"))
+7 if $EXTRACT(LEXNX,1,$LENGTH(LEXCT))=LEXCT
QUIT 1
+8 QUIT 0
TOKN(X) ; Parse Tolkens
+1 NEW LEXX,LEXBEG,LEXEND,LEXCHR,LEXTTK,LEXTKN,LEXNOT
KILL LEXTKNS
SET LEXX=$GET(X)
SET LEXBEG=1
SET LEXTTK=0
+2 SET LEXNOT="^AND^THE^THEN^FOR^FROM^OTHER^THAN^WITH^THEIR^SOME^THIS^"
FOR LEXEND=1:1:$LENGTH(LEXX)+1
Begin DoDot:1
+3 SET LEXCHR=$EXTRACT(LEXX,LEXEND)
IF "~!@#$%&*()_+`-=[]{};'\:|,./?<> """[LEXCHR
Begin DoDot:2
+4 SET LEXTKN=$EXTRACT(LEXX,LEXBEG,LEXEND-1)
SET LEXBEG=LEXEND+1
IF $LENGTH(LEXTKN)>2
IF $LENGTH(LEXTKN)<31
IF LEXNOT'[LEXTKN
Begin DoDot:3
+5 if '$DATA(LEXTKNS($LENGTH(LEXTKN),LEXTKN))
SET LEXTTK=+($GET(LEXTTK))+1
+6 SET LEXTKNS($LENGTH(LEXTKN),LEXTKN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+7 SET X=+($GET(LEXTTK))
+8 QUIT X
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
