LEXDM2.m

LEXDM2 ;ISL/KER - Default Misc - Ask to delete ;04/21/2014

 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1

 ;               

 ; Global Variables

 ;    ^LEX(757.31)        N/A

 ;    ^LEX(757.41)        N/A

 ;               

 ; External References

 ;    $$GET1^DIQ          ICR   2056

 ;    $$UP^XLFSTR         ICR  10103

 ;    ^DIR                ICR  10026

 ;               

 ; Entry:  S X=$$EN^LEXDM2(USER,AP,DEF)

 ;

 ; Input   

 ;         USER    DUZ

 ;         AP      Application

 ;         DEF     Default (1 thru 4)

 ;

 ; Returns

 ;         0       Do not Delete default

 ;         1       Delete default

 ;

EN(LEXUSER,LEXAP,LEXDEF) ;

 ; A few good reasons to quit

 Q:+($G(LEXUSER))=0 0  Q:'$L($$GET1^DIQ(200,+($G(DUZ)),.01)) 0

 Q:+($G(LEXAP))=0 0  Q:'$D(^LEXT(757.2,+($G(LEXAP)))) 0

 Q:+($P($G(^LEXT(757.2,+LEXAP,5)),"^",3))'>0 0

 Q:+($G(LEXDEF))<1!(+($G(LEXDEF))>4) 0

 ; Check for default

 N LEXOV,LEXN S LEXN=""

 S LEXOV=$G(^LEXT(757.2,LEXAP,200,LEXUSER,LEXDEF))

 S LEXN=$G(^LEXT(757.2,LEXAP,200,LEXUSER,(LEXDEF+.5)))

 Q:LEXOV="" 0 D:$L(LEXOV) ASK Q LEXDEF

 ;

ASK ; Ask to delete

 W ! N LEXYPE,DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y S LEXYPE=$S(LEXDEF=1:"filter",LEXDEF=2:"display",LEXDEF=3:"vocabulary",1:"shortcut context")

 I LEXN="" S:LEXDEF=1 LEXN=$$N1(LEXOV) S:LEXDEF=2 LEXN=$$N2(LEXOV) S:LEXDEF=3 LEXN=$$N3(LEXOV) S:LEXDEF=4 LEXN=$$N4(LEXOV)

 S DIR("A",1)="You did not select"_$S(LEXDEF=1:"/create",LEXDEF=2:"/create",1:"")_" a default "_$$UP^XLFSTR(LEXYPE)_", however you already"

 S DIR("A",2)="have a default "_$$UP^XLFSTR(LEXYPE)_" on file.  Did you want to delete"

 S DIR("A",3)="your current default?",DIR("A",4)="",DIR("A",5)="   "_LEXN,DIR("A",6)=""

 S DIR("A")="Delete?  ",DIR("B")="NO",DIR(0)="YAO" D ^DIR K DIR S LEXDEF=+Y Q

 ;

 ; Get default names (N1, N2, N3, and N4)

 ;

 ;   Input   LEXX - The actual value for the default

 ;   Returns LEXX - The name of the default value

 ;

N1(LEXX) ; Filter name

 Q:'$L($G(LEXX)) "Unknown filter"

 N LEXSS,LEXN,LEXSO,LEXI,LEXSP S LEXN="",LEXSP=0,LEXSS=$E(LEXX,1,63)

 S LEXSO=$E(LEXSS,1,($L(LEXSS)-1))_$C($A($E(LEXSS,$L(LEXSS)))-1)_"~"

 F  S LEXSO=$O(^LEX(757.3,"AS",LEXSO)) Q:+LEXSP!(LEXSO'[LEXSS)  D

 . S LEXI=0 F  S LEXI=$O(^LEX(757.3,"AS",LEXSO,LEXI)) Q:+LEXI=0!(+LEXSP'=0)  D

 . . S:$G(^LEX(757.3,+LEXI,1))=LEXX LEXSP=LEXI

 . . S:+LEXSP>0 LEXN=$P($G(^LEX(757.3,+LEXSP,0)),"^",1)

 S LEXX=$S($L(LEXN):LEXN,1:"User defined") Q LEXX

N2(LEXX) ; Display name

 Q:'$L($G(LEXX)) "Unknown display"

 N LEXDP,LEXDS,LEXN S LEXDP=0,LEXN="",LEXDS=$E(LEXX,1,63)

 S LEXDS=$E(LEXDS,1,($L(LEXDS)-1))_$C($A($E(LEXDS,1,$L(LEXDS)))-1)_"~"

 F  S LEXDS=$O(^LEX(757.31,"ADSP",LEXDS)) Q:LEXDS'[LEXX!($L($G(LEXN)))  D

 . S LEXDP=0 F  S LEXDP=$O(^LEX(757.31,"ADSP",LEXDS,LEXDP)) Q:+LEXDP=0!($L($G(LEXN)))  D

 . . I ^LEX(757.31,+LEXDP,1)=LEXX S LEXN=$P(^LEX(757.31,+LEXDP,0),"^",1)

 S LEXX=$S($L(LEXN):LEXN,1:"User defined") Q LEXX

N3(LEXX) ; Vocabulary name

 Q:'$L($G(LEXX)) "Unknown vocabulary"

 Q:'$D(^LEXT(757.2,"AA",LEXX)) "Unknown vocabulary"

 N LEXN S LEXN=$P($G(^LEXT(757.2,$O(^LEXT(757.2,"AA",LEXX,0)),0)),"^",1)

 S LEXX=$S($L(LEXN):LEXN,1:"Unknown vocabulary") Q LEXX

N4(LEXX) ; Context name

 Q:'$L($G(LEXX)) "Unknown context" Q:+LEXX=0 "Unknown context"

 Q:'$D(^LEX(757.41,LEXX)) "Unknown context" N LEXN S LEXN=$P($G(^LEX(757.41,+LEXX,0)),"^",1)

 S LEXX=$S($L(LEXN):LEXN,1:"Unknown context") Q LEXX

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LEXDM2   3423     printed  Feb 18, 2025@23:33:52                                                                                                                                                                                                      Page 2

LEXDM2    ;ISL/KER - Default Misc - Ask to delete ;04/21/2014

 +1       ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1

 +2       ;               

 +3       ; Global Variables

 +4       ;    ^LEX(757.31)        N/A

 +5       ;    ^LEX(757.41)        N/A

 +6       ;               

 +7       ; External References

 +8       ;    $$GET1^DIQ          ICR   2056

 +9       ;    $$UP^XLFSTR         ICR  10103

 +10      ;    ^DIR                ICR  10026

 +11      ;               

 +12      ; Entry:  S X=$$EN^LEXDM2(USER,AP,DEF)

 +13      ;

 +14      ; Input   

 +15      ;         USER    DUZ

 +16      ;         AP      Application

 +17      ;         DEF     Default (1 thru 4)

 +18      ;

 +19      ; Returns

 +20      ;         0       Do not Delete default

 +21      ;         1       Delete default

 +22      ;

EN(LEXUSER,LEXAP,LEXDEF) ;

 +1       ; A few good reasons to quit

 +2        if +($GET(LEXUSER))=0

               QUIT 0

           if '$LENGTH($$GET1^DIQ(200,+($GET(DUZ)),.01))

               QUIT 0

 +3        if +($GET(LEXAP))=0

               QUIT 0

           if '$DATA(^LEXT(757.2,+($GET(LEXAP))))

               QUIT 0

 +4        if +($PIECE($GET(^LEXT(757.2,+LEXAP,5)),"^",3))'>0

               QUIT 0

 +5        if +($GET(LEXDEF))<1!(+($GET(LEXDEF))>4)

               QUIT 0

 +6       ; Check for default

 +7        NEW LEXOV,LEXN

           SET LEXN=""

 +8        SET LEXOV=$GET(^LEXT(757.2,LEXAP,200,LEXUSER,LEXDEF))

 +9        SET LEXN=$GET(^LEXT(757.2,LEXAP,200,LEXUSER,(LEXDEF+.5)))

 +10       if LEXOV=""

               QUIT 0

           if $LENGTH(LEXOV)

               DO ASK

           QUIT LEXDEF

 +11      ;

ASK       ; Ask to delete

 +1        WRITE !

           NEW LEXYPE,DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y

           SET LEXYPE=$SELECT(LEXDEF=1:"filter",LEXDEF=2:"display",LEXDEF=3:"vocabulary",1:"shortcut context")

 +2        IF LEXN=""

               if LEXDEF=1

                   SET LEXN=$$N1(LEXOV)

               if LEXDEF=2

                   SET LEXN=$$N2(LEXOV)

               if LEXDEF=3

                   SET LEXN=$$N3(LEXOV)

               if LEXDEF=4

                   SET LEXN=$$N4(LEXOV)

 +3        SET DIR("A",1)="You did not select"_$SELECT(LEXDEF=1:"/create",LEXDEF=2:"/create",1:"")_" a default "_$$UP^XLFSTR(LEXYPE)_", however you already"

 +4        SET DIR("A",2)="have a default "_$$UP^XLFSTR(LEXYPE)_" on file.  Did you want to delete"

 +5        SET DIR("A",3)="your current default?"

           SET DIR("A",4)=""

           SET DIR("A",5)="   "_LEXN

           SET DIR("A",6)=""

 +6        SET DIR("A")="Delete?  "

           SET DIR("B")="NO"

           SET DIR(0)="YAO"

           DO ^DIR

           KILL DIR

           SET LEXDEF=+Y

           QUIT 

 +7       ;

 +8       ; Get default names (N1, N2, N3, and N4)

 +9       ;

 +10      ;   Input   LEXX - The actual value for the default

 +11      ;   Returns LEXX - The name of the default value

 +12      ;

N1(LEXX)  ; Filter name

 +1        if '$LENGTH($GET(LEXX))

               QUIT "Unknown filter"

 +2        NEW LEXSS,LEXN,LEXSO,LEXI,LEXSP

           SET LEXN=""

           SET LEXSP=0

           SET LEXSS=$EXTRACT(LEXX,1,63)

 +3        SET LEXSO=$EXTRACT(LEXSS,1,($LENGTH(LEXSS)-1))_$CHAR($ASCII($EXTRACT(LEXSS,$LENGTH(LEXSS)))-1)_"~"

 +4        FOR 

               SET LEXSO=$ORDER(^LEX(757.3,"AS",LEXSO))

               if +LEXSP!(LEXSO'[LEXSS)

                   QUIT 

               Begin DoDot:1

 +5                SET LEXI=0

                   FOR 

                       SET LEXI=$ORDER(^LEX(757.3,"AS",LEXSO,LEXI))

                       if +LEXI=0!(+LEXSP'=0)

                           QUIT 

                       Begin DoDot:2

 +6                        if $GET(^LEX(757.3,+LEXI,1))=LEXX

                               SET LEXSP=LEXI

 +7                        if +LEXSP>0

                               SET LEXN=$PIECE($GET(^LEX(757.3,+LEXSP,0)),"^",1)

                       End DoDot:2

               End DoDot:1

 +8        SET LEXX=$SELECT($LENGTH(LEXN):LEXN,1:"User defined")

           QUIT LEXX

N2(LEXX)  ; Display name

 +1        if '$LENGTH($GET(LEXX))

               QUIT "Unknown display"

 +2        NEW LEXDP,LEXDS,LEXN

           SET LEXDP=0

           SET LEXN=""

           SET LEXDS=$EXTRACT(LEXX,1,63)

 +3        SET LEXDS=$EXTRACT(LEXDS,1,($LENGTH(LEXDS)-1))_$CHAR($ASCII($EXTRACT(LEXDS,1,$LENGTH(LEXDS)))-1)_"~"

 +4        FOR 

               SET LEXDS=$ORDER(^LEX(757.31,"ADSP",LEXDS))

               if LEXDS'[LEXX!($LENGTH($GET(LEXN)))

                   QUIT 

               Begin DoDot:1

 +5                SET LEXDP=0

                   FOR 

                       SET LEXDP=$ORDER(^LEX(757.31,"ADSP",LEXDS,LEXDP))

                       if +LEXDP=0!($LENGTH($GET(LEXN)))

                           QUIT 

                       Begin DoDot:2

 +6                        IF ^LEX(757.31,+LEXDP,1)=LEXX

                               SET LEXN=$PIECE(^LEX(757.31,+LEXDP,0),"^",1)

                       End DoDot:2

               End DoDot:1

 +7        SET LEXX=$SELECT($LENGTH(LEXN):LEXN,1:"User defined")

           QUIT LEXX

N3(LEXX)  ; Vocabulary name

 +1        if '$LENGTH($GET(LEXX))

               QUIT "Unknown vocabulary"

 +2        if '$DATA(^LEXT(757.2,"AA",LEXX))

               QUIT "Unknown vocabulary"

 +3        NEW LEXN

           SET LEXN=$PIECE($GET(^LEXT(757.2,$ORDER(^LEXT(757.2,"AA",LEXX,0)),0)),"^",1)

 +4        SET LEXX=$SELECT($LENGTH(LEXN):LEXN,1:"Unknown vocabulary")

           QUIT LEXX

N4(LEXX)  ; Context name

 +1        if '$LENGTH($GET(LEXX))

               QUIT "Unknown context"

           if +LEXX=0

               QUIT "Unknown context"

 +2        if '$DATA(^LEX(757.41,LEXX))

               QUIT "Unknown context"

           NEW LEXN

           SET LEXN=$PIECE($GET(^LEX(757.41,+LEXX,0)),"^",1)

 +3        SET LEXX=$SELECT($LENGTH(LEXN):LEXN,1:"Unknown context")

           QUIT LEXX