XUMFH4 ;CIOFO-SF/RAM - FORUM IMF handler ;06/28/00
;;8.0;KERNEL;**217,218**;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
N HDT,KEY,MID,VALUE,XREF,PARAM,ROOT,SEG
N HLSCS,SFAC
;
D INIT,PROCESS,BG,REPLY,EXIT
;
Q
;
INIT ; -- initialize
;
K ^TMP("DILIST",$J),^TMP("DIERR",$J)
K ^TMP("HLS",$J),^TMP("HLA",$J)
;
S (ERROR,CNT,TYPE)=0
S HLFS=HL("FS"),HLCS=$E(HL("ECH")),HLSCS=$E(HL("ECH"),4)
;
Q
;
PROCESS ; -- pull message text
;
F X HLNEXT Q:HLQUIT'>0 D
.Q:$P(HLNODE,HLFS)=""
.D @($P(HLNODE,HLFS))
;
Q
;
MSH ; -- MSH segment
;
S SFAC=$P(HLNODE,HLFS,4)
;
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("MSA segement error/reject message")
;
Q
;
MFI ; -- MFI segment
;
Q:ERROR
Q:$G(IFN)
;
I $P(HLNODE,HLFS,2)="" D Q
.S ERROR="1^MFI segment missing Master File Identifier"
.D EM(ERROR,.ERR)
.S ERROR=ERROR_U_$G(ERR)
S IFN=$$MFI^XUMFP($P(HLNODE,HLFS,2))
I 'IFN D Q
.S ERROR="1^IFN in MFI could not be resolved"
.D EM(ERROR,.ERR)
.S ERROR=ERROR_U_$G(ERR)
;
Q
;
MFE ; -- MFE segment
;
Q:ERROR
Q:$G(IEN)
;
S KEY=$P(HLNODE,HLFS,5)
;
I $E(KEY,1,3)'=$E(SFAC,1,3) D Q
.S ERROR="1^sending facility not authorized to edit this entry"
.D EM(ERROR)
;
S XREF=$P(KEY,HLCS,3)
S:KEY'="" IEN=$$FIND1^DIC(IFN,,"BX",$P(KEY,HLCS),XREF,,"ERR")
S IEN=$S(IEN:IEN,$G(ERR)'="":"ERROR",1:"NEW")
I IEN="ERROR" D Q
.S ERROR="1^MFE segment couldn't resolve IEN"
.D EM(ERROR,.ERR)
.K ERR
D MAIN^XUMFP(IFN,IEN,TYPE,.PARAM,.ERROR)
;
Q
;
ZIN ; -- VHA Institution segment
ZFT ; -- VHA Facility Type
ZZZ ; -- get [Z...] segment(s)
;
Q:ERROR
;
N FDA,IENS,FIELD,ERR,PRE,POST,XUMF,MULT,FDA1,SEQ,SEQ1,SEQ2,SEQ3
;
S PRE=$G(^TMP("XUMF MFS",$J,"PARAM","PRE"))
D:PRE'="" @(PRE)
;
S XUMF=1
;
S SEG=$P(HLNODE,HLFS)
S IENS=$S(IEN:IEN,1:"+1")_","
S SEQ=0
F S SEQ=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ)) Q:'SEQ D
.S SEQ1=$P(SEQ,"."),SEQ2=$P(SEQ,".",2)
.S SEQ3=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",0))
.I SEQ3 D SUBCOMP Q
.S FIELD=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,0))
.I FIELD=".01" D
..N FDA,IEN1
..S TYP=$G(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,FIELD))
..S VALUE=$$VALUE^XUMFH(.HLNODE,SEQ)
..S:SEQ2 VALUE=$P(VALUE,HLCS,SEQ2)
..S VALUE=$$DTYP^XUMFP(VALUE,TYP,$S(SEQ2:HLSCS,1:HLCS),0)
..S FDA(IFN,IENS,FIELD)=VALUE
..D UPDATE^DIE("E","FDA","IEN1","ERR")
..I $D(ERR) D
...D EM("update DIE call error message in ZZZ",.ERR)
...K ERR
..I $D(IEN1) S IENS=IEN1(1)_","
.I 'FIELD D SUBFILE Q
.S TYP=$G(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,FIELD))
.S VALUE=$$VALUE^XUMFH(.HLNODE,SEQ)
.S:SEQ2 VALUE=$P(VALUE,HLCS,SEQ2)
.S VALUE=$$DTYP^XUMFP(VALUE,TYP,$S(SEQ2:HLSCS,1:HLCS),0)
.S FDA(IFN,IENS,FIELD)=VALUE
;
M FDA=FDA1
K FDA1
;
D FILE^DIE("E","FDA","ERR")
I $D(ERR) D
.D EM("file DIE call error message in ZZZ",.ERR)
.K ERR
;
S POST=$G(^TMP("XUMF MFS",$J,"PARAM","POST"))
D:POST'="" @(POST)
;
Q
;
SUBFILE ; -- process subfile record
;
N IFN,IENS1,KEY1,FIELD,TYP,MKEY,ERR
;
S IFN=^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"FILE")
S FIELD=^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"FIELD")
S TYP=^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"DTYP")
S VALUE=$$VALUE^XUMFH(.HLNODE,SEQ)
S:SEQ2 VALUE=$P(VALUE,HLCS,SEQ2)
S VALUE=$$DTYP^XUMFP(VALUE,TYP,$S(SEQ2:HLSCS,1:HLCS),0)
;
S MULT=$G(^TMP("XUMF MFS",$J,"PARAM","MULT","ZIN",SEQ))
S MKEY=$G(^TMP("XUMF MFS",$J,"PARAM","MKEY","ZIN",SEQ))
I MULT=SEQ Q:VALUE="" D
.N FDA,IEN
.S FDA(IFN,"?+1,"_IENS,.01)=VALUE
.D UPDATE^DIE("E","FDA","IEN","ERR")
.I $D(ERR) D
..D EM("update DIE call error message in SUBFILE",.ERR)
..K ERR
.S IENS1=IEN(1)_","_IENS,MULT(SEQ)=IENS1
I 'MULT D
.N FDA,IEN
.S FDA(IFN,"?+1,"_IENS,.01)=MKEY
.D UPDATE^DIE("E","FDA","IEN","ERR")
.I $D(ERR) D
..D EM("update DIE call error message in SUBFILE",.ERR)
..K ERR
.S IENS1=IEN(1)_","_IENS,MULT(SEQ)=IENS1
.S FDA1(IFN,IENS1,.01)=MKEY
I MULT,MULT'=SEQ S IENS1=$G(MULT(+MULT)) Q:IENS1=""
S FDA1(IFN,IENS1,FIELD)=VALUE
;
Q
;
SUBCOMP ; -- subcomponents
;
S SEQ3=0
F S SEQ3=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",SEQ3)) Q:'SEQ3 D
.S FIELD=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",SEQ3,0))
.S TYP=$G(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",SEQ3,FIELD))
.S VALUE=$$VALUE^XUMFH(.HLNODE,SEQ)
.S VALUE=$P(VALUE,HLCS,SEQ2)
.S VALUE=$P(VALUE,HLSCS,SEQ3)
.S VALUE=$$DTYP^XUMFP(VALUE,TYP,HLSCS,0)
.S FDA(IFN,IENS,FIELD)=VALUE
;
Q
;
BG ; -- background job
;
Q:ERROR
Q:HL("MTN")'="MFN"
;
N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE
;
S ZTRTN="BRDCST^XUMFH4"
S ZTDESC="XUMF Broadcast IMF address changes"
S ZTDTH=$$NOW^XLFDT
S ZTSAVE("IEN")=""
S ZTIO=""
;
D ^%ZTLOAD
;
Q
;
BRDCST ; -- broadcast update
;
N PARAM
;
K ^TMP("HLS",$J),^TMP("HLA",$J),^TMP("XUMF MFS",$J),PARAM
;
S PARAM("PROTOCOL")=$O(^ORD(101,"B","XUMF MFN",0))
S PARAM("BROADCAST")=1
D MAIN^XUMFP(4,IEN,0,.PARAM,.ERROR) Q:ERROR
D MAIN^XUMFI(4,IEN,0,.PARAM,.ERROR)
;
S ZTREQ="@"
;
Q
;
REPLY ; -- master file response
;
Q:HL("MTN")="MFK"
;
S:(TYPE<10) TYPE=(TYPE+10)
;
S IFN=$G(IFN),IEN=$G(IEN)
;
D MAIN^XUMFP(IFN,IEN,TYPE,.PARAM,.ERROR)
D MAIN^XUMFI(IFN,IEN,TYPE,.PARAM,.ERROR)
;
Q
;
EXIT ; -- cleanup, and quit
;
K ^TMP("DILIST",$J),^TMP("DIERR",$J),^TMP("HLS",$J),^TMP("HLA",$J)
;
Q
;
EM(ERROR,ERR) ; -- error message
;
N X,XMSUB,XMY,XMTEXT,FLG
;
S FLG=0
;
D MSG^DIALOG("AM",.X,80,,"ERR")
;
S X(.1)="HL7 message ID: "_$G(HL("MID"))
S X(.2)="",X(.3)=$G(ERROR),X(.4)=""
S XMSUB="IMF HANDLER ERROR MESSAGE"
S XMY="G.XUMF INSTITUTION"
S XMTEXT="X("
;
S X=.9 F S X=$O(X(X)) Q:'X D
.I X(X)="" K X(X) Q
.I X(X)["DINUMed field cannot" S FLG=1 K X(X) Q
;
I FLG Q:'$O(X(.9))
;
D ^XMD
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMFH4 6215 printed Dec 13, 2024@02:10:46 Page 2
XUMFH4 ;CIOFO-SF/RAM - FORUM IMF handler ;06/28/00
+1 ;;8.0;KERNEL;**217,218**;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
+3 NEW HDT,KEY,MID,VALUE,XREF,PARAM,ROOT,SEG
+4 NEW HLSCS,SFAC
+5 ;
+6 DO INIT
DO PROCESS
DO BG
DO REPLY
DO EXIT
+7 ;
+8 QUIT
+9 ;
INIT ; -- initialize
+1 ;
+2 KILL ^TMP("DILIST",$JOB),^TMP("DIERR",$JOB)
+3 KILL ^TMP("HLS",$JOB),^TMP("HLA",$JOB)
+4 ;
+5 SET (ERROR,CNT,TYPE)=0
+6 SET HLFS=HL("FS")
SET HLCS=$EXTRACT(HL("ECH"))
SET HLSCS=$EXTRACT(HL("ECH"),4)
+7 ;
+8 QUIT
+9 ;
PROCESS ; -- pull message text
+1 ;
+2 FOR
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+3 if $PIECE(HLNODE,HLFS)=""
QUIT
+4 DO @($PIECE(HLNODE,HLFS))
End DoDot:1
+5 ;
+6 QUIT
+7 ;
MSH ; -- MSH segment
+1 ;
+2 SET SFAC=$PIECE(HLNODE,HLFS,4)
+3 ;
+4 QUIT
+5 ;
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("MSA segement error/reject message")
End DoDot:1
+9 ;
+10 QUIT
+11 ;
MFI ; -- MFI segment
+1 ;
+2 if ERROR
QUIT
+3 if $GET(IFN)
QUIT
+4 ;
+5 IF $PIECE(HLNODE,HLFS,2)=""
Begin DoDot:1
+6 SET ERROR="1^MFI segment missing Master File Identifier"
+7 DO EM(ERROR,.ERR)
+8 SET ERROR=ERROR_U_$GET(ERR)
End DoDot:1
QUIT
+9 SET IFN=$$MFI^XUMFP($PIECE(HLNODE,HLFS,2))
+10 IF 'IFN
Begin DoDot:1
+11 SET ERROR="1^IFN in MFI could not be resolved"
+12 DO EM(ERROR,.ERR)
+13 SET ERROR=ERROR_U_$GET(ERR)
End DoDot:1
QUIT
+14 ;
+15 QUIT
+16 ;
MFE ; -- MFE segment
+1 ;
+2 if ERROR
QUIT
+3 if $GET(IEN)
QUIT
+4 ;
+5 SET KEY=$PIECE(HLNODE,HLFS,5)
+6 ;
+7 IF $EXTRACT(KEY,1,3)'=$EXTRACT(SFAC,1,3)
Begin DoDot:1
+8 SET ERROR="1^sending facility not authorized to edit this entry"
+9 DO EM(ERROR)
End DoDot:1
QUIT
+10 ;
+11 SET XREF=$PIECE(KEY,HLCS,3)
+12 if KEY'=""
SET IEN=$$FIND1^DIC(IFN,,"BX",$PIECE(KEY,HLCS),XREF,,"ERR")
+13 SET IEN=$SELECT(IEN:IEN,$GET(ERR)'="":"ERROR",1:"NEW")
+14 IF IEN="ERROR"
Begin DoDot:1
+15 SET ERROR="1^MFE segment couldn't resolve IEN"
+16 DO EM(ERROR,.ERR)
+17 KILL ERR
End DoDot:1
QUIT
+18 DO MAIN^XUMFP(IFN,IEN,TYPE,.PARAM,.ERROR)
+19 ;
+20 QUIT
+21 ;
ZIN ; -- VHA Institution segment
ZFT ; -- VHA Facility Type
ZZZ ; -- get [Z...] segment(s)
+1 ;
+2 if ERROR
QUIT
+3 ;
+4 NEW FDA,IENS,FIELD,ERR,PRE,POST,XUMF,MULT,FDA1,SEQ,SEQ1,SEQ2,SEQ3
+5 ;
+6 SET PRE=$GET(^TMP("XUMF MFS",$JOB,"PARAM","PRE"))
+7 if PRE'=""
DO @(PRE)
+8 ;
+9 SET XUMF=1
+10 ;
+11 SET SEG=$PIECE(HLNODE,HLFS)
+12 SET IENS=$SELECT(IEN:IEN,1:"+1")_","
+13 SET SEQ=0
+14 FOR
SET SEQ=$ORDER(^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+15 SET SEQ1=$PIECE(SEQ,".")
SET SEQ2=$PIECE(SEQ,".",2)
+16 SET SEQ3=$ORDER(^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",0))
+17 IF SEQ3
DO SUBCOMP
QUIT
+18 SET FIELD=$ORDER(^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ,0))
+19 IF FIELD=".01"
Begin DoDot:2
+20 NEW FDA,IEN1
+21 SET TYP=$GET(^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ,FIELD))
+22 SET VALUE=$$VALUE^XUMFH(.HLNODE,SEQ)
+23 if SEQ2
SET VALUE=$PIECE(VALUE,HLCS,SEQ2)
+24 SET VALUE=$$DTYP^XUMFP(VALUE,TYP,$SELECT(SEQ2:HLSCS,1:HLCS),0)
+25 SET FDA(IFN,IENS,FIELD)=VALUE
+26 DO UPDATE^DIE("E","FDA","IEN1","ERR")
+27 IF $DATA(ERR)
Begin DoDot:3
+28 DO EM("update DIE call error message in ZZZ",.ERR)
+29 KILL ERR
End DoDot:3
+30 IF $DATA(IEN1)
SET IENS=IEN1(1)_","
End DoDot:2
+31 IF 'FIELD
DO SUBFILE
QUIT
+32 SET TYP=$GET(^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ,FIELD))
+33 SET VALUE=$$VALUE^XUMFH(.HLNODE,SEQ)
+34 if SEQ2
SET VALUE=$PIECE(VALUE,HLCS,SEQ2)
+35 SET VALUE=$$DTYP^XUMFP(VALUE,TYP,$SELECT(SEQ2:HLSCS,1:HLCS),0)
+36 SET FDA(IFN,IENS,FIELD)=VALUE
End DoDot:1
+37 ;
+38 MERGE FDA=FDA1
+39 KILL FDA1
+40 ;
+41 DO FILE^DIE("E","FDA","ERR")
+42 IF $DATA(ERR)
Begin DoDot:1
+43 DO EM("file DIE call error message in ZZZ",.ERR)
+44 KILL ERR
End DoDot:1
+45 ;
+46 SET POST=$GET(^TMP("XUMF MFS",$JOB,"PARAM","POST"))
+47 if POST'=""
DO @(POST)
+48 ;
+49 QUIT
+50 ;
SUBFILE ; -- process subfile record
+1 ;
+2 NEW IFN,IENS1,KEY1,FIELD,TYP,MKEY,ERR
+3 ;
+4 SET IFN=^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ,"FILE")
+5 SET FIELD=^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ,"FIELD")
+6 SET TYP=^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ,"DTYP")
+7 SET VALUE=$$VALUE^XUMFH(.HLNODE,SEQ)
+8 if SEQ2
SET VALUE=$PIECE(VALUE,HLCS,SEQ2)
+9 SET VALUE=$$DTYP^XUMFP(VALUE,TYP,$SELECT(SEQ2:HLSCS,1:HLCS),0)
+10 ;
+11 SET MULT=$GET(^TMP("XUMF MFS",$JOB,"PARAM","MULT","ZIN",SEQ))
+12 SET MKEY=$GET(^TMP("XUMF MFS",$JOB,"PARAM","MKEY","ZIN",SEQ))
+13 IF MULT=SEQ
if VALUE=""
QUIT
Begin DoDot:1
+14 NEW FDA,IEN
+15 SET FDA(IFN,"?+1,"_IENS,.01)=VALUE
+16 DO UPDATE^DIE("E","FDA","IEN","ERR")
+17 IF $DATA(ERR)
Begin DoDot:2
+18 DO EM("update DIE call error message in SUBFILE",.ERR)
+19 KILL ERR
End DoDot:2
+20 SET IENS1=IEN(1)_","_IENS
SET MULT(SEQ)=IENS1
End DoDot:1
+21 IF 'MULT
Begin DoDot:1
+22 NEW FDA,IEN
+23 SET FDA(IFN,"?+1,"_IENS,.01)=MKEY
+24 DO UPDATE^DIE("E","FDA","IEN","ERR")
+25 IF $DATA(ERR)
Begin DoDot:2
+26 DO EM("update DIE call error message in SUBFILE",.ERR)
+27 KILL ERR
End DoDot:2
+28 SET IENS1=IEN(1)_","_IENS
SET MULT(SEQ)=IENS1
+29 SET FDA1(IFN,IENS1,.01)=MKEY
End DoDot:1
+30 IF MULT
IF MULT'=SEQ
SET IENS1=$GET(MULT(+MULT))
if IENS1=""
QUIT
+31 SET FDA1(IFN,IENS1,FIELD)=VALUE
+32 ;
+33 QUIT
+34 ;
SUBCOMP ; -- subcomponents
+1 ;
+2 SET SEQ3=0
+3 FOR
SET SEQ3=$ORDER(^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",SEQ3))
if 'SEQ3
QUIT
Begin DoDot:1
+4 SET FIELD=$ORDER(^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",SEQ3,0))
+5 SET TYP=$GET(^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",SEQ3,FIELD))
+6 SET VALUE=$$VALUE^XUMFH(.HLNODE,SEQ)
+7 SET VALUE=$PIECE(VALUE,HLCS,SEQ2)
+8 SET VALUE=$PIECE(VALUE,HLSCS,SEQ3)
+9 SET VALUE=$$DTYP^XUMFP(VALUE,TYP,HLSCS,0)
+10 SET FDA(IFN,IENS,FIELD)=VALUE
End DoDot:1
+11 ;
+12 QUIT
+13 ;
BG ; -- background job
+1 ;
+2 if ERROR
QUIT
+3 if HL("MTN")'="MFN"
QUIT
+4 ;
+5 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE
+6 ;
+7 SET ZTRTN="BRDCST^XUMFH4"
+8 SET ZTDESC="XUMF Broadcast IMF address changes"
+9 SET ZTDTH=$$NOW^XLFDT
+10 SET ZTSAVE("IEN")=""
+11 SET ZTIO=""
+12 ;
+13 DO ^%ZTLOAD
+14 ;
+15 QUIT
+16 ;
BRDCST ; -- broadcast update
+1 ;
+2 NEW PARAM
+3 ;
+4 KILL ^TMP("HLS",$JOB),^TMP("HLA",$JOB),^TMP("XUMF MFS",$JOB),PARAM
+5 ;
+6 SET PARAM("PROTOCOL")=$ORDER(^ORD(101,"B","XUMF MFN",0))
+7 SET PARAM("BROADCAST")=1
+8 DO MAIN^XUMFP(4,IEN,0,.PARAM,.ERROR)
if ERROR
QUIT
+9 DO MAIN^XUMFI(4,IEN,0,.PARAM,.ERROR)
+10 ;
+11 SET ZTREQ="@"
+12 ;
+13 QUIT
+14 ;
REPLY ; -- master file response
+1 ;
+2 if HL("MTN")="MFK"
QUIT
+3 ;
+4 if (TYPE<10)
SET TYPE=(TYPE+10)
+5 ;
+6 SET IFN=$GET(IFN)
SET IEN=$GET(IEN)
+7 ;
+8 DO MAIN^XUMFP(IFN,IEN,TYPE,.PARAM,.ERROR)
+9 DO MAIN^XUMFI(IFN,IEN,TYPE,.PARAM,.ERROR)
+10 ;
+11 QUIT
+12 ;
EXIT ; -- cleanup, and quit
+1 ;
+2 KILL ^TMP("DILIST",$JOB),^TMP("DIERR",$JOB),^TMP("HLS",$JOB),^TMP("HLA",$JOB)
+3 ;
+4 QUIT
+5 ;
EM(ERROR,ERR) ; -- error message
+1 ;
+2 NEW X,XMSUB,XMY,XMTEXT,FLG
+3 ;
+4 SET FLG=0
+5 ;
+6 DO MSG^DIALOG("AM",.X,80,,"ERR")
+7 ;
+8 SET X(.1)="HL7 message ID: "_$GET(HL("MID"))
+9 SET X(.2)=""
SET X(.3)=$GET(ERROR)
SET X(.4)=""
+10 SET XMSUB="IMF HANDLER ERROR MESSAGE"
+11 SET XMY="G.XUMF INSTITUTION"
+12 SET XMTEXT="X("
+13 ;
+14 SET X=.9
FOR
SET X=$ORDER(X(X))
if 'X
QUIT
Begin DoDot:1
+15 IF X(X)=""
KILL X(X)
QUIT
+16 IF X(X)["DINUMed field cannot"
SET FLG=1
KILL X(X)
QUIT
End DoDot:1
+17 ;
+18 IF FLG
if '$ORDER(X(.9))
QUIT
+19 ;
+20 DO ^XMD
+21 ;
+22 QUIT
+23 ;
