RAHLACK ;HISC/PAV - Process Appl Ack for (ORM) and (ORU) Msgs;14 Feb 2019 10:40 AM
;;5.0;Radiology/Nuclear Medicine;**47,154**;June 16, 2006;Build 1
; Based on information from incoming Ack, e-mail message is
; sent to Mail group: G.RAD HL7 MESSAGES
;
;Integration Agreements
;----------------------
;MSG^DIALOG(2050); $$GETAPP^HLCS2(2887); $$MSG^HLCSUTL(3099);^XMD(10070)
;
MAIN ; Process incoming ACK, called from 2.4 protocols
;
N CNT,ERR,ERROR,EXIT,GROUP,HLFS,HLCS,HLSCS,I,NUMBER,RAERR,SEG,X,Y
D INIT,PROCESS,EXIT
Q
;
INIT ; initialize
;
;S DUZ(0)="@"
;
S ERROR=0
S HLFS=HL("FS"),HLCS=$E(HL("ECH"))
S HLSCS=$E(HL("ECH"),4),HLREP=$E(HL("ECH"),2)
Q
;
PROCESS ; pull message text
;
N SEG
F X HLNEXT Q:HLQUIT'>0 S SEG=$P(HLNODE,HLFS) D:SEG'=""
.D:"^MSH^MSA^ERR^"[(U_SEG_U) @SEG
Q
;
MSH ; -- MSH segment
;
Q
;
MSA ; -- MSA segment
;
N CODE,DA,DIC,RAHLMA,RAMSA,RAMSG,X
S CODE=$P(HLNODE,HLFS,2)
I CODE="AE"!(CODE="AR") D
.S ERROR=ERROR_U_$P(HLNODE,HLFS,4,99)
.S RAERR("DIMSG",1)=CODE_" ACK Code received to the Message ID: "_$P(HLNODE,HLFS,3)
.S RAMSA=$P(HLNODE,HLFS,3),RAMSG=$$MSG^HLCSUTL(RAMSA,"RAHLMA(1)")
.I RAMSG>0 S RAERR("DIMSG",2)=RAHLMA(1,1)
Q
;
ERR ; -- ERR segment
;
; Set ERR segment handler here...
Q
;
EM(MID,ERROR,RAERR,XMSUB,XMY) ; error message
;
N GROUP,RAMPG,RAX,XMDUZ,XMMG,XMTEXT,XMZ
;
D MSG^DIALOG("AM",.RAX,80,"","RAERR")
;
S RAX(.1)="HL7 message ID: "_$G(MID)
S RAX(.2)="",RAX(.3)=$G(ERROR)
S:$G(XMSUB)="" XMSUB="RAD ACK ERROR/WARNING/INFO"
;p154 - undefined HL("SAN") error, add $D check
S RAMPG=$S($D(HL("SAN")):$P($$GETAPP^HLCS2(HL("SAN")),U,1),1:"") ;RAMPG="G.RAD HL7 MESSAGES"
S:'$L(RAMPG) RAMPG="G.RAD HL7 MESSAGES"
S XMY(RAMPG)="",XMDUZ=.5
S XMTEXT="RAX("
;
D ^XMD
Q
;
GSTATUS(HLRESLT,ED) ;
Q:'$D(HLRESLT)
N I,RAERR,ERROR,XMSUB
S XMSUB="RAD HL7: Error in GENERATE^HLMA"
S ERROR="For Event Driver: "_$P($G(^ORD(101,+$G(ED),0)),U)
I +$P(HLRESLT,U,2)!$L($P(HLRESLT,U,3)) D
.S RAERR(1)=$P(HLRESLT,U,2),RAERR(2)=$P(HLRESLT,U,3)
.D EM(+HLRESLT,ERROR_">>"_HLRESLT_"<<",.RAERR,XMSUB_" single subscriber")
.K RAERR
S I=0 F S I=$O(HLRESLT(I)) Q:'I D:$L($P(HLRESLT(I),U,2))!$L($P(HLRESLT(I),U,3))
.S RAERR(1)=$P(HLRESLT(I),U,2),RAERR(2)=$P(HLRESLT(I),U,3)
.D EM(+HLRESLT(I),ERROR,.RAERR,XMSUB_" multi subscribers")
.K RAERR
Q
;
ASTATUS(HLRESLT,MID,VNDR) ;ACK error
;
Q:'$D(HLRESLT)
N I,RAERR,ERROR,XMSUB
S XMSUB="RAD HL7: Error in GENACK^HLMA1"
S ERROR="ACK to:"_VNDR_" Message ID: "_MID
I +$P(HLRESLT,U,2)!$L($P(HLRESLT,U,3)) D
.S RAERR(1)=$P(HLRESLT,U,2),RAERR(2)=$P(HLRESLT,U,3)
.D EM(+HLRESLT,ERROR_">>"_HLRESLT_"<<",.RAERR,XMSUB)
.K RAERR
Q
EXIT ; cleanup, and quit.
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAHLACK 2781 printed Oct 16, 2024@18:35:49 Page 2
RAHLACK ;HISC/PAV - Process Appl Ack for (ORM) and (ORU) Msgs;14 Feb 2019 10:40 AM
+1 ;;5.0;Radiology/Nuclear Medicine;**47,154**;June 16, 2006;Build 1
+2 ; Based on information from incoming Ack, e-mail message is
+3 ; sent to Mail group: G.RAD HL7 MESSAGES
+4 ;
+5 ;Integration Agreements
+6 ;----------------------
+7 ;MSG^DIALOG(2050); $$GETAPP^HLCS2(2887); $$MSG^HLCSUTL(3099);^XMD(10070)
+8 ;
MAIN ; Process incoming ACK, called from 2.4 protocols
+1 ;
+2 NEW CNT,ERR,ERROR,EXIT,GROUP,HLFS,HLCS,HLSCS,I,NUMBER,RAERR,SEG,X,Y
+3 DO INIT
DO PROCESS
DO EXIT
+4 QUIT
+5 ;
INIT ; initialize
+1 ;
+2 ;S DUZ(0)="@"
+3 ;
+4 SET ERROR=0
+5 SET HLFS=HL("FS")
SET HLCS=$EXTRACT(HL("ECH"))
+6 SET HLSCS=$EXTRACT(HL("ECH"),4)
SET HLREP=$EXTRACT(HL("ECH"),2)
+7 QUIT
+8 ;
PROCESS ; pull message text
+1 ;
+2 NEW SEG
+3 FOR
XECUTE HLNEXT
if HLQUIT'>0
QUIT
SET SEG=$PIECE(HLNODE,HLFS)
if SEG'=""
Begin DoDot:1
+4 if "^MSH^MSA^ERR^"[(U_SEG_U)
DO @SEG
End DoDot:1
+5 QUIT
+6 ;
MSH ; -- MSH segment
+1 ;
+2 QUIT
+3 ;
MSA ; -- MSA segment
+1 ;
+2 NEW CODE,DA,DIC,RAHLMA,RAMSA,RAMSG,X
+3 SET CODE=$PIECE(HLNODE,HLFS,2)
+4 IF CODE="AE"!(CODE="AR")
Begin DoDot:1
+5 SET ERROR=ERROR_U_$PIECE(HLNODE,HLFS,4,99)
+6 SET RAERR("DIMSG",1)=CODE_" ACK Code received to the Message ID: "_$PIECE(HLNODE,HLFS,3)
+7 SET RAMSA=$PIECE(HLNODE,HLFS,3)
SET RAMSG=$$MSG^HLCSUTL(RAMSA,"RAHLMA(1)")
+8 IF RAMSG>0
SET RAERR("DIMSG",2)=RAHLMA(1,1)
End DoDot:1
+9 QUIT
+10 ;
ERR ; -- ERR segment
+1 ;
+2 ; Set ERR segment handler here...
+3 QUIT
+4 ;
EM(MID,ERROR,RAERR,XMSUB,XMY) ; error message
+1 ;
+2 NEW GROUP,RAMPG,RAX,XMDUZ,XMMG,XMTEXT,XMZ
+3 ;
+4 DO MSG^DIALOG("AM",.RAX,80,"","RAERR")
+5 ;
+6 SET RAX(.1)="HL7 message ID: "_$GET(MID)
+7 SET RAX(.2)=""
SET RAX(.3)=$GET(ERROR)
+8 if $GET(XMSUB)=""
SET XMSUB="RAD ACK ERROR/WARNING/INFO"
+9 ;p154 - undefined HL("SAN") error, add $D check
+10 ;RAMPG="G.RAD HL7 MESSAGES"
SET RAMPG=$SELECT($DATA(HL("SAN")):$PIECE($$GETAPP^HLCS2(HL("SAN")),U,1),1:"")
+11 if '$LENGTH(RAMPG)
SET RAMPG="G.RAD HL7 MESSAGES"
+12 SET XMY(RAMPG)=""
SET XMDUZ=.5
+13 SET XMTEXT="RAX("
+14 ;
+15 DO ^XMD
+16 QUIT
+17 ;
GSTATUS(HLRESLT,ED) ;
+1 if '$DATA(HLRESLT)
QUIT
+2 NEW I,RAERR,ERROR,XMSUB
+3 SET XMSUB="RAD HL7: Error in GENERATE^HLMA"
+4 SET ERROR="For Event Driver: "_$PIECE($GET(^ORD(101,+$GET(ED),0)),U)
+5 IF +$PIECE(HLRESLT,U,2)!$LENGTH($PIECE(HLRESLT,U,3))
Begin DoDot:1
+6 SET RAERR(1)=$PIECE(HLRESLT,U,2)
SET RAERR(2)=$PIECE(HLRESLT,U,3)
+7 DO EM(+HLRESLT,ERROR_">>"_HLRESLT_"<<",.RAERR,XMSUB_" single subscriber")
+8 KILL RAERR
End DoDot:1
+9 SET I=0
FOR
SET I=$ORDER(HLRESLT(I))
if 'I
QUIT
if $LENGTH($PIECE(HLRESLT(I),U,2))!$LENGTH($PIECE(HLRESLT(I),U,3))
Begin DoDot:1
+10 SET RAERR(1)=$PIECE(HLRESLT(I),U,2)
SET RAERR(2)=$PIECE(HLRESLT(I),U,3)
+11 DO EM(+HLRESLT(I),ERROR,.RAERR,XMSUB_" multi subscribers")
+12 KILL RAERR
End DoDot:1
+13 QUIT
+14 ;
ASTATUS(HLRESLT,MID,VNDR) ;ACK error
+1 ;
+2 if '$DATA(HLRESLT)
QUIT
+3 NEW I,RAERR,ERROR,XMSUB
+4 SET XMSUB="RAD HL7: Error in GENACK^HLMA1"
+5 SET ERROR="ACK to:"_VNDR_" Message ID: "_MID
+6 IF +$PIECE(HLRESLT,U,2)!$LENGTH($PIECE(HLRESLT,U,3))
Begin DoDot:1
+7 SET RAERR(1)=$PIECE(HLRESLT,U,2)
SET RAERR(2)=$PIECE(HLRESLT,U,3)
+8 DO EM(+HLRESLT,ERROR_">>"_HLRESLT_"<<",.RAERR,XMSUB)
+9 KILL RAERR
End DoDot:1
+10 QUIT
EXIT ; cleanup, and quit.
+1 QUIT
