Routine: XUMFH4

XUMFH4 ;CIOFO-SF/RAM - FORUM IMF handler ;06/28/00 [ 07/29/2004   9:01 AM ]

 ;;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

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)

PROCESS ; -- pull message text

 F  X HLNEXT Q:HLQUIT'>0  D

 .Q:$P(HLNODE,HLFS)=""

 .D @($P(HLNODE,HLFS))

MSH ; -- MSH segment

 S SFAC=$P(HLNODE,HLFS,4)

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")

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)

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)

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)

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

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

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

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="@"

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)

EXIT ; -- cleanup, and quit

 K ^TMP("DILIST",$J),^TMP("DIERR",$J),^TMP("HLS",$J),^TMP("HLA",$J)

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

XUMFH4    ;CIOFO-SF/RAM - FORUM IMF handler ;06/28/00 [ 07/29/2004   9:01 AM ]

 +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      ;

XUMFH4.m