XUMFH ;CIOFO-SF/RAM - Master File HL7 Msg Handler ;11/16/05
;;8.0;KERNEL;**206,209,217,218,262,335,261,390,369,416**;Jul 10, 1995;Build 5
;
; 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
N QID,WHAT,WHO,HLSCS,CDSYS,ERRCNT,IDX98
;
D INIT,PROCESS,REPLY,EXIT
;
Q
;
INIT ; -- initialize
;
K ^TMP("DILIST",$J),^TMP("DIERR",$J)
K ^TMP("HLS",$J),^TMP("HLA",$J),^TMP("XUMF ERROR",$J)
;
S (ERROR,CNT,TYPE,ARRAY,ERRCNT)=0
S HLFS=HL("FS"),HLCS=$E(HL("ECH")),HLSCS=$E(HL("ECH"),4)
;
Q
;
PROCESS ; -- pull message text
;
F X HLNEXT Q:HLQUIT'>0 D
.Q:$P(HLNODE,HLFS)=""
.D @($P(HLNODE,HLFS))
;
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(ERROR,.ERR)
;
Q
;
QRD ; -- QRD segment
;
Q:ERROR
;
S QRD="QRD,QDT,QFC,QP,QID,DRT,DRDT,QLR,WHO,WHAT,WDDC,WDCVQ,QRL"
;
F I=2:1:13 S PARAM($P(QRD,",",I))=$P(HLNODE,HLFS,I)
S QID=$P(HLNODE,HLFS,5)
S WHO=$P(HLNODE,HLFS,9)
I WHO="" D Q
.S ERROR="1^QRD segment has null missing WHO parameter"
.D EM(ERROR,.ERR)
S WHAT=$P(HLNODE,HLFS,10)
I WHAT="" D Q
.S ERROR="1^QRD segment has null missing WHAT parameter"
.D EM(ERROR,.ERR)
;
S ARRAY=$S(QID["ARRAY":1,1:0)
S ALL=$S(WHO["ALL":1,1:0)
S GROUP=$S(ALL:1,(WHO["IEN"):1,1:0)
;
S:ARRAY TYPE=$S(GROUP:7,1:3)
S:'ARRAY TYPE=$S(GROUP:5,1:1)
S:HL("MTN")="MFR" TYPE=TYPE+10
;
S IFN=+WHAT
S XREF=$P(WHO,HLCS,9),ROOT=$$ROOT^DILFD(IFN,,1)
S IEN=$O(@ROOT@(XREF,$P(WHO,HLCS),0))
S IEN=$S(IEN:IEN,1:$P(WHO,HLCS))
S:$L(XREF)>1 PARAM("CDSYS")=XREF
;
K:ARRAY ^TMP("XUMF ARRAY",$J)
;
Q
;
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 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)
;
Q
;
MFE ; -- MFE segment
;
Q:ERROR
;Q:$G(IEN)
;
S KEY=$P(HLNODE,HLFS,5) Q:ARRAY
;
I $P(KEY,HLCS)="" D Q
.D EM("MFE segment NULL key "_$E(HLNODE,1,80),.ERR)
.
S XREF=$P(KEY,HLCS,3)
S CDSYS=$S($L(XREF)>1:XREF,1:"")
;
S IEN=$S(CDSYS'="":$$IEN^XUMF(IFN,CDSYS,$P(KEY,HLCS)),1:$$FIND1^DIC(IFN,,"BX",$P(KEY,HLCS),XREF,,"ERR"))
S IEN=$S(IEN:IEN,KEY["ALL":"ALL",$G(ERR)'="":"ERROR",1:"NEW")
I IEN="ERROR" D Q
.D EM("MFE segment couldn't resolve IEN",.ERR)
.K ERR
D MAIN^XUMFP(IFN,IEN,TYPE,.PARAM,.ERROR)
;
Q
;
ZL7 ; -- Generic Master File
ZIN ; -- VHA Institution segment
ZFT ; -- VHA Facility Type segment
LOC ; -- Location Identification segment
ZZZ ; -- get [Z...] segment(s)
;
Q:ERROR
Q:IEN="ERROR"
;
I $G(ARRAY) D ARRAY Q
;
N FDA,IENS,FIELD,ERR,PRE,POST,XUMF,MULT,FDA1,SEQ,SEQ1,SEQ2,SEQ3,XUMFSEQ
;
D SEGPRSE^XUMFXHL7("HLNODE","XUMFSEQ")
;
I IFN=4,CDSYS'="",XUMFSEQ(2)'="",'$D(^DIC(4,"D",XUMFSEQ(2),IEN)) D Q
.D EM("Coding system/station number mismatch - record "_KEY_" not updated",.ERR)
;
S PRE=$G(^TMP("XUMF MFS",$J,"PARAM","PRE"))
D:PRE'="" @(PRE)
;
S XUMF=7
;
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
.I IFN=4,SEQ=17 D NPI^XUMF Q
.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()
..S VALUE=$S(SEQ2:XUMFSEQ($P(SEQ,".")),1:XUMFSEQ(SEQ))
..S:SEQ2 VALUE=$$VAL2()
..S VALUE=$$DTYP^XUMFP(VALUE,TYP,HLCS,0)
..S FDA(IFN,IENS,FIELD)=VALUE
..D UPDATE^DIE("E","FDA","IEN1","ERR")
..I $D(ERR) D
...D EM("Update DIE - error message",.ERR)
...K ERR
..;NEW RECORD
..I $D(IEN1) D
...S IENS=IEN1(1)_","
...D CDSYS^XUMF(CDSYS,$P(KEY,HLCS),IEN1(1))
.I 'FIELD D SUBFILE Q
.S TYP=$G(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,FIELD))
.;S VALUE=$$VALUE()
.S VALUE=$S(SEQ2:XUMFSEQ($P(SEQ,".")),1:XUMFSEQ(SEQ))
.S:SEQ2 VALUE=$$VAL2()
.S VALUE=$$DTYP^XUMFP(VALUE,TYP,HLCS,0)
.S FDA(IFN,IENS,FIELD)=VALUE
;
M FDA=FDA1
;
D FILE^DIE("E","FDA","ERR")
I $D(ERR) D
.D EM("File DIE -- error message",.ERR)
.K ERR
;
S POST=$G(^TMP("XUMF MFS",$J,"PARAM","POST"))
D:POST'="" @(POST)
;
K IEN
;
Q
;
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()
S VALUE=$S(SEQ2:XUMFSEQ($P(SEQ,".")),1:XUMFSEQ(SEQ))
S:SEQ2 VALUE=$$VAL2()
S VALUE=$$DTYP^XUMFP(VALUE,TYP,HLCS,0)
;
S MULT=$G(^TMP("XUMF MFS",$J,"PARAM","MULT",SEG,SEQ))
S MKEY=$G(^TMP("XUMF MFS",$J,"PARAM","MKEY",SEG,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
;
Q
;
VALUE() ; -- parse segment
;
;Q
;
;N COL
;
;D SEGPRSE^XUMFXHL7("HLNODE","COL")
;
;Q:SEQ2 COL($P(SEQ,"."))
;
;Q COL(SEQ)
;
;
VAL2() ; -- parse component
;
N XXX
;
D SEQPRSE^XUMFXHL7("VALUE","XXX")
;
Q XXX(1,SEQ2)
;
;
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()
.S VALUE=$S(SEQ2:XUMFSEQ($P(SEQ,".")),1:XUMFSEQ(SEQ))
.S VALUE=$$VAL2()
.S VALUE=$P(VALUE,HLSCS,SEQ3)
.S VALUE=$$DTYP^XUMFP(VALUE,TYP,HLSCS,0)
.S FDA(IFN,IENS,FIELD)=VALUE
;
Q
;
ARRAY ; -- query data stored in array (not filed)
;
I $P($G(KEY),HLCS)="" D Q
.D EM("Null KEY found in the following segment: "_$E(HLNODE,1,80),.ERR)
.S ERROR=ERROR_U_$G(ERR)
;
I $G(IFN)=9.8 D Q
.S IDX98=$G(IDX98)+1
.S ^TMP("XUMF ARRAY",$J,IDX98)=HLNODE
;
M ^TMP("XUMF ARRAY",$J,$P(KEY,HLCS))=HLNODE
;
Q
;
REPLY ; -- master file response
;
Q:HL("MTN")="MFR"
Q:HL("MTN")="MFK"
Q:HL("MTN")="ACK"
;
S:(TYPE<10) TYPE=(TYPE+10)
;
I HL("MTN")="MFQ" D
.S IFN=+$G(WHAT) I 'IFN D Q
..S ERROR="1^REPLY MFQ couldn't resolve IFN"
..D EM(ERROR,.ERR)
.S XREF=$P(WHO,HLCS,9),ROOT=$$ROOT^DILFD(IFN,,1)
.S IEN=$O(@ROOT@(XREF,$P(WHO,HLCS),0))
.S IEN=$S(IEN:IEN,1:$P(WHO,HLCS))
;
S IFN=$G(IFN),IEN=$G(IEN)
;
D MAIN^XUMFP(IFN,IEN,TYPE,.PARAM,.ERROR)
D MAIN^XUMFI(IFN,IEN,TYPE,.PARAM,.ERROR)
;
Q
;
EXIT ; -- cleanup, and quit
;
I $D(^TMP("XUMF ERROR",$J)) D EM1 K ^TMP("XUMF ERROR",$J)
;
K ^TMP("DILIST",$J),^TMP("DIERR",$J),^TMP("HLS",$J),^TMP("HLA",$J)
;
Q
;
EM(ERROR,ERR) ; -- error message
;
D EM^XUMFHM(ERROR,.ERR)
;
Q
;
;
;N X,I,Y,XMTEXT,FLG
;
;S FLG=0
;
;D MSG^DIALOG("AM",.X,80,,"ERR")
;
;S X(.02)="",X(.03)=$G(ERROR),X(.04)=""
;
;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 X(X)["ASSOCIATION" S FLG=1 K X(X) Q
;.I X(X)["INSTITUTION" S FLG=1 K X(X) Q
;.I X(X)["The entry does not exist." S FLG=1 K X(X) Q
;.I X(X)["already exists." S FLG=1 K X(X) Q
;
;I FLG Q:'$O(X(.9))
;
;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")="KEY: "_$G(KEY)_" IFN: "_$G(IFN)_" IEN: "_$G(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
;
EM1 ;
;
D EM1^XUMFHM
;
Q
;
;N XMY,XMSUB
;
;S ^TMP("XUMF ERROR",$J,.1)="HL7 message ID: "_$G(HL("MID"))
;S XMY("G.XUMF ERROR")="",XMSUB="MFS ERROR"
;S XMTEXT="^TMP(""XUMF ERROR"",$J,"
;
;D ^XMD
;
;Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMFH 8771 printed Sep 23, 2025@19:46:59 Page 2
XUMFH ;CIOFO-SF/RAM - Master File HL7 Msg Handler ;11/16/05
+1 ;;8.0;KERNEL;**206,209,217,218,262,335,261,390,369,416**;Jul 10, 1995;Build 5
+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,ARRAY
+3 NEW HDT,KEY,MID,REASON,VALUE,XREF,ALL,GROUP,PARAM,ROOT,SEG,QRD
+4 NEW QID,WHAT,WHO,HLSCS,CDSYS,ERRCNT,IDX98
+5 ;
+6 DO INIT
DO PROCESS
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),^TMP("XUMF ERROR",$JOB)
+4 ;
+5 SET (ERROR,CNT,TYPE,ARRAY,ERRCNT)=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 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(ERROR,.ERR)
End DoDot:1
+9 ;
+10 QUIT
+11 ;
QRD ; -- QRD segment
+1 ;
+2 if ERROR
QUIT
+3 ;
+4 SET QRD="QRD,QDT,QFC,QP,QID,DRT,DRDT,QLR,WHO,WHAT,WDDC,WDCVQ,QRL"
+5 ;
+6 FOR I=2:1:13
SET PARAM($PIECE(QRD,",",I))=$PIECE(HLNODE,HLFS,I)
+7 SET QID=$PIECE(HLNODE,HLFS,5)
+8 SET WHO=$PIECE(HLNODE,HLFS,9)
+9 IF WHO=""
Begin DoDot:1
+10 SET ERROR="1^QRD segment has null missing WHO parameter"
+11 DO EM(ERROR,.ERR)
End DoDot:1
QUIT
+12 SET WHAT=$PIECE(HLNODE,HLFS,10)
+13 IF WHAT=""
Begin DoDot:1
+14 SET ERROR="1^QRD segment has null missing WHAT parameter"
+15 DO EM(ERROR,.ERR)
End DoDot:1
QUIT
+16 ;
+17 SET ARRAY=$SELECT(QID["ARRAY":1,1:0)
+18 SET ALL=$SELECT(WHO["ALL":1,1:0)
+19 SET GROUP=$SELECT(ALL:1,(WHO["IEN"):1,1:0)
+20 ;
+21 if ARRAY
SET TYPE=$SELECT(GROUP:7,1:3)
+22 if 'ARRAY
SET TYPE=$SELECT(GROUP:5,1:1)
+23 if HL("MTN")="MFR"
SET TYPE=TYPE+10
+24 ;
+25 SET IFN=+WHAT
+26 SET XREF=$PIECE(WHO,HLCS,9)
SET ROOT=$$ROOT^DILFD(IFN,,1)
+27 SET IEN=$ORDER(@ROOT@(XREF,$PIECE(WHO,HLCS),0))
+28 SET IEN=$SELECT(IEN:IEN,1:$PIECE(WHO,HLCS))
+29 if $LENGTH(XREF)>1
SET PARAM("CDSYS")=XREF
+30 ;
+31 if ARRAY
KILL ^TMP("XUMF ARRAY",$JOB)
+32 ;
+33 QUIT
+34 ;
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)
End DoDot:1
QUIT
+8 SET IFN=$$MFI^XUMFP($PIECE(HLNODE,HLFS,2))
+9 IF 'IFN
Begin DoDot:1
+10 SET ERROR="1^IFN in MFI could not be resolved"
+11 DO EM(ERROR,.ERR)
End DoDot:1
QUIT
+12 ;
+13 QUIT
+14 ;
MFE ; -- MFE segment
+1 ;
+2 if ERROR
QUIT
+3 ;Q:$G(IEN)
+4 ;
+5 SET KEY=$PIECE(HLNODE,HLFS,5)
if ARRAY
QUIT
+6 ;
+7 IF $PIECE(KEY,HLCS)=""
Begin DoDot:1
+8 DO EM("MFE segment NULL key "_$EXTRACT(HLNODE,1,80),.ERR)
+9 End DoDot:1
QUIT
+10 SET XREF=$PIECE(KEY,HLCS,3)
+11 SET CDSYS=$SELECT($LENGTH(XREF)>1:XREF,1:"")
+12 ;
+13 SET IEN=$SELECT(CDSYS'="":$$IEN^XUMF(IFN,CDSYS,$PIECE(KEY,HLCS)),1:$$FIND1^DIC(IFN,,"BX",$PIECE(KEY,HLCS),XREF,,"ERR"))
+14 SET IEN=$SELECT(IEN:IEN,KEY["ALL":"ALL",$GET(ERR)'="":"ERROR",1:"NEW")
+15 IF IEN="ERROR"
Begin DoDot:1
+16 DO EM("MFE segment couldn't resolve IEN",.ERR)
+17 KILL ERR
End DoDot:1
QUIT
+18 DO MAIN^XUMFP(IFN,IEN,TYPE,.PARAM,.ERROR)
+19 ;
+20 QUIT
+21 ;
ZL7 ; -- Generic Master File
ZIN ; -- VHA Institution segment
ZFT ; -- VHA Facility Type segment
LOC ; -- Location Identification segment
ZZZ ; -- get [Z...] segment(s)
+1 ;
+2 if ERROR
QUIT
+3 if IEN="ERROR"
QUIT
+4 ;
+5 IF $GET(ARRAY)
DO ARRAY
QUIT
+6 ;
+7 NEW FDA,IENS,FIELD,ERR,PRE,POST,XUMF,MULT,FDA1,SEQ,SEQ1,SEQ2,SEQ3,XUMFSEQ
+8 ;
+9 DO SEGPRSE^XUMFXHL7("HLNODE","XUMFSEQ")
+10 ;
+11 IF IFN=4
IF CDSYS'=""
IF XUMFSEQ(2)'=""
IF '$DATA(^DIC(4,"D",XUMFSEQ(2),IEN))
Begin DoDot:1
+12 DO EM("Coding system/station number mismatch - record "_KEY_" not updated",.ERR)
End DoDot:1
QUIT
+13 ;
+14 SET PRE=$GET(^TMP("XUMF MFS",$JOB,"PARAM","PRE"))
+15 if PRE'=""
DO @(PRE)
+16 ;
+17 SET XUMF=7
+18 ;
+19 SET SEG=$PIECE(HLNODE,HLFS)
+20 SET IENS=$SELECT(IEN:IEN,1:"+1")_","
+21 SET SEQ=0
+22 FOR
SET SEQ=$ORDER(^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+23 IF IFN=4
IF SEQ=17
DO NPI^XUMF
QUIT
+24 SET SEQ1=$PIECE(SEQ,".")
SET SEQ2=$PIECE(SEQ,".",2)
+25 SET SEQ3=$ORDER(^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",0))
+26 IF SEQ3
DO SUBCOMP
QUIT
+27 SET FIELD=$ORDER(^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ,0))
+28 IF FIELD=".01"
Begin DoDot:2
+29 NEW FDA,IEN1
+30 SET TYP=$GET(^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ,FIELD))
+31 ;S VALUE=$$VALUE()
+32 SET VALUE=$SELECT(SEQ2:XUMFSEQ($PIECE(SEQ,".")),1:XUMFSEQ(SEQ))
+33 if SEQ2
SET VALUE=$$VAL2()
+34 SET VALUE=$$DTYP^XUMFP(VALUE,TYP,HLCS,0)
+35 SET FDA(IFN,IENS,FIELD)=VALUE
+36 DO UPDATE^DIE("E","FDA","IEN1","ERR")
+37 IF $DATA(ERR)
Begin DoDot:3
+38 DO EM("Update DIE - error message",.ERR)
+39 KILL ERR
End DoDot:3
+40 ;NEW RECORD
+41 IF $DATA(IEN1)
Begin DoDot:3
+42 SET IENS=IEN1(1)_","
+43 DO CDSYS^XUMF(CDSYS,$PIECE(KEY,HLCS),IEN1(1))
End DoDot:3
End DoDot:2
+44 IF 'FIELD
DO SUBFILE
QUIT
+45 SET TYP=$GET(^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ,FIELD))
+46 ;S VALUE=$$VALUE()
+47 SET VALUE=$SELECT(SEQ2:XUMFSEQ($PIECE(SEQ,".")),1:XUMFSEQ(SEQ))
+48 if SEQ2
SET VALUE=$$VAL2()
+49 SET VALUE=$$DTYP^XUMFP(VALUE,TYP,HLCS,0)
+50 SET FDA(IFN,IENS,FIELD)=VALUE
End DoDot:1
+51 ;
+52 MERGE FDA=FDA1
+53 ;
+54 DO FILE^DIE("E","FDA","ERR")
+55 IF $DATA(ERR)
Begin DoDot:1
+56 DO EM("File DIE -- error message",.ERR)
+57 KILL ERR
End DoDot:1
+58 ;
+59 SET POST=$GET(^TMP("XUMF MFS",$JOB,"PARAM","POST"))
+60 if POST'=""
DO @(POST)
+61 ;
+62 KILL IEN
+63 ;
+64 QUIT
+65 ;
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 ;S VALUE=$$VALUE()
+8 SET VALUE=$SELECT(SEQ2:XUMFSEQ($PIECE(SEQ,".")),1:XUMFSEQ(SEQ))
+9 if SEQ2
SET VALUE=$$VAL2()
+10 SET VALUE=$$DTYP^XUMFP(VALUE,TYP,HLCS,0)
+11 ;
+12 SET MULT=$GET(^TMP("XUMF MFS",$JOB,"PARAM","MULT",SEG,SEQ))
+13 SET MKEY=$GET(^TMP("XUMF MFS",$JOB,"PARAM","MKEY",SEG,SEQ))
+14 IF MULT=SEQ
if VALUE=""
QUIT
Begin DoDot:1
+15 NEW FDA,IEN
+16 SET FDA(IFN,"?+1,"_IENS,.01)=VALUE
+17 DO UPDATE^DIE("E","FDA","IEN","ERR")
+18 IF $DATA(ERR)
Begin DoDot:2
+19 DO EM("update DIE call error message in SUBFILE",.ERR)
+20 KILL ERR
End DoDot:2
+21 SET IENS1=IEN(1)_","_IENS
SET MULT(SEQ)=IENS1
End DoDot:1
+22 IF 'MULT
Begin DoDot:1
+23 NEW FDA,IEN
+24 SET FDA(IFN,"?+1,"_IENS,.01)=MKEY
+25 DO UPDATE^DIE("E","FDA","IEN","ERR")
+26 IF $DATA(ERR)
Begin DoDot:2
+27 DO EM("update DIE call error message in SUBFILE",.ERR)
+28 KILL ERR
End DoDot:2
+29 SET IENS1=IEN(1)_","_IENS
SET MULT(SEQ)=IENS1
+30 SET FDA1(IFN,IENS1,.01)=MKEY
End DoDot:1
+31 IF MULT
IF MULT'=SEQ
SET IENS1=$GET(MULT(+MULT))
if IENS1=""
QUIT
+32 SET FDA1(IFN,IENS1,FIELD)=VALUE
+33 ;
+34 QUIT
+35 ;
VALUE() ; -- parse segment
+1 ;
+2 ;Q
+3 ;
+4 ;N COL
+5 ;
+6 ;D SEGPRSE^XUMFXHL7("HLNODE","COL")
+7 ;
+8 ;Q:SEQ2 COL($P(SEQ,"."))
+9 ;
+10 ;Q COL(SEQ)
+11 ;
+12 ;
VAL2() ; -- parse component
+1 ;
+2 NEW XXX
+3 ;
+4 DO SEQPRSE^XUMFXHL7("VALUE","XXX")
+5 ;
+6 QUIT XXX(1,SEQ2)
+7 ;
+8 ;
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 ;S VALUE=$$VALUE()
+7 SET VALUE=$SELECT(SEQ2:XUMFSEQ($PIECE(SEQ,".")),1:XUMFSEQ(SEQ))
+8 SET VALUE=$$VAL2()
+9 SET VALUE=$PIECE(VALUE,HLSCS,SEQ3)
+10 SET VALUE=$$DTYP^XUMFP(VALUE,TYP,HLSCS,0)
+11 SET FDA(IFN,IENS,FIELD)=VALUE
End DoDot:1
+12 ;
+13 QUIT
+14 ;
ARRAY ; -- query data stored in array (not filed)
+1 ;
+2 IF $PIECE($GET(KEY),HLCS)=""
Begin DoDot:1
+3 DO EM("Null KEY found in the following segment: "_$EXTRACT(HLNODE,1,80),.ERR)
+4 SET ERROR=ERROR_U_$GET(ERR)
End DoDot:1
QUIT
+5 ;
+6 IF $GET(IFN)=9.8
Begin DoDot:1
+7 SET IDX98=$GET(IDX98)+1
+8 SET ^TMP("XUMF ARRAY",$JOB,IDX98)=HLNODE
End DoDot:1
QUIT
+9 ;
+10 MERGE ^TMP("XUMF ARRAY",$JOB,$PIECE(KEY,HLCS))=HLNODE
+11 ;
+12 QUIT
+13 ;
REPLY ; -- master file response
+1 ;
+2 if HL("MTN")="MFR"
QUIT
+3 if HL("MTN")="MFK"
QUIT
+4 if HL("MTN")="ACK"
QUIT
+5 ;
+6 if (TYPE<10)
SET TYPE=(TYPE+10)
+7 ;
+8 IF HL("MTN")="MFQ"
Begin DoDot:1
+9 SET IFN=+$GET(WHAT)
IF 'IFN
Begin DoDot:2
+10 SET ERROR="1^REPLY MFQ couldn't resolve IFN"
+11 DO EM(ERROR,.ERR)
End DoDot:2
QUIT
+12 SET XREF=$PIECE(WHO,HLCS,9)
SET ROOT=$$ROOT^DILFD(IFN,,1)
+13 SET IEN=$ORDER(@ROOT@(XREF,$PIECE(WHO,HLCS),0))
+14 SET IEN=$SELECT(IEN:IEN,1:$PIECE(WHO,HLCS))
End DoDot:1
+15 ;
+16 SET IFN=$GET(IFN)
SET IEN=$GET(IEN)
+17 ;
+18 DO MAIN^XUMFP(IFN,IEN,TYPE,.PARAM,.ERROR)
+19 DO MAIN^XUMFI(IFN,IEN,TYPE,.PARAM,.ERROR)
+20 ;
+21 QUIT
+22 ;
EXIT ; -- cleanup, and quit
+1 ;
+2 IF $DATA(^TMP("XUMF ERROR",$JOB))
DO EM1
KILL ^TMP("XUMF ERROR",$JOB)
+3 ;
+4 KILL ^TMP("DILIST",$JOB),^TMP("DIERR",$JOB),^TMP("HLS",$JOB),^TMP("HLA",$JOB)
+5 ;
+6 QUIT
+7 ;
EM(ERROR,ERR) ; -- error message
+1 ;
+2 DO EM^XUMFHM(ERROR,.ERR)
+3 ;
+4 QUIT
+5 ;
+6 ;
+7 ;N X,I,Y,XMTEXT,FLG
+8 ;
+9 ;S FLG=0
+10 ;
+11 ;D MSG^DIALOG("AM",.X,80,,"ERR")
+12 ;
+13 ;S X(.02)="",X(.03)=$G(ERROR),X(.04)=""
+14 ;
+15 ;S X=.9 F S X=$O(X(X)) Q:'X D
+16 ;.I X(X)="" K X(X) Q
+17 ;.I X(X)["DINUMed field cannot" S FLG=1 K X(X) Q
+18 ;.I X(X)["ASSOCIATION" S FLG=1 K X(X) Q
+19 ;.I X(X)["INSTITUTION" S FLG=1 K X(X) Q
+20 ;.I X(X)["The entry does not exist." S FLG=1 K X(X) Q
+21 ;.I X(X)["already exists." S FLG=1 K X(X) Q
+22 ;
+23 ;I FLG Q:'$O(X(.9))
+24 ;
+25 ;S ERRCNT=ERRCNT+1
+26 ;
+27 ;S ^TMP("XUMF ERROR",$J,ERRCNT_".01")=""
+28 ;S ^TMP("XUMF ERROR",$J,ERRCNT_".02")=""
+29 ;S ^TMP("XUMF ERROR",$J,ERRCNT_".03")=$G(ERROR)
+30 ;S ^TMP("XUMF ERROR",$J,ERRCNT_".04")=""
+31 ;S ^TMP("XUMF ERROR",$J,ERRCNT_".05")="KEY: "_$G(KEY)_" IFN: "_$G(IFN)_" IEN: "_$G(IEN)
+32 ;S ^TMP("XUMF ERROR",$J,ERRCNT_".06")=""
+33 ;S X=.9 F S X=$O(X(X)) Q:'X D
+34 ;.S ^TMP("XUMF ERROR",$J,ERRCNT_"."_X)=X(X)
+35 ;
+36 ;Q
+37 ;
EM1 ;
+1 ;
+2 DO EM1^XUMFHM
+3 ;
+4 QUIT
+5 ;
+6 ;N XMY,XMSUB
+7 ;
+8 ;S ^TMP("XUMF ERROR",$J,.1)="HL7 message ID: "_$G(HL("MID"))
+9 ;S XMY("G.XUMF ERROR")="",XMSUB="MFS ERROR"
+10 ;S XMTEXT="^TMP(""XUMF ERROR"",$J,"
+11 ;
+12 ;D ^XMD
+13 ;
+14 ;Q
+15 ;
