PRCAGDR ;WASH-ISC@ALTOONA,PA/CMS - BALANCE DISCREPANCY REPORT ;12/3/93 9:40 AM
V ;;4.5;Accounts Receivable;**78,198,219,301**;Mar 20, 1995;Build 144
;;Per VA Directive 6402, this routine should not be modified.
N CHK,DAT,DEB,DIC,LN1,LN2,NAM,SSN,STD,PG,POP,Y,X,%ZIS S COMM=0
PAT ;select patient
N DPTNOFZY,DPTNOFZK S (DPTNOFZY,DPTNOFZK)=1
W ! S DIC="^DPT(",DIC(0)="AENMQ",DIC("A")="Select Patient: " D ^DIC G:Y<1 OUT S DEB=$O(^RCD(340,"B",+Y_";DPT(",0)) I 'DEB W *7," No AR Information exists!" G PAT
S $P(LN1,"_",80)="",$P(LN2,"=",80)="",NAM=$$NAM^RCFN01(DEB),SSN=$E($$SSN^RCFN01(DEB),6,9),STD=$$PST^RCAMFN01(DEB) S:STD<1 STD="UNKNOWN"
S PG=0 D HD
I '$$EN^PRCAMRKC(DEB) W !!,"This patient's account is currently in balance!"
E W !!,"This account is out-of-balance!"
D ST
D ASK I CHK=1 D DEV
G PAT
DEV W ! S IOP="Q",%ZIS="QN",%ZIS("B")="" D ^%ZIS G:POP OUT
I '$D(IO("Q")) W !!,*7,"YOU MUST QUEUE THIS REPORT!!",! G DEV
S ZTSAVE("DEB")="",ZTSAVE("NAM")="",ZTSAVE("SSN")="",ZTSAVE("STD")="",ZTRTN="EN^PRCAGDR",ZTDESC="AR DISCREPANCY REPORT" D ^%ZTLOAD G OUT
Q
OUT D ^%ZISC
K ^XTMP("PRCAGU",$J),COMM
Q
CONT ;Ask to Continue
;N Y
;W !! S DIR(0)="E" D ^DIR I Y'=1 S DTOUT=1 Q
Q
HD ;PAGE HEADING
N DIR,Y S PG=PG+1
W @IOF,!!,?3,NAM,"(",$E(NAM,1),SSN,") ACCOUNT BALANCE DISCREPANCY REPORT"
N %,%H,%I,X,Y
D NOW^%DTC S Y=% D DD^%DT
W !,?3,"STATEMENT DAY: ",STD,?46,Y," PAGE ",PG,!,LN2
HDQ Q
ASK ;Ask print statement
N DIR,X,Y
W ! S DIR("A")="Print example of patient statement",DIR(0)="Y" D ^DIR S CHK=Y
Q
EN ;Enter here to print statement from queue
N BN,DAT,PAGE,X,Y S PG=0,PAGE=0,$P(LN1,"_",80)="",$P(LN2,"=",80)=""
D HD,ST
Q
ST ;Start here find bills
NEW BBAL,BEG,CHK,END,LDT3,PBAL,PDAT,PEND,SITE,TBAL,X,Y
; initialize variables for CS
NEW CSBB,CSTCH,CSTPC,CSPREV S (CSBB,CSTCH,CSTPC)=0
I 'STD D 9^PRCAGDT Q
K ^TMP("PRCAGT",$J) D SITE^PRCAGU
D NOW^%DTC S END=%,CHK=1,PBAL=0,DAT=$E(DT,1,5)_$S($L(STD)=1:0_STD,1:STD)
S LDT3=$$FPS^RCAMFN01(DAT,-3)
S BEG=$$LST^RCFN01(DEB,2) I $P(BEG,".")'<$P(DAT,".") D 8^PRCAGDT(BEG) Q
I BEG<1 S PDAT="",BEG=0,PBAL=0
I BEG S PDAT=BEG,BEG=9999999.999999-BEG D PBAL^PRCAGU(DEB,.BEG,.PBAL)
D EN^PRCAGT(DEB,BEG,.END)
S TBAL=0 D TBAL^PRCAGT(DEB,.TBAL)
S BBAL=0 D BBAL^PRCAGU(DEB,.BBAL)
I CSBB,CSBB'<BBAL Q ; entire account has been referred to CS
W !!,"Patient Statement Check:",!!
S X=$$PRE^PRCAGU(DEB) S PEND=$P(X,U,2),X=+X
I X,BBAL D 3^PRCAGDT Q
I BBAL=0,PEND,-PEND=PBAL+TBAL D 2^PRCAGDT Q
I BBAL'=(PBAL+TBAL) D 1^PRCAGDT(DEB,BBAL,.TBAL,PBAL,BEG) Q
I BBAL=0,$G(SITE("ZERO")) D 4^PRCAGDT Q
I BBAL'>0,'$D(^TMP("PRCAGT",$J,DEB)) D 5^PRCAGDT Q
I BBAL<0,BBAL>-.99 D 6^PRCAGDT Q
I BBAL'<0,'$D(^XTMP("PRCAGU",$J,DEB)),'COMM D 10^PRCAGDT 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 CHK=1 D OK^PRCAGDT
K ^TMP("PRCAGT",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAGDR 3351 printed Dec 13, 2024@01:39:39 Page 2
PRCAGDR ;WASH-ISC@ALTOONA,PA/CMS - BALANCE DISCREPANCY REPORT ;12/3/93 9:40 AM
V ;;4.5;Accounts Receivable;**78,198,219,301**;Mar 20, 1995;Build 144
+1 ;;Per VA Directive 6402, this routine should not be modified.
+2 NEW CHK,DAT,DEB,DIC,LN1,LN2,NAM,SSN,STD,PG,POP,Y,X,%ZIS
SET COMM=0
PAT ;select patient
+1 NEW DPTNOFZY,DPTNOFZK
SET (DPTNOFZY,DPTNOFZK)=1
+2 WRITE !
SET DIC="^DPT("
SET DIC(0)="AENMQ"
SET DIC("A")="Select Patient: "
DO ^DIC
if Y<1
GOTO OUT
SET DEB=$ORDER(^RCD(340,"B",+Y_";DPT(",0))
IF 'DEB
WRITE *7," No AR Information exists!"
GOTO PAT
+3 SET $PIECE(LN1,"_",80)=""
SET $PIECE(LN2,"=",80)=""
SET NAM=$$NAM^RCFN01(DEB)
SET SSN=$EXTRACT($$SSN^RCFN01(DEB),6,9)
SET STD=$$PST^RCAMFN01(DEB)
if STD<1
SET STD="UNKNOWN"
+4 SET PG=0
DO HD
+5 IF '$$EN^PRCAMRKC(DEB)
WRITE !!,"This patient's account is currently in balance!"
+6 IF '$TEST
WRITE !!,"This account is out-of-balance!"
+7 DO ST
+8 DO ASK
IF CHK=1
DO DEV
+9 GOTO PAT
DEV WRITE !
SET IOP="Q"
SET %ZIS="QN"
SET %ZIS("B")=""
DO ^%ZIS
if POP
GOTO OUT
+1 IF '$DATA(IO("Q"))
WRITE !!,*7,"YOU MUST QUEUE THIS REPORT!!",!
GOTO DEV
+2 SET ZTSAVE("DEB")=""
SET ZTSAVE("NAM")=""
SET ZTSAVE("SSN")=""
SET ZTSAVE("STD")=""
SET ZTRTN="EN^PRCAGDR"
SET ZTDESC="AR DISCREPANCY REPORT"
DO ^%ZTLOAD
GOTO OUT
+3 QUIT
OUT DO ^%ZISC
+1 KILL ^XTMP("PRCAGU",$JOB),COMM
+2 QUIT
CONT ;Ask to Continue
+1 ;N Y
+2 ;W !! S DIR(0)="E" D ^DIR I Y'=1 S DTOUT=1 Q
+3 QUIT
HD ;PAGE HEADING
+1 NEW DIR,Y
SET PG=PG+1
+2 WRITE @IOF,!!,?3,NAM,"(",$EXTRACT(NAM,1),SSN,") ACCOUNT BALANCE DISCREPANCY REPORT"
+3 NEW %,%H,%I,X,Y
+4 DO NOW^%DTC
SET Y=%
DO DD^%DT
+5 WRITE !,?3,"STATEMENT DAY: ",STD,?46,Y," PAGE ",PG,!,LN2
HDQ QUIT
ASK ;Ask print statement
+1 NEW DIR,X,Y
+2 WRITE !
SET DIR("A")="Print example of patient statement"
SET DIR(0)="Y"
DO ^DIR
SET CHK=Y
+3 QUIT
EN ;Enter here to print statement from queue
+1 NEW BN,DAT,PAGE,X,Y
SET PG=0
SET PAGE=0
SET $PIECE(LN1,"_",80)=""
SET $PIECE(LN2,"=",80)=""
+2 DO HD
DO ST
+3 QUIT
ST ;Start here find bills
+1 NEW BBAL,BEG,CHK,END,LDT3,PBAL,PDAT,PEND,SITE,TBAL,X,Y
+2 ; initialize variables for CS
+3 NEW CSBB,CSTCH,CSTPC,CSPREV
SET (CSBB,CSTCH,CSTPC)=0
+4 IF 'STD
DO 9^PRCAGDT
QUIT
+5 KILL ^TMP("PRCAGT",$JOB)
DO SITE^PRCAGU
+6 DO NOW^%DTC
SET END=%
SET CHK=1
SET PBAL=0
SET DAT=$EXTRACT(DT,1,5)_$SELECT($LENGTH(STD)=1:0_STD,1:STD)
+7 SET LDT3=$$FPS^RCAMFN01(DAT,-3)
+8 SET BEG=$$LST^RCFN01(DEB,2)
IF $PIECE(BEG,".")'<$PIECE(DAT,".")
DO 8^PRCAGDT(BEG)
QUIT
+9 IF BEG<1
SET PDAT=""
SET BEG=0
SET PBAL=0
+10 IF BEG
SET PDAT=BEG
SET BEG=9999999.999999-BEG
DO PBAL^PRCAGU(DEB,.BEG,.PBAL)
+11 DO EN^PRCAGT(DEB,BEG,.END)
+12 SET TBAL=0
DO TBAL^PRCAGT(DEB,.TBAL)
+13 SET BBAL=0
DO BBAL^PRCAGU(DEB,.BBAL)
+14 ; entire account has been referred to CS
IF CSBB
IF CSBB'<BBAL
QUIT
+15 WRITE !!,"Patient Statement Check:",!!
+16 SET X=$$PRE^PRCAGU(DEB)
SET PEND=$PIECE(X,U,2)
SET X=+X
+17 IF X
IF BBAL
DO 3^PRCAGDT
QUIT
+18 IF BBAL=0
IF PEND
IF -PEND=PBAL+TBAL
DO 2^PRCAGDT
QUIT
+19 IF BBAL'=(PBAL+TBAL)
DO 1^PRCAGDT(DEB,BBAL,.TBAL,PBAL,BEG)
QUIT
+20 IF BBAL=0
IF $GET(SITE("ZERO"))
DO 4^PRCAGDT
QUIT
+21 IF BBAL'>0
IF '$DATA(^TMP("PRCAGT",$JOB,DEB))
DO 5^PRCAGDT
QUIT
+22 IF BBAL<0
IF BBAL>-.99
DO 6^PRCAGDT
QUIT
+23 ;third letter printed, not comment
IF BBAL'<0
IF '$DATA(^XTMP("PRCAGU",$JOB,DEB))
IF 'COMM
DO 10^PRCAGDT
QUIT
+24 SET TBAL=TBAL+PBAL
+25 ;adjust amounts to be filed in 349.2 for CS bills
+26 ; reduce the total bill balance by CS balance
SET TBAL=TBAL-CSBB
+27 ; compute the CS previous balance as the difference between the bill balance and the transaction balance
SET CSPREV=CSBB-(CSTCH+CSTPC)
+28 ; reduce the previous balance by the CS previous balance
SET PBAL=PBAL-CSPREV
+29 ; reduce total charges by CS charges
SET TBAL("CH")=TBAL("CH")-CSTCH
+30 ; reduce total credits by CS credits
SET TBAL("PC")=TBAL("PC")-CSTPC
+31 IF CHK=1
DO OK^PRCAGDT
+32 KILL ^TMP("PRCAGT",$JOB)
+33 QUIT
