- XBGC ; IHS/ADC/GTH - COPY GLOBAL (ANY LEVEL) ; [ 02/07/97 3:02 PM ]
- ;;3.0;IHS/VA UTILITIES;;FEB 07, 1997
- ;
- START ;
- NEW (%)
- GSGL ;
- R !,"Source global: ",SG:$G(DTIME,999),!
- 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
- KILL 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:$G(DTIME,999),!
- 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
- KILL 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:$G(DTIME,999) I $E(ANS)="Y" K:$E(DG,$L(DG))="(" @($E(DG,1,$L(DG)-1)) K:$E(DG,$L(DG))'="(" @(DG_")")
- I $D(IS),ANS'="Y" W !,"Copy anyway? (Y/N) N//" R ANS:$G(DTIME,999) S:ANS="" ANS="N" Q:ANS'="Y"
- 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(DG)-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=","
- S CTR=0
- D WALK
- W !!,"All done!",!
- G START
- ;
- WALK ; TRAVERSE TREE AT CURRENT SUBSCRIPT LEVEL
- NEW (CTR,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
- S CTR=CTR+1
- W:'(CTR#100) "."
- S FROM=SG_SCMA_"NL)",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
- ;
- XBGC ; IHS/ADC/GTH - COPY GLOBAL (ANY LEVEL) ; [ 02/07/97 3:02 PM ]
- +1 ;;3.0;IHS/VA UTILITIES;;FEB 07, 1997
- +2 ;
- START ;
- +1 NEW (%)
- GSGL ;
- +1 READ !,"Source global: ",SG:$GET(DTIME,999),!
- +2 IF SG=""
- QUIT
- +3 IF $EXTRACT(SG)'="^"
- SET SG="^"_SG
- +4 IF SG'["("
- SET SG=SG_"("
- +5 IF $EXTRACT(SG,$LENGTH(SG))=","
- SET SG=$EXTRACT(SG,1,$LENGTH(SG)-1)
- +6 IF SG'?1"^"1U.U1"(".UNP
- WRITE $CHAR(7)
- GOTO GSGL
- +7 IF $EXTRACT(SG,$LENGTH(SG))=")"
- WRITE !!,"Global must be partial!,",!,$CHAR(7)
- GOTO GSGL
- +8 KILL SUB,SCNT,NSUB
- +9 IF $EXTRACT(SG,$LENGTH(SG))="("
- IF $DATA(@($EXTRACT(SG,1,$LENGTH(SG)-1)))=0
- WRITE !!,"Global ",SG," does not exist!",!,$CHAR(7)
- GOTO GSGL
- +10 IF $EXTRACT(SG,$LENGTH(SG))'="("
- IF $DATA(@(SG_")"))=0
- WRITE !!,"Partial global ",SG," does not exist!",!,$CHAR(7)
- GOTO GSGL
- GDGL ;
- +1 READ !,"Destination global: ",DG:$GET(DTIME,999),!
- +2 IF DG=""
- QUIT
- +3 IF $EXTRACT(DG)'="^"
- SET DG="^"_DG
- +4 IF DG'["("
- SET DG=DG_"("
- +5 IF $EXTRACT(DG,$LENGTH(DG))=","
- SET DG=$EXTRACT(DG,1,$LENGTH(DG)-1)
- +6 IF DG'?1"^"1U.U1"(".UNP
- WRITE $CHAR(7)
- GOTO GDGL
- +7 IF $EXTRACT(DG,$LENGTH(DG))=")"
- WRITE !!,"Global must be partial!,",!,$CHAR(7)
- GOTO GDGL
- +8 KILL SUB,SCNT,NSUB
- +9 IF SG=DG
- WRITE !!,"Output same as input!",$CHAR(7),!
- GOTO GSGL
- +10 IF $LENGTH(DG)>$LENGTH(SG)
- IF $EXTRACT(DG,1,$LENGTH(SG))=SG
- WRITE !!,"Output contained in input!",$CHAR(7),!
- GOTO GSGL
- +11 IF $LENGTH(DG)<$LENGTH(SG)
- IF $EXTRACT(SG,1,$LENGTH(DG))=DG
- WRITE !!,"Input contained in output!",$CHAR(7),!
- GOTO GSGL
- +12 IF $EXTRACT(DG,$LENGTH(DG))="("
- IF $DATA(@($PIECE(DG,"(",1)))'=0
- WRITE !!,"Destination global """,$PIECE(DG,"(",1),""" already exists!",!
- SET IS=""
- +13 IF $EXTRACT(DG,$LENGTH(DG))'="("
- IF $DATA(@(DG_")"))'=0
- WRITE !!,"Partial global ",DG," already exists.",!
- SET IS=""
- +14 IF $DATA(IS)
- WRITE !,"KILL (Y/N) "
- READ ANS:$GET(DTIME,999)
- IF $EXTRACT(ANS)="Y"
- IF $EXTRACT(DG,$LENGTH(DG))="("
- KILL @($EXTRACT(DG,1,$LENGTH(DG)-1))
- IF $EXTRACT(DG,$LENGTH(DG))'="("
- KILL @(DG_")")
- +15 IF $DATA(IS)
- IF ANS'="Y"
- WRITE !,"Copy anyway? (Y/N) N//"
- READ ANS:$GET(DTIME,999)
- IF ANS=""
- SET ANS="N"
- IF ANS'="Y"
- QUIT
- +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(DG)-1)
- +19 IF '$TEST
- SET TO=DG_")"
- +20 IF $DATA(@(FROM))#10
- SET @(TO)=@(FROM)
- +21 SET (SCMA,DCMA)=""
- +22 IF $EXTRACT(SG,$LENGTH(SG))'="("
- SET SCMA=","
- +23 IF $EXTRACT(DG,$LENGTH(DG))'="("
- SET DCMA=","
- +24 SET CTR=0
- +25 DO WALK
- +26 WRITE !!,"All done!",!
- +27 GOTO START
- +28 ;
- WALK ; TRAVERSE TREE AT CURRENT SUBSCRIPT LEVEL
- +1 NEW (CTR,SCMA,DCMA,SG,DG)
- +2 SET NL=""
- +3 FOR L=0:0
- SET NL=$ORDER(@(SG_SCMA_""""_NL_""")"))
- IF NL=""
- QUIT
- DO GOTNODE
- +4 QUIT
- +5 ;
- GOTNODE ; PROCESS ONE NODE
- +1 SET CTR=CTR+1
- +2 IF '(CTR#100)
- WRITE "."
- +3 SET FROM=SG_SCMA_"NL)"
- 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
- +7 ;
