- 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