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.
  1. RCDPEU2 ;AITC/CJE - ELECTRONIC PAYER UTILITIES ;05-NOV-02
  1. ;;4.5;Accounts Receivable;**326,332,409,436**;Mar 20, 1995;Build 3
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. Q
  1. ;
  1. ;PRCA*4.5*409 Added AREVTYPE as an optional parameter
  1. EFT344(PROMPT,IEN344,AREVTYPE) ; Select and EFT and update reciept - EP
  1. ; Input: PROMPT - Prompt to use when picking an EFT
  1. ; IEN344 - Internal entry number to file 344
  1. ; AREVTYPE - AR Event Type IEN (344.1) optional, defaults to null
  1. ; Output
  1. N FDA,IEN34431,SCREEN
  1. S:'$D(AREVTYPE) AREVTYPE="" ;PRCA*4.5*409 Added line
  1. S SCREEN="I '$O(^RCY(344,""AEFT"",+Y,0)),$P($G(^RCY(344.31,+Y,0)),U,8)=0"
  1. ;
  1. ;PRCA*4.5*436 Begin
  1. I AREVTYPE=18 D
  1. . S SCREEN=SCREEN_",$E($P($G(^RCY(344.31,+Y,0)),U,4),1,3)=""OGC"""
  1. I AREVTYPE=14 D
  1. . S SCREEN=SCREEN_",$E($P($G(^RCY(344.31,+Y,0)),U,4),1,3)'=""OGC"""
  1. ;PRCA*4.5*436 End
  1. ;
  1. S IEN34431=$$ASKEFT(PROMPT,SCREEN)
  1. I IEN34431>0,IEN344 D ;
  1. . S FDA(344,IEN344_",",.17)=IEN34431
  1. . D FILE^DIE("","FDA")
  1. . I '$D(^TMP("DIERR",$J)) K DIC("W")
  1. . W !!,IEN34431,!!
  1. Q
  1. 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.
  1. ; SCREEN - Screen for use in file 344.31 look-up
  1. ; AREVTYPE - AR Event Type IEN (344.1) optional, defaults to null
  1. ; Returns: IEN from file 344.31 or -1 if user times out or '^'
  1. ;
  1. N COUNT,DA,DIC,DIR,DIRUT,DIROUT,DTOUT,DUOUT,FIELDS,FILE,FLAGS,IENS,INDEXES,QUIT,RETURN,VALUE,X,Y
  1. K ^TMP("DILIST",$J),^TMP("DIERR",$J)
  1. S (RETURN,QUIT)=0
  1. S FILE=344.31,IENS=""
  1. S FIELDS=".01;.02;.03;.04;.07;.14"
  1. S FLAGS="M"
  1. S INDEXES=""
  1. F D Q:QUIT ;
  1. . W !,PROMPT R VALUE:DT
  1. . I '$T S QUIT=1,RETURN=-1 Q ; Timeout
  1. . I VALUE="" S QUIT=1,RETURN=0 Q
  1. . I $E(VALUE)="^"!(VALUE="") S QUIT=1,RETURN=-1 Q
  1. . I $E(VALUE)="?" S VALUE=""
  1. . I VALUE="" D ;
  1. . . D LIST^DIC(FILE,"",FIELDS,FLAGS,"*","","","B",SCREEN,"","","")
  1. . E D ;
  1. . . D FIND^DIC(FILE,"",FIELDS,FLAGS,VALUE,"","",SCREEN,"","","")
  1. . S COUNT=$P($G(^TMP("DILIST",$J,0)),"^",1)
  1. . I COUNT=1,VALUE'="" D Q ;
  1. . . S RETURN=+$P($G(^TMP("DILIST",$J,2,1)),"^",1),QUIT=1
  1. . I COUNT>0 D ;
  1. . . S RETURN=$$PICKEFT()
  1. . . I RETURN>0 S QUIT=1
  1. Q RETURN
  1. ;
  1. PICKEFT() ; Given output from FIND^DIC, pick an EFT from the list
  1. ; Input: ^TMP("DILIST",$J) in non-packed format
  1. ; Returns: IEN from file 344.31, or 0 if user does not pick an item from the list
  1. ;
  1. N CNT,COUNT,QUIT,RETURN
  1. S COUNT=$P($G(^TMP("DILIST",$J,0)),"^",1)
  1. S (RETURN,QUIT)=0
  1. F CNT=1:1:COUNT D Q:QUIT ;
  1. . D WRITE(CNT)
  1. . I CNT#10=0!(CNT=COUNT) D Q:QUIT ;
  1. . . S RETURN=$$READ(CNT) I RETURN=-1!(RETURN>0) S QUIT=1
  1. Q RETURN
  1. ;
  1. READ(LAST) ;
  1. ; Input: LAST - The last number displayed that can be picked in the number range 1-LAST
  1. ; Returns: IEN from 344.31 if one is picked, otherwise -1 (^ or timeout) or 0 - nothing picked
  1. N DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,QUIT,RETURN,VALUE,X,Y
  1. S RETURN=0
  1. S DIR(0)="NO^1:"_LAST
  1. D ^DIR
  1. I $D(DTOUT)!($D(DUOUT)) Q -1
  1. I Y,$D(^TMP("DILIST",$J,2,Y)) S RETURN=^TMP("DILIST",$J,2,Y)
  1. Q RETURN
  1. WRITE(X) ; Write out one entry from 344.31
  1. ; Input: X=Counter from ^TMP("DILIST",$J) output from FIND^DIC
  1. ; Output: To screen
  1. N DEPDAT,DEPNO,EFTID,EFTIEN,EFTTR,PAYAMT,PAYNAM,PAYTR,SP,TIN
  1. S SP=$J("",3)
  1. S EFTIEN=$P(^TMP("DILIST",$J,1,X),".")
  1. S EFTID=^TMP("DILIST",$J,"ID",X,.01)
  1. S PAYNAM=^TMP("DILIST",$J,"ID",X,.02)
  1. S TIN=^TMP("DILIST",$J,"ID",X,.03)
  1. S PAYTR=^TMP("DILIST",$J,"ID",X,.04)
  1. S PAYAMT=^TMP("DILIST",$J,"ID",X,.07)
  1. S DEPNO=$$GET1^DIQ(344.3,EFTIEN,.03,"E")
  1. S DEPDAT=$$FMTE^XLFDT($$GET1^DIQ(344.3,EFTIEN,.07,"I"),"2DZ")
  1. ; EFT DETAIL lookup
  1. S PAYNAM=$E(PAYNAM,1,62-$L(TIN))_"/"_TIN I PAYNAM="/" S PAYNAM=""
  1. W !,$J(X,4),?7,EFTID,?16," ",PAYNAM
  1. W !,?16," ",PAYTR,?48," ",$J(PAYAMT,10)
  1. W ?59," ",DEPNO,?71," ",DEPDAT
  1. Q
  1. ;
  1. ; PRCA*4.5*332 - Start modified code block
  1. CHKEOB(RCRECTDA,RCTRANDA,RCARRAY) ; EP from RCDPLPL3/4- Link payment to account, move/copy remove EOBs
  1. ; Inputs RCRECTDA - Receipt IEN file 344
  1. ; RCTRANDA - Payment multiple 344.01 IEN under RCRECTDA
  1. ; RCARRAY - If linking to multiple claims this array contains the list of claims
  1. ; A1^A2^A3^A4 where A1=Account Linked to, A2=Amount, A3=Comment, A4=Account Name
  1. ; Outputs None
  1. N CCLAIM,CLAIM,IEN344491,IEN3611,IFN,JUST,JUST1,LCLAIM,NCLAIM,NCLAIMS,OIFN,ORIG,QUIT
  1. N RCERA,RCLSUSP,RCORIG,RCOSEQ,RCSEQ,RCLORIG,RCSORIG,SCLAIM,X
  1. ;
  1. S RCERA=$$GET1^DIQ(344,RCRECTDA_",",.18,"I")
  1. S RCSEQ=$$GET1^DIQ(344.01,RCTRANDA_","_RCRECTDA_",",.27,"I")
  1. S RCOSEQ=$$GET1^DIQ(344.491,RCSEQ_","_RCERA_",",.01,"E")\1
  1. I 'RCOSEQ Q ; No scratch pad entry for this payment, can not proceed.
  1. S IEN3611=$$ORIG(RCERA,RCOSEQ)
  1. I 'IEN3611 Q ; Can not identify original EOB, can not proceed
  1. S ORIG=$$GET1^DIQ(361.1,IEN3611_",",.01,"E") ; Original Claim#
  1. S OIFN=$$GET1^DIQ(361.1,IEN3611_",",.01,"I") ; Original Bill IEN 399
  1. ;
  1. S (RCSORIG,RCLORIG,RCLSUSP)=0
  1. ; Check the scratch pad. Get claims used in initial split/edit.
  1. ; Store claims other than original in SCLAIM array.
  1. ; If part payment was left on original claim set RCSORIG=1
  1. S X=RCOSEQ
  1. F S X=$O(^RCY(344.49,RCERA,1,"B",X)) Q:((X\1)'=RCOSEQ) D ;
  1. . S IEN344491=""
  1. . F S IEN344491=$O(^RCY(344.49,RCERA,1,"B",X,IEN344491)) Q:'IEN344491 D ;
  1. . . I +$$GET1^DIQ(344.491,IEN344491_","_RCERA_",",.03)=0 Q ; Ignore lines with zero value
  1. . . S CLAIM=$$GET1^DIQ(344.491,IEN344491_","_RCERA_",",.02,"E")
  1. . . I CLAIM=ORIG D ;
  1. . . . S RCSORIG=1
  1. . . E D ;
  1. . . . S IFN=$$GET1^DIQ(344.491,IEN344491_","_RCERA_",",.07,"I")
  1. . . . I IFN S SCLAIM(IFN)=IFN
  1. ;
  1. ; Check link payment details. Get claims we are linking to now.
  1. ; Store claims other than original in LCLAIM array.
  1. ; If part payment was left on original claim set RCLORIG=1
  1. S (NCLAIM,NCLAIMS)=""
  1. I '$D(RCARRAY) D
  1. . S NCLAIM=$$GET1^DIQ(344.01,RCTRANDA_","_RCRECTDA_",",.03,"E")
  1. . I NCLAIM["-" S NCLAIM=$P(NCLAIM,"-",2)
  1. . I NCLAIM=ORIG S RCLORIG=1 Q
  1. . ; Money is going on a new claim.
  1. . S IFN=$O(^DGCR(399,"B",NCLAIM,""))
  1. . I IFN S LCLAIM(IFN)=IFN
  1. E D
  1. . S X=0
  1. . F S X=$O(RCARRAY(X)) Q:'X D
  1. . . ; Check if some money is going back to the original claim or remains in suspense.
  1. . . I $P(RCARRAY(X),"^",2)'=0 D ;
  1. . . . I $P(RCARRAY(X),"^",1)="" S RCLSUSP=1 Q ; Some money going back to suspense
  1. . . . S CLAIM=$P(RCARRAY(X),"^",4)
  1. . . . I CLAIM=ORIG S RCLORIG=1 Q ; Money going back to original claim
  1. . . . I NCLAIMS'="" S NCLAIMS=NCLAIMS_","
  1. . . . S NCLAIMS=NCLAIMS_CLAIM
  1. . . . S IFN=$O(^DGCR(399,"B",CLAIM,""))
  1. . . . I IFN S LCLAIM(IFN)=IFN
  1. ;
  1. ; Do we need to move the EOB or copy it to new claims
  1. ; We will move the EOB, if the whole payment was put in suspense then linked to a single new claim
  1. I '$D(SCLAIM),'$D(RCARRAY),'RCLORIG,'RCSORIG D Q ;
  1. . K CLAIM
  1. . S IFN=$O(^DGCR(399,"B",NCLAIM,""))
  1. . I IFN D ;
  1. . . S CLAIM(1)=IFN
  1. . . ; Change claim number on original EOB attached to ERA
  1. . . D AUTOMOVE^RCDPEM5(IEN3611,.CLAIM,"L")
  1. ;
  1. ; We will copy the EOB if money put into suspense is linked to multiple claims.
  1. ; *Or* if some money went to other claims in the original split.
  1. I $D(SCLAIM)!(RCSORIG)!($D(RCARRAY)) D ;
  1. . K CLAIM
  1. . I '$D(RCARRAY),'RCLORIG D ;
  1. . . S IFN=$O(^DGCR(399,"B",NCLAIM,""))
  1. . . I '$D(SCLAIM(IFN)) S CLAIM(IFN)=IFN ; Link to single claim not in the original split
  1. . I $D(RCARRAY) D ;
  1. . . S X="" F S X=$O(LCLAIM(X)) Q:'X D ;
  1. . . . I '$D(SCLAIM(X)) S CLAIM(X)=X ; Link to a claim that was not included in original split
  1. . I $D(CLAIM) D ; Copy EOB to CLAIM(s)
  1. . . ; Copy EOB to new EOBs for "to" claims
  1. . . D AUTOCOPY^RCDPEM5(IEN3611,.CLAIM,"L")
  1. ;
  1. ; Remove the original EOB if no money left in suspense, or split or linked to original claim
  1. I 'RCSORIG,'RCLORIG,'RCLSUSP D ;
  1. . S JUST="EEOB removed when payment from suspense was linked to claim(s) "_NCLAIMS
  1. . D AUTOREM^RCDPEM5(IEN3611,JUST)
  1. ;
  1. Q
  1. ;
  1. ORIG(RCERA,RCOSEQ) ; Get the original claim from the EOB worklist
  1. ; Inputs RCERA - ERA IEN from file 344.49
  1. ; RCOSEQ - Sequence number IEN from multiple 344.491
  1. ; Returns IEN from 361.1. EOB from 344.41
  1. N EEOBS,IEN491
  1. S IEN491=$O(^RCY(344.49,RCERA,1,"ASEQ",RCOSEQ,0))
  1. I IEN491="" Q "" ; Can't find referenced sequence number.
  1. S EEOBS=$$GET1^DIQ(344.491,IEN491_","_RCERA_",",.09,"E")
  1. I EEOBS["ADJ"!(EEOBS[",") Q "" ; Don't proceed if this is not a split line.
  1. Q $$GET1^DIQ(344.41,(+EEOBS)_","_RCERA_",",.02,"I")
  1. ; PRCA*4.5*332 - End modified code block