source: FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCCPCPS.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 9.2 KB
Line 
1RCCPCPS ;WASH-ISC@ALTOONA,PA/NYB-Build Patient Statement File ;12/19/96 4:14 PM
2V ;;4.5;Accounts Receivable;**34,70,80,48,104,116,149,170,181,190,223,237**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4EN N CCPC,CNT,DAT,DEB,DIK,END,INADFL,LDT1,LDT3,PCC,PRN,RCDATE,RCT,SVADM,SVAMT,SVINT,SVOTH,SITE,TXT,VAR,X,%
5 N RCINFULL,RCINPART
6 K ^RCPS(349.2)
7 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)
8 K ^XTMP("RCCPC")
9 D DT^DICRW,SITE^PRCAGU
10 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
11 D NOW^%DTC S END=%
12 S LDT1=$$FPS^RCAMFN01(DT,-1),RCDATE=DT
13 S (CNT,DEB)=0,PRN=1
14 F S DEB=$O(^RCD(340,"AB","DPT(",DEB)) Q:DEB="" D
15 . N AMT,BBAL,BEG,BN,CAT,DESC,ETY,FC,ND,PAT,PBAL,PC
16 . N PDAT,PEND,ST,SVINT,SVADM,SVOTH,ADDR
17 . I $L(+$$SSN^RCFN01(DEB))<5 Q
18 . ;Check for Emergency Response Indicator (ERI) Flag.
19 . N RCDFN S RCDFN=$P($G(^RCD(340,DEB,0)),"^",1) I $$EMERES^PRCAUTL(+RCDFN)]"" Q
20 . S INADFL=0
21 . S (SVADM,SVAMT,SVINT,SVOTH)=0
22 . N REF,SBAL,SDT,TBAL,TN,TTY,X,Y
23 . K ^TMP("PRCAGT",$J)
24 . S BEG=+$$LST^RCFN01(DEB,2)
25 . S LDT3=$S(BEG>0:$$FPS^RCAMFN01($P(BEG,"."),-3),1:0)
26 . I $P(BEG,".")'<$P(RCDATE,".") Q
27 . D NOW^%DTC S END=%
28 . I BEG<1 S PDAT="",BEG=0,PBAL=0
29 . I BEG S PDAT=BEG,BEG=9999999.999999-BEG,PBAL=0 D PBAL^PRCAGU(DEB,.BEG,.PBAL) ;get prev bal
30 . D EN^PRCAGT(DEB,BEG,.END)
31 . S TBAL=0 D TBAL^PRCAGT(DEB,.TBAL) ;get trans bal
32 . S BBAL=0 D BBAL^PRCAGU(DEB,.BBAL) ;get bill bal
33 . S X=$$PRE^PRCAGU(DEB) S PEND=$P(X,U,2),X=+X I X,BBAL D REF^PRCAGD(DEB,X,$G(REP)) Q
34 . I BBAL=0,PEND,-PEND=PBAL+TBAL Q
35 . I BBAL'=(PBAL+TBAL) D EN^PRCAGD(DEB,BBAL,TBAL,PBAL,BEG,$G(REP)) Q
36 . I BBAL'>0,'$D(^TMP("PRCAGT",$J,DEB)) Q
37 . I BBAL=0,$G(SITE("ZERO")) Q
38 . I BBAL<0,BBAL>-.99 Q
39 . I BBAL'<0,'$$ACT^PRCAGT(DEB,LDT3) Q
40 . S TBAL=TBAL+PBAL
41 . I '$D(^RCPS(349.2,0)) S ^(0)="AR CCPC STATEMENTS RECORDS^349.2I^"
42 . S ^RCPS(349.2,DEB,0)=DEB_"^"_$$SSN^RCFN01(DEB)_"^"
43 . S ADDR=$$DADD^RCAMADD(DEB,1) ;get patient's address, confidential if applicable
44 . S ^RCPS(349.2,DEB,1)=$P(ADDR,"^",1,6)
45 . S ST=$P(ADDR,"^",5)
46 . S ^RCPS(349.2,DEB,7)=$P(^RCD(340,DEB,0),U,7) ;large print
47 . I $G(ST)'="" S ST=$O(^DIC(5,"C",ST,0))
48 . I $G(ST)>90 S FC=$P($G(^DIC(5,ST,0)),"^")
49 . S $P(^RCPS(349.2,DEB,1),"^",7)=$G(FC) S:$G(FC)]"" $P(^RCPS(349.2,DEB,1),"^",5)="FX"
50 . S:$G(FC)]"" $P(^RCPS(349.2,DEB,1),"^",6)=$P(ADDR,"^",8)
51 . D NOW^%DTC S $P(^RCPS(349.2,DEB,0),"^",10)=%
52 . S $P(^RCPS(349.2,DEB,0),"^",3)=$$NAM^RCFN01(DEB)
53 . 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")
54 . S $P(^RCPS(349.2,DEB,0),"^",13,17)=BBAL("PB")_"^"_BBAL("INT")_"^"_BBAL("ADM")_"^"_BBAL("MF")_"^"_BBAL("CT")
55 . ;
56 . N RCBILLDA,RCDATA1,RCDEBTDA,RCDESC,RCPSDA,RCTOTAL,RCTRANDA,RCTRDATE,VALUE,RCCOM1,RCCOM2,RCCOM3
57 . S RCDEBTDA=DEB
58 . I '$D(^RCPS(349.2,RCDEBTDA,2,0)) S ^(0)="^349.21DA^^"
59 . ;
60 . S RCCOM1=$E($TR($G(SITE("COM1")),"~|^",""),1,80),(RCCOM2,RCCOM3)=""
61 . ; Add second comment line for the GMT-reduced status
62 . I $$GMT^PRCAGST(RCDEBTDA) S RCCOM2="REDUCTION OF INPATIENT COPAYMENT DUE TO GEOGRAPHIC MEANS TEST STATUS"
63 . I TBAL'>0 S RCCOM3=" *THIS IS NOT A BILL*"
64 . I RCCOM1'="",RCCOM2'="" S $E(RCCOM1,80)=" " ;Make sure GMT message will be printed on separate line.
65 . S ^RCPS(349.2,RCDEBTDA,3)=RCCOM1_RCCOM2_RCCOM3
66 . ;
67 . S RCPSDA=0 ; this variable used to set the description on the PS segment
68 . 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
69 . . I $P($G(^RCPS(349.2,RCDEBTDA,0)),"^",8)<0 S PC(75)=75
70 . . I $P($G(^PRCA(430,RCBILLDA,6)),"^",2)]"",($P($G(^PRCA(430,RCBILLDA,7)),"^")>0) S PC(1)="01"
71 . . S CAT=$P($G(^PRCA(430,RCBILLDA,0)),"^",2)
72 . . S PC=$P($G(^PRCA(430.2,CAT,0)),"^",14)
73 . . F X=1:1:100 I $P(PC,",",X)'="" S PCC=$P(PC,",",X),PC(+PCC)=PCC Q:PCC=""
74 . . S PC="",X=0 F S X=$O(PC(X)) Q:X="" I $G(PC(X))'="" S PC=PC_PC(X)
75 . . S $P(^RCPS(349.2,RCDEBTDA,4),"^")=PC
76 . . ;
77 . . I $D(^TMP("PRCAGT",$J,RCDEBTDA,RCTRDATE,RCBILLDA,0)) S AMT=+^(0) I AMT D
78 . . . ; get the description for the bill
79 . . . K RCDESC D BILLDESC^RCCPCPS1(RCBILLDA)
80 . . . ;
81 . . . ; store the description in file 349.2, PS segment
82 . . . S RCPSDA=RCPSDA+1
83 . . . S $P(^RCPS(349.2,RCDEBTDA,2,RCPSDA,0),"^",1,4)=$P(RCTRDATE,".")_"^"_$G(RCDESC(1))_"^"_$G(AMT)_"^"_$P(^PRCA(430,RCBILLDA,0),"^")
84 . . . F X=2:1 Q:$G(RCDESC(X))="" S RCPSDA=RCPSDA+1,^RCPS(349.2,RCDEBTDA,2,RCPSDA,0)="^"_RCDESC(X)_"^^"
85 . . ;
86 . . S RCTRANDA=0 F S RCTRANDA=$O(^TMP("PRCAGT",$J,RCDEBTDA,RCTRDATE,RCBILLDA,RCTRANDA)) D:'RCTRANDA NO Q:'RCTRANDA D
87 . . . ; get the description for the transaction
88 . . . K RCDESC D TRANDESC^RCCPCPS1(RCTRANDA),RCDESC
89 . . . ; if it is an interest/admin charge, summarize it below
90 . . . I $G(RCDESC(1))["INTEREST" Q
91 . . . ; get the value of the transaction for the statement
92 . . . S VALUE=$$TRANVALU^RCDPBTLM(RCTRANDA)
93 . . . S VALUE=$P(VALUE,"^",2)+$P(VALUE,"^",3)+$P(VALUE,"^",4)+$P(VALUE,"^",5)+$P(VALUE,"^",6)
94 . . . ; if it is a suspended (47) or unsuspended (46) transaction, show value
95 . . . ; make suspended charges appear as negative
96 . . . S RCDATA1=$G(^PRCA(433,RCTRANDA,1))
97 . . . I $P(RCDATA1,"^",2)=47!($P(RCDATA1,"^",2)=46) S VALUE=$P(RCDATA1,"^",5) I $P(RCDATA1,"^",2)=47 S VALUE=-VALUE
98 . . . ; if it is an amended bill, show value
99 . . . I $P(RCDATA1,"^",2)=33 S VALUE=$P(RCDATA1,"^",5)
100 . . . ; store the description in file 349.2, PS segment
101 . . . S RCPSDA=RCPSDA+1
102 . . . S $P(^RCPS(349.2,RCDEBTDA,2,RCPSDA,0),"^",1,5)=$P(RCTRDATE,".")_"^"_$G(RCDESC(1))_"^"_VALUE_"^"_$P(^PRCA(430,RCBILLDA,0),"^")
103 . . . F X=2:1 Q:$G(RCDESC(X))="" S RCPSDA=RCPSDA+1,^RCPS(349.2,RCDEBTDA,2,RCPSDA,0)="^"_RCDESC(X)_"^^"
104 . . . ;
105 . . . ; for comment transaction ... not sure what this is for ?
106 . . . I $P(RCDATA1,"^",2)=45,$P($G(^PRCA(433,RCTRANDA,5)),"^",2)["your waiver rights" S ^RCPS(349.2,+RCDEBTDA,4)="0150"
107 . ;
108 . ; if interest, admin, or other, add them here
109 . S X=$G(RCTOTAL("INT"))+$G(RCTOTAL("ADM"))+$G(RCTOTAL("OTH"))
110 . I X>0 D
111 . . 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)_")"
112 . . S RCPSDA=RCPSDA+1
113 . . S ^RCPS(349.2,RCDEBTDA,2,RCPSDA,0)="^"_RCDESC_"^"_$J(X,1,2)
114 . . S ^RCPS(349.2,RCDEBTDA,2,0)="^349.21DA^"_RCPSDA_"^"_RCPSDA
115 . ;
116 . ; set 0th node
117 . I RCPSDA S ^RCPS(349.2,RCDEBTDA,2,0)="^349.21DA^"_RCPSDA_"^"_RCPSDA
118 . ;
119 . I RCPSDA'<287 S ^XTMP("RCCPC",0)=DT,^XTMP("RCCPC",RCDEBTDA)="" Q
120 . D NO
121 ;
122 S DIK="^RCPS(349.2," D IXALL^DIK
123 S DEB=0 S DEB=$O(^RCPS(349.2,DEB)) Q:DEB="" S $P(^(DEB,0),"^",18)=1
124 ;
125OSTM ;Process old statements
126 S DIK="^RCPS(349.2,",DA=0 F S DA=$O(^XTMP("RCCPC",DA)) Q:'DA D ^DIK
127 K DA
128 ;
129STATMNT ;Print patient statements
130 N IOP,ZTIO,ZTSAVE,ZTRTN,ZTDESC,ZTASK,%ZIS,ZTDTH,PRCADEV
131 S (IOP,PRCADEV)=$P($G(^RC(342,1,0)),"^",8)
132 I IOP]"" D
133 .S ZTRTN="STM^RCCPCSTM",ZTDTH=$H,ZTDESC="Print old AR Statements"
134 .S %ZIS="N0" D ^%ZIS Q:POP
135 .S ZTSAVE("PRCADEV")="" D ^%ZTLOAD,^%ZISC
136 Q
137 ;
138NO ;If there is no activity
139 I $G(^RCPS(349.2,+DEB,4))["0150" D
140 .S ^RCPS(349.2,+DEB,2,1,0)="^NOTICE: You now have delinquent charges. Please^^"
141 .S ^RCPS(349.2,+DEB,2,2,0)="^review Enforcement of Involuntary Collections^^"
142 .S ^RCPS(349.2,+DEB,2,3,0)="^on reverse.^^"
143 .S ^RCPS(349.2,+DEB,2,0)="^^3^3"
144 I $G(^RCPS(349.2,DEB,2,1,0))="" D
145 .S ^RCPS(349.2,DEB,2,1,0)="^No Activity in the Last 30 Days!^^"
146 .S ^RCPS(349.2,DEB,2,2,0)="^Please refer to previous statement of rights.^^"
147 .S ^RCPS(349.2,DEB,2,0)="^^2^2"
148 .I $G(^RCPS(349.2,DEB,4))="" S ^(4)="90"
149 Q
150BUILD ;This is the entry point from the BUILD CCPC file option
151 N TDT,QDT,ZTDESC,ZTASK,ZTSK,ZDTDTH,ZTIO,ZTRTN
152 S TDT=$O(^RCPS(349.2,0)) I TDT D
153 .S TDT=$$ASOF^RCCPCFN($P($G(^RCPS(349.2,+TDT,0)),"^",10))
154 .S TDT=$TR($$SLH^RCFN01(TDT),"/","")
155 .S TDT("T")=$P($G(^RCT(349,1,0)),"^",10),TDT("T")=$E(TDT("T"),1,4)_$E(TDT("T"),7,8)
156 .I TDT("T")=TDT D
157 ..W *7,!,"The current file reflects activity as of ",$E(TDT,1,2)_"/"_$E(TDT,3,4)_"/"_$E(TDT,5,8)_".",!
158 ..W !,"IT WAS TRANSMITTED ON ",$TR($P($P($G(^RCT(349,1,0)),"^"),".",2,4),".","/"),!
159 ..S TDT=$P($G(^RCT(349,1,0)),"^",9)
160 ..W !,"For statement date: ",$E(TDT,1,2)_"/"_$E(TDT,3,4)_"/"_$E(TDT,5,8)
161 ..W !!,"PLEASE CONTACT CUSTOMER SUPPORT BEFORE PROCEEDING.",!!
162TIME S ZTIO="",ZTRTN="EN^RCCPCPS",ZTDESC="Build CCPC Statement File"
163 S ZTDTH="" D ^%ZTLOAD Q:$G(ZTSK)=""
164 S %H=ZTSK("D") D YMD^%DTC S QDT=X_%
165 I (QDT>DT_"."_0800)&(QDT<(DT_"."_1801)) D G TIME
166 .W !!,*7,"You Can Not Queue this Job Between 8:00am and 6:00pm.",!
167 .D KILL^%ZTLOAD
168 W !,"Queued for Building."
169 Q
170 ;
171RCDESC ;Remove "IN PART" & "IN FULL" from the the bill description
172 QUIT:$G(RCDESC(1))=""
173 S RCINFULL=" (IN FULL)"
174 S RCINPART=" (IN PART)"
175 I RCDESC(1)[RCINFULL S RCDESC(1)=$P(RCDESC(1),RCINFULL)_$P(RCDESC(1),RCINFULL,2)
176 I RCDESC(1)[RCINPART S RCDESC(1)=$P(RCDESC(1),RCINPART)_$P(RCDESC(1),RCINPART,2)
177 Q
Note: See TracBrowser for help on using the repository browser.