DDMP ;SFISC/DPC-IMPORT ASCII DATA ;5DEC2009
;;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.
;
FILE(DDMPF,DDMPFLDS,DDMPFLG,DDMPFSRC,DDMPFMT) ;
;API for import tool.
;DDMPF - file# of primary import file.
;DDMPFLDS (by ref or value) - 1) name of import template (in [])
; 2) ;-delimited fields array. Primary file in top element.
; Other nodes subscripted by subfile#.
;DDMPFLG (by ref.) - ("FLAGS"): 'E'xternal; 'F'ile contains specs
; ("MSGS"): Root to contain error messages.
; ("MAXERR"): Maximum # of errors allowed.
; ("IOP"): Device for report printing.
; ("QTIME"): Queue import time.
;DDMPFSRC (by ref.) -("PATH"): Path to source file
; ("FILE"): Source file name.
;DDMPFMT (by value or ref.) - 1) top node = foreign format.
; 2) ("FDELIM"): Field delimiter.
; ("FIXED"): YES if fixed format.
; ("QUOTED"): YES if delimited fields quoted.
;
I '$D(DIQUIET) N DIQUIET S DIQUIET=1
I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
N DDMPNCNT
S DDMPFLG=$G(DDMPFLG("FLAGS"),$G(DDMPFLG)) I '$$VERFLG^DIEFU(DDMPFLG,"FE") G OUT
S DDMPFLG("MAXERR")=$G(DDMPFLG("MAXERR"),1000)
S DDMPFSRC("PATH")=$G(DDMPFSRC("PATH"))
I $G(DDMPFSRC("FILE"))="" D BLD^DIALOG(202,"host source file","host source file") G OUT
D GETFMT^DDMP1(.DDMPFMT) G:$G(DIERR) OUT
D GETSRC^DDMP1(.DDMPFSRC) G:'$D(^TMP($J,"DDMP")) OUT
S DDMPNCNT=$O(^TMP($J,"DDMP",""))
I DDMPFLG["F" D G:$G(DIERR) OUT
. I $G(DDMPF)'=""!($D(DDMPFLDS)&($G(DDMPFLDS)'="")) D BLD^DIALOG(1833) Q
. D INFILE^DDMP1("^TMP($J,""DDMP"")",.DDMPFMT,.DDMPF,.DDMPFLDS,.DDMPNCNT)
E I $G(DDMPF)=""!('$D(DDMPFLDS)) D BLD^DIALOG(202,"file or the fields","file or the fields") G OUT
I DDMPNCNT="" D BLD^DIALOG(1812,DDMPFSRC("FILE"),DDMPFSRC("FILE")) G OUT
I $E($G(DDMPFLDS))="[" N DDMPERR D G:DDMPERR'=$G(DIERR) OUT ;import template processing
. S DDMPERR=$G(DIERR)
. D TMPL2DR^DDMP1(DDMPF,.DDMPFLDS)
S DDMPFLDS(DDMPF)=$G(DDMPFLDS(DDMPF),$G(DDMPFLDS))
I '$$RQIDOK^DDMP1(.DDMPFLDS) G OUT
N DDMPSQ,DDMPFIEN S (DDMPSQ,DDMPFIEN)=0
D FLDBLD(DDMPF,.DDMPFLDS,.DDMPSQ,.DDMPFIEN,1) G:$G(DIERR) OUT
N DDMPIOP,ZTSK,POP ;Device and queuing setup.
D DEV^DDMP2(.DDMPFLG,.DDMPIOP)
I $G(DDMPIOP("NG")) D BLD^DIALOG(1850) G OUT
I $G(DDMPIOP("Q")) D QUE^DDMP2(.DDMPIOP) G OUT
TASK ;Entry point for queued imports. If not queued, processing continues.
N DDMPRPSB,DDMPLN,DDMPSTAT,POP
D REP1^DDMP2(.DDMPRPSB,.DDMPLN)
S DDMPSTAT("BEG")=$H,(DDMPSTAT("TOT"),DDMPSTAT("NG"))=0
D PUTDRVR(.DDMPSQ,.DDMPFMT,.DDMPFLG,DDMPNCNT,.DDMPSTAT)
D REP2^DDMP2(DDMPRPSB,DDMPLN,.DDMPSTAT)
OUT I $D(ZTQUEUED) D
. S ZTREQ="@"
. D CLEAN^DIEFU
E I $G(DDMPFLG("MSGS"))]"" D CALLOUT^DIEFU(DDMPFLG("MSGS"))
K ^TMP($J,"DDMP")
;K ^XTMP(DDMPRPSB) ;Deletes the report from XTMP
Q
;
FLDBLD(DDMPF,DDMPFLDS,DDMPSQ,DDMPFIEN,DDMPTFIX) ;
N DDMPI,DDMPNFLD,DDMPNIEN,DDMPINFD
S DDMPFIEN=DDMPFIEN+1
S DDMPNIEN="+"_DDMPFIEN_","_$G(DDMPFIEN("UP",DDMPF))
F DDMPI=1:1 S DDMPINFD=$P(DDMPFLDS(DDMPF),";",DDMPI) Q:DDMPINFD="" D Q:$G(DIERR)
. I DDMPINFD'["[" S DDMPNFLD=DDMPINFD
. E N DDMPOFIX S DDMPNFLD=+DDMPINFD,DDMPOFIX=$P($P(DDMPINFD,"]"),"[",2)
. I '$$VFIELD^DIEFU(DDMPF,DDMPNFLD,"D") Q
. N DDMP0P2
. S DDMP0P2=$P($G(^DD(DDMPF,DDMPNFLD,0)),U,2)
. I +DDMP0P2 D Q
. . N DDMPDWF
. . I $P($G(^DD(+DDMP0P2,.01,0)),U,2)["W" D Q
. . . N DDMPE S DDMPE(1)="word processing",DDMPE("FILE")=DDMPF,DDMPE("FIELD")=DDMPNFLD
. . . D BLD^DIALOG(520,"word processing",.DDMPE)
. . S DDMPDWF=+DDMP0P2
. . S DDMPFIEN("UP",DDMPDWF)=DDMPNIEN
. . I '$D(DDMPFLDS(DDMPDWF)) D Q
. . . N DDMPP S DDMPP("FILE")=DDMPDWF
. . . D BLD^DIALOG(525,.DDMPP,.DDMPP)
. . D FLDBLD(DDMPDWF,.DDMPFLDS,.DDMPSQ,.DDMPFIEN,DDMPTFIX)
. S DDMPSQ=DDMPSQ+1
. I DDMPFMT("FIXED")="YES",'$G(DDMPOFIX) D BLD^DIALOG(1822)
. S DDMPSQ(DDMPSQ)=DDMPF_"~"_DDMPNIEN_"~"_DDMPNFLD_"~"_$G(DDMPOFIX)
Q
;
PUTDRVR(DDMPSQ,DDMPFMT,DDMPFLG,DDMPNODE,DDMPSTAT) ;
;Sets up FDA and files data.
;DDMPSQ (by reference): Contains specs for each field.
;DDMPFMT (by reference): Format of imcoming data
;DDMPFLG (by reference): Import control info.
;DDMPNODE (by value): Number of first node containing data.
N DDMPTPAR,DDMPNDCT,DDMPUPFG,DDMPREF
I DDMPFLG["E" S DDMPUPFG="E"
S DDMPNDCT=1
S DDMPREF=$NA(^TMP($J,"DDMP",DDMPNODE))
S DDMPTPAR(1)=^TMP($J,"DDMP",DDMPNODE)
F S DDMPREF=$Q(@DDMPREF) Q:$QS(DDMPREF,1)'=$J!($QS(DDMPREF,2)'="DDMP") D Q:$G(DDMPSTAT("ABORT")) ;GFT $J MIGHT BE NON-NUMERIC
. I DDMPREF'["OVF" D
. . D RECPROC
. . K DDMPTPAR S DDMPNDCT=0
. S DDMPNDCT=DDMPNDCT+1
. S DDMPTPAR(DDMPNDCT)=@DDMPREF
I $G(DDMPSTAT("ABORT")) Q
D RECPROC
Q
;
RECPROC ; Files a record from DDMPTPAR()
N DDMPIENS
K ^TMP($J,"DDMPFDA")
D TOT(.DDMPSTAT) Q:$G(DDMPSTAT("ABORT"))
D PARSE(.DDMPSQ,.DDMPTPAR,DDMPNDCT)
I '$D(^TMP($J,"DDMPFDA")) D RECERR Q
D UPDATE^DIE($G(DDMPUPFG),"^TMP($J,""DDMPFDA"")","DDMPIENS")
I $G(DIERR) D
. D RECERR
E I DDMPSTAT("TOT")-DDMPSTAT("NG")>1 S DDMPSTAT("LIEN")=DDMPIENS(1)
E S (DDMPSTAT("FIEN"),DDMPSTAT("LIEN"))=DDMPIENS(1)
Q
;
TOT(DDMPSTAT) ;
S DDMPSTAT("TOT")=DDMPSTAT("TOT")+1
I '$D(ZTQUEUED) W "."
E I DDMPSTAT("TOT")#10=0,$$S^%ZTLOAD D
. S DDMPSTAT("ABORT")=2
. S ZTSTOP=1
Q
;
RECERR ;
N DDMPERLN,DDMPERR
S DDMPSTAT("NG")=DDMPSTAT("NG")+1
D LDXTMP^DDMP2("Record #"_DDMPSTAT("TOT")_" Rejected:")
D MSG^DIALOG("AEB",.DDMPERR,$S($D(IOM):IOM-5,1:75))
S DDMPERLN=0
F S DDMPERLN=$O(DDMPERR(DDMPERLN)) Q:'DDMPERLN D LDXTMP^DDMP2(" "_DDMPERR(DDMPERLN))
D CLEAN^DIEFU
I DDMPSTAT("NG")'<DDMPFLG("MAXERR") S DDMPSTAT("ABORT")=1
Q
;
PARSE(DDMPSQ,DDMPTPAR,DDMPNDCT) ;
N DDMPQ,DDMPHOLD,DDMPIN,DDMPI,DDMPTVAL,DDMPVAL
I DDMPTPAR(1)="" D BLD^DIALOG(1860) Q
S DDMPQ="""",DDMPSQ=0
F DDMPI=1:1:DDMPNDCT S DDMPIN=DDMPTPAR(DDMPI) F Q:DDMPIN=""!($G(DIERR)) D
. I $G(DDMPFMT("QUOTED"))="YES",($E(DDMPIN)=DDMPQ!($E($G(DDMPHOLD))=DDMPQ)) D
. . I $G(DDMPHOLD)]"" D
. . . I DDMPHOLD'=DDMPQ,$E(DDMPHOLD,$L(DDMPHOLD))=DDMPQ D
. . . . S DDMPVAL=DDMPHOLD,DDMPHOLD=""
. . . . S DDMPIN=$P(DDMPIN,DDMPFMT("FDELIM"),2,99)
. . . E D
. . . . S DDMPVAL=DDMPHOLD_$P(DDMPIN,DDMPQ)_DDMPQ,DDMPHOLD=""
. . . . S DDMPIN=$P($P(DDMPIN,DDMPQ,2,99),DDMPFMT("FDELIM"),2,99)
. . E D
. . . S DDMPTVAL=$P(DDMPIN,DDMPQ,1,2)_$S($L(DDMPIN,DDMPQ)>2:DDMPQ,1:"")
. . . S DDMPIN=$E(DDMPIN,$L(DDMPTVAL)+1,$L(DDMPIN)) ; S DDMPIN=$P(DDMPIN,DDMPTVAL,2)
. . . I DDMPIN=DDMPFMT("FDELIM") S DDMPIN="",DDMPVAL=DDMPTVAL Q
. . . S DDMPIN=$P(DDMPIN,DDMPFMT("FDELIM"),2,99)
. . . I DDMPIN="",DDMPI'=DDMPNDCT S DDMPHOLD=DDMPTVAL Q
. . . S DDMPVAL=DDMPTVAL
. E I $G(DDMPFMT("FDELIM"))'="" D
. . S DDMPTVAL=$P(DDMPIN,DDMPFMT("FDELIM"))
. . I $L(DDMPIN,DDMPFMT("FDELIM"))=2,$P(DDMPIN,DDMPFMT("FDELIM"),2)="" S DDMPIN="",DDMPVAL=$G(DDMPHOLD)_DDMPTVAL,DDMPHOLD="" Q
. . S DDMPIN=$P(DDMPIN,DDMPFMT("FDELIM"),2,99)
. . I $G(DDMPHOLD)]"" S DDMPVAL=DDMPHOLD_DDMPTVAL,DDMPHOLD="" Q
. . I DDMPIN="",DDMPI'=DDMPNDCT S DDMPHOLD=DDMPTVAL Q
. . S DDMPVAL=DDMPTVAL
. E D
. . N DDMPLEN,DDMPLAST
. . I '$D(DDMPSQ(DDMPSQ+1)) D BLD^DIALOG(1862) Q
. . S DDMPLEN=$P(DDMPSQ(DDMPSQ+1),"~",4)
. . I $G(DDMPHOLD)]"" D
. . . S DDMPVAL=DDMPHOLD_$E(DDMPIN,1,DDMPLEN-$L(DDMPHOLD))
. . . S DDMPIN=$E(DDMPIN,DDMPLEN-$L(DDMPHOLD)+1,255)
. . . S DDMPHOLD=""
. . E D
. . . S DDMPTVAL=$E(DDMPIN,1,DDMPLEN)
. . . S DDMPIN=$E(DDMPIN,DDMPLEN+1,255)
. . . I DDMPIN="",DDMPI'=DDMPNDCT S DDMPHOLD=DDMPTVAL Q
. . . S DDMPVAL=DDMPTVAL
. . I $D(DDMPVAL) F S DDMPLAST=$L(DDMPVAL) Q:$E(DDMPVAL,DDMPLAST)'=" " S DDMPVAL=$E(DDMPVAL,1,DDMPLAST-1)
. I $D(DDMPVAL) D K DDMPVAL
. . S DDMPSQ=DDMPSQ+1
. . I '$D(DDMPSQ(DDMPSQ)) D BLD^DIALOG(1862) Q
. . I $G(DDMPFMT("QUOTED"))="YES" S DDMPVAL=$TR(DDMPVAL,DDMPQ)
. . D FDASET(DDMPVAL,DDMPSQ(DDMPSQ))
I $G(DDMPFMT("FIXED"))="YES" F DDMPSQ=DDMPSQ+1:1 Q:'$D(DDMPSQ(DDMPSQ)) S DDMPVAL="" D FDASET(DDMPVAL,DDMPSQ(DDMPSQ))
Q
;
FDASET(DDMPVAL,DDMPSPEC) ;
S ^TMP($J,"DDMPFDA",$P(DDMPSPEC,"~"),$P(DDMPSPEC,"~",2),$P(DDMPSPEC,"~",3))=DDMPVAL
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDMP 8478 printed Apr 09, 2024@21:48:21 Page 2
DDMP ;SFISC/DPC-IMPORT ASCII DATA ;5DEC2009
+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 ;
FILE(DDMPF,DDMPFLDS,DDMPFLG,DDMPFSRC,DDMPFMT) ;
+1 ;API for import tool.
+2 ;DDMPF - file# of primary import file.
+3 ;DDMPFLDS (by ref or value) - 1) name of import template (in [])
+4 ; 2) ;-delimited fields array. Primary file in top element.
+5 ; Other nodes subscripted by subfile#.
+6 ;DDMPFLG (by ref.) - ("FLAGS"): 'E'xternal; 'F'ile contains specs
+7 ; ("MSGS"): Root to contain error messages.
+8 ; ("MAXERR"): Maximum # of errors allowed.
+9 ; ("IOP"): Device for report printing.
+10 ; ("QTIME"): Queue import time.
+11 ;DDMPFSRC (by ref.) -("PATH"): Path to source file
+12 ; ("FILE"): Source file name.
+13 ;DDMPFMT (by value or ref.) - 1) top node = foreign format.
+14 ; 2) ("FDELIM"): Field delimiter.
+15 ; ("FIXED"): YES if fixed format.
+16 ; ("QUOTED"): YES if delimited fields quoted.
+17 ;
+18 IF '$DATA(DIQUIET)
NEW DIQUIET
SET DIQUIET=1
+19 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+20 NEW DDMPNCNT
+21 SET DDMPFLG=$GET(DDMPFLG("FLAGS"),$GET(DDMPFLG))
IF '$$VERFLG^DIEFU(DDMPFLG,"FE")
GOTO OUT
+22 SET DDMPFLG("MAXERR")=$GET(DDMPFLG("MAXERR"),1000)
+23 SET DDMPFSRC("PATH")=$GET(DDMPFSRC("PATH"))
+24 IF $GET(DDMPFSRC("FILE"))=""
DO BLD^DIALOG(202,"host source file","host source file")
GOTO OUT
+25 DO GETFMT^DDMP1(.DDMPFMT)
if $GET(DIERR)
GOTO OUT
+26 DO GETSRC^DDMP1(.DDMPFSRC)
if '$DATA(^TMP($JOB,"DDMP"))
GOTO OUT
+27 SET DDMPNCNT=$ORDER(^TMP($JOB,"DDMP",""))
+28 IF DDMPFLG["F"
Begin DoDot:1
+29 IF $GET(DDMPF)'=""!($DATA(DDMPFLDS)&($GET(DDMPFLDS)'=""))
DO BLD^DIALOG(1833)
QUIT
+30 DO INFILE^DDMP1("^TMP($J,""DDMP"")",.DDMPFMT,.DDMPF,.DDMPFLDS,.DDMPNCNT)
End DoDot:1
if $GET(DIERR)
GOTO OUT
+31 IF '$TEST
IF $GET(DDMPF)=""!('$DATA(DDMPFLDS))
DO BLD^DIALOG(202,"file or the fields","file or the fields")
GOTO OUT
+32 IF DDMPNCNT=""
DO BLD^DIALOG(1812,DDMPFSRC("FILE"),DDMPFSRC("FILE"))
GOTO OUT
+33 ;import template processing
IF $EXTRACT($GET(DDMPFLDS))="["
NEW DDMPERR
Begin DoDot:1
+34 SET DDMPERR=$GET(DIERR)
+35 DO TMPL2DR^DDMP1(DDMPF,.DDMPFLDS)
End DoDot:1
if DDMPERR'=$GET(DIERR)
GOTO OUT
+36 SET DDMPFLDS(DDMPF)=$GET(DDMPFLDS(DDMPF),$GET(DDMPFLDS))
+37 IF '$$RQIDOK^DDMP1(.DDMPFLDS)
GOTO OUT
+38 NEW DDMPSQ,DDMPFIEN
SET (DDMPSQ,DDMPFIEN)=0
+39 DO FLDBLD(DDMPF,.DDMPFLDS,.DDMPSQ,.DDMPFIEN,1)
if $GET(DIERR)
GOTO OUT
+40 ;Device and queuing setup.
NEW DDMPIOP,ZTSK,POP
+41 DO DEV^DDMP2(.DDMPFLG,.DDMPIOP)
+42 IF $GET(DDMPIOP("NG"))
DO BLD^DIALOG(1850)
GOTO OUT
+43 IF $GET(DDMPIOP("Q"))
DO QUE^DDMP2(.DDMPIOP)
GOTO OUT
TASK ;Entry point for queued imports. If not queued, processing continues.
+1 NEW DDMPRPSB,DDMPLN,DDMPSTAT,POP
+2 DO REP1^DDMP2(.DDMPRPSB,.DDMPLN)
+3 SET DDMPSTAT("BEG")=$HOROLOG
SET (DDMPSTAT("TOT"),DDMPSTAT("NG"))=0
+4 DO PUTDRVR(.DDMPSQ,.DDMPFMT,.DDMPFLG,DDMPNCNT,.DDMPSTAT)
+5 DO REP2^DDMP2(DDMPRPSB,DDMPLN,.DDMPSTAT)
OUT IF $DATA(ZTQUEUED)
Begin DoDot:1
+1 SET ZTREQ="@"
+2 DO CLEAN^DIEFU
End DoDot:1
+3 IF '$TEST
IF $GET(DDMPFLG("MSGS"))]""
DO CALLOUT^DIEFU(DDMPFLG("MSGS"))
+4 KILL ^TMP($JOB,"DDMP")
+5 ;K ^XTMP(DDMPRPSB) ;Deletes the report from XTMP
+6 QUIT
+7 ;
FLDBLD(DDMPF,DDMPFLDS,DDMPSQ,DDMPFIEN,DDMPTFIX) ;
+1 NEW DDMPI,DDMPNFLD,DDMPNIEN,DDMPINFD
+2 SET DDMPFIEN=DDMPFIEN+1
+3 SET DDMPNIEN="+"_DDMPFIEN_","_$GET(DDMPFIEN("UP",DDMPF))
+4 FOR DDMPI=1:1
SET DDMPINFD=$PIECE(DDMPFLDS(DDMPF),";",DDMPI)
if DDMPINFD=""
QUIT
Begin DoDot:1
+5 IF DDMPINFD'["["
SET DDMPNFLD=DDMPINFD
+6 IF '$TEST
NEW DDMPOFIX
SET DDMPNFLD=+DDMPINFD
SET DDMPOFIX=$PIECE($PIECE(DDMPINFD,"]"),"[",2)
+7 IF '$$VFIELD^DIEFU(DDMPF,DDMPNFLD,"D")
QUIT
+8 NEW DDMP0P2
+9 SET DDMP0P2=$PIECE($GET(^DD(DDMPF,DDMPNFLD,0)),U,2)
+10 IF +DDMP0P2
Begin DoDot:2
+11 NEW DDMPDWF
+12 IF $PIECE($GET(^DD(+DDMP0P2,.01,0)),U,2)["W"
Begin DoDot:3
+13 NEW DDMPE
SET DDMPE(1)="word processing"
SET DDMPE("FILE")=DDMPF
SET DDMPE("FIELD")=DDMPNFLD
+14 DO BLD^DIALOG(520,"word processing",.DDMPE)
End DoDot:3
QUIT
+15 SET DDMPDWF=+DDMP0P2
+16 SET DDMPFIEN("UP",DDMPDWF)=DDMPNIEN
+17 IF '$DATA(DDMPFLDS(DDMPDWF))
Begin DoDot:3
+18 NEW DDMPP
SET DDMPP("FILE")=DDMPDWF
+19 DO BLD^DIALOG(525,.DDMPP,.DDMPP)
End DoDot:3
QUIT
+20 DO FLDBLD(DDMPDWF,.DDMPFLDS,.DDMPSQ,.DDMPFIEN,DDMPTFIX)
End DoDot:2
QUIT
+21 SET DDMPSQ=DDMPSQ+1
+22 IF DDMPFMT("FIXED")="YES"
IF '$GET(DDMPOFIX)
DO BLD^DIALOG(1822)
+23 SET DDMPSQ(DDMPSQ)=DDMPF_"~"_DDMPNIEN_"~"_DDMPNFLD_"~"_$GET(DDMPOFIX)
End DoDot:1
if $GET(DIERR)
QUIT
+24 QUIT
+25 ;
PUTDRVR(DDMPSQ,DDMPFMT,DDMPFLG,DDMPNODE,DDMPSTAT) ;
+1 ;Sets up FDA and files data.
+2 ;DDMPSQ (by reference): Contains specs for each field.
+3 ;DDMPFMT (by reference): Format of imcoming data
+4 ;DDMPFLG (by reference): Import control info.
+5 ;DDMPNODE (by value): Number of first node containing data.
+6 NEW DDMPTPAR,DDMPNDCT,DDMPUPFG,DDMPREF
+7 IF DDMPFLG["E"
SET DDMPUPFG="E"
+8 SET DDMPNDCT=1
+9 SET DDMPREF=$NAME(^TMP($JOB,"DDMP",DDMPNODE))
+10 SET DDMPTPAR(1)=^TMP($JOB,"DDMP",DDMPNODE)
+11 ;GFT $J MIGHT BE NON-NUMERIC
FOR
SET DDMPREF=$QUERY(@DDMPREF)
if $QSUBSCRIPT(DDMPREF,1)'=$JOB!($QSUBSCRIPT(DDMPREF,2)'="DDMP")
QUIT
Begin DoDot:1
+12 IF DDMPREF'["OVF"
Begin DoDot:2
+13 DO RECPROC
+14 KILL DDMPTPAR
SET DDMPNDCT=0
End DoDot:2
+15 SET DDMPNDCT=DDMPNDCT+1
+16 SET DDMPTPAR(DDMPNDCT)=@DDMPREF
End DoDot:1
if $GET(DDMPSTAT("ABORT"))
QUIT
+17 IF $GET(DDMPSTAT("ABORT"))
QUIT
+18 DO RECPROC
+19 QUIT
+20 ;
RECPROC ; Files a record from DDMPTPAR()
+1 NEW DDMPIENS
+2 KILL ^TMP($JOB,"DDMPFDA")
+3 DO TOT(.DDMPSTAT)
if $GET(DDMPSTAT("ABORT"))
QUIT
+4 DO PARSE(.DDMPSQ,.DDMPTPAR,DDMPNDCT)
+5 IF '$DATA(^TMP($JOB,"DDMPFDA"))
DO RECERR
QUIT
+6 DO UPDATE^DIE($GET(DDMPUPFG),"^TMP($J,""DDMPFDA"")","DDMPIENS")
+7 IF $GET(DIERR)
Begin DoDot:1
+8 DO RECERR
End DoDot:1
+9 IF '$TEST
IF DDMPSTAT("TOT")-DDMPSTAT("NG")>1
SET DDMPSTAT("LIEN")=DDMPIENS(1)
+10 IF '$TEST
SET (DDMPSTAT("FIEN"),DDMPSTAT("LIEN"))=DDMPIENS(1)
+11 QUIT
+12 ;
TOT(DDMPSTAT) ;
+1 SET DDMPSTAT("TOT")=DDMPSTAT("TOT")+1
+2 IF '$DATA(ZTQUEUED)
WRITE "."
+3 IF '$TEST
IF DDMPSTAT("TOT")#10=0
IF $$S^%ZTLOAD
Begin DoDot:1
+4 SET DDMPSTAT("ABORT")=2
+5 SET ZTSTOP=1
End DoDot:1
+6 QUIT
+7 ;
RECERR ;
+1 NEW DDMPERLN,DDMPERR
+2 SET DDMPSTAT("NG")=DDMPSTAT("NG")+1
+3 DO LDXTMP^DDMP2("Record #"_DDMPSTAT("TOT")_" Rejected:")
+4 DO MSG^DIALOG("AEB",.DDMPERR,$SELECT($DATA(IOM):IOM-5,1:75))
+5 SET DDMPERLN=0
+6 FOR
SET DDMPERLN=$ORDER(DDMPERR(DDMPERLN))
if 'DDMPERLN
QUIT
DO LDXTMP^DDMP2(" "_DDMPERR(DDMPERLN))
+7 DO CLEAN^DIEFU
+8 IF DDMPSTAT("NG")'<DDMPFLG("MAXERR")
SET DDMPSTAT("ABORT")=1
+9 QUIT
+10 ;
PARSE(DDMPSQ,DDMPTPAR,DDMPNDCT) ;
+1 NEW DDMPQ,DDMPHOLD,DDMPIN,DDMPI,DDMPTVAL,DDMPVAL
+2 IF DDMPTPAR(1)=""
DO BLD^DIALOG(1860)
QUIT
+3 SET DDMPQ=""""
SET DDMPSQ=0
+4 FOR DDMPI=1:1:DDMPNDCT
SET DDMPIN=DDMPTPAR(DDMPI)
FOR
if DDMPIN=""!($GET(DIERR))
QUIT
Begin DoDot:1
+5 IF $GET(DDMPFMT("QUOTED"))="YES"
IF ($EXTRACT(DDMPIN)=DDMPQ!($EXTRACT($GET(DDMPHOLD))=DDMPQ))
Begin DoDot:2
+6 IF $GET(DDMPHOLD)]""
Begin DoDot:3
+7 IF DDMPHOLD'=DDMPQ
IF $EXTRACT(DDMPHOLD,$LENGTH(DDMPHOLD))=DDMPQ
Begin DoDot:4
+8 SET DDMPVAL=DDMPHOLD
SET DDMPHOLD=""
+9 SET DDMPIN=$PIECE(DDMPIN,DDMPFMT("FDELIM"),2,99)
End DoDot:4
+10 IF '$TEST
Begin DoDot:4
+11 SET DDMPVAL=DDMPHOLD_$PIECE(DDMPIN,DDMPQ)_DDMPQ
SET DDMPHOLD=""
+12 SET DDMPIN=$PIECE($PIECE(DDMPIN,DDMPQ,2,99),DDMPFMT("FDELIM"),2,99)
End DoDot:4
End DoDot:3
+13 IF '$TEST
Begin DoDot:3
+14 SET DDMPTVAL=$PIECE(DDMPIN,DDMPQ,1,2)_$SELECT($LENGTH(DDMPIN,DDMPQ)>2:DDMPQ,1:"")
+15 ; S DDMPIN=$P(DDMPIN,DDMPTVAL,2)
SET DDMPIN=$EXTRACT(DDMPIN,$LENGTH(DDMPTVAL)+1,$LENGTH(DDMPIN))
+16 IF DDMPIN=DDMPFMT("FDELIM")
SET DDMPIN=""
SET DDMPVAL=DDMPTVAL
QUIT
+17 SET DDMPIN=$PIECE(DDMPIN,DDMPFMT("FDELIM"),2,99)
+18 IF DDMPIN=""
IF DDMPI'=DDMPNDCT
SET DDMPHOLD=DDMPTVAL
QUIT
+19 SET DDMPVAL=DDMPTVAL
End DoDot:3
End DoDot:2
+20 IF '$TEST
IF $GET(DDMPFMT("FDELIM"))'=""
Begin DoDot:2
+21 SET DDMPTVAL=$PIECE(DDMPIN,DDMPFMT("FDELIM"))
+22 IF $LENGTH(DDMPIN,DDMPFMT("FDELIM"))=2
IF $PIECE(DDMPIN,DDMPFMT("FDELIM"),2)=""
SET DDMPIN=""
SET DDMPVAL=$GET(DDMPHOLD)_DDMPTVAL
SET DDMPHOLD=""
QUIT
+23 SET DDMPIN=$PIECE(DDMPIN,DDMPFMT("FDELIM"),2,99)
+24 IF $GET(DDMPHOLD)]""
SET DDMPVAL=DDMPHOLD_DDMPTVAL
SET DDMPHOLD=""
QUIT
+25 IF DDMPIN=""
IF DDMPI'=DDMPNDCT
SET DDMPHOLD=DDMPTVAL
QUIT
+26 SET DDMPVAL=DDMPTVAL
End DoDot:2
+27 IF '$TEST
Begin DoDot:2
+28 NEW DDMPLEN,DDMPLAST
+29 IF '$DATA(DDMPSQ(DDMPSQ+1))
DO BLD^DIALOG(1862)
QUIT
+30 SET DDMPLEN=$PIECE(DDMPSQ(DDMPSQ+1),"~",4)
+31 IF $GET(DDMPHOLD)]""
Begin DoDot:3
+32 SET DDMPVAL=DDMPHOLD_$EXTRACT(DDMPIN,1,DDMPLEN-$LENGTH(DDMPHOLD))
+33 SET DDMPIN=$EXTRACT(DDMPIN,DDMPLEN-$LENGTH(DDMPHOLD)+1,255)
+34 SET DDMPHOLD=""
End DoDot:3
+35 IF '$TEST
Begin DoDot:3
+36 SET DDMPTVAL=$EXTRACT(DDMPIN,1,DDMPLEN)
+37 SET DDMPIN=$EXTRACT(DDMPIN,DDMPLEN+1,255)
+38 IF DDMPIN=""
IF DDMPI'=DDMPNDCT
SET DDMPHOLD=DDMPTVAL
QUIT
+39 SET DDMPVAL=DDMPTVAL
End DoDot:3
+40 IF $DATA(DDMPVAL)
FOR
SET DDMPLAST=$LENGTH(DDMPVAL)
if $EXTRACT(DDMPVAL,DDMPLAST)'=" "
QUIT
SET DDMPVAL=$EXTRACT(DDMPVAL,1,DDMPLAST-1)
End DoDot:2
+41 IF $DATA(DDMPVAL)
Begin DoDot:2
+42 SET DDMPSQ=DDMPSQ+1
+43 IF '$DATA(DDMPSQ(DDMPSQ))
DO BLD^DIALOG(1862)
QUIT
+44 IF $GET(DDMPFMT("QUOTED"))="YES"
SET DDMPVAL=$TRANSLATE(DDMPVAL,DDMPQ)
+45 DO FDASET(DDMPVAL,DDMPSQ(DDMPSQ))
End DoDot:2
KILL DDMPVAL
End DoDot:1
+46 IF $GET(DDMPFMT("FIXED"))="YES"
FOR DDMPSQ=DDMPSQ+1:1
if '$DATA(DDMPSQ(DDMPSQ))
QUIT
SET DDMPVAL=""
DO FDASET(DDMPVAL,DDMPSQ(DDMPSQ))
+47 QUIT
+48 ;
FDASET(DDMPVAL,DDMPSPEC) ;
+1 SET ^TMP($JOB,"DDMPFDA",$PIECE(DDMPSPEC,"~"),$PIECE(DDMPSPEC,"~",2),$PIECE(DDMPSPEC,"~",3))=DDMPVAL
+2 QUIT
+3 ;
