PRCHJR02 ;OI&T/KCL - IFCAP/ECMS INTERFACE PROCESS ACK FOR 2237 SEND;6/12/12
;;5.1;IFCAP;**167**;Oct 20, 2000;Build 17
;Per VHA Directive 2004-38, this routine should not be modified.
;
APPACK ;Process ACK (ORN^O08) msg
;This tag^routine is called from an entry in the HLO Application
;Registry (#779.2) file. It's responsible for receiving and
;processing application acknowledgment (ORN^O08) messages
;returned from eCMS. The application acknowledgment is being
;returned in response to a OMN^O07 message that was sent from
;IFCAP to eCMS containing a 2237 transaction.
;
; Input: At the point this tag is called, the HLO variable
; HLMSGIEN is set to the IEN of the message in HLO
; MESSAGES (#778) file.
;
N PRCDUPE ;duplicate msg error flag
N PRCER ;error returned by $$LOG^PRCHJTA
N PRCERR ;error returned by FIND1^DIC
N PRCEVNT ;input event array for $$LOG^PRCHJTA
N PRCHDR ;fields from the MSH segment, pass by ref
N PRCI ;subscript for looping thru work global
N PRCJ ;subscript for PRCEVNT("ERROR") array
N PRCIDX1 ;index for potential multiple ERR segs
N PRCIDX2 ;index for potential multiple ORC segs
N PRCIDX3 ;index for potential multiple RQD segs
N PRCMSG ;administrative information about the msg
N PRCMSGID ;msg control id (MSH-10)
N PRCTRAN ;2237 transaction #
N PRCTXT ;subscript for lines of text returned by ^DIWP
N PRCWORK ;work global ^XTMP that will contain parsed data fields
N PRC410R ;ien of record in (#410) file
;
;start parsing the ack msg
I '$$STARTMSG^HLOPRS(.PRCMSG,HLMSGIEN,.PRCHDR) Q
;
;quit if not the expected msg
I PRCMSG("BATCH") Q
I PRCMSG("MESSAGE TYPE")'="ORN" Q
I PRCMSG("EVENT")'="O08" Q
;
;get any MSH segment fields that are needed
S PRCMSGID=$G(PRCHDR("MESSAGE CONTROL ID")) ;MSH-10
;
;initialize ^XTMP work global
S PRCWORK="PRCHJRACK"_PRCMSGID
K ^XTMP(PRCWORK)
S ^XTMP(PRCWORK,0)=$$FMADD^XLFDT(DT,3)_U_DT_U_"IFCAP - Process eCMS ACK (ORN^O08) message for 2237 Send"
;
;step thru the msg segments and parse them
S (PRCIDX1,PRCIDX2,PRCIDX3)=0
F Q:'$$NEXTSEG^HLOPRS(.PRCMSG,.PRCSEG) D
. I PRCSEG("SEGMENT TYPE")="MSA" D MSA(.PRCSEG,PRCWORK)
. I PRCSEG("SEGMENT TYPE")="ERR" D ERR(.PRCSEG,PRCWORK,.PRCIDX1)
. I PRCSEG("SEGMENT TYPE")="ORC" D ORC(.PRCSEG,PRCWORK,.PRCIDX2)
. I PRCSEG("SEGMENT TYPE")="RQD" D RQD(.PRCSEG,PRCWORK,.PRCIDX3)
;
;now process the parsed data, quit if nothing in work global to process
I '$D(^XTMP(PRCWORK,"MSA")) Q
;
S PRCTRAN=$G(^XTMP(PRCWORK,"MSA","2237 TXN"))
;
;lookup record in (#410) file using 2237 transaction #
S PRC410R=$$FIND1^DIC(410,"","X",$G(PRCTRAN),"","","PRCERR")
Q:('PRC410R)!($D(PRCERR))
;
;if Application Accept DO block
I $G(^XTMP(PRCWORK,"MSA","ACK CODE"))="AA" D
. ;
. ;store ECMS ACTIONUID in (#410) file
. I '$$STOAUID(PRC410R,$G(^XTMP(PRCWORK,"MSA","ECMS ACTIONUID"))) Q
. ;
. ;store ECMS ITEMUID for each item on the 2237
. S PRCI=0
. F S PRCI=$O(^XTMP(PRCWORK,"RQD",PRCI)) Q:PRCI="" D
. . I $G(^XTMP(PRCWORK,"ORC",PRCI,"ORDER CONTROL"))="UA" Q
. . I '$$STOITID(PRC410R,$G(^XTMP(PRCWORK,"RQD",PRCI,"LINE ITEM")),$G(^XTMP(PRCWORK,"RQD",PRCI,"ECMS ITEMUID"))) Q
. ;
. ;log AA ack in IFCAP/ECMS TRANSACTION (#414.06) file
. S PRCEVNT("MSGID")=$G(PRCMSGID)
. S PRCEVNT("IEN410")=PRC410R
. D LOG^PRCHJTA($G(PRCTRAN),$G(^XTMP(PRCWORK,"MSA","ECMS ACTIONUID")),2,.PRCEVNT,.PRCER)
;
;
;if Application Reject or Error DO block
I ($G(^XTMP(PRCWORK,"MSA","ACK CODE"))="AR")!($G(^XTMP(PRCWORK,"MSA","ACK CODE"))="AE") D
. ;
. ;setup PRCEVNT array for call to LOG^PRCHJTA
. S PRCEVNT("MSGID")=$G(PRCMSGID)
. S PRCEVNT("IEN410")=PRC410R
. S (PRCI,PRCJ)=0
. ;for each error returned in ack, set parsed fields into error event array
. F S PRCI=$O(^XTMP(PRCWORK,"ERR",PRCI)) Q:PRCI="" D
. . ;check if this a duplicate msg error, set flag if it is
. . I $G(^XTMP(PRCWORK,"ERR",PRCI,"APPERR ID"))=2 S PRCDUPE=1
. . ;place error into error array
. . S PRCJ=PRCJ+3 ;leave the 1 & 2 node open for additional text for call to PHMSG^PRCHJMSG
. . S PRCEVNT("ERROR",PRCJ)="Error #: "_PRCI S PRCJ=PRCJ+1
. . S PRCEVNT("ERROR",PRCJ)="Severity: "_$G(^XTMP(PRCWORK,"ERR",PRCI,"SEVERITY")) S PRCJ=PRCJ+1
. . ;
. . ;user error msg can be a string up to 250 chars so
. . ;format into lines of 70 chars max using ^DIWP
. . N DIWF,DIWL,DIWR,X
. . S DIWL=1,DIWR=70,(DIWF,X)="" K ^UTILITY($J,"W")
. . S X="Error Message: "_$G(^XTMP(PRCWORK,"ERR",PRCI,"USER MSG"))
. . D ^DIWP
. . S PRCTXT=0
. . F S PRCTXT=$O(^UTILITY($J,"W",1,PRCTXT)) Q:PRCTXT="" D
. . . S PRCEVNT("ERROR",PRCJ)=$G(^UTILITY($J,"W",1,PRCTXT,0)) S PRCJ=PRCJ+1
. . ;
. . S PRCEVNT("ERROR",PRCJ)="Original Message Control ID: "_$G(^XTMP(PRCWORK,"MSA","CONTROL ID")) S PRCJ=PRCJ+1
. . S PRCEVNT("ERROR",PRCJ)="Segment ID: "_$G(^XTMP(PRCWORK,"ERR",PRCI,"SEG ID")) S PRCJ=PRCJ+1
. . S PRCEVNT("ERROR",PRCJ)="Segment Sequence: "_$G(^XTMP(PRCWORK,"ERR",PRCI,"SEG SEQ")) S PRCJ=PRCJ+1
. . S PRCEVNT("ERROR",PRCJ)="Field Position: "_$G(^XTMP(PRCWORK,"ERR",PRCI,"FIELD POS")) S PRCJ=PRCJ+1
. . S PRCEVNT("ERROR",PRCJ)="Field Component: "_$G(^XTMP(PRCWORK,"ERR",PRCI,"COMP")) S PRCJ=PRCJ+1
. . S PRCEVNT("ERROR",PRCJ)="Field Sub-Component: "_$G(^XTMP(PRCWORK,"ERR",PRCI,"SUBCOMP")) S PRCJ=PRCJ+1
. . S PRCEVNT("ERROR",PRCJ)="Field Repetition: "_$G(^XTMP(PRCWORK,"ERR",PRCI,"FIELD REP")) S PRCJ=PRCJ+1
. . S PRCEVNT("ERROR",PRCJ)="HL7 Error Code: "_$G(^XTMP(PRCWORK,"ERR",PRCI,"ERRCODE ID")) S PRCJ=PRCJ+1
. . S PRCEVNT("ERROR",PRCJ)="HL7 Error Text: "_$G(^XTMP(PRCWORK,"ERR",PRCI,"ERRCODE TXT")) S PRCJ=PRCJ+1
. . S PRCEVNT("ERROR",PRCJ)="Coding System: "_$G(^XTMP(PRCWORK,"ERR",PRCI,"ERRCODE SYS")) S PRCJ=PRCJ+1
. . S PRCEVNT("ERROR",PRCJ)="Application Error Code: "_$G(^XTMP(PRCWORK,"ERR",PRCI,"APPERR ID")) S PRCJ=PRCJ+1
. . S PRCEVNT("ERROR",PRCJ)="Application Error Text: "_$G(^XTMP(PRCWORK,"ERR",PRCI,"APPERR TXT"))
. ;
. ;log error(s) contained in PRCEVNT array into IFCAP/ECMS TRANSACTION (#414.06) file
. D LOG^PRCHJTA($G(PRCTRAN),,2,.PRCEVNT,.PRCER)
. ;
. ;send mailman error notification msg to Accountable Officer
. N PRCMSG1,PRCMSG2 ;input array 1 & 2 for PHMSG^PRCHJMSG, pass by ref
. S PRCMSG1(1)=$G(PRCTRAN)
. S PRCMSG1(2)=1 ;ack reject
. S PRCMSG1(3)=$G(PRCHDR("DT/TM OF MESSAGE")) ;MSH-7
. S PRCMSG1(7)="Please forward this message to appropriate OIT staff!"
. ;if not a duplicate msg error, set 1 node of error PRCEVNT array, if dupe status won't be reset
. I '$G(PRCDUPE) S PRCEVNT("ERROR",1)="Status of request is being reset to 'Pending Accountable Officer Sig.'"
. S PRCEVNT("ERROR",2)=""
. M PRCMSG2=PRCEVNT("ERROR") ;merge error array into PRCMSG2 array
. D PHMSG^PRCHJMSG(.PRCMSG1,.PRCMSG2) ;send msg
. ;
. ;if not a duplicate msg error, return 2237 to Accountable Officer and remove signatures
. I '$G(PRCDUPE) D
. . I '$$UPD443^PRCHJUTL(PRC410R,.PRCER) Q
. . I '$$UPD410^PRCHJUTL(PRC410R,.PRCER) Q
. ;
. ;reset original msg purge date/time to 1 month in future for trouble-shooting
. I '$$SETPURGE^HLOAPI3($G(PRCMSG("ACK TO IEN")),$$FMADD^XLFDT($$NOW^XLFDT,30)) Q
;
Q
;
;
MSA(PRCSEG,PRCWRK) ;Parse MSA segment
;This procedure is used to retrieve the data elements from the
;MSA segment and place them into the ^XTMP work global.
;
; Input:
; PRCSEG - (required) Contains all the individual values parsed from the segment
; PRCWRK - (required) Namespace of ^XTMP work global
;
; Output: None
;
N PRCTMP ;temp var
;
S ^XTMP(PRCWRK,"MSA","ACK CODE")=$$GET^HLOPRS(.PRCSEG,1) ;AA, AE, OR AR
S ^XTMP(PRCWRK,"MSA","CONTROL ID")=$$GET^HLOPRS(.PRCSEG,2) ;control ID of original msg
S PRCTMP=$$GET^HLOPRS(.PRCSEG,3) ;2237 number and eCMS ActionUID number separated by *
S ^XTMP(PRCWRK,"MSA","2237 TXN")=$P($G(PRCTMP),"*")
S ^XTMP(PRCWRK,"MSA","ECMS ACTIONUID")=$P($G(PRCTMP),"*",2)
Q
;
;
ERR(PRCSEG,PRCWRK,PRCIDX) ;Parse ERR segment
;This procedure is used to retrieve the data elementsc from the
;ERR segment and place them into the ^XTMP work global.
;
; Input:
; PRCSEG - (required) Contains all the individual values parsed from the segment
; PRCWRK - (required) Namespace of ^XTMP work global
; PRCIDX - (required) Index for multiple ERR segments, passed by ref
;
; Output: None
;
N PRCTMP ;temp var for any data conversion
;
S PRCIDX=$G(PRCIDX)+1 ;increment index
S PRCTMP=$$GET^HLOPRS(.PRCSEG,2,1)
S ^XTMP(PRCWRK,"ERR",PRCIDX,"SEG ID")=$S(PRCTMP'="":PRCTMP,1:"n/a") ;field is not required
S PRCTMP=$$GET^HLOPRS(.PRCSEG,2,2)
S ^XTMP(PRCWRK,"ERR",PRCIDX,"SEG SEQ")=$S(PRCTMP'="":PRCTMP,1:"n/a") ;field is not required
S PRCTMP=$$GET^HLOPRS(.PRCSEG,2,3)
S ^XTMP(PRCWRK,"ERR",PRCIDX,"FIELD POS")=$S(PRCTMP'="":PRCTMP,1:"n/a") ;field is not required
S PRCTMP=$$GET^HLOPRS(.PRCSEG,2,4)
S ^XTMP(PRCWRK,"ERR",PRCIDX,"FIELD REP")=$S(PRCTMP'="":PRCTMP,1:"n/a") ;field is not required
S PRCTMP=$$GET^HLOPRS(.PRCSEG,2,5)
S ^XTMP(PRCWRK,"ERR",PRCIDX,"COMP")=$S(PRCTMP'="":PRCTMP,1:"n/a") ;field is not required
S PRCTMP=$$GET^HLOPRS(.PRCSEG,2,6)
S ^XTMP(PRCWRK,"ERR",PRCIDX,"SUBCOMP")=$S(PRCTMP'="":PRCTMP,1:"n/a") ;field is not required
S ^XTMP(PRCWRK,"ERR",PRCIDX,"ERRCODE ID")=$$GET^HLOPRS(.PRCSEG,3,1)
S ^XTMP(PRCWRK,"ERR",PRCIDX,"ERRCODE TXT")=$$GET^HLOPRS(.PRCSEG,3,2)
S ^XTMP(PRCWRK,"ERR",PRCIDX,"ERRCODE SYS")=$$GET^HLOPRS(.PRCSEG,3,3)
S PRCTMP=$$GET^HLOPRS(.PRCSEG,4) ;convert severity code to text
S ^XTMP(PRCWRK,"ERR",PRCIDX,"SEVERITY")=$S(PRCTMP="E":"Error",PRCTMP="I":"Information",PRCTMP="W":"Warning",1:"Unknown")
S ^XTMP(PRCWRK,"ERR",PRCIDX,"APPERR ID")=$$GET^HLOPRS(.PRCSEG,5,1)
S ^XTMP(PRCWRK,"ERR",PRCIDX,"APPERR TXT")=$$GET^HLOPRS(.PRCSEG,5,2)
S ^XTMP(PRCWRK,"ERR",PRCIDX,"USER MSG")=$$GET^HLOPRS(.PRCSEG,8)
Q
;
;
ORC(PRCSEG,PRCWRK,PRCIDX) ;Parse ORC segment
;This procedure is used to retrieve the data elements from the
;ORC segment and place them into the ^XTMP work global.
;
; Input:
; PRCSEG - (required) Contains all the individual values parsed from the segment
; PRCWRK - (required) Namespace of ^XTMP work global
; PRCIDX - (required) Index for multiple ERR segments, passed by ref
;
; Output: None
;
S PRCIDX=$G(PRCIDX)+1 ;increment index
S ^XTMP(PRCWRK,"ORC",PRCIDX,"ORDER CONTROL")=$$GET^HLOPRS(.PRCSEG,1) ;OK if 2237 is accepted, UA if not
S ^XTMP(PRCWRK,"ORC",PRCIDX,"2237 TXN")=$$GET^HLOPRS(.PRCSEG,2,1)
S ^XTMP(PRCWRK,"ORC",PRCIDX,"ECMS ACTIONUID")=$$GET^HLOPRS(.PRCSEG,3,1)
Q
;
;
RQD(PRCSEG,PRCWRK,PRCIDX) ;Parse RQD segment
;This procedure is used to retrieve the data elements from the
;RQD segment and place them into the ^XTMP work global.
;
; Input:
; PRCSEG - (required) Contains all the individual values parsed from the segment
; PRCWRK - (required) Namespace of ^XTMP work global
; PRCIDX - (required) Index for multiple ERR segments, passed by ref
;
; Output: None
;
S PRCIDX=$G(PRCIDX)+1 ;increment index
S ^XTMP(PRCWRK,"RQD",PRCIDX,"LINE ITEM")=$$GET^HLOPRS(.PRCSEG,1)
S ^XTMP(PRCWRK,"RQD",PRCIDX,"ECMS ITEMUID")=$$GET^HLOPRS(.PRCSEG,2,1)
Q
;
;
STOAUID(PRC410R,PRCAUID,PRCERR) ;Store eCMS ActionUID
;This function is used to store the following field into
;a record in the CONTROL POINT ACTIVITY (#410) file:
;
; Field Name Field #
; -------------- -------
; ECMS ACTIONUID 103
;
; Input:
; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
; PRCAUID - (required) ECMS ACTIONUID field value to be filed
;
; Output:
; Function Value - returns 1 on success, 0 on failure
; PRCERR - (optional) on failure, an error message is returned,
; pass by ref
;
N PRCRSLT ;function result
N PRCIENS ;iens string for FM data array
N PRCFDA ;FM data array
;
S PRC410R=+$G(PRC410R)
S PRCAUID=$G(PRCAUID)
S PRCRSLT=0
S PRCERR="ECMS ACTIONUID not filed: Invalid input parameters"
;
I PRC410R>0,($D(^PRCS(410,PRC410R))),(PRCAUID]"") D
. K PRCERR
. S PRCIENS=PRC410R_","
. S PRCFDA(410,PRCIENS,103)=PRCAUID
. D FILE^DIE("K","PRCFDA","PRCERR")
. ;
. ;quit on filer error
. I $D(PRCERR) S PRCERR="ECMS ACTIONUID not filed: "_$G(PRCERR("DIERR","1","TEXT",1)) Q
. ;
. ;success
. S PRCRSLT=1
;
Q PRCRSLT
;
;
STOITID(PRC410R,PRCIT,PRCITID,PRCERR) ;Store eCMS ItemUID
;This function is used to store the following field into
;a record in the ITEM (#410.02) multiple of the CONTROL
;POINT ACTIVITY (#410) file:
;
; Field Name Field #
; -------------- -------
; ECMS ITEMUID 100
;
; Input:
; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
; PRCIT - (required) Line Item Number
; PRCTID - (required) ECMS ITEMUID field value to be filed
;
; Output:
; Function Value - returns 1 on success, 0 on failure
; PRCERR - (optional) on failure, an error message is returned,
; pass by ref
;
N PRCRSLT ;function result
N PRCIENS ;iens string for FM data array
N PRCFDA ;FM data array
;
S PRC410R=+$G(PRC410R)
S PRCIT=+$G(PRCIT)
S PRCITID=$G(PRCITID)
S PRCRSLT=0
S PRCERR="ECMS ITEMUID not filed: Invalid input parameters"
;
I PRC410R>0,$D(^PRCS(410,PRC410R)),PRCIT>0,PRCITID]"" D
. ;resolve Line Item Number to Item entry's ien and setup iens string for FM data array
. S PRCIENS=$O(^PRCS(410,PRC410R,"IT","B",PRCIT,0))_","_PRC410R_","
. S PRCFDA(410.02,PRCIENS,100)=PRCITID
. K PRCERR
. D FILE^DIE("K","PRCFDA","PRCERR")
. ;
. ;quit on filer error
. I $D(PRCERR) S PRCERR="ECMS ITEMUID not filed: "_$G(PRCERR("DIERR","1","TEXT",1)) Q
. ;
. ;success
. S PRCRSLT=1
;
Q PRCRSLT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHJR02 13885 printed Nov 22, 2024@17:18:16 Page 2
PRCHJR02 ;OI&T/KCL - IFCAP/ECMS INTERFACE PROCESS ACK FOR 2237 SEND;6/12/12
+1 ;;5.1;IFCAP;**167**;Oct 20, 2000;Build 17
+2 ;Per VHA Directive 2004-38, this routine should not be modified.
+3 ;
APPACK ;Process ACK (ORN^O08) msg
+1 ;This tag^routine is called from an entry in the HLO Application
+2 ;Registry (#779.2) file. It's responsible for receiving and
+3 ;processing application acknowledgment (ORN^O08) messages
+4 ;returned from eCMS. The application acknowledgment is being
+5 ;returned in response to a OMN^O07 message that was sent from
+6 ;IFCAP to eCMS containing a 2237 transaction.
+7 ;
+8 ; Input: At the point this tag is called, the HLO variable
+9 ; HLMSGIEN is set to the IEN of the message in HLO
+10 ; MESSAGES (#778) file.
+11 ;
+12 ;duplicate msg error flag
NEW PRCDUPE
+13 ;error returned by $$LOG^PRCHJTA
NEW PRCER
+14 ;error returned by FIND1^DIC
NEW PRCERR
+15 ;input event array for $$LOG^PRCHJTA
NEW PRCEVNT
+16 ;fields from the MSH segment, pass by ref
NEW PRCHDR
+17 ;subscript for looping thru work global
NEW PRCI
+18 ;subscript for PRCEVNT("ERROR") array
NEW PRCJ
+19 ;index for potential multiple ERR segs
NEW PRCIDX1
+20 ;index for potential multiple ORC segs
NEW PRCIDX2
+21 ;index for potential multiple RQD segs
NEW PRCIDX3
+22 ;administrative information about the msg
NEW PRCMSG
+23 ;msg control id (MSH-10)
NEW PRCMSGID
+24 ;2237 transaction #
NEW PRCTRAN
+25 ;subscript for lines of text returned by ^DIWP
NEW PRCTXT
+26 ;work global ^XTMP that will contain parsed data fields
NEW PRCWORK
+27 ;ien of record in (#410) file
NEW PRC410R
+28 ;
+29 ;start parsing the ack msg
+30 IF '$$STARTMSG^HLOPRS(.PRCMSG,HLMSGIEN,.PRCHDR)
QUIT
+31 ;
+32 ;quit if not the expected msg
+33 IF PRCMSG("BATCH")
QUIT
+34 IF PRCMSG("MESSAGE TYPE")'="ORN"
QUIT
+35 IF PRCMSG("EVENT")'="O08"
QUIT
+36 ;
+37 ;get any MSH segment fields that are needed
+38 ;MSH-10
SET PRCMSGID=$GET(PRCHDR("MESSAGE CONTROL ID"))
+39 ;
+40 ;initialize ^XTMP work global
+41 SET PRCWORK="PRCHJRACK"_PRCMSGID
+42 KILL ^XTMP(PRCWORK)
+43 SET ^XTMP(PRCWORK,0)=$$FMADD^XLFDT(DT,3)_U_DT_U_"IFCAP - Process eCMS ACK (ORN^O08) message for 2237 Send"
+44 ;
+45 ;step thru the msg segments and parse them
+46 SET (PRCIDX1,PRCIDX2,PRCIDX3)=0
+47 FOR
if '$$NEXTSEG^HLOPRS(.PRCMSG,.PRCSEG)
QUIT
Begin DoDot:1
+48 IF PRCSEG("SEGMENT TYPE")="MSA"
DO MSA(.PRCSEG,PRCWORK)
+49 IF PRCSEG("SEGMENT TYPE")="ERR"
DO ERR(.PRCSEG,PRCWORK,.PRCIDX1)
+50 IF PRCSEG("SEGMENT TYPE")="ORC"
DO ORC(.PRCSEG,PRCWORK,.PRCIDX2)
+51 IF PRCSEG("SEGMENT TYPE")="RQD"
DO RQD(.PRCSEG,PRCWORK,.PRCIDX3)
End DoDot:1
+52 ;
+53 ;now process the parsed data, quit if nothing in work global to process
+54 IF '$DATA(^XTMP(PRCWORK,"MSA"))
QUIT
+55 ;
+56 SET PRCTRAN=$GET(^XTMP(PRCWORK,"MSA","2237 TXN"))
+57 ;
+58 ;lookup record in (#410) file using 2237 transaction #
+59 SET PRC410R=$$FIND1^DIC(410,"","X",$GET(PRCTRAN),"","","PRCERR")
+60 if ('PRC410R)!($DATA(PRCERR))
QUIT
+61 ;
+62 ;if Application Accept DO block
+63 IF $GET(^XTMP(PRCWORK,"MSA","ACK CODE"))="AA"
Begin DoDot:1
+64 ;
+65 ;store ECMS ACTIONUID in (#410) file
+66 IF '$$STOAUID(PRC410R,$GET(^XTMP(PRCWORK,"MSA","ECMS ACTIONUID")))
QUIT
+67 ;
+68 ;store ECMS ITEMUID for each item on the 2237
+69 SET PRCI=0
+70 FOR
SET PRCI=$ORDER(^XTMP(PRCWORK,"RQD",PRCI))
if PRCI=""
QUIT
Begin DoDot:2
+71 IF $GET(^XTMP(PRCWORK,"ORC",PRCI,"ORDER CONTROL"))="UA"
QUIT
+72 IF '$$STOITID(PRC410R,$GET(^XTMP(PRCWORK,"RQD",PRCI,"LINE ITEM")),$GET(^XTMP(PRCWORK,"RQD",PRCI,"ECMS ITEMUID")))
QUIT
End DoDot:2
+73 ;
+74 ;log AA ack in IFCAP/ECMS TRANSACTION (#414.06) file
+75 SET PRCEVNT("MSGID")=$GET(PRCMSGID)
+76 SET PRCEVNT("IEN410")=PRC410R
+77 DO LOG^PRCHJTA($GET(PRCTRAN),$GET(^XTMP(PRCWORK,"MSA","ECMS ACTIONUID")),2,.PRCEVNT,.PRCER)
End DoDot:1
+78 ;
+79 ;
+80 ;if Application Reject or Error DO block
+81 IF ($GET(^XTMP(PRCWORK,"MSA","ACK CODE"))="AR")!($GET(^XTMP(PRCWORK,"MSA","ACK CODE"))="AE")
Begin DoDot:1
+82 ;
+83 ;setup PRCEVNT array for call to LOG^PRCHJTA
+84 SET PRCEVNT("MSGID")=$GET(PRCMSGID)
+85 SET PRCEVNT("IEN410")=PRC410R
+86 SET (PRCI,PRCJ)=0
+87 ;for each error returned in ack, set parsed fields into error event array
+88 FOR
SET PRCI=$ORDER(^XTMP(PRCWORK,"ERR",PRCI))
if PRCI=""
QUIT
Begin DoDot:2
+89 ;check if this a duplicate msg error, set flag if it is
+90 IF $GET(^XTMP(PRCWORK,"ERR",PRCI,"APPERR ID"))=2
SET PRCDUPE=1
+91 ;place error into error array
+92 ;leave the 1 & 2 node open for additional text for call to PHMSG^PRCHJMSG
SET PRCJ=PRCJ+3
+93 SET PRCEVNT("ERROR",PRCJ)="Error #: "_PRCI
SET PRCJ=PRCJ+1
+94 SET PRCEVNT("ERROR",PRCJ)="Severity: "_$GET(^XTMP(PRCWORK,"ERR",PRCI,"SEVERITY"))
SET PRCJ=PRCJ+1
+95 ;
+96 ;user error msg can be a string up to 250 chars so
+97 ;format into lines of 70 chars max using ^DIWP
+98 NEW DIWF,DIWL,DIWR,X
+99 SET DIWL=1
SET DIWR=70
SET (DIWF,X)=""
KILL ^UTILITY($JOB,"W")
+100 SET X="Error Message: "_$GET(^XTMP(PRCWORK,"ERR",PRCI,"USER MSG"))
+101 DO ^DIWP
+102 SET PRCTXT=0
+103 FOR
SET PRCTXT=$ORDER(^UTILITY($JOB,"W",1,PRCTXT))
if PRCTXT=""
QUIT
Begin DoDot:3
+104 SET PRCEVNT("ERROR",PRCJ)=$GET(^UTILITY($JOB,"W",1,PRCTXT,0))
SET PRCJ=PRCJ+1
End DoDot:3
+105 ;
+106 SET PRCEVNT("ERROR",PRCJ)="Original Message Control ID: "_$GET(^XTMP(PRCWORK,"MSA","CONTROL ID"))
SET PRCJ=PRCJ+1
+107 SET PRCEVNT("ERROR",PRCJ)="Segment ID: "_$GET(^XTMP(PRCWORK,"ERR",PRCI,"SEG ID"))
SET PRCJ=PRCJ+1
+108 SET PRCEVNT("ERROR",PRCJ)="Segment Sequence: "_$GET(^XTMP(PRCWORK,"ERR",PRCI,"SEG SEQ"))
SET PRCJ=PRCJ+1
+109 SET PRCEVNT("ERROR",PRCJ)="Field Position: "_$GET(^XTMP(PRCWORK,"ERR",PRCI,"FIELD POS"))
SET PRCJ=PRCJ+1
+110 SET PRCEVNT("ERROR",PRCJ)="Field Component: "_$GET(^XTMP(PRCWORK,"ERR",PRCI,"COMP"))
SET PRCJ=PRCJ+1
+111 SET PRCEVNT("ERROR",PRCJ)="Field Sub-Component: "_$GET(^XTMP(PRCWORK,"ERR",PRCI,"SUBCOMP"))
SET PRCJ=PRCJ+1
+112 SET PRCEVNT("ERROR",PRCJ)="Field Repetition: "_$GET(^XTMP(PRCWORK,"ERR",PRCI,"FIELD REP"))
SET PRCJ=PRCJ+1
+113 SET PRCEVNT("ERROR",PRCJ)="HL7 Error Code: "_$GET(^XTMP(PRCWORK,"ERR",PRCI,"ERRCODE ID"))
SET PRCJ=PRCJ+1
+114 SET PRCEVNT("ERROR",PRCJ)="HL7 Error Text: "_$GET(^XTMP(PRCWORK,"ERR",PRCI,"ERRCODE TXT"))
SET PRCJ=PRCJ+1
+115 SET PRCEVNT("ERROR",PRCJ)="Coding System: "_$GET(^XTMP(PRCWORK,"ERR",PRCI,"ERRCODE SYS"))
SET PRCJ=PRCJ+1
+116 SET PRCEVNT("ERROR",PRCJ)="Application Error Code: "_$GET(^XTMP(PRCWORK,"ERR",PRCI,"APPERR ID"))
SET PRCJ=PRCJ+1
+117 SET PRCEVNT("ERROR",PRCJ)="Application Error Text: "_$GET(^XTMP(PRCWORK,"ERR",PRCI,"APPERR TXT"))
End DoDot:2
+118 ;
+119 ;log error(s) contained in PRCEVNT array into IFCAP/ECMS TRANSACTION (#414.06) file
+120 DO LOG^PRCHJTA($GET(PRCTRAN),,2,.PRCEVNT,.PRCER)
+121 ;
+122 ;send mailman error notification msg to Accountable Officer
+123 ;input array 1 & 2 for PHMSG^PRCHJMSG, pass by ref
NEW PRCMSG1,PRCMSG2
+124 SET PRCMSG1(1)=$GET(PRCTRAN)
+125 ;ack reject
SET PRCMSG1(2)=1
+126 ;MSH-7
SET PRCMSG1(3)=$GET(PRCHDR("DT/TM OF MESSAGE"))
+127 SET PRCMSG1(7)="Please forward this message to appropriate OIT staff!"
+128 ;if not a duplicate msg error, set 1 node of error PRCEVNT array, if dupe status won't be reset
+129 IF '$GET(PRCDUPE)
SET PRCEVNT("ERROR",1)="Status of request is being reset to 'Pending Accountable Officer Sig.'"
+130 SET PRCEVNT("ERROR",2)=""
+131 ;merge error array into PRCMSG2 array
MERGE PRCMSG2=PRCEVNT("ERROR")
+132 ;send msg
DO PHMSG^PRCHJMSG(.PRCMSG1,.PRCMSG2)
+133 ;
+134 ;if not a duplicate msg error, return 2237 to Accountable Officer and remove signatures
+135 IF '$GET(PRCDUPE)
Begin DoDot:2
+136 IF '$$UPD443^PRCHJUTL(PRC410R,.PRCER)
QUIT
+137 IF '$$UPD410^PRCHJUTL(PRC410R,.PRCER)
QUIT
End DoDot:2
+138 ;
+139 ;reset original msg purge date/time to 1 month in future for trouble-shooting
+140 IF '$$SETPURGE^HLOAPI3($GET(PRCMSG("ACK TO IEN")),$$FMADD^XLFDT($$NOW^XLFDT,30))
QUIT
End DoDot:1
+141 ;
+142 QUIT
+143 ;
+144 ;
MSA(PRCSEG,PRCWRK) ;Parse MSA segment
+1 ;This procedure is used to retrieve the data elements from the
+2 ;MSA segment and place them into the ^XTMP work global.
+3 ;
+4 ; Input:
+5 ; PRCSEG - (required) Contains all the individual values parsed from the segment
+6 ; PRCWRK - (required) Namespace of ^XTMP work global
+7 ;
+8 ; Output: None
+9 ;
+10 ;temp var
NEW PRCTMP
+11 ;
+12 ;AA, AE, OR AR
SET ^XTMP(PRCWRK,"MSA","ACK CODE")=$$GET^HLOPRS(.PRCSEG,1)
+13 ;control ID of original msg
SET ^XTMP(PRCWRK,"MSA","CONTROL ID")=$$GET^HLOPRS(.PRCSEG,2)
+14 ;2237 number and eCMS ActionUID number separated by *
SET PRCTMP=$$GET^HLOPRS(.PRCSEG,3)
+15 SET ^XTMP(PRCWRK,"MSA","2237 TXN")=$PIECE($GET(PRCTMP),"*")
+16 SET ^XTMP(PRCWRK,"MSA","ECMS ACTIONUID")=$PIECE($GET(PRCTMP),"*",2)
+17 QUIT
+18 ;
+19 ;
ERR(PRCSEG,PRCWRK,PRCIDX) ;Parse ERR segment
+1 ;This procedure is used to retrieve the data elementsc from the
+2 ;ERR segment and place them into the ^XTMP work global.
+3 ;
+4 ; Input:
+5 ; PRCSEG - (required) Contains all the individual values parsed from the segment
+6 ; PRCWRK - (required) Namespace of ^XTMP work global
+7 ; PRCIDX - (required) Index for multiple ERR segments, passed by ref
+8 ;
+9 ; Output: None
+10 ;
+11 ;temp var for any data conversion
NEW PRCTMP
+12 ;
+13 ;increment index
SET PRCIDX=$GET(PRCIDX)+1
+14 SET PRCTMP=$$GET^HLOPRS(.PRCSEG,2,1)
+15 ;field is not required
SET ^XTMP(PRCWRK,"ERR",PRCIDX,"SEG ID")=$SELECT(PRCTMP'="":PRCTMP,1:"n/a")
+16 SET PRCTMP=$$GET^HLOPRS(.PRCSEG,2,2)
+17 ;field is not required
SET ^XTMP(PRCWRK,"ERR",PRCIDX,"SEG SEQ")=$SELECT(PRCTMP'="":PRCTMP,1:"n/a")
+18 SET PRCTMP=$$GET^HLOPRS(.PRCSEG,2,3)
+19 ;field is not required
SET ^XTMP(PRCWRK,"ERR",PRCIDX,"FIELD POS")=$SELECT(PRCTMP'="":PRCTMP,1:"n/a")
+20 SET PRCTMP=$$GET^HLOPRS(.PRCSEG,2,4)
+21 ;field is not required
SET ^XTMP(PRCWRK,"ERR",PRCIDX,"FIELD REP")=$SELECT(PRCTMP'="":PRCTMP,1:"n/a")
+22 SET PRCTMP=$$GET^HLOPRS(.PRCSEG,2,5)
+23 ;field is not required
SET ^XTMP(PRCWRK,"ERR",PRCIDX,"COMP")=$SELECT(PRCTMP'="":PRCTMP,1:"n/a")
+24 SET PRCTMP=$$GET^HLOPRS(.PRCSEG,2,6)
+25 ;field is not required
SET ^XTMP(PRCWRK,"ERR",PRCIDX,"SUBCOMP")=$SELECT(PRCTMP'="":PRCTMP,1:"n/a")
+26 SET ^XTMP(PRCWRK,"ERR",PRCIDX,"ERRCODE ID")=$$GET^HLOPRS(.PRCSEG,3,1)
+27 SET ^XTMP(PRCWRK,"ERR",PRCIDX,"ERRCODE TXT")=$$GET^HLOPRS(.PRCSEG,3,2)
+28 SET ^XTMP(PRCWRK,"ERR",PRCIDX,"ERRCODE SYS")=$$GET^HLOPRS(.PRCSEG,3,3)
+29 ;convert severity code to text
SET PRCTMP=$$GET^HLOPRS(.PRCSEG,4)
+30 SET ^XTMP(PRCWRK,"ERR",PRCIDX,"SEVERITY")=$SELECT(PRCTMP="E":"Error",PRCTMP="I":"Information",PRCTMP="W":"Warning",1:"Unknown")
+31 SET ^XTMP(PRCWRK,"ERR",PRCIDX,"APPERR ID")=$$GET^HLOPRS(.PRCSEG,5,1)
+32 SET ^XTMP(PRCWRK,"ERR",PRCIDX,"APPERR TXT")=$$GET^HLOPRS(.PRCSEG,5,2)
+33 SET ^XTMP(PRCWRK,"ERR",PRCIDX,"USER MSG")=$$GET^HLOPRS(.PRCSEG,8)
+34 QUIT
+35 ;
+36 ;
ORC(PRCSEG,PRCWRK,PRCIDX) ;Parse ORC segment
+1 ;This procedure is used to retrieve the data elements from the
+2 ;ORC segment and place them into the ^XTMP work global.
+3 ;
+4 ; Input:
+5 ; PRCSEG - (required) Contains all the individual values parsed from the segment
+6 ; PRCWRK - (required) Namespace of ^XTMP work global
+7 ; PRCIDX - (required) Index for multiple ERR segments, passed by ref
+8 ;
+9 ; Output: None
+10 ;
+11 ;increment index
SET PRCIDX=$GET(PRCIDX)+1
+12 ;OK if 2237 is accepted, UA if not
SET ^XTMP(PRCWRK,"ORC",PRCIDX,"ORDER CONTROL")=$$GET^HLOPRS(.PRCSEG,1)
+13 SET ^XTMP(PRCWRK,"ORC",PRCIDX,"2237 TXN")=$$GET^HLOPRS(.PRCSEG,2,1)
+14 SET ^XTMP(PRCWRK,"ORC",PRCIDX,"ECMS ACTIONUID")=$$GET^HLOPRS(.PRCSEG,3,1)
+15 QUIT
+16 ;
+17 ;
RQD(PRCSEG,PRCWRK,PRCIDX) ;Parse RQD segment
+1 ;This procedure is used to retrieve the data elements from the
+2 ;RQD segment and place them into the ^XTMP work global.
+3 ;
+4 ; Input:
+5 ; PRCSEG - (required) Contains all the individual values parsed from the segment
+6 ; PRCWRK - (required) Namespace of ^XTMP work global
+7 ; PRCIDX - (required) Index for multiple ERR segments, passed by ref
+8 ;
+9 ; Output: None
+10 ;
+11 ;increment index
SET PRCIDX=$GET(PRCIDX)+1
+12 SET ^XTMP(PRCWRK,"RQD",PRCIDX,"LINE ITEM")=$$GET^HLOPRS(.PRCSEG,1)
+13 SET ^XTMP(PRCWRK,"RQD",PRCIDX,"ECMS ITEMUID")=$$GET^HLOPRS(.PRCSEG,2,1)
+14 QUIT
+15 ;
+16 ;
STOAUID(PRC410R,PRCAUID,PRCERR) ;Store eCMS ActionUID
+1 ;This function is used to store the following field into
+2 ;a record in the CONTROL POINT ACTIVITY (#410) file:
+3 ;
+4 ; Field Name Field #
+5 ; -------------- -------
+6 ; ECMS ACTIONUID 103
+7 ;
+8 ; Input:
+9 ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
+10 ; PRCAUID - (required) ECMS ACTIONUID field value to be filed
+11 ;
+12 ; Output:
+13 ; Function Value - returns 1 on success, 0 on failure
+14 ; PRCERR - (optional) on failure, an error message is returned,
+15 ; pass by ref
+16 ;
+17 ;function result
NEW PRCRSLT
+18 ;iens string for FM data array
NEW PRCIENS
+19 ;FM data array
NEW PRCFDA
+20 ;
+21 SET PRC410R=+$GET(PRC410R)
+22 SET PRCAUID=$GET(PRCAUID)
+23 SET PRCRSLT=0
+24 SET PRCERR="ECMS ACTIONUID not filed: Invalid input parameters"
+25 ;
+26 IF PRC410R>0
IF ($DATA(^PRCS(410,PRC410R)))
IF (PRCAUID]"")
Begin DoDot:1
+27 KILL PRCERR
+28 SET PRCIENS=PRC410R_","
+29 SET PRCFDA(410,PRCIENS,103)=PRCAUID
+30 DO FILE^DIE("K","PRCFDA","PRCERR")
+31 ;
+32 ;quit on filer error
+33 IF $DATA(PRCERR)
SET PRCERR="ECMS ACTIONUID not filed: "_$GET(PRCERR("DIERR","1","TEXT",1))
QUIT
+34 ;
+35 ;success
+36 SET PRCRSLT=1
End DoDot:1
+37 ;
+38 QUIT PRCRSLT
+39 ;
+40 ;
STOITID(PRC410R,PRCIT,PRCITID,PRCERR) ;Store eCMS ItemUID
+1 ;This function is used to store the following field into
+2 ;a record in the ITEM (#410.02) multiple of the CONTROL
+3 ;POINT ACTIVITY (#410) file:
+4 ;
+5 ; Field Name Field #
+6 ; -------------- -------
+7 ; ECMS ITEMUID 100
+8 ;
+9 ; Input:
+10 ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
+11 ; PRCIT - (required) Line Item Number
+12 ; PRCTID - (required) ECMS ITEMUID field value to be filed
+13 ;
+14 ; Output:
+15 ; Function Value - returns 1 on success, 0 on failure
+16 ; PRCERR - (optional) on failure, an error message is returned,
+17 ; pass by ref
+18 ;
+19 ;function result
NEW PRCRSLT
+20 ;iens string for FM data array
NEW PRCIENS
+21 ;FM data array
NEW PRCFDA
+22 ;
+23 SET PRC410R=+$GET(PRC410R)
+24 SET PRCIT=+$GET(PRCIT)
+25 SET PRCITID=$GET(PRCITID)
+26 SET PRCRSLT=0
+27 SET PRCERR="ECMS ITEMUID not filed: Invalid input parameters"
+28 ;
+29 IF PRC410R>0
IF $DATA(^PRCS(410,PRC410R))
IF PRCIT>0
IF PRCITID]""
Begin DoDot:1
+30 ;resolve Line Item Number to Item entry's ien and setup iens string for FM data array
+31 SET PRCIENS=$ORDER(^PRCS(410,PRC410R,"IT","B",PRCIT,0))_","_PRC410R_","
+32 SET PRCFDA(410.02,PRCIENS,100)=PRCITID
+33 KILL PRCERR
+34 DO FILE^DIE("K","PRCFDA","PRCERR")
+35 ;
+36 ;quit on filer error
+37 IF $DATA(PRCERR)
SET PRCERR="ECMS ITEMUID not filed: "_$GET(PRCERR("DIERR","1","TEXT",1))
QUIT
+38 ;
+39 ;success
+40 SET PRCRSLT=1
End DoDot:1
+41 ;
+42 QUIT PRCRSLT
