Routine: LEXINF4

LEXINF4 ;ISL/KER - Information - Lookup ;05/23/2017

 ;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2

 ; Global Variables

 ;    ^LEX(757.02         SACC 1.3

 ;    ^LEX(757.03         SACC 1.3

 ;    ^TMP("LEXINFLK"     SACC 2.3.2.5.1

 ;    ^TMP("LEXINFS"      SACC 2.3.2.5.1

 ; External References

 ;    FIND^DIC            ICR   2051

 ;    ^DIR                ICR  10026

 ;    ^LEXA1              Special Lookup

 ;    $$DT^XLFDT          ICR  10103

 ;    $$UP^XLFSTR         ICR  10104

TERM(X) ; Get Term

 ; Input

 ;   X       Date, optional, default is TODAY

 ; Output

 ;   $$TERM  2 piece "^" delimited string

 ;             1    Pointer to Expression file #757.01

 ;             2    Expression

 N DIC,LEXVDT,Y S LEXVDT=$$DT^XLFDT S:$G(X)?7N LEXVDT=$G(X) K X S DIC("S")="I 1" D ^LEXA1

 S X=Y

Q X

CODE(X) ; Get Code

 ; Input

 ;   None

 ; Output

 ;   $$CODE  6 piece "^" delimited string

 ;             1    Code

 ;             2    Coding System

 ;             3    Expression

 ;             4    Pointer to CODES file 757.02

 ;             5    Pointer to CODING SYSTEM file 757.03

 ;             6    Pointer to EXPRESSIONS file 757.01

 N DIR,DTOUT,DUOUT,DIRUT,DIROUT,DIC,DTOUT,DUOUT

 S DIR(0)="FAO^2:40",DIR("PRE")="S X=$$CODEP^LEXINF4($G(X))",DIR("A")=" Select Code:  "

 S (DIR("?"),DIR("??"))="^D CODEH^LEXINF4" D ^DIR Q:'$L(X)&('$D(DTOUT)) "-1^Valid code not entered"

 Q:$D(DTOUT) "-1^Timed out"  Q:X["^"&(X'["^^") "-1^Exit without entering a valid code"

 Q:X["^^" "-1^Abort without entering a valid code" S X=$$CODELK(Y)

Q X

CODEP(X) ;   Code Preprocessing

 N LEXINP,LEXO,LEXCTL,LEXSBS,LEXOK,LEXSRS S LEXINP=$G(X)

 Q:'$L(LEXINP) ""  Q:LEXINP="^" "^"  Q:LEXINP["^"&(LEXINP'["^^") "^"  Q:LEXINP["^^" "^^"

 Q:LEXINP["?" "??"  Q:$L(LEXINP)'>1 "??"

 S LEXSRS="^1^30^2^31^3^4^57^6^17^56^"

 S LEXO=$E(LEXINP,1,($L(LEXINP)-1))_$C($A($E(LEXINP,$L(LEXINP)))-1)_"~ ",LEXCTL=LEXINP,LEXOK=0

 F  S LEXO=$O(^LEX(757.02,"CODE",LEXO)) Q:'$L(LEXO)!($E(LEXO,1,$L(LEXCTL))'=LEXCTL)  Q:LEXOK  D  Q:LEXOK

 . N LEXSIEN S LEXSIEN=0 F  S LEXSIEN=$O(^LEX(757.02,"CODE",LEXO,LEXSIEN)) Q:+LEXSIEN'>0  D

 . . N LEXND S LEXND=$G(^LEX(757.02,+LEXSIEN,0)) Q:$P(LEXND,"^",5)'>0  Q:LEXSRS'[("^"_$P(LEXND,"^",3)_"^")  S LEXOK=1

 Q:LEXOK'>0 "??"  S X=LEXINP

Q X

CODEH ;   Code Help

 W !,?5,"Enter a full or partial code from one of the following"

 W !,?5,"coding systems:",!

 W !,?10,"ICD   ICD-9-CM          10D   ICD-10-CM"

 W !,?10,"ICP   ICD-9 Proc        10P   ICD-10-PCS"

 W !,?10,"CPT   CPT-4             CPC   HCPCS"

 W !,?10,"DS4   DSM-IV            SCC   TITLE 38"

 W !,?10,"SCT   SNOMED CT         BIR   BI-RADS"

CODELK(X) ;   Lookup Code

 K ^TMP("LEXINFLK",$J) N LEXVAL,LEXI,LEXIDX,LEXMSG,LEXTAR,LEXCT,DIR,DTOUT,DUOUT,DIROUT,DIRUT

 S LEXVAL=$G(X),LEXCT=0 Q:'$L(LEXVAL) 0  S LEXIDX="CODE",LEXTAR="^TMP(""LEXINFLK"",$J)"

 D FIND^DIC(757.02,,".01EI;1EI;2EI",,LEXVAL,,LEXIDX,"I $$DICS^LEXINF4(+Y)>0",,LEXTAR,"LEXMSG")

 K ^TMP("LEXINFS",$J) S LEXI=0 F  S LEXI=$O(^TMP("LEXINFLK",$J,"DILIST","ID",LEXI)) Q:+LEXI'>0  D

 . N LEXEX,LEXSO,LEXSR,LEXSAB,LEXSRC,LEXNOM,LEXCODE,LEXEXP,LEXA,LEXSTR,LEXSIEN

 . S LEXSIEN=+($G(^TMP("LEXINFLK",$J,"DILIST",2,LEXI)))

 . S (LEXA(1),LEXEXP)=$G(^TMP("LEXINFLK",$J,"DILIST","ID",LEXI,.01,"E"))

 . S LEXEX=$G(^TMP("LEXINFLK",$J,"DILIST","ID",LEXI,.01,"I"))

 . S LEXCODE=$G(^TMP("LEXINFLK",$J,"DILIST","ID",LEXI,1,"E"))

 . S LEXSO=$G(^TMP("LEXINFLK",$J,"DILIST","ID",LEXI,1,"I"))

 . S LEXSAB=$G(^TMP("LEXINFLK",$J,"DILIST","ID",LEXI,2,"E"))

 . S LEXSR=$G(^TMP("LEXINFLK",$J,"DILIST","ID",LEXI,2,"I"))

 . S:$L(LEXSAB) LEXSRC=$O(^LEX(757.03,"ASAB",LEXSAB,0))

 . S:+LEXSRC>0 LEXNOM=$P($G(^LEX(757.03,+LEXSRC,0)),"^",2)

 . S:$L(LEXNOM) ^TMP("LEXINFLK",$J,"DILIST","ID",LEXI,2)=LEXNOM

 . S ^TMP("LEXINFS",$J,LEXI,0)=LEXSIEN

 . S ^TMP("LEXINFS",$J,LEXI,"SO")=LEXCODE

 . S ^TMP("LEXINFS",$J,LEXI,"EX")=LEXEX_"^"_LEXEXP

 . S ^TMP("LEXINFS",$J,LEXI,"SR")=LEXSR_"^"_LEXNOM

 . S ^TMP("LEXINFS",$J,LEXI,"OUT")=LEXCODE_"^"_LEXNOM_"^"_LEXEXP_"^"_LEXSIEN_"^"_LEXSR_"^"_LEXEX

 . S LEXLEN=$L(LEXCODE)+$L(LEXNOM)+6 D PR^LEXU(.LEXA,(70-LEXLEN))

 . S LEXSTR=LEXCODE_"  ("_LEXNOM_")  "_LEXA(1)

 . S ^TMP("LEXINFLK",$J,"DILIST","ID","LEX",LEXI,1)=LEXSTR

 . S ^TMP("LEXINFS",$J,LEXI,"A",1)=LEXSTR

 . S LEXCT=LEXCT+1

 . K LEXA(1) I $D(LEXA) D PR^LEXU(.LEXA,56) D

 . . N LEXL S LEXL=0 F  S LEXL=$O(LEXA(LEXL)) Q:+LEXL'>0  D

 . . . N LEXT,LEXS S LEXT=$G(LEXA(LEXL)) Q:'$L(LEXT)

 . . . S LEXT="         "_LEXT

 . . . S LEXS=$O(^TMP("LEXINFLK",$J,"DILIST","ID","LEX",LEXI," "),-1)+1

 . . . S ^TMP("LEXINFLK",$J,"DILIST","ID","LEX",LEXI,LEXS)=LEXT

 . . . S ^TMP("LEXINFS",$J,LEXI,"A",LEXS)=LEXT

 . S ^TMP("LEXINFLK",$J,"DILIST","ID","MAT")=LEXCT

 . S ^TMP("LEXINFS",$J,0)=LEXCT

 K ^TMP("LEXINFLK",$J),LEXMSG,LEXTAR

 S X=$$CODEASK

Q X

CODEASK(X) ;   Ask for Selection

 N LEXIT,LEXL,LEXTOT,DTOUT,DUOUT,DIROUT,DIRUT S LEXL=+($G(X)) S:LEXL'>0 LEXL=5

 S LEXTOT=+($G(^TMP("LEXINFS",$J,0))),LEXIT=0 Q:+LEXTOT'>0 "^"

 K X S:+LEXTOT=1 X=$$CODEO(LEXL) S:+LEXTOT>1 X=$$CODEM(LEXL) Q:+X<0 X

 I +X>0,$L($P(X,"^",2)),$L($P(X,"^",3)) D

 . S X=$P(X,"^",2,4000) W "    ",$P(X,"^",2)," code ",$P(X,"^",1),!

Q X

CODEO(X,LEX) ;     One Code Found

 Q:+($G(LEXIT))>0 "-1^Exit"  N DIR,LEXI,LEXS,LEXC S DIR("A",1)=" One match found",DIR("A",2)=" " S LEXC=2

 S LEXI=1,LEXS=0 Q:'$D(^TMP("LEXINFS",$J,LEXI,"A",1)) "-1^Nothing found"

 F  S LEXS=$O(^TMP("LEXINFS",$J,LEXI,"A",LEXS)) Q:+LEXS'>0  D

 . N LEXT S LEXT=$G(^TMP("LEXINFS",$J,LEXI,"A",LEXS)) S LEXC=LEXC+1

 . S:LEXC=3 DIR("A",LEXC)=("   "_LEXT) S:LEXC>3 DIR("A",LEXC)=("     "_LEXT)

 S LEXC=LEXC+1,DIR("A",LEXC)=" "

 S DIR("A")="  OK? (Yes/No)  ",DIR("B")="Yes",DIR(0)="YAO" W !

 D ^DIR S:X["^^"!($D(DTOUT)) LEXIT=1 S:$D(DTOUT) LEXIT=1 S:$D(DUOUT)!($D(DIROUT))!($D(DIRUT)) LEXIT=1

 S:+$G(Y)'>0 LEXIT=1 Q:$D(DTOUT) "-1^Timed out"  Q:$D(DUOUT)!($D(DIROUT))!($D(DIRUT)) "-1^Exit without selection"

 Q:+$G(Y)'>0 "-1^No selection made" Q:X["^^"!(+($G(LEXIT))>0) "-1^Aborted^"

 S X=$S(+Y>0:$$OUT(1),1:"-1^Selection not made")

Q X

CODEM(X) ;     Multiple Codes Found

 Q:+($G(LEXIT))>0 "^^"  N LEXI,LEXS,LEXL,LEXNM,LEXMAX,LEXLAST,LEXSS,LEXX,Y

 S (LEXMAX,LEXIT)=0,LEXL=+($G(X)),U="^" S:+($G(LEXL))'>0 LEXL=5 S LEXLAST=$O(^TMP("LEXINFS",$J," "),-1)

 S LEXX=+($G(^TMP("LEXINFS",$J,0))),LEXSS=0 G:+LEXX<2 CODEMQ W ! W:+LEXX>1 !," ",LEXX," matches found" S (LEXNM,LEXI)=0

 F  S LEXI=$O(^TMP("LEXINFS",$J,LEXI)) Q:+LEXI'>0  Q:+LEXSS>0  Q:LEXIT>0  D  Q:LEXIT>0  Q:+LEXSS>0

 . W:LEXI#LEXL=1 ! D CODEMW

 . S LEXMAX=LEXI W:LEXI#LEXL=0 !

 . S:LEXI#LEXL=0 LEXSS=$$CODEMS(LEXMAX) Q:LEXIT>0

 . I LEXMAX=LEXLAST,LEXI#LEXL'=0,+LEXSS'<0 D  Q:LEXIT>0

 . . W ! S LEXSS=$$CODEMS(LEXMAX)

 G CODEMQ

Q X

CODEMW ;       Write Multiple

 N LEXS S LEXI=+($G(LEXI)),LEXS=0 F  S LEXS=$O(^TMP("LEXINFS",$J,LEXI,"A",LEXS)) Q:+LEXS'>0  D

 . N LEXT S LEXT=$G(^TMP("LEXINFS",$J,LEXI,"A",LEXS)) S:LEXS=1 LEXT=$J(+LEXI,5)_".  "_LEXT

 . S:LEXS>1 LEXT="          "_LEXT W !,LEXT

CODEMS(X) ;       Select from Multiple Entries

 N DIR,DIRB,LEXFI,LEXHLP,LEXLAST,LEXMAX,LEXS

 Q:+($G(LEXIT))>0 "-1^Exit"

 S LEXMAX=+($G(X)) Q:LEXMAX=0 "-1^No matches found"

 S LEXLAST=$O(^TMP("LEXINFS",$J," "),-1)

 I +($O(^TMP("LEXINFS",$J,LEXMAX)))>0 D

 . S DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"_LEXMAX_": "

 I +($O(^TMP("LEXINFS",$J,LEXMAX)))'>0 D

 . S DIR("A")=" Select 1-"_LEXMAX_": "

 S LEXHLP=" Answer must be from 1 to "_LEXMAX_", or <Return> to continue"

 S DIR("PRE")="S:X[""?"" X=""??"""

 S (DIR("?"),DIR("??"))="^D CODEMSH^LEXINF4"

 S DIR(0)="NAO^1:"_LEXMAX_":0" D ^DIR

 I (LEXLAST>LEXMAX) S:'$L(X)&($D(DTOUT)) LEXIT=1 Q:'$L(X)&($D(DTOUT)) "-1^Timed out"

 Q:'$L(X)&(LEXLAST>LEXMAX)&('$D(DTOUT)) "" Q:'$L(X)&(LEXLAST'>LEXMAX)&('$D(DTOUT)) "-1^No selection made"

 S:X["^^" LEXIT=1 S:$D(DTOUT) LEXIT=1 S:$D(DUOUT)!($D(DIROUT))!($D(DIRUT)) LEXIT=1 S:+$G(Y)'>0 LEXIT=1

 Q:X["^^" "-1^Aborted without selection" Q:$D(DTOUT) "-1^Timed out"

 Q:$D(DUOUT)!($D(DIROUT))!($D(DIRUT)) "-1^Exit without selection"

 Q:+$G(Y)'>0 "-1^No selection made" Q:X["^^"!(+($G(LEXIT))>0) "-1^Aborted^"

 Q $S(+Y>0:$$OUT(+Y),1:"")

CODEMSH ;       Select from Multiple Entries Help

 I $L($G(LEXHLP)) W !,$G(LEXHLP) Q

CODEMQ ;       Quit Multiple

 S X=$G(LEXSS) S:+($G(LEXSS))'>0 X="-1^No selection made" S:+($G(LEXSS))<0&($L($P($G(LEXSS),"^",2))) X=LEXSS

Q X

 ; Miscellaneous

OUT(X) ;   Output Selection

 N LEXFND,LEXCODE,LEXEXP,LEXNOM,LEXOUT,LEXI,LEXS,LEXC S LEXFND=+($G(X)) Q:LEXFND'>0 -1  Q:'$D(^TMP("LEXINFS",$J,LEXFND))

 S LEXSO=$G(^TMP("LEXINFS",$J,LEXFND,0)),LEXEXP=$P($G(^TMP("LEXINFS",$J,LEXFND,"EX")),"^",2),LEXEX=$P($G(^TMP("LEXINFS",$J,LEXFND,"EX")),"^",1)

 S LEXCODE=$G(^TMP("LEXINFS",$J,LEXFND,"SO")),LEXNOM=$P($G(^TMP("LEXINFS",$J,LEXFND,"SR")),"^",2),LEXSR=$P($G(^TMP("LEXINFS",$J,LEXFND,"SR")),"^",1)

 S:$L(LEXCODE) LEXOUT=LEXCODE_"^"_LEXNOM_"^"_LEXEXP_"^"_LEXSO_"^"_LEXSR_"^"_LEXEX S:'$L(LEXCODE) LEXOUT=$G(^TMP("LEXINFS",$J,LEXI,"OUT")) Q:'$L($P(LEXOUT,"^",1)) -1

 S X=LEXFND_"^"_LEXOUT

Q X

CONT(X,Y) ;   Ask to Continue

 K DTOUT,DUOUT,DIRUT,DIROUT N LEXX,LEXFQ,LEXW,LEXI,LEXC,DIR

 S LEXX=$$UP^XLFSTR($G(X)),LEXFQ=$G(Y) Q:'$L(LEXX) 1  Q:LEXFQ'>0 1

 S LEXW(1)="Searching for """_LEXX_""" requires inspecting "

 S LEXW(2)=LEXFQ_" records to determine if they match the "

 S LEXW(3)="search criteria.  This could take quite some time."

 S LEXW(4)="Suggest refining the search by further specifying "

 S LEXW(5)=""""_LEXX_"."""

 D PR^LEXU(.LEXW,60) S (LEXC,LEXI)=0 F  S LEXI=$O(LEXW(LEXI)) Q:+LEXI'>0  D

 . Q:'$L($G(LEXW(LEXI)))  S LEXC=LEXC+1 S DIR("A",LEXC)="   "_$G(LEXW(LEXI))

 I LEXC>0 S LEXC=LEXC+1,DIR("A",LEXC)=" "

 S DIR("A")=" Do you wish to continue?  (Y/N)  ",DIR("B")="No"

 S DIR(0)="YAO",(DIR("?"),DIR("??"))="^D COH^LEXINF4"

 S DIR("PRE")="S:X[""?"" X=""??""" W ! D ^DIR

 S X=+Y S:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) X="^"

Q X

COH ;   Continue Help

 I $L($G(LEXX))>0 D

 . W !,"   Enter   To"

 . W !,"   'Yes'   continue searching for """,LEXX,"""."

 . W !,"   'No'    refine the search (further specify)"

 . W !,"   '^'     discontinue the search and exit"

 I '$L($G(LEXX))>0 D

 . W !,"   Enter   To"

 . W !,"   'Yes'   continue the search"

 . W !,"   'No'    refine the search (further specify)"

 . W !,"   '^'     discontinue the search and exit"

DICW(X) ;   DIC Write

 N LEXSIEN,LEXSRC,LEXNOM

 S LEXSIEN=+($G(Y)),LEXSRC=$P($G(^LEX(757.02,+LEXSIEN,0)),"^",3),LEXNOM=$P($G(^LEX(757.03,+LEXSRC,0)),"^",2)

 Q:'$L(LEXNOM) ""  S X="   ("_LEXNOM_")"

Q X

DICS(X) ;   DIC Screen

 N LEXSIEN S LEXSIEN=+($G(X)) Q:$$PREOK(LEXSIEN)'>0 0  Q:$$SABOK(LEXSIEN)'>0 0

Q 1

PREOK(X) ;   Preferred Term OK

 N LEXSIEN,LEXPRE S LEXSIEN=+($G(X)),LEXPRE=+($P($G(^LEX(757.02,+LEXSIEN,0)),"^",5)) Q:+LEXPRE'>0 0

Q 1

SABOK(X) ;   Source OK

 N LEXSIEN,LEXSBS,LEXSRC S LEXSIEN=+($G(X)),LEXSRC=+($P($G(^LEX(757.02,+LEXSIEN,0)),"^",3)),LEXSAB=$P($G(^LEX(757.03,+LEXSRC,0)),"^",1) Q:'$L(LEXSAB) 0

 S LEXSBS="^ICD^10D^ICP^10P^CPT^CPC^BIR^DS4^SCC^SCT^" Q:LEXSBS'[("^"_LEXSAB_"^") 0

Q 1

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[HLEXINF4   11395     printed  Mar 13, 2025@21:12:38                                                                                                                                                                                                    Page 2

LEXINF4   ;ISL/KER - Information - Lookup ;05/23/2017

 +1       ;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2

 +2       ;

 +3       ; Global Variables

 +4       ;    ^LEX(757.02         SACC 1.3

 +5       ;    ^LEX(757.03         SACC 1.3

 +6       ;    ^TMP("LEXINFLK"     SACC 2.3.2.5.1

 +7       ;    ^TMP("LEXINFS"      SACC 2.3.2.5.1

 +8       ;

 +9       ; External References

 +10      ;    FIND^DIC            ICR   2051

 +11      ;    ^DIR                ICR  10026

 +12      ;    ^LEXA1              Special Lookup

 +13      ;    $$DT^XLFDT          ICR  10103

 +14      ;    $$UP^XLFSTR         ICR  10104

 +15      ;

TERM(X)   ; Get Term

 +1       ;

 +2       ; Input

 +3       ;

 +4       ;   X       Date, optional, default is TODAY

 +5       ;

 +6       ; Output

 +7       ;

 +8       ;   $$TERM  2 piece "^" delimited string

 +9       ;             1    Pointer to Expression file #757.01

 +10      ;             2    Expression

 +11      ;

 +12       NEW DIC,LEXVDT,Y

           SET LEXVDT=$$DT^XLFDT

           if $GET(X)?7N

               SET LEXVDT=$GET(X)

           KILL X

           SET DIC("S")="I 1"

           DO ^LEXA1

 +13       SET X=Y

 +14       QUIT X

CODE(X)   ; Get Code

 +1       ;

 +2       ; Input

 +3       ;

 +4       ;   None

 +5       ;

 +6       ; Output

 +7       ;

 +8       ;   $$CODE  6 piece "^" delimited string

 +9       ;             1    Code

 +10      ;             2    Coding System

 +11      ;             3    Expression

 +12      ;             4    Pointer to CODES file 757.02

 +13      ;             5    Pointer to CODING SYSTEM file 757.03

 +14      ;             6    Pointer to EXPRESSIONS file 757.01

 +15      ;

 +16       NEW DIR,DTOUT,DUOUT,DIRUT,DIROUT,DIC,DTOUT,DUOUT

 +17       SET DIR(0)="FAO^2:40"

           SET DIR("PRE")="S X=$$CODEP^LEXINF4($G(X))"

           SET DIR("A")=" Select Code:  "

 +18       SET (DIR("?"),DIR("??"))="^D CODEH^LEXINF4"

           DO ^DIR

           if '$LENGTH(X)&('$DATA(DTOUT))

               QUIT "-1^Valid code not entered"

 +19       if $DATA(DTOUT)

               QUIT "-1^Timed out"

           if X["^"&(X'["^^")

               QUIT "-1^Exit without entering a valid code"

 +20       if X["^^"

               QUIT "-1^Abort without entering a valid code"

           SET X=$$CODELK(Y)

 +21       QUIT X

CODEP(X)  ;   Code Preprocessing

 +1        NEW LEXINP,LEXO,LEXCTL,LEXSBS,LEXOK,LEXSRS

           SET LEXINP=$GET(X)

 +2        if '$LENGTH(LEXINP)

               QUIT ""

           if LEXINP="^"

               QUIT "^"

           if LEXINP["^"&(LEXINP'["^^")

               QUIT "^"

           if LEXINP["^^"

               QUIT "^^"

 +3        if LEXINP["?"

               QUIT "??"

           if $LENGTH(LEXINP)'>1

               QUIT "??"

 +4        SET LEXSRS="^1^30^2^31^3^4^57^6^17^56^"

 +5        SET LEXO=$EXTRACT(LEXINP,1,($LENGTH(LEXINP)-1))_$CHAR($ASCII($EXTRACT(LEXINP,$LENGTH(LEXINP)))-1)_"~ "

           SET LEXCTL=LEXINP

           SET LEXOK=0

 +6        FOR

               SET LEXO=$ORDER(^LEX(757.02,"CODE",LEXO))

               if '$LENGTH(LEXO)!($EXTRACT(LEXO,1,$LENGTH(LEXCTL))'=LEXCTL)

                   QUIT

               if LEXOK

                   QUIT

               Begin DoDot:1

 +7                NEW LEXSIEN

                   SET LEXSIEN=0

FOR

                       SET LEXSIEN=$ORDER(^LEX(757.02,"CODE",LEXO,LEXSIEN))

                       if +LEXSIEN'>0

                           QUIT

                       Begin DoDot:2

 +8                        NEW LEXND

                           SET LEXND=$GET(^LEX(757.02,+LEXSIEN,0))

                           if $PIECE(LEXND,"^",5)'>0

                               QUIT

                           if LEXSRS'[("^"_$PIECE(LEXND,"^",3)_"^")

                               QUIT

                           SET LEXOK=1

                       End DoDot:2

               End DoDot:1

               if LEXOK

                   QUIT

 +9        if LEXOK'>0

               QUIT "??"

           SET X=LEXINP

 +10       QUIT X

CODEH     ;   Code Help

 +1        WRITE !,?5,"Enter a full or partial code from one of the following"

 +2        WRITE !,?5,"coding systems:",!

 +3        WRITE !,?10,"ICD   ICD-9-CM          10D   ICD-10-CM"

 +4        WRITE !,?10,"ICP   ICD-9 Proc        10P   ICD-10-PCS"

 +5        WRITE !,?10,"CPT   CPT-4             CPC   HCPCS"

 +6        WRITE !,?10,"DS4   DSM-IV            SCC   TITLE 38"

 +7        WRITE !,?10,"SCT   SNOMED CT         BIR   BI-RADS"

 +8        QUIT

CODELK(X) ;   Lookup Code

 +1        KILL ^TMP("LEXINFLK",$JOB)

           NEW LEXVAL,LEXI,LEXIDX,LEXMSG,LEXTAR,LEXCT,DIR,DTOUT,DUOUT,DIROUT,DIRUT

 +2        SET LEXVAL=$GET(X)

           SET LEXCT=0

           if '$LENGTH(LEXVAL)

               QUIT 0

           SET LEXIDX="CODE"

           SET LEXTAR="^TMP(""LEXINFLK"",$J)"

 +3        DO FIND^DIC(757.02,,".01EI;1EI;2EI",,LEXVAL,,LEXIDX,"I $$DICS^LEXINF4(+Y)>0",,LEXTAR,"LEXMSG")

 +4        KILL ^TMP("LEXINFS",$JOB)

           SET LEXI=0

FOR

               SET LEXI=$ORDER(^TMP("LEXINFLK",$JOB,"DILIST","ID",LEXI))

               if +LEXI'>0

                   QUIT

               Begin DoDot:1

 +5                NEW LEXEX,LEXSO,LEXSR,LEXSAB,LEXSRC,LEXNOM,LEXCODE,LEXEXP,LEXA,LEXSTR,LEXSIEN

 +6                SET LEXSIEN=+($GET(^TMP("LEXINFLK",$JOB,"DILIST",2,LEXI)))

 +7                SET (LEXA(1),LEXEXP)=$GET(^TMP("LEXINFLK",$JOB,"DILIST","ID",LEXI,.01,"E"))

 +8                SET LEXEX=$GET(^TMP("LEXINFLK",$JOB,"DILIST","ID",LEXI,.01,"I"))

 +9                SET LEXCODE=$GET(^TMP("LEXINFLK",$JOB,"DILIST","ID",LEXI,1,"E"))

 +10               SET LEXSO=$GET(^TMP("LEXINFLK",$JOB,"DILIST","ID",LEXI,1,"I"))

 +11               SET LEXSAB=$GET(^TMP("LEXINFLK",$JOB,"DILIST","ID",LEXI,2,"E"))

 +12               SET LEXSR=$GET(^TMP("LEXINFLK",$JOB,"DILIST","ID",LEXI,2,"I"))

 +13               if $LENGTH(LEXSAB)

                       SET LEXSRC=$ORDER(^LEX(757.03,"ASAB",LEXSAB,0))

 +14               if +LEXSRC>0

                       SET LEXNOM=$PIECE($GET(^LEX(757.03,+LEXSRC,0)),"^",2)

 +15               if $LENGTH(LEXNOM)

                       SET ^TMP("LEXINFLK",$JOB,"DILIST","ID",LEXI,2)=LEXNOM

 +16               SET ^TMP("LEXINFS",$JOB,LEXI,0)=LEXSIEN

 +17               SET ^TMP("LEXINFS",$JOB,LEXI,"SO")=LEXCODE

 +18               SET ^TMP("LEXINFS",$JOB,LEXI,"EX")=LEXEX_"^"_LEXEXP

 +19               SET ^TMP("LEXINFS",$JOB,LEXI,"SR")=LEXSR_"^"_LEXNOM

 +20               SET ^TMP("LEXINFS",$JOB,LEXI,"OUT")=LEXCODE_"^"_LEXNOM_"^"_LEXEXP_"^"_LEXSIEN_"^"_LEXSR_"^"_LEXEX

 +21               SET LEXLEN=$LENGTH(LEXCODE)+$LENGTH(LEXNOM)+6

                   DO PR^LEXU(.LEXA,(70-LEXLEN))

 +22               SET LEXSTR=LEXCODE_"  ("_LEXNOM_")  "_LEXA(1)

 +23               SET ^TMP("LEXINFLK",$JOB,"DILIST","ID","LEX",LEXI,1)=LEXSTR

 +24               SET ^TMP("LEXINFS",$JOB,LEXI,"A",1)=LEXSTR

 +25               SET LEXCT=LEXCT+1

 +26               KILL LEXA(1)

                   IF $DATA(LEXA)

                       DO PR^LEXU(.LEXA,56)

                       Begin DoDot:2

 +27                       NEW LEXL

                           SET LEXL=0

FOR

                               SET LEXL=$ORDER(LEXA(LEXL))

                               if +LEXL'>0

                                   QUIT

                               Begin DoDot:3

 +28                               NEW LEXT,LEXS

                                   SET LEXT=$GET(LEXA(LEXL))

                                   if '$LENGTH(LEXT)

                                       QUIT

 +29                               SET LEXT="         "_LEXT

 +30                               SET LEXS=$ORDER(^TMP("LEXINFLK",$JOB,"DILIST","ID","LEX",LEXI," "),-1)+1

 +31                               SET ^TMP("LEXINFLK",$JOB,"DILIST","ID","LEX",LEXI,LEXS)=LEXT

 +32                               SET ^TMP("LEXINFS",$JOB,LEXI,"A",LEXS)=LEXT

                               End DoDot:3

                       End DoDot:2

 +33               SET ^TMP("LEXINFLK",$JOB,"DILIST","ID","MAT")=LEXCT

 +34               SET ^TMP("LEXINFS",$JOB,0)=LEXCT

               End DoDot:1

 +35       KILL ^TMP("LEXINFLK",$JOB),LEXMSG,LEXTAR

 +36       SET X=$$CODEASK

 +37       QUIT X

CODEASK(X) ;   Ask for Selection

 +1        NEW LEXIT,LEXL,LEXTOT,DTOUT,DUOUT,DIROUT,DIRUT

           SET LEXL=+($GET(X))

           if LEXL'>0

               SET LEXL=5

 +2        SET LEXTOT=+($GET(^TMP("LEXINFS",$JOB,0)))

           SET LEXIT=0

           if +LEXTOT'>0

               QUIT "^"

 +3        KILL X

           if +LEXTOT=1

               SET X=$$CODEO(LEXL)

           if +LEXTOT>1

               SET X=$$CODEM(LEXL)

           if +X<0

               QUIT X

 +4        IF +X>0

               IF $LENGTH($PIECE(X,"^",2))

                   IF $LENGTH($PIECE(X,"^",3))

                       Begin DoDot:1

 +5                        SET X=$PIECE(X,"^",2,4000)

                           WRITE "    ",$PIECE(X,"^",2)," code ",$PIECE(X,"^",1),!

                       End DoDot:1

 +6        QUIT X

CODEO(X,LEX) ;     One Code Found

 +1        if +($GET(LEXIT))>0

               QUIT "-1^Exit"

           NEW DIR,LEXI,LEXS,LEXC

           SET DIR("A",1)=" One match found"

           SET DIR("A",2)=" "

           SET LEXC=2

 +2        SET LEXI=1

           SET LEXS=0

           if '$DATA(^TMP("LEXINFS",$JOB,LEXI,"A",1))

               QUIT "-1^Nothing found"

 +3        FOR

               SET LEXS=$ORDER(^TMP("LEXINFS",$JOB,LEXI,"A",LEXS))

               if +LEXS'>0

                   QUIT

               Begin DoDot:1

 +4                NEW LEXT

                   SET LEXT=$GET(^TMP("LEXINFS",$JOB,LEXI,"A",LEXS))

                   SET LEXC=LEXC+1

 +5                if LEXC=3

                       SET DIR("A",LEXC)=("   "_LEXT)

                   if LEXC>3

                       SET DIR("A",LEXC)=("     "_LEXT)

               End DoDot:1

 +6        SET LEXC=LEXC+1

           SET DIR("A",LEXC)=" "

 +7        SET DIR("A")="  OK? (Yes/No)  "

           SET DIR("B")="Yes"

           SET DIR(0)="YAO"

           WRITE !

 +8        DO ^DIR

           if X["^^"!($DATA(DTOUT))

               SET LEXIT=1

           if $DATA(DTOUT)

               SET LEXIT=1

           if $DATA(DUOUT)!($DATA(DIROUT))!($DATA(DIRUT))

               SET LEXIT=1

 +9        if +$GET(Y)'>0

               SET LEXIT=1

           if $DATA(DTOUT)

               QUIT "-1^Timed out"

           if $DATA(DUOUT)!($DATA(DIROUT))!($DATA(DIRUT))

               QUIT "-1^Exit without selection"

 +10       if +$GET(Y)'>0

               QUIT "-1^No selection made"

           if X["^^"!(+($GET(LEXIT))>0)

               QUIT "-1^Aborted^"

 +11       SET X=$SELECT(+Y>0:$$OUT(1),1:"-1^Selection not made")

 +12       QUIT X

CODEM(X)  ;     Multiple Codes Found

 +1        if +($GET(LEXIT))>0

               QUIT "^^"

           NEW LEXI,LEXS,LEXL,LEXNM,LEXMAX,LEXLAST,LEXSS,LEXX,Y

 +2        SET (LEXMAX,LEXIT)=0

           SET LEXL=+($GET(X))

           SET U="^"

           if +($GET(LEXL))'>0

               SET LEXL=5

           SET LEXLAST=$ORDER(^TMP("LEXINFS",$JOB," "),-1)

 +3        SET LEXX=+($GET(^TMP("LEXINFS",$JOB,0)))

           SET LEXSS=0

           if +LEXX<2

               GOTO CODEMQ

           WRITE !

           if +LEXX>1

               WRITE !," ",LEXX," matches found"

           SET (LEXNM,LEXI)=0

 +4        FOR

               SET LEXI=$ORDER(^TMP("LEXINFS",$JOB,LEXI))

               if +LEXI'>0

                   QUIT

               if +LEXSS>0

                   QUIT

               if LEXIT>0

                   QUIT

               Begin DoDot:1

 +5                if LEXI#LEXL=1

                       WRITE !

                   DO CODEMW

 +6                SET LEXMAX=LEXI

                   if LEXI#LEXL=0

                       WRITE !

 +7                if LEXI#LEXL=0

                       SET LEXSS=$$CODEMS(LEXMAX)

                   if LEXIT>0

                       QUIT

 +8                IF LEXMAX=LEXLAST

                       IF LEXI#LEXL'=0

                           IF +LEXSS'<0

                               Begin DoDot:2

 +9                                WRITE !

                                   SET LEXSS=$$CODEMS(LEXMAX)

                               End DoDot:2

                               if LEXIT>0

                                   QUIT

               End DoDot:1

               if LEXIT>0

                   QUIT

               if +LEXSS>0

                   QUIT

 +10       GOTO CODEMQ

 +11       QUIT X

CODEMW    ;       Write Multiple

 +1        NEW LEXS

           SET LEXI=+($GET(LEXI))

           SET LEXS=0

FOR

               SET LEXS=$ORDER(^TMP("LEXINFS",$JOB,LEXI,"A",LEXS))

               if +LEXS'>0

                   QUIT

               Begin DoDot:1

 +2                NEW LEXT

                   SET LEXT=$GET(^TMP("LEXINFS",$JOB,LEXI,"A",LEXS))

                   if LEXS=1

                       SET LEXT=$JUSTIFY(+LEXI,5)_".  "_LEXT

 +3                if LEXS>1

                       SET LEXT="          "_LEXT

                   WRITE !,LEXT

               End DoDot:1

 +4        QUIT

CODEMS(X) ;       Select from Multiple Entries

 +1        NEW DIR,DIRB,LEXFI,LEXHLP,LEXLAST,LEXMAX,LEXS

 +2        if +($GET(LEXIT))>0

               QUIT "-1^Exit"

 +3        SET LEXMAX=+($GET(X))

           if LEXMAX=0

               QUIT "-1^No matches found"

 +4        SET LEXLAST=$ORDER(^TMP("LEXINFS",$JOB," "),-1)

 +5        IF +($ORDER(^TMP("LEXINFS",$JOB,LEXMAX)))>0

               Begin DoDot:1

 +6                SET DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"_LEXMAX_": "

               End DoDot:1

 +7        IF +($ORDER(^TMP("LEXINFS",$JOB,LEXMAX)))'>0

               Begin DoDot:1

 +8                SET DIR("A")=" Select 1-"_LEXMAX_": "

               End DoDot:1

 +9        SET LEXHLP=" Answer must be from 1 to "_LEXMAX_", or <Return> to continue"

 +10       SET DIR("PRE")="S:X[""?"" X=""??"""

 +11       SET (DIR("?"),DIR("??"))="^D CODEMSH^LEXINF4"

 +12       SET DIR(0)="NAO^1:"_LEXMAX_":0"

           DO ^DIR

 +13       IF (LEXLAST>LEXMAX)

               if '$LENGTH(X)&($DATA(DTOUT))

                   SET LEXIT=1

               if '$LENGTH(X)&($DATA(DTOUT))

                   QUIT "-1^Timed out"

 +14       if '$LENGTH(X)&(LEXLAST>LEXMAX)&('$DATA(DTOUT))

               QUIT ""

           if '$LENGTH(X)&(LEXLAST'>LEXMAX)&('$DATA(DTOUT))

               QUIT "-1^No selection made"

 +15       if X["^^"

               SET LEXIT=1

           if $DATA(DTOUT)

               SET LEXIT=1

           if $DATA(DUOUT)!($DATA(DIROUT))!($DATA(DIRUT))

               SET LEXIT=1

           if +$GET(Y)'>0

               SET LEXIT=1

 +16       if X["^^"

               QUIT "-1^Aborted without selection"

           if $DATA(DTOUT)

               QUIT "-1^Timed out"

 +17       if $DATA(DUOUT)!($DATA(DIROUT))!($DATA(DIRUT))

               QUIT "-1^Exit without selection"

 +18       if +$GET(Y)'>0

               QUIT "-1^No selection made"

           if X["^^"!(+($GET(LEXIT))>0)

               QUIT "-1^Aborted^"

 +19       QUIT $SELECT(+Y>0:$$OUT(+Y),1:"")

CODEMSH   ;       Select from Multiple Entries Help

 +1        IF $LENGTH($GET(LEXHLP))

               WRITE !,$GET(LEXHLP)

               QUIT

 +2        QUIT

CODEMQ    ;       Quit Multiple

 +1        SET X=$GET(LEXSS)

           if +($GET(LEXSS))'>0

               SET X="-1^No selection made"

           if +($GET(LEXSS))<0&($LENGTH($PIECE($GET(LEXSS),"^",2)))

               SET X=LEXSS

 +2        QUIT X

 +3       ;

 +4       ; Miscellaneous

OUT(X)    ;   Output Selection

 +1        NEW LEXFND,LEXCODE,LEXEXP,LEXNOM,LEXOUT,LEXI,LEXS,LEXC

           SET LEXFND=+($GET(X))

           if LEXFND'>0

               QUIT -1

           if '$DATA(^TMP("LEXINFS",$JOB,LEXFND))

               QUIT

 +2        SET LEXSO=$GET(^TMP("LEXINFS",$JOB,LEXFND,0))

           SET LEXEXP=$PIECE($GET(^TMP("LEXINFS",$JOB,LEXFND,"EX")),"^",2)

           SET LEXEX=$PIECE($GET(^TMP("LEXINFS",$JOB,LEXFND,"EX")),"^",1)

 +3        SET LEXCODE=$GET(^TMP("LEXINFS",$JOB,LEXFND,"SO"))

           SET LEXNOM=$PIECE($GET(^TMP("LEXINFS",$JOB,LEXFND,"SR")),"^",2)

           SET LEXSR=$PIECE($GET(^TMP("LEXINFS",$JOB,LEXFND,"SR")),"^",1)

 +4        if $LENGTH(LEXCODE)

               SET LEXOUT=LEXCODE_"^"_LEXNOM_"^"_LEXEXP_"^"_LEXSO_"^"_LEXSR_"^"_LEXEX

           if '$LENGTH(LEXCODE)

               SET LEXOUT=$GET(^TMP("LEXINFS",$JOB,LEXI,"OUT"))

           if '$LENGTH($PIECE(LEXOUT,"^",1))

               QUIT -1

 +5        SET X=LEXFND_"^"_LEXOUT

 +6        QUIT X

CONT(X,Y) ;   Ask to Continue

 +1        KILL DTOUT,DUOUT,DIRUT,DIROUT

           NEW LEXX,LEXFQ,LEXW,LEXI,LEXC,DIR

 +2        SET LEXX=$$UP^XLFSTR($GET(X))

           SET LEXFQ=$GET(Y)

           if '$LENGTH(LEXX)

               QUIT 1

           if LEXFQ'>0

               QUIT 1

 +3        SET LEXW(1)="Searching for """_LEXX_""" requires inspecting "

 +4        SET LEXW(2)=LEXFQ_" records to determine if they match the "

 +5        SET LEXW(3)="search criteria.  This could take quite some time."

 +6        SET LEXW(4)="Suggest refining the search by further specifying "

 +7        SET LEXW(5)=""""_LEXX_"."""

 +8        DO PR^LEXU(.LEXW,60)

           SET (LEXC,LEXI)=0

FOR

               SET LEXI=$ORDER(LEXW(LEXI))

               if +LEXI'>0

                   QUIT

               Begin DoDot:1

 +9                if '$LENGTH($GET(LEXW(LEXI)))

                       QUIT

                   SET LEXC=LEXC+1

                   SET DIR("A",LEXC)="   "_$GET(LEXW(LEXI))

               End DoDot:1

 +10       IF LEXC>0

               SET LEXC=LEXC+1

               SET DIR("A",LEXC)=" "

 +11       SET DIR("A")=" Do you wish to continue?  (Y/N)  "

           SET DIR("B")="No"

 +12       SET DIR(0)="YAO"

           SET (DIR("?"),DIR("??"))="^D COH^LEXINF4"

 +13       SET DIR("PRE")="S:X[""?"" X=""??"""

           WRITE !

           DO ^DIR

 +14       SET X=+Y

           if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))

               SET X="^"

 +15       QUIT X

COH       ;   Continue Help

 +1        IF $LENGTH($GET(LEXX))>0

               Begin DoDot:1

 +2                WRITE !,"   Enter   To"

 +3                WRITE !,"   'Yes'   continue searching for """,LEXX,"""."

 +4                WRITE !,"   'No'    refine the search (further specify)"

 +5                WRITE !,"   '^'     discontinue the search and exit"

               End DoDot:1

 +6        IF '$LENGTH($GET(LEXX))>0

               Begin DoDot:1

 +7                WRITE !,"   Enter   To"

 +8                WRITE !,"   'Yes'   continue the search"

 +9                WRITE !,"   'No'    refine the search (further specify)"

 +10               WRITE !,"   '^'     discontinue the search and exit"

               End DoDot:1

 +11       QUIT

DICW(X)   ;   DIC Write

 +1        NEW LEXSIEN,LEXSRC,LEXNOM

 +2        SET LEXSIEN=+($GET(Y))

           SET LEXSRC=$PIECE($GET(^LEX(757.02,+LEXSIEN,0)),"^",3)

           SET LEXNOM=$PIECE($GET(^LEX(757.03,+LEXSRC,0)),"^",2)

 +3        if '$LENGTH(LEXNOM)

               QUIT ""

           SET X="   ("_LEXNOM_")"

 +4        QUIT X

DICS(X)   ;   DIC Screen

 +1        NEW LEXSIEN

           SET LEXSIEN=+($GET(X))

           if $$PREOK(LEXSIEN)'>0

               QUIT 0

           if $$SABOK(LEXSIEN)'>0

               QUIT 0

 +2        QUIT 1

PREOK(X)  ;   Preferred Term OK

 +1        NEW LEXSIEN,LEXPRE

           SET LEXSIEN=+($GET(X))

           SET LEXPRE=+($PIECE($GET(^LEX(757.02,+LEXSIEN,0)),"^",5))

           if +LEXPRE'>0

               QUIT 0

 +2        QUIT 1

SABOK(X)  ;   Source OK

 +1        NEW LEXSIEN,LEXSBS,LEXSRC

           SET LEXSIEN=+($GET(X))

           SET LEXSRC=+($PIECE($GET(^LEX(757.02,+LEXSIEN,0)),"^",3))

           SET LEXSAB=$PIECE($GET(^LEX(757.03,+LEXSRC,0)),"^",1)

           if '$LENGTH(LEXSAB)

               QUIT 0

 +2        SET LEXSBS="^ICD^10D^ICP^10P^CPT^CPC^BIR^DS4^SCC^SCT^"

           if LEXSBS'[("^"_LEXSAB_"^")

               QUIT 0

 +3        QUIT 1

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

LEXINF4.m