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 ---[H[J[2J[HXUMF1H 11023 printed Dec 13, 2024@02:10:10 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)=""
QUIT
+48 SET LIST(SUBFILE,ZKEY,FIELD)=VALUE
+49 IF IMPLY
DO IMPLY
End DoDot:1
QUIT
+50 ;
+51 IF CLEAN
IF $GET(XIEN(IFN,IEN))'>1
Begin DoDot:1
+52 NEW ROOT,IDX
+53 SET ROOT=$$ROOT^DILFD(SUBFILE,","_IENS,1)
+54 SET IDX=0
FOR
SET IDX=$ORDER(@ROOT@(IDX))
if 'IDX
QUIT
Begin DoDot:2
+55 Begin DoDot:3
+56 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
+57 ;
+58 IF MKEY=NAME
if VALUE=""
QUIT
Begin DoDot:1
+59 NEW FDA,IEN
+60 ;
+61 SET VALUE=$$VAL^XUMF0(SUBFILE,FIELD,VUID1,VALUE,"?+1,"_IENS)
if VALUE="^"
QUIT
+62 SET FDA(SUBFILE,"?+1,"_IENS,.01)=VALUE
+63 DO UPDATE^DIE(,"FDA","IEN","ERR")
+64 IF $DATA(ERR)
Begin DoDot:2
+65 SET ERROR="1^subfile update error SUBFILE#: "_SUBFILE
+66 DO EM(ERROR,.ERR)
KILL ERR
End DoDot:2
QUIT
+67 SET IENS1=IEN(1)_","_IENS
SET MKEY(NAME)=IENS1
End DoDot:1
+68 ;
+69 IF MKEY'=""
IF MKEY'=NAME
SET IENS1=$GET(MKEY(MKEY))
if IENS1=""
QUIT
+70 if MKEY'=NAME
SET VALUE=$$VAL^XUMF0(SUBFILE,FIELD,VUID1,VALUE,"?+1,"_IENS)
if VALUE="^"
QUIT
+71 if $DATA(IENS1)
SET FDA(SUBFILE,IENS1,FIELD)=VALUE
+72 IF IMPLY
DO IMPLY
+73 ;
+74 QUIT
+75 ;
IMPLY ; -- Implied value logic
+1 NEW PREV,ARR
+2 SET ARR=$SELECT(LIST1:"LIST",1:"FDA")
+3 SET PREV=$SELECT(LIST1:ZKEY,1:IENS1)
+4 IF MKEY=NAME
Begin DoDot:1
+5 IF IMPLY("KILL")
KILL IMPLY("PREV")
SET IMPLY("KILL")=0
+6 SET IMPLY("PREV",PREV)=""
End DoDot:1
QUIT
+7 SET PREV=""
FOR
SET PREV=$ORDER(IMPLY("PREV",PREV))
if PREV=""
QUIT
Begin DoDot:1
+8 SET @ARR@(SUBFILE,PREV,FIELD)=VALUE
End DoDot:1
+9 SET IMPLY("KILL")=1
+10 QUIT
+11 ;
LIST ; -- process list
+1 ;
+2 NEW SUBFILE,ZKEY,FIELD,VALUE,IENS,CNT
+3 ;
+4 SET IENS=IEN_","
+5 ;
+6 ;remove non-standard sub-records (not in message)
+7 SET SUBFILE=0
+8 FOR
SET SUBFILE=$ORDER(LIST(SUBFILE))
if 'SUBFILE
QUIT
Begin DoDot:1
+9 NEW ROOT,IDX
+10 SET ROOT=$$ROOT^DILFD(SUBFILE,","_IENS,1)
+11 SET IDX=0
FOR
SET IDX=$ORDER(@ROOT@(IDX))
if 'IDX
QUIT
Begin DoDot:2
+12 SET VALUE=$$GET1^DIQ(SUBFILE,IDX_","_IENS,.01,"I")
+13 IF '$DATA(LIST(SUBFILE,VALUE))
Begin DoDot:3
+14 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
+15 ;
+16 ;update sub-records
+17 SET SUBFILE=0
+18 FOR
SET SUBFILE=$ORDER(LIST(SUBFILE))
if 'SUBFILE
QUIT
Begin DoDot:1
+19 SET ZKEY=""
SET CNT=0
+20 FOR
SET ZKEY=$ORDER(LIST(SUBFILE,ZKEY))
if ZKEY=""
QUIT
Begin DoDot:2
+21 NEW IDX,ROOT
+22 SET ROOT=$$ROOT^DILFD(SUBFILE,","_IENS,1)
+23 SET IDX=$ORDER(@ROOT@("B",ZKEY,0))
+24 IF $ORDER(@ROOT@("B",ZKEY,IDX))
DO DELLIST(IDX)
+25 IF 'IDX
DO ADDLIST
QUIT
+26 SET FIELD=0
+27 FOR
SET FIELD=$ORDER(LIST(SUBFILE,ZKEY,FIELD))
if 'FIELD
QUIT
Begin DoDot:3
+28 NEW X
SET X=$$GET1^DIQ(SUBFILE,IDX_","_IENS,FIELD)
+29 SET VALUE=LIST(SUBFILE,ZKEY,FIELD)
+30 if VALUE=X
QUIT
if (VALUE=""""&X="")
QUIT
+31 SET FDA(SUBFILE,IDX_","_IENS,FIELD)=VALUE
End DoDot:3
End DoDot:2
End DoDot:1
+32 ;
+33 QUIT
+34 ;
ADDLIST ; -- add new sub-record
+1 ;
+2 NEW FDA
+3 ;
+4 SET CNT=$GET(CNT)+1
+5 SET FIELD=0
+6 FOR
SET FIELD=$ORDER(LIST(SUBFILE,ZKEY,FIELD))
if 'FIELD
QUIT
Begin DoDot:1
+7 SET VALUE=LIST(SUBFILE,ZKEY,FIELD)
if VALUE=""
QUIT
+8 SET FDA(SUBFILE,"+"_CNT_","_IENS,FIELD)=VALUE
End DoDot:1
+9 ;
+10 if '$DATA(FDA)
QUIT
+11 ;
+12 DO UPDATE^DIE(,"FDA",,"ERR")
+13 IF $DATA(ERR)
Begin DoDot:1
+14 SET ERROR="1^subfile update error SUBFILE#: "_SUBFILE
+15 DO EM(ERROR,.ERR)
KILL ERR
End DoDot:1
QUIT
+16 ;
+17 QUIT
+18 ;
DELLIST(IDX) ; -- delete duplicate
+1 ;
+2 FOR
SET IDX=$ORDER(@ROOT@("B",ZKEY,IDX))
if 'IDX
QUIT
Begin DoDot:1
+3 NEW DA,DIK,DIC
SET DA(1)=+IENS
SET DA=IDX
SET DIK=$PIECE(ROOT,")")_","
DO ^DIK
End DoDot:1
+4 ;
+5 QUIT
+6 ;
UPDATE ; -- FileMan update
+1 ;
+2 if ERROR
QUIT
+3 if EXIT
QUIT
+4 ;
+5 if $DATA(FDA)
DO FILE^DIE(,"FDA","ERR")
+6 IF $DATA(ERR)
Begin DoDot:1
+7 SET ERROR="1^updating error"
+8 DO EM(ERROR,.ERR)
KILL ERR
End DoDot:1
+9 ;
+10 QUIT
+11 ;
ARRAY ; -- query data stored in array (not filed)
+1 ;
+2 SET ^TMP("XUMF ARRAY",$JOB,IFN,VUID,$PIECE(HLNODE,HLFS,2))=$PIECE(HLNODE,HLFS,3)
+3 ;
+4 QUIT
+5 ;
ADD ; -- ADD-processing logic
+1 ;
+2 NEW X
+3 ;
+4 SET X=$GET(^DIC(4.001,+IFN,3))
if X'=""
XECUTE X
+5 ;
+6 QUIT
+7 ;
MFE0 ; -- MFE-processing logic
+1 ;if creating a new entry you must set IEN and other tasks performed in STUB^XUMF0 (if appropriate)
+2 ;
+3 NEW X
+4 ;
+5 SET X=$GET(^DIC(4.001,+IFN,4))
if X'=""
XECUTE X
+6 ;
+7 QUIT
+8 ;
ZRT0 ; -- ZRT-processing logic
+1 ;
+2 NEW X
+3 ;
+4 SET X=$GET(^DIC(4.001,+IFN,5))
if X'=""
XECUTE X
+5 ;
+6 QUIT
+7 ;
POST ; -- post-processing logic
+1 ;
+2 NEW X
+3 ;
+4 SET X=$GET(^DIC(4.001,+IFN,2))
if X'=""
XECUTE X
+5 ;
+6 QUIT
+7 ;
EXIT ; -- cleanup, and quit
+1 ;
+2 KILL ^TMP("DILIST",$JOB),^TMP("DIERR",$JOB),^TMP("HLS",$JOB),^TMP("HLA",$JOB)
+3 ;
+4 KILL ^TMP("XUMF MFS",$JOB),^TMP("XUMF ERROR",$JOB),^TMP("XUMF EVENT",$JOB)
+5 ;
+6 QUIT
+7 ;
REPLY ; -- MFK
+1 ;
+2 NEW X,I,I1,I2,CNT
+3 ;
+4 SET CNT=1
+5 SET X="MSA"_HLFS_$SELECT(ERROR:"AE",1:"AA")_HLFS_HL("MID")_HLFS_$PIECE(ERROR,U,2)
+6 SET ^TMP("HLA",$JOB,CNT)=X
+7 SET CNT=CNT+1
+8 ;
+9 SET I1=""
SET I=0
+10 FOR
SET I1=$ORDER(^TMP("XUMF ERROR",$JOB,I1))
if '$LENGTH(I1)
QUIT
Begin DoDot:1
+11 SET I2=""
FOR
SET I2=$ORDER(^TMP("XUMF ERROR",$JOB,I1,I2))
if '$LENGTH(I2)
QUIT
Begin DoDot:2
+12 SET X=$GET(^(I2))
+13 if '$LENGTH(X)
QUIT
+14 SET I=I+1
+15 SET X="ERR"_HLFS_I_HLFS_$SELECT($ORDER(^TMP("XUMF ERROR",$JOB,I1))!$ORDER(^TMP("XUMF ERROR",$JOB,I1,I2)):1,1:0)_HLFS_X
+16 SET ^TMP("HLA",$JOB,CNT)=X
+17 SET CNT=CNT+1
End DoDot:2
End DoDot:1
+18 ;
+19 if ERROR
DO EM^XUMF0
+20 ;
+21 DO GENACK^HLMA1($GET(HL("EID")),$GET(HLMTIENS),$GET(HL("EIDS")),"GM",1,.HLRESLT)
+22 ;
+23 QUIT
+24 ;
EM(ERROR,ERR) ; -- error message
+1 ;
+2 NEW X,I,Y
+3 ;
+4 DO MSG^DIALOG("AM",.X,80,,"ERR")
+5 ;
+6 SET ERRCNT=ERRCNT+1
+7 ;
+8 SET ^TMP("XUMF ERROR",$JOB,ERRCNT_".01")=""
+9 SET ^TMP("XUMF ERROR",$JOB,ERRCNT_".02")=""
+10 SET ^TMP("XUMF ERROR",$JOB,ERRCNT_".03")=$GET(ERROR)
+11 SET ^TMP("XUMF ERROR",$JOB,ERRCNT_".04")=""
+12 SET ^TMP("XUMF ERROR",$JOB,ERRCNT_".05")="VUID: "_$GET(VUID)_" IFN: "_$GET(IFN)_" IEN: "_IEN
+13 SET ^TMP("XUMF ERROR",$JOB,ERRCNT_".06")=""
+14 SET X=.9
FOR
SET X=$ORDER(X(X))
if 'X
QUIT
Begin DoDot:1
+15 SET ^TMP("XUMF ERROR",$JOB,ERRCNT_"."_X)=X(X)
End DoDot:1
+16 ;
+17 QUIT
+18 ;
STATUS ;
+1 ;
+2 IF VALUE=$PIECE($$GETSTAT^XTID(IFN,,IEN_","),U)
QUIT
+3 ;
+4 IF SUBFILE=""
SET ERROR="1^status parameter error"
QUIT
+5 ;
+6 NEW FDA
+7 SET FDA(SUBFILE,"?+1,"_IENS,.01)=$$NOW^XLFDT
+8 SET FDA(SUBFILE,"?+1,"_IENS,.02)=VALUE
+9 DO UPDATE^DIE(,"FDA",,"ERR")
+10 IF $DATA(ERR)
Begin DoDot:1
+11 SET ERROR="1^effective date and status error"
+12 DO EM(ERROR,.ERR)
KILL ERR
End DoDot:1
+13 ;
+14 QUIT
+15 ;
WP ;
+1 ;
+2 NEW X,Y,A,I,CNT,X1,X2,ESC
+3 DO SEGPRSE^XUMFXHL7("HLNODE","X",HLFS,60)
+4 ;
+5 SET CNT=1
+6 SET A(CNT)=X(2)
+7 SET I=0
+8 FOR
SET I=$ORDER(X(2,I))
if 'I
QUIT
Begin DoDot:1
+9 SET Y=X(2,I)
+10 IF $EXTRACT(Y,1)=" "
Begin DoDot:2
+11 SET A(CNT)=A(CNT)_" "
+12 if $PIECE(Y," ",2)=""
QUIT
+13 SET CNT=CNT+1
+14 SET A(CNT)=$PIECE(Y," ",2,99)
End DoDot:2
QUIT
+15 SET X1=$PIECE(Y," ",1)
+16 SET X2=$PIECE(Y," ",2,99)
+17 SET A(CNT)=A(CNT)_X1_$SELECT(X2="":"",1:" ")
+18 if X2=""
QUIT
+19 SET CNT=CNT+1
+20 SET A(CNT)=X2
End DoDot:1
+21 ;
+22 DO UNESCWP^XUMF0(.A,.HL)
+23 ;
+24 DO WP^DIE(IFN,IENS,FIELD,"K","A","ERR")
+25 ;
+26 IF $DATA(ERR)
Begin DoDot:1
+27 SET ERROR="1^wp field error"
+28 DO EM(ERROR,.ERR)
KILL ERR
End DoDot:1
+29 ;
+30 QUIT
+31 ;
RECORD ;MFS event protocol data
+1 ;
+2 NEW ROOT,NODE,NODE1,CHANGE,STATUS
+3 ;
+4 IF $GET(ERROR)
Begin DoDot:1
+5 SET ^TMP("XUMF EVENT",$JOB,"ERROR")=ERROR
+6 SET ^TMP("XUMF EVENT",$JOB,"ERROR",1)=$GET(IFN)_U_$GET(IEN)
End DoDot:1
QUIT
+7 ;
+8 SET ROOT=$$ROOT^DILFD(IFN,,1)
+9 MERGE RECORD("AFTER")=@ROOT@(IEN)
+10 ;
+11 IF $GET(RECORD("NEW"))
MERGE ^TMP("XUMF EVENT",$JOB,IFN,"NEW",IEN)=RECORD("AFTER")
QUIT
+12 ;
+13 SET ^TMP("XUMF EVENT",$JOB,IFN,"AFTER",IEN,"REPLACED BY")=$PIECE($GET(@ROOT@(IEN,"VUID")),U,3)
+14 SET ^TMP("XUMF EVENT",$JOB,IFN,"AFTER",IEN,"INHERITS FROM")=$$RPLCMNT^XTIDTRM(IFN,IEN)
+15 ;
+16 SET STATUS=$$GETSTAT^XTID(IFN,,IEN_",")
+17 IF RECORD("STATUS")'=STATUS
Begin DoDot:1
+18 SET ^TMP("XUMF EVENT",$JOB,IFN,"STATUS",IEN)=$PIECE(RECORD("STATUS"),U,1,2)_U_$PIECE(STATUS,U,1,2)
End DoDot:1
+19 ;
+20 SET NODE=$QUERY(RECORD("AFTER",""))
SET NODE1=$QUERY(RECORD("BEFORE",""))
SET CHANGE=0
+21 IF $PIECE(NODE,"RECORD(""AFTER")'=$PIECE(NODE1,"RECORD(""BEFORE")
SET CHANGE=1
+22 IF @NODE'=@NODE1
SET CHANGE=1
+23 IF 'CHANGE
FOR
SET NODE=$QUERY(@NODE)
if NODE=""!(NODE["(""BEFORE")
QUIT
Begin DoDot:1
+24 SET NODE1=$QUERY(@NODE1)
IF NODE1=""
SET CHANGE=1
QUIT
+25 IF $PIECE(NODE,"RECORD(""AFTER")'=$PIECE(NODE1,"RECORD(""BEFORE")
SET CHANGE=1
QUIT
+26 IF @NODE'=@NODE1
SET CHANGE=1
QUIT
End DoDot:1
if CHANGE
QUIT
+27 ;
+28 IF CHANGE
Begin DoDot:1
+29 MERGE ^TMP("XUMF EVENT",$JOB,IFN,"AFTER",IEN)=RECORD("AFTER")
+30 MERGE ^TMP("XUMF EVENT",$JOB,IFN,"BEFORE",IEN)=RECORD("BEFORE")
End DoDot:1
+31 ;
+32 QUIT
+33 ;
