- 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 Mar 13, 2025@21:11:58 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
