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

XUMFH.m

Go to the documentation of this file.
  1. 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
  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
  1. N QID,WHAT,WHO,HLSCS,CDSYS,ERRCNT,IDX98
  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),^TMP("XUMF ERROR",$J)
  1. ;
  1. S (ERROR,CNT,TYPE,ARRAY,ERRCNT)=0
  1. S HLFS=HL("FS"),HLCS=$E(HL("ECH")),HLSCS=$E(HL("ECH"),4)
  1. ;
  1. Q
  1. ;
  1. PROCESS ; -- pull message text
  1. ;
  1. F X HLNEXT Q:HLQUIT'>0 D
  1. .Q:$P(HLNODE,HLFS)=""
  1. .D @($P(HLNODE,HLFS))
  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(ERROR,.ERR)
  1. ;
  1. Q
  1. ;
  1. QRD ; -- QRD segment
  1. ;
  1. Q:ERROR
  1. ;
  1. S QRD="QRD,QDT,QFC,QP,QID,DRT,DRDT,QLR,WHO,WHAT,WDDC,WDCVQ,QRL"
  1. ;
  1. F I=2:1:13 S PARAM($P(QRD,",",I))=$P(HLNODE,HLFS,I)
  1. S QID=$P(HLNODE,HLFS,5)
  1. S WHO=$P(HLNODE,HLFS,9)
  1. I WHO="" D Q
  1. .S ERROR="1^QRD segment has null missing WHO parameter"
  1. .D EM(ERROR,.ERR)
  1. S WHAT=$P(HLNODE,HLFS,10)
  1. I WHAT="" D Q
  1. .S ERROR="1^QRD segment has null missing WHAT parameter"
  1. .D EM(ERROR,.ERR)
  1. ;
  1. S ARRAY=$S(QID["ARRAY":1,1:0)
  1. S ALL=$S(WHO["ALL":1,1:0)
  1. S GROUP=$S(ALL:1,(WHO["IEN"):1,1:0)
  1. ;
  1. S:ARRAY TYPE=$S(GROUP:7,1:3)
  1. S:'ARRAY TYPE=$S(GROUP:5,1:1)
  1. S:HL("MTN")="MFR" TYPE=TYPE+10
  1. ;
  1. S IFN=+WHAT
  1. S XREF=$P(WHO,HLCS,9),ROOT=$$ROOT^DILFD(IFN,,1)
  1. S IEN=$O(@ROOT@(XREF,$P(WHO,HLCS),0))
  1. S IEN=$S(IEN:IEN,1:$P(WHO,HLCS))
  1. S:$L(XREF)>1 PARAM("CDSYS")=XREF
  1. ;
  1. K:ARRAY ^TMP("XUMF ARRAY",$J)
  1. ;
  1. Q
  1. ;
  1. MFI ; -- MFI segment
  1. ;
  1. Q:ERROR
  1. Q:$G(IFN)
  1. ;
  1. I $P(HLNODE,HLFS,2)="" D Q
  1. .S ERROR="1^MFI segment missing Master File Identifier"
  1. .D EM(ERROR,.ERR)
  1. S IFN=$$MFI^XUMFP($P(HLNODE,HLFS,2))
  1. I 'IFN D Q
  1. .S ERROR="1^IFN in MFI could not be resolved"
  1. .D EM(ERROR,.ERR)
  1. ;
  1. Q
  1. ;
  1. MFE ; -- MFE segment
  1. ;
  1. Q:ERROR
  1. ;Q:$G(IEN)
  1. ;
  1. S KEY=$P(HLNODE,HLFS,5) Q:ARRAY
  1. ;
  1. I $P(KEY,HLCS)="" D Q
  1. .D EM("MFE segment NULL key "_$E(HLNODE,1,80),.ERR)
  1. .
  1. S XREF=$P(KEY,HLCS,3)
  1. S CDSYS=$S($L(XREF)>1:XREF,1:"")
  1. ;
  1. S IEN=$S(CDSYS'="":$$IEN^XUMF(IFN,CDSYS,$P(KEY,HLCS)),1:$$FIND1^DIC(IFN,,"BX",$P(KEY,HLCS),XREF,,"ERR"))
  1. S IEN=$S(IEN:IEN,KEY["ALL":"ALL",$G(ERR)'="":"ERROR",1:"NEW")
  1. I IEN="ERROR" D Q
  1. .D EM("MFE segment couldn't resolve IEN",.ERR)
  1. .K ERR
  1. D MAIN^XUMFP(IFN,IEN,TYPE,.PARAM,.ERROR)
  1. ;
  1. Q
  1. ;
  1. ZL7 ; -- Generic Master File
  1. ZIN ; -- VHA Institution segment
  1. ZFT ; -- VHA Facility Type segment
  1. LOC ; -- Location Identification segment
  1. ZZZ ; -- get [Z...] segment(s)
  1. ;
  1. Q:ERROR
  1. Q:IEN="ERROR"
  1. ;
  1. I $G(ARRAY) D ARRAY Q
  1. ;
  1. N FDA,IENS,FIELD,ERR,PRE,POST,XUMF,MULT,FDA1,SEQ,SEQ1,SEQ2,SEQ3,XUMFSEQ
  1. ;
  1. D SEGPRSE^XUMFXHL7("HLNODE","XUMFSEQ")
  1. ;
  1. I IFN=4,CDSYS'="",XUMFSEQ(2)'="",'$D(^DIC(4,"D",XUMFSEQ(2),IEN)) D Q
  1. .D EM("Coding system/station number mismatch - record "_KEY_" not updated",.ERR)
  1. ;
  1. S PRE=$G(^TMP("XUMF MFS",$J,"PARAM","PRE"))
  1. D:PRE'="" @(PRE)
  1. ;
  1. S XUMF=7
  1. ;
  1. S SEG=$P(HLNODE,HLFS)
  1. S IENS=$S(IEN:IEN,1:"+1")_","
  1. S SEQ=0
  1. F S SEQ=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ)) Q:'SEQ D
  1. .I IFN=4,SEQ=17 D NPI^XUMF Q
  1. .S SEQ1=$P(SEQ,"."),SEQ2=$P(SEQ,".",2)
  1. .S SEQ3=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",0))
  1. .I SEQ3 D SUBCOMP Q
  1. .S FIELD=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,0))
  1. .I FIELD=".01" D
  1. ..N FDA,IEN1
  1. ..S TYP=$G(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,FIELD))
  1. ..;S VALUE=$$VALUE()
  1. ..S VALUE=$S(SEQ2:XUMFSEQ($P(SEQ,".")),1:XUMFSEQ(SEQ))
  1. ..S:SEQ2 VALUE=$$VAL2()
  1. ..S VALUE=$$DTYP^XUMFP(VALUE,TYP,HLCS,0)
  1. ..S FDA(IFN,IENS,FIELD)=VALUE
  1. ..D UPDATE^DIE("E","FDA","IEN1","ERR")
  1. ..I $D(ERR) D
  1. ...D EM("Update DIE - error message",.ERR)
  1. ...K ERR
  1. ..;NEW RECORD
  1. ..I $D(IEN1) D
  1. ...S IENS=IEN1(1)_","
  1. ...D CDSYS^XUMF(CDSYS,$P(KEY,HLCS),IEN1(1))
  1. .I 'FIELD D SUBFILE Q
  1. .S TYP=$G(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,FIELD))
  1. .;S VALUE=$$VALUE()
  1. .S VALUE=$S(SEQ2:XUMFSEQ($P(SEQ,".")),1:XUMFSEQ(SEQ))
  1. .S:SEQ2 VALUE=$$VAL2()
  1. .S VALUE=$$DTYP^XUMFP(VALUE,TYP,HLCS,0)
  1. .S FDA(IFN,IENS,FIELD)=VALUE
  1. ;
  1. M FDA=FDA1
  1. ;
  1. D FILE^DIE("E","FDA","ERR")
  1. I $D(ERR) D
  1. .D EM("File DIE -- error message",.ERR)
  1. .K ERR
  1. ;
  1. S POST=$G(^TMP("XUMF MFS",$J,"PARAM","POST"))
  1. D:POST'="" @(POST)
  1. ;
  1. K IEN
  1. ;
  1. Q
  1. ;
  1. SUBFILE ; -- process subfile record
  1. ;
  1. N IFN,IENS1,KEY1,FIELD,TYP,MKEY,ERR
  1. ;
  1. S IFN=^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"FILE")
  1. S FIELD=^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"FIELD")
  1. S TYP=^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"DTYP")
  1. ;S VALUE=$$VALUE()
  1. S VALUE=$S(SEQ2:XUMFSEQ($P(SEQ,".")),1:XUMFSEQ(SEQ))
  1. S:SEQ2 VALUE=$$VAL2()
  1. S VALUE=$$DTYP^XUMFP(VALUE,TYP,HLCS,0)
  1. ;
  1. S MULT=$G(^TMP("XUMF MFS",$J,"PARAM","MULT",SEG,SEQ))
  1. S MKEY=$G(^TMP("XUMF MFS",$J,"PARAM","MKEY",SEG,SEQ))
  1. I MULT=SEQ Q:VALUE="" D
  1. .N FDA,IEN
  1. .S FDA(IFN,"?+1,"_IENS,.01)=VALUE
  1. .D UPDATE^DIE("E","FDA","IEN","ERR")
  1. .I $D(ERR) D
  1. ..D EM("update DIE call error message in SUBFILE",.ERR)
  1. ..K ERR
  1. .S IENS1=IEN(1)_","_IENS,MULT(SEQ)=IENS1
  1. I 'MULT D
  1. .N FDA,IEN
  1. .S FDA(IFN,"?+1,"_IENS,.01)=MKEY
  1. .D UPDATE^DIE("E","FDA","IEN","ERR")
  1. .I $D(ERR) D
  1. ..D EM("update DIE call error message in SUBFILE",.ERR)
  1. ..K ERR
  1. .S IENS1=IEN(1)_","_IENS,MULT(SEQ)=IENS1
  1. .S FDA1(IFN,IENS1,.01)=MKEY
  1. I MULT,MULT'=SEQ S IENS1=$G(MULT(+MULT)) Q:IENS1=""
  1. S FDA1(IFN,IENS1,FIELD)=VALUE
  1. ;
  1. Q
  1. ;
  1. VALUE() ; -- parse segment
  1. ;
  1. ;Q
  1. ;
  1. ;N COL
  1. ;
  1. ;D SEGPRSE^XUMFXHL7("HLNODE","COL")
  1. ;
  1. ;Q:SEQ2 COL($P(SEQ,"."))
  1. ;
  1. ;Q COL(SEQ)
  1. ;
  1. ;
  1. VAL2() ; -- parse component
  1. ;
  1. N XXX
  1. ;
  1. D SEQPRSE^XUMFXHL7("VALUE","XXX")
  1. ;
  1. Q XXX(1,SEQ2)
  1. ;
  1. ;
  1. SUBCOMP ; -- subcomponents
  1. ;
  1. S SEQ3=0
  1. F S SEQ3=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",SEQ3)) Q:'SEQ3 D
  1. .S FIELD=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",SEQ3,0))
  1. .S TYP=$G(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",SEQ3,FIELD))
  1. .;S VALUE=$$VALUE()
  1. .S VALUE=$S(SEQ2:XUMFSEQ($P(SEQ,".")),1:XUMFSEQ(SEQ))
  1. .S VALUE=$$VAL2()
  1. .S VALUE=$P(VALUE,HLSCS,SEQ3)
  1. .S VALUE=$$DTYP^XUMFP(VALUE,TYP,HLSCS,0)
  1. .S FDA(IFN,IENS,FIELD)=VALUE
  1. ;
  1. Q
  1. ;
  1. ARRAY ; -- query data stored in array (not filed)
  1. ;
  1. I $P($G(KEY),HLCS)="" D Q
  1. .D EM("Null KEY found in the following segment: "_$E(HLNODE,1,80),.ERR)
  1. .S ERROR=ERROR_U_$G(ERR)
  1. ;
  1. I $G(IFN)=9.8 D Q
  1. .S IDX98=$G(IDX98)+1
  1. .S ^TMP("XUMF ARRAY",$J,IDX98)=HLNODE
  1. ;
  1. M ^TMP("XUMF ARRAY",$J,$P(KEY,HLCS))=HLNODE
  1. ;
  1. Q
  1. ;
  1. REPLY ; -- master file response
  1. ;
  1. Q:HL("MTN")="MFR"
  1. Q:HL("MTN")="MFK"
  1. Q:HL("MTN")="ACK"
  1. ;
  1. S:(TYPE<10) TYPE=(TYPE+10)
  1. ;
  1. I HL("MTN")="MFQ" D
  1. .S IFN=+$G(WHAT) I 'IFN D Q
  1. ..S ERROR="1^REPLY MFQ couldn't resolve IFN"
  1. ..D EM(ERROR,.ERR)
  1. .S XREF=$P(WHO,HLCS,9),ROOT=$$ROOT^DILFD(IFN,,1)
  1. .S IEN=$O(@ROOT@(XREF,$P(WHO,HLCS),0))
  1. .S IEN=$S(IEN:IEN,1:$P(WHO,HLCS))
  1. ;
  1. S IFN=$G(IFN),IEN=$G(IEN)
  1. ;
  1. D MAIN^XUMFP(IFN,IEN,TYPE,.PARAM,.ERROR)
  1. D MAIN^XUMFI(IFN,IEN,TYPE,.PARAM,.ERROR)
  1. ;
  1. Q
  1. ;
  1. EXIT ; -- cleanup, and quit
  1. ;
  1. I $D(^TMP("XUMF ERROR",$J)) D EM1 K ^TMP("XUMF ERROR",$J)
  1. ;
  1. K ^TMP("DILIST",$J),^TMP("DIERR",$J),^TMP("HLS",$J),^TMP("HLA",$J)
  1. ;
  1. Q
  1. ;
  1. EM(ERROR,ERR) ; -- error message
  1. ;
  1. D EM^XUMFHM(ERROR,.ERR)
  1. ;
  1. Q
  1. ;
  1. ;
  1. ;N X,I,Y,XMTEXT,FLG
  1. ;
  1. ;S FLG=0
  1. ;
  1. ;D MSG^DIALOG("AM",.X,80,,"ERR")
  1. ;
  1. ;S X(.02)="",X(.03)=$G(ERROR),X(.04)=""
  1. ;
  1. ;S X=.9 F S X=$O(X(X)) Q:'X D
  1. ;.I X(X)="" K X(X) Q
  1. ;.I X(X)["DINUMed field cannot" S FLG=1 K X(X) Q
  1. ;.I X(X)["ASSOCIATION" S FLG=1 K X(X) Q
  1. ;.I X(X)["INSTITUTION" S FLG=1 K X(X) Q
  1. ;.I X(X)["The entry does not exist." S FLG=1 K X(X) Q
  1. ;.I X(X)["already exists." S FLG=1 K X(X) Q
  1. ;
  1. ;I FLG Q:'$O(X(.9))
  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")="KEY: "_$G(KEY)_" IFN: "_$G(IFN)_" IEN: "_$G(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. EM1 ;
  1. ;
  1. D EM1^XUMFHM
  1. ;
  1. Q
  1. ;
  1. ;N XMY,XMSUB
  1. ;
  1. ;S ^TMP("XUMF ERROR",$J,.1)="HL7 message ID: "_$G(HL("MID"))
  1. ;S XMY("G.XUMF ERROR")="",XMSUB="MFS ERROR"
  1. ;S XMTEXT="^TMP(""XUMF ERROR"",$J,"
  1. ;
  1. ;D ^XMD
  1. ;
  1. ;Q
  1. ;