DDXP3 ;SFISC/DPC-CREATE EXPORT TEMPLATE ;10/14/94 14:56
;;22.0;VA FileMan;;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
EN1 ;
N DDXPNOUT
N T,Q S T="~",Q="""" K ^TMP($J,"DIP")
N Y,D,DICS D ^DICRW I Y=-1 G QUIT
S DDXPFINO=+Y
FLDT ;
D FLDTEMP^DDXP33 G:DDXPOUT QUIT
FRMT ;
S DIC="^DIST(.44,",DIC(0)="QEAMZ" D ^DIC K DIC
G:Y=-1 QUIT
S DDXPFMNO=+Y,DDXPFMZO=Y(0)
XPTEMP ;
D XPT^DDXP31 G:DDXPOUT QUIT
D FLOAD,CAPDT^DDXP32 G:DDXPOUT QUIT
I $P(DDXPFMZO,U,6) D LENGTH^DDXP31 G:DDXPOUT QUIT
I $P(DDXPFMZO,U,7) D FLDNAME^DDXP31 G:DDXPOUT QUIT
I $P(DDXPFMZO,U,11) D DTYPE^DDXP31 G:DDXPOUT QUIT
D SETFLD^DDXP32
I '$P(DDXPFMZO,U,8) D IOM^DDXP31 G:DDXPOUT QUIT S ^DIPT(DDXPXTNO,"IOM")=$G(DDXPIOM)
D SETEMP^DDXP32
SETDELM ;
I $TR($P(DDXPFMZO,U,2),"ask","ASK")="ASK" D ASKDELM^DDXP31 G:DDXPOUT QUIT
S:'$D(DDXPDELM) DDXPDELM=$P(DDXPFMZO,U,2)
I DDXPDELM]"" S DDXPDELM=$$BLDELIM(DDXPDELM)
TPROC ;
S DDXPFONO=1,DDXPFOUT="",DDXPXPOS=1
F DDXPFLD=1:1:DDXPTOTF D
. S (DDXPNPC,DDXPRNPC)=^TMP($J,"TIN",DDXPFLD)
. I $P(DDXPFMZO,U,10),'DDXPNOUT(DDXPFLD) D QUOT^DDXP32
. I $P(DDXPFMZO,U,6) D FIXLEN
. I '$P(DDXPFMZO,U,6),((DDXPFLD'=1)!(DDXPNPC'=DDXPRNPC)) D RUNON
. I $P(DDXPFMZO,U,10),'DDXPNOUT(DDXPFLD) D QUOT^DDXP32
. I DDXPDELM]"",'DDXPNOUT(DDXPFLD) D DELIM
. D FPROC
. Q
RECPROC ;
I '$P(DDXPFMZO,U,12),DDXPDELM]"" S DDXPFOUT=$P(DDXPFOUT,T,1,($L(DDXPFOUT,T)-2))_T
I $TR($P(DDXPFMZO,U,3),"ask","ASK")="ASK" D ASKRDLM^DDXP31 G:DDXPOUT QUIT
S:'$D(DDXPRDLM) DDXPRDLM=$P(DDXPFMZO,U,3)
I DDXPRDLM]"" S DDXPRDLM=$$BLDELIM(DDXPRDLM) D RECDELIM D FPROC
FINISH ;
I DDXPFOUT]"" S ^DIPT(DDXPXTNO,"F",DDXPFONO)=DDXPFOUT
S DIE="^DIST(.44,",DA=DDXPFMNO,DR="40///1" D ^DIE
S DIE="^DIPT(",DA=DDXPFDTM,DR="110///1" D ^DIE K DIE,DA,DR
W !!,?10,"Export Template created.",!
I $G(DDXPTMDL) D
. S DIK="^DIPT(",DA=DDXPFDTM D ^DIK K DIK,DA
. W ?10,"Selected Fields template "_DDXPFDNM_" deleted.",!
. Q
G DONE
QUIT ;
W !!,?10,"Export Template NOT created!!"
I $G(DDXPTMDL) W !,?10,"Selected Fields template "_DDXPFDNM_" not deleted."
I $D(DDXPXTNO) S DIK="^DIPT(",DA=DDXPXTNO D ^DIK K DIK,DA
DONE ;
K X,Y,DDXPDELM,DDXPDT,DDXPFDTM,DDXPFCAP,DDXPFFNM,DDXPFIN,DDXPFINO,DDXPFLD,DDXPIOM,DDXPFLEN,DDXPFMNO,DDXPFMZO,DDXPFONO,DDXPTLEN,DDXPTMDL
K DDXPFDNM,DDXPFOUT,DDXPLNMX,DDXPRNPC,DDXPNPC,DDXPOUT,DDXPTIN,DDXPATH,DDXPTOTF,DDXPXPOS,DDXPXTNM,DDXPXTNO,DDXPRDLM,Q,T,DTOUT,DUOUT,DIRUT
K ^TMP($J,"DIP")
Q
FLOAD ;
S DDXPFLD=0
F FIN=0:0 S FIN=$O(^DIPT(DDXPFDTM,"F",FIN)) Q:FIN="" S DDXPFIN=^(FIN) D
. F TCNT=1:1 S DDXPTIN=$P(DDXPFIN,T,TCNT) Q:DDXPTIN="" D
. . S DDXPFLD=DDXPFLD+1
. . S ^TMP($J,"TIN",DDXPFLD)=DDXPTIN
. . S DDXPNOUT(DDXPFLD)=$$NOUT(DDXPTIN)
. . Q
. Q
S DDXPTOTF=DDXPFLD
K FIN,TCNT Q
FIXLEN ;
S DDXPLNMX=$S(+$P(DDXPFMZO,U,8):$P(DDXPFMZO,U,8),$G(DDXPIOM):DDXPIOM,1:80)
I DDXPXPOS+DDXPFLEN(DDXPFLD)>(DDXPLNMX+1) S DDXPXPOS=1
S DDXPNPC=DDXPNPC_";L"_DDXPFLEN(DDXPFLD)_";C"_DDXPXPOS
S DDXPXPOS=DDXPXPOS+DDXPFLEN(DDXPFLD)
Q
RUNON ;
S DDXPNPC=DDXPNPC_";X"
Q
DELIM ;
S DDXPNPC=DDXPNPC_T_"W $C("_DDXPDELM_")"
I '$P(DDXPFMZO,U,6) D RUNON
Q
RECDELIM ;
S DDXPNPC="W $C("_DDXPRDLM_")"
I '$P(DDXPFMZO,U,6) D RUNON
Q
BLDELIM(%) ;
N CHAR,DELM
I +% S DELM=% G BLDOUT
S DELM=$A(%)
F CHAR=2:1 Q:$E(%,CHAR)="" S DELM=DELM_","_$A($E(%,CHAR))
BLDOUT Q DELM
FPROC ;
I $L(DDXPFOUT)+$L(DDXPNPC)<220 S DDXPFOUT=DDXPFOUT_DDXPNPC_T Q
S ^DIPT(DDXPXTNO,"F",DDXPFONO)=DDXPFOUT
S DDXPFOUT=DDXPNPC_T,DDXPFONO=DDXPFONO+1
Q
;
NOUT(DDXPTIN) ;
I DDXPTIN["SETDATA"!(DDXPTIN["SETPARAM") Q 1
Q 0
DDXP3 ;SFISC/DPC-CREATE EXPORT TEMPLATE ;10/14/94 14:56
+1 ;;22.0;VA FileMan;;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN1 ;
+1 NEW DDXPNOUT
+2 NEW T,Q
SET T="~"
SET Q=""""
KILL ^TMP($JOB,"DIP")
+3 NEW Y,D,DICS
DO ^DICRW
IF Y=-1
GOTO QUIT
+4 SET DDXPFINO=+Y
FLDT ;
+1 DO FLDTEMP^DDXP33
IF DDXPOUT
GOTO QUIT
FRMT ;
+1 SET DIC="^DIST(.44,"
SET DIC(0)="QEAMZ"
DO ^DIC
KILL DIC
+2 IF Y=-1
GOTO QUIT
+3 SET DDXPFMNO=+Y
SET DDXPFMZO=Y(0)
XPTEMP ;
+1 DO XPT^DDXP31
IF DDXPOUT
GOTO QUIT
+2 DO FLOAD
DO CAPDT^DDXP32
IF DDXPOUT
GOTO QUIT
+3 IF $PIECE(DDXPFMZO,U,6)
DO LENGTH^DDXP31
IF DDXPOUT
GOTO QUIT
+4 IF $PIECE(DDXPFMZO,U,7)
DO FLDNAME^DDXP31
IF DDXPOUT
GOTO QUIT
+5 IF $PIECE(DDXPFMZO,U,11)
DO DTYPE^DDXP31
IF DDXPOUT
GOTO QUIT
+6 DO SETFLD^DDXP32
+7 IF '$PIECE(DDXPFMZO,U,8)
DO IOM^DDXP31
IF DDXPOUT
GOTO QUIT
SET ^DIPT(DDXPXTNO,"IOM")=$GET(DDXPIOM)
+8 DO SETEMP^DDXP32
SETDELM ;
+1 IF $TRANSLATE($PIECE(DDXPFMZO,U,2),"ask","ASK")="ASK"
DO ASKDELM^DDXP31
IF DDXPOUT
GOTO QUIT
+2 IF '$DATA(DDXPDELM)
SET DDXPDELM=$PIECE(DDXPFMZO,U,2)
+3 IF DDXPDELM]""
SET DDXPDELM=$$BLDELIM(DDXPDELM)
TPROC ;
+1 SET DDXPFONO=1
SET DDXPFOUT=""
SET DDXPXPOS=1
+2 FOR DDXPFLD=1:1:DDXPTOTF
Begin DoDot:1
+3 SET (DDXPNPC,DDXPRNPC)=^TMP($JOB,"TIN",DDXPFLD)
+4 IF $PIECE(DDXPFMZO,U,10)
IF 'DDXPNOUT(DDXPFLD)
DO QUOT^DDXP32
+5 IF $PIECE(DDXPFMZO,U,6)
DO FIXLEN
+6 IF '$PIECE(DDXPFMZO,U,6)
IF ((DDXPFLD'=1)!(DDXPNPC'=DDXPRNPC))
DO RUNON
+7 IF $PIECE(DDXPFMZO,U,10)
IF 'DDXPNOUT(DDXPFLD)
DO QUOT^DDXP32
+8 IF DDXPDELM]""
IF 'DDXPNOUT(DDXPFLD)
DO DELIM
+9 DO FPROC
+10 QUIT
End DoDot:1
RECPROC ;
+1 IF '$PIECE(DDXPFMZO,U,12)
IF DDXPDELM]""
SET DDXPFOUT=$PIECE(DDXPFOUT,T,1,($LENGTH(DDXPFOUT,T)-2))_T
+2 IF $TRANSLATE($PIECE(DDXPFMZO,U,3),"ask","ASK")="ASK"
DO ASKRDLM^DDXP31
IF DDXPOUT
GOTO QUIT
+3 IF '$DATA(DDXPRDLM)
SET DDXPRDLM=$PIECE(DDXPFMZO,U,3)
+4 IF DDXPRDLM]""
SET DDXPRDLM=$$BLDELIM(DDXPRDLM)
DO RECDELIM
DO FPROC
FINISH ;
+1 IF DDXPFOUT]""
SET ^DIPT(DDXPXTNO,"F",DDXPFONO)=DDXPFOUT
+2 SET DIE="^DIST(.44,"
SET DA=DDXPFMNO
SET DR="40///1"
DO ^DIE
+3 SET DIE="^DIPT("
SET DA=DDXPFDTM
SET DR="110///1"
DO ^DIE
KILL DIE,DA,DR
+4 WRITE !!,?10,"Export Template created.",!
+5 IF $GET(DDXPTMDL)
Begin DoDot:1
+6 SET DIK="^DIPT("
SET DA=DDXPFDTM
DO ^DIK
KILL DIK,DA
+7 WRITE ?10,"Selected Fields template "_DDXPFDNM_" deleted.",!
+8 QUIT
End DoDot:1
+9 GOTO DONE
QUIT ;
+1 WRITE !!,?10,"Export Template NOT created!!"
+2 IF $GET(DDXPTMDL)
WRITE !,?10,"Selected Fields template "_DDXPFDNM_" not deleted."
+3 IF $DATA(DDXPXTNO)
SET DIK="^DIPT("
SET DA=DDXPXTNO
DO ^DIK
KILL DIK,DA
DONE ;
+1 KILL X,Y,DDXPDELM,DDXPDT,DDXPFDTM,DDXPFCAP,DDXPFFNM,DDXPFIN,DDXPFINO,DDXPFLD,DDXPIOM,DDXPFLEN,DDXPFMNO,DDXPFMZO,DDXPFONO,DDXPTLEN,DDXPTMDL
+2 KILL DDXPFDNM,DDXPFOUT,DDXPLNMX,DDXPRNPC,DDXPNPC,DDXPOUT,DDXPTIN,DDXPATH,DDXPTOTF,DDXPXPOS,DDXPXTNM,DDXPXTNO,DDXPRDLM,Q,T,DTOUT,DUOUT,DIRUT
+3 KILL ^TMP($JOB,"DIP")
+4 QUIT
FLOAD ;
+1 SET DDXPFLD=0
+2 FOR FIN=0:0
SET FIN=$ORDER(^DIPT(DDXPFDTM,"F",FIN))
IF FIN=""
QUIT
SET DDXPFIN=^(FIN)
Begin DoDot:1
+3 FOR TCNT=1:1
SET DDXPTIN=$PIECE(DDXPFIN,T,TCNT)
IF DDXPTIN=""
QUIT
Begin DoDot:2
+4 SET DDXPFLD=DDXPFLD+1
+5 SET ^TMP($JOB,"TIN",DDXPFLD)=DDXPTIN
+6 SET DDXPNOUT(DDXPFLD)=$$NOUT(DDXPTIN)
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 SET DDXPTOTF=DDXPFLD
+10 KILL FIN,TCNT
QUIT
FIXLEN ;
+1 SET DDXPLNMX=$SELECT(+$PIECE(DDXPFMZO,U,8):$PIECE(DDXPFMZO,U,8),$GET(DDXPIOM):DDXPIOM,1:80)
+2 IF DDXPXPOS+DDXPFLEN(DDXPFLD)>(DDXPLNMX+1)
SET DDXPXPOS=1
+3 SET DDXPNPC=DDXPNPC_";L"_DDXPFLEN(DDXPFLD)_";C"_DDXPXPOS
+4 SET DDXPXPOS=DDXPXPOS+DDXPFLEN(DDXPFLD)
+5 QUIT
RUNON ;
+1 SET DDXPNPC=DDXPNPC_";X"
+2 QUIT
DELIM ;
+1 SET DDXPNPC=DDXPNPC_T_"W $C("_DDXPDELM_")"
+2 IF '$PIECE(DDXPFMZO,U,6)
DO RUNON
+3 QUIT
RECDELIM ;
+1 SET DDXPNPC="W $C("_DDXPRDLM_")"
+2 IF '$PIECE(DDXPFMZO,U,6)
DO RUNON
+3 QUIT
BLDELIM(%) ;
+1 NEW CHAR,DELM
+2 IF +%
SET DELM=%
GOTO BLDOUT
+3 SET DELM=$ASCII(%)
+4 FOR CHAR=2:1
IF $EXTRACT(%,CHAR)=""
QUIT
SET DELM=DELM_","_$ASCII($EXTRACT(%,CHAR))
BLDOUT QUIT DELM
FPROC ;
+1 IF $LENGTH(DDXPFOUT)+$LENGTH(DDXPNPC)<220
SET DDXPFOUT=DDXPFOUT_DDXPNPC_T
QUIT
+2 SET ^DIPT(DDXPXTNO,"F",DDXPFONO)=DDXPFOUT
+3 SET DDXPFOUT=DDXPNPC_T
SET DDXPFONO=DDXPFONO+1
+4 QUIT
+5 ;
NOUT(DDXPTIN) ;
+1 IF DDXPTIN["SETDATA"!(DDXPTIN["SETPARAM")
QUIT 1
+2 QUIT 0
