Summary Table

Categories Total Count
PII 1
URL 0
DNS 2
EKL 0
IP 0
PORT 0
VsID 0
CF 0
AI 0
VPD 0
PL 0
Other 0

File Content

KIDS Distribution saved on Mar 06, 2019@10:36:17
BUILD 15 - IOC BUILD
**KIDS**:PRCA*4.5*338^

**INSTALL NAME**
PRCA*4.5*338
"BLD",10903,0)
PRCA*4.5*338^ACCOUNTS RECEIVABLE^0^3190306^y
"BLD",10903,4,0)
^9.64PA^430.2^1
"BLD",10903,4,430.2,0)
430.2
"BLD",10903,4,430.2,2,0)
^9.641^430.2^1
"BLD",10903,4,430.2,2,430.2,0)
ACCOUNTS RECEIVABLE CATEGORY (File-top level)
"BLD",10903,4,430.2,2,430.2,1,0)
^9.6411^1.03^3
"BLD",10903,4,430.2,2,430.2,1,1.01,0)
REFER TO DMC?
"BLD",10903,4,430.2,2,430.2,1,1.02,0)
REFER TO TOP?
"BLD",10903,4,430.2,2,430.2,1,1.03,0)
REFER TO CS?
"BLD",10903,4,430.2,222)
y^n^p^^^^n^^n
"BLD",10903,4,430.2,224)

"BLD",10903,4,"APDD",430.2,430.2)

"BLD",10903,4,"APDD",430.2,430.2,1.01)

"BLD",10903,4,"APDD",430.2,430.2,1.02)

"BLD",10903,4,"APDD",430.2,430.2,1.03)

"BLD",10903,4,"B",430.2,430.2)

"BLD",10903,6)
15^
"BLD",10903,6.3)
70
"BLD",10903,"ABPKG")
n
"BLD",10903,"INIT")
POSTINIT^PRCAP338
"BLD",10903,"KRN",0)
^9.67PA^779.2^20
"BLD",10903,"KRN",.4,0)
.4
"BLD",10903,"KRN",.4,"NM",0)
^9.68A^^
"BLD",10903,"KRN",.401,0)
.401
"BLD",10903,"KRN",.402,0)
.402
"BLD",10903,"KRN",.403,0)
.403
"BLD",10903,"KRN",.5,0)
.5
"BLD",10903,"KRN",.84,0)
.84
"BLD",10903,"KRN",3.6,0)
3.6
"BLD",10903,"KRN",3.8,0)
3.8
"BLD",10903,"KRN",9.2,0)
9.2
"BLD",10903,"KRN",9.8,0)
9.8
"BLD",10903,"KRN",9.8,"NM",0)
^9.68A^28^26
"BLD",10903,"KRN",9.8,"NM",1,0)
RCXFMSUR^^0^B118788042
"BLD",10903,"KRN",9.8,"NM",2,0)
RCXFMSUF^^0^B57862958
"BLD",10903,"KRN",9.8,"NM",3,0)
RCBEADJ^^0^B106126105
"BLD",10903,"KRN",9.8,"NM",4,0)
PRCAACC^^0^B8752523
"BLD",10903,"KRN",9.8,"NM",5,0)
RCRJRDEP^^0^B67133793
"BLD",10903,"KRN",9.8,"NM",6,0)
RCXFMSPR^^0^B75044670
"BLD",10903,"KRN",9.8,"NM",7,0)
PRCABJV^^0^B54348019
"BLD",10903,"KRN",9.8,"NM",8,0)
RCRJRBD^^0^B99557360
"BLD",10903,"KRN",9.8,"NM",11,0)
RCRJRBDT^^0^B66401701
"BLD",10903,"KRN",9.8,"NM",12,0)
RCTOPD^^0^B79395575
"BLD",10903,"KRN",9.8,"NM",13,0)
RCDMC90^^0^B63494730
"BLD",10903,"KRN",9.8,"NM",14,0)
RCTCSPD^^0^B162525249
"BLD",10903,"KRN",9.8,"NM",15,0)
PRCASVC^^0^B26611476
"BLD",10903,"KRN",9.8,"NM",16,0)
RCDPRTP^^0^B16040807
"BLD",10903,"KRN",9.8,"NM",17,0)
RCDPRTP0^^0^B54790234
"BLD",10903,"KRN",9.8,"NM",18,0)
RCXFMSUV^^0^B24853879
"BLD",10903,"KRN",9.8,"NM",19,0)
RCRJRCOU^^0^B143002587
"BLD",10903,"KRN",9.8,"NM",20,0)
RCRJROIG^^0^B29874403
"BLD",10903,"KRN",9.8,"NM",21,0)
RCRJRCOC^^0^B81559216
"BLD",10903,"KRN",9.8,"NM",22,0)
RCDPRTP2^^0^B20901251
"BLD",10903,"KRN",9.8,"NM",23,0)
RCRJRCOR^^0^B71059694
"BLD",10903,"KRN",9.8,"NM",24,0)
PRCABIL1^^0^B39930904
"BLD",10903,"KRN",9.8,"NM",25,0)
PRCACPV^^0^B17132531
"BLD",10903,"KRN",9.8,"NM",26,0)
PRCAFUT^^0^B42522073
"BLD",10903,"KRN",9.8,"NM",27,0)
RCXFMSC1^^0^B23554655
"BLD",10903,"KRN",9.8,"NM",28,0)
PRCABJ2^^0^B20492059
"BLD",10903,"KRN",9.8,"NM","B","PRCAACC",4)

"BLD",10903,"KRN",9.8,"NM","B","PRCABIL1",24)

"BLD",10903,"KRN",9.8,"NM","B","PRCABJ2",28)

"BLD",10903,"KRN",9.8,"NM","B","PRCABJV",7)

"BLD",10903,"KRN",9.8,"NM","B","PRCACPV",25)

"BLD",10903,"KRN",9.8,"NM","B","PRCAFUT",26)

"BLD",10903,"KRN",9.8,"NM","B","PRCASVC",15)

"BLD",10903,"KRN",9.8,"NM","B","RCBEADJ",3)

"BLD",10903,"KRN",9.8,"NM","B","RCDMC90",13)

"BLD",10903,"KRN",9.8,"NM","B","RCDPRTP",16)

"BLD",10903,"KRN",9.8,"NM","B","RCDPRTP0",17)

"BLD",10903,"KRN",9.8,"NM","B","RCDPRTP2",22)

"BLD",10903,"KRN",9.8,"NM","B","RCRJRBD",8)

"BLD",10903,"KRN",9.8,"NM","B","RCRJRBDT",11)

"BLD",10903,"KRN",9.8,"NM","B","RCRJRCOC",21)

"BLD",10903,"KRN",9.8,"NM","B","RCRJRCOR",23)

"BLD",10903,"KRN",9.8,"NM","B","RCRJRCOU",19)

"BLD",10903,"KRN",9.8,"NM","B","RCRJRDEP",5)

"BLD",10903,"KRN",9.8,"NM","B","RCRJROIG",20)

"BLD",10903,"KRN",9.8,"NM","B","RCTCSPD",14)

"BLD",10903,"KRN",9.8,"NM","B","RCTOPD",12)

"BLD",10903,"KRN",9.8,"NM","B","RCXFMSC1",27)

"BLD",10903,"KRN",9.8,"NM","B","RCXFMSPR",6)

"BLD",10903,"KRN",9.8,"NM","B","RCXFMSUF",2)

"BLD",10903,"KRN",9.8,"NM","B","RCXFMSUR",1)

"BLD",10903,"KRN",9.8,"NM","B","RCXFMSUV",18)

"BLD",10903,"KRN",19,0)
19
"BLD",10903,"KRN",19.1,0)
19.1
"BLD",10903,"KRN",101,0)
101
"BLD",10903,"KRN",409.61,0)
409.61
"BLD",10903,"KRN",771,0)
771
"BLD",10903,"KRN",779.2,0)
779.2
"BLD",10903,"KRN",870,0)
870
"BLD",10903,"KRN",8989.51,0)
8989.51
"BLD",10903,"KRN",8989.52,0)
8989.52
"BLD",10903,"KRN",8994,0)
8994
"BLD",10903,"KRN","B",.4,.4)

"BLD",10903,"KRN","B",.401,.401)

"BLD",10903,"KRN","B",.402,.402)

"BLD",10903,"KRN","B",.403,.403)

"BLD",10903,"KRN","B",.5,.5)

"BLD",10903,"KRN","B",.84,.84)

"BLD",10903,"KRN","B",3.6,3.6)

"BLD",10903,"KRN","B",3.8,3.8)

"BLD",10903,"KRN","B",9.2,9.2)

"BLD",10903,"KRN","B",9.8,9.8)

"BLD",10903,"KRN","B",19,19)

"BLD",10903,"KRN","B",19.1,19.1)

"BLD",10903,"KRN","B",101,101)

"BLD",10903,"KRN","B",409.61,409.61)

"BLD",10903,"KRN","B",771,771)

"BLD",10903,"KRN","B",779.2,779.2)

"BLD",10903,"KRN","B",870,870)

"BLD",10903,"KRN","B",8989.51,8989.51)

"BLD",10903,"KRN","B",8989.52,8989.52)

"BLD",10903,"KRN","B",8994,8994)

"BLD",10903,"QDEF")
^^^^NO^^^^NO^^YES
"BLD",10903,"QUES",0)
^9.62^^
"BLD",10903,"REQB",0)
^9.611^6^6
"BLD",10903,"REQB",1,0)
PRCA*4.5*337^1
"BLD",10903,"REQB",2,0)
PRCA*4.5*253^1
"BLD",10903,"REQB",3,0)
PRCA*4.5*340^1
"BLD",10903,"REQB",4,0)
PRCA*4.5*326^1
"BLD",10903,"REQB",5,0)
PRCA*4.5*339^1
"BLD",10903,"REQB",6,0)
PRCA*4.5*335^1
"BLD",10903,"REQB","B","PRCA*4.5*253",2)

"BLD",10903,"REQB","B","PRCA*4.5*326",4)

"BLD",10903,"REQB","B","PRCA*4.5*335",6)

"BLD",10903,"REQB","B","PRCA*4.5*337",1)

"BLD",10903,"REQB","B","PRCA*4.5*339",5)

"BLD",10903,"REQB","B","PRCA*4.5*340",3)

"FIA",430.2)
ACCOUNTS RECEIVABLE CATEGORY
"FIA",430.2,0)
^PRCA(430.2,
"FIA",430.2,0,0)
430.2I
"FIA",430.2,0,1)
y^n^p^^^^n^^n
"FIA",430.2,0,10)

"FIA",430.2,0,11)

"FIA",430.2,0,"RLRO")

"FIA",430.2,0,"VR")
4.5^PRCA
"FIA",430.2,430.2)
1
"FIA",430.2,430.2,1.01)

"FIA",430.2,430.2,1.02)

"FIA",430.2,430.2,1.03)

"INIT")
POSTINIT^PRCAP338
"MBREQ")
0
"PKG",561,-1)
1^1
"PKG",561,0)
ACCOUNTS RECEIVABLE^PRCA^FMS
"PKG",561,22,0)
^9.49I^1^1
"PKG",561,22,1,0)
4.5^2950320^2950331
"PKG",561,22,1,"PAH",1,0)
338^3190306^520824658
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
YES
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
27
"RTN","PRCAACC")
0^4^B8752523
"RTN","PRCAACC",1,0)
PRCAACC ;WASH-ISC@ALTOONA,PA/CMS-AR ACCRUAL TOTALS ;10/19/10 1:36pm
"RTN","PRCAACC",2,0)
;;4.5;Accounts Receivable;**60,74,90,101,157,203,220,273,310,338**;Mar 20, 1995;Build 70
"RTN","PRCAACC",3,0)
;Per VA Directive 6402, this routine should not be modified.
"RTN","PRCAACC",4,0)
NEW PRCAQUE,PRCADEV,PRCA,ZTSK
"RTN","PRCAACC",5,0)
S PRCA("MESS")="Do you wish to queue this report" D QUE^PRCAQUE G:'$D(PRCAQUE) Q
"RTN","PRCAACC",6,0)
I $D(IO("Q")) S ZTRTN="DQ^PRCAACC",ZTDESC="AR Accrual Totals" D ^%ZTLOAD G Q
"RTN","PRCAACC",7,0)
DQ ;
"RTN","PRCAACC",8,0)
U IO
"RTN","PRCAACC",9,0)
NEW BILLN,COM,TOT,STAT,X,Y
"RTN","PRCAACC",10,0)
S BILLN=0
"RTN","PRCAACC",11,0)
D COM G:$O(COM(""))="" RPT
"RTN","PRCAACC",12,0)
F STAT=42,16 F S BILLN=$O(^PRCA(430,"AC",STAT,BILLN)) Q:'BILLN I $$ACCK(BILLN) D
"RTN","PRCAACC",13,0)
.S X=(","_$P(^PRCA(430,BILLN,0),"^",2)_",")
"RTN","PRCAACC",14,0)
.S TOT(X)=$G(TOT(X))+$G(^PRCA(430,BILLN,7))
"RTN","PRCAACC",15,0)
.QUIT
"RTN","PRCAACC",16,0)
RPT D NOW^%DTC W @IOF,!!,?23,"Accrual Totals Report",!?20,"As of: " S Y=% X ^DD("DD") W Y,!
"RTN","PRCAACC",17,0)
S X="",$P(X,"=",80)="" W X
"RTN","PRCAACC",18,0)
W:$O(COM(""))="" !!,"WARNING: Accruals are *NOT* set-up correctly.",!,"No RX accrual common numbering series are set-up in AR Bill Number File!",!!
"RTN","PRCAACC",19,0)
S TOT=$G(TOT(",22,"))+$G(TOT(",23,")) I TOT W !!!,"RX CO-PAYMENT Accrual Amount: $",$FN(TOT,",",2)
"RTN","PRCAACC",20,0)
I $G(TOT(",18,"))>0 W !!!,"C (MEANS TEST) Accrual Amount: $",$FN(TOT(",18,"),",",2)
"RTN","PRCAACC",21,0)
W !!!!,"Includes Common Numbering Series:",! S COM="" F S COM=$O(COM(COM)) Q:COM="" W !,COM,?20,COM(COM)
"RTN","PRCAACC",22,0)
Q D ^%ZISC S IOP=IO(0) D ^%ZIS K IOP,IO("Q") Q
"RTN","PRCAACC",23,0)
ACCK(BN) ;Check BILLN to see if Accrual
"RTN","PRCAACC",24,0)
N ACC,ACTDATE,CAT,FUND,DB
"RTN","PRCAACC",25,0)
S CAT=+$P(^PRCA(430,BN,0),"^",2)
"RTN","PRCAACC",26,0)
; field 12, ACCRUED ? where 0=no 1=yes, 2=could be either
"RTN","PRCAACC",27,0)
S ACC=+$P($G(^PRCA(430.2,CAT,0)),"^",9)
"RTN","PRCAACC",28,0)
; it could be either accrued or non-accrued
"RTN","PRCAACC",29,0)
I ACC=2 D
"RTN","PRCAACC",30,0)
. S FUND=$P($G(^PRCA(430,BN,11)),"^",17)
"RTN","PRCAACC",31,0)
. S ACC=$S(FUND=5014:1,FUND=2431:1,1:0)
"RTN","PRCAACC",32,0)
. I $E(FUND,1,4)=5287 S ACC=$$PTACCT(FUND)
"RTN","PRCAACC",33,0)
. ; special case with Workman's Comp
"RTN","PRCAACC",34,0)
. I ACC=0,CAT=6,FUND="" D
"RTN","PRCAACC",35,0)
. . S DB=$P($G(^RCD(340,+$P($G(^PRCA(430,BN,0)),U,9),0)),U)
"RTN","PRCAACC",36,0)
. . I DB[";DPT"!($P($G(^PRCA(430,BN,0)),U,7)'="") S ACC=1
"RTN","PRCAACC",37,0)
;
"RTN","PRCAACC",38,0)
; public law states that bills in the category ineligible (1),
"RTN","PRCAACC",39,0)
; emerg/human (2), torts (10), or medicare (21) which are older
"RTN","PRCAACC",40,0)
; than oct 1, 1992 should be treated as non-accrued.
"RTN","PRCAACC",41,0)
I CAT=1!(CAT=2)!(CAT=10)!(CAT=21) D
"RTN","PRCAACC",42,0)
. S ACTDATE=$P($G(^PRCA(430,BN,6)),"^",21) I 'ACTDATE S ACTDATE=DT
"RTN","PRCAACC",43,0)
. I ACTDATE<2921001 S ACC=0
"RTN","PRCAACC",44,0)
. ;
"RTN","PRCAACC",45,0)
. ; patch157 changes ineligibles. an ineligible created before
"RTN","PRCAACC",46,0)
. ; oct 1, 1992 or after sep 30, 2000 will be non-accrued.
"RTN","PRCAACC",47,0)
. ; otherwise it will be accrued.
"RTN","PRCAACC",48,0)
. I CAT=1,ACTDATE>3000930 S ACC=0
"RTN","PRCAACC",49,0)
;
"RTN","PRCAACC",50,0)
Q ACC
"RTN","PRCAACC",51,0)
COM ;Find Accrual common numbering series
"RTN","PRCAACC",52,0)
S COM=0
"RTN","PRCAACC",53,0)
F S COM=$O(^PRCA(430.4,COM)) Q:'COM I $P(^PRCA(430.4,COM,0),"^",6) S COM($P(^PRCA(430.4,COM,0),"^"))=$P($G(^DIC(49,$P(^(0),"^",5),0)),"^",1)
"RTN","PRCAACC",54,0)
Q
"RTN","PRCAACC",55,0)
PTACCT(FUND) ;Determines whether Point Accounts are accrued
"RTN","PRCAACC",56,0)
;returns 1 for accrued funds 528701,528702,528703,528704,528709,528711
"RTN","PRCAACC",57,0)
;returns 0 for any other fund
"RTN","PRCAACC",58,0)
;PRCA*4.5*310/DRF Added 528713 to accrued funds
"RTN","PRCAACC",59,0)
;PRCA*4.5*338/OB Added 528714 to accrued funds
"RTN","PRCAACC",60,0)
I FUND'[5287 Q 0
"RTN","PRCAACC",61,0)
S X=$E(FUND,5,6),X=$S(X="09"!(X="11")!(X="13")!(X="14"):1,X<"05":1,1:0)
"RTN","PRCAACC",62,0)
Q X
"RTN","PRCAACC",63,0)
ADDPTEDT() ;Effective date of additional point accounts
"RTN","PRCAACC",64,0)
; (528705 - 528708 and 528710)
"RTN","PRCAACC",65,0)
;Effective date of switch from 4032 to 528709
"RTN","PRCAACC",66,0)
Q 3040928
"RTN","PRCABIL1")
0^24^B39930904
"RTN","PRCABIL1",1,0)
PRCABIL1 ;SF-ISC/RSD - ENTER BILL INFO ;10/16/96 7:04 PM
"RTN","PRCABIL1",2,0)
V ;;4.5;Accounts Receivable;**57,64,109,147,220,276,315,338**;Mar 20, 1995;Build 70
"RTN","PRCABIL1",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","PRCABIL1",4,0)
;
"RTN","PRCABIL1",5,0)
EN1 ;ENTER NEW BILL
"RTN","PRCABIL1",6,0)
D ST Q:'% N CP
"RTN","PRCABIL1",7,0)
EN10 D EN^PRCABIL2 G Q:'$D(PRCABN) S $P(^PRCA(430,PRCABN,0),"^",8)=$O(^PRCA(430.3,"AC",201,0)) D EN G EN10
"RTN","PRCABIL1",8,0)
EN2 ;EDIT BILL
"RTN","PRCABIL1",9,0)
EN20 D SVC^PRCABIL Q:'$D(PRCAP("S")) S DIC("S")="S Z0=$S($D(^PRCA(430.3,+$P(^(0),U,8),0)):$P(^(0),U,3),1:0) I Z0>199,Z0<210,'$P($G(^PRCA(430,Y,3)),U,3),+$P($G(^(100)),U,2)="_PRCAP("S")
"RTN","PRCABIL1",10,0)
D BILLN^PRCAUTL G Q:'$D(PRCABN) D EN G EN20
"RTN","PRCABIL1",11,0)
EN4 ;CANCEL BILL
"RTN","PRCABIL1",12,0)
EN40 D SVC^PRCABIL Q:'$D(PRCAP("S")) S DIC("S")="S Z0=$S($D(^PRCA(430.3,+$P(^(0),U,8),0)):$P(^(0),U,3),1:0) I Z0>199,Z0<210,$D(^PRCA(430,Y,100)),+$P(^(100),U,2)="_PRCAP("S")
"RTN","PRCABIL1",13,0)
D BILLN^PRCAUTL G Q:'$D(PRCABN)
"RTN","PRCABIL1",14,0)
YN S %=2 W !," Sure you want to cancel this Bill" D YN^DICN
"RTN","PRCABIL1",15,0)
I %=0 W !,*7,"Answer 'Yes' or 'No' " G YN
"RTN","PRCABIL1",16,0)
I %'=1 D Q G EN40
"RTN","PRCABIL1",17,0)
S $P(^PRCA(430,PRCABN,0),"^",14)=DT,$P(^(0),"^",17)=DUZ,$P(^(9),"^",6)=$P(^(0),"^",8),PRCA("STATUS")=$O(^PRCA(430.3,"AC",210,0)) D UPSTATS^PRCAUT2 K PRCA("STATUS") D Q G EN40
"RTN","PRCABIL1",18,0)
EN K PRCADFM S DA=PRCABN D LCK G Q:'$D(DA)
"RTN","PRCABIL1",19,0)
S DIE="^PRCA(430,"
"RTN","PRCABIL1",20,0)
I $D(RCAMEND) S X=+^PRCA(430,DA,100) I X?1N,X<4,X>0 G FORM
"RTN","PRCABIL1",21,0)
S DR="100" D ^DIE G:X'?1N Q
"RTN","PRCABIL1",22,0)
FORM N PRCACAT,PRCAFUND,PRCABENE,PRCACA,PRCATYP,PRCAADD,PRCAAD1D,PRCAAD2D,PRCAAD3D,PRCACD,PRCASTD
"RTN","PRCABIL1",23,0)
N PRCAZPD,PRCAPHD,PREND
"RTN","PRCABIL1",24,0)
S PRCABENE=0
"RTN","PRCABIL1",25,0)
S DR="[PRCA BILL "_$P("1081^1080^1114","^",X)_"]",PRCABT=X D ^DIE
"RTN","PRCABIL1",26,0)
S:$D(DUZ) $P(^PRCA(430,PRCABN,9),U,8)=DUZ
"RTN","PRCABIL1",27,0)
S PRCACAT=$P(^PRCA(430,PRCABN,0),U,2)
"RTN","PRCABIL1",28,0)
;PRCA*4.5*315 New Prompt for Beneficiary Travel if Category is VENDOR
"RTN","PRCABIL1",29,0)
I PRCACAT=17 D I $G(PREND)=1 Q
"RTN","PRCABIL1",30,0)
.W !!
"RTN","PRCABIL1",31,0)
.S DIR("A")="IS THIS FOR VETERANS BENEFICIARY TRAVEL? "
"RTN","PRCABIL1",32,0)
.S DIR("?")="Please answer Yes or No."
"RTN","PRCABIL1",33,0)
.S DIR("B")="NO",DIR(0)="YA^^"
"RTN","PRCABIL1",34,0)
.D ^DIR K DIR
"RTN","PRCABIL1",35,0)
.I '$D(Y(0)) S PREND=1 Q
"RTN","PRCABIL1",36,0)
.I Y(0)="YES" D
"RTN","PRCABIL1",37,0)
..S PRCABENE=1
"RTN","PRCABIL1",38,0)
..S PRCACA=$O(^RC(342.1,"B","AGENT CASHIER",0))
"RTN","PRCABIL1",39,0)
..S PRCATYP=$P(^RC(342.1,PRCACA,0),U,2)
"RTN","PRCABIL1",40,0)
..S PRCAADD=$$SADD^RCFN01(PRCATYP)
"RTN","PRCABIL1",41,0)
..I $G(PRCAADD)'="" D
"RTN","PRCABIL1",42,0)
...S PRCAAD1D=$P(PRCAADD,U),PRCAAD2D=$P(PRCAADD,U,2),PRCAAD3D=$P(PRCAADD,U,3),PRCACD=$P(PRCAADD,U,4)
"RTN","PRCABIL1",43,0)
...S PRCASTD=$P(PRCAADD,U,5),PRCAZPD=$P(PRCAADD,U,6),PRCAPHD=$P(PRCAADD,U,7)
"RTN","PRCABIL1",44,0)
I PRCACAT>39,PRCACAT<45 D
"RTN","PRCABIL1",45,0)
.S X=PRCACAT,PRCAFUND=$S(X=40:"05",X=41:"06",X=42:"07",X=43:"08",1:"10"),PRCAFUND=5287_PRCAFUND
"RTN","PRCABIL1",46,0)
.S DR="259////"_"09;203////^S X=PRCAFUND"
"RTN","PRCABIL1",47,0)
.D ^DIE
"RTN","PRCABIL1",48,0)
.K Y,X
"RTN","PRCABIL1",49,0)
.Q
"RTN","PRCABIL1",50,0)
I PRCACAT=47 D ;315
"RTN","PRCABIL1",51,0)
.N FUND
"RTN","PRCABIL1",52,0)
.S FUND="0160R1" ; patch PRCA*4.5*338
"RTN","PRCABIL1",53,0)
.S DR="259////"_"02;203////^S X=FUND"
"RTN","PRCABIL1",54,0)
.D ^DIE
"RTN","PRCABIL1",55,0)
.K Y,X
"RTN","PRCABIL1",56,0)
.Q
"RTN","PRCABIL1",57,0)
I $P(^PRCA(430,PRCABN,0),U,9)=""!('$D(^(100))!('$D(^(101)))) D MESG W !,"Bill is incomplete and must be re-edited !",*7 G Q
"RTN","PRCABIL1",58,0)
D EN4^PRCABIL S PRCAMT1=0,PRCAMTY=0,DIK="^PRCA(430,PRCABN,2,"
"RTN","PRCABIL1",59,0)
F PRCAI=0:0 S PRCAI=$O(^PRCA(430,PRCABN,2,PRCAI)) Q:'PRCAI I $D(^(PRCAI,0)) S X=^(0) I $P(X,"^",8)]"" S PRCAMT1=PRCAMT1+$P(X,"^",8),PRCAMTY=PRCAMTY+1
"RTN","PRCABIL1",60,0)
I 'PRCAMT1 W !!,"Fiscal Year Amount was not entered ! Bill is incomplete",*7 G Q
"RTN","PRCABIL1",61,0)
I PRCAMTY>1 W !!,"Multiple Fiscal Years are not allowed at this time !",!,"Bill is incomplete and must be re-edited.",*7 G Q
"RTN","PRCABIL1",62,0)
I PRCAMT1'=PRCAMT,PRCABT'=1 W !!,"Fiscal Year Amounts do not equal the total bill amount !",!,"Bill is incomplete and must be re-edited !",*7 G Q
"RTN","PRCABIL1",63,0)
I PRCAMT1'=PRCAMT,PRCABT=1 D ;
"RTN","PRCABIL1",64,0)
. N DIE,DA,DR
"RTN","PRCABIL1",65,0)
. S PRCAMT1=PRCAMT
"RTN","PRCABIL1",66,0)
. S DIE="^PRCA(430,PRCABN,2,"
"RTN","PRCABIL1",67,0)
. S DA(1)=PRCABN
"RTN","PRCABIL1",68,0)
. S DA=+$O(^PRCA(430,PRCABN,2,0))
"RTN","PRCABIL1",69,0)
. S DR="1///"_PRCAMT1
"RTN","PRCABIL1",70,0)
. QUIT:'DA
"RTN","PRCABIL1",71,0)
. ;
"RTN","PRCABIL1",72,0)
. DO ^DIE
"RTN","PRCABIL1",73,0)
;
"RTN","PRCABIL1",74,0)
S Y=$P(^PRCA(430,PRCABN,0),"^",9),Y=Y_"^"_$P(^RCD(340,Y,0),"^",1)
"RTN","PRCABIL1",75,0)
G:$P(Y,";",2)="DPT("!($P(Y,";",2)="DIC(36,") CONT
"RTN","PRCABIL1",76,0)
S PRCANODE=.11 S:$P(Y,";",2)="DIC(4," PRCANODE=1 S PRCANODE="^"_$P(Y,";",2)_+$P(Y,"^",2)_","_PRCANODE_")",PRCANODE=$G(@PRCANODE)
"RTN","PRCABIL1",77,0)
I $P(PRCANODE,"^",1)="" S DR=$P(Y,"^",2),%=1 W !," (No Street Address) Edit Debtor Address: " D YN^DICN,EN1^RCAM(DR):%=1 K DIE,DR,DA
"RTN","PRCABIL1",78,0)
CONT S Y=^PRCA(430,PRCABN,0),$P(Y,"^",3)=PRCAMT,PRCA("STATUS")=$O(^PRCA(430.3,"AC",205,0)),^PRCA(430,PRCABN,0)=Y,$P(^PRCA(430,PRCABN,7),"^")=PRCAMT
"RTN","PRCABIL1",79,0)
I '$D(RCAMEND) S DIE="^PRCA(430,",DA=PRCABN,DR="8////"_PRCA("STATUS")_"" D ^DIE K DIE,DR,DA
"RTN","PRCABIL1",80,0)
DISP S %=1,PRCADFM=1 W !," Display/Print Bill:"
"RTN","PRCABIL1",81,0)
K IOP D YN^DICN
"RTN","PRCABIL1",82,0)
I %=0 W !,*7,"Answer 'Yes' or 'No' " G DISP
"RTN","PRCABIL1",83,0)
D ^PRCABD:%=1
"RTN","PRCABIL1",84,0)
Q L -^PRCA(430,+$G(PRCABN),0)
"RTN","PRCABIL1",85,0)
K %,%Y,A,B,C,D0,DA,DIC,DIE,DIK,DR,I,PRCA,PRCABC,PRCABN,PRCABT,PRCADFM,PRCAI,PRCAKCT,PRCARN,PRCATIME,PRCAMT,PRCAMTY,PRCANODE,PRCAMT1,PRCAMT2,PRCAQ,PRCAP,PRCAT,PRCATY,PRCAX,X,Y,Z0,ZRTN,ZTSK Q
"RTN","PRCABIL1",86,0)
LCK L +^PRCA(430,DA,0):0 I Q
"RTN","PRCABIL1",87,0)
W !,"ANOTHER USER IS EDITING THIS ENTRY !" K DA Q
"RTN","PRCABIL1",88,0)
CP ;CONTROL POINT LOOK-UP
"RTN","PRCABIL1",89,0)
N DIC,PRC,DIE,DA,DR,X,Y,PRCSIP,PRCSI
"RTN","PRCABIL1",90,0)
S PRC("SITE")=$S($G(PRCA("SITE")):PRCA("SITE"),1:$$SITE^RCMSITE)
"RTN","PRCABIL1",91,0)
S DIC("B")=$P($G(^PRCA(430,PRCABN,11)),U)
"RTN","PRCABIL1",92,0)
D CP^PRCSUT I '$G(PRC("CP")) Q
"RTN","PRCABIL1",93,0)
I PRC("CP")<0 Q
"RTN","PRCABIL1",94,0)
S $P(^PRCA(430,PRCABN,11),U)=PRC("CP")
"RTN","PRCABIL1",95,0)
Q
"RTN","PRCABIL1",96,0)
BENEPRT ;PRCA*4.5*315 Beneficiary Travel Notice of Rights and Responsibilities
"RTN","PRCABIL1",97,0)
I $G(PRCABENE) D
"RTN","PRCABIL1",98,0)
.N LINE,BENELTR,DIWF,DIWL,DIWR,IOSLSAVE,PRNT
"RTN","PRCABIL1",99,0)
.S BENELTR=$O(^RC(343,"B","BENEFICIARY TRAVEL NOTICE",0))
"RTN","PRCABIL1",100,0)
.K ^UTILITY($J) ;print main body text from 343
"RTN","PRCABIL1",101,0)
.S ^UTILITY($J,1)="W "_IOF
"RTN","PRCABIL1",102,0)
.S IOSLSAVE=IOSL,IOSL=140
"RTN","PRCABIL1",103,0)
.U IO
"RTN","PRCABIL1",104,0)
.W #
"RTN","PRCABIL1",105,0)
.F LINE=0:0 S LINE=$O(^RC(343,BENELTR,1,LINE)) Q:'LINE S X=$G(^(LINE,0)) I X]"" W:($Y+2)>IOSL @IOF S DIWL=1,DIWR=80,DIWF="N" D ^DIWP
"RTN","PRCABIL1",106,0)
.D ^DIWW S:$G(PRNT)="FL" PRNT=1 K ^UTILITY($J)
"RTN","PRCABIL1",107,0)
.S IOSL=IOSLSAVE
"RTN","PRCABIL1",108,0)
.W !,"Local Agent Cashier Contact Information"
"RTN","PRCABIL1",109,0)
.W !," Office Phone: ",$G(PRCAPHD)
"RTN","PRCABIL1",110,0)
.W !,"Mailing Address: ",$G(PRCAAD1D)
"RTN","PRCABIL1",111,0)
.I $G(PRCAAD2D)'="" W !," ",$G(PRCAAD2D)
"RTN","PRCABIL1",112,0)
.I $G(PRCAAD3D)'="" W !," ",$G(PRCAAD3D)
"RTN","PRCABIL1",113,0)
.W !," ",PRCACD_", "_PRCASTD_" "_PRCAZPD
"RTN","PRCABIL1",114,0)
Q
"RTN","PRCABIL1",115,0)
;
"RTN","PRCABIL1",116,0)
ST D CKSITE^PRCAUDT S %=$D(PRCA("CKSITE")) Q
"RTN","PRCABIL1",117,0)
ST1 D SVC^PRCABIL S %=$S($D(PRCAP("S")):1,1:0) Q:%
"RTN","PRCABIL1",118,0)
K PRCAP Q
"RTN","PRCABIL1",119,0)
DIP D SVC^PRCABIL Q:'$D(PRCAP("S"))
"RTN","PRCABIL1",120,0)
; PRCA*4.5*276 - add '@' to BILL NO. in the 'BY' paramter so that printout does not show it as a sorting field.
"RTN","PRCABIL1",121,0)
S FR=PRCAP("S")_",?,@",TO=PRCAP("S")_",?",L=0,DIC="^PRCA(430,",FLDS="[PRCA BILL LIST]",BY="@INTERNAL(SERVICE),@BILL NO.,FORM TYPE" D EN1^DIP K BY,DHD,DIC,FLDS,FR,L,PRCAP,TO Q
"RTN","PRCABIL1",122,0)
MESG I $P(^PRCA(430,PRCABN,0),U,9)="" W !,?3,"Debtor (or Payer) data is missing."
"RTN","PRCABIL1",123,0)
I '$D(^PRCA(430,PRCABN,100)) W !,?3,"Service (or Section) , Form type or Voucher number data is missing."
"RTN","PRCABIL1",124,0)
I '$D(^PRCA(430,PRCABN,101)) W !,?3,"Date of Charge data does not exist."
"RTN","PRCABIL1",125,0)
W ! Q
"RTN","PRCABJ2")
0^28^B20492059
"RTN","PRCABJ2",1,0)
PRCABJ2 ;OIT/hrub - NIGHTLY PROCESS FOR ACCOUNTS RECEIVABLE ;31 Oct 2018 16:00:59
"RTN","PRCABJ2",2,0)
;;4.5;Accounts Receivable;**304,321,326,332,338**;Mar 20, 1995;Build 70
"RTN","PRCABJ2",3,0)
;Per VA Directive 6402, this routine should not be modified.
"RTN","PRCABJ2",4,0)
;
"RTN","PRCABJ2",5,0)
; read of ^DGCR(399.2 allowed by DBIA 3822
"RTN","PRCABJ2",6,0)
; refactored 17 October 2018, PRCA*4.5*332
"RTN","PRCABJ2",7,0)
Q
"RTN","PRCABJ2",8,0)
; Auto-audit Paper, Electronic, and Tricare bills if ready
"RTN","PRCABJ2",9,0)
; PRCA*4.5*332 - Whole subroutine re-written
"RTN","PRCABJ2",10,0)
ABAUDIT ;
"RTN","PRCABJ2",11,0)
; APIEN - Accounts Payable (file #430) ien (also same ien for file #399)
"RTN","PRCABJ2",12,0)
N APIEN,ARBILL,C,FLAG,J,PRCA,RTYPE ;PRCA*4.5*321, PRCA*4.5*332
"RTN","PRCABJ2",13,0)
;
"RTN","PRCABJ2",14,0)
S ARBILL("newBillIEN")=$O(^PRCA(430.3,"B","NEW BILL","")) ; New Bill IEN
"RTN","PRCABJ2",15,0)
Q:ARBILL("newBillIEN")="" ; must have the IEN for new bills
"RTN","PRCABJ2",16,0)
; Check parameters to see if audit needs to run
"RTN","PRCABJ2",17,0)
S FLAG("aaMedPaper")=$$GET1^DIQ(342,"1,",7.05,"I") ; (#7.05) AUTO-AUDIT MEDICAL PAPER BILLS [5S]
"RTN","PRCABJ2",18,0)
S FLAG("aaRxPaper")=$$GET1^DIQ(342,"1,",7.06,"I") ; (#7.06) AUTO-AUDIT RX PAPER BILLS [6S]
"RTN","PRCABJ2",19,0)
S FLAG("aaMedEDI")=$$GET1^DIQ(342,"1,",7.07,"I") ; (#7.07) AUTO-AUDIT MEDICAL EDI BILLS [7S] - PRCA*4.5*321
"RTN","PRCABJ2",20,0)
S FLAG("aaRxEDI")=$$GET1^DIQ(342,"1,",7.08,"I") ; (#7.08) AUTO-AUDIT RX EDI BILLS [8S] - PRCA*4.5*321
"RTN","PRCABJ2",21,0)
S FLAG("aaTricare")=$$GET1^DIQ(342,"1,",7.09,"I") ; (#7.09) AUTO-AUDIT TRICARE BILLS [9S] - PRCA*4.5*332
"RTN","PRCABJ2",22,0)
; quit if all auto-audit parameters are 'No'
"RTN","PRCABJ2",23,0)
Q:('FLAG("aaMedPaper"))&('FLAG("aaRxPaper"))&('FLAG("aaMedEDI"))&('FLAG("aaRxEDI"))&('FLAG("aaTricare")) ; PRCA*4.5*321
"RTN","PRCABJ2",24,0)
;
"RTN","PRCABJ2",25,0)
; RTYPE - array of RATE TYPE entries that have (#.11) BILL RESULTING FROM [11P:430.6] - PRCA*4.5*332
"RTN","PRCABJ2",26,0)
S C=0 F S C=$O(^DGCR(399.3,C)) Q:'C S J=$G(^(C,0)) S:$P(J,U,11) RTYPE(C)=J
"RTN","PRCABJ2",27,0)
; loop through new bills
"RTN","PRCABJ2",28,0)
; BILL - info for this bill
"RTN","PRCABJ2",29,0)
; PRCA - bill # and ECME info
"RTN","PRCABJ2",30,0)
; RTDGCR - used for file #399 info (except rate type)
"RTN","PRCABJ2",31,0)
S APIEN="" F S APIEN=$O(^PRCA(430,"AC",ARBILL("newBillIEN"),APIEN)) Q:'APIEN D
"RTN","PRCABJ2",32,0)
. N BILL,PRCA,RTDGCR
"RTN","PRCABJ2",33,0)
. ;
"RTN","PRCABJ2",34,0)
. S BILL("rtTyp")=$$GET1^DIQ(399,APIEN_",",.07,"I") ; (#.07) RATE TYPE [7P:399.3] - PRCA*4.5*326
"RTN","PRCABJ2",35,0)
. Q:'BILL("rtTyp") ; must have rate type
"RTN","PRCABJ2",36,0)
. Q:'$D(RTYPE(BILL("rtTyp"))) ; no auto-audit for this RATE TYPE
"RTN","PRCABJ2",37,0)
. ; BEGIN - PRCA*4.5*321
"RTN","PRCABJ2",38,0)
. Q:$$GET1^DIQ(430,APIEN_",",7,"I")="" ; quit if no (#7) PATIENT [7P:2]
"RTN","PRCABJ2",39,0)
. Q:$$GET1^DIQ(430,APIEN_",",9,"I")="" ; quit if no (#9) DEBTOR [9P:340]
"RTN","PRCABJ2",40,0)
. Q:$$GET1^DIQ(430,APIEN_",",239,"I")="" ; quit if no (#239) INSURED NAME [1F]
"RTN","PRCABJ2",41,0)
. Q:$$GET1^DIQ(430,APIEN_",",243,"I")="" ; quit if no (#243) GROUP NAME [5F]
"RTN","PRCABJ2",42,0)
. Q:$$GET1^DIQ(430,APIEN_",",244,"I")="" ; quit if no (#244) GROUP NUMBER [6F]
"RTN","PRCABJ2",43,0)
. Q:$$BILLREJ^PRCAUDT(APIEN) ; PRCA*4.5*321 - claim has reject messages, do not audit
"RTN","PRCABJ2",44,0)
. ;
"RTN","PRCABJ2",45,0)
. S RTDGCR("type")=$$GET1^DIQ(399,APIEN_",",.07,"E") ; (#.07) RATE TYPE [7P:399.3] (IA 4118)
"RTN","PRCABJ2",46,0)
. S RTDGCR("paper")=$$GET1^DIQ(399,APIEN_",",27,"I") ; (#.27) BILL CHARGE TYPE [27S] (ICR 3820)
"RTN","PRCABJ2",47,0)
. S BILL("audit?")=0 ; Boolean flag, need to audit bill?
"RTN","PRCABJ2",48,0)
. S BILL("doneCheck?")=0 ; Boolean flag, done checking?
"RTN","PRCABJ2",49,0)
. ; Get Bill number to check if it's a Pharmacy bill
"RTN","PRCABJ2",50,0)
. S PRCA("bill#")=$$GET1^DIQ(430,APIEN_",",.01,"I") ; (#.01) BILL NO. [1F]
"RTN","PRCABJ2",51,0)
. S PRCA("ecme#")=$$GETECME^RCDPENR1(APIEN) ; ECME# from the bill
"RTN","PRCABJ2",52,0)
. ;
"RTN","PRCABJ2",53,0)
. I PRCA("ecme#")'="" D ; has ECME#, check pharmacy flags
"RTN","PRCABJ2",54,0)
.. I RTDGCR("paper"),'FLAG("aaRxPaper") S BILL("doneCheck?")=1 Q ; Skip paper bill if No auto-audit
"RTN","PRCABJ2",55,0)
.. I 'RTDGCR("paper"),'FLAG("aaRxEDI") S BILL("doneCheck?")=1 Q ; Skip EDI bill if No auto-audit
"RTN","PRCABJ2",56,0)
.. S BILL("audit?")="1^pharmacy" ; audit this pharmacy bill
"RTN","PRCABJ2",57,0)
. ;
"RTN","PRCABJ2",58,0)
. I BILL("audit?") D AUDITX^PRCAUDT(APIEN) Q ; audit pharmacy bill, continue loop
"RTN","PRCABJ2",59,0)
. Q:BILL("doneCheck?") ; done checking, continue loop through bills
"RTN","PRCABJ2",60,0)
. ;
"RTN","PRCABJ2",61,0)
. I RTDGCR("type")["TRICARE" D
"RTN","PRCABJ2",62,0)
.. I FLAG("aaTricare") S BILL("audit?")="1^Tricare" ; audit this Tricare bill
"RTN","PRCABJ2",63,0)
.. S BILL("doneCheck?")=1
"RTN","PRCABJ2",64,0)
. I BILL("audit?") D AUDITX^PRCAUDT(APIEN) Q ; audit Tricare bill, continue loop
"RTN","PRCABJ2",65,0)
. Q:BILL("doneCheck?") ; done checking, continue loop through bills
"RTN","PRCABJ2",66,0)
. D ; medical bill, check medical flags
"RTN","PRCABJ2",67,0)
.. I RTDGCR("paper"),'FLAG("aaMedPaper") S BILL("doneCheck?")=1 Q ; Skip paper bill if No auto-audit
"RTN","PRCABJ2",68,0)
.. I 'RTDGCR("paper"),'FLAG("aaMedEDI") S BILL("doneCheck?")=1 Q ; Skip EDI bill if No auto-audit
"RTN","PRCABJ2",69,0)
.. S BILL("audit?")="1^medical" ; audit this medical bill
"RTN","PRCABJ2",70,0)
. Q:BILL("doneCheck?") ; no auto-audit for medical bill
"RTN","PRCABJ2",71,0)
. ; passed medical checks call auto-audit for this Bill
"RTN","PRCABJ2",72,0)
. I BILL("audit?") D AUDITX^PRCAUDT(APIEN)
"RTN","PRCABJ2",73,0)
;
"RTN","PRCABJ2",74,0)
Q
"RTN","PRCABJ2",75,0)
;
"RTN","PRCABJV")
0^7^B54348019
"RTN","PRCABJV",1,0)
PRCABJV ;WASH-ISC@ALTOONA,PA/TJK-FILE VERIFICATION FOR BACKGROUND JOB ;4/6/95 10:13 AM
"RTN","PRCABJV",2,0)
V ;;4.5;Accounts Receivable;**1,48,63,114,141,170,176,173,192,220,296,310,315,338**;Mar 20, 1995;Build 70
"RTN","PRCABJV",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","PRCABJV",4,0)
;;patch 192 changes all occurrences of CHAMPUS to TRICARE
"RTN","PRCABJV",5,0)
EN1(FILE,X1,X2,ERROR) ;
"RTN","PRCABJV",6,0)
;FILE IS THE FILE NUMBER
"RTN","PRCABJV",7,0)
;X1 AND X2 ARE 3 PART VARIABLES SEPARATED BY SEMI-COLONS WITH
"RTN","PRCABJV",8,0)
;THE FORMAT (X-REF INDEX;NODE;PIECE)
"RTN","PRCABJV",9,0)
;AN ERROR ARRAY IS SET IF VALIDATION FAILS
"RTN","PRCABJV",10,0)
NEW LT,CNT,I,I1,I2,I3,REC,IND,ND,PC,DATA,J,LN,FILENT
"RTN","PRCABJV",11,0)
S LT=$S(FILE[430.3:"TRANST",FILE[430.2:"CAT",1:"EVENT"),CNT=0
"RTN","PRCABJV",12,0)
F I=1,2 S J=@("X"_I),IND(I)=$P(J,";"),ND(I)=$P(J,";",2),PC(I)=$P(J,";",3)
"RTN","PRCABJV",13,0)
F I1=1:1 D Q:(DATA(0)="EOF")!(ERROR)
"RTN","PRCABJV",14,0)
.S LN=$T(@LT+I1) F I=3:1:6 S DATA(I-3)=$P(LN,";",I)
"RTN","PRCABJV",15,0)
.Q:DATA(0)="EOF"
"RTN","PRCABJV",16,0)
.G RC:FILE<430
"RTN","PRCABJV",17,0)
.I '$D(^PRCA(FILE,"B",DATA(0))) S ERROR=1 Q
"RTN","PRCABJV",18,0)
.S REC=$O(^PRCA(FILE,"B",DATA(0),0)) I 'REC S ERROR=1 Q
"RTN","PRCABJV",19,0)
.I DATA(3)'=REC S ERROR=1 Q
"RTN","PRCABJV",20,0)
.I $P(^PRCA(FILE,REC,0),U)'=DATA(0) S ERROR=1 Q
"RTN","PRCABJV",21,0)
.G CNT:X1=""
"RTN","PRCABJV",22,0)
.F I2=1,2 D Q:ERROR I I2=1,X2="" Q
"RTN","PRCABJV",23,0)
..I '$D(^PRCA(FILE,IND(I2),DATA(I2))) S ERROR=1 G Q2
"RTN","PRCABJV",24,0)
..; do not check if category number is a zero
"RTN","PRCABJV",25,0)
..I I2=1,DATA(1)'=0,$O(^PRCA(FILE,IND(I2),DATA(I2),0))'=REC S ERROR=1 G Q2
"RTN","PRCABJV",26,0)
..I $P(^PRCA(FILE,REC,ND(I2)),U,PC(I2))'=DATA(I2) S ERROR=1
"RTN","PRCABJV",27,0)
Q2 ..Q
"RTN","PRCABJV",28,0)
CNT .Q:ERROR
"RTN","PRCABJV",29,0)
.S CNT=CNT+1
"RTN","PRCABJV",30,0)
Q1 .Q
"RTN","PRCABJV",31,0)
RC .I '$D(^RC(FILE,"B",DATA(0))) S ERROR=1 Q
"RTN","PRCABJV",32,0)
.S REC=$O(^RC(FILE,"B",DATA(0),0)) I 'REC S ERROR=1 Q
"RTN","PRCABJV",33,0)
.I DATA(3)'=REC S ERROR=1 Q
"RTN","PRCABJV",34,0)
.I $P(^RC(FILE,REC,0),U)'=DATA(0) S ERROR=1 Q
"RTN","PRCABJV",35,0)
.G CNT:X1=""
"RTN","PRCABJV",36,0)
.F I3=1,2 D Q:ERROR I I3=1,X2="" Q
"RTN","PRCABJV",37,0)
..I '$D(^RC(FILE,IND(I3),DATA(I3))) S ERROR=1 G Q3
"RTN","PRCABJV",38,0)
..I $O(^RC(FILE,IND(I3),DATA(I3),0))'=REC S ERROR=1 G Q3
"RTN","PRCABJV",39,0)
..I $P(^RC(FILE,REC,ND(I3)),U,PC(I3))'=DATA(I3) S ERROR=1
"RTN","PRCABJV",40,0)
Q3 ..Q
"RTN","PRCABJV",41,0)
.G CNT
"RTN","PRCABJV",42,0)
I FILE>429.99,$P(^PRCA(FILE,0),U,4)'=CNT S ERROR=1 G EXIT
"RTN","PRCABJV",43,0)
G EXIT:FILE>429.99
"RTN","PRCABJV",44,0)
I $P(^RC(FILE,0),U,4)'=CNT S ERROR=1
"RTN","PRCABJV",45,0)
EXIT Q:'ERROR
"RTN","PRCABJV",46,0)
S FILENT=$S(FILE>429.99:$P(^PRCA(FILE,0),U,4),1:$P(^RC(FILE,0),U,4))
"RTN","PRCABJV",47,0)
S ERROR(1)="An error has been detected in the "_$P(^DIC(FILE,0),U)_" File."
"RTN","PRCABJV",48,0)
I DATA(0)="EOF" S ERROR(2)="There are too many entries in your file."
"RTN","PRCABJV",49,0)
I DATA(0)'="EOF" S ERROR(2)="The "_DATA(0)_" Entry in your file is missing or corrupted."
"RTN","PRCABJV",50,0)
Q
"RTN","PRCABJV",51,0)
TRANST ;
"RTN","PRCABJV",52,0)
;;ACTIVE;102;A;16
"RTN","PRCABJV",53,0)
;;ADD (AMEND);302;AD;37
"RTN","PRCABJV",54,0)
;;ADMIN.COST CHARGE;12;AC;12
"RTN","PRCABJV",55,0)
;;AMEND;303;AM;38
"RTN","PRCABJV",56,0)
;;AMENDED BILL;110;AB;33
"RTN","PRCABJV",57,0)
;;ARCHIVED;115;XX;49
"RTN","PRCABJV",58,0)
;;BILL INCOMPLETE;201;BI;27
"RTN","PRCABJV",59,0)
;;CANCELLATION;111;CN;39
"RTN","PRCABJV",60,0)
;;CANCELLED BILL;210;CB;26
"RTN","PRCABJV",61,0)
;;CASH COLLECTION BY RC/DOJ;7;CJ;7
"RTN","PRCABJV",62,0)
;;CHARGE SUSPENDED;19;CS;47
"RTN","PRCABJV",63,0)
;;COLLECTED/CLOSED;108;CC;22
"RTN","PRCABJV",64,0)
;;COMMENT;17;CM;45
"RTN","PRCABJV",65,0)
;;CS ADD CASE INFO;47;CZ;67
"RTN","PRCABJV",66,0)
;;CS ADMIN ADJ TR REV?N;54;AO;76
"RTN","PRCABJV",67,0)
;;CS ADMIN ADJ TR REV?Y;53;AN;75
"RTN","PRCABJV",68,0)
;;CS ADMIN.COST CHARGE;52;AE;74
"RTN","PRCABJV",69,0)
;;CS BILL RECALL;34;CR;53
"RTN","PRCABJV",70,0)
;;CS CASE RECALL;45;CO;64
"RTN","PRCABJV",71,0)
;;CS DEBTOR NEW BILL;39;CK;85
"RTN","PRCABJV",72,0)
;;CS DEBTOR RECALL;35;CE;56
"RTN","PRCABJV",73,0)
;;CS DECR ADJ NOT APP;40;CA;66
"RTN","PRCABJV",74,0)
;;CS DECREASE ADJ;49;CY;70
"RTN","PRCABJV",75,0)
;;CS DEL BILL RECALL;37;CF;55
"RTN","PRCABJV",76,0)
;;CS DEL CASE RECALL;46;CG;65
"RTN","PRCABJV",77,0)
;;CS DEL DEBTOR RECALL;38;CL;57
"RTN","PRCABJV",78,0)
;;CS INC ADJ TR REV?N;58;AT;80
"RTN","PRCABJV",79,0)
;;CS INC ADJ TR REV?Y;57;AS;79
"RTN","PRCABJV",80,0)
;;CS INCREASE ADJ;51;AI;73
"RTN","PRCABJV",81,0)
;;CS NEW DBTR NEW BILL;48;CH;68
"RTN","PRCABJV",82,0)
;;CS PEND RECON;61;RK;83
"RTN","PRCABJV",83,0)
;;CS RECALL PLACED;62;CQ;84
"RTN","PRCABJV",84,0)
;;CS RECON WORKED;50;CV;71
"RTN","PRCABJV",85,0)
;;CS STOP DELETED;36;CD;54
"RTN","PRCABJV",86,0)
;;CS STOP PLACED;33;CP;51
"RTN","PRCABJV",87,0)
;;CS UPDATE DEBT;41;CU;60
"RTN","PRCABJV",88,0)
;;DEBIT VOUCHER (SF 5515);30;DV;30
"RTN","PRCABJV",89,0)
;;DECREASE ADJUSTMENT;21;DA;35
"RTN","PRCABJV",90,0)
;;DEL REPAY PLAN;31;DP;72
"RTN","PRCABJV",91,0)
;;DELETE (AMEND);301;DL;36
"RTN","PRCABJV",92,0)
;;EXEMPT INT/ADM. COST;14;E;14
"RTN","PRCABJV",93,0)
;;IN-ACTIVE;103;IA;17
"RTN","PRCABJV",94,0)
;;INCOMPLETE;101;IN;15
"RTN","PRCABJV",95,0)
;;INCREASE ADJUSTMENT;1;AJ;1
"RTN","PRCABJV",96,0)
;;INTEREST/ADM. CHARGE;13;IC;13
"RTN","PRCABJV",97,0)
;;MARSHAL/COURT COST;15;ML;24
"RTN","PRCABJV",98,0)
;;NEW BILL;104;N;18
"RTN","PRCABJV",99,0)
;;OLD BILL;106;OB;28
"RTN","PRCABJV",100,0)
;;OPEN;112;OP;42
"RTN","PRCABJV",101,0)
;;PAYMENT (IN FULL);20;PF;34
"RTN","PRCABJV",102,0)
;;PAYMENT (IN PART);2;PP;2
"RTN","PRCABJV",103,0)
;;PENDING APPROVAL;205;PA;20
"RTN","PRCABJV",104,0)
;;PENDING ARCHIVE;114;X;48
"RTN","PRCABJV",105,0)
;;PENDING CALM CODE;107;PC;21
"RTN","PRCABJV",106,0)
;;REESTABLISH TO RC/DOJ;5;RR;5
"RTN","PRCABJV",107,0)
;;RE-ESTABLISH;250;RW;43
"RTN","PRCABJV",108,0)
;;REFER TO DOJ;4;RJ;4
"RTN","PRCABJV",109,0)
;;REFER TO RC;3;RC;3
"RTN","PRCABJV",110,0)
;;REFUND REVIEW;113;PR;44
"RTN","PRCABJV",111,0)
;;REFUNDED;120;RF;41
"RTN","PRCABJV",112,0)
;;REPAYMENT PLAN;16;RP;25
"RTN","PRCABJV",113,0)
;;RETURNED BY RC/DOJ;6;RD;6
"RTN","PRCABJV",114,0)
;;RETURNED FOR AMENDMENT;230;RA;32
"RTN","PRCABJV",115,0)
;;RETURNED FROM AR (NEW);220;RT;31
"RTN","PRCABJV",116,0)
;;SUSPENDED;240;SP;40
"RTN","PRCABJV",117,0)
;;SUSPENSE;105;S;19
"RTN","PRCABJV",118,0)
;;TERM.BY COMPROMISE;9;TC;9
"RTN","PRCABJV",119,0)
;;TERM.BY FIS.OFFICER;8;TO;8
"RTN","PRCABJV",120,0)
;;TERM.BY RC/DOJ;29;TJ;29
"RTN","PRCABJV",121,0)
;;UNSUSPENDED;18;US;46
"RTN","PRCABJV",122,0)
;;WAIVED IN FULL;10;WF;10
"RTN","PRCABJV",123,0)
;;WAIVED IN PART;11;WP;11
"RTN","PRCABJV",124,0)
;;WRITE-OFF;109;WO;23
"RTN","PRCABJV",125,0)
;;EOF
"RTN","PRCABJV",126,0)
;
"RTN","PRCABJV",127,0)
;PRCA*4.5*338 - Added and Alphabetized Community Care categories
"RTN","PRCABJV",128,0)
CAT ;patch 192 - ISC-0502-N2803 change Champus to Tricare
"RTN","PRCABJV",129,0)
;;ADULT DAY HEALTH CARE;40;AD;33
"RTN","PRCABJV",130,0)
;;C (MEANS TEST);24;C;18
"RTN","PRCABJV",131,0)
;;CC INPT;65;CJ;63
"RTN","PRCABJV",132,0)
;;CC MTF INPT;69;CX;67
"RTN","PRCABJV",133,0)
;;CC MTF OPT;86;D3;84
"RTN","PRCABJV",134,0)
;;CC MTF RX CO-PAYMENT;70;CY;68
"RTN","PRCABJV",135,0)
;;CC MTF THIRD PARTY;53;C4;51
"RTN","PRCABJV",136,0)
;;CC NO-FAULT AUTO;60;C8;58
"RTN","PRCABJV",137,0)
;;CC NURSING HOME CARE - LTC;71;CL;69
"RTN","PRCABJV",138,0)
;;CC OPT;84;D1;82
"RTN","PRCABJV",139,0)
;;CC RESPITE CARE;72;CN;70
"RTN","PRCABJV",140,0)
;;CC RX CO-PAYMENT;66;CK;64
"RTN","PRCABJV",141,0)
;;CC THIRD PARTY;51;C2;49
"RTN","PRCABJV",142,0)
;;CC TORT FEASOR;61;C9;59
"RTN","PRCABJV",143,0)
;;CC WORKERS' COMP;59;CA;57
"RTN","PRCABJV",144,0)
;;CCN INPT;67;CO;65
"RTN","PRCABJV",145,0)
;;CCN NO-FAULT AUTO;57;CB;55
"RTN","PRCABJV",146,0)
;;CCN NURSING HOME CARE - LTC;73;CR;71
"RTN","PRCABJV",147,0)
;;CCN OPT;85;D2;83
"RTN","PRCABJV",148,0)
;;CCN RESPITE CARE;74;CU;72
"RTN","PRCABJV",149,0)
;;CCN RX CO-PAYMENT;68;CQ;66
"RTN","PRCABJV",150,0)
;;CCN THIRD PARTY;52;C3;50
"RTN","PRCABJV",151,0)
;;CCN TORT FEASOR;58;CC;56
"RTN","PRCABJV",152,0)
;;CCN WORKERS' COMP;56;CD;54
"RTN","PRCABJV",153,0)
;;CHAMPVA;36;CV;29
"RTN","PRCABJV",154,0)
;;CHAMPVA SUBSISTENCE;34;CS;27
"RTN","PRCABJV",155,0)
;;CHAMPVA THIRD PARTY;35;CT;28
"RTN","PRCABJV",156,0)
;;CHOICE INPT;63;CF;61
"RTN","PRCABJV",157,0)
;;CHOICE NO-FAULT AUTO;54;C5;52
"RTN","PRCABJV",158,0)
;;CHOICE NURSING HOME CARE - LTC;75;CH;73
"RTN","PRCABJV",159,0)
;;CHOICE OPT;83;CZ;81
"RTN","PRCABJV",160,0)
;;CHOICE RESPITE CARE;76;CI;74
"RTN","PRCABJV",161,0)
;;CHOICE RX CO-PAYMENT;64;CG;62
"RTN","PRCABJV",162,0)
;;CHOICE THIRD PARTY;50;C1;48
"RTN","PRCABJV",163,0)
;;CHOICE TORT FEASOR;55;C6;53
"RTN","PRCABJV",164,0)
;;CHOICE WORKERS' COMP;62;C7;60
"RTN","PRCABJV",165,0)
;;COMP & PEN PROCEEDS;8;CM;43
"RTN","PRCABJV",166,0)
;;CRIME OF PER.VIO.;27;CP;8
"RTN","PRCABJV",167,0)
;;CURRENT EMP.;14;CE;16
"RTN","PRCABJV",168,0)
;;CWT PROCEEDS;7;CW;42
"RTN","PRCABJV",169,0)
;;DOMICILIARY;41;DO;34
"RTN","PRCABJV",170,0)
;;EMERGENCY/HUMANITARIAN;25;H;2
"RTN","PRCABJV",171,0)
;;EMERGENCY/HUMANITARIAN REIMB.;48;HR;46
"RTN","PRCABJV",172,0)
;;ENHANCED USE LEASE PROCEEDS;10;EP;44
"RTN","PRCABJV",173,0)
;;EX-EMPLOYEE;13;E;15
"RTN","PRCABJV",174,0)
;;FEDERAL AGENCIES-REFUND;15;F2;13
"RTN","PRCABJV",175,0)
;;FEDERAL AGENCIES-REIMB.;16;F1;14
"RTN","PRCABJV",176,0)
;;FEE REIMB INS;47;FR;45
"RTN","PRCABJV",177,0)
;;GERIATRIC EVAL-INSTITUTIONAL;44;GE;37
"RTN","PRCABJV",178,0)
;;GERIATRIC EVAL-NON-INSTITUTION;45;GN;38
"RTN","PRCABJV",179,0)
;;HOSPITAL CARE (NSC);1;HC;5
"RTN","PRCABJV",180,0)
;;HOSPITAL CARE PER DIEM;32;HP;25
"RTN","PRCABJV",181,0)
;;INELIGIBLE HOSP.;20;I;1
"RTN","PRCABJV",182,0)
;;INELIGIBLE HOSP. REIMB.;49;IR;47
"RTN","PRCABJV",183,0)
;;INTERAGENCY;19;IA;20
"RTN","PRCABJV",184,0)
;;MEDICARE;28;MC;21
"RTN","PRCABJV",185,0)
;;MILITARY;17;M;12
"RTN","PRCABJV",186,0)
;;NO-FAULT AUTO ACC.;26;NA;7
"RTN","PRCABJV",187,0)
;;NURSING HOME CARE PER DIEM;31;NP;24
"RTN","PRCABJV",188,0)
;;NURSING HOME CARE(NSC);3;NC;3
"RTN","PRCABJV",189,0)
;;NURSING HOME CARE-LTC;46;NL;39
"RTN","PRCABJV",190,0)
;;NURSING HOME PROCEEDS;5;NH;40
"RTN","PRCABJV",191,0)
;;OUTPATIENT CARE(NSC);2;OC;4
"RTN","PRCABJV",192,0)
;;PARKING FEES;6;PF;41
"RTN","PRCABJV",193,0)
;;PREPAYMENT;33;PP;26
"RTN","PRCABJV",194,0)
;;REIMBURS.HEALTH INS.;21;RI;9
"RTN","PRCABJV",195,0)
;;RESPITE CARE-INSTITUTIONAL;42;RC;35
"RTN","PRCABJV",196,0)
;;RESPITE CARE-NON-INSTITUTIONAL;43;RN;36
"RTN","PRCABJV",197,0)
;;RX CO-PAYMENT/NSC VET;30;PN;23
"RTN","PRCABJV",198,0)
;;RX CO-PAYMENT/SC VET;29;PS;22
"RTN","PRCABJV",199,0)
;;SHARING AGREEMENTS;18;SA;19
"RTN","PRCABJV",200,0)
;;TORT FEASOR;22;TF;10
"RTN","PRCABJV",201,0)
;;TRICARE;37;T1;30
"RTN","PRCABJV",202,0)
;;TRICARE BLIND REHABILITATION;80;T7;78
"RTN","PRCABJV",203,0)
;;TRICARE DENTAL;81;T8;79
"RTN","PRCABJV",204,0)
;;TRICARE DES;77;T4;75
"RTN","PRCABJV",205,0)
;;TRICARE PATIENT;38;T2;31
"RTN","PRCABJV",206,0)
;;TRICARE PHARMACY;82;T9;80
"RTN","PRCABJV",207,0)
;;TRICARE SCI;78;T5;76
"RTN","PRCABJV",208,0)
;;TRICARE TBI;79;T6;77
"RTN","PRCABJV",209,0)
;;TRICARE THIRD PARTY;39;T3;32
"RTN","PRCABJV",210,0)
;;VENDOR;11;V;17
"RTN","PRCABJV",211,0)
;;WORKMAN'S COMP.;23;WC;6
"RTN","PRCABJV",212,0)
;;EOF
"RTN","PRCABJV",213,0)
EVENT ;
"RTN","PRCABJV",214,0)
;;CASH PAYMENT;6;;6
"RTN","PRCABJV",215,0)
;;CHECK/MO PAYMENT;4;;4
"RTN","PRCABJV",216,0)
;;COMMENT;1;;1
"RTN","PRCABJV",217,0)
;;CREDIT CARD PAYMENT;7;;7
"RTN","PRCABJV",218,0)
;;DEPT OF JUSTICE PAYMENT;5;;5
"RTN","PRCABJV",219,0)
;;REGIONAL COUNSEL PAYMENT;3;;3
"RTN","PRCABJV",220,0)
;;FOLLOW-UP LETTER;10;;10
"RTN","PRCABJV",221,0)
;;IRS PAYMENT;11;;11
"RTN","PRCABJV",222,0)
;;PATIENT STATEMENT;2;;2
"RTN","PRCABJV",223,0)
;;TDA PAYMENT;8;;8
"RTN","PRCABJV",224,0)
;;UB PRINTED;9;;9
"RTN","PRCABJV",225,0)
;;LOCKBOX;12;;12
"RTN","PRCABJV",226,0)
;;TOP PAYMENT;13;;13
"RTN","PRCABJV",227,0)
;;EDI LOCKBOX;14;;14
"RTN","PRCABJV",228,0)
;;ADMINISTRATIVE OFFSET;15;;15
"RTN","PRCABJV",229,0)
;;PRIVATE COLLECTION AGENCY;16;;16
"RTN","PRCABJV",230,0)
;;EOF
"RTN","PRCACPV")
0^25^B17132531
"RTN","PRCACPV",1,0)
PRCACPV ;WASH-ISC@ALTOONA,PA/LDB- CHAMPVA FMS DOCUMENTS ;5/1/95 3:06 PM
"RTN","PRCACPV",2,0)
V ;;4.5;Accounts Receivable;**1,48,90,119,204,192,235,295,315,338**;Mar 20, 1995;Build 70
"RTN","PRCACPV",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","PRCACPV",4,0)
;
"RTN","PRCACPV",5,0)
;Add CAT=47:"INELIGIBLE REIMB. ins. code for PRCA*4.5*315
"RTN","PRCACPV",6,0)
EN(BILL,ERR) ;Send CHAMPVA SUBSISTENCE bill to FMS
"RTN","PRCACPV",7,0)
N ADD,ADDR,AMT,BILL0,BNUM,CAT,DA,DIE,DOC,DR,ERROR,ENT,FY,GECSFMS,I,P,PAT,SITE,TXT,VA,VAERR,VADM,X,XMDUZ,XMTEXT,XMY,XMSUB,Y
"RTN","PRCACPV",8,0)
S ERR=-1
"RTN","PRCACPV",9,0)
I '$G(BILL) S ERR="NO BILL NUMBER TO PROCESS" D ERR Q
"RTN","PRCACPV",10,0)
S BILL0=$G(^PRCA(430,+BILL,0)) I BILL0']"" S ERR="BILL INFO CORRUPTED FOR BILL '"_BILL D ERR Q
"RTN","PRCACPV",11,0)
;Allow all TRICARE categories to transmit to FMS - PRCA*4.5*295
"RTN","PRCACPV",12,0)
;Add ineligible reimb ins *315
"RTN","PRCACPV",13,0)
I "^27^28^30^31^32^47^"'[("^"_$P(BILL0,"^",2)_"^") Q
"RTN","PRCACPV",14,0)
S SITE=$P($P(BILL0,"^"),"-") I SITE']"" S ERR="BILL NUMBER CORRUPTED" D ERR Q
"RTN","PRCACPV",15,0)
S BNUM=$P(BILL0,"^")
"RTN","PRCACPV",16,0)
S AMT=$J($P(BILL0,"^",3),0,2)
"RTN","PRCACPV",17,0)
S CAT=$P(BILL0,"^",2)
"RTN","PRCACPV",18,0)
I "^27^31^"[("^"_CAT_"^") S PAT=$P($G(^PRCA(430,+BILL,0)),"^",9),PAT=$P($G(^RCD(340,+PAT,0)),"^"),PAT=$$NAM^RCFN01(PAT),PAT=$P(PAT,",",2)_" "_$P(PAT,",")
"RTN","PRCACPV",19,0)
S FY=$$FY^RCFN01(DT)
"RTN","PRCACPV",20,0)
S ADD=$$SADD^RCFN01(5)
"RTN","PRCACPV",21,0)
;Add ineligible reimb ins *315
"RTN","PRCACPV",22,0)
S DESC=$S(CAT=27:"CHAMPVA Subsistence",CAT=30:"TRICARE",CAT=31:"TRICARE PATIENT",CAT=32:"TRICARE Third Party",CAT=47:"INELIGIBLE HOSP. REIMB.",1:"CHAMPVA Third Party")
"RTN","PRCACPV",23,0)
F I=1:1:6 S ADDR(I)=$P(ADD,"^",I) I (I'=3),(ADDR(I)']"") S ERR="NO HOSPITAL ADDRESS FOUND FOR SITE GROUP" D ERR Q
"RTN","PRCACPV",24,0)
I ERR>0 Q
"RTN","PRCACPV",25,0)
;CALL TO GET VENDORID BELOW - CHECK NOT NECESSARY SINCE GENERIC
"RTN","PRCACPV",26,0)
;VENDOR CODE ALWAYS RETURNED FOR THESE BILL TYPES
"RTN","PRCACPV",27,0)
S VENDORID=$$VENDORID^RCXFMSUV(BILL)
"RTN","PRCACPV",28,0)
I ADDR(6)["-" S ADDR(7)=$P(ADDR(6),"-",2),ADDR(6)=$P(ADDR(6),"-")
"RTN","PRCACPV",29,0)
N FMSDT S FMSDT=$$FMSDATE^RCBEUTRA(DT)
"RTN","PRCACPV",30,0)
S ^TMP("PRCACPV",$J,1)="BD2^"_$E(FMSDT,4,5)_"^"_$E(FMSDT,6,7)_"^"_$E(FMSDT,2,3)
"RTN","PRCACPV",31,0)
S ^TMP("PRCACPV",$J,1)=^TMP("PRCACPV",$J,1)_"^^^^^^E^"_VENDORID_"^^"_AMT_"^^^^"_$E(ADDR(1),1,30)_"^"_$E(ADDR(2),1,30)_"^"_$E(ADDR(3),1,30)_"^"_$E(ADDR(4),1,19)_"^"_ADDR(5)_"^"_ADDR(6)_"^"_$G(ADDR(7))_"^"_"N^^^^^^W^~"
"RTN","PRCACPV",32,0)
;Add ineligible reimb ins *315
"RTN","PRCACPV",33,0)
S ^TMP("PRCACPV",$J,2)="LIN^~BDA^"_$$LINE^RCXFMSC1(BILL)_"^"_FY_"^^"_$S(CAT=28:"0160R1",CAT<30:"3220",CAT=47:"0160R1",1:"0160R1")_"^"_SITE_"^^^" ; patch PRCA*4.5*338
"RTN","PRCACPV",34,0)
S:CAT<30 CAT("R")=1000
"RTN","PRCACPV",35,0)
I CAT'<30 S CAT("R")=$P($G(^PRCA(430,+BILL,11)),U,6)
"RTN","PRCACPV",36,0)
;Add ineligible reimb ins *315
"RTN","PRCACPV",37,0)
S ^TMP("PRCACPV",$J,2)=^TMP("PRCACPV",$J,2)_CAT("R")_"^^^^^^^"_AMT_"^I^AR_INTERFACE^^^^"_$S(CAT<30:"09",CAT=47:"02",1:"02")_"^~"
"RTN","PRCACPV",38,0)
D CONTROL^GECSUFMS("A",SITE,BNUM,"BD",10,0,"",DESC)
"RTN","PRCACPV",39,0)
I '$D(GECSFMS("DA")) S ERR="COULD NOT ACCESS STACK FILE" D ERR Q
"RTN","PRCACPV",40,0)
S DOC=$S($G(GECSFMS("DOC"))]"":$P(GECSFMS("DOC"),"^",3)_"-"_$P(GECSFMS("DOC"),"^",4),1:BNUM)
"RTN","PRCACPV",41,0)
S DA=0 F S DA=$O(^TMP("PRCACPV",$J,DA)) Q:'DA D
"RTN","PRCACPV",42,0)
. D SETCS^GECSSTAA(GECSFMS("DA"),^TMP("PRCACPV",$J,DA))
"RTN","PRCACPV",43,0)
D OPEN^RCFMDRV1(DOC,6,"B"_+BILL,.ENT,.ERROR,+BILL)
"RTN","PRCACPV",44,0)
I ERROR]"" S ERR="AR DOCUMENT MISSING - "_ERROR Q
"RTN","PRCACPV",45,0)
D SETCODE^GECSSDCT(GECSFMS("DA"),"D RETN^RCFMFN02")
"RTN","PRCACPV",46,0)
D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
"RTN","PRCACPV",47,0)
D SSTAT^RCFMFN02("B"_+BILL,1)
"RTN","PRCACPV",48,0)
K ^TMP("PRCACPV",$J)
"RTN","PRCACPV",49,0)
;
"RTN","PRCACPV",50,0)
ERR ;Add ineligible reimb ins *315
"RTN","PRCACPV",51,0)
I ERR'<0 S ERR="1^"_ERR D
"RTN","PRCACPV",52,0)
.S TXT(1)="The following error has occurred while processing a "_$S(CAT=31:"TRICARE PATIENT ",CAT=47:"INELIGIBLE REIMB. INS. PATIENT",1:"CHAMPVA")
"RTN","PRCACPV",53,0)
.S TXT(2)="bill: ("_$S($G(BNUM):BNUM,1:"BILL IFN - "_+BILL)_")"
"RTN","PRCACPV",54,0)
.S TXT(3)=" "
"RTN","PRCACPV",55,0)
.S TXT(4)=$P(ERR,"^",2)
"RTN","PRCACPV",56,0)
.S TXT(5)=""
"RTN","PRCACPV",57,0)
.S TXT(6)="You will need to use the BILLING DOCUMENT REGENERATION option to create the FMS document."
"RTN","PRCACPV",58,0)
.S XMTEXT="TXT(",XMY("G.PRCA ERROR")=""
"RTN","PRCACPV",59,0)
.S XMSUB=$S(CAT=31:"TRICARE PATIENT",CAT=30:"TRICARE",CAT=32:"TRICARE Third Party",CAT=47:"INELIGIBLE REIMB. INS. PATIENT",1:"CHAMPVA")_" FMS DOC error",XMDUZ="ACCOUNTS RECEIVABLE PACKAGE"
"RTN","PRCACPV",60,0)
.D ^XMD
"RTN","PRCACPV",61,0)
Q
"RTN","PRCAFUT")
0^26^B42522073
"RTN","PRCAFUT",1,0)
PRCAFUT ;WASH-ISC@ALTOONA/CLH-FMS Utilities ;10/8/96 10:50 AM
"RTN","PRCAFUT",2,0)
V ;;4.5;Accounts Receivable;**5,39,64,92,104,169,188,194,220,231,315,338**;Mar 20, 1995;Build 70
"RTN","PRCAFUT",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","PRCAFUT",4,0)
CPLK(PRCABN) ;get control point from file 430 and set DR string to edit CP data
"RTN","PRCAFUT",5,0)
N DR,X,Y,QUIT,FUND,FTBL,CAT,CATTYP,CATTYPE,CP,BBFY,EBFY,DIC,BGFY,CPTBL,CC,SCC,EXIT,FYERROR
"RTN","PRCAFUT",6,0)
K PRCA("EXIT")
"RTN","PRCAFUT",7,0)
S PRCA("SITE")=$S($G(PRCABN):$P($P($G(^PRCA(430,PRCABN,0)),"^"),"-"),1:$$SITE^RCMSITE)
"RTN","PRCAFUT",8,0)
S CP=$P($G(^PRCA(430,PRCABN,11)),U)
"RTN","PRCAFUT",9,0)
S CAT=+$P($G(^PRCA(430,PRCABN,0)),U,2),CATTYP=$P($G(^PRCA(430.2,CAT,0)),U,13)
"RTN","PRCAFUT",10,0)
I CAT>39,CAT<45 D G END
"RTN","PRCAFUT",11,0)
.S TYPE="09" D CHKELEM,REV Q:$G(PRCA("EXIT"))
"RTN","PRCAFUT",12,0)
.S DR="257///^S X=$G(PRCA(""SITE""))"
"RTN","PRCAFUT",13,0)
.;I CAT'=42 S DR=DR_";258////1"
"RTN","PRCAFUT",14,0)
.D DIE
"RTN","PRCAFUT",15,0)
.Q
"RTN","PRCAFUT",16,0)
I CAT=47 D G END ;315
"RTN","PRCAFUT",17,0)
.S TYPE="02",FUND="0160R1" ; patch PRCA*4.5*338
"RTN","PRCAFUT",18,0)
.S DR="259///"_TYPE_";203///^S X=FUND"
"RTN","PRCAFUT",19,0)
.D DIE
"RTN","PRCAFUT",20,0)
.Q
"RTN","PRCAFUT",21,0)
D TYPE Q:$D(PRCA("EXIT"))
"RTN","PRCAFUT",22,0)
I CATTYP=2 K PRCA("EXIT") D G END
"RTN","PRCAFUT",23,0)
. ;reibursement logic (if there is such a thing)
"RTN","PRCAFUT",24,0)
. S DR="203" D DIE K DR I $D(Y) Q
"RTN","PRCAFUT",25,0)
. I '$D(FUND) S FUND=$P($G(^PRCA(430,PRCABN,11)),U,17) D I FUND=-1 S PRCA("EXIT")="" Q
"RTN","PRCAFUT",26,0)
.. N X,Y,DIC
"RTN","PRCAFUT",27,0)
.. S X=FUND,DIC="^PRCD(420.14,",DIC(0)="XMNZ",DIC("B")=FUND D ^DIC
"RTN","PRCAFUT",28,0)
.. I +Y<0 D FUND^PRCAFBDU D Q:FUND=-1
"RTN","PRCAFUT",29,0)
... S DIC="^PRCD(420.14,",DIC(0)="AEMNQZ",DIC("A")="FUND: ",DIC("B")=FUND
"RTN","PRCAFUT",30,0)
... D ^DIC
"RTN","PRCAFUT",31,0)
... S:+Y<0 FUND=-1 Q
"RTN","PRCAFUT",32,0)
.. S FUND=Y
"RTN","PRCAFUT",33,0)
.. S BBFY=$E($P(Y(0),U,3),3,4),EBFY=$E($P(Y(0),U,4),3,4)
"RTN","PRCAFUT",34,0)
..Q
"RTN","PRCAFUT",35,0)
.S PRCABN(1)=$O(^PRCA(430,+PRCABN,2,0))
"RTN","PRCAFUT",36,0)
.S PRCABN(2)=$G(^PRCA(430,+PRCABN,2,PRCABN(1),0))
"RTN","PRCAFUT",37,0)
.S PRCABN(4)=+$G(PRCABN(2))
"RTN","PRCAFUT",38,0)
.S X=BBFY D ^%DT S PRCABN(3)=$E(Y,1,3)
"RTN","PRCAFUT",39,0)
.K ^PRCA(430,PRCABN,2,PRCABN(1),0)
"RTN","PRCAFUT",40,0)
.K ^PRCA(430,PRCABN,2,"B",PRCABN(4),PRCABN(1))
"RTN","PRCAFUT",41,0)
.S ^PRCA(430,PRCABN,2,PRCABN(3),0)=PRCABN(2)
"RTN","PRCAFUT",42,0)
.S $P(^PRCA(430,PRCABN,2,PRCABN(3),0),"^")=BBFY
"RTN","PRCAFUT",43,0)
.S ^PRCA(430,PRCABN,2,"B",BBFY,PRCABN(3))=""
"RTN","PRCAFUT",44,0)
.D DOCREQ^PRC0C(+FUND,"REV","FTBL")
"RTN","PRCAFUT",45,0)
. I '$D(FTBL) S PRCA("EXIT")=1 D Q
"RTN","PRCAFUT",46,0)
.. W !,*7,"FMS REQUIRED FIELDS missing. Edit the IFCAP REQUIRED FIELDS table",!,"for FUND/FY combination."
"RTN","PRCAFUT",47,0)
.. Q
"RTN","PRCAFUT",48,0)
. S DR="259////^S X=CAT;257////^S X=$G(PRCA(""SITE""));201////^S X=BBFY;202////^S X=$S($G(EBFY)'=BBFY:EBFY,1:"""")"
"RTN","PRCAFUT",49,0)
. D DR
"RTN","PRCAFUT",50,0)
. Q
"RTN","PRCAFUT",51,0)
;Ask Beginning/end budget fiscal year
"RTN","PRCAFUT",52,0)
D FY^PRCAFUT1
"RTN","PRCAFUT",53,0)
I $D(FYERROR) S PRCA("EXIT")=1 Q
"RTN","PRCAFUT",54,0)
;S BGFY=$P(^PRCA(430,PRCABN,0),U,10),BGFY=$$FY^RCFN01(BGFY)
"RTN","PRCAFUT",55,0)
S DR="250;I '$D(CPTBL) D CPTBL^PRCAFUT;259////^S X=CAT;204////^S X=$P(CPTBL,U);206////^S X=$P(CPTBL,U,3)"
"RTN","PRCAFUT",56,0)
S DR=DR_";203////^S X=$P(CPTBL,U,5);201////^S X=$E($P(CPTBL,U,6),3,4)"
"RTN","PRCAFUT",57,0)
S DR(1,430,1)="202////^S X=$S($P(CPTBL,U,7)'=$P(CPTBL,U,6):$E($P(CPTBL,U,7),3,4),1:"""")"
"RTN","PRCAFUT",58,0)
S DR(1,430,2)="261////^S X=$P(CPTBL,U,10)"
"RTN","PRCAFUT",59,0)
S DA=PRCABN D ^DIE K DR
"RTN","PRCAFUT",60,0)
I $D(Y) S PRCA("EXIT")=1 Q
"RTN","PRCAFUT",61,0)
K DR
"RTN","PRCAFUT",62,0)
D FTBL Q:'$D(FTBL)
"RTN","PRCAFUT",63,0)
S (X,PRCABN(1))=$E($P(CPTBL,U,6),3,4)
"RTN","PRCAFUT",64,0)
D ^%DT S PRCABN(2)=$E(Y,1,3)
"RTN","PRCAFUT",65,0)
S PRCABN(3)=$O(^PRCA(430,+PRCABN,2,0))
"RTN","PRCAFUT",66,0)
S PRCABN(4)=$G(^PRCA(430,+PRCABN,2,PRCABN(3),0))
"RTN","PRCAFUT",67,0)
S PRCABN(5)=$E(PRCABN(4),1,2)
"RTN","PRCAFUT",68,0)
K ^PRCA(430,PRCABN,2,PRCABN(3),0)
"RTN","PRCAFUT",69,0)
K ^PRCA(430,PRCABN,2,"B",PRCABN(5),PRCABN(3))
"RTN","PRCAFUT",70,0)
S ^PRCA(430,PRCABN,2,PRCABN(2),0)=PRCABN(4)
"RTN","PRCAFUT",71,0)
S $P(^PRCA(430,PRCABN,2,PRCABN(2),0),"^")=PRCABN(1)
"RTN","PRCAFUT",72,0)
S ^PRCA(430,PRCABN,2,"B",PRCABN(1),PRCABN(2))=""
"RTN","PRCAFUT",73,0)
S $P(^PRCA(430,PRCABN,2,0),"^",3)=PRCABN(2)
"RTN","PRCAFUT",74,0)
Q
"RTN","PRCAFUT",75,0)
FTBL S FUND=$$FUND^PRC0C($P(CPTBL,U,5),$P(CPTBL,U,6))
"RTN","PRCAFUT",76,0)
D DOCREQ^PRC0C(+FUND,"SPE","FTBL")
"RTN","PRCAFUT",77,0)
I '$D(FTBL) W !!,*7,"UNABLE TO GET FMS-LINE FUND ACCOUNTING INFORMATION. CHECK CONTROL POINT." H 5 S PRCA("EXIT")=1 Q
"RTN","PRCAFUT",78,0)
S DR="257////^S X=$G(PRCA(""SITE""))"
"RTN","PRCAFUT",79,0)
DR I $$INTEG^RCFN01($G(PRCA("SITE"))) S DR=DR_";260"
"RTN","PRCAFUT",80,0)
I $G(FTBL("AO"))="Y" S DR=DR_";204"
"RTN","PRCAFUT",81,0)
I $G(FTBL("FCPRJ"))="Y" S DR=DR_";I '$D(CPTBL) D CPTBL^PRCAFUT;206////^S X=$P(CPTBL,U,3)"
"RTN","PRCAFUT",82,0)
I $G(FTBL("CC"))="Y" S DR=DR_";251;252////^S X=$G(SCC)"
"RTN","PRCAFUT",83,0)
I $G(FTBL("BOC"))="Y" S DR=DR_";253"
"RTN","PRCAFUT",84,0)
I $G(FTBL("SBOC"))="Y"!(CAT=20) S DR=DR_";254"
"RTN","PRCAFUT",85,0)
I $G(FTBL("JOB"))="Y" S DR=DR_";261"
"RTN","PRCAFUT",86,0)
I $G(FTBL("RC"))="Y" S DR=DR_";263"
"RTN","PRCAFUT",87,0)
I $G(FTBL("REV"))="Y" D DIE Q:$G(PRCA("EXIT")) D REV Q:$G(PRCA("EXIT"))
"RTN","PRCAFUT",88,0)
I $G(FTBL("SREV"))="Y" S DR=$S(DR="":"256",1:DR_";256")
"RTN","PRCAFUT",89,0)
I $G(FTBL("OC"))="Y" S DR=$S(DR="":"205",1:DR_";205")
"RTN","PRCAFUT",90,0)
I DR'="" D DIE
"RTN","PRCAFUT",91,0)
Q
"RTN","PRCAFUT",92,0)
DIE S DA=PRCABN,DIE="^PRCA(430," D ^DIE
"RTN","PRCAFUT",93,0)
END I $D(Y) S PRCA("EXIT")=1
"RTN","PRCAFUT",94,0)
K DR Q
"RTN","PRCAFUT",95,0)
;
"RTN","PRCAFUT",96,0)
RECTYP(BN) ;Refund or reimbursement
"RTN","PRCAFUT",97,0)
I '$D(BN),'$D(^PRCA(430,BN,0)) Q -1
"RTN","PRCAFUT",98,0)
Q $P($G(^PRCA(430,BN,11)),U,10)
"RTN","PRCAFUT",99,0)
;
"RTN","PRCAFUT",100,0)
REV ;lookup revenue by calling "C" xref
"RTN","PRCAFUT",101,0)
N DS,DIC,DIBTDH,HELP,I,IAT,OUT,RV,X,Y
"RTN","PRCAFUT",102,0)
S OUT=0,RV=$P($G(^PRCA(430,PRCABN,11)),U,6)
"RTN","PRCAFUT",103,0)
F D Q:OUT
"RTN","PRCAFUT",104,0)
.W !,"REVENUE SOURCE: "_$S(RV'="":RV_"// ",1:"") R X:DTIME
"RTN","PRCAFUT",105,0)
.I $E(X)="?",X?."?" D @($S($L(X)=1:"REVH1",1:"REVH2")) S DIC=347.3,DIC(0)="QE" D ^DIC Q:Y<1 Q
"RTN","PRCAFUT",106,0)
.I $E(X)="^",X?."^" S OUT=1,PRCA("EXIT")=1 Q
"RTN","PRCAFUT",107,0)
.I X="@" W "?? Required" Q
"RTN","PRCAFUT",108,0)
.I X="",RV'="" S OUT=1 Q
"RTN","PRCAFUT",109,0)
.I X="",RV="" W "??" D REVH1 Q
"RTN","PRCAFUT",110,0)
.I $D(^RC(347.3,"B",X)) D Q
"RTN","PRCAFUT",111,0)
..S DS=$P($G(^RC(347.3,+$O(^RC(347.3,"B",X,0)),0)),U,2),IAT=$P(^(0),U,3)
"RTN","PRCAFUT",112,0)
..W " "_DS W:IAT " INACTIVE" D REVDIE
"RTN","PRCAFUT",113,0)
.S DIC="^RC(347.3,",DIC(0)="QE",D="C" D IX^DIC I Y<1 D REVH1 Q
"RTN","PRCAFUT",114,0)
.S X=$P(Y,U,2) D REVDIE
"RTN","PRCAFUT",115,0)
S DR=""
"RTN","PRCAFUT",116,0)
Q
"RTN","PRCAFUT",117,0)
REVDIE S DA=PRCABN,DIE="^PRCA(430,",DR="255///"_X D ^DIE I $G(X)'="" S OUT=1 Q
"RTN","PRCAFUT",118,0)
D REVH1 Q
"RTN","PRCAFUT",119,0)
REVH1 S HELP("DIHELP",1)=$G(^DD(430,255,3)) D MSG^DIALOG("WH","",70,5,"HELP") Q
"RTN","PRCAFUT",120,0)
REVH2 D HELP^DIE(430,"",255,"D","HELP"),MSG^DIALOG("WH","",70,8,"HELP") Q
"RTN","PRCAFUT",121,0)
;
"RTN","PRCAFUT",122,0)
FUND ;get fund
"RTN","PRCAFUT",123,0)
N DIC,Y
"RTN","PRCAFUT",124,0)
S DIC="^PRCD(420.14,",DIC(0)="EMNQZ"
"RTN","PRCAFUT",125,0)
D ^DIC
"RTN","PRCAFUT",126,0)
I $D(DUOUT)!$D(DTOUT) S PRCA("EXIT")=1 Q
"RTN","PRCAFUT",127,0)
Q:+Y<0
"RTN","PRCAFUT",128,0)
S FUND=Y
"RTN","PRCAFUT",129,0)
S BBFY=$E($P(Y(0),U,3),3,4),EBFY=$E($P(Y(0),U,4),3,4)
"RTN","PRCAFUT",130,0)
Q
"RTN","PRCAFUT",131,0)
;
"RTN","PRCAFUT",132,0)
DISPLACC ;display account information
"RTN","PRCAFUT",133,0)
Q:'$D(PRCABN) NEW DIC,L,FR,TO,FLDS,IOP,X
"RTN","PRCAFUT",134,0)
R !!,"Press <RETURN> to continue: ",X:60
"RTN","PRCAFUT",135,0)
I X["^" S PRCA("EXIT")="" Q
"RTN","PRCAFUT",136,0)
S IOP=IO(0),DIC="^PRCA(430,",FLDS="[PRCA DISP AUDIT2]",(FR,TO)=PRCABN,L=0,BY="@NUMBER" D EN1^DIP
"RTN","PRCAFUT",137,0)
Q
"RTN","PRCAFUT",138,0)
;
"RTN","PRCAFUT",139,0)
CP ;lookup control point
"RTN","PRCAFUT",140,0)
N DIC
"RTN","PRCAFUT",141,0)
S DIC="^PRC(420,"_$S($D(PRCA("SITE")):PRCA("SITE"),1:$$SITE^RCMSITE)_",1,",DIC(0)="EMNQ",X=CP
"RTN","PRCAFUT",142,0)
D ^DIC
"RTN","PRCAFUT",143,0)
I +Y<0 K X,CP Q
"RTN","PRCAFUT",144,0)
S CP=+Y
"RTN","PRCAFUT",145,0)
Q
"RTN","PRCAFUT",146,0)
;
"RTN","PRCAFUT",147,0)
CC ;cost center
"RTN","PRCAFUT",148,0)
G CC^PRCAFBDU
"RTN","PRCAFUT",149,0)
;
"RTN","PRCAFUT",150,0)
BOC ;budget object code
"RTN","PRCAFUT",151,0)
G BOC^PRCAFBDU
"RTN","PRCAFUT",152,0)
;
"RTN","PRCAFUT",153,0)
TYPE ;ask if bill is a refund or reimbursement
"RTN","PRCAFUT",154,0)
W !!,"Building FMS Accounting Elements...",!
"RTN","PRCAFUT",155,0)
N DIR,Y,TYPE
"RTN","PRCAFUT",156,0)
I +$G(CAT)=1 S CAT="02",CATTYPE=2 D CHKELEM Q
"RTN","PRCAFUT",157,0)
I +$G(CAT)=10 S CAT=50,CATTYPE=2 D CHKELEM Q
"RTN","PRCAFUT",158,0)
I +$G(CAT)=47 S CAT="02" Q
"RTN","PRCAFUT",159,0)
D BDTRANS^PRCAFBDU
"RTN","PRCAFUT",160,0)
Q:$D(PRCA("EXIT"))
"RTN","PRCAFUT",161,0)
S CATTYP=$S(TYPE="01":"1",TYPE="20":"1",1:"2")
"RTN","PRCAFUT",162,0)
S CAT=TYPE ; I CAT>2 S CAT=$S(CAT=4:"20",1:"9")
"RTN","PRCAFUT",163,0)
D CHKELEM
"RTN","PRCAFUT",164,0)
Q
"RTN","PRCAFUT",165,0)
;
"RTN","PRCAFUT",166,0)
CHKELEM ;check for correct accounting line data
"RTN","PRCAFUT",167,0)
N I
"RTN","PRCAFUT",168,0)
Q:'$D(^PRCA(430,PRCABN,11))
"RTN","PRCAFUT",169,0)
I $G(CATTYP)=1 D Q
"RTN","PRCAFUT",170,0)
. F I=6,7 S $P(^PRCA(430,PRCABN,11),U,I)=""
"RTN","PRCAFUT",171,0)
. Q
"RTN","PRCAFUT",172,0)
Q:$G(TYPE)=10
"RTN","PRCAFUT",173,0)
F I=1:1:5,11:1:16,18:1:21 S $P(^PRCA(430,PRCABN,11),U,I)=""
"RTN","PRCAFUT",174,0)
S $P(^PRCA(430,PRCABN,11),U,15)="05"
"RTN","PRCAFUT",175,0)
Q
"RTN","PRCAFUT",176,0)
CPTBL ;build CP table
"RTN","PRCAFUT",177,0)
S:'$D(BGFY) BGFY=$$FY^RCFN01(DT)
"RTN","PRCAFUT",178,0)
S BGFY(1)=$S(BGFY>50:19,1:20)
"RTN","PRCAFUT",179,0)
S CPTBL=$$ACC^PRC0C($G(PRCA("SITE")),+CP_U_BGFY_U_BGFY(1)_BGFY)
"RTN","PRCAFUT",180,0)
I '$D(CPTBL) S CPTBL=""
"RTN","PRCAFUT",181,0)
Q
"RTN","PRCAFUT",182,0)
;
"RTN","PRCAFUT",183,0)
CPHLP ;executable help for cp prompt
"RTN","PRCAFUT",184,0)
N DIC,X,Y
"RTN","PRCAFUT",185,0)
S DIC="^PRC(420,"_$S($D(PRCA("SITE")):PRCA("SITE"),1:$$SITE^RCMSITE)_",1,",DIC(0)="EMQ",X="?" D ^DIC
"RTN","PRCAFUT",186,0)
Q
"RTN","PRCAFUT",187,0)
;
"RTN","PRCAFUT",188,0)
FND(BILL) ;Get fund for a bill
"RTN","PRCAFUT",189,0)
I '$D(^PRCA(430,BILL,0)) Q -1
"RTN","PRCAFUT",190,0)
I $D(^PRCA(430,BILL,11)),$P(^(11),"^",17)'="" Q $P(^(11),"^",17)
"RTN","PRCAFUT",191,0)
I $P(^PRCA(430,BILL,0),"^",18)'="" Q $E($P(^(0),"^",18),4,9)
"RTN","PRCAFUT",192,0)
Q -1
"RTN","PRCAFUT",193,0)
;
"RTN","PRCAP338")
0^^B162416898
"RTN","PRCAP338",1,0)
PRCAP338 ;SAB/Albany - PRCA*4.5*338 POST INSTALL;12/11/17 2:10pm
"RTN","PRCAP338",2,0)
;;4.5;Accounts Receivable;**338**;Mar 20, 1995;Build 70
"RTN","PRCAP338",3,0)
;Per VA Directive 6402, this routine should not be modified.
"RTN","PRCAP338",4,0)
Q
"RTN","PRCAP338",5,0)
;
"RTN","PRCAP338",6,0)
POSTINIT ;Post Install for PRCA*4.5*338
"RTN","PRCAP338",7,0)
D BMES^XPDUTL(" >> Starting the Post-Initialization routine for PRCA*4.5*338 ")
"RTN","PRCAP338",8,0)
; Adding AR CATEGORIES and REVENUE SOURCE CODES
"RTN","PRCAP338",9,0)
D ARCAT
"RTN","PRCAP338",10,0)
D ARCATUPD
"RTN","PRCAP338",11,0)
D CHRGUPD
"RTN","PRCAP338",12,0)
D FND714
"RTN","PRCAP338",13,0)
D APPR714
"RTN","PRCAP338",14,0)
D FNDR1
"RTN","PRCAP338",15,0)
D APPRR1
"RTN","PRCAP338",16,0)
D REVSC
"RTN","PRCAP338",17,0)
D BMES^XPDUTL(" >> End of the Post-Initialization routine for PRCA*4.5*338")
"RTN","PRCAP338",18,0)
Q
"RTN","PRCAP338",19,0)
;
"RTN","PRCAP338",20,0)
ARCAT ;AR CATEGORY ENTRIES (430.2)
"RTN","PRCAP338",21,0)
N LOOP,FDA,FDAIEN,DATA,CHK
"RTN","PRCAP338",22,0)
;
"RTN","PRCAP338",23,0)
D MES^XPDUTL(" -> Adding new AR CATEGORY entries to file 430.2 ...")
"RTN","PRCAP338",24,0)
; Add new AR categories
"RTN","PRCAP338",25,0)
F LOOP=2:1:38 D
"RTN","PRCAP338",26,0)
. ;Clear the array
"RTN","PRCAP338",27,0)
. K FDA
"RTN","PRCAP338",28,0)
. ;Extract the new AR Category to be added.
"RTN","PRCAP338",29,0)
. S DATA=$T(ARDATA+LOOP)
"RTN","PRCAP338",30,0)
. ;Check to insure that the AR Category doesn't exist already
"RTN","PRCAP338",31,0)
. S CHK="" ; Initialized the check variable
"RTN","PRCAP338",32,0)
. S CHK=$O(^PRCA(430.2,"B",$P(DATA,";",3),""))
"RTN","PRCAP338",33,0)
. Q:CHK'=""
"RTN","PRCAP338",34,0)
. ;Store in array for adding to the file (#430.2).
"RTN","PRCAP338",35,0)
. S FDA(430.2,"+1,",.01)=$P(DATA,";",3) ;AR Category Name
"RTN","PRCAP338",36,0)
. S FDA(430.2,"+1,",1)=$P(DATA,";",4) ;Abbreviation
"RTN","PRCAP338",37,0)
. S FDA(430.2,"+1,",2)=$P(DATA,";",5) ;Segment
"RTN","PRCAP338",38,0)
. S FDA(430.2,"+1,",3)=$P(DATA,";",6) ;GL #
"RTN","PRCAP338",39,0)
. S FDA(430.2,"+1,",5)=$P(DATA,";",7) ;Type
"RTN","PRCAP338",40,0)
. S FDA(430.2,"+1,",6)=$P(DATA,";",8) ;Category Number
"RTN","PRCAP338",41,0)
. S FDA(430.2,"+1,",7)=$P(DATA,";",9) ;Receivable Code
"RTN","PRCAP338",42,0)
. S FDA(430.2,"+1,",9)=$P(DATA,";",10) ;Charge Interest
"RTN","PRCAP338",43,0)
. S FDA(430.2,"+1,",10)=$P(DATA,";",11) ;Charge Admin
"RTN","PRCAP338",44,0)
. S FDA(430.2,"+1,",11)=$P(DATA,";",12) ;Charge Penalty
"RTN","PRCAP338",45,0)
. S FDA(430.2,"+1,",12)=$P(DATA,";",13) ;Accrued
"RTN","PRCAP338",46,0)
. S FDA(430.2,"+1,",13)=$P(DATA,";",14) ;Refund/Reimbursement
"RTN","PRCAP338",47,0)
. S FDA(430.2,"+1,",14)=$P(DATA,";",15) ;Paragraph Codes
"RTN","PRCAP338",48,0)
. ;Add to the file.
"RTN","PRCAP338",49,0)
. D UPDATE^DIE(,"FDA","FDAIEN")
"RTN","PRCAP338",50,0)
. S FDAIEN=FDAIEN(1) K FDAIEN(1)
"RTN","PRCAP338",51,0)
D MES^XPDUTL(" New AR CATEGORIES added.")
"RTN","PRCAP338",52,0)
Q
"RTN","PRCAP338",53,0)
;
"RTN","PRCAP338",54,0)
ARDATA ; New AR Category data. (Internal data format)
"RTN","PRCAP338",55,0)
;;Category Name;Abbreviation;AMIS Seg #;GL Number;Type;AR Cat #;Receivable Code;Interest;Admin;Penalty;Accrued;Refund;Paragraph Codes
"RTN","PRCAP338",56,0)
;;CHOICE THIRD PARTY;C1;249;1212;T;50;2;0;0;0;1;2;
"RTN","PRCAP338",57,0)
;;CC THIRD PARTY;C2;249;1212;T;51;2;0;0;0;1;2;
"RTN","PRCAP338",58,0)
;;CCN THIRD PARTY;C3;249;1212;T;52;2;0;0;0;1;2;
"RTN","PRCAP338",59,0)
;;CC MTF THIRD PARTY;C4;249;1212;T;53;2;0;0;0;1;2;
"RTN","PRCAP338",60,0)
;;CHOICE NO-FAULT AUTO;C5;247;1212;T;54;2;0;0;0;1;2;
"RTN","PRCAP338",61,0)
;;CHOICE TORT FEASOR;C6;0;1228;T;55;2;0;0;0;1;2;
"RTN","PRCAP338",62,0)
;;CCN WORKERS' COMP;CD;246;1212;T;56;2;0;0;0;1;2;
"RTN","PRCAP338",63,0)
;;CCN NO-FAULT AUTO;CB;247;1212;T;57;2;0;0;0;1;2;
"RTN","PRCAP338",64,0)
;;CCN TORT FEASOR;CC;0;1228;T;58;2;0;0;0;1;2;
"RTN","PRCAP338",65,0)
;;CC WORKERS' COMP;CA;246;1212;T;59;2;0;0;0;1;2;
"RTN","PRCAP338",66,0)
;;CC NO-FAULT AUTO;C8;247;1212;T;60;2;0;0;0;1;2;
"RTN","PRCAP338",67,0)
;;CC TORT FEASOR;C9;0;1228;T;61;2;0;0;0;1;2;
"RTN","PRCAP338",68,0)
;;CHOICE WORKERS' COMP;C7;246;1212;T;62;2;0;0;0;1;2;
"RTN","PRCAP338",69,0)
;;CHOICE INPT;CF;240;1221;P;63;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
"RTN","PRCAP338",70,0)
;;CHOICE RX CO-PAYMENT;CG;294;1212;P;64;2;1;1;0;1;2;25,40,55,80,85,50,60,65,70
"RTN","PRCAP338",71,0)
;;CC INPT;CJ;240;1221;P;65;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
"RTN","PRCAP338",72,0)
;;CC RX CO-PAYMENT;CK;294;1212;P;66;2;1;1;0;1;2;25,40,55,80,85,50,60,65,70
"RTN","PRCAP338",73,0)
;;CCN INPT;CO;240;1221;P;67;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
"RTN","PRCAP338",74,0)
;;CCN RX CO-PAYMENT;CQ;294;1212;P;68;2;1;1;0;1;2;25,40,55,80,85,50,60,65,70
"RTN","PRCAP338",75,0)
;;CC MTF INPT;CX;240;1221;P;69;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
"RTN","PRCAP338",76,0)
;;CC MTF RX CO-PAYMENT;CY;294;1212;P;70;2;1;1;0;1;2;25,40,55,80,85,50,60,65,70
"RTN","PRCAP338",77,0)
;;CC NURSING HOME CARE - LTC;CL;0;1319;P;71;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
"RTN","PRCAP338",78,0)
;;CC RESPITE CARE;CN;0;1319;P;72;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
"RTN","PRCAP338",79,0)
;;CCN NURSING HOME CARE - LTC;CR;0;1319;P;73;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
"RTN","PRCAP338",80,0)
;;CCN RESPITE CARE;CU;0;1319;P;74;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
"RTN","PRCAP338",81,0)
;;CHOICE NURSING HOME CARE - LTC;CH;0;1319;P;75;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
"RTN","PRCAP338",82,0)
;;CHOICE RESPITE CARE;CI;0;1319;P;76;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
"RTN","PRCAP338",83,0)
;;TRICARE DES;T4;0;1311;T;77;2;0;0;0;0;2
"RTN","PRCAP338",84,0)
;;TRICARE SCI;T5;0;1311;T;78;2;0;0;0;0;2
"RTN","PRCAP338",85,0)
;;TRICARE TBI;T6;0;1311;T;79;2;0;0;0;0;2
"RTN","PRCAP338",86,0)
;;TRICARE BLIND REHABILITATION;T7;0;1311;T;80;2;0;0;0;0;2
"RTN","PRCAP338",87,0)
;;TRICARE DENTAL;T8;0;1311;T;81;2;0;0;0;0;2
"RTN","PRCAP338",88,0)
;;TRICARE PHARMACY;T9;0;1311;T;82;2;0;0;0;0;2
"RTN","PRCAP338",89,0)
;;CHOICE OPT;CZ;240;1221;P;83;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
"RTN","PRCAP338",90,0)
;;CC OPT;D1;240;1221;P;84;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
"RTN","PRCAP338",91,0)
;;CCN OPT;D2;240;1221;P;85;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
"RTN","PRCAP338",92,0)
;;CC MTF OPT;D3;240;1221;P;86;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
"RTN","PRCAP338",93,0)
;;END
"RTN","PRCAP338",94,0)
;
"RTN","PRCAP338",95,0)
ARCATUPD ; AR CATEGORY ENTRIES (430.2)
"RTN","PRCAP338",96,0)
N LOOP,LIEN,PRCAARY,PRCADATA,PRCAARCT
"RTN","PRCAP338",97,0)
N PRCADMC,PRCATOP,PRCACS
"RTN","PRCAP338",98,0)
N X,Y,DIE,DA,DR,DTOUT,DATA
"RTN","PRCAP338",99,0)
;
"RTN","PRCAP338",100,0)
D MES^XPDUTL(" -> Adding data to the new AR CATEGORY (430.2) fields ...")
"RTN","PRCAP338",101,0)
;Clear the array
"RTN","PRCAP338",102,0)
K PRCAARY
"RTN","PRCAP338",103,0)
; Grab all of the entries to update
"RTN","PRCAP338",104,0)
F LOOP=2:1 S PRCADATA=$T(ARUPDDAT+LOOP) Q:PRCADATA=" ;;END" D
"RTN","PRCAP338",105,0)
. ;Extract the new AR Category to be added.
"RTN","PRCAP338",106,0)
. S PRCAARCT=$P(PRCADATA,";",4)
"RTN","PRCAP338",107,0)
. ;Store in array for adding to the file (#430.2).
"RTN","PRCAP338",108,0)
. S PRCAARY(PRCAARCT)=$P(PRCADATA,";",5,7)
"RTN","PRCAP338",109,0)
;
"RTN","PRCAP338",110,0)
;Loop through all of the entries in the AC xref of the 430.2 file, and update using the built array
"RTN","PRCAP338",111,0)
F LOOP=1:1:86 D
"RTN","PRCAP338",112,0)
. S DATA=$G(PRCAARY(LOOP))
"RTN","PRCAP338",113,0)
. Q:DATA="" ;go to next entry if Category is not to be updated.
"RTN","PRCAP338",114,0)
. S LIEN=$O(^PRCA(430.2,"AC",LOOP,""))
"RTN","PRCAP338",115,0)
. Q:LIEN=""
"RTN","PRCAP338",116,0)
. S PRCADMC=$P(DATA,";",1)
"RTN","PRCAP338",117,0)
. S PRCATOP=$P(DATA,";",2)
"RTN","PRCAP338",118,0)
. S PRCACS=$P(DATA,";",3)
"RTN","PRCAP338",119,0)
. ;
"RTN","PRCAP338",120,0)
. ; File the update
"RTN","PRCAP338",121,0)
. S DR="1.01////"_PRCADMC_";"
"RTN","PRCAP338",122,0)
. S DR=DR_"1.02////"_PRCATOP_";"
"RTN","PRCAP338",123,0)
. S DR=DR_"1.03////"_PRCACS_";"
"RTN","PRCAP338",124,0)
. Q:DR=""
"RTN","PRCAP338",125,0)
. S DIE="^PRCA(430.2,",DA=LIEN
"RTN","PRCAP338",126,0)
. D ^DIE
"RTN","PRCAP338",127,0)
. K DR ;Clear update array before next use
"RTN","PRCAP338",128,0)
;
"RTN","PRCAP338",129,0)
S DR=""
"RTN","PRCAP338",130,0)
D MES^XPDUTL(" Data added to the new AR CATEGORY (430.2) fields.")
"RTN","PRCAP338",131,0)
Q
"RTN","PRCAP338",132,0)
;
"RTN","PRCAP338",133,0)
ARUPDDAT ; Data for the new AR Category fields. (All categories will be updated)
"RTN","PRCAP338",134,0)
;;Category Name;Category Num;DMC?;TOP?;CS?
"RTN","PRCAP338",135,0)
;;ADULT DAY HEALTH CARE;40;1;2;3
"RTN","PRCAP338",136,0)
;;C (MEANS TEST);24;1;2;3
"RTN","PRCAP338",137,0)
;;CHAMPVA;36;0;0;0
"RTN","PRCAP338",138,0)
;;CHAMPVA SUBSISTENCE;34;0;0;0
"RTN","PRCAP338",139,0)
;;CHAMPVA THIRD PARTY;35;0;0;0
"RTN","PRCAP338",140,0)
;;COMP & PEN PROCEEDS;8;0;0;0
"RTN","PRCAP338",141,0)
;;CRIME OF PER.VIO.;27;0;0;0
"RTN","PRCAP338",142,0)
;;CURRENT EMP.;14;0;1;0
"RTN","PRCAP338",143,0)
;;CWT PROCEEDS;7;0;0;0
"RTN","PRCAP338",144,0)
;;DOMICILIARY;41;1;2;3
"RTN","PRCAP338",145,0)
;;EMERGENCY/HUMANITARIAN;25;0;1;0
"RTN","PRCAP338",146,0)
;;EMERGENCY/HUMANITARIAN REIMB.;48;0;0;0
"RTN","PRCAP338",147,0)
;;ENHANCED USE LEASE PROCEEDS;10;0;1;0
"RTN","PRCAP338",148,0)
;;EX-EMPLOYEE;13;0;1;0
"RTN","PRCAP338",149,0)
;;FEDERAL AGENCIES-REFUND;15;0;0;0
"RTN","PRCAP338",150,0)
;;FEDERAL AGENCIES-REIMB.;16;0;0;0
"RTN","PRCAP338",151,0)
;;FEE REIMB INS;47;0;0;0
"RTN","PRCAP338",152,0)
;;GERIATRIC EVAL-INSTITUTIONAL;44;1;2;3
"RTN","PRCAP338",153,0)
;;GERIATRIC EVAL-NON-INSTITUTION;45;1;2;3
"RTN","PRCAP338",154,0)
;;HOSPITAL CARE (NSC);1;1;2;3
"RTN","PRCAP338",155,0)
;;HOSPITAL CARE PER DIEM;32;1;2;3
"RTN","PRCAP338",156,0)
;;INELIGIBLE HOSP.;20;0;1;0
"RTN","PRCAP338",157,0)
;;INELIGIBLE HOSP. REIMB.;49;0;0;0
"RTN","PRCAP338",158,0)
;;INTERAGENCY;19;0;0;0
"RTN","PRCAP338",159,0)
;;MEDICARE;28;0;0;0
"RTN","PRCAP338",160,0)
;;MILITARY;17;0;0;0
"RTN","PRCAP338",161,0)
;;NO-FAULT AUTO ACC.;26;0;0;0
"RTN","PRCAP338",162,0)
;;NURSING HOME CARE PER DIEM;31;1;2;3
"RTN","PRCAP338",163,0)
;;NURSING HOME CARE(NSC);3;1;2;3
"RTN","PRCAP338",164,0)
;;NURSING HOME CARE-LTC;46;1;2;3
"RTN","PRCAP338",165,0)
;;NURSING HOME PROCEEDS;5;1;2;3
"RTN","PRCAP338",166,0)
;;OUTPATIENT CARE(NSC);2;1;2;3
"RTN","PRCAP338",167,0)
;;PARKING FEES;6;0;1;0
"RTN","PRCAP338",168,0)
;;PREPAYMENT;33;0;0;0
"RTN","PRCAP338",169,0)
;;REIMBURS.HEALTH INS;21;0;0;0
"RTN","PRCAP338",170,0)
;;RESPITE CARE-INSTITUTIONAL;42;1;2;3
"RTN","PRCAP338",171,0)
;;RESPITE CARE-NON-INSTITUTIONAL;43;1;2;3
"RTN","PRCAP338",172,0)
;;RX CO-PAYMENT/NSC VET;30;1;2;3
"RTN","PRCAP338",173,0)
;;RX CO-PAYMENT/SC VET;29;1;2;3
"RTN","PRCAP338",174,0)
;;SHARING AGREEMENTS;18;0;1;0
"RTN","PRCAP338",175,0)
;;TORT FEASOR;22;0;0;0
"RTN","PRCAP338",176,0)
;;TRICARE;37;0;0;0
"RTN","PRCAP338",177,0)
;;TRICARE PATIENT;38;1;2;3
"RTN","PRCAP338",178,0)
;;TRICARE THIRD PARTY;39;0;0;0
"RTN","PRCAP338",179,0)
;;VENDOR;11;0;1;0
"RTN","PRCAP338",180,0)
;;WORKMAN'S COMP.;23;0;0;0
"RTN","PRCAP338",181,0)
;;CHOICE THIRD PARTY;50;0;0;0
"RTN","PRCAP338",182,0)
;;CC THIRD PARTY;51;0;0;0
"RTN","PRCAP338",183,0)
;;CCN THIRD PARTY;52;0;0;0
"RTN","PRCAP338",184,0)
;;CC MTF THIRD PARTY;53;0;0;0
"RTN","PRCAP338",185,0)
;;CHOICE NO-FAULT AUTO;54;0;0;0
"RTN","PRCAP338",186,0)
;;CHOICE TORT FEASOR;55;0;0;0
"RTN","PRCAP338",187,0)
;;CCN WORKERS' COMP;56;0;0;0
"RTN","PRCAP338",188,0)
;;CCN NO-FAULT AUTO;57;0;0;0
"RTN","PRCAP338",189,0)
;;CCN TORT FEASOR;58;0;0;0
"RTN","PRCAP338",190,0)
;;CC WORKERS' COMP;59;0;0;0
"RTN","PRCAP338",191,0)
;;CC NO-FAULT AUTO;60;0;0;0
"RTN","PRCAP338",192,0)
;;CC TORT FEASOR;61;0;0;0
"RTN","PRCAP338",193,0)
;;CHOICE WORKERS' COMP;62;0;0;0
"RTN","PRCAP338",194,0)
;;CHOICE C (MEANS TEST);63;1;2;3
"RTN","PRCAP338",195,0)
;;CHOICE RX CO-PAYMENT;64;1;2;3
"RTN","PRCAP338",196,0)
;;CC C (MEANS TEST);65;1;2;3
"RTN","PRCAP338",197,0)
;;CC RX CO-PAYMENT;66;1;2;3
"RTN","PRCAP338",198,0)
;;CCN C (MEANS TEST);67;1;2;3
"RTN","PRCAP338",199,0)
;;CCN RX CO-PAYMENT;68;1;2;3
"RTN","PRCAP338",200,0)
;;CC MTF C (MEANS TEST);69;1;2;3
"RTN","PRCAP338",201,0)
;;CC MTF RX CO-PAYMENT;70;1;2;3
"RTN","PRCAP338",202,0)
;;CC NURSING HOME CARE - LTC;71;1;2;3
"RTN","PRCAP338",203,0)
;;CC RESPITE CARE;72;1;2;3
"RTN","PRCAP338",204,0)
;;CCN NURSING HOME CARE - LTC;73;1;2;3
"RTN","PRCAP338",205,0)
;;CCN RESPITE CARE;74;1;2;3
"RTN","PRCAP338",206,0)
;;CHOICE NURSING HOME CARE - LTC;75;1;2;3
"RTN","PRCAP338",207,0)
;;CHOICE RESPITE CARE;76;1;2;3
"RTN","PRCAP338",208,0)
;;TRICARE DES;77;0;0;0
"RTN","PRCAP338",209,0)
;;TRICARE SCI;78;0;0;0
"RTN","PRCAP338",210,0)
;;TRICARE TBI;79;0;0;0
"RTN","PRCAP338",211,0)
;;TRICARE BLIND REHABILITATION;80;0;0;0
"RTN","PRCAP338",212,0)
;;TRICARE DENTAL;81;0;0;0
"RTN","PRCAP338",213,0)
;;TRICARE PHARMACY;82;0;0;0
"RTN","PRCAP338",214,0)
;;CHOICE OPT;83;1;2;3
"RTN","PRCAP338",215,0)
;;CC OPT;84;1;2;3
"RTN","PRCAP338",216,0)
;;CCN OPT;85;1;2;3
"RTN","PRCAP338",217,0)
;;CC MTF OPT;86;1;2;3
"RTN","PRCAP338",218,0)
;;END
"RTN","PRCAP338",219,0)
;
"RTN","PRCAP338",220,0)
CHRGUPD ; Update the charge flags
"RTN","PRCAP338",221,0)
N RCLOOP,RCIEN,RCDATA,RCINT,RCADMIN,RCPEN,RCCAT
"RTN","PRCAP338",222,0)
N X,Y,DIE,DA,DR,DTOUT
"RTN","PRCAP338",223,0)
;
"RTN","PRCAP338",224,0)
D MES^XPDUTL(" -> Updating Charge flags in select AR CATEGORY (430.2) entries ...")
"RTN","PRCAP338",225,0)
;Clear the array
"RTN","PRCAP338",226,0)
K PRCAARY
"RTN","PRCAP338",227,0)
; Grab all of the entries to update
"RTN","PRCAP338",228,0)
F RCLOOP=1:1 S RCDATA=$T(CUPDDT+RCLOOP) Q:RCDATA=" ;;END" D
"RTN","PRCAP338",229,0)
. S RCCAT=$P(RCDATA,";",4)
"RTN","PRCAP338",230,0)
. S RCIEN=$O(^PRCA(430.2,"AC",RCCAT,""))
"RTN","PRCAP338",231,0)
. Q:RCIEN=""
"RTN","PRCAP338",232,0)
. S RCINT=$P(RCDATA,";",5)
"RTN","PRCAP338",233,0)
. S RCADMIN=$P(RCDATA,";",6)
"RTN","PRCAP338",234,0)
. S RCPEN=$P(RCDATA,";",7)
"RTN","PRCAP338",235,0)
. ;
"RTN","PRCAP338",236,0)
. ; File the update
"RTN","PRCAP338",237,0)
. S DR="9////"_RCINT_";"
"RTN","PRCAP338",238,0)
. S DR=DR_"10////"_RCADMIN_";"
"RTN","PRCAP338",239,0)
. S DR=DR_"11////"_RCPEN_";"
"RTN","PRCAP338",240,0)
. Q:DR=""
"RTN","PRCAP338",241,0)
. S DIE="^PRCA(430.2,",DA=RCIEN
"RTN","PRCAP338",242,0)
. D ^DIE
"RTN","PRCAP338",243,0)
. K DR ;Clear update array before next use
"RTN","PRCAP338",244,0)
;
"RTN","PRCAP338",245,0)
S DR=""
"RTN","PRCAP338",246,0)
D MES^XPDUTL(" Charge Flags in select AR CATEGORY (430.2) entries.")
"RTN","PRCAP338",247,0)
Q
"RTN","PRCAP338",248,0)
;
"RTN","PRCAP338",249,0)
CUPDDT ; Charge flag update data
"RTN","PRCAP338",250,0)
;;ADULT DAY HEALTH CARE;40;1;1;0
"RTN","PRCAP338",251,0)
;;COMP & PEN PROCEEDS;8;0;0;0
"RTN","PRCAP338",252,0)
;;CRIME OF PER.VIO.;27;0;0;0
"RTN","PRCAP338",253,0)
;;CWT PROCEEDS;7;0;0;0
"RTN","PRCAP338",254,0)
;;DOMICILIARY;41;1;1;0
"RTN","PRCAP338",255,0)
;;GERIATRIC EVAL-INSTITUTIONAL;44;1;1;0
"RTN","PRCAP338",256,0)
;;GERIATRIC EVAL-NON-INSTITUTION;45;1;1;0
"RTN","PRCAP338",257,0)
;;NO-FAULT AUTO ACC.;26;0;0;0
"RTN","PRCAP338",258,0)
;;NURSING HOME CARE-LTC;46;1;1;0
"RTN","PRCAP338",259,0)
;;NURSING HOME PROCEEDS;5;0;0;0
"RTN","PRCAP338",260,0)
;;RESPITE CARE-INSTITUTIONAL;42;1;1;0
"RTN","PRCAP338",261,0)
;;RESPITE CARE-NON-INSTITUTIONAL;43;1;1;0
"RTN","PRCAP338",262,0)
;;TORT FEASOR;22;0;0;0
"RTN","PRCAP338",263,0)
;;END
"RTN","PRCAP338",264,0)
ENV ;environment check
"RTN","PRCAP338",265,0)
S XPDABORT="" ;Package level variable. Don't New
"RTN","PRCAP338",266,0)
D DBCHK(.XPDABORT) ;checks for fund existence
"RTN","PRCAP338",267,0)
I XPDABORT="" K XPDABORT
"RTN","PRCAP338",268,0)
Q
"RTN","PRCAP338",269,0)
;
"RTN","PRCAP338",270,0)
DBCHK(XPDABORT) ;checks for test/production account
"RTN","PRCAP338",271,0)
N RCMISS,RCIEN
"RTN","PRCAP338",272,0)
;
"RTN","PRCAP338",273,0)
S RCMISS=0 ; Set the missing flag to False (No Funds missing)
"RTN","PRCAP338",274,0)
;
"RTN","PRCAP338",275,0)
; check to see if 0160R1 is properly defined
"RTN","PRCAP338",276,0)
S RCIEN=$O(^PRCD(420.3,"B","0160R1","")) S:'RCIEN RCMISS=1
"RTN","PRCAP338",277,0)
S RCIEN=$O(^PRCD(420.14,"B","0160R1","")) S:'RCIEN RCMISS=1
"RTN","PRCAP338",278,0)
;
"RTN","PRCAP338",279,0)
; If not defined properly (RCMISS=1) warn user and abort the installation.
"RTN","PRCAP338",280,0)
I RCMISS DO
"RTN","PRCAP338",281,0)
. D BMES^XPDUTL("******")
"RTN","PRCAP338",282,0)
. D MES^XPDUTL("The new 0160R1 fund has not been fully defined for this facility.")
"RTN","PRCAP338",283,0)
. D MES^XPDUTL("This facility is not yet ready for the installation of PRCA*4.5*338.")
"RTN","PRCAP338",284,0)
. D MES^XPDUTL("Installation aborted.")
"RTN","PRCAP338",285,0)
. D MES^XPDUTL("******")
"RTN","PRCAP338",286,0)
. S XPDABORT=2
"RTN","PRCAP338",287,0)
Q
"RTN","PRCAP338",288,0)
;
"RTN","PRCAP338",289,0)
FND714 ;PRCD FUND entry 528714 in 420.14
"RTN","PRCAP338",290,0)
N DA,DIC,DIK,DLAYGO,FUND,X,Y
"RTN","PRCAP338",291,0)
D MES^XPDUTL(" -> Adding new PRCD FUND entry 528714 to file 420.14 ...")
"RTN","PRCAP338",292,0)
S DIC="^PRCD(420.14,",DIC(0)="L",DLAYGO=420.14,FUND=528714
"RTN","PRCAP338",293,0)
; if the entry is in the file, delete it first to add fields uneditable
"RTN","PRCAP338",294,0)
S X=FUND D ^DIC I +Y>0 S DA=+Y,DIK="^PRCD(420.14," D ^DIK
"RTN","PRCAP338",295,0)
; add entry
"RTN","PRCAP338",296,0)
S X=FUND
"RTN","PRCAP338",297,0)
S DIC("DR")="1////MCCF-FEE-COLL FUND-1ST PARTY;"
"RTN","PRCAP338",298,0)
S DIC("DR")=DIC("DR")_"2///2018;"
"RTN","PRCAP338",299,0)
S DIC("DR")=DIC("DR")_"3///2018;"
"RTN","PRCAP338",300,0)
S DIC("DR")=DIC("DR")_"4.7///NET;"
"RTN","PRCAP338",301,0)
S DIC("DR")=DIC("DR")_"5///A;"
"RTN","PRCAP338",302,0)
S DIC("DR")=DIC("DR")_"4.5///N;"
"RTN","PRCAP338",303,0)
D FILE^DICN
"RTN","PRCAP338",304,0)
D MES^XPDUTL(" PRCD FUND completed.")
"RTN","PRCAP338",305,0)
Q
"RTN","PRCAP338",306,0)
;
"RTN","PRCAP338",307,0)
APPR714 ;PRCD FUND/APPROPRIATION CODE entry 528714 in 420.3
"RTN","PRCAP338",308,0)
N DA,DIC,DIE,DIK,DINUM,DLAYGO,DR,RCDATA,RCDINUM,X,Y
"RTN","PRCAP338",309,0)
D MES^XPDUTL(" -> Adding new PRCD FUND/APPROPRIATION CODE entry 528714 to file 420.3 ...")
"RTN","PRCAP338",310,0)
; install entries in file 420.3
"RTN","PRCAP338",311,0)
S FUND=528714,DIC="^PRCD(420.3,",DIC(0)="L",DLAYGO=420.3
"RTN","PRCAP338",312,0)
; if the entry is in the file, delete it first to add fields uneditable
"RTN","PRCAP338",313,0)
S X=FUND D ^DIC I +Y>0 S DA=+Y,DIK="^PRCD(420.3," D ^DIK
"RTN","PRCAP338",314,0)
; add entry
"RTN","PRCAP338",315,0)
S X=FUND
"RTN","PRCAP338",316,0)
S DIC("DR")="2////36_5287.14;"
"RTN","PRCAP338",317,0)
S DIC("DR")=DIC("DR")_"4///36_5287.14;"
"RTN","PRCAP338",318,0)
S DIC("DR")=DIC("DR")_"6///528714;"
"RTN","PRCAP338",319,0)
S DIC("DR")=DIC("DR")_"7///Y;"
"RTN","PRCAP338",320,0)
D FILE^DICN
"RTN","PRCAP338",321,0)
D MES^XPDUTL(" PRCD FUND/APPROPRIATION CODE completed.")
"RTN","PRCAP338",322,0)
Q
"RTN","PRCAP338",323,0)
;
"RTN","PRCAP338",324,0)
FNDR1 ;PRCD FUND entry 0160R1 into 420.14
"RTN","PRCAP338",325,0)
N DA,DIC,DIK,DLAYGO,FUND,X,Y
"RTN","PRCAP338",326,0)
D MES^XPDUTL(" -> Adding new PRCD FUND entry 0160R1 to file 420.14 ...")
"RTN","PRCAP338",327,0)
S DIC="^PRCD(420.14,",DIC(0)="L",DLAYGO=420.14,FUND="0160R1"
"RTN","PRCAP338",328,0)
; if the entry is in the file, delete it first to add fields uneditable
"RTN","PRCAP338",329,0)
S X=FUND D ^DIC I +Y>0 S DA=+Y,DIK="^PRCD(420.14," D ^DIK
"RTN","PRCAP338",330,0)
; add entry
"RTN","PRCAP338",331,0)
S X=FUND
"RTN","PRCAP338",332,0)
S DIC("DR")="1////MEDICAL SERVICE - LIM1;"
"RTN","PRCAP338",333,0)
S DIC("DR")=DIC("DR")_"2///2018;"
"RTN","PRCAP338",334,0)
S DIC("DR")=DIC("DR")_"3///2018;"
"RTN","PRCAP338",335,0)
S DIC("DR")=DIC("DR")_"4.7///NET;"
"RTN","PRCAP338",336,0)
S DIC("DR")=DIC("DR")_"5///A;"
"RTN","PRCAP338",337,0)
S DIC("DR")=DIC("DR")_"4.5///Y;"
"RTN","PRCAP338",338,0)
D FILE^DICN
"RTN","PRCAP338",339,0)
D MES^XPDUTL(" PRCD FUND completed.")
"RTN","PRCAP338",340,0)
Q
"RTN","PRCAP338",341,0)
;
"RTN","PRCAP338",342,0)
APPRR1 ;PRCD FUND/APPROPRIATION CODE entry 0160R1 into 420.3
"RTN","PRCAP338",343,0)
N DA,DIC,DIE,DIK,DINUM,DLAYGO,DR,RCDATA,RCDINUM,X,Y
"RTN","PRCAP338",344,0)
D MES^XPDUTL(" -> Adding new PRCD FUND/APPROPRIATION CODE entry 0160R1 to file 420.3 ...")
"RTN","PRCAP338",345,0)
; install entries in file 420.3
"RTN","PRCAP338",346,0)
S FUND="0160R1",DIC="^PRCD(420.3,",DIC(0)="L",DLAYGO=420.3
"RTN","PRCAP338",347,0)
; if the entry is in the file, delete it first to add fields uneditable
"RTN","PRCAP338",348,0)
S X=FUND D ^DIC I +Y>0 S DA=+Y,DIK="^PRCD(420.3," D ^DIK
"RTN","PRCAP338",349,0)
; add entry
"RTN","PRCAP338",350,0)
S X=FUND
"RTN","PRCAP338",351,0)
S DIC("DR")="2////36_0160;"
"RTN","PRCAP338",352,0)
S DIC("DR")=DIC("DR")_"4///36 0160;"
"RTN","PRCAP338",353,0)
S DIC("DR")=DIC("DR")_"6///0160R1;"
"RTN","PRCAP338",354,0)
D FILE^DICN
"RTN","PRCAP338",355,0)
D MES^XPDUTL(" PRCD FUND/APPROPRIATION CODE completed.")
"RTN","PRCAP338",356,0)
Q
"RTN","PRCAP338",357,0)
;
"RTN","PRCAP338",358,0)
REVSC ;REVENUE SOURCE CODE entries in file #347.3
"RTN","PRCAP338",359,0)
N RCLOOP,RSCDATA,DIC,Y,GBL,DA,X,DIE,DR
"RTN","PRCAP338",360,0)
D MES^XPDUTL(" -> Adding new REVENUE SOURCE CODE entries to file 347.3 ...")
"RTN","PRCAP338",361,0)
S GBL="^RC(347.3,"
"RTN","PRCAP338",362,0)
F RCLOOP=1:1 D Q:RSCDATA="END"
"RTN","PRCAP338",363,0)
. S RSCDATA=$P($T(NEWRSC+RCLOOP),";",3,99)
"RTN","PRCAP338",364,0)
. Q:RSCDATA="END"
"RTN","PRCAP338",365,0)
. ; do a lookup and continue if exists.
"RTN","PRCAP338",366,0)
. S DIC=GBL,X=$P(RSCDATA,";",2) D ^DIC
"RTN","PRCAP338",367,0)
. I +Y>0 S DIK=GBL,DA=+Y D ^DIK
"RTN","PRCAP338",368,0)
. ; add entry
"RTN","PRCAP338",369,0)
. S X=$P(RSCDATA,";",2)
"RTN","PRCAP338",370,0)
. S DIC("DR")=".02///"_$P(RSCDATA,";")_";"
"RTN","PRCAP338",371,0)
. S DIC("DR")=DIC("DR")_".03///0;"
"RTN","PRCAP338",372,0)
. D FILE^DICN
"RTN","PRCAP338",373,0)
. I +Y=-1 D
"RTN","PRCAP338",374,0)
. . D MES^XPDUTL(" "_$P(RSCDATA,";")_" failed to add!")
"RTN","PRCAP338",375,0)
D MES^XPDUTL(" REVENUE SOURCE CODES completed.")
"RTN","PRCAP338",376,0)
;
"RTN","PRCAP338",377,0)
NEWRSC ;New Revenue Source Codes (RSC#)
"RTN","PRCAP338",378,0)
;;DOD DISABILITY EVALUATION SYSTEM (DES);8085
"RTN","PRCAP338",379,0)
;;DOD SPINAL CORD INPATIENT;8086
"RTN","PRCAP338",380,0)
;;DOD SPINAL CORD OUTPATIENT;8087
"RTN","PRCAP338",381,0)
;;DOD SPINAL CORD OTHER;8088
"RTN","PRCAP338",382,0)
;;DOD TRAUMATIC BRAIN INJURY INPATIENT;8089
"RTN","PRCAP338",383,0)
;;TRAUMATIC BRAIN INJURY OUTPATIENT;8090
"RTN","PRCAP338",384,0)
;;TRAUMATIC BRAIN INJURY OTHER;8091
"RTN","PRCAP338",385,0)
;;BLIND REHABILITATION INPATIENT;8092
"RTN","PRCAP338",386,0)
;;BLIND REHABILITATION OUTPATIENT;8093
"RTN","PRCAP338",387,0)
;;BLIND REHABILITATION OTHER;8094
"RTN","PRCAP338",388,0)
;;TRICARE PHARMACY;8095
"RTN","PRCAP338",389,0)
;;TRICARE ACTIVE DUTY DENTAL;8096
"RTN","PRCAP338",390,0)
;;END
"RTN","PRCASVC")
0^15^B26611476
"RTN","PRCASVC",1,0)
PRCASVC ;SF-ISC/YJK-ACCEPT, AMMEND AND CANCEL AR BILL ;9/6/95 2:09 PM
"RTN","PRCASVC",2,0)
V ;;4.5;Accounts Receivable;**1,21,48,90,136,138,249,274,315,338**;Mar 20, 1995;Build 70
"RTN","PRCASVC",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","PRCASVC",4,0)
REL ;Accept bill into AR
"RTN","PRCASVC",5,0)
N X,Y
"RTN","PRCASVC",6,0)
D ^PRCASVC6 G:$D(PRCAERR) Q3 S PRCADEBT=$O(^RCD(340,"B",PRCASV("DEBTOR"),0)) I 'PRCADEBT K DD,DO S DIC="^RCD(340,",DIC(0)="QL",X=PRCASV("DEBTOR"),DLAYGO=340 D FILE^DICN K DIC,DLAYGO,DO Q:Y<0 S PRCADEBT=+Y
"RTN","PRCASVC",7,0)
D FY S PRCAT=$P(^PRCA(430.2,PRCASV("CAT"),0),"^",6) F Y="IDNO^4","GPNO^6","GPNM^5","INPA^1" S:$D(PRCASV($P(Y,"^"))) $P(^PRCA(430,PRCASV("ARREC"),202),"^",$P(Y,"^",2))=PRCASV($P(Y,"^"))
"RTN","PRCASVC",8,0)
S DIE="^PRCA(430,",DR="[PRCASV REL]",DA=PRCASV("ARREC") D ^DIE
"RTN","PRCASVC",9,0)
Q3 K PRCAT,PRCAORA,PRCADEBT,DIE,DR,%
"RTN","PRCASVC",10,0)
; set the fund for the bill (set in routine rcxfmsuf)
"RTN","PRCASVC",11,0)
S:'$G(DA) DA=PRCASV("ARREC") S %=$$GETFUNDB^RCXFMSUF(DA)
"RTN","PRCASVC",12,0)
I "^27^28^"[("^"_PRCASV("CAT")_"^") D
"RTN","PRCASVC",13,0)
.N P
"RTN","PRCASVC",14,0)
.F P=6,8,10,15 S $P(^PRCA(430,DA,11),"^",P)=$S(P=6:1000,P=8:$G(PRCASV("SITE")),P=10:9,1:$P($G(PRCASV("FY")),"^"))
"RTN","PRCASVC",15,0)
.S $P(^PRCA(430,DA,11),"^",18,999)=""
"RTN","PRCASVC",16,0)
I PRCASV("CAT")=27 S $P(^PRCA(430,+PRCASV("ARREC"),0),"^",5)=$O(^PRCA(430.6,"B","CHMPV",0))
"RTN","PRCASVC",17,0)
I PRCASV("CAT")=29 S $P(^PRCA(430,DA,11),"^",18,999)=""
"RTN","PRCASVC",18,0)
;
"RTN","PRCASVC",19,0)
; prca*4.5*274 - for TRICARE claims, set the station# (field# 257) from the PRCASV("SITE") value
"RTN","PRCASVC",20,0)
I "^30^31^32^"[("^"_PRCASV("CAT")_"^") D
"RTN","PRCASVC",21,0)
.N RCCARE,P
"RTN","PRCASVC",22,0)
.S:'$G(PRCASV("SITE")) PRCASV("SITE")=$P($$SITE^VASITE,"^",3)
"RTN","PRCASVC",23,0)
.F P=8,9,10,15 S $P(^PRCA(430,DA,11),"^",P)=$S(P=8:$G(PRCASV("SITE")),P=9:1,P=10:"02",1:$P($G(PRCASV("FY")),"^"))
"RTN","PRCASVC",24,0)
.S $P(^PRCA(430,DA,11),"^",18)=""
"RTN","PRCASVC",25,0)
.S RCCARE=$$TYP^IBRFN(DA),RCCARE(1)=$S(RCCARE="I":8028,RCCARE="O":8029,1:8030),$P(^PRCA(430,DA,11),"^",6)=RCCARE(1)
"RTN","PRCASVC",26,0)
;
"RTN","PRCASVC",27,0)
I PRCASV("CAT")=47 D ;PRCA*4.5*315/BAA
"RTN","PRCASVC",28,0)
.N RCCARE,P
"RTN","PRCASVC",29,0)
.S:'$G(PRCASV("SITE")) PRCASV("SITE")=$P($$SITE^VASITE,"^",3)
"RTN","PRCASVC",30,0)
.F P=8,9,10,15 S $P(^PRCA(430,DA,11),"^",P)=$S(P=8:$G(PRCASV("SITE")),P=9:1,P=10:"02",1:$P($G(PRCASV("FY")),"^"))
"RTN","PRCASVC",31,0)
.S $P(^PRCA(430,DA,11),"^",18)=""
"RTN","PRCASVC",32,0)
.S RCCARE=$$TYP^IBRFN(DA),RCCARE(1)=$S(RCCARE="I":"841Z",RCCARE="O":"842Z",1:"842Z"),$P(^PRCA(430,DA,11),"^",6)=RCCARE(1)
"RTN","PRCASVC",33,0)
;
"RTN","PRCASVC",34,0)
I PRCASV("CAT")=75 D ;PRCA*4.5*338 Tricare DES
"RTN","PRCASVC",35,0)
.N RCCARE,P
"RTN","PRCASVC",36,0)
.S:'$G(PRCASV("SITE")) PRCASV("SITE")=$P($$SITE^VASITE,"^",3)
"RTN","PRCASVC",37,0)
.F P=8,9,10,15 S $P(^PRCA(430,DA,11),"^",P)=$S(P=8:$G(PRCASV("SITE")),P=9:1,P=10:"02",1:$P($G(PRCASV("FY")),"^"))
"RTN","PRCASVC",38,0)
.S $P(^PRCA(430,DA,11),"^",18)=""
"RTN","PRCASVC",39,0)
.S RCCARE=$$TYP^IBRFN(DA),RCCARE(1)="8085",$P(^PRCA(430,DA,11),"^",6)=RCCARE(1)
"RTN","PRCASVC",40,0)
;
"RTN","PRCASVC",41,0)
I PRCASV("CAT")=76 D ;PRCA*4.5*338 Tricare Spinal
"RTN","PRCASVC",42,0)
.N RCCARE,P
"RTN","PRCASVC",43,0)
.S:'$G(PRCASV("SITE")) PRCASV("SITE")=$P($$SITE^VASITE,"^",3)
"RTN","PRCASVC",44,0)
.F P=8,9,10,15 S $P(^PRCA(430,DA,11),"^",P)=$S(P=8:$G(PRCASV("SITE")),P=9:1,P=10:"02",1:$P($G(PRCASV("FY")),"^"))
"RTN","PRCASVC",45,0)
.S $P(^PRCA(430,DA,11),"^",18)=""
"RTN","PRCASVC",46,0)
.S RCCARE=$$TYP^IBRFN(DA),RCCARE(1)=$S(RCCARE="I":"8086",RCCARE="O":"8087",1:"8088"),$P(^PRCA(430,DA,11),"^",6)=RCCARE(1)
"RTN","PRCASVC",47,0)
;
"RTN","PRCASVC",48,0)
I PRCASV("CAT")=77 D ;PRCA*4.5*338 Tricare TBI
"RTN","PRCASVC",49,0)
.N RCCARE,P
"RTN","PRCASVC",50,0)
.S:'$G(PRCASV("SITE")) PRCASV("SITE")=$P($$SITE^VASITE,"^",3)
"RTN","PRCASVC",51,0)
.F P=8,9,10,15 S $P(^PRCA(430,DA,11),"^",P)=$S(P=8:$G(PRCASV("SITE")),P=9:1,P=10:"02",1:$P($G(PRCASV("FY")),"^"))
"RTN","PRCASVC",52,0)
.S $P(^PRCA(430,DA,11),"^",18)=""
"RTN","PRCASVC",53,0)
.S RCCARE=$$TYP^IBRFN(DA),RCCARE(1)=$S(RCCARE="I":"8089",RCCARE="O":"8090",1:"8091"),$P(^PRCA(430,DA,11),"^",6)=RCCARE(1)
"RTN","PRCASVC",54,0)
;
"RTN","PRCASVC",55,0)
I PRCASV("CAT")=78 D ;PRCA*4.5*338 Tricare Blind Rehab
"RTN","PRCASVC",56,0)
.N RCCARE,P
"RTN","PRCASVC",57,0)
.S:'$G(PRCASV("SITE")) PRCASV("SITE")=$P($$SITE^VASITE,"^",3)
"RTN","PRCASVC",58,0)
.F P=8,9,10,15 S $P(^PRCA(430,DA,11),"^",P)=$S(P=8:$G(PRCASV("SITE")),P=9:1,P=10:"02",1:$P($G(PRCASV("FY")),"^"))
"RTN","PRCASVC",59,0)
.S $P(^PRCA(430,DA,11),"^",18)=""
"RTN","PRCASVC",60,0)
.S RCCARE=$$TYP^IBRFN(DA),RCCARE(1)=$S(RCCARE="I":"8092",RCCARE="O":"8093",1:"8094"),$P(^PRCA(430,DA,11),"^",6)=RCCARE(1)
"RTN","PRCASVC",61,0)
;
"RTN","PRCASVC",62,0)
;
"RTN","PRCASVC",63,0)
I PRCASV("CAT")=79 D ;PRCA*4.5*338 Tricare Dental
"RTN","PRCASVC",64,0)
.N RCCARE,P
"RTN","PRCASVC",65,0)
.S:'$G(PRCASV("SITE")) PRCASV("SITE")=$P($$SITE^VASITE,"^",3)
"RTN","PRCASVC",66,0)
.F P=8,9,10,15 S $P(^PRCA(430,DA,11),"^",P)=$S(P=8:$G(PRCASV("SITE")),P=9:1,P=10:"02",1:$P($G(PRCASV("FY")),"^"))
"RTN","PRCASVC",67,0)
.S $P(^PRCA(430,DA,11),"^",18)=""
"RTN","PRCASVC",68,0)
.S RCCARE=$$TYP^IBRFN(DA),RCCARE(1)="8096",$P(^PRCA(430,DA,11),"^",6)=RCCARE(1)
"RTN","PRCASVC",69,0)
;
"RTN","PRCASVC",70,0)
I PRCASV("CAT")=80 D ;PRCA*4.5*338 Tricare Pharmacy
"RTN","PRCASVC",71,0)
.N RCCARE,P
"RTN","PRCASVC",72,0)
.S:'$G(PRCASV("SITE")) PRCASV("SITE")=$P($$SITE^VASITE,"^",3)
"RTN","PRCASVC",73,0)
.F P=8,9,10,15 S $P(^PRCA(430,DA,11),"^",P)=$S(P=8:$G(PRCASV("SITE")),P=9:1,P=10:"02",1:$P($G(PRCASV("FY")),"^"))
"RTN","PRCASVC",74,0)
.S $P(^PRCA(430,DA,11),"^",18)=""
"RTN","PRCASVC",75,0)
.S RCCARE=$$TYP^IBRFN(DA),RCCARE(1)="8095",$P(^PRCA(430,DA,11),"^",6)=RCCARE(1)
"RTN","PRCASVC",76,0)
I $G(PRCASV("MEDCA"))!$G(PRCASV("MEDURE")) D MEDICARE
"RTN","PRCASVC",77,0)
K DA
"RTN","PRCASVC",78,0)
Q
"RTN","PRCASVC",79,0)
;
"RTN","PRCASVC",80,0)
;
"RTN","PRCASVC",81,0)
FY K:$D(^PRCA(430,PRCASV("ARREC"),2)) ^(2) S PRCAK1=1,PRCAORA=0,^PRCA(430,PRCASV("ARREC"),2,0)="^430.01IA^^"
"RTN","PRCASVC",82,0)
F J=1:1 S X=$P(PRCASV("FY"),U,PRCAK1),PRCAMT=+$P(PRCASV("FY"),U,PRCAK1+1) D FY1 S PRCAK1=PRCAK1+2 Q:$P(PRCASV("FY"),U,PRCAK1)=""
"RTN","PRCASVC",83,0)
EXITFY K PRCAK1,J,PRCAMT Q
"RTN","PRCASVC",84,0)
FY1 S DA(1)=PRCASV("ARREC"),DIC="^PRCA(430,"_DA(1)_",2,",DIC(0)="QL",DLAYGO=430 D ^DIC K DIC,DLAYGO Q:Y<0 S DA=+Y
"RTN","PRCASVC",85,0)
S PRCAORA=PRCAORA+PRCAMT,$P(^PRCA(430,PRCASV("ARREC"),0),"^",3)=PRCAORA,$P(^(7),"^")=PRCAORA,$P(^(2,DA,0),U,2)=PRCAMT,$P(^(0),"^",8)=PRCAMT
"RTN","PRCASVC",86,0)
K DA Q
"RTN","PRCASVC",87,0)
;
"RTN","PRCASVC",88,0)
MEDICARE ;Setup Medicare Supplemental amounts
"RTN","PRCASVC",89,0)
N DR,DIE
"RTN","PRCASVC",90,0)
I $G(PRCASV("MEDCA")) S DIE="^PRCA(430,",DR="131////"_PRCASV("MEDCA") D ^DIE
"RTN","PRCASVC",91,0)
I $G(PRCASV("MEDURE")) S DIE="^PRCA(430,",DR="132////"_PRCASV("MEDURE") D ^DIE
"RTN","PRCASVC",92,0)
K PRCASV("MEDCA"),PRCASV("MEDURE")
"RTN","PRCASVC",93,0)
Q ;MEDICARE
"RTN","PRCASVC",94,0)
;
"RTN","RCBEADJ")
0^3^B106126105
"RTN","RCBEADJ",1,0)
RCBEADJ ;WISC/RFJ-adjustment ;Jun 06, 2014@19:11:19
"RTN","RCBEADJ",2,0)
;;4.5;Accounts Receivable;**169,172,204,173,208,233,298,301,315,326,338**;Mar 20, 1995;Build 70
"RTN","RCBEADJ",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCBEADJ",4,0)
Q
"RTN","RCBEADJ",5,0)
;
"RTN","RCBEADJ",6,0)
;
"RTN","RCBEADJ",7,0)
DECREASE ; menu option: create a decrease adjustment
"RTN","RCBEADJ",8,0)
D ADJUST("DECREASE")
"RTN","RCBEADJ",9,0)
Q
"RTN","RCBEADJ",10,0)
;
"RTN","RCBEADJ",11,0)
;
"RTN","RCBEADJ",12,0)
INCREASE ; menu option: create an increase adjustment
"RTN","RCBEADJ",13,0)
D ADJUST("INCREASE")
"RTN","RCBEADJ",14,0)
Q
"RTN","RCBEADJ",15,0)
;
"RTN","RCBEADJ",16,0)
ADJUST(RCBETYPE,RCEDI) ; create an adjustment
"RTN","RCBEADJ",17,0)
; rcbetype = INCREASE for increase or DECREASE for decrease
"RTN","RCBEADJ",18,0)
; rcedi = the ien of the bill selected via the EDI Worklist;ien of
"RTN","RCBEADJ",19,0)
; XX the ERA entry or null/undefined if bill should be selected
"RTN","RCBEADJ",20,0)
I '$G(GOTBILL) N RCBILLDA ;PRCA*4.5*315 If entering from worklist
"RTN","RCBEADJ",21,0)
F D Q:RCBILLDA<0!$G(RCEDI)!$G(GOTBILL)
"RTN","RCBEADJ",22,0)
. K RCTRANDA,RCLIST,RCTRREV
"RTN","RCBEADJ",23,0)
. ;
"RTN","RCBEADJ",24,0)
. ; select a bill
"RTN","RCBEADJ",25,0)
. I '$G(GOTBILL) S RCBILLDA=$S('$G(RCEDI):$$GETABILL^RCBEUBIL,1:+RCEDI) ;PRCA*4.5*315
"RTN","RCBEADJ",26,0)
. I RCBILLDA<1 Q
"RTN","RCBEADJ",27,0)
. I $D(^PRCA(430,"TCSP",RCBILLDA)),(RCBETYPE="INCREASE") D ;PRCA*4.5*315/DRF
"RTN","RCBEADJ",28,0)
.. S RCTRREV=$$ASKREV()
"RTN","RCBEADJ",29,0)
.. W !
"RTN","RCBEADJ",30,0)
. I $D(^PRCA(430,"TCSP",RCBILLDA)),(RCBETYPE="DECREASE") S %=$$ASKCM Q:(%'=1) ; prca*4.5*301 & *315
"RTN","RCBEADJ",31,0)
. ;
"RTN","RCBEADJ",32,0)
. ; adjust the bill
"RTN","RCBEADJ",33,0)
. D ADJBILL(RCBETYPE,RCBILLDA,$P($G(RCEDI),";",2))
"RTN","RCBEADJ",34,0)
Q
"RTN","RCBEADJ",35,0)
;
"RTN","RCBEADJ",36,0)
ADJBILL(RCBETYPE,RCBILLDA,RCEDIWL) ; adjust a bill
"RTN","RCBEADJ",37,0)
; RCEDIWL = ien of ERA entry if called from worklist
"RTN","RCBEADJ",38,0)
N RCAMOUNT,RCBALANC,RCDATA7,RCLIST,RCONTADJ,RCTRANDA,TOTALCAL,TOTALSTO,I,X,Y
"RTN","RCBEADJ",39,0)
; lock the bill
"RTN","RCBEADJ",40,0)
L +^PRCA(430,RCBILLDA):5 E W !,"ANOTHER USER IS CURRENTLY WORKING WITH THIS BILL." Q
"RTN","RCBEADJ",41,0)
;
"RTN","RCBEADJ",42,0)
; show data for the bill
"RTN","RCBEADJ",43,0)
D SHOWBILL^RCWROFF1(RCBILLDA)
"RTN","RCBEADJ",44,0)
;
"RTN","RCBEADJ",45,0)
; check the balance of the bill
"RTN","RCBEADJ",46,0)
W !!,"Checking the bill's balance ..."
"RTN","RCBEADJ",47,0)
S RCBALANC=$$OUTOFBAL^RCBDBBAL(RCBILLDA)
"RTN","RCBEADJ",48,0)
I RCBALANC="" W " IN Balance!"
"RTN","RCBEADJ",49,0)
;
"RTN","RCBEADJ",50,0)
; out of balance, ask to fix it
"RTN","RCBEADJ",51,0)
I RCBALANC'="" D I RCBILLDA<1 D UNLOCK Q
"RTN","RCBEADJ",52,0)
. S TOTALCAL=$P(RCBALANC,"^")+$P(RCBALANC,"^",2)+$P(RCBALANC,"^",3)+$P(RCBALANC,"^",4)+$P(RCBALANC,"^",5)
"RTN","RCBEADJ",53,0)
. S RCDATA7=$G(^PRCA(430,RCBILLDA,7))
"RTN","RCBEADJ",54,0)
. S TOTALSTO=$P(RCDATA7,"^")+$P(RCDATA7,"^",2)+$P(RCDATA7,"^",3)+$P(RCDATA7,"^",4)+$P(RCDATA7,"^",5)
"RTN","RCBEADJ",55,0)
. W " OUT of Balance!"
"RTN","RCBEADJ",56,0)
. W !!," BALANCE:",$J("Calculated",12),$J("Stored",12)
"RTN","RCBEADJ",57,0)
. W !," ------- ",$J("------------",12),$J("------------",12)
"RTN","RCBEADJ",58,0)
. W !," Principal Balance:",$J($P(RCBALANC,"^",1),12,2),$J($P(RCDATA7,"^",1),12,2)
"RTN","RCBEADJ",59,0)
. I +$P(RCBALANC,"^",1)'=+$P(RCDATA7,"^",1) W " <<-- OUT OF BALANCE"
"RTN","RCBEADJ",60,0)
. W !," Interest Balance:",$J($P(RCBALANC,"^",2),12,2),$J($P(RCDATA7,"^",2),12,2)
"RTN","RCBEADJ",61,0)
. I +$P(RCBALANC,"^",2)'=+$P(RCDATA7,"^",2) W " <<-- OUT OF BALANCE"
"RTN","RCBEADJ",62,0)
. W !," Admin Balance:",$J($P(RCBALANC,"^",3),12,2),$J($P(RCDATA7,"^",3),12,2)
"RTN","RCBEADJ",63,0)
. I +$P(RCBALANC,"^",3)'=+$P(RCDATA7,"^",3) W " <<-- OUT OF BALANCE"
"RTN","RCBEADJ",64,0)
. W !," MF Balance:",$J($P(RCBALANC,"^",4),12,2),$J($P(RCDATA7,"^",4),12,2)
"RTN","RCBEADJ",65,0)
. I +$P(RCBALANC,"^",4)'=+$P(RCDATA7,"^",4) W " <<-- OUT OF BALANCE"
"RTN","RCBEADJ",66,0)
. W !," CC Balance:",$J($P(RCBALANC,"^",5),12,2),$J($P(RCDATA7,"^",5),12,2)
"RTN","RCBEADJ",67,0)
. I +$P(RCBALANC,"^",5)'=+$P(RCDATA7,"^",5) W " <<-- OUT OF BALANCE"
"RTN","RCBEADJ",68,0)
. W !," ------- ",$J("-------------",12),$J("-------------",12)
"RTN","RCBEADJ",69,0)
. W !," TOTAL:",$J(TOTALCAL,12,2),$J(TOTALSTO,12,2)
"RTN","RCBEADJ",70,0)
. I +TOTALCAL'=+TOTALSTO W " <<-- OUT OF BALANCE"
"RTN","RCBEADJ",71,0)
. ;
"RTN","RCBEADJ",72,0)
. ; ask to fix the balances
"RTN","RCBEADJ",73,0)
. S Y=$$ASKFIX I Y'=1 W !," NOTE: You must fix the Balance Discrepancy before processing an adjustment!" S RCBILLDA=0 Q
"RTN","RCBEADJ",74,0)
. ;
"RTN","RCBEADJ",75,0)
. ; fix it
"RTN","RCBEADJ",76,0)
. S $P(RCDATA7,"^",1)=+$P(RCBALANC,"^",1) ; principal
"RTN","RCBEADJ",77,0)
. S $P(RCDATA7,"^",2)=+$P(RCBALANC,"^",2) ; interest
"RTN","RCBEADJ",78,0)
. S $P(RCDATA7,"^",3)=+$P(RCBALANC,"^",3) ; admin
"RTN","RCBEADJ",79,0)
. S $P(RCDATA7,"^",4)=+$P(RCBALANC,"^",4) ; marshal fee
"RTN","RCBEADJ",80,0)
. S $P(RCDATA7,"^",5)=+$P(RCBALANC,"^",5) ; court cost
"RTN","RCBEADJ",81,0)
. S $P(^PRCA(430,RCBILLDA,7),"^",1,5)=$P(RCDATA7,"^",1,5)
"RTN","RCBEADJ",82,0)
. ;
"RTN","RCBEADJ",83,0)
. W !," Balance Discrepancy FIXED!"
"RTN","RCBEADJ",84,0)
;
"RTN","RCBEADJ",85,0)
; if the principal balance is zero, do not allow it to be adjusted
"RTN","RCBEADJ",86,0)
; ask to close/cancel it
"RTN","RCBEADJ",87,0)
I RCBETYPE="DECREASE",'$G(^PRCA(430,RCBILLDA,7)) W !!,"Note: This bill has NO PRINCIPAL BALANCE to decrease !" D INTADMIN(RCBILLDA),UNLOCK Q
"RTN","RCBEADJ",88,0)
;
"RTN","RCBEADJ",89,0)
; If entry is from EDI Lockbox worklist, display total adjustments in ERA
"RTN","RCBEADJ",90,0)
N AP D
"RTN","RCBEADJ",91,0)
.N BILL,EOB,ERA,SEQ S ERA="",AP=0
"RTN","RCBEADJ",92,0)
.F S ERA=$O(^RCY(344.4,"AP",1,ERA)) Q:'ERA D Q:AP
"RTN","RCBEADJ",93,0)
..S SEQ=0
"RTN","RCBEADJ",94,0)
..F S SEQ=$O(^RCY(344.4,"AP",1,ERA,SEQ)) Q:'SEQ D Q:AP
"RTN","RCBEADJ",95,0)
...S EOB=$P($G(^RCY(344.4,ERA,1,SEQ,0)),U,2) Q:'EOB
"RTN","RCBEADJ",96,0)
...S:$P($G(^IBM(361.1,EOB,0)),U)=RCBILLDA AP=1 ;IA #4051
"RTN","RCBEADJ",97,0)
;
"RTN","RCBEADJ",98,0)
; Ask to enter transaction even though it is marked for autopost PRCA*4.5*298
"RTN","RCBEADJ",99,0)
I RCBETYPE="DECREASE",AP S Y=$$ASKAUPO() I Y'=1 W !,"Exiting bill adjustment." D UNLOCK Q
"RTN","RCBEADJ",100,0)
;
"RTN","RCBEADJ",101,0)
; Display warning for decrease adjustment if pending payments exist
"RTN","RCBEADJ",102,0)
I RCBETYPE="DECREASE" D WARN^RCBEADJ1(RCBILLDA) ; PRCA*4.5*326
"RTN","RCBEADJ",103,0)
;
"RTN","RCBEADJ",104,0)
; ask to enter adjustment amount
"RTN","RCBEADJ",105,0)
S RCAMOUNT=$$AMOUNT(RCBILLDA,RCBETYPE)
"RTN","RCBEADJ",106,0)
I RCAMOUNT<0 D UNLOCK Q
"RTN","RCBEADJ",107,0)
;
"RTN","RCBEADJ",108,0)
; if decrease, make negative
"RTN","RCBEADJ",109,0)
I RCBETYPE="DECREASE" S RCAMOUNT=-RCAMOUNT
"RTN","RCBEADJ",110,0)
;
"RTN","RCBEADJ",111,0)
; ask if it is a contract adjustment (Community Care added check for all 3rd party categories PRCA*4.5*338)
"RTN","RCBEADJ",112,0)
I RCBETYPE="DECREASE",$$THRDPRTY(RCBILLDA) S RCONTADJ=$$ASKCONT I RCONTADJ<0 D UNLOCK Q
"RTN","RCBEADJ",113,0)
;
"RTN","RCBEADJ",114,0)
; show what the new transaction will look like
"RTN","RCBEADJ",115,0)
S RCDATA7=$G(^PRCA(430,RCBILLDA,7))
"RTN","RCBEADJ",116,0)
W !!,"If you process the transaction, the bill will look like:"
"RTN","RCBEADJ",117,0)
W !,"Current Principal Balance: ",$J($P(RCDATA7,"^"),11,2)
"RTN","RCBEADJ",118,0)
W !," NEW ",RCBETYPE," Adjustment: ",$J(RCAMOUNT,11,2)
"RTN","RCBEADJ",119,0)
W !," -----------"
"RTN","RCBEADJ",120,0)
W !," NEW Principal Balance: ",$J($P(RCDATA7,"^")+RCAMOUNT,11,2)
"RTN","RCBEADJ",121,0)
;
"RTN","RCBEADJ",122,0)
; ask to enter transaction
"RTN","RCBEADJ",123,0)
S Y=$$ASKOK(RCBETYPE) I Y'=1 D UNLOCK Q
"RTN","RCBEADJ",124,0)
;
"RTN","RCBEADJ",125,0)
ADDADJ ; add adjustment
"RTN","RCBEADJ",126,0)
S RCTRANDA=$$INCDEC^RCBEUTR1(RCBILLDA,RCAMOUNT,"","","",$G(RCONTADJ))
"RTN","RCBEADJ",127,0)
I 'RCTRANDA W !," *** W A R N I N G: Adjustment NOT Processed! ***" D UNLOCK Q
"RTN","RCBEADJ",128,0)
I RCTRANDA W !," Adjustment Transaction: ",RCTRANDA," has been added."
"RTN","RCBEADJ",129,0)
I RCTRANDA,'$G(RCEDIWL),(RCBETYPE="DECREASE"),$D(^PRCA(430,"TCSP",RCBILLDA)) D DECADJ^RCTCSPU(RCBILLDA,RCTRANDA) ;prca*4.5*301 add cs decrease adjustment
"RTN","RCBEADJ",130,0)
I RCTRANDA,$G(RCTRREV)=0 S PRCABN=RCBILLDA D CSITRN^RCTCSPD5
"RTN","RCBEADJ",131,0)
I RCTRANDA,$G(RCTRREV)=0,'$G(RCEDIWL),(RCBETYPE="INCREASE"),$D(^PRCA(430,"TCSP",RCBILLDA)) S PRCABN=RCBILLDA D INCADJ^RCTCSPU(RCBILLDA,RCTRANDA) ;PRCA*4.5*315/DRF add cs increase adjustment
"RTN","RCBEADJ",132,0)
I $G(RCTRREV)=1 S PRCABN=RCBILLDA D CSITRY^RCTCSPD5
"RTN","RCBEADJ",133,0)
I '$G(REFMS)&(DT>$$LDATE^RCRJR(DT)) S Y=$E($$FPS^RCAMFN01(DT,1),1,5)_"01" D DD^%DT W !!," * * * * Transmission will be held until "_Y_" * * * *"
"RTN","RCBEADJ",134,0)
;
"RTN","RCBEADJ",135,0)
; ask to enter a comment
"RTN","RCBEADJ",136,0)
W !!,"Enter a comment for the ",RCBETYPE," Adjustment:"
"RTN","RCBEADJ",137,0)
S Y=$$EDIT433^RCBEUTRA(RCTRANDA,"41;")
"RTN","RCBEADJ",138,0)
;
"RTN","RCBEADJ",139,0)
; ask to exempt interest and admin charges
"RTN","RCBEADJ",140,0)
I RCBETYPE="DECREASE" D INTADMIN(RCBILLDA)
"RTN","RCBEADJ",141,0)
;
"RTN","RCBEADJ",142,0)
; notification of subsequent payer bulletin
"RTN","RCBEADJ",143,0)
S RCDATA7=$G(^PRCA(430,RCBILLDA,7)),X=0
"RTN","RCBEADJ",144,0)
F I=1:1:5 S X=X+$P(RCDATA7,"^",I)
"RTN","RCBEADJ",145,0)
I RCDATA7'="",'X D
"RTN","RCBEADJ",146,0)
. N PRCABN,PRCAEN,PRCAMT
"RTN","RCBEADJ",147,0)
. S PRCABN=RCBILLDA,PRCAEN=RCTRANDA,PRCAMT=+$P($G(^PRCA(433,RCTRANDA,1)),"^",5)
"RTN","RCBEADJ",148,0)
. D EOB^PRCADJ
"RTN","RCBEADJ",149,0)
;
"RTN","RCBEADJ",150,0)
; unlock and ask the next bill to adjust
"RTN","RCBEADJ",151,0)
D UNLOCK
"RTN","RCBEADJ",152,0)
Q
"RTN","RCBEADJ",153,0)
;
"RTN","RCBEADJ",154,0)
;
"RTN","RCBEADJ",155,0)
UNLOCK ; unlock bill and transaction
"RTN","RCBEADJ",156,0)
L -^PRCA(430,RCBILLDA)
"RTN","RCBEADJ",157,0)
I $G(RCTRANDA) L -^PRCA(433,RCTRANDA)
"RTN","RCBEADJ",158,0)
Q
"RTN","RCBEADJ",159,0)
;
"RTN","RCBEADJ",160,0)
;
"RTN","RCBEADJ",161,0)
INTADMIN(RCBILLDA) ; ask and adjust the interest and admin
"RTN","RCBEADJ",162,0)
N RCAMOUNT,RCTRANDA,Y
"RTN","RCBEADJ",163,0)
;
"RTN","RCBEADJ",164,0)
; check to see if there is interest and admin charges
"RTN","RCBEADJ",165,0)
S RCAMOUNT=$G(^PRCA(430,RCBILLDA,7))
"RTN","RCBEADJ",166,0)
I '$P(RCAMOUNT,"^",2),'$P(RCAMOUNT,"^",3),'$P(RCAMOUNT,"^",4),'$P(RCAMOUNT,"^",5) Q
"RTN","RCBEADJ",167,0)
;
"RTN","RCBEADJ",168,0)
; only ask if there is no principal
"RTN","RCBEADJ",169,0)
I RCAMOUNT Q
"RTN","RCBEADJ",170,0)
;
"RTN","RCBEADJ",171,0)
W !!,"You have the option to automatically EXEMPT the interest"
"RTN","RCBEADJ",172,0)
W !,"and administrative charges. This will close the bill."
"RTN","RCBEADJ",173,0)
S Y=$$ASKEXEMP I Y'=1 Q
"RTN","RCBEADJ",174,0)
;
"RTN","RCBEADJ",175,0)
W !!,"Creating an EXEMPT transaction ..."
"RTN","RCBEADJ",176,0)
S RCTRANDA=$$EXEMPT^RCBEUTR2(RCBILLDA,$P(RCAMOUNT,"^",2)_"^"_$P(RCAMOUNT,"^",3)_"^^"_$P(RCAMOUNT,"^",4)_"^"_$P(RCAMOUNT,"^",5))
"RTN","RCBEADJ",177,0)
I 'RCTRANDA W !," *** W A R N I N G: EXEMPTION NOT Processed! ***" Q
"RTN","RCBEADJ",178,0)
I RCTRANDA W !," Exempt Transaction: ",RCTRANDA," has been added."
"RTN","RCBEADJ",179,0)
INTC35B ;Check if CS5B entry needed for exempt transaction
"RTN","RCBEADJ",180,0)
I RCTRANDA,'$G(RCEDIWL),(RCBETYPE="DECREASE"),$D(^PRCA(430,"TCSP",RCBILLDA)) D DECADJ^RCTCSPU(RCBILLDA,RCTRANDA) ;prca*4.5*301 add cs exempt
"RTN","RCBEADJ",181,0)
I '$G(REFMS)&(DT>$$LDATE^RCRJR(DT)) S Y=$E($$FPS^RCAMFN01(DT,1),1,5)_"01" D DD^%DT W !!," * * * * Transmission will be held until "_Y_" * * * *"
"RTN","RCBEADJ",182,0)
;
"RTN","RCBEADJ",183,0)
W !," Current Bill Status: ",$P($G(^PRCA(430.3,+$P($G(^PRCA(430,RCBILLDA,0)),"^",8),0)),"^")
"RTN","RCBEADJ",184,0)
Q
"RTN","RCBEADJ",185,0)
;
"RTN","RCBEADJ",186,0)
ASKOK(RCBETYPE) ; ask record decrease or increase transaction
"RTN","RCBEADJ",187,0)
N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
"RTN","RCBEADJ",188,0)
S DIR(0)="YO",DIR("B")="YES"
"RTN","RCBEADJ",189,0)
S DIR("A")="Are you sure you want to enter this "_RCBETYPE_" adjustment "
"RTN","RCBEADJ",190,0)
W ! D ^DIR
"RTN","RCBEADJ",191,0)
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
"RTN","RCBEADJ",192,0)
Q Y
"RTN","RCBEADJ",193,0)
;
"RTN","RCBEADJ",194,0)
ASKAUPO() ; ask record even though marked for auto post PRCA*4.5*298
"RTN","RCBEADJ",195,0)
N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
"RTN","RCBEADJ",196,0)
S DIR(0)="YOA",DIR("B")="NO"
"RTN","RCBEADJ",197,0)
S DIR("A")="Marked for Auto-Post. Are you sure? (Y/N) "
"RTN","RCBEADJ",198,0)
W ! D ^DIR
"RTN","RCBEADJ",199,0)
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
"RTN","RCBEADJ",200,0)
Q Y
"RTN","RCBEADJ",201,0)
;
"RTN","RCBEADJ",202,0)
;PATCH 313
"RTN","RCBEADJ",203,0)
ASKFIX() ; ask to fix bill's balance
"RTN","RCBEADJ",204,0)
N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
"RTN","RCBEADJ",205,0)
S DIR(0)="YO",DIR("B")="YES"
"RTN","RCBEADJ",206,0)
;S DIR(0)="YO",DIR("B")="NO"
"RTN","RCBEADJ",207,0)
S DIR("A")=" Do you want to FIX the balance discrepancy "
"RTN","RCBEADJ",208,0)
W ! D ^DIR
"RTN","RCBEADJ",209,0)
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
"RTN","RCBEADJ",210,0)
Q Y
"RTN","RCBEADJ",211,0)
;
"RTN","RCBEADJ",212,0)
;
"RTN","RCBEADJ",213,0)
ASKEXEMP() ; ask to record an exempt transaction
"RTN","RCBEADJ",214,0)
N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
"RTN","RCBEADJ",215,0)
S DIR(0)="YO",DIR("B")="NO"
"RTN","RCBEADJ",216,0)
S DIR("A")=" Would you like to EXEMPT the interest and admin charges "
"RTN","RCBEADJ",217,0)
D ^DIR
"RTN","RCBEADJ",218,0)
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
"RTN","RCBEADJ",219,0)
Q Y
"RTN","RCBEADJ",220,0)
;
"RTN","RCBEADJ",221,0)
;
"RTN","RCBEADJ",222,0)
ASKCONT() ; ask if contract adjustment
"RTN","RCBEADJ",223,0)
N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
"RTN","RCBEADJ",224,0)
S DIR(0)="YO",DIR("B")="YES"
"RTN","RCBEADJ",225,0)
S DIR("A")=" Is this a CONTRACT adjustment "
"RTN","RCBEADJ",226,0)
W ! D ^DIR
"RTN","RCBEADJ",227,0)
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
"RTN","RCBEADJ",228,0)
Q Y
"RTN","RCBEADJ",229,0)
;
"RTN","RCBEADJ",230,0)
;
"RTN","RCBEADJ",231,0)
ASKREV() ; Ask if Treasury reversal *315/DRF
"RTN","RCBEADJ",232,0)
N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
"RTN","RCBEADJ",233,0)
S DIR(0)="YO",DIR("B")="NO"
"RTN","RCBEADJ",234,0)
S DIR("A")=" Is this a TREASURY reversal "
"RTN","RCBEADJ",235,0)
W ! D ^DIR
"RTN","RCBEADJ",236,0)
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
"RTN","RCBEADJ",237,0)
Q Y
"RTN","RCBEADJ",238,0)
;
"RTN","RCBEADJ",239,0)
;
"RTN","RCBEADJ",240,0)
ADJNUM(RCBILLDA) ; get next adjustment number for a bill
"RTN","RCBEADJ",241,0)
N %,ADJUST,DATA1,RCTRANDA
"RTN","RCBEADJ",242,0)
S RCTRANDA=0
"RTN","RCBEADJ",243,0)
F S RCTRANDA=$O(^PRCA(433,"C",RCBILLDA,RCTRANDA)) Q:'RCTRANDA S DATA1=$G(^PRCA(433,RCTRANDA,1)) I $P(DATA1,"^",4),$P(DATA1,"^",2)=1!($P(DATA1,"^",2)=35) S ADJUST=$P(DATA1,"^",4)+1
"RTN","RCBEADJ",244,0)
Q ADJUST
"RTN","RCBEADJ",245,0)
;
"RTN","RCBEADJ",246,0)
;
"RTN","RCBEADJ",247,0)
AMOUNT(RCBILLDA,RCBETYPE) ; enter the adjustment amount for a bill
"RTN","RCBEADJ",248,0)
N DIR,DIRUT,DTOUT,DUOUT,PRINBAL,X,Y
"RTN","RCBEADJ",249,0)
S PRINBAL=+$P($G(^PRCA(430,RCBILLDA,7)),"^")
"RTN","RCBEADJ",250,0)
I RCBETYPE="INCREASE" S PRINBAL=9999999.99
"RTN","RCBEADJ",251,0)
W !!,"Enter the ",RCBETYPE," Adjustment AMOUNT, from .01 to ",$J(PRINBAL,0,2),"."
"RTN","RCBEADJ",252,0)
S DIR(0)="NAO^.01:"_PRINBAL_":2"
"RTN","RCBEADJ",253,0)
S DIR("A")=" "_RCBETYPE_" PRINCIPAL BALANCE BY: "
"RTN","RCBEADJ",254,0)
D ^DIR
"RTN","RCBEADJ",255,0)
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
"RTN","RCBEADJ",256,0)
Q $S(Y'="":Y,1:-1)
"RTN","RCBEADJ",257,0)
;
"RTN","RCBEADJ",258,0)
;
"RTN","RCBEADJ",259,0)
ASKCM() ; ask if the action is being performed due to the claims matching process *315
"RTN","RCBEADJ",260,0)
N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
"RTN","RCBEADJ",261,0)
S DIR(0)="YO",DIR("B")="NO"
"RTN","RCBEADJ",262,0)
S DIR("A")="Is this action being performed due to the CLAIMS MATCHING process "
"RTN","RCBEADJ",263,0)
D ^DIR
"RTN","RCBEADJ",264,0)
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
"RTN","RCBEADJ",265,0)
Q Y
"RTN","RCBEADJ",266,0)
;
"RTN","RCBEADJ",267,0)
THRDPRTY(RCBILLDA) ; check whether or not bill is THIRD PARTY
"RTN","RCBEADJ",268,0)
N CAT
"RTN","RCBEADJ",269,0)
S CAT=$$GET1^DIQ(430,RCBILLDA,2,"I") ; get account receivable category
"RTN","RCBEADJ",270,0)
I $$GET1^DIQ(430.2,CAT,5,"I")="T" Q 1 ; return true if AR Category is THIRD PARTY
"RTN","RCBEADJ",271,0)
Q 0
"RTN","RCDMC90")
0^13^B63494730
"RTN","RCDMC90",1,0)
RCDMC90 ;WASH IRMFO@ALTOONA,PA/TJK-DMC 90 DAY ;7/17/97 8:13 AM
"RTN","RCDMC90",2,0)
V ;;4.5;Accounts Receivable;**45,108,133,121,163,190,192,236,237,229,253,338**;Mar 20, 1995;Build 70
"RTN","RCDMC90",3,0)
;Per VA Directive 6402,this routine should not be modified.
"RTN","RCDMC90",4,0)
;
"RTN","RCDMC90",5,0)
ENTER ;Entry point from nightly process
"RTN","RCDMC90",6,0)
Q:'$D(RCDOC)
"RTN","RCDMC90",7,0)
;run the interest and admin for newly flagged Katrina Patients.
"RTN","RCDMC90",8,0)
I DT'<$P($G(^RC(342,1,30)),"^",1)&(DT'>$P($G(^RC(342,1,30)),"^",2)) D ^RCEXINAD
"RTN","RCDMC90",9,0)
N DEBTOR,BILL,DEBTOR0,B0,B6,B7,LTRDT3,P30DT,PRIN,INT,ADMIN,B4,B12
"RTN","RCDMC90",10,0)
N TPRIN,TINT,TADMIN,ESTDT,CATYP,DFN,CNTR,SITE,LN,FN,MN,STNM,DOB,SITE
"RTN","RCDMC90",11,0)
N PHONE,QUIT,TOTAL,ZIPCODE,FULLNM,XN,P91DT,OFFAMT,RCNT,TLINE,REPAY,X1,X2
"RTN","RCDMC90",12,0)
N LKUP,ADDR,ADDRPHO,CHKPHONE,PSSN
"RTN","RCDMC90",13,0)
K ^XTMP("RCDMC90",$J),^TMP($J,"RCDMC90") S ^XTMP("RCDMC90",0)=DT
"RTN","RCDMC90",14,0)
S SITE=$$SITE^RCMSITE(),TLINE="0^0^0"
"RTN","RCDMC90",15,0)
S X1=DT,X2=-91 D C^%DTC S P91DT=X
"RTN","RCDMC90",16,0)
S X1=DT,X2=-30 D C^%DTC S P30DT=X
"RTN","RCDMC90",17,0)
S (CNTR,DEBTOR)=0,RCNT=2 G UPDATE:$G(RCDOC)="W"
"RTN","RCDMC90",18,0)
;MASTER SHEET COMPILATION
"RTN","RCDMC90",19,0)
F S DEBTOR=$O(^PRCA(430,"C",DEBTOR)) Q:DEBTOR'?1N.N D
"RTN","RCDMC90",20,0)
.N X,RCDFN
"RTN","RCDMC90",21,0)
.S RCDFN=$P($G(^RCD(340,DEBTOR,0)),"^",1) I $P(RCDFN,";",2)'["DPT" Q
"RTN","RCDMC90",22,0)
.S X=$$EMERES^PRCAUTL(+RCDFN) I X]""&('$D(^RCD(340,"DMC",1,DEBTOR))) Q ;stop the master sheet compilation for hurricane Katrina sites
"RTN","RCDMC90",23,0)
.K ^TMP($J,"RCDMC90","BILL")
"RTN","RCDMC90",24,0)
.S QUIT=1,OFFAMT=+$P($G(^RCD(340,DEBTOR,3)),U,9)
"RTN","RCDMC90",25,0)
.D PROC(DEBTOR,.QUIT) Q:QUIT
"RTN","RCDMC90",26,0)
.;COMPILES FIELDS UNIQUE TO MASTER CODE SHEETS
"RTN","RCDMC90",27,0)
.S FULLNM=$$NM(DFN),FN=$P(FULLNM,U,3),MN=$P(FULLNM,U,4)
"RTN","RCDMC90",28,0)
.S LN=$P(FULLNM,U,1),XN=$P(FULLNM,U,2)
"RTN","RCDMC90",29,0)
.S FULLNM=FN_" "_$S(MN'="":$P(MN,".")_" ",1:"")_LN_$S(XN'="":" "_$P(XN,"."),1:"")
"RTN","RCDMC90",30,0)
.S STNM=$$LJ^XLFSTR($E(FN)_$S(MN'="":$E(MN),1:" ")_$E(LN,1,5),7," ")
"RTN","RCDMC90",31,0)
.S DOB=$$DATE8(+VADM(3))
"RTN","RCDMC90",32,0)
.;SET HOLDING GLOBAL FOR MASTER SHEETS
"RTN","RCDMC90",33,0)
.S CNTR=CNTR+1
"RTN","RCDMC90",34,0)
.S ^XTMP("RCDMC90",$J,CNTR)=$E($$LJ^XLFSTR($P(VADM(2),U),9),1,9)_STNM_SITE_DOB_PHONE_$$LJ^XLFSTR(FULLNM,40)_$$LJ^XLFSTR($E($P(ADDR,U,1),1,2),2)
"RTN","RCDMC90",35,0)
.S CNTR=CNTR+1
"RTN","RCDMC90",36,0)
.S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,1),3,40),38)_$$LJ^XLFSTR($E($P(ADDR,U,2),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,3)),1)
"RTN","RCDMC90",37,0)
.S CNTR=CNTR+1
"RTN","RCDMC90",38,0)
.S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,3),2,40),39)_$$LJ^XLFSTR($E($P(ADDR,U,4),1,40),40)
"RTN","RCDMC90",39,0)
.S CNTR=CNTR+1
"RTN","RCDMC90",40,0)
.S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,5),1,40),40)_$$LJ^XLFSTR(ZIPCODE,9)_$$DATE8(ESTDT)_$$AMT(TPRIN)_$$AMT(TINT)_$E($$AMT(TADMIN),1,4)
"RTN","RCDMC90",41,0)
.S CNTR=CNTR+1
"RTN","RCDMC90",42,0)
.S ^XTMP("RCDMC90",$J,CNTR)=$E($$AMT(TADMIN),5,9)_$$DATE8(DT)_CATYP_$$AMT(OFFAMT)_$$AMT($$BAL(DEBTOR))_$E("0000000000",1,10-$L(DEBTOR))_DEBTOR_"$"
"RTN","RCDMC90",43,0)
.S $P(^RCD(340,DEBTOR,3),U)=1,$P(^(3),U,2)=DT,$P(^(3),U,3)=ESTDT,$P(^(3),U,5)=TOTAL,$P(^(3),U,6)=TPRIN,$P(^(3),U,7)=TINT,$P(^(3),U,8)=TADMIN,^RCD(340,"DMC",1,DEBTOR)=""
"RTN","RCDMC90",44,0)
.S X=0 F S X=$O(^TMP($J,"RCDMC90","BILL",X)) Q:'X S ^PRCA(430,X,12)=^(X)
"RTN","RCDMC90",45,0)
.D SETREC
"RTN","RCDMC90",46,0)
.Q
"RTN","RCDMC90",47,0)
D COMPILE^RCDMC90U(375,CNTR,5,TLINE),KVAR
"RTN","RCDMC90",48,0)
Q
"RTN","RCDMC90",49,0)
UPDATE ;WEEKLY UPDATE COMPILATION
"RTN","RCDMC90",50,0)
F S DEBTOR=$O(^RCD(340,"DMC",1,DEBTOR)) Q:DEBTOR'?1N.N D
"RTN","RCDMC90",51,0)
.I '$G(^RCD(340,DEBTOR,3)) K ^RCD(340,"DMC",1,DEBTOR) Q
"RTN","RCDMC90",52,0)
.S QUIT=1,OFFAMT=+$P(^RCD(340,DEBTOR,3),U,9)
"RTN","RCDMC90",53,0)
.D PROC(DEBTOR,.QUIT) Q:QUIT
"RTN","RCDMC90",54,0)
.;SET HOLDING GLOBAL FOR WEEKLY UPDATES
"RTN","RCDMC90",55,0)
.S CNTR=CNTR+1
"RTN","RCDMC90",56,0)
.S ^XTMP("RCDMC90",$J,CNTR)=$E($$LJ^XLFSTR($P(VADM(2),U),9),1,9)_$$LJ^XLFSTR($E($P(ADDR,U,1),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,2),1,30),30)
"RTN","RCDMC90",57,0)
.S CNTR=CNTR+1
"RTN","RCDMC90",58,0)
.S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,2),31,40),10)_$$LJ^XLFSTR($E($P(ADDR,U,3),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,4),1,29),29)
"RTN","RCDMC90",59,0)
.S CNTR=CNTR+1
"RTN","RCDMC90",60,0)
.S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,4),30,40),11)_$$LJ^XLFSTR($E($P(ADDR,U,5),1,40),40)_$$LJ^XLFSTR(ZIPCODE,9)_SITE_PHONE_$E($$AMT(TPRIN),1,6)
"RTN","RCDMC90",61,0)
.S CNTR=CNTR+1
"RTN","RCDMC90",62,0)
.S ^XTMP("RCDMC90",$J,CNTR)=$E($$AMT(TPRIN),7,9)_$$AMT(TINT)_$$AMT(TADMIN)_$$DATE8(DT)_CATYP_$$AMT(OFFAMT)_$$AMT($$BAL(DEBTOR))_"$"
"RTN","RCDMC90",63,0)
.S:TOTAL $P(^RCD(340,DEBTOR,3),U,5)=TOTAL,$P(^(3),U,6)=TPRIN,$P(^(3),U,7)=TINT,$P(^(3),U,8)=TADMIN
"RTN","RCDMC90",64,0)
.D SETREC
"RTN","RCDMC90",65,0)
.Q
"RTN","RCDMC90",66,0)
D COMPILE^RCDMC90U(300,CNTR,4,TLINE),KVAR
"RTN","RCDMC90",67,0)
Q
"RTN","RCDMC90",68,0)
KVAR D KVAR^VADPT
"RTN","RCDMC90",69,0)
K RCDOC,^XTMP("RCDMC90",$J),VA("BID"),XMDUZ
"RTN","RCDMC90",70,0)
Q
"RTN","RCDMC90",71,0)
PROC(DEBTOR,QUIT) ;PROCESS BILLS FOR A SPECIFIC DEBTOR
"RTN","RCDMC90",72,0)
;SETS DATA COMMON TO BOTH WEEKLY & MASTER CODESHEETS
"RTN","RCDMC90",73,0)
S DEBTOR0=$G(^RCD(340,DEBTOR,0))
"RTN","RCDMC90",74,0)
Q:$P(DEBTOR0,U)'["DPT"
"RTN","RCDMC90",75,0)
S DFN=+DEBTOR0 D DEM^VADPT Q:$E(VADM(2),1,5)="00000"
"RTN","RCDMC90",76,0)
F X=1:1:6 S CATYP(X)=""
"RTN","RCDMC90",77,0)
S (BILL,TOTAL,TPRIN,TINT,TADMIN,REPAY)=0,ESTDT=P91DT
"RTN","RCDMC90",78,0)
I RCDOC="W",$P(^RCD(340,DEBTOR,3),U,10) G TOTAL
"RTN","RCDMC90",79,0)
F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D K:PRIN=0 ^PRCA(430,BILL,12) Q:REPAY
"RTN","RCDMC90",80,0)
.S (PRIN,INT,ADMIN)=0
"RTN","RCDMC90",81,0)
.I +VADM(6) Q
"RTN","RCDMC90",82,0)
.S B0=$G(^PRCA(430,BILL,0)),B4=$G(^(4)),B6=$G(^(6)),B7=$G(^(7)),B12=$G(^(12))
"RTN","RCDMC90",83,0)
.Q:$P(B0,U,8)'=16
"RTN","RCDMC90",84,0)
.I B4 D Q
"RTN","RCDMC90",85,0)
..S (TOTAL,TPRIN,TINT,TADMIN)=0
"RTN","RCDMC90",86,0)
..S X=0 F S X=$O(^PRCA(430,"C",DEBTOR,X)) Q:X'?1N.N K ^PRCA(430,X,12)
"RTN","RCDMC90",87,0)
..S REPAY=1
"RTN","RCDMC90",88,0)
..Q
"RTN","RCDMC90",89,0)
.I RCDOC="W",'$P(B12,U) Q
"RTN","RCDMC90",90,0)
.S PRIN=$P(B7,U),INT=$P(B7,U,2),ADMIN=$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5)
"RTN","RCDMC90",91,0)
.I PRIN'>0,INT+ADMIN>0 D Q
"RTN","RCDMC90",92,0)
..N XMSUB,XMY,XMTEXT,MSG
"RTN","RCDMC90",93,0)
..S XMSUB="Notice Of Active Bill Without Principal Balance"
"RTN","RCDMC90",94,0)
..S XMY("G.DMR")=""
"RTN","RCDMC90",95,0)
..S XMDUZ="AR PACKAGE"
"RTN","RCDMC90",96,0)
..S XMTEXT="MSG("
"RTN","RCDMC90",97,0)
..S MSG(1)="The following bill has a 0 principal balance,"
"RTN","RCDMC90",98,0)
..S MSG(2)="but has interest/admin charges remaining."
"RTN","RCDMC90",99,0)
..S MSG(3)="These charges should be exempted"
"RTN","RCDMC90",100,0)
..S MSG(4)=" "
"RTN","RCDMC90",101,0)
..S MSG(5)="BILL #: "_$P(B0,U)
"RTN","RCDMC90",102,0)
..D ^XMD
"RTN","RCDMC90",103,0)
..Q
"RTN","RCDMC90",104,0)
.Q:$P(B4,U)
"RTN","RCDMC90",105,0)
.S LTRDT3=$P(B6,U,3) Q:'LTRDT3 Q:LTRDT3>P30DT
"RTN","RCDMC90",106,0)
.;CHECK FOR DC REFERRAL HERE
"RTN","RCDMC90",107,0)
.I $P(B6,U,4),($P(B6,U,5)="DC")!($P(B6,U,5)="RC") Q
"RTN","RCDMC90",108,0)
.;Q:$$INSURED^IBCNS1(DFN,$P(B0,U,10)) ;Commented out w/patch *121
"RTN","RCDMC90",109,0)
.;***PRCA*4.5*338 start
"RTN","RCDMC90",110,0)
.S X=$P(B0,U,2)
"RTN","RCDMC90",111,0)
.; Check to see if the AR category allows for a DMC referral
"RTN","RCDMC90",112,0)
.Q:'$$RFCHK^RCTOPD(X,"I",1.01,$P(B6,U,21))
"RTN","RCDMC90",113,0)
.;end PRCA*4.5*338
"RTN","RCDMC90",114,0)
.;
"RTN","RCDMC90",115,0)
.K CATYP(X)
"RTN","RCDMC90",116,0)
.;Check if bill should be deferred from being sent to DMC if Veteran is
"RTN","RCDMC90",117,0)
.;SC 50% to 100% or Receiving VA Pension (Hold Debt to DMC project, sbw)
"RTN","RCDMC90",118,0)
.Q:+$$HOLDCHK^RCDMCUT1(BILL,DFN)>0
"RTN","RCDMC90",119,0)
.I $P(B6,U,21),$P(B6,U,21)<ESTDT S ESTDT=$P($P(B6,U,21),".")
"RTN","RCDMC90",120,0)
.I $P(B12,U,2),PRIN>$P(B12,U,2) S PRIN=$P(B12,U,2)
"RTN","RCDMC90",121,0)
.S ^TMP($J,"RCDMC90","BILL",BILL)=$S($P(B12,U):$P(B12,U),1:DT)_U_PRIN_U_INT_U_ADMIN
"RTN","RCDMC90",122,0)
.S TPRIN=TPRIN+PRIN,TINT=TINT+INT,TADMIN=TADMIN+ADMIN
"RTN","RCDMC90",123,0)
.Q
"RTN","RCDMC90",124,0)
TOTAL S TOTAL=TPRIN+TINT+TADMIN
"RTN","RCDMC90",125,0)
I RCDOC="M" Q:TPRIN'>0 ;PRCA*4.5*229
"RTN","RCDMC90",126,0)
I RCDOC="M",'+$$SWSTAT^IBBAPI() Q:TOTAL<25 ;PRCA*4.5*229
"RTN","RCDMC90",127,0)
;
"RTN","RCDMC90",128,0)
I RCDOC="M",$P(VADM(2),U)["P" S PSSN=$P(VADM(2),U) D PSEUDO^RCDMC90U(DFN,PSSN) Q
"RTN","RCDMC90",129,0)
I RCDOC="W" Q:(TOTAL_U_TPRIN_U_TINT_U_TADMIN)=$P(^RCD(340,DEBTOR,3),U,5,8)
"RTN","RCDMC90",130,0)
S DFN=+DEBTOR0
"RTN","RCDMC90",131,0)
;SETS CATEGORY CODE 1=MEANS TEST,2=PHARMACY,3=INEL.,4=EMER./HUM.
"RTN","RCDMC90",132,0)
;5=CHAMPVA,6=TRICARE OR ANY COMBINATION THEREOF
"RTN","RCDMC90",133,0)
S CATYP="" F X=1:1:6 S:'$D(CATYP(X)) CATYP=CATYP_X
"RTN","RCDMC90",134,0)
S CATYP=$$LJ^XLFSTR(CATYP,6)
"RTN","RCDMC90",135,0)
;
"RTN","RCDMC90",136,0)
;Send Master/Weekly error msg if Unknown or Invalid address
"RTN","RCDMC90",137,0)
;If Master update, quit and don't refer to DMC
"RTN","RCDMC90",138,0)
;If Weekly update, send a zero balance
"RTN","RCDMC90",139,0)
S LKUP=$$CHKADD(DEBTOR)
"RTN","RCDMC90",140,0)
I LKUP D ERROR^RCDMC90U(RCDOC,LKUP,DFN) Q:RCDOC="M" S (TOTAL,TPRIN,TINT,TADMIN)=0
"RTN","RCDMC90",141,0)
;
"RTN","RCDMC90",142,0)
S ZIPCODE=$TR($P(ADDR,U,6),"-")
"RTN","RCDMC90",143,0)
;
"RTN","RCDMC90",144,0)
;Retrieve and format patient phone number
"RTN","RCDMC90",145,0)
S ADDRPHO=$P(ADDR,U,7),PHONE=""
"RTN","RCDMC90",146,0)
F I=1:1:$L(ADDRPHO) S CHKPHONE=$E(ADDRPHO,I) I CHKPHONE?1N S PHONE=PHONE_CHKPHONE
"RTN","RCDMC90",147,0)
S PHONE=$S(PHONE?10N:PHONE,PHONE?7N:" "_PHONE,1:" ")
"RTN","RCDMC90",148,0)
;
"RTN","RCDMC90",149,0)
I RCDOC="W",TOTAL=0 D
"RTN","RCDMC90",150,0)
.K ^RCD(340,"DMC",1,DEBTOR),^RCD(340,DEBTOR,3)
"RTN","RCDMC90",151,0)
.N NM,XMSUB,XMY,XMTEXT,MSG
"RTN","RCDMC90",152,0)
.S XMSUB="Deletion of Debtor from DMC"
"RTN","RCDMC90",153,0)
.S XMY("G.DMX")=""
"RTN","RCDMC90",154,0)
.S XMDUZ="AR PACKAGE"
"RTN","RCDMC90",155,0)
.S XMTEXT="MSG("
"RTN","RCDMC90",156,0)
.S MSG(1)="The following patient has a DMC balance of '0'"
"RTN","RCDMC90",157,0)
.S MSG(2)="and will be deleted from the DMC system:"
"RTN","RCDMC90",158,0)
.S MSG(3)=" "
"RTN","RCDMC90",159,0)
.S MSG(4)=$P(^DPT(DFN,0),U)_" SSN: "_$P(^(0),U,9)
"RTN","RCDMC90",160,0)
.D ^XMD
"RTN","RCDMC90",161,0)
.Q
"RTN","RCDMC90",162,0)
S QUIT=0
"RTN","RCDMC90",163,0)
PROCQ Q
"RTN","RCDMC90",164,0)
DATE8(X) ;CHANGES FILEMAN DATE INTO 8 DIGIT DATE IN FORMAT MMDDYYYY
"RTN","RCDMC90",165,0)
S X=$E(X,4,7)_($E(X,1,3)+1700)
"RTN","RCDMC90",166,0)
Q X
"RTN","RCDMC90",167,0)
AMT(X) ;CHANGES AMOUNT TO ZERO FILLED, RIGHT JUSTIFIED
"RTN","RCDMC90",168,0)
S X=$TR($J(X,0,2),".")
"RTN","RCDMC90",169,0)
S X=$E("000000000",1,9-$L(X))_X
"RTN","RCDMC90",170,0)
Q X
"RTN","RCDMC90",171,0)
NM(DFN) ;Returns first, middle, and last name in 3 different variables
"RTN","RCDMC90",172,0)
N FN,LN,MN,NM,XN
"RTN","RCDMC90",173,0)
S NM=$P($G(^DPT(DFN,0)),"^")
"RTN","RCDMC90",174,0)
S LN=$TR($P(NM,",")," .'-"),MN=$P($P(NM,",",2)," ",2)
"RTN","RCDMC90",175,0)
I ($E(MN,1,2)="SR")!($E(MN,1,2)="JR")!(MN?2.3"I")!(MN?0.1"I"1"V"1.3"I") S XN=MN,MN=""
"RTN","RCDMC90",176,0)
I $G(XN)="" S XN=$P($P($G(NM),",",2)," ",3)
"RTN","RCDMC90",177,0)
S FN=$P($P(NM,",",2)," ")
"RTN","RCDMC90",178,0)
QNM Q LN_"^"_XN_"^"_FN_"^"_MN
"RTN","RCDMC90",179,0)
BAL(DEBTOR) ;COMPUTES TOTAL OF ACTIVE BILLS THAT COULD BE SENT TO DMC
"RTN","RCDMC90",180,0)
N BILL,BAL
"RTN","RCDMC90",181,0)
S (BILL,BAL)=0
"RTN","RCDMC90",182,0)
F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D
"RTN","RCDMC90",183,0)
.S B0=$G(^PRCA(430,BILL,0)),B7=$G(^(7))
"RTN","RCDMC90",184,0)
.Q:$P(B0,U,8)'=16
"RTN","RCDMC90",185,0)
.S X=$P(B0,U,2),X=$S((X>0)&(X<6):1,X=18:1,(X>21)&(X<26):1,(X>26)&(X<33):1,1:"")
"RTN","RCDMC90",186,0)
.Q:X=""
"RTN","RCDMC90",187,0)
.S BAL=BAL+$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5)
"RTN","RCDMC90",188,0)
.Q
"RTN","RCDMC90",189,0)
BALQ Q BAL
"RTN","RCDMC90",190,0)
SETREC ;SETS TEMPORARY GLOBAL FOR MAIL MESSAGE TO USERS
"RTN","RCDMC90",191,0)
S RCNT=RCNT+1 D PID^VADPT S:$L(VA("BID"))=4 VA("BID")=" "_VA("BID")
"RTN","RCDMC90",192,0)
S TLINE=($P(TLINE,U)+TPRIN)_U_($P(TLINE,U,2)+TINT)_U_($P(TLINE,U,3)+TADMIN)
"RTN","RCDMC90",193,0)
S ^XTMP("RCDMC90",$J,"REC",$P(^DPT(DFN,0),U)_";"_DFN)=$$LJ^XLFSTR($E($P(^DPT(DFN,0),U),1,28),29)_" "_VA("BID")_" "_$J(TPRIN,10,2)_$J(TINT,10,2)_$J(TADMIN,10,2)_$J(TOTAL,10,2)
"RTN","RCDMC90",194,0)
Q
"RTN","RCDMC90",195,0)
;
"RTN","RCDMC90",196,0)
CHKADD(DEBTOR) ; Checks for invalid and unknown addresses
"RTN","RCDMC90",197,0)
N CHK S CHK=0,ADDR=""
"RTN","RCDMC90",198,0)
I $P($G(^RCD(340,+DEBTOR,1)),"^",9)=1 S CHK=1 G CHKADDQ
"RTN","RCDMC90",199,0)
S ADDR=$$DADD^RCAMADD(+DEBTOR,1) ;get address (confidential if possible)
"RTN","RCDMC90",200,0)
I ADDR'?.ANP!(ADDR["$")!(ADDR["**")!(ADDR["///")!(ADDR["ZZZ") S CHK=2
"RTN","RCDMC90",201,0)
CHKADDQ Q CHK
"RTN","RCDMC90",202,0)
;
"RTN","RCDPRTP")
0^16^B16040807
"RTN","RCDPRTP",1,0)
RCDPRTP ;ALB/LDB-CLAIMS MATCHING REPORT ;1/11/01 2:03 PM
"RTN","RCDPRTP",2,0)
;;4.5;Accounts Receivable;**151,186,315,339,338**;Mar 20, 1995;Build 70
"RTN","RCDPRTP",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCDPRTP",4,0)
;
"RTN","RCDPRTP",5,0)
EN ;
"RTN","RCDPRTP",6,0)
N DATEEND,DATESTRT,DIC,DIR,DIRUT,POP,RCBILL,RCDEBT,RCDFN,RCPT,RCSORT,RCQUIT,%ZIS,ZTDESC,ZTSAVE,ZTRTN,Y,RCAN,DIOEND,ZTIO,RCTYPE
"RTN","RCDPRTP",7,0)
W !
"RTN","RCDPRTP",8,0)
K DIRUT S DIR(0)="S^1:Patient;2:Bill Number;3:Payment dates;4:Receipt Number;5:Care Types",DIR("A")="Sort by" D ^DIR K DIR Q:$D(DIRUT)
"RTN","RCDPRTP",9,0)
S RCSORT=Y,RCQUIT=""
"RTN","RCDPRTP",10,0)
D @RCSORT Q:RCQUIT W !
"RTN","RCDPRTP",11,0)
K DIRUT S DIR(0)="Y",DIR("A")="Include cancelled bills",DIR("B")="NO" D ^DIR S RCAN=+Y Q:$D(DIRUT)
"RTN","RCDPRTP",12,0)
;
"RTN","RCDPRTP",13,0)
; if user wants Excel output, then call the device question for Excel and then quit
"RTN","RCDPRTP",14,0)
I $$FORMAT^RCDPRTP0(.RCEXCEL) D DEVICE^RCDPRTP0 Q ; exit point for Excel output
"RTN","RCDPRTP",15,0)
Q:RCQUIT
"RTN","RCDPRTP",16,0)
;
"RTN","RCDPRTP",17,0)
; At this point, the user wants non-Excel output. Ask device question for non-Excel output.
"RTN","RCDPRTP",18,0)
W !!,"This report requires 132 columns.",!!
"RTN","RCDPRTP",19,0)
K IOP,IO("Q") S %ZIS="MQ",%ZIS("B")="" D ^%ZIS Q:POP
"RTN","RCDPRTP",20,0)
I $D(IO("Q")) D Q
"RTN","RCDPRTP",21,0)
.S ZTDESC="Claims Matching Report",ZTRTN="DQ^RCDPRTP"
"RTN","RCDPRTP",22,0)
.S ZTSAVE("RCSORT")=""
"RTN","RCDPRTP",23,0)
. I RCSORT=1 S ZTSAVE("RCDEBT")="",ZTSAVE("RCDFN")="",ZTSAVE("RCTYPE*")=""
"RTN","RCDPRTP",24,0)
. I RCSORT=2 S ZTSAVE("RCBILL")="",ZTSAVE("RCDFN")="",ZTSAVE("RCDEBT")=""
"RTN","RCDPRTP",25,0)
. I RCSORT=4 S ZTSAVE("RCPT")=""
"RTN","RCDPRTP",26,0)
. I RCSORT=5 S ZTSAVE("RCTYPE*")=""
"RTN","RCDPRTP",27,0)
. S ZTSAVE("RCAN")="",ZTSAVE("ZTREQ")="@",ZTSAVE("^TMP(""RCDPRTPB"",$J,")=""
"RTN","RCDPRTP",28,0)
. S ZTSAVE("DATEEND")="",ZTSAVE("DATESTRT")="",ZTSAVE("RCQUIT")="",ZTSAVE("RCSORT")="",ZTSAVE("RCEXCEL")=""
"RTN","RCDPRTP",29,0)
. S ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL
"RTN","RCDPRTP",30,0)
. S DIOEND="K ^TMP(""RCDPRTPB"",$J)"
"RTN","RCDPRTP",31,0)
.D ^%ZTLOAD,HOME^%ZIS K IO("Q") W !,"Task# ",ZTSK
"RTN","RCDPRTP",32,0)
W !!,?20,"<*> please wait <*>"
"RTN","RCDPRTP",33,0)
DQ ; queued report starts here
"RTN","RCDPRTP",34,0)
U IO
"RTN","RCDPRTP",35,0)
K ^TMP("RCDPRTPB",$J),^TMP("IBRBT",$J),^TMP("IBRBF",$J)
"RTN","RCDPRTP",36,0)
N DAT,RCBIL,RCBIL0,RCNAM,RCPAY,RCPAY1,RCREC,RCREC1,RCRECTDA,RCSSN,RCTYP
"RTN","RCDPRTP",37,0)
D @($S(RCSORT=1:"PAT",RCSORT=2:"BILL",RCSORT=3:"DATE",RCSORT=4:"REC",RCSORT=5:"TYPE")_"^RCDPRTP0")
"RTN","RCDPRTP",38,0)
Q:RCQUIT
"RTN","RCDPRTP",39,0)
D EN^RCDPRTP1
"RTN","RCDPRTP",40,0)
W !!,?20,"<End of report>",!
"RTN","RCDPRTP",41,0)
K DATESTRT,DATEEND,^TMP("RCDPRTPB",$J),RCTYPE
"RTN","RCDPRTP",42,0)
D ^%ZISC
"RTN","RCDPRTP",43,0)
Q
"RTN","RCDPRTP",44,0)
;
"RTN","RCDPRTP",45,0)
1 ;
"RTN","RCDPRTP",46,0)
S DIC(0)="QEAMZ",DIC=340,DIC("S")="I ^RCD(340,+Y,0)[""DPT""",DIC("A")="Patient name: " D ^DIC I Y<0 S RCQUIT=1 Q
"RTN","RCDPRTP",47,0)
S RCDEBT=+Y,RCDFN=+$P(Y,"^",2)
"RTN","RCDPRTP",48,0)
D TYPEPIC^RCDPRTP0(.RCTYPE) I '$D(RCTYPE) S RCQUIT=1 Q
"RTN","RCDPRTP",49,0)
D DATESEL^RCRJRTRA("Payment")
"RTN","RCDPRTP",50,0)
I '$G(DATESTRT)!('$G(DATEEND)) S RCQUIT=1
"RTN","RCDPRTP",51,0)
Q
"RTN","RCDPRTP",52,0)
;
"RTN","RCDPRTP",53,0)
3 ;
"RTN","RCDPRTP",54,0)
D DATESEL^RCRJRTRA("Payment")
"RTN","RCDPRTP",55,0)
I '$G(DATESTRT)!('$G(DATEEND)) S RCQUIT=1
"RTN","RCDPRTP",56,0)
Q
"RTN","RCDPRTP",57,0)
;
"RTN","RCDPRTP",58,0)
2 ;
"RTN","RCDPRTP",59,0)
N DIC,DUOUT
"RTN","RCDPRTP",60,0)
K ^TMP("IBRBF",$J)
"RTN","RCDPRTP",61,0)
S DIC(0)="QEAM",DIC=430,DIC("S")="I $$SCRNARCT^RCDPRTP($P(^(0),U,2))" D ^DIC I Y<0 S RCQUIT=1 Q
"RTN","RCDPRTP",62,0)
S RCBILL=+Y,RCDFN=$P($G(^PRCA(430,+RCBILL,0)),"^",7) Q:'RCDFN
"RTN","RCDPRTP",63,0)
S RCDEBT=$O(^RCD(340,"B",RCDFN_";DPT(",0))
"RTN","RCDPRTP",64,0)
I (RCDFN="")!(RCDEBT="") W !,"This bill has no matching first party bills." G 2
"RTN","RCDPRTP",65,0)
D RELBILL^IBRFN(RCBILL)
"RTN","RCDPRTP",66,0)
I '$O(^TMP("IBRBF",$J,RCBILL,0)) W !,"This bill has no matching first party debts." K ^TMP("IBRBF",$J) G 2
"RTN","RCDPRTP",67,0)
K ^TMP("IBRBF",$J)
"RTN","RCDPRTP",68,0)
Q
"RTN","RCDPRTP",69,0)
;
"RTN","RCDPRTP",70,0)
4 ;
"RTN","RCDPRTP",71,0)
N DIC,X,Y
"RTN","RCDPRTP",72,0)
S DIC(0)="QEAM",DIC=344 D ^DIC I Y<0 S RCQUIT=1 Q
"RTN","RCDPRTP",73,0)
S RCPT=$P(Y,"^",2)
"RTN","RCDPRTP",74,0)
Q
"RTN","RCDPRTP",75,0)
;
"RTN","RCDPRTP",76,0)
5 ; Select care type - added in patch 315
"RTN","RCDPRTP",77,0)
D TYPEPIC^RCDPRTP0(.RCTYPE) I '$D(RCTYPE) S RCQUIT=1 Q
"RTN","RCDPRTP",78,0)
Q:RCQUIT
"RTN","RCDPRTP",79,0)
D DATESEL^RCRJRTRA("Payment")
"RTN","RCDPRTP",80,0)
I '$G(DATESTRT)!('$G(DATEEND)) S RCQUIT=1
"RTN","RCDPRTP",81,0)
Q
"RTN","RCDPRTP",82,0)
;
"RTN","RCDPRTP",83,0)
EXIT ;
"RTN","RCDPRTP",84,0)
K DATESTRT,DATEEND,RCEXCEL,^TMP("RCDPRTPB",$J),^TMP("IBRBT",$J)
"RTN","RCDPRTP",85,0)
K ^TMP("IBRBT1",$J),^TMP("IBRBF",$J),^TMP("IBRBF1",$J),RCTYPE
"RTN","RCDPRTP",86,0)
Q
"RTN","RCDPRTP",87,0)
;
"RTN","RCDPRTP",88,0)
;PRCA*4.5*338 - update AR Cat screen to include FEE and CC Reimb Ins Types
"RTN","RCDPRTP",89,0)
SCRNARCT(RCARCT) ;
"RTN","RCDPRTP",90,0)
;
"RTN","RCDPRTP",91,0)
Q:RCARCT=9 1 ;Allow Reimb Insurance
"RTN","RCDPRTP",92,0)
Q:RCARCT=45 1 ;Allow FEE Reimb Insurance
"RTN","RCDPRTP",93,0)
I RCARCT>47,(RCARCT<52) Q 1 ;Allow CC Reimb Insurances
"RTN","RCDPRTP",94,0)
Q 0 ;Disallow everything else
"RTN","RCDPRTP0")
0^17^B54790234
"RTN","RCDPRTP0",1,0)
RCDPRTP0 ;ALB/LDB - CLAIMS MATCHING REPORT ;5/24/00 10:48 AM
"RTN","RCDPRTP0",2,0)
;;4.5;Accounts Receivable;**151,315,339,338**;Mar 20, 1995;Build 70
"RTN","RCDPRTP0",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCDPRTP0",4,0)
;
"RTN","RCDPRTP0",5,0)
PAT ;find patient bills
"RTN","RCDPRTP0",6,0)
S RCNAM=$$NAM^RCFN01(RCDEBT)
"RTN","RCDPRTP0",7,0)
S RCSSN=$$SSN^RCFN01(RCDEBT)
"RTN","RCDPRTP0",8,0)
S RCBIL=0 F S RCBIL=$O(^PRCA(430,"E",RCDFN,RCBIL)) Q:'RCBIL D
"RTN","RCDPRTP0",9,0)
.I '$$SCRNARCT^RCDPRTP($P($G(^PRCA(430,+RCBIL,0)),"^",2)) Q
"RTN","RCDPRTP0",10,0)
.S RCPAY=0 F S RCPAY=$O(^PRCA(433,"C",RCBIL,RCPAY)) Q:'RCPAY D
"RTN","RCDPRTP0",11,0)
..S RCPAY1=$G(^PRCA(433,+RCPAY,1)) Q:RCPAY1=""
"RTN","RCDPRTP0",12,0)
..I "^2^34^"[("^"_$P(RCPAY1,"^",2)_"^"),($P(RCPAY1,"^",9)'<DATESTRT),($P(RCPAY1,"^",9)<(DATEEND_".999999")) D
"RTN","RCDPRTP0",13,0)
...S DFN=RCDFN D DEM^VADPT,ELIG^VADPT
"RTN","RCDPRTP0",14,0)
...S RCTYPE=$$TYP^IBRFN(RCBIL) ; added care type - 315
"RTN","RCDPRTP0",15,0)
...S RCTYPE=$S(RCTYPE="":-1,RCTYPE="PR":"P",RCTYPE="PH":"R",1:RCTYPE)
"RTN","RCDPRTP0",16,0)
...I $D(RCTYPE(RCTYPE)) D Q:'RCTYPE
"RTN","RCDPRTP0",17,0)
....S ^TMP("RCDPRTPB",$J,RCNAM)=$P($G(VADM(3)),"^",2)_"^"_$P($G(VAEL(1)),"^",2)_"^"_RCSSN
"RTN","RCDPRTP0",18,0)
....S ^TMP("RCDPRTPB",$J,RCNAM,RCBIL)=$P($P(RCPAY1,"^",9),".")
"RTN","RCDPRTP0",19,0)
....K DFN,VA,VADM,VAEL,VAERR
"RTN","RCDPRTP0",20,0)
K RCDFN,RCDEBT
"RTN","RCDPRTP0",21,0)
Q
"RTN","RCDPRTP0",22,0)
;
"RTN","RCDPRTP0",23,0)
DATE ;find third party bills by date of payments
"RTN","RCDPRTP0",24,0)
N RCDFN,RCDEBT
"RTN","RCDPRTP0",25,0)
F RCTYP=2,34 S DAT=$$FMADD^XLFDT(DATESTRT,-1)_".999999" F S DAT=$O(^PRCA(433,"AT",RCTYP,DAT)) Q:'DAT!(DAT>(DATEEND_".999999")) D
"RTN","RCDPRTP0",26,0)
.S RCPAY=0 F S RCPAY=$O(^PRCA(433,"AT",RCTYP,DAT,RCPAY)) Q:'RCPAY D
"RTN","RCDPRTP0",27,0)
..S RCBIL=$P($G(^PRCA(433,+RCPAY,0)),"^",2)
"RTN","RCDPRTP0",28,0)
..S RCBIL0=$G(^PRCA(430,+RCBIL,0)) Q:RCBIL0=""
"RTN","RCDPRTP0",29,0)
..Q:'$$SCRNARCT^RCDPRTP($P(RCBIL0,"^",2)) ;PRCA*4.5*338
"RTN","RCDPRTP0",30,0)
..S RCDFN=$P(RCBIL0,"^",7)
"RTN","RCDPRTP0",31,0)
..S RCDEBT=$O(^RCD(340,"B",RCDFN_";DPT(",0)) Q:'RCDEBT
"RTN","RCDPRTP0",32,0)
..S RCNAM=$$NAM^RCFN01(RCDEBT)
"RTN","RCDPRTP0",33,0)
..S RCSSN=$$SSN^RCFN01(RCDEBT)
"RTN","RCDPRTP0",34,0)
..S DFN=RCDFN D DEM^VADPT,ELIG^VADPT
"RTN","RCDPRTP0",35,0)
..S ^TMP("RCDPRTPB",$J,RCNAM_"^"_RCDEBT)=$P($G(VADM(3)),"^",2)_"^"_$P($G(VAEL(1)),"^",2)_"^"_RCSSN
"RTN","RCDPRTP0",36,0)
..S ^TMP("RCDPRTPB",$J,RCNAM_"^"_RCDEBT,RCBIL)=$P(DAT,".")
"RTN","RCDPRTP0",37,0)
..K DFN,VA,VADM,VAEL,VAERR
"RTN","RCDPRTP0",38,0)
Q
"RTN","RCDPRTP0",39,0)
;
"RTN","RCDPRTP0",40,0)
TYPE ;find third party bills by care type PRCA*4.5*315
"RTN","RCDPRTP0",41,0)
N RCDFN,RCDEBT,RCTYP
"RTN","RCDPRTP0",42,0)
F RCTYP=2,34 S DAT=$$FMADD^XLFDT(DATESTRT,-1)_".999999" F S DAT=$O(^PRCA(433,"AT",RCTYP,DAT)) Q:'DAT!(DAT>(DATEEND_".999999")) D
"RTN","RCDPRTP0",43,0)
.S RCPAY=0 F S RCPAY=$O(^PRCA(433,"AT",RCTYP,DAT,RCPAY)) Q:'RCPAY D
"RTN","RCDPRTP0",44,0)
..S RCBIL=$P($G(^PRCA(433,+RCPAY,0)),"^",2)
"RTN","RCDPRTP0",45,0)
..S RCBIL0=$G(^PRCA(430,+RCBIL,0)) Q:RCBIL0=""
"RTN","RCDPRTP0",46,0)
..Q:'$$SCRNARCT^RCDPRTP($P(RCBIL0,"^",2)) ;PRCA*4.5*338
"RTN","RCDPRTP0",47,0)
..S RCDFN=$P(RCBIL0,"^",7)
"RTN","RCDPRTP0",48,0)
..S RCDEBT=$O(^RCD(340,"B",RCDFN_";DPT(",0)) Q:'RCDEBT
"RTN","RCDPRTP0",49,0)
..S RCNAM=$$NAM^RCFN01(RCDEBT)
"RTN","RCDPRTP0",50,0)
..S RCSSN=$$SSN^RCFN01(RCDEBT)
"RTN","RCDPRTP0",51,0)
..S DFN=RCDFN D DEM^VADPT,ELIG^VADPT
"RTN","RCDPRTP0",52,0)
..S RCTYPE=$$TYP^IBRFN(RCBIL)
"RTN","RCDPRTP0",53,0)
..S RCTYPE=$S(RCTYPE="":-1,RCTYPE="PR":"P",RCTYPE="PH":"R",1:RCTYPE)
"RTN","RCDPRTP0",54,0)
..I $D(RCTYPE(RCTYPE)) D Q:'RCTYPE
"RTN","RCDPRTP0",55,0)
...S ^TMP("RCDPRTPB",$J,RCNAM_"^"_RCDEBT)=$P($G(VADM(3)),"^",2)_"^"_$P($G(VAEL(1)),"^",2)_"^"_RCSSN
"RTN","RCDPRTP0",56,0)
...S ^TMP("RCDPRTPB",$J,RCNAM_"^"_RCDEBT,RCBIL)=$P(DAT,".")
"RTN","RCDPRTP0",57,0)
...K DFN,VA,VADM,VAEL,VAERR
"RTN","RCDPRTP0",58,0)
Q
"RTN","RCDPRTP0",59,0)
BILL ;set TMP array
"RTN","RCDPRTP0",60,0)
S RCDEBT=$O(^RCD(340,"B",RCDFN_";DPT(",0)) Q:'RCDEBT
"RTN","RCDPRTP0",61,0)
S RCNAM=$$NAM^RCFN01(RCDEBT)
"RTN","RCDPRTP0",62,0)
S RCSSN=$$SSN^RCFN01(RCDEBT)
"RTN","RCDPRTP0",63,0)
S DFN=+$G(^RCD(340,RCDEBT,0))
"RTN","RCDPRTP0",64,0)
D DEM^VADPT,ELIG^VADPT
"RTN","RCDPRTP0",65,0)
S RCTP=0 F S RCTP=$O(^PRCA(433,"C",RCBILL,RCTP)) Q:'RCTP I "^2^34^"[("^"_$P($G(^PRCA(433,+RCTP,1)),"^",2)_"^") S RCTP(0)=$P($P($G(^PRCA(433,+RCTP,1)),"^",9),".")
"RTN","RCDPRTP0",66,0)
S ^TMP("RCDPRTPB",$J,RCNAM)=$P($G(VADM(3)),"^",2)_"^"_$P($G(VAEL(1)),"^",2)_"^"_RCSSN
"RTN","RCDPRTP0",67,0)
S ^TMP("RCDPRTPB",$J,RCNAM,RCBILL)=RCTP
"RTN","RCDPRTP0",68,0)
K DFN,VA,VADM,VAEL,VAERR,RCBILL,RCTP
"RTN","RCDPRTP0",69,0)
Q
"RTN","RCDPRTP0",70,0)
;
"RTN","RCDPRTP0",71,0)
REC ;find receipt payments
"RTN","RCDPRTP0",72,0)
N RCDEBT,RCDFN,RCREC1,RCPAY1,RCBIL,RCBIL0,RCDFN,RCDEBT,RCSSN
"RTN","RCDPRTP0",73,0)
S RCREC1=0 F S RCREC1=$O(^PRCA(433,"AF",RCPT,RCREC1)) Q:'RCREC1 D
"RTN","RCDPRTP0",74,0)
.S RCPAY1=$G(^PRCA(433,+RCREC1,1)) Q:RCPAY1=""
"RTN","RCDPRTP0",75,0)
.S RCBIL=0 I "^2^34^"[("^"_$P(RCPAY1,"^",2)_"^") S RCBIL=$P($G(^PRCA(433,+RCREC1,0)),"^",2)
"RTN","RCDPRTP0",76,0)
.Q:'RCBIL
"RTN","RCDPRTP0",77,0)
.S RCBIL0=$G(^PRCA(430,+RCBIL,0))
"RTN","RCDPRTP0",78,0)
.Q:'$$SCRNARCT^RCDPRTP($P(RCBIL0,"^",2)) ;PRCA*4.5*338
"RTN","RCDPRTP0",79,0)
.S RCDFN=$P(RCBIL0,"^",7) Q:'RCDFN
"RTN","RCDPRTP0",80,0)
.S RCDEBT=$O(^RCD(340,"B",RCDFN_";DPT(",0)) Q:'RCDEBT
"RTN","RCDPRTP0",81,0)
.S RCSSN=$$SSN^RCFN01(RCDEBT)
"RTN","RCDPRTP0",82,0)
.S RCNAM=$$NAM^RCFN01(RCDEBT)
"RTN","RCDPRTP0",83,0)
.S DFN=RCDFN D DEM^VADPT,ELIG^VADPT
"RTN","RCDPRTP0",84,0)
.S ^TMP("RCDPRTPB",$J,RCNAM_"^"_RCDEBT)=$P($G(VADM(3)),"^",2)_"^"_$P($G(VAEL(1)),"^",2)_"^"_RCSSN
"RTN","RCDPRTP0",85,0)
.K DFN,VA,VADM,VAEL,VAERR
"RTN","RCDPRTP0",86,0)
.S ^TMP("RCDPRTPB",$J,RCNAM_"^"_RCDEBT,RCBIL)=$P($P($G(^PRCA(433,+RCREC1,1)),"^",9),".")
"RTN","RCDPRTP0",87,0)
Q
"RTN","RCDPRTP0",88,0)
;
"RTN","RCDPRTP0",89,0)
TYPEPIC(RCTYPE) ; function for user selection of care types PRCA*4.5*315
"RTN","RCDPRTP0",90,0)
; RCTYPE is an output array, pass by reference
"RTN","RCDPRTP0",91,0)
; RCTYPE(type)="" where type can be (I)npatient, (O)utpatient,(P)rosthetics or (R)x (Prescription)
"RTN","RCDPRTP0",92,0)
; Function value is 1 if at least 1 care type was selected, 0 otherwise
"RTN","RCDPRTP0",93,0)
; User can select one, all or a combination of care types.
"RTN","RCDPRTP0",94,0)
;
"RTN","RCDPRTP0",95,0)
N DIR,X,Y,OK,DTOUT,DUOUT,DIRUT,DIROUT,RC
"RTN","RCDPRTP0",96,0)
K RCTYPE
"RTN","RCDPRTP0",97,0)
S OK=1 ; all OK default
"RTN","RCDPRTP0",98,0)
S DIR(0)="S"
"RTN","RCDPRTP0",99,0)
S RC=";I:Inpatient"
"RTN","RCDPRTP0",100,0)
S RC=RC_";O:Outpatient"
"RTN","RCDPRTP0",101,0)
S RC=RC_";P:Prosthetic"
"RTN","RCDPRTP0",102,0)
S RC=RC_";R:Prescription"
"RTN","RCDPRTP0",103,0)
S RC=RC_";ALL:All"
"RTN","RCDPRTP0",104,0)
S $P(DIR(0),U,2)=RC,DIR("B")="ALL"
"RTN","RCDPRTP0",105,0)
S DIR("A")="Select a Care Type"
"RTN","RCDPRTP0",106,0)
W ! D ^DIR K DIR
"RTN","RCDPRTP0",107,0)
I (Y["A") D Q ; all types selected so set & quit
"RTN","RCDPRTP0",108,0)
. F X="I","O","P","R" S RCTYPE(X)=""
"RTN","RCDPRTP0",109,0)
. Q
"RTN","RCDPRTP0",110,0)
I $D(DIRUT)!(Y="") Q
"RTN","RCDPRTP0",111,0)
S X=$$UP^XLFSTR(X)
"RTN","RCDPRTP0",112,0)
S RCTYPE(X)="" ; Toggle back on
"RTN","RCDPRTP0",113,0)
; Select another type
"RTN","RCDPRTP0",114,0)
I (Y'["A") F D Q:X=""!(RCQUIT)
"RTN","RCDPRTP0",115,0)
. I ($G(DIRUT)'="") S OK=0,RCQUIT=1 Q
"RTN","RCDPRTP0",116,0)
. S DIR(0)="SBO^I:Inpatient;O:Outpatient;P:Prosthetic;R:Prescription"
"RTN","RCDPRTP0",117,0)
. S DIR("A")="Select another Care Type" D ^DIR K DIR
"RTN","RCDPRTP0",118,0)
. I $G(DUOUT) W !!,"User exited with '^', quitting",! S RCQUIT=1 Q
"RTN","RCDPRTP0",119,0)
. I $D(DIRUT) S OK=0 Q
"RTN","RCDPRTP0",120,0)
. I (X="") Q
"RTN","RCDPRTP0",121,0)
. S X=$$UP^XLFSTR(X)
"RTN","RCDPRTP0",122,0)
. S RCTYPE(X)=""
"RTN","RCDPRTP0",123,0)
. Q
"RTN","RCDPRTP0",124,0)
I $D(DUOUT)!$D(DTOUT) S OK=0 ; exit if "^" or time-out
"RTN","RCDPRTP0",125,0)
I '$D(RCTYPE) S OK=0 W $C(7)
"RTN","RCDPRTP0",126,0)
Q OK
"RTN","RCDPRTP0",127,0)
;
"RTN","RCDPRTP0",128,0)
FORMAT(RCEXCEL) ; capture the report format from the user (normal or CSV output) PRCA*4.5*315
"RTN","RCDPRTP0",129,0)
; RCEXCEL=0 for normal output
"RTN","RCDPRTP0",130,0)
; RCEXCEL=1 (^ separated values) for Excel output
"RTN","RCDPRTP0",131,0)
; pass parameter by reference
"RTN","RCDPRTP0",132,0)
;
"RTN","RCDPRTP0",133,0)
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","RCDPRTP0",134,0)
S RCEXCEL=0
"RTN","RCDPRTP0",135,0)
S DIR("A")="Do you want to capture report data for an Excel document"
"RTN","RCDPRTP0",136,0)
S DIR("B")="NO"
"RTN","RCDPRTP0",137,0)
S DIR(0)="Y"
"RTN","RCDPRTP0",138,0)
S DIR("?",1)="If you want to capture the output from this report in a ^-separated"
"RTN","RCDPRTP0",139,0)
S DIR("?",2)="values (Excel) format, then answer YES here."
"RTN","RCDPRTP0",140,0)
S DIR("?",3)=" "
"RTN","RCDPRTP0",141,0)
S DIR("?")="If you just want a normal report output, then answer NO here."
"RTN","RCDPRTP0",142,0)
W ! D ^DIR K DIR
"RTN","RCDPRTP0",143,0)
I $D(DIRUT) S RCQUIT=1 Q 0 ; get out
"RTN","RCDPRTP0",144,0)
S RCEXCEL=Y
"RTN","RCDPRTP0",145,0)
Q RCEXCEL
"RTN","RCDPRTP0",146,0)
;
"RTN","RCDPRTP0",147,0)
DEVICE ; Device Selection for Excel output PRCA*4.5*315
"RTN","RCDPRTP0",148,0)
; RCEXCEL=1 for Excel ('^' separated values) output
"RTN","RCDPRTP0",149,0)
;
"RTN","RCDPRTP0",150,0)
N ZTRTN,ZTDESC,ZTSAVE,POP,ZTSK,DIR,X,Y,DIRUT,DTOUT,DUOUT,DIROUT
"RTN","RCDPRTP0",151,0)
D EXMSG
"RTN","RCDPRTP0",152,0)
;
"RTN","RCDPRTP0",153,0)
S ZTRTN="PRINT^RCDPRTEX"
"RTN","RCDPRTP0",154,0)
S ZTDESC="Claims Matching Excel Report"
"RTN","RCDPRTP0",155,0)
S ZTSAVE("DATEEND")="",ZTSAVE("DATESTRT")="",ZTSAVE("RCQUIT")="",ZTSAVE("RCSORT")="",ZTSAVE("RCEXCEL")=""
"RTN","RCDPRTP0",156,0)
S ZTSAVE("RCAN")="",ZTSAVE("ZTREQ")="@",ZTSAVE("^TMP(""RCDPRTPB"",$J,")=""
"RTN","RCDPRTP0",157,0)
I RCSORT=1 S ZTSAVE("RCDEBT")="",ZTSAVE("RCDFN")="",ZTSAVE("RCTYPE*")=""
"RTN","RCDPRTP0",158,0)
I RCSORT=2 S ZTSAVE("RCBILL")="",ZTSAVE("RCDFN")="",ZTSAVE("RCDEBT")=""
"RTN","RCDPRTP0",159,0)
I RCSORT=4 S ZTSAVE("RCPT")=""
"RTN","RCDPRTP0",160,0)
I RCSORT=5 S ZTSAVE("RCTYPE*")="",ZTSAVE("DATE*")=""
"RTN","RCDPRTP0",161,0)
;
"RTN","RCDPRTP0",162,0)
D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,"QM",1) Q:POP
"RTN","RCDPRTP0",163,0)
I $G(ZTSK) W !!,"Report compilation has started with task# ",ZTSK,".",! S DIR(0)="E" D ^DIR K DIR
"RTN","RCDPRTP0",164,0)
Q
"RTN","RCDPRTP0",165,0)
;
"RTN","RCDPRTP0",166,0)
EXMSG ; - Displays the message about capturing to an Excel file format
"RTN","RCDPRTP0",167,0)
;
"RTN","RCDPRTP0",168,0)
W !!?5,"This report may take a while to run. It is recommended that you Queue it."
"RTN","RCDPRTP0",169,0)
W !!?5,"To capture as an Excel format, it is recommended that you queue this"
"RTN","RCDPRTP0",170,0)
W !?5,"report to a spool device with margins of 256 and page length of 99999"
"RTN","RCDPRTP0",171,0)
W !?5,"(e.g. spoolname;256;99999). This should help avoid wrapping problems."
"RTN","RCDPRTP0",172,0)
W !!?5,"Another method would be to set up your terminal to capture the detail"
"RTN","RCDPRTP0",173,0)
W !?5,"report data. On some terminals, this can be done by clicking on the"
"RTN","RCDPRTP0",174,0)
W !?5,"'Tools' menu above, then click on 'Capture Incoming Data' to save to"
"RTN","RCDPRTP0",175,0)
W !?5,"Desktop. To avoid undesired wrapping of the data saved to the file,"
"RTN","RCDPRTP0",176,0)
W !?5,"please enter '0;256;99999' at the 'DEVICE:' prompt.",!
"RTN","RCDPRTP0",177,0)
Q
"RTN","RCDPRTP0",178,0)
;
"RTN","RCDPRTP2")
0^22^B20901251
"RTN","RCDPRTP2",1,0)
RCDPRTP2 ;ALB/LDB - CLAIMS MATCHING REPORT ;1/26/01 3:16 PM
"RTN","RCDPRTP2",2,0)
;;4.5;Accounts Receivable;**151,276,303,315,338**;Mar 20, 1995;Build 70
"RTN","RCDPRTP2",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCDPRTP2",4,0)
;
"RTN","RCDPRTP2",5,0)
; Reference to $$TYP^IBRFN supported by DBIA# 2031
"RTN","RCDPRTP2",6,0)
;
"RTN","RCDPRTP2",7,0)
PRINT1 ;
"RTN","RCDPRTP2",8,0)
N REJECT,RCTYP
"RTN","RCDPRTP2",9,0)
; double check the status to screen out cancelled third party bills
"RTN","RCDPRTP2",10,0)
I 'RCAN N TSTAT S TSTAT=$$STAT(RCTP) Q:TSTAT="CN"!(TSTAT="CB") ;Added a last minute check for cancelled third party bills
"RTN","RCDPRTP2",11,0)
;
"RTN","RCDPRTP2",12,0)
I $Y>(IOSL-2) D PAUSE Q:$G(RCQ) D HDR^RCDPRTP1,HDR1
"RTN","RCDPRTP2",13,0)
; PRCA*4.5*276 - get EEOB indicator '%'and attach it to the bill number when applicable. Adjust report tabs to make room for EEOB indicator '%'.
"RTN","RCDPRTP2",14,0)
N RC430 S RC430=+$O(^PRCA(430,"B",""_$P(RCIBDAT,"^",4)_"",0))
"RTN","RCDPRTP2",15,0)
S RCEEOB=$$EEOB(RC430)
"RTN","RCDPRTP2",16,0)
; #IA 6060 for $$BILLREJ^IBJTU6
"RTN","RCDPRTP2",17,0)
S REJECT=$S($$BILLREJ^IBJTU6($P($P(RCIBDAT,"^",4),"-",2)):"c",1:" ") ;PRCA*4.5*303 Add indicator for rejects
"RTN","RCDPRTP2",18,0)
W !,$S(RCTP=RCBILL:"*",$D(RCTP(RCTP)):"*",1:" "),$G(RCEEOB)_REJECT_$P(RCIBDAT,"^",4),?17,$P(RCIBDAT,"^",5),?24
"RTN","RCDPRTP2",19,0)
W $$STAT(RCTP),?31,$$DATE(+RCIBDAT),?42,$$DATE($P(RCIBDAT,"^",2))
"RTN","RCDPRTP2",20,0)
S Y=$S($G(RCTP(RCTP)):RCTP(RCTP),$G(^TMP("RCDPRTPB",$J,RCNAM,RCBILL)):^(RCBILL),1:"") I RCTP=RCBILL!($D(RCTP(RCTP))) W ?53,$$DATE(Y)
"RTN","RCDPRTP2",21,0)
S RCAMT=$P($G(^PRCA(430,+RCTP,0)),"^",3),RCAMT1=$P($G(^PRCA(430,+RCTP,7)),"^",7) W ?64,$J(RCAMT,9,2)
"RTN","RCDPRTP2",22,0)
W ?76,$J(RCAMT1,9,2) S RCAMT(0)=RCAMT(0)+RCAMT,RCAMT(1)=RCAMT(1)+RCAMT1
"RTN","RCDPRTP2",23,0)
W ?88,$E($P(RCIBDAT,"^",7),1,25)
"RTN","RCDPRTP2",24,0)
; #IA 2031 for $$TYP^IBRFN
"RTN","RCDPRTP2",25,0)
S RCTYP=$$TYP^IBRFN(RCTP) ; get bill type for an Accounts Receivable
"RTN","RCDPRTP2",26,0)
; Convert to single character care types for:
"RTN","RCDPRTP2",27,0)
; (I)npatient, (O)utpatient, (R)Prescription & (P)rosthetics
"RTN","RCDPRTP2",28,0)
S RCTYP=$S(RCTYP="":-1,RCTYP="PR":"P",RCTYP="PH":"R",1:RCTYP)
"RTN","RCDPRTP2",29,0)
W ?119,RCTYP
"RTN","RCDPRTP2",30,0)
K RCTP(RCTP)
"RTN","RCDPRTP2",31,0)
Q
"RTN","RCDPRTP2",32,0)
;
"RTN","RCDPRTP2",33,0)
PRINT2 ; Print the detail line for a first party bill.
"RTN","RCDPRTP2",34,0)
I $Y>(IOSL-2) D PAUSE Q:$G(RCQ) D HDR^RCDPRTP1,HDR2
"RTN","RCDPRTP2",35,0)
W !," ",$P(RCIBDAT,"^",4),?14,$E($P(RCIBDAT,"^",6),1,18) ;PRCA*4.5*338
"RTN","RCDPRTP2",36,0)
S RCIBFN=$P(RCIBDAT,"^",4) I RCIBFN S RCIBFN=$O(^PRCA(430,"B",RCIBFN,0))
"RTN","RCDPRTP2",37,0)
; PRCA*4.5*276 - adjust report tabs to make room for EEOB indicator '%'.
"RTN","RCDPRTP2",38,0)
W ?36,$$STAT(RCIBFN),?42,$$DATE(+RCIBDAT),?54,$$DATE($P(RCIBDAT,"^",2))
"RTN","RCDPRTP2",39,0)
W ?66,$J($P(RCIBDAT,"^",5),9,2),?78,$P(RCIBDAT,"^",7)
"RTN","RCDPRTP2",40,0)
W ?87,$J($S($G(^PRCA(430,+RCIBFN,7)):+($P(^(7),"^")+$P(^(7),"^",2)+$P(^(7),"^",3)+$P(^(7),"^",4)+$P(^(7),"^",4)),1:0),9,2)
"RTN","RCDPRTP2",41,0)
Q
"RTN","RCDPRTP2",42,0)
;
"RTN","RCDPRTP2",43,0)
;
"RTN","RCDPRTP2",44,0)
PRINT3 ; Print patient detail information.
"RTN","RCDPRTP2",45,0)
N RCNAM1,RCBILL0,RCDFN,RCDOB,DOB
"RTN","RCDPRTP2",46,0)
I $Y>(IOSL-5) D PAUSE Q:$G(RCQ) D HDR^RCDPRTP1
"RTN","RCDPRTP2",47,0)
S RCNAM1=^TMP("RCDPRTPB",$J,RCNAM)
"RTN","RCDPRTP2",48,0)
S RCBILL0=$G(^PRCA(430,RCBILL,0)) ;PRCA*4.3*315
"RTN","RCDPRTP2",49,0)
S RCDFN=$P($G(^PRCA(430,RCBILL,0)),U,7)
"RTN","RCDPRTP2",50,0)
S RCDOB=$P($G(^DPT(RCDFN,0)),U,3)
"RTN","RCDPRTP2",51,0)
S DOB=$$FMTE^XLFDT(RCDOB,"5Z")
"RTN","RCDPRTP2",52,0)
W !!,RCLINE
"RTN","RCDPRTP2",53,0)
W !,"NAME: ",$P(RCNAM,"^"),?44,"SSN: ",$E(RCNAM,1)_$E($P(RCNAM1,"^",3),6,9)
"RTN","RCDPRTP2",54,0)
W !,"Prim. Elig: ",$P(RCNAM1,"^",2)
"RTN","RCDPRTP2",55,0)
W ?44,"DOB: ",DOB
"RTN","RCDPRTP2",56,0)
W ?61,"RX COVERAGE: ",$S('$G(^TMP("IBRBT",$J,RCBILL)):"NO",1:"YES")
"RTN","RCDPRTP2",57,0)
W !,RCLINE
"RTN","RCDPRTP2",58,0)
Q
"RTN","RCDPRTP2",59,0)
;
"RTN","RCDPRTP2",60,0)
HDR1 ;
"RTN","RCDPRTP2",61,0)
W !!,"Third Party Bills: * -> bill for which payment was posted"
"RTN","RCDPRTP2",62,0)
W !,"============================="
"RTN","RCDPRTP2",63,0)
; PRCA*4.5*276 - adjust report tabs to make room for EEOB indicator '%'.
"RTN","RCDPRTP2",64,0)
; PRCA*4.5*315 - added 1-char. care type (I)npatient, (O)utpatient, (R)x or (P)rosthetics) under new Type column
"RTN","RCDPRTP2",65,0)
W !!,"Bill #",?15,"P/S/T",?22,"Status",?30,"Bill From",?42,"Bill To",?53,"Posted",?63,"Amt Billed",?76,"Amt Paid",?88,"Payor",?115,"Care Type"
"RTN","RCDPRTP2",66,0)
W !,"-------------",?15,"-----",?22,"------",?30,"---------",?42,"--------",?53,"--------",?63,"----------",?75,"----------",?88,"-------------------------",?115,"---------"
"RTN","RCDPRTP2",67,0)
Q
"RTN","RCDPRTP2",68,0)
;
"RTN","RCDPRTP2",69,0)
HDR2 ;
"RTN","RCDPRTP2",70,0)
W !!,"Associated First Party Charges:"
"RTN","RCDPRTP2",71,0)
W !,"==============================="
"RTN","RCDPRTP2",72,0)
W !," Bill #",?14,"Charge Type",?34,"Status",?42,"From/Fill",?54,"To/Rel",?65,"Amt Billed",?78,"On Hold",?87," Balance"
"RTN","RCDPRTP2",73,0)
W !,"-----------",?14,"----------------",?34,"------",?42,"---------",?54,"---------",?65,"----------",?78,"-------",?87," ----------"
"RTN","RCDPRTP2",74,0)
Q
"RTN","RCDPRTP2",75,0)
;
"RTN","RCDPRTP2",76,0)
STAT(RCIBFN) ;AR Status
"RTN","RCDPRTP2",77,0)
I '$G(RCIBFN) Q ""
"RTN","RCDPRTP2",78,0)
N RCSTAT
"RTN","RCDPRTP2",79,0)
S RCSTAT=$P($G(^PRCA(430,+RCIBFN,0)),"^",8),RCSTAT=$P($G(^PRCA(430.3,+RCSTAT,0)),"^",2)
"RTN","RCDPRTP2",80,0)
Q RCSTAT
"RTN","RCDPRTP2",81,0)
;
"RTN","RCDPRTP2",82,0)
DATE(X) ; Convert FileMan date to mm/dd/yy
"RTN","RCDPRTP2",83,0)
Q $S($G(X):$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3),1:"")
"RTN","RCDPRTP2",84,0)
;
"RTN","RCDPRTP2",85,0)
;
"RTN","RCDPRTP2",86,0)
PAUSE ; Page break.
"RTN","RCDPRTP2",87,0)
I $E(IOST,1,2)'="C-" Q
"RTN","RCDPRTP2",88,0)
N RCX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
"RTN","RCDPRTP2",89,0)
I IOSL<100 F RCX=$Y:1:(IOSL-3) W !
"RTN","RCDPRTP2",90,0)
S DIR(0)="E" D ^DIR I $D(DIRUT)!($D(DUOUT)) S RCQ=1
"RTN","RCDPRTP2",91,0)
Q
"RTN","RCDPRTP2",92,0)
;
"RTN","RCDPRTP2",93,0)
EEOB(RCBILL) ; PRCA*4.5*276 - get EEOB indicator for a bill
"RTN","RCDPRTP2",94,0)
; Interaction with IB file #361.1 covered by IA #4051.
"RTN","RCDPRTP2",95,0)
; RCBILL is the IEN of the bill in files #399/#430 and must be valid,
"RTN","RCDPRTP2",96,0)
; Exclude an EOB type of MRA when getting payment information. Return
"RTN","RCDPRTP2",97,0)
; the EEOB indicator '%' if payment activity was found.
"RTN","RCDPRTP2",98,0)
;
"RTN","RCDPRTP2",99,0)
N RCEEOB,RCVAL,Z
"RTN","RCDPRTP2",100,0)
I $G(RCBILL)=0 Q ""
"RTN","RCDPRTP2",101,0)
I '$O(^IBM(361.1,"B",RCBILL,0)) Q "" ; no matching entry for bill
"RTN","RCDPRTP2",102,0)
I $P($G(^DGCR(399,RCBILL,0)),"^",13)=1 Q "" ;avoid 'ENTERED/NOT REVIEWED' status
"RTN","RCDPRTP2",103,0)
; handle both single and multiple bill entries in file #361.1
"RTN","RCDPRTP2",104,0)
S Z=0 F S Z=$O(^IBM(361.1,"B",RCBILL,Z)) Q:'Z D Q:$G(RCEEOB)="%"
"RTN","RCDPRTP2",105,0)
. S RCVAL=$G(^IBM(361.1,Z,0))
"RTN","RCDPRTP2",106,0)
. S RCEEOB=$S($P(RCVAL,"^",4)=1:"",$P(RCVAL,"^",4)=0:"%",1:"")
"RTN","RCDPRTP2",107,0)
Q RCEEOB ; EEOB indicator for 1st/3rd party payment on bill
"RTN","RCRJRBD")
0^8^B99557360
"RTN","RCRJRBD",1,0)
RCRJRBD ;WISC/RFJ,TJK-bad debt extractor and report ;10/18/10 9:00am
"RTN","RCRJRBD",2,0)
;;4.5;Accounts Receivable;**101,139,170,193,203,215,220,138,239,273,282,310,315,340,338**;Mar 20, 1995;Build 70
"RTN","RCRJRBD",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCRJRBD",4,0)
; IA 4385 for calls to $$MRATYPE^IBCEMU2 and $$MRADTACT^IBCEMU2
"RTN","RCRJRBD",5,0)
Q
"RTN","RCRJRBD",6,0)
;
"RTN","RCRJRBD",7,0)
;
"RTN","RCRJRBD",8,0)
START(DATEEND) ; run bad debt report
"RTN","RCRJRBD",9,0)
; the DATEEND is the last day of the month being run
"RTN","RCRJRBD",10,0)
; from the routine RCRJRCOL which is the data extractor. The
"RTN","RCRJRBD",11,0)
; current receivable dollars is stored in ^TMP($J,"RCRJRBD",SGL)
"RTN","RCRJRBD",12,0)
; where SGL is the standard general ledger 1319, 1338, or 1339.
"RTN","RCRJRBD",13,0)
;
"RTN","RCRJRBD",14,0)
N ACTDATE,ACTUALCA,ACTUALWO,BEGDATE,BILLDA,CATEGORY
"RTN","RCRJRBD",15,0)
N COLLECT,CONTRACT,DR,ENDDATE,FUND,PAY,PAYMENT,PRIN,PRINCPAL
"RTN","RCRJRBD",16,0)
N RCRJFMM,RCRJDATE,SGL,TRANDA,TRANDATE,TRANTYPE,VALUE,WRITEOFF
"RTN","RCRJRBD",17,0)
N RCPRIN,RCTOMCCF,RCVALUE,RSC,MRATYPE,ARACTDT
"RTN","RCRJRBD",18,0)
;
"RTN","RCRJRBD",19,0)
; lock the bad debt file for storing data, lock cannot fail
"RTN","RCRJRBD",20,0)
; this lock can be used to monitor if the report is running
"RTN","RCRJRBD",21,0)
F L +^RC(348.1):$S($G(DILOCKTM)>5:DILOCKTM,1:5) Q:$T
"RTN","RCRJRBD",22,0)
;
"RTN","RCRJRBD",23,0)
; calculate the base percentages from past data
"RTN","RCRJRBD",24,0)
; example: DATEEND=2980331 => BEGDATE=2970300
"RTN","RCRJRBD",25,0)
; => ENDDATE=2980229
"RTN","RCRJRBD",26,0)
; add one day to ending date to go to next month
"RTN","RCRJRBD",27,0)
S BEGDATE=($E(DATEEND,1,3)-1)_$E(DATEEND,4,5)_"00"
"RTN","RCRJRBD",28,0)
S ENDDATE=($$FMADD^XLFDT($E(DATEEND,1,5)_"00",-1))+1
"RTN","RCRJRBD",29,0)
; loop bills activated between these dates
"RTN","RCRJRBD",30,0)
S ACTDATE=BEGDATE
"RTN","RCRJRBD",31,0)
F S ACTDATE=$O(^PRCA(430,"ACTDT",ACTDATE)) Q:'ACTDATE!(ACTDATE>ENDDATE) D
"RTN","RCRJRBD",32,0)
. S BILLDA=0 F S BILLDA=$O(^PRCA(430,"ACTDT",ACTDATE,BILLDA)) Q:'BILLDA D
"RTN","RCRJRBD",33,0)
. . S CATEGORY=+$P($G(^PRCA(430,BILLDA,0)),"^",2)
"RTN","RCRJRBD",34,0)
. . ; do not look at prepayments
"RTN","RCRJRBD",35,0)
. . I 'CATEGORY!(CATEGORY=26) Q
"RTN","RCRJRBD",36,0)
. . ;
"RTN","RCRJRBD",37,0)
. . ; only look at bills with a 0 principal balance
"RTN","RCRJRBD",38,0)
. . I $P($G(^PRCA(430,BILLDA,7)),"^") Q
"RTN","RCRJRBD",39,0)
. . ;
"RTN","RCRJRBD",40,0)
. . ; only report fund 528701,03,04,11 and 4032/528709 bills
"RTN","RCRJRBD",41,0)
. . ;PRCA*4.5*338 - grab existing FUND for bill. Only recalculate if FUND = NULL
"RTN","RCRJRBD",42,0)
. . S FUND=$$GET1^DIQ(430,BILLDA_",",203)
"RTN","RCRJRBD",43,0)
. . I FUND="" S FUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
"RTN","RCRJRBD",44,0)
. . ;end PRCA*4.5*338
"RTN","RCRJRBD",45,0)
. . I '$$PTACCT^PRCAACC(FUND),$E(FUND,1,4)'=4032 Q
"RTN","RCRJRBD",46,0)
. . ;
"RTN","RCRJRBD",47,0)
. . ; determine MRA type of bill, given bill# and bill active date
"RTN","RCRJRBD",48,0)
. . ; DBIA #4385 activated on 31-Mar-2004
"RTN","RCRJRBD",49,0)
. . S MRATYPE=$$MRATYPE^IBCEMU2(BILLDA,ACTDATE)
"RTN","RCRJRBD",50,0)
. . ;
"RTN","RCRJRBD",51,0)
. . ; derive standard general ledger (SGL) from cat/fund/MRA type
"RTN","RCRJRBD",52,0)
. . S SGL=$$BDRSGL(CATEGORY,FUND,MRATYPE)
"RTN","RCRJRBD",53,0)
. . ;
"RTN","RCRJRBD",54,0)
. . ; determine the original amount of the bill (add increase
"RTN","RCRJRBD",55,0)
. . ; adjustments below)
"RTN","RCRJRBD",56,0)
. . S PRIN=$P($G(^PRCA(430,BILLDA,0)),"^",3)
"RTN","RCRJRBD",57,0)
. . S PAY=0
"RTN","RCRJRBD",58,0)
. . ;
"RTN","RCRJRBD",59,0)
. . ; get the $ transations for bills
"RTN","RCRJRBD",60,0)
. . S TRANDA=0
"RTN","RCRJRBD",61,0)
. . F S TRANDA=$O(^PRCA(433,"C",BILLDA,TRANDA)) Q:'TRANDA D
"RTN","RCRJRBD",62,0)
. . . S TRANTYPE=$P($G(^PRCA(433,TRANDA,1)),"^",2)
"RTN","RCRJRBD",63,0)
. . . I "^1^73^2^34^43^"'[("^"_TRANTYPE_"^") Q ; *340 added 73
"RTN","RCRJRBD",64,0)
. . . S VALUE=$$TRANBAL^RCRJRCOT(TRANDA) I VALUE="" Q
"RTN","RCRJRBD",65,0)
. . . ; increase adjustments or re-establish
"RTN","RCRJRBD",66,0)
. . . I TRANTYPE=1!(TRANTYPE=73)!(TRANTYPE=43) S PRIN=PRIN+$P(VALUE,"^") Q ; *340 added 73
"RTN","RCRJRBD",67,0)
. . . ; payments
"RTN","RCRJRBD",68,0)
. . . I TRANTYPE=2!(TRANTYPE=34) S PAY=PAY+$P(VALUE,"^") Q
"RTN","RCRJRBD",69,0)
. . ;
"RTN","RCRJRBD",70,0)
. . ; payment cannot be greater than principle
"RTN","RCRJRBD",71,0)
. . I PAY>PRIN S PAY=PRIN
"RTN","RCRJRBD",72,0)
. . ;
"RTN","RCRJRBD",73,0)
. . ; store the data
"RTN","RCRJRBD",74,0)
. . S PRINCPAL(SGL)=$G(PRINCPAL(SGL))+PRIN
"RTN","RCRJRBD",75,0)
. . S PAYMENT(SGL)=$G(PAYMENT(SGL))+PAY
"RTN","RCRJRBD",76,0)
. . ;
"RTN","RCRJRBD",77,0)
;
"RTN","RCRJRBD",78,0)
; calculate the writeoffs from 2/0/98
"RTN","RCRJRBD",79,0)
; 2/0/98 is when fms cleared out actual writeoffs and contract adj
"RTN","RCRJRBD",80,0)
K ^XTMP("PRCABDET")
"RTN","RCRJRBD",81,0)
S ^XTMP("PRCABDET",0)=$$FMADD^XLFDT(DT,10)_"^"_DT_"^BAD DEBT REPORT AUDIT"
"RTN","RCRJRBD",82,0)
F TRANTYPE=8,9,10,11,35 D
"RTN","RCRJRBD",83,0)
. S TRANDATE=2980200
"RTN","RCRJRBD",84,0)
. ; do not pick up transactions after the end date
"RTN","RCRJRBD",85,0)
. F S TRANDATE=$O(^PRCA(433,"AT",TRANTYPE,TRANDATE)) Q:'TRANDATE!($P(TRANDATE,".")>DATEEND) D
"RTN","RCRJRBD",86,0)
. . S TRANDA=0 F S TRANDA=$O(^PRCA(433,"AT",TRANTYPE,TRANDATE,TRANDA)) Q:'TRANDA D
"RTN","RCRJRBD",87,0)
. . . ; do not look at decrease adj which are not contract adj
"RTN","RCRJRBD",88,0)
. . . I TRANTYPE=35,'$P($G(^PRCA(433,TRANDA,8)),"^",8) Q
"RTN","RCRJRBD",89,0)
. . . ;
"RTN","RCRJRBD",90,0)
. . . S BILLDA=$P($G(^PRCA(433,TRANDA,0)),"^",2)
"RTN","RCRJRBD",91,0)
. . . I 'BILLDA Q
"RTN","RCRJRBD",92,0)
. . . S CATEGORY=+$P($G(^PRCA(430,BILLDA,0)),"^",2)
"RTN","RCRJRBD",93,0)
. . . ; do not look at prepayments
"RTN","RCRJRBD",94,0)
. . . I 'CATEGORY!(CATEGORY=26) Q
"RTN","RCRJRBD",95,0)
. . . ;
"RTN","RCRJRBD",96,0)
. . . ; only report fund 528701,03,04,11 and 4032/528709 (ltc) bills
"RTN","RCRJRBD",97,0)
. . . ;PRCA*4.5*338 - grab existing FUND for bill. Only recalculate if FUND = NULL
"RTN","RCRJRBD",98,0)
. . . S FUND=$$GET1^DIQ(430,BILLDA_",",203)
"RTN","RCRJRBD",99,0)
. . . I FUND="" S FUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
"RTN","RCRJRBD",100,0)
. . . ;end PRCA*4.5*338
"RTN","RCRJRBD",101,0)
. . . I '$$PTACCT^PRCAACC(FUND),$E(FUND,1,4)'=4032 Q
"RTN","RCRJRBD",102,0)
. . . ;
"RTN","RCRJRBD",103,0)
. . . ; get bill active date
"RTN","RCRJRBD",104,0)
. . . S ARACTDT=+$P($P($G(^PRCA(430,BILLDA,6)),"^",21),".")
"RTN","RCRJRBD",105,0)
. . . ; determine MRA type of bill, given bill# and bill active date
"RTN","RCRJRBD",106,0)
. . . ; DBIA #4385 activated on 31-Mar-2004
"RTN","RCRJRBD",107,0)
. . . S MRATYPE=$$MRATYPE^IBCEMU2(BILLDA,ARACTDT)
"RTN","RCRJRBD",108,0)
. . . ;
"RTN","RCRJRBD",109,0)
. . . ; derive standard general ledger (SGL) from cat/fund/MRA type
"RTN","RCRJRBD",110,0)
. . . S SGL=$$BDRSGL(CATEGORY,FUND,MRATYPE)
"RTN","RCRJRBD",111,0)
. . . ;
"RTN","RCRJRBD",112,0)
. . . ; get the principal transaction value
"RTN","RCRJRBD",113,0)
. . . S RCVALUE=+$P($$TRANBAL^RCRJRCOT(TRANDA),"^")
"RTN","RCRJRBD",114,0)
. . . ; temp variable for value (used below)
"RTN","RCRJRBD",115,0)
. . . S RCPRIN=RCVALUE
"RTN","RCRJRBD",116,0)
. . . ;
"RTN","RCRJRBD",117,0)
. . . ; add actual writeoff amount for fiscal year
"RTN","RCRJRBD",118,0)
. . . I TRANTYPE'=35 S ACTUALWO(SGL)=$G(ACTUALWO(SGL))+RCVALUE
"RTN","RCRJRBD",119,0)
. . . ; add actual contract adjustments for fiscal year
"RTN","RCRJRBD",120,0)
. . . I TRANTYPE=35 S ACTUALCA(SGL)=$G(ACTUALCA(SGL))+RCVALUE
"RTN","RCRJRBD",121,0)
. . . ;PRCA*4.5*338 - retrieve RSC from Bill. If no RSC in BILL, calculate it.
"RTN","RCRJRBD",122,0)
. . . S RSC=$$GET1^DIQ(430,BILLDA_",",255.1) ;Check for accrued RSC
"RTN","RCRJRBD",123,0)
. . . S:RSC="" RSC=$$GET1^DIQ(430,BILLDA_",",255) ;if no accrued RSC, check for non-accrued.
"RTN","RCRJRBD",124,0)
. . . S:RSC="" RSC=$$CALCRSC^RCXFMSUR(BILLDA) ;if neither present, calculate
"RTN","RCRJRBD",125,0)
. . . ;end PRCA*4.5*338
"RTN","RCRJRBD",126,0)
. . . S ^XTMP("PRCABDET",BILLDA,CATEGORY,FUND,RSC,SGL,TRANDA,TRANDATE,TRANTYPE,RCPRIN,RCVALUE,0,0)=""
"RTN","RCRJRBD",127,0)
;
"RTN","RCRJRBD",128,0)
; remove all the entries from the bad debt file
"RTN","RCRJRBD",129,0)
D DELETALL
"RTN","RCRJRBD",130,0)
;
"RTN","RCRJRBD",131,0)
; calculate percentages and store them
"RTN","RCRJRBD",132,0)
; PRCA*4.5*338 - corrected 133.N3 to 133N.3, also added 1319.7, 1319.8, 1319.9
"RTN","RCRJRBD",133,0)
F SGL=1319,1319.2,1319.3,1319.4,1319.5,1319.6,1319.7,1319.8,1319.9,1338,1338.2,1338.3,1339,1339.1,"133N","133N.2","133N.3" D
"RTN","RCRJRBD",134,0)
. ; collection %
"RTN","RCRJRBD",135,0)
. S COLLECT=0 I $G(PRINCPAL(SGL)) S COLLECT=$J($G(PAYMENT(SGL))/PRINCPAL(SGL)*100,0,2)
"RTN","RCRJRBD",136,0)
. ; patch PRCA*4.5*138: for the first year from when MRA is activated at a site, there is no collection
"RTN","RCRJRBD",137,0)
. ; history for post-MRA non-Medicare bills(SGL 133N). So, to calculate the percentage for SGL 133N, the
"RTN","RCRJRBD",138,0)
. ; payment and the principal for SGL 1339 are used in the first year.
"RTN","RCRJRBD",139,0)
. ; override the collection value for SGL=133N for the first year from MRA activation.
"RTN","RCRJRBD",140,0)
. ;; Re-evaluate the calc. of the percentage for 133N as well as 1339.
"RTN","RCRJRBD",141,0)
. ;;I SGL="133N",$G(PRINCIPAL(1339)) D ;
"RTN","RCRJRBD",142,0)
. ;;. N X1,X2,X,%Y
"RTN","RCRJRBD",143,0)
. ;;. ; X2=MRA Activation Date, X1=Today, X=diff in days, %Y=0 invalid dates
"RTN","RCRJRBD",144,0)
. ;;. ; DBIA #4385 activated on 31-Mar-2004
"RTN","RCRJRBD",145,0)
. ;;. S X2=$$MRADTACT^IBCEMU2,X1=$$DT^XLFDT D ^%DTC
"RTN","RCRJRBD",146,0)
. ;;. I %Y,X'>364.25 S COLLECT=$J($G(PAYMENT(1339))/PRINCPAL(1339)*100,0,2)
"RTN","RCRJRBD",147,0)
. S DR=".02////"_+COLLECT_";"
"RTN","RCRJRBD",148,0)
. ;
"RTN","RCRJRBD",149,0)
. ; current month receivable (this is built in the routine
"RTN","RCRJRBD",150,0)
. ; RCRJRCO1 and is stored in ^TMP($J,"RCRJRBD",SGL))
"RTN","RCRJRBD",151,0)
. S DR=DR_".07////"_+$G(^TMP($J,"RCRJRBD",SGL))_";"
"RTN","RCRJRBD",152,0)
. ;
"RTN","RCRJRBD",153,0)
. ; calculate allowance estimate for 1319 and 1338
"RTN","RCRJRBD",154,0)
. ; .08 allowance estimate = (writeoff % * current receivables)
"RTN","RCRJRBD",155,0)
. ; .09 actual writeoffs fytd
"RTN","RCRJRBD",156,0)
. I SGL=1319!(SGL=1319.2)!(SGL=1319.3)!(SGL=1319.4)!(SGL=1319.5)!(SGL=1319.6)!(SGL=1319.7)!(SGL=1319.8)!(SGL=1319.9)!(SGL=1338)!(SGL=1338.2)!(SGL=1338.3) D
"RTN","RCRJRBD",157,0)
. . S WRITEOFF=100-COLLECT
"RTN","RCRJRBD",158,0)
. . S DR=DR_".03////"_WRITEOFF_";"
"RTN","RCRJRBD",159,0)
. . S DR=DR_".08////"_$J((WRITEOFF/100)*$G(^TMP($J,"RCRJRBD",SGL)),0,2)_";"
"RTN","RCRJRBD",160,0)
. . S DR=DR_".09////"_+$G(ACTUALWO(SGL))_";"
"RTN","RCRJRBD",161,0)
. ; calculate allowance estimate for 1339
"RTN","RCRJRBD",162,0)
. ; .08 allowance estimate = (contract % * current receivables)
"RTN","RCRJRBD",163,0)
. ; .09 actual contract adjustments fytd
"RTN","RCRJRBD",164,0)
. I SGL=1339!(SGL=1339.1)!(SGL="133N")!(SGL="133N.2")!(SGL="133N.3") D
"RTN","RCRJRBD",165,0)
. . S CONTRACT=100-COLLECT
"RTN","RCRJRBD",166,0)
. . S DR=DR_".04////"_CONTRACT_";"
"RTN","RCRJRBD",167,0)
. . S DR=DR_".08////"_$J((CONTRACT/100)*$G(^TMP($J,"RCRJRBD",SGL)),0,2)_";"
"RTN","RCRJRBD",168,0)
. . S DR=DR_".09////"_+$G(ACTUALCA(SGL))_";"
"RTN","RCRJRBD",169,0)
. ;
"RTN","RCRJRBD",170,0)
. ; set changed locally flag to no
"RTN","RCRJRBD",171,0)
. S DR=DR_".1////0;"
"RTN","RCRJRBD",172,0)
. D STORE(SGL,DR)
"RTN","RCRJRBD",173,0)
;
"RTN","RCRJRBD",174,0)
L -^RC(348.1)
"RTN","RCRJRBD",175,0)
;
"RTN","RCRJRBD",176,0)
; ; put the report in a mail message (rcrjfmm=1)
"RTN","RCRJRBD",177,0)
; S RCRJFMM=1
"RTN","RCRJRBD",178,0)
; S RCRJDATE=DATEEND
"RTN","RCRJRBD",179,0)
; D DQ^RCRJRBDR
"RTN","RCRJRBD",180,0)
;
"RTN","RCRJRBD",181,0)
; transmit the allowances to FMS, and then generate the report.
"RTN","RCRJRBD",182,0)
D BADDEBT^RCXFMSSV(DATEEND)
"RTN","RCRJRBD",183,0)
Q
"RTN","RCRJRBD",184,0)
;
"RTN","RCRJRBD",185,0)
;
"RTN","RCRJRBD",186,0)
STORE(SGL,DR) ; store data for Standard Ledger Account
"RTN","RCRJRBD",187,0)
N D0,DA,DD,DI,DIC,DIE,DINUM,DO,DQ,X,Y
"RTN","RCRJRBD",188,0)
S DIC="^RC(348.1,",DIC(0)="L",X=SGL,DIC("DR")=DR
"RTN","RCRJRBD",189,0)
D FILE^DICN
"RTN","RCRJRBD",190,0)
Q
"RTN","RCRJRBD",191,0)
;
"RTN","RCRJRBD",192,0)
;
"RTN","RCRJRBD",193,0)
DELETALL ; delete all the entries from the bad debt file
"RTN","RCRJRBD",194,0)
N %,DA,DIC,DIK,X,Y
"RTN","RCRJRBD",195,0)
S DIK="^RC(348.1,"
"RTN","RCRJRBD",196,0)
S DA=0 F S DA=$O(^RC(348.1,DA)) Q:'DA D ^DIK
"RTN","RCRJRBD",197,0)
Q
"RTN","RCRJRBD",198,0)
;
"RTN","RCRJRBD",199,0)
;
"RTN","RCRJRBD",200,0)
WD3() ; return the third work day of the month
"RTN","RCRJRBD",201,0)
N J,P,V,X
"RTN","RCRJRBD",202,0)
S J=0 F P=$E(DT,1,5)_"01":1 S V=$$DOW^XLFDT(P,1) I V,V<6,'$D(^HOLIDAY("B",P)) S J=J+1 Q:J=3
"RTN","RCRJRBD",203,0)
S X=+$E(P,6,7)
"RTN","RCRJRBD",204,0)
Q X
"RTN","RCRJRBD",205,0)
;
"RTN","RCRJRBD",206,0)
;
"RTN","RCRJRBD",207,0)
PREVMONT(FORDATE) ; return the previous month's date
"RTN","RCRJRBD",208,0)
N PREVDATE
"RTN","RCRJRBD",209,0)
S PREVDATE=$E(FORDATE,1,5)-1
"RTN","RCRJRBD",210,0)
I $E(PREVDATE,4,5)="00" S PREVDATE=($E(PREVDATE,1,3)-1)_12
"RTN","RCRJRBD",211,0)
Q PREVDATE_"00"
"RTN","RCRJRBD",212,0)
;
"RTN","RCRJRBD",213,0)
; derive standard general ledger (SGL) from category and fund
"RTN","RCRJRBD",214,0)
SGL(CATEGORY,FUND) ;
"RTN","RCRJRBD",215,0)
I $G(FUND)=528709 Q 1319.2 ;new long term care fund
"RTN","RCRJRBD",216,0)
I $E($G(FUND),1,4)=4032 Q 1319.2 ; breakout long term care as a subset
"RTN","RCRJRBD",217,0)
I $G(FUND)=528711&(CAT=6)!(CAT=7) Q 1319.5 ; breakout pharmacy
"RTN","RCRJRBD",218,0)
I $G(FUND)=528711&(CAT=9) Q "133N.2" ; pharmacy reimburs health ins
"RTN","RCRJRBD",219,0)
I $G(FUND)=528711&(CAT=10) Q 1338.2 ; pharmacy tort feasor
"RTN","RCRJRBD",220,0)
I CATEGORY=8 Q 1339 ; crime or per. vio.
"RTN","RCRJRBD",221,0)
I CATEGORY=9 Q 1339 ; reimbursable health insurance
"RTN","RCRJRBD",222,0)
I CATEGORY=46 Q 1339 ; EMER/HUMAN REIMB INS ;315
"RTN","RCRJRBD",223,0)
I CATEGORY=10 Q 1338 ; tort feasor
"RTN","RCRJRBD",224,0)
I CATEGORY=21 Q 1339 ; medicare
"RTN","RCRJRBD",225,0)
I CATEGORY=45 Q 1339.1 ; Fee Basis
"RTN","RCRJRBD",226,0)
Q 1319
"RTN","RCRJRBD",227,0)
;
"RTN","RCRJRBD",228,0)
;
"RTN","RCRJRBD",229,0)
BDRSGL(CAT,FUND,MRATYPE) ; Calculate SGLs for the BDR process
"RTN","RCRJRBD",230,0)
;PRCA*4.5*310/DRF Added fund 528713, Non-VA Reimbursable Insurance
"RTN","RCRJRBD",231,0)
;
"RTN","RCRJRBD",232,0)
; This API will be used by both the ARDC (routine RCRJRCOC)
"RTN","RCRJRBD",233,0)
; and the BDR estimate calculator to associate receivables
"RTN","RCRJRBD",234,0)
; with the correct standard general ledger account (SGL).
"RTN","RCRJRBD",235,0)
; The following table will be implemented:
"RTN","RCRJRBD",236,0)
;
"RTN","RCRJRBD",237,0)
; Receivable Type (Category) Fund SGL
"RTN","RCRJRBD",238,0)
;==================================================
"RTN","RCRJRBD",239,0)
; Medical Care Co-payments 528703 1319
"RTN","RCRJRBD",240,0)
; (plus Inelig, Emerg./Hum. rec.)
"RTN","RCRJRBD",241,0)
; Long Term Care Co-payments 528709 1319.2
"RTN","RCRJRBD",242,0)
; Medication Co-payments 528701 1319.3
"RTN","RCRJRBD",243,0)
; Crimes of Personal Violence (8), 528704 1319.4
"RTN","RCRJRBD",244,0)
; Medicare (21), No-Fault Auto
"RTN","RCRJRBD",245,0)
; (7), Workman's Comp (6)
"RTN","RCRJRBD",246,0)
; Tort Feasor (10) 528704 1338
"RTN","RCRJRBD",247,0)
; RHI (9), pre-MRA 528704 1339
"RTN","RCRJRBD",248,0)
; RHI (9), post-MRA, MRA rec. 528704 133H
"RTN","RCRJRBD",249,0)
; RHI (9), post-MRA, non-MRA rec. 528704 133N
"RTN","RCRJRBD",250,0)
; Non-VA RHI Tort Feasor 528713 1338.3
"RTN","RCRJRBD",251,0)
; Non-VA RHI (45), pre-MRA 528713 1339.1
"RTN","RCRJRBD",252,0)
; Non-VA RHI (45), post-MRA, MRA rec. 528713 133H.2
"RTN","RCRJRBD",253,0)
; Non-VA RHI (45), post-MRA, non-MRA rec. 528713 133N.3
"RTN","RCRJRBD",254,0)
; Crimes of Personal Violence (8), 528713 1319.6
"RTN","RCRJRBD",255,0)
; Medicare (21), No-Fault Auto
"RTN","RCRJRBD",256,0)
; Inpat./Outpat. Community Care copayments 528714 1319.7
"RTN","RCRJRBD",257,0)
; RX Community Care copayments 528714 1319.8
"RTN","RCRJRBD",258,0)
; LTC Community Care copayments 528714 1319.9
"RTN","RCRJRBD",259,0)
; (7), Workman's Comp (6)
"RTN","RCRJRBD",260,0)
; Pharmacy No Fault Auto(7), 528711 1319.5
"RTN","RCRJRBD",261,0)
; Pharmacy Workman's Comp(6)
"RTN","RCRJRBD",262,0)
; Pharmacy RHI, non MRA (9) 528711 133N.2
"RTN","RCRJRBD",263,0)
; Pharmacy Tort Feasor (10) 528711 1338.2
"RTN","RCRJRBD",264,0)
;
"RTN","RCRJRBD",265,0)
; Input: CAT -- Pointer to the receivable category in file 430.2
"RTN","RCRJRBD",266,0)
; FUND -- Receivable fund calculated by routine RCXFMSUF
"RTN","RCRJRBD",267,0)
; MRATYPE -- Indicator of an MRA (2) or non-MRA (3) receivable
"RTN","RCRJRBD",268,0)
;
"RTN","RCRJRBD",269,0)
;
"RTN","RCRJRBD",270,0)
I $G(FUND)=528709 Q 1319.2
"RTN","RCRJRBD",271,0)
I $E($G(FUND),1,4)=4032 Q 1319.2
"RTN","RCRJRBD",272,0)
I $G(FUND)=528701 Q 1319.3
"RTN","RCRJRBD",273,0)
I $G(FUND)=528711&((CAT=6)!(CAT=7)) Q 1319.5
"RTN","RCRJRBD",274,0)
I $G(FUND)=528711&(CAT=9) Q "133N.2"
"RTN","RCRJRBD",275,0)
I $G(FUND)=528711&(CAT=10) Q 1338.2
"RTN","RCRJRBD",276,0)
;PRCA*4.5*338 - Add new Community Care Categories
"RTN","RCRJRBD",277,0)
; THIRD PARTY =528713 new code begins
"RTN","RCRJRBD",278,0)
I $G(FUND)=528713&(CAT=10!(CAT=53)!(CAT=56)!(CAT=59)) Q 1338.3 ;patch 338 Add Comm Care Tort Feasor
"RTN","RCRJRBD",279,0)
I $G(FUND)=528713&(CAT=8!(CAT=21)!(CAT=6)!(CAT=7)!(CAT=52)!(CAT=54)!(CAT=55)!(CAT=57)!(CAT=59)!(CAT=60)) Q 1319.6 ;patch 338 Added Comm Care No Fault and Workers Comp
"RTN","RCRJRBD",280,0)
I ((CAT>47)&(CAT<52)) Q $S(MRATYPE=2:"133H.2",MRATYPE=3:"133N.3",1:1339.1) ;patch 338 Comm Care Reimb ins types.
"RTN","RCRJRBD",281,0)
; FIRST PARTY = 528714 - Community Care Copays
"RTN","RCRJRBD",282,0)
I $G(FUND)=528714&(CAT=61!(CAT=81)!(CAT=63)!(CAT=82)!(CAT=65)!(CAT=83)!(CAT=67)!(CAT=84)) Q 1319.7 ;INP/OPT copays
"RTN","RCRJRBD",283,0)
I $G(FUND)=528714&(CAT=62!(CAT=64)!(CAT=66)!(CAT=68)) Q 1319.8 ;rx copays
"RTN","RCRJRBD",284,0)
I $G(FUND)=528714&(CAT>68)&(CAT<75) Q 1319.9 ;LTC copays
"RTN","RCRJRBD",285,0)
;end PRCA*4.5*338
"RTN","RCRJRBD",286,0)
I CAT=8!(CAT=21)!(CAT=7)!(CAT=6) Q 1319.4
"RTN","RCRJRBD",287,0)
I CAT=10 Q 1338
"RTN","RCRJRBD",288,0)
I CAT=9 Q $S(MRATYPE=2:"133H",MRATYPE=3:"133N",1:1339)
"RTN","RCRJRBD",289,0)
I CAT=46 Q $S(MRATYPE=2:"133H",MRATYPE=3:"133N",1:1339) ;315
"RTN","RCRJRBD",290,0)
I CAT=45 Q $S(MRATYPE=2:"133H.2",MRATYPE=3:"133N.3",1:1339.1)
"RTN","RCRJRBD",291,0)
Q 1319
"RTN","RCRJRBDT")
0^11^B66401701
"RTN","RCRJRBDT",1,0)
RCRJRBDT ;WISC/RFJ-bad debt retransmit ;9/2/10 8:47am
"RTN","RCRJRBDT",2,0)
;;4.5;Accounts Receivable;**101,170,191,138,239,273,310,338**;Mar 20, 1995;Build 70
"RTN","RCRJRBDT",3,0)
;Per VA Directive 6402, this routine should not be modified.
"RTN","RCRJRBDT",4,0)
;
"RTN","RCRJRBDT",5,0)
;
"RTN","RCRJRBDT",6,0)
; - deactivate this option with patch PRCA*4.5*239
"RTN","RCRJRBDT",7,0)
W !!,"This option may no longer be used to retransmit the Bad Debt"
"RTN","RCRJRBDT",8,0)
W !,"allowance estimates to FMS."
"RTN","RCRJRBDT",9,0)
W !!,"Please use the option 'Monthly NDB, SV and WR Regenerate' to"
"RTN","RCRJRBDT",10,0)
W !,"recalculate the allowance estimates and transmit them to FMS.",!!
"RTN","RCRJRBDT",11,0)
;
"RTN","RCRJRBDT",12,0)
S DIR(0)="E" D ^DIR K DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
"RTN","RCRJRBDT",13,0)
;
"RTN","RCRJRBDT",14,0)
Q
"RTN","RCRJRBDT",15,0)
;
"RTN","RCRJRBDT",16,0)
;
"RTN","RCRJRBDT",17,0)
N DA347,DATEMOYR,FMSDOCNO,GECSDATA,RCRJFSV
"RTN","RCRJRBDT",18,0)
; the date of the report is for previous month if the DT is before the EOAM date of the current month, it is for the current month if the date is after the EOAM cut-off date.
"RTN","RCRJRBDT",19,0)
I $E(DT,6,7)'>$E($$LDATE^RCRJR(DT),6,7) S DATEMOYR=$$PREVMONT^RCRJRBD(DT)
"RTN","RCRJRBDT",20,0)
I $E(DT,6,7)>$E($$LDATE^RCRJR(DT),6,7) S DATEMOYR=$E($$LDATE^RCRJR(DT),1,5)_"00"
"RTN","RCRJRBDT",21,0)
;S DATEMOYR=$$PREVMONT^RCRJRBD(DT)
"RTN","RCRJRBDT",22,0)
W !!,"This option will retransmit the Bad Debt documents to FMS (SV23, SV27, SV2B)."
"RTN","RCRJRBDT",23,0)
;
"RTN","RCRJRBDT",24,0)
;I +$E(DT,6,7)<$$WD3^RCRJRBD D Q
"RTN","RCRJRBDT",25,0)
I $E(DT,6,7)<$E($$LDATE^RCRJR(DT),6,7)!($E(DT,6,7)'<$E($$LDAY^RCRJR(DT),6,7)) D Q
"RTN","RCRJRBDT",26,0)
. W !,"The FMS documents will be automatically sent to FMS on the second to last ",!,"workday of this month."
"RTN","RCRJRBDT",27,0)
; try and find SV document to see if its accepted
"RTN","RCRJRBDT",28,0)
S FMSDOCNO=""
"RTN","RCRJRBDT",29,0)
K GECSDATA
"RTN","RCRJRBDT",30,0)
S DA347=$O(^RC(347,"D","SV-"_$E(DATEMOYR,1,5)_"01",0))
"RTN","RCRJRBDT",31,0)
I DA347 S FMSDOCNO=$P($G(^RC(347,DA347,0)),"^",9)
"RTN","RCRJRBDT",32,0)
; if there is an entry, find the code sheet in gcs to rebuild
"RTN","RCRJRBDT",33,0)
; gecsdata will be the ien for file 2100.1
"RTN","RCRJRBDT",34,0)
I FMSDOCNO'="" D DATA^GECSSGET(FMSDOCNO,0)
"RTN","RCRJRBDT",35,0)
I $G(GECSDATA) D
"RTN","RCRJRBDT",36,0)
. W !!,"The SV document has been transmitted to fms, document number: "_FMSDOCNO
"RTN","RCRJRBDT",37,0)
. I $E($G(GECSDATA(2100.1,GECSDATA,3,"E")))="A" D Q
"RTN","RCRJRBDT",38,0)
. . W !,"The SV document has been ACCEPTED in FMS and will not be resent."
"RTN","RCRJRBDT",39,0)
. . S RCRJFSV=1
"RTN","RCRJRBDT",40,0)
. W !,"The SV document has NOT been ACCEPTED and will be RETRANSMITTED."
"RTN","RCRJRBDT",41,0)
I $G(RCRJFSV) Q
"RTN","RCRJRBDT",42,0)
;
"RTN","RCRJRBDT",43,0)
I $$ASKOKAY(DATEMOYR)'=1 Q
"RTN","RCRJRBDT",44,0)
;
"RTN","RCRJRBDT",45,0)
; make sure this code is not executed.
"RTN","RCRJRBDT",46,0)
;W !!,"Re-sending the documents to FMS ..."
"RTN","RCRJRBDT",47,0)
;D BADDEBT^RCXFMSSV
"RTN","RCRJRBDT",48,0)
;W " Done.",!,"The Bad Debt Report will be sent to the G.FMS mail group."
"RTN","RCRJRBDT",49,0)
Q
"RTN","RCRJRBDT",50,0)
;
"RTN","RCRJRBDT",51,0)
;
"RTN","RCRJRBDT",52,0)
ASKOKAY(DATEMOYR) ; ask if its okay
"RTN","RCRJRBDT",53,0)
; 1 is yes, otherwise no
"RTN","RCRJRBDT",54,0)
N DIR,DIQ2,DTOUT,DUOUT,X,Y
"RTN","RCRJRBDT",55,0)
S Y=DATEMOYR D DD^%DT
"RTN","RCRJRBDT",56,0)
S DIR(0)="YO",DIR("B")="NO"
"RTN","RCRJRBDT",57,0)
S DIR("A")=" Are you SURE you want to resend the Bad Debt Report for "_Y
"RTN","RCRJRBDT",58,0)
W ! D ^DIR
"RTN","RCRJRBDT",59,0)
I $G(DTOUT)!($G(DUOUT)) S Y=-1
"RTN","RCRJRBDT",60,0)
Q Y
"RTN","RCRJRBDT",61,0)
;
"RTN","RCRJRBDT",62,0)
;
"RTN","RCRJRBDT",63,0)
ENDOFREP ; print end of bad debt report footnotes
"RTN","RCRJRBDT",64,0)
; called from rcrjrbdr
"RTN","RCRJRBDT",65,0)
;
"RTN","RCRJRBDT",66,0)
; print footnote
"RTN","RCRJRBDT",67,0)
S Y=RCRJDATE D DD^%DT S ENDDATE=Y
"RTN","RCRJRBDT",68,0)
F %=1:1 S DATA=$P($T(FOOTNOTE+%),";",3,99) Q:DATA="" D
"RTN","RCRJRBDT",69,0)
. I DATA["DATEREPT" S DATA=$P(DATA,"DATEREPT")_DATEREPT_$P(DATA,"DATEREPT",2)
"RTN","RCRJRBDT",70,0)
. I DATA["ENDDATE" S DATA=$P(DATA,"ENDDATE")_ENDDATE_$P(DATA,"ENDDATE",2)
"RTN","RCRJRBDT",71,0)
. D SETLINE^RCRJRBDR(DATA)
"RTN","RCRJRBDT",72,0)
Q
"RTN","RCRJRBDT",73,0)
;
"RTN","RCRJRBDT",74,0)
;
"RTN","RCRJRBDT",75,0)
FOOTNOTE ; report footnotes (from rcrjrbdr)
"RTN","RCRJRBDT",76,0)
;;(1) Calculated Percentages and the Allowance for Contract Adj - Third Party
"RTN","RCRJRBDT",77,0)
;; for SGL 1339 are based on bills created prior to the activation of the
"RTN","RCRJRBDT",78,0)
;; Medicare Remittance Advice software. Over time, there will no longer be
"RTN","RCRJRBDT",79,0)
;; any bills in this category.
"RTN","RCRJRBDT",80,0)
;;
"RTN","RCRJRBDT",81,0)
;;(2) Calculated Percentages and the Allowance for Contract Adj - Third Party
"RTN","RCRJRBDT",82,0)
;; for SGL 133N are based on non-Medicare WNR bills created after the
"RTN","RCRJRBDT",83,0)
;; activation of the Medicare Remittance Advice software.
"RTN","RCRJRBDT",84,0)
;;
"RTN","RCRJRBDT",85,0)
;;(3) The "Allowance Estimate for DATEREPT" is the dollar value estimated
"RTN","RCRJRBDT",86,0)
;; as the Allowance for Bad Debt or Contract Adjustment for the month.
"RTN","RCRJRBDT",87,0)
;;
"RTN","RCRJRBDT",88,0)
;;(4) The "Bad Debt Write-Off (Plus)" is the actual write-offs or contract
"RTN","RCRJRBDT",89,0)
;; adjustments accomplished from FEB 1,1998 thru ENDDATE.
"RTN","RCRJRBDT",90,0)
;;
"RTN","RCRJRBDT",91,0)
;;(5) The "Transmitted Amount to FMS for Month" is the sum of (3) and (4).
"RTN","RCRJRBDT",92,0)
;; The transmitted dollar value is normally a credit value.
"RTN","RCRJRBDT",93,0)
;;
"RTN","RCRJRBDT",94,0)
;;(6) Facilities are responsible for reporting monthly accrued unbilled
"RTN","RCRJRBDT",95,0)
;; amounts. When such amounts are identified and reported, a portion of
"RTN","RCRJRBDT",96,0)
;; those dollars should be reported as uncollectable. The estimated
"RTN","RCRJRBDT",97,0)
;; uncollectable value of the unbilled amounts should be included as part
"RTN","RCRJRBDT",98,0)
;; of the facility's monthly allowance for bad debt or contract adjustments.
"RTN","RCRJRBDT",99,0)
;; The AR Override Option should be used to adjust the value provided to
"RTN","RCRJRBDT",100,0)
;; report the estimated uncollectable accrued unbilled amounts for the
"RTN","RCRJRBDT",101,0)
;; month. Facilities may wish to consider using the allowance percentages
"RTN","RCRJRBDT",102,0)
;; provided with this report, if no other means of determining the
"RTN","RCRJRBDT",103,0)
;; estimated allowance for the accrued unbilled amount is acceptable.
"RTN","RCRJRBDT",104,0)
;;
"RTN","RCRJRBDT",105,0)
;;(7) Only members in the facility's local RC AR DATA COLLECTOR mail group
"RTN","RCRJRBDT",106,0)
;; will receive this report.
"RTN","RCRJRBDT",107,0)
;
"RTN","RCRJRBDT",108,0)
;
"RTN","RCRJRBDT",109,0)
;
"RTN","RCRJRBDT",110,0)
BDR ; Compile new Bad Debt Report.
"RTN","RCRJRBDT",111,0)
; This code will be used to compile the new Bad Debt Report.
"RTN","RCRJRBDT",112,0)
; This routine is invokved by routine RCRJRBDR when the Bad
"RTN","RCRJRBDT",113,0)
; Debt Report needs to be printed.
"RTN","RCRJRBDT",114,0)
;
"RTN","RCRJRBDT",115,0)
; Variable input: LINE -- set to 0
"RTN","RCRJRBDT",116,0)
; SPACE -- set to 81 space characters
"RTN","RCRJRBDT",117,0)
; DATEREPT -- formatted month and year
"RTN","RCRJRBDT",118,0)
;
"RTN","RCRJRBDT",119,0)
N RCARR,RCX,RCD,RCDATA,RCREC,X
"RTN","RCRJRBDT",120,0)
D SETLINE(" ")
"RTN","RCRJRBDT",121,0)
D SETLINE($E(SPACE,1,32)_"Bad Debt Report")
"RTN","RCRJRBDT",122,0)
D SETLINE($E(SPACE,1,13)_"Allowance for Bad Debt and Contract Adjustment Report")
"RTN","RCRJRBDT",123,0)
D SETLINE($E(SPACE,1,27)_"for the month of "_DATEREPT)
"RTN","RCRJRBDT",124,0)
I $D(RCRJFXSV) D
"RTN","RCRJRBDT",125,0)
. D SETLINE(" ")
"RTN","RCRJRBDT",126,0)
. I $E(RCRJFXSV,1,2)="SV" D SETLINE($E(SPACE,1,13)_"***** Report sent to FMS, doc id: "_RCRJFXSV_" *****") Q
"RTN","RCRJRBDT",127,0)
. ; report errored out or did not get generated to fms
"RTN","RCRJRBDT",128,0)
. D SETLINE($E(SPACE,1,10)_"***** NOTICE: Report was NOT sent to FMS, the message is *****")
"RTN","RCRJRBDT",129,0)
. D SETLINE($E(SPACE,1,10)_"***** "_RCRJFXSV_" *****")
"RTN","RCRJRBDT",130,0)
;
"RTN","RCRJRBDT",131,0)
; show mccf
"RTN","RCRJRBDT",132,0)
; PRCA*4.5*310/DRF - add fee basis fund (528713) to report
"RTN","RCRJRBDT",133,0)
; PRCA*4.5*338/DRF - add fund (528714) to report
"RTN","RCRJRBDT",134,0)
D SETLINE(" ")
"RTN","RCRJRBDT",135,0)
D SETLINE($E(SPACE,1,26)_"Medical Care Collection Fund")
"RTN","RCRJRBDT",136,0)
D SETLINE($E(SPACE,1,2)_" Funds 528701; 528703; 528704; 528709; 528711; 528713; and 528714")
"RTN","RCRJRBDT",137,0)
D SETLINE($E(SPACE,1,2)_" ----------------------------------------------------------------")
"RTN","RCRJRBDT",138,0)
D SETLINE(" ")
"RTN","RCRJRBDT",139,0)
D SETLINE(" ")
"RTN","RCRJRBDT",140,0)
D SETLINE($E(SPACE,1,57)_"Contract EOM")
"RTN","RCRJRBDT",141,0)
D SETLINE("FUND - SGL Account Collection% Write-Off% Adjustment% Allowance")
"RTN","RCRJRBDT",142,0)
D SETLINE(" ")
"RTN","RCRJRBDT",143,0)
;
"RTN","RCRJRBDT",144,0)
; List the fund/SGLs as:
"RTN","RCRJRBDT",145,0)
; Order SGL in file Fund - SGL on report
"RTN","RCRJRBDT",146,0)
; ===============================================
"RTN","RCRJRBDT",147,0)
; 1 1319.3 528701 - 1319
"RTN","RCRJRBDT",148,0)
; 2 1319 528703 - 1319
"RTN","RCRJRBDT",149,0)
; 3 1319.4 528704 - 1319
"RTN","RCRJRBDT",150,0)
; 4 1339 528704 - 1339
"RTN","RCRJRBDT",151,0)
; 5 133N 528704 - 133N
"RTN","RCRJRBDT",152,0)
; 6 1338 528704 - 1338
"RTN","RCRJRBDT",153,0)
; 7 1319.2 528709 - 1319
"RTN","RCRJRBDT",154,0)
; 8 1319.5 528711 - 1319
"RTN","RCRJRBDT",155,0)
; 9 133N.2 528711 - 133N
"RTN","RCRJRBDT",156,0)
; 10 1338.2 528711 - 1338
"RTN","RCRJRBDT",157,0)
; 11 1319.6 528713 - 1319
"RTN","RCRJRBDT",158,0)
; 12 1339.1 528713 - 1339
"RTN","RCRJRBDT",159,0)
; 13 133N.3 528713 - 133N
"RTN","RCRJRBDT",160,0)
; 14 1338.3 528713 - 1338
"RTN","RCRJRBDT",161,0)
; 15 1319.7 528714 - 1319
"RTN","RCRJRBDT",162,0)
; 16 1319.8 528714 - 1319
"RTN","RCRJRBDT",163,0)
; 17 1319.9 528714 - 1319
"RTN","RCRJRBDT",164,0)
;
"RTN","RCRJRBDT",165,0)
S RCARR(1)="1319.3^528701 - 1319"
"RTN","RCRJRBDT",166,0)
S RCARR(2)="1319^528703 - 1319"
"RTN","RCRJRBDT",167,0)
S RCARR(3)="1319.4^528704 - 1319"
"RTN","RCRJRBDT",168,0)
S RCARR(4)="1339^528704 - 1339"
"RTN","RCRJRBDT",169,0)
S RCARR(5)="133N^528704 - 133N"
"RTN","RCRJRBDT",170,0)
S RCARR(6)="1338^528704 - 1338"
"RTN","RCRJRBDT",171,0)
S RCARR(7)="1319.2^528709 - 1319"
"RTN","RCRJRBDT",172,0)
S RCARR(8)="1319.5^528711 - 1319"
"RTN","RCRJRBDT",173,0)
S RCARR(9)="133N.2^528711 - 133N"
"RTN","RCRJRBDT",174,0)
S RCARR(10)="1338.2^528711 - 1338"
"RTN","RCRJRBDT",175,0)
S RCARR(11)="1319.6^528713 - 1319"
"RTN","RCRJRBDT",176,0)
S RCARR(12)="1339.1^528713 - 1339"
"RTN","RCRJRBDT",177,0)
S RCARR(13)="133N.3^528713 - 133N"
"RTN","RCRJRBDT",178,0)
S RCARR(14)="1338.3^528713 - 1338"
"RTN","RCRJRBDT",179,0)
S RCARR(15)="1319.7^528714 - 1319.7"
"RTN","RCRJRBDT",180,0)
S RCARR(16)="1319.8^528714 - 1319.8"
"RTN","RCRJRBDT",181,0)
S RCARR(17)="1319.9^528714 - 1319.9"
"RTN","RCRJRBDT",182,0)
;
"RTN","RCRJRBDT",183,0)
S RCX="" F S RCX=$O(RCARR(RCX)) Q:RCX="" S RCD=RCARR(RCX) D
"RTN","RCRJRBDT",184,0)
.S RCDATA=$G(^RC(348.1,+$O(^RC(348.1,"B",$P(RCD,"^"),0)),0))
"RTN","RCRJRBDT",185,0)
.Q:RCDATA=""
"RTN","RCRJRBDT",186,0)
.S RCREC=$P(RCD,"^",2)_$J($P(RCDATA,"^",2),21,2)
"RTN","RCRJRBDT",187,0)
.I RCD[528714 S RCREC=$P(RCD,"^",2)_$J($P(RCDATA,"^",2),19,2) ; patch PRCA*4.5*338 align subcategory format for first party
"RTN","RCRJRBDT",188,0)
.S RCREC=RCREC_$J($P(RCDATA,"^",3),15,2)
"RTN","RCRJRBDT",189,0)
.S RCREC=RCREC_$J($P(RCDATA,"^",4),16,2)
"RTN","RCRJRBDT",190,0)
.S X=+$P(RCDATA,"^",8)
"RTN","RCRJRBDT",191,0)
.S X=$FN(X,",")_$S(X[".":"",1:".")_$E("00",$L($P(X,".",2))+1,2)
"RTN","RCRJRBDT",192,0)
.S RCREC=RCREC_$J(X,14)
"RTN","RCRJRBDT",193,0)
.D SETLINE(RCREC)
"RTN","RCRJRBDT",194,0)
;
"RTN","RCRJRBDT",195,0)
D SETLINE(" ")
"RTN","RCRJRBDT",196,0)
D SETLINE(" ")
"RTN","RCRJRBDT",197,0)
D SETLINE("SGL Definitions")
"RTN","RCRJRBDT",198,0)
D SETLINE(" ")
"RTN","RCRJRBDT",199,0)
D SETLINE("1319 Allowance for Bad Debt")
"RTN","RCRJRBDT",200,0)
D SETLINE("1319.7 Allowance Community Care Inpatient/Outpatient copayments")
"RTN","RCRJRBDT",201,0)
D SETLINE("1319.8 Allowance Community Care RX copayments")
"RTN","RCRJRBDT",202,0)
D SETLINE("1319.9 Allowance Community Care LTC copayments")
"RTN","RCRJRBDT",203,0)
D SETLINE("1338 Allowance for Tort Feasors")
"RTN","RCRJRBDT",204,0)
D SETLINE("1339 Allowance for Contract Adjustments pre-MRA (Medicare Remittance Advice)")
"RTN","RCRJRBDT",205,0)
D SETLINE("133N Allowance for Contract Adjustments post-MRA")
"RTN","RCRJRBDT",206,0)
D SETLINE(" ")
"RTN","RCRJRBDT",207,0)
D SETLINE(" ")
"RTN","RCRJRBDT",208,0)
D SETLINE("Only members in the facility's local RC AR DATA COLLECTOR mail group")
"RTN","RCRJRBDT",209,0)
D SETLINE("will receive this report.")
"RTN","RCRJRBDT",210,0)
Q
"RTN","RCRJRBDT",211,0)
;
"RTN","RCRJRBDT",212,0)
SETLINE(DATA) ; build the line for the report
"RTN","RCRJRBDT",213,0)
S LINE=LINE+1,^TMP($J,"RCRJRCORMM",LINE)=DATA
"RTN","RCRJRBDT",214,0)
Q
"RTN","RCRJRCOC")
0^21^B81559216
"RTN","RCRJRCOC",1,0)
RCRJRCOC ;WISC/RFJ/BGJ-count current receivables ; 11/2/10 10:53am
"RTN","RCRJRCOC",2,0)
;;4.5;Accounts Receivable;**156,170,182,203,220,138,239,272,273,334,335,338**;Mar 20, 1995;Build 70
"RTN","RCRJRCOC",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCRJRCOC",4,0)
; IA 4385 for call to $$MRATYPE^IBCEMU2
"RTN","RCRJRCOC",5,0)
Q
"RTN","RCRJRCOC",6,0)
;
"RTN","RCRJRCOC",7,0)
;
"RTN","RCRJRCOC",8,0)
CURRENT(RCBILLDA,RCVALUE) ; count current bills balance
"RTN","RCRJRCOC",9,0)
; rcvalue = prin ^ int ^ admin ^ mf ^ cc
"RTN","RCRJRCOC",10,0)
;
"RTN","RCRJRCOC",11,0)
N %,RCFUND,RCRSC,RCTOHSIF,RCTOMCCF,SGL,TYPE,MRATYPE,ARACTDT,CATEGORY,RCRHITYP,RCCATNM
"RTN","RCRJRCOC",12,0)
;
"RTN","RCRJRCOC",13,0)
; calculate the rsc for the bill. the rsc is only used for
"RTN","RCRJRCOC",14,0)
; mccf bills
"RTN","RCRJRCOC",15,0)
S RCRSC=""
"RTN","RCRJRCOC",16,0)
;PRCA*4.5*338 - Modified the code to only recalculate RSCs if none currently calculated.
"RTN","RCRJRCOC",17,0)
S RCRSC=$$GET1^DIQ(430,BILLDA_",",255)
"RTN","RCRJRCOC",18,0)
S:RCRSC="" RCRSC=$$GET1^DIQ(430,BILLDA_",",255.1)
"RTN","RCRJRCOC",19,0)
I $$ACCK^PRCAACC(RCBILLDA) S:RCRSC="" RCRSC=$$CALCRSC^RCXFMSUR(RCBILLDA)
"RTN","RCRJRCOC",20,0)
;
"RTN","RCRJRCOC",21,0)
; calculate the amount that goes to mccf and hsif
"RTN","RCRJRCOC",22,0)
D MCCFHSIF(RCBILLDA,RCVALUE,RCRSC,DATEEND+1)
"RTN","RCRJRCOC",23,0)
;
"RTN","RCRJRCOC",24,0)
; store the data for the ndb, if a 0 is returned by the function,
"RTN","RCRJRCOC",25,0)
; then the bill has already been counted as a current receivable,quit
"RTN","RCRJRCOC",26,0)
I '$$NDBSTORE(RCBILLDA,RCVALUE,1) Q
"RTN","RCRJRCOC",27,0)
;
"RTN","RCRJRCOC",28,0)
; store results for FMS SV document for accrued bills only
"RTN","RCRJRCOC",29,0)
; do not include prepayments (26)
"RTN","RCRJRCOC",30,0)
I $$ACCK^PRCAACC(RCBILLDA),$P($G(^PRCA(430,RCBILLDA,0)),"^",2)'=26 D
"RTN","RCRJRCOC",31,0)
. ; get the bills fund and category
"RTN","RCRJRCOC",32,0)
. ;PRCA*4.5*338 Calculate fund only if it is not stored in the bill
"RTN","RCRJRCOC",33,0)
. S RCFUND=$$GET1^DIQ(430,BILLDA_",",203)
"RTN","RCRJRCOC",34,0)
. I RCFUND="" S RCFUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
"RTN","RCRJRCOC",35,0)
. ;end PRCA*4.5*338
"RTN","RCRJRCOC",36,0)
. S RCFUND=$$ADJFUND^RCRJRCO(RCFUND) ; may remove the line after 10/1/03
"RTN","RCRJRCOC",37,0)
. S CATEGORY=+$P($G(^PRCA(430,RCBILLDA,0)),"^",2),RCCATNM=$$GET1^DIQ(430.2,CATEGORY_",",.01) ; retrieve CAT name PRCA*4.5*338
"RTN","RCRJRCOC",38,0)
. ;
"RTN","RCRJRCOC",39,0)
. ; ----- this code is used to set up the SV code sheet -----
"RTN","RCRJRCOC",40,0)
. S TYPE=21
"RTN","RCRJRCOC",41,0)
. ; special type for tort feasor
"RTN","RCRJRCOC",42,0)
. I RCCATNM["TORT" S TYPE="2A" ;Using the category name to look for TORTs - PRCA*4.5*338
"RTN","RCRJRCOC",43,0)
. ;
"RTN","RCRJRCOC",44,0)
. ; Get ARACTDT=AR Date Active for bill
"RTN","RCRJRCOC",45,0)
. S ARACTDT=+$P($P($G(^PRCA(430,RCBILLDA,6)),"^",21),".")
"RTN","RCRJRCOC",46,0)
. ; determine Receivable Type: 1=pre-MRA, 2=post-MRA Medicre, 3=post-MRA non-Medicare
"RTN","RCRJRCOC",47,0)
. ; DBIA #4385 activated on 31-Mar-2004
"RTN","RCRJRCOC",48,0)
. S MRATYPE=$$MRATYPE^IBCEMU2(RCBILLDA,ARACTDT)
"RTN","RCRJRCOC",49,0)
. ; set TYPE to 2F for post-MRA Medicare bills or to 2L for
"RTN","RCRJRCOC",50,0)
. ; post-MRA non-Medicare bills (for RHI receivables only)
"RTN","RCRJRCOC",51,0)
. ; PRCA*4.5*338 moved TYPE set for RHI to function call to ensure Community Care RSCs are captured correctly.
"RTN","RCRJRCOC",52,0)
. S RCRHITYP=$$RHITYPE(RCRSC,MRATYPE,RCCATNM) S:+RCRHITYP TYPE=$P(RCRHITYP,U,2)
"RTN","RCRJRCOC",53,0)
. ;
"RTN","RCRJRCOC",54,0)
. ; store dollars to mccf and hsif
"RTN","RCRJRCOC",55,0)
. I RCTOMCCF S ^TMP($J,"RCRJRCOLSV",TYPE,RCFUND,RCRSC)=$G(^TMP($J,"RCRJRCOLSV",TYPE,RCFUND,RCRSC))+RCTOMCCF
"RTN","RCRJRCOC",56,0)
. I RCTOHSIF S ^TMP($J,"RCRJRCOLSV",21,5358.1,$S(RCRSC="8BZZ":"8B1Z",1:"8C1Z"))=$G(^TMP($J,"RCRJRCOLSV",21,5358.1,$S(RCRSC="8BZZ":"8B1Z",1:"8C1Z")))+RCTOHSIF
"RTN","RCRJRCOC",57,0)
. ;
"RTN","RCRJRCOC",58,0)
. ; ----- this code is used to build the user report
"RTN","RCRJRCOC",59,0)
. S %=+$P($P($G(^PRCA(430,RCBILLDA,6)),"^",21),".")
"RTN","RCRJRCOC",60,0)
. S ^TMP($J,"RCRJRCOLREPORT",%,RCBILLDA)=$P(RCVALUE,"^")_"^"_($P(RCVALUE,"^",2)+$P(RCVALUE,"^",3)+$P(RCVALUE,"^",4)+$P(RCVALUE,"^",5))_"^SV"_TYPE
"RTN","RCRJRCOC",61,0)
. I RCTOMCCF D STORE^RCRJRCOU(BILLDA,DATEBEG,DATEEND,ARACTDT,CATEGORY,"SV"_TYPE,RCFUND,RCRSC,RCVALUE)
"RTN","RCRJRCOC",62,0)
. I RCTOHSIF D STORE^RCRJRCOU(BILLDA,DATEBEG,DATEEND,ARACTDT,CATEGORY,"SV21","5358.1",$S(RCRSC="8BZZ":"8B1Z",1:"8C1Z"),RCVALUE)
"RTN","RCRJRCOC",63,0)
. ;
"RTN","RCRJRCOC",64,0)
. ; ----- this code is used to build the OIG extract, piece 3 = GL acct
"RTN","RCRJRCOC",65,0)
. S ^TMP($J,"RCRJROIG",RCBILLDA)=$P(RCVALUE,"^")_"^"_($P(RCVALUE,"^",2)+$P(RCVALUE,"^",3)+$P(RCVALUE,"^",4)+$P(RCVALUE,"^",5))_"^"_$S(TYPE="2A":1333,TYPE="2F":"13H1",TYPE="2L":"13N1",1:1311)
"RTN","RCRJRCOC",66,0)
. ;
"RTN","RCRJRCOC",67,0)
. ; ----- this code is used to set up medicare supplemental SVs
"RTN","RCRJRCOC",68,0)
. S %=$G(^PRCA(430,RCBILLDA,13))
"RTN","RCRJRCOC",69,0)
. ; medicare contract adjustment field 131 for bills activated in AR during the month the ARDC is running
"RTN","RCRJRCOC",70,0)
. I $P(%,"^",1),ARACTDT'<DATEBEG D ;
"RTN","RCRJRCOC",71,0)
. . S ^TMP($J,"RCRJRCOLSV",17)=$G(^TMP($J,"RCRJRCOLSV",17))+$P(%,"^",1)
"RTN","RCRJRCOC",72,0)
. . S ^TMP($J,"RCRJRCOLSV",17,RCFUND,RCRSC)=$G(^TMP($J,"RCRJRCOLSV",17,RCFUND,RCRSC))+$P(%,"^",1)
"RTN","RCRJRCOC",73,0)
. ; medicare unreimbursable medicare expense field 132 for bills activated in AR during the month the ARDC is running
"RTN","RCRJRCOC",74,0)
. I $P(%,"^",2),ARACTDT'<DATEBEG D ;
"RTN","RCRJRCOC",75,0)
. . S ^TMP($J,"RCRJRCOLSV",18)=$G(^TMP($J,"RCRJRCOLSV",18))+$P(%,"^",2)
"RTN","RCRJRCOC",76,0)
. . S ^TMP($J,"RCRJRCOLSV",18,RCFUND,RCRSC)=$G(^TMP($J,"RCRJRCOLSV",18,RCFUND,RCRSC))+$P(%,"^",2)
"RTN","RCRJRCOC",77,0)
. ;
"RTN","RCRJRCOC",78,0)
. ; ----- this code is used to set up the bad debt report -----
"RTN","RCRJRCOC",79,0)
. S SGL=$$BDRSGL^RCRJRBD(CATEGORY,RCFUND,MRATYPE)
"RTN","RCRJRCOC",80,0)
. ; store dollars to mccf and hsif. both are sgl 1319 so 1319.1 is
"RTN","RCRJRCOC",81,0)
. ; used to put hsif in a subset of 1319
"RTN","RCRJRCOC",82,0)
. I RCTOMCCF S ^TMP($J,"RCRJRBD",SGL)=$G(^TMP($J,"RCRJRBD",SGL))+RCTOMCCF
"RTN","RCRJRCOC",83,0)
. I RCTOHSIF S ^TMP($J,"RCRJRBD",1319.1)=$G(^TMP($J,"RCRJRBD",1319.1))+RCTOHSIF
"RTN","RCRJRCOC",84,0)
;
"RTN","RCRJRCOC",85,0)
; store the interest, admin, mf, cc on the SV code sheet
"RTN","RCRJRCOC",86,0)
; interest (type P2; fund 1435; rsc 8047)
"RTN","RCRJRCOC",87,0)
I $P(RCVALUE,"^",2) S ^TMP($J,"RCRJRCOLSV","P2",1435,8047)=$G(^TMP($J,"RCRJRCOLSV","P2",1435,8047))+$P(RCVALUE,"^",2)
"RTN","RCRJRCOC",88,0)
; admin (type P2; fund 3220; rsc 8046)
"RTN","RCRJRCOC",89,0)
I $P(RCVALUE,"^",3) S ^TMP($J,"RCRJRCOLSV","P2",3220,8046)=$G(^TMP($J,"RCRJRCOLSV","P2",3220,8046))+$P(RCVALUE,"^",3)
"RTN","RCRJRCOC",90,0)
; mf + cc (type P2; fund 0869; rsc 8048)
"RTN","RCRJRCOC",91,0)
S %=$P(RCVALUE,"^",4)+$P(RCVALUE,"^",5)
"RTN","RCRJRCOC",92,0)
I % S ^TMP($J,"RCRJRCOLSV","P2","0869",8048)=$G(^TMP($J,"RCRJRCOLSV","P2","0869",8048))+%
"RTN","RCRJRCOC",93,0)
Q
"RTN","RCRJRCOC",94,0)
;
"RTN","RCRJRCOC",95,0)
RHITYPE(RCRSC,MRATYPE,RCCATNM) ;
"RTN","RCRJRCOC",96,0)
; Input - RCRSC - Revenue Source Code from a Bill
"RTN","RCRJRCOC",97,0)
; RCMRATYP - Type of MRA as determined by the call to $$MRATYPE^IBCEMU2
"RTN","RCRJRCOC",98,0)
; Output - Is it a RHI Bill (0 - No, 1 - Yes) ^ SV Type to return (2F or 2L) [required if an RHI Bill]
"RTN","RCRJRCOC",99,0)
;
"RTN","RCRJRCOC",100,0)
N RCTYPE
"RTN","RCRJRCOC",101,0)
S RCTYPE=0
"RTN","RCRJRCOC",102,0)
I MRATYPE>1 D
"RTN","RCRJRCOC",103,0)
. Q:RCRSC="85CC" ; This specific RSC is a TORT RSC for the CHOICE program
"RTN","RCRJRCOC",104,0)
. I $E(RCRSC,1,2)=85!($E(RCRSC,1,2)="8R") S RCTYPE="1^"_$S(MRATYPE=2:"2F",1:"2L") Q
"RTN","RCRJRCOC",105,0)
. I RCCATNM["THIRD PARTY" D Q
"RTN","RCRJRCOC",106,0)
. . Q:RCCATNM["CHAMPVA" ;Exclude CHAMPVA
"RTN","RCRJRCOC",107,0)
. . Q:RCCATNM["TRICARE" ;Exclude TRICARE
"RTN","RCRJRCOC",108,0)
. . ;otherwise this is a Community Care Bill, set the SV type
"RTN","RCRJRCOC",109,0)
. . S RCTYPE="1^"_$S(MRATYPE=2:"2F",1:"2L")
"RTN","RCRJRCOC",110,0)
Q RCTYPE
"RTN","RCRJRCOC",111,0)
;
"RTN","RCRJRCOC",112,0)
WRITEOFF(RCBILLDA,RCVALUE,RCRITER2) ; count write offs
"RTN","RCRJRCOC",113,0)
; rcvalue = prin ^ int ^ admin ^ mf ^ cc
"RTN","RCRJRCOC",114,0)
; rcriter2 = write off criteria tracked in ndb
"RTN","RCRJRCOC",115,0)
;
"RTN","RCRJRCOC",116,0)
N %,RCFUND,RCRSC,RCTOHSIF,RCTOMCCF,TYPE,MRATYPE,ARACTDT
"RTN","RCRJRCOC",117,0)
;
"RTN","RCRJRCOC",118,0)
; calculate the rsc for the bill. the rsc is only used for
"RTN","RCRJRCOC",119,0)
; mccf bills
"RTN","RCRJRCOC",120,0)
S RCRSC=""
"RTN","RCRJRCOC",121,0)
;PRCA*4.5*338 - Modified the code to only recalculate RSCs if none currently calculated.
"RTN","RCRJRCOC",122,0)
S RCRSC=$$GET1^DIQ(430,BILLDA_",",255)
"RTN","RCRJRCOC",123,0)
S:RCRSC="" RCRSC=$$GET1^DIQ(430,BILLDA_",",255.1)
"RTN","RCRJRCOC",124,0)
I $$ACCK^PRCAACC(RCBILLDA) S:RCRSC="" RCRSC=$$CALCRSC^RCXFMSUR(RCBILLDA)
"RTN","RCRJRCOC",125,0)
;
"RTN","RCRJRCOC",126,0)
; calculate the amount that goes to mccf and hsif
"RTN","RCRJRCOC",127,0)
D MCCFHSIF(RCBILLDA,RCVALUE,RCRSC,DATEEND+1)
"RTN","RCRJRCOC",128,0)
;
"RTN","RCRJRCOC",129,0)
; store the data for the ndb, if a 0 is returned by the function,
"RTN","RCRJRCOC",130,0)
; then the bill has already been counted as a current receivable,quit
"RTN","RCRJRCOC",131,0)
I '$$NDBSTORE(RCBILLDA,RCVALUE,RCRITER2) Q
"RTN","RCRJRCOC",132,0)
;
"RTN","RCRJRCOC",133,0)
; store results for FMS WR document
"RTN","RCRJRCOC",134,0)
; do not include prepayments (26)
"RTN","RCRJRCOC",135,0)
I $$ACCK^PRCAACC(RCBILLDA),$P($G(^PRCA(430,RCBILLDA,0)),"^",2)'=26 D
"RTN","RCRJRCOC",136,0)
. ; get the bills fund
"RTN","RCRJRCOC",137,0)
. ;PRCA*4.5*338 Calculate fund only if it is not stored in the bill
"RTN","RCRJRCOC",138,0)
. S RCFUND=$$GET1^DIQ(430,BILLDA_",",203)
"RTN","RCRJRCOC",139,0)
. I RCFUND="" S RCFUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
"RTN","RCRJRCOC",140,0)
. ;end PRCA*4.5*338
"RTN","RCRJRCOC",141,0)
. S RCFUND=$$ADJFUND^RCRJRCO(RCFUND) ; may remove the line after 10/1/03
"RTN","RCRJRCOC",142,0)
. S CATEGORY=+$P($G(^PRCA(430,RCBILLDA,0)),"^",2),RCCATNM=$$GET1^DIQ(430.2,CATEGORY_",",.01) ; retrieve CAT name PRCA*4.5*338
"RTN","RCRJRCOC",143,0)
. ;
"RTN","RCRJRCOC",144,0)
. S TYPE=37
"RTN","RCRJRCOC",145,0)
. ; special type for tort feasor
"RTN","RCRJRCOC",146,0)
. I RCCATNM["TORT" S TYPE="39" ;Using the category name to look for TORTs - PRCA*4.5*338
"RTN","RCRJRCOC",147,0)
. S ARACTDT=+$P($P($G(^PRCA(430,RCBILLDA,6)),"^",21),".")
"RTN","RCRJRCOC",148,0)
. ; DBIA #4385 activated on 31-Mar-2004
"RTN","RCRJRCOC",149,0)
. S MRATYPE=$$MRATYPE^IBCEMU2(RCBILLDA,ARACTDT)
"RTN","RCRJRCOC",150,0)
. ; for contract adjustments (criter2=22), the type is 38 for pre-
"RTN","RCRJRCOC",151,0)
. ; MRA, 4N for post-MRA non-Medicare and 08 for post-MRA Medicare
"RTN","RCRJRCOC",152,0)
. I RCRITER2=22 S TYPE=$S(MRATYPE=1:38,MRATYPE=2:"08",1:"4N") ;Aging bucket increase modified in PRCA*4.5*334
"RTN","RCRJRCOC",153,0)
. ; store dollars to mccf and hsif
"RTN","RCRJRCOC",154,0)
. I RCTOMCCF S ^TMP($J,"RCRJRCOLWR",TYPE,RCFUND,RCRSC)=$G(^TMP($J,"RCRJRCOLWR",TYPE,RCFUND,RCRSC))+RCTOMCCF
"RTN","RCRJRCOC",155,0)
. I RCTOHSIF S ^TMP($J,"RCRJRCOLWR",TYPE,5358.1,$S(RCRSC="8BZZ":"8B1Z",1:"8C1Z"))=$G(^TMP($J,"RCRJRCOLWR",TYPE,5358.1,$S(RCRSC="8BZZ":"8B1Z",1:"8C1Z")))+RCTOHSIF
"RTN","RCRJRCOC",156,0)
;
"RTN","RCRJRCOC",157,0)
; store the interest, admin, mf, cc on the WR code sheet
"RTN","RCRJRCOC",158,0)
; interest (type P4; fund 1435; rsc 8047)
"RTN","RCRJRCOC",159,0)
I $P(RCVALUE,"^",2) S ^TMP($J,"RCRJRCOLWR","P4",1435,8047)=$G(^TMP($J,"RCRJRCOLWR","P4",1435,8047))+$P(RCVALUE,"^",2)
"RTN","RCRJRCOC",160,0)
; admin (type P4; fund 3220; rsc 8046)
"RTN","RCRJRCOC",161,0)
I $P(RCVALUE,"^",3) S ^TMP($J,"RCRJRCOLWR","P4",3220,8046)=$G(^TMP($J,"RCRJRCOLWR","P4",3220,8046))+$P(RCVALUE,"^",3)
"RTN","RCRJRCOC",162,0)
; mf + cc (type P4; fund 0869; rsc 8048)
"RTN","RCRJRCOC",163,0)
S %=$P(RCVALUE,"^",4)+$P(RCVALUE,"^",5)
"RTN","RCRJRCOC",164,0)
I % S ^TMP($J,"RCRJRCOLWR","P4","0869",8048)=$G(^TMP($J,"RCRJRCOLWR","P4","0869",8048))+%
"RTN","RCRJRCOC",165,0)
Q
"RTN","RCRJRCOC",166,0)
;
"RTN","RCRJRCOC",167,0)
;
"RTN","RCRJRCOC",168,0)
NDBSTORE(RCBILLDA,RCVALUE,RCRITER2) ; store the data for the NDB
"RTN","RCRJRCOC",169,0)
; returns a 1 if the bill has not been counted
"RTN","RCRJRCOC",170,0)
; returns a 0 if the bill has been counted
"RTN","RCRJRCOC",171,0)
N %,CRITERIA
"RTN","RCRJRCOC",172,0)
;
"RTN","RCRJRCOC",173,0)
; this line of code will prevent duplicate counts if a sites cross
"RTN","RCRJRCOC",174,0)
; references in file 430 (actdt and asdt) are duplicated (incorrect)
"RTN","RCRJRCOC",175,0)
I RCRITER2<15,$D(^TMP($J,"RCRJRCOL","COUNT",RCBILLDA,RCRITER2)) Q 0 ; Aging bucket increase modified in PRCA*4.5*334
"RTN","RCRJRCOC",176,0)
;
"RTN","RCRJRCOC",177,0)
; get a bills criteria 1,3,4,5
"RTN","RCRJRCOC",178,0)
S CRITERIA=$G(^TMP($J,"RCRJRCOL","CRITERIA",RCBILLDA))
"RTN","RCRJRCOC",179,0)
I CRITERIA="" S CRITERIA=$$CRITERIA^RCRJRCOL(RCBILLDA),^TMP($J,"RCRJRCOL","CRITERIA",RCBILLDA)=CRITERIA
"RTN","RCRJRCOC",180,0)
S $P(CRITERIA,"-",2)=RCRITER2
"RTN","RCRJRCOC",181,0)
;
"RTN","RCRJRCOC",182,0)
; store results for ndb
"RTN","RCRJRCOC",183,0)
S %=$G(@DATASTOR)
"RTN","RCRJRCOC",184,0)
S $P(%,"^")=$P(%,"^")+1
"RTN","RCRJRCOC",185,0)
S $P(%,"^",2)=$P(%,"^",2)+$P(RCVALUE,"^")
"RTN","RCRJRCOC",186,0)
S $P(%,"^",3)=$P(%,"^",3)+$P(RCVALUE,"^",2)+$P(RCVALUE,"^",3)+$P(RCVALUE,"^",4)+$P(RCVALUE,"^",5)
"RTN","RCRJRCOC",187,0)
S @DATASTOR=%
"RTN","RCRJRCOC",188,0)
;
"RTN","RCRJRCOC",189,0)
; keep a count of current receivables counted
"RTN","RCRJRCOC",190,0)
S ^TMP($J,"RCRJRCOL","COUNT",RCBILLDA,RCRITER2)=""
"RTN","RCRJRCOC",191,0)
S ^TMP($J,"RCRJRCOL","CRIT2",RCRITER2,RCBILLDA)=""
"RTN","RCRJRCOC",192,0)
Q 1
"RTN","RCRJRCOC",193,0)
;
"RTN","RCRJRCOC",194,0)
;
"RTN","RCRJRCOC",195,0)
MCCFHSIF(RCBILLDA,RCVALUE,RCRSC,ASOFDATE) ; calculate the amount that goes
"RTN","RCRJRCOC",196,0)
;
"RTN","RCRJRCOC",197,0)
; to mccf and hsif
"RTN","RCRJRCOC",198,0)
;
"RTN","RCRJRCOC",199,0)
; returns RCTOMCCF and RCTOHSIF as the outstanding balance to mccf
"RTN","RCRJRCOC",200,0)
; and the outstanding balance to hsif
"RTN","RCRJRCOC",201,0)
N MCCFHSIF
"RTN","RCRJRCOC",202,0)
;
"RTN","RCRJRCOC",203,0)
S RCTOMCCF=$P(RCVALUE,"^"),RCTOHSIF=0
"RTN","RCRJRCOC",204,0)
;
"RTN","RCRJRCOC",205,0)
I $$NOHSIF^RCRJRCO() Q ; disabled HSIF
"RTN","RCRJRCOC",206,0)
;
"RTN","RCRJRCOC",207,0)
; if revenue source code is not 8BZZ or 8CZZ then it all goes to mccf
"RTN","RCRJRCOC",208,0)
I RCRSC="8BZZ"!(RCRSC="8CZZ") D
"RTN","RCRJRCOC",209,0)
. ; get the amount for each fund mccf and hsif
"RTN","RCRJRCOC",210,0)
. ; this call returns the total amount owed to mccf (piece 1),
"RTN","RCRJRCOC",211,0)
. ; total amount owed to hsif (piece 2), total amount paid
"RTN","RCRJRCOC",212,0)
. ; to mccf (piece 3), total amount paid to hsif (piece 4).
"RTN","RCRJRCOC",213,0)
. ; for outstanding balance you must subtract the payment in
"RTN","RCRJRCOC",214,0)
. ; pieces 3 and 4 which are returned as negative amounts.
"RTN","RCRJRCOC",215,0)
. S MCCFHSIF=$$BILLFUND^RCBMILLC(RCBILLDA,ASOFDATE)
"RTN","RCRJRCOC",216,0)
. S RCTOMCCF=$P(MCCFHSIF,"^",1)+$P(MCCFHSIF,"^",3)
"RTN","RCRJRCOC",217,0)
. S RCTOHSIF=$P(MCCFHSIF,"^",2)+$P(MCCFHSIF,"^",4)
"RTN","RCRJRCOC",218,0)
Q
"RTN","RCRJRCOR")
0^23^B71059694
"RTN","RCRJRCOR",1,0)
RCRJRCOR ;WISC/RFJ-ar data collector summary report ;1 Mar 97
"RTN","RCRJRCOR",2,0)
;;4.5;Accounts Receivable;**68,96,139,103,156,170,174,191,220,138,239,320,338**;Mar 20, 1995;Build 70
"RTN","RCRJRCOR",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCRJRCOR",4,0)
Q
"RTN","RCRJRCOR",5,0)
;
"RTN","RCRJRCOR",6,0)
;
"RTN","RCRJRCOR",7,0)
SEND ; send data to ndb and data to FMS
"RTN","RCRJRCOR",8,0)
N %,AMOUNT,DATEMOYR,FUND,LINE,RSC,SPACE,TOTAL,TOTALFUN,TOTALTYP,TYPE,X,XMY,Y
"RTN","RCRJRCOR",9,0)
;
"RTN","RCRJRCOR",10,0)
; ---------- send to ndb ----------
"RTN","RCRJRCOR",11,0)
; data stored in tmp($j,rcrjrcolndb)
"RTN","RCRJRCOR",12,0)
I '$G(RCRJFAR1) D NDB(PRCASITE,DATEBEG,DATEEND)
"RTN","RCRJRCOR",13,0)
;
"RTN","RCRJRCOR",14,0)
;
"RTN","RCRJRCOR",15,0)
; ---------- send sv to fms ----------
"RTN","RCRJRCOR",16,0)
; data stored in tmp($j,rcrjrcolsv)
"RTN","RCRJRCOR",17,0)
; rcrjfsv is a flag set in the routine rcrjrco for retransmission
"RTN","RCRJRCOR",18,0)
; to prevent accepted fms documents from being resent
"RTN","RCRJRCOR",19,0)
I '$G(RCRJFSV) D STARTSV^RCXFMSSV(DATEEND)
"RTN","RCRJRCOR",20,0)
;
"RTN","RCRJRCOR",21,0)
;
"RTN","RCRJRCOR",22,0)
; ---------- send wr to fms ----------
"RTN","RCRJRCOR",23,0)
; data stored in tmp($j,rcrjrcolwr)
"RTN","RCRJRCOR",24,0)
; rcrjfwr is a flag set in the routine rcrjrco for retransmission
"RTN","RCRJRCOR",25,0)
; to prevent accepted fms documents from being resent
"RTN","RCRJRCOR",26,0)
I '$G(RCRJFWR) D STARTWR^RCXFMSWR(DATEEND)
"RTN","RCRJRCOR",27,0)
;
"RTN","RCRJRCOR",28,0)
; ---------- send tr to fms ----------
"RTN","RCRJRCOR",29,0)
N RCTRANS
"RTN","RCRJRCOR",30,0)
; this call returns rctrans array (see rcxfmstx for description)
"RTN","RCRJRCOR",31,0)
; rcrjftr is a flag set in the routine rcrjrco for retransmission
"RTN","RCRJRCOR",32,0)
; to prevent accepted fms documents from being resent
"RTN","RCRJRCOR",33,0)
I '$G(RCRJFTR) D STARTTR^RCXFMSTX(DATEEND)
"RTN","RCRJRCOR",34,0)
;
"RTN","RCRJRCOR",35,0)
; ---------- send oig extract ----------
"RTN","RCRJRCOR",36,0)
; data stored in tmp(j,rcrjroig)
"RTN","RCRJRCOR",37,0)
; get non-mccf bills for extract and user report
"RTN","RCRJRCOR",38,0)
D NONMCCF^RCRJROIG(DATEEND)
"RTN","RCRJRCOR",39,0)
; rcrjfoig is a flag set in the routine rcrjrco for retransmission
"RTN","RCRJRCOR",40,0)
; to prevent the oig extract from being resent
"RTN","RCRJRCOR",41,0)
I '$G(RCRJFOIG) D OIG^RCRJROIG(DATEEND)
"RTN","RCRJRCOR",42,0)
;
"RTN","RCRJRCOR",43,0)
; generate a mailman message to the group showing the data
"RTN","RCRJRCOR",44,0)
K ^TMP($J,"RCRJRCORMM")
"RTN","RCRJRCOR",45,0)
S Y=$E(DATEEND,1,5)_"00" D DD^%DT S DATEMOYR=Y
"RTN","RCRJRCOR",46,0)
S LINE=0,SPACE="",$P(SPACE," ",80)=""
"RTN","RCRJRCOR",47,0)
D SET("Data has been collected for the month "_DATEMOYR_". The data has been")
"RTN","RCRJRCOR",48,0)
D SET("transmitted to the following systems:")
"RTN","RCRJRCOR",49,0)
D SET(" ")
"RTN","RCRJRCOR",50,0)
;
"RTN","RCRJRCOR",51,0)
I '$G(RCRJFAR1) D
"RTN","RCRJRCOR",52,0)
. D SET("NATIONAL DATABASE DATA")
"RTN","RCRJRCOR",53,0)
. D SET("----------------------")
"RTN","RCRJRCOR",54,0)
. D SET("The data has been sent to the National Database. For a detail list")
"RTN","RCRJRCOR",55,0)
. D SET("of the data sent, please review the Return Reports which are sent")
"RTN","RCRJRCOR",56,0)
. D SET("from the National Database.")
"RTN","RCRJRCOR",57,0)
. D SET(" ")
"RTN","RCRJRCOR",58,0)
;
"RTN","RCRJRCOR",59,0)
I '$G(RCRJFSV) D
"RTN","RCRJRCOR",60,0)
. D SET("FMS, STANDARD VOUCHER (SV) DOCUMENT")
"RTN","RCRJRCOR",61,0)
. D SET("-----------------------------------")
"RTN","RCRJRCOR",62,0)
. D SET("The following data has been transmitted to FMS in the SV document:")
"RTN","RCRJRCOR",63,0)
. D SET(" Revenue Source Code Type Amount")
"RTN","RCRJRCOR",64,0)
. D SET(" ------------------- ---- ------")
"RTN","RCRJRCOR",65,0)
. S TOTAL=0
"RTN","RCRJRCOR",66,0)
. S TYPE="" F S TYPE=$O(^TMP($J,"RCRJRCOLSV",TYPE)) Q:TYPE="" D
"RTN","RCRJRCOR",67,0)
. . I TYPE=17!(TYPE=18) Q ; display the Medicare totals later
"RTN","RCRJRCOR",68,0)
. . S TOTALTYP=0
"RTN","RCRJRCOR",69,0)
. . S FUND="" F S FUND=$O(^TMP($J,"RCRJRCOLSV",TYPE,FUND)) Q:FUND="" D
"RTN","RCRJRCOR",70,0)
. . . S TOTALFUN=0
"RTN","RCRJRCOR",71,0)
. . . S RSC="" F S RSC=$O(^TMP($J,"RCRJRCOLSV",TYPE,FUND,RSC)) Q:RSC="" S AMOUNT=^(RSC) D
"RTN","RCRJRCOR",72,0)
. . . . D SET(" "_RSC_" "_$E($$GETDESC^RCXFMSPR(RSC)_SPACE,1,54)_" "_TYPE_$J(AMOUNT,13,2))
"RTN","RCRJRCOR",73,0)
. . . . S TOTALFUN=TOTALFUN+AMOUNT
"RTN","RCRJRCOR",74,0)
. . . . S TOTALTYP=TOTALTYP+AMOUNT
"RTN","RCRJRCOR",75,0)
. . . . S TOTAL=TOTAL+AMOUNT
"RTN","RCRJRCOR",76,0)
. . . ;
"RTN","RCRJRCOR",77,0)
. . . ;N RCFUND S RCFUND=$S($E(DATEEND,2,5)<"0410":$E(FUND,1,4)_"."_$E(FUND,6),1:$E(FUND,1,4)_"0"_$E(FUND,6))
"RTN","RCRJRCOR",78,0)
. . . N RCFUND S RCFUND=$S($E(DATEEND,2,5)<"0410":$E(FUND,1,4)_"."_$E(FUND,6),FUND>528700:FUND,1:$E(FUND,1,4)_"0"_$E(FUND,6))
"RTN","RCRJRCOR",79,0)
. . . ;I TYPE=21 D SET($E(" Sub-Total by Fund "_RCFUND_":"_SPACE,1,38)_$J(TOTALFUN,12,2))
"RTN","RCRJRCOR",80,0)
. . . D SET($E(" Sub-Total by Fund "_RCFUND_":"_SPACE,1,38)_$J(TOTALFUN,12,2))
"RTN","RCRJRCOR",81,0)
. . ;
"RTN","RCRJRCOR",82,0)
. . D SET(" ----------")
"RTN","RCRJRCOR",83,0)
. . D SET(" TOTAL TYPE "_TYPE_$J(TOTALTYP,13,2))
"RTN","RCRJRCOR",84,0)
. . D SET(" ")
"RTN","RCRJRCOR",85,0)
. ;
"RTN","RCRJRCOR",86,0)
. ; Display Medicare totals and update the SV total
"RTN","RCRJRCOR",87,0)
. S AMOUNT=+$G(^TMP($J,"RCRJRCOLSV",17)),TOTAL=TOTAL+AMOUNT
"RTN","RCRJRCOR",88,0)
. D SET(" Medicare Contractual Adjustment TOTAL TYPE 17"_$J(AMOUNT,13,2))
"RTN","RCRJRCOR",89,0)
. S AMOUNT=+$G(^TMP($J,"RCRJRCOLSV",18)),TOTAL=TOTAL+AMOUNT
"RTN","RCRJRCOR",90,0)
. D SET(" Unreimbursable Medicare Expense TOTAL TYPE 18"_$J(AMOUNT,13,2))
"RTN","RCRJRCOR",91,0)
. D SET(" ")
"RTN","RCRJRCOR",92,0)
. ;
"RTN","RCRJRCOR",93,0)
. D SET(" ----------")
"RTN","RCRJRCOR",94,0)
. D SET(" TOTAL SV"_$J(TOTAL,13,2))
"RTN","RCRJRCOR",95,0)
. D SET(" ")
"RTN","RCRJRCOR",96,0)
;
"RTN","RCRJRCOR",97,0)
I '$G(RCRJFWR) D
"RTN","RCRJRCOR",98,0)
. D SET("FMS, WRITEOFFS/CONTRACT ADJUSTMENTS (WR) DOCUMENT")
"RTN","RCRJRCOR",99,0)
. D SET("-------------------------------------------------")
"RTN","RCRJRCOR",100,0)
. D SET("The following data has been transmitted to FMS in the WR document:")
"RTN","RCRJRCOR",101,0)
. D SET(" Revenue Source Code Type Amount")
"RTN","RCRJRCOR",102,0)
. D SET(" ------------------- ---- ------")
"RTN","RCRJRCOR",103,0)
. S TOTAL=0
"RTN","RCRJRCOR",104,0)
. S TYPE="" F S TYPE=$O(^TMP($J,"RCRJRCOLWR",TYPE)) Q:TYPE="" D
"RTN","RCRJRCOR",105,0)
. . S TOTALTYP=0
"RTN","RCRJRCOR",106,0)
. . S FUND="" F S FUND=$O(^TMP($J,"RCRJRCOLWR",TYPE,FUND)) Q:FUND="" D
"RTN","RCRJRCOR",107,0)
. . . S TOTALFUN=0
"RTN","RCRJRCOR",108,0)
. . . S RSC="" F S RSC=$O(^TMP($J,"RCRJRCOLWR",TYPE,FUND,RSC)) Q:RSC="" S AMOUNT=^(RSC) D
"RTN","RCRJRCOR",109,0)
. . . . D SET(" "_RSC_" "_$E($$GETDESC^RCXFMSPR(RSC)_SPACE,1,54)_" "_TYPE_$J(AMOUNT,13,2))
"RTN","RCRJRCOR",110,0)
. . . . S TOTALFUN=TOTALFUN+AMOUNT
"RTN","RCRJRCOR",111,0)
. . . . S TOTALTYP=TOTALTYP+AMOUNT
"RTN","RCRJRCOR",112,0)
. . . . S TOTAL=TOTAL+AMOUNT
"RTN","RCRJRCOR",113,0)
. . . ;
"RTN","RCRJRCOR",114,0)
. . . N RCFUND S RCFUND=$S($E(DATEEND,2,5)<"0410":$E(FUND,1,4)_"."_$E(FUND,6),FUND>528700:FUND,1:$E(FUND,1,4)_"0"_$E(FUND,6)) ;PRCA*4.5*338
"RTN","RCRJRCOR",115,0)
. . . ;I TYPE=37 D SET($E(" Sub-Total by Fund "_RCFUND_":"_SPACE,1,38)_$J(TOTALFUN,12,2))
"RTN","RCRJRCOR",116,0)
. . . D SET($E(" Sub-Total by Fund "_RCFUND_":"_SPACE,1,38)_$J(TOTALFUN,12,2))
"RTN","RCRJRCOR",117,0)
. . ;
"RTN","RCRJRCOR",118,0)
. . D SET(" ----------")
"RTN","RCRJRCOR",119,0)
. . D SET(" TOTAL TYPE "_TYPE_$J(TOTALTYP,13,2))
"RTN","RCRJRCOR",120,0)
. . D SET(" ")
"RTN","RCRJRCOR",121,0)
. D SET(" ----------")
"RTN","RCRJRCOR",122,0)
. D SET(" TOTAL WR"_$J(TOTAL,13,2))
"RTN","RCRJRCOR",123,0)
. D SET(" ")
"RTN","RCRJRCOR",124,0)
;
"RTN","RCRJRCOR",125,0)
I '$G(RCRJFTR) D
"RTN","RCRJRCOR",126,0)
. D SET("FMS, TRANSFER FROM MCCF TO HSIF (TR) DOCUMENT")
"RTN","RCRJRCOR",127,0)
. D SET("-------------------------------------------------")
"RTN","RCRJRCOR",128,0)
. D SET("The following data has been transmitted to FMS in the TR document:")
"RTN","RCRJRCOR",129,0)
. D SET(" From Fund From RSC To Fund To RSC Amount")
"RTN","RCRJRCOR",130,0)
. D SET(" --------- -------- ------- ------ ----------")
"RTN","RCRJRCOR",131,0)
. I $O(RCTRANS(""))="" D SET(" No Dollars to Transfer.") Q
"RTN","RCRJRCOR",132,0)
. ;
"RTN","RCRJRCOR",133,0)
. S FUND="" F S FUND=$O(RCTRANS(FUND)) Q:FUND="" D
"RTN","RCRJRCOR",134,0)
. . S RSC="" F S RSC=$O(RCTRANS(FUND,RSC)) Q:RSC="" D
"RTN","RCRJRCOR",135,0)
. . . ; rctrans(fromfund,fromrsc) = tofund ^ torsc ^ amount
"RTN","RCRJRCOR",136,0)
. . . S AMOUNT=RCTRANS(FUND,RSC)
"RTN","RCRJRCOR",137,0)
. . . D SET($J(FUND,11)_$J(RSC,12)_$J($P(AMOUNT,"^"),14)_$J($P(AMOUNT,"^",2),10)_$J($P(AMOUNT,"^",3),31,2))
"RTN","RCRJRCOR",138,0)
;
"RTN","RCRJRCOR",139,0)
S XMY("G.RC AR DATA COLLECTOR")=""
"RTN","RCRJRCOR",140,0)
S %=$$SENDMSG("AR Data Collector for "_DATEMOYR_" Station "_PRCASITE,.XMY)
"RTN","RCRJRCOR",141,0)
K ^TMP($J,"RCRJRCORMM")
"RTN","RCRJRCOR",142,0)
;
"RTN","RCRJRCOR",143,0)
; send users detail report
"RTN","RCRJRCOR",144,0)
;D USERREPT^RCRJRCOU(DATEMOYR) ;removed from backround job p315 (FY16 HAPE RRE PRCA*4.5*320)
"RTN","RCRJRCOR",145,0)
Q
"RTN","RCRJRCOR",146,0)
;
"RTN","RCRJRCOR",147,0)
;
"RTN","RCRJRCOR",148,0)
NDB(PRCASITE,DATEBEG,DATEEND) ; send data to the national database
"RTN","RCRJRCOR",149,0)
N %,BATCNAME,COUNT,CRITERIA,DATA,LINE,XMY,X,Y
"RTN","RCRJRCOR",150,0)
K ^TMP($J,"RCRJRCORMM")
"RTN","RCRJRCOR",151,0)
S LINE=2,DATA="D$ "
"RTN","RCRJRCOR",152,0)
S CRITERIA="" F COUNT=1:1 S CRITERIA=$O(^TMP($J,"RCRJRCOLNDB",CRITERIA)) Q:CRITERIA="" D
"RTN","RCRJRCOR",153,0)
. S DATA=DATA_":"_COUNT_"/"_CRITERIA_"/"_^TMP($J,"RCRJRCOLNDB",CRITERIA)
"RTN","RCRJRCOR",154,0)
. I $L(DATA)>200 D SET(DATA) S DATA="D$ "
"RTN","RCRJRCOR",155,0)
I DATA'="D$ " D SET(DATA)
"RTN","RCRJRCOR",156,0)
;
"RTN","RCRJRCOR",157,0)
; build the first two control lines in mail message
"RTN","RCRJRCOR",158,0)
S Y=DATEBEG D DD^%DT
"RTN","RCRJRCOR",159,0)
S BATCNAME="AR1-"_$E(Y,1,3)_$E(DATEBEG,6,7)_$TR($P(Y,",",2)," ")
"RTN","RCRJRCOR",160,0)
S Y=DATEEND D DD^%DT
"RTN","RCRJRCOR",161,0)
S BATCNAME=BATCNAME_"-"_$E(Y,1,3)_$E(DATEEND,6,7)_$TR($P(Y,",",2)," ")
"RTN","RCRJRCOR",162,0)
S ^TMP($J,"RCRJRCORMM",1)="T$ "_PRCASITE_"$"_BATCNAME_"$$$$$*"
"RTN","RCRJRCOR",163,0)
; get end time (in %)
"RTN","RCRJRCOR",164,0)
D NOW^%DTC
"RTN","RCRJRCOR",165,0)
S ^TMP($J,"RCRJRCORMM",2)="S$ "_STRTTIME_"^"_%_"$0$"_(COUNT-1)
"RTN","RCRJRCOR",166,0)
;
"RTN","RCRJRCOR",167,0)
S XMY("S.PRQN DATA COLLECTION
PII ")=""
"RTN","RCRJRCOR",168,0)
S %=$$SENDMSG("AR1 "_$E(DATEEND,4,5)_"/"_$E(DATEEND,2,3)_" NDB DATA FOR SITE "_PRCASITE,.XMY)
"RTN","RCRJRCOR",169,0)
K ^TMP($J,"RCRJRCORMM")
"RTN","RCRJRCOR",170,0)
Q
"RTN","RCRJRCOR",171,0)
;
"RTN","RCRJRCOR",172,0)
;
"RTN","RCRJRCOR",173,0)
SUMMARY ; print summary report in mailman bulletin
"RTN","RCRJRCOR",174,0)
N %,BILLDA,CRITER2,CRITERIA,DATA0,DFN,LINE,STAT,TOTAL,VA,XMY
"RTN","RCRJRCOR",175,0)
K ^TMP($J,"RCRJRCOR") ; used to identify test patients
"RTN","RCRJRCOR",176,0)
K ^TMP($J,"RCRJRCORMM") ; used to build mailman message
"RTN","RCRJRCOR",177,0)
;
"RTN","RCRJRCOR",178,0)
; print any test patient bills which have not been closed
"RTN","RCRJRCOR",179,0)
S BILLDA=0 F S BILLDA=$O(^TMP($J,"RCRJRCOL","CRIT2",1,BILLDA)) Q:'BILLDA I $D(^(BILLDA,1)) D
"RTN","RCRJRCOR",180,0)
. S DATA0=$G(^PRCA(430,BILLDA,0)),STAT=$P(DATA0,"^",8)
"RTN","RCRJRCOR",181,0)
. I STAT'=16,STAT='42 Q ; bill not currently open
"RTN","RCRJRCOR",182,0)
. S DFN=+$P(DATA0,"^",7) I 'DFN Q
"RTN","RCRJRCOR",183,0)
. D PID^VADPT
"RTN","RCRJRCOR",184,0)
. I $E($TR($G(VA("PID")),"-"),1,5)="00000" S ^TMP($J,"RCRJRCOR","TEST",BILLDA)=""
"RTN","RCRJRCOR",185,0)
;
"RTN","RCRJRCOR",186,0)
I '$D(^TMP($J,"RCRJRCOR","TEST")) Q
"RTN","RCRJRCOR",187,0)
;
"RTN","RCRJRCOR",188,0)
; print data
"RTN","RCRJRCOR",189,0)
S LINE=0
"RTN","RCRJRCOR",190,0)
D SET(" ")
"RTN","RCRJRCOR",191,0)
D SET("The following bills are active and linked to test patients:")
"RTN","RCRJRCOR",192,0)
S BILLDA=0 F S BILLDA=$O(^TMP($J,"RCRJRCOR","TEST",BILLDA)) Q:'BILLDA D SET(" "_$P($G(^PRCA(430,BILLDA,0)),"^")_" (#",BILLDA_")")
"RTN","RCRJRCOR",193,0)
;
"RTN","RCRJRCOR",194,0)
S XMY("G.RC AR DATA COLLECTOR")=""
"RTN","RCRJRCOR",195,0)
S %=$$SENDMSG("MCCR DATA COLLECTOR INFORMATION",.XMY)
"RTN","RCRJRCOR",196,0)
K ^TMP($J,"RCRJRCOR")
"RTN","RCRJRCOR",197,0)
K ^TMP($J,"RCRJRCORMM")
"RTN","RCRJRCOR",198,0)
Q
"RTN","RCRJRCOR",199,0)
;
"RTN","RCRJRCOR",200,0)
;
"RTN","RCRJRCOR",201,0)
SET(DATA) ; store report
"RTN","RCRJRCOR",202,0)
S LINE=LINE+1,^TMP($J,"RCRJRCORMM",LINE)=DATA
"RTN","RCRJRCOR",203,0)
Q
"RTN","RCRJRCOR",204,0)
;
"RTN","RCRJRCOR",205,0)
;
"RTN","RCRJRCOR",206,0)
SENDMSG(XMSUB,XMY) ; send message with subject and recipients
"RTN","RCRJRCOR",207,0)
N %X,D0,D1,D2,DIC,DICR,DIW,X,XCNP,XMDISPI,XMDUN,XMDUZ,XMTEXT,XMZ,ZTPAR
"RTN","RCRJRCOR",208,0)
S XMDUZ="AR PACKAGE",XMTEXT="^TMP($J,""RCRJRCORMM"","
"RTN","RCRJRCOR",209,0)
D ^XMD
"RTN","RCRJRCOR",210,0)
Q +$G(XMZ)
"RTN","RCRJRCOU")
0^19^B143002587
"RTN","RCRJRCOU",1,0)
RCRJRCOU ;WISC/RFJ-ar data collector summary report ;1 Mar 97
"RTN","RCRJRCOU",2,0)
;;4.5;Accounts Receivable;**103,320,335,338**;Mar 20, 1995;Build 70
"RTN","RCRJRCOU",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCRJRCOU",4,0)
Q
"RTN","RCRJRCOU",5,0)
; IA - 4398 FIRST^VAUTOMA
"RTN","RCRJRCOU",6,0)
; 4385 $$MRATYPE^IBCEMU2
"RTN","RCRJRCOU",7,0)
;
"RTN","RCRJRCOU",8,0)
;
"RTN","RCRJRCOU",9,0)
;ARDC detailed report - Modified to print directly as per PRCA*4.5*320 (HAPE FY16 RRE)
"RTN","RCRJRCOU",10,0)
; a MailMan message is no longer generated by this routine !
"RTN","RCRJRCOU",11,0)
; Called by VistA Option - PRCA ARDC REPORT (ARDC Detail Report)
"RTN","RCRJRCOU",12,0)
;
"RTN","RCRJRCOU",13,0)
START ; Entry point from the Option
"RTN","RCRJRCOU",14,0)
N VAUTSTR,VAUTNI,DIC,Y,SCREEN,EXCEL,VAUTC,QUIT,DTFRMTO,BGDT,RCSTDT
"RTN","RCRJRCOU",15,0)
;
"RTN","RCRJRCOU",16,0)
S QUIT=0
"RTN","RCRJRCOU",17,0)
N TXT,MSG F TXT=1:1:12 S MSG=$T(MENU+TXT) W !,?5,$P(MSG,";;",2)
"RTN","RCRJRCOU",18,0)
S SCREEN="^16^18^32^33^40^42^",DIC="^PRCA(430.3,",VAUTNI=2,VAUTSTR="Status",VAUTVB="VAUTC",DIC("S")="I SCREEN[(U_Y_U)" D FIRST^VAUTOMA
"RTN","RCRJRCOU",19,0)
I VAUTC=1 F I=2:1:7 S VAUTC($P(SCREEN,U,I))=$P(^PRCA(430.3,$P(SCREEN,U,I),0),U) ;set array equal to the screen if ALL was selected
"RTN","RCRJRCOU",20,0)
Q:'$D(VAUTC)!(Y=-1)
"RTN","RCRJRCOU",21,0)
N TXT,MSG W ! F TXT=1:1:12 S MSG=$T(DESCTEXT+TXT) W !,?3,$P(MSG,";;",2)
"RTN","RCRJRCOU",22,0)
W !!,?10,"<< Checking available dates. Please wait >>"
"RTN","RCRJRCOU",23,0)
D FIRST ;Get earliest date for selected Status
"RTN","RCRJRCOU",24,0)
W !!,"The earliest date on file for selected status is: ",$G(BGDT)
"RTN","RCRJRCOU",25,0)
S DTFRMTO=$$DTFRMTO Q:'DTFRMTO ;Get date range for report
"RTN","RCRJRCOU",26,0)
S EXCEL=0,PROMPT="CAPTURE Report data to an Excel Document?",DIR(0)="Y",DIR("?")="^D HEXC^RCRJRCOU"
"RTN","RCRJRCOU",27,0)
S EXCEL=$$SELECT^RCTCSJR(PROMPT,"NO") I "01"'[EXCEL Q
"RTN","RCRJRCOU",28,0)
I EXCEL=1 D EXCMSG^RCTCSJR ; Display Excel display message
"RTN","RCRJRCOU",29,0)
I 'EXCEL W !!,"This report requires 132 characters",!
"RTN","RCRJRCOU",30,0)
K IOP,IO("Q") S %ZIS="MQ",%ZIS("B")="" D ^%ZIS Q:POP
"RTN","RCRJRCOU",31,0)
I $D(IO("Q")) D Q
"RTN","RCRJRCOU",32,0)
.S ZTDESC="ARDC Detail Report",ZTRTN="DQ^RCRJRCOU"
"RTN","RCRJRCOU",33,0)
.S ZTSAVE("VAUTC*")="",ZTSAVE("RCRET")="",ZTSAVE("DTFRMTO")="",ZTSAVE("ZTREQ")="@",ZTSAVE("EXCEL")=""
"RTN","RCRJRCOU",34,0)
.D ^%ZTLOAD,HOME^%ZIS S QUIT=1
"RTN","RCRJRCOU",35,0)
W !!,"<*> please wait <*>"
"RTN","RCRJRCOU",36,0)
;
"RTN","RCRJRCOU",37,0)
DQ ; generate user detailed report
"RTN","RCRJRCOU",38,0)
N DATEEND,RCDATE,BILLDA,DATA,RCLINE,REPTDATA,Y,RCBILLN,RCDTAC,RCCAT,RCSTAT,TRANTYP,RCTOT,RCPRIN,RCRSC,PRCASITE,VAUTVB,XMNOW
"RTN","RCRJRCOU",39,0)
N STAT,BILLDA,RCRSC,RECORD,RCBAL,ARACTDT,DATEMOYR,MRATYPE,POP,RCFUND,RCOTHER,TYPE,RCOUT,CURDT,DTFRM,DTFROM,DTTO,RCRET,LIST,ERR
"RTN","RCRJRCOU",40,0)
N RCACCRD,RCRHITYP
"RTN","RCRJRCOU",41,0)
;
"RTN","RCRJRCOU",42,0)
S (RCDATE,DTFRM)=$$FMADD^XLFDT(+$P(DTFRMTO,U,2)),DTTO=$P(DTFRMTO,U,3),CURDT=0
"RTN","RCRJRCOU",43,0)
S XMNOW=$$NOW^XLFDT ;Capture the date and time the report was started for the header
"RTN","RCRJRCOU",44,0)
S DATEEND=$$LDATE^RCRJR(DT),DATEMOYR=$E(DATEEND,1,5)_"00"
"RTN","RCRJRCOU",45,0)
S PRCASITE=$$SITE^RCMSITE
"RTN","RCRJRCOU",46,0)
S RCRET=$NA(^TMP($J,"RCRJRCOU")) K @RCRET
"RTN","RCRJRCOU",47,0)
;
"RTN","RCRJRCOU",48,0)
S (RCLINE,STAT)=0 F S STAT=$O(VAUTC(STAT)) Q:'STAT S RCDATE=DTFRM D
"RTN","RCRJRCOU",49,0)
. S BILLDA=0 F S BILLDA=$O(^PRCA(430,"AC",STAT,BILLDA)) Q:'BILLDA D
"RTN","RCRJRCOU",50,0)
..Q:$P(^PRCA(430,BILLDA,0),U,10)=""
"RTN","RCRJRCOU",51,0)
..Q:$P(^PRCA(430,BILLDA,0),U,8)'=STAT ;Quit if the Current Status from the xref is incorrect
"RTN","RCRJRCOU",52,0)
..S RCDATE=$P(^PRCA(430,BILLDA,0),U,10)
"RTN","RCRJRCOU",53,0)
..Q:RCDATE<DTFRM!(RCDATE>DTTO)
"RTN","RCRJRCOU",54,0)
.. ;As per email from the VA - We need to see all bills, not just accrued bills.
"RTN","RCRJRCOU",55,0)
.. ;I $$ACCK^PRCAACC(BILLDA),$P($G(^PRCA(430,BILLDA,0)),"^",2)'=26 D ;from CURRENT^RCRJRCOC
"RTN","RCRJRCOU",56,0)
.. ;
"RTN","RCRJRCOU",57,0)
.. I $P($G(^PRCA(430,BILLDA,0)),"^",2)'=26 D ;from CURRENT^RCRJRCOC
"RTN","RCRJRCOU",58,0)
... S DATA=$G(^PRCA(430,BILLDA,0)) Q:'DATA
"RTN","RCRJRCOU",59,0)
... S (TYPE,TRANTYP,RCRSC,RCFUND,RCPRIN)="",RCBAL=0
"RTN","RCRJRCOU",60,0)
... ; bill number
"RTN","RCRJRCOU",61,0)
... ;S RCBILLN=$P($P(DATA,"^"),"-",2)
"RTN","RCRJRCOU",62,0)
... S RCBILLN=$P(DATA,"^")
"RTN","RCRJRCOU",63,0)
... ; date activated
"RTN","RCRJRCOU",64,0)
... S RCDTAC=$$FMTE^XLFDT(RCDATE,"2Z")
"RTN","RCRJRCOU",65,0)
... ; category
"RTN","RCRJRCOU",66,0)
... S RCCAT=$P($G(^PRCA(430.2,+$P(DATA,"^",2),0)),"^")
"RTN","RCRJRCOU",67,0)
... S RCACCRD=$$GET1^DIQ(430.2,+$P(DATA,"^",2)_",",12,"I")
"RTN","RCRJRCOU",68,0)
... ; status
"RTN","RCRJRCOU",69,0)
... S RCSTAT=$P($G(^PRCA(430.3,+$P(DATA,"^",8),0)),"^")
"RTN","RCRJRCOU",70,0)
... ;PRCA*4.5*338 - re-wrote section to correctly retrieve RSCs, properly ID TRICARE, CHAMPVA BD doc types, and TORT/MRA SV doc types
"RTN","RCRJRCOU",71,0)
... ; - grab fund and RSC from Bill instead of recalculating. Recalculate only if they are NULL
"RTN","RCRJRCOU",72,0)
... S RCRSC=$$GET1^DIQ(430,BILLDA_",",255)
"RTN","RCRJRCOU",73,0)
... S:RCRSC="" RCRSC=$$GET1^DIQ(430,BILLDA_",",255.1)
"RTN","RCRJRCOU",74,0)
... I $$ACCK^PRCAACC(BILLDA) S:RCRSC="" RCRSC=$$CALCRSC^RCXFMSUR(BILLDA) ; (as per CURRENT^RCRJRCOC)
"RTN","RCRJRCOU",75,0)
... ;Fund
"RTN","RCRJRCOU",76,0)
... S RCFUND=$$GET1^DIQ(430,BILLDA_",",203)
"RTN","RCRJRCOU",77,0)
... I RCFUND="" S RCFUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
"RTN","RCRJRCOU",78,0)
... S TYPE="SV21" ; Default the doc type.
"RTN","RCRJRCOU",79,0)
... ; special type for tort feasor
"RTN","RCRJRCOU",80,0)
... I RCCAT["TORT" S TYPE="2A" ;Using the category name to look for TORTs
"RTN","RCRJRCOU",81,0)
... ; Get AR Date Active for bill
"RTN","RCRJRCOU",82,0)
... S ARACTDT=+$P($P($G(^PRCA(430,BILLDA,6)),"^",21),".") ; (as per START^RCRJRBD)
"RTN","RCRJRCOU",83,0)
... ; determine Receivable Type: 1=pre-MRA, 2=post-MRA Medicre, 3=post-MRA non-Medicare
"RTN","RCRJRCOU",84,0)
... ; fms report type - TRANTYP variable
"RTN","RCRJRCOU",85,0)
... S MRATYPE=$$MRATYPE^IBCEMU2(BILLDA,ARACTDT) ; (as per CURRENT^RCRJRCOC)
"RTN","RCRJRCOU",86,0)
... ; Set TYPE to 2F for post-MRA Medicare bills or to 2L for post-MRA non-Medicare bills (for RHI receivables only)
"RTN","RCRJRCOU",87,0)
... ; Moved TYPE set for RHI to function call to ensure Community Care RSCs are captured correctly.
"RTN","RCRJRCOU",88,0)
... S RCRHITYP=$$RHITYPE^RCRJRCOC(RCRSC,MRATYPE,RCCAT) S:+RCRHITYP TYPE=$P(RCRHITYP,U,2)
"RTN","RCRJRCOU",89,0)
... I 'RCACCRD S TYPE="BD" ; Non accrued have BD FMS doc types.
"RTN","RCRJRCOU",90,0)
... S TRANTYP=$G(TYPE),REPTDATA=""
"RTN","RCRJRCOU",91,0)
... K LIST D FIND^DIC(430,,"@;71;11;IX","M","`"_BILLDA,,,,,"LIST","ERR")
"RTN","RCRJRCOU",92,0)
... S RCPRIN=$G(LIST("DILIST","ID",1,71)),RCBAL=$G(LIST("DILIST","ID",1,11))
"RTN","RCRJRCOU",93,0)
... I RCBAL'>0 Q ;Don't show if current balance not greater than $0
"RTN","RCRJRCOU",94,0)
... S RCPRIN=$J(RCPRIN,9,2),RCBAL=$J(RCBAL,10,2)
"RTN","RCRJRCOU",95,0)
... S RCLINE=RCLINE+1 ;(record counter)
"RTN","RCRJRCOU",96,0)
... S @RCRET@(RCLINE)=RCBILLN_U_RCDTAC_U_RCCAT_U_RCSTAT_U_TRANTYP_U_RCFUND_U_RCRSC_U_RCPRIN_U_RCBAL
"RTN","RCRJRCOU",97,0)
; end of gathering data
"RTN","RCRJRCOU",98,0)
;
"RTN","RCRJRCOU",99,0)
I RCLINE=0 W !!,"***The report found no receivables that match your selection***",!! G EXIT
"RTN","RCRJRCOU",100,0)
;
"RTN","RCRJRCOU",101,0)
D PRINT
"RTN","RCRJRCOU",102,0)
;
"RTN","RCRJRCOU",103,0)
EXIT ;commom exit point
"RTN","RCRJRCOU",104,0)
D ^%ZISC
"RTN","RCRJRCOU",105,0)
K ^TMP($J,"RCRJRCOU")
"RTN","RCRJRCOU",106,0)
Q
"RTN","RCRJRCOU",107,0)
;
"RTN","RCRJRCOU",108,0)
HDR ;Set the header
"RTN","RCRJRCOU",109,0)
;
"RTN","RCRJRCOU",110,0)
S PAGE=PAGE+1 U IO W @IOF
"RTN","RCRJRCOU",111,0)
I 'EXCEL W ?14,"ARDC Detailed Report",?50,"Run Date: ",$$FMTE^XLFDT(XMNOW,"2Z"),?107,"Page:",PAGE,!
"RTN","RCRJRCOU",112,0)
I EXCEL W U_"ARDC Detailed Report"_U_U_"Run Date: "_$$FMTE^XLFDT(XMNOW,"2Z")_U_U_U_U_"Page:"_PAGE,!
"RTN","RCRJRCOU",113,0)
N I F I=1:1:120 W "-"
"RTN","RCRJRCOU",114,0)
I 'EXCEL W !,"Bill#",?14,"Create",?26,"AR Category",?50,"Bill",?68,"FMS",?75,"Fund",?84,"RSC",?93,"Principal",?107,"Current"
"RTN","RCRJRCOU",115,0)
I 'EXCEL W !,?14,"Date",?50,"Status",?75,"Type",?96,"Amount",?107,"Balance",!
"RTN","RCRJRCOU",116,0)
I EXCEL W !,"Bill#"_U_"Create"_U_"AR Category"_U_"Bill"_U_"FMS"_U_"Fund"_U_"RSC"_U_"Principal"_U_"Current"
"RTN","RCRJRCOU",117,0)
I EXCEL W !,U_"Date"_U_U_"Status"_U_U_"Type"_U_U_"Amount"_U_"Balance",!
"RTN","RCRJRCOU",118,0)
N I F I=1:1:120 W "-"
"RTN","RCRJRCOU",119,0)
Q
"RTN","RCRJRCOU",120,0)
;
"RTN","RCRJRCOU",121,0)
PRINT ; print records to screen or printer
"RTN","RCRJRCOU",122,0)
N PAGE S (RCOUT,PAGE)=0,RECORD=0
"RTN","RCRJRCOU",123,0)
F S RECORD=$O(@RCRET@(RECORD)) Q:'RECORD!(RCOUT) D
"RTN","RCRJRCOU",124,0)
. I RECORD=1 D HDR
"RTN","RCRJRCOU",125,0)
. I 'EXCEL,$Y+3>IOSL I ($E(IOST,1,2)="C-")&(IO=IO(0)) S DIR(0)="E" D ^DIR K DIR D
"RTN","RCRJRCOU",126,0)
.. I $D(DTOUT)!($D(DUOUT)) S RCOUT=1 G EXIT
"RTN","RCRJRCOU",127,0)
.. D HDR
"RTN","RCRJRCOU",128,0)
. Q:RCOUT
"RTN","RCRJRCOU",129,0)
. I 'EXCEL W !,$P(@RCRET@(RECORD),U),?14,$P(@RCRET@(RECORD),U,2),?26,$E($P(@RCRET@(RECORD),U,3),1,20),?50,$E($P(@RCRET@(RECORD),U,4),1,15),?68,$P(@RCRET@(RECORD),U,5)
"RTN","RCRJRCOU",130,0)
. I 'EXCEL W ?75,$P(@RCRET@(RECORD),U,6),?84,$P(@RCRET@(RECORD),U,7),?92,$P(@RCRET@(RECORD),U,8),?104,$P(@RCRET@(RECORD),U,9)
"RTN","RCRJRCOU",131,0)
. I EXCEL W !,$P(@RCRET@(RECORD),U)_U_$P(@RCRET@(RECORD),U,2)_U_$P(@RCRET@(RECORD),U,3)_U_$P(@RCRET@(RECORD),U,4)_U_$P(@RCRET@(RECORD),U,5)
"RTN","RCRJRCOU",132,0)
. I EXCEL W U_$P(@RCRET@(RECORD),U,6)_U_$P(@RCRET@(RECORD),U,7)_U_$P(@RCRET@(RECORD),U,8)_U_$P(@RCRET@(RECORD),U,9)
"RTN","RCRJRCOU",133,0)
I 'EXCEL,$E(IOST,1,2)="C-" R !!,"END OF REPORT...PRESS RETURN TO CONTINUE",X:DTIME W @IOF
"RTN","RCRJRCOU",134,0)
Q
"RTN","RCRJRCOU",135,0)
;
"RTN","RCRJRCOU",136,0)
DTFRMTO(PROMPT) ;Get from and to dates (added as per PRCA*4.5*320 to be able to sort by dates for reports)
"RTN","RCRJRCOU",137,0)
N %DT,Y,X,BEGDT,ENDDT,DTOUT,OUT,DIRUT,DUOUT,DIROUT,STATUS,BDT,STDT,STATUS
"RTN","RCRJRCOU",138,0)
;INPUT ; PROMPT - Message to display prior to prompting for dates
"RTN","RCRJRCOU",139,0)
;OUTPUT: 1^BEGDT^ENDDT - Data found
"RTN","RCRJRCOU",140,0)
; 0 - User up arrowed or timed out
"RTN","RCRJRCOU",141,0)
;If they want to show first available date for that set of Status, use this sub
"RTN","RCRJRCOU",142,0)
S OUT=0
"RTN","RCRJRCOU",143,0)
;W !,$G(PROMPT)
"RTN","RCRJRCOU",144,0)
S %DT="AEX",%DT("A")="Date Range: FROM: " ;Enter Beginning Date: "
"RTN","RCRJRCOU",145,0)
W ! D ^%DT K %DT
"RTN","RCRJRCOU",146,0)
I Y<0 W !!,"No Date selected, quitting. ",!! Q OUT ;Quit if user time out or didn't enter valid date
"RTN","RCRJRCOU",147,0)
S DTFROM=+Y,%DT="AEX",%DT("A")=" TO: ",%DT("B")="T" ;"TODAY"
"RTN","RCRJRCOU",148,0)
D ^%DT
"RTN","RCRJRCOU",149,0)
K %DT
"RTN","RCRJRCOU",150,0)
;Quit if user time out or didn't enter valid date
"RTN","RCRJRCOU",151,0)
I Y<0 W !!,"No Date selected, quitting. ",!! Q OUT
"RTN","RCRJRCOU",152,0)
S DTTO=+Y,OUT=1_U_DTFROM_U_DTTO
"RTN","RCRJRCOU",153,0)
;Switch dates if Begin Date is more recent than End Date
"RTN","RCRJRCOU",154,0)
S:DTFROM>DTTO OUT=1_U_DTTO_U_DTFROM
"RTN","RCRJRCOU",155,0)
Q OUT
"RTN","RCRJRCOU",156,0)
;
"RTN","RCRJRCOU",157,0)
HEXC ; - 'Do you want to capture data to EXCEL' prompt
"RTN","RCRJRCOU",158,0)
W !!," Enter: 'Y' - To capture detail report data to transfer"
"RTN","RCRJRCOU",159,0)
W !," to an Excel document"
"RTN","RCRJRCOU",160,0)
W !," '<CR>' - To skip this option"
"RTN","RCRJRCOU",161,0)
W !," '^' - To quit this option"
"RTN","RCRJRCOU",162,0)
Q
"RTN","RCRJRCOU",163,0)
FIRST ; Get 1st available date for selected status
"RTN","RCRJRCOU",164,0)
N RCBILL
"RTN","RCRJRCOU",165,0)
S STATUS=0,(RCBILL,BDT)="" F S STATUS=$O(VAUTC(STATUS)) Q:STATUS="" D
"RTN","RCRJRCOU",166,0)
. S RCBILL=0 F S RCBILL=$O(^PRCA(430,"AC",STATUS,RCBILL)) Q:'RCBILL D
"RTN","RCRJRCOU",167,0)
.. Q:$P($G(^PRCA(430,RCBILL,0)),U,10)=""
"RTN","RCRJRCOU",168,0)
.. S RCSTDT=$P($G(^PRCA(430,RCBILL,0)),U,10)
"RTN","RCRJRCOU",169,0)
.. I $G(BDT)="" S BDT=RCSTDT Q
"RTN","RCRJRCOU",170,0)
.. I RCSTDT<+BDT S BDT=RCSTDT_U_STATUS ;Use earliest available date
"RTN","RCRJRCOU",171,0)
;
"RTN","RCRJRCOU",172,0)
S BGDT=$S(BDT'="":$$FMTE^XLFDT(+BDT,"Z2"),1:"No records on file")
"RTN","RCRJRCOU",173,0)
Q
"RTN","RCRJRCOU",174,0)
MENU ; Selection menu
"RTN","RCRJRCOU",175,0)
;;
"RTN","RCRJRCOU",176,0)
;;
"RTN","RCRJRCOU",177,0)
;;ARDC Detail Report, please select the status desired below:
"RTN","RCRJRCOU",178,0)
;;
"RTN","RCRJRCOU",179,0)
;; AC - ACTIVE(16)
"RTN","RCRJRCOU",180,0)
;; N - NEW BILL(18)
"RTN","RCRJRCOU",181,0)
;; R - RETURNED FOR AMENDMENT(32)
"RTN","RCRJRCOU",182,0)
;; AM - AMENDED BILL(33)
"RTN","RCRJRCOU",183,0)
;; S - SUSPENDED(40)
"RTN","RCRJRCOU",184,0)
;; O - OPEN(42)
"RTN","RCRJRCOU",185,0)
;; ALL of the above (Default, press enter)
"RTN","RCRJRCOU",186,0)
;;
"RTN","RCRJRCOU",187,0)
Q
"RTN","RCRJRCOU",188,0)
DESCTEXT ;
"RTN","RCRJRCOU",189,0)
;; This report was originally generated from the monthly background
"RTN","RCRJRCOU",190,0)
;; process and generated a MailMan message. It can now only be run
"RTN","RCRJRCOU",191,0)
;; manually through this option. The new data does not contain bills
"RTN","RCRJRCOU",192,0)
;; that have been previously closed out. Note that when running the
"RTN","RCRJRCOU",193,0)
;; new report, only specific AR current status are available.
"RTN","RCRJRCOU",194,0)
;; There will be a note that displays the oldest bill in VistA
"RTN","RCRJRCOU",195,0)
;; associated with these statuses for users to know which date
"RTN","RCRJRCOU",196,0)
;; MUST be entered into the "FROM:" prompt for monthly
"RTN","RCRJRCOU",197,0)
;; reconciliation reporting.
"RTN","RCRJRCOU",198,0)
;; Different dates can be entered for other types of audits.
"RTN","RCRJRCOU",199,0)
;;
"RTN","RCRJRCOU",200,0)
;; Please run after hours when possible.
"RTN","RCRJRCOU",201,0)
;;
"RTN","RCRJRCOU",202,0)
Q
"RTN","RCRJRCOU",203,0)
;
"RTN","RCRJRCOU",204,0)
STORE(BILLDA,DATEBEG,DATEEND,ARACTDT,CATEGORY,TYPE,RCFUND,RCRSC,RCVALUE,SCREEN) ;
"RTN","RCRJRCOU",205,0)
;called by ^RCRJRCOC to store the bills in the AR DEBT COLLECTOR DATA (430.7) file.
"RTN","RCRJRCOU",206,0)
; BILLDA - IEN of 430
"RTN","RCRJRCOU",207,0)
; DATEBEG - Beginning date of accounting month
"RTN","RCRJRCOU",208,0)
; DATEEND - Ending date of accouting month
"RTN","RCRJRCOU",209,0)
; ARACTDT - Date account activitated
"RTN","RCRJRCOU",210,0)
; CATEGORY - Category of bill (pointer)
"RTN","RCRJRCOU",211,0)
; TYPE - FMS Document Type (include SV or whatever)
"RTN","RCRJRCOU",212,0)
; RCFUND - Fund
"RTN","RCRJRCOU",213,0)
; RCRSC - Revenue Source Code
"RTN","RCRJRCOU",214,0)
; RCVALUE - value of bill prin ^ int ^ admin ^ mf ^ cc
"RTN","RCRJRCOU",215,0)
; SCREEN - data from OIG routine needs to be screened
"RTN","RCRJRCOU",216,0)
;
"RTN","RCRJRCOU",217,0)
N RCREPORT,RCDR,RCZERO,RCLIST,DIE,DR,DA,X,Y,RCDA,RCSTAT
"RTN","RCRJRCOU",218,0)
;
"RTN","RCRJRCOU",219,0)
Q:'$G(DATEBEG)!('$G(DATEEND))!('$G(BILLDA))
"RTN","RCRJRCOU",220,0)
S RCSTAT=$P(^PRCA(430,BILLDA,0),"^",8)
"RTN","RCRJRCOU",221,0)
I $G(SCREEN) Q:RCSTAT'=16&(RCSTAT'=40) ; only active and suspended
"RTN","RCRJRCOU",222,0)
;
"RTN","RCRJRCOU",223,0)
; Add .01 top file level entry if it doesn't exist
"RTN","RCRJRCOU",224,0)
S RCREPORT=$O(^PRCA(430.7,"B",$E(DATEEND,1,5)_"00",0)) I 'RCREPORT D
"RTN","RCRJRCOU",225,0)
. N DO,DIC,X,Y,RCKEEP,RCPURGE
"RTN","RCRJRCOU",226,0)
. S DIC="^PRCA(430.7,",DIC(0)="",X=$E(DATEEND,1,5)_"00"
"RTN","RCRJRCOU",227,0)
. S DIC("DR")=.02_"////"_DATEBEG_";.03////"_DATEEND
"RTN","RCRJRCOU",228,0)
. D FILE^DICN
"RTN","RCRJRCOU",229,0)
. S RCREPORT=+Y
"RTN","RCRJRCOU",230,0)
. ; purge any reports more than 3 months old
"RTN","RCRJRCOU",231,0)
. S RCKEEP=$E($$FMADD^XLFDT(DATEEND,-65),1,5)_"00",RCPURGE=0
"RTN","RCRJRCOU",232,0)
. F S RCPURGE=$O(^PRCA(430.7,"B",RCPURGE)) Q:'RCPURGE!(RCPURGE'<RCKEEP) D
"RTN","RCRJRCOU",233,0)
.. N DIK,DA
"RTN","RCRJRCOU",234,0)
.. S DIK="^PRCA(430.7,",DA=$O(^PRCA(430.7,"B",RCPURGE,0))
"RTN","RCRJRCOU",235,0)
.. D ^DIK
"RTN","RCRJRCOU",236,0)
; update last date
"RTN","RCRJRCOU",237,0)
S DIE="^PRCA(430.7,",DA=RCREPORT,DR=".04////"_$$NOW^XLFDT D ^DIE
"RTN","RCRJRCOU",238,0)
;
"RTN","RCRJRCOU",239,0)
; determine data for the bill
"RTN","RCRJRCOU",240,0)
S RCDR(.02)=ARACTDT ; date bill activitated
"RTN","RCRJRCOU",241,0)
S RCDR(.03)=CATEGORY ; AR Cateogry
"RTN","RCRJRCOU",242,0)
S RCDR(.04)=RCSTAT ; AR Status
"RTN","RCRJRCOU",243,0)
S:TYPE'="" RCDR(.05)=TYPE ; fms type
"RTN","RCRJRCOU",244,0)
S RCDR(.06)=RCFUND ; Fund Type
"RTN","RCRJRCOU",245,0)
S RCDR(.07)=RCRSC ; Revenue Source Code
"RTN","RCRJRCOU",246,0)
S RCDR(.08)=+RCVALUE ; Principal Amount
"RTN","RCRJRCOU",247,0)
S RCDR(.09)=RCVALUE+$P(RCVALUE,"^",2)+$P(RCVALUE,"^",3)+$P(RCVALUE,"^",4)+$P(RCVALUE,"^",5) ; Current Balance
"RTN","RCRJRCOU",248,0)
;
"RTN","RCRJRCOU",249,0)
; Check for new or update entry
"RTN","RCRJRCOU",250,0)
S RCDA=$O(^PRCA(430.7,RCREPORT,1,"B",BILLDA,0))
"RTN","RCRJRCOU",251,0)
I 'RCDA D Q
"RTN","RCRJRCOU",252,0)
. ; add new entry
"RTN","RCRJRCOU",253,0)
. N DO,DIC,X,Y,DA
"RTN","RCRJRCOU",254,0)
. S DIC="^PRCA(430.7,"_RCREPORT_",1,",DIC(0)="",DA(1)=RCREPORT,X=BILLDA
"RTN","RCRJRCOU",255,0)
. S DIC("DR")="",X=0
"RTN","RCRJRCOU",256,0)
. F S X=$O(RCDR(X)) Q:'X S DIC("DR")=DIC("DR")_X_"////"_RCDR(X)_";"
"RTN","RCRJRCOU",257,0)
. S DIC("DR")=$E(DIC("DR"),1,$L(DIC("DR"))-1)
"RTN","RCRJRCOU",258,0)
. S X=BILLDA
"RTN","RCRJRCOU",259,0)
. D FILE^DICN
"RTN","RCRJRCOU",260,0)
;
"RTN","RCRJRCOU",261,0)
; update entry (if it already exited)
"RTN","RCRJRCOU",262,0)
S DIE="^PRCA(430.7,"_RCREPORT_",1,",DA=RCDA,DA(1)=RCREPORT
"RTN","RCRJRCOU",263,0)
S DR="",X=0
"RTN","RCRJRCOU",264,0)
F S X=$O(RCDR(X)) Q:'X S DR=DR_X_"////"_RCDR(X)_";"
"RTN","RCRJRCOU",265,0)
S DR=$E(DR,1,$L(DR)-1) D:'$G(SCREEN) ^DIE
"RTN","RCRJRCOU",266,0)
Q
"RTN","RCRJRCOU",267,0)
;
"RTN","RCRJRCOU",268,0)
EN ; option entry point to run the report
"RTN","RCRJRCOU",269,0)
N RCREPORT,EXCEL,RCPROMPT,X,Y,DTOUT,DUOUT,DIR,ZTDESC,ZTSAVE,ZTRTN,ZTSK
"RTN","RCRJRCOU",270,0)
;
"RTN","RCRJRCOU",271,0)
W !,"Select which accounting month/year for the ARDC Report"
"RTN","RCRJRCOU",272,0)
S DIC="^PRCA(430.7,",DIC(0)="AEMNQ" D ^DIC Q:Y<1
"RTN","RCRJRCOU",273,0)
S RCREPORT=+Y
"RTN","RCRJRCOU",274,0)
S EXCEL=0,RCPROMPT="CAPTURE Report data to an Excel Document?",DIR(0)="Y",DIR("?")="^D HEXC^RCRJRCOU"
"RTN","RCRJRCOU",275,0)
S EXCEL=$$SELECT^RCTCSJR(RCPROMPT,"NO") I "01"'[EXCEL Q
"RTN","RCRJRCOU",276,0)
I EXCEL=1 D EXCMSG^RCTCSJR ; Display Excel display message
"RTN","RCRJRCOU",277,0)
I 'EXCEL W !!,"This report requires 132 characters",!
"RTN","RCRJRCOU",278,0)
K IOP,IO("Q") S %ZIS="MQ",%ZIS("B")="" D ^%ZIS Q:POP
"RTN","RCRJRCOU",279,0)
I $D(IO("Q")) D Q
"RTN","RCRJRCOU",280,0)
.S ZTDESC="ARDC Detail Report",ZTRTN="DQQ^RCRJRCOU"
"RTN","RCRJRCOU",281,0)
.S (ZTSAVE("RC*"),ZTSAVE("EXCEL"))="",ZTSAVE("ZTREQ")="@"
"RTN","RCRJRCOU",282,0)
.D ^%ZTLOAD,HOME^%ZIS S QUIT=1
"RTN","RCRJRCOU",283,0)
;
"RTN","RCRJRCOU",284,0)
DQQ ; Print the report
"RTN","RCRJRCOU",285,0)
N XMNOW,PAGE,RCOUT,RCREC,RCSP
"RTN","RCRJRCOU",286,0)
S XMNOW=$$NOW^XLFDT ;Capture the date and time the report was started for the header
"RTN","RCRJRCOU",287,0)
S (RCOUT,PAGE)=0
"RTN","RCRJRCOU",288,0)
S RCREC=0 F S RCREC=$O(^PRCA(430.7,RCREPORT,1,RCREC)) Q:'RCREC!(RCOUT) D
"RTN","RCRJRCOU",289,0)
. N RCARRAY
"RTN","RCRJRCOU",290,0)
. I PAGE<1 D HDR
"RTN","RCRJRCOU",291,0)
. I 'EXCEL,$Y+3>IOSL I ($E(IOST,1,2)="C-")&(IO=IO(0)) S DIR(0)="E" D ^DIR K DIR D
"RTN","RCRJRCOU",292,0)
.. I $D(DTOUT)!($D(DUOUT)) S RCOUT=1 G EXIT
"RTN","RCRJRCOU",293,0)
.. D HDR
"RTN","RCRJRCOU",294,0)
. Q:RCOUT
"RTN","RCRJRCOU",295,0)
. ; extract data from file in external form
"RTN","RCRJRCOU",296,0)
. D GETS^DIQ(430.71,RCREC_","_RCREPORT_",","*","","RCARRAY")
"RTN","RCRJRCOU",297,0)
. S RCSP="0^14^26^50^68^75^84^92^104"
"RTN","RCRJRCOU",298,0)
. W ! F X=.01:.01:.09 D
"RTN","RCRJRCOU",299,0)
.. W:'EXCEL @("?"_$P(RCSP,"^",X*100))
"RTN","RCRJRCOU",300,0)
.. S Y=$S(X=.03:20,X=.04:15,1:999)
"RTN","RCRJRCOU",301,0)
.. W $E($G(RCARRAY(430.71,RCREC_","_RCREPORT_",",X)),1,Y)
"RTN","RCRJRCOU",302,0)
.. I EXCEL,X'=.09 W "^"
"RTN","RCRJRCOU",303,0)
;
"RTN","RCRJRCOU",304,0)
Q
"RTN","RCRJRCOU",305,0)
;
"RTN","RCRJRDEP")
0^5^B67133793
"RTN","RCRJRDEP",1,0)
RCRJRDEP ;WISC/RFJ-Deposit Reconciliation Report ;9/7/10 8:19am
"RTN","RCRJRDEP",2,0)
;;4.5;Accounts Receivable;**101,114,203,220,273,310,338**;Mar 20, 1995;Build 70
"RTN","RCRJRDEP",3,0)
;Per VA Directive 6402, this routine should not be modified.
"RTN","RCRJRDEP",4,0)
;
"RTN","RCRJRDEP",5,0)
W !!,"This option will print the Deposit Reconciliation Report. The report will"
"RTN","RCRJRDEP",6,0)
W !,"display the data on the code sheets sent to FMS on the CR document. Only"
"RTN","RCRJRDEP",7,0)
W !,"deposits processed after patch PRCA*4.5*90 was installed can be displayed."
"RTN","RCRJRDEP",8,0)
W !,"Select the starting and ending FMS Document Number without the station"
"RTN","RCRJRDEP",9,0)
W !,"number, example: K8A0346."
"RTN","RCRJRDEP",10,0)
;
"RTN","RCRJRDEP",11,0)
N DEFAULT,RCRJEND,RCRJFXIT,RCRJSTRT,RCRJSUMM,X
"RTN","RCRJRDEP",12,0)
N %,%H,%I,CATEGORY,CHAMPVA,DA,DEPOSDA,DOCTOTAL,FEE,FMSDOCID,FUND,FUNDTOTL,GECSDATA,IO,IOF
"RTN","RCRJRDEP",13,0)
;
"RTN","RCRJRDEP",14,0)
F D Q:$G(RCRJFXIT)
"RTN","RCRJRDEP",15,0)
. R !!,"START WITH CR DOCUMENT: FIRST// ",X:DTIME
"RTN","RCRJRDEP",16,0)
. I X["^" S RCRJFXIT=2 Q
"RTN","RCRJRDEP",17,0)
. I $L(X),$L(X)'=7 W !?5,"The CR DOCUMENT should be 7 characters in length (example: K8A0804)." Q
"RTN","RCRJRDEP",18,0)
. S RCRJSTRT=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
"RTN","RCRJRDEP",19,0)
. ;
"RTN","RCRJRDEP",20,0)
. S DEFAULT=$S(RCRJSTRT="":" LAST",1:RCRJSTRT)
"RTN","RCRJRDEP",21,0)
. W !," END WITH CR DOCUMENT: ",DEFAULT,"// " R X:DTIME
"RTN","RCRJRDEP",22,0)
. I X["^" S RCRJFXIT=2 Q
"RTN","RCRJRDEP",23,0)
. S RCRJEND=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
"RTN","RCRJRDEP",24,0)
. I X="LAST" S (RCRJEND,X)="zzzzzzz"
"RTN","RCRJRDEP",25,0)
. I $L(X),$L(X)'=7 W !?5,"The CR DOCUMENT should be 7 characters in length (example: K8A0804)." Q
"RTN","RCRJRDEP",26,0)
. I X="" S RCRJEND=$S(DEFAULT=" LAST":"zzzzzzz",1:DEFAULT)
"RTN","RCRJRDEP",27,0)
. I RCRJEND'=RCRJSTRT,RCRJEND']RCRJSTRT W !?5,"The END CR DOCUMENT should be after (in sequence) the start document." Q
"RTN","RCRJRDEP",28,0)
. S RCRJFXIT=1
"RTN","RCRJRDEP",29,0)
I RCRJFXIT=2 Q
"RTN","RCRJRDEP",30,0)
;
"RTN","RCRJRDEP",31,0)
S RCRJSUMM=$$SUMMARY^RCRJRTRA I 'RCRJSUMM Q
"RTN","RCRJRDEP",32,0)
;
"RTN","RCRJRDEP",33,0)
; select device
"RTN","RCRJRDEP",34,0)
W ! S %ZIS="Q" D ^%ZIS Q:POP
"RTN","RCRJRDEP",35,0)
I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
"RTN","RCRJRDEP",36,0)
. S ZTDESC="Deposit Reconciliation Report",ZTRTN="DQ^RCRJRDEP"
"RTN","RCRJRDEP",37,0)
. S ZTSAVE("RCRJ*")="",ZTSAVE("ZTREQ")="@"
"RTN","RCRJRDEP",38,0)
W !!,"<*> please wait <*>"
"RTN","RCRJRDEP",39,0)
;
"RTN","RCRJRDEP",40,0)
DQ ; report (queue) starts here
"RTN","RCRJRDEP",41,0)
N %,%H,%I,CHAMPVA,DA,DEPOSDA,DIQ2,DOCTOTAL,FEE,FMSDOCID,FUND,FUNDTOTL,GECSDATA,LINEDA,LINEDATA,NOW,PAGE,RCDATA,RCRJLAST,RCRJLINE,RCRJFLAG,RECEIPDA,RSC,RSCTOTL,SCREEN,SITE,TOTAL,X,Y
"RTN","RCRJRDEP",42,0)
K ^TMP($J,"RCRJRDEP")
"RTN","RCRJRDEP",43,0)
;
"RTN","RCRJRDEP",44,0)
; build list of fms documents
"RTN","RCRJRDEP",45,0)
S SITE=$$SITE^RCMSITE
"RTN","RCRJRDEP",46,0)
S RCRJLAST="CR-"_SITE_RCRJEND_" "
"RTN","RCRJRDEP",47,0)
;
"RTN","RCRJRDEP",48,0)
; the fms document was previously stored in the deposit file 344.1
"RTN","RCRJRDEP",49,0)
; this code can be removed later on
"RTN","RCRJRDEP",50,0)
; this is the starting document, use 31 to start with select doc first
"RTN","RCRJRDEP",51,0)
S FMSDOCID="CR-"_SITE_RCRJSTRT_$C(31)
"RTN","RCRJRDEP",52,0)
F S FMSDOCID=$O(^RCY(344.1,"ADOC",FMSDOCID)) Q:FMSDOCID=""!(FMSDOCID]RCRJLAST) D
"RTN","RCRJRDEP",53,0)
. S DEPOSDA=+$O(^RCY(344.1,"ADOC",FMSDOCID,0))
"RTN","RCRJRDEP",54,0)
. ; compute deposit (all receipts) total for comparison
"RTN","RCRJRDEP",55,0)
. S TOTAL=0,CHAMPVA=0,FEE=0
"RTN","RCRJRDEP",56,0)
. S RECEIPDA=0 F S RECEIPDA=$O(^RCY(344,"AD",DEPOSDA,RECEIPDA)) Q:'RECEIPDA D
"RTN","RCRJRDEP",57,0)
. . S DA=0 F S DA=$O(^RCY(344,RECEIPDA,1,DA)) Q:'DA S TOTAL=TOTAL+$P(^(DA,0),"^",5)
"RTN","RCRJRDEP",58,0)
. . S CHAMPVA=CHAMPVA+$$CHAMPVA(RECEIPDA)
"RTN","RCRJRDEP",59,0)
. . S FEE=FEE+$$FEE(RECEIPDA)
"RTN","RCRJRDEP",60,0)
. ; tmp=deposit ^ depositda ^ depositdate ^ ^ ^ ^ deposittotal ^ champvatotal ^ feetotal
"RTN","RCRJRDEP",61,0)
. S ^TMP($J,"RCRJRDEP",FMSDOCID)=$P($G(^RCY(344.1,DEPOSDA,0)),"^")_"^"_DEPOSDA_"^"_$P($G(^RCY(344.1,DEPOSDA,0)),"^",9)_"^^^^"_TOTAL_"^"_CHAMPVA_"^"_FEE
"RTN","RCRJRDEP",62,0)
;
"RTN","RCRJRDEP",63,0)
; the fms document is now stored in the receipt file 344
"RTN","RCRJRDEP",64,0)
S FMSDOCID="CR-"_SITE_RCRJSTRT_$C(31)
"RTN","RCRJRDEP",65,0)
F S FMSDOCID=$O(^RCY(344,"ADOC",FMSDOCID)) Q:FMSDOCID=""!(FMSDOCID]RCRJLAST) D
"RTN","RCRJRDEP",66,0)
. S RECEIPDA=+$O(^RCY(344,"ADOC",FMSDOCID,0))
"RTN","RCRJRDEP",67,0)
. ; compute deposit (all receipts) total for comparison
"RTN","RCRJRDEP",68,0)
. S TOTAL=0
"RTN","RCRJRDEP",69,0)
. ; use the payment amount to pick up suspense deposits
"RTN","RCRJRDEP",70,0)
. S DA=0 F S DA=$O(^RCY(344,RECEIPDA,1,DA)) Q:'DA S TOTAL=TOTAL+$P(^(DA,0),"^",4)
"RTN","RCRJRDEP",71,0)
. S CHAMPVA=$$CHAMPVA(RECEIPDA)
"RTN","RCRJRDEP",72,0)
. S FEE=$$FEE(RECEIPDA)
"RTN","RCRJRDEP",73,0)
. S DEPOSDA=+$P($G(^RCY(344,RECEIPDA,0)),"^",6)
"RTN","RCRJRDEP",74,0)
. ; tmp=deposit ^ depositda ^ depositdate ^ receipt ^receiptda ^ receipt date ^ receipttotal ^ champvatotal ^ feetotal
"RTN","RCRJRDEP",75,0)
. S ^TMP($J,"RCRJRDEP",FMSDOCID)=$P($G(^RCY(344.1,DEPOSDA,0)),"^")_"^"_DEPOSDA_"^"_$P($G(^RCY(344.1,DEPOSDA,0)),"^",11)_"^"_$P($G(^RCY(344,RECEIPDA,0)),"^")_"^"_RECEIPDA_"^"_$P($G(^RCY(344,RECEIPDA,0)),"^",8)_"^"_TOTAL_"^"_CHAMPVA_"^"_FEE
"RTN","RCRJRDEP",76,0)
;
"RTN","RCRJRDEP",77,0)
; print report
"RTN","RCRJRDEP",78,0)
S SCREEN=0 I '$D(ZTQUEUED),IO=IO(0),$E(IOST)="C" S SCREEN=1
"RTN","RCRJRDEP",79,0)
S RCRJLINE="",$P(RCRJLINE,"-",81)=""
"RTN","RCRJRDEP",80,0)
D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=1
"RTN","RCRJRDEP",81,0)
U IO I $G(RCRJSUMM)'=1 D H
"RTN","RCRJRDEP",82,0)
;
"RTN","RCRJRDEP",83,0)
S FMSDOCID="" F S FMSDOCID=$O(^TMP($J,"RCRJRDEP",FMSDOCID)) Q:FMSDOCID=""!($G(RCRJFLAG)) D
"RTN","RCRJRDEP",84,0)
. S RCDATA=^TMP($J,"RCRJRDEP",FMSDOCID)
"RTN","RCRJRDEP",85,0)
. K GECSDATA
"RTN","RCRJRDEP",86,0)
. D DATA^GECSSGET(FMSDOCID,1)
"RTN","RCRJRDEP",87,0)
. I $G(RCRJSUMM)'=1 D Q:$G(RCRJFLAG)
"RTN","RCRJRDEP",88,0)
. . I $Y>(IOSL-7) D:SCREEN PAUSE^RCRJRTR1 Q:$G(RCRJFLAG) D H
"RTN","RCRJRDEP",89,0)
. . S Y=$P($P(RCDATA,"^",3),".") I Y D DD^%DT
"RTN","RCRJRDEP",90,0)
. . W !,"FMS DOCUMENT: ",FMSDOCID,?34,"DEPOSIT TICKET: ",$P(RCDATA,"^"),?62,"DATE: ",Y
"RTN","RCRJRDEP",91,0)
. . I $P(RCDATA,"^",4)'="" W !?41,"RECEIPT: ",$P(RCDATA,"^",4) S Y=$P($P(RCDATA,"^",6),".") I Y D DD^%DT W ?62,"DATE: ",Y
"RTN","RCRJRDEP",92,0)
. . D H1
"RTN","RCRJRDEP",93,0)
. S DOCTOTAL=0
"RTN","RCRJRDEP",94,0)
. I $D(GECSDATA) S LINEDA=0 F S LINEDA=$O(GECSDATA(2100.1,GECSDATA,10,LINEDA)) Q:'LINEDA!($G(RCRJFLAG)) D
"RTN","RCRJRDEP",95,0)
. . S LINEDATA=GECSDATA(2100.1,GECSDATA,10,LINEDA)
"RTN","RCRJRDEP",96,0)
. . I $E(LINEDATA,1,4)="CR2^" S DOCTOTAL=$P(LINEDATA,"^",15)
"RTN","RCRJRDEP",97,0)
. . I $E(LINEDATA,1,9)'="LIN^~CRA^" Q
"RTN","RCRJRDEP",98,0)
. . I $G(RCRJSUMM)'=1 D
"RTN","RCRJRDEP",99,0)
. . . I $Y>(IOSL-4) D:SCREEN PAUSE^RCRJRTR1 Q:$G(RCRJFLAG) D H,H1
"RTN","RCRJRDEP",100,0)
. . . W !?1,$P(LINEDATA,"^",3),?6,$P(LINEDATA,"^",4),?11,$P(LINEDATA,"^",6),?19,$P(LINEDATA,"^",10)
"RTN","RCRJRDEP",101,0)
. . . W ?30,$J($P(LINEDATA,"^",18),8),?40,$E($P(LINEDATA,"^",25),4,10),?50,$J($P(LINEDATA,"^",20),10,2),?64,$J($P(LINEDATA,"^",23),9)
"RTN","RCRJRDEP",102,0)
. . ; totals by fund
"RTN","RCRJRDEP",103,0)
. . S FUND=$P(LINEDATA,"^",6)
"RTN","RCRJRDEP",104,0)
. . I FUND="" S FUND="0160"
"RTN","RCRJRDEP",105,0)
. . S FUNDTOTL(FUND)=$G(FUNDTOTL(FUND))+$P(LINEDATA,"^",20)
"RTN","RCRJRDEP",106,0)
. . ; totals by rsc for the accrued 5287 funds (01,03,04,09,11)
"RTN","RCRJRDEP",107,0)
. . S RSC=$P(LINEDATA,"^",10)
"RTN","RCRJRDEP",108,0)
. . I RSC'="",($$PTACCT^PRCAACC(FUND)!(FUND=4032)) S RSCTOTL(RSC)=$G(RSCTOTL(RSC))+$P(LINEDATA,"^",20)
"RTN","RCRJRDEP",109,0)
. I $G(RCRJSUMM)=1 Q
"RTN","RCRJRDEP",110,0)
. I $G(RCRJFLAG) Q
"RTN","RCRJRDEP",111,0)
. I $Y>(IOSL-6) D:SCREEN PAUSE^RCRJRTR1 Q:$G(RCRJFLAG) D H
"RTN","RCRJRDEP",112,0)
. W !?23,"LINE TOTAL/DOCUMENT TOTAL: ",$J(DOCTOTAL,10,2)
"RTN","RCRJRDEP",113,0)
. ; compute receipt total for comparison
"RTN","RCRJRDEP",114,0)
. S TOTAL=$P(RCDATA,"^",7)
"RTN","RCRJRDEP",115,0)
. S CHAMPVA=$P(RCDATA,"^",8)
"RTN","RCRJRDEP",116,0)
. S FEE=$P(RCDATA,"^",9)
"RTN","RCRJRDEP",117,0)
. I CHAMPVA W !?35,"CHAMPVA TOTAL: ",$J(CHAMPVA,10,2)
"RTN","RCRJRDEP",118,0)
. I FEE W !?35,"NON-VA TOTAL: ",$J(FEE,10,2)
"RTN","RCRJRDEP",119,0)
. W !?35,"DEPOSIT TOTAL: ",$J(TOTAL,10,2)
"RTN","RCRJRDEP",120,0)
. I (DOCTOTAL+CHAMPVA+FEE)'=TOTAL W !," WARNING: TOTALS DO NOT MATCH, CHECK THE DEPOSIT: **********"
"RTN","RCRJRDEP",121,0)
. W !
"RTN","RCRJRDEP",122,0)
;
"RTN","RCRJRDEP",123,0)
I $G(RCRJFLAG) D Q Q
"RTN","RCRJRDEP",124,0)
I $G(RCRJSUMM)'=1 D:SCREEN PAUSE^RCRJRTR1 I $G(RCRJFLAG) D Q Q
"RTN","RCRJRDEP",125,0)
D H
"RTN","RCRJRDEP",126,0)
; print totals by fund/rsc
"RTN","RCRJRDEP",127,0)
W !!,"TOTAL DEPOSITS BY FUND:"
"RTN","RCRJRDEP",128,0)
S FUND="" F S FUND=$O(FUNDTOTL(FUND)) Q:FUND=""!($G(RCRJFLAG)) D
"RTN","RCRJRDEP",129,0)
. I $Y>(IOSL-4) D:SCREEN PAUSE^RCRJRTR1 Q:$G(RCRJFLAG) D H W !!,"TOTAL DEPOSITS BY FUND:"
"RTN","RCRJRDEP",130,0)
. W !?5,"FUND: ",FUND,?20,$J(FUNDTOTL(FUND),10,2)
"RTN","RCRJRDEP",131,0)
I $G(RCRJFLAG) D Q Q
"RTN","RCRJRDEP",132,0)
I DT<$$ADDPTEDT^PRCAACC() W !!,"TOTAL DEPOSITS BY REVENUE SOURCE CODE FOR THE SERIES OF FUNDS 5287.1,5287.3,5287.4:"
"RTN","RCRJRDEP",133,0)
I DT'<$$ADDPTEDT^PRCAACC() W !!,"TOTAL DEPOSITS BY REVENUE SOURCE CODE FOR THE SERIES OF FUNDS 528701,528703,528704,528711,528713,528714:"
"RTN","RCRJRDEP",134,0)
S RSC="" F S RSC=$O(RSCTOTL(RSC)) Q:RSC="" D Q:$G(RCRJFLAG)
"RTN","RCRJRDEP",135,0)
. I $Y>(IOSL-4) D:SCREEN PAUSE^RCRJRTR1 Q:$G(RCRJFLAG) D H W !!,"TOTAL DEPOSITS BY REVENUE SOURCE CODE FOR THE SERIES OF ACCRUED 5287 FUNDS "_$S(DT<$$ADDPTEDT^PRCAACC():"(.1,.3,.4,.9):",1:"(01,03,04,09,11):")
"RTN","RCRJRDEP",136,0)
. W !?5,"RSC: ",RSC,?17,$$GETDESC^RCXFMSPR(RSC),?70,$J(RSCTOTL(RSC),10,2)
"RTN","RCRJRDEP",137,0)
I $G(RCRJFLAG) D Q Q
"RTN","RCRJRDEP",138,0)
I SCREEN R !,"Press RETURN to continue:",X:DTIME
"RTN","RCRJRDEP",139,0)
;
"RTN","RCRJRDEP",140,0)
Q D ^%ZISC
"RTN","RCRJRDEP",141,0)
K ^TMP($J,"RCRJRDEP")
"RTN","RCRJRDEP",142,0)
Q
"RTN","RCRJRDEP",143,0)
;
"RTN","RCRJRDEP",144,0)
;
"RTN","RCRJRDEP",145,0)
H ; report heading
"RTN","RCRJRDEP",146,0)
I PAGE'=1!(SCREEN) W @IOF
"RTN","RCRJRDEP",147,0)
S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1
"RTN","RCRJRDEP",148,0)
W $C(13),"DEPOSIT RECONCILIATION REPORT",?(80-$L(%)),%
"RTN","RCRJRDEP",149,0)
W !," START WITH DEPOSIT: ",$S(RCRJSTRT="":"**FIRST**",1:RCRJSTRT)," END WITH DEPOSIT: ",$S(RCRJEND="zzzzzzz":"**LAST**",1:RCRJEND),?65,$J("TYPE: "_$S(RCRJSUMM=1:"SUMMARY",1:"DETAILED"),15)
"RTN","RCRJRDEP",150,0)
W !,RCRJLINE
"RTN","RCRJRDEP",151,0)
Q
"RTN","RCRJRDEP",152,0)
;
"RTN","RCRJRDEP",153,0)
;
"RTN","RCRJRDEP",154,0)
H1 ; print line heading
"RTN","RCRJRDEP",155,0)
W !,"LINE",?5,"BFY",?11,"FUND",?20,"RSC",?30,"PROVIDER",?43,"BILL",?54,"AMOUNT",?64,"TRAN TYPE"
"RTN","RCRJRDEP",156,0)
Q
"RTN","RCRJRDEP",157,0)
;
"RTN","RCRJRDEP",158,0)
;
"RTN","RCRJRDEP",159,0)
CHAMPVA(RECEIPDA) ; return dollars for champva
"RTN","RCRJRDEP",160,0)
N %,CATEGORY,RECEIPT,TOTAL,TRAN3,TRANDA
"RTN","RCRJRDEP",161,0)
S RECEIPT=$P($G(^RCY(344,RECEIPDA,0)),"^")
"RTN","RCRJRDEP",162,0)
I RECEIPT="" Q 0
"RTN","RCRJRDEP",163,0)
;
"RTN","RCRJRDEP",164,0)
S TOTAL=0
"RTN","RCRJRDEP",165,0)
S TRANDA=0 F S TRANDA=$O(^PRCA(433,"AF",RECEIPT,TRANDA)) Q:'TRANDA D
"RTN","RCRJRDEP",166,0)
. S CATEGORY=$P($G(^PRCA(430,+$P($G(^PRCA(433,TRANDA,0)),"^",2),0)),"^",2)
"RTN","RCRJRDEP",167,0)
. I CATEGORY'=29 Q
"RTN","RCRJRDEP",168,0)
. S TRAN3=$G(^PRCA(433,TRANDA,3))
"RTN","RCRJRDEP",169,0)
. F %=1:1:5 S TOTAL=TOTAL+$P(TRAN3,"^",%)
"RTN","RCRJRDEP",170,0)
Q TOTAL
"RTN","RCRJRDEP",171,0)
;
"RTN","RCRJRDEP",172,0)
;
"RTN","RCRJRDEP",173,0)
FEE(RECEIPDA) ; return dollars for Fee Basis PRCA*4.5*310/DRF 12/9/2015
"RTN","RCRJRDEP",174,0)
N %,CATEGORY,RECEIPT,TOTAL,TRAN3,TRANDA
"RTN","RCRJRDEP",175,0)
S RECEIPT=$P($G(^RCY(344,RECEIPDA,0)),"^")
"RTN","RCRJRDEP",176,0)
I RECEIPT="" Q 0
"RTN","RCRJRDEP",177,0)
S TOTAL=0
"RTN","RCRJRDEP",178,0)
S TRANDA=0 F S TRANDA=$O(^PRCA(433,"AF",RECEIPT,TRANDA)) Q:'TRANDA D
"RTN","RCRJRDEP",179,0)
. S CATEGORY=$P($G(^PRCA(430,+$P($G(^PRCA(433,TRANDA,0)),"^",2),0)),"^",2)
"RTN","RCRJRDEP",180,0)
. I '$$CHKIEN(CATEGORY) Q ; verify category for 1st and 3rd party(PRCA*4.5*338)
"RTN","RCRJRDEP",181,0)
. S TRAN3=$G(^PRCA(433,TRANDA,3))
"RTN","RCRJRDEP",182,0)
. F %=1:1:5 S TOTAL=TOTAL+$P(TRAN3,"^",%)
"RTN","RCRJRDEP",183,0)
Q TOTAL
"RTN","RCRJRDEP",184,0)
;
"RTN","RCRJRDEP",185,0)
CHKIEN(RCCAT) ; return true if AR CATEGORIES are 1ST and 3RD party (PRCA*4.5*338)
"RTN","RCRJRDEP",186,0)
I RCCAT=45 Q 1
"RTN","RCRJRDEP",187,0)
I RCCAT>47&(RCCAT<76) Q 1
"RTN","RCRJRDEP",188,0)
Q 0
"RTN","RCRJROIG")
0^20^B29874403
"RTN","RCRJROIG",1,0)
RCRJROIG ;WISC/RFJ-send data for oig extract ;1 Jul 99
"RTN","RCRJROIG",2,0)
;;4.5;Accounts Receivable;**103,174,203,205,220,270,335,338**;Mar 20, 1995;Build 70
"RTN","RCRJROIG",3,0)
;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","RCRJROIG",4,0)
Q
"RTN","RCRJROIG",5,0)
;
"RTN","RCRJROIG",6,0)
;
"RTN","RCRJROIG",7,0)
NONMCCF(DATEEND) ; build the non-mccf bills for user report and submission to oig
"RTN","RCRJROIG",8,0)
N BILLDA,DATE,DATA7,OTHER,PRINCPAL
"RTN","RCRJROIG",9,0)
S BILLDA=0 F S BILLDA=$O(^PRCA(430,BILLDA)) Q:'BILLDA D
"RTN","RCRJROIG",10,0)
. N RCFUND,RCRSC
"RTN","RCRJROIG",11,0)
. ; if already stored, then it is a current receivable
"RTN","RCRJROIG",12,0)
. I $D(^TMP($J,"RCRJROIG",BILLDA)) Q
"RTN","RCRJROIG",13,0)
. ; calculate principal and other (int + admin) balance
"RTN","RCRJROIG",14,0)
. S DATA7=$G(^PRCA(430,BILLDA,7))
"RTN","RCRJROIG",15,0)
. S PRINCPAL=+$P(DATA7,"^")
"RTN","RCRJROIG",16,0)
. S OTHER=$P(DATA7,"^",2)+$P(DATA7,"^",3)+$P(DATA7,"^",4)+$P(DATA7,"^",5)
"RTN","RCRJROIG",17,0)
. ; in some bills, the principal and other balance may cancel
"RTN","RCRJROIG",18,0)
. ; each other. for example principal .08 + interest -.08 = 0
"RTN","RCRJROIG",19,0)
. I (PRINCPAL+OTHER)'>0 Q
"RTN","RCRJROIG",20,0)
. ; store the data for submission to oig
"RTN","RCRJROIG",21,0)
. S ^TMP($J,"RCRJROIG",BILLDA)=PRINCPAL_"^"_OTHER
"RTN","RCRJROIG",22,0)
. ; store the data for the user report (only if bill activated)
"RTN","RCRJROIG",23,0)
. S DATE=+$P($P($G(^PRCA(430,BILLDA,6)),"^",21),".") I 'DATE Q
"RTN","RCRJROIG",24,0)
. S ^TMP($J,"RCRJRCOLREPORT",DATE,BILLDA)=PRINCPAL_"^"_OTHER
"RTN","RCRJROIG",25,0)
. S RCFUND=$$GET1^DIQ(430,BILLDA_",",203)
"RTN","RCRJROIG",26,0)
. I RCFUND="" S RCFUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
"RTN","RCRJROIG",27,0)
. S RCRSC=$$GETRSC(BILLDA,RCFUND)
"RTN","RCRJROIG",28,0)
. D STORE^RCRJRCOU(BILLDA,DATEBEG,DATEEND,DATE,$P(^PRCA(430,BILLDA,0),"^",2),"",RCFUND,RCRSC,$P(DATA7,"^",1,5),1)
"RTN","RCRJROIG",29,0)
Q
"RTN","RCRJROIG",30,0)
;
"RTN","RCRJROIG",31,0)
;
"RTN","RCRJROIG",32,0)
OIG(DATEEND) ; send data to the OIG
"RTN","RCRJROIG",33,0)
N BILLDA,COUNT,DATA,DATA0,FUND,FYQ,OIGDATA,SEQUENCE,SITE,TOTALAMT
"RTN","RCRJROIG",34,0)
N TOTALCNT,TOTALMSG,X,X1
"RTN","RCRJROIG",35,0)
;
"RTN","RCRJROIG",36,0)
; get previous fiscal year quarter for mail message header
"RTN","RCRJROIG",37,0)
S FYQ=$E(DATEEND,4,5),FYQ=$S(FYQ<4:1,FYQ<7:2,FYQ<10:3,1:4)
"RTN","RCRJROIG",38,0)
S SITE=$$SITE^RCMSITE()
"RTN","RCRJROIG",39,0)
;
"RTN","RCRJROIG",40,0)
; calculate the number of messages to be sent
"RTN","RCRJROIG",41,0)
S (X,X1)=0 F S X=$O(^TMP($J,"RCRJROIG",X)) Q:'X S X1=X1+1
"RTN","RCRJROIG",42,0)
S TOTALMSG=X1\272 I X1#272 S TOTALMSG=TOTALMSG+1
"RTN","RCRJROIG",43,0)
;
"RTN","RCRJROIG",44,0)
; build the extract for oig
"RTN","RCRJROIG",45,0)
S COUNT=0 ; used to count bills to be sent in a single mail msg
"RTN","RCRJROIG",46,0)
S SEQUENCE=0 ; used to count mail messages sent (in mail subject)
"RTN","RCRJROIG",47,0)
S TOTALCNT=0 ; used to count total bills sent all mail messages
"RTN","RCRJROIG",48,0)
S TOTALAMT=0 ; used to calculate total dollars all mail messages
"RTN","RCRJROIG",49,0)
K ^TMP($J,"RCRJROIGMM")
"RTN","RCRJROIG",50,0)
S BILLDA=0 F S BILLDA=$O(^TMP($J,"RCRJROIG",BILLDA)) Q:'BILLDA D
"RTN","RCRJROIG",51,0)
. S DATA=^TMP($J,"RCRJROIG",BILLDA)
"RTN","RCRJROIG",52,0)
. S DATA0=^PRCA(430,BILLDA,0)
"RTN","RCRJROIG",53,0)
. ; bill number, position 1-11
"RTN","RCRJROIG",54,0)
. S OIGDATA=$E($$LJ^XLFSTR($P(DATA0,"^"),11),1,11) ; WCJ;PRCA*4.5*270
"RTN","RCRJROIG",55,0)
. ; category, position 12-36
"RTN","RCRJROIG",56,0)
. S OIGDATA=OIGDATA_$$LJ^XLFSTR($E($P($G(^PRCA(430.2,+$P(DATA0,"^",2),0)),"^"),1,25),25)
"RTN","RCRJROIG",57,0)
. ; status, position 37-56
"RTN","RCRJROIG",58,0)
. S OIGDATA=OIGDATA_$$LJ^XLFSTR($E($P($G(^PRCA(430.3,+$P(DATA0,"^",8),0)),"^"),1,20),20)
"RTN","RCRJROIG",59,0)
. ; principal balance, position 57-65 (example 000000110 for 1.10)
"RTN","RCRJROIG",60,0)
. S OIGDATA=OIGDATA_$TR($J($P(DATA,"^"),10,2)," .","0")
"RTN","RCRJROIG",61,0)
. ; date status last updated, position 66-76 (example APR 08,1999)
"RTN","RCRJROIG",62,0)
. S OIGDATA=OIGDATA_$$DATE($P(DATA0,"^",14))
"RTN","RCRJROIG",63,0)
. ; fms fund, position 77-82
"RTN","RCRJROIG",64,0)
. S FUND=$$GET1^DIQ(430,BILLDA_",",203)
"RTN","RCRJROIG",65,0)
. I FUND="" S FUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
"RTN","RCRJROIG",66,0)
. ;S FUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
"RTN","RCRJROIG",67,0)
. S FUND=$$ADJFUND^RCRJRCO(FUND) ; may delete this line after 10/1/03
"RTN","RCRJROIG",68,0)
. S OIGDATA=OIGDATA_$J(FUND,6)
"RTN","RCRJROIG",69,0)
. ; revenue source code, position 83-86
"RTN","RCRJROIG",70,0)
. S OIGDATA=OIGDATA_$J($$GETRSC(BILLDA,FUND),4)
"RTN","RCRJROIG",71,0)
. ; general ledger account number, position 87-90
"RTN","RCRJROIG",72,0)
. S OIGDATA=OIGDATA_$J($P(DATA,"^",3),4)
"RTN","RCRJROIG",73,0)
. ; date bill entered, position 91-101 (example APR 08,1999)
"RTN","RCRJROIG",74,0)
. S OIGDATA=OIGDATA_$$DATE($P(DATA0,"^",10))
"RTN","RCRJROIG",75,0)
. ; interest + admin balance, position 102-110
"RTN","RCRJROIG",76,0)
. S OIGDATA=OIGDATA_$TR($J($P(DATA,"^",2),10,2)," .","0")_"$"
"RTN","RCRJROIG",77,0)
. ;
"RTN","RCRJROIG",78,0)
. ; total count and dollars for bills sent
"RTN","RCRJROIG",79,0)
. S TOTALCNT=TOTALCNT+1
"RTN","RCRJROIG",80,0)
. S TOTALAMT=TOTALAMT+$P(DATA,"^")
"RTN","RCRJROIG",81,0)
. ;
"RTN","RCRJROIG",82,0)
. ; store data for transmission
"RTN","RCRJROIG",83,0)
. S COUNT=COUNT+1
"RTN","RCRJROIG",84,0)
. S ^TMP($J,"RCRJROIGMM",COUNT)=OIGDATA
"RTN","RCRJROIG",85,0)
. ; only send message with 272 bills
"RTN","RCRJROIG",86,0)
. I COUNT'=272 Q
"RTN","RCRJROIG",87,0)
. ; if there are no more bills, do not send message until the
"RTN","RCRJROIG",88,0)
. ; totals are placed at the end
"RTN","RCRJROIG",89,0)
. I '$O(^TMP($J,"RCRJROIG",BILLDA)) Q
"RTN","RCRJROIG",90,0)
. ;
"RTN","RCRJROIG",91,0)
. ; send current code sheets
"RTN","RCRJROIG",92,0)
. S SEQUENCE=SEQUENCE+1
"RTN","RCRJROIG",93,0)
. D MAILIT(SITE,FYQ,SEQUENCE)
"RTN","RCRJROIG",94,0)
. S COUNT=0
"RTN","RCRJROIG",95,0)
. K ^TMP($J,"RCRJROIGMM")
"RTN","RCRJROIG",96,0)
;
"RTN","RCRJROIG",97,0)
; mail last message with totals at the end
"RTN","RCRJROIG",98,0)
S COUNT=COUNT+1
"RTN","RCRJROIG",99,0)
S ^TMP($J,"RCRJROIGMM",COUNT)="END OF TRANSMISSION FOR SITE# "_SITE_": TOTAL RECORDS: "_TOTALCNT_" TOTAL AMOUNT: "_TOTALAMT
"RTN","RCRJROIG",100,0)
S SEQUENCE=SEQUENCE+1
"RTN","RCRJROIG",101,0)
D MAILIT(SITE,FYQ,SEQUENCE)
"RTN","RCRJROIG",102,0)
;
"RTN","RCRJROIG",103,0)
K ^TMP($J,"RCRJROIGMM")
"RTN","RCRJROIG",104,0)
K ^TMP($J,"RCRJROIG")
"RTN","RCRJROIG",105,0)
Q
"RTN","RCRJROIG",106,0)
;
"RTN","RCRJROIG",107,0)
;
"RTN","RCRJROIG",108,0)
MAILIT(SITE,FYQ,SEQUENCE) ; send code sheets to oig
"RTN","RCRJROIG",109,0)
N %,%H,%Z,X,XCNP,XMDUZ,XMSCR,XMSUB,XMY,XMZ,Y
"RTN","RCRJROIG",110,0)
;
"RTN","RCRJROIG",111,0)
; set a header record in each file to be transmitted
"RTN","RCRJROIG",112,0)
S ^TMP($J,"RCRJROIGMM",.5)="OH$"_$$RJ^XLFSTR(SEQUENCE,5,0)_"$"_$$RJ^XLFSTR(TOTALMSG,5,0)_"$|"
"RTN","RCRJROIG",113,0)
;
"RTN","RCRJROIG",114,0)
I TOTALCNT=0 S XMY("G.RC AR DATA COLLECTOR")=""
"RTN","RCRJROIG",115,0)
S XMY("XXX@
DNS ")=""
"RTN","RCRJROIG",116,0)
S XMDUZ="AR PACKAGE"
"RTN","RCRJROIG",117,0)
S %H=$H D YX^%DTC
"RTN","RCRJROIG",118,0)
S XMSUB=SITE_"/BILL/"_FYQ_"/SEQ#: "_SEQUENCE_"/"_Y
"RTN","RCRJROIG",119,0)
S XMTEXT="^TMP($J,""RCRJROIGMM"","
"RTN","RCRJROIG",120,0)
D ^XMD
"RTN","RCRJROIG",121,0)
Q
"RTN","RCRJROIG",122,0)
;
"RTN","RCRJROIG",123,0)
;
"RTN","RCRJROIG",124,0)
DATE(DATE) ; format date
"RTN","RCRJROIG",125,0)
; example input=2990408, output=APR 08,1999
"RTN","RCRJROIG",126,0)
I DATE D
"RTN","RCRJROIG",127,0)
. S Y=DATE D DD^%DT
"RTN","RCRJROIG",128,0)
. S DATE=$E(Y,1,3)_" "_$E(DATE,6,7)_","_(1700+$E(DATE,1,3))
"RTN","RCRJROIG",129,0)
Q $$LJ^XLFSTR(DATE,11)
"RTN","RCRJROIG",130,0)
;
"RTN","RCRJROIG",131,0)
;
"RTN","RCRJROIG",132,0)
GETRSC(BILLDA,FUND) ; return the rsc for a bill
"RTN","RCRJROIG",133,0)
N RCRSC
"RTN","RCRJROIG",134,0)
I '$$PTACCT^PRCAACC(FUND),FUND'=4032 Q $P($G(^PRCA(430,BILLDA,11)),"^",6)
"RTN","RCRJROIG",135,0)
; check missing patient for reimbursable health insurance
"RTN","RCRJROIG",136,0)
I $P(^PRCA(430,BILLDA,0),"^",2)=9,'$P(^PRCA(430,BILLDA,0),"^",7) Q " "
"RTN","RCRJROIG",137,0)
;PRCA*4.5*338 - retrieve existing RSC before calculating a new one
"RTN","RCRJROIG",138,0)
S RCRSC=$$GET1^DIQ(430,BILLDA_",",255)
"RTN","RCRJROIG",139,0)
S:RCRSC="" RCRSC=$$GET1^DIQ(430,BILLDA_",",255.1)
"RTN","RCRJROIG",140,0)
Q:RCRSC'="" RCRSC
"RTN","RCRJROIG",141,0)
;end RCRSC
"RTN","RCRJROIG",142,0)
Q $$CALCRSC^RCXFMSUR(BILLDA)
"RTN","RCTCSPD")
0^14^B162525249
"RTN","RCTCSPD",1,0)
RCTCSPD ;ALBANY/BDB-CROSS-SERVICING TRANSMISSION ;03/15/14 3:34 PM
"RTN","RCTCSPD",2,0)
;;4.5;Accounts Receivable;**301,327,315,338**;Mar 20, 1995;Build 70
"RTN","RCTCSPD",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCTCSPD",4,0)
;
"RTN","RCTCSPD",5,0)
;PRCA*4.5*327 a. Add check to insure debtor exists to prevent
"RTN","RCTCSPD",6,0)
; undefined error and set in XTMP work global to
"RTN","RCTCSPD",7,0)
; be reported via 'TCSP' mailgroup.
"RTN","RCTCSPD",8,0)
; b. Added process controls throughout entire batch
"RTN","RCTCSPD",9,0)
; run and message to mail group 'TCSP' batch run
"RTN","RCTCSPD",10,0)
; is complete
"RTN","RCTCSPD",11,0)
; c. Move SETUP/FINISH to new routine RCTCSPD0
"RTN","RCTCSPD",12,0)
; due to SACC size constraints
"RTN","RCTCSPD",13,0)
; d. Move REC2C tag/code to RCTCSP7 to create space
"RTN","RCTCSPD",14,0)
; for debtor undefined logic
"RTN","RCTCSPD",15,0)
;
"RTN","RCTCSPD",16,0)
ENTER ; Entry point from nightly process PRCABJ
"RTN","RCTCSPD",17,0)
N DEBTOR,P150DT,PRIN,INT,ADMIN,TDEB,TFIL,RCDFN,CNTR,SITE,LN,FN,MN,SITE,F60DT,VADM,PHONE,QUIT,TOTAL,ZIPCODE,FULLNM,RCNT,REPAY,X1,X2,ERROR,ADDR,CAT,BILLDT,CURRTOT,SITECD
"RTN","RCTCSPD",18,0)
N SEQ,CNTLID,PREPDT,X1,X2,X,DELDT,ACTDT
"RTN","RCTCSPD",19,0)
D SETUP^RCTCSPD0
"RTN","RCTCSPD",20,0)
S (DEBTOR,RCNT)=0,SEQ=0
"RTN","RCTCSPD",21,0)
RSDEBTOR ;
"RTN","RCTCSPD",22,0)
F S DEBTOR=$O(^PRCA(430,"C",DEBTOR)) Q:DEBTOR'?1N.N D
"RTN","RCTCSPD",23,0)
.D NOW^%DTC S ^XTMP("RCTCSPD",$J,"ZZBDEBTOR")=%_U_DEBTOR
"RTN","RCTCSPD",24,0)
.N X,RCDFN,DEMCS,DOB,GNDR,DEBTOR0,DEBTOR1,DEBTOR3,DEBTOR7,BILL
"RTN","RCTCSPD",25,0)
.I '$D(^RCD(340,DEBTOR,0)) S ^XTMP("RCTCSPD",$J,"ZZUNDEF",DEBTOR)="" Q
"RTN","RCTCSPD",26,0)
.S DEBTOR0=^RCD(340,DEBTOR,0),DEBTOR1=$G(^(1)),DEBTOR3=$G(^(3)),DEBTOR7=$G(^(7))
"RTN","RCTCSPD",27,0)
.S RCDFN=+DEBTOR0
"RTN","RCTCSPD",28,0)
.S DEMCS=$$DEM^RCTCSP1(RCDFN)
"RTN","RCTCSPD",29,0)
.S DOB=$P(DEMCS,U,2)
"RTN","RCTCSPD",30,0)
.S GNDR=$P(DEMCS,U,1) S:"MF"'[GNDR GNDR="U"
"RTN","RCTCSPD",31,0)
.I $P(DEBTOR7,U,2) I '+$P(DEBTOR7,U,3) D ;send type 2 recall record
"RTN","RCTCSPD",32,0)
..N ACTION,B0,B15,BILL
"RTN","RCTCSPD",33,0)
..S ACTION="L"
"RTN","RCTCSPD",34,0)
..S B0="",B15="",BILL=0
"RTN","RCTCSPD",35,0)
..; The code below is designed to get ONLY one bill #. It is not a bug! As per VA SME contacts.
"RTN","RCTCSPD",36,0)
..F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N I $D(^PRCA(430,"TCSP",BILL)) I $P(^PRCA(430,BILL,15),U,7)'=1 S B0=$G(^PRCA(430,BILL,0)),B15=$G(^(15)) Q ;get one bill
"RTN","RCTCSPD",37,0)
..I BILL="" S BILL=0 S $P(^RCD(340,DEBTOR,7),U,2,4)="^^",$P(DEBTOR7,U,2,4)="^^" Q ;cs debtor with no cs bill, clear the debtor recall flag, quit
"RTN","RCTCSPD",38,0)
..D REC2
"RTN","RCTCSPD",39,0)
..S $P(^RCD(340,DEBTOR,7),U,3)=DT
"RTN","RCTCSPD",40,0)
..S DEBTOR7=^RCD(340,DEBTOR,7)
"RTN","RCTCSPD",41,0)
..S BILL=0 ;set debtor cross-serviced bills as recalled
"RTN","RCTCSPD",42,0)
..F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D
"RTN","RCTCSPD",43,0)
...D NOW^%DTC S ^XTMP("RCTCSPD",$J,"ZZCRBILL")=%_U_BILL
"RTN","RCTCSPD",44,0)
...I $D(^PRCA(430,"TCSP",BILL)) D Q ;bill previously sent to TCSP
"RTN","RCTCSPD",45,0)
....S $P(^PRCA(430,BILL,15),U,1)="" ;clear the date referred
"RTN","RCTCSPD",46,0)
....S $P(^PRCA(430,BILL,15),U,2)=1 ;set the recall flag
"RTN","RCTCSPD",47,0)
....S $P(^PRCA(430,BILL,15),U,3)=DT ;set the recall date
"RTN","RCTCSPD",48,0)
....S $P(^PRCA(430,BILL,15),U,4)=$P(DEBTOR7,U,4) ;set the recall reason
"RTN","RCTCSPD",49,0)
....S $P(^PRCA(430,BILL,15),U,5)=$$GET1^DIQ(430,BILL,11) ;set the recall amount to the current amount
"RTN","RCTCSPD",50,0)
....K ^PRCA(430,"TCSP",BILL) ;kill the cross-servicing cross reference
"RTN","RCTCSPD",51,0)
....D RCRSD^RCTCSPD4 ; set debtor recall non-financial transaction PRCA*4.5*315
"RTN","RCTCSPD",52,0)
.S (BILL,TOTAL,REPAY)=0
"RTN","RCTCSPD",53,0)
.F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D
"RTN","RCTCSPD",54,0)
..D NOW^%DTC S ^XTMP("RCTCSPD",$J,"ZZCTRACKER")=%_U_DEBTOR_U_BILL
"RTN","RCTCSPD",55,0)
..N B0,B4,B6,B7,B9,B12,B121,B14,B15,B16,B19,B20,ACTION
"RTN","RCTCSPD",56,0)
..S B0=$G(^PRCA(430,BILL,0)),B4=$G(^(4)),B6=$G(^(6)),B7=$G(^(7)),B9=$G(^(9)),B12=$G(^(12)),B121=$G(^(12.1)),B14=$G(^(14)),B15=$G(^(15)),B16=$G(^(16)),B19=$G(^(19)),B20=$G(^(20))
"RTN","RCTCSPD",57,0)
..Q:($P(B6,U,21)\1)<ACTDT ;cs activation date cutoff
"RTN","RCTCSPD",58,0)
..I $D(^PRCA(430,"TCSP",BILL)),$$RCLLCHK^RCTCSP2(BILL) Q ;bill previously sent to TCSP
"RTN","RCTCSPD",59,0)
..I $$UPDCHK(BILL) Q
"RTN","RCTCSPD",60,0)
..Q:B4 ;repayment plan
"RTN","RCTCSPD",61,0)
..Q:+$P(B15,U,7) ;quit if bill is stopped
"RTN","RCTCSPD",62,0)
..Q:+$P(B14,U,1) ;bill referred to TOP
"RTN","RCTCSPD",63,0)
..Q:$P(DEBTOR1,"^",9)=1 ;quit if debtor address marked unknown
"RTN","RCTCSPD",64,0)
..Q:$E($P(DEMCS,U,3),1,5)="00000" ;quit if the ssn is not valid
"RTN","RCTCSPD",65,0)
..I +$P(B12,U,1) Q ;check date bill sent to dmc
"RTN","RCTCSPD",66,0)
..Q:($P(B121,U,1)="N")!($P(B121,U,1)="P") ;dmc debt valid
"RTN","RCTCSPD",67,0)
..I $P(B6,U,4),($P(B6,U,5)="DOJ") Q
"RTN","RCTCSPD",68,0)
..Q:+$P(DEMCS,U,4) ;deceased patient
"RTN","RCTCSPD",69,0)
..Q:'$P(B0,U,2) ;no category
"RTN","RCTCSPD",70,0)
..S CAT=$P($G(^PRCA(430.2,$P(B0,U,2),0)),U,7)
"RTN","RCTCSPD",71,0)
..Q:'CAT
"RTN","RCTCSPD",72,0)
..;PRCA*4.5*338 - Use RFCHK^RCTOPD to determine if the Category can be referred
"RTN","RCTCSPD",73,0)
..; using the new date based algorithm.
"RTN","RCTCSPD",74,0)
..Q:'$$RFCHK^RCTOPD(CAT,"N",1.03,$P(B6,U,21))
"RTN","RCTCSPD",75,0)
..;end PRCA*4.5*338
"RTN","RCTCSPD",76,0)
..;dpn checks
"RTN","RCTCSPD",77,0)
..I $P(B20,U,3)=1,(10000+$G(^RC(342,1,"CS")))>DT,'$P(B20,U,4) D DUEPROC^RCTCSP3 Q ;check to send dpn file to aitc
"RTN","RCTCSPD",78,0)
..I $P(B20,U,3)=1,(10000+$G(^RC(342,1,"CS")))>DT,$P(B20,U,4),'$P(B20,U,5) Q ;check for print letter date
"RTN","RCTCSPD",79,0)
..I $P(B20,U,3)=1,(10000+$G(^RC(342,1,"CS")))>DT,$P(B20,U,4),$P(B20,U,5) D I X<60 Q ;check for 60 day wait from print letter date
"RTN","RCTCSPD",80,0)
...N X1,X2
"RTN","RCTCSPD",81,0)
...S X1=DT,X2=$P(B20,U,5) D ^%DTC
"RTN","RCTCSPD",82,0)
...I X'<60 S $P(B20,U,6)=DT,^PRCA(430,BILL,20)=B20 ;set the bill referral date to the current date
"RTN","RCTCSPD",83,0)
..S BILLDT=$P(B6,U,21),PREPDT=$P(B0,U,10)
"RTN","RCTCSPD",84,0)
..I BILLDT>P150DT Q ;150 day old check
"RTN","RCTCSPD",85,0)
..I ($P(B0,U,8)=16),('$P(B6,U,3)) D Q
"RTN","RCTCSPD",86,0)
...;no 3rd letter being sent
"RTN","RCTCSPD",87,0)
...N DNM
"RTN","RCTCSPD",88,0)
...S DNM=$$NAMEFF(+DEBTOR0),^XTMP("RCTCSPD",$J,"THIRD",DNM,$P(B0,U))=""
"RTN","RCTCSPD",89,0)
..I $P(B0,U,8)=16 I $$ADDCHKND(BILL) Q
"RTN","RCTCSPD",90,0)
..I $P(B0,U,8)=16 I $$ADDCHKNB(BILL) Q
"RTN","RCTCSPD",91,0)
..Q
"RTN","RCTCSPD",92,0)
.Q
"RTN","RCTCSPD",93,0)
;
"RTN","RCTCSPD",94,0)
D NOW^%DTC S ^XTMP("RCTCSPD",$J,"ZZDEND")=%
"RTN","RCTCSPD",95,0)
D THIRD^RCTCSP2
"RTN","RCTCSPD",96,0)
D NOW^%DTC S ^XTMP("RCTCSPD",$J,"ZZETRANSMIT CS RECS")=%
"RTN","RCTCSPD",97,0)
D COMPILE^RCTCSP2 ;compile cross-serviced records
"RTN","RCTCSPD",98,0)
D NOW^%DTC S ^XTMP("RCTCSPD",$J,"ZZFTRANSMIT DPN")=%
"RTN","RCTCSPD",99,0)
D COMPILED^RCTCSP3 ;compile the aitc due process notification records
"RTN","RCTCSPD",100,0)
D NOW^%DTC S ^XTMP("RCTCSPD",$J,"ZZGTRANSMIT FINISHED")=%
"RTN","RCTCSPD",101,0)
D NOW^%DTC S ^XTMP("RCTCSPD",$J,"ZZHCOMPLETE")=%
"RTN","RCTCSPD",102,0)
D FINISH^RCTCSPD0
"RTN","RCTCSPD",103,0)
Q
"RTN","RCTCSPD",104,0)
;
"RTN","RCTCSPD",105,0)
ADDCHKND(BILL) ;add a new bill referral, new debtor
"RTN","RCTCSPD",106,0)
N TOTAL,ACTION,X
"RTN","RCTCSPD",107,0)
S ACTION="A"
"RTN","RCTCSPD",108,0)
I $D(^RCD(340,"TCSP",DEBTOR)) Q 0 ;check debtor previously referred
"RTN","RCTCSPD",109,0)
I $P(B15,U,2) Q 0 ;check tcsp bill recall flag
"RTN","RCTCSPD",110,0)
I $P(DEBTOR7,U,2) Q 0 ;check debtor recall
"RTN","RCTCSPD",111,0)
I $P(B15,U,7) Q 0 ;check stop tcsp referral flag
"RTN","RCTCSPD",112,0)
I $D(^PRCA(430,"TCSP",BILL)) Q 0 ;bill previously sent to TCSP
"RTN","RCTCSPD",113,0)
S TOTAL=$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5)
"RTN","RCTCSPD",114,0)
I TOTAL<25 Q 1 ;no adds for bills less than $25
"RTN","RCTCSPD",115,0)
D REC1,REC2,REC2A
"RTN","RCTCSPD",116,0)
S $P(^PRCA(430,BILL,16),U,13)=DOB,B16=^(16)
"RTN","RCTCSPD",117,0)
S $P(^PRCA(430,BILL,15),U,14)=GNDR,B15=^(15)
"RTN","RCTCSPD",118,0)
D REC2C^RCTCSP7 ;PRCA*4.5*327
"RTN","RCTCSPD",119,0)
S ADDRCS=$$ADDR^RCTCSP1(RCDFN)
"RTN","RCTCSPD",120,0)
S $P(^PRCA(430,BILL,16),U,4,8)=$P(ADDRCS,U,1,5),$P(^(16),U,11)=$P(ADDRCS,U,6),$P(^(16),U,12)=$P(ADDRCS,U,7)
"RTN","RCTCSPD",121,0)
S B16=^PRCA(430,BILL,16)
"RTN","RCTCSPD",122,0)
D REC3^RCTCSP2
"RTN","RCTCSPD",123,0)
S TAXID=$$TAXID(DEBTOR)
"RTN","RCTCSPD",124,0)
S NAME=$$NAME(+DEBTOR0),NAME=$P(NAME,U)
"RTN","RCTCSPD",125,0)
S $P(^PRCA(430,BILL,15),U,1)=DT,$P(^(16),U,1)=TAXID,$P(^(16),U,2)=NAME
"RTN","RCTCSPD",126,0)
S X1=BILLDT,X2=+30 D C^%DTC S DELDT=X
"RTN","RCTCSPD",127,0)
S $P(^PRCA(430,BILL,16),U,3)=DELDT,^PRCA(430,"TCSP",BILL)=""
"RTN","RCTCSPD",128,0)
I $P($G(^PRCA(430,BILL,21)),U,21)="" S $P(^PRCA(430,BILL,21),U,1)=DT
"RTN","RCTCSPD",129,0)
I '$D(^RCD(340,"TCSP",DEBTOR)) S $P(^RCD(340,DEBTOR,7),U,5)=DT,^RCD(340,"TCSP",DEBTOR)=""
"RTN","RCTCSPD",130,0)
D NEWDEBTR^RCTCSPD4 ; set CS new debtor new bill non-financial transaction PRCA*4.5*315
"RTN","RCTCSPD",131,0)
Q 1
"RTN","RCTCSPD",132,0)
;
"RTN","RCTCSPD",133,0)
ADDCHKNB(BILL) ;add a new bill referral, existing debtor
"RTN","RCTCSPD",134,0)
N TOTAL,ACTION,TAXID,NAME,ADDRCS,X
"RTN","RCTCSPD",135,0)
I '$D(^RCD(340,"TCSP",DEBTOR)) Q 0 ;check debtor previously referred
"RTN","RCTCSPD",136,0)
I $P(B15,U,2) Q 0 ;check tcsp bill recall flag
"RTN","RCTCSPD",137,0)
I $P(B15,U,7) Q 0 ;check stop tcsp referral flag
"RTN","RCTCSPD",138,0)
I $D(^PRCA(430,"TCSP",BILL)) Q 0 ;bill previously sent to TCSP
"RTN","RCTCSPD",139,0)
S TOTAL=$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5)
"RTN","RCTCSPD",140,0)
I TOTAL<25 Q 0 ;no adds for bills less than $25
"RTN","RCTCSPD",141,0)
S ACTION="A" D REC1
"RTN","RCTCSPD",142,0)
S ACTION="B" D REC2
"RTN","RCTCSPD",143,0)
S ACTION="A" D REC3^RCTCSP2
"RTN","RCTCSPD",144,0)
S TAXID=$$TAXID(DEBTOR)
"RTN","RCTCSPD",145,0)
S NAME=$$NAME(+DEBTOR0),NAME=$P(NAME,U)
"RTN","RCTCSPD",146,0)
S $P(^PRCA(430,BILL,15),U,1)=DT,$P(^(16),U,1)=TAXID,$P(^(16),U,2)=NAME,$P(^(16),U,3)=BILLDT,^PRCA(430,"TCSP",BILL)=""
"RTN","RCTCSPD",147,0)
I $P($G(^PRCA(430,BILL,21)),U,21)="" S $P(^PRCA(430,BILL,21),U,1)=DT
"RTN","RCTCSPD",148,0)
S ADDRCS=$$ADDR^RCTCSP1(RCDFN)
"RTN","RCTCSPD",149,0)
S $P(^PRCA(430,BILL,16),U,4,8)=$P(ADDRCS,U,1,5),$P(^(16),U,11)=$P(ADDRCS,U,6),$P(^(16),U,12)=$P(ADDRCS,U,7)
"RTN","RCTCSPD",150,0)
S $P(^PRCA(430,BILL,16),U,13)=DOB,B16=^(16)
"RTN","RCTCSPD",151,0)
S $P(^PRCA(430,BILL,15),U,14)=GNDR,B15=^(15)
"RTN","RCTCSPD",152,0)
I '$D(^RCD(340,"TCSP",DEBTOR)) S $P(^RCD(340,DEBTOR,7),U,5)=DT,^RCD(340,"TCSP",DEBTOR)=""
"RTN","RCTCSPD",153,0)
D DEBTOR^RCTCSPD4 ; set CS debtor new bill non-financial transaction PRCA*4.5*315
"RTN","RCTCSPD",154,0)
Q 1
"RTN","RCTCSPD",155,0)
;
"RTN","RCTCSPD",156,0)
UPDCHK(BILL) ;update 5b or existing bill
"RTN","RCTCSPD",157,0)
I '$D(^PRCA(430,BILL,16)) Q 0 ;quit null node 16 old address
"RTN","RCTCSPD",158,0)
N TOTAL,TAXID,OTAXID,NAME,ONAME,ADDR,OADDR,ADDRCS,COUNTRY,OCOUNTRY,OPHONE,ODOB,OGNDR,TRNIDX,TRN1,TRN8,TRNAMT,TRNNUM,TRNFLG,FIVBFLG
"RTN","RCTCSPD",159,0)
I $P(B15,U,2) Q 0 ;check tcsp bill recall flag
"RTN","RCTCSPD",160,0)
I $P(B15,U,7) Q 0 ;check stop tcsp referral flag
"RTN","RCTCSPD",161,0)
;5b check
"RTN","RCTCSPD",162,0)
S FIVBFLG=0
"RTN","RCTCSPD",163,0)
S TRNIDX=0 F S TRNIDX=$O(^PRCA(430,BILL,17,TRNIDX)) Q:+TRNIDX=0 D
"RTN","RCTCSPD",164,0)
.S TRNNUM=$P($G(^PRCA(430,BILL,17,TRNIDX,0)),U,1),TRNFLG=$P($G(^PRCA(430,BILL,17,TRNIDX,0)),U,2)
"RTN","RCTCSPD",165,0)
.Q:+TRNFLG=0
"RTN","RCTCSPD",166,0)
.S TRN1=$G(^PRCA(433,TRNNUM,1)),TRNAMT=$P(TRN1,U,5) S:TRNAMT<0 TRNAMT=-TRNAMT
"RTN","RCTCSPD",167,0)
.S TRN8=$G(^PRCA(433,TRNNUM,8))
"RTN","RCTCSPD",168,0)
.S ACTION="U"
"RTN","RCTCSPD",169,0)
.D REC5B^RCTCSP1
"RTN","RCTCSPD",170,0)
.S $P(^PRCA(430,BILL,17,TRNIDX,0),U,2)=""
"RTN","RCTCSPD",171,0)
.S FIVBFLG=1
"RTN","RCTCSPD",172,0)
S TOTAL=$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5)
"RTN","RCTCSPD",173,0)
I FIVBFLG,(TOTAL=0) S DR="151///@",DIE="^PRCA(430,",DA=BILL D ^DIE K DR,DIE,DA
"RTN","RCTCSPD",174,0)
I $P(B19,U,1)=1 S ACTION="U" D REC1 S $P(B19,U,1)="" S $P(^PRCA(430,BILL,19),U,1)=""
"RTN","RCTCSPD",175,0)
I $P(B19,U,2)=1 S ACTION="U" D REC2 S $P(B19,U,2)="" S $P(^PRCA(430,BILL,19),U,2)=""
"RTN","RCTCSPD",176,0)
I $P(B19,U,3)=1 S ACTION="U" D REC2A S $P(B19,U,3)="" S $P(^PRCA(430,BILL,19),U,3)=""
"RTN","RCTCSPD",177,0)
I $P(B19,U,4)=1 S ACTION="A" D REC2C^RCTCSP7 S $P(B19,U,4)="" S $P(^PRCA(430,BILL,19),U,4)="" ;PRCA*4.5*327
"RTN","RCTCSPD",178,0)
I FIVBFLG=1 Q 1 ;if 5b sent, then do not continue to referral check
"RTN","RCTCSPD",179,0)
I '$D(^PRCA(430,"TCSP",BILL)) Q 0 ;if not cross-serviced, then continue referral check
"RTN","RCTCSPD",180,0)
S TAXID=$$TAXID(DEBTOR)
"RTN","RCTCSPD",181,0)
S OTAXID=$P(B16,U,1)
"RTN","RCTCSPD",182,0)
S NAME=$$NAME(+DEBTOR0),NAME=$P(NAME,U)
"RTN","RCTCSPD",183,0)
S ONAME=$P(B16,U,2)
"RTN","RCTCSPD",184,0)
I $P(B0,U,8)=16,$D(^PRCA(430,"TCSP",BILL)) I (NAME'=ONAME)!(TAXID'=OTAXID) D
"RTN","RCTCSPD",185,0)
.S ACTION="U"
"RTN","RCTCSPD",186,0)
.D REC2
"RTN","RCTCSPD",187,0)
.S $P(^PRCA(430,BILL,16),U,1)=TAXID,$P(^(16),U,2)=NAME,$P(^(19),U,2)="",$P(B19,U,2)=""
"RTN","RCTCSPD",188,0)
S OADDR=$P(^PRCA(430,BILL,16),U,4,8),OPHONE=$P(^(16),U,11),OCOUNTRY=$P(^(16),U,12)
"RTN","RCTCSPD",189,0)
S ADDRCS=$$ADDR^RCTCSP1(RCDFN),PHONE=$P(ADDRCS,U,6),COUNTRY=$P(ADDRCS,U,7)
"RTN","RCTCSPD",190,0)
I $P(DEBTOR1,"^",9)'=1 D ;if debtor address is not marked unknown, then check address
"RTN","RCTCSPD",191,0)
.I $P(B0,U,8)=16,$D(^PRCA(430,"TCSP",BILL)) I ($P(ADDRCS,U,1,5)'=$P(OADDR,U,1,5))!(PHONE'=OPHONE)!(COUNTRY'=OCOUNTRY) D
"RTN","RCTCSPD",192,0)
..S ACTION="A" ;2c records have action code 'a'
"RTN","RCTCSPD",193,0)
..D REC2C^RCTCSP7
"RTN","RCTCSPD",194,0)
..S $P(B19,U,4)=""
"RTN","RCTCSPD",195,0)
..S $P(^PRCA(430,BILL,16),U,4,8)=$P(ADDRCS,U,1,5),$P(^(16),U,11)=PHONE,$P(^(16),U,12)=$P(ADDRCS,U,7)
"RTN","RCTCSPD",196,0)
S B16=^PRCA(430,BILL,16)
"RTN","RCTCSPD",197,0)
S ODOB=$P(^PRCA(430,BILL,16),U,13)
"RTN","RCTCSPD",198,0)
S OGNDR=$P(^PRCA(430,BILL,15),U,14)
"RTN","RCTCSPD",199,0)
I $P(B0,U,8)=16,$D(^PRCA(430,"TCSP",BILL)) I (DOB'=ODOB)!(GNDR'=OGNDR) D
"RTN","RCTCSPD",200,0)
.S ACTION="U"
"RTN","RCTCSPD",201,0)
.D REC2A
"RTN","RCTCSPD",202,0)
.S $P(^PRCA(430,BILL,16),U,13)=DOB,B16=^(16)
"RTN","RCTCSPD",203,0)
.S $P(^PRCA(430,BILL,15),U,14)=GNDR,B15=^(15)
"RTN","RCTCSPD",204,0)
.Q
"RTN","RCTCSPD",205,0)
Q 1 ;bill is cross-serviced so do not continue referral check
"RTN","RCTCSPD",206,0)
;
"RTN","RCTCSPD",207,0)
REC1 ;record type 1
"RTN","RCTCSPD",208,0)
N REC,KNUM,DEBTNR,AMTORIG,AMTPBAL,AMTIBAL,AMTABAL,AMTFBAL,AMTCBAL,AMTRFRRD,AMOUNT,DELDT,X,X1,X2,BILLDT,PREPDT
"RTN","RCTCSPD",209,0)
S REC="C1 "_ACTION_"3636001200"_"DM1D "
"RTN","RCTCSPD",210,0)
S KNUM=$P($P(B0,U,1),"-",2)
"RTN","RCTCSPD",211,0)
S DEBTNR=$E(SITE,1,3)_$$LJZF(KNUM,7)_$TR($J(BILL,20)," ",0),REC=REC_DEBTNR_" "
"RTN","RCTCSPD",212,0)
S REC=REC_"I A MSCC"
"RTN","RCTCSPD",213,0)
S BILLDT=$P(B6,U,21),PREPDT=$P(B0,U,10)
"RTN","RCTCSPD",214,0)
S REC=REC_$$DATE8(PREPDT)
"RTN","RCTCSPD",215,0)
S X1=BILLDT,X2=+30 D C^%DTC S DELDT=X
"RTN","RCTCSPD",216,0)
S REC=REC_$$DATE8(DELDT)
"RTN","RCTCSPD",217,0)
S AMTPBAL=$P(B7,U,1) ;principle balance
"RTN","RCTCSPD",218,0)
S AMTIBAL=$P(B7,U,2) ;interest balance
"RTN","RCTCSPD",219,0)
S AMTABAL=$P(B7,U,3) ;administrative balance
"RTN","RCTCSPD",220,0)
S AMTFBAL=$P(B7,U,4) ;marshal fee
"RTN","RCTCSPD",221,0)
S AMTCBAL=$P(B7,U,5) ;court cost
"RTN","RCTCSPD",222,0)
S AMTRFRRD=AMTPBAL+AMTIBAL+AMTABAL+AMTFBAL+AMTCBAL
"RTN","RCTCSPD",223,0)
S AMTORIG=$P(B0,U,3)
"RTN","RCTCSPD",224,0)
D ;
"RTN","RCTCSPD",225,0)
.I ACTION="A" S REC=REC_$$AMOUNT(AMTRFRRD)_$$AMOUNT(AMTRFRRD) Q
"RTN","RCTCSPD",226,0)
.I ACTION="L" S AMTRFRRD=0 S REC=REC_$$AMOUNT(AMTRFRRD)_$$AMOUNT(AMTRFRRD) Q
"RTN","RCTCSPD",227,0)
.S REC=REC_$$BLANK(28)
"RTN","RCTCSPD",228,0)
S REC=REC_" N "
"RTN","RCTCSPD",229,0)
S AMOUNT=$$AMOUNT(AMTPBAL)_$$AMOUNT(AMTIBAL)_$$AMOUNT(AMTABAL)_$$AMOUNT(AMTFBAL+AMTCBAL)
"RTN","RCTCSPD",230,0)
I ACTION="L" S AMOUNT=$$AMOUNT(0)_$$AMOUNT(0)_$$AMOUNT(0)_$$AMOUNT(0) ;by iai spec
"RTN","RCTCSPD",231,0)
I ACTION="U" S AMOUNT=$$BLANK(56) ;by iai spec
"RTN","RCTCSPD",232,0)
S REC=REC_AMOUNT
"RTN","RCTCSPD",233,0)
I ACTION="L" D
"RTN","RCTCSPD",234,0)
.S REC=REC_$$BLANK(252-$L(REC))
"RTN","RCTCSPD",235,0)
.S RCD=$P(B15,U,4)
"RTN","RCTCSPD",236,0)
.S REC=REC_$S(RCD="01":"01",RCD="07":"07",RCD="08":"08",RCD="15":"01",RCD="03":"01",RCD="05":"01",RCD="06":"01",1:"01")
"RTN","RCTCSPD",237,0)
S REC=REC_$$BLANK(450-$L(REC))
"RTN","RCTCSPD",238,0)
I ACTION="A" S $P(^PRCA(430,BILL,16),U,9)=AMTRFRRD,$P(^(16),U,10)=AMTRFRRD
"RTN","RCTCSPD",239,0)
I ACTION="L" S $P(^PRCA(430,BILL,16),U,9)="",$P(^(16),U,10)=""
"RTN","RCTCSPD",240,0)
S ^XTMP("RCTCSPD",$J,BILL,ACTION,1)=REC
"RTN","RCTCSPD",241,0)
S ^XTMP("RCTCSPD",$J,"BILL",ACTION,BILL)=$$TAXID(DEBTOR)_"^"_+$E(REC,91,102)_"."_$E(REC,103,104) ;sends mailman message of documents sent to user
"RTN","RCTCSPD",242,0)
D CLR19(BILL,1)
"RTN","RCTCSPD",243,0)
Q
"RTN","RCTCSPD",244,0)
;
"RTN","RCTCSPD",245,0)
REC2 ;
"RTN","RCTCSPD",246,0)
N REC,KNUM,DEBTNR,DEBTORNB,TAXID,NAME,RCD
"RTN","RCTCSPD",247,0)
S REC="C2 "_ACTION_"3636001200"_"DM1D "
"RTN","RCTCSPD",248,0)
S KNUM=$P($P(B0,U,1),"-",2)
"RTN","RCTCSPD",249,0)
S DEBTNR=$E(SITE,1,3)_$$LJZF(KNUM,7)_$TR($J(BILL,20)," ",0),REC=REC_DEBTNR
"RTN","RCTCSPD",250,0)
S DEBTORNB=$E(SITE,1,3)_$TR($J(DEBTOR,12)," ",0)
"RTN","RCTCSPD",251,0)
S REC=REC_DEBTORNB
"RTN","RCTCSPD",252,0)
S TAXID=$$TAXID(DEBTOR)
"RTN","RCTCSPD",253,0)
S REC=REC_TAXID_"SSN"
"RTN","RCTCSPD",254,0)
S NAME=$$NAME(+DEBTOR0),NAME=$P(NAME,U)
"RTN","RCTCSPD",255,0)
S REC=REC_NAME_$$BLANK(5)_"I"
"RTN","RCTCSPD",256,0)
I ACTION="L" D
"RTN","RCTCSPD",257,0)
.S REC=REC_$$BLANK(232-$L(REC))
"RTN","RCTCSPD",258,0)
.S RCD=$P(B15,U,4)
"RTN","RCTCSPD",259,0)
.S REC=REC_$S(RCD="01":"12",RCD="07":"12",RCD="08":"12",RCD="15":"12",RCD="03":"03",RCD="05":"05",RCD="06":"06",1:"12")
"RTN","RCTCSPD",260,0)
S REC=REC_$$BLANK(450-$L(REC))
"RTN","RCTCSPD",261,0)
S ^XTMP("RCTCSPD",$J,BILL,ACTION,2)=REC
"RTN","RCTCSPD",262,0)
S $P(^XTMP("RCTCSPD",$J,"BILL",ACTION,BILL),U,1)=$$TAXID(DEBTOR)
"RTN","RCTCSPD",263,0)
D CLR19(BILL,2)
"RTN","RCTCSPD",264,0)
Q
"RTN","RCTCSPD",265,0)
;
"RTN","RCTCSPD",266,0)
REC2A ;
"RTN","RCTCSPD",267,0)
N REC,KNUM,DEBTNR,DEBTORNB
"RTN","RCTCSPD",268,0)
S REC="C2A"_ACTION_"3636001200"_"DM1D "
"RTN","RCTCSPD",269,0)
S KNUM=$P($P(B0,U,1),"-",2)
"RTN","RCTCSPD",270,0)
S DEBTNR=$E(SITE,1,3)_$$LJZF(KNUM,7)_$TR($J(BILL,20)," ",0),REC=REC_DEBTNR
"RTN","RCTCSPD",271,0)
S DEBTORNB=$E(SITE,1,3)_$TR($J(DEBTOR,12)," ",0)
"RTN","RCTCSPD",272,0)
S REC=REC_DEBTORNB
"RTN","RCTCSPD",273,0)
S REC=REC_$$BLANK(3)
"RTN","RCTCSPD",274,0)
S REC=REC_GNDR
"RTN","RCTCSPD",275,0)
S REC=REC_$$DATE8($P(DEMCS,U,2))
"RTN","RCTCSPD",276,0)
S REC=REC_$$BLANK(450-$L(REC))
"RTN","RCTCSPD",277,0)
S ^XTMP("RCTCSPD",$J,BILL,ACTION,"2A")=REC
"RTN","RCTCSPD",278,0)
S $P(^XTMP("RCTCSPD",$J,"BILL",ACTION,BILL),U,1)=$$TAXID(DEBTOR)
"RTN","RCTCSPD",279,0)
D CLR19(BILL,3)
"RTN","RCTCSPD",280,0)
Q
"RTN","RCTCSPD",281,0)
;
"RTN","RCTCSPD",282,0)
DATE8(X) ;changes fileman date into 8 digit date yyyymmdd
"RTN","RCTCSPD",283,0)
I +X S X=X+17000000
"RTN","RCTCSPD",284,0)
S X=$E(X,1,8)
"RTN","RCTCSPD",285,0)
Q X
"RTN","RCTCSPD",286,0)
;
"RTN","RCTCSPD",287,0)
AMOUNT(X) ;changes amount to zero filled, right justified
"RTN","RCTCSPD",288,0)
S:X<0 X=-X
"RTN","RCTCSPD",289,0)
S X=$TR($J(X,0,2),".")
"RTN","RCTCSPD",290,0)
S X=$E("000000000000",1,14-$L(X))_X
"RTN","RCTCSPD",291,0)
Q X
"RTN","RCTCSPD",292,0)
;
"RTN","RCTCSPD",293,0)
NAME(DFN) ;returns name for document and name in file
"RTN","RCTCSPD",294,0)
N FN,LN,MN,NM,DOCNM,VA,VADM
"RTN","RCTCSPD",295,0)
S NM=""
"RTN","RCTCSPD",296,0)
D DEM^VADPT
"RTN","RCTCSPD",297,0)
I $D(VADM) S NM=VADM(1)
"RTN","RCTCSPD",298,0)
S LN=$TR($P(NM,",")," .'-"),MN=$P($P(NM,",",2)," ",2)
"RTN","RCTCSPD",299,0)
I ($E(MN,1,2)="SR")!($E(MN,1,2)="JR")!(MN?2.3"I")!(MN?0.1"I"1"V"1.3"I") S MN=""
"RTN","RCTCSPD",300,0)
S FN=$P($P(NM,",",2)," ")
"RTN","RCTCSPD",301,0)
S DOCNM=$$LJ^XLFSTR($E(LN,1,35),35)_$$LJ^XLFSTR($E(FN,1,35),35)_$$LJ^XLFSTR($E(MN,1,35),35)
"RTN","RCTCSPD",302,0)
Q DOCNM
"RTN","RCTCSPD",303,0)
;
"RTN","RCTCSPD",304,0)
NAMEFF(DFN) ;returns name for document and name in file
"RTN","RCTCSPD",305,0)
N FN,LN,MN,NM,DOCNM,VA,VADM
"RTN","RCTCSPD",306,0)
S NM=""
"RTN","RCTCSPD",307,0)
D DEM^VADPT
"RTN","RCTCSPD",308,0)
I $D(VADM) S NM=VADM(1)
"RTN","RCTCSPD",309,0)
S LN=$TR($P(NM,",")," .'-"),MN=$P($P(NM,",",2)," ",2)
"RTN","RCTCSPD",310,0)
I ($E(MN,1,2)="SR")!($E(MN,1,2)="JR")!(MN?2.3"I")!(MN?0.1"I"1"V"1.3"I") S MN=""
"RTN","RCTCSPD",311,0)
S FN=$P($P(NM,",",2)," ")
"RTN","RCTCSPD",312,0)
S DOCNM=LN_" "_FN_" "_MN
"RTN","RCTCSPD",313,0)
Q DOCNM
"RTN","RCTCSPD",314,0)
;
"RTN","RCTCSPD",315,0)
BLANK(X) ;returns 'x' blank spaces
"RTN","RCTCSPD",316,0)
N BLANK
"RTN","RCTCSPD",317,0)
S BLANK="",$P(BLANK," ",X+1)=""
"RTN","RCTCSPD",318,0)
Q BLANK
"RTN","RCTCSPD",319,0)
;
"RTN","RCTCSPD",320,0)
NOW() ;compiles current date,time
"RTN","RCTCSPD",321,0)
N X,Y,%,%H
"RTN","RCTCSPD",322,0)
S %H=$H D YX^%DTC
"RTN","RCTCSPD",323,0)
Q Y
"RTN","RCTCSPD",324,0)
;
"RTN","RCTCSPD",325,0)
RJZF(X,Y) ;right justify zero fill width Y
"RTN","RCTCSPD",326,0)
S X=$E("000000000000",1,Y-$L(X))_X
"RTN","RCTCSPD",327,0)
Q X
"RTN","RCTCSPD",328,0)
;
"RTN","RCTCSPD",329,0)
TAXID(DEBTOR) ;computes TAXID to place on documents
"RTN","RCTCSPD",330,0)
N TAXID,DIC,DA,DR,DIQ
"RTN","RCTCSPD",331,0)
S TAXID=$$SSN^RCFN01(DEBTOR)
"RTN","RCTCSPD",332,0)
S TAXID=$$LJSF(TAXID,9)
"RTN","RCTCSPD",333,0)
Q TAXID
"RTN","RCTCSPD",334,0)
;
"RTN","RCTCSPD",335,0)
LJSF(X,Y) ;x left justified, y space filled
"RTN","RCTCSPD",336,0)
S X=$E(X,1,Y)
"RTN","RCTCSPD",337,0)
S X=X_$$BLANK(Y-$L(X))
"RTN","RCTCSPD",338,0)
Q X
"RTN","RCTCSPD",339,0)
;
"RTN","RCTCSPD",340,0)
LJZF(X,Y) ;x left justified, y zero filled
"RTN","RCTCSPD",341,0)
S X=X_"0000000000"
"RTN","RCTCSPD",342,0)
S X=$E(X,X,Y)
"RTN","RCTCSPD",343,0)
Q X
"RTN","RCTCSPD",344,0)
;
"RTN","RCTCSPD",345,0)
RECALL(BILL) ; set the recall flag
"RTN","RCTCSPD",346,0)
S $P(^PRCA(430,BILL,15),U,2)=1
"RTN","RCTCSPD",347,0)
Q
"RTN","RCTCSPD",348,0)
;
"RTN","RCTCSPD",349,0)
CLR19(BILL,X) ; clear the send flag
"RTN","RCTCSPD",350,0)
S $P(^PRCA(430,BILL,19),U,X)=""
"RTN","RCTCSPD",351,0)
;
"RTN","RCTOPD")
0^12^B79395575
"RTN","RCTOPD",1,0)
RCTOPD ;WASH IRMFO@ALTOONA,PA/TJK-TOP TRANSMISSION ;2/11/00 3:34 PM
"RTN","RCTOPD",2,0)
V ;;4.5;Accounts Receivable;**141,187,224,236,229,301,315,337,338**;Mar 20, 1995;Build 70
"RTN","RCTOPD",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCTOPD",4,0)
;
"RTN","RCTOPD",5,0)
;PRCA*4.5*337 Keep XTMP work file for 5 days
"RTN","RCTOPD",6,0)
;
"RTN","RCTOPD",7,0)
ENTER ;Entry point from nightly process
"RTN","RCTOPD",8,0)
Q:'$D(RCDOC)
"RTN","RCTOPD",9,0)
N DEBTOR,BILL,DEBTOR0,B0,B6,B7,P121DT,PRIN,INT,ADMIN,B4,B14 ;PRCA*4.5*315 - P181Dt change to P121DT - FY16 HAPE RRE [TOPS]
"RTN","RCTOPD",10,0)
N EFFDT,DFN,CNTR,SITE,LN,FN,MN,DOB,SITE,F60DT,VADM,DEBTOR4,DEBTOR6
"RTN","RCTOPD",11,0)
N PHONE,QUIT,TOTAL,ZIPCODE,FULLNM,RCNT,REPAY,X1,X2
"RTN","RCTOPD",12,0)
N ERROR,ADDR,CAT,BILLDT,P10YDT,CURRTOT,HOLD,SITECD,RCNEW,ACTDT
"RTN","RCTOPD",13,0)
;
"RTN","RCTOPD",14,0)
;initialize temporary global, variables
"RTN","RCTOPD",15,0)
;
"RTN","RCTOPD",16,0)
K ^XTMP("RCTOPD") S ^XTMP("RCTOPD",0)=$$FMADD^XLFDT(DT,5)_"^"_DT ;PRCA*4.5*315 Allow global to be purged in 5 days
"RTN","RCTOPD",17,0)
S SITE=$E($$SITE^RCMSITE(),1,3),SITECD=$P(^RC(342,1,3),U,5)
"RTN","RCTOPD",18,0)
S X1=DT,X2=-121 D C^%DTC S (P121DT,EFFDT)=X ; PRCA*4.5*315 - FY16 HAPE RRE [TOPS] - change -181 to -121 (120 vs 180 days)
"RTN","RCTOPD",19,0)
S X1=DT,X2=-3650 D C^%DTC S P10YDT=X
"RTN","RCTOPD",20,0)
S X1=DT,X2=+60 D C^%DTC S F60DT=X
"RTN","RCTOPD",21,0)
S ACTDT=3150801 ;activation date for all sites except beckley, little rock, upstate ny
"RTN","RCTOPD",22,0)
S:SITE=598 ACTDT=3150201 ;activation date for little rock
"RTN","RCTOPD",23,0)
S:SITE=517 ACTDT=3150201 ;activation date for beckley
"RTN","RCTOPD",24,0)
S:SITE=528 ACTDT=3150201 ;activation date for upstate ny
"RTN","RCTOPD",25,0)
S (CNTR(1),CNTR(2),CNTR(4),DEBTOR,RCNT)=0
"RTN","RCTOPD",26,0)
;
"RTN","RCTOPD",27,0)
;branch if recertification document
"RTN","RCTOPD",28,0)
I RCDOC="Y" D RECERT G EXIT
"RTN","RCTOPD",29,0)
;
"RTN","RCTOPD",30,0)
;branch to do update documents
"RTN","RCTOPD",31,0)
D UPDATE I RCDOC="U" G EXIT
"RTN","RCTOPD",32,0)
;
"RTN","RCTOPD",33,0)
;master sheet compilation
"RTN","RCTOPD",34,0)
;
"RTN","RCTOPD",35,0)
F S DEBTOR=$O(^PRCA(430,"C",DEBTOR)) Q:DEBTOR'?1N.N D
"RTN","RCTOPD",36,0)
.N X,RCDFN
"RTN","RCTOPD",37,0)
.S RCDFN=$G(^RCD(340,DEBTOR,0))
"RTN","RCTOPD",38,0)
.I $P(RCDFN,";",2)["DPT",$$EMERES^PRCAUTL(+RCDFN)]"" Q ;stop the master sheet compilation for hurricane Katrina sites (patients)
"RTN","RCTOPD",39,0)
.Q:$D(^RCD(340,"TOP",DEBTOR))
"RTN","RCTOPD",40,0)
.; quit if debtor address marked unknown
"RTN","RCTOPD",41,0)
.Q:$P($G(^RCD(340,+DEBTOR,1)),"^",9)=1
"RTN","RCTOPD",42,0)
.S DEBTOR6=$G(^RCD(340,DEBTOR,6)),DEBTOR0=$G(^(0)),HOLD=0,RCNEW=1
"RTN","RCTOPD",43,0)
.I $P(DEBTOR6,U,2),'$P(DEBTOR6,U,3) Q
"RTN","RCTOPD",44,0)
.S QUIT=1,FILE=$$FILE(DEBTOR0) Q:'FILE
"RTN","RCTOPD",45,0)
.S EFFDT=P121DT
"RTN","RCTOPD",46,0)
.D PROC(DEBTOR,.QUIT,FILE,.HOLD,.EFFDT) Q:QUIT
"RTN","RCTOPD",47,0)
.D EN1^RCTOP2(DEBTOR,"M",FILE)
"RTN","RCTOPD",48,0)
.D EN1^RCTOP1(DEBTOR,TOTAL,"M",EFFDT,0,FILE)
"RTN","RCTOPD",49,0)
.;set hold date in file for employee, ex-employee, vendor records
"RTN","RCTOPD",50,0)
.;Austin holds these for 60 days before transmitting to TOP
"RTN","RCTOPD",51,0)
.I $G(HOLD) S $P(^RCD(340,DEBTOR,6),U,6)=F60DT
"RTN","RCTOPD",52,0)
.Q
"RTN","RCTOPD",53,0)
;compile documents into mail messages--sets referral date in 430
"RTN","RCTOPD",54,0)
D COMPILE
"RTN","RCTOPD",55,0)
EXIT K RCDOC,^TMP("RCTOPD"),XMDUZ D KVAR^VADPT
"RTN","RCTOPD",56,0)
Q
"RTN","RCTOPD",57,0)
;
"RTN","RCTOPD",58,0)
UPDATE ;weekly update compilation
"RTN","RCTOPD",59,0)
F S DEBTOR=$O(^RCD(340,"TOP",DEBTOR)) Q:DEBTOR'?1N.N D
"RTN","RCTOPD",60,0)
.S QUIT=1,DEBTOR0=^RCD(340,DEBTOR,0),DEBTOR6=^(6),DEBTOR4=^(4),FILE=$$FILE(DEBTOR0),EFFDT=$P(DEBTOR4,U,6),RCNEW=0
"RTN","RCTOPD",61,0)
.D EN1^RCTOP2(DEBTOR,"U",FILE)
"RTN","RCTOPD",62,0)
.D PROC(DEBTOR,.QUIT,FILE,0,.EFFDT) I QUIT D Q
"RTN","RCTOPD",63,0)
..;process type 4 document if necessary
"RTN","RCTOPD",64,0)
..S TAXID=$$TAXID^RCTOP1(DEBTOR,FILE),OTAXID=$P(DEBTOR4,U)
"RTN","RCTOPD",65,0)
..S NAME=$$NAME^RCTOP1(+DEBTOR0,FILE),ONAME=$P(DEBTOR4,U,2),NAME=$P(NAME,U)
"RTN","RCTOPD",66,0)
..I NAME=ONAME,TAXID=OTAXID Q
"RTN","RCTOPD",67,0)
..D EN1^RCTOP4(NAME,TAXID,DEBTOR4,DEBTOR,FILE)
"RTN","RCTOPD",68,0)
..Q
"RTN","RCTOPD",69,0)
.D EN1^RCTOP1(DEBTOR,TOTAL,"U",EFFDT,0,FILE)
"RTN","RCTOPD",70,0)
.Q
"RTN","RCTOPD",71,0)
;refund/refund reversal documents
"RTN","RCTOPD",72,0)
D REFDOC
"RTN","RCTOPD",73,0)
;compile documents into mail messages--sets referral date in 430
"RTN","RCTOPD",74,0)
D:$G(RCDOC)="U" COMPILE
"RTN","RCTOPD",75,0)
Q
"RTN","RCTOPD",76,0)
;
"RTN","RCTOPD",77,0)
RECERT ;send yearly recertification documents
"RTN","RCTOPD",78,0)
F S DEBTOR=$O(^RCD(340,"TOP",DEBTOR)) Q:DEBTOR'?1N.N D
"RTN","RCTOPD",79,0)
.S DEBTOR4=$G(^RCD(340,DEBTOR,4)),TOTAL=$P(DEBTOR4,U,3),EFFDT=$P(DEBTOR4,U,6),DEBTOR0=$G(^(0)),FILE=$$FILE(DEBTOR0)
"RTN","RCTOPD",80,0)
.I TOTAL D EN1^RCTOP1(DEBTOR,TOTAL,"Y",EFFDT,0,FILE)
"RTN","RCTOPD",81,0)
.Q
"RTN","RCTOPD",82,0)
;compile documents into mail messages
"RTN","RCTOPD",83,0)
D COMPILE
"RTN","RCTOPD",84,0)
Q
"RTN","RCTOPD",85,0)
;
"RTN","RCTOPD",86,0)
REFDOC ; refund, refund reversal documents
"RTN","RCTOPD",87,0)
N CODE,BILL,DEBTOR,TOTAL,EFFDT,FILE,RFCODE
"RTN","RCTOPD",88,0)
F RFCODE=1,3 S CODE=$S(RFCODE=1:"R",1:"RV") D
"RTN","RCTOPD",89,0)
.S BILL=0 F S BILL=$O(^PRCA(430,"TREF",RFCODE,BILL)) Q:'BILL D
"RTN","RCTOPD",90,0)
..S DEBTOR=$P($G(^PRCA(430,BILL,0)),U,9) Q:'DEBTOR
"RTN","RCTOPD",91,0)
..S TOTAL=$P($G(^(7)),U,18) Q:'TOTAL ;NAKED TO LINE ABOVE
"RTN","RCTOPD",92,0)
..S EFFDT=$P($G(^RCD(340,+DEBTOR,4)),U,6),FILE=$$FILE(^(0))
"RTN","RCTOPD",93,0)
..D EN1^RCTOP1(DEBTOR,TOTAL,CODE,EFFDT,BILL,FILE)
"RTN","RCTOPD",94,0)
..Q
"RTN","RCTOPD",95,0)
.Q
"RTN","RCTOPD",96,0)
Q
"RTN","RCTOPD",97,0)
;
"RTN","RCTOPD",98,0)
COMPILE ;compiles documents into mail messages and transmits them
"RTN","RCTOPD",99,0)
;builds message array
"RTN","RCTOPD",100,0)
N CNT,SEQ,REC,XMDUZ,DOCTYPE,LRTYPE,XMSUB,XMTEXT,XMY,TSEQ,DOCAMT
"RTN","RCTOPD",101,0)
S (SEQ,TSEQ)=0
"RTN","RCTOPD",102,0)
F I=1,2,4 S TSEQ=TSEQ+($G(CNTR(I))\150)+$S($G(CNTR(I))#150:1,1:0)
"RTN","RCTOPD",103,0)
F DOCTYPE=1,2,4 D:$D(^XTMP("RCTOPD",$J,DOCTYPE)) COMPILE1(DOCTYPE,CNTR(DOCTYPE))
"RTN","RCTOPD",104,0)
D USRMSG
"RTN","RCTOPD",105,0)
Q
"RTN","RCTOPD",106,0)
COMPILE1(DOCTYPE,CNTR) ; compiles each type of document separately
"RTN","RCTOPD",107,0)
S RCNT=RCNT+CNTR
"RTN","RCTOPD",108,0)
I '$G(LRTYPE) F I=1,2,4 S:$D(^XTMP("RCTOPD",$J,I)) LRTYPE=I
"RTN","RCTOPD",109,0)
F CNT=1:1:CNTR D
"RTN","RCTOPD",110,0)
.D:CNT#150=1
"RTN","RCTOPD",111,0)
..K ^XTMP("RCTOPD",$J,"BUILD") S SEQ=SEQ+1
"RTN","RCTOPD",112,0)
..S REC=1,DOCAMT=0
"RTN","RCTOPD",113,0)
..Q
"RTN","RCTOPD",114,0)
.S REC=REC+1,^XTMP("RCTOPD",$J,"BUILD",REC)=^XTMP("RCTOPD",$J,DOCTYPE,CNT)_U S:DOCTYPE=1 DOCAMT=DOCAMT+($E(^(REC),135,146)/100)
"RTN","RCTOPD",115,0)
.I CNTR=CNT,LRTYPE=DOCTYPE S ^XTMP("RCTOPD",$J,"BUILD",REC+1)="END OF TRANSMISSION FOR SITE# "_SITE_": TOTAL RECORDS: "_RCNT
"RTN","RCTOPD",116,0)
.I $S(CNTR=CNT:1,CNT#150=0:1,1:0) D
"RTN","RCTOPD",117,0)
..S ^XTMP("RCTOPD",$J,"BUILD",1)=SITE_U_$TR($J(SEQ,2)," ",0)_U_$TR($J(TSEQ,2)," ",0)_U_(REC-1)_U_DOCAMT_U
"RTN","RCTOPD",118,0)
..S XMDUZ="AR PACKAGE"
"RTN","RCTOPD",119,0)
..S XMY("XXX@
DNS ")=""
"RTN","RCTOPD",120,0)
..S XMY("G.TOP")=""
"RTN","RCTOPD",121,0)
..S XMSUB=SITE_"/TOP TRANSMISSION/SEQ#: "_SEQ_"/"_$$NOW()
"RTN","RCTOPD",122,0)
..S XMTEXT="^XTMP(""RCTOPD"","_$J_",""BUILD"","
"RTN","RCTOPD",123,0)
..D ^XMD
"RTN","RCTOPD",124,0)
..Q
"RTN","RCTOPD",125,0)
.Q
"RTN","RCTOPD",126,0)
Q
"RTN","RCTOPD",127,0)
;
"RTN","RCTOPD",128,0)
USRMSG ;sends mailman message of documents sent to user
"RTN","RCTOPD",129,0)
N XMY,XMDUZ,XMSUB,X,RCNT
"RTN","RCTOPD",130,0)
S XMDUZ="AR PACKAGE",XMY("G.TOP")=""
"RTN","RCTOPD",131,0)
S XMSUB="TOP "_$S(RCDOC="M":"MASTER/UPDATE",RCDOC="U":"UPDATE",1:"RECERTIFICATION")_" RECORDS SENT ON "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
"RTN","RCTOPD",132,0)
S ^XTMP("RCTOPD",$J,"REC1",1)="Name TIN TYPE AMOUNT"
"RTN","RCTOPD",133,0)
S ^XTMP("RCTOPD",$J,"REC1",2)="---- --- ---- ------"
"RTN","RCTOPD",134,0)
S X="",RCNT=3 F S X=$O(^XTMP("RCTOPD",$J,"REC",X)) Q:X="" S ^XTMP("RCTOPD",$J,"REC1",RCNT)=^(X),RCNT=RCNT+1
"RTN","RCTOPD",135,0)
S ^XTMP("RCTOPD",$J,"REC1",RCNT)="Total Records: "_(RCNT-3)
"RTN","RCTOPD",136,0)
S XMTEXT="^XTMP(""RCTOPD"","_$J_",""REC1"","
"RTN","RCTOPD",137,0)
D ^XMD
"RTN","RCTOPD",138,0)
;
"RTN","RCTOPD",139,0)
THIRD ;sends mailman message to user if no third letter found
"RTN","RCTOPD",140,0)
Q:'$D(^XTMP("RCTOPD",$J,"THIRD"))
"RTN","RCTOPD",141,0)
K ^XTMP("RCTOPD",$J,"REC1")
"RTN","RCTOPD",142,0)
S XMDUZ="AR PACKAGE",XMY("G.TOP")=""
"RTN","RCTOPD",143,0)
N TCT,TDEB,TDEB0,TBIL,TSP,FST
"RTN","RCTOPD",144,0)
S XMSUB="TOP QUALIFIED/NO 3RD LETTER SENT ON "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
"RTN","RCTOPD",145,0)
S ^XTMP("RCTOPD",$J,"REC1",1)="The following list of debtor bills were not sent to TOP."
"RTN","RCTOPD",146,0)
S ^XTMP("RCTOPD",$J,"REC1",2)="Please review debtor's account to determine why the third"
"RTN","RCTOPD",147,0)
S ^XTMP("RCTOPD",$J,"REC1",3)="notice letter has not been sent:"
"RTN","RCTOPD",148,0)
S ^XTMP("RCTOPD",$J,"REC1",4)="Name Bill #"
"RTN","RCTOPD",149,0)
S ^XTMP("RCTOPD",$J,"REC1",5)="---- ------"
"RTN","RCTOPD",150,0)
S TCT=6,TSP=0,TDEB=""
"RTN","RCTOPD",151,0)
F S TDEB=$O(^XTMP("RCTOPD",$J,"THIRD",TDEB)) Q:TDEB="" D
"RTN","RCTOPD",152,0)
.S FST=1,TBIL=""
"RTN","RCTOPD",153,0)
.I FST,TCT'=6 S ^XTMP("RCTOPD",$J,"REC1",TCT)="",TCT=TCT+1,TSP=TSP+1
"RTN","RCTOPD",154,0)
.F S TBIL=$O(^XTMP("RCTOPD",$J,"THIRD",TDEB,TBIL)) Q:TBIL="" D
"RTN","RCTOPD",155,0)
..S TDEB0=$S(FST:TDEB,1:"")
"RTN","RCTOPD",156,0)
..S ^XTMP("RCTOPD",$J,"REC1",TCT)=TDEB0_$J(" ",35-$L(TDEB0))_TBIL
"RTN","RCTOPD",157,0)
..S TCT=TCT+1,FST=0
"RTN","RCTOPD",158,0)
S ^XTMP("RCTOPD",$J,"REC1",TCT)="Total records: "_(TCT-(6+TSP))
"RTN","RCTOPD",159,0)
S XMTEXT="^XTMP(""RCTOPD"","_$J_",""REC1"","
"RTN","RCTOPD",160,0)
D ^XMD
"RTN","RCTOPD",161,0)
COMPQ Q
"RTN","RCTOPD",162,0)
;
"RTN","RCTOPD",163,0)
PROC(DEBTOR,QUIT,FILE,HOLD,EFFDT) ;process bills for a specific debtor
"RTN","RCTOPD",164,0)
K ^TMP("RCTOPD",$J,"BILL")
"RTN","RCTOPD",165,0)
S DEBTOR0=$G(^RCD(340,DEBTOR,0))
"RTN","RCTOPD",166,0)
Q:'FILE
"RTN","RCTOPD",167,0)
I FILE=2 S DFN=+DEBTOR0 D DEM^VADPT Q:$E(VADM(2),1,5)="00000"
"RTN","RCTOPD",168,0)
S (BILL,TOTAL,REPAY)=0
"RTN","RCTOPD",169,0)
I RCNEW,FILE=440 S HOLD=1
"RTN","RCTOPD",170,0)
I 'RCNEW,$P(^RCD(340,DEBTOR,6),U,2),'$P(^(6),U,3) G TOTAL
"RTN","RCTOPD",171,0)
I RCNEW,$D(^RCD(340,"DMC",1,DEBTOR)) G TOTAL
"RTN","RCTOPD",172,0)
F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D
"RTN","RCTOPD",173,0)
.I FILE=2,+VADM(6) S TOTAL=0,REPAY=1 Q
"RTN","RCTOPD",174,0)
.S B0=$G(^PRCA(430,BILL,0)),B4=$G(^(4)),B6=$G(^(6)),B7=$G(^(7)),B14=$G(^(14))
"RTN","RCTOPD",175,0)
.Q:$P(B0,U,8)'=16
"RTN","RCTOPD",176,0)
.Q:B4
"RTN","RCTOPD",177,0)
.Q:'$P(B0,U,2)
"RTN","RCTOPD",178,0)
.S CAT=$P($G(^PRCA(430.2,$P(B0,U,2),0)),U,7)
"RTN","RCTOPD",179,0)
.;*** PRCA*4.5*338 start
"RTN","RCTOPD",180,0)
.Q:'CAT
"RTN","RCTOPD",181,0)
.;Check the Refer to TOP field to see if this should be referred, based on AR Category
"RTN","RCTOPD",182,0)
.S BILLDT=$P(B6,U,21)
"RTN","RCTOPD",183,0)
.Q:'$$RFCHK(CAT,"N",1.02,BILLDT) ;PRCA*4.5*338
"RTN","RCTOPD",184,0)
.;*** PRCA*4.5*338 end
"RTN","RCTOPD",185,0)
.Q:$D(^PRCA(430,"TCSP",BILL)) ;cross-serviced bills
"RTN","RCTOPD",186,0)
.;check for DOJ referral here
"RTN","RCTOPD",187,0)
.I $P(B6,U,4),($P(B6,U,5)="DOJ") Q
"RTN","RCTOPD",188,0)
.I (BILLDT<P10YDT)!(BILLDT>P121DT)!(BILLDT<$P(DEBTOR6,U,3)) Q
"RTN","RCTOPD",189,0)
.I '$P(B6,U,3) D Q
"RTN","RCTOPD",190,0)
..;no 3rd letter being sent
"RTN","RCTOPD",191,0)
..N TDEB,TFIL
"RTN","RCTOPD",192,0)
..S TDEB=$G(^RCD(340,DEBTOR,0)),TFIL=$$FILE(TDEB),TDEB=$$NAME^RCTOP1(+TDEB,TFIL),TDEB=$P(TDEB,U,2),^XTMP("RCTOPD",$J,"THIRD",TDEB,$P(B0,U))=""
"RTN","RCTOPD",193,0)
.I RCNEW,CAT>12,CAT<15 S HOLD=1
"RTN","RCTOPD",194,0)
.I BILLDT,BILLDT<EFFDT S EFFDT=BILLDT
"RTN","RCTOPD",195,0)
.S TOTAL=TOTAL+$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5)
"RTN","RCTOPD",196,0)
.S ^TMP("RCTOPD",$J,"BILL",BILL)=""
"RTN","RCTOPD",197,0)
.Q
"RTN","RCTOPD",198,0)
;
"RTN","RCTOPD",199,0)
TOTAL ;set transmission total, reset quit variable
"RTN","RCTOPD",200,0)
N RCSWINFO S RCSWINFO=$$SWSTAT^IBBAPI() ;PRCA*4.5*229
"RTN","RCTOPD",201,0)
I RCNEW,'+RCSWINFO Q:TOTAL<25 ;PRCA*4.5*229
"RTN","RCTOPD",202,0)
I RCNEW,+RCSWINFO Q:TOTAL'>0 ;PRCA*4.5*229
"RTN","RCTOPD",203,0)
;
"RTN","RCTOPD",204,0)
I 'RCNEW S:TOTAL<25 TOTAL=0 S CURRTOT=$P($G(^RCD(340,DEBTOR,4)),U,3) Q:CURRTOT=TOTAL S TOTAL=TOTAL-CURRTOT
"RTN","RCTOPD",205,0)
S QUIT=0
"RTN","RCTOPD",206,0)
PROCQ Q
"RTN","RCTOPD",207,0)
;
"RTN","RCTOPD",208,0)
NOW() ;compiles current date,time
"RTN","RCTOPD",209,0)
N X,Y,%,%H
"RTN","RCTOPD",210,0)
S %H=$H D YX^%DTC
"RTN","RCTOPD",211,0)
Q Y
"RTN","RCTOPD",212,0)
;
"RTN","RCTOPD",213,0)
FILE(DEBTOR0) ;gets file number for debtor
"RTN","RCTOPD",214,0)
S FILE=$P($P(DEBTOR0,U),";",2)
"RTN","RCTOPD",215,0)
S FILE=$S(FILE["DPT(":2,FILE["PRC(440":440,FILE["VA(200":200,1:0)
"RTN","RCTOPD",216,0)
FILEQ Q FILE
"RTN","RCTOPD",217,0)
;
"RTN","RCTOPD",218,0)
;PRCA*4.5*338
"RTN","RCTOPD",219,0)
RFCHK(RCXCAT,RCIENFLG,RCXRFCD,RCXDT) ;Check to see if bill can be referred to requested collections program
"RTN","RCTOPD",220,0)
;
"RTN","RCTOPD",221,0)
;Input:
"RTN","RCTOPD",222,0)
; RCXCAT - (Required) AR Category to check.
"RTN","RCTOPD",223,0)
; RCXIENFLG - Is the AR Category an IEN (I) or a number (N).
"RTN","RCTOPD",224,0)
; RCXRFCD - (Required) FileMan Field number for the Referral type being checked.
"RTN","RCTOPD",225,0)
; 1.01 - DMC
"RTN","RCTOPD",226,0)
; 1.02 - TOP
"RTN","RCTOPD",227,0)
; 1.03 - CS
"RTN","RCTOPD",228,0)
; RCXDT - (Required) Date of service to be checked.
"RTN","RCTOPD",229,0)
;
"RTN","RCTOPD",230,0)
N RCXFLG,RCXCTIEN,RCXSPDT
"RTN","RCTOPD",231,0)
;
"RTN","RCTOPD",232,0)
; Set the initial split date for the TOP and CS referral programs
"RTN","RCTOPD",233,0)
S RCXSPDT=3150801
"RTN","RCTOPD",234,0)
; Get the category IEN.
"RTN","RCTOPD",235,0)
S RCXCTIEN=RCXCAT ;Initially assume it is an IEN
"RTN","RCTOPD",236,0)
; Update to IEN if AR Category is the Category Number
"RTN","RCTOPD",237,0)
I RCIENFLG="N" S RCXCTIEN=$O(^PRCA(430.2,"AC",RCXCAT,""))
"RTN","RCTOPD",238,0)
; Quit if Category not found
"RTN","RCTOPD",239,0)
Q:RCXCTIEN="" 0
"RTN","RCTOPD",240,0)
;
"RTN","RCTOPD",241,0)
; Extract the flag for the category from the AR Category file (430.2), using the field number sent in
"RTN","RCTOPD",242,0)
S RCXCTIEN=RCXCTIEN_","
"RTN","RCTOPD",243,0)
S RCXFLG=$$GET1^DIQ(430.2,RCXCTIEN,RCXRFCD,"I")
"RTN","RCTOPD",244,0)
I RCXFLG<2 Q RCXFLG
"RTN","RCTOPD",245,0)
I RCXFLG=2,(RCXDT<RCXSPDT) Q 1
"RTN","RCTOPD",246,0)
I RCXFLG=3,(RCXDT'<RCXSPDT) Q 1
"RTN","RCTOPD",247,0)
Q 0
"RTN","RCXFMSC1")
0^27^B23554655
"RTN","RCXFMSC1",1,0)
RCXFMSC1 ;WISC/RFJ-fms cash receipt (cr) build lines ;1 Oct 97
"RTN","RCXFMSC1",2,0)
;;4.5;Accounts Receivable;**90,96,106,113,135,98,173,220,338**;Mar 20, 1995;Build 70
"RTN","RCXFMSC1",3,0)
;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","RCXFMSC1",4,0)
Q
"RTN","RCXFMSC1",5,0)
;
"RTN","RCXFMSC1",6,0)
;
"RTN","RCXFMSC1",7,0)
FMSLINES(RECEIPDA,RCTR) ; receipda is the ien for the receipt in file 344
"RTN","RCXFMSC1",8,0)
; return total(fund,revsrce,vendorid,fmstrantype) = dollar amount
"RTN","RCXFMSC1",9,0)
; RCTR = 1 if extracting for a TR document, null or 0 if for CR
"RTN","RCXFMSC1",10,0)
;
"RTN","RCXFMSC1",11,0)
N %,ACCRUAL,AMOUNT,BILLDA,CATEGORY,FMSTYPE,FUND,RECEIPT,REVSRCE
"RTN","RCXFMSC1",12,0)
N TRAN0,TRAN3,TRANDA,VENDORID,RECEFT,RCEDILB,Z
"RTN","RCXFMSC1",13,0)
;
"RTN","RCXFMSC1",14,0)
S RCEDILB=$$EDILB^RCDPEU(RECEIPDA),RCTR=$G(RCTR)
"RTN","RCXFMSC1",15,0)
S RECEFT=$S(RCEDILB=1:1,1:"") ; EFT deposit CR doc
"RTN","RCXFMSC1",16,0)
S RECEIPT=$P($G(^RCY(344,RECEIPDA,0)),"^")
"RTN","RCXFMSC1",17,0)
I RECEIPT="" Q
"RTN","RCXFMSC1",18,0)
;
"RTN","RCXFMSC1",19,0)
S TRANDA=0 F S TRANDA=$O(^PRCA(433,"AF",RECEIPT,TRANDA)) Q:'TRANDA D
"RTN","RCXFMSC1",20,0)
. S TRAN0=$G(^PRCA(433,TRANDA,0)),TRAN3=$G(^PRCA(433,TRANDA,3))
"RTN","RCXFMSC1",21,0)
. S CATEGORY=$P($G(^PRCA(430,+$P(TRAN0,"^",2),0)),"^",2)
"RTN","RCXFMSC1",22,0)
. S BILLDA=+$P(TRAN0,"^",2)
"RTN","RCXFMSC1",23,0)
. ;
"RTN","RCXFMSC1",24,0)
. ; do not send champva
"RTN","RCXFMSC1",25,0)
. I CATEGORY=29 D Q
"RTN","RCXFMSC1",26,0)
. . ;PRCA*4.5*338 get fund only if not defined
"RTN","RCXFMSC1",27,0)
. . S FUND=$$GET1^DIQ(430,BILLDA_",",203)
"RTN","RCXFMSC1",28,0)
. . I FUND="" S FUND=$$GETFUNDB^RCXFMSUF(BILLDA)
"RTN","RCXFMSC1",29,0)
. . ;end PRCA*4.5*338
"RTN","RCXFMSC1",30,0)
. . D SETTMP
"RTN","RCXFMSC1",31,0)
. ;
"RTN","RCXFMSC1",32,0)
. S ACCRUAL=$$ACCK^PRCAACC(BILLDA)
"RTN","RCXFMSC1",33,0)
. ;
"RTN","RCXFMSC1",34,0)
. ; if its not an accrual, send a detail document
"RTN","RCXFMSC1",35,0)
. I 'ACCRUAL D Q
"RTN","RCXFMSC1",36,0)
. . S FMSTYPE=$$GETTYPE(BILLDA,RCTR)
"RTN","RCXFMSC1",37,0)
. . I FMSTYPE="" S FMSTYPE="XX" ; make it reject if missing
"RTN","RCXFMSC1",38,0)
. . ; send a detail document only if there is principal
"RTN","RCXFMSC1",39,0)
. . I $P(TRAN3,"^") S DETAIL(FMSTYPE,BILLDA)=$G(DETAIL(FMSTYPE,BILLDA))+$P(TRAN3,"^")
"RTN","RCXFMSC1",40,0)
. . ; set tmp global which is used by the 215 report
"RTN","RCXFMSC1",41,0)
. . ;PRCA*4.5*338 get fund only if not defined
"RTN","RCXFMSC1",42,0)
. . S FUND=$$GET1^DIQ(430,BILLDA_",",203)
"RTN","RCXFMSC1",43,0)
. . I FUND="" S FUND=$$GETFUNDB^RCXFMSUF(BILLDA,,RECEFT)
"RTN","RCXFMSC1",44,0)
. . ;end PRCA*4.5*338
"RTN","RCXFMSC1",45,0)
. . D SETTMP
"RTN","RCXFMSC1",46,0)
. . ;
"RTN","RCXFMSC1",47,0)
. . ; look for interest and admin charges
"RTN","RCXFMSC1",48,0)
. . ; use vendorid x for totals
"RTN","RCXFMSC1",49,0)
. . S VENDORID="MISCN"
"RTN","RCXFMSC1",50,0)
. . ; get the revenue source code for the bill
"RTN","RCXFMSC1",51,0)
. . S REVSRCE=$$CALCRSC^RCXFMSUR(BILLDA,RECEFT)
"RTN","RCXFMSC1",52,0)
. . D INTADMIN
"RTN","RCXFMSC1",53,0)
. ;
"RTN","RCXFMSC1",54,0)
. ; get the fund for the bill
"RTN","RCXFMSC1",55,0)
. ;PRCA*4.5*338 get fund only if not defined
"RTN","RCXFMSC1",56,0)
. S FUND=$$GET1^DIQ(430,BILLDA_",",203)
"RTN","RCXFMSC1",57,0)
. I FUND="" S FUND=$$GETFUNDB^RCXFMSUF(BILLDA,,RECEFT)
"RTN","RCXFMSC1",58,0)
. ;end PRCA*4.5*338
"RTN","RCXFMSC1",59,0)
. ;
"RTN","RCXFMSC1",60,0)
. ; get the vendor id $p(2) for the bill
"RTN","RCXFMSC1",61,0)
. S VENDORID=$S(FUND=528709:"EXCFVALUE",FUND=4032:"EXCFVALUE",1:"MCCFVALUE")
"RTN","RCXFMSC1",62,0)
. ;
"RTN","RCXFMSC1",63,0)
. ; get the revenue source code for the bill
"RTN","RCXFMSC1",64,0)
. S REVSRCE=$$GET1^DIQ(430,BILLDA_",",255)
"RTN","RCXFMSC1",65,0)
. S:REVSRCE="" REVSRCE=$$GET1^DIQ(430,BILLDA_",",255.1)
"RTN","RCXFMSC1",66,0)
. S:REVSRCE="" REVSRCE=$$CALCRSC^RCXFMSUR(BILLDA) ; (as per CURRENT^RCRJRCOC)
"RTN","RCXFMSC1",67,0)
. ;
"RTN","RCXFMSC1",68,0)
. ; get the principle collected, $p(tran3,"^"), if prepayment
"RTN","RCXFMSC1",69,0)
. ; set it to 1;5 with no interest, admin, etc.
"RTN","RCXFMSC1",70,0)
. I CATEGORY=26 S TRAN3=$P($G(^PRCA(433,TRANDA,1)),"^",5)
"RTN","RCXFMSC1",71,0)
. ;
"RTN","RCXFMSC1",72,0)
. ; total principal
"RTN","RCXFMSC1",73,0)
. D TOTAL($P(TRAN3,"^"))
"RTN","RCXFMSC1",74,0)
. ;
"RTN","RCXFMSC1",75,0)
. ; set tmp for detail
"RTN","RCXFMSC1",76,0)
. D SETTMP
"RTN","RCXFMSC1",77,0)
. ;
"RTN","RCXFMSC1",78,0)
. ; check for interest collected
"RTN","RCXFMSC1",79,0)
. D INTADMIN
"RTN","RCXFMSC1",80,0)
Q
"RTN","RCXFMSC1",81,0)
;
"RTN","RCXFMSC1",82,0)
;
"RTN","RCXFMSC1",83,0)
INTADMIN ; check for interest and admin charges
"RTN","RCXFMSC1",84,0)
S AMOUNT=$P(TRAN3,"^",2)
"RTN","RCXFMSC1",85,0)
I AMOUNT S FUND=$$GETFUNDO^RCXFMSUF("I") D TOTAL(AMOUNT)
"RTN","RCXFMSC1",86,0)
; check for admin collected
"RTN","RCXFMSC1",87,0)
S AMOUNT=$P(TRAN3,"^",3)
"RTN","RCXFMSC1",88,0)
I AMOUNT S FUND=$$GETFUNDO^RCXFMSUF("A") D TOTAL(AMOUNT)
"RTN","RCXFMSC1",89,0)
; check for marshall fee collected
"RTN","RCXFMSC1",90,0)
S AMOUNT=$P(TRAN3,"^",4)
"RTN","RCXFMSC1",91,0)
I AMOUNT S FUND=$$GETFUNDO^RCXFMSUF("M") D TOTAL(AMOUNT)
"RTN","RCXFMSC1",92,0)
; check for court cost collected
"RTN","RCXFMSC1",93,0)
S AMOUNT=$P(TRAN3,"^",5)
"RTN","RCXFMSC1",94,0)
I AMOUNT S FUND=$$GETFUNDO^RCXFMSUF("C") D TOTAL(AMOUNT)
"RTN","RCXFMSC1",95,0)
Q
"RTN","RCXFMSC1",96,0)
;
"RTN","RCXFMSC1",97,0)
;
"RTN","RCXFMSC1",98,0)
TOTAL(AMOUNT) ; accumulate totals for summary document
"RTN","RCXFMSC1",99,0)
I 'AMOUNT Q
"RTN","RCXFMSC1",100,0)
; check key elements and if null set to X's to reject
"RTN","RCXFMSC1",101,0)
I FUND="" S FUND="XXXXXX"
"RTN","RCXFMSC1",102,0)
I REVSRCE="" S REVSRCE="XXXX"
"RTN","RCXFMSC1",103,0)
I VENDORID="" S VENDORID="XXXXX"
"RTN","RCXFMSC1",104,0)
;
"RTN","RCXFMSC1",105,0)
S TOTAL(FUND,REVSRCE,VENDORID)=$G(TOTAL(FUND,REVSRCE,VENDORID))+AMOUNT
"RTN","RCXFMSC1",106,0)
Q
"RTN","RCXFMSC1",107,0)
;
"RTN","RCXFMSC1",108,0)
;
"RTN","RCXFMSC1",109,0)
SETTMP ; set the tmp global for detailed data by bill
"RTN","RCXFMSC1",110,0)
; the tmp global is used by the 215 report (rcy215a)
"RTN","RCXFMSC1",111,0)
I FUND="" S FUND="XXXXXX"
"RTN","RCXFMSC1",112,0)
;
"RTN","RCXFMSC1",113,0)
S %=$G(^TMP($J,"RCFMSCR",FUND,BILLDA))
"RTN","RCXFMSC1",114,0)
S $P(%,"^",1)=$P(%,"^",1)+$P(TRAN3,"^",1) ; principal
"RTN","RCXFMSC1",115,0)
S $P(%,"^",2)=$P(%,"^",2)+$P(TRAN3,"^",2) ; interest
"RTN","RCXFMSC1",116,0)
S $P(%,"^",3)=$P(%,"^",3)+$P(TRAN3,"^",3) ; admin
"RTN","RCXFMSC1",117,0)
S $P(%,"^",4)=$P(%,"^",4)+$P(TRAN3,"^",4) ; marshal fee
"RTN","RCXFMSC1",118,0)
S $P(%,"^",5)=$P(%,"^",5)+$P(TRAN3,"^",5) ; court cost
"RTN","RCXFMSC1",119,0)
S ^TMP($J,"RCFMSCR",FUND,BILLDA)=%
"RTN","RCXFMSC1",120,0)
Q
"RTN","RCXFMSC1",121,0)
;
"RTN","RCXFMSC1",122,0)
;
"RTN","RCXFMSC1",123,0)
GETTYPE(BILLDA,RCTR) ; return a bills fms transaction type (which goes on the CRA code
"RTN","RCXFMSC1",124,0)
; sheet) from the field 259 refund/reimbursement in file 430.
"RTN","RCXFMSC1",125,0)
; If RCTR = 1, return TR code, otherwise return CR code
"RTN","RCXFMSC1",126,0)
N REFUND
"RTN","RCXFMSC1",127,0)
S RCTR=$S($G(RCTR):7,1:3) ; CR code is in piece 3 of data, TR is in pc 7
"RTN","RCXFMSC1",128,0)
S REFUND=$$RECTYP^PRCAFUT(BILLDA)
"RTN","RCXFMSC1",129,0)
I REFUND<0 S REFUND=""
"RTN","RCXFMSC1",130,0)
I $L(REFUND)=1 S REFUND="0"_REFUND
"RTN","RCXFMSC1",131,0)
; this call gets the transaction type from file 347.4
"RTN","RCXFMSC1",132,0)
S REFUND=$$DTYPE^PRCAFBD1(REFUND)
"RTN","RCXFMSC1",133,0)
I REFUND<0 S REFUND=""
"RTN","RCXFMSC1",134,0)
Q $S($P(REFUND,"^",RCTR)'="":$P(REFUND,"^",RCTR),1:REFUND)
"RTN","RCXFMSC1",135,0)
;
"RTN","RCXFMSC1",136,0)
;
"RTN","RCXFMSC1",137,0)
LINE(BILLDA) ;
"RTN","RCXFMSC1",138,0)
;returns FMS line number
"RTN","RCXFMSC1",139,0)
N X
"RTN","RCXFMSC1",140,0)
S X=$P($G(^PRCA(430,BILLDA,11)),"^",4)
"RTN","RCXFMSC1",141,0)
I X="" S X="001"
"RTN","RCXFMSC1",142,0)
Q X
"RTN","RCXFMSPR")
0^6^B75044670
"RTN","RCXFMSPR",1,0)
RCXFMSPR ;WISC/RFJ-print revenue source codes ;8/31/10 11:34am
"RTN","RCXFMSPR",2,0)
;;4.5;Accounts Receivable;**90,96,101,156,170,203,273,310,315,338**;Mar 20, 1995;Build 70
"RTN","RCXFMSPR",3,0)
;Per VA Directive 6402, this routine should not be modified.
"RTN","RCXFMSPR",4,0)
W !,"This option will print out a list of the revenue source codes sent from"
"RTN","RCXFMSPR",5,0)
W !,"the VISTA system to FMS."
"RTN","RCXFMSPR",6,0)
;
"RTN","RCXFMSPR",7,0)
; select device
"RTN","RCXFMSPR",8,0)
W ! S %ZIS="Q" D ^%ZIS Q:POP
"RTN","RCXFMSPR",9,0)
I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
"RTN","RCXFMSPR",10,0)
. S ZTDESC="Revenue Source Code Report",ZTRTN="DQ^RCXFMSPR"
"RTN","RCXFMSPR",11,0)
. S ZTSAVE("ZTREQ")="@"
"RTN","RCXFMSPR",12,0)
W !!,"<*> please wait <*>"
"RTN","RCXFMSPR",13,0)
;
"RTN","RCXFMSPR",14,0)
DQ ; queue starts here
"RTN","RCXFMSPR",15,0)
N %,%I,BINARY,COL2DESC,COL3DESC,COLUMN1,COLUMN2,COLUMN3,COLUMN4
"RTN","RCXFMSPR",16,0)
N DECIMAL,DESCRIP,NOW,PAGE,RCSTFLAG,SCREEN,X,Y
"RTN","RCXFMSPR",17,0)
D NOW^%DTC S Y=% D DD^%DT S NOW=Y
"RTN","RCXFMSPR",18,0)
S PAGE=1,SCREEN=0 I '$D(ZTQUEUED),IO=IO(0),$E(IOST)="C" S SCREEN=1
"RTN","RCXFMSPR",19,0)
U IO D H
"RTN","RCXFMSPR",20,0)
;
"RTN","RCXFMSPR",21,0)
S COLUMN1="A",COLUMN2="R",COLUMN3="R",COLUMN4="V",DESCRIP="Miscellaneous"
"RTN","RCXFMSPR",22,0)
D WRITEIT
"RTN","RCXFMSPR",23,0)
;
"RTN","RCXFMSPR",24,0)
; for now, column 1 is always 8 and column 4 is always Z
"RTN","RCXFMSPR",25,0)
S COLUMN1=8,COLUMN4="Z"
"RTN","RCXFMSPR",26,0)
F COLUMN2=1:1:9,"A","B","C","D","E","F","G","H","I","J","K","L","M","Q","R","S","T" D Q:$G(RCSTFLAG)
"RTN","RCXFMSPR",27,0)
. S COL2DESC=$P($T(@("A"_COLUMN2)),";",3)
"RTN","RCXFMSPR",28,0)
. ;
"RTN","RCXFMSPR",29,0)
. S COLUMN3=$S(COLUMN2=5:"*",1:"Z")
"RTN","RCXFMSPR",30,0)
. S DESCRIP=COL2DESC D WRITEIT
"RTN","RCXFMSPR",31,0)
. ;
"RTN","RCXFMSPR",32,0)
. I $G(RCSTFLAG) Q
"RTN","RCXFMSPR",33,0)
. ;
"RTN","RCXFMSPR",34,0)
. ; show hsif - disabled by patch 203
"RTN","RCXFMSPR",35,0)
. ;I COLUMN2="B"!(COLUMN2="C") S DESCRIP=DESCRIP_" HSIF",COLUMN3=1 D WRITEIT
"RTN","RCXFMSPR",36,0)
;
"RTN","RCXFMSPR",37,0)
I $G(RCSTFLAG) D Q Q
"RTN","RCXFMSPR",38,0)
;
"RTN","RCXFMSPR",39,0)
; print reimbursable health insurance rsc's
"RTN","RCXFMSPR",40,0)
S COLUMN2=5
"RTN","RCXFMSPR",41,0)
W !!?6,"For REIMBURSABLE HEALTH INSURANCE [85*Z]:"
"RTN","RCXFMSPR",42,0)
F DECIMAL=0:1:31 D Q:$G(RCSTFLAG)
"RTN","RCXFMSPR",43,0)
. I DECIMAL<10 S COLUMN3=DECIMAL
"RTN","RCXFMSPR",44,0)
. E S COLUMN3=$C(65+DECIMAL-10)
"RTN","RCXFMSPR",45,0)
. ;
"RTN","RCXFMSPR",46,0)
. ; convert decimal to binary (ex: 10011) so it can be
"RTN","RCXFMSPR",47,0)
. ; parsed in rsc to get the description
"RTN","RCXFMSPR",48,0)
. S BINARY=$$CONVERT(DECIMAL)
"RTN","RCXFMSPR",49,0)
. S COL3DESC=$P($T(@("B"_$E(BINARY,1,2))),";",3)
"RTN","RCXFMSPR",50,0)
. S COL3DESC=COL3DESC_", "_$P($T(@("C"_$E(BINARY,3))),";",3)
"RTN","RCXFMSPR",51,0)
. S COL3DESC=COL3DESC_", "_$P($T(@("D"_$E(BINARY,4))),";",3)
"RTN","RCXFMSPR",52,0)
. S COL3DESC=COL3DESC_", "_$P($T(@("E"_$E(BINARY,5))),";",3)
"RTN","RCXFMSPR",53,0)
. S DESCRIP=COL3DESC
"RTN","RCXFMSPR",54,0)
. D WRITEIT
"RTN","RCXFMSPR",55,0)
;
"RTN","RCXFMSPR",56,0)
; print fee basis reimbursable health insurance rsc's (PRCA*4.5*310/DRF)
"RTN","RCXFMSPR",57,0)
S COLUMN2="F"
"RTN","RCXFMSPR",58,0)
W !!?6,"For FEE REIMBURSABLE HEALTH INSURANCE [8F*Z]:"
"RTN","RCXFMSPR",59,0)
F DECIMAL=1:1:2 D Q:$G(RCSTFLAG)
"RTN","RCXFMSPR",60,0)
. S DESCRIP="FEE BASIS, NSC VET, MT CAT A, "_$S(DECIMAL=1:"INPATIENT",DECIMAL=2:"OUTPATIENT",1:"")
"RTN","RCXFMSPR",61,0)
. S COLUMN3=DECIMAL
"RTN","RCXFMSPR",62,0)
. D WRITEIT
"RTN","RCXFMSPR",63,0)
;
"RTN","RCXFMSPR",64,0)
; print EMERGENCY/HUMANITARIAN REIMB. PRCA*4.5*315
"RTN","RCXFMSPR",65,0)
; 8VZZ;HUMAN 3RD-PRTY OUTPATIENT
"RTN","RCXFMSPR",66,0)
; 8UZZ;HUMAN 3RD-PRTY INPATIENT
"RTN","RCXFMSPR",67,0)
S COLUMN3="Z"
"RTN","RCXFMSPR",68,0)
W !!?6,"For EMERGENCY/HUMANITARIAN REIMBURSABLE HEALTH INSURANCE [8*ZZ]:"
"RTN","RCXFMSPR",69,0)
F DECIMAL="U","V" D Q:$G(RCSTFLAG)
"RTN","RCXFMSPR",70,0)
. S DESCRIP="EMERGENCY/HUMANITARIAN REIMB. INS., "_$S(DECIMAL="U":"INPATIENT",DECIMAL="V":"OUTPATIENT",1:"")
"RTN","RCXFMSPR",71,0)
. S COLUMN2=DECIMAL
"RTN","RCXFMSPR",72,0)
. D WRITEIT
"RTN","RCXFMSPR",73,0)
;
"RTN","RCXFMSPR",74,0)
; print INELIGIBLE HOSP. REIMB. PRCA*4.5*315
"RTN","RCXFMSPR",75,0)
; 841Z;INELI 3RD-PARTY INPATIENT
"RTN","RCXFMSPR",76,0)
; 842Z;INELI 3RD-PARTY OUTPATIENT
"RTN","RCXFMSPR",77,0)
S COLUMN2="4"
"RTN","RCXFMSPR",78,0)
W !!?6,"For INELIGIBLE HOSPITAL REIMBURSABLE HEALTH INSURANCE [84*Z]:"
"RTN","RCXFMSPR",79,0)
F DECIMAL=1,2 D Q:$G(RCSTFLAG)
"RTN","RCXFMSPR",80,0)
. S DESCRIP="INELIGIBLE HOSP. REIMB. INS., "_$S(DECIMAL=1:"INPATIENT",DECIMAL=2:"OUTPATIENT",1:"")
"RTN","RCXFMSPR",81,0)
. S COLUMN3=DECIMAL
"RTN","RCXFMSPR",82,0)
. D WRITEIT
"RTN","RCXFMSPR",83,0)
Q D ^%ZISC
"RTN","RCXFMSPR",84,0)
; print CCAD rsc's (PRCA*4.5*338)
"RTN","RCXFMSPR",85,0)
N DATA,LOOP
"RTN","RCXFMSPR",86,0)
S (COLUMN2,COLUMN3,COLUMN4)="" ;Clear other columns
"RTN","RCXFMSPR",87,0)
W !!?6,"For COMMUNITY CARE:"
"RTN","RCXFMSPR",88,0)
F LOOP=1:1 S DATA=$T(CCADRSC+LOOP) Q:(DATA="")!($P(DATA,";",3)="END") D Q:$G(RCSTFLAG)
"RTN","RCXFMSPR",89,0)
. S COLUMN1=$P(DATA,";",3),DESCRIP=$P(DATA,";",4)
"RTN","RCXFMSPR",90,0)
. D WRITEIT
"RTN","RCXFMSPR",91,0)
Q
"RTN","RCXFMSPR",92,0)
;
"RTN","RCXFMSPR",93,0)
;
"RTN","RCXFMSPR",94,0)
GETDESC(RSC) ; return the description for the revenue source code
"RTN","RCXFMSPR",95,0)
N BINARY,COL3DESC,COLUMN2,COLUMN3,DESC,RCARY
"RTN","RCXFMSPR",96,0)
;new resource codes for ineligible hosp reimb. and emergency/humanitarian reimb. PRCA*4.5*315
"RTN","RCXFMSPR",97,0)
I RSC="841Z" Q "Ineligible Hosp. Reimb. Ins., Inpatient"
"RTN","RCXFMSPR",98,0)
I RSC="842Z" Q "Ineligible Hosp. Reimb. Ins., Outpatient"
"RTN","RCXFMSPR",99,0)
I RSC="8UZZ" Q "Emergency/Humanitarian Reimb. Ins., Inpatient"
"RTN","RCXFMSPR",100,0)
I RSC="8VZZ" Q "Emergency/Humanitarian Reimb. Ins., Outpatient"
"RTN","RCXFMSPR",101,0)
I RSC="ARRV" Q "Miscellaneous"
"RTN","RCXFMSPR",102,0)
I RSC=8046 Q "Administrative"
"RTN","RCXFMSPR",103,0)
I RSC=8047 Q "Interest"
"RTN","RCXFMSPR",104,0)
I RSC=8048 Q "Marshal Fee and Court Cost"
"RTN","RCXFMSPR",105,0)
;PRCA*4.5*338 - check to see if RSC is a Community Care RSC and add RSCs missing a description.
"RTN","RCXFMSPR",106,0)
I RSC=8000 Q "Non Medical Reimbursements"
"RTN","RCXFMSPR",107,0)
I RSC=8023 Q "Compensated Work Therapy"
"RTN","RCXFMSPR",108,0)
I RSC=8024 Q "Tort Feasor"
"RTN","RCXFMSPR",109,0)
I RSC=8041 Q "FED OWCP"
"RTN","RCXFMSPR",110,0)
F LOOP=1:1 S DATA=$T(CCADRSC+LOOP) Q:(DATA="")!($P(DATA,";",3)="END") D
"RTN","RCXFMSPR",111,0)
. S RCARY($P(DATA,";",3))=$P(DATA,";",4)
"RTN","RCXFMSPR",112,0)
I $G(RCARY(RSC))'="" Q $G(RCARY(RSC))
"RTN","RCXFMSPR",113,0)
;end PRCA*4.5*338
"RTN","RCXFMSPR",114,0)
S DESC="UNKNOWN"
"RTN","RCXFMSPR",115,0)
S COLUMN2=$E(RSC,2)
"RTN","RCXFMSPR",116,0)
I "123456789ABCDEFGHIJKLMQRST"[COLUMN2 S DESC=$P($T(@("A"_COLUMN2)),";",3)
"RTN","RCXFMSPR",117,0)
; HSIF reference disabled by patch 203
"RTN","RCXFMSPR",118,0)
; I RSC="8B1Z"!(RSC="8C1Z") S DESC=DESC_" (HSIF)"
"RTN","RCXFMSPR",119,0)
I COLUMN2'=5 Q DESC
"RTN","RCXFMSPR",120,0)
;
"RTN","RCXFMSPR",121,0)
S COLUMN3=$E(RSC,3)
"RTN","RCXFMSPR",122,0)
; convert alpha letters to decimal
"RTN","RCXFMSPR",123,0)
I "0123456789"'[COLUMN3 S COLUMN3=$A(COLUMN3)-55
"RTN","RCXFMSPR",124,0)
S BINARY=$$CONVERT(COLUMN3)
"RTN","RCXFMSPR",125,0)
S COL3DESC=$P($T(@("B"_$E(BINARY,1,2))),";",3)
"RTN","RCXFMSPR",126,0)
S COL3DESC=COL3DESC_", "_$P($T(@("C"_$E(BINARY,3))),";",3)
"RTN","RCXFMSPR",127,0)
S COL3DESC=COL3DESC_", "_$P($T(@("D"_$E(BINARY,4))),";",3)
"RTN","RCXFMSPR",128,0)
S COL3DESC=COL3DESC_", "_$P($T(@("E"_$E(BINARY,5))),";",3)
"RTN","RCXFMSPR",129,0)
Q "RHI, "_COL3DESC
"RTN","RCXFMSPR",130,0)
;
"RTN","RCXFMSPR",131,0)
;
"RTN","RCXFMSPR",132,0)
CONVERT(DECIMAL) ; convert decimal number to binary (5 digits)
"RTN","RCXFMSPR",133,0)
N Y
"RTN","RCXFMSPR",134,0)
S Y=""
"RTN","RCXFMSPR",135,0)
F S Y=$E("0123456789ABCDEF",DECIMAL#2+1)_Y,DECIMAL=DECIMAL\2 Q:DECIMAL<1
"RTN","RCXFMSPR",136,0)
S Y=$E("00000",0,5-$L(Y))_Y
"RTN","RCXFMSPR",137,0)
Q Y
"RTN","RCXFMSPR",138,0)
;
"RTN","RCXFMSPR",139,0)
;
"RTN","RCXFMSPR",140,0)
WRITEIT ; display the rsc
"RTN","RCXFMSPR",141,0)
W !,COLUMN1,COLUMN2,COLUMN3,COLUMN4,?6,DESCRIP
"RTN","RCXFMSPR",142,0)
I $Y>(IOSL-5) D:SCREEN PAUSE Q:$G(RCSTFLAG) D H
"RTN","RCXFMSPR",143,0)
Q
"RTN","RCXFMSPR",144,0)
;
"RTN","RCXFMSPR",145,0)
;
"RTN","RCXFMSPR",146,0)
PAUSE ; pause at end of page
"RTN","RCXFMSPR",147,0)
N X U IO(0) W !,"Press RETURN to continue, '^' to exit:" R X:DTIME S:'$T X="^" S:X["^" RCSTFLAG=1 U IO
"RTN","RCXFMSPR",148,0)
Q
"RTN","RCXFMSPR",149,0)
;
"RTN","RCXFMSPR",150,0)
;
"RTN","RCXFMSPR",151,0)
H ; header
"RTN","RCXFMSPR",152,0)
S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
"RTN","RCXFMSPR",153,0)
W $C(13),"REVENUE SOURCE CODE REPORT (VISTA TO FMS)",?(80-$L(%)),%
"RTN","RCXFMSPR",154,0)
W !,"RSC",?6,"Description"
"RTN","RCXFMSPR",155,0)
S %="",$P(%,"-",81)=""
"RTN","RCXFMSPR",156,0)
W !,%
"RTN","RCXFMSPR",157,0)
Q
"RTN","RCXFMSPR",158,0)
;
"RTN","RCXFMSPR",159,0)
;
"RTN","RCXFMSPR",160,0)
; this is a listing of all column2 values with a description
"RTN","RCXFMSPR",161,0)
A1 ;;Hospital Care (NSC)
"RTN","RCXFMSPR",162,0)
A2 ;;Outpatient Care (NSC)
"RTN","RCXFMSPR",163,0)
A3 ;;Nursing Home Care (NSC)
"RTN","RCXFMSPR",164,0)
A4 ;;Ineligible Hospitalization
"RTN","RCXFMSPR",165,0)
A5 ;;Reimbursable Health Insurance
"RTN","RCXFMSPR",166,0)
A6 ;;Tort Feasor
"RTN","RCXFMSPR",167,0)
A7 ;;Workmans Compensation (Non-Federal)
"RTN","RCXFMSPR",168,0)
A8 ;;C (Means Test)
"RTN","RCXFMSPR",169,0)
A9 ;;Emergency/Humanitarian
"RTN","RCXFMSPR",170,0)
AA ;;No Fault Auto Accident
"RTN","RCXFMSPR",171,0)
AB ;;Pharmacy Co-Pay (SC Vet)
"RTN","RCXFMSPR",172,0)
AC ;;Pharmacy Co-Pay (NSC Vet)
"RTN","RCXFMSPR",173,0)
AD ;;Nursing Home Care Per Diem
"RTN","RCXFMSPR",174,0)
AE ;;Hospital Care Per Diem
"RTN","RCXFMSPR",175,0)
AF ;;Medicare
"RTN","RCXFMSPR",176,0)
AG ;;Adult Day Health Care (LTC)
"RTN","RCXFMSPR",177,0)
AH ;;Domiciliary (LTC)
"RTN","RCXFMSPR",178,0)
AI ;;Respite Care-Institutional (LTC)
"RTN","RCXFMSPR",179,0)
AJ ;;Respite Care-Non-Institutional (LTC)
"RTN","RCXFMSPR",180,0)
AK ;;Geriatric Eval-Institutional (LTC)
"RTN","RCXFMSPR",181,0)
AL ;;Geriatric Eval-Non-Institutional (LTC)
"RTN","RCXFMSPR",182,0)
AM ;;Nursing Home Care-Long Term Care (LTC)
"RTN","RCXFMSPR",183,0)
AQ ;;Pharmacy No Fault Auto Acc
"RTN","RCXFMSPR",184,0)
AR ;;Pharmacy Reimburs Health Ins
"RTN","RCXFMSPR",185,0)
AS ;;Pharmacy Tort Feasor
"RTN","RCXFMSPR",186,0)
AT ;;Pharmacy Workman's Comp
"RTN","RCXFMSPR",187,0)
;
"RTN","RCXFMSPR",188,0)
;
"RTN","RCXFMSPR",189,0)
; this is a listing for the type of care, first 2 binary digits
"RTN","RCXFMSPR",190,0)
; if column2 is reimbursable health insurance
"RTN","RCXFMSPR",191,0)
B00 ;;Inpatient (Hosp)
"RTN","RCXFMSPR",192,0)
B01 ;;Outpatient
"RTN","RCXFMSPR",193,0)
B10 ;;Nursing Home
"RTN","RCXFMSPR",194,0)
B11 ;;Other
"RTN","RCXFMSPR",195,0)
;
"RTN","RCXFMSPR",196,0)
;
"RTN","RCXFMSPR",197,0)
; this is a listing for the service connected, binary digit 3
"RTN","RCXFMSPR",198,0)
C0 ;;SC for NSC
"RTN","RCXFMSPR",199,0)
C1 ;;NSC Vet
"RTN","RCXFMSPR",200,0)
;
"RTN","RCXFMSPR",201,0)
;
"RTN","RCXFMSPR",202,0)
; this is a listing for means test, binary digit 4
"RTN","RCXFMSPR",203,0)
D0 ;;MT Cat A
"RTN","RCXFMSPR",204,0)
D1 ;;MT Cat C
"RTN","RCXFMSPR",205,0)
;
"RTN","RCXFMSPR",206,0)
;
"RTN","RCXFMSPR",207,0)
; this is a listing for age group, binary digit 5
"RTN","RCXFMSPR",208,0)
E0 ;;Age <65
"RTN","RCXFMSPR",209,0)
E1 ;;Age 65+
"RTN","RCXFMSPR",210,0)
;
"RTN","RCXFMSPR",211,0)
;
"RTN","RCXFMSPR",212,0)
; Community Care RSC listing PRCA*4.5*338
"RTN","RCXFMSPR",213,0)
CCADRSC ;;
"RTN","RCXFMSPR",214,0)
;;8C6C;CC 3rd-Pty Workers' Comp
"RTN","RCXFMSPR",215,0)
;;8C5C;CC 3rd-Pty Tort Feasor
"RTN","RCXFMSPR",216,0)
;;8C4C;CC 3rd-Pty No-Fault Auto
"RTN","RCXFMSPR",217,0)
;;8C1C;CC 3rd-Pty Inpatient
"RTN","RCXFMSPR",218,0)
;;8C2C;CC 3rd-Pty Outpatient
"RTN","RCXFMSPR",219,0)
;;8C3C;CC 3rd-Pty RX
"RTN","RCXFMSPR",220,0)
;;86CC;CC Choice 3rd-Pty Workers' Comp
"RTN","RCXFMSPR",221,0)
;;85CC;CC Choice 3rd-Pty Tort Feasor
"RTN","RCXFMSPR",222,0)
;;84CC;CC Choice 3rd-Pty No-Fault Auto
"RTN","RCXFMSPR",223,0)
;;81CC;CC Choice 3rd-Pty Inpatient
"RTN","RCXFMSPR",224,0)
;;82CC;CC Choice 3rd-Pty Outpatient
"RTN","RCXFMSPR",225,0)
;;83CC;CC Choice 3rd-Pty RX
"RTN","RCXFMSPR",226,0)
;;8CD4;CC DOD 3rd-Pty Inpatient
"RTN","RCXFMSPR",227,0)
;;8CD5;CC DOD 3rd-Pty Outpatient
"RTN","RCXFMSPR",228,0)
;;8CD6;CC DOD 3rd-Pty RX
"RTN","RCXFMSPR",229,0)
;;8CNW;CCN 3rd-Pty Workers' Comp
"RTN","RCXFMSPR",230,0)
;;8CN9;CCN 3rd-Pty Tort Feasor
"RTN","RCXFMSPR",231,0)
;;8CN8;CCN 3rd-Pty No-Fault Auto
"RTN","RCXFMSPR",232,0)
;;8CN5;CCN 3rd-Pty Inpatient
"RTN","RCXFMSPR",233,0)
;;8CN6;CCN 3rd-Pty Outpatient
"RTN","RCXFMSPR",234,0)
;;8CN7;CCN 3rd-Pty RX
"RTN","RCXFMSPR",235,0)
;;8CC1;CC 1st-Pty Inpatient
"RTN","RCXFMSPR",236,0)
;;8CC2;CC 1st-Pty Outpatient
"RTN","RCXFMSPR",237,0)
;;8CC3;CC 1st-Pty RX
"RTN","RCXFMSPR",238,0)
;;8CC4;CC 1st-Pty LTC
"RTN","RCXFMSPR",239,0)
;;8CC5;CC Choice 1st-Pty Inpatient
"RTN","RCXFMSPR",240,0)
;;8CC6;CC Choice 1st-Pty Outpatient
"RTN","RCXFMSPR",241,0)
;;8CC7;CC Choice 1st-Pty RX
"RTN","RCXFMSPR",242,0)
;;8CC8;CC Choice 1st-Pty LTC
"RTN","RCXFMSPR",243,0)
;;8CN1;CCN 1st-Pty Inpatient
"RTN","RCXFMSPR",244,0)
;;8CN2;CCN 1st-Pty Outpatient
"RTN","RCXFMSPR",245,0)
;;8CN3;CCN 1st-Pty RX
"RTN","RCXFMSPR",246,0)
;;8CN4;CCN 1st-Pty LTC
"RTN","RCXFMSPR",247,0)
;;8CD1;CC DOD 1st-Pty Inpatient
"RTN","RCXFMSPR",248,0)
;;8CD2;CC DOD 1st-Pty Outpatient
"RTN","RCXFMSPR",249,0)
;;8CD3;CC DOD 1st-Pty RX
"RTN","RCXFMSPR",250,0)
;;8085;DOD Disability Evaluation System (DES)
"RTN","RCXFMSPR",251,0)
;;8086;DOD Spinal Cord Inpatient
"RTN","RCXFMSPR",252,0)
;;8087;DOD Spinal Cord Outpatient
"RTN","RCXFMSPR",253,0)
;;8088;DOD Spinal Cord Other
"RTN","RCXFMSPR",254,0)
;;8089;Traumatic Brain Injury Inpatient
"RTN","RCXFMSPR",255,0)
;;8090;Traumatic Brain Injury Outpatient
"RTN","RCXFMSPR",256,0)
;;8091;Traumatic Brain Injury Other
"RTN","RCXFMSPR",257,0)
;;8092;Blind Rehabilitation Inpatient
"RTN","RCXFMSPR",258,0)
;;8093;Blind Rehabilitation Outpatient
"RTN","RCXFMSPR",259,0)
;;8094;Blind Rehabilitation Other
"RTN","RCXFMSPR",260,0)
;;8095;TRICARE Pharmacy
"RTN","RCXFMSPR",261,0)
;;8096;TRICARE Active Duty Dental
"RTN","RCXFMSPR",262,0)
;;END
"RTN","RCXFMSUF")
0^2^B57862958
"RTN","RCXFMSUF",1,0)
RCXFMSUF ;WISC/RFJ-calculate fms fund code for a bill ; 10/20/10 10:37am
"RTN","RCXFMSUF",2,0)
;;4.5;Accounts Receivable;**90,101,135,157,160,165,170,203,207,173,211,192,220,235,273,315,338**;Mar 20, 1995;Build 70
"RTN","RCXFMSUF",3,0)
;;Per VA Directive 6402, this routine should not be modifieD
"RTN","RCXFMSUF",4,0)
Q
"RTN","RCXFMSUF",5,0)
;
"RTN","RCXFMSUF",6,0)
;
"RTN","RCXFMSUF",7,0)
GETFUNDO(TYPE) ; return the fund for other type associated collections
"RTN","RCXFMSUF",8,0)
; type can equal:
"RTN","RCXFMSUF",9,0)
; I for interest A for admin
"RTN","RCXFMSUF",10,0)
; M for marshall fee C for court cost
"RTN","RCXFMSUF",11,0)
I TYPE="I" Q "1435"
"RTN","RCXFMSUF",12,0)
I TYPE="A" Q "3220"
"RTN","RCXFMSUF",13,0)
I TYPE="M" Q "0869"
"RTN","RCXFMSUF",14,0)
I TYPE="C" Q "0869"
"RTN","RCXFMSUF",15,0)
Q ""
"RTN","RCXFMSUF",16,0)
;
"RTN","RCXFMSUF",17,0)
;
"RTN","RCXFMSUF",18,0)
GETFUNDB(BILLDA,DONTSTOR,RCEFT) ; return a bills fms fund code
"RTN","RCXFMSUF",19,0)
; pass DONTSTOR equal 1 to prevent storing the fund code
"RTN","RCXFMSUF",20,0)
; cannot rely on data in the fund field since it may reference the
"RTN","RCXFMSUF",21,0)
; old funds S FUND=$P($G(^PRCA(430,BILLDA,11)),"^",17). since there
"RTN","RCXFMSUF",22,0)
; are reports which use 11;17, set it for a bill once its computed
"RTN","RCXFMSUF",23,0)
; until all references to the fund are eliminated.
"RTN","RCXFMSUF",24,0)
; rceft = 1 if processing an EFT deposit
"RTN","RCXFMSUF",25,0)
;
"RTN","RCXFMSUF",26,0)
N ACTDATE,CATEGDA,FUND,NEWFUND
"RTN","RCXFMSUF",27,0)
;
"RTN","RCXFMSUF",28,0)
; calculate a bills fund
"RTN","RCXFMSUF",29,0)
I $G(RCEFT)=1 S FUND="5287"_$S(DT<3030926:"",DT'<3030926&(DT<$$ADDPTEDT^PRCAACC()):".4",1:"04") Q FUND
"RTN","RCXFMSUF",30,0)
S CATEGDA=+$P($G(^PRCA(430,BILLDA,0)),"^",2)
"RTN","RCXFMSUF",31,0)
I CATEGDA>84 Q ""
"RTN","RCXFMSUF",32,0)
;
"RTN","RCXFMSUF",33,0)
; piece 5 is new fund, remove spaces
"RTN","RCXFMSUF",34,0)
S FUND=$P($TR($T(@CATEGDA)," "),";",5)
"RTN","RCXFMSUF",35,0)
;
"RTN","RCXFMSUF",36,0)
; set fund 528711 for 3rd party RX bills after 4/27/2011
"RTN","RCXFMSUF",37,0)
I $$TYP^IBRFN(BILLDA)="PH" D
"RTN","RCXFMSUF",38,0)
. I (CATEGDA=6)!(CATEGDA=7)!(CATEGDA=9)!(CATEGDA=10),$$CHECKRXS(BILLDA) S FUND=528711
"RTN","RCXFMSUF",39,0)
;
"RTN","RCXFMSUF",40,0)
; if category is vendor(17), ex-employee(15), current employee(16)
"RTN","RCXFMSUF",41,0)
; federal agency refund(13), federal agency reimb(14), military(12)
"RTN","RCXFMSUF",42,0)
; set the fund to what is stored in the file. This was entered
"RTN","RCXFMSUF",43,0)
; by the user during the audit process. If fund is in the file
"RTN","RCXFMSUF",44,0)
; already, do not need to store it again.
"RTN","RCXFMSUF",45,0)
; if category is nursing home proceeds (40), parking fees (41),
"RTN","RCXFMSUF",46,0)
; cwt proceeds (42), comp & pen proceeds (43), enhanced use lease
"RTN","RCXFMSUF",47,0)
; proceeds (44), set the fund to what is stored in the file.
"RTN","RCXFMSUF",48,0)
; This was generated by the software at the time of bill enter.
"RTN","RCXFMSUF",49,0)
I CATEGDA=17!(CATEGDA=15)!(CATEGDA=16)!(CATEGDA=13)!(CATEGDA=14)!(CATEGDA=12)!(CATEGDA=40)!(CATEGDA=41)!(CATEGDA=42)!(CATEGDA=43)!(CATEGDA=44) D
"RTN","RCXFMSUF",50,0)
. I $P($G(^PRCA(430,BILLDA,11)),"^",17)'="" S FUND=$P(^(11),"^",17),DONTSTOR=1
"RTN","RCXFMSUF",51,0)
;
"RTN","RCXFMSUF",52,0)
; public law states that bills in the category ineligible (1),
"RTN","RCXFMSUF",53,0)
; emerg/human (2), torts (10), or medicare (21) which are older
"RTN","RCXFMSUF",54,0)
; than oct 1, 1992 should be reported under fund 3220.
"RTN","RCXFMSUF",55,0)
I CATEGDA=1!(CATEGDA=2)!(CATEGDA=10)!(CATEGDA=21) D
"RTN","RCXFMSUF",56,0)
. S ACTDATE=$P($G(^PRCA(430,BILLDA,6)),"^",21)
"RTN","RCXFMSUF",57,0)
. I ACTDATE,ACTDATE<2921001 S FUND=3220 Q
"RTN","RCXFMSUF",58,0)
. ;
"RTN","RCXFMSUF",59,0)
. ; patch157 changes ineligibles. an ineligible activated before
"RTN","RCXFMSUF",60,0)
. ; oct 1, 1992 or after sep 30, 2000 will be recorded in fund 0160A1.
"RTN","RCXFMSUF",61,0)
. ; otherwise it will be recorded in fund 5287.3 if before 3040928
"RTN","RCXFMSUF",62,0)
. ; if 3040928 or after, fund should be 528703
"RTN","RCXFMSUF",63,0)
. I CATEGDA=1,ACTDATE,ACTDATE<3001001 S FUND=$S(DT<$$ADDPTEDT^PRCAACC():"5287.3",1:528703)
"RTN","RCXFMSUF",64,0)
;
"RTN","RCXFMSUF",65,0)
; set the fund for the bill
"RTN","RCXFMSUF",66,0)
; PRCA*4.5*310/DRF Add Non-VA fund 528713
"RTN","RCXFMSUF",67,0)
;
"RTN","RCXFMSUF",68,0)
I $G(DONTSTOR)'=1 D STORE^RCXFMSUR(BILLDA,"",FUND)
"RTN","RCXFMSUF",69,0)
;
"RTN","RCXFMSUF",70,0)
; PRCA*4.5*338 Added funds for Community Care
"RTN","RCXFMSUF",71,0)
I FUND>528704,FUND<528709!(FUND=528710)!(FUND=528711) Q FUND
"RTN","RCXFMSUF",72,0)
I FUND=528713 Q FUND
"RTN","RCXFMSUF",73,0)
I FUND=528714 Q FUND
"RTN","RCXFMSUF",74,0)
;
"RTN","RCXFMSUF",75,0)
I $G(REPRODT),REPRODT<3030926,$E(FUND,1,4)=5287 Q 5287
"RTN","RCXFMSUF",76,0)
I $G(REPRODT),REPRODT<3031001,$E(FUND,1,4)=5287,$G(REFMS) Q 5287
"RTN","RCXFMSUF",77,0)
I DT<3030926,$E(FUND,1,4)=5287 Q 5287 ; Effective date
"RTN","RCXFMSUF",78,0)
I $G(REPRODT),REPRODT<$$ADDPTEDT^PRCAACC(),FUND=528709 Q 4032 ;Effective date-528709
"RTN","RCXFMSUF",79,0)
I $G(REPRODT),REPRODT<3041001,FUND=528709,$G(REFMS) Q 4032 ;Resubmitted documents not held
"RTN","RCXFMSUF",80,0)
I $G(DATEEND),$E(DATEEND,2,5)<"0410",FUND=528709 Q 4032
"RTN","RCXFMSUF",81,0)
I DT<$$ADDPTEDT^PRCAACC(),FUND=528709 Q 4032
"RTN","RCXFMSUF",82,0)
I $G(REPRODT),REPRODT<$$ADDPTEDT^PRCAACC(),FUND=528701 Q 5287.1 ;Effective date-528701
"RTN","RCXFMSUF",83,0)
I $G(REPRODT),REPRODT<3041001,FUND=528701,$G(REFMS) Q 5287.1 ;Resubmitted documents not held
"RTN","RCXFMSUF",84,0)
I $G(DATEEND),$E(DATEEND,2,5)<"0410",FUND=528701 Q 5287.1
"RTN","RCXFMSUF",85,0)
I DT<$$ADDPTEDT^PRCAACC(),FUND=528701 Q 5287.1
"RTN","RCXFMSUF",86,0)
I $G(REPRODT),REPRODT<$$ADDPTEDT^PRCAACC(),FUND=528703 Q 5287.3 ;Effective date-528703
"RTN","RCXFMSUF",87,0)
I $G(REPRODT),REPRODT<3041001,FUND=528703,$G(REFMS) Q 5287.3 ;Resubmitted documents not held
"RTN","RCXFMSUF",88,0)
I $G(DATEEND),$E(DATEEND,2,5)<"0410",FUND=528703 Q 5287.3
"RTN","RCXFMSUF",89,0)
I DT<$$ADDPTEDT^PRCAACC(),FUND=528703 Q 5287.3
"RTN","RCXFMSUF",90,0)
I $G(REPRODT),REPRODT<$$ADDPTEDT^PRCAACC(),FUND=528704 Q 5287.4 ;Effective date-528704
"RTN","RCXFMSUF",91,0)
I $G(REPRODT),REPRODT<3041001,FUND=528704,$G(REFMS) Q 5287.4 ;Resubmitted documents not held
"RTN","RCXFMSUF",92,0)
I $G(DATEEND),$E(DATEEND,2,5)<"0410",FUND=528704 Q 5287.4
"RTN","RCXFMSUF",93,0)
I DT<$$ADDPTEDT^PRCAACC(),FUND=528704 Q 5287.4
"RTN","RCXFMSUF",94,0)
Q FUND
"RTN","RCXFMSUF",95,0)
;
"RTN","RCXFMSUF",96,0)
CHECKRXS(BILLDA) ; returns true (1) if bill has any scripts on or after 4/27/11
"RTN","RCXFMSUF",97,0)
N RXNUM,NEWFUND,FILLDT,ARRXS
"RTN","RCXFMSUF",98,0)
S NEWFUND=0
"RTN","RCXFMSUF",99,0)
D SET^IBCSC5A(BILLDA,.ARRXS,)
"RTN","RCXFMSUF",100,0)
S RXNUM=0,FILLDT=""
"RTN","RCXFMSUF",101,0)
F S RXNUM=$O(ARRXS(RXNUM)) Q:RXNUM'>0!(NEWFUND) D
"RTN","RCXFMSUF",102,0)
. S FILLDT=$O(ARRXS(RXNUM,0))
"RTN","RCXFMSUF",103,0)
. I FILLDT'<3110427 S NEWFUND=1
"RTN","RCXFMSUF",104,0)
Q NEWFUND
"RTN","RCXFMSUF",105,0)
;
"RTN","RCXFMSUF",106,0)
; this is a listing of all categories and associated funds
"RTN","RCXFMSUF",107,0)
; the label is from the internal entry number in the category
"RTN","RCXFMSUF",108,0)
; file 430.2. piece 3 is a description, piece 4 is the old fund,
"RTN","RCXFMSUF",109,0)
; piece 5 is the new fund
"RTN","RCXFMSUF",110,0)
; PRCA*4.5*310/DRF Added 45 - FEE REIMB INS to routine.
"RTN","RCXFMSUF",111,0)
0 ;;no fund ; ;
"RTN","RCXFMSUF",112,0)
1 ;;INELIGIBLE HOSP. ;3220 ;0160R1
"RTN","RCXFMSUF",113,0)
2 ;;EMERGENCY/HUMANITARIAN ;0160A1 ;528703
"RTN","RCXFMSUF",114,0)
3 ;;NURSING HOME CARE(NSC) ;2431 ;528703
"RTN","RCXFMSUF",115,0)
4 ;;OUTPATIENT CARE(NSC) ;2431 ;528703
"RTN","RCXFMSUF",116,0)
5 ;;HOSPITAL CARE (NSC) ;2431 ;528703
"RTN","RCXFMSUF",117,0)
6 ;;WORKMAN'S COMP. ;5014 ;528704
"RTN","RCXFMSUF",118,0)
7 ;;NO-FAULT AUTO ACC. ;5014 ;528704
"RTN","RCXFMSUF",119,0)
8 ;;CRIME OF PER.VIO. ;5014 ;528704
"RTN","RCXFMSUF",120,0)
9 ;;REIMBURS.HEALTH INS. ;5014 ;528704
"RTN","RCXFMSUF",121,0)
10 ;;TORT FEASOR ;0160A1 ;528704
"RTN","RCXFMSUF",122,0)
11 ;;no entry ; ;
"RTN","RCXFMSUF",123,0)
12 ;;MILITARY ;0160A1 ;0160R1
"RTN","RCXFMSUF",124,0)
13 ;;FEDERAL AGENCIES-REFUND ;0160A1 ;0160A1
"RTN","RCXFMSUF",125,0)
14 ;;FEDERAL AGENCIES-REIMB. ;0160R1 ;0160R1
"RTN","RCXFMSUF",126,0)
15 ;;EX-EMPLOYEE ;0160A1 ;0160A1
"RTN","RCXFMSUF",127,0)
16 ;;CURRENT EMP. ;0160A1 ;0160A1
"RTN","RCXFMSUF",128,0)
17 ;;VENDOR ;0160A1 ;0160A1
"RTN","RCXFMSUF",129,0)
18 ;;C (MEANS TEST) ;2431 ;528703
"RTN","RCXFMSUF",130,0)
19 ;;SHARING AGREEMENTS ;0160A1 ;0160R1
"RTN","RCXFMSUF",131,0)
20 ;;INTERAGENCY ;0160A1 ;0160R1
"RTN","RCXFMSUF",132,0)
21 ;;MEDICARE ;5014 ;528704
"RTN","RCXFMSUF",133,0)
22 ;;RX CO-PAYMENT/SC VET ;5014 ;528701
"RTN","RCXFMSUF",134,0)
23 ;;RX CO-PAYMENT/NSC VET ;5014 ;528701
"RTN","RCXFMSUF",135,0)
24 ;;NURSING HOME CARE PER DIEM ;2431 ;528703
"RTN","RCXFMSUF",136,0)
25 ;;HOSPITAL CARE PER DIEM ;2431 ;528703
"RTN","RCXFMSUF",137,0)
26 ;;PREPAYMENT ;5014 ;528703
"RTN","RCXFMSUF",138,0)
27 ;;CHAMPVA SUBSISTENCE ;3220 ;3220
"RTN","RCXFMSUF",139,0)
28 ;;CHAMPVA THIRD PARTY ;3220 ;0160R1
"RTN","RCXFMSUF",140,0)
29 ;;CHAMPVA ;0160A1 ;0160R1
"RTN","RCXFMSUF",141,0)
30 ;;TRICARE ;0160A1 ;0160R1
"RTN","RCXFMSUF",142,0)
31 ;;TRICARE PATIENT ;0160A1 ;0160R1
"RTN","RCXFMSUF",143,0)
32 ;;TRICARE THIRD PARTY ;0160A1 ;0160R1
"RTN","RCXFMSUF",144,0)
33 ;;ADULT DAY HEALTH CARE ;4032 ;528709
"RTN","RCXFMSUF",145,0)
34 ;;DOMICILIARY ;4032 ;528709
"RTN","RCXFMSUF",146,0)
35 ;;RESPITE CARE-INSTITUTIONAL ;4032 ;528709
"RTN","RCXFMSUF",147,0)
36 ;;RESPITE CARE-NON-INSTITUTIONAL;4032 ;528709
"RTN","RCXFMSUF",148,0)
37 ;;GERIATRIC EVAL-INSTITUTIONAL ;4032 ;528709
"RTN","RCXFMSUF",149,0)
38 ;;GERIATRIC EVAL-NON-INSTITUTION;4032 ;528709
"RTN","RCXFMSUF",150,0)
39 ;;NURSING HOME CARE-LTC ;4032 ;528709
"RTN","RCXFMSUF",151,0)
40 ;;NURSING HOME PROCEEDS ; ;528705
"RTN","RCXFMSUF",152,0)
41 ;;PARKING FEES ; ;528706
"RTN","RCXFMSUF",153,0)
42 ;;CWT PROCEEDS ; ;528707
"RTN","RCXFMSUF",154,0)
43 ;;COMP & PEN PROCEEDS ; ;528708
"RTN","RCXFMSUF",155,0)
44 ;;ENHANCED USE LEASE PROCEEDS ;5358.3 ;528710
"RTN","RCXFMSUF",156,0)
45 ;;FEE REIMB INS ; ;528713
"RTN","RCXFMSUF",157,0)
46 ;;EMERGENCY/HUMANITARIAN REIMB. ; ;528704 ;315
"RTN","RCXFMSUF",158,0)
47 ;;INELIGIBLE REIMB. INS. ; ;0160R1 ;315
"RTN","RCXFMSUF",159,0)
48 ;;CHOICE THIRD PARTY ; ;528713
"RTN","RCXFMSUF",160,0)
49 ;;CC THIRD PARTY ; ;528713
"RTN","RCXFMSUF",161,0)
50 ;;CCN THIRD PARTY ; ;528713
"RTN","RCXFMSUF",162,0)
51 ;;CC MTF THIRD PARTY ; ;528713
"RTN","RCXFMSUF",163,0)
52 ;;CHOICE NO-FAULT AUTO ; ;528713
"RTN","RCXFMSUF",164,0)
53 ;;CHOICE TORT FEASOR ; ;528713
"RTN","RCXFMSUF",165,0)
54 ;;CCN WORKERS' COMP ; ;528713
"RTN","RCXFMSUF",166,0)
55 ;;CCN NO-FAULT AUTO ; ;528713
"RTN","RCXFMSUF",167,0)
56 ;;CCN TORT FEASOR ; ;528713
"RTN","RCXFMSUF",168,0)
57 ;;CC WORKERS' COMP ; ;528713
"RTN","RCXFMSUF",169,0)
58 ;;CC NO-FAULT AUTO ; ;528713
"RTN","RCXFMSUF",170,0)
59 ;;CC TORT FEASOR ; ;528713
"RTN","RCXFMSUF",171,0)
60 ;;CHOICE WORKERS' COMP ; ;528713
"RTN","RCXFMSUF",172,0)
61 ;;CHOICE INPT ; ;528714
"RTN","RCXFMSUF",173,0)
62 ;;CHOICE RX CO-PAYMENT ; ;528714
"RTN","RCXFMSUF",174,0)
63 ;;CC INPT ; ;528714
"RTN","RCXFMSUF",175,0)
64 ;;CC RX CO-PAYMENT ; ;528714
"RTN","RCXFMSUF",176,0)
65 ;;CCN INPT ; ;528714
"RTN","RCXFMSUF",177,0)
66 ;;CCN RX CO-PAYMENT ; ;528714
"RTN","RCXFMSUF",178,0)
67 ;;CC MTF INPT ; ;528714
"RTN","RCXFMSUF",179,0)
68 ;;CC MTF RX CO-PAYMENT ; ;528714
"RTN","RCXFMSUF",180,0)
69 ;;CC NURSING HOME CARE - LTC ; ;528714
"RTN","RCXFMSUF",181,0)
70 ;;CC RESPITE CARE ; ;528714
"RTN","RCXFMSUF",182,0)
71 ;;CCN NURSING HOME CARE - LTC ; ;528714
"RTN","RCXFMSUF",183,0)
72 ;;CCN RESPITE CARE ; ;528714
"RTN","RCXFMSUF",184,0)
73 ;;CHOICE NURSING HOME CARE - LTC ; ;528714
"RTN","RCXFMSUF",185,0)
74 ;;CHOICE RESPITE CARE ; ;528714
"RTN","RCXFMSUF",186,0)
75 ;;TRICARE DES ; ;0160R1
"RTN","RCXFMSUF",187,0)
76 ;;TRICARE SCI ; ;0160R1
"RTN","RCXFMSUF",188,0)
77 ;;TRICARE TBI ; ;0160R1
"RTN","RCXFMSUF",189,0)
78 ;;TRICARE BLIND REHABILITATION ; ;0160R1
"RTN","RCXFMSUF",190,0)
79 ;;TRICARE DENTAL ; ;0160R1
"RTN","RCXFMSUF",191,0)
80 ;;TRICARE PHARMACY ; ;0160R1
"RTN","RCXFMSUF",192,0)
81 ;;CHOICE OPT ; ;528714
"RTN","RCXFMSUF",193,0)
82 ;;CC OPT ; ;528714
"RTN","RCXFMSUF",194,0)
83 ;;CCN OPT ; ;528714
"RTN","RCXFMSUF",195,0)
84 ;;CC MTF OPT ; ;528714
"RTN","RCXFMSUR")
0^1^B118788042
"RTN","RCXFMSUR",1,0)
RCXFMSUR ;WISC/RFJ-revenue source codes ;10/19/10 1:47pm
"RTN","RCXFMSUR",2,0)
;;4.5;Accounts Receivable;**90,101,170,203,173,220,231,273,310,315,338**;Mar 20, 1995;Build 70
"RTN","RCXFMSUR",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCXFMSUR",4,0)
;Read ^DGCR(399) via IA 3820
"RTN","RCXFMSUR",5,0)
Q
"RTN","RCXFMSUR",6,0)
;
"RTN","RCXFMSUR",7,0)
;
"RTN","RCXFMSUR",8,0)
CALCRSC(BILLDA,RCEFT) ; calculate the revenue source code for a bill
"RTN","RCXFMSUR",9,0)
; rceft = 1 if processing an EFT deposit
"RTN","RCXFMSUR",10,0)
; returns the 4 column (character) rsc
"RTN","RCXFMSUR",11,0)
N CATEGDA,COLUMN1,COLUMN2,COLUMN3,COLUMN4,RSC
"RTN","RCXFMSUR",12,0)
; if rsc already calculated, return it
"RTN","RCXFMSUR",13,0)
I $G(RCEFT)=1 S RSC="8NZZ" Q RSC
"RTN","RCXFMSUR",14,0)
S RSC=$P($G(^PRCA(430,BILLDA,11)),"^",23)
"RTN","RCXFMSUR",15,0)
I $L(RSC)=4,RSC'="ARRV" Q RSC
"RTN","RCXFMSUR",16,0)
;
"RTN","RCXFMSUR",17,0)
; calculate it and store it
"RTN","RCXFMSUR",18,0)
S CATEGDA=+$P($G(^PRCA(430,BILLDA,0)),"^",2)
"RTN","RCXFMSUR",19,0)
;
"RTN","RCXFMSUR",20,0)
;PRCA$4.5*338 If a Community Care Category, retrieve RSC, store it and exit.
"RTN","RCXFMSUR",21,0)
I CATEGDA>47,(CATEGDA<75) D Q RSC
"RTN","RCXFMSUR",22,0)
. S RSC=$$GETCCRSC(CATEGDA,BILLDA)
"RTN","RCXFMSUR",23,0)
. D STORE(BILLDA,RSC)
"RTN","RCXFMSUR",24,0)
I CATEGDA>80,(CATEGDA<85) D Q RSC
"RTN","RCXFMSUR",25,0)
. S RSC=$$GETCCRSC(CATEGDA,BILLDA)
"RTN","RCXFMSUR",26,0)
. D STORE(BILLDA,RSC)
"RTN","RCXFMSUR",27,0)
;
"RTN","RCXFMSUR",28,0)
; if prepayment, send ARRV
"RTN","RCXFMSUR",29,0)
I CATEGDA=26 D STORE(BILLDA,"ARRV") Q "ARRV"
"RTN","RCXFMSUR",30,0)
;
"RTN","RCXFMSUR",31,0)
S COLUMN1=$$COLUMN1
"RTN","RCXFMSUR",32,0)
;
"RTN","RCXFMSUR",33,0)
; check for 3rd party RX bills after 4/27/2011 for col 2
"RTN","RCXFMSUR",34,0)
N RX3P S RX3P=0
"RTN","RCXFMSUR",35,0)
I ("PH"=$$TYP^IBRFN(BILLDA)) D
"RTN","RCXFMSUR",36,0)
. S RX3P=$$CHECKRXS^RCXFMSUF(BILLDA)
"RTN","RCXFMSUR",37,0)
;
"RTN","RCXFMSUR",38,0)
S COLUMN2=$$COLUMN2
"RTN","RCXFMSUR",39,0)
;
"RTN","RCXFMSUR",40,0)
; if column2 cannot be determined, return the rsc of ARRV
"RTN","RCXFMSUR",41,0)
I COLUMN2="" D STORE(BILLDA,"ARRV") Q "ARRV"
"RTN","RCXFMSUR",42,0)
;
"RTN","RCXFMSUR",43,0)
; if column2 is not a 5 for reimbursable health insurance, or category not 45 (FEE REIMB INS)
"RTN","RCXFMSUR",44,0)
; return ZZ in columns 3 and 4
"RTN","RCXFMSUR",45,0)
I COLUMN2'=5,CATEGDA'=45 D STORE(BILLDA,COLUMN1_COLUMN2_"ZZ") Q COLUMN1_COLUMN2_"ZZ"
"RTN","RCXFMSUR",46,0)
;
"RTN","RCXFMSUR",47,0)
; for reimbursable health insurance, compute columns 3 and 4
"RTN","RCXFMSUR",48,0)
S COLUMN3=$$COLUMN3
"RTN","RCXFMSUR",49,0)
S COLUMN4=$$COLUMN4
"RTN","RCXFMSUR",50,0)
;
"RTN","RCXFMSUR",51,0)
D STORE(BILLDA,COLUMN1_COLUMN2_COLUMN3_COLUMN4)
"RTN","RCXFMSUR",52,0)
Q COLUMN1_COLUMN2_COLUMN3_COLUMN4
"RTN","RCXFMSUR",53,0)
;
"RTN","RCXFMSUR",54,0)
;
"RTN","RCXFMSUR",55,0)
STORE(DA,RSC,FUND) ; store the revenue source code or fund in the file
"RTN","RCXFMSUR",56,0)
I $G(^PRCA(430,DA,0))="" Q
"RTN","RCXFMSUR",57,0)
N D,D0,DI,DIC,DIE,DQ,DR,X,Y
"RTN","RCXFMSUR",58,0)
S DR=""
"RTN","RCXFMSUR",59,0)
I $G(RSC)'="" S DR="255.1////"_RSC_";"
"RTN","RCXFMSUR",60,0)
I $G(FUND)'="" S DR=DR_"203////"_FUND_";"
"RTN","RCXFMSUR",61,0)
S (DIC,DIE)="^PRCA(430,"
"RTN","RCXFMSUR",62,0)
D ^DIE
"RTN","RCXFMSUR",63,0)
Q
"RTN","RCXFMSUR",64,0)
;
"RTN","RCXFMSUR",65,0)
;
"RTN","RCXFMSUR",66,0)
COLUMN1() ; return column 1 number
"RTN","RCXFMSUR",67,0)
Q 8
"RTN","RCXFMSUR",68,0)
;
"RTN","RCXFMSUR",69,0)
;
"RTN","RCXFMSUR",70,0)
COLUMN2() ; return column 2 number
"RTN","RCXFMSUR",71,0)
I CATEGDA=5 Q 1 ; hospital care (nsc)
"RTN","RCXFMSUR",72,0)
I CATEGDA=4 Q 2 ; outpatient care (nsc)
"RTN","RCXFMSUR",73,0)
I CATEGDA=3 Q 3 ; nursing home care (nsc)
"RTN","RCXFMSUR",74,0)
I CATEGDA=1 Q 4 ; ineligible hospital
"RTN","RCXFMSUR",75,0)
I CATEGDA=9&$G(RX3P) Q "R" ; pharmacy reimbursable health insurance
"RTN","RCXFMSUR",76,0)
I CATEGDA=9 Q 5 ; reimbursable health insurance
"RTN","RCXFMSUR",77,0)
I CATEGDA=10&$G(RX3P) Q "S" ; pharmacy tort feasor
"RTN","RCXFMSUR",78,0)
I CATEGDA=10 Q 6 ; tort feasor
"RTN","RCXFMSUR",79,0)
I CATEGDA=6&$G(RX3P) Q "T" ;pharmacy workman's comp
"RTN","RCXFMSUR",80,0)
I CATEGDA=6 Q 7 ; workmans comp
"RTN","RCXFMSUR",81,0)
I CATEGDA=18 Q 8 ; c (means test)
"RTN","RCXFMSUR",82,0)
I CATEGDA=2 Q 9 ; emergency/humanitarian
"RTN","RCXFMSUR",83,0)
I CATEGDA=7&$G(RX3P) Q "Q" ;pharmacy no fault auto acc
"RTN","RCXFMSUR",84,0)
I CATEGDA=7 Q "A" ; no fault auto accident
"RTN","RCXFMSUR",85,0)
I CATEGDA=22 Q "B" ; rx copay/sc vet
"RTN","RCXFMSUR",86,0)
I CATEGDA=23 Q "C" ; rx copay/nsc vet
"RTN","RCXFMSUR",87,0)
I CATEGDA=24 Q "D" ; nursing home care per diem
"RTN","RCXFMSUR",88,0)
I CATEGDA=25 Q "E" ; hospital care per diem
"RTN","RCXFMSUR",89,0)
I CATEGDA=21 Q "F" ; medicare
"RTN","RCXFMSUR",90,0)
I CATEGDA=33 Q "G" ; adult day health care
"RTN","RCXFMSUR",91,0)
I CATEGDA=34 Q "H" ; domiciliary
"RTN","RCXFMSUR",92,0)
I CATEGDA=35 Q "I" ; respite care - institutional
"RTN","RCXFMSUR",93,0)
I CATEGDA=36 Q "J" ; respite care - non-institutional
"RTN","RCXFMSUR",94,0)
I CATEGDA=37 Q "K" ; geriatric evaluation - institutional
"RTN","RCXFMSUR",95,0)
I CATEGDA=38 Q "L" ; geriatric evaluation - non-institutional
"RTN","RCXFMSUR",96,0)
I CATEGDA=39 Q "M" ; nursing home care - ltc
"RTN","RCXFMSUR",97,0)
I CATEGDA=45 Q "F" ; Fee Basis
"RTN","RCXFMSUR",98,0)
I CATEGDA=46 D Q COLUMN2
"RTN","RCXFMSUR",99,0)
. N COL
"RTN","RCXFMSUR",100,0)
. D DIQ399(BILLDA)
"RTN","RCXFMSUR",101,0)
. S COL=$G(IBCNDATA(399,BILLDA,.05,"I"))
"RTN","RCXFMSUR",102,0)
. S COLUMN2=$S(COL=1:"U",COL=2:"U",COL=3:"V",1:"V")
"RTN","RCXFMSUR",103,0)
Q ""
"RTN","RCXFMSUR",104,0)
;
"RTN","RCXFMSUR",105,0)
;
"RTN","RCXFMSUR",106,0)
COLUMN3() ; return the column 3 number
"RTN","RCXFMSUR",107,0)
N AGE,DECIMAL,DFN,IBCNDATA,TYPEAGE,TYPECARE,TYPEMEAN,TYPESERV,VA,VADM,VAERR
"RTN","RCXFMSUR",108,0)
;
"RTN","RCXFMSUR",109,0)
D DIQ399(BILLDA)
"RTN","RCXFMSUR",110,0)
;
"RTN","RCXFMSUR",111,0)
; PRCA*4.5*310/DRF
"RTN","RCXFMSUR",112,0)
; for Fee Basis, column3 = 1 (inpatient) or 2 (outpatient)
"RTN","RCXFMSUR",113,0)
I CATEGDA=45 S COLUMN3=$S($G(IBCNDATA(399,BILLDA,.05,"I"))=1:1,$G(IBCNDATA(399,BILLDA,.05,"I"))=2:2,1:2) Q COLUMN3
"RTN","RCXFMSUR",114,0)
;
"RTN","RCXFMSUR",115,0)
D TYPECARE
"RTN","RCXFMSUR",116,0)
;
"RTN","RCXFMSUR",117,0)
; compute service connected at time of care (1 digit binary)
"RTN","RCXFMSUR",118,0)
; type of service connected is set as follows:
"RTN","RCXFMSUR",119,0)
; 0 = SC Vet 1 = NSC Vet
"RTN","RCXFMSUR",120,0)
S TYPESERV=1
"RTN","RCXFMSUR",121,0)
; service connected at time of care (.18) = yes (1)
"RTN","RCXFMSUR",122,0)
I $G(IBCNDATA(399,BILLDA,.18,"I"))=1 S TYPESERV=0
"RTN","RCXFMSUR",123,0)
;
"RTN","RCXFMSUR",124,0)
S DFN=$P($G(^PRCA(430,BILLDA,0)),"^",7)
"RTN","RCXFMSUR",125,0)
D DEM^VADPT
"RTN","RCXFMSUR",126,0)
;
"RTN","RCXFMSUR",127,0)
; compute means test at time of care (1 digit binary)
"RTN","RCXFMSUR",128,0)
; type of means test is set as follows:
"RTN","RCXFMSUR",129,0)
; 0 = Cat A 1 = Cat C
"RTN","RCXFMSUR",130,0)
S TYPEMEAN=0
"RTN","RCXFMSUR",131,0)
I $$BIL^DGMTUB(DFN,$G(IBCNDATA(399,BILLDA,151,"I")))=1 S TYPEMEAN=1
"RTN","RCXFMSUR",132,0)
;
"RTN","RCXFMSUR",133,0)
; compute patient age at time of care (1 digit binary)
"RTN","RCXFMSUR",134,0)
; type of age is set as follows:
"RTN","RCXFMSUR",135,0)
; 0 = under 65 1 = 65 and older
"RTN","RCXFMSUR",136,0)
S AGE=$$FMDIFF^XLFDT($G(IBCNDATA(399,BILLDA,151,"I")),$P($G(VADM(3)),"^"))\365.25
"RTN","RCXFMSUR",137,0)
S TYPEAGE=1
"RTN","RCXFMSUR",138,0)
I AGE<65 S TYPEAGE=0
"RTN","RCXFMSUR",139,0)
;
"RTN","RCXFMSUR",140,0)
; convert to decimal typecare typeserv typemean typeage
"RTN","RCXFMSUR",141,0)
; binary= 1 1 1 1 1
"RTN","RCXFMSUR",142,0)
; decimal= 16 + 8 + 4 + 2 + 1
"RTN","RCXFMSUR",143,0)
S DECIMAL=$S(TYPECARE="11":24,TYPECARE="10":16,TYPECARE="01":8,1:0)
"RTN","RCXFMSUR",144,0)
I TYPESERV S DECIMAL=DECIMAL+4
"RTN","RCXFMSUR",145,0)
I TYPEMEAN S DECIMAL=DECIMAL+2
"RTN","RCXFMSUR",146,0)
I TYPEAGE S DECIMAL=DECIMAL+1
"RTN","RCXFMSUR",147,0)
I DECIMAL<10 Q DECIMAL
"RTN","RCXFMSUR",148,0)
Q $C(65+DECIMAL-10)
"RTN","RCXFMSUR",149,0)
;
"RTN","RCXFMSUR",150,0)
;
"RTN","RCXFMSUR",151,0)
COLUMN4() ; return the column 4 number (reserved for future expansion)
"RTN","RCXFMSUR",152,0)
Q "Z"
"RTN","RCXFMSUR",153,0)
;
"RTN","RCXFMSUR",154,0)
;
"RTN","RCXFMSUR",155,0)
DIQ399(DA) ; get data from file 399
"RTN","RCXFMSUR",156,0)
N D0,DIC,DIQ,DIQ2,DR
"RTN","RCXFMSUR",157,0)
K IBCNDATA
"RTN","RCXFMSUR",158,0)
S DIQ(0)="IE",DIC="^DGCR(399,",DIQ="IBCNDATA",DR=".04;.05;.18;151;" D EN^DIQ1
"RTN","RCXFMSUR",159,0)
Q
"RTN","RCXFMSUR",160,0)
;
"RTN","RCXFMSUR",161,0)
;
"RTN","RCXFMSUR",162,0)
TYPECARE ; compute type of care (2 digit binary)
"RTN","RCXFMSUR",163,0)
; type of care is set as follows:
"RTN","RCXFMSUR",164,0)
; 00 = inpatient (hospital) 01 = outpatient
"RTN","RCXFMSUR",165,0)
; 10 = nursing home 11 = other
"RTN","RCXFMSUR",166,0)
; default is other if it cannot be computed
"RTN","RCXFMSUR",167,0)
S TYPECARE="11"
"RTN","RCXFMSUR",168,0)
; bill classification (.05) = outpatient (3) or human.emerg(opt) (4)
"RTN","RCXFMSUR",169,0)
I $G(IBCNDATA(399,BILLDA,.05,"I"))=3!($G(IBCNDATA(399,BILLDA,.05,"I"))=4) S TYPECARE="01" Q
"RTN","RCXFMSUR",170,0)
; location of care (.04) = hospital inpt or outpt (1)
"RTN","RCXFMSUR",171,0)
I $G(IBCNDATA(399,BILLDA,.04,"I"))=1 S TYPECARE="00" Q
"RTN","RCXFMSUR",172,0)
; location of care (.04) = skilled nursing (nhcu) (2)
"RTN","RCXFMSUR",173,0)
I $G(IBCNDATA(399,BILLDA,.04,"I"))=2 S TYPECARE="10"
"RTN","RCXFMSUR",174,0)
Q
"RTN","RCXFMSUR",175,0)
;
"RTN","RCXFMSUR",176,0)
;
"RTN","RCXFMSUR",177,0)
ADDEDIT ; enter/edit revenue source codes for fund 0160A1 bills. These
"RTN","RCXFMSUR",178,0)
; bills have the rsc entered by the user. The user can select
"RTN","RCXFMSUR",179,0)
; from rscs in file 347.3
"RTN","RCXFMSUR",180,0)
W !!,"This option should be used with CAUTION. This option will allow the"
"RTN","RCXFMSUR",181,0)
W !,"user owning the PRCASVC supervisor security key, to add or edit the"
"RTN","RCXFMSUR",182,0)
W !,"Revenue Source Codes selectable for non MCCF bills. If an invalid"
"RTN","RCXFMSUR",183,0)
W !,"Revenue Source Code is entered or changed, all code sheets sent to"
"RTN","RCXFMSUR",184,0)
W !,"FMS referencing the invalid Revenue Source Code will reject. Be"
"RTN","RCXFMSUR",185,0)
W !,"cautious when entering new Revenue Source Codes or editing existing"
"RTN","RCXFMSUR",186,0)
W !,"Revenue Source Codes. New Revenue Source Codes should only be added"
"RTN","RCXFMSUR",187,0)
W !,"after they have been added in FMS."
"RTN","RCXFMSUR",188,0)
;
"RTN","RCXFMSUR",189,0)
I '$D(^XUSEC("PRCASVC",DUZ)) W !!,"You are not an owner of the PRCASVC security key." Q
"RTN","RCXFMSUR",190,0)
;
"RTN","RCXFMSUR",191,0)
N %,%Y,C,D,D0,DA,DI,DIC,DIE,DLAYGO,DQ,DR,RCRJFLAG,X,X1,X2,X3,Y
"RTN","RCXFMSUR",192,0)
;
"RTN","RCXFMSUR",193,0)
F D Q:$G(RCRJFLAG)
"RTN","RCXFMSUR",194,0)
. S (DIC,DIE)="^RC(347.3,",DIC(0)="QEL",DLAYGO=347.3
"RTN","RCXFMSUR",195,0)
. R !!,"Select REVENUE SOURCE CODE: ",X:DTIME
"RTN","RCXFMSUR",196,0)
. S X1=X,X=$$UPPER^VALM1(X)
"RTN","RCXFMSUR",197,0)
. I $E(X)="?",X?."?" D ^DIC Q:Y<1
"RTN","RCXFMSUR",198,0)
. I X=""!($E(X)=U) S RCRJFLAG=1 Q
"RTN","RCXFMSUR",199,0)
. I $D(^RC(347.3,"B",X)) S Y=+$O(^(X,0)) W " ",X," ",$P($G(^RC(347.3,Y,0)),U,2) W:$P(^(0),U,3) " INACTIVE" D UPD Q
"RTN","RCXFMSUR",200,0)
. S X2=$L(X1),X3=$C($A($E(X1,X2))-1),X3=$E(X1,1,X2-1)_X3,X3=$O(^RC(347.3,"C",X3)) I $E(X3,1,X2)=X1 S X=X1
"RTN","RCXFMSUR",201,0)
. S D="C" D IX^DIC Q:Y<1 D UPD Q
"RTN","RCXFMSUR",202,0)
Q
"RTN","RCXFMSUR",203,0)
UPD S DIE="^RC(347.3,",DA=+Y,DR=".02;.03" D ^DIE
"RTN","RCXFMSUR",204,0)
Q
"RTN","RCXFMSUR",205,0)
;
"RTN","RCXFMSUR",206,0)
;
"RTN","RCXFMSUR",207,0)
RSC ;revenue code (#430/255)
"RTN","RCXFMSUR",208,0)
I $P($G(^RC(347.3,X,0)),"^",3) D EN^DDIOL("THIS REVENUE SOURCE CODE IS INACTIVE.") K X Q
"RTN","RCXFMSUR",209,0)
S X=$P(^RC(347.3,X,0),"^")
"RTN","RCXFMSUR",210,0)
Q
"RTN","RCXFMSUR",211,0)
;
"RTN","RCXFMSUR",212,0)
SHOW ; show/calculate revenue source code for a selected bill
"RTN","RCXFMSUR",213,0)
W !!,"This option will show the calculated Revenue Source Code for a selected"
"RTN","RCXFMSUR",214,0)
W !,"bill. The Revenue Source Code is only calculated for accrued bills in"
"RTN","RCXFMSUR",215,0)
I DT'<$$ADDPTEDT^PRCAACC() W !,"funds 528701,528703,528704,528709/4032,528711,528713,528714"
"RTN","RCXFMSUR",216,0)
I DT<$$ADDPTEDT^PRCAACC() W !,"funds 5287.1,5287.3,5287.4,4032"
"RTN","RCXFMSUR",217,0)
;
"RTN","RCXFMSUR",218,0)
N %,%Y,BILLDA,C,DIC,FUND,I,RCRJFLAG,RSC,X,Y
"RTN","RCXFMSUR",219,0)
;
"RTN","RCXFMSUR",220,0)
F D Q:$G(RCRJFLAG)
"RTN","RCXFMSUR",221,0)
. S DIC="^PRCA(430,",DIC(0)="QEAM"
"RTN","RCXFMSUR",222,0)
. W ! D ^DIC
"RTN","RCXFMSUR",223,0)
. I Y<1 S RCRJFLAG=1 Q
"RTN","RCXFMSUR",224,0)
. S BILLDA=+Y
"RTN","RCXFMSUR",225,0)
. ;PRCA*4.5*338 - prevent Non-accrued funds from recalculating Fund Number)
"RTN","RCXFMSUR",226,0)
. ; look for an existing fund number
"RTN","RCXFMSUR",227,0)
. S FUND=$P($G(^PRCA(430,BILLDA,11)),"^",17)
"RTN","RCXFMSUR",228,0)
. ; only recalculate fund number if Accrued fund
"RTN","RCXFMSUR",229,0)
. I $$PTACCT^PRCAACC(FUND) S FUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
"RTN","RCXFMSUR",230,0)
. ;end PRCA*4.5*338
"RTN","RCXFMSUR",231,0)
. W !!," Bill Number: ",$P($G(^PRCA(430,BILLDA,0)),"^")
"RTN","RCXFMSUR",232,0)
. W !," Fund: ",FUND
"RTN","RCXFMSUR",233,0)
. I '$$PTACCT^PRCAACC(FUND),FUND'=4032 D Q
"RTN","RCXFMSUR",234,0)
. . W !," The Revenue Source Code cannot be calculated for non-accrued bills."
"RTN","RCXFMSUR",235,0)
. . W !," The Revenue Source Code for non-accrued bills are input by the user."
"RTN","RCXFMSUR",236,0)
. . W !," The Revenue Source Code is currently entered as: "
"RTN","RCXFMSUR",237,0)
. . S RSC=$P($G(^PRCA(430,BILLDA,11)),"^",6)
"RTN","RCXFMSUR",238,0)
. . W $S(RSC="":"<not entered>",1:RSC)
"RTN","RCXFMSUR",239,0)
. ;
"RTN","RCXFMSUR",240,0)
. S RSC=$$CALCRSC(BILLDA)
"RTN","RCXFMSUR",241,0)
. W !,"Revenue Source Code: ",RSC
"RTN","RCXFMSUR",242,0)
Q
"RTN","RCXFMSUR",243,0)
;
"RTN","RCXFMSUR",244,0)
;PRCA*4.5*338
"RTN","RCXFMSUR",245,0)
GETCCRSC(CATEGDA,BILLDA) ;Retrieve the RSC for Community Care Categories
"RTN","RCXFMSUR",246,0)
N RCRSC,IBCNDATA,RCIOPFLG,RX3P
"RTN","RCXFMSUR",247,0)
S RCRSC=""
"RTN","RCXFMSUR",248,0)
Q:CATEGDA=52 "84CC" ;Choice No-Fault Auto AR Category
"RTN","RCXFMSUR",249,0)
Q:CATEGDA=53 "85CC" ;Choice TORT Feasor AR Category
"RTN","RCXFMSUR",250,0)
Q:CATEGDA=60 "86CC" ;Choice Workers' Comp AR Category
"RTN","RCXFMSUR",251,0)
Q:CATEGDA=54 "8CNW" ;CCN Workers' Comp AR Category
"RTN","RCXFMSUR",252,0)
Q:CATEGDA=56 "8CN9" ;CCN TORT Feasor AR Category
"RTN","RCXFMSUR",253,0)
Q:CATEGDA=55 "8CN8" ;CCN No-Fault Auto AR Category
"RTN","RCXFMSUR",254,0)
Q:CATEGDA=57 "8C6C" ;CC Workers' Comp AR Category
"RTN","RCXFMSUR",255,0)
Q:CATEGDA=59 "8C5C" ;CC TORT Feasor AR Category
"RTN","RCXFMSUR",256,0)
Q:CATEGDA=58 "8C4C" ;CC No-Fault Auto AR Category
"RTN","RCXFMSUR",257,0)
Q:CATEGDA=61 "8CC5" ;CHOICE Inpatient Copay
"RTN","RCXFMSUR",258,0)
Q:CATEGDA=62 "8CC7" ;CHOICE RX CO-PAYMENT Copay
"RTN","RCXFMSUR",259,0)
Q:CATEGDA=63 "8CC1" ;CC Inpatient Copay
"RTN","RCXFMSUR",260,0)
Q:CATEGDA=64 "8CC3" ;CC RX CO-PAYMENT
"RTN","RCXFMSUR",261,0)
Q:CATEGDA=65 "8CN1" ;CCN Inpatient Copay
"RTN","RCXFMSUR",262,0)
Q:CATEGDA=66 "8CN3" ;CCN RX CO-PAYMENT
"RTN","RCXFMSUR",263,0)
Q:CATEGDA=67 "8CD1" ;CC MTF C (MEANS TEST)
"RTN","RCXFMSUR",264,0)
Q:CATEGDA=68 "8CD3" ;CC MTF RX CO-PAYMENT
"RTN","RCXFMSUR",265,0)
Q:CATEGDA=69 "8CC4" ;CC NURSING HOME CARE - LTC
"RTN","RCXFMSUR",266,0)
Q:CATEGDA=70 "8CC4" ;CC RESPITE CARE
"RTN","RCXFMSUR",267,0)
Q:CATEGDA=71 "8CN4" ;CCN NURSING HOME CARE - LTC
"RTN","RCXFMSUR",268,0)
Q:CATEGDA=72 "8CN4" ;CCN RESPITE CARE
"RTN","RCXFMSUR",269,0)
Q:CATEGDA=73 "8CC8" ;CHOICE NURSING HOME CARE - LTC
"RTN","RCXFMSUR",270,0)
Q:CATEGDA=74 "8CC8" ;CHOICE RESPITE CARE
"RTN","RCXFMSUR",271,0)
Q:CATEGDA=81 "8CC6" ;CHOICE OPT
"RTN","RCXFMSUR",272,0)
Q:CATEGDA=82 "8CC2" ;CC OPT
"RTN","RCXFMSUR",273,0)
Q:CATEGDA=83 "8CN2" ;CCN OPT
"RTN","RCXFMSUR",274,0)
Q:CATEGDA=84 "8CD2" ;CC MTF OPT
"RTN","RCXFMSUR",275,0)
I (CATEGDA>47),(CATEGDA<52) D Q RCRSC
"RTN","RCXFMSUR",276,0)
. S RCIOPFLG=""
"RTN","RCXFMSUR",277,0)
. S RX3P=0
"RTN","RCXFMSUR",278,0)
. I ("PH"=$$TYP^IBRFN(BILLDA)) D
"RTN","RCXFMSUR",279,0)
. . S RX3P=$$CHECKRXS^RCXFMSUF(BILLDA)
"RTN","RCXFMSUR",280,0)
. D DIQ399(BILLDA)
"RTN","RCXFMSUR",281,0)
. ; for Community Care, 1 (inpatient) or 2 (outpatient -everything else)
"RTN","RCXFMSUR",282,0)
. S RCIOPFLG=$S($G(IBCNDATA(399,BILLDA,.05,"I"))=1:1,1:2)
"RTN","RCXFMSUR",283,0)
. I (CATEGDA=48),RX3P S RCRSC="83CC" Q ;CHOICE INS RX
"RTN","RCXFMSUR",284,0)
. I (CATEGDA=48),(RCIOPFLG=1) S RCRSC="81CC" Q ;CHOICE INS INPATIENT
"RTN","RCXFMSUR",285,0)
. I (CATEGDA=48),(RCIOPFLG=2) S RCRSC="82CC" Q ;CHOICE INS OUTPATIENT
"RTN","RCXFMSUR",286,0)
. I (CATEGDA=49),RX3P S RCRSC="8C3C" Q ;CC INS RX
"RTN","RCXFMSUR",287,0)
. I (CATEGDA=49),(RCIOPFLG=1) S RCRSC="8C1C" Q ;CC INS INPATIENT
"RTN","RCXFMSUR",288,0)
. I (CATEGDA=49),(RCIOPFLG=2) S RCRSC="8C2C" Q ;CC INS OUTPATIENT
"RTN","RCXFMSUR",289,0)
. I (CATEGDA=50),RX3P S RCRSC="8CN7" Q ;CCN INS RX
"RTN","RCXFMSUR",290,0)
. I (CATEGDA=50),(RCIOPFLG=1) S RCRSC="8CN5" Q ;CCN INS INPATIENT
"RTN","RCXFMSUR",291,0)
. I (CATEGDA=50),(RCIOPFLG=2) S RCRSC="8CN6" Q ;CCN INS OUTPATIENT
"RTN","RCXFMSUR",292,0)
. I (CATEGDA=51),RX3P S RCRSC="8CD6" Q ;CC MTF INS RX
"RTN","RCXFMSUR",293,0)
. I (CATEGDA=51),(RCIOPFLG=1) S RCRSC="8CD4" Q ;CC MTF INS INPATIENT
"RTN","RCXFMSUR",294,0)
. I (CATEGDA=51),(RCIOPFLG=2) S RCRSC="8CD5" Q ;CC MTF INS OUTPATIENT
"RTN","RCXFMSUR",295,0)
Q 0
"RTN","RCXFMSUV")
0^18^B24853879
"RTN","RCXFMSUV",1,0)
RCXFMSUV ;WISC/RFJ-fms vendor id ;9/17/98 11:42 AM
"RTN","RCXFMSUV",2,0)
;;4.5;Accounts Receivable;**90,119,98,165,192,220,315,338**;Mar 20, 1995;Build 70
"RTN","RCXFMSUV",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCXFMSUV",4,0)
Q
"RTN","RCXFMSUV",5,0)
;
"RTN","RCXFMSUV",6,0)
;
"RTN","RCXFMSUV",7,0)
VENDORID(BILLDA) ; return the vendorid for a bill (used on a BD document)
"RTN","RCXFMSUV",8,0)
; returns null if vendor id is not required
"RTN","RCXFMSUV",9,0)
; returns UNKNOWN if vendor id is required but could not be determined
"RTN","RCXFMSUV",10,0)
N ACCRUAL,CATEGORY,DEBTOR,RSC,VENDORID,VENDOR,DIR,VENFLAG
"RTN","RCXFMSUV",11,0)
;
"RTN","RCXFMSUV",12,0)
; accrued bills get sent to mccf 5287 fund, no vendor id
"RTN","RCXFMSUV",13,0)
S ACCRUAL=$$ACCK^PRCAACC(BILLDA)
"RTN","RCXFMSUV",14,0)
;
"RTN","RCXFMSUV",15,0)
; if not a category, cannot determine vendor id
"RTN","RCXFMSUV",16,0)
S CATEGORY=$P($G(^PRCA(430,BILLDA,0)),"^",2)
"RTN","RCXFMSUV",17,0)
I 'CATEGORY Q ""
"RTN","RCXFMSUV",18,0)
I ACCRUAL Q "" ;
"RTN","RCXFMSUV",19,0)
;
"RTN","RCXFMSUV",20,0)
;
"RTN","RCXFMSUV",21,0)
; if vendor(17) or military(12) or federal agencies refund(13)
"RTN","RCXFMSUV",22,0)
; or federal agencies-reimb(14) or interagency(20)
"RTN","RCXFMSUV",23,0)
; sharing agreements(19),nursing Home Proceeds (40)
"RTN","RCXFMSUV",24,0)
; parking fees (41), cwt proceeds (42), comp & pen proceeds (43)
"RTN","RCXFMSUV",25,0)
; Enhanced Use Lease Proceeds (44), then get vendor id
"RTN","RCXFMSUV",26,0)
S VENFLAG=$S(CATEGORY=17:2,CATEGORY=12:1,CATEGORY=13:1,CATEGORY=14:1,CATEGORY=20:1,CATEGORY=19:1,CATEGORY=40:2,CATEGORY=41:2,CATEGORY=42:2,CATEGORY=43:2,CATEGORY=44:2,CATEGORY=47:1,1:0)
"RTN","RCXFMSUV",27,0)
I VENFLAG D Q VENDORID
"RTN","RCXFMSUV",28,0)
.S DEBTOR=+$P($G(^PRCA(430,BILLDA,0)),"^",9),VENDOR=$P($G(^RCD(340,DEBTOR,0)),U)
"RTN","RCXFMSUV",29,0)
.I VENDOR="" S VENDORID="UNKNOWN" Q
"RTN","RCXFMSUV",30,0)
.I VENFLAG=2,VENDOR["VA(" S VENDORID="PERSONOTH" D STORE(BILLDA,"PERSONOTH") Q
"RTN","RCXFMSUV",31,0)
.I VENDOR["PRC(" D Q
"RTN","RCXFMSUV",32,0)
..S VENDORID=$$VEN^PRCHUTL(+VENDOR)
"RTN","RCXFMSUV",33,0)
..I VENDORID'="" D STORE(BILLDA,VENDORID) Q
"RTN","RCXFMSUV",34,0)
..I VENFLAG=2 D Q
"RTN","RCXFMSUV",35,0)
...S DIR(0)="Y",DIR("A")="Can this bill be offset by FMS "
"RTN","RCXFMSUV",36,0)
...S DIR("B")="YES" D ^DIR
"RTN","RCXFMSUV",37,0)
...S VENDORID=$S(Y=0:"PERSONOTH",1:"UNKNOWN")
"RTN","RCXFMSUV",38,0)
...D:VENDORID="PERSONOTH" STORE(BILLDA,"PERSONOTH")
"RTN","RCXFMSUV",39,0)
...Q
"RTN","RCXFMSUV",40,0)
..S VENDORID="UNKNOWN"
"RTN","RCXFMSUV",41,0)
..Q
"RTN","RCXFMSUV",42,0)
.S VENDOR=$P(^RCD(340,+DEBTOR,0),U,6)
"RTN","RCXFMSUV",43,0)
.I VENDOR'="" S VENDORID=$$VEN^PRCHUTL(VENDOR) D Q
"RTN","RCXFMSUV",44,0)
..I VENDORID="" S VENDORID="UNKNOWN" Q
"RTN","RCXFMSUV",45,0)
..D STORE(BILLDA,VENDORID)
"RTN","RCXFMSUV",46,0)
..Q
"RTN","RCXFMSUV",47,0)
.I '$D(^XUSEC("PRCA VENDOR",DUZ)) S VENDORID="LINK" Q
"RTN","RCXFMSUV",48,0)
.W !!,"DEBTOR MUST BE LINKED TO VENDOR FILE"
"RTN","RCXFMSUV",49,0)
.S VENDOR=$$VENSEL^PRCHUTL()
"RTN","RCXFMSUV",50,0)
.I VENDOR<0 S VENDORID="LINK" Q
"RTN","RCXFMSUV",51,0)
.S VENDORID=$$VEN^PRCHUTL(VENDOR)
"RTN","RCXFMSUV",52,0)
.I VENDORID="" S VENDORID="UNKNOWN" Q
"RTN","RCXFMSUV",53,0)
.D STORE(BILLDA,VENDORID),STOREL(+DEBTOR,VENDOR)
"RTN","RCXFMSUV",54,0)
.Q
"RTN","RCXFMSUV",55,0)
;
"RTN","RCXFMSUV",56,0)
; for ineligible send INELIG
"RTN","RCXFMSUV",57,0)
I CATEGORY=1 D STORE(BILLDA,"INELIG") Q "INELIG"
"RTN","RCXFMSUV",58,0)
; for ex-employee send XEMPL
"RTN","RCXFMSUV",59,0)
I CATEGORY=15 D STORE(BILLDA,"XEMPL") Q "XEMPL"
"RTN","RCXFMSUV",60,0)
; for current employee send CUREMPL
"RTN","RCXFMSUV",61,0)
I CATEGORY=16 D STORE(BILLDA,"CUREMPL") Q "CUREMPL"
"RTN","RCXFMSUV",62,0)
;
"RTN","RCXFMSUV",63,0)
;
"RTN","RCXFMSUV",64,0)
; for INELIGIBLE HOSP. REIMB.
"RTN","RCXFMSUV",65,0)
; 841Z;INELI 3RD-PARTY INPATIENT
"RTN","RCXFMSUV",66,0)
; 842Z;INELI 3RD-PARTY OUTPATIENT
"RTN","RCXFMSUV",67,0)
I CATEGORY=47 D Q VENDORID
"RTN","RCXFMSUV",68,0)
. S RSC=$P($G(^PRCA(430,BILLDA,11)),"^",6)
"RTN","RCXFMSUV",69,0)
. I RSC'="" D Q
"RTN","RCXFMSUV",70,0)
..I RSC="841Z" S VENDORID="INE3PINP"
"RTN","RCXFMSUV",71,0)
..I RSC="842Z" S VENDORID="INE3POUT"
"RTN","RCXFMSUV",72,0)
. D STORE(BILLDA,VENDORID)
"RTN","RCXFMSUV",73,0)
;
"RTN","RCXFMSUV",74,0)
; champva subsitence(27), champva third party(28)
"RTN","RCXFMSUV",75,0)
I CATEGORY=27 D STORE(BILLDA,"CHMPVA1ST") Q "CHMPVA1ST"
"RTN","RCXFMSUV",76,0)
I CATEGORY=28 D STORE(BILLDA,"CHMPVA3RD") Q "CHMPVA3RD"
"RTN","RCXFMSUV",77,0)
; champva(29) does not get sent to FMS, code commented out
"RTN","RCXFMSUV",78,0)
;I CATEGORY=29 Q ""
"RTN","RCXFMSUV",79,0)
;
"RTN","RCXFMSUV",80,0)
; tricare(30), tricare patient(31), tricare third party(32)
"RTN","RCXFMSUV",81,0)
; test for tricare by looking at the revenue source code
"RTN","RCXFMSUV",82,0)
S RSC=$P($G(^PRCA(430,BILLDA,11)),"^",6)
"RTN","RCXFMSUV",83,0)
I RSC>8027,RSC<8031 D D STORE(BILLDA,VENDORID) Q VENDORID
"RTN","RCXFMSUV",84,0)
.S VENDORID=$S(RSC=8028:"TRIINPAT",RSC=8029:"TRIOUTPAT",1:"TRIOTH")
"RTN","RCXFMSUV",85,0)
.Q
"RTN","RCXFMSUV",86,0)
I CATEGORY>29,CATEGORY<33 D D STORE(BILLDA,VENDORID) Q VENDORID
"RTN","RCXFMSUV",87,0)
.S VENDORID=$S(CATEGORY=30:"TRICAROTH",CATEGORY=31:"TRICAROPT",1:"TRICARINP")
"RTN","RCXFMSUV",88,0)
.Q
"RTN","RCXFMSUV",89,0)
;
"RTN","RCXFMSUV",90,0)
; for TRICARE SCI
"RTN","RCXFMSUV",91,0)
; 8086;TRICARE SCI INPATIENT
"RTN","RCXFMSUV",92,0)
; 8087;TRICARE SCI OUTPATIENT
"RTN","RCXFMSUV",93,0)
; 8088;TRICARE SCI OTHER
"RTN","RCXFMSUV",94,0)
I CATEGORY=76 D Q VENDORID
"RTN","RCXFMSUV",95,0)
. S RSC=$P($G(^PRCA(430,BILLDA,11)),"^",6)
"RTN","RCXFMSUV",96,0)
. I RSC'="" D Q
"RTN","RCXFMSUV",97,0)
..I RSC="8086" S VENDORID="TRISCIINP"
"RTN","RCXFMSUV",98,0)
..I RSC="8087" S VENDORID="TRISCIOPT"
"RTN","RCXFMSUV",99,0)
..I RSC="8088" S VENDORID="TRISCIOTH"
"RTN","RCXFMSUV",100,0)
. D STORE(BILLDA,VENDORID)
"RTN","RCXFMSUV",101,0)
;
"RTN","RCXFMSUV",102,0)
; for TRICARE TBI
"RTN","RCXFMSUV",103,0)
; 8089;TRICARE TBI INPATIENT
"RTN","RCXFMSUV",104,0)
; 8090;TRICARE TBI OUTPATIENT
"RTN","RCXFMSUV",105,0)
; 8091;TRICARE TBI OTHER
"RTN","RCXFMSUV",106,0)
I CATEGORY=77 D Q VENDORID
"RTN","RCXFMSUV",107,0)
. S RSC=$P($G(^PRCA(430,BILLDA,11)),"^",6)
"RTN","RCXFMSUV",108,0)
. I RSC'="" D Q
"RTN","RCXFMSUV",109,0)
..I RSC="8089" S VENDORID="TRITBIINP"
"RTN","RCXFMSUV",110,0)
..I RSC="8090" S VENDORID="TRITBIOPT"
"RTN","RCXFMSUV",111,0)
..I RSC="8091" S VENDORID="TRITBIOTH"
"RTN","RCXFMSUV",112,0)
. D STORE(BILLDA,VENDORID)
"RTN","RCXFMSUV",113,0)
;
"RTN","RCXFMSUV",114,0)
; for TRICARE BLIND REHABILITATION
"RTN","RCXFMSUV",115,0)
; 8092;TRICARE BLIND REHABILITATION INPATIENT
"RTN","RCXFMSUV",116,0)
; 8093;TRICARE BLIND REHABILITATION OUTPATIENT
"RTN","RCXFMSUV",117,0)
; 8094;TRICARE BLIND REHABILITATION OTHER
"RTN","RCXFMSUV",118,0)
I CATEGORY=78 D Q VENDORID
"RTN","RCXFMSUV",119,0)
. S RSC=$P($G(^PRCA(430,BILLDA,11)),"^",6)
"RTN","RCXFMSUV",120,0)
. I RSC'="" D Q
"RTN","RCXFMSUV",121,0)
..I RSC="8092" S VENDORID="TRIBRINP"
"RTN","RCXFMSUV",122,0)
..I RSC="8093" S VENDORID="TRIBROPT"
"RTN","RCXFMSUV",123,0)
..I RSC="8094" S VENDORID="TRIBROTH"
"RTN","RCXFMSUV",124,0)
. D STORE(BILLDA,VENDORID)
"RTN","RCXFMSUV",125,0)
;
"RTN","RCXFMSUV",126,0)
; Tricare Dental (79) and Tricare Pharmacy (80) Vendor IDs
"RTN","RCXFMSUV",127,0)
I CATEGORY=79 D Q VENDORID
"RTN","RCXFMSUV",128,0)
. S VENDORID="TRIDENTAL"
"RTN","RCXFMSUV",129,0)
. D STORE(BILLDA,VENDORID)
"RTN","RCXFMSUV",130,0)
I CATEGORY=80 D Q VENDORID
"RTN","RCXFMSUV",131,0)
. S VENDORID="TRICARERX"
"RTN","RCXFMSUV",132,0)
. D STORE(BILLDA,VENDORID)
"RTN","RCXFMSUV",133,0)
I CATEGORY=75 D Q VENDORID
"RTN","RCXFMSUV",134,0)
. S VENDORID="TRIDES"
"RTN","RCXFMSUV",135,0)
. D STORE(BILLDA,VENDORID)
"RTN","RCXFMSUV",136,0)
;
"RTN","RCXFMSUV",137,0)
; vendor id not known, process should never reach this line of code
"RTN","RCXFMSUV",138,0)
Q "UNKNOWN"
"RTN","RCXFMSUV",139,0)
;
"RTN","RCXFMSUV",140,0)
;
"RTN","RCXFMSUV",141,0)
LINKASK ;ENTRY POINT FOR MENU OPTION TO STORE LINK
"RTN","RCXFMSUV",142,0)
N DIC,Y
"RTN","RCXFMSUV",143,0)
S DIC=340,DIC(0)="AEQM",DIC("A")="Enter Debtor to be linked to Vendor File: ",DIC("S")="I $P(^RCD(340,+Y,0),U)'[""PRC(""" D ^DIC Q:Y<0 S DEBTOR=+Y
"RTN","RCXFMSUV",144,0)
LINK ;LINKS DEBTOR TO VENDOR FILE
"RTN","RCXFMSUV",145,0)
S VENDOR=$$VENSEL^PRCHUTL() I VENDOR<0 S VENDOR="LINK" Q
"RTN","RCXFMSUV",146,0)
D STOREL(DEBTOR,VENDOR) Q
"RTN","RCXFMSUV",147,0)
;
"RTN","RCXFMSUV",148,0)
;
"RTN","RCXFMSUV",149,0)
STOREL(DA,VENDOR) ; store the link from the debtor file to the vendor file
"RTN","RCXFMSUV",150,0)
N D,D0,DI,DIC,DIE,DQ,DR,X,Y
"RTN","RCXFMSUV",151,0)
S DR=".06////"_VENDOR_";"
"RTN","RCXFMSUV",152,0)
S (DIC,DIE)="^RCD(340,"
"RTN","RCXFMSUV",153,0)
D ^DIE
"RTN","RCXFMSUV",154,0)
Q
"RTN","RCXFMSUV",155,0)
;
"RTN","RCXFMSUV",156,0)
;
"RTN","RCXFMSUV",157,0)
STORE(DA,VENDORID) ;STORES THE VENDOR ID WITH THE BILL
"RTN","RCXFMSUV",158,0)
I $G(^PRCA(430,DA,0))="" Q
"RTN","RCXFMSUV",159,0)
N D0,DI,DIC,DIE,DQ,DR,X,Y,D
"RTN","RCXFMSUV",160,0)
S DR="265////"_VENDORID_";"
"RTN","RCXFMSUV",161,0)
S (DIC,DIE)="^PRCA(430,"
"VER")
8.0^22.2
"^DD",430.2,430.2,1.01,0)
REFER TO DMC?^S^0:NO;1:YES;2:PRIOR TO 8/1/15;3:8/1/15 AND AFTER;^1;1^Q
"^DD",430.2,430.2,1.01,3)
Enter whether bills in this category should go to the DMC collections program
"^DD",430.2,430.2,1.01,21,0)
^^2^2^3180131^
"^DD",430.2,430.2,1.01,21,1,0)
The REFER TO DMC? prompt allows overdue bills to be sent to the Debt
"^DD",430.2,430.2,1.01,21,2,0)
Management Center for Collection.
"^DD",430.2,430.2,1.01,"DT")
3180131
"^DD",430.2,430.2,1.02,0)
REFER TO TOP?^S^0:NO;1:YES;2:PRIOR TO 8/1/15;3:8/1/15 AND AFTER;^1;2^Q
"^DD",430.2,430.2,1.02,3)
Enter whether bills with this category should go to the TOP program for collection.
"^DD",430.2,430.2,1.02,21,0)
^^2^2^3180131^
"^DD",430.2,430.2,1.02,21,1,0)
The REFER TO TOP? field allows overdue bills to be sent to the Treasury
"^DD",430.2,430.2,1.02,21,2,0)
Offset Program for collection.
"^DD",430.2,430.2,1.02,"DT")
3180131
"^DD",430.2,430.2,1.03,0)
REFER TO CS?^S^0:NO;1:YES;2:PRIOR TO 8/1/15;3:8/1/15 AND AFTER;^1;3^Q
"^DD",430.2,430.2,1.03,3)
Enter whether an overdue bill will be referred to the CS collections program.
"^DD",430.2,430.2,1.03,21,0)
^.001^2^2^3180209^^^
"^DD",430.2,430.2,1.03,21,1,0)
The REFER TO CS? field allows overdue bills to be sent to the Cross
"^DD",430.2,430.2,1.03,21,2,0)
Servicing (CS) program for collection.
"^DD",430.2,430.2,1.03,"DT")
3180207
**END**
**END**