Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RCDPEU2

RCDPEU2.m

Go to the documentation of this file.
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