Return to DDSCLONF.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DDSCLONF.m, revision 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