DDXP4 ;SFISC/DPC,S0-EXPORT DATA ;7:37 AM 30 May 2000
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
EN1 ;
K ^UTILITY($J)
D ^DICRW I Y=-1 G QUIT
S DDXPFINO=+Y
XTEM ;
S DIC="^DIPT(",DIC(0)="QEASZ",DIC("A")="Choose an EXPORT template or '^' to Quit: ",DIC("S")="I $P(^(0),U,8)=3",D="F"_DDXPFINO W !
D IX^DIC K DIC,D I $D(DTOUT)!$D(DUOUT) G QUIT
I Y=-1 G XTEM
S DDXPXTNO=+Y,DDXPXTNM=$P(Y,U,2),FLDS="["_DDXPXTNM_"]"
I DUZ(0)[$E($P(Y(0),U,6),1)!(DUZ(0)="@") D I $D(DIRUT) G QUIT
. W !,"Do you want to delete the "_DDXPXTNM_" template",!,"after the data export is complete?",!
. S DDXPTMDL=0,DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR W !
. S:Y DDXPTMDL=1
S DDXPFFNO=+$G(^DIPT(DDXPXTNO,105)),DDXPFMZO=$G(^DIST(.44,DDXPFFNO,0))
I $G(^DIST(.44,DDXPFFNO,6))]"" S DDXPDATE=1
S DDXPATH=$P($G(^DIPT(DDXPXTNO,105)),U,4) I DDXPATH]"" D MULTBY
SORS ;
W ! S DIR(0)="YA",DIR("B")="NO",DIR("A")="Do you want to SEARCH for entries to be exported? "
S DIR("?",1)="To use VA FileMan's SEARCH option to choose entries, answer 'YES'."
S:'$D(BY) DIR("?",2)="After the SEARCH, you can respond to VA FileMan's 'SORT BY:' prompt."
S DIR("?")="If you answer 'NO', "_$S('$D(BY):"you can only SORT entries before export.",1:"the data export will begin.")
D ^DIR K DIR I $D(DIRUT) G QUIT
S DDXPSORS=Y,DIC=DDXPFINO,L=0
D DIOBEG,DIOEND
I DDXPSORS D EN^DIS
I $G(X)="^"!($G(POP)) G QUIT
I 'DDXPSORS D EN1^DIP
I $G(X)="^"!($G(POP)) G QUIT
I $G(DDXPQ),$G(DDXPTMDL) W !,?5,"Export template "_DDXPXTNM_" will be deleted",!,?5,"when queued export is completed." G DONE
I $G(DDXPTMDL) S DIK="^DIPT(",DA=DDXPXTNO D ^DIK K DIK,DA
G DONE
QUIT ;
W !!,?10,"Export NOT completed!"
DONE ;
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
Q
ZIS ;
S %ZIS="Q"
S DDXPIOM=$S($P(DDXPFMZO,U,8):$P(DDXPFMZO,U,8),$G(^DIPT(DDXPXTNO,"IOM")):^("IOM"),1:80)
S DDXPIOSL=99999
Q
MULTBY ;
N NUMPC,I,C S BY="",C=",",NUMPC=$L(DDXPATH,C)
W !!,"Since you are exporting fields from multiples,"
W !,"a sort will be done automatically."
W !,"You will NOT have the opportunity to sort the data before export.",!
F I=1:1:NUMPC D
. S BY=BY_DDXPATH_",NUMBER,"
. S DDXPATH=$P(DDXPATH,C,1,$L(DDXPATH,C)-1)
. Q
S BY=$E(BY,1,$L(BY)-1),FR=""
Q
DIOBEG ;
S DDXPBEG=$G(^DIST(.44,DDXPFFNO,1))
I DDXPBEG']"" G QBEG
I $E(DDXPBEG)="""" S DIOBEG="W "_DDXPBEG G QBEG
S DIOBEG=DDXPBEG
QBEG K DDXPBEG
Q
DIOEND ;
S DDXPEND=$G(^DIST(.44,DDXPFFNO,2))
I DDXPEND']"" G QEND
I $E(DDXPEND)="""" S DIOEND="W "_DDXPEND G QEND
S DIOEND=DDXPEND
QEND K DDXPEND
Q
DJTOPY(Y) ;
N BJ,EJ,YOUT,NUMW,TYPEJ,DDXPXORY,SUB S YOUT=Y
S BJ=$F(Y,"$J(") I BJ D
. S DDXPXORY=$P($E(Y,BJ,999),",",1)
. S NUMW=$L($E(Y,1,BJ),"W")-1 I NUMW'>0 Q
. S EJ=$F(Y,") ",BJ)
. S TYPEJ=$L($E(Y,BJ,$S(EJ:EJ-1,1:999)),",")
. I TYPEJ'=2&(TYPEJ'=3) Q
. I TYPEJ=3 S SUB="$S("_DDXPXORY_"]"""":+"_DDXPXORY_",1:"""_$P(DDXPFMZO,U,13)_""")"
. I TYPEJ=2 S SUB=DDXPXORY
. S YOUT=$P($E(Y,1,BJ),"W",1,NUMW)_"W "_SUB_$S(EJ:$E(Y,EJ-1,999),1:"")
. Q
Q YOUT
DT ;
N X
I 'Y S DDXPY=Y Q
S X=Y
I $D(^DIST(.44,DDXPFFNO,6)) X ^(6) S DDXPY=$G(Y)
Q
EN2 ; Export API from EXPORT^DDXP
N DDXP,DDXPXTNO,DDPXFFNO,DDXPFMZO,DDXPDATE,DDXPATH,DDXPOUT,ERROR,DIA
K ^UTILITY($J)
; Check for valild file number
I '$G(DDXPFINO) S ERROR="File Number Missing." D EN2ERR G DONE
I DDXPFINO[U D I $D(DDXPOUT) K DDXPOUT G DONE
. I $P(DDXPFINO,U)'=1.1 S DDXPOUT=1,ERROR="You can only use the "","" syntax if doing an Export of the Audit File(1.1)" D EN2ERR Q
. I '$D(^DIC(+$P(DDXPFINO,U,2),0))#2 S DDXPOUT=1,ERROR="File Does Not Exist on This System." D EN2ERR Q
I DDXPFINO'[U,'$D(^DIC(+DDXPFINO,0))#2 S ERROR="File Does Not Exist on This System." D EN2ERR G DONE
N DIC,D,X
S DIC="^DIPT(",DIC(0)="SZ",DIC("S")="I $P(^(0),U,8)=3",D="F"_+DDXPFINO,X=DDXPXTNM
D IX^DIC K DIC
I Y<0 S ERROR="The Template is Not an Export Template or Is Missing." D EN2ERR G DONE
S DDXPXTNO=+Y
S DDXPFFNO=+$G(^DIPT(DDXPXTNO,105)),DDXPFMZO=$G(^DIST(.44,DDXPFFNO,0))
I $G(^DIST(.44,DDXPFFNO,6))]"" S DDXPDATE=1
I $G(DDXPBY)="" S DDXPATH=$P($G(^DIPT(DDXPXTNO,105)),U,4) I DDXPATH]"" D MULTBY
; Setup For Sort Template If BY NOT Setup by MULTBY
I '$D(BY) D I $D(DDXPOUT) K DDXPOUT S ERROR="Sort Template Invalid or Missing." D EN2ERR G DONE
. I $G(DDXPBY)]"" D Q:$D(DDXPOUT)
.. N DIC,X
.. S DIC="^DIBT(",DIC(0)="Z",X=DDXPBY
.. D ^DIC K DIC
.. I Y<0 S DDXPOUT=1 Q
.. D SORTCHK I $D(DDXPOUT) Q
.. S BY="["_DDXPBY_"]"
S DDXP=4 ; Tell other FileMan routines we are Exporting
S DIC=$S(+DDXPFINO=1.1:"^DIA("_+$P(DDXPFINO,U,2)_",",1:+DDXPFINO)
S L=0
S FLDS="["_DDXPXTNM_"]"
D DIOBEG,DIOEND,EN1^DIP
I $G(X)="^"!($G(POP)) K DDXP,DDXPBY,DDXPFR,DDXPTO G QUIT
K:$D(DIA) DIA ; **Leaking Variable**
I $G(DDXPTMDL) S DIK="^DIPT(",DA=DDXPXTNO D ^DIK K DIK,DA
K DDXP,DDXPBY,DDXPFR,DDXPTO
G DONE
SORTCHK ; Check Sort For Illegal Qualifiers
N D0,D1,DDXPX,I
S D0=+Y
S D1=0
F S D1=$O(^DIBT(D0,2,D1)) Q:D1<1!$D(DDXPOUT) D
. S DDXPX=^DIBT(D0,2,D1,0)
. F I="#","!","+","@" D Q:$D(DDXPOUT)
.. I $P(DDXPX,U,4)[I,I'="@" S DDXPOUT=1,ERROR="You can not use the """_I_""" when exporting." D EN2ERR Q
.. I I="@",$P(DDXPX,U,4)["@",$P(DDXPX,U,4)'["@B" S DDXPOUT=1,ERROR="You can not use the ""@"" when exporting." D EN2ERR Q
. F I=";C",";S" D Q:$D(DDXPOUT)
.. I $P(DDXPX,U,5)[I S DDXPOUT=1,ERROR="You can not use "_I_" when exporting." D EN2ERR Q
.. I $P(DDXPX,U,5)[";""" S DDXPOUT=1,ERROR="You can Replace a Caption when exporting." D EN2ERR Q
Q
EN2ERR ; Error Processing
I $D(IOST),$E(IOST,1,2)="C-" W $C(7)
W "=>"_ERROR,!
K DDXPBY,DDXPFR,DDXPTO,ERROR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDXP4 6071 printed Apr 09, 2024@21:48:51 Page 2
DDXP4 ;SFISC/DPC,S0-EXPORT DATA ;7:37 AM 30 May 2000
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
EN1 ;
+1 KILL ^UTILITY($JOB)
+2 DO ^DICRW
IF Y=-1
GOTO QUIT
+3 SET DDXPFINO=+Y
XTEM ;
+1 SET DIC="^DIPT("
SET DIC(0)="QEASZ"
SET DIC("A")="Choose an EXPORT template or '^' to Quit: "
SET DIC("S")="I $P(^(0),U,8)=3"
SET D="F"_DDXPFINO
WRITE !
+2 DO IX^DIC
KILL DIC,D
IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO QUIT
+3 IF Y=-1
GOTO XTEM
+4 SET DDXPXTNO=+Y
SET DDXPXTNM=$PIECE(Y,U,2)
SET FLDS="["_DDXPXTNM_"]"
+5 IF DUZ(0)[$EXTRACT($PIECE(Y(0),U,6),1)!(DUZ(0)="@")
Begin DoDot:1
+6 WRITE !,"Do you want to delete the "_DDXPXTNM_" template",!,"after the data export is complete?",!
+7 SET DDXPTMDL=0
SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
WRITE !
+8 if Y
SET DDXPTMDL=1
End DoDot:1
IF $DATA(DIRUT)
GOTO QUIT
+9 SET DDXPFFNO=+$GET(^DIPT(DDXPXTNO,105))
SET DDXPFMZO=$GET(^DIST(.44,DDXPFFNO,0))
+10 IF $GET(^DIST(.44,DDXPFFNO,6))]""
SET DDXPDATE=1
+11 SET DDXPATH=$PIECE($GET(^DIPT(DDXPXTNO,105)),U,4)
IF DDXPATH]""
DO MULTBY
SORS ;
+1 WRITE !
SET DIR(0)="YA"
SET DIR("B")="NO"
SET DIR("A")="Do you want to SEARCH for entries to be exported? "
+2 SET DIR("?",1)="To use VA FileMan's SEARCH option to choose entries, answer 'YES'."
+3 if '$DATA(BY)
SET DIR("?",2)="After the SEARCH, you can respond to VA FileMan's 'SORT BY:' prompt."
+4 SET DIR("?")="If you answer 'NO', "_$SELECT('$DATA(BY):"you can only SORT entries before export.",1:"the data export will begin.")
+5 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO QUIT
+6 SET DDXPSORS=Y
SET DIC=DDXPFINO
SET L=0
+7 DO DIOBEG
DO DIOEND
+8 IF DDXPSORS
DO EN^DIS
+9 IF $GET(X)="^"!($GET(POP))
GOTO QUIT
+10 IF 'DDXPSORS
DO EN1^DIP
+11 IF $GET(X)="^"!($GET(POP))
GOTO QUIT
+12 IF $GET(DDXPQ)
IF $GET(DDXPTMDL)
WRITE !,?5,"Export template "_DDXPXTNM_" will be deleted",!,?5,"when queued export is completed."
GOTO DONE
+13 IF $GET(DDXPTMDL)
SET DIK="^DIPT("
SET DA=DDXPXTNO
DO ^DIK
KILL DIK,DA
+14 GOTO DONE
QUIT ;
+1 WRITE !!,?10,"Export NOT completed!"
DONE ;
+1 KILL 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
+2 QUIT
ZIS ;
+1 SET %ZIS="Q"
+2 SET DDXPIOM=$SELECT($PIECE(DDXPFMZO,U,8):$PIECE(DDXPFMZO,U,8),$GET(^DIPT(DDXPXTNO,"IOM")):^("IOM"),1:80)
+3 SET DDXPIOSL=99999
+4 QUIT
MULTBY ;
+1 NEW NUMPC,I,C
SET BY=""
SET C=","
SET NUMPC=$LENGTH(DDXPATH,C)
+2 WRITE !!,"Since you are exporting fields from multiples,"
+3 WRITE !,"a sort will be done automatically."
+4 WRITE !,"You will NOT have the opportunity to sort the data before export.",!
+5 FOR I=1:1:NUMPC
Begin DoDot:1
+6 SET BY=BY_DDXPATH_",NUMBER,"
+7 SET DDXPATH=$PIECE(DDXPATH,C,1,$LENGTH(DDXPATH,C)-1)
+8 QUIT
End DoDot:1
+9 SET BY=$EXTRACT(BY,1,$LENGTH(BY)-1)
SET FR=""
+10 QUIT
DIOBEG ;
+1 SET DDXPBEG=$GET(^DIST(.44,DDXPFFNO,1))
+2 IF DDXPBEG']""
GOTO QBEG
+3 IF $EXTRACT(DDXPBEG)=""""
SET DIOBEG="W "_DDXPBEG
GOTO QBEG
+4 SET DIOBEG=DDXPBEG
QBEG KILL DDXPBEG
+1 QUIT
DIOEND ;
+1 SET DDXPEND=$GET(^DIST(.44,DDXPFFNO,2))
+2 IF DDXPEND']""
GOTO QEND
+3 IF $EXTRACT(DDXPEND)=""""
SET DIOEND="W "_DDXPEND
GOTO QEND
+4 SET DIOEND=DDXPEND
QEND KILL DDXPEND
+1 QUIT
DJTOPY(Y) ;
+1 NEW BJ,EJ,YOUT,NUMW,TYPEJ,DDXPXORY,SUB
SET YOUT=Y
+2 SET BJ=$FIND(Y,"$J(")
IF BJ
Begin DoDot:1
+3 SET DDXPXORY=$PIECE($EXTRACT(Y,BJ,999),",",1)
+4 SET NUMW=$LENGTH($EXTRACT(Y,1,BJ),"W")-1
IF NUMW'>0
QUIT
+5 SET EJ=$FIND(Y,") ",BJ)
+6 SET TYPEJ=$LENGTH($EXTRACT(Y,BJ,$SELECT(EJ:EJ-1,1:999)),",")
+7 IF TYPEJ'=2&(TYPEJ'=3)
QUIT
+8 IF TYPEJ=3
SET SUB="$S("_DDXPXORY_"]"""":+"_DDXPXORY_",1:"""_$PIECE(DDXPFMZO,U,13)_""")"
+9 IF TYPEJ=2
SET SUB=DDXPXORY
+10 SET YOUT=$PIECE($EXTRACT(Y,1,BJ),"W",1,NUMW)_"W "_SUB_$SELECT(EJ:$EXTRACT(Y,EJ-1,999),1:"")
+11 QUIT
End DoDot:1
+12 QUIT YOUT
DT ;
+1 NEW X
+2 IF 'Y
SET DDXPY=Y
QUIT
+3 SET X=Y
+4 IF $DATA(^DIST(.44,DDXPFFNO,6))
XECUTE ^(6)
SET DDXPY=$GET(Y)
+5 QUIT
EN2 ; Export API from EXPORT^DDXP
+1 NEW DDXP,DDXPXTNO,DDPXFFNO,DDXPFMZO,DDXPDATE,DDXPATH,DDXPOUT,ERROR,DIA
+2 KILL ^UTILITY($JOB)
+3 ; Check for valild file number
+4 IF '$GET(DDXPFINO)
SET ERROR="File Number Missing."
DO EN2ERR
GOTO DONE
+5 IF DDXPFINO[U
Begin DoDot:1
+6 IF $PIECE(DDXPFINO,U)'=1.1
SET DDXPOUT=1
SET ERROR="You can only use the "","" syntax if doing an Export of the Audit File(1.1)"
DO EN2ERR
QUIT
+7 IF '$DATA(^DIC(+$PIECE(DDXPFINO,U,2),0))#2
SET DDXPOUT=1
SET ERROR="File Does Not Exist on This System."
DO EN2ERR
QUIT
End DoDot:1
IF $DATA(DDXPOUT)
KILL DDXPOUT
GOTO DONE
+8 IF DDXPFINO'[U
IF '$DATA(^DIC(+DDXPFINO,0))#2
SET ERROR="File Does Not Exist on This System."
DO EN2ERR
GOTO DONE
+9 NEW DIC,D,X
+10 SET DIC="^DIPT("
SET DIC(0)="SZ"
SET DIC("S")="I $P(^(0),U,8)=3"
SET D="F"_+DDXPFINO
SET X=DDXPXTNM
+11 DO IX^DIC
KILL DIC
+12 IF Y<0
SET ERROR="The Template is Not an Export Template or Is Missing."
DO EN2ERR
GOTO DONE
+13 SET DDXPXTNO=+Y
+14 SET DDXPFFNO=+$GET(^DIPT(DDXPXTNO,105))
SET DDXPFMZO=$GET(^DIST(.44,DDXPFFNO,0))
+15 IF $GET(^DIST(.44,DDXPFFNO,6))]""
SET DDXPDATE=1
+16 IF $GET(DDXPBY)=""
SET DDXPATH=$PIECE($GET(^DIPT(DDXPXTNO,105)),U,4)
IF DDXPATH]""
DO MULTBY
+17 ; Setup For Sort Template If BY NOT Setup by MULTBY
+18 IF '$DATA(BY)
Begin DoDot:1
+19 IF $GET(DDXPBY)]""
Begin DoDot:2
+20 NEW DIC,X
+21 SET DIC="^DIBT("
SET DIC(0)="Z"
SET X=DDXPBY
+22 DO ^DIC
KILL DIC
+23 IF Y<0
SET DDXPOUT=1
QUIT
+24 DO SORTCHK
IF $DATA(DDXPOUT)
QUIT
+25 SET BY="["_DDXPBY_"]"
End DoDot:2
if $DATA(DDXPOUT)
QUIT
End DoDot:1
IF $DATA(DDXPOUT)
KILL DDXPOUT
SET ERROR="Sort Template Invalid or Missing."
DO EN2ERR
GOTO DONE
+26 ; Tell other FileMan routines we are Exporting
SET DDXP=4
+27 SET DIC=$SELECT(+DDXPFINO=1.1:"^DIA("_+$PIECE(DDXPFINO,U,2)_",",1:+DDXPFINO)
+28 SET L=0
+29 SET FLDS="["_DDXPXTNM_"]"
+30 DO DIOBEG
DO DIOEND
DO EN1^DIP
+31 IF $GET(X)="^"!($GET(POP))
KILL DDXP,DDXPBY,DDXPFR,DDXPTO
GOTO QUIT
+32 ; **Leaking Variable**
if $DATA(DIA)
KILL DIA
+33 IF $GET(DDXPTMDL)
SET DIK="^DIPT("
SET DA=DDXPXTNO
DO ^DIK
KILL DIK,DA
+34 KILL DDXP,DDXPBY,DDXPFR,DDXPTO
+35 GOTO DONE
SORTCHK ; Check Sort For Illegal Qualifiers
+1 NEW D0,D1,DDXPX,I
+2 SET D0=+Y
+3 SET D1=0
+4 FOR
SET D1=$ORDER(^DIBT(D0,2,D1))
if D1<1!$DATA(DDXPOUT)
QUIT
Begin DoDot:1
+5 SET DDXPX=^DIBT(D0,2,D1,0)
+6 FOR I="#","!","+","@"
Begin DoDot:2
+7 IF $PIECE(DDXPX,U,4)[I
IF I'="@"
SET DDXPOUT=1
SET ERROR="You can not use the """_I_""" when exporting."
DO EN2ERR
QUIT
+8 IF I="@"
IF $PIECE(DDXPX,U,4)["@"
IF $PIECE(DDXPX,U,4)'["@B"
SET DDXPOUT=1
SET ERROR="You can not use the ""@"" when exporting."
DO EN2ERR
QUIT
End DoDot:2
if $DATA(DDXPOUT)
QUIT
+9 FOR I=";C",";S"
Begin DoDot:2
+10 IF $PIECE(DDXPX,U,5)[I
SET DDXPOUT=1
SET ERROR="You can not use "_I_" when exporting."
DO EN2ERR
QUIT
+11 IF $PIECE(DDXPX,U,5)[";"""
SET DDXPOUT=1
SET ERROR="You can Replace a Caption when exporting."
DO EN2ERR
QUIT
End DoDot:2
if $DATA(DDXPOUT)
QUIT
End DoDot:1
+12 QUIT
EN2ERR ; Error Processing
+1 IF $DATA(IOST)
IF $EXTRACT(IOST,1,2)="C-"
WRITE $CHAR(7)
+2 WRITE "=>"_ERROR,!
+3 KILL DDXPBY,DDXPFR,DDXPTO,ERROR
+4 QUIT
