XUMFMD5 ;ISS/RAM - MD5 Handler ;06/28/00
;;8.0;KERNEL;**407**;Jul 10, 1995;Build 8
;
;
Q
;
MAIN ; -- main
;
N ERROR,CNT,HLFS,HLCS,MFI,QRD
;
;
D INIT,PROCESS,MFR,SEND,EXIT
;
Q
;
INIT ; -- initialize
;
K ^TMP("HLA",$J)
;
S ERROR=0,CNT=1
;
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)=""
.Q:"^MSH^MSA^QRD^"'[(U_$P(HLNODE,HLFS)_U)
.D @($P(HLNODE,HLFS))
;
Q
;
MSH ; -- MSH segment
;
Q
;
QRD ; -- QRD segment
;
S MFI=$P(HLNODE,HLFS,10)
I MFI="" S ERROR="1^MFI not resolved HLNODE: "_$TR(HLNODE,HLFS,"#") Q
;
D EN^XUMF5I(MFI)
;
S QRD=HLNODE
;
Q
;
MFR ; -- response
;
D MSA,QRD1
;
Q
;
MSA ; -- Acknowledgement
;
N X
S X="MSA"_HLFS_$S(ERROR:"AE",1:"AA")_HLFS_HL("MID")_HLFS_$P(ERROR,U,2)
S ^TMP("HLA",$J,CNT)=X
S CNT=CNT+1
;
Q
;
QRD1 ; -- query definition segment
;
S ^TMP("HLA",$J,CNT)=QRD
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("HLA",$J)
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMFMD5 1442 printed Apr 09, 2024@21:19:20 Page 2
XUMFMD5 ;ISS/RAM - MD5 Handler ;06/28/00
+1 ;;8.0;KERNEL;**407**;Jul 10, 1995;Build 8
+2 ;
+3 ;
+4 QUIT
+5 ;
MAIN ; -- main
+1 ;
+2 NEW ERROR,CNT,HLFS,HLCS,MFI,QRD
+3 ;
+4 ;
+5 DO INIT
DO PROCESS
DO MFR
DO SEND
DO EXIT
+6 ;
+7 QUIT
+8 ;
INIT ; -- initialize
+1 ;
+2 KILL ^TMP("HLA",$JOB)
+3 ;
+4 SET ERROR=0
SET CNT=1
+5 ;
+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 if "^MSH^MSA^QRD^"'[(U_$PIECE(HLNODE,HLFS)_U)
QUIT
+5 DO @($PIECE(HLNODE,HLFS))
End DoDot:1
+6 ;
+7 QUIT
+8 ;
MSH ; -- MSH segment
+1 ;
+2 QUIT
+3 ;
QRD ; -- QRD segment
+1 ;
+2 SET MFI=$PIECE(HLNODE,HLFS,10)
+3 IF MFI=""
SET ERROR="1^MFI not resolved HLNODE: "_$TRANSLATE(HLNODE,HLFS,"#")
QUIT
+4 ;
+5 DO EN^XUMF5I(MFI)
+6 ;
+7 SET QRD=HLNODE
+8 ;
+9 QUIT
+10 ;
MFR ; -- response
+1 ;
+2 DO MSA
DO QRD1
+3 ;
+4 QUIT
+5 ;
MSA ; -- 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("HLA",$JOB,CNT)=X
+5 SET CNT=CNT+1
+6 ;
+7 QUIT
+8 ;
QRD1 ; -- query definition segment
+1 ;
+2 SET ^TMP("HLA",$JOB,CNT)=QRD
+3 SET CNT=CNT+1
+4 ;
+5 QUIT
+6 ;
SEND ; -- send HL7 message
+1 ;
+2 SET HLP("PRIORITY")="I"
+3 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.HLRESLT)
+4 ;
+5 ; check for error
+6 IF ($PIECE($GET(HLRESLT),U,3)'="")
Begin DoDot:1
+7 SET ERROR=1_U_$PIECE(HLRESLT,HLFS,3)_U_$PIECE(HLRESLT,HLFS,2)_U_$PIECE(HLRESLT,U)
End DoDot:1
QUIT
+8 ;
+9 ; successful call, message ID returned
+10 SET ERROR="0^"_$PIECE($GET(HLRESLT),U,1)
+11 ;
+12 QUIT
+13 ;
EXIT ; -- exit
+1 ;
+2 DO CLEAN^DILF
+3 ;
+4 KILL ^TMP("HLA",$JOB)
+5 ;
+6 QUIT
+7 ;
