XQ83A ;ISC-SF..SEA/JLI,LUKE - MICROSURGERY ON MENU TREES TO ADD A NEW ITEM TO A MENU ;10/27/2009
;;8.0;KERNEL;**157,494,537**;Jul 10, 1995;Build 3
;;"Per VHA Directive 2004-038, this routine should not be modified".
ENTRY ;
D TABLE
I XQC'="P" S A="P" F XQJ=0:0 S A=$O(^DIC(19,"AXP",A)) Q:$E(A)'="P" I $D(^(A,U,XQOPM)) L +^DIC(19,"AXP",A):10 Q:'$T K ^(A,0) D ADD S ^DIC(19,"AXP",A,0)=%XQT1 L -^DIC(19,"AXP",A)
K L,M,N,P,R,S,T,XQJ,XQLAST,XQLM,XQLM1,XQNAM,XQNAME,XQNEW,XQOLD,XQP1,XQP2,XQPATH,XQSYN
Q
TABLE ;
K ^TMP($J,"NEW"),^("S2"),^("PATH") Q:'$D(^DIC(19,XQOPI,0))
S ^TMP($J,"NEW",1,1)=XQOPI_",",S2=^DIC(19,XQOPI,0) S:$P(S2,U,3)'="" $P(S2,U,6)=" OOO " K SU S:$D(^("U")) SU=^("U")
S XQP="" F IJ=0:0 S IJ=$O(^DIC(19,XQOPI,3.91,IJ)) Q:IJ'>0 I ($D(^(IJ,0))#2),$P(^(0),U)'="" S XQP=$S(XQP="":"",1:XQP_",")_$P(^(0),U)_$P(^(0),U,2)
S:XQP'="" $P(S2,U,9)=XQP S ^TMP($J,"S2",XQOPI)=S2 S:$D(SU) ^(XQOPI,"U")=SU I XQC="P" S XQNEW=XQOPM,XQOLD="",N=1,S=1 D XPAND
F J=0:0 S J=$O(^TMP($J,"NEW",J)),N=J+1,S=1 Q:J'>0 F K=0:0 S K=$O(^TMP($J,"NEW",J,K)) Q:K'>0 S XQOLD=^(K),XQNEW=+$P(XQOLD,",",J) I $D(^DIC(19,XQNEW,10)) D XPAND
D PATHS K ^TMP($J,"OLD"),^("NEW"),^("S2")
Q
;
XPAND ; eXPAND option into subtree, if it is a menu
F L=0:0 S L=$O(^DIC(19,XQNEW,10,L)) Q:L'>0 S T=+$G(^(L,0)),S1=$P(^(0),U,2),S2=$G(^DIC(19,T,0)) S:$P(S2,U,3)'="" $P(S2,U,6)=" OOO " I XQC2'[(","_T_",")&(XQOLD'[(","_T_",")) D X1
K S1,S2
Q
;
CLEAN(XQNEW,L) ;clean broken pointers if found on the sub menu with IEN=XQNEW - P ;494
N DA,DIK
S DA(1)=XQNEW,DA=L,DIK="^DIC(19,"_DA(1)_","_10_","
D ^DIK
Q
;
X1 ;
S ^TMP($J,"NEW",N,S)=XQOLD_T_"," S:$G(S1)'="" ^(S,"S")=S1 S S=S+1 Q:$D(^TMP($J,"S2",T)) S ^(T)=S2 S:$D(^DIC(19,T,"U")) ^TMP($J,"S2",T,"U")=^("U")
S XQP="" I $D(^DIC(19,T,3.91)) F IJ=0:0 S IJ=$O(^DIC(19,T,3.91,IJ)) Q:IJ'>0 I ($D(^(IJ,0))#2),$P(^(0),U,1)'="" S XQP=$S(XQP="":"",1:XQP_",")_$P(^(0),U,1)_$P(^(0),U,2)
I XQP'="" S $P(^TMP($J,"S2",T),U,9)=XQP
Q
PATHS ;
F I=0:0 S I=$O(^TMP($J,"NEW",I)) Q:I'>0 F J=0:0 S J=$O(^TMP($J,"NEW",I,J)) Q:J'>0 S PATH=^(J),SYN=$S($D(^(J,"S")):^("S"),1:"") D PATH1
Q
PATH1 ;
S T=$P(PATH,",",I),NPATH=$P(PATH,",",1,I-1)_",",BASE=$S(NPATH'=",":^TMP($J,"PATH",NPATH),1:"")
S XQK=$P(BASE,U,7),XQE=$P(BASE,U,11),XQP=$P(BASE,U,10),XQF=$P(BASE,U,17)
S NEW=^TMP($J,"S2",T),XQUC=$S($D(^(T,"U")):^("U"),1:"")
S XQK1=$P(NEW,U,6),XQE1=$P(NEW,U,10),XQP1=$P(NEW,U,9),XQF1="" I $P(NEW,U,16),$D(^DIC(19,T,3)) S XQF1=$P(^(3),U)
S XQK=$S(XQK'=""&(XQK1'=""):XQK_","_XQK1,1:XQK_XQK1),XQE=$S(XQE'=""&(XQE1'=""):XQE_","_XQE1,1:XQE_XQE1),XQP=$S(XQP'=""&(XQP1'=""):XQP_","_XQP,1:XQP_XQP1),XQF=$S(XQF'=""&(XQF1'=""):XQF_","_XQF1,1:XQF_XQF1)
S ^TMP($J,"PATH",PATH)=U_$P(NEW,U,1,2)_U_$S($P(NEW,U,3)]"":1,1:"")_U_$P(NEW,U,4)_U_PATH_U_XQK_U_$P(NEW,U,7,8)_U_XQP_U_XQE_U_$P(NEW,U,11,15)_U_XQF_U_$P(NEW,U,17,99),^(PATH,"U")=XQUC,^("SYN")=SYN
Q
;
ADD ;
Q:'$D(^DIC(19,"AXP",A,U,XQOPM)) G:$D(^TMP($J,"OLD",XQOPM)) DOIT S ^TMP($J,"OLD",XQOPM,1)=^DIC(19,"AXP",A,U,XQOPM)
S N=0 F J=2:1 S N=$O(^DIC(19,"AXP",A,U,XQOPM,0,N)) Q:N'>0 S P=^(N),$P(L,U,7)=$P(P,U,2),$P(L,U,10,11)=$P(P,U,3,4),$P(L,U,5)=$P(P,U),P=$P(^(N),U),^TMP($J,"OLD",XQOPM,J)=L F K=1:1:J-1 I $P(^TMP($J,"OLD",XQOPM,K),U,9)=P K ^(J) S J=J-1 Q
DOIT K ^TMP($J,"PATH",(XQOPI_","),"SYN") S XQ83AJ=$O(^DIC(19,XQOPM,10,"B",XQOPI,0)) Q:XQ83AJ'>0 S XQ83AJ=$P(^DIC(19,XQOPM,10,XQ83AJ,0),U,2) I XQ83AJ'="" S ^TMP($J,"PATH",(XQOPI_","),"SYN")=XQ83AJ
F XQ83AJ=0:0 S XQ83AJ=$O(^TMP($J,"OLD",XQOPM,XQ83AJ)) Q:XQ83AJ'>0 S T=^(XQ83AJ) D ADD1
Q
;
ADD1 ;
S XQA=$P(T,U,6),XQK=$P(T,U,7),XQP=$P(T,U,10),XQE=$P(T,U,11),XQF=$P(T,U,17)
S PATH="" F K=0:0 S PATH=$O(^TMP($J,"PATH",PATH)) Q:PATH="" S BASE=^(PATH),XQUC=^(PATH,"U"),SYN=$S($D(^("SYN")):^("SYN"),1:"") D ADD2
Q
;
ADD2 ;
S XQK1=$P(BASE,U,7),XQP1=$P(BASE,U,10),XQE1=$P(BASE,U,11),XQF1=$P(BASE,U,17) S XQK1=$S(XQK'=""&(XQK1'=""):XQK_","_XQK1,1:XQK_XQK1),XQP1=$S(XQP'=""&(XQP1'=""):XQP_","_XQP1,1:XQP_XQP1),XQE1=$S(XQE'=""&(XQE1'=""):XQE_","_XQE1,1:XQE_XQE1)
S XQF1=$S(XQF'=""&(XQF1'=""):XQF_","_XQF1,1:XQF_XQF1)
S XQFLG=0,N=$L(PATH,","),T=$P(PATH,",",N-1)
I $S('$D(^DIC(19,"AXP",A,U,T)):1,$P(^(T),U,6)=(XQA_PATH):1,1:0) S ^(T)=$P(BASE,U,1,5)_U_XQA_PATH_U_XQK1_U_$P(BASE,U,8,9)_U_XQP1_U_XQE1_U_$P(BASE,U,12,16)_U_XQF1_U_$P(BASE,U,18,99),XQFLG=1
I 'XQFLG S BASE1=XQA_PATH_U_XQK1_U_XQP1_U_XQE1_U_XQF1 F N=0:0 S N=$O(^DIC(19,"AXP",A,U,T,0,N)) Q:N'>0 S L=N I $P(^(N),U)=(XQA_PATH) S ^(N)=BASE1,XQFLG=1 Q
I 'XQFLG F N=1:1 I '$D(^DIC(19,"AXP",A,U,T,0,N)) S ^(N)=BASE1,^(0)=$S('($D(^DIC(19,"AXP",A,U,T,0))#2):0,1:^(0))+1 Q
S XQSYNY=$E($S(XQUC'="":XQUC,1:$P(BASE,U,3)),1,27),V=T_U_"1" D SYN3^XQ83R
I SYN'="" S XQSYNY=SYN,V=T_U_"0" D SYN3^XQ83R
K V
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQ83A 4730 printed Apr 09, 2024@21:17:27 Page 2
XQ83A ;ISC-SF..SEA/JLI,LUKE - MICROSURGERY ON MENU TREES TO ADD A NEW ITEM TO A MENU ;10/27/2009
+1 ;;8.0;KERNEL;**157,494,537**;Jul 10, 1995;Build 3
+2 ;;"Per VHA Directive 2004-038, this routine should not be modified".
ENTRY ;
+1 DO TABLE
+2 IF XQC'="P"
SET A="P"
FOR XQJ=0:0
SET A=$ORDER(^DIC(19,"AXP",A))
if $EXTRACT(A)'="P"
QUIT
IF $DATA(^(A,U,XQOPM))
LOCK +^DIC(19,"AXP",A):10
if '$TEST
QUIT
KILL ^(A,0)
DO ADD
SET ^DIC(19,"AXP",A,0)=%XQT1
LOCK -^DIC(19,"AXP",A)
+3 KILL L,M,N,P,R,S,T,XQJ,XQLAST,XQLM,XQLM1,XQNAM,XQNAME,XQNEW,XQOLD,XQP1,XQP2,XQPATH,XQSYN
+4 QUIT
TABLE ;
+1 KILL ^TMP($JOB,"NEW"),^("S2"),^("PATH")
if '$DATA(^DIC(19,XQOPI,0))
QUIT
+2 SET ^TMP($JOB,"NEW",1,1)=XQOPI_","
SET S2=^DIC(19,XQOPI,0)
if $PIECE(S2,U,3)'=""
SET $PIECE(S2,U,6)=" OOO "
KILL SU
if $DATA(^("U"))
SET SU=^("U")
+3 SET XQP=""
FOR IJ=0:0
SET IJ=$ORDER(^DIC(19,XQOPI,3.91,IJ))
if IJ'>0
QUIT
IF ($DATA(^(IJ,0))#2)
IF $PIECE(^(0),U)'=""
SET XQP=$SELECT(XQP="":"",1:XQP_",")_$PIECE(^(0),U)_$PIECE(^(0),U,2)
+4 if XQP'=""
SET $PIECE(S2,U,9)=XQP
SET ^TMP($JOB,"S2",XQOPI)=S2
if $DATA(SU)
SET ^(XQOPI,"U")=SU
IF XQC="P"
SET XQNEW=XQOPM
SET XQOLD=""
SET N=1
SET S=1
DO XPAND
+5 FOR J=0:0
SET J=$ORDER(^TMP($JOB,"NEW",J))
SET N=J+1
SET S=1
if J'>0
QUIT
FOR K=0:0
SET K=$ORDER(^TMP($JOB,"NEW",J,K))
if K'>0
QUIT
SET XQOLD=^(K)
SET XQNEW=+$PIECE(XQOLD,",",J)
IF $DATA(^DIC(19,XQNEW,10))
DO XPAND
+6 DO PATHS
KILL ^TMP($JOB,"OLD"),^("NEW"),^("S2")
+7 QUIT
+8 ;
XPAND ; eXPAND option into subtree, if it is a menu
+1 FOR L=0:0
SET L=$ORDER(^DIC(19,XQNEW,10,L))
if L'>0
QUIT
SET T=+$GET(^(L,0))
SET S1=$PIECE(^(0),U,2)
SET S2=$GET(^DIC(19,T,0))
if $PIECE(S2,U,3)'=""
SET $PIECE(S2,U,6)=" OOO "
IF XQC2'[(","_T_",")&(XQOLD'[(","_T_","))
DO X1
+2 KILL S1,S2
+3 QUIT
+4 ;
CLEAN(XQNEW,L) ;clean broken pointers if found on the sub menu with IEN=XQNEW - P ;494
+1 NEW DA,DIK
+2 SET DA(1)=XQNEW
SET DA=L
SET DIK="^DIC(19,"_DA(1)_","_10_","
+3 DO ^DIK
+4 QUIT
+5 ;
X1 ;
+1 SET ^TMP($JOB,"NEW",N,S)=XQOLD_T_","
if $GET(S1)'=""
SET ^(S,"S")=S1
SET S=S+1
if $DATA(^TMP($JOB,"S2",T))
QUIT
SET ^(T)=S2
if $DATA(^DIC(19,T,"U"))
SET ^TMP($JOB,"S2",T,"U")=^("U")
+2 SET XQP=""
IF $DATA(^DIC(19,T,3.91))
FOR IJ=0:0
SET IJ=$ORDER(^DIC(19,T,3.91,IJ))
if IJ'>0
QUIT
IF ($DATA(^(IJ,0))#2)
IF $PIECE(^(0),U,1)'=""
SET XQP=$SELECT(XQP="":"",1:XQP_",")_$PIECE(^(0),U,1)_$PIECE(^(0),U,2)
+3 IF XQP'=""
SET $PIECE(^TMP($JOB,"S2",T),U,9)=XQP
+4 QUIT
PATHS ;
+1 FOR I=0:0
SET I=$ORDER(^TMP($JOB,"NEW",I))
if I'>0
QUIT
FOR J=0:0
SET J=$ORDER(^TMP($JOB,"NEW",I,J))
if J'>0
QUIT
SET PATH=^(J)
SET SYN=$SELECT($DATA(^(J,"S")):^("S"),1:"")
DO PATH1
+2 QUIT
PATH1 ;
+1 SET T=$PIECE(PATH,",",I)
SET NPATH=$PIECE(PATH,",",1,I-1)_","
SET BASE=$SELECT(NPATH'=",":^TMP($JOB,"PATH",NPATH),1:"")
+2 SET XQK=$PIECE(BASE,U,7)
SET XQE=$PIECE(BASE,U,11)
SET XQP=$PIECE(BASE,U,10)
SET XQF=$PIECE(BASE,U,17)
+3 SET NEW=^TMP($JOB,"S2",T)
SET XQUC=$SELECT($DATA(^(T,"U")):^("U"),1:"")
+4 SET XQK1=$PIECE(NEW,U,6)
SET XQE1=$PIECE(NEW,U,10)
SET XQP1=$PIECE(NEW,U,9)
SET XQF1=""
IF $PIECE(NEW,U,16)
IF $DATA(^DIC(19,T,3))
SET XQF1=$PIECE(^(3),U)
+5 SET XQK=$SELECT(XQK'=""&(XQK1'=""):XQK_","_XQK1,1:XQK_XQK1)
SET XQE=$SELECT(XQE'=""&(XQE1'=""):XQE_","_XQE1,1:XQE_XQE1)
SET XQP=$SELECT(XQP'=""&(XQP1'=""):XQP_","_XQP,1:XQP_XQP1)
SET XQF=$SELECT(XQF'=""&(XQF1'=""):XQF_","_XQF1,1:XQF_XQF1)
+6 SET ^TMP($JOB,"PATH",PATH)=U_$PIECE(NEW,U,1,2)_U_$SELECT($PIECE(NEW,U,3)]"":1,1:"")_U_$PIECE(NEW,U,4)_U_PATH_U_XQK_U_$PIECE(NEW,U,7,8)_U_XQP_U_XQE_U_$PIECE(NEW,U,11,15)_U_XQF_U_$PIECE(NEW,U,17,99)
SET ^(PATH,"U")=XQUC
SET ^("SYN")=SYN
+7 QUIT
+8 ;
ADD ;
+1 if '$DATA(^DIC(19,"AXP",A,U,XQOPM))
QUIT
if $DATA(^TMP($JOB,"OLD",XQOPM))
GOTO DOIT
SET ^TMP($JOB,"OLD",XQOPM,1)=^DIC(19,"AXP",A,U,XQOPM)
+2 SET N=0
FOR J=2:1
SET N=$ORDER(^DIC(19,"AXP",A,U,XQOPM,0,N))
if N'>0
QUIT
SET P=^(N)
SET $PIECE(L,U,7)=$PIECE(P,U,2)
SET $PIECE(L,U,10,11)=$PIECE(P,U,3,4)
SET $PIECE(L,U,5)=$PIECE(P,U)
SET P=$PIECE(^(N),U)
SET ^TMP($JOB,"OLD",XQOPM,J)=L
FOR K=1:1:J-1
IF $PIECE(^TMP($JOB,"OLD",XQOPM,K),U,9)=P
KILL ^(J)
SET J=J-1
QUIT
DOIT KILL ^TMP($JOB,"PATH",(XQOPI_","),"SYN")
SET XQ83AJ=$ORDER(^DIC(19,XQOPM,10,"B",XQOPI,0))
if XQ83AJ'>0
QUIT
SET XQ83AJ=$PIECE(^DIC(19,XQOPM,10,XQ83AJ,0),U,2)
IF XQ83AJ'=""
SET ^TMP($JOB,"PATH",(XQOPI_","),"SYN")=XQ83AJ
+1 FOR XQ83AJ=0:0
SET XQ83AJ=$ORDER(^TMP($JOB,"OLD",XQOPM,XQ83AJ))
if XQ83AJ'>0
QUIT
SET T=^(XQ83AJ)
DO ADD1
+2 QUIT
+3 ;
ADD1 ;
+1 SET XQA=$PIECE(T,U,6)
SET XQK=$PIECE(T,U,7)
SET XQP=$PIECE(T,U,10)
SET XQE=$PIECE(T,U,11)
SET XQF=$PIECE(T,U,17)
+2 SET PATH=""
FOR K=0:0
SET PATH=$ORDER(^TMP($JOB,"PATH",PATH))
if PATH=""
QUIT
SET BASE=^(PATH)
SET XQUC=^(PATH,"U")
SET SYN=$SELECT($DATA(^("SYN")):^("SYN"),1:"")
DO ADD2
+3 QUIT
+4 ;
ADD2 ;
+1 SET XQK1=$PIECE(BASE,U,7)
SET XQP1=$PIECE(BASE,U,10)
SET XQE1=$PIECE(BASE,U,11)
SET XQF1=$PIECE(BASE,U,17)
SET XQK1=$SELECT(XQK'=""&(XQK1'=""):XQK_","_XQK1,1:XQK_XQK1)
SET XQP1=$SELECT(XQP'=""&(XQP1'=""):XQP_","_XQP1,1:XQP_XQP1)
SET XQE1=$SELECT(XQE'=""&(XQE1'=""):XQE_","_XQE1,1:XQE_XQE1)
+2 SET XQF1=$SELECT(XQF'=""&(XQF1'=""):XQF_","_XQF1,1:XQF_XQF1)
+3 SET XQFLG=0
SET N=$LENGTH(PATH,",")
SET T=$PIECE(PATH,",",N-1)
+4 IF $SELECT('$DATA(^DIC(19,"AXP",A,U,T)):1,$PIECE(^(T),U,6)=(XQA_PATH):1,1:0)
SET ^(T)=$PIECE(BASE,U,1,5)_U_XQA_PATH_U_XQK1_U_$PIECE(BASE,U,8,9)_U_XQP1_U_XQE1_U_$PIECE(BASE,U,12,16)_U_XQF1_U_$PIECE(BASE,U,18,99)
SET XQFLG=1
+5 IF 'XQFLG
SET BASE1=XQA_PATH_U_XQK1_U_XQP1_U_XQE1_U_XQF1
FOR N=0:0
SET N=$ORDER(^DIC(19,"AXP",A,U,T,0,N))
if N'>0
QUIT
SET L=N
IF $PIECE(^(N),U)=(XQA_PATH)
SET ^(N)=BASE1
SET XQFLG=1
QUIT
+6 IF 'XQFLG
FOR N=1:1
IF '$DATA(^DIC(19,"AXP",A,U,T,0,N))
SET ^(N)=BASE1
SET ^(0)=$SELECT('($DATA(^DIC(19,"AXP",A,U,T,0))#2):0,1:^(0))+1
QUIT
+7 SET XQSYNY=$EXTRACT($SELECT(XQUC'="":XQUC,1:$PIECE(BASE,U,3)),1,27)
SET V=T_U_"1"
DO SYN3^XQ83R
+8 IF SYN'=""
SET XQSYNY=SYN
SET V=T_U_"0"
DO SYN3^XQ83R
+9 KILL V
+10 QUIT
