RCCPCSTM ;WASH-ISC@ALTOONA,PA/LDB - Patient Statement ; 2/14/97 5:12 PM
V ;;4.5;Accounts Receivable;**70,219,401**;Mar 20, 1995;Build 28
;;Per VHA Directive 2004-038, this routine should not be modified.
;ENTRY FROM NIGHTLY PROCESS
NEW HDAT,DEB
STM ;called by RCCPCPS to print >32K at site
NEW DAT,END,LDT1,LDT3,SDT,SITE,PRNT,X1,X2,TMP S COMM=0
N RCIEN,DEB,DEBT,DFN
D DT^DICRW,SITE^PRCAGU
S:$G(HDAT)="" HDAT=DT S SDT=+$E(HDAT,6,7),DAT=HDAT
D NOW^%DTC S END=%
S LDT1=$$FPS^RCAMFN01(HDAT,-1)
S LDT3=$$FPS^RCAMFN01(HDAT,-3)
S (DFN,RCIEN)=0
F S RCIEN=$O(^RCD(340,"ALOCAL",1,RCIEN)) Q:RCIEN="" D
. S DEB=RCIEN
. S TMP=$P(^RCD(340,RCIEN,0),U,1),DFN=+TMP
. I DFN S $P(DEBT,U,2)=$$NAM^RCFN01(RCIEN)
. D STS
Q
STS ;start statement process
NEW BBAL,BEG,PBAL,PDAT,PEND,SBAL,SDT,TBAL,X,Y
K ^TMP("PRCAGT",$J)
D NOW^%DTC S END=%
S BEG=+$$LST^RCFN01(DEB,2) I $P(BEG,".")'<$P(DAT,".") G STSQ ;statement printed on or after this date
I BEG<1 S PDAT="",BEG=0,PBAL=0 ;get last date/time event occurred
I BEG S PDAT=BEG,BEG=9999999.999999-BEG,PBAL=0 D PBAL^PRCAGU(DEB,.BEG,.PBAL) ;Get previous bal and prev date of last transaction
D EN^PRCAGT(DEB,BEG,.END) ;get transactions reset END to last tran
S TBAL=0 D TBAL^PRCAGT(DEB,.TBAL) ;get trans bal
S BBAL=0 D BBAL^PRCAGU(DEB,.BBAL) ;get bill bal
S X=$$PRE^PRCAGU(DEB) S PEND=$P(X,U,2),X=+X I X,BBAL D REF^PRCAGD(DEB,X,$G(REP)) G STSQ ;unprocessed refund and outstand bills send disc
I BBAL=0,PEND,-PEND=PBAL+TBAL G STSQ ;all of the amount due is prepayment pending or refund review status
I BBAL'=(PBAL+TBAL) D EN^PRCAGD(DEB,BBAL,TBAL,PBAL,BEG,$G(REP)) G STSQ ;send disc
I BBAL=0,$G(SITE("ZERO")) G STSQ ;zero balance
I BBAL'>0,'$D(^TMP("PRCAGT",$J,DEB)) G STSQ ;no amt due no activity
I BBAL<0,BBAL>-.99 G STSQ ;refund less than 1.00
I BBAL'<0,'$D(^XTMP("PRCAGU",$J,DEB)),'COMM G STSQ ;third letter printed,not comment
S TBAL=TBAL+PBAL
D EN^PRCAGST(DEB,.TBAL,PDAT,PBAL) S SITE("SCAN")="" ;print statement
D EN^PRCAGF(DEB,TBAL) S ERR="" ;get forms and print
;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
S SITE("SCAN")=$G(^RC(342,1,5))
STSQ ;
K ^XTMP("PRCAGU",$J),COMM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCCPCSTM 2363 printed Apr 09, 2024@20:44:47 Page 2
RCCPCSTM ;WASH-ISC@ALTOONA,PA/LDB - Patient Statement ; 2/14/97 5:12 PM
V ;;4.5;Accounts Receivable;**70,219,401**;Mar 20, 1995;Build 28
+1 ;;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;ENTRY FROM NIGHTLY PROCESS
+3 NEW HDAT,DEB
STM ;called by RCCPCPS to print >32K at site
+1 NEW DAT,END,LDT1,LDT3,SDT,SITE,PRNT,X1,X2,TMP
SET COMM=0
+2 NEW RCIEN,DEB,DEBT,DFN
+3 DO DT^DICRW
DO SITE^PRCAGU
+4 if $GET(HDAT)=""
SET HDAT=DT
SET SDT=+$EXTRACT(HDAT,6,7)
SET DAT=HDAT
+5 DO NOW^%DTC
SET END=%
+6 SET LDT1=$$FPS^RCAMFN01(HDAT,-1)
+7 SET LDT3=$$FPS^RCAMFN01(HDAT,-3)
+8 SET (DFN,RCIEN)=0
+9 FOR
SET RCIEN=$ORDER(^RCD(340,"ALOCAL",1,RCIEN))
if RCIEN=""
QUIT
Begin DoDot:1
+10 SET DEB=RCIEN
+11 SET TMP=$PIECE(^RCD(340,RCIEN,0),U,1)
SET DFN=+TMP
+12 IF DFN
SET $PIECE(DEBT,U,2)=$$NAM^RCFN01(RCIEN)
+13 DO STS
End DoDot:1
+14 QUIT
STS ;start statement process
+1 NEW BBAL,BEG,PBAL,PDAT,PEND,SBAL,SDT,TBAL,X,Y
+2 KILL ^TMP("PRCAGT",$JOB)
+3 DO NOW^%DTC
SET END=%
+4 ;statement printed on or after this date
SET BEG=+$$LST^RCFN01(DEB,2)
IF $PIECE(BEG,".")'<$PIECE(DAT,".")
GOTO STSQ
+5 ;get last date/time event occurred
IF BEG<1
SET PDAT=""
SET BEG=0
SET PBAL=0
+6 ;Get previous bal and prev date of last transaction
IF BEG
SET PDAT=BEG
SET BEG=9999999.999999-BEG
SET PBAL=0
DO PBAL^PRCAGU(DEB,.BEG,.PBAL)
+7 ;get transactions reset END to last tran
DO EN^PRCAGT(DEB,BEG,.END)
+8 ;get trans bal
SET TBAL=0
DO TBAL^PRCAGT(DEB,.TBAL)
+9 ;get bill bal
SET BBAL=0
DO BBAL^PRCAGU(DEB,.BBAL)
+10 ;unprocessed refund and outstand bills send disc
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))
GOTO STSQ
+11 ;all of the amount due is prepayment pending or refund review status
IF BBAL=0
IF PEND
IF -PEND=PBAL+TBAL
GOTO STSQ
+12 ;send disc
IF BBAL'=(PBAL+TBAL)
DO EN^PRCAGD(DEB,BBAL,TBAL,PBAL,BEG,$GET(REP))
GOTO STSQ
+13 ;zero balance
IF BBAL=0
IF $GET(SITE("ZERO"))
GOTO STSQ
+14 ;no amt due no activity
IF BBAL'>0
IF '$DATA(^TMP("PRCAGT",$JOB,DEB))
GOTO STSQ
+15 ;refund less than 1.00
IF BBAL<0
IF BBAL>-.99
GOTO STSQ
+16 ;third letter printed,not comment
IF BBAL'<0
IF '$DATA(^XTMP("PRCAGU",$JOB,DEB))
IF 'COMM
GOTO STSQ
+17 SET TBAL=TBAL+PBAL
+18 ;print statement
DO EN^PRCAGST(DEB,.TBAL,PDAT,PBAL)
SET SITE("SCAN")=""
+19 ;get forms and print
DO EN^PRCAGF(DEB,TBAL)
SET ERR=""
+20 ;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"))
+21 ;I EVN D CLOSE^RCEVDRV1(EVN)
+22 ;D UPDAT^PRCAGU(DEB,DT) ;set bill letter field
+23 SET SITE("SCAN")=$GET(^RC(342,1,5))
STSQ ;
+1 KILL ^XTMP("PRCAGU",$JOB),COMM
+2 QUIT
