LEXSET5 ;ISL/KER - Setup Appl/User Defaults for Look-up ;04/21/2014
;;2.0;LEXICON UTILITY;**6,11,80**;Sep 23, 1996;Build 1
;
; Global Variables
; ^DIC(49) ICR 10093
; ^DISV( ICR 510
; ^SC( ICR 10040
; ^TMP("LEXSCH") SACC 2.3.2.5.1
;
; External References
; $$GET1^DIQ ICR 2056
; ^DIR ICR 10026
; ^XTLKKWL ICR 10122
;
EN ; Set variables
D:+($G(LEXQ))=0 MTLU
D:+($G(LEXQ))=1 QUIET
K LEXD
Q
QUIET ;
N LEXMP S LEXMP="" D DIC0
I $L($G(LEXD("DF","LEXAP"))) S ^TMP("LEXSCH",$J,"APP",0)=LEXD("DF","LEXAP"),^TMP("LEXSCH",$J,"APP",1)=$$APPN^LEXDFN(LEXD("DF","LEXAP"))
I $L($G(LEXD("DF","DIS"))) S ^TMP("LEXSCH",$J,"DIS",0)=LEXD("DF","DIS"),^TMP("LEXSCH",$J,"DIS",1)=$$DISN^LEXDFN(LEXD("DF","DIS"))
I $L($G(LEXD("DF","FIL"))) S ^TMP("LEXSCH",$J,"FIL",0)=LEXD("DF","FIL"),^TMP("LEXSCH",$J,"FIL",1)=$$FILN^LEXDFN(LEXD("DF","FIL"))
I $L($G(LEXD("DF","GBL"))) S (DIC,^TMP("LEXSCH",$J,"GBL",0))=LEXD("DF","GBL"),^TMP("LEXSCH",$J,"GBL",1)=$$GBLN^LEXDFN(LEXD("DF","GBL"))
I $L($G(LEXD("DF","IDX"))) S ^TMP("LEXSCH",$J,"IDX",0)=LEXD("DF","IDX"),^TMP("LEXSCH",$J,"IDX",1)=$$IDXN^LEXDFN(LEXD("DF","IDX"))
I $L($G(LEXD("DF","OVR"))) S ^TMP("LEXSCH",$J,"OVR",0)=LEXD("DF","OVR"),^TMP("LEXSCH",$J,"OVR",1)=$$OVRN^LEXDFN(LEXD("DF","OVR"))
I $L($G(LEXD("DF","SCT"))) S ^TMP("LEXSCH",$J,"SCT",0)=LEXD("DF","SCT"),^TMP("LEXSCH",$J,"SCT",1)=$$SCTN^LEXDFN(LEXD("DF","SCT"))
I $L($G(LEXD("DF","UNR"))) S ^TMP("LEXSCH",$J,"UNR",0)=LEXD("DF","UNR"),^TMP("LEXSCH",$J,"UNR",1)=$$UNRN^LEXDFN(LEXD("DF","UNR"))
; Modifiers PCH 6
I $L($G(LEXD("DF","MOD"))) S ^TMP("LEXSCH",$J,"MOD",0)=LEXD("DF","MOD"),^TMP("LEXSCH",$J,"MOD",1)=$$MODI^LEXDFN(LEXD("DF","MOD"))
I $L($G(LEXD("DF","VOC"))) S ^TMP("LEXSCH",$J,"VOC",0)=LEXD("DF","VOC"),^TMP("LEXSCH",$J,"VOC",1)=$$VOCN^LEXDFN(LEXD("DF","VOC"))
I '$L($G(LEXD("DF","VOC"))),$L($G(LEXD("DF","SUB"))) S ^TMP("LEXSCH",$J,"VOC",0)=LEXD("DF","SUB"),^TMP("LEXSCH",$J,"VOC",1)=$$VOCN^LEXDFN(LEXD("DF","SUB"))
I $L($G(LEXD("DF","FLN"))) S ^TMP("LEXSCH",$J,"FLN",0)=LEXD("DF","FLN"),^TMP("LEXSCH",$J,"FLN",1)="File Number"
I +($G(LEXLL))>0 S ^TMP("LEXSCH",$J,"LEN",0)=+LEXLL
I +($G(LEXLL))'>0 S ^TMP("LEXSCH",$J,"LEN",0)=5
S ^TMP("LEXSCH",$J,"LEN",1)="List Length"
N LEXLOC,LEXSVC S (LEXLOC,LEXSVC)=""
I +($G(DUZ))>0,'$L($$GET1^DIQ(200,+($G(DUZ)),.01)) D
. S LEXLOC="" S:+($G(LEXLOC))=0 LEXLOC=""
. S:$L($G(LEXLOC))&(+($G(LEXLOC))>0) LEXLOC=$P($G(^SC(LEXLOC,0)),U,1)
. S LEXSVC=$$GET1^DIQ(200,+($G(DUZ)),29) S:+($G(LEXSVC))=0 LEXSVC=""
. S:$L($G(LEXSVC))&(+($G(LEXSVC))>0) LEXSVC=$P($G(^DIC(49,LEXSVC,0)),U,1)
S ^TMP("LEXSCH",$J,"LOC",0)=$E(LEXLOC,1,40),^TMP("LEXSCH",$J,"LOC",1)="User Hospital Location"
S ^TMP("LEXSCH",$J,"SVC",0)=$E(LEXSVC,1,40),^TMP("LEXSCH",$J,"SVC",1)="User Service"
S ^TMP("LEXSCH",$J,"USR",0)=+($G(DUZ)),^TMP("LEXSCH",$J,"USR",1)="User"
Q
Q
MTLU ; MTLU Defaults
K LEXSHOW,LEXSUB,XTLKGBL,XTLKKSCH S DIC=""
S:$L($G(LEXD("DF","GBL"))) (DIC,XTLKGBL,XTLKKSCH("GBL"))=LEXD("DF","GBL")
S:$L($G(LEXD("DF","DSP"))) XTLKKSCH("DSPLY")=LEXD("DF","DSP")
S:$L($G(LEXD("DF","IDX"))) XTLKKSCH("INDEX")=LEXD("DF","IDX")
S:$L($G(LEXD("DF","HLP"))) XTLKHLP=LEXD("DF","HLP")
S:$L($G(LEXD("DF","LEXAP"))) LEXAP=LEXD("DF","LEXAP")
S:$L($G(LEXD("DF","UNR"))) LEXUN=LEXD("DF","UNR")
S:$L($G(LEXD("DF","DIS"))) LEXSHOW=LEXD("DF","DIS")
S:$L($G(LEXD("DF","SUB"))) LEXSUB=LEXD("DF","SUB")
S:$L($G(LEXD("DF","FIL"))) DIC("S")=LEXD("DF","FIL")
I DIC=""!('$D(LEXSUB)) D
. S (DIC,XTLKGBL,XTLKKSCH("GBL"))="^LEX(757.01,"
. S XTLKKSCH("INDEX")="AWRD",XTLKKSCH("DSPLY")="XTLK^LEXPRNT"
. S XTLKHLP="D XTLK^LEXHLP",LEXAP=1,LEXLL=5,LEXUN=0
. S:$L($G(^LEXT(757.2,1,200,+($G(DUZ)),1))) DIC("S")=$G(^LEXT(757.2,1,200,+($G(DUZ)),1))
. S LEXSUB="WRD",LEXSHOW="ICD/CPT"
. S:$L($G(^LEXT(757.2,1,200,+($G(DUZ)),2))) LEXSHOW=$G(^LEXT(757.2,1,200,+($G(DUZ)),2))
S XTLKSAY=0 D DIC0 S:$L($G(X)) XTLKX=X
Q
DIC0 S:'$L($G(DIC(0))) DIC(0)="EQM"
S:'$L($G(X))&(DIC(0)'["A") DIC(0)="A"_DIC(0)
S:DIC(0)["L" DIC(0)=$P(DIC(0),"L",1)_$P(DIC(0),"L",2)
S:DIC(0)["I" DIC(0)=$P(DIC(0),"I",1)_$P(DIC(0),"L",2)
Q
XTLK ; MTLU
N LEXQ S LEXQ=0 D MTLU
I '$D(X)!($G(X)[U)!($G(X)="")!($G(X)=" ") S X=$$TERM
Q:X=""!(X["^") S XTLKX=X D ^XTLKKWL
K DIC,LEXAP,LEXLL,LEXSHOW,LEXSUB,LEXUN
K XTLKKSCH,XTLKSAY,XTLKWD2,XTLKX,XTLKHLP S:+Y'>0 X=""
Q
TERM(X) ; Expression
N DIR,Y S DIR("A")="Enter an expression: "
S DIR("?")=" "_$$SQ^LEXHLP ; PCH 11
S DIR("??")="^D TERMHLP^LEXSET5" N Y S DIR(0)="FAO^2:245" D ^DIR
S DIC="^LEX(757.01," S:X[U&(X'["^^") X=U S:X["^^" X="^^" Q:X[U "^"
I X=" ",+($G(^DISV(+($G(DUZ)),DIC)))>0 S X=@(DIC_+($G(^DISV(+($G(DUZ)),DIC)))_",0)") W " ",X
F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
W:$D(DTOUT) !,"Try later.",! S:$D(DTOUT) X=""
S:X[U DUOUT=1 K DIR,DIRUT,DIROUT Q X
TERMHLP ; Help PCH 11
N X S X="" S:$L($G(DIR("?"))) X=$G(DIR("?")) S:'$L(X) X=" "_$$SQ^LEXHLP
W:$L(X) !!,X,!
W !," Best results occur using one to three full or partial words without"
W !," a suffix (i.e., ""DIABETES"",""DIAB MELL"",""DIAB MELL INSUL"") or"
W !," a classification code (ICD, CPT, HCPCS, etc)"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXSET5 5308 printed Apr 09, 2024@21:14:25 Page 2
LEXSET5 ;ISL/KER - Setup Appl/User Defaults for Look-up ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**6,11,80**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^DIC(49) ICR 10093
+5 ; ^DISV( ICR 510
+6 ; ^SC( ICR 10040
+7 ; ^TMP("LEXSCH") SACC 2.3.2.5.1
+8 ;
+9 ; External References
+10 ; $$GET1^DIQ ICR 2056
+11 ; ^DIR ICR 10026
+12 ; ^XTLKKWL ICR 10122
+13 ;
EN ; Set variables
+1 if +($GET(LEXQ))=0
DO MTLU
+2 if +($GET(LEXQ))=1
DO QUIET
+3 KILL LEXD
+4 QUIT
QUIET ;
+1 NEW LEXMP
SET LEXMP=""
DO DIC0
+2 IF $LENGTH($GET(LEXD("DF","LEXAP")))
SET ^TMP("LEXSCH",$JOB,"APP",0)=LEXD("DF","LEXAP")
SET ^TMP("LEXSCH",$JOB,"APP",1)=$$APPN^LEXDFN(LEXD("DF","LEXAP"))
+3 IF $LENGTH($GET(LEXD("DF","DIS")))
SET ^TMP("LEXSCH",$JOB,"DIS",0)=LEXD("DF","DIS")
SET ^TMP("LEXSCH",$JOB,"DIS",1)=$$DISN^LEXDFN(LEXD("DF","DIS"))
+4 IF $LENGTH($GET(LEXD("DF","FIL")))
SET ^TMP("LEXSCH",$JOB,"FIL",0)=LEXD("DF","FIL")
SET ^TMP("LEXSCH",$JOB,"FIL",1)=$$FILN^LEXDFN(LEXD("DF","FIL"))
+5 IF $LENGTH($GET(LEXD("DF","GBL")))
SET (DIC,^TMP("LEXSCH",$JOB,"GBL",0))=LEXD("DF","GBL")
SET ^TMP("LEXSCH",$JOB,"GBL",1)=$$GBLN^LEXDFN(LEXD("DF","GBL"))
+6 IF $LENGTH($GET(LEXD("DF","IDX")))
SET ^TMP("LEXSCH",$JOB,"IDX",0)=LEXD("DF","IDX")
SET ^TMP("LEXSCH",$JOB,"IDX",1)=$$IDXN^LEXDFN(LEXD("DF","IDX"))
+7 IF $LENGTH($GET(LEXD("DF","OVR")))
SET ^TMP("LEXSCH",$JOB,"OVR",0)=LEXD("DF","OVR")
SET ^TMP("LEXSCH",$JOB,"OVR",1)=$$OVRN^LEXDFN(LEXD("DF","OVR"))
+8 IF $LENGTH($GET(LEXD("DF","SCT")))
SET ^TMP("LEXSCH",$JOB,"SCT",0)=LEXD("DF","SCT")
SET ^TMP("LEXSCH",$JOB,"SCT",1)=$$SCTN^LEXDFN(LEXD("DF","SCT"))
+9 IF $LENGTH($GET(LEXD("DF","UNR")))
SET ^TMP("LEXSCH",$JOB,"UNR",0)=LEXD("DF","UNR")
SET ^TMP("LEXSCH",$JOB,"UNR",1)=$$UNRN^LEXDFN(LEXD("DF","UNR"))
+10 ; Modifiers PCH 6
+11 IF $LENGTH($GET(LEXD("DF","MOD")))
SET ^TMP("LEXSCH",$JOB,"MOD",0)=LEXD("DF","MOD")
SET ^TMP("LEXSCH",$JOB,"MOD",1)=$$MODI^LEXDFN(LEXD("DF","MOD"))
+12 IF $LENGTH($GET(LEXD("DF","VOC")))
SET ^TMP("LEXSCH",$JOB,"VOC",0)=LEXD("DF","VOC")
SET ^TMP("LEXSCH",$JOB,"VOC",1)=$$VOCN^LEXDFN(LEXD("DF","VOC"))
+13 IF '$LENGTH($GET(LEXD("DF","VOC")))
IF $LENGTH($GET(LEXD("DF","SUB")))
SET ^TMP("LEXSCH",$JOB,"VOC",0)=LEXD("DF","SUB")
SET ^TMP("LEXSCH",$JOB,"VOC",1)=$$VOCN^LEXDFN(LEXD("DF","SUB"))
+14 IF $LENGTH($GET(LEXD("DF","FLN")))
SET ^TMP("LEXSCH",$JOB,"FLN",0)=LEXD("DF","FLN")
SET ^TMP("LEXSCH",$JOB,"FLN",1)="File Number"
+15 IF +($GET(LEXLL))>0
SET ^TMP("LEXSCH",$JOB,"LEN",0)=+LEXLL
+16 IF +($GET(LEXLL))'>0
SET ^TMP("LEXSCH",$JOB,"LEN",0)=5
+17 SET ^TMP("LEXSCH",$JOB,"LEN",1)="List Length"
+18 NEW LEXLOC,LEXSVC
SET (LEXLOC,LEXSVC)=""
+19 IF +($GET(DUZ))>0
IF '$LENGTH($$GET1^DIQ(200,+($GET(DUZ)),.01))
Begin DoDot:1
+20 SET LEXLOC=""
if +($GET(LEXLOC))=0
SET LEXLOC=""
+21 if $LENGTH($GET(LEXLOC))&(+($GET(LEXLOC))>0)
SET LEXLOC=$PIECE($GET(^SC(LEXLOC,0)),U,1)
+22 SET LEXSVC=$$GET1^DIQ(200,+($GET(DUZ)),29)
if +($GET(LEXSVC))=0
SET LEXSVC=""
+23 if $LENGTH($GET(LEXSVC))&(+($GET(LEXSVC))>0)
SET LEXSVC=$PIECE($GET(^DIC(49,LEXSVC,0)),U,1)
End DoDot:1
+24 SET ^TMP("LEXSCH",$JOB,"LOC",0)=$EXTRACT(LEXLOC,1,40)
SET ^TMP("LEXSCH",$JOB,"LOC",1)="User Hospital Location"
+25 SET ^TMP("LEXSCH",$JOB,"SVC",0)=$EXTRACT(LEXSVC,1,40)
SET ^TMP("LEXSCH",$JOB,"SVC",1)="User Service"
+26 SET ^TMP("LEXSCH",$JOB,"USR",0)=+($GET(DUZ))
SET ^TMP("LEXSCH",$JOB,"USR",1)="User"
+27 QUIT
+28 QUIT
MTLU ; MTLU Defaults
+1 KILL LEXSHOW,LEXSUB,XTLKGBL,XTLKKSCH
SET DIC=""
+2 if $LENGTH($GET(LEXD("DF","GBL")))
SET (DIC,XTLKGBL,XTLKKSCH("GBL"))=LEXD("DF","GBL")
+3 if $LENGTH($GET(LEXD("DF","DSP")))
SET XTLKKSCH("DSPLY")=LEXD("DF","DSP")
+4 if $LENGTH($GET(LEXD("DF","IDX")))
SET XTLKKSCH("INDEX")=LEXD("DF","IDX")
+5 if $LENGTH($GET(LEXD("DF","HLP")))
SET XTLKHLP=LEXD("DF","HLP")
+6 if $LENGTH($GET(LEXD("DF","LEXAP")))
SET LEXAP=LEXD("DF","LEXAP")
+7 if $LENGTH($GET(LEXD("DF","UNR")))
SET LEXUN=LEXD("DF","UNR")
+8 if $LENGTH($GET(LEXD("DF","DIS")))
SET LEXSHOW=LEXD("DF","DIS")
+9 if $LENGTH($GET(LEXD("DF","SUB")))
SET LEXSUB=LEXD("DF","SUB")
+10 if $LENGTH($GET(LEXD("DF","FIL")))
SET DIC("S")=LEXD("DF","FIL")
+11 IF DIC=""!('$DATA(LEXSUB))
Begin DoDot:1
+12 SET (DIC,XTLKGBL,XTLKKSCH("GBL"))="^LEX(757.01,"
+13 SET XTLKKSCH("INDEX")="AWRD"
SET XTLKKSCH("DSPLY")="XTLK^LEXPRNT"
+14 SET XTLKHLP="D XTLK^LEXHLP"
SET LEXAP=1
SET LEXLL=5
SET LEXUN=0
+15 if $LENGTH($GET(^LEXT(757.2,1,200,+($GET(DUZ)),1)))
SET DIC("S")=$GET(^LEXT(757.2,1,200,+($GET(DUZ)),1))
+16 SET LEXSUB="WRD"
SET LEXSHOW="ICD/CPT"
+17 if $LENGTH($GET(^LEXT(757.2,1,200,+($GET(DUZ)),2)))
SET LEXSHOW=$GET(^LEXT(757.2,1,200,+($GET(DUZ)),2))
End DoDot:1
+18 SET XTLKSAY=0
DO DIC0
if $LENGTH($GET(X))
SET XTLKX=X
+19 QUIT
DIC0 if '$LENGTH($GET(DIC(0)))
SET DIC(0)="EQM"
+1 if '$LENGTH($GET(X))&(DIC(0)'["A")
SET DIC(0)="A"_DIC(0)
+2 if DIC(0)["L"
SET DIC(0)=$PIECE(DIC(0),"L",1)_$PIECE(DIC(0),"L",2)
+3 if DIC(0)["I"
SET DIC(0)=$PIECE(DIC(0),"I",1)_$PIECE(DIC(0),"L",2)
+4 QUIT
XTLK ; MTLU
+1 NEW LEXQ
SET LEXQ=0
DO MTLU
+2 IF '$DATA(X)!($GET(X)[U)!($GET(X)="")!($GET(X)=" ")
SET X=$$TERM
+3 if X=""!(X["^")
QUIT
SET XTLKX=X
DO ^XTLKKWL
+4 KILL DIC,LEXAP,LEXLL,LEXSHOW,LEXSUB,LEXUN
+5 KILL XTLKKSCH,XTLKSAY,XTLKWD2,XTLKX,XTLKHLP
if +Y'>0
SET X=""
+6 QUIT
TERM(X) ; Expression
+1 NEW DIR,Y
SET DIR("A")="Enter an expression: "
+2 ; PCH 11
SET DIR("?")=" "_$$SQ^LEXHLP
+3 SET DIR("??")="^D TERMHLP^LEXSET5"
NEW Y
SET DIR(0)="FAO^2:245"
DO ^DIR
+4 SET DIC="^LEX(757.01,"
if X[U&(X'["^^")
SET X=U
if X["^^"
SET X="^^"
if X[U
QUIT "^"
+5 IF X=" "
IF +($GET(^DISV(+($GET(DUZ)),DIC)))>0
SET X=@(DIC_+($GET(^DISV(+($GET(DUZ)),DIC)))_",0)")
WRITE " ",X
+6 FOR
if $EXTRACT(X,1)'=" "
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+7 if $DATA(DTOUT)
WRITE !,"Try later.",!
if $DATA(DTOUT)
SET X=""
+8 if X[U
SET DUOUT=1
KILL DIR,DIRUT,DIROUT
QUIT X
TERMHLP ; Help PCH 11
+1 NEW X
SET X=""
if $LENGTH($GET(DIR("?")))
SET X=$GET(DIR("?"))
if '$LENGTH(X)
SET X=" "_$$SQ^LEXHLP
+2 if $LENGTH(X)
WRITE !!,X,!
+3 WRITE !," Best results occur using one to three full or partial words without"
+4 WRITE !," a suffix (i.e., ""DIABETES"",""DIAB MELL"",""DIAB MELL INSUL"") or"
+5 WRITE !," a classification code (ICD, CPT, HCPCS, etc)"
+6 QUIT
