RCDPLPL1 ;WISC/RFJ/PJH - link payments listmanager options ;5/25/11 2:53pm
;;4.5;Accounts Receivable;**114,148,153,208,269,304,321**;Mar 20, 1995;Build 48
;;Per VA Directive 6402, this routine should not be modified.
Q
;
CHKTRACE ;EP Protocol action - RCDP LINK PAYMENTS SEARCH CHECK
; Ask to search by check # or trace #
N DIR,X,Y
D FULL^VALM1
S DIR("A")="SEARCH BY (C)HECK OR (T)RACE #?: "
S DIR(0)="SA^C:CHECK;T:TRACE",DIR("B")="CHECK"
W ! D ^DIR K DIR
Q:$D(DTOUT)!$D(DUOUT)
I Y="C" D Q
. D FINDCHEK
I Y="T" D Q
. D FINDTRAC
Q
;
FINDCHEK ; Find a specific check used for payments
D FULL^VALM1
S VALMBCK="R"
;
N RCCHECK,RCTYPE
K RCFCHECK,RCFCREDT,RCFTRACE
W !
S RCCHECK=$$ASKCHEK I RCCHECK=-1 D INIT^RCDPLPLM Q
;
S RCTYPE=$$ASKTYPE I RCTYPE=-1 D INIT^RCDPLPLM Q
S RCFCHECK=RCCHECK_"^"_RCTYPE
D INIT^RCDPLPLM
Q
;
FINDTRAC ; Find a specific trace # used for EFT/ERA payments
D FULL^VALM1
S VALMBCK="R"
;
N RCTRACE,RCTYPE
K RCFTRACE,RCFCREDT,RCFCHECK
W !
S RCTRACE=$$ASKTRACE I RCTRACE=-1 D INIT^RCDPLPLM Q
;
S RCTYPE=$$ASKTYPE I RCTYPE=-1 D INIT^RCDPLPLM Q
S RCFTRACE=RCTRACE_"^"_RCTYPE
D INIT^RCDPLPLM
Q
;
;
FINDCRED ;EP Protocol Action - RCDP LINK PAYMENTS SEARCH CREDIT
; Find a specific credit card used for payments
D FULL^VALM1
S VALMBCK="R"
;
N RCCREDT,RCTYPE
K RCFCHECK,RCFCREDT,RCFTRACE
W !
S RCCREDT=$$ASKCRED I RCCREDT=-1 D INIT^RCDPLPLM Q
;
S RCTYPE=$$ASKTYPE I RCTYPE=-1 D INIT^RCDPLPLM Q
S RCFCREDT=RCCREDT_"^"_RCTYPE
D INIT^RCDPLPLM
Q
;
;
ACCOUNT ;EP Protocol Action - RCDP LINK PAYMENTS ACCOUNT PROFILE
; Account profile
D FULL^VALM1
D ACCTPROF^RCDPAPLM
D INIT^RCDPLPLM
S VALMBCK="R"
; fast exit
I $G(RCDPFXIT) S VALMBCK="Q"
Q
;
;
RECEIPT ;EP Protocol Action - RCDP LINK PAYMENTS RECEIPT PROFILE
; Receipt profile
D FULL^VALM1
D RECTPROF^RCDPRPLM
D INIT^RCDPLPLM
S VALMBCK="R"
I $G(RCDPFXIT) S VALMBCK="Q"
Q
;
CLEARSUS ;EP Protocol action - RCDP LINK PAYMENTS CLEAR SUSPENSE
; Flag a payment as being cleared from suspense
D FULL^VALM1
S VALMBCK="R"
;
W !!,"This option will allow you to enter the FMS Document Number used"
W !,"to clear the payment from the suspense account in FMS. Once an"
W !,"FMS Document Number is entered, the payment will no longer appear"
W !,"on the list as Unlinked.",!
N INDEX,RCPAY,RCRECTDA,RCTRANDA
S INDEX=$$SELPAY
I INDEX D
. S RCPAY=$G(^TMP("RCDPLPLM",$J,"IDX",INDEX,INDEX))
. S RCRECTDA=+$P(RCPAY,"^"),RCTRANDA=+$P(RCPAY,"^",2)
I 'INDEX D
. W ! S RCRECTDA=+$$SELRECT^RCDPUREC(0,0) I RCRECTDA<1 Q
. S RCTRANDA=+$$SELTRAN^RCDPURET(RCRECTDA) I RCTRANDA<1 S RCTRANDA=0
I '$G(RCRECTDA)!('$G(RCTRANDA)) S VALMBCK="R" Q
;
W !!," Receipt: ",$P(^RCY(344,RCRECTDA,0),"^")
W !," Transaction: ",RCTRANDA
W !," Unapplied Deposit Number: ",$P($G(^RCY(344,RCRECTDA,1,RCTRANDA,2)),"^",5)
D EDITFMS^RCDPURET(RCRECTDA,RCTRANDA,"")
;
;PRCA*4.5*304 Force a comment and update audit Log
;ask for comment
D ADDCMT(RCRECTDA,RCTRANDA)
;
;If the CR document was filed, update the Audit Log and suspense status
I $P($G(^RCY(344,RCRECTDA,1,RCTRANDA,2)),U,6)'="" D
. D AUDIT^RCBEPAY(RCRECTDA,RCTRANDA,"R")
. D SUSPDIS^RCBEPAY(RCRECTDA,RCTRANDA,"R")
;end PRCA*4.5*304
;
S VALMBCK="R"
D INIT^RCDPLPLM
Q
;
SELPAY() ; Select a payment from the form list
N VALMBG,VALMLST
; if no payments, quit
I '$O(^TMP("RCDPLPLM",$J,"IDX",0)) S VALMSG="There are NO payments on the form to select." Q 0
;
; if only one payment, select that one automatically
I '$O(^TMP("RCDPLPLM",$J,"IDX",1)) Q 1
;
; select the entry from the list
; if not on first screen, make sure selection begins with 1
S VALMBG=1
; if not on last screen, make sure selection ends with last
S VALMLST=$O(^TMP("RCDPLPLM",$J,"IDX",999999999),-1)
D EN^VALM2($G(XQORNOD(0)),"OS")
Q $O(VALMY(0))
;
ASKCHEK() ; Ask the check number
N DIR,X,Y
S DIR(0)="FAO^1:50"
S DIR("A")="Enter the Check Number to Search for: "
S DIR("?")="Enter the check number from 1 to 50 characters free text."
D ^DIR
I $G(DTOUT)!($G(DUOUT)) S Y=-1
Q $S(Y'="":Y,1:-1)
;
ASKTRACE() ; Ask the e-payments trace number
N DIR,X,Y
S DIR(0)="FAO^1:50"
S DIR("A")="Enter the e-Payments Trace Number to Search for: "
S DIR("?")="Enter the trace number from 1 to 50 characters free text."
D ^DIR
I $G(DTOUT)!($G(DUOUT)) S Y=-1
Q $S(Y'="":Y,1:-1)
;
ASKCRED() ; Ask the credit card number
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="NAO^0:9999999999999999"
S DIR("A")="Enter the Credit Card Number to Search for: "
S DIR("?")="Enter the check card number from 1 to 16 numbers."
D ^DIR
I $G(DTOUT)!($G(DUOUT)) S Y=-1
Q $S(Y'="":Y,1:-1)
;
ASKTYPE() ; Ask the type of match
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="SAO^1:Exact Match;2:Contains;"
S DIR("A")="Type of Match: "
S DIR("B")="Contains"
D ^DIR
I $G(DTOUT)!($G(DUOUT)) S Y=-1
Q $S(Y=1:"EQUAL TO",Y=2:"CONTAINING",1:-1)
;
;PRCA*4.5*304
ADDCMT(RCRECTDA,RCTRANDA) ; Ask for a comment for the suspense entry
;
N DA,DIDEL,DIE,DIR,DIRUT,DIROUT,DR,DTOUT,DUOUT,RCDCMT,X,Y
S RCDCMT=""
F D Q:RCDCMT'=""
. S Y=$$COM^RCDPECH ; PRCA*4.5*321
. ;strip all leading and trailing spaces
. S Y=$$TRIM^XLFSTR(Y)
. I (Y="")!(Y=-1) D Q
. . W !,"A comment is required when changing the status of an item in Suspense. Please try again."
. S RCDCMT=Y
;
; Update the comment field
S DR="1.02////"_RCDCMT
S DIE="^RCY(344,"_RCRECTDA_",1,"
S DA=RCTRANDA,DA(1)=RCRECTDA
D ^DIE
D LASTEDIT^RCDPUREC(RCRECTDA)
;Update comment history - PRCA*4.5*321
D AUDIT^RCDPECH(RCRECTDA,RCTRANDA,"","")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPLPL1 5774 printed Sep 23, 2025@19:22:10 Page 2
RCDPLPL1 ;WISC/RFJ/PJH - link payments listmanager options ;5/25/11 2:53pm
+1 ;;4.5;Accounts Receivable;**114,148,153,208,269,304,321**;Mar 20, 1995;Build 48
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
CHKTRACE ;EP Protocol action - RCDP LINK PAYMENTS SEARCH CHECK
+1 ; Ask to search by check # or trace #
+2 NEW DIR,X,Y
+3 DO FULL^VALM1
+4 SET DIR("A")="SEARCH BY (C)HECK OR (T)RACE #?: "
+5 SET DIR(0)="SA^C:CHECK;T:TRACE"
SET DIR("B")="CHECK"
+6 WRITE !
DO ^DIR
KILL DIR
+7 if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+8 IF Y="C"
Begin DoDot:1
+9 DO FINDCHEK
End DoDot:1
QUIT
+10 IF Y="T"
Begin DoDot:1
+11 DO FINDTRAC
End DoDot:1
QUIT
+12 QUIT
+13 ;
FINDCHEK ; Find a specific check used for payments
+1 DO FULL^VALM1
+2 SET VALMBCK="R"
+3 ;
+4 NEW RCCHECK,RCTYPE
+5 KILL RCFCHECK,RCFCREDT,RCFTRACE
+6 WRITE !
+7 SET RCCHECK=$$ASKCHEK
IF RCCHECK=-1
DO INIT^RCDPLPLM
QUIT
+8 ;
+9 SET RCTYPE=$$ASKTYPE
IF RCTYPE=-1
DO INIT^RCDPLPLM
QUIT
+10 SET RCFCHECK=RCCHECK_"^"_RCTYPE
+11 DO INIT^RCDPLPLM
+12 QUIT
+13 ;
FINDTRAC ; Find a specific trace # used for EFT/ERA payments
+1 DO FULL^VALM1
+2 SET VALMBCK="R"
+3 ;
+4 NEW RCTRACE,RCTYPE
+5 KILL RCFTRACE,RCFCREDT,RCFCHECK
+6 WRITE !
+7 SET RCTRACE=$$ASKTRACE
IF RCTRACE=-1
DO INIT^RCDPLPLM
QUIT
+8 ;
+9 SET RCTYPE=$$ASKTYPE
IF RCTYPE=-1
DO INIT^RCDPLPLM
QUIT
+10 SET RCFTRACE=RCTRACE_"^"_RCTYPE
+11 DO INIT^RCDPLPLM
+12 QUIT
+13 ;
+14 ;
FINDCRED ;EP Protocol Action - RCDP LINK PAYMENTS SEARCH CREDIT
+1 ; Find a specific credit card used for payments
+2 DO FULL^VALM1
+3 SET VALMBCK="R"
+4 ;
+5 NEW RCCREDT,RCTYPE
+6 KILL RCFCHECK,RCFCREDT,RCFTRACE
+7 WRITE !
+8 SET RCCREDT=$$ASKCRED
IF RCCREDT=-1
DO INIT^RCDPLPLM
QUIT
+9 ;
+10 SET RCTYPE=$$ASKTYPE
IF RCTYPE=-1
DO INIT^RCDPLPLM
QUIT
+11 SET RCFCREDT=RCCREDT_"^"_RCTYPE
+12 DO INIT^RCDPLPLM
+13 QUIT
+14 ;
+15 ;
ACCOUNT ;EP Protocol Action - RCDP LINK PAYMENTS ACCOUNT PROFILE
+1 ; Account profile
+2 DO FULL^VALM1
+3 DO ACCTPROF^RCDPAPLM
+4 DO INIT^RCDPLPLM
+5 SET VALMBCK="R"
+6 ; fast exit
+7 IF $GET(RCDPFXIT)
SET VALMBCK="Q"
+8 QUIT
+9 ;
+10 ;
RECEIPT ;EP Protocol Action - RCDP LINK PAYMENTS RECEIPT PROFILE
+1 ; Receipt profile
+2 DO FULL^VALM1
+3 DO RECTPROF^RCDPRPLM
+4 DO INIT^RCDPLPLM
+5 SET VALMBCK="R"
+6 IF $GET(RCDPFXIT)
SET VALMBCK="Q"
+7 QUIT
+8 ;
CLEARSUS ;EP Protocol action - RCDP LINK PAYMENTS CLEAR SUSPENSE
+1 ; Flag a payment as being cleared from suspense
+2 DO FULL^VALM1
+3 SET VALMBCK="R"
+4 ;
+5 WRITE !!,"This option will allow you to enter the FMS Document Number used"
+6 WRITE !,"to clear the payment from the suspense account in FMS. Once an"
+7 WRITE !,"FMS Document Number is entered, the payment will no longer appear"
+8 WRITE !,"on the list as Unlinked.",!
+9 NEW INDEX,RCPAY,RCRECTDA,RCTRANDA
+10 SET INDEX=$$SELPAY
+11 IF INDEX
Begin DoDot:1
+12 SET RCPAY=$GET(^TMP("RCDPLPLM",$JOB,"IDX",INDEX,INDEX))
+13 SET RCRECTDA=+$PIECE(RCPAY,"^")
SET RCTRANDA=+$PIECE(RCPAY,"^",2)
End DoDot:1
+14 IF 'INDEX
Begin DoDot:1
+15 WRITE !
SET RCRECTDA=+$$SELRECT^RCDPUREC(0,0)
IF RCRECTDA<1
QUIT
+16 SET RCTRANDA=+$$SELTRAN^RCDPURET(RCRECTDA)
IF RCTRANDA<1
SET RCTRANDA=0
End DoDot:1
+17 IF '$GET(RCRECTDA)!('$GET(RCTRANDA))
SET VALMBCK="R"
QUIT
+18 ;
+19 WRITE !!," Receipt: ",$PIECE(^RCY(344,RCRECTDA,0),"^")
+20 WRITE !," Transaction: ",RCTRANDA
+21 WRITE !," Unapplied Deposit Number: ",$PIECE($GET(^RCY(344,RCRECTDA,1,RCTRANDA,2)),"^",5)
+22 DO EDITFMS^RCDPURET(RCRECTDA,RCTRANDA,"")
+23 ;
+24 ;PRCA*4.5*304 Force a comment and update audit Log
+25 ;ask for comment
+26 DO ADDCMT(RCRECTDA,RCTRANDA)
+27 ;
+28 ;If the CR document was filed, update the Audit Log and suspense status
+29 IF $PIECE($GET(^RCY(344,RCRECTDA,1,RCTRANDA,2)),U,6)'=""
Begin DoDot:1
+30 DO AUDIT^RCBEPAY(RCRECTDA,RCTRANDA,"R")
+31 DO SUSPDIS^RCBEPAY(RCRECTDA,RCTRANDA,"R")
End DoDot:1
+32 ;end PRCA*4.5*304
+33 ;
+34 SET VALMBCK="R"
+35 DO INIT^RCDPLPLM
+36 QUIT
+37 ;
SELPAY() ; Select a payment from the form list
+1 NEW VALMBG,VALMLST
+2 ; if no payments, quit
+3 IF '$ORDER(^TMP("RCDPLPLM",$JOB,"IDX",0))
SET VALMSG="There are NO payments on the form to select."
QUIT 0
+4 ;
+5 ; if only one payment, select that one automatically
+6 IF '$ORDER(^TMP("RCDPLPLM",$JOB,"IDX",1))
QUIT 1
+7 ;
+8 ; select the entry from the list
+9 ; if not on first screen, make sure selection begins with 1
+10 SET VALMBG=1
+11 ; if not on last screen, make sure selection ends with last
+12 SET VALMLST=$ORDER(^TMP("RCDPLPLM",$JOB,"IDX",999999999),-1)
+13 DO EN^VALM2($GET(XQORNOD(0)),"OS")
+14 QUIT $ORDER(VALMY(0))
+15 ;
ASKCHEK() ; Ask the check number
+1 NEW DIR,X,Y
+2 SET DIR(0)="FAO^1:50"
+3 SET DIR("A")="Enter the Check Number to Search for: "
+4 SET DIR("?")="Enter the check number from 1 to 50 characters free text."
+5 DO ^DIR
+6 IF $GET(DTOUT)!($GET(DUOUT))
SET Y=-1
+7 QUIT $SELECT(Y'="":Y,1:-1)
+8 ;
ASKTRACE() ; Ask the e-payments trace number
+1 NEW DIR,X,Y
+2 SET DIR(0)="FAO^1:50"
+3 SET DIR("A")="Enter the e-Payments Trace Number to Search for: "
+4 SET DIR("?")="Enter the trace number from 1 to 50 characters free text."
+5 DO ^DIR
+6 IF $GET(DTOUT)!($GET(DUOUT))
SET Y=-1
+7 QUIT $SELECT(Y'="":Y,1:-1)
+8 ;
ASKCRED() ; Ask the credit card number
+1 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="NAO^0:9999999999999999"
+3 SET DIR("A")="Enter the Credit Card Number to Search for: "
+4 SET DIR("?")="Enter the check card number from 1 to 16 numbers."
+5 DO ^DIR
+6 IF $GET(DTOUT)!($GET(DUOUT))
SET Y=-1
+7 QUIT $SELECT(Y'="":Y,1:-1)
+8 ;
ASKTYPE() ; Ask the type of match
+1 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="SAO^1:Exact Match;2:Contains;"
+3 SET DIR("A")="Type of Match: "
+4 SET DIR("B")="Contains"
+5 DO ^DIR
+6 IF $GET(DTOUT)!($GET(DUOUT))
SET Y=-1
+7 QUIT $SELECT(Y=1:"EQUAL TO",Y=2:"CONTAINING",1:-1)
+8 ;
+9 ;PRCA*4.5*304
ADDCMT(RCRECTDA,RCTRANDA) ; Ask for a comment for the suspense entry
+1 ;
+2 NEW DA,DIDEL,DIE,DIR,DIRUT,DIROUT,DR,DTOUT,DUOUT,RCDCMT,X,Y
+3 SET RCDCMT=""
+4 FOR
Begin DoDot:1
+5 ; PRCA*4.5*321
SET Y=$$COM^RCDPECH
+6 ;strip all leading and trailing spaces
+7 SET Y=$$TRIM^XLFSTR(Y)
+8 IF (Y="")!(Y=-1)
Begin DoDot:2
+9 WRITE !,"A comment is required when changing the status of an item in Suspense. Please try again."
End DoDot:2
QUIT
+10 SET RCDCMT=Y
End DoDot:1
if RCDCMT'=""
QUIT
+11 ;
+12 ; Update the comment field
+13 SET DR="1.02////"_RCDCMT
+14 SET DIE="^RCY(344,"_RCRECTDA_",1,"
+15 SET DA=RCTRANDA
SET DA(1)=RCRECTDA
+16 DO ^DIE
+17 DO LASTEDIT^RCDPUREC(RCRECTDA)
+18 ;Update comment history - PRCA*4.5*321
+19 DO AUDIT^RCDPECH(RCRECTDA,RCTRANDA,"","")
+20 QUIT
