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