408 lines
8.7 KiB
Mathematica
408 lines
8.7 KiB
Mathematica
XUMF1H ;ISS/RAM - MFS Handler ;6/27/06 07:50
|
|
;;8.0;KERNEL;**407**;Jul 10, 1995;Build 8
|
|
;
|
|
; 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
|
|
;
|
|
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)
|
|
;
|
|
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(IFN) D 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(IFN),(IFN'=$O(^DIC(4.001,"MFID",MFI,0))) D POST
|
|
;
|
|
K IFN,IEN,PRE,POST,VUID,IMPLY
|
|
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
|
|
;
|
|
D 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
|
|
;
|
|
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)
|
|
;
|
|
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
|
|
;
|
|
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)
|
|
;
|
|
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)
|
|
;
|
|
; check for error
|
|
;I ($P($G(HLRESLT),U,3)'="") D Q
|
|
;.S ERROR=1_U_$P(HLRESLT,HLFS,3)_U_$P(HLRESLT,HLFS,2)_U_$P(HLRESLT,U)
|
|
;
|
|
; successful call, message ID returned
|
|
;S ERROR="0^"_$P($G(HLRESLT),U,1)
|
|
;
|
|
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
|
|
;
|