%AUGC ; COPY GLOBAL (ANY LEVEL) [ 12/30/86 9:57 AM ]
NEW
GSGL R !,"Source global: ",SG,!
Q:SG=""
S:$E(SG)'="^" SG="^"_SG
S:SG'["(" SG=SG_"("
S:$E(SG,$L(SG))="," SG=$E(SG,1,$L(SG)-1)
I SG'?1"^"1U.U1"(".UNP W $C(7) G GSGL
I $E(SG,$L(SG))=")" W !!,"Global must be partial!,",!,$C(7) G GSGL
S SUB=$P(SG,"(",2),SCNT=0 F L=0:0 S SCNT=SCNT+1,NSUB=$P(SUB,",",SCNT) Q:NSUB="" Q:NSUB'?1N.N&(NSUB'?1"."1N.N)&(NSUB'?1""""1UN.UN1"""")
I NSUB'="" W !!,"Invalid subscript!",$C(7) G GSGL
K SUB,SCNT,NSUB
I $E(SG,$L(SG))="(" I $D(@($E(SG,1,$L(SG)-1)))=0 W !!,"Global ",SG," does not exist!",!,$C(7) G GSGL
I $E(SG,$L(SG))'="(" I $D(@(SG_")"))=0 W !!,"Partial global ",SG," does not exist!",!,$C(7) G GSGL
GDGL R !,"Destination global: ",DG,!
Q:DG=""
S:$E(DG)'="^" DG="^"_DG
S:DG'["(" DG=DG_"("
S:$E(DG,$L(DG))="," DG=$E(DG,1,$L(DG)-1)
I DG'?1"^"1U.U1"(".UNP W $C(7) G GDGL
I $E(DG,$L(DG))=")" W !!,"Global must be partial!,",!,$C(7) G GDGL
S SUB=$P(DG,"(",2),SCNT=0 F L=0:0 S SCNT=SCNT+1,NSUB=$P(SUB,",",SCNT) Q:NSUB="" Q:NSUB'?1N.N&(NSUB'?1""""1UN.UN1"""")
I NSUB'="" W !!,"Invalid subscript!",$C(7) G GDGL
K SUB,SCNT,NSUB
I SG=DG W !!,"Output same as input!",$C(7),! G GSGL
I $L(DG)>$L(SG) I $E(DG,1,$L(SG))=SG W !!,"Output contained in input!",$C(7),! G GSGL
I $L(DG)<$L(SG) I $E(SG,1,$L(DG))=DG W !!,"Input contained in output!",$C(7),! G GSGL
I $E(DG,$L(DG))="(" I $D(@($P(DG,"(",1)))'=0 W !!,"Destination global """,$P(DG,"(",1),""" already exists!",! S IS=""
I $E(DG,$L(DG))'="(" I $D(@(DG_")"))'=0 W !!,"Partial global ",DG," already exists.",! S IS=""
I $D(IS) W !,"KILL (Y/N) " R ANS Q:$E(ANS)'="Y" K:$E(DG,$L(DG))="(" @($E(DG,1,$L(DG)-1)) K:$E(DG,$L(DG))'="(" @(DG_")")
I $E(SG,$L(SG))="(" S FROM=$E(SG,1,$L(SG)-1)
E S FROM=SG_")"
I $E(DG,$L(DG))="(" S TO=$E(DG,1,$L(SG)-1)
E S TO=DG_")"
S:$D(@(FROM))#10 @(TO)=@(FROM)
S (SCMA,DCMA)="" S:$E(SG,$L(SG))'="(" SCMA="," S:$E(DG,$L(DG))'="(" DCMA=","
D WALK
W !!,"All done!",!
K G GSGL
;
WALK ; TRAVERSE TREE AT CURRENT SUBSCRIPT LEVEL
NEW (SCMA,DCMA,SG,DG)
S NL="" F L=0:0 S NL=$O(@(SG_SCMA_""""_NL_""")")) Q:NL="" D GOTNODE
Q
;
GOTNODE ; PROCESS ONE NODE
W "."
S FROM=SG_SCMA_"NL)"
S TO=DG_DCMA_"NL)"
I $D(@(FROM))#10 S VAL=@(FROM),@(TO)=VAL
I $D(@(FROM))\10 S LNL=$L(NL),SG=SG_SCMA_""""_NL_"""",DG=DG_DCMA_""""_NL_"""",SVSCMA=SCMA,SVDCMA=DCMA,(SCMA,DCMA)="," D WALK S SCMA=SVSCMA,DCMA=SVDCMA,SG=$E(SG,1,$L(SG)-(LNL+2+$L(SCMA))),DG=$E(DG,1,$L(DG)-(LNL+2+$L(DCMA)))
Q
%AUGC ; COPY GLOBAL (ANY LEVEL) [ 12/30/86 9:57 AM ]
+1 NEW
GSGL READ !,"Source global: ",SG,!
+1 IF SG=""
QUIT
+2 IF $EXTRACT(SG)'="^"
SET SG="^"_SG
+3 IF SG'["("
SET SG=SG_"("
+4 IF $EXTRACT(SG,$LENGTH(SG))=","
SET SG=$EXTRACT(SG,1,$LENGTH(SG)-1)
+5 IF SG'?1"^"1U.U1"(".UNP
WRITE $CHAR(7)
GOTO GSGL
+6 IF $EXTRACT(SG,$LENGTH(SG))=")"
WRITE !!,"Global must be partial!,",!,$CHAR(7)
GOTO GSGL
+7 SET SUB=$PIECE(SG,"(",2)
SET SCNT=0
FOR L=0:0
SET SCNT=SCNT+1
SET NSUB=$PIECE(SUB,",",SCNT)
IF NSUB=""
QUIT
IF NSUB'?1N.N&(NSUB'?1"."1N.N)&(NSUB'?1""""1UN.UN1"""")
QUIT
+8 IF NSUB'=""
WRITE !!,"Invalid subscript!",$CHAR(7)
GOTO GSGL
+9 KILL SUB,SCNT,NSUB
+10 IF $EXTRACT(SG,$LENGTH(SG))="("
IF $DATA(@($EXTRACT(SG,1,$LENGTH(SG)-1)))=0
WRITE !!,"Global ",SG," does not exist!",!,$CHAR(7)
GOTO GSGL
+11 IF $EXTRACT(SG,$LENGTH(SG))'="("
IF $DATA(@(SG_")"))=0
WRITE !!,"Partial global ",SG," does not exist!",!,$CHAR(7)
GOTO GSGL
GDGL READ !,"Destination global: ",DG,!
+1 IF DG=""
QUIT
+2 IF $EXTRACT(DG)'="^"
SET DG="^"_DG
+3 IF DG'["("
SET DG=DG_"("
+4 IF $EXTRACT(DG,$LENGTH(DG))=","
SET DG=$EXTRACT(DG,1,$LENGTH(DG)-1)
+5 IF DG'?1"^"1U.U1"(".UNP
WRITE $CHAR(7)
GOTO GDGL
+6 IF $EXTRACT(DG,$LENGTH(DG))=")"
WRITE !!,"Global must be partial!,",!,$CHAR(7)
GOTO GDGL
+7 SET SUB=$PIECE(DG,"(",2)
SET SCNT=0
FOR L=0:0
SET SCNT=SCNT+1
SET NSUB=$PIECE(SUB,",",SCNT)
IF NSUB=""
QUIT
IF NSUB'?1N.N&(NSUB'?1""""1UN.UN1"""")
QUIT
+8 IF NSUB'=""
WRITE !!,"Invalid subscript!",$CHAR(7)
GOTO GDGL
+9 KILL SUB,SCNT,NSUB
+10 IF SG=DG
WRITE !!,"Output same as input!",$CHAR(7),!
GOTO GSGL
+11 IF $LENGTH(DG)>$LENGTH(SG)
IF $EXTRACT(DG,1,$LENGTH(SG))=SG
WRITE !!,"Output contained in input!",$CHAR(7),!
GOTO GSGL
+12 IF $LENGTH(DG)<$LENGTH(SG)
IF $EXTRACT(SG,1,$LENGTH(DG))=DG
WRITE !!,"Input contained in output!",$CHAR(7),!
GOTO GSGL
+13 IF $EXTRACT(DG,$LENGTH(DG))="("
IF $DATA(@($PIECE(DG,"(",1)))'=0
WRITE !!,"Destination global """,$PIECE(DG,"(",1),""" already exists!",!
SET IS=""
+14 IF $EXTRACT(DG,$LENGTH(DG))'="("
IF $DATA(@(DG_")"))'=0
WRITE !!,"Partial global ",DG," already exists.",!
SET IS=""
+15 IF $DATA(IS)
WRITE !,"KILL (Y/N) "
READ ANS
IF $EXTRACT(ANS)'="Y"
QUIT
IF $EXTRACT(DG,$LENGTH(DG))="("
KILL @($EXTRACT(DG,1,$LENGTH(DG)-1))
IF $EXTRACT(DG,$LENGTH(DG))'="("
KILL @(DG_")")
+16 IF $EXTRACT(SG,$LENGTH(SG))="("
SET FROM=$EXTRACT(SG,1,$LENGTH(SG)-1)
+17 IF '$TEST
SET FROM=SG_")"
+18 IF $EXTRACT(DG,$LENGTH(DG))="("
SET TO=$EXTRACT(DG,1,$LENGTH(SG)-1)
+19 IF '$TEST
SET TO=DG_")"
+20 IF $DATA(@(FROM))#10
SET @(TO)=@(FROM)
+21 SET (SCMA,DCMA)=""
IF $EXTRACT(SG,$LENGTH(SG))'="("
SET SCMA=","
IF $EXTRACT(DG,$LENGTH(DG))'="("
SET DCMA=","
+22 DO WALK
+23 WRITE !!,"All done!",!
+24 KILL
GOTO GSGL
+25 ;
WALK ; TRAVERSE TREE AT CURRENT SUBSCRIPT LEVEL
+1 NEW (SCMA,DCMA,SG,DG)
+2 SET NL=""
FOR L=0:0
SET NL=$ORDER(@(SG_SCMA_""""_NL_""")"))
IF NL=""
QUIT
DO GOTNODE
+3 QUIT
+4 ;
GOTNODE ; PROCESS ONE NODE
+1 WRITE "."
+2 SET FROM=SG_SCMA_"NL)"
+3 SET TO=DG_DCMA_"NL)"
+4 IF $DATA(@(FROM))#10
SET VAL=@(FROM)
SET @(TO)=VAL
+5 IF $DATA(@(FROM))\10
SET LNL=$LENGTH(NL)
SET SG=SG_SCMA_""""_NL_""""
SET DG=DG_DCMA_""""_NL_""""
SET SVSCMA=SCMA
SET SVDCMA=DCMA
SET (SCMA,DCMA)=","
DO WALK
SET SCMA=SVSCMA
SET DCMA=SVDCMA
SET SG=$EXTRACT(SG,1,$LENGTH(SG)-(LNL+2+$LENGTH(SCMA)))
SET DG=$EXTRACT(DG,1,$LENGTH(DG)-(LNL+2+$LENGTH(DCMA)))
+6 QUIT
