LEXQIL ;ISL/KER - Query - ICD Non-Versioned Lookup ;10/10/2017
;;2.0;LEXICON UTILITY;**114**;Sep 23, 1996;Build 1
;
; Global Variables
; ^TMP("LEXQIL" SACC 2.3.2.5.1
;
; External References
; ^DIR ICR 10026
; $$CODEC^ICDEX ICR 5747
; $$CSI^ICDEX ICR 5747
; $$ICDDX^ICDEX ICR 5747
; $$ICDOP^ICDEX ICR 5747
; $$ROOT^ICDEX ICR 5747
; TOKEN^ICDEX ICR 5747
; $$DT^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10103
;
; Main Entry Points ICD/ICP
ICD(X) ; ICD DX Lookup
N LEXFI,LEXINP,LEXOUT,LEXDIRB S LEXDIRB=$$TM($G(X)),X="^",LEXFI=80
S:$L($G(LEXDIRB)) LEXINP=LEXDIRB S:'$L($G(LEXDIRB)) LEXINP=$$INP Q:$E(LEXINP,1)="^" "^" Q:$E(LEXINP,1,2)="^^" "^^"
K ^TMP("LEXQIL",$J) D BC($G(LEXINP),$G(LEXFI)) I +($G(^TMP("LEXQIL",$J,0)))=1 D Q X
. N OUT S LEXFI=80 S LEXOUT=$$ONE,X=-1 S:$E(LEXOUT,1)["^" X="^" S:+LEXOUT>0 X=$G(LEXOUT)
I +($G(^TMP("LEXQIL",$J,0)))>1 D Q X
. N OUT S LEXFI=80 S LEXOUT=$$MUL,X=-1 S:$E(LEXOUT,1)["^" X="^" S:+LEXOUT>0 X=$G(LEXOUT)
K ^TMP("LEXQIL",$J) D BT($G(LEXINP),$G(LEXFI)) I +($G(^TMP("LEXQIL",$J,0)))=1 D Q X
. N OUT S LEXFI=80 S LEXOUT=$$ONE,X=-1 S:$E(LEXOUT,1)["^" X="^" S:+LEXOUT>0 X=$G(LEXOUT)
I +($G(^TMP("LEXQIL",$J,0)))>1 D Q X
. N OUT S LEXFI=80 S LEXOUT=$$MUL,X=-1 S:$E(LEXOUT,1)["^" X="^" S:+LEXOUT>0 X=$G(LEXOUT)
Q X
ICP(X) ; ICD PR Lookup
N LEXFI,LEXINP,LEXOUT,LEXDIRB S LEXDIRB=$$TM($G(X)),X="^",LEXFI=80.1
S:$L($G(LEXDIRB)) LEXINP=LEXDIRB S:'$L($G(LEXDIRB)) LEXINP=$$INP Q:$E(LEXINP,1)="^" "^" Q:$E(LEXINP,1,2)="^^" "^^"
K ^TMP("LEXQIL",$J) D BC($G(LEXINP),$G(LEXFI)) I +($G(^TMP("LEXQIL",$J,0)))=1 D Q X
. N OUT S LEXFI=80.1 S LEXOUT=$$ONE,X=-1 S:$E(LEXOUT,1)["^" X="^" S:+LEXOUT>0 X=$G(LEXOUT)
I +($G(^TMP("LEXQIL",$J,0)))>1 D Q X
. N OUT S LEXFI=80.1 S LEXOUT=$$MUL,X=-1 S:$E(LEXOUT,1)["^" X="^" S:+LEXOUT>0 X=$G(LEXOUT)
K ^TMP("LEXQIL",$J) D BT($G(LEXINP),$G(LEXFI)) I +($G(^TMP("LEXQIL",$J,0)))=1 D Q X
. N OUT S LEXFI=80.1 S LEXOUT=$$ONE,X=-1 S:$E(LEXOUT,1)["^" X="^" S:+LEXOUT>0 X=$G(LEXOUT)
I +($G(^TMP("LEXQIL",$J,0)))>1 D Q X
. N OUT S LEXFI=80.1 S LEXOUT=$$MUL,X=-1 S:$E(LEXOUT,1)["^" X="^" S:+LEXOUT>0 X=$G(LEXOUT)
Q X
;
; Selections
ONE(X) ; One Entry Found
Q:"^80^80.1^"'[("^"_$G(LEXFI)_"^") "^^" Q:+($G(LEXEXIT))>0 "^^"
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEX,LEXC,LEXCT,LEXIEN,LEXTX,LEXX,Y
S LEXTX=$G(^TMP("LEXQIL",$J,1)),LEXIEN=+LEXTX,LEXTX=$P(LEXTX,U,2),LEX(1)=LEXTX D PR^LEXU(.LEX,70)
S DIR("A",1)=" One code found",DIR("A",2)=" ",DIR("A",3)=" "_$G(LEX(1)),LEXC=3 K LEX(1) D:$O(LEX(0))>0 PR^LEXU(.LEX,64)
S:$L($G(LEX(1))) LEXC=LEXC+1,DIR("A",LEXC)=" "_$G(LEX(1))
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(LEXQUIET) !
S (X,Y)="" D:'$D(LEXQUIET) ^DIR S:$D(LEXQUIET) Y=1 S:X["^^"!($D(DTOUT)) LEXEXIT=1,X="^^"
I X["^^"!(+($G(LEXEXIT))>0)!($D(DIROUT)) K ^TMP("LEXQIL",$J) S LEXEXIT=1 Q "^^"
S X=-1 S:+Y'>0 X=-1 S:+Y>0 X=$$X(+($G(LEXIEN)),+($G(LEXFI)))
Q X
MUL(X) ; Multiple Entries Found
Q:"^80^80.1^"'[("^"_$G(LEXFI)_"^") "^^" Q:+($G(LEXEXIT))>0 "^^"
N LEXENT,LEXI,LEXIEN,LEXIT,LEXMAX,LEXSS,LEXSTR,LEXT1,LEXTTT,Y
S (LEXMAX,LEXI,LEXSS,LEXIT)=0 S U="^",LEXTTT=$G(^TMP("LEXQIL",$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("LEXQIL",$J,LEXI))
. S LEXIEN=$P(LEXENT,U,1) Q:'$L($P(LEXENT,"^",2)) 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 LEX,LEXIEN,LEXJ,LEXK,LEXTX S LEXK=+($G(LEXI)) N LEXI S LEXTX=$P(LEXENT,U,2),LEXIEN=+LEXENT
K LEX S LEX(1)=LEXTX D PR^LEXU(.LEX,70) W !,$J(LEXK,5),". ",$G(LEX(1)) K LEX(1) D:$O(LEX(0))>0 PR^LEXU(.LEX,59)
F LEXJ=1:1:5 S LEXTX=$G(LEX(LEXJ)) W:$L(LEXTX) !," ",LEXTX
Q
MULS(X,Y) ; Select Multiple
Q:+($G(LEXEXIT))>0 "^^"
N DIR,DIRB,DIROUT,DIRUT,DTOUT,DUOUT,LEXI,LEXLAST,LEXMAX,LEXS,LEXTQ,Y
S (LEXS,LEXMAX)=+($G(X)),(LEXI,LEXLAST)=+($G(Y)) Q:LEXMAX=0 -1
S:+($O(^TMP("LEXQIL",$J,+LEXLAST)))>0 DIR("A")=" Press <RETURN> for more, '^' to exit, or Select 1-"_LEXMAX_": "
S:+($O(^TMP("LEXQIL",$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("LEXQIL",$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 Q:"^80^80.1^"'[("^"_$G(LEXFI)_"^") X I +LEXSS>0 D
. N LEXIEN S LEXIEN=+($G(^TMP("LEXQIL",$J,+LEXSS))) S:+LEXIEN>0 X=$$X(+($G(LEXIEN)),+($G(LEXFI)))
Q X
;
; Lookups
BC(X,Y) ; Lookup by Code
K ^TMP("LEXQIL",$J) N LEXFI,LEXCTL,LEXIEN,LEXINP,LEXORD,LEXRT,LEXSY S LEXFI=+($G(Y)) Q:"^80^80.1^"'[("^"_$G(LEXFI)_"^")
S LEXINP=$G(X) Q:'$L(X) S LEXRT=$$ROOT^ICDEX(LEXFI)
S LEXORD=$E(LEXINP,1,($L(LEXINP)-1))_$C($A($E(LEXINP,$L(LEXINP)))-1)_"~",LEXCTL=LEXINP
F S LEXORD=$O(@(LEXRT_"""BA"","""_LEXORD_""")")) Q:'$L(LEXORD) Q:LEXORD'[LEXCTL D
. N LEXIEN S LEXIEN=0,LEXTMP=LEXRT_"""BA"","""_LEXORD_""","_LEXIEN_")"
. F S LEXIEN=$O(@(LEXRT_"""BA"","""_LEXORD_""","_LEXIEN_")")) Q:+LEXIEN'>0 D
. . I +LEXIEN>0&($D(@(LEXRT_+LEXIEN_",0)"))) D
. . . N LEXCODE,LEXCOM,LEXCT,LEXEFF,LEXHIS,LEXLAS,LEXSPC,LEXSR,LEXSTA,LEXSTR,LEXTD,LEXTXT,LEXTY S LEXTD=$$DT^XLFDT
. . . S LEXCODE=$P($G(@(LEXRT_LEXIEN_",0)")),"^",1),LEXSR=$P($G(@(LEXRT_LEXIEN_",1)")),"^",1)
. . . S:"^1^30^"[("^"_LEXSR_"^") LEXTY="Diagnosis" S:"^2^31^"[("^"_LEXSR_"^") LEXTY="Procedure"
. . . S LEXEFF=$O(@(LEXRT_LEXIEN_",66,""B"","_(LEXTD+.0001)_")"),-1)
. . . S LEXHIS=0 S:LEXEFF?7N LEXHIS=$O(@(LEXRT_LEXIEN_",66,""B"","_+LEXEFF_","" "")"),-1)
. . . S LEXSTA=0 S:LEXHIS>0 LEXSTA=$P($G(@(LEXRT_LEXIEN_",66,"_+LEXHIS_",0)")),"^",2)
. . . S LEXLAS=$O(@(LEXRT_LEXIEN_",66,""B"","" "")"),-1)
. . . S LEXHIS=$O(@(LEXRT_LEXIEN_",68,""B"","" "")"),-1)
. . . S:LEXHIS?7N LEXHIS=$O(@(LEXRT_LEXIEN_",68,""B"","_+LEXHIS_","" "")"),-1)
. . . S LEXTXT="" S:+LEXHIS>0 LEXTXT=$P($G(@(LEXRT_LEXIEN_",68,"_+LEXHIS_",1)")),"^",1)
. . . S:LEXEFF=""&(LEXLAS?7N) LEXCOM="Pending"
. . . S:LEXEFF?7N&(+LEXSTA'>0) LEXCOM="Inactive"
. . . S:LEXSR'>29&($L($G(LEXCOM))) LEXCOM=$G(LEXCOM)_", ICD-9"
. . . S:LEXSR>29&($L($G(LEXCOM))) LEXCOM=$G(LEXCOM)_", ICD-10"
. . . S:$L($G(LEXTY))&($L($G(LEXCOM))) LEXCOM=LEXCOM_" "_LEXTY
. . . S LEXSPC=$S(LEXFI=80:$J(" ",(11-$L($G(LEXCODE)))),1:$J(" ",(10-$L($G(LEXCODE)))))
. . . S LEXSTR=$G(LEXCODE)_LEXSPC_LEXTXT S:$L($G(LEXCOM)) LEXSTR=LEXSTR_" ("_$G(LEXCOM)_")"
. . . I $D(LEXQUIET),$L($G(LEXDIRB)) D Q
. . . . I $G(LEXDIRB)=LEXCODE S ^TMP("LEXQIL",$J,0)=1,^TMP("LEXQIL",$J,1)=(LEXIEN_"^"_LEXSTR)
. . . S LEXCT=$O(^TMP("LEXQIL",$J," "),-1)+1
. . . S ^TMP("LEXQIL",$J,0)=LEXCT
. . . S ^TMP("LEXQIL",$J,LEXCT)=(LEXIEN_"^"_LEXSTR)
Q
BT(X,Y) ; Lookup by Text
N LEXFI,LEXINP,LEXRT S LEXINP=$G(X) Q:'$L(X) S LEXFI=+($G(Y)) Q:"^80^80.1^"'[("^"_LEXFI_"^") S LEXRT=$$ROOT^ICDEX(LEXFI) D BLD(LEXINP,LEXFI)
Q
BLD(X,Y) ; Build Selection Array
K ^TMP("LEXQIL",$J) Q:'$L($G(X))!('$L($G(Y))) "^^" N LEXFI,LEXINP,LEXRT,LEXSY,LEXTOK K LEXTOK
S LEXINP=$$UP^XLFSTR($G(X)),LEXFI=+($G(Y)),LEXRT=$$ROOT^ICDEX(LEXFI) D PAR(LEXINP,LEXFI,.LEXTOK) D GET(LEXFI,.LEXTOK)
Q
PAR(X,Y,LEX) ; Parse text into tokens
N LEXFI,LEXI,LEXINP,LEXRT,LEXSY,LEXTK,LEXTMP S LEXINP=$G(X),LEXFI=+($G(Y)),LEXRT=$$ROOT^ICDEX(LEXFI),LEXSY="" K LEX
Q:'$L(LEXINP) Q:'$D(LEXRT) D TOKEN^ICDEX($G(LEXINP),$G(LEXRT),$G(LEXSY),.LEXTMP)
S LEXI=0 F S LEXI=$O(LEXTMP(LEXI)) Q:+LEXI'>0 D
. N LEXTK S LEXTK=$G(LEXTMP(LEXI)) Q:'$L(LEXTK) Q:'$D(@(LEXRT_"""D"","""_LEXTK_""")"))
. S LEX(0)=+($G(LEX(0)))+1,LEX(+($G(LEX(0))))=LEXTK
K LEXTMP
Q
GET(X,LEX) ; Get Entries
N LEXFI,LEXRT,LEXORD,LEXORG,LEXIEN,LEXTD S LEXFI=+($G(X)),LEXRT=$$ROOT^ICDEX(LEXFI),LEXORG=$G(LEX(1)) Q:'$L(LEXORG) S LEXTD=$$DT^XLFDT
S LEXIEN=0 F S LEXIEN=$O(@(LEXRT_"""D"","""_LEXORG_""","_+LEXIEN_")")) Q:+LEXIEN'>0 D
. N LEXOK,LEXI S LEXOK=1 S LEXI=1 F S LEXI=$O(LEX(LEXI)) Q:+LEXI'>0 D Q:'LEXOK
. . N LEXORD S LEXORD=$G(LEX(LEXI)) I '$D(@(LEXRT_"""D"","""_LEXORD_""","_+LEXIEN_")")) S LEXOK=0 Q
. I LEXOK D
. . N LEXCODE,LEXCOM,LEXEFF,LEXHIS,LEXLAS,LEXSPC,LEXSR,LEXSTA,LEXSTR,LEXTXT,LEXTY
. . S LEXCODE=$P($G(@(LEXRT_LEXIEN_",0)")),"^",1)
. . S LEXSR=$P($G(@(LEXRT_LEXIEN_",1)")),"^",1)
. . S:"^1^30^"[("^"_LEXSR_"^") LEXTY="Diagnosis"
. . S:"^2^31^"[("^"_LEXSR_"^") LEXTY="Procedure"
. . S LEXEFF=$O(@(LEXRT_LEXIEN_",66,""B"","_(LEXTD+.0001)_")"),-1)
. . S LEXHIS=0 S:LEXEFF?7N LEXHIS=$O(@(LEXRT_LEXIEN_",66,""B"","_+LEXEFF_","" "")"),-1)
. . S LEXSTA=0 S:LEXHIS>0 LEXSTA=$P($G(@(LEXRT_LEXIEN_",66,"_+LEXHIS_",0)")),"^",2)
. . S LEXLAS=$O(@(LEXRT_LEXIEN_",66,""B"","" "")"),-1)
. . S LEXHIS=$O(@(LEXRT_LEXIEN_",68,""B"","" "")"),-1)
. . S:LEXHIS?7N LEXHIS=$O(@(LEXRT_LEXIEN_",68,""B"","_+LEXHIS_","" "")"),-1)
. . S LEXTXT="" S:+LEXHIS>0 LEXTXT=$P($G(@(LEXRT_LEXIEN_",68,"_+LEXHIS_",1)")),"^",1)
. . S:LEXEFF=""&(LEXLAS?7N) LEXCOM="Pending"
. . S:LEXEFF?7N&(+LEXSTA'>0) LEXCOM="Inactive"
. . S:LEXSR'>29&($L($G(LEXCOM))) LEXCOM=$G(LEXCOM)_", ICD-9"
. . S:LEXSR>29&($L($G(LEXCOM))) LEXCOM=$G(LEXCOM)_", ICD-10"
. . S:$L($G(LEXTY))&($L($G(LEXCOM))) LEXCOM=LEXCOM_" "_LEXTY
. . S LEXSPC=$S(LEXFI=80:$J(" ",(11-$L($G(LEXCODE)))),1:$J(" ",(10-$L($G(LEXCODE)))))
. . S LEXSTR=$G(LEXCODE)_LEXSPC_LEXTXT S:$L($G(LEXCOM)) LEXSTR=LEXSTR_" ("_$G(LEXCOM)_")"
. . S ^TMP("LEXQIL",$J,"ORD",(LEXCODE_" "))=(LEXIEN_"^"_LEXSTR)
S LEXORD="" F S LEXORD=$O(^TMP("LEXQIL",$J,"ORD",LEXORD)) Q:'$L(LEXORD) D
. N LEXCT,LEXVAL S LEXVAL=$G(^TMP("LEXQIL",$J,"ORD",LEXORD)) Q:+LEXVAL'>0 Q:'$L($P(LEXVAL,"^",2))
. S LEXCT=$O(^TMP("LEXQIL",$J," "),-1)+1,^TMP("LEXQIL",$J,LEXCT)=LEXVAL,^TMP("LEXQIL",$J,0)=LEXCT
K ^TMP("LEXQIL",$J,"ORD")
Q
;
; Miscellaneous
INP(X) ; Input
Q:"^80^80.1^"'[("^"_$G(LEXFI)_"^") "^^" Q:+($G(LEXEXIT))>0 "^^"
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXTD,Y,LEX,LEXIT S:LEXFI=80 DIR("A")=" Enter a Diagnosis Code or Term: "
S:LEXFI=80.1 DIR("A")=" Enter a Procedure Code or Term: " Q:'$L($G(DIR("A"))) "^^" S DIR(0)="FAO^1:70"
S DIR("PRE")="S:X[""?"" X=""??""",(DIR("?"),DIR("??"))="^D INPH^LEXQIL" W ! D ^DIR
Q:X="^^"!($D(DTOUT))!(+($G(LEXEXIT))) "^^" S:$D(DIROUT)!($D(DIRUT))!($D(DTOUT))!($D(DUOUT)) X="^" Q:$E(X,1)="^" X
S X="^" S:$L(Y) X=$$UP^XLFSTR(Y)
Q X
INPH ; Input Help
I +($G(LEXFI))=80 D Q
. W !," Enter an ICD Diagnosis code or a term, or '^' to exit",!
I +($G(LEXFI))=80.1 D Q
. W !," Enter an ICD Procedure code or a term, or '^' to exit",!
W !," Enter an ICD code or a term, or '^' to exit",!
Q
X(X,Y) ; Get X Return Value
N LEXIEN,LEXFI S LEXIEN=+X,X=-1,LEXFI=$G(Y) Q:"^80^80.1^"'[("^"_LEXFI_"^") -1 I +LEXIEN>0 D
. N LEXFD,LEXSO,LEXSY,LEXDX,LEXTX,LEXTD S LEXFD=$$FD,LEXTD=$$DT^XLFDT,LEXSO=$$CODEC^ICDEX(LEXFI,LEXIEN)
. S LEXSY=$$CSI^ICDEX(LEXFI,LEXIEN)
. I LEXFI=80 S LEXDX=$$ICDDX^ICDEX(LEXSO,LEXFD,LEXSY,"E"),LEXTX=$P(LEXDX,"^",4)
. I LEXFI=80.1 S LEXDX=$$ICDOP^ICDEX(LEXSO,LEXFD,LEXSY,"E"),LEXTX=$P(LEXDX,"^",5)
. S X=LEXIEN_"^"_LEXSO_"^"_LEXTX
S X=$$UP^XLFSTR(X)
Q X
FD(X) ; Get Future Date
S X=$$DT^XLFDT,X=($E(X,1,3)+1)_"1001" N LEXEXIT
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQIL 12055 printed Sep 23, 2025@19:44:43 Page 2
LEXQIL ;ISL/KER - Query - ICD Non-Versioned Lookup ;10/10/2017
+1 ;;2.0;LEXICON UTILITY;**114**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXQIL" SACC 2.3.2.5.1
+5 ;
+6 ; External References
+7 ; ^DIR ICR 10026
+8 ; $$CODEC^ICDEX ICR 5747
+9 ; $$CSI^ICDEX ICR 5747
+10 ; $$ICDDX^ICDEX ICR 5747
+11 ; $$ICDOP^ICDEX ICR 5747
+12 ; $$ROOT^ICDEX ICR 5747
+13 ; TOKEN^ICDEX ICR 5747
+14 ; $$DT^XLFDT ICR 10103
+15 ; $$UP^XLFSTR ICR 10103
+16 ;
+17 ; Main Entry Points ICD/ICP
ICD(X) ; ICD DX Lookup
+1 NEW LEXFI,LEXINP,LEXOUT,LEXDIRB
SET LEXDIRB=$$TM($GET(X))
SET X="^"
SET LEXFI=80
+2 if $LENGTH($GET(LEXDIRB))
SET LEXINP=LEXDIRB
if '$LENGTH($GET(LEXDIRB))
SET LEXINP=$$INP
if $EXTRACT(LEXINP,1)="^"
QUIT "^"
if $EXTRACT(LEXINP,1,2)="^^"
QUIT "^^"
+3 KILL ^TMP("LEXQIL",$JOB)
DO BC($GET(LEXINP),$GET(LEXFI))
IF +($GET(^TMP("LEXQIL",$JOB,0)))=1
Begin DoDot:1
+4 NEW OUT
SET LEXFI=80
SET LEXOUT=$$ONE
SET X=-1
if $EXTRACT(LEXOUT,1)["^"
SET X="^"
if +LEXOUT>0
SET X=$GET(LEXOUT)
End DoDot:1
QUIT X
+5 IF +($GET(^TMP("LEXQIL",$JOB,0)))>1
Begin DoDot:1
+6 NEW OUT
SET LEXFI=80
SET LEXOUT=$$MUL
SET X=-1
if $EXTRACT(LEXOUT,1)["^"
SET X="^"
if +LEXOUT>0
SET X=$GET(LEXOUT)
End DoDot:1
QUIT X
+7 KILL ^TMP("LEXQIL",$JOB)
DO BT($GET(LEXINP),$GET(LEXFI))
IF +($GET(^TMP("LEXQIL",$JOB,0)))=1
Begin DoDot:1
+8 NEW OUT
SET LEXFI=80
SET LEXOUT=$$ONE
SET X=-1
if $EXTRACT(LEXOUT,1)["^"
SET X="^"
if +LEXOUT>0
SET X=$GET(LEXOUT)
End DoDot:1
QUIT X
+9 IF +($GET(^TMP("LEXQIL",$JOB,0)))>1
Begin DoDot:1
+10 NEW OUT
SET LEXFI=80
SET LEXOUT=$$MUL
SET X=-1
if $EXTRACT(LEXOUT,1)["^"
SET X="^"
if +LEXOUT>0
SET X=$GET(LEXOUT)
End DoDot:1
QUIT X
+11 QUIT X
ICP(X) ; ICD PR Lookup
+1 NEW LEXFI,LEXINP,LEXOUT,LEXDIRB
SET LEXDIRB=$$TM($GET(X))
SET X="^"
SET LEXFI=80.1
+2 if $LENGTH($GET(LEXDIRB))
SET LEXINP=LEXDIRB
if '$LENGTH($GET(LEXDIRB))
SET LEXINP=$$INP
if $EXTRACT(LEXINP,1)="^"
QUIT "^"
if $EXTRACT(LEXINP,1,2)="^^"
QUIT "^^"
+3 KILL ^TMP("LEXQIL",$JOB)
DO BC($GET(LEXINP),$GET(LEXFI))
IF +($GET(^TMP("LEXQIL",$JOB,0)))=1
Begin DoDot:1
+4 NEW OUT
SET LEXFI=80.1
SET LEXOUT=$$ONE
SET X=-1
if $EXTRACT(LEXOUT,1)["^"
SET X="^"
if +LEXOUT>0
SET X=$GET(LEXOUT)
End DoDot:1
QUIT X
+5 IF +($GET(^TMP("LEXQIL",$JOB,0)))>1
Begin DoDot:1
+6 NEW OUT
SET LEXFI=80.1
SET LEXOUT=$$MUL
SET X=-1
if $EXTRACT(LEXOUT,1)["^"
SET X="^"
if +LEXOUT>0
SET X=$GET(LEXOUT)
End DoDot:1
QUIT X
+7 KILL ^TMP("LEXQIL",$JOB)
DO BT($GET(LEXINP),$GET(LEXFI))
IF +($GET(^TMP("LEXQIL",$JOB,0)))=1
Begin DoDot:1
+8 NEW OUT
SET LEXFI=80.1
SET LEXOUT=$$ONE
SET X=-1
if $EXTRACT(LEXOUT,1)["^"
SET X="^"
if +LEXOUT>0
SET X=$GET(LEXOUT)
End DoDot:1
QUIT X
+9 IF +($GET(^TMP("LEXQIL",$JOB,0)))>1
Begin DoDot:1
+10 NEW OUT
SET LEXFI=80.1
SET LEXOUT=$$MUL
SET X=-1
if $EXTRACT(LEXOUT,1)["^"
SET X="^"
if +LEXOUT>0
SET X=$GET(LEXOUT)
End DoDot:1
QUIT X
+11 QUIT X
+12 ;
+13 ; Selections
ONE(X) ; One Entry Found
+1 if "^80^80.1^"'[("^"_$GET(LEXFI)_"^")
QUIT "^^"
if +($GET(LEXEXIT))>0
QUIT "^^"
+2 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEX,LEXC,LEXCT,LEXIEN,LEXTX,LEXX,Y
+3 SET LEXTX=$GET(^TMP("LEXQIL",$JOB,1))
SET LEXIEN=+LEXTX
SET LEXTX=$PIECE(LEXTX,U,2)
SET LEX(1)=LEXTX
DO PR^LEXU(.LEX,70)
+4 SET DIR("A",1)=" One code found"
SET DIR("A",2)=" "
SET DIR("A",3)=" "_$GET(LEX(1))
SET LEXC=3
KILL LEX(1)
if $ORDER(LEX(0))>0
DO PR^LEXU(.LEX,64)
+5 if $LENGTH($GET(LEX(1)))
SET LEXC=LEXC+1
SET DIR("A",LEXC)=" "_$GET(LEX(1))
+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"
if '$DATA(LEXQUIET)
WRITE !
+8 SET (X,Y)=""
if '$DATA(LEXQUIET)
DO ^DIR
if $DATA(LEXQUIET)
SET Y=1
if X["^^"!($DATA(DTOUT))
SET LEXEXIT=1
SET X="^^"
+9 IF X["^^"!(+($GET(LEXEXIT))>0)!($DATA(DIROUT))
KILL ^TMP("LEXQIL",$JOB)
SET LEXEXIT=1
QUIT "^^"
+10 SET X=-1
if +Y'>0
SET X=-1
if +Y>0
SET X=$$X(+($GET(LEXIEN)),+($GET(LEXFI)))
+11 QUIT X
MUL(X) ; Multiple Entries Found
+1 if "^80^80.1^"'[("^"_$GET(LEXFI)_"^")
QUIT "^^"
if +($GET(LEXEXIT))>0
QUIT "^^"
+2 NEW LEXENT,LEXI,LEXIEN,LEXIT,LEXMAX,LEXSS,LEXSTR,LEXT1,LEXTTT,Y
+3 SET (LEXMAX,LEXI,LEXSS,LEXIT)=0
SET U="^"
SET LEXTTT=$GET(^TMP("LEXQIL",$JOB,0))
SET LEXSS=0
+4 if +LEXTTT=0
GOTO MULQ
WRITE !
if +LEXTTT>1
WRITE !," ",LEXTTT," matches found"
+5 FOR LEXI=1:1:LEXTTT
if ((LEXSS>0)&(LEXSS<LEXI+1))
QUIT
if LEXIT
QUIT
Begin DoDot:1
+6 SET LEXENT=$GET(^TMP("LEXQIL",$JOB,LEXI))
+7 SET LEXIEN=$PIECE(LEXENT,U,1)
if '$LENGTH($PIECE(LEXENT,"^",2))
QUIT
SET LEXMAX=LEXI
if LEXI#5=1
WRITE !
DO MULW
+8 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
+9 IF LEXI#5'=0
IF +LEXSS=0
WRITE !
SET LEXSS=$$MULS(LEXMAX,LEXI)
if LEXSS["^"
SET LEXIT=1
+10 GOTO MULQ
+11 QUIT X
MULW ; Write Multiple
+1 NEW LEX,LEXIEN,LEXJ,LEXK,LEXTX
SET LEXK=+($GET(LEXI))
NEW LEXI
SET LEXTX=$PIECE(LEXENT,U,2)
SET LEXIEN=+LEXENT
+2 KILL LEX
SET LEX(1)=LEXTX
DO PR^LEXU(.LEX,70)
WRITE !,$JUSTIFY(LEXK,5),". ",$GET(LEX(1))
KILL LEX(1)
if $ORDER(LEX(0))>0
DO PR^LEXU(.LEX,59)
+3 FOR LEXJ=1:1:5
SET LEXTX=$GET(LEX(LEXJ))
if $LENGTH(LEXTX)
WRITE !," ",LEXTX
+4 QUIT
MULS(X,Y) ; Select Multiple
+1 if +($GET(LEXEXIT))>0
QUIT "^^"
+2 NEW DIR,DIRB,DIROUT,DIRUT,DTOUT,DUOUT,LEXI,LEXLAST,LEXMAX,LEXS,LEXTQ,Y
+3 SET (LEXS,LEXMAX)=+($GET(X))
SET (LEXI,LEXLAST)=+($GET(Y))
if LEXMAX=0
QUIT -1
+4 if +($ORDER(^TMP("LEXQIL",$JOB,+LEXLAST)))>0
SET DIR("A")=" Press <RETURN> for more, '^' to exit, or Select 1-"_LEXMAX_": "
+5 if +($ORDER(^TMP("LEXQIL",$JOB,+LEXLAST)))'>0
SET DIR("A")=" Select 1-"_LEXMAX_": "
+6 SET LEXTQ=" Answer must be from 1 to "_LEXMAX_", or <Return> to continue"
+7 SET DIR("PRE")="S:X[""?"" X=""??"""
SET (DIR("?"),DIR("??"))="^D MULSH^LEXQL"
+8 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("LEXQIL",$JOB)
QUIT "^^"
+9 SET LEXS=+Y
if $DATA(DTOUT)!(X[U)
SET LEXS=U
KILL DIR
+10 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 "^80^80.1^"'[("^"_$GET(LEXFI)_"^")
QUIT X
IF +LEXSS>0
Begin DoDot:1
+2 NEW LEXIEN
SET LEXIEN=+($GET(^TMP("LEXQIL",$JOB,+LEXSS)))
if +LEXIEN>0
SET X=$$X(+($GET(LEXIEN)),+($GET(LEXFI)))
End DoDot:1
+3 QUIT X
+4 ;
+5 ; Lookups
BC(X,Y) ; Lookup by Code
+1 KILL ^TMP("LEXQIL",$JOB)
NEW LEXFI,LEXCTL,LEXIEN,LEXINP,LEXORD,LEXRT,LEXSY
SET LEXFI=+($GET(Y))
if "^80^80.1^"'[("^"_$GET(LEXFI)_"^")
QUIT
+2 SET LEXINP=$GET(X)
if '$LENGTH(X)
QUIT
SET LEXRT=$$ROOT^ICDEX(LEXFI)
+3 SET LEXORD=$EXTRACT(LEXINP,1,($LENGTH(LEXINP)-1))_$CHAR($ASCII($EXTRACT(LEXINP,$LENGTH(LEXINP)))-1)_"~"
SET LEXCTL=LEXINP
+4 FOR
SET LEXORD=$ORDER(@(LEXRT_"""BA"","""_LEXORD_""")"))
if '$LENGTH(LEXORD)
QUIT
if LEXORD'[LEXCTL
QUIT
Begin DoDot:1
+5 NEW LEXIEN
SET LEXIEN=0
SET LEXTMP=LEXRT_"""BA"","""_LEXORD_""","_LEXIEN_")"
+6 FOR
SET LEXIEN=$ORDER(@(LEXRT_"""BA"","""_LEXORD_""","_LEXIEN_")"))
if +LEXIEN'>0
QUIT
Begin DoDot:2
+7 IF +LEXIEN>0&($DATA(@(LEXRT_+LEXIEN_",0)")))
Begin DoDot:3
+8 NEW LEXCODE,LEXCOM,LEXCT,LEXEFF,LEXHIS,LEXLAS,LEXSPC,LEXSR,LEXSTA,LEXSTR,LEXTD,LEXTXT,LEXTY
SET LEXTD=$$DT^XLFDT
+9 SET LEXCODE=$PIECE($GET(@(LEXRT_LEXIEN_",0)")),"^",1)
SET LEXSR=$PIECE($GET(@(LEXRT_LEXIEN_",1)")),"^",1)
+10 if "^1^30^"[("^"_LEXSR_"^")
SET LEXTY="Diagnosis"
if "^2^31^"[("^"_LEXSR_"^")
SET LEXTY="Procedure"
+11 SET LEXEFF=$ORDER(@(LEXRT_LEXIEN_",66,""B"","_(LEXTD+.0001)_")"),-1)
+12 SET LEXHIS=0
if LEXEFF?7N
SET LEXHIS=$ORDER(@(LEXRT_LEXIEN_",66,""B"","_+LEXEFF_","" "")"),-1)
+13 SET LEXSTA=0
if LEXHIS>0
SET LEXSTA=$PIECE($GET(@(LEXRT_LEXIEN_",66,"_+LEXHIS_",0)")),"^",2)
+14 SET LEXLAS=$ORDER(@(LEXRT_LEXIEN_",66,""B"","" "")"),-1)
+15 SET LEXHIS=$ORDER(@(LEXRT_LEXIEN_",68,""B"","" "")"),-1)
+16 if LEXHIS?7N
SET LEXHIS=$ORDER(@(LEXRT_LEXIEN_",68,""B"","_+LEXHIS_","" "")"),-1)
+17 SET LEXTXT=""
if +LEXHIS>0
SET LEXTXT=$PIECE($GET(@(LEXRT_LEXIEN_",68,"_+LEXHIS_",1)")),"^",1)
+18 if LEXEFF=""&(LEXLAS?7N)
SET LEXCOM="Pending"
+19 if LEXEFF?7N&(+LEXSTA'>0)
SET LEXCOM="Inactive"
+20 if LEXSR'>29&($LENGTH($GET(LEXCOM)))
SET LEXCOM=$GET(LEXCOM)_", ICD-9"
+21 if LEXSR>29&($LENGTH($GET(LEXCOM)))
SET LEXCOM=$GET(LEXCOM)_", ICD-10"
+22 if $LENGTH($GET(LEXTY))&($LENGTH($GET(LEXCOM)))
SET LEXCOM=LEXCOM_" "_LEXTY
+23 SET LEXSPC=$SELECT(LEXFI=80:$JUSTIFY(" ",(11-$LENGTH($GET(LEXCODE)))),1:$JUSTIFY(" ",(10-$LENGTH($GET(LEXCODE)))))
+24 SET LEXSTR=$GET(LEXCODE)_LEXSPC_LEXTXT
if $LENGTH($GET(LEXCOM))
SET LEXSTR=LEXSTR_" ("_$GET(LEXCOM)_")"
+25 IF $DATA(LEXQUIET)
IF $LENGTH($GET(LEXDIRB))
Begin DoDot:4
+26 IF $GET(LEXDIRB)=LEXCODE
SET ^TMP("LEXQIL",$JOB,0)=1
SET ^TMP("LEXQIL",$JOB,1)=(LEXIEN_"^"_LEXSTR)
End DoDot:4
QUIT
+27 SET LEXCT=$ORDER(^TMP("LEXQIL",$JOB," "),-1)+1
+28 SET ^TMP("LEXQIL",$JOB,0)=LEXCT
+29 SET ^TMP("LEXQIL",$JOB,LEXCT)=(LEXIEN_"^"_LEXSTR)
End DoDot:3
End DoDot:2
End DoDot:1
+30 QUIT
BT(X,Y) ; Lookup by Text
+1 NEW LEXFI,LEXINP,LEXRT
SET LEXINP=$GET(X)
if '$LENGTH(X)
QUIT
SET LEXFI=+($GET(Y))
if "^80^80.1^"'[("^"_LEXFI_"^")
QUIT
SET LEXRT=$$ROOT^ICDEX(LEXFI)
DO BLD(LEXINP,LEXFI)
+2 QUIT
BLD(X,Y) ; Build Selection Array
+1 KILL ^TMP("LEXQIL",$JOB)
if '$LENGTH($GET(X))!('$LENGTH($GET(Y)))
QUIT "^^"
NEW LEXFI,LEXINP,LEXRT,LEXSY,LEXTOK
KILL LEXTOK
+2 SET LEXINP=$$UP^XLFSTR($GET(X))
SET LEXFI=+($GET(Y))
SET LEXRT=$$ROOT^ICDEX(LEXFI)
DO PAR(LEXINP,LEXFI,.LEXTOK)
DO GET(LEXFI,.LEXTOK)
+3 QUIT
PAR(X,Y,LEX) ; Parse text into tokens
+1 NEW LEXFI,LEXI,LEXINP,LEXRT,LEXSY,LEXTK,LEXTMP
SET LEXINP=$GET(X)
SET LEXFI=+($GET(Y))
SET LEXRT=$$ROOT^ICDEX(LEXFI)
SET LEXSY=""
KILL LEX
+2 if '$LENGTH(LEXINP)
QUIT
if '$DATA(LEXRT)
QUIT
DO TOKEN^ICDEX($GET(LEXINP),$GET(LEXRT),$GET(LEXSY),.LEXTMP)
+3 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXTMP(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+4 NEW LEXTK
SET LEXTK=$GET(LEXTMP(LEXI))
if '$LENGTH(LEXTK)
QUIT
if '$DATA(@(LEXRT_"""D"","""_LEXTK_""")"))
QUIT
+5 SET LEX(0)=+($GET(LEX(0)))+1
SET LEX(+($GET(LEX(0))))=LEXTK
End DoDot:1
+6 KILL LEXTMP
+7 QUIT
GET(X,LEX) ; Get Entries
+1 NEW LEXFI,LEXRT,LEXORD,LEXORG,LEXIEN,LEXTD
SET LEXFI=+($GET(X))
SET LEXRT=$$ROOT^ICDEX(LEXFI)
SET LEXORG=$GET(LEX(1))
if '$LENGTH(LEXORG)
QUIT
SET LEXTD=$$DT^XLFDT
+2 SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(@(LEXRT_"""D"","""_LEXORG_""","_+LEXIEN_")"))
if +LEXIEN'>0
QUIT
Begin DoDot:1
+3 NEW LEXOK,LEXI
SET LEXOK=1
SET LEXI=1
FOR
SET LEXI=$ORDER(LEX(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+4 NEW LEXORD
SET LEXORD=$GET(LEX(LEXI))
IF '$DATA(@(LEXRT_"""D"","""_LEXORD_""","_+LEXIEN_")"))
SET LEXOK=0
QUIT
End DoDot:2
if 'LEXOK
QUIT
+5 IF LEXOK
Begin DoDot:2
+6 NEW LEXCODE,LEXCOM,LEXEFF,LEXHIS,LEXLAS,LEXSPC,LEXSR,LEXSTA,LEXSTR,LEXTXT,LEXTY
+7 SET LEXCODE=$PIECE($GET(@(LEXRT_LEXIEN_",0)")),"^",1)
+8 SET LEXSR=$PIECE($GET(@(LEXRT_LEXIEN_",1)")),"^",1)
+9 if "^1^30^"[("^"_LEXSR_"^")
SET LEXTY="Diagnosis"
+10 if "^2^31^"[("^"_LEXSR_"^")
SET LEXTY="Procedure"
+11 SET LEXEFF=$ORDER(@(LEXRT_LEXIEN_",66,""B"","_(LEXTD+.0001)_")"),-1)
+12 SET LEXHIS=0
if LEXEFF?7N
SET LEXHIS=$ORDER(@(LEXRT_LEXIEN_",66,""B"","_+LEXEFF_","" "")"),-1)
+13 SET LEXSTA=0
if LEXHIS>0
SET LEXSTA=$PIECE($GET(@(LEXRT_LEXIEN_",66,"_+LEXHIS_",0)")),"^",2)
+14 SET LEXLAS=$ORDER(@(LEXRT_LEXIEN_",66,""B"","" "")"),-1)
+15 SET LEXHIS=$ORDER(@(LEXRT_LEXIEN_",68,""B"","" "")"),-1)
+16 if LEXHIS?7N
SET LEXHIS=$ORDER(@(LEXRT_LEXIEN_",68,""B"","_+LEXHIS_","" "")"),-1)
+17 SET LEXTXT=""
if +LEXHIS>0
SET LEXTXT=$PIECE($GET(@(LEXRT_LEXIEN_",68,"_+LEXHIS_",1)")),"^",1)
+18 if LEXEFF=""&(LEXLAS?7N)
SET LEXCOM="Pending"
+19 if LEXEFF?7N&(+LEXSTA'>0)
SET LEXCOM="Inactive"
+20 if LEXSR'>29&($LENGTH($GET(LEXCOM)))
SET LEXCOM=$GET(LEXCOM)_", ICD-9"
+21 if LEXSR>29&($LENGTH($GET(LEXCOM)))
SET LEXCOM=$GET(LEXCOM)_", ICD-10"
+22 if $LENGTH($GET(LEXTY))&($LENGTH($GET(LEXCOM)))
SET LEXCOM=LEXCOM_" "_LEXTY
+23 SET LEXSPC=$SELECT(LEXFI=80:$JUSTIFY(" ",(11-$LENGTH($GET(LEXCODE)))),1:$JUSTIFY(" ",(10-$LENGTH($GET(LEXCODE)))))
+24 SET LEXSTR=$GET(LEXCODE)_LEXSPC_LEXTXT
if $LENGTH($GET(LEXCOM))
SET LEXSTR=LEXSTR_" ("_$GET(LEXCOM)_")"
+25 SET ^TMP("LEXQIL",$JOB,"ORD",(LEXCODE_" "))=(LEXIEN_"^"_LEXSTR)
End DoDot:2
End DoDot:1
+26 SET LEXORD=""
FOR
SET LEXORD=$ORDER(^TMP("LEXQIL",$JOB,"ORD",LEXORD))
if '$LENGTH(LEXORD)
QUIT
Begin DoDot:1
+27 NEW LEXCT,LEXVAL
SET LEXVAL=$GET(^TMP("LEXQIL",$JOB,"ORD",LEXORD))
if +LEXVAL'>0
QUIT
if '$LENGTH($PIECE(LEXVAL,"^",2))
QUIT
+28 SET LEXCT=$ORDER(^TMP("LEXQIL",$JOB," "),-1)+1
SET ^TMP("LEXQIL",$JOB,LEXCT)=LEXVAL
SET ^TMP("LEXQIL",$JOB,0)=LEXCT
End DoDot:1
+29 KILL ^TMP("LEXQIL",$JOB,"ORD")
+30 QUIT
+31 ;
+32 ; Miscellaneous
INP(X) ; Input
+1 if "^80^80.1^"'[("^"_$GET(LEXFI)_"^")
QUIT "^^"
if +($GET(LEXEXIT))>0
QUIT "^^"
+2 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXTD,Y,LEX,LEXIT
if LEXFI=80
SET DIR("A")=" Enter a Diagnosis Code or Term: "
+3 if LEXFI=80.1
SET DIR("A")=" Enter a Procedure Code or Term: "
if '$LENGTH($GET(DIR("A")))
QUIT "^^"
SET DIR(0)="FAO^1:70"
+4 SET DIR("PRE")="S:X[""?"" X=""??"""
SET (DIR("?"),DIR("??"))="^D INPH^LEXQIL"
WRITE !
DO ^DIR
+5 if X="^^"!($DATA(DTOUT))!(+($GET(LEXEXIT)))
QUIT "^^"
if $DATA(DIROUT)!($DATA(DIRUT))!($DATA(DTOUT))!($DATA(DUOUT))
SET X="^"
if $EXTRACT(X,1)="^"
QUIT X
+6 SET X="^"
if $LENGTH(Y)
SET X=$$UP^XLFSTR(Y)
+7 QUIT X
INPH ; Input Help
+1 IF +($GET(LEXFI))=80
Begin DoDot:1
+2 WRITE !," Enter an ICD Diagnosis code or a term, or '^' to exit",!
End DoDot:1
QUIT
+3 IF +($GET(LEXFI))=80.1
Begin DoDot:1
+4 WRITE !," Enter an ICD Procedure code or a term, or '^' to exit",!
End DoDot:1
QUIT
+5 WRITE !," Enter an ICD code or a term, or '^' to exit",!
+6 QUIT
X(X,Y) ; Get X Return Value
+1 NEW LEXIEN,LEXFI
SET LEXIEN=+X
SET X=-1
SET LEXFI=$GET(Y)
if "^80^80.1^"'[("^"_LEXFI_"^")
QUIT -1
IF +LEXIEN>0
Begin DoDot:1
+2 NEW LEXFD,LEXSO,LEXSY,LEXDX,LEXTX,LEXTD
SET LEXFD=$$FD
SET LEXTD=$$DT^XLFDT
SET LEXSO=$$CODEC^ICDEX(LEXFI,LEXIEN)
+3 SET LEXSY=$$CSI^ICDEX(LEXFI,LEXIEN)
+4 IF LEXFI=80
SET LEXDX=$$ICDDX^ICDEX(LEXSO,LEXFD,LEXSY,"E")
SET LEXTX=$PIECE(LEXDX,"^",4)
+5 IF LEXFI=80.1
SET LEXDX=$$ICDOP^ICDEX(LEXSO,LEXFD,LEXSY,"E")
SET LEXTX=$PIECE(LEXDX,"^",5)
+6 SET X=LEXIEN_"^"_LEXSO_"^"_LEXTX
End DoDot:1
+7 SET X=$$UP^XLFSTR(X)
+8 QUIT X
FD(X) ; Get Future Date
+1 SET X=$$DT^XLFDT
SET X=($EXTRACT(X,1,3)+1)_"1001"
NEW LEXEXIT
+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
