XUMFHPQ ;ISS/RAM - MFS param server-side handler ;06/28/00
;;8.0;KERNEL;**299**;Jul 10, 1995
;
Q
;
MAIN ; -- entry point
;
N CNT,ERR,I,X,HLFS,HLCS,ERROR,HLRESLTA,IFN,IEN,TYPE
N VALUE,PARAM,ROOT,SEG,HLSCS,MTYP
;
D INIT,PROCESS,RESPONSE,SEND,EXIT
;
Q
;
INIT ; -- initialize
;
K ^TMP("DILIST",$J),^TMP("DIERR",$J)
K ^TMP("HLS",$J),^TMP("HLA",$J)
;
S ERROR=0,CNT=1,MTYP="HLA"
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^XUMFHPR(ERROR,.ERR)
;
Q
;
QRD ; -- QRD segment
;
Q:ERROR
;
N WHO,WHAT
;
S WHO=$P(HLNODE,HLFS,9)
I WHO="" D Q
.S ERROR="1^QRD segment has null missing WHO parameter"
.D EM^XUMFHPR(ERROR,.ERR)
S WHAT=$P(HLNODE,HLFS,10)
I WHAT="" D Q
.S ERROR="1^QRD segment has null missing WHAT parameter"
.D EM^XUMFHPR(ERROR,.ERR)
;
S IFN=+WHAT
I IFN'=4.001 S ERROR="1^QRD segment invalid WHAT for protocol" Q
;
S IEN=$$FIND1^DIC(4.001,,"B",$P(WHO,HLCS))
;
I 'IEN D Q
.S ERROR="1^"_$P(WHO,HLCS)_" not a supported master file"
;
Q
;
;
RESPONSE ; -- build MFR
;
D INI1,MSA1,QRD1,MFI1,MFE1,ZZZ1,ZZS1
;
Q
;
INI1 ; -- initialize
;
Q:ERROR
;
D MAIN^XUMFXP(IFN,IEN,11,.PARAM,.ERROR)
I $G(ERROR) D
.S ERROR="1error INI1 of XUMFHPQ"
.D EM^XUMFHPR(ERROR,.ERR)
;
Q
;
MSA1 ; - ACK
;
S ^TMP(MTYP,$J,CNT)="MSA"_HLFS_$S(ERROR:"AE",1:"AA")_HLFS_HL("MID")
S CNT=CNT+1
;
Q
;
QRD1 ; -- query definition segment
;
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
;
MFI1 ; 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
;
MFE1 ; 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
;
ZZZ1 ; ZZZ segment
;
Q:ERROR
;
N NODE,SEQ,VALUE,FIELD
;
S NODE=""
;
;zero node
F SEQ=1:1:6 D
.S FIELD=".0"_SEQ
.S VALUE=$$GET1^DIQ(4.001,IEN_",",FIELD)
.S $P(NODE,HLFS,SEQ)=VALUE
;
;mfe node
F SEQ=1:1:9 D
.S FIELD="4."_SEQ
.S VALUE=$$GET1^DIQ(4.001,IEN_",",FIELD)
.S $P(NODE,HLFS,SEQ+6)=VALUE
F SEQ=1,2,4:1:7 D
.S FIELD="4.1"_SEQ
.S VALUE=$$GET1^DIQ(4.001,IEN_",",FIELD)
.S $P(NODE,HLFS,SEQ+15)=VALUE
;
S ^TMP(MTYP,$J,CNT)="ZMF"_HLFS_NODE
S CNT=CNT+1
;
Q
;
ZZS1 ; - ZZS segment
;
Q:ERROR
;
N IDX,FLD,VALUE,NODE
;
S IDX=0
F S IDX=$O(^DIC(4.001,IEN,1,IDX)) Q:'IDX D
.S IENS=IDX_","_IEN_",",NODE=""
.F I=1:1:9 D
..S FLD=".0"_I
..S VALUE=$$GET1^DIQ(4.011,IENS,FLD)
..S $P(NODE,HLFS,I)=VALUE
.;
.S NODE="ZZS"_HLFS_NODE
.S ^TMP(MTYP,$J,CNT)=NODE
.S CNT=CNT+1
;
Q
;
SEND ; -- send HL7 message
;
S HLP("PRIORITY")="I"
;
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
;
XUMFHPQ ;ISS/RAM - MFS param server-side handler ;06/28/00
+1 ;;8.0;KERNEL;**299**;Jul 10, 1995
+2 ;
+3 QUIT
+4 ;
MAIN ; -- entry point
+1 ;
+2 NEW CNT,ERR,I,X,HLFS,HLCS,ERROR,HLRESLTA,IFN,IEN,TYPE
+3 NEW VALUE,PARAM,ROOT,SEG,HLSCS,MTYP
+4 ;
+5 DO INIT
DO PROCESS
DO RESPONSE
DO SEND
DO EXIT
+6 ;
+7 QUIT
+8 ;
INIT ; -- initialize
+1 ;
+2 KILL ^TMP("DILIST",$JOB),^TMP("DIERR",$JOB)
+3 KILL ^TMP("HLS",$JOB),^TMP("HLA",$JOB)
+4 ;
+5 SET ERROR=0
SET CNT=1
SET MTYP="HLA"
+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^XUMFHPR(ERROR,.ERR)
End DoDot:1
+9 ;
+10 QUIT
+11 ;
QRD ; -- QRD segment
+1 ;
+2 IF ERROR
QUIT
+3 ;
+4 NEW WHO,WHAT
+5 ;
+6 SET WHO=$PIECE(HLNODE,HLFS,9)
+7 IF WHO=""
Begin DoDot:1
+8 SET ERROR="1^QRD segment has null missing WHO parameter"
+9 DO EM^XUMFHPR(ERROR,.ERR)
End DoDot:1
QUIT
+10 SET WHAT=$PIECE(HLNODE,HLFS,10)
+11 IF WHAT=""
Begin DoDot:1
+12 SET ERROR="1^QRD segment has null missing WHAT parameter"
+13 DO EM^XUMFHPR(ERROR,.ERR)
End DoDot:1
QUIT
+14 ;
+15 SET IFN=+WHAT
+16 IF IFN'=4.001
SET ERROR="1^QRD segment invalid WHAT for protocol"
QUIT
+17 ;
+18 SET IEN=$$FIND1^DIC(4.001,,"B",$PIECE(WHO,HLCS))
+19 ;
+20 IF 'IEN
Begin DoDot:1
+21 SET ERROR="1^"_$PIECE(WHO,HLCS)_" not a supported master file"
End DoDot:1
QUIT
+22 ;
+23 QUIT
+24 ;
+25 ;
RESPONSE ; -- build MFR
+1 ;
+2 DO INI1
DO MSA1
DO QRD1
DO MFI1
DO MFE1
DO ZZZ1
DO ZZS1
+3 ;
+4 QUIT
+5 ;
INI1 ; -- initialize
+1 ;
+2 IF ERROR
QUIT
+3 ;
+4 DO MAIN^XUMFXP(IFN,IEN,11,.PARAM,.ERROR)
+5 IF $GET(ERROR)
Begin DoDot:1
+6 SET ERROR="1error INI1 of XUMFHPQ"
+7 DO EM^XUMFHPR(ERROR,.ERR)
End DoDot:1
+8 ;
+9 QUIT
+10 ;
MSA1 ; - ACK
+1 ;
+2 SET ^TMP(MTYP,$JOB,CNT)="MSA"_HLFS_$SELECT(ERROR:"AE",1:"AA")_HLFS_HL("MID")
+3 SET CNT=CNT+1
+4 ;
+5 QUIT
+6 ;
QRD1 ; -- query definition segment
+1 ;
+2 IF ERROR
QUIT
+3 ;
+4 NEW QDT,QFC,QP,QID,ZDRT,ZDRDT,QLR,WHO,WHAT,WDDC,WDCVQ,QRL,QRD
+5 ;
+6 SET QDT=$GET(^TMP("XUMF MFS",$JOB,"PARAM","QDT"))
+7 SET QFC=$GET(^TMP("XUMF MFS",$JOB,"PARAM","QFC"))
+8 SET QP=$GET(^TMP("XUMF MFS",$JOB,"PARAM","QP"))
+9 SET QID=$GET(^TMP("XUMF MFS",$JOB,"PARAM","QID"))
+10 SET ZDRT=$GET(^TMP("XUMF MFS",$JOB,"PARAM","DRT"))
+11 SET ZDRDT=$GET(^TMP("XUMF MFS",$JOB,"PARAM","DRDT"))
+12 SET QLR=$GET(^TMP("XUMF MFS",$JOB,"PARAM","QLR"))
+13 SET WHO=$GET(^TMP("XUMF MFS",$JOB,"PARAM","WHO"))
+14 SET WHAT=$GET(^TMP("XUMF MFS",$JOB,"PARAM","WHAT"))
+15 SET WDDC=$GET(^TMP("XUMF MFS",$JOB,"PARAM","WDDC"))
+16 SET WDCVQ=$GET(^TMP("XUMF MFS",$JOB,"PARAM","WDCVQ"))
+17 SET QRL=$GET(^TMP("XUMF MFS",$JOB,"PARAM","QRL"))
+18 SET QRD="QRD"_HLFS_QDT_HLFS_QFC_HLFS_QP_HLFS_QID_HLFS_ZDRT_HLFS_ZDRDT
+19 SET QRD=QRD_HLFS_QLR_HLFS_WHO_HLFS_WHAT_HLFS_WDDC_HLFS_WDCVQ_HLFS_QRL
+20 SET ^TMP(MTYP,$JOB,CNT)=QRD
+21 SET CNT=CNT+1
+22 ;
+23 QUIT
+24 ;
MFI1 ; 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 ;
MFE1 ; 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 ;
ZZZ1 ; ZZZ segment
+1 ;
+2 IF ERROR
QUIT
+3 ;
+4 NEW NODE,SEQ,VALUE,FIELD
+5 ;
+6 SET NODE=""
+7 ;
+8 ;zero node
+9 FOR SEQ=1:1:6
Begin DoDot:1
+10 SET FIELD=".0"_SEQ
+11 SET VALUE=$$GET1^DIQ(4.001,IEN_",",FIELD)
+12 SET $PIECE(NODE,HLFS,SEQ)=VALUE
End DoDot:1
+13 ;
+14 ;mfe node
+15 FOR SEQ=1:1:9
Begin DoDot:1
+16 SET FIELD="4."_SEQ
+17 SET VALUE=$$GET1^DIQ(4.001,IEN_",",FIELD)
+18 SET $PIECE(NODE,HLFS,SEQ+6)=VALUE
End DoDot:1
+19 FOR SEQ=1,2,4:1:7
Begin DoDot:1
+20 SET FIELD="4.1"_SEQ
+21 SET VALUE=$$GET1^DIQ(4.001,IEN_",",FIELD)
+22 SET $PIECE(NODE,HLFS,SEQ+15)=VALUE
End DoDot:1
+23 ;
+24 SET ^TMP(MTYP,$JOB,CNT)="ZMF"_HLFS_NODE
+25 SET CNT=CNT+1
+26 ;
+27 QUIT
+28 ;
ZZS1 ; - ZZS segment
+1 ;
+2 IF ERROR
QUIT
+3 ;
+4 NEW IDX,FLD,VALUE,NODE
+5 ;
+6 SET IDX=0
+7 FOR
SET IDX=$ORDER(^DIC(4.001,IEN,1,IDX))
IF 'IDX
QUIT
Begin DoDot:1
+8 SET IENS=IDX_","_IEN_","
SET NODE=""
+9 FOR I=1:1:9
Begin DoDot:2
+10 SET FLD=".0"_I
+11 SET VALUE=$$GET1^DIQ(4.011,IENS,FLD)
+12 SET $PIECE(NODE,HLFS,I)=VALUE
End DoDot:2
+13 ;
+14 SET NODE="ZZS"_HLFS_NODE
+15 SET ^TMP(MTYP,$JOB,CNT)=NODE
+16 SET CNT=CNT+1
End DoDot:1
+17 ;
+18 QUIT
+19 ;
SEND ; -- send HL7 message
+1 ;
+2 SET HLP("PRIORITY")="I"
+3 ;
+4 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.HLRESLT)
+5 ;
+6 ; check for error
+7 IF ($PIECE($GET(HLRESLT),U,3)'="")
Begin DoDot:1
+8 SET ERROR=1_U_$PIECE(HLRESLT,HLFS,3)_U_$PIECE(HLRESLT,HLFS,2)_U_$PIECE(HLRESLT,U)
End DoDot:1
QUIT
+9 ;
+10 ; successful call, message ID returned
+11 SET ERROR="0^"_$PIECE($GET(HLRESLT),U,1)
+12 ;
+13 QUIT
+14 ;
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 ;
