DDSCLONE ;SFISC/MKO-CLONE A FORM ;10:20 PM  10 Jul 1994
 ;;22.0;VA FileMan;;Mar 30, 1999
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 N %,%CHK,%RET,%X,%Y,D,D0,D1,DA,DI,DIOVRD,DIC,DIR,DIZ,DQ,DREF,X,Y
 K ^TMP("DDSCLONE",$J)
 S DDSQUIT=0,DIOVRD=1
 ;
 S DDSFORM=$$FORM G:DDSFORM=-1 QUIT
 ;
 D GETBLKS
 D REPORT G:DDSQUIT QUIT
 D RENMSP G:DDSQUIT QUIT
 D RENAME G:DDSQUIT QUIT
 D ^DDSCLONF
 W !!!,"DONE!"
 ;
QUIT ;Cleanup
 K ^TMP("DDSCLONE",$J)
 K DDSBK,DDSBKDA,DDSFILE,DDSFORM,DDSNFRM,DDSNNS,DDSONS,DDSQUIT
 K DDH,DIRUT,DIROUT,DTOUT,DUOUT
 Q
 ;
FORM() ;Prompt for form
 ;Select file
 N D,DIC
 S DDS1="CLONE FORM FROM" D W^DICRW K DDS1 G:Y<0 FORMQ
 I '$D(@(DIC_"0)")) S Y=-1 G FORMQ
 S DDSFILE=Y
 ;
 ;Select form
 W ! K DIC
 S DIC="^DIST(.403,",DIC(0)="QEAM"
 S DIC(0)="QEA",D="F"_+DDSFILE
 S DIC("S")="I $P(^(0),U,8)=+DDSFILE"
 S DIC("A")="Select FORM to clone: "
 S DIC("W")=$P($T(DICW),";",3,999)
DICW ;;N %G,%Y S %Y=Y,%G=^(0) W:$X>35 ! W ?35,"#"_Y S Y=$P(%G,U,5) W:Y]"" ?43," "_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) S Y=$P(%G,U,4) W:Y]"" ?53," User #"_Y S Y=$P(%G,U,8) W:Y]"" ?65," File #"_Y S Y=%Y
 D IX^DIC
 ;
FORMQ Q Y
 ;
GETBLKS ;Get all blocks on form
 ; ^TMP("DDSCLONE",$J,bk#)=Block name
 ;
 N B,P
 S P=0 F  S P=$O(^DIST(.403,+DDSFORM,40,P)) Q:'P  D
 . S B=$P(^DIST(.403,+DDSFORM,40,P,0),U,2)
 . I B]"",'$D(^TMP("DDSCLONE",$J,B)) D
 .. S ^TMP("DDSCLONE",$J,B)=$P($G(^DIST(.404,B,0)),U)
 . S B=0
 . F  S B=$O(^DIST(.403,+DDSFORM,40,P,40,B)) Q:'B  D
 .. Q:$D(^TMP("DDSCLONE",$J,B))
 .. S ^TMP("DDSCLONE",$J,B)=$P($G(^DIST(.404,B,0)),U)
 Q
 ;
REPORT ;Print report
 N B
 W !!!
 I '$D(^TMP("DDSCLONE",$J)) S DDSQUIT=1 W "There are no blocks on this form." Q
 ;
 W "  BLOCKS USED ON FORM """_$P(DDSFORM,U,2)_""" (IEN #"_+DDSFORM_")"
 W !!,"  Internal"
 W !,"  Entry Number   Block Name"
 W !,"  ------------   ----------"
 ;
 S B="" F  S B=$O(^TMP("DDSCLONE",$J,B)) Q:B=""  D
 . W !,"  "_B,?17,$P(^TMP("DDSCLONE",$J,B),U)
 ;
 K DIR
 S DIR(0)="E"
 W ! D ^DIR K DIR
 I $D(DIRUT) S DDSQUIT=1
 W !
 Q
 ;
RENMSP ;Prompt for new namespace
 W !!,"The new form and blocks must be given unique names.",!
 ;
 K DIR
 S DIR(0)="Y",DIR("B")="YES"
 S DIR("A",1)="Give the new form and blocks the same names as the original,"
 S DIR("A")="but a different namespace"
 S DIR("?",1)="   Answer 'YES' if the original form and blocks are namespaced, and you want"
 S DIR("?")="   the new forms and blocks to have a different namespace."
 D ^DIR K DIR
 I $D(DIRUT) S DDSQUIT=1 Q
 I 'Y K DDSONSP,DDSNNSP Q
 ;
 K DIR
 W !!
 S DIR(0)="FA^1:30"
 S DIR("A")="Original namespace: "
 S DIR("?")="   Enter the namespace of the original form and blocks"
 D ^DIR K DIR
 I $D(DIRUT) S DDSQUIT=1 Q
 S DDSONS=Y
 ;
 K DIR,X,Y
 S DIR(0)="FA^1:30"
 S DIR("A")="     New namespace: "
 S DIR("?")="   Enter the namespace of the new form and blocks"
 D ^DIR K DIR
 I $D(DIRUT) S DDSQUIT=1 Q
 S DDSNNS=Y
 K X,Y
 Q
 ;
RENAME ;Prompt for new names
 N DDSBK,DDSBKDA
 D:'$D(IOST) HOME^%ZIS
 W @IOF
 W "Enter names for the new form and blocks."
 ;
 D RENFORM Q:DDSQUIT
 ;
 W !
 S DDSBKDA=0
 F  S DDSBKDA=$O(^TMP("DDSCLONE",$J,DDSBKDA))  Q:'DDSBKDA!DDSQUIT  D
 . S DDSBK=^TMP("DDSCLONE",$J,DDSBKDA)
 . D RENBLK(.DDSBK) Q:DDSQUIT
 . S ^TMP("DDSCLONE",$J,DDSBKDA)=DDSBK
 . S ^TMP("DDSCLONE",$J,"B",$P(DDSBK,U,2))=""
 ;
 Q
 ;
RENFORM ;Rename the form
 N DDSANS,DDSCOD
 F  D  Q:DDSANS]""!DDSQUIT
 . W !!,"Original form name: "_$P(DDSFORM,U,2)
 . W !,"     New form name: "
 . D EN^DIR0($S($Y>IOSL:IOSL-1,1:$Y),$X,30,1,$$NAME($P(DDSFORM,U,2),$G(DDSONS),$G(DDSNNS)),30,"","","",.DDSANS,.DDSCOD)
 . ;
 . I $P(DDSCOD,U)="TO"!(DDSANS=U) S DDSQUIT=1 Q
 . I DDSANS?1."?" W !!,"  Enter the name of the new form." S DDSANS=""
 . Q:DDSANS=""
 . S X=DDSANS X $P(^DD(.403,.01,0),U,5,999)
 . I '$D(X) S DDSANS="" W !!,$C(7)_"  Invalid name." Q
 . I $D(^DIST(.403,"B",DDSANS)) D  Q
 .. S DDSANS=""
 .. W !!,$C(7)_"  Form with this name already exists."
 Q:DDSQUIT
 ;
 S $P(DDSFORM,U,3)=DDSANS
 Q
 ;
RENBLK(DDSBK) ;Rename the blocks
 N DDSANS,DDSCOD
 F  D  Q:DDSANS]""!DDSQUIT
 . W !!,"Original block name: "_$P(DDSBK,U)
 . W !,"     New block name: "
 . D EN^DIR0($S($Y>IOSL:IOSL-1,1:$Y),$X,30,1,$$NAME($P(DDSBK,U),$G(DDSONS),$G(DDSNNS)),30,"","","",.DDSANS,.DDSCOD)
 . ;
 . I $P(DDSCOD,U)="TO"!(DDSANS=U) S DDSQUIT=1 Q
 . I DDSANS?1."?" W !!,"  Enter the name of the new form." S DDSANS=""
 . Q:DDSANS=""
 . S X=DDSANS X $P(^DD(.404,.01,0),U,5,999)
 . I '$D(X) S DDSANS="" W !!,$C(7)_"  Invalid name." Q
 . D:$D(^DIST(.404,"B",DDSANS))!$D(^TMP("DDSCLONE",$J,"B",DDSANS))
 .. S DDSANS=""
 .. W !!,$C(7)_"  Block with this name already exists."
 Q:DDSQUIT
 ;
 S $P(DDSBK,U,2)=DDSANS
 Q
 ;
NAME(NAME,ONS,NNS) ;Replace old namespace with new
 I $G(ONS)=""!($G(NNS)="") Q NAME
 I $P(NAME,ONS)]"" Q NAME
 Q NNS_$E(NAME,$L(ONS)+1,999)