XUMFHPQ.m

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

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---XUMFHPQ   5017     printed  Feb 18, 2025@23:37:15                                                                                                                                                                                                     Page 2

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       ;