Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RCRPDR

RCRPDR.m

Go to the documentation of this file. 
  1. RCRPDR ;EDE/YMG - REPAYMENT PLAN DELINQUENT / DEFAULT LETTER REPORTS; 12/28/2020
  1.  ;;4.5;Accounts Receivable;**378,389,429**;Mar 20, 1995;Build 7
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  Q
  1.  ;
  1. EN(TYPE) ; entry point
  1.  ;
  1.  ; TYPE = 0 for delinquent letter report, 1 for default letter report
  1.  ;
  1.  N CLEARQ,EXCEL,POP,ZTDESC,ZTRTN,ZTSAVE,ZTSK,%ZIS
  1.  K ^TMP("RCRPDR",$J)
  1.  W !!,"Print ",$S(TYPE=1:"Default",1:"Delinquent")," Letter Report",!
  1.  ; export to Excel?
  1.  W !,"Answer Yes to print this report in a Mail-merge compatible format."
  1.  W !!,"If you Answer No, the Statement Account Number for the Debtor will not"  ; PRCA*4.5*389
  1.  W !,"appear on the screen.",!!  ; PRCA*4.5*389
  1.  S EXCEL=$$ASKEXCEL^RCRPRPU() I EXCEL<0 Q
  1.  I 'EXCEL W !!,"This report requires 132 characters",!
  1.  I EXCEL D EXCMSG^RCTCSJR    ; Display Excel display message I EXCEL
  1.  ; ask for device
  1.  K IOP,IO("Q")
  1.  S %ZIS="MQ",%ZIS("B")="",POP=0 D ^%ZIS Q:POP
  1.  I $D(IO("Q")) S CLEARQ=$$ASKCLR() Q:CLEARQ<0  D  Q  ; queued report: ask if print queue should be cleared, then queue task
  1.  .S ZTDESC="Repayment Plan "_$S(TYPE=1:"Default",1:"Delinquent")_" Letter Report"
  1.  .S ZTRTN="COMPILE^RCRPDR"
  1.  .S ZTSAVE("TYPE")="",ZTSAVE("EXCEL")="",ZTSAVE("CLEARQ")="",ZTSAVE("ZTREQ")="@"
  1.  .D ^%ZTLOAD,HOME^%ZIS
  1.  .I $G(ZTSK) W !!,"Report compilation has started with task# ",ZTSK,".",! D PAUSE^RCRPRPU
  1.  .Q
  1.  D COMPILE
  1.  Q
  1.  ;
  1. COMPILE ; compile report
  1.  N ACCTNUM,ADDRSTR,CRNTDT,DEBT,DEBTOR,MED,N0,NAME,RPIEN,RPPID,TMP,TMPSTR,XREF
  1.  S XREF=$S(TYPE:"PRTDEF",1:"PRTDEL")
  1.  S RPIEN=0 F  S RPIEN=$O(^RCRP(340.5,XREF,1,RPIEN)) Q:'RPIEN  D
  1.  .S N0=^RCRP(340.5,RPIEN,0)
  1.  .S RPPID=$P(N0,U),DEBTOR=+$P(N0,U,2) Q:DEBTOR'>0
  1.  .S ADDRSTR=$P($$DADD^RCAMADD(DEBTOR,1),U,1,6)     ; ADDRSTR = Str1^Str2^Str3^City^State^ZIP
  1.  .S NAME=$$NAM^RCFN01(DEBTOR) Q:NAME=""  ; debtor name
  1.  .S DEBT=U_$P(NAME,",")  ; needed for ACCT^PRCAAPR1, 2nd piece contains last name of the debtor  PRCA*4.5*389
  1.  .; PRCA*4.5*429
  1.  .S TMP=$P($G(^RCD(340,DEBTOR,0)),U)
  1.  .S MED=1 I $P(TMP,";",2)'="DPT(" S MED=0  ; non-medical debt
  1.  .S ACCTNUM="N/A" I MED S ACCTNUM=$$ACCT^PRCAAPR1($P(TMP,";"))
  1.  .I 'MED S NAME="*"_NAME
  1.  .;
  1.  .S TMPSTR="" S TMPSTR=$$CALC(RPIEN,+$P(N0,U,6)) Q:'+$P(TMPSTR,U)  ; PRCA*4.5*389
  1.  .S ^TMP("RCRPDR",$J,NAME)=ADDRSTR_U_ACCTNUM  ; PRCA*4.5*389
  1.  .S ^TMP("RCRPDR",$J,NAME,RPPID)=TMPSTR
  1.  .S ^TMP("RCRPDR",$J,NAME,RPPID,"IEN")=RPIEN
  1.  .Q
  1.  ;
  1.  D PRINT
  1.  K ^TMP("RCRPDR",$J)
  1.  Q
  1.  ;
  1. PRINT ; print report
  1.  N ACCTNUM,ADDR,AMNT,CNT,DATA,DATA1,EXTDT,LN,NAME,PAGE,RPPID,UPDT
  1.  U IO
  1.  S PAGE=0
  1.  S EXTDT=$$FMTE^XLFDT(DT)
  1.  I EXCEL D
  1.  .W !,"Print ",$S(TYPE=1:"Default",1:"Delinquent")," Letter Report;",EXTDT
  1.  .W !,"Name^Statement Account Number^Street Address^Address 2^Address 3^City^State^Zip Code^RPP ID^Amount Due" W:'TYPE "^Current Through"
  1.  .Q
  1.  I 'EXCEL D
  1.  .I $E(IOST,1,2)["C-",'$D(ZTQUEUED) W @IOF
  1.  .D HDR
  1.  .Q
  1.  I '$D(^TMP("RCRPDR",$J)) D  Q
  1.  .I EXCEL W !!,"No records found." Q
  1.  .W !!,$$CJ^XLFSTR("No records found.",132)
  1.  .Q
  1.  S NAME="" F  S NAME=$O(^TMP("RCRPDR",$J,NAME)) Q:NAME=""  D
  1.  .S RPPID="" F  S RPPID=$O(^TMP("RCRPDR",$J,NAME,RPPID)) Q:RPPID=""  D
  1.  ..S DATA1=^TMP("RCRPDR",$J,NAME),ADDR=$P(DATA1,U,1,6),ACCTNUM=$P(DATA1,U,7)  ; PRCA*4.5*389
  1.  ..S DATA=^TMP("RCRPDR",$J,NAME,RPPID)
  1.  ..S AMNT=$FN($P(DATA,U),"",2)
  1.  ..I 'TYPE S UPDT=$$FMTE^XLFDT($P(DATA,U,2),"5DZ")
  1.  ..I EXCEL D  Q
  1.  ...W !,NAME,U,ACCTNUM,U,$P(ADDR,U),U,$P(ADDR,U,2),U,$P(ADDR,U,3),U,$P(ADDR,U,4),U,$P(ADDR,U,5),U,$P(ADDR,U,6),U,RPPID,U,AMNT  ; PRCA*4.5*389
  1.  ...I 'TYPE W U,UPDT  ; PRCA*4.5*389
  1.  ...Q
  1.  ..S LN=LN+1
  1.  ..W !,$E(NAME,1,26)
  1.  ..W ?28,$E($P(ADDR,U)_" "_$P(ADDR,U,2)_" "_$P(ADDR,U,3)_", "_$P(ADDR,U,4)_", "_$P(ADDR,U,5)_" "_$P(ADDR,U,6),1,56)
  1.  ..W ?86,RPPID,?107,AMNT W:'TYPE ?119,UPDT  ; PRCA*4.5*389
  1.  ..I LN>(IOSL-4) D HDR
  1.  ..Q
  1.  .Q
  1.  ; if not queued, clear print queue if necessary
  1.  I '$D(ZTQUEUED),EXCEL W ! S CLEARQ=$$ASKCLR() I CLEARQ=1 D
  1.  .; clear print flag in file 340.5
  1.  .S NAME="" F  S NAME=$O(^TMP("RCRPDR",$J,NAME)) Q:NAME=""  D
  1.  ..S RPPID="" F  S RPPID=$O(^TMP("RCRPDR",$J,NAME,RPPID)) Q:RPPID=""  D CLRPRNT(^TMP("RCRPDR",$J,NAME,RPPID,"IEN"),TYPE)
  1.  ..Q
  1.  .Q
  1.  Q
  1.  ;
  1. HDR ; print header
  1.  I PAGE>0,'$D(ZTQUEUED) D PAUSE^RCRPRPU
  1.  W @IOF
  1.  S PAGE=PAGE+1,LN=4
  1.  W !,"Print ",$S(TYPE=1:"Default",1:"Delinquent")," Letter Report",?66,EXTDT,?120,"Page: ",PAGE
  1.  W !!,"* Indicates a non-medical debt repayment plan"
  1.  W !!,?11,"Name",?53,"Address",?91,"RPP ID",?105,"Amount Due" W:'TYPE ?117,"Current Through"  ; PRCA*4.5*389
  1.  W ! D DASH^RCRPRPU(132)
  1.  Q
  1.  ;
  1. CALC(RPIEN,MAMNT) ; calculate amount due and "current through" date
  1.  ;
  1.  ; RPIEN - file 340.5 ien
  1.  ; MAMNT - monthly amount (340.5/.06)
  1.  ;
  1.  ; returns amount due ^ "current through" date, or "" if no missing payments were found
  1.  ;
  1.  N CNT,LSTDT,N0,RPDT,TOTAL,UPDT,Z
  1.  I $G(MAMNT)'>0 Q ""
  1.  S LSTDT=$O(^RCRP(340.5,RPIEN,2,"B",""),-1) ; last due date in the schedule  PRCA*4.5*429
  1.  ; loop backwards from today's date, count entries with no payment and no forbearance
  1.  S CNT=0,RPDT=DT F  S RPDT=$O(^RCRP(340.5,RPIEN,2,"B",RPDT),-1) Q:'RPDT  D
  1.  .S Z=$O(^RCRP(340.5,RPIEN,2,"B",RPDT,"")) Q:'Z
  1.  .S N0=^RCRP(340.5,RPIEN,2,Z,0) I +$P(N0,U,2)=0,+$P(N0,U,3)=0 S CNT=CNT+1
  1.  .Q
  1.  I CNT=0 Q ""  ; no missing payments found
  1.  S UPDT=LSTDT I DT'>LSTDT D  ; PRCA*4.5*429
  1.  .S CNT=CNT+1  ; add upcoming payment
  1.  .S UPDT=$O(^RCRP(340.5,RPIEN,2,"B",DT))  ; upcoming payment date
  1.  .; if today's date is between 21st and 28th, add 2nd upcoming payment and go to the next upcoming payment date
  1.  .I DT'>$O(^RCRP(340.5,RPIEN,2,"B",LSTDT),-1) S Z=$E(DT,6,7) I Z>21,Z<28 S CNT=CNT+1,UPDT=$O(^RCRP(340.5,RPIEN,2,"B",UPDT))
  1.  .Q
  1.  S TOTAL=MAMNT*CNT ; total amount owed for missed payments
  1.  Q TOTAL_U_UPDT
  1.  ;
  1. ASKCLR() ; display "clear print queue?" prompt
  1.  ;
  1.  ; returns 1 for Yes, 0 for No, -1 for no selection
  1.  ;
  1.  ;Ask if the user wishes to clear the queue
  1.  N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1.  S DIR(0)="Y",DIR("B")="NO"
  1.  S DIR("A")="Clear the print queue after printing? (Y/N)"
  1.  D ^DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q -1
  1.  Q:+Y'=1 0
  1.  ;
  1.  ;Confirm that the user wishes to clear the queue
  1.  S DIR(0)="Y",DIR("B")="NO"
  1.  S DIR("A")="Are you sure you wish to clear the queue?  If you do, the data in this report will be lost. (Y/N)"
  1.  D ^DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q -1
  1.  Q Y
  1.  ;
  1. CLRPRNT(RPIEN,TYPE) ; clear print delinquent / print default flag for a given RPP
  1.  ;
  1.  ; RPIEN - repayment plan ien (file 340.5)
  1.  ; TYPE - 0 for print delinquent? field (340.5/1.03), 1 for print default? field (340.5/1.02)
  1.  ;
  1.  N FDA,FLD
  1.  I RPIEN'>0 Q
  1.  S FLD=$S(TYPE:1.02,1:1.03)
  1.  L +^RCRP(340.5,RPIEN):5 I '$T Q
  1.  S FDA(340.5,RPIEN_",",FLD)=0
  1.  D FILE^DIE("","FDA")
  1.  ; update audit log
  1.  D UPDAUDIT^RCRPU2(RPIEN,DT,"E",$S(TYPE:"DF",1:"DL"))
  1.  L -^RCRP(340.5,RPIEN)
  1.  Q