PRCAGS ;WASH-ISC@ALTOONA,PA/CMS-Patient Statement ;6/19/96 5:12 PM
V ;;4.5;Accounts Receivable;**34,78,301**;Mar 20, 1995;Build 144
;;Per VHA Directive 10-93-142, this routine should not be modified.
;ENTRY FROM NIGHTLY PROCESS
NEW HDAT,DEB
EN ;entry from patient statement option
NEW %,%H,%I,DAT,END,LDT1,LDT3,SDT,SITE,PRNT,X,X1,X2,Y
D DT^DICRW,SITE^PRCAGU
I '$D(SITE) D Q
. D NOW^%DTC S Y=% D DD^%DT
. W !!,"AR SITE PARAMETER ENTRIES NOT DEFINED!",?46,Y,!!,"COULD NOT PROCESS AR PATIENT STATEMENTS"
;
S:$G(HDAT)="" HDAT=DT S SDT=+$E(HDAT,6,7)
D NOW^%DTC S END=%
S LDT1=$$FPS^RCAMFN01(HDAT,-1)
S LDT3=$$FPS^RCAMFN01(HDAT,-3)
;I $G(DEB) S DAT=HDAT D STS G ENQ ;if comming in thru option.
;F DEB=0:0 S DEB=$O(^RCD(340,"AC",SDT,DEB)) Q:'DEB I $P(^RCD(340,DEB,0),U,1)["DPT" S DAT=HDAT D STS
F DEB=0:0 S DEB=$O(^RCD(340,"AC",SDT,DEB)) Q:'DEB I $P(^RCD(340,DEB,0),U,1)'["DPT" D
.S DAT=$$LST^RCFN01(DEB,10) I $P(DAT,".")'<$P(HDAT,".") Q
.S PRNT="FL",SB="" D EN^PRCAGF(DEB,SB,.PRNT) I PRNT D UPDAT^PRCAGU(DEB,HDAT),BEVN^PRCAGU(DEB,HDAT)
ENQ K DAT,DEB,^TMP("PRCAGT",$J)
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,'$$ACT^PRCAGT(DEB,LDT3) G STSQ ;no activty past 3 stat
;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 ;Q
REP ;entry from reprint statement queued option
NEW DA,DEB,ETY,LST,SDT,SITE,X,Y
D SITE^PRCAGU
S ETY=+$O(^RC(341.1,"AC",2,0))
I 'BEG S BEG=1
F DA=BEG-1:0 S DA=$O(^RC(341,DA)) Q:'DA I ETY=$P($G(^RC(341,DA,0)),U,2) Q:$S(END="*"&($P($P(^RC(341,DA,0),U,7),".")>HDAT):1,END'="*"&(DA>END):1,1:0) S DEB=$P(^RC(341,DA,0),U,5) I DEB D REPS
REPQ Q
REPS ;Start reprint statement process
NEW BBAL,BDT,CR,DAT,EDT,LDT,LST,NOT,PBAL,PDAT,TBAL,X,Y
; initialize variables for CS
NEW CSBB,CSTCH,CSTPC,CSPREV S (CSBB,CSTCH,CSTPC)=0
S DAT=9999999-HDAT
D DT^DICRW S EDT=$P(^RC(341,DA,0),U,6),LDT=$P(^(0),U,7) ;ending date of transactions to reprint
F I=2,3 S II=$P($G(^RC(341,DA,1)),U,I) I II S BBAL("INT")=II Q
K I,II
S BDT=0 D LST^PRCAGU(DEB,DA,.BDT) I 'BDT S PDAT="",PBAL=0 ;get last date/time of previous event before reprint event
I BDT S PDAT=9999999-$P(BDT,"."),PBAL=0 D PBAL^PRCAGU(DEB,.BDT,.PBAL) ;Get previous bal and prev date of last transaction
D EN^PRCAGT(DEB,BDT,EDT) ;get transactions for date range
S TBAL=0 D TBAL^PRCAGT(DEB,.TBAL) ;get trans bal
I CSBB,CSBB'<BBAL Q ; entire account has been referred to CS
S TBAL=PBAL+TBAL
I TBAL=0,SITE("ZERO") G REPSQ ;zero balance
I TBAL'>0,'$D(^TMP("PRCAGT",$J,DEB)) G REPSQ ;less than 0 no activity
I TBAL<0,TBAL>-.99 G REPSQ ;refund less than 1.00
; 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
D EN^PRCAGST(DEB,.TBAL,PDAT,PBAL,LDT) ;print statement
S (CR,NOT)=0,SITE("SCAN")=""
F STAT=16,42 F BN=0:0 S BN=$O(^PRCA(430,"AS",DEB,STAT,BN)) Q:'BN D
.S LET=$G(^PRCA(430,BN,6)) F X=1:1:3 I $P(LET,U,X)=HDAT Q
.S LET=X S SB="" D LT^PRCAGF(BN,SB,LET) ;get forms and print
S SITE("SCAN")=$G(^RC(342,1,5))
REPSQ Q
BILL ;start reprint bill from queued option
NEW BN,PRCADA,DEB,X,Y
S DAT=9999999-DAT I 'BEG S BEG=1
F PRCADA=BEG-1:0 S PRCADA=$O(^RC(341,PRCADA)) Q:'PRCADA I $P(^RC(341,PRCADA,0),U,2)=$S(ETY="UB":9,1:10) Q:$S('PRCADA:1,END="*"&($P($P(^RC(341,PRCADA,0),"^",7),".")>DAT):1,PRCADA>END&(END'="*"):1,1:0) D BILLS
BILLQ Q
BILLS ;start reprint bills process
NEW BAL,NOTICE,PRCASV,X,Y
S BN=$G(^RC(341,PRCADA,5)) Q:'BN
S NOTICE=+$P(BN,U,2),BN=+BN
S BAL=$G(^RC(341,PRCADA,1)) S BAL=+BAL+$P(BAL,U,2)+$P(BAL,U,3)+$P(BAL,U,4)+$P(BAL,U,5)
I ETY'="UB" D LT^PRCAGF(BN,BAL,NOTICE) Q
I NOTICE>1 S PRCASV("NOTICE")=NOTICE,PRCASV("ARREC")=BN D REPRNT^IBCF13 Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAGS 5497 printed Nov 22, 2024@16:49:57 Page 2
PRCAGS ;WASH-ISC@ALTOONA,PA/CMS-Patient Statement ;6/19/96 5:12 PM
V ;;4.5;Accounts Receivable;**34,78,301**;Mar 20, 1995;Build 144
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;ENTRY FROM NIGHTLY PROCESS
+3 NEW HDAT,DEB
EN ;entry from patient statement option
+1 NEW %,%H,%I,DAT,END,LDT1,LDT3,SDT,SITE,PRNT,X,X1,X2,Y
+2 DO DT^DICRW
DO SITE^PRCAGU
+3 IF '$DATA(SITE)
Begin DoDot:1
+4 DO NOW^%DTC
SET Y=%
DO DD^%DT
+5 WRITE !!,"AR SITE PARAMETER ENTRIES NOT DEFINED!",?46,Y,!!,"COULD NOT PROCESS AR PATIENT STATEMENTS"
End DoDot:1
QUIT
+6 ;
+7 if $GET(HDAT)=""
SET HDAT=DT
SET SDT=+$EXTRACT(HDAT,6,7)
+8 DO NOW^%DTC
SET END=%
+9 SET LDT1=$$FPS^RCAMFN01(HDAT,-1)
+10 SET LDT3=$$FPS^RCAMFN01(HDAT,-3)
+11 ;I $G(DEB) S DAT=HDAT D STS G ENQ ;if comming in thru option.
+12 ;F DEB=0:0 S DEB=$O(^RCD(340,"AC",SDT,DEB)) Q:'DEB I $P(^RCD(340,DEB,0),U,1)["DPT" S DAT=HDAT D STS
+13 FOR DEB=0:0
SET DEB=$ORDER(^RCD(340,"AC",SDT,DEB))
if 'DEB
QUIT
IF $PIECE(^RCD(340,DEB,0),U,1)'["DPT"
Begin DoDot:1
+14 SET DAT=$$LST^RCFN01(DEB,10)
IF $PIECE(DAT,".")'<$PIECE(HDAT,".")
QUIT
+15 SET PRNT="FL"
SET SB=""
DO EN^PRCAGF(DEB,SB,.PRNT)
IF PRNT
DO UPDAT^PRCAGU(DEB,HDAT)
DO BEVN^PRCAGU(DEB,HDAT)
End DoDot:1
ENQ KILL DAT,DEB,^TMP("PRCAGT",$JOB)
+1 QUIT
STS ;start statement process
+1 ;NEW BBAL,BEG,PBAL,PDAT,PEND,SBAL,SDT,TBAL,X,Y
+2 ;K ^TMP("PRCAGT",$J)
+3 ;D NOW^%DTC S END=%
+4 ;S BEG=+$$LST^RCFN01(DEB,2) I $P(BEG,".")'<$P(DAT,".") G STSQ ;statement printed on or after this date
+5 ;I BEG<1 S PDAT="",BEG=0,PBAL=0 ;get last date/time event occurred
+6 ;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
+7 ;D EN^PRCAGT(DEB,BEG,.END) ;get transactions reset END to last tran
+8 ;S TBAL=0 D TBAL^PRCAGT(DEB,.TBAL) ;get trans bal
+9 ;S BBAL=0 D BBAL^PRCAGU(DEB,.BBAL) ;get bill bal
+10 ;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
+11 ;I BBAL=0,PEND,-PEND=PBAL+TBAL G STSQ ;all of the amount due is prepayment pending or refund review status
+12 ;I BBAL'=(PBAL+TBAL) D EN^PRCAGD(DEB,BBAL,TBAL,PBAL,BEG,$G(REP)) G STSQ ;send disc
+13 ;I BBAL=0,$G(SITE("ZERO")) G STSQ ;zero balance
+14 ;I BBAL'>0,'$D(^TMP("PRCAGT",$J,DEB)) G STSQ ;no amt due no activity
+15 ;I BBAL<0,BBAL>-.99 G STSQ ;refund less than 1.00
+16 ;I BBAL'<0,'$$ACT^PRCAGT(DEB,LDT3) G STSQ ;no activty past 3 stat
+17 ;S TBAL=TBAL+PBAL
+18 ;D EN^PRCAGST(DEB,.TBAL,PDAT,PBAL) S SITE("SCAN")="" ;print statement
+19 ;D EN^PRCAGF(DEB,TBAL) S ERR="" ;get forms and print
+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 ;S SITE("SCAN")=$G(^RC(342,1,5))
STSQ ;Q
REP ;entry from reprint statement queued option
+1 NEW DA,DEB,ETY,LST,SDT,SITE,X,Y
+2 DO SITE^PRCAGU
+3 SET ETY=+$ORDER(^RC(341.1,"AC",2,0))
+4 IF 'BEG
SET BEG=1
+5 FOR DA=BEG-1:0
SET DA=$ORDER(^RC(341,DA))
if 'DA
QUIT
IF ETY=$PIECE($GET(^RC(341,DA,0)),U,2)
if $SELECT(END="*"&($PIECE($PIECE(^RC(341,DA,0),U,7),".")>HDAT)
QUIT
SET DEB=$PIECE(^RC(341,DA,0),U,5)
IF DEB
DO REPS
REPQ QUIT
REPS ;Start reprint statement process
+1 NEW BBAL,BDT,CR,DAT,EDT,LDT,LST,NOT,PBAL,PDAT,TBAL,X,Y
+2 ; initialize variables for CS
+3 NEW CSBB,CSTCH,CSTPC,CSPREV
SET (CSBB,CSTCH,CSTPC)=0
+4 SET DAT=9999999-HDAT
+5 ;ending date of transactions to reprint
DO DT^DICRW
SET EDT=$PIECE(^RC(341,DA,0),U,6)
SET LDT=$PIECE(^(0),U,7)
+6 FOR I=2,3
SET II=$PIECE($GET(^RC(341,DA,1)),U,I)
IF II
SET BBAL("INT")=II
QUIT
+7 KILL I,II
+8 ;get last date/time of previous event before reprint event
SET BDT=0
DO LST^PRCAGU(DEB,DA,.BDT)
IF 'BDT
SET PDAT=""
SET PBAL=0
+9 ;Get previous bal and prev date of last transaction
IF BDT
SET PDAT=9999999-$PIECE(BDT,".")
SET PBAL=0
DO PBAL^PRCAGU(DEB,.BDT,.PBAL)
+10 ;get transactions for date range
DO EN^PRCAGT(DEB,BDT,EDT)
+11 ;get trans bal
SET TBAL=0
DO TBAL^PRCAGT(DEB,.TBAL)
+12 ; entire account has been referred to CS
IF CSBB
IF CSBB'<BBAL
QUIT
+13 SET TBAL=PBAL+TBAL
+14 ;zero balance
IF TBAL=0
IF SITE("ZERO")
GOTO REPSQ
+15 ;less than 0 no activity
IF TBAL'>0
IF '$DATA(^TMP("PRCAGT",$JOB,DEB))
GOTO REPSQ
+16 ;refund less than 1.00
IF TBAL<0
IF TBAL>-.99
GOTO REPSQ
+17 ; adjust amounts to be filed in 349.2 for CS bills
+18 ; reduce the total bill balance by CS balance
SET TBAL=TBAL-CSBB
+19 ; compute the CS previous balance as the difference between the bill balance and the transaction balance
SET CSPREV=CSBB-(CSTCH+CSTPC)
+20 ; reduce the previous balance by the CS previous balance
SET PBAL=PBAL-CSPREV
+21 ; reduce total charges by CS charges
SET TBAL("CH")=TBAL("CH")-CSTCH
+22 ; reduce total credits by CS credits
SET TBAL("PC")=TBAL("PC")-CSTPC
+23 ;print statement
DO EN^PRCAGST(DEB,.TBAL,PDAT,PBAL,LDT)
+24 SET (CR,NOT)=0
SET SITE("SCAN")=""
+25 FOR STAT=16,42
FOR BN=0:0
SET BN=$ORDER(^PRCA(430,"AS",DEB,STAT,BN))
if 'BN
QUIT
Begin DoDot:1
+26 SET LET=$GET(^PRCA(430,BN,6))
FOR X=1:1:3
IF $PIECE(LET,U,X)=HDAT
QUIT
+27 ;get forms and print
SET LET=X
SET SB=""
DO LT^PRCAGF(BN,SB,LET)
End DoDot:1
+28 SET SITE("SCAN")=$GET(^RC(342,1,5))
REPSQ QUIT
BILL ;start reprint bill from queued option
+1 NEW BN,PRCADA,DEB,X,Y
+2 SET DAT=9999999-DAT
IF 'BEG
SET BEG=1
+3 FOR PRCADA=BEG-1:0
SET PRCADA=$ORDER(^RC(341,PRCADA))
if 'PRCADA
QUIT
IF $PIECE(^RC(341,PRCADA,0),U,2)=$SELECT(ETY="UB":9,1:10)
if $SELECT('PRCADA
QUIT
DO BILLS
BILLQ QUIT
BILLS ;start reprint bills process
+1 NEW BAL,NOTICE,PRCASV,X,Y
+2 SET BN=$GET(^RC(341,PRCADA,5))
if 'BN
QUIT
+3 SET NOTICE=+$PIECE(BN,U,2)
SET BN=+BN
+4 SET BAL=$GET(^RC(341,PRCADA,1))
SET BAL=+BAL+$PIECE(BAL,U,2)+$PIECE(BAL,U,3)+$PIECE(BAL,U,4)+$PIECE(BAL,U,5)
+5 IF ETY'="UB"
DO LT^PRCAGF(BN,BAL,NOTICE)
QUIT
+6 IF NOTICE>1
SET PRCASV("NOTICE")=NOTICE
SET PRCASV("ARREC")=BN
DO REPRNT^IBCF13
QUIT
+7 QUIT
