LEXA1 ;ISL/KER - Lexicon Look-up (Loud) ;05/23/2017
;;2.0;LEXICON UTILITY;**3,4,6,11,15,38,55,73,80,86,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^DISV( ICR 510
; ^TMP("LEXFND" SACC 2.3.2.5.1
; ^TMP("LEXHIT" SACC 2.3.2.5.1
; ^TMP("LEXSCH" SACC 2.3.2.5.1
;
; External References
; ^DIR ICR 10026
; $$DT^XLFDT ICR 10103
;
; Local Variables NEWed or KILLed by calling application
;
; DIC,DTOUT,DUOUT,LEXCAT,LEXQUIET,LEXSRC
;
EN ; Fileman Special Lookup
;
; ^LEXA1 is the Lexicon's special lookup routine
;
; ^DD(757.01,0,"DIC")=LEXA1
;
; Input All input variables are optional
;
; X User's input, if X does not exist the user
; will be prompted
;
; Fileman Variables used:
;
; DIC Global Root (default ^LEX(757.01,)
; DIC(0) DIC response string (default AEQM)
; DIC("A") Prompt (default "Enter Term/Concept:")
; DIC("B") Default lookup value
; DIC("S") Screen
; DIC("W") Output string
;
; Special Input Variables:
;
; LEXVDT Versioning Date - This is a date in
; Fileman format. If set it will force
; the lookup to be date sensitive,
; inactive and pending codes and terms
; will not display on the selection
; list.
;
; Developer Input Variables
;
; LEXIGN Ignore - This flag, if set will ignore
; deactivation flags.
;
; LEXDISP Display - Force overwrite of display default
; parameter.
;
; Output
;
; Fileman
;
; Y 2 piece string containing IEN and
; expression or -1 if not found
; or selection not made
;
; Y(0) If DIC(0) contains a Z this variable
; will be equal to the entire zero node
; of the entry that was selected
;
; Y(0,0) If DIC(0) contains a Z this variable
; will be equal to the external form of
; the .01 field of the entry that was
; selected
;
; Non-Fileman
;
; Y(1) This is the external form of the ICD-9
; diagnosis code when found
;
; Y(2) This is the external form of the ICD-9
; procedure code when found
;
; Y(30) This is the external form of the ICD-10
; diagnosis code when found
;
; Y(31) This is the external form of the ICD-10
; procedure code when found
;
; Y(81) This is the external form of the CPT-4
; or HCPCS code when found
;
I '$D(DIC(0))!($G(DIC(0))["A") K X
; Date Check
N LEXTD,LEXQ,LEXXVDT,LEXASKC S LEXXVDT=$S($G(LEXVDT)?7N:1,1:0) S LEXQ=0 D VDT^LEXU
;
; LEXSUB Specifies the vocabulary subset to use during the search.
; It is a three character mnemonic taken from file 757.2.
; The default is "WRD"
S:'$L($G(LEXSUB)) LEXSUB="WRD"
;
; LEXAP Specifies the application using the Lexicon. It is a pointer
; to file 757.2. The default is 1 (Lexicon)
S:'$L($G(LEXAP))&($L($G(^TMP("LEXSCH",$J,"APP",0)))) LEXAP=^TMP("LEXSCH",$J,"APP",0)
S:'$L($G(LEXAP)) LEXAP=1
;
; LEXLL Specifies the displayable list length that the user selects
; from. Default is 5.
S:'$L($G(LEXLL)) LEXLL=5
;
; LEXSRC Specifies the source of the vocabulary to use during the search.
; It is a pointer to file #757.14.
N LEXXSR S:$L($G(LEXSRC)) LEXXSR=$G(LEXSRC)
;
; LEXCAT Specifies the source category of the vocabulary to use during
; the search. It is a pointer to file #757.13.
N LEXXCT S:$L($G(LEXCAT)) LEXXCT=$G(LEXCAT)
;
; Check the DIC variables new LEXUR "user response"
N LEXDICA,LEXDICB,LEXO,XTLKGBL,XTLKHLP,XTLKKSCH,XTLKSAY D CHK N LEXUR
;
; Save the value of X if "Ask" is not specified in DIC(0)
I DIC(0)'["A",$L($G(X)) S LEXSAVE=X K X
;
; Save the prompt
I $L($G(DIC("A"))) S LEXDICA=DIC("A")
;
; Continue to lookup until the dialog with the application
; ends. If there is nothing to lookup (X="") or an uparrow
; is detected, the Lexicon shuts down killing LEX.
;
S LEXASKC=0 F D LK Q:'$D(LEX)!($D(LEX("SEL")))
G EXIT
LK ; Start Look-up
; X not provided
K DTOUT,DUOUT S LEXASKC=+($G(LEXASKC))+1 W:+($G(LEXASKC))>1 !
D:'$D(LEXSAVE) ASK I $D(DTOUT)!($D(DUOUT)) K LEX Q
; X provided
S:$D(LEXSAVE) X=LEXSAVE K LEXSAVE
; X was null with a default provided
S:$D(DIC("B"))&($G(X)="") X=DIC("B")
; Lookup X - LOOK(LEXX,LEXAP,LEXLL,LEXSUB,LEXVDT,LEXXSR,LEXXCT)
I '$L($G(X)) K LEX Q
D LOOK^LEXA(X,$G(LEXAP),$G(LEXLL),,$G(LEXVDT),$G(LEXXSR),$G(LEXXCT))
K DIC("B")
;
NOTFND ; If X was not found
;
; Write "??"
;
; Calling application uses Unresolved Narratives
; Prompt to "accept or reject" the narrative
;
; Calling application does not use Unresolved Narratives
; Display help, Re-prompt and Continue search
;
I '$D(LEX("LIST")),+($G(LEX))=0,$L(X),X'["^",$E(X,1)'=" " D K LEX S LEX=0 Q
. K DIC("B"),LEX("SEL")
. I +($G(^TMP("LEXSCH",$J,"UNR",0)))=0 I +($G(X))'=757.01 W " ??" D:$D(LEX("HLP")) DH^LEXA3 W ! Q
. I +($G(^TMP("LEXSCH",$J,"UNR",0)))=1 W " ??" D EN^LEXA4 W !
FOUND ; If X was found
;
; Begin user selection. Continue to display the list
; until the dialog with the user is terminated. The
; dialog is considered to be terminated if:
;
; The selection list does not exist '$D(LEX("LIST"))
; The user has made a selection $D(LEX("SEL")
;
I $D(LEX("LIST")) F Q:+($G(LEX))=0 D SELECT^LEXA2
Q:$D(LEX("SEL"))
I '$L($G(LEX)) K LEX Q
I $L($G(LEX)),'$D(LEX("SEL")),$D(^TMP("LEXSCH",$J)) D
. D EN^LEXA4 S:'$D(LEX("SEL")) LEX=0
Q
EXIT ; Set/Kill variables Y, Y(0,0)
S:$L($G(LEX("NAR"))) X=$G(LEX("NAR"))
S:$L($G(LEXDICA)) DIC("A")=LEXDICA S:$L($G(LEXDICB)) DIC("B")=LEXDICB K Y K:+($G(LEXXVDT))'>0 LEXVDT
I '$D(LEX("SEL","EXP",1)) K Y S Y=-1 D CL Q
D:$D(LEX("SEL","SRC")) Y1
I $D(LEX("SEL","EXP",1)) S Y=LEX("SEL","EXP",1) D
. D ECHO,SSBR I DIC(0)["Z" D
. . S Y(0)=^LEX(757.01,+(LEX("SEL","EXP",1)),0)
. . S Y(0,0)=$P(^LEX(757.01,+(LEX("SEL","EXP",1)),0),"^",1)
D CL
Q
CL ; Clear Variables
K LEX,LEXSUB,LEXAP,LEXLL D CLR
Q
CLR ; Clear ^TMP Global
K ^TMP("LEXSCH",$J),^TMP("LEXHIT",$J),^TMP("LEXFND",$J)
Q
Y1 ; Y(n)
; ICD-9 Diagnosis in Y(1)
; ICD-9 Procedure in Y(2)
; CPT Procedure in Y(3)
; HCPCS Procedure in Y(4)
; ICD-10 Diagnosis in Y(30)
; ICD-10 Procedure in Y(31)
N LEXCTL,LEXSR S LEXCTL="^1^2^3^4^30^31^",LEXSR=0 F S LEXSR=$O(LEX("SEL","SRC",LEXSR)) Q:+LEXSR'>0 D
. N LEXNOM,LEXSYS,LEXC S LEXNOM=$P($G(LEX("SEL","SRC",LEXSR)),"^",1) Q:'$L(LEXNOM)
. S LEXSYS=$O(^LEX(757.03,"C",LEXNOM,0)) Q:LEXSYS'>0 Q:LEXCTL'[("^"_LEXSYS_"^")
. S LEXC=$P($G(LEX("SEL","SRC",LEXSR)),"^",2) Q:'$L(LEXC)
. S:'$L($G(Y(+LEXSYS))) Y(+LEXSYS)=LEXC
N IOINHI,IOINORM
Q
ECHO ; Echo codes
N LEXCT,LEXLC,LEXLDR,LEXSY,LEXB,LEXN S LEXB=$G(IOINHI),LEXN=$G(IOINORM)
S LEXLC=0,LEXLDR=" >>> " I '$D(LEXQUIET) F LEXSY=1,2,30,31 D
. N LEXI S (LEXCT,LEXI)=0 F S LEXI=$O(LEX("SEL","VAS","I",LEXSY,LEXI)) Q:+LEXI'>0 D
. . N LEXD,LEXC,LEXS,LEXT S LEXD=$G(LEX("SEL","VAS",LEXI)),LEXC=$P(LEXD,"^",3),LEXS=$P(LEXD,"^",6)
. . Q:'$L(LEXD) Q:'$L(LEXS) S LEXT=LEXLDR_LEXS_" Code:"
. . S LEXT=LEXT_$J(" ",(23-$L(LEXT)))_$G(LEXB)_LEXC_$G(LEXN)
. . S LEXCT=LEXCT+1,LEXLC=LEXLC+1 S:LEXLC>1 LEXLDR=" "
. . Q:LEXCT>1 W:LEXCT=1 ! W !,LEXT
Q
ASK ; Get user input
N DIR,DIRUT,DIROUT S:$L($G(LEXDICA)) DIC("A")=LEXDICA
S DIR("A")=DIC("A") W:'$L($G(X))&('$L($G(LEXDICB))) !
I '$L($G(X)),$L($G(LEXDICB)) S DIR("B")=LEXDICB
S DIR("?")=" "_$$SQ^LEXHLP
S DIR("??")="^D INPHLP^LEXA1",DIR("?")=$G(DIR("??"))
N Y S DIR(0)="FAO^0:245" K X
D ^DIR
K DIC("B") D:$E(X,1)=" " RSBR
W:$E(X,1)'=" " !
F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
W:$D(DTOUT) !,"Try later.",!
I $D(DTOUT)!(X="^") S X=""
S:X[U DUOUT=1 K DIRUT,DIROUT Q
INPHLP ; Look-up help
N IMP,CUR,CUT,FLG,LEXD,LEXCAT,LEXQUIET,LEXSRC S IMP=$$IMPDATE^LEXU(30)
S CUR=$G(LEXVDT) S:CUR'?7N CUR=$$DT^XLFDT S FLG=$S(CUR<IMP:0,1:1)
S LEXD=$G(^TMP("LEXSCH",$J,"FIL",0))
I $G(X)["??",$L(LEXD),LEXD["LEXU(Y,""DS4""," K LEX("HLP") D Q
. D QMH^LEXAR3(X) N LEXI S LEXI=0
. F S LEXI=$O(LEX("HLP",LEXI)) Q:+LEXI'>0 W !,$G(LEX("HLP",LEXI))
. K LEX("HLP")
W !," Enter a ""free text"" term. Best results occur using one to "
W !," three full or partial words without a suffix"
W:$G(X)'["??" "."
W:$G(X)["??" " (i.e., ""DIABETES"","
W:$G(X)["??" !," ""DIAB MELL"",""DIAB MELL "_$S(FLG:"NEO",1:"INSUL")_")"
W !," or "
W !," Enter a classification code (ICD/DSM/CPT etc) to find the single "
W !," term associated with the code."
W:$G(X)["??" " Example, a lookup of code "_$S(FLG:"P70.2",1:"239.0")_" "
W:$G(X)["??" !," returns one and only one term, that is the preferred term for"
W:$G(X)["??" !," the code "_$S(FLG:"P70.2",1:"239.0")_", "
W:$G(X)["??"&(FLG) """Neonatal Diabetes Mellitus"""
W:$G(X)["??"&('FLG) """Neoplasm of unspecified nature",!," of digestive system"""
Q:FLG
W !," or "
W !," Enter a classification code (ICD/DSM/CPT etc) followed by a plus"
W !," sign (+) to retrieve all terms associated with the code."
W:$G(X)["??" " Example,"
W:$G(X)["??" !," a lookup of 239.0+ returns all terms that are linked to the "
W:$G(X)["??" !," code 239.0."
Q
CHK ; Check Fileman look-up variables
K DIC("DR"),DIC("P"),DIC("V"),DLAYGO,DINUM
S:$L($G(X)) LEXSAVE=X S:$L($G(DIC("B"))) LEXDICB=DIC("B") K DIC("B")
I $L($G(DIC(0))) D
. F Q:DIC(0)'["L" S DIC(0)=$P(DIC(0),"L",1)_$P(DIC(0),"L",2)
. F Q:DIC(0)'["I" S DIC(0)=$P(DIC(0),"I",1)_$P(DIC(0),"I",2)
S:'$L($G(DIC(0))) DIC(0)="QEAMF" S:'$L($G(DIC)) DIC="^LEX(757.01,"
S:DIC(0)'["F" DIC(0)=DIC(0)_"F" S:'$L($G(DIC("A"))) DIC("A")="Enter Term/Concept: "
S LEXDICA=DIC("A")
Q
SSBR ; Store data for Space Bar Return
Q:'$L($G(DUZ)) Q:+($G(DUZ))=0 Q:'$L($G(DIC)) Q:$G(DIC)'["757.01,"
Q:$G(DIC(0))'["F" Q:+($G(Y))'>2 Q:$E($G(X),1)=" " S ^DISV(DUZ,DIC)=+($G(Y))
Q
RSBR ; Retrieve onSpace Bar Return
Q:'$L($G(DUZ)) Q:$G(DIC)'="^LEX(757.01," Q:$G(DIC(0))'["F"
Q:$E($G(X),1)'=" " S:+($G(^DISV(DUZ,DIC)))>2 X=@(DIC_+($G(^DISV(DUZ,DIC)))_",0)")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXA1 10772 printed Apr 09, 2024@21:13:33 Page 2
LEXA1 ;ISL/KER - Lexicon Look-up (Loud) ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**3,4,6,11,15,38,55,73,80,86,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^DISV( ICR 510
+5 ; ^TMP("LEXFND" SACC 2.3.2.5.1
+6 ; ^TMP("LEXHIT" SACC 2.3.2.5.1
+7 ; ^TMP("LEXSCH" SACC 2.3.2.5.1
+8 ;
+9 ; External References
+10 ; ^DIR ICR 10026
+11 ; $$DT^XLFDT ICR 10103
+12 ;
+13 ; Local Variables NEWed or KILLed by calling application
+14 ;
+15 ; DIC,DTOUT,DUOUT,LEXCAT,LEXQUIET,LEXSRC
+16 ;
EN ; Fileman Special Lookup
+1 ;
+2 ; ^LEXA1 is the Lexicon's special lookup routine
+3 ;
+4 ; ^DD(757.01,0,"DIC")=LEXA1
+5 ;
+6 ; Input All input variables are optional
+7 ;
+8 ; X User's input, if X does not exist the user
+9 ; will be prompted
+10 ;
+11 ; Fileman Variables used:
+12 ;
+13 ; DIC Global Root (default ^LEX(757.01,)
+14 ; DIC(0) DIC response string (default AEQM)
+15 ; DIC("A") Prompt (default "Enter Term/Concept:")
+16 ; DIC("B") Default lookup value
+17 ; DIC("S") Screen
+18 ; DIC("W") Output string
+19 ;
+20 ; Special Input Variables:
+21 ;
+22 ; LEXVDT Versioning Date - This is a date in
+23 ; Fileman format. If set it will force
+24 ; the lookup to be date sensitive,
+25 ; inactive and pending codes and terms
+26 ; will not display on the selection
+27 ; list.
+28 ;
+29 ; Developer Input Variables
+30 ;
+31 ; LEXIGN Ignore - This flag, if set will ignore
+32 ; deactivation flags.
+33 ;
+34 ; LEXDISP Display - Force overwrite of display default
+35 ; parameter.
+36 ;
+37 ; Output
+38 ;
+39 ; Fileman
+40 ;
+41 ; Y 2 piece string containing IEN and
+42 ; expression or -1 if not found
+43 ; or selection not made
+44 ;
+45 ; Y(0) If DIC(0) contains a Z this variable
+46 ; will be equal to the entire zero node
+47 ; of the entry that was selected
+48 ;
+49 ; Y(0,0) If DIC(0) contains a Z this variable
+50 ; will be equal to the external form of
+51 ; the .01 field of the entry that was
+52 ; selected
+53 ;
+54 ; Non-Fileman
+55 ;
+56 ; Y(1) This is the external form of the ICD-9
+57 ; diagnosis code when found
+58 ;
+59 ; Y(2) This is the external form of the ICD-9
+60 ; procedure code when found
+61 ;
+62 ; Y(30) This is the external form of the ICD-10
+63 ; diagnosis code when found
+64 ;
+65 ; Y(31) This is the external form of the ICD-10
+66 ; procedure code when found
+67 ;
+68 ; Y(81) This is the external form of the CPT-4
+69 ; or HCPCS code when found
+70 ;
+71 IF '$DATA(DIC(0))!($GET(DIC(0))["A")
KILL X
+72 ; Date Check
+73 NEW LEXTD,LEXQ,LEXXVDT,LEXASKC
SET LEXXVDT=$SELECT($GET(LEXVDT)?7N:1,1:0)
SET LEXQ=0
DO VDT^LEXU
+74 ;
+75 ; LEXSUB Specifies the vocabulary subset to use during the search.
+76 ; It is a three character mnemonic taken from file 757.2.
+77 ; The default is "WRD"
+78 if '$LENGTH($GET(LEXSUB))
SET LEXSUB="WRD"
+79 ;
+80 ; LEXAP Specifies the application using the Lexicon. It is a pointer
+81 ; to file 757.2. The default is 1 (Lexicon)
+82 if '$LENGTH($GET(LEXAP))&($LENGTH($GET(^TMP("LEXSCH",$JOB,"APP",0))))
SET LEXAP=^TMP("LEXSCH",$JOB,"APP",0)
+83 if '$LENGTH($GET(LEXAP))
SET LEXAP=1
+84 ;
+85 ; LEXLL Specifies the displayable list length that the user selects
+86 ; from. Default is 5.
+87 if '$LENGTH($GET(LEXLL))
SET LEXLL=5
+88 ;
+89 ; LEXSRC Specifies the source of the vocabulary to use during the search.
+90 ; It is a pointer to file #757.14.
+91 NEW LEXXSR
if $LENGTH($GET(LEXSRC))
SET LEXXSR=$GET(LEXSRC)
+92 ;
+93 ; LEXCAT Specifies the source category of the vocabulary to use during
+94 ; the search. It is a pointer to file #757.13.
+95 NEW LEXXCT
if $LENGTH($GET(LEXCAT))
SET LEXXCT=$GET(LEXCAT)
+96 ;
+97 ; Check the DIC variables new LEXUR "user response"
+98 NEW LEXDICA,LEXDICB,LEXO,XTLKGBL,XTLKHLP,XTLKKSCH,XTLKSAY
DO CHK
NEW LEXUR
+99 ;
+100 ; Save the value of X if "Ask" is not specified in DIC(0)
+101 IF DIC(0)'["A"
IF $LENGTH($GET(X))
SET LEXSAVE=X
KILL X
+102 ;
+103 ; Save the prompt
+104 IF $LENGTH($GET(DIC("A")))
SET LEXDICA=DIC("A")
+105 ;
+106 ; Continue to lookup until the dialog with the application
+107 ; ends. If there is nothing to lookup (X="") or an uparrow
+108 ; is detected, the Lexicon shuts down killing LEX.
+109 ;
+110 SET LEXASKC=0
FOR
DO LK
if '$DATA(LEX)!($DATA(LEX("SEL")))
QUIT
+111 GOTO EXIT
LK ; Start Look-up
+1 ; X not provided
+2 KILL DTOUT,DUOUT
SET LEXASKC=+($GET(LEXASKC))+1
if +($GET(LEXASKC))>1
WRITE !
+3 if '$DATA(LEXSAVE)
DO ASK
IF $DATA(DTOUT)!($DATA(DUOUT))
KILL LEX
QUIT
+4 ; X provided
+5 if $DATA(LEXSAVE)
SET X=LEXSAVE
KILL LEXSAVE
+6 ; X was null with a default provided
+7 if $DATA(DIC("B"))&($GET(X)="")
SET X=DIC("B")
+8 ; Lookup X - LOOK(LEXX,LEXAP,LEXLL,LEXSUB,LEXVDT,LEXXSR,LEXXCT)
+9 IF '$LENGTH($GET(X))
KILL LEX
QUIT
+10 DO LOOK^LEXA(X,$GET(LEXAP),$GET(LEXLL),,$GET(LEXVDT),$GET(LEXXSR),$GET(LEXXCT))
+11 KILL DIC("B")
+12 ;
NOTFND ; If X was not found
+1 ;
+2 ; Write "??"
+3 ;
+4 ; Calling application uses Unresolved Narratives
+5 ; Prompt to "accept or reject" the narrative
+6 ;
+7 ; Calling application does not use Unresolved Narratives
+8 ; Display help, Re-prompt and Continue search
+9 ;
+10 IF '$DATA(LEX("LIST"))
IF +($GET(LEX))=0
IF $LENGTH(X)
IF X'["^"
IF $EXTRACT(X,1)'=" "
Begin DoDot:1
+11 KILL DIC("B"),LEX("SEL")
+12 IF +($GET(^TMP("LEXSCH",$JOB,"UNR",0)))=0
IF +($GET(X))'=757.01
WRITE " ??"
if $DATA(LEX("HLP"))
DO DH^LEXA3
WRITE !
QUIT
+13 IF +($GET(^TMP("LEXSCH",$JOB,"UNR",0)))=1
WRITE " ??"
DO EN^LEXA4
WRITE !
End DoDot:1
KILL LEX
SET LEX=0
QUIT
FOUND ; If X was found
+1 ;
+2 ; Begin user selection. Continue to display the list
+3 ; until the dialog with the user is terminated. The
+4 ; dialog is considered to be terminated if:
+5 ;
+6 ; The selection list does not exist '$D(LEX("LIST"))
+7 ; The user has made a selection $D(LEX("SEL")
+8 ;
+9 IF $DATA(LEX("LIST"))
FOR
if +($GET(LEX))=0
QUIT
DO SELECT^LEXA2
+10 if $DATA(LEX("SEL"))
QUIT
+11 IF '$LENGTH($GET(LEX))
KILL LEX
QUIT
+12 IF $LENGTH($GET(LEX))
IF '$DATA(LEX("SEL"))
IF $DATA(^TMP("LEXSCH",$JOB))
Begin DoDot:1
+13 DO EN^LEXA4
if '$DATA(LEX("SEL"))
SET LEX=0
End DoDot:1
+14 QUIT
EXIT ; Set/Kill variables Y, Y(0,0)
+1 if $LENGTH($GET(LEX("NAR")))
SET X=$GET(LEX("NAR"))
+2 if $LENGTH($GET(LEXDICA))
SET DIC("A")=LEXDICA
if $LENGTH($GET(LEXDICB))
SET DIC("B")=LEXDICB
KILL Y
if +($GET(LEXXVDT))'>0
KILL LEXVDT
+3 IF '$DATA(LEX("SEL","EXP",1))
KILL Y
SET Y=-1
DO CL
QUIT
+4 if $DATA(LEX("SEL","SRC"))
DO Y1
+5 IF $DATA(LEX("SEL","EXP",1))
SET Y=LEX("SEL","EXP",1)
Begin DoDot:1
+6 DO ECHO
DO SSBR
IF DIC(0)["Z"
Begin DoDot:2
+7 SET Y(0)=^LEX(757.01,+(LEX("SEL","EXP",1)),0)
+8 SET Y(0,0)=$PIECE(^LEX(757.01,+(LEX("SEL","EXP",1)),0),"^",1)
End DoDot:2
End DoDot:1
+9 DO CL
+10 QUIT
CL ; Clear Variables
+1 KILL LEX,LEXSUB,LEXAP,LEXLL
DO CLR
+2 QUIT
CLR ; Clear ^TMP Global
+1 KILL ^TMP("LEXSCH",$JOB),^TMP("LEXHIT",$JOB),^TMP("LEXFND",$JOB)
+2 QUIT
Y1 ; Y(n)
+1 ; ICD-9 Diagnosis in Y(1)
+2 ; ICD-9 Procedure in Y(2)
+3 ; CPT Procedure in Y(3)
+4 ; HCPCS Procedure in Y(4)
+5 ; ICD-10 Diagnosis in Y(30)
+6 ; ICD-10 Procedure in Y(31)
+7 NEW LEXCTL,LEXSR
SET LEXCTL="^1^2^3^4^30^31^"
SET LEXSR=0
FOR
SET LEXSR=$ORDER(LEX("SEL","SRC",LEXSR))
if +LEXSR'>0
QUIT
Begin DoDot:1
+8 NEW LEXNOM,LEXSYS,LEXC
SET LEXNOM=$PIECE($GET(LEX("SEL","SRC",LEXSR)),"^",1)
if '$LENGTH(LEXNOM)
QUIT
+9 SET LEXSYS=$ORDER(^LEX(757.03,"C",LEXNOM,0))
if LEXSYS'>0
QUIT
if LEXCTL'[("^"_LEXSYS_"^")
QUIT
+10 SET LEXC=$PIECE($GET(LEX("SEL","SRC",LEXSR)),"^",2)
if '$LENGTH(LEXC)
QUIT
+11 if '$LENGTH($GET(Y(+LEXSYS)))
SET Y(+LEXSYS)=LEXC
End DoDot:1
+12 NEW IOINHI,IOINORM
+13 QUIT
ECHO ; Echo codes
+1 NEW LEXCT,LEXLC,LEXLDR,LEXSY,LEXB,LEXN
SET LEXB=$GET(IOINHI)
SET LEXN=$GET(IOINORM)
+2 SET LEXLC=0
SET LEXLDR=" >>> "
IF '$DATA(LEXQUIET)
FOR LEXSY=1,2,30,31
Begin DoDot:1
+3 NEW LEXI
SET (LEXCT,LEXI)=0
FOR
SET LEXI=$ORDER(LEX("SEL","VAS","I",LEXSY,LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+4 NEW LEXD,LEXC,LEXS,LEXT
SET LEXD=$GET(LEX("SEL","VAS",LEXI))
SET LEXC=$PIECE(LEXD,"^",3)
SET LEXS=$PIECE(LEXD,"^",6)
+5 if '$LENGTH(LEXD)
QUIT
if '$LENGTH(LEXS)
QUIT
SET LEXT=LEXLDR_LEXS_" Code:"
+6 SET LEXT=LEXT_$JUSTIFY(" ",(23-$LENGTH(LEXT)))_$GET(LEXB)_LEXC_$GET(LEXN)
+7 SET LEXCT=LEXCT+1
SET LEXLC=LEXLC+1
if LEXLC>1
SET LEXLDR=" "
+8 if LEXCT>1
QUIT
if LEXCT=1
WRITE !
WRITE !,LEXT
End DoDot:2
End DoDot:1
+9 QUIT
ASK ; Get user input
+1 NEW DIR,DIRUT,DIROUT
if $LENGTH($GET(LEXDICA))
SET DIC("A")=LEXDICA
+2 SET DIR("A")=DIC("A")
if '$LENGTH($GET(X))&('$LENGTH($GET(LEXDICB)))
WRITE !
+3 IF '$LENGTH($GET(X))
IF $LENGTH($GET(LEXDICB))
SET DIR("B")=LEXDICB
+4 SET DIR("?")=" "_$$SQ^LEXHLP
+5 SET DIR("??")="^D INPHLP^LEXA1"
SET DIR("?")=$GET(DIR("??"))
+6 NEW Y
SET DIR(0)="FAO^0:245"
KILL X
+7 DO ^DIR
+8 KILL DIC("B")
if $EXTRACT(X,1)=" "
DO RSBR
+9 if $EXTRACT(X,1)'=" "
WRITE !
+10 FOR
if $EXTRACT(X,1)'=" "
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+11 if $DATA(DTOUT)
WRITE !,"Try later.",!
+12 IF $DATA(DTOUT)!(X="^")
SET X=""
+13 if X[U
SET DUOUT=1
KILL DIRUT,DIROUT
QUIT
INPHLP ; Look-up help
+1 NEW IMP,CUR,CUT,FLG,LEXD,LEXCAT,LEXQUIET,LEXSRC
SET IMP=$$IMPDATE^LEXU(30)
+2 SET CUR=$GET(LEXVDT)
if CUR'?7N
SET CUR=$$DT^XLFDT
SET FLG=$SELECT(CUR<IMP:0,1:1)
+3 SET LEXD=$GET(^TMP("LEXSCH",$JOB,"FIL",0))
+4 IF $GET(X)["??"
IF $LENGTH(LEXD)
IF LEXD["LEXU(Y,""DS4"","
KILL LEX("HLP")
Begin DoDot:1
+5 DO QMH^LEXAR3(X)
NEW LEXI
SET LEXI=0
+6 FOR
SET LEXI=$ORDER(LEX("HLP",LEXI))
if +LEXI'>0
QUIT
WRITE !,$GET(LEX("HLP",LEXI))
+7 KILL LEX("HLP")
End DoDot:1
QUIT
+8 WRITE !," Enter a ""free text"" term. Best results occur using one to "
+9 WRITE !," three full or partial words without a suffix"
+10 if $GET(X)'["??"
WRITE "."
+11 if $GET(X)["??"
WRITE " (i.e., ""DIABETES"","
+12 if $GET(X)["??"
WRITE !," ""DIAB MELL"",""DIAB MELL "_$SELECT(FLG:"NEO",1:"INSUL")_")"
+13 WRITE !," or "
+14 WRITE !," Enter a classification code (ICD/DSM/CPT etc) to find the single "
+15 WRITE !," term associated with the code."
+16 if $GET(X)["??"
WRITE " Example, a lookup of code "_$SELECT(FLG:"P70.2",1:"239.0")_" "
+17 if $GET(X)["??"
WRITE !," returns one and only one term, that is the preferred term for"
+18 if $GET(X)["??"
WRITE !," the code "_$SELECT(FLG:"P70.2",1:"239.0")_", "
+19 if $GET(X)["??"&(FLG)
WRITE """Neonatal Diabetes Mellitus"""
+20 if $GET(X)["??"&('FLG)
WRITE """Neoplasm of unspecified nature",!," of digestive system"""
+21 if FLG
QUIT
+22 WRITE !," or "
+23 WRITE !," Enter a classification code (ICD/DSM/CPT etc) followed by a plus"
+24 WRITE !," sign (+) to retrieve all terms associated with the code."
+25 if $GET(X)["??"
WRITE " Example,"
+26 if $GET(X)["??"
WRITE !," a lookup of 239.0+ returns all terms that are linked to the "
+27 if $GET(X)["??"
WRITE !," code 239.0."
+28 QUIT
CHK ; Check Fileman look-up variables
+1 KILL DIC("DR"),DIC("P"),DIC("V"),DLAYGO,DINUM
+2 if $LENGTH($GET(X))
SET LEXSAVE=X
if $LENGTH($GET(DIC("B")))
SET LEXDICB=DIC("B")
KILL DIC("B")
+3 IF $LENGTH($GET(DIC(0)))
Begin DoDot:1
+4 FOR
if DIC(0)'["L"
QUIT
SET DIC(0)=$PIECE(DIC(0),"L",1)_$PIECE(DIC(0),"L",2)
+5 FOR
if DIC(0)'["I"
QUIT
SET DIC(0)=$PIECE(DIC(0),"I",1)_$PIECE(DIC(0),"I",2)
End DoDot:1
+6 if '$LENGTH($GET(DIC(0)))
SET DIC(0)="QEAMF"
if '$LENGTH($GET(DIC))
SET DIC="^LEX(757.01,"
+7 if DIC(0)'["F"
SET DIC(0)=DIC(0)_"F"
if '$LENGTH($GET(DIC("A")))
SET DIC("A")="Enter Term/Concept: "
+8 SET LEXDICA=DIC("A")
+9 QUIT
SSBR ; Store data for Space Bar Return
+1 if '$LENGTH($GET(DUZ))
QUIT
if +($GET(DUZ))=0
QUIT
if '$LENGTH($GET(DIC))
QUIT
if $GET(DIC)'["757.01,"
QUIT
+2 if $GET(DIC(0))'["F"
QUIT
if +($GET(Y))'>2
QUIT
if $EXTRACT($GET(X),1)=" "
QUIT
SET ^DISV(DUZ,DIC)=+($GET(Y))
+3 QUIT
RSBR ; Retrieve onSpace Bar Return
+1 if '$LENGTH($GET(DUZ))
QUIT
if $GET(DIC)'="^LEX(757.01,"
QUIT
if $GET(DIC(0))'["F"
QUIT
+2 if $EXTRACT($GET(X),1)'=" "
QUIT
if +($GET(^DISV(DUZ,DIC)))>2
SET X=@(DIC_+($GET(^DISV(DUZ,DIC)))_",0)")
+3 QUIT
