| 1 | XQ83R ;SF-ISC.SEA/JLI/LUKE - SURGERY ON ^XUTL("XQO", NODES FOR REGULAR MODIFICATIONS TO OPTIONS ;04/08/2003 12:12
|
|---|
| 2 | ;;8.0;KERNEL;**47,157,286**;Jul 10, 1995
|
|---|
| 3 | Q
|
|---|
| 4 | REG S XQOPI=+XQOP,XQC1=XQOPI_",",XQC2=","_XQC1
|
|---|
| 5 | D TABLE^XQ83A
|
|---|
| 6 | N J S J=1
|
|---|
| 7 | 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_","
|
|---|
| 8 | S A="P" F %I=0:0 S XQ83RL=0 S A=$O(^XUTL("XQO",A)) Q:$E(A)'="P" D
|
|---|
| 9 | . I $D(^XUTL("XQO",A,U,XQOPI)) D Q
|
|---|
| 10 | . . L +^XUTL("XQO",A):0 K ^(A,0)
|
|---|
| 11 | . . 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
|
|---|
| 12 | . F XQ83RI=1:1 S XQOPM=$O(XQ83R(XQ83RI)) Q:XQOPM="" D
|
|---|
| 13 | . . I $D(^XUTL("XQO",A,"^",XQOPM)) D
|
|---|
| 14 | . . . I '$D(XQ83LOCK) L +^XUTL("XQO",A):0 S XQ83LOCK=1 K ^XUTL("XQO",A,0)
|
|---|
| 15 | . . . D ADD^XQ83A
|
|---|
| 16 | . I $D(XQ83LOCK) L -^XUTL("XQO",A) K XQ83LOCK S ^XUTL("XQO",A,0)=%XQT1
|
|---|
| 17 | .Q
|
|---|
| 18 | K XQ83R,XQ83RI,XQ83RL
|
|---|
| 19 | Q
|
|---|
| 20 | ;
|
|---|
| 21 | A ;
|
|---|
| 22 | S B=0 F J=0:0 S B=$O(^XUTL("XQO",A,B)) Q:B=""!(B=U) I +^(B)=XQOPI K ^(B)
|
|---|
| 23 | D A1
|
|---|
| 24 | F I=0:0 S I=$O(^XUTL("XQO",A,U,I)) Q:I'>0 D A2
|
|---|
| 25 | Q
|
|---|
| 26 | A2 ;
|
|---|
| 27 | S L=0,%XQX=$P(^XUTL("XQO",A,U,I),U,9) I $E(%XQX,1,$L(XQC1))=XQC1!(%XQX[XQC2) S L=1
|
|---|
| 28 | 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
|
|---|
| 29 | 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
|
|---|
| 30 | I L I K=0 K ^XUTL("XQO",A,U,I)
|
|---|
| 31 | K L,K
|
|---|
| 32 | Q
|
|---|
| 33 | ;
|
|---|
| 34 | A1 ;
|
|---|
| 35 | Q:$P(^DIC(19,XQOPI,0),U,3)'="" D:'($D(^("U"))#2) UP S %XQX=^DIC(19,XQOPI,"U"),%XQX2=1 D A11
|
|---|
| 36 | 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
|
|---|
| 37 | Q
|
|---|
| 38 | A11 ;
|
|---|
| 39 | 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
|
|---|
| 40 | 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
|
|---|
| 41 | I P S ^XUTL("XQO",A,(%XQX_U_$S(P=1:"",1:P-1)))=XQOPI_U_%XQX2
|
|---|
| 42 | Q
|
|---|
| 43 | ;
|
|---|
| 44 | D ;
|
|---|
| 45 | 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
|
|---|
| 46 | Q
|
|---|
| 47 | D1 ;
|
|---|
| 48 | 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
|
|---|
| 49 | 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
|
|---|
| 50 | Q
|
|---|
| 51 | ;
|
|---|
| 52 | GET ;
|
|---|
| 53 | S XQOOO="",(XQK,XQP,XQE,XQF)="" F M=1:1 S %XQA=$P(XQA,",",M) Q:%XQA'>0 D SUM
|
|---|
| 54 | S:XQOOO XQA="" K XQOOO
|
|---|
| 55 | Q
|
|---|
| 56 | ;
|
|---|
| 57 | SUM ;
|
|---|
| 58 | S XQK1=$P(^DIC(19,%XQA,0),U,6),XQE1=$P(^(0),U,10),XQF1="" I $D(^(3)) S XQF1=$P(^(3),U)
|
|---|
| 59 | 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)
|
|---|
| 60 | S XQOOO=$S($P(^DIC(19,%XQA,0),U,3)'="":1,1:XQOOO)
|
|---|
| 61 | 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)
|
|---|
| 62 | S:XQP1="" XQP1=$P(^DIC(19,%XQA,0),U,9) S XQP=$S(XQP1'=""&(XQP'=""):XQP_";"_XQP1,1:XQP_XQP1)
|
|---|
| 63 | Q
|
|---|
| 64 | ;
|
|---|
| 65 | 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)
|
|---|
| 66 | S X=$E(X,1,30),^DIC(19,XQOPI,"U")=X,^DIC(19,"C",X,XQOPI)=""
|
|---|
| 67 | Q
|
|---|
| 68 | ;
|
|---|
| 69 | SYN ;
|
|---|
| 70 | S A="P" F S=0:0 S A=$O(^XUTL("XQO",A)) Q:$E(A)'="P" D SYN1
|
|---|
| 71 | K A,S,T,XQSYN,XQNAM
|
|---|
| 72 | Q
|
|---|
| 73 | SYN1 ;
|
|---|
| 74 | 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)
|
|---|
| 75 | 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)
|
|---|
| 76 | 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
|
|---|
| 77 | Q
|
|---|
| 78 | SYN2 ;
|
|---|
| 79 | Q:'$D(^XUTL("XQO",A,U,XQOPI)) S XQSYN2A=","_XQOPM_","_XQOPI_","
|
|---|
| 80 | 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
|
|---|
| 81 | K XQSYN2A I 'XQSYN2 K T,XQSYN2 Q
|
|---|
| 82 | S XQLAST=XQOPI,V=XQLAST_U_"0",XQSYNY=XQSYN D SYN3 K XQLAST,V,XQSYNY,XQSYN2
|
|---|
| 83 | Q
|
|---|
| 84 | 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
|
|---|
| 85 | Q:'XQ83RT I XQ83RT=1 S ^XUTL("XQO",A,(XQSYNY_U))=V Q
|
|---|
| 86 | I XQ83RT>1,$D(^XUTL("XQO",A,XQSYNY_U)) S ^(XQSYNY_U_"1")=^(XQSYNY_U) K ^(XQSYNY_U)
|
|---|
| 87 | F XQ83RT=1:1 I '$D(^XUTL("XQO",A,(XQSYNY_U_XQ83RT))) S ^(XQSYNY_U_XQ83RT)=V Q
|
|---|
| 88 | K XQ83RT
|
|---|
| 89 | Q
|
|---|
