Return to DDSCLONF.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

    1: DDSCLONF	;SFISC/MKO-CLONE A FORM ;01:47 PM  29 Jul 1994
    2: 	;;21.0;VA FileMan;;Dec 28, 1994
    3: 	;Per VHA Directive 10-93-142, this routine should not be modified.
    4: 	D ASKCONT Q:DDSQUIT
    5: 	D CREATBK Q:DDSQUIT
    6: 	D CREATFM Q:DDSQUIT
    7: 	D EDITFM
    8: 	D INDEXFM
    9: 	K DDSNFRM
   10: 	Q
   11: 	;
   12: CREATBK	;Create blocks
   13: 	N DA,DIC
   14: 	W !!,"Creating new blocks ...",!
   15: 	S DDSBKDA=0
   16: 	F  S DDSBKDA=$O(^TMP("DDSCLONE",$J,DDSBKDA)) Q:'DDSBKDA!DDSQUIT  D
   17: 	. S DDSBK=^TMP("DDSCLONE",$J,DDSBKDA)
   18: 	. W !?2,$P(DDSBK,U,2)
   19: 	. K DIC
   20: 	. S DIC="^DIST(.404,",DIC(0)="QL",X=$P(DDSBK,U,2)
   21: 	. D FILE^DICN K DIC
   22: 	. I Y=-1 D  Q
   23: 	.. W !,$C(7)_"Attempt to create block "_$P(DDSBK,U,2)_" failed."
   24: 	.. S DDSQUIT=1
   25: 	. M ^DIST(.404,+Y)=^DIST(.404,DDSBKDA)
   26: 	. S $P(^DIST(.404,+Y,0),U)=$P(DDSBK,U,2)
   27: 	. W ?35,"#"_+Y
   28: 	. S $P(^TMP("DDSCLONE",$J,DDSBKDA),U,3)=+Y
   29: 	Q
   30: 	;
   31: CREATFM	;Create form
   32: 	N DA,DIC,DDSI,DDSJ
   33: 	W !!,"Creating new form ..."
   34: 	W !?2,$P(DDSFORM,U,3)
   35: 	K DIC
   36: 	S DIC="^DIST(.403,",DIC(0)="QL",X=$P(DDSFORM,U,3)
   37: 	D FILE^DICN K DIC
   38: 	I Y=-1 D  Q
   39: 	. W !,$C(7)_"Attempt to create form "_$P(DDSFORM,U,3)_" failed."
   40: 	. S DDSQUIT=1
   41: 	M ^DIST(.403,+Y)=^DIST(.403,+DDSFORM)
   42: 	;
   43: 	;Kill page and block multiple indexes
   44: 	S DDSJ=" " F  S DDSJ=$O(^DIST(.403,+Y,40,DDSJ)) Q:DDSJ=""  D
   45: 	. K ^DIST(.403,+Y,40,DDSJ)
   46: 	S DDSI=0 F  S DDSI=$O(^DIST(.403,+Y,40,DDSI)) Q:'DDSI  D
   47: 	. S DDSJ=" "
   48: 	. F  S DDSJ=$O(^DIST(.403,+Y,40,DDSI,40,DDSJ)) Q:DDSJ=""  D
   49: 	.. K ^DIST(.403,+Y,40,DDSI,40,DDSJ)
   50: 	K ^DIST(.403,+Y,"AZ")
   51: 	;
   52: 	S $P(^DIST(.403,+Y,0),U)=$P(DDSFORM,U,3)
   53: 	W ?35,"#"_+Y
   54: 	S DDSNFRM=+Y
   55: 	Q
   56: 	;
   57: EDITFM	;Edit blocks used on new form
   58: 	W !!,"Repointing to new blocks ..."
   59: 	N DDSBK,DDSNBK,DDSPG
   60: 	S DDSPG=0 F  S DDSPG=$O(^DIST(.403,DDSNFRM,40,DDSPG)) Q:'DDSPG  D
   61: 	. S DDSBK=$P(^DIST(.403,DDSNFRM,40,DDSPG,0),U,2)
   62: 	. I DDSBK]"" D
   63: 	.. N DIE,DA,DR
   64: 	.. S DIE="^DIST(.403,"_DDSNFRM_",40,"
   65: 	.. S DA(1)=DDSNFRM,DA=DDSPG
   66: 	.. S DR="1////"_$P(^TMP("DDSCLONE",$J,DDSBK),U,3)
   67: 	.. D ^DIE
   68: 	. ;
   69: 	. N DA,DIK
   70: 	. S DIK="^DIST(.403,"_DDSNFRM_",40,"_DDSPG_",40,"
   71: 	. S DA(2)=DDSNFRM,DA(1)=DDSPG
   72: 	. S DDSBK=0
   73: 	. F  S DDSBK=$O(^DIST(.403,DDSNFRM,40,DDSPG,40,DDSBK)) Q:'DDSBK  D
   74: 	.. Q:$D(^TMP("DDSCLONE",$J,DDSBK))[0  S DDSNBK=$P(^(DDSBK),U,3)
   75: 	.. M ^DIST(.403,DDSNFRM,40,DDSPG,40,DDSNBK)=^DIST(.403,DDSNFRM,40,DDSPG,40,DDSBK)
   76: 	.. S $P(^DIST(.403,DDSNFRM,40,DDSPG,40,DDSNBK,0),U)=DDSNBK
   77: 	.. S DA=DDSBK
   78: 	.. D ^DIK
   79: 	Q
   80: 	;
   81: INDEXFM	;Index new form
   82: 	W !,"Reindexing new form ..."
   83: 	N DIK,DA
   84: 	S DIK="^DIST(.403,",DA=DDSNFRM
   85: 	D IX1^DIK
   86: 	;
   87: 	D EN^DDSZ(DDSNFRM)
   88: 	Q
   89: 	;
   90: ASKCONT	;Final chance to abort
   91: 	K DIR S DIR(0)="Y"
   92: 	S DIR("A",1)=""
   93: 	S DIR("A")="Ready to clone form"
   94: 	S DIR("?")="  Enter 'Y' to clone form.  Enter 'N' to exit."
   95: 	D ^DIR K DIR
   96: 	S:$D(DIRUT)!'Y DDSQUIT=1
   97: 	Q