XQ83R ;SF-ISC.SEA/JLI/LUKE - SURGERY ON ^XUTL("XQO", NODES FOR REGULAR MODIFICATIONS TO OPTIONS ;04/08/2003 12:12
;;8.0;KERNEL;**47,157,286**;Jul 10, 1995
Q
REG S XQOPI=+XQOP,XQC1=XQOPI_",",XQC2=","_XQC1
D TABLE^XQ83A
N J S J=1
S XQ83R="" F I=0:0 S I=$O(^DIC(19,"AD",XQOPI,I)) Q:I'>0 S XQ83R(J)=I,J=J+1 ;S XQ83R=XQ83R_I_","
S A="P" F %I=0:0 S XQ83RL=0 S A=$O(^XUTL("XQO",A)) Q:$E(A)'="P" D
. I $D(^XUTL("XQO",A,U,XQOPI)) D Q
. . L +^XUTL("XQO",A):0 K ^(A,0)
. . F XQ83RI=1:1 S XQOPM=$O(XQ83R(XQ83RI)) S:XQOPM="" ^XUTL("XQO",A,0)=%XQT1 L:XQOPM="" -^XUTL("XQO",A) Q:XQOPM="" D ADD^XQ83A
. F XQ83RI=1:1 S XQOPM=$O(XQ83R(XQ83RI)) Q:XQOPM="" D
. . I $D(^XUTL("XQO",A,"^",XQOPM)) D
. . . I '$D(XQ83LOCK) L +^XUTL("XQO",A):0 S XQ83LOCK=1 K ^XUTL("XQO",A,0)
. . . D ADD^XQ83A
. I $D(XQ83LOCK) L -^XUTL("XQO",A) K XQ83LOCK S ^XUTL("XQO",A,0)=%XQT1
.Q
K XQ83R,XQ83RI,XQ83RL
Q
;
A ;
S B=0 F J=0:0 S B=$O(^XUTL("XQO",A,B)) Q:B=""!(B=U) I +^(B)=XQOPI K ^(B)
D A1
F I=0:0 S I=$O(^XUTL("XQO",A,U,I)) Q:I'>0 D A2
Q
A2 ;
S L=0,%XQX=$P(^XUTL("XQO",A,U,I),U,9) I $E(%XQX,1,$L(XQC1))=XQC1!(%XQX[XQC2) S L=1
I 'L F J=0:0 S J=$O(^XUTL("XQO",A,U,I,0,J)) Q:J'>0 S %XQX=$P(^(J),U,2) I $E(%XQX,1,$L(XQC1))=XQC1!(%XQX[XQC2) S L=1 Q
I L S K=0 D D F J=0:0 S J=$O(^XUTL("XQO",A,U,I,0,J)) Q:J'>0 D D1
I L I K=0 K ^XUTL("XQO",A,U,I)
K L,K
Q
;
A1 ;
Q:$P(^DIC(19,XQOPI,0),U,3)'="" D:'($D(^("U"))#2) UP S %XQX=^DIC(19,XQOPI,"U"),%XQX2=1 D A11
S %XQX2=0 F M=0:0 S M=$O(^DIC(19,"AD",XQOPI,M)) Q:M'>0 S N=$O(^(M,0)) Q:N'>0 S %XQX=$S('($D(^DIC(19,M,10,N,0))#2):"",1:$P(^(0),U,2)) I %XQX'="" D A11
Q
A11 ;
S %XQY=%XQX F P=1:1 S %XQY=$O(^XUTL("XQO",A,%XQY)) Q:$P(%XQY,U,1)'=%XQX Q:+$P(%XQY,U,2)'=(P-1) I +^(%XQY)=XQOPI S P=0 Q
I $P(%XQY,U,1)=%XQX S %XQY=$O(^XUTL("XQO",A,%XQY)) Q:$P(%XQY,U,1)'=%XQX I +^(%XQY)=XQOPI S P=0 Q
I P S ^XUTL("XQO",A,(%XQX_U_$S(P=1:"",1:P-1)))=XQOPI_U_%XQX2
Q
;
D ;
S XQA=$P(^XUTL("XQO",A,U,I),U,9) D GET Q:XQA="" S ^XUTL("XQO",A,U,I)=U_$P(^DIC(19,I,0),U,1,2)_U_$S($P(^(0),U,3)]"":1,1:"")_U_$P(^(0),U,4)_U_XQA_U_XQK_U_$P(^(0),U,7,8)_U_XQP_U_XQE_U_$P(^(0),U,11,15)_U_XQF_U_$P(^(0),U,17,99),K=K+1
Q
D1 ;
S XQA=$P(^XUTL("XQO",A,U,I,0,J),U,2) D GET K ^XUTL("XQO",A,U,I,0,J) Q:XQA="" I K>0 S ^(K)=XQA_U_XQK_U_XQP_U_XQE_U_XQF,K=K+1 Q
S ^XUTL("XQO",A,U,I)=U_$P(^DIC(19,I,0),U,1,2)_U_$S($P(^(0),U,3)]"":1,1:"")_U_$P(^(0),U,4)_U_XQA_U_XQK_U_$P(^(0),U,7,8)_U_XQP_U_XQE_U_$P(^(0),U,11,15)_U_XQF_U_$P(^(0),U,17,99),K=K+1
Q
;
GET ;
S XQOOO="",(XQK,XQP,XQE,XQF)="" F M=1:1 S %XQA=$P(XQA,",",M) Q:%XQA'>0 D SUM
S:XQOOO XQA="" K XQOOO
Q
;
SUM ;
S XQK1=$P(^DIC(19,%XQA,0),U,6),XQE1=$P(^(0),U,10),XQF1="" I $D(^(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),XQF=$S(XQF'=""&(XQF1'=""):XQF_","_XQF1,1:XQF_XQF1)
S XQOOO=$S($P(^DIC(19,%XQA,0),U,3)'="":1,1:XQOOO)
S XQP1="" F I=0:0 S I=$O(^DIC(19,%XQA,3.91,I)) Q:I'>0 S XQP1=$S(XQP1'="":XQP1_";",1:"")_$P(^(I,0),U)_$P(^(0),U,2)
S:XQP1="" XQP1=$P(^DIC(19,%XQA,0),U,9) S XQP=$S(XQP1'=""&(XQP'=""):XQP_";"_XQP1,1:XQP_XQP1)
Q
;
UP S X=$P(^DIC(19,XQOPI,0),U,2) I X'?.PUN S X=$$UP^XLFSTR(X) ;F Z=1:1 Q:X?.NUP S W=$A(X,Z) I W<123,W>96 S X=$E(X,1,Z-1)_$C(W-32)_$E(X,Z+1,255)
S X=$E(X,1,30),^DIC(19,XQOPI,"U")=X,^DIC(19,"C",X,XQOPI)=""
Q
;
SYN ;
S A="P" F S=0:0 S A=$O(^XUTL("XQO",A)) Q:$E(A)'="P" D SYN1
K A,S,T,XQSYN,XQNAM
Q
SYN1 ;
S XQNAM="",V=XQOPI_U_"0" F T=0:0 S XQNAM=$O(^XUTL("XQO",A,XQNAM)) Q:XQNAM=""!(XQNAM=U) I ^(XQNAM)=V K ^(XQNAM)
I $S('$D(^DIC(19,XQOPI,0)):1,$P(^(0),U,3)'="":1,1:0) S XQNAM="",V=XQOPI_U_"1" F T=0:0 S XQNAM=$O(^XUTL("XQO",A,XQNAM)) Q:XQNAM=""!(XQNAM=U) I ^(XQNAM)=V K ^(XQNAM)
Q:'$D(^DIC(19,XQOPI,0)) Q:$P(^DIC(19,XQOPI,0),U,3)'="" F XQOPM=0:0 S XQOPM=$O(^DIC(19,"AD",XQOPI,XQOPM)) Q:XQOPM'>0 S XQ1=$O(^(XQOPM,0)) I $D(^DIC(19,XQOPM,10,XQ1,0)) S XQSYN=$P(^(0),U,2) I XQSYN'="" D SYN2
Q
SYN2 ;
Q:'$D(^XUTL("XQO",A,U,XQOPI)) S XQSYN2A=","_XQOPM_","_XQOPI_","
S XQSYN2=$S($P(A,"P",2)=XQOPM:1,(","_$P(^XUTL("XQO",A,U,XQOPI),U,9))[XQSYN2A:1,1:0) F T=0:0 Q:XQSYN2 S T=$O(^XUTL("XQO",A,U,XQOPI,0,T)) Q:T'>0 I (","_$P(^(T),U,2))[XQSYN2A S XQSYN2=1
K XQSYN2A I 'XQSYN2 K T,XQSYN2 Q
S XQLAST=XQOPI,V=XQLAST_U_"0",XQSYNY=XQSYN D SYN3 K XQLAST,V,XQSYNY,XQSYN2
Q
SYN3 S XQNAM=XQSYNY_"]]]]]]]]]]]" F XQ83RT=1:1 S XQNAM=$O(^XUTL("XQO",A,XQNAM)) Q:$P(XQNAM,U,1)'=XQSYNY I +^(XQNAM)=+V S XQ83RT=0 Q
Q:'XQ83RT I XQ83RT=1 S ^XUTL("XQO",A,(XQSYNY_U))=V Q
I XQ83RT>1,$D(^XUTL("XQO",A,XQSYNY_U)) S ^(XQSYNY_U_"1")=^(XQSYNY_U) K ^(XQSYNY_U)
F XQ83RT=1:1 I '$D(^XUTL("XQO",A,(XQSYNY_U_XQ83RT))) S ^(XQSYNY_U_XQ83RT)=V Q
K XQ83RT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQ83R 4718 printed Oct 16, 2024@18:05:57 Page 2
XQ83R ;SF-ISC.SEA/JLI/LUKE - SURGERY ON ^XUTL("XQO", NODES FOR REGULAR MODIFICATIONS TO OPTIONS ;04/08/2003 12:12
+1 ;;8.0;KERNEL;**47,157,286**;Jul 10, 1995
+2 QUIT
REG SET XQOPI=+XQOP
SET XQC1=XQOPI_","
SET XQC2=","_XQC1
+1 DO TABLE^XQ83A
+2 NEW J
SET J=1
+3 ;S XQ83R=XQ83R_I_","
SET XQ83R=""
FOR I=0:0
SET I=$ORDER(^DIC(19,"AD",XQOPI,I))
if I'>0
QUIT
SET XQ83R(J)=I
SET J=J+1
+4 SET A="P"
FOR %I=0:0
SET XQ83RL=0
SET A=$ORDER(^XUTL("XQO",A))
if $EXTRACT(A)'="P"
QUIT
Begin DoDot:1
+5 IF $DATA(^XUTL("XQO",A,U,XQOPI))
Begin DoDot:2
+6 LOCK +^XUTL("XQO",A):0
KILL ^(A,0)
+7 FOR XQ83RI=1:1
SET XQOPM=$ORDER(XQ83R(XQ83RI))
if XQOPM=""
SET ^XUTL("XQO",A,0)=%XQT1
if XQOPM=""
LOCK -^XUTL("XQO",A)
if XQOPM=""
QUIT
DO ADD^XQ83A
End DoDot:2
QUIT
+8 FOR XQ83RI=1:1
SET XQOPM=$ORDER(XQ83R(XQ83RI))
if XQOPM=""
QUIT
Begin DoDot:2
+9 IF $DATA(^XUTL("XQO",A,"^",XQOPM))
Begin DoDot:3
+10 IF '$DATA(XQ83LOCK)
LOCK +^XUTL("XQO",A):0
SET XQ83LOCK=1
KILL ^XUTL("XQO",A,0)
+11 DO ADD^XQ83A
End DoDot:3
End DoDot:2
+12 IF $DATA(XQ83LOCK)
LOCK -^XUTL("XQO",A)
KILL XQ83LOCK
SET ^XUTL("XQO",A,0)=%XQT1
+13 QUIT
End DoDot:1
+14 KILL XQ83R,XQ83RI,XQ83RL
+15 QUIT
+16 ;
A ;
+1 SET B=0
FOR J=0:0
SET B=$ORDER(^XUTL("XQO",A,B))
if B=""!(B=U)
QUIT
IF +^(B)=XQOPI
KILL ^(B)
+2 DO A1
+3 FOR I=0:0
SET I=$ORDER(^XUTL("XQO",A,U,I))
if I'>0
QUIT
DO A2
+4 QUIT
A2 ;
+1 SET L=0
SET %XQX=$PIECE(^XUTL("XQO",A,U,I),U,9)
IF $EXTRACT(%XQX,1,$LENGTH(XQC1))=XQC1!(%XQX[XQC2)
SET L=1
+2 IF 'L
FOR J=0:0
SET J=$ORDER(^XUTL("XQO",A,U,I,0,J))
if J'>0
QUIT
SET %XQX=$PIECE(^(J),U,2)
IF $EXTRACT(%XQX,1,$LENGTH(XQC1))=XQC1!(%XQX[XQC2)
SET L=1
QUIT
+3 IF L
SET K=0
DO D
FOR J=0:0
SET J=$ORDER(^XUTL("XQO",A,U,I,0,J))
if J'>0
QUIT
DO D1
+4 IF L
IF K=0
KILL ^XUTL("XQO",A,U,I)
+5 KILL L,K
+6 QUIT
+7 ;
A1 ;
+1 if $PIECE(^DIC(19,XQOPI,0),U,3)'=""
QUIT
if '($DATA(^("U"))#2)
DO UP
SET %XQX=^DIC(19,XQOPI,"U")
SET %XQX2=1
DO A11
+2 SET %XQX2=0
FOR M=0:0
SET M=$ORDER(^DIC(19,"AD",XQOPI,M))
if M'>0
QUIT
SET N=$ORDER(^(M,0))
if N'>0
QUIT
SET %XQX=$SELECT('($DATA(^DIC(19,M,10,N,0))#2):"",1:$PIECE(^(0),U,2))
IF %XQX'=""
DO A11
+3 QUIT
A11 ;
+1 SET %XQY=%XQX
FOR P=1:1
SET %XQY=$ORDER(^XUTL("XQO",A,%XQY))
if $PIECE(%XQY,U,1)'=%XQX
QUIT
if +$PIECE(%XQY,U,2)'=(P-1)
QUIT
IF +^(%XQY)=XQOPI
SET P=0
QUIT
+2 IF $PIECE(%XQY,U,1)=%XQX
SET %XQY=$ORDER(^XUTL("XQO",A,%XQY))
if $PIECE(%XQY,U,1)'=%XQX
QUIT
IF +^(%XQY)=XQOPI
SET P=0
QUIT
+3 IF P
SET ^XUTL("XQO",A,(%XQX_U_$SELECT(P=1:"",1:P-1)))=XQOPI_U_%XQX2
+4 QUIT
+5 ;
D ;
+1 SET XQA=$PIECE(^XUTL("XQO",A,U,I),U,9)
DO GET
if XQA=""
QUIT
SET ^XUTL("XQO",A,U,I)=U_$PIECE(^DIC(19,I,0),U,1,2)_U_$SELECT($PIECE(^(0),U,3)]"":1,1:"")_U_$PIECE(^(0),U,4)_U_XQA_U_XQK_U_$PIECE(^(0),U,7,8)_U_XQP_U_XQE_U_$PIECE(^(0),U,11,15)_U_XQF_U_$PIECE(^(0),U,17,99)
SET K=K+1
+2 QUIT
D1 ;
+1 SET XQA=$PIECE(^XUTL("XQO",A,U,I,0,J),U,2)
DO GET
KILL ^XUTL("XQO",A,U,I,0,J)
if XQA=""
QUIT
IF K>0
SET ^(K)=XQA_U_XQK_U_XQP_U_XQE_U_XQF
SET K=K+1
QUIT
+2 SET ^XUTL("XQO",A,U,I)=U_$PIECE(^DIC(19,I,0),U,1,2)_U_$SELECT($PIECE(^(0),U,3)]"":1,1:"")_U_$PIECE(^(0),U,4)_U_XQA_U_XQK_U_$PIECE(^(0),U,7,8)_U_XQP_U_XQE_U_$PIECE(^(0),U,11,15)_U_XQF_U_$PIECE(^(0),U,17,99)
SET K=K+1
+3 QUIT
+4 ;
GET ;
+1 SET XQOOO=""
SET (XQK,XQP,XQE,XQF)=""
FOR M=1:1
SET %XQA=$PIECE(XQA,",",M)
if %XQA'>0
QUIT
DO SUM
+2 if XQOOO
SET XQA=""
KILL XQOOO
+3 QUIT
+4 ;
SUM ;
+1 SET XQK1=$PIECE(^DIC(19,%XQA,0),U,6)
SET XQE1=$PIECE(^(0),U,10)
SET XQF1=""
IF $DATA(^(3))
SET XQF1=$PIECE(^(3),U)
+2 SET XQK=$SELECT(XQK'=""&(XQK1'=""):XQK_","_XQK1,1:XQK_XQK1)
SET XQE=$SELECT(XQE'=""&(XQE1'=""):XQE_","_XQE1,1:XQE_XQE1)
SET XQF=$SELECT(XQF'=""&(XQF1'=""):XQF_","_XQF1,1:XQF_XQF1)
+3 SET XQOOO=$SELECT($PIECE(^DIC(19,%XQA,0),U,3)'="":1,1:XQOOO)
+4 SET XQP1=""
FOR I=0:0
SET I=$ORDER(^DIC(19,%XQA,3.91,I))
if I'>0
QUIT
SET XQP1=$SELECT(XQP1'="":XQP1_";",1:"")_$PIECE(^(I,0),U)_$PIECE(^(0),U,2)
+5 if XQP1=""
SET XQP1=$PIECE(^DIC(19,%XQA,0),U,9)
SET XQP=$SELECT(XQP1'=""&(XQP'=""):XQP_";"_XQP1,1:XQP_XQP1)
+6 QUIT
+7 ;
UP ;F Z=1:1 Q:X?.NUP S W=$A(X,Z) I W<123,W>96 S X=$E(X,1,Z-1)_$C(W-32)_$E(X,Z+1,255)
SET X=$PIECE(^DIC(19,XQOPI,0),U,2)
IF X'?.PUN
SET X=$$UP^XLFSTR(X)
+1 SET X=$EXTRACT(X,1,30)
SET ^DIC(19,XQOPI,"U")=X
SET ^DIC(19,"C",X,XQOPI)=""
+2 QUIT
+3 ;
SYN ;
+1 SET A="P"
FOR S=0:0
SET A=$ORDER(^XUTL("XQO",A))
if $EXTRACT(A)'="P"
QUIT
DO SYN1
+2 KILL A,S,T,XQSYN,XQNAM
+3 QUIT
SYN1 ;
+1 SET XQNAM=""
SET V=XQOPI_U_"0"
FOR T=0:0
SET XQNAM=$ORDER(^XUTL("XQO",A,XQNAM))
if XQNAM=""!(XQNAM=U)
QUIT
IF ^(XQNAM)=V
KILL ^(XQNAM)
+2 IF $SELECT('$DATA(^DIC(19,XQOPI,0)):1,$PIECE(^(0),U,3)'="":1,1:0)
SET XQNAM=""
SET V=XQOPI_U_"1"
FOR T=0:0
SET XQNAM=$ORDER(^XUTL("XQO",A,XQNAM))
if XQNAM=""!(XQNAM=U)
QUIT
IF ^(XQNAM)=V
KILL ^(XQNAM)
+3 if '$DATA(^DIC(19,XQOPI,0))
QUIT
if $PIECE(^DIC(19,XQOPI,0),U,3)'=""
QUIT
FOR XQOPM=0:0
SET XQOPM=$ORDER(^DIC(19,"AD",XQOPI,XQOPM))
if XQOPM'>0
QUIT
SET XQ1=$ORDER(^(XQOPM,0))
IF $DATA(^DIC(19,XQOPM,10,XQ1,0))
SET XQSYN=$PIECE(^(0),U,2)
IF XQSYN'=""
DO SYN2
+4 QUIT
SYN2 ;
+1 if '$DATA(^XUTL("XQO",A,U,XQOPI))
QUIT
SET XQSYN2A=","_XQOPM_","_XQOPI_","
+2 SET XQSYN2=$SELECT($PIECE(A,"P",2)=XQOPM:1,(","_$PIECE(^XUTL("XQO",A,U,XQOPI),U,9))[XQSYN2A:1,1:0)
FOR T=0:0
if XQSYN2
QUIT
SET T=$ORDER(^XUTL("XQO",A,U,XQOPI,0,T))
if T'>0
QUIT
IF (","_$PIECE(^(T),U,2))[XQSYN2A
SET XQSYN2=1
+3 KILL XQSYN2A
IF 'XQSYN2
KILL T,XQSYN2
QUIT
+4 SET XQLAST=XQOPI
SET V=XQLAST_U_"0"
SET XQSYNY=XQSYN
DO SYN3
KILL XQLAST,V,XQSYNY,XQSYN2
+5 QUIT
SYN3 SET XQNAM=XQSYNY_"]]]]]]]]]]]"
FOR XQ83RT=1:1
SET XQNAM=$ORDER(^XUTL("XQO",A,XQNAM))
if $PIECE(XQNAM,U,1)'=XQSYNY
QUIT
IF +^(XQNAM)=+V
SET XQ83RT=0
QUIT
+1 if 'XQ83RT
QUIT
IF XQ83RT=1
SET ^XUTL("XQO",A,(XQSYNY_U))=V
QUIT
+2 IF XQ83RT>1
IF $DATA(^XUTL("XQO",A,XQSYNY_U))
SET ^(XQSYNY_U_"1")=^(XQSYNY_U)
KILL ^(XQSYNY_U)
+3 FOR XQ83RT=1:1
IF '$DATA(^XUTL("XQO",A,(XQSYNY_U_XQ83RT)))
SET ^(XQSYNY_U_XQ83RT)=V
QUIT
+4 KILL XQ83RT
+5 QUIT
