XUMFI ;CIOFO-SF/RAM - Master File Interface ;8/14/06
;;8.0;KERNEL;**206,217,218,335,261,369**;Jul 10, 1995;Build 27
;
; 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 XUMFP to initialize the PARAM array.
; See XUMFP 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^XUMFI0,BUILD,LLNK,SEND,EXIT
;
;
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,ZZZ
;
Q
;
MFK ; -- master file acknowledgement
;
N X
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
;
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
;
ZZZ ; [Z...] segment
;
Q:ERROR
;
N SEG,SEQ,ZZZ,FLD,FILE,IENS,VALUE,ERR,ZDTYP,FIELD,SEQ1,SEQ2,SEQ3
N SEQ0,SEQ9,CNT1,CNT2,NODE,XXX
;
S SEG="",SEQ=0
F S SEG=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG)) Q:SEG="" D
.S ZZZ=SEG
.F S SEQ=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ)) Q:'SEQ D
..;
..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 FLD=$O(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,0))
..;
..I 'FLD D
...S FILE=^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"FILE")
...S IENS=$G(^TMP("XUMF MFS",$J,"PARAM","IENS",SEG,SEQ))
...S FIELD=^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"FIELD")
...S ZDTYP=^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"DTYP")
...I $P(ZDTYP,U,3)[":" S FIELD=FIELD_$P(ZDTYP,U,3)
...S VALUE=$$GET1^DIQ(FILE,IENS,FIELD)
...S VALUE=$$DTYP^XUMFP(VALUE,ZDTYP,HLCS,1)
..I FLD D
...S ZDTYP=$G(^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,FLD))
...I $P(ZDTYP,U,3)[":" S FLD=FLD_$P(ZDTYP,U,3)
...S VALUE=$$GET1^DIQ(IFN,IEN_",",FLD)
...S VALUE=$$DTYP^XUMFP(VALUE,ZDTYP,HLCS,1)
..;
..S ZZZ(SEQ)=VALUE
.;
.S X=0
.F S X=$O(ZZZ(X)) Q:'X D
..S SEQ1=$P(X,"."),SEQ2=+$P(X,".",2)
..S XXX(SEQ1,SEQ2)=ZZZ(X)
.K ZZZ
.M ZZZ=XXX
.;
.K NODE
.S (SEQ,SEQ0,SEQ9,SEQ1,CNT1,CNT2)=0,NODE=""
.F S SEQ1=$O(ZZZ(SEQ1)) Q:'SEQ1 D
..S SEQ2=0,VALUE=$G(ZZZ(SEQ1,SEQ2))
..F S SEQ2=$O(ZZZ(SEQ1,SEQ2)) Q:'SEQ2 D
...S $P(VALUE,HLCS,SEQ2)=ZZZ(SEQ1,SEQ2)
..S NODE(CNT1)=$G(NODE(CNT1))
..I NODE(CNT1)'="",$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=SEG_HLFS_$G(NODE(0)) K NODE(0)
.;
.M ^TMP(MTYP,$J,CNT)=NODE
.S CNT=CNT+1
.;
.I $D(^TMP("XUMF MFS",$J,"PARAM",IEN,"ROUTINE",5)) D
..S X=0 F S X=$O(^TMP("XUMF MFS",$J,"PARAM",IEN,"ROUTINE",5,X)) Q:'X D
...S IENS=$G(^TMP("XUMF MFS",$J,"PARAM",IEN,"ROUTINE",5,X))
...S VALUE=$$GET1^DIQ(9.818,IENS,.01),$P(NODE,HLFS,6)=VALUE
...S VALUE=$$GET1^DIQ(9.818,IENS,2),$P(NODE,HLFS,7)=VALUE
...S ^TMP(MTYP,$J,CNT)=NODE
...S CNT=CNT+1
;
Q
;
SUBCOMP ; -- subcomponents
;
N A,YYY
;
M A=^TMP("XUMF MFS",$J,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS")
S YYY=""
;
S SEQ3=0
F S SEQ3=$O(A(SEQ3)) Q:'SEQ3 D
.S FLD=$O(A(SEQ3,0))
.S ZDTYP=$G(A(SEQ3,FLD))
.I $P(ZDTYP,U,3)[":" S FLD=FLD_$P(ZDTYP,U,3)
.S VALUE=$$GET1^DIQ(IFN,IEN_",",FLD)
.S VALUE=$$DTYP^XUMFP(VALUE,ZDTYP,HLSCS,1)
.S $P(YYY,HLSCS,SEQ3)=VALUE
;
S ZZZ(SEQ)=YYY
;
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,ZZZ
;
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),$G(HLMTIENS) D
.D GENACK^HLMA1(HL("EID"),HLMTIENS,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 MFK^"_LLNK
;
Q
;
SERVER() ; -- servers
;
N I
;
S I=$$KSP^XUPARAM("INST") Q:'I 0
;
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[HXUMFI 7432 printed Nov 22, 2024@17:20:59 Page 2
XUMFI ;CIOFO-SF/RAM - Master File Interface ;8/14/06
+1 ;;8.0;KERNEL;**206,217,218,335,261,369**;Jul 10, 1995;Build 27
+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 XUMFP to initialize the PARAM array.
+8 ; See XUMFP 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^XUMFI0
DO BUILD
DO LLNK
DO SEND
DO EXIT
+9 ;
+10 ;
+11 QUIT
+12 ;
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 ZZZ
+15 ;
+16 QUIT
+17 ;
MFK ; -- master file acknowledgement
+1 ;
+2 NEW X
+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 QUIT
+8 ;
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 ;
ZZZ ; [Z...] 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
+6 ;
+7 SET SEG=""
SET SEQ=0
+8 FOR
SET SEG=$ORDER(^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG))
if SEG=""
QUIT
Begin DoDot:1
+9 SET ZZZ=SEG
+10 FOR
SET SEQ=$ORDER(^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ))
if 'SEQ
QUIT
Begin DoDot:2
+11 ;
+12 SET SEQ1=$PIECE(SEQ,".")
SET SEQ2=$PIECE(SEQ,".",2)
+13 SET SEQ3=$ORDER(^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS",0))
+14 ;
+15 IF SEQ3
DO SUBCOMP
QUIT
+16 ;
+17 SET FLD=$ORDER(^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ,0))
+18 ;
+19 IF 'FLD
Begin DoDot:3
+20 SET FILE=^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ,"FILE")
+21 SET IENS=$GET(^TMP("XUMF MFS",$JOB,"PARAM","IENS",SEG,SEQ))
+22 SET FIELD=^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ,"FIELD")
+23 SET ZDTYP=^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ,"DTYP")
+24 IF $PIECE(ZDTYP,U,3)[":"
SET FIELD=FIELD_$PIECE(ZDTYP,U,3)
+25 SET VALUE=$$GET1^DIQ(FILE,IENS,FIELD)
+26 SET VALUE=$$DTYP^XUMFP(VALUE,ZDTYP,HLCS,1)
End DoDot:3
+27 IF FLD
Begin DoDot:3
+28 SET ZDTYP=$GET(^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ,FLD))
+29 IF $PIECE(ZDTYP,U,3)[":"
SET FLD=FLD_$PIECE(ZDTYP,U,3)
+30 SET VALUE=$$GET1^DIQ(IFN,IEN_",",FLD)
+31 SET VALUE=$$DTYP^XUMFP(VALUE,ZDTYP,HLCS,1)
End DoDot:3
+32 ;
+33 SET ZZZ(SEQ)=VALUE
End DoDot:2
+34 ;
+35 SET X=0
+36 FOR
SET X=$ORDER(ZZZ(X))
if 'X
QUIT
Begin DoDot:2
+37 SET SEQ1=$PIECE(X,".")
SET SEQ2=+$PIECE(X,".",2)
+38 SET XXX(SEQ1,SEQ2)=ZZZ(X)
End DoDot:2
+39 KILL ZZZ
+40 MERGE ZZZ=XXX
+41 ;
+42 KILL NODE
+43 SET (SEQ,SEQ0,SEQ9,SEQ1,CNT1,CNT2)=0
SET NODE=""
+44 FOR
SET SEQ1=$ORDER(ZZZ(SEQ1))
if 'SEQ1
QUIT
Begin DoDot:2
+45 SET SEQ2=0
SET VALUE=$GET(ZZZ(SEQ1,SEQ2))
+46 FOR
SET SEQ2=$ORDER(ZZZ(SEQ1,SEQ2))
if 'SEQ2
QUIT
Begin DoDot:3
+47 SET $PIECE(VALUE,HLCS,SEQ2)=ZZZ(SEQ1,SEQ2)
End DoDot:3
+48 SET NODE(CNT1)=$GET(NODE(CNT1))
+49 IF NODE(CNT1)'=""
IF $LENGTH(NODE(CNT1)_VALUE)>200
Begin DoDot:3
+50 SET CNT1=CNT1+1
SET SEQ9=SEQ0+SEQ9
End DoDot:3
+51 SET SEQ=$SELECT('CNT1:SEQ1,1:SEQ1-SEQ9)
+52 SET $PIECE(NODE(CNT1),HLFS,SEQ)=VALUE
+53 SET SEQ0=SEQ-1
End DoDot:2
+54 ;
+55 SET NODE=SEG_HLFS_$GET(NODE(0))
KILL NODE(0)
+56 ;
+57 MERGE ^TMP(MTYP,$JOB,CNT)=NODE
+58 SET CNT=CNT+1
+59 ;
+60 IF $DATA(^TMP("XUMF MFS",$JOB,"PARAM",IEN,"ROUTINE",5))
Begin DoDot:2
+61 SET X=0
FOR
SET X=$ORDER(^TMP("XUMF MFS",$JOB,"PARAM",IEN,"ROUTINE",5,X))
if 'X
QUIT
Begin DoDot:3
+62 SET IENS=$GET(^TMP("XUMF MFS",$JOB,"PARAM",IEN,"ROUTINE",5,X))
+63 SET VALUE=$$GET1^DIQ(9.818,IENS,.01)
SET $PIECE(NODE,HLFS,6)=VALUE
+64 SET VALUE=$$GET1^DIQ(9.818,IENS,2)
SET $PIECE(NODE,HLFS,7)=VALUE
+65 SET ^TMP(MTYP,$JOB,CNT)=NODE
+66 SET CNT=CNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+67 ;
+68 QUIT
+69 ;
SUBCOMP ; -- subcomponents
+1 ;
+2 NEW A,YYY
+3 ;
+4 MERGE A=^TMP("XUMF MFS",$JOB,"PARAM","SEG",SEG,"SEQ",SEQ,"HLSCS")
+5 SET YYY=""
+6 ;
+7 SET SEQ3=0
+8 FOR
SET SEQ3=$ORDER(A(SEQ3))
if 'SEQ3
QUIT
Begin DoDot:1
+9 SET FLD=$ORDER(A(SEQ3,0))
+10 SET ZDTYP=$GET(A(SEQ3,FLD))
+11 IF $PIECE(ZDTYP,U,3)[":"
SET FLD=FLD_$PIECE(ZDTYP,U,3)
+12 SET VALUE=$$GET1^DIQ(IFN,IEN_",",FLD)
+13 SET VALUE=$$DTYP^XUMFP(VALUE,ZDTYP,HLSCS,1)
+14 SET $PIECE(YYY,HLSCS,SEQ3)=VALUE
End DoDot:1
+15 ;
+16 SET ZZZ(SEQ)=YYY
+17 ;
+18 QUIT
+19 ;
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 ZZZ
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)
IF $GET(HLMTIENS)
Begin DoDot:1
+9 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.HLRESLT)
End DoDot:1
+10 ;
+11 ; check for error
+12 IF ($PIECE($GET(HLRESLT),U,3)'="")
Begin DoDot:1
+13 SET ERROR=1_U_$PIECE(HLRESLT,HLFS,3)_U_$PIECE(HLRESLT,HLFS,2)_U_$PIECE(HLRESLT,U)
End DoDot:1
QUIT
+14 ;
+15 ; successful call, message ID returned
+16 SET ERROR="0^"_$PIECE($GET(HLRESLT),U,1)
+17 ;
+18 QUIT
+19 ;
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 MFK^"_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 ;BP TEST
if I=442
QUIT 1
+7 ;FORUM
if I=12000
QUIT 1
+8 ;HEC
if I=100002
QUIT 1
+9 ;
+10 QUIT 0
+11 ;
