XUMFXH ;ISS/RAM - MFS Handler ;06/28/00
;;8.0;KERNEL;**299,382,383**;Jul 10, 1995
;
; This routine handles Master File HL7 messages.
;
MAIN ; -- entry point
;
N CNT,ERR,I,X,HLFS,HLCS,ERROR,HLRESLTA,IFN,IEN,MTPE,TYPE,ARRAY
N HDT,KEY,MID,REASON,VALUE,XREF,ALL,GROUP,PARAM,ROOT,SEG,QRD,XUMF
N QID,WHAT,WHO,HLSCS,CDSYS,EXIT,HLREP,NUMBER,Y,XXX,YYY,ERR,XIEN
N XUMFSDS
;
D INIT,PROCESS,REPLY^XUMFXACK(ERROR),EXIT
;
Q
;
INIT ; -- initialize
;
K ^TMP("DILIST",$J),^TMP("DIERR",$J)
K ^TMP("HLS",$J),^TMP("HLA",$J)
K ^TMP("XUMF MFS",$J),^TMP("XUMF ERROR",$J)
;
S XUMF=1,DUZ(0)="@"
;
S (ERROR,CNT,TYPE,ARRAY,EXIT)=0
S HLFS=HL("FS"),HLCS=$E(HL("ECH"))
S HLSCS=$E(HL("ECH"),4),HLREP=$E(HL("ECH"),2)
;
Q
;
PROCESS ; -- pull message text
;
F X HLNEXT Q:HLQUIT'>0 D
.Q:$P(HLNODE,HLFS)=""
.Q:"^MSH^MSA^QRD^MFI^MFE^RDF^RDT^"'[(U_$P(HLNODE,HLFS)_U)
.D @($P(HLNODE,HLFS))
;
Q
;
MSH ; -- MSH segment
;
Q
;
MSA ; -- MSA segment
;
N CODE
;
S CODE=$P(HLNODE,HLFS,2)
;
I CODE="AE"!(CODE="AR") D
.S ERROR=ERROR_U_$P(HLNODE,HLFS,4)_U_$G(ERR)
.D EM^XUMFX(ERROR,.ERR)
;
Q
;
MFI ; -- MFI segment
;
Q:ERROR
Q:EXIT
;
K IFN,ARRAY,MFI
;
I $P(HLNODE,HLFS,2)="" D Q
.S ERROR="1^MFI segment missing Master File Identifier HLNODE: "_HLNODE
.D EM^XUMFX(ERROR,.ERR)
;
S MFI=$P(HLNODE,HLFS,2),IFN=MFI
S:'IFN IFN=$O(^DIC(4.001,"MFI",$P(MFI,HLCS,2),0))
S IFN=$S(IFN:IFN,MFI="ZMF":4.001,1:0)
I 'IFN D Q
.S ERROR="1^IFN in MFI could not be resolved HLNODE: "_HLNODE
.D EM^XUMFX(ERROR,.ERR)
;
;sds flag=1; 1H is history record (use alt key for owning record)
S XUMFSDS=$S($P(MFI,HLCS,3)="SDS":1,1:0)
I XUMFSDS,MFI["History" S XUMFSDS="1H"
;
S ARRAY=$S($G(ARRAY):1,$P(HLNODE,HLFS,3)="TEMP":1,1:0)
;
Q
;
MFE ; -- MFE segment
;
Q:ERROR
Q:EXIT
;
K IEN
;
N PRE,POST
;
S KEY=$P(HLNODE,HLFS,5) Q:ARRAY
;
S PRE=$P($G(^DIC(4.001,+IFN,"MFE")),U,16)
I PRE'="" D Q:$G(EXIT)
.S PRE=PRE_"^XUMFXR"
.D @(PRE)
;
D MFE^XUMFX(IFN,KEY,HLCS,.IEN,.ERROR) Q:ERROR
;
S POST=$P($G(^DIC(4.001,+IFN,"MFE")),U,17)
I POST'="" D Q:$G(EXIT)
.S POST=POST_"^XUMFXR"
.D @(POST)
;
I 'IEN D Q
.S ERROR="1^IEN not resolved in MFE File #: "_IFN_" HLNODE: "_HLNODE
.D EM^XUMFX(ERROR,.ERR)
.K ERR
;
; clean multiple flag
K:'$D(XIEN(IEN)) XIEN
S XIEN(IEN)=$G(XIEN(IEN))+1
;
Q
;
RDF ; -- table row definition
;
Q:ERROR
Q:EXIT
;
I $G(ARRAY) D ARRAY Q
;
N COL,X,Y,Z,DTYP,IDX,SEQ,VUID,DATA,NAME
;
K ^TMP("XUMF MFS",$J,"PARAM","SEQ")
K ^TMP("XUMF MFS",$J,"PARAM","MULT")
K ^TMP("XUMF MFS",$J,"PARAM","IENS")
;
K XXX,YYY
;
D SEGPRSE^XUMFXHL7("HLNODE","XXX")
S NUMBER=XXX(1)
D SEQPRSE^XUMFXHL7("XXX(2)","COL") K XXX
I $O(COL(99999),-1)'=NUMBER D Q
.S ERROR="1^RDF number of columns error"
.D EM^XUMFX("RDF segment columns don't match number",.ERROR)
;
;S NUMBER=$P(HLNODE,HLFS,2)
;S DATA=$P(HLNODE,HLFS,3)
;
;S CNT=0,Y=0
;F SEQ=1:1:NUMBER D
;.S Y=Y+1
;.S Z=$P(DATA,HLREP,Y)
;.I Y=$L(DATA,HLREP) D
;..S CNT=$O(HLNODE(CNT))
;..S DATA=$G(HLNODE(+CNT))
;..S Z=Z_$P(DATA,HLREP)
;..S Y=1
;.S COL(SEQ)=Z
;
S SEQ=0
F S SEQ=$O(COL(SEQ)) Q:'SEQ D
.S NAME=COL(SEQ,1),TYP=COL(SEQ,2) Q:NAME=""
.;S NAME=$P(COL(SEQ),HLCS) Q:NAME=""
.S IDX=$O(^DIC(4.001,+IFN,1,"B",NAME,0)) Q:'IDX
.S DATA=$G(^DIC(4.001,+IFN,1,+IDX,0)) Q:DATA=""
.S YYY(NAME,SEQ)=""
.;
.;N FLD,TYP,SUBFILE,LKUP,REPEAT,CLEAN,TIMEZONE
.;S TYP=$P(DATA,U,3),TYP=$$GET1^DIQ(771.4,(+TYP_","),.01)
.N FLD,SUBFILE,LKUP,REPEAT,CLEAN,TIMEZONE
.S FLD=$P(DATA,U,2),SUBFILE=$P(DATA,U,4)
.S LKUP=$P(DATA,U,7),TIMEZONE=$P(DATA,U,14)
.S REPEAT=$P(DATA,U,11),CLEAN=$P(DATA,U,12),VUID=$P(DATA,U,13)
.S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"VUID")=VUID
.;
.I 'SUBFILE D Q
..S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,FLD)=TYP_U_LKUP
.;
.; -- multiple field
.;
.I $P(DATA,U,6)'="" D ;.01 is a field
..S XXX(SEQ)=$P(DATA,U,6)
.;
.S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"FILE")=SUBFILE
.S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"FIELD")=FLD
.S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"DTYP")=TYP
.S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"REPEAT")=REPEAT
.S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"CLEAN")=CLEAN
.S ^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"TIMEZONE")=TIMEZONE
;
S SEQ=0
F S SEQ=$O(XXX(SEQ)) Q:'SEQ D
.S X=XXX(SEQ),Y=$O(YYY(X,0))
.S ^TMP("XUMF MFS",$J,"PARAM","MULT",SEQ)=Y
;
Q
;
RDT ; -- table row data
;
Q:ERROR
Q:EXIT
;
K XXX
D SEGPRSE^XUMFXHL7("HLNODE","XXX")
I $O(XXX(99999),-1)'=NUMBER D Q
.S ERROR="1^RDF/RDT number of columns error"
.D EM^XUMFX("RDF/RDT segment columns don't match number",.ERROR)
;
I $G(ARRAY) D ARRAY Q
;
Q:'IEN
;
N FDA,IENS,FIELD,ERR,PRE,POST,MULT,FDA1,SEQ,VUID,TIMEZONE
;
S PRE=$P($G(^DIC(4.001,+IFN,0)),U,4)
I PRE'="" D
.S PRE=PRE_"^XUMFR"
.D @(PRE)
;
S IENS=IEN_","
S SEQ=0
F S SEQ=$O(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ)) Q:'SEQ D
.S FIELD=$O(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,0))
.S VUID=$G(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"VUID"))
.S TIMEZONE=$G(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"TIMEZONE"))
.I 'FIELD D SUBFILE Q
.S TYP=$G(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,FIELD))
.S VALUE=$$VALUE()
.S VALUE=$$DTYP^XUMFXP(VALUE,TYP,HLCS,0,TIMEZONE)
.S VALUE=$$VAL^XUMFX(IFN,FIELD,VUID,VALUE,IENS) Q:VALUE="^"
.S FDA(IFN,IENS,FIELD)=VALUE
;
M FDA=FDA1
;
D:$D(FDA) FILE^DIE(,"FDA","ERR")
I $D(ERR) D
.S ERROR="1^updating error"
.D EM^XUMFX("file DIE call error message in RDT",.ERR)
.K ERR
;
S POST=$P($G(^DIC(4.001,+IFN,0)),U,5)
I POST'="" D
.S POST=POST_"^XUMFR"
.D @(POST)
;
Q
;
SUBFILE ; -- process subfile record
;
N IFN,IENS1,KEY1,FIELD,TYP,MKEY,ERR,REPEAT,CLEAN
;
S IFN=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"FILE")
S FIELD=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"FIELD")
S TYP=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"DTYP")
S REPEAT=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"REPEAT")
S CLEAN=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"CLEAN")
;
I CLEAN,$G(XIEN(IEN))'>1 D
.N ROOT,IDX
.S ROOT=$$ROOT^DILFD(IFN,","_IENS,1)
.S IDX=0 F S IDX=$O(@ROOT@(IDX)) Q:'IDX D
..D
...N DA,DIK,DIC S DA(1)=+IENS,DA=IDX,DIK=$P(ROOT,")")_"," D ^DIK
;
S VALUE=$$VALUE()
S VALUE=$$DTYP^XUMFXP(VALUE,TYP,HLCS,0,TIMEZONE)
;
S MULT=$G(^TMP("XUMF MFS",$J,"PARAM","MULT",SEQ))
;
I MULT=SEQ Q:VALUE="" D
.N FDA,IEN
.S VALUE=$$VAL^XUMFX(IFN,FIELD,VUID,VALUE,"?+1,"_IENS) Q:VALUE="^"
.S FDA(IFN,"?+1,"_IENS,.01)=VALUE
.D UPDATE^DIE(,"FDA","IEN","ERR")
.I $D(ERR) D Q
..S ERROR="1^subfile update error SUBFILE#: "_IFN
..D EM^XUMFX("update DIE call error message in SUBFILE",.ERR)
..K ERR
.S IENS1=IEN(1)_","_IENS,MULT(SEQ)=IENS1
;
I MULT,MULT'=SEQ S IENS1=$G(MULT(+MULT)) Q:IENS1=""
S:MULT'=SEQ VALUE=$$VAL^XUMFX(IFN,FIELD,VUID,VALUE,"?+1,"_IENS) Q:VALUE="^"
S:$D(IENS1) FDA1(IFN,IENS1,FIELD)=VALUE
;
Q
;
VALUE() ; -- handle HL7 continuation nodes
;
Q:'$O(HLNODE(0)) $P(HLNODE,HLFS,SEQ+1)
;
N COL
;
D SEGPRSE^XUMFXHL7("HLNODE","COL")
;
Q COL(SEQ)
;
ARRAY ; -- query data stored in array (not filed)
;
N X S X=KEY S X=$S($P(X,HLCS)'="":$P(X,HLCS),1:$P(X,HLCS,4)) Q:X=""
;
M ^TMP("XUMF ARRAY",$J,IFN,X)=HLNODE
;
Q
;
EXIT ; -- cleanup, and quit
;
; post processing logic
S X=$G(^DIC(4.001,+IFN,2)) X:X'="" X
;
K ^TMP("DILIST",$J),^TMP("DIERR",$J),^TMP("HLS",$J),^TMP("HLA",$J)
;
K ^TMP("XUMF MFS",$J),^TMP("XUMF ERROR",$J)
;
Q
;
XUMFXH ;ISS/RAM - MFS Handler ;06/28/00
+1 ;;8.0;KERNEL;**299,382,383**;Jul 10, 1995
+2 ;
+3 ; This routine handles Master File HL7 messages.
+4 ;
MAIN ; -- entry point
+1 ;
+2 NEW CNT,ERR,I,X,HLFS,HLCS,ERROR,HLRESLTA,IFN,IEN,MTPE,TYPE,ARRAY
+3 NEW HDT,KEY,MID,REASON,VALUE,XREF,ALL,GROUP,PARAM,ROOT,SEG,QRD,XUMF
+4 NEW QID,WHAT,WHO,HLSCS,CDSYS,EXIT,HLREP,NUMBER,Y,XXX,YYY,ERR,XIEN
+5 NEW XUMFSDS
+6 ;
+7 DO INIT
DO PROCESS
DO REPLY^XUMFXACK(ERROR)
DO EXIT
+8 ;
+9 QUIT
+10 ;
INIT ; -- initialize
+1 ;
+2 KILL ^TMP("DILIST",$JOB),^TMP("DIERR",$JOB)
+3 KILL ^TMP("HLS",$JOB),^TMP("HLA",$JOB)
+4 KILL ^TMP("XUMF MFS",$JOB),^TMP("XUMF ERROR",$JOB)
+5 ;
+6 SET XUMF=1
SET DUZ(0)="@"
+7 ;
+8 SET (ERROR,CNT,TYPE,ARRAY,EXIT)=0
+9 SET HLFS=HL("FS")
SET HLCS=$EXTRACT(HL("ECH"))
+10 SET HLSCS=$EXTRACT(HL("ECH"),4)
SET HLREP=$EXTRACT(HL("ECH"),2)
+11 ;
+12 QUIT
+13 ;
PROCESS ; -- pull message text
+1 ;
+2 FOR
XECUTE HLNEXT
IF HLQUIT'>0
QUIT
Begin DoDot:1
+3 IF $PIECE(HLNODE,HLFS)=""
QUIT
+4 IF "^MSH^MSA^QRD^MFI^MFE^RDF^RDT^"'[(U_$PIECE(HLNODE,HLFS)_U)
QUIT
+5 DO @($PIECE(HLNODE,HLFS))
End DoDot:1
+6 ;
+7 QUIT
+8 ;
MSH ; -- MSH segment
+1 ;
+2 QUIT
+3 ;
MSA ; -- MSA segment
+1 ;
+2 NEW CODE
+3 ;
+4 SET CODE=$PIECE(HLNODE,HLFS,2)
+5 ;
+6 IF CODE="AE"!(CODE="AR")
Begin DoDot:1
+7 SET ERROR=ERROR_U_$PIECE(HLNODE,HLFS,4)_U_$GET(ERR)
+8 DO EM^XUMFX(ERROR,.ERR)
End DoDot:1
+9 ;
+10 QUIT
+11 ;
MFI ; -- MFI segment
+1 ;
+2 IF ERROR
QUIT
+3 IF EXIT
QUIT
+4 ;
+5 KILL IFN,ARRAY,MFI
+6 ;
+7 IF $PIECE(HLNODE,HLFS,2)=""
Begin DoDot:1
+8 SET ERROR="1^MFI segment missing Master File Identifier HLNODE: "_HLNODE
+9 DO EM^XUMFX(ERROR,.ERR)
End DoDot:1
QUIT
+10 ;
+11 SET MFI=$PIECE(HLNODE,HLFS,2)
SET IFN=MFI
+12 IF 'IFN
SET IFN=$ORDER(^DIC(4.001,"MFI",$PIECE(MFI,HLCS,2),0))
+13 SET IFN=$SELECT(IFN:IFN,MFI="ZMF":4.001,1:0)
+14 IF 'IFN
Begin DoDot:1
+15 SET ERROR="1^IFN in MFI could not be resolved HLNODE: "_HLNODE
+16 DO EM^XUMFX(ERROR,.ERR)
End DoDot:1
QUIT
+17 ;
+18 ;sds flag=1; 1H is history record (use alt key for owning record)
+19 SET XUMFSDS=$SELECT($PIECE(MFI,HLCS,3)="SDS":1,1:0)
+20 IF XUMFSDS
IF MFI["History"
SET XUMFSDS="1H"
+21 ;
+22 SET ARRAY=$SELECT($GET(ARRAY):1,$PIECE(HLNODE,HLFS,3)="TEMP":1,1:0)
+23 ;
+24 QUIT
+25 ;
MFE ; -- MFE segment
+1 ;
+2 IF ERROR
QUIT
+3 IF EXIT
QUIT
+4 ;
+5 KILL IEN
+6 ;
+7 NEW PRE,POST
+8 ;
+9 SET KEY=$PIECE(HLNODE,HLFS,5)
IF ARRAY
QUIT
+10 ;
+11 SET PRE=$PIECE($GET(^DIC(4.001,+IFN,"MFE")),U,16)
+12 IF PRE'=""
Begin DoDot:1
+13 SET PRE=PRE_"^XUMFXR"
+14 DO @(PRE)
End DoDot:1
IF $GET(EXIT)
QUIT
+15 ;
+16 DO MFE^XUMFX(IFN,KEY,HLCS,.IEN,.ERROR)
IF ERROR
QUIT
+17 ;
+18 SET POST=$PIECE($GET(^DIC(4.001,+IFN,"MFE")),U,17)
+19 IF POST'=""
Begin DoDot:1
+20 SET POST=POST_"^XUMFXR"
+21 DO @(POST)
End DoDot:1
IF $GET(EXIT)
QUIT
+22 ;
+23 IF 'IEN
Begin DoDot:1
+24 SET ERROR="1^IEN not resolved in MFE File #: "_IFN_" HLNODE: "_HLNODE
+25 DO EM^XUMFX(ERROR,.ERR)
+26 KILL ERR
End DoDot:1
QUIT
+27 ;
+28 ; clean multiple flag
+29 IF '$DATA(XIEN(IEN))
KILL XIEN
+30 SET XIEN(IEN)=$GET(XIEN(IEN))+1
+31 ;
+32 QUIT
+33 ;
RDF ; -- table row definition
+1 ;
+2 IF ERROR
QUIT
+3 IF EXIT
QUIT
+4 ;
+5 IF $GET(ARRAY)
DO ARRAY
QUIT
+6 ;
+7 NEW COL,X,Y,Z,DTYP,IDX,SEQ,VUID,DATA,NAME
+8 ;
+9 KILL ^TMP("XUMF MFS",$JOB,"PARAM","SEQ")
+10 KILL ^TMP("XUMF MFS",$JOB,"PARAM","MULT")
+11 KILL ^TMP("XUMF MFS",$JOB,"PARAM","IENS")
+12 ;
+13 KILL XXX,YYY
+14 ;
+15 DO SEGPRSE^XUMFXHL7("HLNODE","XXX")
+16 SET NUMBER=XXX(1)
+17 DO SEQPRSE^XUMFXHL7("XXX(2)","COL")
KILL XXX
+18 IF $ORDER(COL(99999),-1)'=NUMBER
Begin DoDot:1
+19 SET ERROR="1^RDF number of columns error"
+20 DO EM^XUMFX("RDF segment columns don't match number",.ERROR)
End DoDot:1
QUIT
+21 ;
+22 ;S NUMBER=$P(HLNODE,HLFS,2)
+23 ;S DATA=$P(HLNODE,HLFS,3)
+24 ;
+25 ;S CNT=0,Y=0
+26 ;F SEQ=1:1:NUMBER D
+27 ;.S Y=Y+1
+28 ;.S Z=$P(DATA,HLREP,Y)
+29 ;.I Y=$L(DATA,HLREP) D
+30 ;..S CNT=$O(HLNODE(CNT))
+31 ;..S DATA=$G(HLNODE(+CNT))
+32 ;..S Z=Z_$P(DATA,HLREP)
+33 ;..S Y=1
+34 ;.S COL(SEQ)=Z
+35 ;
+36 SET SEQ=0
+37 FOR
SET SEQ=$ORDER(COL(SEQ))
IF 'SEQ
QUIT
Begin DoDot:1
+38 SET NAME=COL(SEQ,1)
SET TYP=COL(SEQ,2)
IF NAME=""
QUIT
+39 ;S NAME=$P(COL(SEQ),HLCS) Q:NAME=""
+40 SET IDX=$ORDER(^DIC(4.001,+IFN,1,"B",NAME,0))
IF 'IDX
QUIT
+41 SET DATA=$GET(^DIC(4.001,+IFN,1,+IDX,0))
IF DATA=""
QUIT
+42 SET YYY(NAME,SEQ)=""
+43 ;
+44 ;N FLD,TYP,SUBFILE,LKUP,REPEAT,CLEAN,TIMEZONE
+45 ;S TYP=$P(DATA,U,3),TYP=$$GET1^DIQ(771.4,(+TYP_","),.01)
+46 NEW FLD,SUBFILE,LKUP,REPEAT,CLEAN,TIMEZONE
+47 SET FLD=$PIECE(DATA,U,2)
SET SUBFILE=$PIECE(DATA,U,4)
+48 SET LKUP=$PIECE(DATA,U,7)
SET TIMEZONE=$PIECE(DATA,U,14)
+49 SET REPEAT=$PIECE(DATA,U,11)
SET CLEAN=$PIECE(DATA,U,12)
SET VUID=$PIECE(DATA,U,13)
+50 SET ^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"VUID")=VUID
+51 ;
+52 IF 'SUBFILE
Begin DoDot:2
+53 SET ^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,FLD)=TYP_U_LKUP
End DoDot:2
QUIT
+54 ;
+55 ; -- multiple field
+56 ;
+57 ;.01 is a field
IF $PIECE(DATA,U,6)'=""
Begin DoDot:2
+58 SET XXX(SEQ)=$PIECE(DATA,U,6)
End DoDot:2
+59 ;
+60 SET ^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"FILE")=SUBFILE
+61 SET ^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"FIELD")=FLD
+62 SET ^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"DTYP")=TYP
+63 SET ^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"REPEAT")=REPEAT
+64 SET ^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"CLEAN")=CLEAN
+65 SET ^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"TIMEZONE")=TIMEZONE
End DoDot:1
+66 ;
+67 SET SEQ=0
+68 FOR
SET SEQ=$ORDER(XXX(SEQ))
IF 'SEQ
QUIT
Begin DoDot:1
+69 SET X=XXX(SEQ)
SET Y=$ORDER(YYY(X,0))
+70 SET ^TMP("XUMF MFS",$JOB,"PARAM","MULT",SEQ)=Y
End DoDot:1
+71 ;
+72 QUIT
+73 ;
RDT ; -- table row data
+1 ;
+2 IF ERROR
QUIT
+3 IF EXIT
QUIT
+4 ;
+5 KILL XXX
+6 DO SEGPRSE^XUMFXHL7("HLNODE","XXX")
+7 IF $ORDER(XXX(99999),-1)'=NUMBER
Begin DoDot:1
+8 SET ERROR="1^RDF/RDT number of columns error"
+9 DO EM^XUMFX("RDF/RDT segment columns don't match number",.ERROR)
End DoDot:1
QUIT
+10 ;
+11 IF $GET(ARRAY)
DO ARRAY
QUIT
+12 ;
+13 IF 'IEN
QUIT
+14 ;
+15 NEW FDA,IENS,FIELD,ERR,PRE,POST,MULT,FDA1,SEQ,VUID,TIMEZONE
+16 ;
+17 SET PRE=$PIECE($GET(^DIC(4.001,+IFN,0)),U,4)
+18 IF PRE'=""
Begin DoDot:1
+19 SET PRE=PRE_"^XUMFR"
+20 DO @(PRE)
End DoDot:1
+21 ;
+22 SET IENS=IEN_","
+23 SET SEQ=0
+24 FOR
SET SEQ=$ORDER(^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ))
IF 'SEQ
QUIT
Begin DoDot:1
+25 SET FIELD=$ORDER(^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,0))
+26 SET VUID=$GET(^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"VUID"))
+27 SET TIMEZONE=$GET(^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"TIMEZONE"))
+28 IF 'FIELD
DO SUBFILE
QUIT
+29 SET TYP=$GET(^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,FIELD))
+30 SET VALUE=$$VALUE()
+31 SET VALUE=$$DTYP^XUMFXP(VALUE,TYP,HLCS,0,TIMEZONE)
+32 SET VALUE=$$VAL^XUMFX(IFN,FIELD,VUID,VALUE,IENS)
IF VALUE="^"
QUIT
+33 SET FDA(IFN,IENS,FIELD)=VALUE
End DoDot:1
+34 ;
+35 MERGE FDA=FDA1
+36 ;
+37 IF $DATA(FDA)
DO FILE^DIE(,"FDA","ERR")
+38 IF $DATA(ERR)
Begin DoDot:1
+39 SET ERROR="1^updating error"
+40 DO EM^XUMFX("file DIE call error message in RDT",.ERR)
+41 KILL ERR
End DoDot:1
+42 ;
+43 SET POST=$PIECE($GET(^DIC(4.001,+IFN,0)),U,5)
+44 IF POST'=""
Begin DoDot:1
+45 SET POST=POST_"^XUMFR"
+46 DO @(POST)
End DoDot:1
+47 ;
+48 QUIT
+49 ;
SUBFILE ; -- process subfile record
+1 ;
+2 NEW IFN,IENS1,KEY1,FIELD,TYP,MKEY,ERR,REPEAT,CLEAN
+3 ;
+4 SET IFN=^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"FILE")
+5 SET FIELD=^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"FIELD")
+6 SET TYP=^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"DTYP")
+7 SET REPEAT=^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"REPEAT")
+8 SET CLEAN=^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"CLEAN")
+9 ;
+10 IF CLEAN
IF $GET(XIEN(IEN))'>1
Begin DoDot:1
+11 NEW ROOT,IDX
+12 SET ROOT=$$ROOT^DILFD(IFN,","_IENS,1)
+13 SET IDX=0
FOR
SET IDX=$ORDER(@ROOT@(IDX))
IF 'IDX
QUIT
Begin DoDot:2
+14 Begin DoDot:3
+15 NEW DA,DIK,DIC
SET DA(1)=+IENS
SET DA=IDX
SET DIK=$PIECE(ROOT,")")_","
DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+16 ;
+17 SET VALUE=$$VALUE()
+18 SET VALUE=$$DTYP^XUMFXP(VALUE,TYP,HLCS,0,TIMEZONE)
+19 ;
+20 SET MULT=$GET(^TMP("XUMF MFS",$JOB,"PARAM","MULT",SEQ))
+21 ;
+22 IF MULT=SEQ
IF VALUE=""
QUIT
Begin DoDot:1
+23 NEW FDA,IEN
+24 SET VALUE=$$VAL^XUMFX(IFN,FIELD,VUID,VALUE,"?+1,"_IENS)
IF VALUE="^"
QUIT
+25 SET FDA(IFN,"?+1,"_IENS,.01)=VALUE
+26 DO UPDATE^DIE(,"FDA","IEN","ERR")
+27 IF $DATA(ERR)
Begin DoDot:2
+28 SET ERROR="1^subfile update error SUBFILE#: "_IFN
+29 DO EM^XUMFX("update DIE call error message in SUBFILE",.ERR)
+30 KILL ERR
End DoDot:2
QUIT
+31 SET IENS1=IEN(1)_","_IENS
SET MULT(SEQ)=IENS1
End DoDot:1
+32 ;
+33 IF MULT
IF MULT'=SEQ
SET IENS1=$GET(MULT(+MULT))
IF IENS1=""
QUIT
+34 IF MULT'=SEQ
SET VALUE=$$VAL^XUMFX(IFN,FIELD,VUID,VALUE,"?+1,"_IENS)
IF VALUE="^"
QUIT
+35 IF $DATA(IENS1)
SET FDA1(IFN,IENS1,FIELD)=VALUE
+36 ;
+37 QUIT
+38 ;
VALUE() ; -- handle HL7 continuation nodes
+1 ;
+2 IF '$ORDER(HLNODE(0))
QUIT $PIECE(HLNODE,HLFS,SEQ+1)
+3 ;
+4 NEW COL
+5 ;
+6 DO SEGPRSE^XUMFXHL7("HLNODE","COL")
+7 ;
+8 QUIT COL(SEQ)
+9 ;
ARRAY ; -- query data stored in array (not filed)
+1 ;
+2 NEW X
SET X=KEY
SET X=$SELECT($PIECE(X,HLCS)'="":$PIECE(X,HLCS),1:$PIECE(X,HLCS,4))
IF X=""
QUIT
+3 ;
+4 MERGE ^TMP("XUMF ARRAY",$JOB,IFN,X)=HLNODE
+5 ;
+6 QUIT
+7 ;
EXIT ; -- cleanup, and quit
+1 ;
+2 ; post processing logic
+3 SET X=$GET(^DIC(4.001,+IFN,2))
IF X'=""
XECUTE X
+4 ;
+5 KILL ^TMP("DILIST",$JOB),^TMP("DIERR",$JOB),^TMP("HLS",$JOB),^TMP("HLA",$JOB)
+6 ;
+7 KILL ^TMP("XUMF MFS",$JOB),^TMP("XUMF ERROR",$JOB)
+8 ;
+9 QUIT
+10 ;
