RCRJRCOU ;WISC/RFJ-ar data collector summary report ;1 Mar 97
;;4.5;Accounts Receivable;**103,320,335,338,351**;Mar 20, 1995;Build 15
;;Per VA Directive 6402, this routine should not be modified.
Q
; IA - 4398 FIRST^VAUTOMA
; 4385 $$MRATYPE^IBCEMU2
;
;
;ARDC detailed report - Modified to print directly as per PRCA*4.5*320 (HAPE FY16 RRE)
; a MailMan message is no longer generated by this routine !
; Called by VistA Option - PRCA ARDC REPORT (ARDC Detail Report)
;
START ; Entry point from the Option
N VAUTSTR,VAUTNI,DIC,Y,SCREEN,EXCEL,VAUTC,QUIT,DTFRMTO,BGDT,RCSTDT
;
S QUIT=0
N TXT,MSG F TXT=1:1:12 S MSG=$T(MENU+TXT) W !,?5,$P(MSG,";;",2)
S SCREEN="^16^18^32^33^40^42^",DIC="^PRCA(430.3,",VAUTNI=2,VAUTSTR="Status",VAUTVB="VAUTC",DIC("S")="I SCREEN[(U_Y_U)" D FIRST^VAUTOMA
I VAUTC=1 F I=2:1:7 S VAUTC($P(SCREEN,U,I))=$P(^PRCA(430.3,$P(SCREEN,U,I),0),U) ;set array equal to the screen if ALL was selected
Q:'$D(VAUTC)!(Y=-1)
N TXT,MSG W ! F TXT=1:1:12 S MSG=$T(DESCTEXT+TXT) W !,?3,$P(MSG,";;",2)
W !!,?10,"<< Checking available dates. Please wait >>"
D FIRST ;Get earliest date for selected Status
W !!,"The earliest date on file for selected status is: ",$G(BGDT)
S DTFRMTO=$$DTFRMTO Q:'DTFRMTO ;Get date range for report
S EXCEL=0,PROMPT="CAPTURE Report data to an Excel Document?",DIR(0)="Y",DIR("?")="^D HEXC^RCRJRCOU"
S EXCEL=$$SELECT^RCTCSJR(PROMPT,"NO") I "01"'[EXCEL Q
I EXCEL=1 D EXCMSG^RCTCSJR ; Display Excel display message
I 'EXCEL W !!,"This report requires 132 characters",!
K IOP,IO("Q") S %ZIS="MQ",%ZIS("B")="" D ^%ZIS Q:POP
I $D(IO("Q")) D Q
.S ZTDESC="ARDC Detail Report",ZTRTN="DQ^RCRJRCOU"
.S ZTSAVE("VAUTC*")="",ZTSAVE("RCRET")="",ZTSAVE("DTFRMTO")="",ZTSAVE("ZTREQ")="@",ZTSAVE("EXCEL")=""
.D ^%ZTLOAD,HOME^%ZIS S QUIT=1
W !!,"<*> please wait <*>"
;
DQ ; generate user detailed report
N DATEEND,RCDATE,BILLDA,DATA,RCLINE,REPTDATA,Y,RCBILLN,RCDTAC,RCCAT,RCSTAT,TRANTYP,RCTOT,RCPRIN,RCRSC,PRCASITE,VAUTVB,XMNOW
N STAT,BILLDA,RCRSC,RECORD,RCBAL,ARACTDT,DATEMOYR,MRATYPE,POP,RCFUND,RCOTHER,TYPE,RCOUT,CURDT,DTFRM,DTFROM,DTTO,RCRET,LIST,ERR
N RCACCRD,RCRHITYP
;
S (RCDATE,DTFRM)=$$FMADD^XLFDT(+$P(DTFRMTO,U,2)),DTTO=$P(DTFRMTO,U,3),CURDT=0
S XMNOW=$$NOW^XLFDT ;Capture the date and time the report was started for the header
S DATEEND=$$LDATE^RCRJR(DT),DATEMOYR=$E(DATEEND,1,5)_"00"
S PRCASITE=$$SITE^RCMSITE
S RCRET=$NA(^TMP($J,"RCRJRCOU")) K @RCRET
;
S (RCLINE,STAT)=0 F S STAT=$O(VAUTC(STAT)) Q:'STAT S RCDATE=DTFRM D
. S BILLDA=0 F S BILLDA=$O(^PRCA(430,"AC",STAT,BILLDA)) Q:'BILLDA D
..Q:$P(^PRCA(430,BILLDA,0),U,10)=""
..Q:$P(^PRCA(430,BILLDA,0),U,8)'=STAT ;Quit if the Current Status from the xref is incorrect
..S RCDATE=$P(^PRCA(430,BILLDA,0),U,10)
..Q:RCDATE<DTFRM!(RCDATE>DTTO)
.. ;As per email from the VA - We need to see all bills, not just accrued bills.
.. ;I $$ACCK^PRCAACC(BILLDA),$P($G(^PRCA(430,BILLDA,0)),"^",2)'=26 D ;from CURRENT^RCRJRCOC
.. ;
.. I $P($G(^PRCA(430,BILLDA,0)),"^",2)'=26 D ;from CURRENT^RCRJRCOC
... S DATA=$G(^PRCA(430,BILLDA,0)) Q:'DATA
... S (TYPE,TRANTYP,RCRSC,RCFUND,RCPRIN)="",RCBAL=0
... ; bill number
... ;S RCBILLN=$P($P(DATA,"^"),"-",2)
... S RCBILLN=$P(DATA,"^")
... ; date activated
... S RCDTAC=$$FMTE^XLFDT(RCDATE,"2Z")
... ; category
... S RCCAT=$P($G(^PRCA(430.2,+$P(DATA,"^",2),0)),"^")
... S RCACCRD=$$GET1^DIQ(430.2,+$P(DATA,"^",2)_",",12,"I")
... ; status
... S RCSTAT=$P($G(^PRCA(430.3,+$P(DATA,"^",8),0)),"^")
... ;PRCA*4.5*338 - re-wrote section to correctly retrieve RSCs, properly ID TRICARE, CHAMPVA BD doc types, and TORT/MRA SV doc types
... ; - grab fund and RSC from Bill instead of recalculating. Recalculate only if they are NULL
... S RCRSC=$$GET1^DIQ(430,BILLDA_",",255,"I")
... S:RCRSC="" RCRSC=$$GET1^DIQ(430,BILLDA_",",255.1)
... I $$ACCK^PRCAACC(BILLDA) S:RCRSC="" RCRSC=$$CALCRSC^RCXFMSUR(BILLDA) ; (as per CURRENT^RCRJRCOC)
... ;Fund
... S RCFUND=$$GET1^DIQ(430,BILLDA_",",203)
... I RCFUND="" S RCFUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
... S TYPE="SV21" ; Default the doc type.
... ; special type for tort feasor
... I RCCAT["TORT" S TYPE="2A" ;Using the category name to look for TORTs
... ; Get AR Date Active for bill
... S ARACTDT=+$P($P($G(^PRCA(430,BILLDA,6)),"^",21),".") ; (as per START^RCRJRBD)
... ; determine Receivable Type: 1=pre-MRA, 2=post-MRA Medicre, 3=post-MRA non-Medicare
... ; fms report type - TRANTYP variable
... S MRATYPE=$$MRATYPE^IBCEMU2(BILLDA,ARACTDT) ; (as per CURRENT^RCRJRCOC)
... ; Set TYPE to 2F for post-MRA Medicare bills or to 2L for post-MRA non-Medicare bills (for RHI receivables only)
... ; Moved TYPE set for RHI to function call to ensure Community Care RSCs are captured correctly.
... S RCRHITYP=$$RHITYPE^RCRJRCOC(RCRSC,MRATYPE,RCCAT) S:+RCRHITYP TYPE=$P(RCRHITYP,U,2)
... I 'RCACCRD S TYPE="BD" ; Non accrued have BD FMS doc types.
... S TRANTYP=$G(TYPE),REPTDATA=""
... K LIST D FIND^DIC(430,,"@;71;11;IX","M","`"_BILLDA,,,,,"LIST","ERR")
... S RCPRIN=$G(LIST("DILIST","ID",1,71)),RCBAL=$G(LIST("DILIST","ID",1,11))
... I RCBAL'>0 Q ;Don't show if current balance not greater than $0
... S RCPRIN=$J(RCPRIN,9,2),RCBAL=$J(RCBAL,10,2)
... S RCLINE=RCLINE+1 ;(record counter)
... S @RCRET@(RCLINE)=RCBILLN_U_RCDTAC_U_RCCAT_U_RCSTAT_U_TRANTYP_U_RCFUND_U_RCRSC_U_RCPRIN_U_RCBAL
; end of gathering data
;
I RCLINE=0 W !!,"***The report found no receivables that match your selection***",!! G EXIT
;
D PRINT
;
EXIT ;commom exit point
D ^%ZISC
K ^TMP($J,"RCRJRCOU")
Q
;
HDR ;Set the header
;
S PAGE=PAGE+1 U IO W @IOF
I 'EXCEL W ?14,"ARDC Detailed Report",?50,"Run Date: ",$$FMTE^XLFDT(XMNOW,"2Z"),?107,"Page:",PAGE,!
I EXCEL W U_"ARDC Detailed Report"_U_U_"Run Date: "_$$FMTE^XLFDT(XMNOW,"2Z")_U_U_U_U_"Page:"_PAGE,!
N I F I=1:1:120 W "-"
I 'EXCEL W !,"Bill#",?14,"Create",?26,"AR Category",?50,"Bill",?68,"FMS",?75,"Fund",?84,"RSC",?93,"Principal",?107,"Current"
I 'EXCEL W !,?14,"Date",?50,"Status",?75,"Type",?96,"Amount",?107,"Balance",!
I EXCEL W !,"Bill#"_U_"Create"_U_"AR Category"_U_"Bill"_U_"FMS"_U_"Fund"_U_"RSC"_U_"Principal"_U_"Current"
I EXCEL W !,U_"Date"_U_U_"Status"_U_U_"Type"_U_U_"Amount"_U_"Balance",!
N I F I=1:1:120 W "-"
Q
;
PRINT ; print records to screen or printer
N PAGE S (RCOUT,PAGE)=0,RECORD=0
F S RECORD=$O(@RCRET@(RECORD)) Q:'RECORD!(RCOUT) D
. I RECORD=1 D HDR
. I 'EXCEL,$Y+3>IOSL I ($E(IOST,1,2)="C-")&(IO=IO(0)) S DIR(0)="E" D ^DIR K DIR D
.. I $D(DTOUT)!($D(DUOUT)) S RCOUT=1 G EXIT
.. D HDR
. Q:RCOUT
. I 'EXCEL W !,$P(@RCRET@(RECORD),U),?14,$P(@RCRET@(RECORD),U,2),?26,$E($P(@RCRET@(RECORD),U,3),1,20),?50,$E($P(@RCRET@(RECORD),U,4),1,15),?68,$P(@RCRET@(RECORD),U,5)
. I 'EXCEL W ?75,$P(@RCRET@(RECORD),U,6),?84,$P(@RCRET@(RECORD),U,7),?92,$P(@RCRET@(RECORD),U,8),?104,$P(@RCRET@(RECORD),U,9)
. I EXCEL W !,$P(@RCRET@(RECORD),U)_U_$P(@RCRET@(RECORD),U,2)_U_$P(@RCRET@(RECORD),U,3)_U_$P(@RCRET@(RECORD),U,4)_U_$P(@RCRET@(RECORD),U,5)
. I EXCEL W U_$P(@RCRET@(RECORD),U,6)_U_$P(@RCRET@(RECORD),U,7)_U_$P(@RCRET@(RECORD),U,8)_U_$P(@RCRET@(RECORD),U,9)
I 'EXCEL,$E(IOST,1,2)="C-" R !!,"END OF REPORT...PRESS RETURN TO CONTINUE",X:DTIME W @IOF
Q
;
DTFRMTO(PROMPT) ;Get from and to dates (added as per PRCA*4.5*320 to be able to sort by dates for reports)
N %DT,Y,X,BEGDT,ENDDT,DTOUT,OUT,DIRUT,DUOUT,DIROUT,STATUS,BDT,STDT,STATUS
;INPUT ; PROMPT - Message to display prior to prompting for dates
;OUTPUT: 1^BEGDT^ENDDT - Data found
; 0 - User up arrowed or timed out
;If they want to show first available date for that set of Status, use this sub
S OUT=0
;W !,$G(PROMPT)
S %DT="AEX",%DT("A")="Date Range: FROM: " ;Enter Beginning Date: "
W ! D ^%DT K %DT
I Y<0 W !!,"No Date selected, quitting. ",!! Q OUT ;Quit if user time out or didn't enter valid date
S DTFROM=+Y,%DT="AEX",%DT("A")=" TO: ",%DT("B")="T" ;"TODAY"
D ^%DT
K %DT
;Quit if user time out or didn't enter valid date
I Y<0 W !!,"No Date selected, quitting. ",!! Q OUT
S DTTO=+Y,OUT=1_U_DTFROM_U_DTTO
;Switch dates if Begin Date is more recent than End Date
S:DTFROM>DTTO OUT=1_U_DTTO_U_DTFROM
Q OUT
;
HEXC ; - 'Do you want to capture data to EXCEL' prompt
W !!," Enter: 'Y' - To capture detail report data to transfer"
W !," to an Excel document"
W !," '<CR>' - To skip this option"
W !," '^' - To quit this option"
Q
FIRST ; Get 1st available date for selected status
N RCBILL
S STATUS=0,(RCBILL,BDT)="" F S STATUS=$O(VAUTC(STATUS)) Q:STATUS="" D
. S RCBILL=0 F S RCBILL=$O(^PRCA(430,"AC",STATUS,RCBILL)) Q:'RCBILL D
.. Q:$P($G(^PRCA(430,RCBILL,0)),U,10)=""
.. S RCSTDT=$P($G(^PRCA(430,RCBILL,0)),U,10)
.. I $G(BDT)="" S BDT=RCSTDT Q
.. I RCSTDT<+BDT S BDT=RCSTDT_U_STATUS ;Use earliest available date
;
S BGDT=$S(BDT'="":$$FMTE^XLFDT(+BDT,"Z2"),1:"No records on file")
Q
;;
;;
;;ARDC Detail Report, please select the status desired below:
;;
;; AC - ACTIVE(16)
;; N - NEW BILL(18)
;; R - RETURNED FOR AMENDMENT(32)
;; AM - AMENDED BILL(33)
;; S - SUSPENDED(40)
;; O - OPEN(42)
;; ALL of the above (Default, press enter)
;;
Q
DESCTEXT ;
;; This report was originally generated from the monthly background
;; process and generated a MailMan message. It can now only be run
;; manually through this option. The new data does not contain bills
;; that have been previously closed out. Note that when running the
;; new report, only specific AR current status are available.
;; There will be a note that displays the oldest bill in VistA
;; associated with these statuses for users to know which date
;; MUST be entered into the "FROM:" prompt for monthly
;; reconciliation reporting.
;; Different dates can be entered for other types of audits.
;;
;; Please run after hours when possible.
;;
Q
;
STORE(BILLDA,DATEBEG,DATEEND,ARACTDT,CATEGORY,TYPE,RCFUND,RCRSC,RCVALUE,SCREEN) ;
;called by ^RCRJRCOC to store the bills in the AR DEBT COLLECTOR DATA (430.7) file.
; BILLDA - IEN of 430
; DATEBEG - Beginning date of accounting month
; DATEEND - Ending date of accouting month
; ARACTDT - Date account activitated
; CATEGORY - Category of bill (pointer)
; TYPE - FMS Document Type (include SV or whatever)
; RCFUND - Fund
; RCRSC - Revenue Source Code
; RCVALUE - value of bill prin ^ int ^ admin ^ mf ^ cc
; SCREEN - data from OIG routine needs to be screened
;
N RCREPORT,RCDR,RCZERO,RCLIST,DIE,DR,DA,X,Y,RCDA,RCSTAT
;
Q:'$G(DATEBEG)!('$G(DATEEND))!('$G(BILLDA))
S RCSTAT=$P(^PRCA(430,BILLDA,0),"^",8)
I $G(SCREEN) Q:RCSTAT'=16&(RCSTAT'=40) ; only active and suspended
;
; Add .01 top file level entry if it doesn't exist
S RCREPORT=$O(^PRCA(430.7,"B",$E(DATEEND,1,5)_"00",0)) I 'RCREPORT D
. N DO,DIC,X,Y,RCKEEP,RCPURGE
. S DIC="^PRCA(430.7,",DIC(0)="",X=$E(DATEEND,1,5)_"00"
. S DIC("DR")=.02_"////"_DATEBEG_";.03////"_DATEEND
. D FILE^DICN
. S RCREPORT=+Y
. ; purge any reports more than 3 months old
. S RCKEEP=$E($$FMADD^XLFDT(DATEEND,-65),1,5)_"00",RCPURGE=0
. F S RCPURGE=$O(^PRCA(430.7,"B",RCPURGE)) Q:'RCPURGE!(RCPURGE'<RCKEEP) D
.. N DIK,DA
.. S DIK="^PRCA(430.7,",DA=$O(^PRCA(430.7,"B",RCPURGE,0))
.. D ^DIK
; update last date
S DIE="^PRCA(430.7,",DA=RCREPORT,DR=".04////"_$$NOW^XLFDT D ^DIE
;
; determine data for the bill
S RCDR(.02)=ARACTDT ; date bill activitated
S RCDR(.03)=CATEGORY ; AR Cateogry
S RCDR(.04)=RCSTAT ; AR Status
S:TYPE'="" RCDR(.05)=TYPE ; fms type
S RCDR(.06)=RCFUND ; Fund Type
S RCDR(.07)=RCRSC ; Revenue Source Code
S RCDR(.08)=+RCVALUE ; Principal Amount
S RCDR(.09)=RCVALUE+$P(RCVALUE,"^",2)+$P(RCVALUE,"^",3)+$P(RCVALUE,"^",4)+$P(RCVALUE,"^",5) ; Current Balance
;
; Check for new or update entry
S RCDA=$O(^PRCA(430.7,RCREPORT,1,"B",BILLDA,0))
I 'RCDA D Q
. ; add new entry
. N DO,DIC,X,Y,DA
. S DIC="^PRCA(430.7,"_RCREPORT_",1,",DIC(0)="",DA(1)=RCREPORT,X=BILLDA
. S DIC("DR")="",X=0
. F S X=$O(RCDR(X)) Q:'X S DIC("DR")=DIC("DR")_X_"////"_RCDR(X)_";"
. S DIC("DR")=$E(DIC("DR"),1,$L(DIC("DR"))-1)
. S X=BILLDA
. D FILE^DICN
;
; update entry (if it already exited)
S DIE="^PRCA(430.7,"_RCREPORT_",1,",DA=RCDA,DA(1)=RCREPORT
S DR="",X=0
F S X=$O(RCDR(X)) Q:'X S DR=DR_X_"////"_RCDR(X)_";"
S DR=$E(DR,1,$L(DR)-1) D:'$G(SCREEN) ^DIE
Q
;
EN ; option entry point to run the report
N RCREPORT,EXCEL,RCPROMPT,X,Y,DTOUT,DUOUT,DIR,ZTDESC,ZTSAVE,ZTRTN,ZTSK
;
W !,"Select which accounting month/year for the ARDC Report"
S DIC="^PRCA(430.7,",DIC(0)="AEMNQ" D ^DIC Q:Y<1
S RCREPORT=+Y
S EXCEL=0,RCPROMPT="CAPTURE Report data to an Excel Document?",DIR(0)="Y",DIR("?")="^D HEXC^RCRJRCOU"
S EXCEL=$$SELECT^RCTCSJR(RCPROMPT,"NO") I "01"'[EXCEL Q
I EXCEL=1 D EXCMSG^RCTCSJR ; Display Excel display message
I 'EXCEL W !!,"This report requires 132 characters",!
K IOP,IO("Q") S %ZIS="MQ",%ZIS("B")="" D ^%ZIS Q:POP
I $D(IO("Q")) D Q
.S ZTDESC="ARDC Detail Report",ZTRTN="DQQ^RCRJRCOU"
.S (ZTSAVE("RC*"),ZTSAVE("EXCEL"))="",ZTSAVE("ZTREQ")="@"
.D ^%ZTLOAD,HOME^%ZIS S QUIT=1
;
DQQ ; Print the report
N XMNOW,PAGE,RCOUT,RCREC,RCSP
S XMNOW=$$NOW^XLFDT ;Capture the date and time the report was started for the header
S (RCOUT,PAGE)=0
S RCREC=0 F S RCREC=$O(^PRCA(430.7,RCREPORT,1,RCREC)) Q:'RCREC!(RCOUT) D
. N RCARRAY
. I PAGE<1 D HDR
. I 'EXCEL,$Y+3>IOSL I ($E(IOST,1,2)="C-")&(IO=IO(0)) S DIR(0)="E" D ^DIR K DIR D
.. I $D(DTOUT)!($D(DUOUT)) S RCOUT=1 G EXIT
.. D HDR
. Q:RCOUT
. ; extract data from file in external form
. D GETS^DIQ(430.71,RCREC_","_RCREPORT_",","*","","RCARRAY")
. S RCSP="0^14^26^50^68^75^84^92^104"
. W ! F X=.01:.01:.09 D
.. W:'EXCEL @("?"_$P(RCSP,"^",X*100))
.. S Y=$S(X=.03:20,X=.04:15,1:999)
.. W $E($G(RCARRAY(430.71,RCREC_","_RCREPORT_",",X)),1,Y)
.. I EXCEL,X'=.09 W "^"
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCRJRCOU 14323 printed Apr 09, 2024@20:54:03 Page 2
RCRJRCOU ;WISC/RFJ-ar data collector summary report ;1 Mar 97
+1 ;;4.5;Accounts Receivable;**103,320,335,338,351**;Mar 20, 1995;Build 15
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ; IA - 4398 FIRST^VAUTOMA
+5 ; 4385 $$MRATYPE^IBCEMU2
+6 ;
+7 ;
+8 ;ARDC detailed report - Modified to print directly as per PRCA*4.5*320 (HAPE FY16 RRE)
+9 ; a MailMan message is no longer generated by this routine !
+10 ; Called by VistA Option - PRCA ARDC REPORT (ARDC Detail Report)
+11 ;
START ; Entry point from the Option
+1 NEW VAUTSTR,VAUTNI,DIC,Y,SCREEN,EXCEL,VAUTC,QUIT,DTFRMTO,BGDT,RCSTDT
+2 ;
+3 SET QUIT=0
+4 NEW TXT,MSG
FOR TXT=1:1:12
SET MSG=$TEXT(MENU+TXT)
WRITE !,?5,$PIECE(MSG,";;",2)
+5 SET SCREEN="^16^18^32^33^40^42^"
SET DIC="^PRCA(430.3,"
SET VAUTNI=2
SET VAUTSTR="Status"
SET VAUTVB="VAUTC"
SET DIC("S")="I SCREEN[(U_Y_U)"
DO FIRST^VAUTOMA
+6 ;set array equal to the screen if ALL was selected
IF VAUTC=1
FOR I=2:1:7
SET VAUTC($PIECE(SCREEN,U,I))=$PIECE(^PRCA(430.3,$PIECE(SCREEN,U,I),0),U)
+7 if '$DATA(VAUTC)!(Y=-1)
QUIT
+8 NEW TXT,MSG
WRITE !
FOR TXT=1:1:12
SET MSG=$TEXT(DESCTEXT+TXT)
WRITE !,?3,$PIECE(MSG,";;",2)
+9 WRITE !!,?10,"<< Checking available dates. Please wait >>"
+10 ;Get earliest date for selected Status
DO FIRST
+11 WRITE !!,"The earliest date on file for selected status is: ",$GET(BGDT)
+12 ;Get date range for report
SET DTFRMTO=$$DTFRMTO
if 'DTFRMTO
QUIT
+13 SET EXCEL=0
SET PROMPT="CAPTURE Report data to an Excel Document?"
SET DIR(0)="Y"
SET DIR("?")="^D HEXC^RCRJRCOU"
+14 SET EXCEL=$$SELECT^RCTCSJR(PROMPT,"NO")
IF "01"'[EXCEL
QUIT
+15 ; Display Excel display message
IF EXCEL=1
DO EXCMSG^RCTCSJR
+16 IF 'EXCEL
WRITE !!,"This report requires 132 characters",!
+17 KILL IOP,IO("Q")
SET %ZIS="MQ"
SET %ZIS("B")=""
DO ^%ZIS
if POP
QUIT
+18 IF $DATA(IO("Q"))
Begin DoDot:1
+19 SET ZTDESC="ARDC Detail Report"
SET ZTRTN="DQ^RCRJRCOU"
+20 SET ZTSAVE("VAUTC*")=""
SET ZTSAVE("RCRET")=""
SET ZTSAVE("DTFRMTO")=""
SET ZTSAVE("ZTREQ")="@"
SET ZTSAVE("EXCEL")=""
+21 DO ^%ZTLOAD
DO HOME^%ZIS
SET QUIT=1
End DoDot:1
QUIT
+22 WRITE !!,"<*> please wait <*>"
+23 ;
DQ ; generate user detailed report
+1 NEW DATEEND,RCDATE,BILLDA,DATA,RCLINE,REPTDATA,Y,RCBILLN,RCDTAC,RCCAT,RCSTAT,TRANTYP,RCTOT,RCPRIN,RCRSC,PRCASITE,VAUTVB,XMNOW
+2 NEW STAT,BILLDA,RCRSC,RECORD,RCBAL,ARACTDT,DATEMOYR,MRATYPE,POP,RCFUND,RCOTHER,TYPE,RCOUT,CURDT,DTFRM,DTFROM,DTTO,RCRET,LIST,ERR
+3 NEW RCACCRD,RCRHITYP
+4 ;
+5 SET (RCDATE,DTFRM)=$$FMADD^XLFDT(+$PIECE(DTFRMTO,U,2))
SET DTTO=$PIECE(DTFRMTO,U,3)
SET CURDT=0
+6 ;Capture the date and time the report was started for the header
SET XMNOW=$$NOW^XLFDT
+7 SET DATEEND=$$LDATE^RCRJR(DT)
SET DATEMOYR=$EXTRACT(DATEEND,1,5)_"00"
+8 SET PRCASITE=$$SITE^RCMSITE
+9 SET RCRET=$NAME(^TMP($JOB,"RCRJRCOU"))
KILL @RCRET
+10 ;
+11 SET (RCLINE,STAT)=0
FOR
SET STAT=$ORDER(VAUTC(STAT))
if 'STAT
QUIT
SET RCDATE=DTFRM
Begin DoDot:1
+12 SET BILLDA=0
FOR
SET BILLDA=$ORDER(^PRCA(430,"AC",STAT,BILLDA))
if 'BILLDA
QUIT
Begin DoDot:2
+13 if $PIECE(^PRCA(430,BILLDA,0),U,10)=""
QUIT
+14 ;Quit if the Current Status from the xref is incorrect
if $PIECE(^PRCA(430,BILLDA,0),U,8)'=STAT
QUIT
+15 SET RCDATE=$PIECE(^PRCA(430,BILLDA,0),U,10)
+16 if RCDATE<DTFRM!(RCDATE>DTTO)
QUIT
+17 ;As per email from the VA - We need to see all bills, not just accrued bills.
+18 ;I $$ACCK^PRCAACC(BILLDA),$P($G(^PRCA(430,BILLDA,0)),"^",2)'=26 D ;from CURRENT^RCRJRCOC
+19 ;
+20 ;from CURRENT^RCRJRCOC
IF $PIECE($GET(^PRCA(430,BILLDA,0)),"^",2)'=26
Begin DoDot:3
+21 SET DATA=$GET(^PRCA(430,BILLDA,0))
if 'DATA
QUIT
+22 SET (TYPE,TRANTYP,RCRSC,RCFUND,RCPRIN)=""
SET RCBAL=0
+23 ; bill number
+24 ;S RCBILLN=$P($P(DATA,"^"),"-",2)
+25 SET RCBILLN=$PIECE(DATA,"^")
+26 ; date activated
+27 SET RCDTAC=$$FMTE^XLFDT(RCDATE,"2Z")
+28 ; category
+29 SET RCCAT=$PIECE($GET(^PRCA(430.2,+$PIECE(DATA,"^",2),0)),"^")
+30 SET RCACCRD=$$GET1^DIQ(430.2,+$PIECE(DATA,"^",2)_",",12,"I")
+31 ; status
+32 SET RCSTAT=$PIECE($GET(^PRCA(430.3,+$PIECE(DATA,"^",8),0)),"^")
+33 ;PRCA*4.5*338 - re-wrote section to correctly retrieve RSCs, properly ID TRICARE, CHAMPVA BD doc types, and TORT/MRA SV doc types
+34 ; - grab fund and RSC from Bill instead of recalculating. Recalculate only if they are NULL
+35 SET RCRSC=$$GET1^DIQ(430,BILLDA_",",255,"I")
+36 if RCRSC=""
SET RCRSC=$$GET1^DIQ(430,BILLDA_",",255.1)
+37 ; (as per CURRENT^RCRJRCOC)
IF $$ACCK^PRCAACC(BILLDA)
if RCRSC=""
SET RCRSC=$$CALCRSC^RCXFMSUR(BILLDA)
+38 ;Fund
+39 SET RCFUND=$$GET1^DIQ(430,BILLDA_",",203)
+40 IF RCFUND=""
SET RCFUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
+41 ; Default the doc type.
SET TYPE="SV21"
+42 ; special type for tort feasor
+43 ;Using the category name to look for TORTs
IF RCCAT["TORT"
SET TYPE="2A"
+44 ; Get AR Date Active for bill
+45 ; (as per START^RCRJRBD)
SET ARACTDT=+$PIECE($PIECE($GET(^PRCA(430,BILLDA,6)),"^",21),".")
+46 ; determine Receivable Type: 1=pre-MRA, 2=post-MRA Medicre, 3=post-MRA non-Medicare
+47 ; fms report type - TRANTYP variable
+48 ; (as per CURRENT^RCRJRCOC)
SET MRATYPE=$$MRATYPE^IBCEMU2(BILLDA,ARACTDT)
+49 ; Set TYPE to 2F for post-MRA Medicare bills or to 2L for post-MRA non-Medicare bills (for RHI receivables only)
+50 ; Moved TYPE set for RHI to function call to ensure Community Care RSCs are captured correctly.
+51 SET RCRHITYP=$$RHITYPE^RCRJRCOC(RCRSC,MRATYPE,RCCAT)
if +RCRHITYP
SET TYPE=$PIECE(RCRHITYP,U,2)
+52 ; Non accrued have BD FMS doc types.
IF 'RCACCRD
SET TYPE="BD"
+53 SET TRANTYP=$GET(TYPE)
SET REPTDATA=""
+54 KILL LIST
DO FIND^DIC(430,,"@;71;11;IX","M","`"_BILLDA,,,,,"LIST","ERR")
+55 SET RCPRIN=$GET(LIST("DILIST","ID",1,71))
SET RCBAL=$GET(LIST("DILIST","ID",1,11))
+56 ;Don't show if current balance not greater than $0
IF RCBAL'>0
QUIT
+57 SET RCPRIN=$JUSTIFY(RCPRIN,9,2)
SET RCBAL=$JUSTIFY(RCBAL,10,2)
+58 ;(record counter)
SET RCLINE=RCLINE+1
+59 SET @RCRET@(RCLINE)=RCBILLN_U_RCDTAC_U_RCCAT_U_RCSTAT_U_TRANTYP_U_RCFUND_U_RCRSC_U_RCPRIN_U_RCBAL
End DoDot:3
End DoDot:2
End DoDot:1
+60 ; end of gathering data
+61 ;
+62 IF RCLINE=0
WRITE !!,"***The report found no receivables that match your selection***",!!
GOTO EXIT
+63 ;
+64 DO PRINT
+65 ;
EXIT ;commom exit point
+1 DO ^%ZISC
+2 KILL ^TMP($JOB,"RCRJRCOU")
+3 QUIT
+4 ;
HDR ;Set the header
+1 ;
+2 SET PAGE=PAGE+1
USE IO
WRITE @IOF
+3 IF 'EXCEL
WRITE ?14,"ARDC Detailed Report",?50,"Run Date: ",$$FMTE^XLFDT(XMNOW,"2Z"),?107,"Page:",PAGE,!
+4 IF EXCEL
WRITE U_"ARDC Detailed Report"_U_U_"Run Date: "_$$FMTE^XLFDT(XMNOW,"2Z")_U_U_U_U_"Page:"_PAGE,!
+5 NEW I
FOR I=1:1:120
WRITE "-"
+6 IF 'EXCEL
WRITE !,"Bill#",?14,"Create",?26,"AR Category",?50,"Bill",?68,"FMS",?75,"Fund",?84,"RSC",?93,"Principal",?107,"Current"
+7 IF 'EXCEL
WRITE !,?14,"Date",?50,"Status",?75,"Type",?96,"Amount",?107,"Balance",!
+8 IF EXCEL
WRITE !,"Bill#"_U_"Create"_U_"AR Category"_U_"Bill"_U_"FMS"_U_"Fund"_U_"RSC"_U_"Principal"_U_"Current"
+9 IF EXCEL
WRITE !,U_"Date"_U_U_"Status"_U_U_"Type"_U_U_"Amount"_U_"Balance",!
+10 NEW I
FOR I=1:1:120
WRITE "-"
+11 QUIT
+12 ;
PRINT ; print records to screen or printer
+1 NEW PAGE
SET (RCOUT,PAGE)=0
SET RECORD=0
+2 FOR
SET RECORD=$ORDER(@RCRET@(RECORD))
if 'RECORD!(RCOUT)
QUIT
Begin DoDot:1
+3 IF RECORD=1
DO HDR
+4 IF 'EXCEL
IF $Y+3>IOSL
IF ($EXTRACT(IOST,1,2)="C-")&(IO=IO(0))
SET DIR(0)="E"
DO ^DIR
KILL DIR
Begin DoDot:2
+5 IF $DATA(DTOUT)!($DATA(DUOUT))
SET RCOUT=1
GOTO EXIT
+6 DO HDR
End DoDot:2
+7 if RCOUT
QUIT
+8 IF 'EXCEL
WRITE !,$PIECE(@RCRET@(RECORD),U),?14,$PIECE(@RCRET@(RECORD),U,2),?26,$EXTRACT($PIECE(@RCRET@(RECORD),U,3),1,20),?50,$EXTRACT($PIECE(@RCRET@(RECORD),U,4),1,15),?68,$PIECE(@RCRET@(RECORD),U,5)
+9 IF 'EXCEL
WRITE ?75,$PIECE(@RCRET@(RECORD),U,6),?84,$PIECE(@RCRET@(RECORD),U,7),?92,$PIECE(@RCRET@(RECORD),U,8),?104,$PIECE(@RCRET@(RECORD),U,9)
+10 IF EXCEL
WRITE !,$PIECE(@RCRET@(RECORD),U)_U_$PIECE(@RCRET@(RECORD),U,2)_U_$PIECE(@RCRET@(RECORD),U,3)_U_$PIECE(@RCRET@(RECORD),U,4)_U_$PIECE(@RCRET@(RECORD),U,5)
+11 IF EXCEL
WRITE U_$PIECE(@RCRET@(RECORD),U,6)_U_$PIECE(@RCRET@(RECORD),U,7)_U_$PIECE(@RCRET@(RECORD),U,8)_U_$PIECE(@RCRET@(RECORD),U,9)
End DoDot:1
+12 IF 'EXCEL
IF $EXTRACT(IOST,1,2)="C-"
READ !!,"END OF REPORT...PRESS RETURN TO CONTINUE",X:DTIME
WRITE @IOF
+13 QUIT
+14 ;
DTFRMTO(PROMPT) ;Get from and to dates (added as per PRCA*4.5*320 to be able to sort by dates for reports)
+1 NEW %DT,Y,X,BEGDT,ENDDT,DTOUT,OUT,DIRUT,DUOUT,DIROUT,STATUS,BDT,STDT,STATUS
+2 ;INPUT ; PROMPT - Message to display prior to prompting for dates
+3 ;OUTPUT: 1^BEGDT^ENDDT - Data found
+4 ; 0 - User up arrowed or timed out
+5 ;If they want to show first available date for that set of Status, use this sub
+6 SET OUT=0
+7 ;W !,$G(PROMPT)
+8 ;Enter Beginning Date: "
SET %DT="AEX"
SET %DT("A")="Date Range: FROM: "
+9 WRITE !
DO ^%DT
KILL %DT
+10 ;Quit if user time out or didn't enter valid date
IF Y<0
WRITE !!,"No Date selected, quitting. ",!!
QUIT OUT
+11 ;"TODAY"
SET DTFROM=+Y
SET %DT="AEX"
SET %DT("A")=" TO: "
SET %DT("B")="T"
+12 DO ^%DT
+13 KILL %DT
+14 ;Quit if user time out or didn't enter valid date
+15 IF Y<0
WRITE !!,"No Date selected, quitting. ",!!
QUIT OUT
+16 SET DTTO=+Y
SET OUT=1_U_DTFROM_U_DTTO
+17 ;Switch dates if Begin Date is more recent than End Date
+18 if DTFROM>DTTO
SET OUT=1_U_DTTO_U_DTFROM
+19 QUIT OUT
+20 ;
HEXC ; - 'Do you want to capture data to EXCEL' prompt
+1 WRITE !!," Enter: 'Y' - To capture detail report data to transfer"
+2 WRITE !," to an Excel document"
+3 WRITE !," '<CR>' - To skip this option"
+4 WRITE !," '^' - To quit this option"
+5 QUIT
FIRST ; Get 1st available date for selected status
+1 NEW RCBILL
+2 SET STATUS=0
SET (RCBILL,BDT)=""
FOR
SET STATUS=$ORDER(VAUTC(STATUS))
if STATUS=""
QUIT
Begin DoDot:1
+3 SET RCBILL=0
FOR
SET RCBILL=$ORDER(^PRCA(430,"AC",STATUS,RCBILL))
if 'RCBILL
QUIT
Begin DoDot:2
+4 if $PIECE($GET(^PRCA(430,RCBILL,0)),U,10)=""
QUIT
+5 SET RCSTDT=$PIECE($GET(^PRCA(430,RCBILL,0)),U,10)
+6 IF $GET(BDT)=""
SET BDT=RCSTDT
QUIT
+7 ;Use earliest available date
IF RCSTDT<+BDT
SET BDT=RCSTDT_U_STATUS
End DoDot:2
End DoDot:1
+8 ;
+9 SET BGDT=$SELECT(BDT'="":$$FMTE^XLFDT(+BDT,"Z2"),1:"No records on file")
+10 QUIT
+1 ;;
+2 ;;
+3 ;;ARDC Detail Report, please select the status desired below:
+4 ;;
+5 ;; AC - ACTIVE(16)
+6 ;; N - NEW BILL(18)
+7 ;; R - RETURNED FOR AMENDMENT(32)
+8 ;; AM - AMENDED BILL(33)
+9 ;; S - SUSPENDED(40)
+10 ;; O - OPEN(42)
+11 ;; ALL of the above (Default, press enter)
+12 ;;
+13 QUIT
DESCTEXT ;
+1 ;; This report was originally generated from the monthly background
+2 ;; process and generated a MailMan message. It can now only be run
+3 ;; manually through this option. The new data does not contain bills
+4 ;; that have been previously closed out. Note that when running the
+5 ;; new report, only specific AR current status are available.
+6 ;; There will be a note that displays the oldest bill in VistA
+7 ;; associated with these statuses for users to know which date
+8 ;; MUST be entered into the "FROM:" prompt for monthly
+9 ;; reconciliation reporting.
+10 ;; Different dates can be entered for other types of audits.
+11 ;;
+12 ;; Please run after hours when possible.
+13 ;;
+14 QUIT
+15 ;
STORE(BILLDA,DATEBEG,DATEEND,ARACTDT,CATEGORY,TYPE,RCFUND,RCRSC,RCVALUE,SCREEN) ;
+1 ;called by ^RCRJRCOC to store the bills in the AR DEBT COLLECTOR DATA (430.7) file.
+2 ; BILLDA - IEN of 430
+3 ; DATEBEG - Beginning date of accounting month
+4 ; DATEEND - Ending date of accouting month
+5 ; ARACTDT - Date account activitated
+6 ; CATEGORY - Category of bill (pointer)
+7 ; TYPE - FMS Document Type (include SV or whatever)
+8 ; RCFUND - Fund
+9 ; RCRSC - Revenue Source Code
+10 ; RCVALUE - value of bill prin ^ int ^ admin ^ mf ^ cc
+11 ; SCREEN - data from OIG routine needs to be screened
+12 ;
+13 NEW RCREPORT,RCDR,RCZERO,RCLIST,DIE,DR,DA,X,Y,RCDA,RCSTAT
+14 ;
+15 if '$GET(DATEBEG)!('$GET(DATEEND))!('$GET(BILLDA))
QUIT
+16 SET RCSTAT=$PIECE(^PRCA(430,BILLDA,0),"^",8)
+17 ; only active and suspended
IF $GET(SCREEN)
if RCSTAT'=16&(RCSTAT'=40)
QUIT
+18 ;
+19 ; Add .01 top file level entry if it doesn't exist
+20 SET RCREPORT=$ORDER(^PRCA(430.7,"B",$EXTRACT(DATEEND,1,5)_"00",0))
IF 'RCREPORT
Begin DoDot:1
+21 NEW DO,DIC,X,Y,RCKEEP,RCPURGE
+22 SET DIC="^PRCA(430.7,"
SET DIC(0)=""
SET X=$EXTRACT(DATEEND,1,5)_"00"
+23 SET DIC("DR")=.02_"////"_DATEBEG_";.03////"_DATEEND
+24 DO FILE^DICN
+25 SET RCREPORT=+Y
+26 ; purge any reports more than 3 months old
+27 SET RCKEEP=$EXTRACT($$FMADD^XLFDT(DATEEND,-65),1,5)_"00"
SET RCPURGE=0
+28 FOR
SET RCPURGE=$ORDER(^PRCA(430.7,"B",RCPURGE))
if 'RCPURGE!(RCPURGE'<RCKEEP)
QUIT
Begin DoDot:2
+29 NEW DIK,DA
+30 SET DIK="^PRCA(430.7,"
SET DA=$ORDER(^PRCA(430.7,"B",RCPURGE,0))
+31 DO ^DIK
End DoDot:2
End DoDot:1
+32 ; update last date
+33 SET DIE="^PRCA(430.7,"
SET DA=RCREPORT
SET DR=".04////"_$$NOW^XLFDT
DO ^DIE
+34 ;
+35 ; determine data for the bill
+36 ; date bill activitated
SET RCDR(.02)=ARACTDT
+37 ; AR Cateogry
SET RCDR(.03)=CATEGORY
+38 ; AR Status
SET RCDR(.04)=RCSTAT
+39 ; fms type
if TYPE'=""
SET RCDR(.05)=TYPE
+40 ; Fund Type
SET RCDR(.06)=RCFUND
+41 ; Revenue Source Code
SET RCDR(.07)=RCRSC
+42 ; Principal Amount
SET RCDR(.08)=+RCVALUE
+43 ; Current Balance
SET RCDR(.09)=RCVALUE+$PIECE(RCVALUE,"^",2)+$PIECE(RCVALUE,"^",3)+$PIECE(RCVALUE,"^",4)+$PIECE(RCVALUE,"^",5)
+44 ;
+45 ; Check for new or update entry
+46 SET RCDA=$ORDER(^PRCA(430.7,RCREPORT,1,"B",BILLDA,0))
+47 IF 'RCDA
Begin DoDot:1
+48 ; add new entry
+49 NEW DO,DIC,X,Y,DA
+50 SET DIC="^PRCA(430.7,"_RCREPORT_",1,"
SET DIC(0)=""
SET DA(1)=RCREPORT
SET X=BILLDA
+51 SET DIC("DR")=""
SET X=0
+52 FOR
SET X=$ORDER(RCDR(X))
if 'X
QUIT
SET DIC("DR")=DIC("DR")_X_"////"_RCDR(X)_";"
+53 SET DIC("DR")=$EXTRACT(DIC("DR"),1,$LENGTH(DIC("DR"))-1)
+54 SET X=BILLDA
+55 DO FILE^DICN
End DoDot:1
QUIT
+56 ;
+57 ; update entry (if it already exited)
+58 SET DIE="^PRCA(430.7,"_RCREPORT_",1,"
SET DA=RCDA
SET DA(1)=RCREPORT
+59 SET DR=""
SET X=0
+60 FOR
SET X=$ORDER(RCDR(X))
if 'X
QUIT
SET DR=DR_X_"////"_RCDR(X)_";"
+61 SET DR=$EXTRACT(DR,1,$LENGTH(DR)-1)
if '$GET(SCREEN)
DO ^DIE
+62 QUIT
+63 ;
EN ; option entry point to run the report
+1 NEW RCREPORT,EXCEL,RCPROMPT,X,Y,DTOUT,DUOUT,DIR,ZTDESC,ZTSAVE,ZTRTN,ZTSK
+2 ;
+3 WRITE !,"Select which accounting month/year for the ARDC Report"
+4 SET DIC="^PRCA(430.7,"
SET DIC(0)="AEMNQ"
DO ^DIC
if Y<1
QUIT
+5 SET RCREPORT=+Y
+6 SET EXCEL=0
SET RCPROMPT="CAPTURE Report data to an Excel Document?"
SET DIR(0)="Y"
SET DIR("?")="^D HEXC^RCRJRCOU"
+7 SET EXCEL=$$SELECT^RCTCSJR(RCPROMPT,"NO")
IF "01"'[EXCEL
QUIT
+8 ; Display Excel display message
IF EXCEL=1
DO EXCMSG^RCTCSJR
+9 IF 'EXCEL
WRITE !!,"This report requires 132 characters",!
+10 KILL IOP,IO("Q")
SET %ZIS="MQ"
SET %ZIS("B")=""
DO ^%ZIS
if POP
QUIT
+11 IF $DATA(IO("Q"))
Begin DoDot:1
+12 SET ZTDESC="ARDC Detail Report"
SET ZTRTN="DQQ^RCRJRCOU"
+13 SET (ZTSAVE("RC*"),ZTSAVE("EXCEL"))=""
SET ZTSAVE("ZTREQ")="@"
+14 DO ^%ZTLOAD
DO HOME^%ZIS
SET QUIT=1
End DoDot:1
QUIT
+15 ;
DQQ ; Print the report
+1 NEW XMNOW,PAGE,RCOUT,RCREC,RCSP
+2 ;Capture the date and time the report was started for the header
SET XMNOW=$$NOW^XLFDT
+3 SET (RCOUT,PAGE)=0
+4 SET RCREC=0
FOR
SET RCREC=$ORDER(^PRCA(430.7,RCREPORT,1,RCREC))
if 'RCREC!(RCOUT)
QUIT
Begin DoDot:1
+5 NEW RCARRAY
+6 IF PAGE<1
DO HDR
+7 IF 'EXCEL
IF $Y+3>IOSL
IF ($EXTRACT(IOST,1,2)="C-")&(IO=IO(0))
SET DIR(0)="E"
DO ^DIR
KILL DIR
Begin DoDot:2
+8 IF $DATA(DTOUT)!($DATA(DUOUT))
SET RCOUT=1
GOTO EXIT
+9 DO HDR
End DoDot:2
+10 if RCOUT
QUIT
+11 ; extract data from file in external form
+12 DO GETS^DIQ(430.71,RCREC_","_RCREPORT_",","*","","RCARRAY")
+13 SET RCSP="0^14^26^50^68^75^84^92^104"
+14 WRITE !
FOR X=.01:.01:.09
Begin DoDot:2
+15 if 'EXCEL
WRITE @("?"_$PIECE(RCSP,"^",X*100))
+16 SET Y=$SELECT(X=.03:20,X=.04:15,1:999)
+17 WRITE $EXTRACT($GET(RCARRAY(430.71,RCREC_","_RCREPORT_",",X)),1,Y)
+18 IF EXCEL
IF X'=.09
WRITE "^"
End DoDot:2
End DoDot:1
+19 ;
+20 QUIT
+21 ;
