RCDPEU2 ;AITC/CJE - ELECTRONIC PAYER UTILITIES ;05-NOV-02
;;4.5;Accounts Receivable;**326,332,409,436**;Mar 20, 1995;Build 3
;;Per VA Directive 6402, this routine should not be modified.
Q
;
;PRCA*4.5*409 Added AREVTYPE as an optional parameter
EFT344(PROMPT,IEN344,AREVTYPE) ; Select and EFT and update reciept - EP
; Input: PROMPT - Prompt to use when picking an EFT
; IEN344 - Internal entry number to file 344
; AREVTYPE - AR Event Type IEN (344.1) optional, defaults to null
; Output
N FDA,IEN34431,SCREEN
S:'$D(AREVTYPE) AREVTYPE="" ;PRCA*4.5*409 Added line
S SCREEN="I '$O(^RCY(344,""AEFT"",+Y,0)),$P($G(^RCY(344.31,+Y,0)),U,8)=0"
;
;PRCA*4.5*436 Begin
I AREVTYPE=18 D
. S SCREEN=SCREEN_",$E($P($G(^RCY(344.31,+Y,0)),U,4),1,3)=""OGC"""
I AREVTYPE=14 D
. S SCREEN=SCREEN_",$E($P($G(^RCY(344.31,+Y,0)),U,4),1,3)'=""OGC"""
;PRCA*4.5*436 End
;
S IEN34431=$$ASKEFT(PROMPT,SCREEN)
I IEN34431>0,IEN344 D ;
. S FDA(344,IEN344_",",.17)=IEN34431
. D FILE^DIE("","FDA")
. I '$D(^TMP("DIERR",$J)) K DIC("W")
. W !!,IEN34431,!!
Q
ASKEFT(PROMPT,SCREEN,AREVTYPE) ; Select an EFT for an EDI Lockbox receipt - EP
; Input: PROMPT - Prompt to use when asking user to enter an EFT.
; SCREEN - Screen for use in file 344.31 look-up
; AREVTYPE - AR Event Type IEN (344.1) optional, defaults to null
; Returns: IEN from file 344.31 or -1 if user times out or '^'
;
N COUNT,DA,DIC,DIR,DIRUT,DIROUT,DTOUT,DUOUT,FIELDS,FILE,FLAGS,IENS,INDEXES,QUIT,RETURN,VALUE,X,Y
K ^TMP("DILIST",$J),^TMP("DIERR",$J)
S (RETURN,QUIT)=0
S FILE=344.31,IENS=""
S FIELDS=".01;.02;.03;.04;.07;.14"
S FLAGS="M"
S INDEXES=""
F D Q:QUIT ;
. W !,PROMPT R VALUE:DT
. I '$T S QUIT=1,RETURN=-1 Q ; Timeout
. I VALUE="" S QUIT=1,RETURN=0 Q
. I $E(VALUE)="^"!(VALUE="") S QUIT=1,RETURN=-1 Q
. I $E(VALUE)="?" S VALUE=""
. I VALUE="" D ;
. . D LIST^DIC(FILE,"",FIELDS,FLAGS,"*","","","B",SCREEN,"","","")
. E D ;
. . D FIND^DIC(FILE,"",FIELDS,FLAGS,VALUE,"","",SCREEN,"","","")
. S COUNT=$P($G(^TMP("DILIST",$J,0)),"^",1)
. I COUNT=1,VALUE'="" D Q ;
. . S RETURN=+$P($G(^TMP("DILIST",$J,2,1)),"^",1),QUIT=1
. I COUNT>0 D ;
. . S RETURN=$$PICKEFT()
. . I RETURN>0 S QUIT=1
Q RETURN
;
PICKEFT() ; Given output from FIND^DIC, pick an EFT from the list
; Input: ^TMP("DILIST",$J) in non-packed format
; Returns: IEN from file 344.31, or 0 if user does not pick an item from the list
;
N CNT,COUNT,QUIT,RETURN
S COUNT=$P($G(^TMP("DILIST",$J,0)),"^",1)
S (RETURN,QUIT)=0
F CNT=1:1:COUNT D Q:QUIT ;
. D WRITE(CNT)
. I CNT#10=0!(CNT=COUNT) D Q:QUIT ;
. . S RETURN=$$READ(CNT) I RETURN=-1!(RETURN>0) S QUIT=1
Q RETURN
;
READ(LAST) ;
; Input: LAST - The last number displayed that can be picked in the number range 1-LAST
; Returns: IEN from 344.31 if one is picked, otherwise -1 (^ or timeout) or 0 - nothing picked
N DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,QUIT,RETURN,VALUE,X,Y
S RETURN=0
S DIR(0)="NO^1:"_LAST
D ^DIR
I $D(DTOUT)!($D(DUOUT)) Q -1
I Y,$D(^TMP("DILIST",$J,2,Y)) S RETURN=^TMP("DILIST",$J,2,Y)
Q RETURN
WRITE(X) ; Write out one entry from 344.31
; Input: X=Counter from ^TMP("DILIST",$J) output from FIND^DIC
; Output: To screen
N DEPDAT,DEPNO,EFTID,EFTIEN,EFTTR,PAYAMT,PAYNAM,PAYTR,SP,TIN
S SP=$J("",3)
S EFTIEN=$P(^TMP("DILIST",$J,1,X),".")
S EFTID=^TMP("DILIST",$J,"ID",X,.01)
S PAYNAM=^TMP("DILIST",$J,"ID",X,.02)
S TIN=^TMP("DILIST",$J,"ID",X,.03)
S PAYTR=^TMP("DILIST",$J,"ID",X,.04)
S PAYAMT=^TMP("DILIST",$J,"ID",X,.07)
S DEPNO=$$GET1^DIQ(344.3,EFTIEN,.03,"E")
S DEPDAT=$$FMTE^XLFDT($$GET1^DIQ(344.3,EFTIEN,.07,"I"),"2DZ")
; EFT DETAIL lookup
S PAYNAM=$E(PAYNAM,1,62-$L(TIN))_"/"_TIN I PAYNAM="/" S PAYNAM=""
W !,$J(X,4),?7,EFTID,?16," ",PAYNAM
W !,?16," ",PAYTR,?48," ",$J(PAYAMT,10)
W ?59," ",DEPNO,?71," ",DEPDAT
Q
;
; PRCA*4.5*332 - Start modified code block
CHKEOB(RCRECTDA,RCTRANDA,RCARRAY) ; EP from RCDPLPL3/4- Link payment to account, move/copy remove EOBs
; Inputs RCRECTDA - Receipt IEN file 344
; RCTRANDA - Payment multiple 344.01 IEN under RCRECTDA
; RCARRAY - If linking to multiple claims this array contains the list of claims
; A1^A2^A3^A4 where A1=Account Linked to, A2=Amount, A3=Comment, A4=Account Name
; Outputs None
N CCLAIM,CLAIM,IEN344491,IEN3611,IFN,JUST,JUST1,LCLAIM,NCLAIM,NCLAIMS,OIFN,ORIG,QUIT
N RCERA,RCLSUSP,RCORIG,RCOSEQ,RCSEQ,RCLORIG,RCSORIG,SCLAIM,X
;
S RCERA=$$GET1^DIQ(344,RCRECTDA_",",.18,"I")
S RCSEQ=$$GET1^DIQ(344.01,RCTRANDA_","_RCRECTDA_",",.27,"I")
S RCOSEQ=$$GET1^DIQ(344.491,RCSEQ_","_RCERA_",",.01,"E")\1
I 'RCOSEQ Q ; No scratch pad entry for this payment, can not proceed.
S IEN3611=$$ORIG(RCERA,RCOSEQ)
I 'IEN3611 Q ; Can not identify original EOB, can not proceed
S ORIG=$$GET1^DIQ(361.1,IEN3611_",",.01,"E") ; Original Claim#
S OIFN=$$GET1^DIQ(361.1,IEN3611_",",.01,"I") ; Original Bill IEN 399
;
S (RCSORIG,RCLORIG,RCLSUSP)=0
; Check the scratch pad. Get claims used in initial split/edit.
; Store claims other than original in SCLAIM array.
; If part payment was left on original claim set RCSORIG=1
S X=RCOSEQ
F S X=$O(^RCY(344.49,RCERA,1,"B",X)) Q:((X\1)'=RCOSEQ) D ;
. S IEN344491=""
. F S IEN344491=$O(^RCY(344.49,RCERA,1,"B",X,IEN344491)) Q:'IEN344491 D ;
. . I +$$GET1^DIQ(344.491,IEN344491_","_RCERA_",",.03)=0 Q ; Ignore lines with zero value
. . S CLAIM=$$GET1^DIQ(344.491,IEN344491_","_RCERA_",",.02,"E")
. . I CLAIM=ORIG D ;
. . . S RCSORIG=1
. . E D ;
. . . S IFN=$$GET1^DIQ(344.491,IEN344491_","_RCERA_",",.07,"I")
. . . I IFN S SCLAIM(IFN)=IFN
;
; Check link payment details. Get claims we are linking to now.
; Store claims other than original in LCLAIM array.
; If part payment was left on original claim set RCLORIG=1
S (NCLAIM,NCLAIMS)=""
I '$D(RCARRAY) D
. S NCLAIM=$$GET1^DIQ(344.01,RCTRANDA_","_RCRECTDA_",",.03,"E")
. I NCLAIM["-" S NCLAIM=$P(NCLAIM,"-",2)
. I NCLAIM=ORIG S RCLORIG=1 Q
. ; Money is going on a new claim.
. S IFN=$O(^DGCR(399,"B",NCLAIM,""))
. I IFN S LCLAIM(IFN)=IFN
E D
. S X=0
. F S X=$O(RCARRAY(X)) Q:'X D
. . ; Check if some money is going back to the original claim or remains in suspense.
. . I $P(RCARRAY(X),"^",2)'=0 D ;
. . . I $P(RCARRAY(X),"^",1)="" S RCLSUSP=1 Q ; Some money going back to suspense
. . . S CLAIM=$P(RCARRAY(X),"^",4)
. . . I CLAIM=ORIG S RCLORIG=1 Q ; Money going back to original claim
. . . I NCLAIMS'="" S NCLAIMS=NCLAIMS_","
. . . S NCLAIMS=NCLAIMS_CLAIM
. . . S IFN=$O(^DGCR(399,"B",CLAIM,""))
. . . I IFN S LCLAIM(IFN)=IFN
;
; Do we need to move the EOB or copy it to new claims
; We will move the EOB, if the whole payment was put in suspense then linked to a single new claim
I '$D(SCLAIM),'$D(RCARRAY),'RCLORIG,'RCSORIG D Q ;
. K CLAIM
. S IFN=$O(^DGCR(399,"B",NCLAIM,""))
. I IFN D ;
. . S CLAIM(1)=IFN
. . ; Change claim number on original EOB attached to ERA
. . D AUTOMOVE^RCDPEM5(IEN3611,.CLAIM,"L")
;
; We will copy the EOB if money put into suspense is linked to multiple claims.
; *Or* if some money went to other claims in the original split.
I $D(SCLAIM)!(RCSORIG)!($D(RCARRAY)) D ;
. K CLAIM
. I '$D(RCARRAY),'RCLORIG D ;
. . S IFN=$O(^DGCR(399,"B",NCLAIM,""))
. . I '$D(SCLAIM(IFN)) S CLAIM(IFN)=IFN ; Link to single claim not in the original split
. I $D(RCARRAY) D ;
. . S X="" F S X=$O(LCLAIM(X)) Q:'X D ;
. . . I '$D(SCLAIM(X)) S CLAIM(X)=X ; Link to a claim that was not included in original split
. I $D(CLAIM) D ; Copy EOB to CLAIM(s)
. . ; Copy EOB to new EOBs for "to" claims
. . D AUTOCOPY^RCDPEM5(IEN3611,.CLAIM,"L")
;
; Remove the original EOB if no money left in suspense, or split or linked to original claim
I 'RCSORIG,'RCLORIG,'RCLSUSP D ;
. S JUST="EEOB removed when payment from suspense was linked to claim(s) "_NCLAIMS
. D AUTOREM^RCDPEM5(IEN3611,JUST)
;
Q
;
ORIG(RCERA,RCOSEQ) ; Get the original claim from the EOB worklist
; Inputs RCERA - ERA IEN from file 344.49
; RCOSEQ - Sequence number IEN from multiple 344.491
; Returns IEN from 361.1. EOB from 344.41
N EEOBS,IEN491
S IEN491=$O(^RCY(344.49,RCERA,1,"ASEQ",RCOSEQ,0))
I IEN491="" Q "" ; Can't find referenced sequence number.
S EEOBS=$$GET1^DIQ(344.491,IEN491_","_RCERA_",",.09,"E")
I EEOBS["ADJ"!(EEOBS[",") Q "" ; Don't proceed if this is not a split line.
Q $$GET1^DIQ(344.41,(+EEOBS)_","_RCERA_",",.02,"I")
; PRCA*4.5*332 - End modified code block
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPEU2 8683 printed Oct 16, 2024@17:46:25 Page 2
RCDPEU2 ;AITC/CJE - ELECTRONIC PAYER UTILITIES ;05-NOV-02
+1 ;;4.5;Accounts Receivable;**326,332,409,436**;Mar 20, 1995;Build 3
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;PRCA*4.5*409 Added AREVTYPE as an optional parameter
EFT344(PROMPT,IEN344,AREVTYPE) ; Select and EFT and update reciept - EP
+1 ; Input: PROMPT - Prompt to use when picking an EFT
+2 ; IEN344 - Internal entry number to file 344
+3 ; AREVTYPE - AR Event Type IEN (344.1) optional, defaults to null
+4 ; Output
+5 NEW FDA,IEN34431,SCREEN
+6 ;PRCA*4.5*409 Added line
if '$DATA(AREVTYPE)
SET AREVTYPE=""
+7 SET SCREEN="I '$O(^RCY(344,""AEFT"",+Y,0)),$P($G(^RCY(344.31,+Y,0)),U,8)=0"
+8 ;
+9 ;PRCA*4.5*436 Begin
+10 IF AREVTYPE=18
Begin DoDot:1
+11 SET SCREEN=SCREEN_",$E($P($G(^RCY(344.31,+Y,0)),U,4),1,3)=""OGC"""
End DoDot:1
+12 IF AREVTYPE=14
Begin DoDot:1
+13 SET SCREEN=SCREEN_",$E($P($G(^RCY(344.31,+Y,0)),U,4),1,3)'=""OGC"""
End DoDot:1
+14 ;PRCA*4.5*436 End
+15 ;
+16 SET IEN34431=$$ASKEFT(PROMPT,SCREEN)
+17 ;
IF IEN34431>0
IF IEN344
Begin DoDot:1
+18 SET FDA(344,IEN344_",",.17)=IEN34431
+19 DO FILE^DIE("","FDA")
+20 IF '$DATA(^TMP("DIERR",$JOB))
KILL DIC("W")
+21 WRITE !!,IEN34431,!!
End DoDot:1
+22 QUIT
ASKEFT(PROMPT,SCREEN,AREVTYPE) ; Select an EFT for an EDI Lockbox receipt - EP
+1 ; Input: PROMPT - Prompt to use when asking user to enter an EFT.
+2 ; SCREEN - Screen for use in file 344.31 look-up
+3 ; AREVTYPE - AR Event Type IEN (344.1) optional, defaults to null
+4 ; Returns: IEN from file 344.31 or -1 if user times out or '^'
+5 ;
+6 NEW COUNT,DA,DIC,DIR,DIRUT,DIROUT,DTOUT,DUOUT,FIELDS,FILE,FLAGS,IENS,INDEXES,QUIT,RETURN,VALUE,X,Y
+7 KILL ^TMP("DILIST",$JOB),^TMP("DIERR",$JOB)
+8 SET (RETURN,QUIT)=0
+9 SET FILE=344.31
SET IENS=""
+10 SET FIELDS=".01;.02;.03;.04;.07;.14"
+11 SET FLAGS="M"
+12 SET INDEXES=""
+13 ;
FOR
Begin DoDot:1
+14 WRITE !,PROMPT
READ VALUE:DT
+15 ; Timeout
IF '$TEST
SET QUIT=1
SET RETURN=-1
QUIT
+16 IF VALUE=""
SET QUIT=1
SET RETURN=0
QUIT
+17 IF $EXTRACT(VALUE)="^"!(VALUE="")
SET QUIT=1
SET RETURN=-1
QUIT
+18 IF $EXTRACT(VALUE)="?"
SET VALUE=""
+19 ;
IF VALUE=""
Begin DoDot:2
+20 DO LIST^DIC(FILE,"",FIELDS,FLAGS,"*","","","B",SCREEN,"","","")
End DoDot:2
+21 ;
IF '$TEST
Begin DoDot:2
+22 DO FIND^DIC(FILE,"",FIELDS,FLAGS,VALUE,"","",SCREEN,"","","")
End DoDot:2
+23 SET COUNT=$PIECE($GET(^TMP("DILIST",$JOB,0)),"^",1)
+24 ;
IF COUNT=1
IF VALUE'=""
Begin DoDot:2
+25 SET RETURN=+$PIECE($GET(^TMP("DILIST",$JOB,2,1)),"^",1)
SET QUIT=1
End DoDot:2
QUIT
+26 ;
IF COUNT>0
Begin DoDot:2
+27 SET RETURN=$$PICKEFT()
+28 IF RETURN>0
SET QUIT=1
End DoDot:2
End DoDot:1
if QUIT
QUIT
+29 QUIT RETURN
+30 ;
PICKEFT() ; Given output from FIND^DIC, pick an EFT from the list
+1 ; Input: ^TMP("DILIST",$J) in non-packed format
+2 ; Returns: IEN from file 344.31, or 0 if user does not pick an item from the list
+3 ;
+4 NEW CNT,COUNT,QUIT,RETURN
+5 SET COUNT=$PIECE($GET(^TMP("DILIST",$JOB,0)),"^",1)
+6 SET (RETURN,QUIT)=0
+7 ;
FOR CNT=1:1:COUNT
Begin DoDot:1
+8 DO WRITE(CNT)
+9 ;
IF CNT#10=0!(CNT=COUNT)
Begin DoDot:2
+10 SET RETURN=$$READ(CNT)
IF RETURN=-1!(RETURN>0)
SET QUIT=1
End DoDot:2
if QUIT
QUIT
End DoDot:1
if QUIT
QUIT
+11 QUIT RETURN
+12 ;
READ(LAST) ;
+1 ; Input: LAST - The last number displayed that can be picked in the number range 1-LAST
+2 ; Returns: IEN from 344.31 if one is picked, otherwise -1 (^ or timeout) or 0 - nothing picked
+3 NEW DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,QUIT,RETURN,VALUE,X,Y
+4 SET RETURN=0
+5 SET DIR(0)="NO^1:"_LAST
+6 DO ^DIR
+7 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT -1
+8 IF Y
IF $DATA(^TMP("DILIST",$JOB,2,Y))
SET RETURN=^TMP("DILIST",$JOB,2,Y)
+9 QUIT RETURN
WRITE(X) ; Write out one entry from 344.31
+1 ; Input: X=Counter from ^TMP("DILIST",$J) output from FIND^DIC
+2 ; Output: To screen
+3 NEW DEPDAT,DEPNO,EFTID,EFTIEN,EFTTR,PAYAMT,PAYNAM,PAYTR,SP,TIN
+4 SET SP=$JUSTIFY("",3)
+5 SET EFTIEN=$PIECE(^TMP("DILIST",$JOB,1,X),".")
+6 SET EFTID=^TMP("DILIST",$JOB,"ID",X,.01)
+7 SET PAYNAM=^TMP("DILIST",$JOB,"ID",X,.02)
+8 SET TIN=^TMP("DILIST",$JOB,"ID",X,.03)
+9 SET PAYTR=^TMP("DILIST",$JOB,"ID",X,.04)
+10 SET PAYAMT=^TMP("DILIST",$JOB,"ID",X,.07)
+11 SET DEPNO=$$GET1^DIQ(344.3,EFTIEN,.03,"E")
+12 SET DEPDAT=$$FMTE^XLFDT($$GET1^DIQ(344.3,EFTIEN,.07,"I"),"2DZ")
+13 ; EFT DETAIL lookup
+14 SET PAYNAM=$EXTRACT(PAYNAM,1,62-$LENGTH(TIN))_"/"_TIN
IF PAYNAM="/"
SET PAYNAM=""
+15 WRITE !,$JUSTIFY(X,4),?7,EFTID,?16," ",PAYNAM
+16 WRITE !,?16," ",PAYTR,?48," ",$JUSTIFY(PAYAMT,10)
+17 WRITE ?59," ",DEPNO,?71," ",DEPDAT
+18 QUIT
+19 ;
+20 ; PRCA*4.5*332 - Start modified code block
CHKEOB(RCRECTDA,RCTRANDA,RCARRAY) ; EP from RCDPLPL3/4- Link payment to account, move/copy remove EOBs
+1 ; Inputs RCRECTDA - Receipt IEN file 344
+2 ; RCTRANDA - Payment multiple 344.01 IEN under RCRECTDA
+3 ; RCARRAY - If linking to multiple claims this array contains the list of claims
+4 ; A1^A2^A3^A4 where A1=Account Linked to, A2=Amount, A3=Comment, A4=Account Name
+5 ; Outputs None
+6 NEW CCLAIM,CLAIM,IEN344491,IEN3611,IFN,JUST,JUST1,LCLAIM,NCLAIM,NCLAIMS,OIFN,ORIG,QUIT
+7 NEW RCERA,RCLSUSP,RCORIG,RCOSEQ,RCSEQ,RCLORIG,RCSORIG,SCLAIM,X
+8 ;
+9 SET RCERA=$$GET1^DIQ(344,RCRECTDA_",",.18,"I")
+10 SET RCSEQ=$$GET1^DIQ(344.01,RCTRANDA_","_RCRECTDA_",",.27,"I")
+11 SET RCOSEQ=$$GET1^DIQ(344.491,RCSEQ_","_RCERA_",",.01,"E")\1
+12 ; No scratch pad entry for this payment, can not proceed.
IF 'RCOSEQ
QUIT
+13 SET IEN3611=$$ORIG(RCERA,RCOSEQ)
+14 ; Can not identify original EOB, can not proceed
IF 'IEN3611
QUIT
+15 ; Original Claim#
SET ORIG=$$GET1^DIQ(361.1,IEN3611_",",.01,"E")
+16 ; Original Bill IEN 399
SET OIFN=$$GET1^DIQ(361.1,IEN3611_",",.01,"I")
+17 ;
+18 SET (RCSORIG,RCLORIG,RCLSUSP)=0
+19 ; Check the scratch pad. Get claims used in initial split/edit.
+20 ; Store claims other than original in SCLAIM array.
+21 ; If part payment was left on original claim set RCSORIG=1
+22 SET X=RCOSEQ
+23 ;
FOR
SET X=$ORDER(^RCY(344.49,RCERA,1,"B",X))
if ((X\1)'=RCOSEQ)
QUIT
Begin DoDot:1
+24 SET IEN344491=""
+25 ;
FOR
SET IEN344491=$ORDER(^RCY(344.49,RCERA,1,"B",X,IEN344491))
if 'IEN344491
QUIT
Begin DoDot:2
+26 ; Ignore lines with zero value
IF +$$GET1^DIQ(344.491,IEN344491_","_RCERA_",",.03)=0
QUIT
+27 SET CLAIM=$$GET1^DIQ(344.491,IEN344491_","_RCERA_",",.02,"E")
+28 ;
IF CLAIM=ORIG
Begin DoDot:3
+29 SET RCSORIG=1
End DoDot:3
+30 ;
IF '$TEST
Begin DoDot:3
+31 SET IFN=$$GET1^DIQ(344.491,IEN344491_","_RCERA_",",.07,"I")
+32 IF IFN
SET SCLAIM(IFN)=IFN
End DoDot:3
End DoDot:2
End DoDot:1
+33 ;
+34 ; Check link payment details. Get claims we are linking to now.
+35 ; Store claims other than original in LCLAIM array.
+36 ; If part payment was left on original claim set RCLORIG=1
+37 SET (NCLAIM,NCLAIMS)=""
+38 IF '$DATA(RCARRAY)
Begin DoDot:1
+39 SET NCLAIM=$$GET1^DIQ(344.01,RCTRANDA_","_RCRECTDA_",",.03,"E")
+40 IF NCLAIM["-"
SET NCLAIM=$PIECE(NCLAIM,"-",2)
+41 IF NCLAIM=ORIG
SET RCLORIG=1
QUIT
+42 ; Money is going on a new claim.
+43 SET IFN=$ORDER(^DGCR(399,"B",NCLAIM,""))
+44 IF IFN
SET LCLAIM(IFN)=IFN
End DoDot:1
+45 IF '$TEST
Begin DoDot:1
+46 SET X=0
+47 FOR
SET X=$ORDER(RCARRAY(X))
if 'X
QUIT
Begin DoDot:2
+48 ; Check if some money is going back to the original claim or remains in suspense.
+49 ;
IF $PIECE(RCARRAY(X),"^",2)'=0
Begin DoDot:3
+50 ; Some money going back to suspense
IF $PIECE(RCARRAY(X),"^",1)=""
SET RCLSUSP=1
QUIT
+51 SET CLAIM=$PIECE(RCARRAY(X),"^",4)
+52 ; Money going back to original claim
IF CLAIM=ORIG
SET RCLORIG=1
QUIT
+53 IF NCLAIMS'=""
SET NCLAIMS=NCLAIMS_","
+54 SET NCLAIMS=NCLAIMS_CLAIM
+55 SET IFN=$ORDER(^DGCR(399,"B",CLAIM,""))
+56 IF IFN
SET LCLAIM(IFN)=IFN
End DoDot:3
End DoDot:2
End DoDot:1
+57 ;
+58 ; Do we need to move the EOB or copy it to new claims
+59 ; We will move the EOB, if the whole payment was put in suspense then linked to a single new claim
+60 ;
IF '$DATA(SCLAIM)
IF '$DATA(RCARRAY)
IF 'RCLORIG
IF 'RCSORIG
Begin DoDot:1
+61 KILL CLAIM
+62 SET IFN=$ORDER(^DGCR(399,"B",NCLAIM,""))
+63 ;
IF IFN
Begin DoDot:2
+64 SET CLAIM(1)=IFN
+65 ; Change claim number on original EOB attached to ERA
+66 DO AUTOMOVE^RCDPEM5(IEN3611,.CLAIM,"L")
End DoDot:2
End DoDot:1
QUIT
+67 ;
+68 ; We will copy the EOB if money put into suspense is linked to multiple claims.
+69 ; *Or* if some money went to other claims in the original split.
+70 ;
IF $DATA(SCLAIM)!(RCSORIG)!($DATA(RCARRAY))
Begin DoDot:1
+71 KILL CLAIM
+72 ;
IF '$DATA(RCARRAY)
IF 'RCLORIG
Begin DoDot:2
+73 SET IFN=$ORDER(^DGCR(399,"B",NCLAIM,""))
+74 ; Link to single claim not in the original split
IF '$DATA(SCLAIM(IFN))
SET CLAIM(IFN)=IFN
End DoDot:2
+75 ;
IF $DATA(RCARRAY)
Begin DoDot:2
+76 ;
SET X=""
FOR
SET X=$ORDER(LCLAIM(X))
if 'X
QUIT
Begin DoDot:3
+77 ; Link to a claim that was not included in original split
IF '$DATA(SCLAIM(X))
SET CLAIM(X)=X
End DoDot:3
End DoDot:2
+78 ; Copy EOB to CLAIM(s)
IF $DATA(CLAIM)
Begin DoDot:2
+79 ; Copy EOB to new EOBs for "to" claims
+80 DO AUTOCOPY^RCDPEM5(IEN3611,.CLAIM,"L")
End DoDot:2
End DoDot:1
+81 ;
+82 ; Remove the original EOB if no money left in suspense, or split or linked to original claim
+83 ;
IF 'RCSORIG
IF 'RCLORIG
IF 'RCLSUSP
Begin DoDot:1
+84 SET JUST="EEOB removed when payment from suspense was linked to claim(s) "_NCLAIMS
+85 DO AUTOREM^RCDPEM5(IEN3611,JUST)
End DoDot:1
+86 ;
+87 QUIT
+88 ;
ORIG(RCERA,RCOSEQ) ; Get the original claim from the EOB worklist
+1 ; Inputs RCERA - ERA IEN from file 344.49
+2 ; RCOSEQ - Sequence number IEN from multiple 344.491
+3 ; Returns IEN from 361.1. EOB from 344.41
+4 NEW EEOBS,IEN491
+5 SET IEN491=$ORDER(^RCY(344.49,RCERA,1,"ASEQ",RCOSEQ,0))
+6 ; Can't find referenced sequence number.
IF IEN491=""
QUIT ""
+7 SET EEOBS=$$GET1^DIQ(344.491,IEN491_","_RCERA_",",.09,"E")
+8 ; Don't proceed if this is not a split line.
IF EEOBS["ADJ"!(EEOBS[",")
QUIT ""
+9 QUIT $$GET1^DIQ(344.41,(+EEOBS)_","_RCERA_",",.02,"I")
+10 ; PRCA*4.5*332 - End modified code block
