RCCPCPS ;WASH-ISC@ALTOONA,PA/NYB - Build Patient Statement File ;12/19/96 4:14 PM
V ;;4.5;Accounts Receivable;**34,70,80,48,104,116,149,170,181,190,223,237,219,265,301,348,397,401**;Mar 20,1995;Build 28
;;Per VA Directive 6402, this routine should not be modified.
;
;PRCA*4.5*348 Set 'BEG' lookup to handle last statement event
; whether exists or not
;
EN N CCPC,CNT,DAT,DEB,DIK,END,INADFL,LDT1,LDT3,PCC,PRN,RCDATE,RCT,SVADM,SVAMT,SVINT,SVOTH,SITE,TXT,VAR,X,%
N RCINFULL,RCINPART,STATLIM S COMM=0
S STATLIM=$$GET1^DIQ(342,1_",",101,"I")+1 ;Statment Length from AR Site Parameter file
K ^RCPS(349.2)
F X="PA","IS" S RCT=$O(^RCT(349.1,"B",X,0)) Q:'RCT K ^RCT(349.1,+RCT,4),^RCT(349.1,+RCT,5)
K ^XTMP("RCCPC")
D DT^DICRW,SITE^PRCAGU
I '$D(SITE) W !!,"AR SITE PARAMETER ENTRIES NOT DEFINED!",?50 D NOW^%DTC S Y=% D DD^%DT W Y W !!,"COULD NOT PROCESS AR PATIENT STATEMENTS" Q
D NOW^%DTC S END=%
S LDT1=$$FPS^RCAMFN01(DT,-1),RCDATE=DT
S (CNT,DEB)=0,PRN=1
F S DEB=$O(^RCD(340,"AB","DPT(",DEB)) Q:DEB="" D
. N AMT,BBAL,BEG,BN,CAT,DESC,ETY,FC,ND,PAT,PBAL,PC
. N PDAT,PEND,ST,SVINT,SVADM,SVOTH,ADDR
. I $L(+$$SSN^RCFN01(DEB))<5 Q
. ;Check for Emergency Response Indicator (ERI) Flag.
. N RCDFN S RCDFN=$P($G(^RCD(340,DEB,0)),"^",1) I $$EMERES^PRCAUTL(+RCDFN)]"" Q
. ; initialize variables for CS
. N CSBB,CSTCH,CSTPC,CSPREV S (CSBB,CSTCH,CSTPC)=0
. S INADFL=0
. S (SVADM,SVAMT,SVINT,SVOTH)=0
. N REF,SBAL,SDT,TBAL,TN,TTY,X,Y
. K ^TMP("PRCAGT",$J)
. S BEG=+$$LST^RCFN01(DEB,2,1)
. S LDT3=$S(BEG>0:$$FPS^RCAMFN01($P(BEG,"."),-3),1:0)
. I $P(BEG,".")'<$P(RCDATE,".") Q
. D NOW^%DTC S END=%
. I BEG<1 S PDAT="",BEG=0,PBAL=0
. I BEG S PDAT=BEG,BEG=9999999.999999-BEG,PBAL=0 D PBAL^PRCAGU(DEB,.BEG,.PBAL,1) ;get prev bal ; PRCA*4.5*348 set statement flag
. D EN^PRCAGT(DEB,BEG,.END)
. S TBAL=0 D TBAL^PRCAGT(DEB,.TBAL) ;get trans bal
. S BBAL=0 D BBAL^PRCAGU(DEB,.BBAL) ;get bill bal
. I CSBB,CSBB'<BBAL Q ; entire account has been referred to CS
. S X=$$PRE^PRCAGU(DEB) S PEND=$P(X,U,2),X=+X I X,BBAL D REF^PRCAGD(DEB,X,$G(REP)) Q
. I BBAL=0,PEND,-PEND=PBAL+TBAL Q
. I BBAL'=(PBAL+TBAL) D EN^PRCAGD(DEB,BBAL,TBAL,PBAL,BEG,$G(REP)) Q
. I BBAL'>0,'$D(^TMP("PRCAGT",$J,DEB)) Q
. I BBAL=0,$G(SITE("ZERO")) Q
. I BBAL<0,BBAL>-.99 Q
. I BBAL'<0,'$D(^XTMP("PRCAGU",$J,DEB)),'COMM Q ;third letter printed,not comment
. S TBAL=TBAL+PBAL
. ;adjust amounts to be filed in 349.2 for CS bills
. S TBAL=TBAL-CSBB ; reduce the total bill balance by CS balance
. S CSPREV=CSBB-(CSTCH+CSTPC) ; compute the CS previous balance as the difference between the bill balance and the transaction balance
. S PBAL=PBAL-CSPREV ; reduce the previous balance by the CS previous balance
. S TBAL("CH")=TBAL("CH")-CSTCH ; reduce total charges by CS charges
. S TBAL("PC")=TBAL("PC")-CSTPC ; reduce total credits by CS credits
. I '$D(^RCPS(349.2,0)) S ^(0)="AR CCPC STATEMENTS RECORDS^349.2I^"
. S ^RCPS(349.2,DEB,0)=DEB_"^"_$$SSN^RCFN01(DEB)_"^"
. S ADDR=$$DADD^RCAMADD(DEB,1) ;get patient's address, confidential if applicable
. S ^RCPS(349.2,DEB,1)=$P(ADDR,"^",1,6)
. S ST=$P(ADDR,"^",5)
. S ^RCPS(349.2,DEB,7)=$P(^RCD(340,DEB,0),U,7) ;large print
. I $G(ST)'="" S ST=$O(^DIC(5,"C",ST,0))
. I $G(ST)>90,'$P($G(^DIC(5,ST,0)),"^",6) S FC=$P($G(^DIC(5,ST,0)),"^")
. S $P(^RCPS(349.2,DEB,1),"^",7)=$G(FC) S:$G(FC)]"" $P(^RCPS(349.2,DEB,1),"^",5)="FX"
. S:$G(FC)]"" $P(^RCPS(349.2,DEB,1),"^",6)=$P(ADDR,"^",8)
. D NOW^%DTC S $P(^RCPS(349.2,DEB,0),"^",10)=%
. S $P(^RCPS(349.2,DEB,0),"^",3)=$$NAM^RCFN01(DEB)
. S $P(^RCPS(349.2,DEB,0),"^",4,7)=$S(TBAL'>0:0,1:TBAL)_"^"_PBAL_"^"_TBAL("CH")_"^"_TBAL("PC"),$P(^(0),"^",8)=PBAL+TBAL("CH")+TBAL("PC")+TBAL("RF")
. S $P(^RCPS(349.2,DEB,0),"^",13,17)=BBAL("PB")_"^"_BBAL("INT")_"^"_BBAL("ADM")_"^"_BBAL("MF")_"^"_BBAL("CT")
. ;
. N RCBILLDA,RCDATA1,RCDEBTDA,RCDESC,RCPSDA,RCTOTAL,RCTRANDA,RCTRDATE,VALUE,RCCOM1,RCCOM2,RCCOM3
. S RCDEBTDA=DEB
. I '$D(^RCPS(349.2,RCDEBTDA,2,0)) S ^(0)="^349.21DA^^"
. ;
. S RCCOM1=$E($TR($G(SITE("COM1")),"~|^",""),1,80),(RCCOM2,RCCOM3)=""
. ; Add second comment line for the GMT-reduced status
. I $$GMT^PRCAGST(RCDEBTDA) S RCCOM2="REDUCTION OF INPATIENT COPAYMENT DUE TO GEOGRAPHIC MEANS TEST STATUS"
. I TBAL'>0 S RCCOM3=" *THIS IS NOT A BILL*"
. I RCCOM1'="",RCCOM2'="" S $E(RCCOM1,80)=" " ;Make sure GMT message will be printed on separate line.
. S ^RCPS(349.2,RCDEBTDA,3)=RCCOM1_RCCOM2_RCCOM3
. ;
. S RCPSDA=0 ; this variable used to set the description on the PS segment
. S RCTRDATE=0 F S RCTRDATE=$O(^TMP("PRCAGT",$J,RCDEBTDA,RCTRDATE)) Q:'RCTRDATE S RCBILLDA=0 F S RCBILLDA=$O(^TMP("PRCAGT",$J,RCDEBTDA,RCTRDATE,RCBILLDA)) Q:'RCBILLDA D
. . Q:$D(^PRCA(430,"TCSP",RCBILLDA)) ; skip CS bills/transactions
. . I $P($G(^RCPS(349.2,RCDEBTDA,0)),"^",8)<0 S PC(75)=75
. . I $P($G(^PRCA(430,RCBILLDA,6)),"^",2)]"",($P($G(^PRCA(430,RCBILLDA,7)),"^")>0) S PC(1)="01"
. . S CAT=$P($G(^PRCA(430,RCBILLDA,0)),"^",2)
. . S PC=$P($G(^PRCA(430.2,CAT,0)),"^",14)
. . F X=1:1:100 I $P(PC,",",X)'="" S PCC=$P(PC,",",X),PC(+PCC)=PCC Q:PCC=""
. . S PC="",X=0 F S X=$O(PC(X)) Q:X="" I $G(PC(X))'="" S PC=PC_PC(X)
. . S $P(^RCPS(349.2,RCDEBTDA,4),"^")=PC
. . ;
. . I $D(^TMP("PRCAGT",$J,RCDEBTDA,RCTRDATE,RCBILLDA,0)) S AMT=+^(0) I AMT D
. . . ; get the description for the bill
. . . K RCDESC D BILLDESC^RCCPCPS1(RCBILLDA)
. . . ;
. . . ; store the description in file 349.2, PS segment
. . . S RCPSDA=RCPSDA+1
. . . S $P(^RCPS(349.2,RCDEBTDA,2,RCPSDA,0),"^",1,4)=$P(RCTRDATE,".")_"^"_$G(RCDESC(1))_"^"_$G(AMT)_"^"_$P(^PRCA(430,RCBILLDA,0),"^")
. . . F X=2:1 Q:$G(RCDESC(X))="" S RCPSDA=RCPSDA+1,^RCPS(349.2,RCDEBTDA,2,RCPSDA,0)="^"_RCDESC(X)_"^^"
. . ;
. . S RCTRANDA=0 F S RCTRANDA=$O(^TMP("PRCAGT",$J,RCDEBTDA,RCTRDATE,RCBILLDA,RCTRANDA)) D:'RCTRANDA NO Q:'RCTRANDA D
. . . ; get the description for the transaction
. . . K RCDESC D TRANDESC^RCCPCPS1(RCTRANDA),RCDESC
. . . ; if it is an interest/admin charge, summarize it below
. . . I $G(RCDESC(1))["INTEREST" Q
. . . ; get the value of the transaction for the statement
. . . S VALUE=$$TRANVALU^RCDPBTLM(RCTRANDA)
. . . S VALUE=$P(VALUE,"^",2)+$P(VALUE,"^",3)+$P(VALUE,"^",4)+$P(VALUE,"^",5)+$P(VALUE,"^",6)
. . . ; if it is a suspended (47) or unsuspended (46) transaction, show value
. . . ; make suspended charges appear as negative
. . . S RCDATA1=$G(^PRCA(433,RCTRANDA,1))
. . . I $P(RCDATA1,"^",2)=47!($P(RCDATA1,"^",2)=46) S VALUE=$P(RCDATA1,"^",5) I $P(RCDATA1,"^",2)=47 S VALUE=-VALUE
. . . ; if it is an amended bill, show value
. . . I $P(RCDATA1,"^",2)=33 S VALUE=$P(RCDATA1,"^",5)
. . . ; store the description in file 349.2, PS segment
. . . S RCPSDA=RCPSDA+1
. . . S $P(^RCPS(349.2,RCDEBTDA,2,RCPSDA,0),"^",1,5)=$P(RCTRDATE,".")_"^"_$G(RCDESC(1))_"^"_VALUE_"^"_$P(^PRCA(430,RCBILLDA,0),"^")
. . . F X=2:1 Q:$G(RCDESC(X))="" S RCPSDA=RCPSDA+1,^RCPS(349.2,RCDEBTDA,2,RCPSDA,0)="^"_RCDESC(X)_"^^"
. . . ;
. . . ; for comment transaction ... not sure what this is for ?
. . . I $P(RCDATA1,"^",2)=45,$P($G(^PRCA(433,RCTRANDA,5)),"^",2)["your waiver rights" S ^RCPS(349.2,+RCDEBTDA,4)="0150"
. ;
. ; if interest, admin, or other, add them here
. S X=$G(RCTOTAL("INT"))+$G(RCTOTAL("ADM"))+$G(RCTOTAL("OTH"))
. I X>0 D
. . S RCDESC="INTEREST/ADM. CHARGE (Int:"_$J($G(RCTOTAL("INT")),1,2)_" Adm:"_$J($G(RCTOTAL("ADM")),1,2)_" Other:"_$J($G(RCTOTAL("OTH")),1,2)_")"
. . S RCPSDA=RCPSDA+1
. . S ^RCPS(349.2,RCDEBTDA,2,RCPSDA,0)="^"_RCDESC_"^"_$J(X,1,2)
. . S ^RCPS(349.2,RCDEBTDA,2,0)="^349.21DA^"_RCPSDA_"^"_RCPSDA
. ;
. ; set 0th node
. I RCPSDA S ^RCPS(349.2,RCDEBTDA,2,0)="^349.21DA^"_RCPSDA_"^"_RCPSDA
. ;
. I RCPSDA'<STATLIM D Q ;PRCA*4.5*401 Flag Oversized statements for later printing
. . D FILEOSFG(RCDEBTDA,"S")
. . S DIK="^RCPS(349.2,",DA=RCDEBTDA D ^DIK ;Remove statement from file 349.2 if oveersize
. D NO
;
S DIK="^RCPS(349.2," D IXALL^DIK
S DEB=0 S DEB=$O(^RCPS(349.2,DEB)) Q:DEB="" S $P(^(DEB,0),"^",18)=1
K ^XTMP("PRCAGU",$J,DEB),COMM
D RCCPOSST ;Check for Over Size statements and send exteranl email to
Q
;
OSTM ;Process old statements ;PRCA*4.5*401
;S DIK="^RCPS(349.2,",DA=0 F S DA=$O(^XTMP("RCCPC",DA)) Q:'DA D ^DIK
;K DA
;
STATMNT ;Print oversized patient statements to local printer
N POP,ZTIO,ZTSAVE,ZTRTN,ZTDESC,ZTASK,%ZIS,ZTDTH,PRCADEV,DIR
N DIRUT,DTOUT,DUOUT,DIROUT,X,Y
;
;Confirm to continue
S DIR("A",1)="You are about to print oversized patient statements locally. "
S DIR("A")="Are you sure you wish to print these statements? (Y/N)"
S DIR(0)="Y",DIR("B")="Y"
D ^DIR
;
I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) W !,"Nothing done" Q
I Y'=1 W !,"Nothing done" Q
;
W !
S DIR("A")="Print to the (S)creen or to the (D)efault Printer? <Default> (S/D)"
S DIR(0)="SB^S:Screen;D:Default",DIR("B")="D"
D ^DIR
;
I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) W !,"Nothing done" Q
;
I Y="D" S (IOP,PRCADEV)=$P($G(^RC(342,1,"CCPC")),"^",2) ; set printer to file #342 field 102
I Y="D",(IOP']"") W !,"Cannot continue." Q
I Y="S" K IOP,IO("Q") S %ZIS="MQ" D ^%ZIS Q:POP
I Y="D" S %ZIS="N0" D ^%ZIS Q:POP
I Y="S" D STM^RCCPCSTM Q
S ZTRTN="STM^RCCPCSTM",ZTDTH=$H,ZTDESC="Print old AR Statements"
S ZTSAVE("PRCADEV")=""
D ^%ZTLOAD,^%ZISC
Q
;
NO ;If there is no activity
I $G(^RCPS(349.2,+DEB,4))["0150" D
.S ^RCPS(349.2,+DEB,2,1,0)="^NOTICE: You now have delinquent charges. Please^^"
.S ^RCPS(349.2,+DEB,2,2,0)="^review Enforcement of Involuntary Collections^^"
.S ^RCPS(349.2,+DEB,2,3,0)="^on reverse.^^"
.S ^RCPS(349.2,+DEB,2,0)="^^3^3"
I $G(^RCPS(349.2,DEB,2,1,0))="" D
.S ^RCPS(349.2,DEB,2,1,0)="^No Activity in the Last 30 Days!^^"
.S ^RCPS(349.2,DEB,2,2,0)="^Please refer to previous statement of rights.^^"
.S ^RCPS(349.2,DEB,2,0)="^^2^2"
.I $G(^RCPS(349.2,DEB,4))="" S ^(4)="90"
Q
BUILD ;This is the entry point from the BUILD CCPC file option
N TDT,QDT,ZTDESC,ZTASK,ZTSK,ZDTDTH,ZTIO,ZTRTN
S TDT=$O(^RCPS(349.2,0)) I TDT D
.S TDT=$$ASOF^RCCPCFN($P($G(^RCPS(349.2,+TDT,0)),"^",10))
.S TDT=$TR($$SLH^RCFN01(TDT),"/","")
.S TDT("T")=$P($G(^RCT(349,1,0)),"^",10),TDT("T")=$E(TDT("T"),1,4)_$E(TDT("T"),7,8)
.I TDT("T")=TDT D
..W *7,!,"The current file reflects activity as of ",$E(TDT,1,2)_"/"_$E(TDT,3,4)_"/"_$E(TDT,5,8)_".",!
..W !,"IT WAS TRANSMITTED ON ",$TR($P($P($G(^RCT(349,1,0)),"^"),".",2,4),".","/"),!
..S TDT=$P($G(^RCT(349,1,0)),"^",9)
..W !,"For statement date: ",$E(TDT,1,2)_"/"_$E(TDT,3,4)_"/"_$E(TDT,5,8)
..W !!,"PLEASE CONTACT CUSTOMER SUPPORT BEFORE PROCEEDING.",!!
TIME S ZTIO="",ZTRTN="EN^RCCPCPS",ZTDESC="Build CCPC Statement File"
S ZTDTH="" D ^%ZTLOAD Q:$G(ZTSK)=""
S %H=ZTSK("D") D YX^%DTC,H^%DTC I %Y=0!(%Y=6) W !,"Queued for Building." Q ;PRC*4.5*348
S %H=ZTSK("D") D YMD^%DTC S QDT=X_%
I (QDT>(X_".0800"))&(QDT<(X_".1801")) D G TIME ;PRC*4.5*348
.W !!,*7,"You Can Not Queue this Job on a weekday Between 8:00am and 6:00pm.",!
.D KILL^%ZTLOAD
W !,"Queued for Building."
Q
;
RCDESC ;Remove "IN PART" & "IN FULL" from the the bill description
QUIT:$G(RCDESC(1))=""
S RCINFULL=" (IN FULL)"
S RCINPART=" (IN PART)"
I RCDESC(1)[RCINFULL S RCDESC(1)=$P(RCDESC(1),RCINFULL)_$P(RCDESC(1),RCINFULL,2)
I RCDESC(1)[RCINPART S RCDESC(1)=$P(RCDESC(1),RCINPART)_$P(RCDESC(1),RCINPART,2)
Q
;
RCCPOSST ; ;PRCA*4.5*401 Sends external email to Mail group to notify there are statements to print
N RCDEBIEN,CNT,LINE,XMDUZ,XMTEXT,XMY,XMSUB
S (RCDEBIEN,CNT)=0
K ^TMP($J,"RCCPSTMTMSG")
F S RCDEBIEN=$O(^RCD(340,"ALOCAL",1,RCDEBIEN)) Q:RCDEBIEN="" S CNT=CNT+1
I CNT=0 Q
S XMSUB="OVER SIZE STATEMENTS TO PRINT"
S LINE=0
S LINE=LINE+1,^TMP($J,"RCCPSTMTMSG",LINE)="There are "_CNT_" Oversized statements waiting to be printed."
S XMTEXT="^TMP($J,""RCCPSTMTMSG"","
;S XMDUZ=$O(^VA(200,"B","POSTMASTER",0))
S XMDUZ=.5
S XMY("G.RCCPC EXTERNAL")=""
D ^XMD
Q
;
FILEOSFG(RCDEBTDA,RCFT) ; ;PRCA*4.5*401 Set/Clear LOCAL PRINT flag, in file 340, to:
; Yes, i.e. 1 if RCFT="S"
; No, i.e. 0 if RCFT="C"
; RCDEBTDA = File 340 IEN
; RCFT = Filing Type (S Set or C Clear)
;
;VBLLST format - Principal Balance / Interest / Admin Fees / Court Costs / Marshal Fees / Date statement printed
;
N DIE,DA,DR,VBLLST
I RCFT="S" S DIE="^RCD(340,",DA=RCDEBTDA,DR="112///Y"
I RCFT="C" S DIE="^RCD(340,",DA=RCDEBTDA,DR="112///N"
D ^DIE
I RCFT="S" D
. S VBLLST=BBAL("PB")_"/"_BBAL("INT")_"/"_BBAL("ADM")_"/"_BBAL("CT")_"/"_BBAL("MF")_"/"_$$NOW^XLFDT
. S DIE="^RCD(340,",DA=RCDEBTDA,DR="113///"_VBLLST
I RCFT="C" S DIE="^RCD(340,",DA=RCDEBTDA,DR="113///@"
D ^DIE
K DIE,DA,DR
Q
;
CLRSTMTQ ;;PRCA*4.5*401 Clear Oversize statement queue
N RCIEN,RCFT
N DIR,X,Y,DA,DTOUT,DUOUT,DIRUT,DIROUT
S RCFT="C",RCIEN=""
; Loop through AR DEBTOR "C" index and clear all that are set to Yes
S DIR("A",1)="*** Clearing the queue at this time will prevent these"
S DIR("A",2)=" statements from printing again to the Statement Printer"
S DIR("A",3)=" through this option."
S DIR("A",4)=" "
S DIR("A")="Are you sure you want to clear this print queue? (Y/N)"
S DIR(0)="Y",DIR("B")="N",DIR("T")=30
D ^DIR
I Y'=1 W !,"Nothing done" H 2 Q
F S RCIEN=$O(^RCD(340,"ALOCAL",1,RCIEN)) Q:RCIEN="" D
. D FILESTAT(RCIEN)
. D FILEOSFG(RCIEN,RCFT)
W !!,"Local Statement Queue has been cleared" H 2
Q
;
FILESTAT(DEB); ;PRCA*4.5*401 File
; INPUT: DEB - Debtor IEN (file 340)
;
;VBLLST format - Principal Balance / Interest / Admin Fees / Court Costs / Marshal Fees / Date statement printed
;
N VBLLST,BBAL,END,ERR,EVN
S VBLLST=$$GET1^DIQ(340,DEB_",",113,"I") ;Recall saved BBAL array as string
; Parse BBAL array from string VBLLST
S BBAL("PB")=$P(VBLLST,"/",1),BBAL("INT")=$P(VBLLST,"/",2),BBAL("ADM")=$P(VBLLST,"/",3)
S BBAL("CT")=$P(VBLLST,"/",4),BBAL("MF")=$P(VBLLST,"/",5)
;Set End to the day the process ran rather than the day the statements were actually printed to avoid out of balance issues.
S END=$P(VBLLST,"/",6)
D OPEN^RCEVDRV1(2,$P(^RCD(340,DEB,0),U),END,DUZ,$$SITE^RCMSITE,.ERR,.EVN,BBAL("PB")_U_BBAL("INT")_U_BBAL("ADM")_U_BBAL("CT")_U_BBAL("MF"))
I EVN D CLOSE^RCEVDRV1(EVN)
D UPDAT^PRCAGU(DEB,DT) ;set bill letter field
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCCPCPS 14782 printed Oct 16, 2024@17:44:03 Page 2
RCCPCPS ;WASH-ISC@ALTOONA,PA/NYB - Build Patient Statement File ;12/19/96 4:14 PM
V ;;4.5;Accounts Receivable;**34,70,80,48,104,116,149,170,181,190,223,237,219,265,301,348,397,401**;Mar 20,1995;Build 28
+1 ;;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRCA*4.5*348 Set 'BEG' lookup to handle last statement event
+4 ; whether exists or not
+5 ;
EN NEW CCPC,CNT,DAT,DEB,DIK,END,INADFL,LDT1,LDT3,PCC,PRN,RCDATE,RCT,SVADM,SVAMT,SVINT,SVOTH,SITE,TXT,VAR,X,%
+1 NEW RCINFULL,RCINPART,STATLIM
SET COMM=0
+2 ;Statment Length from AR Site Parameter file
SET STATLIM=$$GET1^DIQ(342,1_",",101,"I")+1
+3 KILL ^RCPS(349.2)
+4 FOR X="PA","IS"
SET RCT=$ORDER(^RCT(349.1,"B",X,0))
if 'RCT
QUIT
KILL ^RCT(349.1,+RCT,4),^RCT(349.1,+RCT,5)
+5 KILL ^XTMP("RCCPC")
+6 DO DT^DICRW
DO SITE^PRCAGU
+7 IF '$DATA(SITE)
WRITE !!,"AR SITE PARAMETER ENTRIES NOT DEFINED!",?50
DO NOW^%DTC
SET Y=%
DO DD^%DT
WRITE Y
WRITE !!,"COULD NOT PROCESS AR PATIENT STATEMENTS"
QUIT
+8 DO NOW^%DTC
SET END=%
+9 SET LDT1=$$FPS^RCAMFN01(DT,-1)
SET RCDATE=DT
+10 SET (CNT,DEB)=0
SET PRN=1
+11 FOR
SET DEB=$ORDER(^RCD(340,"AB","DPT(",DEB))
if DEB=""
QUIT
Begin DoDot:1
+12 NEW AMT,BBAL,BEG,BN,CAT,DESC,ETY,FC,ND,PAT,PBAL,PC
+13 NEW PDAT,PEND,ST,SVINT,SVADM,SVOTH,ADDR
+14 IF $LENGTH(+$$SSN^RCFN01(DEB))<5
QUIT
+15 ;Check for Emergency Response Indicator (ERI) Flag.
+16 NEW RCDFN
SET RCDFN=$PIECE($GET(^RCD(340,DEB,0)),"^",1)
IF $$EMERES^PRCAUTL(+RCDFN)]""
QUIT
+17 ; initialize variables for CS
+18 NEW CSBB,CSTCH,CSTPC,CSPREV
SET (CSBB,CSTCH,CSTPC)=0
+19 SET INADFL=0
+20 SET (SVADM,SVAMT,SVINT,SVOTH)=0
+21 NEW REF,SBAL,SDT,TBAL,TN,TTY,X,Y
+22 KILL ^TMP("PRCAGT",$JOB)
+23 SET BEG=+$$LST^RCFN01(DEB,2,1)
+24 SET LDT3=$SELECT(BEG>0:$$FPS^RCAMFN01($PIECE(BEG,"."),-3),1:0)
+25 IF $PIECE(BEG,".")'<$PIECE(RCDATE,".")
QUIT
+26 DO NOW^%DTC
SET END=%
+27 IF BEG<1
SET PDAT=""
SET BEG=0
SET PBAL=0
+28 ;get prev bal ; PRCA*4.5*348 set statement flag
IF BEG
SET PDAT=BEG
SET BEG=9999999.999999-BEG
SET PBAL=0
DO PBAL^PRCAGU(DEB,.BEG,.PBAL,1)
+29 DO EN^PRCAGT(DEB,BEG,.END)
+30 ;get trans bal
SET TBAL=0
DO TBAL^PRCAGT(DEB,.TBAL)
+31 ;get bill bal
SET BBAL=0
DO BBAL^PRCAGU(DEB,.BBAL)
+32 ; entire account has been referred to CS
IF CSBB
IF CSBB'<BBAL
QUIT
+33 SET X=$$PRE^PRCAGU(DEB)
SET PEND=$PIECE(X,U,2)
SET X=+X
IF X
IF BBAL
DO REF^PRCAGD(DEB,X,$GET(REP))
QUIT
+34 IF BBAL=0
IF PEND
IF -PEND=PBAL+TBAL
QUIT
+35 IF BBAL'=(PBAL+TBAL)
DO EN^PRCAGD(DEB,BBAL,TBAL,PBAL,BEG,$GET(REP))
QUIT
+36 IF BBAL'>0
IF '$DATA(^TMP("PRCAGT",$JOB,DEB))
QUIT
+37 IF BBAL=0
IF $GET(SITE("ZERO"))
QUIT
+38 IF BBAL<0
IF BBAL>-.99
QUIT
+39 ;third letter printed,not comment
IF BBAL'<0
IF '$DATA(^XTMP("PRCAGU",$JOB,DEB))
IF 'COMM
QUIT
+40 SET TBAL=TBAL+PBAL
+41 ;adjust amounts to be filed in 349.2 for CS bills
+42 ; reduce the total bill balance by CS balance
SET TBAL=TBAL-CSBB
+43 ; compute the CS previous balance as the difference between the bill balance and the transaction balance
SET CSPREV=CSBB-(CSTCH+CSTPC)
+44 ; reduce the previous balance by the CS previous balance
SET PBAL=PBAL-CSPREV
+45 ; reduce total charges by CS charges
SET TBAL("CH")=TBAL("CH")-CSTCH
+46 ; reduce total credits by CS credits
SET TBAL("PC")=TBAL("PC")-CSTPC
+47 IF '$DATA(^RCPS(349.2,0))
SET ^(0)="AR CCPC STATEMENTS RECORDS^349.2I^"
+48 SET ^RCPS(349.2,DEB,0)=DEB_"^"_$$SSN^RCFN01(DEB)_"^"
+49 ;get patient's address, confidential if applicable
SET ADDR=$$DADD^RCAMADD(DEB,1)
+50 SET ^RCPS(349.2,DEB,1)=$PIECE(ADDR,"^",1,6)
+51 SET ST=$PIECE(ADDR,"^",5)
+52 ;large print
SET ^RCPS(349.2,DEB,7)=$PIECE(^RCD(340,DEB,0),U,7)
+53 IF $GET(ST)'=""
SET ST=$ORDER(^DIC(5,"C",ST,0))
+54 IF $GET(ST)>90
IF '$PIECE($GET(^DIC(5,ST,0)),"^",6)
SET FC=$PIECE($GET(^DIC(5,ST,0)),"^")
+55 SET $PIECE(^RCPS(349.2,DEB,1),"^",7)=$GET(FC)
if $GET(FC)]""
SET $PIECE(^RCPS(349.2,DEB,1),"^",5)="FX"
+56 if $GET(FC)]""
SET $PIECE(^RCPS(349.2,DEB,1),"^",6)=$PIECE(ADDR,"^",8)
+57 DO NOW^%DTC
SET $PIECE(^RCPS(349.2,DEB,0),"^",10)=%
+58 SET $PIECE(^RCPS(349.2,DEB,0),"^",3)=$$NAM^RCFN01(DEB)
+59 SET $PIECE(^RCPS(349.2,DEB,0),"^",4,7)=$SELECT(TBAL'>0:0,1:TBAL)_"^"_PBAL_"^"_TBAL("CH")_"^"_TBAL("PC")
SET $PIECE(^(0),"^",8)=PBAL+TBAL("CH")+TBAL("PC")+TBAL("RF")
+60 SET $PIECE(^RCPS(349.2,DEB,0),"^",13,17)=BBAL("PB")_"^"_BBAL("INT")_"^"_BBAL("ADM")_"^"_BBAL("MF")_"^"_BBAL("CT")
+61 ;
+62 NEW RCBILLDA,RCDATA1,RCDEBTDA,RCDESC,RCPSDA,RCTOTAL,RCTRANDA,RCTRDATE,VALUE,RCCOM1,RCCOM2,RCCOM3
+63 SET RCDEBTDA=DEB
+64 IF '$DATA(^RCPS(349.2,RCDEBTDA,2,0))
SET ^(0)="^349.21DA^^"
+65 ;
+66 SET RCCOM1=$EXTRACT($TRANSLATE($GET(SITE("COM1")),"~|^",""),1,80)
SET (RCCOM2,RCCOM3)=""
+67 ; Add second comment line for the GMT-reduced status
+68 IF $$GMT^PRCAGST(RCDEBTDA)
SET RCCOM2="REDUCTION OF INPATIENT COPAYMENT DUE TO GEOGRAPHIC MEANS TEST STATUS"
+69 IF TBAL'>0
SET RCCOM3=" *THIS IS NOT A BILL*"
+70 ;Make sure GMT message will be printed on separate line.
IF RCCOM1'=""
IF RCCOM2'=""
SET $EXTRACT(RCCOM1,80)=" "
+71 SET ^RCPS(349.2,RCDEBTDA,3)=RCCOM1_RCCOM2_RCCOM3
+72 ;
+73 ; this variable used to set the description on the PS segment
SET RCPSDA=0
+74 SET RCTRDATE=0
FOR
SET RCTRDATE=$ORDER(^TMP("PRCAGT",$JOB,RCDEBTDA,RCTRDATE))
if 'RCTRDATE
QUIT
SET RCBILLDA=0
FOR
SET RCBILLDA=$ORDER(^TMP("PRCAGT",$JOB,RCDEBTDA,RCTRDATE,RCBILLDA))
if 'RCBILLDA
QUIT
Begin DoDot:2
+75 ; skip CS bills/transactions
if $DATA(^PRCA(430,"TCSP",RCBILLDA))
QUIT
+76 IF $PIECE($GET(^RCPS(349.2,RCDEBTDA,0)),"^",8)<0
SET PC(75)=75
+77 IF $PIECE($GET(^PRCA(430,RCBILLDA,6)),"^",2)]""
IF ($PIECE($GET(^PRCA(430,RCBILLDA,7)),"^")>0)
SET PC(1)="01"
+78 SET CAT=$PIECE($GET(^PRCA(430,RCBILLDA,0)),"^",2)
+79 SET PC=$PIECE($GET(^PRCA(430.2,CAT,0)),"^",14)
+80 FOR X=1:1:100
IF $PIECE(PC,",",X)'=""
SET PCC=$PIECE(PC,",",X)
SET PC(+PCC)=PCC
if PCC=""
QUIT
+81 SET PC=""
SET X=0
FOR
SET X=$ORDER(PC(X))
if X=""
QUIT
IF $GET(PC(X))'=""
SET PC=PC_PC(X)
+82 SET $PIECE(^RCPS(349.2,RCDEBTDA,4),"^")=PC
+83 ;
+84 IF $DATA(^TMP("PRCAGT",$JOB,RCDEBTDA,RCTRDATE,RCBILLDA,0))
SET AMT=+^(0)
IF AMT
Begin DoDot:3
+85 ; get the description for the bill
+86 KILL RCDESC
DO BILLDESC^RCCPCPS1(RCBILLDA)
+87 ;
+88 ; store the description in file 349.2, PS segment
+89 SET RCPSDA=RCPSDA+1
+90 SET $PIECE(^RCPS(349.2,RCDEBTDA,2,RCPSDA,0),"^",1,4)=$PIECE(RCTRDATE,".")_"^"_$GET(RCDESC(1))_"^"_$GET(AMT)_"^"_$PIECE(^PRCA(430,RCBILLDA,0),"^")
+91 FOR X=2:1
if $GET(RCDESC(X))=""
QUIT
SET RCPSDA=RCPSDA+1
SET ^RCPS(349.2,RCDEBTDA,2,RCPSDA,0)="^"_RCDESC(X)_"^^"
End DoDot:3
+92 ;
+93 SET RCTRANDA=0
FOR
SET RCTRANDA=$ORDER(^TMP("PRCAGT",$JOB,RCDEBTDA,RCTRDATE,RCBILLDA,RCTRANDA))
if 'RCTRANDA
DO NO
if 'RCTRANDA
QUIT
Begin DoDot:3
+94 ; get the description for the transaction
+95 KILL RCDESC
DO TRANDESC^RCCPCPS1(RCTRANDA)
DO RCDESC
+96 ; if it is an interest/admin charge, summarize it below
+97 IF $GET(RCDESC(1))["INTEREST"
QUIT
+98 ; get the value of the transaction for the statement
+99 SET VALUE=$$TRANVALU^RCDPBTLM(RCTRANDA)
+100 SET VALUE=$PIECE(VALUE,"^",2)+$PIECE(VALUE,"^",3)+$PIECE(VALUE,"^",4)+$PIECE(VALUE,"^",5)+$PIECE(VALUE,"^",6)
+101 ; if it is a suspended (47) or unsuspended (46) transaction, show value
+102 ; make suspended charges appear as negative
+103 SET RCDATA1=$GET(^PRCA(433,RCTRANDA,1))
+104 IF $PIECE(RCDATA1,"^",2)=47!($PIECE(RCDATA1,"^",2)=46)
SET VALUE=$PIECE(RCDATA1,"^",5)
IF $PIECE(RCDATA1,"^",2)=47
SET VALUE=-VALUE
+105 ; if it is an amended bill, show value
+106 IF $PIECE(RCDATA1,"^",2)=33
SET VALUE=$PIECE(RCDATA1,"^",5)
+107 ; store the description in file 349.2, PS segment
+108 SET RCPSDA=RCPSDA+1
+109 SET $PIECE(^RCPS(349.2,RCDEBTDA,2,RCPSDA,0),"^",1,5)=$PIECE(RCTRDATE,".")_"^"_$GET(RCDESC(1))_"^"_VALUE_"^"_$PIECE(^PRCA(430,RCBILLDA,0),"^")
+110 FOR X=2:1
if $GET(RCDESC(X))=""
QUIT
SET RCPSDA=RCPSDA+1
SET ^RCPS(349.2,RCDEBTDA,2,RCPSDA,0)="^"_RCDESC(X)_"^^"
+111 ;
+112 ; for comment transaction ... not sure what this is for ?
+113 IF $PIECE(RCDATA1,"^",2)=45
IF $PIECE($GET(^PRCA(433,RCTRANDA,5)),"^",2)["your waiver rights"
SET ^RCPS(349.2,+RCDEBTDA,4)="0150"
End DoDot:3
End DoDot:2
+114 ;
+115 ; if interest, admin, or other, add them here
+116 SET X=$GET(RCTOTAL("INT"))+$GET(RCTOTAL("ADM"))+$GET(RCTOTAL("OTH"))
+117 IF X>0
Begin DoDot:2
+118 SET RCDESC="INTEREST/ADM. CHARGE (Int:"_$JUSTIFY($GET(RCTOTAL("INT")),1,2)_" Adm:"_$JUSTIFY($GET(RCTOTAL("ADM")),1,2)_" Other:"_$JUSTIFY($GET(RCTOTAL("OTH")),1,2)_")"
+119 SET RCPSDA=RCPSDA+1
+120 SET ^RCPS(349.2,RCDEBTDA,2,RCPSDA,0)="^"_RCDESC_"^"_$JUSTIFY(X,1,2)
+121 SET ^RCPS(349.2,RCDEBTDA,2,0)="^349.21DA^"_RCPSDA_"^"_RCPSDA
End DoDot:2
+122 ;
+123 ; set 0th node
+124 IF RCPSDA
SET ^RCPS(349.2,RCDEBTDA,2,0)="^349.21DA^"_RCPSDA_"^"_RCPSDA
+125 ;
+126 ;PRCA*4.5*401 Flag Oversized statements for later printing
IF RCPSDA'<STATLIM
Begin DoDot:2
+127 DO FILEOSFG(RCDEBTDA,"S")
+128 ;Remove statement from file 349.2 if oveersize
SET DIK="^RCPS(349.2,"
SET DA=RCDEBTDA
DO ^DIK
End DoDot:2
QUIT
+129 DO NO
End DoDot:1
+130 ;
+131 SET DIK="^RCPS(349.2,"
DO IXALL^DIK
+132 SET DEB=0
SET DEB=$ORDER(^RCPS(349.2,DEB))
if DEB=""
QUIT
SET $PIECE(^(DEB,0),"^",18)=1
+133 KILL ^XTMP("PRCAGU",$JOB,DEB),COMM
+134 ;Check for Over Size statements and send exteranl email to
DO RCCPOSST
+135 QUIT
+136 ;
OSTM ;Process old statements ;PRCA*4.5*401
+1 ;S DIK="^RCPS(349.2,",DA=0 F S DA=$O(^XTMP("RCCPC",DA)) Q:'DA D ^DIK
+2 ;K DA
+3 ;
STATMNT ;Print oversized patient statements to local printer
+1 NEW POP,ZTIO,ZTSAVE,ZTRTN,ZTDESC,ZTASK,%ZIS,ZTDTH,PRCADEV,DIR
+2 NEW DIRUT,DTOUT,DUOUT,DIROUT,X,Y
+3 ;
+4 ;Confirm to continue
+5 SET DIR("A",1)="You are about to print oversized patient statements locally. "
+6 SET DIR("A")="Are you sure you wish to print these statements? (Y/N)"
+7 SET DIR(0)="Y"
SET DIR("B")="Y"
+8 DO ^DIR
+9 ;
+10 IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
WRITE !,"Nothing done"
QUIT
+11 IF Y'=1
WRITE !,"Nothing done"
QUIT
+12 ;
+13 WRITE !
+14 SET DIR("A")="Print to the (S)creen or to the (D)efault Printer? <Default> (S/D)"
+15 SET DIR(0)="SB^S:Screen;D:Default"
SET DIR("B")="D"
+16 DO ^DIR
+17 ;
+18 IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
WRITE !,"Nothing done"
QUIT
+19 ;
+20 ; set printer to file #342 field 102
IF Y="D"
SET (IOP,PRCADEV)=$PIECE($GET(^RC(342,1,"CCPC")),"^",2)
+21 IF Y="D"
IF (IOP']"")
WRITE !,"Cannot continue."
QUIT
+22 IF Y="S"
KILL IOP,IO("Q")
SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+23 IF Y="D"
SET %ZIS="N0"
DO ^%ZIS
if POP
QUIT
+24 IF Y="S"
DO STM^RCCPCSTM
QUIT
+25 SET ZTRTN="STM^RCCPCSTM"
SET ZTDTH=$HOROLOG
SET ZTDESC="Print old AR Statements"
+26 SET ZTSAVE("PRCADEV")=""
+27 DO ^%ZTLOAD
DO ^%ZISC
+28 QUIT
+29 ;
NO ;If there is no activity
+1 IF $GET(^RCPS(349.2,+DEB,4))["0150"
Begin DoDot:1
+2 SET ^RCPS(349.2,+DEB,2,1,0)="^NOTICE: You now have delinquent charges. Please^^"
+3 SET ^RCPS(349.2,+DEB,2,2,0)="^review Enforcement of Involuntary Collections^^"
+4 SET ^RCPS(349.2,+DEB,2,3,0)="^on reverse.^^"
+5 SET ^RCPS(349.2,+DEB,2,0)="^^3^3"
End DoDot:1
+6 IF $GET(^RCPS(349.2,DEB,2,1,0))=""
Begin DoDot:1
+7 SET ^RCPS(349.2,DEB,2,1,0)="^No Activity in the Last 30 Days!^^"
+8 SET ^RCPS(349.2,DEB,2,2,0)="^Please refer to previous statement of rights.^^"
+9 SET ^RCPS(349.2,DEB,2,0)="^^2^2"
+10 IF $GET(^RCPS(349.2,DEB,4))=""
SET ^(4)="90"
End DoDot:1
+11 QUIT
BUILD ;This is the entry point from the BUILD CCPC file option
+1 NEW TDT,QDT,ZTDESC,ZTASK,ZTSK,ZDTDTH,ZTIO,ZTRTN
+2 SET TDT=$ORDER(^RCPS(349.2,0))
IF TDT
Begin DoDot:1
+3 SET TDT=$$ASOF^RCCPCFN($PIECE($GET(^RCPS(349.2,+TDT,0)),"^",10))
+4 SET TDT=$TRANSLATE($$SLH^RCFN01(TDT),"/","")
+5 SET TDT("T")=$PIECE($GET(^RCT(349,1,0)),"^",10)
SET TDT("T")=$EXTRACT(TDT("T"),1,4)_$EXTRACT(TDT("T"),7,8)
+6 IF TDT("T")=TDT
Begin DoDot:2
+7 WRITE *7,!,"The current file reflects activity as of ",$EXTRACT(TDT,1,2)_"/"_$EXTRACT(TDT,3,4)_"/"_$EXTRACT(TDT,5,8)_".",!
+8 WRITE !,"IT WAS TRANSMITTED ON ",$TRANSLATE($PIECE($PIECE($GET(^RCT(349,1,0)),"^"),".",2,4),".","/"),!
+9 SET TDT=$PIECE($GET(^RCT(349,1,0)),"^",9)
+10 WRITE !,"For statement date: ",$EXTRACT(TDT,1,2)_"/"_$EXTRACT(TDT,3,4)_"/"_$EXTRACT(TDT,5,8)
+11 WRITE !!,"PLEASE CONTACT CUSTOMER SUPPORT BEFORE PROCEEDING.",!!
End DoDot:2
End DoDot:1
TIME SET ZTIO=""
SET ZTRTN="EN^RCCPCPS"
SET ZTDESC="Build CCPC Statement File"
+1 SET ZTDTH=""
DO ^%ZTLOAD
if $GET(ZTSK)=""
QUIT
+2 ;PRC*4.5*348
SET %H=ZTSK("D")
DO YX^%DTC
DO H^%DTC
IF %Y=0!(%Y=6)
WRITE !,"Queued for Building."
QUIT
+3 SET %H=ZTSK("D")
DO YMD^%DTC
SET QDT=X_%
+4 ;PRC*4.5*348
IF (QDT>(X_".0800"))&(QDT<(X_".1801"))
Begin DoDot:1
+5 WRITE !!,*7,"You Can Not Queue this Job on a weekday Between 8:00am and 6:00pm.",!
+6 DO KILL^%ZTLOAD
End DoDot:1
GOTO TIME
+7 WRITE !,"Queued for Building."
+8 QUIT
+9 ;
RCDESC ;Remove "IN PART" & "IN FULL" from the the bill description
+1 if $GET(RCDESC(1))=""
QUIT
+2 SET RCINFULL=" (IN FULL)"
+3 SET RCINPART=" (IN PART)"
+4 IF RCDESC(1)[RCINFULL
SET RCDESC(1)=$PIECE(RCDESC(1),RCINFULL)_$PIECE(RCDESC(1),RCINFULL,2)
+5 IF RCDESC(1)[RCINPART
SET RCDESC(1)=$PIECE(RCDESC(1),RCINPART)_$PIECE(RCDESC(1),RCINPART,2)
+6 QUIT
+7 ;
RCCPOSST ; ;PRCA*4.5*401 Sends external email to Mail group to notify there are statements to print
+1 NEW RCDEBIEN,CNT,LINE,XMDUZ,XMTEXT,XMY,XMSUB
+2 SET (RCDEBIEN,CNT)=0
+3 KILL ^TMP($JOB,"RCCPSTMTMSG")
+4 FOR
SET RCDEBIEN=$ORDER(^RCD(340,"ALOCAL",1,RCDEBIEN))
if RCDEBIEN=""
QUIT
SET CNT=CNT+1
+5 IF CNT=0
QUIT
+6 SET XMSUB="OVER SIZE STATEMENTS TO PRINT"
+7 SET LINE=0
+8 SET LINE=LINE+1
SET ^TMP($JOB,"RCCPSTMTMSG",LINE)="There are "_CNT_" Oversized statements waiting to be printed."
+9 SET XMTEXT="^TMP($J,""RCCPSTMTMSG"","
+10 ;S XMDUZ=$O(^VA(200,"B","POSTMASTER",0))
+11 SET XMDUZ=.5
+12 SET XMY("G.RCCPC EXTERNAL")=""
+13 DO ^XMD
+14 QUIT
+15 ;
FILEOSFG(RCDEBTDA,RCFT) ; ;PRCA*4.5*401 Set/Clear LOCAL PRINT flag, in file 340, to:
+1 ; Yes, i.e. 1 if RCFT="S"
+2 ; No, i.e. 0 if RCFT="C"
+3 ; RCDEBTDA = File 340 IEN
+4 ; RCFT = Filing Type (S Set or C Clear)
+5 ;
+6 ;VBLLST format - Principal Balance / Interest / Admin Fees / Court Costs / Marshal Fees / Date statement printed
+7 ;
+8 NEW DIE,DA,DR,VBLLST
+9 IF RCFT="S"
SET DIE="^RCD(340,"
SET DA=RCDEBTDA
SET DR="112///Y"
+10 IF RCFT="C"
SET DIE="^RCD(340,"
SET DA=RCDEBTDA
SET DR="112///N"
+11 DO ^DIE
+12 IF RCFT="S"
Begin DoDot:1
+13 SET VBLLST=BBAL("PB")_"/"_BBAL("INT")_"/"_BBAL("ADM")_"/"_BBAL("CT")_"/"_BBAL("MF")_"/"_$$NOW^XLFDT
+14 SET DIE="^RCD(340,"
SET DA=RCDEBTDA
SET DR="113///"_VBLLST
End DoDot:1
+15 IF RCFT="C"
SET DIE="^RCD(340,"
SET DA=RCDEBTDA
SET DR="113///@"
+16 DO ^DIE
+17 KILL DIE,DA,DR
+18 QUIT
+19 ;
CLRSTMTQ ;;PRCA*4.5*401 Clear Oversize statement queue
+1 NEW RCIEN,RCFT
+2 NEW DIR,X,Y,DA,DTOUT,DUOUT,DIRUT,DIROUT
+3 SET RCFT="C"
SET RCIEN=""
+4 ; Loop through AR DEBTOR "C" index and clear all that are set to Yes
+5 SET DIR("A",1)="*** Clearing the queue at this time will prevent these"
+6 SET DIR("A",2)=" statements from printing again to the Statement Printer"
+7 SET DIR("A",3)=" through this option."
+8 SET DIR("A",4)=" "
+9 SET DIR("A")="Are you sure you want to clear this print queue? (Y/N)"
+10 SET DIR(0)="Y"
SET DIR("B")="N"
SET DIR("T")=30
+11 DO ^DIR
+12 IF Y'=1
WRITE !,"Nothing done"
HANG 2
QUIT
+13 FOR
SET RCIEN=$ORDER(^RCD(340,"ALOCAL",1,RCIEN))
if RCIEN=""
QUIT
Begin DoDot:1
+14 DO FILESTAT(RCIEN)
+15 DO FILEOSFG(RCIEN,RCFT)
End DoDot:1
+16 WRITE !!,"Local Statement Queue has been cleared"
HANG 2
+17 QUIT
+18 ;
FILESTAT(DEB); ;PRCA*4.5*401 File
+1 ; INPUT: DEB - Debtor IEN (file 340)
+2 ;
+3 ;VBLLST format - Principal Balance / Interest / Admin Fees / Court Costs / Marshal Fees / Date statement printed
+4 ;
+5 NEW VBLLST,BBAL,END,ERR,EVN
+6 ;Recall saved BBAL array as string
SET VBLLST=$$GET1^DIQ(340,DEB_",",113,"I")
+7 ; Parse BBAL array from string VBLLST
+8 SET BBAL("PB")=$PIECE(VBLLST,"/",1)
SET BBAL("INT")=$PIECE(VBLLST,"/",2)
SET BBAL("ADM")=$PIECE(VBLLST,"/",3)
+9 SET BBAL("CT")=$PIECE(VBLLST,"/",4)
SET BBAL("MF")=$PIECE(VBLLST,"/",5)
+10 ;Set End to the day the process ran rather than the day the statements were actually printed to avoid out of balance issues.
+11 SET END=$PIECE(VBLLST,"/",6)
+12 DO OPEN^RCEVDRV1(2,$PIECE(^RCD(340,DEB,0),U),END,DUZ,$$SITE^RCMSITE,.ERR,.EVN,BBAL("PB")_U_BBAL("INT")_U_BBAL("ADM")_U_BBAL("CT")_U_BBAL("MF"))
+13 IF EVN
DO CLOSE^RCEVDRV1(EVN)
+14 ;set bill letter field
DO UPDAT^PRCAGU(DEB,DT)
+15 QUIT
