LEXDD1 ;ISL/KER - Display Defaults ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
;
; Global Variables
; ^DIC(49) ICR 10093
;
; External References
; $$GET1^DIQ ICR 2056
; HOME^%ZIS ICR 10086
; ^%ZIS ICR 10086
; ^%ZISC ICR 10089
; ^%ZTLOAD ICR 10063
; ^DIR ICR 10026
;
SHOW ; Show user defaults
W @IOF
N LEXMODE,LEXUSER,LEXSERV
SELUSR ; Select user/user group
K LEXD,LEXMODE
W !!,"Show User Defaults for"
W !!," 1: All users with defaults"
W !," 2: A Single User"
W !," 3: Users in a Service",!
BYUSR ; Get response to user/user group
K ZTSAVE S LEXMODE=$$USR G:LEXMODE[U SHOWQ
I LEXMODE=1 D G SELUSR
. S ZTRTN="ALL^LEXDD1" D DEV,HOME^%ZIS
I LEXMODE=2 D G:+($G(LEXDUZ))'<1 SELUSR
. W ! S LEXDUZ=$$USER^LEXDM4,LEXDUZ=+LEXDUZ
. I +LEXDUZ'<1 D
. . S ZTRTN="ONE^LEXDD1"
. . S ZTSAVE("LEXDUZ")=""
. . D DEV,HOME^%ZIS
I LEXMODE=3 D G SELUSR
. W ! S LEXSERV=$$SERV^LEXDM4
. I +LEXSERV>0 D
. . S ZTRTN="SERV^LEXDD1"
. . S ZTSAVE("LEXSERV")=""
. . D DEV,HOME^%ZIS
G SHOWQ
Q
DEV ; Request a device
N LEXCNT,LEXLC,LEXC S (LEXCNT,LEXLC)=0,LEXC=""
S (ZTSAVE("LEXC"),ZTSAVE("LEXCNT"),ZTSAVE("LEXLC"))=""
N %ZIS,IOP S %ZIS="PQ" D ^%ZIS Q:POP I $D(IO("Q")) D QUE Q
NOQUE ; Local display
W @IOF D @ZTRTN,^%ZISC K ZTSAVE Q
QUE ; Queue task to a selected device
N %,ZTDESC,ZTDTH,ZTIO,ZTSK Q:'$D(ZTRTN) K IO("Q")
S ZTDESC="Lexicon Defaults",ZTIO=ION,ZTDTH=$H
D ^%ZTLOAD
W !,$S($D(ZTSK):"Request Queued",1:"Request Cancelled"),!
K ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE D ^%ZISC
Q
ALL ; Display for all users
N LEXUSR,LEXDUZ,LEXITLE
S LEXUSR=""
S LEXITLE="Lexicon User Defaults (all users with defaults)"
W !,LEXITLE W:IOST["P-" !! S LEXLC=$S(IOST["P-":LEXLC+3,1:LEXLC+1)
F S LEXUSR=$O(^LEXT(757.2,"AUD",LEXUSR)) Q:LEXUSR="" D
. N LEXDUZ S LEXDUZ=0
. F S LEXDUZ=$O(^LEXT(757.2,"AUD",LEXUSR,LEXDUZ)) Q:+LEXDUZ=0 D
. . I +LEXDUZ'<1 D
. . . S LEXOK=$$DEF I LEXOK D BUILD^LEXDD2 S LEXCNT=LEXCNT+1
I +LEXCNT=0 D
. W !!,"No users found with defaults set."
D ^%ZISC I $D(ZTQUEUED) S ZTREQ="@"
Q
ONE ; Display for one user
Q:+($G(LEXDUZ))<1 N LEXITLE,LEXOK,LEXNM
S LEXITLE="Lexicon User Defaults (Single User)"
W !,LEXITLE W:IOST["P-" !! S LEXLC=$S(IOST["P-":LEXLC+3,1:LEXLC+1)
S LEXNM=$$GET1^DIQ(200,+($G(LEXDUZ)),.01)
I LEXDUZ'<1,$L(LEXNM) D
. S LEXOK=$$DEF I LEXOK D BUILD^LEXDD2 S LEXCNT=LEXCNT+1
. I 'LEXOK D
. . I LEXNM'="" D
. . . N LEXNAME S LEXNAME=LEXNM
. . . S LEXNAME=$$FL^LEXDD4(LEXNAME)
. . . W !,LEXNAME," has no defaults set",!
. . I LEXNM="" D
. . . W !,"User has no defaults set",!
I LEXDUZ'<1,'$L(LEXNM) D
. W !,"User not found",!
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
SERV ; Display for users in a Service
Q:'$D(LEXSERV) N LEXITLE,LEXNM,LEXSV
S LEXSERV=+LEXSERV
S LEXITLE="Lexicon User Defaults in a Single Service ("_$P(^DIC(49,LEXSERV,0),U,1)_")"
W !,LEXITLE W:IOST["P-" !! S LEXLC=$S(IOST["P-":LEXLC+3,1:LEXLC+1)
S LEXUSR=""
F S LEXUSR=$O(^LEXT(757.2,"AUD",LEXUSR)) Q:LEXUSR="" D
. N LEXDUZ S LEXDUZ=0
. F S LEXDUZ=$O(^LEXT(757.2,"AUD",LEXUSR,LEXDUZ)) Q:+LEXDUZ=0 D
. . I +LEXDUZ'<1 D
. . . N LEXUSV S LEXUSV=$$GET1^DIQ(200,+($G(LEXDUZ)),29,"I")
. . . I LEXUSV=LEXSERV D
. . . . S LEXOK=$$DEF I LEXOK D BUILD^LEXDD2 S LEXCNT=LEXCNT+1
I +LEXCNT=0 D
. W !!,"No users found with defaults set in the ",$P(^DIC(49,LEXSERV,0),U,1)," service."
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
SHOWQ ; Quit SHOW
I IOST["P-" D ^%ZISC
K ZTSAVE,ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTREQ,ZTSK,X,Y
K DIR,DIC,DIC("S"),%,%ZIS,POP,IOP
K LEX,LEXA,LEXAP,LEXAPID,LEXC,LEXCNT,LEXCTR,LEXCTX,LEXD
K LEXDATA,LEXDICS,LEXDUZ,LEXFIL,LEXFN,LEXI,LEXIEN,LEXITL
K LEXITLE,LEXT,LEXLC,LEXLN,LEXMODE,LEXNAME,LEXOK,LEXSERV
K LEXSHOW,LEXSPC,LEXSTLN,LEXSTR,LEXSUB,LEXUSER,LEXUSR
Q
DEF(X) ; Based on DUZ determines if there are defaults defined
S X=0 Q:+($G(LEXDUZ))=0 X N LEXAPID,LEXIEN S LEXAPID=0
; Defaults by Application
F S LEXAPID=$O(^LEXT(757.2,"ADEF",LEXAPID)) Q:+LEXAPID=0!(X) D Q:X
. S LEXIEN=0 F S LEXIEN=$O(^LEXT(757.2,"ADEF",LEXAPID,LEXIEN)) Q:+LEXIEN=0!(X) D Q:X
. . S:$L($G(^LEXT(757.2,LEXIEN,200,LEXDUZ,1))) X=1 Q:X
. . S:$L($G(^LEXT(757.2,LEXIEN,200,LEXDUZ,2))) X=1 Q:X
. . S:$L($G(^LEXT(757.2,LEXIEN,200,LEXDUZ,3))) X=1 Q:X
. . S:$L($G(^LEXT(757.2,LEXIEN,200,LEXDUZ,4))) X=1 Q:X
Q X
USR(X) ; Get response for user type/group
N Y,DTOUT,DUOUT,DIRUT,DIROUT
S DIR("A")="Select (1-3): ",DIR("B")=2
S DIR("?")="Answer must be from 1 to 3"
S DIR(0)="NAO^1:3:0" D ^DIR
S X=$S($D(DTOUT)!(X[U)!(X=""):U,1:X) K DIR Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXDD1 4806 printed Apr 09, 2024@21:10:28 Page 2
LEXDD1 ;ISL/KER - Display Defaults ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^DIC(49) ICR 10093
+5 ;
+6 ; External References
+7 ; $$GET1^DIQ ICR 2056
+8 ; HOME^%ZIS ICR 10086
+9 ; ^%ZIS ICR 10086
+10 ; ^%ZISC ICR 10089
+11 ; ^%ZTLOAD ICR 10063
+12 ; ^DIR ICR 10026
+13 ;
SHOW ; Show user defaults
+1 WRITE @IOF
+2 NEW LEXMODE,LEXUSER,LEXSERV
SELUSR ; Select user/user group
+1 KILL LEXD,LEXMODE
+2 WRITE !!,"Show User Defaults for"
+3 WRITE !!," 1: All users with defaults"
+4 WRITE !," 2: A Single User"
+5 WRITE !," 3: Users in a Service",!
BYUSR ; Get response to user/user group
+1 KILL ZTSAVE
SET LEXMODE=$$USR
if LEXMODE[U
GOTO SHOWQ
+2 IF LEXMODE=1
Begin DoDot:1
+3 SET ZTRTN="ALL^LEXDD1"
DO DEV
DO HOME^%ZIS
End DoDot:1
GOTO SELUSR
+4 IF LEXMODE=2
Begin DoDot:1
+5 WRITE !
SET LEXDUZ=$$USER^LEXDM4
SET LEXDUZ=+LEXDUZ
+6 IF +LEXDUZ'<1
Begin DoDot:2
+7 SET ZTRTN="ONE^LEXDD1"
+8 SET ZTSAVE("LEXDUZ")=""
+9 DO DEV
DO HOME^%ZIS
End DoDot:2
End DoDot:1
if +($GET(LEXDUZ))'<1
GOTO SELUSR
+10 IF LEXMODE=3
Begin DoDot:1
+11 WRITE !
SET LEXSERV=$$SERV^LEXDM4
+12 IF +LEXSERV>0
Begin DoDot:2
+13 SET ZTRTN="SERV^LEXDD1"
+14 SET ZTSAVE("LEXSERV")=""
+15 DO DEV
DO HOME^%ZIS
End DoDot:2
End DoDot:1
GOTO SELUSR
+16 GOTO SHOWQ
+17 QUIT
DEV ; Request a device
+1 NEW LEXCNT,LEXLC,LEXC
SET (LEXCNT,LEXLC)=0
SET LEXC=""
+2 SET (ZTSAVE("LEXC"),ZTSAVE("LEXCNT"),ZTSAVE("LEXLC"))=""
+3 NEW %ZIS,IOP
SET %ZIS="PQ"
DO ^%ZIS
if POP
QUIT
IF $DATA(IO("Q"))
DO QUE
QUIT
NOQUE ; Local display
+1 WRITE @IOF
DO @ZTRTN
DO ^%ZISC
KILL ZTSAVE
QUIT
QUE ; Queue task to a selected device
+1 NEW %,ZTDESC,ZTDTH,ZTIO,ZTSK
if '$DATA(ZTRTN)
QUIT
KILL IO("Q")
+2 SET ZTDESC="Lexicon Defaults"
SET ZTIO=ION
SET ZTDTH=$HOROLOG
+3 DO ^%ZTLOAD
+4 WRITE !,$SELECT($DATA(ZTSK):"Request Queued",1:"Request Cancelled"),!
+5 KILL ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
DO ^%ZISC
+6 QUIT
ALL ; Display for all users
+1 NEW LEXUSR,LEXDUZ,LEXITLE
+2 SET LEXUSR=""
+3 SET LEXITLE="Lexicon User Defaults (all users with defaults)"
+4 WRITE !,LEXITLE
if IOST["P-"
WRITE !!
SET LEXLC=$SELECT(IOST["P-":LEXLC+3,1:LEXLC+1)
+5 FOR
SET LEXUSR=$ORDER(^LEXT(757.2,"AUD",LEXUSR))
if LEXUSR=""
QUIT
Begin DoDot:1
+6 NEW LEXDUZ
SET LEXDUZ=0
+7 FOR
SET LEXDUZ=$ORDER(^LEXT(757.2,"AUD",LEXUSR,LEXDUZ))
if +LEXDUZ=0
QUIT
Begin DoDot:2
+8 IF +LEXDUZ'<1
Begin DoDot:3
+9 SET LEXOK=$$DEF
IF LEXOK
DO BUILD^LEXDD2
SET LEXCNT=LEXCNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+10 IF +LEXCNT=0
Begin DoDot:1
+11 WRITE !!,"No users found with defaults set."
End DoDot:1
+12 DO ^%ZISC
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+13 QUIT
ONE ; Display for one user
+1 if +($GET(LEXDUZ))<1
QUIT
NEW LEXITLE,LEXOK,LEXNM
+2 SET LEXITLE="Lexicon User Defaults (Single User)"
+3 WRITE !,LEXITLE
if IOST["P-"
WRITE !!
SET LEXLC=$SELECT(IOST["P-":LEXLC+3,1:LEXLC+1)
+4 SET LEXNM=$$GET1^DIQ(200,+($GET(LEXDUZ)),.01)
+5 IF LEXDUZ'<1
IF $LENGTH(LEXNM)
Begin DoDot:1
+6 SET LEXOK=$$DEF
IF LEXOK
DO BUILD^LEXDD2
SET LEXCNT=LEXCNT+1
+7 IF 'LEXOK
Begin DoDot:2
+8 IF LEXNM'=""
Begin DoDot:3
+9 NEW LEXNAME
SET LEXNAME=LEXNM
+10 SET LEXNAME=$$FL^LEXDD4(LEXNAME)
+11 WRITE !,LEXNAME," has no defaults set",!
End DoDot:3
+12 IF LEXNM=""
Begin DoDot:3
+13 WRITE !,"User has no defaults set",!
End DoDot:3
End DoDot:2
End DoDot:1
+14 IF LEXDUZ'<1
IF '$LENGTH(LEXNM)
Begin DoDot:1
+15 WRITE !,"User not found",!
End DoDot:1
+16 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+17 QUIT
SERV ; Display for users in a Service
+1 if '$DATA(LEXSERV)
QUIT
NEW LEXITLE,LEXNM,LEXSV
+2 SET LEXSERV=+LEXSERV
+3 SET LEXITLE="Lexicon User Defaults in a Single Service ("_$PIECE(^DIC(49,LEXSERV,0),U,1)_")"
+4 WRITE !,LEXITLE
if IOST["P-"
WRITE !!
SET LEXLC=$SELECT(IOST["P-":LEXLC+3,1:LEXLC+1)
+5 SET LEXUSR=""
+6 FOR
SET LEXUSR=$ORDER(^LEXT(757.2,"AUD",LEXUSR))
if LEXUSR=""
QUIT
Begin DoDot:1
+7 NEW LEXDUZ
SET LEXDUZ=0
+8 FOR
SET LEXDUZ=$ORDER(^LEXT(757.2,"AUD",LEXUSR,LEXDUZ))
if +LEXDUZ=0
QUIT
Begin DoDot:2
+9 IF +LEXDUZ'<1
Begin DoDot:3
+10 NEW LEXUSV
SET LEXUSV=$$GET1^DIQ(200,+($GET(LEXDUZ)),29,"I")
+11 IF LEXUSV=LEXSERV
Begin DoDot:4
+12 SET LEXOK=$$DEF
IF LEXOK
DO BUILD^LEXDD2
SET LEXCNT=LEXCNT+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+13 IF +LEXCNT=0
Begin DoDot:1
+14 WRITE !!,"No users found with defaults set in the ",$PIECE(^DIC(49,LEXSERV,0),U,1)," service."
End DoDot:1
+15 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+16 QUIT
SHOWQ ; Quit SHOW
+1 IF IOST["P-"
DO ^%ZISC
+2 KILL ZTSAVE,ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTREQ,ZTSK,X,Y
+3 KILL DIR,DIC,DIC("S"),%,%ZIS,POP,IOP
+4 KILL LEX,LEXA,LEXAP,LEXAPID,LEXC,LEXCNT,LEXCTR,LEXCTX,LEXD
+5 KILL LEXDATA,LEXDICS,LEXDUZ,LEXFIL,LEXFN,LEXI,LEXIEN,LEXITL
+6 KILL LEXITLE,LEXT,LEXLC,LEXLN,LEXMODE,LEXNAME,LEXOK,LEXSERV
+7 KILL LEXSHOW,LEXSPC,LEXSTLN,LEXSTR,LEXSUB,LEXUSER,LEXUSR
+8 QUIT
DEF(X) ; Based on DUZ determines if there are defaults defined
+1 SET X=0
if +($GET(LEXDUZ))=0
QUIT X
NEW LEXAPID,LEXIEN
SET LEXAPID=0
+2 ; Defaults by Application
+3 FOR
SET LEXAPID=$ORDER(^LEXT(757.2,"ADEF",LEXAPID))
if +LEXAPID=0!(X)
QUIT
Begin DoDot:1
+4 SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEXT(757.2,"ADEF",LEXAPID,LEXIEN))
if +LEXIEN=0!(X)
QUIT
Begin DoDot:2
+5 if $LENGTH($GET(^LEXT(757.2,LEXIEN,200,LEXDUZ,1)))
SET X=1
if X
QUIT
+6 if $LENGTH($GET(^LEXT(757.2,LEXIEN,200,LEXDUZ,2)))
SET X=1
if X
QUIT
+7 if $LENGTH($GET(^LEXT(757.2,LEXIEN,200,LEXDUZ,3)))
SET X=1
if X
QUIT
+8 if $LENGTH($GET(^LEXT(757.2,LEXIEN,200,LEXDUZ,4)))
SET X=1
if X
QUIT
End DoDot:2
if X
QUIT
End DoDot:1
if X
QUIT
+9 QUIT X
USR(X) ; Get response for user type/group
+1 NEW Y,DTOUT,DUOUT,DIRUT,DIROUT
+2 SET DIR("A")="Select (1-3): "
SET DIR("B")=2
+3 SET DIR("?")="Answer must be from 1 to 3"
+4 SET DIR(0)="NAO^1:3:0"
DO ^DIR
+5 SET X=$SELECT($DATA(DTOUT)!(X[U)!(X=""):U,1:X)
KILL DIR
QUIT X
