XQSMD4 ; SEA/MJM,JLI - Edit a user's options ;01/25/2008
;;8.0;KERNEL;**510**;Jul 10, 1995;Build 6
; Per VHA Directive 2004-038, this routine should not be modified.
; Option: XQSMD BUILD MENU
BUILD ;
N XQNMSP,XQOPT
I '$D(^VA(200,DUZ,19.5,"B")) W !!?7,$C(7),"You haven't been delegated any options with which to build a menu." Q
D NAMESP(.XQNMSP) Q:'$D(XQNMSP)
D ASKOPT(.XQOPT,"M") Q:'$D(XQOPT)
I XQOPT("NEW") D NEW(.XQOPT) Q
D OLD(.XQOPT)
Q
ASKOPT(XQOPT,XQTYPE) ;
N XQOPNM
D ASKNAME(.XQOPNM,.XQNMSP,XQTYPE) Q:'$D(XQOPNM)
D ADDFIND(XQOPNM,.XQOPT) Q:'$D(XQOPT)
Q
ADDFIND(X,XQOPT) ;
N DIC,Y,DLAYGO
S DIC(0)="MLE",DIC=19,DLAYGO=19
D ^DIC Q:Y<0
S XQOPT("NAME")=$P(Y,U,2)
S XQOPT("IEN")=+Y
S XQOPT("NEW")=$P(Y,U,3)
Q
NEW(XQOPT) ;
N DIE,DA,DIC,DR,DLAYGO,X,Y
S DIE=19,DR="1;3.5;4///M;",DA=XQOPT("IEN") D ^DIE ; Enter as new option and force type to be menu
S DIC="^VA(200,DUZ,19.5,",X=XQOPT("NAME"),DIC(0)="MLX",DA(1)=DUZ,DLAYGO=200 D ^DIC Q:Y'>0
D EDIT(.XQOPT)
Q
OLD(XQOPT) ;
I $P(^DIC(19,XQOPT("IEN"),0),U,4)'="M" W !,$C(7),"This option already exists but is not a MENU." Q
I '$D(^VA(200,DUZ,19.5,XQOPT("IEN"),0)) W !,$C(7),"This option already exists but is not included in your delegated options.",!,"Choose another option name or get this option delegated to yourself." Q
D EDIT(.XQOPT)
Q
EDIT(XQOPT) ;
N XQOUT
W !!,"You may only include options that have been delegated as items to you.",!
S XQOUT=0
F D Q:XQOUT
. N DIC,X,Y,XQITEM,XQITEMNM
. I $D(^DIC(19,XQOPT("IEN"),10,"B")) D SHOWITEM
. S DIC("A")="Select Menu Item: "
. S DIC("S")="I +Y'="_XQOPT("IEN") ; Don't select the option as a menu item
. S DIC(0)="AEQMZ"
. S DIC="^VA(200,DUZ,19.5,"
. D ^DIC I Y<0 S XQOUT=1 Q
. S XQITEM("IEN")=+Y ; Menu Item IEN
. S XQITEM("NAME")=Y(0,0) ; Menu Item Name
. I $D(^DIC(19,XQOPT("IEN"),10,"B",XQITEM("IEN"))) D Q
. . N DIK,DA ; If already there, remove it from menu
. . S DIK="^DIC(19,"_XQOPT("IEN")_",10,",DA(1)=XQOPT("IEN"),DA=$O(^DIC(19,XQOPT("IEN"),10,"B",XQITEM("IEN"),0)) D ^DIK
. . W !,$C(7),"Menu item ",XQITEM("NAME")," deleted from menu."
. . I '$D(^DIC(19,XQOPT("IEN"),10,"B")) D
. . . W !,"This menu contains no menu items."
. . . W !,"It will be deleted if you don't add a menu item."
. . W !
. N X,Y,DIC,DLAYGO,DA,D0
. S X=XQITEM("NAME")
. S DIC(0)="EQML"
. S DLAYGO=19,(D0,DA(1))=XQOPT("IEN")
. S DIC="^DIC(19,"_XQOPT("IEN")_",10,"
. D ^DIC I Y<0 W ! Q
. N DIE,DR,DA
. S DR="2:3;" ; Set SYNONYM and DISPLAY ORDER
. S DIE=DIC,DA=+Y,DA(1)=XQOPT("IEN") D ^DIE
. W !
Q:$O(^DIC(19,XQOPT("IEN"),10,0))
I $D(^VA(200,"AP",XQOPT("IEN"))),'$G(XQOPT("NEW")) D Q
. D NODEL(.XQOPT)
. W !,"These users now have a Primary Menu with no menu items!",$C(7)
. W !,"Recommend you add some menu items to it."
D DELETE(.XQOPT)
W !!?7,$C(7),"Empty menu removed from option file and your delegated options.",!
Q
SHOWITEM ;
N I,XQREC,XQREC0
W !,"This menu contains the following menu items. You may add a new menu item."
W !,"If you select an existing menu item, it will be deleted from the menu.",!
S I=0
F S I=$O(^DIC(19,XQOPT("IEN"),10,I)) Q:'I S XQREC=^(I,0) D
. S XQREC0=^DIC(19,+XQREC,0)
. W !,?3,$P(XQREC0,U),?40,$P(XQREC,U,2),?46,$P(XQREC0,U,2)
W !
Q
NODEL(XQOPT) ; called by ^XQSMDFM, too
N I
W !!,"This option is used as a Primary Menu for:"
S I=0
F S I=$O(^VA(200,"AP",XQOPT("IEN"),I)) Q:'I W !?10,$P(^VA(200,I,0),U)
W !,"Can't delete it while it is used as a primary menu."
Q
DELETE(XQOPT) ; called by ^XQSMDFM, too
N DIK,DA
I $G(XQOPT("NEW")) D
. S DIK="^VA(200,DUZ,19.5,",DA(1)=DUZ,DA=XQOPT("IEN") D ^DIK
E D
. N XQJ
. S XQJ=0
. ; Delete option from all menus
. F S XQJ=$O(^DIC(19,"AD",XQOPT("IEN"),XQJ)) Q:'XQJ S DA=$O(^(XQJ,0)),DA(1)=XQJ,DIK="^DIC(19,DA(1),10," D ^DIK
. ; Delete option as a secondary menu option for all users
. F S XQJ=$O(^VA(200,"AD",XQOPT("IEN"),XQJ)) Q:'XQJ S DA=$O(^(XQJ,0)),DA(1)=XQJ,DIK="^VA(200,DA(1),203," D ^DIK
. ; Delete option as delegated option for all users
. F S XQJ=$O(^VA(200,XQJ)) Q:'XQJ I $D(^(XQJ,19.5,"B",XQOPT("IEN"))) S DA=XQOPT("IEN"),DA(1)=XQJ,DIK="^VA(200,DA(1),19.5," D ^DIK
S DIK="^DIC(19,",DA=XQOPT("IEN") D ^DIK ; Delete option
Q
NAMESP(XQNMSP) ; Check for available namespaces. Called by ^XQSMDFM, too.
N I
S I=0
F S I=$O(^VA(200,DUZ,19.6,"B",I)) Q:I="" S XQNMSP=$G(XQNMSP)+1,XQNMSP(I)=""
I $D(XQNMSP) D HLPNAME Q
I $D(^VA(200,DUZ,19.6)) K ^(19.6)
W !!?7,$C(7),"No namespace(s) have been set up for you to build new menus.",!?7,"Contact your computer service representative."
Q
HLPNAME ;
N I
W !?7,"The options you build or edit must begin with ",$S(XQNMSP>1:"one of ",1:""),!?7,"the following namespace",$S(XQNMSP>1:"(s)",1:"")," and be no more than 30 characters long:",!
S I=""
F S I=$O(XQNMSP(I)) Q:I="" W !?35,$S($E(I,1)="A":I,1:I_"Z")
W !
Q:"^P^I^E^M^"'[(U_$G(XQTYPE)_U)
N I,XQM,XQREC
S I=0
F S I=$O(^VA(200,DUZ,19.5,"B",I)) Q:'I D
. S XQREC=$G(^DIC(19,I,0)) Q:$P(XQREC,U,4)'=XQTYPE
. S XQM($P(XQREC,U))=$P(XQREC,U,2)
I '$D(XQM) W !?7,"You have no existing delegated "_$$TYPE(XQTYPE)_" options. You may enter a new one." Q
W !,"The following are your existing delegated "_$$TYPE(XQTYPE)_" options:"
F S I=$O(XQM(I)) Q:I="" W !,I,?40,XQM(I)
Q
TYPE(XQT) ;
Q $S(XQT="P":"Print",XQT="I":"Inquire",XQT="E":"Edit",1:"Menu")
ASKNAME(XQOPNM,XQNMSP,XQTYPE) ;Check for a valid option names.
;Called by ^XQSMDFM, too.
;XU*8*428 also allows for local namespaces, e.g., A5A, AFS, etc.
F D Q:$D(DIRUT)!$D(XQOPNM)
. N DIR,X,Y
. S DIR("A")="Option Name"
. S DIR("PRE")="D CHKNAME^XQSMD4"
. S DIR("?")="^D HLPNAME^XQSMD4"
. S DIR(0)="F^3:30"
. D ^DIR Q:$D(DIRUT)
. S XQOPNM=Y
Q
CHKNAME ;
I $D(DTOUT)!(X[U)!(X["?") Q
I X="" S X=U Q
N I
S I=""
F S I=$O(XQNMSP(I)) Q:I="" Q:$E(I,1)="A"&($E(X,1,$L(I))=I) Q:$E(X,1,$L(I))=I&($E(X,$L(I)+1)="Z")
Q:I'=""
W $C(7),!!?7,$E(X,1,4),"* is not a valid namespace for you.",!
K X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQSMD4 6081 printed Dec 13, 2024@02:06:33 Page 2
XQSMD4 ; SEA/MJM,JLI - Edit a user's options ;01/25/2008
+1 ;;8.0;KERNEL;**510**;Jul 10, 1995;Build 6
+2 ; Per VHA Directive 2004-038, this routine should not be modified.
+3 ; Option: XQSMD BUILD MENU
BUILD ;
+1 NEW XQNMSP,XQOPT
+2 IF '$DATA(^VA(200,DUZ,19.5,"B"))
WRITE !!?7,$CHAR(7),"You haven't been delegated any options with which to build a menu."
QUIT
+3 DO NAMESP(.XQNMSP)
if '$DATA(XQNMSP)
QUIT
+4 DO ASKOPT(.XQOPT,"M")
if '$DATA(XQOPT)
QUIT
+5 IF XQOPT("NEW")
DO NEW(.XQOPT)
QUIT
+6 DO OLD(.XQOPT)
+7 QUIT
ASKOPT(XQOPT,XQTYPE) ;
+1 NEW XQOPNM
+2 DO ASKNAME(.XQOPNM,.XQNMSP,XQTYPE)
if '$DATA(XQOPNM)
QUIT
+3 DO ADDFIND(XQOPNM,.XQOPT)
if '$DATA(XQOPT)
QUIT
+4 QUIT
ADDFIND(X,XQOPT) ;
+1 NEW DIC,Y,DLAYGO
+2 SET DIC(0)="MLE"
SET DIC=19
SET DLAYGO=19
+3 DO ^DIC
if Y<0
QUIT
+4 SET XQOPT("NAME")=$PIECE(Y,U,2)
+5 SET XQOPT("IEN")=+Y
+6 SET XQOPT("NEW")=$PIECE(Y,U,3)
+7 QUIT
NEW(XQOPT) ;
+1 NEW DIE,DA,DIC,DR,DLAYGO,X,Y
+2 ; Enter as new option and force type to be menu
SET DIE=19
SET DR="1;3.5;4///M;"
SET DA=XQOPT("IEN")
DO ^DIE
+3 SET DIC="^VA(200,DUZ,19.5,"
SET X=XQOPT("NAME")
SET DIC(0)="MLX"
SET DA(1)=DUZ
SET DLAYGO=200
DO ^DIC
if Y'>0
QUIT
+4 DO EDIT(.XQOPT)
+5 QUIT
OLD(XQOPT) ;
+1 IF $PIECE(^DIC(19,XQOPT("IEN"),0),U,4)'="M"
WRITE !,$CHAR(7),"This option already exists but is not a MENU."
QUIT
+2 IF '$DATA(^VA(200,DUZ,19.5,XQOPT("IEN"),0))
WRITE !,$CHAR(7),"This option already exists but is not included in your delegated options.",!,"Choose another option name or get this option delegated to yourself."
QUIT
+3 DO EDIT(.XQOPT)
+4 QUIT
EDIT(XQOPT) ;
+1 NEW XQOUT
+2 WRITE !!,"You may only include options that have been delegated as items to you.",!
+3 SET XQOUT=0
+4 FOR
Begin DoDot:1
+5 NEW DIC,X,Y,XQITEM,XQITEMNM
+6 IF $DATA(^DIC(19,XQOPT("IEN"),10,"B"))
DO SHOWITEM
+7 SET DIC("A")="Select Menu Item: "
+8 ; Don't select the option as a menu item
SET DIC("S")="I +Y'="_XQOPT("IEN")
+9 SET DIC(0)="AEQMZ"
+10 SET DIC="^VA(200,DUZ,19.5,"
+11 DO ^DIC
IF Y<0
SET XQOUT=1
QUIT
+12 ; Menu Item IEN
SET XQITEM("IEN")=+Y
+13 ; Menu Item Name
SET XQITEM("NAME")=Y(0,0)
+14 IF $DATA(^DIC(19,XQOPT("IEN"),10,"B",XQITEM("IEN")))
Begin DoDot:2
+15 ; If already there, remove it from menu
NEW DIK,DA
+16 SET DIK="^DIC(19,"_XQOPT("IEN")_",10,"
SET DA(1)=XQOPT("IEN")
SET DA=$ORDER(^DIC(19,XQOPT("IEN"),10,"B",XQITEM("IEN"),0))
DO ^DIK
+17 WRITE !,$CHAR(7),"Menu item ",XQITEM("NAME")," deleted from menu."
+18 IF '$DATA(^DIC(19,XQOPT("IEN"),10,"B"))
Begin DoDot:3
+19 WRITE !,"This menu contains no menu items."
+20 WRITE !,"It will be deleted if you don't add a menu item."
End DoDot:3
+21 WRITE !
End DoDot:2
QUIT
+22 NEW X,Y,DIC,DLAYGO,DA,D0
+23 SET X=XQITEM("NAME")
+24 SET DIC(0)="EQML"
+25 SET DLAYGO=19
SET (D0,DA(1))=XQOPT("IEN")
+26 SET DIC="^DIC(19,"_XQOPT("IEN")_",10,"
+27 DO ^DIC
IF Y<0
WRITE !
QUIT
+28 NEW DIE,DR,DA
+29 ; Set SYNONYM and DISPLAY ORDER
SET DR="2:3;"
+30 SET DIE=DIC
SET DA=+Y
SET DA(1)=XQOPT("IEN")
DO ^DIE
+31 WRITE !
End DoDot:1
if XQOUT
QUIT
+32 if $ORDER(^DIC(19,XQOPT("IEN"),10,0))
QUIT
+33 IF $DATA(^VA(200,"AP",XQOPT("IEN")))
IF '$GET(XQOPT("NEW"))
Begin DoDot:1
+34 DO NODEL(.XQOPT)
+35 WRITE !,"These users now have a Primary Menu with no menu items!",$CHAR(7)
+36 WRITE !,"Recommend you add some menu items to it."
End DoDot:1
QUIT
+37 DO DELETE(.XQOPT)
+38 WRITE !!?7,$CHAR(7),"Empty menu removed from option file and your delegated options.",!
+39 QUIT
SHOWITEM ;
+1 NEW I,XQREC,XQREC0
+2 WRITE !,"This menu contains the following menu items. You may add a new menu item."
+3 WRITE !,"If you select an existing menu item, it will be deleted from the menu.",!
+4 SET I=0
+5 FOR
SET I=$ORDER(^DIC(19,XQOPT("IEN"),10,I))
if 'I
QUIT
SET XQREC=^(I,0)
Begin DoDot:1
+6 SET XQREC0=^DIC(19,+XQREC,0)
+7 WRITE !,?3,$PIECE(XQREC0,U),?40,$PIECE(XQREC,U,2),?46,$PIECE(XQREC0,U,2)
End DoDot:1
+8 WRITE !
+9 QUIT
NODEL(XQOPT) ; called by ^XQSMDFM, too
+1 NEW I
+2 WRITE !!,"This option is used as a Primary Menu for:"
+3 SET I=0
+4 FOR
SET I=$ORDER(^VA(200,"AP",XQOPT("IEN"),I))
if 'I
QUIT
WRITE !?10,$PIECE(^VA(200,I,0),U)
+5 WRITE !,"Can't delete it while it is used as a primary menu."
+6 QUIT
DELETE(XQOPT) ; called by ^XQSMDFM, too
+1 NEW DIK,DA
+2 IF $GET(XQOPT("NEW"))
Begin DoDot:1
+3 SET DIK="^VA(200,DUZ,19.5,"
SET DA(1)=DUZ
SET DA=XQOPT("IEN")
DO ^DIK
End DoDot:1
+4 IF '$TEST
Begin DoDot:1
+5 NEW XQJ
+6 SET XQJ=0
+7 ; Delete option from all menus
+8 FOR
SET XQJ=$ORDER(^DIC(19,"AD",XQOPT("IEN"),XQJ))
if 'XQJ
QUIT
SET DA=$ORDER(^(XQJ,0))
SET DA(1)=XQJ
SET DIK="^DIC(19,DA(1),10,"
DO ^DIK
+9 ; Delete option as a secondary menu option for all users
+10 FOR
SET XQJ=$ORDER(^VA(200,"AD",XQOPT("IEN"),XQJ))
if 'XQJ
QUIT
SET DA=$ORDER(^(XQJ,0))
SET DA(1)=XQJ
SET DIK="^VA(200,DA(1),203,"
DO ^DIK
+11 ; Delete option as delegated option for all users
+12 FOR
SET XQJ=$ORDER(^VA(200,XQJ))
if 'XQJ
QUIT
IF $DATA(^(XQJ,19.5,"B",XQOPT("IEN")))
SET DA=XQOPT("IEN")
SET DA(1)=XQJ
SET DIK="^VA(200,DA(1),19.5,"
DO ^DIK
End DoDot:1
+13 ; Delete option
SET DIK="^DIC(19,"
SET DA=XQOPT("IEN")
DO ^DIK
+14 QUIT
NAMESP(XQNMSP) ; Check for available namespaces. Called by ^XQSMDFM, too.
+1 NEW I
+2 SET I=0
+3 FOR
SET I=$ORDER(^VA(200,DUZ,19.6,"B",I))
if I=""
QUIT
SET XQNMSP=$GET(XQNMSP)+1
SET XQNMSP(I)=""
+4 IF $DATA(XQNMSP)
DO HLPNAME
QUIT
+5 IF $DATA(^VA(200,DUZ,19.6))
KILL ^(19.6)
+6 WRITE !!?7,$CHAR(7),"No namespace(s) have been set up for you to build new menus.",!?7,"Contact your computer service representative."
+7 QUIT
HLPNAME ;
+1 NEW I
+2 WRITE !?7,"The options you build or edit must begin with ",$SELECT(XQNMSP>1:"one of ",1:""),!?7,"the following namespace",$SELECT(XQNMSP>1:"(s)",1:"")," and be no more than 30 characters long:",!
+3 SET I=""
+4 FOR
SET I=$ORDER(XQNMSP(I))
if I=""
QUIT
WRITE !?35,$SELECT($EXTRACT(I,1)="A":I,1:I_"Z")
+5 WRITE !
+6 if "^P^I^E^M^"'[(U_$GET(XQTYPE)_U)
QUIT
+7 NEW I,XQM,XQREC
+8 SET I=0
+9 FOR
SET I=$ORDER(^VA(200,DUZ,19.5,"B",I))
if 'I
QUIT
Begin DoDot:1
+10 SET XQREC=$GET(^DIC(19,I,0))
if $PIECE(XQREC,U,4)'=XQTYPE
QUIT
+11 SET XQM($PIECE(XQREC,U))=$PIECE(XQREC,U,2)
End DoDot:1
+12 IF '$DATA(XQM)
WRITE !?7,"You have no existing delegated "_$$TYPE(XQTYPE)_" options. You may enter a new one."
QUIT
+13 WRITE !,"The following are your existing delegated "_$$TYPE(XQTYPE)_" options:"
+14 FOR
SET I=$ORDER(XQM(I))
if I=""
QUIT
WRITE !,I,?40,XQM(I)
+15 QUIT
TYPE(XQT) ;
+1 QUIT $SELECT(XQT="P":"Print",XQT="I":"Inquire",XQT="E":"Edit",1:"Menu")
ASKNAME(XQOPNM,XQNMSP,XQTYPE) ;Check for a valid option names.
+1 ;Called by ^XQSMDFM, too.
+2 ;XU*8*428 also allows for local namespaces, e.g., A5A, AFS, etc.
+3 FOR
Begin DoDot:1
+4 NEW DIR,X,Y
+5 SET DIR("A")="Option Name"
+6 SET DIR("PRE")="D CHKNAME^XQSMD4"
+7 SET DIR("?")="^D HLPNAME^XQSMD4"
+8 SET DIR(0)="F^3:30"
+9 DO ^DIR
if $DATA(DIRUT)
QUIT
+10 SET XQOPNM=Y
End DoDot:1
if $DATA(DIRUT)!$DATA(XQOPNM)
QUIT
+11 QUIT
CHKNAME ;
+1 IF $DATA(DTOUT)!(X[U)!(X["?")
QUIT
+2 IF X=""
SET X=U
QUIT
+3 NEW I
+4 SET I=""
+5 FOR
SET I=$ORDER(XQNMSP(I))
if I=""
QUIT
if $EXTRACT(I,1)="A"&($EXTRACT(X,1,$LENGTH(I))=I)
QUIT
if $EXTRACT(X,1,$LENGTH(I))=I&($EXTRACT(X,$LENGTH(I)+1)="Z")
QUIT
+6 if I'=""
QUIT
+7 WRITE $CHAR(7),!!?7,$EXTRACT(X,1,4),"* is not a valid namespace for you.",!
+8 KILL X
+9 QUIT
