AGMPIACK ; IHS/SD/TPF - MPI A28/A08 ACK PROCESSOR ; 12/15/2007
;;7.2;IHS PATIENT REGISTRATION;**1,3,6**;MAY 20, 2010;Build 23
;
Q
;
PROC(HLMSGIEN) ;EP -
; 06/7/2013 - DMB - TFS8067 - Use unique variables for the HLA and HLB IENs
; 9/01/2017 - GCD - CR 9578 - Added error trap so bad messages will get removed from the queue by the calling routine.
N $ESTACK,$ETRAP S $ETRAP="D UNWIND^%ZTER"
N DATA,HLMSTATE,MSGID,MSGSEG,ICNEUID,RETCODE,NEXTSEG,SENDER,HL778IEN,HL777IEN,MCIDACK,MCIDORIG
D PARSE(.DATA,HLMSGIEN,.HLMSTATE)
N NXT,ICNEUID,LOCALID,SETICN,SEGIEN,SEGMENT,ACKIEN,SEGTYPE,PICN
S ACKIEN=HLMSGIEN
S HL778IEN=$P($G(DATA(1,3,1,1,1))," ",2) ;MSG ID OF THE MSG THIS ACK IS RESPONDING TO
I HL778IEN="" D Q
.S ERROR="NO ORIGINATING MSG ID FOUND WHERE ACKIEN='"_ACKIEN_"'"
.D MSGERR("",ACKIEN,ACKIEN,ERROR)
; 05/30/2013 - KJH - TFS8073 - Check whether the message we are ACK'ing is an "RPMS-MPI" (since there have been 'overwrite' issues in the past).
S SENDER=$P($G(^HLB(HL778IEN,1)),HLMSTATE("HDR","FIELD SEPARATOR"),3)
I SENDER'="RPMS-MPI" D Q
.S ERROR="SENDER NOT 'RPMS-MPI'"
.D MSGERR("",ACKIEN,HL778IEN,ERROR)
; 9/01/2017 - GCD - CR 9520 - Verify the message control IDs match.
S MCIDACK=$G(DATA(1,3,1,1,1)),MCIDORIG=$P($G(^HLB(HL778IEN,2)),HLMSTATE("HDR","FIELD SEPARATOR"),5)
I MCIDACK'=MCIDORIG D Q
.S ERROR="MESSAGE CONTROL ID MISMATCH: "_MCIDACK_" | "_MCIDORIG
.D MSGERR("",ACKIEN,HL778IEN,ERROR)
S HL777IEN=$P($G(^HLB(HL778IEN,0)),U,2) ;GET THE CORRECT ORIGINATING MESSAGE
I HL777IEN="" D Q
.S ERROR="NO ORIGINATING MSG BODY ID FOUND WHERE ACKIEN='"_ACKIEN_"'"
.D MSGERR("",ACKIEN,HL778IEN,ERROR)
S MSGSEG=$G(DATA(1,1,1,1,1))
; 05/29/2013 - KJH - TFS8073 - Segment 3 must be a PID. Make sure (as far as possible) that we're ACK'ing the right message.
S SEGTYPE=$E($G(^HLA(HL777IEN,1,3,0)),1,3)
I SEGTYPE'="PID" D Q
.S ERROR="PID SEGMENT NOT FOUND"
.D MSGERR("",ACKIEN,HL778IEN,ERROR)
;05/29/2013 - KJH - TFS8073 - Added $G to line below to correct an UNDEF. Moved NULL check for LOCALID from later in code.
;05/30/2013 - KJH - TFS8073 - Also added the FIELD SEPARATOR for consistency.
S LOCALID=$P($P($P($G(^HLA(HL777IEN,1,3,0)),HLMSTATE("HDR","FIELD SEPARATOR"),4),HLMSTATE("HDR","REPETITION SEPARATOR"),3),HLMSTATE("HDR","COMPONENT SEPARATOR"))
I LOCALID="" D Q
.S ERROR="LOCALID NULL FOR ACK"
.D MSGERR("",ACKIEN,HL778IEN,ERROR)
S ACKCODE=$G(DATA(1,2,1,1,1))
S IFERR=ACKCODE="CE"!(ACKCODE="CR")!(ACKCODE="AE")!(ACKCODE="AR")
I IFERR D Q
.S $P(^HLB(HL778IEN,0),U,20)=""
.S ERROR=ACKCODE_" "_$G(DATA(2,2,1,4,1))
.D MSGERR(LOCALID,ACKIEN,HL778IEN,ERROR)
S ICNEUID=$P($G(DATA(1,7,1,1,1)),"=",2)
I ICNEUID="" D Q
.S ERROR="NO ICNEUID RETURNED"
.D MSGERR(LOCALID,ACKIEN,HL778IEN,ERROR)
I '$D(^DPT(LOCALID)) D Q
.S ERROR="PATIENT RECORD DOES NOT EXIST"
.D MSGERR(LOCALID,ACKIEN,HL778IEN,ERROR)
;06/07/2013 - DMB - TFS8073 - Update ICN if it has changed
S PICN=$$GET1^DIQ(2,LOCALID_",",991.01,"E") ;INTEGRATION CONTROL NUMBER
I ICNEUID]"",ICNEUID'=PICN D ADDICN(ICNEUID,LOCALID) Q
;06/07/2013 - DMB - TFS8073 - Call MSGCMPLT if not doing ADDICN (which will do it if there is not an error)
D MSGCMPLT^AGMPIBGP(ACKIEN)
D MSGCMPLT^AGMPIBGP(HL778IEN)
Q
;
PARSE(DATA,MIEN,HLMSTATE) ;EP
N SEG,CNT
Q:'$$STARTMSG^HLOPRS(.HLMSTATE,MIEN)
M DATA("HDR")=HLMSTATE("HDR")
S CNT=0
F Q:'$$NEXTSEG^HLOPRS(.HLMSTATE,.SEG) D
.S CNT=CNT+1
.M DATA(CNT)=SEG
Q
;
ADDICN(AGICN,DFN) ;EP - ADD TO 'INTEGRATED CONTROL NUMBER' FIELD
K DIE,DIC,DA,DR,DIR
S DIE="^DPT("
S DA=DFN
S RGRSICN=1
S DR="991.01///^S X=AGICN"
D ^DIE
I $$GET1^DIQ(2,DFN_",",991.01)="" D Q
.S ERROR="FIELD 991.01 DID NOT POPULATE"
.D MSGERR(DFN,ACKIEN,HL778IEN,ERROR)
; 06/07/2013 - DMB - TFS8073 - Remove RESEND variable
D MSGCMPLT^AGMPIBGP(ACKIEN)
D MSGCMPLT^AGMPIBGP(HL778IEN)
Q
;
MSGERR(LOCALID,ACKIEN,HL778IEN,ERROR) ;EP - ERROR OCURRED IN A28 ACK
S AGERROR="MPI ERR ACK IEN "_ACKIEN_" - MSG IEN "_HL778IEN_" :: "_ERROR
D NOTIF^AGMPIHLO(LOCALID,AGERROR)
;06/7/2013 - DMB - TFS8073 - If there is an error, mark it complete so the process can move on to the next ack
D MSGCMPLT^AGMPIBGP(ACKIEN)
Q
AGMPIACK ; IHS/SD/TPF - MPI A28/A08 ACK PROCESSOR ; 12/15/2007
+1 ;;7.2;IHS PATIENT REGISTRATION;**1,3,6**;MAY 20, 2010;Build 23
+2 ;
+3 QUIT
+4 ;
PROC(HLMSGIEN) ;EP -
+1 ; 06/7/2013 - DMB - TFS8067 - Use unique variables for the HLA and HLB IENs
+2 ; 9/01/2017 - GCD - CR 9578 - Added error trap so bad messages will get removed from the queue by the calling routine.
+3 NEW $ESTACK,$ETRAP
SET $ETRAP="D UNWIND^%ZTER"
+4 NEW DATA,HLMSTATE,MSGID,MSGSEG,ICNEUID,RETCODE,NEXTSEG,SENDER,HL778IEN,HL777IEN,MCIDACK,MCIDORIG
+5 DO PARSE(.DATA,HLMSGIEN,.HLMSTATE)
+6 NEW NXT,ICNEUID,LOCALID,SETICN,SEGIEN,SEGMENT,ACKIEN,SEGTYPE,PICN
+7 SET ACKIEN=HLMSGIEN
+8 ;MSG ID OF THE MSG THIS ACK IS RESPONDING TO
SET HL778IEN=$PIECE($GET(DATA(1,3,1,1,1))," ",2)
+9 IF HL778IEN=""
Begin DoDot:1
+10 SET ERROR="NO ORIGINATING MSG ID FOUND WHERE ACKIEN='"_ACKIEN_"'"
+11 DO MSGERR("",ACKIEN,ACKIEN,ERROR)
End DoDot:1
QUIT
+12 ; 05/30/2013 - KJH - TFS8073 - Check whether the message we are ACK'ing is an "RPMS-MPI" (since there have been 'overwrite' issues in the past).
+13 SET SENDER=$PIECE($GET(^HLB(HL778IEN,1)),HLMSTATE("HDR","FIELD SEPARATOR"),3)
+14 IF SENDER'="RPMS-MPI"
Begin DoDot:1
+15 SET ERROR="SENDER NOT 'RPMS-MPI'"
+16 DO MSGERR("",ACKIEN,HL778IEN,ERROR)
End DoDot:1
QUIT
+17 ; 9/01/2017 - GCD - CR 9520 - Verify the message control IDs match.
+18 SET MCIDACK=$GET(DATA(1,3,1,1,1))
SET MCIDORIG=$PIECE($GET(^HLB(HL778IEN,2)),HLMSTATE("HDR","FIELD SEPARATOR"),5)
+19 IF MCIDACK'=MCIDORIG
Begin DoDot:1
+20 SET ERROR="MESSAGE CONTROL ID MISMATCH: "_MCIDACK_" | "_MCIDORIG
+21 DO MSGERR("",ACKIEN,HL778IEN,ERROR)
End DoDot:1
QUIT
+22 ;GET THE CORRECT ORIGINATING MESSAGE
SET HL777IEN=$PIECE($GET(^HLB(HL778IEN,0)),U,2)
+23 IF HL777IEN=""
Begin DoDot:1
+24 SET ERROR="NO ORIGINATING MSG BODY ID FOUND WHERE ACKIEN='"_ACKIEN_"'"
+25 DO MSGERR("",ACKIEN,HL778IEN,ERROR)
End DoDot:1
QUIT
+26 SET MSGSEG=$GET(DATA(1,1,1,1,1))
+27 ; 05/29/2013 - KJH - TFS8073 - Segment 3 must be a PID. Make sure (as far as possible) that we're ACK'ing the right message.
+28 SET SEGTYPE=$EXTRACT($GET(^HLA(HL777IEN,1,3,0)),1,3)
+29 IF SEGTYPE'="PID"
Begin DoDot:1
+30 SET ERROR="PID SEGMENT NOT FOUND"
+31 DO MSGERR("",ACKIEN,HL778IEN,ERROR)
End DoDot:1
QUIT
+32 ;05/29/2013 - KJH - TFS8073 - Added $G to line below to correct an UNDEF. Moved NULL check for LOCALID from later in code.
+33 ;05/30/2013 - KJH - TFS8073 - Also added the FIELD SEPARATOR for consistency.
+34 SET LOCALID=$PIECE($PIECE($PIECE($GET(^HLA(HL777IEN,1,3,0)),HLMSTATE("HDR","FIELD SEPARATOR"),4),HLMSTATE("HDR","REPETITION SEPARATOR"),3),HLMSTATE("HDR","COMPONENT SEPARATOR"))
+35 IF LOCALID=""
Begin DoDot:1
+36 SET ERROR="LOCALID NULL FOR ACK"
+37 DO MSGERR("",ACKIEN,HL778IEN,ERROR)
End DoDot:1
QUIT
+38 SET ACKCODE=$GET(DATA(1,2,1,1,1))
+39 SET IFERR=ACKCODE="CE"!(ACKCODE="CR")!(ACKCODE="AE")!(ACKCODE="AR")
+40 IF IFERR
Begin DoDot:1
+41 SET $PIECE(^HLB(HL778IEN,0),U,20)=""
+42 SET ERROR=ACKCODE_" "_$GET(DATA(2,2,1,4,1))
+43 DO MSGERR(LOCALID,ACKIEN,HL778IEN,ERROR)
End DoDot:1
QUIT
+44 SET ICNEUID=$PIECE($GET(DATA(1,7,1,1,1)),"=",2)
+45 IF ICNEUID=""
Begin DoDot:1
+46 SET ERROR="NO ICNEUID RETURNED"
+47 DO MSGERR(LOCALID,ACKIEN,HL778IEN,ERROR)
End DoDot:1
QUIT
+48 IF '$DATA(^DPT(LOCALID))
Begin DoDot:1
+49 SET ERROR="PATIENT RECORD DOES NOT EXIST"
+50 DO MSGERR(LOCALID,ACKIEN,HL778IEN,ERROR)
End DoDot:1
QUIT
+51 ;06/07/2013 - DMB - TFS8073 - Update ICN if it has changed
+52 ;INTEGRATION CONTROL NUMBER
SET PICN=$$GET1^DIQ(2,LOCALID_",",991.01,"E")
+53 IF ICNEUID]""
IF ICNEUID'=PICN
DO ADDICN(ICNEUID,LOCALID)
QUIT
+54 ;06/07/2013 - DMB - TFS8073 - Call MSGCMPLT if not doing ADDICN (which will do it if there is not an error)
+55 DO MSGCMPLT^AGMPIBGP(ACKIEN)
+56 DO MSGCMPLT^AGMPIBGP(HL778IEN)
+57 QUIT
+58 ;
PARSE(DATA,MIEN,HLMSTATE) ;EP
+1 NEW SEG,CNT
+2 IF '$$STARTMSG^HLOPRS(.HLMSTATE,MIEN)
QUIT
+3 MERGE DATA("HDR")=HLMSTATE("HDR")
+4 SET CNT=0
+5 FOR
IF '$$NEXTSEG^HLOPRS(.HLMSTATE,.SEG)
QUIT
Begin DoDot:1
+6 SET CNT=CNT+1
+7 MERGE DATA(CNT)=SEG
End DoDot:1
+8 QUIT
+9 ;
ADDICN(AGICN,DFN) ;EP - ADD TO 'INTEGRATED CONTROL NUMBER' FIELD
+1 KILL DIE,DIC,DA,DR,DIR
+2 SET DIE="^DPT("
+3 SET DA=DFN
+4 SET RGRSICN=1
+5 SET DR="991.01///^S X=AGICN"
+6 DO ^DIE
+7 IF $$GET1^DIQ(2,DFN_",",991.01)=""
Begin DoDot:1
+8 SET ERROR="FIELD 991.01 DID NOT POPULATE"
+9 DO MSGERR(DFN,ACKIEN,HL778IEN,ERROR)
End DoDot:1
QUIT
+10 ; 06/07/2013 - DMB - TFS8073 - Remove RESEND variable
+11 DO MSGCMPLT^AGMPIBGP(ACKIEN)
+12 DO MSGCMPLT^AGMPIBGP(HL778IEN)
+13 QUIT
+14 ;
MSGERR(LOCALID,ACKIEN,HL778IEN,ERROR) ;EP - ERROR OCURRED IN A28 ACK
+1 SET AGERROR="MPI ERR ACK IEN "_ACKIEN_" - MSG IEN "_HL778IEN_" :: "_ERROR
+2 DO NOTIF^AGMPIHLO(LOCALID,AGERROR)
+3 ;06/7/2013 - DMB - TFS8073 - If there is an error, mark it complete so the process can move on to the next ack
+4 DO MSGCMPLT^AGMPIBGP(ACKIEN)
+5 QUIT
