LRIGCOPY ;COPIES DD(63.04) TO TEMP AND BACK
;;5.2;LR;;NOV 01, 1997
;
S S1="`",S2="~",S3="!",S4="|",CM=",",QT=""""
F Q=0:0 D CTL Q:GLO=""
K SUBS,SUBS1,NN,GLO,OGLO
Q
;
CTL ;
R !,"COPY GLOBAL ",GLO Q:GLO=""
R !," TO GLOBAL ",GLO1 Q:GLO1=""
W !,"COPYING GLOBAL ",GLO," TO ",GLO1,!
ENT S OGLO=GLO S:$E(OGLO)'="^" OGLO="^"_OGLO S OGLO=$P(OGLO,"(")_"("
S SUBS1="",SUBS=$P($P(GLO,"(",2),")") S:$E(SUBS,$L(SUBS))=CM SUBS=$E(SUBS,1,$L(SUBS)-1)
S MXL=0,NSUBS=$L(SUBS,CM)+1,SUBS1="N1" S:SUBS="" NSUBS=1 I NSUBS>1 S SUBS1="" F N=1:1:NSUBS S @("N"_N)=$TR($P(SUBS,CM,N),"""","") S:N>1 SUBS1=SUBS1_CM S SUBS1=SUBS1_"N"_N
S LEV=NSUBS,MXL=LEV,@("N"_LEV)=""
S NGLO=GLO1 S:$E(NGLO)'="^" NGLO="^"_NGLO S NGLO=$P(NGLO,"(")_"("
S SUBS2="",SUBS=$P($P(GLO1,"(",2),")") S:$E(SUBS,$L(SUBS))=CM SUBS=$E(SUBS,1,$L(SUBS)-1)
S MXL1=0,NSUBS1=$L(SUBS,CM)+1,SUBS2="SS1" S:SUBS="" NSUBS1=1 I NSUBS1>1 S SUBS2="" F N=1:1:NSUBS1 S @("SS"_N)=$TR($P(SUBS,CM,N),"""","") S:N>1 SUBS2=SUBS2_CM S SUBS2=SUBS2_"SS"_N
S LEV1=NSUBS1,MXL1=LEV1,@("SS"_LEV1)=""
S DCK=0,X=$G(@$S(LEV=1:$P(OGLO,"("),1:OGLO_$P(SUBS1,CM,1,LEV-1)_")"))
S:X="" DCK=$D(@$S(LEV=1:$P(OGLO,"("),1:OGLO_$P(SUBS1,CM,1,LEV-1)_")"))
I X'=""!(DCK#10) S @$S(LEV1=1:$P(NGLO,"("),1:NGLO_$P(SUBS2,CM,1,LEV1-1)_")")=X
D SRH K @SUBS1,@SUBS2
Q
;
SRH ;
S:MXL<LEV MXL=LEV,SUBS1=SUBS1_CM_"N"_LEV,SUBS2=SUBS2_CM_"SS"_LEV1
S NN="N"_LEV,SS="SS"_LEV1,GLO=OGLO,@NN=$O(@(GLO_$P(SUBS1,CM,1,LEV)_")")),@SS=@NN
I @NN="" Q:LEV=NSUBS S LEV=LEV-1,LEV1=LEV1-1 G SRH
S DCK=0,X=$G(^(@NN)) S:X="" DCK=$D(^(@NN)) I X'=""!(DCK#10) S @(NGLO_$P(SUBS2,CM,1,LEV1)_")")=X
S LEV=LEV+1,LEV1=LEV1+1,@("N"_LEV)=""
G SRH
;
DSP ;
S P=0,LX=$L(X) F Q=0:0 S P=$F(X,STR,P) Q:'P W !,$ZR,!,ATOFF,$E(X,1,P-LNG-1),RV,$E(X,P-LNG,P-1),ATOFF,$E(X,P,999),ATOFF W:LX#80 $J("",LX\80+1*80-LX) R !,R Q:R="*"
Q
LRIGCOPY ;COPIES DD(63.04) TO TEMP AND BACK
+1 ;;5.2;LR;;NOV 01, 1997
+2 ;
+3 SET S1="`"
SET S2="~"
SET S3="!"
SET S4="|"
SET CM=","
SET QT=""""
+4 FOR Q=0:0
DO CTL
IF GLO=""
QUIT
+5 KILL SUBS,SUBS1,NN,GLO,OGLO
+6 QUIT
+7 ;
CTL ;
+1 READ !,"COPY GLOBAL ",GLO
IF GLO=""
QUIT
+2 READ !," TO GLOBAL ",GLO1
IF GLO1=""
QUIT
+3 WRITE !,"COPYING GLOBAL ",GLO," TO ",GLO1,!
ENT SET OGLO=GLO
IF $EXTRACT(OGLO)'="^"
SET OGLO="^"_OGLO
SET OGLO=$PIECE(OGLO,"(")_"("
+1 SET SUBS1=""
SET SUBS=$PIECE($PIECE(GLO,"(",2),")")
IF $EXTRACT(SUBS,$LENGTH(SUBS))=CM
SET SUBS=$EXTRACT(SUBS,1,$LENGTH(SUBS)-1)
+2 SET MXL=0
SET NSUBS=$LENGTH(SUBS,CM)+1
SET SUBS1="N1"
IF SUBS=""
SET NSUBS=1
IF NSUBS>1
SET SUBS1=""
FOR N=1:1:NSUBS
SET @("N"_N)=$TRANSLATE($PIECE(SUBS,CM,N),"""","")
IF N>1
SET SUBS1=SUBS1_CM
SET SUBS1=SUBS1_"N"_N
+3 SET LEV=NSUBS
SET MXL=LEV
SET @("N"_LEV)=""
+4 SET NGLO=GLO1
IF $EXTRACT(NGLO)'="^"
SET NGLO="^"_NGLO
SET NGLO=$PIECE(NGLO,"(")_"("
+5 SET SUBS2=""
SET SUBS=$PIECE($PIECE(GLO1,"(",2),")")
IF $EXTRACT(SUBS,$LENGTH(SUBS))=CM
SET SUBS=$EXTRACT(SUBS,1,$LENGTH(SUBS)-1)
+6 SET MXL1=0
SET NSUBS1=$LENGTH(SUBS,CM)+1
SET SUBS2="SS1"
IF SUBS=""
SET NSUBS1=1
IF NSUBS1>1
SET SUBS2=""
FOR N=1:1:NSUBS1
SET @("SS"_N)=$TRANSLATE($PIECE(SUBS,CM,N),"""","")
IF N>1
SET SUBS2=SUBS2_CM
SET SUBS2=SUBS2_"SS"_N
+7 SET LEV1=NSUBS1
SET MXL1=LEV1
SET @("SS"_LEV1)=""
+8 SET DCK=0
SET X=$GET(@$SELECT(LEV=1:$PIECE(OGLO,"("),1:OGLO_$PIECE(SUBS1,CM,1,LEV-1)_")"))
+9 IF X=""
SET DCK=$DATA(@$SELECT(LEV=1:$PIECE(OGLO,"("),1:OGLO_$PIECE(SUBS1,CM,1,LEV-1)_")"))
+10 IF X'=""!(DCK#10)
SET @$SELECT(LEV1=1:$PIECE(NGLO,"("),1:NGLO_$PIECE(SUBS2,CM,1,LEV1-1)_")")=X
+11 DO SRH
KILL @SUBS1,@SUBS2
+12 QUIT
+13 ;
SRH ;
+1 IF MXL<LEV
SET MXL=LEV
SET SUBS1=SUBS1_CM_"N"_LEV
SET SUBS2=SUBS2_CM_"SS"_LEV1
+2 SET NN="N"_LEV
SET SS="SS"_LEV1
SET GLO=OGLO
SET @NN=$ORDER(@(GLO_$PIECE(SUBS1,CM,1,LEV)_")"))
SET @SS=@NN
+3 IF @NN=""
IF LEV=NSUBS
QUIT
SET LEV=LEV-1
SET LEV1=LEV1-1
GOTO SRH
+4 SET DCK=0
SET X=$GET(^(@NN))
IF X=""
SET DCK=$DATA(^(@NN))
IF X'=""!(DCK#10)
SET @(NGLO_$PIECE(SUBS2,CM,1,LEV1)_")")=X
+5 SET LEV=LEV+1
SET LEV1=LEV1+1
SET @("N"_LEV)=""
+6 GOTO SRH
+7 ;
DSP ;
+1 SET P=0
SET LX=$LENGTH(X)
FOR Q=0:0
SET P=$FIND(X,STR,P)
IF 'P
QUIT
WRITE !,$ZR,!,ATOFF,$EXTRACT(X,1,P-LNG-1),RV,$EXTRACT(X,P-LNG,P-1),ATOFF,$EXTRACT(X,P,999),ATOFF
IF LX#80
WRITE $JUSTIFY("",LX\80+1*80-LX)
READ !,R
IF R="*"
QUIT
+2 QUIT
