- XQ83R ;SF-ISC.SEA/JLI/LUKE - SURGERY ON ^XUTL("XQO", NODES FOR REGULAR MODIFICATIONS TO OPTIONS ;04/08/2003 12:12 [ 07/29/2004 9:01 AM ]
- ;;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
- XQ83R ;SF-ISC.SEA/JLI/LUKE - SURGERY ON ^XUTL("XQO", NODES FOR REGULAR MODIFICATIONS TO OPTIONS ;04/08/2003 12:12 [ 07/29/2004 9:01 AM ]
- +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
