source: FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGS.m@ 873

Last change on this file since 873 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.7 KB
Line 
1PRCAGS ;WASH-ISC@ALTOONA,PA/CMS-Patient Statement ;6/19/96 5:12 PM
2V ;;4.5;Accounts Receivable;**34,78**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;ENTRY FROM NIGHTLY PROCESS
5 NEW HDAT,DEB
6EN ;entry from patient statement option
7 NEW %,%H,%I,DAT,END,LDT1,LDT3,SDT,SITE,PRNT,X,X1,X2,Y
8 D DT^DICRW,SITE^PRCAGU
9 I '$D(SITE) D Q
10 . D NOW^%DTC S Y=% D DD^%DT
11 . W !!,"AR SITE PARAMETER ENTRIES NOT DEFINED!",?46,Y,!!,"COULD NOT PROCESS AR PATIENT STATEMENTS"
12 ;
13 S:$G(HDAT)="" HDAT=DT S SDT=+$E(HDAT,6,7)
14 D NOW^%DTC S END=%
15 S LDT1=$$FPS^RCAMFN01(HDAT,-1)
16 S LDT3=$$FPS^RCAMFN01(HDAT,-3)
17 ;I $G(DEB) S DAT=HDAT D STS G ENQ ;if comming in thru option.
18 ;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
19 F DEB=0:0 S DEB=$O(^RCD(340,"AC",SDT,DEB)) Q:'DEB I $P(^RCD(340,DEB,0),U,1)'["DPT" D
20 .S DAT=$$LST^RCFN01(DEB,10) I $P(DAT,".")'<$P(HDAT,".") Q
21 .S PRNT="FL",SB="" D EN^PRCAGF(DEB,SB,.PRNT) I PRNT D UPDAT^PRCAGU(DEB,HDAT),BEVN^PRCAGU(DEB,HDAT)
22ENQ K DAT,DEB,^TMP("PRCAGT",$J)
23 Q
24STS ;start statement process
25 ;NEW BBAL,BEG,PBAL,PDAT,PEND,SBAL,SDT,TBAL,X,Y
26 ;K ^TMP("PRCAGT",$J)
27 ;D NOW^%DTC S END=%
28 ;S BEG=+$$LST^RCFN01(DEB,2) I $P(BEG,".")'<$P(DAT,".") G STSQ ;statement printed on or after this date
29 ;I BEG<1 S PDAT="",BEG=0,PBAL=0 ;get last date/time event occurred
30 ;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
31 ;D EN^PRCAGT(DEB,BEG,.END) ;get transactions reset END to last tran
32 ;S TBAL=0 D TBAL^PRCAGT(DEB,.TBAL) ;get trans bal
33 ;S BBAL=0 D BBAL^PRCAGU(DEB,.BBAL) ;get bill bal
34 ;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
35 ;I BBAL=0,PEND,-PEND=PBAL+TBAL G STSQ ;all of the amount due is prepayment pending or refund review status
36 ;I BBAL'=(PBAL+TBAL) D EN^PRCAGD(DEB,BBAL,TBAL,PBAL,BEG,$G(REP)) G STSQ ;send disc
37 ;I BBAL=0,$G(SITE("ZERO")) G STSQ ;zero balance
38 ;I BBAL'>0,'$D(^TMP("PRCAGT",$J,DEB)) G STSQ ;no amt due no activity
39 ;I BBAL<0,BBAL>-.99 G STSQ ;refund less than 1.00
40 ;I BBAL'<0,'$$ACT^PRCAGT(DEB,LDT3) G STSQ ;no activty past 3 stat
41 ;S TBAL=TBAL+PBAL
42 ;D EN^PRCAGST(DEB,.TBAL,PDAT,PBAL) S SITE("SCAN")="" ;print statement
43 ;D EN^PRCAGF(DEB,TBAL) S ERR="" ;get forms and print
44 ;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"))
45 ;I EVN D CLOSE^RCEVDRV1(EVN)
46 ;D UPDAT^PRCAGU(DEB,DT) ;set bill letter field
47 ;S SITE("SCAN")=$G(^RC(342,1,5))
48STSQ ;Q
49REP ;entry from reprint statement queued option
50 NEW DA,DEB,ETY,LST,SDT,SITE,X,Y
51 D SITE^PRCAGU
52 S ETY=+$O(^RC(341.1,"AC",2,0))
53 I 'BEG S BEG=1
54 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
55REPQ Q
56REPS ;Start reprint statement process
57 NEW BBAL,BDT,CR,DAT,EDT,LDT,LST,NOT,PBAL,PDAT,TBAL,X,Y
58 S DAT=9999999-HDAT
59 D DT^DICRW S EDT=$P(^RC(341,DA,0),U,6),LDT=$P(^(0),U,7) ;ending date of transactions to reprint
60 F I=2,3 S II=$P($G(^RC(341,DA,1)),U,I) I II S BBAL("INT")=II Q
61 K I,II
62 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
63 I BDT S PDAT=9999999-$P(BDT,"."),PBAL=0 D PBAL^PRCAGU(DEB,.BDT,.PBAL) ;Get previous bal and prev date of last transaction
64 D EN^PRCAGT(DEB,BDT,EDT) ;get transactions for date range
65 S TBAL=0 D TBAL^PRCAGT(DEB,.TBAL) ;get trans bal
66 S TBAL=PBAL+TBAL
67 I TBAL=0,SITE("ZERO") G REPSQ ;zero balance
68 I TBAL'>0,'$D(^TMP("PRCAGT",$J,DEB)) G REPSQ ;less than 0 no activity
69 I TBAL<0,TBAL>-.99 G REPSQ ;refund less than 1.00
70 D EN^PRCAGST(DEB,.TBAL,PDAT,PBAL,LDT) ;print statement
71 S (CR,NOT)=0,SITE("SCAN")=""
72 F STAT=16,42 F BN=0:0 S BN=$O(^PRCA(430,"AS",DEB,STAT,BN)) Q:'BN D
73 .S LET=$G(^PRCA(430,BN,6)) F X=1:1:3 I $P(LET,U,X)=HDAT Q
74 .S LET=X S SB="" D LT^PRCAGF(BN,SB,LET) ;get forms and print
75 S SITE("SCAN")=$G(^RC(342,1,5))
76REPSQ Q
77BILL ;start reprint bill from queued option
78 NEW BN,PRCADA,DEB,X,Y
79 S DAT=9999999-DAT I 'BEG S BEG=1
80 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
81BILLQ Q
82BILLS ;start reprint bills process
83 NEW BAL,NOTICE,PRCASV,X,Y
84 S BN=$G(^RC(341,PRCADA,5)) Q:'BN
85 S NOTICE=+$P(BN,U,2),BN=+BN
86 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)
87 I ETY'="UB" D LT^PRCAGF(BN,BAL,NOTICE) Q
88 I NOTICE>1 S PRCASV("NOTICE")=NOTICE,PRCASV("ARREC")=BN D REPRNT^IBCF13 Q
89 Q
Note: See TracBrowser for help on using the repository browser.