Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XUMF1H

XUMF1H.m

Go to the documentation of this file.
  1. XUMF1H ;ISS/RAM - MFS Handler ;6/27/06 07:50
  1. ;;8.0;KERNEL;**407,474**;Jul 10, 1995;Build 12
  1. ;Per VHA Directive 10-92-142, this routine should not be modified
  1. ;
  1. ; This routine handles Master File HL7 messages.
  1. ;
  1. MAIN ; -- entry point
  1. ;
  1. N CNT,ERR,I,X,HLFS,HLCS,ERROR,HLRESLTA,IFN,IEN,MTPE,TYPE,ARRAY
  1. N HDT,KEY,MID,REASON,VALUE,XREF,ALL,GROUP,PARAM,ROOT,SEG,QRD,XUMF
  1. N QID,WHAT,WHO,HLSCS,CDSYS,EXIT,HLREP,NUMBER,Y,XXX,YYY,XIEN
  1. N XUMFSDS,FDA,LIST,ERRCNT,PKV,MKEY,MKEY1,TYP,MFI,IMPLY,RECORD,OUT
  1. ;
  1. D INIT,PROCESS,REPLY,EXIT
  1. ;
  1. Q
  1. ;
  1. INIT ; -- initialize
  1. ;
  1. K ^TMP("DILIST",$J),^TMP("DIERR",$J)
  1. K ^TMP("HLS",$J),^TMP("HLA",$J)
  1. K ^TMP("XUMF MFS",$J),^TMP("XUMF ERROR",$J)
  1. K ^TMP("XUMF EVENT",$J)
  1. ;
  1. S XUMF=1,DUZ(0)="@"
  1. ;
  1. S (ERROR,CNT,TYPE,ARRAY,EXIT,ERRCNT)=0
  1. S HLFS=HL("FS"),HLCS=$E(HL("ECH"))
  1. S HLSCS=$E(HL("ECH"),4),HLREP=$E(HL("ECH"),2)
  1. ;
  1. Q
  1. ;
  1. PROCESS ; -- pull message text
  1. ;
  1. F X HLNEXT Q:HLQUIT'>0 D
  1. .Q:$P(HLNODE,HLFS)=""
  1. .Q:"^MSH^MSA^QRD^MFI^MFE^ZRT^"'[(U_$P(HLNODE,HLFS)_U)
  1. .D @($P(HLNODE,HLFS))
  1. I $D(LIST) D LIST
  1. I $D(FDA) D UPDATE
  1. I $D(RECORD) D RECORD
  1. I $D(IFN) D EVT^XUMF0,POST
  1. ;
  1. Q
  1. ;
  1. MSH ; -- MSH segment
  1. ;
  1. Q
  1. ;
  1. MSA ; -- MSA segment
  1. ;
  1. N CODE
  1. ;
  1. S CODE=$P(HLNODE,HLFS,2)
  1. ;
  1. I CODE="AE"!(CODE="AR") D
  1. .S ERROR=ERROR_U_$P(HLNODE,HLFS,4)_U_$G(ERR)
  1. .D EM^XUMFX(ERROR,.ERR)
  1. ;
  1. Q
  1. ;
  1. MFI ; -- MFI segment
  1. ;
  1. Q:ERROR
  1. Q:EXIT
  1. ;
  1. Q
  1. ;
  1. MFE ; -- MFE SEGMENT
  1. ;
  1. Q:ERROR
  1. Q:EXIT
  1. ;
  1. S PKV=$P(HLNODE,HLFS,5),MFI=$P(PKV,"@")
  1. ;
  1. I $D(LIST) D LIST K LIST,LISTVUID
  1. I $D(FDA) D UPDATE K FDA
  1. I $D(RECORD) D RECORD
  1. I $D(IFN),(IFN'=$O(^DIC(4.001,"MFID",MFI,0))) D POST
  1. ;
  1. K IFN,IEN,PRE,POST,VUID,IMPLY,RECORD
  1. K ^TMP("XUMF IMPLIED LOGIC",$J)
  1. ;
  1. I MFI="" S ERROR="1^MFI not resolved HLNODE: "_HLNODE Q
  1. S IFN=$O(^DIC(4.001,"MFID",MFI,0))
  1. I 'IFN S ERROR="1^IFN not resolved HLNODE: "_HLNODE Q
  1. ;
  1. S VUID=$P($P(PKV,"@",2),HLCS)
  1. ;
  1. Q:ARRAY
  1. ;
  1. ;MFE processing
  1. D MFE0 Q:ERROR
  1. ;
  1. D:'$G(IEN) MFE^XUMF0(IFN,VUID,.IEN,.ERROR) Q:ERROR
  1. ;
  1. ;D MFE0
  1. ;
  1. ;Implied logic flag - must be set by MFE-Processing Logic field (#4)
  1. S IMPLY=+$G(^TMP("XUMF IMPLIED LOGIC",$J))
  1. S IMPLY("KILL")=0
  1. K ^TMP("XUMF IMPLIED LOGIC",$J)
  1. ;
  1. I IEN D
  1. .; clean multiple flag
  1. .K:'$D(XIEN(IFN,IEN)) XIEN
  1. .S XIEN(IFN,IEN)=$G(XIEN(IFN,IEN))+1
  1. .;
  1. .N ROOT
  1. .S ROOT=$$ROOT^DILFD(IFN,,1)
  1. .M RECORD("BEFORE")=@ROOT@(IEN)
  1. .S RECORD("STATUS")=$$GETSTAT^XTID(IFN,,IEN_",")
  1. .;
  1. .S ^TMP("XUMF EVENT",$J,IFN,"BEFORE",IEN,"REPLACED BY")=$P($G(@ROOT@(IEN,"VUID")),U,3)
  1. .S ^TMP("XUMF EVENT",$J,IFN,"BEFORE",IEN,"INHERITS FROM")=$$RPLCMNT^XTIDTRM(IFN,IEN)
  1. ;
  1. Q
  1. ;
  1. ZRT ; -- data segments
  1. ;
  1. Q:ERROR
  1. Q:EXIT
  1. ;
  1. I $G(ARRAY) D ARRAY Q
  1. ;
  1. N COL,X,Y,Z,DTYP,IDX,SEQ,DATA,NAME,VUID1,LIST1
  1. N FIELD,SUBFILE,LKUP,REPEAT,CLEAN,TIMEZONE,WP
  1. ;
  1. S NAME=$P(HLNODE,HLFS,2)
  1. ;
  1. D ZRT0 Q:ERROR I $G(OUT) K OUT Q
  1. ;
  1. I 'IEN,NAME="Term" D STUB^XUMF0 Q
  1. I 'IEN S ERROR="1^IEN not defined IFN: "_IFN_" VUID: "_VUID Q
  1. ;
  1. ;D ZRT0 Q:ERROR
  1. ;
  1. S IENS=IEN_","
  1. ;
  1. S IDX=$O(^DIC(4.001,+IFN,1,"B",NAME,0))
  1. I 'IDX S ERROR="1^parameter "_NAME_" not defined IFN: "_IFN Q
  1. S DATA=$G(^DIC(4.001,+IFN,1,+IDX,0))
  1. S TYP=$P(DATA,U,3),TYP=$$GET1^DIQ(771.4,(+TYP_","),.01)
  1. S FIELD=$P(DATA,U,2),SUBFILE=$P(DATA,U,4),MKEY=$P(DATA,U,6)
  1. S LKUP=$P(DATA,U,7),TIMEZONE=$P(DATA,U,14),LIST1=$P(DATA,U,8)
  1. S REPEAT=$P(DATA,U,11),CLEAN=$P(DATA,U,12),VUID1=$P(DATA,U,13)
  1. S WP=$P(DATA,U,16)
  1. ;
  1. I WP D WP Q
  1. ;
  1. S VALUE=$$UNESC^XUMF0($P(HLNODE,HLFS,3),.HL)
  1. S VALUE=$$DTYP^XUMFXP(VALUE,TYP,HLCS,0,TIMEZONE)
  1. ;
  1. I NAME="Status" D STATUS Q
  1. ;
  1. I 'SUBFILE D Q
  1. .S VALUE=$$VAL^XUMF0(IFN,FIELD,VUID1,VALUE,IENS) Q:VALUE="^"
  1. .S FDA(IFN,IENS,FIELD)=VALUE
  1. ;
  1. N IENS1
  1. ;
  1. I LIST1 D Q
  1. .S VALUE=$$VAL^XUMF0(SUBFILE,FIELD,VUID1,VALUE,"?+1,"_IENS) Q:VALUE="^"
  1. .I MKEY=NAME S ZKEY=VALUE ;S:VUID1'="" LISTVUID(SUBFILE)=1
  1. .I '$D(ZKEY) S ERROR="1^ZKEY error "_SUBFILE_" VUID: "_VUID Q
  1. .I ((ZKEY="")!(ZKEY=$C(34,34))) S LIST(SUBFILE)="" Q
  1. .S LIST(SUBFILE,ZKEY,FIELD)=VALUE
  1. .I IMPLY D IMPLY
  1. ;
  1. I CLEAN,$G(XIEN(IFN,IEN))'>1 D
  1. .N ROOT,IDX
  1. .S ROOT=$$ROOT^DILFD(SUBFILE,","_IENS,1)
  1. .S IDX=0 F S IDX=$O(@ROOT@(IDX)) Q:'IDX D
  1. ..D
  1. ...N DA,DIK,DIC S DA(1)=+IENS,DA=IDX,DIK=$P(ROOT,")")_"," D ^DIK
  1. ;
  1. I MKEY=NAME Q:VALUE="" D
  1. .N FDA,IEN
  1. .;
  1. .S VALUE=$$VAL^XUMF0(SUBFILE,FIELD,VUID1,VALUE,"?+1,"_IENS) Q:VALUE="^"
  1. .S FDA(SUBFILE,"?+1,"_IENS,.01)=VALUE
  1. .D UPDATE^DIE(,"FDA","IEN","ERR")
  1. .I $D(ERR) D Q
  1. ..S ERROR="1^subfile update error SUBFILE#: "_SUBFILE
  1. ..D EM(ERROR,.ERR) K ERR
  1. .S IENS1=IEN(1)_","_IENS,MKEY(NAME)=IENS1
  1. ;
  1. I MKEY'="",MKEY'=NAME S IENS1=$G(MKEY(MKEY)) Q:IENS1=""
  1. S:MKEY'=NAME VALUE=$$VAL^XUMF0(SUBFILE,FIELD,VUID1,VALUE,"?+1,"_IENS) Q:VALUE="^"
  1. S:$D(IENS1) FDA(SUBFILE,IENS1,FIELD)=VALUE
  1. I IMPLY D IMPLY
  1. ;
  1. Q
  1. ;
  1. IMPLY ; -- Implied value logic
  1. N PREV,ARR
  1. S ARR=$S(LIST1:"LIST",1:"FDA")
  1. S PREV=$S(LIST1:ZKEY,1:IENS1)
  1. I MKEY=NAME D Q
  1. .I IMPLY("KILL") K IMPLY("PREV") S IMPLY("KILL")=0
  1. .S IMPLY("PREV",PREV)=""
  1. S PREV="" F S PREV=$O(IMPLY("PREV",PREV)) Q:PREV="" D
  1. .S @ARR@(SUBFILE,PREV,FIELD)=VALUE
  1. S IMPLY("KILL")=1
  1. Q
  1. ;
  1. LIST ; -- process list
  1. ;
  1. N SUBFILE,ZKEY,FIELD,VALUE,IENS,CNT
  1. ;
  1. S IENS=IEN_","
  1. ;
  1. ;remove non-standard sub-records (not in message)
  1. S SUBFILE=0
  1. F S SUBFILE=$O(LIST(SUBFILE)) Q:'SUBFILE D
  1. .N ROOT,IDX
  1. .S ROOT=$$ROOT^DILFD(SUBFILE,","_IENS,1)
  1. .S IDX=0 F S IDX=$O(@ROOT@(IDX)) Q:'IDX D
  1. ..S VALUE=$$GET1^DIQ(SUBFILE,IDX_","_IENS,.01,"I")
  1. ..I '$D(LIST(SUBFILE,VALUE)) D
  1. ...N DA,DIK,DIC S DA(1)=+IENS,DA=IDX,DIK=$P(ROOT,")")_"," D ^DIK
  1. ;
  1. ;update sub-records
  1. S SUBFILE=0
  1. F S SUBFILE=$O(LIST(SUBFILE)) Q:'SUBFILE D
  1. .S ZKEY="",CNT=0
  1. .F S ZKEY=$O(LIST(SUBFILE,ZKEY)) Q:ZKEY="" D
  1. ..N IDX,ROOT
  1. ..S ROOT=$$ROOT^DILFD(SUBFILE,","_IENS,1)
  1. ..S IDX=$O(@ROOT@("B",ZKEY,0))
  1. ..I $O(@ROOT@("B",ZKEY,IDX)) D DELLIST(IDX)
  1. ..I 'IDX D ADDLIST Q
  1. ..S FIELD=0
  1. ..F S FIELD=$O(LIST(SUBFILE,ZKEY,FIELD)) Q:'FIELD D
  1. ...N X S X=$$GET1^DIQ(SUBFILE,IDX_","_IENS,FIELD)
  1. ...S VALUE=LIST(SUBFILE,ZKEY,FIELD)
  1. ...Q:VALUE=X Q:(VALUE=""""&X="")
  1. ...S FDA(SUBFILE,IDX_","_IENS,FIELD)=VALUE
  1. ;
  1. Q
  1. ;
  1. ADDLIST ; -- add new sub-record
  1. ;
  1. N FDA
  1. ;
  1. S CNT=$G(CNT)+1
  1. S FIELD=0
  1. F S FIELD=$O(LIST(SUBFILE,ZKEY,FIELD)) Q:'FIELD D
  1. .S VALUE=LIST(SUBFILE,ZKEY,FIELD) Q:VALUE=""
  1. .S FDA(SUBFILE,"+"_CNT_","_IENS,FIELD)=VALUE
  1. ;
  1. Q:'$D(FDA)
  1. ;
  1. D UPDATE^DIE(,"FDA",,"ERR")
  1. I $D(ERR) D Q
  1. .S ERROR="1^subfile update error SUBFILE#: "_SUBFILE
  1. .D EM(ERROR,.ERR) K ERR
  1. ;
  1. Q
  1. ;
  1. DELLIST(IDX) ; -- delete duplicate
  1. ;
  1. F S IDX=$O(@ROOT@("B",ZKEY,IDX)) Q:'IDX D
  1. .N DA,DIK,DIC S DA(1)=+IENS,DA=IDX,DIK=$P(ROOT,")")_"," D ^DIK
  1. ;
  1. Q
  1. ;
  1. UPDATE ; -- FileMan update
  1. ;
  1. Q:ERROR
  1. Q:EXIT
  1. ;
  1. D:$D(FDA) FILE^DIE(,"FDA","ERR")
  1. I $D(ERR) D
  1. .S ERROR="1^updating error"
  1. .D EM(ERROR,.ERR) K ERR
  1. ;
  1. Q
  1. ;
  1. ARRAY ; -- query data stored in array (not filed)
  1. ;
  1. S ^TMP("XUMF ARRAY",$J,IFN,VUID,$P(HLNODE,HLFS,2))=$P(HLNODE,HLFS,3)
  1. ;
  1. Q
  1. ;
  1. ADD ; -- ADD-processing logic
  1. ;
  1. N X
  1. ;
  1. S X=$G(^DIC(4.001,+IFN,3)) X:X'="" X
  1. ;
  1. Q
  1. ;
  1. MFE0 ; -- MFE-processing logic
  1. ;if creating a new entry you must set IEN and other tasks performed in STUB^XUMF0 (if appropriate)
  1. ;
  1. N X
  1. ;
  1. S X=$G(^DIC(4.001,+IFN,4)) X:X'="" X
  1. ;
  1. Q
  1. ;
  1. ZRT0 ; -- ZRT-processing logic
  1. ;
  1. N X
  1. ;
  1. S X=$G(^DIC(4.001,+IFN,5)) X:X'="" X
  1. ;
  1. Q
  1. ;
  1. POST ; -- post-processing logic
  1. ;
  1. N X
  1. ;
  1. S X=$G(^DIC(4.001,+IFN,2)) X:X'="" X
  1. ;
  1. Q
  1. ;
  1. EXIT ; -- cleanup, and quit
  1. ;
  1. K ^TMP("DILIST",$J),^TMP("DIERR",$J),^TMP("HLS",$J),^TMP("HLA",$J)
  1. ;
  1. K ^TMP("XUMF MFS",$J),^TMP("XUMF ERROR",$J),^TMP("XUMF EVENT",$J)
  1. ;
  1. Q
  1. ;
  1. REPLY ; -- MFK
  1. ;
  1. N X,I,I1,I2,CNT
  1. ;
  1. S CNT=1
  1. S X="MSA"_HLFS_$S(ERROR:"AE",1:"AA")_HLFS_HL("MID")_HLFS_$P(ERROR,U,2)
  1. S ^TMP("HLA",$J,CNT)=X
  1. S CNT=CNT+1
  1. ;
  1. S I1="",I=0
  1. F S I1=$O(^TMP("XUMF ERROR",$J,I1)) Q:'$L(I1) D
  1. .S I2="" F S I2=$O(^TMP("XUMF ERROR",$J,I1,I2)) Q:'$L(I2) D
  1. ..S X=$G(^(I2))
  1. ..Q:'$L(X)
  1. ..S I=I+1
  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
  1. ..S ^TMP("HLA",$J,CNT)=X
  1. ..S CNT=CNT+1
  1. ;
  1. D:ERROR EM^XUMF0
  1. ;
  1. D GENACK^HLMA1($G(HL("EID")),$G(HLMTIENS),$G(HL("EIDS")),"GM",1,.HLRESLT)
  1. ;
  1. Q
  1. ;
  1. EM(ERROR,ERR) ; -- error message
  1. ;
  1. N X,I,Y
  1. ;
  1. D MSG^DIALOG("AM",.X,80,,"ERR")
  1. ;
  1. S ERRCNT=ERRCNT+1
  1. ;
  1. S ^TMP("XUMF ERROR",$J,ERRCNT_".01")=""
  1. S ^TMP("XUMF ERROR",$J,ERRCNT_".02")=""
  1. S ^TMP("XUMF ERROR",$J,ERRCNT_".03")=$G(ERROR)
  1. S ^TMP("XUMF ERROR",$J,ERRCNT_".04")=""
  1. S ^TMP("XUMF ERROR",$J,ERRCNT_".05")="VUID: "_$G(VUID)_" IFN: "_$G(IFN)_" IEN: "_IEN
  1. S ^TMP("XUMF ERROR",$J,ERRCNT_".06")=""
  1. S X=.9 F S X=$O(X(X)) Q:'X D
  1. .S ^TMP("XUMF ERROR",$J,ERRCNT_"."_X)=X(X)
  1. ;
  1. Q
  1. ;
  1. STATUS ;
  1. ;
  1. I VALUE=$P($$GETSTAT^XTID(IFN,,IEN_","),U) Q
  1. ;
  1. I SUBFILE="" S ERROR="1^status parameter error" Q
  1. ;
  1. N FDA
  1. S FDA(SUBFILE,"?+1,"_IENS,.01)=$$NOW^XLFDT
  1. S FDA(SUBFILE,"?+1,"_IENS,.02)=VALUE
  1. D UPDATE^DIE(,"FDA",,"ERR")
  1. I $D(ERR) D
  1. .S ERROR="1^effective date and status error"
  1. .D EM(ERROR,.ERR) K ERR
  1. ;
  1. Q
  1. ;
  1. WP ;
  1. ;
  1. N X,Y,A,I,CNT,X1,X2,ESC
  1. D SEGPRSE^XUMFXHL7("HLNODE","X",HLFS,60)
  1. ;
  1. S CNT=1
  1. S A(CNT)=X(2)
  1. S I=0
  1. F S I=$O(X(2,I)) Q:'I D
  1. .S Y=X(2,I)
  1. .I $E(Y,1)=" " D Q
  1. ..S A(CNT)=A(CNT)_" "
  1. ..Q:$P(Y," ",2)=""
  1. ..S CNT=CNT+1
  1. ..S A(CNT)=$P(Y," ",2,99)
  1. .S X1=$P(Y," ",1)
  1. .S X2=$P(Y," ",2,99)
  1. .S A(CNT)=A(CNT)_X1_$S(X2="":"",1:" ")
  1. .Q:X2=""
  1. .S CNT=CNT+1
  1. .S A(CNT)=X2
  1. ;
  1. D UNESCWP^XUMF0(.A,.HL)
  1. ;
  1. D WP^DIE(IFN,IENS,FIELD,"K","A","ERR")
  1. ;
  1. I $D(ERR) D
  1. .S ERROR="1^wp field error"
  1. .D EM(ERROR,.ERR) K ERR
  1. ;
  1. Q
  1. ;
  1. RECORD ;MFS event protocol data
  1. ;
  1. N ROOT,NODE,NODE1,CHANGE,STATUS
  1. ;
  1. I $G(ERROR) D Q
  1. .S ^TMP("XUMF EVENT",$J,"ERROR")=ERROR
  1. .S ^TMP("XUMF EVENT",$J,"ERROR",1)=$G(IFN)_U_$G(IEN)
  1. ;
  1. S ROOT=$$ROOT^DILFD(IFN,,1)
  1. M RECORD("AFTER")=@ROOT@(IEN)
  1. ;
  1. I $G(RECORD("NEW")) M ^TMP("XUMF EVENT",$J,IFN,"NEW",IEN)=RECORD("AFTER") Q
  1. ;
  1. S ^TMP("XUMF EVENT",$J,IFN,"AFTER",IEN,"REPLACED BY")=$P($G(@ROOT@(IEN,"VUID")),U,3)
  1. S ^TMP("XUMF EVENT",$J,IFN,"AFTER",IEN,"INHERITS FROM")=$$RPLCMNT^XTIDTRM(IFN,IEN)
  1. ;
  1. S STATUS=$$GETSTAT^XTID(IFN,,IEN_",")
  1. I RECORD("STATUS")'=STATUS D
  1. .S ^TMP("XUMF EVENT",$J,IFN,"STATUS",IEN)=$P(RECORD("STATUS"),U,1,2)_U_$P(STATUS,U,1,2)
  1. ;
  1. S NODE=$Q(RECORD("AFTER","")),NODE1=$Q(RECORD("BEFORE","")),CHANGE=0
  1. I $P(NODE,"RECORD(""AFTER")'=$P(NODE1,"RECORD(""BEFORE") S CHANGE=1
  1. I @NODE'=@NODE1 S CHANGE=1
  1. I 'CHANGE FOR SET NODE=$Q(@NODE) Q:NODE=""!(NODE["(""BEFORE") D Q:CHANGE
  1. .S NODE1=$Q(@NODE1) I NODE1="" S CHANGE=1 Q
  1. .I $P(NODE,"RECORD(""AFTER")'=$P(NODE1,"RECORD(""BEFORE") S CHANGE=1 Q
  1. .I @NODE'=@NODE1 S CHANGE=1 Q
  1. ;
  1. I CHANGE D
  1. .M ^TMP("XUMF EVENT",$J,IFN,"AFTER",IEN)=RECORD("AFTER")
  1. .M ^TMP("XUMF EVENT",$J,IFN,"BEFORE",IEN)=RECORD("BEFORE")
  1. ;
  1. Q
  1. ;