Routine: LRIGCOPY

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

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

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="*"

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

LRIGCOPY.m