Summary Table
Categories |
Total Count |
PII |
1 |
URL |
0 |
DNS |
0 |
EKL |
0 |
IP |
0 |
PORT |
0 |
VsID |
0 |
CF |
0 |
AI |
0 |
VPD |
0 |
PL |
0 |
Other |
0 |
File Content
KIDS Distribution saved on Jul 18, 2018@15:50:57
TEST
**KIDS**:PRCA*4.5*338^
**INSTALL NAME**
PRCA*4.5*338
"BLD",10660,0)
PRCA*4.5*338^ACCOUNTS RECEIVABLE^0^3180718^y
"BLD",10660,4,0)
^9.64PA^430.2^1
"BLD",10660,4,430.2,0)
430.2
"BLD",10660,4,430.2,2,0)
^9.641^430.2^1
"BLD",10660,4,430.2,2,430.2,0)
ACCOUNTS RECEIVABLE CATEGORY (File-top level)
"BLD",10660,4,430.2,2,430.2,1,0)
^9.6411^1.03^3
"BLD",10660,4,430.2,2,430.2,1,1.01,0)
REFER TO DMC?
"BLD",10660,4,430.2,2,430.2,1,1.02,0)
REFER TO TOP?
"BLD",10660,4,430.2,2,430.2,1,1.03,0)
REFER TO CS?
"BLD",10660,4,430.2,222)
y^n^p^^^^n^^n
"BLD",10660,4,430.2,224)
"BLD",10660,4,"APDD",430.2,430.2)
"BLD",10660,4,"APDD",430.2,430.2,1.01)
"BLD",10660,4,"APDD",430.2,430.2,1.02)
"BLD",10660,4,"APDD",430.2,430.2,1.03)
"BLD",10660,4,"B",430.2,430.2)
"BLD",10660,6)
1^
"BLD",10660,6.3)
17
"BLD",10660,"ABPKG")
n
"BLD",10660,"INIT")
POSTINIT^PRCAP338
"BLD",10660,"KRN",0)
^9.67PA^779.2^20
"BLD",10660,"KRN",.4,0)
.4
"BLD",10660,"KRN",.4,"NM",0)
^9.68A^^
"BLD",10660,"KRN",.401,0)
.401
"BLD",10660,"KRN",.402,0)
.402
"BLD",10660,"KRN",.403,0)
.403
"BLD",10660,"KRN",.5,0)
.5
"BLD",10660,"KRN",.84,0)
.84
"BLD",10660,"KRN",3.6,0)
3.6
"BLD",10660,"KRN",3.8,0)
3.8
"BLD",10660,"KRN",9.2,0)
9.2
"BLD",10660,"KRN",9.8,0)
9.8
"BLD",10660,"KRN",9.8,"NM",0)
^9.68A^15^13
"BLD",10660,"KRN",9.8,"NM",1,0)
RCXFMSUR^^0^B109509450
"BLD",10660,"KRN",9.8,"NM",2,0)
RCXFMSUF^^0^B57827951
"BLD",10660,"KRN",9.8,"NM",3,0)
RCBEADJ^^0^B104925198
"BLD",10660,"KRN",9.8,"NM",4,0)
PRCAACC^^0^B8752523
"BLD",10660,"KRN",9.8,"NM",5,0)
RCRJRDEP^^0^B67133793
"BLD",10660,"KRN",9.8,"NM",6,0)
RCXFMSPR^^0^B65169174
"BLD",10660,"KRN",9.8,"NM",7,0)
PRCABJV^^0^B50976632
"BLD",10660,"KRN",9.8,"NM",8,0)
RCRJRBD^^0^B84210608
"BLD",10660,"KRN",9.8,"NM",11,0)
RCRJRBDT^^0^B70483882
"BLD",10660,"KRN",9.8,"NM",12,0)
RCTOPD^^0^B80726007
"BLD",10660,"KRN",9.8,"NM",13,0)
RCDMC90^^0^B63501721
"BLD",10660,"KRN",9.8,"NM",14,0)
RCTCSPD^^0^B162524744
"BLD",10660,"KRN",9.8,"NM",15,0)
PRCASVC^^0^B26610920
"BLD",10660,"KRN",9.8,"NM","B","PRCAACC",4)
"BLD",10660,"KRN",9.8,"NM","B","PRCABJV",7)
"BLD",10660,"KRN",9.8,"NM","B","PRCASVC",15)
"BLD",10660,"KRN",9.8,"NM","B","RCBEADJ",3)
"BLD",10660,"KRN",9.8,"NM","B","RCDMC90",13)
"BLD",10660,"KRN",9.8,"NM","B","RCRJRBD",8)
"BLD",10660,"KRN",9.8,"NM","B","RCRJRBDT",11)
"BLD",10660,"KRN",9.8,"NM","B","RCRJRDEP",5)
"BLD",10660,"KRN",9.8,"NM","B","RCTCSPD",14)
"BLD",10660,"KRN",9.8,"NM","B","RCTOPD",12)
"BLD",10660,"KRN",9.8,"NM","B","RCXFMSPR",6)
"BLD",10660,"KRN",9.8,"NM","B","RCXFMSUF",2)
"BLD",10660,"KRN",9.8,"NM","B","RCXFMSUR",1)
"BLD",10660,"KRN",19,0)
19
"BLD",10660,"KRN",19.1,0)
19.1
"BLD",10660,"KRN",101,0)
101
"BLD",10660,"KRN",409.61,0)
409.61
"BLD",10660,"KRN",771,0)
771
"BLD",10660,"KRN",779.2,0)
779.2
"BLD",10660,"KRN",870,0)
870
"BLD",10660,"KRN",8989.51,0)
8989.51
"BLD",10660,"KRN",8989.52,0)
8989.52
"BLD",10660,"KRN",8994,0)
8994
"BLD",10660,"KRN","B",.4,.4)
"BLD",10660,"KRN","B",.401,.401)
"BLD",10660,"KRN","B",.402,.402)
"BLD",10660,"KRN","B",.403,.403)
"BLD",10660,"KRN","B",.5,.5)
"BLD",10660,"KRN","B",.84,.84)
"BLD",10660,"KRN","B",3.6,3.6)
"BLD",10660,"KRN","B",3.8,3.8)
"BLD",10660,"KRN","B",9.2,9.2)
"BLD",10660,"KRN","B",9.8,9.8)
"BLD",10660,"KRN","B",19,19)
"BLD",10660,"KRN","B",19.1,19.1)
"BLD",10660,"KRN","B",101,101)
"BLD",10660,"KRN","B",409.61,409.61)
"BLD",10660,"KRN","B",771,771)
"BLD",10660,"KRN","B",779.2,779.2)
"BLD",10660,"KRN","B",870,870)
"BLD",10660,"KRN","B",8989.51,8989.51)
"BLD",10660,"KRN","B",8989.52,8989.52)
"BLD",10660,"KRN","B",8994,8994)
"BLD",10660,"QDEF")
^^^^NO^^^^NO^^YES
"BLD",10660,"QUES",0)
^9.62^^
"BLD",10660,"REQB",0)
^9.611^2^2
"BLD",10660,"REQB",1,0)
PRCA*4.5*315^1
"BLD",10660,"REQB",2,0)
PRCA*4.5*253^1
"BLD",10660,"REQB","B","PRCA*4.5*253",2)
"BLD",10660,"REQB","B","PRCA*4.5*315",1)
"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",53,-1)
1^1
"PKG",53,0)
ACCOUNTS RECEIVABLE^PRCA^FMS
"PKG",53,20,0)
^9.402P^1^1
"PKG",53,20,1,0)
2^^PRCAMRG
"PKG",53,20,1,1)
"PKG",53,20,"B",2,1)
"PKG",53,22,0)
^9.49I^1^1
"PKG",53,22,1,0)
4.5^3051119^2960627
"PKG",53,22,1,"PAH",1,0)
338^3180718^62
"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")
14
"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 17
"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","PRCABJV")
0^7^B50976632
"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 17
"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 C (MEANS TEST);65;CJ;63
"RTN","PRCABJV",132,0)
;;CC MTF C (MEANS TEST);69;CX;67
"RTN","PRCABJV",133,0)
;;CC MTF RX CO-PAYMENT;CY;70;294;68
"RTN","PRCABJV",134,0)
;;CC MTF THIRD PARTY;53;C4;51
"RTN","PRCABJV",135,0)
;;CC NO-FAULT AUTO;60;C8;58
"RTN","PRCABJV",136,0)
;;CC NURSING HOME CARE - LTC;71;CL;69
"RTN","PRCABJV",137,0)
;;CC RESPITE CARE;72;CN;70
"RTN","PRCABJV",138,0)
;;CC RX CO-PAYMENT;CK;66;294;64
"RTN","PRCABJV",139,0)
;;CC THIRD PARTY;51;C2;49
"RTN","PRCABJV",140,0)
;;CC TORT FEASOR;61;C9;59
"RTN","PRCABJV",141,0)
;;CC WORKERS' COMP;59;CA;57
"RTN","PRCABJV",142,0)
;;CCN C (MEANS TEST);67;C0;65
"RTN","PRCABJV",143,0)
;;CCN NO-FAULT AUTO;57;CB;55
"RTN","PRCABJV",144,0)
;;CCN NURSING HOME CARE - LTC;73;CR;71
"RTN","PRCABJV",145,0)
;;CCN RESPITE CARE;74;CU;72
"RTN","PRCABJV",146,0)
;;CCN RX CO-PAYMENT;68;CQ;66
"RTN","PRCABJV",147,0)
;;CCN THIRD PARTY;52;C3;50
"RTN","PRCABJV",148,0)
;;CCN TORT FEASOR;58;CC;56
"RTN","PRCABJV",149,0)
;;CCN WORKERS' COMP;56;CD;54
"RTN","PRCABJV",150,0)
;;CHAMPVA;36;CV;29
"RTN","PRCABJV",151,0)
;;CHAMPVA SUBSISTENCE;34;CS;27
"RTN","PRCABJV",152,0)
;;CHAMPVA THIRD PARTY;35;CT;28
"RTN","PRCABJV",153,0)
;;CHOICE C (MEANS TEST);63;CF;61
"RTN","PRCABJV",154,0)
;;CHOICE NO-FAULT AUTO;54;C5;52
"RTN","PRCABJV",155,0)
;;CHOICE NURSING HOME CARE - LTC;75;CH;73
"RTN","PRCABJV",156,0)
;;CHOICE RESPITE CARE;76;CI;74
"RTN","PRCABJV",157,0)
;;CHOICE RX CO-PAYMENT;64;CG;62
"RTN","PRCABJV",158,0)
;;CHOICE THIRD PARTY;50;C1;48
"RTN","PRCABJV",159,0)
;;CHOICE TORT FEASOR;55;C6;53
"RTN","PRCABJV",160,0)
;;CHOICE WORKERS' COMP;62;C7;60
"RTN","PRCABJV",161,0)
;;COMP & PEN PROCEEDS;8;CM;43
"RTN","PRCABJV",162,0)
;;CRIME OF PER.VIO.;27;CP;8
"RTN","PRCABJV",163,0)
;;CURRENT EMP.;14;CE;16
"RTN","PRCABJV",164,0)
;;CWT PROCEEDS;7;CW;42
"RTN","PRCABJV",165,0)
;;DOMICILIARY;41;DO;34
"RTN","PRCABJV",166,0)
;;EMERGENCY/HUMANITARIAN;25;H;2
"RTN","PRCABJV",167,0)
;;EMERGENCY/HUMANITARIAN REIMB.;48;HR;46
"RTN","PRCABJV",168,0)
;;ENHANCED USE LEASE PROCEEDS;10;EP;44
"RTN","PRCABJV",169,0)
;;EX-EMPLOYEE;13;E;15
"RTN","PRCABJV",170,0)
;;FEDERAL AGENCIES-REFUND;15;F2;13
"RTN","PRCABJV",171,0)
;;FEDERAL AGENCIES-REIMB.;16;F1;14
"RTN","PRCABJV",172,0)
;;FEE REIMB INS;47;FR;45
"RTN","PRCABJV",173,0)
;;GERIATRIC EVAL-INSTITUTIONAL;44;GE;37
"RTN","PRCABJV",174,0)
;;GERIATRIC EVAL-NON-INSTITUTION;45;GN;38
"RTN","PRCABJV",175,0)
;;HOSPITAL CARE (NSC);1;HC;5
"RTN","PRCABJV",176,0)
;;HOSPITAL CARE PER DIEM;32;HP;25
"RTN","PRCABJV",177,0)
;;INELIGIBLE HOSP.;20;I;1
"RTN","PRCABJV",178,0)
;;INELIGIBLE HOSP. REIMB.;49;IR;47
"RTN","PRCABJV",179,0)
;;INTERAGENCY;19;IA;20
"RTN","PRCABJV",180,0)
;;MEDICARE;28;MC;21
"RTN","PRCABJV",181,0)
;;MILITARY;17;M;12
"RTN","PRCABJV",182,0)
;;NO-FAULT AUTO ACC.;26;NA;7
"RTN","PRCABJV",183,0)
;;NURSING HOME CARE PER DIEM;31;NP;24
"RTN","PRCABJV",184,0)
;;NURSING HOME CARE(NSC);3;NC;3
"RTN","PRCABJV",185,0)
;;NURSING HOME CARE-LTC;46;NL;39
"RTN","PRCABJV",186,0)
;;NURSING HOME PROCEEDS;5;NH;40
"RTN","PRCABJV",187,0)
;;OUTPATIENT CARE(NSC);2;OC;4
"RTN","PRCABJV",188,0)
;;PARKING FEES;6;PF;41
"RTN","PRCABJV",189,0)
;;PREPAYMENT;33;PP;26
"RTN","PRCABJV",190,0)
;;REIMBURS.HEALTH INS.;21;RI;9
"RTN","PRCABJV",191,0)
;;RESPITE CARE-INSTITUTIONAL;42;RC;35
"RTN","PRCABJV",192,0)
;;RESPITE CARE-NON-INSTITUTIONAL;43;RN;36
"RTN","PRCABJV",193,0)
;;RX CO-PAYMENT/NSC VET;30;PN;23
"RTN","PRCABJV",194,0)
;;RX CO-PAYMENT/SC VET;29;PS;22
"RTN","PRCABJV",195,0)
;;SHARING AGREEMENTS;18;SA;19
"RTN","PRCABJV",196,0)
;;TORT FEASOR;22;TF;10
"RTN","PRCABJV",197,0)
;;TRICARE;37;T1;30
"RTN","PRCABJV",198,0)
;;TRICARE PATIENT;38;T2;31
"RTN","PRCABJV",199,0)
;;TRICARE THIRD PARTY;39;T3;32
"RTN","PRCABJV",200,0)
;;VENDOR;11;V;17
"RTN","PRCABJV",201,0)
;;WORKMAN'S COMP.;23;WC;6
"RTN","PRCABJV",202,0)
;;EOF
"RTN","PRCABJV",203,0)
EVENT ;
"RTN","PRCABJV",204,0)
;;CASH PAYMENT;6;;6
"RTN","PRCABJV",205,0)
;;CHECK/MO PAYMENT;4;;4
"RTN","PRCABJV",206,0)
;;COMMENT;1;;1
"RTN","PRCABJV",207,0)
;;CREDIT CARD PAYMENT;7;;7
"RTN","PRCABJV",208,0)
;;DEPT OF JUSTICE PAYMENT;5;;5
"RTN","PRCABJV",209,0)
;;REGIONAL COUNSEL PAYMENT;3;;3
"RTN","PRCABJV",210,0)
;;FOLLOW-UP LETTER;10;;10
"RTN","PRCABJV",211,0)
;;IRS PAYMENT;11;;11
"RTN","PRCABJV",212,0)
;;PATIENT STATEMENT;2;;2
"RTN","PRCABJV",213,0)
;;TDA PAYMENT;8;;8
"RTN","PRCABJV",214,0)
;;UB PRINTED;9;;9
"RTN","PRCABJV",215,0)
;;LOCKBOX;12;;12
"RTN","PRCABJV",216,0)
;;TOP PAYMENT;13;;13
"RTN","PRCABJV",217,0)
;;EDI LOCKBOX;14;;14
"RTN","PRCABJV",218,0)
;;ADMINISTRATIVE OFFSET;15;;15
"RTN","PRCABJV",219,0)
;;PRIVATE COLLECTION AGENCY;16;;16
"RTN","PRCABJV",220,0)
;;EOF
"RTN","PRCAP338")
0^^B76511010
"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 17
"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 BMES^XPDUTL(" >> End of the Post-Initialization routine for PRCA*4.5*338")
"RTN","PRCAP338",13,0)
Q
"RTN","PRCAP338",14,0)
;
"RTN","PRCAP338",15,0)
ARCAT ;AR CATEGORY ENTRIES (430.2)
"RTN","PRCAP338",16,0)
N LOOP,FDA,FDAIEN,DATA,CHK
"RTN","PRCAP338",17,0)
;
"RTN","PRCAP338",18,0)
D MES^XPDUTL(" -> Adding new AR CATEGORY entries to file 430.2 ...")
"RTN","PRCAP338",19,0)
; Add new AR categories
"RTN","PRCAP338",20,0)
F LOOP=2:1:38 D
"RTN","PRCAP338",21,0)
. ;Clear the array
"RTN","PRCAP338",22,0)
. K FDA
"RTN","PRCAP338",23,0)
. ;Extract the new AR Category to be added.
"RTN","PRCAP338",24,0)
. S DATA=$T(ARDATA+LOOP)
"RTN","PRCAP338",25,0)
. ;Check to insure that the AR Category doesn't exist already
"RTN","PRCAP338",26,0)
. S CHK="" ; Initialized the check variable
"RTN","PRCAP338",27,0)
. S CHK=$O(^PRCA(430.2,"B",$P(DATA,";",3),""))
"RTN","PRCAP338",28,0)
. Q:CHK'=""
"RTN","PRCAP338",29,0)
. ;Store in array for adding to the file (#430.2).
"RTN","PRCAP338",30,0)
. S FDA(430.2,"+1,",.01)=$P(DATA,";",3) ;AR Category Name
"RTN","PRCAP338",31,0)
. S FDA(430.2,"+1,",1)=$P(DATA,";",4) ;Abbreviation
"RTN","PRCAP338",32,0)
. S FDA(430.2,"+1,",2)=$P(DATA,";",5) ;Segment
"RTN","PRCAP338",33,0)
. S FDA(430.2,"+1,",3)=$P(DATA,";",6) ;GL #
"RTN","PRCAP338",34,0)
. S FDA(430.2,"+1,",5)=$P(DATA,";",7) ;Type
"RTN","PRCAP338",35,0)
. S FDA(430.2,"+1,",6)=$P(DATA,";",8) ;Category Number
"RTN","PRCAP338",36,0)
. S FDA(430.2,"+1,",7)=$P(DATA,";",9) ;Receivable Code
"RTN","PRCAP338",37,0)
. S FDA(430.2,"+1,",9)=$P(DATA,";",10) ;Charge Interest
"RTN","PRCAP338",38,0)
. S FDA(430.2,"+1,",10)=$P(DATA,";",11) ;Charge Admin
"RTN","PRCAP338",39,0)
. S FDA(430.2,"+1,",11)=$P(DATA,";",12) ;Charge Penalty
"RTN","PRCAP338",40,0)
. S FDA(430.2,"+1,",12)=$P(DATA,";",13) ;Accrued
"RTN","PRCAP338",41,0)
. S FDA(430.2,"+1,",13)=$P(DATA,";",14) ;Refund/Reimbursement
"RTN","PRCAP338",42,0)
. S FDA(430.2,"+1,",14)=$P(DATA,";",15) ;Paragraph Codes
"RTN","PRCAP338",43,0)
. ;Add to the file.
"RTN","PRCAP338",44,0)
. D UPDATE^DIE(,"FDA","FDAIEN")
"RTN","PRCAP338",45,0)
. S FDAIEN=FDAIEN(1) K FDAIEN(1)
"RTN","PRCAP338",46,0)
D MES^XPDUTL(" New AR CATEGORIES added.")
"RTN","PRCAP338",47,0)
Q
"RTN","PRCAP338",48,0)
;
"RTN","PRCAP338",49,0)
ARDATA ; New AR Category data. (Internal data format)
"RTN","PRCAP338",50,0)
;;Category Name;Abbreviation;AMIS Seg #;GL Number;Type;AR Cat #;Receivable Code;Interest;Admin;Penalty;Accrued;Refund;Paragraph Codes
"RTN","PRCAP338",51,0)
;;CHOICE THIRD PARTY;C1;249;1212;T;50;2;0;0;0;1;2;
"RTN","PRCAP338",52,0)
;;CC THIRD PARTY;C2;249;1212;T;51;2;0;0;0;1;2;
"RTN","PRCAP338",53,0)
;;CCN THIRD PARTY;C3;249;1212;T;52;2;0;0;0;1;2;
"RTN","PRCAP338",54,0)
;;CC MTF THIRD PARTY;C4;249;1212;T;53;2;0;0;0;1;2;
"RTN","PRCAP338",55,0)
;;CHOICE NO-FAULT AUTO;C5;247;1212;T;54;2;0;0;0;1;2;
"RTN","PRCAP338",56,0)
;;CHOICE TORT FEASOR;C6;0;1228;T;55;2;0;0;0;1;2;
"RTN","PRCAP338",57,0)
;;CCN WORKERS' COMP;CD;246;1212;T;56;2;0;0;0;1;2;
"RTN","PRCAP338",58,0)
;;CCN NO-FAULT AUTO;CB;247;1212;T;57;2;0;0;0;1;2;
"RTN","PRCAP338",59,0)
;;CCN TORT FEASOR;CC;0;1228;T;58;2;0;0;0;1;2;
"RTN","PRCAP338",60,0)
;;CC WORKERS' COMP;CA;246;1212;T;59;2;0;0;0;1;2;
"RTN","PRCAP338",61,0)
;;CC NO-FAULT AUTO;C8;247;1212;T;60;2;0;0;0;1;2;
"RTN","PRCAP338",62,0)
;;CC TORT FEASOR;C9;0;1228;T;61;2;0;0;0;1;2;
"RTN","PRCAP338",63,0)
;;CHOICE WORKERS' COMP;C7;246;1212;T;62;2;0;0;0;1;2;
"RTN","PRCAP338",64,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",65,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",66,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",67,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",68,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",69,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",70,0)
;;CC MTF INPT;CX;240;1221;C;69;2;1;1;0;1;2;30,40,55,80,85,50,60,65,70
"RTN","PRCAP338",71,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",72,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",73,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",74,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",75,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",76,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",77,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",78,0)
;;TRICARE DES;T4;0;1311;T;77;2;0;0;0;1;2
"RTN","PRCAP338",79,0)
;;TRICARE SCI;T5;0;1311;T;78;2;0;0;0;1;2
"RTN","PRCAP338",80,0)
;;TRICARE TBI;T6;0;1311;T;79;2;0;0;0;1;2
"RTN","PRCAP338",81,0)
;;TRICARE BLIND REHABILITATION;T7;0;1311;T;80;2;0;0;0;1;2
"RTN","PRCAP338",82,0)
;;TRICARE DENTAL;T8;0;1311;T;81;2;0;0;0;1;2
"RTN","PRCAP338",83,0)
;;TRICARE PHARMACY;T9;0;1311;T;82;2;0;0;0;1;2
"RTN","PRCAP338",84,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",85,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",86,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",87,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",88,0)
;;END
"RTN","PRCAP338",89,0)
;
"RTN","PRCAP338",90,0)
ARCATUPD ; AR CATEGORY ENTRIES (430.2)
"RTN","PRCAP338",91,0)
N LOOP,LIEN,PRCAARY,PRCADATA,PRCAARCT
"RTN","PRCAP338",92,0)
N PRCADMC,PRCATOP,PRCACS
"RTN","PRCAP338",93,0)
N X,Y,DIE,DA,DR,DTOUT,DATA
"RTN","PRCAP338",94,0)
;
"RTN","PRCAP338",95,0)
D MES^XPDUTL(" -> Adding data to the new AR CATEGORY (430.2) fields ...")
"RTN","PRCAP338",96,0)
;Clear the array
"RTN","PRCAP338",97,0)
K PRCAARY
"RTN","PRCAP338",98,0)
; Grab all of the entries to update
"RTN","PRCAP338",99,0)
F LOOP=2:1 S PRCADATA=$T(ARUPDDAT+LOOP) Q:PRCADATA=" ;;END" D
"RTN","PRCAP338",100,0)
. ;Extract the new AR Category to be added.
"RTN","PRCAP338",101,0)
. S PRCAARCT=$P(PRCADATA,";",4)
"RTN","PRCAP338",102,0)
. ;Store in array for adding to the file (#430.2).
"RTN","PRCAP338",103,0)
. S PRCAARY(PRCAARCT)=$P(PRCADATA,";",5,7)
"RTN","PRCAP338",104,0)
;
"RTN","PRCAP338",105,0)
;Loop through all of the entries in the AC xref of the 430.2 file, and update using the built array
"RTN","PRCAP338",106,0)
F LOOP=1:1:86 D
"RTN","PRCAP338",107,0)
. S DATA=$G(PRCAARY(LOOP))
"RTN","PRCAP338",108,0)
. Q:DATA="" ;go to next entry if Category is not to be updated.
"RTN","PRCAP338",109,0)
. S LIEN=$O(^PRCA(430.2,"AC",LOOP,""))
"RTN","PRCAP338",110,0)
. Q:LIEN=""
"RTN","PRCAP338",111,0)
. S PRCADMC=$P(DATA,";",1)
"RTN","PRCAP338",112,0)
. S PRCATOP=$P(DATA,";",2)
"RTN","PRCAP338",113,0)
. S PRCACS=$P(DATA,";",3)
"RTN","PRCAP338",114,0)
. ;
"RTN","PRCAP338",115,0)
. ; File the update
"RTN","PRCAP338",116,0)
. S DR="1.01////"_PRCADMC_";"
"RTN","PRCAP338",117,0)
. S DR=DR_"1.02////"_PRCATOP_";"
"RTN","PRCAP338",118,0)
. S DR=DR_"1.03////"_PRCACS_";"
"RTN","PRCAP338",119,0)
. Q:DR=""
"RTN","PRCAP338",120,0)
. S DIE="^PRCA(430.2,",DA=LIEN
"RTN","PRCAP338",121,0)
. D ^DIE
"RTN","PRCAP338",122,0)
. K DR ;Clear update array before next use
"RTN","PRCAP338",123,0)
;
"RTN","PRCAP338",124,0)
S DR=""
"RTN","PRCAP338",125,0)
D MES^XPDUTL(" Data added to the new AR CATEGORY (430.2) fields.")
"RTN","PRCAP338",126,0)
Q
"RTN","PRCAP338",127,0)
;
"RTN","PRCAP338",128,0)
ARUPDDAT ; Data for the new AR Category fields. (All categories will be updated)
"RTN","PRCAP338",129,0)
;;Category Name;Category Num;DMC?;TOP?;CS?
"RTN","PRCAP338",130,0)
;;ADULT DAY HEALTH CARE;40;1;2;3
"RTN","PRCAP338",131,0)
;;C (MEANS TEST);24;1;2;3
"RTN","PRCAP338",132,0)
;;CHAMPVA;36;0;0;0
"RTN","PRCAP338",133,0)
;;CHAMPVA SUBSISTENCE;34;0;0;0
"RTN","PRCAP338",134,0)
;;CHAMPVA THIRD PARTY;35;0;0;0
"RTN","PRCAP338",135,0)
;;COMP & PEN PROCEEDS;8;0;0;0
"RTN","PRCAP338",136,0)
;;CRIME OF PER.VIO.;27;0;0;0
"RTN","PRCAP338",137,0)
;;CURRENT EMP.;14;0;1;0
"RTN","PRCAP338",138,0)
;;CWT PROCEEDS;7;0;0;0
"RTN","PRCAP338",139,0)
;;DOMICILIARY;41;1;2;3
"RTN","PRCAP338",140,0)
;;EMERGENCY/HUMANITARIAN;25;0;1;0
"RTN","PRCAP338",141,0)
;;EMERGENCY/HUMANITARIAN REIMB.;48;0;0;0
"RTN","PRCAP338",142,0)
;;ENHANCED USE LEASE PROCEEDS;10;0;1;0
"RTN","PRCAP338",143,0)
;;EX-EMPLOYEE;13;0;1;0
"RTN","PRCAP338",144,0)
;;FEDERAL AGENCIES-REFUND;15;0;0;0
"RTN","PRCAP338",145,0)
;;FEDERAL AGENCIES-REIMB.;16;0;0;0
"RTN","PRCAP338",146,0)
;;FEE REIMB INS;47;0;0;0
"RTN","PRCAP338",147,0)
;;GERIATRIC EVAL-INSTITUTIONAL;44;1;2;3
"RTN","PRCAP338",148,0)
;;GERIATRIC EVAL-NON-INSTITUTION;45;1;2;3
"RTN","PRCAP338",149,0)
;;HOSPITAL CARE (NSC);1;1;2;3
"RTN","PRCAP338",150,0)
;;HOSPITAL CARE PER DIEM;32;1;2;3
"RTN","PRCAP338",151,0)
;;INELIGIBLE HOSP.;20;0;1;0
"RTN","PRCAP338",152,0)
;;INELIGIBLE HOSP. REIMB.;49;0;0;0
"RTN","PRCAP338",153,0)
;;INTERAGENCY;19;0;0;0
"RTN","PRCAP338",154,0)
;;MEDICARE;28;0;0;0
"RTN","PRCAP338",155,0)
;;MILITARY;17;0;0;0
"RTN","PRCAP338",156,0)
;;NO-FAULT AUTO ACC.;26;0;0;0
"RTN","PRCAP338",157,0)
;;NURSING HOME CARE PER DIEM;31;1;2;3
"RTN","PRCAP338",158,0)
;;NURSING HOME CARE(NSC);3;1;2;3
"RTN","PRCAP338",159,0)
;;NURSING HOME CARE-LTC;46;1;2;3
"RTN","PRCAP338",160,0)
;;NURSING HOME PROCEEDS;5;1;2;3
"RTN","PRCAP338",161,0)
;;OUTPATIENT CARE(NSC);2;1;2;3
"RTN","PRCAP338",162,0)
;;PARKING FEES;6;0;1;0
"RTN","PRCAP338",163,0)
;;PREPAYMENT;33;0;0;0
"RTN","PRCAP338",164,0)
;;REIMBURS.HEALTH INS;21;0;0;0
"RTN","PRCAP338",165,0)
;;RESPITE CARE-INSTITUTIONAL;42;1;2;3
"RTN","PRCAP338",166,0)
;;RESPITE CARE-NON-INSTITUTIONAL;43;1;2;3
"RTN","PRCAP338",167,0)
;;RX CO-PAYMENT/NSC VET;30;1;2;3
"RTN","PRCAP338",168,0)
;;RX CO-PAYMENT/SC VET;29;1;2;3
"RTN","PRCAP338",169,0)
;;SHARING AGREEMENTS;18;0;1;0
"RTN","PRCAP338",170,0)
;;TORT FEASOR;22;0;0;0
"RTN","PRCAP338",171,0)
;;TRICARE;37;0;0;0
"RTN","PRCAP338",172,0)
;;TRICARE PATIENT;38;1;2;3
"RTN","PRCAP338",173,0)
;;TRICARE THIRD PARTY;39;0;0;0
"RTN","PRCAP338",174,0)
;;VENDOR;11;0;1;0
"RTN","PRCAP338",175,0)
;;WORKMAN'S COMP.;23;0;0;0
"RTN","PRCAP338",176,0)
;;CHOICE THIRD PARTY;50;0;0;0
"RTN","PRCAP338",177,0)
;;CC THIRD PARTY;51;0;0;0
"RTN","PRCAP338",178,0)
;;CCN THIRD PARTY;52;0;0;0
"RTN","PRCAP338",179,0)
;;CC MTF THIRD PARTY;53;0;0;0
"RTN","PRCAP338",180,0)
;;CHOICE NO-FAULT AUTO;54;0;0;0
"RTN","PRCAP338",181,0)
;;CHOICE TORT FEASOR;55;0;0;0
"RTN","PRCAP338",182,0)
;;CCN WORKERS' COMP;56;0;0;0
"RTN","PRCAP338",183,0)
;;CCN NO-FAULT AUTO;57;0;0;0
"RTN","PRCAP338",184,0)
;;CCN TORT FEASOR;58;0;0;0
"RTN","PRCAP338",185,0)
;;CC WORKERS' COMP;59;0;0;0
"RTN","PRCAP338",186,0)
;;CC NO-FAULT AUTO;60;0;0;0
"RTN","PRCAP338",187,0)
;;CC TORT FEASOR;61;0;0;0
"RTN","PRCAP338",188,0)
;;CHOICE WORKERS' COMP;62;0;0;0
"RTN","PRCAP338",189,0)
;;CHOICE C (MEANS TEST);63;1;2;3
"RTN","PRCAP338",190,0)
;;CHOICE RX CO-PAYMENT;64;1;2;3
"RTN","PRCAP338",191,0)
;;CC C (MEANS TEST);65;1;2;3
"RTN","PRCAP338",192,0)
;;CC RX CO-PAYMENT;66;1;2;3
"RTN","PRCAP338",193,0)
;;CCN C (MEANS TEST);67;1;2;3
"RTN","PRCAP338",194,0)
;;CCN RX CO-PAYMENT;68;1;2;3
"RTN","PRCAP338",195,0)
;;CC MTF C (MEANS TEST);69;1;2;3
"RTN","PRCAP338",196,0)
;;CC MTF RX CO-PAYMENT;70;1;2;3
"RTN","PRCAP338",197,0)
;;CC NURSING HOME CARE - LTC;71;1;2;3
"RTN","PRCAP338",198,0)
;;CC RESPITE CARE;72;1;2;3
"RTN","PRCAP338",199,0)
;;CCN NURSING HOME CARE - LTC;73;1;2;3
"RTN","PRCAP338",200,0)
;;CCN RESPITE CARE;74;1;2;3
"RTN","PRCAP338",201,0)
;;CHOICE NURSING HOME CARE - LTC;75;1;2;3
"RTN","PRCAP338",202,0)
;;CHOICE RESPITE CARE;76;1;2;3
"RTN","PRCAP338",203,0)
;;TRICARE DES;77;0;0;0
"RTN","PRCAP338",204,0)
;;TRICARE SCI;78;0;0;0
"RTN","PRCAP338",205,0)
;;TRICARE TBI;79;0;0;0
"RTN","PRCAP338",206,0)
;;TRICARE BLIND REHABILITATION;80;0;0;0
"RTN","PRCAP338",207,0)
;;TRICARE DENTAL;81;0;0;0
"RTN","PRCAP338",208,0)
;;TRICARE PHARMACY;82;0;0;0
"RTN","PRCAP338",209,0)
;;CHOICE OPT;83;1;2;3
"RTN","PRCAP338",210,0)
;;CC OPT;84;1;2;3
"RTN","PRCAP338",211,0)
;;CCN OPT;85;1;2;3
"RTN","PRCAP338",212,0)
;;CC MTF OPT;86;1;2;3
"RTN","PRCAP338",213,0)
;;END
"RTN","PRCAP338",214,0)
;
"RTN","PRCAP338",215,0)
CHRGUPD ; Update the charge flags
"RTN","PRCAP338",216,0)
N RCLOOP,RCIEN,RCDATA,RCINT,RCADMIN,RCPEN,RCCAT
"RTN","PRCAP338",217,0)
N X,Y,DIE,DA,DR,DTOUT
"RTN","PRCAP338",218,0)
;
"RTN","PRCAP338",219,0)
D MES^XPDUTL(" -> Updating Charge flags in select AR CATEGORY (430.2) entries ...")
"RTN","PRCAP338",220,0)
;Clear the array
"RTN","PRCAP338",221,0)
K PRCAARY
"RTN","PRCAP338",222,0)
; Grab all of the entries to update
"RTN","PRCAP338",223,0)
F RCLOOP=1:1 S RCDATA=$T(CUPDDT+RCLOOP) Q:RCDATA=" ;;END" D
"RTN","PRCAP338",224,0)
. S RCCAT=$P(RCDATA,";",4)
"RTN","PRCAP338",225,0)
. S RCIEN=$O(^PRCA(430.2,"AC",RCCAT,""))
"RTN","PRCAP338",226,0)
. Q:RCIEN=""
"RTN","PRCAP338",227,0)
. S RCINT=$P(RCDATA,";",5)
"RTN","PRCAP338",228,0)
. S RCADMIN=$P(RCDATA,";",6)
"RTN","PRCAP338",229,0)
. S RCPEN=$P(RCDATA,";",7)
"RTN","PRCAP338",230,0)
. ;
"RTN","PRCAP338",231,0)
. ; File the update
"RTN","PRCAP338",232,0)
. S DR="9////"_RCINT_";"
"RTN","PRCAP338",233,0)
. S DR=DR_"10////"_RCADMIN_";"
"RTN","PRCAP338",234,0)
. S DR=DR_"11////"_RCPEN_";"
"RTN","PRCAP338",235,0)
. Q:DR=""
"RTN","PRCAP338",236,0)
. S DIE="^PRCA(430.2,",DA=RCIEN
"RTN","PRCAP338",237,0)
. D ^DIE
"RTN","PRCAP338",238,0)
. K DR ;Clear update array before next use
"RTN","PRCAP338",239,0)
;
"RTN","PRCAP338",240,0)
S DR=""
"RTN","PRCAP338",241,0)
D MES^XPDUTL(" Charge Flags in select AR CATEGORY (430.2) entries.")
"RTN","PRCAP338",242,0)
Q
"RTN","PRCAP338",243,0)
;
"RTN","PRCAP338",244,0)
CUPDDT ; Charge flag update data
"RTN","PRCAP338",245,0)
;;ADULT DAY HEALTH CARE;40;1;1;0
"RTN","PRCAP338",246,0)
;;COMP & PEN PROCEEDS;8;0;0;0
"RTN","PRCAP338",247,0)
;;CRIME OF PER.VIO.;27;0;0;0
"RTN","PRCAP338",248,0)
;;CWT PROCEEDS;7;0;0;0
"RTN","PRCAP338",249,0)
;;DOMICILIARY;41;1;1;0
"RTN","PRCAP338",250,0)
;;GERIATRIC EVAL-INSTITUTIONAL;44;1;1;0
"RTN","PRCAP338",251,0)
;;GERIATRIC EVAL-NON-INSTITUTION;45;1;1;0
"RTN","PRCAP338",252,0)
;;NO-FAULT AUTO ACC.;26;0;0;0
"RTN","PRCAP338",253,0)
;;NURSING HOME CARE-LTC;46;1;1;0
"RTN","PRCAP338",254,0)
;;NURSING HOME PROCEEDS;5;0;0;0
"RTN","PRCAP338",255,0)
;;RESPITE CARE-INSTITUTIONAL;42;1;1;0
"RTN","PRCAP338",256,0)
;;RESPITE CARE-NON-INSTITUTIONAL;43;1;1;0
"RTN","PRCAP338",257,0)
;;TORT FEASOR;22;0;0;0
"RTN","PRCAP338",258,0)
;;END
"RTN","PRCASVC")
0^15^B26610920
"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 17
"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")=77 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")=78 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")=79 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")=80 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")=81 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")=82 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^B104925198
"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,338**;Mar 20, 1995;Build 17
"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)
; ask to enter adjustment amount
"RTN","RCBEADJ",102,0)
S RCAMOUNT=$$AMOUNT(RCBILLDA,RCBETYPE)
"RTN","RCBEADJ",103,0)
I RCAMOUNT<0 D UNLOCK Q
"RTN","RCBEADJ",104,0)
;
"RTN","RCBEADJ",105,0)
; if decrease, make negative
"RTN","RCBEADJ",106,0)
I RCBETYPE="DECREASE" S RCAMOUNT=-RCAMOUNT
"RTN","RCBEADJ",107,0)
;
"RTN","RCBEADJ",108,0)
; ask if it is a contract adjustment (Community Care added check for all 3rd party categories PRCA*4.5*338)
"RTN","RCBEADJ",109,0)
I RCBETYPE="DECREASE",$$THRDPRTY(RCBILLDA) S RCONTADJ=$$ASKCONT I RCONTADJ<0 D UNLOCK Q
"RTN","RCBEADJ",110,0)
;
"RTN","RCBEADJ",111,0)
; show what the new transaction will look like
"RTN","RCBEADJ",112,0)
S RCDATA7=$G(^PRCA(430,RCBILLDA,7))
"RTN","RCBEADJ",113,0)
W !!,"If you process the transaction, the bill will look like:"
"RTN","RCBEADJ",114,0)
W !,"Current Principal Balance: ",$J($P(RCDATA7,"^"),11,2)
"RTN","RCBEADJ",115,0)
W !," NEW ",RCBETYPE," Adjustment: ",$J(RCAMOUNT,11,2)
"RTN","RCBEADJ",116,0)
W !," -----------"
"RTN","RCBEADJ",117,0)
W !," NEW Principal Balance: ",$J($P(RCDATA7,"^")+RCAMOUNT,11,2)
"RTN","RCBEADJ",118,0)
;
"RTN","RCBEADJ",119,0)
; ask to enter transaction
"RTN","RCBEADJ",120,0)
S Y=$$ASKOK(RCBETYPE) I Y'=1 D UNLOCK Q
"RTN","RCBEADJ",121,0)
;
"RTN","RCBEADJ",122,0)
ADDADJ ; add adjustment
"RTN","RCBEADJ",123,0)
S RCTRANDA=$$INCDEC^RCBEUTR1(RCBILLDA,RCAMOUNT,"","","",$G(RCONTADJ))
"RTN","RCBEADJ",124,0)
I 'RCTRANDA W !," *** W A R N I N G: Adjustment NOT Processed! ***" D UNLOCK Q
"RTN","RCBEADJ",125,0)
I RCTRANDA W !," Adjustment Transaction: ",RCTRANDA," has been added."
"RTN","RCBEADJ",126,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",127,0)
I RCTRANDA,$G(RCTRREV)=0 S PRCABN=RCBILLDA D CSITRN^RCTCSPD5
"RTN","RCBEADJ",128,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",129,0)
I $G(RCTRREV)=1 S PRCABN=RCBILLDA D CSITRY^RCTCSPD5
"RTN","RCBEADJ",130,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",131,0)
;
"RTN","RCBEADJ",132,0)
; ask to enter a comment
"RTN","RCBEADJ",133,0)
W !!,"Enter a comment for the ",RCBETYPE," Adjustment:"
"RTN","RCBEADJ",134,0)
S Y=$$EDIT433^RCBEUTRA(RCTRANDA,"41;")
"RTN","RCBEADJ",135,0)
;
"RTN","RCBEADJ",136,0)
; ask to exempt interest and admin charges
"RTN","RCBEADJ",137,0)
I RCBETYPE="DECREASE" D INTADMIN(RCBILLDA)
"RTN","RCBEADJ",138,0)
;
"RTN","RCBEADJ",139,0)
; notification of subsequent payer bulletin
"RTN","RCBEADJ",140,0)
S RCDATA7=$G(^PRCA(430,RCBILLDA,7)),X=0
"RTN","RCBEADJ",141,0)
F I=1:1:5 S X=X+$P(RCDATA7,"^",I)
"RTN","RCBEADJ",142,0)
I RCDATA7'="",'X D
"RTN","RCBEADJ",143,0)
. N PRCABN,PRCAEN,PRCAMT
"RTN","RCBEADJ",144,0)
. S PRCABN=RCBILLDA,PRCAEN=RCTRANDA,PRCAMT=+$P($G(^PRCA(433,RCTRANDA,1)),"^",5)
"RTN","RCBEADJ",145,0)
. D EOB^PRCADJ
"RTN","RCBEADJ",146,0)
;
"RTN","RCBEADJ",147,0)
; unlock and ask the next bill to adjust
"RTN","RCBEADJ",148,0)
D UNLOCK
"RTN","RCBEADJ",149,0)
Q
"RTN","RCBEADJ",150,0)
;
"RTN","RCBEADJ",151,0)
;
"RTN","RCBEADJ",152,0)
UNLOCK ; unlock bill and transaction
"RTN","RCBEADJ",153,0)
L -^PRCA(430,RCBILLDA)
"RTN","RCBEADJ",154,0)
I $G(RCTRANDA) L -^PRCA(433,RCTRANDA)
"RTN","RCBEADJ",155,0)
Q
"RTN","RCBEADJ",156,0)
;
"RTN","RCBEADJ",157,0)
;
"RTN","RCBEADJ",158,0)
INTADMIN(RCBILLDA) ; ask and adjust the interest and admin
"RTN","RCBEADJ",159,0)
N RCAMOUNT,RCTRANDA,Y
"RTN","RCBEADJ",160,0)
;
"RTN","RCBEADJ",161,0)
; check to see if there is interest and admin charges
"RTN","RCBEADJ",162,0)
S RCAMOUNT=$G(^PRCA(430,RCBILLDA,7))
"RTN","RCBEADJ",163,0)
I '$P(RCAMOUNT,"^",2),'$P(RCAMOUNT,"^",3),'$P(RCAMOUNT,"^",4),'$P(RCAMOUNT,"^",5) Q
"RTN","RCBEADJ",164,0)
;
"RTN","RCBEADJ",165,0)
; only ask if there is no principal
"RTN","RCBEADJ",166,0)
I RCAMOUNT Q
"RTN","RCBEADJ",167,0)
;
"RTN","RCBEADJ",168,0)
W !!,"You have the option to automatically EXEMPT the interest"
"RTN","RCBEADJ",169,0)
W !,"and administrative charges. This will close the bill."
"RTN","RCBEADJ",170,0)
S Y=$$ASKEXEMP I Y'=1 Q
"RTN","RCBEADJ",171,0)
;
"RTN","RCBEADJ",172,0)
W !!,"Creating an EXEMPT transaction ..."
"RTN","RCBEADJ",173,0)
S RCTRANDA=$$EXEMPT^RCBEUTR2(RCBILLDA,$P(RCAMOUNT,"^",2)_"^"_$P(RCAMOUNT,"^",3)_"^^"_$P(RCAMOUNT,"^",4)_"^"_$P(RCAMOUNT,"^",5))
"RTN","RCBEADJ",174,0)
I 'RCTRANDA W !," *** W A R N I N G: EXEMPTION NOT Processed! ***" Q
"RTN","RCBEADJ",175,0)
I RCTRANDA W !," Exempt Transaction: ",RCTRANDA," has been added."
"RTN","RCBEADJ",176,0)
INTC35B ;Check if CS5B entry needed for exempt transaction
"RTN","RCBEADJ",177,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",178,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",179,0)
;
"RTN","RCBEADJ",180,0)
W !," Current Bill Status: ",$P($G(^PRCA(430.3,+$P($G(^PRCA(430,RCBILLDA,0)),"^",8),0)),"^")
"RTN","RCBEADJ",181,0)
Q
"RTN","RCBEADJ",182,0)
;
"RTN","RCBEADJ",183,0)
ASKOK(RCBETYPE) ; ask record decrease or increase transaction
"RTN","RCBEADJ",184,0)
N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
"RTN","RCBEADJ",185,0)
S DIR(0)="YO",DIR("B")="YES"
"RTN","RCBEADJ",186,0)
S DIR("A")="Are you sure you want to enter this "_RCBETYPE_" adjustment "
"RTN","RCBEADJ",187,0)
W ! D ^DIR
"RTN","RCBEADJ",188,0)
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
"RTN","RCBEADJ",189,0)
Q Y
"RTN","RCBEADJ",190,0)
;
"RTN","RCBEADJ",191,0)
ASKAUPO() ; ask record even though marked for auto post PRCA*4.5*298
"RTN","RCBEADJ",192,0)
N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
"RTN","RCBEADJ",193,0)
S DIR(0)="YOA",DIR("B")="NO"
"RTN","RCBEADJ",194,0)
S DIR("A")="Marked for Auto-Post. Are you sure? (Y/N) "
"RTN","RCBEADJ",195,0)
W ! D ^DIR
"RTN","RCBEADJ",196,0)
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
"RTN","RCBEADJ",197,0)
Q Y
"RTN","RCBEADJ",198,0)
;
"RTN","RCBEADJ",199,0)
ASKFIX() ; ask to fix bill's balance
"RTN","RCBEADJ",200,0)
N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
"RTN","RCBEADJ",201,0)
S DIR(0)="YO",DIR("B")="YES"
"RTN","RCBEADJ",202,0)
S DIR("A")=" Do you want to FIX the balance discrepancy "
"RTN","RCBEADJ",203,0)
W ! D ^DIR
"RTN","RCBEADJ",204,0)
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
"RTN","RCBEADJ",205,0)
Q Y
"RTN","RCBEADJ",206,0)
;
"RTN","RCBEADJ",207,0)
;
"RTN","RCBEADJ",208,0)
ASKEXEMP() ; ask to record an exempt transaction
"RTN","RCBEADJ",209,0)
N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
"RTN","RCBEADJ",210,0)
S DIR(0)="YO",DIR("B")="NO"
"RTN","RCBEADJ",211,0)
S DIR("A")=" Would you like to EXEMPT the interest and admin charges "
"RTN","RCBEADJ",212,0)
D ^DIR
"RTN","RCBEADJ",213,0)
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
"RTN","RCBEADJ",214,0)
Q Y
"RTN","RCBEADJ",215,0)
;
"RTN","RCBEADJ",216,0)
;
"RTN","RCBEADJ",217,0)
ASKCONT() ; ask if contract adjustment
"RTN","RCBEADJ",218,0)
N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
"RTN","RCBEADJ",219,0)
S DIR(0)="YO",DIR("B")="YES"
"RTN","RCBEADJ",220,0)
S DIR("A")=" Is this a CONTRACT adjustment "
"RTN","RCBEADJ",221,0)
W ! D ^DIR
"RTN","RCBEADJ",222,0)
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
"RTN","RCBEADJ",223,0)
Q Y
"RTN","RCBEADJ",224,0)
;
"RTN","RCBEADJ",225,0)
;
"RTN","RCBEADJ",226,0)
ASKREV() ; Ask if Treasury reversal *315/DRF
"RTN","RCBEADJ",227,0)
N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
"RTN","RCBEADJ",228,0)
S DIR(0)="YO",DIR("B")="NO"
"RTN","RCBEADJ",229,0)
S DIR("A")=" Is this a TREASURY reversal "
"RTN","RCBEADJ",230,0)
W ! D ^DIR
"RTN","RCBEADJ",231,0)
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
"RTN","RCBEADJ",232,0)
Q Y
"RTN","RCBEADJ",233,0)
;
"RTN","RCBEADJ",234,0)
;
"RTN","RCBEADJ",235,0)
ADJNUM(RCBILLDA) ; get next adjustment number for a bill
"RTN","RCBEADJ",236,0)
N %,ADJUST,DATA1,RCTRANDA
"RTN","RCBEADJ",237,0)
S RCTRANDA=0
"RTN","RCBEADJ",238,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",239,0)
Q ADJUST
"RTN","RCBEADJ",240,0)
;
"RTN","RCBEADJ",241,0)
;
"RTN","RCBEADJ",242,0)
AMOUNT(RCBILLDA,RCBETYPE) ; enter the adjustment amount for a bill
"RTN","RCBEADJ",243,0)
N DIR,DIRUT,DTOUT,DUOUT,PRINBAL,X,Y
"RTN","RCBEADJ",244,0)
S PRINBAL=+$P($G(^PRCA(430,RCBILLDA,7)),"^")
"RTN","RCBEADJ",245,0)
I RCBETYPE="INCREASE" S PRINBAL=9999999.99
"RTN","RCBEADJ",246,0)
W !!,"Enter the ",RCBETYPE," Adjustment AMOUNT, from .01 to ",$J(PRINBAL,0,2),"."
"RTN","RCBEADJ",247,0)
S DIR(0)="NAO^.01:"_PRINBAL_":2"
"RTN","RCBEADJ",248,0)
S DIR("A")=" "_RCBETYPE_" PRINCIPAL BALANCE BY: "
"RTN","RCBEADJ",249,0)
D ^DIR
"RTN","RCBEADJ",250,0)
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
"RTN","RCBEADJ",251,0)
Q $S(Y'="":Y,1:-1)
"RTN","RCBEADJ",252,0)
;
"RTN","RCBEADJ",253,0)
;
"RTN","RCBEADJ",254,0)
ASKCM() ; ask if the action is being performed due to the claims matching process *315
"RTN","RCBEADJ",255,0)
N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
"RTN","RCBEADJ",256,0)
S DIR(0)="YO",DIR("B")="NO"
"RTN","RCBEADJ",257,0)
S DIR("A")="Is this action being performed due to the CLAIMS MATCHING process "
"RTN","RCBEADJ",258,0)
D ^DIR
"RTN","RCBEADJ",259,0)
I $G(DTOUT)!($G(DUOUT)) S Y=-1 I $G(GOTBILL) S RCDPGQ=1 ; account profile listman quit flag *315
"RTN","RCBEADJ",260,0)
Q Y
"RTN","RCBEADJ",261,0)
;
"RTN","RCBEADJ",262,0)
;
"RTN","RCBEADJ",263,0)
THRDPRTY(RCBILLDA) ; check whether or not bill is THIRD PARTY
"RTN","RCBEADJ",264,0)
N CAT
"RTN","RCBEADJ",265,0)
S CAT=$$GET1^DIQ(430,RCBILLDA,2,"I") ; get account receivable category
"RTN","RCBEADJ",266,0)
I $$GET1^DIQ(430.2,CAT,5,"I")="T" Q 1 ; return true if the account receivable category is THIRD PARTY
"RTN","RCBEADJ",267,0)
Q 0
"RTN","RCBEADJ",268,0)
;
"RTN","RCDMC90")
0^13^B63501721
"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 17
"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","RCRJRBD")
0^8^B84210608
"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,338**;Mar 20, 1995;Build 17
"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)
. . S FUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
"RTN","RCRJRBD",42,0)
. . I '$$PTACCT^PRCAACC(FUND),$E(FUND,1,4)'=4032 Q
"RTN","RCRJRBD",43,0)
. . ;
"RTN","RCRJRBD",44,0)
. . ; determine MRA type of bill, given bill# and bill active date
"RTN","RCRJRBD",45,0)
. . ; DBIA #4385 activated on 31-Mar-2004
"RTN","RCRJRBD",46,0)
. . S MRATYPE=$$MRATYPE^IBCEMU2(BILLDA,ACTDATE)
"RTN","RCRJRBD",47,0)
. . ;
"RTN","RCRJRBD",48,0)
. . ; derive standard general ledger (SGL) from cat/fund/MRA type
"RTN","RCRJRBD",49,0)
. . S SGL=$$BDRSGL(CATEGORY,FUND,MRATYPE)
"RTN","RCRJRBD",50,0)
. . ;
"RTN","RCRJRBD",51,0)
. . ; determine the original amount of the bill (add increase
"RTN","RCRJRBD",52,0)
. . ; adjustments below)
"RTN","RCRJRBD",53,0)
. . S PRIN=$P($G(^PRCA(430,BILLDA,0)),"^",3)
"RTN","RCRJRBD",54,0)
. . S PAY=0
"RTN","RCRJRBD",55,0)
. . ;
"RTN","RCRJRBD",56,0)
. . ; get the $ transations for bills
"RTN","RCRJRBD",57,0)
. . S TRANDA=0
"RTN","RCRJRBD",58,0)
. . F S TRANDA=$O(^PRCA(433,"C",BILLDA,TRANDA)) Q:'TRANDA D
"RTN","RCRJRBD",59,0)
. . . S TRANTYPE=$P($G(^PRCA(433,TRANDA,1)),"^",2)
"RTN","RCRJRBD",60,0)
. . . I "^1^2^34^43^"'[("^"_TRANTYPE_"^") Q
"RTN","RCRJRBD",61,0)
. . . S VALUE=$$TRANBAL^RCRJRCOT(TRANDA) I VALUE="" Q
"RTN","RCRJRBD",62,0)
. . . ; increase adjustments or re-establish
"RTN","RCRJRBD",63,0)
. . . I TRANTYPE=1!(TRANTYPE=43) S PRIN=PRIN+$P(VALUE,"^") Q
"RTN","RCRJRBD",64,0)
. . . ; payments
"RTN","RCRJRBD",65,0)
. . . I TRANTYPE=2!(TRANTYPE=34) S PAY=PAY+$P(VALUE,"^") Q
"RTN","RCRJRBD",66,0)
. . ;
"RTN","RCRJRBD",67,0)
. . ; payment cannot be greater than principle
"RTN","RCRJRBD",68,0)
. . I PAY>PRIN S PAY=PRIN
"RTN","RCRJRBD",69,0)
. . ;
"RTN","RCRJRBD",70,0)
. . ; store the data
"RTN","RCRJRBD",71,0)
. . S PRINCPAL(SGL)=$G(PRINCPAL(SGL))+PRIN
"RTN","RCRJRBD",72,0)
. . S PAYMENT(SGL)=$G(PAYMENT(SGL))+PAY
"RTN","RCRJRBD",73,0)
. . ;
"RTN","RCRJRBD",74,0)
;
"RTN","RCRJRBD",75,0)
; calculate the writeoffs from 2/0/98
"RTN","RCRJRBD",76,0)
; 2/0/98 is when fms cleared out actual writeoffs and contract adj
"RTN","RCRJRBD",77,0)
K ^XTMP("PRCABDET")
"RTN","RCRJRBD",78,0)
S ^XTMP("PRCABDET",0)=$$FMADD^XLFDT(DT,10)_"^"_DT_"^BAD DEBT REPORT AUDIT"
"RTN","RCRJRBD",79,0)
F TRANTYPE=8,9,10,11,35 D
"RTN","RCRJRBD",80,0)
. S TRANDATE=2980200
"RTN","RCRJRBD",81,0)
. ; do not pick up transactions after the end date
"RTN","RCRJRBD",82,0)
. F S TRANDATE=$O(^PRCA(433,"AT",TRANTYPE,TRANDATE)) Q:'TRANDATE!($P(TRANDATE,".")>DATEEND) D
"RTN","RCRJRBD",83,0)
. . S TRANDA=0 F S TRANDA=$O(^PRCA(433,"AT",TRANTYPE,TRANDATE,TRANDA)) Q:'TRANDA D
"RTN","RCRJRBD",84,0)
. . . ; do not look at decrease adj which are not contract adj
"RTN","RCRJRBD",85,0)
. . . I TRANTYPE=35,'$P($G(^PRCA(433,TRANDA,8)),"^",8) Q
"RTN","RCRJRBD",86,0)
. . . ;
"RTN","RCRJRBD",87,0)
. . . S BILLDA=$P($G(^PRCA(433,TRANDA,0)),"^",2)
"RTN","RCRJRBD",88,0)
. . . I 'BILLDA Q
"RTN","RCRJRBD",89,0)
. . . S CATEGORY=+$P($G(^PRCA(430,BILLDA,0)),"^",2)
"RTN","RCRJRBD",90,0)
. . . ; do not look at prepayments
"RTN","RCRJRBD",91,0)
. . . I 'CATEGORY!(CATEGORY=26) Q
"RTN","RCRJRBD",92,0)
. . . ;
"RTN","RCRJRBD",93,0)
. . . ; only report fund 528701,03,04,11 and 4032/528709 (ltc) bills
"RTN","RCRJRBD",94,0)
. . . S FUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
"RTN","RCRJRBD",95,0)
. . . I '$$PTACCT^PRCAACC(FUND),$E(FUND,1,4)'=4032 Q
"RTN","RCRJRBD",96,0)
. . . ;
"RTN","RCRJRBD",97,0)
. . . ; get bill active date
"RTN","RCRJRBD",98,0)
. . . S ARACTDT=+$P($P($G(^PRCA(430,BILLDA,6)),"^",21),".")
"RTN","RCRJRBD",99,0)
. . . ; determine MRA type of bill, given bill# and bill active date
"RTN","RCRJRBD",100,0)
. . . ; DBIA #4385 activated on 31-Mar-2004
"RTN","RCRJRBD",101,0)
. . . S MRATYPE=$$MRATYPE^IBCEMU2(BILLDA,ARACTDT)
"RTN","RCRJRBD",102,0)
. . . ;
"RTN","RCRJRBD",103,0)
. . . ; derive standard general ledger (SGL) from cat/fund/MRA type
"RTN","RCRJRBD",104,0)
. . . S SGL=$$BDRSGL(CATEGORY,FUND,MRATYPE)
"RTN","RCRJRBD",105,0)
. . . ;
"RTN","RCRJRBD",106,0)
. . . ; get the principal transaction value
"RTN","RCRJRBD",107,0)
. . . S RCVALUE=+$P($$TRANBAL^RCRJRCOT(TRANDA),"^")
"RTN","RCRJRBD",108,0)
. . . ; temp variable for value (used below)
"RTN","RCRJRBD",109,0)
. . . S RCPRIN=RCVALUE
"RTN","RCRJRBD",110,0)
. . . ;
"RTN","RCRJRBD",111,0)
. . . ; add actual writeoff amount for fiscal year
"RTN","RCRJRBD",112,0)
. . . I TRANTYPE'=35 S ACTUALWO(SGL)=$G(ACTUALWO(SGL))+RCVALUE
"RTN","RCRJRBD",113,0)
. . . ; add actual contract adjustments for fiscal year
"RTN","RCRJRBD",114,0)
. . . I TRANTYPE=35 S ACTUALCA(SGL)=$G(ACTUALCA(SGL))+RCVALUE
"RTN","RCRJRBD",115,0)
. . . S RSC=$$CALCRSC^RCXFMSUR(BILLDA)
"RTN","RCRJRBD",116,0)
. . . S ^XTMP("PRCABDET",BILLDA,CATEGORY,FUND,RSC,SGL,TRANDA,TRANDATE,TRANTYPE,RCPRIN,RCVALUE,0,0)=""
"RTN","RCRJRBD",117,0)
;
"RTN","RCRJRBD",118,0)
; remove all the entries from the bad debt file
"RTN","RCRJRBD",119,0)
D DELETALL
"RTN","RCRJRBD",120,0)
;
"RTN","RCRJRBD",121,0)
; calculate percentages and store them
"RTN","RCRJRBD",122,0)
F SGL=1319,1319.2,1319.3,1319.4,1319.5,1319.6,1338,1338.2,1338.3,1339,1339.1,"133N","133N.2","133.N3" D
"RTN","RCRJRBD",123,0)
. ; collection %
"RTN","RCRJRBD",124,0)
. S COLLECT=0 I $G(PRINCPAL(SGL)) S COLLECT=$J($G(PAYMENT(SGL))/PRINCPAL(SGL)*100,0,2)
"RTN","RCRJRBD",125,0)
. ; patch PRCA*4.5*138: for the first year from when MRA is activated at a site, there is no collection
"RTN","RCRJRBD",126,0)
. ; history for post-MRA non-Medicare bills(SGL 133N). So, to calculate the percentage for SGL 133N, the
"RTN","RCRJRBD",127,0)
. ; payment and the principal for SGL 1339 are used in the first year.
"RTN","RCRJRBD",128,0)
. ; override the collection value for SGL=133N for the first year from MRA activation.
"RTN","RCRJRBD",129,0)
. ;; Re-evaluate the calc. of the percentage for 133N as well as 1339.
"RTN","RCRJRBD",130,0)
. ;;I SGL="133N",$G(PRINCIPAL(1339)) D ;
"RTN","RCRJRBD",131,0)
. ;;. N X1,X2,X,%Y
"RTN","RCRJRBD",132,0)
. ;;. ; X2=MRA Activation Date, X1=Today, X=diff in days, %Y=0 invalid dates
"RTN","RCRJRBD",133,0)
. ;;. ; DBIA #4385 activated on 31-Mar-2004
"RTN","RCRJRBD",134,0)
. ;;. S X2=$$MRADTACT^IBCEMU2,X1=$$DT^XLFDT D ^%DTC
"RTN","RCRJRBD",135,0)
. ;;. I %Y,X'>364.25 S COLLECT=$J($G(PAYMENT(1339))/PRINCPAL(1339)*100,0,2)
"RTN","RCRJRBD",136,0)
. S DR=".02////"_+COLLECT_";"
"RTN","RCRJRBD",137,0)
. ;
"RTN","RCRJRBD",138,0)
. ; current month receivable (this is built in the routine
"RTN","RCRJRBD",139,0)
. ; RCRJRCO1 and is stored in ^TMP($J,"RCRJRBD",SGL))
"RTN","RCRJRBD",140,0)
. S DR=DR_".07////"_+$G(^TMP($J,"RCRJRBD",SGL))_";"
"RTN","RCRJRBD",141,0)
. ;
"RTN","RCRJRBD",142,0)
. ; calculate allowance estimate for 1319 and 1338
"RTN","RCRJRBD",143,0)
. ; .08 allowance estimate = (writeoff % * current receivables)
"RTN","RCRJRBD",144,0)
. ; .09 actual writeoffs fytd
"RTN","RCRJRBD",145,0)
. I SGL=1319!(SGL=1319.2)!(SGL=1319.3)!(SGL=1319.4)!(SGL=1319.5)!(SGL=1319.6)!(SGL=1338)!(SGL=1338.2)!(SGL=1338.3) D
"RTN","RCRJRBD",146,0)
. . S WRITEOFF=100-COLLECT
"RTN","RCRJRBD",147,0)
. . S DR=DR_".03////"_WRITEOFF_";"
"RTN","RCRJRBD",148,0)
. . S DR=DR_".08////"_$J((WRITEOFF/100)*$G(^TMP($J,"RCRJRBD",SGL)),0,2)_";"
"RTN","RCRJRBD",149,0)
. . S DR=DR_".09////"_+$G(ACTUALWO(SGL))_";"
"RTN","RCRJRBD",150,0)
. ; calculate allowance estimate for 1339
"RTN","RCRJRBD",151,0)
. ; .08 allowance estimate = (contract % * current receivables)
"RTN","RCRJRBD",152,0)
. ; .09 actual contract adjustments fytd
"RTN","RCRJRBD",153,0)
. I SGL=1339!(SGL=1339.1)!(SGL="133N")!(SGL="133N.2")!(SGL="133N.3") D
"RTN","RCRJRBD",154,0)
. . S CONTRACT=100-COLLECT
"RTN","RCRJRBD",155,0)
. . S DR=DR_".04////"_CONTRACT_";"
"RTN","RCRJRBD",156,0)
. . S DR=DR_".08////"_$J((CONTRACT/100)*$G(^TMP($J,"RCRJRBD",SGL)),0,2)_";"
"RTN","RCRJRBD",157,0)
. . S DR=DR_".09////"_+$G(ACTUALCA(SGL))_";"
"RTN","RCRJRBD",158,0)
. ;
"RTN","RCRJRBD",159,0)
. ; set changed locally flag to no
"RTN","RCRJRBD",160,0)
. S DR=DR_".1////0;"
"RTN","RCRJRBD",161,0)
. D STORE(SGL,DR)
"RTN","RCRJRBD",162,0)
;
"RTN","RCRJRBD",163,0)
L -^RC(348.1)
"RTN","RCRJRBD",164,0)
;
"RTN","RCRJRBD",165,0)
; ; put the report in a mail message (rcrjfmm=1)
"RTN","RCRJRBD",166,0)
; S RCRJFMM=1
"RTN","RCRJRBD",167,0)
; S RCRJDATE=DATEEND
"RTN","RCRJRBD",168,0)
; D DQ^RCRJRBDR
"RTN","RCRJRBD",169,0)
;
"RTN","RCRJRBD",170,0)
; transmit the allowances to FMS, and then generate the report.
"RTN","RCRJRBD",171,0)
D BADDEBT^RCXFMSSV(DATEEND)
"RTN","RCRJRBD",172,0)
Q
"RTN","RCRJRBD",173,0)
;
"RTN","RCRJRBD",174,0)
;
"RTN","RCRJRBD",175,0)
STORE(SGL,DR) ; store data for Standard Ledger Account
"RTN","RCRJRBD",176,0)
N D0,DA,DD,DI,DIC,DIE,DINUM,DO,DQ,X,Y
"RTN","RCRJRBD",177,0)
S DIC="^RC(348.1,",DIC(0)="L",X=SGL,DIC("DR")=DR
"RTN","RCRJRBD",178,0)
D FILE^DICN
"RTN","RCRJRBD",179,0)
Q
"RTN","RCRJRBD",180,0)
;
"RTN","RCRJRBD",181,0)
;
"RTN","RCRJRBD",182,0)
DELETALL ; delete all the entries from the bad debt file
"RTN","RCRJRBD",183,0)
N %,DA,DIC,DIK,X,Y
"RTN","RCRJRBD",184,0)
S DIK="^RC(348.1,"
"RTN","RCRJRBD",185,0)
S DA=0 F S DA=$O(^RC(348.1,DA)) Q:'DA D ^DIK
"RTN","RCRJRBD",186,0)
Q
"RTN","RCRJRBD",187,0)
;
"RTN","RCRJRBD",188,0)
;
"RTN","RCRJRBD",189,0)
WD3() ; return the third work day of the month
"RTN","RCRJRBD",190,0)
N J,P,V,X
"RTN","RCRJRBD",191,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",192,0)
S X=+$E(P,6,7)
"RTN","RCRJRBD",193,0)
Q X
"RTN","RCRJRBD",194,0)
;
"RTN","RCRJRBD",195,0)
;
"RTN","RCRJRBD",196,0)
PREVMONT(FORDATE) ; return the previous month's date
"RTN","RCRJRBD",197,0)
N PREVDATE
"RTN","RCRJRBD",198,0)
S PREVDATE=$E(FORDATE,1,5)-1
"RTN","RCRJRBD",199,0)
I $E(PREVDATE,4,5)="00" S PREVDATE=($E(PREVDATE,1,3)-1)_12
"RTN","RCRJRBD",200,0)
Q PREVDATE_"00"
"RTN","RCRJRBD",201,0)
;
"RTN","RCRJRBD",202,0)
; derive standard general ledger (SGL) from category and fund
"RTN","RCRJRBD",203,0)
SGL(CATEGORY,FUND) ;
"RTN","RCRJRBD",204,0)
I $G(FUND)=528709 Q 1319.2 ;new long term care fund
"RTN","RCRJRBD",205,0)
I $E($G(FUND),1,4)=4032 Q 1319.2 ; breakout long term care as a subset
"RTN","RCRJRBD",206,0)
I $G(FUND)=528711&(CAT=6)!(CAT=7) Q 1319.5 ; breakout pharmacy
"RTN","RCRJRBD",207,0)
I $G(FUND)=528711&(CAT=9) Q "133N.2" ; pharmacy reimburs health ins
"RTN","RCRJRBD",208,0)
I $G(FUND)=528711&(CAT=10) Q 1338.2 ; pharmacy tort feasor
"RTN","RCRJRBD",209,0)
I CATEGORY=8 Q 1339 ; crime or per. vio.
"RTN","RCRJRBD",210,0)
I CATEGORY=9 Q 1339 ; reimbursable health insurance
"RTN","RCRJRBD",211,0)
I CATEGORY=46 Q 1339 ; EMER/HUMAN REIMB INS ;315
"RTN","RCRJRBD",212,0)
I CATEGORY=10 Q 1338 ; tort feasor
"RTN","RCRJRBD",213,0)
I CATEGORY=21 Q 1339 ; medicare
"RTN","RCRJRBD",214,0)
I CATEGORY=45 Q 1339.1 ; Fee Basis
"RTN","RCRJRBD",215,0)
Q 1319
"RTN","RCRJRBD",216,0)
;
"RTN","RCRJRBD",217,0)
;
"RTN","RCRJRBD",218,0)
BDRSGL(CAT,FUND,MRATYPE) ; Calculate SGLs for the BDR process
"RTN","RCRJRBD",219,0)
;PRCA*4.5*310/DRF Added fund 528713, Non-VA Reimbursable Insurance
"RTN","RCRJRBD",220,0)
;
"RTN","RCRJRBD",221,0)
; This API will be used by both the ARDC (routine RCRJRCOC)
"RTN","RCRJRBD",222,0)
; and the BDR estimate calculator to associate receivables
"RTN","RCRJRBD",223,0)
; with the correct standard general ledger account (SGL).
"RTN","RCRJRBD",224,0)
; The following table will be implemented:
"RTN","RCRJRBD",225,0)
;
"RTN","RCRJRBD",226,0)
; Receivable Type (Category) Fund SGL
"RTN","RCRJRBD",227,0)
;==================================================
"RTN","RCRJRBD",228,0)
; Medical Care Co-payments 528703 1319
"RTN","RCRJRBD",229,0)
; (plus Inelig, Emerg./Hum. rec.)
"RTN","RCRJRBD",230,0)
; Long Term Care Co-payments 528709 1319.2
"RTN","RCRJRBD",231,0)
; Medication Co-payments 528701 1319.3
"RTN","RCRJRBD",232,0)
; Crimes of Personal Violence (8), 528704 1319.4
"RTN","RCRJRBD",233,0)
; Medicare (21), No-Fault Auto
"RTN","RCRJRBD",234,0)
; (7), Workman's Comp (6)
"RTN","RCRJRBD",235,0)
; Tort Feasor (10) 528704 1338
"RTN","RCRJRBD",236,0)
; RHI (9), pre-MRA 528704 1339
"RTN","RCRJRBD",237,0)
; RHI (9), post-MRA, MRA rec. 528704 133H
"RTN","RCRJRBD",238,0)
; RHI (9), post-MRA, non-MRA rec. 528704 133N
"RTN","RCRJRBD",239,0)
; Non-VA RHI Tort Feasor 528713 1338.3
"RTN","RCRJRBD",240,0)
; Non-VA RHI (45), pre-MRA 528713 1339.1
"RTN","RCRJRBD",241,0)
; Non-VA RHI (45), post-MRA, MRA rec. 528713 133H.2
"RTN","RCRJRBD",242,0)
; Non-VA RHI (45), post-MRA, non-MRA rec. 528713 133N.3
"RTN","RCRJRBD",243,0)
; Crimes of Personal Violence (8), 528713 1319.6
"RTN","RCRJRBD",244,0)
; Medicare (21), No-Fault Auto
"RTN","RCRJRBD",245,0)
; (7), Workman's Comp (6)
"RTN","RCRJRBD",246,0)
; Pharmacy No Fault Auto(7), 528711 1319.5
"RTN","RCRJRBD",247,0)
; Pharmacy Workman's Comp(6)
"RTN","RCRJRBD",248,0)
; Pharmacy RHI, non MRA (9) 528711 133N.2
"RTN","RCRJRBD",249,0)
; Pharmacy Tort Feasor (10) 528711 1338.2
"RTN","RCRJRBD",250,0)
;
"RTN","RCRJRBD",251,0)
; Input: CAT -- Pointer to the receivable category in file 430.2
"RTN","RCRJRBD",252,0)
; FUND -- Receivable fund calculated by routine RCXFMSUF
"RTN","RCRJRBD",253,0)
; MRATYPE -- Indicator of an MRA (2) or non-MRA (3) receivable
"RTN","RCRJRBD",254,0)
;
"RTN","RCRJRBD",255,0)
;
"RTN","RCRJRBD",256,0)
I $G(FUND)=528709 Q 1319.2
"RTN","RCRJRBD",257,0)
I $E($G(FUND),1,4)=4032 Q 1319.2
"RTN","RCRJRBD",258,0)
I $G(FUND)=528701 Q 1319.3
"RTN","RCRJRBD",259,0)
I $G(FUND)=528711&((CAT=6)!(CAT=7)) Q 1319.5
"RTN","RCRJRBD",260,0)
I $G(FUND)=528711&(CAT=9) Q "133N.2"
"RTN","RCRJRBD",261,0)
I $G(FUND)=528711&(CAT=10) Q 1338.2
"RTN","RCRJRBD",262,0)
; THIRD PARTY =528713 new code begins
"RTN","RCRJRBD",263,0)
I $G(FUND)=528713&(CAT=50!(CAT=51)!(CAT=52)) Q 1339.1
"RTN","RCRJRBD",264,0)
I $G(FUND)=528713&(CAT=10!(CAT=53)!(CAT=58)!(CAT=61)) Q 1338.3
"RTN","RCRJRBD",265,0)
I $G(FUND)=528713&(CAT=8!(CAT=21)!(CAT=6)!(CAT=7)!(CAT=56)!(CAT=57)!(CAT=59)!(CAT=60)) Q 1319.6
"RTN","RCRJRBD",266,0)
; FIRST PARTY = 528714
"RTN","RCRJRBD",267,0)
I $G(FUND)=528714&(CAT=7!(CAT=56)!(CAT=57)!(CAT=59)!(CAT=60)!(CAT=62)) Q 1319.4
"RTN","RCRJRBD",268,0)
I $G(FUND)=528714&(CAT=53!(CAT=58)!(CAT=61)) Q 1338
"RTN","RCRJRBD",269,0)
I $G(FUND)=528714&(CAT=63!(CAT=65)!(CAT=67)!(CAT=69)) Q 1319
"RTN","RCRJRBD",270,0)
I $G(FUND)=528714&(CAT=64!(CAT=66)!(CAT=68)!(CAT=70)) Q 1319.3
"RTN","RCRJRBD",271,0)
I $G(FUND)=528714&(CAT=70!(CAT=71)!(CAT=72)!(CAT=73)!(CAT=74)!(CAT=75)!(CAT=76)) Q 1319.2
"RTN","RCRJRBD",272,0)
; end of FIRST PARTY
"RTN","RCRJRBD",273,0)
I CAT=8!(CAT=21)!(CAT=7)!(CAT=6) Q 1319.4
"RTN","RCRJRBD",274,0)
I CAT=10 Q 1338
"RTN","RCRJRBD",275,0)
I CAT=9 Q $S(MRATYPE=2:"133H",MRATYPE=3:"133N",1:1339)
"RTN","RCRJRBD",276,0)
I CAT=46 Q $S(MRATYPE=2:"133H",MRATYPE=3:"133N",1:1339) ;315
"RTN","RCRJRBD",277,0)
I CAT=45 Q $S(MRATYPE=2:"133H.2",MRATYPE=3:"133N.3",1:1339.1)
"RTN","RCRJRBD",278,0)
Q 1319
"RTN","RCRJRBDT")
0^11^B70483882
"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 17
"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.6 528714 - 1319
"RTN","RCRJRBDT",162,0)
; 16 1339.1 528714 - 1339
"RTN","RCRJRBDT",163,0)
; 17 133H.2 528714 - 133H
"RTN","RCRJRBDT",164,0)
; 18 133N.3 528714 - 133N
"RTN","RCRJRBDT",165,0)
; 19 1338.3 528714 - 1338
"RTN","RCRJRBDT",166,0)
; 20 1319.6 528714 - 1319
"RTN","RCRJRBDT",167,0)
; 21 1319.6 528714 - 1319
"RTN","RCRJRBDT",168,0)
; 22 1339.1 528714 - 1339
"RTN","RCRJRBDT",169,0)
; 23 133H.2 528714 - 133H
"RTN","RCRJRBDT",170,0)
; 24 133N.3 528714 - 133N
"RTN","RCRJRBDT",171,0)
; 25 1338.3 528714 - 1338
"RTN","RCRJRBDT",172,0)
; 26 1319.6 528714 - 1319
"RTN","RCRJRBDT",173,0)
; 27 1319.6 528714 - 1319
"RTN","RCRJRBDT",174,0)
; 28 1338.3 528714 - 1338
"RTN","RCRJRBDT",175,0)
; 29 1319.6 528714 - 1319
"RTN","RCRJRBDT",176,0)
; 30 1339.1 528714 - 1339
"RTN","RCRJRBDT",177,0)
; 31 133H.2 528714 - 133H
"RTN","RCRJRBDT",178,0)
; 32 133N.3 528714 - 133N
"RTN","RCRJRBDT",179,0)
; 33 1339.1 528714 - 1339
"RTN","RCRJRBDT",180,0)
; 34 133H.2 528714 - 133H
"RTN","RCRJRBDT",181,0)
; 35 133N.3 528714 - 133N
"RTN","RCRJRBDT",182,0)
;
"RTN","RCRJRBDT",183,0)
S RCARR(1)="1319.3^528701 - 1319"
"RTN","RCRJRBDT",184,0)
S RCARR(2)="1319^528703 - 1319"
"RTN","RCRJRBDT",185,0)
S RCARR(3)="1319.4^528704 - 1319"
"RTN","RCRJRBDT",186,0)
S RCARR(4)="1339^528704 - 1339"
"RTN","RCRJRBDT",187,0)
S RCARR(5)="133N^528704 - 133N"
"RTN","RCRJRBDT",188,0)
S RCARR(6)="1338^528704 - 1338"
"RTN","RCRJRBDT",189,0)
S RCARR(7)="1319.2^528709 - 1319"
"RTN","RCRJRBDT",190,0)
S RCARR(8)="1319.5^528711 - 1319"
"RTN","RCRJRBDT",191,0)
S RCARR(9)="133N.2^528711 - 133N"
"RTN","RCRJRBDT",192,0)
S RCARR(10)="1338.2^528711 - 1338"
"RTN","RCRJRBDT",193,0)
S RCARR(11)="1319.6^528713 - 1319"
"RTN","RCRJRBDT",194,0)
S RCARR(12)="1339.1^528713 - 1339"
"RTN","RCRJRBDT",195,0)
S RCARR(13)="133N.3^528713 - 133N"
"RTN","RCRJRBDT",196,0)
S RCARR(14)="1338.3^528713 - 1338"
"RTN","RCRJRBDT",197,0)
S RCARR(15)="1319.6^528714 - 1319"
"RTN","RCRJRBDT",198,0)
S RCARR(16)="1339.1^528714 - 1339"
"RTN","RCRJRBDT",199,0)
S RCARR(17)="133H.2^528714 - 133H"
"RTN","RCRJRBDT",200,0)
S RCARR(18)="133N.3^528714 - 133N"
"RTN","RCRJRBDT",201,0)
S RCARR(19)="1338.3^528714 - 1338"
"RTN","RCRJRBDT",202,0)
S RCARR(20)="1319.6^528714 - 1319"
"RTN","RCRJRBDT",203,0)
S RCARR(21)="1319.6^528714 - 1319"
"RTN","RCRJRBDT",204,0)
S RCARR(22)="1339.1^528714 - 1339"
"RTN","RCRJRBDT",205,0)
S RCARR(23)="133H.2^528714 - 133H"
"RTN","RCRJRBDT",206,0)
S RCARR(24)="133N.3^528714 - 133N"
"RTN","RCRJRBDT",207,0)
S RCARR(25)="1338.3^528714 - 1338"
"RTN","RCRJRBDT",208,0)
S RCARR(26)="1319.6^528714 - 1319"
"RTN","RCRJRBDT",209,0)
S RCARR(27)="1319.6^528714 - 1319"
"RTN","RCRJRBDT",210,0)
S RCARR(28)="1338.3^528714 - 1338"
"RTN","RCRJRBDT",211,0)
S RCARR(29)="1319.6^528714 - 1319"
"RTN","RCRJRBDT",212,0)
S RCARR(30)="1339.1^528714 - 1339"
"RTN","RCRJRBDT",213,0)
S RCARR(31)="133H.2^528714 - 133H"
"RTN","RCRJRBDT",214,0)
S RCARR(32)="133N.3^528714 - 133N"
"RTN","RCRJRBDT",215,0)
S RCARR(33)="1339.1^528714 - 1339"
"RTN","RCRJRBDT",216,0)
S RCARR(34)="133H.2^528714 - 133H"
"RTN","RCRJRBDT",217,0)
S RCARR(35)="133N.3^528714 - 133N"
"RTN","RCRJRBDT",218,0)
;
"RTN","RCRJRBDT",219,0)
S RCX="" F S RCX=$O(RCARR(RCX)) Q:RCX="" S RCD=RCARR(RCX) D
"RTN","RCRJRBDT",220,0)
.S RCDATA=$G(^RC(348.1,+$O(^RC(348.1,"B",$P(RCD,"^"),0)),0))
"RTN","RCRJRBDT",221,0)
.Q:RCDATA=""
"RTN","RCRJRBDT",222,0)
.S RCREC=$P(RCD,"^",2)_$J($P(RCDATA,"^",2),21,2)
"RTN","RCRJRBDT",223,0)
.S RCREC=RCREC_$J($P(RCDATA,"^",3),15,2)
"RTN","RCRJRBDT",224,0)
.S RCREC=RCREC_$J($P(RCDATA,"^",4),16,2)
"RTN","RCRJRBDT",225,0)
.S X=+$P(RCDATA,"^",8)
"RTN","RCRJRBDT",226,0)
.S X=$FN(X,",")_$S(X[".":"",1:".")_$E("00",$L($P(X,".",2))+1,2)
"RTN","RCRJRBDT",227,0)
.S RCREC=RCREC_$J(X,14)
"RTN","RCRJRBDT",228,0)
.D SETLINE(RCREC)
"RTN","RCRJRBDT",229,0)
;
"RTN","RCRJRBDT",230,0)
D SETLINE(" ")
"RTN","RCRJRBDT",231,0)
D SETLINE(" ")
"RTN","RCRJRBDT",232,0)
D SETLINE("SGL Definitions")
"RTN","RCRJRBDT",233,0)
D SETLINE(" ")
"RTN","RCRJRBDT",234,0)
D SETLINE("1319 - Allowance for Bad Debt")
"RTN","RCRJRBDT",235,0)
D SETLINE("1338 - Allowance for Tort Feasors")
"RTN","RCRJRBDT",236,0)
D SETLINE("1339 - Allowance for Contract Adjustments pre-MRA (Medicare Remittance Advice)")
"RTN","RCRJRBDT",237,0)
D SETLINE("133N - Allowance for Contract Adjustments post-MRA")
"RTN","RCRJRBDT",238,0)
D SETLINE(" ")
"RTN","RCRJRBDT",239,0)
D SETLINE(" ")
"RTN","RCRJRBDT",240,0)
D SETLINE("Only members in the facility's local RC AR DATA COLLECTOR mail group")
"RTN","RCRJRBDT",241,0)
D SETLINE("will receive this report.")
"RTN","RCRJRBDT",242,0)
Q
"RTN","RCRJRBDT",243,0)
;
"RTN","RCRJRBDT",244,0)
SETLINE(DATA) ; build the line for the report
"RTN","RCRJRBDT",245,0)
S LINE=LINE+1,^TMP($J,"RCRJRCORMM",LINE)=DATA
"RTN","RCRJRBDT",246,0)
Q
"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 17
"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","RCTCSPD")
0^14^B162524744
"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 17
"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,"I",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^B80726007
"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,338**;Mar 20, 1995;Build 17
"RTN","RCTOPD",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCTOPD",4,0)
ENTER ;Entry point from nightly process
"RTN","RCTOPD",5,0)
Q:'$D(RCDOC)
"RTN","RCTOPD",6,0)
N DEBTOR,BILL,DEBTOR0,B0,B6,B7,P121DT,PRIN,INT,ADMIN,B4 ;PRCA*4.5*315 - P181Dt change to P121DT - FY16 HAPE RRE [TOPS]
"RTN","RCTOPD",7,0)
N EFFDT,DFN,CNTR,SITE,LN,FN,MN,DOB,SITE,F60DT,VADM,DEBTOR4,DEBTOR6
"RTN","RCTOPD",8,0)
N PHONE,QUIT,TOTAL,ZIPCODE,FULLNM,RCNT,REPAY,X1,X2
"RTN","RCTOPD",9,0)
N ERROR,ADDR,CAT,BILLDT,P10YDT,CURRTOT,HOLD,SITECD,RCNEW,ACTDT
"RTN","RCTOPD",10,0)
;
"RTN","RCTOPD",11,0)
;initialize temporary global, variables
"RTN","RCTOPD",12,0)
;
"RTN","RCTOPD",13,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",14,0)
S SITE=$E($$SITE^RCMSITE(),1,3),SITECD=$P(^RC(342,1,3),U,5)
"RTN","RCTOPD",15,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",16,0)
S X1=DT,X2=-3650 D C^%DTC S P10YDT=X
"RTN","RCTOPD",17,0)
S X1=DT,X2=+60 D C^%DTC S F60DT=X
"RTN","RCTOPD",18,0)
S ACTDT=3150801 ;activation date for all sites except beckley, little rock, upstate ny
"RTN","RCTOPD",19,0)
S:SITE=598 ACTDT=3150201 ;activation date for little rock
"RTN","RCTOPD",20,0)
S:SITE=517 ACTDT=3150201 ;activation date for beckley
"RTN","RCTOPD",21,0)
S:SITE=528 ACTDT=3150201 ;activation date for upstate ny
"RTN","RCTOPD",22,0)
S (CNTR(1),CNTR(2),CNTR(4),DEBTOR,RCNT)=0
"RTN","RCTOPD",23,0)
;
"RTN","RCTOPD",24,0)
;branch if recertification document
"RTN","RCTOPD",25,0)
I RCDOC="Y" D RECERT G EXIT
"RTN","RCTOPD",26,0)
;
"RTN","RCTOPD",27,0)
;branch to do update documents
"RTN","RCTOPD",28,0)
D UPDATE I RCDOC="U" G EXIT
"RTN","RCTOPD",29,0)
;
"RTN","RCTOPD",30,0)
;master sheet compilation
"RTN","RCTOPD",31,0)
;
"RTN","RCTOPD",32,0)
F S DEBTOR=$O(^PRCA(430,"C",DEBTOR)) Q:DEBTOR'?1N.N D
"RTN","RCTOPD",33,0)
.N X,RCDFN
"RTN","RCTOPD",34,0)
.S RCDFN=$G(^RCD(340,DEBTOR,0))
"RTN","RCTOPD",35,0)
.I $P(RCDFN,";",2)["DPT",$$EMERES^PRCAUTL(+RCDFN)]"" Q ;stop the master sheet compilation for hurricane Katrina sites (patients)
"RTN","RCTOPD",36,0)
.Q:$D(^RCD(340,"TOP",DEBTOR))
"RTN","RCTOPD",37,0)
.; quit if debtor address marked unknown
"RTN","RCTOPD",38,0)
.Q:$P($G(^RCD(340,+DEBTOR,1)),"^",9)=1
"RTN","RCTOPD",39,0)
.S DEBTOR6=$G(^RCD(340,DEBTOR,6)),DEBTOR0=$G(^(0)),HOLD=0,RCNEW=1
"RTN","RCTOPD",40,0)
.I $P(DEBTOR6,U,2),'$P(DEBTOR6,U,3) Q
"RTN","RCTOPD",41,0)
.S QUIT=1,FILE=$$FILE(DEBTOR0) Q:'FILE
"RTN","RCTOPD",42,0)
.S EFFDT=P121DT
"RTN","RCTOPD",43,0)
.D PROC(DEBTOR,.QUIT,FILE,.HOLD,.EFFDT) Q:QUIT
"RTN","RCTOPD",44,0)
.D EN1^RCTOP2(DEBTOR,"M",FILE)
"RTN","RCTOPD",45,0)
.D EN1^RCTOP1(DEBTOR,TOTAL,"M",EFFDT,0,FILE)
"RTN","RCTOPD",46,0)
.;set hold date in file for employee, ex-employee, vendor records
"RTN","RCTOPD",47,0)
.;Austin holds these for 60 days before transmitting to TOP
"RTN","RCTOPD",48,0)
.I $G(HOLD) S $P(^RCD(340,DEBTOR,6),U,6)=F60DT
"RTN","RCTOPD",49,0)
.Q
"RTN","RCTOPD",50,0)
;compile documents into mail messages--sets referral date in 430
"RTN","RCTOPD",51,0)
D COMPILE
"RTN","RCTOPD",52,0)
EXIT K RCDOC,^XTMP("RCTOPD"),^TMP("RCTOPD"),XMDUZ D KVAR^VADPT
"RTN","RCTOPD",53,0)
Q
"RTN","RCTOPD",54,0)
;
"RTN","RCTOPD",55,0)
UPDATE ;weekly update compilation
"RTN","RCTOPD",56,0)
F S DEBTOR=$O(^RCD(340,"TOP",DEBTOR)) Q:DEBTOR'?1N.N D
"RTN","RCTOPD",57,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",58,0)
.D EN1^RCTOP2(DEBTOR,"U",FILE)
"RTN","RCTOPD",59,0)
.D PROC(DEBTOR,.QUIT,FILE,0,.EFFDT) I QUIT D Q
"RTN","RCTOPD",60,0)
..;process type 4 document if necessary
"RTN","RCTOPD",61,0)
..S TAXID=$$TAXID^RCTOP1(DEBTOR,FILE),OTAXID=$P(DEBTOR4,U)
"RTN","RCTOPD",62,0)
..S NAME=$$NAME^RCTOP1(+DEBTOR0,FILE),ONAME=$P(DEBTOR4,U,2),NAME=$P(NAME,U)
"RTN","RCTOPD",63,0)
..I NAME=ONAME,TAXID=OTAXID Q
"RTN","RCTOPD",64,0)
..D EN1^RCTOP4(NAME,TAXID,DEBTOR4,DEBTOR,FILE)
"RTN","RCTOPD",65,0)
..Q
"RTN","RCTOPD",66,0)
.D EN1^RCTOP1(DEBTOR,TOTAL,"U",EFFDT,0,FILE)
"RTN","RCTOPD",67,0)
.Q
"RTN","RCTOPD",68,0)
;refund/refund reversal documents
"RTN","RCTOPD",69,0)
D REFDOC
"RTN","RCTOPD",70,0)
;compile documents into mail messages--sets referral date in 430
"RTN","RCTOPD",71,0)
D:$G(RCDOC)="U" COMPILE
"RTN","RCTOPD",72,0)
Q
"RTN","RCTOPD",73,0)
;
"RTN","RCTOPD",74,0)
RECERT ;send yearly recertification documents
"RTN","RCTOPD",75,0)
F S DEBTOR=$O(^RCD(340,"TOP",DEBTOR)) Q:DEBTOR'?1N.N D
"RTN","RCTOPD",76,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",77,0)
.I TOTAL D EN1^RCTOP1(DEBTOR,TOTAL,"Y",EFFDT,0,FILE)
"RTN","RCTOPD",78,0)
.Q
"RTN","RCTOPD",79,0)
;compile documents into mail messages
"RTN","RCTOPD",80,0)
D COMPILE
"RTN","RCTOPD",81,0)
Q
"RTN","RCTOPD",82,0)
;
"RTN","RCTOPD",83,0)
REFDOC ; refund, refund reversal documents
"RTN","RCTOPD",84,0)
N CODE,BILL,DEBTOR,TOTAL,EFFDT,FILE,RFCODE
"RTN","RCTOPD",85,0)
F RFCODE=1,3 S CODE=$S(RFCODE=1:"R",1:"RV") D
"RTN","RCTOPD",86,0)
.S BILL=0 F S BILL=$O(^PRCA(430,"TREF",RFCODE,BILL)) Q:'BILL D
"RTN","RCTOPD",87,0)
..S DEBTOR=$P($G(^PRCA(430,BILL,0)),U,9) Q:'DEBTOR
"RTN","RCTOPD",88,0)
..S TOTAL=$P($G(^(7)),U,18) Q:'TOTAL ;NAKED TO LINE ABOVE
"RTN","RCTOPD",89,0)
..S EFFDT=$P($G(^RCD(340,+DEBTOR,4)),U,6),FILE=$$FILE(^(0))
"RTN","RCTOPD",90,0)
..D EN1^RCTOP1(DEBTOR,TOTAL,CODE,EFFDT,BILL,FILE)
"RTN","RCTOPD",91,0)
..Q
"RTN","RCTOPD",92,0)
.Q
"RTN","RCTOPD",93,0)
Q
"RTN","RCTOPD",94,0)
;
"RTN","RCTOPD",95,0)
COMPILE ;compiles documents into mail messages and transmits them
"RTN","RCTOPD",96,0)
;builds message array
"RTN","RCTOPD",97,0)
N CNT,SEQ,REC,XMDUZ,DOCTYPE,LRTYPE,XMSUB,XMTEXT,XMY,TSEQ,DOCAMT
"RTN","RCTOPD",98,0)
S (SEQ,TSEQ)=0
"RTN","RCTOPD",99,0)
F I=1,2,4 S TSEQ=TSEQ+($G(CNTR(I))\150)+$S($G(CNTR(I))#150:1,1:0)
"RTN","RCTOPD",100,0)
F DOCTYPE=1,2,4 D:$D(^XTMP("RCTOPD",$J,DOCTYPE)) COMPILE1(DOCTYPE,CNTR(DOCTYPE))
"RTN","RCTOPD",101,0)
D USRMSG
"RTN","RCTOPD",102,0)
Q
"RTN","RCTOPD",103,0)
COMPILE1(DOCTYPE,CNTR) ; compiles each type of document separately
"RTN","RCTOPD",104,0)
S RCNT=RCNT+CNTR
"RTN","RCTOPD",105,0)
I '$G(LRTYPE) F I=1,2,4 S:$D(^XTMP("RCTOPD",$J,I)) LRTYPE=I
"RTN","RCTOPD",106,0)
F CNT=1:1:CNTR D
"RTN","RCTOPD",107,0)
.D:CNT#150=1
"RTN","RCTOPD",108,0)
..K ^XTMP("RCTOPD",$J,"BUILD") S SEQ=SEQ+1
"RTN","RCTOPD",109,0)
..S REC=1,DOCAMT=0
"RTN","RCTOPD",110,0)
..Q
"RTN","RCTOPD",111,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",112,0)
.I CNTR=CNT,LRTYPE=DOCTYPE S ^XTMP("RCTOPD",$J,"BUILD",REC+1)="END OF TRANSMISSION FOR SITE# "_SITE_": TOTAL RECORDS: "_RCNT
"RTN","RCTOPD",113,0)
.I $S(CNTR=CNT:1,CNT#150=0:1,1:0) D
"RTN","RCTOPD",114,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",115,0)
..S XMDUZ="AR PACKAGE"
"RTN","RCTOPD",116,0)
..S XMY("
PII
")=""
"RTN","RCTOPD",117,0)
..S XMY("G.TOP")=""
"RTN","RCTOPD",118,0)
..S XMSUB=SITE_"/TOP TRANSMISSION/SEQ#: "_SEQ_"/"_$$NOW()
"RTN","RCTOPD",119,0)
..S XMTEXT="^XTMP(""RCTOPD"","_$J_",""BUILD"","
"RTN","RCTOPD",120,0)
..D ^XMD
"RTN","RCTOPD",121,0)
..Q
"RTN","RCTOPD",122,0)
.Q
"RTN","RCTOPD",123,0)
Q
"RTN","RCTOPD",124,0)
;
"RTN","RCTOPD",125,0)
USRMSG ;sends mailman message of documents sent to user
"RTN","RCTOPD",126,0)
N XMY,XMDUZ,XMSUB,X,RCNT
"RTN","RCTOPD",127,0)
S XMDUZ="AR PACKAGE",XMY("G.TOP")=""
"RTN","RCTOPD",128,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",129,0)
S ^XTMP("RCTOPD",$J,"REC1",1)="Name TIN TYPE AMOUNT"
"RTN","RCTOPD",130,0)
S ^XTMP("RCTOPD",$J,"REC1",2)="---- --- ---- ------"
"RTN","RCTOPD",131,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",132,0)
S ^XTMP("RCTOPD",$J,"REC1",RCNT)="Total Records: "_(RCNT-3)
"RTN","RCTOPD",133,0)
S XMTEXT="^XTMP(""RCTOPD"","_$J_",""REC1"","
"RTN","RCTOPD",134,0)
D ^XMD
"RTN","RCTOPD",135,0)
;
"RTN","RCTOPD",136,0)
THIRD ;sends mailman message to user if no third letter found
"RTN","RCTOPD",137,0)
Q:'$D(^XTMP("RCTOPD",$J,"THIRD"))
"RTN","RCTOPD",138,0)
K ^XTMP("RCTOPD",$J,"REC1")
"RTN","RCTOPD",139,0)
S XMDUZ="AR PACKAGE",XMY("G.TOP")=""
"RTN","RCTOPD",140,0)
N TCT,TDEB,TDEB0,TBIL,TSP,FST
"RTN","RCTOPD",141,0)
S XMSUB="TOP QUALIFIED/NO 3RD LETTER SENT ON "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
"RTN","RCTOPD",142,0)
S ^XTMP("RCTOPD",$J,"REC1",1)="The following list of debtor bills were not sent to TOP."
"RTN","RCTOPD",143,0)
S ^XTMP("RCTOPD",$J,"REC1",2)="Please review debtor's account to determine why the third"
"RTN","RCTOPD",144,0)
S ^XTMP("RCTOPD",$J,"REC1",3)="notice letter has not been sent:"
"RTN","RCTOPD",145,0)
S ^XTMP("RCTOPD",$J,"REC1",4)="Name Bill #"
"RTN","RCTOPD",146,0)
S ^XTMP("RCTOPD",$J,"REC1",5)="---- ------"
"RTN","RCTOPD",147,0)
S TCT=6,TSP=0,TDEB=""
"RTN","RCTOPD",148,0)
F S TDEB=$O(^XTMP("RCTOPD",$J,"THIRD",TDEB)) Q:TDEB="" D
"RTN","RCTOPD",149,0)
.S FST=1,TBIL=""
"RTN","RCTOPD",150,0)
.I FST,TCT'=6 S ^XTMP("RCTOPD",$J,"REC1",TCT)="",TCT=TCT+1,TSP=TSP+1
"RTN","RCTOPD",151,0)
.F S TBIL=$O(^XTMP("RCTOPD",$J,"THIRD",TDEB,TBIL)) Q:TBIL="" D
"RTN","RCTOPD",152,0)
..S TDEB0=$S(FST:TDEB,1:"")
"RTN","RCTOPD",153,0)
..S ^XTMP("RCTOPD",$J,"REC1",TCT)=TDEB0_$J(" ",35-$L(TDEB0))_TBIL
"RTN","RCTOPD",154,0)
..S TCT=TCT+1,FST=0
"RTN","RCTOPD",155,0)
S ^XTMP("RCTOPD",$J,"REC1",TCT)="Total records: "_(TCT-(6+TSP))
"RTN","RCTOPD",156,0)
S XMTEXT="^XTMP(""RCTOPD"","_$J_",""REC1"","
"RTN","RCTOPD",157,0)
D ^XMD
"RTN","RCTOPD",158,0)
COMPQ Q
"RTN","RCTOPD",159,0)
;
"RTN","RCTOPD",160,0)
PROC(DEBTOR,QUIT,FILE,HOLD,EFFDT) ;process bills for a specific debtor
"RTN","RCTOPD",161,0)
K ^TMP("RCTOPD",$J,"BILL")
"RTN","RCTOPD",162,0)
S DEBTOR0=$G(^RCD(340,DEBTOR,0))
"RTN","RCTOPD",163,0)
Q:'FILE
"RTN","RCTOPD",164,0)
I FILE=2 S DFN=+DEBTOR0 D DEM^VADPT Q:$E(VADM(2),1,5)="00000"
"RTN","RCTOPD",165,0)
S (BILL,TOTAL,REPAY)=0
"RTN","RCTOPD",166,0)
I RCNEW,FILE=440 S HOLD=1
"RTN","RCTOPD",167,0)
I 'RCNEW,$P(^RCD(340,DEBTOR,6),U,2),'$P(^(6),U,3) G TOTAL
"RTN","RCTOPD",168,0)
I RCNEW,$D(^RCD(340,"DMC",1,DEBTOR)) G TOTAL
"RTN","RCTOPD",169,0)
F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D
"RTN","RCTOPD",170,0)
.I FILE=2,+VADM(6) S TOTAL=0,REPAY=1 Q
"RTN","RCTOPD",171,0)
.S B0=$G(^PRCA(430,BILL,0)),B4=$G(^(4)),B6=$G(^(6)),B7=$G(^(7)),B14=$G(^(14))
"RTN","RCTOPD",172,0)
.Q:$P(B0,U,8)'=16
"RTN","RCTOPD",173,0)
.Q:B4
"RTN","RCTOPD",174,0)
.Q:'$P(B0,U,2) S CAT=$P($G(^PRCA(430.2,$P(B0,U,2),0)),U,7)
"RTN","RCTOPD",175,0)
.;*** PRCA*4.5*338 start
"RTN","RCTOPD",176,0)
.Q:'CAT ; I ",16,17,21,22,23,26,27,33,"[(","_CAT_",") Q
"RTN","RCTOPD",177,0)
.;Check the Refer to TOP field to see if this should be referred, based on AR Category
"RTN","RCTOPD",178,0)
.Q:'$$RFCHK(CAT,"N",1.02,ACTDT)
"RTN","RCTOPD",179,0)
.;*** PRCA*4.5*338 end
"RTN","RCTOPD",180,0)
.Q:$D(^PRCA(430,"TCSP",BILL)) ;cross-serviced bills
"RTN","RCTOPD",181,0)
.I '+B14,($P(B6,U,21)'<ACTDT) I ",1,2,3,24,29,30,31,32,40,41,42,43,44,45,46,"[(","_CAT_",") Q ;prca*4.5*301 cs activation date and 1st party bill
"RTN","RCTOPD",182,0)
.;check for DOJ referral here
"RTN","RCTOPD",183,0)
.I $P(B6,U,4),($P(B6,U,5)="DOJ") Q
"RTN","RCTOPD",184,0)
.S BILLDT=$P(B6,U,21) I (BILLDT<P10YDT)!(BILLDT>P121DT)!(BILLDT<$P(DEBTOR6,U,3)) Q
"RTN","RCTOPD",185,0)
.I '$P(B6,U,3) D Q
"RTN","RCTOPD",186,0)
..;no 3rd letter being sent
"RTN","RCTOPD",187,0)
..N TDEB,TFIL
"RTN","RCTOPD",188,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",189,0)
.I RCNEW,CAT>12,CAT<15 S HOLD=1
"RTN","RCTOPD",190,0)
.I BILLDT,BILLDT<EFFDT S EFFDT=BILLDT
"RTN","RCTOPD",191,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",192,0)
.S ^TMP("RCTOPD",$J,"BILL",BILL)=""
"RTN","RCTOPD",193,0)
.Q
"RTN","RCTOPD",194,0)
;
"RTN","RCTOPD",195,0)
TOTAL ;set transmission total, reset quit variable
"RTN","RCTOPD",196,0)
N RCSWINFO S RCSWINFO=$$SWSTAT^IBBAPI() ;PRCA*4.5*229
"RTN","RCTOPD",197,0)
I RCNEW,'+RCSWINFO Q:TOTAL<25 ;PRCA*4.5*229
"RTN","RCTOPD",198,0)
I RCNEW,+RCSWINFO Q:TOTAL'>0 ;PRCA*4.5*229
"RTN","RCTOPD",199,0)
;
"RTN","RCTOPD",200,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",201,0)
S QUIT=0
"RTN","RCTOPD",202,0)
PROCQ Q
"RTN","RCTOPD",203,0)
;
"RTN","RCTOPD",204,0)
NOW() ;compiles current date,time
"RTN","RCTOPD",205,0)
N X,Y,%,%H
"RTN","RCTOPD",206,0)
S %H=$H D YX^%DTC
"RTN","RCTOPD",207,0)
Q Y
"RTN","RCTOPD",208,0)
;
"RTN","RCTOPD",209,0)
FILE(DEBTOR0) ;gets file number for debtor
"RTN","RCTOPD",210,0)
S FILE=$P($P(DEBTOR0,U),";",2)
"RTN","RCTOPD",211,0)
S FILE=$S(FILE["DPT(":2,FILE["PRC(440":440,FILE["VA(200":200,1:0)
"RTN","RCTOPD",212,0)
FILEQ Q FILE
"RTN","RCTOPD",213,0)
;
"RTN","RCTOPD",214,0)
;PRCA*4.5*338
"RTN","RCTOPD",215,0)
RFCHK(RCXCAT,RCIENFLG,RCXRFCD,RCXDT) ;Check to see if bill can be referred to requested collections program
"RTN","RCTOPD",216,0)
;
"RTN","RCTOPD",217,0)
;Input:
"RTN","RCTOPD",218,0)
; RCXCAT - (Required) AR Category to check.
"RTN","RCTOPD",219,0)
; RCXIENFLG - Is the AR Category an IEN (I) or a number (N).
"RTN","RCTOPD",220,0)
; RCXRFCD - (Required) FileMan Field number for the Referral type being checked.
"RTN","RCTOPD",221,0)
; 1.01 - DMC
"RTN","RCTOPD",222,0)
; 1.02 - TOP
"RTN","RCTOPD",223,0)
; 1.03 - CS
"RTN","RCTOPD",224,0)
; RCXDT - (Required) Date of service to be checked.
"RTN","RCTOPD",225,0)
;
"RTN","RCTOPD",226,0)
N RCXFLG,RCXCTIEN,RCXSPDT
"RTN","RCTOPD",227,0)
;
"RTN","RCTOPD",228,0)
; Set the initial split date for the TOP and CS referral programs
"RTN","RCTOPD",229,0)
S RCXSPDT=3150801
"RTN","RCTOPD",230,0)
; Get the category IEN.
"RTN","RCTOPD",231,0)
S RCXCTIEN=RCXCAT ;Initially assume it is an IEN
"RTN","RCTOPD",232,0)
; Update to IEN if AR Category is the Category Number
"RTN","RCTOPD",233,0)
I RCIENFLG="N" S RCXCTIEN=$O(^PRCA(430.2,"AC",RCXCAT,""))
"RTN","RCTOPD",234,0)
; Quit if Category not found
"RTN","RCTOPD",235,0)
Q:RCXCTIEN="" 0
"RTN","RCTOPD",236,0)
;
"RTN","RCTOPD",237,0)
; Extract the flag for the category from the AR Category file (430.2), using the field number sent in
"RTN","RCTOPD",238,0)
S RCXCTIEN=RCXCTIEN_","
"RTN","RCTOPD",239,0)
S RCXFLG=$$GET1^DIQ(430.2,RCXCTIEN,RCXRFCD,"I")
"RTN","RCTOPD",240,0)
I RCXFLG<2 Q RCXFLG
"RTN","RCTOPD",241,0)
I RCXFLG=2,(RCXDT<RCXSPDT) Q 1
"RTN","RCTOPD",242,0)
I RCXFLG=3,(RCXDT'<RCXSPDT) Q 1
"RTN","RCTOPD",243,0)
Q 0
"RTN","RCXFMSPR")
0^6^B65169174
"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 17
"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)
S COLUMN2="F"
"RTN","RCXFMSPR",85,0)
N DATA,LOOP
"RTN","RCXFMSPR",86,0)
; print CCAD rsc's (PRCA*4.5*338)
"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,";;",2)="END") D
"RTN","RCXFMSPR",89,0)
. W !,$P(DATA,";;",2)
"RTN","RCXFMSPR",90,0)
Q
"RTN","RCXFMSPR",91,0)
;
"RTN","RCXFMSPR",92,0)
;
"RTN","RCXFMSPR",93,0)
GETDESC(RSC) ; return the description for the revenue source code
"RTN","RCXFMSPR",94,0)
N BINARY,COL3DESC,COLUMN2,COLUMN3,DESC
"RTN","RCXFMSPR",95,0)
;new resource codes for ineligible hosp reimb. and emergency/humanitarian reimb. PRCA*4.5*315
"RTN","RCXFMSPR",96,0)
I RSC="841Z" Q "Ineligible Hosp. Reimb. Ins., Inpatient"
"RTN","RCXFMSPR",97,0)
I RSC="842Z" Q "Ineligible Hosp. Reimb. Ins., Outpatient"
"RTN","RCXFMSPR",98,0)
I RSC="8UZZ" Q "Emergency/Humanitarian Reimb. Ins., Inpatient"
"RTN","RCXFMSPR",99,0)
I RSC="8VZZ" Q "Emergency/Humanitarian Reimb. Ins., Outpatient"
"RTN","RCXFMSPR",100,0)
I RSC="ARRV" Q "Miscellaneous"
"RTN","RCXFMSPR",101,0)
I RSC=8046 Q "Administrative"
"RTN","RCXFMSPR",102,0)
I RSC=8047 Q "Interest"
"RTN","RCXFMSPR",103,0)
I RSC=8048 Q "Marshal Fee and Court Cost"
"RTN","RCXFMSPR",104,0)
S DESC="UNKNOWN"
"RTN","RCXFMSPR",105,0)
S COLUMN2=$E(RSC,2)
"RTN","RCXFMSPR",106,0)
I "123456789ABCDEFGHIJKLMQRST"[COLUMN2 S DESC=$P($T(@("A"_COLUMN2)),";",3)
"RTN","RCXFMSPR",107,0)
; HSIF reference disabled by patch 203
"RTN","RCXFMSPR",108,0)
; I RSC="8B1Z"!(RSC="8C1Z") S DESC=DESC_" (HSIF)"
"RTN","RCXFMSPR",109,0)
I COLUMN2'=5 Q DESC
"RTN","RCXFMSPR",110,0)
;
"RTN","RCXFMSPR",111,0)
S COLUMN3=$E(RSC,3)
"RTN","RCXFMSPR",112,0)
; convert alpha letters to decimal
"RTN","RCXFMSPR",113,0)
I "0123456789"'[COLUMN3 S COLUMN3=$A(COLUMN3)-55
"RTN","RCXFMSPR",114,0)
S BINARY=$$CONVERT(COLUMN3)
"RTN","RCXFMSPR",115,0)
S COL3DESC=$P($T(@("B"_$E(BINARY,1,2))),";",3)
"RTN","RCXFMSPR",116,0)
S COL3DESC=COL3DESC_", "_$P($T(@("C"_$E(BINARY,3))),";",3)
"RTN","RCXFMSPR",117,0)
S COL3DESC=COL3DESC_", "_$P($T(@("D"_$E(BINARY,4))),";",3)
"RTN","RCXFMSPR",118,0)
S COL3DESC=COL3DESC_", "_$P($T(@("E"_$E(BINARY,5))),";",3)
"RTN","RCXFMSPR",119,0)
Q "RHI, "_COL3DESC
"RTN","RCXFMSPR",120,0)
;
"RTN","RCXFMSPR",121,0)
;
"RTN","RCXFMSPR",122,0)
CONVERT(DECIMAL) ; convert decimal number to binary (5 digits)
"RTN","RCXFMSPR",123,0)
N Y
"RTN","RCXFMSPR",124,0)
S Y=""
"RTN","RCXFMSPR",125,0)
F S Y=$E("0123456789ABCDEF",DECIMAL#2+1)_Y,DECIMAL=DECIMAL\2 Q:DECIMAL<1
"RTN","RCXFMSPR",126,0)
S Y=$E("00000",0,5-$L(Y))_Y
"RTN","RCXFMSPR",127,0)
Q Y
"RTN","RCXFMSPR",128,0)
;
"RTN","RCXFMSPR",129,0)
;
"RTN","RCXFMSPR",130,0)
WRITEIT ; display the rsc
"RTN","RCXFMSPR",131,0)
W !,COLUMN1,COLUMN2,COLUMN3,COLUMN4,?6,DESCRIP
"RTN","RCXFMSPR",132,0)
I $Y>(IOSL-5) D:SCREEN PAUSE Q:$G(RCSTFLAG) D H
"RTN","RCXFMSPR",133,0)
Q
"RTN","RCXFMSPR",134,0)
;
"RTN","RCXFMSPR",135,0)
;
"RTN","RCXFMSPR",136,0)
PAUSE ; pause at end of page
"RTN","RCXFMSPR",137,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",138,0)
Q
"RTN","RCXFMSPR",139,0)
;
"RTN","RCXFMSPR",140,0)
;
"RTN","RCXFMSPR",141,0)
H ; header
"RTN","RCXFMSPR",142,0)
S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
"RTN","RCXFMSPR",143,0)
W $C(13),"REVENUE SOURCE CODE REPORT (VISTA TO FMS)",?(80-$L(%)),%
"RTN","RCXFMSPR",144,0)
W !,"RSC",?6,"Description"
"RTN","RCXFMSPR",145,0)
S %="",$P(%,"-",81)=""
"RTN","RCXFMSPR",146,0)
W !,%
"RTN","RCXFMSPR",147,0)
Q
"RTN","RCXFMSPR",148,0)
;
"RTN","RCXFMSPR",149,0)
;
"RTN","RCXFMSPR",150,0)
; this is a listing of all column2 values with a description
"RTN","RCXFMSPR",151,0)
A1 ;;Hospital Care (NSC)
"RTN","RCXFMSPR",152,0)
A2 ;;Outpatient Care (NSC)
"RTN","RCXFMSPR",153,0)
A3 ;;Nursing Home Care (NSC)
"RTN","RCXFMSPR",154,0)
A4 ;;Ineligible Hospitalization
"RTN","RCXFMSPR",155,0)
A5 ;;Reimbursable Health Insurance
"RTN","RCXFMSPR",156,0)
A6 ;;Tort Feasor
"RTN","RCXFMSPR",157,0)
A7 ;;Workmans Compensation (Non-Federal)
"RTN","RCXFMSPR",158,0)
A8 ;;C (Means Test)
"RTN","RCXFMSPR",159,0)
A9 ;;Emergency/Humanitarian
"RTN","RCXFMSPR",160,0)
AA ;;No Fault Auto Accident
"RTN","RCXFMSPR",161,0)
AB ;;Pharmacy Co-Pay (SC Vet)
"RTN","RCXFMSPR",162,0)
AC ;;Pharmacy Co-Pay (NSC Vet)
"RTN","RCXFMSPR",163,0)
AD ;;Nursing Home Care Per Diem
"RTN","RCXFMSPR",164,0)
AE ;;Hospital Care Per Diem
"RTN","RCXFMSPR",165,0)
AF ;;Medicare
"RTN","RCXFMSPR",166,0)
AG ;;Adult Day Health Care (LTC)
"RTN","RCXFMSPR",167,0)
AH ;;Domiciliary (LTC)
"RTN","RCXFMSPR",168,0)
AI ;;Respite Care-Institutional (LTC)
"RTN","RCXFMSPR",169,0)
AJ ;;Respite Care-Non-Institutional (LTC)
"RTN","RCXFMSPR",170,0)
AK ;;Geriatric Eval-Institutional (LTC)
"RTN","RCXFMSPR",171,0)
AL ;;Geriatric Eval-Non-Institutional (LTC)
"RTN","RCXFMSPR",172,0)
AM ;;Nursing Home Care-Long Term Care (LTC)
"RTN","RCXFMSPR",173,0)
AQ ;;Pharmacy No Fault Auto Acc
"RTN","RCXFMSPR",174,0)
AR ;;Pharmacy Reimburs Health Ins
"RTN","RCXFMSPR",175,0)
AS ;;Pharmacy Tort Feasor
"RTN","RCXFMSPR",176,0)
AT ;;Pharmacy Workman's Comp
"RTN","RCXFMSPR",177,0)
;
"RTN","RCXFMSPR",178,0)
;
"RTN","RCXFMSPR",179,0)
; this is a listing for the type of care, first 2 binary digits
"RTN","RCXFMSPR",180,0)
; if column2 is reimbursable health insurance
"RTN","RCXFMSPR",181,0)
B00 ;;Inpatient (Hosp)
"RTN","RCXFMSPR",182,0)
B01 ;;Outpatient
"RTN","RCXFMSPR",183,0)
B10 ;;Nursing Home
"RTN","RCXFMSPR",184,0)
B11 ;;Other
"RTN","RCXFMSPR",185,0)
;
"RTN","RCXFMSPR",186,0)
;
"RTN","RCXFMSPR",187,0)
; this is a listing for the service connected, binary digit 3
"RTN","RCXFMSPR",188,0)
C0 ;;SC for NSC
"RTN","RCXFMSPR",189,0)
C1 ;;NSC Vet
"RTN","RCXFMSPR",190,0)
;
"RTN","RCXFMSPR",191,0)
;
"RTN","RCXFMSPR",192,0)
; this is a listing for means test, binary digit 4
"RTN","RCXFMSPR",193,0)
D0 ;;MT Cat A
"RTN","RCXFMSPR",194,0)
D1 ;;MT Cat C
"RTN","RCXFMSPR",195,0)
;
"RTN","RCXFMSPR",196,0)
;
"RTN","RCXFMSPR",197,0)
; this is a listing for age group, binary digit 5
"RTN","RCXFMSPR",198,0)
E0 ;;Age <65
"RTN","RCXFMSPR",199,0)
E1 ;;Age 65+
"RTN","RCXFMSPR",200,0)
;
"RTN","RCXFMSPR",201,0)
;
"RTN","RCXFMSPR",202,0)
; Community Care RSC listing PRCA*4.5*338
"RTN","RCXFMSPR",203,0)
CCADRSC ;;
"RTN","RCXFMSPR",204,0)
;;8C6C CC 3RD-PTY WORKERS' COMP
"RTN","RCXFMSPR",205,0)
;;8C5C CC 3RD-PTY TORT FEASOR
"RTN","RCXFMSPR",206,0)
;;8C4C CC 3RD-PTY NO-FAULT AUTO
"RTN","RCXFMSPR",207,0)
;;8C1C CC 3RD-PTY INPATIENT
"RTN","RCXFMSPR",208,0)
;;8C2C CC 3RD-PTY OUTPATIENT
"RTN","RCXFMSPR",209,0)
;;8C3C CC 3RD-PTY RX
"RTN","RCXFMSPR",210,0)
;;86CC CC CHOICE 3RD-PTY WORKERS'
"RTN","RCXFMSPR",211,0)
;;85CC CC CHOICE 3RD-PTY TORT
"RTN","RCXFMSPR",212,0)
;;84CC CC CHOICE 3RD-PTY NF AUTO
"RTN","RCXFMSPR",213,0)
;;81CC CC CHOICE 3RD-PTY INPATIENT
"RTN","RCXFMSPR",214,0)
;;82CC CC CHOICE 3RD-PTY OUTPATIENT
"RTN","RCXFMSPR",215,0)
;;83CC CC CHOICE 3RD-PTY RX
"RTN","RCXFMSPR",216,0)
;;8CD4 CC DOD 3RD-PTY INPATIENT
"RTN","RCXFMSPR",217,0)
;;8CD5 CC DOD 3RD-PTY OUTPATIENT
"RTN","RCXFMSPR",218,0)
;;8CD6 CC DOD 3RD-PTY RX
"RTN","RCXFMSPR",219,0)
;;8CNW CCN 3RD-PTY WORKERS'
"RTN","RCXFMSPR",220,0)
;;8CN9 CCN 3RD-PTY TORT
"RTN","RCXFMSPR",221,0)
;;8CN8 CCN 3RD-PTY NF AUTO
"RTN","RCXFMSPR",222,0)
;;8CN5 CCN 3RD-PTY INPATIENT
"RTN","RCXFMSPR",223,0)
;;8CN6 CCN 3RD-PTY OUTPATIENT
"RTN","RCXFMSPR",224,0)
;;8CN7 CCN 3RD-PTY RX
"RTN","RCXFMSPR",225,0)
;;8CC1 CC 1ST-PTY INPATIENT
"RTN","RCXFMSPR",226,0)
;;8CC2 CC 1ST-PTY OUTPATIENT
"RTN","RCXFMSPR",227,0)
;;8CC3 CC 1ST-PTY RX
"RTN","RCXFMSPR",228,0)
;;8CC4 CC 1ST-PTY LTC
"RTN","RCXFMSPR",229,0)
;;8CC5 CC CHOICE 1ST-PTY INPATIENT
"RTN","RCXFMSPR",230,0)
;;8CC6 CC CHOICE 1ST-PTY OUTPATIENT
"RTN","RCXFMSPR",231,0)
;;8CC7 CC CHOICE 1ST-PTY RX
"RTN","RCXFMSPR",232,0)
;;8CC8 CC CHOICE 1ST-PTY LTC
"RTN","RCXFMSPR",233,0)
;;8CN1 CCN 1ST-PTY INPATIENT
"RTN","RCXFMSPR",234,0)
;;8CN2 CCN 1ST-PTY OUTPATIENT
"RTN","RCXFMSPR",235,0)
;;8CN3 CCN 1ST-PTY RX
"RTN","RCXFMSPR",236,0)
;;8CN4 CCN 1ST-PTY LTC
"RTN","RCXFMSPR",237,0)
;;8CD1 CC DOD 1ST-PTY INPATIENT
"RTN","RCXFMSPR",238,0)
;;8CD2 CC DOD 1ST-PTY OUTPATIENT
"RTN","RCXFMSPR",239,0)
;;8CD3 CC DOD 1ST-PTY RX
"RTN","RCXFMSPR",240,0)
;;8CC1 CC 1ST-PTY PER DIEM
"RTN","RCXFMSPR",241,0)
;;8CC5 CC CHOICE 1ST-PTY PER DIEM
"RTN","RCXFMSPR",242,0)
;;8CN1 CCN 1ST-PTY PER DIEM
"RTN","RCXFMSPR",243,0)
;;8CD1 CC DOD 1ST-PTY PER DIEM
"RTN","RCXFMSPR",244,0)
;;8085 DOD DISABILITY EVALUATION SYSTEM (DES)
"RTN","RCXFMSPR",245,0)
;;8086 DOD SPINAL CORD INPATIENT
"RTN","RCXFMSPR",246,0)
;;8087 DOD SPINAL CORD OUTPATIENT
"RTN","RCXFMSPR",247,0)
;;8088 DOD SPINAL CORD OTHER
"RTN","RCXFMSPR",248,0)
;;8089 DOD TRAUMATIC BRAIN INJURY INPATIENT
"RTN","RCXFMSPR",249,0)
;;8090 TRAUMATIC BRAIN INJURY OUTPATIENT
"RTN","RCXFMSPR",250,0)
;;8091 TRAUMATIC BRAIN INJURY OTHER
"RTN","RCXFMSPR",251,0)
;;8092 BLIND REHABILITATION INPATIENT
"RTN","RCXFMSPR",252,0)
;;8093 BLIND REHABILITATION OUTPATIENT
"RTN","RCXFMSPR",253,0)
;;8094 BLIND REHABILITATION OTHER
"RTN","RCXFMSPR",254,0)
;;8095 TRICARE PHARMACY
"RTN","RCXFMSPR",255,0)
;;8096 TRICARE ACTIVE DUTY DENTAL
"RTN","RCXFMSPR",256,0)
;;END
"RTN","RCXFMSUF")
0^2^B57827951
"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 17
"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 ;0160A1
"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 ;0160A1
"RTN","RCXFMSUF",124,0)
13 ;;FEDERAL AGENCIES-REFUND ;0160A1 ;0160A1
"RTN","RCXFMSUF",125,0)
14 ;;FEDERAL AGENCIES-REIMB. ;0160A1 ;0160A1
"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 ;0160A1
"RTN","RCXFMSUF",131,0)
20 ;;INTERAGENCY ;0160A1 ;0160A1
"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 ;0160A1
"RTN","RCXFMSUF",140,0)
29 ;;CHAMPVA ;0160A1 ;0160A1
"RTN","RCXFMSUF",141,0)
30 ;;TRICARE ;0160A1 ;0160A1
"RTN","RCXFMSUF",142,0)
31 ;;TRICARE PATIENT ;0160A1 ;0160A1
"RTN","RCXFMSUF",143,0)
32 ;;TRICARE THIRD PARTY ;0160A1 ;0160A1
"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. ; ;0160A1 ;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 ; ;528713
"RTN","RCXFMSUF",187,0)
76 ;;TRICARE SCI ; ;528713
"RTN","RCXFMSUF",188,0)
77 ;;TRICARE TBI ; ;528713
"RTN","RCXFMSUF",189,0)
78 ;;TRICARE BLIND REHABILITATION ; ;528713
"RTN","RCXFMSUF",190,0)
79 ;;TRICARE DENTAL ; ;528713
"RTN","RCXFMSUF",191,0)
80 ;;TRICARE PHARMACY ; ;528713
"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^B109509450
"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 17
"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 and exit.
"RTN","RCXFMSUR",21,0)
I CATEGDA>47,(CATEGDA<75) Q $$GETCCRSC(CATEGDA,BILLDA)
"RTN","RCXFMSUR",22,0)
I CATEGDA>80,(CATEGDA<85) Q $$GETCCRSC(CATEGDA,BILLDA)
"RTN","RCXFMSUR",23,0)
;
"RTN","RCXFMSUR",24,0)
; if prepayment, send ARRV
"RTN","RCXFMSUR",25,0)
I CATEGDA=26 D STORE(BILLDA,"ARRV") Q "ARRV"
"RTN","RCXFMSUR",26,0)
;
"RTN","RCXFMSUR",27,0)
S COLUMN1=$$COLUMN1
"RTN","RCXFMSUR",28,0)
;
"RTN","RCXFMSUR",29,0)
; check for 3rd party RX bills after 4/27/2011 for col 2
"RTN","RCXFMSUR",30,0)
N RX3P S RX3P=0
"RTN","RCXFMSUR",31,0)
I ("PH"=$$TYP^IBRFN(BILLDA)) D
"RTN","RCXFMSUR",32,0)
. S RX3P=$$CHECKRXS^RCXFMSUF(BILLDA)
"RTN","RCXFMSUR",33,0)
;
"RTN","RCXFMSUR",34,0)
S COLUMN2=$$COLUMN2
"RTN","RCXFMSUR",35,0)
;
"RTN","RCXFMSUR",36,0)
; if column2 cannot be determined, return the rsc of ARRV
"RTN","RCXFMSUR",37,0)
I COLUMN2="" D STORE(BILLDA,"ARRV") Q "ARRV"
"RTN","RCXFMSUR",38,0)
;
"RTN","RCXFMSUR",39,0)
; if column2 is not a 5 for reimbursable health insurance, or category not 45 (FEE REIMB INS)
"RTN","RCXFMSUR",40,0)
; return ZZ in columns 3 and 4
"RTN","RCXFMSUR",41,0)
I COLUMN2'=5,CATEGDA'=45 D STORE(BILLDA,COLUMN1_COLUMN2_"ZZ") Q COLUMN1_COLUMN2_"ZZ"
"RTN","RCXFMSUR",42,0)
;
"RTN","RCXFMSUR",43,0)
; for reimbursable health insurance, compute columns 3 and 4
"RTN","RCXFMSUR",44,0)
S COLUMN3=$$COLUMN3
"RTN","RCXFMSUR",45,0)
S COLUMN4=$$COLUMN4
"RTN","RCXFMSUR",46,0)
;
"RTN","RCXFMSUR",47,0)
D STORE(BILLDA,COLUMN1_COLUMN2_COLUMN3_COLUMN4)
"RTN","RCXFMSUR",48,0)
Q COLUMN1_COLUMN2_COLUMN3_COLUMN4
"RTN","RCXFMSUR",49,0)
;
"RTN","RCXFMSUR",50,0)
;
"RTN","RCXFMSUR",51,0)
STORE(DA,RSC,FUND) ; store the revenue source code or fund in the file
"RTN","RCXFMSUR",52,0)
I $G(^PRCA(430,DA,0))="" Q
"RTN","RCXFMSUR",53,0)
N D,D0,DI,DIC,DIE,DQ,DR,X,Y
"RTN","RCXFMSUR",54,0)
S DR=""
"RTN","RCXFMSUR",55,0)
I $G(RSC)'="" S DR="255.1////"_RSC_";"
"RTN","RCXFMSUR",56,0)
I $G(FUND)'="" S DR=DR_"203////"_FUND_";"
"RTN","RCXFMSUR",57,0)
S (DIC,DIE)="^PRCA(430,"
"RTN","RCXFMSUR",58,0)
D ^DIE
"RTN","RCXFMSUR",59,0)
Q
"RTN","RCXFMSUR",60,0)
;
"RTN","RCXFMSUR",61,0)
;
"RTN","RCXFMSUR",62,0)
COLUMN1() ; return column 1 number
"RTN","RCXFMSUR",63,0)
Q 8
"RTN","RCXFMSUR",64,0)
;
"RTN","RCXFMSUR",65,0)
;
"RTN","RCXFMSUR",66,0)
COLUMN2() ; return column 2 number
"RTN","RCXFMSUR",67,0)
I CATEGDA=5 Q 1 ; hospital care (nsc)
"RTN","RCXFMSUR",68,0)
I CATEGDA=4 Q 2 ; outpatient care (nsc)
"RTN","RCXFMSUR",69,0)
I CATEGDA=3 Q 3 ; nursing home care (nsc)
"RTN","RCXFMSUR",70,0)
I CATEGDA=1 Q 4 ; ineligible hospital
"RTN","RCXFMSUR",71,0)
I CATEGDA=9&$G(RX3P) Q "R" ; pharmacy reimbursable health insurance
"RTN","RCXFMSUR",72,0)
I CATEGDA=9 Q 5 ; reimbursable health insurance
"RTN","RCXFMSUR",73,0)
I CATEGDA=10&$G(RX3P) Q "S" ; pharmacy tort feasor
"RTN","RCXFMSUR",74,0)
I CATEGDA=10 Q 6 ; tort feasor
"RTN","RCXFMSUR",75,0)
I CATEGDA=6&$G(RX3P) Q "T" ;pharmacy workman's comp
"RTN","RCXFMSUR",76,0)
I CATEGDA=6 Q 7 ; workmans comp
"RTN","RCXFMSUR",77,0)
I CATEGDA=18 Q 8 ; c (means test)
"RTN","RCXFMSUR",78,0)
I CATEGDA=2 Q 9 ; emergency/humanitarian
"RTN","RCXFMSUR",79,0)
I CATEGDA=7&$G(RX3P) Q "Q" ;pharmacy no fault auto acc
"RTN","RCXFMSUR",80,0)
I CATEGDA=7 Q "A" ; no fault auto accident
"RTN","RCXFMSUR",81,0)
I CATEGDA=22 Q "B" ; rx copay/sc vet
"RTN","RCXFMSUR",82,0)
I CATEGDA=23 Q "C" ; rx copay/nsc vet
"RTN","RCXFMSUR",83,0)
I CATEGDA=24 Q "D" ; nursing home care per diem
"RTN","RCXFMSUR",84,0)
I CATEGDA=25 Q "E" ; hospital care per diem
"RTN","RCXFMSUR",85,0)
I CATEGDA=21 Q "F" ; medicare
"RTN","RCXFMSUR",86,0)
I CATEGDA=33 Q "G" ; adult day health care
"RTN","RCXFMSUR",87,0)
I CATEGDA=34 Q "H" ; domiciliary
"RTN","RCXFMSUR",88,0)
I CATEGDA=35 Q "I" ; respite care - institutional
"RTN","RCXFMSUR",89,0)
I CATEGDA=36 Q "J" ; respite care - non-institutional
"RTN","RCXFMSUR",90,0)
I CATEGDA=37 Q "K" ; geriatric evaluation - institutional
"RTN","RCXFMSUR",91,0)
I CATEGDA=38 Q "L" ; geriatric evaluation - non-institutional
"RTN","RCXFMSUR",92,0)
I CATEGDA=39 Q "M" ; nursing home care - ltc
"RTN","RCXFMSUR",93,0)
I CATEGDA=45 Q "F" ; Fee Basis
"RTN","RCXFMSUR",94,0)
I CATEGDA=46 D Q COLUMN2
"RTN","RCXFMSUR",95,0)
. N COL
"RTN","RCXFMSUR",96,0)
. D DIQ399(BILLDA)
"RTN","RCXFMSUR",97,0)
. S COL=$G(IBCNDATA(399,BILLDA,.05,"I"))
"RTN","RCXFMSUR",98,0)
. S COLUMN2=$S(COL=1:"U",COL=2:"U",COL=3:"V",1:"V")
"RTN","RCXFMSUR",99,0)
Q ""
"RTN","RCXFMSUR",100,0)
;
"RTN","RCXFMSUR",101,0)
;
"RTN","RCXFMSUR",102,0)
COLUMN3() ; return the column 3 number
"RTN","RCXFMSUR",103,0)
N AGE,DECIMAL,DFN,IBCNDATA,TYPEAGE,TYPECARE,TYPEMEAN,TYPESERV,VA,VADM,VAERR
"RTN","RCXFMSUR",104,0)
;
"RTN","RCXFMSUR",105,0)
D DIQ399(BILLDA)
"RTN","RCXFMSUR",106,0)
;
"RTN","RCXFMSUR",107,0)
; PRCA*4.5*310/DRF
"RTN","RCXFMSUR",108,0)
; for Fee Basis, column3 = 1 (inpatient) or 2 (outpatient)
"RTN","RCXFMSUR",109,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",110,0)
;
"RTN","RCXFMSUR",111,0)
D TYPECARE
"RTN","RCXFMSUR",112,0)
;
"RTN","RCXFMSUR",113,0)
; compute service connected at time of care (1 digit binary)
"RTN","RCXFMSUR",114,0)
; type of service connected is set as follows:
"RTN","RCXFMSUR",115,0)
; 0 = SC Vet 1 = NSC Vet
"RTN","RCXFMSUR",116,0)
S TYPESERV=1
"RTN","RCXFMSUR",117,0)
; service connected at time of care (.18) = yes (1)
"RTN","RCXFMSUR",118,0)
I $G(IBCNDATA(399,BILLDA,.18,"I"))=1 S TYPESERV=0
"RTN","RCXFMSUR",119,0)
;
"RTN","RCXFMSUR",120,0)
S DFN=$P($G(^PRCA(430,BILLDA,0)),"^",7)
"RTN","RCXFMSUR",121,0)
D DEM^VADPT
"RTN","RCXFMSUR",122,0)
;
"RTN","RCXFMSUR",123,0)
; compute means test at time of care (1 digit binary)
"RTN","RCXFMSUR",124,0)
; type of means test is set as follows:
"RTN","RCXFMSUR",125,0)
; 0 = Cat A 1 = Cat C
"RTN","RCXFMSUR",126,0)
S TYPEMEAN=0
"RTN","RCXFMSUR",127,0)
I $$BIL^DGMTUB(DFN,$G(IBCNDATA(399,BILLDA,151,"I")))=1 S TYPEMEAN=1
"RTN","RCXFMSUR",128,0)
;
"RTN","RCXFMSUR",129,0)
; compute patient age at time of care (1 digit binary)
"RTN","RCXFMSUR",130,0)
; type of age is set as follows:
"RTN","RCXFMSUR",131,0)
; 0 = under 65 1 = 65 and older
"RTN","RCXFMSUR",132,0)
S AGE=$$FMDIFF^XLFDT($G(IBCNDATA(399,BILLDA,151,"I")),$P($G(VADM(3)),"^"))\365.25
"RTN","RCXFMSUR",133,0)
S TYPEAGE=1
"RTN","RCXFMSUR",134,0)
I AGE<65 S TYPEAGE=0
"RTN","RCXFMSUR",135,0)
;
"RTN","RCXFMSUR",136,0)
; convert to decimal typecare typeserv typemean typeage
"RTN","RCXFMSUR",137,0)
; binary= 1 1 1 1 1
"RTN","RCXFMSUR",138,0)
; decimal= 16 + 8 + 4 + 2 + 1
"RTN","RCXFMSUR",139,0)
S DECIMAL=$S(TYPECARE="11":24,TYPECARE="10":16,TYPECARE="01":8,1:0)
"RTN","RCXFMSUR",140,0)
I TYPESERV S DECIMAL=DECIMAL+4
"RTN","RCXFMSUR",141,0)
I TYPEMEAN S DECIMAL=DECIMAL+2
"RTN","RCXFMSUR",142,0)
I TYPEAGE S DECIMAL=DECIMAL+1
"RTN","RCXFMSUR",143,0)
I DECIMAL<10 Q DECIMAL
"RTN","RCXFMSUR",144,0)
Q $C(65+DECIMAL-10)
"RTN","RCXFMSUR",145,0)
;
"RTN","RCXFMSUR",146,0)
;
"RTN","RCXFMSUR",147,0)
COLUMN4() ; return the column 4 number (reserved for future expansion)
"RTN","RCXFMSUR",148,0)
Q "Z"
"RTN","RCXFMSUR",149,0)
;
"RTN","RCXFMSUR",150,0)
;
"RTN","RCXFMSUR",151,0)
DIQ399(DA) ; get data from file 399
"RTN","RCXFMSUR",152,0)
N D0,DIC,DIQ,DIQ2,DR
"RTN","RCXFMSUR",153,0)
K IBCNDATA
"RTN","RCXFMSUR",154,0)
S DIQ(0)="IE",DIC="^DGCR(399,",DIQ="IBCNDATA",DR=".04;.05;.18;151;" D EN^DIQ1
"RTN","RCXFMSUR",155,0)
Q
"RTN","RCXFMSUR",156,0)
;
"RTN","RCXFMSUR",157,0)
;
"RTN","RCXFMSUR",158,0)
TYPECARE ; compute type of care (2 digit binary)
"RTN","RCXFMSUR",159,0)
; type of care is set as follows:
"RTN","RCXFMSUR",160,0)
; 00 = inpatient (hospital) 01 = outpatient
"RTN","RCXFMSUR",161,0)
; 10 = nursing home 11 = other
"RTN","RCXFMSUR",162,0)
; default is other if it cannot be computed
"RTN","RCXFMSUR",163,0)
S TYPECARE="11"
"RTN","RCXFMSUR",164,0)
; bill classification (.05) = outpatient (3) or human.emerg(opt) (4)
"RTN","RCXFMSUR",165,0)
I $G(IBCNDATA(399,BILLDA,.05,"I"))=3!($G(IBCNDATA(399,BILLDA,.05,"I"))=4) S TYPECARE="01" Q
"RTN","RCXFMSUR",166,0)
; location of care (.04) = hospital inpt or outpt (1)
"RTN","RCXFMSUR",167,0)
I $G(IBCNDATA(399,BILLDA,.04,"I"))=1 S TYPECARE="00" Q
"RTN","RCXFMSUR",168,0)
; location of care (.04) = skilled nursing (nhcu) (2)
"RTN","RCXFMSUR",169,0)
I $G(IBCNDATA(399,BILLDA,.04,"I"))=2 S TYPECARE="10"
"RTN","RCXFMSUR",170,0)
Q
"RTN","RCXFMSUR",171,0)
;
"RTN","RCXFMSUR",172,0)
;
"RTN","RCXFMSUR",173,0)
ADDEDIT ; enter/edit revenue source codes for fund 0160A1 bills. These
"RTN","RCXFMSUR",174,0)
; bills have the rsc entered by the user. The user can select
"RTN","RCXFMSUR",175,0)
; from rscs in file 347.3
"RTN","RCXFMSUR",176,0)
W !!,"This option should be used with CAUTION. This option will allow the"
"RTN","RCXFMSUR",177,0)
W !,"user owning the PRCASVC supervisor security key, to add or edit the"
"RTN","RCXFMSUR",178,0)
W !,"Revenue Source Codes selectable for non MCCF bills. If an invalid"
"RTN","RCXFMSUR",179,0)
W !,"Revenue Source Code is entered or changed, all code sheets sent to"
"RTN","RCXFMSUR",180,0)
W !,"FMS referencing the invalid Revenue Source Code will reject. Be"
"RTN","RCXFMSUR",181,0)
W !,"cautious when entering new Revenue Source Codes or editing existing"
"RTN","RCXFMSUR",182,0)
W !,"Revenue Source Codes. New Revenue Source Codes should only be added"
"RTN","RCXFMSUR",183,0)
W !,"after they have been added in FMS."
"RTN","RCXFMSUR",184,0)
;
"RTN","RCXFMSUR",185,0)
I '$D(^XUSEC("PRCASVC",DUZ)) W !!,"You are not an owner of the PRCASVC security key." Q
"RTN","RCXFMSUR",186,0)
;
"RTN","RCXFMSUR",187,0)
N %,%Y,C,D,D0,DA,DI,DIC,DIE,DLAYGO,DQ,DR,RCRJFLAG,X,X1,X2,X3,Y
"RTN","RCXFMSUR",188,0)
;
"RTN","RCXFMSUR",189,0)
F D Q:$G(RCRJFLAG)
"RTN","RCXFMSUR",190,0)
. S (DIC,DIE)="^RC(347.3,",DIC(0)="QEL",DLAYGO=347.3
"RTN","RCXFMSUR",191,0)
. R !!,"Select REVENUE SOURCE CODE: ",X:DTIME
"RTN","RCXFMSUR",192,0)
. S X1=X,X=$$UPPER^VALM1(X)
"RTN","RCXFMSUR",193,0)
. I $E(X)="?",X?."?" D ^DIC Q:Y<1
"RTN","RCXFMSUR",194,0)
. I X=""!($E(X)=U) S RCRJFLAG=1 Q
"RTN","RCXFMSUR",195,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",196,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",197,0)
. S D="C" D IX^DIC Q:Y<1 D UPD Q
"RTN","RCXFMSUR",198,0)
Q
"RTN","RCXFMSUR",199,0)
UPD S DIE="^RC(347.3,",DA=+Y,DR=".02;.03" D ^DIE
"RTN","RCXFMSUR",200,0)
Q
"RTN","RCXFMSUR",201,0)
;
"RTN","RCXFMSUR",202,0)
;
"RTN","RCXFMSUR",203,0)
RSC ;revenue code (#430/255)
"RTN","RCXFMSUR",204,0)
I $P($G(^RC(347.3,X,0)),"^",3) D EN^DDIOL("THIS REVENUE SOURCE CODE IS INACTIVE.") K X Q
"RTN","RCXFMSUR",205,0)
S X=$P(^RC(347.3,X,0),"^")
"RTN","RCXFMSUR",206,0)
Q
"RTN","RCXFMSUR",207,0)
;
"RTN","RCXFMSUR",208,0)
SHOW ; show/calculate revenue source code for a selected bill
"RTN","RCXFMSUR",209,0)
W !!,"This option will show the calculated Revenue Source Code for a selected"
"RTN","RCXFMSUR",210,0)
W !,"bill. The Revenue Source Code is only calculated for accrued bills in"
"RTN","RCXFMSUR",211,0)
I DT'<$$ADDPTEDT^PRCAACC() W !,"funds 528701,528703,528704,528709/4032,528711,528713"
"RTN","RCXFMSUR",212,0)
I DT<$$ADDPTEDT^PRCAACC() W !,"funds 5287.1,5287.3,5287.4,4032"
"RTN","RCXFMSUR",213,0)
;
"RTN","RCXFMSUR",214,0)
N %,%Y,BILLDA,C,DIC,FUND,I,RCRJFLAG,RSC,X,Y
"RTN","RCXFMSUR",215,0)
;
"RTN","RCXFMSUR",216,0)
F D Q:$G(RCRJFLAG)
"RTN","RCXFMSUR",217,0)
. S DIC="^PRCA(430,",DIC(0)="QEAM"
"RTN","RCXFMSUR",218,0)
. W ! D ^DIC
"RTN","RCXFMSUR",219,0)
. I Y<1 S RCRJFLAG=1 Q
"RTN","RCXFMSUR",220,0)
. S BILLDA=+Y
"RTN","RCXFMSUR",221,0)
. S FUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
"RTN","RCXFMSUR",222,0)
. W !!," Bill Number: ",$P($G(^PRCA(430,BILLDA,0)),"^")
"RTN","RCXFMSUR",223,0)
. W !," Fund: ",FUND
"RTN","RCXFMSUR",224,0)
. I '$$PTACCT^PRCAACC(FUND),FUND'=4032 D Q
"RTN","RCXFMSUR",225,0)
. . W !," The Revenue Source Code cannot be calculated for non-accrued bills."
"RTN","RCXFMSUR",226,0)
. . W !," The Revenue Source Code for non-accrued bills are input by the user."
"RTN","RCXFMSUR",227,0)
. . W !," The Revenue Source Code is currently entered as: "
"RTN","RCXFMSUR",228,0)
. . S RSC=$P($G(^PRCA(430,BILLDA,11)),"^",6)
"RTN","RCXFMSUR",229,0)
. . W $S(RSC="":"<not entered>",1:RSC)
"RTN","RCXFMSUR",230,0)
. ;
"RTN","RCXFMSUR",231,0)
. S RSC=$$CALCRSC(BILLDA)
"RTN","RCXFMSUR",232,0)
. W !,"Revenue Source Code: ",RSC
"RTN","RCXFMSUR",233,0)
Q
"RTN","RCXFMSUR",234,0)
;
"RTN","RCXFMSUR",235,0)
;PRCA*4.5*338
"RTN","RCXFMSUR",236,0)
GETCCRSC(CATEGDA,BILLDA) ;Retrieve the RSC for Community Care Categories
"RTN","RCXFMSUR",237,0)
N RCRSC,IBCNDATA,RCIOPFLG,RX3P
"RTN","RCXFMSUR",238,0)
S RCRSC=""
"RTN","RCXFMSUR",239,0)
Q:CATEGDA=52 "84CC" ;Choice No-Fault Auto AR Category
"RTN","RCXFMSUR",240,0)
Q:CATEGDA=53 "85CC" ;Choice TORT Feasor AR Category
"RTN","RCXFMSUR",241,0)
Q:CATEGDA=60 "86CC" ;Choice Workers' Comp AR Category
"RTN","RCXFMSUR",242,0)
Q:CATEGDA=54 "8CNW" ;CCN Workers' Comp AR Category
"RTN","RCXFMSUR",243,0)
Q:CATEGDA=55 "8CN9" ;CCN TORT Feasor AR Category
"RTN","RCXFMSUR",244,0)
Q:CATEGDA=56 "8CN8" ;CCN No-Fault Auto AR Category
"RTN","RCXFMSUR",245,0)
Q:CATEGDA=57 "8C6C" ;CC Workers' Comp AR Category
"RTN","RCXFMSUR",246,0)
Q:CATEGDA=58 "8C5C" ;CC TORT Feasor AR Category
"RTN","RCXFMSUR",247,0)
Q:CATEGDA=59 "8C4C" ;CC No-Fault Auto AR Category
"RTN","RCXFMSUR",248,0)
Q:CATEGDA=61 "8CC5" ;CHOICE Inpatient Copay
"RTN","RCXFMSUR",249,0)
Q:CATEGDA=62 "8CC7" ;CHOICE RX CO-PAYMENT Copay
"RTN","RCXFMSUR",250,0)
Q:CATEGDA=63 "8CC1" ;CC Inpatient Copay
"RTN","RCXFMSUR",251,0)
Q:CATEGDA=64 "8CC3" ;CC RX CO-PAYMENT
"RTN","RCXFMSUR",252,0)
Q:CATEGDA=65 "8CN1" ;CCN Inpatient Copay
"RTN","RCXFMSUR",253,0)
Q:CATEGDA=66 "8CN3" ;CCN RX CO-PAYMENT
"RTN","RCXFMSUR",254,0)
Q:CATEGDA=67 "8CD1" ;CC MTF C (MEANS TEST)
"RTN","RCXFMSUR",255,0)
Q:CATEGDA=68 "8CD3" ;CC MTF RX CO-PAYMENT
"RTN","RCXFMSUR",256,0)
Q:CATEGDA=69 "8CC4" ;CC NURSING HOME CARE - LTC
"RTN","RCXFMSUR",257,0)
Q:CATEGDA=70 "8CC4" ;CC RESPITE CARE
"RTN","RCXFMSUR",258,0)
Q:CATEGDA=71 "8CN4" ;CCN NURSING HOME CARE - LTC
"RTN","RCXFMSUR",259,0)
Q:CATEGDA=72 "8CN4" ;CCN RESPITE CARE
"RTN","RCXFMSUR",260,0)
Q:CATEGDA=73 "8CC8" ;CHOICE NURSING HOME CARE - LTC
"RTN","RCXFMSUR",261,0)
Q:CATEGDA=81 "8CC6" ;CHOICE OPT
"RTN","RCXFMSUR",262,0)
Q:CATEGDA=82 "8CC2" ;CC OPT
"RTN","RCXFMSUR",263,0)
Q:CATEGDA=83 "8CN2" ;CCN OPT
"RTN","RCXFMSUR",264,0)
Q:CATEGDA=84 "8CD2" ;CC MTF OPT
"RTN","RCXFMSUR",265,0)
I (CATEGDA>47),(CATEGDA<52) D Q RCRSC
"RTN","RCXFMSUR",266,0)
. S RCIOPFLG=""
"RTN","RCXFMSUR",267,0)
. S RX3P=0
"RTN","RCXFMSUR",268,0)
. I ("PH"=$$TYP^IBRFN(BILLDA)) D
"RTN","RCXFMSUR",269,0)
. . S RX3P=$$CHECKRXS^RCXFMSUF(BILLDA)
"RTN","RCXFMSUR",270,0)
. D DIQ399(BILLDA)
"RTN","RCXFMSUR",271,0)
. ; for Community Care, 1 (inpatient) or 2 (outpatient -everything else)
"RTN","RCXFMSUR",272,0)
. S RCIOPFLG=$S($G(IBCNDATA(399,BILLDA,.05,"I"))=1:1,1:2)
"RTN","RCXFMSUR",273,0)
. I (CATEGDA=50),RX3P S RCRSC="83CC" Q ;CHOICE INS RX
"RTN","RCXFMSUR",274,0)
. I (CATEGDA=50),(RCIOPFLG=1) S RCRSC="81CC" Q ;CHOICE INS INPATIENT
"RTN","RCXFMSUR",275,0)
. I (CATEGDA=50),(RCIOPFLG=2) S RCRSC="82CC" Q ;CHOICE INS OUTPATIENT
"RTN","RCXFMSUR",276,0)
. I (CATEGDA=51),RX3P S RCRSC="8C3C" Q ;CC INS RX
"RTN","RCXFMSUR",277,0)
. I (CATEGDA=51),(RCIOPFLG=1) S RCRSC="8C1C" Q ;CC INS INPATIENT
"RTN","RCXFMSUR",278,0)
. I (CATEGDA=51),(RCIOPFLG=2) S RCRSC="8C2C" Q ;CC INS OUTPATIENT
"RTN","RCXFMSUR",279,0)
. I (CATEGDA=52),RX3P S RCRSC="8CN7" Q ;CCN INS RX
"RTN","RCXFMSUR",280,0)
. I (CATEGDA=52),(RCIOPFLG=1) S RCRSC="8CN5" Q ;CCN INS INPATIENT
"RTN","RCXFMSUR",281,0)
. I (CATEGDA=52),(RCIOPFLG=2) S RCRSC="8CN6" Q ;CCN INS OUTPATIENT
"RTN","RCXFMSUR",282,0)
. I (CATEGDA=53),RX3P S RCRSC="8CD6" Q ;CHOICE INS RX
"RTN","RCXFMSUR",283,0)
. I (CATEGDA=53),(RCIOPFLG=1) S RCRSC="8CD4" Q ;CHOICE INS INPATIENT
"RTN","RCXFMSUR",284,0)
. I (CATEGDA=53),(RCIOPFLG=2) S RCRSC="8CD5" Q ;CHOICE INS OUTPATIENT
"RTN","RCXFMSUR",285,0)
Q 0
"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**