RCDPRLIS ;WISC/RFJ - list of receipts report ;1 Jun 99
;;4.5;Accounts Receivable;**114,304,321,332,349**;Mar 20, 1995;Build 44
;;Per VA Directive 6402, this routine should not be modified.
;
N %ZIS,DATEEND,DATESTRT,POP,RCFILTF,RCFILTT,RCLSTMGR,RCSORT
N ZTDESC,ZTQUEUED,ZTRTN,ZTSAVE,ZTSK
W !
D DATESEL^RCRJRTRA("RECEIPT Opened")
I '$G(DATESTRT)!('$G(DATEEND)) Q
;
; Prompt for sort order PRCA*4.5*321
S RCSORT=$$SORTSEL()
I RCSORT=-1 Q
;
; Prompt for filter by FMS Status PRCA*4.5*321
D SELFILTF(.RCFILTF)
I RCFILTF=-1 Q
;
; Prompt for filter by Payment Type PRCA*4.5*321
D SELFILTT(.RCFILTT)
I RCFILTT=-1 Q
;
; Ask for ListMan display, exit if timeout or '^'
W !
S RCLSTMGR=$$ASKLM^RCDPEARL() I RCLSTMGR<0 Q
;
; Send report to Listman if requested
I RCLSTMGR D D CLEAN Q
. D DQ
. D EN^RCDPRL
;
; select device
W ! S %ZIS="Q" D ^%ZIS I POP Q
I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
. S ZTDESC="List of Receipts",ZTRTN="DQ^RCDPRLIS"
. S ZTSAVE("DATE*")="",ZTSAVE("RC*")="",ZTSAVE("ZTREQ")="@"
W !!,"<*> please wait <*>"
D DQ
Q
;
DQ ; queued report starts here
; PRCA*4.5*321 Extensive changes to this subroutine for filter/sort/ListMan
N %,%I,CNT,DATA,DATE,DATEDIS1,DATEDIS2,FMSDOCNO,FMSTATUS,NOW,PAGE,PTYPE,RCDK,RCDPDATA
;
; PRCA*4.5*349 - Added RCTTL
N RCDPFPRE,RCIX,RCRECTDA,RCRJFLAG,RCRJLINE,RCTTL,RCUSER,SCREEN,SPACE,TOTALS,TYPE,X,XX,Y,ZZ ; PRCA*4.5*332
K ^TMP($J,"RCDPRLIS")
S SPACE=$J("",80)
S RCDK=$$FMADD^XLFDT(DATESTRT,-1)_".24" ; Initialize start date for first $ORDER
S DATEEND=DATEEND_".24" ; Receipt date opened can include time, so compare with midnight on the end date.
F S RCDK=$O(^RCY(344,"AO",RCDK)) Q:(RCDK=""!(RCDK>DATEEND)) D ;
. S RCRECTDA=0 F S RCRECTDA=$O(^RCY(344,"AO",RCDK,RCRECTDA)) Q:'RCRECTDA D
. . K RCDPDATA
. . D DIQ344^RCDPRPLM(RCRECTDA,".01:200")
. . S FMSDOCNO=$$FMSSTAT^RCDPUREC(RCRECTDA) ; get FMS Document^Status^Pre lockbox patch
. . S FMSTATUS=$P(FMSDOCNO,"^",2) ; Apply filter by FMS Status
. . I RCFILTF,FMSTATUS'="",'$D(RCFILTF(FMSTATUS)) Q ; Status not included
. . S PTYPE=RCDPDATA(344,RCRECTDA,.04,"E") ; Apply filter by Payment Type
. . I RCFILTT,PTYPE'="",'$D(RCFILTT(PTYPE)) Q ; Status not included
. . S RCTTL=$$RCPTTL(RCRECTDA) ; PRCA*4.5*349 - Total of receipt
. . ;
. . ; Compute totals by type
. . I RCDPDATA(344,RCRECTDA,.04,"E")="" S RCDPDATA(344,RCRECTDA,.04,"E")="UNKNOWN"
. . S $P(TOTALS(PTYPE),"^",1)=$P($G(TOTALS(PTYPE)),"^",1)+RCDPDATA(344,RCRECTDA,101,"E")
. . ;
. . ; PRCA*4.5*349 - Changed RCDPDATA(344,RCRECTDA,.15,"E") to RCTTL below
. . S $P(TOTALS(PTYPE),"^",2)=$P($G(TOTALS(PTYPE)),"^",2)+RCTTL
. . S $P(TOTALS,"^",1)=$P($G(TOTALS),"^",1)+RCDPDATA(344,RCRECTDA,101,"E")
. . ;
. . ; PRCA*4.5*349 - Changed RCDPDATA(344,RCRECTDA,.15,"E") to RCTTL below
. . S $P(TOTALS,"^",2)=$P($G(TOTALS),"^",2)+RCTTL
. . ;
. . I RCDPDATA(344,RCRECTDA,.02,"I")=.5 D ; Opened by
. . . S RCUSER="ar"
. . ; PRCA*4.5*332 Begin modified code block
. . E D ;
. . . S RCUSER=RCDPDATA(344,RCRECTDA,.02,"E")
. . . I RCUSER'="" D
. . . . S RCUSER=$E($P(RCUSER,",",1),1,5)_","_$E($P(RCUSER,",",2),1)
. . ;
. . S DATA=RCDPDATA(344,RCRECTDA,.01,"E") ; Receipt number
. . S DATA=DATA_"^"_RCDPDATA(344,RCRECTDA,.03,"I") ; Date opened
. . S ZZ=$$TYPE(RCDPDATA(344,RCRECTDA,.04,"E")) ; Payment type
. . S DATA=DATA_"^"_ZZ ; Payment type
. . S DATA=DATA_"^"_RCUSER ; User initials
. . S DATA=DATA_"^"_RCDPDATA(344,RCRECTDA,101,"E") ; Payment count
. . ;
. . ; PRCA*4.5*349 - Changed RCDPDATA(344,RCRECTDA,.15,"E") to RCTTL below
. . S DATA=DATA_"^"_RCTTL ; Payment amount
. . S DATA=DATA_"^"_$S($P(FMSDOCNO,"^",3):"*",1:" ") ; Pre lockbox
. . S DATA=DATA_"^"_$P(FMSDOCNO,"^") ; FMS CR document
. . S ZZ=$$STATUS($P(FMSDOCNO,"^",2)) ; FMS CR doc status
. . ; PRCA*4.5*332 End modified code block
. . S DATA=DATA_"^"_ZZ ; FMS CR doc status
. . S DATA=DATA_"^"_RCRECTDA ; IEN of file 344
. . ;
. . ; Index ^TMP global by user selected sort order
. . I RCSORT="D" S RCIX=RCDPDATA(344,RCRECTDA,.03,"I")
. . I RCSORT="F" S RCIX=FMSTATUS
. . I RCSORT="T" S RCIX=PTYPE
. . S ^TMP($J,"RCDPRLIS","SORT",RCIX,RCRECTDA)=DATA
;
S Y=$P(DATESTRT,".") S DATEDIS1=$$FMTE^XLFDT(Y,"2DZ")
S Y=$P(DATEEND,".") S DATEDIS2=$$FMTE^XLFDT(Y,"2DZ")
D NOW^%DTC S Y=% D DD^%DT S NOW=Y
S PAGE=1,RCRJLINE="",$P(RCRJLINE,"-",81)=""
S SCREEN=0 I '$D(ZTQUEUED),'$G(RCLSTMGR),IO=IO(0),$E(IOST)="C" S SCREEN=1
D HDR ; Compile header in to ^TMP for use in report or ListMan
U IO D:'$G(RCLSTMGR) H
S CNT=0
S RCIX=0 F S RCIX=$O(^TMP($J,"RCDPRLIS","SORT",RCIX)) Q:RCIX=""!($G(RCRJFLAG)) D
. S RCRECTDA=0 F S RCRECTDA=$O(^TMP($J,"RCDPRLIS","SORT",RCIX,RCRECTDA)) Q:'RCRECTDA!($G(RCRJFLAG)) D
. . S DATA=^TMP($J,"RCDPRLIS","SORT",RCIX,RCRECTDA)
. . S DATE=$P(DATA,"^",2)
. . S CNT=CNT+1
. . S XX=""
. . I RCLSTMGR S XX=" "_$E(CNT_SPACE,1,4)_" " ; line number (for listman)
. . S XX=XX_$$FMTE^XLFDT(DATE,"2ZD")_" " ; date opened
. . S XX=XX_$E($P(DATA,"^",1)_SPACE,1,12)_" " ; receipt number
. . S XX=XX_$E($P(DATA,"^",3)_SPACE,1,$S(RCLSTMGR:5,1:6))_" " ; payment type PRCA*4.5*332
. . S XX=XX_$E($P(DATA,"^",4)_SPACE,1,7)_" " ; user initials PRCA*4.5*332
. . S XX=XX_$J($P(DATA,"^",5),5) ; payment count
. . S XX=XX_$J($P(DATA,"^",6),$S(RCLSTMGR:11,1:13),2)_" " ; payment amount
. . S XX=XX_$E($P(DATA,"^",7)_SPACE,1) ; pre lockbox
. . S XX=XX_$E($P(DATA,"^",8)_SPACE,1,16)_" " ; fms cr document
. . S XX=XX_$E($P(DATA,"^",9),1,6) ; fms cr doc status
. . ;
. . ; Write line or put it to global
. . I '$G(RCLSTMGR) D ;
. . . W !,XX
. . E D ;
. . . S ^TMP($J,"RCDPRLIS",CNT)=XX
. . . S ^TMP($J,"RCDPRLIS","IDX",CNT)=$P(DATA,"^",10) ; Cross reference line# vs file 344 DA
. . ;
. . ; set pre lockbox flag to 1 to show note at end of report
. . I $P(DATA,"^",7)="*" S RCDPFPRE=1
. . ;
. . I '$G(RCLSTMGR),$Y>(IOSL-6) D:SCREEN PAUSE^RCRJRTR1 Q:$G(RCRJFLAG) D H
;
I $G(RCLSTMGR) Q ; PRCA*4.5*321 - Totals don't have a place in a protocol list with actions
;
I $G(RCRJFLAG) D CLEAN Q
I $G(RCDPFPRE) W !?54,"*CR tied to deposit"
W !?33,"------ -----------"
W !?33,$J($P($G(TOTALS),"^"),6),$J($P($G(TOTALS),"^",2),13,2)
;
; show totals by type of payment
W !!,"TOTALS BY TYPE OF PAYMENT"
W !,"-------------------------"
S TYPE="" F S TYPE=$O(TOTALS(TYPE)) Q:TYPE=""!($G(RCRJFLAG)) D
. W !,TYPE,?33,$J($P(TOTALS(TYPE),"^"),6),$J($P(TOTALS(TYPE),"^",2),13,2)
. I $Y>(IOSL-6) D:SCREEN PAUSE^RCRJRTR1 Q:$G(RCRJFLAG) D H
;
W !!,"*** END OF REPORT ***",!
;
I $G(RCRJFLAG) D CLEAN Q
I SCREEN U IO(0) R !,"Press RETURN to continue:",%:DTIME
;
I '$G(RCLSTMGR) D CLEAN
Q
;
RCPTTL(RCRECTDA) ; Returns the Total Amount of all of the Receipt Transactions
; PRCA*4.5*349 - Added Method
; Input: RCRECTDA - IEN of the Receipt (#344)
; Returns: Total Amount of all of the Receipt Transactions
N TOTAL,X
S X=0,TOTAL=0
F D Q:'X
. S X=$O(^RCY(344,+$G(RCRECTDA),1,X)) Q:'X
. S TOTAL=TOTAL+$P($G(^(X,0)),"^",4)
Q TOTAL
;
TYPE(AREVENT) ; Returns an abbreviated type of the AR EVENT - PRCA*4.5*332 Subroutine added
; Input: AREVENT - External AR Event Type (file 344, field .04)
; Returns: 6 character (max) event type abbreviation
I AREVENT="EDI LOCKBOX" Q "EDI"
I AREVENT="CASH PAYMENT" Q "CASH"
I AREVENT="CHECK/MO PAYMENT" Q "CHECK"
I AREVENT="LOCKBOX" Q "LOCKBX"
Q $E(AREVENT,1,6)
;
STATUS(STATUS) ; Returns an abbreviated status of the FMS Doc Status - PRCA*4.5*332 Subroutine added
; Input: STATUS - 2nd word of the FMS Doc Status
; Returns: 9 character (max) status
S STATUS=$P(STATUS," ",1)
I STATUS="TRANSMITTED" Q "XMIT"
I STATUS="ACCEPTED" Q "ACCEPT"
I STATUS="REJECTED" Q "REJECT"
I STATUS="NOT" Q "NOTENT"
I STATUS="ON" Q "ONLINE"
Q STATUS
;
CLEAN ; Clean up ^TMP arrays
D ^%ZISC
K ^TMP($J,"RCDPRLIS")
Q
;
SORTSEL() ; Select sort order for report, by Date Opened, FMS Status or Payment Type
; Input: None
; Return: Sort Type D - Date, F - FMS Status, T - Payment Type
N DIR,X,Y,DUOUT,DTOUT,DIRUT,DIROUT,RCREP
W !
S DIR(0)="SOA^D:Date;F:FMS Status;T:Type of payment"
S DIR("A")="Sort By (D)ATE OPENED, (F)MS STATUS OR (T)YPE OF PAYMENT: "
S DIR("B")="D"
S DIR("?",1)="Select the order you wish the receipts to appear in on the report."
S DIR("?",2)=" "
S DIR("?",3)=" D - Sort by the date the receipt was opened"
S DIR("?",4)=" S - Sort by the FMS Status"
S DIR("?")=" T - Sort by the Payment Type"
D ^DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") S RETURN=-1
E S RETURN=Y
Q RETURN
;
SELFILTF(RETURN) ; Ask if user want to filter by FMS status. If yes get list of status.
; Input: None
; Output: RETURN, passed by reference
; RETURN - 1=Filter by FMS Status, 0=Don't
; RETURN(STATUS) - array of FMS Status to include in the report
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,J,QUIT,RCODES,RCOUT,X,Y
K RETURN
S RETURN=0
;
W !
S DIR(0)="YA"
S DIR("A")="Filter by FMS Status? (Y/N): "
S DIR("B")="NO"
S DIR("?",1)="Enter 'Y' or 'Yes' to only show receipts with selected FMS Status"
S DIR("?",2)="Enter 'N' or 'No' if you wish to show receipts including all FMS Status"
S DIR("?")="If you select yes, you will be prompted for the FMS Status' you wish to include"
D ^DIR
I $D(DIRUT) S RETURN=-1 Q
I Y=0 Q
S RETURN=1
;
; Prompt for status' to be included. Multi-select
W !
D FIELD^DID(2100.1,3,"","POINTER","RCOUT")
S RCODES=RCOUT("POINTER")
; Add pseudo codes to list for "NOT ENTERED" and "ON LINE ENTRY" returned by FMSSTAT^RCDPUREC
I $E(RCODES,$L(RCODES))'=";" S RCODES=RCODES_";"
S RCODES=RCODES_"O:ON LINE ENTRY;N:NOT ENTERED"
K DIR
S DIR(0)="SOA^"_RCODES
S DIR("A")="Select an FMS Status to include in the report: "
K DIR("?")
S DIR("?",1)="Select an FMS Status to show in the report."
S DIR("?",2)="You will be prompted multiple times, until you hit ENTER"
S DIR("?")="without making a selection."
S QUIT=0
F D I QUIT Q
. W !
. D ^DIR
. I $D(DTOUT)!$D(DUOUT) K RETURN S RETURN=-1,QUIT=1 Q
. I Y="" S QUIT=1 Q
. S RETURN(Y(0))=""
. ; Rebuid DIR(0) to only include codes not yet selected
. S DIR(0)=$$BLDS(RCODES,.RETURN)
. I $P(DIR(0),"^",2)="" S QUIT=1 ; All status selected so stop prompting.
I RETURN=-1 Q
; If no FMS Status' were selected, don't filter by it.
I $O(RETURN(""))="" D ;
. S RETURN=0
. W !!,"No FMS Status' were selected. All FMS Status' will be shown",!
Q
;
SELFILTT(RETURN) ; Ask if user want to filter by Payment Type. If yes get list of types.
; Input: None
; Output: RETURN, passed by reference
; RETURN - 1=Filter by FMS Status, 0=Don't
; RETURN(STATUS) - array of FMS Status to include in the report
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,RCODES,RCIEN,RCNAME,QUIT,X,Y
K RETURN
S RETURN=0
;
W !
S DIR(0)="YA"
S DIR("A")="Filter by Payment Type? (Y/N): "
S DIR("B")="NO"
S DIR("?",1)="Enter 'Y' or 'Yes' to only show receipts with selected Payment Types"
S DIR("?",2)="Enter 'N' or 'No' if you wish to show receipts including all Payment Types"
S DIR("?")="If you select yes, you will be prompted for the Payment Types you wish to include"
D ^DIR
I $D(DIRUT) S RETURN=-1 Q
I Y=0 Q
S RETURN=1
;
; Prompt for types to be included. Multi-select
W !
K DIR
; Present payment types as a set of codes to streamline user interface/selection/help
S (RCODES,RCNAME)=""
F S RCNAME=$O(^RC(341.1,"B",RCNAME)) Q:RCNAME="" D ;
. S RCIEN=0 F S RCIEN=$O(^RC(341.1,"B",RCNAME,RCIEN)) Q:'RCIEN D ;
. . I $$GET1^DIQ(341.1,RCIEN_",",.06,"I")=1 D ;
. . . S RCODES=RCODES_":"_$$GET1^DIQ(341.1,RCIEN_",",.01,"E")_";"
S DIR(0)="SOA^"_RCODES
S DIR("A")="Select a Payment Type to include in the report: "
K DIR("?")
S DIR("?",1)="Select an Payment Type to include in the report."
S DIR("?",2)="You will be prompted multiple times, until you hit ENTER"
S DIR("?")="without making a selection."
S QUIT=0
F D I QUIT Q
. W !
. D ^DIR
. I $D(DTOUT)!$D(DUOUT) K RETURN S RETURN=-1,QUIT=1 Q
. I $G(Y(0))="" S QUIT=1 Q
. S RETURN(Y(0))=""
. ; Rebuid DIR(0) to only include codes not yet selected
. S DIR(0)=$$BLDS(RCODES,.RETURN)
. I $P(DIR(0),"^",2)="" S QUIT=1 ; All status selected so stop prompting.
;
I RETURN=-1 Q
; If no payment types were selected, don't filter by it.
I $O(RETURN(""))="" D ;
. S RETURN=0
. W !!,"No Payment Types were selected. Filter will not be used",!
Q
;
BLDS(CODES,PICKED) ; Build DIR(0) string taking into account codes already picked.
; Input: CODES - Set of codes string in fileman format e.g. A:Apple;B:Ball;
; PICKED - Array of values already picked, subscripted by external value e.g. PICKED("Apple")=""
; Return: RETURN in DIR(0) format. Set of codes that only includes ones not picked.
; e.g "SAO^B:Ball"
;
N RETURN
S RETURN="SOA^"
F J=1:1:$L(CODES,";") D ;
. S X=$P($P(CODES,";",J),":",2)
. I X'="",'$D(PICKED(X)) S RETURN=RETURN_$P(CODES,";",J)_";"
Q RETURN
;
HDR ; Compile header into ^TMP for use in ListMan or report
; Input: None
; Output: Header information in ^TMP($J,"RCDPRLIS","HDR",n) for us in report or ListMan formats
N K,XX
S ^TMP($J,"RCDPRLIS","HDR",1)="LIST OF RECEIPTS REPORT"
S XX=" DATE RANGE : "_DATEDIS1_" TO "_DATEDIS2_" "
S XX=XX_"SORT ORDER: "_$S(RCSORT="D":"DATE OPENED",RCSORT="F":"FMS STATUS",1:"PAYMENT TYPE")
S ^TMP($J,"RCDPRLIS","HDR",2)=XX
;
I 'RCFILTF D ;
. S XX="ALL"
E D ;
. S XX=""
. S K="" F S K=$O(RCFILTF(K)) Q:K="" S:XX'="" XX=XX_"; " S XX=XX_K
S ^TMP($J,"RCDPRLIS","HDR",3)=" FMS STATUS : "_$S($L(XX)>63:"SELECTED",1:XX)
;
I 'RCFILTT D ;
. S XX="ALL"
E D ;
. S XX=""
. S K="" F S K=$O(RCFILTT(K)) Q:K="" S:XX'="" XX=XX_"; " S XX=XX_K
S ^TMP($J,"RCDPRLIS","HDR",4)=" PAYMENT TYPES: "_$S($L(XX)>63:"SELECTED",1:XX)
; PRCA*4.5*332
S ^TMP($J,"RCDPRLIS","HDR",5)="DATE RECEIPT TYPE USER COUNT AMOUNT FMS CR DOC STATUS"
W !,RCRJLINE
Q
;
H ; header
N %
S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W $C(13),^TMP($J,"RCDPRLIS","HDR",1),?(80-$L(%)),%
W !,^TMP($J,"RCDPRLIS","HDR",2)
W !,^TMP($J,"RCDPRLIS","HDR",3)
W !,^TMP($J,"RCDPRLIS","HDR",4)
W !,^TMP($J,"RCDPRLIS","HDR",5)
W !,RCRJLINE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPRLIS 15068 printed Sep 23, 2025@19:22:23 Page 2
RCDPRLIS ;WISC/RFJ - list of receipts report ;1 Jun 99
+1 ;;4.5;Accounts Receivable;**114,304,321,332,349**;Mar 20, 1995;Build 44
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 NEW %ZIS,DATEEND,DATESTRT,POP,RCFILTF,RCFILTT,RCLSTMGR,RCSORT
+5 NEW ZTDESC,ZTQUEUED,ZTRTN,ZTSAVE,ZTSK
+6 WRITE !
+7 DO DATESEL^RCRJRTRA("RECEIPT Opened")
+8 IF '$GET(DATESTRT)!('$GET(DATEEND))
QUIT
+9 ;
+10 ; Prompt for sort order PRCA*4.5*321
+11 SET RCSORT=$$SORTSEL()
+12 IF RCSORT=-1
QUIT
+13 ;
+14 ; Prompt for filter by FMS Status PRCA*4.5*321
+15 DO SELFILTF(.RCFILTF)
+16 IF RCFILTF=-1
QUIT
+17 ;
+18 ; Prompt for filter by Payment Type PRCA*4.5*321
+19 DO SELFILTT(.RCFILTT)
+20 IF RCFILTT=-1
QUIT
+21 ;
+22 ; Ask for ListMan display, exit if timeout or '^'
+23 WRITE !
+24 SET RCLSTMGR=$$ASKLM^RCDPEARL()
IF RCLSTMGR<0
QUIT
+25 ;
+26 ; Send report to Listman if requested
+27 IF RCLSTMGR
Begin DoDot:1
+28 DO DQ
+29 DO EN^RCDPRL
End DoDot:1
DO CLEAN
QUIT
+30 ;
+31 ; select device
+32 WRITE !
SET %ZIS="Q"
DO ^%ZIS
IF POP
QUIT
+33 IF $DATA(IO("Q"))
Begin DoDot:1
+34 SET ZTDESC="List of Receipts"
SET ZTRTN="DQ^RCDPRLIS"
+35 SET ZTSAVE("DATE*")=""
SET ZTSAVE("RC*")=""
SET ZTSAVE("ZTREQ")="@"
End DoDot:1
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
QUIT
+36 WRITE !!,"<*> please wait <*>"
+37 DO DQ
+38 QUIT
+39 ;
DQ ; queued report starts here
+1 ; PRCA*4.5*321 Extensive changes to this subroutine for filter/sort/ListMan
+2 NEW %,%I,CNT,DATA,DATE,DATEDIS1,DATEDIS2,FMSDOCNO,FMSTATUS,NOW,PAGE,PTYPE,RCDK,RCDPDATA
+3 ;
+4 ; PRCA*4.5*349 - Added RCTTL
+5 ; PRCA*4.5*332
NEW RCDPFPRE,RCIX,RCRECTDA,RCRJFLAG,RCRJLINE,RCTTL,RCUSER,SCREEN,SPACE,TOTALS,TYPE,X,XX,Y,ZZ
+6 KILL ^TMP($JOB,"RCDPRLIS")
+7 SET SPACE=$JUSTIFY("",80)
+8 ; Initialize start date for first $ORDER
SET RCDK=$$FMADD^XLFDT(DATESTRT,-1)_".24"
+9 ; Receipt date opened can include time, so compare with midnight on the end date.
SET DATEEND=DATEEND_".24"
+10 ;
FOR
SET RCDK=$ORDER(^RCY(344,"AO",RCDK))
if (RCDK=""!(RCDK>DATEEND))
QUIT
Begin DoDot:1
+11 SET RCRECTDA=0
FOR
SET RCRECTDA=$ORDER(^RCY(344,"AO",RCDK,RCRECTDA))
if 'RCRECTDA
QUIT
Begin DoDot:2
+12 KILL RCDPDATA
+13 DO DIQ344^RCDPRPLM(RCRECTDA,".01:200")
+14 ; get FMS Document^Status^Pre lockbox patch
SET FMSDOCNO=$$FMSSTAT^RCDPUREC(RCRECTDA)
+15 ; Apply filter by FMS Status
SET FMSTATUS=$PIECE(FMSDOCNO,"^",2)
+16 ; Status not included
IF RCFILTF
IF FMSTATUS'=""
IF '$DATA(RCFILTF(FMSTATUS))
QUIT
+17 ; Apply filter by Payment Type
SET PTYPE=RCDPDATA(344,RCRECTDA,.04,"E")
+18 ; Status not included
IF RCFILTT
IF PTYPE'=""
IF '$DATA(RCFILTT(PTYPE))
QUIT
+19 ; PRCA*4.5*349 - Total of receipt
SET RCTTL=$$RCPTTL(RCRECTDA)
+20 ;
+21 ; Compute totals by type
+22 IF RCDPDATA(344,RCRECTDA,.04,"E")=""
SET RCDPDATA(344,RCRECTDA,.04,"E")="UNKNOWN"
+23 SET $PIECE(TOTALS(PTYPE),"^",1)=$PIECE($GET(TOTALS(PTYPE)),"^",1)+RCDPDATA(344,RCRECTDA,101,"E")
+24 ;
+25 ; PRCA*4.5*349 - Changed RCDPDATA(344,RCRECTDA,.15,"E") to RCTTL below
+26 SET $PIECE(TOTALS(PTYPE),"^",2)=$PIECE($GET(TOTALS(PTYPE)),"^",2)+RCTTL
+27 SET $PIECE(TOTALS,"^",1)=$PIECE($GET(TOTALS),"^",1)+RCDPDATA(344,RCRECTDA,101,"E")
+28 ;
+29 ; PRCA*4.5*349 - Changed RCDPDATA(344,RCRECTDA,.15,"E") to RCTTL below
+30 SET $PIECE(TOTALS,"^",2)=$PIECE($GET(TOTALS),"^",2)+RCTTL
+31 ;
+32 ; Opened by
IF RCDPDATA(344,RCRECTDA,.02,"I")=.5
Begin DoDot:3
+33 SET RCUSER="ar"
End DoDot:3
+34 ; PRCA*4.5*332 Begin modified code block
+35 ;
IF '$TEST
Begin DoDot:3
+36 SET RCUSER=RCDPDATA(344,RCRECTDA,.02,"E")
+37 IF RCUSER'=""
Begin DoDot:4
+38 SET RCUSER=$EXTRACT($PIECE(RCUSER,",",1),1,5)_","_$EXTRACT($PIECE(RCUSER,",",2),1)
End DoDot:4
End DoDot:3
+39 ;
+40 ; Receipt number
SET DATA=RCDPDATA(344,RCRECTDA,.01,"E")
+41 ; Date opened
SET DATA=DATA_"^"_RCDPDATA(344,RCRECTDA,.03,"I")
+42 ; Payment type
SET ZZ=$$TYPE(RCDPDATA(344,RCRECTDA,.04,"E"))
+43 ; Payment type
SET DATA=DATA_"^"_ZZ
+44 ; User initials
SET DATA=DATA_"^"_RCUSER
+45 ; Payment count
SET DATA=DATA_"^"_RCDPDATA(344,RCRECTDA,101,"E")
+46 ;
+47 ; PRCA*4.5*349 - Changed RCDPDATA(344,RCRECTDA,.15,"E") to RCTTL below
+48 ; Payment amount
SET DATA=DATA_"^"_RCTTL
+49 ; Pre lockbox
SET DATA=DATA_"^"_$SELECT($PIECE(FMSDOCNO,"^",3):"*",1:" ")
+50 ; FMS CR document
SET DATA=DATA_"^"_$PIECE(FMSDOCNO,"^")
+51 ; FMS CR doc status
SET ZZ=$$STATUS($PIECE(FMSDOCNO,"^",2))
+52 ; PRCA*4.5*332 End modified code block
+53 ; FMS CR doc status
SET DATA=DATA_"^"_ZZ
+54 ; IEN of file 344
SET DATA=DATA_"^"_RCRECTDA
+55 ;
+56 ; Index ^TMP global by user selected sort order
+57 IF RCSORT="D"
SET RCIX=RCDPDATA(344,RCRECTDA,.03,"I")
+58 IF RCSORT="F"
SET RCIX=FMSTATUS
+59 IF RCSORT="T"
SET RCIX=PTYPE
+60 SET ^TMP($JOB,"RCDPRLIS","SORT",RCIX,RCRECTDA)=DATA
End DoDot:2
End DoDot:1
+61 ;
+62 SET Y=$PIECE(DATESTRT,".")
SET DATEDIS1=$$FMTE^XLFDT(Y,"2DZ")
+63 SET Y=$PIECE(DATEEND,".")
SET DATEDIS2=$$FMTE^XLFDT(Y,"2DZ")
+64 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET NOW=Y
+65 SET PAGE=1
SET RCRJLINE=""
SET $PIECE(RCRJLINE,"-",81)=""
+66 SET SCREEN=0
IF '$DATA(ZTQUEUED)
IF '$GET(RCLSTMGR)
IF IO=IO(0)
IF $EXTRACT(IOST)="C"
SET SCREEN=1
+67 ; Compile header in to ^TMP for use in report or ListMan
DO HDR
+68 USE IO
if '$GET(RCLSTMGR)
DO H
+69 SET CNT=0
+70 SET RCIX=0
FOR
SET RCIX=$ORDER(^TMP($JOB,"RCDPRLIS","SORT",RCIX))
if RCIX=""!($GET(RCRJFLAG))
QUIT
Begin DoDot:1
+71 SET RCRECTDA=0
FOR
SET RCRECTDA=$ORDER(^TMP($JOB,"RCDPRLIS","SORT",RCIX,RCRECTDA))
if 'RCRECTDA!($GET(RCRJFLAG))
QUIT
Begin DoDot:2
+72 SET DATA=^TMP($JOB,"RCDPRLIS","SORT",RCIX,RCRECTDA)
+73 SET DATE=$PIECE(DATA,"^",2)
+74 SET CNT=CNT+1
+75 SET XX=""
+76 ; line number (for listman)
IF RCLSTMGR
SET XX=" "_$EXTRACT(CNT_SPACE,1,4)_" "
+77 ; date opened
SET XX=XX_$$FMTE^XLFDT(DATE,"2ZD")_" "
+78 ; receipt number
SET XX=XX_$EXTRACT($PIECE(DATA,"^",1)_SPACE,1,12)_" "
+79 ; payment type PRCA*4.5*332
SET XX=XX_$EXTRACT($PIECE(DATA,"^",3)_SPACE,1,$SELECT(RCLSTMGR:5,1:6))_" "
+80 ; user initials PRCA*4.5*332
SET XX=XX_$EXTRACT($PIECE(DATA,"^",4)_SPACE,1,7)_" "
+81 ; payment count
SET XX=XX_$JUSTIFY($PIECE(DATA,"^",5),5)
+82 ; payment amount
SET XX=XX_$JUSTIFY($PIECE(DATA,"^",6),$SELECT(RCLSTMGR:11,1:13),2)_" "
+83 ; pre lockbox
SET XX=XX_$EXTRACT($PIECE(DATA,"^",7)_SPACE,1)
+84 ; fms cr document
SET XX=XX_$EXTRACT($PIECE(DATA,"^",8)_SPACE,1,16)_" "
+85 ; fms cr doc status
SET XX=XX_$EXTRACT($PIECE(DATA,"^",9),1,6)
+86 ;
+87 ; Write line or put it to global
+88 ;
IF '$GET(RCLSTMGR)
Begin DoDot:3
+89 WRITE !,XX
End DoDot:3
+90 ;
IF '$TEST
Begin DoDot:3
+91 SET ^TMP($JOB,"RCDPRLIS",CNT)=XX
+92 ; Cross reference line# vs file 344 DA
SET ^TMP($JOB,"RCDPRLIS","IDX",CNT)=$PIECE(DATA,"^",10)
End DoDot:3
+93 ;
+94 ; set pre lockbox flag to 1 to show note at end of report
+95 IF $PIECE(DATA,"^",7)="*"
SET RCDPFPRE=1
+96 ;
+97 IF '$GET(RCLSTMGR)
IF $Y>(IOSL-6)
if SCREEN
DO PAUSE^RCRJRTR1
if $GET(RCRJFLAG)
QUIT
DO H
End DoDot:2
End DoDot:1
+98 ;
+99 ; PRCA*4.5*321 - Totals don't have a place in a protocol list with actions
IF $GET(RCLSTMGR)
QUIT
+100 ;
+101 IF $GET(RCRJFLAG)
DO CLEAN
QUIT
+102 IF $GET(RCDPFPRE)
WRITE !?54,"*CR tied to deposit"
+103 WRITE !?33,"------ -----------"
+104 WRITE !?33,$JUSTIFY($PIECE($GET(TOTALS),"^"),6),$JUSTIFY($PIECE($GET(TOTALS),"^",2),13,2)
+105 ;
+106 ; show totals by type of payment
+107 WRITE !!,"TOTALS BY TYPE OF PAYMENT"
+108 WRITE !,"-------------------------"
+109 SET TYPE=""
FOR
SET TYPE=$ORDER(TOTALS(TYPE))
if TYPE=""!($GET(RCRJFLAG))
QUIT
Begin DoDot:1
+110 WRITE !,TYPE,?33,$JUSTIFY($PIECE(TOTALS(TYPE),"^"),6),$JUSTIFY($PIECE(TOTALS(TYPE),"^",2),13,2)
+111 IF $Y>(IOSL-6)
if SCREEN
DO PAUSE^RCRJRTR1
if $GET(RCRJFLAG)
QUIT
DO H
End DoDot:1
+112 ;
+113 WRITE !!,"*** END OF REPORT ***",!
+114 ;
+115 IF $GET(RCRJFLAG)
DO CLEAN
QUIT
+116 IF SCREEN
USE IO(0)
READ !,"Press RETURN to continue:",%:DTIME
+117 ;
+118 IF '$GET(RCLSTMGR)
DO CLEAN
+119 QUIT
+120 ;
RCPTTL(RCRECTDA) ; Returns the Total Amount of all of the Receipt Transactions
+1 ; PRCA*4.5*349 - Added Method
+2 ; Input: RCRECTDA - IEN of the Receipt (#344)
+3 ; Returns: Total Amount of all of the Receipt Transactions
+4 NEW TOTAL,X
+5 SET X=0
SET TOTAL=0
+6 FOR
Begin DoDot:1
+7 SET X=$ORDER(^RCY(344,+$GET(RCRECTDA),1,X))
if 'X
QUIT
+8 SET TOTAL=TOTAL+$PIECE($GET(^(X,0)),"^",4)
End DoDot:1
if 'X
QUIT
+9 QUIT TOTAL
+10 ;
TYPE(AREVENT) ; Returns an abbreviated type of the AR EVENT - PRCA*4.5*332 Subroutine added
+1 ; Input: AREVENT - External AR Event Type (file 344, field .04)
+2 ; Returns: 6 character (max) event type abbreviation
+3 IF AREVENT="EDI LOCKBOX"
QUIT "EDI"
+4 IF AREVENT="CASH PAYMENT"
QUIT "CASH"
+5 IF AREVENT="CHECK/MO PAYMENT"
QUIT "CHECK"
+6 IF AREVENT="LOCKBOX"
QUIT "LOCKBX"
+7 QUIT $EXTRACT(AREVENT,1,6)
+8 ;
STATUS(STATUS) ; Returns an abbreviated status of the FMS Doc Status - PRCA*4.5*332 Subroutine added
+1 ; Input: STATUS - 2nd word of the FMS Doc Status
+2 ; Returns: 9 character (max) status
+3 SET STATUS=$PIECE(STATUS," ",1)
+4 IF STATUS="TRANSMITTED"
QUIT "XMIT"
+5 IF STATUS="ACCEPTED"
QUIT "ACCEPT"
+6 IF STATUS="REJECTED"
QUIT "REJECT"
+7 IF STATUS="NOT"
QUIT "NOTENT"
+8 IF STATUS="ON"
QUIT "ONLINE"
+9 QUIT STATUS
+10 ;
CLEAN ; Clean up ^TMP arrays
+1 DO ^%ZISC
+2 KILL ^TMP($JOB,"RCDPRLIS")
+3 QUIT
+4 ;
SORTSEL() ; Select sort order for report, by Date Opened, FMS Status or Payment Type
+1 ; Input: None
+2 ; Return: Sort Type D - Date, F - FMS Status, T - Payment Type
+3 NEW DIR,X,Y,DUOUT,DTOUT,DIRUT,DIROUT,RCREP
+4 WRITE !
+5 SET DIR(0)="SOA^D:Date;F:FMS Status;T:Type of payment"
+6 SET DIR("A")="Sort By (D)ATE OPENED, (F)MS STATUS OR (T)YPE OF PAYMENT: "
+7 SET DIR("B")="D"
+8 SET DIR("?",1)="Select the order you wish the receipts to appear in on the report."
+9 SET DIR("?",2)=" "
+10 SET DIR("?",3)=" D - Sort by the date the receipt was opened"
+11 SET DIR("?",4)=" S - Sort by the FMS Status"
+12 SET DIR("?")=" T - Sort by the Payment Type"
+13 DO ^DIR
+14 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
SET RETURN=-1
+15 IF '$TEST
SET RETURN=Y
+16 QUIT RETURN
+17 ;
SELFILTF(RETURN) ; Ask if user want to filter by FMS status. If yes get list of status.
+1 ; Input: None
+2 ; Output: RETURN, passed by reference
+3 ; RETURN - 1=Filter by FMS Status, 0=Don't
+4 ; RETURN(STATUS) - array of FMS Status to include in the report
+5 ;
+6 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,J,QUIT,RCODES,RCOUT,X,Y
+7 KILL RETURN
+8 SET RETURN=0
+9 ;
+10 WRITE !
+11 SET DIR(0)="YA"
+12 SET DIR("A")="Filter by FMS Status? (Y/N): "
+13 SET DIR("B")="NO"
+14 SET DIR("?",1)="Enter 'Y' or 'Yes' to only show receipts with selected FMS Status"
+15 SET DIR("?",2)="Enter 'N' or 'No' if you wish to show receipts including all FMS Status"
+16 SET DIR("?")="If you select yes, you will be prompted for the FMS Status' you wish to include"
+17 DO ^DIR
+18 IF $DATA(DIRUT)
SET RETURN=-1
QUIT
+19 IF Y=0
QUIT
+20 SET RETURN=1
+21 ;
+22 ; Prompt for status' to be included. Multi-select
+23 WRITE !
+24 DO FIELD^DID(2100.1,3,"","POINTER","RCOUT")
+25 SET RCODES=RCOUT("POINTER")
+26 ; Add pseudo codes to list for "NOT ENTERED" and "ON LINE ENTRY" returned by FMSSTAT^RCDPUREC
+27 IF $EXTRACT(RCODES,$LENGTH(RCODES))'=";"
SET RCODES=RCODES_";"
+28 SET RCODES=RCODES_"O:ON LINE ENTRY;N:NOT ENTERED"
+29 KILL DIR
+30 SET DIR(0)="SOA^"_RCODES
+31 SET DIR("A")="Select an FMS Status to include in the report: "
+32 KILL DIR("?")
+33 SET DIR("?",1)="Select an FMS Status to show in the report."
+34 SET DIR("?",2)="You will be prompted multiple times, until you hit ENTER"
+35 SET DIR("?")="without making a selection."
+36 SET QUIT=0
+37 FOR
Begin DoDot:1
+38 WRITE !
+39 DO ^DIR
+40 IF $DATA(DTOUT)!$DATA(DUOUT)
KILL RETURN
SET RETURN=-1
SET QUIT=1
QUIT
+41 IF Y=""
SET QUIT=1
QUIT
+42 SET RETURN(Y(0))=""
+43 ; Rebuid DIR(0) to only include codes not yet selected
+44 SET DIR(0)=$$BLDS(RCODES,.RETURN)
+45 ; All status selected so stop prompting.
IF $PIECE(DIR(0),"^",2)=""
SET QUIT=1
End DoDot:1
IF QUIT
QUIT
+46 IF RETURN=-1
QUIT
+47 ; If no FMS Status' were selected, don't filter by it.
+48 ;
IF $ORDER(RETURN(""))=""
Begin DoDot:1
+49 SET RETURN=0
+50 WRITE !!,"No FMS Status' were selected. All FMS Status' will be shown",!
End DoDot:1
+51 QUIT
+52 ;
SELFILTT(RETURN) ; Ask if user want to filter by Payment Type. If yes get list of types.
+1 ; Input: None
+2 ; Output: RETURN, passed by reference
+3 ; RETURN - 1=Filter by FMS Status, 0=Don't
+4 ; RETURN(STATUS) - array of FMS Status to include in the report
+5 ;
+6 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,RCODES,RCIEN,RCNAME,QUIT,X,Y
+7 KILL RETURN
+8 SET RETURN=0
+9 ;
+10 WRITE !
+11 SET DIR(0)="YA"
+12 SET DIR("A")="Filter by Payment Type? (Y/N): "
+13 SET DIR("B")="NO"
+14 SET DIR("?",1)="Enter 'Y' or 'Yes' to only show receipts with selected Payment Types"
+15 SET DIR("?",2)="Enter 'N' or 'No' if you wish to show receipts including all Payment Types"
+16 SET DIR("?")="If you select yes, you will be prompted for the Payment Types you wish to include"
+17 DO ^DIR
+18 IF $DATA(DIRUT)
SET RETURN=-1
QUIT
+19 IF Y=0
QUIT
+20 SET RETURN=1
+21 ;
+22 ; Prompt for types to be included. Multi-select
+23 WRITE !
+24 KILL DIR
+25 ; Present payment types as a set of codes to streamline user interface/selection/help
+26 SET (RCODES,RCNAME)=""
+27 ;
FOR
SET RCNAME=$ORDER(^RC(341.1,"B",RCNAME))
if RCNAME=""
QUIT
Begin DoDot:1
+28 ;
SET RCIEN=0
FOR
SET RCIEN=$ORDER(^RC(341.1,"B",RCNAME,RCIEN))
if 'RCIEN
QUIT
Begin DoDot:2
+29 ;
IF $$GET1^DIQ(341.1,RCIEN_",",.06,"I")=1
Begin DoDot:3
+30 SET RCODES=RCODES_":"_$$GET1^DIQ(341.1,RCIEN_",",.01,"E")_";"
End DoDot:3
End DoDot:2
End DoDot:1
+31 SET DIR(0)="SOA^"_RCODES
+32 SET DIR("A")="Select a Payment Type to include in the report: "
+33 KILL DIR("?")
+34 SET DIR("?",1)="Select an Payment Type to include in the report."
+35 SET DIR("?",2)="You will be prompted multiple times, until you hit ENTER"
+36 SET DIR("?")="without making a selection."
+37 SET QUIT=0
+38 FOR
Begin DoDot:1
+39 WRITE !
+40 DO ^DIR
+41 IF $DATA(DTOUT)!$DATA(DUOUT)
KILL RETURN
SET RETURN=-1
SET QUIT=1
QUIT
+42 IF $GET(Y(0))=""
SET QUIT=1
QUIT
+43 SET RETURN(Y(0))=""
+44 ; Rebuid DIR(0) to only include codes not yet selected
+45 SET DIR(0)=$$BLDS(RCODES,.RETURN)
+46 ; All status selected so stop prompting.
IF $PIECE(DIR(0),"^",2)=""
SET QUIT=1
End DoDot:1
IF QUIT
QUIT
+47 ;
+48 IF RETURN=-1
QUIT
+49 ; If no payment types were selected, don't filter by it.
+50 ;
IF $ORDER(RETURN(""))=""
Begin DoDot:1
+51 SET RETURN=0
+52 WRITE !!,"No Payment Types were selected. Filter will not be used",!
End DoDot:1
+53 QUIT
+54 ;
BLDS(CODES,PICKED) ; Build DIR(0) string taking into account codes already picked.
+1 ; Input: CODES - Set of codes string in fileman format e.g. A:Apple;B:Ball;
+2 ; PICKED - Array of values already picked, subscripted by external value e.g. PICKED("Apple")=""
+3 ; Return: RETURN in DIR(0) format. Set of codes that only includes ones not picked.
+4 ; e.g "SAO^B:Ball"
+5 ;
+6 NEW RETURN
+7 SET RETURN="SOA^"
+8 ;
FOR J=1:1:$LENGTH(CODES,";")
Begin DoDot:1
+9 SET X=$PIECE($PIECE(CODES,";",J),":",2)
+10 IF X'=""
IF '$DATA(PICKED(X))
SET RETURN=RETURN_$PIECE(CODES,";",J)_";"
End DoDot:1
+11 QUIT RETURN
+12 ;
HDR ; Compile header into ^TMP for use in ListMan or report
+1 ; Input: None
+2 ; Output: Header information in ^TMP($J,"RCDPRLIS","HDR",n) for us in report or ListMan formats
+3 NEW K,XX
+4 SET ^TMP($JOB,"RCDPRLIS","HDR",1)="LIST OF RECEIPTS REPORT"
+5 SET XX=" DATE RANGE : "_DATEDIS1_" TO "_DATEDIS2_" "
+6 SET XX=XX_"SORT ORDER: "_$SELECT(RCSORT="D":"DATE OPENED",RCSORT="F":"FMS STATUS",1:"PAYMENT TYPE")
+7 SET ^TMP($JOB,"RCDPRLIS","HDR",2)=XX
+8 ;
+9 ;
IF 'RCFILTF
Begin DoDot:1
+10 SET XX="ALL"
End DoDot:1
+11 ;
IF '$TEST
Begin DoDot:1
+12 SET XX=""
+13 SET K=""
FOR
SET K=$ORDER(RCFILTF(K))
if K=""
QUIT
if XX'=""
SET XX=XX_"; "
SET XX=XX_K
End DoDot:1
+14 SET ^TMP($JOB,"RCDPRLIS","HDR",3)=" FMS STATUS : "_$SELECT($LENGTH(XX)>63:"SELECTED",1:XX)
+15 ;
+16 ;
IF 'RCFILTT
Begin DoDot:1
+17 SET XX="ALL"
End DoDot:1
+18 ;
IF '$TEST
Begin DoDot:1
+19 SET XX=""
+20 SET K=""
FOR
SET K=$ORDER(RCFILTT(K))
if K=""
QUIT
if XX'=""
SET XX=XX_"; "
SET XX=XX_K
End DoDot:1
+21 SET ^TMP($JOB,"RCDPRLIS","HDR",4)=" PAYMENT TYPES: "_$SELECT($LENGTH(XX)>63:"SELECTED",1:XX)
+22 ; PRCA*4.5*332
+23 SET ^TMP($JOB,"RCDPRLIS","HDR",5)="DATE RECEIPT TYPE USER COUNT AMOUNT FMS CR DOC STATUS"
+24 WRITE !,RCRJLINE
+25 QUIT
+26 ;
H ; header
+1 NEW %
+2 SET %=NOW_" PAGE "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+3 WRITE $CHAR(13),^TMP($JOB,"RCDPRLIS","HDR",1),?(80-$LENGTH(%)),%
+4 WRITE !,^TMP($JOB,"RCDPRLIS","HDR",2)
+5 WRITE !,^TMP($JOB,"RCDPRLIS","HDR",3)
+6 WRITE !,^TMP($JOB,"RCDPRLIS","HDR",4)
+7 WRITE !,^TMP($JOB,"RCDPRLIS","HDR",5)
+8 WRITE !,RCRJLINE
+9 QUIT
