Summary Table

Categories Total Count
PII 0
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 Jan 15, 2019@09:18:33
VERSION 1
**KIDS**:IB*2.0*618^

**INSTALL NAME**
IB*2.0*618
"BLD",10904,0)
IB*2.0*618^INTEGRATED BILLING^0^3190115^y
"BLD",10904,4,0)
^9.64PA^351.7^2
"BLD",10904,4,350.1,0)
350.1
"BLD",10904,4,350.1,2,0)
^9.641^350.1^1
"BLD",10904,4,350.1,2,350.1,0)
IB ACTION TYPE (File-top level)
"BLD",10904,4,350.1,2,350.1,1,0)
^9.6411^.12^1
"BLD",10904,4,350.1,2,350.1,1,.12,0)
INACTIVE
"BLD",10904,4,350.1,222)
y^y^p^^^^n^^n
"BLD",10904,4,350.1,224)

"BLD",10904,4,351.7,0)
351.7
"BLD",10904,4,351.7,222)
y^y^f^^y^^y^o^n
"BLD",10904,4,351.7,224)
I $P(^IBE(351.7,Y,0),U)["FOLLOW"
"BLD",10904,4,"APDD",350.1,350.1)

"BLD",10904,4,"APDD",350.1,350.1,.12)

"BLD",10904,4,"B",350.1,350.1)

"BLD",10904,4,"B",351.7,351.7)

"BLD",10904,6.3)
60
"BLD",10904,"ABPKG")
n
"BLD",10904,"INIT")
POSTINIT^IB20P618
"BLD",10904,"KRN",0)
^9.67PA^779.2^20
"BLD",10904,"KRN",.4,0)
.4
"BLD",10904,"KRN",.4,"NM",0)
^9.68A^1^1
"BLD",10904,"KRN",.4,"NM",1,0)
IB LIST FILE #350^350^0
"BLD",10904,"KRN",.4,"NM","B","IB LIST FILE #350",1)

"BLD",10904,"KRN",.401,0)
.401
"BLD",10904,"KRN",.402,0)
.402
"BLD",10904,"KRN",.403,0)
.403
"BLD",10904,"KRN",.5,0)
.5
"BLD",10904,"KRN",.84,0)
.84
"BLD",10904,"KRN",3.6,0)
3.6
"BLD",10904,"KRN",3.8,0)
3.8
"BLD",10904,"KRN",9.2,0)
9.2
"BLD",10904,"KRN",9.8,0)
9.8
"BLD",10904,"KRN",9.8,"NM",0)
^9.68A^31^29
"BLD",10904,"KRN",9.8,"NM",1,0)
IBP618B^^0^B119788887
"BLD",10904,"KRN",9.8,"NM",2,0)
IBP618A^^0^B102033920
"BLD",10904,"KRN",9.8,"NM",3,0)
IB20P618^^0^B168640602
"BLD",10904,"KRN",9.8,"NM",4,0)
IBECEA3^^0^B81661482
"BLD",10904,"KRN",9.8,"NM",7,0)
IBECEA33^^0^B23530923
"BLD",10904,"KRN",9.8,"NM",8,0)
IBJDF1^^0^B38760357
"BLD",10904,"KRN",9.8,"NM",9,0)
IBJDF11^^0^B39397116
"BLD",10904,"KRN",9.8,"NM",10,0)
IBJDF12^^0^B26906871
"BLD",10904,"KRN",9.8,"NM",11,0)
IBJDF2^^0^B82293894
"BLD",10904,"KRN",9.8,"NM",12,0)
IBJDF4^^0^B44100210
"BLD",10904,"KRN",9.8,"NM",13,0)
IBJDF41^^0^B109334634
"BLD",10904,"KRN",9.8,"NM",14,0)
IBJDF42^^0^B65167304
"BLD",10904,"KRN",9.8,"NM",15,0)
IBJDF51^^0^B60268800
"BLD",10904,"KRN",9.8,"NM",16,0)
IBJDF53^^0^B26261562
"BLD",10904,"KRN",9.8,"NM",17,0)
IBJDF6^^0^B36325924
"BLD",10904,"KRN",9.8,"NM",18,0)
IBJDF61^^0^B66883609
"BLD",10904,"KRN",9.8,"NM",19,0)
IBOCDRPT^^0^B19445750
"BLD",10904,"KRN",9.8,"NM",20,0)
IBJDF52^^0^B28589932
"BLD",10904,"KRN",9.8,"NM",21,0)
IBJDF62^^0^B35799175
"BLD",10904,"KRN",9.8,"NM",22,0)
IBJDF63^^0^B22433470
"BLD",10904,"KRN",9.8,"NM",23,0)
IBECEAU2^^0^B34191708
"BLD",10904,"KRN",9.8,"NM",24,0)
IBOHLD2^^0^B32477589
"BLD",10904,"KRN",9.8,"NM",25,0)
IBOHLS1^^0^B100301549
"BLD",10904,"KRN",9.8,"NM",26,0)
IBOHLD1^^0^B21577919
"BLD",10904,"KRN",9.8,"NM",27,0)
IBEFURF^^0^B21059318
"BLD",10904,"KRN",9.8,"NM",28,0)
IBOMTC1^^0^B13744112
"BLD",10904,"KRN",9.8,"NM",29,0)
IBOLK^^0^B19580786
"BLD",10904,"KRN",9.8,"NM",30,0)
IBECEAU3^^0^B8064716
"BLD",10904,"KRN",9.8,"NM",31,0)
IBOHDT1^^0^B18269083
"BLD",10904,"KRN",9.8,"NM","B","IB20P618",3)

"BLD",10904,"KRN",9.8,"NM","B","IBECEA3",4)

"BLD",10904,"KRN",9.8,"NM","B","IBECEA33",7)

"BLD",10904,"KRN",9.8,"NM","B","IBECEAU2",23)

"BLD",10904,"KRN",9.8,"NM","B","IBECEAU3",30)

"BLD",10904,"KRN",9.8,"NM","B","IBEFURF",27)

"BLD",10904,"KRN",9.8,"NM","B","IBJDF1",8)

"BLD",10904,"KRN",9.8,"NM","B","IBJDF11",9)

"BLD",10904,"KRN",9.8,"NM","B","IBJDF12",10)

"BLD",10904,"KRN",9.8,"NM","B","IBJDF2",11)

"BLD",10904,"KRN",9.8,"NM","B","IBJDF4",12)

"BLD",10904,"KRN",9.8,"NM","B","IBJDF41",13)

"BLD",10904,"KRN",9.8,"NM","B","IBJDF42",14)

"BLD",10904,"KRN",9.8,"NM","B","IBJDF51",15)

"BLD",10904,"KRN",9.8,"NM","B","IBJDF52",20)

"BLD",10904,"KRN",9.8,"NM","B","IBJDF53",16)

"BLD",10904,"KRN",9.8,"NM","B","IBJDF6",17)

"BLD",10904,"KRN",9.8,"NM","B","IBJDF61",18)

"BLD",10904,"KRN",9.8,"NM","B","IBJDF62",21)

"BLD",10904,"KRN",9.8,"NM","B","IBJDF63",22)

"BLD",10904,"KRN",9.8,"NM","B","IBOCDRPT",19)

"BLD",10904,"KRN",9.8,"NM","B","IBOHDT1",31)

"BLD",10904,"KRN",9.8,"NM","B","IBOHLD1",26)

"BLD",10904,"KRN",9.8,"NM","B","IBOHLD2",24)

"BLD",10904,"KRN",9.8,"NM","B","IBOHLS1",25)

"BLD",10904,"KRN",9.8,"NM","B","IBOLK",29)

"BLD",10904,"KRN",9.8,"NM","B","IBOMTC1",28)

"BLD",10904,"KRN",9.8,"NM","B","IBP618A",2)

"BLD",10904,"KRN",9.8,"NM","B","IBP618B",1)

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

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

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

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

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

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

"BLD",10904,"KRN","B",3.6,3.6)

"BLD",10904,"KRN","B",3.8,3.8)

"BLD",10904,"KRN","B",9.2,9.2)

"BLD",10904,"KRN","B",9.8,9.8)

"BLD",10904,"KRN","B",19,19)

"BLD",10904,"KRN","B",19.1,19.1)

"BLD",10904,"KRN","B",101,101)

"BLD",10904,"KRN","B",409.61,409.61)

"BLD",10904,"KRN","B",771,771)

"BLD",10904,"KRN","B",779.2,779.2)

"BLD",10904,"KRN","B",870,870)

"BLD",10904,"KRN","B",8989.51,8989.51)

"BLD",10904,"KRN","B",8989.52,8989.52)

"BLD",10904,"KRN","B",8994,8994)

"BLD",10904,"QDEF")
^^^^NO^^^^NO^^NO
"BLD",10904,"QUES",0)
^9.62^^
"BLD",10904,"REQB",0)
^9.611^10^8
"BLD",10904,"REQB",1,0)
PRCA*4.5*338^1
"BLD",10904,"REQB",3,0)
IB*2.0*568^1
"BLD",10904,"REQB",4,0)
IB*2.0*449^1
"BLD",10904,"REQB",5,0)
IB*2.0*516^1
"BLD",10904,"REQB",6,0)
IB*2.0*616^1
"BLD",10904,"REQB",8,0)
IB*2.0*604^1
"BLD",10904,"REQB",9,0)
IB*2.0*614^1
"BLD",10904,"REQB",10,0)
IB*2.0*433^1
"BLD",10904,"REQB","B","IB*2.0*433",10)

"BLD",10904,"REQB","B","IB*2.0*449",4)

"BLD",10904,"REQB","B","IB*2.0*516",5)

"BLD",10904,"REQB","B","IB*2.0*568",3)

"BLD",10904,"REQB","B","IB*2.0*604",8)

"BLD",10904,"REQB","B","IB*2.0*614",9)

"BLD",10904,"REQB","B","IB*2.0*616",6)

"BLD",10904,"REQB","B","PRCA*4.5*338",1)

"DATA",351.7,9,0)
THIRD PARTY FOLLOW-UP SUMMARY
"DATA",351.7,9,1,0)
^351.702^3^3
"DATA",351.7,9,1,1,0)
IBSORT^0
"DATA",351.7,9,1,2,0)
IBSEL^10,
"DATA",351.7,9,1,3,0)
IBSDATE
"DATA",351.7,9,1,3,1)
S ZTSAVE("IBSDATE")="D"
"DATA",351.7,9,2)
DQ^IBJDF2
"DATA",351.7,12,0)
FIRST PARTY FOLLOW-UP (Emergency/Humanitarian)
"DATA",351.7,12,1,0)
^351.702^13^13
"DATA",351.7,12,1,1,0)
IBSEL^1,2,3,
"DATA",351.7,12,1,2,0)
IBRPT^S
"DATA",351.7,12,1,3,0)
IBSNF
"DATA",351.7,12,1,4,0)
IBSNA^ALL
"DATA",351.7,12,1,5,0)
IBSNL^zzzzz
"DATA",351.7,12,1,6,0)
IBSTA^A
"DATA",351.7,12,1,7,0)
IBSMN^A
"DATA",351.7,12,1,8,0)
IBSMX^99999
"DATA",351.7,12,1,9,0)
IBSAM^0
"DATA",351.7,12,1,10,0)
IBEXCEL^0
"DATA",351.7,12,1,11,0)
IBSH^0
"DATA",351.7,12,1,12,0)
IBSRC^1
"DATA",351.7,12,1,13,0)
IBSN^N
"DATA",351.7,12,2)
DQ^IBJDF4
"DATA",351.7,13,0)
FIRST PARTY FOLLOW-UP (Ineligible receivables)
"DATA",351.7,14,0)
FIRST PARTY FOLLOW-UP (C - Means Test)
"DATA",351.7,15,0)
FIRST PARTY FOLLOW-UP (RX CO-PAYMENT/SC VET)
"DATA",351.7,16,0)
FIRST PARTY FOLLOW-UP (RX CO-PAYMENT/NSC VET)
"DATA",351.7,17,0)
TRICARE FOLLOW-UP (All receivables)
"DATA",351.7,17,1,0)
^351.702^14^14
"DATA",351.7,17,1,1,0)
IBSEL^1,2,3,4,5,6,
"DATA",351.7,17,1,2,0)
IBSD^0
"DATA",351.7,17,1,3,0)
IBSEL1^4,
"DATA",351.7,17,1,4,0)
IBRPT^S
"DATA",351.7,17,1,5,0)
IBSNF
"DATA",351.7,17,1,6,0)
IBSNL^zzzzz
"DATA",351.7,17,1,7,0)
IBSNA^ALL
"DATA",351.7,17,1,8,0)
IBSMN^A
"DATA",351.7,17,1,9,0)
IBSMX^99999
"DATA",351.7,17,1,10,0)
IBSAM^0
"DATA",351.7,17,1,11,0)
IBSH^0
"DATA",351.7,17,1,12,0)
IBSH1^A
"DATA",351.7,17,1,13,0)
IBSH2^0
"DATA",351.7,17,1,14,0)
IBEXCEL^0
"DATA",351.7,17,2)
DQ^IBJDF5
"DATA",351.7,18,0)
TRICARE Patient FOLLOW-UP (All receivables)
"DATA",351.7,19,0)
TRICARE Reimbursable FOLLOW-UP (All receivables)
"DATA",351.7,20,0)
CHAMPVA FOLLOW-UP (All receivables)
"DATA",351.7,21,0)
CHAMPVA Reimbursable FOLLOW-UP (All receivables)
"DATA",351.7,22,0)
MISCELLANEOUS BILLS FOLLOW-UP (No-fault auto acc.)
"DATA",351.7,22,1,0)
^351.702^16^16
"DATA",351.7,22,1,1,0)
IBSEL^2,3,4,
"DATA",351.7,22,1,2,0)
IBSDV^0
"DATA",351.7,22,1,3,0)
IBRPT^S
"DATA",351.7,22,1,4,0)
IBSNA^ALL
"DATA",351.7,22,1,5,0)
IBSNF
"DATA",351.7,22,1,6,0)
IBSNL^zzzzz
"DATA",351.7,22,1,7,0)
IBSDA^ALL
"DATA",351.7,22,1,8,0)
IBSDF
"DATA",351.7,22,1,9,0)
IBSDL^zzzzz
"DATA",351.7,22,1,10,0)
IBSMN^A
"DATA",351.7,22,1,11,0)
IBSAM^0
"DATA",351.7,22,1,12,0)
IBEXCEL^0
"DATA",351.7,22,1,13,0)
IBSH^0
"DATA",351.7,22,1,14,0)
IBSH1^A
"DATA",351.7,22,1,15,0)
IBSH2^0
"DATA",351.7,22,1,16,0)
IBSMX^99999
"DATA",351.7,22,2)
DQ^IBJDF6
"DATA",351.7,23,0)
MISCELLANEOUS BILLS FOLLOW-UP (Tort Feasor)
"DATA",351.7,24,0)
MISCELLANEOUS BILLS FOLLOW-UP (Workman's Comp)
"FIA",350.1)
IB ACTION TYPE
"FIA",350.1,0)
^IBE(350.1,
"FIA",350.1,0,0)
350.1
"FIA",350.1,0,1)
y^y^p^^^^n^^n
"FIA",350.1,0,10)

"FIA",350.1,0,11)

"FIA",350.1,0,"RLRO")

"FIA",350.1,0,"VR")
2.0^IB
"FIA",350.1,350.1)
1
"FIA",350.1,350.1,.12)

"FIA",351.7)
IB DM EXTRACT REPORTS
"FIA",351.7,0)
^IBE(351.7,
"FIA",351.7,0,0)
351.7
"FIA",351.7,0,1)
y^y^f^^y^^y^o^n
"FIA",351.7,0,10)

"FIA",351.7,0,11)
I $P(^IBE(351.7,Y,0),U)["FOLLOW"
"FIA",351.7,0,"RLRO")

"FIA",351.7,0,"VR")
2.0^IB
"FIA",351.7,351.7)
0
"FIA",351.7,351.702)
0
"INIT")
POSTINIT^IB20P618
"KRN",.4,2267,-1)
0^1
"KRN",.4,2267,0)
IB LIST^2950810.1305^^350^^^3181015^
"KRN",.4,2267,"%D",0)
^.4001^1^1^3181010^^^^
"KRN",.4,2267,"%D",1,0)
Integrated Billing Action List.
"KRN",.4,2267,"DCL","350^.01")
!
"KRN",.4,2267,"DCL","350^.06")
&
"KRN",.4,2267,"DCL","350^.07")
&
"KRN",.4,2267,"DXS",1,9.2)
S DIP(1)=$S($D(^IB(D0,0)):^(0),1:"") S X=+$P(DIP(1),U,3) S:X["" X=$$GETATYPE^IBOMTC1(X)
"KRN",.4,2267,"F",1)
.02;L20~.01;"REF. NO";L10~X DXS(1,9.2) W X K DIP;"TYPE";L20;Z;"$P(#.03," ",1)"~.05;L10~
"KRN",.4,2267,"F",2)
S DIP(1)=$S($D(^IB(D0,1)):^(1),1:"") S X=$P(DIP(1),U,2),X=$P(X,".",1) S Y=X D DT K DIP;L11;"DATE ADDED";Z;"DATE(#12)"~.06;R5~.07;"CHARGE";R8~.08~
"KRN",.4,2267,"F",3)
.11;"CHARGE ID";L12~
"KRN",.4,2267,"H")
INTEGRATED BILLING ACTION LIST
"MBREQ")
0
"ORD",5,.4)
.4;5;;;EDEOUT^DIFROMSO(.4,DA,"",XPDA);FPRE^DIFROMSI(.4,"",XPDA);EPRE^DIFROMSI(.4,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.4,DA,"",XPDA);DEL^DIFROMSK(.4,"",%)
"ORD",5,.4,0)
PRINT TEMPLATE
"PKG",230,-1)
1^1
"PKG",230,0)
INTEGRATED BILLING^IB^INTEGRATED BILLING
"PKG",230,22,0)
^9.49I^1^1
"PKG",230,22,1,0)
2.0^2940321^2940525
"PKG",230,22,1,"PAH",1,0)
618^3190115^520824649
"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")
NO
"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")
29
"RTN","IB20P618")
0^3^B168640602
"RTN","IB20P618",1,0)
IB20P618 ;SAB/Albany - IB*2.0*618 POST INSTALL;12/11/17 2:10pm
"RTN","IB20P618",2,0)
;;2.0;Integrated Billing;**618**;Mar 20, 1995;Build 60
"RTN","IB20P618",3,0)
;Per VA Directive 6402, this routine should not be modified.
"RTN","IB20P618",4,0)
Q
"RTN","IB20P618",5,0)
;
"RTN","IB20P618",6,0)
POSTINIT ;Post Install for IB*2.0*618
"RTN","IB20P618",7,0)
D BMES^XPDUTL(" >> Starting the Post-Initialization routine for IB*2.0*618 ")
"RTN","IB20P618",8,0)
; Adding AR CATEGORIES and REVENUE SOURCE CODES
"RTN","IB20P618",9,0)
D RTADD
"RTN","IB20P618",10,0)
D RTUPD
"RTN","IB20P618",11,0)
D ADDRS
"RTN","IB20P618",12,0)
D IBUPD^IBP618A
"RTN","IB20P618",13,0)
D ADDACT^IBP618A
"RTN","IB20P618",14,0)
D UPDACT^IBP618B
"RTN","IB20P618",15,0)
D ADDACTCH^IBP618B
"RTN","IB20P618",16,0)
D BMES^XPDUTL(" >> End of the Post-Initialization routine for IB*2.0*618")
"RTN","IB20P618",17,0)
Q
"RTN","IB20P618",18,0)
;
"RTN","IB20P618",19,0)
RTADD ;Add New rate types to the Rate type File
"RTN","IB20P618",20,0)
;
"RTN","IB20P618",21,0)
N LOOP,FDA,FDAIEN,DATA,BRF,ARCAT,CHK
"RTN","IB20P618",22,0)
;
"RTN","IB20P618",23,0)
D MES^XPDUTL(" -> Adding new Rate Type entries to file 399.3 ...")
"RTN","IB20P618",24,0)
; Add new Rate Types
"RTN","IB20P618",25,0)
F LOOP=2:1 S DATA=$T(RTDATA+LOOP) Q:$P(DATA,";",3)="END" D
"RTN","IB20P618",26,0)
. ;Clear the array
"RTN","IB20P618",27,0)
. K FDA
"RTN","IB20P618",28,0)
. ;Check to insure that the rate type doesn't exist already
"RTN","IB20P618",29,0)
. S CHK="" ; Initialized the check variable
"RTN","IB20P618",30,0)
. S CHK=$O(^DGCR(399.3,"B",$P(DATA,";",3),""))
"RTN","IB20P618",31,0)
. Q:CHK'=""
"RTN","IB20P618",32,0)
. ;Store in array for adding to the file (#399.3).
"RTN","IB20P618",33,0)
. S FDA(399.3,"+1,",.01)=$P(DATA,";",3) ;Rate Type Name
"RTN","IB20P618",34,0)
. S FDA(399.3,"+1,",.02)=$P(DATA,";",4) ;Bill Name
"RTN","IB20P618",35,0)
. S FDA(399.3,"+1,",.03)=$P(DATA,";",5) ;Inactive Flag
"RTN","IB20P618",36,0)
. S FDA(399.3,"+1,",.04)=$P(DATA,";",6) ;Abbreviation
"RTN","IB20P618",37,0)
. S FDA(399.3,"+1,",.05)=$P(DATA,";",7) ;Third Party?
"RTN","IB20P618",38,0)
. S ARCAT=$P(DATA,";",8) ;AR Cat
"RTN","IB20P618",39,0)
. S:ARCAT'="" ARCAT=$O(^PRCA(430.2,"AC",ARCAT,"")) ;Find local IEN for AR Cat
"RTN","IB20P618",40,0)
. S FDA(399.3,"+1,",.06)=ARCAT ;AR Cat
"RTN","IB20P618",41,0)
. S FDA(399.3,"+1,",.07)=$P(DATA,";",9) ;Responsible?
"RTN","IB20P618",42,0)
. S FDA(399.3,"+1,",.08)=$P(DATA,";",10) ;Reimbursable
"RTN","IB20P618",43,0)
. S FDA(399.3,"+1,",.09)=$P(DATA,";",11) ;NSC Statement
"RTN","IB20P618",44,0)
. S FDA(399.3,"+1,",.1)=$P(DATA,";",12) ;Electronic Transmit
"RTN","IB20P618",45,0)
. S BRF=$P(DATA,";",13) ;Bill Resulting From (BRF) (430.6)
"RTN","IB20P618",46,0)
. S:BRF'="" BRF=$O(^PRCA(430.6,"B",BRF,"")) ;Find local IEN for BRF
"RTN","IB20P618",47,0)
. S FDA(399.3,"+1,",.11)=BRF
"RTN","IB20P618",48,0)
. S FDA(399.3,"+1,",.12)=$P(DATA,";",14) ;Collect?
"RTN","IB20P618",49,0)
. ;Add to the file.
"RTN","IB20P618",50,0)
. D UPDATE^DIE(,"FDA","FDAIEN")
"RTN","IB20P618",51,0)
. S FDAIEN=FDAIEN(1) K FDAIEN(1)
"RTN","IB20P618",52,0)
D MES^XPDUTL(" New Rate Types added.")
"RTN","IB20P618",53,0)
Q
"RTN","IB20P618",54,0)
;
"RTN","IB20P618",55,0)
RTDATA ; New RATE TYPE data. (Internal data format
"RTN","IB20P618",56,0)
;;name;billname;inactive; abbreviation;thirdparty;AR Cat #;resp;reimb;nsc;etransmit;billfrom;collect?
"RTN","IB20P618",57,0)
;;CC WORKERS' COMP;CC WORKERS' COMP;;CC WC;1;59;i;1;1;1;;
"RTN","IB20P618",58,0)
;;CC NO-FAULT AUTO;CC NO-FAULT AUTO;;CC NF;1;60;i;1;1;1;;
"RTN","IB20P618",59,0)
;;CC TORT FEASOR;CC TORT FEASOR;;CC TF;1;61;i;1;1;1;;
"RTN","IB20P618",60,0)
;;CHOICE WORKERS' COMP;CHOICE WORKERS' COMP;;CCC WC;1;62;i;1;1;1;;
"RTN","IB20P618",61,0)
;;CHOICE NO-FAULT AUTO;CHOICE NO-FAULT AUTO;;CCC NF;1;54;i;1;1;1;;
"RTN","IB20P618",62,0)
;;CHOICE TORT FEASOR;CHOICE TORT FEASOR;;CCC TF;1;55;i;1;1;1;;
"RTN","IB20P618",63,0)
;;CCN WORKERS' COMP;CCN WORKERS' COMP;;CCN WC;1;56;i;1;1;1;;
"RTN","IB20P618",64,0)
;;CCN NO-FAULT AUTO;CCN NO-FAULT AUTO;;CCN NF;1;57;i;1;1;1;;
"RTN","IB20P618",65,0)
;;CCN TORT FEASOR;CCN TORT FEASOR;;CCN TF;1;58;i;1;1;1;;
"RTN","IB20P618",66,0)
;;CHOICE REIMB INS;CHOICE REIMB INS;;CCC REIM;1;50;i;1;1;1;HI;1
"RTN","IB20P618",67,0)
;;CC REIMB INS;CC REIMB INS;;CC REIM;1;51;i;1;1;1;HI;1
"RTN","IB20P618",68,0)
;;CCN REIMB INS;CCN REIMB INS;;CCN REIM;1;52;i;1;1;1;HI;1
"RTN","IB20P618",69,0)
;;CC MTF REIMB INS;CC MTF REIMB INS;;CCD REIM;1;53;i;1;1;1;HI;1
"RTN","IB20P618",70,0)
;;DOD DISABILITY EVALUATION;DOD DISABILITY EVALUATION;;TR IDES;1;77;i;1;1;1;HI;1
"RTN","IB20P618",71,0)
;;DOD SPINAL CORD INJURY;DOD SPINAL CORD INJURY;;TRSPINAL;1;78;i;1;1;1;HI;1
"RTN","IB20P618",72,0)
;;DOD TRAUMATIC BRAIN INJURY;DOD TRAUMATIC BRAIN INJURY;;TR TBI;1;79;i;1;1;1;HI;1
"RTN","IB20P618",73,0)
;;DOD BLIND REHABILITATION;DOD BLIND REHABILITATION;;TRREHAB;1;80;i;1;1;1;HI;1
"RTN","IB20P618",74,0)
;;TRICARE DENTAL;TRICARE DENTAL;;TR DENTAL;1;81;i;1;1;1;HI;1
"RTN","IB20P618",75,0)
;;TRICARE PHARMACY;TRICARE PHARMACY;;TR RX;1;82;i;1;1;1;HI;1
"RTN","IB20P618",76,0)
;;END
"RTN","IB20P618",77,0)
;
"RTN","IB20P618",78,0)
RTUPD ; Update the FEE REIMB INS entry in the Rate Type File (399.3) to inactivate
"RTN","IB20P618",79,0)
N LIEN,X,Y,DIE,DA,DR,DTOUT,DATA
"RTN","IB20P618",80,0)
;
"RTN","IB20P618",81,0)
D MES^XPDUTL(" -> Inactivating the FEE REIMB INS Rate Type...")
"RTN","IB20P618",82,0)
S LIEN=$O(^DGCR(399.3,"B","FEE REIMB INS",""))
"RTN","IB20P618",83,0)
Q:'LIEN
"RTN","IB20P618",84,0)
; File the update
"RTN","IB20P618",85,0)
S DR=".03////1;"
"RTN","IB20P618",86,0)
S DIE="^DGCR(399.3,",DA=LIEN
"RTN","IB20P618",87,0)
D ^DIE
"RTN","IB20P618",88,0)
;
"RTN","IB20P618",89,0)
Q
"RTN","IB20P618",90,0)
ADDRS ; Add Rate Schedules (363) for FEE REIMB INS
"RTN","IB20P618",91,0)
D MES^XPDUTL(" -> Adding new Rate Schedules to file 363 ...")
"RTN","IB20P618",92,0)
N IBA,IBCNT,IBI,IBLN,IBFN,IBRT,IBBS,IBCNTCS,IBDISP,IBJ,IBLNCS,IBCS,IBCSFN,IBADMIN,DD,DO
"RTN","IB20P618",93,0)
N DLAYGO,DIC,DIE,DA,DR,RXDT,X,Y,IBCPNM,IBEDT
"RTN","IB20P618",94,0)
S IBCNT=0
"RTN","IB20P618",95,0)
F IBI=2:1 S IBLN=$P($T(RSF+IBI),";;",2) Q:IBLN="END" I $E(IBLN)?1A D
"RTN","IB20P618",96,0)
. ;Check for problems
"RTN","IB20P618",97,0)
. S IBBS=$P(IBLN,U,4) I IBBS'="" S IBBS=$$MCCRUTL(IBBS,13) Q:'IBBS ;Billable service invalid
"RTN","IB20P618",98,0)
. S IBRT=$P(IBLN,U,2),IBRT=$O(^DGCR(399.3,"B",IBRT,0)) D Q:'IBRT
"RTN","IB20P618",99,0)
.. I 'IBRT D MSG(" **** Rate Type "_$P(IBLN,U,2)_" not defined, RS "_$P(IBLN,U,1)_" not created")
"RTN","IB20P618",100,0)
.. I +$P($G(^DGCR(399.3,+IBRT,0)),U,3) S IBRT=0 D MSG(" **** Rate Type "_$P(IBLN,U,2)_" not Active, RS "_$P(IBLN,U,1)_" not created")
"RTN","IB20P618",101,0)
. ;No problems found, so create entry
"RTN","IB20P618",102,0)
. K DD,DO
"RTN","IB20P618",103,0)
. S DLAYGO=363,DIC="^IBE(363,",DIC(0)="L",X=$P(IBLN,U,1)
"RTN","IB20P618",104,0)
. D FILE^DICN K DIC,DINUM,DLAYGO
"RTN","IB20P618",105,0)
. I Y<1 K X,Y Q
"RTN","IB20P618",106,0)
. S IBFN=+Y,IBCNT=IBCNT+1
"RTN","IB20P618",107,0)
. S IBCPNM=$P(IBLN,U,5),IBEDT=$P(IBLN,U,6)
"RTN","IB20P618",108,0)
. S RXDT=$$RXDT(IBCPNM,IBEDT)
"RTN","IB20P618",109,0)
. S DR=".02////"_IBRT_";.03////"_$P(IBLN,U,3) I +IBBS S DR=DR_";.04////"_IBBS
"RTN","IB20P618",110,0)
. S DR=DR_";.05////"_$P(RXDT,U)
"RTN","IB20P618",111,0)
. I $P(RXDT,U,2) S DR=DR_";.06////"_$P(RXDT,U,2)
"RTN","IB20P618",112,0)
. I ($P(IBLN,U,1)["RX"),($G(IBDISP)]"") S DR=DR_";1.01///"_IBDISP
"RTN","IB20P618",113,0)
. I ($P(IBLN,U,1)["RX"),($G(IBADMIN)]"") S DR=DR_";1.02////"_IBADMIN
"RTN","IB20P618",114,0)
. S DIE="^IBE(363,",DA=+Y D ^DIE K DIE,DA,DR,X,Y
"RTN","IB20P618",115,0)
. S IBCNTCS=0
"RTN","IB20P618",116,0)
. ; Retrieve name of Charge Set to copy
"RTN","IB20P618",117,0)
. I IBRT="" D MSG(" **** Rate Type "_$P(IBLN,U,2)_" missing Charge Set Information, RS "_$P(IBLN,U,1)_" not created") Q
"RTN","IB20P618",118,0)
. ; add all Reasonable Charges Charge Sets to the Rate Schedule.
"RTN","IB20P618",119,0)
. S IBCNTCS=$$RSCS(IBFN,IBCPNM,$P(RXDT,U))
"RTN","IB20P618",120,0)
. D MES^XPDUTL(" Total Reasonable Charge Set"_$S(IBCNTCS=1:" ",1:"s ")_IBCNTCS_" added to Rate Schedule "_$P(IBLN,U,1)_".")
"RTN","IB20P618",121,0)
D MES^XPDUTL(" Rate Schedules completed.")
"RTN","IB20P618",122,0)
Q ;ADDRS
"RTN","IB20P618",123,0)
;
"RTN","IB20P618",124,0)
RSCS(IBFN,IBCPNM,RXDT) ; add existing Charge Sets to FR
"RTN","IB20P618",125,0)
; copy the Charge Sets from the corresponding RI RS (v2)
"RTN","IB20P618",126,0)
; IBFN - Rate Schedule IEN
"RTN","IB20P618",127,0)
; IBCPNM - Charge Set to copy
"RTN","IB20P618",128,0)
; RXDT - last effective date of charge set being copied.
"RTN","IB20P618",129,0)
N IBCNT,IBNRS,IBRSNM,IBTY,IBVDT,IBCOPY,IBCS,IBCS0,IBXFN,IBCSFN,IBCSNM,IBCSAA,IBNAME
"RTN","IB20P618",130,0)
S (IBCNT,IBCOPY)=0
"RTN","IB20P618",131,0)
S IBNRS=$G(^IBE(363,+$G(IBFN),0)),IBRSNM=$P(IBNRS,"^",1)
"RTN","IB20P618",132,0)
S IBTY=$P(IBNRS,"^",3)
"RTN","IB20P618",133,0)
S IBVDT=RXDT
"RTN","IB20P618",134,0)
Q:IBVDT="" 0
"RTN","IB20P618",135,0)
S IBCOPY=+$$RSEXISTS(IBVDT,IBCPNM)
"RTN","IB20P618",136,0)
I 'IBCOPY G RSCSQ
"RTN","IB20P618",137,0)
I +$P($G(^IBE(363,+IBCOPY,0)),U,3)=IBTY D
"RTN","IB20P618",138,0)
. S IBXFN=0 F S IBXFN=$O(^IBE(363,IBCOPY,11,IBXFN)) Q:'IBXFN D
"RTN","IB20P618",139,0)
.. S IBCS=$G(^IBE(363,IBCOPY,11,IBXFN,0)),IBCSFN=+IBCS
"RTN","IB20P618",140,0)
.. I +$$RSCSFILE(IBFN,$P($G(^IBE(363.1,IBCSFN,0)),U,1),$P(IBCS,U,2)) S IBCNT=IBCNT+1
"RTN","IB20P618",141,0)
RSCSQ Q IBCNT
"RTN","IB20P618",142,0)
;
"RTN","IB20P618",143,0)
;
"RTN","IB20P618",144,0)
RSCSFILE(IBFN,IBCSNM,IBCSAA) ; Add Charge Set to a Rate Schedule
"RTN","IB20P618",145,0)
N IBX,DD,DO,DLAYGO,DIC,DA,DR,X,Y,IBCSFN S IBX=0
"RTN","IB20P618",146,0)
I $G(^IBE(363,+$G(IBFN),0))="" G RSCSFQ
"RTN","IB20P618",147,0)
I $G(IBCSNM)="" G RSCSFQ
"RTN","IB20P618",148,0)
S IBCSFN=$O(^IBE(363.1,"B",IBCSNM,0)) I 'IBCSFN G RSCSFQ
"RTN","IB20P618",149,0)
I $O(^IBE(363,IBFN,11,"B",IBCSFN,0)) G RSCSFQ
"RTN","IB20P618",150,0)
S DLAYGO=363,DA(1)=+IBFN,DIC="^IBE(363,"_DA(1)_",11,",DIC(0)="L"
"RTN","IB20P618",151,0)
S X=IBCSNM,DIC("DR")=".02///"_$G(IBCSAA),DIC("P")="363.0011P"
"RTN","IB20P618",152,0)
D ^DIC S:+Y IBX=1
"RTN","IB20P618",153,0)
RSCSFQ Q IBX
"RTN","IB20P618",154,0)
;
"RTN","IB20P618",155,0)
;
"RTN","IB20P618",156,0)
RSEXISTS(IBVDT,IBNAME) ; return RS IFN if Rate Schedule exists for Effective Date
"RTN","IB20P618",157,0)
N IBX,IBRSFN,IBRS0 S IBX=0
"RTN","IB20P618",158,0)
S IBRSFN=0 F S IBRSFN=$O(^IBE(363,IBRSFN)) Q:'IBRSFN D I IBX Q
"RTN","IB20P618",159,0)
. S IBRS0=$G(^IBE(363,IBRSFN,0))
"RTN","IB20P618",160,0)
. I $P(IBRS0,U,1)=IBNAME,$P(IBRS0,U,5)=IBVDT S IBX=IBRSFN
"RTN","IB20P618",161,0)
Q IBX
"RTN","IB20P618",162,0)
;
"RTN","IB20P618",163,0)
MSG(X) ;
"RTN","IB20P618",164,0)
N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
"RTN","IB20P618",165,0)
S IBA(IBX)=$G(X)
"RTN","IB20P618",166,0)
Q ;MSG
"RTN","IB20P618",167,0)
;
"RTN","IB20P618",168,0)
MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
"RTN","IB20P618",169,0)
N IBX,IBY S IBY=""
"RTN","IB20P618",170,0)
I $G(X)'="" S IBX=0 F S IBX=$O(^DGCR(399.1,"B",X,IBX)) Q:'IBX I $P($G(^DGCR(399.1,IBX,0)),U,+$G(P)) S IBY=IBX
"RTN","IB20P618",171,0)
Q IBY
"RTN","IB20P618",172,0)
;
"RTN","IB20P618",173,0)
RXDT(IBCPNM,IBEDT) ;Copy the active charge schedule from charge set being copied.
"RTN","IB20P618",174,0)
; update Fee information if Pharmacy.
"RTN","IB20P618",175,0)
N IBEFLG,IBD
"RTN","IB20P618",176,0)
S IBEDT=$G(IBEDT) ; Set to NULL if not passed in
"RTN","IB20P618",177,0)
S IBCS=""
"RTN","IB20P618",178,0)
;If no Effective Date sent, get the latest entry.
"RTN","IB20P618",179,0)
I IBEDT="" S IBCS=$O(^IBE(363,"B",IBCPNM,IBCS),-1)
"RTN","IB20P618",180,0)
;If Effective date sent, loop through the entries to find the entry
"RTN","IB20P618",181,0)
; with the correct effective date.
"RTN","IB20P618",182,0)
I IBEDT'="" D
"RTN","IB20P618",183,0)
. S IBEFLG=0
"RTN","IB20P618",184,0)
. F S IBCS=$O(^IBE(363,"B",IBCPNM,IBCS),-1) Q:'IBCS D Q:IBEFLG
"RTN","IB20P618",185,0)
.. S IBD=$G(^IBE(363,IBCS,0))
"RTN","IB20P618",186,0)
.. I $P(IBD,U,5)=IBEDT S IBEFLG=1
"RTN","IB20P618",187,0)
Q:IBCS="" ""
"RTN","IB20P618",188,0)
S IBCS0=^IBE(363,IBCS,0)
"RTN","IB20P618",189,0)
I IBCPNM["RX" S IBDISP=$P($G(^IBE(363,IBCS,1)),U,1),IBADMIN=$G(^IBE(363,IBCS,10))
"RTN","IB20P618",190,0)
Q $P(IBCS0,U,5,6) ;return effective and end dates
"RTN","IB20P618",191,0)
;
"RTN","IB20P618",192,0)
RSF ;Rate Schedules (363) for the new Community Care Rate Types.
"RTN","IB20P618",193,0)
;;Rate Schedule Name^Rate Type^Bill Type^Billable Service^Rate Schedule to copy for Charge Sets
"RTN","IB20P618",194,0)
;;CCC-NF-INPT^CHOICE NO-FAULT AUTO^1^^NF-INPT
"RTN","IB20P618",195,0)
;;CCC-NF-SNF^CHOICE NO-FAULT AUTO^1^SKILLED NURSING^NF-SNF
"RTN","IB20P618",196,0)
;;CCC-NF-OPT^CHOICE NO-FAULT AUTO^3^^NF-OPT
"RTN","IB20P618",197,0)
;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^NF-RX^3140101
"RTN","IB20P618",198,0)
;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^NF-RX^3150101
"RTN","IB20P618",199,0)
;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^NF-RX^3160101
"RTN","IB20P618",200,0)
;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^NF-RX^3170101
"RTN","IB20P618",201,0)
;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^NF-RX^3180101
"RTN","IB20P618",202,0)
;;CC-NF-INPT^CC NO-FAULT AUTO^1^^NF-INPT
"RTN","IB20P618",203,0)
;;CC-NF-SNF^CC NO-FAULT AUTO^1^SKILLED NURSING^NF-SNF
"RTN","IB20P618",204,0)
;;CC-NF-OPT^CC NO-FAULT AUTO^3^^NF-OPT
"RTN","IB20P618",205,0)
;;CC-NF-RX^CC NO-FAULT AUTO^3^^NF-RX^3140101
"RTN","IB20P618",206,0)
;;CC-NF-RX^CC NO-FAULT AUTO^3^^NF-RX^3150101
"RTN","IB20P618",207,0)
;;CC-NF-RX^CC NO-FAULT AUTO^3^^NF-RX^3160101
"RTN","IB20P618",208,0)
;;CC-NF-RX^CC NO-FAULT AUTO^3^^NF-RX^3170101
"RTN","IB20P618",209,0)
;;CC-NF-RX^CC NO-FAULT AUTO^3^^NF-RX^3180101
"RTN","IB20P618",210,0)
;;CCN-NF-INPT^CCN NO-FAULT AUTO^1^^NF-INPT
"RTN","IB20P618",211,0)
;;CCN-NF-SNF^CCN NO-FAULT AUTO^1^SKILLED NURSING^NF-SNF
"RTN","IB20P618",212,0)
;;CCN-NF-OPT^CCN NO-FAULT AUTO^3^^NF-OPT
"RTN","IB20P618",213,0)
;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^NF-RX^3140101
"RTN","IB20P618",214,0)
;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^NF-RX^3150101
"RTN","IB20P618",215,0)
;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^NF-RX^3160101
"RTN","IB20P618",216,0)
;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^NF-RX^3170101
"RTN","IB20P618",217,0)
;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^NF-RX^3180101
"RTN","IB20P618",218,0)
;;CCC-RI-INPT^CHOICE REIMB INS^1^^RI-INPT
"RTN","IB20P618",219,0)
;;CCC-RI-SNF^CHOICE REIMB INS^1^SKILLED NURSING^RI-SNF
"RTN","IB20P618",220,0)
;;CCC-RI-OPT^CHOICE REIMB INS^3^^RI-OPT
"RTN","IB20P618",221,0)
;;CCC-RI-RX^CHOICE REIMB INS^3^^RI-RX^3140101
"RTN","IB20P618",222,0)
;;CCC-RI-RX^CHOICE REIMB INS^3^^RI-RX^3150101
"RTN","IB20P618",223,0)
;;CCC-RI-RX^CHOICE REIMB INS^3^^RI-RX^3160101
"RTN","IB20P618",224,0)
;;CCC-RI-RX^CHOICE REIMB INS^3^^RI-RX^3170101
"RTN","IB20P618",225,0)
;;CCC-RI-RX^CHOICE REIMB INS^3^^RI-RX^3180101
"RTN","IB20P618",226,0)
;;CC-RI-INPT^CC REIMB INS^1^^RI-INPT
"RTN","IB20P618",227,0)
;;CC-RI-SNF^CC REIMB INS^1^SKILLED NURSING^RI-SNF
"RTN","IB20P618",228,0)
;;CC-RI-OPT^CC REIMB INS^3^^RI-OPT
"RTN","IB20P618",229,0)
;;CC-RI-RX^CC REIMB INS^3^^RI-RX^3140101
"RTN","IB20P618",230,0)
;;CC-RI-RX^CC REIMB INS^3^^RI-RX^3150101
"RTN","IB20P618",231,0)
;;CC-RI-RX^CC REIMB INS^3^^RI-RX^3160101
"RTN","IB20P618",232,0)
;;CC-RI-RX^CC REIMB INS^3^^RI-RX^3170101
"RTN","IB20P618",233,0)
;;CC-RI-RX^CC REIMB INS^3^^RI-RX^3180101
"RTN","IB20P618",234,0)
;;CCN-RI-INPT^CCN REIMB INS^1^^RI-INPT
"RTN","IB20P618",235,0)
;;CCN-RI-SNF^CCN REIMB INS^1^SKILLED NURSING^RI-SNF
"RTN","IB20P618",236,0)
;;CCN-RI-OPT^CCN REIMB INS^3^^RI-OPT
"RTN","IB20P618",237,0)
;;CCN-RI-RX^CCN REIMB INS^3^^RI-RX^3140101
"RTN","IB20P618",238,0)
;;CCN-RI-RX^CCN REIMB INS^3^^RI-RX^3150101
"RTN","IB20P618",239,0)
;;CCN-RI-RX^CCN REIMB INS^3^^RI-RX^3160101
"RTN","IB20P618",240,0)
;;CCN-RI-RX^CCN REIMB INS^3^^RI-RX^3170101
"RTN","IB20P618",241,0)
;;CCN-RI-RX^CCN REIMB INS^3^^RI-RX^3180101
"RTN","IB20P618",242,0)
;;CC-DOD-INPT^CC MTF REIMB INS^1^INPATIENT^RI-INPT
"RTN","IB20P618",243,0)
;;CC-DOD-SNF^CC MTF REIMB INS^1^SKILLED NURSING^RI-SNF
"RTN","IB20P618",244,0)
;;CC-DOD-OPT^CC MTF REIMB INS^3^OUTPATIENT VISIT^RI-OPT
"RTN","IB20P618",245,0)
;;CC-DOD-RX^CC MTF REIMB INS^3^^RI-RX^3140101
"RTN","IB20P618",246,0)
;;CC-DOD-RX^CC MTF REIMB INS^3^^RI-RX^3150101
"RTN","IB20P618",247,0)
;;CC-DOD-RX^CC MTF REIMB INS^3^^RI-RX^3160101
"RTN","IB20P618",248,0)
;;CC-DOD-RX^CC MTF REIMB INS^3^^RI-RX^3170101
"RTN","IB20P618",249,0)
;;CC-DOD-RX^CC MTF REIMB INS^3^^RI-RX^3180101
"RTN","IB20P618",250,0)
;;CCC-TF-INPT^CHOICE TORT FEASOR^1^^TF-INPT
"RTN","IB20P618",251,0)
;;CCC-TF-SNF^CHOICE TORT FEASOR^1^SKILLED NURSING^TF-SNF
"RTN","IB20P618",252,0)
;;CCC-TF-OPT^CHOICE TORT FEASOR^3^^TF-OPT
"RTN","IB20P618",253,0)
;;CCC-TF-RX^CHOICE TORT FEASOR^3^^TF-RX^3140101
"RTN","IB20P618",254,0)
;;CCC-TF-RX^CHOICE TORT FEASOR^3^^TF-RX^3150101
"RTN","IB20P618",255,0)
;;CCC-TF-RX^CHOICE TORT FEASOR^3^^TF-RX^3160101
"RTN","IB20P618",256,0)
;;CCC-TF-RX^CHOICE TORT FEASOR^3^^TF-RX^3170101
"RTN","IB20P618",257,0)
;;CCC-TF-RX^CHOICE TORT FEASOR^3^^TF-RX^3180101
"RTN","IB20P618",258,0)
;;CC-TF-INPT^CC TORT FEASOR^1^^TF-INPT
"RTN","IB20P618",259,0)
;;CC-TF-SNF^CC TORT FEASOR^1^SKILLED NURSING^TF-SNF
"RTN","IB20P618",260,0)
;;CC-TF-OPT^CC TORT FEASOR^3^^TF-OPT
"RTN","IB20P618",261,0)
;;CC-TF-RX^CC TORT FEASOR^3^^TF-RX^3140101
"RTN","IB20P618",262,0)
;;CC-TF-RX^CC TORT FEASOR^3^^TF-RX^3150101
"RTN","IB20P618",263,0)
;;CC-TF-RX^CC TORT FEASOR^3^^TF-RX^3160101
"RTN","IB20P618",264,0)
;;CC-TF-RX^CC TORT FEASOR^3^^TF-RX^3170101
"RTN","IB20P618",265,0)
;;CC-TF-RX^CC TORT FEASOR^3^^TF-RX^3180101
"RTN","IB20P618",266,0)
;;CCN-TF-INPT^CCN TORT FEASOR^1^^TF-INPT
"RTN","IB20P618",267,0)
;;CCN-TF-SNF^CCN TORT FEASOR^1^SKILLED NURSING^TF-SNF
"RTN","IB20P618",268,0)
;;CCN-TF-OPT^CCN TORT FEASOR^3^^TF-OPT
"RTN","IB20P618",269,0)
;;CCN-TF-RX^CCN TORT FEASOR^3^^TF-RX^3140101
"RTN","IB20P618",270,0)
;;CCN-TF-RX^CCN TORT FEASOR^3^^TF-RX^3150101
"RTN","IB20P618",271,0)
;;CCN-TF-RX^CCN TORT FEASOR^3^^TF-RX^3160101
"RTN","IB20P618",272,0)
;;CCN-TF-RX^CCN TORT FEASOR^3^^TF-RX^3170101
"RTN","IB20P618",273,0)
;;CCN-TF-RX^CCN TORT FEASOR^3^^TF-RX^3180101
"RTN","IB20P618",274,0)
;;CCC-WC-INPT^CHOICE WORKERS' COMP^1^^WC-INPT
"RTN","IB20P618",275,0)
;;CCC-WC-SNF^CHOICE WORKERS' COMP^1^SKILLED NURSING^WC-SNF
"RTN","IB20P618",276,0)
;;CCC-WC-OPT^CHOICE WORKERS' COMP^3^^WC-OPT
"RTN","IB20P618",277,0)
;;CCC-WC-RX^CHOICE WORKERS' COMP^3^^WC-RX^3140101
"RTN","IB20P618",278,0)
;;CCC-WC-RX^CHOICE WORKERS' COMP^3^^WC-RX^3150101
"RTN","IB20P618",279,0)
;;CCC-WC-RX^CHOICE WORKERS' COMP^3^^WC-RX^3160101
"RTN","IB20P618",280,0)
;;CCC-WC-RX^CHOICE WORKERS' COMP^3^^WC-RX^3170101
"RTN","IB20P618",281,0)
;;CCC-WC-RX^CHOICE WORKERS' COMP^3^^WC-RX^3180101
"RTN","IB20P618",282,0)
;;CC-WC-INPT^CC WORKERS' COMP^1^^WC-INPT
"RTN","IB20P618",283,0)
;;CC-WC-SNF^CC WORKERS' COMP^1^SKILLED NURSING^WC-SNF
"RTN","IB20P618",284,0)
;;CC-WC-OPT^CC WORKERS' COMP^3^^WC-OPT
"RTN","IB20P618",285,0)
;;CC-WC-RX^CC WORKERS' COMP^3^^WC-RX^3140101
"RTN","IB20P618",286,0)
;;CC-WC-RX^CC WORKERS' COMP^3^^WC-RX^3150101
"RTN","IB20P618",287,0)
;;CC-WC-RX^CC WORKERS' COMP^3^^WC-RX^3160101
"RTN","IB20P618",288,0)
;;CC-WC-RX^CC WORKERS' COMP^3^^WC-RX^3170101
"RTN","IB20P618",289,0)
;;CC-WC-RX^CC WORKERS' COMP^3^^WC-RX^3180101
"RTN","IB20P618",290,0)
;;CCN-WC-INPT^CCN WORKERS' COMP^1^^WC-INPT
"RTN","IB20P618",291,0)
;;CCN-WC-SNF^CCN WORKERS' COMP^1^SKILLED NURSING^WC-SNF
"RTN","IB20P618",292,0)
;;CCN-WC-OPT^CCN WORKERS' COMP^3^^WC-OPT
"RTN","IB20P618",293,0)
;;CCN-WC-RX^CCN WORKERS' COMP^3^^WC-RX^3140101
"RTN","IB20P618",294,0)
;;CCN-WC-RX^CCN WORKERS' COMP^3^^WC-RX^3150101
"RTN","IB20P618",295,0)
;;CCN-WC-RX^CCN WORKERS' COMP^3^^WC-RX^3160101
"RTN","IB20P618",296,0)
;;CCN-WC-RX^CCN WORKERS' COMP^3^^WC-RX^3170101
"RTN","IB20P618",297,0)
;;CCN-WC-RX^CCN WORKERS' COMP^3^^WC-RX^3180101
"RTN","IB20P618",298,0)
;;DOD-DIS EXAM-OPT^DOD DISABILITY EVALUATION^3^OUTPATIENT VISIT^RI-OPT
"RTN","IB20P618",299,0)
;;DOD-SCI-INPT^DOD SPINAL CORD INJURY^1^INPATIENT^RI-INPT
"RTN","IB20P618",300,0)
;;DOD-SCI-OPT^DOD SPINAL CORD INJURY^3^OUTPATIENT VISIT^RI-OPT
"RTN","IB20P618",301,0)
;;DOD-SCI-SNF^DOD SPINAL CORD INJURY^1^SKILLED NURSING^RI-SNF
"RTN","IB20P618",302,0)
;;DOD-TBI-INPT^DOD TRAUMATIC BRAIN INJURY^1^INPATIENT^RI-INPT
"RTN","IB20P618",303,0)
;;DOD-TBI-OPT^DOD TRAUMATIC BRAIN INJURY^3^OUTPATIENT VISIT^RI-OPT
"RTN","IB20P618",304,0)
;;DOD-TBI-SNF^DOD TRAUMATIC BRAIN INJURY^1^SKILLED NURSING^RI-SNF
"RTN","IB20P618",305,0)
;;DOD-BR-INPT^DOD BLIND REHABILITATION^1^INPATIENT^RI-INPT
"RTN","IB20P618",306,0)
;;DOD-BR-OPT^DOD BLIND REHABILITATION^3^OUTPATIENT VISIT^RI-OPT
"RTN","IB20P618",307,0)
;;DOD-BR-SNF^DOD BLIND REHABILITATION^1^SKILLED NURSING^RI-SNF
"RTN","IB20P618",308,0)
;;TR-DENTAL^TRICARE DENTAL^3^OUTPATIENT VISIT^RI-OPT
"RTN","IB20P618",309,0)
;;TR-PHARM^TRICARE PHARMACY^3^^RI-RX^3140101
"RTN","IB20P618",310,0)
;;TR-PHARM^TRICARE PHARMACY^3^^RI-RX^3150101
"RTN","IB20P618",311,0)
;;TR-PHARM^TRICARE PHARMACY^3^^RI-RX^3160101
"RTN","IB20P618",312,0)
;;TR-PHARM^TRICARE PHARMACY^3^^RI-RX^3170101
"RTN","IB20P618",313,0)
;;TR-PHARM^TRICARE PHARMACY^3^^RI-RX^3180101
"RTN","IB20P618",314,0)
;;END
"RTN","IB20P618",315,0)
;
"RTN","IBECEA3")
0^4^B81661482
"RTN","IBECEA3",1,0)
IBECEA3 ;ALB/CPM - Cancel/Edit/Add... Add a Charge ;30-MAR-93
"RTN","IBECEA3",2,0)
;;2.0;INTEGRATED BILLING;**7,57,52,132,150,153,166,156,167,176,198,188,183,202,240,312,402,454,563,614,618**;21-MAR-94;Build 60
"RTN","IBECEA3",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","IBECEA3",4,0)
;
"RTN","IBECEA3",5,0)
ADD ; Add a Charge protocol
"RTN","IBECEA3",6,0)
N IBGMT,IBGMTR,IBUSNM ;IN*2.0*618 Add IBUSNM
"RTN","IBECEA3",7,0)
S (IBGMT,IBGMTR)=0
"RTN","IBECEA3",8,0)
S IBCOMMIT=0,IBEXSTAT=$$RXST^IBARXEU(DFN,DT),IBCATC=$$BILST^DGMTUB(DFN),IBCVAEL=$$CVA^IBAUTL5(DFN),IBLTCST=$$LTCST^IBAECU(DFN,DT,1)
"RTN","IBECEA3",9,0)
;I 'IBCVAEL,'IBCATC,'$G(IBRX),+IBEXSTAT<1 W !!,"This patient has never been Means Test billable." S VALMBCK="" D PAUSE^VALM1 G ADDQ1
"RTN","IBECEA3",10,0)
;
"RTN","IBECEA3",11,0)
; - clear screen and begin
"RTN","IBECEA3",12,0)
D CLOCK^IBAUTL3 I 'IBCLDA S (IBMED,IBCLDAY,IBCLDOL,IBCLDT)=0
"RTN","IBECEA3",13,0)
D HDR^IBECEAU("A D D")
"RTN","IBECEA3",14,0)
I IBY<0 D NODED^IBECEAU3 G ADDQ
"RTN","IBECEA3",15,0)
;
"RTN","IBECEA3",16,0)
; - ask for the charge type
"RTN","IBECEA3",17,0)
D CHTYP^IBECEA33 G:IBY<0 ADDQ
"RTN","IBECEA3",18,0)
;
"RTN","IBECEA3",19,0)
;***IB*2.0*618 change to add more Action Types to this list...
"RTN","IBECEA3",20,0)
; Allow user to add an extra "co-payment" charge if the Action Type
"RTN","IBECEA3",21,0)
; selected is an Outpatient FEE BASIS, CHOICE, CC or CCN charge type
"RTN","IBECEA3",22,0)
N IBAFEE
"RTN","IBECEA3",23,0)
S IBUSNM=$P($G(^IBE(350.1,+$G(IBATYP),0)),"^",8)
"RTN","IBECEA3",24,0)
I IBUSNM'="" D
"RTN","IBECEA3",25,0)
. I IBUSNM="FEE SERVICE/OUTPATIENT" S IBAFEE=IBATYP Q
"RTN","IBECEA3",26,0)
. I (IBUSNM["CC")!(IBUSNM["CHOICE") D
"RTN","IBECEA3",27,0)
. . I (IBUSNM["OPT")!(IBUSNM["OUTPATIENT") S IBAFEE=IBATYP
"RTN","IBECEA3",28,0)
;*** END IB*2.0*618 ***
"RTN","IBECEA3",29,0)
;
"RTN","IBECEA3",30,0)
; - process CHAMPVA charges
"RTN","IBECEA3",31,0)
I IBXA=6 D CHMPVA^IBECEA32 G ADDQ
"RTN","IBECEA3",32,0)
;
"RTN","IBECEA3",33,0)
; - process TRICARE charges
"RTN","IBECEA3",34,0)
I IBXA=7 D CUS^IBECEA35 G ADDQ
"RTN","IBECEA3",35,0)
;
"RTN","IBECEA3",36,0)
; - display MT billing clock data
"RTN","IBECEA3",37,0)
I IBXA=2,$P($G(^IBE(350.1,+IBATYP,0)),"^",8)'["NHCU",IBCLDAY>90 S IBMED=IBMED/2
"RTN","IBECEA3",38,0)
I IBXA=1,IBCLDAY>90 D MED^IBECEA34 G:IBY<0 ADDQ
"RTN","IBECEA3",39,0)
I "^1^2^3^"[("^"_IBXA_"^"),IBCLDA W !!," ** Active Billing Clock ** # Inpt Days: ",IBCLDAY," ",$$INPT^IBECEAU(IBCLDAY)," 90 days: $",+IBCLDOL,!
"RTN","IBECEA3",40,0)
;
"RTN","IBECEA3",41,0)
; - if LTC OPT (non-institutional) and CD display message of warning
"RTN","IBECEA3",42,0)
I IBXA=8,$$CDEXMPT^IBAECU(DFN,DT) W !!," ** Patient is currently Catastrophically Disabled",!
"RTN","IBECEA3",43,0)
;
"RTN","IBECEA3",44,0)
; - display LTC billing clock data
"RTN","IBECEA3",45,0)
I IBXA>7,IBXA<10 D G:IBCLDA<1 ADDQ
"RTN","IBECEA3",46,0)
. N IBCLZ
"RTN","IBECEA3",47,0)
. S IBCLDA=$O(^IBA(351.81,"AE",DFN,9999999),-1)
"RTN","IBECEA3",48,0)
. S:IBCLDA IBCLDA=$O(^IBA(351.81,"AE",DFN,IBCLDA,0))
"RTN","IBECEA3",49,0)
. I 'IBCLDA W !!," ** Patient has no LTC billing clock **" Q
"RTN","IBECEA3",50,0)
. S IBCLZ=^IBA(351.81,IBCLDA,0)
"RTN","IBECEA3",51,0)
. W !!," **Last LTC Billing Clock Start Date: ",$$FMTE^XLFDT($P(IBCLZ,"^",3))," Free Days Remaining: ",+$P(IBCLZ,"^",6)
"RTN","IBECEA3",52,0)
. I $P(IBCLZ,"^",6) W !,"The patient must use his free days first." S IBCLDA=0
"RTN","IBECEA3",53,0)
;
"RTN","IBECEA3",54,0)
; - ask date, units and maybe tier for rx copay charge
"RTN","IBECEA3",55,0)
I IBXA=5 D G ADDQ:IBY<0,PROC
"RTN","IBECEA3",56,0)
. N IBA,IBB,IBC,IBX
"RTN","IBECEA3",57,0)
. S IBLIM=DT D FR^IBECEAU2(0) Q:IBY<0
"RTN","IBECEA3",58,0)
. S (IBTO,IBEFDT)=IBFR
"RTN","IBECEA3",59,0)
. ;
"RTN","IBECEA3",60,0)
. ;PRCA*4.5*338 - if Community Care RX copay, set event date
"RTN","IBECEA3",61,0)
. I (IBXA=5),(IBUSNM["RX"),((IBUSNM["CC")!(IBUSNM["CHOICE")) S IBEVDA="*",IBEVDT=IBEFDT
"RTN","IBECEA3",62,0)
. ;
"RTN","IBECEA3",63,0)
. ; ask tier if needed
"RTN","IBECEA3",64,0)
. S IBTIER=$$TIER^IBECEAU2(IBATYP,IBEFDT) Q:IBY<0
"RTN","IBECEA3",65,0)
. ;
"RTN","IBECEA3",66,0)
. ; ask units
"RTN","IBECEA3",67,0)
. D UNIT^IBECEAU2(0) Q:IBY<0
"RTN","IBECEA3",68,0)
. ;
"RTN","IBECEA3",69,0)
. ; has patient been previously tracked for cap info
"RTN","IBECEA3",70,0)
. D TRACK^IBARXMN(DFN)
"RTN","IBECEA3",71,0)
. ;
"RTN","IBECEA3",72,0)
. D CTBB^IBECEAU3
"RTN","IBECEA3",73,0)
. ;
"RTN","IBECEA3",74,0)
. ; check if above cap
"RTN","IBECEA3",75,0)
. I IBY'<0 D
"RTN","IBECEA3",76,0)
.. N IBB,IBN,DIR,DIRUT,DUOUT,DTOUT,X,Y
"RTN","IBECEA3",77,0)
.. D NEW^IBARXMC(1,IBCHG,IBFR,.IBB,.IBN) Q:'IBN
"RTN","IBECEA3",78,0)
.. ;
"RTN","IBECEA3",79,0)
.. ; display message ask to proceed
"RTN","IBECEA3",80,0)
.. W !!,"This charge will put the patient > $",$J(IBN,0,2)," above their cap amount."
"RTN","IBECEA3",81,0)
.. S DIR(0)="Y",DIR("A")="Okay to proceed" D ^DIR S:'Y IBY=-1
"RTN","IBECEA3",82,0)
.. ;
"RTN","IBECEA3",83,0)
S IBLIM=$S(IBXA=4!(IBXA=3):DT,1:$$FMADD^XLFDT(DT,-1))
"RTN","IBECEA3",84,0)
;
"RTN","IBECEA3",85,0)
FR ; - ask 'bill from' date
"RTN","IBECEA3",86,0)
D FR^IBECEAU2(0) G:IBY<0 ADDQ
"RTN","IBECEA3",87,0)
;
"RTN","IBECEA3",88,0)
S IBGMT=$$ISGMTPT^IBAGMT(DFN,IBFR),IBGMTR=0 ;GMT Copayment Status
"RTN","IBECEA3",89,0)
I IBGMT>0,IBXA>0,IBXA<4 W !,"The patient has GMT Copayment Status."
"RTN","IBECEA3",90,0)
; - check the MT billing clock
"RTN","IBECEA3",91,0)
I IBXA'=8,IBXA'=9 D CLMSG^IBECEA33 G:IBY<0 ADDQ
"RTN","IBECEA3",92,0)
;Adjust Deductible for GMT patient
"RTN","IBECEA3",93,0)
I IBGMT>0,IBXA>0,IBXA<4,$G(IBMED) S IBMED=$$REDUCE^IBAGMT(IBMED) W !,"Medicare Deductible reduced due to GMT Copayment Status ($",$J(IBMED,"",2),")."
"RTN","IBECEA3",94,0)
;
"RTN","IBECEA3",95,0)
; - check LTC non-institutional (opt) for CD exemption
"RTN","IBECEA3",96,0)
I IBXA=8,$$CDEXMPT^IBAECU(DFN,IBFR) W !,"Patient is LTC non-institutional exempt, Catastrophically Disabled" G ADDQ
"RTN","IBECEA3",97,0)
;
"RTN","IBECEA3",98,0)
; - check the LTC billing clock
"RTN","IBECEA3",99,0)
I IBXA>7,IBXA<10 D I IBY<0 W !!,"The patient has no LTC clock active for the date.",! G ADDQ
"RTN","IBECEA3",100,0)
. N IBCLZ S IBCLZ=^IBA(351.81,IBCLDA,0)
"RTN","IBECEA3",101,0)
. ;
"RTN","IBECEA3",102,0)
. ; is this the clock and within the date range
"RTN","IBECEA3",103,0)
. I IBFR'<$P(IBCLZ,"^",3),$$YR^IBAECU($P(IBCLZ,"^",3),IBFR) S IBY=-1 Q
"RTN","IBECEA3",104,0)
. ;
"RTN","IBECEA3",105,0)
. ; look for another clock that might fit the date
"RTN","IBECEA3",106,0)
. I IBFR<$P(IBCLZ,"^",3) S IBCLDA=$O(^IBA(351.81,"AE",DFN,IBFR+1),-1) I 'IBCLDA!($$YR^IBAECU($P($G(^IBA(351.81,+IBCLDA,0)),"^",3),IBFR)) S IBY=-1
"RTN","IBECEA3",107,0)
;
"RTN","IBECEA3",108,0)
; - calculate the MT inpt copay charge
"RTN","IBECEA3",109,0)
I IBXA=2 S IBDT=IBFR D COPAY^IBAUTL2 G ADDQ:IBY<0 S:IBGMT>0 IBGMTR=1,IBCHG=$$REDUCE^IBAGMT(IBCHG) I IBCHG+IBCLDOL<IBMED W *7," ($",IBCHG,"/day)" W:IBGMTR " GMT Rate"
"RTN","IBECEA3",110,0)
;
"RTN","IBECEA3",111,0)
; - find the correct clock from the 'bill from' date (ignore LTC)
"RTN","IBECEA3",112,0)
I IBXA'=8,IBXA'=9,('IBCLDA!(IBCLDA&(IBFR<IBCLDT))) D NOCL^IBECEA33 G:IBY<0 ADDQ
"RTN","IBECEA3",113,0)
;
"RTN","IBECEA3",114,0)
; - perform outpatient edits
"RTN","IBECEA3",115,0)
N IBSTOPDA
"RTN","IBECEA3",116,0)
I IBXA=4,$$CHKHRFS^IBAMTS3(DFN,IBFR,IBFR) W !!,"This patient is 'Exempt' from Outpatient Visit charges on that date of service.",! G ADDQ ;IB*2.0*614 (no copayment if HRfS flag)
"RTN","IBECEA3",117,0)
I IBXA=4 D G ADDQ:IBY<0,PROC
"RTN","IBECEA3",118,0)
. ; for visits prior to 12/6/01 or FEE
"RTN","IBECEA3",119,0)
. I IBFR<3011206!($G(IBAFEE)) D OPT^IBECEA33 Q
"RTN","IBECEA3",120,0)
. ; for visits on or after 12/5/01
"RTN","IBECEA3",121,0)
. D OPT^IBEMTSCU
"RTN","IBECEA3",122,0)
;
"RTN","IBECEA3",123,0)
; - if LTC outpatient calculate the charge
"RTN","IBECEA3",124,0)
I IBXA=8 D G:IBY<0 ADDQ S (IBDT,IBTO,IBEVDT)=IBFR,IBDESC=$P(^IBE(350.1,IBATYP,0),"^",8),IBUNIT=1,IBEVDA="*" D COST^IBAUTL2,CALC^IBAECO,CTBB^IBECEAU3 G @$S(IBCHG:"PROC",1:"ADDQ")
"RTN","IBECEA3",125,0)
. ;
"RTN","IBECEA3",126,0)
. ; is this day already a free day
"RTN","IBECEA3",127,0)
. I $D(^IBA(351.81,IBCLDA,1,"AC",IBFR)) W !!,"This day is already marked as a Free Day." S IBY=-1
"RTN","IBECEA3",128,0)
. ;
"RTN","IBECEA3",129,0)
. ; have we already billed for this day
"RTN","IBECEA3",130,0)
. I $$BFO^IBECEAU(DFN,IBFR) W !!,"This patient has already been billed for this date." S IBY=-1
"RTN","IBECEA3",131,0)
;
"RTN","IBECEA3",132,0)
; - find per diem charge and description
"RTN","IBECEA3",133,0)
I IBXA=3 D I 'IBCHG W !!,"Unable to determine the per diem rate. Please check your rate table." G ADDQ
"RTN","IBECEA3",134,0)
.N IBDT S IBDT=IBFR,IBGMTR=0 D COST^IBAUTL2
"RTN","IBECEA3",135,0)
.I IBGMT>0 S IBGMTR=1,IBCHG=$$REDUCE^IBAGMT(IBCHG)
"RTN","IBECEA3",136,0)
.S IBDESC="" X:$D(^IBE(350.1,IBATYP,20)) ^(20)
"RTN","IBECEA3",137,0)
;
"RTN","IBECEA3",138,0)
; - calculate charge for the inpatient copay
"RTN","IBECEA3",139,0)
I IBXA=2,IBCHG+IBCLDOL'<IBMED S IBCHG=IBMED-IBCLDOL,IBUNIT=1,IBTO=IBFR D CTBB^IBECEAU3 G EV
"RTN","IBECEA3",140,0)
;
"RTN","IBECEA3",141,0)
TO ; - ask 'bill to' date
"RTN","IBECEA3",142,0)
D TO^IBECEAU2(0) G:IBY<0 ADDQ
"RTN","IBECEA3",143,0)
;
"RTN","IBECEA3",144,0)
I IBXA>0,IBXA<4,IBGMT'=$$ISGMTPT^IBAGMT(DFN,IBTO) W !!,"The patient's GMT Copayment status changed within the specified period!",! G ADDQ
"RTN","IBECEA3",145,0)
;
"RTN","IBECEA3",146,0)
; - calculate unit charge for LTC inpatient in IBCHG
"RTN","IBECEA3",147,0)
I IBXA=9 S IBDT=IBFR,IBEVDA=$$EVF^IBECEA31(DFN,IBFR,IBTO,IBNH),IBEVDT=$E(IBFR,1,5)_"01" D:IBEVDA<1 G ADDQ:IBY<0 D COST^IBAUTL2 I $E(IBFR,1,5)'=$E(IBTO,1,5) W !!," LTC Copayment charges cannot go from one month to another." G ADDQ
"RTN","IBECEA3",148,0)
. D NOEV^IBECEA31 I '$G(IBDG)!(IBY<0) S IBY=-1 Q
"RTN","IBECEA3",149,0)
. ; - build the event record
"RTN","IBECEA3",150,0)
. N IBNHLTC S IBNHLTC=1 D ADEV^IBECEA31
"RTN","IBECEA3",151,0)
;
"RTN","IBECEA3",152,0)
;
"RTN","IBECEA3",153,0)
; - calculate units and total charge
"RTN","IBECEA3",154,0)
S IBUNIT=$$FMDIFF^XLFDT(IBTO,IBFR) S:IBXA'=3!(IBFR=IBTO) IBUNIT=IBUNIT+1
"RTN","IBECEA3",155,0)
I IBXA=1 D:IBGMT>0 D FEPR^IBECEA32 G ADDQ:IBY<0,EV
"RTN","IBECEA3",156,0)
. S IBGMTR=1
"RTN","IBECEA3",157,0)
. W !,"The patient has GMT Copayment Status! GMT rate must be applied.",!
"RTN","IBECEA3",158,0)
S IBCHG=IBCHG*IBUNIT S:IBXA=2 IBCHG=$S(IBCLDOL+IBCHG>IBMED:IBMED-IBCLDOL,1:IBCHG)
"RTN","IBECEA3",159,0)
;
"RTN","IBECEA3",160,0)
; adjust the LTC charge based on the calculated copay cap
"RTN","IBECEA3",161,0)
I IBXA=9 D CALC^IBAECI G:IBY<1!('IBCHG) ADDQ S IBDESC="LTC INPATIENT COPAY"
"RTN","IBECEA3",162,0)
;
"RTN","IBECEA3",163,0)
D CTBB^IBECEAU3 W:IBXA=3!(IBXA=9) " (for ",IBUNIT," day",$E("s",IBUNIT>1),")" W:IBGMTR " GMT Rate"
"RTN","IBECEA3",164,0)
;
"RTN","IBECEA3",165,0)
EV ; - find event record, or select admission for linkage
"RTN","IBECEA3",166,0)
I IBXA'=9 S IBEVDA=$$EVF^IBECEA31(DFN,IBFR,IBTO,IBNH)
"RTN","IBECEA3",167,0)
I IBEVDA'>0 D NOEV^IBECEA31 G ADDQ:IBY<0,PROC
"RTN","IBECEA3",168,0)
S IBSL=$P($G(^IB(+IBEVDA,0)),"^",4)
"RTN","IBECEA3",169,0)
W !!,"Linked charge to ",$$TYP(),"admission on ",$$DAT1^IBOUTL($P(IBEVDA,"^",2))," ("
"RTN","IBECEA3",170,0)
W $S($P(IBEVDA,"^",3)=9999999:"Still admitted)",1:"Discharged on "_$$DAT1^IBOUTL($P(IBEVDA,"^",3))_$S($P(IBEVDA,"^",3)>DT:" [pseudo])",1:")"))," ..."
"RTN","IBECEA3",171,0)
S IBEVDA=+IBEVDA
"RTN","IBECEA3",172,0)
I '$G(IBSIBC) D SPEC^IBECEA32(0,$O(^IBE(351.2,"AD",IBEVDA,0)))
"RTN","IBECEA3",173,0)
;
"RTN","IBECEA3",174,0)
;
"RTN","IBECEA3",175,0)
PROC ; - okay to proceed?
"RTN","IBECEA3",176,0)
D PROC^IBECEAU4("add") G:IBY<0 ADDQ
"RTN","IBECEA3",177,0)
;
"RTN","IBECEA3",178,0)
; - build the event record first if necessary
"RTN","IBECEA3",179,0)
I $G(IBDG),IBXA'=9 D @("ADEV^IBECEA3"_$S($G(IBFEEV):4,1:1)) G:IBY<0 ADDQ
"RTN","IBECEA3",180,0)
;
"RTN","IBECEA3",181,0)
; - disposition the special inpatient billing case, if necessary
"RTN","IBECEA3",182,0)
I $G(IBSIBC) D CEA^IBAMTI1(IBSIBC,IBEVDA)
"RTN","IBECEA3",183,0)
;
"RTN","IBECEA3",184,0)
; - generate entry in file #354.71 (for VA RX only per IB*2.0*618) and #350
"RTN","IBECEA3",185,0)
I IBXA=5,(IBUSNM'["CC"),(IBUSNM'["CHOICE") W !!,"Building the new transaction... " S IBAM=$$ADD^IBARXMN(DFN,"^^"_IBEFDT_"^^P^^"_IBUNIT_"^"_IBCHG_"^"_IBDESC_"^^"_IBCHG_"^0^"_IBSITE_"^^^^^^^"_$G(IBTIER)) G:IBAM<0 ADDQ
"RTN","IBECEA3",186,0)
D ADD^IBECEAU3 G:IBY<0 ADDQ W "done."
"RTN","IBECEA3",187,0)
;
"RTN","IBECEA3",188,0)
; - pass the charge off to AR on-line
"RTN","IBECEA3",189,0)
W !,"Passing the charge directly to Accounts Receivable... "
"RTN","IBECEA3",190,0)
D PASSCH^IBECEA22 W:IBY>0 "done." G:IBY<0 ADDQ
"RTN","IBECEA3",191,0)
;
"RTN","IBECEA3",192,0)
; - review the special inpatient billing case
"RTN","IBECEA3",193,0)
I $G(IBSIBC1) D CHK^IBAMTI1(IBSIBC1,IBEVDA)
"RTN","IBECEA3",194,0)
;
"RTN","IBECEA3",195,0)
; - handle updating of clock
"RTN","IBECEA3",196,0)
I IBXA'=8,IBXA'=9 D CLUPD^IBECEA32
"RTN","IBECEA3",197,0)
;
"RTN","IBECEA3",198,0)
ADDQ ; - display error, rebuild list, and quit
"RTN","IBECEA3",199,0)
D ERR^IBECEAU4:IBY<0,PAUSE^IBECEAU S VALMBCK="R"
"RTN","IBECEA3",200,0)
I IBCOMMIT S IBBG=VALMBG W !,"Rebuilding list of charges..." D ARRAY^IBECEA0 S VALMBG=IBBG
"RTN","IBECEA3",201,0)
K IBMED,IBCLDA,IBCLDT,IBCLDOL,IBCLDAY,IBATYP,IBDG,IBSEQNO,IBXA,IBNH,IBBS,IBLIM,IBFR,IBTO,IBRTED,IBSIBC,IBSIBC1,IBBG,IBFEEV,IBAM
"RTN","IBECEA3",202,0)
K IBX,IBCHG,IBUNIT,IBDESC,IBDT,IBEVDT,IBEVDA,IBSL,IBNOS,IBN,IBTOTL,IBARTYP,IBIL,IBTRAN,IBAFY,IBCVA,IBCLSF,IBDD,IBND,VADM,VA,VAERR,IBADJMED
"RTN","IBECEA3",203,0)
ADDQ1 K IBEXSTAT,IBCOMMIT,IBCATC,IBCVAEL,IBLTCST,IBTIER,IBEFDT
"RTN","IBECEA3",204,0)
Q
"RTN","IBECEA3",205,0)
;
"RTN","IBECEA3",206,0)
;
"RTN","IBECEA3",207,0)
TYP() ; Return descriptive admission type.
"RTN","IBECEA3",208,0)
N X S X=""
"RTN","IBECEA3",209,0)
I IBNH'=2 G TYPQ
"RTN","IBECEA3",210,0)
I $G(IBADJMED) S X=$S(IBADJMED=1:"C",1:"H")
"RTN","IBECEA3",211,0)
E S X=$S($P($G(^IBE(350.1,+IBATYP,0)),"^")["NHCU":"C",1:"H")
"RTN","IBECEA3",212,0)
S X=$S(X="C":"CNH ",1:"Contract Hospital ")
"RTN","IBECEA3",213,0)
TYPQ Q X
"RTN","IBECEA33")
0^7^B23530923
"RTN","IBECEA33",1,0)
IBECEA33 ;ALB/CPM-Cancel/Edit/Add... More Add Utilities ; 23-APR-93
"RTN","IBECEA33",2,0)
;;2.0;INTEGRATED BILLING;**57,52,132,153,167,176,188,618**;21-MAR-94;Build 60
"RTN","IBECEA33",3,0)
;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IBECEA33",4,0)
;
"RTN","IBECEA33",5,0)
NOCL ; Find the correct clock from the 'bill from' date.
"RTN","IBECEA33",6,0)
N IBCLST,IBALR S IBALR=0
"RTN","IBECEA33",7,0)
I IBCLDA S IBALR=1 W !!,"The Bill From date is prior to the start of the active clock..."
"RTN","IBECEA33",8,0)
D CLSTR^IBECEAU1(DFN,IBFR)
"RTN","IBECEA33",9,0)
I 'IBCLDA D G NOCLQ
"RTN","IBECEA33",10,0)
.I IBALR W !!,"This patient has no clock which would cover this date. You should use the",!,"Clock Maintenance option to adjust this patient's clocks before proceeding." S IBY=-1 Q
"RTN","IBECEA33",11,0)
.W !!,"Please note that I cannot find an active or closed clock for this patient",!,"on this date.",!
"RTN","IBECEA33",12,0)
D CLDATA^IBAUTL3,DED^IBAUTL3 I IBY<0 D NODED^IBECEAU3 G NOCLQ
"RTN","IBECEA33",13,0)
I IBXA=2,$P($G(^IBE(350.1,IBATYP,0)),"^",8)'["NHCU",IBCLDAY>90 S IBMED=IBMED/2
"RTN","IBECEA33",14,0)
I IBXA=1,IBCLDAY>90,$G(IBADJMED)'=1 S:$G(IBADJMED)=2 IBMED=IBMED/2 I '$G(IBADJMED) D MED^IBECEA34 G:IBY<0 NOCLQ
"RTN","IBECEA33",15,0)
S IBLIM=$S($P(IBCLST,"^",10):$P(IBCLST,"^",10),1:$$FMADD^XLFDT(IBCLDT,364))
"RTN","IBECEA33",16,0)
W !!?5,"This charge will be billed under the following closed clock:"
"RTN","IBECEA33",17,0)
W !!?6,"Begin Date: ",$$DAT1^IBOUTL(IBCLDT)," # Inpt Days: ",IBCLDAY
"RTN","IBECEA33",18,0)
W !?5,"Closed Date: ",$$DAT1^IBOUTL($P(IBCLST,"^",10))," ",$$INPT^IBECEAU(IBCLDAY)," 90 Days: $",+IBCLDOL
"RTN","IBECEA33",19,0)
I IBXA=2,IBCLDOL'<IBMED S IBY=-1 W !!?5,"This patient has been billed the full copayment under this billing clock!",!?5,"You cannot add another copay charge starting on this date."
"RTN","IBECEA33",20,0)
NOCLQ Q
"RTN","IBECEA33",21,0)
;
"RTN","IBECEA33",22,0)
OPT ; Check for a C&P exam and determine the outpatient copay rate.
"RTN","IBECEA33",23,0)
I $$CNP^IBECEAU(DFN,IBFR) D I IBY<0 G OPTQ
"RTN","IBECEA33",24,0)
.N DIR,DIRUT,DUOUT,DTOUT,Y
"RTN","IBECEA33",25,0)
.W !!,"This patient had a Compensation & Pension exam on this date."
"RTN","IBECEA33",26,0)
.S DIR(0)="Y",DIR("A")="Do you still want to add a charge"
"RTN","IBECEA33",27,0)
.S DIR("?")="Enter 'Y' to continue to add the charge, or 'N' or '^' to quit"
"RTN","IBECEA33",28,0)
.D ^DIR S:'Y IBY=-1
"RTN","IBECEA33",29,0)
;
"RTN","IBECEA33",30,0)
N IBDT,IBX,IBBS,IBTYPE
"RTN","IBECEA33",31,0)
S (IBDT,IBTO)=IBFR,IBX="O",(IBTYPE,IBUNIT)=1,IBEVDA="*"
"RTN","IBECEA33",32,0)
D:$G(IBATYP)=74 CHRG^IBECEAU5 D:$G(IBATYP)'=74 TYPE^IBAUTL2
"RTN","IBECEA33",33,0)
D CTBB^IBECEAU3:IBY>0
"RTN","IBECEA33",34,0)
OPTQ Q
"RTN","IBECEA33",35,0)
;
"RTN","IBECEA33",36,0)
CHTYP ; Ask for the Charge Type
"RTN","IBECEA33",37,0)
;*** IB*2.0*618 add check for inactive field when building the list of Action Types.
"RTN","IBECEA33",38,0)
S DIC="^IBE(350.1,",DIC(0)="AEMQZ",D="E",DIC("S")="I '$P($G(^(0)),U,12),$P(^(0),U)'[""MEDICARE"",$P(^(0),U)'[""CHAMPVA SUB""",DIC("A")="Select CHARGE TYPE: "
"RTN","IBECEA33",39,0)
D IX^DIC K DIC S IBATYP=+Y I Y<0 S IBY=-1 W !!,"No CHARGE TYPE entered - transaction cannot be completed." G CHTYPQ
"RTN","IBECEA33",40,0)
;
"RTN","IBECEA33",41,0)
; - perform charge type edits
"RTN","IBECEA33",42,0)
S IBSEQNO=$P(Y(0),"^",5),IBXA=$P(Y(0),"^",11),IBNH=$S(IBXA=1:2,IBXA=9&(Y(0)["FEE"):2,1:$P(Y(0),"^",8)["NHCU")
"RTN","IBECEA33",43,0)
I 'IBSEQNO S IBY="-1^IB023" G CHTYPQ
"RTN","IBECEA33",44,0)
I IBXA=7 G CHTYPQ
"RTN","IBECEA33",45,0)
I IBXA=6 G:IBCVAEL CHTYPQ W !!,"This patient does not have a Primary Eligibility of CHAMPVA.",! G CHTYP
"RTN","IBECEA33",46,0)
I 'IBCATC,IBXA'=5,IBXA'=8,IBXA'=9 W !!,"This patient has never been Means Test billable...",!,"You may only select a Pharmacy copay charge type.",! G CHTYP
"RTN","IBECEA33",47,0)
I +IBEXSTAT,IBXA=5 W !!,"Patient is Exempt from Medication Copayment",!,$P(IBEXSTAT,"^",4),! G CHTYP
"RTN","IBECEA33",48,0)
I IBLTCST=0,IBXA>7,IBXA<10 W !!,"This patient has no LTC (1010EC) information on file.",!,"You cannot select a LTC charge type.",! G CHTYP
"RTN","IBECEA33",49,0)
I +IBLTCST=1,IBXA>7,IBXA<10 W !!,"This patient is Exempt from LTC Charges.",! G CHTYP
"RTN","IBECEA33",50,0)
S:IBXA=2 IBBS=$O(^DGCR(399.1,"AC",IBATYP,0))
"RTN","IBECEA33",51,0)
I IBXA=3 D
"RTN","IBECEA33",52,0)
.N DIR,DIRUT,DTOUT,DUOUT,DIROUT,TYPE
"RTN","IBECEA33",53,0)
.S TYPE=$S(Y(0,0)["NHCU PER DIEM":"N",1:"H")
"RTN","IBECEA33",54,0)
.S DIR(0)="Y",DIR("A")=" Is this charge for a "_$S(TYPE="N":"CNH",1:"Contract Hospital")_" admission",DIR("B")="NO"
"RTN","IBECEA33",55,0)
.S DIR("?")="Enter '<CR>' if the charge is for a VA "_$S(TYPE="N":"NHCU",1:"Hospital")_" admission, 'Y' for a "_$S(TYPE="N":"CNH",1:"Contract Hospital")_" admission, or '^' to quit."
"RTN","IBECEA33",56,0)
.W ! D ^DIR I $D(DIRUT)!$D(DUOUT) S IBY=-1 Q
"RTN","IBECEA33",57,0)
.I Y S IBNH=2
"RTN","IBECEA33",58,0)
I IBXA>7,IBXA<10,IBNH'=2 S IBNH=3
"RTN","IBECEA33",59,0)
CHTYPQ Q
"RTN","IBECEA33",60,0)
;
"RTN","IBECEA33",61,0)
CLMSG ; Check the Medicare Deductible and Billing Clock
"RTN","IBECEA33",62,0)
I 'IBMED S IBCLDT=IBFR D DED^IBAUTL3 I IBY<0 D NODED^IBECEAU3 G CLMSGQ
"RTN","IBECEA33",63,0)
I "^1^2^"[("^"_IBXA_"^"),IBCLDA,IBFR'<IBCLDT,IBCLDOL'<IBMED S IBY=-1 D
"RTN","IBECEA33",64,0)
.W !!?5,*7,"This patient has already been billed the Medicare Deductible ($",IBMED,")"
"RTN","IBECEA33",65,0)
.W !?5,"for his current 90 days of care. If you know this not to be the case,"
"RTN","IBECEA33",66,0)
.W !?5,"please adjust the billing clock before proceeding."
"RTN","IBECEA33",67,0)
CLMSGQ Q
"RTN","IBECEAU2")
0^23^B34191708
"RTN","IBECEAU2",1,0)
IBECEAU2 ;ALB/CPM-Cancel/Edit/Add... User Prompts ; 19-APR-93
"RTN","IBECEAU2",2,0)
;;2.0;INTEGRATED BILLING;**7,52,153,176,545,563,614,618**;21-MAR-94;Build 60
"RTN","IBECEAU2",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","IBECEAU2",4,0)
;
"RTN","IBECEAU2",5,0)
REAS(IBX) ; Ask for the cancellation reason.
"RTN","IBECEAU2",6,0)
; Input: IBX -- "C" (Cancel a charge), "E" (Edit a Charge)
"RTN","IBECEAU2",7,0)
S DIC="^IBE(350.3,",DIC(0)="AEMQZ",DIC("A")="Select "_$S(IBX="E":"EDIT",1:"CANCELLATION")_" REASON: "
"RTN","IBECEAU2",8,0)
S DIC("S")=$S(IBXA=7:"I 1",IBXA=6:"I $P(^(0),U,3)=3",IBXA=5:"I ($P(^(0),U,3)=1)!($P(^(0),U,3)=3)",1:"I ($P(^(0),U,3)=2)!($P(^(0),U,3)=3)")
"RTN","IBECEAU2",9,0)
D ^DIC K DIC S IBCRES=+Y I Y<0 W !!,"No ",$S(IBX="E":"edit",1:"cancellation")," reason entered - the transaction cannot be completed."
"RTN","IBECEAU2",10,0)
Q
"RTN","IBECEAU2",11,0)
;
"RTN","IBECEAU2",12,0)
UNIT(DEF) ; Ask for units for Rx copay charges
"RTN","IBECEAU2",13,0)
; Input: DEF -- Default value if previous charge is to be displayed
"RTN","IBECEAU2",14,0)
N DA,DIR,DIRUT,DUOUT,DTOUT,X,X1,Y
"RTN","IBECEAU2",15,0)
S DA=IBATYP,IBDESC="RX COPAYMENT" D COST^IBAUTL S IBCHG=X1
"RTN","IBECEAU2",16,0)
; IB*2.0*614
"RTN","IBECEAU2",17,0)
; Check for HRfS flag and days supply, if flag and days supply is less than 30 prorate cost
"RTN","IBECEAU2",18,0)
I $$CHKHRFS^IBAMTS3(DFN,IBEFDT) N IBSUPP D ;Pt has the HRfS active flag
"RTN","IBECEAU2",19,0)
. N DA,DIR,DIRUT,DUOUT,DTOUT,X,X1,Y
"RTN","IBECEAU2",20,0)
. S DIR("0")="N^1:90",DIR("?")="Enter a whole number between 1 and 90",DIR("A")="DAYS SUPPLY",DIR("B")=30
"RTN","IBECEAU2",21,0)
. D ^DIR I 'Y!($D(DIRUT))!($D(DUOUT)) Q
"RTN","IBECEAU2",22,0)
. I $G(Y)>29 Q ;Quit if day supply is not less than 30
"RTN","IBECEAU2",23,0)
. S IBCHG=$$PRORATE^IBAMTS3(Y,IBCHG) ;Prorate the cost as per regulation
"RTN","IBECEAU2",24,0)
; END OF IB*2.0*614 changes
"RTN","IBECEAU2",25,0)
S DIR(0)="N^::0^K:X<1!(X>12) X",DIR("A")="Units",DIR("?")="^D HUN^IBECEAU2"
"RTN","IBECEAU2",26,0)
S:DEF DIR("B")=DEF D ^DIR I Y S IBUNIT=Y,IBCHG=IBCHG*Y
"RTN","IBECEAU2",27,0)
I 'Y W !!,"Units not entered - transaction cannot be completed." S IBY=-1
"RTN","IBECEAU2",28,0)
Q
"RTN","IBECEAU2",29,0)
;
"RTN","IBECEAU2",30,0)
FR(DEF) ; Ask Bill From Date
"RTN","IBECEAU2",31,0)
; Input: DEF -- Default value if previous charge is to be displayed
"RTN","IBECEAU2",32,0)
N DA,DIR,DIRUT,DUOUT,DTOUT,X,X1,Y
"RTN","IBECEAU2",33,0)
FRA S:$G(DEF) DIR("B")=$$DAT2^IBOUTL(DEF)
"RTN","IBECEAU2",34,0)
S DIR(0)="DA^2901001:"_IBLIM_":EX",DIR("A")=$S(IBXA=4!(IBXA=7):"Visit Date: ",IBXA=5:"Rx Date: ",1:"Charge for services from: "),DIR("?")="^D HFR^IBECEAU2"
"RTN","IBECEAU2",35,0)
D ^DIR K DIR S IBFR=Y I 'Y W !!,$S(IBXA=4!(IBXA=7):"Visit",IBXA=5:"Rx",1:"Bill From")," Date not entered - transaction cannot be completed." S IBY=-1 G FRQ
"RTN","IBECEAU2",36,0)
I IBXA=7 G FRQ
"RTN","IBECEAU2",37,0)
I IBXA'=8,IBXA'=9,IBXA'=5,'$$BIL^DGMTUB(DFN,IBFR+.24) D CATC G FRA
"RTN","IBECEAU2",38,0)
I IBXA>7,IBXA<10,$$LTCST^IBAECU(DFN,IBFR,1)<2 W !,"This patient is not LTC billable on this date.",! G FRA
"RTN","IBECEAU2",39,0)
I IBXA=4,$$BFO^IBECEAU(DFN,IBFR) W !!,"This patient has already been billed the outpatient copay charge for ",$$DAT1^IBOUTL(IBFR),".",! G FRA
"RTN","IBECEAU2",40,0)
FRQ Q
"RTN","IBECEAU2",41,0)
;
"RTN","IBECEAU2",42,0)
TO(DEF) ; Ask Bill To Date
"RTN","IBECEAU2",43,0)
; Input: DEF -- Default value if previous charge is to be displayed
"RTN","IBECEAU2",44,0)
N DA,DIR,DIRUT,DUOUT,DTOUT,X,X1,Y
"RTN","IBECEAU2",45,0)
TOA S:$G(DEF) DIR("B")=$$DAT2^IBOUTL(DEF)
"RTN","IBECEAU2",46,0)
S DIR(0)="DA^"_IBFR_":"_IBLIM_":EX",DIR("A")=" Charge for services to: ",DIR("?")="^D HTO^IBECEAU2"
"RTN","IBECEAU2",47,0)
D ^DIR K DIR S IBTO=Y I 'Y W !!,"Bill To date not entered - transaction cannot be completed." S IBY=-1 G TOQ
"RTN","IBECEAU2",48,0)
I IBTO'=IBFR,'$$BIL^DGMTUB(DFN,$S(IBXA=3&'$G(DEF):$$FMADD^XLFDT(IBTO,-1),1:IBTO)+.24),IBXA'=8,IBXA'=9 D CATC G TOA
"RTN","IBECEAU2",49,0)
TOQ Q
"RTN","IBECEAU2",50,0)
;
"RTN","IBECEAU2",51,0)
FEE(DEF) ; Ask for Fee Amount
"RTN","IBECEAU2",52,0)
; Input: DEF -- Default value if previous charge is to be displayed
"RTN","IBECEAU2",53,0)
N DIR,DIRUT,DUOUT,DTOUT,X,Y
"RTN","IBECEAU2",54,0)
S:$G(DEF) DIR("B")=DEF
"RTN","IBECEAU2",55,0)
S DIR(0)="NA^::2^K:X<0!(X>(IBMED-IBCLDOL)) X",DIR("A")=" Fee Amount: ",DIR("?")="^D HFEE^IBECEAU2"
"RTN","IBECEAU2",56,0)
D ^DIR S IBCHG=Y I 'Y W !!,"Charge not entered - transaction cannot be completed." S IBY=-1
"RTN","IBECEAU2",57,0)
Q
"RTN","IBECEAU2",58,0)
;
"RTN","IBECEAU2",59,0)
AMT ; Ask for Charge Amount
"RTN","IBECEAU2",60,0)
N DIR,DIRUT,DUOUT,DTOUT,X,Y
"RTN","IBECEAU2",61,0)
S DIR(0)="NA^::2^K:X<0!(X>99999) X",DIR("A")="Charge Amount: ",DIR("?")="^D HAMT^IBECEAU2"
"RTN","IBECEAU2",62,0)
D ^DIR S IBCHG=Y I 'Y W !!,"Charge not entered - transaction cannot be completed." S IBY=-1
"RTN","IBECEAU2",63,0)
Q
"RTN","IBECEAU2",64,0)
;
"RTN","IBECEAU2",65,0)
CATC ; Display that patient is not Means Test billable.
"RTN","IBECEAU2",66,0)
W !!,"The patient ",$S(IBFR<DT:"was",1:"is")," not Means Test billable on this date.",!
"RTN","IBECEAU2",67,0)
Q
"RTN","IBECEAU2",68,0)
;
"RTN","IBECEAU2",69,0)
HUN ; Help for units
"RTN","IBECEAU2",70,0)
W !!,"Please enter 1, 2, 3, ...,12 to denote a 30, 60, 90, ...,360 days supply of"
"RTN","IBECEAU2",71,0)
W !,"medication, or '^' to quit."
"RTN","IBECEAU2",72,0)
Q
"RTN","IBECEAU2",73,0)
;
"RTN","IBECEAU2",74,0)
HFR ; Help for Bill From date
"RTN","IBECEAU2",75,0)
W !!,"Please enter the ",$S(IBXA=4!(IBXA=7):"patient's outpatient visit date",IBXA=5:"patient's prescription date",1:"'Bill From' date for this charge"),$S(IBXA'=5:", which must follow",1:"")
"RTN","IBECEAU2",76,0)
W !,$S(IBXA=5:"today or prior to today",1:"10/1/90"_$S(IBXA=4!(IBXA=7):"",1:" (and be prior to today)")),", or '^' to quit."
"RTN","IBECEAU2",77,0)
Q
"RTN","IBECEAU2",78,0)
;
"RTN","IBECEAU2",79,0)
HTO ; Help for Bill To date
"RTN","IBECEAU2",80,0)
W !!,"Please enter the 'Bill To' date for this charge, which may not precede"
"RTN","IBECEAU2",81,0)
W !,$$DAT1^IBOUTL(IBFR),", or '^' to quit."
"RTN","IBECEAU2",82,0)
Q
"RTN","IBECEAU2",83,0)
;
"RTN","IBECEAU2",84,0)
HFEE ; Help for Fee Amount
"RTN","IBECEAU2",85,0)
W !!,"Please enter the charge for this Fee Service, which may not be greater than"
"RTN","IBECEAU2",86,0)
W !,"the difference between the Medicare Deductible amount and the "
"RTN","IBECEAU2",87,0)
W $$INPT^IBECEAU(IBCLDAY)," 90 days",!,"copay billed ($",IBMED-IBCLDOL,"), or '^' to quit."
"RTN","IBECEAU2",88,0)
Q
"RTN","IBECEAU2",89,0)
;
"RTN","IBECEAU2",90,0)
HAMT ; Help for Charge Amount
"RTN","IBECEAU2",91,0)
W !!,"Please enter the charge for this copayment."
"RTN","IBECEAU2",92,0)
Q
"RTN","IBECEAU2",93,0)
;
"RTN","IBECEAU2",94,0)
TIER(IBATYP,IBEFDT,TIER) ; Prompt if needed for copay tier
"RTN","IBECEAU2",95,0)
; IBATYP - 350.1 IB Action Type
"RTN","IBECEAU2",96,0)
; IBEFDT - Date for possible tier choice or not if only one tier available
"RTN","IBECEAU2",97,0)
; TIER - {optional) default tier, if none specified, then 2 used
"RTN","IBECEAU2",98,0)
N IB,IBN,IBD,IBEND,IBFTIER,IBLTIER,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DIR,IBTIER
"RTN","IBECEAU2",99,0)
S IBD=-($G(IBEFDT,DT)+.9),IBD=$O(^IBE(350.2,"AIVDT",IBATYP,IBD)),IBEND=$O(^IBE(350.2,"AIVDT",IBATYP,IBD))
"RTN","IBECEAU2",100,0)
I IBD="" D Q 0
"RTN","IBECEAU2",101,0)
. W !!,"Rx Date entered is invalid for the charge type. Please confirm",!
"RTN","IBECEAU2",102,0)
. W "the date and re-enter."
"RTN","IBECEAU2",103,0)
. S IBY=-1
"RTN","IBECEAU2",104,0)
S IBEND=$O(^IBE(350.2,"AIVDT",IBATYP,IBD))
"RTN","IBECEAU2",105,0)
S IBN=0 F S IBN=$O(^IBE(350.2,"AIVDT",IBATYP,IBD,IBN)) Q:'IBN S IB=$G(^IBE(350.2,IBN,0)) I IB]"",'$P(IB,"^",5)!($P(IB,"^",5)>IBEFDT) S IBTIER($P(IB,"^",7))=""
"RTN","IBECEAU2",106,0)
; if only one tier don't prompt just use it
"RTN","IBECEAU2",107,0)
S IBFTIER=$O(IBTIER(0)) I '$O(IBTIER(IBFTIER)) Q IBFTIER
"RTN","IBECEAU2",108,0)
S IBLTIER=$O(IBTIER(1000),-1)
"RTN","IBECEAU2",109,0)
S DIR(0)="N^"_IBFTIER_":"_IBLTIER_":0"
"RTN","IBECEAU2",110,0)
S DIR("A")="ENTER THE COPAY TIER"
"RTN","IBECEAU2",111,0)
S DIR("B")=$S($G(TIER):TIER,1:2)
"RTN","IBECEAU2",112,0)
S DIR("?")="Enter the copayment tier for this charge, it will be used to determine the per unit rate."
"RTN","IBECEAU2",113,0)
D ^DIR
"RTN","IBECEAU2",114,0)
I $D(DIRUT) S IBY=-1 Q 0
"RTN","IBECEAU2",115,0)
Q Y
"RTN","IBECEAU3")
0^30^B8064716
"RTN","IBECEAU3",1,0)
IBECEAU3 ;ALB/CPM-Cancel/Edit/Add... Add New IB Action;11-MAR-93
"RTN","IBECEAU3",2,0)
;;2.0;INTEGRATED BILLING;**132,150,167,183,341,563,618**;21-MAR-94;Build 60
"RTN","IBECEAU3",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","IBECEAU3",4,0)
;
"RTN","IBECEAU3",5,0)
ADD ; Add a new Integrated Billing Action entry.
"RTN","IBECEAU3",6,0)
; Input: DFN -- Pointer to patient in file #2
"RTN","IBECEAU3",7,0)
; IBATYP -- Pointer to Action Type in file #350.1
"RTN","IBECEAU3",8,0)
; IBUNIT -- Number of units of charge
"RTN","IBECEAU3",9,0)
; IBCHG -- Total charge
"RTN","IBECEAU3",10,0)
; IBDESC -- Charge description
"RTN","IBECEAU3",11,0)
; IBSITE -- Pointer to the facility in file #4
"RTN","IBECEAU3",12,0)
; IBFAC -- Facility number
"RTN","IBECEAU3",13,0)
; IBFR -- Bill From date
"RTN","IBECEAU3",14,0)
; IBTO -- Bill To date
"RTN","IBECEAU3",15,0)
; IBEFDT -- Bill Effective Date [OPTIONAL Rx Only]
"RTN","IBECEAU3",16,0)
; IBSL -- Softlink [OPTIONAL]
"RTN","IBECEAU3",17,0)
; IBPARNT -- Pointer to parent entry in #350 [OPTIONAL]
"RTN","IBECEAU3",18,0)
; IBEVDA -- Pointer to parent event in #350 [OPTIONAL], or
"RTN","IBECEAU3",19,0)
; -- "*" to set ibevda=ibn
"RTN","IBECEAU3",20,0)
; IBEVDT -- Event Date [OPTIONAL]
"RTN","IBECEAU3",21,0)
; IBIL -- Bill Number [OPTIONAL]
"RTN","IBECEAU3",22,0)
; IBCRES -- Pointer to canc. reason in #350.3 [OPTIONAL]
"RTN","IBECEAU3",23,0)
; IBXA -- IB Action billing group [OPTIONAL]
"RTN","IBECEAU3",24,0)
; IBJOB -- Option being executed [OPTIONAL]
"RTN","IBECEAU3",25,0)
; IBCVA -- CHAMPVA Admission date [OPTIONAL]
"RTN","IBECEAU3",26,0)
; IBSTOPDA -- Pointer to clinic stop entry in #352.5 [OPTIONAL]
"RTN","IBECEAU3",27,0)
; (used for new outpatient appts created in IB)
"RTN","IBECEAU3",28,0)
; IBGMTR -- GMT Related flag [OPTIONAL]
"RTN","IBECEAU3",29,0)
; IBTIER -- Copay Tier [OPTIONAL]
"RTN","IBECEAU3",30,0)
;
"RTN","IBECEAU3",31,0)
; Output: IBN -- Internal number of new entry in file #350
"RTN","IBECEAU3",32,0)
;
"RTN","IBECEAU3",33,0)
N DA,DIK,IBASTR,IBND,Y
"RTN","IBECEAU3",34,0)
D ADD^IBAUTL I Y<1 S IBY=Y G ADDQ
"RTN","IBECEAU3",35,0)
S:$G(IBEVDA)="*" IBEVDA=IBN
"RTN","IBECEAU3",36,0)
S IBND=DFN_"^"_IBATYP_"^"_$S($G(IBSL):IBSL,1:"350:"_IBN)_"^1^"_IBUNIT_"^"_IBCHG_"^"_IBDESC_"^"_$S($D(IBPARNT):IBPARNT,1:IBN)_"^"_$G(IBCRES)_"^"_$G(IBIL)_"^^"_IBFAC
"RTN","IBECEAU3",37,0)
I IBDESC["RX COPAY",$D(IBAM) S $P(IBND,"^",18)=IBAM,$P(^IBAM(354.71,IBAM,0),"^",6)="350:"_IBN ; mark 354.71 entry back and forth
"RTN","IBECEAU3",38,0)
I IBDESC["RX COPAY",$G(IBEFDT) S $P(IBND,"^",13,14)=IBEFDT_"^"_IBEFDT
"RTN","IBECEAU3",39,0)
I IBDESC'["RX COPAY" S IBND=IBND_"^"_IBFR_"^"_IBTO_"^"_$G(IBEVDA)_$S($G(IBEVDT):"^"_IBEVDT,$G(IBXA)=1!($G(IBXA)=4)!($G(IBJOB)=5):"^"_IBFR,1:"")
"RTN","IBECEAU3",40,0)
I $G(IBSTOPDA) S $P(IBND,"^",19)=IBSTOPDA
"RTN","IBECEAU3",41,0)
I $G(IBTIER) S $P(IBND,"^",21)=IBTIER
"RTN","IBECEAU3",42,0)
S $P(^IB(IBN,0),"^",2,20)=IBND
"RTN","IBECEAU3",43,0)
; IB*2.0*618 Allow Event date to File for Community Care RX
"RTN","IBECEAU3",44,0)
I IBDESC["RX COPAY",$G(IBEVDT) D
"RTN","IBECEAU3",45,0)
. N DIE,DR,DTOUT
"RTN","IBECEAU3",46,0)
. S DA=IBN,DIE="^IB("
"RTN","IBECEAU3",47,0)
. S DR=".16///"_IBEVDA_";.17///"_IBEVDT
"RTN","IBECEAU3",48,0)
. D ^DIE
"RTN","IBECEAU3",49,0)
; end IB*2.0*618
"RTN","IBECEAU3",50,0)
;
"RTN","IBECEAU3",51,0)
I $G(IBGMTR) S $P(^IB(IBN,0),"^",21)=1 ; GMT Related
"RTN","IBECEAU3",52,0)
; DUZ may be null if this code is called by a process started by an HL7 multi-threaded listener
"RTN","IBECEAU3",53,0)
; if this condition occurs the approved fix is to use the Postmaster IEN. 2/27/06, IB*2.0*341
"RTN","IBECEAU3",54,0)
D NOW^%DTC S $P(^IB(IBN,1),"^")=$S(DUZ:DUZ,1:.5),$P(^(1),"^",3,5)=$S(DUZ:DUZ,1:.5)_"^"_%_$S($G(IBCVA):"^"_IBCVA,1:"")
"RTN","IBECEAU3",55,0)
S DIK="^IB(",DA=IBN D IX1^DIK
"RTN","IBECEAU3",56,0)
ADDQ Q
"RTN","IBECEAU3",57,0)
;
"RTN","IBECEAU3",58,0)
CTBB ; Charge to be billed
"RTN","IBECEAU3",59,0)
; Check Outpat. Fee Service less than 20% Outpat Co Pay
"RTN","IBECEAU3",60,0)
D:$G(IBAFEE) FEE^IBECEAU5 Q:IBY<1
"RTN","IBECEAU3",61,0)
W !!,"Charge to be billed --> $",$J(IBCHG,0,2)
"RTN","IBECEAU3",62,0)
Q
"RTN","IBECEAU3",63,0)
;
"RTN","IBECEAU3",64,0)
NODED ; Could not determine the Medicare Deductible amount.
"RTN","IBECEAU3",65,0)
W !,*7,"The Medicare Deductible Amount for ",$$DAT1^IBOUTL(IBCLDT)," could not be determined."
"RTN","IBECEAU3",66,0)
W !,"You should determine the cause of this problem before proceeding."
"RTN","IBECEAU3",67,0)
S IBY=-1
"RTN","IBECEAU3",68,0)
Q
"RTN","IBEFURF")
0^27^B21059318
"RTN","IBEFURF",1,0)
IBEFURF ;ALB/ARH - UTILITY: FIND RELATED FIRST PARTY BILLS ;3/7/00
"RTN","IBEFURF",2,0)
;;2.0;INTEGRATED BILLING;**130,347,459,604,618**;21-MAR-94;Build 60
"RTN","IBEFURF",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","IBEFURF",4,0)
;
"RTN","IBEFURF",5,0)
; the following procedures search for First Party charges for specific events, matchs are returned in TMP
"RTN","IBEFURF",6,0)
; only a single record of a charge event is returned, defining the charges current status, although there may
"RTN","IBEFURF",7,0)
; have been cancellations or updates to the original charge
"RTN","IBEFURF",8,0)
; o Inpatient Events may have multiple charge events (Copay and Per Diem)
"RTN","IBEFURF",9,0)
; o Opt and Rx Events have only a single charge event (Copay)
"RTN","IBEFURF",10,0)
;
"RTN","IBEFURF",11,0)
; ^TMP("IBRBF",$J, XRF, charge ifn) =
"RTN","IBEFURF",12,0)
; BILL FROM ^ BILL TO ^ CANCELLED? (1/0)^ AR BILL NUMBER ^ TOTAL CHARGE ^ ACTION TYPE (SHORT) ^ # DAYS ON HOLD
"RTN","IBEFURF",13,0)
;
"RTN","IBEFURF",14,0)
FPINPT(DFN,ADMDT,XRF) ; given a patient and admission date, find any Inpatient Charges
"RTN","IBEFURF",15,0)
; find the record of the Event (based on Event Date) then find all charges with that Event as the Parent Event
"RTN","IBEFURF",16,0)
N IBFPIFN,IBEVDT,IBEVIFN,IB0 S ADMDT=+$G(ADMDT)\1
"RTN","IBEFURF",17,0)
I +$G(DFN),+$G(ADMDT) S IBEVDT=-(ADMDT+.01) F S IBEVDT=$O(^IB("AFDT",DFN,IBEVDT)) Q:'IBEVDT!(-IBEVDT<ADMDT) D
"RTN","IBEFURF",18,0)
. S IBEVIFN=0 F S IBEVIFN=$O(^IB("AFDT",DFN,IBEVDT,IBEVIFN)) Q:'IBEVIFN D
"RTN","IBEFURF",19,0)
.. S IBFPIFN=0 F S IBFPIFN=$O(^IB("AF",IBEVIFN,IBFPIFN)) Q:'IBFPIFN D
"RTN","IBEFURF",20,0)
... S IB0=$G(^IB(IBFPIFN,0)) Q:IB0="" I $P($G(^IBE(350.1,+$P(IB0,U,3),0)),U,1)["OPT" Q
"RTN","IBEFURF",21,0)
... D FPONE(IBFPIFN,$G(XRF))
"RTN","IBEFURF",22,0)
Q
"RTN","IBEFURF",23,0)
;
"RTN","IBEFURF",24,0)
FPOPV(DFN,DT1,DT2,XRF) ; given a patient and date range, find any Outpatient Charges
"RTN","IBEFURF",25,0)
; find all records where the Event Date is within the selected date range and the charge is Outpatient
"RTN","IBEFURF",26,0)
N IBFPIFN,IBEVDT,IB0 I '$G(DT2) S DT2=+$G(DT1)
"RTN","IBEFURF",27,0)
I +$G(DFN),+$G(DT1) S IBEVDT=-(DT2+.01) F S IBEVDT=$O(^IB("AFDT",DFN,IBEVDT)) Q:'IBEVDT!(-IBEVDT<DT1) D
"RTN","IBEFURF",28,0)
. S IBFPIFN=0 F S IBFPIFN=$O(^IB("AFDT",DFN,IBEVDT,IBFPIFN)) Q:'IBFPIFN D
"RTN","IBEFURF",29,0)
.. S IB0=$G(^IB(IBFPIFN,0)) Q:IB0="" I '$$CHKOPRX(+$P(IB0,U,3)) Q
"RTN","IBEFURF",30,0)
.. D FPONE(IBFPIFN,$G(XRF))
"RTN","IBEFURF",31,0)
Q
"RTN","IBEFURF",32,0)
;
"RTN","IBEFURF",33,0)
FPRX(RXIFN,FILLDT,XRF,IBRXFL) ; given the prescription ifn (52) and the fill date, find any First Party charges
"RTN","IBEFURF",34,0)
; get specific charge entry for an Rx from the Prescription file (52,106 and 52,52,9)
"RTN","IBEFURF",35,0)
N IBFPIFN,IBFILLN,DFN S IBFPIFN=""
"RTN","IBEFURF",36,0)
I '+$G(RXIFN) Q
"RTN","IBEFURF",37,0)
I '+$G(FILLDT) Q
"RTN","IBEFURF",38,0)
S IBFILLN=$G(IBRXFL)
"RTN","IBEFURF",39,0)
S DFN=$$FILE^IBRXUTL(RXIFN,2) Q:'DFN
"RTN","IBEFURF",40,0)
;I $$FILE^IBRXUTL(RXIFN,22)=$G(FILLDT) D ; IB*2.0*604 - original code
"RTN","IBEFURF",41,0)
I $$FILE^IBRXUTL(RXIFN,22)=$G(FILLDT)!(IBFILLN=0) D ; *604-Add check for fill #. If fill # is 0, process as original fill
"RTN","IBEFURF",42,0)
. S IBFPIFN=+$P($$IBND^IBRXUTL(DFN,RXIFN),"^",2)
"RTN","IBEFURF",43,0)
. D FPONE(IBFPIFN,$G(XRF))
"RTN","IBEFURF",44,0)
E D
"RTN","IBEFURF",45,0)
. S:IBFILLN="" IBFILLN=$$RFLNUM^IBRXUTL(RXIFN,FILLDT)
"RTN","IBEFURF",46,0)
. S IBFPIFN=+$$IBNDFL^IBRXUTL(DFN,RXIFN,IBFILLN)
"RTN","IBEFURF",47,0)
. D FPONE(IBFPIFN,$G(XRF))
"RTN","IBEFURF",48,0)
Q
"RTN","IBEFURF",49,0)
;
"RTN","IBEFURF",50,0)
FPONE(FPIFN,XRF) ; for a FP charge entry get the one line item that defines the entire events charge(s)
"RTN","IBEFURF",51,0)
; get the Parent Charge then use the last charge entry as the current record for the event
"RTN","IBEFURF",52,0)
N IBPARENT,IBLAST,IBDATA Q:'$G(FPIFN)
"RTN","IBEFURF",53,0)
;
"RTN","IBEFURF",54,0)
S IBPARENT=+$P($G(^IB(+FPIFN,0)),U,9) Q:'IBPARENT
"RTN","IBEFURF",55,0)
S IBLAST=+$$LAST^IBECEAU(IBPARENT) Q:'IBLAST
"RTN","IBEFURF",56,0)
;
"RTN","IBEFURF",57,0)
I '$$DONE(IBLAST,$G(XRF)) S IBDATA=$$LN2(IBLAST) D SAVELN2(IBLAST,IBDATA,$G(XRF))
"RTN","IBEFURF",58,0)
Q
"RTN","IBEFURF",59,0)
;
"RTN","IBEFURF",60,0)
; ========================================================================================
"RTN","IBEFURF",61,0)
;
"RTN","IBEFURF",62,0)
DONE(FPIFN,XRF) ; return true if item charge (last) is already included
"RTN","IBEFURF",63,0)
N IBX S IBX="" S XRF=$S($G(XRF)="":"FP",1:XRF) I +$G(FPIFN),$D(^TMP("IBRBF",$J,XRF,+FPIFN)) S IBX=1
"RTN","IBEFURF",64,0)
Q IBX
"RTN","IBEFURF",65,0)
;
"RTN","IBEFURF",66,0)
SAVELN1(XRF,DATA) ; set charges found into array, ^TMP("IBRBF",$J,XRF) = DATA
"RTN","IBEFURF",67,0)
S XRF=$S($G(XRF)="":"FP",1:XRF),^TMP("IBRBF",$J,XRF)=$G(DATA)
"RTN","IBEFURF",68,0)
Q
"RTN","IBEFURF",69,0)
;
"RTN","IBEFURF",70,0)
SAVELN2(FPIFN,DATA,XRF) ; set charges found into array, ^TMP("IBRBF",$J,XRF,charge ifn) = DATA (from $$LN2)
"RTN","IBEFURF",71,0)
I +$G(FPIFN),$D(^IB(+FPIFN,0)) S XRF=$S($G(XRF)="":"FP",1:XRF),^TMP("IBRBF",$J,XRF,+FPIFN)=$G(DATA)
"RTN","IBEFURF",72,0)
Q
"RTN","IBEFURF",73,0)
;
"RTN","IBEFURF",74,0)
LN2(FPIFN) ; return data for a specific First Party Bill:
"RTN","IBEFURF",75,0)
; BILL FROM ^ BILL TO ^ CANCELLED? (1/0)^ AR BILL NUMBER ^ TOTAL CHARGE ^ ACTION TYPE (SHORT) ^ # DAYS ON HOLD
"RTN","IBEFURF",76,0)
; for rx's: FROM date is the (re)fill date in 52 and TO is the date entry added (release date)
"RTN","IBEFURF",77,0)
; also set # Days On Hold only if the bill is currently in On Hold status
"RTN","IBEFURF",78,0)
N IBX,IB0,IB1 S IBX="",IB0=$G(^IB(+$G(FPIFN),0)) I IB0="" G LN2Q
"RTN","IBEFURF",79,0)
S IB1=$G(^IB(+FPIFN,1))
"RTN","IBEFURF",80,0)
;
"RTN","IBEFURF",81,0)
S $P(IBX,U,1)=$S(+$P(IB0,U,4)=52:$$RXDT(+FPIFN),+$P(IB0,U,14):+$P(IB0,U,14),1:+$P(IB1,U,2))\1
"RTN","IBEFURF",82,0)
S $P(IBX,U,2)=$S(+$P(IB0,U,15):+$P(IB0,U,15),1:+$P(IB1,U,2))\1
"RTN","IBEFURF",83,0)
S $P(IBX,U,3)=$$CANC(+FPIFN)
"RTN","IBEFURF",84,0)
S $P(IBX,U,4)=$P(IB0,U,11)
"RTN","IBEFURF",85,0)
S $P(IBX,U,5)=$P(IB0,U,7)
"RTN","IBEFURF",86,0)
S $P(IBX,U,6)=$$ATAB($P(IB0,U,3))
"RTN","IBEFURF",87,0)
S $P(IBX,U,7)=$$OHDT(+FPIFN)
"RTN","IBEFURF",88,0)
LN2Q Q IBX
"RTN","IBEFURF",89,0)
;
"RTN","IBEFURF",90,0)
; ========================================================================================
"RTN","IBEFURF",91,0)
;
"RTN","IBEFURF",92,0)
; these procedures return First Party charge specific data and status
"RTN","IBEFURF",93,0)
;
"RTN","IBEFURF",94,0)
ATAB(AT) ; given an Action Type (ptr to 350.1), return a shortened/abbreviated form of Action Type (350.1,.01)
"RTN","IBEFURF",95,0)
N IBX,IBY S IBX="",IBY=$P($G(^IBE(350.1,+$G(AT),0)),U,1) I IBY="" G ATABQ
"RTN","IBEFURF",96,0)
I "IB DG PSO"'[$E(IBY,1,3) S IBX=IBY
"RTN","IBEFURF",97,0)
I IBX="" S IBY=$P(IBY," ",2,999),IBY=$P(IBY," ",1,$L(IBY," ")-1) S IBX=IBY
"RTN","IBEFURF",98,0)
ATABQ Q IBX
"RTN","IBEFURF",99,0)
;
"RTN","IBEFURF",100,0)
CANC(FPIFN) ; given a First Party Charge (ptr to 350), return 1 if charge is Cancelled, "" otherwise
"RTN","IBEFURF",101,0)
; is cancelled if the Action Type (350,.03) Sequence Number (350.1,.05) is Cancel
"RTN","IBEFURF",102,0)
; or is cancelled if the Status (350,.05) is Cancelled (350.21,.05) (never passed to AR)
"RTN","IBEFURF",103,0)
N IBX,IBY,IB0 S IBX="",IB0=$G(^IB(+$G(FPIFN),0)) I IB0="" G CANCQ
"RTN","IBEFURF",104,0)
S IBY=$P($G(^IBE(350.1,+$P(IB0,U,3),0)),U,5) I +IBY=2 S IBX=1 ; action is cancel
"RTN","IBEFURF",105,0)
I 'IBX S IBY=$P($G(^IBE(350.21,+$P(IB0,U,5),0)),U,5) I +IBY S IBX=1 ; status is cancel
"RTN","IBEFURF",106,0)
CANCQ Q IBX
"RTN","IBEFURF",107,0)
;
"RTN","IBEFURF",108,0)
RXDT(FPIFN) ; return fill date of rx being billed, Resulting From must be 52
"RTN","IBEFURF",109,0)
; fill date for Original = (52,22), for Refill = (52,52,.01)
"RTN","IBEFURF",110,0)
N IBX,IBY,IB0,IBRX,IBRXN S IBX="",IB0=$G(^IB(+$G(FPIFN),0)) I IB0="" G RXDTQ
"RTN","IBEFURF",111,0)
S IBY=$P(IB0,U,4) I +IBY=52 S IBRX=+$P(IBY,":",2),IBRXN=+$P(IBY,":",3) D I +IBY S IBX=IBY\1
"RTN","IBEFURF",112,0)
. S IBY=$S('IBRXN:$$FILE^IBRXUTL(IBRX,22),1:+$$SUBFILE^IBRXUTL(IBRX,IBRXN,52,.01))
"RTN","IBEFURF",113,0)
RXDTQ Q IBX
"RTN","IBEFURF",114,0)
;
"RTN","IBEFURF",115,0)
OHDT(FPIFN) ; return the bills # DAYS ON HOLD, if the bill is currently in the On Hold Status
"RTN","IBEFURF",116,0)
N IBX,IBY,IB0 S IBX="",IB0=$G(^IB(+$G(FPIFN),0)) I IB0="" G OHDQ
"RTN","IBEFURF",117,0)
S IBY=$P($G(^IBE(350.21,+$P(IB0,U,5),0)),U,6)
"RTN","IBEFURF",118,0)
I +IBY S IBY=$P($G(^IB(+FPIFN,1)),U,6) I +IBY S IBX=$$FMDIFF^XLFDT(DT,IBY)
"RTN","IBEFURF",119,0)
OHDQ Q IBX
"RTN","IBEFURF",120,0)
;
"RTN","IBEFURF",121,0)
;IB*2.0*618
"RTN","IBEFURF",122,0)
;-Outpatient Action type check
"RTN","IBEFURF",123,0)
;-This includes Tricare and Community Care RX Action types that will only
"RTN","IBEFURF",124,0)
; have an Outpatient billable event to reference.
"RTN","IBEFURF",125,0)
CHKOPRX(IBACTIEN) ;
"RTN","IBEFURF",126,0)
;Output: 1-Outpatient Action Type
"RTN","IBEFURF",127,0)
; (including CC and Tricare RX)
"RTN","IBEFURF",128,0)
; 0-Not Outpatient Action Type
"RTN","IBEFURF",129,0)
N IBACTNM
"RTN","IBEFURF",130,0)
;Retrieve the name
"RTN","IBEFURF",131,0)
S IBACTNM=$P($G(^IBE(350.1,IBACTIEN,0)),U,1)
"RTN","IBEFURF",132,0)
;Outpatient type found
"RTN","IBEFURF",133,0)
Q:IBACTNM["OPT" 1
"RTN","IBEFURF",134,0)
;Comm Care RX found
"RTN","IBEFURF",135,0)
I IBACTNM["RX",IBACTNM["CC" Q 1
"RTN","IBEFURF",136,0)
I IBACTNM["RX",IBACTNM["CHOICE" Q 1
"RTN","IBEFURF",137,0)
;Otherwise, not and Outpatient Action
"RTN","IBEFURF",138,0)
Q 0
"RTN","IBJDF1")
0^8^B38760357
"RTN","IBJDF1",1,0)
IBJDF1 ;ALB/CPM - THIRD PARTY FOLLOW-UP REPORT ;09-JAN-97
"RTN","IBJDF1",2,0)
;;2.0;INTEGRATED BILLING;**69,118,128,205,554,618**;21-MAR-94;Build 60
"RTN","IBJDF1",3,0)
;Per VA Directive 6402, this routine should not be modified.
"RTN","IBJDF1",4,0)
;
"RTN","IBJDF1",5,0)
EN ; - Option entry point.
"RTN","IBJDF1",6,0)
;
"RTN","IBJDF1",7,0)
W !!,"This report provides a tool for sites to use to perform follow-up"
"RTN","IBJDF1",8,0)
W !,"activities for Third Party receivables.",!
"RTN","IBJDF1",9,0)
;
"RTN","IBJDF1",10,0)
DATE ; - Choose date to use for calculation
"RTN","IBJDF1",11,0)
W !!,"Calculate report using (D)ATE OF CARE or (A)CTIVE IN AR (days): (A)CTIVE IN AR// " R X:DTIME
"RTN","IBJDF1",12,0)
G:'$T!(X["^") ENQ S:X="" X="A" S X=$E(X)
"RTN","IBJDF1",13,0)
I "ADad"'[X S IBOFF=99 D HELP^IBJDF1H G DATE
"RTN","IBJDF1",14,0)
W " ",$S("Dd"[X:"DATE OF CARE",1:"(DAYS) ACTIVE IN AR")
"RTN","IBJDF1",15,0)
S IBSDATE=$S("Dd"[X:"D",1:"A")
"RTN","IBJDF1",16,0)
;
"RTN","IBJDF1",17,0)
; - Sort by division.
"RTN","IBJDF1",18,0)
S DIR(0)="Y",DIR("B")="NO"
"RTN","IBJDF1",19,0)
S DIR("A")="Do you wish to sort this report by division"
"RTN","IBJDF1",20,0)
S DIR("?")="^S IBOFF=1 D HELP^IBJDF1H"
"RTN","IBJDF1",21,0)
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
"RTN","IBJDF1",22,0)
S IBSD=+Y K DIROUT,DTOUT,DUOUT,DIRUT
"RTN","IBJDF1",23,0)
;
"RTN","IBJDF1",24,0)
; - Issue prompt for division.
"RTN","IBJDF1",25,0)
I IBSD D PSDR^IBODIV G:Y<0 ENQ
"RTN","IBJDF1",26,0)
;
"RTN","IBJDF1",27,0)
INS ; - Determine range of carriers.
"RTN","IBJDF1",28,0)
W !!,"Run report for (S)PECIFIC insurance companies or a (R)ANGE: RANGE// "
"RTN","IBJDF1",29,0)
R X:DTIME G:'$T!(X["^") ENQ S:X="" X="R" S X=$E(X)
"RTN","IBJDF1",30,0)
I "RSrs"'[X S IBOFF=8 D HELP^IBJDF1H G INS
"RTN","IBJDF1",31,0)
W " ",$S("Ss"[X:"SPECIFIC",1:"RANGE") G:"Rr"[X INS1 K IBSI
"RTN","IBJDF1",32,0)
INS0 S DIC="^DIC(36,",DIC(0)="AEQMZ",DIC("S")="I '$G(^(5))"
"RTN","IBJDF1",33,0)
S DIC("A")=" Select "_$S($G(IBSI):"another ",1:"")_"INSURANCE CO.: "
"RTN","IBJDF1",34,0)
D ^DIC K DIC I Y'>0 G ENQ:'$G(IBSI),NAM
"RTN","IBJDF1",35,0)
I $D(IBSI(+Y)) D G INS0
"RTN","IBJDF1",36,0)
.W !!?3,"Already selected. Choose another insurance company.",!,*7
"RTN","IBJDF1",37,0)
S IBSI(+Y)="" S:'$G(IBSI) IBSI=1 G INS0
"RTN","IBJDF1",38,0)
INS1 R !?3,"START WITH INSURANCE COMPANY: FIRST// ",X:DTIME G:'$T!(X["^") ENQ
"RTN","IBJDF1",39,0)
I $E(X)="?" S IBOFF=14 D HELP^IBJDF1H G INS1
"RTN","IBJDF1",40,0)
S IBSIF=X
"RTN","IBJDF1",41,0)
INS2 R !?8,"GO TO INSURANCE COMPANY: LAST// ",X:DTIME G:'$T!(X["^") ENQ
"RTN","IBJDF1",42,0)
I $E(X)="?" S IBOFF=21 D HELP^IBJDF1H G INS2
"RTN","IBJDF1",43,0)
I X="" S IBSIL="zzzzz" S:IBSIF="" IBSIA="ALL" G NAM
"RTN","IBJDF1",44,0)
I X="@",IBSIF="@" S IBSIL="@",IBSIA="NULL" G NAM
"RTN","IBJDF1",45,0)
I IBSIF'="@",IBSIF]X D G INS2
"RTN","IBJDF1",46,0)
.W *7,!!?4,"The LAST value must follow the FIRST.",!
"RTN","IBJDF1",47,0)
S IBSIL=X
"RTN","IBJDF1",48,0)
;
"RTN","IBJDF1",49,0)
NAM ; - Determine range of patients.
"RTN","IBJDF1",50,0)
S DIR(0)="SA^N:NAME;L:LAST 4"
"RTN","IBJDF1",51,0)
S DIR("A")="Sort Patients by (N)AME or (L)AST of the SSN: "
"RTN","IBJDF1",52,0)
S DIR("B")="NAME",DIR("T")=20,DIR("?")="^S IBOFF=29 D HELP^IBJDF1H"
"RTN","IBJDF1",53,0)
W ! D ^DIR K DIR G:Y=""!(X="^") ENQ S IBSN=Y,IBI=Y(0)
"RTN","IBJDF1",54,0)
NAM1 W !?3,"START WITH PATIENT ",IBI,": FIRST// " R X:DTIME G:'$T!(X["^") ENQ
"RTN","IBJDF1",55,0)
I $E(X)="?" S IBOFF=36 D HELP^IBJDF1H G NAM1
"RTN","IBJDF1",56,0)
S IBSNF=X
"RTN","IBJDF1",57,0)
NAM2 W !?8,"GO TO PATIENT ",IBI,": LAST// " R X:DTIME G:'$T!(X["^") ENQ
"RTN","IBJDF1",58,0)
I $E(X)="?" S IBOFF=43 D HELP^IBJDF1H G NAM2
"RTN","IBJDF1",59,0)
I X="" S IBSNL="zzzzz" S:IBSNF="" IBSNA="ALL" G TYP
"RTN","IBJDF1",60,0)
I X="@",IBSNF="@" S IBSNL="@",IBSNA="NULL" G TYP
"RTN","IBJDF1",61,0)
I IBSNF'="@",IBSNF]X D G NAM2
"RTN","IBJDF1",62,0)
.W *7,!!?7,"The LAST value must follow the FIRST.",!
"RTN","IBJDF1",63,0)
S IBSNL=X
"RTN","IBJDF1",64,0)
;
"RTN","IBJDF1",65,0)
TYP ; - Select type of receivables to print.
"RTN","IBJDF1",66,0)
; IB*2.0*554/DRF 10/20/2015 Add Non-VA care
"RTN","IBJDF1",67,0)
; IB*2.0*618/SAB 6/1/2018 Add Community Care
"RTN","IBJDF1",68,0)
W !!,"Choose which type of receivables to print:",!
"RTN","IBJDF1",69,0)
S DIR(0)="LO^1:10^K:+$P(X,""-"",2)>10 X"
"RTN","IBJDF1",70,0)
S DIR("A",1)=" 1 - INPATIENT"
"RTN","IBJDF1",71,0)
S DIR("A",2)=" 2 - OUTPATIENT"
"RTN","IBJDF1",72,0)
S DIR("A",3)=" 3 - PHARMACY REFILL"
"RTN","IBJDF1",73,0)
S DIR("A",4)=" 4 - ALL COMMUNITY CARE AND FEE RECEIVABLES"
"RTN","IBJDF1",74,0)
S DIR("A",5)=" 5 - FEE REIMB INS"
"RTN","IBJDF1",75,0)
S DIR("A",6)=" 6 - COMMUNITY CARE"
"RTN","IBJDF1",76,0)
S DIR("A",7)=" 7 - COMMUNITY CARE CHOICE"
"RTN","IBJDF1",77,0)
S DIR("A",8)=" 8 - COMMUNITY CARE NETWORK"
"RTN","IBJDF1",78,0)
S DIR("A",9)=" 9 - COMMUNITY CARE MTF"
"RTN","IBJDF1",79,0)
S DIR("A",10)=" 10 - ALL RECEIVABLES"
"RTN","IBJDF1",80,0)
S DIR("A",11)="",DIR("A")="Select",DIR("B")=10
"RTN","IBJDF1",81,0)
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
"RTN","IBJDF1",82,0)
S IBSEL=Y K DIROUT,DTOUT,DUOUT,DIRUT
"RTN","IBJDF1",83,0)
;
"RTN","IBJDF1",84,0)
AR ; - Determine if the active receivable must be within an age range.
"RTN","IBJDF1",85,0)
W !!,"Include (A)LL active AR's or those within an AGE (R)ANGE: ALL// " R X:DTIME
"RTN","IBJDF1",86,0)
G:'$T!(X["^") ENQ S:X="" X="A" S X=$E(X)
"RTN","IBJDF1",87,0)
I "ARar"'[X S IBOFF=51 D HELP^IBJDF1H G AR
"RTN","IBJDF1",88,0)
W " ",$S("Rr"[X:"RANGE",1:"ALL")
"RTN","IBJDF1",89,0)
S IBSMN=$S("Rr"[X:"R",1:"A") I IBSMN="A" G AMT
"RTN","IBJDF1",90,0)
;
"RTN","IBJDF1",91,0)
AGE ;-Determine the active receivable age range.
"RTN","IBJDF1",92,0)
S DIR(0)="NA^1:99999",DIR("?")="^S IBOFF=59 D HELP^IBJDF1H"
"RTN","IBJDF1",93,0)
S DIR("A")=" Enter the minimum age of the active receivable: "
"RTN","IBJDF1",94,0)
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
"RTN","IBJDF1",95,0)
S IBSMN=+Y W " ",IBSMN," DAYS" K DIROUT,DTOUT,DUOUT,DIRUT
"RTN","IBJDF1",96,0)
;
"RTN","IBJDF1",97,0)
S DIR(0)="NA^"_IBSMN_":99999",DIR("?")="^S IBOFF=64 D HELP^IBJDF1H"
"RTN","IBJDF1",98,0)
S DIR("A")=" Enter the maximum age of the active receivable: "
"RTN","IBJDF1",99,0)
S DIR("B")=IBSMN D ^DIR K DIR
"RTN","IBJDF1",100,0)
I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
"RTN","IBJDF1",101,0)
S IBSMX=+Y W " ",IBSMX," DAYS" K DIROUT,DTOUT,DUOUT,DIRUT
"RTN","IBJDF1",102,0)
;
"RTN","IBJDF1",103,0)
AMT ; - Print receivables with a minimum balance.
"RTN","IBJDF1",104,0)
S DIR(0)="Y",DIR("B")="NO" W !
"RTN","IBJDF1",105,0)
S DIR("A")="Print receivables with a minimum balance"
"RTN","IBJDF1",106,0)
S DIR("?")="^S IBOFF=69 D HELP^IBJDF1H"
"RTN","IBJDF1",107,0)
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
"RTN","IBJDF1",108,0)
S IBSAM=+Y K DIROUT,DTOUT,DUOUT,DIRUT I 'IBSAM G BCH
"RTN","IBJDF1",109,0)
;
"RTN","IBJDF1",110,0)
AMT1 ; - Determine the minimum balance amount.
"RTN","IBJDF1",111,0)
S DIR(0)="NA^1:9999999",DIR("?")="^S IBOFF=76 D HELP^IBJDF1H"
"RTN","IBJDF1",112,0)
S DIR("A")=" Enter the minimum balance amount of the receivable: "
"RTN","IBJDF1",113,0)
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
"RTN","IBJDF1",114,0)
S IBSAM=+Y K DIROUT,DTOUT,DUOUT,DIRUT
"RTN","IBJDF1",115,0)
;
"RTN","IBJDF1",116,0)
BCH ; - Determine whether to include the bill comment history.
"RTN","IBJDF1",117,0)
S DIR(0)="Y",DIR("B")="NO" W !
"RTN","IBJDF1",118,0)
S DIR("A")="Include the Bill Comment history with each receivable"
"RTN","IBJDF1",119,0)
S DIR("?")="^S IBOFF=81 D HELP^IBJDF1H"
"RTN","IBJDF1",120,0)
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
"RTN","IBJDF1",121,0)
S IBSH=+Y K DIROUT,DTOUT,DUOUT,DIRUT
"RTN","IBJDF1",122,0)
;
"RTN","IBJDF1",123,0)
RC ; - Include receivables referred to Regional Counsel?
"RTN","IBJDF1",124,0)
S DIR(0)="Y",DIR("B")="NO" W !
"RTN","IBJDF1",125,0)
S DIR("A")="Include receivables referred to Regional Counsel"
"RTN","IBJDF1",126,0)
S DIR("?")="^S IBOFF=90 D HELP^IBJDF1H"
"RTN","IBJDF1",127,0)
D ^DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
"RTN","IBJDF1",128,0)
S IBSRC=+Y K DIROUT,DTOUT,DUOUT,DIRUT
"RTN","IBJDF1",129,0)
;
"RTN","IBJDF1",130,0)
W !!,"This report requires a 132 column printer."
"RTN","IBJDF1",131,0)
W !!,"Note: This report will search through all active receivables."
"RTN","IBJDF1",132,0)
W !?6,"You should queue this report to run after normal business hours."
"RTN","IBJDF1",133,0)
;
"RTN","IBJDF1",134,0)
; - Select a device.
"RTN","IBJDF1",135,0)
W ! S %ZIS="QM" D ^%ZIS G:POP ENQ
"RTN","IBJDF1",136,0)
I $D(IO("Q")) D G ENQ
"RTN","IBJDF1",137,0)
.S ZTRTN="DQ^IBJDF11",ZTDESC="IB - THIRD PARTY FOLLOW-UP REPORT"
"RTN","IBJDF1",138,0)
.F I="IBS*","VAUTD","VAUTD(" S ZTSAVE(I)=""
"RTN","IBJDF1",139,0)
.D ^%ZTLOAD
"RTN","IBJDF1",140,0)
.W !!,$S($D(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.")
"RTN","IBJDF1",141,0)
.K ZTSK,IO("Q") D HOME^%ZIS
"RTN","IBJDF1",142,0)
;
"RTN","IBJDF1",143,0)
U IO
"RTN","IBJDF1",144,0)
;
"RTN","IBJDF1",145,0)
D DQ^IBJDF11 ; Compile and print the report.
"RTN","IBJDF1",146,0)
;
"RTN","IBJDF1",147,0)
ENQ K IBSD,IBSEL,IBSI,IBSIF,IBSIL,IBSIA,IBSN,IBSNF,IBSNL,IBOFF,IBSNA,IBSH
"RTN","IBJDF1",148,0)
K IBSAM,IBSDATE,IBSMN,IBSMX,IBSRC,IBTEXT,IBI,POP,VAUTD,%ZIS,ZTDESC,ZTRTN,ZTSAVE,DIR
"RTN","IBJDF1",149,0)
K DIROUT,DTOUT,DUOUT,DIRUT
"RTN","IBJDF1",150,0)
Q
"RTN","IBJDF11")
0^9^B39397116
"RTN","IBJDF11",1,0)
IBJDF11 ;ALB/CPM - THIRD PARTY FOLLOW-UP REPORT (COMPILE) ;09-JAN-97
"RTN","IBJDF11",2,0)
;;2.0;INTEGRATED BILLING;**69,80,118,128,204,205,227,451,530,554,568,618**;21-MAR-94;Build 60
"RTN","IBJDF11",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","IBJDF11",4,0)
;
"RTN","IBJDF11",5,0)
DQ ; - Tasked entry point.
"RTN","IBJDF11",6,0)
K ^TMP("IBJDF1",$J) S IBQ=0
"RTN","IBJDF11",7,0)
;
"RTN","IBJDF11",8,0)
; - Collect divisions when running the job for all divisions.
"RTN","IBJDF11",9,0)
I IBSD,VAUTD S J=0 F S J=$O(^DG(40.8,J)) Q:'J S VAUTD(J)=""
"RTN","IBJDF11",10,0)
;
"RTN","IBJDF11",11,0)
; - Find data required for the report.
"RTN","IBJDF11",12,0)
S IBA=0 F S IBA=$O(^PRCA(430,"AC",16,IBA)) Q:'IBA D Q:IBQ
"RTN","IBJDF11",13,0)
.;
"RTN","IBJDF11",14,0)
.I IBA#100=0 S IBQ=$$STOP^IBOUTL("Third Party Follow-Up Report") Q:IBQ
"RTN","IBJDF11",15,0)
.;
"RTN","IBJDF11",16,0)
.;
"RTN","IBJDF11",17,0)
.;**IB*2.0*668 - Moved ahead of RI Bill check to ensure
"RTN","IBJDF11",18,0)
.; claim exists before checking rate types
"RTN","IBJDF11",19,0)
.; on Community Care Categories.
"RTN","IBJDF11",20,0)
.I '$D(^DGCR(399,IBA,0)) Q ; No corresponding claim to this AR.
"RTN","IBJDF11",21,0)
.;
"RTN","IBJDF11",22,0)
.S IBAR=$G(^PRCA(430,IBA,0))
"RTN","IBJDF11",23,0)
.;**IB*2.0*668 - Change add new AR Categories and AR Category/
"RTN","IBJDF11",24,0)
.; Rate Types
"RTN","IBJDF11",25,0)
.S IBARNUM=$$GET1^DIQ(430.2,$P(IBAR,U,2)_",",6) ; Get AR Cat Num
"RTN","IBJDF11",26,0)
.Q:'$$CHKARNUM(IBARNUM) ;Confirm RI Bill, quit if not
"RTN","IBJDF11",27,0)
.;
"RTN","IBJDF11",28,0)
.; - Determine whether bill is inpatient, outpatient, or RX refill.
"RTN","IBJDF11",29,0)
.S IBTYP=$P($G(^DGCR(399,IBA,0)),U,5),IBTYP=$S(IBTYP>2:2,1:1)
"RTN","IBJDF11",30,0)
.S:$D(^IBA(362.4,"C",IBA)) IBTYP=3
"RTN","IBJDF11",31,0)
.I $P(IBAR,U,2)=45 S IBTYP=5 ;IB*2*554/DRF Look for Non-VA *618 - Moved to FEE prompt
"RTN","IBJDF11",32,0)
.S IBTYP=$S(IBARNUM=50:7,IBARNUM=51:6,IBARNUM=52:8,IBARNUM=53:9,1:IBTYP) ;CC types
"RTN","IBJDF11",33,0)
.;CC summary flag in case doing all CC types.
"RTN","IBJDF11",34,0)
.S IBCCFLG=0 I (IBTYP>4),(IBTYP<10) S IBCCFLG=1
"RTN","IBJDF11",35,0)
.;Quit if type doesnt match, didn't select all or not the summary
"RTN","IBJDF11",36,0)
.I IBSEL'[IBTYP,IBSEL'[10,((+IBSEL=4)&(IBCCFLG=0)) Q
"RTN","IBJDF11",37,0)
.;
"RTN","IBJDF11",38,0)
.; - Check the receivable age, if necessary.
"RTN","IBJDF11",39,0)
.I IBSMN S:"Aa"[IBSDATE IBARD=$$ACT^IBJDF2(IBA) S:"Dd"[IBSDATE IBARD=$$DATE1^IBJDF2(IBA) Q:'IBARD S:IBARD IBARD=$$FMDIFF^XLFDT(DT,IBARD) I IBARD<IBSMN!(IBARD>IBSMX) Q
"RTN","IBJDF11",40,0)
.;
"RTN","IBJDF11",41,0)
.; - Check the minimum dollar amount, if necessary.
"RTN","IBJDF11",42,0)
.S IBWBA=+$G(^PRCA(430,IBA,7)) I IBSAM,IBWBA<IBSAM Q
"RTN","IBJDF11",43,0)
.;
"RTN","IBJDF11",44,0)
.; - Get division, if necessary.
"RTN","IBJDF11",45,0)
.I 'IBSD S IBDIV=0
"RTN","IBJDF11",46,0)
.E S IBDIV=$$DIV^IBJDF2(IBA) I 'IBDIV S IBDIV=+$$PRIM^VASITE()
"RTN","IBJDF11",47,0)
.I IBSD,'VAUTD Q:'$D(VAUTD(IBDIV)) ; Not a selected division.
"RTN","IBJDF11",48,0)
.;
"RTN","IBJDF11",49,0)
.; - Exclude receivables referred to Regional Counsel, if necessary.
"RTN","IBJDF11",50,0)
.S IBWRC=$G(^PRCA(430,IBA,6)) I 'IBSRC,$P(IBWRC,U,4) Q
"RTN","IBJDF11",51,0)
.S IBWRC=$S('$P(IBWRC,U,4):"",$P(IBWRC,U,22):$P(IBWRC,U,22),1:$P(IBWRC,U,4))
"RTN","IBJDF11",52,0)
.;
"RTN","IBJDF11",53,0)
.; - Get the insurance carrier and exclude claim, if necessary.
"RTN","IBJDF11",54,0)
.S IBWIN=$$INS(IBA) I IBWIN="" Q
"RTN","IBJDF11",55,0)
.;
"RTN","IBJDF11",56,0)
.; - Get the claim patient and exclude claim, if necessary.
"RTN","IBJDF11",57,0)
.S IBWPT=$$PAT(IBA) I IBWPT="" Q
"RTN","IBJDF11",58,0)
.;
"RTN","IBJDF11",59,0)
.; - Get remaining claim information.
"RTN","IBJDF11",60,0)
.; IB*2.0*451 - get 1st/3rd party payment EEOB indicator for bill
"RTN","IBJDF11",61,0)
.S IBPFLAG=$$EEOB^IBOA31(IBA)
"RTN","IBJDF11",62,0)
.S IBWDP=$P(IBAR,U,10)
"RTN","IBJDF11",63,0)
.;IB*2.0*530 Add indicator for rejects - External Bill # (.01) value is passed in, not IEN
"RTN","IBJDF11",64,0)
.S IBWBN=$G(IBPFLAG)_$S(+$$BILLREJ^IBJTU6($P($G(^DGCR(399,IBA,0)),U)):"c",1:"")_$P(IBAR,U) ; flag bill # when applicable
"RTN","IBJDF11",65,0)
.S IBBU=$G(^DGCR(399,IBA,"U")),IBWFR=+IBBU,IBWTO=$P(IBBU,U,2)
"RTN","IBJDF11",66,0)
.S IBWSC=$$OTH($P(IBWPT,U,5),$P(IBWIN,"@@",2),IBWFR),IBWOR=$P(IBAR,U,3)
"RTN","IBJDF11",67,0)
.S IBWSI=$P($G(^DPT(+$P(IBWPT,U,5),.312,+$P($G(^DGCR(399,IBA,"MP")),U,2),0)),U,2)
"RTN","IBJDF11",68,0)
.;
"RTN","IBJDF11",69,0)
.;**IB*2.0*618 - Add Non-VA summary
"RTN","IBJDF11",70,0)
.; - Set up main report index
"RTN","IBJDF11",71,0)
.F X=IBTYP,4,10 I IBSEL[X D
"RTN","IBJDF11",72,0)
..S ^TMP("IBJDF1",$J,IBDIV,X,IBWIN,$P(IBWPT,U)_"@@"_$P(IBWPT,U,5),IBWDP_"@@"_IBWBN)=$P(IBWPT,U,2)_" ("_$P(IBWPT,U,4)_")"_U_$P(IBWPT,U,3)_U_IBWSC_U_IBWFR_U_IBWTO_U_IBWOR_U_IBWBA_"~"_IBWRC_U_IBWSI
"RTN","IBJDF11",73,0)
.;
"RTN","IBJDF11",74,0)
.; - Add bill comment history, if necessary.
"RTN","IBJDF11",75,0)
.I IBSH D
"RTN","IBJDF11",76,0)
..S X=0 F S X=$O(^PRCA(433,"C",IBA,X)) Q:'X D
"RTN","IBJDF11",77,0)
...S Y=$G(^PRCA(433,X,1))
"RTN","IBJDF11",78,0)
...I $P(Y,U,2)'=35,$P(Y,U,2)'=45 Q ; Not a decrease/comment transact.
"RTN","IBJDF11",79,0)
...S DAT=$S(Y:+Y\1,1:+$P(Y,U,9)\1)
"RTN","IBJDF11",80,0)
...;
"RTN","IBJDF11",81,0)
...; - Append brief and transaction comments.
"RTN","IBJDF11",82,0)
...K COM,COM1 S COM(0)=DAT,X1=0
"RTN","IBJDF11",83,0)
...S COM1(1)=$P($G(^PRCA(433,X,5)),U,2),COM1(2)=$E($P($G(^(8)),U,6),1,70)
"RTN","IBJDF11",84,0)
...S COM(1)=COM1(1)_$S(COM1(1)]""&(COM1(2)]""):"|",1:"")_COM1(2)
"RTN","IBJDF11",85,0)
...I COM(1)]"" S COM(1)="**"_COM(1)_"**",X1=1
"RTN","IBJDF11",86,0)
...;
"RTN","IBJDF11",87,0)
...; - Get main comments.
"RTN","IBJDF11",88,0)
...S X2=0 F S X2=$O(^PRCA(433,X,7,X2)) Q:'X2 S COM($S(X1:X2+1,1:X2))=^(X2,0)
"RTN","IBJDF11",89,0)
...;
"RTN","IBJDF11",90,0)
...;**IB*2.0*618 - Added Non-VA to index collection.
"RTN","IBJDF11",91,0)
...S X1="" F S X1=$O(COM(X1)) Q:X1="" F X2=IBTYP,4,10 I IBSEL[X2 D
"RTN","IBJDF11",92,0)
....S ^TMP("IBJDF1",$J,IBDIV,X2,IBWIN,$P(IBWPT,U)_"@@"_$P(IBWPT,U,5),IBWDP_"@@"_IBWBN,X,X1)=COM(X1)
"RTN","IBJDF11",93,0)
;
"RTN","IBJDF11",94,0)
I 'IBQ D EN^IBJDF12 ; Print the report.
"RTN","IBJDF11",95,0)
;
"RTN","IBJDF11",96,0)
;IB*2.0*618 - Extract RI check and add new RI Categories
"RTN","IBJDF11",97,0)
CHKARNUM(IBCAT) ; Check for Reimbursable insurance
"RTN","IBJDF11",98,0)
;
"RTN","IBJDF11",99,0)
Q:IBCAT=21 1 ;Reimbursable Insurance - Third Party
"RTN","IBJDF11",100,0)
;
"RTN","IBJDF11",101,0)
;All Non VA care AR Categories, Emergency/Humanitarian, and Ineligible Hospital
"RTN","IBJDF11",102,0)
I (IBCAT>46),(IBCAT<54) Q 1 ;Fee Reimbursable Insurance - Third Party
"RTN","IBJDF11",103,0)
Q 0
"RTN","IBJDF11",104,0)
;
"RTN","IBJDF11",105,0)
ENQ K ^TMP("IBJDF1",$J)
"RTN","IBJDF11",106,0)
I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
"RTN","IBJDF11",107,0)
;
"RTN","IBJDF11",108,0)
D ^%ZISC
"RTN","IBJDF11",109,0)
ENQ1 K IBA,IBAR,IBARD,IBBU,IBDIV,IBQ,IBIO,IBWRC,IBWPT,IBWDP,IBWIN,IBWBN
"RTN","IBJDF11",110,0)
K IBTYP,IBWSC,IBWSI,IBWFR,IBWTO,IBWOR,IBWBA,COM,COM1,DAT,VAUTD
"RTN","IBJDF11",111,0)
K IBCCFLG,IBARNUM ;IB*2.0*618
"RTN","IBJDF11",112,0)
K X,X1,X2,Y,Z
"RTN","IBJDF11",113,0)
Q
"RTN","IBJDF11",114,0)
;
"RTN","IBJDF11",115,0)
INS(X) ; - Find the Insurance company and decide to include the claim.
"RTN","IBJDF11",116,0)
; Input: X=Pointer to the claim/AR in file #399/#430
"RTN","IBJDF11",117,0)
; plus all variable input in IBS*
"RTN","IBJDF11",118,0)
; Output: Y=Insurance Company name and pointer to file #36
"RTN","IBJDF11",119,0)
;
"RTN","IBJDF11",120,0)
N Y,Z,Z1 S Y=""
"RTN","IBJDF11",121,0)
I '$G(X) G INSQ
"RTN","IBJDF11",122,0)
S Z=+$G(^DGCR(399,X,"MP")),Z1=$P($G(^DIC(36,Z,0)),U)
"RTN","IBJDF11",123,0)
I $G(IBSI) G INSQ:'$D(IBSI(Z)),INSC
"RTN","IBJDF11",124,0)
I IBSIF'="@",'Z G INSQ
"RTN","IBJDF11",125,0)
I $D(IBSIA) G:IBSIA="ALL"&('Z) INSQ G:IBSIA="NULL"&(Z) INSQ
"RTN","IBJDF11",126,0)
I Z1="" S Z1="UNKNOWN" G INSC
"RTN","IBJDF11",127,0)
I $G(IBSIA)="ALL" G INSC
"RTN","IBJDF11",128,0)
I IBSIF="@",IBSIL="zzzzz" G INSC
"RTN","IBJDF11",129,0)
I IBSIF]Z1!(Z1]IBSIL) G INSQ
"RTN","IBJDF11",130,0)
;
"RTN","IBJDF11",131,0)
INSC S Y=Z1_"@@"_Z
"RTN","IBJDF11",132,0)
INSQ Q Y
"RTN","IBJDF11",133,0)
;
"RTN","IBJDF11",134,0)
PAT(X) ; - Find the claim patient and decide to include the claim.
"RTN","IBJDF11",135,0)
; Input: X=Pointer to the claim/AR in file #399/#430
"RTN","IBJDF11",136,0)
; plus all variable input in IBS*
"RTN","IBJDF11",137,0)
; Output: Y=1^2^3^4^5, where
"RTN","IBJDF11",138,0)
; 1 => sort key (name or last four)
"RTN","IBJDF11",139,0)
; 2 => patient name
"RTN","IBJDF11",140,0)
; 3 => patient ssn
"RTN","IBJDF11",141,0)
; 4 => patient age
"RTN","IBJDF11",142,0)
; 5 => patient pointer to file #2
"RTN","IBJDF11",143,0)
;
"RTN","IBJDF11",144,0)
N AGE,DFN,DOB,KEY,Y,Z S Y=""
"RTN","IBJDF11",145,0)
I '$G(X) G PATQ
"RTN","IBJDF11",146,0)
S DFN=+$P($G(^DGCR(399,X,0)),U,2),Z=$G(^DPT(DFN,0))
"RTN","IBJDF11",147,0)
S KEY=$S(IBSN="N":$P(Z,U),1:$E($P(Z,U,9),6,9))
"RTN","IBJDF11",148,0)
;
"RTN","IBJDF11",149,0)
I IBSNF'="@",'DFN G PATQ
"RTN","IBJDF11",150,0)
I $D(IBSNA) G:IBSNA="ALL"&('DFN) PATQ G:IBSNA="NULL"&(DFN) PATQ
"RTN","IBJDF11",151,0)
I KEY="" S Y="UNK^UNK^UNK^UNK^UNK" G PATQ
"RTN","IBJDF11",152,0)
I $G(IBSNA)="ALL" G PATC
"RTN","IBJDF11",153,0)
I IBSNF="@",IBSNL="zzzzz" G PATC
"RTN","IBJDF11",154,0)
I IBSNF]KEY!(KEY]IBSNL) G PATQ
"RTN","IBJDF11",155,0)
;
"RTN","IBJDF11",156,0)
PATC ; - Find all patient data.
"RTN","IBJDF11",157,0)
S DOB=$P(Z,U,3)
"RTN","IBJDF11",158,0)
S AGE=$S('DOB:"UNK",1:$E(DT,1,3)-$E(DOB,1,3)-($E(DT,4,7)<$E(DOB,4,7)))
"RTN","IBJDF11",159,0)
S Y=KEY_U_$E($P(Z,U),1,17)_U_$P(Z,U,9)_U_AGE_U_DFN
"RTN","IBJDF11",160,0)
PATQ Q Y
"RTN","IBJDF11",161,0)
;
"RTN","IBJDF11",162,0)
OTH(DFN,INS,DS) ; - Find a patient's other valid insurance carrier (if any).
"RTN","IBJDF11",163,0)
; Input: DFN=Pointer to the patient in file #2
"RTN","IBJDF11",164,0)
; INS=Pointer to the patient's primary carrier in file #36
"RTN","IBJDF11",165,0)
; DS=Date of service for validity check
"RTN","IBJDF11",166,0)
; Output: Valid insurance carrier (1st 13 chars.) or null
"RTN","IBJDF11",167,0)
;
"RTN","IBJDF11",168,0)
N Y S Y="" I '$G(DFN)!('$G(DS)) G OTHQ
"RTN","IBJDF11",169,0)
S Z=0 F S Z=$O(^DPT(DFN,.312,Z)) Q:'Z S X=$G(^(Z,0)) D:X Q:Y]""
"RTN","IBJDF11",170,0)
.I $G(INS),+X=INS Q
"RTN","IBJDF11",171,0)
.S X1=$G(^DIC(36,+X,0)) I X1="" Q
"RTN","IBJDF11",172,0)
.I $P(X1,U,2)'="N",$$CHK^IBCNS1(X,DS) S Y=$E($P(X1,U),1,13)
"RTN","IBJDF11",173,0)
;
"RTN","IBJDF11",174,0)
OTHQ Q Y
"RTN","IBJDF12")
0^10^B26906871
"RTN","IBJDF12",1,0)
IBJDF12 ;ALB/CPM - THIRD PARTY FOLLOW-UP REPORT (PRINT) ;10-JAN-97
"RTN","IBJDF12",2,0)
;;2.0;INTEGRATED BILLING;**69,118,128,123,204,205,554,618**;21-MAR-94;Build 60
"RTN","IBJDF12",3,0)
;Per VA Directive 6402, this routine should not be modified.
"RTN","IBJDF12",4,0)
;
"RTN","IBJDF12",5,0)
EN ; - Print the Follow-up report.
"RTN","IBJDF12",6,0)
S IBQ=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%)
"RTN","IBJDF12",7,0)
I 'IBSD D DET(0),PAUSE:'IBQ G ENQ
"RTN","IBJDF12",8,0)
S IBDIV=0 F S IBDIV=$O(VAUTD(IBDIV)) Q:'IBDIV D DET(IBDIV),PAUSE:'IBQ Q:IBQ
"RTN","IBJDF12",9,0)
;
"RTN","IBJDF12",10,0)
ENQ K IBPAG,IBRUN,IBDIV,IBWIN,IBWPT,IBWDP,IBQ,IBH,IBZ,IBC,IBC1,IBC2,IBCD,%
"RTN","IBJDF12",11,0)
Q
"RTN","IBJDF12",12,0)
;
"RTN","IBJDF12",13,0)
DET(IBDIV) ; - Print report for a specific division.
"RTN","IBJDF12",14,0)
; Input: IBDIV=Pointer to the division in file #40.8
"RTN","IBJDF12",15,0)
S IBPAG=0
"RTN","IBJDF12",16,0)
I '$D(^TMP("IBJDF1",$J,IBDIV)) D G DETQ
"RTN","IBJDF12",17,0)
.S IBSEL=10 D HDR1 I IBQ Q ;IB*2.0*618 all changed from selection 5 to 10.
"RTN","IBJDF12",18,0)
.W !!,"There are no active receivables "
"RTN","IBJDF12",19,0)
.I IBSMN W IBSMN,$S(IBSMX>IBSMN:" to "_IBSMX,1:"")," days old "
"RTN","IBJDF12",20,0)
.I IBDIV W "for this division."
"RTN","IBJDF12",21,0)
;
"RTN","IBJDF12",22,0)
S IBTYP=0 F S IBTYP=$O(^TMP("IBJDF1",$J,IBDIV,IBTYP)) Q:'IBTYP D Q:IBQ
"RTN","IBJDF12",23,0)
.D HDR1 I IBQ Q
"RTN","IBJDF12",24,0)
.S IBWIN="" F S IBWIN=$O(^TMP("IBJDF1",$J,IBDIV,IBTYP,IBWIN)) Q:IBWIN="" D Q:IBQ
"RTN","IBJDF12",25,0)
..I $Y>(IOSL-5) D PAUSE Q:IBQ D HDR1 Q:IBQ
"RTN","IBJDF12",26,0)
..D HDR2
"RTN","IBJDF12",27,0)
..S IBWPT="" F S IBWPT=$O(^TMP("IBJDF1",$J,IBDIV,IBTYP,IBWIN,IBWPT)) Q:IBWPT="" D Q:IBQ
"RTN","IBJDF12",28,0)
...S (IBH,IBWDP)="" F S IBWDP=$O(^TMP("IBJDF1",$J,IBDIV,IBTYP,IBWIN,IBWPT,IBWDP)) W:IBWDP="" ! Q:IBWDP="" S IBZ=$G(^(IBWDP)) D Q:IBQ
"RTN","IBJDF12",29,0)
....I $Y>(IOSL-3) D PAUSE Q:IBQ D HDR1,HDR2 Q:IBQ S IBH=0
"RTN","IBJDF12",30,0)
....W ! I 'IBH D WPAT S IBH=1
"RTN","IBJDF12",31,0)
....D WBIL Q:IBQ
"RTN","IBJDF12",32,0)
....;
"RTN","IBJDF12",33,0)
....; - Display bill comment history, if necessary.
"RTN","IBJDF12",34,0)
....I IBSH D WCOM Q:IBQ
"RTN","IBJDF12",35,0)
;
"RTN","IBJDF12",36,0)
DETQ Q
"RTN","IBJDF12",37,0)
;
"RTN","IBJDF12",38,0)
DASH(X) ; - Return a dashed line.
"RTN","IBJDF12",39,0)
Q $TR($J("",X)," ","=")
"RTN","IBJDF12",40,0)
;
"RTN","IBJDF12",41,0)
PAUSE ; - Page break.
"RTN","IBJDF12",42,0)
I $E(IOST,1,2)'="C-" Q
"RTN","IBJDF12",43,0)
N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
"RTN","IBJDF12",44,0)
F IBX=$Y:1:(IOSL-3) W !
"RTN","IBJDF12",45,0)
S DIR(0)="E" D ^DIR I $D(DIRUT)!($D(DUOUT)) S IBQ=1
"RTN","IBJDF12",46,0)
Q
"RTN","IBJDF12",47,0)
;
"RTN","IBJDF12",48,0)
HDR1 ; - Write the primary report header.
"RTN","IBJDF12",49,0)
I $E(IOST,1,2)="C-"!(IBPAG) W @IOF,*13
"RTN","IBJDF12",50,0)
S IBPAG=IBPAG+1
"RTN","IBJDF12",51,0)
W "Third Party Follow-Up Report"_$S(IBSDATE="D":" ( date of care )",1:" ( days in AR )")
"RTN","IBJDF12",52,0)
I IBDIV W " for ",$P($G(^DG(40.8,IBDIV,0)),U)
"RTN","IBJDF12",53,0)
W ?88,"Run Date: ",IBRUN,?123,"Page: ",$J(IBPAG,3)
"RTN","IBJDF12",54,0)
; IB*2*554/DRF - Add NON-VA to header
"RTN","IBJDF12",55,0)
; IB*2.0*618 - Add Comunity Care headers - Corrected Select Statement to prevent error.
"RTN","IBJDF12",56,0)
W !,"All active ",$$GETHDR(IBSEL),"receivables "
"RTN","IBJDF12",57,0)
I IBSMN W IBSMN,$S(IBSMX>IBSMN:" to "_IBSMX,1:"")," days old "
"RTN","IBJDF12",58,0)
I IBSAM W "with balances of at least $",IBSAM
"RTN","IBJDF12",59,0)
W !!?37,"Other",?51,"Date",?92,"Original",?103,"Current"
"RTN","IBJDF12",60,0)
W !,"Patient (Age)",?24,"SSN",?37,"Carrier",?51,"Prepared",?61,"Bill No.",?73,"Bill Fr. Bill To",?94,"Amount",?103,"Balance",?114,"Subscriber ID"
"RTN","IBJDF12",61,0)
W !,$$DASH(IOM)
"RTN","IBJDF12",62,0)
I IBSRC W !,"Note: '(n)' or '(*)' next to balance means AR was referred to Regional Counsel"
"RTN","IBJDF12",63,0)
W ! S IBQ=$$STOP^IBOUTL("Third Party Follow-Up Report")
"RTN","IBJDF12",64,0)
Q
"RTN","IBJDF12",65,0)
;
"RTN","IBJDF12",66,0)
HDR2 ; - Write the insurance company sub-header.
"RTN","IBJDF12",67,0)
N X,X13 W !?3,"Carrier: ",$P(IBWIN,"@@")
"RTN","IBJDF12",68,0)
S X=$G(^DIC(36,+$P(IBWIN,"@@",2),.11)),X13=$G(^(.13))
"RTN","IBJDF12",69,0)
I X]"" D
"RTN","IBJDF12",70,0)
.W ", ",$P(X,U),", ",$P(X,U,4),", ",$P($G(^DIC(5,+$P(X,U,5),0)),U,2)," ",$P(X,U,6)
"RTN","IBJDF12",71,0)
.I $P(X13,U,2)]"" W " Billing Phone: ",$P(X13,U,2) Q
"RTN","IBJDF12",72,0)
.I $P(X13,U)]"" W " Main Phone: ",$P(X13,U)
"RTN","IBJDF12",73,0)
Q
"RTN","IBJDF12",74,0)
;
"RTN","IBJDF12",75,0)
;IB*2.0*618 - Centralize header phrases for all Third Party Follow-up reports
"RTN","IBJDF12",76,0)
GETHDR(IBSEL,IBFLG) ; - retrieve the text display for the header, based upon selection type.
"RTN","IBJDF12",77,0)
; IBSEL = (Required) Type of Report
"RTN","IBJDF12",78,0)
; IBFLG = (Optional) Summary Report = 1, Detail Report = NULL
"RTN","IBJDF12",79,0)
;
"RTN","IBJDF12",80,0)
S IBFLG=$G(IBFLG)
"RTN","IBJDF12",81,0)
Q:IBSEL="1," "INPATIENT "
"RTN","IBJDF12",82,0)
Q:IBSEL="2," "OUTPATIENT "
"RTN","IBJDF12",83,0)
Q:IBSEL="3," "RX REFILL "
"RTN","IBJDF12",84,0)
Q:IBSEL="4," "ALL COMMUNITY CARE AND FEE "
"RTN","IBJDF12",85,0)
Q:IBSEL="5," "FEE REIMB INS "
"RTN","IBJDF12",86,0)
Q:IBSEL="6," "COMMUNITY CARE "
"RTN","IBJDF12",87,0)
Q:IBSEL="7," "COMMUNITY CARE CHOICE "
"RTN","IBJDF12",88,0)
Q:IBSEL="8," "COMMUNITY CARE NETWORK "
"RTN","IBJDF12",89,0)
Q:IBSEL="9," "COMMUNITY CARE MTF "
"RTN","IBJDF12",90,0)
Q:IBFLG "ALL " ; Used in the Third Party Summary
"RTN","IBJDF12",91,0)
Q ""
"RTN","IBJDF12",92,0)
;
"RTN","IBJDF12",93,0)
WPAT ; - Write patient data.
"RTN","IBJDF12",94,0)
W $P(IBZ,U),?24,$$SSN($P(IBZ,U,2)),?37,$P(IBZ,U,3)
"RTN","IBJDF12",95,0)
Q
"RTN","IBJDF12",96,0)
;
"RTN","IBJDF12",97,0)
WBIL ; - Write bill data.
"RTN","IBJDF12",98,0)
W ?51,$$DAT1^IBOUTL(+IBWDP),?60,$P(IBWDP,"@@",2)
"RTN","IBJDF12",99,0)
W ?73,$$DAT1^IBOUTL($P(IBZ,U,4)),?82,$$DAT1^IBOUTL($P(IBZ,U,5))
"RTN","IBJDF12",100,0)
W ?90,$J($P(IBZ,U,6),10,2),?100,$J(+$P(IBZ,U,7),10,2)
"RTN","IBJDF12",101,0)
I $P($P(IBZ,U,7),"~",2) D
"RTN","IBJDF12",102,0)
. I $P($P(IBZ,U,7),"~",2)<6 W "(",$P($P(IBZ,U,7),"~",2),")" Q
"RTN","IBJDF12",103,0)
. W "(*)"
"RTN","IBJDF12",104,0)
W ?114,$E($P(IBZ,U,8),1,18)
"RTN","IBJDF12",105,0)
Q
"RTN","IBJDF12",106,0)
;
"RTN","IBJDF12",107,0)
WCOM ; - Write the comments
"RTN","IBJDF12",108,0)
N CONT,DIWL,DIWR,IBC,IBC1,IBC2,X
"RTN","IBJDF12",109,0)
;
"RTN","IBJDF12",110,0)
S (IBC,CONT)=0,DIWL=1,DIWR=104 K ^UTILITY($J,"W")
"RTN","IBJDF12",111,0)
F S IBC=$O(^TMP("IBJDF1",$J,IBDIV,IBTYP,IBWIN,IBWPT,IBWDP,IBC)) Q:'IBC D Q:IBQ
"RTN","IBJDF12",112,0)
. I $Y>(IOSL-4) D PAUSE Q:IBQ D HDR1,HDR2 Q:IBQ W ! D WPAT,WBIL
"RTN","IBJDF12",113,0)
. S IBC1=""
"RTN","IBJDF12",114,0)
. F S IBC1=$O(^TMP("IBJDF1",$J,IBDIV,IBTYP,IBWIN,IBWPT,IBWDP,IBC,IBC1)) Q:IBC1="" D Q:IBQ
"RTN","IBJDF12",115,0)
. . S IBC2=^TMP("IBJDF1",$J,IBDIV,IBTYP,IBWIN,IBWPT,IBWDP,IBC,IBC1)
"RTN","IBJDF12",116,0)
. . I $Y>(IOSL-4) D WCPB Q:IBQ
"RTN","IBJDF12",117,0)
. . I 'IBC1 S IBCD=IBC2 D WCD Q
"RTN","IBJDF12",118,0)
. . S X=IBC2 I $E(X)=" ",$L(X)>1 S $E(X)=""
"RTN","IBJDF12",119,0)
. . D ^DIWP
"RTN","IBJDF12",120,0)
. . I 'CONT,$L(IBC2)<66 D WCTXT Q
"RTN","IBJDF12",121,0)
. . S CONT=$L(IBC2)>65
"RTN","IBJDF12",122,0)
. . I '$O(^TMP("IBJDF1",$J,IBDIV,IBTYP,IBWIN,IBWPT,IBWDP,IBC,IBC1)) D
"RTN","IBJDF12",123,0)
. . . D:$D(^UTILITY($J,"W")) WCTXT
"RTN","IBJDF12",124,0)
K ^UTILITY($J,"W")
"RTN","IBJDF12",125,0)
Q
"RTN","IBJDF12",126,0)
;
"RTN","IBJDF12",127,0)
WCD ; - Write comment date.
"RTN","IBJDF12",128,0)
W !?2,"Comment Date: ",$$DAT1^IBOUTL(IBCD)
"RTN","IBJDF12",129,0)
Q
"RTN","IBJDF12",130,0)
;
"RTN","IBJDF12",131,0)
WCTXT ; - Write comment text
"RTN","IBJDF12",132,0)
N LIN,WLIN
"RTN","IBJDF12",133,0)
S LIN=""
"RTN","IBJDF12",134,0)
F S LIN=$O(^UTILITY($J,"W",1,LIN)) Q:LIN="" D Q:IBQ
"RTN","IBJDF12",135,0)
. S WLIN=$G(^UTILITY($J,"W",1,LIN,0))
"RTN","IBJDF12",136,0)
. I $Y>(IOSL-4) D WCPB Q:IBQ
"RTN","IBJDF12",137,0)
. W:WLIN'="" ?26,WLIN,!
"RTN","IBJDF12",138,0)
K ^UTILITY($J,"W")
"RTN","IBJDF12",139,0)
Q
"RTN","IBJDF12",140,0)
;
"RTN","IBJDF12",141,0)
WCPB ; - Page Break in the middle of Comments
"RTN","IBJDF12",142,0)
;
"RTN","IBJDF12",143,0)
D PAUSE Q:IBQ D HDR1,HDR2 Q:IBQ
"RTN","IBJDF12",144,0)
W ! D WPAT,WBIL D WCD W:IBC1>1 ?26,"(continued)",!
"RTN","IBJDF12",145,0)
Q
"RTN","IBJDF12",146,0)
;
"RTN","IBJDF12",147,0)
SSN(X) ; - Format the SSN.
"RTN","IBJDF12",148,0)
Q $S(X]"":$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),1:"")
"RTN","IBJDF2")
0^11^B82293894
"RTN","IBJDF2",1,0)
IBJDF2 ;ALB/CPM - THIRD PARTY FOLLOW-UP SUMMARY REPORT ;Feb 09, 2018@10:11:43
"RTN","IBJDF2",2,0)
;;2.0;INTEGRATED BILLING;**69,91,100,118,133,205,554,597,568,618**;21-MAR-94;Build 60
"RTN","IBJDF2",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","IBJDF2",4,0)
;
"RTN","IBJDF2",5,0)
EN ; - Option entry point.
"RTN","IBJDF2",6,0)
;
"RTN","IBJDF2",7,0)
W !!,"This report provides a summary of all outstanding Third Party receivables.",!
"RTN","IBJDF2",8,0)
;
"RTN","IBJDF2",9,0)
DATE ; - Choose date to use for calculation
"RTN","IBJDF2",10,0)
W !!,"Calculate report using (D)ATE OF CARE or (A)CTIVE IN AR (days): (A)CTIVE IN AR// " R X:DTIME
"RTN","IBJDF2",11,0)
G:'$T!(X["^") ENQ S:X="" X="A" S X=$E(X)
"RTN","IBJDF2",12,0)
I "ADad"'[X S IBOFF=99 D HELP^IBJDF1H G DATE
"RTN","IBJDF2",13,0)
W " ",$S("Dd"[X:"DATE OF CARE",1:"(DAYS) ACTIVE IN AR")
"RTN","IBJDF2",14,0)
S IBSDATE=$S("Dd"[X:"D",1:"A")
"RTN","IBJDF2",15,0)
;
"RTN","IBJDF2",16,0)
; - Sort by division.
"RTN","IBJDF2",17,0)
S DIR(0)="Y",DIR("B")="NO"
"RTN","IBJDF2",18,0)
S DIR("A")="Do you wish to sort this report by division"
"RTN","IBJDF2",19,0)
S DIR("?")="^D DHLP^IBJDF2"
"RTN","IBJDF2",20,0)
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
"RTN","IBJDF2",21,0)
S IBSORT=+Y K DIROUT,DTOUT,DUOUT,DIRUT
"RTN","IBJDF2",22,0)
;
"RTN","IBJDF2",23,0)
; - Issue prompt for division.
"RTN","IBJDF2",24,0)
I IBSORT D PSDR^IBODIV G:Y<0 ENQ
"RTN","IBJDF2",25,0)
;
"RTN","IBJDF2",26,0)
TYP ; - Select type of summaries to print.
"RTN","IBJDF2",27,0)
; IB*2.0*554 DRF 10/19/2015 Add Non-VA care
"RTN","IBJDF2",28,0)
;IB*2.0*618 expanded Non-VA care to list the different programs.
"RTN","IBJDF2",29,0)
W !!,"Choose which type of summaries to print:",!
"RTN","IBJDF2",30,0)
S DIR(0)="LO^1:10^K:+$P(X,""-"",2)>10 X"
"RTN","IBJDF2",31,0)
S DIR("A",1)=" 1 - INPATIENT"
"RTN","IBJDF2",32,0)
S DIR("A",2)=" 2 - OUTPATIENT"
"RTN","IBJDF2",33,0)
S DIR("A",3)=" 3 - PHARMACY REFILL"
"RTN","IBJDF2",34,0)
S DIR("A",4)=" 4 - ALL COMMUNITY CARE AND FEE RECEIVABLES"
"RTN","IBJDF2",35,0)
S DIR("A",5)=" 5 - FEE REIMB INS"
"RTN","IBJDF2",36,0)
S DIR("A",6)=" 6 - COMMUNITY CARE"
"RTN","IBJDF2",37,0)
S DIR("A",7)=" 7 - COMMUNITY CARE CHOICE"
"RTN","IBJDF2",38,0)
S DIR("A",8)=" 8 - COMMUNITY CARE NETWORK"
"RTN","IBJDF2",39,0)
S DIR("A",9)=" 9 - COMMUNITY CARE MTF"
"RTN","IBJDF2",40,0)
S DIR("A",10)=" 10 - ALL RECEIVABLES"
"RTN","IBJDF2",41,0)
S DIR("A",11)="",DIR("A")="Select",DIR("B")=10
"RTN","IBJDF2",42,0)
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
"RTN","IBJDF2",43,0)
S IBSEL=Y K DIROUT,DTOUT,DUOUT,DIRUT
"RTN","IBJDF2",44,0)
;
"RTN","IBJDF2",45,0)
W !!,"This report only requires an 80 column printer."
"RTN","IBJDF2",46,0)
W !!,"Note: This report requires a search through all active receivables."
"RTN","IBJDF2",47,0)
W !?6,"You should queue this report to run after normal business hours.",!
"RTN","IBJDF2",48,0)
;
"RTN","IBJDF2",49,0)
; - Select a device.
"RTN","IBJDF2",50,0)
S %ZIS="QM" D ^%ZIS G:POP ENQ
"RTN","IBJDF2",51,0)
I $D(IO("Q")) D G ENQ
"RTN","IBJDF2",52,0)
.S ZTRTN="DQ^IBJDF2",ZTDESC="IB - FOLLOW-UP SUMMARY REPORT"
"RTN","IBJDF2",53,0)
.F I="IBSEL","IBSDATE","IBSORT","VAUTD","VAUTD(" S ZTSAVE(I)=""
"RTN","IBJDF2",54,0)
.D ^%ZTLOAD
"RTN","IBJDF2",55,0)
.W !!,$S($D(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.")
"RTN","IBJDF2",56,0)
.K ZTSK,IO("Q") D HOME^%ZIS
"RTN","IBJDF2",57,0)
;
"RTN","IBJDF2",58,0)
U IO
"RTN","IBJDF2",59,0)
;
"RTN","IBJDF2",60,0)
DQ ; - Tasked entry point.
"RTN","IBJDF2",61,0)
;
"RTN","IBJDF2",62,0)
I $G(IBXTRACT) D E^IBJDE(9,1) ; Change extract status.
"RTN","IBJDF2",63,0)
;
"RTN","IBJDF2",64,0)
; Set IBTYP array
"RTN","IBJDF2",65,0)
K IBTYPE F IBLP=1:1:($L(IBSEL,",")-1) S IBTYPE($P(IBSEL,",",IBLP))=$P(IBSEL,",",IBLP)
"RTN","IBJDF2",66,0)
;
"RTN","IBJDF2",67,0)
;**IB*2.0*618 - expanded loop to account for new options
"RTN","IBJDF2",68,0)
K IB F I=1:1:10 I $G(IBTYPE(I)) D
"RTN","IBJDF2",69,0)
.I 'IBSORT D Q
"RTN","IBJDF2",70,0)
..F J=1:1:9 S IB(0,I,J)=""
"RTN","IBJDF2",71,0)
.I 'VAUTD D Q
"RTN","IBJDF2",72,0)
..S J=0 F S J=$O(VAUTD(J)) Q:'J F K=1:1:9 S IB(J,I,K)=""
"RTN","IBJDF2",73,0)
.S J=0 F S J=$O(^DG(40.8,J)) Q:'J F K=1:1:9 S IB(J,I,K)=""
"RTN","IBJDF2",74,0)
;
"RTN","IBJDF2",75,0)
; - Find data required for the report.
"RTN","IBJDF2",76,0)
S (IBQ,IBA)=0 F S IBA=$O(^PRCA(430,"AC",16,IBA)) Q:'IBA D Q:IBQ
"RTN","IBJDF2",77,0)
.;
"RTN","IBJDF2",78,0)
.I IBA#100=0 S IBQ=$$STOP^IBOUTL("Third Party Follow-Up Summary Report") Q:IBQ
"RTN","IBJDF2",79,0)
.;
"RTN","IBJDF2",80,0)
.;IB*2.0*618 moved ahead of AR Cat check to ensure bill exists before performing lookup in CHKARNUM
"RTN","IBJDF2",81,0)
.S:"Aa"[IBSDATE IBARD=$$ACT(IBA) S:"Dd"[IBSDATE IBARD=$$DATE1(IBA) I 'IBARD Q ; No activation date.
"RTN","IBJDF2",82,0)
.I '$D(^DGCR(399,IBA,0)) Q ; No corresponding claim to this AR.
"RTN","IBJDF2",83,0)
.;
"RTN","IBJDF2",84,0)
.S IBAR=$G(^PRCA(430,IBA,0))
"RTN","IBJDF2",85,0)
.;**IB*2.0*618 - Change add new AR Categories and AR Category/
"RTN","IBJDF2",86,0)
.; Rate Types
"RTN","IBJDF2",87,0)
.S IBARNUM=$$GET1^DIQ(430.2,$P(IBAR,U,2)_",",6) ; Get AR Cat Num
"RTN","IBJDF2",88,0)
.Q:'$$CHKARNUM^IBJDF11(IBARNUM) ;Confirm RI Bill, quit if not
"RTN","IBJDF2",89,0)
.;
"RTN","IBJDF2",90,0)
.; - Get division if necessary.
"RTN","IBJDF2",91,0)
.I 'IBSORT S IBDIV=0
"RTN","IBJDF2",92,0)
.E S IBDIV=$$DIV(IBA) I 'IBDIV S IBDIV=+$$PRIM^VASITE()
"RTN","IBJDF2",93,0)
.I IBSORT,'VAUTD Q:'$D(VAUTD(IBDIV)) ; Not a selected division.
"RTN","IBJDF2",94,0)
.;
"RTN","IBJDF2",95,0)
.; - Determine whether bill is inpatient, outpatient, or RX refill.
"RTN","IBJDF2",96,0)
.S IBTYP=$P($G(^DGCR(399,IBA,0)),U,5),IBTYP=$S(IBTYP>2:2,1:1)
"RTN","IBJDF2",97,0)
.S:$D(^IBA(362.4,"C",IBA)) IBTYP=3
"RTN","IBJDF2",98,0)
.I $P(IBAR,U,2)=45 S IBTYP=5 ;IB*2*554/DRF Look for Non-VA/IB*2.0*618/Moved FEE to option 5
"RTN","IBJDF2",99,0)
.S IBTYP=$S(IBARNUM=50:7,IBARNUM=51:6,IBARNUM=52:8,IBARNUM=53:9,1:IBTYP) ;CC types
"RTN","IBJDF2",100,0)
.;CC summary flag in case doing all CC types.
"RTN","IBJDF2",101,0)
.S IBCCFLG=0 I (IBTYP>4),(IBTYP<10) S IBCCFLG=1
"RTN","IBJDF2",102,0)
.;Quit if type doesnt match, didn't select all or not the summary
"RTN","IBJDF2",103,0)
.I $G(IBTYPE(IBTYP))="",(IBSEL'[10),((IBSEL[4)&(IBCCFLG=0)) Q
"RTN","IBJDF2",104,0)
.;
"RTN","IBJDF2",105,0)
.; - Handle claims referred to Regional Counsel.
"RTN","IBJDF2",106,0)
.S IBOUT=+$G(^PRCA(430,IBA,7))
"RTN","IBJDF2",107,0)
.I $P($G(^PRCA(430,IBA,6)),U,4) D Q
"RTN","IBJDF2",108,0)
..;**IB*2.0*618 - Add Non-VA summary
"RTN","IBJDF2",109,0)
..F I=IBTYP,4,10 I $G(IBTYPE(I)) D
"RTN","IBJDF2",110,0)
...S $P(IB(IBDIV,I,8),U)=+IB(IBDIV,I,8)+1
"RTN","IBJDF2",111,0)
...S $P(IB(IBDIV,I,8),U,2)=$P(IB(IBDIV,I,8),U,2)+IBOUT
"RTN","IBJDF2",112,0)
.;
"RTN","IBJDF2",113,0)
.; - Determine age and outstanding balance.
"RTN","IBJDF2",114,0)
.S IBAGE=$$FMDIFF^XLFDT(DT,IBARD),IBCAT=$$CAT(IBAGE)
"RTN","IBJDF2",115,0)
.;
"RTN","IBJDF2",116,0)
.;**IB*2.0*618 - Add Non-VA summary
"RTN","IBJDF2",117,0)
.F I=IBTYP,4,10 I $G(IBTYPE(I)) D
"RTN","IBJDF2",118,0)
..S $P(IB(IBDIV,I,IBCAT),U)=+IB(IBDIV,I,IBCAT)+1
"RTN","IBJDF2",119,0)
..S $P(IB(IBDIV,I,IBCAT),U,2)=$P(IB(IBDIV,I,IBCAT),U,2)+IBOUT
"RTN","IBJDF2",120,0)
;
"RTN","IBJDF2",121,0)
I IBQ G ENQ
"RTN","IBJDF2",122,0)
;
"RTN","IBJDF2",123,0)
; - Extract summary data.
"RTN","IBJDF2",124,0)
; *597 fix array subscripts for all types
"RTN","IBJDF2",125,0)
;IB*2.0*618 - update array subscripts for all types
"RTN","IBJDF2",126,0)
I $G(IBXTRACT) D G ENQ
"RTN","IBJDF2",127,0)
.F I=1:1:8 D
"RTN","IBJDF2",128,0)
..F J=1,2 S $P(IB(0,10,9),U,J)=$P(IB(0,10,9),U,J)+$P(IB(0,10,I),U,J)
"RTN","IBJDF2",129,0)
.S I=0 F J=1:1:9 D
"RTN","IBJDF2",130,0)
..S I=I+1,IB(I)=+IB(0,10,J),I=I+1,IB(I)=$J(+$P(IB(0,10,J),U,2),0,2)
"RTN","IBJDF2",131,0)
.D E^IBJDE(9,0)
"RTN","IBJDF2",132,0)
;
"RTN","IBJDF2",133,0)
; - Print the reports.
"RTN","IBJDF2",134,0)
S (IBPAG,IBQ)=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%)
"RTN","IBJDF2",135,0)
I 'IBSORT D SUM(0) G ENQ
"RTN","IBJDF2",136,0)
;
"RTN","IBJDF2",137,0)
S IBDIV=0 F S IBDIV=$O(IB(IBDIV)) Q:'IBDIV D SUM(IBDIV) Q:IBQ
"RTN","IBJDF2",138,0)
;
"RTN","IBJDF2",139,0)
ENQ I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
"RTN","IBJDF2",140,0)
;
"RTN","IBJDF2",141,0)
D ^%ZISC
"RTN","IBJDF2",142,0)
ENQ1 K IB,IBOFF,IBQ,IBSDATE,IBSEL,IBSORT,IBTEXT,IBA,IBAR,IBARD,IBDIV,IBAGE,IBOUT,IBCAT,IBPAG,IBRUN
"RTN","IBJDF2",143,0)
K IBDH,IBTYP,IBTYPH,%,%ZIS,DFN,I,J,K,POP,VAUTD,X,Y,Z,ZTDESC,ZTRTN,ZTSAVE
"RTN","IBJDF2",144,0)
K IBCCFLG,IBARNUM,IBLP,IBTYPE
"RTN","IBJDF2",145,0)
K DIROUT,DTOUT,DUOUT,DIRUT
"RTN","IBJDF2",146,0)
Q
"RTN","IBJDF2",147,0)
;
"RTN","IBJDF2",148,0)
SUM(IBDIV) ; - Print the report.
"RTN","IBJDF2",149,0)
; Input: IBDIV=Pointer to the division in file #40.8
"RTN","IBJDF2",150,0)
;
"RTN","IBJDF2",151,0)
S IBTYP=0 F S IBTYP=$O(IB(IBDIV,IBTYP)) Q:'IBTYP D Q:IBQ
"RTN","IBJDF2",152,0)
.I $E(IOST,1,2)="C-"!(IBPAG) W @IOF,*13
"RTN","IBJDF2",153,0)
.S IBPAG=IBPAG+1 W !?68,"Page: ",IBPAG
"RTN","IBJDF2",154,0)
.W !!?22,"THIRD PARTY FOLLOW-UP SUMMARY REPORT"
"RTN","IBJDF2",155,0)
.S IBTYPH=$$GETHDR^IBJDF12(IBTYP_",",1)_"RECEIVABLES"_$S(IBSDATE="D":" ( date of care )",1:" ( days in AR )")
"RTN","IBJDF2",156,0)
.W !?(80-$L(IBTYPH))\2,IBTYPH
"RTN","IBJDF2",157,0)
.I IBDIV S IBDH="Division: "_$P($G(^DG(40.8,IBDIV,0)),U) W !?(80-$L(IBDH)\2),IBDH
"RTN","IBJDF2",158,0)
.W !!?24,"Run Date: ",IBRUN,!?24,$$DASH(31),!!
"RTN","IBJDF2",159,0)
.;
"RTN","IBJDF2",160,0)
.; - Calculate totals first.
"RTN","IBJDF2",161,0)
.F I=1:1:8 F J=1,2 S $P(IB(IBDIV,IBTYP,9),U,J)=$P(IB(IBDIV,IBTYP,9),U,J)+$P(IB(IBDIV,IBTYP,I),U,J)
"RTN","IBJDF2",162,0)
.;
"RTN","IBJDF2",163,0)
.W "AR Category",?31,"# Receivables",?52,"Total Outstanding Balance"
"RTN","IBJDF2",164,0)
.W !,"-----------",?31,"-------------",?52,"-------------------------",!
"RTN","IBJDF2",165,0)
.;
"RTN","IBJDF2",166,0)
.I 'IB(IBDIV,IBTYP,9) W !,"There are no active receivables",$S(IBDIV:" for this division",1:""),"." D PAUSE Q
"RTN","IBJDF2",167,0)
.;
"RTN","IBJDF2",168,0)
.; - Primary loop to write results.
"RTN","IBJDF2",169,0)
.S Y=$P(IB(IBDIV,IBTYP,9),U,2) F I=1:1:9 S X=$P($T(CATN+I),";;",2,99) D
"RTN","IBJDF2",170,0)
..W:I=9 ! W !,X,?30,$J(+IB(IBDIV,IBTYP,I),6)
"RTN","IBJDF2",171,0)
..W " (",$J(+IB(IBDIV,IBTYP,I)/+IB(IBDIV,IBTYP,9)*100,0,$S(I=9:0,1:2)),"%)"
"RTN","IBJDF2",172,0)
..S Z=$FN($P(IB(IBDIV,IBTYP,I),U,2),",",2)
"RTN","IBJDF2",173,0)
..W ?52,$J($S(I=1!(I=9):"$",1:"")_Z,15)
"RTN","IBJDF2",174,0)
..W " (",$J($S('Y:0,1:$P(IB(IBDIV,IBTYP,I),U,2)/Y*100),0,$S(I=9:0,1:2)),"%)"
"RTN","IBJDF2",175,0)
.;
"RTN","IBJDF2",176,0)
.D PAUSE
"RTN","IBJDF2",177,0)
;
"RTN","IBJDF2",178,0)
SUMQ Q
"RTN","IBJDF2",179,0)
;
"RTN","IBJDF2",180,0)
DASH(X) ; - Return a dashed line.
"RTN","IBJDF2",181,0)
Q $TR($J("",X)," ","=")
"RTN","IBJDF2",182,0)
;
"RTN","IBJDF2",183,0)
PAUSE ; - Page break.
"RTN","IBJDF2",184,0)
I $E(IOST,1,2)'="C-" Q
"RTN","IBJDF2",185,0)
N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
"RTN","IBJDF2",186,0)
F IBX=$Y:1:(IOSL-3) W !
"RTN","IBJDF2",187,0)
S DIR(0)="E" D ^DIR I $D(DIRUT)!($D(DUOUT)) S IBQ=1
"RTN","IBJDF2",188,0)
Q
"RTN","IBJDF2",189,0)
;
"RTN","IBJDF2",190,0)
DHLP ; - 'Display Registration User' help.
"RTN","IBJDF2",191,0)
W !,"Enter <CR> to summarize all receivables without regard to division,"
"RTN","IBJDF2",192,0)
W !,"or YES to select those divisions for which a separate report should"
"RTN","IBJDF2",193,0)
W !,"be created."
"RTN","IBJDF2",194,0)
Q
"RTN","IBJDF2",195,0)
;
"RTN","IBJDF2",196,0)
CAT(X) ; - Determine category to place receivable.
"RTN","IBJDF2",197,0)
Q $S($G(X)<31:1,X<61:2,X<91:3,X<121:4,X<181:5,X<366:6,1:7)
"RTN","IBJDF2",198,0)
;
"RTN","IBJDF2",199,0)
ACT(X) ; - Determine the activation date for a receivable.
"RTN","IBJDF2",200,0)
N Y S Y=0 I '$G(X) G ACTQ
"RTN","IBJDF2",201,0)
S Y=$P($G(^PRCA(430,X,6)),U,21) I Y G ACTQ
"RTN","IBJDF2",202,0)
S Y=$P($G(^PRCA(430,X,9)),U,3) I Y G ACTQ
"RTN","IBJDF2",203,0)
S Y=$P($G(^PRCA(430,X,0)),U,10)
"RTN","IBJDF2",204,0)
ACTQ Q Y
"RTN","IBJDF2",205,0)
;
"RTN","IBJDF2",206,0)
DATE1(X) ; - Determine the Date of Care
"RTN","IBJDF2",207,0)
N Y S Y=0 I '$G(X) G DATEQ
"RTN","IBJDF2",208,0)
S Y=$P($G(^DGCR(399,X,"U")),U,2) I Y G DATEQ
"RTN","IBJDF2",209,0)
DATEQ Q Y
"RTN","IBJDF2",210,0)
;
"RTN","IBJDF2",211,0)
DIV(IBX) ; - Determine the division for a claim.
"RTN","IBJDF2",212,0)
; Input: IBX=Pointer to a claim in file #399
"RTN","IBJDF2",213,0)
; Output: IBY=Pointer to a division in file #40.8,
"RTN","IBJDF2",214,0)
; or 0 if not determined
"RTN","IBJDF2",215,0)
;
"RTN","IBJDF2",216,0)
N DFN,IBADM,IBEV,IBD,IBPTF,IBU,IBY,IBC,IBTY,VAINDT,VADMVT
"RTN","IBJDF2",217,0)
S IBY=0,IBC=$G(^DGCR(399,+$G(IBX),0)) I $P(IBC,U)="" G DIVQ
"RTN","IBJDF2",218,0)
S DFN=+$P(IBC,U,2),IBEV=+$P(IBC,U,3)\1,IBTY=$P(IBC,U,5)
"RTN","IBJDF2",219,0)
;
"RTN","IBJDF2",220,0)
S IBY=+$P(IBC,U,22) I +IBY G DIVQ ; use bill default division if defined
"RTN","IBJDF2",221,0)
;
"RTN","IBJDF2",222,0)
; - For Pharmacy or Prosthetics claims, use the primary division.
"RTN","IBJDF2",223,0)
I $D(^IBA(362.4,"AIFN"_IBX))!$D(^IBA(362.5,"AIFN"_IBX)) D G DIVQ
"RTN","IBJDF2",224,0)
.S IBY=$$PRIM^VASITE(DT) S:IBY'>0 IBY=0
"RTN","IBJDF2",225,0)
;
"RTN","IBJDF2",226,0)
; - Check all visit dates if outpatient claim.
"RTN","IBJDF2",227,0)
I IBTY>2 D G DIVQ
"RTN","IBJDF2",228,0)
.S IBY=$$OPT(IBEV,DFN) Q:IBY
"RTN","IBJDF2",229,0)
.S IBD=0 F S IBD=$O(^DGCR(399,IBX,"OP",IBD)) Q:'IBD S IBY=$$OPT(IBD,DFN) Q:IBY
"RTN","IBJDF2",230,0)
;
"RTN","IBJDF2",231,0)
; - Check inpatient claim.
"RTN","IBJDF2",232,0)
S IBPTF=+$P(IBC,U,8),IBU=$G(^DGCR(399,IBX,"U"))
"RTN","IBJDF2",233,0)
I IBPTF S IBADM=$O(^DGPM("APTF",IBPTF,0)) I IBADM S IBY=$$INP(IBADM) G:IBY DIVQ
"RTN","IBJDF2",234,0)
S VAINDT=+IBU\1_.23 D ADM^VADPT2 I VADMVT S IBY=$$INP(VADMVT) G:IBY DIVQ
"RTN","IBJDF2",235,0)
S VAINDT=$S($P(IBEV,".",2):IBEV,1:+IBEV\1_.23) D ADM^VADPT2 I VADMVT S IBY=$$INP(VADMVT)
"RTN","IBJDF2",236,0)
;
"RTN","IBJDF2",237,0)
DIVQ ; - If a division cannot be determined, use the primary division.
"RTN","IBJDF2",238,0)
I 'IBY S IBY=$$PRIM^VASITE(DT) S:IBY'>0 IBY=0
"RTN","IBJDF2",239,0)
Q IBY
"RTN","IBJDF2",240,0)
;
"RTN","IBJDF2",241,0)
INP(X) ; - Return division for a movement.
"RTN","IBJDF2",242,0)
Q +$P($G(^DIC(42,+$P($G(^DGPM(+$G(X),0)),U,6),0)),U,11)
"RTN","IBJDF2",243,0)
;
"RTN","IBJDF2",244,0)
OPT(X,DFN) ; - Return division for a patient's outpatient visit date.
"RTN","IBJDF2",245,0)
N IBFR,IBTO,IBY,IBY1,IBZ,IBZERR
"RTN","IBJDF2",246,0)
S IBY=0 I '$G(X) G OPTQ
"RTN","IBJDF2",247,0)
S IBFR=X,IBTO=X\1_".99"
"RTN","IBJDF2",248,0)
F S IBZ=$$EXOE^SDOE(DFN,IBFR,IBTO,,"IBZERR") K IBZERR Q:'IBZ S IBY1=$$SCE^IBSDU(IBZ) D Q:IBY
"RTN","IBJDF2",249,0)
.I $P(IBY1,U,11) S IBY=$P(IBY1,U,11) Q
"RTN","IBJDF2",250,0)
.S IBFR=IBY1+.000001
"RTN","IBJDF2",251,0)
OPTQ Q IBY
"RTN","IBJDF2",252,0)
;
"RTN","IBJDF2",253,0)
CATN ; - List of category names.
"RTN","IBJDF2",254,0)
;;Less than 30 days old
"RTN","IBJDF2",255,0)
;;31-60 days
"RTN","IBJDF2",256,0)
;;61-90 days
"RTN","IBJDF2",257,0)
;;91-120 days
"RTN","IBJDF2",258,0)
;;121-180 days
"RTN","IBJDF2",259,0)
;;181-365 days
"RTN","IBJDF2",260,0)
;;Over 365 days
"RTN","IBJDF2",261,0)
;;Referred to Regional Counsel
"RTN","IBJDF2",262,0)
;;Total Third Party Receivables
"RTN","IBJDF4")
0^12^B44100210
"RTN","IBJDF4",1,0)
IBJDF4 ;ALB/RB - FIRST PARTY FOLLOW-UP REPORT ;15-APR-00
"RTN","IBJDF4",2,0)
;;2.0;INTEGRATED BILLING;**123,204,220,568,618**;21-MAR-94;Build 60
"RTN","IBJDF4",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","IBJDF4",4,0)
;
"RTN","IBJDF4",5,0)
EN ; - Option entry point.
"RTN","IBJDF4",6,0)
S IBEXCEL=0
"RTN","IBJDF4",7,0)
N X,XX,I,CH,LAST
"RTN","IBJDF4",8,0)
K IBSUS
"RTN","IBJDF4",9,0)
S XX=$$GET1^DID(433,90,,"POINTER") ; current list of AR suspension types, fileman set of codes and descriptions
"RTN","IBJDF4",10,0)
F I=1:1 S CH=$P(XX,";",I) Q:CH="" S IBSUS($P(CH,":",1))=$P(CH,":",2)
"RTN","IBJDF4",11,0)
S LAST=$O(IBSUS(""),-1),IBSUS(LAST+1)="NONE"
"RTN","IBJDF4",12,0)
S LAST=LAST+2,IBSUS(LAST)="ALL OF THE ABOVE"
"RTN","IBJDF4",13,0)
;
"RTN","IBJDF4",14,0)
; - Select AR categories to print.
"RTN","IBJDF4",15,0)
S IBPRT="Choose which type of receivables to print:"
"RTN","IBJDF4",16,0)
K IBOPT
"RTN","IBJDF4",17,0)
S IBOPT(1)="EMERGENCY/HUMANITARIAN"
"RTN","IBJDF4",18,0)
S IBOPT(2)="INELIGIBLE"
"RTN","IBJDF4",19,0)
S IBOPT(3)="C-MEANS TEST & RX COPAY"
"RTN","IBJDF4",20,0)
S IBOPT(4)="LONG TERM CARE COPAY"
"RTN","IBJDF4",21,0)
S IBOPT(5)="COMMUNITY CARE COPAY"
"RTN","IBJDF4",22,0)
S IBOPT(6)="ALL OF THE ABOVE"
"RTN","IBJDF4",23,0)
S IBSEL=$$MLTP^IBJD(IBPRT,.IBOPT,1) I 'IBSEL G ENQ
"RTN","IBJDF4",24,0)
;
"RTN","IBJDF4",25,0)
STA ; - Choose bill status.
"RTN","IBJDF4",26,0)
W !!,"Run report for (A)CTIVE ARs, (S)USPENDED ARs, or (B)OTH: B// "
"RTN","IBJDF4",27,0)
R X:DTIME G:'$T!(X["^") ENQ S:X="" X="B" S X=$E(X)
"RTN","IBJDF4",28,0)
I "AaBbSs"'[X S IBOFF=1 D HELP^IBJDF4H G STA
"RTN","IBJDF4",29,0)
S IBSTA=$S("Aa"[X:"A","Ss"[X:"S",1:"B")
"RTN","IBJDF4",30,0)
W " ",$S(IBSTA="A":"ACTIVE",IBSTA="S":"SUSPENDED",1:"BOTH")
"RTN","IBJDF4",31,0)
;
"RTN","IBJDF4",32,0)
SUSTYP ;If SUSPENDED is chosen, prompt for which suspended bills to display IB*2.0*568/DRF
"RTN","IBJDF4",33,0)
I IBSTA="S" D
"RTN","IBJDF4",34,0)
. S IBPRT="Choose which suspended types to print:"
"RTN","IBJDF4",35,0)
. S IBSELST=$$MLTP0(IBPRT,.IBSUS,1)
"RTN","IBJDF4",36,0)
I IBSTA="S",IBSELST="" G ENQ
"RTN","IBJDF4",37,0)
;
"RTN","IBJDF4",38,0)
; - Select a detailed or summary report.
"RTN","IBJDF4",39,0)
D DS^IBJD G ENQ:IBRPT["^"
"RTN","IBJDF4",40,0)
I IBRPT="S" D G RC
"RTN","IBJDF4",41,0)
. S IBSN="N",IBSNA="ALL",IBSNF="",IBSNL="zzzzz",IBSMN="A"
"RTN","IBJDF4",42,0)
;
"RTN","IBJDF4",43,0)
; - Determine sorting (By name or Last 4 SSN)
"RTN","IBJDF4",44,0)
S IBSN=$$SNL^IBJD() G ENQ:IBSN="^"
"RTN","IBJDF4",45,0)
;
"RTN","IBJDF4",46,0)
; - Determine the range
"RTN","IBJDF4",47,0)
S X=$$INTV^IBJD("PATIENT "_$S(IBSN="N":"NAME",1:"LAST 4")) G ENQ:X="^"
"RTN","IBJDF4",48,0)
S IBSNF=$P(X,"^",1),IBSNL=$P(X,"^",2),IBSNA=$P(X,"^",3)
"RTN","IBJDF4",49,0)
;
"RTN","IBJDF4",50,0)
AGE ; - Determine if the active receivable must be within an age range.
"RTN","IBJDF4",51,0)
W !!,"Include (A)LL ",$S(IBSTA="A":"active ",IBSTA="S":"suspended ",1:""),"ARs or those within an AGE (R)ANGE: ALL// "
"RTN","IBJDF4",52,0)
R X:DTIME G:'$T!(X["^") ENQ S:X="" X="A" S X=$E(X)
"RTN","IBJDF4",53,0)
I "ARar"'[X S IBOFF=9 D HELP^IBJDF4H G AGE
"RTN","IBJDF4",54,0)
S IBSMN=$S("Rr"[X:"R",1:"A") W " ",$S(IBSMN="R":"RANGE",1:"ALL")
"RTN","IBJDF4",55,0)
I IBSMN="A" G AMT
"RTN","IBJDF4",56,0)
;
"RTN","IBJDF4",57,0)
; - Determine the active receivable age range.
"RTN","IBJDF4",58,0)
W !,"EXAMPLE Range: 31-60 days"
"RTN","IBJDF4",59,0)
S DIR(0)="NA^1:99999"
"RTN","IBJDF4",60,0)
S DIR("A")="Enter the minimum age of the receivable: "
"RTN","IBJDF4",61,0)
S DIR("T")=DTIME,DIR("?")="^S IBOFF=16 D HELP^IBJDF4H"
"RTN","IBJDF4",62,0)
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
"RTN","IBJDF4",63,0)
S IBSMN=+Y W " ",IBSMN," DAYS" K DIROUT,DTOUT,DUOUT,DIRUT
"RTN","IBJDF4",64,0)
;
"RTN","IBJDF4",65,0)
S DIR(0)="NA^"_IBSMN_":99999"
"RTN","IBJDF4",66,0)
S DIR("A")="Enter the maximum age of the receivable: "
"RTN","IBJDF4",67,0)
S DIR("B")=IBSMN,DIR("T")=DTIME,DIR("?")="^S IBOFF=21 D HELP^IBJDF4H"
"RTN","IBJDF4",68,0)
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
"RTN","IBJDF4",69,0)
S IBSMX=+Y W " ",IBSMX," DAYS" K DIROUT,DTOUT,DUOUT,DIRUT
"RTN","IBJDF4",70,0)
;
"RTN","IBJDF4",71,0)
AMT ; - Print receivables with a minimum balance.
"RTN","IBJDF4",72,0)
S DIR(0)="Y",DIR("B")="NO" W !
"RTN","IBJDF4",73,0)
S DIR("A")="Print receivables with a minimum balance"
"RTN","IBJDF4",74,0)
S DIR("T")=DTIME,DIR("?")="^S IBOFF=26 D HELP^IBJDF4H"
"RTN","IBJDF4",75,0)
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
"RTN","IBJDF4",76,0)
S IBSAM=+Y K DIROUT,DTOUT,DUOUT,DIRUT G:'IBSAM EXCEL
"RTN","IBJDF4",77,0)
;
"RTN","IBJDF4",78,0)
AMT1 ; - Determine the minimum balance amount.
"RTN","IBJDF4",79,0)
S DIR(0)="NA^1:9999999"
"RTN","IBJDF4",80,0)
S DIR("A")="Enter the minimum balance amount of the receivable: "
"RTN","IBJDF4",81,0)
S DIR("T")=DTIME,DIR("?")="^S IBOFF=33 D HELP^IBJDF4H"
"RTN","IBJDF4",82,0)
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
"RTN","IBJDF4",83,0)
S IBSAM=+Y K DIROUT,DTOUT,DUOUT,DIRUT
"RTN","IBJDF4",84,0)
;
"RTN","IBJDF4",85,0)
EXCEL ; - Determine whether to gather data for Excel report.
"RTN","IBJDF4",86,0)
S IBEXCEL=$$EXCEL^IBJD() G ENQ:IBEXCEL="^"
"RTN","IBJDF4",87,0)
I IBEXCEL S IBSH=1,IBSH1="M" G RC
"RTN","IBJDF4",88,0)
;
"RTN","IBJDF4",89,0)
BCH ; - Determine whether to include the bill comment history.
"RTN","IBJDF4",90,0)
S DIR(0)="Y",DIR("B")="NO" W !
"RTN","IBJDF4",91,0)
S DIR("A")="Include the bill comment history with each receivable"
"RTN","IBJDF4",92,0)
S DIR("T")=DTIME,DIR("?")="^S IBOFF=38 D HELP^IBJDF4H"
"RTN","IBJDF4",93,0)
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
"RTN","IBJDF4",94,0)
S IBSH=+Y K DIROUT,DTOUT,DUOUT,DIRUT G:'IBSH RC
"RTN","IBJDF4",95,0)
;
"RTN","IBJDF4",96,0)
S DIR(0)="SA^A:ALL;M:MOST RECENT"
"RTN","IBJDF4",97,0)
S DIR("A")="Print (A)LL comments or the (M)OST RECENT comment: "
"RTN","IBJDF4",98,0)
S DIR("B")="ALL",DIR("T")=DTIME,DIR("?")="^S IBOFF=47 D HELP^IBJDF4H"
"RTN","IBJDF4",99,0)
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
"RTN","IBJDF4",100,0)
S IBSH1=Y K DIROUT,DTOUT,DUOUT,DIRUT G:IBSH1="A" RC
"RTN","IBJDF4",101,0)
;
"RTN","IBJDF4",102,0)
S DIR(0)="NAO^1:999"
"RTN","IBJDF4",103,0)
S DIR("A")="Minimum age of most recent bill comment (optional): "
"RTN","IBJDF4",104,0)
S DIR("T")=DTIME,DIR("?")="^S IBOFF=54 D HELP^IBJDF4H"
"RTN","IBJDF4",105,0)
D ^DIR K DIR G:$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
"RTN","IBJDF4",106,0)
S IBSH2=+Y W:IBSH2 " days" K DIROUT,DTOUT,DUOUT
"RTN","IBJDF4",107,0)
;
"RTN","IBJDF4",108,0)
RC ; - Include receivables referred to Regional Counsel?
"RTN","IBJDF4",109,0)
S DIR(0)="Y",DIR("B")="NO",DIR("T")=DTIME W !
"RTN","IBJDF4",110,0)
S DIR("A")="Include ARs referred to Regional Counsel"
"RTN","IBJDF4",111,0)
S DIR("?")="^S IBOFF=61 D HELP^IBJDF4H"
"RTN","IBJDF4",112,0)
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
"RTN","IBJDF4",113,0)
S IBSRC=+Y K DIROUT,DTOUT,DUOUT,DIRUT
"RTN","IBJDF4",114,0)
;
"RTN","IBJDF4",115,0)
DEV ; - Select a device.
"RTN","IBJDF4",116,0)
I '$G(IBEXCEL) D
"RTN","IBJDF4",117,0)
. W !!,"Note: This report will search through all "
"RTN","IBJDF4",118,0)
. W $S(IBSTA="A":"active",IBSTA="S":"suspended",1:"active & suspended")," receivables."
"RTN","IBJDF4",119,0)
. W !?6,"It is recommended that you queue it to run after normal business hours."
"RTN","IBJDF4",120,0)
;
"RTN","IBJDF4",121,0)
I $G(IBEXCEL) D EXMSG^IBJD
"RTN","IBJDF4",122,0)
;
"RTN","IBJDF4",123,0)
W ! S %ZIS="QM" D ^%ZIS G:POP ENQ
"RTN","IBJDF4",124,0)
I $D(IO("Q")) D G ENQ
"RTN","IBJDF4",125,0)
.S ZTRTN="DQ^IBJDF4",ZTDESC="IB - FIRST PARTY FOLLOW-UP REPORT"
"RTN","IBJDF4",126,0)
.S ZTSAVE("IB*")="" D ^%ZTLOAD
"RTN","IBJDF4",127,0)
.I $G(ZTSK) W !!,"This job has been queued. The task no. is ",ZTSK,"."
"RTN","IBJDF4",128,0)
.E W !!,"Unable to queue this job."
"RTN","IBJDF4",129,0)
.K ZTSK,IO("Q") D HOME^%ZIS
"RTN","IBJDF4",130,0)
;
"RTN","IBJDF4",131,0)
U IO
"RTN","IBJDF4",132,0)
;
"RTN","IBJDF4",133,0)
; If called by the Extraction Module, change extract status for the 5
"RTN","IBJDF4",134,0)
; reports: Emergency/Humanitarian, Ineligible receivables, C-Means Test,
"RTN","IBJDF4",135,0)
; RX Copay/SC VET and RX Copay/NSC VET
"RTN","IBJDF4",136,0)
DQ I $G(IBXTRACT) F I=12:1:16 D E^IBJDE(I,1)
"RTN","IBJDF4",137,0)
;
"RTN","IBJDF4",138,0)
D ST^IBJDF41 ; Compile and print the report.
"RTN","IBJDF4",139,0)
;
"RTN","IBJDF4",140,0)
ENQ K IBSEL,IBSN,IBSNF,IBSNL,IBOFF,IBSNA,IBSH,IBSH1,IBSH2,IBSAM,IBSRC,IBTEXT
"RTN","IBJDF4",141,0)
K IBI,IBOPT,IBPRT,IBSTA,IBEXCEL,IBRPT,IBSMN,IBSMX,IBSELST,IBSUSTYP,POP,DIROUT,DTOUT,DUOUT
"RTN","IBJDF4",142,0)
K DIRUT,%ZIS,ZTDESC,ZTRTN,ZTSAVE,I,X,Y
"RTN","IBJDF4",143,0)
Q
"RTN","IBJDF4",144,0)
;
"RTN","IBJDF4",145,0)
MLTP0(PRPT,OPT,ALL) ; Function for multiple value selection
"RTN","IBJDF4",146,0)
; Input: PRPT - String to be prompted to the user, before listing options
"RTN","IBJDF4",147,0)
; OPT - Array containing the possible entries (indexed by code)
"RTN","IBJDF4",148,0)
; Obs: Code must be sequential starting with 0
"RTN","IBJDF4",149,0)
; ALL - Flag indicating if the last option is ALL OF THE ABOVE
"RTN","IBJDF4",150,0)
;
"RTN","IBJDF4",151,0)
; Output: MLTP - User selection, i.e. ",1,2,3," or "1," or NULL (nothing
"RTN","IBJDF4",152,0)
; was selected)
"RTN","IBJDF4",153,0)
;
"RTN","IBJDF4",154,0)
N A,DIR,DIRUT,DTOUT,DUOUT,DIROUT,I,IX,LST,MLTP
"RTN","IBJDF4",155,0)
;
"RTN","IBJDF4",156,0)
PRPT S MLTP="",ALL=+$G(ALL)
"RTN","IBJDF4",157,0)
S LST=$O(OPT(""),-1)
"RTN","IBJDF4",158,0)
S DIR(0)="LO^0:"_LST_"^K:+$P(X,""-"",2)>"_LST_" X"
"RTN","IBJDF4",159,0)
S DIR("A",1)=$G(PRPT),DIR("A",2)=""
"RTN","IBJDF4",160,0)
S A="",IX=3
"RTN","IBJDF4",161,0)
F S A=$O(OPT(A)) Q:A="" D
"RTN","IBJDF4",162,0)
. S DIR("A",IX)=" "_A_" - "_$G(OPT(A)),IX=IX+1
"RTN","IBJDF4",163,0)
S DIR("A",IX)="",DIR("A")="Select",DIR("B")=LST,DIR("T")=DTIME W !
"RTN","IBJDF4",164,0)
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G QT
"RTN","IBJDF4",165,0)
S MLTP=Y K DIROUT,DTOUT,DUOUT,DIRUT
"RTN","IBJDF4",166,0)
;
"RTN","IBJDF4",167,0)
I ALL,MLTP[LST S MLTP=LST_","
"RTN","IBJDF4",168,0)
;
"RTN","IBJDF4",169,0)
S DIR(0)="Y",DIR("A",1)="You have selected",DIR("A",2)=""
"RTN","IBJDF4",170,0)
S A="",IX=3
"RTN","IBJDF4",171,0)
F I=1:1:($L(MLTP,",")-1) D
"RTN","IBJDF4",172,0)
. S DIR("A",IX)=" "_$P(MLTP,",",I)_" - "_$G(OPT($P(MLTP,",",I)))
"RTN","IBJDF4",173,0)
. S IX=IX+1
"RTN","IBJDF4",174,0)
S DIR("A",IX)=""
"RTN","IBJDF4",175,0)
S DIR("A")="Are you sure",DIR("B")="NO",DIR("T")=DTIME W !
"RTN","IBJDF4",176,0)
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) S MLTP="" G QT
"RTN","IBJDF4",177,0)
K DIROUT,DTOUT,DUOUT,DIRUT I 'Y K DIR G PRPT
"RTN","IBJDF4",178,0)
;
"RTN","IBJDF4",179,0)
I ALL,MLTP[LST D
"RTN","IBJDF4",180,0)
. S MLTP="" F I=(LST-1):-1:0 S MLTP=I_","_MLTP
"RTN","IBJDF4",181,0)
;
"RTN","IBJDF4",182,0)
QT I MLTP'="" S MLTP=","_MLTP
"RTN","IBJDF4",183,0)
Q MLTP
"RTN","IBJDF41")
0^13^B109334634
"RTN","IBJDF41",1,0)
IBJDF41 ;ALB/RB - FIRST PARTY FOLLOW-UP REPORT (COMPILE) ;15-APR-00
"RTN","IBJDF41",2,0)
;;2.0;INTEGRATED BILLING;**123,159,204,356,451,473,568,618**;21-MAR-94;Build 60
"RTN","IBJDF41",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","IBJDF41",4,0)
;
"RTN","IBJDF41",5,0)
ST ; - Tasked entry point.
"RTN","IBJDF41",6,0)
K IB,IBCAT,^TMP("IBJDF4",$J)
"RTN","IBJDF41",7,0)
S IBQ=0
"RTN","IBJDF41",8,0)
;
"RTN","IBJDF41",9,0)
; - Set selected categories for report.
"RTN","IBJDF41",10,0)
I IBSEL[1 S IBCAT(2)=1
"RTN","IBJDF41",11,0)
I IBSEL[2 S IBCAT(1)=2
"RTN","IBJDF41",12,0)
I IBSEL[3 S IBCAT(18)=3 F X=22,23 S IBCAT(X)=3
"RTN","IBJDF41",13,0)
I IBSEL[4 F X=33:1:39 S IBCAT(X)=4
"RTN","IBJDF41",14,0)
; *** new code
"RTN","IBJDF41",15,0)
I IBSEL[5 D
"RTN","IBJDF41",16,0)
. F X=61:1:74 S IBCAT(X)=5
"RTN","IBJDF41",17,0)
. F X=81:1:84 S IBCAT(X)=5
"RTN","IBJDF41",18,0)
;
"RTN","IBJDF41",19,0)
; - Print the header line for the Excel spreadsheet
"RTN","IBJDF41",20,0)
I $G(IBEXCEL) D PHDL
"RTN","IBJDF41",21,0)
;
"RTN","IBJDF41",22,0)
; - Find data required for report.
"RTN","IBJDF41",23,0)
F IB=16,19,40 D G:IBQ ENQ
"RTN","IBJDF41",24,0)
. I IBSTA="A",IB'=16 Q ; Active AR's only.
"RTN","IBJDF41",25,0)
. I IBSTA="S",IB=16 Q ; Suspended AR's only.
"RTN","IBJDF41",26,0)
. I IB'=40 D
"RTN","IBJDF41",27,0)
. . S IBCAT=""
"RTN","IBJDF41",28,0)
. . F S IBCAT=$O(IBCAT(IBCAT)) Q:IBCAT="" D
"RTN","IBJDF41",29,0)
. . . D INIT^IBJDF43
"RTN","IBJDF41",30,0)
. S IBA=0
"RTN","IBJDF41",31,0)
. F S IBA=$O(^PRCA(430,"AC",IB,IBA)) Q:'IBA D Q:IBQ
"RTN","IBJDF41",32,0)
. . D PROC
"RTN","IBJDF41",33,0)
;
"RTN","IBJDF41",34,0)
I 'IBQ,'$G(IBEXCEL) D EN^IBJDF42 ; Print the report.
"RTN","IBJDF41",35,0)
;
"RTN","IBJDF41",36,0)
ENQ K ^TMP("IBJDF4",$J)
"RTN","IBJDF41",37,0)
I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
"RTN","IBJDF41",38,0)
;
"RTN","IBJDF41",39,0)
D ^%ZISC
"RTN","IBJDF41",40,0)
ENQ1 K IB,IB0,IBA,IBA1,IBADM,IBAGE,IBAR,IBAR1,IBBA,IBBN,IBBU,IBC,IBCAT,IBCAT1
"RTN","IBJDF41",41,0)
K IBELIG,IBEXCEL,IBFLG,IBAI,IBAIQ,IBIDX,IBIO,IBINT,IBN,IBPA,IBPD,IBPAT
"RTN","IBJDF41",42,0)
K IBPT,IBQ,IBRFD,IBRFT,IBSRC,IBRP,IBVA,COM,COM1,DAT,DFN,X,X1,X2,Y,Z
"RTN","IBJDF41",43,0)
Q
"RTN","IBJDF41",44,0)
;
"RTN","IBJDF41",45,0)
PROC ; - Process data for report(s).
"RTN","IBJDF41",46,0)
I IBA#100=0 D Q:IBQ
"RTN","IBJDF41",47,0)
. S IBQ=$$STOP^IBOUTL("First Party Follow-Up Report")
"RTN","IBJDF41",48,0)
S IBAR=$G(^PRCA(430,IBA,0)) I 'IBAR Q
"RTN","IBJDF41",49,0)
S IBCAT=+$P(IBAR,U,2) I '$D(IBCAT(IBCAT)) Q ; Get valid AR category.
"RTN","IBJDF41",50,0)
I '$$CLMACT^IBJD(IBA,IBCAT) Q ; Invalid IB claim/action.
"RTN","IBJDF41",51,0)
S IBSUSTYP=""
"RTN","IBJDF41",52,0)
I IB=40 S IBSUSTYP=$$SUST(IBA)
"RTN","IBJDF41",53,0)
I IBSTA="S",IBSELST'[(","_IBSUSTYP_",") Q ; Filter by suspended type IB*2*568/DRF
"RTN","IBJDF41",54,0)
S IBPT=$$PAT(IBA) I IBPT="" Q ; Get patient info.
"RTN","IBJDF41",55,0)
S DFN=$P(IBPT,U,2)
"RTN","IBJDF41",56,0)
S IBAGE=$$FMDIFF^XLFDT(DT,+$P(IBAR,U,10))
"RTN","IBJDF41",57,0)
I IBSMN,IBAGE<IBSMN!(IBAGE>IBSMX) Q ; AR outside age range.
"RTN","IBJDF41",58,0)
S IBVA=$$VA^IBJD1(DFN),IBBN=$P(IBAR,U),IBPD=$P($$PYMT^IBJD1(IBA),U)
"RTN","IBJDF41",59,0)
S IBPAT=$P(IBPT,U)_"@@"_DFN
"RTN","IBJDF41",60,0)
;
"RTN","IBJDF41",61,0)
; - Check the AR balance amounts, if necessary.
"RTN","IBJDF41",62,0)
S (IBADM,IBBA,IBINT,IBPA)=0,IBN=$G(^PRCA(430,IBA,7))
"RTN","IBJDF41",63,0)
F X=1:1:5 D
"RTN","IBJDF41",64,0)
. S IBBA=IBBA+$P(IBN,U,X)
"RTN","IBJDF41",65,0)
. S:X=1 IBPA=+IBN S:X=2 IBINT=$P(IBN,U,2) S:X=3 IBADM=$P(IBN,U,3)
"RTN","IBJDF41",66,0)
;
"RTN","IBJDF41",67,0)
I '$G(IBEXCEL) D EN^IBJDF43 I IBRPT="S" Q ; Get summary stats.
"RTN","IBJDF41",68,0)
;
"RTN","IBJDF41",69,0)
I IBSAM,IBBA<IBSAM Q
"RTN","IBJDF41",70,0)
;
"RTN","IBJDF41",71,0)
; - Check if AR was referred to R-Regional Counsel, D-DMC, T-TOP,
"RTN","IBJDF41",72,0)
; or C-CROSS SERVICING and exclude, if necessary.
"RTN","IBJDF41",73,0)
S IB0=$S(IB=40:19,1:IB),IBIDX=0,IBRFT=""
"RTN","IBJDF41",74,0)
S IBAIQ=0,IBAI=$G(^TMP("IBJDF4",$J,IBPAT,0,"A"))
"RTN","IBJDF41",75,0)
S IBRFD=$P($G(^PRCA(430,IBA,6)),U,4)
"RTN","IBJDF41",76,0)
I IBRPT="D",IBRFD D I IBAIQ Q ; Referred to RC
"RTN","IBJDF41",77,0)
. S IBRFT="R" I IBAI'["R" S IBAI=IBAI_"R"
"RTN","IBJDF41",78,0)
. I 'IBSRC S IBAIQ=1 Q
"RTN","IBJDF41",79,0)
. D SREF("R",IBRFD,IB0,,.IBIDX)
"RTN","IBJDF41",80,0)
S IBRFD=+$G(^PRCA(430,IBA,12))
"RTN","IBJDF41",81,0)
I IBRPT="D",IBRFD D ; Referred to DMC
"RTN","IBJDF41",82,0)
. S IBRFT=IBRFT_"D" I IBAI'["D" S IBAI=IBAI_"D"
"RTN","IBJDF41",83,0)
. D SREF("D",IBRFD,IB0,,.IBIDX)
"RTN","IBJDF41",84,0)
S IBRFD=+$G(^PRCA(430,IBA,14))
"RTN","IBJDF41",85,0)
I IBRPT="D",IBRFD D ; Referred to TOP
"RTN","IBJDF41",86,0)
. S IBRFT=IBRFT_"T" I IBAI'["T" S IBAI=IBAI_"T"
"RTN","IBJDF41",87,0)
. D SREF("T",IBRFD,IB0,,.IBIDX)
"RTN","IBJDF41",88,0)
; PRCA*4.5*338 added CS
"RTN","IBJDF41",89,0)
S IBRFD=+$G(^PRCA(430,IBA,15))
"RTN","IBJDF41",90,0)
I IBRPT="D",IBRFD D ; Referred to CS
"RTN","IBJDF41",91,0)
. S IBRFT=IBRFT_"C" I IBAI'["C" S IBAI=IBAI_"C"
"RTN","IBJDF41",92,0)
. D SREF("C",IBRFD,IB0,,.IBIDX)
"RTN","IBJDF41",93,0)
;
"RTN","IBJDF41",94,0)
; - Check if AR is on P-Repayment plan or F-Defaulted repayment plan.
"RTN","IBJDF41",95,0)
; and exclude if repayment plan is active.
"RTN","IBJDF41",96,0)
S IBRP=$$RP(IBA)
"RTN","IBJDF41",97,0)
I IBRP D
"RTN","IBJDF41",98,0)
. I IBRP=2 S IBRFT=IBRFT_"F" I IBAI'["F" S IBAI=IBAI_"F"
"RTN","IBJDF41",99,0)
. I IBRP=1 S IBRFT=IBRFT_"P" I IBAI'["P"&(IBAI'["F") S IBAI=IBAI_"P"
"RTN","IBJDF41",100,0)
. D SREF("P",$P(IBRP,"^",2),IB0,$S(+IBRP=2:1,1:0),.IBIDX)
"RTN","IBJDF41",101,0)
;
"RTN","IBJDF41",102,0)
I IBIDX S IBFLG=1
"RTN","IBJDF41",103,0)
;
"RTN","IBJDF41",104,0)
; - Check if VA Employee
"RTN","IBJDF41",105,0)
I $P(IBVA,"^")["*",IBAI'["V" S IBAI=IBAI_"V"
"RTN","IBJDF41",106,0)
;
"RTN","IBJDF41",107,0)
I IBAI'="" S ^TMP("IBJDF4",$J,IBPAT,0,"A")=IBAI
"RTN","IBJDF41",108,0)
;
"RTN","IBJDF41",109,0)
; IB*2.0*451 - Check for EEOB on associated 3rd party bills and attach EOB indicator '%' if applicable
"RTN","IBJDF41",110,0)
S IBBN=$$IBEEOBCK(IBBN,DFN)_IBBN ; Pass AR BILL#, Pat ID
"RTN","IBJDF41",111,0)
;
"RTN","IBJDF41",112,0)
; - Set up indexes for detail report.
"RTN","IBJDF41",113,0)
I $G(IBEXCEL) D Q
"RTN","IBJDF41",114,0)
. S IBEXCEL1=$P($G(^PRCA(430.2,IBCAT,0)),U,2)_U_$P(IBPT,U,3)_U_$P(IBVA,U)_U_$P(IBPT,U,4)_U_$$DT^IBJD($P(IBPT,U,6),1)_U_$$ELIG^IBJDF42(+$P(IBPT,U,5))_U
"RTN","IBJDF41",115,0)
. S IBEXCEL1=IBEXCEL1_$$GET1^DIQ(2,DFN,.381)_U_$$MTRX(DFN)_U_IBBN_U_$S(IB=16:"A",1:"S")_U_$S("BS"[IBSTA:$$ABBR($G(IBSUSTYP)),1:"")_U_IBRFT_U_$$DT^IBJD($P(IBAR,U,10),1)_U_$$DT^IBJD(IBPD,1)_U_IBBA_U_IBPA_U_IBINT_U_IBADM_U
"RTN","IBJDF41",116,0)
. I IBSH D COM
"RTN","IBJDF41",117,0)
. S IBD=0 I DAT!IBPD S IBD=$$FMDIFF^XLFDT(DT,$S('DAT:IBPD,1:$G(DAT)))
"RTN","IBJDF41",118,0)
. S IBEXCEL1=IBEXCEL1_U_IBD
"RTN","IBJDF41",119,0)
. W !,IBEXCEL1 K IBD,IBEXCEL1
"RTN","IBJDF41",120,0)
;
"RTN","IBJDF41",121,0)
I '($D(^TMP("IBJDF4",$J,IBPAT))#10) D
"RTN","IBJDF41",122,0)
. S ^TMP("IBJDF4",$J,IBPAT)=$P(IBPT,U,3,5)_U_$$MTRX(DFN)_U_$P(IBPT,U,6)_"^"_$P(IBVA,"^",2)_"^"_$$ACCBAL($P(IBPT,U,7))
"RTN","IBJDF41",123,0)
S ^TMP("IBJDF4",$J,IBPAT,IB0,IBCAT,IBBN)=IBPD_U_IBBA_U_IBPA_U_IBINT_U_IBADM_U_IBIDX_U_$S($D(IBSUSTYP):IBSUSTYP,1:"")
"RTN","IBJDF41",124,0)
;
"RTN","IBJDF41",125,0)
I IBSH D COM
"RTN","IBJDF41",126,0)
Q
"RTN","IBJDF41",127,0)
;
"RTN","IBJDF41",128,0)
ACCBAL(DFN) ; Calculates the Account Balance for the Bill
"RTN","IBJDF41",129,0)
; Input: DFN - Patient/Debtor internal number
"RTN","IBJDF41",130,0)
; Output: BAL - Patient/Debtor Account Balance
"RTN","IBJDF41",131,0)
;
"RTN","IBJDF41",132,0)
N B0,B7,BAL,BILL,I
"RTN","IBJDF41",133,0)
S (BAL,BILL)=0
"RTN","IBJDF41",134,0)
F S BILL=$O(^PRCA(430,"C",DFN,BILL)) Q:BILL="" D
"RTN","IBJDF41",135,0)
. S B0=$G(^PRCA(430,BILL,0)) I $P(B0,"^",8)'=16 Q
"RTN","IBJDF41",136,0)
. S B7=$G(^PRCA(430,BILL,7))
"RTN","IBJDF41",137,0)
. F I=1:1:5 S BAL=BAL+$P(B7,"^",I)
"RTN","IBJDF41",138,0)
Q BAL
"RTN","IBJDF41",139,0)
;
"RTN","IBJDF41",140,0)
PHDL ; - Print the header line for the Excel spreadsheet
"RTN","IBJDF41",141,0)
N X
"RTN","IBJDF41",142,0)
S X="Cat^Patient^VA Empl.?^SSN^Dt Death^Prim.Elig.^Med.Elig.?^"
"RTN","IBJDF41",143,0)
S X=X_"Means Tst Sts^Means Tst Dt^RX Copay Exemp.Sts^RX Copay Exemp.Dt^"
"RTN","IBJDF41",144,0)
S X=X_"Bill #^Act/Susp^Reason^Refer. to^Dt Bill prep.^Last Pymt Dt^" ;Added reason IB*2*568/DRF
"RTN","IBJDF41",145,0)
S X=X_"Curr.Bal.^Princ.Bal.^Int.^Admin.^Last Comm.Dt^Days Lst Comm.^"
"RTN","IBJDF41",146,0)
W !,X
"RTN","IBJDF41",147,0)
Q
"RTN","IBJDF41",148,0)
;
"RTN","IBJDF41",149,0)
PAT(X) ; - Find the AR patient and decide to include the AR.
"RTN","IBJDF41",150,0)
; Input: X=AR pointer to file #430 and pre-set variables IBS*
"RTN","IBJDF41",151,0)
; Output: Y=Sort key (name or last 4) ^ Patient pointer to file #2
"RTN","IBJDF41",152,0)
; ^ Name ^ SSN ^ Eligibilities ^ Date of death (if any)
"RTN","IBJDF41",153,0)
; ^ Debtor pointer to file #340
"RTN","IBJDF41",154,0)
N PAT,KEY,DBTR,DFN,DEATH,NAME,SSN,VAEL,VADM,X1,X2
"RTN","IBJDF41",155,0)
S PAT="" G:'$G(X) PATQ
"RTN","IBJDF41",156,0)
S DBTR=+$P($G(^PRCA(430,X,0)),U,9)
"RTN","IBJDF41",157,0)
S X1=$P($G(^RCD(340,DBTR,0)),U) G:X1'["DPT" PATQ
"RTN","IBJDF41",158,0)
S DFN=+X1 G:'DFN PATQ D DEM^VADPT
"RTN","IBJDF41",159,0)
S NAME=VADM(1),SSN=$P(VADM(2),"^"),DEATH=VADM(6)\1
"RTN","IBJDF41",160,0)
S KEY=$S(IBSN="N":NAME,1:$E(SSN,6,9))
"RTN","IBJDF41",161,0)
I KEY=""!(IBSNF'="@"&('DFN)) G PATQ
"RTN","IBJDF41",162,0)
I $D(IBSNA) G:IBSNA="ALL"&('DFN) PATQ G:IBSNA="NULL"&(DFN) PATQ
"RTN","IBJDF41",163,0)
I $G(IBSNA)="ALL" G PATC
"RTN","IBJDF41",164,0)
I IBSNF="@",IBSNL="zzzzz" G PATC
"RTN","IBJDF41",165,0)
I IBSNF'=KEY,IBSNF]KEY G PATQ
"RTN","IBJDF41",166,0)
I IBSNL'=KEY,KEY]IBSNL G PATQ
"RTN","IBJDF41",167,0)
;
"RTN","IBJDF41",168,0)
PATC ; - Set patient eligibilities.
"RTN","IBJDF41",169,0)
D ELIG^VADPT S X2=+$G(VAEL(1))_";"
"RTN","IBJDF41",170,0)
I +X2 S X1=0 F S X1=$O(VAEL(1,X1)) Q:'X1 S X2=X2_X1_";"
"RTN","IBJDF41",171,0)
;
"RTN","IBJDF41",172,0)
S PAT=KEY_U_DFN_U_$E(NAME,1,26)_U_SSN_U_X2_U_DEATH
"RTN","IBJDF41",173,0)
S PAT=PAT_U_DBTR
"RTN","IBJDF41",174,0)
PATQ Q PAT
"RTN","IBJDF41",175,0)
;
"RTN","IBJDF41",176,0)
RP(X) ; - Check if claim/receivable is under a repayment plan.
"RTN","IBJDF41",177,0)
; Input: X=Bill pointer to file #399/#430
"RTN","IBJDF41",178,0)
; Output: 0-Not on repay plan, 1-On repay plan, 2-On defaulted plan
"RTN","IBJDF41",179,0)
N Z
"RTN","IBJDF41",180,0)
S Z=$$REPDATA^RCBECHGA(X,1) I Z="" Q 0
"RTN","IBJDF41",181,0)
I '$P(Z,"^",7) Q ("1^"_$P(Z,"^"))
"RTN","IBJDF41",182,0)
Q ("2^"_$P(Z,"^"))
"RTN","IBJDF41",183,0)
;
"RTN","IBJDF41",184,0)
MTRX(X) ; - Return patient's means test and/or RX copay status and most recent
"RTN","IBJDF41",185,0)
; test dates for both.
"RTN","IBJDF41",186,0)
; Input: X=Patient pointer to file #2 and opt. variable IBEXCEL
"RTN","IBJDF41",187,0)
; Output: Y=Means test status ^ Date ^ RX copay status ^ Date
"RTN","IBJDF41",188,0)
N MTST,RXST,Y
"RTN","IBJDF41",189,0)
S Y="^^^",MTST=$$LST^DGMTU(X),RXST=$$RXST^IBARXEU(X)
"RTN","IBJDF41",190,0)
I '$G(IBEXCEL) D
"RTN","IBJDF41",191,0)
. S $P(Y,"^",1,2)=$P(MTST,"^",3)_"^"_$$DAT1^IBOUTL($P(MTST,"^",2))
"RTN","IBJDF41",192,0)
. S $P(Y,"^",3)=$S('RXST:"NON-EXEMPT",+RXST=1:"EXEMPT",1:"")
"RTN","IBJDF41",193,0)
. I $P(Y,"^",3)'="" S $P(Y,"^",4)=$$DAT1^IBOUTL($P(RXST,"^",5))
"RTN","IBJDF41",194,0)
I $G(IBEXCEL) D
"RTN","IBJDF41",195,0)
. S $P(Y,"^",1,2)=$P(MTST,"^",4)_"^"_$$DT^IBJD($P(MTST,"^",2),1)
"RTN","IBJDF41",196,0)
. S $P(Y,"^",3)=$S('RXST:"M",+RXST=1:"E",1:"")
"RTN","IBJDF41",197,0)
. I $P(Y,"^",3)'="" S $P(Y,"^",4)=$$DT^IBJD($P(RXST,"^",5),1)
"RTN","IBJDF41",198,0)
Q Y
"RTN","IBJDF41",199,0)
;
"RTN","IBJDF41",200,0)
SREF(RFT,DAT,STS,DEF,IDX) ; Set the "referred to" information on the
"RTN","IBJDF41",201,0)
; temporary global ^TMP
"RTN","IBJDF41",202,0)
;Input: RFT: "R": RC, "D": DMC, "T": TOP, "C": CROSS SERVICING, "P": REPAYMENT PLAN
"RTN","IBJDF41",203,0)
; DAT: Date it was referred/established
"RTN","IBJDF41",204,0)
; STS: Receivable status (16-Active,19-Suspended)
"RTN","IBJDF41",205,0)
; DEF: Repayment Plan in Default? (1 - YES, 0 - NO)
"RTN","IBJDF41",206,0)
; IDX: Subscript to be set in the Temporary global ^TMP
"RTN","IBJDF41",207,0)
;Output: IDX: Subscript set in the Temporary global ^TMP
"RTN","IBJDF41",208,0)
;
"RTN","IBJDF41",209,0)
N SREF,IDX1
"RTN","IBJDF41",210,0)
S DEF=+$G(DEF),IDX=+$G(IDX)
"RTN","IBJDF41",211,0)
I RFT="R" S SREF="REFERRED TO RC"
"RTN","IBJDF41",212,0)
I RFT="D" S SREF="REFERRED TO DMC"
"RTN","IBJDF41",213,0)
I RFT="T" S SREF="REFERRED TO TOP"
"RTN","IBJDF41",214,0)
I RFT="C" S SREF="REFERRED TO CS" ; PRCA*4.5*338
"RTN","IBJDF41",215,0)
I RFT="P" D
"RTN","IBJDF41",216,0)
. S SREF="REPAYMENT PLAN ESTABLISHED"
"RTN","IBJDF41",217,0)
. I $G(DEF) S SREF=SREF_" (CURRENTLY IN DEFAULT)"
"RTN","IBJDF41",218,0)
;
"RTN","IBJDF41",219,0)
I 'IDX S IDX=$O(^TMP("IBJDF4",$J,IBPAT,0,"C",STS,""),-1)+1
"RTN","IBJDF41",220,0)
S IDX1=$O(^TMP("IBJDF4",$J,IBPAT,0,"C",STS,IDX,""),-1)+1
"RTN","IBJDF41",221,0)
S ^TMP("IBJDF4",$J,IBPAT,0,"C",STS,IDX,IDX1)=DAT
"RTN","IBJDF41",222,0)
S ^TMP("IBJDF4",$J,IBPAT,0,"C",STS,IDX,IDX1,1)=SREF
"RTN","IBJDF41",223,0)
Q
"RTN","IBJDF41",224,0)
;
"RTN","IBJDF41",225,0)
COM ; - Get bill comments.
"RTN","IBJDF41",226,0)
I 'IBIDX,'$G(IBEXCEL) D
"RTN","IBJDF41",227,0)
. S IBFLG=0,IBIDX=$O(^TMP("IBJDF4",$J,IBPAT,0,"C",IB0,""),-1)+1
"RTN","IBJDF41",228,0)
;
"RTN","IBJDF41",229,0)
S DAT=0,IBA1=$S(IBSH1="M":999999999,1:0)
"RTN","IBJDF41",230,0)
F S IBA1=$S(IBSH1="M":$O(^PRCA(433,"C",IBA,IBA1),-1),1:$O(^PRCA(433,"C",IBA,IBA1))) Q:'IBA1 D I IBSH1="M",DAT Q
"RTN","IBJDF41",231,0)
. S IBC=$G(^PRCA(433,IBA1,1)) Q:'IBC
"RTN","IBJDF41",232,0)
. I $G(IBSH2),$$FMDIFF^XLFDT(DT,+IBC)>IBSH2 Q ; Comment age not minimum.
"RTN","IBJDF41",233,0)
. I $P(IBC,U,2)'=35,$P(IBC,U,2)'=45 Q ; Not decrease/comment transact.
"RTN","IBJDF41",234,0)
. S DAT=$S(IBC:+IBC\1,1:+$P(IBC,U,9)\1)
"RTN","IBJDF41",235,0)
. I $G(IBEXCEL),IBSH1="M" S IBEXCEL1=IBEXCEL1_$$DT^IBJD(DAT,1) Q
"RTN","IBJDF41",236,0)
. ;
"RTN","IBJDF41",237,0)
. ; - Append brief and transaction comments.
"RTN","IBJDF41",238,0)
. K COM,COM1 S COM(0)=DAT,X1=0
"RTN","IBJDF41",239,0)
. S COM1(1)=$P($G(^PRCA(433,IBA1,5)),U,2)
"RTN","IBJDF41",240,0)
. S COM1(2)=$E($P($G(^PRCA(433,IBA1,8)),U,6),1,70)
"RTN","IBJDF41",241,0)
. S COM(1)=COM1(1)_$S(COM1(1)]""&(COM1(2)]""):"|",1:"")_COM1(2)
"RTN","IBJDF41",242,0)
. I COM(1)]"" S COM(1)="**"_COM(1)_"**",X1=1
"RTN","IBJDF41",243,0)
. ;
"RTN","IBJDF41",244,0)
. ; - Get main comments.
"RTN","IBJDF41",245,0)
. S X2=0
"RTN","IBJDF41",246,0)
. F S X2=$O(^PRCA(433,IBA1,7,X2)) Q:'X2 D
"RTN","IBJDF41",247,0)
. . S COM($S(X1:X2+1,1:X2))=^PRCA(433,IBA1,7,X2,0)
"RTN","IBJDF41",248,0)
. ;
"RTN","IBJDF41",249,0)
. I $G(IBEXCEL) Q
"RTN","IBJDF41",250,0)
. ;
"RTN","IBJDF41",251,0)
. S IBFLG=1,^TMP("IBJDF4",$J,IBPAT,0,"C",IB0,IBIDX,IBA1)=$G(COM(0)),X1=0
"RTN","IBJDF41",252,0)
. F S X1=$O(COM(X1)) Q:X1="" D
"RTN","IBJDF41",253,0)
. . S ^TMP("IBJDF4",$J,IBPAT,0,"C",IB0,IBIDX,IBA1,X1)=COM(X1)
"RTN","IBJDF41",254,0)
;
"RTN","IBJDF41",255,0)
I '$G(IBEXCEL),IBFLG D
"RTN","IBJDF41",256,0)
. S $P(^TMP("IBJDF4",$J,IBPAT,IB0,IBCAT,IBBN),"^",6)=IBIDX
"RTN","IBJDF41",257,0)
Q
"RTN","IBJDF41",258,0)
; IB*2.0*451 - Use Event Date to find an associated 3rd Party bill with an associated EEOB
"RTN","IBJDF41",259,0)
IBEEOBCK(IBBN,DFN) ; Passed AR Bill, Patient ID
"RTN","IBJDF41",260,0)
; Function will quit as soon as a 3rd party bill is located that has an associated EEOB
"RTN","IBJDF41",261,0)
;
"RTN","IBJDF41",262,0)
; Find 3rd Party Bills with an Event Date
"RTN","IBJDF41",263,0)
N IBREF,IBEEOB,IBDT
"RTN","IBJDF41",264,0)
S IBEEOB=""
"RTN","IBJDF41",265,0)
; Loop through Xref of ARbill (#430) to Action file (#350)
"RTN","IBJDF41",266,0)
I +$G(IBBN) S IBREF=0 F S IBREF=$O(^IB("ABIL",IBBN,IBREF)) Q:'IBREF D Q:IBEEOB="%"
"RTN","IBJDF41",267,0)
. S IBDT=$P($G(^IB(IBREF,0)),"^",17) ;Get event Date
"RTN","IBJDF41",268,0)
. I IBDT S IBEEOB=$$TPEVDT(DFN,IBDT)
"RTN","IBJDF41",269,0)
. I IBDT S IBEEOB=$$TPOPV(DFN,IBDT)
"RTN","IBJDF41",270,0)
;
"RTN","IBJDF41",271,0)
Q IBEEOB
"RTN","IBJDF41",272,0)
;
"RTN","IBJDF41",273,0)
; IB*2.0*451 - Traverse all THIRD PARTY bills for a patient with a specific Event Date (399,.03)
"RTN","IBJDF41",274,0)
TPEVDT(DFN,EVDT) ;
"RTN","IBJDF41",275,0)
; Function will quit as soon as a 3rd party bill is located that has an associated EEOB
"RTN","IBJDF41",276,0)
; IB*2.0*473 - Use the 399,"APDT" (by patient) index instead of the 399,"D" index for efficiency
"RTN","IBJDF41",277,0)
I '$G(DFN)!'$G(EVDT) Q ""
"RTN","IBJDF41",278,0)
N IBIFN,IBEEOB
"RTN","IBJDF41",279,0)
S IBEEOB="",IBIFN=""
"RTN","IBJDF41",280,0)
F S IBIFN=$O(^DGCR(399,"APDT",DFN,IBIFN),-1) Q:'IBIFN D Q:IBEEOB="%"
"RTN","IBJDF41",281,0)
. I $D(^DGCR(399,"APDT",DFN,IBIFN,9999999-EVDT)) S IBEEOB=$$EEOBCK(IBIFN)
"RTN","IBJDF41",282,0)
Q IBEEOB
"RTN","IBJDF41",283,0)
;
"RTN","IBJDF41",284,0)
; IB*2.0*451 - Traverse all THIRD PARTY bills for a patient with any Opt Visit Dates same as Event Date (399,43)
"RTN","IBJDF41",285,0)
TPOPV(DFN,EVDT) ;
"RTN","IBJDF41",286,0)
; Function will quit as soon as a 3rd party bill is located that has an associated EEOB
"RTN","IBJDF41",287,0)
N IBIFN,IBEEOB
"RTN","IBJDF41",288,0)
S IBEEOB=""
"RTN","IBJDF41",289,0)
I +$G(DFN),+$G(EVDT) S IBIFN=0 F S IBIFN=$O(^DGCR(399,"AOPV",DFN,EVDT,IBIFN)) Q:'IBIFN D Q:IBEEOB="%"
"RTN","IBJDF41",290,0)
. ; attach EOB indicator '%' to bill # when applicable
"RTN","IBJDF41",291,0)
. S IBEEOB=$$EEOBCK(IBIFN)
"RTN","IBJDF41",292,0)
Q IBEEOB
"RTN","IBJDF41",293,0)
;
"RTN","IBJDF41",294,0)
; IB*2.0*451 - Check for EEOB indicator
"RTN","IBJDF41",295,0)
EEOBCK(IBBILL) ;
"RTN","IBJDF41",296,0)
; Check for 1st and 3rd party payment activity on bill
"RTN","IBJDF41",297,0)
; IBBILL is the IEN for the bill # in files #399/#430 and must be valid,
"RTN","IBJDF41",298,0)
; check the EOB type and exclude it if it is an MRA. Otherwise,
"RTN","IBJDF41",299,0)
; returns the EEOB indicator '%' if payment activity was found.
"RTN","IBJDF41",300,0)
; Access to file #361.1 covered by IA #4051.
"RTN","IBJDF41",301,0)
; Access to file #399 covered by IA #3820.
"RTN","IBJDF41",302,0)
N IBOUT,IBVAL,Z
"RTN","IBJDF41",303,0)
I $G(IBBILL)=0 Q ""
"RTN","IBJDF41",304,0)
I '$O(^IBM(361.1,"B",IBBILL,0)) Q "" ; no entry here
"RTN","IBJDF41",305,0)
I $P($G(^DGCR(399,IBBILL,0)),"^",13)=1 Q "" ;avoid 'ENTERED/NOT REVIEWED' status
"RTN","IBJDF41",306,0)
; handle both single and multiple bill entries in file #361.1
"RTN","IBJDF41",307,0)
S Z=0 F S Z=$O(^IBM(361.1,"B",IBBILL,Z)) Q:'Z D Q:$G(IBOUT)="%"
"RTN","IBJDF41",308,0)
. S IBVAL=$G(^IBM(361.1,Z,0))
"RTN","IBJDF41",309,0)
. S IBOUT=$S($P(IBVAL,"^",4)=1:"",$P(IBVAL,"^",4)=0:"%",1:"")
"RTN","IBJDF41",310,0)
Q IBOUT ; EOB indicator for either 1st or 3rd party payment on bill
"RTN","IBJDF41",311,0)
;
"RTN","IBJDF41",312,0)
;
"RTN","IBJDF41",313,0)
SUST(IBA) ;Look for suspended type for a suspended bill IB*2*568/DRF
"RTN","IBJDF41",314,0)
N TRANS,ST
"RTN","IBJDF41",315,0)
S IBA=$G(IBA) I IBA="" Q ""
"RTN","IBJDF41",316,0)
S ST=""
"RTN","IBJDF41",317,0)
S TRANS=$O(^PRCA(433,"C",IBA,""),-1)
"RTN","IBJDF41",318,0)
S ST=$P($G(^PRCA(433,TRANS,1)),U,11)
"RTN","IBJDF41",319,0)
I ST="" S ST=12 ;Added option for NONE
"RTN","IBJDF41",320,0)
Q ST
"RTN","IBJDF41",321,0)
;
"RTN","IBJDF41",322,0)
;
"RTN","IBJDF41",323,0)
ABBR(SUSP) ;Return abbreviation for suspended bill types IB*2*568/DRF
"RTN","IBJDF41",324,0)
S SUSP=$G(SUSP)
"RTN","IBJDF41",325,0)
I SUSP=0 Q "NonCoS"
"RTN","IBJDF41",326,0)
I SUSP=1 Q "IniCoS"
"RTN","IBJDF41",327,0)
I SUSP=2 Q "AplCoW"
"RTN","IBJDF41",328,0)
I SUSP=3 Q "AdminS"
"RTN","IBJDF41",329,0)
I SUSP=4 Q "Compro"
"RTN","IBJDF41",330,0)
I SUSP=5 Q "Termin"
"RTN","IBJDF41",331,0)
I SUSP=6 Q "BnkCh7"
"RTN","IBJDF41",332,0)
I SUSP=7 Q "BnkC13"
"RTN","IBJDF41",333,0)
I SUSP=8 Q "BnkOth"
"RTN","IBJDF41",334,0)
I SUSP=9 Q "Probat"
"RTN","IBJDF41",335,0)
I SUSP=10 Q "Choice"
"RTN","IBJDF41",336,0)
I SUSP=11 Q "Disput"
"RTN","IBJDF41",337,0)
I SUSP=12 Q "None"
"RTN","IBJDF41",338,0)
Q ""
"RTN","IBJDF42")
0^14^B65167304
"RTN","IBJDF42",1,0)
IBJDF42 ;ALB/RB - FIRST PARTY FOLLOW-UP REPORT (PRINT);15-APR-00
"RTN","IBJDF42",2,0)
;;2.0;INTEGRATED BILLING;**123,204,568,618**;21-MAR-94;Build 60
"RTN","IBJDF42",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","IBJDF42",4,0)
;
"RTN","IBJDF42",5,0)
EN ; - Print the Follow-up report.
"RTN","IBJDF42",6,0)
;
"RTN","IBJDF42",7,0)
S IBCT(1)="INELIGIBLE",IBCT(2)="EMERG/HUMAN.",IBCT(18)="C MEANS TEST"
"RTN","IBJDF42",8,0)
S IBCT(22)="RX COPAY/SC",IBCT(23)="RX COPAY/NSC"
"RTN","IBJDF42",9,0)
S IBCT(33)="ADHC LTC"
"RTN","IBJDF42",10,0)
S IBCT(34)="DOM LTC"
"RTN","IBJDF42",11,0)
S IBCT(35)="RESPITE INPT LTC"
"RTN","IBJDF42",12,0)
S IBCT(36)="RESPITE OPT LTC"
"RTN","IBJDF42",13,0)
S IBCT(37)="GERIATRIC INPT LTC"
"RTN","IBJDF42",14,0)
S IBCT(38)="GERIATRIC OPT LTC"
"RTN","IBJDF42",15,0)
S IBCT(39)="NURSING HOME LTC"
"RTN","IBJDF42",16,0)
;
"RTN","IBJDF42",17,0)
; PRCA*4.5*338 Adding new categories for community care
"RTN","IBJDF42",18,0)
;
"RTN","IBJDF42",19,0)
; next are the new AR categories
"RTN","IBJDF42",20,0)
S IBCT(61)="CHOICE INPT"
"RTN","IBJDF42",21,0)
S IBCT(62)="CHOICE RX CO-PAYMENT"
"RTN","IBJDF42",22,0)
S IBCT(63)="CC INPT"
"RTN","IBJDF42",23,0)
S IBCT(64)="CC RX CO-PAYMENT"
"RTN","IBJDF42",24,0)
S IBCT(65)="CCN INPT"
"RTN","IBJDF42",25,0)
S IBCT(66)="CCN RX CO-PAYMENT"
"RTN","IBJDF42",26,0)
S IBCT(67)="CC MTF INPT"
"RTN","IBJDF42",27,0)
S IBCT(68)="CC MTF RX CO-PAYMENT"
"RTN","IBJDF42",28,0)
S IBCT(69)="CC NURSING HOME CARE - LTC"
"RTN","IBJDF42",29,0)
S IBCT(70)="CC RESPITE CARE"
"RTN","IBJDF42",30,0)
S IBCT(71)="CCN NURSING HOME CARE - LTC"
"RTN","IBJDF42",31,0)
S IBCT(72)="CCN RESPITE CARE"
"RTN","IBJDF42",32,0)
S IBCT(73)="CHOICE NURSING HOME CARE - LTC"
"RTN","IBJDF42",33,0)
S IBCT(74)="CHOICE RESPITE CARE"
"RTN","IBJDF42",34,0)
S IBCT(81)="CHOICE OPT"
"RTN","IBJDF42",35,0)
S IBCT(82)="CC OPT"
"RTN","IBJDF42",36,0)
S IBCT(83)="CCN OPT"
"RTN","IBJDF42",37,0)
S IBCT(84)="CC MTF OPT"
"RTN","IBJDF42",38,0)
;
"RTN","IBJDF42",39,0)
S IBQ=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%) G:IBRPT="S" SUM
"RTN","IBJDF42",40,0)
S IBPRTFLG=0 D DET D PAUSE:'IBPRTFLG I IBQ!'IBPRTFLG G ENQ
"RTN","IBJDF42",41,0)
;
"RTN","IBJDF42",42,0)
D PAUSE I IBQ G ENQ
"RTN","IBJDF42",43,0)
;
"RTN","IBJDF42",44,0)
SUM I 'IBQ D PRT^IBJDF43 ; Print summary.
"RTN","IBJDF42",45,0)
ENQ K IB0,IBAI,IBC,IBCAT,IBCD,IBC1,IBC2,IBCT,IBCNT,IBN,IBP,IBPAG,IBQ,IBRUN,IBS
"RTN","IBJDF42",46,0)
K IBST,IBTOT,%,DFN,IBPRTFLG
"RTN","IBJDF42",47,0)
Q
"RTN","IBJDF42",48,0)
;
"RTN","IBJDF42",49,0)
DET ; - Print report for a specific category.
"RTN","IBJDF42",50,0)
;
"RTN","IBJDF42",51,0)
D HDR1 G:IBQ DETQ
"RTN","IBJDF42",52,0)
S (IBPT,IB,IBCAT,IB0)=""
"RTN","IBJDF42",53,0)
F S IBPT=$O(^TMP("IBJDF4",$J,IBPT)) Q:IBPT="" D Q:IBQ
"RTN","IBJDF42",54,0)
. I $O(^TMP("IBJDF4",$J,IBPT,0))="" Q
"RTN","IBJDF42",55,0)
. S IBP=$G(^TMP("IBJDF4",$J,IBPT))
"RTN","IBJDF42",56,0)
. I $Y>(IOSL-14) D PAUSE Q:IBQ D HDR1 Q:IBQ
"RTN","IBJDF42",57,0)
. D WPAT
"RTN","IBJDF42",58,0)
. F IB=16,19 D Q:IBQ
"RTN","IBJDF42",59,0)
. . I IBSTA="A",IB'=16 Q
"RTN","IBJDF42",60,0)
. . I IBSTA="S",IB=16 Q
"RTN","IBJDF42",61,0)
. . I '$D(^TMP("IBJDF4",$J,IBPT,IB)) D Q
"RTN","IBJDF42",62,0)
. . . I $Y>(IOSL-5) D PAUSE Q:IBQ D HDR1,WPAT,HDR2 Q:IBQ
"RTN","IBJDF42",63,0)
. . . W !,"-> NO "_$S(IB=16:"ACTIVE",1:"SUSPENDED")_" BILLS."
"RTN","IBJDF42",64,0)
. . I $Y>(IOSL-9) D PAUSE Q:IBQ D HDR1,WPAT Q:IBQ
"RTN","IBJDF42",65,0)
. . D HDR2
"RTN","IBJDF42",66,0)
. . K IBFLG S IBTOT="",IBCNT=0
"RTN","IBJDF42",67,0)
. . F S IBCAT=$O(^TMP("IBJDF4",$J,IBPT,IB,IBCAT)) Q:IBCAT="" D Q:IBQ
"RTN","IBJDF42",68,0)
. . . F S IB0=$O(^TMP("IBJDF4",$J,IBPT,IB,IBCAT,IB0)) Q:IB0="" D Q:IBQ
"RTN","IBJDF42",69,0)
. . . . S IBN=$G(^TMP("IBJDF4",$J,IBPT,IB,IBCAT,IB0))
"RTN","IBJDF42",70,0)
. . . . I $Y>(IOSL-5) D PAUSE Q:IBQ D HDR1,WPAT,HDR2 Q:IBQ
"RTN","IBJDF42",71,0)
. . . . D WBIL Q:IBQ
"RTN","IBJDF42",72,0)
. . . . S IBCNT=IBCNT+1
"RTN","IBJDF42",73,0)
. . . I 'IBQ,$O(^TMP("IBJDF4",$J,IBPT,IB,IBCAT))="" D
"RTN","IBJDF42",74,0)
. . . . D TOT W !
"RTN","IBJDF42",75,0)
. . ; - Display bill comment history, if selected.
"RTN","IBJDF42",76,0)
. . S IBPRTFLG=1
"RTN","IBJDF42",77,0)
. . D WCOM(IBPT,IB)
"RTN","IBJDF42",78,0)
;
"RTN","IBJDF42",79,0)
I 'IBPRTFLG D
"RTN","IBJDF42",80,0)
. W !!!!!!,"There are no receivables for the parameters entered."
"RTN","IBJDF42",81,0)
;
"RTN","IBJDF42",82,0)
DETQ Q
"RTN","IBJDF42",83,0)
;
"RTN","IBJDF42",84,0)
WPAT ; - Write patient data.
"RTN","IBJDF42",85,0)
N I,X
"RTN","IBJDF42",86,0)
S DFN=$P(IBPT,"@@",2),IBAI=$G(^TMP("IBJDF4",$J,IBPT,0,"A"))
"RTN","IBJDF42",87,0)
W !!,"Patient Name : ",$P(IBP,U) W:IBAI["V" " *"
"RTN","IBJDF42",88,0)
W ?63,"SSN: ",$$SSN($P(IBP,U,2)),!,"Means Test Status: ",$P(IBP,U,4)
"RTN","IBJDF42",89,0)
W:$P(IBP,U,5)'="" " ("_$P(IBP,U,5)_")"
"RTN","IBJDF42",90,0)
W ?58,"Medicaid: ",$$GET1^DIQ(2,DFN,.381)
"RTN","IBJDF42",91,0)
W !,"RX Copay Status : ",$P(IBP,U,6)
"RTN","IBJDF42",92,0)
W:$P(IBP,U,7)'="" " ("_$P(IBP,U,7)_")"
"RTN","IBJDF42",93,0)
W:$P(IBP,U,8) ?53,"Date of Death: ",$$DAT1^IBOUTL($P(IBP,U,8))
"RTN","IBJDF42",94,0)
W !,"Eligibilities : " S X=$$ELIG($P(IBP,U,3))
"RTN","IBJDF42",95,0)
F I=1:1 Q:X="" W ?19,$E(X,1,61) S X=$E(X,62,999) I X'="" W !
"RTN","IBJDF42",96,0)
S X=$$INFO(IBAI)
"RTN","IBJDF42",97,0)
I X'="" D
"RTN","IBJDF42",98,0)
. W !,"Additional Info : "
"RTN","IBJDF42",99,0)
. F I=1:1 Q:X="" W ?19,$E(X,1,61) S X=$E(X,62,999) I X'="" W !
"RTN","IBJDF42",100,0)
;
"RTN","IBJDF42",101,0)
Q
"RTN","IBJDF42",102,0)
;
"RTN","IBJDF42",103,0)
WBIL ; - Write bill data.
"RTN","IBJDF42",104,0)
W ! W:'$D(IBFLG(IBCAT)) $E(IBCT(IBCAT),1,11) W ?13,IB0 ;IB*2.0*618 - Limit length to 11 chars
"RTN","IBJDF42",105,0)
W:$P(IBN,"^",6) ?25,$J("("_$P(IBN,"^",6)_")",4)
"RTN","IBJDF42",106,0)
W ?30,$$DAT1^IBOUTL(+IBN)
"RTN","IBJDF42",107,0)
W ?39,$J($FN($P(IBN,U,2),",",2),10),?50,$J($FN($P(IBN,U,3),",",2),10)
"RTN","IBJDF42",108,0)
W ?61,$J($FN($P(IBN,U,4),",",2),9),?71,$J($FN($P(IBN,U,5),",",2),9)
"RTN","IBJDF42",109,0)
I "SB"[IBSTA,$P(IBN,U,7)]"" W ?82,IBSUS($P(IBN,U,7))
"RTN","IBJDF42",110,0)
S $P(IBTOT,"^")=$P(IBTOT,"^")+$P(IBN,U,2)
"RTN","IBJDF42",111,0)
S $P(IBTOT,"^",2)=$P(IBTOT,"^",2)+$P(IBN,U,3)
"RTN","IBJDF42",112,0)
S $P(IBTOT,"^",3)=$P(IBTOT,"^",3)+$P(IBN,U,4)
"RTN","IBJDF42",113,0)
S $P(IBTOT,"^",4)=$P(IBTOT,"^",4)+$P(IBN,U,5)
"RTN","IBJDF42",114,0)
S IBFLG(IBCAT)=""
"RTN","IBJDF42",115,0)
Q
"RTN","IBJDF42",116,0)
;
"RTN","IBJDF42",117,0)
WCOM(IBPT,IB) ; - Write bill comments.
"RTN","IBJDF42",118,0)
N CMDT,CONT,DIWL,DIWR,IBIDX,IBTR,IBLN,IBX,X
"RTN","IBJDF42",119,0)
;
"RTN","IBJDF42",120,0)
S (IBIDX,IBTR,IBLN)="",DIWL=1,DIWR=64 K ^UTILITY($J,"W")
"RTN","IBJDF42",121,0)
F S IBIDX=$O(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX)) Q:IBIDX="" D Q:IBQ
"RTN","IBJDF42",122,0)
. I $Y>(IOSL-6) D WCPB Q:IBQ
"RTN","IBJDF42",123,0)
. D WCD(IBIDX)
"RTN","IBJDF42",124,0)
. F S IBTR=$O(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX,IBTR)) Q:IBTR="" D Q:IBQ
"RTN","IBJDF42",125,0)
. . S CMDT=$G(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX,IBTR))
"RTN","IBJDF42",126,0)
. . I $Y>(IOSL-4) D WCPB Q:IBQ
"RTN","IBJDF42",127,0)
. . S CONT=0 D WCD(,1,)
"RTN","IBJDF42",128,0)
. . F S IBLN=$O(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX,IBTR,IBLN)) Q:IBLN="" D Q:IBQ
"RTN","IBJDF42",129,0)
. . . S IBX=$G(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX,IBTR,IBLN))
"RTN","IBJDF42",130,0)
. . . I $E(IBX)=" ",$L(IBX)>1 S $E(IBX)=""
"RTN","IBJDF42",131,0)
. . . S X=IBX D ^DIWP
"RTN","IBJDF42",132,0)
. . . I 'CONT,$L(IBX)<66 D WCTX
"RTN","IBJDF42",133,0)
. . . S CONT=$L(IBX)>65
"RTN","IBJDF42",134,0)
. . . I '$O(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX,IBTR,IBLN)) D
"RTN","IBJDF42",135,0)
. . . . D:$D(^UTILITY($J,"W")) WCTX
"RTN","IBJDF42",136,0)
K ^UTILITY($J,"W")
"RTN","IBJDF42",137,0)
Q
"RTN","IBJDF42",138,0)
;
"RTN","IBJDF42",139,0)
WCD(I,D,C) ; - Write the comment date.
"RTN","IBJDF42",140,0)
; Input: I - Index # "(I)"
"RTN","IBJDF42",141,0)
; D - Print the Date " - MM/DD/YY"
"RTN","IBJDF42",142,0)
; C - Print the Cont. "(Continued)"
"RTN","IBJDF42",143,0)
;
"RTN","IBJDF42",144,0)
W:$G(I) !,"(",I,")" W:$G(D) ?3," - ",$$DAT1^IBOUTL(CMDT),": "
"RTN","IBJDF42",145,0)
W:$G(C) "(Continued)",!
"RTN","IBJDF42",146,0)
Q
"RTN","IBJDF42",147,0)
;
"RTN","IBJDF42",148,0)
WCTX ; - Write the comment text.
"RTN","IBJDF42",149,0)
N LIN,WLIN,Z
"RTN","IBJDF42",150,0)
S LIN=""
"RTN","IBJDF42",151,0)
F S LIN=$O(^UTILITY($J,"W",1,LIN)) Q:LIN="" D Q:IBQ
"RTN","IBJDF42",152,0)
. S WLIN=$G(^UTILITY($J,"W",1,LIN,0)) Q:WLIN=""
"RTN","IBJDF42",153,0)
. W ?16,WLIN
"RTN","IBJDF42",154,0)
. I '$O(^UTILITY($J,"W",1,LIN)) W ! Q
"RTN","IBJDF42",155,0)
. I $Y>(IOSL-4) D WCPB,WCD(IBIDX,1,1) Q
"RTN","IBJDF42",156,0)
. W !
"RTN","IBJDF42",157,0)
K ^UTILITY($J,"W")
"RTN","IBJDF42",158,0)
Q
"RTN","IBJDF42",159,0)
;
"RTN","IBJDF42",160,0)
WCPB ; - Page Break in the middle of the Comments
"RTN","IBJDF42",161,0)
D PAUSE Q:IBQ D HDR1,WPAT W !!
"RTN","IBJDF42",162,0)
Q
"RTN","IBJDF42",163,0)
;
"RTN","IBJDF42",164,0)
HDR1 ; - Write the report header.
"RTN","IBJDF42",165,0)
N X,I
"RTN","IBJDF42",166,0)
W:'$G(IBPAG) ! I $E(IOST,1,2)="C-"!$G(IBPAG) W @IOF,*13
"RTN","IBJDF42",167,0)
S IBPAG=$G(IBPAG)+1 W "First Party Follow-Up Report"
"RTN","IBJDF42",168,0)
W ?34,"Run Date: ",IBRUN,?71,"Page: ",$J(IBPAG,3)
"RTN","IBJDF42",169,0)
S X="ALL "_$S(IBSTA'="S":"ACTIVE",1:"")_$S(IBSTA="B":" AND ",1:"")
"RTN","IBJDF42",170,0)
S X=X_$S(IBSTA'="A":"SUSPENDED",1:"")_" RECEIVABLES"
"RTN","IBJDF42",171,0)
I IBSMN'="A" S X=X_" OVER "_IBSMN_" AND UNDER "_IBSMX_" DAYS OLD"
"RTN","IBJDF42",172,0)
S X=X_" / BY "_$S(IBSN="N":"NAME",1:"LAST 4 SSN")
"RTN","IBJDF42",173,0)
S X=X_" ("_$S($G(IBSNA)="ALL":"ALL",1:"From "_$S(IBSNF="":"FIRST",1:IBSNF)_" to "_$S(IBSNL="zzzzz":"LAST",1:IBSNL))_")"
"RTN","IBJDF42",174,0)
S X=X_" / "_$S('IBSAM:"NO ",1:"")_"MINIMUM BALANCE"
"RTN","IBJDF42",175,0)
S X=X_$S(IBSAM:": $"_$FN(IBSAM,",",2),1:"")
"RTN","IBJDF42",176,0)
S X=X_" / "_$S('IBSH:"NO ",IBSH1="A":"ALL ",1:"ONLY ")_"COMMENTS"
"RTN","IBJDF42",177,0)
S X=X_$S($G(IBSH2):" LESS THAN "_IBSH2_" DAYS OLD",1:"")
"RTN","IBJDF42",178,0)
S X=X_" / RECEIVABLES REFERRED TO RC "_$S('IBSRC:"NOT ",1:"")_"INCLUDED"
"RTN","IBJDF42",179,0)
F I=1:1 W !,$E(X,1,80) S X=$E(X,81,999) I X="" Q
"RTN","IBJDF42",180,0)
;
"RTN","IBJDF42",181,0)
S IBQ=$$STOP^IBOUTL("First Party Follow-Up Report")
"RTN","IBJDF42",182,0)
Q
"RTN","IBJDF42",183,0)
;
"RTN","IBJDF42",184,0)
TYPE(SEL) ; Returns a string with the type of receivables (description)
"RTN","IBJDF42",185,0)
; selected or NULL if ALL receivable type have been selected.
"RTN","IBJDF42",186,0)
; SEL - User input for the parameter "Type of Receivable"
"RTN","IBJDF42",187,0)
;
"RTN","IBJDF42",188,0)
N TYPE,I,X
"RTN","IBJDF42",189,0)
I SEL="1,2,3," Q ""
"RTN","IBJDF42",190,0)
S TYPE="",X="EMERGENCY/HUMANITARIAN^INELIGIBLE^C-MEANS TEST & RX COPAY"
"RTN","IBJDF42",191,0)
F I=2:1:($L(SEL,",")-1) D
"RTN","IBJDF42",192,0)
. S TYPE=TYPE_$S(I=($L(SEL,",")-1)&(TYPE'=""):" AND ",1:", ")
"RTN","IBJDF42",193,0)
. S TYPE=TYPE_$P(X,"^",+$P(SEL,",",I))
"RTN","IBJDF42",194,0)
S $E(TYPE,1)=""
"RTN","IBJDF42",195,0)
;
"RTN","IBJDF42",196,0)
Q TYPE
"RTN","IBJDF42",197,0)
;
"RTN","IBJDF42",198,0)
HDR2 ; - Write bill sub-header.
"RTN","IBJDF42",199,0)
W ! I IBSTA="B" W !,$S(IB=16:"ACTIVE",1:"SUSPENDED")
"RTN","IBJDF42",200,0)
W ! I IBSTA="B" W $S(IB=16:"======",1:"=========")
"RTN","IBJDF42",201,0)
W:IBSH ?26,"COM" W ?30,"Last",?40,"Current",?51,"Principal"
"RTN","IBJDF42",202,0)
W !,"Category",?13,"Bill Number",?26,"REF"
"RTN","IBJDF42",203,0)
W ?30,"Payment",?40,"Balance",?51,"Balance",?62,"Interest",?72,"Admin."
"RTN","IBJDF42",204,0)
I "BS"[IBSTA W ?82,"Suspended Type"
"RTN","IBJDF42",205,0)
W !,$$DASH(96,1)
"RTN","IBJDF42",206,0)
Q
"RTN","IBJDF42",207,0)
;
"RTN","IBJDF42",208,0)
TOT ; - Write balance total for patient.
"RTN","IBJDF42",209,0)
N I,J
"RTN","IBJDF42",210,0)
I IBCNT>1 W ! F I=40,51,62,72 W ?I,$E("---------",1,$S(I>60:8,1:9))
"RTN","IBJDF42",211,0)
W:IBCNT'>1 !
"RTN","IBJDF42",212,0)
W !,"Account Balance: $"_$FN($P(IBP,"^",10),",",2)
"RTN","IBJDF42",213,0)
I IBCNT'>1 Q
"RTN","IBJDF42",214,0)
S J=1 F I=39,50,60,70 W ?I,$J($FN($P(IBTOT,"^",J),",",2),10) S J=J+1
"RTN","IBJDF42",215,0)
Q
"RTN","IBJDF42",216,0)
;
"RTN","IBJDF42",217,0)
DASH(X,Y) ; - Return a dashed line.
"RTN","IBJDF42",218,0)
Q $TR($J("",X)," ",$S(Y:"-",1:"="))
"RTN","IBJDF42",219,0)
;
"RTN","IBJDF42",220,0)
ELIG(X) ; - Return eligibility code name.
"RTN","IBJDF42",221,0)
; X - Eligibility codes separated by semi-collon (;)
"RTN","IBJDF42",222,0)
;
"RTN","IBJDF42",223,0)
N ELIG,I
"RTN","IBJDF42",224,0)
S ELIG="" F I=1:1:$L(X,";") D
"RTN","IBJDF42",225,0)
. I '$P(X,";",I) Q
"RTN","IBJDF42",226,0)
. S ELIG=ELIG_", "_$E($P($G(^DIC(8,+$P(X,";",I),0)),U),1,20)
"RTN","IBJDF42",227,0)
S $E(ELIG,1,2)=""
"RTN","IBJDF42",228,0)
;
"RTN","IBJDF42",229,0)
Q ELIG
"RTN","IBJDF42",230,0)
;
"RTN","IBJDF42",231,0)
INFO(X) ; - Return the patient Additional Information about the Patient Accout
"RTN","IBJDF42",232,0)
; X - Flags representing the observations
"RTN","IBJDF42",233,0)
;
"RTN","IBJDF42",234,0)
N INFO,I
"RTN","IBJDF42",235,0)
S INFO="" F I=1:1:$L(X) D
"RTN","IBJDF42",236,0)
. I $E(X,I)="V" S INFO=INFO_", '*' - VA EMPLOYEE"
"RTN","IBJDF42",237,0)
. I $E(X,I)="R" S INFO=INFO_", REFERRED TO RC"
"RTN","IBJDF42",238,0)
. I $E(X,I)="D" S INFO=INFO_", REFERRED TO DMC"
"RTN","IBJDF42",239,0)
. I $E(X,I)="T" S INFO=INFO_", REFERRED TO TOP"
"RTN","IBJDF42",240,0)
. I $E(X,I)="P" S INFO=INFO_", UNDER REPAYMENT PLAN"
"RTN","IBJDF42",241,0)
. I $E(X,I)="F" S INFO=INFO_", UNDER DEFAULTED REPAYMENT PLAN"
"RTN","IBJDF42",242,0)
S $E(INFO,1,2)=""
"RTN","IBJDF42",243,0)
;
"RTN","IBJDF42",244,0)
Q INFO
"RTN","IBJDF42",245,0)
;
"RTN","IBJDF42",246,0)
SSN(X) ; - Format the SSN.
"RTN","IBJDF42",247,0)
Q $S(X]"":$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),1:"")
"RTN","IBJDF42",248,0)
;
"RTN","IBJDF42",249,0)
PAUSE ; - Page break.
"RTN","IBJDF42",250,0)
I $E(IOST,1,2)'="C-" Q
"RTN","IBJDF42",251,0)
N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
"RTN","IBJDF42",252,0)
F IBX=$Y:1:(IOSL-3) W !
"RTN","IBJDF42",253,0)
S DIR(0)="E" D ^DIR S:$D(DIRUT)!($D(DUOUT)) IBQ=1
"RTN","IBJDF42",254,0)
Q
"RTN","IBJDF51")
0^15^B60268800
"RTN","IBJDF51",1,0)
IBJDF51 ;ALB/RB - CHAMPVA/TRICARE FOLLOW-UP REPORT (COMPILE) ;15-APR-00
"RTN","IBJDF51",2,0)
;;2.0;INTEGRATED BILLING;**123,185,240,356,452,516,618**;21-MAR-94;Build 60
"RTN","IBJDF51",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","IBJDF51",4,0)
;
"RTN","IBJDF51",5,0)
ST ; - Tasked entry point.
"RTN","IBJDF51",6,0)
K IB,^TMP("IBJDF5",$J) S IBQ=0
"RTN","IBJDF51",7,0)
;
"RTN","IBJDF51",8,0)
; - Set selected categories for report.
"RTN","IBJDF51",9,0)
I IBSEL[1 S IBCAT(31)=1
"RTN","IBJDF51",10,0)
I IBSEL[2 S IBCAT(19)=2
"RTN","IBJDF51",11,0)
; IB*2.0*618 - Add new TriCare Categories
"RTN","IBJDF51",12,0)
I IBSEL[3 D
"RTN","IBJDF51",13,0)
. S IBCAT(30)=3
"RTN","IBJDF51",14,0)
. F IBI=75:1:80 S IBCAT(IBI)=3
"RTN","IBJDF51",15,0)
I IBSEL[4 S IBCAT(32)=4
"RTN","IBJDF51",16,0)
I IBSEL[5 S IBCAT(29)=5
"RTN","IBJDF51",17,0)
I IBSEL[6 S IBCAT(28)=6
"RTN","IBJDF51",18,0)
;
"RTN","IBJDF51",19,0)
; Initialize the Summary Information
"RTN","IBJDF51",20,0)
S IBCAT="" F S IBCAT=$O(IBCAT(IBCAT)) Q:IBCAT="" D
"RTN","IBJDF51",21,0)
. S IBDIV=0
"RTN","IBJDF51",22,0)
. I IBSD,IBCAT'=31 D Q
"RTN","IBJDF51",23,0)
. . F S IBDIV=$O(VAUTD(IBDIV)) Q:IBDIV="" D INIT^IBJDF53
"RTN","IBJDF51",24,0)
. D INIT^IBJDF53
"RTN","IBJDF51",25,0)
;
"RTN","IBJDF51",26,0)
; - Print the header line for the Excel spreadsheet
"RTN","IBJDF51",27,0)
I $G(IBEXCEL) D PHDL
"RTN","IBJDF51",28,0)
;
"RTN","IBJDF51",29,0)
; - Find data required for the report.
"RTN","IBJDF51",30,0)
S IBA=0 F S IBA=$O(^PRCA(430,"AC",16,IBA)) Q:'IBA D Q:IBQ
"RTN","IBJDF51",31,0)
. I IBA#100=0 D Q:IBQ
"RTN","IBJDF51",32,0)
. . S IBQ=$$STOP^IBOUTL("CHAMPVA/TRICARE Follow-Up Report")
"RTN","IBJDF51",33,0)
. S IBAR=$G(^PRCA(430,IBA,0)) Q:'IBAR
"RTN","IBJDF51",34,0)
. I $P($G(^DGCR(399,IBA,0)),U,13)=7 Q ; Cancelled claim.
"RTN","IBJDF51",35,0)
. S IBCAT=+$P(IBAR,U,2) Q:'$D(IBCAT(IBCAT)) ; Invalid AR category.
"RTN","IBJDF51",36,0)
. S IBCAT1=IBCAT(IBCAT)
"RTN","IBJDF51",37,0)
. ;
"RTN","IBJDF51",38,0)
. ; - Get division, if necessary.
"RTN","IBJDF51",39,0)
. I IBCAT1=1 S IBDIV=0 ; CHAMPVA/TRICARE Patient
"RTN","IBJDF51",40,0)
. ;
"RTN","IBJDF51",41,0)
. I IBCAT1'=1 D ; Others
"RTN","IBJDF51",42,0)
. . I 'IBSD S IBDIV=0 Q
"RTN","IBJDF51",43,0)
. . S IBDIV=$$DIV(IBA)
"RTN","IBJDF51",44,0)
. ;
"RTN","IBJDF51",45,0)
. I IBSD,IBDIV,'VAUTD Q:'$D(VAUTD(IBDIV)) ; Not a selected division.
"RTN","IBJDF51",46,0)
. ;
"RTN","IBJDF51",47,0)
. ; - Determine whether AR has corresponding IB action or claim and
"RTN","IBJDF51",48,0)
. ; whether action/claim is inpatient, outpatient, or RX refill.
"RTN","IBJDF51",49,0)
. S IBAC=$$CLMACT^IBJD(IBA,IBCAT) Q:IBAC=""!(+IBAC=3)
"RTN","IBJDF51",50,0)
. I +IBAC=1 D
"RTN","IBJDF51",51,0)
. . S X=$P($G(^IB($P(IBAC,U,2),0)),U,3)
"RTN","IBJDF51",52,0)
. . S X=$P($G(^IBE(350.1,X,0)),U)
"RTN","IBJDF51",53,0)
. . S IBTYP=$S(X["RX":3,X["OPT":2,1:1)
"RTN","IBJDF51",54,0)
. I +IBAC'=1 D
"RTN","IBJDF51",55,0)
. . S IBTYP=$S($P($G(^DGCR(399,IBA,0)),U,5)>2:2,1:1)
"RTN","IBJDF51",56,0)
. . I $D(^IBA(362.4,"C",IBA)) S IBTYP=3
"RTN","IBJDF51",57,0)
. ;
"RTN","IBJDF51",58,0)
. I IBSEL1'[IBTYP,IBSEL1'[4 Q
"RTN","IBJDF51",59,0)
. ;
"RTN","IBJDF51",60,0)
. I IBRPT="D" S IBPT=$$PAT(IBA) Q:IBPT="" ; Get patient info.
"RTN","IBJDF51",61,0)
. ;
"RTN","IBJDF51",62,0)
. I '$G(IBEXCEL) D EN^IBJDF53 Q:IBRPT="S" ; Get stats for summary.
"RTN","IBJDF51",63,0)
. ;
"RTN","IBJDF51",64,0)
. ; - Get insurance info.
"RTN","IBJDF51",65,0)
. S (IBI,IBIN)=0
"RTN","IBJDF51",66,0)
. I $G(^DGCR(399,IBA,"MP")) D I 'IBI Q
"RTN","IBJDF51",67,0)
. . S IBI=+$G(^DGCR(399,IBA,"MP")) I 'IBI S IBIN="*** UNKNOWN ***" Q
"RTN","IBJDF51",68,0)
. . S IBIN=$P($G(^DIC(36,IBI,0)),U)_"@@"_IBI
"RTN","IBJDF51",69,0)
. ;
"RTN","IBJDF51",70,0)
. ; - Check the receivable age, if necessary.
"RTN","IBJDF51",71,0)
. I IBSMN D Q:IBARD<IBSMN!(IBARD>IBSMX)
"RTN","IBJDF51",72,0)
. . S IBARD=+$$ACT^IBJDF2(IBA) S:IBARD IBARD=$$FMDIFF^XLFDT(DT,IBARD)
"RTN","IBJDF51",73,0)
. ;
"RTN","IBJDF51",74,0)
. ; - Check the minimum balance amount, if necessary.
"RTN","IBJDF51",75,0)
. S IBBA=0 F X=1:1:5 S IBBA=IBBA+$P($G(^PRCA(430,IBA,7)),U,X)
"RTN","IBJDF51",76,0)
. I IBSAM,IBBA<IBSAM Q
"RTN","IBJDF51",77,0)
. ;
"RTN","IBJDF51",78,0)
. ; - Get remaining AR/claim information.
"RTN","IBJDF51",79,0)
. S IBDP=$P(IBAR,U,10),X=$$CLMACT^IBJD(IBA,IBCAT) Q:X=""
"RTN","IBJDF51",80,0)
. S IBBU=$S(+IBAC=1:$G(^IB($P(IBAC,U,2),0)),1:$G(^DGCR(399,IBA,"U")))
"RTN","IBJDF51",81,0)
. S IBFR=$P(IBBU,U,$S(+IBAC=1:14,1:1))
"RTN","IBJDF51",82,0)
. S IBTO=$P(IBBU,U,$S(+IBAC=1:15,1:2))
"RTN","IBJDF51",83,0)
. S DFN=$P(IBPT,U,5),IBSID=$$SID(DFN,IBI)
"RTN","IBJDF51",84,0)
. S IBOI=$$OTH(DFN,IBI,IBFR),IBVA=$$VA^IBJD1(DFN)
"RTN","IBJDF51",85,0)
. S IBBN=$P(IBAR,U),IBOR=$P(IBAR,U,3)
"RTN","IBJDF51",86,0)
. ;
"RTN","IBJDF51",87,0)
. ; - Set up indexes for detail report.
"RTN","IBJDF51",88,0)
. I $G(IBEXCEL) D Q
"RTN","IBJDF51",89,0)
. . S IBDIV=$P($G(^DG(40.8,$S('IBDIV:+$$PRIM^VASITE(),1:IBDIV),0)),U)
"RTN","IBJDF51",90,0)
. . ;
"RTN","IBJDF51",91,0)
. . S IBEXCEL1=$P(IBPT,U,2)_U_IBVA_U_$P(IBPT,U,3)_U_$TR($P(IBPT,U,4),"-")
"RTN","IBJDF51",92,0)
. . S IBEXCEL1=IBEXCEL1_U_$S(IBIN=0:"",1:$E($P(IBIN,"@@"),1,12))_U_$E(IBOI,1,12)
"RTN","IBJDF51",93,0)
. . S IBEXCEL1=IBEXCEL1_U_$$DT^IBJD(IBDP,1)_U_$$DT^IBJD(IBFR,1)
"RTN","IBJDF51",94,0)
. . S IBEXCEL1=IBEXCEL1_U_$$DT^IBJD(IBTO,1)_U_IBSID_U_IBBN_U_IBOR
"RTN","IBJDF51",95,0)
. . S IBEXCEL1=IBEXCEL1_U_IBBA_U_$P($G(^PRCA(430.2,IBCAT,0)),U,2)
"RTN","IBJDF51",96,0)
. . S IBEXCEL1=IBEXCEL1_U_$E("IOR",IBTYP)_U
"RTN","IBJDF51",97,0)
. . I IBSH D COM ; This will capture the Last Comment Date
"RTN","IBJDF51",98,0)
. . S IBD=$$FMDIFF^XLFDT(DT,$S('$P(IBEXCEL1,U,16):IBDP,1:$G(DAT)))
"RTN","IBJDF51",99,0)
. . S IBEXCEL1=IBEXCEL1_U_IBD_U_$E(IBDIV,1,12) W !,IBEXCEL1 K IBD,IBEXCEL1
"RTN","IBJDF51",100,0)
. ;
"RTN","IBJDF51",101,0)
. S IBKEY=$P(IBPT,U)_"@@"_$S($G(IBPT):IBDP,1:IBFR_"/"_IBTO)
"RTN","IBJDF51",102,0)
. F X=IBTYP,4 I IBSEL1[X D
"RTN","IBJDF51",103,0)
. . I '($D(^TMP("IBJDF5",$J,IBDIV,IBCAT,X,IBIN,IBKEY))#10) D
"RTN","IBJDF51",104,0)
. . . S ^TMP("IBJDF5",$J,IBDIV,IBCAT,X,IBIN,IBKEY)=$P(IBPT,U,2)_" "_IBVA_U_$P(IBPT,U,3,4)_U_IBOI
"RTN","IBJDF51",105,0)
. . S ^TMP("IBJDF5",$J,IBDIV,IBCAT,X,IBIN,IBKEY,IBBN)=IBDP_U_IBFR_U_IBTO_U_IBOR_U_IBBA_U_IBSID
"RTN","IBJDF51",106,0)
. . I IBSH D COM
"RTN","IBJDF51",107,0)
;
"RTN","IBJDF51",108,0)
I 'IBQ,'$G(IBEXCEL) D EN^IBJDF52 ; Print the report.
"RTN","IBJDF51",109,0)
;
"RTN","IBJDF51",110,0)
ENQ K ^TMP("IBJDF5",$J)
"RTN","IBJDF51",111,0)
I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
"RTN","IBJDF51",112,0)
;
"RTN","IBJDF51",113,0)
D ^%ZISC
"RTN","IBJDF51",114,0)
ENQ1 K IB,IBA,IBA1,IBAR,IBARD,IBBU,IBC,IBCAT,IBCAT1,IBDIV,IBD,IBI,IBQ,IBPT
"RTN","IBJDF51",115,0)
K IBDP,IBKEY,IBVA,IBAC,IBBA,IBBN,IBFR,IBIN,IBOI,IBOR,IBSID,IBTO,IBTYP,IBI
"RTN","IBJDF51",116,0)
K COM,COM1,DAT,DFN,J,X,X1,X2,Y,Z D KVA^VADPT
"RTN","IBJDF51",117,0)
Q
"RTN","IBJDF51",118,0)
;
"RTN","IBJDF51",119,0)
PAT(IBDA) ; - Find the claim patient and decide to include the claim.
"RTN","IBJDF51",120,0)
; Input: IBDA=Pointer to the claim/AR in file #399/#430 plus all
"RTN","IBJDF51",121,0)
; variable input in IBS*
"RTN","IBJDF51",122,0)
; Output: Y=Sort key (name or last 4)_@@_patient IEN to file #2
"RTN","IBJDF51",123,0)
; ^ Patient name ^ Age ^ SSN ^ Patient IEN to file #2
"RTN","IBJDF51",124,0)
N AGE,ALL,ARZ,DA,DBTR,DFN,DIC,DIQ,DOB,DR,END,IBZ,INI,KEY,NAME,RCZ,SSN
"RTN","IBJDF51",125,0)
N VADM,Y,Z
"RTN","IBJDF51",126,0)
;
"RTN","IBJDF51",127,0)
S Y="" G:'$G(IBDA) PATQ
"RTN","IBJDF51",128,0)
S DFN=0,(NAME,AGE,SSN)="",ARZ=$G(^PRCA(430,IBDA,0))
"RTN","IBJDF51",129,0)
;
"RTN","IBJDF51",130,0)
; - Look for Patient (Corresponding Claim in IB)
"RTN","IBJDF51",131,0)
I $D(^DGCR(399,IBDA,0)) D I 'DFN S Y="" G PATQ
"RTN","IBJDF51",132,0)
. S IBZ=^DGCR(399,IBDA,0),DFN=+$P(IBZ,"^",2)
"RTN","IBJDF51",133,0)
. D DEM^VADPT S NAME=VADM(1),SSN=$P(VADM(2),"^",2),AGE=VADM(4)
"RTN","IBJDF51",134,0)
;
"RTN","IBJDF51",135,0)
; - Look for Debtor (No corresponding Claim in IB)
"RTN","IBJDF51",136,0)
I '$D(^DGCR(399,IBDA,0)) D I 'DFN S Y="" G PATQ
"RTN","IBJDF51",137,0)
. S DBTR=+$P(ARZ,"^",9) I 'DBTR Q
"RTN","IBJDF51",138,0)
. S RCZ=$G(^RCD(340,DBTR,0)),DFN=+RCZ
"RTN","IBJDF51",139,0)
. I $P(RCZ,"^")["DPT" D
"RTN","IBJDF51",140,0)
. . D DEM^VADPT S NAME=VADM(1),SSN=$P(VADM(2),"^",2),AGE=VADM(4)
"RTN","IBJDF51",141,0)
. I $P(RCZ,"^")'["DPT" D
"RTN","IBJDF51",142,0)
. . S DIC="^PRCA(430,",DA=IBDA,DR=9,DIQ="DEB" D EN^DIQ1
"RTN","IBJDF51",143,0)
. . S NAME=$G(DEB(430,DA,9)),KEY=NAME
"RTN","IBJDF51",144,0)
. . S DIC="^RCD(340,",DA=DBTR,DR=110,DIQ="DEB" D EN^DIQ1
"RTN","IBJDF51",145,0)
. . S SSN=$G(DEB(340,DA,110))
"RTN","IBJDF51",146,0)
. . I SSN S SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)
"RTN","IBJDF51",147,0)
;
"RTN","IBJDF51",148,0)
S KEY=$S(IBSN="N":NAME,1:+$P(SSN,"-",3))
"RTN","IBJDF51",149,0)
S INI=IBSNF,END=IBSNL,ALL=IBSNA
"RTN","IBJDF51",150,0)
I (INI'="@"&('DFN)) S Y="" G PATQ
"RTN","IBJDF51",151,0)
I ALL="ALL"&('DFN)!(ALL="NULL"&(DFN)) S Y="" G PATQ
"RTN","IBJDF51",152,0)
I INI="@",END="zzzzz" G PATC
"RTN","IBJDF51",153,0)
I INI]KEY!(KEY]END) S Y="" G PATQ
"RTN","IBJDF51",154,0)
;
"RTN","IBJDF51",155,0)
PATC ; - Find all patient data.
"RTN","IBJDF51",156,0)
S Y=KEY_"@@"_DFN_U_$E(NAME,1,25)_U_AGE_U_SSN_"^"_DFN
"RTN","IBJDF51",157,0)
PATQ Q Y
"RTN","IBJDF51",158,0)
;
"RTN","IBJDF51",159,0)
DIV(CLM) ;Find the default division of the bill.
"RTN","IBJDF51",160,0)
S DIV=$P($G(^DGCR(399,CLM,0)),"^",22)
"RTN","IBJDF51",161,0)
QDIV S:'DIV DIV=$$PRIM^VASITE() S:DIV'>0 DIV=0
"RTN","IBJDF51",162,0)
Q DIV
"RTN","IBJDF51",163,0)
SID(DFN,INS) ; - Find the subscriber ID for a bill (if any).
"RTN","IBJDF51",164,0)
; Input: DFN=Pointer to the patient in file #2
"RTN","IBJDF51",165,0)
; INS=Pointer to the patient's primary carrier in file #36
"RTN","IBJDF51",166,0)
; Output: Subscriber ID no. or null
"RTN","IBJDF51",167,0)
N X,Y,Z S Y="" G:'$G(DFN)!('$G(INS)) SIDQ
"RTN","IBJDF51",168,0)
S Z=0 F S Z=$O(^DPT(DFN,.312,Z)) Q:'Z S X=$G(^(Z,0)) D Q:Y]""
"RTN","IBJDF51",169,0)
.;IB*2.0*516/TAZ - Use HIPAA compliant Sub ID
"RTN","IBJDF51",170,0)
.I +X=INS S Y=$E($$GET1^DIQ(2.312,Z_","_DFN_",",7.02),1,16)
"RTN","IBJDF51",171,0)
;
"RTN","IBJDF51",172,0)
SIDQ Q Y
"RTN","IBJDF51",173,0)
;
"RTN","IBJDF51",174,0)
PHDL ; - Print the header line for the Excel spreadsheet
"RTN","IBJDF51",175,0)
N X
"RTN","IBJDF51",176,0)
S X="Patient^VA Empl.?^Age^SSN^Prim.Ins.Carrier^Other Ins.Carrier^"
"RTN","IBJDF51",177,0)
S X=X_"Dt Bill prep.^Bill From Dt^Bill To Dt^Subsc.ID^Bill #^"
"RTN","IBJDF51",178,0)
S X=X_"Orig.Amt^Curr.Bal.^Cat.^Bill Type^Lst Comm.Dt^Days Lst Comm.^"
"RTN","IBJDF51",179,0)
S X=X_"Division"
"RTN","IBJDF51",180,0)
W !,X
"RTN","IBJDF51",181,0)
Q
"RTN","IBJDF51",182,0)
;
"RTN","IBJDF51",183,0)
OTH(DFN,INS,DS) ; - Find a patient's other valid insurance carrier (if any).
"RTN","IBJDF51",184,0)
; Input: DFN=Pointer to the patient in file #2
"RTN","IBJDF51",185,0)
; INS=Pointer to the patient's primary carrier in file #36
"RTN","IBJDF51",186,0)
; DS=Date of service for validity check
"RTN","IBJDF51",187,0)
; Output: Valid insurance carrier (first 15 chars.) or null
"RTN","IBJDF51",188,0)
N X,X1,Y,Z S Y="" G:'$G(DFN)!('$G(INS))!('$G(DS)) OTHQ
"RTN","IBJDF51",189,0)
S Z=0 F S Z=$O(^DPT(DFN,.312,Z)) Q:'Z S X=$G(^(Z,0)) D:X Q:Y]""
"RTN","IBJDF51",190,0)
.I +X=INS Q
"RTN","IBJDF51",191,0)
.S X1=$G(^DIC(36,+X,0)) Q:X1=""
"RTN","IBJDF51",192,0)
.I $P(X1,U,2)'="N",$$CHK^IBCNS1(X,DS) S Y=$E($P(X1,U),1,15)
"RTN","IBJDF51",193,0)
;
"RTN","IBJDF51",194,0)
OTHQ Q Y
"RTN","IBJDF51",195,0)
;
"RTN","IBJDF51",196,0)
COM ; - Get bill comments.
"RTN","IBJDF51",197,0)
S DAT=0,IBA1=$S(IBSH1="M":999999999,1:0)
"RTN","IBJDF51",198,0)
F S IBA1=$S(IBSH1="M":$O(^PRCA(433,"C",IBA,IBA1),-1),1:$O(^PRCA(433,"C",IBA,IBA1))) Q:'IBA1 D I IBSH1="M",DAT Q
"RTN","IBJDF51",199,0)
.S IBC=$G(^PRCA(433,IBA1,1)) Q:'IBC
"RTN","IBJDF51",200,0)
.I $G(IBSH2),$$FMDIFF^XLFDT(DT,+IBC)<IBSH2 Q ; Comment age not minimum.
"RTN","IBJDF51",201,0)
.I $P(IBC,U,2)'=35,$P(IBC,U,2)'=45 Q ; Not decrease/comment transact.
"RTN","IBJDF51",202,0)
.S DAT=$S(IBC:+IBC\1,1:+$P(IBC,U,9)\1)
"RTN","IBJDF51",203,0)
.I $G(IBEXCEL),IBSH1="M" S IBEXCEL1=IBEXCEL1_$$DT^IBJD(DAT,1) Q
"RTN","IBJDF51",204,0)
.;
"RTN","IBJDF51",205,0)
.; - Append brief and transaction comments.
"RTN","IBJDF51",206,0)
.K COM,COM1 S COM(0)=DAT,X1=0
"RTN","IBJDF51",207,0)
.S COM1(1)=$P($G(^PRCA(433,IBA1,5)),U,2)
"RTN","IBJDF51",208,0)
.S COM1(2)=$E($P($G(^PRCA(433,IBA1,8)),U,6),1,70)
"RTN","IBJDF51",209,0)
.S COM(1)=COM1(1)_$S(COM1(1)]""&(COM1(2)]""):"|",1:"")_COM1(2)
"RTN","IBJDF51",210,0)
.I COM(1)]"" S COM(1)="**"_COM(1)_"**",X1=1
"RTN","IBJDF51",211,0)
.;
"RTN","IBJDF51",212,0)
.; - Get main comments.
"RTN","IBJDF51",213,0)
.S X2=0 F S X2=$O(^PRCA(433,IBA1,7,X2)) Q:'X2 S COM($S(X1:X2+1,1:X2))=^(X2,0)
"RTN","IBJDF51",214,0)
.;
"RTN","IBJDF51",215,0)
.S X1="" F S X1=$O(COM(X1)) Q:X1="" D
"RTN","IBJDF51",216,0)
..S ^TMP("IBJDF5",$J,IBDIV,IBCAT,X,IBIN,IBKEY,IBBN,IBA1,X1)=COM(X1)
"RTN","IBJDF51",217,0)
;
"RTN","IBJDF51",218,0)
Q
"RTN","IBJDF52")
0^20^B28589932
"RTN","IBJDF52",1,0)
IBJDF52 ;ALB/RB - CHAMPVA/TRICARE FOLLOW-UP REPORT (PRINT) ;15-APR-00
"RTN","IBJDF52",2,0)
;;2.0;INTEGRATED BILLING;**123,159,240,618**;21-MAR-94;Build 60
"RTN","IBJDF52",3,0)
;;Per VHA Directive 6402, this routine should not be modified.
"RTN","IBJDF52",4,0)
;
"RTN","IBJDF52",5,0)
EN ; - Print the Follow-up report.
"RTN","IBJDF52",6,0)
S (IBQ,IBFLG)=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%) G:IBRPT="S" SUM
"RTN","IBJDF52",7,0)
I 'IBSD D DET(0) G SUM
"RTN","IBJDF52",8,0)
I IBSEL["1" D DET(0)
"RTN","IBJDF52",9,0)
S IBDIV=""
"RTN","IBJDF52",10,0)
F S IBDIV=$O(VAUTD(IBDIV)) Q:IBDIV="" D DET(IBDIV) Q:IBQ
"RTN","IBJDF52",11,0)
;
"RTN","IBJDF52",12,0)
SUM I 'IBQ D PRT^IBJDF53 ; Print summary.
"RTN","IBJDF52",13,0)
ENQ K I,IB0,IBC,IBCAT,IBCD,IBC1,IBC2,IBDIV,IBFLG,IBIN,IBKEY,IBN,IBPT,IBPAG
"RTN","IBJDF52",14,0)
K IBQ,IBRUN,IBTYP,%
"RTN","IBJDF52",15,0)
Q
"RTN","IBJDF52",16,0)
;
"RTN","IBJDF52",17,0)
DET(IBDIV) ; - Print report for a specific division.
"RTN","IBJDF52",18,0)
; Input: IBDIV=Pointer to the division in file #40.8 & variable IBSEL1
"RTN","IBJDF52",19,0)
S IBCAT=0
"RTN","IBJDF52",20,0)
F S IBCAT=$O(IBCAT(IBCAT)) Q:'IBCAT D Q:IBQ
"RTN","IBJDF52",21,0)
. S (IB0,IBIN,IBKEY,IBTYP)=""
"RTN","IBJDF52",22,0)
. F IBTYP=1:1:4 D:IBSEL1[IBTYP Q:IBQ
"RTN","IBJDF52",23,0)
. . I IBDIV,IBCAT=31 Q
"RTN","IBJDF52",24,0)
. . I IBSD,'IBDIV,IBCAT'=31 Q
"RTN","IBJDF52",25,0)
. . I '$D(^TMP("IBJDF5",$J,IBDIV,IBCAT,IBTYP)) D HDR1,NAR,PAUSE Q
"RTN","IBJDF52",26,0)
. . S IBFLG=0
"RTN","IBJDF52",27,0)
. . F S IBIN=$O(^TMP("IBJDF5",$J,IBDIV,IBCAT,IBTYP,IBIN)) Q:IBIN="" D Q:IBQ
"RTN","IBJDF52",28,0)
. . . D HDR1,HDR2 Q:IBQ
"RTN","IBJDF52",29,0)
. . . F S IBKEY=$O(^TMP("IBJDF5",$J,IBDIV,IBCAT,IBTYP,IBIN,IBKEY)) Q:IBKEY="" D Q:IBQ
"RTN","IBJDF52",30,0)
. . . . S IBPT=$G(^TMP("IBJDF5",$J,IBDIV,IBCAT,IBTYP,IBIN,IBKEY))
"RTN","IBJDF52",31,0)
. . . . D WPAT
"RTN","IBJDF52",32,0)
. . . . F S IB0=$O(^TMP("IBJDF5",$J,IBDIV,IBCAT,IBTYP,IBIN,IBKEY,IB0)) Q:IB0="" D Q:IBQ
"RTN","IBJDF52",33,0)
. . . . . S IBN=$G(^TMP("IBJDF5",$J,IBDIV,IBCAT,IBTYP,IBIN,IBKEY,IB0))
"RTN","IBJDF52",34,0)
. . . . . I $Y>(IOSL-3) D PAUSE Q:IBQ D HDR1,HDR2 Q:IBQ D WPAT
"RTN","IBJDF52",35,0)
. . . . . W ?59,IB0,?71,$$DAT1^IBOUTL(+IBN)
"RTN","IBJDF52",36,0)
. . . . . W ?80,$$DAT1^IBOUTL($P(IBN,U,2))
"RTN","IBJDF52",37,0)
. . . . . W ?89,$$DAT1^IBOUTL($P(IBN,U,3)),?98,$J($P(IBN,U,4),8,2)
"RTN","IBJDF52",38,0)
. . . . . W ?107,$J($P(IBN,U,5),8,2),?116,$P(IBN,U,6),!
"RTN","IBJDF52",39,0)
. . . . . ;
"RTN","IBJDF52",40,0)
. . . . . ; - Display bill comment history, if necessary.
"RTN","IBJDF52",41,0)
. . . . . I IBSH D WCOM
"RTN","IBJDF52",42,0)
. . . D:'IBQ PAUSE
"RTN","IBJDF52",43,0)
;
"RTN","IBJDF52",44,0)
DETQ Q
"RTN","IBJDF52",45,0)
;
"RTN","IBJDF52",46,0)
DASH(X) ; - Return a dashed line.
"RTN","IBJDF52",47,0)
Q $TR($J("",X)," ","=")
"RTN","IBJDF52",48,0)
;
"RTN","IBJDF52",49,0)
PAUSE ; - Page break.
"RTN","IBJDF52",50,0)
I $E(IOST,1,2)'="C-" Q
"RTN","IBJDF52",51,0)
N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
"RTN","IBJDF52",52,0)
F IBX=$Y:1:(IOSL-3) W !
"RTN","IBJDF52",53,0)
S DIR(0)="E" D ^DIR S:$D(DIRUT)!($D(DUOUT)) IBQ=1
"RTN","IBJDF52",54,0)
Q
"RTN","IBJDF52",55,0)
;
"RTN","IBJDF52",56,0)
HDR1 ; - Write the primary report header.
"RTN","IBJDF52",57,0)
N FLG,X,IBCATNM
"RTN","IBJDF52",58,0)
;
"RTN","IBJDF52",59,0)
S FLG=1 I $G(IBFLG) S FLG=0
"RTN","IBJDF52",60,0)
I '$G(IBFLG),$E(IOST,1,2)="C-"!$G(IBPAG) D
"RTN","IBJDF52",61,0)
. W @IOF,*13 S IBFLG=0
"RTN","IBJDF52",62,0)
. S IBPAG=$G(IBPAG)+1
"RTN","IBJDF52",63,0)
I $G(IBFLG) D
"RTN","IBJDF52",64,0)
. I $Y'>(IOSL-11) W !!! Q
"RTN","IBJDF52",65,0)
. W @IOF,*13 S IBPAG=$G(IBPAG)+1,FLG=1
"RTN","IBJDF52",66,0)
I '$G(IBPAG) S IBPAG=1
"RTN","IBJDF52",67,0)
I IBDIV!FLG D
"RTN","IBJDF52",68,0)
. W "CHAMPVA/TRICARE Follow-Up Report"
"RTN","IBJDF52",69,0)
. I IBDIV W " for ",$P($G(^DG(40.8,IBDIV,0)),U)," "
"RTN","IBJDF52",70,0)
. W ?75,"Run Date: ",IBRUN W:FLG ?123,"Page: ",$J(IBPAG,3)
"RTN","IBJDF52",71,0)
S IBCATNM=$$ARCAT^IBJDF62(IBCAT) ; patch IB*2.0*618
"RTN","IBJDF52",72,0)
S X="ALL ACTIVE "_$G(IBCATNM)_" RECEIVABLES " ; patch IB*2.0*618
"RTN","IBJDF52",73,0)
I IBTYP'=4 S X=X_"("_$G(IBTPR(IBTYP))_") "
"RTN","IBJDF52",74,0)
I IBSMN S X=X_"OVER "_IBSMN_" AND UNDER "_IBSMX_" DAYS OLD "
"RTN","IBJDF52",75,0)
S X=X_" / BY PATIENT "_$S(IBSN="N":"NAME",1:"LAST 4 DIGITS OF SSN")
"RTN","IBJDF52",76,0)
S X=X_" ("_$S($G(IBSNA)="ALL":"ALL",1:"From "_$S(IBSNF="":"FIRST",1:IBSNF)_" to "_$S(IBSNL="zzzzz":"LAST",1:IBSNL))_")"
"RTN","IBJDF52",77,0)
S X=X_" / "_$S('IBSAM:"NO ",1:"")_"MINIMUM BALANCE"
"RTN","IBJDF52",78,0)
I IBSAM S X=X_$S(IBSAM:": $"_$FN(IBSAM,",",2),1:"")
"RTN","IBJDF52",79,0)
S X=X_" / "_$S('IBSH:"NO ",IBSH1="A":"ALL ",1:"ONLY ")_"COMMENTS"
"RTN","IBJDF52",80,0)
S X=X_$S($G(IBSH2):" NOT OLDER THAN "_IBSH2_" DAYS",1:"")
"RTN","IBJDF52",81,0)
S X=X_" / '*' AFTER THE PATIENT NAME = VA EMPLOYEE"
"RTN","IBJDF52",82,0)
F I=1:1 W !,$E(X,1,132) S X=$E(X,133,999) I X="" Q
"RTN","IBJDF52",83,0)
;
"RTN","IBJDF52",84,0)
W !!?71,"Dte Bill",?98,"Original Current"
"RTN","IBJDF52",85,0)
W !,"Patient",?26,"Age SSN" W:IBCAT'=31 ?43,"Other Insurance"
"RTN","IBJDF52",86,0)
W ?59,"Bill Number Prepared",?80,"Bill Frm Bill To Amount Balance"
"RTN","IBJDF52",87,0)
W:IBCAT'=31 ?116,"Subscriber ID"
"RTN","IBJDF52",88,0)
W !,$$DASH(IOM),!
"RTN","IBJDF52",89,0)
S IBQ=$$STOP^IBOUTL("CHAMPVA/TRICARE Follow-Up Report")
"RTN","IBJDF52",90,0)
Q
"RTN","IBJDF52",91,0)
;
"RTN","IBJDF52",92,0)
HDR2 ; - Write the insurance company sub-header.
"RTN","IBJDF52",93,0)
N X,X13
"RTN","IBJDF52",94,0)
I $P(IBIN,"@@")'=0 W ?2,"Carrier: ",$P(IBIN,"@@")
"RTN","IBJDF52",95,0)
S X=$G(^DIC(36,+$P(IBIN,"@@",2),.11)),X13=$G(^(.13))
"RTN","IBJDF52",96,0)
I X]"" D
"RTN","IBJDF52",97,0)
.W ", ",$P(X,U),", ",$P(X,U,4),", ",$P($G(^DIC(5,+$P(X,U,5),0)),U,2)," ",$P(X,U,6)
"RTN","IBJDF52",98,0)
.I $P(X13,U,2)]"" W " Billing Phone: ",$P(X13,U,2) Q
"RTN","IBJDF52",99,0)
.I $P(X13,U)]"" W " Main Phone: ",$P(X13,U)
"RTN","IBJDF52",100,0)
;
"RTN","IBJDF52",101,0)
Q
"RTN","IBJDF52",102,0)
;
"RTN","IBJDF52",103,0)
NAR ; - Write detail line (if '$D).
"RTN","IBJDF52",104,0)
S IBFLG=1
"RTN","IBJDF52",105,0)
W !!,"There are no active receivables for the parameters above."
"RTN","IBJDF52",106,0)
Q
"RTN","IBJDF52",107,0)
;
"RTN","IBJDF52",108,0)
WPAT ; - Write patient data.
"RTN","IBJDF52",109,0)
W !,$P(IBPT,U),?26,$J($P(IBPT,U,2),3),?30,$P(IBPT,U,3)
"RTN","IBJDF52",110,0)
W ?43,$P(IBPT,U,4)
"RTN","IBJDF52",111,0)
Q
"RTN","IBJDF52",112,0)
;
"RTN","IBJDF52",113,0)
WCOM ; - Write bill comments
"RTN","IBJDF52",114,0)
N CONT,DIWL,DIWR,IBC,IBCD,IBC1,IBC2,X
"RTN","IBJDF52",115,0)
;
"RTN","IBJDF52",116,0)
S (IBC,CONT,IBCD)=0,IBC1="",DIWL=1,DIWR=104 K ^UTILITY($J)
"RTN","IBJDF52",117,0)
F S IBC=$O(^TMP("IBJDF5",$J,IBDIV,IBCAT,IBTYP,IBIN,IBKEY,IB0,IBC)) Q:'IBC D Q:IBQ
"RTN","IBJDF52",118,0)
. F S IBC1=$O(^TMP("IBJDF5",$J,IBDIV,IBCAT,IBTYP,IBIN,IBKEY,IB0,IBC,IBC1)) Q:IBC1="" D Q:IBQ
"RTN","IBJDF52",119,0)
. . S IBC2=^TMP("IBJDF5",$J,IBDIV,IBCAT,IBTYP,IBIN,IBKEY,IB0,IBC,IBC1)
"RTN","IBJDF52",120,0)
. . I 'IBC1 S IBCD=IBC2 D WCD Q
"RTN","IBJDF52",121,0)
. . I $Y>(IOSL-4) D WCPB Q:IBQ
"RTN","IBJDF52",122,0)
. . S X=IBC2 I $E(X)=" ",$L(X)>1 S $E(X)=""
"RTN","IBJDF52",123,0)
. . D ^DIWP
"RTN","IBJDF52",124,0)
. . I 'CONT,$L(IBC2)<66 D WCTXT Q
"RTN","IBJDF52",125,0)
. . S CONT=$L(IBC2)>65
"RTN","IBJDF52",126,0)
. . I '$O(^TMP("IBJDF5",$J,IBDIV,IBCAT,IBTYP,IBIN,IBKEY,IB0,IBC,IBC1)) D
"RTN","IBJDF52",127,0)
. . . D:$D(^UTILITY($J,"W")) WCTXT
"RTN","IBJDF52",128,0)
K ^UTILITY($J,"W")
"RTN","IBJDF52",129,0)
Q
"RTN","IBJDF52",130,0)
;
"RTN","IBJDF52",131,0)
WCTXT ; - Write comment text
"RTN","IBJDF52",132,0)
N LIN,WLIN
"RTN","IBJDF52",133,0)
S LIN=""
"RTN","IBJDF52",134,0)
F S LIN=$O(^UTILITY($J,"W",1,LIN)) Q:LIN="" D Q:IBQ
"RTN","IBJDF52",135,0)
. S WLIN=$G(^UTILITY($J,"W",1,LIN,0))
"RTN","IBJDF52",136,0)
. I $Y>(IOSL-4) D WCPB Q:IBQ
"RTN","IBJDF52",137,0)
. W:WLIN'="" ?26,WLIN,!
"RTN","IBJDF52",138,0)
K ^UTILITY($J,"W")
"RTN","IBJDF52",139,0)
Q
"RTN","IBJDF52",140,0)
;
"RTN","IBJDF52",141,0)
WCPB ; - Page Break in the middle of Comments
"RTN","IBJDF52",142,0)
;
"RTN","IBJDF52",143,0)
D PAUSE Q:IBQ D HDR1,HDR2 Q:IBQ
"RTN","IBJDF52",144,0)
W ! D WPAT D WCD W:IBC1>1 ?26,"(continued)",!
"RTN","IBJDF52",145,0)
Q
"RTN","IBJDF52",146,0)
;
"RTN","IBJDF52",147,0)
WCD ; - Write comment date.
"RTN","IBJDF52",148,0)
W !?2,"Comment Date: ",$$DAT1^IBOUTL(IBCD)
"RTN","IBJDF52",149,0)
Q
"RTN","IBJDF52",150,0)
;
"RTN","IBJDF52",151,0)
SSN(X) ; - Format the SSN.
"RTN","IBJDF52",152,0)
Q $S(X:$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),1:"")
"RTN","IBJDF53")
0^16^B26261562
"RTN","IBJDF53",1,0)
IBJDF53 ;ALB/RB - CHAMPVA/TRICARE FOLLOW-UP REPORT (SUMMARY);15-APR-00
"RTN","IBJDF53",2,0)
;;2.0;INTEGRATED BILLING;**123,185,240,618**;21-MAR-94;Build 60
"RTN","IBJDF53",3,0)
;;Per VHA Directive 6402, this routine should not be modified.
"RTN","IBJDF53",4,0)
;
"RTN","IBJDF53",5,0)
INIT ; - Initialize counters, if necessary.
"RTN","IBJDF53",6,0)
; Pre-set variables IBCAT, IBDIV, IBSEL1 required.
"RTN","IBJDF53",7,0)
N I,IB0
"RTN","IBJDF53",8,0)
I '$D(IB(IBDIV,IBCAT)) D
"RTN","IBJDF53",9,0)
. F IB0=1:1:4 I IBSEL1[IB0 F I=1:1:8 S IB(IBDIV,IBCAT,IB0,I)=0
"RTN","IBJDF53",10,0)
;
"RTN","IBJDF53",11,0)
Q
"RTN","IBJDF53",12,0)
;
"RTN","IBJDF53",13,0)
EN ; - Compile entry point from IBJDF51.
"RTN","IBJDF53",14,0)
; Pre-set variables IB(, IBA, IBCAT, IBDIV, IBSEL1, IBTYP required.
"RTN","IBJDF53",15,0)
N I,IB0,IBAGE,IBARD,IBOUT
"RTN","IBJDF53",16,0)
;
"RTN","IBJDF53",17,0)
; - Add totals for summary.
"RTN","IBJDF53",18,0)
S IBARD=$$ACT^IBJDF2(IBA) G:'IBARD ENQ ; No activation date.
"RTN","IBJDF53",19,0)
S IBOUT=0 F I=1:1:5 S IBOUT=IBOUT+$P($G(^PRCA(430,IBA,7)),U,I)
"RTN","IBJDF53",20,0)
S IBAGE=$$FMDIFF^XLFDT(DT,IBARD),IB0=$$CAT(IBAGE)
"RTN","IBJDF53",21,0)
F I=IBTYP,4 I IBSEL1[I D
"RTN","IBJDF53",22,0)
. S $P(IB(IBDIV,IBCAT,I,IB0),U)=+IB(IBDIV,IBCAT,I,IB0)+1
"RTN","IBJDF53",23,0)
. S $P(IB(IBDIV,IBCAT,I,IB0),U,2)=$P(IB(IBDIV,IBCAT,I,IB0),U,2)+IBOUT
"RTN","IBJDF53",24,0)
;
"RTN","IBJDF53",25,0)
ENQ Q
"RTN","IBJDF53",26,0)
;
"RTN","IBJDF53",27,0)
PRT ; - Print entry point from IBJDF52.
"RTN","IBJDF53",28,0)
N IBDIV
"RTN","IBJDF53",29,0)
;
"RTN","IBJDF53",30,0)
; - Extract summary data.
"RTN","IBJDF53",31,0)
I $G(IBXTRACT) D EXTMO(.IB) G ENQ1
"RTN","IBJDF53",32,0)
;
"RTN","IBJDF53",33,0)
S IBDIV=""
"RTN","IBJDF53",34,0)
F S IBDIV=$O(IB(IBDIV)) Q:IBDIV="" D
"RTN","IBJDF53",35,0)
. S IBCAT=0
"RTN","IBJDF53",36,0)
. F S IBCAT=$O(IB(IBDIV,IBCAT)) Q:'IBCAT D SUM(.IBCAT) Q:IBQ
"RTN","IBJDF53",37,0)
;
"RTN","IBJDF53",38,0)
ENQ1 Q
"RTN","IBJDF53",39,0)
;
"RTN","IBJDF53",40,0)
EXTMO(IBS) ; Extract/transmit data to DM Extract Module
"RTN","IBJDF53",41,0)
; IBS - Array containing the summary information
"RTN","IBJDF53",42,0)
;
"RTN","IBJDF53",43,0)
N IB,IBCT,IBI,IBJ,IBR,IBSQ,IBTP,IBZ
"RTN","IBJDF53",44,0)
;
"RTN","IBJDF53",45,0)
F IBI=1:1:6 F IBJ=1:1:16 S IB(IBI,IBJ)=$S(IBJ#2:0,1:"0.00")
"RTN","IBJDF53",46,0)
;
"RTN","IBJDF53",47,0)
S IBCT=""
"RTN","IBJDF53",48,0)
F S IBCT=$O(IBS(0,IBCT)) Q:IBCT="" D
"RTN","IBJDF53",49,0)
. S IBTP=0
"RTN","IBJDF53",50,0)
. I IBCT=31 S IBTP=1 ; TRICARE Patient
"RTN","IBJDF53",51,0)
. I IBCT=19 Q ; Sharing Agreements (NOT EXTRACTED)
"RTN","IBJDF53",52,0)
. I IBCT=30 S IBTP=2 ; TRICARE
"RTN","IBJDF53",53,0)
. I IBCT=75 S IBTP=2 ; TRICARE DES IB*2.0*618
"RTN","IBJDF53",54,0)
. I IBCT=76 S IBTP=2 ; TRICARE SCI IB*2.0*618
"RTN","IBJDF53",55,0)
. I IBCT=77 S IBTP=2 ; TRICARE TBI IB*2.0*618
"RTN","IBJDF53",56,0)
. I IBCT=78 S IBTP=2 ; TRICARE BLIND IB*2.0*618
"RTN","IBJDF53",57,0)
. I IBCT=79 S IBTP=2 ; TRICARE DENTAL IB*2.0*618
"RTN","IBJDF53",58,0)
. I IBCT=80 S IBTP=2 ; TRICARE PHARMACY IB*2.0*618
"RTN","IBJDF53",59,0)
. I IBCT=32 S IBTP=3 ; TRICARE THIRD PARTY
"RTN","IBJDF53",60,0)
. I IBCT=28 S IBTP=4 ; CHAMPVA
"RTN","IBJDF53",61,0)
. I IBCT=29 S IBTP=5 ; CHAMPVA THRID PARTY
"RTN","IBJDF53",62,0)
. S IBSQ=1
"RTN","IBJDF53",63,0)
. F IBI=1:1:7 D
"RTN","IBJDF53",64,0)
. . S IBZ=$G(IBS(0,IBCT,4,IBI))
"RTN","IBJDF53",65,0)
. . S IB(IBTP,IBSQ)=+IBZ
"RTN","IBJDF53",66,0)
. . S IB(IBTP,IBSQ+1)=$FN(+$P(IBZ,"^",2),"",2)
"RTN","IBJDF53",67,0)
. . S IB(IBTP,15)=IB(IBTP,15)+IBZ
"RTN","IBJDF53",68,0)
. . S IB(IBTP,16)=IB(IBTP,16)+$P(IBZ,"^",2)
"RTN","IBJDF53",69,0)
. . S IBSQ=IBSQ+2
"RTN","IBJDF53",70,0)
. S IB(IBTP,16)=$FN(IB(IBTP,16),"",2)
"RTN","IBJDF53",71,0)
;
"RTN","IBJDF53",72,0)
F IBR=17:1:21 D E^IBJDE(IBR,0)
"RTN","IBJDF53",73,0)
Q
"RTN","IBJDF53",74,0)
;
"RTN","IBJDF53",75,0)
SUM(IBCAT) ; - Print summary for AR category.
"RTN","IBJDF53",76,0)
; Input: IBCAT=AR category pointer to file #430.2, and pre-set
"RTN","IBJDF53",77,0)
; variables IBDIV and IBRPT
"RTN","IBJDF53",78,0)
N IBDH,IBTYP,IBTYPH,I,J
"RTN","IBJDF53",79,0)
N IBCATNM ; patch IB*2.0*618
"RTN","IBJDF53",80,0)
;
"RTN","IBJDF53",81,0)
S (IBFLG,IBTYP)=0 D HDR
"RTN","IBJDF53",82,0)
F S IBTYP=$O(IB(IBDIV,IBCAT,IBTYP)) Q:'IBTYP D Q:IBQ
"RTN","IBJDF53",83,0)
. S IBCATNM=$$ARCAT^IBJDF62(IBCAT) ; patch IB*2.0*618
"RTN","IBJDF53",84,0)
. I $Y>(IOSL-16) D HDR Q:IBQ
"RTN","IBJDF53",85,0)
. S IBTYPH=$G(IBCATNM)_" RECEIVABLES ("_$G(IBTPR(IBTYP))_")"
"RTN","IBJDF53",86,0)
. W !!!?(80-$L(IBTYPH))\2,IBTYPH
"RTN","IBJDF53",87,0)
. W !?(80-$L(IBTYPH)\2),$$DASH($L(IBTYPH))
"RTN","IBJDF53",88,0)
. I IBDIV D
"RTN","IBJDF53",89,0)
. . S IBDH="Division: "_$P($G(^DG(40.8,IBDIV,0)),U)
"RTN","IBJDF53",90,0)
. . W !?(80-$L(IBDH)\2),IBDH
"RTN","IBJDF53",91,0)
. W !!
"RTN","IBJDF53",92,0)
. ;
"RTN","IBJDF53",93,0)
. ; - Calculate totals first.
"RTN","IBJDF53",94,0)
. F I=1:1:7 F J=1,2 S $P(IB(IBDIV,IBCAT,IBTYP,8),U,J)=$P(IB(IBDIV,IBCAT,IBTYP,8),U,J)+$P(IB(IBDIV,IBCAT,IBTYP,I),U,J)
"RTN","IBJDF53",95,0)
. ;
"RTN","IBJDF53",96,0)
. W "AR Category",?31,"# Receivables",?52,"Total Outstanding Balance",!
"RTN","IBJDF53",97,0)
. W "-----------",?31,"-------------",?52,"-------------------------"
"RTN","IBJDF53",98,0)
. I 'IB(IBDIV,IBCAT,IBTYP,8) D D PAUSE Q
"RTN","IBJDF53",99,0)
. . W !!,"There are no active receivables",$S(IBDIV:" for this division",1:""),"."
"RTN","IBJDF53",100,0)
. . S IBFLG=1
"RTN","IBJDF53",101,0)
. ;
"RTN","IBJDF53",102,0)
. ; - Primary loop to write results.
"RTN","IBJDF53",103,0)
. S Y=$P(IB(IBDIV,IBCAT,IBTYP,8),U,2)
"RTN","IBJDF53",104,0)
. F I=1:1:8 S X=$P($T(CATN+I),";;",2,99) D
"RTN","IBJDF53",105,0)
. . W:I=8 ! W !,X,?30,$J(+IB(IBDIV,IBCAT,IBTYP,I),6)
"RTN","IBJDF53",106,0)
. . W " (",$J(+IB(IBDIV,IBCAT,IBTYP,I)/+IB(IBDIV,IBCAT,IBTYP,8)*100,0,$S(I=8:0,1:2)),"%)"
"RTN","IBJDF53",107,0)
. . S Z=$FN($P(IB(IBDIV,IBCAT,IBTYP,I),U,2),",",2)
"RTN","IBJDF53",108,0)
. . W ?52,$J($S(I=1!(I=9):"$",1:"")_Z,15)
"RTN","IBJDF53",109,0)
. . W " (",$J($S('Y:0,1:$P(IB(IBDIV,IBCAT,IBTYP,I),U,2)/Y*100),0,$S(I=8:0,1:2)),"%)"
"RTN","IBJDF53",110,0)
. ;
"RTN","IBJDF53",111,0)
. D PAUSE
"RTN","IBJDF53",112,0)
;
"RTN","IBJDF53",113,0)
SUMQ Q
"RTN","IBJDF53",114,0)
;
"RTN","IBJDF53",115,0)
HDR ; - Write the summary report header.
"RTN","IBJDF53",116,0)
N X
"RTN","IBJDF53",117,0)
;
"RTN","IBJDF53",118,0)
I $E(IOST,1,2)="C-"!$G(IBPAG) W @IOF,*13
"RTN","IBJDF53",119,0)
S IBPAG=$G(IBPAG)+1
"RTN","IBJDF53",120,0)
W "CHAMPVA/TRICARE FOLLOW-UP SUMMARY REPORT"
"RTN","IBJDF53",121,0)
W ?71,"Page: ",$J(IBPAG,3),!,"Run Date: ",IBRUN
"RTN","IBJDF53",122,0)
S X=""
"RTN","IBJDF53",123,0)
I IBRPT="D" D
"RTN","IBJDF53",124,0)
. I IBSMN'="A" D
"RTN","IBJDF53",125,0)
. . S X=" RECEIVABLES OVER "_IBSMN_" AND LESS THAN "_IBSMX_" DAYS OLD "
"RTN","IBJDF53",126,0)
. I $G(IBSNA)'="ALL" D
"RTN","IBJDF53",127,0)
. . S X=X_"/ PATIENTS FROM '"_$S(IBSNF="":"FIRST",1:IBSNF)_"' TO '"
"RTN","IBJDF53",128,0)
. . S X=X_$S(IBSNL="zzzzz":"LAST",1:IBSNL)_"' "
"RTN","IBJDF53",129,0)
. I $G(IBSAM) S X=X_"/ MINIMUM BALANCE: $"_$FN(IBSAM,",",2)_" "
"RTN","IBJDF53",130,0)
S $E(X,1,2)=""
"RTN","IBJDF53",131,0)
I X'="" F I=1:1 W !,$E(X,1,80) S X=$E(X,81,999) I X="" Q
"RTN","IBJDF53",132,0)
;
"RTN","IBJDF53",133,0)
Q
"RTN","IBJDF53",134,0)
;
"RTN","IBJDF53",135,0)
DASH(X) ; - Return a dashed line.
"RTN","IBJDF53",136,0)
Q $TR($J("",X)," ","=")
"RTN","IBJDF53",137,0)
;
"RTN","IBJDF53",138,0)
PAUSE ; - Page break.
"RTN","IBJDF53",139,0)
I $E(IOST,1,2)'="C-" Q
"RTN","IBJDF53",140,0)
N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
"RTN","IBJDF53",141,0)
F IBX=$Y:1:(IOSL-3) W !
"RTN","IBJDF53",142,0)
S DIR(0)="E" D ^DIR S:$D(DIRUT)!($D(DUOUT)) IBQ=1
"RTN","IBJDF53",143,0)
Q
"RTN","IBJDF53",144,0)
;
"RTN","IBJDF53",145,0)
CAT(X) ; - Determine category to place receivable.
"RTN","IBJDF53",146,0)
Q $S($G(X)<31:1,X<61:2,X<91:3,X<121:4,X<181:5,X<366:6,1:7)
"RTN","IBJDF53",147,0)
;
"RTN","IBJDF53",148,0)
CATN ; - List of category names.
"RTN","IBJDF53",149,0)
;;Less than 30 days old
"RTN","IBJDF53",150,0)
;;31-60 days
"RTN","IBJDF53",151,0)
;;61-90 days
"RTN","IBJDF53",152,0)
;;91-120 days
"RTN","IBJDF53",153,0)
;;121-180 days
"RTN","IBJDF53",154,0)
;;181-365 days
"RTN","IBJDF53",155,0)
;;Over 365 days
"RTN","IBJDF53",156,0)
;;Total
"RTN","IBJDF6")
0^17^B36325924
"RTN","IBJDF6",1,0)
IBJDF6 ;ALB/RB - MISCELLANEOUS BILLS FOLLOW-UP REPORT ;15-APR-00
"RTN","IBJDF6",2,0)
;;2.0;INTEGRATED BILLING;**123,159,618**;21-MAR-94;Build 60
"RTN","IBJDF6",3,0)
;
"RTN","IBJDF6",4,0)
EN ; - Option entry point.
"RTN","IBJDF6",5,0)
;
"RTN","IBJDF6",6,0)
SEL ; - Select type of receivables to print.
"RTN","IBJDF6",7,0)
K IBCTG S IBPRT="Choose which type of receivables to print:"
"RTN","IBJDF6",8,0)
S IBCTG(1)="MEDICARE"
"RTN","IBJDF6",9,0)
S IBCTG(2)="NO-FAULT AUTO ACCIDENT"
"RTN","IBJDF6",10,0)
S IBCTG(3)="COMMUNITY CARE NO-FAULT AUTO ACCIDENT"
"RTN","IBJDF6",11,0)
S IBCTG(4)="TORT FEASOR"
"RTN","IBJDF6",12,0)
S IBCTG(5)="COMMUNITY CARE TORT FEASOR"
"RTN","IBJDF6",13,0)
S IBCTG(6)="WORKMEN'S COMP"
"RTN","IBJDF6",14,0)
S IBCTG(7)="COMMUNITY CARE WORKMEN'S COMP"
"RTN","IBJDF6",15,0)
S IBCTG(8)="CURRENT EMPLOYEE"
"RTN","IBJDF6",16,0)
S IBCTG(9)="EX-EMPLOYEE"
"RTN","IBJDF6",17,0)
S IBCTG(10)="FEDERAL AGENCIES-REFUND"
"RTN","IBJDF6",18,0)
S IBCTG(11)="FEDERAL AGENCIES-REIMBURSEMENT"
"RTN","IBJDF6",19,0)
S IBCTG(12)="MILITARY"
"RTN","IBJDF6",20,0)
S IBCTG(13)="INTERAGENCY"
"RTN","IBJDF6",21,0)
S IBCTG(14)="VENDOR"
"RTN","IBJDF6",22,0)
S IBCTG(15)="ALL OF THE ABOVE"
"RTN","IBJDF6",23,0)
;
"RTN","IBJDF6",24,0)
S IBSEL=$$MLTP^IBJD(IBPRT,.IBCTG,1) I 'IBSEL G ENQ
"RTN","IBJDF6",25,0)
S (IB0,IB1)=0
"RTN","IBJDF6",26,0)
F X=1:1 S Y=$P(IBSEL,",",X) Q:'Y D
"RTN","IBJDF6",27,0)
. I Y<8 S IB0=1 Q ;IB*2.0*618
"RTN","IBJDF6",28,0)
. S IB1=1
"RTN","IBJDF6",29,0)
G ENQ:'IBSEL S IBSEL=","_IBSEL
"RTN","IBJDF6",30,0)
;
"RTN","IBJDF6",31,0)
; - Sort by division.
"RTN","IBJDF6",32,0)
S IBSDV=0 I IB0 S IBSDV=$$SDIV^IBJD() I IBSDV["^" G ENQ
"RTN","IBJDF6",33,0)
;
"RTN","IBJDF6",34,0)
; - Select a detailed or summary report.
"RTN","IBJDF6",35,0)
D DS^IBJD I IBRPT["^" G ENQ
"RTN","IBJDF6",36,0)
;
"RTN","IBJDF6",37,0)
;IB*2.0*618 - changed starting point from selection 4 to selection 8
"RTN","IBJDF6",38,0)
; Display receivables not sorting by division
"RTN","IBJDF6",39,0)
I IBSDV S IB2=0 F X=2:1 S Y=$P(IBSEL,",",X) Q:'Y D
"RTN","IBJDF6",40,0)
. ; Only display options 8-14
"RTN","IBJDF6",41,0)
. Q:Y<8
"RTN","IBJDF6",42,0)
. Q:Y>14
"RTN","IBJDF6",43,0)
. I 'IB2 D S IB2=1
"RTN","IBJDF6",44,0)
. . W !!,"NOTE: The receivables of these types will NOT be sorted by division:",!,*7
"RTN","IBJDF6",45,0)
. W !?6,IBCTG(Y)
"RTN","IBJDF6",46,0)
;end IB*2.0*618
"RTN","IBJDF6",47,0)
;
"RTN","IBJDF6",48,0)
G DEV:IBRPT="S"
"RTN","IBJDF6",49,0)
;
"RTN","IBJDF6",50,0)
; - Determine sorting (By name or Last 4 SSN)
"RTN","IBJDF6",51,0)
S (IBSN,X)=""
"RTN","IBJDF6",52,0)
I IB0 D I IBSN="^"!(X="^") G ENQ
"RTN","IBJDF6",53,0)
. S IBSN=$$SNL^IBJD() Q:IBSN="^"
"RTN","IBJDF6",54,0)
. W !!,"These receivables will be sorted by PATIENT/SSN:",!
"RTN","IBJDF6",55,0)
. F X=2:1 S Y=$P(IBSEL,",",X) Q:'Y I Y<8 W !?6,IBCTG(Y)
"RTN","IBJDF6",56,0)
. ; - Determine the PATIENT range
"RTN","IBJDF6",57,0)
. S X=$$INTV^IBJD("PATIENT "_$S(IBSN="N":"NAME",1:"LAST 4")) Q:X="^"
"RTN","IBJDF6",58,0)
. S IBSNF=$P(X,"^",1),IBSNL=$P(X,"^",2),IBSNA=$P(X,"^",3)
"RTN","IBJDF6",59,0)
;
"RTN","IBJDF6",60,0)
; - Determine range of debtors.
"RTN","IBJDF6",61,0)
I 'IB1 G AGE
"RTN","IBJDF6",62,0)
;
"RTN","IBJDF6",63,0)
I IB1 D
"RTN","IBJDF6",64,0)
. W !!,"These receivables will be sorted by DEBTOR:",!
"RTN","IBJDF6",65,0)
. F X=2:1 S Y=$P(IBSEL,",",X) Q:'Y I Y>4 W !?6,IBCTG(Y)
"RTN","IBJDF6",66,0)
S VAUTD(0)=""
"RTN","IBJDF6",67,0)
;
"RTN","IBJDF6",68,0)
; - Determine the DEBTOR range
"RTN","IBJDF6",69,0)
S X=$$INTV^IBJD("DEBTOR") G ENQ:X="^"
"RTN","IBJDF6",70,0)
S IBSDF=$P(X,"^",1),IBSDL=$P(X,"^",2),IBSDA=$P(X,"^",3)
"RTN","IBJDF6",71,0)
;
"RTN","IBJDF6",72,0)
AGE ; - Determine if the active receivable must be within an age range.
"RTN","IBJDF6",73,0)
W !!,"Include (A)LL active AR's or those within an AGE (R)ANGE: ALL// "
"RTN","IBJDF6",74,0)
R X:DTIME G:'$T!(X["^") ENQ S:X="" X="A" S X=$E(X)
"RTN","IBJDF6",75,0)
I "ARar"'[X S IBOFF=1 D HELP^IBJDF6H G AGE
"RTN","IBJDF6",76,0)
W " ",$S("Rr"[X:"RANGE",1:"ALL")
"RTN","IBJDF6",77,0)
S IBSMN=$S("Rr"[X:"R",1:"A") G:IBSMN="A" AMT
"RTN","IBJDF6",78,0)
;
"RTN","IBJDF6",79,0)
; - Determine the active receivable age range.
"RTN","IBJDF6",80,0)
S DIR(0)="NA^1:99999"
"RTN","IBJDF6",81,0)
S DIR("A")="Enter the minimum age of the active receivable: "
"RTN","IBJDF6",82,0)
S DIR("T")=DTIME,DIR("?")="^S IBOFF=9 D HELP^IBJDF6H"
"RTN","IBJDF6",83,0)
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
"RTN","IBJDF6",84,0)
S IBSMN=+Y W " ",IBSMN," DAYS" K DIROUT,DTOUT,DUOUT,DIRUT
"RTN","IBJDF6",85,0)
;
"RTN","IBJDF6",86,0)
S DIR(0)="NA^"_IBSMN_":99999",DIR("B")=IBSMN
"RTN","IBJDF6",87,0)
S DIR("A")="Enter the maximum age of the active receivable: "
"RTN","IBJDF6",88,0)
S DIR("T")=DTIME,DIR("?")="^S IBOFF=14 D HELP^IBJDF6H"
"RTN","IBJDF6",89,0)
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
"RTN","IBJDF6",90,0)
S IBSMX=+Y W " ",IBSMX," DAYS" K DIROUT,DTOUT,DUOUT,DIRUT
"RTN","IBJDF6",91,0)
;
"RTN","IBJDF6",92,0)
AMT ; - Print receivables with a minimum balance.
"RTN","IBJDF6",93,0)
S DIR(0)="Y",DIR("B")="NO" W !
"RTN","IBJDF6",94,0)
S DIR("A")="Print receivables with a minimum balance"
"RTN","IBJDF6",95,0)
S DIR("T")=DTIME,DIR("?")="^S IBOFF=19 D HELP^IBJDF6H"
"RTN","IBJDF6",96,0)
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
"RTN","IBJDF6",97,0)
S IBSAM=+Y K DIROUT,DTOUT,DUOUT,DIRUT G:'IBSAM EXCEL
"RTN","IBJDF6",98,0)
;
"RTN","IBJDF6",99,0)
AMT1 ; - Determine the minimum balance amount.
"RTN","IBJDF6",100,0)
S DIR(0)="NA^1:9999999"
"RTN","IBJDF6",101,0)
S DIR("A")="Enter the minimum balance amount of the receivable: "
"RTN","IBJDF6",102,0)
S DIR("T")=DTIME,DIR("?")="^S IBOFF=26 D HELP^IBJDF6H"
"RTN","IBJDF6",103,0)
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
"RTN","IBJDF6",104,0)
S IBSAM=+Y K DIROUT,DTOUT,DUOUT,DIRUT
"RTN","IBJDF6",105,0)
;
"RTN","IBJDF6",106,0)
EXCEL ; - Determine whether to gather data for Excel report.
"RTN","IBJDF6",107,0)
S IBEXCEL=$$EXCEL^IBJD() G ENQ:IBEXCEL="^"
"RTN","IBJDF6",108,0)
I IBEXCEL S IBSH=1,IBSH1="M" G DEV
"RTN","IBJDF6",109,0)
;
"RTN","IBJDF6",110,0)
BCH ; - Determine whether to include the bill comment history.
"RTN","IBJDF6",111,0)
S DIR(0)="Y",DIR("B")="NO" W !
"RTN","IBJDF6",112,0)
S DIR("A")="Include the bill comment history with each receivable"
"RTN","IBJDF6",113,0)
S DIR("T")=DTIME,DIR("?")="^S IBOFF=31 D HELP^IBJDF6H"
"RTN","IBJDF6",114,0)
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
"RTN","IBJDF6",115,0)
S IBSH=+Y K DIROUT,DTOUT,DUOUT,DIRUT G:'IBSH DEV
"RTN","IBJDF6",116,0)
;
"RTN","IBJDF6",117,0)
S DIR(0)="SA^A:ALL;M:MOST RECENT"
"RTN","IBJDF6",118,0)
S DIR("A")="Print (A)LL comments or the (M)OST RECENT comment: "
"RTN","IBJDF6",119,0)
S DIR("B")="ALL",DIR("T")=DTIME,DIR("?")="^S IBOFF=40 D HELP^IBJDF6H"
"RTN","IBJDF6",120,0)
D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
"RTN","IBJDF6",121,0)
S IBSH1=Y K DIROUT,DTOUT,DUOUT,DIRUT G:IBSH1="A" DEV
"RTN","IBJDF6",122,0)
;
"RTN","IBJDF6",123,0)
S DIR(0)="NAO^1:999"
"RTN","IBJDF6",124,0)
S DIR("A")="Minimum age of most recent bill comment (optional): "
"RTN","IBJDF6",125,0)
S DIR("T")=DTIME,DIR("?")="^S IBOFF=47 D HELP^IBJDF6H"
"RTN","IBJDF6",126,0)
D ^DIR K DIR G:$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ
"RTN","IBJDF6",127,0)
S IBSH2=+Y W:IBSH2 " DAYS" K DIROUT,DTOUT,DUOUT,DIRUT
"RTN","IBJDF6",128,0)
;
"RTN","IBJDF6",129,0)
DEV ; - Select a device.
"RTN","IBJDF6",130,0)
K IB0,IB1,IB2
"RTN","IBJDF6",131,0)
I '$G(IBEXCEL) D
"RTN","IBJDF6",132,0)
. S X=$S(IBRPT="S":80,1:132)
"RTN","IBJDF6",133,0)
. W !!,"You will need a ",X," column printer for this report!",!
"RTN","IBJDF6",134,0)
. W !,"Note: This report will search through all active receivables."
"RTN","IBJDF6",135,0)
. W !," You should queue it to run after normal business hours.",!
"RTN","IBJDF6",136,0)
;
"RTN","IBJDF6",137,0)
I $G(IBEXCEL) D EXMSG^IBJD
"RTN","IBJDF6",138,0)
;
"RTN","IBJDF6",139,0)
W ! S %ZIS="QM" D ^%ZIS G:POP ENQ
"RTN","IBJDF6",140,0)
I $D(IO("Q")) D G ENQ
"RTN","IBJDF6",141,0)
. S ZTRTN="DQ^IBJDF6",ZTDESC="IB - MISC. BILLS FOLLOW-UP REPORT"
"RTN","IBJDF6",142,0)
. F I="IB*","VAUTD","VAUTD(" S ZTSAVE(I)=""
"RTN","IBJDF6",143,0)
. D ^%ZTLOAD
"RTN","IBJDF6",144,0)
. I $D(ZTSK) W !!,"This job has been queued. Task number is ",ZTSK,"."
"RTN","IBJDF6",145,0)
. E W !!,"Unable to queue this job."
"RTN","IBJDF6",146,0)
. K ZTSK,IO("Q") D HOME^%ZIS
"RTN","IBJDF6",147,0)
;
"RTN","IBJDF6",148,0)
U IO
"RTN","IBJDF6",149,0)
;
"RTN","IBJDF6",150,0)
; If called by the Extraction Module, change extract status for the 3
"RTN","IBJDF6",151,0)
; reports: No-fault auto accident, Tort Feasor and Workman's Comp
"RTN","IBJDF6",152,0)
DQ I $G(IBXTRACT) F I=22:1:24 D E^IBJDE(I,1)
"RTN","IBJDF6",153,0)
;
"RTN","IBJDF6",154,0)
D ST^IBJDF61 ; Compile and print the report.
"RTN","IBJDF6",155,0)
;
"RTN","IBJDF6",156,0)
ENQ K IBSDA,IBSDF,IBSDL,IBSDV,IBSEL,IBSN,IBSNA,IBSNF,IBSNL,IBSH,IBSH1,IBSH2
"RTN","IBJDF6",157,0)
K IBCTG,IBCTS,IBOFF,IBPRT,IBRPT,IBSAM,IBSMN,IBSMX,IBTEXT,IBI,DIROUT
"RTN","IBJDF6",158,0)
K DTOUT,DUOUT,DIRUT,POP,VAUTD,%ZIS,ZTDESC,ZTRTN,ZTSAVE,I,X,Y,Z
"RTN","IBJDF6",159,0)
Q
"RTN","IBJDF61")
0^18^B66883609
"RTN","IBJDF61",1,0)
IBJDF61 ;ALB/RB - MISC. BILLS FOLLOW-UP REPORT (COMPILE) ;15-APR-00
"RTN","IBJDF61",2,0)
;;2.0;INTEGRATED BILLING;**123,159,356,618**;21-MAR-94;Build 60
"RTN","IBJDF61",3,0)
;;Per VHA Directive 6402, this routine should not be modified.
"RTN","IBJDF61",4,0)
;
"RTN","IBJDF61",5,0)
ST ; - Tasked entry point.
"RTN","IBJDF61",6,0)
K IB,IBCAT,^TMP("IBJDF6P",$J),^TMP("IBJDF6D",$J) S IBQ=0
"RTN","IBJDF61",7,0)
N IBPDFLG ;Patient (1) or Debtor (0) flag
"RTN","IBJDF61",8,0)
;
"RTN","IBJDF61",9,0)
; - Set selected categories for report.
"RTN","IBJDF61",10,0)
; IB*2.0*618 - Added Community Care Misc. Categories
"RTN","IBJDF61",11,0)
I IBSEL[",1," S IBCAT(21)=1 ; MEDICARE
"RTN","IBJDF61",12,0)
I IBSEL[",2," S IBCAT(7)=2 ; NO-FAULT AUTO ACCIDENT
"RTN","IBJDF61",13,0)
I IBSEL[",3," D ; COMMUNITY CARE NO-FAULT AUTO
"RTN","IBJDF61",14,0)
. S IBCAT(52)=3
"RTN","IBJDF61",15,0)
. S IBCAT(55)=3
"RTN","IBJDF61",16,0)
. S IBCAT(58)=3
"RTN","IBJDF61",17,0)
I IBSEL[",4," S IBCAT(10)=4 ; TORT FEASOR
"RTN","IBJDF61",18,0)
I IBSEL[",5," D ; COMMUNITY CARE TORT FEASOR
"RTN","IBJDF61",19,0)
. S IBCAT(53)=5
"RTN","IBJDF61",20,0)
. S IBCAT(56)=5
"RTN","IBJDF61",21,0)
. S IBCAT(59)=5
"RTN","IBJDF61",22,0)
I IBSEL[6 S IBCAT(6)=6 ; WORKMEN'S COMP
"RTN","IBJDF61",23,0)
I IBSEL[7 D ; COMMUNITY CARE NO-FAULT AUTO
"RTN","IBJDF61",24,0)
. S IBCAT(54)=7
"RTN","IBJDF61",25,0)
. S IBCAT(57)=7
"RTN","IBJDF61",26,0)
. S IBCAT(60)=7
"RTN","IBJDF61",27,0)
I IBSEL[8 S IBCAT(16)=8 ; CURRENT EMPLOYEE
"RTN","IBJDF61",28,0)
I IBSEL[9 S IBCAT(15)=9 ; EX-EMPLOYEE
"RTN","IBJDF61",29,0)
I IBSEL[10 S IBCAT(13)=10 ; FEDERAL AGENCIES-REFUND
"RTN","IBJDF61",30,0)
I IBSEL[11 S IBCAT(14)=11 ; FEDERAL AGENCIES-REIMBURSEMENT
"RTN","IBJDF61",31,0)
I IBSEL[12 S IBCAT(12)=12 ; MILITARY
"RTN","IBJDF61",32,0)
I IBSEL[13 S IBCAT(20)=13 ; INTERAGENCY
"RTN","IBJDF61",33,0)
I IBSEL[14 S IBCAT(17)=14 ; VENDOR
"RTN","IBJDF61",34,0)
;
"RTN","IBJDF61",35,0)
; Initialize the Summary Information
"RTN","IBJDF61",36,0)
S IBCAT="" F S IBCAT=$O(IBCAT(IBCAT)) Q:IBCAT="" D
"RTN","IBJDF61",37,0)
. S IBDIV=0
"RTN","IBJDF61",38,0)
. I IBSDV,$$CATCHK(IBCAT) D Q ;IB*2.0*618
"RTN","IBJDF61",39,0)
. . F S IBDIV=$O(VAUTD(IBDIV)) Q:IBDIV="" D INIT^IBJDF63
"RTN","IBJDF61",40,0)
. D INIT^IBJDF63
"RTN","IBJDF61",41,0)
;
"RTN","IBJDF61",42,0)
; - Print the header line for the Excel spreadsheet
"RTN","IBJDF61",43,0)
I $G(IBEXCEL) D PHDL
"RTN","IBJDF61",44,0)
;
"RTN","IBJDF61",45,0)
; - Find data required for the report.
"RTN","IBJDF61",46,0)
S IBA=0 F S IBA=$O(^PRCA(430,"AC",16,IBA)) Q:'IBA D Q:IBQ
"RTN","IBJDF61",47,0)
. I IBA#100=0 D Q:IBQ
"RTN","IBJDF61",48,0)
. . S IBQ=$$STOP^IBOUTL("Miscellaneous Bills Follow-Up Report")
"RTN","IBJDF61",49,0)
. S IBAR=$G(^PRCA(430,IBA,0)) Q:'IBAR
"RTN","IBJDF61",50,0)
. S IBCAT=+$P(IBAR,U,2) Q:'$D(IBCAT(IBCAT)) ; Invalid AR category.
"RTN","IBJDF61",51,0)
. S IBCAT1=IBCAT(IBCAT),IBPDFLG=$$CATCHK(IBCAT)
"RTN","IBJDF61",52,0)
. I IBPDFLG,'$D(^DGCR(399,IBA,0)) Q ; No claim.
"RTN","IBJDF61",53,0)
. I IBPDFLG,$P($G(^DGCR(399,IBA,0)),U,13)=7 Q ; Cancelled claim.
"RTN","IBJDF61",54,0)
. ;
"RTN","IBJDF61",55,0)
. ; - Get division, if necessary.
"RTN","IBJDF61",56,0)
. I (IBCAT1>7),(IBCAT1<15) S IBDIV=0 ;IB*2.0*618
"RTN","IBJDF61",57,0)
. E D
"RTN","IBJDF61",58,0)
. . I 'IBSDV S IBDIV=0
"RTN","IBJDF61",59,0)
. . E S IBDIV=$$DIV^IBJDF51(IBA)
"RTN","IBJDF61",60,0)
. ;
"RTN","IBJDF61",61,0)
. I IBSDV,IBDIV,'VAUTD Q:'$D(VAUTD(IBDIV)) ; Not a selected division.
"RTN","IBJDF61",62,0)
. ;
"RTN","IBJDF61",63,0)
. ; - Get patient or debtor for report.
"RTN","IBJDF61",64,0)
. I IBRPT="D" S IBPTDB=$$PTDB(IBA) Q:IBPTDB=""
"RTN","IBJDF61",65,0)
. ;
"RTN","IBJDF61",66,0)
. ; - Check the receivable age, if necessary.
"RTN","IBJDF61",67,0)
. I IBRPT="D",IBSMN D I (IBARD)<IBSMN!(IBARD>IBSMX) Q
"RTN","IBJDF61",68,0)
. . S IBARD=+$$ACT^IBJDF2(IBA) S:IBARD IBARD=$$FMDIFF^XLFDT(DT,IBARD)
"RTN","IBJDF61",69,0)
. ;
"RTN","IBJDF61",70,0)
. ; - Check the minimum balance amount, if necessary.
"RTN","IBJDF61",71,0)
. S IBBA=0 F X=1:1:5 S IBBA=IBBA+$P($G(^PRCA(430,IBA,7)),U,X)
"RTN","IBJDF61",72,0)
. I IBRPT="D",IBSAM,IBBA<IBSAM Q
"RTN","IBJDF61",73,0)
. ;
"RTN","IBJDF61",74,0)
. ; - Get stats for summary
"RTN","IBJDF61",75,0)
. I '$G(IBEXCEL) D EN^IBJDF63 Q:IBRPT="S"
"RTN","IBJDF61",76,0)
. ;
"RTN","IBJDF61",77,0)
. ; - Get remaining AR/claim info and set indexes for detailed report.
"RTN","IBJDF61",78,0)
. S (IBFR,IBLP,IBOI,IBTO,IBCLM)="",IBIN=0
"RTN","IBJDF61",79,0)
. S IBBN=$P(IBAR,U),IBOR=$P(IBAR,U,3),IBDP=$P(IBAR,U,10)
"RTN","IBJDF61",80,0)
. I IBPDFLG D Q:'IBI!('IBCLM) ;IB*2.0*618
"RTN","IBJDF61",81,0)
. . S IBI=+$G(^DGCR(399,IBA,"MP")) Q:'IBI ; Get primary ins carrier.
"RTN","IBJDF61",82,0)
. . S IBIN=$P($G(^DIC(36,IBI,0)),U)_"@@"_IBI,DFN=$P($P(IBPTDB,U),"@@",2)
"RTN","IBJDF61",83,0)
. . S IBDP=$P(IBAR,U,10),IBCLM=$$CLMACT^IBJD(IBA,IBCAT) Q:IBCLM=""
"RTN","IBJDF61",84,0)
. . S IBR=$S(+IBCLM=1:$G(^IB($P(IBCLM,U,2),0)),+IBCLM=2:$G(^DGCR(399,IBA,"U")),1:IBDP)
"RTN","IBJDF61",85,0)
. . S IBFR=$P(IBR,U,$S(+IBCLM=1:14,1:1)),IBTO=$P(IBR,U,$S(+IBCLM=1:15,+IBCLM=2:2,1:1))
"RTN","IBJDF61",86,0)
. . S IBOI=$$OTH(DFN,$P(IBIN,"@@",2),IBFR) ; Get other insurance carrier.
"RTN","IBJDF61",87,0)
. . I $G(IBEXCEL) Q
"RTN","IBJDF61",88,0)
. . I '($D(^TMP("IBJDF6P",$J,IBDIV,IBCAT,IBIN,$P(IBPTDB,U)))#10) D
"RTN","IBJDF61",89,0)
. . . S ^TMP("IBJDF6P",$J,IBDIV,IBCAT,IBIN,$P(IBPTDB,U))=$P(IBPTDB,U,2)_" "_$P(IBPTDB,U,6)_U_$P(IBPTDB,U,3,4)_U_IBOI
"RTN","IBJDF61",90,0)
. . S ^TMP("IBJDF6P",$J,IBDIV,IBCAT,IBIN,$P(IBPTDB,U),IBBN)=IBDP_U_IBFR_U_IBTO_U_IBOR_U_IBBA
"RTN","IBJDF61",91,0)
. I 'IBPDFLG D
"RTN","IBJDF61",92,0)
. . S IBLP=+$P($$PYMT^IBJD1(IBA),U,2)
"RTN","IBJDF61",93,0)
. . I '($D(^TMP("IBJDF6D",$J,IBDIV,IBCAT,0,$P(IBPTDB,U)))#10) D
"RTN","IBJDF61",94,0)
. . . S ^TMP("IBJDF6D",$J,IBDIV,IBCAT,0,$P(IBPTDB,U))=$P(IBPTDB,U,2)_" "_$P(IBPTDB,U,6)
"RTN","IBJDF61",95,0)
. . S ^TMP("IBJDF6D",$J,IBDIV,IBCAT,0,$P(IBPTDB,U),IBBN)=IBDP_U_$P(IBPTDB,U,5)_U_IBOR_U_IBLP_U_IBBA
"RTN","IBJDF61",96,0)
. ;
"RTN","IBJDF61",97,0)
. I '$G(IBEXCEL) D:IBSH COM Q
"RTN","IBJDF61",98,0)
. ;
"RTN","IBJDF61",99,0)
. ; - Set up and write line for Excel document.
"RTN","IBJDF61",100,0)
. S IBDIV=$P($G(^DG(40.8,$S('IBDIV:+$$PRIM^VASITE(),1:IBDIV),0)),U)
"RTN","IBJDF61",101,0)
. S IBEXCEL1=IBDIV_U_$P($G(^PRCA(430.2,IBCAT,0)),U,2)_U_$S(IBIN=0:"",1:$P(IBIN,"@@"))
"RTN","IBJDF61",102,0)
. S IBEXCEL1=IBEXCEL1_U_$P(IBPTDB,U,2)_U_$S($P(IBPTDB,"^",6)="*":"E",1:"")_U_$TR($P(IBPTDB,U,4),"-")
"RTN","IBJDF61",103,0)
. S IBEXCEL1=IBEXCEL1_U_$P(IBPTDB,U,3)_U_IBOI_U_IBBN_U_$$DT^IBJD(IBDP,1)
"RTN","IBJDF61",104,0)
. S IBEXCEL1=IBEXCEL1_U_$$DT^IBJD(IBFR,1)_U_$$DT^IBJD(IBTO,1)_U_IBOR
"RTN","IBJDF61",105,0)
. S IBEXCEL1=IBEXCEL1_U_IBLP_U_IBBA_U
"RTN","IBJDF61",106,0)
. I IBSH D COM ; This will capture the Last Comment Date
"RTN","IBJDF61",107,0)
. S IBD=$$FMDIFF^XLFDT(DT,$S('$P(IBEXCEL1,U,17):IBDP,1:$G(DAT)))
"RTN","IBJDF61",108,0)
. S IBEXCEL1=IBEXCEL1_U_IBD W !,IBEXCEL1 K IBD,IBEXCEL1
"RTN","IBJDF61",109,0)
;
"RTN","IBJDF61",110,0)
I 'IBQ,'$G(IBEXCEL) D EN^IBJDF62 ; Print the report.
"RTN","IBJDF61",111,0)
;
"RTN","IBJDF61",112,0)
ENQ K ^TMP("IBJDF6P",$J),^TMP("IBJDF6D",$J)
"RTN","IBJDF61",113,0)
I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
"RTN","IBJDF61",114,0)
;
"RTN","IBJDF61",115,0)
D ^%ZISC
"RTN","IBJDF61",116,0)
ENQ1 K IBA,IBA1,IBAR,IBARD,IBCAT,IBCAT1,IBDIV,IBD,IBI,IBIN,IBQ,IBR,IBOI,IBBA
"RTN","IBJDF61",117,0)
K IBBN,IBCLM,IBDP,IBEXCEL,IBFR,IBLP,IBOR,IBPTDB,IBTO,IBTYP,COM
"RTN","IBJDF61",118,0)
K COM1,DAT,DFN,J,X,X1,X2,Y,Z
"RTN","IBJDF61",119,0)
Q
"RTN","IBJDF61",120,0)
;
"RTN","IBJDF61",121,0)
PTDB(X) ; - Find Patient/Debtor and decide to include the AR.
"RTN","IBJDF61",122,0)
; Input: X=Pointer to the AR in file #430 plus all IBS* variables
"RTN","IBJDF61",123,0)
; Output: Y=Sort key (name or last 4) and Patient/Debtor IEN(file #2)
"RTN","IBJDF61",124,0)
; ^ Patient/Debtor name (1st 25 chars) ^ Age ^ SSN
"RTN","IBJDF61",125,0)
; ^ Processed by (File #200) ^ Current VA Employee? (*=Yes)
"RTN","IBJDF61",126,0)
N AGE,ALL,ARZ,CAT,DEB,DA,DFN,DIC,DIQ,DR,END,IBZ,INI,KEY,NAME,PRC,SSN
"RTN","IBJDF61",127,0)
N VA,VADM,VAERR,Y,IBPTFLG
"RTN","IBJDF61",128,0)
;
"RTN","IBJDF61",129,0)
S Y="" I '$G(X) G PDQ
"RTN","IBJDF61",130,0)
S DFN=0,ARZ=$G(^PRCA(430,X,0)),CAT=$P(ARZ,"^",2)
"RTN","IBJDF61",131,0)
S (NAME,AGE,SSN,PRC)=""
"RTN","IBJDF61",132,0)
;
"RTN","IBJDF61",133,0)
; - Look for Patient (Medicare,Tort Feasor,Work's Comp,No-Fault Auto Acc)
"RTN","IBJDF61",134,0)
S IBPTFLG=$$CATCHK(CAT) ;IB*2.0*618
"RTN","IBJDF61",135,0)
I IBPTFLG D I 'DFN S Y="" G PDQ
"RTN","IBJDF61",136,0)
. I '$D(^DGCR(399,X,0)) Q
"RTN","IBJDF61",137,0)
. S IBZ=^DGCR(399,X,0),DFN=+$P(IBZ,"^",2)
"RTN","IBJDF61",138,0)
. S INI=IBSNF,END=IBSNL,ALL=IBSNA
"RTN","IBJDF61",139,0)
. D DEM^VADPT S NAME=VADM(1),SSN=$P(VADM(2),"^",2),AGE=VADM(4)
"RTN","IBJDF61",140,0)
. S KEY=$S(IBSN="N":NAME,1:$P(SSN,"-",3))
"RTN","IBJDF61",141,0)
. ; - Look for Debtor (All the other Categories)
"RTN","IBJDF61",142,0)
I 'IBPTFLG D I 'DFN S Y="" G PDQ
"RTN","IBJDF61",143,0)
. S DIC="^PRCA(430,",DA=X,DR="9;97",DIQ="DEB" D EN^DIQ1
"RTN","IBJDF61",144,0)
. S DFN=+$P(ARZ,"^",9) I 'DFN Q
"RTN","IBJDF61",145,0)
. S NAME=$G(DEB(430,DA,9)),PRC=$G(DEB(430,DA,97)),KEY=NAME
"RTN","IBJDF61",146,0)
. S DIC="^RCD(340,",DA=DFN,DR="110",DIQ="DEB" D EN^DIQ1
"RTN","IBJDF61",147,0)
. S SSN=$G(DEB(340,DA,110)) S:SSN=-1 SSN=""
"RTN","IBJDF61",148,0)
. S INI=IBSDF,END=IBSDL,ALL=IBSDA
"RTN","IBJDF61",149,0)
;
"RTN","IBJDF61",150,0)
I (INI'="@"&('DFN)) S Y="" G PDQ
"RTN","IBJDF61",151,0)
I ALL="ALL"&('DFN)!(ALL="NULL"&(DFN)) S Y="" G PDQ
"RTN","IBJDF61",152,0)
I INI="@",END="zzzzz" G PDC
"RTN","IBJDF61",153,0)
I INI]KEY!(KEY]END) S Y="" G PDQ
"RTN","IBJDF61",154,0)
;
"RTN","IBJDF61",155,0)
S KEY=KEY_"@@"_DFN
"RTN","IBJDF61",156,0)
PDC S Y=KEY_U_$E(NAME,1,25)_U_AGE_U_SSN_U_PRC_U_$$VAEMP(+$TR(SSN,"-"))
"RTN","IBJDF61",157,0)
PDQ Q Y
"RTN","IBJDF61",158,0)
;
"RTN","IBJDF61",159,0)
PHDL ; - Print the header line for the Excel spreadsheet
"RTN","IBJDF61",160,0)
N X
"RTN","IBJDF61",161,0)
S X="Division^Cat.^Prim.Ins.Carrier^Patient/Debtor^VA Empl.?^SSN^Age^"
"RTN","IBJDF61",162,0)
S X=X_"Other Ins.Carrier^Bill #^Dt Bill prep.^Bill From Dt^Bill To Dt^"
"RTN","IBJDF61",163,0)
S X=X_"Orig.Amt^Lst Pymt Amt^Curr.Bal.^Lst Comm.Dt^Days Lst Comm."
"RTN","IBJDF61",164,0)
W !,X
"RTN","IBJDF61",165,0)
Q
"RTN","IBJDF61",166,0)
;
"RTN","IBJDF61",167,0)
VAEMP(SSN) ; - Check if the Patient/Debtor is a current VA Employee
"RTN","IBJDF61",168,0)
; Input: SSN - Patient/Debtor Social Security Number
"RTN","IBJDF61",169,0)
;Output: VAEMP - "*":Current VA Employee / "":Not a Current VA Employee
"RTN","IBJDF61",170,0)
;
"RTN","IBJDF61",171,0)
N IEN I 'SSN Q ""
"RTN","IBJDF61",172,0)
S IEN=+$O(^PRSPC("SSN",SSN,0)) Q:'IEN ""
"RTN","IBJDF61",173,0)
I $P($G(^PRSPC(IEN,1)),U,33)'="Y" Q "*"
"RTN","IBJDF61",174,0)
Q ""
"RTN","IBJDF61",175,0)
;
"RTN","IBJDF61",176,0)
OTH(DFN,INS,DS) ; - Find a patient's other valid insurance carrier (if any).
"RTN","IBJDF61",177,0)
; Input: DFN=Pointer to the patient in file #2
"RTN","IBJDF61",178,0)
; INS=Pointer to the patient's primary carrier in file #36
"RTN","IBJDF61",179,0)
; DS=Date of service for validity check
"RTN","IBJDF61",180,0)
; Output: Valid insurance carrier (first 22 chars.) or null
"RTN","IBJDF61",181,0)
N Y S Y="" G:'$G(DFN)!('$G(DS)) OTHQ
"RTN","IBJDF61",182,0)
S Z=0 F S Z=$O(^DPT(DFN,.312,Z)) Q:'Z S X=$G(^(Z,0)) D:X Q:Y]""
"RTN","IBJDF61",183,0)
.I $G(INS),+X=INS Q
"RTN","IBJDF61",184,0)
.S X1=$G(^DIC(36,+X,0)) Q:X1=""
"RTN","IBJDF61",185,0)
.I $P(X1,U,2)'="N",$$CHK^IBCNS1(X,DS) S Y=$E($P(X1,U),1,22)
"RTN","IBJDF61",186,0)
;
"RTN","IBJDF61",187,0)
OTHQ Q Y
"RTN","IBJDF61",188,0)
;
"RTN","IBJDF61",189,0)
COM ; - Get bill comments.
"RTN","IBJDF61",190,0)
N IBGLB,DAT,IBA1,IBC,COM,COM1,X1,X2
"RTN","IBJDF61",191,0)
;
"RTN","IBJDF61",192,0)
S DAT=0,IBA1=$S(IBSH1="M":999999999,1:0)
"RTN","IBJDF61",193,0)
F S IBA1=$S(IBSH1="M":$O(^PRCA(433,"C",IBA,IBA1),-1),1:$O(^PRCA(433,"C",IBA,IBA1))) Q:'IBA1 D I IBSH1="M",DAT Q
"RTN","IBJDF61",194,0)
. S IBC=$G(^PRCA(433,IBA1,1)) Q:'IBC
"RTN","IBJDF61",195,0)
. I $G(IBSH2),$$FMDIFF^XLFDT(DT,+IBC)<IBSH2 Q ; Comment age not minimum.
"RTN","IBJDF61",196,0)
. I $P(IBC,U,2)'=35,$P(IBC,U,2)'=45 Q ; Not decrease/comment transact.
"RTN","IBJDF61",197,0)
. S DAT=$S(IBC:+IBC\1,1:+$P(IBC,U,9)\1)
"RTN","IBJDF61",198,0)
. I $G(IBEXCEL),IBSH1="M" S IBEXCEL1=IBEXCEL1_$$DT^IBJD(DAT,1) Q
"RTN","IBJDF61",199,0)
. ;
"RTN","IBJDF61",200,0)
. ; - Append brief and transaction comments.
"RTN","IBJDF61",201,0)
. K COM,COM1 S COM(0)=DAT,X1=0
"RTN","IBJDF61",202,0)
. S COM1(1)=$P($G(^PRCA(433,IBA1,5)),U,2)
"RTN","IBJDF61",203,0)
. S COM1(2)=$E($P($G(^PRCA(433,IBA1,8)),U,6),1,70)
"RTN","IBJDF61",204,0)
. S COM(1)=COM1(1)_$S(COM1(1)]""&(COM1(2)]""):"|",1:"")_COM1(2)
"RTN","IBJDF61",205,0)
. I COM(1)]"" S COM(1)="**"_COM(1)_"**",X1=1
"RTN","IBJDF61",206,0)
. ;
"RTN","IBJDF61",207,0)
. ; - Get main comments.
"RTN","IBJDF61",208,0)
. S X2=0 F S X2=$O(^PRCA(433,IBA1,7,X2)) Q:'X2 S COM($S(X1:X2+1,1:X2))=^(X2,0)
"RTN","IBJDF61",209,0)
. ;
"RTN","IBJDF61",210,0)
. S X1="" F S X1=$O(COM(X1)) Q:X1="" D
"RTN","IBJDF61",211,0)
. . S IBGLB=$S(IBCAT1<8:"IBJDF6P",1:"IBJDF6D") ;IB*2.0*618
"RTN","IBJDF61",212,0)
. . S ^TMP(IBGLB,$J,IBDIV,IBCAT,IBIN,$P(IBPTDB,U),IBBN,IBA1,X1)=COM(X1)
"RTN","IBJDF61",213,0)
;
"RTN","IBJDF61",214,0)
Q
"RTN","IBJDF61",215,0)
CATCHK(IBCAT) ; Check to see if the AR Category should be a patient or Debtor Category
"RTN","IBJDF61",216,0)
; Output: 1 - Patient, 0 - Debtor (default)
"RTN","IBJDF61",217,0)
Q:IBCAT=6 1 ;Worker's Comp
"RTN","IBJDF61",218,0)
Q:IBCAT=7 1 ;No Fault
"RTN","IBJDF61",219,0)
Q:IBCAT=10 1 ;Tort
"RTN","IBJDF61",220,0)
Q:IBCAT=21 1 ;Medicare
"RTN","IBJDF61",221,0)
I (IBCAT>51),(IBCAT<61) Q 1 ; a WC, TORT or NF category for Community Care
"RTN","IBJDF61",222,0)
Q 0
"RTN","IBJDF62")
0^21^B35799175
"RTN","IBJDF62",1,0)
IBJDF62 ;ALB/RB - MISC. BILLS FOLLOW-UP REPORT (PRINT) ;15-APR-00
"RTN","IBJDF62",2,0)
;;2.0;INTEGRATED BILLING;**123,159,618**;21-MAR-94;Build 60
"RTN","IBJDF62",3,0)
;;Per VHA Directive 6402, this routine should not be modified.
"RTN","IBJDF62",4,0)
;
"RTN","IBJDF62",5,0)
;Read ^PRCA(430.2) via Private IA 594
"RTN","IBJDF62",6,0)
;
"RTN","IBJDF62",7,0)
EN ; - Print the Follow-up report.
"RTN","IBJDF62",8,0)
S IBQ=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%) G:IBRPT="S" SUM
"RTN","IBJDF62",9,0)
I 'IBSDV D DET(0) G SUM
"RTN","IBJDF62",10,0)
S IBDIV=""
"RTN","IBJDF62",11,0)
F S IBDIV=$O(VAUTD(IBDIV)) Q:IBDIV="" D Q:IBQ
"RTN","IBJDF62",12,0)
. D DET(IBDIV)
"RTN","IBJDF62",13,0)
;
"RTN","IBJDF62",14,0)
SUM I 'IBQ D PRT^IBJDF63 ; Print summary.
"RTN","IBJDF62",15,0)
ENQ K IBN,IBIN,IBC,IBCD,IBC1,IBC2,IBCAT1,IBD,IBDIV,IBGBL,IBPAG,IBP,IBPD,IBPTD,IBQ,IBRUN,%
"RTN","IBJDF62",16,0)
Q
"RTN","IBJDF62",17,0)
;
"RTN","IBJDF62",18,0)
DET(IBDIV) ; - Print report for a specific division.
"RTN","IBJDF62",19,0)
; Input: IBDIV=Pointer to the division in file #40.8
"RTN","IBJDF62",20,0)
S IBCAT=0
"RTN","IBJDF62",21,0)
F S IBCAT=$O(IBCAT(IBCAT)) Q:'IBCAT D Q:IBQ
"RTN","IBJDF62",22,0)
. S IBCAT1=IBCAT(IBCAT),IBGBL=$S(IBCAT1<8:"IBJDF6P",1:"IBJDF6D") ;IB*2.0*618
"RTN","IBJDF62",23,0)
. I IBDIV,IBCAT1'<8 Q ;IB*2.0*618
"RTN","IBJDF62",24,0)
. I IBSDV,'IBDIV,IBCAT1<8 Q ;IB*2.0*618
"RTN","IBJDF62",25,0)
. I '$D(^TMP(IBGBL,$J,IBDIV,IBCAT)) D HDR1 Q:IBQ D NAR,PAUSE Q
"RTN","IBJDF62",26,0)
. D HDR1 Q:IBQ
"RTN","IBJDF62",27,0)
. S IBIN="" F S IBIN=$O(^TMP(IBGBL,$J,IBDIV,IBCAT,IBIN)) Q:IBIN="" D Q:IBQ
"RTN","IBJDF62",28,0)
. . I $Y>(IOSL-5) D PAUSE Q:IBQ D HDR1 Q:IBQ
"RTN","IBJDF62",29,0)
. . D HDR2
"RTN","IBJDF62",30,0)
. . S (IBPTD,IB0,IBD)=""
"RTN","IBJDF62",31,0)
. . F S IBPTD=$O(^TMP(IBGBL,$J,IBDIV,IBCAT,IBIN,IBPTD)) Q:IBPTD="" D Q:IBQ
"RTN","IBJDF62",32,0)
. . . I $Y>(IOSL-5) D PAUSE Q:IBQ D HDR1,HDR2 Q:IBQ
"RTN","IBJDF62",33,0)
. . . S IBPD=$G(^TMP(IBGBL,$J,IBDIV,IBCAT,IBIN,IBPTD))
"RTN","IBJDF62",34,0)
. . . D WPAT
"RTN","IBJDF62",35,0)
. . . F S IB0=$O(^TMP(IBGBL,$J,IBDIV,IBCAT,IBIN,IBPTD,IB0)) Q:IB0="" D Q:IBQ
"RTN","IBJDF62",36,0)
. . . . S IBN=$G(^TMP(IBGBL,$J,IBDIV,IBCAT,IBIN,IBPTD,IB0))
"RTN","IBJDF62",37,0)
. . . . I $Y>(IOSL-3) D PAUSE Q:IBQ D HDR1,HDR2 Q:IBQ D WPAT
"RTN","IBJDF62",38,0)
. . . . I IBCAT1<8 D ;IB*2.0*618
"RTN","IBJDF62",39,0)
. . . . . W ?71,IB0,?84,$$DAT1^IBOUTL(+IBN),?94,$$DAT1^IBOUTL($P(IBN,U,2))
"RTN","IBJDF62",40,0)
. . . . . W ?104,$$DAT1^IBOUTL($P(IBN,U,3)),?114,$J($P(IBN,U,4),8,2)
"RTN","IBJDF62",41,0)
. . . . . W ?124,$J($P(IBN,U,5),8,2),!
"RTN","IBJDF62",42,0)
. . . . E D
"RTN","IBJDF62",43,0)
. . . . . W ?33,IB0,?47,$$DAT1^IBOUTL(+IBN),?59,$P($P(IBN,U,2),"@@")
"RTN","IBJDF62",44,0)
. . . . . W ?92,$J($P(IBN,U,3),8,2),?103,$J($P(IBN,U,4),8,2)
"RTN","IBJDF62",45,0)
. . . . . W ?114,$J($P(IBN,U,5),8,2),!
"RTN","IBJDF62",46,0)
. . . . ;
"RTN","IBJDF62",47,0)
. . . . ; - Display bill comment history, if necessary.
"RTN","IBJDF62",48,0)
. . . . I IBSH D COM
"RTN","IBJDF62",49,0)
. ;
"RTN","IBJDF62",50,0)
. I 'IBQ D PAUSE
"RTN","IBJDF62",51,0)
;
"RTN","IBJDF62",52,0)
DETQ Q
"RTN","IBJDF62",53,0)
;
"RTN","IBJDF62",54,0)
DASH(X) ; - Return a dashed line.
"RTN","IBJDF62",55,0)
Q $TR($J("",X)," ","=")
"RTN","IBJDF62",56,0)
;
"RTN","IBJDF62",57,0)
PAUSE ; - Page break.
"RTN","IBJDF62",58,0)
I $E(IOST,1,2)'="C-" Q
"RTN","IBJDF62",59,0)
N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
"RTN","IBJDF62",60,0)
F IBX=$Y:1:(IOSL-3) W !
"RTN","IBJDF62",61,0)
S DIR(0)="E" D ^DIR S:$D(DIRUT)!($D(DUOUT)) IBQ=1
"RTN","IBJDF62",62,0)
Q
"RTN","IBJDF62",63,0)
;
"RTN","IBJDF62",64,0)
HDR1 ; - Write the primary report header.
"RTN","IBJDF62",65,0)
N IBCATNM
"RTN","IBJDF62",66,0)
I $E(IOST,1,2)="C-"!$G(IBPAG) W @IOF,*13
"RTN","IBJDF62",67,0)
S IBPAG=$G(IBPAG)+1 W "Miscellaneous Bills Follow-Up Report"
"RTN","IBJDF62",68,0)
I IBDIV W " for ",$P($G(^DG(40.8,IBDIV,0)),U)
"RTN","IBJDF62",69,0)
W ?60," Run Date: ",IBRUN,?123,"Page: ",$J(IBPAG,3)
"RTN","IBJDF62",70,0)
;
"RTN","IBJDF62",71,0)
S IBCATNM=$$ARCAT(IBCAT) ; patch IB*2.0*618
"RTN","IBJDF62",72,0)
S X="ALL ACTIVE "_$G(IBCATNM)_" RECEIVABLES "
"RTN","IBJDF62",73,0)
I IBSMN S X=X_"OVER "_IBSMN_" AND LESS THAN "_IBSMX_" DAYS OLD "
"RTN","IBJDF62",74,0)
I IBCAT(IBCAT)<8 D ;IB*2.0*618
"RTN","IBJDF62",75,0)
. S X=X_" / BY PATIENT "_$S(IBSN="N":"NAME",1:"LAST 4 DIGITS OF SSN")
"RTN","IBJDF62",76,0)
. S X=X_" ("_$S($G(IBSNA)="ALL":"ALL",1:"From "_$S(IBSNF="":"FIRST",1:IBSNF)_" to "_$S(IBSNL="zzzzz":"LAST",1:IBSNL))_") / "
"RTN","IBJDF62",77,0)
I IBCAT(IBCAT)>7 D ;IB*2.0*618
"RTN","IBJDF62",78,0)
. S X=X_" / BY DEBTOR NAME"
"RTN","IBJDF62",79,0)
. S X=X_" ("_$S($G(IBSDA)="ALL":"ALL",1:"From "_$S(IBSDF="":"FIRST",1:IBSDF)_" to "_$S(IBSDL="zzzzz":"LAST",1:IBSDL))_") / "
"RTN","IBJDF62",80,0)
S X=X_$S('IBSAM:"NO ",1:"")_" MINIMUM BALANCE"
"RTN","IBJDF62",81,0)
I IBSAM S X=X_$S(IBSAM:": $"_$FN(IBSAM,",",2),1:"")
"RTN","IBJDF62",82,0)
S X=X_" / "_$S('IBSH:"NO ",IBSH1="A":"ALL ",1:"ONLY ")_"COMMENTS"
"RTN","IBJDF62",83,0)
S X=X_$S($G(IBSH2):" NOT OLDER THAN "_IBSH2_" DAYS",1:"")
"RTN","IBJDF62",84,0)
S X=X_" / '*' AFTER THE PATIENT/DEBTOR NAME = VA EMPLOYEE"
"RTN","IBJDF62",85,0)
F I=1:1 W !,$E(X,1,132) S X=$E(X,133,999) I X="" Q
"RTN","IBJDF62",86,0)
;
"RTN","IBJDF62",87,0)
I IBCAT1<8 D G HDQ ;IB*2.0*618
"RTN","IBJDF62",88,0)
.W !!?84,"Date",?94,"Bill",?104,"Bill",?114,"Original Current"
"RTN","IBJDF62",89,0)
.W !,"Patient (Age)",?33,"SSN",?47,"Other Insurance",?71,"Bill Number"
"RTN","IBJDF62",90,0)
.W ?84,"Prepared From Dte To Date",?116,"Amount Balance"
"RTN","IBJDF62",91,0)
;
"RTN","IBJDF62",92,0)
W !!?47,"Date Bill",?92,"Original Last Amt Current"
"RTN","IBJDF62",93,0)
W !,"Debtor",?33,"Bill Number Prepared Processed By",?94,"Amount"
"RTN","IBJDF62",94,0)
W ?107,"Paid Balance" S:$G(IBD) IBD=""
"RTN","IBJDF62",95,0)
HDQ W !,$$DASH(IOM),!
"RTN","IBJDF62",96,0)
S IBQ=$$STOP^IBOUTL("Miscellaneous Bills Follow-Up Report")
"RTN","IBJDF62",97,0)
Q
"RTN","IBJDF62",98,0)
;
"RTN","IBJDF62",99,0)
HDR2 ; - Write the insurance company sub-header.
"RTN","IBJDF62",100,0)
N X,X13 Q:IBCAT1>7 ;IB*2.0*618
"RTN","IBJDF62",101,0)
W ?2,"Carrier: ",$P(IBIN,"@@")
"RTN","IBJDF62",102,0)
S X=$G(^DIC(36,+$P(IBIN,"@@",2),.11)),X13=$G(^(.13))
"RTN","IBJDF62",103,0)
I X]"" D
"RTN","IBJDF62",104,0)
.W ", ",$P(X,U),", ",$P(X,U,4),", ",$P($G(^DIC(5,+$P(X,U,5),0)),U,2)," ",$P(X,U,6)
"RTN","IBJDF62",105,0)
.I $P(X13,U,2)]"" W " Billing Phone: ",$P(X13,U,2) Q
"RTN","IBJDF62",106,0)
.I $P(X13,U)]"" W " Main Phone: ",$P(X13,U)
"RTN","IBJDF62",107,0)
;
"RTN","IBJDF62",108,0)
W !
"RTN","IBJDF62",109,0)
Q
"RTN","IBJDF62",110,0)
;
"RTN","IBJDF62",111,0)
NAR ; - Write detail line (if '$D).
"RTN","IBJDF62",112,0)
N I
"RTN","IBJDF62",113,0)
W !!,"There are no active receivables "
"RTN","IBJDF62",114,0)
I IBSMN W IBSMN,$S(IBSMX>IBSMN:" to "_IBSMX,1:"")," days old "
"RTN","IBJDF62",115,0)
I IBDIV W "for this division."
"RTN","IBJDF62",116,0)
I IBSDV,IBDIV,IBCAT1<8 Q ;IB*2.0*618
"RTN","IBJDF62",117,0)
I IBSDV,'IBDIV,IBCAT1'<8 Q ;IB*2.0*618
"RTN","IBJDF62",118,0)
F I=1:1:8 S IB(+IBDIV,IBCAT,I)=""
"RTN","IBJDF62",119,0)
Q
"RTN","IBJDF62",120,0)
;
"RTN","IBJDF62",121,0)
WPAT ; - Write patient data.
"RTN","IBJDF62",122,0)
I IBCAT1<8 D Q ;IB*2.0*618
"RTN","IBJDF62",123,0)
. W $P(IBPD,U)," (",$P(IBPD,U,2),")",?33,$P(IBPD,U,3),?47,$P(IBPD,U,4)
"RTN","IBJDF62",124,0)
W $P(IBPD,U)
"RTN","IBJDF62",125,0)
Q
"RTN","IBJDF62",126,0)
;
"RTN","IBJDF62",127,0)
COM ; - Write comments
"RTN","IBJDF62",128,0)
N CONT,DIWL,DIWR,IBC,IBC1,IBC2,X
"RTN","IBJDF62",129,0)
;
"RTN","IBJDF62",130,0)
S (IBC,CONT)=0,IBC1="",DIWL=1,DIWR=104 K ^UTILITY($J,"W")
"RTN","IBJDF62",131,0)
F S IBC=$O(^TMP(IBGBL,$J,IBDIV,IBCAT,IBIN,IBPTD,IB0,IBC)) Q:'IBC D Q:IBQ
"RTN","IBJDF62",132,0)
. I $Y>(IOSL-4) D PAUSE Q:IBQ D HDR1,HDR2 Q:IBQ D WPAT W !
"RTN","IBJDF62",133,0)
. F S IBC1=$O(^TMP(IBGBL,$J,IBDIV,IBCAT,IBIN,IBPTD,IB0,IBC,IBC1)) Q:IBC1="" D Q:IBQ
"RTN","IBJDF62",134,0)
. . S IBC2=^TMP(IBGBL,$J,IBDIV,IBCAT,IBIN,IBPTD,IB0,IBC,IBC1)
"RTN","IBJDF62",135,0)
. . I $Y>(IOSL-4) D WCPB Q:IBQ
"RTN","IBJDF62",136,0)
. . I 'IBC1 S IBCD=IBC2 D WCD Q
"RTN","IBJDF62",137,0)
. . S X=IBC2 I $E(X)=" ",$L(X)>1 S $E(X)=""
"RTN","IBJDF62",138,0)
. . D ^DIWP
"RTN","IBJDF62",139,0)
. . I 'CONT,$L(IBC2)<66 D WCTXT Q
"RTN","IBJDF62",140,0)
. . S CONT=$L(IBC2)>65
"RTN","IBJDF62",141,0)
. . I '$O(^TMP(IBGBL,$J,IBDIV,IBCAT,IBIN,IBPTD,IB0,IBC,IBC1)) D
"RTN","IBJDF62",142,0)
. . . D:$D(^UTILITY($J,"W")) WCTXT
"RTN","IBJDF62",143,0)
K ^UTILITY($J,"W")
"RTN","IBJDF62",144,0)
Q
"RTN","IBJDF62",145,0)
;
"RTN","IBJDF62",146,0)
WCTXT ; - Write comment text
"RTN","IBJDF62",147,0)
N LIN,WLIN
"RTN","IBJDF62",148,0)
S LIN=""
"RTN","IBJDF62",149,0)
F S LIN=$O(^UTILITY($J,"W",1,LIN)) Q:LIN="" D Q:IBQ
"RTN","IBJDF62",150,0)
. S WLIN=$G(^UTILITY($J,"W",1,LIN,0))
"RTN","IBJDF62",151,0)
. I $Y>(IOSL-4) D WCPB Q:IBQ
"RTN","IBJDF62",152,0)
. W:WLIN'="" ?26,WLIN,!
"RTN","IBJDF62",153,0)
K ^UTILITY($J,"W")
"RTN","IBJDF62",154,0)
Q
"RTN","IBJDF62",155,0)
;
"RTN","IBJDF62",156,0)
WCPB ; - Page Break in the middle of Comments
"RTN","IBJDF62",157,0)
D PAUSE Q:IBQ D HDR1,HDR2 Q:IBQ
"RTN","IBJDF62",158,0)
W ! D WPAT W ! D WCD W:IBC1>1 ?26,"(continued)",!
"RTN","IBJDF62",159,0)
Q
"RTN","IBJDF62",160,0)
;
"RTN","IBJDF62",161,0)
WCD ; - Write comment date.
"RTN","IBJDF62",162,0)
W ?2,"Comment Date: ",$$DAT1^IBOUTL(IBCD)
"RTN","IBJDF62",163,0)
Q
"RTN","IBJDF62",164,0)
;
"RTN","IBJDF62",165,0)
ARCAT(IBCAT) ; obtain AR Category's name - patch IB*2.0*618
"RTN","IBJDF62",166,0)
N IBCATNAM
"RTN","IBJDF62",167,0)
S IBCATNAM=$$GET1^DIQ(430.2,IBCAT,.01) ; get AR CATEGORY
"RTN","IBJDF62",168,0)
Q IBCATNAM
"RTN","IBJDF63")
0^22^B22433470
"RTN","IBJDF63",1,0)
IBJDF63 ;ALB/RB - MISC. BILLS FOLLOW-UP REPORT (COMPILE/PRINT SUMMARY);15-APR-00
"RTN","IBJDF63",2,0)
;;2.0;INTEGRATED BILLING;**123,618**;21-MAR-94;Build 60
"RTN","IBJDF63",3,0)
;;Per VHA Directive 6402, this routine should not be modified.
"RTN","IBJDF63",4,0)
;
"RTN","IBJDF63",5,0)
INIT ; - Initialize counters, if necessary.
"RTN","IBJDF63",6,0)
; Quit if division selected for Debtor (doesn't split by division)
"RTN","IBJDF63",7,0)
I IBSDV,IBDIV,'$$CATCHK^IBJDF61(IBCAT) Q
"RTN","IBJDF63",8,0)
; Quit if division flag is false when a patient category and requested to
"RTN","IBJDF63",9,0)
; sort by division
"RTN","IBJDF63",10,0)
I IBSDV,'IBDIV,$$CATCHK^IBJDF61(IBCAT) Q
"RTN","IBJDF63",11,0)
; Initialize division counters
"RTN","IBJDF63",12,0)
F I=1:1:8 S IB(IBDIV,IBCAT,I)=0
"RTN","IBJDF63",13,0)
Q
"RTN","IBJDF63",14,0)
;
"RTN","IBJDF63",15,0)
EN ; - Compile entry point from IBJDF61.
"RTN","IBJDF63",16,0)
; Pre-set variables IBA, IBCAT, IBDIV required.
"RTN","IBJDF63",17,0)
N I,IB0,IBAGE,IBARD,IBOUT,J
"RTN","IBJDF63",18,0)
;
"RTN","IBJDF63",19,0)
; - Add totals for summary.
"RTN","IBJDF63",20,0)
S IBARD=$$ACT^IBJDF2(IBA) G:'IBARD ENQ ; No activation date.
"RTN","IBJDF63",21,0)
S IBOUT=0 F I=1:1:5 S IBOUT=IBOUT+$P($G(^PRCA(430,IBA,7)),U,I)
"RTN","IBJDF63",22,0)
S IBAGE=$$FMDIFF^XLFDT(DT,IBARD),IB0=$$CAT(IBAGE)
"RTN","IBJDF63",23,0)
S $P(IB(IBDIV,IBCAT,IB0),U)=+IB(IBDIV,IBCAT,IB0)+1
"RTN","IBJDF63",24,0)
S $P(IB(IBDIV,IBCAT,IB0),U,2)=$P(IB(IBDIV,IBCAT,IB0),U,2)+IBOUT
"RTN","IBJDF63",25,0)
ENQ Q
"RTN","IBJDF63",26,0)
;
"RTN","IBJDF63",27,0)
PRT ; - Print entry point from IBJDF62.
"RTN","IBJDF63",28,0)
;
"RTN","IBJDF63",29,0)
; - Extract summary data.
"RTN","IBJDF63",30,0)
I $G(IBXTRACT) D EXTMO(.IB) G ENQ1
"RTN","IBJDF63",31,0)
;
"RTN","IBJDF63",32,0)
S IBDIV=""
"RTN","IBJDF63",33,0)
F S IBDIV=$O(IB(IBDIV)) Q:IBDIV="" D SUM(IBDIV) Q:IBQ
"RTN","IBJDF63",34,0)
;
"RTN","IBJDF63",35,0)
ENQ1 Q
"RTN","IBJDF63",36,0)
;
"RTN","IBJDF63",37,0)
EXTMO(IBS) ; Extract/transmit data to DM Extract Module
"RTN","IBJDF63",38,0)
; IBS - Array containing the summary information
"RTN","IBJDF63",39,0)
;
"RTN","IBJDF63",40,0)
N IB,IBCT,IBI,IBJ,IBR,IBSQ,IBTP,IBZ
"RTN","IBJDF63",41,0)
;
"RTN","IBJDF63",42,0)
F IBI=1,2,3 F IBJ=1:1:16 S IB(IBI,IBJ)=$S(IBJ#2:0,1:"0.00")
"RTN","IBJDF63",43,0)
;
"RTN","IBJDF63",44,0)
F IBCT=6,7,10 D
"RTN","IBJDF63",45,0)
. S IBTP=0
"RTN","IBJDF63",46,0)
. I IBCT=7 S IBTP=1 ; Workman's Comp.
"RTN","IBJDF63",47,0)
. I IBCT=10 S IBTP=2 ; NO-Fault Auto Accident
"RTN","IBJDF63",48,0)
. I IBCT=6 S IBTP=3 ; Tort-Feasor
"RTN","IBJDF63",49,0)
. S IBSQ=1
"RTN","IBJDF63",50,0)
. F IBI=1:1:7 D
"RTN","IBJDF63",51,0)
. . S IBZ=$G(IBS(0,IBCT,IBI))
"RTN","IBJDF63",52,0)
. . S IB(IBTP,IBSQ)=+IBZ
"RTN","IBJDF63",53,0)
. . S IB(IBTP,IBSQ+1)=$FN(+$P(IBZ,"^",2),"",2)
"RTN","IBJDF63",54,0)
. . S IB(IBTP,15)=IB(IBTP,15)+IBZ
"RTN","IBJDF63",55,0)
. . S IB(IBTP,16)=IB(IBTP,16)+$P(IBZ,"^",2)
"RTN","IBJDF63",56,0)
. . S IBSQ=IBSQ+2
"RTN","IBJDF63",57,0)
. S IB(IBTP,16)=$FN(IB(IBTP,16),"",2)
"RTN","IBJDF63",58,0)
;
"RTN","IBJDF63",59,0)
F IBR=22:1:24 D E^IBJDE(IBR,0)
"RTN","IBJDF63",60,0)
Q
"RTN","IBJDF63",61,0)
;
"RTN","IBJDF63",62,0)
SUM(IBDIV) ; - Print summary for division.
"RTN","IBJDF63",63,0)
; Input: IBDIV=Pointer to the division in file #40.8 and pre-set
"RTN","IBJDF63",64,0)
; variable IBRPT
"RTN","IBJDF63",65,0)
N IBDH,IBTYP,I,J,Z,%
"RTN","IBJDF63",66,0)
N IBCATNM ; patch IB*2.0*618
"RTN","IBJDF63",67,0)
;
"RTN","IBJDF63",68,0)
S IBCAT=0
"RTN","IBJDF63",69,0)
F S IBCAT=$O(IB(IBDIV,IBCAT)) Q:'IBCAT D Q:IBQ
"RTN","IBJDF63",70,0)
. S IBCATNM=$$ARCAT^IBJDF62(IBCAT) ; patch IB*2.0*618
"RTN","IBJDF63",71,0)
. D HDR Q:IBQ
"RTN","IBJDF63",72,0)
. S IBTYP=$G(IBCATNM)_" RECEIVABLES"
"RTN","IBJDF63",73,0)
. W !!?(80-$L(IBTYP))\2,IBTYP
"RTN","IBJDF63",74,0)
. W !?(80-$L(IBTYP)\2),$$DASH($L(IBTYP))
"RTN","IBJDF63",75,0)
. I IBDIV D
"RTN","IBJDF63",76,0)
. . S IBDH="Division: "_$P($G(^DG(40.8,IBDIV,0)),U)
"RTN","IBJDF63",77,0)
. . W !?(80-$L(IBDH)\2),IBDH
"RTN","IBJDF63",78,0)
. ;
"RTN","IBJDF63",79,0)
. W !!
"RTN","IBJDF63",80,0)
. ;
"RTN","IBJDF63",81,0)
. ; - Calculate totals first.
"RTN","IBJDF63",82,0)
. F I=1:1:7 F J=1,2 S $P(IB(IBDIV,IBCAT,8),U,J)=$P(IB(IBDIV,IBCAT,8),U,J)+$P(IB(IBDIV,IBCAT,I),U,J)
"RTN","IBJDF63",83,0)
. ;
"RTN","IBJDF63",84,0)
. W "AR Category",?31,"# Receivables",?52,"Total Outstanding Balance",!
"RTN","IBJDF63",85,0)
. W "-----------",?31,"-------------",?52,"-------------------------"
"RTN","IBJDF63",86,0)
. I 'IB(IBDIV,IBCAT,8) W !!,"There are no active receivables",$S(IBDIV:" for this division",1:""),".",!! D PAUSE Q
"RTN","IBJDF63",87,0)
. ;
"RTN","IBJDF63",88,0)
. ; - Primary loop to write results.
"RTN","IBJDF63",89,0)
. S Y=$P(IB(IBDIV,IBCAT,8),U,2) F I=1:1:8 S X=$P($T(CATN+I),";;",2,99) D
"RTN","IBJDF63",90,0)
. . W:I=8 ! W !,X,?30,$J(+IB(IBDIV,IBCAT,I),6)
"RTN","IBJDF63",91,0)
. . W " (",$J(+IB(IBDIV,IBCAT,I)/+IB(IBDIV,IBCAT,8)*100,0,$S(I=8:0,1:2)),"%)"
"RTN","IBJDF63",92,0)
. . S Z=$FN($P(IB(IBDIV,IBCAT,I),U,2),",",2)
"RTN","IBJDF63",93,0)
. . W ?52,$J($S(I=1!(I=9):"$",1:"")_Z,15)
"RTN","IBJDF63",94,0)
. . W " (",$J($S('Y:0,1:$P(IB(IBDIV,IBCAT,I),U,2)/Y*100),0,$S(I=8:0,1:2)),"%)"
"RTN","IBJDF63",95,0)
. . W:I=8 !!
"RTN","IBJDF63",96,0)
. ;
"RTN","IBJDF63",97,0)
. D PAUSE
"RTN","IBJDF63",98,0)
;
"RTN","IBJDF63",99,0)
SUMQ Q
"RTN","IBJDF63",100,0)
;
"RTN","IBJDF63",101,0)
HDR ; - Write the summary report header.
"RTN","IBJDF63",102,0)
N X,PD,PDA,PDF,PDL
"RTN","IBJDF63",103,0)
;
"RTN","IBJDF63",104,0)
I $E(IOST,1,2)="C-"!$G(IBPAG) W @IOF,*13
"RTN","IBJDF63",105,0)
S IBPAG=$G(IBPAG)+1
"RTN","IBJDF63",106,0)
W "MISCELLANEOUS BILLS FOLLOW-UP SUMMARY REPORT"
"RTN","IBJDF63",107,0)
W ?71,"Page: ",$J(IBPAG,3),!,"Run Date: ",IBRUN
"RTN","IBJDF63",108,0)
S X=""
"RTN","IBJDF63",109,0)
I IBRPT="D" D
"RTN","IBJDF63",110,0)
. I IBSMN'="A" D
"RTN","IBJDF63",111,0)
. . S X=" RECEIVABLES OVER "_IBSMN_" AND LESS THAN "_IBSMX_" DAYS OLD "
"RTN","IBJDF63",112,0)
. ; Modified the Patient/Debtor dividing line
"RTN","IBJDF63",113,0)
. I IBCAT(IBCAT)>7 S PD="DEBTORS",PDA=IBSDA,PDF=IBSDF,PDL=IBSDL
"RTN","IBJDF63",114,0)
. I IBCAT(IBCAT)<8 S PD="PATIENTS",PDA=IBSNA,PDF=IBSNF,PDL=IBSNL
"RTN","IBJDF63",115,0)
. I $G(PDA)'="ALL" D
"RTN","IBJDF63",116,0)
. . S X=X_"/ "_PD_" FROM '"_$S(PDF="":"FIRST",1:PDF)_"' TO '"
"RTN","IBJDF63",117,0)
. . S X=X_$S(PDL="zzzzz":"LAST",1:PDL)_"' "
"RTN","IBJDF63",118,0)
. I $G(IBSAM) S X=X_"/ MINIMUM BALANCE: $"_$FN(IBSAM,",",2)_" "
"RTN","IBJDF63",119,0)
S $E(X,1,2)=""
"RTN","IBJDF63",120,0)
I X'="" F I=1:1 W !,$E(X,1,80) S X=$E(X,81,999) I X="" Q
"RTN","IBJDF63",121,0)
;
"RTN","IBJDF63",122,0)
Q
"RTN","IBJDF63",123,0)
DASH(X) ; - Return a dashed line.
"RTN","IBJDF63",124,0)
Q $TR($J("",X)," ","=")
"RTN","IBJDF63",125,0)
;
"RTN","IBJDF63",126,0)
PAUSE ; - Page break.
"RTN","IBJDF63",127,0)
I $E(IOST,1,2)'="C-" Q
"RTN","IBJDF63",128,0)
N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
"RTN","IBJDF63",129,0)
F IBX=$Y:1:(IOSL-3) W !
"RTN","IBJDF63",130,0)
S DIR(0)="E" D ^DIR S:$D(DIRUT)!($D(DUOUT)) IBQ=1
"RTN","IBJDF63",131,0)
Q
"RTN","IBJDF63",132,0)
;
"RTN","IBJDF63",133,0)
CAT(X) ; - Determine category to place receivable.
"RTN","IBJDF63",134,0)
Q $S($G(X)<31:1,X<61:2,X<91:3,X<121:4,X<181:5,X<366:6,1:7)
"RTN","IBJDF63",135,0)
;
"RTN","IBJDF63",136,0)
CATN ; - List of category names.
"RTN","IBJDF63",137,0)
;;Less than 30 days old
"RTN","IBJDF63",138,0)
;;31-60 days
"RTN","IBJDF63",139,0)
;;61-90 days
"RTN","IBJDF63",140,0)
;;91-120 days
"RTN","IBJDF63",141,0)
;;121-180 days
"RTN","IBJDF63",142,0)
;;181-365 days
"RTN","IBJDF63",143,0)
;;Over 365 days
"RTN","IBJDF63",144,0)
;;Total
"RTN","IBOCDRPT")
0^19^B19445750
"RTN","IBOCDRPT",1,0)
IBOCDRPT ;ELZ/OAK - CATASTROPHICALLY DISABLED PATIENT BILLING ;03/21/2011
"RTN","IBOCDRPT",2,0)
;;2.0;INTEGRATED BILLING;**449,618**;21-MAR-94;Build 60
"RTN","IBOCDRPT",3,0)
;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBOCDRPT",4,0)
;
"RTN","IBOCDRPT",5,0)
;
"RTN","IBOCDRPT",6,0)
EN ; - this will produce a report of patient's with charges that are CD.
"RTN","IBOCDRPT",7,0)
;
"RTN","IBOCDRPT",8,0)
N POP,%ZIS,ZTRTN,ZTDESC,ZTSK,IBEDT,IBBDT,%DT,ZTSAVE
"RTN","IBOCDRPT",9,0)
W !,"The Catastrophically Disabled legislation effective date is May 5, 2010."
"RTN","IBOCDRPT",10,0)
W !,"You should not enter a date prior to that date, any date entered before"
"RTN","IBOCDRPT",11,0)
W !,"that will be automatically changed to May 5, 2010."
"RTN","IBOCDRPT",12,0)
S %DT(0)=3100505,%DT("B")="May 5, 2010"
"RTN","IBOCDRPT",13,0)
D DATE^IBOUTL Q:'IBEDT
"RTN","IBOCDRPT",14,0)
;
"RTN","IBOCDRPT",15,0)
W !!,"Select the device for the Catastrophically Disabled Charge report. It"
"RTN","IBOCDRPT",16,0)
W !,"should be queued to a printer off hours as it can take some time to run"
"RTN","IBOCDRPT",17,0)
W !,"with at least a margin of 132 columns."
"RTN","IBOCDRPT",18,0)
S %ZIS="QM" D ^%ZIS Q:POP
"RTN","IBOCDRPT",19,0)
I $D(IO("Q")) D Q
"RTN","IBOCDRPT",20,0)
.S ZTRTN="DQ^IBOCDRPT",ZTDESC="Catastrophically Disabled Copay Report"
"RTN","IBOCDRPT",21,0)
.S (ZTSAVE("IBEDT"),ZTSAVE("IBBDT"))=""
"RTN","IBOCDRPT",22,0)
.D ^%ZTLOAD D HOME^%ZIS K IO("Q")
"RTN","IBOCDRPT",23,0)
.D MES^XPDUTL("Catastrophically Disabled Copay Report queued #"_ZTSK)
"RTN","IBOCDRPT",24,0)
DQ U IO
"RTN","IBOCDRPT",25,0)
;
"RTN","IBOCDRPT",26,0)
N IBX,IBZ,IBDT,IBDG,DFN,IBP,IBARX,IBARBILL,IBARDATA,IBDPT,IBDDT,IBQUIT
"RTN","IBOCDRPT",27,0)
;
"RTN","IBOCDRPT",28,0)
S (IBP,IBQUIT)=0
"RTN","IBOCDRPT",29,0)
D HEAD
"RTN","IBOCDRPT",30,0)
I IBBDT<3100505 S IBBDT=3100505 ; not before CD effective date
"RTN","IBOCDRPT",31,0)
S IBDDT=IBBDT-1 F S IBDDT=$O(^IB("D",IBDDT)) Q:'IBDDT!(IBQUIT) S IBX=0 F S IBX=$O(^IB("D",IBDDT,IBX)) Q:'IBX!(IBQUIT) D
"RTN","IBOCDRPT",32,0)
. S IBZ=$G(^IB(IBX,0)),DFN=+$P(IBZ,"^",2)
"RTN","IBOCDRPT",33,0)
. S IBDT=$S($E($P(IBZ,"^",4),1,2)=52:IBDDT,$P(IBZ,"^",8)="RX COPAYMENT":IBDDT,$P(IBZ,"^",15):$P(IBZ,"^",15),1:$P(IBZ,"^",14))
"RTN","IBOCDRPT",34,0)
. K IBDG
"RTN","IBOCDRPT",35,0)
. S IBDG=$$GET^DGENCDA(DFN,.IBDG) ; IA# 4969
"RTN","IBOCDRPT",36,0)
. S IBARX=+$O(^PRCA(430,"B",$S($P(IBZ,"^",11):$P(IBZ,"^",11),1:0),0)) ; IA# 389
"RTN","IBOCDRPT",37,0)
. S IBARBILL=$S(IBARX:$$BILL^RCJIBFN2(IBARX),1:"") ; IA# 1452
"RTN","IBOCDRPT",38,0)
. K IBARDATA
"RTN","IBOCDRPT",39,0)
. I IBARX D DIQ^RCJIBFN2(IBARX,"77:79;141;203;255.1","IBARDATA") ; IA# 1452
"RTN","IBOCDRPT",40,0)
. ;
"RTN","IBOCDRPT",41,0)
. ; quit if no date, status cancelled (ib) or pt not CD, or no charge
"RTN","IBOCDRPT",42,0)
. Q:'IBDT!($P(IBZ,"^",5)=10)!($G(IBDG("VCD"))'="Y")!('$P(IBZ,"^",7))
"RTN","IBOCDRPT",43,0)
. ; quit if cancelled in AR (if passed)
"RTN","IBOCDRPT",44,0)
. I IBARX,$P(IBARBILL,"^",2)=26 Q
"RTN","IBOCDRPT",45,0)
. ; quit if CD effective date not before event date
"RTN","IBOCDRPT",46,0)
. Q:IBDT<3100505!(IBDT<$G(IBDG("DATE")))
"RTN","IBOCDRPT",47,0)
. ; quit if not within specified date range
"RTN","IBOCDRPT",48,0)
. Q:IBDT<IBBDT!($P(IBDT,".")>(IBEDT+1))
"RTN","IBOCDRPT",49,0)
. ;IB*2.0*618 - modified LTC check to include new LTC patients
"RTN","IBOCDRPT",50,0)
. ; quit if LTC inpatient
"RTN","IBOCDRPT",51,0)
. Q:'$$LTCCHK(IBZ)
"RTN","IBOCDRPT",52,0)
. ;
"RTN","IBOCDRPT",53,0)
. S IBDPT=$G(^DPT(DFN,0))
"RTN","IBOCDRPT",54,0)
. W !,$E($P(IBDPT,"^"),1,20) ; patient name
"RTN","IBOCDRPT",55,0)
. W ?22,$E($P(IBDPT,"^",9),6,9) ; last 4 snn
"RTN","IBOCDRPT",56,0)
. W ?27,$$FMTE^XLFDT($G(IBDG("DATE")),"2DZ") ; Catastrophically Disabled Date, IA# 10103
"RTN","IBOCDRPT",57,0)
. W ?36,$$FMTE^XLFDT(IBDT,"2DZ") ; date of service, IA# 10103
"RTN","IBOCDRPT",58,0)
. W:$E($P(IBZ,"^",4),1,2)=52 ?45,$E($P($P(IBZ,"^",8),"-"),1,11) ; rx
"RTN","IBOCDRPT",59,0)
. W ?57,$E($P($G(^IBE(350.1,+$P(IBZ,"^",3),0)),"^"),1,9) ; action type
"RTN","IBOCDRPT",60,0)
. W ?67,$E($P($P(IBZ,"^",11),"-",2),1,8) ; ar bill no
"RTN","IBOCDRPT",61,0)
. W ?76,$E($P($G(^IBE(350.21,+$P(IBZ,"^",5),0)),"^"),1,8) ; 350 status
"RTN","IBOCDRPT",62,0)
. W ?85,$J($FN($P(IBARBILL,"^",3),"",2),7) ; current balance
"RTN","IBOCDRPT",63,0)
. W ?93,$J($FN($G(IBARDATA(430,IBARX,77,"E")),"",2),7) ; pd principal
"RTN","IBOCDRPT",64,0)
. W ?101,$J($FN($G(IBARDATA(430,IBARX,78,"E")),"",2),5) ; pd int
"RTN","IBOCDRPT",65,0)
. W ?107,$J($FN($G(IBARDATA(430,IBARX,79,"E")),"",2),5) ; pd admin
"RTN","IBOCDRPT",66,0)
. W ?113,$$FMTE^XLFDT($G(IBARDATA(430,IBARX,141,"I")),"2DZ") ; IA# 10103
"RTN","IBOCDRPT",67,0)
. W ?122,$E($G(IBARDATA(430,IBARX,203,"E")),1,6)
"RTN","IBOCDRPT",68,0)
. W ?129,$E($G(IBARDATA(430,IBARX,255.1,"E")),1,4)
"RTN","IBOCDRPT",69,0)
. I $Y+3>IOSL D HEAD
"RTN","IBOCDRPT",70,0)
;
"RTN","IBOCDRPT",71,0)
D ^%ZISC
"RTN","IBOCDRPT",72,0)
EXIT S:$D(ZTQUEUED) ZTREQ="@"
"RTN","IBOCDRPT",73,0)
Q
"RTN","IBOCDRPT",74,0)
;
"RTN","IBOCDRPT",75,0)
;IB*2.0*618 Converted LTC check to a function call to allow ability to
"RTN","IBOCDRPT",76,0)
; look for new CC LTC Action Types.
"RTN","IBOCDRPT",77,0)
LTCCHK(IBZ) ; Check for all LTC Action Types. Return 1 if Action Type is LTC, 0 if not.
"RTN","IBOCDRPT",78,0)
N IBLTCNM
"RTN","IBOCDRPT",79,0)
S IBLTCNM=$P($G(^IBE(350.1,+$P(IBZ,"^",3),0)),"^")
"RTN","IBOCDRPT",80,0)
Q:IBLTCNM["DG LTC INPT" 1
"RTN","IBOCDRPT",81,0)
Q:IBLTCNM["DG LTC FEE INPT" 1
"RTN","IBOCDRPT",82,0)
Q:IBLTCNM["LTC CHOICE INPT" 1
"RTN","IBOCDRPT",83,0)
Q:IBLTCNM["LTC CC INPT" 1
"RTN","IBOCDRPT",84,0)
Q:IBLTCNM["LTC CCN INPT" 1
"RTN","IBOCDRPT",85,0)
Q 0
"RTN","IBOCDRPT",86,0)
;
"RTN","IBOCDRPT",87,0)
HEAD ;
"RTN","IBOCDRPT",88,0)
N IBL,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","IBOCDRPT",89,0)
I IBP,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR I $D(DIRUT) S IBQUIT=1 Q
"RTN","IBOCDRPT",90,0)
S IBP=IBP+1
"RTN","IBOCDRPT",91,0)
W @IOF,!,"Catastrophically Disabled Copayment Charge Report PAGE: ",IBP,!
"RTN","IBOCDRPT",92,0)
W "PATIENT SSN CD DATE DOS RX TYPE BILL NO STATUS BALANCE PD PRIN INT ADM TOP FUND RSC",!
"RTN","IBOCDRPT",93,0)
F IBL=1:1:$S(IOM:IOM,1:132) W "-"
"RTN","IBOCDRPT",94,0)
Q
"RTN","IBOHDT1")
0^31^B18269083
"RTN","IBOHDT1",1,0)
IBOHDT1 ;ALB/EMG - REPORT OF CHARGES ON HOLD > 60 DAYS-CONT ;FEB 18 1997
"RTN","IBOHDT1",2,0)
;;2.0;INTEGRATED BILLING;**70,95,347,452,618**;21-MAR-94;Build 60
"RTN","IBOHDT1",3,0)
;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBOHDT1",4,0)
;
"RTN","IBOHDT1",5,0)
REPORT ;
"RTN","IBOHDT1",6,0)
N IBQUIT,IBPAGE,IBNOW,IBLINE,IBCRT,IBBOT,DFN,IBNAME,IBATYPE,IBN,X
"RTN","IBOHDT1",7,0)
S IBCRT=0,IBBOT=6,IBQUIT=0 I $E(IOST,1,2)="C-" S IBCRT=1,IBBOT=4
"RTN","IBOHDT1",8,0)
S IBLINE="",$P(IBLINE,"=",96)="||",IBLINE=IBLINE_$E(IBLINE,1,32)
"RTN","IBOHDT1",9,0)
S IBNOW=$$FMTE^XLFDT($$NOW^XLFDT)
"RTN","IBOHDT1",10,0)
I IBCRT W @IOF
"RTN","IBOHDT1",11,0)
LOOP ;
"RTN","IBOHDT1",12,0)
S IBPAGE=1 D HEADER Q:IBQUIT
"RTN","IBOHDT1",13,0)
S IBNAME="" F S IBNAME=$O(^TMP($J,"HOLD",IBNAME)) Q:IBNAME="" S DFN=0 F S DFN=$O(^TMP($J,"HOLD",IBNAME,DFN)) Q:DFN="" D PRNTPAT Q:IBQUIT S IBATYPE="" F S IBATYPE=$O(^TMP($J,"HOLD",IBNAME,DFN,IBATYPE)) Q:IBATYPE="" D
"RTN","IBOHDT1",14,0)
.S IBN=0 F S IBN=$O(^TMP($J,"HOLD",IBNAME,DFN,IBATYPE,IBN)) Q:'IBN!(IBQUIT) D
"RTN","IBOHDT1",15,0)
..D PRNTCHG,PRNTBILL:'IBQUIT
"RTN","IBOHDT1",16,0)
Q
"RTN","IBOHDT1",17,0)
PRNTBILL ; prints bills for a charge
"RTN","IBOHDT1",18,0)
N IB,IB0,IBSTAT,IBCHG,IBPD,Y,I,IBT
"RTN","IBOHDT1",19,0)
D:$Y-IBBOT+1>IOSL HEADER Q:IBQUIT
"RTN","IBOHDT1",20,0)
S IB="" F I=1:1 S IB=$O(^TMP($J,"HOLD",IBNAME,DFN,IBATYPE,IBN,IB)) W:'IB&(I<2) ?90,"||",! D:$Y+IBBOT>IOSL HEADER Q:'IB!(IBQUIT) D
"RTN","IBOHDT1",21,0)
.W ?95,"||"
"RTN","IBOHDT1",22,0)
.S IB0=$G(^DGCR(399,IB,0)) Q:IB0=""
"RTN","IBOHDT1",23,0)
.W ?98,$P(IB0,"^",1) ; bill #
"RTN","IBOHDT1",24,0)
.S IBSTAT=$$STA^PRCAFN(IB)
"RTN","IBOHDT1",25,0)
.W:+IBSTAT>0 ?106,$E($P(IBSTAT,"^",2),1,3)
"RTN","IBOHDT1",26,0)
.S IBT=$J((+^DGCR(399,IB,"U1")-$P(^("U1"),"^",2)),9,2)
"RTN","IBOHDT1",27,0)
.W ?113,IBT ; total charges
"RTN","IBOHDT1",28,0)
.S IBPD=$$TPR^PRCAFN(IB) S:IBPD<0 IBPD="" S IBPD=$J(IBPD,9,2) W ?122,IBPD,! D:$Y+IBBOT>IOSL HEADER
"RTN","IBOHDT1",29,0)
Q
"RTN","IBOHDT1",30,0)
PRNTPAT ; prints patient data
"RTN","IBOHDT1",31,0)
N VAERR,VADM,IBSSN D DEM^VADPT S:'VAERR IBNAME=$G(VADM(1)),IBSSN=VA("BID") ; pt id,brief
"RTN","IBOHDT1",32,0)
D:$Y+IBBOT>IOSL HEADER Q:IBQUIT
"RTN","IBOHDT1",33,0)
W $E(IBNAME,1,20),?22,IBSSN
"RTN","IBOHDT1",34,0)
Q
"RTN","IBOHDT1",35,0)
PRNTCHG ; prints a charge
"RTN","IBOHDT1",36,0)
N IBACT,IBTYPE,IBBILL,IBFR,IBTO,IBCHG,IBND,IBND1,IBDAY,IBOHDT,X1,X2
"RTN","IBOHDT1",37,0)
N IBRX,IBRXN,IBRF,IBRDT,IBX,IENS,IBECME
"RTN","IBOHDT1",38,0)
S IBND=$G(^IB(IBN,0))
"RTN","IBOHDT1",39,0)
S IBND1=$G(^IB(IBN,1))
"RTN","IBOHDT1",40,0)
S (IBRX,IBRXN,IBRF,IBRDT,IBX,IBECME)=0
"RTN","IBOHDT1",41,0)
; action id
"RTN","IBOHDT1",42,0)
S IBACT=+IBND
"RTN","IBOHDT1",43,0)
; type
"RTN","IBOHDT1",44,0)
; Patch IB*2.0*618 - added community care - action types to DAYS ON HOLD report
"RTN","IBOHDT1",45,0)
S IBTYPE=$P(IBND,"^",3),IBTYPE=$P($G(^IBE(350.1,IBTYPE,0)),"^",1)
"RTN","IBOHDT1",46,0)
S IBTYPE=$$IBACTYPE^IBOHLD2(IBTYPE)
"RTN","IBOHDT1",47,0)
; end of Patch IB*2.0*618
"RTN","IBOHDT1",48,0)
; bill #
"RTN","IBOHDT1",49,0)
; S IBBILL=$P($P(IBND,"^",11),"-",2)
"RTN","IBOHDT1",50,0)
;
"RTN","IBOHDT1",51,0)
; rx info
"RTN","IBOHDT1",52,0)
I $P(IBND,"^",4)["52:" D
"RTN","IBOHDT1",53,0)
. S IBRXN=$P($P(IBND,"^",4),":",2) ; Rx ien
"RTN","IBOHDT1",54,0)
. S IBRX=$P($P(IBND,"^",8),"-") ; external Rx#
"RTN","IBOHDT1",55,0)
. S IBRF=$P($P(IBND,"^",4),":",3) ; fill# or 0 for original fill
"RTN","IBOHDT1",56,0)
. S IBECME=$P($$CLAIM^BPSBUTL(+IBRXN,+IBRF),U,6) ; ecme# DBIA 4719
"RTN","IBOHDT1",57,0)
. I IBRF S IENS=+IBRF,IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,+IENS,52,.01) ; refill date
"RTN","IBOHDT1",58,0)
. I 'IBRF S IENS=+IBRXN,IBRDT=$$FILE^IBRXUTL(IENS,22) ; fill date
"RTN","IBOHDT1",59,0)
. Q
"RTN","IBOHDT1",60,0)
;
"RTN","IBOHDT1",61,0)
S IBX=$$APPT^IBCU3(IBRDT,DFN)
"RTN","IBOHDT1",62,0)
; from/fill date
"RTN","IBOHDT1",63,0)
S IBFR=$$DAT1^IBOUTL($S(+IBRXN>0:IBRDT,1:$P(IBND,"^",14)))
"RTN","IBOHDT1",64,0)
; to date
"RTN","IBOHDT1",65,0)
S IBTO=$$DAT1^IBOUTL($S($P(IBND,"^",15)'="":$P(IBND,"^",15),1:$P(IBND1,"^",2)))
"RTN","IBOHDT1",66,0)
; on hold date
"RTN","IBOHDT1",67,0)
S IBOHDT=$$DAT1^IBOUTL($P(IBND1,"^",6))
"RTN","IBOHDT1",68,0)
; number of days on hold
"RTN","IBOHDT1",69,0)
S X1=DT,X2=$P(IBND1,"^",6) D ^%DTC S IBDAY=$J(X,7)
"RTN","IBOHDT1",70,0)
; charge$
"RTN","IBOHDT1",71,0)
S IBCHG=$J(+$P(IBND,"^",7),9,2)
"RTN","IBOHDT1",72,0)
W ?29,IBACT,?40,IBTYPE W:IBRX>0 ?46,"Rx #: "_IBRX_$S(IBRF>0:"("_IBRF_")",1:""),?68,$S(IBECME:"ECME #: "_IBECME,1:""),?95,"||",!
"RTN","IBOHDT1",73,0)
W:IBX=1 ?45,"*"
"RTN","IBOHDT1",74,0)
W ?46,IBFR,?55,IBTO,?66,IBOHDT,?77,IBDAY,?86,IBCHG
"RTN","IBOHDT1",75,0)
Q
"RTN","IBOHDT1",76,0)
HEADER ; writes the report header
"RTN","IBOHDT1",77,0)
Q:IBQUIT
"RTN","IBOHDT1",78,0)
I IBCRT,$Y>1 D Q:IBQUIT
"RTN","IBOHDT1",79,0)
.F Q:$Y>(IOSL-3) W !
"RTN","IBOHDT1",80,0)
.N T R " Press RETURN to continue",T:DTIME I '$T!(T["^") S IBQUIT=1 Q
"RTN","IBOHDT1",81,0)
I IBPAGE>1 W !,@IOF
"RTN","IBOHDT1",82,0)
W ?53,"CHARGES ON HOLD LONGER THAN "_IBNUM_" DAYS",?110,IBNOW," PAGE ",IBPAGE,!,"HELD CHARGES",?98,"CORRESPONDING THIRD PARTY BILLS",!,IBLINE
"RTN","IBOHDT1",83,0)
W !,?46,"From/",?55,"To/",?66,"On Hold",?77,"# Days",?95,"||",?105,"AR"
"RTN","IBOHDT1",84,0)
W !,"Name",?22,"Pt.ID",?29,"Act.ID",?40,"Type",?46,"Fill Dt",?55,"Rls Dt",?66,"Date",?77,"On Hold",?89,"Charge",?95,"||",?98,"Bill#",?105,"Status",?113,"Charge",?125,"Paid"
"RTN","IBOHDT1",85,0)
W !,IBLINE,!
"RTN","IBOHDT1",86,0)
W ?44,"'*' = outpt visit on same day as Rx fill date",?95,"||",!,IBLINE,!
"RTN","IBOHDT1",87,0)
S IBPAGE=IBPAGE+1
"RTN","IBOHDT1",88,0)
Q
"RTN","IBOHLD1")
0^26^B21577919
"RTN","IBOHLD1",1,0)
IBOHLD1 ;ALB/CJM - REPORT OF CHARGES ON HOLD W/INS INFO ;MARCH 3 1992
"RTN","IBOHLD1",2,0)
;;2.0;INTEGRATED BILLING;**70,95,133,356,347,618**;21-MAR-94;Build 60
"RTN","IBOHLD1",3,0)
;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBOHLD1",4,0)
;
"RTN","IBOHLD1",5,0)
; modified HELD CHARGES REPORT - includes INS info
"RTN","IBOHLD1",6,0)
;
"RTN","IBOHLD1",7,0)
MAIN ;
"RTN","IBOHLD1",8,0)
N IBQUIT,IBII,DIRUT,DUOUT,DTOUT,ZTIO,Y S IBQUIT=0
"RTN","IBOHLD1",9,0)
S DIR(0)="Y",DIR("A")="Include Insurance information on this report",DIR("B")="NO"
"RTN","IBOHLD1",10,0)
S DIR("?",1)=" Enter: 'Y' - to include patient insurance information on this report"
"RTN","IBOHLD1",11,0)
S DIR("?",2)=" 'N' - to exclude patient insurance information on this report"
"RTN","IBOHLD1",12,0)
S DIR("?",3)=" '^' - to exit this option"
"RTN","IBOHLD1",13,0)
D ^DIR K DIR G:$D(DIRUT) EXIT S IBII=+Y
"RTN","IBOHLD1",14,0)
;
"RTN","IBOHLD1",15,0)
QUEUED ; entry point if queued
"RTN","IBOHLD1",16,0)
;***
"RTN","IBOHLD1",17,0)
K ^TMP($J)
"RTN","IBOHLD1",18,0)
D:'$G(IBQUIT) DEVICE D:'$G(IBQUIT) CHRGS,REPORT^IBOHLD2
"RTN","IBOHLD1",19,0)
D EXIT
"RTN","IBOHLD1",20,0)
;***
"RTN","IBOHLD1",21,0)
Q
"RTN","IBOHLD1",22,0)
EXIT ;
"RTN","IBOHLD1",23,0)
K ^TMP($J)
"RTN","IBOHLD1",24,0)
K IBRDT,IBRF,IBRX,IBRXN
"RTN","IBOHLD1",25,0)
I $D(ZTQUEUED) S ZTREQ="@" Q
"RTN","IBOHLD1",26,0)
D ^%ZISC
"RTN","IBOHLD1",27,0)
Q
"RTN","IBOHLD1",28,0)
DEVICE ;
"RTN","IBOHLD1",29,0)
I $D(ZTQUEUED) Q
"RTN","IBOHLD1",30,0)
W !!,*7,"*** Margin width of this output is 132 ***"
"RTN","IBOHLD1",31,0)
W !,"*** This output should be queued ***"
"RTN","IBOHLD1",32,0)
S %ZIS="QM" D ^%ZIS I POP S IBQUIT=1 Q
"RTN","IBOHLD1",33,0)
I $D(IO("Q")) D Q
"RTN","IBOHLD1",34,0)
. S ZTRTN="QUEUED^IBOHLD1"
"RTN","IBOHLD1",35,0)
. S ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL
"RTN","IBOHLD1",36,0)
. S ZTDESC="HELD CHARGES RPT W/INS"
"RTN","IBOHLD1",37,0)
. S ZTSAVE("IB*")=""
"RTN","IBOHLD1",38,0)
. D ^%ZTLOAD
"RTN","IBOHLD1",39,0)
. W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
"RTN","IBOHLD1",40,0)
. D HOME^%ZIS K ZTSK S IBQUIT=1
"RTN","IBOHLD1",41,0)
U IO
"RTN","IBOHLD1",42,0)
Q
"RTN","IBOHLD1",43,0)
; indexes records that should be included in report
"RTN","IBOHLD1",44,0)
;
"RTN","IBOHLD1",45,0)
CHRGS ; charges on hold
"RTN","IBOHLD1",46,0)
N IBN,DFN,IBNAME,IBND
"RTN","IBOHLD1",47,0)
S DFN=0 F S DFN=$O(^IB("AH",DFN)) Q:'DFN D PAT S IBN=0 F S IBN=$O(^IB("AH",DFN,IBN)) Q:'IBN D
"RTN","IBOHLD1",48,0)
.S IBND=$G(^IB(IBN,0)) Q:'IBND
"RTN","IBOHLD1",49,0)
.S ^TMP($J,"HOLD",IBNAME,DFN,IBN)=""
"RTN","IBOHLD1",50,0)
.D BILLS
"RTN","IBOHLD1",51,0)
Q
"RTN","IBOHLD1",52,0)
PAT ; patient name
"RTN","IBOHLD1",53,0)
N VAERR,VADM D DEM^VADPT I VAERR K VADM
"RTN","IBOHLD1",54,0)
S IBNAME=$G(VADM(1)) S:IBNAME="" IBNAME=" "
"RTN","IBOHLD1",55,0)
Q
"RTN","IBOHLD1",56,0)
BILLS ; find bills for charges on hold
"RTN","IBOHLD1",57,0)
N IBFR,IBT,IBATYPE,IBTO
"RTN","IBOHLD1",58,0)
;***IB*2.0*618
"RTN","IBOHLD1",59,0)
; Look up the type to match to using the Action Type name
"RTN","IBOHLD1",60,0)
S IBATYPE=$$FNDBTYP($P(IBND,"^",3)) ;end IB*2.0*618
"RTN","IBOHLD1",61,0)
S IBFR=$P(IBND,"^",14),IBTO=$P(IBND,"^",15)
"RTN","IBOHLD1",62,0)
I IBATYPE="I" D INP
"RTN","IBOHLD1",63,0)
I IBATYPE="O" D OTP
"RTN","IBOHLD1",64,0)
E D RX
"RTN","IBOHLD1",65,0)
Q
"RTN","IBOHLD1",66,0)
;
"RTN","IBOHLD1",67,0)
FNDBTYP(IBACTIEN) ;Determine what type of 3rd party bill to try and match the
"RTN","IBOHLD1",68,0)
; held charge to.
"RTN","IBOHLD1",69,0)
; INPUT - IB Action Type IEN (350.1,.01)
"RTN","IBOHLD1",70,0)
;
"RTN","IBOHLD1",71,0)
N IBACTPNM
"RTN","IBOHLD1",72,0)
;
"RTN","IBOHLD1",73,0)
S IBACTPNM=$P($G(^IBE(350.1,IBACTIEN,0)),"^")
"RTN","IBOHLD1",74,0)
I IBACTPNM["OPT" Q "O"
"RTN","IBOHLD1",75,0)
I IBACTPNM["PSO" Q "RX"
"RTN","IBOHLD1",76,0)
I IBACTPNM["RX" Q "O" ;any other RX after PSO link to Outpatient
"RTN","IBOHLD1",77,0)
Q "I" ;assume inpatient if not matched above
"RTN","IBOHLD1",78,0)
;
"RTN","IBOHLD1",79,0)
INP ; inpatient bills
"RTN","IBOHLD1",80,0)
N IBEV,IBBILL,IBT,X,X1,X2,IBEND,IBOK
"RTN","IBOHLD1",81,0)
S IBEV=$P(IBND,"^",16) Q:'IBEV ; parent event
"RTN","IBOHLD1",82,0)
S IBEV=($P($G(^IB(IBEV,0)),"^",17)\1) Q:'IBEV ; date of parent event
"RTN","IBOHLD1",83,0)
S X1=IBEV,X2=1 D C^%DTC S IBEND=X
"RTN","IBOHLD1",84,0)
S IBT=(IBEV-.0001) F S IBT=$O(^DGCR(399,"D",IBT)) Q:'IBT!(IBT'<IBEND) S IBBILL=0 F S IBBILL=$O(^DGCR(399,"D",IBT,IBBILL)) Q:IBBILL="" D
"RTN","IBOHLD1",85,0)
.D INPTCK
"RTN","IBOHLD1",86,0)
.I IBOK S ^TMP($J,"HOLD",IBNAME,DFN,IBN,IBBILL)=""
"RTN","IBOHLD1",87,0)
Q
"RTN","IBOHLD1",88,0)
;
"RTN","IBOHLD1",89,0)
INPTCK ; does bill belong to charge? returns IBOK=0 if no
"RTN","IBOHLD1",90,0)
N IBBILL0,IBBILLU
"RTN","IBOHLD1",91,0)
S IBBILL0=$G(^DGCR(399,IBBILL,0)),IBBILLU=$G(^("U"))
"RTN","IBOHLD1",92,0)
S IBOK=1
"RTN","IBOHLD1",93,0)
CK1 ; for same patient?
"RTN","IBOHLD1",94,0)
I DFN=$P(IBBILL0,"^",2)
"RTN","IBOHLD1",95,0)
S IBOK=$T
"RTN","IBOHLD1",96,0)
Q:'IBOK
"RTN","IBOHLD1",97,0)
CK2 ; same type- inp or opt?
"RTN","IBOHLD1",98,0)
N B S B=$S(+$P(IBBILL0,"^",5)<3:"I",1:"O")
"RTN","IBOHLD1",99,0)
I B=IBATYPE
"RTN","IBOHLD1",100,0)
S IBOK=$T
"RTN","IBOHLD1",101,0)
Q:'IBOK
"RTN","IBOHLD1",102,0)
CK3 ; overlap in date range?
"RTN","IBOHLD1",103,0)
N F,T
"RTN","IBOHLD1",104,0)
S F=+IBBILLU,T=$P(IBBILLU,"^",2)
"RTN","IBOHLD1",105,0)
I (IBTO<F)!(IBFR>T)
"RTN","IBOHLD1",106,0)
S IBOK='$T
"RTN","IBOHLD1",107,0)
Q:'IBOK
"RTN","IBOHLD1",108,0)
CK4 ; insurance bill?
"RTN","IBOHLD1",109,0)
I $P(IBBILL0,"^",11)="i"
"RTN","IBOHLD1",110,0)
S IBOK=$T
"RTN","IBOHLD1",111,0)
Q
"RTN","IBOHLD1",112,0)
OTP ; outpatient bills
"RTN","IBOHLD1",113,0)
N X,IBV,IBBILL,IBOK,IBBILL0
"RTN","IBOHLD1",114,0)
S IBV=(IBFR\1)-.0001 F S IBV=$O(^DGCR(399,"AOPV",DFN,IBV)) Q:'IBV!(IBV>IBTO) S IBBILL=0 D
"RTN","IBOHLD1",115,0)
.F S IBBILL=$O(^DGCR(399,"AOPV",DFN,IBV,IBBILL)) Q:('IBBILL) D
"RTN","IBOHLD1",116,0)
..Q:$D(^TMP($J,"HOLD",IBNAME,DFN,IBN,IBBILL))
"RTN","IBOHLD1",117,0)
..S IBBILL0=$G(^DGCR(399,IBBILL,0)) D CK4 Q:'IBOK
"RTN","IBOHLD1",118,0)
..S ^TMP($J,"HOLD",IBNAME,DFN,IBN,IBBILL)=""
"RTN","IBOHLD1",119,0)
Q
"RTN","IBOHLD1",120,0)
RX ; rx refill bills
"RTN","IBOHLD1",121,0)
S (IBRX,IBRXN,IBRF,IBRDT)=0 N IENS
"RTN","IBOHLD1",122,0)
I $P(IBND,"^",4)'["52:" Q
"RTN","IBOHLD1",123,0)
;
"RTN","IBOHLD1",124,0)
S IBRXN=$P($P(IBND,"^",4),":",2),IBRX=$P($P(IBND,"^",8),"-"),IBRF=$P($P(IBND,"^",4),":",3)
"RTN","IBOHLD1",125,0)
;
"RTN","IBOHLD1",126,0)
I +IBRF>0 S IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,IBRF,52,.01)
"RTN","IBOHLD1",127,0)
I +IBRF=0 S IBRDT=$$FILE^IBRXUTL(+IBRXN,22)
"RTN","IBOHLD1",128,0)
;
"RTN","IBOHLD1",129,0)
Q:(IBRX="")!('IBRDT)
"RTN","IBOHLD1",130,0)
N X,IBBILL,IBBILL0,IBFILL,IBFILL0,IBOK S IBBILL=0
"RTN","IBOHLD1",131,0)
S IBFILL=0 F S IBFILL=$O(^IBA(362.4,"B",IBRX,IBFILL)) Q:IBFILL="" D
"RTN","IBOHLD1",132,0)
.S IBFILL0=$G(^IBA(362.4,IBFILL,0)) I $P(IBFILL0,"^",3)'=IBRDT Q
"RTN","IBOHLD1",133,0)
.S IBBILL=+$P(IBFILL0,"^",2) I 'IBBILL Q
"RTN","IBOHLD1",134,0)
.S IBBILL0=$G(^DGCR(399,IBBILL,0)) D CK4 I 'IBOK Q
"RTN","IBOHLD1",135,0)
.S ^TMP($J,"HOLD",IBNAME,DFN,IBN,IBBILL)=""
"RTN","IBOHLD1",136,0)
Q
"RTN","IBOHLD2")
0^24^B32477589
"RTN","IBOHLD2",1,0)
IBOHLD2 ;ALB/CJM - REPORT OF CHARGES ON HOLD W/INS ;MAR 6,1991
"RTN","IBOHLD2",2,0)
;;2.0;INTEGRATED BILLING;**70,95,133,153,347,452,618**;21-MAR-94;Build 60
"RTN","IBOHLD2",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","IBOHLD2",4,0)
;
"RTN","IBOHLD2",5,0)
; Reference to $$CLAIM^BPSBUTL supported by DBIA# 4719
"RTN","IBOHLD2",6,0)
REPORT ;
"RTN","IBOHLD2",7,0)
N IBQUIT,IBPAGE,IBNOW,IBLINE,IBLINE2,IBCRT,IBBOT,DFN,IBNAME,IBN
"RTN","IBOHLD2",8,0)
S IBCRT=0,IBBOT=7,IBQUIT=0 I $E(IOST,1,2)="C-" S IBCRT=1,IBBOT=7
"RTN","IBOHLD2",9,0)
S IBLINE="",$P(IBLINE,"=",86)="||",IBLINE=IBLINE_$E(IBLINE,1,45)
"RTN","IBOHLD2",10,0)
S IBLINE2="",$P(IBLINE2,"-",75)="--"
"RTN","IBOHLD2",11,0)
D NOW^%DTC S Y=X X ^DD("DD") S IBNOW=Y
"RTN","IBOHLD2",12,0)
I IBCRT W @IOF
"RTN","IBOHLD2",13,0)
LOOP ;
"RTN","IBOHLD2",14,0)
S IBPAGE=1 D HEADER Q:IBQUIT
"RTN","IBOHLD2",15,0)
S IBNAME="" F S IBNAME=$O(^TMP($J,"HOLD",IBNAME)) Q:IBNAME=""!(IBQUIT) S DFN=0 F S DFN=$O(^TMP($J,"HOLD",IBNAME,DFN)) Q:'DFN!(IBQUIT) D
"RTN","IBOHLD2",16,0)
.D PRNTPAT,PRNTINS W:IBII ?35,IBLINE2,! Q:IBQUIT S IBN=0 F S IBN=$O(^TMP($J,"HOLD",IBNAME,DFN,IBN)) Q:'IBN!(IBQUIT) D
"RTN","IBOHLD2",17,0)
..D PRNTCHG,PRNTBILL:'IBQUIT
"RTN","IBOHLD2",18,0)
Q
"RTN","IBOHLD2",19,0)
PRNTBILL ; prints bills for a charge
"RTN","IBOHLD2",20,0)
N IB,IB0,IBSTAT,IBCHG,IBPD,C,Y,I,IBT
"RTN","IBOHLD2",21,0)
D:$Y+IBBOT>IOSL HEADER Q:IBQUIT
"RTN","IBOHLD2",22,0)
S IB="" F I=1:1 S IB=$O(^TMP($J,"HOLD",IBNAME,DFN,IBN,IB)) W:'IB&(I<2) ?85,"||",! Q:'IB!(IBQUIT) D
"RTN","IBOHLD2",23,0)
.W ?85,"||"
"RTN","IBOHLD2",24,0)
.S IB0=$G(^DGCR(399,IB,0)) Q:IB0=""
"RTN","IBOHLD2",25,0)
.W ?88,$P(IB0,"^",1) ; bill #
"RTN","IBOHLD2",26,0)
.S IBSTAT=$$STA^PRCAFN(IB)
"RTN","IBOHLD2",27,0)
.W:+IBSTAT>0 ?97,$E($P(IBSTAT,"^",2),1,14)
"RTN","IBOHLD2",28,0)
.S IBT=$J((+^DGCR(399,IB,"U1")-$P(^("U1"),"^",2)),9,2)
"RTN","IBOHLD2",29,0)
.W ?112,IBT ; total charges
"RTN","IBOHLD2",30,0)
.S IBPD=$$TPR^PRCAFN(IB) S:IBPD<0 IBPD="" S IBPD=$J(IBPD,9,2) W ?123,IBPD,! D:$Y+IBBOT>IOSL HEADER
"RTN","IBOHLD2",31,0)
Q
"RTN","IBOHLD2",32,0)
PRNTPAT ; prints patient data
"RTN","IBOHLD2",33,0)
N VAERR,VADM,IBSSN D DEM^VADPT S:'VAERR IBSSN=VA("BID") ; pt id,brief
"RTN","IBOHLD2",34,0)
D:$Y+IBBOT>IOSL HEADER Q:IBQUIT
"RTN","IBOHLD2",35,0)
W IBLINE,!
"RTN","IBOHLD2",36,0)
W $E(IBNAME,1,20),?22,IBSSN
"RTN","IBOHLD2",37,0)
W:IBII ?35,"Insurance Co.",?53,"Subscriber ID",?71,"Group",?88,"Eff Dt",?102,"Exp Dt",!
"RTN","IBOHLD2",38,0)
Q
"RTN","IBOHLD2",39,0)
PRNTINS ; prints insurance information
"RTN","IBOHLD2",40,0)
Q:'$D(DFN)!(IBII=0)
"RTN","IBOHLD2",41,0)
N X,IBINS,IBX
"RTN","IBOHLD2",42,0)
D ALL^IBCNS1(DFN,"IBINS")
"RTN","IBOHLD2",43,0)
D:$Y+IBBOT>IOSL HEADER Q:IBQUIT
"RTN","IBOHLD2",44,0)
W IBLINE,!
"RTN","IBOHLD2",45,0)
I '$D(IBINS) W ?35,"No Insurance Information"
"RTN","IBOHLD2",46,0)
S X=0 F S X=$O(IBINS(X)) Q:'X S IBINS=IBINS(X,0) D
"RTN","IBOHLD2",47,0)
.D:$Y+IBBOT>IOSL HEADER Q:IBQUIT
"RTN","IBOHLD2",48,0)
.N COV,COVD,COVFN,IBCNT,LEDT,LIM,PLN,SP,X,X1,X2,Z0 Q:'$D(IBINS)
"RTN","IBOHLD2",49,0)
.W ?36,$S($D(^DIC(36,+IBINS,0)):$E($P(^(0),"^",1),1,16),1:"UNKNOWN")
"RTN","IBOHLD2",50,0)
.W ?54,$E($P(IBINS,"^",2),1,16)
"RTN","IBOHLD2",51,0)
.W ?72,$E($$GRP($P(IBINS,"^",18)),1,10) S PLN=$P(IBINS,"^",18)
"RTN","IBOHLD2",52,0)
.W ?88,$$DAT1^IBOUTL($P(IBINS,"^",8)),?102,$$DAT1^IBOUTL($P(IBINS,"^",4))
"RTN","IBOHLD2",53,0)
.I PLN="" W !,?38,"* No Group Plan Information for this Patient - Verify Insurance Info!",! Q
"RTN","IBOHLD2",54,0)
.W !,?40,"Plan Coverage Effective Date Covered? Limit Comments",!
"RTN","IBOHLD2",55,0)
.W ?40,"------------- -------------- -------- --------------",!
"RTN","IBOHLD2",56,0)
.S LIM=0 F S LIM=$O(^IBE(355.31,LIM)) Q:'LIM S COV=$P($G(^(LIM,0)),U),IBCNT=0,LEDT="" F S LEDT=$O(^IBA(355.32,"APCD",PLN,LIM,LEDT)) Q:$S(LEDT="":IBCNT,1:0) D Q:LEDT=""
"RTN","IBOHLD2",57,0)
..D:$Y+IBBOT>IOSL HEADER Q:IBQUIT
"RTN","IBOHLD2",58,0)
..S COVFN=+$O(^IBA(355.32,"APCD",PLN,LIM,+LEDT,"")),COVD=$G(^IBA(355.32,+COVFN,0))
"RTN","IBOHLD2",59,0)
..I COVD="" W ?40,COV,?86,"BY DEFAULT",! Q
"RTN","IBOHLD2",60,0)
..S IBCNT=IBCNT+1
"RTN","IBOHLD2",61,0)
..S X1=" "_$S(IBCNT=1:COV,1:"") ;Don't duplicate category
"RTN","IBOHLD2",62,0)
..S X2=$$PR(X1,18)_$$PR($$DAT1^IBOUTL($P(LEDT,"-",2)),16)_$$PR($S($P(COVD,U,4):$S($P(COVD,U,4)<2:"YES",$P(COVD,U,4)=2:"CONDITIONAL",1:"UNKNOWN"),1:"NO"),14)
"RTN","IBOHLD2",63,0)
..I '$O(^IBA(355.32,COVFN,2,0)) W ?40,X2,! Q
"RTN","IBOHLD2",64,0)
..S Z0=0 F S Z0=$O(^IBA(355.32,COVFN,2,Z0)) Q:'Z0 S SP="" W ?40,$S(Z0=1:X2_$G(^IBA(355.32,COVFN,2,Z0,0)),1:$$PR(SP,48)_$G(^IBA(355.32,COVFN,2,Z0,0))),!
"RTN","IBOHLD2",65,0)
Q
"RTN","IBOHLD2",66,0)
GRP(IBCPOL) ; get group name/group policy
"RTN","IBOHLD2",67,0)
N X,Y S X=""
"RTN","IBOHLD2",68,0)
S X=$G(^IBA(355.3,+$G(IBCPOL),0))
"RTN","IBOHLD2",69,0)
S Y=$S($P(X,"^",4)'="":$P(X,"^",4),1:$P(X,"^",3))
"RTN","IBOHLD2",70,0)
I $P(X,"^",10) S Y="Ind Plan "_Y
"RTN","IBOHLD2",71,0)
GRPQ Q Y
"RTN","IBOHLD2",72,0)
PR(STR,LEN) ; pad right
"RTN","IBOHLD2",73,0)
N B S STR=$E(STR,1,LEN),$P(B," ",LEN-$L(STR))=" "
"RTN","IBOHLD2",74,0)
Q STR_$G(B)
"RTN","IBOHLD2",75,0)
PRNTCHG ; prints a charge
"RTN","IBOHLD2",76,0)
N IBACT,IBTYPE,IBBILL,IBFR,IBTO,IBCHG,IBND,IBND1
"RTN","IBOHLD2",77,0)
N IBRX,IBRXN,IBRF,IBRDT,IBX,IENS,IBECME
"RTN","IBOHLD2",78,0)
S IBND=$G(^IB(IBN,0))
"RTN","IBOHLD2",79,0)
S IBND1=$G(^IB(IBN,1))
"RTN","IBOHLD2",80,0)
S (IBRX,IBRXN,IBRF,IBRDT,IBX,IBECME)=0
"RTN","IBOHLD2",81,0)
; action id
"RTN","IBOHLD2",82,0)
S IBACT=+IBND
"RTN","IBOHLD2",83,0)
; type
"RTN","IBOHLD2",84,0)
; begin of Patch IB*2.0*618 - added community care - action types to HELD CHARGES report
"RTN","IBOHLD2",85,0)
S IBTYPE=$P(IBND,"^",3),IBTYPE=$P($G(^IBE(350.1,IBTYPE,0)),"^",1)
"RTN","IBOHLD2",86,0)
S IBTYPE=$$IBACTYPE(IBTYPE)
"RTN","IBOHLD2",87,0)
; end of Patch IB*2.0*618
"RTN","IBOHLD2",88,0)
; bill #
"RTN","IBOHLD2",89,0)
S IBBILL=$P($P(IBND,"^",11),"-",2)
"RTN","IBOHLD2",90,0)
; rx info
"RTN","IBOHLD2",91,0)
I $P(IBND,"^",4)["52:" D
"RTN","IBOHLD2",92,0)
. S IBRXN=+$P($P(IBND,"^",4),":",2) ; Rx ien
"RTN","IBOHLD2",93,0)
. S IBRX=$P($P(IBND,"^",8),"-") ; external Rx#
"RTN","IBOHLD2",94,0)
. S IBRF=+$P($P(IBND,"^",4),":",3) ; fill# or 0 for original fill
"RTN","IBOHLD2",95,0)
. S IBECME=$P($$CLAIM^BPSBUTL(IBRXN,IBRF),U,6) ; ecme# DBIA# 4719
"RTN","IBOHLD2",96,0)
. I IBRF S IENS=+IBRF,IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,+IENS,52,.01) ; refill date
"RTN","IBOHLD2",97,0)
. I 'IBRF S IENS=+IBRXN,IBRDT=$$FILE^IBRXUTL(+IENS,22) ; orig fill date
"RTN","IBOHLD2",98,0)
. Q
"RTN","IBOHLD2",99,0)
;
"RTN","IBOHLD2",100,0)
S IBX=$$APPT^IBCU3(IBRDT,DFN)
"RTN","IBOHLD2",101,0)
; from/rx fill date
"RTN","IBOHLD2",102,0)
S IBFR=$$DAT1^IBOUTL($S(IBRXN>0:IBRDT,1:$P(IBND,"^",15)))
"RTN","IBOHLD2",103,0)
; to date
"RTN","IBOHLD2",104,0)
S IBTO=$$DAT1^IBOUTL($S($P(IBND,"^",15)'="":($P(IBND,"^",15)),1:$P(IBND1,"^",2)))
"RTN","IBOHLD2",105,0)
; charge$
"RTN","IBOHLD2",106,0)
S IBCHG=$J(+$P(IBND,"^",7),9,2)
"RTN","IBOHLD2",107,0)
W ?29,IBACT,?39,IBTYPE,?46,IBBILL
"RTN","IBOHLD2",108,0)
I IBRX>0 W ?55,"Rx #: "_IBRX_$S(IBRF>0:"("_IBRF_")",1:""),?85,"||",! I IBECME W ?55,"ECME #: ",IBECME,?85,"||",!
"RTN","IBOHLD2",109,0)
W:IBX=1 ?54,"*"
"RTN","IBOHLD2",110,0)
W ?55,IBFR,?66,IBTO,?75,IBCHG
"RTN","IBOHLD2",111,0)
Q
"RTN","IBOHLD2",112,0)
HEADER ; writes the report header
"RTN","IBOHLD2",113,0)
Q:IBQUIT
"RTN","IBOHLD2",114,0)
I IBCRT,$Y>1 D Q:IBQUIT ;F Q:$Y>(IOSL-1) W !
"RTN","IBOHLD2",115,0)
.W ! N T R " Press RETURN to continue",T:DTIME I '$T!(T["^") S IBQUIT=1 Q
"RTN","IBOHLD2",116,0)
I IBPAGE>1 W !,@IOF
"RTN","IBOHLD2",117,0)
W ?53,"MEANS TEST CHARGES ON HOLD",?110,IBNOW," PAGE ",IBPAGE,!,"HELD CHARGES",?87,"CORRESPONDING THIRD PARTY BILLS",!,IBLINE
"RTN","IBOHLD2",118,0)
W !,"Name",?22,"Pt.ID",?29,"Act.ID",?39,"Type",?46,"Bill#",?55,"Fr/Fl Dt",?66,"To/Rls Dt",?78,"Charge",?85,"||",?88,"Bill#",?97,"AR-Status",?115,"Charge",?128,"Paid"
"RTN","IBOHLD2",119,0)
W !,IBLINE,!
"RTN","IBOHLD2",120,0)
W ?20,"'*' = outpt visit on same day as Rx fill date",?85,"||",!,IBLINE,!
"RTN","IBOHLD2",121,0)
S IBPAGE=IBPAGE+1
"RTN","IBOHLD2",122,0)
Q
"RTN","IBOHLD2",123,0)
IBACTYPE(IBTYPE) ; Patch IB*2.0*618 - added community care - action types to HELD CHARGES report
"RTN","IBOHLD2",124,0)
I IBTYPE["CC " Q "NVC"
"RTN","IBOHLD2",125,0)
I IBTYPE["CCN " Q "NVC"
"RTN","IBOHLD2",126,0)
I IBTYPE["CHOICE" Q "NVC"
"RTN","IBOHLD2",127,0)
I IBTYPE["PSO NSC" Q "RXNSC"
"RTN","IBOHLD2",128,0)
I IBTYPE["PSO SC" Q "RX SC"
"RTN","IBOHLD2",129,0)
Q $E(IBTYPE,4,7)
"RTN","IBOHLD2",130,0)
;
"RTN","IBOHLS1")
0^25^B100301549
"RTN","IBOHLS1",1,0)
IBOHLS1 ;ALB/BAA - IB HELD CHARGES LIST MANAGER ;08-SEP-2015
"RTN","IBOHLS1",2,0)
;;2.0;INTEGRATED BILLING;**554,616,618**;21-MAR-94;Build 60
"RTN","IBOHLS1",3,0)
;Per VA Directive 6402, this routine should not be modified.
"RTN","IBOHLS1",4,0)
;
"RTN","IBOHLS1",5,0)
SORT ; get the data
"RTN","IBOHLS1",6,0)
N CNT,IBN,SINST
"RTN","IBOHLS1",7,0)
S CNT=0
"RTN","IBOHLS1",8,0)
; compile data to display here
"RTN","IBOHLS1",9,0)
I 'PATS D
"RTN","IBOHLS1",10,0)
. S IBN=0 F S IBN=$O(^IB("AC",8,IBN)) Q:'IBN D CHRGS(IBN,PATS)
"RTN","IBOHLS1",11,0)
I PATS D
"RTN","IBOHLS1",12,0)
. S DFN=0 F S DFN=$O(FILTERS(2,DFN)) Q:'DFN D
"RTN","IBOHLS1",13,0)
.. S IBN=0 F S IBN=$O(^IB("AH",DFN,IBN)) Q:'IBN D CHRGS(IBN,PATS)
"RTN","IBOHLS1",14,0)
Q
"RTN","IBOHLS1",15,0)
;
"RTN","IBOHLS1",16,0)
CHRGS(IBN,PATS) ; charges on hold
"RTN","IBOHLS1",17,0)
N IBFR,IBTO,HDAYS,IBND,HINST,DFN,HST,IBACT,IBCHG,ID,SS,SSLE,SSLS,NAME,HLDT,FLAG
"RTN","IBOHLS1",18,0)
N CLINIC,IBND1,RSLTFRM
"RTN","IBOHLS1",19,0)
S SINST=""
"RTN","IBOHLS1",20,0)
S IBND=$G(^IB(IBN,0)) Q:'IBND
"RTN","IBOHLS1",21,0)
S RSLTFRM=$P(IBND,U,4)
"RTN","IBOHLS1",22,0)
S HINST=$$INST(RSLTFRM),CLINIC=$P(HINST,U,2),HINST=$P(HINST,U,1)
"RTN","IBOHLS1",23,0)
S FLAG=""
"RTN","IBOHLS1",24,0)
I HINST="*" S FLAG="*",HINST=$P(IBND,U,13)
"RTN","IBOHLS1",25,0)
I HINST="" S FLAG="*",HINST=$P(IBND,U,13)
"RTN","IBOHLS1",26,0)
I HINST'="" S SINST=$P(^DIC(4,HINST,0),U,1)
"RTN","IBOHLS1",27,0)
I INSTS,HINST="" Q
"RTN","IBOHLS1",28,0)
I INSTS,'$D(FILTERS(1,HINST)) Q
"RTN","IBOHLS1",29,0)
S IBND1=$G(^IB(IBN,1))
"RTN","IBOHLS1",30,0)
S HLDT=$P(IBND1,U,6)
"RTN","IBOHLS1",31,0)
S IBACT=+IBND
"RTN","IBOHLS1",32,0)
S DFN=$P(IBND,U,2)
"RTN","IBOHLS1",33,0)
D PAT
"RTN","IBOHLS1",34,0)
S HST=$P(IBND,U,5)
"RTN","IBOHLS1",35,0)
I HST'=8 Q
"RTN","IBOHLS1",36,0)
S IBFR=$P(IBND,U,14),IBTO=$P(IBND,U,15)
"RTN","IBOHLS1",37,0)
I $P(IBND,U,4)["52:" D
"RTN","IBOHLS1",38,0)
.S IBRXN=$P($P(IBND,U,4),":",2),IBRF=$P($P(IBND,U,4),":",3)
"RTN","IBOHLS1",39,0)
.I +IBRF>0 S IBFR=$$SUBFILE^IBRXUTL(+IBRXN,IBRF,52,.01),IBTO=$P($$SUBFILE^IBRXUTL(+IBRXN,IBRF,52,17),".")
"RTN","IBOHLS1",40,0)
.I +IBRF=0 S IBFR=$$FILE^IBRXUTL(+IBRXN,22),IBTO=$P($$FILE^IBRXUTL(+IBRXN,31),".")
"RTN","IBOHLS1",41,0)
I HLDT<BDATE!(HLDT>EDATE) Q
"RTN","IBOHLS1",42,0)
S HDAYS=$$FMDIFF^XLFDT(DT,HLDT,1)
"RTN","IBOHLS1",43,0)
S IBCHG=$P(IBND,U,7)
"RTN","IBOHLS1",44,0)
D BILLS
"RTN","IBOHLS1",45,0)
Q
"RTN","IBOHLS1",46,0)
;
"RTN","IBOHLS1",47,0)
INST(RF) ; figure out where performed
"RTN","IBOHLS1",48,0)
N FL,IEN,IBIEN,DIEN,INT,CLNM,IBSTA
"RTN","IBOHLS1",49,0)
S IBRXN=$P(RF,":",2),INT="*",CLNM=""
"RTN","IBOHLS1",50,0)
S IBIEN=$P(IBRXN,";",1)
"RTN","IBOHLS1",51,0)
S FL=$P(RF,":",1)
"RTN","IBOHLS1",52,0)
;
"RTN","IBOHLS1",53,0)
I FL=350 S INT="*",CLNM=""
"RTN","IBOHLS1",54,0)
;
"RTN","IBOHLS1",55,0)
I FL=45 D
"RTN","IBOHLS1",56,0)
. S IBSTA=$$GET1^DIQ(45,IBIEN_",",3,"I"),CLNM="" ;IB*2*616, 45 file stores Station Number
"RTN","IBOHLS1",57,0)
. D FIND^DIC(4,"","@;.01;IX","X",IBSTA,99,"D","","","MSG") S INT=$G(MSG("DILIST",2,1)) ;Convert Station number to Institution file IEN
"RTN","IBOHLS1",58,0)
;
"RTN","IBOHLS1",59,0)
I FL=52 D
"RTN","IBOHLS1",60,0)
. S IEN=$$GET1^DIQ(52,IBIEN_",",20,"I"),CLNM=$$GET1^DIQ(52,IBIEN_",",20,"E")
"RTN","IBOHLS1",61,0)
. S INT=$$GET1^DIQ(59,IEN_",",100,"I")
"RTN","IBOHLS1",62,0)
;
"RTN","IBOHLS1",63,0)
I FL=405 D
"RTN","IBOHLS1",64,0)
. S IEN=$$GET1^DIQ(405,IBIEN_",",.06,"I"),CLNM=$$GET1^DIQ(405,IBIEN_",",.06,"E")
"RTN","IBOHLS1",65,0)
. S DIEN=$$GET1^DIQ(42,IEN_",",.015,"I")
"RTN","IBOHLS1",66,0)
. S INT=$$GET1^DIQ(40.8,DIEN_",",.07,"I")
"RTN","IBOHLS1",67,0)
;
"RTN","IBOHLS1",68,0)
I FL=409.68 D
"RTN","IBOHLS1",69,0)
. S IEN=$$GET1^DIQ(409.68,IBIEN_",",.04,"I"),CLNM=$$GET1^DIQ(409.68,IBIEN_",",.04,"E")
"RTN","IBOHLS1",70,0)
. S INT=$$GET1^DIQ(44,IEN_",",3,"I")
"RTN","IBOHLS1",71,0)
;
"RTN","IBOHLS1",72,0)
Q INT_U_CLNM
"RTN","IBOHLS1",73,0)
;
"RTN","IBOHLS1",74,0)
;
"RTN","IBOHLS1",75,0)
PAT ; patient name
"RTN","IBOHLS1",76,0)
N VAERR,VADM D DEM^VADPT I VAERR K VADM
"RTN","IBOHLS1",77,0)
S NAME=$G(VADM(1)) S:NAME="" NAME=" "
"RTN","IBOHLS1",78,0)
S SS=$P($G(VADM(2)),U,1),SSLE=$L(SS),SSLS=6 I $E(SS,SSLE)="P" S SSLS=5
"RTN","IBOHLS1",79,0)
S ID=$E(NAME,1)_$E(SS,SSLS,SSLE)
"RTN","IBOHLS1",80,0)
Q
"RTN","IBOHLS1",81,0)
;
"RTN","IBOHLS1",82,0)
BILLS ; find bills for charges on hold
"RTN","IBOHLS1",83,0)
N IBT,IBATYPE,IBCHRG,IBTP
"RTN","IBOHLS1",84,0)
; Look up the type to match to using the Action Type name
"RTN","IBOHLS1",85,0)
S IBATYPE=$$FNDBTYP^IBOHLD1($P(IBND,"^",3)) ;IB*2.0*618
"RTN","IBOHLS1",86,0)
S CNT=CNT+1
"RTN","IBOHLS1",87,0)
; Patch IB*2.0*618 - added community care - action types to HELD CHARGES report
"RTN","IBOHLS1",88,0)
S IBTP=$P(IBND,"^",3),IBTP=$P($G(^IBE(350.1,IBTP,0)),"^",1)
"RTN","IBOHLS1",89,0)
S IBTP=$$IBACTYPE^IBOHLD2(IBTP)
"RTN","IBOHLS1",90,0)
; end of Patch IB*2.0*618
"RTN","IBOHLS1",91,0)
S ^TMP($J,"IBOHLS",NAME,CNT)=NAME_U_ID_U_IBTP_U_IBFR_U_IBTO_U_HDAYS_U_IBCHG
"RTN","IBOHLS1",92,0)
S ^TMP($J,"IBOHLS",NAME,CNT,"IBND")=DFN_U_NAME_U_IBN_U_IBFR_U_IBTO_U_SINST_U_FLAG_U_CLINIC
"RTN","IBOHLS1",93,0)
I IBATYPE="I" D INP
"RTN","IBOHLS1",94,0)
I IBATYPE="O" D OTP
"RTN","IBOHLS1",95,0)
E D RX
"RTN","IBOHLS1",96,0)
I IINS,$D(^TMP($J,"IBOHLS",NAME,CNT)),'$D(^TMP($J,"IBOHLS INS",NAME)) D GETINS
"RTN","IBOHLS1",97,0)
Q
"RTN","IBOHLS1",98,0)
;
"RTN","IBOHLS1",99,0)
INP ; inpatient bills
"RTN","IBOHLS1",100,0)
N IBEV,IBBILL,IBT,X,X1,X2,IBEND,IBOK,IBBCHG,IBBILL0,IBBILLU1,BILL,BCNT,BLTRK,RNB,STATUS
"RTN","IBOHLS1",101,0)
N HLDDT,AUDT,IBTYPE
"RTN","IBOHLS1",102,0)
S IBTYPE=$P(IBND,"^",3),IBTYPE=$P($G(^IBE(350.1,IBTYPE,0)),"^",1),IBTYPE=$S(IBTYPE["PSO NSC":"RXNSC",IBTYPE["PSO SC":"RX SC",1:$E(IBTYPE,4,7))
"RTN","IBOHLS1",103,0)
S IBEV=$P(IBND,U,16) Q:'IBEV ; parent event
"RTN","IBOHLS1",104,0)
S IBEV=($P($G(^IB(IBEV,0)),U,17)\1) Q:'IBEV ; date of parent event
"RTN","IBOHLS1",105,0)
S X1=IBEV,X2=1 D C^%DTC S IBEND=X
"RTN","IBOHLS1",106,0)
S BCNT=0
"RTN","IBOHLS1",107,0)
S IBT=(IBEV-.0001) F S IBT=$O(^DGCR(399,"D",IBT)) Q:'IBT!(IBT'<IBEND) S IBBILL=0 F S IBBILL=$O(^DGCR(399,"D",IBT,IBBILL)) Q:IBBILL="" D
"RTN","IBOHLS1",108,0)
. S IBBILL0=$G(^DGCR(399,IBBILL,0))
"RTN","IBOHLS1",109,0)
. S BILL=$P(IBBILL0,U,1)
"RTN","IBOHLS1",110,0)
. S AUDT=$$GET1^DIQ(399,IBBILL,10,"I")
"RTN","IBOHLS1",111,0)
. S HLDDT=$S(AUDT'="":$$FMDIFF^XLFDT(DT,AUDT,1),1:HDAYS)
"RTN","IBOHLS1",112,0)
. S IBBCHG=$$GET1^DIQ(430,IBBILL,77)
"RTN","IBOHLS1",113,0)
. S STATUS=$$GET1^DIQ(430,IBBILL,8,"O")
"RTN","IBOHLS1",114,0)
. S (BLTRK,RNB)=""
"RTN","IBOHLS1",115,0)
. S BLTRK=$O(^IBT(356,"E",IBBILL,BLTRK))
"RTN","IBOHLS1",116,0)
. I BLTRK'="" S RNB=$$GET1^DIQ(356,BLTRK,.19,"O")
"RTN","IBOHLS1",117,0)
. D INPTCK
"RTN","IBOHLS1",118,0)
. I IBOK D
"RTN","IBOHLS1",119,0)
.. ;BILL#AR STATUS^DATE BILLED^AUTH DATE^HLD DAYS^CHARGE^RNB^BILL TRK #
"RTN","IBOHLS1",120,0)
.. S BCNT=BCNT+1
"RTN","IBOHLS1",121,0)
.. S ^TMP($J,"IBOHLS",NAME,CNT,2,BCNT)=BILL_U_STATUS_U_IBT_U_AUDT_U_HLDDT_U_IBBCHG_U_RNB_U_BLTRK ;BILL#^AR STATUS^DATE BILLED^CHARGE
"RTN","IBOHLS1",122,0)
.. S ^TMP($J,"IBOHLS",NAME,CNT,2,BCNT,"B")=IBBILL_U_BLTRK_U_RNB
"RTN","IBOHLS1",123,0)
Q
"RTN","IBOHLS1",124,0)
;
"RTN","IBOHLS1",125,0)
INPTCK ; does bill belong to charge? returns IBOK=0 if no
"RTN","IBOHLS1",126,0)
N IBBILLU
"RTN","IBOHLS1",127,0)
S IBBILLU=$G(^DGCR(399,IBBILL,"U"))
"RTN","IBOHLS1",128,0)
S IBBILL=$P(IBBILL0,U,1)
"RTN","IBOHLS1",129,0)
S IBOK=1
"RTN","IBOHLS1",130,0)
CK1 ; for same patient?
"RTN","IBOHLS1",131,0)
I DFN=$P(IBBILL0,U,2)
"RTN","IBOHLS1",132,0)
S IBOK=$T
"RTN","IBOHLS1",133,0)
Q:'IBOK
"RTN","IBOHLS1",134,0)
CK2 ; same type- inp or opt?
"RTN","IBOHLS1",135,0)
N B S B=$S(+$P(IBBILL0,U,5)<3:"I",1:"O")
"RTN","IBOHLS1",136,0)
I B=IBATYPE S IBOK=1
"RTN","IBOHLS1",137,0)
S IBOK=$T
"RTN","IBOHLS1",138,0)
Q:'IBOK
"RTN","IBOHLS1",139,0)
CK3 ; overlap in date range?
"RTN","IBOHLS1",140,0)
N F,T
"RTN","IBOHLS1",141,0)
S F=+IBBILLU,T=$P(IBBILLU,U,2)
"RTN","IBOHLS1",142,0)
I (IBTO<F)!(IBFR>T)
"RTN","IBOHLS1",143,0)
S IBOK='$T
"RTN","IBOHLS1",144,0)
Q:'IBOK
"RTN","IBOHLS1",145,0)
CK4 ; insurance bill?
"RTN","IBOHLS1",146,0)
I $P(IBBILL0,U,11)="i"
"RTN","IBOHLS1",147,0)
S IBOK=$T
"RTN","IBOHLS1",148,0)
Q
"RTN","IBOHLS1",149,0)
;
"RTN","IBOHLS1",150,0)
OTP ; outpatient bills
"RTN","IBOHLS1",151,0)
N X,IBV,IBBILL,IBOK,IBBILL0,IBBCHG,IBBILLU1,IBBILLU,BILL,BCNT
"RTN","IBOHLS1",152,0)
S BCNT=0
"RTN","IBOHLS1",153,0)
S IBV=(IBFR\1)-.0001 F S IBV=$O(^DGCR(399,"AOPV",DFN,IBV)) Q:'IBV!(IBV>IBTO) S IBBILL=0 D
"RTN","IBOHLS1",154,0)
.F S IBBILL=$O(^DGCR(399,"AOPV",DFN,IBV,IBBILL)) Q:('IBBILL) D
"RTN","IBOHLS1",155,0)
.. S IBBILL0=$G(^DGCR(399,IBBILL,0)),IBBILLU=$G(^DGCR(399,IBBILL,"U")) D CK4 Q:'IBOK
"RTN","IBOHLS1",156,0)
.. S BILL=$P(IBBILL0,U,1)
"RTN","IBOHLS1",157,0)
.. S AUDT=$$GET1^DIQ(399,IBBILL,10,"I")
"RTN","IBOHLS1",158,0)
.. S HLDDT=$S(AUDT'="":$$FMDIFF^XLFDT(DT,AUDT,1),1:HDAYS)
"RTN","IBOHLS1",159,0)
.. S IBBCHG=$$GET1^DIQ(430,IBBILL,77)
"RTN","IBOHLS1",160,0)
.. S STATUS=$$GET1^DIQ(430,IBBILL,8,"O")
"RTN","IBOHLS1",161,0)
.. S (BLTRK,RNB)=""
"RTN","IBOHLS1",162,0)
.. S BLTRK=$O(^IBT(356,"E",IBBILL,BLTRK))
"RTN","IBOHLS1",163,0)
.. I BLTRK'="" S RNB=$$GET1^DIQ(356,BLTRK,.19,"O")
"RTN","IBOHLS1",164,0)
.. S BILL=$P(IBBILL0,U,1),BCNT=BCNT+1
"RTN","IBOHLS1",165,0)
.. S IBBILLU1=$G(^DGCR(399,IBBILL,"U1")),IBBCHG=$P(IBBILLU1,U,1)
"RTN","IBOHLS1",166,0)
.. S ^TMP($J,"IBOHLS",NAME,CNT,2,BCNT)=BILL_U_STATUS_U_IBV_U_AUDT_U_HLDDT_U_IBBCHG_U_RNB_U_BLTRK ;BILL#^AR STATUS^DATE BILLED^AUTH DATE^DAYS ON HOLD^CHARGE^RNB^BILL TRK NO
"RTN","IBOHLS1",167,0)
.. S ^TMP($J,"IBOHLS",NAME,CNT,2,BCNT,"B")=IBBILL_U_BLTRK
"RTN","IBOHLS1",168,0)
Q
"RTN","IBOHLS1",169,0)
;
"RTN","IBOHLS1",170,0)
RX ; rx refill bills
"RTN","IBOHLS1",171,0)
N IBRDT,IBRF,IBRX,IBRXN,IBTYPE
"RTN","IBOHLS1",172,0)
S (IBRX,IBRXN,IBRF,IBRDT)=0 N IENS
"RTN","IBOHLS1",173,0)
I $P(IBND,U,4)'["52:" Q
"RTN","IBOHLS1",174,0)
;
"RTN","IBOHLS1",175,0)
S IBTYPE=$P(IBND,"^",3),IBTYPE=$P($G(^IBE(350.1,IBTYPE,0)),"^",1),IBTYPE=$S(IBTYPE["PSO NSC":"RXNSC",IBTYPE["PSO SC":"RX SC",1:$E(IBTYPE,4,7))
"RTN","IBOHLS1",176,0)
S IBRXN=$P($P(IBND,U,4),":",2),IBRX=$P($P(IBND,U,8),"-"),IBRF=$P($P(IBND,U,4),":",3)
"RTN","IBOHLS1",177,0)
S ^TMP($J,"IBOHLS",NAME,CNT,1)=IBRX ;RX VALUE
"RTN","IBOHLS1",178,0)
I +IBRF>0 S IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,IBRF,52,.01)
"RTN","IBOHLS1",179,0)
I +IBRF=0 S IBRDT=$$FILE^IBRXUTL(+IBRXN,22)
"RTN","IBOHLS1",180,0)
;
"RTN","IBOHLS1",181,0)
Q:(IBRX="")!('IBRDT)
"RTN","IBOHLS1",182,0)
N X,IBBILL,IBBILL0,IBFILL,IBFILL0,IBOK,IBBCHG,BCNT
"RTN","IBOHLS1",183,0)
S BCNT=0
"RTN","IBOHLS1",184,0)
S IBFILL=0 F S IBFILL=$O(^IBA(362.4,"B",IBRX,IBFILL)) Q:IBFILL="" D
"RTN","IBOHLS1",185,0)
. S BCNT=BCNT+1
"RTN","IBOHLS1",186,0)
. S IBFILL0=$G(^IBA(362.4,IBFILL,0)) I $P(IBFILL0,U,3)'=IBRDT Q
"RTN","IBOHLS1",187,0)
. S IBBILL=+$P(IBFILL0,U,2) I 'IBBILL Q
"RTN","IBOHLS1",188,0)
. S IBBILL0=$G(^DGCR(399,IBBILL,0)) D CK4 I 'IBOK Q
"RTN","IBOHLS1",189,0)
. S BILL=$P(IBBILL0,U,1)
"RTN","IBOHLS1",190,0)
. S AUDT=$$GET1^DIQ(399,IBBILL,10,"I")
"RTN","IBOHLS1",191,0)
. S HLDDT=$S(AUDT'="":$$FMDIFF^XLFDT(DT,AUDT,1),1:HDAYS)
"RTN","IBOHLS1",192,0)
. S IBBCHG=$$GET1^DIQ(430,IBBILL,77)
"RTN","IBOHLS1",193,0)
. S STATUS=$$GET1^DIQ(430,IBBILL,8,"O")
"RTN","IBOHLS1",194,0)
. S (BLTRK,RNB)=""
"RTN","IBOHLS1",195,0)
. S BLTRK=$O(^IBT(356,"E",IBBILL,BLTRK))
"RTN","IBOHLS1",196,0)
. I BLTRK'="" S RNB=$$GET1^DIQ(356,BLTRK,.19,"O")
"RTN","IBOHLS1",197,0)
. S BCNT=BCNT+1
"RTN","IBOHLS1",198,0)
. S IBBILLU1=$G(^DGCR(399,IBBILL,"U1")),IBBCHG=$P(IBBILLU1,U,1)
"RTN","IBOHLS1",199,0)
. S ^TMP($J,"IBOHLS",NAME,CNT,2,BCNT)=BILL_U_STATUS_U_IBRDT_U_AUDT_U_HLDDT_U_IBBCHG_U_RNB_U_BLTRK ;BILL#^AR STATUS^DATE BILLED^CHARGE
"RTN","IBOHLS1",200,0)
. S ^TMP($J,"IBOHLS",NAME,CNT,2,BCNT,"B")=IBBILL_U_BLTRK_U_RNB
"RTN","IBOHLS1",201,0)
Q
"RTN","IBOHLS1",202,0)
;
"RTN","IBOHLS1",203,0)
GETINS ; get insurance information
"RTN","IBOHLS1",204,0)
N XX,IBINS,IBX,ICNT,INSCO,SUBID,PLNID,EFFDT,EFDTCK,EXPDT,EXDTCK,LEDT,SUBNAM,CVD
"RTN","IBOHLS1",205,0)
N PLNCOV,PEFDT,PCOVD,PCOM,PCNT,COVFN,GRP,CKDT,IBCNT
"RTN","IBOHLS1",206,0)
N IBINS0,IBINS7,LIM,INSTYP,IB0,IBS,REIMB
"RTN","IBOHLS1",207,0)
S (PLNCOV,PLNID,PEFDT,PCOVD,PCOM)=""
"RTN","IBOHLS1",208,0)
S ICNT=0
"RTN","IBOHLS1",209,0)
D ALL^IBCNS1(DFN,"IBINS")
"RTN","IBOHLS1",210,0)
S XX=0
"RTN","IBOHLS1",211,0)
F S XX=$O(IBINS(XX)) Q:'XX D
"RTN","IBOHLS1",212,0)
. S IBINS0=IBINS(XX,0)
"RTN","IBOHLS1",213,0)
. S IBINS7=$G(IBINS(XX,7))
"RTN","IBOHLS1",214,0)
. S PLNID=$P(IBINS0,U,18),GRP=$P(IBINS0,U,3)
"RTN","IBOHLS1",215,0)
. I PLNID'="" I $P($G(^IBA(355.3,PLNID,0)),"^",11) Q ;plan is inactive
"RTN","IBOHLS1",216,0)
. S INSCO=$P(^DIC(36,+IBINS0,0),U,1),REIMB=$P(INSCO,U,2)
"RTN","IBOHLS1",217,0)
. I $P(INSCO,U,5) Q ;insurance company inactive
"RTN","IBOHLS1",218,0)
. S SUBID=$P(IBINS7,U,2)
"RTN","IBOHLS1",219,0)
. S SUBNAM=$P(IBINS7,U,1)
"RTN","IBOHLS1",220,0)
. S EXDTCK=+$P(IBINS0,U,4)
"RTN","IBOHLS1",221,0)
. S EFDTCK=+$P(IBINS0,U,8)
"RTN","IBOHLS1",222,0)
. I EXDTCK,EXDTCK<IBFR Q ; if insurance expired before the from date of copay quit
"RTN","IBOHLS1",223,0)
. I EFDTCK,EFDTCK>IBTO Q ; if insurance not in effect for period quit
"RTN","IBOHLS1",224,0)
. S EFFDT=$$DAT1^IBOUTL(EFDTCK)
"RTN","IBOHLS1",225,0)
. S EXPDT=$$DAT1^IBOUTL(EXDTCK)
"RTN","IBOHLS1",226,0)
. S ICNT=ICNT+1
"RTN","IBOHLS1",227,0)
. ;ins co^sub id^plan id^effective dt^expiration date
"RTN","IBOHLS1",228,0)
. S ^TMP($J,"IBOHLS",NAME,CNT,3,ICNT)=IBINS0_U_PLNID
"RTN","IBOHLS1",229,0)
. S ^TMP($J,"IBOHLS INS",NAME,ICNT)=INSCO_U_SUBNAM_U_GRP_U_EFFDT_U_EXPDT
"RTN","IBOHLS1",230,0)
. ;plan coverage^effective date^covered?^limit comments
"RTN","IBOHLS1",231,0)
. S LIM=0,PCNT=0
"RTN","IBOHLS1",232,0)
. F S LIM=$O(^IBE(355.31,LIM)) Q:'LIM D
"RTN","IBOHLS1",233,0)
.. S PLNCOV=$P($G(^IBE(355.31,LIM,0)),U),IBCNT=0,PEFDT=""
"RTN","IBOHLS1",234,0)
.. S PCOVD="",LEDT="",PCOM=""
"RTN","IBOHLS1",235,0)
.. F S LEDT=$O(^IBA(355.32,"APCD",PLNID,LIM,LEDT)) Q:$S(LEDT="":IBCNT,1:0) D Q:LEDT=""
"RTN","IBOHLS1",236,0)
... S COVFN=+$O(^IBA(355.32,"APCD",PLNID,LIM,+LEDT,"")),PCOVD=$G(^IBA(355.32,+COVFN,0))
"RTN","IBOHLS1",237,0)
... S PEFDT=$$DAT1^IBOUTL($P(LEDT,"-",2))
"RTN","IBOHLS1",238,0)
... I PCOVD="" S PCOVD="BY DEFAULT" D SETINS(PLNCOV,PEFDT,PCOVD,PCOM,IBCNT) Q
"RTN","IBOHLS1",239,0)
... S IBCNT=IBCNT+1,PCOM=""
"RTN","IBOHLS1",240,0)
... I PCOVD'="" S CVD=$P(PCOVD,U,4),PCOVD=$S(CVD:$S(CVD<2:"YES",CVD=2:"CONDITIONAL",1:"UNKNOWN"),1:"NO")
"RTN","IBOHLS1",241,0)
... I '$O(^IBA(355.32,COVFN,2,0)) D SETINS(PLNCOV,PEFDT,PCOVD,PCOM,IBCNT) Q
"RTN","IBOHLS1",242,0)
... S (IBS,IB0)=0 F S IB0=$O(^IBA(355.32,COVFN,2,IB0)) Q:'IB0 D
"RTN","IBOHLS1",243,0)
.... S PCOM=""
"RTN","IBOHLS1",244,0)
.... S PCOM=^IBA(355.32,COVFN,2,IB0,0)
"RTN","IBOHLS1",245,0)
.... I IBS=0 D SETINS(PLNCOV,PEFDT,PCOVD,PCOM,IBCNT)
"RTN","IBOHLS1",246,0)
.... I IBS>0 D SETCOV(PCOM)
"RTN","IBOHLS1",247,0)
.... S IBS=IBS+1
"RTN","IBOHLS1",248,0)
Q
"RTN","IBOHLS1",249,0)
;
"RTN","IBOHLS1",250,0)
SETINS(PLNCOV,PEFDT,PCOVD,PCOM,IBCNT) ; SET GLOBAL ENTRY
"RTN","IBOHLS1",251,0)
S PCNT=PCNT+1
"RTN","IBOHLS1",252,0)
I IBCNT>1 S PLNCOV=""
"RTN","IBOHLS1",253,0)
S ^TMP($J,"IBOHLS",NAME,CNT,3,ICNT,PCNT)=""
"RTN","IBOHLS1",254,0)
S ^TMP($J,"IBOHLS INS",NAME,ICNT,0)=IBINS0_U_PLNID
"RTN","IBOHLS1",255,0)
S ^TMP($J,"IBOHLS INS",NAME,ICNT,PCNT)=PLNCOV_U_PEFDT_U_PCOVD_U_PCOM
"RTN","IBOHLS1",256,0)
Q
"RTN","IBOHLS1",257,0)
;
"RTN","IBOHLS1",258,0)
SETCOV(PCOM) ; SET COVERAGE WHEN MULTIPLE
"RTN","IBOHLS1",259,0)
S PCNT=PCNT+1
"RTN","IBOHLS1",260,0)
S ^TMP($J,"IBOHLS INS",NAME,ICNT,PCNT)=""_U_""_U_""_U_PCOM
"RTN","IBOHLS1",261,0)
Q
"RTN","IBOLK")
0^29^B19580786
"RTN","IBOLK",1,0)
IBOLK ;ALB/AAS - INTEGRATED BILLING - DISPLAY BY BILL NUMBER ;6-MAR-91
"RTN","IBOLK",2,0)
;;2.0;INTEGRATED BILLING ;**199,420,433,618**;21-MAR-94;Build 60
"RTN","IBOLK",3,0)
;Per VA Directive 6402, this routine should not be modified.
"RTN","IBOLK",4,0)
;
"RTN","IBOLK",5,0)
% ;
"RTN","IBOLK",6,0)
;***
"RTN","IBOLK",7,0)
;I $D(XRT0) S:'$D(XRTN) XRTN="IBOLK" D T1^%ZOSV ;stop rt clock
"RTN","IBOLK",8,0)
;S XRTL=$ZU(0),XRTN="IBOLK-1" D T0^%ZOSV ;start rt clock
"RTN","IBOLK",9,0)
N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
"RTN","IBOLK",10,0)
S DIC("A")="Select CHARGE ID or PATIENT NAME: ",DIC="^PRCA(430,",DIC(0)="AEQM" D ^DIC K DIC G END1:+Y<1 S IBIL=$P(Y,"^",2)
"RTN","IBOLK",11,0)
; user needs to be able to look-up any iteration ie. K600111 or K600111-01
"RTN","IBOLK",12,0)
;S IBIFN=$O(^DGCR(399,"B",$P(IBIL,"-",2),0))
"RTN","IBOLK",13,0)
S IBIFN=$O(^DGCR(399,"B",$P(IBIL,"-",2,3),0))
"RTN","IBOLK",14,0)
I '$D(^IB("ABIL",IBIL)),'IBIFN W !!,"Billing has no Record of this Charge ID.",! G %
"RTN","IBOLK",15,0)
;
"RTN","IBOLK",16,0)
BRIEF R !,"(B)rief or (F)ull Inquiry: B// ",X:DTIME G:X="^"!('$T) END1 S:X="" X="B" S X=$E(X)
"RTN","IBOLK",17,0)
I "BFbf"'[X D G BRIEF
"RTN","IBOLK",18,0)
. W !!?5,"Enter: '<CR>' - To select the Brief Inquiry."
"RTN","IBOLK",19,0)
. W !?12,"'F' - To select the Full Inquiry. This option will"
"RTN","IBOLK",20,0)
. W !?23,"include the Address Inquiry, and more detailed"
"RTN","IBOLK",21,0)
. W !?23,"information for Pharmacy Co-Pay bills."
"RTN","IBOLK",22,0)
. W !?12,"'^' - To quit this option.",!
"RTN","IBOLK",23,0)
W $S("Bb"[X:" BRIEF",1:" FULL") S IBFULL="Ff"[X
"RTN","IBOLK",24,0)
I IBIFN S IBAC=8,IBQUIT=0
"RTN","IBOLK",25,0)
;
"RTN","IBOLK",26,0)
DEV W ! S %ZIS="QM",%ZIS("A")="Output Device: " D ^%ZIS G:POP END
"RTN","IBOLK",27,0)
I $D(IO("Q")) D D ^%ZTLOAD K IO("Q") D HOME^%ZIS W ! G %
"RTN","IBOLK",28,0)
. S ZTDESC="IB Print Actions by Bill Number"
"RTN","IBOLK",29,0)
. S ZTRTN=$S(IBIFN:"VIEW^IBCNQ",1:"EN^IBOLK")
"RTN","IBOLK",30,0)
. S ZTSAVE("IBFULL")="",ZTSAVE("IBIL")="",ZTSAVE("IBIFN")=""
"RTN","IBOLK",31,0)
. I IBIFN F I="IBAC","IBQUIT" S ZTSAVE(I)=""
"RTN","IBOLK",32,0)
;
"RTN","IBOLK",33,0)
U IO
"RTN","IBOLK",34,0)
;***
"RTN","IBOLK",35,0)
;I $D(XRT0) S:'$D(XRTN) XRTN="IBOLK" D T1^%ZOSV ;stop rt clock
"RTN","IBOLK",36,0)
I 'IBIFN D EN G %
"RTN","IBOLK",37,0)
D VIEW^IBCNQ,Q^IBCNQ,END1 G %
"RTN","IBOLK",38,0)
;
"RTN","IBOLK",39,0)
EN ; -Entry to display IB Action data for an AR Bill number
"RTN","IBOLK",40,0)
; -Input IBIL = external form of bill number, ie 500-K10001
"RTN","IBOLK",41,0)
; IBFULL = 1 for full profile logic, 0 for brief description
"RTN","IBOLK",42,0)
;***
"RTN","IBOLK",43,0)
;S XRTL=$ZU(0),XRTN="IBOLK-2" D T0^%ZOSV ;start rt clock
"RTN","IBOLK",44,0)
S IBN=$O(^IB("ABIL",IBIL,"")) G:'$D(^IB(IBN,0)) ENQ
"RTN","IBOLK",45,0)
S IBTOTL=0,IBQUIT="",IBPAG=0 D NOW^%DTC S IBHDT=$$DAT2^IBOUTL($E(%,1,12)) D HDR
"RTN","IBOLK",46,0)
;
"RTN","IBOLK",47,0)
S IBN="" F IBI=0:0 S IBN=$O(^IB("ABIL",IBIL,IBN)) Q:'IBN I $D(^IB(IBN,0)) D LINE Q:IBQUIT
"RTN","IBOLK",48,0)
I 'IBQUIT D TOTAL,PAUSE,^IBOLK1:IBFULL&('IBQUIT)
"RTN","IBOLK",49,0)
ENQ D END Q
"RTN","IBOLK",50,0)
;
"RTN","IBOLK",51,0)
LINE ; -find data for one line, write line, accumulate totals
"RTN","IBOLK",52,0)
I '$D(IBTRAN),$Y>(IOSL-5) D PAUSE Q:IBQUIT D HDR1
"RTN","IBOLK",53,0)
S IBND=^IB(IBN,0),IBND1=$G(^(1))
"RTN","IBOLK",54,0)
I IBFULL,$D(^IBE(350.1,+$P(IBND,"^",3),30)),+$P(IBND,"^",4)=52 W ! S X1=$P($P($P(IBND,"^",4),";",1),":",2),X2=$P($P($P(IBND,"^",4),";",2),":",2),X=X1_"^"_$S(X2:X2,1:0) X ^(30)
"RTN","IBOLK",55,0)
S IBTYP=$G(^IBE(350.1,+$P(IBND,"^",3),0)),IBSEQNO=$P(IBTYP,"^",5)
"RTN","IBOLK",56,0)
W ! S Y=$P($P(IBND1,"^",2),".",1) D DT^DIQ
"RTN","IBOLK",57,0)
;IB*2.0*618 Corrected display for new Action Types
"RTN","IBOLK",58,0)
S IBTYP=$S($E(IBTYP,1,2)="DG":$P(IBTYP," ",2,99),$E(IBTYP,1,3)="PSO":$P(IBTYP," ",2,99),1:IBTYP)
"RTN","IBOLK",59,0)
W ?15,$E($P(IBTYP,"^"),1,20)
"RTN","IBOLK",60,0)
; display brief description if not a CC action type
"RTN","IBOLK",61,0)
I ($P(IBTYP,U)'["CC"),($P(IBTYP,U)'["CHOICE") W ?37,$E($P(IBND,"^",8),1,20)
"RTN","IBOLK",62,0)
;end IB*2.0*618
"RTN","IBOLK",63,0)
W ?60,$J($P(IBND,"^",6),5)
"RTN","IBOLK",64,0)
S IBCHRG=$P(IBND,"^",7) I IBSEQNO=2 S IBCHRG=(-IBCHRG) ;cancel types are decrease adjustments
"RTN","IBOLK",65,0)
S X=IBCHRG,X2="2$",X3=10 D COMMA^%DTC W ?69,X
"RTN","IBOLK",66,0)
S IBTOTL=IBTOTL+IBCHRG
"RTN","IBOLK",67,0)
I $P(IBND,"^",10),IBSEQNO=2 W !,?5,"Charge Removal Reason: ",$S($D(^IBE(350.3,$P(IBND,"^",10),0)):$P(^(0),"^"),1:"UNKNOWN")
"RTN","IBOLK",68,0)
Q
"RTN","IBOLK",69,0)
;
"RTN","IBOLK",70,0)
HDR S IBND=^IB(IBN,0),DFN=+$P(IBND,"^",2),IBNAME=$$PT^IBEFUNC(DFN)
"RTN","IBOLK",71,0)
HDR1 S IBPAG=IBPAG+1 I $E(IOST,1,2)["C-"!(IBPAG>1) W @IOF,*13
"RTN","IBOLK",72,0)
;W $E($P(IBNAME,"^"),1,20)," ",$P(IBNAME,"^",2),?38,IBIL,?51,IBHDT,?72,"PAGE: ",IBPAG
"RTN","IBOLK",73,0)
W $E($P(IBNAME,"^"),1,20)," ",$P(IBNAME,"^",2),?36,IBIL,?51,IBHDT,?72,"PAGE: ",IBPAG
"RTN","IBOLK",74,0)
D DISP^IBARXEU(DFN,DT,2) W !
"RTN","IBOLK",75,0)
W:'IBFULL !,"DATE",?15,"CHARGE TYPE",?37,"BRIEF DESCRIPTION",?62,"UNITS",?73,"CHARGE"
"RTN","IBOLK",76,0)
S IBLINE="",$P(IBLINE,"=",IOM)="" W !,IBLINE K IBLINE
"RTN","IBOLK",77,0)
Q
"RTN","IBOLK",78,0)
;
"RTN","IBOLK",79,0)
TOTAL W !?67,"------------" S X=IBTOTL,X2="2$",X3=12 D COMMA^%DTC
"RTN","IBOLK",80,0)
W !,?67,X
"RTN","IBOLK",81,0)
Q
"RTN","IBOLK",82,0)
;
"RTN","IBOLK",83,0)
PAUSE Q:$E(IOST,1,2)'["C-"
"RTN","IBOLK",84,0)
F IBJ=$Y:1:(IOSL-4) W !
"RTN","IBOLK",85,0)
S DIR(0)="E" D ^DIR K DIR I $D(DIRUT)!($D(DUOUT)) S IBQUIT=1 K DIRUT,DTOUT,DUOUT
"RTN","IBOLK",86,0)
Q
"RTN","IBOLK",87,0)
;
"RTN","IBOLK",88,0)
END1 K IBFULL
"RTN","IBOLK",89,0)
END W !
"RTN","IBOLK",90,0)
;***
"RTN","IBOLK",91,0)
;I $D(XRT0) S:'$D(XRTN) XRTN="IBOLK" D T1^%ZOSV ;stop rt clock
"RTN","IBOLK",92,0)
I $D(ZTQUEUED) S ZTREQ="@" Q
"RTN","IBOLK",93,0)
K X,X2,X3,Y,DFN,IBIFN,IBAC,I,IB,IBIL,IBI,IBJ,IBNAME,IBLINE,IBN,IBND,IBND1,IBCHRG,IBSEQNO,IBTYP,IBTOTL,ZTSK,IBHDT,IBPAG,IBQUIT,DN,D0,DUOUT,DTOUT,VA,VADM,VAERR
"RTN","IBOLK",94,0)
D ^%ZISC
"RTN","IBOLK",95,0)
Q
"RTN","IBOLK",96,0)
;
"RTN","IBOLK",97,0)
ENF ; -entry point for AR to print full profile for IB actions for
"RTN","IBOLK",98,0)
; an ar transaction number.
"RTN","IBOLK",99,0)
; -input x = ar transaction number ($p(^ib(ibn,0),u,12)
"RTN","IBOLK",100,0)
;
"RTN","IBOLK",101,0)
S IBFULL=1
"RTN","IBOLK",102,0)
;
"RTN","IBOLK",103,0)
ENB ; -entry point for AR to print brief profile for IB actions for
"RTN","IBOLK",104,0)
; an ar transaction number.
"RTN","IBOLK",105,0)
; -input x = ar transaction number
"RTN","IBOLK",106,0)
;
"RTN","IBOLK",107,0)
S IBTOTL=0,IBPAG=0,IBQUIT="" S:'$D(IBFULL) IBFULL=0
"RTN","IBOLK",108,0)
S IBTRAN=X
"RTN","IBOLK",109,0)
S IBN="" F S IBN=$O(^IB("AT",IBTRAN,IBN)) Q:IBN="" D LINE
"RTN","IBOLK",110,0)
K D0,DN,X,X2,X3,Y,IBFULL,IBTOTL,IBPAG,IBQUIT,IBTRAN,IBN,IBND,IBND1,IBSEQNO,IBTYP,IBCHRG
"RTN","IBOLK",111,0)
Q
"RTN","IBOMTC1")
0^28^B13744112
"RTN","IBOMTC1",1,0)
IBOMTC1 ;ALB/CPM-BILLING ACTIVITY LIST (CON'T) ; 09-JAN-92
"RTN","IBOMTC1",2,0)
;;2.0;INTEGRATED BILLING;**145,176,618**;21-MAR-94;Build 60
"RTN","IBOMTC1",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","IBOMTC1",4,0)
;
"RTN","IBOMTC1",5,0)
;***
"RTN","IBOMTC1",6,0)
;S XRTL=$ZU(0),XRTN="IBOMTC-2" D T0^%ZOSV ;start rt clock
"RTN","IBOMTC1",7,0)
; Select charges from file #350.
"RTN","IBOMTC1",8,0)
K ^TMP($J,"IBPHT")
"RTN","IBOMTC1",9,0)
N IBTYPE,IBIEN ; Patch IB*2.0*618
"RTN","IBOMTC1",10,0)
S DFN="" F S DFN=$O(^IB("AFDT",DFN)) Q:'DFN S IBHEART=$$PH(DFN) D:'$G(IBPURPHT)!($G(IBPURPHT)&(IBHEART))
"RTN","IBOMTC1",11,0)
. S EVDT=-(IBEDT+.99) F S EVDT=$O(^IB("AFDT",DFN,EVDT)) Q:'EVDT D
"RTN","IBOMTC1",12,0)
.. S EVDA=0 F S EVDA=$O(^IB("AFDT",DFN,EVDT,EVDA)) Q:'EVDA D
"RTN","IBOMTC1",13,0)
... S IBDA=0 F IBCNT=1:1 S IBDA=$O(^IB("AF",EVDA,IBDA)) Q:'IBDA D
"RTN","IBOMTC1",14,0)
.... Q:'$D(^IB(IBDA,0)) S IBD0=^(0)
"RTN","IBOMTC1",15,0)
.... Q:$P(IBD0,"^",8)["ADMISSION"
"RTN","IBOMTC1",16,0)
.... I $P(IBD0,"^",15)<IBBDT!($P(IBD0,"^",14)>IBEDT) Q
"RTN","IBOMTC1",17,0)
.... S NAM=$P($G(^DPT(DFN,0)),"^") S:NAM="" NAM="UNKNOWN"
"RTN","IBOMTC1",18,0)
.... S ^TMP($J,"IBOMTC",NAM_"@@"_DFN,+$P(IBD0,"^",14),IBDA)=""
"RTN","IBOMTC1",19,0)
.... I IBHEART S ^TMP($J,"IBPHT",NAM_"@@"_DFN)=""
"RTN","IBOMTC1",20,0)
;
"RTN","IBOMTC1",21,0)
; Print report.
"RTN","IBOMTC1",22,0)
D NOW^%DTC S IBHDT=$$DAT2^IBOUTL($E(%,1,12))
"RTN","IBOMTC1",23,0)
S IBLINE="",$P(IBLINE,"-",IOM+1)="",(IBPAG,IBQUIT)=0 D HDR G:IBQUIT END
"RTN","IBOMTC1",24,0)
I '$D(^TMP($J,"IBOMTC")) S IBX=$S($G(IBPURPHT):"Purple Heart Recipients",1:"Bills") W !!,"There are no "_IBX_" for this date range." G END
"RTN","IBOMTC1",25,0)
;
"RTN","IBOMTC1",26,0)
S NAM="" F S NAM=$O(^TMP($J,"IBOMTC",NAM)) Q:NAM="" D Q:IBQUIT
"RTN","IBOMTC1",27,0)
. S IBPT=$$PT^IBEFUNC($P(NAM,"@@",2))
"RTN","IBOMTC1",28,0)
. I $Y>(IOSL-5) D PHT,PAUSE^IBOUTL Q:IBQUIT D HDR Q:IBQUIT
"RTN","IBOMTC1",29,0)
. W !,$S($D(^TMP($J,"IBPHT",NAM)):"*",1:" ")_$E($P(IBPT,"^"),1,9),?11,$P(IBPT,"^",3)
"RTN","IBOMTC1",30,0)
. S IBDT="" F S IBDT=$O(^TMP($J,"IBOMTC",NAM,IBDT)) Q:'IBDT D Q:IBQUIT
"RTN","IBOMTC1",31,0)
.. S IBDA="" F S IBDA=$O(^TMP($J,"IBOMTC",NAM,IBDT,IBDA)) Q:'IBDA D Q:IBQUIT
"RTN","IBOMTC1",32,0)
... I $Y>(IOSL-4) D PHT,PAUSE^IBOUTL Q:IBQUIT D HDR Q:IBQUIT W !,$S($D(^TMP($J,"IBPHT",NAM)):"*",1:" ")_$E($P(IBPT,"^"),1,9),?11,$P(IBPT,"^",3)
"RTN","IBOMTC1",33,0)
... S IBD0=$G(^IB(+IBDA,0)) Q:'IBD0
"RTN","IBOMTC1",34,0)
... S X=$P($G(^IBE(350.1,+$P(IBD0,"^",3),0)),"^")
"RTN","IBOMTC1",35,0)
... ; begin of Patch IB*2.0*618 - added community care - action types
"RTN","IBOMTC1",36,0)
... S IBIEN=$P(IBD0,"^",3),IBTYPE=$$GETATYPE(IBIEN)
"RTN","IBOMTC1",37,0)
... W ?17,IBTYPE
"RTN","IBOMTC1",38,0)
... ; end of Patch IB*2.0*618
"RTN","IBOMTC1",39,0)
... W ?35,$E($P($G(^IBE(350.21,+$P(IBD0,"^",5),0)),"^",2),1,11)
"RTN","IBOMTC1",40,0)
... W ?47,$$DAT1^IBOUTL($P(IBD0,"^",14)),?57,$$DAT1^IBOUTL($P(IBD0,"^",15))
"RTN","IBOMTC1",41,0)
... W ?66,$J($P(IBD0,"^",6),3)
"RTN","IBOMTC1",42,0)
... S X=$P(IBD0,"^",7),X2="2$",X3=10 D COMMA^%DTC W ?70,X,!
"RTN","IBOMTC1",43,0)
;
"RTN","IBOMTC1",44,0)
; - close device and quit
"RTN","IBOMTC1",45,0)
END D:'IBQUIT PHT,PAUSE^IBOUTL K ^TMP($J,"IBOMTC"),^TMP($J,"IBPHT")
"RTN","IBOMTC1",46,0)
;***
"RTN","IBOMTC1",47,0)
;I $D(XRT0) S:'$D(XRTN) XRTN="IBOMTC1" D T1^%ZOSV ;stop rt clock
"RTN","IBOMTC1",48,0)
I $D(ZTQUEUED) S ZTREQ="@" Q
"RTN","IBOMTC1",49,0)
K NAM,DFN,EVDA,EVDT,IBD0,IBDA,IBDT,IBJ,IBQUIT,IBLINE,IBHDT,IBHEART,IBN,IBPAG,IBPT,IBCNT,X,X2,X3
"RTN","IBOMTC1",50,0)
D ^%ZISC Q
"RTN","IBOMTC1",51,0)
;
"RTN","IBOMTC1",52,0)
;
"RTN","IBOMTC1",53,0)
HDR ; Print header.
"RTN","IBOMTC1",54,0)
I $E(IOST,1,2)["C-"!(IBPAG) W @IOF
"RTN","IBOMTC1",55,0)
S IBPAG=IBPAG+1 W !,IBDESC,?IOM-35,IBHDT,?IOM-9,"Page: ",IBPAG
"RTN","IBOMTC1",56,0)
I $G(IBPURPHT) W !," * This report is being generated for Purple Heart Patients only *"
"RTN","IBOMTC1",57,0)
W !,"Charges from ",$$DAT1^IBOUTL(IBBDT)," through ",$$DAT1^IBOUTL(IBEDT)
"RTN","IBOMTC1",58,0)
W !,"PATIENT/ID",?17,"DESCRIPTION",?35,"STATUS",?49,"FROM",?60,"TO",?66,"UNITS",?72,"CHARGE"
"RTN","IBOMTC1",59,0)
W !,IBLINE
"RTN","IBOMTC1",60,0)
S IBQUIT=$$STOP^IBOUTL("Billing Activity List")
"RTN","IBOMTC1",61,0)
Q
"RTN","IBOMTC1",62,0)
PHT ;ADDS the footnote of * Purple Heart Recipient to the report.
"RTN","IBOMTC1",63,0)
W !,?10,"* Purple Heart Recipient"
"RTN","IBOMTC1",64,0)
Q
"RTN","IBOMTC1",65,0)
;
"RTN","IBOMTC1",66,0)
;
"RTN","IBOMTC1",67,0)
PH(DFN) ;Call to find out if a patient is a Purple Heart recipient.
"RTN","IBOMTC1",68,0)
; DFN - patient's DFN
"RTN","IBOMTC1",69,0)
;
"RTN","IBOMTC1",70,0)
; Output - 1 means PH Indicator is "Yes"
"RTN","IBOMTC1",71,0)
; 0 means PH Indicator is not "yes" (either "no" or null)
"RTN","IBOMTC1",72,0)
I '$D(^DPT(+$G(DFN),0)) Q 0
"RTN","IBOMTC1",73,0)
N IBPHT,VASV,VAERR
"RTN","IBOMTC1",74,0)
D SVC^VADPT
"RTN","IBOMTC1",75,0)
S IBPHT=$P($G(VASV(9,1)),"^",1)
"RTN","IBOMTC1",76,0)
I IBPHT'=3 S IBPHT=0
"RTN","IBOMTC1",77,0)
Q IBPHT
"RTN","IBOMTC1",78,0)
;
"RTN","IBOMTC1",79,0)
GETATYPE(IBIEN) ; Patch IB*2.0*618 - added community care - action types
"RTN","IBOMTC1",80,0)
S IBTYPE=$P(^IBE(350.1,IBIEN,0),"^") I $E(IBTYPE,1,2)="DG" Q $E($P(IBTYPE," ",2,99),1,16)
"RTN","IBOMTC1",81,0)
I $E(IBTYPE,1,3)="PSO" Q $E($P(IBTYPE," ",2,99),1,16)
"RTN","IBOMTC1",82,0)
Q $E(IBTYPE,1,16)
"RTN","IBP618A")
0^2^B102033920
"RTN","IBP618A",1,0)
IBP618A ;SAB/Albany - IB*2.0*618 POST INSTALL (CONT'D);12/11/17 2:10pm
"RTN","IBP618A",2,0)
;;2.0;Integrated Billing;**618**;Mar 20, 1995;Build 60
"RTN","IBP618A",3,0)
;Per VA Directive 6402, this routine should not be modified.
"RTN","IBP618A",4,0)
Q
"RTN","IBP618A",5,0)
;
"RTN","IBP618A",6,0)
ADDACT ; Add new ACTION TYPE ENTRIES (350.1)
"RTN","IBP618A",7,0)
;
"RTN","IBP618A",8,0)
N IBLOOP,IBDATA,FDA,IBARCAT,IBSVC,FDAIEN
"RTN","IBP618A",9,0)
N X,Y,DIE,DA,DR,DTOUT
"RTN","IBP618A",10,0)
N IBSL,IBSL1,IBSL1TXT,IBSL2,IBSL2TXT,IBSL3,IBSL3TX1,IBSL3TX2,IBSL3TX3
"RTN","IBP618A",11,0)
N IBIEN,IBLAST,IBBEG,IBEND
"RTN","IBP618A",12,0)
N IBEL,IBEL1,IBEL2,IBEL3,IBDQDASH
"RTN","IBP618A",13,0)
;
"RTN","IBP618A",14,0)
; Define the Logic field information
"RTN","IBP618A",15,0)
; Set Logic
"RTN","IBP618A",16,0)
S IBDQDASH=$c(95)_$c(34)_$c(45)_$c(34)_$c(95)
"RTN","IBP618A",17,0)
S IBSL2TXT="FEE OPT COPAYMENT"
"RTN","IBP618A",18,0)
S IBSL2="S IBDESC="_$C(34)_IBSL2TXT_$C(34)
"RTN","IBP618A",19,0)
S IBSL1TXT="INPT PER DIEM"
"RTN","IBP618A",20,0)
S IBSL1="S IBDESC="_$C(34)_IBSL1TXT_$C(34)
"RTN","IBP618A",21,0)
S IBSL3TX1="S:'$D(^(10)) X="""" I $D(^(10)) X ^(10) S X=$S($D(Y(0)):$P(Y(0),U),1:""UNK"") "
"RTN","IBP618A",22,0)
S IBSL3TX2="I $D(Y(0)) S X=X_""-""_$S($$DRUG^IBRXUTL1(+$P(Y(0),U,6))'="""":$$DRUG^IBRXUTL1(+$P(Y(0),U,6)),1:"_"""UNK DRUG"""_")"
"RTN","IBP618A",23,0)
S IBSL3TX3=",X=$E(X,1,18)_""-""_$S($D(IBUNIT):IBUNIT,$D(IBX):$P(IBX,U,2),1:"""")"
"RTN","IBP618A",24,0)
S IBSL3=IBSL3TX1_IBSL3TX2_IBSL3TX3
"RTN","IBP618A",25,0)
;
"RTN","IBP618A",26,0)
; Eligibility Logic
"RTN","IBP618A",27,0)
S IBEL1="S X=0,X1="""_",X2="_""""_" "
"RTN","IBP618A",28,0)
S IBEL2="G:'$D(VAEL) 1^IBAERR I VAEL(4),'+VAEL(3),'IBDOM,'$$RXEXMT^IBARXEU0(DFN,DT) "
"RTN","IBP618A",29,0)
S IBEL3="S X=1,X2=$P(^IBE(350.1,DA,0),"_""_"^"_""_",4) D COST^IBAUTL"
"RTN","IBP618A",30,0)
S IBEL=IBEL1_IBEL2_IBEL3
"RTN","IBP618A",31,0)
S IBLAST=1
"RTN","IBP618A",32,0)
S IBIEN="" F S IBIEN=$O(^IBE(350.1,IBIEN)) Q:IBIEN="" S:$G(IBIEN) IBLAST=IBIEN
"RTN","IBP618A",33,0)
S IBBEG=IBLAST
"RTN","IBP618A",34,0)
;
"RTN","IBP618A",35,0)
D MES^XPDUTL(" -> Adding new AT entries to file 350.1 ...")
"RTN","IBP618A",36,0)
F IBLOOP=1:1 S IBDATA=$T(ACTDAT+IBLOOP) Q:IBDATA=" ;;END" D
"RTN","IBP618A",37,0)
. ;Clear the array
"RTN","IBP618A",38,0)
. K FDA
"RTN","IBP618A",39,0)
. ;Extract the new ACTION TYPE to be added.
"RTN","IBP618A",40,0)
. Q:$D(^IBE(350.1,"B",$P(IBDATA,";",3))) ; Quit loop if action type exist
"RTN","IBP618A",41,0)
. ;Store in array for adding to the file (#350.1).
"RTN","IBP618A",42,0)
. S FDA(350.1,"+1,",.01)=$P(IBDATA,";",3) ;Name
"RTN","IBP618A",43,0)
. S FDA(350.1,"+1,",.02)=$P(IBDATA,";",4) ;Abbreviation
"RTN","IBP618A",44,0)
. S IBARCAT=$P(IBDATA,";",5) ;AR Cat (Charge Code)
"RTN","IBP618A",45,0)
. S:IBARCAT'="" IBARCAT=$O(^PRCA(430.2,"B",IBARCAT,"")) ;Find local IEN for AR Cat
"RTN","IBP618A",46,0)
. S FDA(350.1,"+1,",.03)=IBARCAT
"RTN","IBP618A",47,0)
. S IBSVC=$P(IBDATA,";",6) ;Service
"RTN","IBP618A",48,0)
. S:IBSVC'="" IBSVC=$O(^DIC(49,"B",IBSVC,"")) ;Find local IEN for Service
"RTN","IBP618A",49,0)
. S FDA(350.1,"+1,",.04)=IBSVC
"RTN","IBP618A",50,0)
. S FDA(350.1,"+1,",.05)=$P(IBDATA,";",7) ;Seq Number
"RTN","IBP618A",51,0)
. S FDA(350.1,"+1,",.08)=$P(IBDATA,";",8) ;User Lookup Name
"RTN","IBP618A",52,0)
. S FDA(350.1,"+1,",.1)=$P(IBDATA,";",9) ;Place on Hold
"RTN","IBP618A",53,0)
. S FDA(350.1,"+1,",.11)=$P(IBDATA,";",10) ;Billing Group
"RTN","IBP618A",54,0)
. I $P(IBDATA,";",11)'="" S FDA(350.1,"+1,",10)=$P(IBDATA,";",11) ;Parent Logic
"RTN","IBP618A",55,0)
. I $P(IBDATA,";",12)'="" S FDA(350.1,"+1,",20)=@$P(IBDATA,";",12) ;Set Logic
"RTN","IBP618A",56,0)
. I $P(IBDATA,";",13)'="" S FDA(350.1,"+1,",30)=$P(IBDATA,";",13) ;Full Logic
"RTN","IBP618A",57,0)
. I $P(IBDATA,";",14)'="" S FDA(350.1,"+1,",40)=@$P(IBDATA,";",14) ;Eligibility Logic
"RTN","IBP618A",58,0)
. ;Add to the IB file.
"RTN","IBP618A",59,0)
. D UPDATE^DIE(,"FDA","FDAIEN")
"RTN","IBP618A",60,0)
. S FDAIEN=FDAIEN(1) K FDAIEN(1)
"RTN","IBP618A",61,0)
D MES^XPDUTL(" New ACTION TYPES added.")
"RTN","IBP618A",62,0)
Q
"RTN","IBP618A",63,0)
;
"RTN","IBP618A",64,0)
ACTDAT ; Data for the new ACTION TYPE fields. (All categories will be updated)
"RTN","IBP618A",65,0)
;;CHOICE (INPT) CANCEL;CAN CCCI;CHOICE INPT;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",66,0)
;;CHOICE (INPT) NEW;NEW CCCI;CHOICE INPT;BUSINESS OFFICE;1;CHOICE INPATIENT;1;1;;;;
"RTN","IBP618A",67,0)
;;CHOICE (INPT) UPDATE;UPD CCCI;CHOICE INPT;BUSINESS OFFICE;3;;1;1;;;;
"RTN","IBP618A",68,0)
;;CHOICE (PER DIEM) CANCEL;CAN CCCP;CHOICE INPT;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",69,0)
;;CHOICE (PER DIEM) NEW;NEW CCCP;CHOICE INPT;BUSINESS OFFICE;1;CHOICE PER DIEM;1;3;;IBSL1;;
"RTN","IBP618A",70,0)
;;CHOICE (PER DIEM) UPDATE;UPD CCCP;CHOICE INPT;BUSINESS OFFICE;3;;1;3;;;;
"RTN","IBP618A",71,0)
;;CHOICE (OPT) CANCEL;CAN CCCO;CHOICE OPT;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",72,0)
;;CHOICE (OPT) NEW;NEW CCCO;CHOICE OPT;BUSINESS OFFICE;1;CHOICE OUTPATIENT;1;4;;IBSL2;;
"RTN","IBP618A",73,0)
;;CHOICE (OPT) UPDATE;UPD CCCO;CHOICE OPT;BUSINESS OFFICE;3;;1;4;;;;
"RTN","IBP618A",74,0)
;;CHOICE (RX) CANCEL;CAN CCCR;CHOICE RX CO-PAYMENT;PHARMACY;2;;;;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;
"RTN","IBP618A",75,0)
;;CHOICE (RX) NEW;NEW CCCR;CHOICE RX CO-PAYMENT;PHARMACY;1;CHOICE RX;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;IBEL
"RTN","IBP618A",76,0)
;;CHOICE (RX) UPDATE;UPD CCCR;CHOICE RX CO-PAYMENT;PHARMACY;3;;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;
"RTN","IBP618A",77,0)
;;CC (INPT) CANCEL;CAN CCIP;CC INPT;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",78,0)
;;CC (INPT) NEW;NEW CCIP;CC INPT;BUSINESS OFFICE;1;CC INPATIENT;1;1;;;;
"RTN","IBP618A",79,0)
;;CC (INPT) UPDATE;UPD CCIP;CC INPT;BUSINESS OFFICE;3;;1;1;;;;
"RTN","IBP618A",80,0)
;;CC (PER DIEM) CANCEL;CAN CCPD;CC INPT;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",81,0)
;;CC (PER DIEM) NEW;NEW CCPD;CC INPT;BUSINESS OFFICE;1;CC PER DIEM;1;3;;IBSL1;;
"RTN","IBP618A",82,0)
;;CC (PER DIEM) UPDATE;UPD CCPD;CC INPT;BUSINESS OFFICE;3;;1;3;;;;
"RTN","IBP618A",83,0)
;;CC (OPT) CANCEL;CAN CCO;CC OPT;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",84,0)
;;CC (OPT) NEW;NEW CCO;CC OPT;BUSINESS OFFICE;1;CC OUTPATIENT;1;4;;IBSL2;;
"RTN","IBP618A",85,0)
;;CC (OPT) UPDATE;UPD CCO;CC OPT;BUSINESS OFFICE;3;;1;4;;;;
"RTN","IBP618A",86,0)
;;CC (RX) CANCEL;CAN CCRX;CC RX CO-PAYMENT;PHARMACY;2;;;;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;
"RTN","IBP618A",87,0)
;;CC (RX) NEW;NEW CCRX;CC RX CO-PAYMENT;PHARMACY;1;CC RX COPAY;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;IBEL
"RTN","IBP618A",88,0)
;;CC (RX) UPDATE;UPD CCRX;CC RX CO-PAYMENT;PHARMACY;3;;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;
"RTN","IBP618A",89,0)
;;CCN (INPT) CANCEL;CAN CCNI;CCN INPT;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",90,0)
;;CCN (INPT) NEW;NEW CCNI;CCN INPT;BUSINESS OFFICE;1;CCN INPATIENT;1;1;;;;
"RTN","IBP618A",91,0)
;;CCN (INPT) UPDATE;UPD CCNI;CCN INPT;BUSINESS OFFICE;3;;1;1;;;;
"RTN","IBP618A",92,0)
;;CCN (PER DIEM) CANCEL;CAN CCNP;CCN INPT;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",93,0)
;;CCN (PER DIEM) NEW;NEW CCNP;CCN INPT;BUSINESS OFFICE;1;CCN PER DIEM;1;3;;IBSL1;;
"RTN","IBP618A",94,0)
;;CCN (PER DIEM) UPDATE;UPD CCNP;CCN INPT;BUSINESS OFFICE;3;;1;3;;;;
"RTN","IBP618A",95,0)
;;CCN (OPT) CANCEL;CAN CCNO;CCN OPT;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",96,0)
;;CCN (OPT) NEW;NEW CCNO;CCN OPT;BUSINESS OFFICE;1;CCN OUTPATIENT;1;4;;IBSL2;;
"RTN","IBP618A",97,0)
;;CCN (OPT) UPDATE;UPD CCNO;CCN OPT;BUSINESS OFFICE;3;;1;4;;;;
"RTN","IBP618A",98,0)
;;CCN (RX) CANCEL;CAN CCNR;CCN RX CO-PAYMENT;PHARMACY;2;;;;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;
"RTN","IBP618A",99,0)
;;CCN (RX) NEW;NEW CCNR;CCN RX CO-PAYMENT;PHARMACY;1;CCN RX COPAY;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;IBEL
"RTN","IBP618A",100,0)
;;CCN (RX) UPDATE;UPD CCNR;CCN RX CO-PAYMENT;PHARMACY;3;;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;
"RTN","IBP618A",101,0)
;;CC MTF (INPT) CANCEL;CAN CCDI;CC MTF INPT;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",102,0)
;;CC MTF (INPT) NEW;NEW CCDI;CC MTF INPT;BUSINESS OFFICE;1;CC MTF INPATIENT;1;1;;;;
"RTN","IBP618A",103,0)
;;CC MTF (INPT) UPDATE;UPD CCDI;CC MTF INPT;BUSINESS OFFICE;3;;1;1;;;;
"RTN","IBP618A",104,0)
;;CC MTF (PER DIEM) CANCEL;CAN CCDP;CC MTF INPT;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",105,0)
;;CC MTF (PER DIEM) NEW;NEW CCDP;CC MTF INPT;BUSINESS OFFICE;1;CC MTF PER DIEM;1;3;;IBSL1;;
"RTN","IBP618A",106,0)
;;CC MTF (PER DIEM) UPDATE;UPD CCDP;CC MTF INPT;BUSINESS OFFICE;3;;1;3;;;;
"RTN","IBP618A",107,0)
;;CC MTF (OPT) CANCEL;CAN CCDO;CC MTF OPT;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",108,0)
;;CC MTF (OPT) NEW;NEW CCDO;CC MTF OPT;BUSINESS OFFICE;1;CC MTF OUTPATIENT;1;4;;IBSL2;;
"RTN","IBP618A",109,0)
;;CC MTF (OPT) UPDATE;UPD CCDO;CC MTF OPT;BUSINESS OFFICE;3;;1;4;;;;
"RTN","IBP618A",110,0)
;;CC MTF (RX) CANCEL;CAN CCDR;CC MTF RX CO-PAYMENT;PHARMACY;2;;;;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;
"RTN","IBP618A",111,0)
;;CC MTF (RX) NEW;NEW CCDR;CC MTF RX CO-PAYMENT;PHARMACY;1;CC MTF RX COPAY;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;IBEL
"RTN","IBP618A",112,0)
;;CC MTF (RX) UPDATE;UPD CCDR;CC MTF RX CO-PAYMENT;PHARMACY;3;;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;
"RTN","IBP618A",113,0)
;;LTC CC INPT CNH CANCEL;C CCCNH;CC NURSING HOME CARE - LTC;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",114,0)
;;LTC CC INPT CNH NEW;N CCCNH;CC NURSING HOME CARE - LTC;BUSINESS OFFICE;1;CC LTC INPT CNH;1;9;;;;
"RTN","IBP618A",115,0)
;;LTC CC INPT CNH UPDATE;U CCCNH;CC NURSING HOME CARE - LTC;BUSINESS OFFICE;3;;1;9;;;;
"RTN","IBP618A",116,0)
;;LTC CC INPT RESPITE CANCEL;C CCIRES;CC RESPITE CARE;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",117,0)
;;LTC CC INPT RESPITE NEW;N CCIRES;CC RESPITE CARE;BUSINESS OFFICE;1;CC LTC INPT RESPITE;1;9;;;;
"RTN","IBP618A",118,0)
;;LTC CC INPT RESPITE UPDATE;U CCIRES;CC RESPITE CARE;BUSINESS OFFICE;3;;1;9;;;;
"RTN","IBP618A",119,0)
;;LTC CC OPT ADHC CANCEL;C CCADHC;CC NURSING HOME CARE - LTC;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",120,0)
;;LTC CC OPT ADHC NEW;N CCADHC;CC NURSING HOME CARE - LTC;BUSINESS OFFICE;1;CC LTC OPT ADHC;1;8;;;;
"RTN","IBP618A",121,0)
;;LTC CC OPT ADHC UPDATE;U CCADHC;CC NURSING HOME CARE - LTC;BUSINESS OFFICE;3;;1;8;;;;
"RTN","IBP618A",122,0)
;;LTC CC OPT RESPITE CANCEL;C CCORES;CC RESPITE CARE;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",123,0)
;;LTC CC OPT RESPITE NEW;N CCORES;CC RESPITE CARE;BUSINESS OFFICE;1;CC LTC OPT RESPITE;1;8;;;;
"RTN","IBP618A",124,0)
;;LTC CC OPT RESPITE UPDATE;U CCORES;CC RESPITE CARE;BUSINESS OFFICE;3;;1;8;;;;
"RTN","IBP618A",125,0)
;;LTC CCN INPT CNH CANCEL;C CCNCNH;CCN NURSING HOME CARE - LTC;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",126,0)
;;LTC CCN INPT CNH NEW;N CCNCNH;CCN NURSING HOME CARE - LTC;BUSINESS OFFICE;1;CCN LTC INPT CNH;1;9;;;;
"RTN","IBP618A",127,0)
;;LTC CCN INPT CNH UPDATE;U CCNCNH;CCN NURSING HOME CARE - LTC;BUSINESS OFFICE;3;;1;9;;;;
"RTN","IBP618A",128,0)
;;LTC CCN INPT RESPITE CANCEL;C CCNIRS;CCN RESPITE CARE;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",129,0)
;;LTC CCN INPT RESPITE NEW;N CCNIRS;CCN RESPITE CARE;BUSINESS OFFICE;1;CCN LTC INPT RESPITE;1;9;;;;
"RTN","IBP618A",130,0)
;;LTC CCN INPT RESPITE UPDATE;U CCNIRS;CCN RESPITE CARE;BUSINESS OFFICE;3;;1;9;;;;
"RTN","IBP618A",131,0)
;;LTC CCN OPT ADHC CANCEL;C CCNOAD;CCN NURSING HOME CARE - LTC;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",132,0)
;;LTC CCN OPT ADHC NEW;N CCNOAD;CCN NURSING HOME CARE - LTC;BUSINESS OFFICE;1;CCN LTC OPT ADHC;1;8;;;;
"RTN","IBP618A",133,0)
;;LTC CCN OPT ADHC UPDATE;U CCNOAD;CCN NURSING HOME CARE - LTC;BUSINESS OFFICE;3;;1;8;;;;
"RTN","IBP618A",134,0)
;;LTC CCN OPT RESPITE CANCEL;C CCNORS;CCN RESPITE CARE;BUSINESS OFFICE;2;;;;;;;;
"RTN","IBP618A",135,0)
;;LTC CCN OPT RESPITE NEW;N CCNORS;CCN RESPITE CARE;BUSINESS OFFICE;1;CCN LTC OPT RESPITE;1;8;;;;
"RTN","IBP618A",136,0)
;;LTC CCN OPT RESPITE UPDATE;U CCNORS;CCN RESPITE CARE;BUSINESS OFFICE;3;;1;8;;;;
"RTN","IBP618A",137,0)
;;LTC CHOICE INPT CNH CANCEL;C CCCCNH;CHOICE NURSING HOME CARE - LTC;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",138,0)
;;LTC CHOICE INPT CNH NEW;N CCCCNH;CHOICE NURSING HOME CARE - LTC;BUSINESS OFFICE;1;CHOICE LTC INPT CNH;1;9;;;;
"RTN","IBP618A",139,0)
;;LTC CHOICE INPT CNH UPDATE;U CCCCNH;CHOICE NURSING HOME CARE - LTC;BUSINESS OFFICE;3;;1;9;;;;
"RTN","IBP618A",140,0)
;;LTC CHOICE INPT RESPITE CANCEL;C CCCIRS;CHOICE RESPITE CARE;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",141,0)
;;LTC CHOICE INPT RESPITE NEW;N CCCIRS;CHOICE RESPITE CARE;BUSINESS OFFICE;1;CHOICE LTC INP RESPITE;1;9;;;;
"RTN","IBP618A",142,0)
;;LTC CHOICE INPT RESPITE UPDATE;U CCCIRS;CHOICE RESPITE CARE;BUSINESS OFFICE;3;;1;9;;;;
"RTN","IBP618A",143,0)
;;LTC CHOICE OPT ADHC CANCEL;C CCCOAD;CHOICE NURSING HOME CARE - LTC;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",144,0)
;;LTC CHOICE OPT ADHC NEW;N CCCOAD;CHOICE NURSING HOME CARE - LTC;BUSINESS OFFICE;1;CHOICE LTC OPT ADHC;1;8;;;;
"RTN","IBP618A",145,0)
;;LTC CHOICE OPT ADHC UPDATE;U CCCOAD;CHOICE NURSING HOME CARE - LTC;BUSINESS OFFICE;3;;1;8;;;;
"RTN","IBP618A",146,0)
;;LTC CHOICE OPT RESPITE CANCEL;C CCCORS;CHOICE RESPITE CARE;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",147,0)
;;LTC CHOICE OPT RESPITE NEW;N CCCORS;CHOICE RESPITE CARE;BUSINESS OFFICE;1;CHOICE LTC OPT RESPITE;1;8;;;;
"RTN","IBP618A",148,0)
;;LTC CHOICE OPT RESPITE UPDATE;U CCCORS;CHOICE RESPITE CARE;BUSINESS OFFICE;3;;1;8;;;;
"RTN","IBP618A",149,0)
;;END
"RTN","IBP618A",150,0)
IBUPD ; Inactivate FEE Service Entries
"RTN","IBP618A",151,0)
;
"RTN","IBP618A",152,0)
N LOOP,LIEN,IBDATA
"RTN","IBP618A",153,0)
N X,Y,DIE,DA,DR,DTOUT,DATA
"RTN","IBP618A",154,0)
;
"RTN","IBP618A",155,0)
; Grab all of the entries to update
"RTN","IBP618A",156,0)
F LOOP=1:1:24 D
"RTN","IBP618A",157,0)
. ;Extract the new ACTION TYPE to be added.
"RTN","IBP618A",158,0)
. S IBDATA=$T(IBDDAT+LOOP)
"RTN","IBP618A",159,0)
. S IBDATA=$P(IBDATA,";;",2)
"RTN","IBP618A",160,0)
. ;Store in array for adding to the file (#350.1).
"RTN","IBP618A",161,0)
. Q:IBDATA="" ;go to next entry if Category is not to be updated.
"RTN","IBP618A",162,0)
. S LIEN=$O(^IBE(350.1,"B",IBDATA,"")) ; find ACTION TYPE entry
"RTN","IBP618A",163,0)
. Q:LIEN=""
"RTN","IBP618A",164,0)
. ;
"RTN","IBP618A",165,0)
. ; File the update along with inactivate the ACTION TYPE
"RTN","IBP618A",166,0)
. S DR=".12////1;"
"RTN","IBP618A",167,0)
. S DIE="^IBE(350.1,",DA=LIEN
"RTN","IBP618A",168,0)
. D ^DIE
"RTN","IBP618A",169,0)
. K DR ;Clear update array before next use
"RTN","IBP618A",170,0)
;
"RTN","IBP618A",171,0)
S DR=""
"RTN","IBP618A",172,0)
D MES^XPDUTL(" -> Data added to the ACTION TYPE (350.1) INACTIVE field.")
"RTN","IBP618A",173,0)
Q
"RTN","IBP618A",174,0)
;
"RTN","IBP618A",175,0)
IBDDAT ; Fee Service to inactivate
"RTN","IBP618A",176,0)
;;DG FEE SERVICE (INPT) CANCEL
"RTN","IBP618A",177,0)
;;DG FEE SERVICE (INPT) NEW
"RTN","IBP618A",178,0)
;;DG FEE SERVICE (INPT) UPDATE
"RTN","IBP618A",179,0)
;;DG FEE SERVICE (OPT) CANCEL
"RTN","IBP618A",180,0)
;;DG FEE SERVICE (OPT) NEW
"RTN","IBP618A",181,0)
;;DG FEE SERVICE (OPT) UPDATE
"RTN","IBP618A",182,0)
;;DG LTC FEE INPT CNH CANCEL
"RTN","IBP618A",183,0)
;;DG LTC FEE INPT CNH NEW
"RTN","IBP618A",184,0)
;;DG LTC FEE INPT CNH UPDATE
"RTN","IBP618A",185,0)
;;DG LTC FEE INPT RESPITE CANCEL
"RTN","IBP618A",186,0)
;;DG LTC FEE INPT RESPITE NEW
"RTN","IBP618A",187,0)
;;DG LTC FEE INPT RESPITE UPDATE
"RTN","IBP618A",188,0)
;;DG LTC FEE OPT ADHC CANCEL
"RTN","IBP618A",189,0)
;;DG LTC FEE OPT ADHC NEW
"RTN","IBP618A",190,0)
;;DG LTC FEE OPT ADHC UPDATE
"RTN","IBP618A",191,0)
;;DG LTC FEE OPT RESPITE CANCEL
"RTN","IBP618A",192,0)
;;DG LTC FEE OPT RESPITE NEW
"RTN","IBP618A",193,0)
;;DG LTC FEE OPT RESPITE UPDATE
"RTN","IBP618A",194,0)
;;FEE SERV INPT PER DIEM CANCEL
"RTN","IBP618A",195,0)
;;FEE SERV INPT PER DIEM NEW
"RTN","IBP618A",196,0)
;;FEE SERV INPT PER DIEM UPDATE
"RTN","IBP618A",197,0)
;;FEE SERV NSC RX COPAY CANCEL
"RTN","IBP618A",198,0)
;;FEE SERV NSC RX COPAY NEW
"RTN","IBP618A",199,0)
;;FEE SERV NSC RX COPAY UPDATE
"RTN","IBP618A",200,0)
;;END
"RTN","IBP618B")
0^1^B119788887
"RTN","IBP618B",1,0)
IBP618B ;SAB/Albany - IB*2.0*618 POST INSTALL (CONT'D);12/11/17 2:10pm
"RTN","IBP618B",2,0)
;;2.0;Integrated Billing;**618**;Mar 20, 1995;Build 60
"RTN","IBP618B",3,0)
;Per VA Directive 6402, this routine should not be modified.
"RTN","IBP618B",4,0)
Q
"RTN","IBP618B",5,0)
;
"RTN","IBP618B",6,0)
UPDACT ; Update the Action Type Fields for the new Action Types
"RTN","IBP618B",7,0)
;
"RTN","IBP618B",8,0)
N IBDATA,IBLOOP,IBIEN,IBACTNM
"RTN","IBP618B",9,0)
N X,Y,DIE,DA,DR,DTOUT,DATA ;^DIE variables
"RTN","IBP618B",10,0)
D MES^XPDUTL(" -> Updating the Action Type Fields in file 350.1 ...")
"RTN","IBP618B",11,0)
F IBLOOP=2:1 S IBDATA=$T(UPDDAT+IBLOOP) Q:IBDATA=" ;;END" D
"RTN","IBP618B",12,0)
. S IBACTNM=$P(IBDATA,";",3) ;Name of the Action Type
"RTN","IBP618B",13,0)
. ;Retrieve the IEN.
"RTN","IBP618B",14,0)
. S IBIEN=$O(^IBE(350.1,"B",IBACTNM,""))
"RTN","IBP618B",15,0)
. I IBIEN="" D MES^XPDUTL(" -> Action Type "_IBACTNM_" Is not in the Action Type file.") Q
"RTN","IBP618B",16,0)
. ;File the update
"RTN","IBP618B",17,0)
. S DR=".06///"_$P(IBDATA,";",4)_";"
"RTN","IBP618B",18,0)
. S DR=DR_".07///"_$P(IBDATA,";",5)_";"
"RTN","IBP618B",19,0)
. S DR=DR_".09///"_$P(IBDATA,";",6)
"RTN","IBP618B",20,0)
. Q:DR=""
"RTN","IBP618B",21,0)
. S DIE="^IBE(350.1,",DA=IBIEN
"RTN","IBP618B",22,0)
. D ^DIE
"RTN","IBP618B",23,0)
. K DR ;Clear update array before next use
"RTN","IBP618B",24,0)
D MES^XPDUTL(" -> Update completed ...")
"RTN","IBP618B",25,0)
;Clear the array
"RTN","IBP618B",26,0)
Q
"RTN","IBP618B",27,0)
;
"RTN","IBP618B",28,0)
UPDDAT ;
"RTN","IBP618B",29,0)
;;Action Type;Cancellation Action;Update Action;New Action
"RTN","IBP618B",30,0)
;;CHOICE (INPT) CANCEL;CHOICE (INPT) CANCEL;CHOICE (INPT) UPDATE;CHOICE (INPT) NEW
"RTN","IBP618B",31,0)
;;CHOICE (INPT) NEW;CHOICE (INPT) CANCEL;CHOICE (INPT) UPDATE;CHOICE (INPT) NEW
"RTN","IBP618B",32,0)
;;CHOICE (INPT) UPDATE;CHOICE (INPT) CANCEL;CHOICE (INPT) UPDATE;CHOICE (INPT) NEW
"RTN","IBP618B",33,0)
;;CHOICE (PER DIEM) CANCEL;CHOICE (PER DIEM) CANCEL;CHOICE (PER DIEM) UPDATE;CHOICE (PER DIEM) NEW
"RTN","IBP618B",34,0)
;;CHOICE (PER DIEM) NEW;CHOICE (PER DIEM) CANCEL;CHOICE (PER DIEM) UPDATE;CHOICE (PER DIEM) NEW
"RTN","IBP618B",35,0)
;;CHOICE (PER DIEM) UPDATE;CHOICE (PER DIEM) CANCEL;CHOICE (PER DIEM) UPDATE;CHOICE (PER DIEM) NEW
"RTN","IBP618B",36,0)
;;CHOICE (OPT) CANCEL;CHOICE (OPT) CANCEL;CHOICE (OPT) UPDATE;CHOICE (OPT) NEW
"RTN","IBP618B",37,0)
;;CHOICE (OPT) NEW;CHOICE (OPT) CANCEL;CHOICE (OPT) UPDATE;CHOICE (OPT) NEW
"RTN","IBP618B",38,0)
;;CHOICE (OPT) UPDATE;CHOICE (OPT) CANCEL;CHOICE (OPT) UPDATE;CHOICE (OPT) NEW
"RTN","IBP618B",39,0)
;;CHOICE (RX) CANCEL;CHOICE (RX) CANCEL;CHOICE (RX) UPDATE;CHOICE (RX) NEW
"RTN","IBP618B",40,0)
;;CHOICE (RX) NEW;CHOICE (RX) CANCEL;CHOICE (RX) UPDATE;CHOICE (RX) NEW
"RTN","IBP618B",41,0)
;;CHOICE (RX) UPDATE;CHOICE (RX) CANCEL;CHOICE (RX) UPDATE;CHOICE (RX) NEW
"RTN","IBP618B",42,0)
;;CC (INPT) CANCEL;CC (INPT) CANCEL;CC (INPT) UPDATE;CC (INPT) NEW
"RTN","IBP618B",43,0)
;;CC (INPT) NEW;CC (INPT) CANCEL;CC (INPT) UPDATE;CC (INPT) NEW
"RTN","IBP618B",44,0)
;;CC (INPT) UPDATE;CC (INPT) CANCEL;CC (INPT) UPDATE;CC (INPT) NEW
"RTN","IBP618B",45,0)
;;CC (PER DIEM) CANCEL;CC (PER DIEM) CANCEL;CC (PER DIEM) UPDATE;CC (PER DIEM) NEW
"RTN","IBP618B",46,0)
;;CC (PER DIEM) NEW;CC (PER DIEM) CANCEL;CC (PER DIEM) UPDATE;CC (PER DIEM) NEW
"RTN","IBP618B",47,0)
;;CC (PER DIEM) UPDATE;CC (PER DIEM) CANCEL;CC (PER DIEM) UPDATE;CC (PER DIEM) NEW
"RTN","IBP618B",48,0)
;;CC (OPT) CANCEL;CC (OPT) CANCEL;CC (OPT) UPDATE;CC (OPT) NEW
"RTN","IBP618B",49,0)
;;CC (OPT) NEW;CC (OPT) CANCEL;CC (OPT) UPDATE;CC (OPT) NEW
"RTN","IBP618B",50,0)
;;CC (OPT) UPDATE;CC (OPT) CANCEL;CC (OPT) UPDATE;CC (OPT) NEW
"RTN","IBP618B",51,0)
;;CC (RX) CANCEL;CC (RX) CANCEL;CC (RX) UPDATE;CC (RX) NEW
"RTN","IBP618B",52,0)
;;CC (RX) NEW;CC (RX) CANCEL;CC (RX) UPDATE;CC (RX) NEW
"RTN","IBP618B",53,0)
;;CC (RX) UPDATE;CC (RX) CANCEL;CC (RX) UPDATE;CC (RX) NEW
"RTN","IBP618B",54,0)
;;CCN (INPT) CANCEL;CCN (INPT) CANCEL;CCN (INPT) UPDATE;CCN (INPT) NEW
"RTN","IBP618B",55,0)
;;CCN (INPT) NEW;CCN (INPT) CANCEL;CCN (INPT) UPDATE;CCN (INPT) NEW
"RTN","IBP618B",56,0)
;;CCN (INPT) UPDATE;CCN (INPT) CANCEL;CCN (INPT) UPDATE;CCN (INPT) NEW
"RTN","IBP618B",57,0)
;;CCN (PER DIEM) CANCEL;CCN (PER DIEM) CANCEL;CCN (PER DIEM) UPDATE;CCN (PER DIEM) NEW
"RTN","IBP618B",58,0)
;;CCN (PER DIEM) NEW;CCN (PER DIEM) CANCEL;CCN (PER DIEM) UPDATE;CCN (PER DIEM) NEW
"RTN","IBP618B",59,0)
;;CCN (PER DIEM) UPDATE;CCN (PER DIEM) CANCEL;CCN (PER DIEM) UPDATE;CCN (PER DIEM) NEW
"RTN","IBP618B",60,0)
;;CCN (OPT) CANCEL;CCN (OPT) CANCEL;CCN (OPT) UPDATE;CCN (OPT) NEW
"RTN","IBP618B",61,0)
;;CCN (OPT) NEW;CCN (OPT) CANCEL;CCN (OPT) UPDATE;CCN (OPT) NEW
"RTN","IBP618B",62,0)
;;CCN (OPT) UPDATE;CCN (OPT) CANCEL;CCN (OPT) UPDATE;CCN (OPT) NEW
"RTN","IBP618B",63,0)
;;CCN (RX) CANCEL;CCN (RX) CANCEL;CCN (RX) UPDATE;CCN (RX) NEW
"RTN","IBP618B",64,0)
;;CCN (RX) NEW;CCN (RX) CANCEL;CCN (RX) UPDATE;CCN (RX) NEW
"RTN","IBP618B",65,0)
;;CCN (RX) UPDATE;CCN (RX) CANCEL;CCN (RX) UPDATE;CCN (RX) NEW
"RTN","IBP618B",66,0)
;;CC MTF (INPT) CANCEL;CC MTF (INPT) CANCEL;CC MTF (INPT) UPDATE;CC MTF (INPT) NEW
"RTN","IBP618B",67,0)
;;CC MTF (INPT) NEW;CC MTF (INPT) CANCEL;CC MTF (INPT) UPDATE;CC MTF (INPT) NEW
"RTN","IBP618B",68,0)
;;CC MTF (INPT) UPDATE;CC MTF (INPT) CANCEL;CC MTF (INPT) UPDATE;CC MTF (INPT) NEW
"RTN","IBP618B",69,0)
;;CC MTF (PER DIEM) CANCEL;CC MTF (PER DIEM) CANCEL;CC MTF (PER DIEM) UPDATE;CC MTF (PER DIEM) NEW
"RTN","IBP618B",70,0)
;;CC MTF (PER DIEM) NEW;CC MTF (PER DIEM) CANCEL;CC MTF (PER DIEM) UPDATE;CC MTF (PER DIEM) NEW
"RTN","IBP618B",71,0)
;;CC MTF (PER DIEM) UPDATE;CC MTF (PER DIEM) CANCEL;CC MTF (PER DIEM) UPDATE;CC MTF (PER DIEM) NEW
"RTN","IBP618B",72,0)
;;CC MTF (OPT) CANCEL;CC MTF (OPT) CANCEL;CC MTF (OPT) UPDATE;CC MTF (OPT) NEW
"RTN","IBP618B",73,0)
;;CC MTF (OPT) NEW;CC MTF (OPT) CANCEL;CC MTF (OPT) UPDATE;CC MTF (OPT) NEW
"RTN","IBP618B",74,0)
;;CC MTF (OPT) UPDATE;CC MTF (OPT) CANCEL;CC MTF (OPT) UPDATE;CC MTF (OPT) NEW
"RTN","IBP618B",75,0)
;;CC MTF (RX) CANCEL;CC MTF (RX) CANCEL;CC MTF (RX) UPDATE;CC MTF (RX) NEW
"RTN","IBP618B",76,0)
;;CC MTF (RX) NEW;CC MTF (RX) CANCEL;CC MTF (RX) UPDATE;CC MTF (RX) NEW
"RTN","IBP618B",77,0)
;;CC MTF (RX) UPDATE;CC MTF (RX) CANCEL;CC MTF (RX) UPDATE;CC MTF (RX) NEW
"RTN","IBP618B",78,0)
;;LTC CC INPT CNH CANCEL;LTC CC INPT CNH CANCEL;LTC CC INPT CNH UPDATE;LTC CC INPT CNH NEW
"RTN","IBP618B",79,0)
;;LTC CC INPT CNH NEW;LTC CC INPT CNH CANCEL;LTC CC INPT CNH UPDATE;LTC CC INPT CNH NEW
"RTN","IBP618B",80,0)
;;LTC CC INPT CNH UPDATE;LTC CC INPT CNH CANCEL;LTC CC INPT CNH UPDATE;LTC CC INPT CNH NEW
"RTN","IBP618B",81,0)
;;LTC CC INPT RESPITE CANCEL;LTC CC INPT RESPITE CANCEL;LTC CC INPT RESPITE UPDATE;LTC CC INPT RESPITE NEW
"RTN","IBP618B",82,0)
;;LTC CC INPT RESPITE NEW;LTC CC INPT RESPITE CANCEL;LTC CC INPT RESPITE UPDATE;LTC CC INPT RESPITE NEW
"RTN","IBP618B",83,0)
;;LTC CC INPT RESPITE UPDATE;LTC CC INPT RESPITE CANCEL;LTC CC INPT RESPITE UPDATE;LTC CC INPT RESPITE NEW
"RTN","IBP618B",84,0)
;;LTC CC OPT ADHC CANCEL;LTC CC OPT ADHC CANCEL;LTC CC OPT ADHC UPDATE;LTC CC OPT ADHC NEW
"RTN","IBP618B",85,0)
;;LTC CC OPT ADHC NEW;LTC CC OPT ADHC CANCEL;LTC CC OPT ADHC UPDATE;LTC CC OPT ADHC NEW
"RTN","IBP618B",86,0)
;;LTC CC OPT ADHC UPDATE;LTC CC OPT ADHC CANCEL;LTC CC OPT ADHC UPDATE;LTC CC OPT ADHC NEW
"RTN","IBP618B",87,0)
;;LTC CC OPT RESPITE CANCEL;LTC CC OPT RESPITE CANCEL;LTC CC OPT RESPITE UPDATE;LTC CC OPT RESPITE NEW
"RTN","IBP618B",88,0)
;;LTC CC OPT RESPITE NEW;LTC CC OPT RESPITE CANCEL;LTC CC OPT RESPITE UPDATE;LTC CC OPT RESPITE NEW
"RTN","IBP618B",89,0)
;;LTC CC OPT RESPITE UPDATE;LTC CC OPT RESPITE CANCEL;LTC CC OPT RESPITE UPDATE;LTC CC OPT RESPITE NEW
"RTN","IBP618B",90,0)
;;LTC CCN INPT CNH CANCEL;LTC CCN INPT CNH CANCEL;LTC CCN INPT CNH UPDATE;LTC CCN INPT CNH NEW
"RTN","IBP618B",91,0)
;;LTC CCN INPT CNH NEW;LTC CCN INPT CNH CANCEL;LTC CCN INPT CNH UPDATE;LTC CCN INPT CNH NEW
"RTN","IBP618B",92,0)
;;LTC CCN INPT CNH UPDATE;LTC CCN INPT CNH CANCEL;LTC CCN INPT CNH UPDATE;LTC CCN INPT CNH NEW
"RTN","IBP618B",93,0)
;;LTC CCN INPT RESPITE CANCEL;LTC CCN INPT RESPITE CANCEL;LTC CCN INPT RESPITE UPDATE;LTC CCN INPT RESPITE NEW
"RTN","IBP618B",94,0)
;;LTC CCN INPT RESPITE NEW;LTC CCN INPT RESPITE CANCEL;LTC CCN INPT RESPITE UPDATE;LTC CCN INPT RESPITE NEW
"RTN","IBP618B",95,0)
;;LTC CCN INPT RESPITE UPDATE;LTC CCN INPT RESPITE CANCEL;LTC CCN INPT RESPITE UPDATE;LTC CCN INPT RESPITE NEW
"RTN","IBP618B",96,0)
;;LTC CCN OPT ADHC CANCEL;LTC CCN OPT ADHC CANCEL;LTC CCN OPT ADHC UPDATE;LTC CCN OPT ADHC NEW
"RTN","IBP618B",97,0)
;;LTC CCN OPT ADHC NEW;LTC CCN OPT ADHC CANCEL;LTC CCN OPT ADHC UPDATE;LTC CCN OPT ADHC NEW
"RTN","IBP618B",98,0)
;;LTC CCN OPT ADHC UPDATE;LTC CCN OPT ADHC CANCEL;LTC CCN OPT ADHC UPDATE;LTC CCN OPT ADHC NEW
"RTN","IBP618B",99,0)
;;LTC CCN OPT RESPITE CANCEL;LTC CCN OPT RESPITE CANCEL;LTC CCN OPT RESPITE UPDATE;LTC CCN OPT RESPITE NEW
"RTN","IBP618B",100,0)
;;LTC CCN OPT RESPITE NEW;LTC CCN OPT RESPITE CANCEL;LTC CCN OPT RESPITE UPDATE;LTC CCN OPT RESPITE NEW
"RTN","IBP618B",101,0)
;;LTC CCN OPT RESPITE UPDATE;LTC CCN OPT RESPITE CANCEL;LTC CCN OPT RESPITE UPDATE;LTC CCN OPT RESPITE NEW
"RTN","IBP618B",102,0)
;;LTC CHOICE INPT CNH CANCEL;LTC CHOICE INPT CNH CANCEL;LTC CHOICE INPT CNH UPDATE;LTC CHOICE INPT CNH NEW
"RTN","IBP618B",103,0)
;;LTC CHOICE INPT CNH NEW;LTC CHOICE INPT CNH CANCEL;LTC CHOICE INPT CNH UPDATE;LTC CHOICE INPT CNH NEW
"RTN","IBP618B",104,0)
;;LTC CHOICE INPT CNH UPDATE;LTC CHOICE INPT CNH CANCEL;LTC CHOICE INPT CNH UPDATE;LTC CHOICE INPT CNH NEW
"RTN","IBP618B",105,0)
;;LTC CHOICE INPT RESPITE CANCEL;LTC CHOICE INPT RESPITE CANCEL;LTC CHOICE INPT RESPITE UPDATE;LTC CHOICE INPT RESPITE NEW
"RTN","IBP618B",106,0)
;;LTC CHOICE INPT RESPITE NEW;LTC CHOICE INPT RESPITE CANCEL;LTC CHOICE INPT RESPITE UPDATE;LTC CHOICE INPT RESPITE NEW
"RTN","IBP618B",107,0)
;;LTC CHOICE INPT RESPITE UPDATE;LTC CHOICE INPT RESPITE CANCEL;LTC CHOICE INPT RESPITE UPDATE;LTC CHOICE INPT RESPITE NEW
"RTN","IBP618B",108,0)
;;LTC CHOICE OPT ADHC CANCEL;LTC CHOICE OPT ADHC CANCEL;LTC CHOICE OPT ADHC UPDATE;LTC CHOICE OPT ADHC NEW
"RTN","IBP618B",109,0)
;;LTC CHOICE OPT ADHC NEW;LTC CHOICE OPT ADHC CANCEL;LTC CHOICE OPT ADHC UPDATE;LTC CHOICE OPT ADHC NEW
"RTN","IBP618B",110,0)
;;LTC CHOICE OPT ADHC UPDATE;LTC CHOICE OPT ADHC CANCEL;LTC CHOICE OPT ADHC UPDATE;LTC CHOICE OPT ADHC NEW
"RTN","IBP618B",111,0)
;;LTC CHOICE OPT RESPITE CANCEL;LTC CHOICE OPT RESPITE CANCEL;LTC CHOICE OPT RESPITE UPDATE;LTC CHOICE OPT RESPITE NEW
"RTN","IBP618B",112,0)
;;LTC CHOICE OPT RESPITE NEW;LTC CHOICE OPT RESPITE CANCEL;LTC CHOICE OPT RESPITE UPDATE;LTC CHOICE OPT RESPITE NEW
"RTN","IBP618B",113,0)
;;LTC CHOICE OPT RESPITE UPDATE;LTC CHOICE OPT RESPITE CANCEL;LTC CHOICE OPT RESPITE UPDATE;LTC CHOICE OPT RESPITE NEW
"RTN","IBP618B",114,0)
;;END
"RTN","IBP618B",115,0)
;
"RTN","IBP618B",116,0)
ADDACTCH ; Update the Action Charges
"RTN","IBP618B",117,0)
;
"RTN","IBP618B",118,0)
N IBLOOP,IBARRAY,IBACTYP,IBACTCH,IBATIEN,IBACIEN,IBEFDT,IBACTIEN,IBARYIEN,IBDATA,IBTIER,IBI,IBTRLK,IBEDT
"RTN","IBP618B",119,0)
N X,Y,DIE,DA,DR,DTOUT,FDA,FDAIEN
"RTN","IBP618B",120,0)
;
"RTN","IBP618B",121,0)
; Define the Logic field information
"RTN","IBP618B",122,0)
; Set Logic
"RTN","IBP618B",123,0)
;
"RTN","IBP618B",124,0)
D MES^XPDUTL(" -> Adding new ACTION CHARGE entries to file 350.2 ...")
"RTN","IBP618B",125,0)
F IBLOOP=1:1:64 D
"RTN","IBP618B",126,0)
. S IBDATA=$T(ACTCHDAT+IBLOOP)
"RTN","IBP618B",127,0)
. ;Retrieve the mapping
"RTN","IBP618B",128,0)
. S IBACTYP=$P(IBDATA,";",3),IBACTCH=$P(IBDATA,";",4),IBTIER=$P(IBDATA,";",5)
"RTN","IBP618B",129,0)
. ;determine if new entry for Action type/Action Charge combination
"RTN","IBP618B",130,0)
. S IBATIEN=$O(^IBE(350.1,"B",IBACTYP,"")),IBACIEN=""
"RTN","IBP618B",131,0)
. S:IBTIER="" IBACIEN=$O(^IBE(350.2,"B",IBACTCH,""),-1) ;get the latest entry
"RTN","IBP618B",132,0)
. I IBTIER'="" D
"RTN","IBP618B",133,0)
. . ;Loading current copay schedule
"RTN","IBP618B",134,0)
. . I IBTIER'="O" D Q
"RTN","IBP618B",135,0)
. . . S IBI=""
"RTN","IBP618B",136,0)
. . . F S IBI=$O(^IBE(350.2,"B",IBACTCH,IBI)) Q:'IBI D Q:IBACIEN
"RTN","IBP618B",137,0)
. . . . S IBEDT=$$GET1^DIQ(350.2,IBI_",",.02,"I")
"RTN","IBP618B",138,0)
. . . . Q:IBEDT'=3170227
"RTN","IBP618B",139,0)
. . . . S IBTRLK=$$GET1^DIQ(350.2,IBI_",",.07,"E")
"RTN","IBP618B",140,0)
. . . . I IBTRLK=IBTIER S IBACIEN=IBI
"RTN","IBP618B",141,0)
. . ; Otherwise, loading old copay schedule.
"RTN","IBP618B",142,0)
. . S IBTIER=2,IBI=0
"RTN","IBP618B",143,0)
. . F S IBI=$O(^IBE(350.2,"B",IBACTCH,IBI)) Q:'IBI D Q:IBACIEN
"RTN","IBP618B",144,0)
. . . S IBEDT=$$GET1^DIQ(350.2,IBI_",",.02,"I")
"RTN","IBP618B",145,0)
. . . Q:IBEDT'=3140312
"RTN","IBP618B",146,0)
. . . S IBTRLK=$$GET1^DIQ(350.2,IBI_",",.07,"E")
"RTN","IBP618B",147,0)
. . . I IBTRLK=IBTIER S IBACIEN=IBI
"RTN","IBP618B",148,0)
. ;
"RTN","IBP618B",149,0)
. ; Add the new entry
"RTN","IBP618B",150,0)
. K FDA,IBARRAY ;Clear the arrays
"RTN","IBP618B",151,0)
. ;
"RTN","IBP618B",152,0)
. S IBARYIEN=IBACIEN_","
"RTN","IBP618B",153,0)
. ;Store in array for adding to the file (#350.1).
"RTN","IBP618B",154,0)
. D GETS^DIQ(350.2,IBARYIEN,"*","I","IBARRAY")
"RTN","IBP618B",155,0)
. S IBTIER=IBARRAY(350.2,IBARYIEN,.07,"I")
"RTN","IBP618B",156,0)
. S FDA(350.2,"+1,",.01)=IBARRAY(350.2,IBARYIEN,.01,"I") ;Key
"RTN","IBP618B",157,0)
. S FDA(350.2,"+1,",.02)=IBARRAY(350.2,IBARYIEN,.02,"I") ;Effective Date
"RTN","IBP618B",158,0)
. S FDA(350.2,"+1,",.03)=IBATIEN ;Action Type
"RTN","IBP618B",159,0)
. S FDA(350.2,"+1,",.04)=IBARRAY(350.2,IBARYIEN,.04,"I") ;Unit Charged Fixed
"RTN","IBP618B",160,0)
. S FDA(350.2,"+1,",.05)=IBARRAY(350.2,IBARYIEN,.05,"I") ;Inactivation Date
"RTN","IBP618B",161,0)
. S FDA(350.2,"+1,",.06)=IBARRAY(350.2,IBARYIEN,.06,"I") ;Additional Amount
"RTN","IBP618B",162,0)
. S FDA(350.2,"+1,",.07)=IBTIER ;CoPayment Tier
"RTN","IBP618B",163,0)
. S FDA(350.2,"+1,",10)=IBARRAY(350.2,IBARYIEN,10,"I") ;Unit Charge Logic
"RTN","IBP618B",164,0)
. S FDA(350.2,"+1,",20)=IBARRAY(350.2,IBARYIEN,20,"I") ;Additional Amount Logic
"RTN","IBP618B",165,0)
. ;Add to the IB file.
"RTN","IBP618B",166,0)
. D UPDATE^DIE(,"FDA","FDAIEN")
"RTN","IBP618B",167,0)
. S FDAIEN=FDAIEN(1) K FDAIEN(1)
"RTN","IBP618B",168,0)
D MES^XPDUTL(" New ACTION CHARGES added.")
"RTN","IBP618B",169,0)
K FDA,IBARRAY
"RTN","IBP618B",170,0)
Q
"RTN","IBP618B",171,0)
;
"RTN","IBP618B",172,0)
ACTCHDAT ; Action Charge Data
"RTN","IBP618B",173,0)
;;CHOICE (PER DIEM) NEW;FEE SERV INPT PER DIEM
"RTN","IBP618B",174,0)
;;CC (PER DIEM) NEW;FEE SERV INPT PER DIEM
"RTN","IBP618B",175,0)
;;CCN (PER DIEM) NEW;FEE SERV INPT PER DIEM
"RTN","IBP618B",176,0)
;;CC MTF (PER DIEM) NEW;FEE SERV INPT PER DIEM
"RTN","IBP618B",177,0)
;;LTC CC INPT CNH NEW;FEE LTC INPT CNH
"RTN","IBP618B",178,0)
;;LTC CCN INPT CNH NEW;FEE LTC INPT CNH
"RTN","IBP618B",179,0)
;;LTC CHOICE INPT CNH NEW;FEE LTC INPT CNH
"RTN","IBP618B",180,0)
;;LTC CC INPT RESPITE NEW;FEE LTC INPT RESPITE
"RTN","IBP618B",181,0)
;;LTC CCN INPT RESPITE NEW;FEE LTC INPT RESPITE
"RTN","IBP618B",182,0)
;;LTC CHOICE INPT RESPITE NEW;FEE LTC INPT RESPITE
"RTN","IBP618B",183,0)
;;LTC CC OPT ADHC NEW;FEE LTC OPT ADHC
"RTN","IBP618B",184,0)
;;LTC CCN OPT ADHC NEW;FEE LTC OPT ADHC
"RTN","IBP618B",185,0)
;;LTC CHOICE OPT ADHC NEW;FEE LTC OPT ADHC
"RTN","IBP618B",186,0)
;;LTC CC OPT RESPITE NEW;FEE LTC OPT RESPITE
"RTN","IBP618B",187,0)
;;LTC CCN OPT RESPITE NEW;FEE LTC OPT RESPITE
"RTN","IBP618B",188,0)
;;LTC CHOICE OPT RESPITE NEW;FEE LTC OPT RESPITE
"RTN","IBP618B",189,0)
;;CHOICE (RX) NEW;FEE SERV RX1;O
"RTN","IBP618B",190,0)
;;CHOICE (RX) CANCEL;FEE SERV RX3;O
"RTN","IBP618B",191,0)
;;CHOICE (RX) UPDATE;FEE SERV RX4;O
"RTN","IBP618B",192,0)
;;CC (RX) NEW;FEE SERV RX1;O
"RTN","IBP618B",193,0)
;;CC (RX) CANCEL;FEE SERV RX3;O
"RTN","IBP618B",194,0)
;;CC (RX) UPDATE;FEE SERV RX4;O
"RTN","IBP618B",195,0)
;;CCN (RX) NEW;FEE SERV RX1;O
"RTN","IBP618B",196,0)
;;CCN (RX) CANCEL;FEE SERV RX3;O
"RTN","IBP618B",197,0)
;;CCN (RX) UPDATE;FEE SERV RX4;O
"RTN","IBP618B",198,0)
;;CC MTF (RX) NEW;FEE SERV RX1;O
"RTN","IBP618B",199,0)
;;CC MTF (RX) CANCEL;FEE SERV RX3;O
"RTN","IBP618B",200,0)
;;CC MTF (RX) UPDATE;FEE SERV RX4;O
"RTN","IBP618B",201,0)
;;CHOICE (RX) NEW;FEE SERV RX1;1
"RTN","IBP618B",202,0)
;;CHOICE (RX) NEW;FEE SERV RX1;2
"RTN","IBP618B",203,0)
;;CHOICE (RX) NEW;FEE SERV RX1;3
"RTN","IBP618B",204,0)
;;CHOICE (RX) CANCEL;FEE SERV RX3;1
"RTN","IBP618B",205,0)
;;CHOICE (RX) CANCEL;FEE SERV RX3;2
"RTN","IBP618B",206,0)
;;CHOICE (RX) CANCEL;FEE SERV RX3;3
"RTN","IBP618B",207,0)
;;CHOICE (RX) UPDATE;FEE SERV RX4;1
"RTN","IBP618B",208,0)
;;CHOICE (RX) UPDATE;FEE SERV RX4;2
"RTN","IBP618B",209,0)
;;CHOICE (RX) UPDATE;FEE SERV RX4;3
"RTN","IBP618B",210,0)
;;CC (RX) NEW;FEE SERV RX1;1
"RTN","IBP618B",211,0)
;;CC (RX) NEW;FEE SERV RX1;2
"RTN","IBP618B",212,0)
;;CC (RX) NEW;FEE SERV RX1;3
"RTN","IBP618B",213,0)
;;CC (RX) CANCEL;FEE SERV RX3;1
"RTN","IBP618B",214,0)
;;CC (RX) CANCEL;FEE SERV RX3;2
"RTN","IBP618B",215,0)
;;CC (RX) CANCEL;FEE SERV RX3;3
"RTN","IBP618B",216,0)
;;CC (RX) UPDATE;FEE SERV RX4;1
"RTN","IBP618B",217,0)
;;CC (RX) UPDATE;FEE SERV RX4;2
"RTN","IBP618B",218,0)
;;CC (RX) UPDATE;FEE SERV RX4;3
"RTN","IBP618B",219,0)
;;CCN (RX) NEW;FEE SERV RX1;1
"RTN","IBP618B",220,0)
;;CCN (RX) NEW;FEE SERV RX1;2
"RTN","IBP618B",221,0)
;;CCN (RX) NEW;FEE SERV RX1;3
"RTN","IBP618B",222,0)
;;CCN (RX) CANCEL;FEE SERV RX3;1
"RTN","IBP618B",223,0)
;;CCN (RX) CANCEL;FEE SERV RX3;2
"RTN","IBP618B",224,0)
;;CCN (RX) CANCEL;FEE SERV RX3;3
"RTN","IBP618B",225,0)
;;CCN (RX) UPDATE;FEE SERV RX4;1
"RTN","IBP618B",226,0)
;;CCN (RX) UPDATE;FEE SERV RX4;2
"RTN","IBP618B",227,0)
;;CCN (RX) UPDATE;FEE SERV RX4;3
"RTN","IBP618B",228,0)
;;CC MTF (RX) NEW;FEE SERV RX1;1
"RTN","IBP618B",229,0)
;;CC MTF (RX) NEW;FEE SERV RX1;2
"RTN","IBP618B",230,0)
;;CC MTF (RX) NEW;FEE SERV RX1;3
"RTN","IBP618B",231,0)
;;CC MTF (RX) CANCEL;FEE SERV RX3;1
"RTN","IBP618B",232,0)
;;CC MTF (RX) CANCEL;FEE SERV RX3;2
"RTN","IBP618B",233,0)
;;CC MTF (RX) CANCEL;FEE SERV RX3;3
"RTN","IBP618B",234,0)
;;CC MTF (RX) UPDATE;FEE SERV RX4;1
"RTN","IBP618B",235,0)
;;CC MTF (RX) UPDATE;FEE SERV RX4;2
"RTN","IBP618B",236,0)
;;CC MTF (RX) UPDATE;FEE SERV RX4;3
"RTN","IBP618B",237,0)
Q
"VER")
8.0^22.2
"^DD",350.1,350.1,.12,0)
INACTIVE^St11^^0;12^
"^DD",350.1,350.1,.12,3)
Enter the code which indicates whether or not you would like to inactivate this action type.
"^DD",350.1,350.1,.12,21,0)
^^1^1^3180312^
"^DD",350.1,350.1,.12,21,1,0)
This field indicates whether or not this Action Type has been inactivated.
"^DD",350.1,350.1,.12,"DT")
3180312
"^DD",351.7,351.7,0)
FIELD^^2^4
"^DD",351.7,351.7,0,"DT")
3000913
"^DD",351.7,351.7,0,"IX","AC",351.7,.02)

"^DD",351.7,351.7,0,"IX","B",351.7,.01)

"^DD",351.7,351.7,0,"NM","IB DM EXTRACT REPORTS")

"^DD",351.7,351.7,0,"PT",351.701,.03)

"^DD",351.7,351.7,0,"PT",351.711,.01)

"^DD",351.7,351.7,0,"PT",351.7111,.01)

"^DD",351.7,351.7,0,"VRPK")
IB
"^DD",351.7,351.7,.01,0)
REPORT NAME^RF^^0;1^K:$L(X)>50!($L(X)<3)!'(X'?1P.E) X
"^DD",351.7,351.7,.01,1,0)
^.1
"^DD",351.7,351.7,.01,1,1,0)
351.7^B
"^DD",351.7,351.7,.01,1,1,1)
S ^IBE(351.7,"B",$E(X,1,30),DA)=""
"^DD",351.7,351.7,.01,1,1,2)
K ^IBE(351.7,"B",$E(X,1,30),DA)
"^DD",351.7,351.7,.01,3)
Answer must be 3-50 characters in length.
"^DD",351.7,351.7,.01,21,0)
^.001^1^1^3000913^^^
"^DD",351.7,351.7,.01,21,1,0)
This is the DM report from which data will be extracted.
"^DD",351.7,351.7,.01,"DT")
2990303
"^DD",351.7,351.7,.02,0)
DISABLE?^S^1:YES;^0;2^Q
"^DD",351.7,351.7,.02,1,0)
^.1
"^DD",351.7,351.7,.02,1,1,0)
351.7^AC
"^DD",351.7,351.7,.02,1,1,1)
S ^IBE(351.7,"AC",$E(X,1,30),DA)=""
"^DD",351.7,351.7,.02,1,1,2)
K ^IBE(351.7,"AC",$E(X,1,30),DA)
"^DD",351.7,351.7,.02,1,1,"DT")
2990317
"^DD",351.7,351.7,.02,3)
Enter 'YES' if you don't want this report's summary data extracted.
"^DD",351.7,351.7,.02,21,0)
2^^2^2^2990518^^^^
"^DD",351.7,351.7,.02,21,1,0)
Enter 'YES' if you don't want this report's summary data extracted.
"^DD",351.7,351.7,.02,21,2,0)
The DM extraction background job will skip queueing this report.
"^DD",351.7,351.7,.02,"DT")
3000913
"^DD",351.7,351.7,1,0)
INPUT VARIABLE^351.702^^1;0
"^DD",351.7,351.7,2,0)
ROUTINE^FX^^2;E1,20^K:$L(X)>20!(X'?.1ANP.7AN.1"^"1ANP.7AN.1"[".E) X I $D(X),X["[" K X
"^DD",351.7,351.7,2,3)

"^DD",351.7,351.7,2,4)
D RTN^IBJDE1
"^DD",351.7,351.7,2,21,0)
^.001^10^10^3010418^^^^
"^DD",351.7,351.7,2,21,1,0)
This field is the entry point called by this report to extract
"^DD",351.7,351.7,2,21,2,0)
the data that will be sent to the Extract Module. It is possible
"^DD",351.7,351.7,2,21,3,0)
to enter a program (^ROUTINE), a specific label (TAG^ROUTINE) or
"^DD",351.7,351.7,2,21,4,0)
leave it blank. When this field is left blank, no code will be
"^DD",351.7,351.7,2,21,5,0)
invoked by this report to extract the data. This option should
"^DD",351.7,351.7,2,21,6,0)
be used to allow the data for this report to be extracted by a
"^DD",351.7,351.7,2,21,7,0)
program invoked by another report. This is intended to be used
"^DD",351.7,351.7,2,21,8,0)
when there are two (or more) different reports that run the same
"^DD",351.7,351.7,2,21,9,0)
program to extract their data, then only one will be responsible
"^DD",351.7,351.7,2,21,10,0)
for running the code and extracting the data for both reports.
"^DD",351.7,351.7,2,23,0)
^.001^8^8^3010418^^^^
"^DD",351.7,351.7,2,23,1,0)
This field will hold the routine name responsible for extracting
"^DD",351.7,351.7,2,23,2,0)
the data for the report. It is also possible to indicate a
"^DD",351.7,351.7,2,23,3,0)
specific label. The Data Extraction routine will then queue this
"^DD",351.7,351.7,2,23,4,0)
routine and will store the data returned (usually through the IB
"^DD",351.7,351.7,2,23,5,0)
array) from it. When this field is NULL, the Data Extraction
"^DD",351.7,351.7,2,23,6,0)
routine will do everything but queue a job. This resource (NULL)
"^DD",351.7,351.7,2,23,7,0)
is used to allow that the routine of one report to retrieve and
"^DD",351.7,351.7,2,23,8,0)
store the data for other reports.
"^DD",351.7,351.7,2,"DT")
3000918
"^DD",351.7,351.702,0)
INPUT VARIABLE SUB-FIELD^^1^3
"^DD",351.7,351.702,0,"DT")
2990330
"^DD",351.7,351.702,0,"IX","B",351.702,.01)

"^DD",351.7,351.702,0,"NM","INPUT VARIABLE")

"^DD",351.7,351.702,0,"UP")
351.7
"^DD",351.7,351.702,.01,0)
INPUT VARIABLE^MF^^0;1^K:$L(X)>8!($L(X)<1) X
"^DD",351.7,351.702,.01,1,0)
^.1
"^DD",351.7,351.702,.01,1,1,0)
351.702^B
"^DD",351.7,351.702,.01,1,1,1)
S ^IBE(351.7,DA(1),1,"B",$E(X,1,30),DA)=""
"^DD",351.7,351.702,.01,1,1,2)
K ^IBE(351.7,DA(1),1,"B",$E(X,1,30),DA)
"^DD",351.7,351.702,.01,3)
Answer must be 1-8 characters in length.
"^DD",351.7,351.702,.01,8.5)
@
"^DD",351.7,351.702,.01,9)
@
"^DD",351.7,351.702,.01,21,0)
^^1^1^2990318^
"^DD",351.7,351.702,.01,21,1,0)
This is the name of the pre-set variable associated with this report.
"^DD",351.7,351.702,.01,"DT")
2990316
"^DD",351.7,351.702,.02,0)
VALUE^F^^0;2^K:$L(X)>30!($L(X)<1) X
"^DD",351.7,351.702,.02,3)
Answer must be 1-30 characters in length.
"^DD",351.7,351.702,.02,8.5)
@
"^DD",351.7,351.702,.02,9)
@
"^DD",351.7,351.702,.02,21,0)
^^3^3^2990318^^
"^DD",351.7,351.702,.02,21,1,0)
This is the value of the pre-set variable associated with this report.
"^DD",351.7,351.702,.02,21,2,0)
If the variable is a date variable (IBBDT, IBEDT, etc.), the value is
"^DD",351.7,351.702,.02,21,3,0)
null.
"^DD",351.7,351.702,.02,"DT")
2990330
"^DD",351.7,351.702,1,0)
INPUT STATEMENT^K^^1;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
"^DD",351.7,351.702,1,3)
This is Standard MUMPS code.
"^DD",351.7,351.702,1,8.5)
@
"^DD",351.7,351.702,1,9)
@
"^DD",351.7,351.702,1,21,0)
^^3^3^2990528^^
"^DD",351.7,351.702,1,21,1,0)
This statement, if it exists ($D), will be Xecuted instead of setting the
"^DD",351.7,351.702,1,21,2,0)
contents of the INPUT VARIABLE zero node via the DM extract process. This
"^DD",351.7,351.702,1,21,3,0)
is used primarily for setting date fields (ex. IBBDT, IBEDT).
"^DD",351.7,351.702,1,"DT")
2990327
"^DIC",351.7,351.7,0)
IB DM EXTRACT REPORTS^351.7
"^DIC",351.7,351.7,0,"GL")
^IBE(351.7,
"^DIC",351.7,351.7,"%D",0)
^^4^4^2990405^^
"^DIC",351.7,351.7,"%D",1,0)
This file contains the necessary DM reports which will have their summary
"^DIC",351.7,351.7,"%D",2,0)
data collected via the Diagnostic Measures Extraction process.
"^DIC",351.7,351.7,"%D",3,0)

"^DIC",351.7,351.7,"%D",4,0)
Per VHA directive 10-93-142, this file definition should not be modified.
"^DIC",351.7,"B","IB DM EXTRACT REPORTS",351.7)

**END**
**END**