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"
Q
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
Q
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
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"
Q
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 Dec 13, 2024@02:08:07 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
