Return to DDSCLONF.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DDSCLONF.m, revision 1.1.1.1

1.1       snw         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