XUMFXI ;ISS/RAM - MFS build message ;06/28/00
;;8.0;KERNEL;**299,382**;Jul 10, 1995
;
; This routine is the Master File Server HL7 message builder API.
; The routine will generate messages for both trigger events and
; queries.
;
; Use the routine XUMFXP to initialize the PARAM array.
; See XUMFXP for a full description of the parameters.
;
; use of $O(^HLCS(870,"C",institution_ptr)) supported by IA# 3550
;
MAIN(IFN,IEN,TYPE,PARAM,ERROR) ; -- entry point
;
;
N HLFS,HLCS,HLRESLT,QUERY,UPDATE,ALL,CNT,ROOT,PROTOCOL,MFR,MFQ,MTYP,I
N ARRAY,GROUP,MFK,CDSYS,J,HLSCS
;
M ^TMP("XUMF MFS",$J,"PARAM")=PARAM K PARAM
;
D INIT,BUILD,LLNK,SEND,EXIT
;
;
Q
;
INIT ; -- initialize
;
K ^TMP("DILIST",$J),^TMP("DIERR",$J)
K ^TMP("HLS",$J),^TMP("HLA",$J)
;
S IEN=$G(IEN),IFN=$G(IFN)
S TYPE=$G(TYPE),ERROR=$G(ERROR),CNT=1
S UPDATE=$S(TYPE#2:0,1:1)
S QUERY='UPDATE
S GROUP=$S(UPDATE:0,TYPE[5:1,TYPE[7:1,1:0)
S ARRAY=$S(UPDATE:0,TYPE[3:1,TYPE[7:1,1:0)
S ALL=$S(IEN["ALL":1,1:0)
S PROTOCOL=$G(^TMP("XUMF MFS",$J,"PARAM","PROTOCOL"))
S MFR=$S(UPDATE:0,TYPE>10:1,1:0)
S MFQ=$S(UPDATE:0,'MFR:1,1:0)
S MFK=$S(TYPE=10:1,1:0)
S MTYP=$S(MFR:"HLA",MFK:"HLA",1:"HLS")
;
; -- get variables from HL7 package
I $O(HL(""))="" D INIT^HLFNC2(PROTOCOL,.HL)
I $O(HL(""))="" S ERROR="1^"_$P(HL,"^",2) Q
S HLFS=HL("FS"),HLCS=$E(HL("ECH")),HLSCS=$E(HL("ECH"),4)
;
Q:ERROR
Q:MFK
;
; -- check parameters
I 'QUERY,'UPDATE S ERROR="1^invalid message type" Q
I 'IFN S ERROR="1^invalid file number" Q
I 'IEN,'ALL,'MFK S ERROR="1^invalid IEN" Q
I '$$VFILE^DILFD(IFN) S ERROR="1^invalid file number" Q
I UPDATE,'IEN S ERROR="1^update message requires an IEN" Q
;
; -- get root of file
S ROOT=$$ROOT^DILFD(IFN,,1)
;
; -- if IEN array input, merge with param
I 'ALL,'IEN,$O(IEN(0)) M ^TMP("XUMF MFS",$J,"PARAM","IEN")=IEN
;
; -- if CDSYS and ALL get entries
S CDSYS=$G(^TMP("XUMF MFS",$J,"PARAM","CDSYS"))
I ALL,CDSYS'="" D
.S I=0 F S I=$O(@ROOT@("XUMFIDX",CDSYS,I)) Q:'I D
..S J=$O(@ROOT@("XUMFIDX",CDSYS,I,0))
..S ^TMP("XUMF MFS",$J,"PARAM","IEN",J)=""
;
; -- get ALL file 'national' entries
I ALL,'$D(^TMP("XUMF MFS",$J,"PARAM","IEN")) D
.S I=0 F S I=$O(@ROOT@("AVUID",I)) Q:'I D
..S J=$O(@ROOT@("AVUID",I,0))
..S ^TMP("XUMF MFS",$J,"PARAM","IEN",J)=""
;
Q
;
BUILD ; -- build message
;
I MFK D MFK Q
;
Q:ERROR
;
N ID,APP,EVENT,ENDT,EFFDT,RESP,MFI,MFN,EDT,CODE,MFE
;
I QUERY D QRD Q:MFQ
;
D MFI
;
I GROUP D GROUP Q
;
D MFE,RDT
;
Q
;
MFK ; -- master file acknowledgement
;
N X,I,I1,I2
S X="MSA"_HLFS_$S(ERROR:"AE",1:"AA")_HLFS_HL("MID")_HLFS_$P(ERROR,U,2)
S ^TMP(MTYP,$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(MTYP,$J,CNT)=X
..S CNT=CNT+1
;
Q
;
QRD ; -- query definition segment
;
I TYPE>10 D
.S ^TMP(MTYP,$J,CNT)="MSA"_HLFS_$S(ERROR:"AE",1:"AA")_HLFS_HL("MID")
.S CNT=CNT+1
;
Q:ERROR
;
N QDT,QFC,QP,QID,ZDRT,ZDRDT,QLR,WHO,WHAT,WDDC,WDCVQ,QRL,QRD
;
S QDT=$G(^TMP("XUMF MFS",$J,"PARAM","QDT"))
S QFC=$G(^TMP("XUMF MFS",$J,"PARAM","QFC"))
S QP=$G(^TMP("XUMF MFS",$J,"PARAM","QP"))
S QID=$G(^TMP("XUMF MFS",$J,"PARAM","QID"))
S ZDRT=$G(^TMP("XUMF MFS",$J,"PARAM","DRT"))
S ZDRDT=$G(^TMP("XUMF MFS",$J,"PARAM","DRDT"))
S QLR=$G(^TMP("XUMF MFS",$J,"PARAM","QLR"))
S WHO=$G(^TMP("XUMF MFS",$J,"PARAM","WHO"))
S WHAT=$G(^TMP("XUMF MFS",$J,"PARAM","WHAT"))
S WDDC=$G(^TMP("XUMF MFS",$J,"PARAM","WDDC"))
S WDCVQ=$G(^TMP("XUMF MFS",$J,"PARAM","WDCVQ"))
S QRL=$G(^TMP("XUMF MFS",$J,"PARAM","QRL"))
S QRD="QRD"_HLFS_QDT_HLFS_QFC_HLFS_QP_HLFS_QID_HLFS_ZDRT_HLFS_ZDRDT
S QRD=QRD_HLFS_QLR_HLFS_WHO_HLFS_WHAT_HLFS_WDDC_HLFS_WDCVQ_HLFS_QRL
S ^TMP(MTYP,$J,CNT)=QRD
S CNT=CNT+1
;
Q
;
MFI ; master file identifier segment
;
Q:ERROR
;
N ID,APP,EVENT,ENDT,EFFDT,RESP,MFI
;
S ID=$G(^TMP("XUMF MFS",$J,"PARAM","MFI"))
S APP=$G(^TMP("XUMF MFS",$J,"PARAM","MFAI"))
S EVENT=$G(^TMP("XUMF MFS",$J,"PARAM","FLEV"))
S ENDT=$G(^TMP("XUMF MFS",$J,"PARAM","ENDT"))
S EFFDT=$G(^TMP("XUMF MFS",$J,"PARAM","MFIEDT"))
S RESP=$G(^TMP("XUMF MFS",$J,"PARAM","RLC"))
S:APP="" APP="MFS" S:EVENT="" EVENT="REP" S:RESP="" RESP="NE"
S:ENDT="" ENDT=$$NOW^XLFDT S:EFFDT="" EFFDT=$$NOW^XLFDT
S MFI=$$MFI^XUMFMFI(ID,APP,EVENT,ENDT,EFFDT,RESP)
I $E(MFI)="-" S ERROR=MFI Q
S ^TMP(MTYP,$J,CNT)=MFI
S CNT=CNT+1
;
Q
;
MFE ; master file entry segment
;
Q:ERROR
;
N EVENT,MFN,EDT,CODE,MFE
;
S EVENT=$G(^TMP("XUMF MFS",$J,"PARAM","RLEC"))
S MFN=$G(^TMP("XUMF MFS",$J,"PARAM","MFNCID"))
S EDT=$G(^TMP("XUMF MFS",$J,"PARAM","MFEEDT"))
S CODE=$G(^TMP("XUMF MFS",$J,"PARAM","PKV"))
S:EDT="" EDT=$$NOW^XLFDT S:EVENT="" EVENT="MAD"
S MFE=$$MFE^XUMFMFE(EVENT,MFN,EDT,CODE)
I $E(MFE)="-" S ERROR=MFE Q
S ^TMP(MTYP,$J,CNT)=MFE
S CNT=CNT+1
;
Q
;
RDT ; table row definition/data segment
;
Q:ERROR
;
N SEG,SEQ,ZZZ,FLD,FILE,IENS,VALUE,ERR,ZDTYP,FIELD,SEQ1,SEQ2,SEQ3
N SEQ0,SEQ9,CNT1,CNT2,NODE,XXX,LKUP
;
S SEQ=0
F S SEQ=$O(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ)) Q:'SEQ D
.;
.S FLD=$O(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,0))
.;
.I 'FLD D
..S FILE=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"FILE")
..S IENS=$G(^TMP("XUMF MFS",$J,"PARAM","IENS",SEQ))
..S FIELD=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"FIELD")
..S ZDTYP=^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"DTYP")
..S LKUP=$G(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,"LKUP"))
..I LKUP S FIELD=FIELD_":"_LKUP
..S VALUE=$$GET1^DIQ(FILE,IENS,FIELD)
..S VALUE=$$DTYP^XUMFXP(VALUE,ZDTYP,HLCS,1)
.I FLD D
..S ZDTYP=$G(^TMP("XUMF MFS",$J,"PARAM","SEQ",SEQ,FLD))
..S LKUP=$P(ZDTYP,U,2),ZDTYP=$P(ZDTYP,U)
..I LKUP S FLD=FLD_":"_LKUP
..S VALUE=$$GET1^DIQ(IFN,IEN_",",FLD)
..S VALUE=$$DTYP^XUMFXP(VALUE,ZDTYP,HLCS,1)
.;
.S ZZZ(SEQ)=VALUE
;
K NODE
S (SEQ,SEQ0,SEQ9,SEQ1,CNT1)=0,NODE(0)=""
F S SEQ1=$O(ZZZ(SEQ1)) Q:'SEQ1 D
.S VALUE=ZZZ(SEQ1)
.I $L(NODE(CNT1)_VALUE)>200 D
..S CNT1=CNT1+1,SEQ9=SEQ0+SEQ9
.S SEQ=$S('CNT1:SEQ1,1:SEQ1-SEQ9)
.S $P(NODE(CNT1),HLFS,SEQ)=VALUE
.S SEQ0=SEQ-1
;
S NODE="RDT"_HLFS_$G(NODE(0)) K NODE(0)
;
M ^TMP(MTYP,$J,CNT)=^TMP("XUMF MFS",$J,"PARAM","RDF")
S CNT=CNT+1
M ^TMP(MTYP,$J,CNT)=NODE
S CNT=CNT+1
;
Q
;
GROUP ; -- query group records
;
Q:ERROR
;
S IEN=0
F S IEN=$O(^TMP("XUMF MFS",$J,"PARAM","IEN",IEN)) Q:'IEN D
.K ^TMP("XUMF MFS",$J,"PARAM","PKV")
.K ^TMP("XUMF MFS",$J,"PARAM","IENS")
.S ^TMP("XUMF MFS",$J,"PARAM","PKV")=^TMP("XUMF MFS",$J,"PARAM",IEN,"PKV")
.M ^TMP("XUMF MFS",$J,"PARAM","IENS")=^TMP("XUMF MFS",$J,"PARAM",IEN,"IENS")
.D MFE,RDT
;
Q
;
SEND ; -- send HL7 message
;
I 'MFK,ERROR Q
;
S HLP("PRIORITY")="I"
;
I 'TYPE D GENERATE^HLMA(PROTOCOL,"GM",1,.HLRESLT,"",.HLP)
I TYPE,(TYPE<10) D DIRECT^HLMA(PROTOCOL,"GM",1,.HLRESLT,"",.HLP)
I (TYPE>9) 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
;
EXIT ; -- exit
;
D CLEAN^DILF
;
K ^TMP("HLS",$J),^TMP("HLA",$J)
K ^TMP("XUMF MFS",$J)
;
Q
;
LLNK ; -- dynamic addressing BROADCAST
;
Q:TYPE>9
;
I $G(^TMP("XUMF MFS",$J,"PARAM","LLNK"))'="" D Q
.S HLL("LINKS",1)=^TMP("XUMF MFS",$J,"PARAM","LLNK")
;
Q:'$$SERVER()
;
Q:TYPE
Q:'$G(^TMP("XUMF MFS",$J,"PARAM","BROADCAST"))
;
N I,J,LLNK
;
S (I,J)=0
F S I=$O(^HLCS(870,"C",I)) Q:'I D
.S J=$O(^HLCS(870,"C",I,0)) Q:'J
.S LLNK=$P($G(^HLCS(870,J,0)),U)
.S HLL("LINKS",I)="XUMF MFS^"_LLNK
;
Q
;
SERVER() ; -- servers
;
N I
;
S I=$$KSP^XUPARAM("INST") Q:'I 0
;
Q:I=662 1 ;VAB
Q:I=442 1 ;BP TEST
Q:I=12000 1 ;FORUM
Q:I=100002 1 ;HEC
;
Q 0
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMFXI 8184 printed Nov 22, 2024@17:21:18 Page 2
XUMFXI ;ISS/RAM - MFS build message ;06/28/00
+1 ;;8.0;KERNEL;**299,382**;Jul 10, 1995
+2 ;
+3 ; This routine is the Master File Server HL7 message builder API.
+4 ; The routine will generate messages for both trigger events and
+5 ; queries.
+6 ;
+7 ; Use the routine XUMFXP to initialize the PARAM array.
+8 ; See XUMFXP for a full description of the parameters.
+9 ;
+10 ; use of $O(^HLCS(870,"C",institution_ptr)) supported by IA# 3550
+11 ;
MAIN(IFN,IEN,TYPE,PARAM,ERROR) ; -- entry point
+1 ;
+2 ;
+3 NEW HLFS,HLCS,HLRESLT,QUERY,UPDATE,ALL,CNT,ROOT,PROTOCOL,MFR,MFQ,MTYP,I
+4 NEW ARRAY,GROUP,MFK,CDSYS,J,HLSCS
+5 ;
+6 MERGE ^TMP("XUMF MFS",$JOB,"PARAM")=PARAM
KILL PARAM
+7 ;
+8 DO INIT
DO BUILD
DO LLNK
DO SEND
DO EXIT
+9 ;
+10 ;
+11 QUIT
+12 ;
INIT ; -- initialize
+1 ;
+2 KILL ^TMP("DILIST",$JOB),^TMP("DIERR",$JOB)
+3 KILL ^TMP("HLS",$JOB),^TMP("HLA",$JOB)
+4 ;
+5 SET IEN=$GET(IEN)
SET IFN=$GET(IFN)
+6 SET TYPE=$GET(TYPE)
SET ERROR=$GET(ERROR)
SET CNT=1
+7 SET UPDATE=$SELECT(TYPE#2:0,1:1)
+8 SET QUERY='UPDATE
+9 SET GROUP=$SELECT(UPDATE:0,TYPE[5:1,TYPE[7:1,1:0)
+10 SET ARRAY=$SELECT(UPDATE:0,TYPE[3:1,TYPE[7:1,1:0)
+11 SET ALL=$SELECT(IEN["ALL":1,1:0)
+12 SET PROTOCOL=$GET(^TMP("XUMF MFS",$JOB,"PARAM","PROTOCOL"))
+13 SET MFR=$SELECT(UPDATE:0,TYPE>10:1,1:0)
+14 SET MFQ=$SELECT(UPDATE:0,'MFR:1,1:0)
+15 SET MFK=$SELECT(TYPE=10:1,1:0)
+16 SET MTYP=$SELECT(MFR:"HLA",MFK:"HLA",1:"HLS")
+17 ;
+18 ; -- get variables from HL7 package
+19 IF $ORDER(HL(""))=""
DO INIT^HLFNC2(PROTOCOL,.HL)
+20 IF $ORDER(HL(""))=""
SET ERROR="1^"_$PIECE(HL,"^",2)
QUIT
+21 SET HLFS=HL("FS")
SET HLCS=$EXTRACT(HL("ECH"))
SET HLSCS=$EXTRACT(HL("ECH"),4)
+22 ;
+23 if ERROR
QUIT
+24 if MFK
QUIT
+25 ;
+26 ; -- check parameters
+27 IF 'QUERY
IF 'UPDATE
SET ERROR="1^invalid message type"
QUIT
+28 IF 'IFN
SET ERROR="1^invalid file number"
QUIT
+29 IF 'IEN
IF 'ALL
IF 'MFK
SET ERROR="1^invalid IEN"
QUIT
+30 IF '$$VFILE^DILFD(IFN)
SET ERROR="1^invalid file number"
QUIT
+31 IF UPDATE
IF 'IEN
SET ERROR="1^update message requires an IEN"
QUIT
+32 ;
+33 ; -- get root of file
+34 SET ROOT=$$ROOT^DILFD(IFN,,1)
+35 ;
+36 ; -- if IEN array input, merge with param
+37 IF 'ALL
IF 'IEN
IF $ORDER(IEN(0))
MERGE ^TMP("XUMF MFS",$JOB,"PARAM","IEN")=IEN
+38 ;
+39 ; -- if CDSYS and ALL get entries
+40 SET CDSYS=$GET(^TMP("XUMF MFS",$JOB,"PARAM","CDSYS"))
+41 IF ALL
IF CDSYS'=""
Begin DoDot:1
+42 SET I=0
FOR
SET I=$ORDER(@ROOT@("XUMFIDX",CDSYS,I))
if 'I
QUIT
Begin DoDot:2
+43 SET J=$ORDER(@ROOT@("XUMFIDX",CDSYS,I,0))
+44 SET ^TMP("XUMF MFS",$JOB,"PARAM","IEN",J)=""
End DoDot:2
End DoDot:1
+45 ;
+46 ; -- get ALL file 'national' entries
+47 IF ALL
IF '$DATA(^TMP("XUMF MFS",$JOB,"PARAM","IEN"))
Begin DoDot:1
+48 SET I=0
FOR
SET I=$ORDER(@ROOT@("AVUID",I))
if 'I
QUIT
Begin DoDot:2
+49 SET J=$ORDER(@ROOT@("AVUID",I,0))
+50 SET ^TMP("XUMF MFS",$JOB,"PARAM","IEN",J)=""
End DoDot:2
End DoDot:1
+51 ;
+52 QUIT
+53 ;
BUILD ; -- build message
+1 ;
+2 IF MFK
DO MFK
QUIT
+3 ;
+4 if ERROR
QUIT
+5 ;
+6 NEW ID,APP,EVENT,ENDT,EFFDT,RESP,MFI,MFN,EDT,CODE,MFE
+7 ;
+8 IF QUERY
DO QRD
if MFQ
QUIT
+9 ;
+10 DO MFI
+11 ;
+12 IF GROUP
DO GROUP
QUIT
+13 ;
+14 DO MFE
DO RDT
+15 ;
+16 QUIT
+17 ;
MFK ; -- master file acknowledgement
+1 ;
+2 NEW X,I,I1,I2
+3 SET X="MSA"_HLFS_$SELECT(ERROR:"AE",1:"AA")_HLFS_HL("MID")_HLFS_$PIECE(ERROR,U,2)
+4 SET ^TMP(MTYP,$JOB,CNT)=X
+5 SET CNT=CNT+1
+6 ;
+7 SET I1=""
SET I=0
+8 FOR
SET I1=$ORDER(^TMP("XUMF ERROR",$JOB,I1))
if '$LENGTH(I1)
QUIT
Begin DoDot:1
+9 SET I2=""
FOR
SET I2=$ORDER(^TMP("XUMF ERROR",$JOB,I1,I2))
if '$LENGTH(I2)
QUIT
Begin DoDot:2
+10 SET X=$GET(^(I2))
+11 if '$LENGTH(X)
QUIT
+12 SET I=I+1
+13 SET X="ERR"_HLFS_I_HLFS_$SELECT($ORDER(^TMP("XUMF ERROR",$JOB,I1))!$ORDER(^TMP("XUMF ERROR",$JOB,I1,I2)):1,1:0)_HLFS_X
+14 SET ^TMP(MTYP,$JOB,CNT)=X
+15 SET CNT=CNT+1
End DoDot:2
End DoDot:1
+16 ;
+17 QUIT
+18 ;
QRD ; -- query definition segment
+1 ;
+2 IF TYPE>10
Begin DoDot:1
+3 SET ^TMP(MTYP,$JOB,CNT)="MSA"_HLFS_$SELECT(ERROR:"AE",1:"AA")_HLFS_HL("MID")
+4 SET CNT=CNT+1
End DoDot:1
+5 ;
+6 if ERROR
QUIT
+7 ;
+8 NEW QDT,QFC,QP,QID,ZDRT,ZDRDT,QLR,WHO,WHAT,WDDC,WDCVQ,QRL,QRD
+9 ;
+10 SET QDT=$GET(^TMP("XUMF MFS",$JOB,"PARAM","QDT"))
+11 SET QFC=$GET(^TMP("XUMF MFS",$JOB,"PARAM","QFC"))
+12 SET QP=$GET(^TMP("XUMF MFS",$JOB,"PARAM","QP"))
+13 SET QID=$GET(^TMP("XUMF MFS",$JOB,"PARAM","QID"))
+14 SET ZDRT=$GET(^TMP("XUMF MFS",$JOB,"PARAM","DRT"))
+15 SET ZDRDT=$GET(^TMP("XUMF MFS",$JOB,"PARAM","DRDT"))
+16 SET QLR=$GET(^TMP("XUMF MFS",$JOB,"PARAM","QLR"))
+17 SET WHO=$GET(^TMP("XUMF MFS",$JOB,"PARAM","WHO"))
+18 SET WHAT=$GET(^TMP("XUMF MFS",$JOB,"PARAM","WHAT"))
+19 SET WDDC=$GET(^TMP("XUMF MFS",$JOB,"PARAM","WDDC"))
+20 SET WDCVQ=$GET(^TMP("XUMF MFS",$JOB,"PARAM","WDCVQ"))
+21 SET QRL=$GET(^TMP("XUMF MFS",$JOB,"PARAM","QRL"))
+22 SET QRD="QRD"_HLFS_QDT_HLFS_QFC_HLFS_QP_HLFS_QID_HLFS_ZDRT_HLFS_ZDRDT
+23 SET QRD=QRD_HLFS_QLR_HLFS_WHO_HLFS_WHAT_HLFS_WDDC_HLFS_WDCVQ_HLFS_QRL
+24 SET ^TMP(MTYP,$JOB,CNT)=QRD
+25 SET CNT=CNT+1
+26 ;
+27 QUIT
+28 ;
MFI ; master file identifier segment
+1 ;
+2 if ERROR
QUIT
+3 ;
+4 NEW ID,APP,EVENT,ENDT,EFFDT,RESP,MFI
+5 ;
+6 SET ID=$GET(^TMP("XUMF MFS",$JOB,"PARAM","MFI"))
+7 SET APP=$GET(^TMP("XUMF MFS",$JOB,"PARAM","MFAI"))
+8 SET EVENT=$GET(^TMP("XUMF MFS",$JOB,"PARAM","FLEV"))
+9 SET ENDT=$GET(^TMP("XUMF MFS",$JOB,"PARAM","ENDT"))
+10 SET EFFDT=$GET(^TMP("XUMF MFS",$JOB,"PARAM","MFIEDT"))
+11 SET RESP=$GET(^TMP("XUMF MFS",$JOB,"PARAM","RLC"))
+12 if APP=""
SET APP="MFS"
if EVENT=""
SET EVENT="REP"
if RESP=""
SET RESP="NE"
+13 if ENDT=""
SET ENDT=$$NOW^XLFDT
if EFFDT=""
SET EFFDT=$$NOW^XLFDT
+14 SET MFI=$$MFI^XUMFMFI(ID,APP,EVENT,ENDT,EFFDT,RESP)
+15 IF $EXTRACT(MFI)="-"
SET ERROR=MFI
QUIT
+16 SET ^TMP(MTYP,$JOB,CNT)=MFI
+17 SET CNT=CNT+1
+18 ;
+19 QUIT
+20 ;
MFE ; master file entry segment
+1 ;
+2 if ERROR
QUIT
+3 ;
+4 NEW EVENT,MFN,EDT,CODE,MFE
+5 ;
+6 SET EVENT=$GET(^TMP("XUMF MFS",$JOB,"PARAM","RLEC"))
+7 SET MFN=$GET(^TMP("XUMF MFS",$JOB,"PARAM","MFNCID"))
+8 SET EDT=$GET(^TMP("XUMF MFS",$JOB,"PARAM","MFEEDT"))
+9 SET CODE=$GET(^TMP("XUMF MFS",$JOB,"PARAM","PKV"))
+10 if EDT=""
SET EDT=$$NOW^XLFDT
if EVENT=""
SET EVENT="MAD"
+11 SET MFE=$$MFE^XUMFMFE(EVENT,MFN,EDT,CODE)
+12 IF $EXTRACT(MFE)="-"
SET ERROR=MFE
QUIT
+13 SET ^TMP(MTYP,$JOB,CNT)=MFE
+14 SET CNT=CNT+1
+15 ;
+16 QUIT
+17 ;
RDT ; table row definition/data segment
+1 ;
+2 if ERROR
QUIT
+3 ;
+4 NEW SEG,SEQ,ZZZ,FLD,FILE,IENS,VALUE,ERR,ZDTYP,FIELD,SEQ1,SEQ2,SEQ3
+5 NEW SEQ0,SEQ9,CNT1,CNT2,NODE,XXX,LKUP
+6 ;
+7 SET SEQ=0
+8 FOR
SET SEQ=$ORDER(^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+9 ;
+10 SET FLD=$ORDER(^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,0))
+11 ;
+12 IF 'FLD
Begin DoDot:2
+13 SET FILE=^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"FILE")
+14 SET IENS=$GET(^TMP("XUMF MFS",$JOB,"PARAM","IENS",SEQ))
+15 SET FIELD=^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"FIELD")
+16 SET ZDTYP=^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"DTYP")
+17 SET LKUP=$GET(^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,"LKUP"))
+18 IF LKUP
SET FIELD=FIELD_":"_LKUP
+19 SET VALUE=$$GET1^DIQ(FILE,IENS,FIELD)
+20 SET VALUE=$$DTYP^XUMFXP(VALUE,ZDTYP,HLCS,1)
End DoDot:2
+21 IF FLD
Begin DoDot:2
+22 SET ZDTYP=$GET(^TMP("XUMF MFS",$JOB,"PARAM","SEQ",SEQ,FLD))
+23 SET LKUP=$PIECE(ZDTYP,U,2)
SET ZDTYP=$PIECE(ZDTYP,U)
+24 IF LKUP
SET FLD=FLD_":"_LKUP
+25 SET VALUE=$$GET1^DIQ(IFN,IEN_",",FLD)
+26 SET VALUE=$$DTYP^XUMFXP(VALUE,ZDTYP,HLCS,1)
End DoDot:2
+27 ;
+28 SET ZZZ(SEQ)=VALUE
End DoDot:1
+29 ;
+30 KILL NODE
+31 SET (SEQ,SEQ0,SEQ9,SEQ1,CNT1)=0
SET NODE(0)=""
+32 FOR
SET SEQ1=$ORDER(ZZZ(SEQ1))
if 'SEQ1
QUIT
Begin DoDot:1
+33 SET VALUE=ZZZ(SEQ1)
+34 IF $LENGTH(NODE(CNT1)_VALUE)>200
Begin DoDot:2
+35 SET CNT1=CNT1+1
SET SEQ9=SEQ0+SEQ9
End DoDot:2
+36 SET SEQ=$SELECT('CNT1:SEQ1,1:SEQ1-SEQ9)
+37 SET $PIECE(NODE(CNT1),HLFS,SEQ)=VALUE
+38 SET SEQ0=SEQ-1
End DoDot:1
+39 ;
+40 SET NODE="RDT"_HLFS_$GET(NODE(0))
KILL NODE(0)
+41 ;
+42 MERGE ^TMP(MTYP,$JOB,CNT)=^TMP("XUMF MFS",$JOB,"PARAM","RDF")
+43 SET CNT=CNT+1
+44 MERGE ^TMP(MTYP,$JOB,CNT)=NODE
+45 SET CNT=CNT+1
+46 ;
+47 QUIT
+48 ;
GROUP ; -- query group records
+1 ;
+2 if ERROR
QUIT
+3 ;
+4 SET IEN=0
+5 FOR
SET IEN=$ORDER(^TMP("XUMF MFS",$JOB,"PARAM","IEN",IEN))
if 'IEN
QUIT
Begin DoDot:1
+6 KILL ^TMP("XUMF MFS",$JOB,"PARAM","PKV")
+7 KILL ^TMP("XUMF MFS",$JOB,"PARAM","IENS")
+8 SET ^TMP("XUMF MFS",$JOB,"PARAM","PKV")=^TMP("XUMF MFS",$JOB,"PARAM",IEN,"PKV")
+9 MERGE ^TMP("XUMF MFS",$JOB,"PARAM","IENS")=^TMP("XUMF MFS",$JOB,"PARAM",IEN,"IENS")
+10 DO MFE
DO RDT
End DoDot:1
+11 ;
+12 QUIT
+13 ;
SEND ; -- send HL7 message
+1 ;
+2 IF 'MFK
IF ERROR
QUIT
+3 ;
+4 SET HLP("PRIORITY")="I"
+5 ;
+6 IF 'TYPE
DO GENERATE^HLMA(PROTOCOL,"GM",1,.HLRESLT,"",.HLP)
+7 IF TYPE
IF (TYPE<10)
DO DIRECT^HLMA(PROTOCOL,"GM",1,.HLRESLT,"",.HLP)
+8 IF (TYPE>9)
DO GENACK^HLMA1($GET(HL("EID")),$GET(HLMTIENS),$GET(HL("EIDS")),"GM",1,.HLRESLT)
+9 ;
+10 ; check for error
+11 IF ($PIECE($GET(HLRESLT),U,3)'="")
Begin DoDot:1
+12 SET ERROR=1_U_$PIECE(HLRESLT,HLFS,3)_U_$PIECE(HLRESLT,HLFS,2)_U_$PIECE(HLRESLT,U)
End DoDot:1
QUIT
+13 ;
+14 ; successful call, message ID returned
+15 SET ERROR="0^"_$PIECE($GET(HLRESLT),U,1)
+16 ;
+17 QUIT
+18 ;
EXIT ; -- exit
+1 ;
+2 DO CLEAN^DILF
+3 ;
+4 KILL ^TMP("HLS",$JOB),^TMP("HLA",$JOB)
+5 KILL ^TMP("XUMF MFS",$JOB)
+6 ;
+7 QUIT
+8 ;
LLNK ; -- dynamic addressing BROADCAST
+1 ;
+2 if TYPE>9
QUIT
+3 ;
+4 IF $GET(^TMP("XUMF MFS",$JOB,"PARAM","LLNK"))'=""
Begin DoDot:1
+5 SET HLL("LINKS",1)=^TMP("XUMF MFS",$JOB,"PARAM","LLNK")
End DoDot:1
QUIT
+6 ;
+7 if '$$SERVER()
QUIT
+8 ;
+9 if TYPE
QUIT
+10 if '$GET(^TMP("XUMF MFS",$JOB,"PARAM","BROADCAST"))
QUIT
+11 ;
+12 NEW I,J,LLNK
+13 ;
+14 SET (I,J)=0
+15 FOR
SET I=$ORDER(^HLCS(870,"C",I))
if 'I
QUIT
Begin DoDot:1
+16 SET J=$ORDER(^HLCS(870,"C",I,0))
if 'J
QUIT
+17 SET LLNK=$PIECE($GET(^HLCS(870,J,0)),U)
+18 SET HLL("LINKS",I)="XUMF MFS^"_LLNK
End DoDot:1
+19 ;
+20 QUIT
+21 ;
SERVER() ; -- servers
+1 ;
+2 NEW I
+3 ;
+4 SET I=$$KSP^XUPARAM("INST")
if 'I
QUIT 0
+5 ;
+6 ;VAB
if I=662
QUIT 1
+7 ;BP TEST
if I=442
QUIT 1
+8 ;FORUM
if I=12000
QUIT 1
+9 ;HEC
if I=100002
QUIT 1
+10 ;
+11 QUIT 0
+12 ;
