- 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
