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

XUMFXI.m

Go to the documentation of this file. 
  1. XUMFXI ;ISS/RAM - MFS build message ;06/28/00
  1.  ;;8.0;KERNEL;**299,382**;Jul 10, 1995
  1.  ;
  1.  ; This routine is the Master File Server HL7 message builder API.
  1.  ; The routine will generate messages for both trigger events and
  1.  ; queries.
  1.  ;
  1.  ; Use the routine XUMFXP to initialize the PARAM array.
  1.  ; See XUMFXP for a full description of the parameters.
  1.  ;
  1.  ; use of $O(^HLCS(870,"C",institution_ptr)) supported by IA# 3550
  1.  ;
  1. MAIN(IFN,IEN,TYPE,PARAM,ERROR) ;  -- entry point
  1.  ;
  1.  ;
  1.  N HLFS,HLCS,HLRESLT,QUERY,UPDATE,ALL,CNT,ROOT,PROTOCOL,MFR,MFQ,MTYP,I
  1.  N ARRAY,GROUP,MFK,CDSYS,J,HLSCS
  1.  ;
  1.  M ^TMP("XUMF MFS",$J,"PARAM")=PARAM K PARAM
  1.  ;
  1.  D INIT,BUILD,LLNK,SEND,EXIT
  1.  ;
  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.  ;
  1.  S IEN=$G(IEN),IFN=$G(IFN)
  1.  S TYPE=$G(TYPE),ERROR=$G(ERROR),CNT=1
  1.  S UPDATE=$S(TYPE#2:0,1:1)
  1.  S QUERY='UPDATE
  1.  S GROUP=$S(UPDATE:0,TYPE[5:1,TYPE[7:1,1:0)
  1.  S ARRAY=$S(UPDATE:0,TYPE[3:1,TYPE[7:1,1:0)
  1.  S ALL=$S(IEN["ALL":1,1:0)
  1.  S PROTOCOL=$G(^TMP("XUMF MFS",$J,"PARAM","PROTOCOL"))
  1.  S MFR=$S(UPDATE:0,TYPE>10:1,1:0)
  1.  S MFQ=$S(UPDATE:0,'MFR:1,1:0)
  1.  S MFK=$S(TYPE=10:1,1:0)
  1.  S MTYP=$S(MFR:"HLA",MFK:"HLA",1:"HLS")
  1.  ;
  1.  ; -- get variables from HL7 package
  1.  I $O(HL(""))="" D INIT^HLFNC2(PROTOCOL,.HL)
  1.  I $O(HL(""))="" S ERROR="1^"_$P(HL,"^",2) Q
  1.  S HLFS=HL("FS"),HLCS=$E(HL("ECH")),HLSCS=$E(HL("ECH"),4)
  1.  ;
  1.  Q:ERROR
  1.  Q:MFK
  1.  ;
  1.  ; -- check parameters
  1.  I 'QUERY,'UPDATE S ERROR="1^invalid message type" Q
  1.  I 'IFN S ERROR="1^invalid file number" Q
  1.  I 'IEN,'ALL,'MFK S ERROR="1^invalid IEN" Q
  1.  I '$$VFILE^DILFD(IFN) S ERROR="1^invalid file number" Q
  1.  I UPDATE,'IEN S ERROR="1^update message requires an IEN" Q
  1.  ;
  1.  ; -- get root of file
  1.  S ROOT=$$ROOT^DILFD(IFN,,1)
  1.  ;
  1.  ; -- if IEN array input, merge with param
  1.  I 'ALL,'IEN,$O(IEN(0)) M ^TMP("XUMF MFS",$J,"PARAM","IEN")=IEN
  1.  ;
  1.  ; -- if CDSYS and ALL get entries
  1.  S CDSYS=$G(^TMP("XUMF MFS",$J,"PARAM","CDSYS"))
  1.  I ALL,CDSYS'="" D
  1.  .S I=0 F  S I=$O(@ROOT@("XUMFIDX",CDSYS,I)) Q:'I  D
  1.  ..S J=$O(@ROOT@("XUMFIDX",CDSYS,I,0))
  1.  ..S ^TMP("XUMF MFS",$J,"PARAM","IEN",J)=""
  1.  ;
  1.  ; -- get ALL file 'national' entries
  1.  I ALL,'$D(^TMP("XUMF MFS",$J,"PARAM","IEN")) D
  1.  .S I=0 F  S I=$O(@ROOT@("AVUID",I)) Q:'I  D
  1.  ..S J=$O(@ROOT@("AVUID",I,0))
  1.  ..S ^TMP("XUMF MFS",$J,"PARAM","IEN",J)=""
  1.  ;
  1.  Q
  1.  ;
  1. BUILD ; -- build message
  1.  ;
  1.  I MFK D MFK Q
  1.  ;
  1.  Q:ERROR
  1.  ;
  1.  N ID,APP,EVENT,ENDT,EFFDT,RESP,MFI,MFN,EDT,CODE,MFE
  1.  ;
  1.  I QUERY D QRD Q:MFQ
  1.  ;
  1.  D MFI
  1.  ;
  1.  I GROUP D GROUP Q
  1.  ;
  1.  D MFE,RDT
  1.  ;
  1.  Q
  1.  ;
  1. MFK ; -- master file acknowledgement
  1.  ;
  1.  N X,I,I1,I2
  1.  S X="MSA"_HLFS_$S(ERROR:"AE",1:"AA")_HLFS_HL("MID")_HLFS_$P(ERROR,U,2)
  1.  S ^TMP(MTYP,$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(MTYP,$J,CNT)=X
  1.  ..S CNT=CNT+1
  1.  ;
  1.  Q
  1.  ;
  1. QRD ; -- query definition segment
  1.  ;
  1.  I TYPE>10 D
  1.  .S ^TMP(MTYP,$J,CNT)="MSA"_HLFS_$S(ERROR:"AE",1:"AA")_HLFS_HL("MID")
  1.  .S CNT=CNT+1
  1.  ;
  1.  Q:ERROR
  1.  ;
  1.  N QDT,QFC,QP,QID,ZDRT,ZDRDT,QLR,WHO,WHAT,WDDC,WDCVQ,QRL,QRD
  1.  ;
  1.  S QDT=$G(^TMP("XUMF MFS",$J,"PARAM","QDT"))
  1.  S QFC=$G(^TMP("XUMF MFS",$J,"PARAM","QFC"))
  1.  S QP=$G(^TMP("XUMF MFS",$J,"PARAM","QP"))
  1.  S QID=$G(^TMP("XUMF MFS",$J,"PARAM","QID"))
  1.  S ZDRT=$G(^TMP("XUMF MFS",$J,"PARAM","DRT"))
  1.  S ZDRDT=$G(^TMP("XUMF MFS",$J,"PARAM","DRDT"))
  1.  S QLR=$G(^TMP("XUMF MFS",$J,"PARAM","QLR"))
  1.  S WHO=$G(^TMP("XUMF MFS",$J,"PARAM","WHO"))
  1.  S WHAT=$G(^TMP("XUMF MFS",$J,"PARAM","WHAT"))
  1.  S WDDC=$G(^TMP("XUMF MFS",$J,"PARAM","WDDC"))
  1.  S WDCVQ=$G(^TMP("XUMF MFS",$J,"PARAM","WDCVQ"))
  1.  S QRL=$G(^TMP("XUMF MFS",$J,"PARAM","QRL"))
  1.  S QRD="QRD"_HLFS_QDT_HLFS_QFC_HLFS_QP_HLFS_QID_HLFS_ZDRT_HLFS_ZDRDT
  1.  S QRD=QRD_HLFS_QLR_HLFS_WHO_HLFS_WHAT_HLFS_WDDC_HLFS_WDCVQ_HLFS_QRL
  1.  S ^TMP(MTYP,$J,CNT)=QRD
  1.  S CNT=CNT+1
  1.  ;
  1.  Q
  1.  ;
  1. MFI ; master file identifier segment
  1.  ;
  1.  Q:ERROR
  1.  ;
  1.  N ID,APP,EVENT,ENDT,EFFDT,RESP,MFI
  1.  ;
  1.  S ID=$G(^TMP("XUMF MFS",$J,"PARAM","MFI"))
  1.  S APP=$G(^TMP("XUMF MFS",$J,"PARAM","MFAI"))
  1.  S EVENT=$G(^TMP("XUMF MFS",$J,"PARAM","FLEV"))
  1.  S ENDT=$G(^TMP("XUMF MFS",$J,"PARAM","ENDT"))
  1.  S EFFDT=$G(^TMP("XUMF MFS",$J,"PARAM","MFIEDT"))
  1.  S RESP=$G(^TMP("XUMF MFS",$J,"PARAM","RLC"))
  1.  S:APP="" APP="MFS" S:EVENT="" EVENT="REP" S:RESP="" RESP="NE"
  1.  S:ENDT="" ENDT=$$NOW^XLFDT S:EFFDT="" EFFDT=$$NOW^XLFDT
  1.  S MFI=$$MFI^XUMFMFI(ID,APP,EVENT,ENDT,EFFDT,RESP)
  1.  I $E(MFI)="-" S ERROR=MFI Q
  1.  S ^TMP(MTYP,$J,CNT)=MFI
  1.  S CNT=CNT+1
  1.  ;
  1.  Q
  1.  ;
  1. MFE ; master file entry segment
  1.  ;
  1.  Q:ERROR
  1.  ;
  1.  N EVENT,MFN,EDT,CODE,MFE
  1.  ;
  1.  S EVENT=$G(^TMP("XUMF MFS",$J,"PARAM","RLEC"))
  1.  S MFN=$G(^TMP("XUMF MFS",$J,"PARAM","MFNCID"))
  1.  S EDT=$G(^TMP("XUMF MFS",$J,"PARAM","MFEEDT"))
  1.  S CODE=$G(^TMP("XUMF MFS",$J,"PARAM","PKV"))
  1.  S:EDT="" EDT=$$NOW^XLFDT S:EVENT="" EVENT="MAD"
  1.  S MFE=$$MFE^XUMFMFE(EVENT,MFN,EDT,CODE)
  1.  I $E(MFE)="-" S ERROR=MFE Q
  1.  S ^TMP(MTYP,$J,CNT)=MFE
  1.  S CNT=CNT+1
  1.  ;
  1.  Q
  1.  ;
  1. RDT ; table row definition/data segment
  1.  ;
  1.  Q:ERROR
  1.  ;
  1.  N SEG,SEQ,ZZZ,FLD,FILE,IENS,VALUE,ERR,ZDTYP,FIELD,SEQ1,SEQ2,SEQ3
  1.  N SEQ0,SEQ9,CNT1,CNT2,NODE,XXX,LKUP
  1.  ;
  1.  S SEQ=0
  1.  F  S SEQ=$O(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ)) Q:'SEQ  D
  1.  .;
  1.  .S FLD=$O(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,0))
  1.  .;
  1.  .I 'FLD D
  1.  ..S FILE=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"FILE")
  1.  ..S IENS=$G(^TMP("XUMF MFS",$J,"PARAM","IENS",SEQ))
  1.  ..S FIELD=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"FIELD")
  1.  ..S ZDTYP=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"DTYP")
  1.  ..S LKUP=$G(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"LKUP"))
  1.  ..I LKUP S FIELD=FIELD_":"_LKUP
  1.  ..S VALUE=$$GET1^DIQ(FILE,IENS,FIELD)
  1.  ..S VALUE=$$DTYP^XUMFXP(VALUE,ZDTYP,HLCS,1)
  1.  .I FLD D
  1.  ..S ZDTYP=$G(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,FLD))
  1.  ..S LKUP=$P(ZDTYP,U,2),ZDTYP=$P(ZDTYP,U)
  1.  ..I LKUP S FLD=FLD_":"_LKUP
  1.  ..S VALUE=$$GET1^DIQ(IFN,IEN_",",FLD)
  1.  ..S VALUE=$$DTYP^XUMFXP(VALUE,ZDTYP,HLCS,1)
  1.  .;
  1.  .S ZZZ(SEQ)=VALUE
  1.  ;
  1.  K NODE
  1.  S (SEQ,SEQ0,SEQ9,SEQ1,CNT1)=0,NODE(0)=""
  1.  F  S SEQ1=$O(ZZZ(SEQ1)) Q:'SEQ1  D
  1.  .S VALUE=ZZZ(SEQ1)
  1.  .I $L(NODE(CNT1)_VALUE)>200 D
  1.  ..S CNT1=CNT1+1,SEQ9=SEQ0+SEQ9
  1.  .S SEQ=$S('CNT1:SEQ1,1:SEQ1-SEQ9)
  1.  .S $P(NODE(CNT1),HLFS,SEQ)=VALUE
  1.  .S SEQ0=SEQ-1
  1.  ;
  1.  S NODE="RDT"_HLFS_$G(NODE(0)) K NODE(0)
  1.  ;
  1.  M ^TMP(MTYP,$J,CNT)=^TMP("XUMF MFS",$J,"PARAM","RDF")
  1.  S CNT=CNT+1
  1.  M ^TMP(MTYP,$J,CNT)=NODE
  1.  S CNT=CNT+1
  1.  ;
  1.  Q
  1.  ;
  1. GROUP ; -- query group records
  1.  ;
  1.  Q:ERROR
  1.  ;
  1.  S IEN=0
  1.  F  S IEN=$O(^TMP("XUMF MFS",$J,"PARAM","IEN",IEN)) Q:'IEN  D
  1.  .K ^TMP("XUMF MFS",$J,"PARAM","PKV")
  1.  .K ^TMP("XUMF MFS",$J,"PARAM","IENS")
  1.  .S ^TMP("XUMF MFS",$J,"PARAM","PKV")=^TMP("XUMF MFS",$J,"PARAM",IEN,"PKV")
  1.  .M ^TMP("XUMF MFS",$J,"PARAM","IENS")=^TMP("XUMF MFS",$J,"PARAM",IEN,"IENS")
  1.  .D MFE,RDT
  1.  ;
  1.  Q
  1.  ;
  1. SEND ; -- send HL7 message
  1.  ;
  1.  I 'MFK,ERROR Q
  1.  ;
  1.  S HLP("PRIORITY")="I"
  1.  ;
  1.  I 'TYPE D GENERATE^HLMA(PROTOCOL,"GM",1,.HLRESLT,"",.HLP)
  1.  I TYPE,(TYPE<10) D DIRECT^HLMA(PROTOCOL,"GM",1,.HLRESLT,"",.HLP)
  1.  I (TYPE>9) D GENACK^HLMA1($G(HL("EID")),$G(HLMTIENS),$G(HL("EIDS")),"GM",1,.HLRESLT)
  1.  ;
  1.  ; check for error
  1.  I ($P($G(HLRESLT),U,3)'="") D  Q
  1.  .S ERROR=1_U_$P(HLRESLT,HLFS,3)_U_$P(HLRESLT,HLFS,2)_U_$P(HLRESLT,U)
  1.  ;
  1.  ; successful call, message ID returned
  1.  S ERROR="0^"_$P($G(HLRESLT),U,1)
  1.  ;
  1.  Q
  1.  ;
  1. EXIT ; -- exit
  1.  ;
  1.  D CLEAN^DILF
  1.  ;
  1.  K ^TMP("HLS",$J),^TMP("HLA",$J)
  1.  K ^TMP("XUMF MFS",$J)
  1.  ;
  1.  Q
  1.  ;
  1. LLNK ; -- dynamic addressing BROADCAST
  1.  ;
  1.  Q:TYPE>9
  1.  ;
  1.  I $G(^TMP("XUMF MFS",$J,"PARAM","LLNK"))'="" D  Q
  1.  .S HLL("LINKS",1)=^TMP("XUMF MFS",$J,"PARAM","LLNK")
  1.  ;
  1.  Q:'$$SERVER()
  1.  ;
  1.  Q:TYPE
  1.  Q:'$G(^TMP("XUMF MFS",$J,"PARAM","BROADCAST"))
  1.  ;
  1.  N I,J,LLNK
  1.  ;
  1.  S (I,J)=0
  1.  F  S I=$O(^HLCS(870,"C",I)) Q:'I  D
  1.  .S J=$O(^HLCS(870,"C",I,0)) Q:'J
  1.  .S LLNK=$P($G(^HLCS(870,J,0)),U)
  1.  .S HLL("LINKS",I)="XUMF MFS^"_LLNK
  1.  ;
  1.  Q
  1.  ;
  1. SERVER() ; -- servers
  1.  ;
  1.  N I
  1.  ;
  1.  S I=$$KSP^XUPARAM("INST") Q:'I 0
  1.  ;
  1.  Q:I=662 1  ;VAB
  1.  Q:I=442 1  ;BP TEST
  1.  Q:I=12000 1  ;FORUM
  1.  Q:I=100002 1  ;HEC
  1.  ;
  1.  Q 0
  1.  ;