- 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 Feb 18, 2025@23:11:57 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