XUMF1H.m

XUMF1H ;ISS/RAM - MFS Handler ;6/27/06  07:50

 ;;8.0;KERNEL;**407,474**;Jul 10, 1995;Build 12

 ;Per VHA Directive 10-92-142, this routine should not be modified

 ;

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

 N XUMFSDS,FDA,LIST,ERRCNT,PKV,MKEY,MKEY1,TYP,MFI,IMPLY,RECORD,OUT

 ;

 D INIT,PROCESS,REPLY,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)

 K ^TMP("XUMF EVENT",$J)

 ;

 S XUMF=1,DUZ(0)="@"

 ;

 S (ERROR,CNT,TYPE,ARRAY,EXIT,ERRCNT)=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^ZRT^"'[(U_$P(HLNODE,HLFS)_U)

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

 I $D(LIST) D LIST

 I $D(FDA) D UPDATE

 I $D(RECORD) D RECORD

 I $D(IFN) D EVT^XUMF0,POST

 ;

 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

 ;

 Q

 ;

MFE ; -- MFE SEGMENT

 ;

 Q:ERROR

 Q:EXIT

 ;

 S PKV=$P(HLNODE,HLFS,5),MFI=$P(PKV,"@")

 ;

 I $D(LIST) D LIST K LIST,LISTVUID

 I $D(FDA) D UPDATE K FDA

 I $D(RECORD) D RECORD

 I $D(IFN),(IFN'=$O(^DIC(4.001,"MFID",MFI,0))) D POST

 ;

 K IFN,IEN,PRE,POST,VUID,IMPLY,RECORD

 K ^TMP("XUMF IMPLIED LOGIC",$J)

 ;

 I MFI="" S ERROR="1^MFI not resolved HLNODE: "_HLNODE Q

 S IFN=$O(^DIC(4.001,"MFID",MFI,0))

 I 'IFN S ERROR="1^IFN not resolved HLNODE: "_HLNODE Q

 ;

 S VUID=$P($P(PKV,"@",2),HLCS)

 ;

 Q:ARRAY

 ;

 ;MFE processing

 D MFE0 Q:ERROR

 ;

 D:'$G(IEN) MFE^XUMF0(IFN,VUID,.IEN,.ERROR) Q:ERROR

 ;

 ;D MFE0

 ;

 ;Implied logic flag - must be set by MFE-Processing Logic field (#4)

 S IMPLY=+$G(^TMP("XUMF IMPLIED LOGIC",$J))

 S IMPLY("KILL")=0

 K ^TMP("XUMF IMPLIED LOGIC",$J)

 ;

 I IEN D

 .; clean multiple flag

 .K:'$D(XIEN(IFN,IEN)) XIEN

 .S XIEN(IFN,IEN)=$G(XIEN(IFN,IEN))+1

 .;

 .N ROOT

 .S ROOT=$$ROOT^DILFD(IFN,,1)

 .M RECORD("BEFORE")=@ROOT@(IEN)

 .S RECORD("STATUS")=$$GETSTAT^XTID(IFN,,IEN_",")

 .;

 .S ^TMP("XUMF EVENT",$J,IFN,"BEFORE",IEN,"REPLACED BY")=$P($G(@ROOT@(IEN,"VUID")),U,3)

 .S ^TMP("XUMF EVENT",$J,IFN,"BEFORE",IEN,"INHERITS FROM")=$$RPLCMNT^XTIDTRM(IFN,IEN)

 ;

 Q

 ;

ZRT ; -- data segments

 ;

 Q:ERROR

 Q:EXIT

 ;

 I $G(ARRAY) D ARRAY Q

 ;

 N COL,X,Y,Z,DTYP,IDX,SEQ,DATA,NAME,VUID1,LIST1

 N FIELD,SUBFILE,LKUP,REPEAT,CLEAN,TIMEZONE,WP

 ;

 S NAME=$P(HLNODE,HLFS,2)

 ;

 D ZRT0 Q:ERROR  I $G(OUT) K OUT Q

 ;

 I 'IEN,NAME="Term" D STUB^XUMF0 Q

 I 'IEN S ERROR="1^IEN not defined IFN: "_IFN_" VUID: "_VUID Q

 ;

 ;D ZRT0 Q:ERROR

 ;

 S IENS=IEN_","

 ;

 S IDX=$O(^DIC(4.001,+IFN,1,"B",NAME,0))

 I 'IDX S ERROR="1^parameter "_NAME_" not defined IFN: "_IFN Q

 S DATA=$G(^DIC(4.001,+IFN,1,+IDX,0))

 S TYP=$P(DATA,U,3),TYP=$$GET1^DIQ(771.4,(+TYP_","),.01)

 S FIELD=$P(DATA,U,2),SUBFILE=$P(DATA,U,4),MKEY=$P(DATA,U,6)

 S LKUP=$P(DATA,U,7),TIMEZONE=$P(DATA,U,14),LIST1=$P(DATA,U,8)

 S REPEAT=$P(DATA,U,11),CLEAN=$P(DATA,U,12),VUID1=$P(DATA,U,13)

 S WP=$P(DATA,U,16)

 ;

 I WP D WP Q

 ;

 S VALUE=$$UNESC^XUMF0($P(HLNODE,HLFS,3),.HL)

 S VALUE=$$DTYP^XUMFXP(VALUE,TYP,HLCS,0,TIMEZONE)

 ;

 I NAME="Status" D STATUS Q

 ;

 I 'SUBFILE D  Q

 .S VALUE=$$VAL^XUMF0(IFN,FIELD,VUID1,VALUE,IENS) Q:VALUE="^"

 .S FDA(IFN,IENS,FIELD)=VALUE

 ;

 N IENS1

 ;

 I LIST1 D  Q

 .S VALUE=$$VAL^XUMF0(SUBFILE,FIELD,VUID1,VALUE,"?+1,"_IENS) Q:VALUE="^"

 .I MKEY=NAME S ZKEY=VALUE ;S:VUID1'="" LISTVUID(SUBFILE)=1

 .I '$D(ZKEY) S ERROR="1^ZKEY error "_SUBFILE_" VUID: "_VUID Q

 .I ((ZKEY="")!(ZKEY=$C(34,34))) S LIST(SUBFILE)="" Q

 .S LIST(SUBFILE,ZKEY,FIELD)=VALUE

 .I IMPLY D IMPLY

 ;

 I CLEAN,$G(XIEN(IFN,IEN))'>1 D

 .N ROOT,IDX

 .S ROOT=$$ROOT^DILFD(SUBFILE,","_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

 ;

 I MKEY=NAME Q:VALUE=""  D

 .N FDA,IEN

 .;

 .S VALUE=$$VAL^XUMF0(SUBFILE,FIELD,VUID1,VALUE,"?+1,"_IENS) Q:VALUE="^"

 .S FDA(SUBFILE,"?+1,"_IENS,.01)=VALUE

 .D UPDATE^DIE(,"FDA","IEN","ERR")

 .I $D(ERR) D  Q

 ..S ERROR="1^subfile update error SUBFILE#: "_SUBFILE

 ..D EM(ERROR,.ERR) K ERR

 .S IENS1=IEN(1)_","_IENS,MKEY(NAME)=IENS1

 ;

 I MKEY'="",MKEY'=NAME S IENS1=$G(MKEY(MKEY)) Q:IENS1=""

 S:MKEY'=NAME VALUE=$$VAL^XUMF0(SUBFILE,FIELD,VUID1,VALUE,"?+1,"_IENS) Q:VALUE="^"

 S:$D(IENS1) FDA(SUBFILE,IENS1,FIELD)=VALUE

 I IMPLY D IMPLY

 ;

 Q

 ;

IMPLY ; -- Implied value logic

 N PREV,ARR

 S ARR=$S(LIST1:"LIST",1:"FDA")

 S PREV=$S(LIST1:ZKEY,1:IENS1)

 I MKEY=NAME D  Q

 .I IMPLY("KILL") K IMPLY("PREV") S IMPLY("KILL")=0

 .S IMPLY("PREV",PREV)=""

 S PREV="" F  S PREV=$O(IMPLY("PREV",PREV)) Q:PREV=""  D

 .S @ARR@(SUBFILE,PREV,FIELD)=VALUE

 S IMPLY("KILL")=1

 Q

 ;

LIST ; -- process list

 ;

 N SUBFILE,ZKEY,FIELD,VALUE,IENS,CNT

 ;

 S IENS=IEN_","

 ;

 ;remove non-standard sub-records (not in message)

 S SUBFILE=0

 F  S SUBFILE=$O(LIST(SUBFILE)) Q:'SUBFILE  D

 .N ROOT,IDX

 .S ROOT=$$ROOT^DILFD(SUBFILE,","_IENS,1)

 .S IDX=0 F  S IDX=$O(@ROOT@(IDX)) Q:'IDX  D

 ..S VALUE=$$GET1^DIQ(SUBFILE,IDX_","_IENS,.01,"I")

 ..I '$D(LIST(SUBFILE,VALUE)) D

 ...N DA,DIK,DIC S DA(1)=+IENS,DA=IDX,DIK=$P(ROOT,")")_"," D ^DIK

 ;

 ;update sub-records

 S SUBFILE=0

 F  S SUBFILE=$O(LIST(SUBFILE)) Q:'SUBFILE  D

 .S ZKEY="",CNT=0

 .F  S ZKEY=$O(LIST(SUBFILE,ZKEY)) Q:ZKEY=""  D

 ..N IDX,ROOT

 ..S ROOT=$$ROOT^DILFD(SUBFILE,","_IENS,1)

 ..S IDX=$O(@ROOT@("B",ZKEY,0))

 ..I $O(@ROOT@("B",ZKEY,IDX)) D DELLIST(IDX)

 ..I 'IDX D ADDLIST Q

 ..S FIELD=0

 ..F  S FIELD=$O(LIST(SUBFILE,ZKEY,FIELD)) Q:'FIELD  D

 ...N X S X=$$GET1^DIQ(SUBFILE,IDX_","_IENS,FIELD)

 ...S VALUE=LIST(SUBFILE,ZKEY,FIELD)

 ...Q:VALUE=X  Q:(VALUE=""""&X="")

 ...S FDA(SUBFILE,IDX_","_IENS,FIELD)=VALUE

 ;

 Q

 ;

ADDLIST ; -- add new sub-record

 ;

 N FDA

 ;

 S CNT=$G(CNT)+1

 S FIELD=0

 F  S FIELD=$O(LIST(SUBFILE,ZKEY,FIELD)) Q:'FIELD  D

 .S VALUE=LIST(SUBFILE,ZKEY,FIELD) Q:VALUE=""

 .S FDA(SUBFILE,"+"_CNT_","_IENS,FIELD)=VALUE

 ;

 Q:'$D(FDA)

 ;

 D UPDATE^DIE(,"FDA",,"ERR")

 I $D(ERR) D  Q

 .S ERROR="1^subfile update error SUBFILE#: "_SUBFILE

 .D EM(ERROR,.ERR) K ERR

 ;

 Q

 ;

DELLIST(IDX) ; -- delete duplicate

 ;

 F  S IDX=$O(@ROOT@("B",ZKEY,IDX)) Q:'IDX  D

 .N DA,DIK,DIC S DA(1)=+IENS,DA=IDX,DIK=$P(ROOT,")")_"," D ^DIK

 ;

 Q

 ;

UPDATE ; -- FileMan update

 ;

 Q:ERROR

 Q:EXIT

 ;

 D:$D(FDA) FILE^DIE(,"FDA","ERR")

 I $D(ERR) D

 .S ERROR="1^updating error"

 .D EM(ERROR,.ERR) K ERR

 ;

 Q

 ;

ARRAY ; -- query data stored in array (not filed)

 ;

 S ^TMP("XUMF ARRAY",$J,IFN,VUID,$P(HLNODE,HLFS,2))=$P(HLNODE,HLFS,3)

 ;

 Q

 ;

ADD ; -- ADD-processing logic

 ;

 N X

 ;

 S X=$G(^DIC(4.001,+IFN,3)) X:X'="" X

 ;

 Q

 ;

MFE0 ; -- MFE-processing logic

 ;if creating a new entry you must set IEN and other tasks performed in STUB^XUMF0 (if appropriate)

 ;

 N X

 ;

 S X=$G(^DIC(4.001,+IFN,4)) X:X'="" X

 ;

 Q

 ;

ZRT0 ; -- ZRT-processing logic

 ;

 N X

 ;

 S X=$G(^DIC(4.001,+IFN,5)) X:X'="" X

 ;

 Q

 ;

POST ; -- post-processing logic

 ;

 N X

 ;

 S X=$G(^DIC(4.001,+IFN,2)) X:X'="" X

 ;

 Q

 ;

EXIT ; -- cleanup, and quit

 ;

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

 ;

 K ^TMP("XUMF MFS",$J),^TMP("XUMF ERROR",$J),^TMP("XUMF EVENT",$J)

 ;

 Q

 ;

REPLY ; -- MFK

 ;

 N X,I,I1,I2,CNT

 ;

 S CNT=1

 S X="MSA"_HLFS_$S(ERROR:"AE",1:"AA")_HLFS_HL("MID")_HLFS_$P(ERROR,U,2)

 S ^TMP("HLA",$J,CNT)=X

 S CNT=CNT+1

 ;

 S I1="",I=0

 F  S I1=$O(^TMP("XUMF ERROR",$J,I1)) Q:'$L(I1)  D

 .S I2="" F  S I2=$O(^TMP("XUMF ERROR",$J,I1,I2)) Q:'$L(I2)  D

 ..S X=$G(^(I2))

 ..Q:'$L(X)

 ..S I=I+1

 ..S X="ERR"_HLFS_I_HLFS_$S($O(^TMP("XUMF ERROR",$J,I1))!$O(^TMP("XUMF ERROR",$J,I1,I2)):1,1:0)_HLFS_X

 ..S ^TMP("HLA",$J,CNT)=X

 ..S CNT=CNT+1

 ;

 D:ERROR EM^XUMF0

 ;

 D GENACK^HLMA1($G(HL("EID")),$G(HLMTIENS),$G(HL("EIDS")),"GM",1,.HLRESLT)

 ;

 Q

 ;

EM(ERROR,ERR) ; -- error message

 ;

 N X,I,Y

 ;

 D MSG^DIALOG("AM",.X,80,,"ERR")

 ;

 S ERRCNT=ERRCNT+1

 ;

 S ^TMP("XUMF ERROR",$J,ERRCNT_".01")=""

 S ^TMP("XUMF ERROR",$J,ERRCNT_".02")=""

 S ^TMP("XUMF ERROR",$J,ERRCNT_".03")=$G(ERROR)

 S ^TMP("XUMF ERROR",$J,ERRCNT_".04")=""

 S ^TMP("XUMF ERROR",$J,ERRCNT_".05")="VUID: "_$G(VUID)_"   IFN: "_$G(IFN)_"   IEN: "_IEN

 S ^TMP("XUMF ERROR",$J,ERRCNT_".06")=""

 S X=.9 F  S X=$O(X(X)) Q:'X  D

 .S ^TMP("XUMF ERROR",$J,ERRCNT_"."_X)=X(X)

 ;

 Q

 ;

STATUS ;

 ;

 I VALUE=$P($$GETSTAT^XTID(IFN,,IEN_","),U) Q

 ;

 I SUBFILE="" S ERROR="1^status parameter error" Q

 ;

 N FDA

 S FDA(SUBFILE,"?+1,"_IENS,.01)=$$NOW^XLFDT

 S FDA(SUBFILE,"?+1,"_IENS,.02)=VALUE

 D UPDATE^DIE(,"FDA",,"ERR")

 I $D(ERR) D

 .S ERROR="1^effective date and status error"

 .D EM(ERROR,.ERR) K ERR

 ;

 Q

 ;

WP ;

 ;

 N X,Y,A,I,CNT,X1,X2,ESC

 D SEGPRSE^XUMFXHL7("HLNODE","X",HLFS,60)

 ;

 S CNT=1

 S A(CNT)=X(2)

 S I=0

 F  S I=$O(X(2,I)) Q:'I  D

 .S Y=X(2,I)

 .I $E(Y,1)=" " D  Q

 ..S A(CNT)=A(CNT)_" "

 ..Q:$P(Y," ",2)=""

 ..S CNT=CNT+1

 ..S A(CNT)=$P(Y," ",2,99)

 .S X1=$P(Y," ",1)

 .S X2=$P(Y," ",2,99)

 .S A(CNT)=A(CNT)_X1_$S(X2="":"",1:" ")

 .Q:X2=""

 .S CNT=CNT+1

 .S A(CNT)=X2

 ;

 D UNESCWP^XUMF0(.A,.HL)

 ;

 D WP^DIE(IFN,IENS,FIELD,"K","A","ERR")

 ;

 I $D(ERR) D

 .S ERROR="1^wp field error"

 .D EM(ERROR,.ERR) K ERR

 ;

 Q

 ;

RECORD ;MFS event protocol data

 ;

 N ROOT,NODE,NODE1,CHANGE,STATUS

 ;

 I $G(ERROR) D  Q

 .S ^TMP("XUMF EVENT",$J,"ERROR")=ERROR

 .S ^TMP("XUMF EVENT",$J,"ERROR",1)=$G(IFN)_U_$G(IEN)

 ;

 S ROOT=$$ROOT^DILFD(IFN,,1)

 M RECORD("AFTER")=@ROOT@(IEN)

 ;

 I $G(RECORD("NEW")) M ^TMP("XUMF EVENT",$J,IFN,"NEW",IEN)=RECORD("AFTER") Q

 ;

 S ^TMP("XUMF EVENT",$J,IFN,"AFTER",IEN,"REPLACED BY")=$P($G(@ROOT@(IEN,"VUID")),U,3)

 S ^TMP("XUMF EVENT",$J,IFN,"AFTER",IEN,"INHERITS FROM")=$$RPLCMNT^XTIDTRM(IFN,IEN)

 ;

 S STATUS=$$GETSTAT^XTID(IFN,,IEN_",")

 I RECORD("STATUS")'=STATUS D

 .S ^TMP("XUMF EVENT",$J,IFN,"STATUS",IEN)=$P(RECORD("STATUS"),U,1,2)_U_$P(STATUS,U,1,2)

 ;

 S NODE=$Q(RECORD("AFTER","")),NODE1=$Q(RECORD("BEFORE","")),CHANGE=0

 I $P(NODE,"RECORD(""AFTER")'=$P(NODE1,"RECORD(""BEFORE") S CHANGE=1

 I @NODE'=@NODE1 S CHANGE=1

 I 'CHANGE FOR  SET NODE=$Q(@NODE) Q:NODE=""!(NODE["(""BEFORE")  D  Q:CHANGE

 .S NODE1=$Q(@NODE1) I NODE1="" S CHANGE=1 Q

 .I $P(NODE,"RECORD(""AFTER")'=$P(NODE1,"RECORD(""BEFORE") S CHANGE=1 Q

 .I @NODE'=@NODE1 S CHANGE=1 Q

 ;

 I CHANGE D

 .M ^TMP("XUMF EVENT",$J,IFN,"AFTER",IEN)=RECORD("AFTER")

 .M ^TMP("XUMF EVENT",$J,IFN,"BEFORE",IEN)=RECORD("BEFORE")

 ;

 Q

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---XUMF1H   11023     printed  Mar 13, 2025@21:15:04                                                                                                                                                                                                     Page 2

XUMF1H    ;ISS/RAM - MFS Handler ;6/27/06  07:50

 +1       ;;8.0;KERNEL;**407,474**;Jul 10, 1995;Build 12

 +2       ;Per VHA Directive 10-92-142, this routine should not be modified

 +3       ;

 +4       ; This routine handles Master File HL7 messages.

 +5       ;

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,XIEN

 +5        NEW XUMFSDS,FDA,LIST,ERRCNT,PKV,MKEY,MKEY1,TYP,MFI,IMPLY,RECORD,OUT

 +6       ;

 +7        DO INIT

           DO PROCESS

           DO REPLY

           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        KILL ^TMP("XUMF EVENT",$JOB)

 +6       ;

 +7        SET XUMF=1

           SET DUZ(0)="@"

 +8       ;

 +9        SET (ERROR,CNT,TYPE,ARRAY,EXIT,ERRCNT)=0

 +10       SET HLFS=HL("FS")

           SET HLCS=$EXTRACT(HL("ECH"))

 +11       SET HLSCS=$EXTRACT(HL("ECH"),4)

           SET HLREP=$EXTRACT(HL("ECH"),2)

 +12      ;

 +13       QUIT 

 +14      ;

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^ZRT^"'[(U_$PIECE(HLNODE,HLFS)_U)

                       QUIT 

 +5                DO @($PIECE(HLNODE,HLFS))

               End DoDot:1

 +6        IF $DATA(LIST)

               DO LIST

 +7        IF $DATA(FDA)

               DO UPDATE

 +8        IF $DATA(RECORD)

               DO RECORD

 +9        IF $DATA(IFN)

               DO EVT^XUMF0

               DO POST

 +10      ;

 +11       QUIT 

 +12      ;

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        QUIT 

 +6       ;

MFE       ; -- MFE SEGMENT

 +1       ;

 +2        if ERROR

               QUIT 

 +3        if EXIT

               QUIT 

 +4       ;

 +5        SET PKV=$PIECE(HLNODE,HLFS,5)

           SET MFI=$PIECE(PKV,"@")

 +6       ;

 +7        IF $DATA(LIST)

               DO LIST

               KILL LIST,LISTVUID

 +8        IF $DATA(FDA)

               DO UPDATE

               KILL FDA

 +9        IF $DATA(RECORD)

               DO RECORD

 +10       IF $DATA(IFN)

               IF (IFN'=$ORDER(^DIC(4.001,"MFID",MFI,0)))

                   DO POST

 +11      ;

 +12       KILL IFN,IEN,PRE,POST,VUID,IMPLY,RECORD

 +13       KILL ^TMP("XUMF IMPLIED LOGIC",$JOB)

 +14      ;

 +15       IF MFI=""

               SET ERROR="1^MFI not resolved HLNODE: "_HLNODE

               QUIT 

 +16       SET IFN=$ORDER(^DIC(4.001,"MFID",MFI,0))

 +17       IF 'IFN

               SET ERROR="1^IFN not resolved HLNODE: "_HLNODE

               QUIT 

 +18      ;

 +19       SET VUID=$PIECE($PIECE(PKV,"@",2),HLCS)

 +20      ;

 +21       if ARRAY

               QUIT 

 +22      ;

 +23      ;MFE processing

 +24       DO MFE0

           if ERROR

               QUIT 

 +25      ;

 +26       if '$GET(IEN)

               DO MFE^XUMF0(IFN,VUID,.IEN,.ERROR)

           if ERROR

               QUIT 

 +27      ;

 +28      ;D MFE0

 +29      ;

 +30      ;Implied logic flag - must be set by MFE-Processing Logic field (#4)

 +31       SET IMPLY=+$GET(^TMP("XUMF IMPLIED LOGIC",$JOB))

 +32       SET IMPLY("KILL")=0

 +33       KILL ^TMP("XUMF IMPLIED LOGIC",$JOB)

 +34      ;

 +35       IF IEN

               Begin DoDot:1

 +36      ; clean multiple flag

 +37               if '$DATA(XIEN(IFN,IEN))

                       KILL XIEN

 +38               SET XIEN(IFN,IEN)=$GET(XIEN(IFN,IEN))+1

 +39      ;

 +40               NEW ROOT

 +41               SET ROOT=$$ROOT^DILFD(IFN,,1)

 +42               MERGE RECORD("BEFORE")=@ROOT@(IEN)

 +43               SET RECORD("STATUS")=$$GETSTAT^XTID(IFN,,IEN_",")

 +44      ;

 +45               SET ^TMP("XUMF EVENT",$JOB,IFN,"BEFORE",IEN,"REPLACED BY")=$PIECE($GET(@ROOT@(IEN,"VUID")),U,3)

 +46               SET ^TMP("XUMF EVENT",$JOB,IFN,"BEFORE",IEN,"INHERITS FROM")=$$RPLCMNT^XTIDTRM(IFN,IEN)

               End DoDot:1

 +47      ;

 +48       QUIT 

 +49      ;

ZRT       ; -- data segments

 +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,DATA,NAME,VUID1,LIST1

 +8        NEW FIELD,SUBFILE,LKUP,REPEAT,CLEAN,TIMEZONE,WP

 +9       ;

 +10       SET NAME=$PIECE(HLNODE,HLFS,2)

 +11      ;

 +12       DO ZRT0

           if ERROR

               QUIT 

           IF $GET(OUT)

               KILL OUT

               QUIT 

 +13      ;

 +14       IF 'IEN

               IF NAME="Term"

                   DO STUB^XUMF0

                   QUIT 

 +15       IF 'IEN

               SET ERROR="1^IEN not defined IFN: "_IFN_" VUID: "_VUID

               QUIT 

 +16      ;

 +17      ;D ZRT0 Q:ERROR

 +18      ;

 +19       SET IENS=IEN_","

 +20      ;

 +21       SET IDX=$ORDER(^DIC(4.001,+IFN,1,"B",NAME,0))

 +22       IF 'IDX

               SET ERROR="1^parameter "_NAME_" not defined IFN: "_IFN

               QUIT 

 +23       SET DATA=$GET(^DIC(4.001,+IFN,1,+IDX,0))

 +24       SET TYP=$PIECE(DATA,U,3)

           SET TYP=$$GET1^DIQ(771.4,(+TYP_","),.01)

 +25       SET FIELD=$PIECE(DATA,U,2)

           SET SUBFILE=$PIECE(DATA,U,4)

           SET MKEY=$PIECE(DATA,U,6)

 +26       SET LKUP=$PIECE(DATA,U,7)

           SET TIMEZONE=$PIECE(DATA,U,14)

           SET LIST1=$PIECE(DATA,U,8)

 +27       SET REPEAT=$PIECE(DATA,U,11)

           SET CLEAN=$PIECE(DATA,U,12)

           SET VUID1=$PIECE(DATA,U,13)

 +28       SET WP=$PIECE(DATA,U,16)

 +29      ;

 +30       IF WP

               DO WP

               QUIT 

 +31      ;

 +32       SET VALUE=$$UNESC^XUMF0($PIECE(HLNODE,HLFS,3),.HL)

 +33       SET VALUE=$$DTYP^XUMFXP(VALUE,TYP,HLCS,0,TIMEZONE)

 +34      ;

 +35       IF NAME="Status"

               DO STATUS

               QUIT 

 +36      ;

 +37       IF 'SUBFILE

               Begin DoDot:1

 +38               SET VALUE=$$VAL^XUMF0(IFN,FIELD,VUID1,VALUE,IENS)

                   if VALUE="^"

                       QUIT 

 +39               SET FDA(IFN,IENS,FIELD)=VALUE

               End DoDot:1

               QUIT 

 +40      ;

 +41       NEW IENS1

 +42      ;

 +43       IF LIST1

               Begin DoDot:1

 +44               SET VALUE=$$VAL^XUMF0(SUBFILE,FIELD,VUID1,VALUE,"?+1,"_IENS)

                   if VALUE="^"

                       QUIT 

 +45      ;S:VUID1'="" LISTVUID(SUBFILE)=1

                   IF MKEY=NAME

                       SET ZKEY=VALUE

 +46               IF '$DATA(ZKEY)

                       SET ERROR="1^ZKEY error "_SUBFILE_" VUID: "_VUID

                       QUIT 

 +47               IF ((ZKEY="")!(ZKEY=$CHAR(34,34)))

                       SET LIST(SUBFILE)=""