LEXDDSP ;ISL/KER - Display Defaults - Single User Parse ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
;
; Global Variables
; ^LEX(757.41) N/A
; ^TMP("LEXDIC") SACC 2.3.2.5.1
;
; External References
; $$GET1^DIQ ICR 2056
; $$LOW^XLFSTR ICR 10104
;
DISP ; Display single user defaults
S:$D(ZTQUEUED) ZTREQ="@"
G:+($G(LEXAP))=0 EXIT S LEXAP=+LEXAP G:'$L($G(^LEXT(757.2,LEXAP,0))) EXIT
G:$P($G(^LEXT(757.2,LEXAP,5)),U,3)'=1 EXIT K LEX
D NAME,VOC,DIS,FIL,CTX,DSPLY^LEXDDSD
EXIT ; Cleanup/quit
K LEX,LEXV,LEXN,DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEX,^TMP("LEXDIC",$J) Q
;
NAME ; Name
N LEXV,LEXN S LEXV=$$GET1^DIQ(200,+($G(DUZ)),.01),LEXN=""
I LEXV["," S LEXN=$P(LEXV,",",2),LEXV=$P(LEXV,",",1)
S:LEXN'="" LEXN=$$MIXED(LEXN) S:LEXV'="" LEXV=$$MIXED(LEXV)
D NAME^LEXDDSS((LEXN_" "_LEXV)) Q
;
VOC ; Vocabulary
N LEXV,LEXN S LEXV=$G(^LEXT(757.2,LEXAP,200,DUZ,3)) S:LEXV="" LEXV="WRD"
S:$D(^LEXT(757.2,"AA",LEXV)) LEXN=$P(^LEXT(757.2,+($O(^LEXT(757.2,"AA",LEXV,0))),0),"^",1)
D VOC^LEXDDSS(LEXN)
Q
;
DIS ; Display Format
D LEXSHOW^LEXDDSD Q
;
FIL ; Filter
N LEXV D DICS($G(^LEXT(757.2,LEXAP,200,DUZ,1)))
K ^TMP("LEXDIC",$J) W:IOST["C-" @IOF S:$D(ZTQUEUED) ZTREQ="@"
Q
;
DICS(LEXV) ; Translate filter
Q:'$D(LEXV) N LEXS,LEXSHOW,LEXIN,LEXEX
I $G(LEXV)="" D FIL^LEXDDSS("No search filter defined") Q
S LEXS=LEXV D PARSE S:LEXV["SO^" LEXSHOW=LEXS
D FIL^LEXDDSS($G(^LEXT(757.2,LEXAP,200,DUZ,1.5)))
I $G(LEXS)=""!(LEXV="I 1") D
. N LEXDA S LEXDA=0
. F S LEXDA=$O(^LEX(757.11,LEXDA)) Q:+LEXDA=0 D
. . S LEXS=LEXS_"/"_$P(^LEX(757.11,LEXDA,0),U,1)
. S:$E(LEXS,1)="/" LEXS=$E(LEXS,2,$L(LEXS)) S LEXS=LEXS_";"
I LEXV["SC^"!(LEXV="I 1") D
. S:$L(LEXS,";")=3 LEXSHOW=$P(LEXS,";",3)
. D LB^LEXDDSS(" Look-up filter will: ")
. D INCEXC,DICS^LEXDDSD
I $G(LEXSHOW)'="" D
. I LEXV["SC^" D BLB^LEXDDSS(" Look-up filter will also include terms linked to:")
. I LEXV["SO^" D LB^LEXDDSS(" Look-up filter will include terms linked to: ")
. D CODES^LEXDDSD(LEXSHOW)
K ^TMP("LEXDIC",$J)
Q
PARSE ; Parse DIS("S") string into INCLUDE;EXCLUDE;LEXSHOW
S (LEXIN,LEXEX)="" S:LEXS["," LEXS=$P(LEXS,",",2)
S LEXS=$TR(LEXS,"()",""),LEXS=$TR(LEXS,"""","") Q
INCEXC ; Include/Exclude Components
S LEXIN=$P(LEXS,";",1),LEXEX=$P(LEXS,";",2) K ^TMP("LEXDIC",$J)
I $D(LEXIN),LEXIN'="",LEXIN["/" D
. N LEXI F LEXI=1:1:$L(LEXIN,"/") D
. . I +($P(LEXIN,"/",LEXI))=0 D
. . . S ^TMP("LEXDIC",$J,"INC","CLASS",$P(LEXIN,"/",LEXI))=""
. . I +($P(LEXIN,"/",LEXI))'=0 D
. . . S ^TMP("LEXDIC",$J,"INC","TYPE",$P(LEXIN,"/",LEXI))=""
I $D(LEXIN),LEXIN'="",LEXIN'["/" D
. I +LEXIN=0 S ^TMP("LEXDIC",$J,"INC","CLASS",LEXIN)="" Q
. S ^TMP("LEXDIC",$J,"INC","TYPE",LEXIN)=""
I $D(LEXEX),LEXEX'="",LEXEX["/" D
. N LEXI F LEXI=1:1:$L(LEXEX,"/") D
. . I +($P(LEXEX,"/",LEXI))=0 D
. . . S ^TMP("LEXDIC",$J,"EXC","CLASS",$P(LEXEX,"/",LEXI))=""
. . I +($P(LEXEX,"/",LEXI))'=0 D
. . . S ^TMP("LEXDIC",$J,"EXC","TYPE",$P(LEXEX,"/",LEXI))=""
I $D(LEXEX),LEXEX'="",LEXEX'["/" D
. I +LEXEX=0 S ^TMP("LEXDIC",$J,"EXC","CLASS",LEXEX)="" Q
. S ^TMP("LEXDIC",$J,"EXC","TYPE",LEXEX)=""
S LEXN="" F S LEXN=$O(^LEX(757.11,"B",LEXN)) Q:LEXN="" D
. Q:LEXIN[LEXN N LEXTT,LEXTI S LEXTI=1,LEXT=0
. F S LEXT=$O(^LEX(757.12,"C",LEXN,LEXT)) Q:+LEXT=0!(+LEXTI=0) D
. . I LEXIN[LEXT S LEXTI=0
. I LEXTI S ^TMP("LEXDIC",$J,"EXC","CLASS",LEXN)=""
Q
;
CTX ; Shortcut Context
N LEXV S LEXV=$G(^LEXT(757.2,LEXAP,200,DUZ,4.5)) I LEXV="" D
. N LEXN S LEXN=+($G(^LEXT(757.2,LEXAP,200,DUZ,4.5)))
. Q:+LEXN'>0 Q:'$D(^LEX(757.41,+LEXN))
. S LEXV=$P(^LEX(757.41,+LEXN,0),U,1)
D CON^LEXDDSS(LEXV)
Q
MIXED(LEXV) ; Convert UPPERCASE to Mixed case
S LEXV=$E(LEXV,1)_$$LOW^XLFSTR($E(LEXV,2,$L(LEXV)))
Q LEXV
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXDDSP 3901 printed Nov 22, 2024@17:17:35 Page 2
LEXDDSP ;ISL/KER - Display Defaults - Single User Parse ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.41) N/A
+5 ; ^TMP("LEXDIC") SACC 2.3.2.5.1
+6 ;
+7 ; External References
+8 ; $$GET1^DIQ ICR 2056
+9 ; $$LOW^XLFSTR ICR 10104
+10 ;
DISP ; Display single user defaults
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 if +($GET(LEXAP))=0
GOTO EXIT
SET LEXAP=+LEXAP
if '$LENGTH($GET(^LEXT(757.2,LEXAP,0)))
GOTO EXIT
+3 if $PIECE($GET(^LEXT(757.2,LEXAP,5)),U,3)'=1
GOTO EXIT
KILL LEX
+4 DO NAME
DO VOC
DO DIS
DO FIL
DO CTX
DO DSPLY^LEXDDSD
EXIT ; Cleanup/quit
+1 KILL LEX,LEXV,LEXN,DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEX,^TMP("LEXDIC",$JOB)
QUIT
+2 ;
NAME ; Name
+1 NEW LEXV,LEXN
SET LEXV=$$GET1^DIQ(200,+($GET(DUZ)),.01)
SET LEXN=""
+2 IF LEXV[","
SET LEXN=$PIECE(LEXV,",",2)
SET LEXV=$PIECE(LEXV,",",1)
+3 if LEXN'=""
SET LEXN=$$MIXED(LEXN)
if LEXV'=""
SET LEXV=$$MIXED(LEXV)
+4 DO NAME^LEXDDSS((LEXN_" "_LEXV))
QUIT
+5 ;
VOC ; Vocabulary
+1 NEW LEXV,LEXN
SET LEXV=$GET(^LEXT(757.2,LEXAP,200,DUZ,3))
if LEXV=""
SET LEXV="WRD"
+2 if $DATA(^LEXT(757.2,"AA",LEXV))
SET LEXN=$PIECE(^LEXT(757.2,+($ORDER(^LEXT(757.2,"AA",LEXV,0))),0),"^",1)
+3 DO VOC^LEXDDSS(LEXN)
+4 QUIT
+5 ;
DIS ; Display Format
+1 DO LEXSHOW^LEXDDSD
QUIT
+2 ;
FIL ; Filter
+1 NEW LEXV
DO DICS($GET(^LEXT(757.2,LEXAP,200,DUZ,1)))
+2 KILL ^TMP("LEXDIC",$JOB)
if IOST["C-"
WRITE @IOF
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 QUIT
+4 ;
DICS(LEXV) ; Translate filter
+1 if '$DATA(LEXV)
QUIT
NEW LEXS,LEXSHOW,LEXIN,LEXEX
+2 IF $GET(LEXV)=""
DO FIL^LEXDDSS("No search filter defined")
QUIT
+3 SET LEXS=LEXV
DO PARSE
if LEXV["SO^"
SET LEXSHOW=LEXS
+4 DO FIL^LEXDDSS($GET(^LEXT(757.2,LEXAP,200,DUZ,1.5)))
+5 IF $GET(LEXS)=""!(LEXV="I 1")
Begin DoDot:1
+6 NEW LEXDA
SET LEXDA=0
+7 FOR
SET LEXDA=$ORDER(^LEX(757.11,LEXDA))
if +LEXDA=0
QUIT
Begin DoDot:2
+8 SET LEXS=LEXS_"/"_$PIECE(^LEX(757.11,LEXDA,0),U,1)
End DoDot:2
+9 if $EXTRACT(LEXS,1)="/"
SET LEXS=$EXTRACT(LEXS,2,$LENGTH(LEXS))
SET LEXS=LEXS_";"
End DoDot:1
+10 IF LEXV["SC^"!(LEXV="I 1")
Begin DoDot:1
+11 if $LENGTH(LEXS,";")=3
SET LEXSHOW=$PIECE(LEXS,";",3)
+12 DO LB^LEXDDSS(" Look-up filter will: ")
+13 DO INCEXC
DO DICS^LEXDDSD
End DoDot:1
+14 IF $GET(LEXSHOW)'=""
Begin DoDot:1
+15 IF LEXV["SC^"
DO BLB^LEXDDSS(" Look-up filter will also include terms linked to:")
+16 IF LEXV["SO^"
DO LB^LEXDDSS(" Look-up filter will include terms linked to: ")
+17 DO CODES^LEXDDSD(LEXSHOW)
End DoDot:1
+18 KILL ^TMP("LEXDIC",$JOB)
+19 QUIT
PARSE ; Parse DIS("S") string into INCLUDE;EXCLUDE;LEXSHOW
+1 SET (LEXIN,LEXEX)=""
if LEXS[","
SET LEXS=$PIECE(LEXS,",",2)
+2 SET LEXS=$TRANSLATE(LEXS,"()","")
SET LEXS=$TRANSLATE(LEXS,"""","")
QUIT
INCEXC ; Include/Exclude Components
+1 SET LEXIN=$PIECE(LEXS,";",1)
SET LEXEX=$PIECE(LEXS,";",2)
KILL ^TMP("LEXDIC",$JOB)
+2 IF $DATA(LEXIN)
IF LEXIN'=""
IF LEXIN["/"
Begin DoDot:1
+3 NEW LEXI
FOR LEXI=1:1:$LENGTH(LEXIN,"/")
Begin DoDot:2
+4 IF +($PIECE(LEXIN,"/",LEXI))=0
Begin DoDot:3
+5 SET ^TMP("LEXDIC",$JOB,"INC","CLASS",$PIECE(LEXIN,"/",LEXI))=""
End DoDot:3
+6 IF +($PIECE(LEXIN,"/",LEXI))'=0
Begin DoDot:3
+7 SET ^TMP("LEXDIC",$JOB,"INC","TYPE",$PIECE(LEXIN,"/",LEXI))=""
End DoDot:3
End DoDot:2
End DoDot:1
+8 IF $DATA(LEXIN)
IF LEXIN'=""
IF LEXIN'["/"
Begin DoDot:1
+9 IF +LEXIN=0
SET ^TMP("LEXDIC",$JOB,"INC","CLASS",LEXIN)=""
QUIT
+10 SET ^TMP("LEXDIC",$JOB,"INC","TYPE",LEXIN)=""
End DoDot:1
+11 IF $DATA(LEXEX)
IF LEXEX'=""
IF LEXEX["/"
Begin DoDot:1
+12 NEW LEXI
FOR LEXI=1:1:$LENGTH(LEXEX,"/")
Begin DoDot:2
+13 IF +($PIECE(LEXEX,"/",LEXI))=0
Begin DoDot:3
+14 SET ^TMP("LEXDIC",$JOB,"EXC","CLASS",$PIECE(LEXEX,"/",LEXI))=""
End DoDot:3
+15 IF +($PIECE(LEXEX,"/",LEXI))'=0
Begin DoDot:3
+16 SET ^TMP("LEXDIC",$JOB,"EXC","TYPE",$PIECE(LEXEX,"/",LEXI))=""
End DoDot:3
End DoDot:2
End DoDot:1
+17 IF $DATA(LEXEX)
IF LEXEX'=""
IF LEXEX'["/"
Begin DoDot:1
+18 IF +LEXEX=0
SET ^TMP("LEXDIC",$JOB,"EXC","CLASS",LEXEX)=""
QUIT
+19 SET ^TMP("LEXDIC",$JOB,"EXC","TYPE",LEXEX)=""
End DoDot:1
+20 SET LEXN=""
FOR
SET LEXN=$ORDER(^LEX(757.11,"B",LEXN))
if LEXN=""
QUIT
Begin DoDot:1
+21 if LEXIN[LEXN
QUIT
NEW LEXTT,LEXTI
SET LEXTI=1
SET LEXT=0
+22 FOR
SET LEXT=$ORDER(^LEX(757.12,"C",LEXN,LEXT))
if +LEXT=0!(+LEXTI=0)
QUIT
Begin DoDot:2
+23 IF LEXIN[LEXT
SET LEXTI=0
End DoDot:2
+24 IF LEXTI
SET ^TMP("LEXDIC",$JOB,"EXC","CLASS",LEXN)=""
End DoDot:1
+25 QUIT
+26 ;
CTX ; Shortcut Context
+1 NEW LEXV
SET LEXV=$GET(^LEXT(757.2,LEXAP,200,DUZ,4.5))
IF LEXV=""
Begin DoDot:1
+2 NEW LEXN
SET LEXN=+($GET(^LEXT(757.2,LEXAP,200,DUZ,4.5)))
+3 if +LEXN'>0
QUIT
if '$DATA(^LEX(757.41,+LEXN))
QUIT
+4 SET LEXV=$PIECE(^LEX(757.41,+LEXN,0),U,1)
End DoDot:1
+5 DO CON^LEXDDSS(LEXV)
+6 QUIT
MIXED(LEXV) ; Convert UPPERCASE to Mixed case
+1 SET LEXV=$EXTRACT(LEXV,1)_$$LOW^XLFSTR($EXTRACT(LEXV,2,$LENGTH(LEXV)))
+2 QUIT LEXV
