Return to DDXP4.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DDXP4.m, revision 1.1

1.1     ! snw         1: DDXP4  ;SFISC/DPC-EXPORT DATA ;10/17/94  14:27
        !             2:        ;;21.0;VA FileMan;;Dec 28, 1994
        !             3:        ;Per VHA Directive 10-93-142, this routine should not be modified.
        !             4: EN1    ;
        !             5:        K ^UTILITY($J)
        !             6:        D ^DICRW I Y=-1 G QUIT
        !             7:        S DDXPFINO=+Y
        !             8: XTEM   ;
        !             9:        S DIC="^DIPT(",DIC(0)="QEASZ",DIC("A")="Choose an EXPORT template: ",DIC("S")="I $P(^(0),U,8)=3",D="F"_DDXPFINO W !
        !            10:        D IX^DIC K DIC,D I $D(DTOUT)!$D(DUOUT) G QUIT
        !            11:        I Y=-1 G XTEM
        !            12:        S DDXPXTNO=+Y,DDXPXTNM=$P(Y,U,2),FLDS="["_DDXPXTNM_"]"
        !            13:        W !,"Do you want to delete the "_DDXPXTNM_" template",!,"after the data export is complete?",!
        !            14:        S DDXPTMDL=0,DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR W !
        !            15:        I $D(DIRUT) G QUIT
        !            16:        S:Y DDXPTMDL=1
        !            17:        S DDXPFFNO=+$G(^DIPT(DDXPXTNO,105)),DDXPFMZO=$G(^DIST(.44,DDXPFFNO,0))
        !            18:        I $G(^DIST(.44,DDXPFFNO,6))]"" S DDXPDATE=1
        !            19:        S DDXPATH=$P($G(^DIPT(DDXPXTNO,105)),U,4) I DDXPATH]"" D MULTBY
        !            20: SORS   ;
        !            21:        W ! S DIR(0)="YA",DIR("B")="NO",DIR("A")="Do you want to SEARCH for entries to be exported? "
        !            22:        S DIR("?",1)="To use VA FileMan's SEARCH option to choose entries, answer 'YES'."
        !            23:        S:'$D(BY) DIR("?",2)="After the SEARCH, you can respond to VA FileMan's 'SORT BY:' prompt."
        !            24:        S DIR("?")="If you answer 'NO', "_$S('$D(BY):"you can only SORT entries before export.",1:"the data export will begin.")
        !            25:        D ^DIR K DIR I $D(DIRUT) G QUIT
        !            26:        S DDXPSORS=Y,DIC=DDXPFINO,L=0
        !            27:        D DIOBEG,DIOEND
        !            28:        I DDXPSORS D EN^DIS
        !            29:        I 'DDXPSORS D EN1^DIP
        !            30:        I $G(X)="^"!($G(POP)) G QUIT
        !            31:        I $G(DDXPQ) W !,?5,"Export template "_DDXPXTNM_" will be deleted",!,?5,"when queued export is completed." G DONE
        !            32:        I $G(DDXPTMDL) S DIK="^DIPT(",DA=DDXPXTNO D ^DIK K DIK,DA
        !            33:        G DONE
        !            34: QUIT   ;
        !            35:        W !!,?10,"Export NOT completed!"
        !            36: DONE   ;
        !            37:        K DDXPFINO,DDXPSORS,DDXPIOM,DDXPIOSL,DDXPXTNO,DDXPXTNM,DDXPFFNO,DDXPFMZO,DDXPCUSR,DDXPDATE,DDXPTMDL,DDXPY,DDXPATH,L,Y,DTOUT,DUOUT,DIRUT,DIC,FLDS,BY,FR,DIOEND,DIOBEG,DDXPQ,X,POP
        !            38:        Q
        !            39: ZIS    ;
        !            40:        S %ZIS="Q"
        !            41:        S DDXPIOM=$S($P(DDXPFMZO,U,8):$P(DDXPFMZO,U,8),$G(^DIPT(DDXPXTNO,"IOM")):^("IOM"),1:80)
        !            42:        S DDXPIOSL=99999
        !            43:        Q
        !            44: MULTBY ;
        !            45:        N NUMPC,I,C S BY="",C=",",NUMPC=$L(DDXPATH,C)
        !            46:        W !!,"Since you are exporting fields from multiples,"
        !            47:        W !,"a sort will be done automatically."
        !            48:        W !,"You will not have the opportunity to sort the data before export.",!
        !            49:        F I=1:1:NUMPC D
        !            50:        . S BY=BY_DDXPATH_",NUMBER,"
        !            51:        . S DDXPATH=$P(DDXPATH,C,1,$L(DDXPATH,C)-1)
        !            52:        . Q
        !            53:        S BY=$E(BY,1,$L(BY)-1),FR=""
        !            54:        Q
        !            55: DIOBEG ;
        !            56:        S DDXPBEG=$G(^DIST(.44,DDXPFFNO,1))
        !            57:        I DDXPBEG']"" G QBEG
        !            58:        I $E(DDXPBEG)="""" S DIOBEG="W "_DDXPBEG G QBEG
        !            59:        S DIOBEG=DDXPBEG
        !            60: QBEG   K DDXPBEG
        !            61:        Q
        !            62: DIOEND ;
        !            63:        S DDXPEND=$G(^DIST(.44,DDXPFFNO,2))
        !            64:        I DDXPEND']"" G QEND
        !            65:        I $E(DDXPEND)="""" S DIOEND="W "_DDXPEND G QEND
        !            66:        S DIOEND=DDXPEND
        !            67: QEND   K DDXPEND
        !            68:        Q
        !            69: DJTOPY(Y)      ;
        !            70:        N BJ,EJ,YOUT,NUMW,TYPEJ,DDXPXORY,SUB S YOUT=Y
        !            71:        S BJ=$F(Y,"$J(") I BJ D
        !            72:        . S DDXPXORY=$P($E(Y,BJ,999),",",1)
        !            73:        . S NUMW=$L($E(Y,1,BJ),"W")-1 I NUMW'>0 Q
        !            74:        . S EJ=$F(Y,") ",BJ)
        !            75:        . S TYPEJ=$L($E(Y,BJ,$S(EJ:EJ-1,1:999)),",")
        !            76:        . I TYPEJ'=2&(TYPEJ'=3) Q
        !            77:        . I TYPEJ=3 S SUB="$S("_DDXPXORY_"]"""":+"_DDXPXORY_",1:"""_$P(DDXPFMZO,U,13)_""")"
        !            78:        . I TYPEJ=2 S SUB=DDXPXORY
        !            79:        . S YOUT=$P($E(Y,1,BJ),"W",1,NUMW)_"W "_SUB_$S(EJ:$E(Y,EJ-1,999),1:"")
        !            80:        . Q
        !            81:        Q YOUT
        !            82: DT     ;
        !            83:        N X
        !            84:        I 'Y S DDXPY=Y Q
        !            85:        S X=Y
        !            86:        I $D(^DIST(.44,DDXPFFNO,6)) X ^(6) S DDXPY=$G(Y)
        !            87:        Q