RCTCSJR ;ALBANY/LEG-CS DEBT REFERRAL REJECT REPORTING ;07/15/14 3:34 PM
;;4.5;Accounts Receivable;**301,315,339**;Mar 20, 1995;Build 2
;;Per VA Directive 6402, this routine should not be modified.
;
Q
ECLIST ; prints IAI Error Codes List
S DIC="^RC(348.5,",BY=.01
S (FR,TO)=""
S FLDS="[TCS IAI ERROR CODES LIST]"
S DHD="TCS IAI ERROR CODES LIST"
S DIOBEG="W !!"
D EN1^DIP
Q
;
RJRPT ; for CS REJECT REPORT processing
D INIT S STOP=0
D PROMPTS Q:POP
Q:STOP
D HEADING,GETRECS,PRTRECS
K %ZIS,ACTN,ASCDES,BILLID,BILLIEN,BLNKS,BY,CD,CDIEN,CDREC,CDSH,CHDR,CHDRS,CNTR,COLDASH,COLHDRS,COLWIDTH1,COLWIDTH2,COLWIDTH3,CWID,DASH,DATA,DATAITMS,DATE,DEBTIDX,DEBTIEN,DEBTOR,DEBTREC,DEBTREF,DEFAULT,DESC,DHD,DIOBEG
K DTFRM,DTFRMTO,DTFROM,DTTO,ECDS,EXCEL,FIELD,FLDS,FR,GROUPBD,HDTITLE,I,INCLUDE,INDATE,L,LEV1,LEV2,LEV3,LEV4,LN,OUTDATE,PAGE,POP,QUIT,RPTITEMS,RPTREC,SEQ,SRC,SSN,STOP,STR,TO,TYP,UPDN,RECW1,RECW2,EXCOLH,EXSSN,CDREC1
Q
;
INIT ;
K ^TMP("RCTCSJR",$J),REC
S DASH="",$P(DASH,"-",78)="" ; (as per PRCA*4.5*315)
S BLNKS="",$P(BLNKS," ",71)=""
S DATAITMS="DATE^SRC^ECD(1)^ECD(2)^ECD(3)^ECD(4)^ECD(5)^ECD(6)^ECD(7)^ECD(8)^ECD(9)^TYP^ACTN"
S RPTITEMS="BILLID^DEBTOR^SSN^TYP^ACTN^OUTDATE^SRC^ECDS"
I $G(EXCEL) S RPTITEMS="BILLID^DEBTOR^EXSSN^TYP^ACTN^OUTDATE^SRC^ECDS^RECDET" ;PRCA*4.5*315
Q
;
GETRECS ;
N PC,RECDET
K ^TMP("RCTCSJR",$J)
S (DATE,DTFRM)=$$FMADD^XLFDT(+$P(DTFRMTO,U,2),-1),DTTO=$P(DTFRMTO,U,3)
F S DATE=$O(^PRCA(430,"AB",DATE)),BILLIEN=0 Q:DATE>DTTO!'DATE D ;
. S INDATE=DATE,OUTDATE=$$FMTE^XLFDT(DATE,"2Z") ;Standardize dates (as per PRCA*4.5*315)
. F S BILLIEN=$O(^PRCA(430,"AB",DATE,BILLIEN)),SEQ=0 Q:BILLIEN="" D ;
.. S BILLID=$P(^PRCA(430,BILLIEN,0),U)
.. S DEBTIEN=$P(^PRCA(430,BILLIEN,0),U,9) ;33460
.. S DEBTIDX=$P($G(^RCD(340,DEBTIEN,0)),U) ;777706050;DPT(
.. Q:$G(DEBTIDX)=""
.. S DEBTREF="^"_$P(DEBTIDX,";",2)_$P(DEBTIDX,";")_",0)"
.. S DEBTREC=@(DEBTREF)
.. S DEBTOR=$E($P(DEBTREC,U),1,19),SSN=$E($$SSN^RCFN01($P($G(^RCD(340,DEBTIEN,0)),"^")),6,9) ;Last 4 of SSN only (as per PRCA*4.5*315)
.. S SSN=$E($$SSN^RCFN01($P($G(^RCD(340,DEBTIEN,0)),"^")),6,9) ;Last 4 of SSN if Excel PRCA*4.5*315
.. S EXSSN=$E(DEBTOR)_$S(SSN'="":SSN,1:" ") ; 1st init last name, last 4 of SSN if not Excel PRCA*4.5*315
.. F S SEQ=$O(^PRCA(430,"AB",DATE,BILLIEN,SEQ)) Q:SEQ="" D ;
... S DATA=$G(^PRCA(430,BILLIEN,18,SEQ,0))
... Q:'$L(DATA) ; in the event the X-REF is out of sync due to test clearing
... F PC=2,12,13 S CD=$P(DATA,U,PC),X=$P(DATAITMS,U,PC)_"="""_$S(CD="":CD,PC=2:CD,PC=12:$P($G(^RC(348.7,CD,0)),U),PC=13:$P($G(^RC(348.6,CD,0)),U),1:"")_"""",@X
... K ECD
... S ECDS=""
... F PC=3:1:11 S CD=$P(DATA,U,PC) Q:'$L(CD) S CD=$S('$D(^RC(348.5,CD,0)):CD,1:$P(^RC(348.5,CD,0),U)) S X="S "_$P(DATAITMS,U,PC)_"="""_CD_"""" D ;
.... Q:'$D(^RC(348.5,$P(DATA,U,PC),0))!(CD="ZZ") ; quits just in case bad error code got thru
.... X X
.... S ECDS=ECDS_$S(PC>3:";",1:"")_ECD(PC-2) ;Error codes new delimiter ";"
... ; gets record layout based on RPTTYP and places into RPTTYP sorting sequence
... D @RPTTYP ;1=BILL NO. 2=DEBTOR 3=REJECT DATE
... Q ;
... ;
S LEV1="",CNTR=0
K REC
S UPDN=$S(ASCDES="D":-1,1:1) ; determines ASCending or DeSCending direction
F S LEV1=$O(^TMP("RCTCSJR",$J,"RPT",LEV1),UPDN),LEV2="" Q:LEV1="" D ;
. F S LEV2=$O(^TMP("RCTCSJR",$J,"RPT",LEV1,LEV2),UPDN),LEV3="" Q:LEV2="" D ;
.. F S LEV3=$O(^TMP("RCTCSJR",$J,"RPT",LEV1,LEV2,LEV3),UPDN),LEV4="" Q:LEV3="" D ;
... F S LEV4=$O(^TMP("RCTCSJR",$J,"RPT",LEV1,LEV2,LEV3,LEV4),UPDN) Q:LEV4="" D ;
.... S RPTREC=^TMP("RCTCSJR",$J,"RPT",LEV1,LEV2,LEV3,LEV4)
.... I 'EXCEL S SRC=$E(RPTREC,65)
.... I EXCEL S SRC=$P(RPTREC,U,7)
.... I INCLUDE'="ALL",INCLUDE'=SRC Q ; unwanted source
.... S CNTR=CNTR+1
.... S REC(CNTR)=$P(RPTREC,";",1,$S(EXCEL:10,1:4))
.... I EXCEL S RECW1=$E(REC(CNTR),1,70),RECW2=$TR($E(REC(CNTR),71,999),"^","-"),REC(CNTR)=RECW1_RECW2
.... ;Q:EXCEL ; only needs single line string if in Excel format
.... I 'EXCEL S RECW1=$E(REC(CNTR),1,70),RECW2=$TR($E(REC(CNTR),71,999),"^",";"),REC(CNTR)=RECW1_RECW2
.... I 'EXCEL,$L($P(RPTREC,";",5,8)) D
..... S CNTR=CNTR+1,REC(CNTR)=$E(BLNKS,1,67)_$P(RPTREC,";",5,8)
.... I 'EXCEL,$L($P(RPTREC,";",9)) D
..... S CNTR=CNTR+1,REC(CNTR)=$E(BLNKS,1,67)_$P(RPTREC,";",9)
.... I GROUPBD="D" D ;
..... K ECD
..... S ECDS=$E(RPTREC,68,100)
..... F I=1:1:9 S ECD(I)=$P(ECDS,";",I) Q:'$L(ECD(I)) D
...... S CD=$P(ECDS,";",I),CDIEN=$O(^RC(348.5,"B",CD,0))
...... S (CDREC,CDREC1)="" I CDIEN,$D(^RC(348.5,CDIEN)) S CDREC=^RC(348.5,CDIEN,0),CDREC1=$G(^RC(348.5,CDIEN,1))
...... S (X,DESC,RECDET)=" "_CD_" - "_CDREC1
...... I $L(DESC)<81 S CNTR=CNTR+1,REC(CNTR)=X
...... ; splits line if > 80 chars
...... I $L(DESC)>80 D ;
....... F S STR=$E(X,1,80) D Q:'$L(X) ;
........ I $L(X)<81 S CNTR=CNTR+1 S REC(CNTR)=X,X="" Q
........ F L=$L(STR):-1:1 I $F(STR," ",L) D Q ;
......... S CNTR=CNTR+1
......... S REC(CNTR)=$E(X,1,L),X=$E(X,L+1,999)
......... I $L(X) S X=" "_X
......... Q ;
M ^TMP("RCTCSJR",$J,"REC")=REC
Q
;
1 ; for report by 1) Bill Number
S QUIT=0
I 'EXCEL D Q:QUIT ;
. S RPTREC=""
. F PC=1:1:7 D Q:QUIT ;
.. S FIELD=$P(RPTITEMS,U,PC)
.. I PC=7,INCLUDE'="ALL",@FIELD'=INCLUDE S QUIT=1 Q ;
.. S RPTREC=RPTREC_$E(@FIELD_BLNKS,1,$P(COLWIDTH1,U,PC))
. F PC=8 S RPTREC=RPTREC_@$P(RPTITEMS,U,PC)
I EXCEL S RPTREC=BILLID_U_DEBTOR_U_EXSSN_U_TYP_U_ACTN_U_OUTDATE_U_SRC_U_ECDS ; PRCA*4.5*315
S ^TMP("RCTCSJR",$J,"RPT",BILLID,INDATE,DEBTOR,SEQ)=RPTREC
Q
2 ; for report by 2) Debtor Name
S QUIT=0
I EXCEL S RPTREC=DEBTOR_U_BILLID_U_EXSSN_U_TYP_U_ACTN_U_OUTDATE_U_SRC_U_ECDS ; PRCA*4.5*315
I 'EXCEL D Q:QUIT ;
. S RPTREC=""
. F PC=2,1,3:1:7 D Q:QUIT ;
.. S FIELD=$P(RPTITEMS,U,PC)
.. I PC=7,INCLUDE'="ALL",@FIELD'=INCLUDE S QUIT=1 Q ;
.. S RPTREC=RPTREC_$E(@FIELD_BLNKS,1,$P(COLWIDTH2,U,PC))
. F PC=8 S RPTREC=RPTREC_@$P(RPTITEMS,U,PC)
S ^TMP("RCTCSJR",$J,"RPT",DEBTOR,BILLID,INDATE,SEQ)=RPTREC
Q
3 ; for report by 3) CS Reject Date
S QUIT=0
I EXCEL S RPTREC=OUTDATE_U_BILLID_U_DEBTOR_U_EXSSN_U_TYP_U_ACTN_U_SRC_U_ECDS ; PRCA*4.5*315
I 'EXCEL D Q:QUIT ;
. S RPTREC=""
. F PC=6,1:1:5,7 D Q:QUIT ;
.. S FIELD=$P(RPTITEMS,U,PC)
.. I PC=7,INCLUDE'="ALL",@FIELD'=INCLUDE S QUIT=1 Q ;
.. S RPTREC=RPTREC_$E(@$P(RPTITEMS,U,PC)_BLNKS,1,$P(COLWIDTH3,U,PC))
. F PC=8 S RPTREC=RPTREC_@$P(RPTITEMS,U,PC)
S ^TMP("RCTCSJR",$J,"RPT",INDATE,BILLID,DEBTOR,SEQ)=RPTREC
Q
QRPT ;if queued
D HEADING,GETRECS,PRTRECS
Q
;
PRTRECS ; prints report
S PAGE=0
K DIRUT,DUOUT,DTOUT
D HEADING,REJREPH
S LN=0 F LN=1:1 Q:'$D(^TMP("RCTCSJR",$J,"REC",LN)) D Q:$D(DIRUT)!$D(DUOUT)!$D(DTOUT)
. W ^TMP("RCTCSJR",$J,"REC",LN),!
. ; check for end of page here, if necessary form feed and print header
. I $Y+3>IOSL D
.. I $E(IOST,1,2)="C-" S DIR(0)="E" K DIRUT D ^DIR Q:$D(DIRUT)!$D(DUOUT)!$D(DTOUT)
.. D REJREPH
. Q
I $E(IOST,1,2)="C-" R !!,"END OF REPORT...PRESS RETURN TO CONTINUE",X:DTIME W @IOF
D ^%ZISC
K ^TMP("RCTCSJR",$J)
I $D(ZTQUEUED) S ZTREQ="@" ; purge the task
Q
REJREPH ;
U IO W @IOF S PAGE=PAGE+1
W "PAGE "_PAGE,?10,HDTITLE,?68,$$FMTE^XLFDT(DT,"2Z") ;Standardize the date
I EXCEL W !,$TR(CHDR," ",""),! Q
W !,DASH,!,CHDR,!,CDSH,! Q
Q
COLHDR ; sets report line based on type of report
S CHDR=CHDR_$P(COLHDRS,U,PC)_$S(EXCEL:"^",1:"")
S CDSH=CDSH_$P(COLDASH,U,PC)_$S(EXCEL:"^",1:"")
Q
HEADING ; compiles info for Heading and titles for cross-servicing reject report
S HDTITLE="DEBT REFERRAL REJECT REPORT (SORTED BY "_$P("BILL NO.^DEBTOR^REJ DATE",U,RPTTYP)
S HDTITLE=HDTITLE_" <"_$S(ASCDES="D":"DSC",1:"ASC")_">)"
;
S COLWIDTH1="12^20^9^5^5^13^3^11" ;Change SSN to last initial last 4 only (as per PRCA*4.5*315)
S COLWIDTH2="12^20^9^5^5^13^3^8",COLWIDTH3="12^20^9^5^6^12^3^11"
S EXCOLH="BILL NO.^DEBTOR^Pt ID^TYP ^ACTNCD ^REJECT DATE ^SRC ^ERR CODES"
S COLHDRS="BILL NO. ^DEBTOR ^Pt ID ^TYP ^ACTNCD ^REJECT DATE ^SRC ^ERR CODES"
S COLDASH="----------- ^------------------- ^----- ^--- ^------ ^----------- ^--- ^---------"
S (CHDR,CDSH,CWID)=""
I RPTTYP=1 S CWID=COLWIDTH1,CHDR=$S(EXCEL:COLHDRS,1:$TR(COLHDRS,"^","")),CDSH=$S(EXCEL:COLDASH,1:$TR(COLDASH,"^",""))
I RPTTYP=2 F PC=2,1,3:1:8 D COLHDR
I RPTTYP=3 F PC=6,1:1:5,7,8 D COLHDR
Q
PROMPTS S U="^"
S STOP=0,PROMPT="*** DEBT REFERRAL REJECT REPORT ***"
S DTFRMTO=$$DTFRMTO(PROMPT) I 'DTFRMTO S (STOP,POP)=1 Q
;
S PROMPT="Group Error Codes: Brief or Detail"
S DIR(0)="SB^B:Brief;D:Detail"
S GROUPBD=$$SELECT(PROMPT,"B") I "BD"'[GROUPBD S (STOP,POP)=1 Q
;
S SET="S^1:Bill Number;2:Debtor Name;3:CS Reject Date"
S RPTTYP=$$RPTTYP("Select One of the Following:",SET) I 'RPTTYP S (STOP,POP)=1 Q
;
S PROMPT="Include Only: AITC, DMC, TREASURY or 'ALL'"
S DIR(0)="SB^A:AITC;D:DMC;T:TREASURY;ALL:ALL",DIR("L")=PROMPT
S INCLUDE=$$SELECT(PROMPT,"ALL") I "ADT"'[$E(INCLUDE) S (STOP,POP)=1 Q
;
S PROMPT="Sort ASCENDING or DESCENDING",DIR(0)="SB^A:ASCENDING;D:DESCENDING"
S DIR("L")=PROMPT
S ASCDES=$$SELECT(PROMPT,"A") I "AD"'[ASCDES S (STOP,POP)=1 Q
;
S EXCEL=0
I GROUPBD="B" D
. S PROMPT="CAPTURE Report data to an Excel Document"
. S DIR(0)="Y",DIR("?")="^D HEXC^RCTCSJR"
. S EXCEL=$$SELECT(PROMPT,"NO") I "01"'[EXCEL S (POP,STOP)=1 Q
I EXCEL=1 D EXCMSG^RCTCSJR ; Display Excel display message
;
K IOP,IO("Q") S %ZIS="MQ",%ZIS("B")="" D ^%ZIS I POP S STOP=1 Q
I $D(IO("Q")) D Q
.S ZTSAVE("DEBTOR")="",ZTSAVE("DTFRMTO")="",ZTSAVE("EXCEL")="",ZTSAVE("PROMPT")="",ZTSAVE("DASH")="",ZTSAVE("BLNKS")="",ZTSAVE("DATAITMS")="",ZTSAVE("RPTITEMS")=""
.S ZTSAVE("GROUPBD")="",ZTSAVE("RPTTYP")="",ZTSAVE("INCLUDE")="",ZTSAVE("ASCDES")="",ZTSAVE("CHDR")="",ZTSAVE("CDSH")="",ZTSAVE("ZTASK")=""
.S ZTRTN="QRPT^RCTCSJR",ZTDESC="CROSS-SERVICING BILL REPORT"
.D ^%ZTLOAD,^%ZISC S (STOP,POP)=1
.I $G(ZTSK) W !!,"Report compilation has started with task# ",ZTSK,".",! S DIR(0)="E" D ^DIR K DIR
.Q
Q ; PROMPTS
;
SELECT(PROMPT,DEFAULT) ; prompts for a selection
;INPUT:
; PROMPT - Message to display prior to prompting for dates
;OUTPUT:
; 1^BEGDT^ENDDT - Data found
; 0 - User up arrowed or timed out
N Y,X,DTOUT,OUT,DIRUT,DUOUT,DIROUT
S OUT=0
W !
S DIR("A")=PROMPT,DIR("B")=DEFAULT
D ^DIR K DIR
;Quit if user time out or didn't enter valid date
Q:Y<0 OUT
Q Y
;
RPTTYP(PROMPT,SET) ;PRINT CROSS-SERVICING REPORT; print cross-servicing report, prints sorted individual bills that make up a cross-servicing account
N DIC,ZTSAVE,ZTDESC,ZTRTN,RCSORT
S OUT=0
W !
S DIR(0)=SET ;"S^1:Bill Number;2:Debtor Name;3:CS Reject Date"
S DIR("A")="Sort by",DIR("B")=1 D ^DIR K DIR
Q:Y<0 OUT
Q Y
;
DTFRMTO(PROMPT) ;Get from and to dates
;INPUT:
; PROMPT - Message to display prior to prompting for dates
;OUTPUT:
; 1^BEGDT^ENDDT - Data found
; 0 - User up arrowed or timed out
;
N %DT,Y,X,BEGDT,ENDDT,DTOUT,OUT,DIRUT,DUOUT,DIROUT
S OUT=0
W !,$G(PROMPT)
S %DT="AEX",%DT("A")="Date Range: FROM: " ;Enter Beginning Date: "
S %DT("B")="T-7"
W !
D ^%DT K %DT
Q:Y<0 OUT ;Quit if user time out or didn't enter valid date
S DTFROM=+Y
S %DT="AEX"
S %DT("A")=" TO: ",%DT("B")="T" ;"TODAY"
D ^%DT K %DT
;Quit if user time out or didn't enter valid date
Q:Y<0 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",!," to an Excel document"
W !," '<CR>' - To skip this option",!," '^' - To quit this option"
Q
;
EXCMSG ; - Displays the message about capturing to an Excel file format
;
W !!?5,"To capture as an Excel format, it is recommended that you queue this"
W !?5,"report to a spool device with margins of 256 and page length of 99999"
W !?5,"(e.g. 0;256;99999). This should help avoid wrapping problems."
W !!?5,"Another method would be to set up your terminal to capture the detail"
W !?5,"report data. On some terminals, this can be done by invoking 'Logging'"
W !?5,"or clicking on the 'Tools' menu above, then click on 'Capture Incoming "
W !?5,"Data' to save to Desktop. To avoid undesired wrapping of the data saved"
W !?5,"to the file, change the DISPLAY screen width size to 132 and you can"
W !?5,"enter '0;256;99999' at the 'DEVICE:' prompt.",!
Q
; ========================================================================
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCTCSJR 12787 printed Apr 09, 2024@20:52:04 Page 2
RCTCSJR ;ALBANY/LEG-CS DEBT REFERRAL REJECT REPORTING ;07/15/14 3:34 PM
+1 ;;4.5;Accounts Receivable;**301,315,339**;Mar 20, 1995;Build 2
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
ECLIST ; prints IAI Error Codes List
+1 SET DIC="^RC(348.5,"
SET BY=.01
+2 SET (FR,TO)=""
+3 SET FLDS="[TCS IAI ERROR CODES LIST]"
+4 SET DHD="TCS IAI ERROR CODES LIST"
+5 SET DIOBEG="W !!"
+6 DO EN1^DIP
+7 QUIT
+8 ;
RJRPT ; for CS REJECT REPORT processing
+1 DO INIT
SET STOP=0
+2 DO PROMPTS
if POP
QUIT
+3 if STOP
QUIT
+4 DO HEADING
DO GETRECS
DO PRTRECS
+5 KILL %ZIS,ACTN,ASCDES,BILLID,BILLIEN,BLNKS,BY,CD,CDIEN,CDREC,CDSH,CHDR,CHDRS,CNTR,COLDASH,COLHDRS,COLWIDTH1,COLWIDTH2,COLWIDTH3,CWID,DASH,DATA,DATAITMS,DATE,DEBTIDX,DEBTIEN,DEBTOR,DEBTREC,DEBTREF,DEFAULT,DESC,DHD,DIOBEG
+6 KILL DTFRM,DTFRMTO,DTFROM,DTTO,ECDS,EXCEL,FIELD,FLDS,FR,GROUPBD,HDTITLE,I,INCLUDE,INDATE,L,LEV1,LEV2,LEV3,LEV4,LN,OUTDATE,PAGE,POP,QUIT,RPTITEMS,RPTREC,SEQ,SRC,SSN,STOP,STR,TO,TYP,UPDN,RECW1,RECW2,EXCOLH,EXSSN,CDREC1
+7 QUIT
+8 ;
INIT ;
+1 KILL ^TMP("RCTCSJR",$JOB),REC
+2 ; (as per PRCA*4.5*315)
SET DASH=""
SET $PIECE(DASH,"-",78)=""
+3 SET BLNKS=""
SET $PIECE(BLNKS," ",71)=""
+4 SET DATAITMS="DATE^SRC^ECD(1)^ECD(2)^ECD(3)^ECD(4)^ECD(5)^ECD(6)^ECD(7)^ECD(8)^ECD(9)^TYP^ACTN"
+5 SET RPTITEMS="BILLID^DEBTOR^SSN^TYP^ACTN^OUTDATE^SRC^ECDS"
+6 ;PRCA*4.5*315
IF $GET(EXCEL)
SET RPTITEMS="BILLID^DEBTOR^EXSSN^TYP^ACTN^OUTDATE^SRC^ECDS^RECDET"
+7 QUIT
+8 ;
GETRECS ;
+1 NEW PC,RECDET
+2 KILL ^TMP("RCTCSJR",$JOB)
+3 SET (DATE,DTFRM)=$$FMADD^XLFDT(+$PIECE(DTFRMTO,U,2),-1)
SET DTTO=$PIECE(DTFRMTO,U,3)
+4 ;
FOR
SET DATE=$ORDER(^PRCA(430,"AB",DATE))
SET BILLIEN=0
if DATE>DTTO!'DATE
QUIT
Begin DoDot:1
+5 ;Standardize dates (as per PRCA*4.5*315)
SET INDATE=DATE
SET OUTDATE=$$FMTE^XLFDT(DATE,"2Z")
+6 ;
FOR
SET BILLIEN=$ORDER(^PRCA(430,"AB",DATE,BILLIEN))
SET SEQ=0
if BILLIEN=""
QUIT
Begin DoDot:2
+7 SET BILLID=$PIECE(^PRCA(430,BILLIEN,0),U)
+8 ;33460
SET DEBTIEN=$PIECE(^PRCA(430,BILLIEN,0),U,9)
+9 ;777706050;DPT(
SET DEBTIDX=$PIECE($GET(^RCD(340,DEBTIEN,0)),U)
+10 if $GET(DEBTIDX)=""
QUIT
+11 SET DEBTREF="^"_$PIECE(DEBTIDX,";",2)_$PIECE(DEBTIDX,";")_",0)"
+12 SET DEBTREC=@(DEBTREF)
+13 ;Last 4 of SSN only (as per PRCA*4.5*315)
SET DEBTOR=$EXTRACT($PIECE(DEBTREC,U),1,19)
SET SSN=$EXTRACT($$SSN^RCFN01($PIECE($GET(^RCD(340,DEBTIEN,0)),"^")),6,9)
+14 ;Last 4 of SSN if Excel PRCA*4.5*315
SET SSN=$EXTRACT($$SSN^RCFN01($PIECE($GET(^RCD(340,DEBTIEN,0)),"^")),6,9)
+15 ; 1st init last name, last 4 of SSN if not Excel PRCA*4.5*315
SET EXSSN=$EXTRACT(DEBTOR)_$SELECT(SSN'="":SSN,1:" ")
+16 ;
FOR
SET SEQ=$ORDER(^PRCA(430,"AB",DATE,BILLIEN,SEQ))
if SEQ=""
QUIT
Begin DoDot:3
+17 SET DATA=$GET(^PRCA(430,BILLIEN,18,SEQ,0))
+18 ; in the event the X-REF is out of sync due to test clearing
if '$LENGTH(DATA)
QUIT
+19 FOR PC=2,12,13
SET CD=$PIECE(DATA,U,PC)
SET X=$PIECE(DATAITMS,U,PC)_"="""_$SELECT(CD="":CD,PC=2:CD,PC=12:$PIECE($GET(^RC(348.7,CD,0)),U),PC=13:$PIECE($GET(^RC(348.6,CD,0)),U),1:"")_""""
SET @X
+20 KILL ECD
+21 SET ECDS=""
+22 ;
FOR PC=3:1:11
SET CD=$PIECE(DATA,U,PC)
if '$LENGTH(CD)
QUIT
SET CD=$SELECT('$DATA(^RC(348.5,CD,0)):CD,1:$PIECE(^RC(348.5,CD,0),U))
SET X="S "_$PIECE(DATAITMS,U,PC)_"="""_CD_""""
Begin DoDot:4
+23 ; quits just in case bad error code got thru
if '$DATA(^RC(348.5,$PIECE(DATA,U,PC),0))!(CD="ZZ")
QUIT
+24 XECUTE X
+25 ;Error codes new delimiter ";"
SET ECDS=ECDS_$SELECT(PC>3:";",1:"")_ECD(PC-2)
End DoDot:4
+26 ; gets record layout based on RPTTYP and places into RPTTYP sorting sequence
+27 ;1=BILL NO. 2=DEBTOR 3=REJECT DATE
DO @RPTTYP
+28 ;
QUIT
+29 ;
End DoDot:3
End DoDot:2
End DoDot:1
+30 SET LEV1=""
SET CNTR=0
+31 KILL REC
+32 ; determines ASCending or DeSCending direction
SET UPDN=$SELECT(ASCDES="D":-1,1:1)
+33 ;
FOR
SET LEV1=$ORDER(^TMP("RCTCSJR",$JOB,"RPT",LEV1),UPDN)
SET LEV2=""
if LEV1=""
QUIT
Begin DoDot:1
+34 ;
FOR
SET LEV2=$ORDER(^TMP("RCTCSJR",$JOB,"RPT",LEV1,LEV2),UPDN)
SET LEV3=""
if LEV2=""
QUIT
Begin DoDot:2
+35 ;
FOR
SET LEV3=$ORDER(^TMP("RCTCSJR",$JOB,"RPT",LEV1,LEV2,LEV3),UPDN)
SET LEV4=""
if LEV3=""
QUIT
Begin DoDot:3
+36 ;
FOR
SET LEV4=$ORDER(^TMP("RCTCSJR",$JOB,"RPT",LEV1,LEV2,LEV3,LEV4),UPDN)
if LEV4=""
QUIT
Begin DoDot:4
+37 SET RPTREC=^TMP("RCTCSJR",$JOB,"RPT",LEV1,LEV2,LEV3,LEV4)
+38 IF 'EXCEL
SET SRC=$EXTRACT(RPTREC,65)
+39 IF EXCEL
SET SRC=$PIECE(RPTREC,U,7)
+40 ; unwanted source
IF INCLUDE'="ALL"
IF INCLUDE'=SRC
QUIT
+41 SET CNTR=CNTR+1
+42 SET REC(CNTR)=$PIECE(RPTREC,";",1,$SELECT(EXCEL:10,1:4))
+43 IF EXCEL
SET RECW1=$EXTRACT(REC(CNTR),1,70)
SET RECW2=$TRANSLATE($EXTRACT(REC(CNTR),71,999),"^","-")
SET REC(CNTR)=RECW1_RECW2
+44 ;Q:EXCEL ; only needs single line string if in Excel format
+45 IF 'EXCEL
SET RECW1=$EXTRACT(REC(CNTR),1,70)
SET RECW2=$TRANSLATE($EXTRACT(REC(CNTR),71,999),"^",";")
SET REC(CNTR)=RECW1_RECW2
+46 IF 'EXCEL
IF $LENGTH($PIECE(RPTREC,";",5,8))
Begin DoDot:5
+47 SET CNTR=CNTR+1
SET REC(CNTR)=$EXTRACT(BLNKS,1,67)_$PIECE(RPTREC,";",5,8)
End DoDot:5
+48 IF 'EXCEL
IF $LENGTH($PIECE(RPTREC,";",9))
Begin DoDot:5
+49 SET CNTR=CNTR+1
SET REC(CNTR)=$EXTRACT(BLNKS,1,67)_$PIECE(RPTREC,";",9)
End DoDot:5
+50 ;
IF GROUPBD="D"
Begin DoDot:5
+51 KILL ECD
+52 SET ECDS=$EXTRACT(RPTREC,68,100)
+53 FOR I=1:1:9
SET ECD(I)=$PIECE(ECDS,";",I)
if '$LENGTH(ECD(I))
QUIT
Begin DoDot:6
+54 SET CD=$PIECE(ECDS,";",I)
SET CDIEN=$ORDER(^RC(348.5,"B",CD,0))
+55 SET (CDREC,CDREC1)=""
IF CDIEN
IF $DATA(^RC(348.5,CDIEN))
SET CDREC=^RC(348.5,CDIEN,0)
SET CDREC1=$GET(^RC(348.5,CDIEN,1))
+56 SET (X,DESC,RECDET)=" "_CD_" - "_CDREC1
+57 IF $LENGTH(DESC)<81
SET CNTR=CNTR+1
SET REC(CNTR)=X
+58 ; splits line if > 80 chars
+59 ;
IF $LENGTH(DESC)>80
Begin DoDot:7
+60 ;
FOR
SET STR=$EXTRACT(X,1,80)
Begin DoDot:8
+61 IF $LENGTH(X)<81
SET CNTR=CNTR+1
SET REC(CNTR)=X
SET X=""
QUIT
+62 ;
FOR L=$LENGTH(STR):-1:1
IF $FIND(STR," ",L)
Begin DoDot:9
+63 SET CNTR=CNTR+1
+64 SET REC(CNTR)=$EXTRACT(X,1,L)
SET X=$EXTRACT(X,L+1,999)
+65 IF $LENGTH(X)
SET X=" "_X
+66 ;
QUIT
End DoDot:9
QUIT
End DoDot:8
if '$LENGTH(X)
QUIT
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+67 MERGE ^TMP("RCTCSJR",$JOB,"REC")=REC
+68 QUIT
+69 ;
1 ; for report by 1) Bill Number
+1 SET QUIT=0
+2 ;
IF 'EXCEL
Begin DoDot:1
+3 SET RPTREC=""
+4 ;
FOR PC=1:1:7
Begin DoDot:2
+5 SET FIELD=$PIECE(RPTITEMS,U,PC)
+6 ;
IF PC=7
IF INCLUDE'="ALL"
IF @FIELD'=INCLUDE
SET QUIT=1
QUIT
+7 SET RPTREC=RPTREC_$EXTRACT(@FIELD_BLNKS,1,$PIECE(COLWIDTH1,U,PC))
End DoDot:2
if QUIT
QUIT
+8 FOR PC=8
SET RPTREC=RPTREC_@$PIECE(RPTITEMS,U,PC)
End DoDot:1
if QUIT
QUIT
+9 ; PRCA*4.5*315
IF EXCEL
SET RPTREC=BILLID_U_DEBTOR_U_EXSSN_U_TYP_U_ACTN_U_OUTDATE_U_SRC_U_ECDS
+10 SET ^TMP("RCTCSJR",$JOB,"RPT",BILLID,INDATE,DEBTOR,SEQ)=RPTREC
+11 QUIT
2 ; for report by 2) Debtor Name
+1 SET QUIT=0
+2 ; PRCA*4.5*315
IF EXCEL
SET RPTREC=DEBTOR_U_BILLID_U_EXSSN_U_TYP_U_ACTN_U_OUTDATE_U_SRC_U_ECDS
+3 ;
IF 'EXCEL
Begin DoDot:1
+4 SET RPTREC=""
+5 ;
FOR PC=2,1,3:1:7
Begin DoDot:2
+6 SET FIELD=$PIECE(RPTITEMS,U,PC)
+7 ;
IF PC=7
IF INCLUDE'="ALL"
IF @FIELD'=INCLUDE
SET QUIT=1
QUIT
+8 SET RPTREC=RPTREC_$EXTRACT(@FIELD_BLNKS,1,$PIECE(COLWIDTH2,U,PC))
End DoDot:2
if QUIT
QUIT
+9 FOR PC=8
SET RPTREC=RPTREC_@$PIECE(RPTITEMS,U,PC)
End DoDot:1
if QUIT
QUIT
+10 SET ^TMP("RCTCSJR",$JOB,"RPT",DEBTOR,BILLID,INDATE,SEQ)=RPTREC
+11 QUIT
3 ; for report by 3) CS Reject Date
+1 SET QUIT=0
+2 ; PRCA*4.5*315
IF EXCEL
SET RPTREC=OUTDATE_U_BILLID_U_DEBTOR_U_EXSSN_U_TYP_U_ACTN_U_SRC_U_ECDS
+3 ;
IF 'EXCEL
Begin DoDot:1
+4 SET RPTREC=""
+5 ;
FOR PC=6,1:1:5,7
Begin DoDot:2
+6 SET FIELD=$PIECE(RPTITEMS,U,PC)
+7 ;
IF PC=7
IF INCLUDE'="ALL"
IF @FIELD'=INCLUDE
SET QUIT=1
QUIT
+8 SET RPTREC=RPTREC_$EXTRACT(@$PIECE(RPTITEMS,U,PC)_BLNKS,1,$PIECE(COLWIDTH3,U,PC))
End DoDot:2
if QUIT
QUIT
+9 FOR PC=8
SET RPTREC=RPTREC_@$PIECE(RPTITEMS,U,PC)
End DoDot:1
if QUIT
QUIT
+10 SET ^TMP("RCTCSJR",$JOB,"RPT",INDATE,BILLID,DEBTOR,SEQ)=RPTREC
+11 QUIT
QRPT ;if queued
+1 DO HEADING
DO GETRECS
DO PRTRECS
+2 QUIT
+3 ;
PRTRECS ; prints report
+1 SET PAGE=0
+2 KILL DIRUT,DUOUT,DTOUT
+3 DO HEADING
DO REJREPH
+4 SET LN=0
FOR LN=1:1
if '$DATA(^TMP("RCTCSJR",$JOB,"REC",LN))
QUIT
Begin DoDot:1
+5 WRITE ^TMP("RCTCSJR",$JOB,"REC",LN),!
+6 ; check for end of page here, if necessary form feed and print header
+7 IF $Y+3>IOSL
Begin DoDot:2
+8 IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
KILL DIRUT
DO ^DIR
if $DATA(DIRUT)!$DATA(DUOUT)!$DATA(DTOUT)
QUIT
+9 DO REJREPH
End DoDot:2
+10 QUIT
End DoDot:1
if $DATA(DIRUT)!$DATA(DUOUT)!$DATA(DTOUT)
QUIT
+11 IF $EXTRACT(IOST,1,2)="C-"
READ !!,"END OF REPORT...PRESS RETURN TO CONTINUE",X:DTIME
WRITE @IOF
+12 DO ^%ZISC
+13 KILL ^TMP("RCTCSJR",$JOB)
+14 ; purge the task
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+15 QUIT
REJREPH ;
+1 USE IO
WRITE @IOF
SET PAGE=PAGE+1
+2 ;Standardize the date
WRITE "PAGE "_PAGE,?10,HDTITLE,?68,$$FMTE^XLFDT(DT,"2Z")
+3 IF EXCEL
WRITE !,$TRANSLATE(CHDR," ",""),!
QUIT
+4 WRITE !,DASH,!,CHDR,!,CDSH,!
QUIT
+5 QUIT
COLHDR ; sets report line based on type of report
+1 SET CHDR=CHDR_$PIECE(COLHDRS,U,PC)_$SELECT(EXCEL:"^",1:"")
+2 SET CDSH=CDSH_$PIECE(COLDASH,U,PC)_$SELECT(EXCEL:"^",1:"")
+3 QUIT
HEADING ; compiles info for Heading and titles for cross-servicing reject report
+1 SET HDTITLE="DEBT REFERRAL REJECT REPORT (SORTED BY "_$PIECE("BILL NO.^DEBTOR^REJ DATE",U,RPTTYP)
+2 SET HDTITLE=HDTITLE_" <"_$SELECT(ASCDES="D":"DSC",1:"ASC")_">)"
+3 ;
+4 ;Change SSN to last initial last 4 only (as per PRCA*4.5*315)
SET COLWIDTH1="12^20^9^5^5^13^3^11"
+5 SET COLWIDTH2="12^20^9^5^5^13^3^8"
SET COLWIDTH3="12^20^9^5^6^12^3^11"
+6 SET EXCOLH="BILL NO.^DEBTOR^Pt ID^TYP ^ACTNCD ^REJECT DATE ^SRC ^ERR CODES"
+7 SET COLHDRS="BILL NO. ^DEBTOR ^Pt ID ^TYP ^ACTNCD ^REJECT DATE ^SRC ^ERR CODES"
+8 SET COLDASH="----------- ^------------------- ^----- ^--- ^------ ^----------- ^--- ^---------"
+9 SET (CHDR,CDSH,CWID)=""
+10 IF RPTTYP=1
SET CWID=COLWIDTH1
SET CHDR=$SELECT(EXCEL:COLHDRS,1:$TRANSLATE(COLHDRS,"^",""))
SET CDSH=$SELECT(EXCEL:COLDASH,1:$TRANSLATE(COLDASH,"^",""))
+11 IF RPTTYP=2
FOR PC=2,1,3:1:8
DO COLHDR
+12 IF RPTTYP=3
FOR PC=6,1:1:5,7,8
DO COLHDR
+13 QUIT
PROMPTS SET U="^"
+1 SET STOP=0
SET PROMPT="*** DEBT REFERRAL REJECT REPORT ***"
+2 SET DTFRMTO=$$DTFRMTO(PROMPT)
IF 'DTFRMTO
SET (STOP,POP)=1
QUIT
+3 ;
+4 SET PROMPT="Group Error Codes: Brief or Detail"
+5 SET DIR(0)="SB^B:Brief;D:Detail"
+6 SET GROUPBD=$$SELECT(PROMPT,"B")
IF "BD"'[GROUPBD
SET (STOP,POP)=1
QUIT
+7 ;
+8 SET SET="S^1:Bill Number;2:Debtor Name;3:CS Reject Date"
+9 SET RPTTYP=$$RPTTYP("Select One of the Following:",SET)
IF 'RPTTYP
SET (STOP,POP)=1
QUIT
+10 ;
+11 SET PROMPT="Include Only: AITC, DMC, TREASURY or 'ALL'"
+12 SET DIR(0)="SB^A:AITC;D:DMC;T:TREASURY;ALL:ALL"
SET DIR("L")=PROMPT
+13 SET INCLUDE=$$SELECT(PROMPT,"ALL")
IF "ADT"'[$EXTRACT(INCLUDE)
SET (STOP,POP)=1
QUIT
+14 ;
+15 SET PROMPT="Sort ASCENDING or DESCENDING"
SET DIR(0)="SB^A:ASCENDING;D:DESCENDING"
+16 SET DIR("L")=PROMPT
+17 SET ASCDES=$$SELECT(PROMPT,"A")
IF "AD"'[ASCDES
SET (STOP,POP)=1
QUIT
+18 ;
+19 SET EXCEL=0
+20 IF GROUPBD="B"
Begin DoDot:1
+21 SET PROMPT="CAPTURE Report data to an Excel Document"
+22 SET DIR(0)="Y"
SET DIR("?")="^D HEXC^RCTCSJR"
+23 SET EXCEL=$$SELECT(PROMPT,"NO")
IF "01"'[EXCEL
SET (POP,STOP)=1
QUIT
End DoDot:1
+24 ; Display Excel display message
IF EXCEL=1
DO EXCMSG^RCTCSJR
+25 ;
+26 KILL IOP,IO("Q")
SET %ZIS="MQ"
SET %ZIS("B")=""
DO ^%ZIS
IF POP
SET STOP=1
QUIT
+27 IF $DATA(IO("Q"))
Begin DoDot:1
+28 SET ZTSAVE("DEBTOR")=""
SET ZTSAVE("DTFRMTO")=""
SET ZTSAVE("EXCEL")=""
SET ZTSAVE("PROMPT")=""
SET ZTSAVE("DASH")=""
SET ZTSAVE("BLNKS")=""
SET ZTSAVE("DATAITMS")=""
SET ZTSAVE("RPTITEMS")=""
+29 SET ZTSAVE("GROUPBD")=""
SET ZTSAVE("RPTTYP")=""
SET ZTSAVE("INCLUDE")=""
SET ZTSAVE("ASCDES")=""
SET ZTSAVE("CHDR")=""
SET ZTSAVE("CDSH")=""
SET ZTSAVE("ZTASK")=""
+30 SET ZTRTN="QRPT^RCTCSJR"
SET ZTDESC="CROSS-SERVICING BILL REPORT"
+31 DO ^%ZTLOAD
DO ^%ZISC
SET (STOP,POP)=1
+32 IF $GET(ZTSK)
WRITE !!,"Report compilation has started with task# ",ZTSK,".",!
SET DIR(0)="E"
DO ^DIR
KILL DIR
+33 QUIT
End DoDot:1
QUIT
+34 ; PROMPTS
QUIT
+35 ;
SELECT(PROMPT,DEFAULT) ; prompts for a selection
+1 ;INPUT:
+2 ; PROMPT - Message to display prior to prompting for dates
+3 ;OUTPUT:
+4 ; 1^BEGDT^ENDDT - Data found
+5 ; 0 - User up arrowed or timed out
+6 NEW Y,X,DTOUT,OUT,DIRUT,DUOUT,DIROUT
+7 SET OUT=0
+8 WRITE !
+9 SET DIR("A")=PROMPT
SET DIR("B")=DEFAULT
+10 DO ^DIR
KILL DIR
+11 ;Quit if user time out or didn't enter valid date
+12 if Y<0
QUIT OUT
+13 QUIT Y
+14 ;
RPTTYP(PROMPT,SET) ;PRINT CROSS-SERVICING REPORT; print cross-servicing report, prints sorted individual bills that make up a cross-servicing account
+1 NEW DIC,ZTSAVE,ZTDESC,ZTRTN,RCSORT
+2 SET OUT=0
+3 WRITE !
+4 ;"S^1:Bill Number;2:Debtor Name;3:CS Reject Date"
SET DIR(0)=SET
+5 SET DIR("A")="Sort by"
SET DIR("B")=1
DO ^DIR
KILL DIR
+6 if Y<0
QUIT OUT
+7 QUIT Y
+8 ;
DTFRMTO(PROMPT) ;Get from and to dates
+1 ;INPUT:
+2 ; PROMPT - Message to display prior to prompting for dates
+3 ;OUTPUT:
+4 ; 1^BEGDT^ENDDT - Data found
+5 ; 0 - User up arrowed or timed out
+6 ;
+7 NEW %DT,Y,X,BEGDT,ENDDT,DTOUT,OUT,DIRUT,DUOUT,DIROUT
+8 SET OUT=0
+9 WRITE !,$GET(PROMPT)
+10 ;Enter Beginning Date: "
SET %DT="AEX"
SET %DT("A")="Date Range: FROM: "
+11 SET %DT("B")="T-7"
+12 WRITE !
+13 DO ^%DT
KILL %DT
+14 ;Quit if user time out or didn't enter valid date
if Y<0
QUIT OUT
+15 SET DTFROM=+Y
+16 SET %DT="AEX"
+17 ;"TODAY"
SET %DT("A")=" TO: "
SET %DT("B")="T"
+18 DO ^%DT
KILL %DT
+19 ;Quit if user time out or didn't enter valid date
+20 if Y<0
QUIT OUT
+21 SET DTTO=+Y
SET OUT=1_U_DTFROM_U_DTTO
+22 ;Switch dates if Begin Date is more recent than End Date
+23 if DTFROM>DTTO
SET OUT=1_U_DTTO_U_DTFROM
+24 QUIT OUT
+25 ;
HEXC ; - 'Do you want to capture data to EXCEL' prompt
+1 WRITE !!," Enter: 'Y' - To capture detail report data to transfer",!," to an Excel document"
+2 WRITE !," '<CR>' - To skip this option",!," '^' - To quit this option"
+3 QUIT
+4 ;
EXCMSG ; - Displays the message about capturing to an Excel file format
+1 ;
+2 WRITE !!?5,"To capture as an Excel format, it is recommended that you queue this"
+3 WRITE !?5,"report to a spool device with margins of 256 and page length of 99999"
+4 WRITE !?5,"(e.g. 0;256;99999). This should help avoid wrapping problems."
+5 WRITE !!?5,"Another method would be to set up your terminal to capture the detail"
+6 WRITE !?5,"report data. On some terminals, this can be done by invoking 'Logging'"
+7 WRITE !?5,"or clicking on the 'Tools' menu above, then click on 'Capture Incoming "
+8 WRITE !?5,"Data' to save to Desktop. To avoid undesired wrapping of the data saved"
+9 WRITE !?5,"to the file, change the DISPLAY screen width size to 132 and you can"
+10 WRITE !?5,"enter '0;256;99999' at the 'DEVICE:' prompt.",!
+11 QUIT
+12 ; ========================================================================
