Annotation of freem_fileman/USER/DDSCLONE.m, revision 1.1
1.1 ! snw 1: DDSCLONE ;SFISC/MKO-CLONE A FORM ;10:20 PM 10 Jul 1994
! 2: ;;21.0;VA FileMan;;Dec 28, 1994
! 3: ;Per VHA Directive 10-93-142, this routine should not be modified.
! 4: N %,%CHK,%RET,%X,%Y,D,D0,D1,DA,DI,DIOVRD,DIC,DIR,DIZ,DQ,DREF,X,Y
! 5: K ^TMP("DDSCLONE",$J)
! 6: S DDSQUIT=0,DIOVRD=1
! 7: ;
! 8: S DDSFORM=$$FORM G:DDSFORM=-1 QUIT
! 9: ;
! 10: D GETBLKS
! 11: D REPORT G:DDSQUIT QUIT
! 12: D RENMSP G:DDSQUIT QUIT
! 13: D RENAME G:DDSQUIT QUIT
! 14: D ^DDSCLONF
! 15: W !!!,"DONE!"
! 16: ;
! 17: QUIT ;Cleanup
! 18: K ^TMP("DDSCLONE",$J)
! 19: K DDSBK,DDSBKDA,DDSFILE,DDSFORM,DDSNFRM,DDSNNS,DDSONS,DDSQUIT
! 20: K DDH,DIRUT,DIROUT,DTOUT,DUOUT
! 21: Q
! 22: ;
! 23: FORM() ;Prompt for form
! 24: ;Select file
! 25: N D,DIC
! 26: S DDS1="CLONE FORM FROM" D W^DICRW K DDS1 G:Y<0 FORMQ
! 27: I '$D(@(DIC_"0)")) S Y=-1 G FORMQ
! 28: S DDSFILE=Y
! 29: ;
! 30: ;Select form
! 31: W ! K DIC
! 32: S DIC="^DIST(.403,",DIC(0)="QEAM"
! 33: S DIC(0)="QEA",D="F"_+DDSFILE
! 34: S DIC("S")="I $P(^(0),U,8)=+DDSFILE"
! 35: S DIC("A")="Select FORM to clone: "
! 36: S DIC("W")=$P($T(DICW),";",3,999)
! 37: 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
! 38: D IX^DIC
! 39: ;
! 40: FORMQ Q Y
! 41: ;
! 42: GETBLKS ;Get all blocks on form
! 43: ; ^TMP("DDSCLONE",$J,bk#)=Block name
! 44: ;
! 45: N B,P
! 46: S P=0 F S P=$O(^DIST(.403,+DDSFORM,40,P)) Q:'P D
! 47: . S B=$P(^DIST(.403,+DDSFORM,40,P,0),U,2)
! 48: . I B]"",'$D(^TMP("DDSCLONE",$J,B)) D
! 49: .. S ^TMP("DDSCLONE",$J,B)=$P($G(^DIST(.404,B,0)),U)
! 50: . S B=0
! 51: . F S B=$O(^DIST(.403,+DDSFORM,40,P,40,B)) Q:'B D
! 52: .. Q:$D(^TMP("DDSCLONE",$J,B))
! 53: .. S ^TMP("DDSCLONE",$J,B)=$P($G(^DIST(.404,B,0)),U)
! 54: Q
! 55: ;
! 56: REPORT ;Print report
! 57: N B
! 58: W !!!
! 59: I '$D(^TMP("DDSCLONE",$J)) S DDSQUIT=1 W "There are no blocks on this form." Q
! 60: ;
! 61: W " BLOCKS USED ON FORM """_$P(DDSFORM,U,2)_""" (IEN #"_+DDSFORM_")"
! 62: W !!," Internal"
! 63: W !," Entry Number Block Name"
! 64: W !," ------------ ----------"
! 65: ;
! 66: S B="" F S B=$O(^TMP("DDSCLONE",$J,B)) Q:B="" D
! 67: . W !," "_B,?17,$P(^TMP("DDSCLONE",$J,B),U)
! 68: ;
! 69: K DIR
! 70: S DIR(0)="E"
! 71: W ! D ^DIR K DIR
! 72: I $D(DIRUT) S DDSQUIT=1
! 73: W !
! 74: Q
! 75: ;
! 76: RENMSP ;Prompt for new namespace
! 77: W !!,"The new form and blocks must be given unique names.",!
! 78: ;
! 79: K DIR
! 80: S DIR(0)="Y",DIR("B")="YES"
! 81: S DIR("A",1)="Give the new form and blocks the same names as the original,"
! 82: S DIR("A")="but a different namespace"
! 83: S DIR("?",1)=" Answer 'YES' if the original form and blocks are namespaced, and you want"
! 84: S DIR("?")=" the new forms and blocks to have a different namespace."
! 85: D ^DIR K DIR
! 86: I $D(DIRUT) S DDSQUIT=1 Q
! 87: I 'Y K DDSONSP,DDSNNSP Q
! 88: ;
! 89: K DIR
! 90: W !!
! 91: S DIR(0)="FA^1:30"
! 92: S DIR("A")="Original namespace: "
! 93: S DIR("?")=" Enter the namespace of the original form and blocks"
! 94: D ^DIR K DIR
! 95: I $D(DIRUT) S DDSQUIT=1 Q
! 96: S DDSONS=Y
! 97: ;
! 98: K DIR,X,Y
! 99: S DIR(0)="FA^1:30"
! 100: S DIR("A")=" New namespace: "
! 101: S DIR("?")=" Enter the namespace of the new form and blocks"
! 102: D ^DIR K DIR
! 103: I $D(DIRUT) S DDSQUIT=1 Q
! 104: S DDSNNS=Y
! 105: K X,Y
! 106: Q
! 107: ;
! 108: RENAME ;Prompt for new names
! 109: N DDSBK,DDSBKDA
! 110: D:'$D(IOST) HOME^%ZIS
! 111: W @IOF
! 112: W "Enter names for the new form and blocks."
! 113: ;
! 114: D RENFORM Q:DDSQUIT
! 115: ;
! 116: W !
! 117: S DDSBKDA=0
! 118: F S DDSBKDA=$O(^TMP("DDSCLONE",$J,DDSBKDA)) Q:'DDSBKDA!DDSQUIT D
! 119: . S DDSBK=^TMP("DDSCLONE",$J,DDSBKDA)
! 120: . D RENBLK(.DDSBK) Q:DDSQUIT
! 121: . S ^TMP("DDSCLONE",$J,DDSBKDA)=DDSBK
! 122: . S ^TMP("DDSCLONE",$J,"B",$P(DDSBK,U,2))=""
! 123: ;
! 124: Q
! 125: ;
! 126: RENFORM ;Rename the form
! 127: N DDSANS,DDSCOD
! 128: F D Q:DDSANS]""!DDSQUIT
! 129: . W !!,"Original form name: "_$P(DDSFORM,U,2)
! 130: . W !," New form name: "
! 131: . 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)
! 132: . ;
! 133: . I $P(DDSCOD,U)="TO"!(DDSANS=U) S DDSQUIT=1 Q
! 134: . I DDSANS?1."?" W !!," Enter the name of the new form." S DDSANS=""
! 135: . Q:DDSANS=""
! 136: . S X=DDSANS X $P(^DD(.403,.01,0),U,5,999)
! 137: . I '$D(X) S DDSANS="" W !!,$C(7)_" Invalid name." Q
! 138: . I $D(^DIST(.403,"B",DDSANS)) D Q
! 139: .. S DDSANS=""
! 140: .. W !!,$C(7)_" Form with this name already exists."
! 141: Q:DDSQUIT
! 142: ;
! 143: S $P(DDSFORM,U,3)=DDSANS
! 144: Q
! 145: ;
! 146: RENBLK(DDSBK) ;Rename the blocks
! 147: N DDSANS,DDSCOD
! 148: F D Q:DDSANS]""!DDSQUIT
! 149: . W !!,"Original block name: "_$P(DDSBK,U)
! 150: . W !," New block name: "
! 151: . D EN^DIR0($S($Y>IOSL:IOSL-1,1:$Y),$X,30,1,$$NAME($P(DDSBK,U),$G(DDSONS),$G(DDSNNS)),30,"","","",.DDSANS,.DDSCOD)
! 152: . ;
! 153: . I $P(DDSCOD,U)="TO"!(DDSANS=U) S DDSQUIT=1 Q
! 154: . I DDSANS?1."?" W !!," Enter the name of the new form." S DDSANS=""
! 155: . Q:DDSANS=""
! 156: . S X=DDSANS X $P(^DD(.404,.01,0),U,5,999)
! 157: . I '$D(X) S DDSANS="" W !!,$C(7)_" Invalid name." Q
! 158: . D:$D(^DIST(.404,"B",DDSANS))!$D(^TMP("DDSCLONE",$J,"B",DDSANS))
! 159: .. S DDSANS=""
! 160: .. W !!,$C(7)_" Block with this name already exists."
! 161: Q:DDSQUIT
! 162: ;
! 163: S $P(DDSBK,U,2)=DDSANS
! 164: Q
! 165: ;
! 166: NAME(NAME,ONS,NNS) ;Replace old namespace with new
! 167: I $G(ONS)=""!($G(NNS)="") Q NAME
! 168: I $P(NAME,ONS)]"" Q NAME
! 169: Q NNS_$E(NAME,$L(ONS)+1,999)
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to DDSCLONE.m CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Coherent Logic Development] / freem_fileman / USER