LEXA1 ;ISL/KER - Lexicon Look-up (Loud) ;04/21/2014
;;2.0;LEXICON UTILITY;**3,4,6,11,15,38,55,73,80**;Sep 23, 1996;Build 10
;
; 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
; established by Fileman Data Dictionary's node:
;
; ^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 for textto search for.
;
; 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. Deactivated terms
; will appear on the selection list. This
; is used by developers in the mainteance
; of the Code Sets.
;
; LEXDISP Display - Force overwrite of display default
; parameter.
;
; Output
;
; Fileman
;
; Y 2 piece string containing IEN and
; expression or -1 if X is 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 S LEXQ=0 D VDT^LEXU
;
; LEXSUB Special variable from version 1.0 specifying the
; vocabulary subset to use during the search. It is
; a three character mnemonic taken from the Subset
; Definition file #757.2. The default is "WRD"
S:'$L($G(LEXSUB)) LEXSUB="WRD"
;
; LEXAP Special variable from version 1.0 specifying the
; application using the Lexicon. It is a pointer
; value to the Subset Definition 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 Special variable (new) specifying the length of the
; displayable list the user is to select from. Default
; is 5 (display 5 at a time until the entire list has
; been reviewed)
S:'$L($G(LEXLL)) LEXLL=5
;
; LEXSRC Special variable specifying the source of the
; vocabulary to use during the search. It is
; an Internal Entry Number to the Source File
; #757.14. There is no default value.
N LEXXSR S:$L($G(LEXSRC)) LEXXSR=$G(LEXSRC)
;
; LEXCAT Special variable specifying the source category of
; the vocabulary to use during the search. It is
; an Internal Entry Number in the Source Category
; file #757.13. There is no default value.
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.
;
F D LK Q:'$D(LEX)!($D(LEX("SEL")))
G EXIT
LK ; Start Look-up
; X not provided
D:'$D(LEXSAVE) ASK
; 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)
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, if
; no selection is made continue the search
;
; 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) from LEX("SEL")
S:$L($G(LEXDICA)) DIC("A")=LEXDICA S:$L($G(LEXDICB)) DIC("B")=LEXDICB K Y
I '$D(LEX("SEL","EXP",1)) K Y S Y=-1 D CL Q
I $D(LEX("SEL","EXP",1)) S Y=LEX("SEL","EXP",1) D Y1,SSBR S:DIC(0)["Z" Y(0)=^LEX(757.01,+(LEX("SEL","EXP",1)),0),Y(0,0)=$P(^LEX(757.01,+(LEX("SEL","EXP",1)),0),"^",1)
D CL
Q
CL ; Clear LEX and Multi-Term Lookup XTLK
K LEX,LEXSUB,LEXAP,LEXLL D CLR
Q
CLR ; Clear ^TMP Global
K ^TMP("LEXSCH",$J),^TMP("LEXHIT",$J),^TMP("LEXFND",$J)
Q
Y1 ; ICD-9 DX in Y(1), ICD-10 DX in Y(30)
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
. . S:'$L($G(Y(+LEXSY))) Y(+LEXSY)=LEXC
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,CUT,FLG,LEXD 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
LEXA1 ;ISL/KER - Lexicon Look-up (Loud) ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**3,4,6,11,15,38,55,73,80**;Sep 23, 1996;Build 10
+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 ; established by Fileman Data Dictionary's node:
+4 ;
+5 ; ^DD(757.01,0,"DIC")=LEXA1
+6 ;
+7 ; Input All input variables are optional
+8 ;
+9 ; X User's input, if X does not exist the user
+10 ; will be prompted for textto search for.
+11 ;
+12 ; Fileman Variables used:
+13 ;
+14 ; DIC Global Root (default ^LEX(757.01,)
+15 ; DIC(0) DIC response string (default AEQM)
+16 ; DIC("A") Prompt (default "Enter Term/Concept:")
+17 ; DIC("B") Default lookup value
+18 ; DIC("S") Screen
+19 ; DIC("W") Output string
+20 ;
+21 ; Special Input Variables:
+22 ;
+23 ; LEXVDT Versioning Date - This is a date in
+24 ; Fileman format. If set it will force
+25 ; the lookup to be date sensitive,
+26 ; inactive and pending codes and terms
+27 ; will not display on the selection
+28 ; list.
+29 ;
+30 ; Developer Input Variables
+31 ;
+32 ; LEXIGN Ignore - This flag, if set will ignore
+33 ; deactivation flags. Deactivated terms
+34 ; will appear on the selection list. This
+35 ; is used by developers in the mainteance
+36 ; of the Code Sets.
+37 ;
+38 ; LEXDISP Display - Force overwrite of display default
+39 ; parameter.
+40 ;
+41 ; Output
+42 ;
+43 ; Fileman
+44 ;
+45 ; Y 2 piece string containing IEN and
+46 ; expression or -1 if X is not found
+47 ; or selection not made
+48 ;
+49 ; Y(0) If DIC(0) contains a Z this variable
+50 ; will be equal to the entire zero node
+51 ; of the entry that was selected
+52 ;
+53 ; Y(0,0) If DIC(0) contains a Z this variable
+54 ; will be equal to the external form of
+55 ; the .01 field of the entry that was
+56 ; selected
+57 ;
+58 ; Non-Fileman
+59 ;
+60 ; Y(1) This is the external form of the ICD-9
+61 ; diagnosis code when found
+62 ;
+63 ; Y(2) This is the external form of the ICD-9
+64 ; procedure code when found
+65 ;
+66 ; Y(30) This is the external form of the ICD-10
+67 ; diagnosis code when found
+68 ;
+69 ; Y(31) This is the external form of the ICD-10
+70 ; procedure code when found
+71 ;
+72 ; Y(81) This is the external form of the CPT-4
+73 ; or HCPCS code when found
+74 ;
+75 IF $DATA(DIC(0))
IF $GET(DIC(0))["A"
KILL X
+76 ; Date Check
+77 NEW LEXTD,LEXQ
SET LEXQ=0
DO VDT^LEXU
+78 ;
+79 ; LEXSUB Special variable from version 1.0 specifying the
+80 ; vocabulary subset to use during the search. It is
+81 ; a three character mnemonic taken from the Subset
+82 ; Definition file #757.2. The default is "WRD"
+83 IF '$LENGTH($GET(LEXSUB))
SET LEXSUB="WRD"
+84 ;
+85 ; LEXAP Special variable from version 1.0 specifying the
+86 ; application using the Lexicon. It is a pointer
+87 ; value to the Subset Definition file #757.2.
+88 ; The default is 1 (Lexicon)
+89 IF '$LENGTH($GET(LEXAP))&($LENGTH($GET(^TMP("LEXSCH",$JOB,"APP",0))))
SET LEXAP=^TMP("LEXSCH",$JOB,"APP",0)
+90 IF '$LENGTH($GET(LEXAP))
SET LEXAP=1
+91 ;
+92 ; LEXLL Special variable (new) specifying the length of the
+93 ; displayable list the user is to select from. Default
+94 ; is 5 (display 5 at a time until the entire list has
+95 ; been reviewed)
+96 IF '$LENGTH($GET(LEXLL))
SET LEXLL=5
+97 ;
+98 ; LEXSRC Special variable specifying the source of the
+99 ; vocabulary to use during the search. It is
+100 ; an Internal Entry Number to the Source File
+101 ; #757.14. There is no default value.
+102 NEW LEXXSR
IF $LENGTH($GET(LEXSRC))
SET LEXXSR=$GET(LEXSRC)
+103 ;
+104 ; LEXCAT Special variable specifying the source category of
+105 ; the vocabulary to use during the search. It is
+106 ; an Internal Entry Number in the Source Category
+107 ; file #757.13. There is no default value.
+108 NEW LEXXCT
IF $LENGTH($GET(LEXCAT))
SET LEXXCT=$GET(LEXCAT)
+109 ;
+110 ; Check the DIC variables new LEXUR "user response"
+111 NEW LEXDICA,LEXDICB,LEXO,XTLKGBL,XTLKHLP,XTLKKSCH,XTLKSAY
DO CHK
NEW LEXUR
+112 ;
+113 ; Save the value of X if "Ask" is not specified in DIC(0)
+114 IF DIC(0)'["A"
IF $LENGTH($GET(X))
SET LEXSAVE=X
KILL X
+115 ;
+116 ; Save the prompt
+117 IF $LENGTH($GET(DIC("A")))
SET LEXDICA=DIC("A")
+118 ;
+119 ; Continue to lookup until the dialog with the application
+120 ; ends. If there is nothing to lookup (X="") or an uparrow
+121 ; is detected, the Lexicon shuts down killing LEX.
+122 ;
+123 FOR
DO LK
IF '$DATA(LEX)!($DATA(LEX("SEL")))
QUIT
+124 GOTO EXIT
LK ; Start Look-up
+1 ; X not provided
+2 IF '$DATA(LEXSAVE)
DO ASK
+3 ; X provided
+4 IF $DATA(LEXSAVE)
SET X=LEXSAVE
KILL LEXSAVE
+5 ; X was null with a default provided
+6 IF $DATA(DIC("B"))&($GET(X)="")
SET X=DIC("B")
+7 ; Lookup X - LOOK(LEXX,LEXAP,LEXLL,LEXSUB,LEXVDT,LEXXSR,LEXXCT)
+8 DO LOOK^LEXA(X,$GET(LEXAP),$GET(LEXLL),,$GET(LEXVDT),$GET(LEXXSR),$GET(LEXXCT))
+9 KILL DIC("B")
+10 ;
NOTFND ; If X was not found
+1 ;
+2 ; Write "??"
+3 ;
+4 ; Calling application uses Unresolved Narratives
+5 ; Prompt to "accept or reject" the narrative, if
+6 ; no selection is made continue the search
+7 ;
+8 ; Calling application does not use Unresolved Narratives
+9 ; Display help, Re-prompt and Continue search
+10 ;
+11 IF '$DATA(LEX("LIST"))
IF +($GET(LEX))=0
IF $LENGTH(X)
IF X'["^"
IF $EXTRACT(X,1)'=" "
Begin DoDot:1
+12 KILL DIC("B"),LEX("SEL")
+13 IF +($GET(^TMP("LEXSCH",$JOB,"UNR",0)))=0
IF +($GET(X))'=757.01
WRITE " ??"
IF $DATA(LEX("HLP"))
DO DH^LEXA3
WRITE !
QUIT
+14 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) from LEX("SEL")
+1 IF $LENGTH($GET(LEXDICA))
SET DIC("A")=LEXDICA
IF $LENGTH($GET(LEXDICB))
SET DIC("B")=LEXDICB
KILL Y
+2 IF '$DATA(LEX("SEL","EXP",1))
KILL Y
SET Y=-1
DO CL
QUIT
+3 IF $DATA(LEX("SEL","EXP",1))
SET Y=LEX("SEL","EXP",1)
DO Y1
DO SSBR
IF DIC(0)["Z"
SET Y(0)=^LEX(757.01,+(LEX("SEL","EXP",1)),0)
SET Y(0,0)=$PIECE(^LEX(757.01,+(LEX("SEL","EXP",1)),0),"^",1)
+4 DO CL
+5 QUIT
CL ; Clear LEX and Multi-Term Lookup XTLK
+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 ; ICD-9 DX in Y(1), ICD-10 DX in Y(30)
+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
+9 IF '$LENGTH($GET(Y(+LEXSY)))
SET Y(+LEXSY)=LEXC
End DoDot:2
End DoDot:1
+10 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,CUT,FLG,LEXD
SET IMP=$$IMPDATE^LEXU(30)
SET CUR=$GET(LEXVDT)
IF CUR'?7N
SET CUR=$$DT^XLFDT
SET FLG=$SELECT(CUR<IMP:0,1:1)
+2 SET LEXD=$GET(^TMP("LEXSCH",$JOB,"FIL",0))
+3 IF $GET(X)["??"
IF $LENGTH(LEXD)
IF LEXD["LEXU(Y,""DS4"","
KILL LEX("HLP")
Begin DoDot:1
+4 DO QMH^LEXAR3(X)
NEW LEXI
SET LEXI=0
+5 FOR
SET LEXI=$ORDER(LEX("HLP",LEXI))
IF +LEXI'>0
QUIT
WRITE !,$GET(LEX("HLP",LEXI))
+6 KILL LEX("HLP")
End DoDot:1
QUIT
+7 WRITE !," Enter a ""free text"" term. Best results occur using one to "
+8 WRITE !," three full or partial words without a suffix"
+9 IF $GET(X)'["??"
WRITE "."
+10 IF $GET(X)["??"
WRITE " (i.e., ""DIABETES"","
+11 IF $GET(X)["??"
WRITE !," ""DIAB MELL"",""DIAB MELL "_$SELECT(FLG:"NEO",1:"INSUL")_")"
+12 WRITE !," or "
+13 WRITE !," Enter a classification code (ICD/DSM/CPT etc) to find the single "
+14 WRITE !," term associated with the code."
+15 IF $GET(X)["??"
WRITE " Example, a lookup of code "_$SELECT(FLG:"P70.2",1:"239.0")_" "
+16 IF $GET(X)["??"
WRITE !," returns one and only one term, that is the preferred term for"
+17 IF $GET(X)["??"
WRITE !," the code "_$SELECT(FLG:"P70.2",1:"239.0")_", "
+18 IF $GET(X)["??"&(FLG)
WRITE """Neonatal Diabetes Mellitus"""
+19 IF $GET(X)["??"&('FLG)
WRITE """Neoplasm of unspecified nature",!," of digestive system"""
+20 IF FLG
QUIT
+21 WRITE !," or "
+22 WRITE !," Enter a classification code (ICD/DSM/CPT etc) followed by a plus"
+23 WRITE !," sign (+) to retrieve all terms associated with the code."
+24 IF $GET(X)["??"
WRITE " Example,"
+25 IF $GET(X)["??"
WRITE !," a lookup of 239.0+ returns all terms that are linked to the "
+26 IF $GET(X)["??"
WRITE !," code 239.0."
+27 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
