- 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 Feb 18, 2025@23:35:45 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