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 ---[H[J[2J[HLEXDM2 3423 printed Oct 16, 2024@18:08:29 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
