- RCDPESRV ;ALB/TMK - Server interface to AR from Austin ;06/03/02
- ;;4.5;Accounts Receivable;**173**;Mar 20, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- SERVER ; Entry point for server option to process EDI Lockbox msgs received
- ; from Austin and redirected EOB transactions received from another
- ; VistA site
- ;
- N RCEFLG,RCERR,XMER,RCXMZ,RCTYPE
- K ^TMP("RCERR",$J),^TMP("RCMSG",$J),^TMP("RCMSGH",$J),^TMP($J)
- S RCXMZ=$G(XMZ)
- S RCEFLG=$$MSG(RCXMZ,.RCERR)
- D:$G(RCEFLG) PERROR^RCDPESR1(.RCERR,"G.RCDPE PAYMENTS EXCEPTIONS",RCXMZ)
- D DKILL^RCDPESR1(RCXMZ) S ZTREQ="@"
- K ^TMP("RCERR",$J),^TMP("RCMSG",$J),^TMP("RCMSGH",$J),^TMP($J)
- Q
- ;
- MSG(RCXMZ,RCERR) ; Read/Store message lines
- ; RCERR = array of errors
- ; RCXMZ = the # of the Mailman message contianing this message
- ;
- ; OUTPUT:
- ; Function returns flag ... 0 = no errors 1 = errors
- ; and the standard Mailman error variable contents of XMER
- ;
- N RCTYP1,RCDATE,RCHD,RCTXN,XMDUZ,RCGBL,RCD,RCEFLG,RCCT,RCDXM,X,Y
- K ^TMP("RCERR",$J),^TMP("RCMSG",$J),^TMP("RCMSGH",$J)
- ;
- S (RCEFLG,RCERR,RCTXN)="",RCGBL="RCTXN"
- ; Set up formatted mailman header data in RCD
- S RCD("MSG#")=RCXMZ\1
- S RCHD=$$NET^XMRENT(RCXMZ)
- S RCD("FROM")=$P(RCHD,U,3)
- S RCD("SUBJ")=$P(RCHD,U,6)
- S (X,RCDATE)=$P(RCHD,U)
- I X'="" D ;Reformat date, if needed
- . N %DT
- . I X'["@" S X=$P(X," ",1,3)_"@"_$P(X," ",4)
- . S %DT="XTS" D ^%DT S:Y>0 RCDATE=Y\.0001*.0001
- ;
- S RCD("DATE")=RCDATE
- ; Read up to the header line of message
- S RCCT=1
- F X XMREC Q:$S(XMER<0:1,1:$E(XMRG,1,3)="835"&($E(XMRG,4,6)="ERA"!($E(XMRG,4,6)="EFT")!($E(XMRG,4,6)="XFR")!($E(XMRG,4,6)="XAK"))) S RCCT=RCCT+1,^TMP("RCERR",$J,"MSG",RCCT)=XMRG
- I XMER<0 D G MSGQ
- . S (RCEFLG,RCERR)=1
- . S ^TMP("RCERR",$J,"MSG",.5)=RCHD
- . S ^TMP("RCERR",$J,"DATE")=RCDATE
- ;
- K ^TMP("RCERR",$J,"MSG")
- S RCTXN=XMRG,RCD("PAYFROM")=$P(RCTXN,U,6)
- S RCTYP1=$P(RCTXN,U)
- ;
- I RCTYP1["835XAK" D G MSGQ ; Accept/reject of transferred EOB
- . N DA,DR,DIE,RCACC,RC0,RC00,XMZ,XMTO,XMBODY,RCXM,X,Y
- . S RCACC=$P(RCTXN,U,2)
- . S DR=$S(RCACC'="":".1////"_RCACC_";.13////"_RCACC,1:".16////1")
- . S DA(1)=+$P(RCTXN,U,3),DA=$P($P(RCTXN,U,3),";",2)
- . S RC0=$G(^RCY(344.4,DA(1),0))
- . S RC00=$G(^RCY(344.4,DA(1),1,DA,0))
- . I $P(RC00,U,10)'="" Q ; Already updated
- . S DIE="^RCY(344.4,"_DA(1)_",1,"
- . I DA(1),DA,RC00'="" D ^DIE
- . S RCXM(1)="An EEOB record for bill "_$P(RC00,U,5)_" was transferred to",RCXM(2)=$P($G(^DIC(4,+$P(RC00,U,11),0)),U)_" on "_$$FMTE^XLFDT($P(RC00,U,12),2)
- . S RCXM(3)=" ",RCXM(4)=" ERA TRACE #: "_$P(RC0,U,2)_" SEQ #:"_+RC00
- . S RCXM(5)=" ",RCXM(6)=" ",RCXM(7)=" This message is to inform you this transfer was **** "_$S(RCACC="":"RECEIVED",1:$P("REJECTED^ACCEPTED",U,RCACC+1))_" ****"
- . S RCXM(8)=" ",RCXM(9)=" "
- . I RCACC S RCXM(10)=" You must make the appropriate funds transfers manually"
- . I 'RCACC S RCXM(10)=$S(RCACC="":" Contact this site if the EEOB is not ACCEPTED or REJECTED in a timely manner",1:" Try another site or contact your IMPLEMENTATION MANAGER to reconcile this")
- . S XMBODY="RCXM"
- . S XMTO("I:G.RCDPE PAYMENTS"_$S(RCACC:" MGMNT",1:""))=""
- . D
- .. N DUZ S DUZ=.5,DUZ(0)="@"
- .. D SENDMSG^XMXAPI(.5,"EDI LBOX TRANSFERRED EEOB "_$S(RCACC="":"RECEIVED",RCACC:"ACCEPTED",1:"REJECTED"),XMBODY,.XMTO,,.XMZ)
- . ;
- ;
- I RCTYP1["835",$E(RCTYP1,1,4)'="835X",RCD("FROM")'["POSTMASTER@FOC-AUSTIN.DOMAIN.EXT" D G MSGQ
- . ;Send bulletin warning for non-Austin ERA/EFT message received
- . S RCDXM(1)="An electronic transmission ("_$E($P(RCTXN,U),4,6)_") has been received by the EDI Lockbox",RCDXM(2)=" system that did not originate from the Austin system. This message"
- . S RCDXM(3)=" WILL NOT be stored on your system and may be a breach of security.",RCDXM(4)=" "
- . S RCDXM(5)=" Please contact your IRM with the following information:",RCDXM(6)=" ",RCDXM(7)="The message was sent from "_RCD("FROM")
- . S RCDXM(8)="The mail message number is "_RCXMZ
- . S RCDXM(9)="The text received in the message is:",RCDXM(10)=" "
- . S RCDXM(11)=RCTXN
- . D RESTMSG^RCDPESR1(+$O(RCDXM(""),-1),"RCDXM",RCXMZ)
- . D BULLERA^RCDPESR0("","",RCXMZ,"EDI LBOX - ERA/EFT NOT FROM AUSTIN "_$G(RCD("PAYFROM")),.RCDXM,0)
- ;
- S RCGBL="^TMP(""RCMSG"","_$J_")"
- S @RCGBL=RCTYP1,^TMP("RCMSGH",$J,0)=RCTXN
- ;
- I RCTYP1["835ERA"!(RCTYP1["835XFR") D ERAEOBIN^RCDPESR4(RCTXN,.RCD,RCGBL,.RCEFLG)
- ;
- I RCTYP1["835EFT" D EFTIN^RCDPESR3(RCTXN,.RCD,XMZ,RCGBL,.RCEFLG)
- ;
- MSGQ Q RCEFLG
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPESRV 4519 printed Feb 18, 2025@23:11:54 Page 2
- RCDPESRV ;ALB/TMK - Server interface to AR from Austin ;06/03/02
- +1 ;;4.5;Accounts Receivable;**173**;Mar 20, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- SERVER ; Entry point for server option to process EDI Lockbox msgs received
- +1 ; from Austin and redirected EOB transactions received from another
- +2 ; VistA site
- +3 ;
- +4 NEW RCEFLG,RCERR,XMER,RCXMZ,RCTYPE
- +5 KILL ^TMP("RCERR",$JOB),^TMP("RCMSG",$JOB),^TMP("RCMSGH",$JOB),^TMP($JOB)
- +6 SET RCXMZ=$GET(XMZ)
- +7 SET RCEFLG=$$MSG(RCXMZ,.RCERR)
- +8 if $GET(RCEFLG)
- DO PERROR^RCDPESR1(.RCERR,"G.RCDPE PAYMENTS EXCEPTIONS",RCXMZ)
- +9 DO DKILL^RCDPESR1(RCXMZ)
- SET ZTREQ="@"
- +10 KILL ^TMP("RCERR",$JOB),^TMP("RCMSG",$JOB),^TMP("RCMSGH",$JOB),^TMP($JOB)
- +11 QUIT
- +12 ;
- MSG(RCXMZ,RCERR) ; Read/Store message lines
- +1 ; RCERR = array of errors
- +2 ; RCXMZ = the # of the Mailman message contianing this message
- +3 ;
- +4 ; OUTPUT:
- +5 ; Function returns flag ... 0 = no errors 1 = errors
- +6 ; and the standard Mailman error variable contents of XMER
- +7 ;
- +8 NEW RCTYP1,RCDATE,RCHD,RCTXN,XMDUZ,RCGBL,RCD,RCEFLG,RCCT,RCDXM,X,Y
- +9 KILL ^TMP("RCERR",$JOB),^TMP("RCMSG",$JOB),^TMP("RCMSGH",$JOB)
- +10 ;
- +11 SET (RCEFLG,RCERR,RCTXN)=""
- SET RCGBL="RCTXN"
- +12 ; Set up formatted mailman header data in RCD
- +13 SET RCD("MSG#")=RCXMZ\1
- +14 SET RCHD=$$NET^XMRENT(RCXMZ)
- +15 SET RCD("FROM")=$PIECE(RCHD,U,3)
- +16 SET RCD("SUBJ")=$PIECE(RCHD,U,6)
- +17 SET (X,RCDATE)=$PIECE(RCHD,U)
- +18 ;Reformat date, if needed
- IF X'=""
- Begin DoDot:1
- +19 NEW %DT
- +20 IF X'["@"
- SET X=$PIECE(X," ",1,3)_"@"_$PIECE(X," ",4)
- +21 SET %DT="XTS"
- DO ^%DT
- if Y>0
- SET RCDATE=Y\.0001*.0001
- End DoDot:1
- +22 ;
- +23 SET RCD("DATE")=RCDATE
- +24 ; Read up to the header line of message
- +25 SET RCCT=1
- +26 FOR
- XECUTE XMREC
- if $SELECT(XMER<0
- QUIT
- SET RCCT=RCCT+1
- SET ^TMP("RCERR",$JOB,"MSG",RCCT)=XMRG
- +27 IF XMER<0
- Begin DoDot:1
- +28 SET (RCEFLG,RCERR)=1
- +29 SET ^TMP("RCERR",$JOB,"MSG",.5)=RCHD
- +30 SET ^TMP("RCERR",$JOB,"DATE")=RCDATE
- End DoDot:1
- GOTO MSGQ
- +31 ;
- +32 KILL ^TMP("RCERR",$JOB,"MSG")
- +33 SET RCTXN=XMRG
- SET RCD("PAYFROM")=$PIECE(RCTXN,U,6)
- +34 SET RCTYP1=$PIECE(RCTXN,U)
- +35 ;
- +36 ; Accept/reject of transferred EOB
- IF RCTYP1["835XAK"
- Begin DoDot:1
- +37 NEW DA,DR,DIE,RCACC,RC0,RC00,XMZ,XMTO,XMBODY,RCXM,X,Y
- +38 SET RCACC=$PIECE(RCTXN,U,2)
- +39 SET DR=$SELECT(RCACC'="":".1////"_RCACC_";.13////"_RCACC,1:".16////1")
- +40 SET DA(1)=+$PIECE(RCTXN,U,3)
- SET DA=$PIECE($PIECE(RCTXN,U,3),";",2)
- +41 SET RC0=$GET(^RCY(344.4,DA(1),0))
- +42 SET RC00=$GET(^RCY(344.4,DA(1),1,DA,0))
- +43 ; Already updated
- IF $PIECE(RC00,U,10)'=""
- QUIT
- +44 SET DIE="^RCY(344.4,"_DA(1)_",1,"
- +45 IF DA(1)
- IF DA
- IF RC00'=""
- DO ^DIE
- +46 SET RCXM(1)="An EEOB record for bill "_$PIECE(RC00,U,5)_" was transferred to"
- SET RCXM(2)=$PIECE($GET(^DIC(4,+$PIECE(RC00,U,11),0)),U)_" on "_$$FMTE^XLFDT($PIECE(RC00,U,12),2)
- +47 SET RCXM(3)=" "
- SET RCXM(4)=" ERA TRACE #: "_$PIECE(RC0,U,2)_" SEQ #:"_+RC00
- +48 SET RCXM(5)=" "
- SET RCXM(6)=" "
- SET RCXM(7)=" This message is to inform you this transfer was **** "_$SELECT(RCACC="":"RECEIVED",1:$PIECE("REJECTED^ACCEPTED",U,RCACC+1))_" ****"
- +49 SET RCXM(8)=" "
- SET RCXM(9)=" "
- +50 IF RCACC
- SET RCXM(10)=" You must make the appropriate funds transfers manually"
- +51 IF 'RCACC
- SET RCXM(10)=$SELECT(RCACC="":" Contact this site if the EEOB is not ACCEPTED or REJECTED in a timely manner",1:" Try another site or contact your IMPLEMENTATION MANAGER to reconcile this")
- +52 SET XMBODY="RCXM"
- +53 SET XMTO("I:G.RCDPE PAYMENTS"_$SELECT(RCACC:" MGMNT",1:""))=""
- +54 Begin DoDot:2
- +55 NEW DUZ
- SET DUZ=.5
- SET DUZ(0)="@"
- +56 DO SENDMSG^XMXAPI(.5,"EDI LBOX TRANSFERRED EEOB "_$SELECT(RCACC="":"RECEIVED",RCACC:"ACCEPTED",1:"REJECTED"),XMBODY,.XMTO,,.XMZ)
- End DoDot:2
- +57 ;
- End DoDot:1
- GOTO MSGQ
- +58 ;
- +59 IF RCTYP1["835"
- IF $EXTRACT(RCTYP1,1,4)'="835X"
- IF RCD("FROM")'["POSTMASTER@FOC-AUSTIN.DOMAIN.EXT"
- Begin DoDot:1
- +60 ;Send bulletin warning for non-Austin ERA/EFT message received
- +61 SET RCDXM(1)="An electronic transmission ("_$EXTRACT($PIECE(RCTXN,U),4,6)_") has been received by the EDI Lockbox"
- SET RCDXM(2)=" system that did not originate from the Austin system. This message"
- +62 SET RCDXM(3)=" WILL NOT be stored on your system and may be a breach of security."
- SET RCDXM(4)=" "
- +63 SET RCDXM(5)=" Please contact your IRM with the following information:"
- SET RCDXM(6)=" "
- SET RCDXM(7)="The message was sent from "_RCD("FROM")
- +64 SET RCDXM(8)="The mail message number is "_RCXMZ
- +65 SET RCDXM(9)="The text received in the message is:"
- SET RCDXM(10)=" "
- +66 SET RCDXM(11)=RCTXN
- +67 DO RESTMSG^RCDPESR1(+$ORDER(RCDXM(""),-1),"RCDXM",RCXMZ)
- +68 DO BULLERA^RCDPESR0("","",RCXMZ,"EDI LBOX - ERA/EFT NOT FROM AUSTIN "_$GET(RCD("PAYFROM")),.RCDXM,0)
- End DoDot:1
- GOTO MSGQ
- +69 ;
- +70 SET RCGBL="^TMP(""RCMSG"","_$JOB_")"
- +71 SET @RCGBL=RCTYP1
- SET ^TMP("RCMSGH",$JOB,0)=RCTXN
- +72 ;
- +73 IF RCTYP1["835ERA"!(RCTYP1["835XFR")
- DO ERAEOBIN^RCDPESR4(RCTXN,.RCD,RCGBL,.RCEFLG)
- +74 ;
- +75 IF RCTYP1["835EFT"
- DO EFTIN^RCDPESR3(RCTXN,.RCD,XMZ,RCGBL,.RCEFLG)
- +76 ;
- MSGQ QUIT RCEFLG
- +1 ;