Return to DDXP4.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

    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