DGRUHL1 ;ALB/SCK - RAI/MDS HL7 MESSAGING ACKNOWLEDGEMENT ROUTINES ; 7-9-1999
;;5.3;Registration;**190,354,419**;Aug 13, 1993
;
ACK ; Receives the ACK messages
; Input : All variables set by the HL7 package
; Output : None
;
N DGI,DGX,DGMSG,DGACK,DGPARAM,HLNODE,I,X
;
;Get message text
S ^TMP("DGRUACK",$H)="START PROCESS"
F I=1:1 X HLNEXT Q:(HLQUIT'>0) D
. S DGMSG(I,1)=HLNODE
. ; Check for segment length greater than 245
. S X=0 F S X=+$O(HLNODE(X)) Q:('X) S DGMSG(I,(X+1))=HLNODE(X)
;
M ^TMP("DGRUACK",$H,"HL")=DGMSG
; analyze the message and take appropriate response
; Quit if there is no valid message header
Q:$P(DGMSG(1,1),"^")'="MSH"
;
S X=1,DGPARAM=""
F S X=+$O(DGMSG(X)) Q:('X) D
. I $P(DGMSG(X,1),"^")="MSA" D
.. D PROCESS(DGMSG(X,1),.DGPARAM)
.. D NOTIFY
Q
;
NOTIFY ; TAsk sending of response notification
;
Q:$O(DGPARAM(""))="" ;added p-354
D SENDIT
Q
;
SENDIT ; Notify mail group that a response message was received from the RAI/MDS COTS system
; Input : MSGARY() - Array containing HL7 message received
; Output : None
;
N MSGTXT,XMY,XMTEXT,XMY,XMDUZ,XMDT,XMZ,LINE,XMB,XMCHAN,XMSUB
;
S XMCHAN=1
S XMSUB="RAI/MDS Message Receipt for "_DGPARAM(1)
S (XMDUZ,XMDUZ)="RAI/MDS APPLICATION"
;
M XMB=DGPARAM
S XMB="DGRU REJECT"
S XMDT=DT
D ^XMB
Q
;
PROCESS(DGMSG,DGPARAM) ;
N ACK,MSGID
;
Q:$G(DGMSG)']""
;
S ACK=$P(DGMSG,"^",2) ; Get acknowledgement code
; If the acknowledgement code is AA, then do not send notification
Q:ACK="AA" ;changed p-354
;
; Get outgoing message ID
S MSGID=$P(DGMSG,"^",3)
;
; Retrieve outgoing message information from file #773 for message ID
D EXTRACT(MSGID,.DGPARAM)
;
;; ===================================================================
;; The current HL7 package does not process acknowledgements other than
;; "accepted" through the process routine at the current time. This line
;; should be removed once the HL7 package is patched to process AR and AE messages.
;S:ACK="AA" DGPARAM(4)="" ;changed p-354
;; ===================================================================
;
; Retrieve rejection message from COTS acknowledgement message
S:'(ACK="AA") DGPARAM(4)=$P(DGMSG,"^",4)
S ^TMP("DGRUACK",$H,"ACK")=DGPARAM(4)
Q
;
; error bulletin to be sent
;
N DGIEN,DGOIEN,DGQUIT,DGTXT,NDX
;
S DGIEN=0
; Retrieve ien of outgoing message administration entry, file #773
F S DGIEN=+$O(^HLMA("C",MSGID,DGIEN)) Q:'DGIEN D Q:$G(DGQUIT)
. ; Retrieve ien of outgoing message text
. S DGOIEN=+$$GET1^DIQ(773,DGIEN,.01,"I")
. S DGPARAM(7)=$$GET1^DIQ(773,DGIEN,16,"E") ;changed p-419
. S DGPARAM(5)=$$GET1^DIQ(773,DGIEN,2,"I") ;added p-354
. Q:(DGOIEN<0)
. ; Retrieve information from message file
. ;S DGPARAM(5)=+$$GET1^DIQ(772,DGOIEN,6) ;changed p-354
. S X=$$GET1^DIQ(772,DGOIEN,200,"","DGTXT")
. I $D(DGTXT) D
.. S NDX=0
.. F S NDX=$O(DGTXT(NDX)) Q:'NDX D
... I $P(DGTXT(NDX),"^")="PID" D
.... S DGPARAM(1)=$$FMNAME^HLFNC($P(DGTXT(NDX),"^",6),"~")
.... S DGPARAM(2)=$P(DGTXT(NDX),"^",20)
... I $P(DGTXT(NDX),"^")="EVN" D
.... S DGPARAM(3)=$P(DGTXT(NDX),"^",2)
.... S DGPARAM(6)=$$FMTE^XLFDT($$FMDATE^HLFNC($P(DGTXT(NDX),"^",3)))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRUHL1 3374 printed Dec 13, 2024@02:58:39 Page 2
DGRUHL1 ;ALB/SCK - RAI/MDS HL7 MESSAGING ACKNOWLEDGEMENT ROUTINES ; 7-9-1999
+1 ;;5.3;Registration;**190,354,419**;Aug 13, 1993
+2 ;
ACK ; Receives the ACK messages
+1 ; Input : All variables set by the HL7 package
+2 ; Output : None
+3 ;
+4 NEW DGI,DGX,DGMSG,DGACK,DGPARAM,HLNODE,I,X
+5 ;
+6 ;Get message text
+7 SET ^TMP("DGRUACK",$HOROLOG)="START PROCESS"
+8 FOR I=1:1
XECUTE HLNEXT
if (HLQUIT'>0)
QUIT
Begin DoDot:1
+9 SET DGMSG(I,1)=HLNODE
+10 ; Check for segment length greater than 245
+11 SET X=0
FOR
SET X=+$ORDER(HLNODE(X))
if ('X)
QUIT
SET DGMSG(I,(X+1))=HLNODE(X)
End DoDot:1
+12 ;
+13 MERGE ^TMP("DGRUACK",$HOROLOG,"HL")=DGMSG
+14 ; analyze the message and take appropriate response
+15 ; Quit if there is no valid message header
+16 if $PIECE(DGMSG(1,1),"^")'="MSH"
QUIT
+17 ;
+18 SET X=1
SET DGPARAM=""
+19 FOR
SET X=+$ORDER(DGMSG(X))
if ('X)
QUIT
Begin DoDot:1
+20 IF $PIECE(DGMSG(X,1),"^")="MSA"
Begin DoDot:2
+21 DO PROCESS(DGMSG(X,1),.DGPARAM)
+22 DO NOTIFY
End DoDot:2
End DoDot:1
+23 QUIT
+24 ;
NOTIFY ; TAsk sending of response notification
+1 ;
+2 ;added p-354
if $ORDER(DGPARAM(""))=""
QUIT
+3 DO SENDIT
+4 QUIT
+5 ;
SENDIT ; Notify mail group that a response message was received from the RAI/MDS COTS system
+1 ; Input : MSGARY() - Array containing HL7 message received
+2 ; Output : None
+3 ;
+4 NEW MSGTXT,XMY,XMTEXT,XMY,XMDUZ,XMDT,XMZ,LINE,XMB,XMCHAN,XMSUB
+5 ;
+6 SET XMCHAN=1
+7 SET XMSUB="RAI/MDS Message Receipt for "_DGPARAM(1)
+8 SET (XMDUZ,XMDUZ)="RAI/MDS APPLICATION"
+9 ;
+10 MERGE XMB=DGPARAM
+11 SET XMB="DGRU REJECT"
+12 SET XMDT=DT
+13 DO ^XMB
+14 QUIT
+15 ;
PROCESS(DGMSG,DGPARAM) ;
+1 NEW ACK,MSGID
+2 ;
+3 if $GET(DGMSG)']""
QUIT
+4 ;
+5 ; Get acknowledgement code
SET ACK=$PIECE(DGMSG,"^",2)
+6 ; If the acknowledgement code is AA, then do not send notification
+7 ;changed p-354
if ACK="AA"
QUIT
+8 ;
+9 ; Get outgoing message ID
+10 SET MSGID=$PIECE(DGMSG,"^",3)
+11 ;
+12 ; Retrieve outgoing message information from file #773 for message ID
+13 DO EXTRACT(MSGID,.DGPARAM)
+14 ;
+15 ;; ===================================================================
+16 ;; The current HL7 package does not process acknowledgements other than
+17 ;; "accepted" through the process routine at the current time. This line
+18 ;; should be removed once the HL7 package is patched to process AR and AE messages.
+19 ;S:ACK="AA" DGPARAM(4)="" ;changed p-354
+20 ;; ===================================================================
+21 ;
+22 ; Retrieve rejection message from COTS acknowledgement message
+23 if '(ACK="AA")
SET DGPARAM(4)=$PIECE(DGMSG,"^",4)
+24 SET ^TMP("DGRUACK",$HOROLOG,"ACK")=DGPARAM(4)
+25 QUIT
+26 ;
+1 ; error bulletin to be sent
+2 ;
+3 NEW DGIEN,DGOIEN,DGQUIT,DGTXT,NDX
+4 ;
+5 SET DGIEN=0
+6 ; Retrieve ien of outgoing message administration entry, file #773
+7 FOR
SET DGIEN=+$ORDER(^HLMA("C",MSGID,DGIEN))
if 'DGIEN
QUIT
Begin DoDot:1
+8 ; Retrieve ien of outgoing message text
+9 SET DGOIEN=+$$GET1^DIQ(773,DGIEN,.01,"I")
+10 ;changed p-419
SET DGPARAM(7)=$$GET1^DIQ(773,DGIEN,16,"E")
+11 ;added p-354
SET DGPARAM(5)=$$GET1^DIQ(773,DGIEN,2,"I")
+12 if (DGOIEN<0)
QUIT
+13 ; Retrieve information from message file
+14 ;S DGPARAM(5)=+$$GET1^DIQ(772,DGOIEN,6) ;changed p-354
+15 SET X=$$GET1^DIQ(772,DGOIEN,200,"","DGTXT")
+16 IF $DATA(DGTXT)
Begin DoDot:2
+17 SET NDX=0
+18 FOR
SET NDX=$ORDER(DGTXT(NDX))
if 'NDX
QUIT
Begin DoDot:3
+19 IF $PIECE(DGTXT(NDX),"^")="PID"
Begin DoDot:4
+20 SET DGPARAM(1)=$$FMNAME^HLFNC($PIECE(DGTXT(NDX),"^",6),"~")
+21 SET DGPARAM(2)=$PIECE(DGTXT(NDX),"^",20)
End DoDot:4
+22 IF $PIECE(DGTXT(NDX),"^")="EVN"
Begin DoDot:4
+23 SET DGPARAM(3)=$PIECE(DGTXT(NDX),"^",2)
+24 SET DGPARAM(6)=$$FMTE^XLFDT($$FMDATE^HLFNC($PIECE(DGTXT(NDX),"^",3)))
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
if $GET(DGQUIT)
QUIT
+25 QUIT
