RCDPESR6 ;ALB/TMK/DWA - Server auto-update file 344.4 - EDI Lockbox ;20 Dec 2018 14:47:23
;;4.5;Accounts Receivable;**173,214,208,230,252,269,271,298,321,332,345**;Mar 20, 1995;Build 34
;Per VA Directive 6402, this routine should not be modified.
;
;Reference to $$VALECME^BPSUTIL2 supported by IA# 6139
;
UPD3444(RCRTOT) ; Add EOB detail to list in 344.41 for file 344.4 entry RCRTOT
; If passed by reference, RCRTOT is returned = "" if errors
;
N DA,DD,DIC,DIK,DLAYGO,DO,DR,RC,RC1,RC2,RCCOM1,RCCOM2,RCCT,RCDPNM,RCEOB,RCNPI1,RCNPI2,X,Y,Z
S RC=0 F S RC=$O(^TMP($J,"RCDPEOB",RC)) Q:'RC S RC1=$G(^(RC)),RC2=$G(^(RC,"EOB")),RCEOB=+RC2 D Q:'RCRTOT
. ; Update 344.41 with reference to this record if it doesn't already exist
. I RCEOB>0 Q:$D(^RCY(344.4,RCRTOT,1,"AC",RCEOB,RC))
. I RCEOB'>0,$S($P(RC1,U,2)'="":$D(^RCY(344.4,RCRTOT,1,"AD",$P(RC1,U,2),RC)),1:0) Q
. ; Disregard ECME reject related EEOBs; ECME# can be 7 digits or 12 digits
. I RCEOB'>0,'$P(RC2,U,2),$$VALECME^BPSUTIL2($P(RC1,U,2)),$$REJECT^IBNCPDPU($P(RC1,U,2),$P(RC1,U,3)) Q
. ;
. S DA(1)=RCRTOT,X=RC,DIC="^RCY(344.4,"_DA(1)_",1,",DIC(0)="L",DLAYGO=344.41
. S DIC("DR")=$S($G(RCEOB)>0:".02////"_RCEOB,1:".05////"_$P(RC1,U,2)_";.07////1")
. I $P(RC2,U,2)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".03///"_$P(RC2,U,2) ; amt
. I $P(RC2,U,3)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".04////"_$P(RC2,U,3) ; ins co
. I $P(RC2,U,4) S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".14////1" ; reversal
. I $P(RC2,U,5)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".15////^S X=$E($P(RC2,U,5),1,30)" ; Patient name
. ; Process Billing Prov NPI, Rendering/Servicing NPI & name
. S (RCCOM1,RCCOM2)=""
. S RCNPI1=$P(RC2,U,10),RCNPI2=$P(RC2,U,11)
. I RCNPI1'="",'$$CHKDGT^XUSNPI(RCNPI1) S RCCOM1="The Billing Provider NPI received on the 835 ("_$E(RCNPI1,1,10)_") is not a valid format."
. I RCNPI2'="",'$$CHKDGT^XUSNPI(RCNPI2) S RCCOM2="The "_$S($P(RC2,U,12)=1:"Rendering",1:"Servicing")_" NPI received on the 835 ("_$E(RCNPI2,1,10)_") is not a valid format."
. I RCCOM1="" S DIC("DR")=DIC("DR")_";.18////^S X=$P(RC2,U,10)" ;Billing Provider NPI
. I RCCOM2="" S DIC("DR")=DIC("DR")_";.19////^S X=$P(RC2,U,11)" ;Rendering Provider NPI
. S RCDPNM=$P(RC2,U,13) I $P(RC2,U,14)]"" S RCDPNM=RCDPNM_$S(RCDPNM]"":",",1:"")_$P(RC2,U,14)
. S DIC("DR")=DIC("DR")_";.2////^S X=$P(RC2,U,12);.21////^S X=RCDPNM" ; Entity Type Qualifier ^ Last name,First Name
. S DIC("DR")=DIC("DR")_";.22////^S X=RCCOM1;.23////^S X=RCCOM2" ;Comment on Billing provider^comment on rendering/servicing provider NPI
. I $$VALECME^BPSUTIL2($P(RC1,U,4)) D
.. S DIC("DR")=DIC("DR")_";.24////^S X=$P(RC1,U,4)" ;Add ECME number (if valid) PRCA*4.5*298
. D FILE^DICN K DO,DD,DLAYGO,DIC,DIK
. S RCCT=+Y
. I RCCT<0 D Q
.. S DA=RCRTOT,DIK="^RCY(344.4," D ^DIK
.. S RCRTOT=0
. ; PRCA*4.5*345 - Update file 361.1 with era detail pointer
. I RCEOB D ERADET^IBCEOB(RCEOB,RCCT_","_RCRTOT_",")
. ; If there is no IB EOB record, store the raw data in 344.411
. I RC1'>0!(RCEOB'>0) D
.. N RCDATA,RCC,RCDA
.. S RCC=2,RCDATA(1)=$G(^TMP($J,"RCDPEOB","HDR"))
.. ; PRCA*4.5*321 - use RC in place of RCCT to allow for gaps in ERA sequence numbers (due to ECME rejects)
.. S Z=0 F S Z=$O(^TMP($J,"RCDPEOB",RC,Z)) Q:'Z S RCC=RCC+1,RCDATA(RCC)=$G(^TMP($J,"RCDPEOB",RC,Z))
.. S RCDA(1)=RCRTOT,RCDA=RCCT
.. D WP^DIE(344.41,$$IENS^DILF(.RCDA),1,"A","RCDATA")
Q
;
; PRCA*4.5*332 start - 8 August 2018
ERATOT(RC3445DA,RCERR) ;function, File ERA TOTAL rec in 344.4 from entry RC3445DA in 344.5
; RC3445DA = ien file 344.5
; Returns: NEW ien file 344.4
; RCERR if passed by reference, with error text
; RCERR(1)=duplicated message
N LPXREF,RCDA,RCDUP,RCFORCE,RCRAW,RCTRACE,RCX,X,Y
S (RCERR,RCDA)="" ; returned values
S RCRAW(0)=$G(^RCY(344.5,RC3445DA,2,1,0))
S RCRAW("Type")=$P(RCRAW(0),U),RCTRACE=$P(RCRAW(0),U,8),RCRAW("InsID")=$P(RCRAW(0),U,7),RCRAW("Payer")=$P(RCRAW(0),U,6),RCRAW("Method")=$P(RCRAW(0),U,17)
; Need header record as first entry in field
I RCRAW("Type")'["835ERA" S RCERR="No header record found in message. An EEOB exception record was created" G ERATOTQ
;
S RCRAW("Date")=$$FMDT^RCDPESR1($P(RCRAW(0),U,9)),RCRAW("Amount")=$J(($P(RCRAW(0),U,10)/100),0,2)
;Elec ERA's must have a trace # and an ins co id
I RCTRACE=""!(RCRAW("InsID")="") S RCERR="Trace # or ins ID missing on ERA transaction. An EEOB exception record was created." G ERATOTQ
; Make sure it's not already there
S (RCDUP,LPXREF)=0
F S LPXREF=$O(^RCY(344.4,"ATRIDUP",$$UP^XLFSTR(RCTRACE),$$UP^XLFSTR(RCRAW("InsID")),LPXREF)) Q:'LPXREF D Q:RCDUP
. S LPXREF(0)=$G(^RCY(344.4,LPXREF,0))
. I $P(LPXREF(0),U,4)=RCRAW("Date"),+$P(LPXREF(0),U,5)=+RCRAW("Amount") S RCDUP=1
; If ERA has a receipt and is being filed from Duplicate ERA Worklist find a new
; unique trace number for this payer/amount/date and override duplicate check
S RCFORCE=+$$GET1^DIQ(344.5,RC3445DA_",",.15,"I") ;(#.15) DUPLICATE INDICATOR [15S]
I RCFORCE D ; create new trace #
. N DPCNTR S X=$E(RCTRACE,1,45)_"-DUP" ; 49 chars. max
. ; start with null, then add numbers until it's unique
. F DPCNTR="",1:1 Q:'$D(^RCY(344.4,"ATRIDUP",$$UP^XLFSTR(X_DPCNTR),$$UP^XLFSTR(RCRAW("InsID"))))
. ; above: "ATRIDUP" x-ref is TRACE NUMBER & INSURANCE CO ID
. S (RCTRACE,RCNEWTRC)=X_DPCNTR
;
I '$G(RCFORCE),RCDUP,$P(LPXREF(0),U,8) D G ERATOTQ ; Receipt already exists - no update
. S RCERR="This is a duplicate ERA and has already been posted",RCERR(1)=-2
;
I '$G(RCFORCE),RCDUP D G ERATOTQ ; duplicate found
. S RCERR="DUP",RCERR(1)=$S($P(LPXREF(0),U,12)'=$P($G(^RCY(344.5,RC3445DA,0)),U,11):$P(LPXREF(0),U,12),1:-1) G ERATOTQ
;
D ; context for FileMan variables
. N DA,DD,DIC,DIE,DIK,DLAYGO,DO,DR,X,Y
. S RCX=$O(^RCY(344.4,$C(1)),-1)+1,X=0 ; create new IEN
. ; loop until no entry found
. F RCX=RCX:1 L +^RCY(344.4,RCX,0):1 D:$T Q:X ; PRCA*4.5*332 Fix duplicate number issue
. . I $D(^RCY(344.4,RCX)) L -^RCY(344.4,RCX,0) Q ; Lock first then check for existance
. . S X=RCX ; new entry #
. ; X from above will be new .01 field value
. S DIC(0)="L",DIC="^RCY(344.4,",DLAYGO=344.4
. S DIC("DR")=".02////"_RCTRACE_";.03////"_RCRAW("InsID")_";.04////"_RCRAW("Date")_";.05////"_RCRAW("Amount")_";.06////"_$P(RCRAW(0),U,6)_";.09////0;.12////"_$P($G(^RCY(344.5,RC3445DA,0)),U,11)_";.07////"_$$NOW^XLFDT()_";.1////1"
. I RCRAW("Method")'="" S DIC("DR")=DIC("DR")_";.15////"_RCRAW("Method")
. D FILE^DICN S RCDA=$S(Y<0:"",1:+Y) ; new IEN in 344.4
; done filing, unlock
L -^RCY(344.4,RCX,0)
I 'RCDA D
. S RCERR="An error was encountered that prevented the adding of an ERA totals record. An EEOB exception record was created."
;
ERATOTQ ; GOTO here or fall through
Q RCDA ; return new IEN
; PRCA*4.5*332 end - 8 August 2018
;
UPDCON(RCRTOT) ; Add contact information to file 344.4 for an ERA
N DIE,DA,DR,Z,Q,X,Y,A,TYPE
S Z=$G(^TMP($J,"RCDPEOB","CONTACT"))
Q:$TR($P(Z,U,3,9),U)=""
S DA=RCRTOT,DIE="^RCY(344.4,",DR=""
;
; If old format do
I +$P($G(^TMP($J,"RCDPEOB","HDR")),U,16)'>0 D
. F Q=2:1:8 S DR=DR_$S(DR'="":";3.0",1:"3.0")_(Q-1)_"///"_$S($P(Z,U,Q)="":"@",1:"/"_$P(Z,U,Q))
;
; If new format (5010) do
I +$P($G(^TMP($J,"RCDPEOB","HDR")),U,16)>0 D
. N CNT S CNT=0
. I $P(Z,U,2)'="" S DR="3.01////"_$P(Z,U,2)
.I $P(Z,U,3)'="" S DR=DR_$S(DR'="":";3.02",1:"3.02")_"////"_$P(Z,U,3)_";3.03////TE",CNT=CNT+1
.I $P(Z,U,4)'="" D
..S:CNT=1 DR=DR_$S(DR'="":";3.04",1:"3.04")_"////"_$P(Z,U,4)_";3.05////FX"
..S:CNT=0 DR=DR_$S(DR'="":";3.02",1:"3.02")_"////"_$P(Z,U,4)_";3.03////FX"
..S CNT=CNT+1
.I $P(Z,U,5)'="" D
..S:CNT=2 DR=DR_$S(DR'="":";3.06",1:"3.06")_"////"_$P(Z,U,5)_";3.07////EM"
..S:CNT=1 DR=DR_$S(DR'="":";3.04",1:"3.04")_"////"_$P(Z,U,5)_";3.05////EM"
..S:CNT=0 DR=DR_$S(DR'="":";3.02",1:"3.02")_"////"_$P(Z,U,5)_";3.03////EM"
. I $P(Z,U,6)'="" S DR=DR_$S(DR'="":";5.01",1:"5.01")_"////"_$P(Z,U,6)
D ^DIE
Q
;
UPDADJ(RCRTOT) ; Add ERA level adj data to file 344.4
N Z,Z0,DA,DIC,DLAYGO,DR,X,Y,DO,DD
; Remove any already there
S Z=0 F S Z=$O(^RCY(344.4,RCRTOT,2,Z)) Q:'Z S DA(1)=RCRTOT,DA=Z D ^DIK
;
S Z=0 F S Z=$O(^TMP($J,"RCDPEOB","ADJ",Z)) Q:'Z S Z0=$G(^(Z)) D
. S DIC(0)="L",X=$P(Z0,U,3)_" ",DA(1)=RCRTOT,DIC="^RCY(344.4,"_DA(1)_",2,",DIC("DR")=$S($P(Z0,U,2)'="":".02////"_$P(Z0,U,2),1:"")
. S DIC("DR")=DIC("DR")_$S(DIC("DR")'="":";",1:"")_$S($P(Z0,U,4)'="":".03////"_$J(-$P(Z0,U,4)/100,"",2),1:"")
. S DIC("DR")=DIC("DR")_$S(DIC("DR")'="":";",1:"")_$S($P(Z0,U,5)'="":".04////"_$P(Z0,U,5),1:""),DLAYGO=344.42
. S:$O(^RCY(344.4,RCRTOT,2,"B",X,0)) X=""""_X_""""
. D FILE^DICN K DIC,DO,DD
Q
;
DUPREC(RCET,RCCT,RCSTAR,RCFILE,RCALLDUP,RCEOB,RCBILL,RCDUPEOB) ; Overflow from RCDPESR2
S ^TMP("RCERR1",$J,RCCT)=" ",^TMP("RCERR1",$J,RCCT,1)=RCET_RCCT_RCSTAR
S ^TMP("RCERR1",$J,RCCT,2)="(Warning): EEOB detail already filed for "_RCBILL_" - "_$S(RCALLDUP:"Duplicate not stored",1:"EEOB updated"),^TMP("RCERR1",$J,RCCT,3)=" " S:RCFILE=5 ^TMP("RCERR1",$J,RCCT,"*")=^TMP("RCERR1",$J,RCCT,2)
I RCALLDUP S RCEOB="",RCDUPEOB=-1 Q
S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U)=RCEOB
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPESR6 9286 printed Dec 13, 2024@01:45:27 Page 2
RCDPESR6 ;ALB/TMK/DWA - Server auto-update file 344.4 - EDI Lockbox ;20 Dec 2018 14:47:23
+1 ;;4.5;Accounts Receivable;**173,214,208,230,252,269,271,298,321,332,345**;Mar 20, 1995;Build 34
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;Reference to $$VALECME^BPSUTIL2 supported by IA# 6139
+5 ;
UPD3444(RCRTOT) ; Add EOB detail to list in 344.41 for file 344.4 entry RCRTOT
+1 ; If passed by reference, RCRTOT is returned = "" if errors
+2 ;
+3 NEW DA,DD,DIC,DIK,DLAYGO,DO,DR,RC,RC1,RC2,RCCOM1,RCCOM2,RCCT,RCDPNM,RCEOB,RCNPI1,RCNPI2,X,Y,Z
+4 SET RC=0
FOR
SET RC=$ORDER(^TMP($JOB,"RCDPEOB",RC))
if 'RC
QUIT
SET RC1=$GET(^(RC))
SET RC2=$GET(^(RC,"EOB"))
SET RCEOB=+RC2
Begin DoDot:1
+5 ; Update 344.41 with reference to this record if it doesn't already exist
+6 IF RCEOB>0
if $DATA(^RCY(344.4,RCRTOT,1,"AC",RCEOB,RC))
QUIT
+7 IF RCEOB'>0
IF $SELECT($PIECE(RC1,U,2)'="":$DATA(^RCY(344.4,RCRTOT,1,"AD",$PIECE(RC1,U,2),RC)),1:0)
QUIT
+8 ; Disregard ECME reject related EEOBs; ECME# can be 7 digits or 12 digits
+9 IF RCEOB'>0
IF '$PIECE(RC2,U,2)
IF $$VALECME^BPSUTIL2($PIECE(RC1,U,2))
IF $$REJECT^IBNCPDPU($PIECE(RC1,U,2),$PIECE(RC1,U,3))
QUIT
+10 ;
+11 SET DA(1)=RCRTOT
SET X=RC
SET DIC="^RCY(344.4,"_DA(1)_",1,"
SET DIC(0)="L"
SET DLAYGO=344.41
+12 SET DIC("DR")=$SELECT($GET(RCEOB)>0:".02////"_RCEOB,1:".05////"_$PIECE(RC1,U,2)_";.07////1")
+13 ; amt
IF $PIECE(RC2,U,2)'=""
SET DIC("DR")=DIC("DR")_$SELECT($LENGTH(DIC("DR")):";",1:"")_".03///"_$PIECE(RC2,U,2)
+14 ; ins co
IF $PIECE(RC2,U,3)'=""
SET DIC("DR")=DIC("DR")_$SELECT($LENGTH(DIC("DR")):";",1:"")_".04////"_$PIECE(RC2,U,3)
+15 ; reversal
IF $PIECE(RC2,U,4)
SET DIC("DR")=DIC("DR")_$SELECT($LENGTH(DIC("DR")):";",1:"")_".14////1"
+16 ; Patient name
IF $PIECE(RC2,U,5)'=""
SET DIC("DR")=DIC("DR")_$SELECT($LENGTH(DIC("DR")):";",1:"")_".15////^S X=$E($P(RC2,U,5),1,30)"
+17 ; Process Billing Prov NPI, Rendering/Servicing NPI & name
+18 SET (RCCOM1,RCCOM2)=""
+19 SET RCNPI1=$PIECE(RC2,U,10)
SET RCNPI2=$PIECE(RC2,U,11)
+20 IF RCNPI1'=""
IF '$$CHKDGT^XUSNPI(RCNPI1)
SET RCCOM1="The Billing Provider NPI received on the 835 ("_$EXTRACT(RCNPI1,1,10)_") is not a valid format."
+21 IF RCNPI2'=""
IF '$$CHKDGT^XUSNPI(RCNPI2)
SET RCCOM2="The "_$SELECT($PIECE(RC2,U,12)=1:"Rendering",1:"Servicing")_" NPI received on the 835 ("_$EXTRACT(RCNPI2,1,10)_") is not a valid format."
+22 ;Billing Provider NPI
IF RCCOM1=""
SET DIC("DR")=DIC("DR")_";.18////^S X=$P(RC2,U,10)"
+23 ;Rendering Provider NPI
IF RCCOM2=""
SET DIC("DR")=DIC("DR")_";.19////^S X=$P(RC2,U,11)"
+24 SET RCDPNM=$PIECE(RC2,U,13)
IF $PIECE(RC2,U,14)]""
SET RCDPNM=RCDPNM_$SELECT(RCDPNM]"":",",1:"")_$PIECE(RC2,U,14)
+25 ; Entity Type Qualifier ^ Last name,First Name
SET DIC("DR")=DIC("DR")_";.2////^S X=$P(RC2,U,12);.21////^S X=RCDPNM"
+26 ;Comment on Billing provider^comment on rendering/servicing provider NPI
SET DIC("DR")=DIC("DR")_";.22////^S X=RCCOM1;.23////^S X=RCCOM2"
+27 IF $$VALECME^BPSUTIL2($PIECE(RC1,U,4))
Begin DoDot:2
+28 ;Add ECME number (if valid) PRCA*4.5*298
SET DIC("DR")=DIC("DR")_";.24////^S X=$P(RC1,U,4)"
End DoDot:2
+29 DO FILE^DICN
KILL DO,DD,DLAYGO,DIC,DIK
+30 SET RCCT=+Y
+31 IF RCCT<0
Begin DoDot:2
+32 SET DA=RCRTOT
SET DIK="^RCY(344.4,"
DO ^DIK
+33 SET RCRTOT=0
End DoDot:2
QUIT
+34 ; PRCA*4.5*345 - Update file 361.1 with era detail pointer
+35 IF RCEOB
DO ERADET^IBCEOB(RCEOB,RCCT_","_RCRTOT_",")
+36 ; If there is no IB EOB record, store the raw data in 344.411
+37 IF RC1'>0!(RCEOB'>0)
Begin DoDot:2
+38 NEW RCDATA,RCC,RCDA
+39 SET RCC=2
SET RCDATA(1)=$GET(^TMP($JOB,"RCDPEOB","HDR"))
+40 ; PRCA*4.5*321 - use RC in place of RCCT to allow for gaps in ERA sequence numbers (due to ECME rejects)
+41 SET Z=0
FOR
SET Z=$ORDER(^TMP($JOB,"RCDPEOB",RC,Z))
if 'Z
QUIT
SET RCC=RCC+1
SET RCDATA(RCC)=$GET(^TMP($JOB,"RCDPEOB",RC,Z))
+42 SET RCDA(1)=RCRTOT
SET RCDA=RCCT
+43 DO WP^DIE(344.41,$$IENS^DILF(.RCDA),1,"A","RCDATA")
End DoDot:2
End DoDot:1
if 'RCRTOT
QUIT
+44 QUIT
+45 ;
+46 ; PRCA*4.5*332 start - 8 August 2018
ERATOT(RC3445DA,RCERR) ;function, File ERA TOTAL rec in 344.4 from entry RC3445DA in 344.5
+1 ; RC3445DA = ien file 344.5
+2 ; Returns: NEW ien file 344.4
+3 ; RCERR if passed by reference, with error text
+4 ; RCERR(1)=duplicated message
+5 NEW LPXREF,RCDA,RCDUP,RCFORCE,RCRAW,RCTRACE,RCX,X,Y
+6 ; returned values
SET (RCERR,RCDA)=""
+7 SET RCRAW(0)=$GET(^RCY(344.5,RC3445DA,2,1,0))
+8 SET RCRAW("Type")=$PIECE(RCRAW(0),U)
SET RCTRACE=$PIECE(RCRAW(0),U,8)
SET RCRAW("InsID")=$PIECE(RCRAW(0),U,7)
SET RCRAW("Payer")=$PIECE(RCRAW(0),U,6)
SET RCRAW("Method")=$PIECE(RCRAW(0),U,17)
+9 ; Need header record as first entry in field
+10 IF RCRAW("Type")'["835ERA"
SET RCERR="No header record found in message. An EEOB exception record was created"
GOTO ERATOTQ
+11 ;
+12 SET RCRAW("Date")=$$FMDT^RCDPESR1($PIECE(RCRAW(0),U,9))
SET RCRAW("Amount")=$JUSTIFY(($PIECE(RCRAW(0),U,10)/100),0,2)
+13 ;Elec ERA's must have a trace # and an ins co id
+14 IF RCTRACE=""!(RCRAW("InsID")="")
SET RCERR="Trace # or ins ID missing on ERA transaction. An EEOB exception record was created."
GOTO ERATOTQ
+15 ; Make sure it's not already there
+16 SET (RCDUP,LPXREF)=0
+17 FOR
SET LPXREF=$ORDER(^RCY(344.4,"ATRIDUP",$$UP^XLFSTR(RCTRACE),$$UP^XLFSTR(RCRAW("InsID")),LPXREF))
if 'LPXREF
QUIT
Begin DoDot:1
+18 SET LPXREF(0)=$GET(^RCY(344.4,LPXREF,0))
+19 IF $PIECE(LPXREF(0),U,4)=RCRAW("Date")
IF +$PIECE(LPXREF(0),U,5)=+RCRAW("Amount")
SET RCDUP=1
End DoDot:1
if RCDUP
QUIT
+20 ; If ERA has a receipt and is being filed from Duplicate ERA Worklist find a new
+21 ; unique trace number for this payer/amount/date and override duplicate check
+22 ;(#.15) DUPLICATE INDICATOR [15S]
SET RCFORCE=+$$GET1^DIQ(344.5,RC3445DA_",",.15,"I")
+23 ; create new trace #
IF RCFORCE
Begin DoDot:1
+24 ; 49 chars. max
NEW DPCNTR
SET X=$EXTRACT(RCTRACE,1,45)_"-DUP"
+25 ; start with null, then add numbers until it's unique
+26 FOR DPCNTR="",1:1
if '$DATA(^RCY(344.4,"ATRIDUP",$$UP^XLFSTR(X_DPCNTR),$$UP^XLFSTR(RCRAW("InsID"))))
QUIT
+27 ; above: "ATRIDUP" x-ref is TRACE NUMBER & INSURANCE CO ID
+28 SET (RCTRACE,RCNEWTRC)=X_DPCNTR
End DoDot:1
+29 ;
+30 ; Receipt already exists - no update
IF '$GET(RCFORCE)
IF RCDUP
IF $PIECE(LPXREF(0),U,8)
Begin DoDot:1
+31 SET RCERR="This is a duplicate ERA and has already been posted"
SET RCERR(1)=-2
End DoDot:1
GOTO ERATOTQ
+32 ;
+33 ; duplicate found
IF '$GET(RCFORCE)
IF RCDUP
Begin DoDot:1
+34 SET RCERR="DUP"
SET RCERR(1)=$SELECT($PIECE(LPXREF(0),U,12)'=$PIECE($GET(^RCY(344.5,RC3445DA,0)),U,11):$PIECE(LPXREF(0),U,12),1:-1)
GOTO ERATOTQ
End DoDot:1
GOTO ERATOTQ
+35 ;
+36 ; context for FileMan variables
Begin DoDot:1
+37 NEW DA,DD,DIC,DIE,DIK,DLAYGO,DO,DR,X,Y
+38 ; create new IEN
SET RCX=$ORDER(^RCY(344.4,$CHAR(1)),-1)+1
SET X=0
+39 ; loop until no entry found
+40 ; PRCA*4.5*332 Fix duplicate number issue
FOR RCX=RCX:1
LOCK +^RCY(344.4,RCX,0):1
if $TEST
Begin DoDot:2
+41 ; Lock first then check for existance
IF $DATA(^RCY(344.4,RCX))
LOCK -^RCY(344.4,RCX,0)
QUIT
+42 ; new entry #
SET X=RCX
End DoDot:2
if X
QUIT
+43 ; X from above will be new .01 field value
+44 SET DIC(0)="L"
SET DIC="^RCY(344.4,"
SET DLAYGO=344.4
+45 SET DIC("DR")=".02////"_RCTRACE_";.03////"_RCRAW("InsID")_";.04////"_RCRAW("Date")_";.05////"_RCRAW("Amount")_";.06////"_$PIECE(RCRAW(0),U,6)_";.09////0;.12////"_$PIECE($GET(^RCY(344.5,RC3445DA,0)),U,11)_";.07////"_$$NOW^XLFDT()_";.1////1"
+46 IF RCRAW("Method")'=""
SET DIC("DR")=DIC("DR")_";.15////"_RCRAW("Method")
+47 ; new IEN in 344.4
DO FILE^DICN
SET RCDA=$SELECT(Y<0:"",1:+Y)
End DoDot:1
+48 ; done filing, unlock
+49 LOCK -^RCY(344.4,RCX,0)
+50 IF 'RCDA
Begin DoDot:1
+51 SET RCERR="An error was encountered that prevented the adding of an ERA totals record. An EEOB exception record was created."
End DoDot:1
+52 ;
ERATOTQ ; GOTO here or fall through
+1 ; return new IEN
QUIT RCDA
+2 ; PRCA*4.5*332 end - 8 August 2018
+3 ;
UPDCON(RCRTOT) ; Add contact information to file 344.4 for an ERA
+1 NEW DIE,DA,DR,Z,Q,X,Y,A,TYPE
+2 SET Z=$GET(^TMP($JOB,"RCDPEOB","CONTACT"))
+3 if $TRANSLATE($PIECE(Z,U,3,9),U)=""
QUIT
+4 SET DA=RCRTOT
SET DIE="^RCY(344.4,"
SET DR=""
+5 ;
+6 ; If old format do
+7 IF +$PIECE($GET(^TMP($JOB,"RCDPEOB","HDR")),U,16)'>0
Begin DoDot:1
+8 FOR Q=2:1:8
SET DR=DR_$SELECT(DR'="":";3.0",1:"3.0")_(Q-1)_"///"_$SELECT($PIECE(Z,U,Q)="":"@",1:"/"_$PIECE(Z,U,Q))
End DoDot:1
+9 ;
+10 ; If new format (5010) do
+11 IF +$PIECE($GET(^TMP($JOB,"RCDPEOB","HDR")),U,16)>0
Begin DoDot:1
+12 NEW CNT
SET CNT=0
+13 IF $PIECE(Z,U,2)'=""
SET DR="3.01////"_$PIECE(Z,U,2)
+14 IF $PIECE(Z,U,3)'=""
SET DR=DR_$SELECT(DR'="":";3.02",1:"3.02")_"////"_$PIECE(Z,U,3)_";3.03////TE"
SET CNT=CNT+1
+15 IF $PIECE(Z,U,4)'=""
Begin DoDot:2
+16 if CNT=1
SET DR=DR_$SELECT(DR'="":";3.04",1:"3.04")_"////"_$PIECE(Z,U,4)_";3.05////FX"
+17 if CNT=0
SET DR=DR_$SELECT(DR'="":";3.02",1:"3.02")_"////"_$PIECE(Z,U,4)_";3.03////FX"
+18 SET CNT=CNT+1
End DoDot:2
+19 IF $PIECE(Z,U,5)'=""
Begin DoDot:2
+20 if CNT=2
SET DR=DR_$SELECT(DR'="":";3.06",1:"3.06")_"////"_$PIECE(Z,U,5)_";3.07////EM"
+21 if CNT=1
SET DR=DR_$SELECT(DR'="":";3.04",1:"3.04")_"////"_$PIECE(Z,U,5)_";3.05////EM"
+22 if CNT=0
SET DR=DR_$SELECT(DR'="":";3.02",1:"3.02")_"////"_$PIECE(Z,U,5)_";3.03////EM"
End DoDot:2
+23 IF $PIECE(Z,U,6)'=""
SET DR=DR_$SELECT(DR'="":";5.01",1:"5.01")_"////"_$PIECE(Z,U,6)
End DoDot:1
+24 DO ^DIE
+25 QUIT
+26 ;
UPDADJ(RCRTOT) ; Add ERA level adj data to file 344.4
+1 NEW Z,Z0,DA,DIC,DLAYGO,DR,X,Y,DO,DD
+2 ; Remove any already there
+3 SET Z=0
FOR
SET Z=$ORDER(^RCY(344.4,RCRTOT,2,Z))
if 'Z
QUIT
SET DA(1)=RCRTOT
SET DA=Z
DO ^DIK
+4 ;
+5 SET Z=0
FOR
SET Z=$ORDER(^TMP($JOB,"RCDPEOB","ADJ",Z))
if 'Z
QUIT
SET Z0=$GET(^(Z))
Begin DoDot:1
+6 SET DIC(0)="L"
SET X=$PIECE(Z0,U,3)_" "
SET DA(1)=RCRTOT
SET DIC="^RCY(344.4,"_DA(1)_",2,"
SET DIC("DR")=$SELECT($PIECE(Z0,U,2)'="":".02////"_$PIECE(Z0,U,2),1:"")
+7 SET DIC("DR")=DIC("DR")_$SELECT(DIC("DR")'="":";",1:"")_$SELECT($PIECE(Z0,U,4)'="":".03////"_$JUSTIFY(-$PIECE(Z0,U,4)/100,"",2),1:"")
+8 SET DIC("DR")=DIC("DR")_$SELECT(DIC("DR")'="":";",1:"")_$SELECT($PIECE(Z0,U,5)'="":".04////"_$PIECE(Z0,U,5),1:"")
SET DLAYGO=344.42
+9 if $ORDER(^RCY(344.4,RCRTOT,2,"B",X,0))
SET X=""""_X_""""
+10 DO FILE^DICN
KILL DIC,DO,DD
End DoDot:1
+11 QUIT
+12 ;
DUPREC(RCET,RCCT,RCSTAR,RCFILE,RCALLDUP,RCEOB,RCBILL,RCDUPEOB) ; Overflow from RCDPESR2
+1 SET ^TMP("RCERR1",$JOB,RCCT)=" "
SET ^TMP("RCERR1",$JOB,RCCT,1)=RCET_RCCT_RCSTAR
+2 SET ^TMP("RCERR1",$JOB,RCCT,2)="(Warning): EEOB detail already filed for "_RCBILL_" - "_$SELECT(RCALLDUP:"Duplicate not stored",1:"EEOB updated")
SET ^TMP("RCERR1",$JOB,RCCT,3)=" "
if RCFILE=5
SET ^TMP("RCERR1",$JOB,RCCT,"*")=^TMP("RCERR1",$JOB,RCCT,2)
+3 IF RCALLDUP
SET RCEOB=""
SET RCDUPEOB=-1
QUIT
+4 SET $PIECE(^TMP($JOB,"RCDPEOB",RCCT,"EOB"),U)=RCEOB
+5 QUIT
+6 ;
