RCDPLPLM ;WISC/RFJ - link payments listmanager top routine ;1 Jun 99
;;4.5;Accounts Receivable;**114,208,304**;Mar 20, 1995;Build 104
;;Per VA Directive 6402, this routine should not be modified.
;
N RCFCHECK,RCFTRACE,RCFCREDT,RCDPFXIT
N %,%DT,%H,%I,RCDPPADT,X,Y
S %DT("A")="Start with Payment Date (press RETURN for FIRST): ",%DT="AEP",%DT(0)=-DT
D ^%DT I Y<0,X["^" Q
; if user entered a date, go back one day
I Y'<0 S RCDPPADT=$$FMADD^XLFDT(+Y,-1)
;
D EN^VALM("RCDP LINK PAYMENTS TO ACCOUNTS")
Q
;
INIT ; initialization for list manager list
; pass RCDPPADT to display payments after RCDPPADT date
; pass RCFCHECK, RCFTRACE and RCFCREDT to search by
; check/trace #/credit card #
; fast exit
I $G(RCDPFXIT) S VALMQUIT=1 Q
;
W !!,"please wait, building list of unlinked payments..."
;
N DATE,FMSDOC,NUMBER,RCCOUNT,RCDATA,RCLINE,RCRECTDA,RCTOTAL,RCTRANDA,RECDATA,TYPE
;
; set the listmanager line number
S RCLINE=0
; set the lookup payment number from list
S RCCOUNT=0
; get list of unlinked accounts
K ^TMP("RCDPLPLM",$J)
S RCRECTDA=0 F S RCRECTDA=$O(^RCY(344,"AN",RCRECTDA)) Q:'RCRECTDA D
. S RECDATA=$G(^RCY(344,RCRECTDA,0))
. S RCTRANDA=0 F S RCTRANDA=$O(^RCY(344,"AN",RCRECTDA,RCTRANDA)) Q:'RCTRANDA D
. . S RCDATA=$G(^RCY(344,RCRECTDA,1,RCTRANDA,0))
. . I '$P(RCDATA,"^",4) Q ;no payment amount
. . ; fms doc id entered (field 26) to clear suspense
. . I $P($G(^RCY(344,RCRECTDA,1,RCTRANDA,2)),"^",6)'="" Q
. . ; unlinked
. . ; get payment date
. . S DATE=$P(RCDATA,"^",6)
. . I 'DATE S DATE=$P(RCDATA,"^",10)
. . I 'DATE S DATE=$P(RECDATA,"^",3)
. . I 'DATE S DATE=0
. . ; before selected payment date
. . I $G(RCDPPADT),DATE<RCDPPADT Q
. . ;
. . S RCLINE=RCLINE+1
. . S RCCOUNT=RCCOUNT+1
. . ;
. . ; create an index array for bill lookup in list
. . S ^TMP("RCDPLPLM",$J,"IDX",RCCOUNT,RCCOUNT)=RCRECTDA_"^"_RCTRANDA
. . ;
. . D SET(RCCOUNT,RCLINE,1,80)
. . ; receipt number
. . D SET($P(RECDATA,"^"),RCLINE,6,18)
. . ; transaction number
. . D SET($J(RCTRANDA,5),RCLINE,20,24)
. . ; unapplied deposit number
. . D SET($J($$GETUNAPP^RCXFMSCR(RCRECTDA,RCTRANDA,0),13),RCLINE,26,39)
. . ; receipt status
. . D SET($E($S($P(RECDATA,"^",14):"OPEN",1:"CLOSED"),1,4),RCLINE,41,44)
. . ; payment date
. . D SET($E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3),RCLINE,47,54)
. . ; get type of payment
. . S TYPE=$S($P(RECDATA,U,18)&$P(RECDATA,U,17):"TRACE",1:"") ;EFT/ERA payment
. . I TYPE="" D
. . . S TYPE=$P($G(^RCY(344,RCRECTDA,1,RCTRANDA,2)),"^",4)
. . . S TYPE=$S(TYPE=1:"CASH",TYPE=2:"CHECK",TYPE=3:"CREDIT",1:"")
. . I TYPE="" S TYPE=$P($G(^RC(341.1,+$P(RECDATA,"^",4),0)),"^")
. . D SET(TYPE,RCLINE,57,60)
. . ; get check, trace, credit #, RCFCHECK RCFTRACE and RCFCREDT
. . ; can be used to match a specific check, trace or credit card #
. . ; the variable is in the form:
. . ; RCFCHECK=number^EXACT or number^CONTAINS
. . I $G(RCFCHECK)'="",$E(TYPE,1,5)'="CHECK" Q
. . I $G(RCFTRACE)'="",$E(TYPE,1,5)'="TRACE" Q
. . I $G(RCFCREDT)'="",$E(TYPE,1,6)'="CREDIT" Q
. . S NUMBER=""
. . I $E(TYPE,1,5)="CHECK" D Q:NUMBER=""
. . . S NUMBER=$P(RCDATA,"^",7)
. . . I $G(RCFCHECK)'="",NUMBER="" Q
. . . I $E($P($G(RCFCHECK),"^",2))="E",NUMBER'=$P(RCFCHECK,"^") S NUMBER="" Q
. . . I $E($P($G(RCFCHECK),"^",2))="C",NUMBER'[$P(RCFCHECK,"^") S NUMBER="" Q
. . . I NUMBER="" S NUMBER=" "
. . I $E(TYPE,1,5)="TRACE" D Q:NUMBER=""
. . . S NUMBER=$P($G(^RCY(344.4,+$P(RECDATA,U,18),0)),U,2)
. . . I $G(RCFTRACE)'="",NUMBER="" Q
. . . I $E($P($G(RCFTRACE),"^",2))="E",NUMBER'=$P(RCFTRACE,"^") S NUMBER="" Q
. . . I $E($P($G(RCFTRACE),"^",2))="C",NUMBER'[$P(RCFTRACE,"^") S NUMBER="" Q
. . . I NUMBER="" S NUMBER=" "
. . I $E(TYPE,1,6)="CREDIT" D Q:NUMBER=""
. . . S NUMBER=$P(RCDATA,"^",11)
. . . I $G(RCFCHECK)'="",NUMBER="" Q
. . . I $E($P($G(RCFCREDT),"^",2))="E",NUMBER'=$P(RCFCREDT,"^") S NUMBER="" Q
. . . I $E($P($G(RCFCREDT),"^",2))="C",NUMBER'[$P(RCFCREDT,"^") S NUMBER="" Q
. . . I NUMBER="" S NUMBER=" "
. . I NUMBER="" S NUMBER=" "
. . S %=$L(NUMBER) I %>8 S NUMBER=$E(NUMBER,%-7,%)
. . ; check/trace/credit# (last 8 chars)
. . D SET(NUMBER,RCLINE,62,69)
. . ; amount paid
. . D SET($J($P(RCDATA,"^",4),10,2),RCLINE,70,80)
. . ; since list manager adds spaces to line, make sure line is
. . ; 80 characters so the print list looks okay
. . S ^TMP("RCDPLPLM",$J,RCLINE,0)=$E(^TMP("RCDPLPLM",$J,RCLINE,0),1,80)
. . S RCTOTAL=$G(RCTOTAL)+$P(RCDATA,"^",4)
. . ;
. . ; show line 2
. . ; account lookup
. . S RCLINE=RCLINE+1
. . S %=$E("AcctLU: "_$P($G(^RCY(344,RCRECTDA,1,RCTRANDA,2)),"^")_" ",1,24)
. . D SET(" "_%,RCLINE,1,80)
. . ; fms cr document
. . S FMSDOC=$$FMSSTAT^RCDPUREC(RCRECTDA)
. . D SET($E("CRdoc: "_$P(FMSDOC,"^")_" ",1,22),RCLINE,41,80)
. . ; cr document status
. . D SET($P(FMSDOC,"^",2),RCLINE,63,68)
. . ; make second line longer than 80 characters for printing
. . ; this will add an extra line after each entry
. . D SET(" ",RCLINE,80,84)
;
S RCLINE=RCLINE+1 D SET("----------",RCLINE,70,80)
S RCLINE=RCLINE+1 D SET("TOTAL: "_$J($G(RCTOTAL),10,2),RCLINE,63,80)
;
; set valmcnt to number of lines in the list
S VALMCNT=RCLINE
D HDR
Q
;
;
SET(STRING,LINE,COLBEG,COLEND) ; set array
I '$D(@VALMAR@(LINE,0)) D SET^VALM10(LINE,$J("",80))
D SET^VALM10(LINE,$$SETSTR^VALM1(STRING,@VALMAR@(LINE,0),COLBEG,COLEND-COLBEG+1))
Q
;
;
HDR ; header code for list manager display
S VALMHDR(1)="Transactions for ALL Unapplied Payments"
I $G(RCDPPADT)>0 S Y=RCDPPADT D DD^%DT S VALMHDR(1)="Transactions for Unapplied Payments After "_Y
S VALMHDR(2)=" "
I $G(RCFCHECK)'="" S VALMHDR(2)=" List of Payments With Check Numbers "_$P(RCFCHECK,"^",2)_" "_$P(RCFCHECK,"^")
I $G(RCFTRACE)'="" S VALMHDR(2)=" List of Payments With Trace Numbers "_$P(RCFTRACE,"^",2)_" "_$P(RCFTRACE,"^")
I $G(RCFCREDT)'="" S VALMHDR(2)=" List of Payments With Credit Cards "_$P(RCFCREDT,"^",2)_" "_$P(RCFCREDT,"^")
Q
;
;
EXIT ; exit list manager option and clean up
K ^TMP("RCDPLPLM",$J),^TMP("RCDPLPLMUNLINK",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPLPLM 6686 printed Oct 16, 2024@17:46:57 Page 2
RCDPLPLM ;WISC/RFJ - link payments listmanager top routine ;1 Jun 99
+1 ;;4.5;Accounts Receivable;**114,208,304**;Mar 20, 1995;Build 104
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 NEW RCFCHECK,RCFTRACE,RCFCREDT,RCDPFXIT
+5 NEW %,%DT,%H,%I,RCDPPADT,X,Y
+6 SET %DT("A")="Start with Payment Date (press RETURN for FIRST): "
SET %DT="AEP"
SET %DT(0)=-DT
+7 DO ^%DT
IF Y<0
IF X["^"
QUIT
+8 ; if user entered a date, go back one day
+9 IF Y'<0
SET RCDPPADT=$$FMADD^XLFDT(+Y,-1)
+10 ;
+11 DO EN^VALM("RCDP LINK PAYMENTS TO ACCOUNTS")
+12 QUIT
+13 ;
INIT ; initialization for list manager list
+1 ; pass RCDPPADT to display payments after RCDPPADT date
+2 ; pass RCFCHECK, RCFTRACE and RCFCREDT to search by
+3 ; check/trace #/credit card #
+4 ; fast exit
+5 IF $GET(RCDPFXIT)
SET VALMQUIT=1
QUIT
+6 ;
+7 WRITE !!,"please wait, building list of unlinked payments..."
+8 ;
+9 NEW DATE,FMSDOC,NUMBER,RCCOUNT,RCDATA,RCLINE,RCRECTDA,RCTOTAL,RCTRANDA,RECDATA,TYPE
+10 ;
+11 ; set the listmanager line number
+12 SET RCLINE=0
+13 ; set the lookup payment number from list
+14 SET RCCOUNT=0
+15 ; get list of unlinked accounts
+16 KILL ^TMP("RCDPLPLM",$JOB)
+17 SET RCRECTDA=0
FOR
SET RCRECTDA=$ORDER(^RCY(344,"AN",RCRECTDA))
if 'RCRECTDA
QUIT
Begin DoDot:1
+18 SET RECDATA=$GET(^RCY(344,RCRECTDA,0))
+19 SET RCTRANDA=0
FOR
SET RCTRANDA=$ORDER(^RCY(344,"AN",RCRECTDA,RCTRANDA))
if 'RCTRANDA
QUIT
Begin DoDot:2
+20 SET RCDATA=$GET(^RCY(344,RCRECTDA,1,RCTRANDA,0))
+21 ;no payment amount
IF '$PIECE(RCDATA,"^",4)
QUIT
+22 ; fms doc id entered (field 26) to clear suspense
+23 IF $PIECE($GET(^RCY(344,RCRECTDA,1,RCTRANDA,2)),"^",6)'=""
QUIT
+24 ; unlinked
+25 ; get payment date
+26 SET DATE=$PIECE(RCDATA,"^",6)
+27 IF 'DATE
SET DATE=$PIECE(RCDATA,"^",10)
+28 IF 'DATE
SET DATE=$PIECE(RECDATA,"^",3)
+29 IF 'DATE
SET DATE=0
+30 ; before selected payment date
+31 IF $GET(RCDPPADT)
IF DATE<RCDPPADT
QUIT
+32 ;
+33 SET RCLINE=RCLINE+1
+34 SET RCCOUNT=RCCOUNT+1
+35 ;
+36 ; create an index array for bill lookup in list
+37 SET ^TMP("RCDPLPLM",$JOB,"IDX",RCCOUNT,RCCOUNT)=RCRECTDA_"^"_RCTRANDA
+38 ;
+39 DO SET(RCCOUNT,RCLINE,1,80)
+40 ; receipt number
+41 DO SET($PIECE(RECDATA,"^"),RCLINE,6,18)
+42 ; transaction number
+43 DO SET($JUSTIFY(RCTRANDA,5),RCLINE,20,24)
+44 ; unapplied deposit number
+45 DO SET($JUSTIFY($$GETUNAPP^RCXFMSCR(RCRECTDA,RCTRANDA,0),13),RCLINE,26,39)
+46 ; receipt status
+47 DO SET($EXTRACT($SELECT($PIECE(RECDATA,"^",14):"OPEN",1:"CLOSED"),1,4),RCLINE,41,44)
+48 ; payment date
+49 DO SET($EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)_"/"_$EXTRACT(DATE,2,3),RCLINE,47,54)
+50 ; get type of payment
+51 ;EFT/ERA payment
SET TYPE=$SELECT($PIECE(RECDATA,U,18)&$PIECE(RECDATA,U,17):"TRACE",1:"")
+52 IF TYPE=""
Begin DoDot:3
+53 SET TYPE=$PIECE($GET(^RCY(344,RCRECTDA,1,RCTRANDA,2)),"^",4)
+54 SET TYPE=$SELECT(TYPE=1:"CASH",TYPE=2:"CHECK",TYPE=3:"CREDIT",1:"")
End DoDot:3
+55 IF TYPE=""
SET TYPE=$PIECE($GET(^RC(341.1,+$PIECE(RECDATA,"^",4),0)),"^")
+56 DO SET(TYPE,RCLINE,57,60)
+57 ; get check, trace, credit #, RCFCHECK RCFTRACE and RCFCREDT
+58 ; can be used to match a specific check, trace or credit card #
+59 ; the variable is in the form:
+60 ; RCFCHECK=number^EXACT or number^CONTAINS
+61 IF $GET(RCFCHECK)'=""
IF $EXTRACT(TYPE,1,5)'="CHECK"
QUIT
+62 IF $GET(RCFTRACE)'=""
IF $EXTRACT(TYPE,1,5)'="TRACE"
QUIT
+63 IF $GET(RCFCREDT)'=""
IF $EXTRACT(TYPE,1,6)'="CREDIT"
QUIT
+64 SET NUMBER=""
+65 IF $EXTRACT(TYPE,1,5)="CHECK"
Begin DoDot:3
+66 SET NUMBER=$PIECE(RCDATA,"^",7)
+67 IF $GET(RCFCHECK)'=""
IF NUMBER=""
QUIT
+68 IF $EXTRACT($PIECE($GET(RCFCHECK),"^",2))="E"
IF NUMBER'=$PIECE(RCFCHECK,"^")
SET NUMBER=""
QUIT
+69 IF $EXTRACT($PIECE($GET(RCFCHECK),"^",2))="C"
IF NUMBER'[$PIECE(RCFCHECK,"^")
SET NUMBER=""
QUIT
+70 IF NUMBER=""
SET NUMBER=" "
End DoDot:3
if NUMBER=""
QUIT
+71 IF $EXTRACT(TYPE,1,5)="TRACE"
Begin DoDot:3
+72 SET NUMBER=$PIECE($GET(^RCY(344.4,+$PIECE(RECDATA,U,18),0)),U,2)
+73 IF $GET(RCFTRACE)'=""
IF NUMBER=""
QUIT
+74 IF $EXTRACT($PIECE($GET(RCFTRACE),"^",2))="E"
IF NUMBER'=$PIECE(RCFTRACE,"^")
SET NUMBER=""
QUIT
+75 IF $EXTRACT($PIECE($GET(RCFTRACE),"^",2))="C"
IF NUMBER'[$PIECE(RCFTRACE,"^")
SET NUMBER=""
QUIT
+76 IF NUMBER=""
SET NUMBER=" "
End DoDot:3
if NUMBER=""
QUIT
+77 IF $EXTRACT(TYPE,1,6)="CREDIT"
Begin DoDot:3
+78 SET NUMBER=$PIECE(RCDATA,"^",11)
+79 IF $GET(RCFCHECK)'=""
IF NUMBER=""
QUIT
+80 IF $EXTRACT($PIECE($GET(RCFCREDT),"^",2))="E"
IF NUMBER'=$PIECE(RCFCREDT,"^")
SET NUMBER=""
QUIT
+81 IF $EXTRACT($PIECE($GET(RCFCREDT),"^",2))="C"
IF NUMBER'[$PIECE(RCFCREDT,"^")
SET NUMBER=""
QUIT
+82 IF NUMBER=""
SET NUMBER=" "
End DoDot:3
if NUMBER=""
QUIT
+83 IF NUMBER=""
SET NUMBER=" "
+84 SET %=$LENGTH(NUMBER)
IF %>8
SET NUMBER=$EXTRACT(NUMBER,%-7,%)
+85 ; check/trace/credit# (last 8 chars)
+86 DO SET(NUMBER,RCLINE,62,69)
+87 ; amount paid
+88 DO SET($JUSTIFY($PIECE(RCDATA,"^",4),10,2),RCLINE,70,80)
+89 ; since list manager adds spaces to line, make sure line is
+90 ; 80 characters so the print list looks okay
+91 SET ^TMP("RCDPLPLM",$JOB,RCLINE,0)=$EXTRACT(^TMP("RCDPLPLM",$JOB,RCLINE,0),1,80)
+92 SET RCTOTAL=$GET(RCTOTAL)+$PIECE(RCDATA,"^",4)
+93 ;
+94 ; show line 2
+95 ; account lookup
+96 SET RCLINE=RCLINE+1
+97 SET %=$EXTRACT("AcctLU: "_$PIECE($GET(^RCY(344,RCRECTDA,1,RCTRANDA,2)),"^")_" ",1,24)
+98 DO SET(" "_%,RCLINE,1,80)
+99 ; fms cr document
+100 SET FMSDOC=$$FMSSTAT^RCDPUREC(RCRECTDA)
+101 DO SET($EXTRACT("CRdoc: "_$PIECE(FMSDOC,"^")_" ",1,22),RCLINE,41,80)
+102 ; cr document status
+103 DO SET($PIECE(FMSDOC,"^",2),RCLINE,63,68)
+104 ; make second line longer than 80 characters for printing
+105 ; this will add an extra line after each entry
+106 DO SET(" ",RCLINE,80,84)
End DoDot:2
End DoDot:1
+107 ;
+108 SET RCLINE=RCLINE+1
DO SET("----------",RCLINE,70,80)
+109 SET RCLINE=RCLINE+1
DO SET("TOTAL: "_$JUSTIFY($GET(RCTOTAL),10,2),RCLINE,63,80)
+110 ;
+111 ; set valmcnt to number of lines in the list
+112 SET VALMCNT=RCLINE
+113 DO HDR
+114 QUIT
+115 ;
+116 ;
SET(STRING,LINE,COLBEG,COLEND) ; set array
+1 IF '$DATA(@VALMAR@(LINE,0))
DO SET^VALM10(LINE,$JUSTIFY("",80))
+2 DO SET^VALM10(LINE,$$SETSTR^VALM1(STRING,@VALMAR@(LINE,0),COLBEG,COLEND-COLBEG+1))
+3 QUIT
+4 ;
+5 ;
HDR ; header code for list manager display
+1 SET VALMHDR(1)="Transactions for ALL Unapplied Payments"
+2 IF $GET(RCDPPADT)>0
SET Y=RCDPPADT
DO DD^%DT
SET VALMHDR(1)="Transactions for Unapplied Payments After "_Y
+3 SET VALMHDR(2)=" "
+4 IF $GET(RCFCHECK)'=""
SET VALMHDR(2)=" List of Payments With Check Numbers "_$PIECE(RCFCHECK,"^",2)_" "_$PIECE(RCFCHECK,"^")
+5 IF $GET(RCFTRACE)'=""
SET VALMHDR(2)=" List of Payments With Trace Numbers "_$PIECE(RCFTRACE,"^",2)_" "_$PIECE(RCFTRACE,"^")
+6 IF $GET(RCFCREDT)'=""
SET VALMHDR(2)=" List of Payments With Credit Cards "_$PIECE(RCFCREDT,"^",2)_" "_$PIECE(RCFCREDT,"^")
+7 QUIT
+8 ;
+9 ;
EXIT ; exit list manager option and clean up
+1 KILL ^TMP("RCDPLPLM",$JOB),^TMP("RCDPLPLMUNLINK",$JOB)
+2 QUIT
