ECLAIMS_5_5010.KID

KIDS Distribution saved on Jan 16, 2012@14:28:31
E-CLAIMS 5010 BUNDLE 1.0
**KIDS**:ECLAIMS 5 BUNDLE 1.0^PRCA*4.5*275^IB*2.0*447^

**INSTALL NAME**
ECLAIMS 5 BUNDLE 1.0
"BLD",8148,0)
ECLAIMS 5 BUNDLE 1.0^^1^3120116^y
"BLD",8148,1,0)
^^2^2^3110829^
"BLD",8148,1,1,0)
This Integrated Billing (IB) and Accounts Receivable (PRCA) patch expands
"BLD",8148,1,2,0)
the HIPAA 5010 enhancements introduced in patch IB*2.0*432.
"BLD",8148,6.3)
55
"BLD",8148,10,0)
^9.63^2^2
"BLD",8148,10,1,0)
PRCA*4.5*275^1
"BLD",8148,10,2,0)
IB*2.0*447^1
"BLD",8148,10,"B","IB*2.0*447",2)

"BLD",8148,10,"B","PRCA*4.5*275",1)

"BLD",8148,"KRN",0)
^9.67PA^779.2^20
"BLD",8148,"KRN",.4,0)
.4
"BLD",8148,"KRN",.401,0)
.401
"BLD",8148,"KRN",.402,0)
.402
"BLD",8148,"KRN",.403,0)
.403
"BLD",8148,"KRN",.5,0)
.5
"BLD",8148,"KRN",.84,0)
.84
"BLD",8148,"KRN",3.6,0)
3.6
"BLD",8148,"KRN",3.8,0)
3.8
"BLD",8148,"KRN",9.2,0)
9.2
"BLD",8148,"KRN",9.8,0)
9.8
"BLD",8148,"KRN",19,0)
19
"BLD",8148,"KRN",19.1,0)
19.1
"BLD",8148,"KRN",101,0)
101
"BLD",8148,"KRN",409.61,0)
409.61
"BLD",8148,"KRN",771,0)
771
"BLD",8148,"KRN",779.2,0)
779.2
"BLD",8148,"KRN",870,0)
870
"BLD",8148,"KRN",8989.51,0)
8989.51
"BLD",8148,"KRN",8989.52,0)
8989.52
"BLD",8148,"KRN",8994,0)
8994
"BLD",8148,"KRN","B",.4,.4)

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

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

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

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

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

"BLD",8148,"KRN","B",3.6,3.6)

"BLD",8148,"KRN","B",3.8,3.8)

"BLD",8148,"KRN","B",9.2,9.2)

"BLD",8148,"KRN","B",9.8,9.8)

"BLD",8148,"KRN","B",19,19)

"BLD",8148,"KRN","B",19.1,19.1)

"BLD",8148,"KRN","B",101,101)

"BLD",8148,"KRN","B",409.61,409.61)

"BLD",8148,"KRN","B",771,771)

"BLD",8148,"KRN","B",779.2,779.2)

"BLD",8148,"KRN","B",870,870)

"BLD",8148,"KRN","B",8989.51,8989.51)

"BLD",8148,"KRN","B",8989.52,8989.52)

"BLD",8148,"KRN","B",8994,8994)

"MBREQ")
0
"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
"VER")
8.0^22.0
**INSTALL NAME**
PRCA*4.5*275
"BLD",8126,0)
PRCA*4.5*275^ACCOUNTS RECEIVABLE^0^3120116^y
"BLD",8126,4,0)
^9.64PA^436.1^1
"BLD",8126,4,436.1,0)
436.1
"BLD",8126,4,436.1,222)
y^y^f^^^^n
"BLD",8126,4,"B",436.1,436.1)

"BLD",8126,6.3)
72
"BLD",8126,"ABPKG")
n
"BLD",8126,"INID")
^y
"BLD",8126,"INIT")
RCY275PO
"BLD",8126,"KRN",0)
^9.67PA^779.2^20
"BLD",8126,"KRN",.4,0)
.4
"BLD",8126,"KRN",.401,0)
.401
"BLD",8126,"KRN",.402,0)
.402
"BLD",8126,"KRN",.403,0)
.403
"BLD",8126,"KRN",.5,0)
.5
"BLD",8126,"KRN",.84,0)
.84
"BLD",8126,"KRN",3.6,0)
3.6
"BLD",8126,"KRN",3.8,0)
3.8
"BLD",8126,"KRN",3.8,"NM",0)
^9.68A^1^1
"BLD",8126,"KRN",3.8,"NM",1,0)
MDA^^0
"BLD",8126,"KRN",3.8,"NM","B","MDA",1)

"BLD",8126,"KRN",9.2,0)
9.2
"BLD",8126,"KRN",9.8,0)
9.8
"BLD",8126,"KRN",9.8,"NM",0)
^9.68A^7^7
"BLD",8126,"KRN",9.8,"NM",1,0)
PRCAFBDM^^0^B9939431
"BLD",8126,"KRN",9.8,"NM",2,0)
PRCAMDA1^^0^B25439881
"BLD",8126,"KRN",9.8,"NM",3,0)
PRCAMDA2^^0^B34581746
"BLD",8126,"KRN",9.8,"NM",4,0)
PRCAMDA3^^0^B5974782
"BLD",8126,"KRN",9.8,"NM",5,0)
PRCAMDS^^0^B11777483
"BLD",8126,"KRN",9.8,"NM",6,0)
PRCAFBD^^0^B17368357
"BLD",8126,"KRN",9.8,"NM",7,0)
PRCAAPR1^^0^B43589285
"BLD",8126,"KRN",9.8,"NM","B","PRCAAPR1",7)

"BLD",8126,"KRN",9.8,"NM","B","PRCAFBD",6)

"BLD",8126,"KRN",9.8,"NM","B","PRCAFBDM",1)

"BLD",8126,"KRN",9.8,"NM","B","PRCAMDA1",2)

"BLD",8126,"KRN",9.8,"NM","B","PRCAMDA2",3)

"BLD",8126,"KRN",9.8,"NM","B","PRCAMDA3",4)

"BLD",8126,"KRN",9.8,"NM","B","PRCAMDS",5)

"BLD",8126,"KRN",19,0)
19
"BLD",8126,"KRN",19,"NM",0)
^9.68A^3^3
"BLD",8126,"KRN",19,"NM",1,0)
PRCA MDA WORKLIST^^0
"BLD",8126,"KRN",19,"NM",2,0)
PRCAL LIST MENU^^3
"BLD",8126,"KRN",19,"NM",3,0)
PRCA MDA SERVER^^0
"BLD",8126,"KRN",19,"NM","B","PRCA MDA SERVER",3)

"BLD",8126,"KRN",19,"NM","B","PRCA MDA WORKLIST",1)

"BLD",8126,"KRN",19,"NM","B","PRCAL LIST MENU",2)

"BLD",8126,"KRN",19.1,0)
19.1
"BLD",8126,"KRN",19.1,"NM",0)
^9.68A^^
"BLD",8126,"KRN",101,0)
101
"BLD",8126,"KRN",101,"NM",0)
^9.68A^9^8
"BLD",8126,"KRN",101,"NM",1,0)
PRCA MDA ENTER COMMENT^^0
"BLD",8126,"KRN",101,"NM",2,0)
PRCA MDA COMMENT EXIT^^0
"BLD",8126,"KRN",101,"NM",4,0)
PRCA MDA ENTER/VIEW COMMENTS^^0
"BLD",8126,"KRN",101,"NM",5,0)
PRCA MDA EXIT^^0
"BLD",8126,"KRN",101,"NM",6,0)
PRCA MDA MANAGEMENT^^0
"BLD",8126,"KRN",101,"NM",7,0)
PRCA MDA REVIEW STATUS^^0
"BLD",8126,"KRN",101,"NM",8,0)
PRCA MDA TPJI^^0
"BLD",8126,"KRN",101,"NM",9,0)
PRCA MDA COMMENT MENU^^0
"BLD",8126,"KRN",101,"NM","B","PRCA MDA COMMENT EXIT",2)

"BLD",8126,"KRN",101,"NM","B","PRCA MDA COMMENT MENU",9)

"BLD",8126,"KRN",101,"NM","B","PRCA MDA ENTER COMMENT",1)

"BLD",8126,"KRN",101,"NM","B","PRCA MDA ENTER/VIEW COMMENTS",4)

"BLD",8126,"KRN",101,"NM","B","PRCA MDA EXIT",5)

"BLD",8126,"KRN",101,"NM","B","PRCA MDA MANAGEMENT",6)

"BLD",8126,"KRN",101,"NM","B","PRCA MDA REVIEW STATUS",7)

"BLD",8126,"KRN",101,"NM","B","PRCA MDA TPJI",8)

"BLD",8126,"KRN",409.61,0)
409.61
"BLD",8126,"KRN",409.61,"NM",0)
^9.68A^2^2
"BLD",8126,"KRN",409.61,"NM",1,0)
PRCA MDA COMMENTS^^0
"BLD",8126,"KRN",409.61,"NM",2,0)
PRCA MDA WORKLIST^^0
"BLD",8126,"KRN",409.61,"NM","B","PRCA MDA COMMENTS",1)

"BLD",8126,"KRN",409.61,"NM","B","PRCA MDA WORKLIST",2)

"BLD",8126,"KRN",771,0)
771
"BLD",8126,"KRN",779.2,0)
779.2
"BLD",8126,"KRN",870,0)
870
"BLD",8126,"KRN",8989.51,0)
8989.51
"BLD",8126,"KRN",8989.52,0)
8989.52
"BLD",8126,"KRN",8994,0)
8994
"BLD",8126,"KRN","B",.4,.4)

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

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

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

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

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

"BLD",8126,"KRN","B",3.6,3.6)

"BLD",8126,"KRN","B",3.8,3.8)

"BLD",8126,"KRN","B",9.2,9.2)

"BLD",8126,"KRN","B",9.8,9.8)

"BLD",8126,"KRN","B",19,19)

"BLD",8126,"KRN","B",19.1,19.1)

"BLD",8126,"KRN","B",101,101)

"BLD",8126,"KRN","B",409.61,409.61)

"BLD",8126,"KRN","B",771,771)

"BLD",8126,"KRN","B",779.2,779.2)

"BLD",8126,"KRN","B",870,870)

"BLD",8126,"KRN","B",8989.51,8989.51)

"BLD",8126,"KRN","B",8989.52,8989.52)

"BLD",8126,"KRN","B",8994,8994)

"BLD",8126,"QUES",0)
^9.62^^
"BLD",8126,"REQB",0)
^9.611^2^2
"BLD",8126,"REQB",1,0)
PRCA*4.5*270^1
"BLD",8126,"REQB",2,0)
PRCA*4.5*276^1
"BLD",8126,"REQB","B","PRCA*4.5*270",1)

"BLD",8126,"REQB","B","PRCA*4.5*276",2)

"FIA",436.1)
AR MEDICARE DEDUCTIBLE ALERTS PART A
"FIA",436.1,0)
^PRCA(436.1,
"FIA",436.1,0,0)
436.1
"FIA",436.1,0,1)
y^y^f^^^^n
"FIA",436.1,0,10)

"FIA",436.1,0,11)

"FIA",436.1,0,"RLRO")

"FIA",436.1,0,"VR")
4.5^PRCA
"FIA",436.1,436.1)
0
"FIA",436.1,436.12)
0
"FIA",436.1,436.122)
0
"INIT")
RCY275PO
"IX",436.1,436.1,"AMDA",0)
436.1^AMDA^MDA worklist entry^R^^F^IR^I^436.1^^^^^S
"IX",436.1,436.1,"AMDA",.1,0)
^^4^4^3110811^
"IX",436.1,436.1,"AMDA",.1,1,0)
This is the cross reference used to display the entries on the MDA 
"IX",436.1,436.1,"AMDA",.1,2,0)
worklist.  There are 4 values for the MDA REVIEW STATUS field, 3 of 
"IX",436.1,436.1,"AMDA",.1,3,0)
which are on the worklist and only one is not.  While there are 3 values
"IX",436.1,436.1,"AMDA",.1,4,0)
that are on the worklist, the worklist is not sorted by this value.
"IX",436.1,436.1,"AMDA",1)
S ^PRCA(436.1,"AMDA",$E(X,1,1),DA)=""
"IX",436.1,436.1,"AMDA",2)
K ^PRCA(436.1,"AMDA",$E(X,1,1),DA)
"IX",436.1,436.1,"AMDA",2.5)
K ^PRCA(436.1,"AMDA")
"IX",436.1,436.1,"AMDA",11.1,0)
^.114IA^1^1
"IX",436.1,436.1,"AMDA",11.1,1,0)
1^F^436.1^1.02^1^1^F
"IX",436.1,436.1,"AMDA",11.1,1,2)
S X=$S(X=3:0,1:1)
"IX",436.1,436.1,"AMDA",11.1,1,3)

"KRN",3.8,416,-1)
0^1
"KRN",3.8,416,0)
MDA^PU^n^^^0^
"KRN",3.8,416,2,0)
^3.801^2^2^3111019^^^^
"KRN",3.8,416,2,1,0)
This is the Medicare Deductible Alert (MDA) queue that will receive all
"KRN",3.8,416,2,2,0)
the MDA transmissions from Austin.
"KRN",3.8,416,3)

"KRN",19,1395,-1)
3^2
"KRN",19,1395,0)
PRCAL LIST MENU^Accounts Receivable Status Reports^^M^^^^^^^^
"KRN",19,1395,1,0)
^19.06^3^3^3110804^^^^
"KRN",19,1395,1,1,0)
This is a menu of options to display lists of bills by status (new,
"KRN",19,1395,1,2,0)
incomplete, active, written-off) or referral action (Regional Counsel
"KRN",19,1395,1,3,0)
or Department of Justice).
"KRN",19,1395,10,0)
^19.01IP^12^12
"KRN",19,1395,10,12,0)
12969^MDA
"KRN",19,1395,10,12,"^")
PRCA MDA WORKLIST
"KRN",19,1395,99)
62469,56989
"KRN",19,1395,99.1)
57575,61208
"KRN",19,1395,"U")
ACCOUNTS RECEIVABLE STATUS REP
"KRN",19,12964,-1)
0^3
"KRN",19,12964,0)
PRCA MDA SERVER^PRCA MEDICARE DEDUCTIBLE ALERT SERVER^^S^^^^^^^^ACCOUNTS RECEIVABLE
"KRN",19,12964,1,0)
^19.06^2^2^3111019^^^^
"KRN",19,12964,1,1,0)
This option is the server for receiving Medicare Deductible Alerts for
"KRN",19,12964,1,2,0)
automatic processing in AR.
"KRN",19,12964,25)
SERVER^PRCAMDS
"KRN",19,12964,220)
^R^^^Y^^1^^
"KRN",19,12964,"U")
PRCA MEDICARE DEDUCTIBLE ALERT
"KRN",19,12969,-1)
0^1
"KRN",19,12969,0)
PRCA MDA WORKLIST^Medicare Deductible Alert Worklist^^R^^^^^^^^
"KRN",19,12969,1,0)
^^1^1^3110826^
"KRN",19,12969,1,1,0)
This option is the worklist for processing Medicare Deductible Alerts.
"KRN",19,12969,25)
EN^PRCAMDA1
"KRN",19,12969,"U")
MEDICARE DEDUCTIBLE ALERT WORK
"KRN",101,4635,-1)
0^8
"KRN",101,4635,0)
PRCA MDA TPJI^Third Party Joint Inq.^^A^^^^^^^^ACCOUNTS RECEIVABLE
"KRN",101,4635,4)
^^^TP
"KRN",101,4635,20)
D TPJI^PRCAMDA2
"KRN",101,4635,99)
62469,56989
"KRN",101,4636,-1)
0^6
"KRN",101,4636,0)
PRCA MDA MANAGEMENT^Medicare Deductible Alert Management Worklist^^M^^^^^^^^ACCOUNTS RECEIVABLE
"KRN",101,4636,4)
26^4^^PR
"KRN",101,4636,10,0)
^101.01PA^4^4
"KRN",101,4636,10,1,0)
4635^TP^40^
"KRN",101,4636,10,1,"^")
PRCA MDA TPJI
"KRN",101,4636,10,2,0)
4637^EC^10^
"KRN",101,4636,10,2,"^")
PRCA MDA ENTER/VIEW COMMENTS
"KRN",101,4636,10,3,0)
4639^EX^50^
"KRN",101,4636,10,3,"^")
PRCA MDA EXIT
"KRN",101,4636,10,4,0)
4638^RS^30^
"KRN",101,4636,10,4,"^")
PRCA MDA REVIEW STATUS
"KRN",101,4636,26)
D SHOW^VALM
"KRN",101,4636,28)
Select Action: 
"KRN",101,4636,99)
62469,56989
"KRN",101,4637,-1)
0^4
"KRN",101,4637,0)
PRCA MDA ENTER/VIEW COMMENTS^Enter/View Comments^^A^^^^^^^^ACCOUNTS RECEIVABLE
"KRN",101,4637,20)
D CMNT^PRCAMDA2
"KRN",101,4637,99)
62469,56989
"KRN",101,4638,-1)
0^7
"KRN",101,4638,0)
PRCA MDA REVIEW STATUS^Review Status^^A^^^^^^^^ACCOUNTS RECEIVABLE
"KRN",101,4638,20)
D STATUS^PRCAMDA2
"KRN",101,4638,99)
62469,56989
"KRN",101,4639,-1)
0^5
"KRN",101,4639,0)
PRCA MDA EXIT^Exit^^A^^^^^^^^ACCOUNTS RECEIVABLE
"KRN",101,4639,99)
62469,56989
"KRN",101,4643,-1)
0^1
"KRN",101,4643,0)
PRCA MDA ENTER COMMENT^Enter Comment^^A^^^^^^^^ACCOUNTS RECEIVABLE
"KRN",101,4643,20)
D CMNT^PRCAMDA3
"KRN",101,4643,99)
62469,56989
"KRN",101,4644,-1)
0^2
"KRN",101,4644,0)
PRCA MDA COMMENT EXIT^Exit^^A^^^^^^^^ACCOUNTS RECEIVABLE
"KRN",101,4644,99)
62469,56989
"KRN",101,4645,-1)
0^9
"KRN",101,4645,0)
PRCA MDA COMMENT MENU^Medicare Deductible Alert Comments^^M^^^^^^^^ACCOUNTS RECEIVABLE
"KRN",101,4645,4)
26^4
"KRN",101,4645,10,0)
^101.01PA^1^1
"KRN",101,4645,10,1,0)
4643^EC^10^
"KRN",101,4645,10,1,"^")
PRCA MDA ENTER COMMENT
"KRN",101,4645,26)
D SHOW^VALM
"KRN",101,4645,28)
Select Action: 
"KRN",101,4645,99)
62469,56989
"KRN",409.61,827,-1)
0^2
"KRN",409.61,827,0)
PRCA MDA WORKLIST^1^^80^4^18^1^1^AR^PRCA MDA MANAGEMENT^MDA Management Worklist^1^^1
"KRN",409.61,827,1)
^VALM HIDDEN ACTIONS
"KRN",409.61,827,"ARRAY")
 ^TMP("PRCAMDA",$J)
"KRN",409.61,827,"COL",0)
^409.621^9^9
"KRN",409.61,827,"COL",1,0)
BILL^4^12^Bill #^^0
"KRN",409.61,827,"COL",2,0)
PTNAME^16^20^Patient Name^^0
"KRN",409.61,827,"COL",3,0)
SUBID^37^10^Sub ID
"KRN",409.61,827,"COL",4,0)
NUMBER^1^4
"KRN",409.61,827,"COL",5,0)
SYEAR^47^5^SrtYr
"KRN",409.61,827,"COL",6,0)
EYEAR^53^5^EndYr
"KRN",409.61,827,"COL",7,0)
DEDSUB^59^6^DedSub
"KRN",409.61,827,"COL",8,0)
DEDAVL^66^6^DedAvl
"KRN",409.61,827,"COL",9,0)
RPTDT^73^8^RptDt
"KRN",409.61,827,"COL","AIDENT",0,1)

"KRN",409.61,827,"COL","AIDENT",0,2)

"KRN",409.61,827,"COL","B","BILL",1)

"KRN",409.61,827,"COL","B","DEDAVL",8)

"KRN",409.61,827,"COL","B","DEDSUB",7)

"KRN",409.61,827,"COL","B","EYEAR",6)

"KRN",409.61,827,"COL","B","NUMBER",4)

"KRN",409.61,827,"COL","B","PTNAME",2)

"KRN",409.61,827,"COL","B","RPTDT",9)

"KRN",409.61,827,"COL","B","SUBID",3)

"KRN",409.61,827,"COL","B","SYEAR",5)

"KRN",409.61,827,"EXP")
D EXP^PRCAMDA1
"KRN",409.61,827,"FNL")
D EXIT^PRCAMDA1
"KRN",409.61,827,"HDR")
D HDR^PRCAMDA1
"KRN",409.61,827,"HLP")
D HELP^PRCAMDA1
"KRN",409.61,827,"INIT")
D INIT^PRCAMDA1
"KRN",409.61,830,-1)
0^1
"KRN",409.61,830,0)
PRCA MDA COMMENTS^1^^80^5^14^0^1^^PRCA MDA COMMENT MENU^PRCA MDA COMMENTS^1^^1
"KRN",409.61,830,1)
^VALM HIDDEN ACTIONS
"KRN",409.61,830,"FNL")
D EXIT^PRCAMDA3
"KRN",409.61,830,"HDR")
D HDR^PRCAMDA3
"KRN",409.61,830,"HLP")
D HELP^PRCAMDA3
"KRN",409.61,830,"INIT")
D INIT^PRCAMDA3
"MBREQ")
1
"ORD",11,3.8)
3.8;11;;;MAILG^XPDTA1;MAILGF1^XPDIA1;MAILGE1^XPDIA1;MAILGF2^XPDIA1;;MAILGDEL^XPDIA1(%)
"ORD",11,3.8,0)
MAIL GROUP
"ORD",15,101)
101;15;;;PRO^XPDTA;PROF1^XPDIA;PROE1^XPDIA;PROF2^XPDIA;;PRODEL^XPDIA
"ORD",15,101,0)
PROTOCOL
"ORD",17,409.61)
409.61;17;1;;;;LME1^XPDIA1;;;LMDEL^XPDIA1
"ORD",17,409.61,0)
LIST TEMPLATE
"ORD",18,19)
19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA
"ORD",18,19,0)
OPTION
"PKG",142,-1)
1^1
"PKG",142,0)
ACCOUNTS RECEIVABLE^PRCA^BILL COLLECTIONS
"PKG",142,20,0)
^9.402P^2^1
"PKG",142,20,2,0)
2^^PRCAMRG
"PKG",142,20,2,1)

"PKG",142,20,"B",2,2)

"PKG",142,22,0)
^9.49I^1^1
"PKG",142,22,1,0)
4.5^^2950320
"PKG",142,22,1,"PAH",1,0)
275^3120116^123456868
"PKG",142,22,1,"PAH",1,1,0)
^^241^241^3120113
"PKG",142,22,1,"PAH",1,1,1,0)
This Integrated Billing (IB) patch expands the HIPAA 5010 
"PKG",142,22,1,"PAH",1,1,2,0)
enhancements 
"PKG",142,22,1,"PAH",1,1,3,0)
introduced in patch IB*2.0*432.
"PKG",142,22,1,"PAH",1,1,4,0)
 
"PKG",142,22,1,"PAH",1,1,5,0)
The intent of this patch is to:
"PKG",142,22,1,"PAH",1,1,6,0)
1. Modify the Third Party Joint Inquiry option [IBJ THIRD PARTY JOINT
"PKG",142,22,1,"PAH",1,1,7,0)
   INQUIRY] to allow up to 10 characters of an inactive claim number to
"PKG",142,22,1,"PAH",1,1,8,0)
   display.
"PKG",142,22,1,"PAH",1,1,9,0)
 
"PKG",142,22,1,"PAH",1,1,10,0)
2. Modify the Full Account Profile option [PRCAY FULL ACCOUNT PROFILE] to
"PKG",142,22,1,"PAH",1,1,11,0)
   allow up to 10 characters of an inactive claim number to display.
"PKG",142,22,1,"PAH",1,1,12,0)
 
"PKG",142,22,1,"PAH",1,1,13,0)
3. Create the processes to support the receipt, storage and display of
"PKG",142,22,1,"PAH",1,1,14,0)
   Medicare deductible information from Trailblazer Health care
"PKG",142,22,1,"PAH",1,1,15,0)
   Enterprise.
"PKG",142,22,1,"PAH",1,1,16,0)
 
"PKG",142,22,1,"PAH",1,1,17,0)
4. Create a new option called the Medicare Deductible Alert Worklist [PRCA
"PKG",142,22,1,"PAH",1,1,18,0)
   MDA Worklist] from which users can view Medicare deductible 
"PKG",142,22,1,"PAH",1,1,19,0)
   information.
"PKG",142,22,1,"PAH",1,1,20,0)
 
"PKG",142,22,1,"PAH",1,1,21,0)
 
"PKG",142,22,1,"PAH",1,1,22,0)
Patch Components
"PKG",142,22,1,"PAH",1,1,23,0)
================
"PKG",142,22,1,"PAH",1,1,24,0)
<Additional patch components can be added alphabetically if needed.>
"PKG",142,22,1,"PAH",1,1,25,0)
 
"PKG",142,22,1,"PAH",1,1,26,0)
 
"PKG",142,22,1,"PAH",1,1,27,0)
Files & Fields Associated:
"PKG",142,22,1,"PAH",1,1,28,0)
 
"PKG",142,22,1,"PAH",1,1,29,0)
File Name (Number)         Field Name (Number)   New/Modified/Deleted
"PKG",142,22,1,"PAH",1,1,30,0)
------------------         -------------------   --------------------
"PKG",142,22,1,"PAH",1,1,31,0)
 
"PKG",142,22,1,"PAH",1,1,32,0)
 
"PKG",142,22,1,"PAH",1,1,33,0)
Forms Associated:
"PKG",142,22,1,"PAH",1,1,34,0)
 
"PKG",142,22,1,"PAH",1,1,35,0)
Form Name             File #                     New/Modified/Deleted
"PKG",142,22,1,"PAH",1,1,36,0)
---------             ------                     --------------------
"PKG",142,22,1,"PAH",1,1,37,0)
 
"PKG",142,22,1,"PAH",1,1,38,0)
 
"PKG",142,22,1,"PAH",1,1,39,0)
Mail Groups Associated:
"PKG",142,22,1,"PAH",1,1,40,0)
 
"PKG",142,22,1,"PAH",1,1,41,0)
Mail Group Name                                  New/Modified/Deleted
"PKG",142,22,1,"PAH",1,1,42,0)
---------------                                  --------------------
"PKG",142,22,1,"PAH",1,1,43,0)
 
"PKG",142,22,1,"PAH",1,1,44,0)
MDA 
"PKG",142,22,1,"PAH",1,1,45,0)
 
"PKG",142,22,1,"PAH",1,1,46,0)
 
"PKG",142,22,1,"PAH",1,1,47,0)
Options Associated:
"PKG",142,22,1,"PAH",1,1,48,0)
 
"PKG",142,22,1,"PAH",1,1,49,0)
Option Name            Type                      New/Modified/Deleted
"PKG",142,22,1,"PAH",1,1,50,0)
-----------            ----                      --------------------
"PKG",142,22,1,"PAH",1,1,51,0)
 
"PKG",142,22,1,"PAH",1,1,52,0)
PRCA MDA WORKLIST      run routine
"PKG",142,22,1,"PAH",1,1,53,0)
 
"PKG",142,22,1,"PAH",1,1,54,0)
PRCAL LIST MENU        menu
"PKG",142,22,1,"PAH",1,1,55,0)
 
"PKG",142,22,1,"PAH",1,1,56,0)
PRCA MDA SERVER        server
"PKG",142,22,1,"PAH",1,1,57,0)
 
"PKG",142,22,1,"PAH",1,1,58,0)
 
"PKG",142,22,1,"PAH",1,1,59,0)
Protocols Associated:
"PKG",142,22,1,"PAH",1,1,60,0)
 
"PKG",142,22,1,"PAH",1,1,61,0)
Protocol Name                                    New/Modified/Deleted
"PKG",142,22,1,"PAH",1,1,62,0)
-------------                                    --------------------
"PKG",142,22,1,"PAH",1,1,63,0)
 
"PKG",142,22,1,"PAH",1,1,64,0)
PRCA MDA COMMENT
"PKG",142,22,1,"PAH",1,1,65,0)
EXIT 
"PKG",142,22,1,"PAH",1,1,66,0)
 
"PKG",142,22,1,"PAH",1,1,67,0)
PRCA MDA ENTER
"PKG",142,22,1,"PAH",1,1,68,0)
COMMENT 
"PKG",142,22,1,"PAH",1,1,69,0)
 
"PKG",142,22,1,"PAH",1,1,70,0)
PRCA MDA ENTER/VIEW
"PKG",142,22,1,"PAH",1,1,71,0)
COMMENTS 
"PKG",142,22,1,"PAH",1,1,72,0)
 
"PKG",142,22,1,"PAH",1,1,73,0)
PRCA MDA EXIT 
"PKG",142,22,1,"PAH",1,1,74,0)
 
"PKG",142,22,1,"PAH",1,1,75,0)
PRCA MDA MANAGEMENT 
"PKG",142,22,1,"PAH",1,1,76,0)
 
"PKG",142,22,1,"PAH",1,1,77,0)
PRCA MDA REVIEW
"PKG",142,22,1,"PAH",1,1,78,0)
STATUS 
"PKG",142,22,1,"PAH",1,1,79,0)
 
"PKG",142,22,1,"PAH",1,1,80,0)
PRCA MDA TPJI 
"PKG",142,22,1,"PAH",1,1,81,0)
 
"PKG",142,22,1,"PAH",1,1,82,0)
 
"PKG",142,22,1,"PAH",1,1,83,0)
Security Keys Associated:
"PKG",142,22,1,"PAH",1,1,84,0)
 
"PKG",142,22,1,"PAH",1,1,85,0)
Security Key Name                                New/Modified/Deleted
"PKG",142,22,1,"PAH",1,1,86,0)
-----------------                                --------------------
"PKG",142,22,1,"PAH",1,1,87,0)
 
"PKG",142,22,1,"PAH",1,1,88,0)
 
"PKG",142,22,1,"PAH",1,1,89,0)
Templates Associated:
"PKG",142,22,1,"PAH",1,1,90,0)
 
"PKG",142,22,1,"PAH",1,1,91,0)
Template Name      Type      File Name (Number)  New/Modified/Deleted 
"PKG",142,22,1,"PAH",1,1,92,0)
-------------      ----      ------------------  --------------------
"PKG",142,22,1,"PAH",1,1,93,0)
 
"PKG",142,22,1,"PAH",1,1,94,0)
 
"PKG",142,22,1,"PAH",1,1,95,0)
Additional Information:
"PKG",142,22,1,"PAH",1,1,96,0)
<Additional information sections can be added alphabetically if needed.>
"PKG",142,22,1,"PAH",1,1,97,0)
 
"PKG",142,22,1,"PAH",1,1,98,0)
 
"PKG",142,22,1,"PAH",1,1,99,0)
New Service Requests (NSRs)
"PKG",142,22,1,"PAH",1,1,100,0)
----------------------------  
"PKG",142,22,1,"PAH",1,1,101,0)
<List each NSR and its subject. If there are none, then list N/A>
"PKG",142,22,1,"PAH",1,1,102,0)
 
"PKG",142,22,1,"PAH",1,1,103,0)
 
"PKG",142,22,1,"PAH",1,1,104,0)
Patient Safety Issues (PSIs)
"PKG",142,22,1,"PAH",1,1,105,0)
-----------------------------
"PKG",142,22,1,"PAH",1,1,106,0)
<List PSI number and brief description.>
"PKG",142,22,1,"PAH",1,1,107,0)
 
"PKG",142,22,1,"PAH",1,1,108,0)
 
"PKG",142,22,1,"PAH",1,1,109,0)
Remedy Ticket(s) & Overview
"PKG",142,22,1,"PAH",1,1,110,0)
---------------------------
"PKG",142,22,1,"PAH",1,1,111,0)
<List each Remedy Ticket, and include a description of the problem and the
"PKG",142,22,1,"PAH",1,1,112,0)
resolution.>
"PKG",142,22,1,"PAH",1,1,113,0)
 
"PKG",142,22,1,"PAH",1,1,114,0)
1. <Remedy Ticket #> <Subject>
"PKG",142,22,1,"PAH",1,1,115,0)
 
"PKG",142,22,1,"PAH",1,1,116,0)
Problem:
"PKG",142,22,1,"PAH",1,1,117,0)
-------
"PKG",142,22,1,"PAH",1,1,118,0)
<Enter a brief description of problem reported.>
"PKG",142,22,1,"PAH",1,1,119,0)
 
"PKG",142,22,1,"PAH",1,1,120,0)
Resolution:
"PKG",142,22,1,"PAH",1,1,121,0)
----------
"PKG",142,22,1,"PAH",1,1,122,0)
<Enter a brief description of the resolution.>
"PKG",142,22,1,"PAH",1,1,123,0)
 
"PKG",142,22,1,"PAH",1,1,124,0)
 
"PKG",142,22,1,"PAH",1,1,125,0)
Test Sites:
"PKG",142,22,1,"PAH",1,1,126,0)
----------
"PKG",142,22,1,"PAH",1,1,127,0)
<List test sites that actually participated in testing and signed off on 
"PKG",142,22,1,"PAH",1,1,128,0)
the patch. A copy and paste from NOIS displaying the test sites in
"PKG",142,22,1,"PAH",1,1,129,0)
production can be used.>
"PKG",142,22,1,"PAH",1,1,130,0)
 
"PKG",142,22,1,"PAH",1,1,131,0)
 
"PKG",142,22,1,"PAH",1,1,132,0)
Documentation Retrieval Instructions
"PKG",142,22,1,"PAH",1,1,133,0)
------------------------------------ 
"PKG",142,22,1,"PAH",1,1,134,0)
Updated documentation describing the new functionality introduced by this 
"PKG",142,22,1,"PAH",1,1,135,0)
patch is available.
"PKG",142,22,1,"PAH",1,1,136,0)
 
"PKG",142,22,1,"PAH",1,1,137,0)
The preferred method is to FTP the files from 
"PKG",142,22,1,"PAH",1,1,138,0)
ftp://download.vista.med.va.gov/.
"PKG",142,22,1,"PAH",1,1,139,0)
This transmits the files from the first available FTP server. Sites may 
"PKG",142,22,1,"PAH",1,1,140,0)
also elect to retrieve software directly from a specific server as 
"PKG",142,22,1,"PAH",1,1,141,0)
follows:
"PKG",142,22,1,"PAH",1,1,142,0)
 
"PKG",142,22,1,"PAH",1,1,143,0)
 Albany         ftp.fo-albany.med.va.gov  <ftp://ftp.fo-albany.med.va.gov>
"PKG",142,22,1,"PAH",1,1,144,0)
 Hines          ftp.fo-hines.med.va.gov   <ftp://ftp.fo-hines.med.va.gov>
"PKG",142,22,1,"PAH",1,1,145,0)
 Salt Lake City ftp.fo-slc.med.va.gov     <ftp://ftp.fo-slc.med.va.gov>
"PKG",142,22,1,"PAH",1,1,146,0)
 
"PKG",142,22,1,"PAH",1,1,147,0)
Documentation can also be found on the VA Software Documentation Library 
"PKG",142,22,1,"PAH",1,1,148,0)
at: http://www4.va.gov/vdl/
"PKG",142,22,1,"PAH",1,1,149,0)
 
"PKG",142,22,1,"PAH",1,1,150,0)
Title                         File Name                       FTP Mode
"PKG",142,22,1,"PAH",1,1,151,0)
-----------------------------------------------------------------------
"PKG",142,22,1,"PAH",1,1,152,0)
<Documentation title>       
"PKG",142,22,1,"PAH",1,1,153,0)
 
"PKG",142,22,1,"PAH",1,1,154,0)
 
"PKG",142,22,1,"PAH",1,1,155,0)
Patch Installation:
"PKG",142,22,1,"PAH",1,1,156,0)
 
"PKG",142,22,1,"PAH",1,1,157,0)
 
"PKG",142,22,1,"PAH",1,1,158,0)
Pre/Post Installation Overview
"PKG",142,22,1,"PAH",1,1,159,0)
------------------------------
"PKG",142,22,1,"PAH",1,1,160,0)
<Provide a brief overview of what the pre/post installation entails.  The
"PKG",142,22,1,"PAH",1,1,161,0)
actual instructions will be listed below in the Installation Instructions
"PKG",142,22,1,"PAH",1,1,162,0)
section. Note whether pre/post installation routines can be deleted after
"PKG",142,22,1,"PAH",1,1,163,0)
they run or whether they are automatically deleted.>
"PKG",142,22,1,"PAH",1,1,164,0)
 
"PKG",142,22,1,"PAH",1,1,165,0)
**** Please note, if you select the option below, Compare Transport Global
"PKG",142,22,1,"PAH",1,1,166,0)
     to Current System, and select #1 Full Comparison, you will get a
"PKG",142,22,1,"PAH",1,1,167,0)
     system error:  <UNDEFINED>S+1^DIQ ^IBA(364.6,1937,0) due to a known
"PKG",142,22,1,"PAH",1,1,168,0)
     issue with the KIDS Full Compare option (see Remedy Ticket
"PKG",142,22,1,"PAH",1,1,169,0)
     HD0000000449128). You can run any of the other 3 compare options
"PKG",142,22,1,"PAH",1,1,170,0)
     without issue.
"PKG",142,22,1,"PAH",1,1,171,0)
 
"PKG",142,22,1,"PAH",1,1,172,0)
Installation Instructions
"PKG",142,22,1,"PAH",1,1,173,0)
-------------------------
"PKG",142,22,1,"PAH",1,1,174,0)
  ******************************************************************
"PKG",142,22,1,"PAH",1,1,175,0)
  *  You should install this patch during non-peak hours, when no  *
"PKG",142,22,1,"PAH",1,1,176,0)
  *  Integrated Billing or Accounts Receivable users are on the    *
"PKG",142,22,1,"PAH",1,1,177,0)
  *  system.                                                       *
"PKG",142,22,1,"PAH",1,1,178,0)
  ******************************************************************
"PKG",142,22,1,"PAH",1,1,179,0)
 
"PKG",142,22,1,"PAH",1,1,180,0)
There are no options to disable.
"PKG",142,22,1,"PAH",1,1,181,0)
 
"PKG",142,22,1,"PAH",1,1,182,0)
Pre-Installation Instructions
"PKG",142,22,1,"PAH",1,1,183,0)
-----------------------------
"PKG",142,22,1,"PAH",1,1,184,0)
<Provide a brief description of what the pre-installation will be doing. 
"PKG",142,22,1,"PAH",1,1,185,0)
List pre-installation instructions (i.e., links, filers, or batch
"PKG",142,22,1,"PAH",1,1,186,0)
transmissions that need to be stopped, jobs unscheduled, etc.), if
"PKG",142,22,1,"PAH",1,1,187,0)
applicable.>
"PKG",142,22,1,"PAH",1,1,188,0)
 
"PKG",142,22,1,"PAH",1,1,189,0)
1.  Choose the PackMan message containing this patch.
"PKG",142,22,1,"PAH",1,1,190,0)
 
"PKG",142,22,1,"PAH",1,1,191,0)
2.  Choose the INSTALL/CHECK MESSAGE PackMan option.  
"PKG",142,22,1,"PAH",1,1,192,0)
 
"PKG",142,22,1,"PAH",1,1,193,0)
3.  From the Kernel Installation and Distribution System Menu, select
"PKG",142,22,1,"PAH",1,1,194,0)
    the Installation Menu.  From this menu, you may elect to use the
"PKG",142,22,1,"PAH",1,1,195,0)
    following option. When prompted for the INSTALL enter the patch #(ex.
"PKG",142,22,1,"PAH",1,1,196,0)
    XXX*X.X*XX):
"PKG",142,22,1,"PAH",1,1,197,0)
 
"PKG",142,22,1,"PAH",1,1,198,0)
    a.  Backup a Transport Global - This option will create a backup
"PKG",142,22,1,"PAH",1,1,199,0)
        message of any routines exported with this patch. It will not
"PKG",142,22,1,"PAH",1,1,200,0)
        backup any other changes such as DD's or templates.
"PKG",142,22,1,"PAH",1,1,201,0)
    b.  Compare Transport Global to Current System - This option will
"PKG",142,22,1,"PAH",1,1,202,0)
        allow you to view all changes that will be made when this patch
"PKG",142,22,1,"PAH",1,1,203,0)
        is installed.  It compares all components of this patch
"PKG",142,22,1,"PAH",1,1,204,0)
        (routines, DD's, templates, etc.).
"PKG",142,22,1,"PAH",1,1,205,0)
    c.  Verify Checksums in Transport Global - This option will allow
"PKG",142,22,1,"PAH",1,1,206,0)
        you to ensure the integrity of the routines that are in the
"PKG",142,22,1,"PAH",1,1,207,0)
        transport global.
"PKG",142,22,1,"PAH",1,1,208,0)
     
"PKG",142,22,1,"PAH",1,1,209,0)
4.  From the Installation Menu, select the Install Package(s) option and
"PKG",142,22,1,"PAH",1,1,210,0)
    choose the patch to install.
"PKG",142,22,1,"PAH",1,1,211,0)
 
"PKG",142,22,1,"PAH",1,1,212,0)
5.  When prompted 'Want KIDS to Rebuild Menu Trees Upon Completion of
"PKG",142,22,1,"PAH",1,1,213,0)
    Install? NO//'     
"PKG",142,22,1,"PAH",1,1,214,0)
    <Provide the installer with guidance on whether or not menu trees need
"PKG",142,22,1,"PAH",1,1,215,0)
    to be rebuilt.  For instance the menu trees do not need rebuilt if 
"PKG",142,22,1,"PAH",1,1,216,0)
    there are no menus involved in the patch or their system rebuilds menu
"PKG",142,22,1,"PAH",1,1,217,0)
    trees nightly using TaskMan. If they must answering YES to rebuild 
"PKG",142,22,1,"PAH",1,1,218,0)
    the menu trees warn them that it could affect users on the system and
"PKG",142,22,1,"PAH",1,1,219,0)
    installation times will increase.>
"PKG",142,22,1,"PAH",1,1,220,0)
 
"PKG",142,22,1,"PAH",1,1,221,0)
6.  When prompted 'Want KIDS to INHIBIT LOGONs during the install?
"PKG",142,22,1,"PAH",1,1,222,0)
    NO//'
"PKG",142,22,1,"PAH",1,1,223,0)
 
"PKG",142,22,1,"PAH",1,1,224,0)
    <to inhibit logons.>
"PKG",142,22,1,"PAH",1,1,225,0)
 
"PKG",142,22,1,"PAH",1,1,226,0)
7.  When prompted 'Want to DISABLE Scheduled Options, Menu Options, 
"PKG",142,22,1,"PAH",1,1,227,0)
    and Protocols? NO// 
"PKG",142,22,1,"PAH",1,1,228,0)
 
"PKG",142,22,1,"PAH",1,1,229,0)
    <Provide the installer with guidance on whether or not to disable 
"PKG",142,22,1,"PAH",1,1,230,0)
    scheduled Options, menu options, and protocols.>
"PKG",142,22,1,"PAH",1,1,231,0)
 
"PKG",142,22,1,"PAH",1,1,232,0)
8.  If prompted "Delay Install (Minutes):  (0 - 60): 0// respond 0.
"PKG",142,22,1,"PAH",1,1,233,0)
 
"PKG",142,22,1,"PAH",1,1,234,0)
 
"PKG",142,22,1,"PAH",1,1,235,0)
Post-Installation Instructions
"PKG",142,22,1,"PAH",1,1,236,0)
------------------------------
"PKG",142,22,1,"PAH",1,1,237,0)
 
"PKG",142,22,1,"PAH",1,1,238,0)
<Provide a brief description of what the pre-installation will be doing. 
"PKG",142,22,1,"PAH",1,1,239,0)
List pre-installation instructions (i.e., links, filers, or batch
"PKG",142,22,1,"PAH",1,1,240,0)
transmissions that need to be stopped, jobs unscheduled, etc.), if
"PKG",142,22,1,"PAH",1,1,241,0)
applicable.>
"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")
8
"RTN","PRCAAPR1")
0^7^B43589285
"RTN","PRCAAPR1",1,0)
PRCAAPR1 ;WASH-ISC@ALTOONA,PA/RGY - PATIENT ACCOUNT PROFILE ;2/12/97  11:48 AM
"RTN","PRCAAPR1",2,0)
 ;;4.5;Accounts Receivable;**34,45,108,143,141,206,192,218,276,275**;Mar 20, 1995;Build 72
"RTN","PRCAAPR1",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","PRCAAPR1",4,0)
HDR ;Head for Account profile
"RTN","PRCAAPR1",5,0)
 S X="",$P(X,"=",23)="" W @IOF,!,X,"   A c c o u n t   P r o f i l e   ",X
"RTN","PRCAAPR1",6,0)
HDR1 N DMC,IBRX,RSN,TOP4,TOP6,DPTFLG,ACCTNUM,RCCV
"RTN","PRCAAPR1",7,0)
 S IBRX=0,DPTFLG=0
"RTN","PRCAAPR1",8,0)
 ;
"RTN","PRCAAPR1",9,0)
 ;Display new 'Statement Account Number" (Patch 206)
"RTN","PRCAAPR1",10,0)
 I PRCADB["DPT(" S DPTFLG=1,ACCTNUM=$$ACCT(PRCADB)
"RTN","PRCAAPR1",11,0)
 ;
"RTN","PRCAAPR1",12,0)
 W !,$P(DEBT,"^",2) I DPTFLG!(PRCADB["VA(200,") S X=$S(PRCADB["DPT(":$P(^DPT(+PRCADB,0),"^",9),1:$P($G(^VA(200,+PRCADB,1)),"^",9)) W " (",$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9),")"
"RTN","PRCAAPR1",13,0)
 W ?53,"Statement Day: ",$S($$PST^RCAMFN01(+DEBT)>0:$$PST^RCAMFN01(+DEBT),1:"N/A")
"RTN","PRCAAPR1",14,0)
 K Y S X("ADD")=$$DADD^RCAMADD(PRCADB)
"RTN","PRCAAPR1",15,0)
 ;
"RTN","PRCAAPR1",16,0)
 ;Display new 'Statement Account Number" (Patch 206)
"RTN","PRCAAPR1",17,0)
 I DPTFLG W !,"Statement Account #: ",ACCTNUM,?52,"Last Statement: "
"RTN","PRCAAPR1",18,0)
 E  W !?52,"Last Statement: "
"RTN","PRCAAPR1",19,0)
 ;
"RTN","PRCAAPR1",20,0)
 S Y=+$$LST^RCFN01(PRCADB,2)
"RTN","PRCAAPR1",21,0)
 I Y>0 S Y("CCPC")=$$FPS^RCCPCFN(+DEBT) S:Y("CCPC") Y=+$P(Y("CCPC"),"^")
"RTN","PRCAAPR1",22,0)
 W $S(Y=-1:"N/A",1:$$SLH^RCFN01(Y))
"RTN","PRCAAPR1",23,0)
 W !,$P(X("ADD"),"^")
"RTN","PRCAAPR1",24,0)
 W:+$G(Y("CCPC")) ?52,"Activity as of: ",$$SLH^RCFN01($$ASOF^RCCPCFN($P(Y("CCPC"),"^",2)))
"RTN","PRCAAPR1",25,0)
 W:$P(X("ADD"),"^",2)]"" !,$P(X("ADD"),"^",2) W:$P(X("ADD"),"^",3)]"" !,$P(X("ADD"),"^",3)
"RTN","PRCAAPR1",26,0)
 W ! W:$P(X("ADD"),"^",4)]"" $P(X("ADD"),"^",4),", ",$P(X("ADD"),"^",5),"  ",$S($P(X("ADD"),"^",6):$P(X("ADD"),"^",6),1:$P(X("ADD"),"^",8))
"RTN","PRCAAPR1",27,0)
 W ?55,"Amount Owed: ",?69,$J(+$G(^TMP("PRCAAPR",$J,"C")),9,2)
"RTN","PRCAAPR1",28,0)
 W !,"Phone #: ",$S($P(X("ADD"),"^",7)]"":$P(X("ADD"),"^",7),1:"N/A")
"RTN","PRCAAPR1",29,0)
 I PRCADB["DPT(" W ?51,"RX Copay Exempt: " S IBRX=$$RXST^IBARXEU(+PRCADB,DT) W $S($P(IBRX,U)=1:"YES",$P(IBRX,U)=0:"NO",1:"N/A")
"RTN","PRCAAPR1",30,0)
 I PRCADB["DPT(" W !?57,"CV Status: " S RCCV=$$CVEDT^DGCV(+PRCADB,DT) W $S($P(RCCV,U,3)>0:"YES",1:"NO") I $P(RCCV,U,2) W !?52,"CV Status Ends: ",$$SLH^RCFN01($P(RCCV,U,2))
"RTN","PRCAAPR1",31,0)
 ; *108 add exemption reason/dmc info
"RTN","PRCAAPR1",32,0)
 I IBRX>0,($P(IBRX,U)=1) S DIC="^IBE(354.2,",DIC(0)="M",X=+$P(IBRX,"^",3) D ^DIC I Y>0 W !,?54,"(",$P(Y,"^",2),")"
"RTN","PRCAAPR1",33,0)
 I $D(^RCD(340,"DMC",1,+DEBT)) S DMC=$G(^RCD(340,+DEBT,3)) D
"RTN","PRCAAPR1",34,0)
 .I $P(DMC,"^",2) W !,"** Account forwarded to DMC: ",$$SLH^RCFN01($P(DMC,"^",2)),?50,"Total DMC Amount: ",?69,$J($P(DMC,"^",5),9,2)
"RTN","PRCAAPR1",35,0)
 .I $P(DMC,"^",9)'="" W !,?49,"Lesser Amt to DMC: ",?69,$J($P(DMC,"^",9),9,2)
"RTN","PRCAAPR1",36,0)
 .Q
"RTN","PRCAAPR1",37,0)
 I $D(^RCD(340,"TOP",+DEBT)) S TOP4=$G(^RCD(340,+DEBT,4)),TOP6=$G(^(6)) D
"RTN","PRCAAPR1",38,0)
 .I +TOP6 W !,"** Account forwarded to TOP: ",$$SLH^RCFN01($P(TOP6,"^")),?45,"Total TOP Amount: ",?65,$J($P(TOP4,"^",3),13,2)
"RTN","PRCAAPR1",39,0)
 .I $P(TOP6,"^",6) W !,?45,"TOP HOLD DATE: ",$$SLH^RCFN01($P(TOP6,"^",6))
"RTN","PRCAAPR1",40,0)
 .Q
"RTN","PRCAAPR1",41,0)
 I $O(^RCD(340,+DEBT,2,0)) D
"RTN","PRCAAPR1",42,0)
 .S Y=0 F X=0:0 S X=$O(^RCD(340,+DEBT,2,X)) Q:'X  W:'Y ! W !,$G(^(X,0)) S Y=Y+1 W:Y=3&$O(^RCD(340,+DEBT,2,X)) "..." Q:Y=3
"RTN","PRCAAPR1",43,0)
 .Q
"RTN","PRCAAPR1",44,0)
 Q
"RTN","PRCAAPR1",45,0)
 ; PRCA*4.5*276 - moved headers right to add EOB indicator to bill #, adjusted at tag BLN accordingly
"RTN","PRCAAPR1",46,0)
 ; PRCA*4.5*275 - moved headers to line up with column changes.
"RTN","PRCAAPR1",47,0)
HDR2 W !!,"#",?5,"Bill #",?20,"Est",?31,"Type",?43,"Paid",?52,"Prin",?58,"Int",?64,"Adm",?72,"Balance"
"RTN","PRCAAPR1",48,0)
 Q
"RTN","PRCAAPR1",49,0)
DIS ;Display bill line items
"RTN","PRCAAPR1",50,0)
 NEW STAT1
"RTN","PRCAAPR1",51,0)
 I '$O(^TMP("PRCAAPR",$J,"C",0)) S X="",$P(X,"*",22)="" W !!,X,"  NO ACCOUNT INFORMATION AVAILABLE  ",X G Q1
"RTN","PRCAAPR1",52,0)
 F STAT1=0:0 S STAT1=$O(^TMP("PRCAAPR",$J,"C",STAT1)) Q:'STAT1!$D(OUT)  D BHDR S BILL=0 F  S BILL=$O(^TMP("PRCAAPR",$J,"C",STAT1,BILL)) Q:BILL=""!$D(OUT)  D BLN
"RTN","PRCAAPR1",53,0)
 I '$D(OUT) D READ
"RTN","PRCAAPR1",54,0)
Q1 Q
"RTN","PRCAAPR1",55,0)
BHDR ;Display status line
"RTN","PRCAAPR1",56,0)
 S X=$S(+$P(^TMP("PRCAAPR",$J,"C",STAT1),"^",2)=99:"PAYMENTS",1:$P($G(^PRCA(430.3,+$O(^PRCA(430.3,"AC",+$P(^TMP("PRCAAPR",$J,"C",STAT1),"^",2),0)),0)),"^"))
"RTN","PRCAAPR1",57,0)
 S Y=" "_X_" ("_$J(+^TMP("PRCAAPR",$J,"C",STAT1),0,2)_") " W ! F X=1:1:80-$L(Y)/2 W "-"
"RTN","PRCAAPR1",58,0)
 W Y F X=1:1:IOM-$X-1 W "-"
"RTN","PRCAAPR1",59,0)
 Q
"RTN","PRCAAPR1",60,0)
BLN ;
"RTN","PRCAAPR1",61,0)
 N PRCOUT
"RTN","PRCAAPR1",62,0)
 I $Y+5>IOSL,COUNT D READ G:$D(OUT) Q2 D HDR,HDR2,BHDR
"RTN","PRCAAPR1",63,0)
 ; PRCA*4.5*276, attach EOB indicator '%' to bill # when applicable
"RTN","PRCAAPR1",64,0)
 S PRCOUT=$$COMP3^PRCAAPR(BILL)
"RTN","PRCAAPR1",65,0)
 I STAT1'=99,PRCOUT'="%" S PRCOUT=$$IBEEOBCK(BILL)
"RTN","PRCAAPR1",66,0)
 S:STAT1'=99 COUNT=COUNT+1,^TMP("PRCAAPR",$J,"O",COUNT)=BILL S X=$S(STAT1=99:BILL,1:$G(PRCOUT)_$G(^PRCA(430,BILL,0)))
"RTN","PRCAAPR1",67,0)
 W !,$S(STAT1'=99:COUNT,1:"*"),?4,$P(X,"^") W:STAT1'=99 ?20,$$SLH^RCFN01($P(X,"^",10))
"RTN","PRCAAPR1",68,0)
 W:STAT1'=99 ?31,$S($P(X,"^",2)=31:"TRIC PT",1:$E($P($G(^PRCA(430.2,$S($O(^PRCA(430.2,"AC",24,0))=$P(X,"^",2):+$P(X,"^",16),1:+$P(X,"^",2)),0)),"^"),1,7))  ; PRCA*4.5*192 changed CHMP PT to TRIC PT
"RTN","PRCAAPR1",69,0)
 W:STAT1=99 ?31,"PAYMENT"
"RTN","PRCAAPR1",70,0)
 S X=$S(STAT1=99:"^^^^^^"_^TMP("PRCAAPR",$J,"C",STAT1,BILL),1:$G(^PRCA(430,BILL,7))) W ?39 W:STAT1=99 "-" W $J($P(X,"^",7)+$P(X,"^",8)+$P(X,"^",9)+$P(X,"^",10)+$P(X,"^",11),8,2)
"RTN","PRCAAPR1",71,0)
 W ?48 W:STAT1=99 " " W:STAT1'=99 $S($P(^PRCA(430,BILL,0),"^",2)=$O(^PRCA(430.2,"AC",33,0)):"-",1:" ")
"RTN","PRCAAPR1",72,0)
 W $J($P(X,"^"),7,2),?57,$J($P(X,"^",2),5,2),?63,$J($P(X,"^",3),5,2),?69,$S(STAT1=99:"-",$P(^PRCA(430,BILL,0),"^",2)=$O(^PRCA(430.2,"AC",33,0)):"-",1:" ")
"RTN","PRCAAPR1",73,0)
 W $S(STAT1=99:$J(^TMP("PRCAAPR",$J,"C",STAT1,BILL),9,2),1:$J($P(X,"^")+$P(X,"^",2)+$P(X,"^",3)+$P(X,"^",4)+$P(X,"^",5),9,2))
"RTN","PRCAAPR1",74,0)
 K ^TMP("PRCAAPR",$J,"C",STAT1,BILL) K:$O(^TMP("PRCAAPR",$J,"C",STAT1,""))="" ^TMP("PRCAAPR",$J,"C",STAT1)
"RTN","PRCAAPR1",75,0)
Q2 Q
"RTN","PRCAAPR1",76,0)
READ ;Read bill number
"RTN","PRCAAPR1",77,0)
 W !!,"Select 1-",COUNT W:$O(^TMP("PRCAAPR",$J,"C","")) " or return to continue" R ": ",X:DTIME I X["^"!'$T S:'$T DTOUT=1 S OUT=1 G Q3
"RTN","PRCAAPR1",78,0)
 I X["?" W !!,"To see detailed information for a bill number, enter the corresponding '#'",!,"next to the bill.  (Ex: 1 or 1,3)" G READ
"RTN","PRCAAPR1",79,0)
 I X="",'$O(^TMP("PRCAAPR",$J,"C","")) S OUT=1 G Q3
"RTN","PRCAAPR1",80,0)
 G:X="" Q3 S SEL=X
"RTN","PRCAAPR1",81,0)
 F X=1:1:$L(SEL,",") S Y=$P(SEL,",",X) I Y'?1N.N!'$D(^TMP("PRCAAPR",$J,"O",+Y)) W *7," ??" G READ
"RTN","PRCAAPR1",82,0)
 S OUT=1 F X=1:1:$L(SEL,",") S Y=$P(SEL,",",X) D EN1^PRCAATR($G(^TMP("PRCAAPR",$J,"O",+Y)))
"RTN","PRCAAPR1",83,0)
Q3 Q
"RTN","PRCAAPR1",84,0)
 ;
"RTN","PRCAAPR1",85,0)
ACCT(DFN) ;Get account number. Join station with DFN (Patch 206)
"RTN","PRCAAPR1",86,0)
 N SITE,ACCT,ACCT1,LEN
"RTN","PRCAAPR1",87,0)
 S DFN=+DFN
"RTN","PRCAAPR1",88,0)
 S LEN=$L(DFN)-1
"RTN","PRCAAPR1",89,0)
 S SITE=$$SITE^RCMSITE                          ;station number
"RTN","PRCAAPR1",90,0)
 S ACCT=$$RJ^XLFSTR(DFN,13,0)                   ;add leading zeroes
"RTN","PRCAAPR1",91,0)
 S ACCT1=SITE_"-"_$E(ACCT,1,$L(ACCT)-$L(DFN))   ;add hyphen
"RTN","PRCAAPR1",92,0)
 S ACCT1=ACCT1_"-"_$E(ACCT,$L(ACCT)-LEN,99)     ;add hyphen
"RTN","PRCAAPR1",93,0)
 S ACCT1=ACCT1_"-"_$E($P($P(DEBT,U,2),","),1,5) ;add last name
"RTN","PRCAAPR1",94,0)
 Q ACCT1
"RTN","PRCAAPR1",95,0)
 ;
"RTN","PRCAAPR1",96,0)
 ; PRCA*4.5*276 -  Use Event Date to find an associated 3rd Party bill with an associated EEOB
"RTN","PRCAAPR1",97,0)
IBEEOBCK(PRCAAR) ; Passed AR Bill
"RTN","PRCAAPR1",98,0)
 ; Function will quit as soon as a 3rd party bill is located that has an associated EEOB
"RTN","PRCAAPR1",99,0)
 ;
"RTN","PRCAAPR1",100,0)
 ; Find 3rd Party Bills with an Event Date
"RTN","PRCAAPR1",101,0)
 N PRCAREF,PRCAEEOB,PRCADT,DFN,DBTR,X1
"RTN","PRCAAPR1",102,0)
 ; Get DFN
"RTN","PRCAAPR1",103,0)
 S DBTR=+$P($G(^PRCA(430,PRCAAR,0)),U,9)
"RTN","PRCAAPR1",104,0)
 S X1=$P($G(^RCD(340,DBTR,0)),U) I X1'["DPT" Q ""
"RTN","PRCAAPR1",105,0)
 S DFN=+X1
"RTN","PRCAAPR1",106,0)
 S PRCAEEOB=""
"RTN","PRCAAPR1",107,0)
 ; Loop through Xref of ARbill (#430) to Action file (#350)
"RTN","PRCAAPR1",108,0)
 I +$G(PRCAAR) S PRCAREF=0 F  S PRCAREF=$O(^IB("ABIL",$P($G(^PRCA(430,PRCAAR,0)),"^"),PRCAREF)) Q:'PRCAREF  D  Q:PRCAEEOB="%"
"RTN","PRCAAPR1",109,0)
 . S PRCADT=$P($G(^IB(PRCAREF,0)),"^",17) ;Get event Date
"RTN","PRCAAPR1",110,0)
 . I PRCADT S PRCAEEOB=$$TPEVDT(DFN,PRCADT) Q:PRCAEEOB="%"
"RTN","PRCAAPR1",111,0)
 . I PRCADT S PRCAEEOB=$$TPOPV(DFN,PRCADT)
"RTN","PRCAAPR1",112,0)
 ;
"RTN","PRCAAPR1",113,0)
 Q PRCAEEOB
"RTN","PRCAAPR1",114,0)
 ;
"RTN","PRCAAPR1",115,0)
 ; PRCA*4.5*276 - Traverse all THIRD PARTY bills for a patient with a specific Event Date (399,.03)
"RTN","PRCAAPR1",116,0)
TPEVDT(DFN,EVDT) ;
"RTN","PRCAAPR1",117,0)
 ; Function will quit as soon as a 3rd party bill is located that has an associated EEOB
"RTN","PRCAAPR1",118,0)
 N PRCAIFN,PRCADT,PRCAEEOB
"RTN","PRCAAPR1",119,0)
 S PRCAEEOB=""
"RTN","PRCAAPR1",120,0)
 I +$G(DFN),+$G(EVDT) S PRCADT=(EVDT\1)-.001 F  S PRCADT=$O(^DGCR(399,"D",PRCADT)) Q:'PRCADT!((PRCADT\1)>(EVDT\1))  D  Q:PRCAEEOB="%"
"RTN","PRCAAPR1",121,0)
 . S PRCAIFN=0 F  S PRCAIFN=$O(^DGCR(399,"D",PRCADT,PRCAIFN)) Q:'PRCAIFN  D  Q:PRCAEEOB="%"
"RTN","PRCAAPR1",122,0)
 .. Q:DFN'=$P($G(^DGCR(399,PRCAIFN,0)),U,2)
"RTN","PRCAAPR1",123,0)
 .. ; attach EOB indicator '%' to bill # when applicable
"RTN","PRCAAPR1",124,0)
 .. S PRCAEEOB=$$COMP3^PRCAAPR(PRCAIFN)
"RTN","PRCAAPR1",125,0)
 Q PRCAEEOB
"RTN","PRCAAPR1",126,0)
 ;
"RTN","PRCAAPR1",127,0)
 ; PRCA*4.5*276 - Traverse all THIRD PARTY bills for a patient with any Opt Visit Dates same as Event Date (399,43)
"RTN","PRCAAPR1",128,0)
TPOPV(DFN,EVDT) ;
"RTN","PRCAAPR1",129,0)
 ; Function will quit as soon as a 3rd party bill is located that has an associated EEOB
"RTN","PRCAAPR1",130,0)
 N PRCAIFN,PRCAEEOB
"RTN","PRCAAPR1",131,0)
 S PRCAEEOB=""
"RTN","PRCAAPR1",132,0)
 I +$G(DFN),+$G(EVDT) S PRCAIFN=0 F  S PRCAIFN=$O(^DGCR(399,"AOPV",DFN,EVDT,PRCAIFN)) Q:'PRCAIFN  D  Q:PRCAEEOB="%"
"RTN","PRCAAPR1",133,0)
 . ; attach EOB indicator '%' to bill # when applicable
"RTN","PRCAAPR1",134,0)
 . S PRCAEEOB=$$COMP3^PRCAAPR(PRCAIFN)
"RTN","PRCAAPR1",135,0)
 Q PRCAEEOB
"RTN","PRCAFBD")
0^6^B17368357
"RTN","PRCAFBD",1,0)
PRCAFBD ;WASH-ISC@ALTOONA,PA/CLH-Build FMS Billing Document ;8/2/95  3:14 PM
"RTN","PRCAFBD",2,0)
V ;;4.5;Accounts Receivable;**16,48,86,90,119,165,204,203,173,220,184,270,275**;Mar 20, 1995;Build 72
"RTN","PRCAFBD",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","PRCAFBD",4,0)
EN(BILL,ERR) ;Process NEW BILL to FMS
"RTN","PRCAFBD",5,0)
 N PRCMD
"RTN","PRCAFBD",6,0)
 S ERR=-1,PRCMD=""
"RTN","PRCAFBD",7,0)
 Q:$D(RCONVERT)
"RTN","PRCAFBD",8,0)
 I '$D(^PRCA(430,BILL,11)) S ERR="1^ACCOUNTING INFORMATION MISSING.  CANNOT PROCESS BILL" Q
"RTN","PRCAFBD",9,0)
 ;
"RTN","PRCAFBD",10,0)
 ;  funds 5014 (old), 2431 (old), 528701,03,04,09 and 4032 should not create a BD
"RTN","PRCAFBD",11,0)
 S %=$P($G(^PRCA(430,BILL,11)),"^",17)
"RTN","PRCAFBD",12,0)
 I %=5014!(%=2431)!(%=4032) Q
"RTN","PRCAFBD",13,0)
 I %[5287 Q:$$PTACCT^PRCAACC(%)
"RTN","PRCAFBD",14,0)
 ;
"RTN","PRCAFBD",15,0)
 I '$D(PRCA("SITE")) S PRCA("SITE")=$S($G(BILL):$P($P($G(^PRCA(430,BILL,0)),"^"),"-"),1:$$SITE^RCMSITE)
"RTN","PRCAFBD",16,0)
 K ^TMP("PRCABD",$J)
"RTN","PRCAFBD",17,0)
 I $G(BILL)="" S ERR="1^Missing Bill Number"
"RTN","PRCAFBD",18,0)
 I $D(^PRCA(430,BILL,0)),$P(^(0),U,9)="" S ERR="1^No debtor for bill" Q
"RTN","PRCAFBD",19,0)
 N GECSFMS,REC,REC11,VENCODE,BFY,EFY,LINEFUND,%,%I,%H,X,VEN,CAT,CP,ADDR,AC,RJ,FMSNUM,FMSNUM1,VENDORID,ADD,DA,Y
"RTN","PRCAFBD",20,0)
 D NOW^%DTC
"RTN","PRCAFBD",21,0)
 I '$G(PRCA("AUTO_AUDIT")) W !,"Building FMS Billing Document. Please hold...",!
"RTN","PRCAFBD",22,0)
 S REC=$G(^PRCA(430,BILL,0)),REC11=$G(^PRCA(430,BILL,11)),FMSNUM=$P($P(REC,U),"-")_$P($P(REC,U),"-",2)
"RTN","PRCAFBD",23,0)
 ;gather vendor information
"RTN","PRCAFBD",24,0)
 S VENCODE=$$VENDORID^RCXFMSUV(BILL)
"RTN","PRCAFBD",25,0)
 I VENCODE="UNKNOWN" S ERR="1^Need FMS Vendor ID for BD Document" Q
"RTN","PRCAFBD",26,0)
 I VENCODE="LINK" S ERR="1^Debtor must be linked to vendor file" Q
"RTN","PRCAFBD",27,0)
 S ADD=$$SADD^RCFN01(5)
"RTN","PRCAFBD",28,0)
 I (VENCODE="PERSONOTH")!(VENCODE="XEMPL")!(VENCODE="CUREMPL")!($E(VENCODE,1,4)="CHMP")!($E(VENCODE,1,3)="TRI")!(VENCODE="INELIG") D
"RTN","PRCAFBD",29,0)
  . N I F I=1:1:6 S ADDR(I)=$P(ADD,U,I)
"RTN","PRCAFBD",30,0)
  . I ADDR(6)["-" S ADDR(7)=$P(ADDR(6),"-",2),ADDR(6)=$P(ADDR(6),"-")
"RTN","PRCAFBD",31,0)
  . Q
"RTN","PRCAFBD",32,0)
 ; PRCA*4.5*270 Doc# not unique for corrected claims, remove from file 347 before creating new one to send
"RTN","PRCAFBD",33,0)
 ; PRCA*4.5*275 Don't delete, causes matching issues for FMS between original and new E records.
"RTN","PRCAFBD",34,0)
 ; Assign batch header id instead for unique ID (pass PRCMD=1 for modify flag).
"RTN","PRCAFBD",35,0)
 ;I '$G(REFMS),$$GSTAT^RCFMFN02("BD-"_FMSNUM_" ")>-1 D DEL^RCFMFN02("BD-"_FMSNUM_" ") S PRCMD=1
"RTN","PRCAFBD",36,0)
 N FMSDT S FMSDT=$$FMSDATE^RCBEUTRA(DT)
"RTN","PRCAFBD",37,0)
 ; PRCA*4.5*275 If this is a corrected claim wait 24 hours before sending new E record
"RTN","PRCAFBD",38,0)
 ; to avoid possible collision at FMS if original E record was rejected.
"RTN","PRCAFBD",39,0)
 I '$G(REFMS),$$GSTAT^RCFMFN02("BD-"_FMSNUM_" ")>-1 S FMSDT=$$FMADD^XLFDT(FMSDT,1),PRCMD=1
"RTN","PRCAFBD",40,0)
 S ^TMP("PRCABD",$J,1)="BD2^"_$E(FMSDT,4,5)_U_$E(FMSDT,6,7)_U_$E(FMSDT,2,3)_"^^^^^^E^"_$E(VENCODE,1,9)_U_$E(VENCODE,10,11)_U_$J($P(REC,U,3),0,2)_"^^^^"_$E($G(ADDR(1)),1,30)_U_$E($G(ADDR(2)),1,30)_U_$E($G(ADDR(3)),1,30)
"RTN","PRCAFBD",41,0)
 S ^TMP("PRCABD",$J,1)=^TMP("PRCABD",$J,1)_U_$E($G(ADDR(4)),1,19)_U_$G(ADDR(5))_U_$G(ADDR(6))_U_$G(ADDR(7))_"^N^^^^^^W^~"
"RTN","PRCAFBD",42,0)
 S ^TMP("PRCABD",$J,2)="LIN^~"
"RTN","PRCAFBD",43,0)
 ;accouting information - stored on 11th node file 430
"RTN","PRCAFBD",44,0)
 S ^TMP("PRCABD",$J,3)="BDA^"_$$LINE^RCXFMSC1(BILL)_"^"_$P(REC11,U,15)_U_$P(REC11,U,16)_U_$P(REC11,U,17)_U_$P(REC11,U,8)_U_$P(REC11,U,11)_U_$P(REC11,U,20)_U_$P(REC11,U,6)_U_$P(REC11,U,7)_U_$P(REC11,U,21)_U_$P(REC11,U,5)
"RTN","PRCAFBD",45,0)
 S ^TMP("PRCABD",$J,3)=^TMP("PRCABD",$J,3)_U_$P(REC11,U,12)_U_$P(REC11,U,14)_"^^"_$J($P(REC,U,3),0,2)_"^I^AR_INTERFACE^^^^"
"RTN","PRCAFBD",46,0)
 S ^TMP("PRCABD",$J,3)=^TMP("PRCABD",$J,3)_$P(REC11,U,10)_"^^^^^^^^"_$P(REC11,U,2)_U_$P(REC11,U,3)_"^~"
"RTN","PRCAFBD",47,0)
 I $E($P(REC11,U,17),1,4)=5287 S $P(^TMP("PRCABD",$J,3),U,3)="05"
"RTN","PRCAFBD",48,0)
 ;build control segment  prca*4.5*275 If corrected claim, send modified flag (PRCMD=1) so that batch # is appended to record
"RTN","PRCAFBD",49,0)
 ;D CONTROL^GECSUFMS("A",PRCA("SITE"),FMSNUM,"BD",10,"","","Billing Document")
"RTN","PRCAFBD",50,0)
 D CONTROL^GECSUFMS("A",PRCA("SITE"),FMSNUM,"BD",10,$G(PRCMD),"","Billing Document")
"RTN","PRCAFBD",51,0)
 S FMSNUM1=$P($G(GECSFMS("DOC")),U,3)_"-"_$P($G(GECSFMS("DOC")),U,4)
"RTN","PRCAFBD",52,0)
 ; if corrected record, add batch# PRCA*4.5*275
"RTN","PRCAFBD",53,0)
 S:$G(PRCMD)=1 FMSNUM1=$P($G(GECSFMS("DOC")),U,3)_"-"_$P($G(GECSFMS("DOC")),U,4)_"-"_$P($G(GECSFMS("BAT")),U,3)
"RTN","PRCAFBD",54,0)
 ;build and send document to FTH
"RTN","PRCAFBD",55,0)
 S DA=0 F  S DA=$O(^TMP("PRCABD",$J,DA)) Q:'DA  D SETCS^GECSSTAA(GECSFMS("DA"),^(DA))
"RTN","PRCAFBD",56,0)
 D OPEN^RCFMDRV1(FMSNUM1,6,"B"_BILL,.ENT,.ERR,BILL) I ERR]"" D
"RTN","PRCAFBD",57,0)
 . S ERR=-1
"RTN","PRCAFBD",58,0)
 . N Z S Z="Unable to create an entry in AR Document file."
"RTN","PRCAFBD",59,0)
 . I '$G(PRCA("AUTO_AUDIT")) W !!,Z,! Q
"RTN","PRCAFBD",60,0)
 . D SETERR^PRCAUDT("BILL: "_$$BILL^PRCAUDT(BILL)),SETERR^PRCAUDT(Z)
"RTN","PRCAFBD",61,0)
 D SETCODE^GECSSDCT(GECSFMS("DA"),"D RETN^RCFMFN02")
"RTN","PRCAFBD",62,0)
 D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
"RTN","PRCAFBD",63,0)
 D SSTAT^RCFMFN02(FMSNUM1,1)
"RTN","PRCAFBD",64,0)
 I '$G(PRCA("AUTO_AUDIT")) D
"RTN","PRCAFBD",65,0)
 . S Y=FMSDT D DD^%DT
"RTN","PRCAFBD",66,0)
 . W !!,"FMS document, # ",GECSFMS("DA"),", built and queued for transmission on "_Y,!!
"RTN","PRCAFBD",67,0)
 Q
"RTN","PRCAFBD",68,0)
 ;
"RTN","PRCAFBDM")
0^1^B9939431
"RTN","PRCAFBDM",1,0)
PRCAFBDM ;WASH-ISC@ALTOONA,PA/CLH-Build MODIFIED FMS Billing Document ;9/16/94  12:11 PM
"RTN","PRCAFBDM",2,0)
 ;;4.5;Accounts Receivable;**60,90,204,203,220,270,275**;Mar 20, 1995;Build 72
"RTN","PRCAFBDM",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","PRCAFBDM",4,0)
 ;
"RTN","PRCAFBDM",5,0)
 ; PRCA*4.5*270 add CRD flag to send X record to FMS
"RTN","PRCAFBDM",6,0)
EN(BILL,AMT,ADJTYP,PRCADJD,TN,ERR,CRD) ;Process NEW BILL to FMS
"RTN","PRCAFBDM",7,0)
 ; EN(BILL,AMT,ADJTYP,PRCADJD,TN,ERR) ;Process NEW BILL to FMS
"RTN","PRCAFBDM",8,0)
 Q:$D(RCONVERT)
"RTN","PRCAFBDM",9,0)
 N GECSFMS,REC,FMSNUM,FMSTA
"RTN","PRCAFBDM",10,0)
 K ^TMP("PRCABD",$J)
"RTN","PRCAFBDM",11,0)
 I $G(BILL)="" S ERR="1^Missing Bill Number" Q
"RTN","PRCAFBDM",12,0)
 ;
"RTN","PRCAFBDM",13,0)
 ;  funds 5014 (old), 2431 (old), 528701,03,04,09 and 4032 should not create a BD
"RTN","PRCAFBDM",14,0)
 S %=$P($G(^PRCA(430,BILL,11)),"^",17)
"RTN","PRCAFBDM",15,0)
 I %=5014!(%=2431)!(%=4032) Q
"RTN","PRCAFBDM",16,0)
 I %[5287 Q:$$PTACCT^PRCAACC(%)
"RTN","PRCAFBDM",17,0)
 ;
"RTN","PRCAFBDM",18,0)
 I +PRCADJD<1 S PRCADJD=DT
"RTN","PRCAFBDM",19,0)
 I AMT<0 S AMT=-AMT
"RTN","PRCAFBDM",20,0)
 I '$D(^PRCA(430,BILL,0)) S ERR="1^Unable to locate bill" Q
"RTN","PRCAFBDM",21,0)
 S REC=$G(^PRCA(430,BILL,0)),FMSNUM=$P($P(REC,U),"-")_$P($P(REC,U),"-",2)
"RTN","PRCAFBDM",22,0)
 ; PRCA*4.5*270 if the new CRD function is being performed, don't send the modified BD if the original BD has not yet been sent to FMS
"RTN","PRCAFBDM",23,0)
 ; set REFMS = 1 so that CRD records will transmit immediately (sets hold date to today)
"RTN","PRCAFBDM",24,0)
 I $G(CRD) N RCQ,REFMS S RCQ=0,REFMS=1 D  Q:RCQ
"RTN","PRCAFBDM",25,0)
 .; - BD accepted by FMS - need to cancel (send X record)
"RTN","PRCAFBDM",26,0)
 .S FMSTA=$$GSTAT^RCFMFN02("B"_BILL) Q:FMSTA=2
"RTN","PRCAFBDM",27,0)
 .I FMSTA=1,$E($$STATUS^GECSSGET("BD-"_FMSNUM))="T" Q  ; - BD transmitted to FMS - need to cancel (send X record)
"RTN","PRCAFBDM",28,0)
 .S RCQ=1 ; - set flag to quit, don't send FMS M or X records for CRD if we can still delete the E record
"RTN","PRCAFBDM",29,0)
 .; delete event in #347, delete code sheet (only) from GECS stack
"RTN","PRCAFBDM",30,0)
 .D DEL^RCFMFN02("B"_BILL)
"RTN","PRCAFBDM",31,0)
 W !!,"Creating FMS Modified Billing Document..."
"RTN","PRCAFBDM",32,0)
 N FMSDT S FMSDT=$$FMSDATE^RCBEUTRA(DT)
"RTN","PRCAFBDM",33,0)
 ; PRCA*4.5*275 X record (corrected claim) does not need LIN and BDA section or amount, M still does
"RTN","PRCAFBDM",34,0)
 I $G(CRD)="" D
"RTN","PRCAFBDM",35,0)
 .S ^TMP("PRCABD",$J,1)="BD2^"_$E(FMSDT,4,5)_U_$E(FMSDT,6,7)_U_$E(FMSDT,2,3)_"^^^^^^M^^^"_$J(AMT,0,2)_"^~"
"RTN","PRCAFBDM",36,0)
 .S ^TMP("PRCABD",$J,2)="LIN^~"
"RTN","PRCAFBDM",37,0)
 .S ^TMP("PRCABD",$J,3)="BDA^"_$$LINE^RCXFMSC1(BILL)_"^^^^^^^^^^^^^^"_$J(AMT,0,2)_"^"_$S(ADJTYP=35:"D",ADJTYP=1:"I",1:"")_"^AR_INTERFACE^~"
"RTN","PRCAFBDM",38,0)
 S:$G(CRD)'="" ^TMP("PRCABD",$J,1)="BD2^"_$E(FMSDT,4,5)_U_$E(FMSDT,6,7)_U_$E(FMSDT,2,3)_"^^^^^^X^^^^^~"
"RTN","PRCAFBDM",39,0)
 ;build control segment, indicate whether this is an M or X record
"RTN","PRCAFBDM",40,0)
 ;D CONTROL^GECSUFMS("A",$P(REC,U,12),FMSNUM,"BD",10,"1","","Modified Billing Document")
"RTN","PRCAFBDM",41,0)
 D CONTROL^GECSUFMS("A",$P(REC,U,12),FMSNUM,"BD",10,"1","",$S($G(CRD):"Cancelled",1:"Modified")_" Billing Document")
"RTN","PRCAFBDM",42,0)
 S FMSNUM1=$P($G(GECSFMS("DOC")),U,3)_"-"_$P($G(GECSFMS("DOC")),U,4)_"-"_$P($G(GECSFMS("BAT")),U,3)
"RTN","PRCAFBDM",43,0)
 D OPEN^RCFMDRV1(FMSNUM1,7,"T"_TN,.ENT,.ERR,BILL,TN) I ERR]"" W !!,"Unable to create entry in AR Document File.",! S ERR=-1
"RTN","PRCAFBDM",44,0)
 ;build and send document to FTH
"RTN","PRCAFBDM",45,0)
 S DA=0 F  S DA=$O(^TMP("PRCABD",$J,DA)) Q:'DA  D SETCS^GECSSTAA(GECSFMS("DA"),^(DA))
"RTN","PRCAFBDM",46,0)
 D SETCODE^GECSSDCT(GECSFMS("DA"),"D RETN^RCFMFN02")
"RTN","PRCAFBDM",47,0)
 ; PRCA*4.5*270 if this is a CRD record, mark it for immediate transmission, otherwise put it in the queue
"RTN","PRCAFBDM",48,0)
 ;D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
"RTN","PRCAFBDM",49,0)
 D SETSTAT^GECSSTAA(GECSFMS("DA"),$S($G(CRD):"M",1:"Q"))
"RTN","PRCAFBDM",50,0)
 D SSTAT^RCFMFN02("T"_TN,1)
"RTN","PRCAFBDM",51,0)
 W !,"Document #",GECSFMS("DA")," Created.",!
"RTN","PRCAFBDM",52,0)
 Q
"RTN","PRCAFBDM",53,0)
 ;
"RTN","PRCAMDA1")
0^2^B25439881
"RTN","PRCAMDA1",1,0)
PRCAMDA1 ;ALB/TAZ - PRCA MDA WORKLIST SCREEN ;18-APR-2011
"RTN","PRCAMDA1",2,0)
 ;;4.5;Accounts Receivable;**275**;Mar 20, 1995;Build 72
"RTN","PRCAMDA1",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","PRCAMDA1",4,0)
 ;DBIA #3820
"RTN","PRCAMDA1",5,0)
 ;
"RTN","PRCAMDA1",6,0)
EN ; -- main entry point for MDA Worklist
"RTN","PRCAMDA1",7,0)
 N PRCAEDT,PRCASDT,PRCASORT,PRCAQUIT,PRCASDV
"RTN","PRCAMDA1",8,0)
 N VALMBCK,VALMCNT,VALMHDR,VALMQUIT
"RTN","PRCAMDA1",9,0)
 D EN^VALM("PRCA MDA WORKLIST")
"RTN","PRCAMDA1",10,0)
 Q
"RTN","PRCAMDA1",11,0)
 ;
"RTN","PRCAMDA1",12,0)
HDR ; -- header code
"RTN","PRCAMDA1",13,0)
 S VALMHDR(1)="Part A Inpatient"
"RTN","PRCAMDA1",14,0)
 S VALMHDR(2)=""
"RTN","PRCAMDA1",15,0)
 Q
"RTN","PRCAMDA1",16,0)
 ;
"RTN","PRCAMDA1",17,0)
INIT ; -- init variables and list array
"RTN","PRCAMDA1",18,0)
 N DIC,DIRUT,DIROUT,DTOUT,DUOUT,X,Y,DIR,LN,PRCADIV
"RTN","PRCAMDA1",19,0)
 K ^TMP("PRCAMDA",$J),^TMP($J,"PRCAMDA")
"RTN","PRCAMDA1",20,0)
 S PRCAQUIT=0
"RTN","PRCAMDA1",21,0)
 ;
"RTN","PRCAMDA1",22,0)
 D DIV(.PRCASDV) ;Build list of Divisions (or all divisions)
"RTN","PRCAMDA1",23,0)
 I PRCAQUIT=1 S VALMQUIT="" G INITQ
"RTN","PRCAMDA1",24,0)
 ;
"RTN","PRCAMDA1",25,0)
 D DTR(.PRCASDT,.PRCAEDT) ;Get Worklist Dates
"RTN","PRCAMDA1",26,0)
 I PRCAQUIT=1 S VALMQUIT="" G INITQ
"RTN","PRCAMDA1",27,0)
 ;
"RTN","PRCAMDA1",28,0)
 D SORT(.PRCASORT) ;Get Worklist Sort Direction
"RTN","PRCAMDA1",29,0)
 I PRCAQUIT=1 S VALMQUIT="" G INITQ
"RTN","PRCAMDA1",30,0)
 ;
"RTN","PRCAMDA1",31,0)
 D BLD ;Build Arrays
"RTN","PRCAMDA1",32,0)
 ;
"RTN","PRCAMDA1",33,0)
INITQ ;
"RTN","PRCAMDA1",34,0)
 Q
"RTN","PRCAMDA1",35,0)
 ;
"RTN","PRCAMDA1",36,0)
BLD ; -- Build the Arrays
"RTN","PRCAMDA1",37,0)
 ;Build the DIV array
"RTN","PRCAMDA1",38,0)
 K ^TMP($J,"PRCAMDA","DIV")
"RTN","PRCAMDA1",39,0)
 S PRCAIEN=""
"RTN","PRCAMDA1",40,0)
 F  S PRCAIEN=$O(^PRCA(436.1,"AMDA",1,PRCAIEN),PRCASORT) Q:'PRCAIEN  D
"RTN","PRCAMDA1",41,0)
 . N PRCARDT,PRCAOK
"RTN","PRCAMDA1",42,0)
 . S PRCARDT=$$GET1^DIQ(436.1,PRCAIEN_", ",.1,"I") I PRCARDT>PRCAEDT!(PRCARDT<PRCASDT) Q  ;Not in Date Range
"RTN","PRCAMDA1",43,0)
 . S PRCADIV=$$GET1^DIQ(436.1,PRCAIEN_", ",1.03,"I") I 'PRCADIV S PRCADIV="99999"
"RTN","PRCAMDA1",44,0)
 . I PRCASDV,'$D(^TMP($J,"PRCAMDA","DIV",PRCADIV)) Q  ; Not a selected division
"RTN","PRCAMDA1",45,0)
 . S ^TMP($J,"PRCAMDA","DIV",PRCADIV,PRCAIEN)=""
"RTN","PRCAMDA1",46,0)
 ;
"RTN","PRCAMDA1",47,0)
 ; Build the List Array.
"RTN","PRCAMDA1",48,0)
 S PRCADIV="",(LN,VALMCNT)=0
"RTN","PRCAMDA1",49,0)
 F  S PRCADIV=$O(^TMP($J,"PRCAMDA","DIV",PRCADIV)) Q:'PRCADIV  D
"RTN","PRCAMDA1",50,0)
 . D SET("Division: "_$S(PRCADIV=99999:"Unknown",1:$P(^DG(40.8,PRCADIV,0),U,1)),LN+1)
"RTN","PRCAMDA1",51,0)
 . S PRCAIEN=""
"RTN","PRCAMDA1",52,0)
 . F  S PRCAIEN=$O(^TMP($J,"PRCAMDA","DIV",PRCADIV,PRCAIEN)) Q:'PRCAIEN  D
"RTN","PRCAMDA1",53,0)
 .. N PRCABN,PRCAFN,PRCAPN,PRCARS,LINEVAR
"RTN","PRCAMDA1",54,0)
 .. S PRCABN=$$GET1^DIQ(436.1,PRCAIEN_", ",.01,"I"),PRCAPN="Unknown Patient"
"RTN","PRCAMDA1",55,0)
 .. S PRCAFN=$$GET1^DIQ(436.1,PRCAIEN_", ",1.01,"I") I PRCAFN S PRCAPN=$$GET1^DIQ(399,PRCAFN_", ",.02,"E") ;DBIA #3820
"RTN","PRCAMDA1",56,0)
 .. S PRCARS=$$GET1^DIQ(436.1,PRCAIEN_", ",1.02,"I")=1 ;Only place asterisk on REVIEW IN PROCESS entries.
"RTN","PRCAMDA1",57,0)
 .. S LINEVAR=""
"RTN","PRCAMDA1",58,0)
 .. S LN=LN+1
"RTN","PRCAMDA1",59,0)
 .. S LINEVAR=$$SETFLD^VALM1(LN,LINEVAR,"NUMBER")
"RTN","PRCAMDA1",60,0)
 .. S LINEVAR=$$SETFLD^VALM1(PRCABN,LINEVAR,"BILL")
"RTN","PRCAMDA1",61,0)
 .. I PRCARS S LINEVAR=$$SETSTR^VALM1("*",LINEVAR,15,15)
"RTN","PRCAMDA1",62,0)
 .. S LINEVAR=$$SETFLD^VALM1(PRCAPN,LINEVAR,"PTNAME")
"RTN","PRCAMDA1",63,0)
 .. S LINEVAR=$$SETFLD^VALM1($$GET1^DIQ(436.1,PRCAIEN_", ",.03,"I"),LINEVAR,"SUBID")
"RTN","PRCAMDA1",64,0)
 .. S LINEVAR=$$SETFLD^VALM1(" "_$P($$FMTE^XLFDT($$GET1^DIQ(436.1,PRCAIEN_", ",.08,"I"),"7D"),"/",1),LINEVAR,"SYEAR")
"RTN","PRCAMDA1",65,0)
 .. S LINEVAR=$$SETFLD^VALM1(" "_$P($$FMTE^XLFDT($$GET1^DIQ(436.1,PRCAIEN_", ",.09,"I"),"7D"),"/",1),LINEVAR,"EYEAR")
"RTN","PRCAMDA1",66,0)
 .. S LINEVAR=$$SETFLD^VALM1($J($$GET1^DIQ(436.1,PRCAIEN_", ",.06,"I"),6),LINEVAR,"DEDSUB")
"RTN","PRCAMDA1",67,0)
 .. S LINEVAR=$$SETFLD^VALM1($J($$GET1^DIQ(436.1,PRCAIEN_", ",.07,"I"),6),LINEVAR,"DEDAVL")
"RTN","PRCAMDA1",68,0)
 .. S LINEVAR=$$SETFLD^VALM1($J($$FMTE^XLFDT($$GET1^DIQ(436.1,PRCAIEN_", ",.1,"I"),"2DZ"),8),LINEVAR,"RPTDT")
"RTN","PRCAMDA1",69,0)
 .. D SET(LINEVAR,LN,PRCAIEN)
"RTN","PRCAMDA1",70,0)
BLDQ ;
"RTN","PRCAMDA1",71,0)
 Q
"RTN","PRCAMDA1",72,0)
 ;
"RTN","PRCAMDA1",73,0)
HELP ; -- help code
"RTN","PRCAMDA1",74,0)
 S X="?" D DISP^XQORM1 W !!
"RTN","PRCAMDA1",75,0)
 Q
"RTN","PRCAMDA1",76,0)
 ;
"RTN","PRCAMDA1",77,0)
EXIT ; -- exit code
"RTN","PRCAMDA1",78,0)
 K ^TMP("PRCAMDA",$J),^TMP($J,"PRCAMDA","DIV")
"RTN","PRCAMDA1",79,0)
 D CLEAN^VALM10
"RTN","PRCAMDA1",80,0)
 Q
"RTN","PRCAMDA1",81,0)
 ;
"RTN","PRCAMDA1",82,0)
 ;Output:
"RTN","PRCAMDA1",83,0)
 ;^TMP($J,"PRCAMDA","DIV",<div>) - List of selected divisions
"RTN","PRCAMDA1",84,0)
 ;PRCASDV - Selected division switch - 1 = Divisions selected, 0 = all divisions
"RTN","PRCAMDA1",85,0)
DIV(PRCASDV) ; Get Division
"RTN","PRCAMDA1",86,0)
 N DIC,Y,PRCA1ST
"RTN","PRCAMDA1",87,0)
 K ^TMP($J,"PRCAMDA","DIV")
"RTN","PRCAMDA1",88,0)
 S PRCA1ST=1
"RTN","PRCAMDA1",89,0)
 F  D  Q:(Y<0)!PRCAQUIT
"RTN","PRCAMDA1",90,0)
 . S DIC="^DG(40.8,",DIC(0)="AEQMN",DIC("A")="Select "_$S(PRCA1ST:"",1:" Another ")_"Division: "_$S(PRCA1ST:"All Divisions// ",1:"")
"RTN","PRCAMDA1",91,0)
 . D ^DIC
"RTN","PRCAMDA1",92,0)
 . K DIC
"RTN","PRCAMDA1",93,0)
 . I Y<0 W:PRCA1ST " All Divisions" S PRCASDV=0 Q
"RTN","PRCAMDA1",94,0)
 . I $D(DTOUT)!$D(DUOUT) S PRCAQUIT=1 Q
"RTN","PRCAMDA1",95,0)
 . S ^TMP($J,"PRCAMDA","DIV",+Y)="",PRCA1ST=0
"RTN","PRCAMDA1",96,0)
 ;
"RTN","PRCAMDA1",97,0)
DIVX ;
"RTN","PRCAMDA1",98,0)
 Q
"RTN","PRCAMDA1",99,0)
 ;
"RTN","PRCAMDA1",100,0)
 ;Output:
"RTN","PRCAMDA1",101,0)
 ;PRCASDT - Worklist Earliest Report Date
"RTN","PRCAMDA1",102,0)
 ;PRCAEDT - Worklist Latest Report Date
"RTN","PRCAMDA1",103,0)
 ;
"RTN","PRCAMDA1",104,0)
DTR(PRCASDT,PRCAEDT) ;date range
"RTN","PRCAMDA1",105,0)
 N %DT,DTOUT,DUOUT,X,Y
"RTN","PRCAMDA1",106,0)
 S %DT="AEX"
"RTN","PRCAMDA1",107,0)
 S %DT("A")="Select Earliest Report Date: ",%DT("B")="TODAY-7"
"RTN","PRCAMDA1",108,0)
 W ! D ^%DT ;K %DT
"RTN","PRCAMDA1",109,0)
 I $D(DTOUT)!$D(DUOUT)!(Y<0) S PRCAQUIT=1 G DTRX
"RTN","PRCAMDA1",110,0)
 S PRCASDT=+Y
"RTN","PRCAMDA1",111,0)
 S %DT="AEX"
"RTN","PRCAMDA1",112,0)
 S %DT("A")="Select Latest Report Date: ",%DT("B")="TODAY"
"RTN","PRCAMDA1",113,0)
 D ^%DT ;K %DT
"RTN","PRCAMDA1",114,0)
 I $D(DTOUT)!$D(DUOUT)!(Y<0) S PRCAQUIT=1 G DTRX
"RTN","PRCAMDA1",115,0)
 S PRCAEDT=+Y
"RTN","PRCAMDA1",116,0)
 ;
"RTN","PRCAMDA1",117,0)
DTRX ;
"RTN","PRCAMDA1",118,0)
 Q
"RTN","PRCAMDA1",119,0)
 ;
"RTN","PRCAMDA1",120,0)
 ;Output:
"RTN","PRCAMDA1",121,0)
 ;PRCASORT - Direction of report entries.
"RTN","PRCAMDA1",122,0)
 ;
"RTN","PRCAMDA1",123,0)
SORT(PRCASORT) ;
"RTN","PRCAMDA1",124,0)
 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
"RTN","PRCAMDA1",125,0)
 W !
"RTN","PRCAMDA1",126,0)
 S DIR(0)="SA^1:Earliest Report Date;2:Latest Report Date"
"RTN","PRCAMDA1",127,0)
 S DIR("A")="Sort Report By: "
"RTN","PRCAMDA1",128,0)
 S DIR("B")="Latest Report Date"
"RTN","PRCAMDA1",129,0)
 D ^DIR
"RTN","PRCAMDA1",130,0)
 I $D(DTOUT)!$D(DUOUT)!(Y<0) S PRCAQUIT=1 G SORTX
"RTN","PRCAMDA1",131,0)
 S PRCASORT=$S(Y=2:"-1",1:"+1")
"RTN","PRCAMDA1",132,0)
 ;
"RTN","PRCAMDA1",133,0)
SORTX ;
"RTN","PRCAMDA1",134,0)
 Q
"RTN","PRCAMDA1",135,0)
 ;
"RTN","PRCAMDA1",136,0)
SET(X,CNT,PRCAIEN) ;set up list manager screen array
"RTN","PRCAMDA1",137,0)
 S VALMCNT=VALMCNT+1
"RTN","PRCAMDA1",138,0)
 S ^TMP("PRCAMDA",$J,VALMCNT,0)=X
"RTN","PRCAMDA1",139,0)
 S ^TMP("PRCAMDA",$J,"IDX",VALMCNT,CNT)=""
"RTN","PRCAMDA1",140,0)
 I $G(PRCAIEN),$G(^TMP("PRCAMDA",$J,CNT))="" S ^TMP("PRCAMDA",$J,CNT)=VALMCNT_U_PRCAIEN
"RTN","PRCAMDA1",141,0)
 Q
"RTN","PRCAMDA1",142,0)
 ;
"RTN","PRCAMDA1",143,0)
EXP ; -- expand code to show additional details of the EOB record
"RTN","PRCAMDA1",144,0)
 S VALMBCK="R"
"RTN","PRCAMDA1",145,0)
 Q
"RTN","PRCAMDA1",146,0)
 ;
"RTN","PRCAMDA2")
0^3^B34581746
"RTN","PRCAMDA2",1,0)
PRCAMDA2 ;ALB/TAZ - PRCA MDA MANAGEMENT WORKLIST SCREEN ;26-APR-2011
"RTN","PRCAMDA2",2,0)
 ;;4.5;Accounts Receivable;**275**;Mar 20, 1995;Build 72
"RTN","PRCAMDA2",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","PRCAMDA2",4,0)
 ;
"RTN","PRCAMDA2",5,0)
 ; Need Integration Agreement with IB to call into TPJI.  We are using IB variables to make sure that everything works.
"RTN","PRCAMDA2",6,0)
TPJI ;Third Party joint Inquiry - IA-???
"RTN","PRCAMDA2",7,0)
 N DFN,PRCAIEN,IBIFN,IBNOTPJI
"RTN","PRCAMDA2",8,0)
 D SEL(.PRCADA,1)
"RTN","PRCAMDA2",9,0)
 S PRCAIEN=+$G(PRCADA(+$O(PRCADA(0))))
"RTN","PRCAMDA2",10,0)
 I 'PRCAIEN G TPJIQ
"RTN","PRCAMDA2",11,0)
 S PRCAFN=$P($G(^PRCA(436.1,PRCAIEN,1)),U,1) I PRCAFN S DFN=$P(^PRCA(430,PRCAFN,0),U,7)
"RTN","PRCAMDA2",12,0)
 I '$G(DFN)!'PRCAFN G TPJIQ
"RTN","PRCAMDA2",13,0)
 S IBIFN=PRCAFN,IBNOTPJI=1
"RTN","PRCAMDA2",14,0)
 D EN^VALM("IBJT CLAIM INFO")
"RTN","PRCAMDA2",15,0)
 K:$D(IBFASTXT) IBFASTXT
"RTN","PRCAMDA2",16,0)
TPJIQ S VALMBCK="R"
"RTN","PRCAMDA2",17,0)
 Q
"RTN","PRCAMDA2",18,0)
 ;
"RTN","PRCAMDA2",19,0)
CMNT ; enter MDA comments - entry point from MDA Worklist screen
"RTN","PRCAMDA2",20,0)
 ; we need to select an entry from the list and set PRCAFN
"RTN","PRCAMDA2",21,0)
 N DA,DD,DIC,DIK,DLAYGO,X,Y,PRCADA,PRCAFN,MRAFLG
"RTN","PRCAMDA2",22,0)
 S MRAFLG=1
"RTN","PRCAMDA2",23,0)
 D SEL(.PRCADA,1) S:$O(PRCADA(0)) PRCAIEN=+PRCADA($O(PRCADA(0))) I '$G(PRCAIEN) G CMNTQ
"RTN","PRCAMDA2",24,0)
 D EN^VALM("PRCA MDA COMMENTS")
"RTN","PRCAMDA2",25,0)
 D BLD^PRCAMDA1
"RTN","PRCAMDA2",26,0)
 ;
"RTN","PRCAMDA2",27,0)
CMNTQ ;
"RTN","PRCAMDA2",28,0)
 S VALMBCK="R"
"RTN","PRCAMDA2",29,0)
 Q
"RTN","PRCAMDA2",30,0)
 ;
"RTN","PRCAMDA2",31,0)
SEL(PRCADA,ONE) ; Select entry(s) from list
"RTN","PRCAMDA2",32,0)
 ; PRCADA = array returned if selections made
"RTN","PRCAMDA2",33,0)
 ;    PRCADA(n)=ien of entry selected (file 436.1)
"RTN","PRCAMDA2",34,0)
 ; ONE = if set to 1, only one selection can be made at a time
"RTN","PRCAMDA2",35,0)
 N VALMY
"RTN","PRCAMDA2",36,0)
 K PRCADA
"RTN","PRCAMDA2",37,0)
 D FULL^VALM1
"RTN","PRCAMDA2",38,0)
 D EN^VALM2("",$S('$G(ONE):"",1:"S"))
"RTN","PRCAMDA2",39,0)
 S PRCADA=0 F  S PRCADA=$O(VALMY(PRCADA)) Q:'PRCADA  S PRCADA(PRCADA)=$P($G(^TMP("PRCAMDA",$J,+PRCADA)),U,2,6)
"RTN","PRCAMDA2",40,0)
 Q
"RTN","PRCAMDA2",41,0)
 ;
"RTN","PRCAMDA2",42,0)
STATUS ; change MDA review status
"RTN","PRCAMDA2",43,0)
 N DA,DIE,DR,PRCADA,PRCAFN,SEL
"RTN","PRCAMDA2",44,0)
 D SEL(.PRCADA,1) S:$O(PRCADA(0)) PRCAIEN=+PRCADA($O(PRCADA(0))) G:'$G(PRCAIEN) STATUSX
"RTN","PRCAMDA2",45,0)
 L +^PRCA(436.1,PRCAIEN):3 I '$T W !,*7,"Sorry, another user currently editing this entry." D PAUSE^VALM1 G STATUSX
"RTN","PRCAMDA2",46,0)
 D STATUS1
"RTN","PRCAMDA2",47,0)
STATUSX ;
"RTN","PRCAMDA2",48,0)
 ;update list manager display
"RTN","PRCAMDA2",49,0)
 L -^PRCA(436.1,PRCAIEN)
"RTN","PRCAMDA2",50,0)
 D BLD^PRCAMDA1
"RTN","PRCAMDA2",51,0)
 S VALMBCK="R"
"RTN","PRCAMDA2",52,0)
 Q
"RTN","PRCAMDA2",53,0)
 ;
"RTN","PRCAMDA2",54,0)
STATUS1 ; Entry point from comments section
"RTN","PRCAMDA2",55,0)
 N PRCASTAT,PRCATEXT
"RTN","PRCAMDA2",56,0)
 ; make sure this entry is not locked already
"RTN","PRCAMDA2",57,0)
 ; Prompt for status change
"RTN","PRCAMDA2",58,0)
 W !
"RTN","PRCAMDA2",59,0)
 S DIR(0)="436.1,1.02",DIR("B")="REVIEW IN PROCESS"
"RTN","PRCAMDA2",60,0)
 D ^DIR K DIR
"RTN","PRCAMDA2",61,0)
 I $D(DTOUT)!$D(DUOUT) G STATUS1X
"RTN","PRCAMDA2",62,0)
 M PRCASTAT=Y
"RTN","PRCAMDA2",63,0)
 I PRCASTAT=3 D
"RTN","PRCAMDA2",64,0)
 . W !
"RTN","PRCAMDA2",65,0)
 . S DIR(0)="Y",DIR("A")="Are you sure you want to remove this entry from the worklist",DIR("B")="NO"
"RTN","PRCAMDA2",66,0)
 . D ^DIR K DIR
"RTN","PRCAMDA2",67,0)
 . I $D(DTOUT)!$D(DUOUT)!'Y S PRCASTAT="" Q
"RTN","PRCAMDA2",68,0)
 . ; Enter comment for removal from worklist
"RTN","PRCAMDA2",69,0)
 . S PRCATEXT(1)="Review completed and entry removed from worklist."
"RTN","PRCAMDA2",70,0)
 . S DA(1)=PRCAIEN
"RTN","PRCAMDA2",71,0)
 . K DO S DIC="^PRCA(436.1,"_DA(1)_",2,",DIC(0)="L",X=$$NOW^XLFDT,DLAYGO=436.12
"RTN","PRCAMDA2",72,0)
 . D FILE^DICN
"RTN","PRCAMDA2",73,0)
 . S DA=+Y I DA'>0 Q
"RTN","PRCAMDA2",74,0)
 . D WP^DIE(436.12,DA_","_DA(1)_",",2,,"PRCATEXT")
"RTN","PRCAMDA2",75,0)
 . K DIC
"RTN","PRCAMDA2",76,0)
 I PRCASTAT'="" S DIE=436.1,DA=PRCAIEN,DR="1.02///"_PRCASTAT(0) D ^DIE,CLEAN^DILF
"RTN","PRCAMDA2",77,0)
STATUS1X ;
"RTN","PRCAMDA2",78,0)
 Q
"RTN","PRCAMDA2",79,0)
 ;
"RTN","PRCAMDA2",80,0)
MCOM(PRCABN,PRCALN)  ; MDA (Medicare Deductible Alert) Comments
"RTN","PRCAMDA2",81,0)
 ; INPUTS: IEN for 430
"RTN","PRCAMDA2",82,0)
 ;       : LIST MAN LINE COUNTER (Pass by Reference)
"RTN","PRCAMDA2",83,0)
 ; OUTPUT: VALMAR
"RTN","PRCAMDA2",84,0)
 ; PRCA*4.5*275 BI
"RTN","PRCAMDA2",85,0)
 ; INTEGRATION CONTROL REGISTRATION is contained in DBIA #5696.
"RTN","PRCAMDA2",86,0)
 ;
"RTN","PRCAMDA2",87,0)
 N PRCADATE,PRCAIMDA,PRCAZ,PRCACMLN,PRCACTL,PRCAMCOM
"RTN","PRCAMDA2",88,0)
 S PRCACTL=1
"RTN","PRCAMDA2",89,0)
 S PRCAMCOM(0)=0
"RTN","PRCAMDA2",90,0)
 I '$G(PRCABN) Q
"RTN","PRCAMDA2",91,0)
 S PRCAIMDA=""
"RTN","PRCAMDA2",92,0)
 F  S PRCAIMDA=$O(^PRCA(436.1,"C",PRCABN,PRCAIMDA)) Q:PRCAIMDA=""  D
"RTN","PRCAMDA2",93,0)
 . D MCOM2(PRCAIMDA,.PRCALN,PRCACTL)
"RTN","PRCAMDA2",94,0)
 D:PRCACTL=1 MDACMTS
"RTN","PRCAMDA2",95,0)
 Q
"RTN","PRCAMDA2",96,0)
MCOM2(PRCAIMDA,PRCALN,PRCACTL)  ; MDA (Medicare Deductible Alert) Comments
"RTN","PRCAMDA2",97,0)
 ; INPUTS: IEN for 436.1
"RTN","PRCAMDA2",98,0)
 ;       : LIST MAN LINE COUNTER (Pass by Reference)
"RTN","PRCAMDA2",99,0)
 ; OUTPUT: VALMAR
"RTN","PRCAMDA2",100,0)
 ; PRCA*4.5*275 BI
"RTN","PRCAMDA2",101,0)
 ;
"RTN","PRCAMDA2",102,0)
 S PRCACTL=$G(PRCACTL,0)
"RTN","PRCAMDA2",103,0)
 I PRCACTL=0 N PRCACMLN,PRCADATE,PRCAZ,PRCAMCOM S PRCAMCOM(0)=0
"RTN","PRCAMDA2",104,0)
 I 'PRCAIMDA Q
"RTN","PRCAMDA2",105,0)
 I $D(^PRCA(436.1,PRCAIMDA,2))'>1 Q
"RTN","PRCAMDA2",106,0)
 ; Loop through all available MDA comments.
"RTN","PRCAMDA2",107,0)
 S PRCADATE="" F  S PRCADATE=$O(^PRCA(436.1,PRCAIMDA,2,"B",PRCADATE),-1) Q:PRCADATE=""  D
"RTN","PRCAMDA2",108,0)
 . S PRCAMCOM(0)=PRCAMCOM(0)+1
"RTN","PRCAMDA2",109,0)
 . S PRCAZ=$O(^PRCA(436.1,PRCAIMDA,2,"B",PRCADATE,""))
"RTN","PRCAMDA2",110,0)
 . S PRCAIMDA(0)=$G(^PRCA(436.1,PRCAIMDA,2,PRCAZ,0))
"RTN","PRCAMDA2",111,0)
 . S PRCAIMDA(0,0)=$G(^PRCA(436.1,PRCAIMDA,2,PRCAZ,1,0))
"RTN","PRCAMDA2",112,0)
 . S PRCAMCOM(PRCAMCOM(0))=$$GET1^DIQ(200,$P(PRCAIMDA(0),U,2),.01)_U
"RTN","PRCAMDA2",113,0)
 . S PRCAMCOM(PRCAMCOM(0))=PRCAMCOM(PRCAMCOM(0))_$$FMTE^XLFDT(PRCADATE,"2Z")_U
"RTN","PRCAMDA2",114,0)
 . S PRCAMCOM(PRCAMCOM(0))=PRCAMCOM(PRCAMCOM(0))_$$FMTE^XLFDT($P(PRCAIMDA(0),U,3),"2Z")
"RTN","PRCAMDA2",115,0)
 . ; Loop through the comment lines.
"RTN","PRCAMDA2",116,0)
 . S PRCAMCOM(PRCAMCOM(0),0)=$P(PRCAIMDA(0,0),U,4)
"RTN","PRCAMDA2",117,0)
 . F PRCACMLN=1:1:PRCAMCOM(PRCAMCOM(0),0) D
"RTN","PRCAMDA2",118,0)
 .. S PRCAMCOM(PRCAMCOM(0),PRCACMLN)=^PRCA(436.1,PRCAIMDA,2,PRCAZ,1,PRCACMLN,0)
"RTN","PRCAMDA2",119,0)
 I PRCACTL=0 D MDACMTS
"RTN","PRCAMDA2",120,0)
 Q
"RTN","PRCAMDA2",121,0)
 ;
"RTN","PRCAMDA2",122,0)
MDACMTS ; Check for MDA comments, Load for List Manager Screen IB*2.0*447 BI
"RTN","PRCAMDA2",123,0)
 ; Input:  VALMAR
"RTN","PRCAMDA2",124,0)
 ;         PRCALN
"RTN","PRCAMDA2",125,0)
 ; Output: @VALMAR Array
"RTN","PRCAMDA2",126,0)
 ;
"RTN","PRCAMDA2",127,0)
 N PRCASTR,PRCACCNT,PRCAK
"RTN","PRCAMDA2",128,0)
 N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,%,I,X,Z
"RTN","PRCAMDA2",129,0)
 I PRCAMCOM(0)=0 Q
"RTN","PRCAMDA2",130,0)
 ;
"RTN","PRCAMDA2",131,0)
 ; Set up the header for the MDA comments section.
"RTN","PRCAMDA2",132,0)
 S PRCALN=PRCALN+1 D SET^VALM10(PRCALN,"")
"RTN","PRCAMDA2",133,0)
 S PRCASTR=""
"RTN","PRCAMDA2",134,0)
 S PRCASTR=$$SETSTR^VALM1("MEDICARE DEDUCTIBLE ALERT WORKLIST COMMENTS",PRCASTR,25,54)
"RTN","PRCAMDA2",135,0)
 S PRCALN=PRCALN+1 D SET^VALM10(PRCALN,PRCASTR)
"RTN","PRCAMDA2",136,0)
 S PRCASTR=""
"RTN","PRCAMDA2",137,0)
 S PRCASTR=$$SETSTR^VALM1("-------------------------------------------",PRCASTR,25,54)
"RTN","PRCAMDA2",138,0)
 S PRCALN=PRCALN+1 D SET^VALM10(PRCALN,PRCASTR)
"RTN","PRCAMDA2",139,0)
 ;
"RTN","PRCAMDA2",140,0)
 ; Loop through all available MDA comments.
"RTN","PRCAMDA2",141,0)
 F PRCACCNT=1:1:PRCAMCOM(0) D
"RTN","PRCAMDA2",142,0)
 . S PRCASTR=""
"RTN","PRCAMDA2",143,0)
 . S PRCASTR=$$SETSTR^VALM1($P(PRCAMCOM(PRCACCNT),U,2),PRCASTR,14,8)
"RTN","PRCAMDA2",144,0)
 . S PRCASTR=$$SETSTR^VALM1($J("Entered by "_$P(PRCAMCOM(PRCACCNT),U,1),54),PRCASTR,25,54)
"RTN","PRCAMDA2",145,0)
 . S PRCALN=PRCALN+1 D SET^VALM10(PRCALN,PRCASTR)
"RTN","PRCAMDA2",146,0)
 . K ^UTILITY($J)
"RTN","PRCAMDA2",147,0)
 . F PRCACMLN=1:1:PRCAMCOM(PRCACCNT,0) D
"RTN","PRCAMDA2",148,0)
 .. S X=PRCAMCOM(PRCACCNT,PRCACMLN) I X'="" S DIWL=1,DIWR=54,DIWF=""  D ^DIWP
"RTN","PRCAMDA2",149,0)
 . I $D(^UTILITY($J,"W")) S PRCAK=0 F  S PRCAK=$O(^UTILITY($J,"W",1,PRCAK)) Q:'PRCAK  D
"RTN","PRCAMDA2",150,0)
 .. S PRCASTR=""
"RTN","PRCAMDA2",151,0)
 .. S PRCASTR=$$SETSTR^VALM1($G(^UTILITY($J,"W",1,PRCAK,0)),PRCASTR,25,54)
"RTN","PRCAMDA2",152,0)
 .. S PRCALN=PRCALN+1 D SET^VALM10(PRCALN,PRCASTR)
"RTN","PRCAMDA2",153,0)
 . I $P(PRCAMCOM(PRCACCNT),U,3)'="" D
"RTN","PRCAMDA2",154,0)
 .. S PRCASTR=""
"RTN","PRCAMDA2",155,0)
 .. S PRCASTR=$$SETSTR^VALM1("Follow Up Date: "_$P(PRCAMCOM(PRCACCNT),U,3),PRCASTR,14,24)
"RTN","PRCAMDA2",156,0)
 .. S PRCALN=PRCALN+1 D SET^VALM10(PRCALN,PRCASTR)
"RTN","PRCAMDA2",157,0)
 . S PRCALN=PRCALN+1 D SET^VALM10(PRCALN,"")
"RTN","PRCAMDA2",158,0)
 . K ^UTILITY($J,"W")
"RTN","PRCAMDA2",159,0)
 Q
"RTN","PRCAMDA3")
0^4^B5974782
"RTN","PRCAMDA3",1,0)
PRCAMDA3 ;ALB/TAZ - PRCA MDA MANAGEMENT WORKLIST SCREEN ;26-APR-2011
"RTN","PRCAMDA3",2,0)
 ;;4.5;Accounts Receivable;**275**;Mar 20, 1995;Build 72
"RTN","PRCAMDA3",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","PRCAMDA3",4,0)
 ;;DBIA #5713 
"RTN","PRCAMDA3",5,0)
 ;
"RTN","PRCAMDA3",6,0)
EN ; -- main entry point for PRCA MDA COMMENTS
"RTN","PRCAMDA3",7,0)
 N VALMAR
"RTN","PRCAMDA3",8,0)
 D EN^VALM("PRCA MDA COMMENTS")
"RTN","PRCAMDA3",9,0)
 Q
"RTN","PRCAMDA3",10,0)
 ;
"RTN","PRCAMDA3",11,0)
HDR ; -- header code
"RTN","PRCAMDA3",12,0)
 N PRCACL
"RTN","PRCAMDA3",13,0)
 S PRCACL=$P(^PRCA(436.1,PRCAIEN,0),U,1)
"RTN","PRCAMDA3",14,0)
 I PRCAFN S PRCACL=$P(^PRCA(430,PRCAFN,0),U,1)
"RTN","PRCAMDA3",15,0)
 S VALMHDR(1)="Claim Comment History"
"RTN","PRCAMDA3",16,0)
 S VALMHDR(2)="MDA Claim "_PRCACL
"RTN","PRCAMDA3",17,0)
 Q
"RTN","PRCAMDA3",18,0)
 ;
"RTN","PRCAMDA3",19,0)
INIT ; -- init variables and list array
"RTN","PRCAMDA3",20,0)
 N PRCACNT
"RTN","PRCAMDA3",21,0)
 K ^TMP("PRCAMDAC",$J),@VALMAR
"RTN","PRCAMDA3",22,0)
 S PRCAFN=$P(^PRCA(436.1,PRCAIEN,1),U,1)
"RTN","PRCAMDA3",23,0)
 ;Remove the I $T(^IBJUT6)'="" in the following line after IB*2.0*452 is released since 
"RTN","PRCAMDA3",24,0)
 ; IBJTU6 is part of that patch and may be released after the release of PRCA*4.5*275
"RTN","PRCAMDA3",25,0)
 I $T(^IBJTU6)'="" I PRCAFN D IBDSP^IBJTU6(3,PRCAFN,,,VALMAR) G INITQ ;#DBIA #5713
"RTN","PRCAMDA3",26,0)
 S PRCACNT=0 D MCOM2^PRCAMDA2(PRCAIEN,.PRCACNT)
"RTN","PRCAMDA3",27,0)
INITQ ;
"RTN","PRCAMDA3",28,0)
 I '$D(@VALMAR) D SET^VALM10(1,""),SET^VALM10(2,"No Comment Transactions Exist For This Account.")
"RTN","PRCAMDA3",29,0)
 S VALMBCK="R"
"RTN","PRCAMDA3",30,0)
 Q
"RTN","PRCAMDA3",31,0)
 ;
"RTN","PRCAMDA3",32,0)
HELP ; -- help code
"RTN","PRCAMDA3",33,0)
 S X="?" D DISP^XQORM1 W !!
"RTN","PRCAMDA3",34,0)
 Q
"RTN","PRCAMDA3",35,0)
 ;
"RTN","PRCAMDA3",36,0)
EXIT ; -- exit code
"RTN","PRCAMDA3",37,0)
 K ^TMP("PRCAMDC",$J)
"RTN","PRCAMDA3",38,0)
 Q
"RTN","PRCAMDA3",39,0)
 ;
"RTN","PRCAMDA3",40,0)
EXPND ; -- expand code
"RTN","PRCAMDA3",41,0)
 Q
"RTN","PRCAMDA3",42,0)
 ;
"RTN","PRCAMDA3",43,0)
CMNT ; Enter MDA Comments.  This is called from the PRCA MDA ENTER COMMENT protocol.
"RTN","PRCAMDA3",44,0)
 N DA,DD,DIC,DIK,DLAYGO,X,Y
"RTN","PRCAMDA3",45,0)
 W !
"RTN","PRCAMDA3",46,0)
 ; make sure this entry is not locked already
"RTN","PRCAMDA3",47,0)
 L +^PRCA(436.1,PRCAFN):3 I '$T W !,*7,"Sorry, another user currently editing this entry." D PAUSE^VALM1 G CMNTQ
"RTN","PRCAMDA3",48,0)
 S DA(1)=PRCAIEN
"RTN","PRCAMDA3",49,0)
 K DO S DIC="^PRCA(436.1,"_DA(1)_",2,",DIC(0)="L",DIC("DR")="2;.03",X=$$NOW^XLFDT,DLAYGO=436.12
"RTN","PRCAMDA3",50,0)
 D FILE^DICN
"RTN","PRCAMDA3",51,0)
 S DA=+Y I DA>0 D
"RTN","PRCAMDA3",52,0)
 . ;Make sure a comment or followup date was created.  Otherwise delete the entry.
"RTN","PRCAMDA3",53,0)
 . I '$D(^PRCA(436.1,DA(1),2,DA,1)),$P($G(^PRCA(436.1,DA(1),2,DA,0)),U,3)=""  S DIK=DIC D ^DIK Q
"RTN","PRCAMDA3",54,0)
 . ;There is a comment or follow up date so ask status prompt
"RTN","PRCAMDA3",55,0)
 . K DIC
"RTN","PRCAMDA3",56,0)
 . D STATUS1^PRCAMDA2
"RTN","PRCAMDA3",57,0)
 L -^PRCA(436.1,PRCAFN)
"RTN","PRCAMDA3",58,0)
CMNTQ ;
"RTN","PRCAMDA3",59,0)
 S VALMBCK="R"
"RTN","PRCAMDA3",60,0)
 D INIT
"RTN","PRCAMDA3",61,0)
 Q
"RTN","PRCAMDA3",62,0)
 ;
"RTN","PRCAMDS")
0^5^B11777483
"RTN","PRCAMDS",1,0)
PRCAMDS ;ALB/WCJ - Server interface to AR from Austin ;04/11/2011
"RTN","PRCAMDS",2,0)
 ;;4.5;Accounts Receivable;**275**;Mar 20, 1995;Build 72
"RTN","PRCAMDS",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","PRCAMDS",4,0)
 ;
"RTN","PRCAMDS",5,0)
 ; patterned off RCDPESRV
"RTN","PRCAMDS",6,0)
 ;
"RTN","PRCAMDS",7,0)
SERVER ; Entry point for server option to process MDA msgs received from Austin
"RTN","PRCAMDS",8,0)
 ; Mail messages to the MDA mail group should trigger server option PRCA MDA SERVER
"RTN","PRCAMDS",9,0)
 ;
"RTN","PRCAMDS",10,0)
 N PRCAEFLG,PRCAERR,XMER,PRCAXMZ,PRCAFROM
"RTN","PRCAMDS",11,0)
 ;
"RTN","PRCAMDS",12,0)
 ; save the message number into an AR variable
"RTN","PRCAMDS",13,0)
 S PRCAXMZ=$G(XMZ)
"RTN","PRCAMDS",14,0)
 ;
"RTN","PRCAMDS",15,0)
 ; Test to determine if the email came from AUSTIN for production systems(DBIA 1143).
"RTN","PRCAMDS",16,0)
 S PRCAFROM=$P($$NET^XMRENT(PRCAXMZ),U,3)
"RTN","PRCAMDS",17,0)
 I $$PROD^XUPROD,PRCAFROM'["AUSTIN.VA.GOV" Q
"RTN","PRCAMDS",18,0)
 ;
"RTN","PRCAMDS",19,0)
 ; get the message and process it
"RTN","PRCAMDS",20,0)
 S PRCAEFLG=$$MSG(PRCAXMZ,.PRCAERR)
"RTN","PRCAMDS",21,0)
 ;
"RTN","PRCAMDS",22,0)
 ; Need to determine if there is anything that needs to be done on errors
"RTN","PRCAMDS",23,0)
 ; initial consensus is no ; below is an example of error handling if we choose to go that route
"RTN","PRCAMDS",24,0)
 ; D:$G(PRCAEFLG) PERROR^RCDPESR1(.RCERR,"G.RCDPE PAYMENTS EXCEPTIONS",RCXMZ)
"RTN","PRCAMDS",25,0)
 ;
"RTN","PRCAMDS",26,0)
 ; Delete server mail msg from postmaster mailbox
"RTN","PRCAMDS",27,0)
 D ZAPSERV^XMXAPI("S.PRCA MDA SERVER",PRCAXMZ)   ;IA#2729
"RTN","PRCAMDS",28,0)
 ;
"RTN","PRCAMDS",29,0)
 Q
"RTN","PRCAMDS",30,0)
 ;
"RTN","PRCAMDS",31,0)
MSG(PRCAXMZ,PRCAERR) ; Read/Store message lines
"RTN","PRCAMDS",32,0)
 ; PRCAXMZ = the # of the Mailman message containing this message
"RTN","PRCAMDS",33,0)
 ; PRCAERR = array of errors
"RTN","PRCAMDS",34,0)
 ; 
"RTN","PRCAMDS",35,0)
 ; OUTPUT:
"RTN","PRCAMDS",36,0)
 ;  Function returns flag ... 0 = no errors    1 = errors
"RTN","PRCAMDS",37,0)
 ;     and the standard Mailman error variable contents of XMER
"RTN","PRCAMDS",38,0)
 ;
"RTN","PRCAMDS",39,0)
 ;  Read the file and process and MDA records and ignore the rest
"RTN","PRCAMDS",40,0)
 ;
"RTN","PRCAMDS",41,0)
 F  X XMREC Q:XMER<0  I $E(XMRG,1,3)="MDA" D PROCESS(XMRG,.PRCAERR)
"RTN","PRCAMDS",42,0)
 ;
"RTN","PRCAMDS",43,0)
MSGQ Q 0
"RTN","PRCAMDS",44,0)
 ;
"RTN","PRCAMDS",45,0)
PROCESS(MDAREC,PRCAERR) ; Process the MDA record.
"RTN","PRCAMDS",46,0)
 ;
"RTN","PRCAMDS",47,0)
 Q:$P(MDAREC,U)'="MDA"
"RTN","PRCAMDS",48,0)
 ;
"RTN","PRCAMDS",49,0)
 N X,DIC,Y,DIE,DR,D0,DA
"RTN","PRCAMDS",50,0)
 N PRCAPTR,PRCADIV,PRCAIEN,PRCADT
"RTN","PRCAMDS",51,0)
 ;
"RTN","PRCAMDS",52,0)
 ; See if we can find the bill number
"RTN","PRCAMDS",53,0)
 ; If so grab some info about the claim.
"RTN","PRCAMDS",54,0)
 S X=$P(MDAREC,U,5)
"RTN","PRCAMDS",55,0)
 Q:X=""
"RTN","PRCAMDS",56,0)
 ;
"RTN","PRCAMDS",57,0)
 S (PRCAPTR,PRCADIV)=""
"RTN","PRCAMDS",58,0)
 S DIC="^PRCA(430,"
"RTN","PRCAMDS",59,0)
 S DIC(0)="BX"
"RTN","PRCAMDS",60,0)
 D ^DIC I Y<1 S Y=""
"RTN","PRCAMDS",61,0)
 I +Y D
"RTN","PRCAMDS",62,0)
 . S PRCAPTR=+Y
"RTN","PRCAMDS",63,0)
 . ;Using ptr since by definition file 399 and 430 are DINUMed
"RTN","PRCAMDS",64,0)
 . S PRCADIV=$P($G(^DGCR(399,PRCAPTR,0)),U,22)   ; DBIA#3820 for accessing division. 
"RTN","PRCAMDS",65,0)
 ;
"RTN","PRCAMDS",66,0)
 ; Get a new IEN by appending quotes to the account number.
"RTN","PRCAMDS",67,0)
 ; Every entry we get will be put in the file.
"RTN","PRCAMDS",68,0)
 ;
"RTN","PRCAMDS",69,0)
 K DIC,X,Y
"RTN","PRCAMDS",70,0)
 S X=""""_$P(MDAREC,U,5)_""""   ; forces a new entry by putting quotes around it (an old Fileman trick)
"RTN","PRCAMDS",71,0)
 ;
"RTN","PRCAMDS",72,0)
 S DIC(0)="LBX"
"RTN","PRCAMDS",73,0)
 S DLAYGO=436.1
"RTN","PRCAMDS",74,0)
 S DIC="^PRCA(436.1,"
"RTN","PRCAMDS",75,0)
 D ^DIC
"RTN","PRCAMDS",76,0)
 S PRCAIEN=+Y
"RTN","PRCAMDS",77,0)
 ;
"RTN","PRCAMDS",78,0)
 ; File the data as best you can
"RTN","PRCAMDS",79,0)
 ; If it's not in the correct format, then skip it.
"RTN","PRCAMDS",80,0)
 K DIC,X,Y
"RTN","PRCAMDS",81,0)
 I $P(MDAREC,U,2)="A" S DR=".02///A"
"RTN","PRCAMDS",82,0)
 S DR=DR_";.03///"_$E($P(MDAREC,U,3),1,19)  ; Subscriber ID
"RTN","PRCAMDS",83,0)
 S DR=DR_";.04///"_$E(($P(MDAREC,U,4)_"    "),1,4)   ; Claim Year
"RTN","PRCAMDS",84,0)
 S DR=DR_";.05///"_$E($P(MDAREC,U,6),1,25)  ; DCN
"RTN","PRCAMDS",85,0)
 S DR=DR_";.06///"_$E((1000000+$P(MDAREC,U,7)),2,7)   ; amount DDDDDCC
"RTN","PRCAMDS",86,0)
 S DR=DR_";.07///"_$E((1000000+$P(MDAREC,U,8)),2,7)   ; amount DDDDDCC
"RTN","PRCAMDS",87,0)
 S PRCADT=$E($P(MDAREC,U,9),5,8)_$E($P(MDAREC,U,9),1,4)
"RTN","PRCAMDS",88,0)
 S DR=DR_";.08///"_PRCADT ; date CCYYMMDD
"RTN","PRCAMDS",89,0)
 S PRCADT=$E($P(MDAREC,U,10),5,8)_$E($P(MDAREC,U,10),1,4)
"RTN","PRCAMDS",90,0)
 S DR=DR_";.09///"_PRCADT ; date CCYYMMDD
"RTN","PRCAMDS",91,0)
 S PRCADT=$E($P(MDAREC,U,11),5,8)_$E($P(MDAREC,U,11),1,4)
"RTN","PRCAMDS",92,0)
 S DR=DR_";.1///"_PRCADT  ; date CCYYMMDD
"RTN","PRCAMDS",93,0)
 I PRCAPTR S DR=DR_";1.01////"_PRCAPTR  ; pointer to 430 if one was found.  Stuff in the ptr to 430.
"RTN","PRCAMDS",94,0)
 S DR=DR_";1.02///0"      ; set status to unreviewed
"RTN","PRCAMDS",95,0)
 I PRCADIV S DR=DR_";1.03///"_PRCADIV  ; pointer to 40.8 if one was found.
"RTN","PRCAMDS",96,0)
 S DA=PRCAIEN
"RTN","PRCAMDS",97,0)
 S DIE="^PRCA(436.1,"
"RTN","PRCAMDS",98,0)
 D ^DIE
"RTN","PRCAMDS",99,0)
 ;
"RTN","PRCAMDS",100,0)
 Q
"RTN","PRCAMDS",101,0)
 ;
"RTN","RCY275PO")
0^^B1227458
"RTN","RCY275PO",1,0)
RCY275PO ;ALB/BI - Post-Installation for PRCA patch 275 ;25-AUG-2011
"RTN","RCY275PO",2,0)
 ;;4.5;Accounts Receivable;**275**;AUG 25, 2011;Build 72
"RTN","RCY275PO",3,0)
 D MGAEXT
"RTN","RCY275PO",4,0)
 Q
"RTN","RCY275PO",5,0)
 ;
"RTN","RCY275PO",6,0)
MGAEXT   ; Add external mail address to mail group. 
"RTN","RCY275PO",7,0)
 N DO,DD,DA,DLAYGO,DIC,X,RCSITE
"RTN","RCY275PO",8,0)
 S RCSITE=$G(^XMB("NETNAME"))  Q:RCSITE=""   ; SITE DOMAIN NAME
"RTN","RCY275PO",9,0)
 S X="S.PRCA MDA SERVER@"_RCSITE             ; SERVER NAME WITH SITE DOMAIN NAME
"RTN","RCY275PO",10,0)
 S DA(1)=$O(^XMB(3.8,"B","MDA",0))           ; MAIL GROUP IEN
"RTN","RCY275PO",11,0)
 I $D(^XMB(3.8,DA(1),6,"B",$E(X,1,30))) Q    ; MAIL ADDRESS ALREADY EXISTS.
"RTN","RCY275PO",12,0)
 S DLAYGO=3.812,DIC(0)="L",DIC="^XMB(3.8,"_DA(1)_",6,"
"RTN","RCY275PO",13,0)
 D FILE^DICN                                 ; FILE THE ADDRESS
"RTN","RCY275PO",14,0)
 Q
"SEC","^DIC",436.1,436.1,0,"AUDIT")
@
"SEC","^DIC",436.1,436.1,0,"DD")
@
"SEC","^DIC",436.1,436.1,0,"DEL")
@
"SEC","^DIC",436.1,436.1,0,"LAYGO")
@
"SEC","^DIC",436.1,436.1,0,"RD")
@
"SEC","^DIC",436.1,436.1,0,"WR")
@
"VER")
8.0^22.0
"^DD",436.1,436.1,0)
FIELD^^2^14
"^DD",436.1,436.1,0,"DDA")
N
"^DD",436.1,436.1,0,"DT")
3111013
"^DD",436.1,436.1,0,"IX","B",436.1,.01)

"^DD",436.1,436.1,0,"IX","C",436.1,1.01)

"^DD",436.1,436.1,0,"NM","AR MEDICARE DEDUCTIBLE ALERTS PART A")

"^DD",436.1,436.1,0,"VRPK")
PRCA
"^DD",436.1,436.1,.01,0)
PATIENT ACCOUNT NUMBER^RF^^0;1^K:$L(X)>11!($L(X)<1)!'(X'?1P.E) X
"^DD",436.1,436.1,.01,1,0)
^.1
"^DD",436.1,436.1,.01,1,1,0)
436.1^B
"^DD",436.1,436.1,.01,1,1,1)
S ^PRCA(436.1,"B",$E(X,1,30),DA)=""
"^DD",436.1,436.1,.01,1,1,2)
K ^PRCA(436.1,"B",$E(X,1,30),DA)
"^DD",436.1,436.1,.01,3)
Answer must be 1-11 characters in length.
"^DD",436.1,436.1,.01,21,0)
^^3^3^3110811^
"^DD",436.1,436.1,.01,21,1,0)
The PATIENT ACCOUNT NUMBER will be used as a look up to the BILL NO. field
"^DD",436.1,436.1,.01,21,2,0)
(#.01) in the ACCOUNTS RECEIVABLE file (#430).  It is loaded as it is
"^DD",436.1,436.1,.01,21,3,0)
received from the Financial Services Center, FSC.
"^DD",436.1,436.1,.01,"DT")
3110811
"^DD",436.1,436.1,.02,0)
MEDICARE TYPE^S^A:PART A;^0;2^Q
"^DD",436.1,436.1,.02,3)
Enter the type of Medicare to which this deductible applies.
"^DD",436.1,436.1,.02,21,0)
^^3^3^3110810^
"^DD",436.1,436.1,.02,21,1,0)
Medicare type to which the deductible applied.  Currently only 
"^DD",436.1,436.1,.02,21,2,0)
supporting Medicare Part A. It is loaded as it is received from the 
"^DD",436.1,436.1,.02,21,3,0)
Financial  Services Center, FSC.  
"^DD",436.1,436.1,.02,"DT")
3110810
"^DD",436.1,436.1,.03,0)
SUBSCRIBER ID (HICN)^F^^0;3^K:$L(X)>19!($L(X)<1) X
"^DD",436.1,436.1,.03,3)
Answer must be 1-19 characters in length.
"^DD",436.1,436.1,.03,21,0)
^^2^2^3110810^
"^DD",436.1,436.1,.03,21,1,0)
This is the Medicare Assigned Member ID number. It is loaded as it is
"^DD",436.1,436.1,.03,21,2,0)
received from the Financial Services Center, FSC.
"^DD",436.1,436.1,.03,"DT")
3110810
"^DD",436.1,436.1,.04,0)
CLAIM YEAR^F^^0;4^K:$L(X)>4!($L(X)<4) X
"^DD",436.1,436.1,.04,3)
Answer must be 4 characters in length.
"^DD",436.1,436.1,.04,21,0)
^.001^2^2^3110822^^
"^DD",436.1,436.1,.04,21,1,0)
This is the 4 character year the deductible is applied against.  It is 
"^DD",436.1,436.1,.04,21,2,0)
loaded as it is received from the Financial  Services Center, FSC.
"^DD",436.1,436.1,.04,"DT")
3110822
"^DD",436.1,436.1,.05,0)
DCN^F^^0;5^K:$L(X)>25!($L(X)<1) X
"^DD",436.1,436.1,.05,3)
Answer must be 1-25 characters in length.
"^DD",436.1,436.1,.05,21,0)
^^2^2^3110810^
"^DD",436.1,436.1,.05,21,1,0)
This is the Document Control Number for this claim. It is loaded as it is 
"^DD",436.1,436.1,.05,21,2,0)
received from the Financial  Services Center, FSC.  
"^DD",436.1,436.1,.05,"DT")
3110810
"^DD",436.1,436.1,.06,0)
CASH DEDUCTIBLE SUBMITTED^F^^0;6^K:$L(X)>6!($L(X)<6) X
"^DD",436.1,436.1,.06,3)
Answer must be 6 characters in length.
"^DD",436.1,436.1,.06,21,0)
^.001^2^2^3110822^^
"^DD",436.1,436.1,.06,21,1,0)
This is the Cash Deductible Submitted amount (DDDDCC) as it is received
"^DD",436.1,436.1,.06,21,2,0)
from the Financial  Services Center, FSC.
"^DD",436.1,436.1,.06,"DT")
3110822
"^DD",436.1,436.1,.07,0)
CASH DEDUCTIBLE AVAILABLE^F^^0;7^K:$L(X)>6!($L(X)<6) X
"^DD",436.1,436.1,.07,3)
Answer must be 6 characters in length.
"^DD",436.1,436.1,.07,21,0)
^.001^2^2^3110822^^
"^DD",436.1,436.1,.07,21,1,0)
This is the Cash Deductible Available amount (DDDDCC) as it is received
"^DD",436.1,436.1,.07,21,2,0)
from the Financial  Services Center, FSC.
"^DD",436.1,436.1,.07,"DT")
3110822
"^DD",436.1,436.1,.08,0)
SERVICE START DATE^D^^0;8^S %DT="E" D ^%DT S X=Y K:X<1 X
"^DD",436.1,436.1,.08,3)
(No range limit on date)
"^DD",436.1,436.1,.08,21,0)
^^3^3^3111013^
"^DD",436.1,436.1,.08,21,1,0)
This is the Service Start Date. It is received from the Financial 
"^DD",436.1,436.1,.08,21,2,0)
Services Center (FSC) in the format CCYYMMDD, but converted and filed as 
"^DD",436.1,436.1,.08,21,3,0)
a FileMan date.
"^DD",436.1,436.1,.08,"DT")
3111013
"^DD",436.1,436.1,.09,0)
SERVICE END DATE^D^^0;9^S %DT="E" D ^%DT S X=Y K:X<1 X
"^DD",436.1,436.1,.09,3)
(No range limit on date)
"^DD",436.1,436.1,.09,21,0)
^^3^3^3111013^
"^DD",436.1,436.1,.09,21,1,0)
This is the Service End Date. It is received from the Financial Services 
"^DD",436.1,436.1,.09,21,2,0)
Center (FSC) in the format CCYYMMDD, but converted and filed as a FileMan 
"^DD",436.1,436.1,.09,21,3,0)
date.
"^DD",436.1,436.1,.09,"DT")
3111013
"^DD",436.1,436.1,.1,0)
REPORT DATE^D^^0;10^S %DT="E" D ^%DT S X=Y K:X<1 X
"^DD",436.1,436.1,.1,3)
(No range limit on date)
"^DD",436.1,436.1,.1,21,0)
^^3^3^3111013^
"^DD",436.1,436.1,.1,21,1,0)
This is the Report Date. It is received from the Financial Services 
"^DD",436.1,436.1,.1,21,2,0)
Center (FSC) in the format CCYYMMDD, but converted and filed as a FileMan 
"^DD",436.1,436.1,.1,21,3,0)
date.
"^DD",436.1,436.1,.1,"DT")
3111013
"^DD",436.1,436.1,1.01,0)
BILL NO.^P430'^PRCA(430,^1;1^Q
"^DD",436.1,436.1,1.01,1,0)
^.1
"^DD",436.1,436.1,1.01,1,1,0)
436.1^C
"^DD",436.1,436.1,1.01,1,1,1)
S ^PRCA(436.1,"C",$E(X,1,30),DA)=""
"^DD",436.1,436.1,1.01,1,1,2)
K ^PRCA(436.1,"C",$E(X,1,30),DA)
"^DD",436.1,436.1,1.01,1,1,"DT")
3110627
"^DD",436.1,436.1,1.01,3)
Enter the Bill Number for this Medicare Deductible Alert.
"^DD",436.1,436.1,1.01,21,0)
^^2^2^3110811^
"^DD",436.1,436.1,1.01,21,1,0)
The PATIENT ACCOUNT NUMBER will be used as a look up to the BILL NO.  
"^DD",436.1,436.1,1.01,21,2,0)
field (#.01) in the ACCOUNTS RECEIVABLE file (#430).
"^DD",436.1,436.1,1.01,"DT")
3110811
"^DD",436.1,436.1,1.02,0)
MDA REVIEW STATUS^S^0:NOT REVIEWED;1:REVIEW IN PROCESS;2:REVIEW COMPLETE;3:REVIEW COMPLETE/REMOVE ENTRY;^1;2^Q
"^DD",436.1,436.1,1.02,3)
Enter the status of this item on the MDA worklist.
"^DD",436.1,436.1,1.02,"DT")
3110811
"^DD",436.1,436.1,1.03,0)
DIVISION^P40.8'^DG(40.8,^1;3^Q
"^DD",436.1,436.1,1.03,3)
Enter the Division to which this deductible was applied.
"^DD",436.1,436.1,1.03,21,0)
^^2^2^3110810^
"^DD",436.1,436.1,1.03,21,1,0)
This is the Medical Center Division to which this deductible was applied.
"^DD",436.1,436.1,1.03,21,2,0)
It is retrieved using the Bill Number.
"^DD",436.1,436.1,1.03,"DT")
3110810
"^DD",436.1,436.1,2,0)
COMMENT DATE TIME^436.12DA^^2;0
"^DD",436.1,436.1,2,21,0)
^^2^2^3110811^
"^DD",436.1,436.1,2,21,1,0)
This multiple contains comments pertaining to the Medicare Deductible
"^DD",436.1,436.1,2,21,2,0)
Alert received from the Financial Services Center, FSC.
"^DD",436.1,436.12,0)
COMMENT DATE TIME SUB-FIELD^^2^4
"^DD",436.1,436.12,0,"DT")
3110810
"^DD",436.1,436.12,0,"IX","B",436.12,.01)

"^DD",436.1,436.12,0,"NM","COMMENT DATE TIME")

"^DD",436.1,436.12,0,"UP")
436.1
"^DD",436.1,436.12,.01,0)
COMMENT DATE TIME^D^^0;1^S %DT="ESTX" D ^%DT S X=Y K:X<1 X
"^DD",436.1,436.12,.01,1,0)
^.1
"^DD",436.1,436.12,.01,1,1,0)
436.12^B
"^DD",436.1,436.12,.01,1,1,1)
S ^PRCA(436.1,DA(1),2,"B",$E(X,1,30),DA)=""
"^DD",436.1,436.12,.01,1,1,2)
K ^PRCA(436.1,DA(1),2,"B",$E(X,1,30),DA)
"^DD",436.1,436.12,.01,1,2,0)
^^TRIGGER^436.12^.02
"^DD",436.1,436.12,.01,1,2,1)
K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^PRCA(436.1,D0,2,D1,0)):^(0),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(436.12,.01,1,2,1.4)
"^DD",436.1,436.12,.01,1,2,1.4)
S DIH=$G(^PRCA(436.1,DIV(0),2,DIV(1),0)),DIV=X S $P(^(0),U,2)=DIV,DIH=436.12,DIG=.02 D ^DICR
"^DD",436.1,436.12,.01,1,2,2)
Q
"^DD",436.1,436.12,.01,1,2,"%D",0)
^^2^2^3110824^
"^DD",436.1,436.12,.01,1,2,"%D",1,0)
This trigger will insert the current user into ENTERED BY field of the 
"^DD",436.1,436.12,.01,1,2,"%D",2,0)
COMMENT DATE TIME multiple.
"^DD",436.1,436.12,.01,1,2,"CREATE VALUE")
S X=DUZ
"^DD",436.1,436.12,.01,1,2,"DELETE VALUE")
NO EFFECT
"^DD",436.1,436.12,.01,1,2,"DT")
3110624
"^DD",436.1,436.12,.01,1,2,"FIELD")
#.02
"^DD",436.1,436.12,.01,3)
Enter the date/time that the comment is being added.
"^DD",436.1,436.12,.01,21,0)
^^3^3^3110822^
"^DD",436.1,436.12,.01,21,1,0)
This is the date and time that the comment was added by the user.  It is 
"^DD",436.1,436.12,.01,21,2,0)
defaulted to NOW by the system when adding a comment from the 
"^DD",436.1,436.12,.01,21,3,0)
MDA worklist.
"^DD",436.1,436.12,.01,"DT")
3110822
"^DD",436.1,436.12,.02,0)
ENTERED BY^P200'^VA(200,^0;2^Q
"^DD",436.1,436.12,.02,3)
Enter the user adding the comments.
"^DD",436.1,436.12,.02,5,1,0)
436.12^.01^2
"^DD",436.1,436.12,.02,9)
^
"^DD",436.1,436.12,.02,21,0)
^^2^2^3110810^
"^DD",436.1,436.12,.02,21,1,0)
This is the user who added the comments.  The field is not asked but is 
"^DD",436.1,436.12,.02,21,2,0)
automatically stored when comments are entered.
"^DD",436.1,436.12,.02,"DT")
3110810
"^DD",436.1,436.12,.03,0)
FOLLOW-UP DATE^D^^0;3^S %DT="EST" D ^%DT S X=Y K:X<1 X
"^DD",436.1,436.12,.03,3)
Enter the date to follow-up on this alert.
"^DD",436.1,436.12,.03,21,0)
^^1^1^3110810^
"^DD",436.1,436.12,.03,21,1,0)
This is the follow-up date as determined by the user entering the comment.
"^DD",436.1,436.12,.03,"DT")
3110810
"^DD",436.1,436.12,2,0)
COMMENT^436.122^^1;0
"^DD",436.1,436.12,2,21,0)
^^2^2^3110810^
"^DD",436.1,436.12,2,21,1,0)
This field is for any comments that the user chooses to enter for this 
"^DD",436.1,436.12,2,21,2,0)
alert.
"^DD",436.1,436.122,0)
COMMENT SUB-FIELD^^.01^1
"^DD",436.1,436.122,0,"DT")
3110810
"^DD",436.1,436.122,0,"NM","COMMENT")

"^DD",436.1,436.122,0,"UP")
436.12
"^DD",436.1,436.122,.01,0)
COMMENT^Wx^^0;1
"^DD",436.1,436.122,.01,"DT")
3110810
"^DIC",436.1,436.1,0)
AR MEDICARE DEDUCTIBLE ALERTS PART A^436.1
"^DIC",436.1,436.1,0,"GL")
^PRCA(436.1,
"^DIC",436.1,436.1,"%",0)
^1.005^^0
"^DIC",436.1,436.1,"%D",0)
^1.001^4^4^3111013^^
"^DIC",436.1,436.1,"%D",1,0)
This file is used to store Medicare Part A Deductible Alerts (MDA) that
"^DIC",436.1,436.1,"%D",2,0)
are received by the Financial Services Center (FSC) in Austin and sent to
"^DIC",436.1,436.1,"%D",3,0)
the individual sites.  This data will be used by the new MDA worklist so
"^DIC",436.1,436.1,"%D",4,0)
that Accounts Receivable personnel can take any necessary action.
"^DIC",436.1,"B","AR MEDICARE DEDUCTIBLE ALERTS PART A",436.1)

**INSTALL NAME**
IB*2.0*447
"BLD",8125,0)
IB*2.0*447^INTEGRATED BILLING^0^3120116^y
"BLD",8125,4,0)
^9.64PA^355.93^11
"BLD",8125,4,350.8,0)
350.8
"BLD",8125,4,350.8,222)
n^n^f^^n^^y^o^n
"BLD",8125,4,350.8,224)
I $$INC3508^IBY447PR(Y)
"BLD",8125,4,353,0)
353
"BLD",8125,4,353,2,0)
^9.641^353^1
"BLD",8125,4,353,2,353,0)
BILL FORM TYPE  (File-top level)
"BLD",8125,4,353,2,353,1,0)
^9.6411^2.09^1
"BLD",8125,4,353,2,353,1,2.09,0)
LOCAL BILLING SCREEN
"BLD",8125,4,353,222)
y^y^p^^^^n^^n
"BLD",8125,4,353,224)

"BLD",8125,4,353.4,0)
353.4
"BLD",8125,4,353.4,222)
y^y^f^^n^^y^o^n
"BLD",8125,4,353.5,0)
353.5
"BLD",8125,4,353.5,222)
y^y^f^^n^^y^o^n
"BLD",8125,4,355.1,0)
355.1
"BLD",8125,4,355.1,222)
y^y^f^^n^^y^o^n
"BLD",8125,4,355.1,224)
I $$INC3551^IBY447PR(Y)
"BLD",8125,4,355.93,0)
355.93
"BLD",8125,4,355.93,2,0)
^9.641^355.93^1
"BLD",8125,4,355.93,2,355.93,0)
IB NON/OTHER VA BILLING PROVIDER  (File-top level)
"BLD",8125,4,355.93,2,355.93,1,0)
^9.6411^.16^1
"BLD",8125,4,355.93,2,355.93,1,.16,0)
LICENSE STATE
"BLD",8125,4,355.93,222)
y^n^p^^^^n^^n
"BLD",8125,4,355.93,224)

"BLD",8125,4,361.1,0)
361.1
"BLD",8125,4,361.1,2,0)
^9.641^361.1^1
"BLD",8125,4,361.1,2,361.1,0)
EXPLANATION OF BENEFITS  (File-top level)
"BLD",8125,4,361.1,2,361.1,1,0)
^9.6411^.05^2
"BLD",8125,4,361.1,2,361.1,1,.04,0)
EOB TYPE
"BLD",8125,4,361.1,2,361.1,1,.05,0)
ENTRY DATE/TIME
"BLD",8125,4,361.1,222)
y^y^p^^^^n^^n
"BLD",8125,4,361.1,224)

"BLD",8125,4,364.5,0)
364.5
"BLD",8125,4,364.5,222)
n^n^f^^y^^y^o^n
"BLD",8125,4,364.5,224)
I $$INCLUDE^IBY447PR(5,Y)
"BLD",8125,4,364.6,0)
364.6
"BLD",8125,4,364.6,222)
n^n^f^^y^^y^o^n
"BLD",8125,4,364.6,224)
I $$INCLUDE^IBY447PR(6,Y)
"BLD",8125,4,364.7,0)
364.7
"BLD",8125,4,364.7,222)
n^n^f^^y^^y^o^n
"BLD",8125,4,364.7,224)
I $$INCLUDE^IBY447PR(7,Y)
"BLD",8125,4,399,0)
399
"BLD",8125,4,399,2,0)
^9.641^399.0304^4
"BLD",8125,4,399,2,399,0)
BILL/CLAIMS  (File-top level)
"BLD",8125,4,399,2,399,1,0)
^9.6411^.05^7
"BLD",8125,4,399,2,399,1,.05,0)
BILL CLASSIFICATION
"BLD",8125,4,399,2,399,1,.27,0)
BILL CHARGE TYPE
"BLD",8125,4,399,2,399,1,287,0)
PATIENT WEIGHT (LB)
"BLD",8125,4,399,2,399,1,288,0)
TRANSPORT REASON CODE
"BLD",8125,4,399,2,399,1,289,0)
AMBULANCE TRANSPORT DISTANCE
"BLD",8125,4,399,2,399,1,290,0)
ROUND TRIP PURPOSE DESCRIPTION
"BLD",8125,4,399,2,399,1,291,0)
STRETCHER PURPOSE DESCRIPTION
"BLD",8125,4,399,2,399.0292,0)
AMBULANCE CONDITION INDICATOR  (sub-file)
"BLD",8125,4,399,2,399.0292,1,0)
^9.6411^^0
"BLD",8125,4,399,2,399.0304,0)
PROCEDURES  (sub-file)
"BLD",8125,4,399,2,399.0304,1,0)
^9.6411^.01^2
"BLD",8125,4,399,2,399.0304,1,.01,0)
PROCEDURES
"BLD",8125,4,399,2,399.0304,1,5,0)
DIVISION
"BLD",8125,4,399,2,399.042,0)
REVENUE CODE  (sub-file)
"BLD",8125,4,399,2,399.042,1,0)
^9.6411^.02^2
"BLD",8125,4,399,2,399.042,1,.02,0)
CHARGES
"BLD",8125,4,399,2,399.042,1,.16,0)
MANUALLY EDITED
"BLD",8125,4,399,222)
y^y^p^^^^n^^n
"BLD",8125,4,399,224)

"BLD",8125,4,"APDD",353,353)

"BLD",8125,4,"APDD",353,353,2.09)

"BLD",8125,4,"APDD",355.93,355.93)

"BLD",8125,4,"APDD",355.93,355.93,.16)

"BLD",8125,4,"APDD",361.1,361.1)

"BLD",8125,4,"APDD",361.1,361.1,.04)

"BLD",8125,4,"APDD",361.1,361.1,.05)

"BLD",8125,4,"APDD",399,399)

"BLD",8125,4,"APDD",399,399,.05)

"BLD",8125,4,"APDD",399,399,.27)

"BLD",8125,4,"APDD",399,399,287)

"BLD",8125,4,"APDD",399,399,288)

"BLD",8125,4,"APDD",399,399,289)

"BLD",8125,4,"APDD",399,399,290)

"BLD",8125,4,"APDD",399,399,291)

"BLD",8125,4,"APDD",399,399.0292)

"BLD",8125,4,"APDD",399,399.0304)

"BLD",8125,4,"APDD",399,399.0304,.01)

"BLD",8125,4,"APDD",399,399.0304,5)

"BLD",8125,4,"APDD",399,399.042)

"BLD",8125,4,"APDD",399,399.042,.02)

"BLD",8125,4,"APDD",399,399.042,.16)

"BLD",8125,4,"B",350.8,350.8)

"BLD",8125,4,"B",353,353)

"BLD",8125,4,"B",353.4,353.4)

"BLD",8125,4,"B",353.5,353.5)

"BLD",8125,4,"B",355.1,355.1)

"BLD",8125,4,"B",355.93,355.93)

"BLD",8125,4,"B",361.1,361.1)

"BLD",8125,4,"B",364.5,364.5)

"BLD",8125,4,"B",364.6,364.6)

"BLD",8125,4,"B",364.7,364.7)

"BLD",8125,4,"B",399,399)

"BLD",8125,6.3)
80
"BLD",8125,"ABPKG")
n
"BLD",8125,"INI")
IBY447PR
"BLD",8125,"INID")
^y^y
"BLD",8125,"INIT")
IBY447PO
"BLD",8125,"KRN",0)
^9.67PA^779.2^20
"BLD",8125,"KRN",.4,0)
.4
"BLD",8125,"KRN",.401,0)
.401
"BLD",8125,"KRN",.402,0)
.402
"BLD",8125,"KRN",.402,"NM",0)
^9.68A^9^5
"BLD",8125,"KRN",.402,"NM",1,0)
IB SCREEN5    FILE #399^399^0
"BLD",8125,"KRN",.402,"NM",6,0)
IB SCREEN9    FILE #399^399^0
"BLD",8125,"KRN",.402,"NM",7,0)
IB SCREEN8    FILE #399^399^0
"BLD",8125,"KRN",.402,"NM",8,0)
IB SCREEN7    FILE #399^399^0
"BLD",8125,"KRN",.402,"NM",9,0)
IB SCREEN6    FILE #399^399^0
"BLD",8125,"KRN",.402,"NM","B","IB SCREEN5    FILE #399",1)

"BLD",8125,"KRN",.402,"NM","B","IB SCREEN6    FILE #399",9)

"BLD",8125,"KRN",.402,"NM","B","IB SCREEN7    FILE #399",8)

"BLD",8125,"KRN",.402,"NM","B","IB SCREEN8    FILE #399",7)

"BLD",8125,"KRN",.402,"NM","B","IB SCREEN9    FILE #399",6)

"BLD",8125,"KRN",.403,0)
.403
"BLD",8125,"KRN",.5,0)
.5
"BLD",8125,"KRN",.84,0)
.84
"BLD",8125,"KRN",3.6,0)
3.6
"BLD",8125,"KRN",3.8,0)
3.8
"BLD",8125,"KRN",3.8,"NM",0)
^9.68A^^0
"BLD",8125,"KRN",9.2,0)
9.2
"BLD",8125,"KRN",9.8,0)
9.8
"BLD",8125,"KRN",9.8,"NM",0)
^9.68A^68^52
"BLD",8125,"KRN",9.8,"NM",1,0)
IBCSC5^^0^B17112329
"BLD",8125,"KRN",9.8,"NM",7,0)
IBCSCP^^0^B11636365
"BLD",8125,"KRN",9.8,"NM",8,0)
IBCSC11^^0^B7658686
"BLD",8125,"KRN",9.8,"NM",13,0)
IBCSCE^^0^B9204544
"BLD",8125,"KRN",9.8,"NM",15,0)
IBCSC8^^0^B7203948
"BLD",8125,"KRN",9.8,"NM",16,0)
IBCCCB^^0^B65683261
"BLD",8125,"KRN",9.8,"NM",17,0)
IBCEMU4^^0^B29651910
"BLD",8125,"KRN",9.8,"NM",18,0)
IBCEF^^0^B58449164
"BLD",8125,"KRN",9.8,"NM",19,0)
IBCEF11^^0^B73456164
"BLD",8125,"KRN",9.8,"NM",21,0)
IBJTTC^^0^B69337757
"BLD",8125,"KRN",9.8,"NM",22,0)
IBCEMSR2^^0^B83574265
"BLD",8125,"KRN",9.8,"NM",23,0)
IBCECOB2^^0^B167373990
"BLD",8125,"KRN",9.8,"NM",24,0)
IBCCC2^^0^B108841715
"BLD",8125,"KRN",9.8,"NM",27,0)
IBOTR2^^0^B22290146
"BLD",8125,"KRN",9.8,"NM",28,0)
IBOTR3^^0^B29774240
"BLD",8125,"KRN",9.8,"NM",29,0)
IBCBB1^^0^B98716914
"BLD",8125,"KRN",9.8,"NM",31,0)
IBCAPP2^^0^B43298709
"BLD",8125,"KRN",9.8,"NM",32,0)
IBCECOB1^^0^B102535687
"BLD",8125,"KRN",9.8,"NM",33,0)
IBCEMSR^^0^B53975881
"BLD",8125,"KRN",9.8,"NM",34,0)
IBCEMQC^^0^B30540187
"BLD",8125,"KRN",9.8,"NM",35,0)
IBCAPP1^^0^B38009717
"BLD",8125,"KRN",9.8,"NM",36,0)
IBCEMSR3^^0^B132530577
"BLD",8125,"KRN",9.8,"NM",37,0)
IBCEMSR4^^0^B110188807
"BLD",8125,"KRN",9.8,"NM",38,0)
IBCB2^^0^B52688677
"BLD",8125,"KRN",9.8,"NM",39,0)
IBCSC9^^0^B7536045
"BLD",8125,"KRN",9.8,"NM",40,0)
IBCSCH^^0^B48120299
"BLD",8125,"KRN",9.8,"NM",41,0)
IBCSCU^^0^B12535542
"BLD",8125,"KRN",9.8,"NM",42,0)
IBCC^^0^B57603103
"BLD",8125,"KRN",9.8,"NM",44,0)
IBCRBE^^0^B31355983
"BLD",8125,"KRN",9.8,"NM",45,0)
IBCU61^^0^B6243488
"BLD",8125,"KRN",9.8,"NM",46,0)
IBCU62^^0^B10149874
"BLD",8125,"KRN",9.8,"NM",47,0)
IBCU9^^0^B4596044
"BLD",8125,"KRN",9.8,"NM",48,0)
IBCEFP^^0^B100162925
"BLD",8125,"KRN",9.8,"NM",49,0)
IBCRBF^^0^B10793881
"BLD",8125,"KRN",9.8,"NM",51,0)
IBCBB6^^0^B235040
"BLD",8125,"KRN",9.8,"NM",52,0)
IBCSC102^^0^B41181952
"BLD",8125,"KRN",9.8,"NM",53,0)
IBCBB2^^0^B50172747
"BLD",8125,"KRN",9.8,"NM",54,0)
IBCBB21^^0^B14595417
"BLD",8125,"KRN",9.8,"NM",55,0)
IBCBB13^^0^B19726855
"BLD",8125,"KRN",9.8,"NM",56,0)
IBCRBC3^^0^B15092850
"BLD",8125,"KRN",9.8,"NM",57,0)
IBCU7^^0^B81426431
"BLD",8125,"KRN",9.8,"NM",58,0)
IBCU7B^^0^B55412712
"BLD",8125,"KRN",9.8,"NM",59,0)
IBCRBC2^^0^B28219080
"BLD",8125,"KRN",9.8,"NM",60,0)
IBCRCC^^0^B34225525
"BLD",8125,"KRN",9.8,"NM",61,0)
IBCEF1^^0^B60116186
"BLD",8125,"KRN",9.8,"NM",62,0)
IBCBB7^^0^B27582918
"BLD",8125,"KRN",9.8,"NM",63,0)
IBCCC^^0^B20967189
"BLD",8125,"KRN",9.8,"NM",64,0)
IBCEP8^^0^B124149510
"BLD",8125,"KRN",9.8,"NM",65,0)
IBCEP5A^^0^B26443385
"BLD",8125,"KRN",9.8,"NM",66,0)
IBCAPP^^0^B21485583
"BLD",8125,"KRN",9.8,"NM",67,0)
IBCEMSR5^^0^B7131681
"BLD",8125,"KRN",9.8,"NM",68,0)
IBCU5^^0^B14664584
"BLD",8125,"KRN",9.8,"NM","B","IBCAPP",66)

"BLD",8125,"KRN",9.8,"NM","B","IBCAPP1",35)

"BLD",8125,"KRN",9.8,"NM","B","IBCAPP2",31)

"BLD",8125,"KRN",9.8,"NM","B","IBCB2",38)

"BLD",8125,"KRN",9.8,"NM","B","IBCBB1",29)

"BLD",8125,"KRN",9.8,"NM","B","IBCBB13",55)

"BLD",8125,"KRN",9.8,"NM","B","IBCBB2",53)

"BLD",8125,"KRN",9.8,"NM","B","IBCBB21",54)

"BLD",8125,"KRN",9.8,"NM","B","IBCBB6",51)

"BLD",8125,"KRN",9.8,"NM","B","IBCBB7",62)

"BLD",8125,"KRN",9.8,"NM","B","IBCC",42)

"BLD",8125,"KRN",9.8,"NM","B","IBCCC",63)

"BLD",8125,"KRN",9.8,"NM","B","IBCCC2",24)

"BLD",8125,"KRN",9.8,"NM","B","IBCCCB",16)

"BLD",8125,"KRN",9.8,"NM","B","IBCECOB1",32)

"BLD",8125,"KRN",9.8,"NM","B","IBCECOB2",23)

"BLD",8125,"KRN",9.8,"NM","B","IBCEF",18)

"BLD",8125,"KRN",9.8,"NM","B","IBCEF1",61)

"BLD",8125,"KRN",9.8,"NM","B","IBCEF11",19)

"BLD",8125,"KRN",9.8,"NM","B","IBCEFP",48)

"BLD",8125,"KRN",9.8,"NM","B","IBCEMQC",34)

"BLD",8125,"KRN",9.8,"NM","B","IBCEMSR",33)

"BLD",8125,"KRN",9.8,"NM","B","IBCEMSR2",22)

"BLD",8125,"KRN",9.8,"NM","B","IBCEMSR3",36)

"BLD",8125,"KRN",9.8,"NM","B","IBCEMSR4",37)

"BLD",8125,"KRN",9.8,"NM","B","IBCEMSR5",67)

"BLD",8125,"KRN",9.8,"NM","B","IBCEMU4",17)

"BLD",8125,"KRN",9.8,"NM","B","IBCEP5A",65)

"BLD",8125,"KRN",9.8,"NM","B","IBCEP8",64)

"BLD",8125,"KRN",9.8,"NM","B","IBCRBC2",59)

"BLD",8125,"KRN",9.8,"NM","B","IBCRBC3",56)

"BLD",8125,"KRN",9.8,"NM","B","IBCRBE",44)

"BLD",8125,"KRN",9.8,"NM","B","IBCRBF",49)

"BLD",8125,"KRN",9.8,"NM","B","IBCRCC",60)

"BLD",8125,"KRN",9.8,"NM","B","IBCSC102",52)

"BLD",8125,"KRN",9.8,"NM","B","IBCSC11",8)

"BLD",8125,"KRN",9.8,"NM","B","IBCSC5",1)

"BLD",8125,"KRN",9.8,"NM","B","IBCSC8",15)

"BLD",8125,"KRN",9.8,"NM","B","IBCSC9",39)

"BLD",8125,"KRN",9.8,"NM","B","IBCSCE",13)

"BLD",8125,"KRN",9.8,"NM","B","IBCSCH",40)

"BLD",8125,"KRN",9.8,"NM","B","IBCSCP",7)

"BLD",8125,"KRN",9.8,"NM","B","IBCSCU",41)

"BLD",8125,"KRN",9.8,"NM","B","IBCU5",68)

"BLD",8125,"KRN",9.8,"NM","B","IBCU61",45)

"BLD",8125,"KRN",9.8,"NM","B","IBCU62",46)

"BLD",8125,"KRN",9.8,"NM","B","IBCU7",57)

"BLD",8125,"KRN",9.8,"NM","B","IBCU7B",58)

"BLD",8125,"KRN",9.8,"NM","B","IBCU9",47)

"BLD",8125,"KRN",9.8,"NM","B","IBJTTC",21)

"BLD",8125,"KRN",9.8,"NM","B","IBOTR2",27)

"BLD",8125,"KRN",9.8,"NM","B","IBOTR3",28)

"BLD",8125,"KRN",19,0)
19
"BLD",8125,"KRN",19,"NM",0)
^9.68A^7^4
"BLD",8125,"KRN",19,"NM",3,0)
IB OUTPUT MANAGEMENT REPORTS^^3
"BLD",8125,"KRN",19,"NM",4,0)
IBCEM NON-MRA REPORT^^0
"BLD",8125,"KRN",19,"NM",6,0)
IB OUTPUT PATIENT REPORT MENU^^3
"BLD",8125,"KRN",19,"NM",7,0)
IB COPY SECOND/THIRD^^1^
"BLD",8125,"KRN",19,"NM","B","IB COPY SECOND/THIRD",7)

"BLD",8125,"KRN",19,"NM","B","IB OUTPUT MANAGEMENT REPORTS",3)

"BLD",8125,"KRN",19,"NM","B","IB OUTPUT PATIENT REPORT MENU",6)

"BLD",8125,"KRN",19,"NM","B","IBCEM NON-MRA REPORT",4)

"BLD",8125,"KRN",19.1,0)
19.1
"BLD",8125,"KRN",19.1,"NM",0)
^9.68A^^
"BLD",8125,"KRN",101,0)
101
"BLD",8125,"KRN",409.61,0)
409.61
"BLD",8125,"KRN",409.61,"NM",0)
^9.68A^3^3
"BLD",8125,"KRN",409.61,"NM",1,0)
IBJT INACTIVE LIST^^0
"BLD",8125,"KRN",409.61,"NM",2,0)
IBCEM COB MANAGEMENT^^0
"BLD",8125,"KRN",409.61,"NM",3,0)
IBCEM MRA MANAGEMENT^^0
"BLD",8125,"KRN",409.61,"NM","B","IBCEM COB MANAGEMENT",2)

"BLD",8125,"KRN",409.61,"NM","B","IBCEM MRA MANAGEMENT",3)

"BLD",8125,"KRN",409.61,"NM","B","IBJT INACTIVE LIST",1)

"BLD",8125,"KRN",771,0)
771
"BLD",8125,"KRN",779.2,0)
779.2
"BLD",8125,"KRN",870,0)
870
"BLD",8125,"KRN",8989.51,0)
8989.51
"BLD",8125,"KRN",8989.52,0)
8989.52
"BLD",8125,"KRN",8994,0)
8994
"BLD",8125,"KRN","B",.4,.4)

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

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

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

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

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

"BLD",8125,"KRN","B",3.6,3.6)

"BLD",8125,"KRN","B",3.8,3.8)

"BLD",8125,"KRN","B",9.2,9.2)

"BLD",8125,"KRN","B",9.8,9.8)

"BLD",8125,"KRN","B",19,19)

"BLD",8125,"KRN","B",19.1,19.1)

"BLD",8125,"KRN","B",101,101)

"BLD",8125,"KRN","B",409.61,409.61)

"BLD",8125,"KRN","B",771,771)

"BLD",8125,"KRN","B",779.2,779.2)

"BLD",8125,"KRN","B",870,870)

"BLD",8125,"KRN","B",8989.51,8989.51)

"BLD",8125,"KRN","B",8989.52,8989.52)

"BLD",8125,"KRN","B",8994,8994)

"BLD",8125,"PRE")

"BLD",8125,"QDEF")
^^^^NO^^^^YES^^NO
"BLD",8125,"QUES",0)
^9.62^^
"BLD",8125,"REQB",0)
^9.611^9^8
"BLD",8125,"REQB",1,0)
IB*2.0*432^1
"BLD",8125,"REQB",2,0)
IB*2.0*359^1
"BLD",8125,"REQB",3,0)
IB*2.0*389^1
"BLD",8125,"REQB",5,0)
IB*2.0*133^1
"BLD",8125,"REQB",6,0)
IB*2.0*240^1
"BLD",8125,"REQB",7,0)
IB*2.0*455^1
"BLD",8125,"REQB",8,0)
IB*2.0*451^1
"BLD",8125,"REQB",9,0)
IB*2.0*206^1
"BLD",8125,"REQB","B","IB*2.0*133",5)

"BLD",8125,"REQB","B","IB*2.0*206",9)

"BLD",8125,"REQB","B","IB*2.0*240",6)

"BLD",8125,"REQB","B","IB*2.0*359",2)

"BLD",8125,"REQB","B","IB*2.0*389",3)

"BLD",8125,"REQB","B","IB*2.0*432",1)

"BLD",8125,"REQB","B","IB*2.0*451",8)

"BLD",8125,"REQB","B","IB*2.0*455",7)

"DATA",350.8,179,0)
IB348^Claims with multiple payers require all Payer IDs.^IB348^1^3
"DATA",350.8,180,0)
IB349^UB04 claims require a Priority (Type) of Admission.^IB349^1^3
"DATA",350.8,202,0)
IB344^Total charge on claim must equal sum of line item charges.^IB344^1^3
"DATA",350.8,203,0)
IB345^Providers' EIN/SY IDs must be 9 digits.^IB345^1^3
"DATA",350.8,204,0)
IB346^Destination payer's ICN required when bill timeframe is 7 or 8.^IB346^1^3
"DATA",350.8,205,0)
IB347^Outpt. UB04 claims require a Patient Reason for Visit.^IB347^1^3
"DATA",353.4,1,0)
A^Patient was transported to nearest facility for care of symptoms, complaints or both.
"DATA",353.4,2,0)
B^Patient was transported for the benefit of a preferred physician.
"DATA",353.4,3,0)
C^Patient was transported for the nearness of family members.
"DATA",353.4,4,0)
D^Patient was transported for the care of a specialist or for availability of specialized equipment.
"DATA",353.4,5,0)
E^Patient transferred to Rehabilitation Facility.
"DATA",353.5,1,0)
01^Admitted to hospital
"DATA",353.5,2,0)
04^Moved by stretcher
"DATA",353.5,3,0)
05^Unconscious or in Shock
"DATA",353.5,4,0)
06^Transported in emergency situation
"DATA",353.5,5,0)
07^Had to be physically restrained
"DATA",353.5,6,0)
08^Visible hemorrhaging
"DATA",353.5,7,0)
09^Medically necessary service
"DATA",353.5,8,0)
12^Confined to a bed or chair
"DATA",355.1,8,0)
COMPREHENSIVE MAJOR MEDICAL^CMM^1
"DATA",355.1,8,10,0)
^355.11^2^2^3110428^^^^
"DATA",355.1,8,10,1,0)
A policy designed to give the protection offered by both a basic
"DATA",355.1,8,10,2,0)
and a major medical health insurance policy.
"DATA",355.1,8,14,0)
^355.14D^1^1
"DATA",355.1,8,14,1,0)
3100601
"DATA",355.1,8,14,1,1,0)
^355.141^2^2
"DATA",355.1,8,14,1,1,1,0)
PR
"DATA",355.1,8,14,1,1,1,1,0)
^355.1411^3^3
"DATA",355.1,8,14,1,1,1,1,1,0)
1^100^100
"DATA",355.1,8,14,1,1,1,1,2,0)
2^100^100
"DATA",355.1,8,14,1,1,1,1,3,0)
3^100^100
"DATA",355.1,8,14,1,1,2,0)
CO
"DATA",355.1,8,14,1,1,2,1,0)
^355.1411^1^1
"DATA",355.1,8,14,1,1,2,1,1,0)
45^0^100
"DATA",355.1,32,0)
MEDICAL EXPENSE (OPT/PROF)^MEI^1
"DATA",355.1,32,10,0)
^355.11^5^5^3110428^^^^
"DATA",355.1,32,10,1,0)
A form of health insurance that provides benefits for medical care
"DATA",355.1,32,10,2,0)
on an outpatient basis.  The company may limit the amount it will
"DATA",355.1,32,10,3,0)
pay per call or the total amount for all calls.  It may also exclude
"DATA",355.1,32,10,4,0)
the first few calls made by the physician at the beginning of an
"DATA",355.1,32,10,5,0)
illness.
"DATA",355.1,32,14,0)
^355.14D^1^1
"DATA",355.1,32,14,1,0)
3100601
"DATA",355.1,32,14,1,1,0)
^355.141^2^2
"DATA",355.1,32,14,1,1,1,0)
PR
"DATA",355.1,32,14,1,1,1,1,0)
^355.1411^3^3
"DATA",355.1,32,14,1,1,1,1,1,0)
1^100^100
"DATA",355.1,32,14,1,1,1,1,2,0)
2^100^100
"DATA",355.1,32,14,1,1,1,1,3,0)
3^100^100
"DATA",355.1,32,14,1,1,2,0)
CO
"DATA",355.1,32,14,1,1,2,1,0)
^355.1411^1^1
"DATA",355.1,32,14,1,1,2,1,1,0)
45^0^100
"DATA",355.1,35,0)
MEDIGAP PLAN C^MGC^11
"DATA",355.1,35,10,0)
^355.11^6^6^3110428^^^^
"DATA",355.1,35,10,1,0)
This is a standard MEDIGAP plan purchased individually as a
"DATA",355.1,35,10,2,0)
supplemental policy and is designed to cover amounts not covered 
"DATA",355.1,35,10,3,0)
by Medicare. These policies are not available to individuals 
"DATA",355.1,35,10,4,0)
not covered by Medicare and are usually purchased directly by the 
"DATA",355.1,35,10,5,0)
individual and not through an employer.  Services not covered by Medicare
"DATA",355.1,35,10,6,0)
are not covered by a supplemental plan. 
"DATA",355.1,35,14,0)
^355.14D^1^1
"DATA",355.1,35,14,1,0)
3100601
"DATA",355.1,35,14,1,1,0)
^355.141^1^1
"DATA",355.1,35,14,1,1,1,0)
PR
"DATA",355.1,35,14,1,1,1,1,0)
^355.1411^3^3
"DATA",355.1,35,14,1,1,1,1,1,0)
1^100^100
"DATA",355.1,35,14,1,1,1,1,2,0)
2^100^100
"DATA",355.1,35,14,1,1,1,1,3,0)
3^100^100
"DATA",355.1,40,0)
PREFERRED PROVIDER ORGANIZATION (PPO)^PPO^4
"DATA",355.1,40,10,0)
^355.11^4^4^3110428^^^^
"DATA",355.1,40,10,1,0)
An entity that serves as a broker to contract for comprehensive
"DATA",355.1,40,10,2,0)
health care services, with both hospitals and physicians, on
"DATA",355.1,40,10,3,0)
behalf of an employer or other group of patients,
"DATA",355.1,40,10,4,0)
at prearranged discounted rates or on a fee schedule.
"DATA",355.1,40,14,0)
^355.14D^1^1
"DATA",355.1,40,14,1,0)
3100601
"DATA",355.1,40,14,1,1,0)
^355.141^2^2
"DATA",355.1,40,14,1,1,1,0)
PR
"DATA",355.1,40,14,1,1,1,1,0)
^355.1411^3^3
"DATA",355.1,40,14,1,1,1,1,1,0)
1^100^100
"DATA",355.1,40,14,1,1,1,1,2,0)
2^100^100
"DATA",355.1,40,14,1,1,1,1,3,0)
3^100^100
"DATA",355.1,40,14,1,1,2,0)
CO
"DATA",355.1,40,14,1,1,2,1,0)
^355.1411^1^1
"DATA",355.1,40,14,1,1,2,1,1,0)
45^0^100
"DATA",355.1,44,0)
RETIREE^RETIREE^1
"DATA",355.1,44,10,0)
^355.11^2^2^3110428^^^^
"DATA",355.1,44,10,1,0)
Plan pays secondary to Medicare and covers co-insurance and deductibles
"DATA",355.1,44,10,2,0)
not paid by Medicare.
"DATA",355.1,44,14,0)
^355.14D^1^1
"DATA",355.1,44,14,1,0)
3100601
"DATA",355.1,44,14,1,1,0)
^355.141^2^2
"DATA",355.1,44,14,1,1,1,0)
PR
"DATA",355.1,44,14,1,1,1,1,0)
^355.1411^3^3
"DATA",355.1,44,14,1,1,1,1,1,0)
1^100^100
"DATA",355.1,44,14,1,1,1,1,2,0)
2^100^100
"DATA",355.1,44,14,1,1,1,1,3,0)
3^100^100
"DATA",355.1,44,14,1,1,2,0)
CO
"DATA",355.1,44,14,1,1,2,1,0)
^355.1411^1^1
"DATA",355.1,44,14,1,1,2,1,1,0)
45^0^100
"DATA",355.1,50,0)
SURGICAL EXPENSE INSURANCE^SEI^1
"DATA",355.1,50,10,0)
^355.11^3^3^3110428^^^
"DATA",355.1,50,10,1,0)
A health insurance policy that provides benefits toward the doctor's
"DATA",355.1,50,10,2,0)
operating fees.  Benefits usually consist of scheduled amounts for
"DATA",355.1,50,10,3,0)
each surgical procedure.
"DATA",355.1,50,14,0)
^355.14D^1^1
"DATA",355.1,50,14,1,0)
3100601
"DATA",355.1,50,14,1,1,0)
^355.141^2^2
"DATA",355.1,50,14,1,1,1,0)
PR
"DATA",355.1,50,14,1,1,1,1,0)
^355.1411^3^3
"DATA",355.1,50,14,1,1,1,1,1,0)
1^100^100
"DATA",355.1,50,14,1,1,1,1,2,0)
2^100^100
"DATA",355.1,50,14,1,1,1,1,3,0)
3^100^100
"DATA",355.1,50,14,1,1,2,0)
CO
"DATA",355.1,50,14,1,1,2,1,0)
^355.1411^1^1
"DATA",355.1,50,14,1,1,2,1,1,0)
45^0^100
"DATA",355.1,58,0)
MENTAL HEALTH^MH^12
"DATA",355.1,58,10,0)
^355.11^1^1^3110428^^
"DATA",355.1,58,10,1,0)
Plan which covers mental health care and substance abuse care.
"DATA",355.1,58,14,0)
^355.14D^1^1
"DATA",355.1,58,14,1,0)
3100601
"DATA",355.1,58,14,1,1,0)
^355.141^2^2
"DATA",355.1,58,14,1,1,1,0)
PR
"DATA",355.1,58,14,1,1,1,1,0)
^355.1411^3^3
"DATA",355.1,58,14,1,1,1,1,1,0)
1^100^100
"DATA",355.1,58,14,1,1,1,1,2,0)
2^100^100
"DATA",355.1,58,14,1,1,1,1,3,0)
3^100^100
"DATA",355.1,58,14,1,1,2,0)
CO
"DATA",355.1,58,14,1,1,2,1,0)
^355.1411^1^1
"DATA",355.1,58,14,1,1,2,1,1,0)
45^0^100
"DATA",355.1,62,0)
CARVE-OUT^COUT^1
"DATA",355.1,62,10,0)
^355.11^4^4^3110509^^^^
"DATA",355.1,62,10,1,0)
Employer provided benefits that deduct the amount that any other
"DATA",355.1,62,10,2,0)
insurance pays for a service from the plan's allowed charge for the same
"DATA",355.1,62,10,3,0)
service and pays the difference after the patient pays the annual
"DATA",355.1,62,10,4,0)
deductible.
"DATA",355.1,62,14,0)
^355.14D^1^1
"DATA",355.1,62,14,1,0)
3100601
"DATA",355.1,62,14,1,1,0)
^355.141^2^2
"DATA",355.1,62,14,1,1,1,0)
PR
"DATA",355.1,62,14,1,1,1,1,0)
^355.1411^3^3
"DATA",355.1,62,14,1,1,1,1,1,0)
1^100^100
"DATA",355.1,62,14,1,1,1,1,2,0)
2^100^100
"DATA",355.1,62,14,1,1,1,1,3,0)
3^100^100
"DATA",355.1,62,14,1,1,2,0)
CO
"DATA",355.1,62,14,1,1,2,1,0)
^355.1411^1^1
"DATA",355.1,62,14,1,1,2,1,1,0)
45^0^100
"DATA",355.1,64,0)
MEDICARE SECONDARY (NO B EXC)^MS^1
"DATA",355.1,64,10,0)
^355.11^3^3^3110428^^^
"DATA",355.1,64,10,1,0)
This is a plan for a group of retirees, purchased separately after they 
"DATA",355.1,64,10,2,0)
become Medicare eligible.  All members in this plan are retired and  
"DATA",355.1,64,10,3,0)
Medicare eligible and the benefits are not supplemental to Medicare. 
"DATA",355.1,64,14,0)
^355.14D^1^1
"DATA",355.1,64,14,1,0)
3100601
"DATA",355.1,64,14,1,1,0)
^355.141^1^1
"DATA",355.1,64,14,1,1,1,0)
PR
"DATA",355.1,64,14,1,1,1,1,0)
^355.1411^3^3
"DATA",355.1,64,14,1,1,1,1,1,0)
1^100^100
"DATA",355.1,64,14,1,1,1,1,2,0)
2^100^100
"DATA",355.1,64,14,1,1,1,1,3,0)
3^100^100
"DATA",355.1,65,0)
POINT OF SERVICE^POS^3
"DATA",355.1,65,10,0)
^355.11^3^3^3110428^^
"DATA",355.1,65,10,1,0)
This plan requires the selection of primary care physician
"DATA",355.1,65,10,2,0)
 and/or a primary care facility.  Benefits will usually be paid to out of  
"DATA",355.1,65,10,3,0)
network providers/facilities at a reduced rate.  
"DATA",355.1,65,14,0)
^355.14D^1^1
"DATA",355.1,65,14,1,0)
3100601
"DATA",355.1,65,14,1,1,0)
^355.141^2^2
"DATA",355.1,65,14,1,1,1,0)
PR
"DATA",355.1,65,14,1,1,1,1,0)
^355.1411^3^3
"DATA",355.1,65,14,1,1,1,1,1,0)
1^100^100
"DATA",355.1,65,14,1,1,1,1,2,0)
2^100^100
"DATA",355.1,65,14,1,1,1,1,3,0)
3^100^100
"DATA",355.1,65,14,1,1,2,0)
CO
"DATA",355.1,65,14,1,1,2,1,0)
^355.1411^1^1
"DATA",355.1,65,14,1,1,2,1,1,0)
45^0^100
"DATA",355.1,67,0)
MEDIGAP PLAN F^MGF^11^
"DATA",355.1,67,10,0)
^355.11^6^6^3110428^^
"DATA",355.1,67,10,1,0)
This is a standard MEDIGAP plan purchased individually as a
"DATA",355.1,67,10,2,0)
supplemental policy and is designed to cover amounts not covered 
"DATA",355.1,67,10,3,0)
by Medicare. These policies are not available to individuals 
"DATA",355.1,67,10,4,0)
not covered by Medicare and are usually purchased directly by the 
"DATA",355.1,67,10,5,0)
individual and not through an employer.  Services not covered by Medicare
"DATA",355.1,67,10,6,0)
are not covered by a supplemental plan.
"DATA",355.1,67,14,0)
^355.14D^1^1
"DATA",355.1,67,14,1,0)
3100601
"DATA",355.1,67,14,1,1,0)
^355.141^1^1
"DATA",355.1,67,14,1,1,1,0)
PR
"DATA",355.1,67,14,1,1,1,1,0)
^355.1411^3^3
"DATA",355.1,67,14,1,1,1,1,1,0)
1^100^100
"DATA",355.1,67,14,1,1,1,1,2,0)
2^100^100
"DATA",355.1,67,14,1,1,1,1,3,0)
3^100^100
"DATA",355.1,68,0)
MEDIGAP PLAN A^MGA^11
"DATA",355.1,68,10,0)
^355.11^6^6^3110428^^^^
"DATA",355.1,68,10,1,0)
This is a Standard MEDIGAP plan purchased individually as a supplemental 
"DATA",355.1,68,10,2,0)
policy and is designed to cover amounts not covered by  Medicare.  These 
"DATA",355.1,68,10,3,0)
policies are not available to individuals not covered by Medicare and 
"DATA",355.1,68,10,4,0)
are usually purchased directly by the individual and not through an 
"DATA",355.1,68,10,5,0)
employer.  Services not covered by Medicare are not covered by a 
"DATA",355.1,68,10,6,0)
supplemental plan.
"DATA",355.1,68,14,0)
^355.14D^1^1
"DATA",355.1,68,14,1,0)
3100601
"DATA",355.1,68,14,1,1,0)
^355.141^1^1
"DATA",355.1,68,14,1,1,1,0)
PR
"DATA",355.1,68,14,1,1,1,1,0)
^355.1411^3^2
"DATA",355.1,68,14,1,1,1,1,2,0)
2^100^100
"DATA",355.1,68,14,1,1,1,1,3,0)
3^100^100
"DATA",355.1,69,0)
MEDIGAP PLAN B^MGB^11
"DATA",355.1,69,10,0)
^355.11^6^6^3110428^^^
"DATA",355.1,69,10,1,0)
This is a standard MEDIGAP plan purchased individually as a supplemental 
"DATA",355.1,69,10,2,0)
policy and is designed to cover amounts not covered by Medicare.  
"DATA",355.1,69,10,3,0)
These policies are not available to individuals not 
"DATA",355.1,69,10,4,0)
covered by Medicare and are usually purchased directly by the 
"DATA",355.1,69,10,5,0)
individual and not through an employer.  Services not covered by Medicare 
"DATA",355.1,69,10,6,0)
are not covered by a supplemental plan.
"DATA",355.1,69,14,0)
^355.14D^1^1
"DATA",355.1,69,14,1,0)
3100601
"DATA",355.1,69,14,1,1,0)
^355.141^1^1
"DATA",355.1,69,14,1,1,1,0)
PR
"DATA",355.1,69,14,1,1,1,1,0)
^355.1411^3^3
"DATA",355.1,69,14,1,1,1,1,1,0)
1^100^0
"DATA",355.1,69,14,1,1,1,1,2,0)
2^100^100
"DATA",355.1,69,14,1,1,1,1,3,0)
3^100^100
"DATA",355.1,70,0)
MEDIGAP PLAN D^MGD^11
"DATA",355.1,70,10,0)
^355.11^6^6^3110428^^^
"DATA",355.1,70,10,1,0)
This is a standard MEDIGAP plan purchased individually as a
"DATA",355.1,70,10,2,0)
supplemental policy and is designed to cover amounts not covered 
"DATA",355.1,70,10,3,0)
by Medicare. These policies are not available to individuals 
"DATA",355.1,70,10,4,0)
not covered by Medicare and are usually purchased directly by the 
"DATA",355.1,70,10,5,0)
individual and not through an employer.  Services not covered by Medicare
"DATA",355.1,70,10,6,0)
are not covered by a supplemental plan.
"DATA",355.1,70,14,0)
^355.14D^1^1
"DATA",355.1,70,14,1,0)
3100601
"DATA",355.1,70,14,1,1,0)
^355.141^1^1
"DATA",355.1,70,14,1,1,1,0)
PR
"DATA",355.1,70,14,1,1,1,1,0)
^355.1411^3^3
"DATA",355.1,70,14,1,1,1,1,1,0)
1^100^0
"DATA",355.1,70,14,1,1,1,1,2,0)
2^100^100
"DATA",355.1,70,14,1,1,1,1,3,0)
3^100^100
"DATA",355.1,71,0)
MEDIGAP PLAN G^MGG^11
"DATA",355.1,71,10,0)
^355.11^6^6^3110428^^
"DATA",355.1,71,10,1,0)
This is a standard MEDIGAP plan purchased individually as a
"DATA",355.1,71,10,2,0)
supplemental policy and is designed to cover amounts not covered 
"DATA",355.1,71,10,3,0)
by Medicare. These policies are not available to individuals 
"DATA",355.1,71,10,4,0)
not covered by Medicare and are usually purchased directly by the 
"DATA",355.1,71,10,5,0)
individual and not through an employer.  Services not covered by Medicare
"DATA",355.1,71,10,6,0)
are not covered by a supplemental plan.
"DATA",355.1,71,14,0)
^355.14D^1^1
"DATA",355.1,71,14,1,0)
3100601
"DATA",355.1,71,14,1,1,0)
^355.141^1^1
"DATA",355.1,71,14,1,1,1,0)
PR
"DATA",355.1,71,14,1,1,1,1,0)
^355.1411^3^3
"DATA",355.1,71,14,1,1,1,1,1,0)
1^100^0
"DATA",355.1,71,14,1,1,1,1,2,0)
2^100^100
"DATA",355.1,71,14,1,1,1,1,3,0)
3^100^100
"DATA",355.1,72,0)
MEDIGAP PLAN K^MGK^11
"DATA",355.1,72,10,0)
^355.11^6^6^3110428^^
"DATA",355.1,72,10,1,0)
This is a standard MEDIGAP plan purchased individually as a
"DATA",355.1,72,10,2,0)
supplemental policy and is designed to cover amounts not covered 
"DATA",355.1,72,10,3,0)
by Medicare. These policies are not available to individuals 
"DATA",355.1,72,10,4,0)
not covered by Medicare and are usually purchased directly by the 
"DATA",355.1,72,10,5,0)
individual and not through an employer.  Services not covered by Medicare
"DATA",355.1,72,10,6,0)
are not covered by a supplemental plan.
"DATA",355.1,72,14,0)
^355.14D^1^1
"DATA",355.1,72,14,1,0)
3100601
"DATA",355.1,72,14,1,1,0)
^355.141^1^1
"DATA",355.1,72,14,1,1,1,0)
PR
"DATA",355.1,72,14,1,1,1,1,0)
^355.1411^3^3
"DATA",355.1,72,14,1,1,1,1,1,0)
1^50^0
"DATA",355.1,72,14,1,1,1,1,2,0)
2^100^50
"DATA",355.1,72,14,1,1,1,1,3,0)
3^100^50
"DATA",355.1,73,0)
MEDIGAP PLAN L^MGL^11
"DATA",355.1,73,10,0)
^355.11^6^6^3110428^^
"DATA",355.1,73,10,1,0)
This is a standard MEDIGAP plan purchased individually as a
"DATA",355.1,73,10,2,0)
supplemental policy and is designed to cover amounts not covered 
"DATA",355.1,73,10,3,0)
by Medicare. These policies are not available to individuals 
"DATA",355.1,73,10,4,0)
not covered by Medicare and are usually purchased directly by the 
"DATA",355.1,73,10,5,0)
individual and not through an employer.  Services not covered by Medicare
"DATA",355.1,73,10,6,0)
are not covered by a supplemental plan. 
"DATA",355.1,73,14,0)
^355.14D^1^1
"DATA",355.1,73,14,1,0)
3100601
"DATA",355.1,73,14,1,1,0)
^355.141^1^1
"DATA",355.1,73,14,1,1,1,0)
PR
"DATA",355.1,73,14,1,1,1,1,0)
^355.1411^3^3
"DATA",355.1,73,14,1,1,1,1,1,0)
1^75^0
"DATA",355.1,73,14,1,1,1,1,2,0)
2^100^75
"DATA",355.1,73,14,1,1,1,1,3,0)
3^100^75
"DATA",355.1,74,0)
MEDIGAP PLAN M^MGM^11
"DATA",355.1,74,10,0)
^355.11^6^6^3110428^^
"DATA",355.1,74,10,1,0)
This is a standard MEDIGAP plan purchased individually as a
"DATA",355.1,74,10,2,0)
supplemental policy and is designed to cover amounts not covered 
"DATA",355.1,74,10,3,0)
by Medicare. These policies are not available to individuals 
"DATA",355.1,74,10,4,0)
not covered by Medicare and are usually purchased directly by the 
"DATA",355.1,74,10,5,0)
individual and not through an employer.  Services not covered by Medicare
"DATA",355.1,74,10,6,0)
are not covered by a supplemental plan.
"DATA",355.1,74,14,0)
^355.14D^1^1
"DATA",355.1,74,14,1,0)
3100601
"DATA",355.1,74,14,1,1,0)
^355.141^1^1
"DATA",355.1,74,14,1,1,1,0)
PR
"DATA",355.1,74,14,1,1,1,1,0)
^355.1411^3^3
"DATA",355.1,74,14,1,1,1,1,1,0)
1^50^0
"DATA",355.1,74,14,1,1,1,1,2,0)
2^100^100
"DATA",355.1,74,14,1,1,1,1,3,0)
3^100^100
"DATA",355.1,75,0)
MEDIGAP PLAN N^MGN^11
"DATA",355.1,75,10,0)
^355.11^6^6^3110428^^
"DATA",355.1,75,10,1,0)
This is a standard MEDIGAP plan purchased individually as a
"DATA",355.1,75,10,2,0)
supplemental policy and is designed to cover amounts not covered 
"DATA",355.1,75,10,3,0)
by Medicare. These policies are not available to individuals 
"DATA",355.1,75,10,4,0)
not covered by Medicare and are usually purchased directly by the 
"DATA",355.1,75,10,5,0)
individual and not through an employer.  Services not covered by Medicare
"DATA",355.1,75,10,6,0)
are not covered by a supplemental plan.
"DATA",355.1,75,14,0)
^355.14D^1^1
"DATA",355.1,75,14,1,0)
3100601
"DATA",355.1,75,14,1,1,0)
^355.141^1^1
"DATA",355.1,75,14,1,1,1,0)
PR
"DATA",355.1,75,14,1,1,1,1,0)
^355.1411^3^3
"DATA",355.1,75,14,1,1,1,1,1,0)
1^100^0
"DATA",355.1,75,14,1,1,1,1,2,0)
2^100^100
"DATA",355.1,75,14,1,1,1,1,3,0)
3^100^100
"DATA",355.1,76,0)
MEDICARE SECONDARY (B EXC)^MS+^1
"DATA",355.1,76,10,0)
^355.11^4^4^3110428^^^
"DATA",355.1,76,10,1,0)
This is a plan for a group of retirees, purchased separately after they 
"DATA",355.1,76,10,2,0)
become Medicare eligible.  All members in this plan are retired and  
"DATA",355.1,76,10,3,0)
Medicare eligible and the benefits are not supplemental to Medicare.  
"DATA",355.1,76,10,4,0)
This plan includes Part B excess charges.
"DATA",355.1,76,14,0)
^355.14D^1^1
"DATA",355.1,76,14,1,0)
3100601
"DATA",355.1,76,14,1,1,0)
^355.141^2^2
"DATA",355.1,76,14,1,1,1,0)
PR
"DATA",355.1,76,14,1,1,1,1,0)
^355.1411^3^3
"DATA",355.1,76,14,1,1,1,1,1,0)
1^100^100
"DATA",355.1,76,14,1,1,1,1,2,0)
2^100^100
"DATA",355.1,76,14,1,1,1,1,3,0)
3^100^100
"DATA",355.1,76,14,1,1,2,0)
CO
"DATA",355.1,76,14,1,1,2,1,0)
^355.1411^1^1
"DATA",355.1,76,14,1,1,2,1,1,0)
45^0^100
"DATA",355.1,77,0)
MEDICARE SUPPLEMENTAL^MSP^1
"DATA",355.1,77,10,0)
^355.11^2^2^3110510^^^^
"DATA",355.1,77,10,1,0)
This is a plan purchased as a supplement to Medicare.  This
"DATA",355.1,77,10,2,0)
plan is intended to help cover co-insurance/deductible amounts.
"DATA",355.1,77,14,0)
^355.14D^1^1
"DATA",355.1,77,14,1,0)
3100601
"DATA",355.1,77,14,1,1,0)
^355.141^1^1
"DATA",355.1,77,14,1,1,1,0)
PR
"DATA",355.1,77,14,1,1,1,1,0)
^355.1411^3^3
"DATA",355.1,77,14,1,1,1,1,1,0)
1^100^100
"DATA",355.1,77,14,1,1,1,1,2,0)
2^100^100
"DATA",355.1,77,14,1,1,1,1,3,0)
3^100^100
"DATA",364.5,79,0)
N-TYPE OF ADMISSION^N^E^I^399^^^
"DATA",364.5,79,1)
S IBXDATA="" I (($$INPAT^IBCEF(IBXIEN,1))!($$INSTOUT^IBCEF(IBIFN))) S IBXDATA=$P($G(^DGCR(399,IBXIEN,"U")),U,8) S:'IBXDATA IBXDATA=9
"DATA",364.5,79,3,0)
^364.53^2^2^3110603^^^^
"DATA",364.5,79,3,1,0)
The type of admission (if an inpatient type bill) for bill entry IBXIEN.
"DATA",364.5,79,3,2,0)
If none found on the bill, asssume 9.
"DATA",364.6,107,0)
8^N^^105^1^^0^9^1^BLANK^0
"DATA",364.6,111,0)
8^N^^105^1^^0^10^1^BLANK^^1
"DATA",364.6,891,0)
8^N^^115^1^^0^10^1^BLANK^^1
"DATA",364.6,962,0)
8^N^^115^1^^0^12^1^BLANK^0^1
"DATA",364.6,1045,0)
8^N^^57^1^^0^1.5^2^Lab/Facility ID Setup^1^1^0
"DATA",364.6,1487,0)
2^N^^1^44^^1^49^9^CHARGES (BX-24F)
"DATA",364.6,1938,0)
8^N^^104.8^1^^0^2^2^Ambulance Addr Type Qual^0^1^0
"DATA",364.6,1939,0)
8^N^^104.9^1^^0^1^4^RECORD ID 'AMB1'^^1^0
"DATA",364.6,1940,0)
8^N^^104.8^1^^0^3^40^Ambulance Address 1^0^1^0
"DATA",364.6,1941,0)
8^N^^104.8^1^^0^4^30^Ambulance Address 2^0^1^0
"DATA",364.6,1942,0)
8^N^^104.8^1^^0^5^30^Ambulance City^0^1^0
"DATA",364.6,1943,0)
8^N^^104.8^1^^0^6^2^Ambulance State^0^1^0
"DATA",364.6,1944,0)
8^N^^104.8^1^^0^7^15^Ambulance Zip Code^0^1^0
"DATA",364.6,1945,0)
8^N^^104.9^1^^0^2^2^Amb Patient Weight Units^0^1^0
"DATA",364.6,1946,0)
8^N^^104.9^1^1^0^3^3^Amb Patient Weight^0^1^0
"DATA",364.6,1947,0)
8^N^^104.9^1^1^0^4^1^Amb Transport Reason Code^0^1^0
"DATA",364.6,1948,0)
8^N^^104.9^1^1^0^5^2^Amb Distance Units^0^1^0
"DATA",364.6,1949,0)
8^N^^104.9^1^^0^6^15^Amb Transport Distance^0^1^0
"DATA",364.6,1950,0)
8^N^^104.9^1^^0^7^80^Amb Round Trip Purpose^0^1^0
"DATA",364.6,1951,0)
8^N^^104.8^1^^0^8^60^Ambulance Drop Off Location^0^1^0
"DATA",364.6,2209,0)
8^N^^104.8^1^1^0^1.9^2^Ambulance Record Setup^1
"DATA",364.6,2210,0)
8^N^^104.8^1^1^0^99.9^1^AMB Cleanup Record^1
"DATA",364.6,2211,0)
8^N^^104.9^1^1^0^1.9^1^AMB1 Record Setup^1
"DATA",364.6,2212,0)
8^N^^104.9^1^^0^8^80^Amb Stretcher Purpose
"DATA",364.6,2213,0)
8^N^^104.9^1^^0^99.9^1^AMB1 Clean up^1
"DATA",364.6,2214,0)
8^N^^104.91^1^^0^1^4^RECORD ID 'AMB2'
"DATA",364.6,2215,0)
8^N^^104.91^1^^0^1.9^1^AMB2 Setup^1
"DATA",364.6,2216,0)
8^N^^104.91^1^^0^2^2^Amb Code Category^0
"DATA",364.6,2217,0)
8^N^^104.91^1^^0^3^1^Amb Certification Condition Indicator^0
"DATA",364.6,2218,0)
8^N^^104.91^1^^0^4^3^Amb Condition Code [1]^0
"DATA",364.6,2219,0)
8^N^^104.91^1^^0^5^3^Amb Condition Code [2]
"DATA",364.6,2220,0)
8^N^^104.91^1^^0^6^3^Amb Condition Code [3]
"DATA",364.6,2221,0)
8^N^^104.91^1^^0^7^3^Amb Condition Code [4]^0
"DATA",364.6,2222,0)
8^N^^104.91^1^^0^8^3^Amb Condition Code [5]^0
"DATA",364.6,2223,0)
8^N^^104.91^1^^0^99.9^1^AMB2 Clean up^1
"DATA",364.6,2224,0)
8^N^^115^1^^0^7^1^BLANK
"DATA",364.6,2225,0)
8^N^^106^1^^0^1^4^RECORD ID 'OI1A'^^1
"DATA",364.6,2226,0)
8^N^^106^1^^0^2^1^Payer Responsibility Sequence # Code^^1
"DATA",364.6,2227,0)
8^N^^106^1^^0^3^50^Other Payer Claim Control number^^1
"DATA",364.7,37,0)
139^N^16^^^^N
"DATA",364.7,37,1)
K:$$FT^IBCEF(IBXIEN)=2!'$$INPAT^IBCEF(IBXIEN) IBXDATA N Z S Z=0 F  S Z=$O(IBXDATA(Z)) K:'Z IBXDATA Q:'Z  I '$D(IBXDATA(Z,"M")) S IBXSAVE("PROC",Z)=IBXDATA(Z) I Z'<6 K IBXDATA Q
"DATA",364.7,37,3,0)
^364.73^6^6^3110603^^^^
"DATA",364.7,37,3,1,0)
This is a group data element so more than 1 occurrence of a value is
"DATA",364.7,37,3,2,0)
possible for the data element in the IBXDATA array.  If an institutional
"DATA",364.7,37,3,3,0)
bill or if the bill is professional and the procedure being extracted was
"DATA",364.7,37,3,4,0)
not added as a result of being a modifier with a 5-digit code starting with
"DATA",364.7,37,3,5,0)
0 ("M" node does not exist), save in an IBXSAVE array for later use.  No
"DATA",364.7,37,3,6,0)
output.
"DATA",364.7,103,0)
63^N^5^^^^N
"DATA",364.7,103,1)
S IBXDATA=$P($G(^DGCR(399,IBXIEN,"U")),U,8) S:'IBXDATA IBXDATA=9
"DATA",364.7,103,3,0)
^^1^1^3110630^
"DATA",364.7,103,3,1,0)
If data element's value is null, transmit 9.
"DATA",364.7,130,0)
111^N^5^^^^N
"DATA",364.7,205,0)
1041^N^274^^^^N^0
"DATA",364.7,205,1)
S IBXDATA=$$SNDS2^IBCEFP(.IBXDATA,2)
"DATA",364.7,205,3,0)
^^6^6^3111214^
"DATA",364.7,205,3,1,0)
If the service is performed at an outside facility, output the
"DATA",364.7,205,3,2,0)
service facility type of facility if defined for the outside facility.
"DATA",364.7,205,3,3,0)
If none defined, output the default of 'FA' for non-lab and 'LI' for lab.
"DATA",364.7,205,3,4,0)
With Patch IB*2.0*432 always send '77' if the record is created.
"DATA",364.7,205,3,5,0)
With Patch IB*2.0*447 always send if Facility Name is defined in SUB 
"DATA",364.7,205,3,6,0)
record.  Check by using $$SENDSF^IBCEF79(IBXIEN).
"DATA",364.7,206,0)
1042^N^274^^^^N^0
"DATA",364.7,206,1)
S IBXDATA=$$SNDS2^IBCEFP(.IBXDATA,3)
"DATA",364.7,206,3,0)
^^5^5^3111214^
"DATA",364.7,206,3,1,0)
Output the service facility entity as a non-person (2) if service was
"DATA",364.7,206,3,2,0)
performed at an outside facility.
"DATA",364.7,206,3,3,0)
With Patch IB*2.0*432 always send 2 if the record is created.
"DATA",364.7,206,3,4,0)
With Patch IB*2.0*447 always send 2 if the Facility Name is defined in 
"DATA",364.7,206,3,5,0)
the SUB record. Determine by using $$SENDSF^IBCEF79(IBXIEN).
"DATA",364.7,209,0)
1045^N^5^^^^N^0
"DATA",364.7,209,1)
D CLEANUP^IBCEFP1(.IBXSAVE) D:$$SNDS2^IBCEFP(.IBXDATA,1.5) ALLIDS^IBCEFP(IBXIEN,.IBXSAVE,1) S IBXDATA=$P($G(IBXSAVE("LAB/FAC",IBXIEN,"C",1,0)),U,1)
"DATA",364.7,209,3,0)
^364.73^3^3^3101104^^
"DATA",364.7,209,3,1,0)
Build the IBXSAVE array with the data needed to complete the SUB2 record.
"DATA",364.7,209,3,2,0)
Only build if $$SENDSF^IBCEF79(IBXIEN) is true.  We only send 
"DATA",364.7,209,3,3,0)
SUB2 if there is a SUB record.
"DATA",364.7,1015,0)
1014^N^5^^^^N
"DATA",364.7,1015,1)
S IBXDATA="447.0" I '$$PROD^XUPROD(1) S $E(IBXDATA,11)="D"
"DATA",364.7,1015,3,0)
^364.73^7^7^3111108^^^^
"DATA",364.7,1015,3,1,0)
This field contains the VistA IB patch# that pertains to the
"DATA",364.7,1015,3,2,0)
applicable changes in the claim map.  Austin uses this field to determine
"DATA",364.7,1015,3,3,0)
which set of EDI claim maps to use when processing the EDI claims.
"DATA",364.7,1015,3,4,0)

"DATA",364.7,1015,3,5,0)
If the EDI claims are being transmitted from a non-production account,
"DATA",364.7,1015,3,6,0)
then the "D" in the 11th position indicates to Austin that it is test
"DATA",364.7,1015,3,7,0)
data.
"DATA",364.7,1403,0)
1703^N^16^^^^N
"DATA",364.7,1403,1)
K:'$$INPAT^IBCEF(IBXIEN) IBXDATA N Z S Z="" F  S Z=$O(IBXDATA(Z)) Q:'Z  S $P(IBXDATA(Z),U,2)=$$DATE^IBCF3($P(IBXDATA(Z),U,2)),IBXSAVE("PROC",Z)=IBXDATA(Z) K IBXDATA(Z)
"DATA",364.7,1403,3,0)
^364.73^5^5^3110603^^^^
"DATA",364.7,1403,3,1,0)
This is a group data element so more than one occurrence of IBXDATA(n) is
"DATA",364.7,1403,3,2,0)
possible.  Save off the procedures in the IBXSAVE array.  Six procedures
"DATA",364.7,1403,3,3,0)
will fit on a single page of a bill.  If more than 6 procedure codes are
"DATA",364.7,1403,3,4,0)
on the bill, multiple pages are used.  The format of the IBXSAVE array is:
"DATA",364.7,1403,3,5,0)
   the actual code for the ICD9 or ICD0 code^proc date formatted as MMDDYY
"DATA",364.7,1638,0)
1938^N^5^^^^N^0
"DATA",364.7,1638,1)
N DATA,NODE,Z K IBXDATA S Z=0 F NODE="U5","U6" S DATA=$G(IBXSAVE("AMB",NODE)) I $L(DATA) S Z=Z+1,IBXDATA(Z)=$S(NODE="U5":"PW",1:45) D:Z>1 ID^IBCEF2(Z,"AMB")
"DATA",364.7,1639,0)
1939^N^131^^^^N^0
"DATA",364.7,1639,1)
S IBXDATA="AMB1"
"DATA",364.7,1640,0)
1940^N^5^^^^N^0
"DATA",364.7,1640,1)
N DATA,NODE,Z K IBXDATA S Z=0 F NODE="U5","U6" S DATA=$G(IBXSAVE("AMB",NODE)) I $L(DATA) S Z=Z+1,IBXDATA(Z)=$P(IBXSAVE("AMB",NODE),U,2)
"DATA",364.7,1640,3,0)
^^1^1^3110609^
"DATA",364.7,1640,3,1,0)
Gets the Ambulance Address 1 from the 2nd piece of the data string.
"DATA",364.7,1641,0)
1941^N^5^^^^N^0
"DATA",364.7,1641,1)
N DATA,NODE,Z K IBXDATA S Z=0 F NODE="U5","U6" S DATA=$G(IBXSAVE("AMB",NODE)) I $L(DATA) S Z=Z+1,IBXDATA(Z)=$P(IBXSAVE("AMB",NODE),U,3)
"DATA",364.7,1641,3,0)
^^1^1^3110609^
"DATA",364.7,1641,3,1,0)
Gets the Ambulance Address 2 from the 3rd piece of the data string.
"DATA",364.7,1642,0)
1942^N^5^^^^N^0
"DATA",364.7,1642,1)
N DATA,NODE,Z K IBXDATA S Z=0 F NODE="U5","U6" S DATA=$G(IBXSAVE("AMB",NODE)) I $L(DATA) S Z=Z+1,IBXDATA(Z)=$P(IBXSAVE("AMB",NODE),U,4)
"DATA",364.7,1642,3,0)
^^1^1^3110609^
"DATA",364.7,1642,3,1,0)
Gets the Ambulance City from the 4th piece of the data string
"DATA",364.7,1643,0)
1943^N^5^^^^N^0
"DATA",364.7,1643,1)
N DATA,NODE,Z K IBXDATA S Z=0 F NODE="U5","U6" S DATA=$G(IBXSAVE("AMB",NODE)) I $L(DATA) S Z=Z+1,IBXDATA(Z)=$$STATE^IBCEFG1($P(IBXSAVE("AMB",NODE),U,5))
"DATA",364.7,1643,3,0)
^364.73^1^1^3110610^^
"DATA",364.7,1643,3,1,0)
Gets the Ambulance State from the 5th piece of the data string.
"DATA",364.7,1644,0)
1944^N^5^^^^N^0
"DATA",364.7,1644,1)
N DATA,NODE,Z K IBXDATA S Z=0 F NODE="U5","U6" S DATA=$G(IBXSAVE("AMB",NODE)) I $L(DATA) S Z=Z+1,IBXDATA(Z)=$P(IBXSAVE("AMB",NODE),U,6)
"DATA",364.7,1644,3,0)
^^1^1^3110609^
"DATA",364.7,1644,3,1,0)
Gets the Ambulance Zip code from the 6th piece of the data string.
"DATA",364.7,1645,0)
1945^N^5^^^^N^0
"DATA",364.7,1645,1)
K IBXDATA I $P($G(IBXSAVE("AMB","U7")),U,1) S IBXDATA="LB"
"DATA",364.7,1646,0)
1946^N^5^^^^N^0
"DATA",364.7,1646,1)
S IBXDATA=$P($G(IBXSAVE("AMB","U7")),U,1) I IBXDATA="" K IBXDATA
"DATA",364.7,1647,0)
1947^N^5^^^^N^0
"DATA",364.7,1647,1)
S IBXDATA=$P($G(IBXSAVE("AMB","U7")),U,2) S:IBXDATA IBXDATA=$$GET1^DIQ(399,IBXIEN,288,IBXDATA) I IBXDATA="" K IBXDATA
"DATA",364.7,1647,3,0)
^364.73^1^1^3110809^^
"DATA",364.7,1647,3,1,0)
Ambulance Transport Reason Code
"DATA",364.7,1648,0)
1948^N^5^^^^N^0
"DATA",364.7,1648,1)
K IBXDATA I $P($G(IBXSAVE("AMB","U7")),U,3)'="" S IBXDATA="DH"
"DATA",364.7,1648,3,0)
^364.73^1^1^3110809^^
"DATA",364.7,1648,3,1,0)
Ambulance Distance Units.  Only if Ambulance distance is not null.
"DATA",364.7,1649,0)
1949^N^5^^^^N^0
"DATA",364.7,1649,1)
S IBXDATA=$P($G(IBXSAVE("AMB","U7")),U,3) I IBXDATA="" K IBXDATA
"DATA",364.7,1649,3,0)
^364.73^1^1^3110809^^
"DATA",364.7,1649,3,1,0)
Ambulance Transport Distance
"DATA",364.7,1650,0)
1950^N^5^^^^N^0
"DATA",364.7,1650,1)
S IBXDATA=$P($G(IBXSAVE("AMB","U7")),U,4) I IBXDATA="" K IBXDATA
"DATA",364.7,1650,3,0)
^364.73^1^1^3110809^^
"DATA",364.7,1650,3,1,0)
Ambulance Round Trip Purpose
"DATA",364.7,1651,0)
1951^N^5^^^^N^0
"DATA",364.7,1651,1)
N DATA,NODE,Z K IBXDATA S Z=0 F NODE="U5","U6" S DATA=$G(IBXSAVE("AMB",NODE)) I $L(DATA) S Z=Z+1,IBXDATA(Z)=$P(IBXSAVE("AMB",NODE),U,1)
"DATA",364.7,1651,3,0)
^364.73^3^3^3110609^^
"DATA",364.7,1651,3,1,0)
Get the Ambulance Drop Off Location from the 1st piece of the data string.
"DATA",364.7,1651,3,2,0)
This is from the Drop Off record ("U6") only.  Will always be blank on the
"DATA",364.7,1651,3,3,0)
pick up record.
"DATA",364.7,1909,0)
2209^N^5^^^^N
"DATA",364.7,1909,1)
D AMB^IBCEFP(IBXIEN,.IBXSAVE)
"DATA",364.7,1909,3,0)
^^1^1^3110609^
"DATA",364.7,1909,3,1,0)
Set up Data fields for AMB record(s)
"DATA",364.7,1910,0)
2210^N^5^^^^N
"DATA",364.7,1910,1)
K IBXSAVE("AMB")
"DATA",364.7,1910,3,0)
^364.73^1^1^3110609^^
"DATA",364.7,1910,3,1,0)
Clean up the IBXSAVE array
"DATA",364.7,1911,0)
2211^N^5^^^^N
"DATA",364.7,1911,1)
D AMB^IBCEFP(IBXIEN,.IBXSAVE)
"DATA",364.7,1911,3,0)
^^1^1^3110610^
"DATA",364.7,1911,3,1,0)
Set up IBXSAVE Array for AMB1 record
"DATA",364.7,1912,0)
2212^N^5^^^^N
"DATA",364.7,1912,1)
S IBXDATA=$P($G(IBXSAVE("AMB","U7")),U,5) I IBXDATA="" K IBXDATA
"DATA",364.7,1912,3,0)
^364.73^1^1^3110809^^
"DATA",364.7,1912,3,1,0)
Ambulance Stretcher Purpose
"DATA",364.7,1913,0)
2213^N^5^^^^N^0
"DATA",364.7,1913,1)
K IBXSAVE("AMB")
"DATA",364.7,1913,3,0)
^364.73^1^1^3110610^^^^
"DATA",364.7,1913,3,1,0)
Clean up after Ambulance record creation
"DATA",364.7,1914,0)
2214^N^131^^^^N
"DATA",364.7,1914,1)
S IBXDATA="AMB2"
"DATA",364.7,1914,3,0)
^^1^1^3110610^
"DATA",364.7,1914,3,1,0)
AMB2 Record ID field
"DATA",364.7,1915,0)
2215^N^5^^^^N
"DATA",364.7,1915,1)
D AMB^IBCEFP(IBXIEN,.IBXSAVE)
"DATA",364.7,1915,3,0)
^^1^1^3110610^
"DATA",364.7,1915,3,1,0)
Set up IBXSAVE array with Ambulance data
"DATA",364.7,1916,0)
2216^N^5^^^^N
"DATA",364.7,1916,1)
K IBXDATA I $D(IBXSAVE("AMB","U9")) S IBXDATA="07"
"DATA",364.7,1916,3,0)
^^1^1^3110610^
"DATA",364.7,1916,3,1,0)
Set up Amb Code Categorywith "07" if data exists for this record.
"DATA",364.7,1917,0)
2217^N^5^^^^N
"DATA",364.7,1917,1)
K IBXDATA I $D(IBXSAVE("AMB","U9")) S IBXDATA="Y"
"DATA",364.7,1917,3,0)
^^2^2^3110610^
"DATA",364.7,1917,3,1,0)
Set Y into field Amb Certification Condition Indicator if data exists for 
"DATA",364.7,1917,3,2,0)
the record.
"DATA",364.7,1918,0)
2218^N^5^^^^N
"DATA",364.7,1918,1)
S IBXDATA=$G(IBXSAVE("AMB","U9",1)) I IBXDATA="" K IBXDATA
"DATA",364.7,1918,3,0)
^^1^1^3110610^
"DATA",364.7,1918,3,1,0)
Amb Condition code 1 data
"DATA",364.7,1919,0)
2219^N^5^^^^N
"DATA",364.7,1919,1)
S IBXDATA=$G(IBXSAVE("AMB","U9",2)) I IBXDATA="" K IBXDATA
"DATA",364.7,1919,3,0)
^364.73^1^1^3110610^
"DATA",364.7,1919,3,1,0)
Amb Condition code 2
"DATA",364.7,1920,0)
2220^N^5^^^^N
"DATA",364.7,1920,1)
S IBXDATA=$G(IBXSAVE("AMB","U9",3)) I IBXDATA="" K IBXDATA
"DATA",364.7,1920,3,0)
^^1^1^3110610^
"DATA",364.7,1920,3,1,0)
Amb Condition Code 3
"DATA",364.7,1921,0)
2221^N^5^^^^N
"DATA",364.7,1921,1)
S IBXDATA=$G(IBXSAVE("AMB","U9",4)) I IBXDATA="" K IBXDATA
"DATA",364.7,1921,3,0)
^^1^1^3110610^
"DATA",364.7,1921,3,1,0)
Amb Condition Code 4
"DATA",364.7,1922,0)
2222^N^5^^^^N
"DATA",364.7,1922,1)
S IBXDATA=$G(IBXSAVE("AMB","U9",5)) I IBXDATA="" K IBXDATA
"DATA",364.7,1922,3,0)
^^1^1^3110610^
"DATA",364.7,1922,3,1,0)
Amb Condition Code 5
"DATA",364.7,1923,0)
2223^N^5^^^^N
"DATA",364.7,1923,1)
K IBXSAVE("AMB")
"DATA",364.7,1923,3,0)
^^1^1^3110610^
"DATA",364.7,1923,3,1,0)
Clean up after AMB2 record.
"DATA",364.7,1924,0)
2224^N^5^^^^N
"DATA",364.7,1924,1)
K IBXDATA
"DATA",364.7,1925,0)
2225^N^131^^^^N
"DATA",364.7,1925,1)
S IBXDATA="OI1A"
"DATA",364.7,1925,3,0)
^^1^1^3111025^
"DATA",364.7,1925,3,1,0)
Continuation of Record OI1 (Other Subscriber and Other Payer Data)
"DATA",364.7,1926,0)
2226^N^101^^^^N
"DATA",364.7,1926,1)
N IBZ,Z,Z0 M IBZ=IBXDATA K IBXDATA I $O(IBXSAVE(1,0)) S (Z,Z0)=0 F  S Z=$O(IBXSAVE(1,Z)) Q:'Z  S Z0=Z0+1,IBXDATA(Z0)=IBXSAVE(1,Z) I Z0>1 D ID^IBCEF2(Z0,"OI1A")
"DATA",364.7,1926,3,0)
^^8^8^3111025^
"DATA",364.7,1926,3,1,0)
This is a group data element so more than 1 occurrence of a value is
"DATA",364.7,1926,3,2,0)
possible for the data element in the IBXDATA array. The IBXSAVE(1)
"DATA",364.7,1926,3,3,0)
variable holds the indicator of which insurance
"DATA",364.7,1926,3,4,0)
[(P)rimary/(S)econdary/(T)ertiary] is currently responsible for the bill.
"DATA",364.7,1926,3,5,0)
Using this data as a guide, the next insurance for the primary is 
"DATA",364.7,1926,3,6,0)
secondary, then tertiary.  For secondary, it's primary then tertiary, and
"DATA",364.7,1926,3,7,0)
for tertiary, it's primary, then secondary. For other than the first
"DATA",364.7,1926,3,8,0)
occurrence, the RECORD ID 'OI1A' must be output.
"DATA",364.7,1927,0)
2227^N^56^^^^N
"DATA",364.7,1927,1)
N Z,Z1,IBZ M IBZ=IBXDATA K IBXDATA F Z=1,2 I $D(^DGCR(399,IBXIEN,"I"_(Z+1))),$G(IBZ(Z))'="" S IBXDATA(Z)=IBZ(Z)
"DATA",364.7,1927,3,0)
^^10^10^3111025^
"DATA",364.7,1927,3,1,0)
This is a group data element so more than 1 occurrence of a value is
"DATA",364.7,1927,3,2,0)
possible for the data element in the IBXDATA array. If any other insurance
"DATA",364.7,1927,3,3,0)
form locator 64 data is found, the data is output.
"DATA",364.7,1927,3,4,0)
  
"DATA",364.7,1927,3,5,0)
 This is OI1A-03 also known as the ICN/DCN for the MRA secondary claims. 
"DATA",364.7,1927,3,6,0)
If there is data here in OI1A-03, then we cannot transmit the Other Payer
"DATA",364.7,1927,3,7,0)
secondary ID and qualifier #2.  This is in the OI6 segment, pieces 7 and 
"DATA",364.7,1927,3,8,0)
8. For this calculation, OI6-6.9 is set-up very similar to this OI1A-03
"DATA",364.7,1927,3,9,0)
piece to see if there is an ICN/DCN present.   So any changes here should
"DATA",364.7,1927,3,10,0)
also be made to OI6-6.9 as a calculate only field.
"FIA",350.8)
IB ERROR
"FIA",350.8,0)
^IBE(350.8,
"FIA",350.8,0,0)
350.8I
"FIA",350.8,0,1)
n^n^f^^n^^y^o^n
"FIA",350.8,0,10)

"FIA",350.8,0,11)
I $$INC3508^IBY447PR(Y)
"FIA",350.8,0,"RLRO")

"FIA",350.8,0,"VR")
2.0^IB
"FIA",350.8,350.8)
0
"FIA",353)
BILL FORM TYPE
"FIA",353,0)
^IBE(353,
"FIA",353,0,0)
353
"FIA",353,0,1)
y^y^p^^^^n^^n
"FIA",353,0,10)

"FIA",353,0,11)

"FIA",353,0,"RLRO")

"FIA",353,0,"VR")
2.0^IB
"FIA",353,353)
1
"FIA",353,353,2.09)

"FIA",353.4)
TRANSPORT REASON CODE
"FIA",353.4,0)
^IBE(353.4,
"FIA",353.4,0,0)
353.4I
"FIA",353.4,0,1)
y^y^f^^n^^y^o^n
"FIA",353.4,0,10)

"FIA",353.4,0,11)

"FIA",353.4,0,"RLRO")

"FIA",353.4,0,"VR")
2.0^IB
"FIA",353.4,353.4)
0
"FIA",353.5)
AMBULANCE CONDITION INDICATORS
"FIA",353.5,0)
^IBE(353.5,
"FIA",353.5,0,0)
353.5I
"FIA",353.5,0,1)
y^y^f^^n^^y^o^n
"FIA",353.5,0,10)

"FIA",353.5,0,11)

"FIA",353.5,0,"RLRO")

"FIA",353.5,0,"VR")
2.0^IB
"FIA",353.5,353.5)
0
"FIA",355.1)
TYPE OF PLAN
"FIA",355.1,0)
^IBE(355.1,
"FIA",355.1,0,0)
355.1I
"FIA",355.1,0,1)
y^y^f^^n^^y^o^n
"FIA",355.1,0,10)

"FIA",355.1,0,11)
I $$INC3551^IBY447PR(Y)
"FIA",355.1,0,"RLRO")

"FIA",355.1,0,"VR")
2.0^IB
"FIA",355.1,355.1)
0
"FIA",355.1,355.11)
0
"FIA",355.1,355.14)
0
"FIA",355.1,355.141)
0
"FIA",355.1,355.1411)
0
"FIA",355.93)
IB NON/OTHER VA BILLING PROVIDER
"FIA",355.93,0)
^IBA(355.93,
"FIA",355.93,0,0)
355.93I
"FIA",355.93,0,1)
y^n^p^^^^n^^n
"FIA",355.93,0,10)

"FIA",355.93,0,11)

"FIA",355.93,0,"RLRO")

"FIA",355.93,0,"VR")
2.0^IB
"FIA",355.93,355.93)
1
"FIA",355.93,355.93,.16)

"FIA",361.1)
EXPLANATION OF BENEFITS
"FIA",361.1,0)
^IBM(361.1,
"FIA",361.1,0,0)
361.1PI
"FIA",361.1,0,1)
y^y^p^^^^n^^n
"FIA",361.1,0,10)

"FIA",361.1,0,11)

"FIA",361.1,0,"RLRO")

"FIA",361.1,0,"VR")
2.0^IB
"FIA",361.1,361.1)
1
"FIA",361.1,361.1,.04)

"FIA",361.1,361.1,.05)

"FIA",364.5)
IB DATA ELEMENT DEFINITION
"FIA",364.5,0)
^IBA(364.5,
"FIA",364.5,0,0)
364.5I
"FIA",364.5,0,1)
n^n^f^^y^^y^o^n
"FIA",364.5,0,10)

"FIA",364.5,0,11)
I $$INCLUDE^IBY447PR(5,Y)
"FIA",364.5,0,"RLRO")

"FIA",364.5,0,"VR")
2.0^IB
"FIA",364.5,364.5)
0
"FIA",364.5,364.53)
0
"FIA",364.6)
IB FORM SKELETON DEFINITION
"FIA",364.6,0)
^IBA(364.6,
"FIA",364.6,0,0)
364.6IP
"FIA",364.6,0,1)
n^n^f^^y^^y^o^n
"FIA",364.6,0,10)

"FIA",364.6,0,11)
I $$INCLUDE^IBY447PR(6,Y)
"FIA",364.6,0,"RLRO")

"FIA",364.6,0,"VR")
2.0^IB
"FIA",364.6,364.6)
0
"FIA",364.7)
IB FORM FIELD CONTENT
"FIA",364.7,0)
^IBA(364.7,
"FIA",364.7,0,0)
364.7IP
"FIA",364.7,0,1)
n^n^f^^y^^y^o^n
"FIA",364.7,0,10)

"FIA",364.7,0,11)
I $$INCLUDE^IBY447PR(7,Y)
"FIA",364.7,0,"RLRO")

"FIA",364.7,0,"VR")
2.0^IB
"FIA",364.7,364.7)
0
"FIA",364.7,364.73)
0
"FIA",399)
BILL/CLAIMS
"FIA",399,0)
^DGCR(399,
"FIA",399,0,0)
399I
"FIA",399,0,1)
y^y^p^^^^n^^n
"FIA",399,0,10)

"FIA",399,0,11)

"FIA",399,0,"RLRO")

"FIA",399,0,"VR")
2.0^IB
"FIA",399,399)
1
"FIA",399,399,.05)

"FIA",399,399,.27)

"FIA",399,399,287)

"FIA",399,399,288)

"FIA",399,399,289)

"FIA",399,399,290)

"FIA",399,399,291)

"FIA",399,399,292)

"FIA",399,399,304)

"FIA",399,399.0292)
0
"FIA",399,399.0304)
1
"FIA",399,399.0304,.01)

"FIA",399,399.0304,5)

"FIA",399,399.042)
1
"FIA",399,399.042,.02)

"FIA",399,399.042,.16)

"INI")
IBY447PR
"INIT")
IBY447PO
"IX",355.1,355.1,"B",0)
355.1^B^"B" Regular Cross-Reference of .01 field^R^^F^IR^I^355.1^^^^^LS
"IX",355.1,355.1,"B",.1,0)
^^3^3^3090615^^
"IX",355.1,355.1,"B",.1,1,0)
The "B" cross-reference has been updated to allow for a full 40-character
"IX",355.1,355.1,"B",.1,2,0)
lookup instead of being limited to the first 30 characters. This is done
"IX",355.1,355.1,"B",.1,3,0)
to prevent a potential lookup error by Fileman DBS calls.
"IX",355.1,355.1,"B",1)
S ^IBE(355.1,"B",$E(X,1,40),DA)=""
"IX",355.1,355.1,"B",2)
K ^IBE(355.1,"B",$E(X,1,40),DA)
"IX",355.1,355.1,"B",2.5)
K ^IBE(355.1,"B")
"IX",355.1,355.1,"B",11.1,0)
^.114IA^1^1
"IX",355.1,355.1,"B",11.1,1,0)
1^F^355.1^.01^40^1^F
"IX",355.1,355.14,"AEDT",0)
355.14^AEDT^Effective Date Index^MU^^R^IR^W^355.1411^^^^^S
"IX",355.1,355.14,"AEDT",.1,0)
^^11^11^3110524^
"IX",355.1,355.14,"AEDT",.1,1,0)
This index is used to find the part A and B percentages paid for a type 
"IX",355.1,355.14,"AEDT",.1,2,0)
of plan based on the group and reason codes entered on the MRA.
"IX",355.1,355.14,"AEDT",.1,3,0)
This index uses computed code:
"IX",355.1,355.14,"AEDT",.1,4,0)
X(3):  Computed Code: S X=$P($G(^IBE(355.1,DA(3),14,DA(2),0)),U)
"IX",355.1,355.14,"AEDT",.1,5,0)
which sets X(3) = to the external value of the Group Code
"IX",355.1,355.14,"AEDT",.1,6,0)
and
"IX",355.1,355.14,"AEDT",.1,7,0)
X(4):  Computed Code: S X=$P($G(^IBE(355.1,DA(3),14,DA(2),1,DA(1),0)),U)
"IX",355.1,355.14,"AEDT",.1,8,0)
which sets X(4) = to the external value of the Reason Code.
"IX",355.1,355.14,"AEDT",.1,9,0)
This allows for an efficient match between the Group and Reason Codes on 
"IX",355.1,355.14,"AEDT",.1,10,0)
the patient's MRA and the Group and Reason Codes for the patient's 
"IX",355.1,355.14,"AEDT",.1,11,0)
supplemental type of plan.
"IX",355.1,355.14,"AEDT",1)
S ^IBE(355.1,DA(3),14,"AEDT",X(3),X(4),X(5))=X(1)_U_X(2)
"IX",355.1,355.14,"AEDT",2)
K ^IBE(355.1,DA(3),14,"AEDT",X(3),X(4),X(5))
"IX",355.1,355.14,"AEDT",11.1,0)
^.114IA^8^5
"IX",355.1,355.14,"AEDT",11.1,4,0)
1^F^355.1411^1^^^F
"IX",355.1,355.14,"AEDT",11.1,5,0)
2^F^355.1411^2^^^F
"IX",355.1,355.14,"AEDT",11.1,6,0)
3^C
"IX",355.1,355.14,"AEDT",11.1,6,1.5)
S X=$P($G(^IBE(355.1,DA(3),14,DA(2),0)),U)
"IX",355.1,355.14,"AEDT",11.1,7,0)
4^C
"IX",355.1,355.14,"AEDT",11.1,7,1.5)
S X=$P($G(^IBE(355.1,DA(3),14,DA(2),1,DA(1),0)),U)
"IX",355.1,355.14,"AEDT",11.1,8,0)
5^F^355.1411^.01^^^F
"IX",361.1,361.1,"AEDT",0)
361.1^AEDT^EOB TYPE / DATE AND TIME^R^^R^IR^I^361.1^^^^^S
"IX",361.1,361.1,"AEDT",.1,0)
^^1^1^3110606^^
"IX",361.1,361.1,"AEDT",.1,1,0)
Creates an index by EOB TYPE and DATE/TIME.
"IX",361.1,361.1,"AEDT",1)
S ^IBM(361.1,"AEDT",X(1),X(2),DA)=""
"IX",361.1,361.1,"AEDT",2)
K ^IBM(361.1,"AEDT",X(1),X(2),DA)
"IX",361.1,361.1,"AEDT",2.5)
K ^IBM(361.1,"AEDT")
"IX",361.1,361.1,"AEDT",11.1,0)
^.114IA^2^2
"IX",361.1,361.1,"AEDT",11.1,1,0)
1^F^361.1^.04^^1^F
"IX",361.1,361.1,"AEDT",11.1,1,3)

"IX",361.1,361.1,"AEDT",11.1,2,0)
2^F^361.1^.05^^2^F
"IX",361.1,361.1,"AEDT",11.1,2,3)

"IX",361.1,361.1,"AMRA",0)
361.1^AMRA^Index by EOB type and Review Status^R^^R^IR^I^361.1^^^^^S
"IX",361.1,361.1,"AMRA",1)
S ^IBM(361.1,"AMRA",X(1),X(2),DA)=""
"IX",361.1,361.1,"AMRA",2)
K ^IBM(361.1,"AMRA",X(1),X(2),DA)
"IX",361.1,361.1,"AMRA",2.5)
K ^IBM(361.1,"AMRA")
"IX",361.1,361.1,"AMRA",11.1,0)
^.114IA^2^2
"IX",361.1,361.1,"AMRA",11.1,1,0)
1^F^361.1^.04^^1^F
"IX",361.1,361.1,"AMRA",11.1,2,0)
2^F^361.1^.16^^2^F
"IX",361.1,361.1,"ATIN",0)
361.1^ATIN^Xref by date filed and transferred from^R^^R^IR^I^361.1^^^^^S
"IX",361.1,361.1,"ATIN",1)
S ^IBM(361.1,"ATIN",X(1),$E(X(2),1,30),DA)=""
"IX",361.1,361.1,"ATIN",2)
K ^IBM(361.1,"ATIN",X(1),$E(X(2),1,30),DA)
"IX",361.1,361.1,"ATIN",2.5)
K ^IBM(361.1,"ATIN")
"IX",361.1,361.1,"ATIN",11.1,0)
^.114IA^2^2
"IX",361.1,361.1,"ATIN",11.1,1,0)
1^F^361.1^.05^^1^F
"IX",361.1,361.1,"ATIN",11.1,1,3)

"IX",361.1,361.1,"ATIN",11.1,2,0)
2^F^361.1^7.01^30^2^F
"IX",361.1,361.1,"ATIN",11.1,2,3)

"IX",361.1,361.1,"ATRID",0)
361.1^ATRID^Xref by bank trace # and ins co id for uniqueness^R^^R^IR^I^361.1^^^^^S
"IX",361.1,361.1,"ATRID",1)
S ^IBM(361.1,"ATRID",$E(X(1),1,50),$E(X(2),1,30),DA)=""
"IX",361.1,361.1,"ATRID",1.4)
I 'X(3)
"IX",361.1,361.1,"ATRID",2)
K ^IBM(361.1,"ATRID",$E(X(1),1,50),$E(X(2),1,30),DA)
"IX",361.1,361.1,"ATRID",2.5)
K ^IBM(361.1,"ATRID")
"IX",361.1,361.1,"ATRID",11.1,0)
^.114IA^3^3
"IX",361.1,361.1,"ATRID",11.1,1,0)
1^F^361.1^.07^50^1^F
"IX",361.1,361.1,"ATRID",11.1,1,3)

"IX",361.1,361.1,"ATRID",11.1,2,0)
2^F^361.1^.03^30^2^F
"IX",361.1,361.1,"ATRID",11.1,2,3)

"IX",361.1,361.1,"ATRID",11.1,3,0)
3^F^361.1^.04^^^F
"IX",361.1,361.1,"ATRID",11.1,3,3)

"IX",364.6,364.6,"ALL",0)
364.6^ALL^Allows for identification of local override fields that apply to ALL^MU^^F^IR^I^364.6^^^^^S
"IX",364.6,364.6,"ALL",1)
S ^IBA(364.7,"ALL",DA,X2(5))=""
"IX",364.6,364.6,"ALL",1.4)
I X2(4)'="L"!'X2(5)!(X2(2)'="")!(X2(3)'="")!'X2(1) S X=0
"IX",364.6,364.6,"ALL",2)
K ^IBA(364.7,"ALL",DA,X1(5))
"IX",364.6,364.6,"ALL",2.4)
I X1(4)'="L"!'X1(5)!(X1(2)'="")!(X1(3)'="")!'X1(1) S X=0
"IX",364.6,364.6,"ALL",2.5)
K ^IBA(364.7,"ALL")
"IX",364.6,364.6,"ALL",11.1,0)
^.114IA^5^5
"IX",364.6,364.6,"ALL",11.1,1,0)
1^F^364.6^.03^^1^F
"IX",364.6,364.6,"ALL",11.1,1,1)
 
"IX",364.6,364.6,"ALL",11.1,2,0)
2^C
"IX",364.6,364.6,"ALL",11.1,2,1.5)
N Z S Z=+$O(^IBA(364.7,"B",DA,0)) I Z S X=$P($G(^IBA(364.7,Z,0)),U,5)
"IX",364.6,364.6,"ALL",11.1,3,0)
3^C
"IX",364.6,364.6,"ALL",11.1,3,1.5)
N Z S Z=+$O(^IBA(364.7,"B",DA,0)) I Z S X=$P($G(^IBA(364.7,Z,0)),U,6)
"IX",364.6,364.6,"ALL",11.1,4,0)
4^C
"IX",364.6,364.6,"ALL",11.1,4,1.5)
N Z S Z=+$O(^IBA(364.7,"B",DA,0)) I Z S X=$P($G(^IBA(364.7,Z,0)),U,2)
"IX",364.6,364.6,"ALL",11.1,5,0)
5^C
"IX",364.6,364.6,"ALL",11.1,5,1.5)
S X=+$O(^IBA(364.7,"B",DA,0))
"IX",364.6,364.6,"C",0)
364.6^C^Field name lookup^R^^F^IR^I^364.6^^^^^LS
"IX",364.6,364.6,"C",1)
S ^IBA(364.6,"C",$E(X,1,40),DA)=""
"IX",364.6,364.6,"C",2)
K ^IBA(364.6,"C",$E(X,1,40),DA)
"IX",364.6,364.6,"C",2.5)
K ^IBA(364.6,"C")
"IX",364.6,364.6,"C",11.1,0)
^.114IA^1^1
"IX",364.6,364.6,"C",11.1,1,0)
1^F^364.6^.1^40^1^F
"IX",364.6,364.6,"C",11.1,1,2)
S X=$$UP^XLFSTR(X)
"IX",364.6,364.6,"D",0)
364.6^D^XREF BY FORM,PAGE,LINE,COL TO SIMPLIFY DEVELOPMENT^MU^^R^IR^I^364.6^^^^^LS
"IX",364.6,364.6,"D",1)
S ^IBA(364.6,"D",X2(1)_","_X2(2)_","_X2(3)_","_X2(4),DA)=""
"IX",364.6,364.6,"D",1.4)
I X2(1)=""!(X2(2)="")!(X2(3)="")!(X2(4)="") S X=0
"IX",364.6,364.6,"D",2)
K ^IBA(364.6,"D",X1(1)_","_X1(2)_","_X1(3)_","_X1(4),DA)
"IX",364.6,364.6,"D",2.4)
I X1(1)=""!(X1(2)="")!(X1(3)="")!(X1(4)="") S X=0
"IX",364.6,364.6,"D",2.5)
K ^IBA(364.6,"D")
"IX",364.6,364.6,"D",11.1,0)
^.114IA^4^4
"IX",364.6,364.6,"D",11.1,1,0)
1^F^364.6^.01^^1^F
"IX",364.6,364.6,"D",11.1,2,0)
2^F^364.6^.04^^^F
"IX",364.6,364.6,"D",11.1,3,0)
3^F^364.6^.05^^^F
"IX",364.6,364.6,"D",11.1,4,0)
4^F^364.6^.08^^^F
"IX",364.7,364.7,"ALL",0)
364.7^ALL^Xref contains all local overrides defined for all insurance and type^MU^^F^IR^I^364.7^^^^^S
"IX",364.7,364.7,"ALL",1)
S ^IBA(364.7,"ALL",X2(2),DA)=""
"IX",364.7,364.7,"ALL",1.4)
I 'X2(2)!(X2(4)'="")!(X2(5)'="")!(X2(3)'="L") S X=0
"IX",364.7,364.7,"ALL",2)
K ^IBA(364.7,"ALL",X1(2),DA)
"IX",364.7,364.7,"ALL",2.4)
I 'X1(2)!(X1(4)'="")!(X1(5)'="")!(X1(3)'="L") S X=0
"IX",364.7,364.7,"ALL",2.5)
K ^IBA(364.7,"ALL")
"IX",364.7,364.7,"ALL",11.1,0)
^.114IA^5^5
"IX",364.7,364.7,"ALL",11.1,1,0)
1^F^364.7^.01^15^^F
"IX",364.7,364.7,"ALL",11.1,1,3)
 
"IX",364.7,364.7,"ALL",11.1,2,0)
2^C^^^10^1
"IX",364.7,364.7,"ALL",11.1,2,1.5)
S X=$P($G(^IBA(364.6,+X(1),0)),U,3)
"IX",364.7,364.7,"ALL",11.1,3,0)
3^F^364.7^.02^10^^F
"IX",364.7,364.7,"ALL",11.1,3,3)
 
"IX",364.7,364.7,"ALL",11.1,4,0)
4^F^364.7^.05^20^^F
"IX",364.7,364.7,"ALL",11.1,4,3)
 
"IX",364.7,364.7,"ALL",11.1,5,0)
5^F^364.7^.06^20^^F
"IX",364.7,364.7,"ALL",11.1,5,3)
 
"IX",399,399,"AM",0)
399^AM^Trigger to reset the Revenue Code MANUALLY EDITED flag.^MU^^F^IR^I^399^^^^^A
"IX",399,399,"AM",.1,0)
^^3^3^3110719^
"IX",399,399,"AM",.1,1,0)
This trigger is designed to remove the MANUALLY EDITED flag from all 
"IX",399,399,"AM",.1,2,0)
records in the REVENUE CODE multiple when the BILL CHARGE TYPE field is
"IX",399,399,"AM",.1,3,0)
changed.
"IX",399,399,"AM",1)
D CMAEDALL^IBCU9(DA)
"IX",399,399,"AM",2)
D CMAEDALL^IBCU9(DA)
"IX",399,399,"AM",11.1,0)
^.114IA^1^1
"IX",399,399,"AM",11.1,1,0)
1^F^399^.27^^1^F
"IX",399,399.0304,"AC",0)
399.0304^AC^Remove MANUALLY EDITED flag from Revenue Code^MU^^F^IR^I^399.0304^^^^^A
"IX",399,399.0304,"AC",.1,0)
^^3^3^3110721^
"IX",399,399.0304,"AC",.1,1,0)
This cross reference is designed to remove the MANUALLY EDITED flag from 
"IX",399,399.0304,"AC",.1,2,0)
records in the REVENUE CODE multiple if changes were made to the PROCEDURE
"IX",399,399.0304,"AC",.1,3,0)
CODE pointed to by the soft pointer in the ITEM (#399.042,.11) field.
"IX",399,399.0304,"AC",1)
D FROMPROC^IBCU9(DA(1),DA,"E")
"IX",399,399.0304,"AC",2)
Q
"IX",399,399.0304,"AC",11.1,0)
^.114IA^1^1
"IX",399,399.0304,"AC",11.1,1,0)
1^F^399.0304^5^^1^F
"IX",399,399.0304,"AD",0)
399.0304^AD^Remove MANUALLY EDITED flag from Revenue Code.^MU^^F^IR^I^399.0304^^^^^A
"IX",399,399.0304,"AD",.1,0)
^^3^3^3110721^
"IX",399,399.0304,"AD",.1,1,0)
This cross reference is designed to remove the MANUALLY EDITED flag from 
"IX",399,399.0304,"AD",.1,2,0)
records in the REVENUE CODE multiple if changes were made to the PROCEDURE
"IX",399,399.0304,"AD",.1,3,0)
CODE pointed to by the soft pointer in the ITEM (#399.042,.11) field.
"IX",399,399.0304,"AD",1)
Q
"IX",399,399.0304,"AD",2)
D FROMPROC^IBCU9(DA(1),DA,"D")
"IX",399,399.0304,"AD",11.1,0)
^.114IA^1^1
"IX",399,399.0304,"AD",11.1,1,0)
1^F^399.0304^.01^^1^F
"KRN",.402,1075,-1)
0^1
"KRN",.402,1075,0)
IB SCREEN5^3110509.145^@^399^^@^3111026
"KRN",.402,1075,"DIAB",1,1,399.04,0)
ALL
"KRN",.402,1075,"DIAB",1,1,399.043,0)
ALL
"KRN",.402,1075,"DR",1,399)
S:IBDR20'["53" Y="@51";S:$D(IBOUT) Y="@999";43;158//ELECTIVE;@999;K IBOUT;@51;S:IBDR20'["51" Y="@52";.03;@52;S:IBDR20'["52" Y="@55";@55;@56;S:IBDR20'["57" Y="@58";41;@56;@58;S:IBDR20'["58" Y="@54";40;@54;S:IBDR20'["54" Y="@59";
"KRN",.402,1075,"DR",1,399,1)
S IBZ20=$P(^DGCR(399,DA,0),U,9);.09;S IBASKCOD=1;@59;S:IBDR20'["59" Y="@999";I $P(^DGCR(399,DA,0),U,19)=2 S Y="@999";47;@999;
"KRN",.402,1075,"DR",2,399.04)
.01
"KRN",.402,1075,"DR",2,399.041)
.01;.02;I $P($G(^DGCR(399.1,+^DGCR(399,DA(1),"OC",DA,0),0)),U,9)'=2 S Y="@554";.03;S Y="@555";@554;I '$P(^DGCR(399.1,+^DGCR(399,DA(1),"OC",DA,0),0),U,10) S Y="@555";.04;@555;
"KRN",.402,1075,"DR",2,399.043)
.01
"KRN",.402,1075,"DR",2,399.047)
.01;.02;
"KRN",.402,1075,"ROU")
^IBXS5
"KRN",.402,1075,"ROUOLD")
IBXS5
"KRN",.402,1076,-1)
0^9
"KRN",.402,1076,0)
IB SCREEN6^3111019.1516^@^399^^@^3111212
"KRN",.402,1076,"AR",399,839)
1^IBXS610
"KRN",.402,1076,"DIAB",4,0,399,1)
UB-04 TIMEFRAME OF BILL;"TIMEFRAME OF BILL"
"KRN",.402,1076,"DIAB",5,0,399,0)
UB-04 LOCATION OF CARE;"LOCATION OF CARE"
"KRN",.402,1076,"DIAB",7,0,399,0)
UB-04 BILL CLASSIFICATION;"BILL CLASSIFICATION"
"KRN",.402,1076,"DR",1,399)
S:IBDR20'["61" Y="@62";S:$P($G(^DGCR(399,DA,0)),U,19)'=3 Y="@612";@611;S DIE("NO^")="";.24LOCATION OF CARE~;S:'$D(DIE("NO^")) DIE("NO^")="";.25BILL CLASSIFICATION~;
"KRN",.402,1076,"DR",1,399,1)
I '$$TOBIN^IBCU4($P(^DGCR(399,DA,0),U,25),DA) W !!,*7,"  **  The 'BILL CLASSIFICATION' must be consistent with the 'LOCATION OF CARE.'",! S Y="@611";@612;K DIE("NO^");.26TIMEFRAME OF BILL~;
"KRN",.402,1076,"DR",1,399,2)
I '$$INPAT^IBCEF(DA)!($$FT^IBCEF(DA)'=3) S Y="@6121";@6121;.22;243;D DISPTAX^IBCEP81($P($G(^DGCR(399,DA,"U3")),U,2),"Service Facility");.27;S DGRVRCAL=1;S DIPA("FT1")=$P($G(^DGCR(399,DA,0)),U,19);D CKFT^IBCIUT1(IBIFN);@614;.19;
"KRN",.402,1076,"DR",1,399,3)
S DIPA("FT")=$P($G(^DGCR(399,DA,0)),U,19);I $P($G(^IBE(353,+DIPA("FT"),2)),U,2)="P",$P($G(^(2)),U,4) S DIPA("FT1")=DIPA("FT") D CKFT^IBCIUT1(IBIFN) S Y="@615";W !,*7,"Must be a printable national form type";
"KRN",.402,1076,"DR",1,399,4)
.19///^S X=$G(DIPA("FT1"));S Y="@614";@615;D FTPRV^IBCEU5(DA);@62;S:IBDR20'["62" Y="@63";155;S:X=0 Y=156;157;156;S:'$D(IBOX) Y="@63";153;@63;S:IBDR20'["63" Y="@64";151;152;@64;S:IBDR20'["64" Y="@65";161;165;@65;
"KRN",.402,1076,"DR",1,399,5)
S:IBDR20'["65" Y="@66";D RCD^IBCU1;42;202;S:'X Y="@657";203;@657;I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@66";210;@66;@67;S:IBDR20'["67" Y="@68";S:'$D(^DGCR(399,DA,"I1")) Y="@672";218;@672;S:'$D(^DGCR(399,DA,"I2")) Y="@673";219;
"KRN",.402,1076,"DR",1,399,6)
@673;S:'$D(^DGCR(399,DA,"I3")) Y="@68";220;@68;K DIE("NO^");
"KRN",.402,1076,"DR",2,399.042)
.01;S IBMAED=1,DIE("NO^")="";.02;K IBMAED,DIE("NO^");.03;.04;.05;.09;.06;I '$P(^DGCR(399,DA(1),"RC",DA,0),U,6) S Y="@658";.07;@658;I +$P(^DGCR(399,DA(1),"RC",DA,0),U,8) S Y="@659";.1;.12;
"KRN",.402,1076,"DR",2,399.042,1)
I $P($G(^DGCR(399,DA(1),"RC",DA,0)),U,10)'=4!'$P(^DGCR(399,DA(1),"RC",DA,0),U,6) S Y="@659";D LINKCPT^IBCEU5(DA(1),DA);@659;
"KRN",.402,1076,"ROU")
^IBXS6
"KRN",.402,1076,"ROUOLD")
IBXS6
"KRN",.402,1077,-1)
0^8
"KRN",.402,1077,0)
IB SCREEN7^3110718.1052^@^399^^@^3111212
"KRN",.402,1077,"AR",399,839)
1^IBXS74
"KRN",.402,1077,"DIAB",1,1,399.043,0)
ALL
"KRN",.402,1077,"DIAB",4,0,399,1)
UB-04 TIMEFRAME OF BILL;"TIMEFRAME OF BILL"
"KRN",.402,1077,"DIAB",11,0,399,0)
UB-04 LOCATION OF CARE;"LOCATION OF CARE"
"KRN",.402,1077,"DIAB",13,0,399,0)
UB-04 BILL CLASSIFICATION;"BILL CLASSIFICATION"
"KRN",.402,1077,"DR",1,399)
S:IBDR20'["74" Y="@71";S:$D(IBOUT) Y="@999";43;@999;K IBOUT;@71;S:IBDR20'["71" Y="@72";S:$P($G(^DGCR(399,DA,0)),U,19)'=3 Y="@712";@711;S DIE("NO^")="";.24LOCATION OF CARE~;S:'$D(DIE("NO^")) DIE("NO^")="";.25BILL CLASSIFICATION~;
"KRN",.402,1077,"DR",1,399,1)
I '$$TOBIN^IBCU4($P(^DGCR(399,DA,0),U,25),DA) W !!,*7,"  **  The 'BILL CLASSIFICATION' must be consistent with the 'LOCATION OF CARE.'",! S Y="@711";@712;K DIE("NO^");.26TIMEFRAME OF BILL~;162;.22;243;
"KRN",.402,1077,"DR",1,399,2)
D DISPTAX^IBCEP81($P($G(^DGCR(399,DA,"U3")),U,2),"Service Facility");.27;S DGRVRCAL=1;S DIPA("FT1")=$P($G(^DGCR(399,DA,0)),U,19);D CKFT^IBCIUT1(IBIFN);@714;.19;S DIPA("FT")=$P($G(^DGCR(399,DA,0)),U,19);
"KRN",.402,1077,"DR",1,399,3)
I $P($G(^IBE(353,+DIPA("FT"),2)),U,2)="P",$P($G(^(2)),U,4) S DIPA("FT1")=DIPA("FT") D CKFT^IBCIUT1(IBIFN) S Y="@715";W !,*7,"Must be a printable national form type";.19///^S X=$G(DIPA("FT1"));S Y="@714";@715;D FTPRV^IBCEU5(DA);@72;
"KRN",.402,1077,"DR",1,399,4)
S:IBDR20'["72" Y="@73";155;S:X=0 Y=156;157;156;S:'$D(IBOX) Y="@73";153;@73;S:IBDR20'["73" Y="@75";151;152;@75;S:IBDR20'["75" Y="@76";D RCD^IBCU1;42;202;S:'X Y="@757";203;@757;I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@76";210;@76;
"KRN",.402,1077,"DR",1,399,5)
@77;S:IBDR20'["77" Y="@78";S:'$D(^DGCR(399,DA,"I1")) Y="@772";218;@772;S:'$D(^DGCR(399,DA,"I2")) Y="@773";219;@773;S:'$D(^DGCR(399,DA,"I3")) Y="@78";220;@78;K DIE("NO^");
"KRN",.402,1077,"DR",2,399.042)
.01;S IBMAED=1,DIE("NO^")="";.02;K IBMAED,DIE("NO^");.03;.04;.05;.09;.06;I '$P(^DGCR(399,DA(1),"RC",DA,0),U,6) S Y="@758";.07//^S X=$$DEFDIV^IBCU7(DA(1));@758;
"KRN",.402,1077,"DR",2,399.042,1)
I +$P(^DGCR(399,DA(1),"RC",DA,0),U,8) W !," AUTO ADDED CHARGE - NO CHANGE TO TYPE/COMPONENT" S Y="@759";.1;.12;I $S($P($G(^DGCR(399,DA(1),"RC",DA,0)),U,10)=3:0,1:$P($G(^(0)),U,10)'=4)!$P($G(^(0)),U,8) S Y="@759";
"KRN",.402,1077,"DR",2,399.042,2)
I $P($G(^DGCR(399,DA(1),"RC",DA,0)),U,10)=4 S Y="@7581";S DGRVRCAL=1;D LINKRX^IBCEU5(DA(1),DA);.15;S Y="@759";@7581;D LINKCPT^IBCEU5(DA(1),DA);@759;
"KRN",.402,1077,"DR",2,399.043)
.01
"KRN",.402,1077,"ROU")
^IBXS7
"KRN",.402,1077,"ROUOLD")
IBXS7
"KRN",.402,1079,-1)
0^7
"KRN",.402,1079,0)
IB SCREEN8^3110718.11^@^399^^@^3110518
"KRN",.402,1079,"DIAB",2,0,399,1)
PRIMARY SURGICAL PROC CODE;"Primary Code"
"KRN",.402,1079,"DIAB",3,0,399,0)
COB TOTAL NON-COVERED AMOUNT;"COB Non-Covered Charge Amt"
"KRN",.402,1079,"DIAB",3,0,399,1)
SECONDARY SURGICAL PROC CODE;"Secondary Code"
"KRN",.402,1079,"DIAB",4,0,399,2)
ASSUMED CARE DATE;"Assumed Care Date"
"KRN",.402,1079,"DIAB",5,0,399,2)
RELINQUISHED CARE DATE;"Relinquished Care Date"
"KRN",.402,1079,"DIAB",6,0,399,0)
PROPERTY/CASUALTY CLAIM NUMBER;"Claim Number"
"KRN",.402,1079,"DIAB",6,0,399,1)
ATTACHMENT REPORT TYPE;"Report Type"
"KRN",.402,1079,"DIAB",7,0,399,1)
ATTACHMENT REPORT TRANS CODE;"Transmission Method"
"KRN",.402,1079,"DIAB",8,0,399,0)
PROP/CAS DATE OF 1ST CONTACT;"Date of 1st Contact"
"KRN",.402,1079,"DIAB",8,0,399,1)
ATTACHMENT CONTROL NUMBER;"Attachment Control #"
"KRN",.402,1079,"DIAB",9,0,399,0)
PROPERTY/CASUALTY CONTACT NAME;"Contact Name"
"KRN",.402,1079,"DIAB",10,0,399,0)
PROP/CAS COMMUNICATION NUMBER;"Contact Phone"
"KRN",.402,1079,"DIAB",11,0,399,0)
PROP/CAS EXTENSION NUMBER;"Contact Phone Extension"
"KRN",.402,1079,"DIAB",11,0,399,1)
DISABILITY START DATE;"Disability Start Date"
"KRN",.402,1079,"DIAB",12,0,399,1)
DISABILITY END DATE;"Disability End Date"
"KRN",.402,1079,"DR",1,399)
@81;S:IBDR20'["81" Y="@82";260COB Non-Covered Charge Amt~;@82;S:IBDR20'["82" Y="@83";261Claim Number~;S:IBT=3 Y="@84";262Date of 1st Contact~;268Contact Name~;269Contact Phone~;269.1Contact Phone Extension~;@83;
"KRN",.402,1079,"DR",1,399,1)
S:IBDR20'["83" Y="@84";266Primary Code~;267Secondary Code~;@84;S:IBDR20'["84" Y="@85";285Report Type~;286Transmission Method~;284Attachment Control #~;@85;S:IBDR20'["85" Y="@86";263Disability Start Date~;264Disability End Date~;
"KRN",.402,1079,"DR",1,399,2)
@86;S:IBDR20'["86" Y="@899";S:$P($G(^DGCR(IBIFN,0)),U,19)=3 Y="@899";282Assumed Care Date~;283Relinquished Care Date~;@899;
"KRN",.402,1079,"ROU")
^IBXS8
"KRN",.402,1079,"ROUOLD")
IBXS8
"KRN",.402,2690,-1)
0^6
"KRN",.402,2690,0)
IB SCREEN9^3110801.1447^@^399^^@^3110801
"KRN",.402,2690,"%D",0)
^^1^1^3110708^^^
"KRN",.402,2690,"%D",1,0)
Ambulance Information
"KRN",.402,2690,"DIAB",1,0,399,1)
TRANSPORT REASON CODE;"Transport Reason"
"KRN",.402,2690,"DIAB",2,0,399,0)
AMBULANCE P/U ADDRESS 1;"P/U Address1"
"KRN",.402,2690,"DIAB",2,0,399,1)
ROUND TRIP PURPOSE DESCRIPTION;"R/T Purpose"
"KRN",.402,2690,"DIAB",3,0,399,0)
AMBULANCE P/U ADDRESS 2;"P/U Address 2"
"KRN",.402,2690,"DIAB",3,0,399,1)
STRETCHER PURPOSE DESCRIPTION;"Stretcher Purpose"
"KRN",.402,2690,"DIAB",4,0,399,0)
AMBULANCE P/U CITY;"P/U City"
"KRN",.402,2690,"DIAB",5,0,399,0)
AMBULANCE P/U STATE;"P/U State"
"KRN",.402,2690,"DIAB",6,0,399,0)
AMBULANCE P/U ZIP;"P/U Zip"
"KRN",.402,2690,"DIAB",7,0,399,0)
AMBULANCE D/O LOCATION;"D/O Location"
"KRN",.402,2690,"DIAB",7,0,399,1)
AMBULANCE CONDITION INDICATOR;"Ambulance Condition Indicator"
"KRN",.402,2690,"DIAB",8,0,399,0)
AMBULANCE D/O ADDRESS 1;"D/O Address1"
"KRN",.402,2690,"DIAB",9,0,399,0)
AMBULANCE D/O ADDRESS 2;"D/O Address2"
"KRN",.402,2690,"DIAB",10,0,399,0)
AMBULANCE D/O CITY;"D/O City"
"KRN",.402,2690,"DIAB",11,0,399,0)
AMBULANCE D/O STATE;"D/O State"
"KRN",.402,2690,"DIAB",12,0,399,0)
AMBULANCE D/O ZIP;"D/O Zip"
"KRN",.402,2690,"DIAB",13,0,399,0)
PATIENT WEIGHT (LB);"Patient Weight"
"KRN",.402,2690,"DIAB",14,0,399,0)
AMBULANCE TRANSPORT DISTANCE;"Transport Distance"
"KRN",.402,2690,"DR",1,399)
S:IBDR20'["91" Y="@92";271P/U Address1~;272P/U Address 2~;273P/U City~;274P/U State~;275P/U Zip~;276D/O Location~;277D/O Address1~;278D/O Address2~;279D/O City~;280D/O State~;281D/O Zip~;287Patient Weight~;289Transport Distance~;
"KRN",.402,2690,"DR",1,399,1)
288Transport Reason~;290R/T Purpose~;291Stretcher Purpose~;S Y="@999";@92;S:IBDR20'["92" Y="@999";292Ambulance Condition Indicator~;@999;
"KRN",.402,2690,"DR",2,399.0292)
.01;
"KRN",.402,2690,"ROU")
^IBXS9
"KRN",.402,2690,"ROUOLD")
IBXS9
"KRN",19,2523,-1)
3^6
"KRN",19,2523,0)
IB OUTPUT PATIENT REPORT MENU^Patient Billing Reports Menu^^M^^^^^^^^INTEGRATED BILLING
"KRN",19,2523,1,0)
^19.06^3^3^3110804^^^^
"KRN",19,2523,1,1,0)
This menu contains the Billing reports that deal with one
"KRN",19,2523,1,2,0)
or a group of patients.   This includes all billing lists of patients and
"KRN",19,2523,1,3,0)
billing inquiries.
"KRN",19,2523,10,0)
^19.01IP^33^33
"KRN",19,2523,99)
62469,56998
"KRN",19,2523,99.1)
58924,39746
"KRN",19,2523,"U")
PATIENT BILLING REPORTS MENU
"KRN",19,3374,-1)
3^3
"KRN",19,3374,0)
IB OUTPUT MANAGEMENT REPORTS^Management Reports (Billing) Menu^^M^^^^^^^^INTEGRATED BILLING
"KRN",19,3374,1,0)
^19.06^2^2^3110721^^^^
"KRN",19,3374,1,1,0)
This menu contains reports that provide statistics or lists of bills
"KRN",19,3374,1,2,0)
that can be used in managing the Billing program.
"KRN",19,3374,10,0)
^19.01IP^18^18
"KRN",19,3374,10,18,0)
12968^NMR
"KRN",19,3374,10,18,"^")
IBCEM NON-MRA REPORT
"KRN",19,3374,99)
62469,56998
"KRN",19,3374,99.1)
57061,53199
"KRN",19,3374,"U")
MANAGEMENT REPORTS (BILLING) M
"KRN",19,12968,-1)
0^4
"KRN",19,12968,0)
IBCEM NON-MRA REPORT^Non-MRA Productivity Report^^R^^^^^^^^INTEGRATED BILLING
"KRN",19,12968,1,0)
^19.06^2^2^3110805^^^
"KRN",19,12968,1,1,0)
The Non-MRA Productivity Report displays information on Primary, 
"KRN",19,12968,1,2,0)
Secondary and Tertiary non-MRA claims.
"KRN",19,12968,25)
EN^IBCEMSR2
"KRN",19,12968,"U")
NON-MRA PRODUCTIVITY REPORT
"KRN",19,13045,-1)
1^7
"KRN",19,13045,0)
IB COPY SECOND/THIRD
"KRN",409.61,254,-1)
0^1
"KRN",409.61,254,0)
IBJT INACTIVE LIST^1^^80^5^20^1^1^Inactive Bill^IBJT INACTIVE LIST SCREEN MENU^Inactive Bills^1^^1
"KRN",409.61,254,1)
^VALM HIDDEN ACTIONS
"KRN",409.61,254,"ARRAY")
 ^TMP("IBJTLB",$J)
"KRN",409.61,254,"COL",0)
^409.621^13^13
"KRN",409.61,254,"COL",1,0)
NUMBER^1^3
"KRN",409.61,254,"COL",2,0)
BILL^4^12^ Bill #
"KRN",409.61,254,"COL",3,0)
HD^17^1
"KRN",409.61,254,"COL",4,0)
STFROM^18^8^From
"KRN",409.61,254,"COL",5,0)
STTO^27^8^To
"KRN",409.61,254,"COL",6,0)
TYPE^36^4^Type
"KRN",409.61,254,"COL",7,0)
ARST^41^4^Stat
"KRN",409.61,254,"COL",8,0)
RATE^46^7^Rate
"KRN",409.61,254,"COL",9,0)
CB^54^1
"KRN",409.61,254,"COL",10,0)
INSUR^55^7^Insurer
"KRN",409.61,254,"COL",11,0)
OAMT^64^8^Orig Amt
"KRN",409.61,254,"COL",12,0)
CAMT^73^8^Curr Amt
"KRN",409.61,254,"COL",13,0)
REFER^16^1
"KRN",409.61,254,"COL","B","ARST",7)

"KRN",409.61,254,"COL","B","BILL",2)

"KRN",409.61,254,"COL","B","CAMT",12)

"KRN",409.61,254,"COL","B","CB",9)

"KRN",409.61,254,"COL","B","HD",3)

"KRN",409.61,254,"COL","B","INSUR",10)

"KRN",409.61,254,"COL","B","NUMBER",1)

"KRN",409.61,254,"COL","B","OAMT",11)

"KRN",409.61,254,"COL","B","RATE",8)

"KRN",409.61,254,"COL","B","REFER",13)

"KRN",409.61,254,"COL","B","STFROM",4)

"KRN",409.61,254,"COL","B","STTO",5)

"KRN",409.61,254,"COL","B","TYPE",6)

"KRN",409.61,254,"FNL")
D EXIT^IBJTLB
"KRN",409.61,254,"HDR")
D HDR^IBJTLB
"KRN",409.61,254,"HLP")
D HELP^IBJTLB
"KRN",409.61,254,"INIT")
D INIT^IBJTLB
"KRN",409.61,710,-1)
0^3
"KRN",409.61,710,0)
IBCEM MRA MANAGEMENT^1^^80^4^17^1^1^MRA/EOB^IBCEM COB MANAGEMENT^MRA Management WorkList^1^^1
"KRN",409.61,710,1)
^VALM HIDDEN ACTIONS
"KRN",409.61,710,"ARRAY")
 ^TMP("IBCECOB",$J)
"KRN",409.61,710,"COL",0)
^409.621^14^7
"KRN",409.61,710,"COL",1,0)
BILL^5^14^Bill #^^
"KRN",409.61,710,"COL",2,0)
SERVICE^20^8^Svc Date^^
"KRN",409.61,710,"COL",9,0)
NUMBER^1^4^^^
"KRN",409.61,710,"COL",10,0)
PATNM^29^23^Patient Name        SSN
"KRN",409.61,710,"COL",12,0)
BTYPE^75^4^Type
"KRN",409.61,710,"COL",13,0)
PTRESP^53^10^  Pt Resp
"KRN",409.61,710,"COL",14,0)
IBAMT^64^9^ Bill Amt
"KRN",409.61,710,"COL","B","BILL",1)

"KRN",409.61,710,"COL","B","BTYPE",12)

"KRN",409.61,710,"COL","B","IBAMT",14)

"KRN",409.61,710,"COL","B","NUMBER",9)

"KRN",409.61,710,"COL","B","PATNM",10)

"KRN",409.61,710,"COL","B","PTRESP",13)

"KRN",409.61,710,"COL","B","SERVICE",2)

"KRN",409.61,710,"EXP")
D EXP^IBCECOB
"KRN",409.61,710,"FNL")
D EXIT^IBCECOB
"KRN",409.61,710,"HDR")
D HDR^IBCECOB
"KRN",409.61,710,"HLP")
D HELP^IBCECOB
"KRN",409.61,710,"INIT")
D INIT^IBCECOB
"KRN",409.61,824,-1)
0^2
"KRN",409.61,824,0)
IBCEM COB MANAGEMENT^1^^80^4^18^1^1^COB^IBCEM COB MANAGEMENT 2^COB Management WorkList^1^^1
"KRN",409.61,824,1)
^VALM HIDDEN ACTIONS
"KRN",409.61,824,"ARRAY")
 ^TMP("IBCECOB",$J)
"KRN",409.61,824,"COL",0)
^409.621^14^7
"KRN",409.61,824,"COL",1,0)
BILL^5^14^Bill #^^
"KRN",409.61,824,"COL",2,0)
SERVICE^20^8^Svc Date^^
"KRN",409.61,824,"COL",9,0)
NUMBER^1^4^^^
"KRN",409.61,824,"COL",10,0)
PATNM^29^23^Patient Name        SSN
"KRN",409.61,824,"COL",12,0)
BTYPE^75^4^Type
"KRN",409.61,824,"COL",13,0)
PTRESP^53^9^  Bal Due
"KRN",409.61,824,"COL",14,0)
IBAMT^63^9^ Bill Amt
"KRN",409.61,824,"COL","B","BILL",1)

"KRN",409.61,824,"COL","B","BTYPE",12)

"KRN",409.61,824,"COL","B","IBAMT",14)

"KRN",409.61,824,"COL","B","NUMBER",9)

"KRN",409.61,824,"COL","B","PATNM",10)

"KRN",409.61,824,"COL","B","PTRESP",13)

"KRN",409.61,824,"COL","B","SERVICE",2)

"KRN",409.61,824,"EXP")
D EXP^IBCECOB
"KRN",409.61,824,"FNL")
D EXIT^IBCECOB
"KRN",409.61,824,"HDR")
D HDR^IBCECOB
"KRN",409.61,824,"HLP")
D HELP^IBCECOB
"KRN",409.61,824,"INIT")
D INIT^IBCECOB
"MBREQ")
1
"ORD",7,.402)
.402;7;;;EDEOUT^DIFROMSO(.402,DA,"",XPDA);FPRE^DIFROMSI(.402,"",XPDA);EPRE^DIFROMSI(.402,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.402,DA,"",XPDA);DEL^DIFROMSK(.402,"",%)
"ORD",7,.402,0)
INPUT TEMPLATE
"ORD",17,409.61)
409.61;17;1;;;;LME1^XPDIA1;;;LMDEL^XPDIA1
"ORD",17,409.61,0)
LIST TEMPLATE
"ORD",18,19)
19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA
"ORD",18,19,0)
OPTION
"PGL",364.6,0,3,.03)
ASSOCIATED FORM DEFINITION^P364.6'^IBA(364.6,^0;3^Q
"PGL",364.7,0,5,.05)
INSURANCE COMPANY^P36'^DIC(36,^0;5^Q
"PKG",200,-1)
1^1
"PKG",200,0)
INTEGRATED BILLING^IB^INTEGRATED BILLING
"PKG",200,20,0)
^9.402P^1^1
"PKG",200,20,1,0)
2^^IBAXDR
"PKG",200,20,1,1)

"PKG",200,20,"B",2,1)

"PKG",200,22,0)
^9.49I^1^1
"PKG",200,22,1,0)
2.0^2940321^2990406^2447
"PKG",200,22,1,"PAH",1,0)
447^3120116^123456868
"PKG",200,22,1,"PAH",1,1,0)
^^276^276^3120113
"PKG",200,22,1,"PAH",1,1,1,0)
This Integrated Billing (IB) patch expands the HIPAA 5010 enhancements 
"PKG",200,22,1,"PAH",1,1,2,0)
introduced in patch IB*2.0*432.
"PKG",200,22,1,"PAH",1,1,3,0)
 
"PKG",200,22,1,"PAH",1,1,4,0)
The intent of this patch is to:
"PKG",200,22,1,"PAH",1,1,5,0)
     1. Add new fields to the Enter/Edit Billing Information option [IB
"PKG",200,22,1,"PAH",1,1,6,0)
        EDIT BILLING INFO] to allow users to enter additional data
"PKG",200,22,1,"PAH",1,1,7,0)
        elements to claims for health care services provided to patients.
"PKG",200,22,1,"PAH",1,1,8,0)
 
"PKG",200,22,1,"PAH",1,1,9,0)
     2. Modify the logic which calculates what the monetary amounts that 
"PKG",200,22,1,"PAH",1,1,10,0)
        were bill to the secondary payers on the MRA Statistics Report
"PKG",200,22,1,"PAH",1,1,11,0)
        option [IBCEM MRA STATISTICS REPORT].
"PKG",200,22,1,"PAH",1,1,12,0)
 
"PKG",200,22,1,"PAH",1,1,13,0)
     3. Modify the outbound 837 Heath Care Claims transmissions to 
"PKG",200,22,1,"PAH",1,1,14,0)
        incorporate the additional/modified data elements that may be
"PKG",200,22,1,"PAH",1,1,15,0)
        added to a claim.
"PKG",200,22,1,"PAH",1,1,16,0)
 
"PKG",200,22,1,"PAH",1,1,17,0)
     4. Modify the printing process for outpatient, UB04 claims to print 
"PKG",200,22,1,"PAH",1,1,18,0)
        the Priority (Type) of Admission.
"PKG",200,22,1,"PAH",1,1,19,0)
 
"PKG",200,22,1,"PAH",1,1,20,0)
     5. Modify the printing process for UB04 and CMS-1500 claims to allow 
"PKG",200,22,1,"PAH",1,1,21,0)
        the printing of Revenue/Procedure codes with zero dollar amounts.
"PKG",200,22,1,"PAH",1,1,22,0)
 
"PKG",200,22,1,"PAH",1,1,23,0)
     6. Modify The Insurance Company Enter/Edit option [IBCN INSURANCE CO 
"PKG",200,22,1,"PAH",1,1,24,0)
        EDIT] to allow users to assign additional MEDIGAP policies as Type
"PKG",200,22,1,"PAH",1,1,25,0)
        of Plan for an Insurance Company.
"PKG",200,22,1,"PAH",1,1,26,0)
 
"PKG",200,22,1,"PAH",1,1,27,0)
     7. Create a new option called the Non-MRA Productivity Report option 
"PKG",200,22,1,"PAH",1,1,28,0)
        [IBCEM NON-MRA REPORT].
"PKG",200,22,1,"PAH",1,1,29,0)
 
"PKG",200,22,1,"PAH",1,1,30,0)
     8. Modify the mnemonic for the Third Party Billing Menu [IB THIRD 
"PKG",200,22,1,"PAH",1,1,31,0)
        PARTY BILLING MENU].
"PKG",200,22,1,"PAH",1,1,32,0)
 
"PKG",200,22,1,"PAH",1,1,33,0)
     9. Modify the Insurance Payment Trend Report option [IB OUTPUT TREND 
"PKG",200,22,1,"PAH",1,1,34,0)
        REPORT] to display the Insurance Plan Group Number.
"PKG",200,22,1,"PAH",1,1,35,0)
 
"PKG",200,22,1,"PAH",1,1,36,0)
     10. Modify the Correct a Rejected/Denied Bill option [IB CORRECT 
"PKG",200,22,1,"PAH",1,1,37,0)
         REJECTED/DENIED] to allow the correction of claims to
"PKG",200,22,1,"PAH",1,1,38,0)
         non-accruing funds such as TRICARE claims.
"PKG",200,22,1,"PAH",1,1,39,0)
 
"PKG",200,22,1,"PAH",1,1,40,0)
Patch Components
"PKG",200,22,1,"PAH",1,1,41,0)
================
"PKG",200,22,1,"PAH",1,1,42,0)
<Additional patch components can be added alphabetically if needed.>
"PKG",200,22,1,"PAH",1,1,43,0)
 
"PKG",200,22,1,"PAH",1,1,44,0)
 
"PKG",200,22,1,"PAH",1,1,45,0)
Files & Fields Associated:
"PKG",200,22,1,"PAH",1,1,46,0)
 
"PKG",200,22,1,"PAH",1,1,47,0)
File Name (Number)         Field Name (Number)   New/Modified/Deleted
"PKG",200,22,1,"PAH",1,1,48,0)
------------------         -------------------   --------------------
"PKG",200,22,1,"PAH",1,1,49,0)
BILL FORM                  LOCAL BILLING         Modified
"PKG",200,22,1,"PAH",1,1,50,0)
TYPE(#353)                 SCREEN(#2.09)
"PKG",200,22,1,"PAH",1,1,51,0)
 
"PKG",200,22,1,"PAH",1,1,52,0)
EXPLANATION OF             EOB TYPE(#.04)        New
"PKG",200,22,1,"PAH",1,1,53,0)
BENEFITS(#361.1)           
"PKG",200,22,1,"PAH",1,1,54,0)
 
"PKG",200,22,1,"PAH",1,1,55,0)
EXPLANATION OF             ENTRY                 New
"PKG",200,22,1,"PAH",1,1,56,0)
BENEFITS(#361.1)           DATE/TIME(#.05) 
"PKG",200,22,1,"PAH",1,1,57,0)
 
"PKG",200,22,1,"PAH",1,1,58,0)
BILL/CLAIMS(#399)          BILL                  New
"PKG",200,22,1,"PAH",1,1,59,0)
                           CLASSIFICATION(#.05)
"PKG",200,22,1,"PAH",1,1,60,0)
 
"PKG",200,22,1,"PAH",1,1,61,0)
BILL/CLAIMS(#399)          BILL CHARGE           New
"PKG",200,22,1,"PAH",1,1,62,0)
                           TYPE(#.27) 
"PKG",200,22,1,"PAH",1,1,63,0)
 
"PKG",200,22,1,"PAH",1,1,64,0)
BILL/CLAIMS(#399)          PATIENT WEIGHT        New
"PKG",200,22,1,"PAH",1,1,65,0)
                           (LB)(#287) 
"PKG",200,22,1,"PAH",1,1,66,0)
 
"PKG",200,22,1,"PAH",1,1,67,0)
BILL/CLAIMS(#399)          TRANSPORT REASON      New
"PKG",200,22,1,"PAH",1,1,68,0)
                           CODE(#288) 
"PKG",200,22,1,"PAH",1,1,69,0)
 
"PKG",200,22,1,"PAH",1,1,70,0)
BILL/CLAIMS(#399)          AMBULANCE TRANSPORT   New
"PKG",200,22,1,"PAH",1,1,71,0)
                           DISTANCE(#289)
"PKG",200,22,1,"PAH",1,1,72,0)
 
"PKG",200,22,1,"PAH",1,1,73,0)
BILL/CLAIMS(#399)          ROUND TRIP PURPOSE    New
"PKG",200,22,1,"PAH",1,1,74,0)
                           DESCRIPTION(#290) 
"PKG",200,22,1,"PAH",1,1,75,0)
 
"PKG",200,22,1,"PAH",1,1,76,0)
BILL/CLAIMS(#399)          STRETCHER PURPOSE     New
"PKG",200,22,1,"PAH",1,1,77,0)
                           DESCRIPTION(#291) 
"PKG",200,22,1,"PAH",1,1,78,0)
 
"PKG",200,22,1,"PAH",1,1,79,0)
AMBULANCE CONDITION                              New
"PKG",200,22,1,"PAH",1,1,80,0)
INDICATOR(#399.0292)
"PKG",200,22,1,"PAH",1,1,81,0)
 
"PKG",200,22,1,"PAH",1,1,82,0)
PROCEDURES(#399.0304)      PROCEDURES(#.01)      Modified
"PKG",200,22,1,"PAH",1,1,83,0)
 
"PKG",200,22,1,"PAH",1,1,84,0)
PROCEDURES(#399.0304)      DIVISION(#5)          Modified
"PKG",200,22,1,"PAH",1,1,85,0)
 
"PKG",200,22,1,"PAH",1,1,86,0)
REVENUE                    CHARGES(#.02)         Modified
"PKG",200,22,1,"PAH",1,1,87,0)
CODE(#399.042)             
"PKG",200,22,1,"PAH",1,1,88,0)
 
"PKG",200,22,1,"PAH",1,1,89,0)
REVENUE                    MANUALLY              New
"PKG",200,22,1,"PAH",1,1,90,0)
CODE(#399.042)             EDITED(#.16) 
"PKG",200,22,1,"PAH",1,1,91,0)
 
"PKG",200,22,1,"PAH",1,1,92,0)
 
"PKG",200,22,1,"PAH",1,1,93,0)
Forms Associated:
"PKG",200,22,1,"PAH",1,1,94,0)
 
"PKG",200,22,1,"PAH",1,1,95,0)
Form Name             File #                     New/Modified/Deleted
"PKG",200,22,1,"PAH",1,1,96,0)
---------             ------                     --------------------
"PKG",200,22,1,"PAH",1,1,97,0)
 
"PKG",200,22,1,"PAH",1,1,98,0)
 
"PKG",200,22,1,"PAH",1,1,99,0)
Options Associated:
"PKG",200,22,1,"PAH",1,1,100,0)
 
"PKG",200,22,1,"PAH",1,1,101,0)
Option Name            Type                      New/Modified/Deleted
"PKG",200,22,1,"PAH",1,1,102,0)
-----------            ----                      --------------------
"PKG",200,22,1,"PAH",1,1,103,0)
IB OUTPUT              menu                      Modified
"PKG",200,22,1,"PAH",1,1,104,0)
MANAGEMENT REPORTS 
"PKG",200,22,1,"PAH",1,1,105,0)
 
"PKG",200,22,1,"PAH",1,1,106,0)
IBCEM NON-MRA          run routine               New
"PKG",200,22,1,"PAH",1,1,107,0)
REPORT 
"PKG",200,22,1,"PAH",1,1,108,0)
 
"PKG",200,22,1,"PAH",1,1,109,0)
IB OUTPUT PATIENT      menu                      Modified
"PKG",200,22,1,"PAH",1,1,110,0)
REPORT MENU 
"PKG",200,22,1,"PAH",1,1,111,0)
 
"PKG",200,22,1,"PAH",1,1,112,0)
 
"PKG",200,22,1,"PAH",1,1,113,0)
Templates Associated:
"PKG",200,22,1,"PAH",1,1,114,0)
 
"PKG",200,22,1,"PAH",1,1,115,0)
Template Name      Type      File Name (Number)  New/Modified/Deleted 
"PKG",200,22,1,"PAH",1,1,116,0)
-------------      ----      ------------------  --------------------
"PKG",200,22,1,"PAH",1,1,117,0)
 
"PKG",200,22,1,"PAH",1,1,118,0)
IB SCREEN5         INPUT     BILL/CLAIMS(399)    Modified
"PKG",200,22,1,"PAH",1,1,119,0)
 
"PKG",200,22,1,"PAH",1,1,120,0)
IB SCREEN7         INPUT     BILL/CLAIMS(399)    Modified
"PKG",200,22,1,"PAH",1,1,121,0)
 
"PKG",200,22,1,"PAH",1,1,122,0)
IB SCREEN8         INPUT     BILL/CLAIMS(399)    Modified
"PKG",200,22,1,"PAH",1,1,123,0)
 
"PKG",200,22,1,"PAH",1,1,124,0)
IB SCREEN9         INPUT     BILL/CLAIMS(399)    New
"PKG",200,22,1,"PAH",1,1,125,0)
 
"PKG",200,22,1,"PAH",1,1,126,0)
 
"PKG",200,22,1,"PAH",1,1,127,0)
Additional Information:
"PKG",200,22,1,"PAH",1,1,128,0)
<Additional information sections can be added alphabetically if needed.>
"PKG",200,22,1,"PAH",1,1,129,0)
 
"PKG",200,22,1,"PAH",1,1,130,0)
 
"PKG",200,22,1,"PAH",1,1,131,0)
New Service Requests (NSRs)
"PKG",200,22,1,"PAH",1,1,132,0)
----------------------------  
"PKG",200,22,1,"PAH",1,1,133,0)
No New Service Requests 
"PKG",200,22,1,"PAH",1,1,134,0)
 
"PKG",200,22,1,"PAH",1,1,135,0)
Patient Safety Issues (PSIs)
"PKG",200,22,1,"PAH",1,1,136,0)
-----------------------------
"PKG",200,22,1,"PAH",1,1,137,0)
No Patient Safety Issues 
"PKG",200,22,1,"PAH",1,1,138,0)
 
"PKG",200,22,1,"PAH",1,1,139,0)
Remedy Ticket(s) & Overview
"PKG",200,22,1,"PAH",1,1,140,0)
---------------------------
"PKG",200,22,1,"PAH",1,1,141,0)
No Remedy Tickets 
"PKG",200,22,1,"PAH",1,1,142,0)
 
"PKG",200,22,1,"PAH",1,1,143,0)
Test Sites:
"PKG",200,22,1,"PAH",1,1,144,0)
----------
"PKG",200,22,1,"PAH",1,1,145,0)
<List test sites that actually participated in testing and signed off on 
"PKG",200,22,1,"PAH",1,1,146,0)
the patch. A copy and paste from NOIS displaying the test sites in
"PKG",200,22,1,"PAH",1,1,147,0)
production can be used.>
"PKG",200,22,1,"PAH",1,1,148,0)
 
"PKG",200,22,1,"PAH",1,1,149,0)
 
"PKG",200,22,1,"PAH",1,1,150,0)
Documentation Retrieval Instructions
"PKG",200,22,1,"PAH",1,1,151,0)
------------------------------------ 
"PKG",200,22,1,"PAH",1,1,152,0)
Updated documentation describing the new functionality introduced by this 
"PKG",200,22,1,"PAH",1,1,153,0)
patch is available.
"PKG",200,22,1,"PAH",1,1,154,0)
 
"PKG",200,22,1,"PAH",1,1,155,0)
The preferred method is to FTP the files from 
"PKG",200,22,1,"PAH",1,1,156,0)
ftp://download.vista.med.va.gov/. This transmits the files from the first
"PKG",200,22,1,"PAH",1,1,157,0)
available FTP server. Sites may also elect to retrieve software directly
"PKG",200,22,1,"PAH",1,1,158,0)
from a specific server as follows:
"PKG",200,22,1,"PAH",1,1,159,0)
 
"PKG",200,22,1,"PAH",1,1,160,0)
 Albany         ftp.fo-albany.med.va.gov  <ftp://ftp.fo-albany.med.va.gov>
"PKG",200,22,1,"PAH",1,1,161,0)
 Hines          ftp.fo-hines.med.va.gov   <ftp://ftp.fo-hines.med.va.gov>
"PKG",200,22,1,"PAH",1,1,162,0)
 Salt Lake City ftp.fo-slc.med.va.gov     <ftp://ftp.fo-slc.med.va.gov>
"PKG",200,22,1,"PAH",1,1,163,0)
 
"PKG",200,22,1,"PAH",1,1,164,0)
Documentation can also be found on the VA Software Documentation Library 
"PKG",200,22,1,"PAH",1,1,165,0)
at: http://www4.va.gov/vdl/
"PKG",200,22,1,"PAH",1,1,166,0)
 
"PKG",200,22,1,"PAH",1,1,167,0)
Title                         File Name                       FTP Mode
"PKG",200,22,1,"PAH",1,1,168,0)
-----------------------------------------------------------------------
"PKG",200,22,1,"PAH",1,1,169,0)
<Documentation title>       
"PKG",200,22,1,"PAH",1,1,170,0)
 
"PKG",200,22,1,"PAH",1,1,171,0)
 
"PKG",200,22,1,"PAH",1,1,172,0)
Patch Installation:
"PKG",200,22,1,"PAH",1,1,173,0)
 
"PKG",200,22,1,"PAH",1,1,174,0)
 
"PKG",200,22,1,"PAH",1,1,175,0)
Pre/Post Installation Overview
"PKG",200,22,1,"PAH",1,1,176,0)
------------------------------
"PKG",200,22,1,"PAH",1,1,177,0)
<Provide a brief overview of what the pre/post installation entails.  The
"PKG",200,22,1,"PAH",1,1,178,0)
actual instructions will be listed below in the Installation Instructions
"PKG",200,22,1,"PAH",1,1,179,0)
section. Note whether pre/post installation routines can be deleted after
"PKG",200,22,1,"PAH",1,1,180,0)
they run or whether they are automatically deleted.>
"PKG",200,22,1,"PAH",1,1,181,0)
 
"PKG",200,22,1,"PAH",1,1,182,0)
 
"PKG",200,22,1,"PAH",1,1,183,0)
Installation Instructions
"PKG",200,22,1,"PAH",1,1,184,0)
-------------------------       
"PKG",200,22,1,"PAH",1,1,185,0)
 
"PKG",200,22,1,"PAH",1,1,186,0)
  ******************************************************************
"PKG",200,22,1,"PAH",1,1,187,0)
  *  You should install this patch during non-peak hours, when no  *
"PKG",200,22,1,"PAH",1,1,188,0)
  *  Integrated Billing or Accounts Receivable users are on the    *
"PKG",200,22,1,"PAH",1,1,189,0)
  *  system.                                                       *
"PKG",200,22,1,"PAH",1,1,190,0)
  ******************************************************************
"PKG",200,22,1,"PAH",1,1,191,0)
 
"PKG",200,22,1,"PAH",1,1,192,0)
There are no options to disable. 
"PKG",200,22,1,"PAH",1,1,193,0)
 
"PKG",200,22,1,"PAH",1,1,194,0)
Pre-Installation Instructions
"PKG",200,22,1,"PAH",1,1,195,0)
-----------------------------
"PKG",200,22,1,"PAH",1,1,196,0)
<Provide a brief description of what the pre-installation will be doing. 
"PKG",200,22,1,"PAH",1,1,197,0)
List pre-installation instructions (i.e., links, filers, or batch
"PKG",200,22,1,"PAH",1,1,198,0)
transmissions that need to be stopped, jobs unscheduled, etc.), if
"PKG",200,22,1,"PAH",1,1,199,0)
applicable.>
"PKG",200,22,1,"PAH",1,1,200,0)
 
"PKG",200,22,1,"PAH",1,1,201,0)
1.  Obtain the Patch.
"PKG",200,22,1,"PAH",1,1,202,0)
    Obtain the host file PRCA_275_IB_447_16.KID, which contains the
"PKG",200,22,1,"PAH",1,1,203,0)
    following two patch installs:
"PKG",200,22,1,"PAH",1,1,204,0)
  
"PKG",200,22,1,"PAH",1,1,205,0)
        PRCA*4.5*275
"PKG",200,22,1,"PAH",1,1,206,0)
        IB*2.0*447
"PKG",200,22,1,"PAH",1,1,207,0)
  
"PKG",200,22,1,"PAH",1,1,208,0)
    Sites can retrieve VistA software from the following FTP addresses.
"PKG",200,22,1,"PAH",1,1,209,0)
    The preferred method is to FTP the files from:
"PKG",200,22,1,"PAH",1,1,210,0)
  
"PKG",200,22,1,"PAH",1,1,211,0)
                   download.vista.med.va.gov
"PKG",200,22,1,"PAH",1,1,212,0)
  
"PKG",200,22,1,"PAH",1,1,213,0)
    This will transmit the files from the first available FTP server.
"PKG",200,22,1,"PAH",1,1,214,0)
    Sites may also elect to retrieve software directly from a specific
"PKG",200,22,1,"PAH",1,1,215,0)
    server as follows:
"PKG",200,22,1,"PAH",1,1,216,0)
  
"PKG",200,22,1,"PAH",1,1,217,0)
      Albany                  ftp.fo-albany.med.va.gov
"PKG",200,22,1,"PAH",1,1,218,0)
      Hines                   ftp.fo-hines.med.va.gov
"PKG",200,22,1,"PAH",1,1,219,0)
      Salt Lake City          ftp.fo-slc.med.va.gov
"PKG",200,22,1,"PAH",1,1,220,0)
  
"PKG",200,22,1,"PAH",1,1,221,0)
    The PRCA_275_IB_447_16.KID host file is located in the
"PKG",200,22,1,"PAH",1,1,222,0)
    anonymous.software directory.  Use ASCII Mode when downloading the
"PKG",200,22,1,"PAH",1,1,223,0)
    file.
"PKG",200,22,1,"PAH",1,1,224,0)
 
"PKG",200,22,1,"PAH",1,1,225,0)
3.  From the Kernel Installation and Distribution System Menu, select
"PKG",200,22,1,"PAH",1,1,226,0)
    the Installation Menu.  From this menu, you may elect to use the
"PKG",200,22,1,"PAH",1,1,227,0)
    following option. When prompted for the INSTALL enter the patch #(ex.
"PKG",200,22,1,"PAH",1,1,228,0)
    PRCA*4.5*275):
"PKG",200,22,1,"PAH",1,1,229,0)
 
"PKG",200,22,1,"PAH",1,1,230,0)
    a.  Backup a Transport Global - This option will create a backup
"PKG",200,22,1,"PAH",1,1,231,0)
        message of any routines exported with this patch. It will not
"PKG",200,22,1,"PAH",1,1,232,0)
        backup any other changes such as DD's or templates.
"PKG",200,22,1,"PAH",1,1,233,0)
    b.  Compare Transport Global to Current System - This option will
"PKG",200,22,1,"PAH",1,1,234,0)
        allow you to view all changes that will be made when this patch
"PKG",200,22,1,"PAH",1,1,235,0)
        is installed.  It compares all components of this patch
"PKG",200,22,1,"PAH",1,1,236,0)
        (routines, DD's, templates, etc.).
"PKG",200,22,1,"PAH",1,1,237,0)
    c.  Verify Checksums in Transport Global - This option will allow
"PKG",200,22,1,"PAH",1,1,238,0)
        you to ensure the integrity of the routines that are in the
"PKG",200,22,1,"PAH",1,1,239,0)
        transport global.
"PKG",200,22,1,"PAH",1,1,240,0)
     
"PKG",200,22,1,"PAH",1,1,241,0)
4.  From the Installation Menu, select the Install Package(s) option and
"PKG",200,22,1,"PAH",1,1,242,0)
    choose the patch to install.
"PKG",200,22,1,"PAH",1,1,243,0)
 
"PKG",200,22,1,"PAH",1,1,244,0)
5.  When prompted 'Want KIDS to Rebuild Menu Trees Upon Completion of
"PKG",200,22,1,"PAH",1,1,245,0)
    Install? NO//'     
"PKG",200,22,1,"PAH",1,1,246,0)
    <Provide the installer with guidance on whether or not menu trees need
"PKG",200,22,1,"PAH",1,1,247,0)
    to be rebuilt.  For instance the menu trees do not need rebuilt if 
"PKG",200,22,1,"PAH",1,1,248,0)
    there are no menus involved in the patch or their system rebuilds menu
"PKG",200,22,1,"PAH",1,1,249,0)
    trees nightly using TaskMan. If they must answering YES to rebuild
"PKG",200,22,1,"PAH",1,1,250,0)
    the menu trees warn them that it could affect users on the system and
"PKG",200,22,1,"PAH",1,1,251,0)
    installation times will increase.>
"PKG",200,22,1,"PAH",1,1,252,0)
 
"PKG",200,22,1,"PAH",1,1,253,0)
6.  When prompted 'Want KIDS to INHIBIT LOGONs during the install?
"PKG",200,22,1,"PAH",1,1,254,0)
    NO//'
"PKG",200,22,1,"PAH",1,1,255,0)
 
"PKG",200,22,1,"PAH",1,1,256,0)
    <to inhibit logons.>
"PKG",200,22,1,"PAH",1,1,257,0)
 
"PKG",200,22,1,"PAH",1,1,258,0)
7.  When prompted 'Want to DISABLE Scheduled Options, Menu Options, 
"PKG",200,22,1,"PAH",1,1,259,0)
    and Protocols? NO// 
"PKG",200,22,1,"PAH",1,1,260,0)
 
"PKG",200,22,1,"PAH",1,1,261,0)
    <Provide the installer with guidance on whether or not to disable
"PKG",200,22,1,"PAH",1,1,262,0)
    scheduled Options, menu options, and protocols.>
"PKG",200,22,1,"PAH",1,1,263,0)
 
"PKG",200,22,1,"PAH",1,1,264,0)
8.  If prompted "Delay Install (Minutes):  (0 - 60): 0// respond 0.
"PKG",200,22,1,"PAH",1,1,265,0)
 
"PKG",200,22,1,"PAH",1,1,266,0)
9.  When prompted "Enter the Coordinator for Mail Group 'MDA'"
"PKG",200,22,1,"PAH",1,1,267,0)
 
"PKG",200,22,1,"PAH",1,1,268,0)
    Enter:  
"PKG",200,22,1,"PAH",1,1,269,0)
 
"PKG",200,22,1,"PAH",1,1,270,0)
Post-Installation Instructions
"PKG",200,22,1,"PAH",1,1,271,0)
------------------------------
"PKG",200,22,1,"PAH",1,1,272,0)
 
"PKG",200,22,1,"PAH",1,1,273,0)
<Provide a brief description of what the pre-installation will be doing. 
"PKG",200,22,1,"PAH",1,1,274,0)
List pre-installation instructions (i.e., links, filers, or batch
"PKG",200,22,1,"PAH",1,1,275,0)
transmissions that need to be stopped, jobs unscheduled, etc.), if
"PKG",200,22,1,"PAH",1,1,276,0)
applicable.>
"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")
YES
"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")
54
"RTN","IBCAPP")
0^66^B21485583
"RTN","IBCAPP",1,0)
IBCAPP ;ALB/WCJ - Claims Auto Processing Main Processer;27-AUG-10
"RTN","IBCAPP",2,0)
 ;;2.0;INTEGRATED BILLING;**432,447**;21-MAR-94;Build 80
"RTN","IBCAPP",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCAPP",4,0)
 G AWAY
"RTN","IBCAPP",5,0)
AWAY Q
"RTN","IBCAPP",6,0)
 ;
"RTN","IBCAPP",7,0)
EN(IBIFN,IBORIG,IBPYMT,IBWLF) ;
"RTN","IBCAPP",8,0)
 ; This is called from tag BULL^IBCNSBL2.  It is the starting point for the claims auto-processing.
"RTN","IBCAPP",9,0)
 ; Instead of sending a bulletin which started a manual process, the bulletin routine calls this routine
"RTN","IBCAPP",10,0)
 ; which will evaluate the claim and perform one of three actions.
"RTN","IBCAPP",11,0)
 ; 1) auto-process the claim to a subsequent payer.
"RTN","IBCAPP",12,0)
 ; 2) auto-print a claim in case the payer does not want to receive secondary/tertiary claims electronically
"RTN","IBCAPP",13,0)
 ; 3) put the claim on the new COB Management work list.
"RTN","IBCAPP",14,0)
 ;
"RTN","IBCAPP",15,0)
 ;   Input:    IBIFN  --  Pointer to AR (file #430), or Claim (file #399) (same internal number goes to files)
"RTN","IBCAPP",16,0)
 ;            IBORIG  --  Original amount of the claim
"RTN","IBCAPP",17,0)
 ;            IBPYMT  --  Total Amount paid on the claim
"RTN","IBCAPP",18,0)
 ;             IBWLF  --  1 if it should go straight to the work list or 
"RTN","IBCAPP",19,0)
 ;                        0 if it should be evaluated.
"RTN","IBCAPP",20,0)
 ;
"RTN","IBCAPP",21,0)
 N IBREASON,IBX,IBMRANOT,IBERRMSG,IBEOB,IBINS,Z,IB,IBF,IBFT,IBNCN,IBDV,IBREG,IBNCN
"RTN","IBCAPP",22,0)
 S IBMRANOT=1
"RTN","IBCAPP",23,0)
 ;
"RTN","IBCAPP",24,0)
 ; A specific non-human user for all reg 835 EOB filing processes.
"RTN","IBCAPP",25,0)
 ; Change the DUZ to be this user.
"RTN","IBCAPP",26,0)
 ; *** Integration Agreement 4129 - Activated on 30-June-2003 ***
"RTN","IBCAPP",27,0)
 S IBREG=$$IBREG()
"RTN","IBCAPP",28,0)
 I IBREG>0 NEW DUZ D DUZ^XUP(IBREG)  ; IA#4129
"RTN","IBCAPP",29,0)
 ;
"RTN","IBCAPP",30,0)
 ; Check if this is being forced to the work list.  
"RTN","IBCAPP",31,0)
 I $G(IBWLF) S IBREASON="IB813:CHAMPVA Center or TRICARE Fiscal Intermediary or TRICARE Supplemental policy." D PUTONWL(IBIFN,IBREASON) G ENX   ;IB*2*432
"RTN","IBCAPP",32,0)
 ;
"RTN","IBCAPP",33,0)
 I IBPYMT'<IBORIG D WLCK^IBCNSBL2(IBIFN) Q  ; no reason to continue if nothing else owed
"RTN","IBCAPP",34,0)
 ;
"RTN","IBCAPP",35,0)
 ; Make sure there is another payer
"RTN","IBCAPP",36,0)
 I '$P($G(^DGCR(399,IBIFN,"I"_($$COBN^IBCEF(IBIFN)+1))),U,1) D WLCK^IBCNSBL2(IBIFN) G ENX   ;IB*2*432
"RTN","IBCAPP",37,0)
 ;
"RTN","IBCAPP",38,0)
 ; stop if the subsequent claim was already created
"RTN","IBCAPP",39,0)
 I +$P($G(^DGCR(399,IBIFN,"M1")),U,$$COBN^IBCEF(IBIFN)+5) D WLCK^IBCNSBL2(IBIFN) G ENX ;IB*2*432
"RTN","IBCAPP",40,0)
 ;
"RTN","IBCAPP",41,0)
 ; stop if the subsequent payer is Medicare.  If there is a non-Medicare tertiary payer, force to worklist
"RTN","IBCAPP",42,0)
 I $$WNRBILL^IBEFUNC(IBIFN,$$COBN^IBCEF(IBIFN)+1) D  Q
"RTN","IBCAPP",43,0)
 .I $D(^DGCR(399,IBIFN,"I3")),'$$WNRBILL^IBEFUNC(IBIFN,3) D PUTONWL(IBIFN,"IB814") Q 
"RTN","IBCAPP",44,0)
 .D WLCK^IBCNSBL2(IBIFN) Q
"RTN","IBCAPP",45,0)
 ;
"RTN","IBCAPP",46,0)
 ; check the Commercial Auto Processing criteria
"RTN","IBCAPP",47,0)
 S IBX=$$CRIT^IBCAPP1(IBIFN,.IBEOB)
"RTN","IBCAPP",48,0)
 ; 
"RTN","IBCAPP",49,0)
 ; If it fails the criteria check, put it on the work list
"RTN","IBCAPP",50,0)
 I '+IBX D PUTONWL(IBIFN,$P(IBX,U,2)) G ENX   ;IB*2*432
"RTN","IBCAPP",51,0)
 ;
"RTN","IBCAPP",52,0)
 ; Auto Process this bad boy
"RTN","IBCAPP",53,0)
 ;
"RTN","IBCAPP",54,0)
 ; first check that if it's supposed to be printed locally, the printers are defined.
"RTN","IBCAPP",55,0)
 ; if not, put on the work list
"RTN","IBCAPP",56,0)
 ; if they are, then fall through 
"RTN","IBCAPP",57,0)
 S Z=$$COBN^IBCEF(IBIFN)+1
"RTN","IBCAPP",58,0)
 S IBINS=$$POLICY^IBCEF(IBIFN,1,Z)
"RTN","IBCAPP",59,0)
 S IBWLF=0
"RTN","IBCAPP",60,0)
 I $P($G(^DIC(36,IBINS,6)),U,9)=1 D  I IBWLF D PUTONWL(IBIFN,IBREASON) G ENX   ;IB*2*432
"RTN","IBCAPP",61,0)
 .I $$EOBPRT^IBCAPR()="" S IBWLF=1,IBREASON="IB811:Auto-printer not defined in IB Site Parameters" Q
"RTN","IBCAPP",62,0)
 .I $$MRAPRT^IBCAPR()="" S IBWLF=1,IBREASON="IB811:Auto-printer not defined in IB Site Parameters" Q
"RTN","IBCAPP",63,0)
 .S IB=$$FT^IBCU3(IBIFN) ; form type ien (2 or 3)
"RTN","IBCAPP",64,0)
 .I "^2^3^"'[(U_IB_U) S IBWLF=1,IBREASON="IB810:No Form Type defined" Q
"RTN","IBCAPP",65,0)
 .S IBFT=$$FTN^IBCU3(IB) ; form type name
"RTN","IBCAPP",66,0)
 .S IBF=$P($G(^IBE(353,+IB,2)),U,8)
"RTN","IBCAPP",67,0)
 .S:IBF="" IBF=IB ;Forces the use of the output formatter to print bills
"RTN","IBCAPP",68,0)
 .; get default CMS or UB printer (based on claim form type)
"RTN","IBCAPP",69,0)
 .S IBDV=$S(IB=2:$$CMS1500^IBCAPR1(),1:$$UB4PRT^IBCAPR1())
"RTN","IBCAPP",70,0)
 .I IBDV="" S IBWLF=1,IBREASON="IB811:Auto-printer not defined in IB Site Parameters" Q
"RTN","IBCAPP",71,0)
 I $G(IBREASON)]"" D PUTONWL(IBIFN,IBREASON) G ENX   ;IB*2*432
"RTN","IBCAPP",72,0)
 ;
"RTN","IBCAPP",73,0)
 ; create the new claim
"RTN","IBCAPP",74,0)
 S IBNCN=""   ; Initialize New Claim Number
"RTN","IBCAPP",75,0)
 D AUTOCOB^IBCEMQA(IBIFN,IBEOB,.IBERRMSG,IBMRANOT,.IBNCN)
"RTN","IBCAPP",76,0)
 ;
"RTN","IBCAPP",77,0)
 ; make sure everything was cool with creating the new claim.
"RTN","IBCAPP",78,0)
 I $G(IBERRMSG)]""!('+$G(IBNCN)) S IBREASON="IB812:Failed AUTOCOB Generation" D PUTONWL(IBIFN,IBREASON) G ENX   ;IB*2*432
"RTN","IBCAPP",79,0)
 ;
"RTN","IBCAPP",80,0)
 ; If it's to be auto printed, set force to local print flag on new claim 
"RTN","IBCAPP",81,0)
 S IBINS=$$POLICY^IBCEF(IBNCN,1,$$COBN^IBCEF(IBNCN))
"RTN","IBCAPP",82,0)
 ; set field 35 on original claim to indicate subsequent claim was auto-created IB*2.0*447
"RTN","IBCAPP",83,0)
 I $P($G(^DIC(36,IBINS,6)),U,9)=1 D FORCEPRT(IBNCN),AUTOPRC($G(IBIFN),2)
"RTN","IBCAPP",84,0)
 D:$P($G(^DIC(36,IBINS,6)),U,9)'=1 AUTOPRC($G(IBIFN),3)
"RTN","IBCAPP",85,0)
 ;
"RTN","IBCAPP",86,0)
 ; authorize the new claim
"RTN","IBCAPP",87,0)
 D AUTH^IBCEMQA(IBNCN,.IBERRMSG,IBMRANOT)
"RTN","IBCAPP",88,0)
 ;
"RTN","IBCAPP",89,0)
 ; If AUTH error occurred, file the automatic bill generation failure message
"RTN","IBCAPP",90,0)
 I $G(IBERRMSG)]"" D AUTOMSG^IBCESRV3(IBEOB,IBERRMSG) G ENX
"RTN","IBCAPP",91,0)
 ;
"RTN","IBCAPP",92,0)
 ; If local print, then print it
"RTN","IBCAPP",93,0)
 I $P($G(^DIC(36,IBINS,6)),U,9)=1 D STFLP^IBCAPR1(IBNCN)
"RTN","IBCAPP",94,0)
 ;
"RTN","IBCAPP",95,0)
ENX   ;Quit and Cleanup of Main Entry Point, added with IB*2*432
"RTN","IBCAPP",96,0)
 ;
"RTN","IBCAPP",97,0)
 ; DBIA #10111: Allows FM read access of ^XMB(3.8,D0,0) using DIC.
"RTN","IBCAPP",98,0)
 S DIC="^XMB(3.8,",DIC(0)="QM",X="IB DEV TEAM" D ^DIC
"RTN","IBCAPP",99,0)
 ;
"RTN","IBCAPP",100,0)
 Q
"RTN","IBCAPP",101,0)
 ;
"RTN","IBCAPP",102,0)
PUTONWL(IBIFN,IBREASON) ; Put a claim on the worklist
"RTN","IBCAPP",103,0)
 ; IBIFN - internal claim number
"RTN","IBCAPP",104,0)
 ; IBREASON - reason why this is being put on the worklist (error code:text)
"RTN","IBCAPP",105,0)
 ;
"RTN","IBCAPP",106,0)
 N DA,DIE,DR
"RTN","IBCAPP",107,0)
 S DA=IBIFN
"RTN","IBCAPP",108,0)
 S DIE="^DGCR(399,"
"RTN","IBCAPP",109,0)
 S DR="35///1"              ; place on the worklist
"RTN","IBCAPP",110,0)
 S DR=DR_";"_"36///"_$P(IBREASON,":")        ; why placed on worklist
"RTN","IBCAPP",111,0)
 D ^DIE
"RTN","IBCAPP",112,0)
 Q
"RTN","IBCAPP",113,0)
 ;
"RTN","IBCAPP",114,0)
AUTOPRC(IBIFN,IBAP) ; record that a claim was auto-processed IB*2.0*447
"RTN","IBCAPP",115,0)
 ; IBIFN - internal claim number
"RTN","IBCAPP",116,0)
 ; IBAP - 2 = AUTO LOCAL PRINT, 3 = AUTO EDI
"RTN","IBCAPP",117,0)
 ;
"RTN","IBCAPP",118,0)
 N DA,DIE,DR
"RTN","IBCAPP",119,0)
 Q:IBIFN=""
"RTN","IBCAPP",120,0)
 Q:IBAP=""
"RTN","IBCAPP",121,0)
 S DA=IBIFN
"RTN","IBCAPP",122,0)
 S DIE="^DGCR(399,"
"RTN","IBCAPP",123,0)
 S DR="35///"_IBAP              ; UPDATE AUTO-PROCESS FIELD
"RTN","IBCAPP",124,0)
 D ^DIE
"RTN","IBCAPP",125,0)
 Q
"RTN","IBCAPP",126,0)
 ;
"RTN","IBCAPP",127,0)
FORCEPRT(IBIFN) ; set force to local print flag in claim
"RTN","IBCAPP",128,0)
 ; IBIFN - internal claim number 
"RTN","IBCAPP",129,0)
 ;
"RTN","IBCAPP",130,0)
 N DA,DIE,DR
"RTN","IBCAPP",131,0)
 S DA=IBIFN
"RTN","IBCAPP",132,0)
 S DIE="^DGCR(399,"
"RTN","IBCAPP",133,0)
 S DR="27///1"      ; Force Local Print
"RTN","IBCAPP",134,0)
 D ^DIE
"RTN","IBCAPP",135,0)
 Q
"RTN","IBCAPP",136,0)
 ;
"RTN","IBCAPP",137,0)
IBREG() ; Returns IEN (Internal Entry Number) from file #200 for
"RTN","IBCAPP",138,0)
 ; the Bill Authorizer of acceptable regular (non MRA) secondary claims,
"RTN","IBCAPP",139,0)
 ; namely, AUTHORIZER,IB REG
"RTN","IBCAPP",140,0)
 ;
"RTN","IBCAPP",141,0)
 ; Output:    -1   if record not on file
"RTN","IBCAPP",142,0)
 ;            IEN  if record is on file
"RTN","IBCAPP",143,0)
 ;
"RTN","IBCAPP",144,0)
 N DIC,X,Y
"RTN","IBCAPP",145,0)
 S DIC(0)="MO",DIC="^VA(200,",X="AUTHORIZER,IB REG"
"RTN","IBCAPP",146,0)
 ; call FM lookup utility
"RTN","IBCAPP",147,0)
 D ^DIC
"RTN","IBCAPP",148,0)
 ; if record is already on file, return IEN
"RTN","IBCAPP",149,0)
 ; else  return -1
"RTN","IBCAPP",150,0)
 Q +Y
"RTN","IBCAPP1")
0^35^B38009717
"RTN","IBCAPP1",1,0)
IBCAPP1 ;ALB/WCJ - Claims Auto Processing Utilities;27-AUG-10
"RTN","IBCAPP1",2,0)
 ;;2.0;INTEGRATED BILLING;**432,447**;21-MAR-94;Build 80
"RTN","IBCAPP1",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCAPP1",4,0)
 G AWAY
"RTN","IBCAPP1",5,0)
AWAY Q
"RTN","IBCAPP1",6,0)
 ;
"RTN","IBCAPP1",7,0)
 ; Borrowed heavily from the Medicare auto processing 
"RTN","IBCAPP1",8,0)
CRIT(IBIFN,IBEOB) ; Function to determine if a claim meets the criteria for auto-authorization and
"RTN","IBCAPP1",9,0)
 ; secondary/tertiary claim submission for NON MEDICARE claims
"RTN","IBCAPP1",10,0)
 ;
"RTN","IBCAPP1",11,0)
 ; Input:  IBIFN - internal entry number for an entry in 399
"RTN","IBCAPP1",12,0)
 ;         IBEOB - by reference to it can be returned
"RTN","IBCAPP1",13,0)
 ; Output:  This function returns a pieced string
"RTN","IBCAPP1",14,0)
 ;          [1] 0 or 1, EOB meets criteria
"RTN","IBCAPP1",15,0)
 ;          [2] error message if the first piece is 0
"RTN","IBCAPP1",16,0)
 ;
"RTN","IBCAPP1",17,0)
 ; The IB system shall automatically generate a non-Medicare secondary/tertiary claim to the next payer on
"RTN","IBCAPP1",18,0)
 ; the claim when all services lines on the previous EOB(s) meet the following criteria:
"RTN","IBCAPP1",19,0)
 ;
"RTN","IBCAPP1",20,0)
 ; Adjustment group code of CO is associated with one of the following reason codes:
"RTN","IBCAPP1",21,0)
 ; A2; B6; 42; 45; 102; 104; 118; 131; 23; 232; 44; 59; 94; 97; or 10
"RTN","IBCAPP1",22,0)
 ; Patient Responsibility group code of PR is associated with one of the following reason codes:
"RTN","IBCAPP1",23,0)
 ; 1; 2; or 66 
"RTN","IBCAPP1",24,0)
 ; The sum of the deductible, coinsurance and co-payment amounts is greater than $0.00
"RTN","IBCAPP1",25,0)
 ; The claim status is Approved; and
"RTN","IBCAPP1",26,0)
 ; The CLP02 equals one of the following:1; 2; or 3
"RTN","IBCAPP1",27,0)
 N IB0,IBCT,IBI,IBILLCNT,IBPTRESP,IBSHEOB,REASON,Z,ERR
"RTN","IBCAPP1",28,0)
 S OK=0,REASON="Unknown",IBEOB=0
"RTN","IBCAPP1",29,0)
 ;
"RTN","IBCAPP1",30,0)
 ; Check the parameter value (Make sure this bad boy is turned on).
"RTN","IBCAPP1",31,0)
 I '+IBIFN S REASON="IB807:Need to pass in an internal claim number" G CRITX
"RTN","IBCAPP1",32,0)
 ;
"RTN","IBCAPP1",33,0)
 ; Check the parameter value (Make sure this baby is turned on).
"RTN","IBCAPP1",34,0)
 I '$P($G(^IBE(350.9,1,8)),U,17) S REASON="IB800:Automatic EOB Processing parameter is turned off.  File 350.9, Field 8.17." G CRITX
"RTN","IBCAPP1",35,0)
 ;
"RTN","IBCAPP1",36,0)
 ; Quit if we don't have any EOBs
"RTN","IBCAPP1",37,0)
 I '$D(^IBM(361.1,"B",IBIFN)),'$D(^IBM(361.1,"C",IBIFN)) S REASON="IB801:No EOB Data Found" G CRITX
"RTN","IBCAPP1",38,0)
 ;
"RTN","IBCAPP1",39,0)
 ; Let's go get us some EOBs
"RTN","IBCAPP1",40,0)
 S IBCT=0,IBI=0
"RTN","IBCAPP1",41,0)
 F  S IBI=$O(^IBM(361.1,"B",IBIFN,IBI)) Q:'IBI  D
"RTN","IBCAPP1",42,0)
 . S IB0=$G(^IBM(361.1,IBI,0))
"RTN","IBCAPP1",43,0)
 . Q:IB0=""
"RTN","IBCAPP1",44,0)
 . Q:$P(IB0,U,4)'=0  ; do not care about MRAs, only EOBs
"RTN","IBCAPP1",45,0)
 . S Z=+$O(^IBM(361.1,IBI,8,0))
"RTN","IBCAPP1",46,0)
 . I '$O(^IBM(361.1,IBI,8,Z)) S IBCT=IBCT+1,IBSHEOB(IBI)=0  ; Entire EOB belongs to the bill
"RTN","IBCAPP1",47,0)
 ;
"RTN","IBCAPP1",48,0)
 S IBI=0
"RTN","IBCAPP1",49,0)
 F  S IBI=$O(^IBM(361.1,"C",IBIFN,IBI)) Q:'IBI  D
"RTN","IBCAPP1",50,0)
 . S IB0=$G(^IBM(361.1,IBI,0))
"RTN","IBCAPP1",51,0)
 . Q:IB0=""
"RTN","IBCAPP1",52,0)
 . Q:$P(IB0,U,4)'=0  ; do not care about MRAs, only EOBs
"RTN","IBCAPP1",53,0)
 . I '$D(IBSHEOB(IBI)) S IBCT=IBCT+1 ; don't count it twice
"RTN","IBCAPP1",54,0)
 . S IBSHEOB(IBI)=1 ; EOB has been reapportioned at the site
"RTN","IBCAPP1",55,0)
 ;
"RTN","IBCAPP1",56,0)
 I '$D(IBSHEOB) S ERR=1,REASON="IB801:No EOB Data Found" G CRITX
"RTN","IBCAPP1",57,0)
 I $G(IBCT)>1 S ERR=1,REASON="IB802:Multiple EOBs found for this claim" G CRITX
"RTN","IBCAPP1",58,0)
 ;
"RTN","IBCAPP1",59,0)
 ; only one EOB
"RTN","IBCAPP1",60,0)
 S ERR=0
"RTN","IBCAPP1",61,0)
 S IBEOB=$O(IBSHEOB(0))
"RTN","IBCAPP1",62,0)
 ;
"RTN","IBCAPP1",63,0)
 I $D(^IBM(361.1,IBEOB,"ERR")) S REASON="IB803:EOB Filing Errors" G CRITX
"RTN","IBCAPP1",64,0)
 ;
"RTN","IBCAPP1",65,0)
 S IB0=$G(^IBM(361.1,IBEOB,0))
"RTN","IBCAPP1",66,0)
 I $P(IB0,U,13)'=1 S REASON="IB804:Claim Status must be PROCESSED" G CRITX
"RTN","IBCAPP1",67,0)
 ;
"RTN","IBCAPP1",68,0)
 ; If this EOB is a split EOB, then don't allow it
"RTN","IBCAPP1",69,0)
 I $$SPLIT^IBCEMU1(IBEOB) S REASON="IB805:Claim level remark code MA15 received.  Multiple EOBs." G CRITX
"RTN","IBCAPP1",70,0)
 ;
"RTN","IBCAPP1",71,0)
 ; More than one claim on this EOB
"RTN","IBCAPP1",72,0)
 S Z=0 F  S Z=$O(^IBM(361.1,IBEOB,8,Z)) Q:'Z  I $P($G(^IBM(361.1,IBEOB,8,Z,0)),U,3)'=IBIFN S REASON="IB809:EOB Split to more claims" G CRITX
"RTN","IBCAPP1",73,0)
 ;
"RTN","IBCAPP1",74,0)
 ; Call the function that checks the claim level and/or line level
"RTN","IBCAPP1",75,0)
 ; adjustments for this EOB
"RTN","IBCAPP1",76,0)
 I '$$CAS(IBEOB,"B",.REASON) S REASON="IB808:Failed adjustment criteria selection" G CRITX  ; "B" for both
"RTN","IBCAPP1",77,0)
 ;
"RTN","IBCAPP1",78,0)
 ; Make sure the balance remaining amount is greater than $0 IB*2.0*447
"RTN","IBCAPP1",79,0)
 S IBPTRESP=$$TOT^IBCECOB2(IBIFN,1)
"RTN","IBCAPP1",80,0)
 I IBPTRESP'>0 S REASON="IB806:Balance remaining dollar amount is less than or equal to $0" G CRITX
"RTN","IBCAPP1",81,0)
 ;
"RTN","IBCAPP1",82,0)
 ; At this point, we're OK
"RTN","IBCAPP1",83,0)
 S OK=1,REASON=""
"RTN","IBCAPP1",84,0)
 ;
"RTN","IBCAPP1",85,0)
CRITX ;
"RTN","IBCAPP1",86,0)
 ;
"RTN","IBCAPP1",87,0)
 Q OK_U_REASON
"RTN","IBCAPP1",88,0)
 ;
"RTN","IBCAPP1",89,0)
 ;
"RTN","IBCAPP1",90,0)
CAS(IBEOB,ADJFLAG,REASON) ; This function determines if the EOB
"RTN","IBCAPP1",91,0)
 ; adjustment group codes and reason codes from file 361.1 (either
"RTN","IBCAPP1",92,0)
 ; claim level or line level or both) meet the criteria for auto-
"RTN","IBCAPP1",93,0)
 ; authorization and secondary claim submission.
"RTN","IBCAPP1",94,0)
 ;
"RTN","IBCAPP1",95,0)
 ; Input Parameters
"RTN","IBCAPP1",96,0)
 ;        IBEOB    - ien of entry in file 361.1
"RTN","IBCAPP1",97,0)
 ;      ADJFLAG    - adjustment flag
"RTN","IBCAPP1",98,0)
 ;                   "C" - look at claim level adjustments only
"RTN","IBCAPP1",99,0)
 ;                   "L" - look at line level adjustments only
"RTN","IBCAPP1",100,0)
 ;                   "B" - look at both claim and line level adjustments
"RTN","IBCAPP1",101,0)
 ; Output Parameter
"RTN","IBCAPP1",102,0)
 ;       REASON    - error message describing why it failed
"RTN","IBCAPP1",103,0)
 ;
"RTN","IBCAPP1",104,0)
 ; Function Value is either 0 or 1, indicating if it passed the criteria
"RTN","IBCAPP1",105,0)
 ;
"RTN","IBCAPP1",106,0)
 NEW EOBADJ,OK,OKCOMBO,PATRESP,STOP,LNIEN
"RTN","IBCAPP1",107,0)
 ;
"RTN","IBCAPP1",108,0)
 S IBEOB=+$G(IBEOB)
"RTN","IBCAPP1",109,0)
 S ADJFLAG=$G(ADJFLAG,"B")     ; default is "B" if not passed in
"RTN","IBCAPP1",110,0)
 D BUILD           ; build the array of OK group/reason combinations
"RTN","IBCAPP1",111,0)
 S PATRESP=0       ; patient responsibility flag (default false)
"RTN","IBCAPP1",112,0)
 S STOP=0          ; Stop flag
"RTN","IBCAPP1",113,0)
 S OK=0            ; OK flag (function value)
"RTN","IBCAPP1",114,0)
 S REASON=""       ; error reason text
"RTN","IBCAPP1",115,0)
 ;
"RTN","IBCAPP1",116,0)
 ; claim level adjustments
"RTN","IBCAPP1",117,0)
 I $F(".C.B.","."_ADJFLAG_".") D
"RTN","IBCAPP1",118,0)
 . KILL EOBADJ
"RTN","IBCAPP1",119,0)
 . M EOBADJ=^IBM(361.1,IBEOB,10)
"RTN","IBCAPP1",120,0)
 . D ADJCHK
"RTN","IBCAPP1",121,0)
 . Q
"RTN","IBCAPP1",122,0)
 ;
"RTN","IBCAPP1",123,0)
 ; Get out if the claim level adjustments failed
"RTN","IBCAPP1",124,0)
 I STOP G CASX
"RTN","IBCAPP1",125,0)
 ;
"RTN","IBCAPP1",126,0)
 ; line level adjustments
"RTN","IBCAPP1",127,0)
 I $F(".L.B.","."_ADJFLAG_".") D
"RTN","IBCAPP1",128,0)
 . S LNIEN=0
"RTN","IBCAPP1",129,0)
 . F  S LNIEN=$O(^IBM(361.1,IBEOB,15,LNIEN)) Q:'LNIEN  D  Q:STOP
"RTN","IBCAPP1",130,0)
 .. KILL EOBADJ
"RTN","IBCAPP1",131,0)
 .. M EOBADJ=^IBM(361.1,IBEOB,15,LNIEN,1)
"RTN","IBCAPP1",132,0)
 .. D ADJCHK
"RTN","IBCAPP1",133,0)
 .. Q
"RTN","IBCAPP1",134,0)
 . Q
"RTN","IBCAPP1",135,0)
 ;
"RTN","IBCAPP1",136,0)
 ; Get out if the line level adjustments failed
"RTN","IBCAPP1",137,0)
 I STOP G CASX
"RTN","IBCAPP1",138,0)
 ;
"RTN","IBCAPP1",139,0)
 ; Get out if there was no patient responsibility adjustments found
"RTN","IBCAPP1",140,0)
 I 'PATRESP S REASON="No Patient Responsibility Adjustments found" G CASX
"RTN","IBCAPP1",141,0)
 ;
"RTN","IBCAPP1",142,0)
 ; At this point, we're OK
"RTN","IBCAPP1",143,0)
 S OK=1,REASON=""
"RTN","IBCAPP1",144,0)
CASX ;
"RTN","IBCAPP1",145,0)
 Q OK
"RTN","IBCAPP1",146,0)
 ;
"RTN","IBCAPP1",147,0)
 ;
"RTN","IBCAPP1",148,0)
ADJCHK ; This procedure checks the adjustments for this EOB.  The group codes
"RTN","IBCAPP1",149,0)
 ; and reason codes are in the EOBADJ array structures from file 361.1.
"RTN","IBCAPP1",150,0)
 ;
"RTN","IBCAPP1",151,0)
 ;   Variables STOP and REASON will be returned on an error
"RTN","IBCAPP1",152,0)
 ;   Variable PATRESP will be returned if a valid PR adjustment found
"RTN","IBCAPP1",153,0)
 ;
"RTN","IBCAPP1",154,0)
 NEW ADJIEN,GROUP,RSNIEN,RSNCODE
"RTN","IBCAPP1",155,0)
 S ADJIEN=0
"RTN","IBCAPP1",156,0)
 F  S ADJIEN=$O(EOBADJ(ADJIEN)) Q:'ADJIEN  D  Q:STOP
"RTN","IBCAPP1",157,0)
 . S GROUP=$P($G(EOBADJ(ADJIEN,0)),U,1)
"RTN","IBCAPP1",158,0)
 . I GROUP="LQ" Q      ; line level remark code kludge: 42 rec [3]
"RTN","IBCAPP1",159,0)
 . I GROUP="" S GROUP="<Undefined>"
"RTN","IBCAPP1",160,0)
 . I '$D(OKCOMBO(GROUP)) S STOP=1,REASON="Unacceptable Claim Adjustment Group Code: "_GROUP Q
"RTN","IBCAPP1",161,0)
 . S RSNIEN=0
"RTN","IBCAPP1",162,0)
 . F  S RSNIEN=$O(EOBADJ(ADJIEN,1,RSNIEN)) Q:'RSNIEN  D  Q:STOP
"RTN","IBCAPP1",163,0)
 .. S RSNCODE=$P($G(EOBADJ(ADJIEN,1,RSNIEN,0)),U,1)
"RTN","IBCAPP1",164,0)
 .. ;
"RTN","IBCAPP1",165,0)
 .. ; Ignore some special adjustment data that is filed with the MRA
"RTN","IBCAPP1",166,0)
 .. I GROUP="PR",RSNCODE="AAA" Q    ; Allowed Amount: 41 rec [3]
"RTN","IBCAPP1",167,0)
 .. I GROUP="OA",RSNCODE="AB3" Q    ; Covered Amount: 15 rec [3]
"RTN","IBCAPP1",168,0)
 .. ;
"RTN","IBCAPP1",169,0)
 .. I RSNCODE="" S RSNCODE="<Undefined>"
"RTN","IBCAPP1",170,0)
 .. I '$D(OKCOMBO(GROUP,RSNCODE)) S STOP=1,REASON="Unacceptable Reason Code ("_RSNCODE_") for Claim Adjustment Group Code ("_GROUP_")" Q
"RTN","IBCAPP1",171,0)
 .. ;
"RTN","IBCAPP1",172,0)
 .. ; Set the flag if the group is PR
"RTN","IBCAPP1",173,0)
 .. I GROUP="PR" S PATRESP=1
"RTN","IBCAPP1",174,0)
 .. Q
"RTN","IBCAPP1",175,0)
 . Q
"RTN","IBCAPP1",176,0)
ADJCHKX ;
"RTN","IBCAPP1",177,0)
 Q
"RTN","IBCAPP1",178,0)
 ;
"RTN","IBCAPP1",179,0)
 ;
"RTN","IBCAPP1",180,0)
BUILD ; This procedure builds the OKCOMBO array which identifies which
"RTN","IBCAPP1",181,0)
 ; combinations of group codes and reason codes are acceptable
"RTN","IBCAPP1",182,0)
 ;
"RTN","IBCAPP1",183,0)
 NEW LN,LINE,GROUP,RSNLST,R,RSN
"RTN","IBCAPP1",184,0)
 KILL OKCOMBO
"RTN","IBCAPP1",185,0)
 F LN=1:1 D  Q:$P(LINE,";",4)=""&$D(OKCOMBO)
"RTN","IBCAPP1",186,0)
 . S LINE=$T(OKCOMBO+LN)
"RTN","IBCAPP1",187,0)
 . S GROUP=$P(LINE,";",3) Q:GROUP=""
"RTN","IBCAPP1",188,0)
 . S RSNLST=$P(LINE,";",4) Q:RSNLST=""
"RTN","IBCAPP1",189,0)
 . F R=1:1:$L(RSNLST,",") D
"RTN","IBCAPP1",190,0)
 .. S RSN=$P(RSNLST,",",R) Q:RSN=""
"RTN","IBCAPP1",191,0)
 .. S OKCOMBO(GROUP,RSN)=""
"RTN","IBCAPP1",192,0)
 .. Q
"RTN","IBCAPP1",193,0)
 . Q
"RTN","IBCAPP1",194,0)
BUILDX ;
"RTN","IBCAPP1",195,0)
 Q
"RTN","IBCAPP1",196,0)
 ;
"RTN","IBCAPP1",197,0)
 ;
"RTN","IBCAPP1",198,0)
OKCOMBO ; This section lists OK combinations of adjustment category group codes
"RTN","IBCAPP1",199,0)
 ; and associated reason codes.
"RTN","IBCAPP1",200,0)
 ; The format is as follows - semi-colon delimiter
"RTN","IBCAPP1",201,0)
 ;     [3] Adjustment category (group code)
"RTN","IBCAPP1",202,0)
 ;     [4] List of acceptable reason codes - comma delimiter
"RTN","IBCAPP1",203,0)
 ;
"RTN","IBCAPP1",204,0)
 ;;CO;A2,B6,42,45,102,104,118,131,23,232,44,59,94,97,10
"RTN","IBCAPP1",205,0)
 ;;PR;1,2,66
"RTN","IBCAPP1",206,0)
 ;
"RTN","IBCAPP2")
0^31^B43298709
"RTN","IBCAPP2",1,0)
IBCAPP2 ;ALB/GEF - Claims Auto Processing  ;14-OCT-10
"RTN","IBCAPP2",2,0)
 ;;2.0;INTEGRATED BILLING;**432,447**;21-MAR-94;Build 80
"RTN","IBCAPP2",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCAPP2",4,0)
 ;
"RTN","IBCAPP2",5,0)
 ; IBMRANOT = 1 when dealing with the COB Management Worklist.   
"RTN","IBCAPP2",6,0)
 ;            It is set by the entry action in the option file. 
"RTN","IBCAPP2",7,0)
 ;
"RTN","IBCAPP2",8,0)
CAP ; Build list from CAP x-ref entrypoint.  Called from BLD^IBCECOB1 for non-MRA worklist
"RTN","IBCAPP2",9,0)
 N IBDA,IBIFN
"RTN","IBCAPP2",10,0)
 S IBIFN=0 F  S IBIFN=$O(^DGCR(399,"CAP",1,IBIFN)) Q:'IBIFN  D
"RTN","IBCAPP2",11,0)
 .; screen all eob's for the claim to see if claim can be on worklist
"RTN","IBCAPP2",12,0)
 .; IBDA= ien of 1st eob to pass all checks - or - 0 if none passed - or - -1 if process as paper EOB
"RTN","IBCAPP2",13,0)
 .S IBDA=$$MELG(IBIFN,IBMRADUP) Q:'IBDA
"RTN","IBCAPP2",14,0)
 .D BLD1(IBIFN,$S(IBDA=-1:"",1:IBDA))
"RTN","IBCAPP2",15,0)
 Q
"RTN","IBCAPP2",16,0)
BLD1(IBIFN,IBDA) ;
"RTN","IBCAPP2",17,0)
 N IB3611,IBTXT,IBX,IBPY,I,IB364,IBDT,IBAPY,IBB,IBB364,IBBPY,IBDAY,IBEUT
"RTN","IBCAPP2",18,0)
 N IBINS1,IBINS2,IBMRACNT,Z,Z0,IBMUT,IBNBAL,IBNDI1,IBNDI2,IBNDI3,IBNDM
"RTN","IBCAPP2",19,0)
 N IBPTRSP,IBQ,IBSEQ,IBSRVC,IBEXPY,IBFND,IBINS,IBNDS,IBOAM,IBPTNM,IBDENDUP
"RTN","IBCAPP2",20,0)
 Q:$D(^TMP("IBCOBSTX",$J,IBIFN))  ;show each bill once on the worklist
"RTN","IBCAPP2",21,0)
 S IBB=$G(^DGCR(399,IBIFN,0))
"RTN","IBCAPP2",22,0)
 S IBNDS=$G(^DGCR(399,IBIFN,"S")),IBNDI1=$G(^("I1")),IBNDI2=$G(^("I2")),IBNDI3=$G(^("I3")),IBNDM=$G(^("M"))
"RTN","IBCAPP2",23,0)
 S IBMUT=+$P(IBNDS,U,8),IBEUT=+$P(IBNDS,U,2)
"RTN","IBCAPP2",24,0)
 S IBINS="",IBSEQ=$$COBN^IBCEF(IBIFN),IB364="UNKNOWN",IBDT="UNKNOWN"
"RTN","IBCAPP2",25,0)
 S IB3611=$S($G(IBDA)'="":$G(^IBM(361.1,IBDA,0)),1:"")
"RTN","IBCAPP2",26,0)
 I $G(IB3611)'="" S IB364=$P(IB3611,U,19),IBDT=+$P(IB3611,U,6),IBSEQ=$P(IB3611,U,15)
"RTN","IBCAPP2",27,0)
 F I=1:1:3 S Z="IBNDI"_I I @Z D
"RTN","IBCAPP2",28,0)
 . N Q
"RTN","IBCAPP2",29,0)
 . S Q=(IBSEQ=I)
"RTN","IBCAPP2",30,0)
 . I Q S IBINS1=+@Z_U_$P($G(^DIC(36,+@Z,0)),U)
"RTN","IBCAPP2",31,0)
 . S IBINS=IBINS_$S(IBINS="":"",1:", ")_$P($G(^DIC(36,+@Z,0)),U)
"RTN","IBCAPP2",32,0)
 ; Get the payer/insurance company that comes after Medicare WNR
"RTN","IBCAPP2",33,0)
 ; If WNR is Primary, get the secondary ins. co.
"RTN","IBCAPP2",34,0)
 ; If WNR is secondary, get the tertiary ins. co.
"RTN","IBCAPP2",35,0)
 D  I $P($G(IBINS2),U,2)="" S $P(IBINS2,U,2)="UNKNOWN"
"RTN","IBCAPP2",36,0)
 . I $$WNRBILL^IBEFUNC(IBIFN,1) S IBINS2=+IBNDI2_U_$P($G(^DIC(36,+IBNDI2,0)),U) Q
"RTN","IBCAPP2",37,0)
 . S IBINS2=+IBNDI3_U_$P($G(^DIC(36,+IBNDI3,0)),U)
"RTN","IBCAPP2",38,0)
 S IBFND=0
"RTN","IBCAPP2",39,0)
 ; biller entry not ALL and no biller, then get entered/edited by user
"RTN","IBCAPP2",40,0)
 I $D(^TMP("IBBIL",$J)) D  Q:'IBFND
"RTN","IBCAPP2",41,0)
 . S IBFND=$S($D(^TMP("IBBIL",$J,IBMUT)):IBMUT,$D(^TMP("IBBIL",$J,IBEUT)):IBEUT,1:0)
"RTN","IBCAPP2",42,0)
 S Z=$S(IBFND:IBFND,IBMUT:IBMUT,1:IBEUT)
"RTN","IBCAPP2",43,0)
 S IBMUT=$P($G(^VA(200,+Z,0)),U)_"~"_Z
"RTN","IBCAPP2",44,0)
 S:'$P(IBMUT,"~",2) IBMUT="UNKNOWN~0"
"RTN","IBCAPP2",45,0)
 S IBBPY=+$$COBN^IBCEF(IBIFN),IBQ=1
"RTN","IBCAPP2",46,0)
 ;IBQ;1=EOB without subsequent insurer,0=COB,2=0 balance
"RTN","IBCAPP2",47,0)
 D  ;I IBQ Q
"RTN","IBCAPP2",48,0)
 . ;Check for no reimbursable subsequent insurance
"RTN","IBCAPP2",49,0)
 .  F I=IBBPY+1:1:3 D  Q:'IBQ
"RTN","IBCAPP2",50,0)
 .. S Z="IBNDI"_I,Z=$G(@Z)
"RTN","IBCAPP2",51,0)
 .. I $P($G(^DIC(36,+Z,0)),U,2)="N" S IBQ=0 Q
"RTN","IBCAPP2",52,0)
 . ;Check if next ins doesn't exist or next bill# already created
"RTN","IBCAPP2",53,0)
 . S Z="IBNDI"_(IBBPY+1),Z=$G(@Z)
"RTN","IBCAPP2",54,0)
 . I Z,'$P($G(^DGCR(399,IBIFN,"M1")),U,5+IBBPY) S IBQ=0
"RTN","IBCAPP2",55,0)
 ;
"RTN","IBCAPP2",56,0)
 ; Days since transmission of latest bill in COB - IBDAY
"RTN","IBCAPP2",57,0)
 S IBDAY=+$P($G(^DGCR(399,IBIFN,"TX")),U,2) I IBDAY S IBDAY=$$FMDIFF^XLFDT(DT,IBDAY,1)
"RTN","IBCAPP2",58,0)
 ; if no Last Electronic Extract Date on file 399, get it from file 364
"RTN","IBCAPP2",59,0)
 I 'IBDAY D  I IBDAY S IBDAY=$$FMDIFF^XLFDT(DT,IBDAY,1) ;calc. the difference
"RTN","IBCAPP2",60,0)
 . S IBB364=$$LAST364^IBCEF4(IBIFN) I IBB364'="" S IBDAY=+$P($P($G(^IBA(364,IBB364,0)),U,4),".",1)
"RTN","IBCAPP2",61,0)
 ;
"RTN","IBCAPP2",62,0)
 S IBAPY=$$TPR^PRCAFN(IBIFN) ; payment on this bill from A/R  IA#380
"RTN","IBCAPP2",63,0)
 S:$G(IBDA)'="" IBEXPY=+$G(^IBM(361.1,IBDA,1))       ; payer paid amount
"RTN","IBCAPP2",64,0)
 S IBPY=$S(IBAPY:IBAPY,1:+$G(IBEXPY))
"RTN","IBCAPP2",65,0)
 S IBOAM=+$G(^DGCR(399,IBIFN,"U1"))     ; total charges for bill
"RTN","IBCAPP2",66,0)
 ; Don't include claim if AR STATUS is COLLECTED/CLOSED and no subsequent payer and not one of the TRICARE/Champus claims that needs to be evaluated for Pt Payment,remove from list and quit
"RTN","IBCAPP2",67,0)
 I $P($$BILL^RCJIBFN2(IBIFN),U,2)=22 S IBX=$$EOB^IBCNSBL2(IBIFN,IBOAM,IBPY,.IBTXT) I '$D(IBTXT) D RMV(IBIFN) Q
"RTN","IBCAPP2",68,0)
 S IBNBAL=IBOAM-IBPY
"RTN","IBCAPP2",69,0)
 S IBPTRSP=$S(IBNBAL>0:IBNBAL,1:0)
"RTN","IBCAPP2",70,0)
 I IBNBAL'>0 S IBQ=2
"RTN","IBCAPP2",71,0)
 S IBPTNM=$P($G(^DPT(+$P($G(^DGCR(399,IBIFN,0)),U,2),0)),U) I IBPTNM="" S IBPTNM="UNKNOWN"
"RTN","IBCAPP2",72,0)
 S IBSRVC=$P($G(^DGCR(399,IBIFN,"U")),U)
"RTN","IBCAPP2",73,0)
 S Z0=$S(IBSRT="B":IBMUT,IBSRT="D":-IBDAY,IBSRT="I":$P(IBINS2,U,2)_"~"_$P(IBINS2,U),IBSRT="M":$$EXTERNAL^DILFD(361.1,.13,"",$P(IB3611,"^",13)),IBSRT="R":-IBPTRSP,IBSRT="P":IBPTNM,IBSRT="S":+IBSRVC,1:+IBDT)
"RTN","IBCAPP2",74,0)
 S:((IBSRT="M")&(Z0="")) Z0="UNKNOWN"   ;USE UNKNOWN IF NOT SET - BI;IB*2.0*432
"RTN","IBCAPP2",75,0)
 S ^TMP("IBCOBST",$J,Z0,IBIFN)=IBSRVC_U_IBOAM_U_IBAPY_U_$S(IBNBAL>0:IBNBAL,1:0)_U_$P(IBB,U,5)_U_$P(IBB,U,19)_U_IBBPY_U_$P(IBMUT,"~")_U_IBINS_U_$G(IBDA)_U_$$HIS(IBIFN)_U_$G(IBDAY)_U_$G(IBDT)_U_IBQ_U_$G(IB364)_U_IBSEQ_U_$G(IBEXPY)_U_IBPTRSP
"RTN","IBCAPP2",76,0)
 S ^TMP("IBCOBST",$J,Z0,IBIFN,1)=$S($G(IB3611)="":"No EEOB Received ",1:$$EXTERNAL^DILFD(361.1,.13,"",$P(IB3611,"^",13))_", "_$$FMTE^XLFDT($P($P(IB3611,"^",6),"."))_"^"_$P(IB3611,"^",16))
"RTN","IBCAPP2",77,0)
 S ^TMP("IBCOBSTX",$J,IBIFN)=$G(IBDA)  ;keep track of compiled IBIFN's
"RTN","IBCAPP2",78,0)
 ;
"RTN","IBCAPP2",79,0)
 ; Save some data when there are multiple MRA's on file for this bill
"RTN","IBCAPP2",80,0)
 S IBMRACNT=$$MRACNT^IBCEMU1(IBIFN,$G(IBMRANOT))   ;WCJ IB*2.0*432
"RTN","IBCAPP2",81,0)
 I IBMRACNT>1 S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,1)="Multiple "_$S($G(IBMRANOT):"EOBs",1:"MRA's")_" on file"  ;WCJ IB*2.0*432
"RTN","IBCAPP2",82,0)
 S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,3)=IBMRACNT
"RTN","IBCAPP2",83,0)
 S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,4)=$G(IBDENDUP)
"RTN","IBCAPP2",84,0)
 S:$G(IBDA)'="" $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,4)=$$DENDUP^IBCEMU4(IBDA,1)
"RTN","IBCAPP2",85,0)
 Q
"RTN","IBCAPP2",86,0)
 ;
"RTN","IBCAPP2",87,0)
HIS(IBIFN) ; COB history
"RTN","IBCAPP2",88,0)
 N A,B,IBST,IBBIL,IBHIS
"RTN","IBCAPP2",89,0)
 S IBHIS="",A=0 F  S A=$O(^IBM(361.1,"ABS",IBIFN,A)) Q:'A  S B=0 F  S B=$O(^IBM(361.1,"ABS",IBIFN,A,B)) Q:'B  D
"RTN","IBCAPP2",90,0)
 . S IBST=$P($G(^IBM(361.1,B,0)),U,4),IBBIL=$P($G(^DGCR(399,IBIFN,"M1")),U,4+A)   ;WCJ IB*2.0*432 added $G
"RTN","IBCAPP2",91,0)
 . Q:IBBIL=""
"RTN","IBCAPP2",92,0)
 . S IBHIS=IBHIS_$S(IBHIS="":"",1:";")_$S(A=1:"PRIMARY",A=2:"SECONDARY",1:"TERTIARY")_" "_$S(IBST:"MRA",1:"EOB")_" RECEIVED - "_IBBIL
"RTN","IBCAPP2",93,0)
 I '$D(^IBM(361.1,"ABS",IBIFN)) F A=1:1:3 S IBBIL=$P($G(^DGCR(399,IBIFN,"M1")),U,4+A) I IBBIL'="" S IBHIS=IBHIS_$S(IBHIS="":"",1:";")_$S(A=1:"PRIMARY",A=2:"SECONDARY",A=3:"TERTIARY",1:"UNKNOWN")_" No EOB RECEIVED - "_IBBIL
"RTN","IBCAPP2",94,0)
 Q IBHIS
"RTN","IBCAPP2",95,0)
 ;
"RTN","IBCAPP2",96,0)
MELG(IBIFN,IBMRADUP) ; function to check all EOBs for a claim and determine if they are
"RTN","IBCAPP2",97,0)
 ; eligible for inclusion on the COB management worklist, uses both B & C x-ref
"RTN","IBCAPP2",98,0)
 ; IBIFN - claim ien (required)
"RTN","IBCAPP2",99,0)
 ; IBMRADUP - indicates user said NO to "include denied for duplicate" prompt
"RTN","IBCAPP2",100,0)
 ;
"RTN","IBCAPP2",101,0)
 ; Returns EOB ien to use for display, if at least 1 EOB passed all checks
"RTN","IBCAPP2",102,0)
 ; if multiple EOBs passed but some have filing errors, returns the 1st EOB found that does NOT have filing errors
"RTN","IBCAPP2",103,0)
 ; if all EOBs have filing errors, tries to find one that is a PROCESSED status and return that one for CBW display
"RTN","IBCAPP2",104,0)
 ; Returns -1 if claim should appear on the worklist with no EOB
"RTN","IBCAPP2",105,0)
 ; Returns 0 if no EOBs passed the checks and claim should not appear on the worklist, also removes it
"RTN","IBCAPP2",106,0)
 ;
"RTN","IBCAPP2",107,0)
 ; IBCK = Total number of EOBs found for this claim ien
"RTN","IBCAPP2",108,0)
 ; IBECT = Total number of EOBs that failed the EOB TYPE check
"RTN","IBCAPP2",109,0)
 ; IBCT = Total number of EOBs for a claim that passed ALL the checks
"RTN","IBCAPP2",110,0)
 ;
"RTN","IBCAPP2",111,0)
 N IBDA,IBCT,IBEOBNDX,IBEOB,IB3611,IBCK,IBETC
"RTN","IBCAPP2",112,0)
 S IBCT=0,IBCK=0,IBETC=0
"RTN","IBCAPP2",113,0)
 F IBEOBNDX="B","C" D
"RTN","IBCAPP2",114,0)
 .S IBDA=0 F  S IBDA=$O(^IBM(361.1,IBEOBNDX,IBIFN,IBDA)) Q:'+IBDA  D
"RTN","IBCAPP2",115,0)
 ..Q:$D(IBEOB(IBDA))
"RTN","IBCAPP2",116,0)
 ..S IB3611=$G(^IBM(361.1,IBDA,0)),IBCK=IBCK+1
"RTN","IBCAPP2",117,0)
 ..Q:$D(^IBM(361.1,IBDA,"ERR"))
"RTN","IBCAPP2",118,0)
 ..; if this is a denied EOB and user does NOT want to include denied as duplicates and this EOB was denied as duplicate, don't include
"RTN","IBCAPP2",119,0)
 ..I $P(IB3611,U,13)=2,'$G(IBMRADUP),$$DENDUP^IBCEMU4(IBDA,1) Q
"RTN","IBCAPP2",120,0)
 ..; eob type must be correct for this worklist
"RTN","IBCAPP2",121,0)
 ..I $P(IB3611,U,4)=1 S IBETC=IBETC+1 Q
"RTN","IBCAPP2",122,0)
 ..; allow filing errors on worklist, but try to find at least 1 Processed EOB w/out errors
"RTN","IBCAPP2",123,0)
 ..I $D(^IBM(361.1,IBDA,"ERR")) S:$P($G(^IBM(361.1,IBDA,0)),U,13)'=1 IBEOB("DER",IBDA)="" S:$P($G(^IBM(361.1,IBDA,0)),U,13)=1 IBEOB("PER",IBDA)="" Q
"RTN","IBCAPP2",124,0)
 ..S IBEOB(IBDA)="",IBCT=IBCT+1
"RTN","IBCAPP2",125,0)
 ; if no EOB was found to check, return -1 to process as no EOB
"RTN","IBCAPP2",126,0)
 Q:IBCK=0 -1
"RTN","IBCAPP2",127,0)
 ; if no EOB passed, check to see if the EOBs were all MRA primaries that failed the EOB type check (2ndary/tertiaries were paper)
"RTN","IBCAPP2",128,0)
 I IBCT=0,$$WNRBILL^IBEFUNC(IBIFN,1),$$COBN^IBCEF(IBIFN)>1,(IBCK=IBETC) Q -1
"RTN","IBCAPP2",129,0)
 ; if no EOB's passed, check for filing errors and use that EOB, with Processed EOB's taking priority over denied
"RTN","IBCAPP2",130,0)
 I IBCT=0,$D(IBEOB("PER")) Q $O(IBEOB("PER",0))
"RTN","IBCAPP2",131,0)
 I IBCT=0,$D(IBEOB("DER")) Q $O(IBEOB("DER",0))
"RTN","IBCAPP2",132,0)
 ; if no EOB passed and not MRA primary w/subsequent paper EOB's or filing errors, do not put on CBW
"RTN","IBCAPP2",133,0)
 Q:IBCT=0 0
"RTN","IBCAPP2",134,0)
 ; if one or more EOBs passed, return the 1st one that passed the checks as the one to use for CBW display
"RTN","IBCAPP2",135,0)
 Q $O(IBEOB(0))
"RTN","IBCAPP2",136,0)
 ;
"RTN","IBCAPP2",137,0)
RMV(DA) ;remove from worklist claims that are erroneously there
"RTN","IBCAPP2",138,0)
 N DIE,DR
"RTN","IBCAPP2",139,0)
 S DIE="^DGCR(399,",DR="35////@" D ^DIE ; Should never have been on the WORKLIST
"RTN","IBCAPP2",140,0)
 Q
"RTN","IBCAPP2",141,0)
 ;
"RTN","IBCB2")
0^38^B52688677
"RTN","IBCB2",1,0)
IBCB2 ;ALB/AAS - Process bill after enter/edited ;13-DEC-89
"RTN","IBCB2",2,0)
 ;;2.0;INTEGRATED BILLING;**52,51,161,182,155,447**;21-MAR-94;Build 80
"RTN","IBCB2",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IBCB2",4,0)
 ;
"RTN","IBCB2",5,0)
 ;MAP TO DGCRB2
"RTN","IBCB2",6,0)
 ;
"RTN","IBCB2",7,0)
 ;IBQUIT = Flag to stop processing
"RTN","IBCB2",8,0)
 ;IBVIEW = Flag showing Bill has been viewed
"RTN","IBCB2",9,0)
 ;IBDISP = Flag showing Bill entering display has been viewed.
"RTN","IBCB2",10,0)
 ;IBNOFIX = Flag to indicate do not ask to edit or review bill screens
"RTN","IBCB2",11,0)
 ;IBREEDIT = Flag to indicate Bill has been re-edited
"RTN","IBCB2",12,0)
 ;
"RTN","IBCB2",13,0)
VIEW ;View screens; if status allows editing , allow editing
"RTN","IBCB2",14,0)
 N Y,DIR
"RTN","IBCB2",15,0)
 S IBPOPOUT=0
"RTN","IBCB2",16,0)
 S IBVIEW=1,IBV=$S($D(IBV):IBV,1:1)
"RTN","IBCB2",17,0)
 S DIR(0)="YA",DIR("B")="NO",DIR("A")="WANT TO "_$S('IBV:"EDIT",1:"REVIEW")_" SCREENS? ",DIR("?",1)="   YES - to "_$S('IBV:"EDIT",1:"REVIEW")_" the screens",DIR("?")="   NO - To take no action"
"RTN","IBCB2",18,0)
 D ^DIR K DIR
"RTN","IBCB2",19,0)
 S:$D(DTOUT) IBQUIT=1
"RTN","IBCB2",20,0)
 Q:Y'=1
"RTN","IBCB2",21,0)
 I $G(IBREEDIT)=1,'IBV S IBREEDIT=2   ; set flag indicating re-edit
"RTN","IBCB2",22,0)
VIEW1 S IBVIEW=1,IBEDIT=0
"RTN","IBCB2",23,0)
 D SCREENS
"RTN","IBCB2",24,0)
 S:$G(IBPOPOUT) IBQUIT=1
"RTN","IBCB2",25,0)
 Q
"RTN","IBCB2",26,0)
 ;
"RTN","IBCB2",27,0)
DISP S IB("S")=$S($D(^DGCR(399,IBIFN,"S")):^("S"),1:"")
"RTN","IBCB2",28,0)
 W ! D DISP^IBCNQ W !
"RTN","IBCB2",29,0)
 S IBDISP=1 Q
"RTN","IBCB2",30,0)
 Q
"RTN","IBCB2",31,0)
 ;
"RTN","IBCB2",32,0)
EDITS ; Perform edits on bill prior to authorization/transmission
"RTN","IBCB2",33,0)
 N IBREEDIT
"RTN","IBCB2",34,0)
ED1 ;
"RTN","IBCB2",35,0)
 S IBQUIT=0
"RTN","IBCB2",36,0)
 I '$D(IBER)!('$D(PRCASV)) D ALLED(.IBQUIT)
"RTN","IBCB2",37,0)
 ;
"RTN","IBCB2",38,0)
 ; If the user is wanting to quit, but there are some unresolved
"RTN","IBCB2",39,0)
 ; errors reported by ClaimsManager, then capture the user's Exit
"RTN","IBCB2",40,0)
 ; comments.
"RTN","IBCB2",41,0)
 ;
"RTN","IBCB2",42,0)
 I $$CM^IBCIUT1(IBIFN),IBQUIT,$P($G(^IBA(351.9,IBIFN,0)),U,2)=4 D COMMENT^IBCIUT7(IBIFN,1)
"RTN","IBCB2",43,0)
 ;
"RTN","IBCB2",44,0)
 Q:IBQUIT
"RTN","IBCB2",45,0)
 D:'$D(IBDISP) DISP
"RTN","IBCB2",46,0)
 ;
"RTN","IBCB2",47,0)
 ; If claim re-edit, then call the IB edit checks again
"RTN","IBCB2",48,0)
 I '$D(IBVIEW) S IBREEDIT=1 D VIEW I $G(IBREEDIT)=2 K IBER,IBDISP,IBVIEW G ED1
"RTN","IBCB2",49,0)
 Q
"RTN","IBCB2",50,0)
 ;
"RTN","IBCB2",51,0)
ALLED(IBQUIT) ; Billing edit/correction
"RTN","IBCB2",52,0)
 N IBQUIT1,IBDONE1,IBDONE,IBEDIT,IBCORR,IBER,IBPRT,IBXERR
"RTN","IBCB2",53,0)
 S (IBQUIT,IBDONE,IBCORR)=0,IBER=""
"RTN","IBCB2",54,0)
 ; IBDONE = 1 ==> exit, no errors 
"RTN","IBCB2",55,0)
 ; IBQUIT = 1 ==> exit, errors not corrected
"RTN","IBCB2",56,0)
 I $$FT^IBCEF(IBIFN)=2,'$G(IBNOFIX) D DISP24(IBIFN,.IBCORR,.IBQUIT)
"RTN","IBCB2",57,0)
 ;
"RTN","IBCB2",58,0)
 F  D  Q:IBQUIT!IBDONE  D VIEW1 I $$FT^IBCEF(IBIFN)=2,'$G(IBNOFIX),'IBQUIT S IBCORR=0 D DISP24(IBIFN,.IBCORR,.IBQUIT)
"RTN","IBCB2",59,0)
 . I $G(IBPOPOUT) S IBQUIT=1
"RTN","IBCB2",60,0)
 . Q:IBQUIT!IBCORR
"RTN","IBCB2",61,0)
 . I $G(IBNOFIX) D
"RTN","IBCB2",62,0)
 .. W !!,"... Checking claim validity"
"RTN","IBCB2",63,0)
 . E  D
"RTN","IBCB2",64,0)
 .. W !!,"... Executing national IB edits"
"RTN","IBCB2",65,0)
 . D EN^IBCBB,LOCERR
"RTN","IBCB2",66,0)
 . ;
"RTN","IBCB2",67,0)
 . I $G(IBER)'=""!$D(IBXERR) D  Q:'IBDONE
"RTN","IBCB2",68,0)
 .. D DSPLERR ; Displays warnings/errors
"RTN","IBCB2",69,0)
 .. K IBXERR
"RTN","IBCB2",70,0)
 .. Q:IBQUIT!(IBDONE)
"RTN","IBCB2",71,0)
 .. I $G(IBNOFIX) S IBDONE=1 Q
"RTN","IBCB2",72,0)
 .. I '$$ASKEDIT($G(IBAC)) W ! S IBQUIT=1 ; Don't want to re-edit
"RTN","IBCB2",73,0)
 .. ;
"RTN","IBCB2",74,0)
 . I $G(IBNOFIX) S IBDONE=1 Q
"RTN","IBCB2",75,0)
 . S IBEDIT=0
"RTN","IBCB2",76,0)
 . I $S($P($G(^DGCR(399,IBIFN,0)),U,13)>2:1,$D(PRCASV):'$D(PRCASV("OKAY")),1:0) D  S:'IBQUIT&'IBEDIT IBDONE=1 Q
"RTN","IBCB2",77,0)
 .. N IBQUIT1
"RTN","IBCB2",78,0)
 .. S IBQUIT1=0
"RTN","IBCB2",79,0)
 .. W !!!,"... Executing A/R edits"
"RTN","IBCB2",80,0)
 .. I $P($G(^DGCR(399,IBIFN,0)),U,13)>2 D GVAR^IBCBB,ARRAY^IBCBB1
"RTN","IBCB2",81,0)
 .. D ARCHK($G(IBNOFIX),0,.IBQUIT1,.IBQUIT,.IBEDIT,.PRCASV)
"RTN","IBCB2",82,0)
 . S IBDONE=1 ; No errors
"RTN","IBCB2",83,0)
 . S:$G(IBPRT("PRT"))'<0 IBQUIT=0
"RTN","IBCB2",84,0)
 Q
"RTN","IBCB2",85,0)
 ;
"RTN","IBCB2",86,0)
ARCHK(IBNOFIX,IBNOPRT,IBQUIT1,IBQUIT,IBEDIT,PRCASV) ; A/R Verification
"RTN","IBCB2",87,0)
 ; Returns IBEDIT, IBQUIT1, IBQUIT,PRCASV array if passed by reference
"RTN","IBCB2",88,0)
 ; IBNOFIX = 1 if no editing needed
"RTN","IBCB2",89,0)
 ; IBNOPRT = 1 if no printing needed
"RTN","IBCB2",90,0)
 F  D ^PRCASVC6 D  Q:IBQUIT1!IBEDIT  D GVAR^IBCBB,ARRAY^IBCBB1
"RTN","IBCB2",91,0)
 . I '$G(IBNOPRT) Q:$G(IBPRT("PRT"))<0
"RTN","IBCB2",92,0)
 . I PRCASV("OKAY") W:'$G(IBNOPRT) !!,"No A/R errors found" S IBQUIT1=1 Q
"RTN","IBCB2",93,0)
 . I 'PRCASV("OKAY") D  Q
"RTN","IBCB2",94,0)
 .. D DSPARERR($G(IBNOPRT)) ; Display A/R errors
"RTN","IBCB2",95,0)
 .. Q:IBQUIT
"RTN","IBCB2",96,0)
 .. I $G(IBNOFIX) S IBQUIT1=1 Q
"RTN","IBCB2",97,0)
 .. I '$$ASKEDIT($G(IBAC)) W !,"There is an unresolved A/R error - cannot authorize bill" D PAUSE^VALM1 S (IBQUIT,IBQUIT1)=1 Q
"RTN","IBCB2",98,0)
 .. S IBEDIT=1
"RTN","IBCB2",99,0)
 ;
"RTN","IBCB2",100,0)
 Q
"RTN","IBCB2",101,0)
 ;
"RTN","IBCB2",102,0)
DSPLERR ; Display national/local edits failed
"RTN","IBCB2",103,0)
 N Z
"RTN","IBCB2",104,0)
 D PRTH(.IBPRT)
"RTN","IBCB2",105,0)
 I IBPRT("PRT")<0 S IBQUIT=1 Q
"RTN","IBCB2",106,0)
 S Z=0 F  S Z=$O(^TMP($J,"BILL-WARN",Z)) Q:'Z  W !,^(Z) W:'$O(^(Z)) !
"RTN","IBCB2",107,0)
 S Y2=""
"RTN","IBCB2",108,0)
 I IBER'="WARN" F I=1:1 S X=$P(IBER,";",I) Q:X=""  W:I=1 !?5,"**Errors**:" I $D(^IBE(350.8,+$O(^IBE(350.8,"AC",X,0)),0)) S Y=^(0),Y1=$P(Y,"^",5),Y2=Y2_Y1 I Y1<5 W !?5,$E($P(Y,"^",2),1,80)
"RTN","IBCB2",109,0)
 ; IBXERR = local edits return error array
"RTN","IBCB2",110,0)
 ; If IBXERR returns = 1 then we have at least one error
"RTN","IBCB2",111,0)
 ;                   = "" or 0, then we have only local warnings
"RTN","IBCB2",112,0)
 ;           undefined = no local errors or warnings
"RTN","IBCB2",113,0)
 I $D(IBXERR) D
"RTN","IBCB2",114,0)
 . S I="" W !!,?3,"Local Edits:"
"RTN","IBCB2",115,0)
 . S:$G(IBXERR) Y2=3,IBER="L"
"RTN","IBCB2",116,0)
 . F  S I=$O(IBXERR(I)) Q:I=""  W !,?5,$E(IBXERR(I),1,75)
"RTN","IBCB2",117,0)
 I $G(IBPRT("PRT")) D CLOSE(.IBPRT)
"RTN","IBCB2",118,0)
 G:$G(IBNOFIX) Q
"RTN","IBCB2",119,0)
 I $G(IBER)="WARN"!($G(IBXERR)=0) D  ;Warnings only - make biller stop and look
"RTN","IBCB2",120,0)
 . W !
"RTN","IBCB2",121,0)
 . N DIR,X,Y
"RTN","IBCB2",122,0)
 . S DIR(0)="YA",DIR("B")="NO",DIR("A",1)="THIS BILL STILL HAS ONE OR MORE WARNINGS - PLEASE REVIEW THEM CAREFULLY",DIR("A")="ARE YOU SURE IT'S OK TO CONTINUE? "
"RTN","IBCB2",123,0)
 . D ^DIR K DIR
"RTN","IBCB2",124,0)
 . I Y'=1 S Y2=3 Q
"RTN","IBCB2",125,0)
 . S IBER="",IBDONE=1 K IBXERR
"RTN","IBCB2",126,0)
 I $S(Y2'["3"&'$G(IBXERR):0,1:1) K IBXERR
"RTN","IBCB2",127,0)
Q K ^TMP($J,"BILL-WARN")
"RTN","IBCB2",128,0)
 Q
"RTN","IBCB2",129,0)
 ;
"RTN","IBCB2",130,0)
DSPARERR(IBNOPRT) ; Displays A/R errors
"RTN","IBCB2",131,0)
 N I,J,Y,X,ERRPRT
"RTN","IBCB2",132,0)
 I '$G(IBNOPRT) D PRTH(.IBPRT) I IBPRT("PRT")<0 S IBQUIT=1 Q
"RTN","IBCB2",133,0)
 I $P($G(PRCAERR),U,2)'="" D
"RTN","IBCB2",134,0)
 . N Z
"RTN","IBCB2",135,0)
 . S Z=+$O(^IBE(350.8,"C",$P(PRCAERR,U,2),0)),Z=$P($G(^IBE(350.8,+Z,0)),U,2)
"RTN","IBCB2",136,0)
 . W !,?5,"An A/R error has been reported - bill cannot be authorized",!!,?5,$P(PRCAERR,U,2)," - ",$S(Z'="":Z,1:"??")
"RTN","IBCB2",137,0)
 E  D
"RTN","IBCB2",138,0)
 . W !,?5,"An undetermined A/R error was found - "_$G(PRCAERR)
"RTN","IBCB2",139,0)
 I $G(IBPRT("PRT")) D CLOSE(.IBPRT)
"RTN","IBCB2",140,0)
 Q
"RTN","IBCB2",141,0)
 ;
"RTN","IBCB2",142,0)
NOPTF S IBAC1=1 I $D(^DGCR(399,IBIFN,0)),$P(^(0),"^",8),'$D(^DGPT($P(^(0),"^",8),0)) S IBAC1=0
"RTN","IBCB2",143,0)
 Q
"RTN","IBCB2",144,0)
 ;
"RTN","IBCB2",145,0)
NOPTF1 W !!,*7,"PTF Record for this Bill was DELETED!",!,"Further processing not allowed.  Cancel and re-enter." Q
"RTN","IBCB2",146,0)
 ;
"RTN","IBCB2",147,0)
LOCERR ; Check for local edits
"RTN","IBCB2",148,0)
 ; Execute screen post-processor for bills with local scrn 9 affiliations
"RTN","IBCB2",149,0)
 N IBZ,IBXIEN,IBPRT
"RTN","IBCB2",150,0)
 K IBXERR
"RTN","IBCB2",151,0)
 S IBZ=$$LOCSCRN^IBCSC11(IBIFN)     ; IB*2.0*447 BI
"RTN","IBCB2",152,0)
 I IBZ S IBXIEN=IBIFN W !!,"... Executing local IB edits" D FPOST^IBCEFG7(IBZ,0,.IBXERR) I '$D(IBXERR) W !!,"No errors found for local edits"
"RTN","IBCB2",153,0)
 Q
"RTN","IBCB2",154,0)
 ;
"RTN","IBCB2",155,0)
PRTH(IBPRT,IBA) ; Print a heading for error/warnings sent to a printer
"RTN","IBCB2",156,0)
 ; Returns IBPRT = 1 if valid pritner selected
"RTN","IBCB2",157,0)
 ;         IBPRT = -1 if '^' entered
"RTN","IBCB2",158,0)
 ;         IBPRT = 0 if home device
"RTN","IBCB2",159,0)
 N POP,%ZIS,POP
"RTN","IBCB2",160,0)
 S %ZIS("A")="ERROR/WARNING OUTPUT DEVICE: "
"RTN","IBCB2",161,0)
 D ^%ZIS
"RTN","IBCB2",162,0)
 I POP S IBPRT("PRT")=-1 Q
"RTN","IBCB2",163,0)
 I IO=IO(0) S IBPRT("PRT")=0 Q
"RTN","IBCB2",164,0)
 S IBPRT("PRT")=1
"RTN","IBCB2",165,0)
 U IO
"RTN","IBCB2",166,0)
 W !,"INCONSISTENCIES LIST FOR BILL #: ",$P($G(^DGCR(399,IBIFN,0)),U),!,$J("",29),"AT: ",$$FMTE^XLFDT($$NOW^XLFDT,2),!,$J("",19),"GENERATED BY: ",$P($G(^VA(200,DUZ,0)),U),!!
"RTN","IBCB2",167,0)
 Q
"RTN","IBCB2",168,0)
 ;
"RTN","IBCB2",169,0)
CLOSE(IBPRT) ; Close device, reset printer flag
"RTN","IBCB2",170,0)
 D ^%ZISC
"RTN","IBCB2",171,0)
 S IBPRT("PRT")=0
"RTN","IBCB2",172,0)
 D HOME^%ZIS
"RTN","IBCB2",173,0)
 Q
"RTN","IBCB2",174,0)
 ;
"RTN","IBCB2",175,0)
ASKEDIT(IBAC) ; Ask if edit/review of bill is desired
"RTN","IBCB2",176,0)
 ; FUNCTION returns 0/1 for NO/YES
"RTN","IBCB2",177,0)
 ; IBAC = flag for function being performed - to determine edit/review
"RTN","IBCB2",178,0)
 N DIR,X,Y
"RTN","IBCB2",179,0)
 S DIR(0)="YA"
"RTN","IBCB2",180,0)
 S DIR("A",1)=" ",DIR("A",2)=" ",DIR("A")="Do you wish to "_$S($G(IBAC)<4:"edit",1:"review")_" the inconsistencies now? ",DIR("B")="NO"
"RTN","IBCB2",181,0)
 S DIR("?",1)=" ",DIR("?",2)=" ",DIR("?",3)="   YES - To edit inconsistent fields",DIR("?")="   NO - To discontinue this process."
"RTN","IBCB2",182,0)
 D ^DIR K DIR
"RTN","IBCB2",183,0)
 Q (Y=1)
"RTN","IBCB2",184,0)
 ;
"RTN","IBCB2",185,0)
SCREENS ;
"RTN","IBCB2",186,0)
 N IBH
"RTN","IBCB2",187,0)
 D ^IBCSCU,^IBCSC1
"RTN","IBCB2",188,0)
 I $G(IBV) K IBPOPOUT
"RTN","IBCB2",189,0)
 Q
"RTN","IBCB2",190,0)
 ;
"RTN","IBCB2",191,0)
DISP24(IBIFN,IBCORR,IBQUIT) ;
"RTN","IBCB2",192,0)
 W @IOF D BL24^IBCSCH(IBIFN,0)
"RTN","IBCB2",193,0)
 S DIR("A",1)=" ",DIR("A")="Are the above charges correct for this bill? ",DIR("B")="YES",DIR(0)="YA" D ^DIR K DIR
"RTN","IBCB2",194,0)
 I Y'=1 D
"RTN","IBCB2",195,0)
 . I Y=0,$$ASKEDIT($G(IBAC)) S IBCORR=1 Q
"RTN","IBCB2",196,0)
 . S IBQUIT=1
"RTN","IBCB2",197,0)
 Q
"RTN","IBCB2",198,0)
 ;
"RTN","IBCB2",199,0)
IICM(IBIFN) ; Ingenix ClaimsManager: Claim Scrubber
"RTN","IBCB2",200,0)
 ; Send the bill to ClaimsManager, the IBCISTAT variable returned from ClaimsManager indicates
"RTN","IBCB2",201,0)
 ;         3 - Passed CM with no errors
"RTN","IBCB2",202,0)
 ;         5 - User overriding the CM errors
"RTN","IBCB2",203,0)
 ;         7 - the CM interface isn't working
"RTN","IBCB2",204,0)
 ;        11 - User overriding the CM errors (CM not updated)
"RTN","IBCB2",205,0)
 ; 
"RTN","IBCB2",206,0)
 ; Returns False (0) if the bill fails the ClaimsManager Scrubber/errors found
"RTN","IBCB2",207,0)
 ; Returns True (1) if the bill passed the ClaimsManager Scrubber/no errors found or ClaimsManager not On at site
"RTN","IBCB2",208,0)
 ;
"RTN","IBCB2",209,0)
 N IBOK S IBOK=1
"RTN","IBCB2",210,0)
 I +$G(IBIFN),$$CM^IBCIUT1(IBIFN) S IBCISNT=1 D ST2^IBCIST I '$F(".3.5.7.11.","."_IBCISTAT_".") S IBOK=0
"RTN","IBCB2",211,0)
 Q IBOK
"RTN","IBCB2",212,0)
 ;
"RTN","IBCB2",213,0)
IIQMED(IBIFN) ; DSS QuadraMed Interface: QuadraMed Claim Scrubber
"RTN","IBCB2",214,0)
 ; Send the bill to the QuadraMed Claim Scrubber
"RTN","IBCB2",215,0)
 ; Returns False (0) if the bill fails the QuadraMed Scrubber/errors found
"RTN","IBCB2",216,0)
 ; Returns True (1) if the bill passed the QuadraMed Scrubber/no errors found or QuadraMed not On at site
"RTN","IBCB2",217,0)
 ;
"RTN","IBCB2",218,0)
 ; QuadraMed Scrubber EN^VEJDIBSC returns IBQMED = 1 if no error found, returns 0 if error found
"RTN","IBCB2",219,0)
 ;
"RTN","IBCB2",220,0)
 N IBQMED S IBQMED=1
"RTN","IBCB2",221,0)
 I +$G(IBIFN),$$QMED^IBCU1("EN^VEJDIBSC",IBIFN) D EN^VEJDIBSC(IBIFN)
"RTN","IBCB2",222,0)
 Q IBQMED
"RTN","IBCBB1")
0^29^B98716914
"RTN","IBCBB1",1,0)
IBCBB1 ;ALB/AAS - CONTINUATION OF EDIT CHECK ROUTINE ;2-NOV-89
"RTN","IBCBB1",2,0)
 ;;2.0;INTEGRATED BILLING;**27,52,80,93,106,51,151,148,153,137,232,280,155,320,343,349,363,371,395,384,432,447**;21-MAR-94;Build 80
"RTN","IBCBB1",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCBB1",4,0)
 ;
"RTN","IBCBB1",5,0)
 ;MAP TO DGCRBB1
"RTN","IBCBB1",6,0)
 ;
"RTN","IBCBB1",7,0)
% ;Bill Status
"RTN","IBCBB1",8,0)
 N Z,Z0,Z1,IBFT
"RTN","IBCBB1",9,0)
 I $S(+IBST=0:1,1:"^1^2^3^4^7^"'[(U_IBST_U)) S IBER=IBER_"IB045;"
"RTN","IBCBB1",10,0)
 ;
"RTN","IBCBB1",11,0)
 ;Statement Covers From
"RTN","IBCBB1",12,0)
 I IBFDT="" S IBER=IBER_"IB061;"
"RTN","IBCBB1",13,0)
 I IBFDT]"",IBFDT'?7N&(IBFDT'?7N1".".N) S IBER=IBER_"IB061;"
"RTN","IBCBB1",14,0)
 I IBFDT>IBTDT S IBER=IBER_"IB061;" ; from must be on or before the to date 
"RTN","IBCBB1",15,0)
 S IBFFY=$$FY^IBOUTL(IBFDT)
"RTN","IBCBB1",16,0)
 ; if inpat - from date must not be prior to admit date.
"RTN","IBCBB1",17,0)
 I $$INPAT^IBCEF(IBIFN,1),(IBFDT<($P($G(^DGPT(+$P(IBND0,U,8),0)),U,2)\1))  S IBER=IBER_"IB061;"
"RTN","IBCBB1",18,0)
 ;
"RTN","IBCBB1",19,0)
 ;Statement Covers To
"RTN","IBCBB1",20,0)
 I IBTDT="" S IBER=IBER_"IB062;"
"RTN","IBCBB1",21,0)
 I IBTDT]"",IBTDT'?7N&(IBTDT'?7N1".".N) S IBER=IBER_"IB062;"
"RTN","IBCBB1",22,0)
 I IBTDT>DT!(IBTDT<IBFDT) S IBER=IBER_"IB062;"  ; to date must not be >than today's date
"RTN","IBCBB1",23,0)
 S IBTFY=$$FY^IBOUTL(IBTDT)
"RTN","IBCBB1",24,0)
 ;
"RTN","IBCBB1",25,0)
 ;Total Charges
"RTN","IBCBB1",26,0)
 ; IB*2.0*447/TAZ Removed this error so that zero dollar revenue codes can process on the 837
"RTN","IBCBB1",27,0)
 ;I +IBTC'>0!(+IBTC'=IBTC) S IBER=IBER_"IB064;"
"RTN","IBCBB1",28,0)
 ;
"RTN","IBCBB1",29,0)
 ;Billable charges for secondary claim
"RTN","IBCBB1",30,0)
 I $$MCRONBIL^IBEFUNC(IBIFN)&(($P(IBNDU1,U,1)-$P(IBNDU1,U,2))'>0) S IBER=IBER_"IB094;"
"RTN","IBCBB1",31,0)
 ;Fiscal Year 1
"RTN","IBCBB1",32,0)
 S IBFFY=$$FY^IBOUTL(IBFDT)
"RTN","IBCBB1",33,0)
 ;
"RTN","IBCBB1",34,0)
 ;Check provider link for current user, enterer, reviewer and Authorizor
"RTN","IBCBB1",35,0)
 I '$D(^VA(200,DUZ,0)) S IBER=IBER_"IB048;"
"RTN","IBCBB1",36,0)
 I IBEU]"",'$D(^VA(200,IBEU,0)) S IBER=IBER_"IB048;"
"RTN","IBCBB1",37,0)
 I IBRU]"",'$D(^VA(200,IBRU,0)) S IBER=IBER_"IB060;"
"RTN","IBCBB1",38,0)
 I IBAU]"",'$D(^VA(200,IBAU,0)) S IBER=IBER_"IB041;"
"RTN","IBCBB1",39,0)
 ;
"RTN","IBCBB1",40,0)
 I IBER="",+$$STA^PRCAFN(IBIFN)=104 S IBER=IBER_"IB040;"
"RTN","IBCBB1",41,0)
 ; If ins bill, must have valid COB sequence
"RTN","IBCBB1",42,0)
 I $P(IBND0,U,11)="i",$S($P(IBND0,U,21)="":1,1:"PST"'[$P(IBND0,U,21)) S IBER=IBER_"IB324;"
"RTN","IBCBB1",43,0)
 ;
"RTN","IBCBB1",44,0)
 ; Check for valid sec provider id for current ins
"RTN","IBCBB1",45,0)
 S Z=0 F  S Z=$O(^DGCR(399,IBIFN,"PRV",Z)) Q:'Z  S Z0=$G(^(Z,0)),Z1=+$$COBN^IBCEF(IBIFN) I $P(Z0,U,4+Z1)'="",$P(Z0,U,11+Z1)'="" D
"RTN","IBCBB1",46,0)
 . I '$$SECIDCK^IBCEF74(IBIFN,Z1,$P(Z0,U,11+Z1),Z) D WARN^IBCBB11("Prov secondary id type for the "_$P("PRIMARY^SECONDARY^TERTIARY",U,Z1)_" "_$$EXTERNAL^DILFD(399.0222,.01,,+Z0)_" is invalid/won't transmit")
"RTN","IBCBB1",47,0)
 ; Check NPIs
"RTN","IBCBB1",48,0)
 D NPICHK^IBCBB11
"RTN","IBCBB1",49,0)
 ;
"RTN","IBCBB1",50,0)
 ; Check multiple rx NPIs
"RTN","IBCBB1",51,0)
 D RXNPI^IBCBB11(IBIFN)
"RTN","IBCBB1",52,0)
 ;
"RTN","IBCBB1",53,0)
 ; Check taxonomies
"RTN","IBCBB1",54,0)
 D TAXCHK^IBCBB11
"RTN","IBCBB1",55,0)
 ;
"RTN","IBCBB1",56,0)
 ; Check for Physician Name
"RTN","IBCBB1",57,0)
 K IBXDATA D F^IBCEF("N-ATT/REND PHYSICIAN NAME",,,IBIFN)
"RTN","IBCBB1",58,0)
 ; IB*2.0*432 - CMS1500 no longer needs a claim level rendering
"RTN","IBCBB1",59,0)
 S IBFT=$$FT^IBCEF(IBIFN)
"RTN","IBCBB1",60,0)
 I IBFT'=2,$P($G(IBXDATA),U)="" S IBER=IBER_"IB303;"
"RTN","IBCBB1",61,0)
 ;
"RTN","IBCBB1",62,0)
 N FUNCTION,IBINS
"RTN","IBCBB1",63,0)
 ; IB*2.0*432 - CMS1500 no longer needs a claim level rendering
"RTN","IBCBB1",64,0)
 ;S FUNCTION=$S($$FT^IBCEF(IBIFN)=3:4,1:3)
"RTN","IBCBB1",65,0)
 S FUNCTION=$S(IBFT=3:4,1:3)
"RTN","IBCBB1",66,0)
 I IBFT'=2,IBER'["IB303;" D
"RTN","IBCBB1",67,0)
 . F IBINS=1:1:3 D
"RTN","IBCBB1",68,0)
 .. S Z=$$GETTYP^IBCEP2A(IBIFN,IBINS)
"RTN","IBCBB1",69,0)
 .. I Z,$P(Z,U,2) D  ; Rendering/attending prov secondary id required
"RTN","IBCBB1",70,0)
 ... N IBID,IBOK,Q0
"RTN","IBCBB1",71,0)
 ... D PROVINF^IBCEF74(IBIFN,IBINS,.IBID,1,"C")  ; check all as though they were current
"RTN","IBCBB1",72,0)
 ... S IBOK=0
"RTN","IBCBB1",73,0)
 ... S Q0=0 F  S Q0=$O(IBID(1,FUNCTION,Q0)) Q:'Q0  I $P(IBID(1,FUNCTION,Q0),U,9)=+Z S IBOK=1 Q
"RTN","IBCBB1",74,0)
 ... I 'IBOK S IBER=IBER_$S(IBINS=1:"IB236;",IBINS=2:"IB237;",IBINS=3:"IB238;",1:"")
"RTN","IBCBB1",75,0)
 ;
"RTN","IBCBB1",76,0)
 ; Patch 432 enh5:The IB system shall no longer prevent users from authorizing(fatal error message)a claim because the system cannot find the providersSSNorEIN
"RTN","IBCBB1",77,0)
 ; D PRIIDCHK^IBCBB11
"RTN","IBCBB1",78,0)
 ;
"RTN","IBCBB1",79,0)
 N IBM,IBM1
"RTN","IBCBB1",80,0)
 S IBM=$G(^DGCR(399,IBIFN,"M"))
"RTN","IBCBB1",81,0)
 S IBM1=$G(^DGCR(399,IBIFN,"M1"))
"RTN","IBCBB1",82,0)
 I $P(IBM,U),$P($G(^DIC(36,$P(IBM,U),4)),U,6),$P(IBM1,U,2)="" S IBER=IBER_"IB244;"
"RTN","IBCBB1",83,0)
 I $P(IBM,U,2),$P($G(^DIC(36,$P(IBM,U,2),4)),U,6),$P(IBM1,U,3)="" S IBER=IBER_"IB245;"
"RTN","IBCBB1",84,0)
 I $P(IBM,U,3),$P($G(^DIC(36,$P(IBM,U,3),4)),U,6),$P(IBM1,U,4)="" S IBER=IBER_"IB246;"
"RTN","IBCBB1",85,0)
 ;
"RTN","IBCBB1",86,0)
 ; If outside facility, check for ID and qualifier in 355.93
"RTN","IBCBB1",87,0)
 ; 5/15/06 - esg - hard error IB243 turned into warning message instead
"RTN","IBCBB1",88,0)
 S Z=$P($G(^DGCR(399,IBIFN,"U2")),U,10)
"RTN","IBCBB1",89,0)
 I Z D
"RTN","IBCBB1",90,0)
 . I $P($G(^IBA(355.93,Z,0)),U,9)=""!($P($G(^IBA(355.93,Z,0)),U,13)="") D
"RTN","IBCBB1",91,0)
 .. N Z1,Z2
"RTN","IBCBB1",92,0)
 .. S Z1="Missing Lab or Facility Primary ID for non-VA facility, "
"RTN","IBCBB1",93,0)
 .. S Z2=$$EXTERNAL^DILFD(399,232,,Z)
"RTN","IBCBB1",94,0)
 .. I $L(Z2)'>19 D WARN^IBCBB11(Z1_Z2) Q
"RTN","IBCBB1",95,0)
 .. D WARN^IBCBB11(Z1),WARN^IBCBB11("     "_Z2)
"RTN","IBCBB1",96,0)
 .. Q
"RTN","IBCBB1",97,0)
 . Q
"RTN","IBCBB1",98,0)
 ;
"RTN","IBCBB1",99,0)
 ; Must be one and only one division on bill
"RTN","IBCBB1",100,0)
 S IBZ=$$MULTDIV^IBCBB11(IBIFN,IBND0)
"RTN","IBCBB1",101,0)
 ; I IBZ S IBER=IBER_$S(IBZ=1:"IB095;",IBZ=2:"IB104;",1:"IB105;")
"RTN","IBCBB1",102,0)
 ; Allow multi-divisional for OP instutional claims
"RTN","IBCBB1",103,0)
 I IBZ,$$INPAT^IBCEF(IBIFN)!'($$INSPRF^IBCEF(IBIFN)) S IBER=IBER_$S(IBZ=1:"IB095;",IBZ=2:"IB104;",1:"IB105;")
"RTN","IBCBB1",104,0)
 ; Still need error msg on OP Institutional if No Default division
"RTN","IBCBB1",105,0)
 I IBZ=3,'$$INPAT^IBCEF(IBIFN),$$INSPRF^IBCEF(IBIFN) S IBER=IBER_"IB105;"
"RTN","IBCBB1",106,0)
 ; Division address must be defined in institution file
"RTN","IBCBB1",107,0)
 I $P(IBND0,U,22) D
"RTN","IBCBB1",108,0)
 . N Z,Z0,Z1
"RTN","IBCBB1",109,0)
 . S Z0=$G(^DIC(4,+$P($G(^DG(40.8,+$P(IBND0,U,22),0)),U,7),0))
"RTN","IBCBB1",110,0)
 . S Z1=$G(^DIC(4,+$P($G(^DG(40.8,+$P(IBND0,U,22),0)),U,7),1))
"RTN","IBCBB1",111,0)
 . I $P(Z0,U,2)="" S IBER=IBER_"IB097;" Q
"RTN","IBCBB1",112,0)
 . F Z=1,3,4 I $P(Z1,U,Z)="" S IBER=IBER_"IB097;" Q
"RTN","IBCBB1",113,0)
 ;
"RTN","IBCBB1",114,0)
 ; IB*2.0*432 Check ambulance addresses, COB Non-covered amt. & Attachment Control
"RTN","IBCBB1",115,0)
 I $$AMBCK^IBCBB11(IBIFN)=1 S IBER=IBER_"IB329;"
"RTN","IBCBB1",116,0)
 I $$COBAMT^IBCBB11(IBIFN)=1 S IBER=IBER_"IB330;"
"RTN","IBCBB1",117,0)
 I $$TMCK^IBCBB11(IBIFN)=1 S IBER=IBER_"IB331;"
"RTN","IBCBB1",118,0)
 I $$ACCK^IBCBB11(IBIFN)=1 S IBER=IBER_"IB332;"
"RTN","IBCBB1",119,0)
 I $$COBMRA^IBCBB11(IBIFN)=1 S IBER=IBER_"IB342;"
"RTN","IBCBB1",120,0)
 I $$COBSEC^IBCBB11(IBIFN)=1 S IBER=IBER_"IB343;"
"RTN","IBCBB1",121,0)
 ;
"RTN","IBCBB1",122,0)
 ;CHAMPVA Rate Type and Primary Insurance Carriers Type of Coverage must match
"RTN","IBCBB1",123,0)
 S (IBRTCHV,IBPICHV)=0
"RTN","IBCBB1",124,0)
 I $P($G(^DGCR(399.3,+IBAT,0)),U,1)="CHAMPVA" S IBRTCHV=1
"RTN","IBCBB1",125,0)
 I $P($G(^IBE(355.2,+$P($G(^DIC(36,+IBNDMP,0)),U,13),0)),U,1)="CHAMPVA" S IBPICHV=1
"RTN","IBCBB1",126,0)
 I (+IBRTCHV!+IBPICHV)&('IBRTCHV!'IBPICHV) S IBER=IBER_"IB085;"
"RTN","IBCBB1",127,0)
 ;
"RTN","IBCBB1",128,0)
 N IBZPRC,IBZPRCUB
"RTN","IBCBB1",129,0)
 D F^IBCEF("N-ALL PROCEDURES","IBZPRC",,IBIFN)
"RTN","IBCBB1",130,0)
 ; Procedure Clinic is required for Surgical Procedures Outpt Facility Charges
"RTN","IBCBB1",131,0)
 I +$P(IBND0,U,27)'=2,$$BILLRATE^IBCRU3(IBAT,IBCL,IBEVDT,"RC OUTPATIENT") D
"RTN","IBCBB1",132,0)
 . N Z,Z0,Z1,ZE S (ZE,Z)=0 F  S Z=$O(^DGCR(399,IBIFN,"CP",Z)) Q:'Z  D  I +ZE S IBER=IBER_"IB320;" Q
"RTN","IBCBB1",133,0)
 .. S Z0=$G(^DGCR(399,IBIFN,"CP",Z,0)),Z1=+Z0 I Z0'[";ICPT(" Q
"RTN","IBCBB1",134,0)
 .. I '((Z1'<10000)&(Z1'>69999))&'((Z1'<93501)&(Z1'>93533)) Q
"RTN","IBCBB1",135,0)
 .. I '$P(Z0,U,7) S ZE=1
"RTN","IBCBB1",136,0)
 ;
"RTN","IBCBB1",137,0)
 ; Extract procedures for UB-04
"RTN","IBCBB1",138,0)
 D F^IBCEF("N-UB-04 PROCEDURES","IBZPRCUB",,IBIFN)
"RTN","IBCBB1",139,0)
 ; Does this bill have ANY prescriptions associated with it?
"RTN","IBCBB1",140,0)
 ; Must bill prescriptions separately from other charges
"RTN","IBCBB1",141,0)
 ;
"RTN","IBCBB1",142,0)
 ; DEM;432 - Call line level provider edit checks.
"RTN","IBCBB1",143,0)
 D LNPROV^IBCBB12(IBIFN)  ; DEM;432 - If there are line provider edits, then routine LNPROV^IBCBB12(IBIFN) updates IBER string.
"RTN","IBCBB1",144,0)
 ; DEM;432 - Call to Other Operating/Operating Provider edit checks.
"RTN","IBCBB1",145,0)
 I $$OPPROVCK^IBCBB12(IBIFN)=1 S IBER=IBER_"IB337;"  ; DEM;432
"RTN","IBCBB1",146,0)
 ; DEM;432 - Line level Attachment Control edits.
"RTN","IBCBB1",147,0)
 I $$LNTMCK^IBCBB11(IBIFN)=1 S IBER=IBER_"IB331;"  ; DEM;432
"RTN","IBCBB1",148,0)
 I $$LNACCK^IBCBB11(IBIFN)=1 S IBER=IBER_"IB332;"  ; DEM;432
"RTN","IBCBB1",149,0)
 ;
"RTN","IBCBB1",150,0)
 I $$ISRX^IBCEF1(IBIFN) D
"RTN","IBCBB1",151,0)
 . N IBZ,IBRXDEF
"RTN","IBCBB1",152,0)
 . S IBRXDEF=$P($G(^IBE(350.9,1,1)),U,30),IBZ=0
"RTN","IBCBB1",153,0)
 . F  S IBZ=$O(IBZPRCUB(IBZ)) Q:'IBZ  I IBZPRCUB(IBZ),+$P(IBZPRCUB(IBZ),U)'=IBRXDEF S IBER=IBER_"IB102;" Q
"RTN","IBCBB1",154,0)
 . K IBZ
"RTN","IBCBB1",155,0)
 ;
"RTN","IBCBB1",156,0)
 ; Check that COB sequences are not skipped
"RTN","IBCBB1",157,0)
 K Z
"RTN","IBCBB1",158,0)
 F Z=1:1:3 S:+$G(^DGCR(399,IBIFN,"I"_Z)) Z(Z)=""
"RTN","IBCBB1",159,0)
 F Z=0:1:2 S Z0=$O(Z(Z)) Q:'Z0  I Z0'=(Z+1) S IBER=IBER_"IB322;" Q
"RTN","IBCBB1",160,0)
 K Z
"RTN","IBCBB1",161,0)
 ; HD64676  IB*2*371 - OK for payer sequence to be blank when the Rate
"RTN","IBCBB1",162,0)
 ;    Type is either Interagency or Sharing Agreement
"RTN","IBCBB1",163,0)
 I $P($G(^DGCR(399,IBIFN,0)),U,21)="",$P($G(^DGCR(399,IBIFN,0)),U,7)'=4,$P($G(^DGCR(399,IBIFN,0)),U,7)'=9 S IBER=IBER_"IB323;"
"RTN","IBCBB1",164,0)
 K IBXDATA D F^IBCEF("N-PROCEDURE CODING METHD",,,IBIFN)
"RTN","IBCBB1",165,0)
 ; Coding method should agree with types of procedure codes
"RTN","IBCBB1",166,0)
 S IBOK=$S('$O(IBZPRC(0))!(IBXDATA=""):1,1:0)
"RTN","IBCBB1",167,0)
 I 'IBOK S IBOK=1,IBZ=0 F  S IBZ=$O(IBZPRC(IBZ)) Q:'IBZ  I IBZPRC(IBZ),$P(IBZPRC(IBZ),U)'[$S(IBXDATA=9:"ICD",1:"ICP") S IBOK=0 Q
"RTN","IBCBB1",168,0)
 I 'IBOK D WARN^IBCBB11("Coding Method does not agree with all procedure codes found on bill")
"RTN","IBCBB1",169,0)
 D EDITMRA^IBCBB3(.IBQUIT,.IBER,IBIFN,IBFT)
"RTN","IBCBB1",170,0)
 Q:$G(IBQUIT)
"RTN","IBCBB1",171,0)
 ;
"RTN","IBCBB1",172,0)
 ;Other things that could be added:  Rev Code - calculating charges
"RTN","IBCBB1",173,0)
 ;        Diagnosis Coding, if MT copay - check for other co-payments
"RTN","IBCBB1",174,0)
 ;
"RTN","IBCBB1",175,0)
 I $P(IBNDTX,U,8),$$REQMRA^IBEFUNC(IBIFN) S IBER=IBER_"IB121;"   ; can't force MRAs to print
"RTN","IBCBB1",176,0)
 I $P(IBNDTX,U,8)!$P(IBNDTX,U,9) D WARN^IBCBB11($S($$REQMRA^IBEFUNC(IBIFN)&($P(IBNDTX,U,9)):"MRA Secondary ",1:"")_"Bill has been forced to print "_$S($P(IBNDTX,U,8)=1!($P(IBNDTX,U,9)=1):"locally",1:"at clearinghouse"))
"RTN","IBCBB1",177,0)
 N IBXZ,IBIZ F IBIZ=12,13,14 S IBXZ=$P(IBNDM,U,IBIZ) I +IBXZ S IBXZ=$P($G(^DPT(DFN,.312,IBXZ,0)),U,18) I +IBXZ S IBXZ=$G(^IBA(355.3,+IBXZ,0)) I +$P(IBXZ,U,12) D
"RTN","IBCBB1",178,0)
 . D WARN^IBCBB11($P($G(^DIC(36,+IBXZ,0)),U,1)_" requires Amb Care Certification")
"RTN","IBCBB1",179,0)
 ;
"RTN","IBCBB1",180,0)
 D VALNDC^IBCBB11(IBIFN,DFN)  ;validate NDC#
"RTN","IBCBB1",181,0)
 ;
"RTN","IBCBB1",182,0)
 ;Build AR array if no errors and MRA not needed or already rec'd
"RTN","IBCBB1",183,0)
 I IBER="",$S($$NEEDMRA^IBEFUNC(IBIFN)!($$REQMRA^IBEFUNC(IBIFN)):0,1:1) D ARRAY
"RTN","IBCBB1",184,0)
 ;
"RTN","IBCBB1",185,0)
 ;Check ROI
"RTN","IBCBB1",186,0)
 N ROIERR
"RTN","IBCBB1",187,0)
 S ROIERR=0 I $P($G(^DGCR(399,IBIFN,"U")),U,5)=1,+$P($G(^DGCR(399,IBIFN,"U")),U,7)=0 S ROIERR=1 ; screen 7 sensitive record and no ROI
"RTN","IBCBB1",188,0)
 I $$ROICHK^IBCBB11(IBIFN,DFN,+IBNDMP) S ROIERR=1 ; check file for sensitive Rx and missing ROI
"RTN","IBCBB1",189,0)
 I ROIERR S IBER=IBER_"IB328;"
"RTN","IBCBB1",190,0)
 ;
"RTN","IBCBB1",191,0)
 ;Verify Line Charges Match Claim Total Charge. IB*2.0*447 BI
"RTN","IBCBB1",192,0)
 I +$$GET1^DIQ(399,IBIFN_",",201)'=+$$IBLNTOT^IBCBB13(IBIFN) S IBER=IBER_"IB344;"
"RTN","IBCBB1",193,0)
 ;
"RTN","IBCBB1",194,0)
 ;Test for valid EIN/SY ID Values. IB*2.0*447 BI
"RTN","IBCBB1",195,0)
 I $$IBSYEI^IBCBB13(IBIFN) S IBER=IBER_"IB345;"
"RTN","IBCBB1",196,0)
 ;
"RTN","IBCBB1",197,0)
 ;Test for a missing ICN. IB*2.0*447 BI
"RTN","IBCBB1",198,0)
 I $$IBMICN^IBCBB13(IBIFN) S IBER=IBER_"IB346;"
"RTN","IBCBB1",199,0)
 ;
"RTN","IBCBB1",200,0)
 ;Test for a ZERO charge amounts. IB*2.0*447 BI
"RTN","IBCBB1",201,0)
 I $$IBRCCHK^IBCBB13(IBIFN) D WARN^IBCBB11("Claim contains revenue codes with no associated charges.")
"RTN","IBCBB1",202,0)
 ;
"RTN","IBCBB1",203,0)
 ;Test for missing "Patient reason for visit". IB*2.0*447 BI
"RTN","IBCBB1",204,0)
 I $$FT^IBCEF(IBIFN)=3,'$$INPAT^IBCEF(IBIFN),$$IBPRV3^IBCBB13(IBIFN) S IBER=IBER_"IB347;"
"RTN","IBCBB1",205,0)
 ;
"RTN","IBCBB1",206,0)
 ;Test for missing Payer ID. IB*2.0*447 BI
"RTN","IBCBB1",207,0)
 ;I $$IBMPID^IBCBB13(IBIFN) S IBER=IBER_"IB348;"
"RTN","IBCBB1",208,0)
 ;Changed Error to Warning. IB*2.0*447 TAZ
"RTN","IBCBB1",209,0)
 I $$IBMPID^IBCBB13(IBIFN) D WARN^IBCBB11("Not all payers have Payer IDs.")
"RTN","IBCBB1",210,0)
 ;
"RTN","IBCBB1",211,0)
 ;Test for missing "Priority (Type) of Admission" for UB-04. IB*2.0*447 BI
"RTN","IBCBB1",212,0)
 I $$FT^IBCEF(IBIFN)=3,$$GET1^DIQ(399,IBIFN_",",158)="" S IBER=IBER_"IB349;"
"RTN","IBCBB1",213,0)
 ;
"RTN","IBCBB1",214,0)
END ;Don't kill IBIFN, IBER, DFN
"RTN","IBCBB1",215,0)
 I $O(^TMP($J,"BILL-WARN",0)),$G(IBER)="" S IBER="WARN" ;Warnings only
"RTN","IBCBB1",216,0)
 K IBBNO,IBEVDT,IBLOC,IBCL,IBTF,IBAT,IBWHO,IBST,IBFDT,IBTDT,IBTC,IBFY,IBFY1,IBAU,IBRU,IBEU,IBARTP,IBFYC,IBMRA,IBTOB,IBTOB12,IBNDU2,IBNDUF3,IBNDUF31,IBNDTX
"RTN","IBCBB1",217,0)
 K IBNDS,IBND0,IBNDU,IBNDM,IBNDMP,IBNDU1,IBFFY,IBTFY,IBFT,IBRTCHV,IBPICHV,IBXDATA,IBOK
"RTN","IBCBB1",218,0)
 I $D(IBER),IBER="" W !,"No Errors found for National edits"
"RTN","IBCBB1",219,0)
 Q
"RTN","IBCBB1",220,0)
 ;
"RTN","IBCBB1",221,0)
ARRAY ;Build PRCASV(array)
"RTN","IBCBB1",222,0)
 N IBCOBN,X
"RTN","IBCBB1",223,0)
 K PRCASV
"RTN","IBCBB1",224,0)
 Q:$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN))
"RTN","IBCBB1",225,0)
 S IBCOBN=$$COBN^IBCEF(IBIFN)
"RTN","IBCBB1",226,0)
 S X=IBIFN
"RTN","IBCBB1",227,0)
 S PRCASV("BDT")=DT,PRCASV("ARREC")=IBIFN
"RTN","IBCBB1",228,0)
 S PRCASV("APR")=DUZ
"RTN","IBCBB1",229,0)
 S PRCASV("PAT")=DFN,PRCASV("CAT")=$P(^DGCR(399.3,IBAT,0),"^",6)
"RTN","IBCBB1",230,0)
 I IBWHO="i" S PRCASV("DEBTOR")=+IBNDMP_";DIC(36,"
"RTN","IBCBB1",231,0)
 S PRCASV("DEBTOR")=$S(IBWHO="p":DFN_";DPT(",IBWHO="o":$P(IBNDM,"^",11)_";DIC(4,",IBWHO="i":PRCASV("DEBTOR"),1:"")
"RTN","IBCBB1",232,0)
 S PRCASV("CARE")=$E($$TOB^IBCEF1(IBIFN),1,2)
"RTN","IBCBB1",233,0)
 S PRCASV("FY")=$$FY^IBOUTL(DT)_U_($P(IBNDU1,U)-$P(IBNDU1,U,2))
"RTN","IBCBB1",234,0)
 ;S PRCASV("FY")=$P(IBNDU1,U,9)_U_$S($P(IBNDU1,U,2)]"":($P(IBNDU1,U,10)-$P(IBNDU1,U,2)),1:$P(IBNDU1,U,10))_$S($P(IBNDU1,U,11)]"":U_$P(IBNDU1,U,11)_U_$P(IBNDU1,U,12),1:"")
"RTN","IBCBB1",235,0)
PLUS I IBWHO="i",$P(IBNDM,"^",2),$D(^DIC(36,$P(IBNDM,"^",2),0)) S PRCASV("2NDINS")=$P(IBNDM,"^",2)
"RTN","IBCBB1",236,0)
 I IBWHO="i",$P(IBNDM,"^",3),$D(^DIC(36,$P(IBNDM,"^",3),0)) S PRCASV("3RDINS")=$P(IBNDM,"^",3)
"RTN","IBCBB1",237,0)
 ;
"RTN","IBCBB1",238,0)
 N IBX S IBX=$P(IBND0,U,21),IBX=$S(IBX="P":"I1",IBX="S":"I2",IBX="T":"I3",1:"") Q:IBX=""
"RTN","IBCBB1",239,0)
 N IBNDI1
"RTN","IBCBB1",240,0)
 Q:'$D(^DGCR(399,IBIFN,IBX))  S IBNDI1=^(IBX)
"RTN","IBCBB1",241,0)
 S:$P(IBNDI1,"^",3)]"" PRCASV("GPNO")=$P(IBNDI1,"^",3)
"RTN","IBCBB1",242,0)
 S:$P(IBNDI1,"^",15)]"" PRCASV("GPNM")=$P(IBNDI1,"^",15)
"RTN","IBCBB1",243,0)
 S:$P(IBNDI1,"^",17)]"" PRCASV("INPA")=$P(IBNDI1,"^",17)
"RTN","IBCBB1",244,0)
 S:$P(IBNDI1,"^",2)]"" PRCASV("IDNO")=$P(IBNDI1,"^",2),PRCASV("INID")=PRCASV("IDNO")
"RTN","IBCBB1",245,0)
 ; Check that this is a secondary or tertiary bill and insurance for previous
"RTN","IBCBB1",246,0)
 ; COB sequence is Medicare WNR and MRA is active --> send data elements to AR
"RTN","IBCBB1",247,0)
 I IBCOBN>1,$$WNRBILL^IBEFUNC(IBIFN,IBCOBN-1),$$EDIACTV^IBCEF4(2) D MRA
"RTN","IBCBB1",248,0)
 Q
"RTN","IBCBB1",249,0)
 ;
"RTN","IBCBB1",250,0)
MRA N IBEOB S IBEOB=0
"RTN","IBCBB1",251,0)
 ;
"RTN","IBCBB1",252,0)
 K PRCASV("MEDURE"),PRCASV("MEDCA")
"RTN","IBCBB1",253,0)
 ; Get EOB data
"RTN","IBCBB1",254,0)
 F  S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB  D
"RTN","IBCBB1",255,0)
 . D MRACALC^IBCEMU2(IBEOB,IBIFN,1,.PRCASV)
"RTN","IBCBB1",256,0)
 Q  ;MRA
"RTN","IBCBB1",257,0)
 ;
"RTN","IBCBB1",258,0)
 ;; PREGNANCY DX CODES: V22**-V24**, V27**-V28**, 630**-677**
"RTN","IBCBB1",259,0)
 ;; FLU SHOTS PROCEDURE CODES: 90724, G0008, 90732, G0009
"RTN","IBCBB13")
0^55^B19726855
"RTN","IBCBB13",1,0)
IBCBB13 ;ALB/BI - PROCEDURE AND LINE LEVEL PROVIDER EDITS ;5-OCT-2011
"RTN","IBCBB13",2,0)
 ;;2.0;INTEGRATED BILLING;**447**;21-MAR-94;Build 80
"RTN","IBCBB13",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCBB13",4,0)
 Q
"RTN","IBCBB13",5,0)
 ;
"RTN","IBCBB13",6,0)
IBLNTOT(IBIFN)   ; Calculate Line total charges.  IB*2.0*447 BI
"RTN","IBCBB13",7,0)
 N X,SUM S SUM=0
"RTN","IBCBB13",8,0)
 S X=0 F  S X=$O(^DGCR(399,IBIFN,"RC",X)) Q:+X=0  D
"RTN","IBCBB13",9,0)
 . S SUM=SUM+$P($G(^DGCR(399,IBIFN,"RC",X,0)),"^",4)
"RTN","IBCBB13",10,0)
 Q SUM
"RTN","IBCBB13",11,0)
 ;
"RTN","IBCBB13",12,0)
IBSYEI(IBIFN)   ; Test for valid EIN/SY ID Values. IB*2.0*447 BI
"RTN","IBCBB13",13,0)
 N X12CODE,RESULT,IBPIEN,IBWIEN,IBLIEN
"RTN","IBCBB13",14,0)
 S RESULT=0
"RTN","IBCBB13",15,0)
 ; Check Claim Level Providers
"RTN","IBCBB13",16,0)
 S IBWIEN=IBIFN_","
"RTN","IBCBB13",17,0)
 S X12CODE=$$GET1^DIQ(355.97,$$GET1^DIQ(399,IBWIEN,128,"I")_",",.03)
"RTN","IBCBB13",18,0)
 I ((X12CODE="SY")!(X12CODE="EI")),$TR($$GET1^DIQ(399,IBWIEN,122),"-","")'?9N S RESULT=1 Q RESULT
"RTN","IBCBB13",19,0)
 S X12CODE=$$GET1^DIQ(355.97,$$GET1^DIQ(399,IBWIEN,129,"I")_",",.03)
"RTN","IBCBB13",20,0)
 I ((X12CODE="SY")!(X12CODE="EI")),$TR($$GET1^DIQ(399,IBWIEN,123),"-","")'?9N S RESULT=1 Q RESULT
"RTN","IBCBB13",21,0)
 S X12CODE=$$GET1^DIQ(355.97,$$GET1^DIQ(399,IBWIEN,130,"I")_",",.03)
"RTN","IBCBB13",22,0)
 I ((X12CODE="SY")!(X12CODE="EI")),$TR($$GET1^DIQ(399,IBWIEN,124),"-","")'?9N S RESULT=1 Q RESULT
"RTN","IBCBB13",23,0)
 ; Check Claim Level Providers
"RTN","IBCBB13",24,0)
 S IBPIEN=0 F  S IBPIEN=$O(^DGCR(399,IBIFN,"PRV",IBPIEN)) Q:+IBPIEN=0  Q:RESULT=1  D
"RTN","IBCBB13",25,0)
 .S IBWIEN=IBPIEN_","_IBIFN_","
"RTN","IBCBB13",26,0)
 .; Test for each provider listed.
"RTN","IBCBB13",27,0)
 .S X12CODE=$$GET1^DIQ(355.97,$$GET1^DIQ(399.0222,IBWIEN,.12,"I")_",",.03)
"RTN","IBCBB13",28,0)
 .I ((X12CODE="SY")!(X12CODE="EI")),$TR($$GET1^DIQ(399.0222,IBWIEN,.05),"-","")'?9N S RESULT=1 Q
"RTN","IBCBB13",29,0)
 .S X12CODE=$$GET1^DIQ(355.97,$$GET1^DIQ(399.0222,IBWIEN,.13,"I")_",",.03)
"RTN","IBCBB13",30,0)
 .I ((X12CODE="SY")!(X12CODE="EI")),$TR($$GET1^DIQ(399.0222,IBWIEN,.06),"-","")'?9N S RESULT=1 Q 
"RTN","IBCBB13",31,0)
 .S X12CODE=$$GET1^DIQ(355.97,$$GET1^DIQ(399.0222,IBWIEN,.14,"I")_",",.03)
"RTN","IBCBB13",32,0)
 .I ((X12CODE="SY")!(X12CODE="EI")),$TR($$GET1^DIQ(399.0222,IBWIEN,.07),"-","")'?9N S RESULT=1 Q
"RTN","IBCBB13",33,0)
 ; Check Line Level Providers
"RTN","IBCBB13",34,0)
 ; For each charge code / line.
"RTN","IBCBB13",35,0)
 S IBLIEN=0 F  S IBLIEN=$O(^DGCR(399,IBIFN,"CP",IBLIEN)) Q:+IBLIEN=0  Q:RESULT=1  D
"RTN","IBCBB13",36,0)
 .; For each provider associated with the line.
"RTN","IBCBB13",37,0)
 .S IBPIEN=0 F  S IBPIEN=$O(^DGCR(399,IBIFN,"CP",IBLIEN,"LNPRV",IBPIEN)) Q:+IBPIEN=0  Q:RESULT=1  D
"RTN","IBCBB13",38,0)
 ..S IBWIEN=IBPIEN_","_IBLIEN_","_IBIFN_","
"RTN","IBCBB13",39,0)
 ..; Test for each provider listed.
"RTN","IBCBB13",40,0)
 ..S X12CODE=$$GET1^DIQ(355.97,$$GET1^DIQ(399.0404,IBWIEN,.12,"I")_",",.03)
"RTN","IBCBB13",41,0)
 ..I ((X12CODE="SY")!(X12CODE="EI")),$TR($$GET1^DIQ(399.0404,IBWIEN,.05),"-","")'?9N S RESULT=1 Q
"RTN","IBCBB13",42,0)
 ..S X12CODE=$$GET1^DIQ(355.97,$$GET1^DIQ(399.0404,IBWIEN,.13,"I")_",",.03)
"RTN","IBCBB13",43,0)
 ..I ((X12CODE="SY")!(X12CODE="EI")),$TR($$GET1^DIQ(399.0404,IBWIEN,.06),"-","")'?9N S RESULT=1 Q
"RTN","IBCBB13",44,0)
 ..S X12CODE=$$GET1^DIQ(355.97,$$GET1^DIQ(399.0404,IBWIEN,.14,"I")_",",.03)
"RTN","IBCBB13",45,0)
 ..I ((X12CODE="SY")!(X12CODE="EI")),$TR($$GET1^DIQ(399.0404,IBWIEN,.07),"-","")'?9N S RESULT=1 Q
"RTN","IBCBB13",46,0)
 Q RESULT
"RTN","IBCBB13",47,0)
 ;
"RTN","IBCBB13",48,0)
IBMICN(IBIFN)   ; Test for a missing ICN. IB*2.0*447 BI
"RTN","IBCBB13",49,0)
 N IBTFOB ; TIMEFRAME OF BILL
"RTN","IBCBB13",50,0)
 N IBCBPS ; CURRENT BILL PAYER SEQUENCE, P-PRI, S-SEC, T-TER, A-PATIENT
"RTN","IBCBB13",51,0)
 S IBTFOB=$$GET1^DIQ(399,IBIFN_",",.06,"I")
"RTN","IBCBB13",52,0)
 I '((IBTFOB=7)!(IBTFOB=8)) Q 0
"RTN","IBCBB13",53,0)
 S IBCBPS=$$GET1^DIQ(399,IBIFN_",",.21,"I")
"RTN","IBCBB13",54,0)
 I IBCBPS="P",$$GET1^DIQ(399,IBIFN_",",101)'="",$$GET1^DIQ(399,IBIFN_",",453)="" Q 1
"RTN","IBCBB13",55,0)
 I IBCBPS="S",$$GET1^DIQ(399,IBIFN_",",102)'="",$$GET1^DIQ(399,IBIFN_",",454)="" Q 1
"RTN","IBCBB13",56,0)
 I IBCBPS="T",$$GET1^DIQ(399,IBIFN_",",103)'="",$$GET1^DIQ(399,IBIFN_",",455)="" Q 1
"RTN","IBCBB13",57,0)
 Q 0
"RTN","IBCBB13",58,0)
 ;
"RTN","IBCBB13",59,0)
IBRCCHK(IBIFN)   ; Test for a ZERO charge amounts. IB*2.0*447 BI
"RTN","IBCBB13",60,0)
 N IBN0
"RTN","IBCBB13",61,0)
 N IBRCCNT S IBRCCNT=0
"RTN","IBCBB13",62,0)
 N IBRCCHG S IBRCCHG=0
"RTN","IBCBB13",63,0)
 F  S IBRCCNT=$O(^DGCR(399,IBIFN,"RC",IBRCCNT)) Q:+IBRCCNT=0  Q:IBRCCHG=1  D
"RTN","IBCBB13",64,0)
 .S IBN0=$G(^DGCR(399,IBIFN,"RC",IBRCCNT,0))
"RTN","IBCBB13",65,0)
 .I $P(IBN0,U,1)'="",+$P(IBN0,U,4)=0 S IBRCCHG=1
"RTN","IBCBB13",66,0)
 Q IBRCCHG
"RTN","IBCBB13",67,0)
 ;
"RTN","IBCBB13",68,0)
IBPRV3(IBIFN)   ; Test for missing "Patient reason for visit". IB*2.0*447 BI
"RTN","IBCBB13",69,0)
 I $$GET1^DIQ(399,IBIFN_",",249)="",$$GET1^DIQ(399,IBIFN_",",250)="",$$GET1^DIQ(399,IBIFN_",",251)="" Q 1
"RTN","IBCBB13",70,0)
 Q 0
"RTN","IBCBB13",71,0)
 ;
"RTN","IBCBB13",72,0)
IBMPID(IBIFN)   ; Test for multiple payers. IB*2.0*447 BI
"RTN","IBCBB13",73,0)
 N IBPAY1 S IBPAY1=$$GET1^DIQ(399,IBIFN_",",101,"I")
"RTN","IBCBB13",74,0)
 N IBPAY2 S IBPAY2=$$GET1^DIQ(399,IBIFN_",",102,"I")
"RTN","IBCBB13",75,0)
 N IBPAY3 S IBPAY3=$$GET1^DIQ(399,IBIFN_",",103,"I")
"RTN","IBCBB13",76,0)
 N IBCNT S IBCNT=0
"RTN","IBCBB13",77,0)
 S:IBPAY1 IBCNT=IBCNT+1 S:IBPAY2 IBCNT=IBCNT+1 S:IBPAY3 IBCNT=IBCNT+1 I IBCNT<2 Q 0
"RTN","IBCBB13",78,0)
 N IBINSTIT S IBINSTIT=$$INSPRF^IBCEF(IBIFN)
"RTN","IBCBB13",79,0)
 I IBPAY1,$S(IBINSTIT:$$GET1^DIQ(36,IBPAY1_",",3.04),1:$$GET1^DIQ(36,IBPAY1_",",3.02))="" Q 1
"RTN","IBCBB13",80,0)
 I IBPAY2,$S(IBINSTIT:$$GET1^DIQ(36,IBPAY2_",",3.04),1:$$GET1^DIQ(36,IBPAY2_",",3.02))="" Q 1
"RTN","IBCBB13",81,0)
 I IBPAY3,$S(IBINSTIT:$$GET1^DIQ(36,IBPAY3_",",3.04),1:$$GET1^DIQ(36,IBPAY3_",",3.02))="" Q 1
"RTN","IBCBB13",82,0)
 Q 0
"RTN","IBCBB2")
0^53^B50172747
"RTN","IBCBB2",1,0)
IBCBB2 ;ALB/ARH - CONTINUATION OF EDIT CHECKS ROUTINE (CMS-1500) ;04/14/92
"RTN","IBCBB2",2,0)
 ;;2.0;INTEGRATED BILLING;**51,137,210,245,232,296,320,349,371,403,432,447**;21-MAR-94;Build 80
"RTN","IBCBB2",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCBB2",4,0)
 ;
"RTN","IBCBB2",5,0)
 ;MAP TO DGCRBB2
"RTN","IBCBB2",6,0)
 ;
"RTN","IBCBB2",7,0)
EN ;
"RTN","IBCBB2",8,0)
 N IBI,IBJ,IBN,IBY,IBDX,IBDXO,IBDXL,IBDXTYP,IBCPT,IBCPTL,IBOLAB,Z,IBXSAVE,IBLOC,IBTX,IBPS,IBSP,IBLCT,IBNVFLG,IBU3
"RTN","IBCBB2",9,0)
 I '$D(IBER) S IBER=""
"RTN","IBCBB2",10,0)
 S IBTX=$$TXMT^IBCEF4(IBIFN)
"RTN","IBCBB2",11,0)
 ;
"RTN","IBCBB2",12,0)
 ; Max 4 modifiers per CPT code allowed before warning
"RTN","IBCBB2",13,0)
 K IBXDATA
"RTN","IBCBB2",14,0)
 D F^IBCEF("N-HCFA 1500 MODIFIERS",,,IBIFN) ;Get modifiers
"RTN","IBCBB2",15,0)
 ;
"RTN","IBCBB2",16,0)
 S Z=0 F  S Z=$O(IBZPRC92(Z)) Q:'Z  I $P(IBZPRC92(Z),U)["ICPT(",$L($P(IBZPRC92(Z),U,15),",")>4 S IBI="Proc "_$$PRCD^IBCEF1($P(IBZPRC92(Z),U))_" has > 4 modifiers - only first 4 will be used" D WARN^IBCBB11(IBI)
"RTN","IBCBB2",17,0)
 ; ICD-9 diagnosis, at least 1 required
"RTN","IBCBB2",18,0)
 D SET^IBCSC4D(IBIFN,.IBDX,.IBDXO) I '$P(IBDX,U,2) S IBER=IBER_"IB071;"
"RTN","IBCBB2",19,0)
 S IBI=$O(IBDXO(0))
"RTN","IBCBB2",20,0)
 I IBI D
"RTN","IBCBB2",21,0)
 .S IBDXTYP=$E($$ICD9^IBACSV(+$P(IBDXO(IBI),U)))
"RTN","IBCBB2",22,0)
 .S:IBDXTYP="E" IBER=IBER_"IB117;"
"RTN","IBCBB2",23,0)
 .I $$INPAT^IBCEF(IBIFN,1),IBDXTYP="V" S Z="Principal Dx V-code may not be valid" D WARN^IBCBB11(Z)
"RTN","IBCBB2",24,0)
 .Q
"RTN","IBCBB2",25,0)
 ;
"RTN","IBCBB2",26,0)
 ; CPT procs must be associated with a dx, must have a defined provider
"RTN","IBCBB2",27,0)
 S (IBLOC,IBN,IBI,IBY)=0 F  S IBI=$O(^DGCR(399,IBIFN,"CP",IBI)) Q:IBI'?1N.N  S IBCPT=^(IBI,0) D  I +IBY S IBN=1
"RTN","IBCBB2",28,0)
 . I 'IBLOC,$P(IBCPT,U,15)'="",IBTX S Z="At least 1 charge has local box 24K data that will not be transmitted - " S IBLOC=1 D WARN^IBCBB11(Z) S Z="  This data will only print locally" D WARN^IBCBB11(Z)
"RTN","IBCBB2",29,0)
 . I $P(IBCPT,U)'["ICPT(" S:IBER'["IB092" IBER=IBER_"IB092;" Q
"RTN","IBCBB2",30,0)
 . S IBY=1 F IBJ=11:1:14 I +$P(IBCPT,"^",IBJ) S IBCPTL(+$P(IBCPT,"^",IBJ))="",IBY=0
"RTN","IBCBB2",31,0)
 I +IBN S IBER=IBER_"IB072;"
"RTN","IBCBB2",32,0)
 ;
"RTN","IBCBB2",33,0)
 I '$$OCC10(IBIFN,.IBDX,2) S IBER=IBER_"IB093;"
"RTN","IBCBB2",34,0)
 ; CMS-1500: dxs associated with procs must be defined dxs for the bill
"RTN","IBCBB2",35,0)
 S IBI=0 F  S IBI=$O(IBDX(IBI))  Q:'IBI  S IBDXL(IBDX(IBI))=""
"RTN","IBCBB2",36,0)
 S (IBN,IBI)=0 F  S IBI=$O(IBCPTL(IBI)) Q:'IBI  I '$D(IBDXL(IBI)) S IBN=1 Q
"RTN","IBCBB2",37,0)
 I +IBN S IBER=IBER_"IB073;"
"RTN","IBCBB2",38,0)
 ; ejk *296* Change # of diagnoses codes from 4 to 8 on CMS-1500 Claims. 
"RTN","IBCBB2",39,0)
 I IBTX S IBI=8 F  S IBI=$O(IBDXO(IBI)) Q:'IBI  S Z=+$G(IBDX(+$G(IBDXO(IBI)))) I Z,$D(IBCPTL(Z)) D WARN^IBCBB11("Too many diagnoses for claim & will be rejected - consider printing locally")
"RTN","IBCBB2",40,0)
 ;
"RTN","IBCBB2",41,0)
 I $$WNRBILL^IBEFUNC(IBIFN),$$MRATYPE^IBEFUNC(IBIFN)'="B" S IBER=IBER_"IB087;"
"RTN","IBCBB2",42,0)
 ;
"RTN","IBCBB2",43,0)
 ; IB*320 - CLIA# error/warning - error msg for MRA claims, else warning
"RTN","IBCBB2",44,0)
 I $P(IBNDU2,U,13)="",$$CLIAREQ^IBCEP8A(IBIFN) D
"RTN","IBCBB2",45,0)
 . I $$REQMRA^IBEFUNC(IBIFN) S IBER=IBER_"IB235;" Q
"RTN","IBCBB2",46,0)
 . D WARN^IBCBB11("Claim contains laboratory services. The payer may require a CLIA #.")
"RTN","IBCBB2",47,0)
 . Q
"RTN","IBCBB2",48,0)
 ;
"RTN","IBCBB2",49,0)
 ; Only one occurrence code can be present for event date for box 14
"RTN","IBCBB2",50,0)
 S Z=$$EVENT^IBCF22(IBIFN,.IBXSAVE,.IBI)
"RTN","IBCBB2",51,0)
 I IBI S IBER=IBER_"IB099;"
"RTN","IBCBB2",52,0)
 ;
"RTN","IBCBB2",53,0)
 ; esg - 6/6/07 - warning if missing non-VA care type for outside facility
"RTN","IBCBB2",54,0)
 S IBNVFLG=0
"RTN","IBCBB2",55,0)
 I $P(IBNDU2,U,10),'$P(IBNDU2,U,11) D WARN^IBCBB11("Non-VA facility indicated, but the Non-VA Care Type field is not defined") S IBNVFLG=1
"RTN","IBCBB2",56,0)
 ;
"RTN","IBCBB2",57,0)
 ; unit/charge limits
"RTN","IBCBB2",58,0)
 K IBXDATA
"RTN","IBCBB2",59,0)
 D F^IBCEF("N-HCFA 1500 SERVICES (PRINT)",,,IBIFN) ;Get charge lines
"RTN","IBCBB2",60,0)
 S (IBLCT,IBOLAB)=0,IBPS="",IBSP=$$BILLSPEC^IBCEU3(IBIFN)
"RTN","IBCBB2",61,0)
 S IBI=0 F  S IBI=$O(IBXDATA(IBI)) Q:'IBI  D  Q:IBER["IB310"!(IBER["IB311")
"RTN","IBCBB2",62,0)
 . S IBLCT=IBLCT+1
"RTN","IBCBB2",63,0)
 . I $P(IBNDU2,U,11) D
"RTN","IBCBB2",64,0)
 .. I '$P(IBXDATA(IBI),U,11) S IBPS=IBPS_$S(IBPS'="":",",1:"")_IBI Q
"RTN","IBCBB2",65,0)
 .. I $P(IBXDATA(IBI),U,14),"24"'[$P(IBNDU2,U,11) D WARN^IBCBB11("Outside lab charges exist on a non-lab NON-VA bill")
"RTN","IBCBB2",66,0)
 . I '$P(IBNDU2,U,11),$P(IBXDATA(IBI),U,11) D WARN^IBCBB11("Purchased service amounts are invalid unless this is a NON-VA bill")
"RTN","IBCBB2",67,0)
 . I IBNVFLG,'$P(IBXDATA(IBI),U,11) D WARN^IBCBB11("Non-VA facility indicated, but no purchased service charge on line# "_IBI)
"RTN","IBCBB2",68,0)
 . I $D(IBXDATA(IBI,"A")) S IBER=IBER_"IB310;" Q
"RTN","IBCBB2",69,0)
 . I $D(IBXDATA(IBI,"ARX")),IBER'["311;" S IBER=IBER_"IB311;" Q
"RTN","IBCBB2",70,0)
 . I $P(IBXDATA(IBI),U,14) S IBOLAB=IBOLAB+1
"RTN","IBCBB2",71,0)
 . ; Place of service required
"RTN","IBCBB2",72,0)
 . I $G(IBER)'["IB314;",$P(IBXDATA(IBI),U,3)="" S IBER=IBER_"IB314;"
"RTN","IBCBB2",73,0)
 . ; Type of service required
"RTN","IBCBB2",74,0)
 . I $G(IBER)'["IB313;",$P(IBXDATA(IBI),U,4)="" S IBER=IBER_"IB313;"
"RTN","IBCBB2",75,0)
 . ; 43 and 53 are invalid types of service
"RTN","IBCBB2",76,0)
 . I $G(IBER)'["IB110;",($P(IBXDATA(IBI),U,4)=43!($P(IBXDATA(IBI),U,4)=53)) S IBER=IBER_"IB110;"
"RTN","IBCBB2",77,0)
 . ; Units for the line item must be less than 100/1000
"RTN","IBCBB2",78,0)
 . I IBER'["IB088",$P(IBXDATA(IBI),U,9)'<100 D
"RTN","IBCBB2",79,0)
 .. I $P(IBXDATA(IBI),U,4)'=7 S IBER=IBER_"IB088;" Q
"RTN","IBCBB2",80,0)
 .. I $P(IBXDATA(IBI),U,9)'<1000 S IBER=IBER_"IB088;"
"RTN","IBCBB2",81,0)
 . ; Line item total charge must be less than $10,000.00, greater than 0
"RTN","IBCBB2",82,0)
 . ; IB*2.0*432 - The IB system shall provide the ability for users to enter maximum line item dollar amounts of 9999999.99.
"RTN","IBCBB2",83,0)
 . ; I IBER'["IB090",$P(IBXDATA(IBI),U,9)'<10000 S IBER=IBER_"IB090;"
"RTN","IBCBB2",84,0)
 . I IBER'["IB090",$P(IBXDATA(IBI),U,9)'<10000000 S IBER=IBER_"IB090;"
"RTN","IBCBB2",85,0)
 . ; IB*2.0*447 BI Removed individual warning replaced by a claim level warning.
"RTN","IBCBB2",86,0)
 . ; I '($P(IBXDATA(IBI),U,9)*$P(IBXDATA(IBI),U,8)),$$COBN^IBCEF(IBIFN)'>1 S Z="Procedure "_$P(IBXDATA(IBI),U,5)_" has a 0-charge and will not be transmitted" D WARN^IBCBB11(Z)
"RTN","IBCBB2",87,0)
 I IBTX,IBLCT>50 D
"RTN","IBCBB2",88,0)
 . I '$$REQMRA^IBEFUNC(IBIFN) S IBER=IBER_"IB308;" Q
"RTN","IBCBB2",89,0)
 . I '$P(IBNDTX,U,9) S IBER=IBER_"IB325;"
"RTN","IBCBB2",90,0)
 S IBU3=$P($G(^DGCR(399,IBIFN,"U3")),U,4,7) I $TR(IBU3,U)'="" D
"RTN","IBCBB2",91,0)
 .; ib*2.0*432 add line-level check
"RTN","IBCBB2",92,0)
 .;I +IBSP'=35 D WARN^IBCBB11("Chiropractic service details only valid if provider specialty is '35'")
"RTN","IBCBB2",93,0)
 .I $$LINSPEC^IBCEU3(IBIFN)'[35 D WARN^IBCBB11("Chiropractic service details only valid if provider specialty is '35'")
"RTN","IBCBB2",94,0)
 .I $P(IBU3,U,2)="" S IBER=IBER_"IB137;"
"RTN","IBCBB2",95,0)
 .I $P(IBU3,U,4)="" S IBER=IBER_"IB138;" Q
"RTN","IBCBB2",96,0)
 .I $P(IBU3,U,3)="","AM"[$P(IBU3,U,4) S IBER=IBER_"IB139;"
"RTN","IBCBB2",97,0)
 .Q
"RTN","IBCBB2",98,0)
 I IBPS'="" D WARN^IBCBB11("NON-VA facility indicated, but no purchased service charge on line item"_$S(IBPS[",":"s",1:"")_" #"_IBPS)
"RTN","IBCBB2",99,0)
 I $P(IBNDU2,U,11),$P(IBNDU2,U,11)=4,IBOLAB>1 D WARN^IBCBB11("For proper payment, you must bill each outside lab on a separate claim form")
"RTN","IBCBB2",100,0)
 K IBXDATA
"RTN","IBCBB2",101,0)
 ;
"RTN","IBCBB2",102,0)
 ;       ; Check for Physician Name
"RTN","IBCBB2",103,0)
 D F^IBCEF("N-REFERRING PROVIDER NAME",,,IBIFN)
"RTN","IBCBB2",104,0)
 I $P($G(IBXDATA),U)]"" D
"RTN","IBCBB2",105,0)
 .N IBZ,FUNCTION,IBINS
"RTN","IBCBB2",106,0)
 .S FUNCTION=1
"RTN","IBCBB2",107,0)
 .F IBINS=1:1:3 D
"RTN","IBCBB2",108,0)
 .. S Z=$$GETTYP^IBCEP2A(IBIFN,IBINS,FUNCTION)
"RTN","IBCBB2",109,0)
 .. I Z,$P(Z,U,2) D  ; Rendering/attending prov secondary id required
"RTN","IBCBB2",110,0)
 ... N IBID,IBOK,Q0
"RTN","IBCBB2",111,0)
 ... D PROVINF^IBCEF74(IBIFN,IBINS,.IBID,1,"C")  ; check all as though they were current
"RTN","IBCBB2",112,0)
 ... S IBOK=0
"RTN","IBCBB2",113,0)
 ... S Q0=0 F  S Q0=$O(IBID(1,FUNCTION,Q0)) Q:'Q0  I $P(IBID(1,FUNCTION,Q0),U,9)=+Z S IBOK=1 Q
"RTN","IBCBB2",114,0)
 ... I 'IBOK S IBER=IBER_$S(IBINS=1:"IB239;",IBINS=2:"IB240;",IBINS=3:"IB241;",1:"")
"RTN","IBCBB2",115,0)
 ;
"RTN","IBCBB2",116,0)
 Q
"RTN","IBCBB2",117,0)
 ;
"RTN","IBCBB2",118,0)
OCC10(IBIFN,IBARR,IBFT) ; Determine if occurrence code 10 exists for pregnancy dx
"RTN","IBCBB2",119,0)
 ; IBARR=array subscripted by ien of DX code if IBFT=2 (CMS-1500 form)
"RTN","IBCBB2",120,0)
 ;                         by seq # and = ien of DX code if IBFT'=2
"RTN","IBCBB2",121,0)
 ;
"RTN","IBCBB2",122,0)
 N IBN,IBI,IBXDATA,IBXSAVE,IBDX,Z
"RTN","IBCBB2",123,0)
 S IBN=1
"RTN","IBCBB2",124,0)
 ;
"RTN","IBCBB2",125,0)
 I '$D(^TMP($J,"LMD")) D
"RTN","IBCBB2",126,0)
 . D F^IBCEF("N-OCCURRENCE CODES",,,IBIFN)
"RTN","IBCBB2",127,0)
 . S ^TMP($J,"LMD")=""
"RTN","IBCBB2",128,0)
 . S Z=0 F  S Z=$O(IBXSAVE("OCC",Z)) Q:'Z  I +IBXSAVE("OCC",Z)=10 S ^TMP($J,"LMD")=1 Q
"RTN","IBCBB2",129,0)
 ;
"RTN","IBCBB2",130,0)
 I '^TMP($J,"LMD") S IBI=0 F  S IBI=$O(IBARR(IBI))  Q:'IBI  D  Q:'IBN
"RTN","IBCBB2",131,0)
 . N Z,Z1
"RTN","IBCBB2",132,0)
 . ; If a pregnancy DX exists, must be an occurrence code 10 for LMP date
"RTN","IBCBB2",133,0)
 . ; dx ranges are: V22*-V24*, V27*-V28*, 630*-677*
"RTN","IBCBB2",134,0)
 . S IBDX=$S($G(IBFT)'=2:+IBARR(IBI),1:IBI)
"RTN","IBCBB2",135,0)
 . S Z=$E($P($$ICD9^IBACSV(IBDX),U),1,3),Z1=$E(Z,2,3)
"RTN","IBCBB2",136,0)
 . I $S(Z'<630&(Z<678):1,$E(Z)="V":$S(Z1'<22&(Z1<25):1,1:Z1'<27&(Z1<28)),1:0) S IBN=0 ;Pregnancy Dx exists
"RTN","IBCBB2",137,0)
 ;
"RTN","IBCBB2",138,0)
OCC10Q K ^TMP($J,"LMD")
"RTN","IBCBB2",139,0)
 Q IBN
"RTN","IBCBB2",140,0)
 ;
"RTN","IBCBB21")
0^54^B14595417
"RTN","IBCBB21",1,0)
IBCBB21 ;ALB/AAS - CONTINUATION OF EDIT CHECK ROUTINE FOR UB-04 ;2-NOV-89
"RTN","IBCBB21",2,0)
 ;;2.0;INTEGRATED BILLING;**51,137,210,232,155,291,348,349,403,400,432,447**;21-MAR-94;Build 80
"RTN","IBCBB21",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCBB21",4,0)
 ;
"RTN","IBCBB21",5,0)
EN(IBZPRC92) ;
"RTN","IBCBB21",6,0)
 ;
"RTN","IBCBB21",7,0)
 N ECODE,IBTXMT,IBXDATA,IBDXTYP,IBLPRT,IBI,Z,Z0,Z1,IBREQMRA
"RTN","IBCBB21",8,0)
 I '$D(IBZPRC92) D ALLPROC^IBCVA1(IBIFN,.IBZPRC92)
"RTN","IBCBB21",9,0)
 S IBREQMRA=$$REQMRA^IBEFUNC(IBIFN)    ; MRA?
"RTN","IBCBB21",10,0)
 K IBQUIT S IBQUIT=0
"RTN","IBCBB21",11,0)
 S (Z,Z0,Z1)=0
"RTN","IBCBB21",12,0)
 F  S Z=$O(IBZPRC92(Z)) Q:'Z  S:IBZPRC92(Z)["CPT" Z0=Z0+1 S:IBZPRC92(Z)["ICD" Z1=Z1+1
"RTN","IBCBB21",13,0)
 S IBTXMT=$$TXMT^IBCEF4(IBIFN)
"RTN","IBCBB21",14,0)
 S IBZPRC92=Z0_U_Z1 ;Save # of CPT's and ICD9's
"RTN","IBCBB21",15,0)
 ; More than 50 procedures on a bill - must print locally
"RTN","IBCBB21",16,0)
 I IBTXMT,(+IBZPRC92>50!(+$P(IBZPRC92,U,2)>50)) D  Q:IBQUIT
"RTN","IBCBB21",17,0)
 . I 'IBREQMRA S IBQUIT=$$IBER^IBCBB3(.IBER,308) Q
"RTN","IBCBB21",18,0)
 . I '$P(IBNDTX,U,9) S IBQUIT=$$IBER^IBCBB3(.IBER,325)
"RTN","IBCBB21",19,0)
 ; removed 11x check ;WCJ IB*2.0*432
"RTN","IBCBB21",20,0)
 ; If ICD9 procedures with dates and charges, bill 11x or 83x needs operating physician
"RTN","IBCBB21",21,0)
 ;I IBTOB12="11",$P(IBZPRC92,U,2),'$$CKPROV^IBCEU(IBIFN,2) S IBER=IBER_"IB304;"
"RTN","IBCBB21",22,0)
 ;modify 83x check for line level providers and also chacnged the erro check slightly
"RTN","IBCBB21",23,0)
 ;I IBTOB12="83",$P(IBZPRC92,U,2),'$$CKPROV^IBCEU(IBIFN,2) S IBER=IBER_"IB312;"
"RTN","IBCBB21",24,0)
 I IBTOB12="83",'$$UBPRVCK^IBCBB12(IBIFN) S IBER=IBER_"IB312;"  ; DEM;432
"RTN","IBCBB21",25,0)
 ;
"RTN","IBCBB21",26,0)
 ; If any CPT procedures have more than 2 modifiers, warn
"RTN","IBCBB21",27,0)
 S Z=0 F  S Z=$O(IBZPRC92(Z)) Q:'Z  I $P(IBZPRC92(Z),U)["ICPT(",$L($P(IBZPRC92(Z),U,15),",")>2 S Z0="Proc "_$$PRCD^IBCEF1($P(IBZPRC92(Z),U))_" has > 2 modifiers - only first 2 will be used" D WARN^IBCBB11(Z0)
"RTN","IBCBB21",28,0)
 ;
"RTN","IBCBB21",29,0)
 I $$WNRBILL^IBEFUNC(IBIFN),$$MRATYPE^IBEFUNC(IBIFN)'="A" S IBER=IBER_"IB086;"
"RTN","IBCBB21",30,0)
 ;
"RTN","IBCBB21",31,0)
 ; UB-04 Diagnosis Codes
"RTN","IBCBB21",32,0)
 K IBXDATA D F^IBCEF("N-DIAGNOSES",,,IBIFN)
"RTN","IBCBB21",33,0)
 ;
"RTN","IBCBB21",34,0)
 ; Only 24 other dx's + 1 principal dx + 3 ecode dx's are allowed per claim
"RTN","IBCBB21",35,0)
 S (Z,ECODE,IBI)=0 F  S Z=$O(IBXDATA(Z)) Q:'Z  D  Q:IBER["309;"!(ECODE>3)
"RTN","IBCBB21",36,0)
 . S IBI=IBI+1
"RTN","IBCBB21",37,0)
 . I $E($$ICD9^IBACSV(+$P(IBXDATA(Z),U),$$BDATE^IBACSV(IBIFN)))="E" D
"RTN","IBCBB21",38,0)
 .. I ECODE>3 D WARN^IBCBB11("Claim contains more than 3 External Cause of Injury codes.") Q
"RTN","IBCBB21",39,0)
 .. S:ECODE<=3 ECODE=ECODE+1,IBI=IBI-1
"RTN","IBCBB21",40,0)
 .. Q
"RTN","IBCBB21",41,0)
 . ; max DX check does not apply to MRAs
"RTN","IBCBB21",42,0)
 . I IBTXMT,IBI>25 D
"RTN","IBCBB21",43,0)
 .. I 'IBREQMRA Q:$P(IBNDTX,U,8)  S IBER=IBER_"IB309;" Q
"RTN","IBCBB21",44,0)
 .. I '$P(IBNDTX,U,9) S IBER=IBER_"IB326;"
"RTN","IBCBB21",45,0)
 ;
"RTN","IBCBB21",46,0)
 I '$O(IBXDATA(0)) S IBER=IBER_"IB071;"   ;Require Diag code NOIS:OKL-0304-72495
"RTN","IBCBB21",47,0)
 I $O(IBXDATA(0)) D
"RTN","IBCBB21",48,0)
 .S IBDXTYP=$E($$ICD9^IBACSV(+$P(IBXDATA(1),U),$$BDATE^IBACSV(IBIFN)))
"RTN","IBCBB21",49,0)
 .S:IBDXTYP="E" IBER=IBER_"IB117;"
"RTN","IBCBB21",50,0)
 .I $$INPAT^IBCEF(IBIFN),IBDXTYP="V" S Z="Principal Dx V-code may not be valid" D WARN^IBCBB11(Z)
"RTN","IBCBB21",51,0)
 .Q
"RTN","IBCBB21",52,0)
 I '$$OCC10^IBCBB2(IBIFN,.IBXDATA,3) S IBER=IBER_"IB093;"
"RTN","IBCBB21",53,0)
 ; At least one PRV diagnosis is required for outpatient UB-04 claim
"RTN","IBCBB21",54,0)
 ; IB*2.0*447 BI This warning was removed and replaced with an Error Message in routine IBCBB1.
"RTN","IBCBB21",55,0)
 ;I '$$INPAT^IBCEF(IBIFN),$$CHKPRV^IBCSC10B=3 D WARN^IBCBB11("Outpatient Institutional claims should contain a Patient Reason for Visit.")
"RTN","IBCBB21",56,0)
 ;
"RTN","IBCBB21",57,0)
 K ^TMP($J,"IBC-RC")
"RTN","IBCBB21",58,0)
 D F^IBCEF("N-UB-04 SERVICE LINE (PRINT)",,,IBIFN)
"RTN","IBCBB21",59,0)
 S (Z0,IBI)=0 F  S IBI=$O(^TMP($J,"IBC-RC",IBI)) Q:'IBI  S Z=$G(^(IBI))  Q:+$P(Z,U,2)=1  I $P(Z,U,2),$P(Z,U,1)=1 D
"RTN","IBCBB21",60,0)
 . ; IB*2.0*432 - The IB system shall provide the ability for users to enter maximum line item dollar amounts of 9999999.99.
"RTN","IBCBB21",61,0)
 . ;I IBER'["IB090;",$P(Z,U,2)>1,($P(Z,U,7)>99999.99!($P(Z,U,8)>99999.99)) S IBER=IBER_"IB090;"
"RTN","IBCBB21",62,0)
 . I IBER'["IB090;",$P(Z,U,2)>1,($P(Z,U,7)>9999999.99!($P(Z,U,8)>9999999.99)) S IBER=IBER_"IB090;"
"RTN","IBCBB21",63,0)
 . Q:$P(Z,U,2)'<180&($P(Z,U,2)'>189)  ;Pass days (LOA) don't matter
"RTN","IBCBB21",64,0)
 . ; Removed the following warning IB*2.0*447 BI Replaced in IBCBB1.
"RTN","IBCBB21",65,0)
 . ;I '$P(Z,U,7),'$P(Z,U,8),'Z0,$$COBN^IBCEF(IBIFN)'>1  S Z0="Rev Code(s) having a 0-charge will not be transmitted for the bill" D WARN^IBCBB11(Z0) S Z0=1
"RTN","IBCBB21",66,0)
 K ^TMP($J,"IBC-RC")
"RTN","IBCBB21",67,0)
 Q
"RTN","IBCBB21",68,0)
 ;
"RTN","IBCBB6")
0^51^B235040
"RTN","IBCBB6",1,0)
IBCBB6 ;ALB/BGA - CONT. OF MEDICARE EDIT CHECKS ;08/12/98
"RTN","IBCBB6",2,0)
 ;;2.0;INTEGRATED BILLING;**51,447**;21-MAR-94;Build 80
"RTN","IBCBB6",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified
"RTN","IBCBB6",4,0)
 ;
"RTN","IBCBB6",5,0)
 ; Occurrence Span Codes and Dates
"RTN","IBCBB6",6,0)
 ; occ span 74 req admit and discharge of hosp stays for bill types
"RTN","IBCBB6",7,0)
 ; 13x,23x,72x,74x,75x
"RTN","IBCBB6",8,0)
 ;I $D(IBOCSP(74)),"^13^23^72^74^75^"[(U_IBTOB12_U),('IBZADMIT!'IBZDISCH) S IBQUIT=$$IBER^IBCBB3(.IBER,169) Q:IBQUIT
"RTN","IBCBB6",9,0)
 ; Internal Control Number (ICN) or Document Control Number (DCN)
"RTN","IBCBB6",10,0)
 ; IB*2.0*447 BI Removed and replaced with a call to $$IBMICN^IBCBB13 from IBCBB1
"RTN","IBCBB6",11,0)
 ;I ($E(IBTOB,3)=7!($E(IBTOB,3)=8)),$P(IBNDUF3,U,4)="" S IBQUIT=$$IBER^IBCBB3(.IBER,174) Q:IBQUIT
"RTN","IBCBB6",12,0)
 ;
"RTN","IBCBB6",13,0)
 D ^IBCBB7
"RTN","IBCBB6",14,0)
 Q
"RTN","IBCBB7")
0^62^B27582918
"RTN","IBCBB7",1,0)
IBCBB7 ;ALB/BGA - CONT. OF MEDICARE EDIT CHECKS ;09/10/98
"RTN","IBCBB7",2,0)
 ;;2.0;INTEGRATED BILLING;**51,137,240,447**;21-MAR-94;Build 80
"RTN","IBCBB7",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IBCBB7",4,0)
 ;
"RTN","IBCBB7",5,0)
 ; Revenue Codes
"RTN","IBCBB7",6,0)
 ;
"RTN","IBCBB7",7,0)
 ; rev codes must be between 100 AND 999
"RTN","IBCBB7",8,0)
 I $O(IBREV1(100),-1)>0!($O(IBREV1(999))>0) S IBQUIT=$$IBER^IBCBB3(.IBER,184) Q:IBQUIT
"RTN","IBCBB7",9,0)
 N IBRATYP
"RTN","IBCBB7",10,0)
 ;
"RTN","IBCBB7",11,0)
 ; ibrev1(rev cd,seq #)=Rev code^ptr cpt^unit chg^units^total^tot unc^^^mod ptrs
"RTN","IBCBB7",12,0)
 ; 3 subsection edits
"RTN","IBCBB7",13,0)
 ;
"RTN","IBCBB7",14,0)
 D F^IBCEF("N-BILL RATE TYPE","IBZ",,IBIFN)
"RTN","IBCBB7",15,0)
 ; Don't apply some edits unless specific rate types
"RTN","IBCBB7",16,0)
 S IBZ=$P($G(^DGCR(399.3,+IBZ,0)),U)
"RTN","IBCBB7",17,0)
 S IBRATYP=$S(IBZ="":1,IBZ["TRICARE"!(IBZ["CHAMPVA")!(IBZ["SHARING")!(IBZ["REIMBURS"):1,1:0)
"RTN","IBCBB7",18,0)
 S IBREVC=0 F  S IBREVC=$O(IBREV1(IBREVC)) Q:IBREVC=""  D  Q:IBQUIT
"RTN","IBCBB7",19,0)
 . S IBI=0
"RTN","IBCBB7",20,0)
 . F  S IBI=$O(IBREV1(IBREVC,IBI)) Q:'IBI  D  Q:IBQUIT
"RTN","IBCBB7",21,0)
 . . ;
"RTN","IBCBB7",22,0)
 . . S IBREVD=IBREV1(IBREVC,IBI),IBREVC12=$E(IBREVC,1,2),IBBCPT=$P(IBREVD,U,2)
"RTN","IBCBB7",23,0)
 . . ;
"RTN","IBCBB7",24,0)
 . . ; IB*2.0*447/TAZ Removed this error so that zero dollar revenue codes can process on the 837
"RTN","IBCBB7",25,0)
 . . ; No charge associated with rev code
"RTN","IBCBB7",26,0)
 . . ;I '$P(IBREVD,U,3),IBREVC12'=18 S IBQUIT=$$IBER^IBCBB3(.IBER,185) Q:IBQUIT
"RTN","IBCBB7",27,0)
 . . ;
"RTN","IBCBB7",28,0)
 . . ; Charges cannot be negative dollar amounts
"RTN","IBCBB7",29,0)
 . . I $P(IBREVD,U,5)<0 S IBQUIT=$$IBER^IBCBB3(.IBER,213) Q:IBQUIT
"RTN","IBCBB7",30,0)
 . . ;
"RTN","IBCBB7",31,0)
 . . ; Non Covered charges cannot be a negative amount
"RTN","IBCBB7",32,0)
 . . ;     and must not be > total charge
"RTN","IBCBB7",33,0)
 . . I $P(IBREVD,U,6)>$P(IBREVD,U,5)!($P(IBREVD,U,6)<0) S IBQUIT=$$IBER^IBCBB3(.IBER,214) Q:IBQUIT
"RTN","IBCBB7",34,0)
 . . ;
"RTN","IBCBB7",35,0)
 . . ; =====
"RTN","IBCBB7",36,0)
 . . ; Accommodation revenue code edits
"RTN","IBCBB7",37,0)
 . . I IBREV1(IBREVC)="AC" D  Q
"RTN","IBCBB7",38,0)
 . . . N IBBSEC
"RTN","IBCBB7",39,0)
 . . . ; dup Rev accom cds must have diff rates and bedsections
"RTN","IBCBB7",40,0)
 . . . S IBBSEC=$P($G(^DGCR(399,IBIFN,"RC",+$P(IBREVD,U,8),0)),U,5)
"RTN","IBCBB7",41,0)
 . . . I $O(IBREV1(IBREVC,1)) D  Q:IBQUIT
"RTN","IBCBB7",42,0)
 . . . . I IBI=1 K IBREVDUP S IBREVDUP(+$P(IBREVD,U,3)_" "_IBBSEC)=""
"RTN","IBCBB7",43,0)
 . . . . I IBI>1,$D(IBREVDUP(+$P(IBREVD,U,3)_" "_IBBSEC)) S IBQUIT=$$IBER^IBCBB3(.IBER,186)
"RTN","IBCBB7",44,0)
 . . . ; Total Line charges for accom rev codes can not be < 0
"RTN","IBCBB7",45,0)
 . . . I IBREVC>99,IBREVC<220,IBREVTOT("AC")<0 S IBQUIT=$$IBER^IBCBB3(.IBER,211)
"RTN","IBCBB7",46,0)
 . . . ; For accom rev codes, detail charge for revc=18x must be 0
"RTN","IBCBB7",47,0)
 . . . I IBREVC12=18,$P(IBREV1(IBREVC,IBI),U,3) S IBQUIT=$$IBER^IBCBB3(.IBER,212)
"RTN","IBCBB7",48,0)
 . . ;
"RTN","IBCBB7",49,0)
 . . ; =====
"RTN","IBCBB7",50,0)
 . . ; Inpatient Ancillary only Rev Codes edit 60-4
"RTN","IBCBB7",51,0)
 . . I IBREV1(IBREVC)="AI" D  Q
"RTN","IBCBB7",52,0)
 . . . ; Cannot have dup anc REV codes except 24X
"RTN","IBCBB7",53,0)
 . . . N IBMOD
"RTN","IBCBB7",54,0)
 . . . S IBMOD=$P(IBREVD,U,9)
"RTN","IBCBB7",55,0)
 . . . ;I IBRATYP,IBI>1,IBREVC12'=24 S IBQUIT=$$IBER^IBCBB3(.IBER,188)
"RTN","IBCBB7",56,0)
 . . . ;
"RTN","IBCBB7",57,0)
 . . . ;HCPCS code is required for rev code 636 and TOB 13X, 14X, 83X
"RTN","IBCBB7",58,0)
 . . . I IBREVC=636,IBBCPT="",(IBTOB12=13!(IBTOB12=14)!(IBTOB12=83)) S IBQUIT=$$IBER^IBCBB3(.IBER,191)
"RTN","IBCBB7",59,0)
 . . . ;
"RTN","IBCBB7",60,0)
 . . ; =====
"RTN","IBCBB7",61,0)
 . . ; OUTPATIENT ANCILLARY only Rev Codes edit rec 61-04
"RTN","IBCBB7",62,0)
 . . I IBREV1(IBREVC)="AO" D  Q
"RTN","IBCBB7",63,0)
 . . . ;
"RTN","IBCBB7",64,0)
 . . . ; Rev codes with different HCPCS codes can be duplicated
"RTN","IBCBB7",65,0)
 . . . I $$FT^IBCEF(IBIFN)=3,$O(IBREV1(IBREVC,1))  D  Q:IBQUIT
"RTN","IBCBB7",66,0)
 . . . . N IBMOD
"RTN","IBCBB7",67,0)
 . . . . S IBMOD=$P(IBREVD,U,9)
"RTN","IBCBB7",68,0)
 . . . . I IBI=1 K IBREVDUP S IBREVDUP(IBBCPT_" "_IBMOD)=""
"RTN","IBCBB7",69,0)
 . . . . I '$$ISRX^IBCEF1(IBIFN),IBI>1,$D(IBREVDUP(IBBCPT_" "_IBMOD)),IBER'["IB192;" S IBQUIT=$$IBER^IBCBB3(.IBER,192)
"RTN","IBCBB7",70,0)
 . . . ;
"RTN","IBCBB7",71,0)
 . . . ; Rev Code 49x can not be entered with 36x and 37x
"RTN","IBCBB7",72,0)
 . . . I IBREVC12=49,$O(IBREV1(380),-1)'<360 S IBQUIT=$$IBER^IBCBB3(.IBER,195) Q:IBQUIT
"RTN","IBCBB7",73,0)
 . . . ;
"RTN","IBCBB7",74,0)
 . . . ; If Rev=42x & billtype=83x!13x req occ cds 11&35 and val code 50
"RTN","IBCBB7",75,0)
 . . . ;I IBREVC12=42,(IBTOB12=83!(IBTOB12=13)) D  Q:IBQUIT
"RTN","IBCBB7",76,0)
 . . . ;. I '$D(IBVALCD(50))!'$D(IBOCCD(11))!'$D(IBOCCD(35)) S IBQUIT=$$IBER^IBCBB3(.IBER,196)
"RTN","IBCBB7",77,0)
 . . . ;
"RTN","IBCBB7",78,0)
 . . . ; If Rev=43x & billtype=83x!13x req occ cds 11&44 and val code 51
"RTN","IBCBB7",79,0)
 . . . ;I IBREVC12=43,(IBTOB12=83!(IBTOB12=13)) D
"RTN","IBCBB7",80,0)
 . . . ;. I '$D(IBVALCD(51))!'$D(IBOCCD(11))!'$D(IBOCCD(44)) S IBQUIT=$$IBER^IBCBB3(.IBER,197)
"RTN","IBCBB7",81,0)
 . . . ;
"RTN","IBCBB7",82,0)
 . . . ; If Rev=44x & billtype=83x!13x req occ cds 11&45 and val code 52
"RTN","IBCBB7",83,0)
 . . . ;I IBREVC12=44,(IBTOB12=83!(IBTOB12=13)) D
"RTN","IBCBB7",84,0)
 . . . ;. I '$D(IBVALCD(52))!'$D(IBOCCD(11))!'$D(IBOCCD(45)) S IBQUIT=$$IBER^IBCBB3(.IBER,198)
"RTN","IBCBB7",85,0)
 . . . ;
"RTN","IBCBB7",86,0)
 . . . ; If Rev=943 & billtype=83x!13x req occ cds 11&46 and val code 53
"RTN","IBCBB7",87,0)
 . . . ;I IBREVC=943,(IBTOB12=83!IBTOB12=13) D
"RTN","IBCBB7",88,0)
 . . . ;. I '$D(IBVALCD(53))!('$D(IBOCCD(11)))!('$D(IBOCCD(46))) S IBQUIT=$$IBER^IBCBB3(.IBER,199)
"RTN","IBCBB7",89,0)
 . . . ;
"RTN","IBCBB7",90,0)
 . . . ; If Rev=403 & bill type=14x!23x and service date >= 01-01-91
"RTN","IBCBB7",91,0)
 . . . ;   require only HCPCS codes 76092 and no other rev codes
"RTN","IBCBB7",92,0)
 . . . I IBREVC=403,IBFDT'<2910101,(IBTOB12=14!(IBTOB12=23)) D
"RTN","IBCBB7",93,0)
 . . . . I $O(IBREV1(403))!$O(IBREV1(403),-1)!(IBBCPT'=76092) S IBQUIT=$$IBER^IBCBB3(.IBER,194) Q
"RTN","IBCBB7",94,0)
 . . . ;
"RTN","IBCBB7",95,0)
 . . . ; If Rev=401 & bill type=13x!14x!23x!71x allow only HCPSCS codes
"RTN","IBCBB7",96,0)
 . . . ;   76090 or 78091
"RTN","IBCBB7",97,0)
 . . . ;I IBREVC=401,(IBTOB12=13!(IBTOB12=14)!(IBTOB12=23)!(IBTOB12=71)),IBBCPT'="",IBBCPT'=76090,IBBCPT'=78091 S IBQUIT=$$IBER^IBCBB3(.IBER,201)
"RTN","IBCBB7",98,0)
 . . . ;
"RTN","IBCBB7",99,0)
 . . . ; Rev code cannot equal 227 or 29x
"RTN","IBCBB7",100,0)
 . . . ;I IBREVC=227!(IBREVC12=29) S IBQUIT=$$IBER^IBCBB3(.IBER,202)
"RTN","IBCBB7",101,0)
 . . . D REVC^IBCBB7A(IBREVD,IBREVC,IBBCPT,IBREVC12,.IBER)
"RTN","IBCBB7",102,0)
 Q:IBQUIT
"RTN","IBCBB7",103,0)
 ;
"RTN","IBCBB7",104,0)
 D ^IBCBB8
"RTN","IBCBB7",105,0)
 Q
"RTN","IBCC")
0^42^B57603103
"RTN","IBCC",1,0)
IBCC ;ALB/MJB - CANCEL THIRD PARTY BILL ;14 JUN 88  10:12
"RTN","IBCC",2,0)
 ;;2.0;INTEGRATED BILLING;**2,19,77,80,51,142,137,161,199,241,155,276,320,358,433,432,447**;21-MAR-94;Build 80
"RTN","IBCC",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCC",4,0)
 ;
"RTN","IBCC",5,0)
 ;MAP TO DGCRC
"RTN","IBCC",6,0)
 ;
"RTN","IBCC",7,0)
 I '$D(IBCAN) S IBCAN=1
"RTN","IBCC",8,0)
ASK ;
"RTN","IBCC",9,0)
 ;***
"RTN","IBCC",10,0)
 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBCC" D T1^%ZOSV ;stop rt clock
"RTN","IBCC",11,0)
 ;S XRTL=$ZU(0),XRTN="IBCC-1" D T0^%ZOSV ;start rt clock
"RTN","IBCC",12,0)
 ;
"RTN","IBCC",13,0)
 ; If called at entry point PROCESS, variable IBNOASK will exist.
"RTN","IBCC",14,0)
 ; First time through, IBNOASK=1
"RTN","IBCC",15,0)
 ; Second time through, IBNOASK=2 and it will quit
"RTN","IBCC",16,0)
 I $G(IBNOASK)=2 G Q
"RTN","IBCC",17,0)
 I $G(IBNOASK)=1 S IBNOASK=2
"RTN","IBCC",18,0)
 ;
"RTN","IBCC",19,0)
 G Q:$G(IBCE("EDI"))
"RTN","IBCC",20,0)
 D Q
"RTN","IBCC",21,0)
 S IBQUIT=0
"RTN","IBCC",22,0)
 N DPTNOFZY S DPTNOFZY=1  ;Suppress PATIENT file fuzzy lookups
"RTN","IBCC",23,0)
 I '$G(IBNOASK) S DIC="^DGCR(399,",DIC(0)="AEMQZ",DIC("A")="Enter BILL NUMBER or Patient NAME: " W !! D ^DIC I Y<1 S IBQUIT=1 G Q1
"RTN","IBCC",24,0)
 K IB364
"RTN","IBCC",25,0)
NOPTF ; Note if IB364 is >0 it will be used as the ien to update in file 364
"RTN","IBCC",26,0)
 N DA,I
"RTN","IBCC",27,0)
 I '$G(IBNOASK) S IBIFN=+$G(Y)
"RTN","IBCC",28,0)
 I '$G(IBIFN) G ASK
"RTN","IBCC",29,0)
 I IBCAN>1 D NOPTF^IBCB2 I 'IBAC1 D NOPTF1^IBCB2 G ASK
"RTN","IBCC",30,0)
 ;
"RTN","IBCC",31,0)
 I $G(IBCNCRD)=1,$P($P($G(^DGCR(399,IBIFN,0)),U),"-",2)>98 D  Q
"RTN","IBCC",32,0)
 .W !!,"Please note that you have exceeded the maximum number of iterations (99) for this claim."
"RTN","IBCC",33,0)
 .W "Copy and cancel (CLON) must be used to correct this bill."
"RTN","IBCC",34,0)
 .S IBQUIT=1 H 3
"RTN","IBCC",35,0)
 ; Check if bill has been referred to Counsel
"RTN","IBCC",36,0)
 I $P($G(^PRCA(430,IBIFN,6)),U,4) D  G ASK
"RTN","IBCC",37,0)
 . W !,"This bill has been referred to Regional Counsel and cannot be 'CANCELLED' in"
"RTN","IBCC",38,0)
 . W !,"Integrated Billing.  Please use the option 'TP Referred Follow-up'"
"RTN","IBCC",39,0)
 . W !,"[PRCA RC ACTION MENU] in Accounts Receivable to request that Regional"
"RTN","IBCC",40,0)
 . W !,"Counsel return the bill to your facility."
"RTN","IBCC",41,0)
 . Q
"RTN","IBCC",42,0)
 ;
"RTN","IBCC",43,0)
 F I=0,"S","U1" S IB(I)=$G(^DGCR(399,IBIFN,I))
"RTN","IBCC",44,0)
 S IBSTAT=$P(IB(0),U,13)
"RTN","IBCC",45,0)
 ; REMOVE New messages for CRD option IB*2.0*433 in IB*2.0*447  IA#5630
"RTN","IBCC",46,0)
 ;I $G(IBCNCRD)=1,IBSTAT'=2,'$$ACCK^PRCAACC(IBIFN) D  Q
"RTN","IBCC",47,0)
 ;.W !!,"This option cannot be used to correct some Billing Rate Types (Example: TRICARE)"
"RTN","IBCC",48,0)
 ;.W "Copy and cancel (CLON) must be used to correct this bill."
"RTN","IBCC",49,0)
 ;.S IBQUIT=1 H 3
"RTN","IBCC",50,0)
 ;
"RTN","IBCC",51,0)
 ; Restrict access to this process for REQUEST MRA bills
"RTN","IBCC",52,0)
 I IBSTAT=2,'$G(IBCE("EDI")),$$MRAWL^IBCEMU2(IBIFN) D  G ASK
"RTN","IBCC",53,0)
 . W !!?4,"This bill is in a status of REQUEST MRA and it does appear on the"
"RTN","IBCC",54,0)
 . W !?4,"MRA Management Work List.  Please use the 'MRA Management Menu' options"
"RTN","IBCC",55,0)
 . W !?4,"for all processing related to this bill."
"RTN","IBCC",56,0)
 . Q
"RTN","IBCC",57,0)
 ;
"RTN","IBCC",58,0)
 ; IB*2.0*432 Restrict access to claims on the new CBW Worklist
"RTN","IBCC",59,0)
 I $P($G(^DGCR(399,IBIFN,"S1")),U,7)=1,$G(IBMRANOT)'=1 D  G ASK
"RTN","IBCC",60,0)
 . W !!?4,"This bill appears on the CBW Management Work List.  Please use the"
"RTN","IBCC",61,0)
 . W !?4,"'CBW Management Menu' options for all processing related to this bill."
"RTN","IBCC",62,0)
 . Q
"RTN","IBCC",63,0)
 ;
"RTN","IBCC",64,0)
 ; Check if this is a paper claim. If not, check for split EOB.  If split, don't allow CRD unless more than 1 EOB has been returned
"RTN","IBCC",65,0)
 I $G(IBCNCRD)=1,$P($G(^DGCR(399,IBIFN,"TX")),U,8)'=1,$$SPLTMRA^IBCEMU1(IBIFN)=1 D  Q
"RTN","IBCC",66,0)
 .W !!,"There is a split EOB associated with this claim.  You cannot use this option to Correct this claim until the second EOB has been received."
"RTN","IBCC",67,0)
 .S IBQUIT=1 H 3
"RTN","IBCC",68,0)
 .Q
"RTN","IBCC",69,0)
 ;
"RTN","IBCC",70,0)
 ; Warning message if in a REQUEST MRA status with no MRA on file
"RTN","IBCC",71,0)
 I IBSTAT=2,'$$MRACNT^IBCEMU1(IBIFN) D
"RTN","IBCC",72,0)
 . N REJ
"RTN","IBCC",73,0)
 . D TXSTS^IBCEMU2(IBIFN,,.REJ)
"RTN","IBCC",74,0)
 . W *7,!!?4,"Warning!  This bill is in a status of REQUEST MRA."
"RTN","IBCC",75,0)
 . W !?4,"No MRAs have been received"
"RTN","IBCC",76,0)
 . I REJ W ", but the most recent transmission of this",!?4,"MRA request bill was rejected."
"RTN","IBCC",77,0)
 . I 'REJ W " and there are no rejection messages on file",!?4,"for the most recent transmission of this MRA request bill."
"RTN","IBCC",78,0)
 . Q
"RTN","IBCC",79,0)
 ;
"RTN","IBCC",80,0)
 I IBCAN=2,IB("S")]"",+$P(IB("S"),U,16),$P(IB("S"),U,17)]"" D  G 1
"RTN","IBCC",81,0)
 . W !!,"This bill was cancelled on " S Y=$P(IB("S"),U,17) X ^DD("DD") W Y," by ",$S($P(IB("S"),U,18)']"":IBU,$D(^VA(200,$P(IB("S"),U,18),0)):$P(^(0),U,1),1:IBU),"."
"RTN","IBCC",82,0)
 . S IBQUIT=1
"RTN","IBCC",83,0)
 ; Notify if a payment has been posted to this bill before cancel
"RTN","IBCC",84,0)
 N PRCABILL
"RTN","IBCC",85,0)
 S PRCABILL=$$TPR^PRCAFN(IBIFN)
"RTN","IBCC",86,0)
 I PRCABILL=-1 W !!,"Please note: PRCA was unable to determine if a payment has been posted." I $G(IBCNCRD)=1 W !,"Copy and cancel (CLON) must be used to correct this bill." S IBQUIT=1 H 3 Q
"RTN","IBCC",87,0)
 I PRCABILL>0 W !!,"Please note a PAYMENT of **$"_$$TPR^PRCAFN(IBIFN)_"** has been POSTED to this bill."
"RTN","IBCC",88,0)
 ; New message for CRD option
"RTN","IBCC",89,0)
 I $G(IBCNCRD)=1,PRCABILL>0 W !,"Copy and cancel (CLON) must be used to correct this bill." S IBQUIT=1 H 3 Q
"RTN","IBCC",90,0)
 ;
"RTN","IBCC",91,0)
 ; If bill was created via Electronic claims process then notify
"RTN","IBCC",92,0)
 ; user that cancellation should occur using ECME package
"RTN","IBCC",93,0)
 I $$GET1^DIQ(399,IBIFN_",",460)]"" D  G:'Y ASK
"RTN","IBCC",94,0)
 . W !!!?5,"This bill was created by the"
"RTN","IBCC",95,0)
 . W !?5,"Electronic Claims Management Engine (ECME)."
"RTN","IBCC",96,0)
 . W !?5,"Cancellation needs to occur in the ECME package by"
"RTN","IBCC",97,0)
 . W !?5,"submitting a REVERSAL to the Payer.",!!
"RTN","IBCC",98,0)
 . K DIR S DIR("A",1)="Has a REVERSAL for this e-Claim already been",DIR("A")="submitted to the payer via the ECME package (Y/N)",DIR(0)="Y",DIR("B")="NO" D ^DIR
"RTN","IBCC",99,0)
 . I Y=0 W !!,"<PLEASE SUBMIT A REVERSAL USING THE APPROPRIATE OPTION IN THE ECME PACKAGE>",$C(7)
"RTN","IBCC",100,0)
 ;
"RTN","IBCC",101,0)
CHK ;
"RTN","IBCC",102,0)
 ; if user came from CLON, make sure they know about the new CRD option  IB*2.0*447 remove TRICARE msg.
"RTN","IBCC",103,0)
 I $G(IBCNCOPY)=1 D
"RTN","IBCC",104,0)
 .W !!,*7,"Warning:  This option should NOT be used to correct Rejected/Denied claims."
"RTN","IBCC",105,0)
 .W !,"          It should ONLY be used to correct DENIED claims which have payments"
"RTN","IBCC",106,0)
 .W !,"          posted against them.***" ; and claims with certain Billing Rate Types (Example: TRICARE)."
"RTN","IBCC",107,0)
 ;
"RTN","IBCC",108,0)
 S (IBCCCC,IBQUIT)=0 I '$G(IBCEAUTO),'$G(IBMCSCAN) W !!,"ARE YOU SURE YOU WANT TO CANCEL THIS BILL" S %=2 D YN^DICN G:%=0 HELP I %'=1 S IBQUIT=1 G NO
"RTN","IBCC",109,0)
 ;
"RTN","IBCC",110,0)
 I '$G(IBCEAUTO) W !!,"LAST CHANCE TO CHANGE YOUR MIND..."
"RTN","IBCC",111,0)
 S DIE=399,DA=IBIFN,DIE("NO^")=""
"RTN","IBCC",112,0)
 S DR="16;S:'X Y=0;19;S IBCCCC=1;"
"RTN","IBCC",113,0)
 I $G(IBCEAUTO) S DR="16////1;19////EDI/MRA TURNED OFF;S IBCCCC=1;"
"RTN","IBCC",114,0)
 ;
"RTN","IBCC",115,0)
 ; esg - 8/23/06 - IB*2*358 - fix semi-colon in free text field
"RTN","IBCC",116,0)
 I $G(IBMCSRSC)'="" S DR="16;S:'X Y=0;19//^S X=IBMCSRSC;S IBCCCC=1;"
"RTN","IBCC",117,0)
 D ^DIE K DIE,DR
"RTN","IBCC",118,0)
 ;
"RTN","IBCC",119,0)
NO I 'IBCCCC W !!,"<NO ACTION TAKEN>",*7 S IBQUIT=1 G ASK:IBCAN<2,Q
"RTN","IBCC",120,0)
 S IBCCR=$P($G(^DGCR(399,IBIFN,"S")),U,19)
"RTN","IBCC",121,0)
 ; update claim # with new iteration  IB*2.0*447 move to later in the process
"RTN","IBCC",122,0)
 ;D:$G(IBCNCRD)=1 CRD
"RTN","IBCC",123,0)
 W !!,"...Bill has been cancelled..." D BULL^IBCBULL,BSTAT^IBCDC(IBIFN),PRIOR^IBCCC2(IBIFN)
"RTN","IBCC",124,0)
 ;
"RTN","IBCC",125,0)
 ; cancelling in ingenix claimsmanager if ingenix is running
"RTN","IBCC",126,0)
 ; clean-up of variables is OK if not coming in from ListMan screen
"RTN","IBCC",127,0)
 I $$CM^IBCIUT1(IBIFN) S IBCISNT=4 D ST2^IBCIST I '$G(IBCICNCL) K IBCISNT,IBCISTAT,IBCIREDT,IBCIERR
"RTN","IBCC",128,0)
 ;
"RTN","IBCC",129,0)
 S IBEDI=$G(IB364)
"RTN","IBCC",130,0)
 I 'IBEDI S IBEDI=+$$LAST364^IBCEF4(IBIFN)
"RTN","IBCC",131,0)
 I IBEDI D UPDEDI^IBCEM(IBEDI,"C") ;Update EDI files, if needed
"RTN","IBCC",132,0)
 ;
"RTN","IBCC",133,0)
 F I="S","U1" S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"")
"RTN","IBCC",134,0)
 S PRCASV("ARREC")=IBIFN,PRCASV("AMT")=$S(IB("U1")']"":0,1:$P(IB("U1"),"^")),PRCASV("DATE")=$P(IB("S"),"^",17),PRCASV("BY")=$P(IB("S"),"^",18)
"RTN","IBCC",135,0)
 S PRCASV("COMMENT")=$S($P(IB("S"),U,19)]"":$P(IB("S"),U,19),$P(^IBE(350.9,1,2),"^",7)]"":$P(^(2),"^",7),1:"BILL CANCELLED IN MAS")
"RTN","IBCC",136,0)
 S PRCASV("BY")=$S($P(IB("S"),U,18)]"":$P(IB("S"),U,18),1:"")
"RTN","IBCC",137,0)
 ; IA#3374/IB*2.0*433 Pass the CRD flag so FMS knows to send a cancel record before the new E record is sent
"RTN","IBCC",138,0)
 ;S X=$$CANCEL^RCBEIB($G(PRCASV("ARREC")),$G(PRCASV("DATE")),$G(PRCASV("BY")),$G(PRCASV("AMT")),$G(PRCASV("COMMENT")))
"RTN","IBCC",139,0)
 S PRCASV("ARCRD")=$G(IBCNCRD)
"RTN","IBCC",140,0)
 S X=$$CANCEL^RCBEIB($G(PRCASV("ARREC")),$G(PRCASV("DATE")),$G(PRCASV("BY")),$G(PRCASV("AMT")),$G(PRCASV("COMMENT")),$G(PRCASV("ARCRD")))
"RTN","IBCC",141,0)
 W !,$S(X:">> The receivable associated with the claim was cancelled.",1:">> The receivable associated with the claim was not cancelled.")
"RTN","IBCC",142,0)
 I $P(X,U,2)]"" W !,">>> ",$P(X,U,2) ; The reason why the claim can not be cancelled.
"RTN","IBCC",143,0)
 I IBCAN<2 D RNB^IBCC1 ;assign a reason not billable
"RTN","IBCC",144,0)
 G ASK:IBCAN<2,Q
"RTN","IBCC",145,0)
 ;
"RTN","IBCC",146,0)
HELP W !,?3,"Answer 'YES' or 'Y' if you wish to cancel this bill.",!,?3,"Answer 'NO' or 'N' if you want to abort." G CHK
"RTN","IBCC",147,0)
 Q
"RTN","IBCC",148,0)
1 I $P(IB(0),U,13)=1 W !,"This record was re-opened on " S Y=$P(IB(0),U,14) X ^DD("DD") W Y,"." G CHK
"RTN","IBCC",149,0)
 G ASK
"RTN","IBCC",150,0)
Q1 K:IBCAN=1 IBQUIT K IBCAN
"RTN","IBCC",151,0)
Q K %,IBEPAR,IBSTAT,IBARST,IBAC1,IB,DFN,IBX,IBZ,DIC,DIE,DR,PRCASV,PRCASVC,X,Y,IBEDI
"RTN","IBCC",152,0)
 ;***
"RTN","IBCC",153,0)
 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBCC" D T1^%ZOSV ;stop rt clock
"RTN","IBCC",154,0)
 Q
"RTN","IBCC",155,0)
CRD(IBIFN) ; entry to point to add iteration # to claim
"RTN","IBCC",156,0)
 N IBFDA
"RTN","IBCC",157,0)
 S IBITN=$$ITN^IBCCC(IBIFN)
"RTN","IBCC",158,0)
 S IBFDA(399,IBIFN_",",.01)=IBITN
"RTN","IBCC",159,0)
 D FILE^DIE("","IBFDA")
"RTN","IBCC",160,0)
 ; this will re-open the claim, so reset to cancelled
"RTN","IBCC",161,0)
 S DIE=399,DA=IBIFN
"RTN","IBCC",162,0)
 S DR="16////1"
"RTN","IBCC",163,0)
 D ^DIE K DIE,DR
"RTN","IBCC",164,0)
 Q
"RTN","IBCC",165,0)
 ;
"RTN","IBCC",166,0)
PROCESS(IBIFN,IBCAN) ;
"RTN","IBCC",167,0)
 ; Entry point when the bill number is already known.  Use this when
"RTN","IBCC",168,0)
 ; you just want to try to cancel this bill and this bill only.
"RTN","IBCC",169,0)
 ; Input:
"RTN","IBCC",170,0)
 ;   IBIFN - Internal bill# (Required)
"RTN","IBCC",171,0)
 ;   IBCAN - Cancel Flag (optional, defaults to 1 if not included)
"RTN","IBCC",172,0)
 ;
"RTN","IBCC",173,0)
 NEW IBNOASK
"RTN","IBCC",174,0)
 S IBNOASK=1
"RTN","IBCC",175,0)
 S IBCAN=$G(IBCAN,1)
"RTN","IBCC",176,0)
 G ASK
"RTN","IBCC",177,0)
 ;
"RTN","IBCC",178,0)
 ;IBCC
"RTN","IBCCC")
0^63^B20967189
"RTN","IBCCC",1,0)
IBCCC ;ALB/AAS - CANCEL AND CLONE A BILL ;25-JAN-90
"RTN","IBCCC",2,0)
 ;;2.0;INTEGRATED BILLING;**80,109,106,51,320,433,432,447**;21-MAR-94;Build 80
"RTN","IBCCC",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCCC",4,0)
 ;
"RTN","IBCCC",5,0)
 ;MAP TO DGCRCC
"RTN","IBCCC",6,0)
 ;
"RTN","IBCCC",7,0)
 ;STEP 1 - cancel bill
"RTN","IBCCC",8,0)
 ;STEP 1.5 - entry to clone previously cancelled bill.  (must be cancel)
"RTN","IBCCC",9,0)
 ;STEP 2 - build array of IBIDS call screen that asks ok
"RTN","IBCCC",10,0)
 ;STEP 3 - pass stub entry to ar
"RTN","IBCCC",11,0)
 ;STEP 4 - store stub data in MCCR then x-ref
"RTN","IBCCC",12,0)
 ;STEP 4.5 - store claim clone info on "S1" node.
"RTN","IBCCC",13,0)
 ;STEP 5 - get remainder of data to move and store in MCCR then x-ref
"RTN","IBCCC",14,0)
 ;STEP 6 - go to screens, come out to IBB1 
"RTN","IBCCC",15,0)
EN ;
"RTN","IBCCC",16,0)
 N IBBCF,IBBCT,IBBCB,IBCCR,IBDBC,IBCNCOPY
"RTN","IBCCC",17,0)
 S IBDBC=DT    ;date claim was cloned
"RTN","IBCCC",18,0)
 S IBBCB=DUZ   ;user-id of person cloning the claim.
"RTN","IBCCC",19,0)
 S IBCNCOPY=1 ; flag indicating this function is entered as the copy/cancel option
"RTN","IBCCC",20,0)
 ;
"RTN","IBCCC",21,0)
STEP1 I $G(IBCE("EDI"))>1 G END1
"RTN","IBCCC",22,0)
 S IBCAN=2,IBQUIT=0,IBAC=6,IBU="UNSPECIFIED"
"RTN","IBCCC",23,0)
 I '$G(IBCE("EDI")) D ASK^IBCC
"RTN","IBCCC",24,0)
 I $G(IBCE("EDI"))=1 S IB364="" D NOPTF^IBCC
"RTN","IBCCC",25,0)
 G:IBQUIT END1
"RTN","IBCCC",26,0)
 I 'IBCCCC!('$D(IBIFN)) G STEP1:'$G(IBCE("EDI")),END1
"RTN","IBCCC",27,0)
 I $G(IBCE("EDI")) S IBCE("EDI")=2
"RTN","IBCCC",28,0)
EN1 ;
"RTN","IBCCC",29,0)
STEP1P5 I '$D(IBIFN) S IBCAN=2,IBQUIT=0,IBAC=6 W !,"Copy Previously Cancelled Bill.",!! S DIC="^DGCR(399,",DIC("S")="I $P(^(0),U,13)=7",DIC(0)="AEMQZ",DIC("A")="Enter BILL NUMBER or Patient NAME: " D ^DIC G:Y<1 END S IBIFN=+Y
"RTN","IBCCC",30,0)
 ;
"RTN","IBCCC",31,0)
 S IBBCF=IBIFN    ;this is the claim we are copying FROM
"RTN","IBCCC",32,0)
 S IBIDS(.15)=IBIFN K IBIFN
"RTN","IBCCC",33,0)
STEP2 S IBND0=^DGCR(399,IBIDS(.15),0) I $D(^("U")) S IBNDU=^("U")
"RTN","IBCCC",34,0)
 ; *** Note - all these fields should also be included in WHERE^IBCCC1
"RTN","IBCCC",35,0)
 ; IB*2.0*432 added check of variable IBSILENT to allow COB copy in background mode
"RTN","IBCCC",36,0)
 F I=2:1:12 S:$P(IBND0,"^",I)]"" IBIDS(I/100)=$P(IBND0,"^",I)
"RTN","IBCCC",37,0)
 F I=16:1:19,21:1:27 S:$P(IBND0,"^",I)]"" IBIDS(I/100)=$P(IBND0,"^",I)
"RTN","IBCCC",38,0)
 F I=151,152,155 S IBIDS(I)=$P(IBNDU,"^",(I-150))
"RTN","IBCCC",39,0)
 S IBIDS(159.5)=$P(IBNDU,U,20)
"RTN","IBCCC",40,0)
 ; ***
"RTN","IBCCC",41,0)
 D:$G(IBSILENT)="" HOME^%ZIS
"RTN","IBCCC",42,0)
 S DFN=IBIDS(.02) D DEM^VADPT
"RTN","IBCCC",43,0)
 I +$G(IBCTCOPY)!$G(IBCE("EDI")) G STEP3
"RTN","IBCCC",44,0)
 D ^IBCA1
"RTN","IBCCC",45,0)
ASK S IBYN=0 W !!,"IS THE ABOVE INFORMATION CORRECT AS SHOWN" S %=1 D YN^DICN G END:%=2,STEP3:%=1 I % G END
"RTN","IBCCC",46,0)
 W !!?4,"YES - If this information is correct as shown and you wish to file the bill.",!?4,"NO  - If you wish to change this information prior to filing."
"RTN","IBCCC",47,0)
 W !?4,"'^' - Enter the up-arrow character to DELETE this Bill at this time." G ASK
"RTN","IBCCC",48,0)
 ;
"RTN","IBCCC",49,0)
STEP3 ;
"RTN","IBCCC",50,0)
 S PRCASV("SER")=$P($G(^IBE(350.9,1,1)),"^",14)
"RTN","IBCCC",51,0)
 S PRCASV("SITE")=$P($$SITE^VASITE,"^",3),IBNWBL="",PRCASV("ARCRD")=$G(IBCNCRD)
"RTN","IBCCC",52,0)
 ; IA#386 & 1992  If user came from CRD option, need to pass old bill # and claim ien, as well as new iteration number
"RTN","IBCCC",53,0)
 I $G(IBCNCRD)=1 D CRD^IBCC(IBBCF) S PRCASV("ARREC")=IBBCF,PRCASV("ARBIL")=PRCASV("SITE")_"-"_$P(IBITN,"-"),PRCASV("ARITN")=PRCASV("SITE")_"-"_IBITN
"RTN","IBCCC",54,0)
 W:$G(IBSILENT)="" !,"Passing bill to Accounts Receivable Module..." D SETUP^PRCASVC3 I $S($P(PRCASV("ARREC"),"^")=-1:1,$P(PRCASV("ARBIL"),"^")=-1:1,1:0) W:$G(IBSILENT)="" *7,"  ",$P(PRCASV("ARREC"),"^",2),$P(PRCASV("ARBIL"),"^",2) G END
"RTN","IBCCC",55,0)
 S IBIDS(.01)=$P(PRCASV("ARBIL"),"-",2),IBIDS(.17)=$S($D(IBIDS(.17)):IBIDS(.17),1:PRCASV("ARREC"))
"RTN","IBCCC",56,0)
 I '$G(IBCE("EDI")) W !,"Billing Record #",IBIDS(.01)," being established for '",VADM(1),"'..." S IBIDS(.02)=DFN,IBHV("IBIFN")=$S($G(IBIFN):IBIFN,1:$G(IBIDS(.15)))
"RTN","IBCCC",57,0)
 G ^IBCCC1 ;go to step4
"RTN","IBCCC",58,0)
 Q
"RTN","IBCCC",59,0)
 ;
"RTN","IBCCC",60,0)
END W:$G(IBSILENT)="" !!,"No Billing Record Set up.  You must manually enter the bill."
"RTN","IBCCC",61,0)
END1 K %,%DT,IBCAN,IBAC,IBND0,IBNDU,IBYN,IBCCCC,IBIFN,IB,IBA,IBNWBL,IBBT,IBIDS,IBU,I,J,VA,VADM,X,X1,X2,X3,X4,D,Y
"RTN","IBCCC",62,0)
 ;I '$G(IBQUIT),$S(+$G(IBCNCOPY):1,1:'$G(IBCE("EDI"))) G STEP1
"RTN","IBCCC",63,0)
 I '$G(IBQUIT),$S(+$G(IBCNCOPY)!(+$G(IBCNCRD)):1,1:'$G(IBCE("EDI"))) G STEP1
"RTN","IBCCC",64,0)
 K IBQUIT,IBCNCOPY,IBCNCRD
"RTN","IBCCC",65,0)
 Q
"RTN","IBCCC",66,0)
 ;
"RTN","IBCCC",67,0)
ITN(IBX) ; determine iteration # for rejected or denied claim
"RTN","IBCCC",68,0)
 N IBCF,IBCL
"RTN","IBCCC",69,0)
 S IBCF=$P($G(^DGCR(399,IBX,"S1")),U,2)
"RTN","IBCCC",70,0)
 ; if this claim has never been cloned, iteration # is -01
"RTN","IBCCC",71,0)
 Q:IBCF="" $P($G(^DGCR(399,IBX,0)),U)_"-01"
"RTN","IBCCC",72,0)
 S IBCL=$P($G(^DGCR(399,IBCF,0)),U)
"RTN","IBCCC",73,0)
 ; if claim was a CLON 1st and now a CORRECT, this is the 1st iteration
"RTN","IBCCC",74,0)
 I $P(IBCL,"-")'=$P($P($G(^DGCR(399,IBX,0)),U),"-") Q $P($G(^DGCR(399,IBX,0)),U)_"-01"
"RTN","IBCCC",75,0)
 ; to determine iteration#, need to incriment from claim that was cloned from
"RTN","IBCCC",76,0)
 S IBITN=$P(IBCL,"-",2),IBITN=IBITN+1 I $L(IBITN)=1 S IBITN="0"_IBITN
"RTN","IBCCC",77,0)
 Q $P(IBCL,"-")_"-"_IBITN
"RTN","IBCCC",78,0)
 ;
"RTN","IBCCC",79,0)
CRD ; new entry point if user comes from CRD option instead of CLON  
"RTN","IBCCC",80,0)
 N IBBCF,IBBCT,IBBCB,IBCCR,IBDBC,IBCNCRD,IBITN
"RTN","IBCCC",81,0)
 S IBDBC=DT    ;date claim was cloned
"RTN","IBCCC",82,0)
 S IBBCB=DUZ   ;user-id of person cloning the claim.
"RTN","IBCCC",83,0)
 S IBCNCRD=1 ; flag indicating this function is entered as the CRD option
"RTN","IBCCC",84,0)
 G STEP1
"RTN","IBCCC",85,0)
 Q
"RTN","IBCCC",86,0)
 ;
"RTN","IBCCC2")
0^24^B108841715
"RTN","IBCCC2",1,0)
IBCCC2 ;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;6/6/03 9:56am
"RTN","IBCCC2",2,0)
 ;;2.0;INTEGRATED BILLING;**80,106,124,138,51,151,137,161,182,211,245,155,296,320,348,349,371,400,433,432,447**;21-MAR-94;Build 80
"RTN","IBCCC2",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCCC2",4,0)
 ;
"RTN","IBCCC2",5,0)
 ;MAP TO DGCRCC2
"RTN","IBCCC2",6,0)
 ;
"RTN","IBCCC2",7,0)
 ;STEP 5 - get remainder of data to move and store in MCCR then x-ref
"RTN","IBCCC2",8,0)
 ;STEP 6 - go to screens, come out to IBB1 or something like that
"RTN","IBCCC2",9,0)
 ;
"RTN","IBCCC2",10,0)
STEP5 S IBIFN1=$P(^DGCR(399,IBIFN,0),"^",15) G END:$S(IBIFN1="":1,'$D(^DGCR(399,IBIFN1,0)):1,1:0)
"RTN","IBCCC2",11,0)
 ; NOTE:  any new or changed data nodes may also need to be updated in IBNCPDP5
"RTN","IBCCC2",12,0)
 ;move pure data nodes
"RTN","IBCCC2",13,0)
 F I="I1","I2","I3","M1" I $D(^DGCR(399,IBIFN1,I)) S ^DGCR(399,IBIFN,I)=^DGCR(399,IBIFN1,I)
"RTN","IBCCC2",14,0)
 ;
"RTN","IBCCC2",15,0)
 ;move top level data node. ;Do not move 'TX' node EXCEPT piece 8 (added with IB*2.0*432)
"RTN","IBCCC2",16,0)
 ;F I="U","U1","U2","U3","UF2","UF3","UF31","C","M" I $D(^DGCR(399,IBIFN1,I)) S IBND(I)=^(I) D @I
"RTN","IBCCC2",17,0)
 ; add new data nodes introduced with IB*2.0*432
"RTN","IBCCC2",18,0)
 F I="TX","U","U1","U2","U3","U4","U5","U6","U7","U8","UF2","UF3","UF31","UF32","C","M" I $D(^DGCR(399,IBIFN1,I)) S IBND(I)=^(I) D @I
"RTN","IBCCC2",19,0)
 ;
"RTN","IBCCC2",20,0)
 ;move multiple level data
"RTN","IBCCC2",21,0)
 ;F I="CC","OC","OP","OT","RC","CP","CV","PRV" I $D(^DGCR(399,IBIFN1,I,0)) D @I
"RTN","IBCCC2",22,0)
 ; add new data nodes introduced with IB*2.0*447 BI
"RTN","IBCCC2",23,0)
 F I="CC","OC","OP","OT","RC","CP","CV","PRV","U9" I $D(^DGCR(399,IBIFN1,I,0)) D @I
"RTN","IBCCC2",24,0)
 ;
"RTN","IBCCC2",25,0)
 ; IB*2.0*432  ADDED IBSILENT flag so that this can be processed in background
"RTN","IBCCC2",26,0)
 D FTPRV^IBCEU5(IBIFN,$G(IBSILENT)) ; Ask change prov type if form type not the same
"RTN","IBCCC2",27,0)
 D COBCHG(IBIFN,,.IBCOB)
"RTN","IBCCC2",28,0)
 ;
"RTN","IBCCC2",29,0)
 D ^IBCCC3 ; copy table files (362.3)
"RTN","IBCCC2",30,0)
 ;
"RTN","IBCCC2",31,0)
 S I=$G(^DGCR(399,IBIFN1,0)) I $P(I,U,13)=7,$P(I,U,20)=1 D COPYB^IBCDC(IBIFN1,IBIFN) ; update auto bill files
"RTN","IBCCC2",32,0)
 D PRIOR(IBIFN) ; add new bill to previous bills in series, primary/secondary
"RTN","IBCCC2",33,0)
 ;
"RTN","IBCCC2",34,0)
 I +$G(IBCTCOPY) N IBAUTO S IBAUTO=1 D PROC^IBCU7A(IBIFN),BILL^IBCRBC(IBIFN),CPTMOD26^IBCU73(IBIFN) D RECALL^DILFD(399,IBIFN_",",DUZ) G END
"RTN","IBCCC2",35,0)
 ;
"RTN","IBCCC2",36,0)
STEP6 N IBGOEND
"RTN","IBCCC2",37,0)
 ; need to kill CRD flag prior to entering billing screens in case a copy for corresponding claim is needed
"RTN","IBCCC2",38,0)
 K IBCNCRD
"RTN","IBCCC2",39,0)
 ; don't call IB bill edit screens if this is non-MRA background processing
"RTN","IBCCC2",40,0)
 I $G(IBSTSM)=1 G END
"RTN","IBCCC2",41,0)
 I '$G(IBCE("EDI"))!$G(IBCE("EDI","NEW")),'$G(IBCEAUTO) D IBSCEDT G END:$G(IBGOEND)
"RTN","IBCCC2",42,0)
 ;
"RTN","IBCCC2",43,0)
 ;
"RTN","IBCCC2",44,0)
END K DFN,IB,IBA,IBA2,IBAD,IBADD1,IBBNO,IBCAN,IBCCC,IBDA,IBDPT,IBDR,IBDT,IBI,IBI1,IBIDS,IBIFN,IBIFN1,IBND,IBQUIT,IBU,IBUN,IBARST,IBCOB,IBCNCOPY,IBCBCOPY,IBCNCRD,IBKEY
"RTN","IBCCC2",45,0)
 K IBV,IBV1,IBW,IBWW,IBYN,IBZZ,PRCASV,PRCAERCD,PRCAERR,PRCASVC,PRCAT,IBBT,IBCH,IBNDS,IBOA,IBREV,IBX,DGXRF1,VAEL,VAERR,IBAC,IBCCC,IBDD1,IBIN,DGREV,DGREV00,DGREVHDR,IBCHK
"RTN","IBCCC2",46,0)
 K IBBS,IBLS,DGPCM,IBIP,IBND0,IBNDU,IBO,IBPTF,IBST,IBUC,IBDD,D,%,%DT,DIC,VA,VADM,X,X1,X2,X3,X4,Y,I,J,K,DGRVRCAL,DDH,DGACTDT,DGAMNT,DGBR,DGBRN,DGBSI,DGBSLOS,IBA1,IBOD,IBINS,IBN,IBPROC,DGFUNC,DGIFN
"RTN","IBCCC2",47,0)
 Q
"RTN","IBCCC2",48,0)
 ;
"RTN","IBCCC2",49,0)
 ;
"RTN","IBCCC2",50,0)
IBSCEDT ; call the IB bill edit screens and validate the data
"RTN","IBCCC2",51,0)
 N IBV,IBPAR,IBAC,IBHV,IBH,IBCIREDT
"RTN","IBCCC2",52,0)
 ; if the user came from CBW->PC and this is a non-MRA claim w/a paper EOB, set force print flag IB*2.0*432
"RTN","IBCCC2",53,0)
 ; also, if the user came from CBW->PC and this is a non-MRA claim and the only EEOB we have has filing errors, set force print flag
"RTN","IBCCC2",54,0)
 I $G(IBMRANOT)=1,$$COBN^IBCEF(IBIFN)>1,$G(IBFROM)=2 D 
"RTN","IBCCC2",55,0)
 .I $G(IBDA)="" D FORCEPRT^IBCAPP($G(IBIFN)) Q
"RTN","IBCCC2",56,0)
 .I $D(^IBM(361.1,IBDA,"ERR")) D FORCEPRT^IBCAPP($G(IBIFN)) Q
"RTN","IBCCC2",57,0)
 D RECALL^DILFD(399,IBIFN_",",DUZ)
"RTN","IBCCC2",58,0)
ST1 S IBV=0 D ^IBCSCU,^IBCSC1 I $G(IBPOPOUT) S IBGOEND=1 G IBSCX
"RTN","IBCCC2",59,0)
 S IBAC=1
"RTN","IBCCC2",60,0)
 D ^IBCB1
"RTN","IBCCC2",61,0)
 I $G(IBCIREDT) G ST1
"RTN","IBCCC2",62,0)
IBSCX ;
"RTN","IBCCC2",63,0)
 Q
"RTN","IBCCC2",64,0)
 ;
"RTN","IBCCC2",65,0)
 ;
"RTN","IBCCC2",66,0)
TX F J=8 I $P(IBND("TX"),"^",J)]"" S $P(^DGCR(399,IBIFN,"TX"),"^",J)=$P(IBND("TX"),"^",J)
"RTN","IBCCC2",67,0)
 Q
"RTN","IBCCC2",68,0)
U F J=3,4,6:1:17,20 I $P(IBND("U"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U"),"^",J)=$P(IBND("U"),"^",J)
"RTN","IBCCC2",69,0)
 Q
"RTN","IBCCC2",70,0)
U1 F J=1:1:3,15 I $P(IBND("U1"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U1"),"^",J)=$P(IBND("U1"),"^",J)
"RTN","IBCCC2",71,0)
 Q
"RTN","IBCCC2",72,0)
U2 F J=1:1:19 I $P(IBND("U2"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U2"),"^",J)=$P(IBND("U2"),"^",J)
"RTN","IBCCC2",73,0)
 Q
"RTN","IBCCC2",74,0)
U3 F J=1:1:11 I $P(IBND("U3"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U3"),"^",J)=$P(IBND("U3"),"^",J)
"RTN","IBCCC2",75,0)
 Q
"RTN","IBCCC2",76,0)
UF2 F J=1,3 I $P(IBND("UF2"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF2"),"^",J)=$P(IBND("UF2"),"^",J)
"RTN","IBCCC2",77,0)
 Q
"RTN","IBCCC2",78,0)
UF3 F J=4:1:6 I $P(IBND("UF3"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF3"),"^",J)=$P(IBND("UF3"),"^",J)
"RTN","IBCCC2",79,0)
 Q
"RTN","IBCCC2",80,0)
U4 F J=1:1:14 I $P(IBND("U4"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U4"),"^",J)=$P(IBND("U4"),"^",J)
"RTN","IBCCC2",81,0)
 Q
"RTN","IBCCC2",82,0)
U5 F J=1:1:6 I $P(IBND("U5"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U5"),"^",J)=$P(IBND("U5"),"^",J)
"RTN","IBCCC2",83,0)
 Q
"RTN","IBCCC2",84,0)
U6 F J=1:1:6 I $P(IBND("U6"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U6"),"^",J)=$P(IBND("U6"),"^",J)
"RTN","IBCCC2",85,0)
 Q
"RTN","IBCCC2",86,0)
U7 F J=1:1:5 I $P(IBND("U7"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U7"),"^",J)=$P(IBND("U7"),"^",J)
"RTN","IBCCC2",87,0)
 Q
"RTN","IBCCC2",88,0)
U8 F J=1:1:3 I $P(IBND("U8"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U8"),"^",J)=$P(IBND("U8"),"^",J)
"RTN","IBCCC2",89,0)
 Q
"RTN","IBCCC2",90,0)
UF31 F J=3 I $P(IBND("UF31"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF31"),"^",J)=$P(IBND("UF31"),"^",J)
"RTN","IBCCC2",91,0)
 Q
"RTN","IBCCC2",92,0)
UF32 F J=1:1:3 I $P(IBND("UF32"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF32"),"^",J)=$P(IBND("UF32"),"^",J)
"RTN","IBCCC2",93,0)
 Q
"RTN","IBCCC2",94,0)
C F J=10 I $P(IBND("C"),"^",J)]"" S $P(^DGCR(399,IBIFN,"C"),"^",J)=$P(IBND("C"),"^",J)
"RTN","IBCCC2",95,0)
 I '$D(^DGCR(399,IBIFN1,"CP")) D CP1
"RTN","IBCCC2",96,0)
 Q
"RTN","IBCCC2",97,0)
M F J=1:1:9,11:1:14 I $P(IBND("M"),"^",J)]"" S $P(^DGCR(399,IBIFN,"M"),"^",J)=$P(IBND("M"),"^",J)
"RTN","IBCCC2",98,0)
 Q
"RTN","IBCCC2",99,0)
CC S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
"RTN","IBCCC2",100,0)
 S IBDD=399.04 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
"RTN","IBCCC2",101,0)
OP S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
"RTN","IBCCC2",102,0)
 S IBDD=399.043 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
"RTN","IBCCC2",103,0)
 Q
"RTN","IBCCC2",104,0)
OC S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
"RTN","IBCCC2",105,0)
 S IBDD=399.041 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
"RTN","IBCCC2",106,0)
 Q
"RTN","IBCCC2",107,0)
OT S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
"RTN","IBCCC2",108,0)
 S IBDD=399.048 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
"RTN","IBCCC2",109,0)
 Q
"RTN","IBCCC2",110,0)
CV ; Don't copy value codes from inpatient inst to inpatient prof bills
"RTN","IBCCC2",111,0)
 I $$FT^IBCEF(IBIFN1)'=2,$$FT^IBCEF(IBIFN)=2 Q
"RTN","IBCCC2",112,0)
 S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
"RTN","IBCCC2",113,0)
 S IBDD=399.047 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
"RTN","IBCCC2",114,0)
 Q
"RTN","IBCCC2",115,0)
RC S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
"RTN","IBCCC2",116,0)
 S IBDD=399.042 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) S IBND("RC")=^(0) F K=1:1:16 S $P(^DGCR(399,IBIFN,I,J,0),"^",K)=$P(IBND("RC"),"^",K),X=$P(IBND("RC"),"^",K)
"RTN","IBCCC2",117,0)
 Q
"RTN","IBCCC2",118,0)
CP S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
"RTN","IBCCC2",119,0)
 I +$G(IBNOCPT) Q
"RTN","IBCCC2",120,0)
 S IBDD=399.0304 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) S IBND("CP")=^(0),IBND("CP1")=$G(^(1)),IBND("CP-AUX")=$G(^("AUX")) D
"RTN","IBCCC2",121,0)
 . F K=1:1:7,9:1:14,16:1:22 S $P(^DGCR(399,IBIFN,I,J,0),"^",K)=$P(IBND("CP"),"^",K)
"RTN","IBCCC2",122,0)
 . ; IB*2.0*432 add new 1 node
"RTN","IBCCC2",123,0)
 . F K=1:1:5 S $P(^DGCR(399,IBIFN,I,J,1),"^",K)=$P(IBND("CP1"),"^",K)
"RTN","IBCCC2",124,0)
 . ; esg - 11/2/06 - IB*2*348 - 50.09 field was added - AUX piece [9]
"RTN","IBCCC2",125,0)
 . I IBND("CP-AUX")'="" F K=1:1:9 S $P(^DGCR(399,IBIFN,I,J,"AUX"),"^",K)=$P(IBND("CP-AUX"),"^",K)
"RTN","IBCCC2",126,0)
 . ; IB*2.0*432 add new LNPRV multiple
"RTN","IBCCC2",127,0)
 . I $D(^DGCR(399,IBIFN1,I,J,"LNPRV",0)) S ^DGCR(399,IBIFN,I,J,"LNPRV",0)=^DGCR(399,IBIFN1,I,J,"LNPRV",0) D
"RTN","IBCCC2",128,0)
 .. S K=0 F  S K=$O(^DGCR(399,IBIFN1,I,J,"LNPRV",K)) Q:'K  D
"RTN","IBCCC2",129,0)
 ... S ^DGCR(399,IBIFN,I,J,"LNPRV",K,0)=^DGCR(399,IBIFN1,I,J,"LNPRV",K,0)
"RTN","IBCCC2",130,0)
 . I $D(^DGCR(399,IBIFN1,I,J,"MOD",0)) S ^DGCR(399,IBIFN,I,J,"MOD",0)=^DGCR(399,IBIFN1,I,J,"MOD",0) D
"RTN","IBCCC2",131,0)
 .. S K=0 F  S K=$O(^DGCR(399,IBIFN1,I,J,"MOD",K)) Q:'K  D
"RTN","IBCCC2",132,0)
 ... I $G(IBNOTC),$P($$MOD^ICPTMOD(+$P($G(^DGCR(399,IBIFN1,I,J,"MOD",K,0)),U,2),"I"),U,2)="TC" Q  ; Don't copy TC modifier from inst to prof bill
"RTN","IBCCC2",133,0)
 ... S ^DGCR(399,IBIFN,I,J,"MOD",K,0)=^DGCR(399,IBIFN1,I,J,"MOD",K,0)
"RTN","IBCCC2",134,0)
CP1 S IBCOD=$P($G(^DGCR(399,IBIFN,0)),"^",9) Q:IBCOD=""!('$D(^DGCR(399,IBIFN1,"C")))
"RTN","IBCCC2",135,0)
 I IBCOD=9 F DGI=4,5,6 I $P(^DGCR(399,IBIFN1,"C"),"^",DGI) S X=$P(^("C"),"^",DGI)_";ICD0(",DGPROCDT=$P(^("C"),"^",DGI+7) D FILE
"RTN","IBCCC2",136,0)
 I IBCOD=4 F DGI=1,2,3 I $P(^DGCR(399,IBIFN1,"C"),"^",DGI) S X=$P(^("C"),"^",DGI)_";ICPT(",DGPROCDT=$P(^("C"),"^",DGI+10) D FILE
"RTN","IBCCC2",137,0)
 I IBCOD=5 F DGI=7,8,9 I $P(^DGCR(399,IBIFN1,"C"),"^",DGI) S X=$P(^("C"),"^",DGI)_";ICPT(",DGPROCDT=$P(^("C"),"^",DGI+4) D FILE
"RTN","IBCCC2",138,0)
 Q
"RTN","IBCCC2",139,0)
 ;
"RTN","IBCCC2",140,0)
PRV S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
"RTN","IBCCC2",141,0)
 N Z,Z0
"RTN","IBCCC2",142,0)
 S Z=$P($G(^DGCR(399,IBIFN,0)),U,19),Z0=$P($G(^DGCR(399,IBIFN1,0)),U,19)
"RTN","IBCCC2",143,0)
 S IBDD=399.0222 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) D
"RTN","IBCCC2",144,0)
 . S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
"RTN","IBCCC2",145,0)
 . I Z'=Z0,$S(X=3:Z0=3,X=4:Z0=2,1:0) S $P(^DGCR(399,IBIFN,I,J,0),U)=(Z0+1)
"RTN","IBCCC2",146,0)
 Q
"RTN","IBCCC2",147,0)
 ;
"RTN","IBCCC2",148,0)
U9 ; Added for new data elements in IB*2.0*447 BI
"RTN","IBCCC2",149,0)
 M ^DGCR(399,IBIFN,I)=^DGCR(399,IBIFN1,I)
"RTN","IBCCC2",150,0)
 Q
"RTN","IBCCC2",151,0)
 ;
"RTN","IBCCC2",152,0)
COB S J=0 F  S J=$O(IBCOB(I,J)) Q:'J  S $P(^DGCR(399,IBIFN,I),U,J)=IBCOB(I,J)
"RTN","IBCCC2",153,0)
 Q
"RTN","IBCCC2",154,0)
 ;
"RTN","IBCCC2",155,0)
FILE N DIC,DIE,DR,DA,X,Y,DLAYGO,DD,DO
"RTN","IBCCC2",156,0)
 I '$D(^DGCR(399,IBIFN,"CP",0)) S DIC("P")=$$GETSPEC^IBEFUNC(399,304)
"RTN","IBCCC2",157,0)
 S DIC(0)="L",DLAYGO=399,DA(1)=IBIFN,DIC="^DGCR(399,"_DA(1)_",""CP""," Q:X=""  D FILE^DICN K DO,DD Q:+Y<1  S DA=+Y
"RTN","IBCCC2",158,0)
 S DIE="^DGCR(399,"_DA(1)_",""CP"",",DR="1///"_DGPROCDT D ^DIE
"RTN","IBCCC2",159,0)
 K DGPROCDT
"RTN","IBCCC2",160,0)
 Q
"RTN","IBCCC2",161,0)
 ;
"RTN","IBCCC2",162,0)
INDEX ;index entire file (set logic)
"RTN","IBCCC2",163,0)
 N IBMAED D SAVERC(IBIFN,.IBMAED)  ; IB*2.0*447 BI - Save the value of piece 16 of each RC node before re-indexing.
"RTN","IBCCC2",164,0)
 S DIK="^DGCR(399,",DA=IBIFN D IX1^DIK K DA,DIK
"RTN","IBCCC2",165,0)
 D RESTRC(IBIFN,.IBMAED)  ; IB*2.0*447 BI - Restore the value of piece 16 of each RC node before re-indexing.
"RTN","IBCCC2",166,0)
 Q
"RTN","IBCCC2",167,0)
 ;
"RTN","IBCCC2",168,0)
PRIOR(IBIFN) ; set Secondary/Tertiary Bill #s on prior bills, if the bill is cancelled remove it from prior bills
"RTN","IBCCC2",169,0)
 N IBSEQ,IBSEQN,IBM1,I,IBIFN1
"RTN","IBCCC2",170,0)
 S IBSEQ=$$COB^IBCEF(IBIFN)
"RTN","IBCCC2",171,0)
 S IBSEQN=$S(IBSEQ="S":6,IBSEQ="T":7,1:"") Q:'IBSEQN
"RTN","IBCCC2",172,0)
 ;
"RTN","IBCCC2",173,0)
 S IBM1=$G(^DGCR(399,IBIFN,"M1")) I +$P(^DGCR(399,IBIFN,0),U,13)=7 S IBIFN=""
"RTN","IBCCC2",174,0)
 F I=5,6 I I<IBSEQN  S IBIFN1=+$P(IBM1,U,I) I +IBIFN1,$D(^DGCR(399,+IBIFN1,0)) S $P(^DGCR(399,IBIFN1,"M1"),U,IBSEQN)=IBIFN
"RTN","IBCCC2",175,0)
 Q
"RTN","IBCCC2",176,0)
 ;
"RTN","IBCCC2",177,0)
COBCHG(IBIFN,IBINS,IBCOB) ; Make changes for a new COB payer for bill
"RTN","IBCCC2",178,0)
 ; IBIFN = ien of bill in file 399
"RTN","IBCCC2",179,0)
 ; IBINS = ien of bill's current insurance (optional)
"RTN","IBCCC2",180,0)
 ; IBCOB = array subscripted by node,piece of COB data field change
"RTN","IBCCC2",181,0)
 ;
"RTN","IBCCC2",182,0)
 N I,IBFRMTYP,IBTAXLST
"RTN","IBCCC2",183,0)
 ; Subtract the Prior Payments from the bill's Offset (these are re-added by triggers)
"RTN","IBCCC2",184,0)
 F I=4,5,6  S $P(^DGCR(399,IBIFN,"U1"),U,2)=$P($G(^DGCR(399,IBIFN,"U1")),U,2)-$P($G(^DGCR(399,IBIFN,"U2")),U,I)
"RTN","IBCCC2",185,0)
 ;
"RTN","IBCCC2",186,0)
 I $G(IBINS),$$MCRWNR^IBEFUNC(IBINS) D
"RTN","IBCCC2",187,0)
 . ;MCRWNR is current insurance ... move payer only
"RTN","IBCCC2",188,0)
 . N IBCOBN,IBX
"RTN","IBCCC2",189,0)
 . S IBCOBN=$$COBN^IBCEF(IBIFN)
"RTN","IBCCC2",190,0)
 . S IBCOB(0,21)=$P("S^T^",U,IBCOBN)
"RTN","IBCCC2",191,0)
 . S IBCOB("M1",IBCOBN+4)=IBIFN
"RTN","IBCCC2",192,0)
 . S IBCOB("TX",1)="",IBCOB("TX",2)=""
"RTN","IBCCC2",193,0)
 . S IBX=$$REQMRA^IBEFUNC(IBIFN)
"RTN","IBCCC2",194,0)
 . I IBX=0 S IBCOB("TX",5)=0                         ; MRA not needed
"RTN","IBCCC2",195,0)
 . I IBX["R" S IBCOB("TX",5)="A"                     ; MRA skipped
"RTN","IBCCC2",196,0)
 . I IBX=1,$$CHK^IBCEMU1(IBIFN) S IBCOB("TX",5)="C"  ; MRA on file
"RTN","IBCCC2",197,0)
 . I $G(IBPRCOB) S IBCOB("TX",5)="C"                 ; MRA being proc'd
"RTN","IBCCC2",198,0)
 . D PRIOR(IBIFN)
"RTN","IBCCC2",199,0)
 . Q
"RTN","IBCCC2",200,0)
 ;
"RTN","IBCCC2",201,0)
 ;reset fields for next Sequence Payer
"RTN","IBCCC2",202,0)
 F I=0,"M1","U2","TX" I $D(IBCOB(I)) D COB
"RTN","IBCCC2",203,0)
 ;
"RTN","IBCCC2",204,0)
 ; IB*2.0*211
"RTN","IBCCC2",205,0)
 ; save off Form Type
"RTN","IBCCC2",206,0)
 S IBFRMTYP=$P($G(^DGCR(399,IBIFN,0)),U,19)
"RTN","IBCCC2",207,0)
 ; Save off Taxonomies for providers.
"RTN","IBCCC2",208,0)
 S I=0 F  S I=$O(^DGCR(399,IBIFN,"PRV",I)) Q:'I  S IBTAXLST(I)=$P($G(^DGCR(399,IBIFN,"PRV",I,0)),U,15)
"RTN","IBCCC2",209,0)
 ;
"RTN","IBCCC2",210,0)
 ; fire xrefs set logic
"RTN","IBCCC2",211,0)
 D INDEX
"RTN","IBCCC2",212,0)
 ;
"RTN","IBCCC2",213,0)
 ; Restore Form Type if changed, but don't restore Form Type if
"RTN","IBCCC2",214,0)
 ;   creating CMS-1500 claim from CTCOPY1^IBCCCB
"RTN","IBCCC2",215,0)
 I $G(IBCTCOPY)'=1,IBFRMTYP'=$P($G(^DGCR(399,IBIFN,0)),U,19) N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399,",DR=".19////"_IBFRMTYP D ^DIE
"RTN","IBCCC2",216,0)
 ;
"RTN","IBCCC2",217,0)
 ; Restore Claim MRA Status field since triggers in fields 101 & 102
"RTN","IBCCC2",218,0)
 ;   will overwrite the correct value when processing the MRA/EOB.
"RTN","IBCCC2",219,0)
 ; If we're processing the MRA/EOB, then a valid MRA has been received.
"RTN","IBCCC2",220,0)
 I $G(IBPRCOB) N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399,",DR="24////C" D ^DIE
"RTN","IBCCC2",221,0)
 ;
"RTN","IBCCC2",222,0)
 ; Only if cloning, then restore Taxonomies in fields 243 and 244 and 252.
"RTN","IBCCC2",223,0)
 I '$G(IBINS),'$G(IBPRCOB) D
"RTN","IBCCC2",224,0)
 . S I=$P($G(IBND("U3")),U,2)
"RTN","IBCCC2",225,0)
 . I I'=$P($G(^DGCR(399,IBIFN,"U3")),U,2) D
"RTN","IBCCC2",226,0)
 .. N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399,",DR="243////"_$S(I'="":I,1:"@") D ^DIE
"RTN","IBCCC2",227,0)
 . ;
"RTN","IBCCC2",228,0)
 . S I=$P($G(IBND("U3")),U,3)
"RTN","IBCCC2",229,0)
 . I I'=$P($G(^DGCR(399,IBIFN,"U3")),U,3) D
"RTN","IBCCC2",230,0)
 .. N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399,",DR="244////"_$S(I'="":I,1:"@") D ^DIE
"RTN","IBCCC2",231,0)
 . ;
"RTN","IBCCC2",232,0)
 . S I=$P($G(IBND("U3")),U,11)
"RTN","IBCCC2",233,0)
 . I I'=$P($G(^DGCR(399,IBIFN,"U3")),U,11) D
"RTN","IBCCC2",234,0)
 .. N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399,",DR="252////"_$S(I'="":I,1:"@") D ^DIE
"RTN","IBCCC2",235,0)
 . Q
"RTN","IBCCC2",236,0)
 ;
"RTN","IBCCC2",237,0)
 ; Restore Taxonomies in field .15 in sub-file 399.0222.
"RTN","IBCCC2",238,0)
 S IBTAXLST=0 F  S IBTAXLST=$O(IBTAXLST(IBTAXLST)) Q:'IBTAXLST  D
"RTN","IBCCC2",239,0)
 . S I=IBTAXLST(IBTAXLST)
"RTN","IBCCC2",240,0)
 . I I=$P($G(^DGCR(399,IBIFN,"PRV",IBTAXLST,0)),U,15) Q  ; No change
"RTN","IBCCC2",241,0)
 . N DA,DIE,DR
"RTN","IBCCC2",242,0)
 . S DA(1)=IBIFN,DA=IBTAXLST
"RTN","IBCCC2",243,0)
 . S DIE="^DGCR(399,"_DA(1)_",""PRV"",",DR=".15////"_$S(I'="":I,1:"@")
"RTN","IBCCC2",244,0)
 . D ^DIE
"RTN","IBCCC2",245,0)
 . Q
"RTN","IBCCC2",246,0)
 ;
"RTN","IBCCC2",247,0)
 K IBCOB("TX")
"RTN","IBCCC2",248,0)
 Q
"RTN","IBCCC2",249,0)
 ;
"RTN","IBCCC2",250,0)
SAVERC(IBIFN,IBMAED)  ; IB*2.0*447 BI - Save the value of piece 16 of each RC node before re-indexing.
"RTN","IBCCC2",251,0)
 Q:$G(IBCTCOPY)=1  Q:$G(IBCTCOPY)=2
"RTN","IBCCC2",252,0)
 N IBCNT S IBCNT=0
"RTN","IBCCC2",253,0)
 Q:'$G(IBIFN)  Q:'$D(^DGCR(399,IBIFN,"RC"))
"RTN","IBCCC2",254,0)
 F  S IBCNT=$O(^DGCR(399,IBIFN,"RC",IBCNT)) Q:+IBCNT=0  D
"RTN","IBCCC2",255,0)
 . S IBMAED(IBCNT)=$P($G(^DGCR(399,IBIFN,"RC",IBCNT,0)),U,16)
"RTN","IBCCC2",256,0)
 Q
"RTN","IBCCC2",257,0)
 ;
"RTN","IBCCC2",258,0)
RESTRC(IBIFN,IBMAED)  ; IB*2.0*447 BI - Restore the value of piece 16 of each RC node after re-indexing.
"RTN","IBCCC2",259,0)
 Q:$G(IBCTCOPY)=1  Q:$G(IBCTCOPY)=2
"RTN","IBCCC2",260,0)
 N IBCNT S IBCNT=0
"RTN","IBCCC2",261,0)
 Q:'$G(IBIFN)  Q:'$D(^DGCR(399,IBIFN,"RC"))
"RTN","IBCCC2",262,0)
 F  S IBCNT=$O(IBMAED(IBCNT)) Q:+IBCNT=0  D
"RTN","IBCCC2",263,0)
 . S $P(^DGCR(399,IBIFN,"RC",IBCNT,0),U,16)=IBMAED(IBCNT)
"RTN","IBCCC2",264,0)
 Q
"RTN","IBCCCB")
0^16^B65683261
"RTN","IBCCCB",1,0)
IBCCCB ;ALB/ARH - COPY BILL FOR COB ;2/13/06 10:46am
"RTN","IBCCCB",2,0)
 ;;2.0;INTEGRATED BILLING;**80,106,51,151,137,182,155,323,436,432,447**;21-MAR-94;Build 80
"RTN","IBCCCB",3,0)
 ;;Per VHA Directive 2004-38, this routine should not be modified.
"RTN","IBCCCB",4,0)
 ;
"RTN","IBCCCB",5,0)
 ; Copy bill for COB w/out cancelling, update some flds
"RTN","IBCCCB",6,0)
 ; Primary->Secondary->Tertiary
"RTN","IBCCCB",7,0)
ASK ;
"RTN","IBCCCB",8,0)
 S IBCBCOPY=1 ; flag that copy function entered thru Copy COB option
"RTN","IBCCCB",9,0)
 ;
"RTN","IBCCCB",10,0)
 D KVAR S IBCAN=2,IBU="UNSPECIFIED"
"RTN","IBCCCB",11,0)
 ;
"RTN","IBCCCB",12,0)
 S IBX=$$PB^IBJTU2 S:+IBX=2 IBIFN=$P(IBX,U,2) I +IBX=1 S DFN=$P(IBX,U,2),IBV=1,IBAC=5 D DATE^IBCB
"RTN","IBCCCB",13,0)
 I '$G(IBIFN) G EXIT
"RTN","IBCCCB",14,0)
 ;
"RTN","IBCCCB",15,0)
 ; IB*2.0*432 Restrict access to only allow claims that are NOT on the new CBW Worklist
"RTN","IBCCCB",16,0)
 I $P($G(^DGCR(399,IBIFN,"S1")),U,7)=1,$G(IBMRANOT)'=1 D  G ASK
"RTN","IBCCCB",17,0)
 . W !!?4,"This bill appears on the CBW Management Work List.  Please use the"
"RTN","IBCCCB",18,0)
 . W !?4,"'CBW Management Menu' options for all processing related to this bill."
"RTN","IBCCCB",19,0)
 . Q
"RTN","IBCCCB",20,0)
 ; Restrict access to this process for REQUEST MRA bills in 2 Cases:
"RTN","IBCCCB",21,0)
 ; 1. No MRA EOB's on File for bill
"RTN","IBCCCB",22,0)
 I $P($G(^DGCR(399,IBIFN,0)),U,13)=2,'$$CHK^IBCEMU1(IBIFN) D  G ASK
"RTN","IBCCCB",23,0)
 . W !!?4,"This bill is in a status of REQUEST MRA and it has No MRA EOB's"
"RTN","IBCCCB",24,0)
 . W !?4,"on file.  Access to this bill is restricted."
"RTN","IBCCCB",25,0)
 ;
"RTN","IBCCCB",26,0)
 ; 2. At least one MRA EOB appears on the MRA management worklist
"RTN","IBCCCB",27,0)
 I $P($G(^DGCR(399,IBIFN,0)),U,13)=2,$$MRAWL^IBCEMU2(IBIFN) D  G ASK
"RTN","IBCCCB",28,0)
 . W !!?4,"This bill is in a status of REQUEST MRA and it does appear on the"
"RTN","IBCCCB",29,0)
 . W !?4,"MRA Management Work List.  Please use the 'MRA Management Menu' options"
"RTN","IBCCCB",30,0)
 . W !?4,"for all processing related to this bill."
"RTN","IBCCCB",31,0)
 . Q
"RTN","IBCCCB",32,0)
 ;
"RTN","IBCCCB",33,0)
 ; If MRA is Activated and bill is in Entered/Not Reviewed status and current insurance Co. is WNR -->
"RTN","IBCCCB",34,0)
 ; ask if user wants to continue
"RTN","IBCCCB",35,0)
 I $$EDIACTV^IBCEF4(2),$P($G(^DGCR(399,IBIFN,0)),U,13)=1,$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN)) D  I 'Y G ASK
"RTN","IBCCCB",36,0)
 . W !!?4,"This bill is in a status of ENTERED/NOT REVIEWED and current payer is "
"RTN","IBCCCB",37,0)
 . W !?4,"MEDICARE (WNR). No MRA has been requested for this bill."
"RTN","IBCCCB",38,0)
 . S DIR(0)="YA",DIR("B")="NO",DIR("A")="    Are you sure you want to continue to process this bill?: "
"RTN","IBCCCB",39,0)
 . D ^DIR K DIR
"RTN","IBCCCB",40,0)
 ;
"RTN","IBCCCB",41,0)
 ; Display related bills
"RTN","IBCCCB",42,0)
 D DSPRB^IBCCCB0(IBIFN)
"RTN","IBCCCB",43,0)
 ;
"RTN","IBCCCB",44,0)
CHKB ; Entrypoint-COB processing via EDI's COB Mgmt
"RTN","IBCCCB",45,0)
 ; Ask if final EOB was received for previous bill
"RTN","IBCCCB",46,0)
 I '$$FINALEOB^IBCCCB0(IBIFN) S IBSECHK=1
"RTN","IBCCCB",47,0)
 I $G(IBSECHK)=1,$$MCRONBIL^IBEFUNC(IBIFN) G EXIT
"RTN","IBCCCB",48,0)
 ;
"RTN","IBCCCB",49,0)
 ; Warn if previous bill not at least authorized
"RTN","IBCCCB",50,0)
 I '$$MCRONBIL^IBEFUNC(IBIFN) I '$$COBOK^IBCCCB0(IBIFN) G EXIT
"RTN","IBCCCB",51,0)
 ;
"RTN","IBCCCB",52,0)
CHKB1 ; Entry point for Automatic/Silent COB Processing.
"RTN","IBCCCB",53,0)
 ; No writes or reads can occur from this point forward if variable
"RTN","IBCCCB",54,0)
 ; IBSILENT=1.  Any and all error messages should be processed with
"RTN","IBCCCB",55,0)
 ; the ERROR procedure below.
"RTN","IBCCCB",56,0)
 ;
"RTN","IBCCCB",57,0)
 S IBX=$G(^DGCR(399,+IBIFN,0)),DFN=$P(IBX,U,2),IBDT=$P(IBX,U,3)\1,IBER=""
"RTN","IBCCCB",58,0)
 I IBCAN>1 D NOPTF^IBCB2 I 'IBAC1 D NOPTF1^IBCB2 G ASK1
"RTN","IBCCCB",59,0)
 ;
"RTN","IBCCCB",60,0)
 F IBI=0,"S","U1","M","MP","M1" S IB(IBI)=$G(^DGCR(399,IBIFN,IBI))
"RTN","IBCCCB",61,0)
 I IB(0)="" S IBER="Invalid Bill Number" D ERROR G ASK1
"RTN","IBCCCB",62,0)
 ;
"RTN","IBCCCB",63,0)
 ; check to see if the bill has been cancelled
"RTN","IBCCCB",64,0)
 I $P(IB("S"),U,16),$P(IB("S"),U,17) D  G ASK1
"RTN","IBCCCB",65,0)
 . N WHO
"RTN","IBCCCB",66,0)
 . S IBER="This bill was cancelled on "
"RTN","IBCCCB",67,0)
 . S IBER=IBER_$$FMTE^XLFDT($P(IB("S"),U,17),"1Z")_" by "
"RTN","IBCCCB",68,0)
 . S WHO="UNSPECIFIED"
"RTN","IBCCCB",69,0)
 . I $P(IB("S"),U,18) S WHO=$P($G(^VA(200,$P(IB("S"),U,18),0)),U,1)
"RTN","IBCCCB",70,0)
 . S IBER=IBER_WHO_"."
"RTN","IBCCCB",71,0)
 . D ERROR
"RTN","IBCCCB",72,0)
 . Q
"RTN","IBCCCB",73,0)
 ;
"RTN","IBCCCB",74,0)
 S IBCOB=$$COB^IBCEF(IBIFN),IBCOBN=$TR(IBCOB,"PSTA","12")
"RTN","IBCCCB",75,0)
 S IBMRAIO=+$$CURR^IBCEF2(IBIFN),IBMRAO=$$MCRWNR^IBEFUNC(IBMRAIO)
"RTN","IBCCCB",76,0)
 S IBNMOLD=$S(IBCOB="P":"Primary",IBCOB="S":"Secondary",IBCOB="T":"Tertiary",IBCOB="A":"Patient",1:"")_$S(IBMRAO:"-MRA Only",1:"")
"RTN","IBCCCB",77,0)
 S IBINSOLD=$G(^DIC(36,$S(IB("MP"):+IB("MP"),IBMRAO:IBMRAIO,1:0),0))
"RTN","IBCCCB",78,0)
 ;
"RTN","IBCCCB",79,0)
NEXTP ; If current bill=MEDICARE WNR and valid 'next payer', use same
"RTN","IBCCCB",80,0)
 ;  bill for new payer
"RTN","IBCCCB",81,0)
 ; If next valid 'payer' is ins co or MEDICARE WNR, create new bill
"RTN","IBCCCB",82,0)
 S IBCOBN=IBCOBN+1,IBNM=$S(IBCOBN=2:"Secondary Payer",IBCOBN=3:"Tertiary Payer",1:"")
"RTN","IBCCCB",83,0)
 ;
"RTN","IBCCCB",84,0)
 I IBNM="" S IBER=$P(IB(0),U,1)_" is a "_IBNMOLD_" bill, there is no next bill in the series." D ERROR G ASK1
"RTN","IBCCCB",85,0)
 ;
"RTN","IBCCCB",86,0)
 S IBX=+$P(IB("M1"),U,(4+IBCOBN)),IBY=$G(^DGCR(399,+IBX,0)),IBCOBIL(+IBIFN)=""
"RTN","IBCCCB",87,0)
 ;
"RTN","IBCCCB",88,0)
 I $P(IBY,U,13)=7 S IBER="The "_$P(IBNM," ",1)_" bill "_$P(IBY,U,1)_" has been cancelled." D ERROR S IBX=""
"RTN","IBCCCB",89,0)
 ;
"RTN","IBCCCB",90,0)
 I +IBX,$D(IBCOBIL(+IBX)) S IBER="Next bill in series can not be determined." D ERROR G ASK1
"RTN","IBCCCB",91,0)
 I +IBX S IBER=$P(IBNM," ",1)_" bill already defined for this series: "_$P(IBY,U,1) D ERROR S IBIFN=IBX G ASK1
"RTN","IBCCCB",92,0)
 ;
"RTN","IBCCCB",93,0)
 S IBINSN=$P(IB("M"),U,IBCOBN) I 'IBINSN S IBER="There is no "_IBNM_" for "_$P(IB(0),U,1)_"." D ERROR G ASK1
"RTN","IBCCCB",94,0)
 S IBINS=$G(^DIC(36,+IBINSN,0)) I IBINS="" S IBER="The "_IBNM_" for "_$P(IB(0),U,1)_" is not a valid Insurance Co." D ERROR G ASK1
"RTN","IBCCCB",95,0)
 ;
"RTN","IBCCCB",96,0)
 S IBMRA=0
"RTN","IBCCCB",97,0)
 I $P(IBINS,U,2)="N" S IBQ=0 D  G:IBQ NEXTP
"RTN","IBCCCB",98,0)
 . I $$MCRWNR^IBEFUNC(IBINSN) D  Q
"RTN","IBCCCB",99,0)
 .. ; Check if a valid tert ins if MCR WNR secondary
"RTN","IBCCCB",100,0)
 .. I IBCOBN'>2 D
"RTN","IBCCCB",101,0)
 ... N Z
"RTN","IBCCCB",102,0)
 ... S Z=+$P(IB("M"),U,IBCOBN+1)
"RTN","IBCCCB",103,0)
 ... I Z,$D(^DIC(36,Z,0)),$P(^(0),U,2)'="N" S IBMRA=1,IBNM=$P(IBNM," ")_"-MRA.Only"
"RTN","IBCCCB",104,0)
 .. I 'IBMRA S IBER="MEDICARE will not reimburse and no further valid insurance for bill" D ERROR S IBQ=1
"RTN","IBCCCB",105,0)
 . S IBER=$P(IB(0),U,1)_" "_IBNM_", "_$P(IBINS,U,1)_", will not Reimburse" D ERROR S IBQ=1
"RTN","IBCCCB",106,0)
 ;
"RTN","IBCCCB",107,0)
 ; If processing in silent mode, skip over the following reads
"RTN","IBCCCB",108,0)
 I $G(IBSILENT) G SKIP
"RTN","IBCCCB",109,0)
 ;
"RTN","IBCCCB",110,0)
 W !!
"RTN","IBCCCB",111,0)
 S DIR("?")="Enter Yes to "_$S('$G(IBMRAO):"create a new bill in the bill series for this care.  The new bill will be the "_$P(IBNM," ")_" bill ",1:"enter the MRA information and change the payer to the "_$P($P(IBNM,"-")," ")_" payer ")
"RTN","IBCCCB",112,0)
 S DIR("?")=DIR("?")_$S('IBMRA:"with the "_IBNM_" responsible for payment.",1:"and will request an MRA from MEDICARE.")
"RTN","IBCCCB",113,0)
 S DIR(0)="YO",DIR("A")=$S('$G(IBMRAO):"Copy "_$P(IB(0),U,1)_" for a bill to the ",1:"Change payer on bill "_$P(IB(0),U,1)_" to ")_IBNM_", "_$P(IBINS,U,1) D ^DIR K DIR I Y'=1 S IBSECHK=1 G ASK1
"RTN","IBCCCB",114,0)
 ;
"RTN","IBCCCB",115,0)
 W !
"RTN","IBCCCB",116,0)
 S IBQ=0
"RTN","IBCCCB",117,0)
 I '$G(IBMRAO) D  G:IBQ ASK1
"RTN","IBCCCB",118,0)
 . N Z
"RTN","IBCCCB",119,0)
 . S DIR("?")="Enter the amount of the payment from the payer of the "_IBNMOLD_" bill."
"RTN","IBCCCB",120,0)
 . S DIR("?")=DIR("?")_"  This will be added to the new bill as a prior payment and subtracted from the charges due for the new bill."
"RTN","IBCCCB",121,0)
 . S DIR("A")="Prior Payment from "_$P(IB(0),U,1)_" "_IBNMOLD_" Payer, "_$P(IBINSOLD,U,1)_": "
"RTN","IBCCCB",122,0)
 . S Z=$$EOBTOT^IBCEU1(IBIFN,$$COBN^IBCEF(IBIFN))
"RTN","IBCCCB",123,0)
 . S:Z DIR("B")=Z
"RTN","IBCCCB",124,0)
 . S DIR(0)="NOA^0:99999999:2"
"RTN","IBCCCB",125,0)
 . D ^DIR K DIR I Y=""!$D(DIRUT) S IBQ=1
"RTN","IBCCCB",126,0)
 . K IBCOB
"RTN","IBCCCB",127,0)
 . S IBCOB("U2",IBCOBN+2)=Y
"RTN","IBCCCB",128,0)
 . Q
"RTN","IBCCCB",129,0)
 ;
"RTN","IBCCCB",130,0)
SKIP ; Jump here if skipping over the preceeding reads
"RTN","IBCCCB",131,0)
 ;
"RTN","IBCCCB",132,0)
 ; If payer is Medicare (WNR) update payer sequence and quit
"RTN","IBCCCB",133,0)
 I IBMRAO!($G(IBSTSM)=1) D  I $G(IBSTSM)'=1 G END
"RTN","IBCCCB",134,0)
 . N IBPRTOT,IBTOTCHG,IBPTRESP
"RTN","IBCCCB",135,0)
 . S IBTOTCHG=0
"RTN","IBCCCB",136,0)
 . ;
"RTN","IBCCCB",137,0)
 . ; Get Total Charges from BILLS/CLAIMS (#399) file
"RTN","IBCCCB",138,0)
 . S IBTOTCHG=$P($G(^DGCR(399,IBIFN,"U1")),U,1)
"RTN","IBCCCB",139,0)
 . ; Calculate Patient Responsibility for Bill  
"RTN","IBCCCB",140,0)
 . ; IB*2.0*447 If claim's type of plan has effective date multiple, use those calculations
"RTN","IBCCCB",141,0)
 . ;S IBPTRESP=$$PREOBTOT^IBCEU0(IBIFN,$G(IBSTSM))
"RTN","IBCCCB",142,0)
 . ; Calculate Patient Primary/Secondary Prior Payment (field 218 or 219 of File 399)
"RTN","IBCCCB",143,0)
 . ; These fields are stored in DGCR(399,IBIFN,"U2") pieces 4 and 5 respectively
"RTN","IBCCCB",144,0)
 . ; Calculate: Prior Payment= Total Submitted Charges - Patient Responsibility
"RTN","IBCCCB",145,0)
 . S:$G(IBSTSM)'=1 IBPTRESP=$S($$MSEDT^IBCEMU4(IBIFN)'="":$$MSPRE^IBCEMU4(IBIFN),1:$$PREOBTOT^IBCEU0(IBIFN,$G(IBSTSM))),IBPRTOT=IBTOTCHG-IBPTRESP
"RTN","IBCCCB",146,0)
 . S:$G(IBSTSM)=1 IBPRTOT=$$EOBTOT^IBCEU1(IBIFN,$$COBN^IBCEF(IBIFN)) ;Pat Resp for non-medicare
"RTN","IBCCCB",147,0)
 . I IBPRTOT<0 S IBPRTOT=0      ; don't allow negative prior payment or offset
"RTN","IBCCCB",148,0)
 . S IBCOB("U2",IBCOBN+2)=IBPRTOT
"RTN","IBCCCB",149,0)
 . D:$G(IBSTSM)'=1 COBCHG^IBCCC2(IBIFN,IBMRAIO,.IBCOB)
"RTN","IBCCCB",150,0)
 . D STAT^IBCEMU2(IBIFN,1.5,1)     ; mra eob status update
"RTN","IBCCCB",151,0)
 . I $G(IBSILENT) S IBERRMSG=""
"RTN","IBCCCB",152,0)
 . Q
"RTN","IBCCCB",153,0)
 ;
"RTN","IBCCCB",154,0)
 ; We should NOT get to here in silent mode .... just in case
"RTN","IBCCCB",155,0)
 I $G(IBSILENT),$G(IBSTSM)'=1 G END    ; currently only MCRWNR in silent mode
"RTN","IBCCCB",156,0)
 ;
"RTN","IBCCCB",157,0)
 ; Payer is not Medicare (WNR) - Perform additional steps
"RTN","IBCCCB",158,0)
 S IBCOB(0,15)=""
"RTN","IBCCCB",159,0)
 S IBCOB(0,21)=$S(IBCOBN=2:"S",IBCOBN=3:"T",1:"")
"RTN","IBCCCB",160,0)
 I IBCOB(0,21)="" G END
"RTN","IBCCCB",161,0)
 S IBCOB("M1",IBCOBN+3)=IBIFN
"RTN","IBCCCB",162,0)
 S IBIDS(.15)=IBIFN
"RTN","IBCCCB",163,0)
 D KVAR
"RTN","IBCCCB",164,0)
 G STEP2^IBCCC
"RTN","IBCCCB",165,0)
 ;
"RTN","IBCCCB",166,0)
END ;
"RTN","IBCCCB",167,0)
 Q
"RTN","IBCCCB",168,0)
 ;
"RTN","IBCCCB",169,0)
 ;
"RTN","IBCCCB",170,0)
ASK1 ; If entering thru EDI COB processing, don't ask for new bill, quit
"RTN","IBCCCB",171,0)
 I $G(IBCBASK) G EXIT
"RTN","IBCCCB",172,0)
 G ASK
"RTN","IBCCCB",173,0)
 ;
"RTN","IBCCCB",174,0)
ERROR ; Display/Save error message
"RTN","IBCCCB",175,0)
 I '$G(IBSILENT) W !,IBER,!
"RTN","IBCCCB",176,0)
 E  S IBERRMSG=IBER
"RTN","IBCCCB",177,0)
 S IBER=""
"RTN","IBCCCB",178,0)
 I $D(IBSECHK) S IBSECHK=1
"RTN","IBCCCB",179,0)
 Q
"RTN","IBCCCB",180,0)
 ;
"RTN","IBCCCB",181,0)
EXIT K IBCAN,IBCOB,IBU
"RTN","IBCCCB",182,0)
KVAR K IBX,IBY,IBI,IBIFN,DFN,IBDT,IB,IBCOBN,IBNMOLD,IBINSOLD,IBNM,IBINSN,IBINS,IBER,DIR,IBAC,IBAC1,IBV,X,Y,IBDATA,IBT,IBND0,DIRUT,IBCOBIL,IBMRA,IBMRAI,IBMRAO,IBMRAIO,IBCBCOPY
"RTN","IBCCCB",183,0)
 K ^UTILITY($J)
"RTN","IBCCCB",184,0)
 Q
"RTN","IBCCCB",185,0)
 ;
"RTN","IBCCCB",186,0)
DSPRB(IBIFN) ; display related bills
"RTN","IBCCCB",187,0)
 ;
"RTN","IBCCCB",188,0)
 D DSPRB^IBCCCB0(IBIFN) ; Code moved for size too big
"RTN","IBCCCB",189,0)
 Q
"RTN","IBCCCB",190,0)
 ;
"RTN","IBCCCB",191,0)
 ; ==============
"RTN","IBCCCB",192,0)
 ; 
"RTN","IBCCCB",193,0)
 ; Copy a bill for Reasonable Charges without cancelling it, update certain fields
"RTN","IBCCCB",194,0)
 ;
"RTN","IBCCCB",195,0)
 ; there is always both inpt inst (created first) and prof charges, always need both bills
"RTN","IBCCCB",196,0)
 ; there may be both outpt inst (created first) and prof charges, may not need both bills
"RTN","IBCCCB",197,0)
 ; if billing by episode rather than by day (current standard) then may need multiple prof bills per day
"RTN","IBCCCB",198,0)
 ; 
"RTN","IBCCCB",199,0)
 ; Inst bills are copied to create prof Bills automatically
"RTN","IBCCCB",200,0)
 ; Subsequent prof bills may be created if the user wants them
"RTN","IBCCCB",201,0)
 ;
"RTN","IBCCCB",202,0)
 ; Only the first bill in the COB series of bills should be copied for the next prof bill
"RTN","IBCCCB",203,0)
 ; The primary inst bill should be copied to get the secondary inst bill
"RTN","IBCCCB",204,0)
 ; The primary prof bill should be copied to get the secondary prof bill
"RTN","IBCCCB",205,0)
 ;
"RTN","IBCCCB",206,0)
CTCOPY(IBIFN,IBMRA) ; based on the type of bill, copy without cancelling
"RTN","IBCCCB",207,0)
 ; IBMRA = 1 if an MRA bill and copy for prof components is desired
"RTN","IBCCCB",208,0)
 ;
"RTN","IBCCCB",209,0)
 D CTCOPY^IBCCCB0(IBIFN,$G(IBMRA)) ;Moved due to routine size
"RTN","IBCCCB",210,0)
 Q
"RTN","IBCCCB",211,0)
 ;
"RTN","IBCECOB1")
0^32^B102535687
"RTN","IBCECOB1",1,0)
IBCECOB1 ;ALB/CXW - IB COB MANAGEMENT SCREEN/REPORT ;14-JUN-99
"RTN","IBCECOB1",2,0)
 ;;2.0;INTEGRATED BILLING;**137,155,288,348,377,417,432,447**;21-MAR-94;Build 80
"RTN","IBCECOB1",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCECOB1",4,0)
 ;
"RTN","IBCECOB1",5,0)
 ; IBMRANOT = 1 when dealing with the COB Management Worklist.   
"RTN","IBCECOB1",6,0)
 ;            It is set by the entry action in the option file. 
"RTN","IBCECOB1",7,0)
 ;
"RTN","IBCECOB1",8,0)
BLD ; Build list entrypoint
"RTN","IBCECOB1",9,0)
 N I,IBFND,IBB,IBIFN,IB364,IBDA1,IBDTN,IBDA,IBDAY,IBHIS,IBNDS,IBEUT,IBAPY,IBOAM,IBDT,IBMUT,IBBPY,IBINS,IBNDM,IBQ,IBNDI1,IBNDI2,IBNDI3,Z,Z0,IBSEQ,IB3611,IBINS1,IBINS2,IBEXPY,IBNBAL,IBPTRSP,IBAMT,IBMRACNT,IBPTNM,IBSRVC,IBPY,IBB364
"RTN","IBCECOB1",10,0)
 N IBEOBREV,IBDENDUP,EOBTYPE
"RTN","IBCECOB1",11,0)
 K ^TMP("IBCECOB",$J),^TMP("IBCECOB1",$J),^TMP("IBCOBST",$J),^TMP("IBCOBSTX",$J)
"RTN","IBCECOB1",12,0)
 D CLEAN^VALM10      ; kill data and video control arrays
"RTN","IBCECOB1",13,0)
 S VALMCNT=0,IBHIS=""
"RTN","IBCECOB1",14,0)
 ; IB*2.0*432 IF not MRA, use new CAP index on 399 file
"RTN","IBCECOB1",15,0)
 D:$G(IBMRANOT)=1 CAP^IBCAPP2
"RTN","IBCECOB1",16,0)
 ; since 0 is a valid Review Status, init w/null
"RTN","IBCECOB1",17,0)
 S IBEOBREV=""
"RTN","IBCECOB1",18,0)
 ; get EOB's w/Review Status of 0, 1, 1.5 or 2; If 3 or higher, not needed
"RTN","IBCECOB1",19,0)
 I $G(IBMRANOT)'=1 F  S IBEOBREV=$O(^IBM(361.1,"AMRA",1,IBEOBREV)) Q:IBEOBREV=""  Q:IBEOBREV>2  D
"RTN","IBCECOB1",20,0)
 . S IBDA="A" F  S IBDA=$O(^IBM(361.1,"AMRA",1,IBEOBREV,IBDA),-1) Q:'IBDA  D BLD1
"RTN","IBCECOB1",21,0)
 ; no data accumulated
"RTN","IBCECOB1",22,0)
 I $O(^TMP("IBCOBST",$J,""))="" D NMAT Q
"RTN","IBCECOB1",23,0)
 ; display accumulated data
"RTN","IBCECOB1",24,0)
 D SCRN
"RTN","IBCECOB1",25,0)
 Q
"RTN","IBCECOB1",26,0)
BLD1 ;
"RTN","IBCECOB1",27,0)
 I '$$ELIG(IBDA) Q
"RTN","IBCECOB1",28,0)
 S IBDENDUP=$$DENDUP^IBCEMU4(IBDA,$G(IBMRANOT))
"RTN","IBCECOB1",29,0)
 I '$G(IBMRADUP),IBDENDUP Q     ; don't include denied MRAs/EOBs for Duplicate Claim/Service
"RTN","IBCECOB1",30,0)
 S IB3611=$G(^IBM(361.1,IBDA,0))
"RTN","IBCECOB1",31,0)
 S IBIFN=+IB3611,IB364=$P(IB3611,U,19),IBDT=+$P(IB3611,U,6)
"RTN","IBCECOB1",32,0)
 I $D(^TMP("IBCOBSTX",$J,IBIFN)) Q  ;show each bill once on the worklist
"RTN","IBCECOB1",33,0)
 S IBB=$G(^DGCR(399,IBIFN,0))
"RTN","IBCECOB1",34,0)
 S IBNDS=$G(^DGCR(399,IBIFN,"S")),IBNDI1=$G(^("I1")),IBNDI2=$G(^("I2")),IBNDI3=$G(^("I3")),IBNDM=$G(^("M"))
"RTN","IBCECOB1",35,0)
 S IBMUT=+$P(IBNDS,U,8),IBEUT=+$P(IBNDS,U,2)
"RTN","IBCECOB1",36,0)
 S IBINS="",IBSEQ=$P(IB3611,U,15)
"RTN","IBCECOB1",37,0)
 F I=1:1:3 S Z="IBNDI"_I I @Z D
"RTN","IBCECOB1",38,0)
 . N Q
"RTN","IBCECOB1",39,0)
 . S Q=(IBSEQ=I)
"RTN","IBCECOB1",40,0)
 . I Q S IBINS1=+@Z_U_$P($G(^DIC(36,+@Z,0)),U)
"RTN","IBCECOB1",41,0)
 . S IBINS=IBINS_$S(IBINS="":"",1:", ")_$P($G(^DIC(36,+@Z,0)),U)
"RTN","IBCECOB1",42,0)
 ; Get the payer/insurance company that comes after Medicare WNR
"RTN","IBCECOB1",43,0)
 ; If WNR is Primary, get the secondary ins. co.
"RTN","IBCECOB1",44,0)
 ; If WNR is secondary, get the tertiary ins. co.
"RTN","IBCECOB1",45,0)
 D  I $P($G(IBINS2),U,2)="" S $P(IBINS2,U,2)="UNKNOWN"
"RTN","IBCECOB1",46,0)
 . I $$WNRBILL^IBEFUNC(IBIFN,1) S IBINS2=+IBNDI2_U_$P($G(^DIC(36,+IBNDI2,0)),U) Q
"RTN","IBCECOB1",47,0)
 . S IBINS2=+IBNDI3_U_$P($G(^DIC(36,+IBNDI3,0)),U)
"RTN","IBCECOB1",48,0)
 S IBFND=0
"RTN","IBCECOB1",49,0)
 ; biller entry not ALL and no biller, then get entered/edited by user
"RTN","IBCECOB1",50,0)
 I $D(^TMP("IBBIL",$J)) D  Q:'IBFND
"RTN","IBCECOB1",51,0)
 . S IBFND=$S($D(^TMP("IBBIL",$J,IBMUT)):IBMUT,$D(^TMP("IBBIL",$J,IBEUT)):IBEUT,1:0)
"RTN","IBCECOB1",52,0)
 S Z=$S(IBFND:IBFND,IBMUT:IBMUT,1:IBEUT)
"RTN","IBCECOB1",53,0)
 S IBMUT=$P($G(^VA(200,+Z,0)),U)_"~"_Z
"RTN","IBCECOB1",54,0)
 S:'$P(IBMUT,"~",2) IBMUT="UNKNOWN~0"
"RTN","IBCECOB1",55,0)
 S IBBPY=+$$COBN^IBCEF(IBIFN),IBQ=1
"RTN","IBCECOB1",56,0)
 ;IBQ;1=EOB without subsequent insurer,0=COB,2=0 balance
"RTN","IBCECOB1",57,0)
 D  ;I IBQ Q
"RTN","IBCECOB1",58,0)
 . ;Check for no reimbursable subsequent insurance
"RTN","IBCECOB1",59,0)
 .  F I=IBBPY+1:1:3 D  Q:'IBQ
"RTN","IBCECOB1",60,0)
 .. S Z="IBNDI"_I,Z=$G(@Z)
"RTN","IBCECOB1",61,0)
 .. I $P($G(^DIC(36,+Z,0)),U,2)="N" S IBQ=0 Q
"RTN","IBCECOB1",62,0)
 . ;Check if next ins doesn't exist or next bill# already created
"RTN","IBCECOB1",63,0)
 . S Z="IBNDI"_(IBBPY+1),Z=$G(@Z)
"RTN","IBCECOB1",64,0)
 . I Z,'$P($G(^DGCR(399,IBIFN,"M1")),U,5+IBBPY) S IBQ=0
"RTN","IBCECOB1",65,0)
 ;
"RTN","IBCECOB1",66,0)
 ; Days since transmission of latest bill in COB - IBDAY
"RTN","IBCECOB1",67,0)
 S IBDAY=+$P($G(^DGCR(399,IBIFN,"TX")),U,2) I IBDAY S IBDAY=$$FMDIFF^XLFDT(DT,IBDAY,1)
"RTN","IBCECOB1",68,0)
 ; if no Last Electronic Extract Date on file 399, get it from file 364
"RTN","IBCECOB1",69,0)
 I 'IBDAY D  I IBDAY S IBDAY=$$FMDIFF^XLFDT(DT,IBDAY,1) ;calc. the difference
"RTN","IBCECOB1",70,0)
 . S IBB364=$$LAST364^IBCEF4(IBIFN) I IBB364'="" S IBDAY=+$P($P($G(^IBA(364,IBB364,0)),U,4),".",1)
"RTN","IBCECOB1",71,0)
 ;
"RTN","IBCECOB1",72,0)
 S IBAPY=$$TPR^PRCAFN(IBIFN) ; payment on this bill from A/R
"RTN","IBCECOB1",73,0)
 S IBEXPY=+$G(^IBM(361.1,IBDA,1))       ; payer paid amount
"RTN","IBCECOB1",74,0)
 ; IB*2.0*447 add excess indicator to MRW screen and adjust calcs to include percentages
"RTN","IBCECOB1",75,0)
 S IBPTRSP=$S($$MSEDT^IBCEMU4(IBIFN)'="":$$MSPRE^IBCEMU4(IBIFN,1),1:$$PREOBTOT^IBCEU0(IBIFN)) ; patient resp. function
"RTN","IBCECOB1",76,0)
 S IBPY=$S(IBAPY:IBAPY,1:IBEXPY)
"RTN","IBCECOB1",77,0)
 S IBOAM=+$G(^DGCR(399,IBIFN,"U1"))     ; total charges for bill
"RTN","IBCECOB1",78,0)
 S IBNBAL=IBOAM-IBPY
"RTN","IBCECOB1",79,0)
 I IBNBAL'>0 S IBQ=2
"RTN","IBCECOB1",80,0)
 S IBPTNM=$P($G(^DPT(+$P($G(^DGCR(399,IBIFN,0)),U,2),0)),U) I IBPTNM="" S IBPTNM="UNKNOWN"
"RTN","IBCECOB1",81,0)
 S IBSRVC=$P($G(^DGCR(399,IBIFN,"U")),U)
"RTN","IBCECOB1",82,0)
 S Z0=$S(IBSRT="B":IBMUT,IBSRT="D":-IBDAY,IBSRT="I":$P(IBINS2,U,2)_"~"_$P(IBINS2,U),IBSRT="M":$$EXTERNAL^DILFD(361.1,.13,"",$P(IB3611,"^",13)),IBSRT="R":-IBPTRSP,IBSRT="P":IBPTNM,IBSRT="S":+IBSRVC,1:+IBDT)
"RTN","IBCECOB1",83,0)
 S:((IBSRT="M")&(Z0="")) Z0="UNKNOWN"   ;USE UNKNOWN IF NOT SET - BI;IB*2.0*432
"RTN","IBCECOB1",84,0)
 S ^TMP("IBCOBST",$J,Z0,IBIFN)=IBSRVC_U_IBOAM_U_IBAPY_U_$S(IBNBAL>0:IBNBAL,1:0)_U_$P(IBB,U,5)_U_$P(IBB,U,19)_U_IBBPY_U_$P(IBMUT,"~")_U_IBINS_U_IBDA_U_$$HIS(IBIFN)_U_IBDAY_U_IBDT_U_IBQ_U_IB364_U_IBSEQ_U_IBEXPY_U_IBPTRSP
"RTN","IBCECOB1",85,0)
 S ^TMP("IBCOBST",$J,Z0,IBIFN,1)=$$EXTERNAL^DILFD(361.1,.13,"",$P(IB3611,"^",13))_", "_$$FMTE^XLFDT($P($P(IB3611,"^",6),"."))_"^"_$P(IB3611,"^",16)
"RTN","IBCECOB1",86,0)
 S ^TMP("IBCOBSTX",$J,IBIFN)=IBDA  ;keep track of compiled IBIFN's
"RTN","IBCECOB1",87,0)
 ;
"RTN","IBCECOB1",88,0)
 ; Save some data when there are multiple MRA's on file for this bill
"RTN","IBCECOB1",89,0)
 S IBMRACNT=$$MRACNT^IBCEMU1(IBIFN,$G(IBMRANOT))   ;WCJ IB*2.0*432
"RTN","IBCECOB1",90,0)
 I IBMRACNT>1 S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,1)="Multiple "_$S($G(IBMRANOT):"EOBs",1:"MRA's")_" on file"  ;WCJ IB*2.0*432
"RTN","IBCECOB1",91,0)
 S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,3)=IBMRACNT
"RTN","IBCECOB1",92,0)
 S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,4)=IBDENDUP
"RTN","IBCECOB1",93,0)
 Q
"RTN","IBCECOB1",94,0)
 ;
"RTN","IBCECOB1",95,0)
HIS(IBIFN) ; COB history
"RTN","IBCECOB1",96,0)
 N A,B,IBST,IBBIL,IBHIS
"RTN","IBCECOB1",97,0)
 S IBHIS="",A=0 F  S A=$O(^IBM(361.1,"ABS",IBIFN,A)) Q:'A  S B=0 F  S B=$O(^IBM(361.1,"ABS",IBIFN,A,B)) Q:'B  D
"RTN","IBCECOB1",98,0)
 . S IBST=$P($G(^IBM(361.1,B,0)),U,4),IBBIL=$P($G(^DGCR(399,IBIFN,"M1")),U,4+A)   ;WCJ IB*2.0*432 added $G
"RTN","IBCECOB1",99,0)
 . Q:IBBIL=""
"RTN","IBCECOB1",100,0)
 . S IBHIS=IBHIS_$S(IBHIS="":"",1:";")_$S(A=1:"PRIMARY",A=2:"SECONDARY",1:"TERTIARY")_" "_$S(IBST:"MRA",1:"EOB")_" RECEIVED - "_IBBIL
"RTN","IBCECOB1",101,0)
 Q IBHIS
"RTN","IBCECOB1",102,0)
 ;
"RTN","IBCECOB1",103,0)
NMAT ;No COB list
"RTN","IBCECOB1",104,0)
 S VALMCNT=2,IBCNT=2
"RTN","IBCECOB1",105,0)
 S ^TMP("IBCECOB",$J,1,0)=" "
"RTN","IBCECOB1",106,0)
 S ^TMP("IBCECOB",$J,2,0)="    No "_$S($G(IBMRANOT)=1:"EOB's",1:"MRA's")_" Matching Selection Criteria Were Found"
"RTN","IBCECOB1",107,0)
 Q
"RTN","IBCECOB1",108,0)
 ;
"RTN","IBCECOB1",109,0)
SCRN ;
"RTN","IBCECOB1",110,0)
 N IBX,IBCNT,IBIFN,IBDA,IB,X,IBS1,IBPAT,Z,IBK,IBFORM
"RTN","IBCECOB1",111,0)
 S IBCNT=0
"RTN","IBCECOB1",112,0)
 S IBS1=$S(IBSRT="B":"BILLER",IBSRT="D":"Days Since Last Transmission",IBSRT="L":"Date Last "_$S($G(IBMRANOT):"EOB",1:"MRA")_" Received",IBSRT="I":"SECONDARY INSURANCE COMPANY",IBSRT="M":$S($G(IBMRANOT):"EOB",1:"MRA")_" Status",1:"")
"RTN","IBCECOB1",113,0)
 S IBX="" F  S IBX=$O(^TMP("IBCOBST",$J,IBX)) Q:IBX=""  D
"RTN","IBCECOB1",114,0)
 . I IBSRT="B"!(IBSRT="I")!(IBSRT="M") D
"RTN","IBCECOB1",115,0)
 .. D:IBCNT SET("",IBCNT+1)
"RTN","IBCECOB1",116,0)
 .. D SET(IBS1_": "_$P(IBX,"~"),IBCNT+1)
"RTN","IBCECOB1",117,0)
 . S IBIFN=0 F  S IBIFN=$O(^TMP("IBCOBST",$J,IBX,IBIFN)) Q:'IBIFN  D
"RTN","IBCECOB1",118,0)
 .. S IB=$G(^TMP("IBCOBST",$J,IBX,IBIFN))
"RTN","IBCECOB1",119,0)
 .. S Z=$G(^DPT(+$P($G(^DGCR(399,IBIFN,0)),U,2),0))
"RTN","IBCECOB1",120,0)
 .. S IBPAT=$$LJ^XLFSTR($E($P(Z,U),1,18),18," ")_" "_$E($P(Z,U,9),6,9)
"RTN","IBCECOB1",121,0)
 .. S IBDA=$P(IB,U,10) ;361.1-ien
"RTN","IBCECOB1",122,0)
 .. S IBQ=$P(IB,U,14),IB364=$P(IB,U,15)
"RTN","IBCECOB1",123,0)
 .. ; IB*2.0*447 shorten form column to I for Instutional and P for Professional
"RTN","IBCECOB1",124,0)
 .. ;S IBFORM=$$EXTERNAL^DILFD(399,.19,,+$P(IB,U,6))
"RTN","IBCECOB1",125,0)
 .. ;I +$P(IB,U,6)=2 S IBFORM=1500   ; for space reasons
"RTN","IBCECOB1",126,0)
 .. S IBFORM=$S(+$P(IB,U,6)=2:"P",1:"I")
"RTN","IBCECOB1",127,0)
 .. S IBPTRSP=$P(IB,U,18)
"RTN","IBCECOB1",128,0)
 .. S IBAMT=$P(IB,U,2)
"RTN","IBCECOB1",129,0)
 .. S IBCNT=IBCNT+1
"RTN","IBCECOB1",130,0)
 .. S X=""
"RTN","IBCECOB1",131,0)
 .. S X=$$SETFLD^VALM1(IBCNT,X,"NUMBER")
"RTN","IBCECOB1",132,0)
 .. S X=$$SETFLD^VALM1($$BN1^PRCAFN(IBIFN)_$S($P($G(^DGCR(399,IBIFN,"TX")),U,10)=1:"*",1:""),X,"BILL")
"RTN","IBCECOB1",133,0)
 .. S X=$$SETFLD^VALM1($$DAT1^IBOUTL($P(IB,U)),X,"SERVICE")
"RTN","IBCECOB1",134,0)
 .. S X=$$SETFLD^VALM1(IBPAT,X,"PATNM")
"RTN","IBCECOB1",135,0)
 .. S X=$$SETFLD^VALM1($$RJ^XLFSTR($FN(IBPTRSP,"",2),9," "),X,"PTRESP")
"RTN","IBCECOB1",136,0)
 .. S X=$$SETFLD^VALM1($$RJ^XLFSTR($FN(IBAMT,"",2),9," "),X,"IBAMT")
"RTN","IBCECOB1",137,0)
 .. S X=$$SETFLD^VALM1($E($$TYPE^IBJTLA1($P(IB,U,5)))_"/"_IBFORM,X,"BTYPE")
"RTN","IBCECOB1",138,0)
 .. D SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB)
"RTN","IBCECOB1",139,0)
 .. ;For R (Pt Resp), P (Pt Name) and S (Service Date) don't display sub-headers
"RTN","IBCECOB1",140,0)
 .. I "BIMRPS"'[IBSRT D
"RTN","IBCECOB1",141,0)
 ... S Z=$S(IBSRT="L":$$DAT1^IBOUTL(IBX),IBSRT="D":-IBX,1:IBX)
"RTN","IBCECOB1",142,0)
 ... D SET("   "_IBS1_": "_Z,IBCNT)
"RTN","IBCECOB1",143,0)
 .. S X=$$SETSTR^VALM1("Insurers:  "_$P(IB,U,9),"",7,74)
"RTN","IBCECOB1",144,0)
 .. D SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB)
"RTN","IBCECOB1",145,0)
 .. ;
"RTN","IBCECOB1",146,0)
 .. ; line 3 of display:  MRA status/date/split claim indicator
"RTN","IBCECOB1",147,0)
 .. S X=$$SETSTR^VALM1($S($G(IBMRANOT):"EOB",1:"MRA")_" Status:  ","",5,13)
"RTN","IBCECOB1",148,0)
 .. S IBK=$G(^TMP("IBCOBST",$J,IBX,IBIFN,1))
"RTN","IBCECOB1",149,0)
 .. S X=$$SETSTR^VALM1($P(IBK,U,1),X,18,63)
"RTN","IBCECOB1",150,0)
 .. I $P(IBK,U,2)=2 S X=$$SETSTR^VALM1("** SPLIT CLAIM **",X,63,18)
"RTN","IBCECOB1",151,0)
 .. I $P(IBK,U,4),$P(IBK,U,2)'=2,$P(IBK,U,3)=1 S X=$$SETSTR^VALM1("** Denied for Duplicate **",X,54,27)
"RTN","IBCECOB1",152,0)
 .. D SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB)
"RTN","IBCECOB1",153,0)
 .. ;
"RTN","IBCECOB1",154,0)
 .. ; conditionally update video attributes of line 3
"RTN","IBCECOB1",155,0)
 .. I '$D(IOINHI) D ENS^%ZISS
"RTN","IBCECOB1",156,0)
 .. ; split claim
"RTN","IBCECOB1",157,0)
 .. I $P(IBK,U,2)=2 D CNTRL^VALM10(VALMCNT,63,17,IOINHI,IOINORM)
"RTN","IBCECOB1",158,0)
 .. ; multiple mra's on file
"RTN","IBCECOB1",159,0)
 .. I $P(IBK,U,3)>1 D CNTRL^VALM10(VALMCNT,18,22,IOINHI,IOINORM)
"RTN","IBCECOB1",160,0)
 .. ; Denied for Duplicate - no split claim and single MRA only
"RTN","IBCECOB1",161,0)
 .. I $P(IBK,U,4),$P(IBK,U,2)'=2,$P(IBK,U,3)=1 D CNTRL^VALM10(VALMCNT,54,26,IOINHI,IOINORM)
"RTN","IBCECOB1",162,0)
 .. Q
"RTN","IBCECOB1",163,0)
 Q
"RTN","IBCECOB1",164,0)
 ;
"RTN","IBCECOB1",165,0)
SET(X,CNT,IBIFN,IBDA,IBQ,IB364,IBX,IB) ;set up list manager screen array
"RTN","IBCECOB1",166,0)
 S VALMCNT=VALMCNT+1
"RTN","IBCECOB1",167,0)
 S ^TMP("IBCECOB",$J,VALMCNT,0)=X
"RTN","IBCECOB1",168,0)
 S ^TMP("IBCECOB",$J,"IDX",VALMCNT,CNT)=""
"RTN","IBCECOB1",169,0)
 I $G(IBIFN),$G(^TMP("IBCECOB",$J,CNT))="" S ^TMP("IBCECOB",$J,CNT)=VALMCNT_U_IBIFN_U_IB364_U_IBDA_U_IBQ_U_IBX,^TMP("IBCECOB1",$J,CNT)=IB
"RTN","IBCECOB1",170,0)
 Q
"RTN","IBCECOB1",171,0)
 ;
"RTN","IBCECOB1",172,0)
FTYPE(Y) ;type classification
"RTN","IBCECOB1",173,0)
 Q $E($P($G(^IBE(353,Y,0)),U),1,8)
"RTN","IBCECOB1",174,0)
 ;
"RTN","IBCECOB1",175,0)
PTRESPI(IBEOB) ; Function - Computes the Patient's Responsibility based on IBEOB
"RTN","IBCECOB1",176,0)
 ; of 361.1 for Claims/Bills with form type 3=UB
"RTN","IBCECOB1",177,0)
 ; Input IBEOB - a single EOB ien; Required
"RTN","IBCECOB1",178,0)
 ; Output      - Function Returns IBPTRES - Patient Responsibility Amount for the EOB
"RTN","IBCECOB1",179,0)
 ;
"RTN","IBCECOB1",180,0)
 N IBPTRES,IBC,EOBADJ
"RTN","IBCECOB1",181,0)
 S IBPTRES=0,IBEOB=+$G(IBEOB)
"RTN","IBCECOB1",182,0)
 I 'IBEOB Q IBPTRES   ;PTRESPI
"RTN","IBCECOB1",183,0)
 ; filing error
"RTN","IBCECOB1",184,0)
 Q:$D(^IBM(361.1,IBEOB,"ERR")) IBPTRES
"RTN","IBCECOB1",185,0)
 ;
"RTN","IBCECOB1",186,0)
 ; get claim level adjustments
"RTN","IBCECOB1",187,0)
 K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,10)
"RTN","IBCECOB1",188,0)
 S IBPTRES=$$CALCPR^IBCEU0(.EOBADJ)
"RTN","IBCECOB1",189,0)
 ;
"RTN","IBCECOB1",190,0)
 ; get line level adjustments
"RTN","IBCECOB1",191,0)
 S IBC=0 F  S IBC=$O(^IBM(361.1,IBEOB,15,IBC)) Q:'IBC  D
"RTN","IBCECOB1",192,0)
 . K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,15,IBC,1)
"RTN","IBCECOB1",193,0)
 . S IBPTRES=IBPTRES+$$CALCPR^IBCEU0(.EOBADJ)
"RTN","IBCECOB1",194,0)
 Q IBPTRES
"RTN","IBCECOB1",195,0)
 ;
"RTN","IBCECOB1",196,0)
ELIG(IBEOB) ; Function to determine if an EOB entry is eligible for
"RTN","IBCECOB1",197,0)
 ; inclusion on the MRA or COB management worklist or not.
"RTN","IBCECOB1",198,0)
 ; IBEOB - ien into file 361.1 (required)
"RTN","IBCECOB1",199,0)
 ; Returns 1 if EOB should appear on the worklist
"RTN","IBCECOB1",200,0)
 ; Returns 0 if EOB should not appear on the worklist
"RTN","IBCECOB1",201,0)
 ;
"RTN","IBCECOB1",202,0)
 NEW ELIG,IB3611,IBIFN
"RTN","IBCECOB1",203,0)
 S ELIG=0,IBEOB=+$G(IBEOB)
"RTN","IBCECOB1",204,0)
 S IB3611=$G(^IBM(361.1,IBEOB,0))
"RTN","IBCECOB1",205,0)
 I $P(IB3611,U,4)'=1 G ELIGX    ; eob type must be correct for this worklist
"RTN","IBCECOB1",206,0)
 I $P(IB3611,U,16)>2 G ELIGX    ; review status must be <= 2
"RTN","IBCECOB1",207,0)
 S IBIFN=+IB3611
"RTN","IBCECOB1",208,0)
 I $P($G(^DGCR(399,IBIFN,0)),U,13)'=2 G ELIGX  ; Request MRA bill status
"RTN","IBCECOB1",209,0)
 I $D(^IBM(361.1,IBEOB,"ERR")) G ELIGX         ; filing errors
"RTN","IBCECOB1",210,0)
 ;
"RTN","IBCECOB1",211,0)
 S ELIG=1    ; this EOB is eligible for the worklist
"RTN","IBCECOB1",212,0)
 ;
"RTN","IBCECOB1",213,0)
ELIGX ;
"RTN","IBCECOB1",214,0)
 Q ELIG
"RTN","IBCECOB1",215,0)
 ;
"RTN","IBCECOB1",216,0)
WLRMV ; REMOVE FROM EOB WORK LIST
"RTN","IBCECOB1",217,0)
 ; IBDA(IBDA)=IBIFN^IB364^ien of 361.1^user selection seq^user name~duz#
"RTN","IBCECOB1",218,0)
 N IBIFN,IBDA,DIR,DTOUT,DUOUT,DA,DIE,DR,X
"RTN","IBCECOB1",219,0)
 D SEL^IBCECOB2(.IBDA,1)
"RTN","IBCECOB1",220,0)
 S VALMBCK="R"
"RTN","IBCECOB1",221,0)
 S IBDA=$O(IBDA(0)) I 'IBDA Q
"RTN","IBCECOB1",222,0)
 S IBIFN=$P(IBDA(IBDA),U,1) I 'IBIFN Q
"RTN","IBCECOB1",223,0)
 S DIR("A",1)=""
"RTN","IBCECOB1",224,0)
 S DIR("A",2)="    Bill #: "_$$GET1^DIQ(399,IBIFN_", ",.01,"E")
"RTN","IBCECOB1",225,0)
 S DIR("A",3)="   Patient: "_$$GET1^DIQ(399,IBIFN_", ",.02,"E")
"RTN","IBCECOB1",226,0)
 S DIR("A",4)=" Bill Type: "_$$GET1^DIQ(399,IBIFN_", ",.05,"E")
"RTN","IBCECOB1",227,0)
 S DIR("A",5)="Bill Dates: "_$$GET1^DIQ(399,IBIFN_", ",151,"E")_" - "_$$GET1^DIQ(399,IBIFN_", ",152,"E")
"RTN","IBCECOB1",228,0)
 S DIR("A",6)=" "
"RTN","IBCECOB1",229,0)
 S DIR("A")="Are you sure remove this claim from the worklist? "
"RTN","IBCECOB1",230,0)
 S DIR("B")="NO"
"RTN","IBCECOB1",231,0)
 S DIR(0)="YA" D ^DIR K DIR
"RTN","IBCECOB1",232,0)
 I $D(DTOUT)!$D(DUOUT)!'Y Q
"RTN","IBCECOB1",233,0)
 ;FLAG IF USER ANSWERS YES
"RTN","IBCECOB1",234,0)
 S X=$$WLRMVF^IBCECOB1(IBIFN,"RM")
"RTN","IBCECOB1",235,0)
 D BLD^IBCECOB1
"RTN","IBCECOB1",236,0)
 Q
"RTN","IBCECOB1",237,0)
 ;
"RTN","IBCECOB1",238,0)
WLRMVF(IBIFN,METHOD,BKFL) ;
"RTN","IBCECOB1",239,0)
 ; BFKL = 1 means background process, remove NOT initiated by a user
"RTN","IBCECOB1",240,0)
 N SOC,SOCCNT,SOCLIST,STATUS,IBDUZ
"RTN","IBCECOB1",241,0)
 S STATUS=0
"RTN","IBCECOB1",242,0)
 Q:'$G(DUZ) STATUS_"^MISSING DUZ"
"RTN","IBCECOB1",243,0)
 Q:'$G(IBIFN) STATUS_"^MISSING IBIFN"
"RTN","IBCECOB1",244,0)
 Q:'$D(^DGCR(399,IBIFN)) STATUS_"^INVALID IBIFN"
"RTN","IBCECOB1",245,0)
 ; if this is a background process, set user who removed to AUTHORIZER,IB REG
"RTN","IBCECOB1",246,0)
 S IBDUZ=$S($G(BKFL)=1:$$IBREG^IBCAPP(),1:$G(DUZ))
"RTN","IBCECOB1",247,0)
 ; GET DICTIONARY SET OF CODES.
"RTN","IBCECOB1",248,0)
 ; SOC("POINTER")="RM:REMOVE ACTION;PC:PROCESS COB ACTION;CL:CLONE ACTION;"
"RTN","IBCECOB1",249,0)
 D FIELD^DID(399,38,"","POINTER","SOC")
"RTN","IBCECOB1",250,0)
 S SOC=$G(SOC("POINTER"))
"RTN","IBCECOB1",251,0)
 F SOCCNT=1:1:$L(SOC,";")-1 S SOCLIST($P($P(SOC,";",SOCCNT),":",1))=""
"RTN","IBCECOB1",252,0)
 Q:$D(SOCLIST(METHOD))=0 STATUS_"^INVALID METHOD"
"RTN","IBCECOB1",253,0)
 S DA=IBIFN
"RTN","IBCECOB1",254,0)
 S DIE="^DGCR(399,"
"RTN","IBCECOB1",255,0)
 S DR="35////4"                ; AUTO PROCESS, NO LONGER ON WORKLIST
"RTN","IBCECOB1",256,0)
 S:IBDUZ'=-1 DR=DR_";"_"37////"_IBDUZ    ; WHO REMOVED FROM WORKLIST
"RTN","IBCECOB1",257,0)
 S DR=DR_";"_"38////"_METHOD   ; METHOD USED TO REMOVE FROM WORKLIST
"RTN","IBCECOB1",258,0)
 S DR=DR_";"_"39///NOW"        ; DATE STAMP WHEN REMOVED FOR WORKLIST
"RTN","IBCECOB1",259,0)
 D ^DIE
"RTN","IBCECOB1",260,0)
 S STATUS=1
"RTN","IBCECOB1",261,0)
 Q STATUS
"RTN","IBCECOB2")
0^23^B167373990
"RTN","IBCECOB2",1,0)
IBCECOB2 ;ALB/CXW - IB COB MANAGEMENT SCREEN ;16-JUN-1999
"RTN","IBCECOB2",2,0)
 ;;2.0;INTEGRATED BILLING;**137,155,433,432,447**;21-MAR-1994;Build 80
"RTN","IBCECOB2",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCECOB2",4,0)
 ;
"RTN","IBCECOB2",5,0)
EDI ;history detail display
"RTN","IBCECOB2",6,0)
 N IBIFN,IBDA
"RTN","IBCECOB2",7,0)
 D SEL(.IBDA,1)
"RTN","IBCECOB2",8,0)
 S IBDA=+$O(IBDA(0)),IBIFN=+$G(IBDA(IBDA))
"RTN","IBCECOB2",9,0)
 D EDI1(IBIFN)
"RTN","IBCECOB2",10,0)
 S VALMBCK="R"
"RTN","IBCECOB2",11,0)
 Q
"RTN","IBCECOB2",12,0)
 ;
"RTN","IBCECOB2",13,0)
EDI1(IBIFN) ;
"RTN","IBCECOB2",14,0)
 N DFN
"RTN","IBCECOB2",15,0)
 Q:'IBIFN
"RTN","IBCECOB2",16,0)
 S DFN=$P($G(^DGCR(399,IBIFN,0)),U,2)
"RTN","IBCECOB2",17,0)
 D EN^VALM("IBJT EDI STATUS")
"RTN","IBCECOB2",18,0)
 K:$D(IBFASTXT) IBFASTXT
"RTN","IBCECOB2",19,0)
 Q
"RTN","IBCECOB2",20,0)
 ;
"RTN","IBCECOB2",21,0)
EDI2(IBIFN) ;
"RTN","IBCECOB2",22,0)
 N DFN
"RTN","IBCECOB2",23,0)
 Q:'IBIFN
"RTN","IBCECOB2",24,0)
 S DFN=$P($G(^DGCR(399,IBIFN,0)),U,2)
"RTN","IBCECOB2",25,0)
 D EN^VALM("IBJT EDI STATUS ALONE")
"RTN","IBCECOB2",26,0)
 K:$D(IBFASTXT) IBFASTXT
"RTN","IBCECOB2",27,0)
 Q
"RTN","IBCECOB2",28,0)
 ;
"RTN","IBCECOB2",29,0)
CSA ;claims status awaiting resolution
"RTN","IBCECOB2",30,0)
 N IBDAX
"RTN","IBCECOB2",31,0)
 D EN^IBCECSA
"RTN","IBCECOB2",32,0)
 I $D(IBFASTXT) K IBFASTXT
"RTN","IBCECOB2",33,0)
 S VALMBCK="R"
"RTN","IBCECOB2",34,0)
 Q
"RTN","IBCECOB2",35,0)
 ;
"RTN","IBCECOB2",36,0)
RVEOB ;Review EOB
"RTN","IBCECOB2",37,0)
 D FULL^VALM1 W !
"RTN","IBCECOB2",38,0)
 N IBDA,IBIFN,IBCMT,IBSEL
"RTN","IBCECOB2",39,0)
 D SEL(.IBDA,1)
"RTN","IBCECOB2",40,0)
 S IBSEL=+$O(IBDA(0))
"RTN","IBCECOB2",41,0)
 S IBDA=$G(IBDA(IBSEL))
"RTN","IBCECOB2",42,0)
 S IBIFN=$P(IBDA,U),IBDA=$P(IBDA,U,3)
"RTN","IBCECOB2",43,0)
 I 'IBIFN G VEOBQ
"RTN","IBCECOB2",44,0)
 S IBCMT=$G(^TMP("IBCECOB1",$J,IBSEL))
"RTN","IBCECOB2",45,0)
 I IBCMT'="" D EN^VALM("IBCEM MRA REVIEW")
"RTN","IBCECOB2",46,0)
VEOBQ K ^TMP("IBCECOC",$J)
"RTN","IBCECOB2",47,0)
 S VALMBCK="R"
"RTN","IBCECOB2",48,0)
 Q
"RTN","IBCECOB2",49,0)
 ;
"RTN","IBCECOB2",50,0)
TPJI ;Third Party joint Inquiry
"RTN","IBCECOB2",51,0)
 N IBDA,IBIFN
"RTN","IBCECOB2",52,0)
 D SEL(.IBDA,1)
"RTN","IBCECOB2",53,0)
 S IBDA=+$O(IBDA(0)),IBIFN=+$G(IBDA(IBDA))
"RTN","IBCECOB2",54,0)
 I IBDA="" G TPJIQ
"RTN","IBCECOB2",55,0)
 D TPJI1(IBIFN)
"RTN","IBCECOB2",56,0)
TPJIQ S VALMBCK="R"
"RTN","IBCECOB2",57,0)
 Q
"RTN","IBCECOB2",58,0)
 ;
"RTN","IBCECOB2",59,0)
TPJI1(IBIFN) ;
"RTN","IBCECOB2",60,0)
 N DFN,IBNOTPJI
"RTN","IBCECOB2",61,0)
 Q:'IBIFN
"RTN","IBCECOB2",62,0)
 S DFN=$P($G(^DGCR(399,IBIFN,0)),U,2),IBNOTPJI=1
"RTN","IBCECOB2",63,0)
 D EN^VALM("IBJT CLAIM INFO")
"RTN","IBCECOB2",64,0)
 K:$D(IBFASTXT) IBFASTXT
"RTN","IBCECOB2",65,0)
 Q
"RTN","IBCECOB2",66,0)
 ;
"RTN","IBCECOB2",67,0)
PBILL ;Print bill
"RTN","IBCECOB2",68,0)
 N IBIFN,IBDA,IBRESUB
"RTN","IBCECOB2",69,0)
 D SEL(.IBDA,1)
"RTN","IBCECOB2",70,0)
 S IBDA=$O(IBDA(0)),IBIFN=+$G(IBDA(+IBDA))
"RTN","IBCECOB2",71,0)
 I IBDA="" G PBOUT
"RTN","IBCECOB2",72,0)
 S IBRESUB=$$RESUB^IBCECSA4(IBIFN,1,"P")
"RTN","IBCECOB2",73,0)
 I IBRESUB'>0 W !,*7,"This is not a transmittable bill or review not needed" D PAUSE^VALM1 G PBOUT
"RTN","IBCECOB2",74,0)
 I IBRESUB=2 D  G PBOUT
"RTN","IBCECOB2",75,0)
 . N IB364
"RTN","IBCECOB2",76,0)
 . S IB364=+$P($G(IBDA(IBDA)),U,2)
"RTN","IBCECOB2",77,0)
 . D PRINT1^IBCEM03(IBIFN,.IBDA,IB364)
"RTN","IBCECOB2",78,0)
 D PBILL1(IBIFN)
"RTN","IBCECOB2",79,0)
PBOUT S VALMBCK="R"
"RTN","IBCECOB2",80,0)
 Q
"RTN","IBCECOB2",81,0)
 ;
"RTN","IBCECOB2",82,0)
PMRA ;Print MRA
"RTN","IBCECOB2",83,0)
 N IBIFN,IBDA
"RTN","IBCECOB2",84,0)
 D SEL(.IBDA,1)
"RTN","IBCECOB2",85,0)
 S IBDA=$O(IBDA(0)),IBIFN=+$G(IBDA(+IBDA))
"RTN","IBCECOB2",86,0)
 G:'IBIFN PRMQ
"RTN","IBCECOB2",87,0)
 D MRA^IBCEMRAA(.IBIFN)
"RTN","IBCECOB2",88,0)
PRMQ S VALMBCK="R"
"RTN","IBCECOB2",89,0)
 Q
"RTN","IBCECOB2",90,0)
PBILL1(IBIFN) ;
"RTN","IBCECOB2",91,0)
 N IBAC1,IBAC,DFN
"RTN","IBCECOB2",92,0)
 Q:'IBIFN
"RTN","IBCECOB2",93,0)
 S DFN=$P($G(^DGCR(399,IBIFN,0)),U,2)
"RTN","IBCECOB2",94,0)
 S IBAC=4,IBAC1=1
"RTN","IBCECOB2",95,0)
 D 4^IBCB1
"RTN","IBCECOB2",96,0)
 D FULL^VALM1,PAUSE^VALM1
"RTN","IBCECOB2",97,0)
 Q
"RTN","IBCECOB2",98,0)
 ;
"RTN","IBCECOB2",99,0)
CANCEL ;Cancel bill
"RTN","IBCECOB2",100,0)
 ; IBDA(IBDA)=IBIFN^IB364^ien of 361.1^user selection seq^user name~duz#
"RTN","IBCECOB2",101,0)
 ;
"RTN","IBCECOB2",102,0)
 N IBIFN,IBDA,IB364,IBEOBIFN,X,IBDENCT
"RTN","IBCECOB2",103,0)
 ;
"RTN","IBCECOB2",104,0)
 ; Check for security key
"RTN","IBCECOB2",105,0)
 I '$$KCHK^XUSRB("IB AUTHORIZE") D  G CANCELQ
"RTN","IBCECOB2",106,0)
 . D FULL^VALM1 S VALMBCK="R"
"RTN","IBCECOB2",107,0)
 . W !!?5,"You don't hold the proper security key to access this function."
"RTN","IBCECOB2",108,0)
 . W !?5,"The necessary key is IB AUTHORIZE.  Please see your manager."
"RTN","IBCECOB2",109,0)
 . D PAUSE^VALM1
"RTN","IBCECOB2",110,0)
 . Q
"RTN","IBCECOB2",111,0)
 ;
"RTN","IBCECOB2",112,0)
 D SEL(.IBDA,1)
"RTN","IBCECOB2",113,0)
 S IBDA=$O(IBDA(0)),IBIFN=+$G(IBDA(+IBDA)),IB364=$P($G(IBDA(+IBDA)),U,2)
"RTN","IBCECOB2",114,0)
 S IBEOBIFN=$P($G(IBDA(+IBDA)),U,3)
"RTN","IBCECOB2",115,0)
 ;
"RTN","IBCECOB2",116,0)
 ; IB*2.0*432 - if not mra, only allow cancel of denied claims.  If no EOB, check AR status instead
"RTN","IBCECOB2",117,0)
 I 'IBEOBIFN,$G(IBMRANOT)=1,$P($$ARSTATA^IBJTU4(IBIFN),U)="COLLECTED/CLOSED" D  G CANCELQ
"RTN","IBCECOB2",118,0)
 . D FULL^VALM1 S VALMBCK="R"
"RTN","IBCECOB2",119,0)
 . W !!,*7,"You can only cancel denied claims.  This claim is in a COLLECTED/CLOSED status"
"RTN","IBCECOB2",120,0)
 . W !,"Use Remove Action to remove claim from this worklist."
"RTN","IBCECOB2",121,0)
 . D PAUSE^VALM1
"RTN","IBCECOB2",122,0)
 . Q
"RTN","IBCECOB2",123,0)
 ;
"RTN","IBCECOB2",124,0)
 ; IB*2.0*432 - if not mra, only allow cancel of claims with multiple EOBS if none have processed.
"RTN","IBCECOB2",125,0)
 I $G(IBMRANOT)=1,'$$DENCHK(IBIFN,.IBDENCT),$G(IBDENCT)>1 D  G CANCELQ
"RTN","IBCECOB2",126,0)
 . D FULL^VALM1 S VALMBCK="R"
"RTN","IBCECOB2",127,0)
 . W !!,*7,"Multiple EOBs exist for this claim and at least one has EOB status of PROCESSED."
"RTN","IBCECOB2",128,0)
 . W !,"Use Remove Action to remove claim from this worklist."
"RTN","IBCECOB2",129,0)
 . D PAUSE^VALM1
"RTN","IBCECOB2",130,0)
 . Q
"RTN","IBCECOB2",131,0)
 ;
"RTN","IBCECOB2",132,0)
 ; IB*2.0*432 - if not mra, only allow cancel of denied claims
"RTN","IBCECOB2",133,0)
 I IBEOBIFN,$G(IBMRANOT)=1,$P($G(^IBM(361.1,IBEOBIFN,0)),U,13)'=2 D  G CANCELQ
"RTN","IBCECOB2",134,0)
 . D FULL^VALM1 S VALMBCK="R"
"RTN","IBCECOB2",135,0)
 . W !!?5,*7,"You can only cancel denied claims."
"RTN","IBCECOB2",136,0)
 . D PAUSE^VALM1
"RTN","IBCECOB2",137,0)
 . Q
"RTN","IBCECOB2",138,0)
 ;
"RTN","IBCECOB2",139,0)
 I IBDA D
"RTN","IBCECOB2",140,0)
 . I '$$LOCK^IBCEU0(361.1,IBEOBIFN) Q
"RTN","IBCECOB2",141,0)
 . D CANCEL^IBCEM3(.IBDA,IBIFN,IB364)
"RTN","IBCECOB2",142,0)
 . D UNLOCK^IBCEU0(361.1,IBEOBIFN)
"RTN","IBCECOB2",143,0)
 S VALMBCK="R"
"RTN","IBCECOB2",144,0)
 ;
"RTN","IBCECOB2",145,0)
 ; for non-MRA claims cancelled from worklist, set field 38
"RTN","IBCECOB2",146,0)
 I $G(IBMRANOT)=1,$P($G(^DGCR(399,IBIFN,0)),U,13)=7 S X=$$WLRMVF^IBCECOB1($S($G(IBIFN)'="":IBIFN,1:+$G(IBDA(IBDA))),"CA")
"RTN","IBCECOB2",147,0)
 I $G(IBDA)'="" D BLD^IBCECOB1
"RTN","IBCECOB2",148,0)
CANCELQ Q
"RTN","IBCECOB2",149,0)
 ;
"RTN","IBCECOB2",150,0)
CRD ; Correct Rejected/Denied claim protocol action
"RTN","IBCECOB2",151,0)
 N IBCNCRD
"RTN","IBCECOB2",152,0)
 S IBCNCRD=1
"RTN","IBCECOB2",153,0)
CLONE ; 'Copy/cancel bill' protocol action
"RTN","IBCECOB2",154,0)
 N IBDA,IBQ,IBEOBIFN,IBKEY,X,IBDENCT
"RTN","IBCECOB2",155,0)
 ;
"RTN","IBCECOB2",156,0)
 ; Check for security key
"RTN","IBCECOB2",157,0)
 ;I '$$KCHK^XUSRB("IB AUTHORIZE") D  G CLONEQ
"RTN","IBCECOB2",158,0)
 S IBKEY=$S($G(IBCNCRD)=1:"IB AUTHORIZE",1:"IB CLON")
"RTN","IBCECOB2",159,0)
 I '$$KCHK^XUSRB(IBKEY) D  G CLONEQ
"RTN","IBCECOB2",160,0)
 . D FULL^VALM1 S VALMBCK="R"
"RTN","IBCECOB2",161,0)
 . ;W !!?5,"You don't hold the proper security key to access this function."
"RTN","IBCECOB2",162,0)
 . ;W !?5,"The necessary key is IB AUTHORIZE.  Please see your manager."
"RTN","IBCECOB2",163,0)
 . W !!?5,"You must hold the "_IBKEY_" security key to access this function."
"RTN","IBCECOB2",164,0)
 . W !?5,"Please see your manager."
"RTN","IBCECOB2",165,0)
 . D PAUSE^VALM1
"RTN","IBCECOB2",166,0)
 . Q
"RTN","IBCECOB2",167,0)
 ;
"RTN","IBCECOB2",168,0)
 D SEL(.IBDA,1)
"RTN","IBCECOB2",169,0)
 S IBDA=$O(IBDA(""))
"RTN","IBCECOB2",170,0)
 I IBDA="" G CLONEQ
"RTN","IBCECOB2",171,0)
 ;
"RTN","IBCECOB2",172,0)
 ; IB*2.0*432 - if not mra, only allow cancel of claims with multiple EOBS if none have processed.
"RTN","IBCECOB2",173,0)
 I $G(IBMRANOT)=1,'$$DENCHK(+IBDA(IBDA),.IBDENCT),$G(IBDENCT)>1 D  G CANCELQ
"RTN","IBCECOB2",174,0)
 . D FULL^VALM1 S VALMBCK="R"
"RTN","IBCECOB2",175,0)
 . W !!,*7,"Multiple EOBs exist for this claim and at least one has EOB status of PROCESSED."
"RTN","IBCECOB2",176,0)
 . W !,"Use Remove Action to remove claim from this worklist."
"RTN","IBCECOB2",177,0)
 . D PAUSE^VALM1
"RTN","IBCECOB2",178,0)
 . Q
"RTN","IBCECOB2",179,0)
 ;
"RTN","IBCECOB2",180,0)
 S IBEOBIFN=$P($G(IBDA(+IBDA)),U,3)
"RTN","IBCECOB2",181,0)
 I '$$LOCK^IBCEU0(361.1,IBEOBIFN) G CLONEQ
"RTN","IBCECOB2",182,0)
 D COPYCLON(+$G(IBDA(IBDA)),$P($G(IBDA(+IBDA)),U,2),.IBQ)
"RTN","IBCECOB2",183,0)
 D UNLOCK^IBCEU0(361.1,IBEOBIFN)
"RTN","IBCECOB2",184,0)
 ;
"RTN","IBCECOB2",185,0)
 ; for non-MRA claims cloned or corrected from worklist, set field 38
"RTN","IBCECOB2",186,0)
 I $G(IBMRANOT)=1,$G(IBQ)'="" S X=$$WLRMVF^IBCECOB1(+$G(IBDA(IBDA)),$S($G(IBCNCRD)=1:"CR",1:"CL"))
"RTN","IBCECOB2",187,0)
 ;
"RTN","IBCECOB2",188,0)
CLONEQ ;
"RTN","IBCECOB2",189,0)
 S VALMBCK="R"
"RTN","IBCECOB2",190,0)
 D:$G(IBQ)'="" BLD^IBCECOB1
"RTN","IBCECOB2",191,0)
 Q
"RTN","IBCECOB2",192,0)
 ;
"RTN","IBCECOB2",193,0)
COPYCLON(IBIFN,IB364,IBQ) ; Generic entry point for clone a bill from EDI processing
"RTN","IBCECOB2",194,0)
 ; IBIFN = original bill ien
"RTN","IBCECOB2",195,0)
 ; IB364 = the ien of the transmission bill entry in file 364
"RTN","IBCECOB2",196,0)
 ; IBQ = If bill is not cancelled, this is returned as null
"RTN","IBCECOB2",197,0)
 ;        - pass by reference -
"RTN","IBCECOB2",198,0)
 ;
"RTN","IBCECOB2",199,0)
 N IBQUIT,IBCCCC,IBHV,Y,IBCAN,IBCE,IBDA,IBCNCOPY
"RTN","IBCECOB2",200,0)
 ;I '$$CANCKS^IBCEM3("CC",IBIFN) S IBQ="" G CCQ
"RTN","IBCECOB2",201,0)
 I $G(IBCNCRD)'=1,'$$CANCKS^IBCEM3("CC",IBIFN) S IBQ="" G CCQ
"RTN","IBCECOB2",202,0)
 ;
"RTN","IBCECOB2",203,0)
 ;S IBCAN=2,IBCE("EDI")=1,Y=IBIFN,IBCCCC=0,IBHV("IBIFN")=IBIFN,IBHV("IBIFN1")="",IBCNCOPY=1
"RTN","IBCECOB2",204,0)
 S IBCAN=2,IBCE("EDI")=1,Y=IBIFN,IBCCCC=0,IBHV("IBIFN")=IBIFN,IBHV("IBIFN1")=""
"RTN","IBCECOB2",205,0)
 I $G(IBCNCRD)'=1 S IBCNCOPY=1 D ^IBCCC
"RTN","IBCECOB2",206,0)
 I $G(IBCNCRD)=1 D CRD^IBCCC
"RTN","IBCECOB2",207,0)
 ;D ^IBCCC
"RTN","IBCECOB2",208,0)
 S IBIFN=IBHV("IBIFN")
"RTN","IBCECOB2",209,0)
 K IBCE("EDI") S IBQ=1
"RTN","IBCECOB2",210,0)
 I $P($G(^DGCR(399,IBIFN,0)),U,13)'=7 S IBQ=""
"RTN","IBCECOB2",211,0)
 I IBHV("IBIFN1") D
"RTN","IBCECOB2",212,0)
 . N IBU
"RTN","IBCECOB2",213,0)
 . S IBU="R"
"RTN","IBCECOB2",214,0)
 . S IBNIEN=+IBHV("IBIFN1")
"RTN","IBCECOB2",215,0)
 . I "23"'[$P($G(^DGCR(399,+IBHV("IBIFN1"),0)),U,13) D
"RTN","IBCECOB2",216,0)
 .. W:'$G(IBCEAUTO) !,*7,"Please note: the new bill was not AUTHORIZED.",!,"It can only be accessed now via the normal, non-EDI functions.",!,"Status of new bill is ",$$EXPAND^IBTRE(399,.13,$P(^DGCR(399,IBHV("IBIFN1"),0),U,13)) S IBU="C"
"RTN","IBCECOB2",217,0)
 . D UPDEDI^IBCEM(IB364,IBU)
"RTN","IBCECOB2",218,0)
 ;
"RTN","IBCECOB2",219,0)
 I '$G(IBCEAUTO) D PAUSE^VALM1
"RTN","IBCECOB2",220,0)
CCQ Q
"RTN","IBCECOB2",221,0)
 ;
"RTN","IBCECOB2",222,0)
PRO ; Copy for secondary/tertiary bill
"RTN","IBCECOB2",223,0)
 N VALMY,IBDA,Z,IBIFN,IBIFNH,IB364,IBCE,IBNCN
"RTN","IBCECOB2",224,0)
 ;I '$P($G(^IBE(350.9,1,8)),U,12) D  G PROQ
"RTN","IBCECOB2",225,0)
 I '$P($G(^IBE(350.9,1,8)),U,12),$G(IBMRANOT)'=1 D  G PROQ
"RTN","IBCECOB2",226,0)
 . D FULL^VALM1
"RTN","IBCECOB2",227,0)
 . W !!?5,"MRA's may not be processed at this time."
"RTN","IBCECOB2",228,0)
 . W !?5,"The IB site parameter ""Allow MRA Processing?"" is set to NO."
"RTN","IBCECOB2",229,0)
 . D PAUSE^VALM1
"RTN","IBCECOB2",230,0)
 . Q
"RTN","IBCECOB2",231,0)
 D SEL(.IBDA,1)
"RTN","IBCECOB2",232,0)
 S Z=$O(IBDA(0)),Z=$G(IBDA(+Z)) G:'Z PROQ
"RTN","IBCECOB2",233,0)
 S IBIFN=$P(Z,U),IB364=$P(Z,U,2),IBDA=$P(Z,U,3),IBIFNH=IBIFN
"RTN","IBCECOB2",234,0)
 I 'IBIFN G PROQ
"RTN","IBCECOB2",235,0)
 I '$$LOCK^IBCEU0(361.1,IBDA) G PROQ
"RTN","IBCECOB2",236,0)
 D COBCOPY(IBIFN,IB364,2,IBDA,"BLD^IBCECOB1",.IBNCN)
"RTN","IBCECOB2",237,0)
 D UNLOCK^IBCEU0(361.1,IBDA)
"RTN","IBCECOB2",238,0)
 ;
"RTN","IBCECOB2",239,0)
 ; for non-MRA claims copied from work list, set field 38
"RTN","IBCECOB2",240,0)
 I $G(IBMRANOT)=1,$G(IBNCN)'="",($G(IBNCN)'=$G(IBIFN)) D
"RTN","IBCECOB2",241,0)
 .S X=$$WLRMVF^IBCECOB1($G(IBIFN),"PC")
"RTN","IBCECOB2",242,0)
 .;I $P($G(^DGCR(399,+IBNCN,"S")),U,9)'=1 D
"RTN","IBCECOB2",243,0)
 .;.W:'$G(IBCEAUTO) !,*7,"Please note: the new bill was not AUTHORIZED.",!,"It can only be accessed now via the normal, non-EDI functions.",!,"Status of new bill is ",$$EXPAND^IBTRE(399,.13,$P(^DGCR(399,IBNCN,0),U,13))
"RTN","IBCECOB2",244,0)
 .;.D PAUSE^VALM1
"RTN","IBCECOB2",245,0)
 .D:$G(IBMRANOT)=1 BLD^IBCECOB1
"RTN","IBCECOB2",246,0)
 .Q
"RTN","IBCECOB2",247,0)
 ;
"RTN","IBCECOB2",248,0)
PROQ S VALMBCK="R"
"RTN","IBCECOB2",249,0)
 Q
"RTN","IBCECOB2",250,0)
 ;
"RTN","IBCECOB2",251,0)
COBCOPY(IBIFN,IB364,IBFROM,IBIEN,IBBLD,IBNCN) ; Generic entry point for EDI COB copy
"RTN","IBCECOB2",252,0)
 ; IBIFN = original bill ien
"RTN","IBCECOB2",253,0)
 ; IB364 = the ien of the transmission bill entry in file 364
"RTN","IBCECOB2",254,0)
 ; IBFROM = 1 if called from CSA, 2 if called from COB/EOB processing
"RTN","IBCECOB2",255,0)
 ; IBIEN = entry in 361 (IBFROM=1) or 361.1 (IBFROM=2) being processed
"RTN","IBCECOB2",256,0)
 ; IBBLD = the name of the entrypoint that will rebuild the display
"RTN","IBCECOB2",257,0)
 ; IBNCN = by reference, returns the new claim ien if user completed the Copy process
"RTN","IBCECOB2",258,0)
 ;
"RTN","IBCECOB2",259,0)
 N IBCBASK,IBCBCOPY,IBCAN,IBIFNH,IBNSTAT,IBOSTAT,IBPRCOB,IBSECHK,IBLMVAR,IBAC,IBMRAIEN,IBDA,IBAUTO
"RTN","IBCECOB2",260,0)
 N IBCOB,IBCOBIL,IBCOBN,IBINS,IBINSN,IBINSOLD,IBMRAIO,IBMRAO,IBNMOLD,IBQUIT
"RTN","IBCECOB2",261,0)
 S (IBCBASK,IBCBCOPY,IBCAN,IBAUTO)=1,(IBPRCOB,IBSECHK)=0,(IBMRAIEN,IBDA)=IBIEN
"RTN","IBCECOB2",262,0)
 I $G(IBMRANOT)'=1,'IB364!'IBIFN W !,"Transmission record is missing for this bill" D PAUSE^VALM1 G COBCOPX
"RTN","IBCECOB2",263,0)
 ;
"RTN","IBCECOB2",264,0)
 S IBIFNH=IBIFN
"RTN","IBCECOB2",265,0)
 I IBFROM=2 S IBPRCOB=1
"RTN","IBCECOB2",266,0)
 ; IB*2.0*447 Check PR to include excess and percentages where applicable
"RTN","IBCECOB2",267,0)
 ;I $S($G(IBMRANOT)=1:$$TOT(IBIFN)'>0,1:$$PREOBTOT^IBCEU0(IBIFN,$G(IBMRANOT))'>0) D  G COBCOPX
"RTN","IBCECOB2",268,0)
 I $$TOT(IBIFN,$G(IBMRANOT))'>0 D  G COBCOPX
"RTN","IBCECOB2",269,0)
 . D FULL^VALM1
"RTN","IBCECOB2",270,0)
 . W !!?5,"There is no "_$S($G(IBMRANOT)=1:"balance remaining",1:"patient responsibility and/or excess charges")_" for this claim."
"RTN","IBCECOB2",271,0)
 . W !?5,"This claim may not be processed."
"RTN","IBCECOB2",272,0)
 . D PAUSE^VALM1
"RTN","IBCECOB2",273,0)
 . Q
"RTN","IBCECOB2",274,0)
 ;
"RTN","IBCECOB2",275,0)
 I $G(IBDA)'="",$P($G(^IBM(361.1,IBDA,0)),U,16)="1.5" D  G COBCOPX
"RTN","IBCECOB2",276,0)
 . W !!,"This claim has already been processed as a sec/tert claim."
"RTN","IBCECOB2",277,0)
 . W !,"You will need to complete the authorization process for this claim."
"RTN","IBCECOB2",278,0)
 . D PAUSE^VALM1
"RTN","IBCECOB2",279,0)
 . D AUTH
"RTN","IBCECOB2",280,0)
 . Q
"RTN","IBCECOB2",281,0)
 ;
"RTN","IBCECOB2",282,0)
 ; If multiple EOBs and one is processed, make sure collected closed.
"RTN","IBCECOB2",283,0)
 I $G(IBMRANOT),$$CCCHK(IBIFN)<0 D  G COBCOPX
"RTN","IBCECOB2",284,0)
 . W !,"Multiple EOBs exist for this claim and at least one has EOB status of PROCESSED."
"RTN","IBCECOB2",285,0)
 . W !,"Claim cannot be sent to next payer until AR status is Collected/Closed."
"RTN","IBCECOB2",286,0)
 . D PAUSE^VALM1
"RTN","IBCECOB2",287,0)
 . Q
"RTN","IBCECOB2",288,0)
 ;
"RTN","IBCECOB2",289,0)
 ; Get out if no next payer
"RTN","IBCECOB2",290,0)
 I '$P($G(^DGCR(399,IBIFN,"I"_($$COBN^IBCEF(IBIFN)+1))),U,1) D  G COBCOPX
"RTN","IBCECOB2",291,0)
 . W !,"There is no next payer for this bill"
"RTN","IBCECOB2",292,0)
 . D PAUSE^VALM1
"RTN","IBCECOB2",293,0)
 . Q
"RTN","IBCECOB2",294,0)
 ;
"RTN","IBCECOB2",295,0)
 D DSPRB^IBCCCB0(IBIFN)        ; display related bills
"RTN","IBCECOB2",296,0)
 S IBCE("EDI")=1
"RTN","IBCECOB2",297,0)
 D CHKB^IBCCCB                 ; process COB, create secondary bill
"RTN","IBCECOB2",298,0)
 S IBNCN=$G(IBCE("EDI","NEW")) ; get new claim ien
"RTN","IBCECOB2",299,0)
 S IBIFN=IBIFNH
"RTN","IBCECOB2",300,0)
 I IBSECHK G COBCOPX
"RTN","IBCECOB2",301,0)
 ;
"RTN","IBCECOB2",302,0)
 ; if user came from CBW, no need to view and authorize a 2nd time (already happens in IBCCCB)
"RTN","IBCECOB2",303,0)
 Q:$G(IBMRANOT)=1
"RTN","IBCECOB2",304,0)
 S IBV=1 D VIEW^IBCB2          ; display billing screens
"RTN","IBCECOB2",305,0)
 D AUTH                        ; authorize bill
"RTN","IBCECOB2",306,0)
COBCOPX ;
"RTN","IBCECOB2",307,0)
 Q
"RTN","IBCECOB2",308,0)
 ;
"RTN","IBCECOB2",309,0)
AUTH ; procedure to authorize the claim and refresh the screen
"RTN","IBCECOB2",310,0)
 K ^UTILITY($J) S IBAC=1,IBQUIT=0 D 3^IBCB1
"RTN","IBCECOB2",311,0)
 I '$D(IOUON)!'$D(IORVON) D ENS^%ZISS
"RTN","IBCECOB2",312,0)
 I $P($G(^IBM(361.1,IBMRAIEN,0)),U,16)=3 D UPDEDI^IBCEM(IB364,"Z")
"RTN","IBCECOB2",313,0)
 I $G(IBBLD)'="" D @IBBLD
"RTN","IBCECOB2",314,0)
 D PAUSE^VALM1
"RTN","IBCECOB2",315,0)
AUTHX ;
"RTN","IBCECOB2",316,0)
 Q
"RTN","IBCECOB2",317,0)
 ;
"RTN","IBCECOB2",318,0)
RES ;Resubmit bill by print
"RTN","IBCECOB2",319,0)
 N IBDA,IBIFN,IB364
"RTN","IBCECOB2",320,0)
 D SEL(.IBDA,1)
"RTN","IBCECOB2",321,0)
 S IBDA=+$O(IBDA(0)),IBIFN=+$G(IBDA(+IBDA)),IB364=+$P($G(IBDA(IBDA)),U,2)
"RTN","IBCECOB2",322,0)
 I 'IBIFN G RESQ
"RTN","IBCECOB2",323,0)
 D PRINT1^IBCEM03(IBIFN,.IBDA,IB364)
"RTN","IBCECOB2",324,0)
 D PAUSE^VALM1
"RTN","IBCECOB2",325,0)
 I $G(IBDA)'="" D BLD^IBCECOB1
"RTN","IBCECOB2",326,0)
RESQ S VALMBCK="R"
"RTN","IBCECOB2",327,0)
 Q
"RTN","IBCECOB2",328,0)
 ;
"RTN","IBCECOB2",329,0)
EBI ;View an unauthorized transmitted bill
"RTN","IBCECOB2",330,0)
 N IBFLG,IBDA,IBIFN,IB364,DFN
"RTN","IBCECOB2",331,0)
 K ^TMP($J,"IBBILL")
"RTN","IBCECOB2",332,0)
 D FULL^VALM1
"RTN","IBCECOB2",333,0)
 ;
"RTN","IBCECOB2",334,0)
 D SEL(.IBDA,1)
"RTN","IBCECOB2",335,0)
 S IBDA=+$O(IBDA(""))
"RTN","IBCECOB2",336,0)
 S IBIFN=+$G(IBDA(IBDA)),IB364=+$P($G(IBDA(IBDA)),U,2),DFN=$P($G(^DGCR(399,IBIFN,0)),U,2)
"RTN","IBCECOB2",337,0)
 G:'IBIFN EDITQ
"RTN","IBCECOB2",338,0)
 S IBV=1 D VIEW^IBCB2
"RTN","IBCECOB2",339,0)
 I '$D(IOUON)!'$D(IORVON) D ENS^%ZISS
"RTN","IBCECOB2",340,0)
 D BLD^IBCECOB1
"RTN","IBCECOB2",341,0)
EDITQ S VALMBCK="R"
"RTN","IBCECOB2",342,0)
 Q
"RTN","IBCECOB2",343,0)
 ;
"RTN","IBCECOB2",344,0)
SEL(IBDA,ONE) ; Select entry(s) from list
"RTN","IBCECOB2",345,0)
 ; IBDA = array returned if selections made
"RTN","IBCECOB2",346,0)
 ;    IBDA(n)=ien of bill selected (file 399)
"RTN","IBCECOB2",347,0)
 ; ONE = if set to 1, only one selection can be made at a time
"RTN","IBCECOB2",348,0)
 N IB
"RTN","IBCECOB2",349,0)
 K IBDA
"RTN","IBCECOB2",350,0)
 D FULL^VALM1
"RTN","IBCECOB2",351,0)
 D EN^VALM2($G(XQORNOD(0)),$S('$G(ONE):"",1:"S"))
"RTN","IBCECOB2",352,0)
 S IBDA=0 F  S IBDA=$O(VALMY(IBDA)) Q:'IBDA  S IBDA(IBDA)=$P($G(^TMP("IBCECOB",$J,+IBDA)),U,2,6)
"RTN","IBCECOB2",353,0)
 Q
"RTN","IBCECOB2",354,0)
 ;
"RTN","IBCECOB2",355,0)
EXIT ; Exit out of COB
"RTN","IBCECOB2",356,0)
 D FASTEXIT^IBCEFG4
"RTN","IBCECOB2",357,0)
 I $G(IBFASTXT)=1 S IBFASTXT=5
"RTN","IBCECOB2",358,0)
 Q
"RTN","IBCECOB2",359,0)
 ;
"RTN","IBCECOB2",360,0)
TOT(IBIFN,IBMRANOT) ; calculate if any balance remaining on non-MRA claim
"RTN","IBCECOB2",361,0)
 ; IBIFN = claim ien
"RTN","IBCECOB2",362,0)
 ; IBMRANOT = MRW/CBW flag (1=user came from CBW)  added with IB*2.0*447
"RTN","IBCECOB2",363,0)
 N IBPRTOT,IBBLD,IBCBN,IBU2
"RTN","IBCECOB2",364,0)
 I $G(IBMRANOT)'=1 Q $S($$MSEDT^IBCEMU4(IBIFN)'="":$$MSPRE^IBCEMU4(IBIFN),1:$$PREOBTOT^IBCEU0(IBIFN))
"RTN","IBCECOB2",365,0)
 ; total up the payer paid amounts, if this is a 2ndary claim, be sure to account for what the primary paid also
"RTN","IBCECOB2",366,0)
 S IBU2=$G(^DGCR(399,IBIFN,"U2")),IBCBN=$$COBN^IBCEF(IBIFN),IBPRTOT=$$EOBTOT^IBCEU1(IBIFN,IBCBN)
"RTN","IBCECOB2",367,0)
 S:IBPRTOT<0 IBPRTOT=0      ; don't allow negative prior payment or offset
"RTN","IBCECOB2",368,0)
 S:IBCBN=2 IBPRTOT=IBPRTOT+$P(IBU2,U,4)
"RTN","IBCECOB2",369,0)
 S:IBCBN=3 IBPRTOT=IBPRTOT+$P(IBU2,U,4)+$P(IBU2,U,5)
"RTN","IBCECOB2",370,0)
 S:IBPRTOT<0 IBPRTOT=0      ; don't allow negative prior payment or offset
"RTN","IBCECOB2",371,0)
 ; Subtract payer paid amount from Total Charges from BILLS/CLAIMS (#399) file, don't allow neg
"RTN","IBCECOB2",372,0)
 S IBBLD=$P($G(^DGCR(399,IBIFN,"U1")),U,1)-IBPRTOT
"RTN","IBCECOB2",373,0)
 S:IBBLD<0 IBBLD=0
"RTN","IBCECOB2",374,0)
 Q IBBLD
"RTN","IBCECOB2",375,0)
 ;
"RTN","IBCECOB2",376,0)
CCCHK(IBIFN) ; If there are multiple EOBS on file for this claim, then one of them must be processed and AR status must be collected closed to process.
"RTN","IBCECOB2",377,0)
 ; returns 1 if true
"RTN","IBCECOB2",378,0)
 ;         0 if there are not multiple EOBs or mulitple EOBs and none are processed (all denials)
"RTN","IBCECOB2",379,0)
 ;        -1 if false
"RTN","IBCECOB2",380,0)
 N IBDA,IBCT,IBPROC,IBARSTAT,IBEOBNDX,IBEOB
"RTN","IBCECOB2",381,0)
 S IBCT=0,IBPROC=0
"RTN","IBCECOB2",382,0)
 F IBEOBNDX="B","C" D
"RTN","IBCECOB2",383,0)
 .S IBDA=0 F  S IBDA=$O(^IBM(361.1,IBEOBNDX,IBIFN,IBDA)) Q:'+IBDA  D
"RTN","IBCECOB2",384,0)
 ..Q:$D(IBEOB(IBDA))
"RTN","IBCECOB2",385,0)
 ..Q:$P($G(^IBM(361.1,IBDA,0)),U,4)=1    ; only count EOBs
"RTN","IBCECOB2",386,0)
 ..S IBEOB(IBDA)="",IBCT=IBCT+1
"RTN","IBCECOB2",387,0)
 ..I $P($G(^IBM(361.1,IBDA,0)),U,13)=1 S IBPROC=1
"RTN","IBCECOB2",388,0)
 I IBCT<2 Q 0  ; less than 2 EOBs
"RTN","IBCECOB2",389,0)
 I 'IBPROC Q 0  ; no EOBs with status processed 
"RTN","IBCECOB2",390,0)
 S IBARSTAT=$$ARSTATA^IBJTU4(IBIFN)  ; get status of AR
"RTN","IBCECOB2",391,0)
 I $P(IBARSTAT,U)="COLLECTED/CLOSED" Q 1
"RTN","IBCECOB2",392,0)
 Q -1
"RTN","IBCECOB2",393,0)
 ;
"RTN","IBCECOB2",394,0)
DENCHK(IBIFN,IBCT) ; Make sure all EOBs from this claim are denied.
"RTN","IBCECOB2",395,0)
 ; Input: IBIFN - IEN to 399
"RTN","IBCECOB2",396,0)
 ;        IBCT - by reference. Return count of EOBs.
"RTN","IBCECOB2",397,0)
 ; Output: returns 1 if there is at least one EOB and that none of the EOBS are processed.
"RTN","IBCECOB2",398,0)
 ; otherwise 0
"RTN","IBCECOB2",399,0)
 ;
"RTN","IBCECOB2",400,0)
 N IBDA,IBPROC,IBEOBNDX,IBEOB
"RTN","IBCECOB2",401,0)
 S IBCT=0,IBPROC=0
"RTN","IBCECOB2",402,0)
 F IBEOBNDX="B","C" D
"RTN","IBCECOB2",403,0)
 .S IBDA=0 F  S IBDA=$O(^IBM(361.1,IBEOBNDX,IBIFN,IBDA)) Q:'+IBDA  D
"RTN","IBCECOB2",404,0)
 ..Q:$D(IBEOB(IBDA))
"RTN","IBCECOB2",405,0)
 ..Q:$P($G(^IBM(361.1,IBDA,0)),U,4)=1    ; only count EOBs
"RTN","IBCECOB2",406,0)
 ..S IBEOB(IBDA)="",IBCT=IBCT+1
"RTN","IBCECOB2",407,0)
 ..I $P($G(^IBM(361.1,IBDA,0)),U,13)=1 S IBPROC=1
"RTN","IBCECOB2",408,0)
 I IBCT,'IBPROC Q 1  ; there is at least one EOB and none of the EOBS are processed.
"RTN","IBCECOB2",409,0)
 Q 0  ;
"RTN","IBCEF")
0^18^B58449164
"RTN","IBCEF",1,0)
IBCEF ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;22-JAN-96
"RTN","IBCEF",2,0)
 ;;2.0;INTEGRATED BILLING;**52,80,51,137,288,296,361,371,447**;21-MAR-94;Build 80
"RTN","IBCEF",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCEF",4,0)
 ;
"RTN","IBCEF",5,0)
 ;IBIFN = bill ien throughout this routine
"RTN","IBCEF",6,0)
COB(IBIFN) ; Bill seq
"RTN","IBCEF",7,0)
 N A
"RTN","IBCEF",8,0)
 S A=$P($G(^DGCR(399,IBIFN,0)),U,21) S:A="" A="P"
"RTN","IBCEF",9,0)
 Q A
"RTN","IBCEF",10,0)
 ;
"RTN","IBCEF",11,0)
COBN(IBIFN,A) ; Return seq # of selected payer
"RTN","IBCEF",12,0)
 ; A = 'PST' or null to get current bill payer seq #
"RTN","IBCEF",13,0)
 I $G(A)="" S A=$$COB(IBIFN) S:"PST"'[A A="P"
"RTN","IBCEF",14,0)
 I 'A S A=$F("PST",A)-1 S:A<1 A=1
"RTN","IBCEF",15,0)
 Q A
"RTN","IBCEF",16,0)
 ;
"RTN","IBCEF",17,0)
POLICY(IBIFN,IBPC,IBCOBN) ; Return raw data from policy info on bill
"RTN","IBCEF",18,0)
 ; IBPC  = pc # of data element in policy (optional)
"RTN","IBCEF",19,0)
 ;          if null, 0-node is returned
"RTN","IBCEF",20,0)
 ; IBCOBN = bill designation 1-3 or 'PST' (optional)
"RTN","IBCEF",21,0)
 ;          if null, default to current
"RTN","IBCEF",22,0)
 N IBI
"RTN","IBCEF",23,0)
 I "PST"[$G(IBCOBN) S IBCOBN=$$COBN(IBIFN,$G(IBCOBN))
"RTN","IBCEF",24,0)
 S IBI=$G(^DGCR(399,IBIFN,"I"_IBCOBN))
"RTN","IBCEF",25,0)
 I $G(IBPC) S IBI=$P(IBI,U,IBPC)
"RTN","IBCEF",26,0)
POLICYQ Q IBI
"RTN","IBCEF",27,0)
 ;
"RTN","IBCEF",28,0)
INSADDR(IBIFN,IBCOB) ; Return insured's address in 7 pieces:
"RTN","IBCEF",29,0)
 ; ALL STREET ADDRESSES^CITY^STATE ABBREVIATION^ZIP^STREET ADDRESS 1^
"RTN","IBCEF",30,0)
 ;  STREET ADDRESS 2^STREET ADDRESS 3
"RTN","IBCEF",31,0)
 ; IBIFN = bill ien
"RTN","IBCEF",32,0)
 ; IBCOB = bill designation (P)rimary, (S)econdary, (T)ertiary
"RTN","IBCEF",33,0)
 ;          or 1-2-3. If not defined or null, return current
"RTN","IBCEF",34,0)
 ; If insured is patient or spouse, take from patient file top level
"RTN","IBCEF",35,0)
 ;   fields, then if top-level street addresses are blank and policy
"RTN","IBCEF",36,0)
 ;   level fields are not, use policy level
"RTN","IBCEF",37,0)
 ; If insured is other than patient/spouse, use policy level fields only
"RTN","IBCEF",38,0)
 N A,B,IBADDR,IBI,DFN,VAPA,VATEST
"RTN","IBCEF",39,0)
 S:$G(IBCOB)="" IBCOB=""
"RTN","IBCEF",40,0)
 I 'IBCOB S IBCOB=$$COBN(IBIFN,$G(IBCOB))
"RTN","IBCEF",41,0)
 S IBI=+$$POLICY(IBIFN,16,IBCOB)     ; pt relationship to insured
"RTN","IBCEF",42,0)
 S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
"RTN","IBCEF",43,0)
 I $S('IBI:1,1:"12"'[IBI) S IBADDR="" G INSADDQ
"RTN","IBCEF",44,0)
 ; insured's address (patient/spouse) same as patient's
"RTN","IBCEF",45,0)
 S VATEST("ADD",9)=+$G(^DGCR(399,IBIFN,"U")),VATEST("ADD",10)=+$P($G(^("U")),U,2)
"RTN","IBCEF",46,0)
 D ADD^VADPT
"RTN","IBCEF",47,0)
 S IBADDR=VAPA(1)_" "_VAPA(2)_" "_VAPA(3)_U_VAPA(4)_U_$P($G(^DIC(5,+VAPA(5),0)),U,2)_U_VAPA(6)_U_VAPA(1)_U_VAPA(2)_U_VAPA(3)
"RTN","IBCEF",48,0)
INSADDQ S A=$P($G(^DGCR(399,IBIFN,"M")),U,(11+IBCOB))
"RTN","IBCEF",49,0)
 S A=$G(^DPT(DFN,.312,+A,3))
"RTN","IBCEF",50,0)
 I $TR($P(IBADDR,U)," ")="" D PI3
"RTN","IBCEF",51,0)
 I IBI=2,$$NOPUNCT($P(A,U,6,10),1)'="" D PI3
"RTN","IBCEF",52,0)
 Q IBADDR
"RTN","IBCEF",53,0)
 ;
"RTN","IBCEF",54,0)
PI3 ; build IBADDR string from patient insurance 3 node data
"RTN","IBCEF",55,0)
 S $P(IBADDR,U,1)=$P(A,U,6)_" "_$P(A,U,7)
"RTN","IBCEF",56,0)
 S $P(IBADDR,U,5,6)=$P(A,U,6,7)
"RTN","IBCEF",57,0)
 F B=2,4 S $P(IBADDR,U,B)=$P(A,U,B+6)
"RTN","IBCEF",58,0)
 S $P(IBADDR,U,3)=$P($G(^DIC(5,+$P(A,U,9),0)),U,2)
"RTN","IBCEF",59,0)
 S $P(IBADDR,U,7)=""   ; no street address 3 in file 2.312
"RTN","IBCEF",60,0)
 Q
"RTN","IBCEF",61,0)
 ;
"RTN","IBCEF",62,0)
PTADDR(IBIFN,ELE) ;Return part of patient's permanent address
"RTN","IBCEF",63,0)
 ;IBIFN = bill ien
"RTN","IBCEF",64,0)
 ;ELE = subscript in ^UTILITY("VAPA", array for element needed
"RTN","IBCEF",65,0)
 ;
"RTN","IBCEF",66,0)
 I '$D(^UTILITY("VAPA",$J)) D  ; once per pt
"RTN","IBCEF",67,0)
 .N VAHOW,DFN,VAPA
"RTN","IBCEF",68,0)
 .S VAHOW=2,DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2),VAPA("P")=""
"RTN","IBCEF",69,0)
 .D ADD^VADPT
"RTN","IBCEF",70,0)
 Q $P($G(^UTILITY("VAPA",$J,ELE)),U)
"RTN","IBCEF",71,0)
 ;
"RTN","IBCEF",72,0)
PTDEM(IBIFN,ELE,PC) ;Return part of patient's demographics
"RTN","IBCEF",73,0)
 ;IBIFN = bill ien
"RTN","IBCEF",74,0)
 ;ELE = subscript in ^UTILITY("VADM" array for demographic element needed
"RTN","IBCEF",75,0)
 ;PC = pc of string at subscript ELE to be returned
"RTN","IBCEF",76,0)
 ;
"RTN","IBCEF",77,0)
 I '$G(PC) S PC=1
"RTN","IBCEF",78,0)
 I '$D(^UTILITY("VADM",$J)) D  ; once per pt
"RTN","IBCEF",79,0)
 .N VAHOW,DFN,VADM
"RTN","IBCEF",80,0)
 .S VAHOW=2,DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
"RTN","IBCEF",81,0)
 .D DEM^VADPT
"RTN","IBCEF",82,0)
 Q $P($G(^UTILITY("VADM",$J,ELE)),U,PC)
"RTN","IBCEF",83,0)
 ;
"RTN","IBCEF",84,0)
PTEMPL(IBIFN,ELE,WHOSE,VAOA) ;Return part of pt's or spouse's employer info
"RTN","IBCEF",85,0)
 ;ELE = subscript in VAOA array for employer element needed
"RTN","IBCEF",86,0)
 ;WHOSE = 6 if spouse's info needed  5 if pt info needed (DEFAULT)
"RTN","IBCEF",87,0)
 ;
"RTN","IBCEF",88,0)
 N DFN
"RTN","IBCEF",89,0)
 S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2),VAOA("A")=$S($G(WHOSE):WHOSE,1:5)
"RTN","IBCEF",90,0)
 D OAD^VADPT
"RTN","IBCEF",91,0)
 Q $P($G(VAOA(ELE)),U)
"RTN","IBCEF",92,0)
 ;
"RTN","IBCEF",93,0)
INSDEM(IBIFN,IBCOB) ; Return insured's demographics in 6 pieces:
"RTN","IBCEF",94,0)
 ; DATE OF BIRTH^SEX^PHONE^BRANCH pointer^RANK^SSN(no dashes)
"RTN","IBCEF",95,0)
 ; IBIFN = bill ien
"RTN","IBCEF",96,0)
 ; IBCOB = bill designation (P)rimary (default), (S)econdary, (T)ertiary
"RTN","IBCEF",97,0)
 ;          or 1,2,3 ... if not defined or null, return current
"RTN","IBCEF",98,0)
 ; If insured is patient/spouse, take from patient file top level
"RTN","IBCEF",99,0)
 ;   fields, then if top-level are blank and policy level aren't,
"RTN","IBCEF",100,0)
 ;   use policy level
"RTN","IBCEF",101,0)
 ; If insured other than patient/spouse, use policy level fields only
"RTN","IBCEF",102,0)
 N A,B,IBDEM,IBI,DFN,VADM
"RTN","IBCEF",103,0)
 S:$G(IBCOB)="" IBCOB=""
"RTN","IBCEF",104,0)
 S:'IBCOB IBCOB=$$COBN(IBIFN,IBCOB)
"RTN","IBCEF",105,0)
 S IBI=$$WHOSINS(IBIFN,IBCOB)
"RTN","IBCEF",106,0)
 S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
"RTN","IBCEF",107,0)
 I $S('IBI:1,1:"12"'[IBI) S IBDEM="" G INSDEM1
"RTN","IBCEF",108,0)
 ; If it gets here, assume insured is patient/spouse
"RTN","IBCEF",109,0)
 S A=$$PTDEM(IBIFN,0),A=$$PTADDR(IBIFN,0)
"RTN","IBCEF",110,0)
 F A=2,3,5 S VADM(A)=$P($G(^UTILITY("VADM",$J,A)),U)
"RTN","IBCEF",111,0)
 S VAPA(8)=$P($G(^UTILITY("VAPA",$J,8)),U)
"RTN","IBCEF",112,0)
 I VADM(5)="",'VADM(3),VAPA(8)="" S IBDEM="" G INSDEM1
"RTN","IBCEF",113,0)
 S $P(IBDEM,U,3)=VAPA(8),$P(IBDEM,U,6)=VADM(2)
"RTN","IBCEF",114,0)
 I IBI=1,VADM(3) S $P(IBDEM,U)=VADM(3) ;Patient's own policy only
"RTN","IBCEF",115,0)
INSDEM1 S A=$P($G(^DGCR(399,IBIFN,"M")),U,(11+IBCOB))
"RTN","IBCEF",116,0)
 S A=$G(^DPT(DFN,.312,+A,3))
"RTN","IBCEF",117,0)
 S:"MF"'[$G(VADM(5)) VADM(5)=""
"RTN","IBCEF",118,0)
 S $P(IBDEM,U,2)=$S(IBI=1:VADM(5),1:$P(A,U,12))
"RTN","IBCEF",119,0)
 S $P(IBDEM,U,4,5)=$P(A,U,2)_U_$P(A,U,3)
"RTN","IBCEF",120,0)
 S:'$P(IBDEM,U) $P(IBDEM,U)=$P(A,U)
"RTN","IBCEF",121,0)
 S:$P(IBDEM,U,3)="" $P(IBDEM,U,3)=$P(A,U,11)
"RTN","IBCEF",122,0)
 S:$P(IBDEM,U,6)="" $P(IBDEM,U,6)=$P(A,U,5)
"RTN","IBCEF",123,0)
 Q IBDEM
"RTN","IBCEF",124,0)
 ;
"RTN","IBCEF",125,0)
INSEMPL(IBIFN,IBCOB) ; Return insured's employer data in 5 pieces:
"RTN","IBCEF",126,0)
 ; EMPLOYER NAME^EMPLOYER CITY^EMPLOYER STATE ABBREVIATION^STATE IEN^STREET 1
"RTN","IBCEF",127,0)
 ; IBCOB = bill designation (P)rimary-default, (S)econdary, (T)ertiary
"RTN","IBCEF",128,0)
 ;            or 123 - if not defined or null, return current
"RTN","IBCEF",129,0)
 N A,IBEMPL,IBI,DFN,VAOA
"RTN","IBCEF",130,0)
 S IBI=$$WHOSINS(IBIFN,$G(IBCOB))
"RTN","IBCEF",131,0)
 I $S('IBI:1,1:"12"'[IBI) S IBEMPL="^^" G INSEMPQ
"RTN","IBCEF",132,0)
 ; insured = pt/spouse
"RTN","IBCEF",133,0)
 S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
"RTN","IBCEF",134,0)
 S A=$$PTEMPL(IBIFN,0,IBI+4,.VAOA)
"RTN","IBCEF",135,0)
 S IBEMPL=VAOA(9)_U_VAOA(4)_U_$P($G(^DIC(5,+VAOA(5),0)),U,2)_U_+VAOA(5)_U_VAOA(1)
"RTN","IBCEF",136,0)
INSEMPQ Q IBEMPL
"RTN","IBCEF",137,0)
 ;
"RTN","IBCEF",138,0)
WHOSINS(IBIFN,IBCOB) ; Determine who is insured for bill IBIFN and 
"RTN","IBCEF",139,0)
 ; seq of coverage COB (123 or PST) or if not defined or null, current
"RTN","IBCEF",140,0)
 N Z,Z0,VAEL,DFN
"RTN","IBCEF",141,0)
 S Z=+$$POLICY(IBIFN,16,$G(IBCOB))
"RTN","IBCEF",142,0)
 I 'Z D
"RTN","IBCEF",143,0)
 .S Z0=$$POLICY(IBIFN,6,$G(IBCOB)),DFN=$P($G(^DGCR(399,IBIFN,0)),U,2)
"RTN","IBCEF",144,0)
 .I Z0="v" D ELIG^VADPT I VAEL(4) S Z=1 Q  ;vet is pt
"RTN","IBCEF",145,0)
 .I Z0="s" D ELIG^VADPT I VAEL(4) S Z=2 Q  ;vet is pt, so vets spouse is pt's spouse
"RTN","IBCEF",146,0)
 .S Z=9 ; relationship of insured to pt unknown
"RTN","IBCEF",147,0)
 Q Z
"RTN","IBCEF",148,0)
 ;
"RTN","IBCEF",149,0)
EMPSTAT(IBIFN,WHOSE) ;Return employment status
"RTN","IBCEF",150,0)
 ; IBIFN = bill ien
"RTN","IBCEF",151,0)
 ; WHOSE = v for vet, s for spouse status
"RTN","IBCEF",152,0)
 N STAT,DFN,VAPD
"RTN","IBCEF",153,0)
 S STAT="",DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
"RTN","IBCEF",154,0)
 I WHOSE="v" D OPD^VADPT S STAT=$P(VAPD(7),U)
"RTN","IBCEF",155,0)
 I WHOSE="s" S STAT=$P($G(^DPT(DFN,.25)),U,15)
"RTN","IBCEF",156,0)
 I STAT="" S STAT=9
"RTN","IBCEF",157,0)
 Q STAT
"RTN","IBCEF",158,0)
 ;
"RTN","IBCEF",159,0)
INPAT(IBIFN,OUT) ; Determine if bill is inpatient
"RTN","IBCEF",160,0)
 ; OUT = optional - if 1, return output value based on 
"RTN","IBCEF",161,0)
 ;  inpatient/outpatient from UB-04 type of bill field
"RTN","IBCEF",162,0)
 ; Return 1 if inpatient, 0 if not inpatient or can't be determined
"RTN","IBCEF",163,0)
 N INPT,CODE,CODE0,IB0
"RTN","IBCEF",164,0)
 S IB0=$G(^DGCR(399,IBIFN,0))
"RTN","IBCEF",165,0)
 S OUT=+$G(OUT),CODE=+$P(IB0,U,5)
"RTN","IBCEF",166,0)
 I 'OUT S INPT=CODE
"RTN","IBCEF",167,0)
 I OUT D
"RTN","IBCEF",168,0)
 . S CODE0=$P($G(^DGCR(399.1,+$P(IB0,U,25),0)),U,2)
"RTN","IBCEF",169,0)
 . I CODE0=8,$P(IB0,U,24)=1 S INPT=$P(IB0,U,5) Q  ; 18X
"RTN","IBCEF",170,0)
 . I CODE0=9,$P(IB0,U,24)=8 S INPT=$P(IB0,U,5) Q  ; 89X
"RTN","IBCEF",171,0)
 . I CODE0=1,$P(IB0,U,24)=8 S INPT=0 Q  ; 81X
"RTN","IBCEF",172,0)
 . I CODE0=1,$P(IB0,U,24)=7 S INPT=0 Q  ; 71X
"RTN","IBCEF",173,0)
 . I CODE0=2,$P(IB0,U,24)=7 S INPT=0 Q  ; 72X
"RTN","IBCEF",174,0)
 . S INPT=CODE0
"RTN","IBCEF",175,0)
 Q $S(INPT:INPT'>2,1:0)
"RTN","IBCEF",176,0)
 ;
"RTN","IBCEF",177,0)
INSPRF(IBIFN) ; Function to determine if bill is prof or inst
"RTN","IBCEF",178,0)
 ; Return 1 if institutional (UB-04) claim, 0 if professional (CMS-1500) claim
"RTN","IBCEF",179,0)
 N A
"RTN","IBCEF",180,0)
 S A=$G(^DGCR(399,IBIFN,0))
"RTN","IBCEF",181,0)
 I $P(A,U,27)="" S $P(A,U,27)=$S($P(A,U,19)=3:1,1:0)
"RTN","IBCEF",182,0)
 Q $S($P(A,U,27)=1:1,1:0)
"RTN","IBCEF",183,0)
 ;
"RTN","IBCEF",184,0)
F(FLD,IBXRET,IBXERR1,IBIEN) ;Execute extract for data element FLD and bill IBIEN
"RTN","IBCEF",185,0)
 ; If IBXDATA array to be returned as data value(s) of fld
"RTN","IBCEF",186,0)
 ;   D F^IBCEF("FLD NAME","IBXDATA","IBXERR") or D F^IBCEF("FLD NAME") 
"RTN","IBCEF",187,0)
 ; Variable ref-ed by IBXERR1 will contain error message if an error
"RTN","IBCEF",188,0)
 ; @IBXRET always defined on return.  It will be null if error
"RTN","IBCEF",189,0)
 I $G(IBIEN) N IBXIEN S IBXIEN=IBIEN
"RTN","IBCEF",190,0)
 I $G(IBXERR1)="" S IBXERR1="IBXERR"
"RTN","IBCEF",191,0)
 N IBXHOLD
"RTN","IBCEF",192,0)
 S IBXHOLD=""
"RTN","IBCEF",193,0)
 I $G(IBXRET)=""!($G(IBXRET)="IBXDATA") S IBXHOLD="IBXDATA",IBXRET="IBXRET"
"RTN","IBCEF",194,0)
 S @IBXERR1=""
"RTN","IBCEF",195,0)
 ;
"RTN","IBCEF",196,0)
 N FLDN,OFLD,STOP,Z,IBXERR2,IBXRETX
"RTN","IBCEF",197,0)
 ;
"RTN","IBCEF",198,0)
 I '$G(IBXIEN) S @IBXERR1="Invalid entry #" G FQ
"RTN","IBCEF",199,0)
 I '$D(^IBA(364.5,"B",FLD)) S OFLD=FLD,STOP=0 D  I FLD="" S @IBXERR1=OFLD_" Field not found!!" G FQ
"RTN","IBCEF",200,0)
 .F  S FLD=$O(^IBA(364.5,"B",FLD))  D  Q:STOP
"RTN","IBCEF",201,0)
 ..I $E(FLD,1,$L(OFLD))'=OFLD S FLD=""
"RTN","IBCEF",202,0)
 ..S STOP=1
"RTN","IBCEF",203,0)
 ;
"RTN","IBCEF",204,0)
 S Z=0
"RTN","IBCEF",205,0)
 F  S Z=$O(^IBA(364.5,"B",FLD,Z)) Q:'Z  I $P($G(^IBA(364.5,Z,0)),U,5)=399 Q
"RTN","IBCEF",206,0)
 I 'Z S @IBXERR1=FLD_" Field not found!!" G FQ
"RTN","IBCEF",207,0)
 ;
"RTN","IBCEF",208,0)
 S FLDN(1)=Z D EXTONE^IBCEFG0(IBXIEN,.FLDN,""_IBXRET_"",.IBXERR2)
"RTN","IBCEF",209,0)
 ;
"RTN","IBCEF",210,0)
 I $G(IBXERR2)'="" S @IBXERR1=IBXERR2
"RTN","IBCEF",211,0)
FQ S IBXARRY=$S(IBXHOLD="IBXDATA":"IBXDATA",1:""_IBXRET_"")
"RTN","IBCEF",212,0)
 I @IBXERR1'="" K @IBXARRY S @IBXARRY="" Q
"RTN","IBCEF",213,0)
 ;
"RTN","IBCEF",214,0)
 I IBXHOLD="IBXDATA" S IBXRET="IBXRET"
"RTN","IBCEF",215,0)
 M IBXRETX=@IBXRET K @IBXARRY M @IBXARRY=IBXRETX(1)
"RTN","IBCEF",216,0)
 S:'($D(@IBXARRY)#2) @IBXARRY=""
"RTN","IBCEF",217,0)
 Q
"RTN","IBCEF",218,0)
 ;
"RTN","IBCEF",219,0)
SERVDT(IBIFN,LENGTH,FORMAT) ; Return default service date for 
"RTN","IBCEF",220,0)
 ; outpatient/UB-04 lines or X12-837 institutional lines
"RTN","IBCEF",221,0)
 ; LENGTH = null/8 for 8 digit date, 6 for 6 digit date
"RTN","IBCEF",222,0)
 ; FORMAT = 1 = X12 format (YYYYMMDD), 2 = FM internal (NNNNNNN),
"RTN","IBCEF",223,0)
 ;          0 = external (MMDDYY or MMDDYYYY)
"RTN","IBCEF",224,0)
 N IBZ
"RTN","IBCEF",225,0)
 G:$$INPAT^IBCEF(IBIFN,1)!($$FT^IBCEF(IBIFN)'=3) SERVDTQ ;Inpatient claim or billed on a CMS-1500
"RTN","IBCEF",226,0)
 S LENGTH=$G(LENGTH),FORMAT=$G(FORMAT)
"RTN","IBCEF",227,0)
 D F("N-STATEMENT COVERS FROM DATE","IBZ",,IBIFN)
"RTN","IBCEF",228,0)
 I '$G(IBZ)!(FORMAT=2) G SERVDTQ
"RTN","IBCEF",229,0)
 ;
"RTN","IBCEF",230,0)
 I FORMAT=1 S IBZ=$$DT^IBCEFG1(IBZ,"",$S(LENGTH'=6:"D8",1:"D6")) G SERVDTQ
"RTN","IBCEF",231,0)
 S IBZ=$$DATE^IBCF2(IBZ,$S(LENGTH=6:0,1:1),1)
"RTN","IBCEF",232,0)
 ;
"RTN","IBCEF",233,0)
SERVDTQ Q $G(IBZ)
"RTN","IBCEF",234,0)
 ;
"RTN","IBCEF",235,0)
NOPUNCT(X,SPACE,EXC) ; Strip punctuation from data in X
"RTN","IBCEF",236,0)
 ; SPACE = flag if 1 strip SPACES
"RTN","IBCEF",237,0)
 ; EXC = list of punctuation not to strip
"RTN","IBCEF",238,0)
 ;
"RTN","IBCEF",239,0)
 N PUNCT,Z
"RTN","IBCEF",240,0)
 S PUNCT=".,-+(){}[]\/><:;?|=_*&%$#@!~`^'"""
"RTN","IBCEF",241,0)
 I $G(SPACE) S PUNCT=PUNCT_" "
"RTN","IBCEF",242,0)
 I $G(EXC)'="" F Z=1:1:$L(EXC) S PUNCT=$TR(PUNCT,$E(EXC,Z))
"RTN","IBCEF",243,0)
 S X=$TR(X,PUNCT)
"RTN","IBCEF",244,0)
 Q X
"RTN","IBCEF",245,0)
 ;
"RTN","IBCEF",246,0)
FT(IBIFN) ; Internal code for bill form type
"RTN","IBCEF",247,0)
 Q +$P($G(^DGCR(399,IBIFN,0)),U,19)
"RTN","IBCEF",248,0)
 ;
"RTN","IBCEF",249,0)
COBCT(IBIFN) ; # of payers on claim
"RTN","IBCEF",250,0)
 N CT,Z
"RTN","IBCEF",251,0)
 S CT=0 F Z="I1","I2","I3" Q:'$D(^DGCR(399,IBIFN,Z))  S CT=CT+1
"RTN","IBCEF",252,0)
 Q CT
"RTN","IBCEF",253,0)
 ;
"RTN","IBCEF",254,0)
INSTOUT(IBIFN)   ; Identify a Outpatient Institutional Claim. IB*2.0*447 BI
"RTN","IBCEF",255,0)
 ; Return a 1 if claim/bill is Institutional and Outpatient, otherwise return 0.
"RTN","IBCEF",256,0)
 Q (($$INPAT^IBCEF(IBIFN)=0)&($$INSPRF^IBCEF(IBIFN)=1))
"RTN","IBCEF",257,0)
 ;
"RTN","IBCEF1")
0^61^B60116186
"RTN","IBCEF1",1,0)
IBCEF1 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS - CONT ;30-JAN-96
"RTN","IBCEF1",2,0)
 ;;2.0;INTEGRATED BILLING;**52,124,51,137,210,155,349,371,447**;21-MAR-94;Build 80
"RTN","IBCEF1",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCEF1",4,0)
 ;
"RTN","IBCEF1",5,0)
OCC(IBIFN,REL,TEXT) ;Sets up an arrays of occurrence codes for various cks
"RTN","IBCEF1",6,0)
 ;RETURNS 1^additional data for entry IBXSAVE("OCC",n) if REL or TEXT
"RTN","IBCEF1",7,0)
 ;   parameters have been met or null if conditions not met
"RTN","IBCEF1",8,0)
 ;If no REL or TEXT parameters sent, just extract codes array
"RTN","IBCEF1",9,0)
 ; IBIFN = bill ien
"RTN","IBCEF1",10,0)
 ; REL = 'OCC RELATED TO' value to check for
"RTN","IBCEF1",11,0)
 ; TEXT = text to check for the .01 field of 399.1 entry pointed to
"RTN","IBCEF1",12,0)
 ;         by the occurrence code
"RTN","IBCEF1",13,0)
 N OCC,SORT,ARR,N,DATA,CODE,CT
"RTN","IBCEF1",14,0)
 I '$D(IBXSAVE("OCC")),'$D(IBXSAVE("OCCS")) D
"RTN","IBCEF1",15,0)
 .N IBI,Z,CT1,CT2,Z0 S (IBI,CT1,CT2)=0
"RTN","IBCEF1",16,0)
 .F  S IBI=$O(^DGCR(399,IBIFN,"OC",IBI)) Q:'IBI  S Z=$G(^(IBI,0)) D
"RTN","IBCEF1",17,0)
 ..S Z0=$G(^DGCR(399.1,+Z,0))
"RTN","IBCEF1",18,0)
 ..Q:'$P(Z0,U,10)&'$P(Z0,U,4)  ;Not an occurrence code
"RTN","IBCEF1",19,0)
 ..I $P(Z0,U,10) S CT2=CT2+1,IBXSAVE("OCCS",CT2)=$S($P(Z0,U,4):$P(Z0,U,2)_U_$P(Z,U,2),1:U)_U_$P(Z,U,4)_U_$P(Z0,U)_U_$P(Z0,U,9)_U_$P(Z,U,3)_U_$P(Z,U,2)
"RTN","IBCEF1",20,0)
 ..I '$P(Z0,U,10) S CT1=CT1+1,IBXSAVE("OCC",CT1)=$S($P(Z0,U,4):$P(Z0,U,2)_U_$P(Z,U,2),1:U)_U_U_$P(Z0,U)_U_$P(Z0,U,9)_U_$P(Z,U,3)_U_$P(Z,U,2)
"RTN","IBCEF1",21,0)
 I '$D(IBXSAVE("OCC"))&'$D(IBXSAVE("OCCS")) S IBXSAVE("OCC")="" G OCCQ
"RTN","IBCEF1",22,0)
 ;
"RTN","IBCEF1",23,0)
 ; esg - IB*2*349 - order the occurrence codes
"RTN","IBCEF1",24,0)
 ;       Build the SORT array sorted by the occ code
"RTN","IBCEF1",25,0)
 F ARR="OCC","OCCS" S N=0 F  S N=$O(IBXSAVE(ARR,N)) Q:'N  S DATA=$G(IBXSAVE(ARR,N)) I $P(DATA,U,1)'="" S CODE=" "_$P(DATA,U,1),SORT(ARR,CODE,N)=DATA
"RTN","IBCEF1",26,0)
 ;       Loop thru the SORT array and re-build the IBXSAVE array
"RTN","IBCEF1",27,0)
 F ARR="OCC","OCCS" K IBXSAVE(ARR) S CODE="",CT=0 F  S CODE=$O(SORT(ARR,CODE)) Q:CODE=""  S N=0 F  S N=$O(SORT(ARR,CODE,N)) Q:'N  S CT=CT+1,IBXSAVE(ARR,CT)=SORT(ARR,CODE,N)
"RTN","IBCEF1",28,0)
 ;
"RTN","IBCEF1",29,0)
 I $G(REL)'=""!($G(TEXT)'="") D OCC1("",.OCC,$G(REL),$G(TEXT)) D:'$D(OCC) OCC1("S",.OCC,$G(REL),$G(TEXT))
"RTN","IBCEF1",30,0)
OCCQ Q $G(OCC)
"RTN","IBCEF1",31,0)
 ;
"RTN","IBCEF1",32,0)
OCC1(ARR,OCC,REL,TEXT) ; Search thru local array for parameters met
"RTN","IBCEF1",33,0)
 ; ARR = null to search OCC subscript, "S" to search OCCS subscript
"RTN","IBCEF1",34,0)
 N Z
"RTN","IBCEF1",35,0)
 S ARR="OCC"_ARR,Z=0
"RTN","IBCEF1",36,0)
 F  S Z=$O(IBXSAVE(ARR,Z)) Q:'Z  D
"RTN","IBCEF1",37,0)
 .I $G(REL)'="",$P(IBXSAVE(ARR,Z),U,5)=REL S OCC="1"_$S(REL=2:U_$P(IBXSAVE(ARR,Z),U,6),1:"") Q
"RTN","IBCEF1",38,0)
 .I $G(TEXT)'="",$P(IBXSAVE(ARR,Z),U,4)=TEXT S OCC="1^"_$P(IBXSAVE(ARR,Z),U,7)
"RTN","IBCEF1",39,0)
 Q
"RTN","IBCEF1",40,0)
 ;
"RTN","IBCEF1",41,0)
RX(IBIFN) ; Format billable prescription data for refills for 837
"RTN","IBCEF1",42,0)
 N Z,IBXDATA,CT
"RTN","IBCEF1",43,0)
 I '$D(IBXSAVE("BOX24")) D B24^IBCEF3(.IBXSAVE,IBIFN,1)
"RTN","IBCEF1",44,0)
 S Z="",CT=0
"RTN","IBCEF1",45,0)
 F  S Z=$O(IBXSAVE("BOX24",Z)) Q:Z=""  I $D(IBXSAVE("BOX24",Z,"RX")) S CT=CT+1,IBXDATA(Z)=IBXSAVE("BOX24",Z,"RX")
"RTN","IBCEF1",46,0)
RXQ Q CT
"RTN","IBCEF1",47,0)
 ;
"RTN","IBCEF1",48,0)
OTHPAY(IBIFN,SEQ) ; Return the other insurance payment amount for bill
"RTN","IBCEF1",49,0)
 ;  IBIFN and payer sequence SEQ (1-3)
"RTN","IBCEF1",50,0)
 N AMT,IBIFN1
"RTN","IBCEF1",51,0)
 S IBIFN1=$P($G(^DGCR(399,IBIFN,"M1")),U,SEQ+4)
"RTN","IBCEF1",52,0)
 I IBIFN1 D
"RTN","IBCEF1",53,0)
 . I $$MCRWNR^IBEFUNC(+$G(^DGCR(399,IBIFN,"I"_SEQ))) S AMT=$$MCRPAY^IBCEU0(IBIFN) Q
"RTN","IBCEF1",54,0)
 . S AMT=+$$TPR^PRCAFN(IBIFN1) Q:AMT  ; A/R amount
"RTN","IBCEF1",55,0)
 . S AMT=+$P($G(^DGCR(399,IBIFN,"U2")),U,SEQ+3) ; amount on bill
"RTN","IBCEF1",56,0)
 Q $G(AMT)
"RTN","IBCEF1",57,0)
 ;
"RTN","IBCEF1",58,0)
OUTPT(IBIFN,IBPRINT) ; Moved for space
"RTN","IBCEF1",59,0)
 D OUTPT^IBCEF11(IBIFN,$G(IBPRINT))
"RTN","IBCEF1",60,0)
 Q
"RTN","IBCEF1",61,0)
 ;
"RTN","IBCEF1",62,0)
OCC92 ;Reformats IBXSAVE("OCC") and IBXSAVE("OCCS") to fit blocks on UB-04
"RTN","IBCEF1",63,0)
 ; Set up IBXSAVE(32-36) arrays
"RTN","IBCEF1",64,0)
 N IBPG,IB32,IB33,IB34,IB35,IB36,IBFL,Z,Z0,PG
"RTN","IBCEF1",65,0)
 S IBPG=0
"RTN","IBCEF1",66,0)
 F Z=32:1:36 K IBFL(Z) S IBFL(Z)=0
"RTN","IBCEF1",67,0)
 M IB32=IBXSAVE("OCC"),IB36=IBXSAVE("OCCS")
"RTN","IBCEF1",68,0)
 S IB32=$O(IB32(""),-1),IB36=$O(IB36(""),-1),PG=1
"RTN","IBCEF1",69,0)
 D OCC^IBCF32
"RTN","IBCEF1",70,0)
 F Z=32:1:36 S Z0="" F  S Z0=$O(IBFL(Z,Z0)) Q:'Z0  S IBXSAVE("OC92",Z,Z0)=$P(IBFL(Z,Z0),U,1,3)
"RTN","IBCEF1",71,0)
 Q
"RTN","IBCEF1",72,0)
 ;
"RTN","IBCEF1",73,0)
BATCH() ; Moved for space IB*2*349
"RTN","IBCEF1",74,0)
 Q $$BATCH^IBCEF11()
"RTN","IBCEF1",75,0)
 ;
"RTN","IBCEF1",76,0)
PROC(T,TYPE) ; Find procedure code, strip '.' Function returns result
"RTN","IBCEF1",77,0)
 ; T = Procedure internal entry #;file reference
"RTN","IBCEF1",78,0)
 ; TYPE = "CPT" for only CPT/HCPCS valid
"RTN","IBCEF1",79,0)
 ;        "ICD" for only ICD9 valid or null for either
"RTN","IBCEF1",80,0)
 N Q,S
"RTN","IBCEF1",81,0)
 S Q="",S="^"_$P($P(T,";",2),"(")
"RTN","IBCEF1",82,0)
 I $G(TYPE)="" D
"RTN","IBCEF1",83,0)
 . I $E(S,2,3)="IC" S Q=$P($$PRCD(T),U) Q
"RTN","IBCEF1",84,0)
 . I T["DIC(81.3" S Q=$$MOD^ICPTMOD(+T,"I") S Q=$S(Q>0:$P(Q,U,4),1:"")
"RTN","IBCEF1",85,0)
 I $G(TYPE)="CPT",$E(S,2,3)="IC" S Q=$$PRCD(T) Q
"RTN","IBCEF1",86,0)
 I $G(TYPE)="ICD",T["ICD0" S Q=$P($$ICD0^IBACSV(+T),U)
"RTN","IBCEF1",87,0)
 Q $TR(Q,".")
"RTN","IBCEF1",88,0)
 ;
"RTN","IBCEF1",89,0)
FACILITY(IBIFN) ;return the Facility (Institution pointer-#4) for a bill
"RTN","IBCEF1",90,0)
 ; the institution of the Bill Division (399,.22) if defined, otherwise the Facility Name (350.9,.02)
"RTN","IBCEF1",91,0)
 ;
"RTN","IBCEF1",92,0)
 N IB0,IBIN S IBIN=0
"RTN","IBCEF1",93,0)
 S IB0=$G(^DGCR(399,+$G(IBIFN),0)) I +$P(IB0,U,22) S IBIN=$$SITE^VASITE(+$P(IB0,U,3),+$P(IB0,U,22))
"RTN","IBCEF1",94,0)
 I IBIN'>0 S IBIN=+$P($G(^IBE(350.9,1,0)),U,2)
"RTN","IBCEF1",95,0)
 Q +IBIN
"RTN","IBCEF1",96,0)
 ;
"RTN","IBCEF1",97,0)
ISRX(IBIFN) ; Function to determine if bill is a prescription refill bill
"RTN","IBCEF1",98,0)
 ; Returns 0 if no Rx on bill or 1 if there is.
"RTN","IBCEF1",99,0)
 ;
"RTN","IBCEF1",100,0)
 N IBRX
"RTN","IBCEF1",101,0)
 I $D(^IBA(362.4,"AIFN"_IBIFN)) S IBRX=1
"RTN","IBCEF1",102,0)
 Q +$G(IBRX)
"RTN","IBCEF1",103,0)
 ;
"RTN","IBCEF1",104,0)
ISPROS(IBIFN) ; Function to determine if bill is a prosthetics bill
"RTN","IBCEF1",105,0)
 ; Returns 0 if no Prosthetics on bill or 1 if there is.
"RTN","IBCEF1",106,0)
 ;
"RTN","IBCEF1",107,0)
 N IBPROS
"RTN","IBCEF1",108,0)
 I $D(^IBA(362.5,"AIFN"_IBIFN)) S IBPROS=1
"RTN","IBCEF1",109,0)
 Q +$G(IBPROS)
"RTN","IBCEF1",110,0)
 ;
"RTN","IBCEF1",111,0)
FINDINS(IBIFN,IBSEQ) ; Returns the internal entry number of the insurance
"RTN","IBCEF1",112,0)
 ;  company for bill ien IBIFN for payer sequence IBSEQ (or current if
"RTN","IBCEF1",113,0)
 ;  IBSEQ is null)
"RTN","IBCEF1",114,0)
 Q $P($G(^DGCR(399,IBIFN,"I"_$$COBN^IBCEF(IBIFN,$G(IBSEQ)))),U)
"RTN","IBCEF1",115,0)
 ;
"RTN","IBCEF1",116,0)
TOB(IBIFN) ; Returns UB-04 type of bill from data in the output formatter
"RTN","IBCEF1",117,0)
 N IBTOB,IBZ1,IBZ2,IBZ3
"RTN","IBCEF1",118,0)
 D F^IBCEF("N-UB-04 LOCATION OF CARE","IBZ1",,IBIFN)
"RTN","IBCEF1",119,0)
 D F^IBCEF("N-UB-04 BILL CLASSIFICATION","IBZ2",,IBIFN)
"RTN","IBCEF1",120,0)
 D F^IBCEF("N-UB-04 TIMEFRAME OF BILL","IBZ3",,IBIFN)
"RTN","IBCEF1",121,0)
 S IBTOB=IBZ1_IBZ2_IBZ3
"RTN","IBCEF1",122,0)
 Q IBTOB
"RTN","IBCEF1",123,0)
 ;
"RTN","IBCEF1",124,0)
PRCD(PRIEN,ALL,EDT) ; Function returns the code that corresponds to the variable
"RTN","IBCEF1",125,0)
 ; pointer data in PRIEN (ien;file)
"RTN","IBCEF1",126,0)
 ; ALL = if ALL=1, returns the entire $$CPT^ICPTCOD for CPT or
"RTN","IBCEF1",127,0)
 ;       ^code^name format for ICD result
"RTN","IBCEF1",128,0)
 ;       or null if lookup fails
"RTN","IBCEF1",129,0)
 ; EDT = Effective date to check (not used if +$G(ALL)=0)
"RTN","IBCEF1",130,0)
 N CODE,IBX
"RTN","IBCEF1",131,0)
 S CODE=""
"RTN","IBCEF1",132,0)
 ;Modified for Code Set Versioning
"RTN","IBCEF1",133,0)
 I PRIEN["ICPT" S IBX=$$CPT^ICPTCOD(+PRIEN,$G(EDT)) G:IBX'>0 PRCDQ S CODE=$S($G(ALL):IBX,1:$P(IBX,U,2))
"RTN","IBCEF1",134,0)
 I PRIEN["ICD0" S IBX=$$ICD0^IBACSV(+PRIEN,$G(EDT)) G:IBX="" PRCDQ S CODE=$S($G(ALL):U_$P(IBX,U)_U_$P(IBX,U,4),1:$P(IBX,U))
"RTN","IBCEF1",135,0)
PRCDQ Q CODE
"RTN","IBCEF1",136,0)
 ;
"RTN","IBCEF1",137,0)
NFT(FT,IBIFN) ; Returns 1 if bill IBIFN is not of form type FT (internal)
"RTN","IBCEF1",138,0)
 ; so the data element should not be required
"RTN","IBCEF1",139,0)
 S FT=$S($$FT^IBCEF(IBIFN)=FT:0,1:1)
"RTN","IBCEF1",140,0)
 Q FT
"RTN","IBCEF1",141,0)
 ;
"RTN","IBCEF1",142,0)
REQ(FT,INP,IBIFN) ; Determine if bill IBIFN is of form type FT and
"RTN","IBCEF1",143,0)
 ; Inpatient (I) or Outpatient (O) status INP [or either if (null)] 
"RTN","IBCEF1",144,0)
 ;
"RTN","IBCEF1",145,0)
 ;Returns 1 if both conditions FT and INP match for the bill
"RTN","IBCEF1",146,0)
 ; or 0 if either of these conditions are not true
"RTN","IBCEF1",147,0)
 ; I $$REQ^IBCEF1(2,"I",1) would mean if bill entry #1 is
"RTN","IBCEF1",148,0)
 ;                         CMS-1500/inpatient the data would be required
"RTN","IBCEF1",149,0)
 ; I '$$REQ^IBCEF1(2,"I",1) would mean if bill entry #1 is anything but
"RTN","IBCEF1",150,0)
 ;                          CMS-1500/inpatient, the data would not be
"RTN","IBCEF1",151,0)
 ;                          required
"RTN","IBCEF1",152,0)
 N Z
"RTN","IBCEF1",153,0)
 S Z=1
"RTN","IBCEF1",154,0)
 S:$$NFT(FT,IBIFN) Z=0 ; Not the form type for requirement
"RTN","IBCEF1",155,0)
 I Z,$G(INP)'="" D
"RTN","IBCEF1",156,0)
 . S Z0=$$INPAT^IBCEF(IBIFN,1),INP=$G(INP)
"RTN","IBCEF1",157,0)
 . S Z=$S(Z0:INP="I",1:INP="O") ;Check if I/O matches required state
"RTN","IBCEF1",158,0)
 Q Z
"RTN","IBCEF1",159,0)
 ;
"RTN","IBCEF1",160,0)
SET1(IBIFN,A,IBZ,IBXDATA,IBXNOREQ) ; Utility to set variables for output
"RTN","IBCEF1",161,0)
 ; formatter for professional EDI 
"RTN","IBCEF1",162,0)
 ; Returns values of A, IBXDATA, IBZ, IBXNOREQ
"RTN","IBCEF1",163,0)
 N Z,CT
"RTN","IBCEF1",164,0)
 S A="^TMP($J,""IBLCT"")"
"RTN","IBCEF1",165,0)
 S (Z,CT)=0
"RTN","IBCEF1",166,0)
 F  S Z=$O(IBXDATA(Z)) Q:'Z  D  ; Don't transmit 0-charges
"RTN","IBCEF1",167,0)
 . ;IB*2.0*447/TAZ - Transmit $0 charges.
"RTN","IBCEF1",168,0)
 . ;I $P(IBXDATA(Z),U,9),$P(IBXDATA(Z),U,8) S CT=CT+1 M IBZ(CT)=IBXDATA(Z)
"RTN","IBCEF1",169,0)
 . I $P(IBXDATA(Z),U,9) S CT=CT+1 M IBZ(CT)=IBXDATA(Z)
"RTN","IBCEF1",170,0)
 . ;IB*2.0*447
"RTN","IBCEF1",171,0)
 K IBXDATA
"RTN","IBCEF1",172,0)
 S IBXNOREQ='$$REQ(2,"O",IBIFN)
"RTN","IBCEF1",173,0)
 Q
"RTN","IBCEF1",174,0)
 ;
"RTN","IBCEF1",175,0)
CIADDR(IBXDATA,IBXSAVE,LINE,FORM) ; Format current ins co address line LINE for FORM
"RTN","IBCEF1",176,0)
 ; FORM = 1 for CMS-1500, 2 for UB-04
"RTN","IBCEF1",177,0)
 ; Called from output formatter - both IBXDATA, IBXSAVE parameters are
"RTN","IBCEF1",178,0)
 ;  passed by reference
"RTN","IBCEF1",179,0)
 ;
"RTN","IBCEF1",180,0)
 K IBXDATA
"RTN","IBCEF1",181,0)
 I $G(FORM)'=1 D
"RTN","IBCEF1",182,0)
 . ;
"RTN","IBCEF1",183,0)
 . ; esg - 11/17/06 - IB*2*349 - UB-04 FL-38 contains the payer name
"RTN","IBCEF1",184,0)
 . ;       and address on 4 lines within this 5 line box.  All 5 lines
"RTN","IBCEF1",185,0)
 . ;       are formatted here into the IBXDATA array.  This is the
"RTN","IBCEF1",186,0)
 . ;       address that shows through the envelope window.
"RTN","IBCEF1",187,0)
 . ;
"RTN","IBCEF1",188,0)
 . ; esg - 9/13/07 - IB*2*371 - Line 1 of this box contains the print
"RTN","IBCEF1",189,0)
 . ;       status (i.e. copy, 2nd notice, 3rd notice, MRA needed).
"RTN","IBCEF1",190,0)
 . ;
"RTN","IBCEF1",191,0)
 . N Z,Z1,LM,Q,ADDR,X,IBPSTAT
"RTN","IBCEF1",192,0)
 . S LM=$P($G(^IBE(350.9,1,1)),U,31)   ; UB address column parameter
"RTN","IBCEF1",193,0)
 . S Z=""
"RTN","IBCEF1",194,0)
 . I LM S $P(Z," ",LM)=""              ; beginning spaces indent
"RTN","IBCEF1",195,0)
 . S ADDR=$G(IBXSAVE("CADR"))          ; address data string
"RTN","IBCEF1",196,0)
 . ;
"RTN","IBCEF1",197,0)
 . D F^IBCEF("N-PRINT BILL SUBMIT STATUS","IBPSTAT",,+$G(IBXIEN))
"RTN","IBCEF1",198,0)
 . S Z1=Z I Z1="" S Z1=" "     ; line 1 can't start in column 1
"RTN","IBCEF1",199,0)
 . S IBXDATA(1)=Z1_$G(IBPSTAT),Q=1             ; line 1 print status
"RTN","IBCEF1",200,0)
 . S Q=Q+1
"RTN","IBCEF1",201,0)
 . S IBXDATA(Q)=Z_$G(IBXSAVE("CADR_NAME"))     ; line 2 payer name
"RTN","IBCEF1",202,0)
 . S X=$P(ADDR,U,1)
"RTN","IBCEF1",203,0)
 . I X'="" S Q=Q+1,IBXDATA(Q)=Z_X              ; address line 1
"RTN","IBCEF1",204,0)
 . S X=$P(ADDR,U,2)
"RTN","IBCEF1",205,0)
 . I X'="" S Q=Q+1,IBXDATA(Q)=Z_X D            ; address line 2
"RTN","IBCEF1",206,0)
 .. S X=$P(ADDR,U,3)
"RTN","IBCEF1",207,0)
 .. I X'="" S IBXDATA(Q)=IBXDATA(Q)_" "_X      ; address line 3
"RTN","IBCEF1",208,0)
 .. Q
"RTN","IBCEF1",209,0)
 . S Q=Q+1                                     ; city,st,zip on last line
"RTN","IBCEF1",210,0)
 . S IBXDATA(Q)=Z_$P(ADDR,U,4)_", "_$$STATE^IBCEFG1($P(ADDR,U,5))_" "_$P(ADDR,U,6)
"RTN","IBCEF1",211,0)
 . KILL IBXSAVE("CADR_NAME"),IBXSAVE("CADR")   ; cleanup
"RTN","IBCEF1",212,0)
 . Q
"RTN","IBCEF1",213,0)
 ;
"RTN","IBCEF1",214,0)
 I $G(FORM)=1 D           ; CMS-1500
"RTN","IBCEF1",215,0)
 . N CT,X,Z
"RTN","IBCEF1",216,0)
 . S:'$D(IBXSAVE("INDENT")) Z="",$P(Z," ",+$P($G(^IBE(350.9,1,1)),U,27)+1)="",IBXSAVE("INDENT")=Z
"RTN","IBCEF1",217,0)
 . S CT=0
"RTN","IBCEF1",218,0)
 . S X=$P(IBXSAVE("CADR"),U) S:X'="" CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_X
"RTN","IBCEF1",219,0)
 . S X=$S($P(IBXSAVE("CADR"),U,2)'="":$P(IBXSAVE("CADR"),U,2),1:"")_$S($P(IBXSAVE("CADR"),U,2)'="":" ",1:"")_$P(IBXSAVE("CADR"),U,3) S:X'="" CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_X
"RTN","IBCEF1",220,0)
 . S CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_$P(IBXSAVE("CADR"),U,4)_", "_$$STATE^IBCEFG1($P(IBXSAVE("CADR"),U,5))_" "_$P(IBXSAVE("CADR"),U,6)
"RTN","IBCEF1",221,0)
 . Q
"RTN","IBCEF1",222,0)
 ;
"RTN","IBCEF1",223,0)
 Q
"RTN","IBCEF1",224,0)
 ;
"RTN","IBCEF11")
0^19^B73456164
"RTN","IBCEF11",1,0)
IBCEF11 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS - CONT ;30-JAN-96
"RTN","IBCEF11",2,0)
 ;;2.0;INTEGRATED BILLING;**51,137,155,309,335,348,349,371,432,447**;21-MAR-94;Build 80
"RTN","IBCEF11",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCEF11",4,0)
 ;
"RTN","IBCEF11",5,0)
BOX24D(A,IB) ; Returns the lines for boxes 19-24 of the CMS-1500 display
"RTN","IBCEF11",6,0)
 ; IB = flag is 1 if only box 24 is needed
"RTN","IBCEF11",7,0)
 Q $S('$G(IB):"36",1:"44")_"^55"
"RTN","IBCEF11",8,0)
 ;
"RTN","IBCEF11",9,0)
RCBOX() ; Returns the lines for revenue code boxes of the UB-04 display
"RTN","IBCEF11",10,0)
 Q "19^41"
"RTN","IBCEF11",11,0)
 ;
"RTN","IBCEF11",12,0)
OUTPT(IBIFN,IBPRINT) ; Returns an array of service line data from
"RTN","IBCEF11",13,0)
 ;                 CMS-1500 box 24.  Output is in IBXDATA(n)
"RTN","IBCEF11",14,0)
 ; IBPRINT = print flag  1: return print fields
"RTN","IBCEF11",15,0)
 ;                       0: return EDI fields
"RTN","IBCEF11",16,0)
 ; Uses diagnosis array ^TMP("IBXSAVE",$J,"DX",IBIFN,DIAG CODE)=SEQ #
"RTN","IBCEF11",17,0)
 ;   if it already exists. If not, it builds it from N-DIAGNOSES element
"RTN","IBCEF11",18,0)
 ;
"RTN","IBCEF11",19,0)
 ; For EDI call: Returns IBXDATA(n)=
"RTN","IBCEF11",20,0)
 ;   begin date(YYYYMMDD)^end date(YYYYMMDD)^pos^tos^
"RTN","IBCEF11",21,0)
 ;   proc code/revenue code - if no procedure (not the pointers)^
"RTN","IBCEF11",22,0)
 ;   type of code^dx pointer(s)^unit charge^units^modifiers separated by;
"RTN","IBCEF11",23,0)
 ;   ^purchased charge amount ^anesthesia minutes^emergency indicator^
"RTN","IBCEF11",24,0)
 ;   lab-type service flag.
"RTN","IBCEF11",25,0)
 ;
"RTN","IBCEF11",26,0)
 ;   Also Returns IBXDATA(IBI,"COB",COB,m) with COB data for each line
"RTN","IBCEF11",27,0)
 ;      item found in an accepted EOB for the bill and = the reference
"RTN","IBCEF11",28,0)
 ;      line in the first '^' piece followed by the '0' node data of file
"RTN","IBCEF11",29,0)
 ;      361.115 (LINE LEVEL ADJUSTMENTS)
"RTN","IBCEF11",30,0)
 ;       COB = COB sequence # of adjustment's ins co, m = seq #
"RTN","IBCEF11",31,0)
 ;         -- AND --
"RTN","IBCEF11",32,0)
 ;    IBXDATA(IBI,"COB",COB,m,z,p)=
"RTN","IBCEF11",33,0)
 ;           the data on the '0' node for each subordinate entry of file
"RTN","IBCEF11",34,0)
 ;           361.11511 (REASONS) (Only first 3 pieces for 837 output)
"RTN","IBCEF11",35,0)
 ;       z = group code, sometimes preceeded by a space   p = seq #
"RTN","IBCEF11",36,0)
 ;
"RTN","IBCEF11",37,0)
 ; For Print call: Returns begin date(DDMMYYYY)^end date(DDMMYYYY) or
"RTN","IBCEF11",38,0)
 ;   null if equal to begin date^pos^tos^bedsection name(if no procedure)
"RTN","IBCEF11",39,0)
 ;   or procedure code(not the pointer)^ ... refer to EDI call results
"RTN","IBCEF11",40,0)
 ;   Also, IBXDATA(n,"TEXT")=the text to print on first line of box 24,
"RTN","IBCEF11",41,0)
 ;   If no procedure code, returns IBXDATA(n,"A")=rev code abbrev
"RTN","IBCEF11",42,0)
 ;
"RTN","IBCEF11",43,0)
 ;  For both calls, returns IBXDATA(n,item type,item ptr)=""
"RTN","IBCEF11",44,0)
 ;      -- AND --
"RTN","IBCEF11",45,0)
 ;   IBXDATA(n,"RX")=RX#^drug name^NDC^refill #^(re)fill date^qty^days
"RTN","IBCEF11",46,0)
 ;                   ^chrge^ien of file 362.4^NDC format
"RTN","IBCEF11",47,0)
 ;           If line references a prescription
"RTN","IBCEF11",48,0)
 ;      -- AND --
"RTN","IBCEF11",49,0)
 ;   If no revenue code for a prescription, returns IBXDATA(n,"ARX")=""
"RTN","IBCEF11",50,0)
 ;      -- AND --
"RTN","IBCEF11",51,0)
 ;   IBXDATA(n,"AUX")='AUX' node of the procedure entry
"RTN","IBCEF11",52,0)
 ;
"RTN","IBCEF11",53,0)
 ; Also returns IBXDATA(n,"CPLNK") = soft link to corresponding entry in PROCEDURES multiple of file 399
"RTN","IBCEF11",54,0)
 ;
"RTN","IBCEF11",55,0)
 N IB,IBI,IBJ,IBFLD,IBDXI,IBXIEN,Z,IBXTRA,IBRX,IBRX0,IBRX1,Z0,Z1
"RTN","IBCEF11",56,0)
 ;
"RTN","IBCEF11",57,0)
 K ^TMP($J,"IBITEM")
"RTN","IBCEF11",58,0)
 S ^TMP($J,"IBITEM")=""
"RTN","IBCEF11",59,0)
 ; Build diagnosis array if not already built
"RTN","IBCEF11",60,0)
 I $O(^TMP("IBXSAVE",$J,"DX",IBIFN,""))="",$O(^IBA(362.3,"AIFN"_IBIFN,"")) D
"RTN","IBCEF11",61,0)
 .N Z,IBXDATA D F^IBCEF("N-DIAGNOSES",,,IBIFN)
"RTN","IBCEF11",62,0)
 .S Z="" F  S Z=$O(IBXDATA(Z)) K:$O(IBXDATA(0))=""&(Z="") IBXDATA Q:Z=""  S:$P(IBXDATA(Z),U,2) ^TMP("IBXSAVE",$J,"DX",IBIFN,$P(IBXDATA(Z),U,2))=Z
"RTN","IBCEF11",63,0)
 ;
"RTN","IBCEF11",64,0)
 S IB(0)=$G(^DGCR(399,IBIFN,0)),IB("U")=$G(^("U")),IB("U1")=$G(^("U1"))
"RTN","IBCEF11",65,0)
 S IBI="" F  S IBI=$O(^TMP("IBXSAVE",$J,"DX",IBIFN,IBI)) Q:IBI=""  S IBDXI(IBI)=^(IBI)
"RTN","IBCEF11",66,0)
 I '$G(IBPRINT) D RVCE^IBCF23(IBIFN,IBIFN)
"RTN","IBCEF11",67,0)
 I $G(IBPRINT) D RVCE^IBCF23(,IBIFN)
"RTN","IBCEF11",68,0)
 ; Returns IBFLD(24) = begin date^end date^pos^tos^
"RTN","IBCEF11",69,0)
 ;     proc/bedsection/revenue code^dx pointer^unit charge^
"RTN","IBCEF11",70,0)
 ;     units^modifiers^ purchased charge amount ^anesthesia minutes^
"RTN","IBCEF11",71,0)
 ;     emergency indicator ^ soft pointer to PROCEDURES multiple in file 399 AND
"RTN","IBCEF11",72,0)
 ;         IBFLD(24,n,type,item)=""
"RTN","IBCEF11",73,0)
 ;         IBFLD(24,n_"A") = revenue code abbreviation if no procedure
"RTN","IBCEF11",74,0)
 ;         IBFLD(24,n,"AUX") = 'AUX' node of line item 
"RTN","IBCEF11",75,0)
 ;         IBFLD(24,n,"RX") = soft pointer to file 362.4 from 'item' fld
"RTN","IBCEF11",76,0)
 ;                            (can be null)
"RTN","IBCEF11",77,0)
 ;
"RTN","IBCEF11",78,0)
 D SET^IBCSC5A(IBIFN,.IBRX) ;prescriptions
"RTN","IBCEF11",79,0)
 ; IBRX1(ien 362.4)=RX#^drug ien^NDC^refil #^(re)fil date^qty^days^chrge
"RTN","IBCEF11",80,0)
 I IBRX S IBRX="" F  S IBRX=$O(IBRX(IBRX)) Q:IBRX=""  S IBRX0=0 F  S IBRX0=$O(IBRX(IBRX,IBRX0)) Q:'IBRX0  D
"RTN","IBCEF11",81,0)
 . N IBRXH
"RTN","IBCEF11",82,0)
 . S IBRXH=IBRX(IBRX,IBRX0)
"RTN","IBCEF11",83,0)
 . ; **IB*2.0*432** added _U_$P(IBRXH,U,9) (Rx Date) to Output Formatter
"RTN","IBCEF11",84,0)
 . S IBRX1(+IBRXH)=IBRX_U_$P(IBRXH,U,2)_U_$P(IBRXH,U,5)_U_$P(IBRXH,U,7)_U_IBRX0_U_$P(IBRXH,U,4)_U_$P(IBRXH,U,3)_U_$P(IBRXH,U,6)_U_+IBRXH_U_$P(IBRXH,U,8)_U_$P(IBRXH,U,9)
"RTN","IBCEF11",85,0)
 K IBRX
"RTN","IBCEF11",86,0)
 ;
"RTN","IBCEF11",87,0)
 ; for EDI, remove any $0 line items from the IBFLD array before 
"RTN","IBCEF11",88,0)
 ; dropping down into the next loop (IB*2*371)
"RTN","IBCEF11",89,0)
 ; Start IB*2.0*447 BI - Code removed to allow 0 dollars to print.
"RTN","IBCEF11",90,0)
 ;I '$G(IBPRINT) D
"RTN","IBCEF11",91,0)
 ;. NEW IBZ,IBI,Z
"RTN","IBCEF11",92,0)
 ;. M IBZ=IBFLD K IBFLD
"RTN","IBCEF11",93,0)
 ;. S (IBI,Z)=0
"RTN","IBCEF11",94,0)
 ;. F  S IBI=$O(IBZ(24,IBI)) Q:IBI'=+IBI  D
"RTN","IBCEF11",95,0)
 ;.. I $P(IBZ(24,IBI),U,7)*$P(IBZ(24,IBI),U,8)'>0 Q
"RTN","IBCEF11",96,0)
 ;.. S Z=Z+1
"RTN","IBCEF11",97,0)
 ;.. M IBFLD(24,Z)=IBZ(24,IBI)
"RTN","IBCEF11",98,0)
 ;.. S IBFLD(24)=Z
"RTN","IBCEF11",99,0)
 ;.. Q
"RTN","IBCEF11",100,0)
 ;. Q
"RTN","IBCEF11",101,0)
 ; End IB*2.0*447 BI
"RTN","IBCEF11",102,0)
 ;
"RTN","IBCEF11",103,0)
 S IBI=0
"RTN","IBCEF11",104,0)
 F  S IBI=$O(IBFLD(24,IBI)) Q:IBI'=+IBI  D
"RTN","IBCEF11",105,0)
 . S IBRX1=0
"RTN","IBCEF11",106,0)
 . S IBXDATA(IBI)=$P(IBFLD(24,IBI),U)_U_$P(IBFLD(24,IBI),U,$S($P(IBFLD(24,IBI),U,2)=""&'$G(IBPRINT):1,1:2))
"RTN","IBCEF11",107,0)
 . S $P(IBXDATA(IBI),U,3,5)=$P(IBFLD(24,IBI),U,3,5)
"RTN","IBCEF11",108,0)
 . S $P(IBXDATA(IBI),U,6)=$S($D(IBFLD(24,IBI_"X")):"CJ",1:"HC")
"RTN","IBCEF11",109,0)
 . S $P(IBXDATA(IBI),U,7,13)=$P(IBFLD(24,IBI),U,6,12)
"RTN","IBCEF11",110,0)
 . S $P(IBXDATA(IBI),U,14)=+$$ISLAB(IBXDATA(IBI))
"RTN","IBCEF11",111,0)
 . ;
"RTN","IBCEF11",112,0)
 . I $D(IBFLD(24,IBI,"RX")) D  ;Rx
"RTN","IBCEF11",113,0)
 .. S IBRX1=1
"RTN","IBCEF11",114,0)
 .. I $P($G(IBFLD(24,IBI,"AUX")),U,8)'="" S $P(IBFLD(24,IBI,"AUX"),U,8)="",$P(IBFLD(24,IBI,"AUX"),U,9)=""  ;No free text allowed for rx's
"RTN","IBCEF11",115,0)
 .. I $D(IBRX1(+IBFLD(24,IBI,"RX"))) D  Q  ;Soft link exists
"RTN","IBCEF11",116,0)
 ...D ZERO^IBRXUTL(+$P(IBRX1(+IBFLD(24,IBI,"RX")),U,2))
"RTN","IBCEF11",117,0)
 ... S IBXDATA(IBI,"RX")=IBRX1(+IBFLD(24,IBI,"RX")),$P(IBXDATA(IBI,"RX"),U,2)=$E($G(^TMP($J,"IBDRUG",+$P(IBRX1(+IBFLD(24,IBI,"RX")),U,2),.01)),1,30)
"RTN","IBCEF11",118,0)
 ... K IBRX1(+IBFLD(24,IBI,"RX"))
"RTN","IBCEF11",119,0)
 ... ; No soft link - must find the first Rx with the same charge
"RTN","IBCEF11",120,0)
 .. S IBRX="" F  S IBRX=$O(IBRX1(IBRX)) Q:'IBRX  I +$P(IBRX1(IBRX),U,8)=+$P(IBXDATA(IBI),U,8) D  Q
"RTN","IBCEF11",121,0)
 ... D ZERO^IBRXUTL(+$P(IBRX1(IBRX),U,2))
"RTN","IBCEF11",122,0)
 ... S IBXDATA(IBI,"RX")=IBRX1(IBRX),$P(IBXDATA(IBI,"RX"),U,2)=$E($G(^TMP($J,"IBDRUG",+$P(IBRX1(IBRX),U,2),.01)),1,30) K IBRX1(IBRX) Q
"RTN","IBCEF11",123,0)
 ... Q
"RTN","IBCEF11",124,0)
 .. Q
"RTN","IBCEF11",125,0)
 . ;
"RTN","IBCEF11",126,0)
 . I $G(IBFLD(24,IBI,"AUX"))'="" D
"RTN","IBCEF11",127,0)
 .. I $G(IBPRINT),$P(IBFLD(24,IBI,"AUX"),U,8)'="" S IBXDATA(IBI,"TEXT")=$P(IBFLD(24,IBI,"AUX"),U,8),$P(IBFLD(24,IBI,"AUX"),U,8)=""
"RTN","IBCEF11",128,0)
 .. S IBXDATA(IBI,"AUX")=IBFLD(24,IBI,"AUX")
"RTN","IBCEF11",129,0)
 .. Q
"RTN","IBCEF11",130,0)
 . ;
"RTN","IBCEF11",131,0)
 . I $G(IBPRINT) D
"RTN","IBCEF11",132,0)
 .. ; START IB*2.0*447 BI ZERO DOLLAR CHANGES
"RTN","IBCEF11",133,0)
 .. ; I '$P(IBXDATA(IBI),U,8),'$G(IBXDATA(IBI,"RX")) D  Q
"RTN","IBCEF11",134,0)
 .. I $P(IBXDATA(IBI),U,8)="",'$G(IBXDATA(IBI,"RX")) D  Q
"RTN","IBCEF11",135,0)
 ... ; END IB*2.0*447 BI ZERO DOLLAR CHANGES
"RTN","IBCEF11",136,0)
 ... I $G(IBNOSHOW) Q    ; don't show errors/warnings
"RTN","IBCEF11",137,0)
 ... S IBXDATA(IBI,"TEXT")="Warning:** REV CODE UNITS < #PROCEDURES, THEY MUST BE ="
"RTN","IBCEF11",138,0)
 ... I $D(IBXDATA(IBI,"AUX")) S $P(IBXDATA(IBI,"AUX"),U,9)=""
"RTN","IBCEF11",139,0)
 ... Q
"RTN","IBCEF11",140,0)
 .. ;
"RTN","IBCEF11",141,0)
 .. I $G(IBFLD(24,IBI_"A"))'="" D  Q
"RTN","IBCEF11",142,0)
 ... S IBXDATA(IBI,"A")=IBFLD(24,IBI_"A")
"RTN","IBCEF11",143,0)
 ... I $G(IBNOSHOW) Q    ; don't show errors/warnings
"RTN","IBCEF11",144,0)
 ... S IBXDATA(IBI,"TEXT")="Warning:** REV CODE UNITS > #PROCEDURES, THEY MUST BE=: "_IBFLD(24,IBI_"A")
"RTN","IBCEF11",145,0)
 ... I $D(IBXDATA(IBI,"AUX")) S $P(IBXDATA(IBI,"AUX"),U,9)=""
"RTN","IBCEF11",146,0)
 ... Q
"RTN","IBCEF11",147,0)
 .. ;
"RTN","IBCEF11",148,0)
 .. S IBRX=$G(IBXDATA(IBI,"RX"))
"RTN","IBCEF11",149,0)
 .. I IBRX'="" D  ;Format Rx detail
"RTN","IBCEF11",150,0)
 ... N Z
"RTN","IBCEF11",151,0)
 ... S Z=$P(IBRX,U)
"RTN","IBCEF11",152,0)
 ... S Z=$S(Z'="":"Rx#"_Z_" ",1:"RX: ")
"RTN","IBCEF11",153,0)
 ... S IBXDATA(IBI,"TEXT")=Z_$S($P(IBRX,U,3)'="":"NDC: "_$P(IBRX,U,3),1:"NOC: "_$P(IBRX,U,2))_" Qty: "_$P(IBRX,U,6)_" Days: "_$P(IBRX,U,7)
"RTN","IBCEF11",154,0)
 ... S $P(IBXDATA(IBI,"AUX"),U,9)="N4"   ; service line comment qualifier for RX's
"RTN","IBCEF11",155,0)
 ... Q
"RTN","IBCEF11",156,0)
 .. Q
"RTN","IBCEF11",157,0)
 . S IBXDATA(IBI,"CPLNK")=$P(IBFLD(24,IBI),U,13)
"RTN","IBCEF11",158,0)
 . I '$G(IBPRINT) D COBLINE^IBCEU6(IBIFN,IBI,.IBXDATA,,.IBXTRA)
"RTN","IBCEF11",159,0)
 . Q
"RTN","IBCEF11",160,0)
 ;
"RTN","IBCEF11",161,0)
 I $G(IBPRINT) D
"RTN","IBCEF11",162,0)
 . S IBRX=0 F  S IBRX=$O(IBRX1(IBRX)) Q:'IBRX  D
"RTN","IBCEF11",163,0)
 .. S IBI=+$O(IBXDATA(""),-1)+1
"RTN","IBCEF11",164,0)
 .. S IBXDATA(IBI)=$$DATE($P(IBRX1(IBRX),U,5))
"RTN","IBCEF11",165,0)
 .. S IBXDATA(IBI,"TEXT")="**** ERROR - NO PROC LINK TO REV CODE FOR DRUG: RX#: "_$P(IBRX1(IBRX),U)_"  NDC #: "_$P(IBRX1(IBRX),U,3)
"RTN","IBCEF11",166,0)
 .. I $D(IBXDATA(IBI,"AUX")) S $P(IBXDATA(IBI,"AUX"),U,9)=""
"RTN","IBCEF11",167,0)
 .. S IBXDATA(IBI,"ARX")=""
"RTN","IBCEF11",168,0)
 .. D ZERO^IBRXUTL(+$P(IBRX1(IBRX),U,2))
"RTN","IBCEF11",169,0)
 .. S IBXDATA(IBI,"RX")=IBRX1(IBRX),$P(IBXDATA(IBI,"RX"),U,2)=$E($G(^TMP($J,"IBDRUG",+$P(IBRX1(IBRX),U,2),.01)),1,30) K IBRX1(IBRX)
"RTN","IBCEF11",170,0)
 .. Q
"RTN","IBCEF11",171,0)
 . Q
"RTN","IBCEF11",172,0)
 ;
"RTN","IBCEF11",173,0)
 I '$G(IBPRINT),$D(IBXTRA) D COMBO^IBCEU2(.IBXDATA,.IBXTRA,0) ;Handle bundled/unbundled lines
"RTN","IBCEF11",174,0)
 K ^TMP($J,"IBDRUG")
"RTN","IBCEF11",175,0)
 Q
"RTN","IBCEF11",176,0)
 ;
"RTN","IBCEF11",177,0)
ISLAB(LDATA) ; Returns 0/1 if line item data indicates the item is a lab (1)
"RTN","IBCEF11",178,0)
 ; 'LAB' is defined here as type of service = 5
"RTN","IBCEF11",179,0)
 Q $E($P(LDATA,U,4))="5"
"RTN","IBCEF11",180,0)
 ;
"RTN","IBCEF11",181,0)
FMT(DATA,DLEN,FLEN) ; Returns a string in DATA with a max length of DLEN
"RTN","IBCEF11",182,0)
 ;  and a field length of FLEN
"RTN","IBCEF11",183,0)
 Q $E($E(DATA,1,DLEN)_$J("",FLEN),1,FLEN)
"RTN","IBCEF11",184,0)
 ;
"RTN","IBCEF11",185,0)
DATE(X,DEL) ;  Returns FM date in X as MMxDDxYYYY  where x=DEL
"RTN","IBCEF11",186,0)
 S DEL=$G(DEL)
"RTN","IBCEF11",187,0)
 S X=$$DATE^IBCF2(X,1,1)
"RTN","IBCEF11",188,0)
 I X'="" S X=$E(X,1,2)_DEL_$E(X,3,4)_DEL_$E(X,5,8)
"RTN","IBCEF11",189,0)
 Q X
"RTN","IBCEF11",190,0)
 ;
"RTN","IBCEF11",191,0)
BATCH() ; Sets up record for and stores/returns the next batch number
"RTN","IBCEF11",192,0)
 N NUM,FAC,DO,DD,DLAYGO,DIC,X,Y
"RTN","IBCEF11",193,0)
 ;Keep latest batch number for view/print edi bill extract data option
"RTN","IBCEF11",194,0)
 I $D(IBVNUM) S NUM=IBVNUM G BATCHQ
"RTN","IBCEF11",195,0)
 ;Check for batch resubmit - if yes, use same number as original batch
"RTN","IBCEF11",196,0)
 I $P($G(^TMP("IBRESUBMIT",$J)),U,3)=1 S NUM=$P(^($J),U) G BATCHQ
"RTN","IBCEF11",197,0)
 L +^IBA(364.1,0):5 I '$T Q 0
"RTN","IBCEF11",198,0)
 S FAC=+$P($$SITE^VASITE(),U,3),NUM=$O(^IBA(364.1,"B",""),-1)
"RTN","IBCEF11",199,0)
 I $D(^IBA(364.1,+NUM,0)),$P(^(0),U,2)="" F  D  Q:'NUM!($P($G(^IBA(364.1,+NUM,0)),U,2)'="")
"RTN","IBCEF11",200,0)
 . I $D(^IBA(364.1,NUM,0)) S DA=NUM,DIK="^IBA(364.1," D ^DIK
"RTN","IBCEF11",201,0)
 . S NUM=$O(^IBA(364.1,"B",""),-1)
"RTN","IBCEF11",202,0)
 F  S NUM=$S($P(NUM,FAC,2)'="":NUM+1,1:FAC_"0000001") Q:'$D(^IBA(364.1,"B",NUM))
"RTN","IBCEF11",203,0)
 K DO,DD S DIC="^IBA(364.1,",DLAYGO=364.1,DIC(0)="L",X=NUM D FILE^DICN K DD,DO I Y'>0 S NUM=0
"RTN","IBCEF11",204,0)
 L -^IBA(364.1,0)
"RTN","IBCEF11",205,0)
BATCHQ Q NUM
"RTN","IBCEF11",206,0)
 ;
"RTN","IBCEF11",207,0)
GETLDAT(IBXIEN) ; Extract data for 837 transmission LDAT record
"RTN","IBCEF11",208,0)
 ; IBXIEN - ien in file 399
"RTN","IBCEF11",209,0)
 ; Sets up IBXSAVE("LDAT",n) array:
"RTN","IBCEF11",210,0)
 ; Attachment report type ^ Attachment report transmission code ^ Attachment control number ^ 
"RTN","IBCEF11",211,0)
 ; OB Anesthesia Additional Units ^ Purchase Service Provider ID ^ Purchase Service Amount ^
"RTN","IBCEF11",212,0)
 N CPIEN,FTYPE,IBXDATA,IDS,NODE1,PSAMNT,PSPID,Z,PCE1,LINE
"RTN","IBCEF11",213,0)
 I '+$G(IBXIEN) Q
"RTN","IBCEF11",214,0)
 K IBXSAVE("LDAT")
"RTN","IBCEF11",215,0)
 S FTYPE=$$FT^IBCEF(IBXIEN)
"RTN","IBCEF11",216,0)
 I FTYPE=2 D OUTPT(IBXIEN,0)
"RTN","IBCEF11",217,0)
 I FTYPE=3 D HOS^IBCEF2(IBXIEN)
"RTN","IBCEF11",218,0)
 D ALLIDS^IBCEFP(IBXIEN,.IDS,1)
"RTN","IBCEF11",219,0)
 S PSPID=$P($G(IDS("LAB/FAC",IBXIEN,"C",1,1)),U,2)
"RTN","IBCEF11",220,0)
 I PSPID="" S PSPID=$P($$ORGNPI^IBCEF73A(IBXIEN),U,1)
"RTN","IBCEF11",221,0)
 ;IB*2.0*432/TAZ - Get Rendering Provider NPI if Facility NPI is null.
"RTN","IBCEF11",222,0)
 I PSPID="" S PSPID=$P($G(IDS("PROVINF",IBIFN,"C",1,3,0)),U,4)  ; Get claim level Rendering Provider NPI
"RTN","IBCEF11",223,0)
 I PSPID="",$D(IDS("L-PROV")) D  ; Get 1st line level Rendering Provider NPI
"RTN","IBCEF11",224,0)
 . F LINE=1:1:$O(IDS("L-PROV",IBIFN,""),-1) D  I PSPID'="" Q
"RTN","IBCEF11",225,0)
 .. S PSPID=$P($G(IDS("L-PROV",IBIFN,LINE,"C",1,3,0)),U,4)
"RTN","IBCEF11",226,0)
 ;IB*2.0*432/TAZ - END
"RTN","IBCEF11",227,0)
 S Z=0 F  S Z=$O(IBXDATA(Z)) Q:'Z  D
"RTN","IBCEF11",228,0)
 .S CPIEN=+$G(IBXDATA(Z,"CPLNK")) ;I 'CPIEN Q
"RTN","IBCEF11",229,0)
 .I FTYPE=2 S PSAMNT=$$DOLLAR^IBCEFG1($P($G(IBXDATA(Z)),U,11))
"RTN","IBCEF11",230,0)
 .I FTYPE=3 S PSPID="" ;S PSAMNT=$P($G(IBXDATA(Z)),U,5) ;WCJ; not a purchased service
"RTN","IBCEF11",231,0)
 .I '$$SUB1OK^IBCEP8A(IBXIEN) S (PSPID,PSAMNT)=""
"RTN","IBCEF11",232,0)
 .S (PCE1,NODE1)=""
"RTN","IBCEF11",233,0)
 .I CPIEN D
"RTN","IBCEF11",234,0)
 ..S NODE1=$G(^DGCR(399,IBXIEN,"CP",CPIEN,1))
"RTN","IBCEF11",235,0)
 ..S PCE1=$$GET1^DIQ(399.0304,CPIEN_","_IBXIEN_",",71)
"RTN","IBCEF11",236,0)
 .S IBXSAVE("LDAT",Z)=PCE1_U_$P(NODE1,U,3)_U_$P(NODE1,U)_U_$P(NODE1,U,5)_U_$G(PSPID)_U_$G(PSAMNT)
"RTN","IBCEF11",237,0)
 .Q
"RTN","IBCEF11",238,0)
 Q
"RTN","IBCEFP")
0^48^B100162925
"RTN","IBCEFP",1,0)
IBCEFP ;ALB/TAZ - Provider ID functions ;28-OCT-10
"RTN","IBCEFP",2,0)
 ;;2.0;INTEGRATED BILLING;**432,447**;21-MAR-94;Build 80
"RTN","IBCEFP",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCEFP",4,0)
 ;
"RTN","IBCEFP",5,0)
 Q
"RTN","IBCEFP",6,0)
 ;
"RTN","IBCEFP",7,0)
ALLIDS(IBIFN,IBXSAVE,IBSTRIP,SEG) ; Return all of the Provider IDS
"RTN","IBCEFP",8,0)
 I '$D(IBSTRIP) S IBSTRIP=0
"RTN","IBCEFP",9,0)
 I '$D(SEG) S SEG=""
"RTN","IBCEFP",10,0)
 N IBXIEN,ARINFO,ARID,ARQ,IBFRMTYP,ARIEN,ARINS,Z0,DAT,I,SORT1,SORT2,SORT3,COB,IBCCOB,IBCARE,IBCURR,IBXDATA,NPI,CUROTH
"RTN","IBCEFP",11,0)
 ;
"RTN","IBCEFP",12,0)
 S IBFRMTYP=$$FT^IBCEF(IBIFN),IBFRMTYP=$S(IBFRMTYP=2:2,IBFRMTYP=3:1,1:0)
"RTN","IBCEFP",13,0)
 S IBCARE=$S($$ISRX^IBCEF1(IBIFN):3,1:0) ;if an Rx refill bill
"RTN","IBCEFP",14,0)
 S:IBCARE=0 IBCARE=$$INPAT^IBCEF(IBIFN,1) S:'IBCARE IBCARE=2 ;1-inp,2-out
"RTN","IBCEFP",15,0)
 S IBCURR=$$COB^IBCEF(IBIFN) ;current bill payer sequence
"RTN","IBCEFP",16,0)
 ;don't create anything if form type not CMS-1500 or UB
"RTN","IBCEFP",17,0)
 I IBFRMTYP,'+$G(IBXSAVE("PROVINF",IBIFN)) D
"RTN","IBCEFP",18,0)
 . N IBZ,CUROTH
"RTN","IBCEFP",19,0)
 . I IBFRMTYP=2 D OUTPT^IBCEF11(IBIFN,0)
"RTN","IBCEFP",20,0)
 . I IBFRMTYP=1 D HOS^IBCEF22(IBIFN)
"RTN","IBCEFP",21,0)
 . ; START IB*2.0*447 BI
"RTN","IBCEFP",22,0)
 . I IBCURR="A" D  Q
"RTN","IBCEFP",23,0)
 .. N IBRESARR
"RTN","IBCEFP",24,0)
 .. S IBLIMIT=5
"RTN","IBCEFP",25,0)
 .. D PROVINF(IBIFN,1,.IBRESARR,1,"C",IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
"RTN","IBCEFP",26,0)
 .. M IBXSAVE=IBRESARR
"RTN","IBCEFP",27,0)
 .. S IBXSAVE("PROVINF",IBIFN)=IBIFN
"RTN","IBCEFP",28,0)
 . ; END IB*2.0*447 BI
"RTN","IBCEFP",29,0)
 . F CUROTH="C","O" D PROVIDER(IBIFN,CUROTH,.IBZ,IBFRMTYP,IBCARE,IBCURR,.IBXDATA) M IBXSAVE=IBZ
"RTN","IBCEFP",30,0)
 . S IBXSAVE("PROVINF",IBIFN)=IBIFN
"RTN","IBCEFP",31,0)
 . Q
"RTN","IBCEFP",32,0)
 ;
"RTN","IBCEFP",33,0)
 D LFIDS^IBCEF76(IBIFN,.IBXSAVE,IBSTRIP,SEG)   ; Get the Lab/Facility IDs
"RTN","IBCEFP",34,0)
 S NPI=$P($$ORGNPI^IBCEF73A(IBIFN),U,1)
"RTN","IBCEFP",35,0)
 F CUROTH="C","O" D
"RTN","IBCEFP",36,0)
 . S IBXSAVE("LAB/FAC",IBIFN,CUROTH,1,0)=$S(NPI]"":"XX",1:"")_U_NPI
"RTN","IBCEFP",37,0)
 ;
"RTN","IBCEFP",38,0)
 S IBFRMTYP=$$FT^IBCEF(IBIFN)
"RTN","IBCEFP",39,0)
 S ARIEN=$S(IBFRMTYP=2:3,1:4)
"RTN","IBCEFP",40,0)
 S IBCCOB=$$COBN^IBCEF(IBIFN)  ; Current Insurance
"RTN","IBCEFP",41,0)
 F COB=1:1:3 D
"RTN","IBCEFP",42,0)
 . S SORT1=$S(COB=IBCCOB:"C",1:"O")
"RTN","IBCEFP",43,0)
 . S SORT2=$S(SORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2)
"RTN","IBCEFP",44,0)
 . S ARINFO=$G(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,ARIEN,1))
"RTN","IBCEFP",45,0)
 . ;
"RTN","IBCEFP",46,0)
 . D BPIDS^IBCEF75(IBIFN,.IBXSAVE,SORT1,SORT2,COB,IBSTRIP,SEG)
"RTN","IBCEFP",47,0)
 ;
"RTN","IBCEFP",48,0)
 D EN^IBCEF81(.IBXSAVE)
"RTN","IBCEFP",49,0)
 ;
"RTN","IBCEFP",50,0)
 I SEG="OPR1" D
"RTN","IBCEFP",51,0)
 . I '$D(IBXSAVE("PROVINF",IBIFN,"C",1,3)) D  G ALLIDSQ
"RTN","IBCEFP",52,0)
 .. N SLC,CRED S SLC=0
"RTN","IBCEFP",53,0)
 .. F  S SLC=$O(IBXSAVE("L-PROV",IBIFN,SLC)) Q:'SLC  D  I $D(IBXSAVE("PROVINF",IBIFN,"C",1,3,"NAME")) Q
"RTN","IBCEFP",54,0)
 ... S CRED=$P($G(IBXSAVE("L-PROV",IBIFN,SLC,"C",1,3,"NAME")),U,4)
"RTN","IBCEFP",55,0)
 ... I CRED]"" S $P(IBXSAVE("PROVINF",IBIFN,"C",1,3,"NAME"),U,4)=CRED
"RTN","IBCEFP",56,0)
 ;
"RTN","IBCEFP",57,0)
 I SEG="LPUR",$$SUB1OK^IBCEP8A(IBIFN),$G(IBXSAVE("SLC")) D  G ALLIDSQ
"RTN","IBCEFP",58,0)
 . N IBCNT,OUT,SID,SIDQ,IBPID,LINE
"RTN","IBCEFP",59,0)
 . S (SID,SIDQ)=""
"RTN","IBCEFP",60,0)
 . F LINE=1:1 Q:'$D(IBXSAVE("LAB/FAC",IBIFN,"C",1,LINE))  D  I SID'="" Q
"RTN","IBCEFP",61,0)
 .. S SIDQ=$P($G(IBXSAVE("LAB/FAC",IBIFN,"C",1,LINE)),U) I ",0B,1G,G2,"'[(","_SIDQ_",") Q
"RTN","IBCEFP",62,0)
 .. S SID=$P($G(IBXSAVE("LAB/FAC",IBIFN,"C",1,LINE)),U,2)
"RTN","IBCEFP",63,0)
 . ;S $P(OUT,U,6)=$P($G(IBXSAVE("LAB/FAC",IBIFN,"C",1,0)),U,2) ; primary id
"RTN","IBCEFP",64,0)
 . ;IB*2.0*432/TAZ - changed to make sure there is an ID for the Non-VA Service Facility
"RTN","IBCEFP",65,0)
 . S IBPID=$P($G(IBXSAVE("LAB/FAC",IBIFN,"C",1,0)),U,2) ; primary id
"RTN","IBCEFP",66,0)
 . I (IBPID=""),(SID="") D
"RTN","IBCEFP",67,0)
 .. S IBPID=$P($G(IBXSAVE("PROVINF",IBIFN,"C",1,3,0)),U,4)  ; Get claim level Rendering Provider NPI
"RTN","IBCEFP",68,0)
 .. I IBPID="",$D(IBXSAVE("L-PROV")) D
"RTN","IBCEFP",69,0)
 ... F LINE=1:1:$O(IBXSAVE("L-PROV",IBIFN,""),-1) D  I IBPID'="" Q
"RTN","IBCEFP",70,0)
 .... S IBPID=$P($G(IBXSAVE("L-PROV",IBIFN,LINE,"C",1,3,0)),U,4)
"RTN","IBCEFP",71,0)
 . S $P(OUT,U,6)=IBPID
"RTN","IBCEFP",72,0)
 . S $P(OUT,U,7)=SID ; secondary id (1)
"RTN","IBCEFP",73,0)
 . S $P(OUT,U,8)=SIDQ ; secondary id qualifier(1)
"RTN","IBCEFP",74,0)
 . F IBCNT=1:1:IBXSAVE("SLC") S IBXSAVE("SLPRV",IBCNT)=OUT,IBXSAVE("SLPRV",IBCNT,"SLC")=IBCNT
"RTN","IBCEFP",75,0)
 ;
"RTN","IBCEFP",76,0)
 I SEG="LOPE" D SLPRV(IBIFN,.IBXSAVE,2) G ALLIDSQ
"RTN","IBCEFP",77,0)
 I SEG="LOP1" D SLPRV(IBIFN,.IBXSAVE,9) G ALLIDSQ
"RTN","IBCEFP",78,0)
 I SEG="LREN" D SLPRV(IBIFN,.IBXSAVE,3) G ALLIDSQ
"RTN","IBCEFP",79,0)
 I SEG="LSUP" D SLPRV(IBIFN,.IBXSAVE,5) G ALLIDSQ
"RTN","IBCEFP",80,0)
 I SEG="LREF" D SLPRV(IBIFN,.IBXSAVE,1) G ALLIDSQ
"RTN","IBCEFP",81,0)
 ;
"RTN","IBCEFP",82,0)
ALLIDSQ ;
"RTN","IBCEFP",83,0)
 Q
"RTN","IBCEFP",84,0)
 ;
"RTN","IBCEFP",85,0)
SLPRV(IBXIEN,IBX,PRTYPE) ;Build SLPRV nodes for the line provider type record
"RTN","IBCEFP",86,0)
 N SLC,DATA,IBCNT,NAME,OUT
"RTN","IBCEFP",87,0)
 S (SLC,IBCNT)=0
"RTN","IBCEFP",88,0)
 F  S SLC=$O(IBX("L-PROV",IBXIEN,SLC)) Q:'SLC  D
"RTN","IBCEFP",89,0)
 . I '$D(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE)) Q
"RTN","IBCEFP",90,0)
 . S NAME=$G(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,"NAME"))
"RTN","IBCEFP",91,0)
 . S OUT=$P(NAME,U,1,3)_U_$P(NAME,U,5)_U_$G(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,"TAXONOMY"))_U_$P($G(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,0)),U,4)
"RTN","IBCEFP",92,0)
 . F IBN=1:1 Q:'$D(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,IBN))  D
"RTN","IBCEFP",93,0)
 .. S DATA=$G(IBX("L-PROV",IBXIEN,SLC,"C",1,PRTYPE,IBN))
"RTN","IBCEFP",94,0)
 .. I ",0B,1G,G2,LU,"[(","_$P(DATA,U,3)_",") S OUT=OUT_U_$P(DATA,U,4)_U_$P(DATA,U,3)
"RTN","IBCEFP",95,0)
 . S IBCNT=IBCNT+1
"RTN","IBCEFP",96,0)
 . S IBX("SLPRV",IBCNT)=OUT
"RTN","IBCEFP",97,0)
 . S IBX("SLPRV",IBCNT,"SLC")=SLC
"RTN","IBCEFP",98,0)
SLPRVQ ;
"RTN","IBCEFP",99,0)
 Q
"RTN","IBCEFP",100,0)
 ;
"RTN","IBCEFP",101,0)
 ;PROVIDER
"RTN","IBCEFP",102,0)
 ;Input:
"RTN","IBCEFP",103,0)
 ; IB399 - ien of #399
"RTN","IBCEFP",104,0)
 ; IBPROV:
"RTN","IBCEFP",105,0)
 ;   "C"- to get info for CURRENT provider
"RTN","IBCEFP",106,0)
 ;   "O"- to get info for all others (in this case the array will contain info fot two providers
"RTN","IBCEFP",107,0)
 ; IBRES - array for results (by reference)
"RTN","IBCEFP",108,0)
 ; IBFRMTYP - Form Type
"RTN","IBCEFP",109,0)
 ; IBCARE - Care Type
"RTN","IBCEFP",110,0)
 ; IBCURR - current bill payer sequence
"RTN","IBCEFP",111,0)
 ;
"RTN","IBCEFP",112,0)
 ;Output:
"RTN","IBCEFP",113,0)
 ; IBRES - array to get back info (by reference)
"RTN","IBCEFP",114,0)
 ; IBRES(IBPROV,PRNUM,PRTYPE,SEQ#)=PROV^INSUR^IDTYPE^ID^FORMTYP^CARETYP
"RTN","IBCEFP",115,0)
 ; where:
"RTN","IBCEFP",116,0)
 ; IBPROV - see input parameter
"RTN","IBCEFP",117,0)
 ; PRNUM: 1=primary insurance provider, 2= secondary, 3 -tretiary
"RTN","IBCEFP",118,0)
 ; PRTYPE: Provider type(FUNCTION) 
"RTN","IBCEFP",119,0)
 ; SEQ# : sequence number (1st is used for ID1, 2nd - for ID2, etc)
"RTN","IBCEFP",120,0)
 ; PROV : provider/VARIABLEPTR
"RTN","IBCEFP",121,0)
 ; INSUR: Insurance PTR #36 or NONE
"RTN","IBCEFP",122,0)
 ; IDTYPE: ID type
"RTN","IBCEFP",123,0)
 ; ID: ID 
"RTN","IBCEFP",124,0)
 ; FORMTYP: Form type 1=UB,2=1500
"RTN","IBCEFP",125,0)
 ; CARETYP: Care type 0=both inp/outp,1=inpatient, 2=outpatient
"RTN","IBCEFP",126,0)
PROVIDER(IB399,IBPROV,IBRES,IBFRMTYP,IBCARE,IBCURR,IBXDATA) ;
"RTN","IBCEFP",127,0)
 N IBZ,IBRESARR,IBLIMIT
"RTN","IBCEFP",128,0)
 S IBRESARR=""
"RTN","IBCEFP",129,0)
 Q:IBCURR="A"  ;PATIENT's bill IB*2.0*447 BI Changes IBPROV to IBCURR
"RTN","IBCEFP",130,0)
 I IBPROV="C" D
"RTN","IBCEFP",131,0)
 . S IBLIMIT=5
"RTN","IBCEFP",132,0)
 . D:$$ISINSUR^IBCEF71(IBCURR,IB399) PROVINF(IB399,$S(IBCURR="T":3,IBCURR="S":2,IBCURR="P":1,1:1),.IBRESARR,1,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
"RTN","IBCEFP",133,0)
 I IBPROV="O" D
"RTN","IBCEFP",134,0)
 . S IBLIMIT=3
"RTN","IBCEFP",135,0)
 . I IBCURR="P" D
"RTN","IBCEFP",136,0)
 .. D:$$ISINSUR^IBCEF71("S",IB399) PROVINF(IB399,2,.IBRESARR,1,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
"RTN","IBCEFP",137,0)
 .. D:$$ISINSUR^IBCEF71("T",IB399) PROVINF(IB399,3,.IBRESARR,2,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
"RTN","IBCEFP",138,0)
 . I IBCURR="S" D
"RTN","IBCEFP",139,0)
 .. D:$$ISINSUR^IBCEF71("P",IB399) PROVINF(IB399,1,.IBRESARR,1,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
"RTN","IBCEFP",140,0)
 .. D:$$ISINSUR^IBCEF71("T",IB399) PROVINF(IB399,3,.IBRESARR,2,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
"RTN","IBCEFP",141,0)
 . I IBCURR="T" D
"RTN","IBCEFP",142,0)
 .. D:$$ISINSUR^IBCEF71("P",IB399) PROVINF(IB399,1,.IBRESARR,1,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
"RTN","IBCEFP",143,0)
 .. D:$$ISINSUR^IBCEF71("S",IB399) PROVINF(IB399,2,.IBRESARR,2,IBPROV,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,.IBXDATA)
"RTN","IBCEFP",144,0)
 M IBRES=IBRESARR
"RTN","IBCEFP",145,0)
 Q
"RTN","IBCEFP",146,0)
 ;
"RTN","IBCEFP",147,0)
 ;-- PROVINF --
"RTN","IBCEFP",148,0)
 ;Create array with prov info
"RTN","IBCEFP",149,0)
 ;Input:
"RTN","IBCEFP",150,0)
 ; IB399 - ien #399
"RTN","IBCEFP",151,0)
 ; IBPRNUM - 1=prim ins, 2= sec, 3 -tert
"RTN","IBCEFP",152,0)
 ; IBRES - for results
"RTN","IBCEFP",153,0)
 ; IBSORT - to sort OTHER INSURANCE data 
"RTN","IBCEFP",154,0)
 ;  if PROVINF is called for "C" mode of PROVIDER subroutine then 
"RTN","IBCEFP",155,0)
 ;    IBSORT can be any (say 1)
"RTN","IBCEFP",156,0)
 ;  if PROVINF is called for "O" mode then can be more than set of data
"RTN","IBCEFP",157,0)
 ;    - need to sort array to use it (like IBXDATA(1) and IBXDATA(2))
"RTN","IBCEFP",158,0)
 ;    for mode "O" it should be 1 or 2 (see PROVIDER section)
"RTN","IBCEFP",159,0)
 ;IBINSTP -  "C" -current ins, "O"-other
"RTN","IBCEFP",160,0)
 ;IBFRMTYP - Form Type
"RTN","IBCEFP",161,0)
 ;IBCARE - Care Type
"RTN","IBCEFP",162,0)
 ;IBLIMIT - Limits on Secondary
"RTN","IBCEFP",163,0)
 ;IBCURR - Current Insurance
"RTN","IBCEFP",164,0)
 ;IBXDAYA - Revenue Code Array
"RTN","IBCEFP",165,0)
 ;Output:
"RTN","IBCEFP",166,0)
 ; IBRES(PRNUM,PRTYPE,SEQ#)=PROV^INSUR^IDTYPE^ID^FORMTYP^CARETYP
"RTN","IBCEFP",167,0)
 ; where:(see PROVIDER)
"RTN","IBCEFP",168,0)
PROVINF(IB399,IBPRNUM,IBRES,IBSORT,IBINSTP,IBFRMTYP,IBCARE,IBLIMIT,IBCURR,IBXDATA) ;
"RTN","IBCEFP",169,0)
 I $G(IB399)="" G PROVINFQ
"RTN","IBCEFP",170,0)
 I $G(IBINSTP)="" G PROVINFQ
"RTN","IBCEFP",171,0)
 I +$G(IBSORT)=0 S IBSORT=$G(IBPRNUM)
"RTN","IBCEFP",172,0)
 N IBPRTYP,IBINSCO,IBPROV,IB35591,IBN,IBEXC
"RTN","IBCEFP",173,0)
 S IBN=0
"RTN","IBCEFP",174,0)
 S IBINSCO=+$P($G(^DGCR(399,IB399,"M")),"^",IBPRNUM)
"RTN","IBCEFP",175,0)
 S IB35591=$$CH35591^IBCEF72(IBINSCO,IBFRMTYP,IBCARE)
"RTN","IBCEFP",176,0)
 S IBPRTYP=0
"RTN","IBCEFP",177,0)
 F  S IBPRTYP=$O(^DGCR(399,IB399,"PRV","B",IBPRTYP)) Q:'IBPRTYP  D
"RTN","IBCEFP",178,0)
 . N Z,IB355OV,IBPROV,IBARR
"RTN","IBCEFP",179,0)
 . S IBPROV=$$PROVPTR(IB399,IBPRTYP,0),IBEXC=""
"RTN","IBCEFP",180,0)
 . Q:+IBPROV=0
"RTN","IBCEFP",181,0)
 . S Z=$O(^DGCR(399,IB399,"PRV","B",IBPRTYP,0)) I Z S Z=$G(^DGCR(399,IB399,"PRV",Z,0))
"RTN","IBCEFP",182,0)
 . D GETPRV(IBINSCO,IBFRMTYP,IBCARE,IBPROV,.IBARR,IBPRTYP,IBINSTP,Z)
"RTN","IBCEFP",183,0)
 . M IBRES("PROVINF",IB399,IBINSTP)=IBARR
"RTN","IBCEFP",184,0)
 I $D(IBRES("PROVINF",IB399,IBINSTP,IBSORT))>1 S IBRES("PROVINF",IB399,IBINSTP,IBSORT)=$S(IBPRNUM=3:"T",IBPRNUM=2:"S",1:"P")
"RTN","IBCEFP",185,0)
 N SLC,CPLNK
"RTN","IBCEFP",186,0)
 S SLC=0
"RTN","IBCEFP",187,0)
 F  S SLC=$O(IBXDATA(SLC)) Q:'SLC   S IBXSAVE("SLC")=+SLC D
"RTN","IBCEFP",188,0)
 . S CPLNK=$G(IBXDATA(SLC,"CPLNK")) I 'CPLNK Q
"RTN","IBCEFP",189,0)
 . S IBPRTYP=0
"RTN","IBCEFP",190,0)
 . F  S IBPRTYP=$O(^DGCR(399,IB399,"CP",CPLNK,"LNPRV","B",IBPRTYP)) Q:'IBPRTYP  D
"RTN","IBCEFP",191,0)
 .. N Z,IBPROV,IBARR
"RTN","IBCEFP",192,0)
 .. S IBPROV=$$PROVPTR(IB399,IBPRTYP,CPLNK),IBEXC=""
"RTN","IBCEFP",193,0)
 .. Q:'+IBPROV
"RTN","IBCEFP",194,0)
 .. S Z=$O(^DGCR(399,IB399,"CP",CPLNK,"LNPRV","B",IBPRTYP,0)) I Z S Z=$G(^DGCR(399,IB399,"CP",CPLNK,"LNPRV",Z,0))
"RTN","IBCEFP",195,0)
 .. D GETPRV(IBINSCO,IBFRMTYP,IBCARE,IBPROV,.IBARR,IBPRTYP,IBINSTP,Z)
"RTN","IBCEFP",196,0)
 .. M IBRES("L-PROV",IB399,SLC,IBINSTP)=IBARR
"RTN","IBCEFP",197,0)
 . I $D(IBRES("L-PROV",IB399,SLC,IBINSTP,IBSORT))>1 S IBRES("L-PROV",IB399,SLC,IBINSTP,IBSORT)=$S(IBPRNUM=3:"T",IBPRNUM=2:"S",1:"P")
"RTN","IBCEFP",198,0)
 ;
"RTN","IBCEFP",199,0)
PROVINFQ ;Exit PROVINF
"RTN","IBCEFP",200,0)
 Q
"RTN","IBCEFP",201,0)
 ;
"RTN","IBCEFP",202,0)
GETPRV(IBINSCO,IBFRMTYP,IBCARE,IBPROV,IBRES,IBPRTYP,IBINSTP,IBD) ;
"RTN","IBCEFP",203,0)
 I "CO"'[$G(IBINSTP) G GETPRVQ
"RTN","IBCEFP",204,0)
 N IBRETARR,IBNPI,IBN,IBMRAND,IB355OV S IBRETARR=0,IB355OV=""
"RTN","IBCEFP",205,0)
 D PRACT^IBCEF71(IBINSCO,IBFRMTYP,IBCARE,IBPROV,.IBRETARR,IBPRTYP,$G(IBINSTP))
"RTN","IBCEFP",206,0)
 I $P(IBD,U,IBPRNUM+4)'="",$P(IBD,U,IBPRNUM+11)'="" S IB355OV=$P(IBD,U,IBPRNUM+4)_U_$P(IBD,U,IBPRNUM+11)
"RTN","IBCEFP",207,0)
 S IBN=0,IBMRAND=$$MCRONBIL^IBEFUNC(IB399)
"RTN","IBCEFP",208,0)
 ;Calculate MEDICARE (WNR) specific provider qualifier and ID for CMS-1500 secondary claims
"RTN","IBCEFP",209,0)
 I "34"[$G(IBPRTYP),$G(IBFRMTYP)=2,IBMRAND S IB355OV=$$MCR24K^IBCEU3(IB399,IBPROV)_"^12"
"RTN","IBCEFP",210,0)
 I $P(IB355OV,U,2) D
"RTN","IBCEFP",211,0)
 . I $$CHCKSEC^IBCEF73(IBFRMTYP,IBPRTYP,$G(IBINSTP),$P($G(^IBE(355.97,+$P(IB355OV,U,2),0)),U,3)) D
"RTN","IBCEFP",212,0)
 .. S IBEXC=$P(IB355OV,U,2),IBN=IBN+1,IBRES(IBSORT,IBPRTYP,IBN)="OVERRIDE^"_IBINSCO_U_$P($G(^IBE(355.97,+IBEXC,0)),U,3)_U_$P(IB355OV,U)_"^^^^^"_+IBEXC
"RTN","IBCEFP",213,0)
 I IB35591'="",IBEXC'=$P(IB35591,U,3) I $$CHCKSEC^IBCEF73(IBFRMTYP,IBPRTYP,$G(IBINSTP),$P(IB35591,"^")) D
"RTN","IBCEFP",214,0)
 . S IBN=IBN+1,IBRES(IBSORT,IBPRTYP,IBN)="DEFAULT^"_IBINSCO_"^"_IB35591_"^^",$P(IBRES(IBSORT,IBPRTYP,IBN),U,9)=$P(IB35591,U,3)
"RTN","IBCEFP",215,0)
 S IBNPI=$$NPI^IBCEFP1(IBPROV)
"RTN","IBCEFP",216,0)
 D SORT^IBCEF77(IBSORT,IBPRTYP,IB399,.IBRETARR,.IBRES,IBN,IBEXC,IBPRNUM,IBLIMIT)
"RTN","IBCEFP",217,0)
 S IBRES(IBSORT,IBPRTYP,0)="PRIMARY"_U_U_$$STRIP^IBCEF76($S(IBNPI]"":"XX",1:"")_U_IBNPI,1,U,IBSTRIP)
"RTN","IBCEFP",218,0)
 F IBN=1:1 Q:'$D(IBRES(IBSORT,IBPRTYP,IBN))  S $P(IBRES(IBSORT,IBPRTYP,IBN),U,3,4)=$$STRIP^IBCEF76($P(IBRES(IBSORT,IBPRTYP,IBN),U,3,4),1,U,IBSTRIP)
"RTN","IBCEFP",219,0)
 S IBRES(IBSORT,IBPRTYP,"NAME")=$$NAME^IBCEFP1(IBPROV,IBIFN,$P(IBD,U,3),$P(IBD,U,8))
"RTN","IBCEFP",220,0)
 S IBRES(IBSORT,IBPRTYP,"ENTITY TYPE")=$S(IBPROV'["355.93,":1,$P($G(^IBA(355.93,+IBPROV,0)),U,2)=2:1,1:2)
"RTN","IBCEFP",221,0)
 S IBRES(IBSORT,IBPRTYP,"TAXONOMY")=$$TAXON^IBCEFP1(IBPROV,$P(IBD,U,15))
"RTN","IBCEFP",222,0)
 S IBRES(IBSORT,IBPRTYP,"COBID")=$$COBID^IBCEFP1(IB399,IBPRTYP,IBMRAND,IBD)
"RTN","IBCEFP",223,0)
 S IBRES(IBSORT,IBPRTYP)=IBPROV
"RTN","IBCEFP",224,0)
GETPRVQ ;
"RTN","IBCEFP",225,0)
 Q
"RTN","IBCEFP",226,0)
 ;
"RTN","IBCEFP",227,0)
PROVPTR(IBIEN399,IBFUNC,IBCP) ; Retrieve Provider Pointer from appropriate file
"RTN","IBCEFP",228,0)
 N IBN,RSLT
"RTN","IBCEFP",229,0)
 S IBCP=+$G(IBCP)
"RTN","IBCEFP",230,0)
 I 'IBCP D
"RTN","IBCEFP",231,0)
 . S IBN=$O(^DGCR(399,IBIEN399,"PRV","B",IBFUNC,0))
"RTN","IBCEFP",232,0)
 . I +IBN=0 S RSLT=0 Q
"RTN","IBCEFP",233,0)
 . S RSLT=$P($G(^DGCR(399,IBIEN399,"PRV",+IBN,0)),U,2)
"RTN","IBCEFP",234,0)
 I IBCP D
"RTN","IBCEFP",235,0)
 . S IBN=$O(^DGCR(399,IBIEN399,"CP",IBCP,"LNPRV","B",IBFUNC,0))
"RTN","IBCEFP",236,0)
 . I +IBN=0 S RSLT=0 Q
"RTN","IBCEFP",237,0)
 . S RSLT=$P($G(^DGCR(399,IBIEN399,"CP",IBCP,"LNPRV",+IBN,0)),U,2)
"RTN","IBCEFP",238,0)
 Q RSLT
"RTN","IBCEFP",239,0)
 ;
"RTN","IBCEFP",240,0)
 ;Input:
"RTN","IBCEFP",241,0)
 ;IBXIEN - Internal Entry Number for the current bill/claim
"RTN","IBCEFP",242,0)
 ;IBXSAVE - Array for returning the data
"RTN","IBCEFP",243,0)
 ;
"RTN","IBCEFP",244,0)
 ;Output:
"RTN","IBCEFP",245,0)
 ;IBXSAVE - Data Array
"RTN","IBCEFP",246,0)
AMB(IBXIEN,IBXSAVE) ; Gather Ambulance Data for AMB Record(s) - IB*2.0*447/TAZ
"RTN","IBCEFP",247,0)
 N NODE,CODE,CNT,IBXDATA
"RTN","IBCEFP",248,0)
 K IBXSAVE("AMB")
"RTN","IBCEFP",249,0)
 F NODE="U5","U6","U7" S IBXDATA=$G(^DGCR(399,IBXIEN,NODE)) I $TR(IBXDATA,U)'="" S IBXSAVE("AMB",NODE)=IBXDATA
"RTN","IBCEFP",250,0)
 S CODE="",CNT=0
"RTN","IBCEFP",251,0)
 F  S CODE=$O(^DGCR(399,IBXIEN,"U9","B",CODE)) Q:'CODE  D
"RTN","IBCEFP",252,0)
 . S IBXDATA=$P($G(^IBE(353.5,CODE,0)),U,1) I IBXDATA="" Q
"RTN","IBCEFP",253,0)
 . S CNT=CNT+1,IBXSAVE("AMB","U9",CNT)=IBXDATA
"RTN","IBCEFP",254,0)
 Q
"RTN","IBCEFP",255,0)
 ;
"RTN","IBCEFP",256,0)
SNDS2(IBXDATA,PIECE) ;Determine if a SUB2 record is necessary.
"RTN","IBCEFP",257,0)
 ; Input: IBXDATA
"RTN","IBCEFP",258,0)
 ;       May contain data from field 232 of file 399.
"RTN","IBCEFP",259,0)
 ; Output: IBXDATA
"RTN","IBCEFP",260,0)
 ;       Returns Output for piece 2 or 3 or 1 for any other piece (like 1.5)
"RTN","IBCEFP",261,0)
 ;Any time that ONE of the following criteria is met we should send a SUB2 record
"RTN","IBCEFP",262,0)
 ; 1. Incoming IBXDATA is not null SEND - Non-VA facility in field 232 of file 399
"RTN","IBCEFP",263,0)
 ; 2. If the service facility is a VA Institution in file 4 or a non-VA facility in file 355.93 SEND
"RTN","IBCEFP",264,0)
 ; 3. Not a switchback payer $$SENDSF^IBCEF79(IBXIEN)'=0 SEND
"RTN","IBCEFP",265,0)
 ;
"RTN","IBCEFP",266,0)
 I IBXDATA="" D
"RTN","IBCEFP",267,0)
 . N Z,Z1
"RTN","IBCEFP",268,0)
 . S Z=$P($$B^IBCEF79(IBXIEN),U,3)
"RTN","IBCEFP",269,0)
 . S Z1=$$SENDSF^IBCEF79(IBXIEN)
"RTN","IBCEFP",270,0)
 . S IBXDATA=$S(Z="":0,'Z1:0,1:1)
"RTN","IBCEFP",271,0)
 I 'IBXDATA S IBXDATA=""
"RTN","IBCEFP",272,0)
 I IBXDATA'="" S IBXDATA=$S(PIECE=2:77,PIECE=3:2,1:1)
"RTN","IBCEFP",273,0)
 Q IBXDATA
"RTN","IBCEMQC")
0^34^B30540187
"RTN","IBCEMQC",1,0)
IBCEMQC ;ALB/ESG - MRA EOB CRITERIA FOR AUTO-AUTHORIZE ; 11/1/06 10:34am
"RTN","IBCEMQC",2,0)
 ;;2.0;INTEGRATED BILLING;**155,323,302,350,359,447**;21-MAR-94;Build 80
"RTN","IBCEMQC",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IBCEMQC",4,0)
 ;
"RTN","IBCEMQC",5,0)
 Q   ; must be called at proper entry point
"RTN","IBCEMQC",6,0)
 ;
"RTN","IBCEMQC",7,0)
CRIT(IBEOB) ; Function to determine if EOB entry meets the criteria for
"RTN","IBCEMQC",8,0)
 ; auto-authorization and secondary claim submission
"RTN","IBCEMQC",9,0)
 ;
"RTN","IBCEMQC",10,0)
 ; Input:  IBEOB - internal entry number for an entry in 361.1
"RTN","IBCEMQC",11,0)
 ;
"RTN","IBCEMQC",12,0)
 ; Output:  This function returns a pieced string
"RTN","IBCEMQC",13,0)
 ;          [1] 0 or 1, EOB meets criteria
"RTN","IBCEMQC",14,0)
 ;          [2] error message if the first piece is 0
"RTN","IBCEMQC",15,0)
 ;
"RTN","IBCEMQC",16,0)
 NEW IBM,IBM3,IBM5,IBIFN,PCE,REMC,Z,OK,REASON,STOP,IBPTRESP
"RTN","IBCEMQC",17,0)
 ;
"RTN","IBCEMQC",18,0)
 S OK=0,REASON="Unknown",IBEOB=+$G(IBEOB)
"RTN","IBCEMQC",19,0)
 ;
"RTN","IBCEMQC",20,0)
 S IBM=$G(^IBM(361.1,IBEOB,0)) I IBM="" S REASON="No EOB Data Found" G CRITX
"RTN","IBCEMQC",21,0)
 I $D(^IBM(361.1,IBEOB,"ERR")) S REASON="Filing Errors" G CRITX
"RTN","IBCEMQC",22,0)
 I $P(IBM,U,13)'=1 S REASON="Claim Status is "_$$GET1^DIQ(361.1,IBEOB_",",.13)_".  It must be PROCESSED." G CRITX
"RTN","IBCEMQC",23,0)
 ;
"RTN","IBCEMQC",24,0)
 I $P(IBM,U,4)'=1 S REASON="The EOB Type is not Medicare MRA" G CRITX
"RTN","IBCEMQC",25,0)
 ;
"RTN","IBCEMQC",26,0)
 ; If any other MRA's on file for this bill failed the auto-generation
"RTN","IBCEMQC",27,0)
 ; check, then this MRA must also fail the check
"RTN","IBCEMQC",28,0)
 S IBIFN=+IBM,Z=0,STOP=0
"RTN","IBCEMQC",29,0)
 F  S Z=$O(^IBM(361.1,"B",IBIFN,Z)) Q:'Z  D  Q:STOP
"RTN","IBCEMQC",30,0)
 . I Z=IBEOB Q             ; check different EOB records if they exist
"RTN","IBCEMQC",31,0)
 . I $P($G(^IBM(361.1,Z,0)),U,4)'=1 Q     ; must be an MRA
"RTN","IBCEMQC",32,0)
 . I $P($G(^IBM(361.1,Z,30)),U,1)="" Q    ; no problems recorded
"RTN","IBCEMQC",33,0)
 . S REASON="Another MRA for this bill (ien="_Z_") failed the auto-generation criteria check."
"RTN","IBCEMQC",34,0)
 . S STOP=1
"RTN","IBCEMQC",35,0)
 . Q
"RTN","IBCEMQC",36,0)
 I STOP G CRITX
"RTN","IBCEMQC",37,0)
 ;
"RTN","IBCEMQC",38,0)
 ; If this EOB is a split EOB, then don't allow it
"RTN","IBCEMQC",39,0)
 I $$SPLIT^IBCEMU1(IBEOB) S REASON="Claim level remark code MA15 received.  Multiple MRA's" G CRITX
"RTN","IBCEMQC",40,0)
 ;
"RTN","IBCEMQC",41,0)
 ; Call the function that checks the claim level and/or line level
"RTN","IBCEMQC",42,0)
 ; adjustments for this EOB
"RTN","IBCEMQC",43,0)
 I '$$CAS(IBEOB,"B",.REASON) G CRITX      ; "B" for both
"RTN","IBCEMQC",44,0)
 ;
"RTN","IBCEMQC",45,0)
 ; Make sure the patient responsibility amount for this MRA is greater than $0
"RTN","IBCEMQC",46,0)
 S IBPTRESP=$P($G(^IBM(361.1,IBEOB,1)),U,2)      ; Pt Resp Amt 1.02 field
"RTN","IBCEMQC",47,0)
 I $$FT^IBCEF(IBIFN)=3 S IBPTRESP=$$PTRESPI^IBCECOB1(IBEOB)
"RTN","IBCEMQC",48,0)
 ; IB*2.0*447 PR for supplemental plans can be different
"RTN","IBCEMQC",49,0)
 S:$$MSEDT^IBCEMU4(IBIFN)'="" IBPTRESP=$$MSPRE^IBCEMU4(IBIFN)
"RTN","IBCEMQC",50,0)
 I IBPTRESP'>0 S REASON="Patient responsibility dollar amount is less than or equal to $0" G CRITX
"RTN","IBCEMQC",51,0)
 ;
"RTN","IBCEMQC",52,0)
 ; Check the parameter values last of all
"RTN","IBCEMQC",53,0)
 I '$P($G(^IBE(350.9,1,8)),U,11) S REASON="Automatic MRA Processing parameter is turned off.  File 350.9, Field 8.11." G CRITX
"RTN","IBCEMQC",54,0)
 I '$P($G(^IBE(350.9,1,8)),U,12) S REASON="Allow MRA Processing parameter is turned off.  File 350.9, Field 8.12." G CRITX
"RTN","IBCEMQC",55,0)
 ;
"RTN","IBCEMQC",56,0)
 ; At this point, we're OK
"RTN","IBCEMQC",57,0)
 S OK=1,REASON=""
"RTN","IBCEMQC",58,0)
 ;
"RTN","IBCEMQC",59,0)
CRITX ;
"RTN","IBCEMQC",60,0)
 Q OK_U_REASON
"RTN","IBCEMQC",61,0)
 ;
"RTN","IBCEMQC",62,0)
 ;
"RTN","IBCEMQC",63,0)
CAS(IBEOB,ADJFLAG,REASON) ; This function determines if the EOB
"RTN","IBCEMQC",64,0)
 ; adjustment group codes and reason codes from file 361.1 (either
"RTN","IBCEMQC",65,0)
 ; claim level or line level or both) meet the criteria for auto-
"RTN","IBCEMQC",66,0)
 ; authorization and secondary claim submission.
"RTN","IBCEMQC",67,0)
 ;
"RTN","IBCEMQC",68,0)
 ; Input Parameters
"RTN","IBCEMQC",69,0)
 ;        IBEOB    - ien of entry in file 361.1
"RTN","IBCEMQC",70,0)
 ;      ADJFLAG    - adjustment flag
"RTN","IBCEMQC",71,0)
 ;                   "C" - look at claim level adjustments only
"RTN","IBCEMQC",72,0)
 ;                   "L" - look at line level adjustments only
"RTN","IBCEMQC",73,0)
 ;                   "B" - look at both claim and line level adjustments
"RTN","IBCEMQC",74,0)
 ; Output Parameter
"RTN","IBCEMQC",75,0)
 ;       REASON    - error message describing why it failed
"RTN","IBCEMQC",76,0)
 ;
"RTN","IBCEMQC",77,0)
 ; Function Value is either 0 or 1, indicating if it passed the criteria
"RTN","IBCEMQC",78,0)
 ;
"RTN","IBCEMQC",79,0)
 NEW EOBADJ,OK,OKCOMBO,PATRESP,STOP,LNIEN
"RTN","IBCEMQC",80,0)
 ;
"RTN","IBCEMQC",81,0)
 S IBEOB=+$G(IBEOB)
"RTN","IBCEMQC",82,0)
 S ADJFLAG=$G(ADJFLAG,"B")     ; default is "B" if not passed in
"RTN","IBCEMQC",83,0)
 D BUILD           ; build the array of OK group/reason combinations
"RTN","IBCEMQC",84,0)
 S PATRESP=0       ; patient responsibility flag (default false)
"RTN","IBCEMQC",85,0)
 S STOP=0          ; Stop flag
"RTN","IBCEMQC",86,0)
 S OK=0            ; OK flag (function value)
"RTN","IBCEMQC",87,0)
 S REASON=""       ; error reason text
"RTN","IBCEMQC",88,0)
 ;
"RTN","IBCEMQC",89,0)
 ; claim level adjustments
"RTN","IBCEMQC",90,0)
 I $F(".C.B.","."_ADJFLAG_".") D
"RTN","IBCEMQC",91,0)
 . KILL EOBADJ
"RTN","IBCEMQC",92,0)
 . M EOBADJ=^IBM(361.1,IBEOB,10)
"RTN","IBCEMQC",93,0)
 . D ADJCHK
"RTN","IBCEMQC",94,0)
 . Q
"RTN","IBCEMQC",95,0)
 ;
"RTN","IBCEMQC",96,0)
 ; Get out if the claim level adjustments failed
"RTN","IBCEMQC",97,0)
 I STOP G CASX
"RTN","IBCEMQC",98,0)
 ;
"RTN","IBCEMQC",99,0)
 ; line level adjustments
"RTN","IBCEMQC",100,0)
 I $F(".L.B.","."_ADJFLAG_".") D
"RTN","IBCEMQC",101,0)
 . S LNIEN=0
"RTN","IBCEMQC",102,0)
 . F  S LNIEN=$O(^IBM(361.1,IBEOB,15,LNIEN)) Q:'LNIEN  D  Q:STOP
"RTN","IBCEMQC",103,0)
 .. KILL EOBADJ
"RTN","IBCEMQC",104,0)
 .. M EOBADJ=^IBM(361.1,IBEOB,15,LNIEN,1)
"RTN","IBCEMQC",105,0)
 .. D ADJCHK
"RTN","IBCEMQC",106,0)
 .. Q
"RTN","IBCEMQC",107,0)
 . Q
"RTN","IBCEMQC",108,0)
 ;
"RTN","IBCEMQC",109,0)
 ; Get out if the line level adjustments failed
"RTN","IBCEMQC",110,0)
 I STOP G CASX
"RTN","IBCEMQC",111,0)
 ;
"RTN","IBCEMQC",112,0)
 ; Get out if there was no patient responsibility adjustments found
"RTN","IBCEMQC",113,0)
 I 'PATRESP S REASON="No Patient Responsibility Adjustments found" G CASX
"RTN","IBCEMQC",114,0)
 ;
"RTN","IBCEMQC",115,0)
 ; At this point, we're OK
"RTN","IBCEMQC",116,0)
 S OK=1,REASON=""
"RTN","IBCEMQC",117,0)
CASX ;
"RTN","IBCEMQC",118,0)
 Q OK
"RTN","IBCEMQC",119,0)
 ;
"RTN","IBCEMQC",120,0)
 ;
"RTN","IBCEMQC",121,0)
ADJCHK ; This procedure checks the adjustments for this EOB.  The group codes
"RTN","IBCEMQC",122,0)
 ; and reason codes are in the EOBADJ array structures from file 361.1.
"RTN","IBCEMQC",123,0)
 ;
"RTN","IBCEMQC",124,0)
 ;   Variables STOP and REASON will be returned on an error
"RTN","IBCEMQC",125,0)
 ;   Variable PATRESP will be returned if a valid PR adjustment found
"RTN","IBCEMQC",126,0)
 ;
"RTN","IBCEMQC",127,0)
 NEW ADJIEN,GROUP,RSNIEN,RSNCODE
"RTN","IBCEMQC",128,0)
 S ADJIEN=0
"RTN","IBCEMQC",129,0)
 F  S ADJIEN=$O(EOBADJ(ADJIEN)) Q:'ADJIEN  D  Q:STOP
"RTN","IBCEMQC",130,0)
 . S GROUP=$P($G(EOBADJ(ADJIEN,0)),U,1)
"RTN","IBCEMQC",131,0)
 . I GROUP="LQ" Q      ; line level remark code kludge: 42 rec [3]
"RTN","IBCEMQC",132,0)
 . I GROUP="" S GROUP="<Undefined>"
"RTN","IBCEMQC",133,0)
 . I '$D(OKCOMBO(GROUP)) S STOP=1,REASON="Unacceptable Claim Adjustment Group Code: "_GROUP Q
"RTN","IBCEMQC",134,0)
 . S RSNIEN=0
"RTN","IBCEMQC",135,0)
 . F  S RSNIEN=$O(EOBADJ(ADJIEN,1,RSNIEN)) Q:'RSNIEN  D  Q:STOP
"RTN","IBCEMQC",136,0)
 .. S RSNCODE=$P($G(EOBADJ(ADJIEN,1,RSNIEN,0)),U,1)
"RTN","IBCEMQC",137,0)
 .. ;
"RTN","IBCEMQC",138,0)
 .. ; Ignore some special adjustment data that is filed with the MRA
"RTN","IBCEMQC",139,0)
 .. I GROUP="PR",RSNCODE="AAA" Q    ; Allowed Amount: 41 rec [3]
"RTN","IBCEMQC",140,0)
 .. I GROUP="OA",RSNCODE="AB3" Q    ; Covered Amount: 15 rec [3]
"RTN","IBCEMQC",141,0)
 .. ;
"RTN","IBCEMQC",142,0)
 .. I RSNCODE="" S RSNCODE="<Undefined>"
"RTN","IBCEMQC",143,0)
 .. I '$D(OKCOMBO(GROUP,RSNCODE)) S STOP=1,REASON="Unacceptable Reason Code ("_RSNCODE_") for Claim Adjustment Group Code ("_GROUP_")" Q
"RTN","IBCEMQC",144,0)
 .. ;
"RTN","IBCEMQC",145,0)
 .. ; Set the flag if the group is PR
"RTN","IBCEMQC",146,0)
 .. I GROUP="PR" S PATRESP=1
"RTN","IBCEMQC",147,0)
 .. Q
"RTN","IBCEMQC",148,0)
 . Q
"RTN","IBCEMQC",149,0)
ADJCHKX ;
"RTN","IBCEMQC",150,0)
 Q
"RTN","IBCEMQC",151,0)
 ;
"RTN","IBCEMQC",152,0)
 ;
"RTN","IBCEMQC",153,0)
BUILD ; This procedure builds the OKCOMBO array which identifies which
"RTN","IBCEMQC",154,0)
 ; combinations of group codes and reason codes are acceptable
"RTN","IBCEMQC",155,0)
 ;
"RTN","IBCEMQC",156,0)
 NEW LN,LINE,GROUP,RSNLST,R,RSN
"RTN","IBCEMQC",157,0)
 KILL OKCOMBO
"RTN","IBCEMQC",158,0)
 F LN=1:1 D  Q:$P(LINE,";",4)=""&$D(OKCOMBO)
"RTN","IBCEMQC",159,0)
 . S LINE=$T(OKCOMBO+LN)
"RTN","IBCEMQC",160,0)
 . S GROUP=$P(LINE,";",3) Q:GROUP=""
"RTN","IBCEMQC",161,0)
 . S RSNLST=$P(LINE,";",4) Q:RSNLST=""
"RTN","IBCEMQC",162,0)
 . F R=1:1:$L(RSNLST,",") D
"RTN","IBCEMQC",163,0)
 .. S RSN=$P(RSNLST,",",R) Q:RSN=""
"RTN","IBCEMQC",164,0)
 .. S OKCOMBO(GROUP,RSN)=""
"RTN","IBCEMQC",165,0)
 .. Q
"RTN","IBCEMQC",166,0)
 . Q
"RTN","IBCEMQC",167,0)
BUILDX ;
"RTN","IBCEMQC",168,0)
 Q
"RTN","IBCEMQC",169,0)
 ;
"RTN","IBCEMQC",170,0)
 ;
"RTN","IBCEMQC",171,0)
OKCOMBO ; This section lists OK combinations of adjustment category group codes
"RTN","IBCEMQC",172,0)
 ; and associated reason codes.
"RTN","IBCEMQC",173,0)
 ; The format is as follows - semi-colon delimiter
"RTN","IBCEMQC",174,0)
 ;     [3] Adjustment category (group code)
"RTN","IBCEMQC",175,0)
 ;     [4] List of acceptable reason codes - comma delimiter
"RTN","IBCEMQC",176,0)
 ;
"RTN","IBCEMQC",177,0)
 ; PR-AAA is created by VistA for the Allowed Amount
"RTN","IBCEMQC",178,0)
 ; OA-AB3 is created by VistA for the Covered Amount
"RTN","IBCEMQC",179,0)
 ; LQ-zzz is created by VistA for the Line Level remark
"RTN","IBCEMQC",180,0)
 ;
"RTN","IBCEMQC",181,0)
 ;;CO;A2,B6,42,45,172,94,194
"RTN","IBCEMQC",182,0)
 ;;PR;1,2,66,122,AAA
"RTN","IBCEMQC",183,0)
 ;;OA;AB3
"RTN","IBCEMQC",184,0)
 ;
"RTN","IBCEMSR")
0^33^B53975881
"RTN","IBCEMSR",1,0)
IBCEMSR ;WOIFO/AAT - MRA STATISTICS REPORT ;09/03/04
"RTN","IBCEMSR",2,0)
 ;;2.0;INTEGRATED BILLING;**155,288,294,349,447**;21-MAR-94;Build 80
"RTN","IBCEMSR",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCEMSR",4,0)
 ;
"RTN","IBCEMSR",5,0)
EN ;
"RTN","IBCEMSR",6,0)
 N IBQ,IBDIV,IBBDT,IBEDT,IBSUM,IBSCR
"RTN","IBCEMSR",7,0)
 W !!,"Report requires 132 Columns"
"RTN","IBCEMSR",8,0)
 S IBQ=0 ; quit flag
"RTN","IBCEMSR",9,0)
 ; Prompts to the user:
"RTN","IBCEMSR",10,0)
 D DIV Q:IBQ  ; Division(s)
"RTN","IBCEMSR",11,0)
 D SUM Q:IBQ  ; Summary only?
"RTN","IBCEMSR",12,0)
 W !!,"Normal processing time for a MRA is 10-12 days.  If you select a date range of"
"RTN","IBCEMSR",13,0)
 W !,"less than 2 weeks, do not expect to have received many MRAs."
"RTN","IBCEMSR",14,0)
 D DTR Q:IBQ  ; From-To date range
"RTN","IBCEMSR",15,0)
 D DEVICE Q:IBQ
"RTN","IBCEMSR",16,0)
 D RUN
"RTN","IBCEMSR",17,0)
 Q
"RTN","IBCEMSR",18,0)
 ;
"RTN","IBCEMSR",19,0)
DIV N DIC,DIR,DIRUT,Y
"RTN","IBCEMSR",20,0)
 W ! S DIR("B")="ALL",DIR("A")="Run this report for All divisions or Selected Divisions: "
"RTN","IBCEMSR",21,0)
 S DIR(0)="SA^ALL:All divisions;S:Selected divisions" D ^DIR
"RTN","IBCEMSR",22,0)
 I $D(DIRUT) S IBQ=1 Q
"RTN","IBCEMSR",23,0)
 S IBDIV=Y Q:Y="ALL"
"RTN","IBCEMSR",24,0)
 ; Collect divisions
"RTN","IBCEMSR",25,0)
 F  D  Q:Y'>0
"RTN","IBCEMSR",26,0)
 . W ! S DIC("A")="Division: ",DIC=40.8,DIC(0)="AEQM" D ^DIC
"RTN","IBCEMSR",27,0)
 . I $D(DIRUT) S IBQ=1 Q
"RTN","IBCEMSR",28,0)
 . I Y'>0 Q
"RTN","IBCEMSR",29,0)
 . S IBDIV(+Y)=""
"RTN","IBCEMSR",30,0)
 I $O(IBDIV(""))=""  S IBQ=1 Q  ; None selected
"RTN","IBCEMSR",31,0)
 Q
"RTN","IBCEMSR",32,0)
 ;
"RTN","IBCEMSR",33,0)
DTR ;date range
"RTN","IBCEMSR",34,0)
 N %DT,Y
"RTN","IBCEMSR",35,0)
 S (IBBDT,IBEDT)=DT
"RTN","IBCEMSR",36,0)
 S %DT="AEX"
"RTN","IBCEMSR",37,0)
 S %DT("A")="Start with MRA Request Transmission Date: " ; No default,%DT("B")="TODAY"
"RTN","IBCEMSR",38,0)
 W ! D ^%DT K %DT
"RTN","IBCEMSR",39,0)
 I Y<0 S IBQ=1 Q
"RTN","IBCEMSR",40,0)
 S IBBDT=+Y
"RTN","IBCEMSR",41,0)
 S %DT="AEX"
"RTN","IBCEMSR",42,0)
 S %DT("A")="Go to MRA Request Transmission Date: ",%DT("B")="TODAY"
"RTN","IBCEMSR",43,0)
 D ^%DT K %DT
"RTN","IBCEMSR",44,0)
 I Y<0 S IBQ=1 Q
"RTN","IBCEMSR",45,0)
 S IBEDT=+Y
"RTN","IBCEMSR",46,0)
 Q
"RTN","IBCEMSR",47,0)
 ;
"RTN","IBCEMSR",48,0)
SUM N DIR,DIRUT,Y
"RTN","IBCEMSR",49,0)
 W ! S DIR("B")="YES",DIR("A")="Do you want to print a summary only? "
"RTN","IBCEMSR",50,0)
 S DIR(0)="YA" D ^DIR
"RTN","IBCEMSR",51,0)
 I $D(DIRUT) S IBQ=1 Q
"RTN","IBCEMSR",52,0)
 S IBSUM=+Y
"RTN","IBCEMSR",53,0)
 Q
"RTN","IBCEMSR",54,0)
 ;
"RTN","IBCEMSR",55,0)
DEVICE N %ZIS,IOP,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP
"RTN","IBCEMSR",56,0)
 K IO("Q")
"RTN","IBCEMSR",57,0)
 S %ZIS="QM"
"RTN","IBCEMSR",58,0)
 W ! D ^%ZIS
"RTN","IBCEMSR",59,0)
 I POP S IBQ=1 Q
"RTN","IBCEMSR",60,0)
 S IBSCR=$S($E($G(IOST),1,2)="C-":1,1:0)
"RTN","IBCEMSR",61,0)
 ;
"RTN","IBCEMSR",62,0)
 I $D(IO("Q")) D  S IBQ=1
"RTN","IBCEMSR",63,0)
 . S ZTRTN="RUN^IBCEMSR"
"RTN","IBCEMSR",64,0)
 . S ZTIO=ION
"RTN","IBCEMSR",65,0)
 . S ZTSAVE("IB*")=""
"RTN","IBCEMSR",66,0)
 . S ZTDESC="IB MRA STATISTICS REPORT"
"RTN","IBCEMSR",67,0)
 . D ^%ZTLOAD
"RTN","IBCEMSR",68,0)
 . W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
"RTN","IBCEMSR",69,0)
 . D HOME^%ZIS
"RTN","IBCEMSR",70,0)
 U IO
"RTN","IBCEMSR",71,0)
 Q
"RTN","IBCEMSR",72,0)
 ;
"RTN","IBCEMSR",73,0)
 ;
"RTN","IBCEMSR",74,0)
RUN N REF
"RTN","IBCEMSR",75,0)
 S REF=$NA(^TMP($J,"IBCEMSR"))
"RTN","IBCEMSR",76,0)
 K @REF
"RTN","IBCEMSR",77,0)
 D COLLECT  ; Collect the data in ^TMP
"RTN","IBCEMSR",78,0)
 U IO
"RTN","IBCEMSR",79,0)
 D REPORT^IBCEMSR1
"RTN","IBCEMSR",80,0)
 I 'IBSCR W !,@IOF
"RTN","IBCEMSR",81,0)
 D ^%ZISC
"RTN","IBCEMSR",82,0)
 K @REF
"RTN","IBCEMSR",83,0)
 Q
"RTN","IBCEMSR",84,0)
 ;
"RTN","IBCEMSR",85,0)
COLLECT ; Collect Information
"RTN","IBCEMSR",86,0)
 ; Input: IBDIV, IBBDT,IBEDT
"RTN","IBCEMSR",87,0)
 N IBDT,IBBAT,IBTRAN,IBZ,MRAUSR,NUMDIV,IBDV,ALLDIV
"RTN","IBCEMSR",88,0)
 S IBDV=0 F NUMDIV=0:1 S IBDV=$O(IBDIV(IBDV)) Q:'IBDV
"RTN","IBCEMSR",89,0)
 S ALLDIV=" "
"RTN","IBCEMSR",90,0)
 I IBDIV="ALL" S ALLDIV="  *** ALL DIVISIONS ***"
"RTN","IBCEMSR",91,0)
 I NUMDIV>1 S ALLDIV="  *** ALL SELECTED DIVISIONS ***"
"RTN","IBCEMSR",92,0)
 ;
"RTN","IBCEMSR",93,0)
 S MRAUSR=$$MRAUSR^IBCEMU1() ;Auto-authorizer
"RTN","IBCEMSR",94,0)
 S IBDT=IBBDT-.000001
"RTN","IBCEMSR",95,0)
 F  S IBDT=$O(^IBA(364.1,"ALT",IBDT)) Q:'IBDT  Q:IBDT\1>IBEDT  D
"RTN","IBCEMSR",96,0)
 . S IBBAT=0 F  S IBBAT=$O(^IBA(364.1,"ALT",IBDT,IBBAT)) Q:'IBBAT  D
"RTN","IBCEMSR",97,0)
 .. S IBTRAN=0 F  S IBTRAN=$O(^IBA(364,"C",IBBAT,IBTRAN)) Q:'IBTRAN  D
"RTN","IBCEMSR",98,0)
 ... S IBZ=$G(^IBA(364,IBTRAN,0)) Q:IBZ=""
"RTN","IBCEMSR",99,0)
 ... N IBIFN,IBSTAT,IBSEQ,IBBILZ,IBBILST,IBFORM,IBCLERK,IBDV,IBDVN,REFX,REFS,REFT,REFTX,MRACNT,IBREJECT
"RTN","IBCEMSR",100,0)
 ... S IBIFN=+IBZ
"RTN","IBCEMSR",101,0)
 ... I '$P($G(^DGCR(399,IBIFN,"S")),U,7) Q  ; no MRA request
"RTN","IBCEMSR",102,0)
 ... S IBSTAT=$P(IBZ,U,3)
"RTN","IBCEMSR",103,0)
 ... S IBSEQ=$P(IBZ,U,8) Q:"T"[IBSEQ
"RTN","IBCEMSR",104,0)
 ... I '$$WNRBILL^IBEFUNC(IBIFN,IBSEQ) Q   ; payer sequence must be Medicare for this transmission
"RTN","IBCEMSR",105,0)
 ... S IBBILZ=$G(^DGCR(399,IBIFN,0))
"RTN","IBCEMSR",106,0)
 ... S IBBILST=$P(IBBILZ,U,13)
"RTN","IBCEMSR",107,0)
 ... S IBFORM=+$P(IBBILZ,U,19)
"RTN","IBCEMSR",108,0)
 ... I IBFORM'=2,IBFORM'=3 Q  ; not 1500 or UB
"RTN","IBCEMSR",109,0)
 ... S IBCLERK=+$P($G(^DGCR(399,IBIFN,"S")),U,8) ; Who requested MRA?
"RTN","IBCEMSR",110,0)
 ... S IBCLERK=$P($G(^VA(200,IBCLERK,0)),U)
"RTN","IBCEMSR",111,0)
 ... S:IBCLERK="" IBCLERK="UNKNOWN"
"RTN","IBCEMSR",112,0)
 ... S IBDV=+$P(IBBILZ,U,22) ; Default division
"RTN","IBCEMSR",113,0)
 ... S IBDVN=$P($G(^DG(40.8,IBDV,0)),U) ; Div name
"RTN","IBCEMSR",114,0)
 ... S:IBDVN="" IBDVN="UNKNOWN"
"RTN","IBCEMSR",115,0)
 ... I IBDIV'="ALL",'$D(IBDIV(IBDV)) Q  ;Division filter
"RTN","IBCEMSR",116,0)
 ... I 'IBSUM S REFX=$NA(@REF@(IBDVN,IBCLERK,IBFORM)) I NUMDIV'=1 S REFTX=$NA(@REF@(ALLDIV,IBCLERK,IBFORM))  ; all divisions detail
"RTN","IBCEMSR",117,0)
 ... S REFS=$NA(@REF@(IBDVN,0,IBFORM)) ; Summary by division
"RTN","IBCEMSR",118,0)
 ... I NUMDIV'=1 S REFT=$NA(@REF@(ALLDIV,0,IBFORM))  ; all divisions
"RTN","IBCEMSR",119,0)
 ... D TXSTS^IBCEMU2(IBIFN,IBTRAN,.IBREJECT) ; rejected?
"RTN","IBCEMSR",120,0)
 ... S MRACNT=$$MRACNT^IBCEMU1(IBIFN) ; how many MRAs?
"RTN","IBCEMSR",121,0)
 ... D INC("ALL") ; total no of requests
"RTN","IBCEMSR",122,0)
 ... I IBSTAT="C" D INC("ALLC") ;cancelled
"RTN","IBCEMSR",123,0)
 ... I IBSTAT="R" D INC("ALLR") ;resubmitted
"RTN","IBCEMSR",124,0)
 ... I '$D(@REFS@("TOT",IBIFN)) S ^(IBIFN)="" D INC("TOT") ;unique requests
"RTN","IBCEMSR",125,0)
 ... ;no response?
"RTN","IBCEMSR",126,0)
 ... I 'IBREJECT,'MRACNT,'$D(@REFS@("NON",IBIFN)) S ^(IBIFN)="" D INC("NON")
"RTN","IBCEMSR",127,0)
 ... ;final reject?
"RTN","IBCEMSR",128,0)
 ... I 'MRACNT,IBREJECT,'$D(@REFS@("REJF",IBIFN)),IBTRAN=$$LAST364^IBCEF4(IBIFN) D
"RTN","IBCEMSR",129,0)
 .... S @REFS@("REJF",IBIFN)="" D INC("REJF")
"RTN","IBCEMSR",130,0)
 .... ; MRA?
"RTN","IBCEMSR",131,0)
 ... I MRACNT,'$D(@REFS@("MRA",IBIFN)) S ^(IBIFN)="" D
"RTN","IBCEMSR",132,0)
 .... D INC("MRA")
"RTN","IBCEMSR",133,0)
 .... I $$DENIED(IBIFN) D INC("MRAD")
"RTN","IBCEMSR",134,0)
 ... ;any secondary claims?
"RTN","IBCEMSR",135,0)
 ... D SECOND
"RTN","IBCEMSR",136,0)
 Q
"RTN","IBCEMSR",137,0)
 ;
"RTN","IBCEMSR",138,0)
INC(NODE,VALUE) ;Increase the respective value in ^TMP
"RTN","IBCEMSR",139,0)
 I 'IBSUM D
"RTN","IBCEMSR",140,0)
 . S @REFX@(NODE)=$G(@REFX@(NODE))+$G(VALUE,1)
"RTN","IBCEMSR",141,0)
 . I $D(REFTX) S @REFTX@(NODE)=$G(@REFTX@(NODE))+$G(VALUE,1)
"RTN","IBCEMSR",142,0)
 . Q
"RTN","IBCEMSR",143,0)
 S @REFS@(NODE)=$G(@REFS@(NODE))+$G(VALUE,1)
"RTN","IBCEMSR",144,0)
 I $D(REFT) S @REFT@(NODE)=$G(@REFT@(NODE))+$G(VALUE,1)
"RTN","IBCEMSR",145,0)
 Q
"RTN","IBCEMSR",146,0)
 ;
"RTN","IBCEMSR",147,0)
DENIED(IBIFN) ;MRA requests denied?
"RTN","IBCEMSR",148,0)
 ; 361.1 for this bill#
"RTN","IBCEMSR",149,0)
 ; if at least one request is 'processed' - MRA is NOT DENIED
"RTN","IBCEMSR",150,0)
 N IBDEN,IEN,IBZ
"RTN","IBCEMSR",151,0)
 S IBDEN=1
"RTN","IBCEMSR",152,0)
 S IEN=0 F  S IEN=$O(^IBM(361.1,"B",+$G(IBIFN),IEN)) Q:'IEN  D  Q:'IBDEN
"RTN","IBCEMSR",153,0)
 . S IBZ=$G(^IBM(361.1,IEN,0))
"RTN","IBCEMSR",154,0)
 . I $P(IBZ,U,4)'=1 Q  ; only MEDICARE
"RTN","IBCEMSR",155,0)
 . I $P(IBZ,U,13)=1 S IBDEN=0
"RTN","IBCEMSR",156,0)
 Q IBDEN
"RTN","IBCEMSR",157,0)
 ;
"RTN","IBCEMSR",158,0)
SECOND ;Secondary claims
"RTN","IBCEMSR",159,0)
 N IBAUT,IBTX,IBCBPS,IBNEXT,IBBILS,IBTOT,IBUNR,IB2ND,IBNODE,IBGRPN,IBTYPLN,IBPRP
"RTN","IBCEMSR",160,0)
 I $D(@REFS@("SEC",IBIFN)) Q  ; Already included
"RTN","IBCEMSR",161,0)
 S IBCBPS=$P(IBBILZ,U,21) ; current bill sequence
"RTN","IBCEMSR",162,0)
 S IBNEXT=$S(IBSEQ="S":"T",1:"S") ;Next (after MRA) sequence
"RTN","IBCEMSR",163,0)
 I IBCBPS'=IBNEXT Q
"RTN","IBCEMSR",164,0)
 ; Number of unique sec claims
"RTN","IBCEMSR",165,0)
 S @REFS@("SEC",IBIFN)=""
"RTN","IBCEMSR",166,0)
 D INC("SEC")
"RTN","IBCEMSR",167,0)
 S IBBILS=$G(^DGCR(399,IBIFN,"S")) Q:'$P(IBBILS,U,10)  ; Not even authorized
"RTN","IBCEMSR",168,0)
 ; Authorized but not yet printed?
"RTN","IBCEMSR",169,0)
 I $P(IBBILS,U,10),'$P(IBBILS,U,13) D  Q
"RTN","IBCEMSR",170,0)
 . I +$$TXMT^IBCEF4(IBIFN)'=1 D INC("AUT") ; Exclude transmittable
"RTN","IBCEMSR",171,0)
 ; Check the field 'AUTHORIZER'
"RTN","IBCEMSR",172,0)
 S IBAUT=($P(IBBILS,U,11)=MRAUSR) ; Auto-authorized?
"RTN","IBCEMSR",173,0)
 S IBTX=$$TRANSM(IBIFN,IBNEXT) ; Transmitted? (present in 364?)
"RTN","IBCEMSR",174,0)
 I IBAUT,IBTX S IBNODE="AT"   ; Auto-gen Tx
"RTN","IBCEMSR",175,0)
 I 'IBAUT,IBTX S IBNODE="MT"  ; Manually Tx
"RTN","IBCEMSR",176,0)
 I IBAUT,'IBTX S IBNODE="AP"  ; Auto-gen Prn
"RTN","IBCEMSR",177,0)
 I 'IBAUT,'IBTX S IBNODE="MP" ; Manually Prn
"RTN","IBCEMSR",178,0)
 ;
"RTN","IBCEMSR",179,0)
 ;Calculate amounts
"RTN","IBCEMSR",180,0)
 S IBTOT=+$G(^DGCR(399,IBIFN,"U1"))
"RTN","IBCEMSR",181,0)
 S IBUNR=$P($G(^PRCA(430,IBIFN,13)),U,2) ; Medicare Unreimbursable
"RTN","IBCEMSR",182,0)
 ; IB*2.0*447 calculate differently for claims w/Medicare supplemental, need plan type now and prior payments
"RTN","IBCEMSR",183,0)
 ;S IB2ND=$$PREOBTOT^IBCEU0(IBIFN)
"RTN","IBCEMSR",184,0)
 S IBGRPN=+$P($G(^DGCR(399,IBIFN,"I"_$S(IBCBPS="S":2,IBCBPS="T":3,1:1))),U,18),IBTYPLN=$P($G(^IBA(355.3,IBGRPN,0)),U,9)
"RTN","IBCEMSR",185,0)
 S IBPRP=$P($G(^DGCR(399,IBIFN,"U2")),U,4) S:IBCBPS="T" IBPRP=IBPRP+$P($G(^DGCR(399,IBIFN,"U2")),U,5)
"RTN","IBCEMSR",186,0)
 ; if current payer is primary, or prior payments are a negative amt., set prior payments to 0
"RTN","IBCEMSR",187,0)
 I IBCBPS="P"!(IBPRP<0) S IBPRP=0
"RTN","IBCEMSR",188,0)
 ; if plan type does NOT have any special calculations, just calculate the old way (PR only)
"RTN","IBCEMSR",189,0)
 S IB2ND=$S($$MSEDT^IBCEMU4(IBIFN,IBTYPLN)'="":IBTOT-IBPRP,1:$$PREOBTOT^IBCEU0(IBIFN))
"RTN","IBCEMSR",190,0)
 D INC(IBNODE)
"RTN","IBCEMSR",191,0)
 D INC(IBNODE_"1",IBTOT)
"RTN","IBCEMSR",192,0)
 D INC(IBNODE_"2",IBUNR)
"RTN","IBCEMSR",193,0)
 D INC(IBNODE_"3",IB2ND)
"RTN","IBCEMSR",194,0)
 Q
"RTN","IBCEMSR",195,0)
 ;
"RTN","IBCEMSR",196,0)
TRANSM(IBIFN,IBSEQ) ;was the claim ever transmitted?
"RTN","IBCEMSR",197,0)
 ; Does the claim present in 364?
"RTN","IBCEMSR",198,0)
 N RES,IBI
"RTN","IBCEMSR",199,0)
 S RES=0
"RTN","IBCEMSR",200,0)
 S IBI="" F  S IBI=$O(^IBA(364,"B",IBIFN,IBI),-1) Q:IBI=""  D  Q:RES
"RTN","IBCEMSR",201,0)
 . I $P($G(^IBA(364,IBI,0)),U,8)=IBSEQ S RES=1
"RTN","IBCEMSR",202,0)
 Q RES
"RTN","IBCEMSR",203,0)
 ;
"RTN","IBCEMSR2")
0^22^B83574265
"RTN","IBCEMSR2",1,0)
IBCEMSR2  ;BI/ALB - non-MRA PRODUCTIVITY REPORT ;02/14/11
"RTN","IBCEMSR2",2,0)
 ;;2.0;INTEGRATED BILLING;**447**;21-MAR-94;Build 80
"RTN","IBCEMSR2",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCEMSR2",4,0)
 ;
"RTN","IBCEMSR2",5,0)
 Q
"RTN","IBCEMSR2",6,0)
 ;
"RTN","IBCEMSR2",7,0)
EN  ; Main Routine Entry Point
"RTN","IBCEMSR2",8,0)
 N IBQ,IBDIV,IBBDT,IBEDT,IBSUM,IBSCR,IBPAGE,POP
"RTN","IBCEMSR2",9,0)
 S IBPAGE=0
"RTN","IBCEMSR2",10,0)
 N IBLTMPH        ; Report Header Information
"RTN","IBCEMSR2",11,0)
 N IBLTMP         ; Data Collection Array
"RTN","IBCEMSR2",12,0)
 W !!,"Report requires 132 Columns"
"RTN","IBCEMSR2",13,0)
 S IBQ=0          ; quit flag
"RTN","IBCEMSR2",14,0)
 ; Prompts to the user:
"RTN","IBCEMSR2",15,0)
 D DIV Q:IBQ      ; Division(s)
"RTN","IBCEMSR2",16,0)
 D SUM Q:IBQ      ; Summary or Full Report
"RTN","IBCEMSR2",17,0)
 D DTR Q:IBQ      ; From-To date range
"RTN","IBCEMSR2",18,0)
 D DEVICE Q:IBQ   ; Print to device
"RTN","IBCEMSR2",19,0)
 K ^TMP($J,"IBCEMSR2") ; Clear the temporary accumulator
"RTN","IBCEMSR2",20,0)
 D RUN Q:IBQ      ; Run Report
"RTN","IBCEMSR2",21,0)
 K ^TMP($J,"IBCEMSR2") ; Clear the temporary accumulator
"RTN","IBCEMSR2",22,0)
 Q
"RTN","IBCEMSR2",23,0)
 ;
"RTN","IBCEMSR2",24,0)
DIV  ; Collect Division(s)
"RTN","IBCEMSR2",25,0)
 N DIC,DIR,DIRUT,X,Y
"RTN","IBCEMSR2",26,0)
 W ! S DIR("B")="ALL",DIR("A")="Run this report for All divisions or Selected Divisions: "
"RTN","IBCEMSR2",27,0)
 S DIR(0)="SA^ALL:All divisions;S:Selected divisions" D ^DIR
"RTN","IBCEMSR2",28,0)
 I $D(DIRUT) S IBQ=1 Q
"RTN","IBCEMSR2",29,0)
 S IBDIV=Y Q:Y="ALL"
"RTN","IBCEMSR2",30,0)
 ; Collect divisions
"RTN","IBCEMSR2",31,0)
 F  D  Q:Y'>0
"RTN","IBCEMSR2",32,0)
 . W ! S DIC("A")="Division: ",DIC=40.8,DIC(0)="AEQM" D ^DIC
"RTN","IBCEMSR2",33,0)
 . I $D(DIRUT) S IBQ=1 Q
"RTN","IBCEMSR2",34,0)
 . I Y'>0 Q
"RTN","IBCEMSR2",35,0)
 . S IBDIV(+Y)=""
"RTN","IBCEMSR2",36,0)
 I $O(IBDIV(""))=""  S IBQ=1 Q  ; None selected
"RTN","IBCEMSR2",37,0)
 Q
"RTN","IBCEMSR2",38,0)
 ;
"RTN","IBCEMSR2",39,0)
DTR  ; Get Date Range
"RTN","IBCEMSR2",40,0)
 N %DT,Y,X,IBIDT              ; Local subroutine variables.
"RTN","IBCEMSR2",41,0)
 S IBBDT=$$FMADD^XLFDT(DT,-7) ; Earliest date set in stack for global routine use.
"RTN","IBCEMSR2",42,0)
 S IBEDT=DT                   ; Latest date set in stack for global routine use.
"RTN","IBCEMSR2",43,0)
 ;
"RTN","IBCEMSR2",44,0)
 ; Don't allow the user to go back earlier than patch install date.
"RTN","IBCEMSR2",45,0)
 S X=$$INSTALDT^XPDUTL("IB*2.0*447",.IBIDT)
"RTN","IBCEMSR2",46,0)
 I X=0 W !!,"This report can't be run before installing patch IB*2.0*447.",! S IBQ=1 Q
"RTN","IBCEMSR2",47,0)
 S IBIDT=$P($S(X:$O(IBIDT("")),1:DT),".",1)
"RTN","IBCEMSR2",48,0)
 I IBBDT<IBIDT S IBBDT=IBIDT
"RTN","IBCEMSR2",49,0)
DTR1  ; Return for invalid "Earliest EOB Receipt Date"
"RTN","IBCEMSR2",50,0)
 S %DT="AEX"
"RTN","IBCEMSR2",51,0)
 S %DT("A")="Earliest EOB Receipt Date:  "
"RTN","IBCEMSR2",52,0)
 S %DT("B")=$$FMTE^XLFDT(IBBDT)
"RTN","IBCEMSR2",53,0)
 W ! D ^%DT K %DT
"RTN","IBCEMSR2",54,0)
 I Y<0 S IBQ=1 Q
"RTN","IBCEMSR2",55,0)
 I +Y<IBIDT D  G DTR1
"RTN","IBCEMSR2",56,0)
 . W !!,"The Earliest EOB Receipt Date can't be before ",$$FMTE^XLFDT(IBIDT),!
"RTN","IBCEMSR2",57,0)
 I +Y>DT D  G DTR1
"RTN","IBCEMSR2",58,0)
 . W !!,"Future Dates are not allowed.",!
"RTN","IBCEMSR2",59,0)
 S IBBDT=+Y
"RTN","IBCEMSR2",60,0)
DTR2  ; Return for invalid "Latest EOB Receipt Date"
"RTN","IBCEMSR2",61,0)
 S %DT="AEX"
"RTN","IBCEMSR2",62,0)
 S %DT("A")="Latest EOB Receipt Date: "
"RTN","IBCEMSR2",63,0)
 S %DT("B")=$$FMTE^XLFDT(DT)
"RTN","IBCEMSR2",64,0)
 D ^%DT K %DT
"RTN","IBCEMSR2",65,0)
 I Y<0 S IBQ=1 Q
"RTN","IBCEMSR2",66,0)
 S IBEDT=+Y
"RTN","IBCEMSR2",67,0)
 I IBEDT<IBBDT D  G DTR2
"RTN","IBCEMSR2",68,0)
 . W !!,"The Latest EOB Receipt Date can't be before ",$$FMTE^XLFDT(IBBDT),!
"RTN","IBCEMSR2",69,0)
 I +Y>DT D  G DTR2
"RTN","IBCEMSR2",70,0)
 . W !!,"Future Dates are not allowed.",!
"RTN","IBCEMSR2",71,0)
 W !!
"RTN","IBCEMSR2",72,0)
 Q
"RTN","IBCEMSR2",73,0)
 ;
"RTN","IBCEMSR2",74,0)
SUM  ; Ask if printing a Summary or Full report.
"RTN","IBCEMSR2",75,0)
 N DIR,DIRUT,X,Y
"RTN","IBCEMSR2",76,0)
 W ! S DIR("B")="Summary",DIR("A")="Print a Summary or a Full report? "
"RTN","IBCEMSR2",77,0)
 S DIR(0)="SA^S:Summary;F:Full" D ^DIR
"RTN","IBCEMSR2",78,0)
 I $D(DIRUT) S IBQ=1 Q
"RTN","IBCEMSR2",79,0)
 S IBSUM=Y
"RTN","IBCEMSR2",80,0)
 Q
"RTN","IBCEMSR2",81,0)
 ;
"RTN","IBCEMSR2",82,0)
DEVICE  ; Request Device Information
"RTN","IBCEMSR2",83,0)
 N %ZIS,IOP,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP
"RTN","IBCEMSR2",84,0)
 K IO("Q")
"RTN","IBCEMSR2",85,0)
 S %ZIS="QM"
"RTN","IBCEMSR2",86,0)
 W ! D ^%ZIS
"RTN","IBCEMSR2",87,0)
 I POP S IBQ=1 Q
"RTN","IBCEMSR2",88,0)
 S IBSCR=$S($E($G(IOST),1,2)="C-":1,1:0)
"RTN","IBCEMSR2",89,0)
 I $D(IO("Q")) D  S IBQ=1
"RTN","IBCEMSR2",90,0)
 . S ZTRTN="RUN^IBCEMSR2"
"RTN","IBCEMSR2",91,0)
 . S ZTIO=ION
"RTN","IBCEMSR2",92,0)
 . S ZTSAVE("IB*")=""
"RTN","IBCEMSR2",93,0)
 . S ZTDESC="IB NON-MRA PRODUCTIVITY REPORT"
"RTN","IBCEMSR2",94,0)
 . D ^%ZTLOAD
"RTN","IBCEMSR2",95,0)
 . W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
"RTN","IBCEMSR2",96,0)
 . D HOME^%ZIS
"RTN","IBCEMSR2",97,0)
 U IO
"RTN","IBCEMSR2",98,0)
 Q
"RTN","IBCEMSR2",99,0)
 ;
"RTN","IBCEMSR2",100,0)
RUN  ; Run Report
"RTN","IBCEMSR2",101,0)
 U IO
"RTN","IBCEMSR2",102,0)
 D COLLECT        ; Collect the data in Local Array "IBLTMP"
"RTN","IBCEMSR2",103,0)
 D REPORT
"RTN","IBCEMSR2",104,0)
 I 'IBSCR W !,@IOF
"RTN","IBCEMSR2",105,0)
 D ^%ZISC
"RTN","IBCEMSR2",106,0)
 Q
"RTN","IBCEMSR2",107,0)
 ;
"RTN","IBCEMSR2",108,0)
COLLECT  ; Collect Information, Scan through the EOB Cross Reference
"RTN","IBCEMSR2",109,0)
 ; Input: IBDIV, IBBDT, IBEDT
"RTN","IBCEMSR2",110,0)
 N IBDT,IBEOB,IBZ,MRAUSR,DIVCNT,IBX
"RTN","IBCEMSR2",111,0)
 S IBX=0 F DIVCNT=0:1 S IBX=$O(IBDIV(IBX)) Q:'IBX  ; Count the requested Divisions
"RTN","IBCEMSR2",112,0)
 S IBLTMPH("ALLDIV")="DIVISION TOTALS"
"RTN","IBCEMSR2",113,0)
 I IBDIV="ALL" S IBLTMPH("ALLDIV")="ALL DIVISION TOTALS"
"RTN","IBCEMSR2",114,0)
 I DIVCNT>1 S IBLTMPH("ALLDIV")="ALL SELECTED DIVISION TOTALS"
"RTN","IBCEMSR2",115,0)
 ;
"RTN","IBCEMSR2",116,0)
 S IBDT=IBBDT-.000001
"RTN","IBCEMSR2",117,0)
 ; Use new Entry date x-ref: EOBTYP=0 ^IBM(361.1,"AEDT",EOBTYP,ENTRY DT,IEN)=""
"RTN","IBCEMSR2",118,0)
 F  S IBDT=$O(^IBM(361.1,"AEDT",0,IBDT)) Q:'IBDT  D
"RTN","IBCEMSR2",119,0)
 . I IBDT<IBBDT Q
"RTN","IBCEMSR2",120,0)
 . I (IBDT\1)>IBEDT Q
"RTN","IBCEMSR2",121,0)
 . S IBEOB=0 F  S IBEOB=$O(^IBM(361.1,"AEDT",0,IBDT,IBEOB)) Q:'IBEOB  D
"RTN","IBCEMSR2",122,0)
 .. D COLLECT1
"RTN","IBCEMSR2",123,0)
 Q
"RTN","IBCEMSR2",124,0)
 ;
"RTN","IBCEMSR2",125,0)
COLLECT1  ; Collect Information, Get Data for specific EOB and BILL/CLAIM
"RTN","IBCEMSR2",126,0)
 N IBIFN,IBFLDS,IBX
"RTN","IBCEMSR2",127,0)
 N IBOE                       ; Dict 361.1 EXPLANATION OF BENEFITS field data.
"RTN","IBCEMSR2",128,0)
 N IBOB                       ; Dict 399 BILL/CLAIMS field data current claim.
"RTN","IBCEMSR2",129,0)
 N IBOBS                      ; Dict 399 BILL/CLAIMS field data Secondary Claim.
"RTN","IBCEMSR2",130,0)
 N IBOBT                      ; Dict 399 BILL/CLAIMS field data Tertiary Claim.
"RTN","IBCEMSR2",131,0)
 ; Initial Testing
"RTN","IBCEMSR2",132,0)
 ; Get all the EOB Data
"RTN","IBCEMSR2",133,0)
 ; FIELD  .01 POINTER TO BILL/CLAIMS FILE (#399)
"RTN","IBCEMSR2",134,0)
 ; FIELD  .13 CLAIM STATUS, 1-PROCESSED, 2-DENIED, 3-PENDED, 4-REVERSAL, 5-OTHER
"RTN","IBCEMSR2",135,0)
 ; FIELD  .15 INSURANCE SEQUENCE, 1-PRIMARY, 2-SECONDARY, 3-TERTIARY
"RTN","IBCEMSR2",136,0)
 ; FIELD  .16 REVIEW STATUS, 0-NOT REVIEWED, 1-REVIEW IN PROCESS, 1.5-COB PROCESSED, NOT AUTHORIZED,
"RTN","IBCEMSR2",137,0)
 ;                           2-ACCEPTED-INTERIM EOB, 3-ACCEPTED-COMPLETE EOB, 4-REJECTED, 9-CLAIM CANCELLED
"RTN","IBCEMSR2",138,0)
 ; FIELD 2.04 TOTAL SUBMITTED CHARGES
"RTN","IBCEMSR2",139,0)
 D IBOBJ(361.1,IBEOB,".01;.13;.15;.16;2.04",.IBOE)  ; Load EOB Data.
"RTN","IBCEMSR2",140,0)
 ;
"RTN","IBCEMSR2",141,0)
 ; Quit if an associated bill number doesn't exist
"RTN","IBCEMSR2",142,0)
 S IBIFN=IBOE(.01) I IBIFN="" Q
"RTN","IBCEMSR2",143,0)
 ;
"RTN","IBCEMSR2",144,0)
 ; Get all the BILL/CLAIMS Data
"RTN","IBCEMSR2",145,0)
 ; FIELD .13 STATUS, 0-CLOSED, 1-ENTERED/NOT REVIEWED, 2-REQUEST MRA, 3-AUTHORIZED,
"RTN","IBCEMSR2",146,0)
 ;                   4-PRNT/TX, 5-**NOT USED**, 7-CANCELLED
"RTN","IBCEMSR2",147,0)
 ; FIELD .19 FORM TYPE, POINTER TO BILL FORM TYPE FILE (#353), 2-CMS1500, 3-UB4
"RTN","IBCEMSR2",148,0)
 ; FIELD .21 CURRENT BILL PAYER SEQUENCE, P-PRIMARY, S-SECONDARY, T-TERTIARY, A-PATIENT
"RTN","IBCEMSR2",149,0)
 ; FIELD .22 DEFAULT DIVISION, POINTER TO MEDICAL CENTER DIVISION FILE (#40.8)
"RTN","IBCEMSR2",150,0)
 ; FIELD .27 BILL CHARGE TYPE, 1-INSTITUTIONAL, 2-PROFESSIONAL
"RTN","IBCEMSR2",151,0)
 ; FIELD  7  MRA REQUESTED DATE
"RTN","IBCEMSR2",152,0)
 ; FIELD  8  MRA REQUESTOR, POINTER TO NEW PERSON FILE (#200)
"RTN","IBCEMSR2",153,0)
 ; FIELD 21  LAST ELECTRONIC EXTRACT DATE
"RTN","IBCEMSR2",154,0)
 ; FIELD 27  FORCE CLAIM TO PRINT
"RTN","IBCEMSR2",155,0)
 ; FIELD 35  AUTO PROCESS, 1-WORKLIST, 2-LOCAL PRINT, 3-EDI, 4-NO LONGER ON WORK LIST
"RTN","IBCEMSR2",156,0)
 ; FIELD 38  REMOVED FROM WORKLIST, RM-REMOVED, PC-PROCESS COB, CL-CLONE, CA-CANCELLED, CR-CORRECTED
"RTN","IBCEMSR2",157,0)
 ; FIELD 125 PRIMARY BILL #
"RTN","IBCEMSR2",158,0)
 ; FIELD 126 SECONDARY BILL #
"RTN","IBCEMSR2",159,0)
 ; FIELD 127 TERTIARY BILL #
"RTN","IBCEMSR2",160,0)
 ; FIELD 201 TOTAL CHARGES
"RTN","IBCEMSR2",161,0)
 ; FIELD 218 PRIMARY PRIOR PAYMENT
"RTN","IBCEMSR2",162,0)
 ; FIELD 219 SECONDARY PRIOR PAYMENT
"RTN","IBCEMSR2",163,0)
 D IBOBJ(399,IBIFN,".13;.19;.21;.22;.27;7;8;21;27;35;38;125;126;127;201;218;219;302;303",.IBOB)  ; Load BILL/CLAIMS Data.
"RTN","IBCEMSR2",164,0)
 I IBOB(126) D IBOBJ(399,IBOB(126),".13;.19;.21;.22;.27;7;8;21;27;35;38;125;126;127;201;218;219;302;303",.IBOBS)  ; Load Secondary BILL/CLAIMS Data.
"RTN","IBCEMSR2",165,0)
 I IBOB(127) D IBOBJ(399,IBOB(127),".13;.19;.21;.22;.27;7;8;21;27;35;38;125;126;127;201;218;219;302;303",.IBOBT)  ; Load Tertiary BILL/CLAIMS Data.
"RTN","IBCEMSR2",166,0)
 ;
"RTN","IBCEMSR2",167,0)
 ; Quit if this bill contains a MRA date.
"RTN","IBCEMSR2",168,0)
 ; I IBOB(7) Q  Removed to allow secondary Non-MRA EOBs.
"RTN","IBCEMSR2",169,0)
 ;
"RTN","IBCEMSR2",170,0)
 ; Quit if this Insurance Company WNR for this sequence
"RTN","IBCEMSR2",171,0)
 I $$WNRBILL^IBEFUNC(IBIFN,IBOE(.15)) Q
"RTN","IBCEMSR2",172,0)
 ;
"RTN","IBCEMSR2",173,0)
 ; Quit if this BILL/CLAIM isn't a 2-CMS-1500 or 3-UB-04
"RTN","IBCEMSR2",174,0)
 I IBOB(.19)'=2,IBOB(.19)'=3 Q
"RTN","IBCEMSR2",175,0)
 ;
"RTN","IBCEMSR2",176,0)
 ; Quit if this BILL/CLAIM isn't from a selected Division
"RTN","IBCEMSR2",177,0)
 I IBDIV'="ALL",'$D(IBDIV(+IBOB(.22))) Q
"RTN","IBCEMSR2",178,0)
 ;
"RTN","IBCEMSR2",179,0)
 D COLLECT2^IBCEMSR3  ; Accumulate information for the Detailed Report
"RTN","IBCEMSR2",180,0)
 D COLLECT3^IBCEMSR3  ; Accumulate information for the Summary Report
"RTN","IBCEMSR2",181,0)
 D CALCPCT^IBCEMSR5   ; Calculate the Summary Report Percentages
"RTN","IBCEMSR2",182,0)
 Q
"RTN","IBCEMSR2",183,0)
 ;
"RTN","IBCEMSR2",184,0)
REPORT  ; IF REQUESTED DO DETAIL REPORT, ALWAYS DO SUMMARY REPORT
"RTN","IBCEMSR2",185,0)
 N IBLNUMB,IBLTEXT,IBCLERK,IBDIV2
"RTN","IBCEMSR2",186,0)
 ; Do the Full report if requested.
"RTN","IBCEMSR2",187,0)
 I IBSUM="F" D
"RTN","IBCEMSR2",188,0)
 . D HDR
"RTN","IBCEMSR2",189,0)
 . S IBDIV2="DIVISION"
"RTN","IBCEMSR2",190,0)
 . W !,"DIVISION: ","*** ",IBLTMPH("ALLDIV")," ***",! D CHKP Q:IBQ
"RTN","IBCEMSR2",191,0)
 . F IBLNUMB=2:1  S IBLTEXT=$T(FFORM+IBLNUMB^IBCEMSR4) Q:$P(IBLTEXT,";;",2)="END"  Q:IBQ  D PARSE
"RTN","IBCEMSR2",192,0)
 . S IBDIV2=0 F  S IBDIV2=$O(IBLTMP(IBDIV2)) Q:+IBDIV2=0  Q:IBQ  D
"RTN","IBCEMSR2",193,0)
 .. W !,"DIVISION: ",$$GET1^DIQ(40.8,IBDIV2_",",.01),! D CHKP Q:IBQ
"RTN","IBCEMSR2",194,0)
 .. F IBLNUMB=2:1  S IBLTEXT=$T(FFORM+IBLNUMB^IBCEMSR4) Q:$P(IBLTEXT,";;",2)="END"  Q:IBQ  D PARSE
"RTN","IBCEMSR2",195,0)
 ; Do the Summary report if requested.
"RTN","IBCEMSR2",196,0)
 I IBSUM="S" D
"RTN","IBCEMSR2",197,0)
 . D HDR
"RTN","IBCEMSR2",198,0)
 . W !,"SUMMARY",! D CHKP Q:IBQ
"RTN","IBCEMSR2",199,0)
 . S IBDIV2="DIVISION"
"RTN","IBCEMSR2",200,0)
 . W "DIVISION: ","*** ",IBLTMPH("ALLDIV")," ***",! D CHKP Q:IBQ
"RTN","IBCEMSR2",201,0)
 . F IBLNUMB=2:1  S IBLTEXT=$T(SFORM+IBLNUMB^IBCEMSR4) Q:$P(IBLTEXT,";;",2)="END"  Q:IBQ  D PARSE
"RTN","IBCEMSR2",202,0)
 . S IBDIV2=0 F  S IBDIV2=$O(IBLTMP(IBDIV2)) Q:+IBDIV2=0  Q:IBQ  D
"RTN","IBCEMSR2",203,0)
 .. W !,"DIVISION: ",$$GET1^DIQ(40.8,IBDIV2_",",.01),! D CHKP Q:IBQ
"RTN","IBCEMSR2",204,0)
 .. F IBLNUMB=2:1  S IBLTEXT=$T(SFORM+IBLNUMB^IBCEMSR4) Q:$P(IBLTEXT,";;",2)="END"  Q:IBQ  D PARSE
"RTN","IBCEMSR2",205,0)
 Q
"RTN","IBCEMSR2",206,0)
 ;
"RTN","IBCEMSR2",207,0)
HDR  ; Report header
"RTN","IBCEMSR2",208,0)
 N IBI
"RTN","IBCEMSR2",209,0)
 S IBPAGE=IBPAGE+1
"RTN","IBCEMSR2",210,0)
 W @IOF,"Non-MRA Productivity Report for period covering "_$$FMTE^XLFDT(IBBDT)_" thru "_$$FMTE^XLFDT(IBEDT),"   ",?100,$$FMTE^XLFDT(DT),"   Page ",IBPAGE
"RTN","IBCEMSR2",211,0)
 W ! F IBI=1:1:$S($G(IOM):IOM,1:130) W "-"
"RTN","IBCEMSR2",212,0)
 W !
"RTN","IBCEMSR2",213,0)
 Q
"RTN","IBCEMSR2",214,0)
 ;
"RTN","IBCEMSR2",215,0)
CHKP  ; Check for End Of Page
"RTN","IBCEMSR2",216,0)
 I $Y>(IOSL-4) D:IBSCR  Q:IBQ  D HDR
"RTN","IBCEMSR2",217,0)
 . N X,Y,DTOUT,DUOUT,DIRUT,DIR
"RTN","IBCEMSR2",218,0)
 . U IO(0) S DIR(0)="E" D ^DIR S:$D(DIRUT) IBQ=2
"RTN","IBCEMSR2",219,0)
 . U IO
"RTN","IBCEMSR2",220,0)
 Q
"RTN","IBCEMSR2",221,0)
 ;
"RTN","IBCEMSR2",222,0)
PARSE  ; USE TEXT INFORMATION FROM FFORM & SFORM TO PRODUCE THE REPORT
"RTN","IBCEMSR2",223,0)
 N IBACCUM
"RTN","IBCEMSR2",224,0)
 S IBACCUM=$$TRIM^XLFSTR($P(IBLTEXT,";",4))
"RTN","IBCEMSR2",225,0)
 S:IBACCUM="" IBACCUM="SKIP"
"RTN","IBCEMSR2",226,0)
 S IBLTEXT=$P(IBLTEXT,";",5)
"RTN","IBCEMSR2",227,0)
 W ?($P(IBLTEXT,U,1)),$$TRIM^XLFSTR($P(IBLTEXT,U,2))
"RTN","IBCEMSR2",228,0)
 W:$$TRIM^XLFSTR($P(IBLTEXT,U,5))="" ?($P(IBLTEXT,U,3)),$J($G(IBLTMP(IBDIV2,IBACCUM,3)),$P(IBLTEXT,U,4))
"RTN","IBCEMSR2",229,0)
 W:$$TRIM^XLFSTR($P(IBLTEXT,U,5))'="" ?($P(IBLTEXT,U,3)),$J($G(IBLTMP(IBDIV2,IBACCUM,3)),$P(IBLTEXT,U,4),$P(IBLTEXT,U,5))
"RTN","IBCEMSR2",230,0)
 W ?($P(IBLTEXT,U,6)),$$TRIM^XLFSTR($P(IBLTEXT,U,7))
"RTN","IBCEMSR2",231,0)
 W:$$TRIM^XLFSTR($P(IBLTEXT,U,10))="" ?($P(IBLTEXT,U,8)),$J($G(IBLTMP(IBDIV2,IBACCUM,2)),$P(IBLTEXT,U,9)),!
"RTN","IBCEMSR2",232,0)
 W:$$TRIM^XLFSTR($P(IBLTEXT,U,10))'="" ?($P(IBLTEXT,U,8)),$J($G(IBLTMP(IBDIV2,IBACCUM,2)),$P(IBLTEXT,U,9),$P(IBLTEXT,U,10)),!
"RTN","IBCEMSR2",233,0)
 D CHKP Q:IBQ
"RTN","IBCEMSR2",234,0)
 Q
"RTN","IBCEMSR2",235,0)
 ;
"RTN","IBCEMSR2",236,0)
IBOBJ(IBDICT,IBIEN,IBFLDS,IBARRY)  ; LOAD DATA ARRAY
"RTN","IBCEMSR2",237,0)
 N IBTMPARR,IBX K IBARRY
"RTN","IBCEMSR2",238,0)
 D GETS^DIQ(IBDICT,IBIEN_",",IBFLDS,"I","IBTMPARR")
"RTN","IBCEMSR2",239,0)
 S IBX="" F  S IBX=$O(IBTMPARR(IBDICT,IBIEN_",",IBX)) Q:IBX=""  D
"RTN","IBCEMSR2",240,0)
 . S IBARRY(IBX)=IBTMPARR(IBDICT,IBIEN_",",IBX,"I")
"RTN","IBCEMSR2",241,0)
 Q
"RTN","IBCEMSR2",242,0)
 ;
"RTN","IBCEMSR2",243,0)
IBDOC  ; Print accumulater list to screen
"RTN","IBCEMSR2",244,0)
 N IBLNUMB,IBLTEXT
"RTN","IBCEMSR2",245,0)
 W !,"Detail Form Accumulators",!
"RTN","IBCEMSR2",246,0)
 W "-------------------------",!
"RTN","IBCEMSR2",247,0)
 F IBLNUMB=2:1  S IBLTEXT=$T(FFORM+IBLNUMB^IBCEMSR4) Q:$P(IBLTEXT,";;",2)="END"  D
"RTN","IBCEMSR2",248,0)
 . W $P(IBLTEXT,";",4),?10,$$TRIM^XLFSTR($P(IBLTEXT,U,2)),!
"RTN","IBCEMSR2",249,0)
 W !,"Summary Form Accumulators",!
"RTN","IBCEMSR2",250,0)
 W "-------------------------",!
"RTN","IBCEMSR2",251,0)
 F IBLNUMB=2:1  S IBLTEXT=$T(SFORM+IBLNUMB^IBCEMSR4) Q:$P(IBLTEXT,";;",2)="END"  D
"RTN","IBCEMSR2",252,0)
 . W $P(IBLTEXT,";",4),?10,$$TRIM^XLFSTR($P(IBLTEXT,U,2)),!
"RTN","IBCEMSR2",253,0)
 Q
"RTN","IBCEMSR3")
0^36^B132530577
"RTN","IBCEMSR3",1,0)
IBCEMSR3  ;BI/ALB - non-MRA PRODUCTIVITY REPORT ;02/14/11
"RTN","IBCEMSR3",2,0)
 ;;2.0;INTEGRATED BILLING;**447**;21-MAR-94;Build 80
"RTN","IBCEMSR3",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCEMSR3",4,0)
 ;
"RTN","IBCEMSR3",5,0)
 Q
"RTN","IBCEMSR3",6,0)
 ;
"RTN","IBCEMSR3",7,0)
COLLECT2  ; Accumulate information for the Detailed Report
"RTN","IBCEMSR3",8,0)
 Q:$D(^TMP($J,"IBCEMSR2","FFORM",IBIFN))                ; Count each CLAIM/BILL only once
"RTN","IBCEMSR3",9,0)
 S ^TMP($J,"IBCEMSR2","FFORM",IBIFN)=""                 ; Record CLAIM/BILL use
"RTN","IBCEMSR3",10,0)
 I IBOB(.21)="P" D                                      ; Primary
"RTN","IBCEMSR3",11,0)
 . I $$PROCSSED^IBCEMSR5(IBIFN) D                       ;   Processed 
"RTN","IBCEMSR3",12,0)
 .. D FFORM("FPA",1)                                    ;     Total Number of Processes Requests
"RTN","IBCEMSR3",13,0)
 .. I ((IBOB(35)=2)!(IBOB(35)=3)) D                     ;       Auto-processed to secondary
"RTN","IBCEMSR3",14,0)
 ... D FFORM("FPAA",1)                                  ;         Total Number auto-processed to secondary
"RTN","IBCEMSR3",15,0)
 ... I IBOB(35)=2 D                                     ;           Printed Locally
"RTN","IBCEMSR3",16,0)
 .... D FFORM("FPAAA",1)                                ;             Number Printed Locally
"RTN","IBCEMSR3",17,0)
 .... D FFORM("FPAAA1",$G(IBOBS(201))-$G(IBOBS(218)))   ;               Total Secondary Charges
"RTN","IBCEMSR3",18,0)
 ... I IBOB(35)=3 D                                     ;           Transmitted
"RTN","IBCEMSR3",19,0)
 .... D FFORM("FPAAB",1)                                ;             Number Transmitted
"RTN","IBCEMSR3",20,0)
 .... D FFORM("FPAAB1",$G(IBOBS(201))-$G(IBOBS(218)))   ;               Total Secondary Charges
"RTN","IBCEMSR3",21,0)
 .. I ((IBOB(35)=1)!(IBOB(35)=4)) D                     ;       Sent to Worklist
"RTN","IBCEMSR3",22,0)
 ... D FFORM("FPAB",1)                                  ;         Total Number Sent to Worklist
"RTN","IBCEMSR3",23,0)
 ... I IBOB(38)="PC" D                                  ;           Processed from worklist
"RTN","IBCEMSR3",24,0)
 .... D FFORM("FPABA",1)                                ;             Number processed from worklist
"RTN","IBCEMSR3",25,0)
 .... D FFORM("FPABA1",$G(IBOBS(201))-$G(IBOBS(218)))   ;               Total secondary charges
"RTN","IBCEMSR3",26,0)
 ... I IBOB(38)="RM" D                                  ;           Removed from worklist
"RTN","IBCEMSR3",27,0)
 .... D FFORM("FPABB",1)                                ;             Number removed from worklist
"RTN","IBCEMSR3",28,0)
 .... D FFORM("FPABB1",$$TOT^IBCECOB2(IBIFN,1))         ;               Total secondary charges
"RTN","IBCEMSR3",29,0)
 ... I IBOB(38)="CA" D                                  ;           Cancelled from worklist
"RTN","IBCEMSR3",30,0)
 .... D FFORM("FPABC",1)                                ;             Number cancelled from worklist
"RTN","IBCEMSR3",31,0)
 .... D FFORM("FPABC1",$$TOT^IBCECOB2(IBIFN,1))         ;               Total secondary charges
"RTN","IBCEMSR3",32,0)
 ... I IBOB(35)=1 D                                     ;           Still on worklist
"RTN","IBCEMSR3",33,0)
 .... D FFORM("FPABD",1)                                ;             Number still on worklist
"RTN","IBCEMSR3",34,0)
 .... D FFORM("FPABD1",$$TOT^IBCECOB2(IBIFN,1))         ;               Total secondary charges
"RTN","IBCEMSR3",35,0)
 .. I $$NOSUB^IBCEMSR5(IBIFN),$P($$BILL^RCJIBFN2(IBIFN),U,2)=22 D  ;  Number without secondary
"RTN","IBCEMSR3",36,0)
 ... D FFORM("FPWOS",1)                                 ;         Total number w/out secondary
"RTN","IBCEMSR3",37,0)
 .. ;DBIA 1452  ;  Number of EEOBs not collected/closed
"RTN","IBCEMSR3",38,0)
 .. I '((IBOB(35)=1)!(IBOB(35)=4)),$$NOSUB^IBCEMSR5(IBIFN),$P($$BILL^RCJIBFN2(IBIFN),U,2)'=22 D
"RTN","IBCEMSR3",39,0)
 ... D FFORM("FPNCC",1)                                 ;         Total Number of EEOBs not collected/closed
"RTN","IBCEMSR3",40,0)
 . I $$DENIED^IBCEMSR5(IBIFN) D                         ;   Denied
"RTN","IBCEMSR3",41,0)
 .. D FFORM("FPB",1)                                    ;     Total Number of Denied Requests
"RTN","IBCEMSR3",42,0)
 .. I IBOB(35)=1 D                                      ;           Still on worklist
"RTN","IBCEMSR3",43,0)
 ... D SFORM("FPSOW",1)                                 ;             Number still on worklist
"RTN","IBCEMSR3",44,0)
 .. I IBOB(38)="PC" D                                   ;           Processed from worklist
"RTN","IBCEMSR3",45,0)
 ... D FFORM("FPBXD",1)                                 ;             Number processed from worklist
"RTN","IBCEMSR3",46,0)
 .. I IBOB(38)="RM" D                                   ;           Removed from worklist
"RTN","IBCEMSR3",47,0)
 ... D FFORM("FPBXA",1)                                 ;             Number removed from worklist
"RTN","IBCEMSR3",48,0)
 .. I IBOB(38)="CA" D                                   ;           Cancelled from worklist
"RTN","IBCEMSR3",49,0)
 ... D FFORM("FPBXE",1)                                 ;             Number cancelled from worklist
"RTN","IBCEMSR3",50,0)
 .. I IBOB(38)="CR" D                                   ;           Corrected from worklist
"RTN","IBCEMSR3",51,0)
 ... D FFORM("FPBXB",1)                                 ;             Number corrected from worklist
"RTN","IBCEMSR3",52,0)
 ... D FFORM("FPBXB1",IBOB(201))                        ;               Total primary charges
"RTN","IBCEMSR3",53,0)
 .. I IBOB(38)="CL" D                                   ;           Cloned from worklist
"RTN","IBCEMSR3",54,0)
 ... D FFORM("FPBXC",1)                                 ;             Number cloned from worklist
"RTN","IBCEMSR3",55,0)
 ... D FFORM("FPBXC1",IBOB(201))                        ;               Total primary charges
"RTN","IBCEMSR3",56,0)
 ;                                                      ;
"RTN","IBCEMSR3",57,0)
 I IBOB(.21)="S" D                                      ; Secondary
"RTN","IBCEMSR3",58,0)
 . I $$PROCSSED^IBCEMSR5(IBIFN) D                       ;   Processed 
"RTN","IBCEMSR3",59,0)
 .. D FFORM("FSA",1)                                    ;     Total Number of Processes Requests
"RTN","IBCEMSR3",60,0)
 .. I ((IBOB(35)=2)!(IBOB(35)=3)) D                     ;       Auto-processed to tertiary
"RTN","IBCEMSR3",61,0)
 ... D FFORM("FSAA",1)                                  ;         Total Number auto-processed to tertiary
"RTN","IBCEMSR3",62,0)
 ... I IBOB(35)=2 D                                     ;           Printed Locally
"RTN","IBCEMSR3",63,0)
 .... D FFORM("FSAAA",1)                                ;             Number Printed Locally
"RTN","IBCEMSR3",64,0)
 .... D FFORM("FSAAA1",$G(IBOBT(201))-$G(IBOBT(218))-$G(IBOBT(219))) ;  Total tertiary Charges
"RTN","IBCEMSR3",65,0)
 ... I IBOB(35)=3 D                                     ;           Transmitted
"RTN","IBCEMSR3",66,0)
 .... D FFORM("FSAAB",1)                                ;             Number Transmitted
"RTN","IBCEMSR3",67,0)
 .... D FFORM("FSAAB1",$G(IBOBT(201))-$G(IBOBT(218))-$G(IBOBT(219))) ;  Total tertiary Charges
"RTN","IBCEMSR3",68,0)
 .. I ((IBOB(35)=1)!(IBOB(35)=4)) D                     ;       Sent to Worklist
"RTN","IBCEMSR3",69,0)
 ... D FFORM("FSAB",1)                                  ;         Total Number Sent to Worklist
"RTN","IBCEMSR3",70,0)
 ... I IBOB(38)="PC" D                                  ;           Processed from worklist
"RTN","IBCEMSR3",71,0)
 .... D FFORM("FSABA",1)                                ;             Number processed from worklist
"RTN","IBCEMSR3",72,0)
 .... D FFORM("FSABA1",$G(IBOBT(201))-$G(IBOBT(218))-$G(IBOBT(219)))   ;  Total secondary charges
"RTN","IBCEMSR3",73,0)
 ... I IBOB(38)="RM" D                                  ;           Removed from worklist
"RTN","IBCEMSR3",74,0)
 .... D FFORM("FSABB",1)                                ;             Number removed from worklist
"RTN","IBCEMSR3",75,0)
 .... D FFORM("FSABB1",$$TOT^IBCECOB2(IBIFN,1))         ;               Total tertiary charges
"RTN","IBCEMSR3",76,0)
 ... I IBOB(38)="CA" D                                  ;           Cancelled from worklist
"RTN","IBCEMSR3",77,0)
 .... D FFORM("FSABC",1)                                ;             Number cancelled from worklist
"RTN","IBCEMSR3",78,0)
 .... D FFORM("FSABC1",$$TOT^IBCECOB2(IBIFN,1))         ;               Total tertiary charges
"RTN","IBCEMSR3",79,0)
 ... I IBOB(35)=1 D                                     ;           Still on worklist
"RTN","IBCEMSR3",80,0)
 .... D FFORM("FSABD",1)                                ;             Number still on worklist
"RTN","IBCEMSR3",81,0)
 .... D FFORM("FSABD1",$$TOT^IBCECOB2(IBIFN,1))         ;               Total tertiary charges
"RTN","IBCEMSR3",82,0)
 .. I $$NOSUB^IBCEMSR5(IBIFN),$P($$BILL^RCJIBFN2(IBIFN),U,2)=22 D  ;  Number without tertiary
"RTN","IBCEMSR3",83,0)
 ... D FFORM("FSWOT",1)                                 ;         Total number w/out tertiary
"RTN","IBCEMSR3",84,0)
 .. ;DBIA 1452  ;  Number of EEOBs not collected/closed
"RTN","IBCEMSR3",85,0)
 .. I '((IBOB(35)=1)!(IBOB(35)=4)),$$NOSUB^IBCEMSR5(IBIFN),$P($$BILL^RCJIBFN2(IBIFN),U,2)'=22 D
"RTN","IBCEMSR3",86,0)
 ... D FFORM("FSNCC",1)                                 ;         Total Number of EEOBs not collected/closed
"RTN","IBCEMSR3",87,0)
 . I $$DENIED^IBCEMSR5(IBIFN) D                         ;   Denied
"RTN","IBCEMSR3",88,0)
 .. D FFORM("FSB",1)                                    ;     Total Number of Denied Requests
"RTN","IBCEMSR3",89,0)
 .. I IBOB(35)=1 D                                      ;           Still on worklist
"RTN","IBCEMSR3",90,0)
 ... D SFORM("FSSOW",1)                                 ;             Number still on worklist
"RTN","IBCEMSR3",91,0)
 .. I IBOB(38)="PC" D                                   ;           Processed from worklist
"RTN","IBCEMSR3",92,0)
 ... D FFORM("FSBXD",1)                                 ;             Number processed from worklist
"RTN","IBCEMSR3",93,0)
 .. I IBOB(38)="RM" D                                   ;           Removed from worklist
"RTN","IBCEMSR3",94,0)
 ... D FFORM("FSBXA",1)                                 ;             Number removed from worklist
"RTN","IBCEMSR3",95,0)
 .. I IBOB(38)="CA" D                                   ;           Cancelled from worklist
"RTN","IBCEMSR3",96,0)
 ... D FFORM("FSBXE",1)                                 ;             Number cancelled from worklist
"RTN","IBCEMSR3",97,0)
 .. I IBOB(38)="CR" D                                   ;           Corrected from worklist
"RTN","IBCEMSR3",98,0)
 ... D FFORM("FSBXB",1)                                 ;             Number corrected from worklist
"RTN","IBCEMSR3",99,0)
 ... D FFORM("FSBXB1",$G(IBOBS(201))-$G(IBOBS(218)))    ;               Total tertiary charges
"RTN","IBCEMSR3",100,0)
 .. I IBOB(38)="CL" D                                   ;           Cloned from worklist
"RTN","IBCEMSR3",101,0)
 ... D FFORM("FSBXC",1)                                 ;             Number cloned from worklist
"RTN","IBCEMSR3",102,0)
 ... D FFORM("FSBXC1",$G(IBOBS(201))-$G(IBOBS(218)))    ;               Total tertiary charges
"RTN","IBCEMSR3",103,0)
 ;
"RTN","IBCEMSR3",104,0)
 Q
"RTN","IBCEMSR3",105,0)
 ;
"RTN","IBCEMSR3",106,0)
FFORM(IBACCUM,IBCNTCST)  ; Detail Form Collectors
"RTN","IBCEMSR3",107,0)
 ; IBLFTMP(IBDIV2,IBACCUM,IBFT)
"RTN","IBCEMSR3",108,0)
 ;         |      |       |
"RTN","IBCEMSR3",109,0)
 ;         |      |        - BILL/CLAIM FORM TYPE 2-CMS1500, 3-UB4
"RTN","IBCEMSR3",110,0)
 ;         |       --------- ACCUMULATOR FOR COUNTS AND CHARGES
"RTN","IBCEMSR3",111,0)
 ;          ---------------- BILL/CLAIM DEFAULT DIVISION, DICT #40.8, ^DG(40.8,)
"RTN","IBCEMSR3",112,0)
 S IBLTMP(IBOB(.22),IBACCUM,IBOB(.19))=$G(IBLTMP(IBOB(.22),IBACCUM,IBOB(.19)))+IBCNTCST
"RTN","IBCEMSR3",113,0)
 S IBLTMP("DIVISION",IBACCUM,IBOB(.19))=$G(IBLTMP("DIVISION",IBACCUM,IBOB(.19)))+IBCNTCST
"RTN","IBCEMSR3",114,0)
 Q
"RTN","IBCEMSR3",115,0)
 ;
"RTN","IBCEMSR3",116,0)
COLLECT3  ; Accumulate information for the Summary Report
"RTN","IBCEMSR3",117,0)
 I IBOB(.21)="P" D                                      ; Primary
"RTN","IBCEMSR3",118,0)
 . D SFORM("SPA",1)                                     ; Total number of EEOBs received
"RTN","IBCEMSR3",119,0)
 . Q:$D(^TMP($J,"IBCEMSR2","SFORM",IBIFN))              ; Count each CLAIM/BILL only once
"RTN","IBCEMSR3",120,0)
 . S ^TMP($J,"IBCEMSR2","SFORM",IBIFN)=""               ; Record CLAIM/BILL use
"RTN","IBCEMSR3",121,0)
 . D SFORM("SPACL",1)                                   ; Total number of associated CLAIM/BILLS
"RTN","IBCEMSR3",122,0)
 . ; SPAA Calculated Later                              ;   % Processed
"RTN","IBCEMSR3",123,0)
 . ; SPAB Calculated Later                              ;   % of Processed auto-processed to secondary
"RTN","IBCEMSR3",124,0)
 . I $$PROCSSED^IBCEMSR5(IBIFN) D                       ;   Processed
"RTN","IBCEMSR3",125,0)
 .. D SFORM("SPAC",1)                                   ;     Total Number of Processes Requests
"RTN","IBCEMSR3",126,0)
 .. I ((IBOB(35)=2)!(IBOB(35)=3)) D                     ;       Auto-processed to secondary
"RTN","IBCEMSR3",127,0)
 ... D SFORM("SPACA",1)                                 ;         Total Number auto-processed to secondary
"RTN","IBCEMSR3",128,0)
 ... I IBOB(35)=2 D                                     ;           Printed Locally
"RTN","IBCEMSR3",129,0)
 .... D SFORM("SPACAA",1)                               ;             Number Printed Locally
"RTN","IBCEMSR3",130,0)
 .... D SFORM("SPACAA1",$G(IBOBS(201))-$G(IBOBS(218)))  ;               Total Secondary Charges
"RTN","IBCEMSR3",131,0)
 ... I IBOB(35)=3 D                                     ;           Transmitted
"RTN","IBCEMSR3",132,0)
 .... D SFORM("SPACAB",1)                               ;             Number Transmitted
"RTN","IBCEMSR3",133,0)
 .... D SFORM("SPACAB1",$G(IBOBS(201))-$G(IBOBS(218)))  ;               Total Secondary Charges
"RTN","IBCEMSR3",134,0)
 .. I '((IBOB(35)=2)!(IBOB(35)=3)),IBOB(38)="PC" D      ;       Manually processed to secondary
"RTN","IBCEMSR3",135,0)
 ... D SFORM("SPACB",1)                                 ;         Number manually processed to secondary
"RTN","IBCEMSR3",136,0)
 ... I $G(IBOBS(27))'="",$G(IBOBS(21))="" D             ;           Printed Locally
"RTN","IBCEMSR3",137,0)
 .... D SFORM("SPACBA",1)                               ;             Number Printed Locally
"RTN","IBCEMSR3",138,0)
 .... D SFORM("SPACBA1",$G(IBOBS(201))-$G(IBOBS(218)))  ;               Total secondary charges
"RTN","IBCEMSR3",139,0)
 ... I $G(IBOBS(21))'="",$G(IBOBS(27))="" D             ;           Transmitted
"RTN","IBCEMSR3",140,0)
 .... D SFORM("SPACBB",1)                               ;             Number Transmitted
"RTN","IBCEMSR3",141,0)
 .... D SFORM("SPACBB1",$G(IBOBS(201))-$G(IBOBS(218)))  ;               Total secondary charges
"RTN","IBCEMSR3",142,0)
 .. I $$NOSUB^IBCEMSR5(IBIFN),$P($$BILL^RCJIBFN2(IBIFN),U,2)=22 D  ;       Number without secondary
"RTN","IBCEMSR3",143,0)
 ... D SFORM("SPWOS",1)                                 ;         Total number w/out secondary
"RTN","IBCEMSR3",144,0)
 .. ;DBIA 1452 ; Number of EEOBs not collected/closed
"RTN","IBCEMSR3",145,0)
 .. I '((IBOB(35)=1)!(IBOB(35)=4)),$$NOSUB^IBCEMSR5(IBIFN),$P($$BILL^RCJIBFN2(IBIFN),U,2)'=22 D
"RTN","IBCEMSR3",146,0)
 ... D SFORM("SPNCC",1)                                 ;         Total Number of EEOBs not collected/closed
"RTN","IBCEMSR3",147,0)
 .. I IBOB(35)=1 D                                      ;           Still on worklist
"RTN","IBCEMSR3",148,0)
 ... D SFORM("SPABD",1)                                 ;             Number still on worklist
"RTN","IBCEMSR3",149,0)
 . I $$DENIED^IBCEMSR5(IBIFN) D                         ;  Denied
"RTN","IBCEMSR3",150,0)
 .. D SFORM("SPAD",1)                                   ;    Number of Denied EEOBs
"RTN","IBCEMSR3",151,0)
 ;
"RTN","IBCEMSR3",152,0)
 I IBOB(.21)="S" D                                      ; Secondary
"RTN","IBCEMSR3",153,0)
 . D SFORM("SSA",1)                                     ; Total number of EEOBs received
"RTN","IBCEMSR3",154,0)
 . Q:$D(^TMP($J,"IBCEMSR2","SFORM",IBIFN))              ; Count each CLAIM/BILL only once
"RTN","IBCEMSR3",155,0)
 . S ^TMP($J,"IBCEMSR2","SFORM",IBIFN)=""               ; Record CLAIM/BILL use
"RTN","IBCEMSR3",156,0)
 . D SFORM("SSACL",1)                                   ; Total number of associated CLAIM/BILLS
"RTN","IBCEMSR3",157,0)
 . ; SSAA Calculated Later                              ;   % Processed
"RTN","IBCEMSR3",158,0)
 . ; SSAB Calculated Later                              ;   % of Processed auto-processed to tertiary
"RTN","IBCEMSR3",159,0)
 . I $$PROCSSED^IBCEMSR5(IBIFN) D                       ;   Processed
"RTN","IBCEMSR3",160,0)
 .. D SFORM("SSAC",1)                                   ;     Total Number of Processes Requests
"RTN","IBCEMSR3",161,0)
 .. I ((IBOB(35)=2)!(IBOB(35)=3)) D                     ;       Auto-processed to tertiary
"RTN","IBCEMSR3",162,0)
 ... D SFORM("SSACA",1)                                 ;         Total Number auto-processed to tertiary
"RTN","IBCEMSR3",163,0)
 ... I IBOB(35)=2 D                                     ;           Printed Locally
"RTN","IBCEMSR3",164,0)
 .... D SFORM("SSACAA",1)                               ;             Number Printed Locally
"RTN","IBCEMSR3",165,0)
 .... D SFORM("SSACAA1",$G(IBOBT(201))-$G(IBOBT(218))-$G(IBOBT(219))) ;    Total tertiary Charges
"RTN","IBCEMSR3",166,0)
 ... I IBOB(35)=3 D                                     ;           Transmitted
"RTN","IBCEMSR3",167,0)
 .... D SFORM("SSACAB",1)                               ;             Number Transmitted
"RTN","IBCEMSR3",168,0)
 .... D SFORM("SSACAB1",$G(IBOBT(201))-$G(IBOBT(218))-$G(IBOBT(219))) ;    Total tertiary Charges
"RTN","IBCEMSR3",169,0)
 .. I '((IBOB(35)=2)!(IBOB(35)=3)),IBOB(38)="PC" D      ;       Manually processed to tertiary
"RTN","IBCEMSR3",170,0)
 ... D SFORM("SSADB",1)                                 ;         Number manually processed to tertiary
"RTN","IBCEMSR3",171,0)
 ... I $G(IBOBT(27))'="",$G(IBOBT(21))="" D             ;           Printed Locally
"RTN","IBCEMSR3",172,0)
 .... D SFORM("SSADBA",1)                               ;             Number Printed Locally
"RTN","IBCEMSR3",173,0)
 .... D SFORM("SSADBA1",$G(IBOBT(201))-$G(IBOBT(218))-$G(IBOBT(219))) ;    Total tertiary charges
"RTN","IBCEMSR3",174,0)
 ... I $G(IBOBT(21))'="",$G(IBOBT(27))="" D             ;           Transmitted
"RTN","IBCEMSR3",175,0)
 .... D SFORM("SSPDABB",1)                              ;             Number Transmitted
"RTN","IBCEMSR3",176,0)
 .... D SFORM("SSADBB1",$G(IBOBT(201))-$G(IBOBT(218))-$G(IBOBT(219))) ;    Total tertiary charges
"RTN","IBCEMSR3",177,0)
 .. I $$NOSUB^IBCEMSR5(IBIFN),$P($$BILL^RCJIBFN2(IBIFN),U,2)=22 D  ;       Number without tertiary
"RTN","IBCEMSR3",178,0)
 ... D SFORM("SSWOT",1)                                 ;         Total number w/out tertiary
"RTN","IBCEMSR3",179,0)
 .. ;DBIA 1452 ; Number of EEOBs not collected/closed
"RTN","IBCEMSR3",180,0)
 .. I '((IBOB(35)=1)!(IBOB(35)=4)),$$NOSUB^IBCEMSR5(IBIFN),$P($$BILL^RCJIBFN2(IBIFN),U,2)'=22 D  ;DBIA 1452 ; Number of EEOBs not collected/closed
"RTN","IBCEMSR3",181,0)
 ... D SFORM("SSNCC",1)                                 ;         Total Number of EEOBs not collected/closed
"RTN","IBCEMSR3",182,0)
 .. I IBOB(35)=1 D                                      ;           Still on worklist
"RTN","IBCEMSR3",183,0)
 ... D SFORM("SSABD",1)                                 ;             Number still on worklist
"RTN","IBCEMSR3",184,0)
 . I $$DENIED^IBCEMSR5(IBIFN) D                         ;  Denied
"RTN","IBCEMSR3",185,0)
 .. D SFORM("SSAD",1)                                   ;    Number of Denied EEOBs
"RTN","IBCEMSR3",186,0)
 ;
"RTN","IBCEMSR3",187,0)
 Q
"RTN","IBCEMSR3",188,0)
 ;
"RTN","IBCEMSR3",189,0)
SFORM(IBACCUM,IBCNTCST)  ; Summary Form Collectors
"RTN","IBCEMSR3",190,0)
 ; IBLSTMP(IBDIV2,IBACCUM,IBFT)
"RTN","IBCEMSR3",191,0)
 ;         |      |       |
"RTN","IBCEMSR3",192,0)
 ;         |      |        - BILL/CLAIM FORM TYPE 2-CMS1500, 3-UB4
"RTN","IBCEMSR3",193,0)
 ;         |       --------- ACCUMULATOR IDENTIFIER FOR COUNTS AND CHARGES
"RTN","IBCEMSR3",194,0)
 ;          -------------------------- BILL/CLAIM DEFAULT IBDIV2, DICT #40.8, ^DG(40.8,)
"RTN","IBCEMSR3",195,0)
 S IBLTMP(IBOB(.22),IBACCUM,IBOB(.19))=$G(IBLTMP(IBOB(.22),IBACCUM,IBOB(.19)))+IBCNTCST
"RTN","IBCEMSR3",196,0)
 S IBLTMP("DIVISION",IBACCUM,IBOB(.19))=$G(IBLTMP("DIVISION",IBACCUM,IBOB(.19)))+IBCNTCST
"RTN","IBCEMSR3",197,0)
 Q
"RTN","IBCEMSR4")
0^37^B110188807
"RTN","IBCEMSR4",1,0)
IBCEMSR4  ;BI/ALB - non-MRA PRODUCTIVITY REPORT ;02/14/11
"RTN","IBCEMSR4",2,0)
 ;;2.0;INTEGRATED BILLING;**447**;21-MAR-94;Build 80
"RTN","IBCEMSR4",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCEMSR4",4,0)
 ;
"RTN","IBCEMSR4",5,0)
 Q
"RTN","IBCEMSR4",6,0)
 ;
"RTN","IBCEMSR4",7,0)
FFORM  ; Detail FORM Setup
"RTN","IBCEMSR4",8,0)
 ;;LINE#;IBACCUM ;TAB^LABEL                                     ^TAB^$J^#D^TAB^LABEL                                      ^TAB^$J^#D
"RTN","IBCEMSR4",9,0)
 ;;1    ;        ;3  ^Primary UB04 Claim EEOBs                  ^41 ^  ^  ^63 ^Primary CMS-1500 Claim EEOBs               ^101^  ^
"RTN","IBCEMSR4",10,0)
 ;;2    ;        ;3  ^--------------------------                ^41 ^  ^  ^63 ^-----------------------------              ^101^  ^
"RTN","IBCEMSR4",11,0)
 ;;3    ;FPA     ;3  ^Total number of Processed EOBs:           ^41 ^14^0 ^63 ^Total number of Processed EEOBs:           ^101^14^0
"RTN","IBCEMSR4",12,0)
 ;;4    ;FPAA    ;6  ^Number Auto-processed to 2ndary:          ^41 ^14^0 ^66 ^Number Auto-processed to 2ndary:           ^101^14^0
"RTN","IBCEMSR4",13,0)
 ;;5    ;FPAAA   ;9  ^Number Printed locally:                   ^41 ^14^0 ^69 ^Number Printed locally:                    ^101^14^0
"RTN","IBCEMSR4",14,0)
 ;;6    ;FPAAA1  ;12 ^Total secondary charges:                  ^41 ^14^2 ^72 ^Total secondary charges:                   ^101^14^2
"RTN","IBCEMSR4",15,0)
 ;;7    ;FPAAB   ;9  ^Number Transmitted:                       ^41 ^14^0 ^69 ^Number Transmitted:                        ^101^14^0
"RTN","IBCEMSR4",16,0)
 ;;8    ;FPAAB1  ;12 ^Total secondary charges:                  ^41 ^14^2 ^72 ^Total secondary charges:                   ^101^14^2
"RTN","IBCEMSR4",17,0)
 ;;9    ;FPAB    ;6  ^Total number Sent to worklist:            ^41 ^14^0 ^66 ^Total number Sent to worklist:             ^101^14^0
"RTN","IBCEMSR4",18,0)
 ;;10   ;FPABA   ;9  ^Number Processed from worklist:           ^41 ^14^0 ^69 ^Number Processed from worklist:            ^101^14^0
"RTN","IBCEMSR4",19,0)
 ;;11   ;FPABA1  ;12 ^Total secondary charges:                  ^41 ^14^2 ^72 ^Total secondary charges:                   ^101^14^2
"RTN","IBCEMSR4",20,0)
 ;;12   ;FPABB   ;9  ^Number Removed from worklist:             ^41 ^14^0 ^69 ^Number Removed from worklist:              ^101^14^0
"RTN","IBCEMSR4",21,0)
 ;;13   ;FPABB1  ;12 ^Total secondary charges:                  ^41 ^14^2 ^72 ^Total secondary charges:                   ^101^14^2
"RTN","IBCEMSR4",22,0)
 ;;14   ;FPABC   ;9  ^Number Cancelled from worklist:           ^41 ^14^0 ^69 ^Number Cancelled from worklist:            ^101^14^0
"RTN","IBCEMSR4",23,0)
 ;;15   ;FPABC1  ;12 ^Total secondary charges:                  ^41 ^14^2 ^72 ^Total secondary charges:                   ^101^14^2
"RTN","IBCEMSR4",24,0)
 ;;16   ;FPABD   ;9  ^Number Still on worklist:                 ^41 ^14^0 ^69 ^Number Still on worklist:                  ^101^14^0
"RTN","IBCEMSR4",25,0)
 ;;17   ;FPABD1  ;12 ^Total secondary charges:                  ^41 ^14^2 ^72 ^Total secondary charges:                   ^101^14^2
"RTN","IBCEMSR4",26,0)
 ;;18   ;FPNCC   ;6  ^Number of EEOBs not collected/closed:     ^45 ^10^0 ^66 ^Number of EEOBs not collected/closed:      ^105^10^0
"RTN","IBCEMSR4",27,0)
 ;;19   ;FPWOS   ;6  ^Number of Closed EEOBs w/out 2ndary:      ^45 ^10^0 ^66 ^Number of Closed EEOBs w/out 2ndary:       ^105^10^0
"RTN","IBCEMSR4",28,0)
 ;;20   ;FPB     ;3  ^Total number of Denied EEOBs w/2ndary:    ^41 ^14^0 ^63 ^Total number of Denied EEOBs w/2ndary:     ^101^14^0
"RTN","IBCEMSR4",29,0)
 ;;21   ;FPSOW   ;6  ^Number Still on Worklist:                 ^41 ^14^0 ^66 ^Number Still on Worklist:                  ^101^14^0
"RTN","IBCEMSR4",30,0)
 ;;22   ;FPBXD   ;6  ^Number Processed from worklist:           ^41 ^14^0 ^66 ^Number Processed from worklist:            ^101^14^0
"RTN","IBCEMSR4",31,0)
 ;;23   ;FPBXA   ;6  ^Number Removed from worklist:             ^41 ^14^0 ^66 ^Number Removed from worklist:              ^101^14^0
"RTN","IBCEMSR4",32,0)
 ;;24   ;FPBXE   ;6  ^Number Cancelled from worklist:           ^41 ^14^0 ^66 ^Number Cancelled from worklist:            ^101^14^0
"RTN","IBCEMSR4",33,0)
 ;;25   ;FPBXB   ;6  ^Number Corrected from worklist:           ^41 ^14^0 ^66 ^Number Corrected from worklist:            ^101^14^0
"RTN","IBCEMSR4",34,0)
 ;;26   ;FPBXB1  ;9  ^Total primary charges:                    ^41 ^14^2 ^69 ^Total primary charges:                     ^101^14^2
"RTN","IBCEMSR4",35,0)
 ;;27   ;FPBXC   ;6  ^Number Cloned from worklist:              ^41 ^14^0 ^66 ^Number Cloned from worklist:               ^101^14^0
"RTN","IBCEMSR4",36,0)
 ;;28   ;FPBXC1  ;9  ^Total primary charges:                    ^41 ^14^2 ^69 ^Total primary charges:                     ^101^14^2
"RTN","IBCEMSR4",37,0)
 ;;29   ;        ;20 ^                                          ^41 ^  ^  ^   ^                                           ^101^  ^
"RTN","IBCEMSR4",38,0)
 ;;30   ;        ;3  ^Secondary UB04 Claim EEOBs                ^41 ^  ^  ^63 ^Secondary CMS-1500 Claim EEOBs             ^101^  ^
"RTN","IBCEMSR4",39,0)
 ;;31   ;        ;3  ^--------------------------                ^41 ^  ^  ^63 ^-----------------------------              ^101^  ^
"RTN","IBCEMSR4",40,0)
 ;;32   ;FSA     ;3  ^Total number of Processed EOBs:           ^41 ^14^0 ^63 ^Total number of Processed EEOBs:           ^101^14^0
"RTN","IBCEMSR4",41,0)
 ;;33   ;FSAA    ;6  ^Number Auto-processed to 2ndary:          ^41 ^14^0 ^66 ^Number Auto-processed to 2ndary:           ^101^14^0
"RTN","IBCEMSR4",42,0)
 ;;34   ;FSAAA   ;9  ^Number Printed locally:                   ^41 ^14^0 ^69 ^Number Printed locally:                    ^101^14^0
"RTN","IBCEMSR4",43,0)
 ;;35   ;FSAAA1  ;12 ^Total tertiary charges:                   ^41 ^14^2 ^72 ^Total tertiary charges:                    ^101^14^2
"RTN","IBCEMSR4",44,0)
 ;;36   ;FSAAB   ;9  ^Number Transmitted:                       ^41 ^14^0 ^69 ^Number Transmitted:                        ^101^14^0
"RTN","IBCEMSR4",45,0)
 ;;37   ;FSAAB1  ;12 ^Total tertiary charges:                   ^41 ^14^2 ^72 ^Total tertiary charges:                    ^101^14^2
"RTN","IBCEMSR4",46,0)
 ;;38   ;FSAB    ;6  ^Total number Sent to worklist:            ^41 ^14^0 ^66 ^Total number Sent to worklist:             ^101^14^0
"RTN","IBCEMSR4",47,0)
 ;;39   ;FSABA   ;9  ^Number Processed from worklist:           ^41 ^14^0 ^69 ^Number Processed from worklist:            ^101^14^0
"RTN","IBCEMSR4",48,0)
 ;;40   ;FSABA1  ;12 ^Total tertiary charges:                   ^41 ^14^2 ^72 ^Total tertiary charges:                    ^101^14^2
"RTN","IBCEMSR4",49,0)
 ;;41   ;FSABB   ;9  ^Number Removed from worklist:             ^41 ^14^0 ^69 ^Number Removed from worklist:              ^101^14^0
"RTN","IBCEMSR4",50,0)
 ;;42   ;FSABB1  ;12 ^Total tertiary charges:                   ^41 ^14^2 ^72 ^Total tertiary charges:                    ^101^14^2
"RTN","IBCEMSR4",51,0)
 ;;43   ;FSABC   ;9  ^Number Cancelled from worklist:           ^41 ^14^0 ^69 ^Number Cancelled from worklist:            ^101^14^0
"RTN","IBCEMSR4",52,0)
 ;;44   ;FSABC1  ;12 ^Total tertiary charges:                   ^41 ^14^2 ^72 ^Total tertiary charges:                    ^101^14^2
"RTN","IBCEMSR4",53,0)
 ;;45   ;FSABD   ;9  ^Number Still on worklist:                 ^41 ^14^0 ^69 ^Number Still on worklist:                  ^101^14^0
"RTN","IBCEMSR4",54,0)
 ;;46   ;FSABD1  ;12 ^Total tertiary charges:                   ^41 ^14^2 ^72 ^Total tertiary charges:                    ^101^14^2
"RTN","IBCEMSR4",55,0)
 ;;47   ;FSNCC   ;6  ^Number of EEOBs not collected/closed:     ^45 ^10^0 ^66 ^Number of EEOBs not collected/closed:      ^105^10^0
"RTN","IBCEMSR4",56,0)
 ;;48   ;FSWOT   ;6  ^Number of Closed EEOBs w/out tertiary:    ^45 ^10^0 ^66 ^Number of Closed EEOBs w/out tertiary:     ^105^10^0
"RTN","IBCEMSR4",57,0)
 ;;49   ;FSB     ;3  ^Total number of Denied EEOBs w/Tertiary:  ^46 ^9 ^0 ^63 ^Total number of Denied EEOBs w/Tertiary:   ^105^10^0
"RTN","IBCEMSR4",58,0)
 ;;50   ;FSSOW   ;6  ^Number Still on Worklist:                 ^41 ^14^0 ^66 ^Number Still on Worklist:                  ^101^14^0
"RTN","IBCEMSR4",59,0)
 ;;51   ;FSBXD   ;6  ^Number Processed from worklist:           ^41 ^14^0 ^66 ^Number Processed from worklist:            ^101^14^0
"RTN","IBCEMSR4",60,0)
 ;;52   ;FSBXA   ;6  ^Number Removed from worklist:             ^41 ^14^0 ^66 ^Number Removed from worklist:              ^101^14^0
"RTN","IBCEMSR4",61,0)
 ;;53   ;FSBXE   ;6  ^Number Cancelled from worklist:           ^41 ^14^0 ^66 ^Number Cancelled from worklist:            ^101^14^0
"RTN","IBCEMSR4",62,0)
 ;;54   ;FSBXB   ;6  ^Number Corrected from worklist:           ^41 ^14^0 ^66 ^Number Corrected from worklist:            ^101^14^0
"RTN","IBCEMSR4",63,0)
 ;;55   ;FSBXB1  ;9  ^Total secondary charges:                  ^41 ^14^2 ^69 ^Total secondary charges:                   ^101^14^2
"RTN","IBCEMSR4",64,0)
 ;;56   ;FSBXC   ;6  ^Number Cloned from worklist:              ^41 ^14^0 ^66 ^Number Cloned from worklist:               ^101^14^0
"RTN","IBCEMSR4",65,0)
 ;;57   ;FSBXC1  ;9  ^Total secondary charges:                  ^41 ^14^2 ^69 ^Total secondary charges:                   ^101^14^2
"RTN","IBCEMSR4",66,0)
 ;;END
"RTN","IBCEMSR4",67,0)
 Q
"RTN","IBCEMSR4",68,0)
 ;
"RTN","IBCEMSR4",69,0)
SFORM  ; Summary FORM Setup
"RTN","IBCEMSR4",70,0)
 ;;LINE#;IBACCUM ;TAB^LABEL                                     ^TAB^$J^#D^TAB^LABEL                                      ^TAB^$J^#D
"RTN","IBCEMSR4",71,0)
 ;;1    ;        ;3  ^Primary UB04 Claim EEOBs                  ^41 ^  ^  ^63 ^Primary CMS-1500 Claim EEOBs               ^101^  ^
"RTN","IBCEMSR4",72,0)
 ;;2    ;        ;3  ^--------------------------                ^41 ^  ^  ^63 ^-----------------------------              ^101^  ^
"RTN","IBCEMSR4",73,0)
 ;;3    ;SPA     ;3  ^Total number of EEOBs received:           ^41 ^14^0 ^63 ^Total number of EEOBs received:            ^101^14^0
"RTN","IBCEMSR4",74,0)
 ;;4    ;SPACL   ;3  ^Number of unique EEOBs received:          ^41 ^14^0 ^63 ^Number of unique EEOBs received:           ^101^14^0
"RTN","IBCEMSR4",75,0)
 ;;5    ;SPAA    ;6  ^% Processed:                              ^41 ^15^  ^66 ^% Processed:                               ^101^15^
"RTN","IBCEMSR4",76,0)
 ;;6    ;SPAB    ;6  ^% of Processed auto-processed to 2ndary:  ^46 ^10^  ^66 ^% of Processed auto-processed to 2ndary:   ^106^10^
"RTN","IBCEMSR4",77,0)
 ;;7    ;SPAC    ;6  ^Number of Processed EEOBs:                ^41 ^14^0 ^66 ^Number of Processed EEOBs:                 ^101^14^0
"RTN","IBCEMSR4",78,0)
 ;;8    ;SPACA   ;9  ^Number Auto-processed to 2ndary:          ^42 ^13^0 ^69 ^Number Auto-processed to 2ndary:           ^110^5 ^0
"RTN","IBCEMSR4",79,0)
 ;;9    ;SPACAA  ;12 ^Number Printed locally:                   ^41 ^14^0 ^72 ^Number Printed locally:                    ^101^14^0
"RTN","IBCEMSR4",80,0)
 ;;10   ;SPACAA1 ;15 ^Total secondary charges:                  ^41 ^14^2 ^75 ^Total secondary charges:                   ^101^14^2
"RTN","IBCEMSR4",81,0)
 ;;11   ;SPACAB  ;12 ^Number Transmitted:                       ^41 ^14^0 ^72 ^Number Transmitted:                        ^101^14^0
"RTN","IBCEMSR4",82,0)
 ;;12   ;SPACAB1 ;15 ^Total secondary charges:                  ^41 ^14^2 ^75 ^Total secondary charges:                   ^101^14^2
"RTN","IBCEMSR4",83,0)
 ;;13   ;SPACB   ;9  ^Number Manually Processed to 2ndary:      ^50 ^5 ^0 ^69 ^Number Manually Processed to 2ndary:       ^110^5 ^0
"RTN","IBCEMSR4",84,0)
 ;;14   ;SPACBA  ;12 ^Number Printed locally:                   ^41 ^14^0 ^72 ^Number Printed locally:                    ^101^14^0
"RTN","IBCEMSR4",85,0)
 ;;15   ;SPACBA1 ;15 ^Total secondary charges:                  ^41 ^14^2 ^75 ^Total secondary charges:                   ^101^14^2
"RTN","IBCEMSR4",86,0)
 ;;16   ;SPACBB  ;12 ^Number Transmitted:                       ^41 ^14^0 ^72 ^Number Transmitted:                        ^101^14^0
"RTN","IBCEMSR4",87,0)
 ;;17   ;SPACBB1 ;15 ^Total secondary charges:                  ^41 ^14^2 ^75 ^Total secondary charges:                   ^101^14^2
"RTN","IBCEMSR4",88,0)
 ;;18   ;SPNCC   ;9  ^Number of EEOBs not collected/closed:     ^50 ^5 ^0 ^69 ^Number of EEOBs not collected/closed:      ^110^5 ^0
"RTN","IBCEMSR4",89,0)
 ;;19   ;SPWOS   ;9  ^Number of Closed EEOBs w/out 2ndary:      ^50 ^5 ^0 ^69 ^Number of Closed EEOBs w/out 2ndary:       ^110^5 ^0
"RTN","IBCEMSR4",90,0)
 ;;20   ;SPABD   ;9  ^Number of EEOBs Still on worklist:        ^50 ^5 ^0 ^69 ^Number of EEOBs Still on worklist:         ^110^5 ^0
"RTN","IBCEMSR4",91,0)
 ;;21   ;SPAD    ;6  ^Number of Denied EEOBs:                   ^41 ^14^0 ^66 ^Number of Denied EEOBS:                    ^101^14^0
"RTN","IBCEMSR4",92,0)
 ;;22   ;        ;3  ^                                          ^41 ^  ^  ^   ^                                           ^101^  ^
"RTN","IBCEMSR4",93,0)
 ;;23   ;        ;3  ^Secondary UB04 Claim EEOBs                ^41 ^  ^  ^63 ^Secondary CMS-1500 Claim EEOBs             ^101^  ^
"RTN","IBCEMSR4",94,0)
 ;;24   ;        ;3  ^--------------------------                ^41 ^  ^  ^63 ^   -----------------------------           ^101^  ^
"RTN","IBCEMSR4",95,0)
 ;;25   ;SSA     ;3  ^Total number of EEOBs received:           ^41 ^14^0 ^63 ^Total number of EEOBs received:            ^101^14^0
"RTN","IBCEMSR4",96,0)
 ;;26   ;SSACL   ;3  ^Number of unique EEOBs received:          ^41 ^14^0 ^63 ^Number of unique EEOBs received:           ^101^14^0
"RTN","IBCEMSR4",97,0)
 ;;27   ;SSAA    ;6  ^% Processed:                              ^41 ^15^  ^66 ^% Processed:                               ^101^15^
"RTN","IBCEMSR4",98,0)
 ;;28   ;SSAB    ;6  ^% of Processed auto-processed to tertiary:^49 ^7 ^  ^66 ^% of Processed auto-processed to tertiary: ^110^6 ^
"RTN","IBCEMSR4",99,0)
 ;;29   ;SSAC    ;6  ^Number of Processed EEOBs:                ^41 ^14^0 ^66 ^Number of Processed EEOBs:                 ^101^14^0
"RTN","IBCEMSR4",100,0)
 ;;30   ;SSACA   ;9  ^Number Auto-processed to tertiary:        ^44 ^11^0 ^69 ^Number Auto-processed to tertiary:         ^110^5 ^0
"RTN","IBCEMSR4",101,0)
 ;;31   ;SSACAA  ;12 ^Number Printed locally:                   ^41 ^14^0 ^72 ^Number Printed locally:                    ^101^14^0
"RTN","IBCEMSR4",102,0)
 ;;32   ;SSACAA1 ;15 ^Total tertiary charges:                   ^41 ^14^2 ^75 ^Total tertiary charges:                    ^101^14^2
"RTN","IBCEMSR4",103,0)
 ;;33   ;SSACAB  ;12 ^Number Transmitted:                       ^41 ^14^0 ^72 ^Number Transmitted:                        ^101^14^0
"RTN","IBCEMSR4",104,0)
 ;;34   ;SSACAB1 ;15 ^Total tertiary charges:                   ^41 ^14^2 ^75 ^Total tertiary charges:                    ^101^14^2
"RTN","IBCEMSR4",105,0)
 ;;35   ;SSADA   ;9  ^Number Manually Processed to tertiary:    ^50 ^5 ^0 ^69 ^Number Manually Processed to tertiary:     ^110^5 ^0
"RTN","IBCEMSR4",106,0)
 ;;36   ;SSADAA  ;12 ^Number Printed locally:                   ^41 ^14^0 ^72 ^Number Printed locally:                    ^101^14^0
"RTN","IBCEMSR4",107,0)
 ;;37   ;SSADAA1 ;15 ^Total tertiary charges:                   ^41 ^14^2 ^75 ^Total tertiary charges:                    ^101^14^2
"RTN","IBCEMSR4",108,0)
 ;;38   ;SSADAB  ;12 ^Number Transmitted:                       ^41 ^14^0 ^72 ^Number Transmitted:                        ^101^14^0
"RTN","IBCEMSR4",109,0)
 ;;39   ;SSADAB1 ;15 ^Total tertiary charges:                   ^41 ^14^2 ^75 ^Total tertiary charges:                    ^101^14^2
"RTN","IBCEMSR4",110,0)
 ;;40   ;SSNCC   ;9  ^Number of EEOBs not collected/closed:     ^50 ^5 ^0 ^69 ^Number of EEOBs not collected/closed:      ^110^5 ^0
"RTN","IBCEMSR4",111,0)
 ;;41   ;SSWOT   ;9  ^Number of Closed EEOBs w/out tertiary:    ^50 ^5 ^0 ^69 ^Number of Closed EEOBs w/out tertiary:     ^110^5 ^0
"RTN","IBCEMSR4",112,0)
 ;;42   ;SSABD   ;9  ^Number of EEOBs Still on worklist:        ^50 ^5 ^0 ^69 ^Number of EEOBs Still on worklist:         ^110^5 ^0
"RTN","IBCEMSR4",113,0)
 ;;43   ;SSAD    ;6  ^Number of Denied EEOBs:                   ^41 ^14^0 ^66 ^Number of Denied EEOBS:                    ^101^14^0
"RTN","IBCEMSR4",114,0)
 ;;END
"RTN","IBCEMSR4",115,0)
 Q
"RTN","IBCEMSR5")
0^67^B7131681
"RTN","IBCEMSR5",1,0)
IBCEMSR5  ;BI/ALB - non-MRA PRODUCTIVITY REPORT ;02/14/11
"RTN","IBCEMSR5",2,0)
 ;;2.0;INTEGRATED BILLING;**447**;21-MAR-94;Build 80
"RTN","IBCEMSR5",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCEMSR5",4,0)
 ;
"RTN","IBCEMSR5",5,0)
 Q
"RTN","IBCEMSR5",6,0)
 ;
"RTN","IBCEMSR5",7,0)
CALCPCT  ; Calculate final percentages for the Summary Report
"RTN","IBCEMSR5",8,0)
 N IBDIV,IBACCUM,IBFT,IBPERCENT
"RTN","IBCEMSR5",9,0)
 S IBDIV=""
"RTN","IBCEMSR5",10,0)
 F  S IBDIV=$O(IBLTMP(IBDIV)) Q:IBDIV=""  D
"RTN","IBCEMSR5",11,0)
 . F IBACCUM="SPAA","SPAB","SSAA","SSAB" F IBFT=2,3 D
"RTN","IBCEMSR5",12,0)
 .. S IBLTMP(IBDIV,IBACCUM,IBFT)="0%"
"RTN","IBCEMSR5",13,0)
 . F IBFT=2,3 D
"RTN","IBCEMSR5",14,0)
 .. I +$G(IBLTMP(IBDIV,"SPA",IBFT)) D
"RTN","IBCEMSR5",15,0)
 ... S IBPERCENT=$G(IBLTMP(IBDIV,"SPAC",IBFT))*100/IBLTMP(IBDIV,"SPACL",IBFT)
"RTN","IBCEMSR5",16,0)
 ... S IBLTMP(IBDIV,"SPAA",IBFT)=$S(((IBPERCENT>0)&(IBPERCENT<1)):"<1",1:$J(IBPERCENT,0,0))_"%"
"RTN","IBCEMSR5",17,0)
 ... S IBPERCENT=$G(IBLTMP(IBDIV,"SPACA",IBFT))*100/IBLTMP(IBDIV,"SPACL",IBFT)
"RTN","IBCEMSR5",18,0)
 ... S IBLTMP(IBDIV,"SPAB",IBFT)=$S(((IBPERCENT>0)&(IBPERCENT<1)):"<1",1:$J(IBPERCENT,0,0))_"%"
"RTN","IBCEMSR5",19,0)
 .. I +$G(IBLTMP(IBDIV,"SSA",IBFT)) D
"RTN","IBCEMSR5",20,0)
 ... S IBPERCENT=$G(IBLTMP(IBDIV,"SSAC",IBFT))*100\IBLTMP(IBDIV,"SSACL",IBFT)
"RTN","IBCEMSR5",21,0)
 ... S IBLTMP(IBDIV,"SSAA",IBFT)=$S(((IBPERCENT>0)&(IBPERCENT<1)):"<1",1:$J(IBPERCENT,0,0))_"%"
"RTN","IBCEMSR5",22,0)
 ... S IBPERCENT=$G(IBLTMP(IBDIV,"SSACA",IBFT))*100\IBLTMP(IBDIV,"SSACL",IBFT)
"RTN","IBCEMSR5",23,0)
 ... S IBLTMP(IBDIV,"SSAB",IBFT)=$S(((IBPERCENT>0)&(IBPERCENT<1)):"<1",1:$J(IBPERCENT,0,0))_"%"
"RTN","IBCEMSR5",24,0)
 Q
"RTN","IBCEMSR5",25,0)
 ;
"RTN","IBCEMSR5",26,0)
NOSUB(IBIFN)  ; Check for subsequent payer or balance due.
"RTN","IBCEMSR5",27,0)
 N IBPY,IBOAM,IBX,IBTXT
"RTN","IBCEMSR5",28,0)
 I $P($$BILL^RCJIBFN2(IBIFN),U,2)=22 D
"RTN","IBCEMSR5",29,0)
 . S IBPY=$$TPR^PRCAFN(IBIFN)             ; payment on this bill from A/R  IA#380
"RTN","IBCEMSR5",30,0)
 . S IBOAM=+$G(^DGCR(399,IBIFN,"U1"))     ; total charges for bill
"RTN","IBCEMSR5",31,0)
 . S IBX=$$EOB^IBCNSBL2(IBIFN,IBOAM,IBPY,.IBTXT)
"RTN","IBCEMSR5",32,0)
 Q '$D(IBTXT)
"RTN","IBCEMSR5",33,0)
 ;
"RTN","IBCEMSR5",34,0)
PROCSSED(IBIFN) ;CLAIM/BILL Requests Processed?
"RTN","IBCEMSR5",35,0)
 ; Search dictionary 361.1 for this CLAIM/BILL#
"RTN","IBCEMSR5",36,0)
 ; If at least one request is 'processed' the CLAIM/BILL is considered processed.
"RTN","IBCEMSR5",37,0)
 N IBPSD,IEN,IBZ
"RTN","IBCEMSR5",38,0)
 S IBPSD=0
"RTN","IBCEMSR5",39,0)
 S IEN=0 F  S IEN=$O(^IBM(361.1,"B",+$G(IBIFN),IEN)) Q:'IEN  D  Q:IBPSD
"RTN","IBCEMSR5",40,0)
 . S IBZ=$G(^IBM(361.1,IEN,0))
"RTN","IBCEMSR5",41,0)
 . I $P(IBZ,U,4)'=0 Q  ; Scan for only Normal EOBs (Non-MRA)
"RTN","IBCEMSR5",42,0)
 . I $P(IBZ,U,13)=1 S IBPSD=1
"RTN","IBCEMSR5",43,0)
 Q IBPSD
"RTN","IBCEMSR5",44,0)
 ;
"RTN","IBCEMSR5",45,0)
DENIED(IBIFN) ;CLAIM/BILL Requests Denied?
"RTN","IBCEMSR5",46,0)
 ; Search dictionary 361.1 for this CLAIM/BILL#
"RTN","IBCEMSR5",47,0)
 ; If all request are 'denied' the CLAIM/BILL is considered denied.
"RTN","IBCEMSR5",48,0)
 N IBDEN,IEN,IBZ
"RTN","IBCEMSR5",49,0)
 S IBDEN=1
"RTN","IBCEMSR5",50,0)
 S IEN=0 F  S IEN=$O(^IBM(361.1,"B",+$G(IBIFN),IEN)) Q:'IEN  D  Q:'IBDEN
"RTN","IBCEMSR5",51,0)
 . S IBZ=$G(^IBM(361.1,IEN,0))
"RTN","IBCEMSR5",52,0)
 . I $P(IBZ,U,4)'=0 Q  ; Scan for only Normal EOBs (Non-MRA)
"RTN","IBCEMSR5",53,0)
 . I $P(IBZ,U,13)'=2 S IBDEN=0
"RTN","IBCEMSR5",54,0)
 Q IBDEN
"RTN","IBCEMU4")
0^17^B29651910
"RTN","IBCEMU4",1,0)
IBCEMU4 ;ALB/ESG - MRA UTILITIES ;25-OCT-2004
"RTN","IBCEMU4",2,0)
 ;;2.0;INTEGRATED BILLING;**288,432,447**;21-MAR-94;Build 80
"RTN","IBCEMU4",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCEMU4",4,0)
 ;
"RTN","IBCEMU4",5,0)
 Q
"RTN","IBCEMU4",6,0)
 ;
"RTN","IBCEMU4",7,0)
DENDUP(IBEOB,IBMRANOT) ; Denied for Duplicate Function ;WCJ IB*2.0*432
"RTN","IBCEMU4",8,0)
 ; Function returns true if MRA is Denied AND Reason code 18 is present (Duplicate claim/service)
"RTN","IBCEMU4",9,0)
 NEW IBX,IBM,LINE,DUP,ADJ
"RTN","IBCEMU4",10,0)
 S IBX=0,IBM=$G(^IBM(361.1,+$G(IBEOB),0))
"RTN","IBCEMU4",11,0)
 I '$G(IBMRANOT),$P(IBM,U,4)'=1 G DENDUPX    ; not an MRA  ;WCJ IB*2.0*432
"RTN","IBCEMU4",12,0)
 I $G(IBMRANOT),$P(IBM,U,4)'=0 G DENDUPX    ; not an EOB ;WCJ IB*2.0*432
"RTN","IBCEMU4",13,0)
 I $P(IBM,U,13)'=2 G DENDUPX   ; not Denied
"RTN","IBCEMU4",14,0)
 ;
"RTN","IBCEMU4",15,0)
 ; check line item adjustments for reason code 18
"RTN","IBCEMU4",16,0)
 S LINE=0,DUP=0
"RTN","IBCEMU4",17,0)
 F  S LINE=$O(^IBM(361.1,IBEOB,15,LINE)) Q:'LINE  D  Q:DUP
"RTN","IBCEMU4",18,0)
 . S ADJ=0
"RTN","IBCEMU4",19,0)
 . F  S ADJ=$O(^IBM(361.1,IBEOB,15,LINE,1,ADJ)) Q:'ADJ  D  Q:DUP
"RTN","IBCEMU4",20,0)
 .. I $D(^IBM(361.1,IBEOB,15,LINE,1,ADJ,1,"B",18)) S DUP=1 Q
"RTN","IBCEMU4",21,0)
 .. Q
"RTN","IBCEMU4",22,0)
 . Q
"RTN","IBCEMU4",23,0)
 ;
"RTN","IBCEMU4",24,0)
 I DUP S IBX=1
"RTN","IBCEMU4",25,0)
DENDUPX ;
"RTN","IBCEMU4",26,0)
 Q IBX
"RTN","IBCEMU4",27,0)
 ;
"RTN","IBCEMU4",28,0)
 ; the remaining functions are all new w/ IB*2.0*447 and have to do with calculating
"RTN","IBCEMU4",29,0)
 ; different amounts based on percentages stored in the effective date multiple of
"RTN","IBCEMU4",30,0)
 ; the TYPE OF PLAN file (#355.1) for Medicare Supplemental plans
"RTN","IBCEMU4",31,0)
 ;
"RTN","IBCEMU4",32,0)
MSPRE(IBIFN,IBEXF,IBTYPLAN) ; Medicare supplemental PR and Excess calculations
"RTN","IBCEMU4",33,0)
 ; determine PR amount in order to calculate balance due after medicare for secondary/tertiary
"RTN","IBCEMU4",34,0)
 ; if type of plan is a Medicare supplemental or EGHP plan secondary to Medicare, PR 
"RTN","IBCEMU4",35,0)
 ; calculations are determined based on the effective date multiple in the TYPE OF PLAN file
"RTN","IBCEMU4",36,0)
 ; and may or may not included Excess charges (CO-45), based on Plan Type.
"RTN","IBCEMU4",37,0)
 ; need to pass in:
"RTN","IBCEMU4",38,0)
 ;  IBIFN (REQUIRED) = claim ien
"RTN","IBCEMU4",39,0)
 ;  IBEXF = Excess Flag, set to 1 if NOT to include excess charges in calculation but to
"RTN","IBCEMU4",40,0)
 ;          return "e" (IBE) for excess indicator if plan allows excess and there are 
"RTN","IBCEMU4",41,0)
 ;          excess charges.  Used by PR column of MRW screen to show PR without excess
"RTN","IBCEMU4",42,0)
 ;          amounts included in calculation.
"RTN","IBCEMU4",43,0)
 ;  IBTYPLAN = ien in TYPE OF PLAN file (355.1)
"RTN","IBCEMU4",44,0)
 ;  returns "" if no effective date for type of plan to calculate on
"RTN","IBCEMU4",45,0)
 ;
"RTN","IBCEMU4",46,0)
 N IBFRMTYP,IBPNCAT,IBINPAT,IBMGBD,IBEOB,LNLVL,EOBADJ,IBPCE,IBEDT,IBE,IBTOT
"RTN","IBCEMU4",47,0)
 Q:$G(IBIFN)="" ""
"RTN","IBCEMU4",48,0)
 S:$G(IBTYPLAN)="" IBTYPLAN=$$TYPLN(IBIFN)
"RTN","IBCEMU4",49,0)
 S IBEDT=$$MSEDT(IBIFN,IBTYPLAN) Q:IBEDT="" ""
"RTN","IBCEMU4",50,0)
 S IBINPAT=$$INPAT^IBCEF(IBIFN)     ;Inpat/Outpat Flag
"RTN","IBCEMU4",51,0)
 S IBFRMTYP=$P($G(^DGCR(399,IBIFN,0)),U,19)  ; Form Type 2=1500, 3=UB
"RTN","IBCEMU4",52,0)
 ; plan category - PART A is Inpatient Institutional, B is all Outpatient and Inpatient Professional
"RTN","IBCEMU4",53,0)
 S IBPNCAT="B"
"RTN","IBCEMU4",54,0)
 I IBINPAT=1,IBFRMTYP=3 S IBPNCAT="A" Q:IBPNCAT="" ""
"RTN","IBCEMU4",55,0)
 ; Medicare supplemental plan  Offset amount = total charges - what medicare secondary plan will pay
"RTN","IBCEMU4",56,0)
 ; so balance due = whatever medicare secondary will pay
"RTN","IBCEMU4",57,0)
 ;
"RTN","IBCEMU4",58,0)
 ; plan category - PART A =1st piece of AEDT Index, B =2nd
"RTN","IBCEMU4",59,0)
 S IBPCE=$S(IBPNCAT="B":2,1:1)
"RTN","IBCEMU4",60,0)
 S IBMGBD=0,IBEOB=0
"RTN","IBCEMU4",61,0)
 F  S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB  D
"RTN","IBCEMU4",62,0)
 .N I
"RTN","IBCEMU4",63,0)
 .F I=0,1,2 S IBEOB(I)=$G(^IBM(361.1,IBEOB,I))
"RTN","IBCEMU4",64,0)
 .I $P(IBEOB(0),U,4)'=1 Q  ;make sure it's an MRA
"RTN","IBCEMU4",65,0)
 .;
"RTN","IBCEMU4",66,0)
 .; Handle CMS-1500 Form Type and UB Outpatient:
"RTN","IBCEMU4",67,0)
 .I IBFRMTYP=2!('IBINPAT) D  Q
"RTN","IBCEMU4",68,0)
 ..; calculate Medicare unpaid amount from line-level (outpatient)
"RTN","IBCEMU4",69,0)
 ..S LNLVL=0 F  S LNLVL=$O(^IBM(361.1,IBEOB,15,LNLVL)) Q:'LNLVL  D  ;
"RTN","IBCEMU4",70,0)
 ...K EOBADJ
"RTN","IBCEMU4",71,0)
 ...M EOBADJ=^IBM(361.1,IBEOB,15,LNLVL,1)
"RTN","IBCEMU4",72,0)
 ...; Total up the Medicare Contract Adjustment across ALL Service Lines to find
"RTN","IBCEMU4",73,0)
 ...; Medicare supplemental Balance Due
"RTN","IBCEMU4",74,0)
 ...S IBTOT=$$CALC(.EOBADJ,IBTYPLAN,IBPCE,IBEDT,$G(IBEXF)),IBE=$P(IBTOT,U,2)
"RTN","IBCEMU4",75,0)
 ...S IBMGBD=$G(IBMGBD)+$P(IBTOT,U)
"RTN","IBCEMU4",76,0)
 .;
"RTN","IBCEMU4",77,0)
 .; Handle Inpatient UB Form Type Next:  Calculate from Claim level data
"RTN","IBCEMU4",78,0)
 .K EOBADJ
"RTN","IBCEMU4",79,0)
 .M EOBADJ=^IBM(361.1,IBEOB,10)
"RTN","IBCEMU4",80,0)
 .S IBTOT=$$CALC(.EOBADJ,IBTYPLAN,IBPCE,IBEDT,$G(IBEXF)),IBE=$P(IBTOT,U,2)
"RTN","IBCEMU4",81,0)
 .S IBMGBD=$G(IBMGBD)+$P(IBTOT,U)
"RTN","IBCEMU4",82,0)
 Q IBMGBD_$G(IBE)
"RTN","IBCEMU4",83,0)
 ;
"RTN","IBCEMU4",84,0)
CALC(EOBADJ,IBTYPLAN,IBPCE,IBEDT,IBEXF) ; FUNCTION - Calculate Medicare Supplemental Balance due
"RTN","IBCEMU4",85,0)
 ; Sums up Amounts on ALL Reason Codes under ALL Group Codes = 'PR' and CO/Reason code=45.
"RTN","IBCEMU4",86,0)
 ; If those reason codes have an entry in the effective date mutliple, multiples that
"RTN","IBCEMU4",87,0)
 ; reason amount by the % the Type of plan will pay.  If no entry, assume 100% payment for PR.
"RTN","IBCEMU4",88,0)
 ; any other Group and reason codes would be 0%. 
"RTN","IBCEMU4",89,0)
 ; Adds up all those sums and returns that value as the total PR&CO the Medicare 
"RTN","IBCEMU4",90,0)
 ; Supplemental plan will pay.
"RTN","IBCEMU4",91,0)
 ;
"RTN","IBCEMU4",92,0)
 ; Input  EOBADJ = Array of Group Codes & Reason Codes from either the Claim 
"RTN","IBCEMU4",93,0)
 ;                 Level (10) or Service Line Level (15) of EOB file (#361.1)
"RTN","IBCEMU4",94,0)
 ; IBTYPLAN = ien in TYPE OF PLAN file 
"RTN","IBCEMU4",95,0)
 ; IBPCE = 2 for PART A, 3 for PART B - REQUIRED
"RTN","IBCEMU4",96,0)
 ; IBEDT = effective date of plan rates 
"RTN","IBCEMU4",97,0)
 ; IBEXF = Excess Flag, set to 1 if NOT to include excess charges in calculation but to
"RTN","IBCEMU4",98,0)
 ;          return "e" for excess indicator if plan allows excess and there are excess 
"RTN","IBCEMU4",99,0)
 ;          charges.   Used by PR column of MRW screen to show PR without excess
"RTN","IBCEMU4",100,0)
 ;          amounts included in calculation.
"RTN","IBCEMU4",101,0)
 ; Output  amount that Medicare supplemental plan will pay
"RTN","IBCEMU4",102,0)
 ;
"RTN","IBCEMU4",103,0)
 N GRPLVL,RSNLVL,RSNAMT,MCA,GRPCD,RSNCD,RSN0,CALC,IBIND
"RTN","IBCEMU4",104,0)
 Q:$G(IBPCE)="" ""
"RTN","IBCEMU4",105,0)
 S:$G(IBTYPLAN)="" IBTYPLAN=$$TYPLN(IBIFN)
"RTN","IBCEMU4",106,0)
 I $G(IBEDT)="" S IBEDT=$$MSEDT(IBIFN,IBTYPLAN) Q:IBEDT="" ""
"RTN","IBCEMU4",107,0)
 S (GRPLVL,MCA)=0
"RTN","IBCEMU4",108,0)
 F  S GRPLVL=$O(EOBADJ(GRPLVL)) Q:'GRPLVL  D 
"RTN","IBCEMU4",109,0)
 .S GRPCD=$P($G(EOBADJ(GRPLVL,0)),U)
"RTN","IBCEMU4",110,0)
 .; For now they want to calculate all PR but only apply %age calcs to PR-1,2 & 3 
"RTN","IBCEMU4",111,0)
 .I GRPCD'="PR" Q:'$D(^IBE(355.1,IBTYPLAN,14,"AEDT",IBEDT,GRPCD))
"RTN","IBCEMU4",112,0)
 .S RSNLVL=0
"RTN","IBCEMU4",113,0)
 .F  S RSNLVL=$O(EOBADJ(GRPLVL,1,RSNLVL)) Q:'RSNLVL  D  ;
"RTN","IBCEMU4",114,0)
 ..S RSN0=$G(EOBADJ(GRPLVL,1,RSNLVL,0)),RSNAMT=$P(RSN0,U,2),RSNCD=$P(RSN0,U)
"RTN","IBCEMU4",115,0)
 ..I GRPCD="PR",RSNCD="AAA" Q  ; ignore PR-AAA
"RTN","IBCEMU4",116,0)
 ..; For now they want to calculate all PR but only apply %age calcs to PR-1,2 & 3
"RTN","IBCEMU4",117,0)
 ..I GRPCD="PR","1^2^3"'[RSNCD,'$D(^IBE(355.1,IBTYPLAN,14,"AEDT",IBEDT,GRPCD,RSNCD)) S MCA=MCA+RSNAMT Q
"RTN","IBCEMU4",118,0)
 ..Q:'$D(^IBE(355.1,IBTYPLAN,14,"AEDT",IBEDT,GRPCD,RSNCD))
"RTN","IBCEMU4",119,0)
 ..; if there is an entry in the effective date multiple for this grp/rsn code use it to calculate amount for PART A and B.
"RTN","IBCEMU4",120,0)
 ..; for MRW, don't add up excess charges if IBEXF=1, just send back an "e" indicator to alert user of excess  
"RTN","IBCEMU4",121,0)
 ..I $G(IBEXF)=1,GRPCD="CO",RSNCD=45,$P($G(^IBE(355.1,IBTYPLAN,14,"AEDT",IBEDT,GRPCD,RSNCD)),U,IBPCE)>0 S IBIND="e" Q
"RTN","IBCEMU4",122,0)
 ..S CALC=$P($G(^IBE(355.1,IBTYPLAN,14,"AEDT",IBEDT,GRPCD,RSNCD)),U,IBPCE)/100
"RTN","IBCEMU4",123,0)
 ..S MCA=MCA+(RSNAMT*CALC)
"RTN","IBCEMU4",124,0)
 Q MCA_U_$G(IBIND)
"RTN","IBCEMU4",125,0)
 ;
"RTN","IBCEMU4",126,0)
MSEDT(IBIFN,IBTYPLAN) ; does this claim's TYPE OF PLAN have an effective date multiple on or before the
"RTN","IBCEMU4",127,0)
 ; claim 'statement covers from' date
"RTN","IBCEMU4",128,0)
 ; IBIFN = claim ien - REQUIRED
"RTN","IBCEMU4",129,0)
 ; IBTYPLAN = Type of Plan ien
"RTN","IBCEMU4",130,0)
 ; returns eff.date calculation multiple to use or null
"RTN","IBCEMU4",131,0)
 ; called from SKIP^IBCCCB, BLD^IBCECOB1, TOT^IBCECOB2, CRIT^IBCEMQC, & SECOND^IBCEMSR
"RTN","IBCEMU4",132,0)
 ;
"RTN","IBCEMU4",133,0)
 ; IB*2.0*447:  the below quit statement has been added because CBO has decided not to implement
"RTN","IBCEMU4",134,0)
 ; these changes with patch 447 after all.  Once a long-term maintenance plan for the plan type
"RTN","IBCEMU4",135,0)
 ; calculations can be worked out and CBO is ready to implement the special calculations, the
"RTN","IBCEMU4",136,0)
 ; below quit statement and these comments should be removed and the type of plan special calculations 
"RTN","IBCEMU4",137,0)
 ; will immediately take effect.  For now, returning a null will allow existing code to bypass 
"RTN","IBCEMU4",138,0)
 ; the special calculation table in file 355.1 and calculate everything as 100% of Patient Responsibility (PR).
"RTN","IBCEMU4",139,0)
 Q ""
"RTN","IBCEMU4",140,0)
 ;
"RTN","IBCEMU4",141,0)
 N IBSVDT
"RTN","IBCEMU4",142,0)
 Q:$G(IBIFN)="" ""
"RTN","IBCEMU4",143,0)
 S:$G(IBTYPLAN)="" IBTYPLAN=+$$TYPLN(IBIFN)
"RTN","IBCEMU4",144,0)
 S IBSVDT=+$P($G(^DGCR(399,IBIFN,"U")),U)
"RTN","IBCEMU4",145,0)
 Q:$D(^IBE(355.1,IBTYPLAN,14,"B",IBSVDT)) IBSVDT
"RTN","IBCEMU4",146,0)
 Q $O(^IBE(355.1,IBTYPLAN,14,"B",IBSVDT),-1)
"RTN","IBCEMU4",147,0)
 ;
"RTN","IBCEMU4",148,0)
TYPLN(IBIFN) ; find type of plan for claim
"RTN","IBCEMU4",149,0)
 ; IBIFN = claim ien - REQUIRED
"RTN","IBCEMU4",150,0)
 ; returns ien from file 355.1 or null if none found
"RTN","IBCEMU4",151,0)
 ;
"RTN","IBCEMU4",152,0)
 Q:$G(IBIFN)="" ""
"RTN","IBCEMU4",153,0)
 N IBCOBN,IBGRPNO
"RTN","IBCEMU4",154,0)
 S IBCOBN=$$COBN^IBCEF(IBIFN)+1 ;find next payer
"RTN","IBCEMU4",155,0)
 S IBGRPNO=+$P($G(^DGCR(399,IBIFN,"I"_IBCOBN)),U,18) ; group plan number
"RTN","IBCEMU4",156,0)
 Q $P($G(^IBA(355.3,IBGRPNO,0)),U,9) ; type of plan - IEN
"RTN","IBCEMU4",157,0)
 ;
"RTN","IBCEP5A")
0^65^B26443385
"RTN","IBCEP5A",1,0)
IBCEP5A ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00
"RTN","IBCEP5A",2,0)
 ;;2.0;INTEGRATED BILLING;**137,232,320,348,447**;21-MAR-94;Build 80
"RTN","IBCEP5A",3,0)
 ;
"RTN","IBCEP5A",4,0)
NEW(IBPRV,IBINS) ; Add new prov id
"RTN","IBCEP5A",5,0)
 D FULL^VALM1
"RTN","IBCEP5A",6,0)
 N DIC,DIR,X,Y,DA,DO,DD,DLAYGO,IBQ,IBIEN,IBPRV0,DTOUT,DUOUT,IBIF,IBSIC
"RTN","IBCEP5A",7,0)
 S IBQ=0,IBPRV0=$S(IBPRV'["355.93":"",1:$G(^IBA(355.93,+IBPRV,0)))
"RTN","IBCEP5A",8,0)
 ;
"RTN","IBCEP5A",9,0)
 ; Only 5 secondary providers allowed for lab/facilities
"RTN","IBCEP5A",10,0)
 S IBIF=$P(IBPRV0,U,2)
"RTN","IBCEP5A",11,0)
 S IBSIC=$O(^TMP("IBPRV_",$J,"ZIDX",""),-1)
"RTN","IBCEP5A",12,0)
 I IBIF=1,IBSIC>4 D  G NEWQ
"RTN","IBCEP5A",13,0)
 . S DIR(0)="EA",DIR("A",1)="A maximum of 5 secondary IDs are allowed for a lab/facility.",DIR("A")="PRESS ENTER TO CONTINUE " D ^DIR K DIR W !
"RTN","IBCEP5A",14,0)
 ;
"RTN","IBCEP5A",15,0)
 S DIR(0)="PAr^355.97:AEMQ"
"RTN","IBCEP5A",16,0)
 S DIR("A")="Enter Provider ID Qualifier: "
"RTN","IBCEP5A",17,0)
 S DIR("?")="Enter a Qualifier to indentify the type of ID number you are entering."
"RTN","IBCEP5A",18,0)
 ;
"RTN","IBCEP5A",19,0)
 ;S DIR("S")=$S($G(IBINS):"I ""04""[+$P($G(^(0)),U,2)",1:"I +$P($G(^(1)),U,7)&'$G(^(1))&$S($P(IBPRV0,U,2)'=1:1,1:$P(^(0),U,3)'=""SY"")")
"RTN","IBCEP5A",20,0)
 I $G(IBINS) D
"RTN","IBCEP5A",21,0)
 . I $P(IBPRV0,U,2)=1 S DIR("S")="I $$LFINS^IBCEPU(Y)" Q   ; Lab or Facility ID provided by ins
"RTN","IBCEP5A",22,0)
 . S DIR("S")="I $$RAINS^IBCEPU(Y)" Q   ; Non VA Ind provided by ins
"RTN","IBCEP5A",23,0)
 I '$G(IBINS) D
"RTN","IBCEP5A",24,0)
 . I $P(IBPRV0,U,2)=1 D  Q
"RTN","IBCEP5A",25,0)
 .. I IBPRV["VA(200," S DIR("S")="I $$LFINS^IBCEPU(Y)" Q   ; VA facility own IDS
"RTN","IBCEP5A",26,0)
 .. S DIR("S")="I $$NVALFOWN^IBCEPU(Y)" Q   ; Non -VA facility own
"RTN","IBCEP5A",27,0)
 . S DIR("S")="I $$RAOWN^IBCEPU(Y)"   ; FACILITY/GROUP;PROVIDER'S OWN PERSONAL NUMBER
"RTN","IBCEP5A",28,0)
 ;
"RTN","IBCEP5A",29,0)
 D ^DIR K DIR
"RTN","IBCEP5A",30,0)
 I $D(DTOUT)!$D(DUOUT) S IBQ=1 G NEWQ
"RTN","IBCEP5A",31,0)
 I $P($G(^IBE(355.97,+Y,1)),U,3),IBPRV["355.93" D  G NEWQ
"RTN","IBCEP5A",32,0)
 . K DIE,DR
"RTN","IBCEP5A",33,0)
 . S DIE="^IBA(355.93,",DA=+IBPRV
"RTN","IBCEP5A",34,0)
 . ;S DR="S Y=""@5"";@1;.07;@5;I $P($G(^IBA(355.93,DA,0)),U,7)'="""" S Y=""@2"";W !!,""YOU MUST HAVE A STATE TO USE LICENSE # AS AN ID!!"",! S Y=""@1"";@2;W !!,""LICENSING STATE: "",$P($G(^DIC(5,+$P($G(^IBA(355.93,DA,0)),U,7),0)),U,2);.12"
"RTN","IBCEP5A",35,0)
 . ; Changed with IB*2.0*447 BI
"RTN","IBCEP5A",36,0)
 . S DR="S Y=""@5"";@1;.16;@5;I $P($G(^IBA(355.93,DA,0)),U,16)'="""" S Y=""@2"";"
"RTN","IBCEP5A",37,0)
 . S DR=DR_"W !!,""YOU MUST HAVE A LICENSE STATE TO USE LICENSE # AS AN ID!!"",! S Y=""@1"";"
"RTN","IBCEP5A",38,0)
 . S DR=DR_"@2;W !!,""LICENSING STATE: "",$P($G(^DIC(5,+$P($G(^IBA(355.93,DA,0)),U,16),0)),U,2);.12"
"RTN","IBCEP5A",39,0)
 . D ^DIE
"RTN","IBCEP5A",40,0)
 . I '$D(Y) D BLD^IBCEP5
"RTN","IBCEP5A",41,0)
 K IB3559(.06)
"RTN","IBCEP5A",42,0)
 S IB3559(.06)=+Y
"RTN","IBCEP5A",43,0)
 ;
"RTN","IBCEP5A",44,0)
 I $G(IBINS)'="NO",'$G(IBINS),'$P($G(^IBE(355.97,IB3559(.06),1)),U,8) D  G:IBQ NEWQ
"RTN","IBCEP5A",45,0)
 . S DIR(0)="PA^DIC(36,:AEMQ",DIR("A")="Select INSURANCE CO: ",DIR("?")="Select the INSURANCE CO that is furnishing you with the provider ID"
"RTN","IBCEP5A",46,0)
 . D ^DIR K DIR
"RTN","IBCEP5A",47,0)
 . I $D(DTOUT)!$D(DUOUT) S IBQ=1 Q
"RTN","IBCEP5A",48,0)
 . S IBINS=$S(Y>0:+Y,1:"")
"RTN","IBCEP5A",49,0)
 S IB3559(.02)=$S($G(IBINS):IBINS,1:"*ALL*")
"RTN","IBCEP5A",50,0)
 ;
"RTN","IBCEP5A",51,0)
 I '$P($G(^IBE(355.97,IB3559(.06),1)),U,8) D  G:'IBIEN NEWQ
"RTN","IBCEP5A",52,0)
 . S DIC(0)="L",DLAYGO=355.9,DIC="^IBA(355.9,",X=IBPRV
"RTN","IBCEP5A",53,0)
 . S:$G(IBINS) DIC("DR")=".02////"_IBINS
"RTN","IBCEP5A",54,0)
 . D FILE^DICN K DIC,DLAYGO,DD,DO
"RTN","IBCEP5A",55,0)
 . I Y'>0!$D(DUOUT)!$D(DTOUT) S IBIEN=0 Q
"RTN","IBCEP5A",56,0)
 . S IBIEN=+Y
"RTN","IBCEP5A",57,0)
 . D NEWID^IBCEP5B(355.9,IB3559(.02),IBPRV,IB3559(.06),IBIEN,1)
"RTN","IBCEP5A",58,0)
 ;
"RTN","IBCEP5A",59,0)
 E  D  ; Provider-specific id stored outside of billing
"RTN","IBCEP5A",60,0)
 . N DIR,X,Y,Z
"RTN","IBCEP5A",61,0)
 . ; State License # is stored in file 200
"RTN","IBCEP5A",62,0)
 . ; DEA# may not be edited in IB
"RTN","IBCEP5A",63,0)
 . S Z=$G(^IBE(355.97,IB3559(.06),1))
"RTN","IBCEP5A",64,0)
 . I +Z D  Q
"RTN","IBCEP5A",65,0)
 .. W ! S DIR(0)="EA",DIR("A",1)="DEA # CANNOT BE EDITED WITHIN THE BILLING SOFTWARE",DIR("A")="PRESS ENTER TO CONTINUE " D ^DIR K DIR W !
"RTN","IBCEP5A",66,0)
 . I $P(Z,U,3) D
"RTN","IBCEP5A",67,0)
 .. D PRVED(+IBPRV)
"RTN","IBCEP5A",68,0)
 D BLD^IBCEP5
"RTN","IBCEP5A",69,0)
NEWQ K VALMBCK
"RTN","IBCEP5A",70,0)
 S VALMBCK="R"
"RTN","IBCEP5A",71,0)
 Q
"RTN","IBCEP5A",72,0)
 ;
"RTN","IBCEP5A",73,0)
DEL1 ; Delete Provider specific ID's
"RTN","IBCEP5A",74,0)
 N IBDA,DA,DIE,DR
"RTN","IBCEP5A",75,0)
 D FULL^VALM1
"RTN","IBCEP5A",76,0)
 D SEL^IBCEP5(.IBDA)
"RTN","IBCEP5A",77,0)
 G:'$O(IBDA(0)) DEL1Q
"RTN","IBCEP5A",78,0)
 S IBDA=+$O(IBDA("")),IBDA=$G(IBDA(IBDA))
"RTN","IBCEP5A",79,0)
 G:'IBDA&($E($P(IBDA,U),1,3)'="LIC") DEL1Q
"RTN","IBCEP5A",80,0)
 I IBDA>0 D DEL^IBCEP5B(355.9,IBDA,""),BLD^IBCEP5
"RTN","IBCEP5A",81,0)
 E  D  ; check for state license
"RTN","IBCEP5A",82,0)
 . Q:$E($P(IBDA,U),1,3)'="LIC"
"RTN","IBCEP5A",83,0)
 . I $P(IBDA,U,2)["IBA(355.93" D
"RTN","IBCEP5A",84,0)
 .. S DA=+$P(IBDA,U,2),DR=".12///@;.16///@",DIE="^IBA(355.93," D ^DIE
"RTN","IBCEP5A",85,0)
 . E  D
"RTN","IBCEP5A",86,0)
 .. D PRVED(+$P(IBDA,U,2))
"RTN","IBCEP5A",87,0)
 . D BLD^IBCEP5
"RTN","IBCEP5A",88,0)
DEL1Q S VALMBCK="R"
"RTN","IBCEP5A",89,0)
 Q
"RTN","IBCEP5A",90,0)
 ;
"RTN","IBCEP5A",91,0)
CHG1 ; Edit Provider ID's
"RTN","IBCEP5A",92,0)
 N IBDA,DIR,DA,DIE,DR,Z
"RTN","IBCEP5A",93,0)
 D FULL^VALM1
"RTN","IBCEP5A",94,0)
 D SEL^IBCEP5(.IBDA)
"RTN","IBCEP5A",95,0)
 G:'$O(IBDA(0)) CHG1Q
"RTN","IBCEP5A",96,0)
 S IBDA=+$O(IBDA("")),IBDA=$G(IBDA(IBDA))
"RTN","IBCEP5A",97,0)
 I IBDA>0 D
"RTN","IBCEP5A",98,0)
 . D CHG^IBCEP5B(355.9,IBDA),BLD^IBCEP5
"RTN","IBCEP5A",99,0)
 ; check for state license
"RTN","IBCEP5A",100,0)
 E  D
"RTN","IBCEP5A",101,0)
 . Q:$E($P(IBDA,U),1,3)'="LIC"
"RTN","IBCEP5A",102,0)
 . I $P(IBDA,U,2)["IBA(355.93" D
"RTN","IBCEP5A",103,0)
 .. S DA=+$P(IBDA,U,2),DIE="^IBA(355.93,"
"RTN","IBCEP5A",104,0)
 .. ;S DR="S Y=""@5"";@1;.07;@5;I $P($G(^IBA(355.93,DA,0)),U,7)'="""" S Y=""@2"";W !,""YOU MUST HAVE A STATE TO USE LICENSE # AS AN ID!!"" S Y=""@1"";@2;W !!,""LICENSING STATE: "",$P($G(^DIC(5,+$P($G(^IBA(355.93,DA,0)),U,7),0)),U,2);.12"
"RTN","IBCEP5A",105,0)
 .. ; Changed with IB*2.0*447 BI
"RTN","IBCEP5A",106,0)
 .. S DR=".16;S Y=""@5"";@1;.16;@5;I $P($G(^IBA(355.93,DA,0)),U,16)'="""" S Y=""@2"";"
"RTN","IBCEP5A",107,0)
 .. S DR=DR_"W !,""YOU MUST HAVE A LICENSE STATE TO USE LICENSE # AS AN ID!!"" S Y=""@1"";@2;"
"RTN","IBCEP5A",108,0)
 .. S DR=DR_"W !!,""LICENSING STATE: "",$P($G(^DIC(5,+$P($G(^IBA(355.93,DA,0)),U,16),0)),U,2);.12"
"RTN","IBCEP5A",109,0)
 .. D ^DIE
"RTN","IBCEP5A",110,0)
 . E  D
"RTN","IBCEP5A",111,0)
 .. D PRVED(+$P(IBDA,U,2))
"RTN","IBCEP5A",112,0)
 . D BLD^IBCEP5
"RTN","IBCEP5A",113,0)
CHG1Q S VALMBCK="R"
"RTN","IBCEP5A",114,0)
 Q
"RTN","IBCEP5A",115,0)
 ;
"RTN","IBCEP5A",116,0)
PRVED(IBPRV) ; Maintain license #'s for VA provider ien IBPRV
"RTN","IBCEP5A",117,0)
 S IBPRV=IBPRV_";VA(200,"
"RTN","IBCEP5A",118,0)
 D EN^IBCEP5D
"RTN","IBCEP5A",119,0)
 Q
"RTN","IBCEP5A",120,0)
 ;
"RTN","IBCEP5A",121,0)
COPYPROV(IBINS) ; Check if any ID's were edited and this is a parent insurance company
"RTN","IBCEP5A",122,0)
 ; IBINS = IEN into Insurance co file
"RTN","IBCEP5A",123,0)
 ; 
"RTN","IBCEP5A",124,0)
 Q:'$D(^TMP("IB_EDITED_IDS",$J))
"RTN","IBCEP5A",125,0)
 K ^TMP("IB_EDITED_IDS",$J)
"RTN","IBCEP5A",126,0)
 D COPY^IBCEPCID(IBINS)
"RTN","IBCEP5A",127,0)
 Q
"RTN","IBCEP5A",128,0)
 ;
"RTN","IBCEP5A",129,0)
 ; Get the next number so that the edits can be replicated in order for other providers/insurance companies
"RTN","IBCEP5A",130,0)
NEXTONE() ;
"RTN","IBCEP5A",131,0)
 Q $O(^TMP("IB_EDITED_IDS",$J,""),-1)+1
"RTN","IBCEP8")
0^64^B124149510
"RTN","IBCEP8",1,0)
IBCEP8 ;ALB/TMP/OIFO-BP/RBN - Functions for NON-VA PROVIDER ;11-07-00
"RTN","IBCEP8",2,0)
 ;;2.0;INTEGRATED BILLING;**51,137,232,288,320,343,374,377,391,400,436,432,447**;21-MAR-94;Build 80
"RTN","IBCEP8",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCEP8",4,0)
 ;
"RTN","IBCEP8",5,0)
EN ; -- main entry point
"RTN","IBCEP8",6,0)
 N IBNPRV
"RTN","IBCEP8",7,0)
 K IBFASTXT
"RTN","IBCEP8",8,0)
 D FULL^VALM1
"RTN","IBCEP8",9,0)
 D EN^VALM("IBCE PRVNVA MAINT")
"RTN","IBCEP8",10,0)
 Q
"RTN","IBCEP8",11,0)
 ;
"RTN","IBCEP8",12,0)
HDR ; -- header code
"RTN","IBCEP8",13,0)
 K VALMHDR
"RTN","IBCEP8",14,0)
 Q
"RTN","IBCEP8",15,0)
 ;
"RTN","IBCEP8",16,0)
INIT ; Initialization
"RTN","IBCEP8",17,0)
 N DIC,DA,X,Y,DLAYGO,IBIF,DIR,DTOUT,DUOUT
"RTN","IBCEP8",18,0)
 K ^TMP("IBCE_PRVNVA_MAINT",$J)
"RTN","IBCEP8",19,0)
 ;
"RTN","IBCEP8",20,0)
 ; if coming in from main routine ^IBCEP6 this special variable IBNVPMIF is set already
"RTN","IBCEP8",21,0)
 I $G(IBNVPMIF)'="" S IBIF=IBNVPMIF G INIT1
"RTN","IBCEP8",22,0)
 ;
"RTN","IBCEP8",23,0)
 S DIR("A")="(I)NDIVIDUAL OR (F)ACILITY?: ",DIR(0)="SA^I:INDIVIDUAL;F:FACILITY" D ^DIR K DIR
"RTN","IBCEP8",24,0)
 I $D(DUOUT)!$D(DTOUT) S VALMQUIT=1 G INITQ
"RTN","IBCEP8",25,0)
 S IBIF=Y
"RTN","IBCEP8",26,0)
 ;
"RTN","IBCEP8",27,0)
INIT1 ;
"RTN","IBCEP8",28,0)
 ;
"RTN","IBCEP8",29,0)
 ; Begin IB*2.0*436 - RBN
"RTN","IBCEP8",30,0)
 ;
"RTN","IBCEP8",31,0)
 ;I IBIF="F" D
"RTN","IBCEP8",32,0)
 ;. S VALM("TITLE")="Non-VA Lab or Facility Info"
"RTN","IBCEP8",33,0)
 ;. K VALM("PROTOCOL")
"RTN","IBCEP8",34,0)
 ;. S Y=$$FIND1^DIC(101,,,"IBCE PRVNVA NONIND MAINT")
"RTN","IBCEP8",35,0)
 ;. I Y S VALM("PROTOCOL")=+Y_";ORD(101,"
"RTN","IBCEP8",36,0)
 ;
"RTN","IBCEP8",37,0)
 ; End IB*2.0*436 - RBN
"RTN","IBCEP8",38,0)
 ;
"RTN","IBCEP8",39,0)
 S DIC="^IBA(355.93,",DIC("DR")=".02///"_$S(IBIF'="F":2,1:1)
"RTN","IBCEP8",40,0)
 S DIC("S")="I $P(^(0),U,2)="_$S(IBIF'="F":2,1:1)
"RTN","IBCEP8",41,0)
 S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON"_$S(IBIF="I":"-",1:"/OTHER ")_"VA PROVIDER: "
"RTN","IBCEP8",42,0)
 D ^DIC K DIC,DLAYGO
"RTN","IBCEP8",43,0)
 I Y'>0 S VALMQUIT=1 G INITQ
"RTN","IBCEP8",44,0)
 S IBNPRV=+Y
"RTN","IBCEP8",45,0)
 ;
"RTN","IBCEP8",46,0)
 ; *** Begin IB*2.0*436 - RBN
"RTN","IBCEP8",47,0)
 ;
"RTN","IBCEP8",48,0)
 N NEWENTRY
"RTN","IBCEP8",49,0)
 S IBNPRV=+Y,NEWENTRY=$P($G(Y),U,3),IBFLPFLP=0
"RTN","IBCEP8",50,0)
 I 'NEWENTRY D
"RTN","IBCEP8",51,0)
 . N DA,X,Y,DIE,DR
"RTN","IBCEP8",52,0)
 . ;D EN^DDIOL(" ")
"RTN","IBCEP8",53,0)
 . ;D EN^DDIOL("If you do NOT want to edit the provider name or the provider type,","","!")
"RTN","IBCEP8",54,0)
 . ;D EN^DDIOL("then press return at the following NAME prompt.  Otherwise,")
"RTN","IBCEP8",55,0)
 . ;D EN^DDIOL("retype the name as you want it entered into the system.")
"RTN","IBCEP8",56,0)
 . ;D EN^DDIOL(" ")
"RTN","IBCEP8",57,0)
 . ;S DA=IBNPRV
"RTN","IBCEP8",58,0)
 . ;S DIE="^IBA(355.93,"
"RTN","IBCEP8",59,0)
 . ;S DR=".01"
"RTN","IBCEP8",60,0)
 . ;D ^DIE
"RTN","IBCEP8",61,0)
 . D SCREEN(IBNPRV)
"RTN","IBCEP8",62,0)
 . I $D(Y) S VALMQUIT=1 G INITQ
"RTN","IBCEP8",63,0)
 . I $G(IBFLPFLP) S IBIF=$S(IBIF="F":"I",1:"F")
"RTN","IBCEP8",64,0)
 ;
"RTN","IBCEP8",65,0)
 ; *** End IB*2.0*436 - rbn
"RTN","IBCEP8",66,0)
 ;
"RTN","IBCEP8",67,0)
 I IBIF="F" D
"RTN","IBCEP8",68,0)
 . S VALM("TITLE")="Non-VA Lab or Facility Info"
"RTN","IBCEP8",69,0)
 . K VALM("PROTOCOL")
"RTN","IBCEP8",70,0)
 . S Y=$$FIND1^DIC(101,,,"IBCE PRVNVA NONIND MAINT")
"RTN","IBCEP8",71,0)
 . I Y S VALM("PROTOCOL")=+Y_";ORD(101,"
"RTN","IBCEP8",72,0)
 D BLD^IBCEP8B(IBNPRV)
"RTN","IBCEP8",73,0)
INITQ Q
"RTN","IBCEP8",74,0)
 ;
"RTN","IBCEP8",75,0)
EXPND ;
"RTN","IBCEP8",76,0)
 Q
"RTN","IBCEP8",77,0)
 ;
"RTN","IBCEP8",78,0)
HELP ;
"RTN","IBCEP8",79,0)
 Q
"RTN","IBCEP8",80,0)
 ;
"RTN","IBCEP8",81,0)
EXIT ;
"RTN","IBCEP8",82,0)
 K ^TMP("IBCE_PRVNVA_MAINT",$J)
"RTN","IBCEP8",83,0)
 D CLEAN^VALM10
"RTN","IBCEP8",84,0)
 K IBFASTXT
"RTN","IBCEP8",85,0)
 Q
"RTN","IBCEP8",86,0)
 ;
"RTN","IBCEP8",87,0)
EDIT1(IBNPRV,IBNOLM) ; Edit non-VA provider/facility demographics
"RTN","IBCEP8",88,0)
 ; IBNPRV = ien of entry in file 355.93
"RTN","IBCEP8",89,0)
 ; IBNOLM = 1 if not called from list manager
"RTN","IBCEP8",90,0)
 ;
"RTN","IBCEP8",91,0)
 N DA,X,Y,DIE,DR,IBP
"RTN","IBCEP8",92,0)
 I '$G(IBNOLM) D FULL^VALM1
"RTN","IBCEP8",93,0)
 I IBNPRV D
"RTN","IBCEP8",94,0)
 . I '$G(IBNOLM) D CLEAR^VALM1
"RTN","IBCEP8",95,0)
 . S DIE="^IBA(355.93,",DA=IBNPRV,IBP=($P($G(^IBA(355.93,IBNPRV,0)),U,2)=2)
"RTN","IBCEP8",96,0)
 . ; PRXM/KJH - Added NPI and Taxonomy to the list of fields to be edited. Put a "NO^" around the Taxonomy multiple (#42) since some of the sub-field entries are 'required'.
"RTN","IBCEP8",97,0)
 . ; Begin IB*2.0*436 - RBN
"RTN","IBCEP8",98,0)
 . ;S DR=".01;"_$S(IBP:".03;.04",1:".05;.1;.06;.07;.08;.13///24;W !,""ID Qualifier: 24 - EMPLOYER'S IDENTIFICATION #"";.09Lab or Facility Primary ID;.11;.15")_";D PRENPI^IBCEP81(IBNPRV);D EN^IBCEP82(IBNPRV);S DIE(""NO^"")="""";42;K DIE(""NO^"")"
"RTN","IBCEP8",99,0)
 . ;S DR=$S(IBP:".03;.04",1:".05;.1;.06;.07;.08;.13///24;W !,""ID Qualifier: 24 - EMPLOYER'S IDENTIFICATION #"";.09Lab or Facility Primary ID;.11;.15")_";D PRENPI^IBCEP81(IBNPRV);D EN^IBCEP82(IBNPRV);S DIE(""NO^"")="""";42;K DIE(""NO^"")"
"RTN","IBCEP8",100,0)
 . ; End IB*2.0*436 - RBN
"RTN","IBCEP8",101,0)
 . ;IB*2.0*432 - add contact phone and name
"RTN","IBCEP8",102,0)
 . S DR=$S(IBP:".03;.04",1:".05;.1;.06;.07;.08;1.01;I X="""" S Y=""@2"";1.02R;S Y=""@3"";@2;1.02;@3;1.03;.13///24;W !,""ID Qualifier: 24 - EMPLOYER'S IDENTIFICATION #"";.09Lab or Facility Primary ID;.11;.15")
"RTN","IBCEP8",103,0)
 . S DR=DR_";D PRENPI^IBCEP81(IBNPRV);D EN^IBCEP82(IBNPRV);S DIE(""NO^"")="""";42;K DIE(""NO^"")"
"RTN","IBCEP8",104,0)
 . D ^DIE
"RTN","IBCEP8",105,0)
 . Q:$G(IBNOLM)
"RTN","IBCEP8",106,0)
 . D BLD^IBCEP8B(IBNPRV)
"RTN","IBCEP8",107,0)
 I '$G(IBNOLM) K VALMBCK S VALMBCK="R"
"RTN","IBCEP8",108,0)
 Q
"RTN","IBCEP8",109,0)
 ;
"RTN","IBCEP8",110,0)
EDITID(IBNPRV,IBSLEV) ; Link from this list template to maintain provider-specific ids
"RTN","IBCEP8",111,0)
 ; This entry point is called by 4 action protocols.
"RTN","IBCEP8",112,0)
 ; IBNPRV = ien of entry in file 355.93 (can be either an individual or a facility) (required)
"RTN","IBCEP8",113,0)
 ; IBSLEV = 1 for facility/provider own ID's
"RTN","IBCEP8",114,0)
 ; IBSLEV = 2 for facility/provider ID's furnished by an insurance company
"RTN","IBCEP8",115,0)
 ;
"RTN","IBCEP8",116,0)
 Q:'$G(IBNPRV)
"RTN","IBCEP8",117,0)
 Q:'$G(IBSLEV)
"RTN","IBCEP8",118,0)
 N IBPRV,IBIF
"RTN","IBCEP8",119,0)
 D FULL^VALM1    ; set full scrolling region
"RTN","IBCEP8",120,0)
 D CLEAR^VALM1   ; clear screen
"RTN","IBCEP8",121,0)
 S IBPRV=IBNPRV
"RTN","IBCEP8",122,0)
 ;
"RTN","IBCEP8",123,0)
 K IBFASTXT
"RTN","IBCEP8",124,0)
 S IBIF=$$GET1^DIQ(355.93,IBPRV,.02,"I")    ; 1=facility/group      2=individual
"RTN","IBCEP8",125,0)
 D EN^VALM("IBCE PRVPRV MAINT")
"RTN","IBCEP8",126,0)
 ;
"RTN","IBCEP8",127,0)
 K VALMQUIT
"RTN","IBCEP8",128,0)
 S VALMBCK=$S($G(IBFASTXT)'="":"Q",1:"R")
"RTN","IBCEP8",129,0)
 Q
"RTN","IBCEP8",130,0)
 ;
"RTN","IBCEP8",131,0)
NVAFAC ; Enter/edit Non-VA facility information
"RTN","IBCEP8",132,0)
 ; This entry point is called by the menu system for option IBCE PRVNVA FAC EDIT
"RTN","IBCEP8",133,0)
 N X,Y,DA,DIC,IBNPRV,DLAYGO
"RTN","IBCEP8",134,0)
 S DIC="^IBA(355.93,",DIC("S")="I $P(^(0),U,2)=1",DIC("DR")=".02///1"
"RTN","IBCEP8",135,0)
 S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON/Other VA FACILITY: "
"RTN","IBCEP8",136,0)
 D ^DIC K DIC,DLAYGO
"RTN","IBCEP8",137,0)
 I Y'>0 S VALMQUIT=1 G NVAFACQ
"RTN","IBCEP8",138,0)
 S IBNPRV=+Y
"RTN","IBCEP8",139,0)
 D EDIT1(IBNPRV,1)
"RTN","IBCEP8",140,0)
 ;
"RTN","IBCEP8",141,0)
NVAFACQ Q
"RTN","IBCEP8",142,0)
 ;
"RTN","IBCEP8",143,0)
GETFAC(IB,IBFILE,IBELE,CSZLEN) ; Returns facility name, address lines or city-state-zip
"RTN","IBCEP8",144,0)
 ;        IB = ien of entry in file
"RTN","IBCEP8",145,0)
 ;    IBFILE = 0 for retrieval from file 4, 1 for retrieval from file 355.93
"RTN","IBCEP8",146,0)
 ;  If IBELE = 0, returns name
"RTN","IBCEP8",147,0)
 ;           = 1, returns address line 1
"RTN","IBCEP8",148,0)
 ;           = 2, returns address line 2
"RTN","IBCEP8",149,0)
 ;           = 12, returns address lines 1 and 2 together
"RTN","IBCEP8",150,0)
 ;           = 3, returns city, state zip
"RTN","IBCEP8",151,0)
 ;           = "3C", returns city    = "3S", state    = "3Z", zip
"RTN","IBCEP8",152,0)
 ;    CSZLEN = max length allowed for city,st,zip string - Only applies when IBELE=3
"RTN","IBCEP8",153,0)
 ;
"RTN","IBCEP8",154,0)
 N Z,IBX,IC,IS,IZ,DIFF
"RTN","IBCEP8",155,0)
 S IBX=""
"RTN","IBCEP8",156,0)
 ;
"RTN","IBCEP8",157,0)
 S Z=$S('IBFILE:$G(^DIC(4,+IB,1)),1:$G(^IBA(355.93,+IB,0)))
"RTN","IBCEP8",158,0)
 I +IBELE=0 S IBX=$S('IBFILE:$P($G(^DIC(4,+IB,0)),U),1:$P($G(^IBA(355.93,+IB,0)),U))
"RTN","IBCEP8",159,0)
 I IBELE=1!(IBELE=12) S IBX=$S('IBFILE:$P(Z,U),1:$P(Z,U,5))
"RTN","IBCEP8",160,0)
 I IBELE=2!(IBELE=12) S IBX=$S(IBELE=12:IBX_" ",1:"")_$S('IBFILE:$P(Z,U,2),1:$P(Z,U,10))
"RTN","IBCEP8",161,0)
 ;
"RTN","IBCEP8",162,0)
 I +IBELE=3 D
"RTN","IBCEP8",163,0)
 . I 'IBFILE S IC=$P(Z,U,3),IS=$$STATE^IBCEFG1($P($G(^DIC(4,+IB,0)),U,2)),IZ=$P(Z,U,4)
"RTN","IBCEP8",164,0)
 . I IBFILE S IC=$P(Z,U,6),IS=$$STATE^IBCEFG1($P(Z,U,7)),IZ=$P(Z,U,8)
"RTN","IBCEP8",165,0)
 . ;
"RTN","IBCEP8",166,0)
 . I IBELE="3C" S IBX=IC Q
"RTN","IBCEP8",167,0)
 . I IBELE="3S" S IBX=IS Q
"RTN","IBCEP8",168,0)
 . I IBELE="3Z" S IBX=IZ Q
"RTN","IBCEP8",169,0)
 . ;
"RTN","IBCEP8",170,0)
 . S IBX=$$CSZ(IC,IS,IZ,+$G(CSZLEN))    ; build the city, st zip string since IBELE=3 here
"RTN","IBCEP8",171,0)
 . Q
"RTN","IBCEP8",172,0)
 ;
"RTN","IBCEP8",173,0)
GETFACX ;
"RTN","IBCEP8",174,0)
 Q IBX
"RTN","IBCEP8",175,0)
 ;
"RTN","IBCEP8",176,0)
CSZ(IC,IS,IZ,CSZLEN) ; build city, state, zip string
"RTN","IBCEP8",177,0)
 ; IC - city
"RTN","IBCEP8",178,0)
 ; IS - state abbreviation
"RTN","IBCEP8",179,0)
 ; IZ - zip
"RTN","IBCEP8",180,0)
 ; CSZLEN - max length allowed for city, st zip string
"RTN","IBCEP8",181,0)
 ;
"RTN","IBCEP8",182,0)
 NEW IBX,DIFF
"RTN","IBCEP8",183,0)
 ;
"RTN","IBCEP8",184,0)
 ; build the full city, st zip string
"RTN","IBCEP8",185,0)
 S IBX=IC_$S(IC'="":", ",1:"")_IS_" "_IZ
"RTN","IBCEP8",186,0)
 ;
"RTN","IBCEP8",187,0)
 I '$G(CSZLEN) G CSZX          ; no max length to worry about
"RTN","IBCEP8",188,0)
 I $L(IBX)'>CSZLEN G CSZX      ; length is OK so get out
"RTN","IBCEP8",189,0)
 ;
"RTN","IBCEP8",190,0)
 ; string is too long so try to shorten the zip if it has a dash
"RTN","IBCEP8",191,0)
 I IZ["-" S IZ=$P(IZ,"-",1),IBX=IC_$S(IC'="":", ",1:"")_IS_" "_IZ I $L(IBX)'>CSZLEN G CSZX
"RTN","IBCEP8",192,0)
 ;
"RTN","IBCEP8",193,0)
 ; string is still too long so truncate the city name until it fits
"RTN","IBCEP8",194,0)
 S DIFF=$L(IBX)-CSZLEN
"RTN","IBCEP8",195,0)
 S IC=$E(IC,1,$L(IC)-DIFF)
"RTN","IBCEP8",196,0)
 S IBX=IC_$S(IC'="":", ",1:"")_IS_" "_IZ
"RTN","IBCEP8",197,0)
CSZX ;
"RTN","IBCEP8",198,0)
 Q IBX
"RTN","IBCEP8",199,0)
 ;
"RTN","IBCEP8",200,0)
ALLID(IBPRV,IBPTYP,IBZ) ; Returns array IBZ for all ids for provider IBPRV
"RTN","IBCEP8",201,0)
 ; for all provider id types or for id type in IBPTYP
"RTN","IBCEP8",202,0)
 ; IBPRV = vp ien of provider
"RTN","IBCEP8",203,0)
 ; IBPTYP = ien of provider id type to return or "" for all
"RTN","IBCEP8",204,0)
 ; IBZ = array returned with internal data:
"RTN","IBCEP8",205,0)
 ;  IBZ(file 355.9 ien)=ID type^ID#^ins co^form type^bill care type^care un^X12 code for id type
"RTN","IBCEP8",206,0)
 N Z,Z0
"RTN","IBCEP8",207,0)
 K IBZ
"RTN","IBCEP8",208,0)
 G:'$G(IBPRV) ALLIDQ
"RTN","IBCEP8",209,0)
 S IBPTYP=$G(IBPTYP)
"RTN","IBCEP8",210,0)
 S Z=0 F  S Z=$O(^IBA(355.9,"B",IBPRV,Z)) Q:'Z  S Z0=$G(^IBA(355.9,Z,0)) D
"RTN","IBCEP8",211,0)
 . I $S(IBPTYP="":1,1:($P(Z0,U,6)=IBPTYP)) S IBZ(Z)=($P(Z0,U,6)_U_$P(Z0,U,7)_U_$P(Z0,U,2)_U_$P(Z0,U,4)_U_$P(Z0,U,5)_U_$P(Z0,U,3))_U_$P($G(^IBE(355.97,+$P(Z0,U,6),0)),U,3)
"RTN","IBCEP8",212,0)
 ;
"RTN","IBCEP8",213,0)
ALLIDQ Q
"RTN","IBCEP8",214,0)
 ;
"RTN","IBCEP8",215,0)
CLIA() ; Returns ien of CLIA # provider id type
"RTN","IBCEP8",216,0)
 N Z,IBZ
"RTN","IBCEP8",217,0)
 S (IBZ,Z)=0 F  S Z=$O(^IBE(355.97,Z)) Q:'Z  I $P($G(^(Z,0)),U,3)="X4",$P(^(0),U)["CLIA" S IBZ=Z Q
"RTN","IBCEP8",218,0)
 Q IBZ
"RTN","IBCEP8",219,0)
 ;
"RTN","IBCEP8",220,0)
STLIC() ; Returns ien of STLIC# provider id type
"RTN","IBCEP8",221,0)
 N Z,IBZ
"RTN","IBCEP8",222,0)
 S (IBZ,Z)=0 F  S Z=$O(^IBE(355.97,Z)) Q:'Z  I $P($G(^(Z,1)),U,3) S IBZ=Z Q
"RTN","IBCEP8",223,0)
 Q IBZ
"RTN","IBCEP8",224,0)
 ;
"RTN","IBCEP8",225,0)
TAXID() ; Returns ien of Fed tax id provider id type
"RTN","IBCEP8",226,0)
 N Z,IBZ
"RTN","IBCEP8",227,0)
 S (IBZ,Z)=0 F  S Z=$O(^IBE(355.97,Z)) Q:'Z  I $P($G(^(Z,1)),U,4) S IBZ=Z Q
"RTN","IBCEP8",228,0)
 Q IBZ
"RTN","IBCEP8",229,0)
 ;
"RTN","IBCEP8",230,0)
CLIANVA(IBIFN) ; Returns CLIA # for a non-VA facility on bill ien IBIFN
"RTN","IBCEP8",231,0)
 N IBCLIA,IBZ,IBNVA,Z
"RTN","IBCEP8",232,0)
 S IBCLIA="",IBZ=$$CLIA()
"RTN","IBCEP8",233,0)
 I IBZ D
"RTN","IBCEP8",234,0)
 . S IBNVA=$P($G(^DGCR(399,IBIFN,"U2")),U,10) Q:'IBNVA
"RTN","IBCEP8",235,0)
 . S IBCLIA=$$IDFIND^IBCEP2(IBIFN,IBZ,IBNVA_";IBA(355.93,","",1)
"RTN","IBCEP8",236,0)
 Q IBCLIA
"RTN","IBCEP8",237,0)
 ;
"RTN","IBCEP8",238,0)
VALFAC(X) ; Function returns 1 if format is valid for X12 facility name
"RTN","IBCEP8",239,0)
 ; Alpha/numeric/certain punctuation valid.  Must start with an Alpha
"RTN","IBCEP8",240,0)
 N OK,VAL
"RTN","IBCEP8",241,0)
 S OK=1
"RTN","IBCEP8",242,0)
 S VAL("A")="",VAL("N")="",VAL=",.- "
"RTN","IBCEP8",243,0)
 I $E(X)'?1A!'$$VALFMT(X,.VAL) S OK=0
"RTN","IBCEP8",244,0)
 Q OK
"RTN","IBCEP8",245,0)
 ;
"RTN","IBCEP8",246,0)
VALFMT(X,VAL) ; Returns 1 if format of X is valid, 0 if not
"RTN","IBCEP8",247,0)
 ; X = data to be examined
"RTN","IBCEP8",248,0)
 ; VAL = a 'string' of valid characters AND/OR (passed by reference)
"RTN","IBCEP8",249,0)
 ;    if VAL("A") defined ==> Alpha
"RTN","IBCEP8",250,0)
 ;    if VAL("A") defined ==> Numeric valid
"RTN","IBCEP8",251,0)
 ;    if VAL("A") defined ==> Punctuation valid
"RTN","IBCEP8",252,0)
 ;   any other character included in the string is checked individually
"RTN","IBCEP8",253,0)
 N Z
"RTN","IBCEP8",254,0)
 I $D(VAL("A")) D
"RTN","IBCEP8",255,0)
 . N Z0
"RTN","IBCEP8",256,0)
 . F Z=1:1:$L(X) I $E(X,Z)?1A S Z0(Z)=""
"RTN","IBCEP8",257,0)
 . S Z0="" F  S Z0=$O(Z0(Z0),-1) Q:'Z0  S $E(X,Z0)=""
"RTN","IBCEP8",258,0)
 I $D(VAL("N")) D
"RTN","IBCEP8",259,0)
 . N Z0
"RTN","IBCEP8",260,0)
 . F Z=1:1:$L(X) I $E(X,Z)?1N S Z0(Z)=""
"RTN","IBCEP8",261,0)
 . S Z0="" F  S Z0=$O(Z0(Z0),-1) Q:'Z0  S $E(X,Z0)=""
"RTN","IBCEP8",262,0)
 I $D(VAL("P")) D
"RTN","IBCEP8",263,0)
 . N Z0
"RTN","IBCEP8",264,0)
 . F Z=1:1:$L(X) I $E(X,Z)?1P S Z0(Z)=""
"RTN","IBCEP8",265,0)
 . S Z0="" F  S Z0=$O(Z0(Z0),-1) Q:'Z0  S $E(X,Z0)=""
"RTN","IBCEP8",266,0)
 I $G(VAL)'="" S X=$TR(X,VAL,"")
"RTN","IBCEP8",267,0)
 Q (X="")
"RTN","IBCEP8",268,0)
 ;
"RTN","IBCEP8",269,0)
PS(IBXSAVE) ; Returns 1 if IBXSAVE("PSVC") indicates the svc was non-lab
"RTN","IBCEP8",270,0)
 ; 
"RTN","IBCEP8",271,0)
 Q $S($G(IBXSAVE("PSVC"))="":0,1:"13"[IBXSAVE("PSVC"))
"RTN","IBCEP8",272,0)
 ;
"RTN","IBCEP8",273,0)
 ; Pass in the Internal Entry number to File 355.93
"RTN","IBCEP8",274,0)
 ; Return the Primary ID and Qualifier (ID Type) from 355.9
"RTN","IBCEP8",275,0)
PRIMID(IEN35593) ; Return External Primary ID and ID Quailier
"RTN","IBCEP8",276,0)
 N INDXVAL,LIST,MSG,IDCODE
"RTN","IBCEP8",277,0)
 S INDXVAL=IEN35593_";IBA(355.93,"
"RTN","IBCEP8",278,0)
 N SCREEN S SCREEN="I $P(^(0),U,8)"
"RTN","IBCEP8",279,0)
 D FIND^DIC(355.9,,"@;.06EI;.07","Q",INDXVAL,,,SCREEN,,"LIST","MSG")
"RTN","IBCEP8",280,0)
 I '+$G(LIST("DILIST",0)) Q ""   ; No Primary ID
"RTN","IBCEP8",281,0)
 I +$G(LIST("DILIST",0))>1 Q "***ERROR***^***ERROR***"  ; Bad.  More than one. 
"RTN","IBCEP8",282,0)
 ; Found just one
"RTN","IBCEP8",283,0)
 S IDCODE=$$GET1^DIQ(355.97,LIST("DILIST","ID",1,.06,"I"),.03)
"RTN","IBCEP8",284,0)
 Q $G(LIST("DILIST","ID",1,.07))_U_IDCODE_" - "_$G(LIST("DILIST","ID",1,.06,"E"))
"RTN","IBCEP8",285,0)
 ;
"RTN","IBCEP8",286,0)
 ; Begin IB*2.0*436 - RBN
"RTN","IBCEP8",287,0)
 ;
"RTN","IBCEP8",288,0)
PRVFMT ;  called only by the INPUT TRANSFORM of #355.93,.01
"RTN","IBCEP8",289,0)
 ;      no other calls are allowed to this tag
"RTN","IBCEP8",290,0)
 ;
"RTN","IBCEP8",291,0)
 ; DESCRIPTION  : Sets the NAME (.01) and the ENTITY TYPE (.02) fields
"RTN","IBCEP8",292,0)
 ;                of file 355.93.  Allows the user to change the ENTITY
"RTN","IBCEP8",293,0)
 ;                TYPE and forces reentry of the provider data so
"RTN","IBCEP8",294,0)
 ;                that it matches the ENTITY TYPE.  Also formats the 
"RTN","IBCEP8",295,0)
 ;                NAME to correspond to the ENTITY TYPE. Disallows
"RTN","IBCEP8",296,0)
 ;                changing of the NAME field from ANYWHERE other than
"RTN","IBCEP8",297,0)
 ;                PROVIDER ID MAINTENANCE or IB EDIT BILLING INFO 
"RTN","IBCEP8",298,0)
 ;                (billing screens).  Adding new entries directly from
"RTN","IBCEP8",299,0)
 ;                FileMan is no longer permitted.
"RTN","IBCEP8",300,0)
 ; 
"RTN","IBCEP8",301,0)
 ; INPUTS       : Variables set by user selected option, screen actions
"RTN","IBCEP8",302,0)
 ;                and user input:
"RTN","IBCEP8",303,0)
 ;                X        - Provider name passed in by .01 field input
"RTN","IBCEP8",304,0)
 ;                           transform.
"RTN","IBCEP8",305,0)
 ;                XQY0     - IB option selected by the user.
"RTN","IBCEP8",306,0)
 ;                DA       - IEN of the record selected by the user
"RTN","IBCEP8",307,0)
 ;                IBNVPMIF - ENTITY TYPE flag passed in from ListManager
"RTN","IBCEP8",308,0)
 ;                           (F=Facility,I=Individual).
"RTN","IBCEP8",309,0)
 ;                IBSCNN   - IB variable indication of the actions/submenu:
"RTN","IBCEP8",310,0)
 ;                           #3, #4, and #7 found on bill screen #8
"RTN","IBCEP8",311,0)
 ;
"RTN","IBCEP8",312,0)
 ; OUTPUTS      : IBFLPFLP - Indicate that the user is changing the
"RTN","IBCEP8",313,0)
 ;                           ENTITY TYPE (flip flop).  Possible states:
"RTN","IBCEP8",314,0)
 ;
"RTN","IBCEP8",315,0)
 ;                   IBFLPFLP = 0 - The type was not changed.
"RTN","IBCEP8",316,0)
 ;                            = 1 - The type changed to facility type.
"RTN","IBCEP8",317,0)
 ;                            = 2 - The type changed to individual type.
"RTN","IBCEP8",318,0)
 ;
"RTN","IBCEP8",319,0)
 ; 
"RTN","IBCEP8",320,0)
 ; GLOBALS      : ^IBA(355.93  - IB NON/OTHER VA BILLING PROVIDER file
"RTN","IBCEP8",321,0)
 ; 
"RTN","IBCEP8",322,0)
 ; 
"RTN","IBCEP8",323,0)
 ;
"RTN","IBCEP8",324,0)
 N OKRTN,IBNAM,IBCEPDA,IBTYPE
"RTN","IBCEP8",325,0)
 S (IBFLPFLP,OKRTN)=0,IBNAM=X,IBCEPDA=$G(DA)
"RTN","IBCEP8",326,0)
 ;
"RTN","IBCEP8",327,0)
 ; Prevent modification of NAME (#.01) in file #355.93 from anywhere
"RTN","IBCEP8",328,0)
 ; but the PROVIDER ID MAINTENANCE or IB EDIT BILLING INFO screens.
"RTN","IBCEP8",329,0)
 ;
"RTN","IBCEP8",330,0)
 I $P($G(XQY0),U,1)="IB EDIT BILLING INFO" D PRVINIT,PRVMANT S OKRTN=1
"RTN","IBCEP8",331,0)
 I $P($G(XQY0),U,1)="IBCE PROVIDER MAINT" D PRVINIT,PRVMANT S OKRTN=1
"RTN","IBCEP8",332,0)
 I 'OKRTN K X
"RTN","IBCEP8",333,0)
 Q
"RTN","IBCEP8",334,0)
 ;==========================
"RTN","IBCEP8",335,0)
PRVINIT ; initialization
"RTN","IBCEP8",336,0)
 ;
"RTN","IBCEP8",337,0)
 ; If arriving from the billing screens (IBSCNN is 3 or 4) the
"RTN","IBCEP8",338,0)
 ; variable DA is the ien of the bill (file #399) - need to find the ien
"RTN","IBCEP8",339,0)
 ; of 355.93 of the provider that the user entered/selected
"RTN","IBCEP8",340,0)
 ;
"RTN","IBCEP8",341,0)
 ; *** Begin IB*2.0*436 -RBN ***
"RTN","IBCEP8",342,0)
 ;I $G(IBSCNN)=3!($G(IBSCNN)=4) S IBCEPDA=$O(^IBA(355.93,"B",IBNAM,"")),IBTYPE=$S(IBSCNN=3:2,1:1)
"RTN","IBCEP8",343,0)
 I $G(IBDR20),'$G(IBCEP6FL) S IBCEPDA=$O(^IBA(355.93,"B",IBNAM,"")),IBTYPE=$S(IBDR20=84:1,IBDR20=104:1,1:2)
"RTN","IBCEP8",344,0)
 ; *** End IB*2.0*436 -RBN ***
"RTN","IBCEP8",345,0)
 ;
"RTN","IBCEP8",346,0)
 ; If arriving from the Provider ID Maintenance call (billing screen or
"RTN","IBCEP8",347,0)
 ; direct call to the option) & the user entered a brand new record, the
"RTN","IBCEP8",348,0)
 ; IBNVPMIF variable is set to indicate if the user was entering a
"RTN","IBCEP8",349,0)
 ; Non-VA facility ("F") or a Non-VA Provider (ie. individual) ("I")
"RTN","IBCEP8",350,0)
 I '$G(IBCEPDA)&$D(IBNVPMIF) S IBTYPE=$S(IBNVPMIF="F":1,1:2)
"RTN","IBCEP8",351,0)
 ;
"RTN","IBCEP8",352,0)
 ; If arriving from the Provider ID Maintenance call (billing screen or
"RTN","IBCEP8",353,0)
 ; direct call to the option) & the user selected an existing record
"RTN","IBCEP8",354,0)
 I $G(IBCEPDA) S IBTYPE=$P($G(^IBA(355.93,IBCEPDA,0)),U,2)
"RTN","IBCEP8",355,0)
 Q
"RTN","IBCEP8",356,0)
 ;----------------------------
"RTN","IBCEP8",357,0)
PRVMANT ; is the user flipping the provider type (for existing records only)
"RTN","IBCEP8",358,0)
 N TXT,TXT2,%
"RTN","IBCEP8",359,0)
 ;
"RTN","IBCEP8",360,0)
 ; IBTYPE - based on the current value of provider type (#355.93,.02)
"RTN","IBCEP8",361,0)
 ;          where "1" = Facility/Group  & "2" = Individual
"RTN","IBCEP8",362,0)
 ;
"RTN","IBCEP8",363,0)
 I '$G(IBTYPE) Q    ; one of the calls that triggers this routine needs
"RTN","IBCEP8",364,0)
 ;               ; this check when creating a new record in file #355.93
"RTN","IBCEP8",365,0)
 ;
"RTN","IBCEP8",366,0)
 ; If record is not brand new (IBCEPDA exists) - give the user the
"RTN","IBCEP8",367,0)
 ; opportunity to change the provider type field (#355.93,.02)
"RTN","IBCEP8",368,0)
 I IBTYPE,$G(IBCEPDA) D
"RTN","IBCEP8",369,0)
 . ;
"RTN","IBCEP8",370,0)
 . S %=2  ; Default answer is no
"RTN","IBCEP8",371,0)
 . ;
"RTN","IBCEP8",372,0)
 . I IBTYPE=1 S TXT="Facility",TXT2="Individual/Provider"
"RTN","IBCEP8",373,0)
 . I IBTYPE=2 S TXT="Individual/Provider",TXT2="Facility"
"RTN","IBCEP8",374,0)
 . ;
"RTN","IBCEP8",375,0)
 . D EN^DDIOL("This provider name exists and is a "_TXT_".","","!")
"RTN","IBCEP8",376,0)
 . D EN^DDIOL("Do you want to change this record to be a "_TXT2)
"RTN","IBCEP8",377,0)
 . ;
"RTN","IBCEP8",378,0)
 . D YN^DICN
"RTN","IBCEP8",379,0)
 . ;
"RTN","IBCEP8",380,0)
 . I %=1 D
"RTN","IBCEP8",381,0)
 . . ;
"RTN","IBCEP8",382,0)
 . . S IBTYPE=$S(IBTYPE=1:2,1:1),IBFLPFLP=IBTYPE
"RTN","IBCEP8",383,0)
 ;
"RTN","IBCEP8",384,0)
 I IBTYPE=2 D STDNAME^XLFNAME(.IBNAM,"GP") S X=IBNAM
"RTN","IBCEP8",385,0)
 I IBTYPE=1,('$$VALFAC^IBCEP8(IBNAM)) K X
"RTN","IBCEP8",386,0)
 Q
"RTN","IBCEP8",387,0)
 ;
"RTN","IBCEP8",388,0)
 ; DESCRIPTION: This routine inputs a provider name and formats it appropriately as an 
"RTN","IBCEP8",389,0)
 ;              individual or a facility name.
"RTN","IBCEP8",390,0)
 ; 
"RTN","IBCEP8",391,0)
 ; INPUTS     : name
"RTN","IBCEP8",392,0)
 ; 
"RTN","IBCEP8",393,0)
 ; OUTPUTS    : formatted name and provider type
"RTN","IBCEP8",394,0)
 ; 
"RTN","IBCEP8",395,0)
 ; VARIABLES  :
"RTN","IBCEP8",396,0)
 ; 
"RTN","IBCEP8",397,0)
 ; GLOBALS      : 
"RTN","IBCEP8",398,0)
 ; 
"RTN","IBCEP8",399,0)
 ; FUNCTIONS    : None
"RTN","IBCEP8",400,0)
 ; 
"RTN","IBCEP8",401,0)
 ; SUBROUTINES  : 
"RTN","IBCEP8",402,0)
 ; 
"RTN","IBCEP8",403,0)
 ; HISTORY    : Original version - 21 September 2010
"RTN","IBCEP8",404,0)
 ;
"RTN","IBCEP8",405,0)
SCREEN(IBNPRV) ;
"RTN","IBCEP8",406,0)
 N IBNPRVN,IBNAME,DR,DIR,DA,DIRUT,X,DTOUT,DUOUT
"RTN","IBCEP8",407,0)
 S IBNPRVN=""
"RTN","IBCEP8",408,0)
 D EN^DDIOL(" ")
"RTN","IBCEP8",409,0)
 D EN^DDIOL("If you do NOT want to edit the provider name or the provider type,","","!")
"RTN","IBCEP8",410,0)
 D EN^DDIOL("then press return at the following NAME prompt.  Otherwise,")
"RTN","IBCEP8",411,0)
 D EN^DDIOL("retype the name as you want it entered into the system.")
"RTN","IBCEP8",412,0)
 D EN^DDIOL(" ")
"RTN","IBCEP8",413,0)
 ;
"RTN","IBCEP8",414,0)
 ; Get the current provider name
"RTN","IBCEP8",415,0)
 ;
"RTN","IBCEP8",416,0)
 S IBNAME=$P(^IBA(355.93,IBNPRV,0),U,1)
"RTN","IBCEP8",417,0)
 ;
"RTN","IBCEP8",418,0)
 ; Get the user's input
"RTN","IBCEP8",419,0)
 ;
"RTN","IBCEP8",420,0)
INPUT ;
"RTN","IBCEP8",421,0)
 S DIR(0)="FOUrA^3:30"
"RTN","IBCEP8",422,0)
 S DIR("A")="NAME: "_IBNAME_"// "
"RTN","IBCEP8",423,0)
 ;
"RTN","IBCEP8",424,0)
 S DIR("?")=" "
"RTN","IBCEP8",425,0)
 S DIR("?",1)="Press <ENTER> to accept the displayed provider name"
"RTN","IBCEP8",426,0)
 S DIR("?",2)="or enter the name as you would like it displayed."
"RTN","IBCEP8",427,0)
 ;
"RTN","IBCEP8",428,0)
 S DIR("??")="IB PROV ID MAINT^"
"RTN","IBCEP8",429,0)
 ;
"RTN","IBCEP8",430,0)
 D ^DIR
"RTN","IBCEP8",431,0)
 ;
"RTN","IBCEP8",432,0)
 Q:$D(DTOUT)!$D(DUOUT)
"RTN","IBCEP8",433,0)
 I X["?" G INPUT
"RTN","IBCEP8",434,0)
 S:'$D(DIRUT) IBNPRVN=X
"RTN","IBCEP8",435,0)
 ; The user entered something else
"RTN","IBCEP8",436,0)
 ;
"RTN","IBCEP8",437,0)
 S DIE="^IBA(355.93,"
"RTN","IBCEP8",438,0)
 S DA=IBNPRV
"RTN","IBCEP8",439,0)
 S DR=".01///"_IBNPRVN
"RTN","IBCEP8",440,0)
 D ^DIE
"RTN","IBCEP8",441,0)
 Q
"RTN","IBCEP8",442,0)
 ;
"RTN","IBCEP8",443,0)
 ; End IB*2.0*436 - RBN
"RTN","IBCEP8",444,0)
 ;
"RTN","IBCRBC2")
0^59^B28219080
"RTN","IBCRBC2",1,0)
IBCRBC2 ;ALB/ARH - RATES: BILL CALCULATION OF ITEM CHARGE ; 22-MAY-1996
"RTN","IBCRBC2",2,0)
 ;;2.0;INTEGRATED BILLING;**52,106,138,148,245,370,447**;21-MAR-94;Build 80
"RTN","IBCRBC2",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCRBC2",4,0)
 ;
"RTN","IBCRBC2",5,0)
 ; Input:  RS     - rate schedule necessary to calculated modified charges
"RTN","IBCRBC2",6,0)
 ;         CS     - required, charge set which defines the charges to calculate
"RTN","IBCRBC2",7,0)
 ;         ITEM   - required, ptr to source item to be billed, type defined by billable item of the rate
"RTN","IBCRBC2",8,0)
 ;         EVDT   - date of event, to be used when searching for a charge effective date, default=DT
"RTN","IBCRBC2",9,0)
 ;         UNITS  - required, used only for Quantity:  # of units of Charge Item Charge for each Item
"RTN","IBCRBC2",10,0)
 ;         MOD    - CPT Modifier if any
"RTN","IBCRBC2",11,0)
 ;         INSRC  - special revenue code to use (from ins comp), if any (overrides set and item rv cd)
"RTN","IBCRBC2",12,0)
 ;         IDFRC  - different revenue codes to use, these replace the standard set in CM (DRC:SRC,DRC:SRC)
"RTN","IBCRBC2",13,0)
 ;         SAVE   - serveral data items not needed here but passed on to next step (store) in TMP array:
"RTN","IBCRBC2",14,0)
 ;                  TUNITS - required to add charge to bill, total # of the Item on the bill
"RTN","IBCRBC2",15,0)
 ;                  CPT    - default CPT to be added to the bill for the charge
"RTN","IBCRBC2",16,0)
 ;                  DIV    - division charges apply to
"RTN","IBCRBC2",17,0)
 ;                  TYPE   - type of item being billed - defines the source of the item on the bill
"RTN","IBCRBC2",18,0)
 ;                  ITMPTR - soft pointer to the item on the bill:  may be a multiple or file IFN
"RTN","IBCRBC2",19,0)
 ;                  CMPNT  - what component of the total charge: institutional or professional
"RTN","IBCRBC2",20,0)
 ;                  BEDS   - billable bedsection to use if not a bedsection item, if null uses set default
"RTN","IBCRBC2",21,0)
 ;                  PROV   - procedure provider
"RTN","IBCRBC2",22,0)
 ;                  CLINIC - procedures associated clinic
"RTN","IBCRBC2",23,0)
 ;                  IBOE   - Outpatient Encounter, pointer to #408.69
"RTN","IBCRBC2",24,0)
 ;                  MODS   - list of all modifiers define for the procedure, separated by ','
"RTN","IBCRBC2",25,0)
 ;
"RTN","IBCRBC2",26,0)
 ; Total charge is calculated:  X = UNITS * UNIT CHARGE of the item         (per unit charge (un-adjusted))
"RTN","IBCRBC2",27,0)
 ;                              Y = X modified by Rate Schedule Adjustment  (per unit charge (adjusted))
"RTN","IBCRBC2",28,0)
 ; the Units are used to calculate the per item charge: 30 pills for an rx, 1 bs per bs
"RTN","IBCRBC2",29,0)
 ; and the Tunits are the number of that Item on the bill: 1 rx of 30 pills, 11 days of bs stay
"RTN","IBCRBC2",30,0)
 ;
"RTN","IBCRBC2",31,0)
 ; Output: TMP($J,"IBCRCC", containing all chargable items and all related info needed to file them on the bill
"RTN","IBCRBC2",32,0)
 ;         each charge will have it's own entry, nothing combined (12 = per unit charge (adjusted), p13 = Tunits)
"RTN","IBCRBC2",33,0)
 ;         TMP is not killed on entry so each items charges are compiled and added to existing charges
"RTN","IBCRBC2",34,0)
 ;         
"RTN","IBCRBC2",35,0)
BITMCHG(RS,CS,ITEM,EVDT,UNITS,MOD,INSRC,IDFRC,SAVE) ; get bill charges for a specific item, rate schedule and charge set and date set into temp array
"RTN","IBCRBC2",36,0)
 ;
"RTN","IBCRBC2",37,0)
 N IBCS0,IBDRVCD,IBBS,IBCHGARR,IBI,IBCNT,IBLN,IBCI,IBRVCD,IBPPRV,IBCHRG,IBTCHRG,IBRCHRG,IBPCHRG,IBACHRG
"RTN","IBCRBC2",38,0)
 N IBMCHRG,IBMODS,IBBASE,IBCOM I '$G(ITEM)!'$G(CS)!'$G(UNITS) Q
"RTN","IBCRBC2",39,0)
 ;
"RTN","IBCRBC2",40,0)
 S RS=$G(RS),EVDT=$S(+$G(EVDT):+EVDT\1,1:DT),MOD=$G(MOD),INSRC=$G(INSRC),IDFRC=$G(IDFRC),SAVE=$G(SAVE)
"RTN","IBCRBC2",41,0)
 S IBCS0=$G(^IBE(363.1,+CS,0)),IBDRVCD=$P(IBCS0,U,5),IBPPRV=$P(SAVE,U,8),IBMODS=$P(SAVE,U,11)
"RTN","IBCRBC2",42,0)
 S IBBS=+ITEM I $P($G(^IBE(363.3,+$P(IBCS0,U,2),0)),U,4)'=1 S IBBS=$P(SAVE,U,7) I 'IBBS S IBBS=$P(IBCS0,U,6)
"RTN","IBCRBC2",43,0)
 I 'IBBS Q
"RTN","IBCRBC2",44,0)
 ;
"RTN","IBCRBC2",45,0)
 D ITMCHG^IBCRCC(CS,ITEM,EVDT,MOD,.IBCHGARR)
"RTN","IBCRBC2",46,0)
 ;
"RTN","IBCRBC2",47,0)
 S IBCNT=+$G(^TMP($J,"IBCRCC"))
"RTN","IBCRBC2",48,0)
 S IBI=0 F  S IBI=$O(IBCHGARR(IBI)) Q:'IBI  D
"RTN","IBCRBC2",49,0)
 . ; START IB*2.0*447 BI ZERO DOLLAR CHANGES
"RTN","IBCRBC2",50,0)
 . ;S IBLN=IBCHGARR(IBI),IBCI=+IBLN,IBCHRG=$P(IBLN,U,3),(IBPCHRG,IBRCHRG)="" Q:'IBCHRG  S IBBASE=$P(IBLN,U,4)
"RTN","IBCRBC2",51,0)
 . S IBLN=IBCHGARR(IBI),IBCI=+IBLN,IBCHRG=$P(IBLN,U,3),(IBPCHRG,IBRCHRG)="" S IBBASE=$P(IBLN,U,4)
"RTN","IBCRBC2",52,0)
 . ; END IB*2.0*447 BI ZERO DOLLAR CHANGES
"RTN","IBCRBC2",53,0)
 . S IBRVCD=INSRC I 'IBRVCD S IBRVCD=$P(IBLN,U,2)
"RTN","IBCRBC2",54,0)
 . I 'IBRVCD S IBRVCD=$P($$RVLNK^IBCRU6(+ITEM,"",+CS),U,2) I 'IBRVCD S IBRVCD=IBDRVCD Q:'IBRVCD
"RTN","IBCRBC2",55,0)
 . I +IDFRC,+$P(IDFRC,IBRVCD_":",2) S IBRVCD=+$P(IDFRC,IBRVCD_":",2) Q:IBRVCD'?3N
"RTN","IBCRBC2",56,0)
 . ;
"RTN","IBCRBC2",57,0)
 . S IBCHRG=IBCHRG*UNITS
"RTN","IBCRBC2",58,0)
 . S IBCHRG=IBCHRG+IBBASE
"RTN","IBCRBC2",59,0)
 . S IBPCHRG=IBCHRG I +IBPPRV S IBPCHRG=$$PRVCHG^IBCRCC(CS,IBCHRG,IBPPRV,EVDT,ITEM)
"RTN","IBCRBC2",60,0)
 . S IBMCHRG=+IBPCHRG I +IBMODS S IBMCHRG=$$MODCHG^IBCRCC(CS,IBPCHRG,IBMODS)
"RTN","IBCRBC2",61,0)
 . S (IBCHRG,IBTCHRG)=+IBMCHRG
"RTN","IBCRBC2",62,0)
 . S IBACHRG=IBTCHRG I +RS,+IBTCHRG S IBRCHRG=$$RATECHG^IBCRCC(RS,IBTCHRG,EVDT),IBACHRG=+IBRCHRG
"RTN","IBCRBC2",63,0)
 . ;
"RTN","IBCRBC2",64,0)
 . S IBCNT=IBCNT+1,^TMP($J,"IBCRCC")=IBCNT
"RTN","IBCRBC2",65,0)
 . S ^TMP($J,"IBCRCC",IBCNT)=IBCI_U_CS_U_RS_U_ITEM_U_MOD_U_IBRVCD_U_IBBS_U_EVDT_U_IBCHRG_U_UNITS_U_IBTCHRG_U_IBACHRG_U_$G(SAVE)
"RTN","IBCRBC2",66,0)
 . ;
"RTN","IBCRBC2",67,0)
 . I (UNITS>1)!(+IBBASE) S IBCOM=$$COMMUB(CS,UNITS,IBBASE) I IBCOM'="" D COMMENT(IBCNT,IBCOM)
"RTN","IBCRBC2",68,0)
 . I $P(IBPCHRG,U,2)'="" S IBCOM=$P(IBPCHRG,U,2) I IBCOM'="" D COMMENT(IBCNT,IBCOM)
"RTN","IBCRBC2",69,0)
 . I $P(IBMCHRG,U,2)'="" S IBCOM=$P(IBMCHRG,U,2) I IBCOM'="" D COMMENT(IBCNT,IBCOM)
"RTN","IBCRBC2",70,0)
 . I $P(IBRCHRG,U,2)'="" S IBCOM=$P(IBRCHRG,U,2) I IBCOM'="" D COMMENT(IBCNT,IBCOM)
"RTN","IBCRBC2",71,0)
 Q
"RTN","IBCRBC2",72,0)
 ;
"RTN","IBCRBC2",73,0)
COMMENT(LINE,COMM) ; set comment into charge array for a particular line item
"RTN","IBCRBC2",74,0)
 I +$D(^TMP($J,"IBCRCC",+$G(LINE))) N IBX D
"RTN","IBCRBC2",75,0)
 . S IBX=$O(^TMP($J,"IBCRCC",+LINE,"CC",9999),-1) S IBX=IBX+1
"RTN","IBCRBC2",76,0)
 . S ^TMP($J,"IBCRCC",+LINE,"CC",IBX)=$G(COMM)
"RTN","IBCRBC2",77,0)
 Q
"RTN","IBCRBC2",78,0)
 ;
"RTN","IBCRBC2",79,0)
COMMUB(CS,UNITS,BASE) ; return comment for special units and base
"RTN","IBCRBC2",80,0)
 N IBX,IBY,IBCM S IBX="",IBY="Charge calculated"
"RTN","IBCRBC2",81,0)
 S IBCM=$P($G(^IBE(363.1,+CS,0)),U,2),IBCM=$P($G(^IBE(363.3,+IBCM,0)),U,5)
"RTN","IBCRBC2",82,0)
 S IBCM=$S(IBCM=4:"Miles",IBCM=5:"SubUnits",IBCM=6:"Hours",1:"")
"RTN","IBCRBC2",83,0)
 I +$G(UNITS) S IBX=IBY_" for "_UNITS_" "_IBCM,IBY=""
"RTN","IBCRBC2",84,0)
 I +$G(BASE) S IBX=IBY_IBX_" with a Base Charge="_$J(BASE,0,2)
"RTN","IBCRBC2",85,0)
 Q IBX
"RTN","IBCRBC2",86,0)
 ;
"RTN","IBCRBC2",87,0)
ALLBEDS(RS,CS,EVDT,RC,DFRC,SAVE) ; get charges for all bedsections active on date of visit
"RTN","IBCRBC2",88,0)
 ; each effective date supercedes all previous effective date, regardless of the item
"RTN","IBCRBC2",89,0)
 ; used for per diem rates where the charges are associated with a bedsection, but the item being billed is not
"RTN","IBCRBC2",90,0)
 ; a bedsection, so the count of the item on the bill is found and applied as the units to all bedsections active
"RTN","IBCRBC2",91,0)
 ; on the event date  (the 3 opt visit dates on a bill are the units for the Outpatient Visit bedsection charge)
"RTN","IBCRBC2",92,0)
 ;
"RTN","IBCRBC2",93,0)
 N IBITM,IBITEMS I '$G(CS)!'$G(EVDT) Q
"RTN","IBCRBC2",94,0)
 ;
"RTN","IBCRBC2",95,0)
 D CSALL^IBCRCU1(CS,EVDT,.IBITEMS)
"RTN","IBCRBC2",96,0)
 ;
"RTN","IBCRBC2",97,0)
 I +IBITEMS S IBITM="" F  S IBITM=$O(IBITEMS(IBITM)) Q:'IBITM  D
"RTN","IBCRBC2",98,0)
 . D BITMCHG($G(RS),CS,IBITM,EVDT,1,"",$G(RC),$G(DFRC),$G(SAVE))
"RTN","IBCRBC2",99,0)
 Q
"RTN","IBCRBC2",100,0)
 ;
"RTN","IBCRBC2",101,0)
 ;
"RTN","IBCRBC2",102,0)
CPTUNITS(CS,CHGMTH,ITLINE) ; return CPT units based on Charge Method and CPT data
"RTN","IBCRBC2",103,0)
 ; Input:  CS is the related Charge Set
"RTN","IBCRBC2",104,0)
 ;         CHGMTH is the Rate Schedule Charge Method (363.3, .05)
"RTN","IBCRBC2",105,0)
 ;         ITLINE is item data from CPT^IBCRBG1
"RTN","IBCRBC2",106,0)
 ; Output: calculated units for CPT, 1 or calculated for miles/minutes/hours
"RTN","IBCRBC2",107,0)
 N IBUNIT S IBUNIT=1,CHGMTH=$G(CHGMTH),ITLINE=$G(ITLINE),CS=$G(CS)
"RTN","IBCRBC2",108,0)
 I CHGMTH=4 S IBUNIT=+$P(ITLINE,U,8) ; miles
"RTN","IBCRBC2",109,0)
 I CHGMTH=5 S IBUNIT=+$P(ITLINE,U,7) ; minutes
"RTN","IBCRBC2",110,0)
 I CHGMTH=6 S IBUNIT=+$P(ITLINE,U,9) ; hours
"RTN","IBCRBC2",111,0)
 S IBUNIT=$$CPTUNITS^IBCRCU1(CS,IBUNIT)
"RTN","IBCRBC2",112,0)
 Q IBUNIT
"RTN","IBCRBC2",113,0)
 ;
"RTN","IBCRBC2",114,0)
CHGOTH(IBIFN,RS,EVDT) ; check if the Rate Schedule charges are applicable to the event date for the bill
"RTN","IBCRBC2",115,0)
 ; this is relevent to RC v2.0 and type of care of Other
"RTN","IBCRBC2",116,0)
 ; both Rate Schedule is SNF and event date is SNF care or neither can be otherwise no charge
"RTN","IBCRBC2",117,0)
 ; SNF charges can't be used for non-SNF care and non-SNF charges can't be used for SNF care
"RTN","IBCRBC2",118,0)
 ; Output: returns true if charges and bill date are of same type, SNF or non-SNF
"RTN","IBCRBC2",119,0)
 N IBOK,IBRSTY,IBDTTY S (IBRSTY,IBDTTY)=0,IBOK=1
"RTN","IBCRBC2",120,0)
 I $G(EVDT)<$$VERSDT^IBCRU8(2) G CHGOTHQ
"RTN","IBCRBC2",121,0)
 I '$G(IBIFN)!'$G(RS) G CHGOTHQ
"RTN","IBCRBC2",122,0)
 ;
"RTN","IBCRBC2",123,0)
 S IBRSTY=$$RSOTHER^IBCRU8(RS) ; are charges for other type of care
"RTN","IBCRBC2",124,0)
 S IBDTTY=$$BOTHER^IBCU3(IBIFN,EVDT) ; is date other type of care
"RTN","IBCRBC2",125,0)
 ;
"RTN","IBCRBC2",126,0)
 I +IBRSTY,'IBDTTY S IBOK=0
"RTN","IBCRBC2",127,0)
 I 'IBRSTY,+IBDTTY S IBOK=0
"RTN","IBCRBC2",128,0)
 ;
"RTN","IBCRBC2",129,0)
CHGOTHQ Q IBOK
"RTN","IBCRBC2",130,0)
 ;
"RTN","IBCRBC2",131,0)
CHGICU(CS,BS) ; check if charge and bedsection match relative to ICU RC 2.0+, compares Charge Set Name and Bedsection
"RTN","IBCRBC2",132,0)
 ; both the charge set and the bedsection have to be ICU or neither of them can be ICU otherwise no charge
"RTN","IBCRBC2",133,0)
 ; ICU charges can't be used with non-ICU bedsections and non-ICU charges can't be used with ICU bedsection
"RTN","IBCRBC2",134,0)
 ; Output: returns true if charges and bedsection are of same type, ICU or non-ICU
"RTN","IBCRBC2",135,0)
 N IBCSICU,IBCSN,IBICU,IBOK S (IBOK,IBCSICU)=0,BS=+$G(BS)
"RTN","IBCRBC2",136,0)
 S IBICU=$$MCCRUTL^IBCRU1("ICU",5)
"RTN","IBCRBC2",137,0)
 S IBCSN=$G(^IBE(363.1,+$G(CS),0)) I $E(IBCSN,1,2)'="RC" S IBOK=1
"RTN","IBCRBC2",138,0)
 I $P(IBCSN,U,1)["ICU" S IBCSICU=1 ; charge set is icu
"RTN","IBCRBC2",139,0)
 ;
"RTN","IBCRBC2",140,0)
 I BS=IBICU,+IBCSICU S IBOK=1 ; both bedsection and charge set are icu
"RTN","IBCRBC2",141,0)
 I BS'=IBICU,'IBCSICU S IBOK=1 ; niether bedsection nor charge set are icu
"RTN","IBCRBC2",142,0)
 Q IBOK
"RTN","IBCRBC3")
0^56^B15092850
"RTN","IBCRBC3",1,0)
IBCRBC3 ;ALB/ARH - RATES: BILL CALCULATION SORT/STORE ;22-MAY-1996
"RTN","IBCRBC3",2,0)
 ;;2.0;INTEGRATED BILLING;**52,106,138,51,447**;21-MAR-94;Build 80
"RTN","IBCRBC3",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IBCRBC3",4,0)
 ;
"RTN","IBCRBC3",5,0)
SORTCI ; process charge array - create new array sorted by bedsection and revenue code
"RTN","IBCRBC3",6,0)
 ; if bs, rv cd, unit charge, cpt, div, item type, item ptr and component all match then charge is combined
"RTN","IBCRBC3",7,0)
 ; Input:  TMP($J,"IBCRCC",X) = ...  (from IBCRBC2)
"RTN","IBCRBC3",8,0)
 ; Output: TMP($J,"IBCRCS",BS,RV CD,Y) = 
"RTN","IBCRBC3",9,0)
 ;         RV CD PTR ^ BS PTR ^ UNIT $ ^ UNITS ^ CPT ^ DIV ^ ITEM TYPE ^ ITEM PTR ^ CHARGE COMPONENT
"RTN","IBCRBC3",10,0)
 ;
"RTN","IBCRBC3",11,0)
 N IBI,IBLN,IBRVCD,IBBS,IBUNITS,IBCHG,IBCPT,IBDV,IBIT,IBIP,IBCMPT,IBTUNITS,IBK,IBJ,IBX K ^TMP($J,"IBCRCS")
"RTN","IBCRBC3",12,0)
 ;
"RTN","IBCRBC3",13,0)
 S IBI=0 F  S IBI=$O(^TMP($J,"IBCRCC",IBI)) Q:'IBI  D
"RTN","IBCRBC3",14,0)
 . ;
"RTN","IBCRBC3",15,0)
 . S IBLN=^TMP($J,"IBCRCC",IBI)
"RTN","IBCRBC3",16,0)
 . ; START IB*2.0*447 BI ZERO DOLLAR CHANGES
"RTN","IBCRBC3",17,0)
 . ;S IBRVCD=$P(IBLN,U,6),IBBS=$P(IBLN,U,7),IBCHG=$P(IBLN,U,12),IBUNITS=$P(IBLN,U,13) Q:'IBCHG
"RTN","IBCRBC3",18,0)
 . S IBRVCD=$P(IBLN,U,6),IBBS=$P(IBLN,U,7),IBCHG=$P(IBLN,U,12),IBUNITS=$P(IBLN,U,13)
"RTN","IBCRBC3",19,0)
 . ; END IB*2.0*447 BI ZERO DOLLAR CHANGES
"RTN","IBCRBC3",20,0)
 . S IBCPT=$P(IBLN,U,14),IBDV=$P(IBLN,U,15),IBIT=$P(IBLN,U,16),IBIP=$P(IBLN,U,17),IBCMPT=$P(IBLN,U,18)
"RTN","IBCRBC3",21,0)
 . ;
"RTN","IBCRBC3",22,0)
 . S (IBTUNITS,IBK)=0 ; combine like charges
"RTN","IBCRBC3",23,0)
 . S IBJ=0 F  S IBJ=$O(^TMP($J,"IBCRCS",+IBBS,+IBRVCD,IBJ)) Q:'IBJ  D  Q:+IBTUNITS
"RTN","IBCRBC3",24,0)
 .. S IBK=IBJ,IBX=$G(^TMP($J,"IBCRCS",+IBBS,+IBRVCD,IBJ))
"RTN","IBCRBC3",25,0)
 .. I IBCHG=$P(IBX,U,3),IBCPT=$P(IBX,U,5),IBDV=$P(IBX,U,6),IBIT=$P(IBX,U,7),IBIP=$P(IBX,U,8),IBCMPT=$P(IBX,U,9) D
"RTN","IBCRBC3",26,0)
 ... S IBTUNITS=$P(IBX,U,4)
"RTN","IBCRBC3",27,0)
 . ;
"RTN","IBCRBC3",28,0)
 . I 'IBTUNITS S IBK=IBK+1 ; no combination, new line item charge
"RTN","IBCRBC3",29,0)
 . S IBTUNITS=IBTUNITS+IBUNITS
"RTN","IBCRBC3",30,0)
 . ;
"RTN","IBCRBC3",31,0)
 . S ^TMP($J,"IBCRCS",+IBBS,+IBRVCD,IBK)=IBRVCD_U_+IBBS_U_IBCHG_U_IBTUNITS_U_IBCPT_U_IBDV_U_IBIT_U_IBIP_U_IBCMPT
"RTN","IBCRBC3",32,0)
 Q
"RTN","IBCRBC3",33,0)
 ;
"RTN","IBCRBC3",34,0)
 ;
"RTN","IBCRBC3",35,0)
ADDBCHGS(IBIFN) ; store all auto calculated charges: add charges to bill:  sets RC multiple
"RTN","IBCRBC3",36,0)
 ; Input: TMP($J,"IBCRCS",BS,RV CD,X) = ... (from SORTCI)
"RTN","IBCRBC3",37,0)
 ;
"RTN","IBCRBC3",38,0)
 N IBX,IBI,IBJ,IBK,IBLN,IBRVCD,IBBS,IBCHG,IBUNITS,IBAUTOAD,IBCPT,IBDIV,IBITYP,IBIPTR,IBCMPNT,IBRCFN,Z
"RTN","IBCRBC3",39,0)
 ;
"RTN","IBCRBC3",40,0)
 D DSPHDR
"RTN","IBCRBC3",41,0)
 ;
"RTN","IBCRBC3",42,0)
 S IBI=0 F  S IBI=$O(^TMP($J,"IBCRCS",IBI)) Q:'IBI  D
"RTN","IBCRBC3",43,0)
 . S IBJ=0 F  S IBJ=$O(^TMP($J,"IBCRCS",IBI,IBJ)) Q:'IBJ  D
"RTN","IBCRBC3",44,0)
 .. S IBK=0 F  S IBK=$O(^TMP($J,"IBCRCS",IBI,IBJ,IBK)) Q:'IBK  D
"RTN","IBCRBC3",45,0)
 ... S IBLN=$G(^TMP($J,"IBCRCS",IBI,IBJ,IBK)) Q:IBLN=""
"RTN","IBCRBC3",46,0)
 ... ;
"RTN","IBCRBC3",47,0)
 ... ; add charges to RC multiple
"RTN","IBCRBC3",48,0)
 ... S IBRVCD=$P(IBLN,U,1),IBBS=$P(IBLN,U,2),IBCHG=$P(IBLN,U,3),IBUNITS=$P(IBLN,U,4),IBAUTOAD=1
"RTN","IBCRBC3",49,0)
 ... S IBCPT=$P(IBLN,U,5),IBDIV=$P(IBLN,U,6),IBITYP=$P(IBLN,U,7),IBIPTR=$P(IBLN,U,8),IBCMPNT=$P(IBLN,U,9)
"RTN","IBCRBC3",50,0)
 ... ;
"RTN","IBCRBC3",51,0)
 ... S IBRCFN=$$ADDRC^IBCRBF(IBIFN,IBRVCD,IBBS,.IBCHG,IBUNITS,IBCPT,IBDIV,IBAUTOAD,IBITYP,IBIPTR,IBCMPNT)
"RTN","IBCRBC3",52,0)
 ... ;
"RTN","IBCRBC3",53,0)
 ... I +IBRCFN D
"RTN","IBCRBC3",54,0)
 .... I IBITYP=3,IBIPTR'="" D DEFAULT^IBCSC5C(IBIFN,+IBRCFN)
"RTN","IBCRBC3",55,0)
 .... S IBX=IBRVCD_U_IBCHG_U_IBUNITS_U_IBBS_U_IBITYP_U_IBIPTR_U_IBCPT D DSPLN(IBX)
"RTN","IBCRBC3",56,0)
 ;
"RTN","IBCRBC3",57,0)
 D CLEANRX(IBIFN)
"RTN","IBCRBC3",58,0)
 Q
"RTN","IBCRBC3",59,0)
 ;
"RTN","IBCRBC3",60,0)
CLEANRX(IBIFN) ; Clean up any procedures left over from deleted Rx entries
"RTN","IBCRBC3",61,0)
 N Z,DA,DIK
"RTN","IBCRBC3",62,0)
 S Z=0 F  S Z=$O(^TMP("IBCRRX",$J,Z)) Q:'Z  S DA=0 F  S DA=$O(^TMP("IBCRRX",$J,Z,DA)) Q:'DA  S DA(1)=IBIFN,DIK="^DGCR(399,"_DA(1)_",""CP""," D ^DIK
"RTN","IBCRBC3",63,0)
 K ^TMP("IBCRRX",$J)
"RTN","IBCRBC3",64,0)
 Q
"RTN","IBCRBC3",65,0)
 ;
"RTN","IBCRBC3",66,0)
DSPDL ;
"RTN","IBCRBC3",67,0)
 I $D(ZTQUEUED)!(+$G(IBAUTO)) Q
"RTN","IBCRBC3",68,0)
 W !,"Removing old Revenue Codes and Rate Schedules..."
"RTN","IBCRBC3",69,0)
 Q
"RTN","IBCRBC3",70,0)
DSPHDR ;
"RTN","IBCRBC3",71,0)
 I $D(ZTQUEUED)!(+$G(IBAUTO)) Q
"RTN","IBCRBC3",72,0)
 W !,"Updating Revenue Codes and Charges"
"RTN","IBCRBC3",73,0)
 W !,?9,"Rev Code",?19,"Units",?31,"Charge",?41,"Bedsection"
"RTN","IBCRBC3",74,0)
 Q
"RTN","IBCRBC3",75,0)
DSPLN(LN) ;
"RTN","IBCRBC3",76,0)
 I $D(ZTQUEUED)!(+$G(IBAUTO)) Q
"RTN","IBCRBC3",77,0)
 N RVCD,BS,ITM S LN=$G(LN)
"RTN","IBCRBC3",78,0)
 S RVCD=$P($G(^DGCR(399.2,+LN,0)),U,1),BS=$$EMUTL^IBCRU1(+$P(LN,U,4)),ITM=$$NAME^IBCSC61($P(LN,U,5),$P(LN,U,6))
"RTN","IBCRBC3",79,0)
 I ITM="",$P(LN,U,7) S ITM=$P($$CPT^ICPTCOD(+$P(LN,U,7),DT),U,2)
"RTN","IBCRBC3",80,0)
 W !,"Adding",?11,RVCD,?19,$J($P(LN,U,3),3),?28,"$",$J($P(LN,U,2),8,2),?41,$E(BS,U,26),?69,$E(ITM,1,11)
"RTN","IBCRBC3",81,0)
 Q
"RTN","IBCRBE")
0^44^B31355983
"RTN","IBCRBE",1,0)
IBCRBE ;ALB/ARH - RATES: BILL ENTER/EDIT (RS/CS) SCREEN ; 22-MAY-1996
"RTN","IBCRBE",2,0)
 ;;2.0;INTEGRATED BILLING;**52,106,245,287,447**;21-MAR-94;Build 80
"RTN","IBCRBE",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IBCRBE",4,0)
 ; 
"RTN","IBCRBE",5,0)
EDIT(IBIFN) ; ENTRY POINT from Enter/Edit a Bill option:  
"RTN","IBCRBE",6,0)
 ; display available Schedules/Sets for a bill, allow the user to choose the ones to use,
"RTN","IBCRBE",7,0)
 ; then recalculate the bills charges
"RTN","IBCRBE",8,0)
 ;
"RTN","IBCRBE",9,0)
 N IBSRTARR,IBCHGARR,IBUCHGAR I '$G(IBIFN) G EDITQ
"RTN","IBCRBE",10,0)
 ;
"RTN","IBCRBE",11,0)
 I '$$DISPLAY(IBIFN,.IBSRTARR) G EDITQ
"RTN","IBCRBE",12,0)
 ;
"RTN","IBCRBE",13,0)
 I '$$SELCT(IBIFN,.IBSRTARR,.IBCHGARR) G EDITQ
"RTN","IBCRBE",14,0)
 ;
"RTN","IBCRBE",15,0)
 I $O(IBCHGARR(0)) D BILL^IBCRBC(IBIFN,.IBCHGARR)
"RTN","IBCRBE",16,0)
 ;
"RTN","IBCRBE",17,0)
 I $O(IBCHGARR(0)),$$SELITEMS^IBCRBEI(IBIFN,.IBCHGARR,.IBUCHGAR) D BILLITEM^IBCRBC(IBIFN,.IBUCHGAR)
"RTN","IBCRBE",18,0)
 ;
"RTN","IBCRBE",19,0)
EDITQ Q
"RTN","IBCRBE",20,0)
 ;
"RTN","IBCRBE",21,0)
DISPLAY(IBIFN,IBSRTARR) ; get list of all RS/CS combinations available for use on the bill
"RTN","IBCRBE",22,0)
 ; sort them in name order then display the results to the screen, returns 1 if some found
"RTN","IBCRBE",23,0)
 N IB0,IBU,IBC,IBRSARR K IBSRTARR S IBC=1
"RTN","IBCRBE",24,0)
 ;
"RTN","IBCRBE",25,0)
 S IB0=$G(^DGCR(399,+$G(IBIFN),0)) I IB0="" S IBC=0 G DISPQ
"RTN","IBCRBE",26,0)
 S IBU=$G(^DGCR(399,+$G(IBIFN),"U")) I 'IBU S IBC=0 G DISPQ
"RTN","IBCRBE",27,0)
 D RT^IBCRU3($P(IB0,U,7),+$P(IB0,U,5),$P(IBU,U,1,2),.IBRSARR)
"RTN","IBCRBE",28,0)
 ;
"RTN","IBCRBE",29,0)
 I 'IBRSARR D NONE($P(IB0,U,1),$P(IB0,U,7),+$P(IB0,U,5),$P(IB0,U,3)),WAIT S IBC=0 G DISPQ
"RTN","IBCRBE",30,0)
 ;
"RTN","IBCRBE",31,0)
 D SORTBRS(.IBRSARR,.IBSRTARR,$P(IB0,U,27)),DISPRS($P(IB0,U,7),$P(IB0,U,5),.IBSRTARR)
"RTN","IBCRBE",32,0)
 ;
"RTN","IBCRBE",33,0)
DISPQ Q IBC
"RTN","IBCRBE",34,0)
 ;
"RTN","IBCRBE",35,0)
SORTBRS(IBRSARR,IBSRTARR,IBBCT) ; return array in rs name, cs name sorted order with external form of data
"RTN","IBCRBE",36,0)
 ; input:   IBRSARR(rate sched IFN,charge set IFN) = true if auto add
"RTN","IBCRBE",37,0)
 ; output:  IBSRTARR = CNT of RS/CS to be auto added ^ total CNT
"RTN","IBCRBE",38,0)
 ;          IBSRTARR(CNT) = rs IFN ^ cs IFN ^ rs name ^ cs name ^ auto add ^ unassoc event ^ chg type ^ disp set
"RTN","IBCRBE",39,0)
 ;
"RTN","IBCRBE",40,0)
 N IBRS,IBCS,IBRSN,IBCSN,IBAA,IBUA,IBCT,IBTCNT,IBACNT,IBLN,IBS,ARRX K IBSRTARR S IBBCT=+$G(IBBCT)
"RTN","IBCRBE",41,0)
 S IBRS=0 F  S IBRS=$O(IBRSARR(IBRS)) Q:'IBRS  D
"RTN","IBCRBE",42,0)
 . S IBCS=0 F  S IBCS=$O(IBRSARR(IBRS,IBCS)) Q:'IBCS  D
"RTN","IBCRBE",43,0)
 .. S IBAA=IBRSARR(IBRS,IBCS),IBRSN=$P($G(^IBE(363,+IBRS,0)),U,1),IBCSN=$P($G(^IBE(363.1,+IBCS,0)),U,1)
"RTN","IBCRBE",44,0)
 .. S IBUA=$S($$CSBR^IBCRU3(IBCS)["UNASSOCIATE":1,1:0),IBCT=$P($G(^IBE(363.1,+IBCS,0)),U,4)
"RTN","IBCRBE",45,0)
 .. S IBS=$S('IBAA:2,(+IBBCT&(IBBCT'=IBCT)):1,1:" ")_$S(IBCT=1:"I",IBCT=2:"P",1:" ")
"RTN","IBCRBE",46,0)
 .. I IBRSN'="",IBCSN'="" S ARRX(IBS_IBRSN_IBRS_IBCS,IBCSN)=IBRS_U_IBCS_U_IBRSN_U_IBCSN_U_IBAA_U_IBUA_U_IBCT_U_IBS
"RTN","IBCRBE",47,0)
 ;
"RTN","IBCRBE",48,0)
 S (IBTCNT,IBACNT)=0,IBRSN="" F  S IBRSN=$O(ARRX(IBRSN)) Q:IBRSN=""  D
"RTN","IBCRBE",49,0)
 . S IBCSN="" F  S IBCSN=$O(ARRX(IBRSN,IBCSN)) Q:IBCSN=""  D
"RTN","IBCRBE",50,0)
 .. S IBLN=ARRX(IBRSN,IBCSN),IBTCNT=IBTCNT+1 I 'IBRSN S IBACNT=IBACNT+1
"RTN","IBCRBE",51,0)
 .. S IBSRTARR(IBTCNT)=IBLN
"RTN","IBCRBE",52,0)
 S IBSRTARR=IBACNT_U_IBTCNT
"RTN","IBCRBE",53,0)
 Q
"RTN","IBCRBE",54,0)
 ;
"RTN","IBCRBE",55,0)
DISPRS(RT,BT,IBSRTARR) ; display available rate schedules and charge sets for a bill
"RTN","IBCRBE",56,0)
 N RTN,IBCNT,IBLN,IBLAST S RTN=$P($G(^DGCR(399.3,+$G(RT),0)),U,1),BT=$G(BT)
"RTN","IBCRBE",57,0)
 W @IOF,!?5,"Rate Schedules available for an "_$S(BT>2:"Outpatient ",BT>0:"Inpatient ",1:"")_$E(RTN,1,27)_" bill"
"RTN","IBCRBE",58,0)
 W !,"------------------------------------------------------------------------------"
"RTN","IBCRBE",59,0)
 ;
"RTN","IBCRBE",60,0)
 S IBCNT=0 F  S IBCNT=$O(IBSRTARR(IBCNT)) Q:'IBCNT  D
"RTN","IBCRBE",61,0)
 . S IBLN=$G(IBSRTARR(IBCNT)) I +$P(IBLN,U,8)'=+$G(IBLAST) W ! S IBLAST=+$P(IBLN,U,8)
"RTN","IBCRBE",62,0)
 . W !,?3,IBCNT,")",?8,$P(IBLN,U,3),?31,$P(IBLN,U,4),?69,$S(+$P(IBLN,U,7)=1:"INST",$P(IBLN,U,7)=2:"PROF",1:""),?75,$S(+$P(IBLN,U,6):"s",1:""),?77,$S('$P(IBLN,U,5):"*",1:"")
"RTN","IBCRBE",63,0)
 ;
"RTN","IBCRBE",64,0)
 Q
"RTN","IBCRBE",65,0)
 ;
"RTN","IBCRBE",66,0)
SELCT(IBIFN,IBSRTARR,IBCHGARR) ; get the user selection of rs/cs charges to add to the bill
"RTN","IBCRBE",67,0)
 ; input:   IBSRTARR = CNT of RS/CS to be auto added ^ total CNT
"RTN","IBCRBE",68,0)
 ;          IBSRTARR(CNT) = rs IFN ^ cs IFN ^ rs name ^ cs name ^ Auto Add ^ unassoc event ^ chg type ^ disp set
"RTN","IBCRBE",69,0)
 ; output:  IBCHGARR(rate sched IFN,charge set IFN) = 1 - add charges for rs/cs
"RTN","IBCRBE",70,0)
 ;
"RTN","IBCRBE",71,0)
 N IBCHNG,IBSEL,IBI,IBS,IBX,IBLN,DIR,DIRUT,DUOUT,DTOUT,X,Y K IBCHGARR S IBCHNG=0 I '$G(IBIFN) G SELCTQ
"RTN","IBCRBE",72,0)
 I '$O(IBSRTARR(0)) G SELCTQ
"RTN","IBCRBE",73,0)
 ;
"RTN","IBCRBE",74,0)
 S DIR("?")="Enter the number (1-"_+$P(IBSRTARR,U,2)_") preceding the Rate Schedule/Charge Sets that apply to this bill.  All associated charges will be added to the bill."
"RTN","IBCRBE",75,0)
 S DIR("?",1)="* - these charges are available to be added to this bill if selected here,"
"RTN","IBCRBE",76,0)
 S DIR("?",2)="    but will not be added when the bills charges are automatically calculated."
"RTN","IBCRBE",77,0)
 S DIR("?",3)="s - the items these charges are associated with must be specifically"
"RTN","IBCRBE",78,0)
 S DIR("?",4)="    selected here, they do not relate to any item on the bill.",DIR("?",5)=" "
"RTN","IBCRBE",79,0)
 S DIR("?",6)="If the bill's charge type is exclusively institutional or professional then"
"RTN","IBCRBE",80,0)
 S DIR("?",7)="only sets of charges with a corresponding type will be added when the bills"
"RTN","IBCRBE",81,0)
 S DIR("?",8)="charges are automatically calculated.  On this screen, these charges will be"
"RTN","IBCRBE",82,0)
 S DIR("?",9)="displayed in the first set and used as the selection default.",DIR("?",10)=" "
"RTN","IBCRBE",83,0)
 S DIR("??")="^D HELP^IBCRBE("_IBIFN_")"
"RTN","IBCRBE",84,0)
 S DIR("A")="Select Schedule Charges to ADD to the bill: " I +IBSRTARR S DIR("B")="1-"_+IBSRTARR
"RTN","IBCRBE",85,0)
 ;
"RTN","IBCRBE",86,0)
 ; Clear the manually edited flag. IB*2.0*447 BI
"RTN","IBCRBE",87,0)
 D CMAEDALL^IBCU9(IBIFN)
"RTN","IBCRBE",88,0)
 ;
"RTN","IBCRBE",89,0)
 W !! S DIR(0)="LOA^1:"_+$P(IBSRTARR,U,2) D ^DIR K DIR I 'Y!$D(DIRUT) G SELCTQ
"RTN","IBCRBE",90,0)
 ;
"RTN","IBCRBE",91,0)
 S IBX="" F  S IBX=$O(Y(IBX)) Q:IBX=""  D
"RTN","IBCRBE",92,0)
 . S IBSEL=Y(IBX) F IBI=1:1:100 S IBS=$P(IBSEL,",",IBI) Q:'IBS  D
"RTN","IBCRBE",93,0)
 .. I $D(IBSRTARR(IBS)) S IBCHNG=1,IBLN=IBSRTARR(IBS),IBCHGARR(+IBLN,$P(IBLN,U,2))=1
"RTN","IBCRBE",94,0)
 ;
"RTN","IBCRBE",95,0)
SELCTQ Q IBCHNG
"RTN","IBCRBE",96,0)
 ;
"RTN","IBCRBE",97,0)
NONE(IBBN,RT,BT,EVDT) ; write message indicating no rate schedules defined for this bill
"RTN","IBCRBE",98,0)
 N IBRTN S BT=+$G(BT),EVDT=$G(EVDT),IBRTN=$P($G(^DGCR(399.3,+$G(RT),0)),U,1)
"RTN","IBCRBE",99,0)
 W !,?7 I +EVDT W !,?7,"On ",$$DATE^IBCRU1(+EVDT),", there are "
"RTN","IBCRBE",100,0)
 W "No Rate Schedules with charges defined "
"RTN","IBCRBE",101,0)
 I IBRTN'="" W:+EVDT !,?20 W "for ",$S(BT>2:"Outpatient ",BT>0:"Inpatient ",1:""),IBRTN
"RTN","IBCRBE",102,0)
 I $G(IBBN)'="" W !!,?7,"Therefore, charges can not be calculated for this bill (",IBBN,") "
"RTN","IBCRBE",103,0)
 W !
"RTN","IBCRBE",104,0)
 Q
"RTN","IBCRBE",105,0)
 ;
"RTN","IBCRBE",106,0)
WAIT N DIR,DIRUT,DUOUT,DTOUT,Y,X S DIR("A")="Press RETURN to continue",DIR(0)="E" D ^DIR K DIR
"RTN","IBCRBE",107,0)
 Q
"RTN","IBCRBE",108,0)
 ;
"RTN","IBCRBE",109,0)
HELP(IBIFN) ; display rs/cs for the bill - used as help text
"RTN","IBCRBE",110,0)
 N IBX I +$G(IBIFN) S IBX=$$DISPLAY(IBIFN)
"RTN","IBCRBE",111,0)
 Q
"RTN","IBCRBF")
0^49^B10793881
"RTN","IBCRBF",1,0)
IBCRBF ;ALB/ARH - RATES: BILL FILE CHARGES ;22-MAY-1996
"RTN","IBCRBF",2,0)
 ;;2.0;INTEGRATED BILLING;**52,106,51,447**;21-MAR-94;Build 80
"RTN","IBCRBF",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IBCRBF",4,0)
 ;
"RTN","IBCRBF",5,0)
ADDRC(IBIFN,IBRVCD,IBBS,IBCHG,IBUNITS,IBCPT,IBDIV,IBAA,IBITYP,IBIPTR,IBCMPNT) ; add a revenue code charge entry to a bill (399,42)
"RTN","IBCRBF",6,0)
 ; returns DA of new entry or -1
"RTN","IBCRBF",7,0)
 N X,Y,DA,DLAYGO,DIC,DIE,DR,IBDA,DGXRF1,Z,Z1 S IBDA=-1
"RTN","IBCRBF",8,0)
 ;
"RTN","IBCRBF",9,0)
 ; START IB*2.0*447 BI ZERO DOLLAR CHANGES
"RTN","IBCRBF",10,0)
 ;I ($G(IBCHG)'>0)!('$G(IBUNITS)) G ADDRCQ
"RTN","IBCRBF",11,0)
 I '$G(IBUNITS) G ADDRCQ
"RTN","IBCRBF",12,0)
 ; END IB*2.0*447 BI ZERO DOLLAR CHANGES
"RTN","IBCRBF",13,0)
 I $G(^DGCR(399,+$G(IBIFN),0))="" G ADDRCQ
"RTN","IBCRBF",14,0)
 I '$P($G(^DGCR(399.2,+$G(IBRVCD),0)),U,3) G ADDRCQ
"RTN","IBCRBF",15,0)
 I '$P($G(^DGCR(399.1,+$G(IBBS),0)),U,5) G ADDRCQ
"RTN","IBCRBF",16,0)
 S IBCPT=$G(IBCPT) I +IBCPT,$$CPT^ICPTCOD(+IBCPT,DT)<1 G ADDRCQ
"RTN","IBCRBF",17,0)
 S IBDIV=$G(IBDIV) I +IBDIV,'$D(^DG(40.8,+IBDIV,0)) G ADDRCQ
"RTN","IBCRBF",18,0)
 S IBCHG=+$FN(IBCHG,"",2)
"RTN","IBCRBF",19,0)
 ;
"RTN","IBCRBF",20,0)
 I $$NOIPINST(IBIFN),$$RCDUP(IBIFN,IBRVCD,IBITYP,IBIPTR,.IBCHG) S IBCHG=+$FN(IBCHG,"",2) G ADDRCQ  ; ADDED TO PREVENT DUPLICATE REVENUE CODES IB*2.0*447 BI
"RTN","IBCRBF",21,0)
 ;
"RTN","IBCRBF",22,0)
 K DD,DO S DIC("P")=$P(^DD(399,42,0),U,2)
"RTN","IBCRBF",23,0)
 S DLAYGO=399,DA(1)=IBIFN,DIC="^DGCR(399,"_DA(1)_",""RC"",",DIC(0)="L",X=IBRVCD D FILE^DICN G:Y<1 ADDRCQ
"RTN","IBCRBF",24,0)
 ;
"RTN","IBCRBF",25,0)
 S DR=".02////"_IBCHG_";.03////"_IBUNITS_";.05////"_IBBS
"RTN","IBCRBF",26,0)
 I +IBCPT S DR=DR_";.06////"_IBCPT I +IBDIV S DR=DR_";.07////"_IBDIV
"RTN","IBCRBF",27,0)
 I +$G(IBAA) S DR=DR_";.08////1"
"RTN","IBCRBF",28,0)
 I +$G(IBITYP)>0,IBITYP<10 S DR=DR_";.1////"_IBITYP I +$G(IBIPTR) S DR=DR_";.11////"_IBIPTR
"RTN","IBCRBF",29,0)
 I +$G(IBCMPNT)>0,IBCMPNT<3 S DR=DR_";.12////"_IBCMPNT
"RTN","IBCRBF",30,0)
 I IBITYP=3,IBIPTR D
"RTN","IBCRBF",31,0)
 . N Z
"RTN","IBCRBF",32,0)
 . S Z=+$O(^TMP("IBCRRX",$J,IBIPTR,0))
"RTN","IBCRBF",33,0)
 . I Z S DR=DR_";.15////"_Z K ^TMP("IBCRRX",$J,IBIPTR,Z)
"RTN","IBCRBF",34,0)
 S (DA,IBDA)=+Y,DIE=DIC D ^DIE
"RTN","IBCRBF",35,0)
 ;
"RTN","IBCRBF",36,0)
ADDRCQ Q IBDA
"RTN","IBCRBF",37,0)
 ;
"RTN","IBCRBF",38,0)
DELALLRC(IBIFN) ; delete all charges on the bill that were automatically calculated and added
"RTN","IBCRBF",39,0)
 ;
"RTN","IBCRBF",40,0)
 N IBI,DA,DIK,X,Y,DGXRF1,Z,Z1
"RTN","IBCRBF",41,0)
 K ^TMP("IBCRRX",$J)
"RTN","IBCRBF",42,0)
 I +$G(IBIFN) S IBI=0 F  S IBI=$O(^DGCR(399,+IBIFN,"RC",IBI)) Q:'IBI  D
"RTN","IBCRBF",43,0)
 . N Z0
"RTN","IBCRBF",44,0)
 . S Z0=$G(^DGCR(399,+IBIFN,"RC",IBI,0))
"RTN","IBCRBF",45,0)
 . I '$P(Z0,U,8) Q
"RTN","IBCRBF",46,0)
 . I $$NOIPINST(IBIFN),+$P(Z0,U,16) Q  ; Don't delete if MANUALLY EDITED, IB*2.0*447 BI
"RTN","IBCRBF",47,0)
 . ; Capture revenue codes and their relation to prescriptions
"RTN","IBCRBF",48,0)
 . I $P(Z0,U,15) S ^TMP("IBCRRX",$J,+$P(Z0,U,11),$P(Z0,U,15))=""
"RTN","IBCRBF",49,0)
 . ; Be careful changing the name of this array - this is used in index
"RTN","IBCRBF",50,0)
 . ; ADPR - file 399.042, fields .01 and .03 to determine if the RX
"RTN","IBCRBF",51,0)
 . ; procedures should be deleted when the revenue codes are
"RTN","IBCRBF",52,0)
 . S DA(1)=+IBIFN,DA=IBI,DIK="^DGCR(399,"_DA(1)_",""RC""," D ^DIK K DIK
"RTN","IBCRBF",53,0)
 Q
"RTN","IBCRBF",54,0)
 ;
"RTN","IBCRBF",55,0)
RCDUP(IBIFN,IBRVCD,IBITYP,IBIPTR,IBCHG) ; Check for duplicate Revenue Codes for the same Charge Code
"RTN","IBCRBF",56,0)
 ; IB*2.0*447 BI
"RTN","IBCRBF",57,0)
 ; Inputs: IBIFN  - Bill/Claim IEN
"RTN","IBCRBF",58,0)
 ;         IBIPTR - Charge Code Multiple IEN
"RTN","IBCRBF",59,0)
 ; Output: RCDUP  - 0=No Duplicate, 1=Duplicate Exists
"RTN","IBCRBF",60,0)
 ;
"RTN","IBCRBF",61,0)
 N RCLOOP,RC0
"RTN","IBCRBF",62,0)
 N RCDUP S RCDUP=0
"RTN","IBCRBF",63,0)
 I $G(IBIFN)="" Q RCDUP
"RTN","IBCRBF",64,0)
 S RCLOOP=0 F  S RCLOOP=$O(^DGCR(399,IBIFN,"RC",RCLOOP)) Q:+RCLOOP=0!(RCDUP=1)  D
"RTN","IBCRBF",65,0)
 . S RC0=$G(^DGCR(399,IBIFN,"RC",RCLOOP,0)) Q:RC0=""  Q:'$P(RC0,U,16)
"RTN","IBCRBF",66,0)
 . I $P(RC0,U,1)=IBRVCD,$P(RC0,U,10)=IBITYP,$P(RC0,U,11)=IBIPTR S IBCHG=$P(RC0,U,2),RCDUP=1
"RTN","IBCRBF",67,0)
 Q RCDUP
"RTN","IBCRBF",68,0)
 ;
"RTN","IBCRBF",69,0)
NOIPINST(IBIFN) ; Test for Not Inpatient Institutional.
"RTN","IBCRBF",70,0)
 ; Returns a 1 if the claim is not an Inpatient Institutional claim.
"RTN","IBCRBF",71,0)
 Q '($$INPAT^IBCEF(IBIFN)&($P($G(^DGCR(399,+$G(IBIFN),0)),U,27)=1))
"RTN","IBCRCC")
0^60^B34225525
"RTN","IBCRCC",1,0)
IBCRCC ;ALB/ARH - RATES: CALCULATION OF ITEM CHARGE ;22-MAY-1996
"RTN","IBCRCC",2,0)
 ;;2.0;INTEGRATED BILLING;**52,80,106,138,245,223,309,347,370,383,427,455,447**;21-MAR-94;Build 80
"RTN","IBCRCC",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCRCC",4,0)
 ;
"RTN","IBCRCC",5,0)
 ; ITMCHG and RATECHG are basic item/set/rate charge functions, IBCRCI contains more standard callable functions
"RTN","IBCRCC",6,0)
 ;
"RTN","IBCRCC",7,0)
ITMCHG(CS,ITEM,EVDT,MOD,ARR) ; get the base unit charges for a specific item, given a charge set, item and date
"RTN","IBCRCC",8,0)
 ; this is the primary function to get an item charge and works for all Charge Methods, given an Item
"RTN","IBCRCC",9,0)
 ; returns ARR = count of items in array ^ total charge for item ^ total base charge
"RTN","IBCRCC",10,0)
 ;         ARR(x) = charge item IFN (if any) ^ rev code (if any) ^ $ charge ^ $ base charge
"RTN","IBCRCC",11,0)
 ; checks Item effective and inactive dates, modifier match, and only sets array if the charge is non-zero
"RTN","IBCRCC",12,0)
 ; each item will be passed back separately in the array, no combination of charges
"RTN","IBCRCC",13,0)
 ;
"RTN","IBCRCC",14,0)
 N IBCSBR,IBEVDT,IBEFDT,IBXREF,IBITEM,IBDA,IBLN,IBCHRG,IBITMFND K ARR S ARR=0
"RTN","IBCRCC",15,0)
 S CS=+$G(CS),IBEVDT=$S(+$G(EVDT):+EVDT,1:DT),IBITEM=+$G(ITEM),MOD=$G(MOD) I 'CS!'IBITEM Q
"RTN","IBCRCC",16,0)
 S IBCSBR=$$CSBR^IBCRU3(CS)
"RTN","IBCRCC",17,0)
 ;
"RTN","IBCRCC",18,0)
 ; va cost
"RTN","IBCRCC",19,0)
 I $P(IBCSBR,U,5)=2 D  Q  ; va cost
"RTN","IBCRCC",20,0)
 . I $P(IBCSBR,U,1)["PROSTHETICS" S IBCHRG=$$PICOST(IBITEM)  I +IBCHRG D SETARR(0,0,+IBCHRG,.ARR) Q
"RTN","IBCRCC",21,0)
 . I $P(IBCSBR,U,1)["PRESCRIPTION" S IBCHRG=$$RXCOST(IBITEM) I +IBCHRG D SETARR(0,0,+IBCHRG,.ARR) Q
"RTN","IBCRCC",22,0)
 ;
"RTN","IBCRCC",23,0)
 ; all others - have Charge Item entries
"RTN","IBCRCC",24,0)
 ;
"RTN","IBCRCC",25,0)
 ; find most recent Charge Item for the item, search until modifiers match (only BI=CPT should have mods defined)
"RTN","IBCRCC",26,0)
 S IBXREF="AIVDTS"_CS,IBITMFND=0
"RTN","IBCRCC",27,0)
 S IBEFDT=-(IBEVDT+.01) F  S IBEFDT=$O(^IBA(363.2,IBXREF,IBITEM,IBEFDT)) Q:'IBEFDT  D  Q:IBITMFND
"RTN","IBCRCC",28,0)
 . S IBDA=0 F  S IBDA=$O(^IBA(363.2,IBXREF,IBITEM,IBEFDT,IBDA)) Q:'IBDA  D
"RTN","IBCRCC",29,0)
 .. S IBLN=$G(^IBA(363.2,IBDA,0))
"RTN","IBCRCC",30,0)
 .. I +$P(IBLN,U,7)'=+MOD Q  ; charge item modifier does not match modifier passed in
"RTN","IBCRCC",31,0)
 .. S IBITMFND=1 ; item found
"RTN","IBCRCC",32,0)
 .. I +$P(IBLN,U,4),+$P(IBLN,U,4)<IBEVDT Q  ; charge is inactive on event date
"RTN","IBCRCC",33,0)
 .. ; START IB*2.0*447 BI ZERO DOLLAR CHANGES
"RTN","IBCRCC",34,0)
 .. ;I +$P(IBLN,U,5) D SETARR(IBDA,+$P(IBLN,U,6),+$P(IBLN,U,5),.ARR,$P(IBLN,U,8))
"RTN","IBCRCC",35,0)
 .. D SETARR(IBDA,+$P(IBLN,U,6),+$P(IBLN,U,5),.ARR,$P(IBLN,U,8))
"RTN","IBCRCC",36,0)
 .. ; END IB*2.0*447 BI ZERO DOLLAR CHANGES
"RTN","IBCRCC",37,0)
 Q
"RTN","IBCRCC",38,0)
 ;
"RTN","IBCRCC",39,0)
SETARR(CI,RVCD,CHRG,ARR,CHRGB) ; set charges into an array, does not allow zero charge, a new entry is created each time,
"RTN","IBCRCC",40,0)
 ; no attempt to combine like items, the new item charge is added to any that may already be in the array 
"RTN","IBCRCC",41,0)
 ; returns ARR = count of items in array ^ total charge for item
"RTN","IBCRCC",42,0)
 ;         ARR(x) = charge item IFN (if any) ^ item rev code (if any) ^ $ charge
"RTN","IBCRCC",43,0)
 ;
"RTN","IBCRCC",44,0)
 N CNT,TCHRG,TCHRGB
"RTN","IBCRCC",45,0)
 S CNT=+$G(ARR)+1,TCHRG=$P($G(ARR),U,2)+$G(CHRG) I +$G(CHRGB) S TCHRGB=+$P($G(ARR),U,3)+CHRGB
"RTN","IBCRCC",46,0)
 ; START IB*2.0*447 BI ZERO DOLLAR CHANGES
"RTN","IBCRCC",47,0)
 ;I +$G(CHRG) S ARR=CNT_U_+TCHRG_U_$G(TCHRGB),ARR(CNT)=$G(CI)_U_+$G(RVCD)_U_+CHRG_U_$G(TCHRGB)
"RTN","IBCRCC",48,0)
 S ARR=CNT_U_+TCHRG_U_$G(TCHRGB),ARR(CNT)=$G(CI)_U_+$G(RVCD)_U_+CHRG_U_$G(TCHRGB)
"RTN","IBCRCC",49,0)
 ; END IB*2.0*447 BI ZERO DOLLAR CHANGES
"RTN","IBCRCC",50,0)
 Q
"RTN","IBCRCC",51,0)
 ;
"RTN","IBCRCC",52,0)
PICOST(PI) ; returns (PI=ptr 362.5): total VA cost of an item (660,14) ^ quantity (660,5) from prosthetics ^ bill IFN
"RTN","IBCRCC",53,0)
 ;
"RTN","IBCRCC",54,0)
 N IBPIP,IBLN,IBX,IBIFN S (IBPIP,IBX)=0
"RTN","IBCRCC",55,0)
 I +$G(PI) S IBLN=$G(^IBA(362.5,+PI,0)),IBPIP=$P(IBLN,U,4),IBIFN=$P(IBLN,U,2)
"RTN","IBCRCC",56,0)
 I +IBPIP S IBLN=$G(^RMPR(660,+IBPIP,0)) I IBLN'="" S IBX=$P(IBLN,U,16)_U_$P(IBLN,U,7)_U_IBIFN
"RTN","IBCRCC",57,0)
 Q IBX
"RTN","IBCRCC",58,0)
 ;
"RTN","IBCRCC",59,0)
RATECHG(RS,CHG,EVDT,FEE) ; returns modifed item charge based on rate schedule:  check effective dates, apply adjustment
"RTN","IBCRCC",60,0)
 ; adjusted amount ^ comment (if there is an adjustment)
"RTN","IBCRCC",61,0)
 ; if FEE passed by reference, returns disp fee^admin fee
"RTN","IBCRCC",62,0)
 ;
"RTN","IBCRCC",63,0)
 N IBX,IBRS0,IBRS10,IBEFDT,IBINADT,IBRTY,X S IBRTY=""
"RTN","IBCRCC",64,0)
 S IBX=+$G(CHG),IBRS0=$G(^IBE(363,+$G(RS),0)),IBRS10=$G(^IBE(363,+$G(RS),10))
"RTN","IBCRCC",65,0)
 S EVDT=$S(+$G(EVDT):EVDT,1:DT),IBEFDT=$P(IBRS0,U,5),IBINADT=$P(IBRS0,U,6)
"RTN","IBCRCC",66,0)
 I +IBEFDT>EVDT!(+IBINADT&(IBINADT<EVDT)) S IBX=0
"RTN","IBCRCC",67,0)
 I +IBX,IBRS10'="" S X=IBX X IBRS10 S IBX=X,IBRTY="^Rate Schedule Adjustment ("_$J(CHG,"",2)_")"
"RTN","IBCRCC",68,0)
 S FEE=$P($G(^IBE(363,+$G(RS),1)),"^",1,2)
"RTN","IBCRCC",69,0)
 Q IBX_IBRTY
"RTN","IBCRCC",70,0)
 ;
"RTN","IBCRCC",71,0)
RXCOST(RX) ; returns (RX=ptr 362.4): VA Cost of an Rx - Per Unit Cost ^ bill IFN
"RTN","IBCRCC",72,0)
 ; w/ Per Unit Cost = Refill (Current Unit Price of Drug - 52.1,1.2) or RX (Unit Price of Drug - 52,17) or Drug (Price Per Dispense Unit - 50,16)
"RTN","IBCRCC",73,0)
 ;
"RTN","IBCRCC",74,0)
 N IBRXP,IBDGP,IBLN,IBX,IBIFN,IBDT,IBY
"RTN","IBCRCC",75,0)
 S (IBRXP,IBX,IBDGP,IBDT,IBIFN)=0,IBY=""
"RTN","IBCRCC",76,0)
 ; fill number (362.4,.1)
"RTN","IBCRCC",77,0)
 I +$G(RX) S IBLN=$G(^IBA(362.4,+RX,0)),IBRXP=$P(IBLN,U,5),IBDGP=$P(IBLN,U,4),IBIFN=$P(IBLN,U,2),IBDT=$P(IBLN,U,3),IBY=$P(IBLN,U,10)
"RTN","IBCRCC",78,0)
 I IBY="" S IBY=$$RFLNUM^IBRXUTL(IBRXP,IBDT)
"RTN","IBCRCC",79,0)
 ;
"RTN","IBCRCC",80,0)
 I IBRXP,IBY S IBX=$$SUBFILE^IBRXUTL(IBRXP,+IBY,52,1.2)_U_IBIFN
"RTN","IBCRCC",81,0)
 I IBRXP,'IBX S IBX=$$FILE^IBRXUTL(IBRXP,17)_U_IBIFN
"RTN","IBCRCC",82,0)
 I 'IBRXP,IBDGP D DATA^IBRXUTL(+IBDGP) S IBLN=$G(^TMP($J,"IBDRUG",0)) I IBLN'="" S IBX=$G(^TMP($J,"IBDRUG",+IBDGP,16))_U_IBIFN
"RTN","IBCRCC",83,0)
 ;
"RTN","IBCRCC",84,0)
 ; penny drug cost is 0
"RTN","IBCRCC",85,0)
 I $P(IBX,U,1)=0 S IBX=$$DRGCT(IBDGP)_U_IBIFN
"RTN","IBCRCC",86,0)
 K ^TMP($J,"IBDRUG")
"RTN","IBCRCC",87,0)
 Q IBX
"RTN","IBCRCC",88,0)
 ;
"RTN","IBCRCC",89,0)
 ;
"RTN","IBCRCC",90,0)
DRGCT(IBDGP) ;Penny drug cost calculation
"RTN","IBCRCC",91,0)
 ; Input - IEN
"RTN","IBCRCC",92,0)
 ; Output - true value of unit price (50-13/15)
"RTN","IBCRCC",93,0)
 N IBCUT,IBX,IBY S IBCUT=0
"RTN","IBCRCC",94,0)
 G:'IBDGP DRGCTQ
"RTN","IBCRCC",95,0)
 D:'$D(^TMP($J,"IBDRUG")) DATA^IBRXUTL(+IBDGP)
"RTN","IBCRCC",96,0)
 S IBX=$G(^TMP($J,"IBDRUG",+IBDGP,13))
"RTN","IBCRCC",97,0)
 S IBY=$G(^TMP($J,"IBDRUG",+IBDGP,15))
"RTN","IBCRCC",98,0)
 I IBX,IBY S IBCUT=$J(IBX/IBY,1,4),IBCUT=$S(IBCUT>0:IBCUT,1:0.0001)
"RTN","IBCRCC",99,0)
DRGCTQ Q IBCUT
"RTN","IBCRCC",100,0)
 ;
"RTN","IBCRCC",101,0)
PRVCHG(CS,CHG,PRV,EVDT,ITEM) ; return discounted amount, based on total charge for a the care, the provider and Charge Set (BR)
"RTN","IBCRCC",102,0)
 ; if no discount record found for the Charge Set or the provider then returns original amount
"RTN","IBCRCC",103,0)
 ; no provider discount for Lab charges (80000-89999)
"RTN","IBCRCC",104,0)
 ;   discounted amount ^ comment (if discounted) ^ percent discount
"RTN","IBCRCC",105,0)
 ;
"RTN","IBCRCC",106,0)
 N IBPC,IBSGFN,IBSG,IBPDFN,IBPD0,IBPDTY,IBI,IBX,IBY S IBX=+$G(CHG),(IBSGFN,IBPDTY)="" I '$G(EVDT) S EVDT=DT
"RTN","IBCRCC",107,0)
 I +$G(ITEM),ITEM>79999,ITEM<90000 S (CS,PRV)=""
"RTN","IBCRCC",108,0)
 I +$G(CS) S IBSGFN=+$$CSSG^IBCRU6(+CS,"",2,.IBSG)
"RTN","IBCRCC",109,0)
 I +$G(PRV),+IBSGFN S IBPC=$$GET^XUA4A72(PRV,EVDT)
"RTN","IBCRCC",110,0)
 ;
"RTN","IBCRCC",111,0)
 S IBI=0 F  S IBI=$O(IBSG(IBI)) Q:'IBI  S IBSGFN=+IBSG(IBI) I +IBSGFN D
"RTN","IBCRCC",112,0)
 . S IBPDFN=0 F  S IBPDFN=$O(^IBE(363.34,"C",+IBSGFN,IBPDFN)) Q:'IBPDFN  D  Q:IBPDTY'=""
"RTN","IBCRCC",113,0)
 .. I '$O(^IBE(363.34,+IBPDFN,11,"B",+IBPC,0)) Q
"RTN","IBCRCC",114,0)
 .. S IBPD0=$G(^IBE(363.34,+IBPDFN,0)),IBY=$P(IBPD0,U,3) Q:IBY=""
"RTN","IBCRCC",115,0)
 .. S IBY=+IBY/100,IBX=IBY*IBX
"RTN","IBCRCC",116,0)
 .. S IBPDTY=U_$P($G(^VA(200,+PRV,0)),U,1)_" - "_$P(IBPD0,U,1)_" "_$P(IBPD0,U,3)_"% of "_$J(CHG,0,2)_U_+IBY
"RTN","IBCRCC",117,0)
 Q IBX_IBPDTY
"RTN","IBCRCC",118,0)
 ;
"RTN","IBCRCC",119,0)
MODCHG(CS,CHG,MODS) ; return adjusted amount due to RC modifier adjustment
"RTN","IBCRCC",120,0)
 ; straight adjustment for RC Physician charges by modifier, if no modifier adjustment returns original amount
"RTN","IBCRCC",121,0)
 ; Input:  Charge Set, Procedure Charge, Modifiers - list with modifier IEN's separated by ','
"RTN","IBCRCC",122,0)
 ; Output: discounted amount ^ comment (if discounted) ^ percent discount
"RTN","IBCRCC",123,0)
 ;
"RTN","IBCRCC",124,0)
 N IBCS0,IBBR0,IBMOD,IBMODS,IBMODE,IBDSCNT,IBPDTY,IBI,IBX,IBY
"RTN","IBCRCC",125,0)
 S CHG=+$G(CHG),MODS=$G(MODS),(IBBR0,IBPDTY,IBMODS)="",IBDSCNT=1,IBX=+CHG
"RTN","IBCRCC",126,0)
 I +$G(CS) S IBCS0=$G(^IBE(363.1,+CS,0)),IBBR0=$G(^IBE(363.3,+$P(IBCS0,U,2),0))
"RTN","IBCRCC",127,0)
 I $P(IBBR0,U,1)'["RC PHYSICIAN" S MODS="" ; professional charge only
"RTN","IBCRCC",128,0)
 I $P(IBBR0,U,4)'=2 S MODS="" ; CPT item only
"RTN","IBCRCC",129,0)
 I 'CHG S MODS=""
"RTN","IBCRCC",130,0)
 ;
"RTN","IBCRCC",131,0)
 I +MODS F IBI=1:1 S IBMOD=$P(MODS,",",IBI) Q:'IBMOD  S IBY=0 D
"RTN","IBCRCC",132,0)
 . I IBMOD=3 S IBMODE=22,IBY=1.3,IBX=IBX*IBY ; modifier 22 at 120% adjustment
"RTN","IBCRCC",133,0)
 . I IBMOD=10 S IBMODE=50,IBY=1.54,IBX=IBX*IBY ; modifier 50 at 154% adjustment
"RTN","IBCRCC",134,0)
 . I +IBY S IBMODS=IBMODS_$S(IBMODS="":"",1:",")_IBMODE,IBDSCNT=IBDSCNT*IBY ; allow for multiple discounts
"RTN","IBCRCC",135,0)
 I IBMODS'="" S IBPDTY=U_"Modifier "_IBMODS_" Adjustment "_(IBDSCNT*100)_"% of "_$J(CHG,0,2)_U_+IBDSCNT
"RTN","IBCRCC",136,0)
 Q IBX_IBPDTY
"RTN","IBCRCC",137,0)
 ;
"RTN","IBCRCC",138,0)
HRUNIT(HRS) ; returns Hour Units based on the Hours passed in
"RTN","IBCRCC",139,0)
 ; Hour Units are the hours rounded to the nearest whole hour (less than 30 minutes is 0 units)
"RTN","IBCRCC",140,0)
 N IBX S IBX=0 I +$G(HRS) S IBX=$J(HRS,0,0)
"RTN","IBCRCC",141,0)
 Q IBX
"RTN","IBCRCC",142,0)
 ;
"RTN","IBCRCC",143,0)
MLUNIT(MLS) ; returns Miles Units based on the Miles passed in
"RTN","IBCRCC",144,0)
 ; Mile Units are the miles rounded to the nearest whole mile
"RTN","IBCRCC",145,0)
 N IBX S IBX=0 I +$G(MLS) S IBX=$J(MLS,0,0) I 'IBX S IBX=1
"RTN","IBCRCC",146,0)
 Q IBX
"RTN","IBCRCC",147,0)
 ;
"RTN","IBCRCC",148,0)
MNUNIT(MNS) ; return Minute Units based on the Minutes passed in
"RTN","IBCRCC",149,0)
 ; Minute Units are 15 minute intervals, rounded up after any minutes
"RTN","IBCRCC",150,0)
 N IBX S IBX=0 I +$G(MNS) S IBX=(MNS\15) S:+(MNS#15) IBX=IBX+1 I 'IBX S IBX=1
"RTN","IBCRCC",151,0)
 Q IBX
"RTN","IBCSC102")
0^52^B41181952
"RTN","IBCSC102",1,0)
IBCSC102 ;ALB/MJB - MCCR SCREEN 10 (UB-04 BILL SPECIFIC INFO) ;27 MAY 88 10:20
"RTN","IBCSC102",2,0)
 ;;2.0;INTEGRATED BILLING;**432,447**;21-MAR-94;Build 80
"RTN","IBCSC102",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCSC102",4,0)
 ;
"RTN","IBCSC102",5,0)
 ; DEM;432 - Moved IBCSC8* billing screen routines to IBCSC10* billing screen
"RTN","IBCSC102",6,0)
 ;           routines and created a new billing screen 8 routine IBCSC8.
"RTN","IBCSC102",7,0)
 ;
"RTN","IBCSC102",8,0)
EN S IBCUBFT=$$FT^IBCU3(IBIFN) I IBCUBFT=2 K IBCUBFT G ^IBCSC10H ;CMS-1500
"RTN","IBCSC102",9,0)
 ;
"RTN","IBCSC102",10,0)
 N FIRSTPRV,I,IB,IBINP,IBX,PRV,PRVS,Z
"RTN","IBCSC102",11,0)
 S IBINP=$$INPAT^IBCEF(IBIFN)
"RTN","IBCSC102",12,0)
 D ^IBCSCU
"RTN","IBCSC102",13,0)
 S IBSR=10,IBSR1=2,IBV1="0000000" S:IBINP $E(IBV1,2)=1 S:IBV IBV1="1111111"
"RTN","IBCSC102",14,0)
 F I="U","U1",0,"UF3","UF31","UF32","U2","TX","U3" S IB(I)=$G(^DGCR(399,IBIFN,I))
"RTN","IBCSC102",15,0)
 N IBZ,IBPRV,IBREQ,IBMRASEC,TEXT,BPZ,TXMT,IBZCNT
"RTN","IBCSC102",16,0)
 D GETPRV^IBCEU(IBIFN,"ALL",.IBPRV)
"RTN","IBCSC102",17,0)
 K IB("PRV")
"RTN","IBCSC102",18,0)
 S IBZ=0 F  S IBZ=$O(IBPRV(IBZ)) Q:'IBZ  I $O(IBPRV(IBZ,0))!$D(IBPRV(IBZ,"NOTOPT")) M IB("PRV",IBZ)=IBPRV(IBZ)
"RTN","IBCSC102",19,0)
 ;
"RTN","IBCSC102",20,0)
 D H^IBCSCU
"RTN","IBCSC102",21,0)
 ;
"RTN","IBCSC102",22,0)
 ; Section 1
"RTN","IBCSC102",23,0)
 S Z=1,IBW=1 X IBWW W " Bill Remarks",!?5,"- FL-80",?22,": "
"RTN","IBCSC102",24,0)
 S TEXT=$P($G(^DGCR(399,IBIFN,"UF2")),U,3)  ; field# 402
"RTN","IBCSC102",25,0)
 I TEXT="" W IBUN                           ; unspecified [not required]
"RTN","IBCSC102",26,0)
 I TEXT'="" D
"RTN","IBCSC102",27,0)
 . N IBZ,Z
"RTN","IBCSC102",28,0)
 . D REMARK^IBCEF77(IBIFN,.IBZ)
"RTN","IBCSC102",29,0)
 . S Z=0 F  S Z=$O(IBZ(Z)) Q:'Z  D
"RTN","IBCSC102",30,0)
 .. W ?24,$G(IBZ(Z))
"RTN","IBCSC102",31,0)
 .. I Z>4 W ?48,$G(IBVI)," <--- This Line Will Not Print ",$G(IBVO)
"RTN","IBCSC102",32,0)
 .. I $O(IBZ(Z)) W !
"RTN","IBCSC102",33,0)
 .. Q
"RTN","IBCSC102",34,0)
 . Q
"RTN","IBCSC102",35,0)
 ;
"RTN","IBCSC102",36,0)
 S IBZCNT=0,IBZ(IBZCNT)=""
"RTN","IBCSC102",37,0)
 I $P(IB("UF3"),U,4)]"" S IBZ(IBZCNT)="P: "_$P(IB("UF3"),U,4),IBZCNT=IBZCNT+1
"RTN","IBCSC102",38,0)
 I $P(IB("UF3"),U,5)]"" S IBZ(IBZCNT)="S: "_$P(IB("UF3"),U,5),IBZCNT=IBZCNT+1
"RTN","IBCSC102",39,0)
 I $P(IB("UF3"),U,6)]"" S IBZ(IBZCNT)="T: "_$P(IB("UF3"),U,6)
"RTN","IBCSC102",40,0)
 ;S IBZ(0)="",IBZ=$S($P(IB("UF3"),U,4)]"":"Pri: "_$P(IB("UF3"),U,4),1:"")_$S($P(IB("UF3"),U,5)'="":"  Sec: "_$P(IB("UF3"),U,5),1:"")_$S($P(IB("UF3"),U,6)'="":" Ter: "_$P(IB("UF3"),U,6),1:"")
"RTN","IBCSC102",41,0)
 I IBZ(0)="",$$IBMICN^IBCBB13(IBIFN) S IBZ(0)="UNSPECIFIED [REQUIRED]"
"RTN","IBCSC102",42,0)
 S:IBZ(0)="" IBZ(0)=IBUN
"RTN","IBCSC102",43,0)
 W !?4,"ICN/DCN(s)        : ",IBZ(0)
"RTN","IBCSC102",44,0)
 F IBZCNT=1:1 Q:'$D(IBZ(IBZCNT))  W !?24,IBZ(IBZCNT)
"RTN","IBCSC102",45,0)
 K IBZ
"RTN","IBCSC102",46,0)
 S IBZCNT=0,IBZ(IBZCNT)=""
"RTN","IBCSC102",47,0)
 I $P(IB("U"),U,13)]"" S IBZ(IBZCNT)="P: "_$P(IB("U"),U,13),IBZCNT=IBZCNT+1
"RTN","IBCSC102",48,0)
 I $P(IB("U2"),U,8)'="" S IBZ(IBZCNT)="S: "_$P(IB("U2"),U,8),IBZCNT=IBZCNT+1
"RTN","IBCSC102",49,0)
 I $P(IB("U2"),U,9)'="" S IBZ(IBZCNT)="T: "_$P(IB("U2"),U,9),IBZCNT=IBZCNT+1
"RTN","IBCSC102",50,0)
 I $P(IB("UF32"),U,1)'="" S IBZ(IBZCNT)="P: "_$P(IB("UF32"),U,1),IBZCNT=IBZCNT+1
"RTN","IBCSC102",51,0)
 I $P(IB("UF32"),U,2)'="" S IBZ(IBZCNT)="S: "_$P(IB("UF32"),U,2),IBZCNT=IBZCNT+1
"RTN","IBCSC102",52,0)
 I $P(IB("UF32"),U,3)'="" S IBZ(IBZCNT)="T: "_$P(IB("UF32"),U,3)
"RTN","IBCSC102",53,0)
 S IBZ="",IBZ=$S($P(IB("U"),U,13)]"":"P: "_$P(IB("U"),U,13),1:"")
"RTN","IBCSC102",54,0)
 S:IBZ(0)="" IBZ(0)=IBUN
"RTN","IBCSC102",55,0)
 W !,?3," Auth/Referral     : ",IBZ(0)
"RTN","IBCSC102",56,0)
 F IBZCNT=1:1 Q:'$D(IBZ(IBZCNT))  W !?24,IBZ(IBZCNT)
"RTN","IBCSC102",57,0)
 K IBZ S IBZ=""
"RTN","IBCSC102",58,0)
 ;
"RTN","IBCSC102",59,0)
 ; IB*2*400 - Admitting diagnosis only for inpatients
"RTN","IBCSC102",60,0)
 I IBINP W !,?3," Admitting Dx      : " S IBX=$$ICD9^IBACSV(+IB("U2"),$$BDATE^IBACSV(IBIFN)) W $S(IBX'="":$P(IBX,U)_" - "_$P(IBX,U,3),1:IBU)
"RTN","IBCSC102",61,0)
 ;
"RTN","IBCSC102",62,0)
 ; IB*2*400 - esg - display PPS (DRG) info for inpatient, UB claims
"RTN","IBCSC102",63,0)
 I IBINP D
"RTN","IBCSC102",64,0)
 . N PPS,PPSDISP
"RTN","IBCSC102",65,0)
 . S PPS=+$P(IB("U1"),U,15)
"RTN","IBCSC102",66,0)
 . I 'PPS S PPSDISP=IBUN
"RTN","IBCSC102",67,0)
 . I PPS S PPSDISP=$$FO^IBCNEUT1(PPS,4,"R",0)_" - "_$$DRGTD^IBACSV(PPS,$$BDATE^IBACSV(IBIFN))
"RTN","IBCSC102",68,0)
 . W !?4,"PPS (DRG)",?22,": ",$E(PPSDISP,1,56)
"RTN","IBCSC102",69,0)
 . Q
"RTN","IBCSC102",70,0)
 ;
"RTN","IBCSC102",71,0)
 I 'IBINP W !,?3," Admission Source  : " S IBX=$$EXTERNAL^DILFD(399,159,,$P(IB("U"),U,9)) W $S(IBX'="":IBX,1:IBU)   ; Outpatient only
"RTN","IBCSC102",72,0)
 ;
"RTN","IBCSC102",73,0)
 ; Section 2
"RTN","IBCSC102",74,0)
 S Z=2,IBW=1 X IBWW
"RTN","IBCSC102",75,0)
 S PRVS=$TR($P(IB("U3"),U,8,10),U) W " Pt Reason f/Visit : " I PRVS="" W IBU_$S(IBINP:" [NOT USED]",1:"")
"RTN","IBCSC102",76,0)
 I PRVS'="" S FIRSTPRV=1 F I=8:1:10 D
"RTN","IBCSC102",77,0)
 .S PRV=$$ICD9^IBACSV($P(IB("U3"),U,I),$$BDATE^IBACSV(IBIFN)) I PRV'="" W:'FIRSTPRV !,?24 W $P(PRV,U,3)_" - "_$P(PRV,U) S FIRSTPRV=0
"RTN","IBCSC102",78,0)
 .Q
"RTN","IBCSC102",79,0)
 ;
"RTN","IBCSC102",80,0)
 ; Section 3
"RTN","IBCSC102",81,0)
 S Z=3,IBW=1 X IBWW
"RTN","IBCSC102",82,0)
 W " Providers         : ",$S('$O(IB("PRV",0)):IBU,1:"")
"RTN","IBCSC102",83,0)
 I $D(IB("PRV")) D
"RTN","IBCSC102",84,0)
 . N Z,IBT,IBQ,IBARR,IBTAX,IBNOTAX,IBSPEC,IBNOSPEC
"RTN","IBCSC102",85,0)
 . S IBZ=0
"RTN","IBCSC102",86,0)
 . D DEFSEC^IBCEF74(IBIFN,.IBARR)
"RTN","IBCSC102",87,0)
 . ; PRXM/KJH - Add Taxonomy code to display for patch 343. Moved secondary IDs slightly (below).
"RTN","IBCSC102",88,0)
 . S IBTAX=$$PROVTAX^IBCEF73A(IBIFN,.IBNOTAX)
"RTN","IBCSC102",89,0)
 . S IBSPEC=$$SPECTAX^IBCEF73A(IBIFN,.IBNOSPEC)
"RTN","IBCSC102",90,0)
 . F  S IBZ=$O(IB("PRV",IBZ)) Q:'IBZ  D
"RTN","IBCSC102",91,0)
 .. N A,A1
"RTN","IBCSC102",92,0)
 .. S IBQ=""
"RTN","IBCSC102",93,0)
 .. W !,?5,"- "
"RTN","IBCSC102",94,0)
 .. S A=$$EXPAND^IBTRE(399.0222,.01,IBZ)
"RTN","IBCSC102",95,0)
 .. I $P($G(IB("PRV",IBZ,1)),U,4)'="" S A1=" ("_$E($P(IB("PRV",IBZ,1),U,4),1,3)_")",A=$E(A,1,15-$L(A1))_A1
"RTN","IBCSC102",96,0)
 .. W $E(A_$J("",15),1,15),": "
"RTN","IBCSC102",97,0)
 .. I '$P($G(IB("PRV",IBZ,1)),U,3),$P($G(IB("PRV",IBZ,1)),U)="" W IBU Q
"RTN","IBCSC102",98,0)
 .. I $P($G(IB("PRV",IBZ,1)),U)'="" W:'$G(IB("PRV",IBZ)) $E($P(IB("PRV",IBZ,1),U)_$J("",20),1,20) W:$G(IB("PRV",IBZ)) "(OLD PROV DATA) "_$P(IB("PRV",IBZ,1),U)
"RTN","IBCSC102",99,0)
 .. I $P($G(IB("PRV",IBZ,1)),U)="",$P($G(IB("PRV",IBZ)),U)'="" W $E($P(IB("PRV",IBZ),U)_$J("",20),1,20)
"RTN","IBCSC102",100,0)
 .. W "    Taxonomy: ",$S($P(IBTAX,U,IBZ)'="":$P(IBTAX,U,IBZ),1:IBU),$S($P(IBSPEC,U,IBZ)'="":" ("_$P(IBSPEC,U,IBZ)_")",1:"")
"RTN","IBCSC102",101,0)
 .. F A=1:1:3 I $G(IBARR(IBZ,A))'="" S IBQ=IBQ_"["_$E("PST",A)_"]"_IBARR(IBZ,A)_" "
"RTN","IBCSC102",102,0)
 .. I $L(IBQ) W !,?30,$E(IBQ,1,49)
"RTN","IBCSC102",103,0)
 K IB("PRV")
"RTN","IBCSC102",104,0)
 ;
"RTN","IBCSC102",105,0)
 ; Section 4
"RTN","IBCSC102",106,0)
 S Z=4,IBW=1 X IBWW
"RTN","IBCSC102",107,0)
 W " Other Facility (VA/non): " S IBZ=$$EXPAND^IBTRE(399,232,+$P(IB("U2"),U,10))
"RTN","IBCSC102",108,0)
 W $S(IBZ'="":$E(IBZ,1,23),$$PSRV^IBCEU(IBIFN):IBU,1:IBUN)
"RTN","IBCSC102",109,0)
 I IBZ'="" D
"RTN","IBCSC102",110,0)
 . ; PRXM/KJH - Add Taxonomy code to display for patch 343.
"RTN","IBCSC102",111,0)
 . W ?53,"Taxonomy: "
"RTN","IBCSC102",112,0)
 . S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,3),"X12 CODE") W $S(IBZ'="":IBZ,1:IBU)
"RTN","IBCSC102",113,0)
 . S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,3),"SPECIALTY CODE") W $S(IBZ'="":" ("_IBZ_")",1:"")
"RTN","IBCSC102",114,0)
 . Q
"RTN","IBCSC102",115,0)
 ;
"RTN","IBCSC102",116,0)
 ; Section 5
"RTN","IBCSC102",117,0)
 S Z=5,IBW=1 X IBWW
"RTN","IBCSC102",118,0)
 W " Billing Provider  : "
"RTN","IBCSC102",119,0)
 K IBZ
"RTN","IBCSC102",120,0)
 S BPZ=+$$B^IBCEF79(IBIFN)
"RTN","IBCSC102",121,0)
 D GETBP^IBCEF79(IBIFN,"",BPZ,"UB SCREEN 8",.IBZ)
"RTN","IBCSC102",122,0)
 S TXMT=$$TXMT^IBCEF4(IBIFN)    ; transmittable?  variable also used in next section
"RTN","IBCSC102",123,0)
 I TXMT S IBZ=$G(IBZ("UB SCREEN 8","NAME"))     ; this is the BP name used in the PRV segment
"RTN","IBCSC102",124,0)
 I 'TXMT S IBZ=$$GETFAC^IBCEP8(BPZ,0,0)         ; this is the BP name printed in FL-1
"RTN","IBCSC102",125,0)
 W $S(IBZ'="":IBZ,1:IBU)                        ; billing provider name
"RTN","IBCSC102",126,0)
 W !?3," Taxonomy Code     : "
"RTN","IBCSC102",127,0)
 S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,11),"X12 CODE") W $S(IBZ'="":IBZ,1:IBU)
"RTN","IBCSC102",128,0)
 S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,11),"SPECIALTY CODE") W $S(IBZ'="":" ("_IBZ_")",1:"")
"RTN","IBCSC102",129,0)
 ;
"RTN","IBCSC102",130,0)
 ; Section 6
"RTN","IBCSC102",131,0)
 S IBREQ=+$$REQMRA^IBEFUNC(IBIFN) S:IBREQ IBREQ=1
"RTN","IBCSC102",132,0)
 S IBMRASEC=$$MRASEC^IBCEF4(IBIFN)
"RTN","IBCSC102",133,0)
 S Z=6,IBW=1 X IBWW W " ",$S('IBREQ:"Force To Print?   : ",1:"Force MRA Sec Prt?: ")
"RTN","IBCSC102",134,0)
 S IBZ=$$EXTERNAL^DILFD(399,27+IBREQ,,+$P(IB("TX"),U,8+IBREQ))
"RTN","IBCSC102",135,0)
 I IBMRASEC,'$P(IB("TX"),U,8),$P(IB("TX"),U,9) S IBZ="FORCED TO PRINT BY MRA PRIMARY",$P(IB("TX"),U,8)=0
"RTN","IBCSC102",136,0)
 W $S(IBZ'=""&($P(IB("TX"),U,8+IBREQ)'=""):IBZ,'TXMT:"[NOT APPLICABLE - NOT TRANSMITTABLE]",IBREQ:"NO FORCED PRINT",1:IBZ)
"RTN","IBCSC102",137,0)
 ;
"RTN","IBCSC102",138,0)
 ; Section 7
"RTN","IBCSC102",139,0)
 S Z=7,IBW=1 X IBWW
"RTN","IBCSC102",140,0)
 W " Provider ID Maint : (Edit Provider ID information)"
"RTN","IBCSC102",141,0)
 ;
"RTN","IBCSC102",142,0)
 G ^IBCSCP
"RTN","IBCSC102",143,0)
Q Q
"RTN","IBCSC102",144,0)
 ;IBCSC102
"RTN","IBCSC11")
0^8^B7658686
"RTN","IBCSC11",1,0)
IBCSC11 ;ALB/MJB - MCCR SCREEN 11 (LOCAL SCREEN 11 SPECIFIC INFO) ;27 MAY 99 10:20
"RTN","IBCSC11",2,0)
 ;;2.0;INTEGRATED BILLING;**52,51,447**;21-MAR-94;Build 80
"RTN","IBCSC11",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IBCSC11",4,0)
 ;
"RTN","IBCSC11",5,0)
 ; Copied from IBCSC9 to place LOCAL SCREEN last in the screen sequence. IB*2.0*447 BI
"RTN","IBCSC11",6,0)
 ;
"RTN","IBCSC11",7,0)
EN N IBCOB,IBSCRN,IBANY,IBXERR
"RTN","IBCSC11",8,0)
 S IBCOB=$$COBN^IBCEF(IBIFN),IBANY=1
"RTN","IBCSC11",9,0)
 S IBSCRN=$$LOCSCRN(IBIFN) ;Find screen from file 353
"RTN","IBCSC11",10,0)
 I IBSCRN="" S IBANY="No local screen has been defined for this form type"
"RTN","IBCSC11",11,0)
 I '$D(^DGCR(399,IBIFN,"I"_IBCOB)),'$P($G(^DGCR(399,IBIFN,"M")),U,11) S IBANY="Bill must have insurance co or resp institution to use this screen"
"RTN","IBCSC11",12,0)
 D ^IBCSCU S IBSR=11,IBSR1=""
"RTN","IBCSC11",13,0)
 D H^IBCSCU
"RTN","IBCSC11",14,0)
 N IBWW,Z,IBPARMS
"RTN","IBCSC11",15,0)
 ;Call formatter to extract data for screen here ... read thru the array
"RTN","IBCSC11",16,0)
 ; ^TMP("IBXDATA",$J,1,PG,LINE,COL)=DATA to 'display' the data fields
"RTN","IBCSC11",17,0)
 S IBPARMS(1)="BILL-SEARCH",IBPARMS(3)=$S($$INPAT^IBCEF(IBIFN):"I",1:"O"),IBPARMS(2)=$P($G(^DGCR(399,IBIFN,"I"_IBCOB)),U)
"RTN","IBCSC11",18,0)
 S IBWW=""
"RTN","IBCSC11",19,0)
 K ^TMP("IBXDATA",$J),^TMP("IBXEDIT",$J),IBXERR
"RTN","IBCSC11",20,0)
 D FPRE^IBCEFG7(+IBSCRN,0,.IBXERR) ;Form pre-processor
"RTN","IBCSC11",21,0)
 I $D(IBXERR) S IBANY=IBXERR
"RTN","IBCSC11",22,0)
 I IBANY D
"RTN","IBCSC11",23,0)
 .N VADM
"RTN","IBCSC11",24,0)
 .S IBANY=$$EXTRACT^IBCEFG(IBSCRN,IBIFN,1,.IBPARMS) S:'IBANY IBANY="No local data fields are needed for this bill type/insurance company"
"RTN","IBCSC11",25,0)
 I IBANY D
"RTN","IBCSC11",26,0)
 .F Z0=1:1:$O(^TMP("IBXDATA",$J,1,1,""),-1) W ! S Z1="" F  S Z1=$O(^TMP("IBXDATA",$J,1,1,Z0,Z1)) Q:'Z1  S Z2=^(Z1),Z3="" S:$E(Z2)="[" Z3=+$P(Z2,"[",2),Z2=$P(Z2,"]",2,999) W ?Z1 W:Z3 "[",IBVI,Z3,IBVO,"]" W Z2
"RTN","IBCSC11",27,0)
 .S IBV1=""
"RTN","IBCSC11",28,0)
 .I $S($G(IBV)=1:0,1:$$STATOK^IBCEU4(IBIFN,"12")) S Z="" F  S Z=$O(^TMP("IBXEDIT",$J,Z)) Q:'Z  S $E(IBV1,Z)=0
"RTN","IBCSC11",29,0)
 I 'IBANY S IBV1="1" W !!,IBANY
"RTN","IBCSC11",30,0)
 G ^IBCSCP
"RTN","IBCSC11",31,0)
 ;
"RTN","IBCSC11",32,0)
EDIT ;
"RTN","IBCSC11",33,0)
 N Z,DR,DA,DIE,FLDS,Z0,IBCUFT
"RTN","IBCSC11",34,0)
 S IBCUFT=$P($G(^DGCR(399,IBIFN,0)),U,19)
"RTN","IBCSC11",35,0)
 F Z=1:1:$L(IBDR20,",") S Z0=$P(IBDR20,",",Z) D
"RTN","IBCSC11",36,0)
 .S DR=""
"RTN","IBCSC11",37,0)
 .S IBGRP=Z0-110,Z0=0 F  S Z0=$O(^TMP("IBXEDIT",$J,IBGRP,Z0)) Q:'Z0  S DR=DR_$S($L(DR):";",1:"")_^(Z0)
"RTN","IBCSC11",38,0)
 .I $L(DR) S DIE=+$G(^IBE(353,IBCUFT,2)),DA=IBIFN D ^DIE
"RTN","IBCSC11",39,0)
 Q
"RTN","IBCSC11",40,0)
 ;
"RTN","IBCSC11",41,0)
LOCSCRN(IBIFN) ; Find the local screen from the bill form type
"RTN","IBCSC11",42,0)
 Q $P($G(^IBE(353,+$P($G(^DGCR(399,IBIFN,0)),U,19),2)),U,9)
"RTN","IBCSC11",43,0)
 ;
"RTN","IBCSC11",44,0)
Q Q
"RTN","IBCSC11",45,0)
 ;IBCSC11
"RTN","IBCSC5")
0^1^B17112329
"RTN","IBCSC5",1,0)
IBCSC5 ;ALB/MJB - MCCR SCREEN 5 (OPT. EOC) ;27 MAY 88 10:15
"RTN","IBCSC5",2,0)
 ;;2.0;INTEGRATED BILLING;**52,125,51,210,266,288,287,309,389,447**;21-MAR-94;Build 80
"RTN","IBCSC5",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCSC5",4,0)
 ;
"RTN","IBCSC5",5,0)
 ;MAP TO DGCRSC5
"RTN","IBCSC5",6,0)
 ;
"RTN","IBCSC5",7,0)
EN I $$INPAT^IBCEF(IBIFN) G ^IBCSC4
"RTN","IBCSC5",8,0)
 I $D(IBASKCOD) K IBASKCOD D CODMUL^IBCU7 I $$BILLCPT^IBCRU4(IBIFN) D ASK^IBCU7A(IBIFN) S DGRVRCAL=1
"RTN","IBCSC5",9,0)
 I $D(DGRVRCAL) D ^IBCU6 K DGRVRCAL
"RTN","IBCSC5",10,0)
 L ^DGCR(399,IBIFN):1
"RTN","IBCSC5",11,0)
 D ^IBCSCU S IBSR=5,IBSR1="",IBV1="10000000"_$S($$FT^IBCEF(IBIFN)'=2:0,1:1) F I="U",0 S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"") S:IBV IBV1="111111111"
"RTN","IBCSC5",12,0)
 D H^IBCSCU
"RTN","IBCSC5",13,0)
 S IBPTF=$P(IB(0),U,8),IBBT=$P(IB(0),"^",4)_$P(IB(0),"^",5)_$P(IB(0),"^",6)
"RTN","IBCSC5",14,0)
 D EN4^IBCVA1
"RTN","IBCSC5",15,0)
 S Z=1,IBW=1 X IBWW W " Event Date : " S Y=$P(IB(0),U,3) D DT^DIQ
"RTN","IBCSC5",16,0)
 N IBPOARR,IBDATE
"RTN","IBCSC5",17,0)
 D SET^IBCSC4D(IBIFN,"",.IBPOARR)
"RTN","IBCSC5",18,0)
 S IBDATE=$$BDATE^IBACSV(IBIFN) ; Event date
"RTN","IBCSC5",19,0)
 S Z=2,IBW=1 X IBWW W " Prin. Diag.: " S Y=$$DX^IBCSC4(0,IBDATE) W $S(Y'="":$P(Y,U,4)_" - "_$P(Y,U,2),$$DXREQ^IBCSC4(IBIFN):IBU,1:IBUN)
"RTN","IBCSC5",20,0)
 F I=1:1:4 S Y=$$DX^IBCSC4(+Y,IBDATE) Q:Y=""  W !?4,"Other Diag.: ",$P(Y,U,4)_" - "_$P(Y,U,2)
"RTN","IBCSC5",21,0)
 I +Y S Y=$$DX^IBCSC4(+Y,IBDATE) I +Y W !?4,"***There are more diagnoses associated with this bill.***"
"RTN","IBCSC5",22,0)
OP S Z=3,IBW=1 X IBWW W " OP Visits  : " F I=0:0 S I=$O(^DGCR(399,IBIFN,"OP",I)) Q:'I  S Y=I X ^DD("DD") W:$X>67 !?17 W Y_", "
"RTN","IBCSC5",23,0)
 S:$D(^DGCR(399,"OP")) DGOPV=1 I '$O(^DGCR(399,IBIFN,"OP",0)) W IBU
"RTN","IBCSC5",24,0)
 W !,?4,"Type       : ",$$GET1^DIQ(399,IBIFN_",",158)  ; Added with IB*2.0*447 BI
"RTN","IBCSC5",25,0)
 S Z=4,IBW=1 X IBWW W " Cod. Method: ",$S($P(IB(0),U,9)="":IBUN,$P(IB(0),U,9)=9:"ICD-9-CM",$P(IB(0),U,9)=4:"CPT-4",1:"HCPCS")
"RTN","IBCSC5",26,0)
 D WRT:$D(IBPROC)
"RTN","IBCSC5",27,0)
 S Z=5,IBW=1 X IBWW W " Rx. Refills: " S Y=$$RX I 'Y W IBUN
"RTN","IBCSC5",28,0)
OCC G OCC^IBCSC4
"RTN","IBCSC5",29,0)
 W !?4,"Opt. Code  : ",IBUN
"RTN","IBCSC5",30,0)
 G OCC^IBCSC4
"RTN","IBCSC5",31,0)
 Q
"RTN","IBCSC5",32,0)
MORE W !?4,*7,"***There are more procedures associated with this bill.***" S I=0
"RTN","IBCSC5",33,0)
 Q
"RTN","IBCSC5",34,0)
WRT ;  -write out procedures codes on screen
"RTN","IBCSC5",35,0)
 N IBDATE
"RTN","IBCSC5",36,0)
 S J=0 F I=1:1 S J=$O(IBPROC(J)) Q:'J  D  I I>6 D MORE Q
"RTN","IBCSC5",37,0)
 .S IBDATE=$P(IBPROC(J),U,2) I 'IBDATE S IBDATE=$$BDATE^IBACSV($G(IBIFN))
"RTN","IBCSC5",38,0)
 .S X=$$PRCD^IBCEF1($P(IBPROC(J),U),1,IBDATE)
"RTN","IBCSC5",39,0)
 .I IBPROC(J)["ICD" W !?4,"ICD Code   : ",$E($P(X,U,3),1,28)_" - "_$P(X,U,2)
"RTN","IBCSC5",40,0)
 .I IBPROC(J)["CPT" W !?4,"CPT Code   : " D
"RTN","IBCSC5",41,0)
 .. N Z
"RTN","IBCSC5",42,0)
 .. S Z=$P(X,"^",3)_" "_$P(X,"^",2)_$S($P(IBPROC(J),U,15):"-"_$$MODLST^IBEFUNC2($P(IBPROC(J),U,15)),1:"")
"RTN","IBCSC5",43,0)
 .. I $L(Z)>40 S Z=" "_$P(X,"^",2)_$S($P(IBPROC(J),U,15):"-"_$$MODLST^IBEFUNC2($P(IBPROC(J),U,15)),1:""),Z=$E($P(X,U,3),1,40-$L(Z))_Z
"RTN","IBCSC5",44,0)
 .. W Z
"RTN","IBCSC5",45,0)
 .I $P(IB(0),U,19)=2 S Y=+$P(IBPROC(J),U,11) S:+Y Y=+$G(^IBA(362.3,+Y,0)) W ?58,$P($$ICD9^IBACSV(Y,IBDATE),U) S Y=$P(IBPROC(J),U,2) D D^DIQ W ?67,Y Q
"RTN","IBCSC5",46,0)
 .S Y=$P(IBPROC(J),"^",2) D D^DIQ W ?67,Y
"RTN","IBCSC5",47,0)
 Q
"RTN","IBCSC5",48,0)
 ;
"RTN","IBCSC5",49,0)
MOD(IBM,PUNC) ; Returns modifier list from comma delimited ien's in string IBM
"RTN","IBCSC5",50,0)
 ; PUNC = Punctuation to use as first character of output
"RTN","IBCSC5",51,0)
 N IBMOD,Q
"RTN","IBCSC5",52,0)
 S IBMOD=""
"RTN","IBCSC5",53,0)
 F Q=1:1:$L(IBM,",") I $P(IBM,",",Q)'="" S IBMOD=IBMOD_$S(IBMOD'="":",",1:"")_$P($$MOD^ICPTMOD($P(IBM,",",Q),"I"),U,2)
"RTN","IBCSC5",54,0)
 I IBMOD'="" S IBMOD=$G(PUNC)_IBMOD
"RTN","IBCSC5",55,0)
 Q IBMOD
"RTN","IBCSC5",56,0)
 ;
"RTN","IBCSC5",57,0)
PD() ;prints prosthetic device in external form, returns 0 if there are none
"RTN","IBCSC5",58,0)
 N IBX,IBY,IBZ,IBN,X S X=0 S IBX=0 F  S IBX=$O(^IBA(362.5,"AIFN"_IBIFN,IBX)) Q:'IBX  D  Q:X>5
"RTN","IBCSC5",59,0)
 . S IBY=0 F  S IBY=$O(^IBA(362.5,"AIFN"_IBIFN,IBX,IBY)) Q:'IBY  S IBZ=$G(^IBA(362.5,IBY,0)) I IBZ'="" D  Q:X>5
"RTN","IBCSC5",60,0)
 .. S X=X+1 I X>5 W !,?17,"*** There are more Pros. Items associated with this bill.***" Q
"RTN","IBCSC5",61,0)
 .. W:X'=1 ! W ?17,$E($P(IBZ,U,5),1,40),?67,$$FMTE^XLFDT(+IBZ)
"RTN","IBCSC5",62,0)
 Q X
"RTN","IBCSC5",63,0)
 ;
"RTN","IBCSC5",64,0)
RX() ;prints RX REFILLS in external form, returns 0 if there are none
"RTN","IBCSC5",65,0)
 N IBX,IBY,IBZ,IBN,X S X=0 S IBX="" F  S IBX=$O(^IBA(362.4,"AIFN"_IBIFN,IBX)) Q:IBX=""  D  Q:X>5
"RTN","IBCSC5",66,0)
 . S IBY=0 F  S IBY=$O(^IBA(362.4,"AIFN"_IBIFN,IBX,IBY)) Q:'IBY  S IBZ=$G(^IBA(362.4,IBY,0)) I IBZ'="" D  Q:X>5
"RTN","IBCSC5",67,0)
 .. S X=X+1 I X>5 W !,?17,"*** There are more Rx. Refills associated with this bill.***" Q
"RTN","IBCSC5",68,0)
 ..D ZERO^IBRXUTL(+$P(IBZ,U,4))
"RTN","IBCSC5",69,0)
 .. S IBN=$G(^TMP($J,"IBDRUG",+$P(IBZ,U,4),.01)) W:X'=1 ! W ?17,IBN,?65,$$FMTE^XLFDT(+$P(IBZ,U,3))
"RTN","IBCSC5",70,0)
 K ^TMP($J,"IBDRUG")
"RTN","IBCSC5",71,0)
 Q X
"RTN","IBCSC5",72,0)
 ;
"RTN","IBCSC5",73,0)
 ;IBCSC5
"RTN","IBCSC8")
0^15^B7203948
"RTN","IBCSC8",1,0)
IBCSC8 ;ALB/MJB/AAS - MCCR SCREEN 8 (BILLING - CLAIM INFORMATION SCREEN) ;27 MAY 88 10:15
"RTN","IBCSC8",2,0)
 ;;2.0;INTEGRATED BILLING;**432,447**;21-MAR-94;Build 80
"RTN","IBCSC8",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCSC8",4,0)
 ;
"RTN","IBCSC8",5,0)
 ;
"RTN","IBCSC8",6,0)
EN D ^IBCSCU S IBSR=8,IBSR1="" S IB("U4")=$G(^DGCR(399,IBIFN,"U4")),IB("U5")=$G(^DGCR(399,IBIFN,"U5")),IB("U6")=$G(^DGCR(399,IBIFN,"U6")),IB("U8")=$G(^DGCR(399,IBIFN,"U8"))
"RTN","IBCSC8",7,0)
 D H^IBCSCU
"RTN","IBCSC8",8,0)
 ; DEM - IBV is set in EDI^IBCB => S IBAC=1,IBV=0 D EN G Q:'IBAC1,EDI
"RTN","IBCSC8",9,0)
 ;       IBV=0, or IBV=1 as a flag if field on screen is required
"RTN","IBCSC8",10,0)
 ;       or not. <Field #> indicates field is not required.
"RTN","IBCSC8",11,0)
 ;       [Field #]
"RTN","IBCSC8",12,0)
 ; Make some sections NOT available for UB04 form
"RTN","IBCSC8",13,0)
 S IBT=$P($G(^DGCR(399,IBIFN,0)),U,19)
"RTN","IBCSC8",14,0)
 S IBV1=$S(IBT=3:"001011",IBV:"111111",1:"000000")
"RTN","IBCSC8",15,0)
 ;
"RTN","IBCSC8",16,0)
 S Z=1,IBW=1 X IBWW W " COB Non-Covered Charge Amt: " S X=$P(IB("U4"),U),X2="2$" I X'="" D COMMA^%DTC W X
"RTN","IBCSC8",17,0)
 S Z=2 X IBWW W " Property Casualty Information"
"RTN","IBCSC8",18,0)
 W !,?4,"Claim Number:  ",$P(IB("U4"),U,2),?41,"Contact Name:  ",$P(IB("U4"),U,9)
"RTN","IBCSC8",19,0)
 W !,?4,"Date of 1st Contact:  ",$$FMTE^XLFDT($P(IB("U4"),U,3)),?41,"Contact Phone:  ",$P(IB("U4"),U,10),"  ",$P(IB("U4"),U,11)
"RTN","IBCSC8",20,0)
 ; Start IB*2.0*447 BI
"RTN","IBCSC8",21,0)
 ;S Z=3 X IBWW W " Ambulance Information"
"RTN","IBCSC8",22,0)
 ;W !,?41,"D/O Location: ",$P(IB("U6"),U)
"RTN","IBCSC8",23,0)
 ;W !,?4,"P/U Address1:  ",$P(IB("U5"),U,2),?41,"D/O Address1:  ",$P(IB("U6"),U,2)
"RTN","IBCSC8",24,0)
 ;W !,?4,"P/U Address2:  ",$P(IB("U5"),U,3),?41,"D/O Address2:  ",$P(IB("U6"),U,3)
"RTN","IBCSC8",25,0)
 ;W !,?4,"P/U City:  ",$P(IB("U5"),U,4),?41,"D/O City:  ",$P(IB("U6"),U,4)
"RTN","IBCSC8",26,0)
 ;W !,?4,"P/U State/Zip:  " W:$P(IB("U5"),U,5)'="" $P($G(^DIC(5,$P(IB("U5"),U,5),0)),U,2)
"RTN","IBCSC8",27,0)
 ;W:$P(IB("U5"),U,6)]"" "/"_$P(IB("U5"),U,6)
"RTN","IBCSC8",28,0)
 ;W ?41,"D/O State/Zip:  " W:$P(IB("U6"),U,5)'="" $P($G(^DIC(5,$P(IB("U6"),U,5),0)),U,2)
"RTN","IBCSC8",29,0)
 ;W:$P(IB("U6"),U,6)]"" "/"_$P(IB("U6"),U,6)
"RTN","IBCSC8",30,0)
 ;;W !,?4,"P/U Country/SubDiv:  ",$P(IB("U5"),U),?41,"D/O Country/SubDiv:  "
"RTN","IBCSC8",31,0)
 S Z=3 X IBWW W " Surgical Codes for Anesthesia Claims"
"RTN","IBCSC8",32,0)
 W !,?4,"Primary Code:  " W:$P(IB("U4"),U,7)'="" $P($G(^ICPT($P(IB("U4"),U,7),0)),U)
"RTN","IBCSC8",33,0)
 W ?41,"Secondary Code:  " W:$P(IB("U4"),U,8)'="" $P($G(^ICPT($P(IB("U4"),U,8),0)),U)
"RTN","IBCSC8",34,0)
 S Z=4 X IBWW W " Paperwork Attachment Information"
"RTN","IBCSC8",35,0)
 W !,?4,"Report Type:  " W:$P(IB("U8"),U,2)'="" $P($G(^IBE(353.3,$P(IB("U8"),U,2),0)),U)
"RTN","IBCSC8",36,0)
 W ?41,"Transmission Method:  ",$P(IB("U8"),U,3)
"RTN","IBCSC8",37,0)
 W !,?4,"Attachment Control #:  ",$P(IB("U8"),U)
"RTN","IBCSC8",38,0)
 S Z=5 X IBWW W " Disability Start Date:  ",$$FMTE^XLFDT($P(IB("U4"),U,4)),?41,"Disability End Date:  ",$$FMTE^XLFDT($P(IB("U4"),U,5))
"RTN","IBCSC8",39,0)
 S Z=6 X IBWW W " Assumed Care Date:  ",$$FMTE^XLFDT($P(IB("U4"),U,13)),?41,"Relinquished Care Date:  ",$$FMTE^XLFDT($P(IB("U4"),U,14))
"RTN","IBCSC8",40,0)
 ; End IB*2.0*447 BI
"RTN","IBCSC8",41,0)
 W !
"RTN","IBCSC8",42,0)
REV G ^IBCSCP
"RTN","IBCSC8",43,0)
 ;IBCSC8
"RTN","IBCSC9")
0^39^B7536045
"RTN","IBCSC9",1,0)
IBCSC9 ;ALB/BI - MCCR SCREEN 9 (AMBULANCE INFO)  ;11 MAY 2011 10:20
"RTN","IBCSC9",2,0)
 ;;2.0;INTEGRATED BILLING;**447**;11-MAY-2011;Build 80
"RTN","IBCSC9",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCSC9",4,0)
 ;
"RTN","IBCSC9",5,0)
EN ; Main Entry Point
"RTN","IBCSC9",6,0)
 N IBACI,IBACIX,IB,IBT
"RTN","IBCSC9",7,0)
 D ^IBCSCU
"RTN","IBCSC9",8,0)
 S IBT=$P($G(^DGCR(399,IBIFN,0)),U,19)
"RTN","IBCSC9",9,0)
 S IBSR=9,IBSR1="",IBV1=$S(IBT=3:"11",IBV:"11",1:"00")
"RTN","IBCSC9",10,0)
 S IB("U")=$G(^DGCR(399,IBIFN,"U"))
"RTN","IBCSC9",11,0)
 S IB("U1")=$G(^DGCR(399,IBIFN,"U1"))
"RTN","IBCSC9",12,0)
 S IB("U4")=$G(^DGCR(399,IBIFN,"U4"))
"RTN","IBCSC9",13,0)
 S IB("U5")=$G(^DGCR(399,IBIFN,"U5"))
"RTN","IBCSC9",14,0)
 S IB("U6")=$G(^DGCR(399,IBIFN,"U6"))
"RTN","IBCSC9",15,0)
 S IB("U7")=$G(^DGCR(399,IBIFN,"U7"))
"RTN","IBCSC9",16,0)
 S IB("U8")=$G(^DGCR(399,IBIFN,"U8"))
"RTN","IBCSC9",17,0)
 M IB("U9")=^DGCR(399,IBIFN,"U9")
"RTN","IBCSC9",18,0)
 D H^IBCSCU
"RTN","IBCSC9",19,0)
 S Z=1,IBW=1 X IBWW W " Ambulance Transport Data"
"RTN","IBCSC9",20,0)
 W !,?41,"D/O Location: ",$P(IB("U6"),U)
"RTN","IBCSC9",21,0)
 W !,?4,"P/U Address1: ",$P(IB("U5"),U,2),?41,"D/O Address1: ",$P(IB("U6"),U,2)
"RTN","IBCSC9",22,0)
 W !,?4,"P/U Address2: ",$P(IB("U5"),U,3),?41,"D/O Address2: ",$P(IB("U6"),U,3)
"RTN","IBCSC9",23,0)
 W !,?4,"P/U City: ",$P(IB("U5"),U,4),?41,"D/O City: ",$P(IB("U6"),U,4)
"RTN","IBCSC9",24,0)
 W !,?4,"P/U State/Zip: " W:$P(IB("U5"),U,5)'="" $P($G(^DIC(5,$P(IB("U5"),U,5),0)),U,2)
"RTN","IBCSC9",25,0)
 W:$P(IB("U5"),U,6)]"" "/"_$P(IB("U5"),U,6)
"RTN","IBCSC9",26,0)
 W ?41,"D/O State/Zip: " W:$P(IB("U6"),U,5)'="" $P($G(^DIC(5,$P(IB("U6"),U,5),0)),U,2)
"RTN","IBCSC9",27,0)
 W:$P(IB("U6"),U,6)]"" "/"_$P(IB("U6"),U,6)
"RTN","IBCSC9",28,0)
 W !,?4,"Patient Weight: ",$P(IB("U7"),U,1),?41,"Transport Distance: ",$P(IB("U7"),U,3)
"RTN","IBCSC9",29,0)
 W !,?4,"Transport Reason: " I $P(IB("U7"),U,2)'="" D IBWP($$GET1^DIQ(353.4,$P(IB("U7"),U,2)_",",.02),22,55)
"RTN","IBCSC9",30,0)
 W !,?4,"R/T Purpose: " D IBWP($P(IB("U7"),U,4),17,60)
"RTN","IBCSC9",31,0)
 W !,?4,"Stretcher Purpose: " D IBWP($P(IB("U7"),U,5),23,54)
"RTN","IBCSC9",32,0)
 S Z=2,IBW=2 X IBWW W " Ambulance Certification Data"
"RTN","IBCSC9",33,0)
 W !,?4,"Condition Indicator:"
"RTN","IBCSC9",34,0)
 S IBACIX=0
"RTN","IBCSC9",35,0)
 F  S IBACIX=$O(IB("U9",IBACIX)) Q:+IBACIX=0  D
"RTN","IBCSC9",36,0)
 . S IBACI=IB("U9",IBACIX,0)
"RTN","IBCSC9",37,0)
 . W ?25,$$GET1^DIQ(353.5,IBACI_",",.01)," - ",$$GET1^DIQ(353.5,IBACI_",",.02),!
"RTN","IBCSC9",38,0)
 K IB("U9")
"RTN","IBCSC9",39,0)
 W !
"RTN","IBCSC9",40,0)
 G ^IBCSCP
"RTN","IBCSC9",41,0)
 Q
"RTN","IBCSC9",42,0)
 ;
"RTN","IBCSC9",43,0)
IBWP(IBX,IBLM,IBRM) ;
"RTN","IBCSC9",44,0)
 K ^UTILITY($J,"W")
"RTN","IBCSC9",45,0)
 N X,Y,DIWF,DIWL,DIWR S X=IBX
"RTN","IBCSC9",46,0)
 S DIWL=1,DIWR=IBRM,DIWF="" D ^DIWP
"RTN","IBCSC9",47,0)
 I $D(^UTILITY($J,"W")) S Y=0 F  S Y=$O(^UTILITY($J,"W",1,Y)) Q:'Y  W:Y>1 !,?(IBLM) W $G(^UTILITY($J,"W",1,Y,0))
"RTN","IBCSC9",48,0)
 K ^UTILITY($J,"W")
"RTN","IBCSC9",49,0)
 Q
"RTN","IBCSC9",50,0)
 ;
"RTN","IBCSC9",51,0)
SCREEN1(DA1) ;
"RTN","IBCSC9",52,0)
 N A,RESPONSE S RESPONSE=0
"RTN","IBCSC9",53,0)
 I +$P($G(^DGCR(399,DA1,"U9",0)),U,4)<5 S RESPONSE=1 Q RESPONSE
"RTN","IBCSC9",54,0)
 S A(1,"F")="!?35",A(1)="Maximum of 5 Condition Indicators allowed"
"RTN","IBCSC9",55,0)
 D EN^DDIOL(.A)
"RTN","IBCSC9",56,0)
 Q RESPONSE
"RTN","IBCSC9",57,0)
 ;IBCSC9
"RTN","IBCSCE")
0^13^B9204544
"RTN","IBCSCE",1,0)
IBCSCE ;ALB/MRL,MJB - MCCR SCREEN EDITS ;07 JUN 88 14:35
"RTN","IBCSCE",2,0)
 ;;2.0;INTEGRATED BILLING;**52,80,91,106,51,137,236,245,287,349,371,400,432,447**;21-MAR-94;Build 80
"RTN","IBCSCE",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCSCE",4,0)
 ;
"RTN","IBCSCE",5,0)
 ;MAP TO DGCRSCE
"RTN","IBCSCE",6,0)
 ; always do procedures last because they are edited upon return to screen routine
"RTN","IBCSCE",7,0)
 I IBDR20["54," S IBDR20=$P(IBDR20,"54,",1)_$P(IBDR20,"54,",2)_"54,"
"RTN","IBCSCE",8,0)
 I IBDR20["44," S IBDR20=$P(IBDR20,"44,",1)_$P(IBDR20,"44,",2)_"44,"
"RTN","IBCSCE",9,0)
LOOP N IBDRLP,IBDRL S IBDRLP=IBDR20 F IBDRL=1:1 S IBDR20=$P(IBDRLP,",",IBDRL) Q:IBDR20=""  D EDIT
"RTN","IBCSCE",10,0)
 Q
"RTN","IBCSCE",11,0)
EDIT N IBQUERY
"RTN","IBCSCE",12,0)
 I (IBDR20["31") D MCCR^IBCNSP2 G ENQ
"RTN","IBCSCE",13,0)
 I (IBDR20["43")!(IBDR20["52") D ^IBCSC4D G ENQ
"RTN","IBCSCE",14,0)
 I (IBDR20["74")!(IBDR20["53") K DR N I D ^IBCOPV S (DA,Y)=IBIFN G TMPL
"RTN","IBCSCE",15,0)
 I (IBDR20["54"),$P($G(^IBE(350.9,1,1)),"^",17) K DR N I D EN1^IBCCPT(.IBQUERY) D CLOSE^IBSDU(.IBQUERY) G TMPL ;
"RTN","IBCSCE",16,0)
 I (IBDR20["55") D ^IBCSC5A G ENQ
"RTN","IBCSCE",17,0)
 I (IBDR20["45")!(IBDR20["56") D ^IBCSC5B G ENQ
"RTN","IBCSCE",18,0)
 I (IBDR20["66")!(IBDR20["76") D EDIT^IBCRBE(IBIFN) D ASKCMB^IBCU65(IBIFN) G ENQ
"RTN","IBCSCE",19,0)
 I IBDR20["102",$$FT^IBCEF(IBIFN)=3 D EN^IBCSC10B G ENQ   ; UB-04 patient reason for visit (screen 10, section 2)
"RTN","IBCSCE",20,0)
 I IBDR20["105",$$FT^IBCEF(IBIFN)=2 D ^IBCSC10A G ENQ     ; cms-1500 chiropractic data (screen 10, section 5)
"RTN","IBCSCE",21,0)
 I IBDR20["107",$$FT^IBCEF(IBIFN)=3 D EN1^IBCEP6 G ENQ   ; UB-04 provider ID maintenance (screen 10, section 7)
"RTN","IBCSCE",22,0)
 I IBDR20["109",$$FT^IBCEF(IBIFN)=2 D EN1^IBCEP6 G ENQ   ; cms-1500 provider ID maintenance (screen 10, section 9)
"RTN","IBCSCE",23,0)
 ;
"RTN","IBCSCE",24,0)
 F Q=1:1:9 I IBDR20[("11"_Q) D EDIT^IBCSC11 G ENQ     ; IB*2.0*447 BI
"RTN","IBCSCE",25,0)
TMPL N IBFLIAE S IBFLIAE=1 ;to invoke EN^DGREGAED from [IB SCREEN1]
"RTN","IBCSCE",26,0)
 S DR="[IB SCREEN"_IBSR_IBSR1_"]",(DA,Y)=IBIFN,DIE="^DGCR(399,"
"RTN","IBCSCE",27,0)
 D ^DIE K DIE,DR,DLAYGO
"RTN","IBCSCE",28,0)
 I (IBDR20["61")!(IBDR20["71") I +$G(DGRVRCAL) D PROC^IBCU7A(IBIFN,1)
"RTN","IBCSCE",29,0)
 ;
"RTN","IBCSCE",30,0)
ENQ ;
"RTN","IBCSCE",31,0)
 K DIE,DR,IBDR1,IBDR20,DGDRD,DGDRS,DGDRS1,DA
"RTN","IBCSCE",32,0)
 Q
"RTN","IBCSCE",33,0)
 ;
"RTN","IBCSCE",34,0)
 ;called by screen 3 (input template)
"RTN","IBCSCE",35,0)
UPDT F IBDD=0:0 S IBDD=$O(^DPT(DFN,.312,IBDD)) Q:IBDD'>0  S IBI1=^DPT(DFN,.312,IBDD,0) I $D(^DIC(36,+IBI1,0)),$P(^(0),"^",2)'="N" S IBDD(+IBI1)=IBI1
"RTN","IBCSCE",36,0)
 F IBAIC=0:0 S IBAIC=$O(^DGCR(399,IBIFN,"AIC",IBAIC)) Q:IBAIC'>0  I $D(IBDD(IBAIC)) F IBI1="I1","I2","I3" I $D(^DGCR(399,IBIFN,IBI1)),+^(IBI1)=IBAIC,^(IBI1)'=IBDD(IBAIC) S ^DGCR(399,IBIFN,IBI1)=IBDD(IBAIC)
"RTN","IBCSCE",37,0)
 K IBAIC,IBDD,IBI1 Q
"RTN","IBCSCE",38,0)
 ;
"RTN","IBCSCE",39,0)
 ;Edit patient's address using DGREGAED API
"RTN","IBCSCE",40,0)
EDADDR(IBDFN) ;
"RTN","IBCSCE",41,0)
 I $G(IBFLIAE)'=1!(IBDFN=0) Q 0
"RTN","IBCSCE",42,0)
 N IBFL S IBFL(1)=1
"RTN","IBCSCE",43,0)
 N X,Y,DIE,DA,DR,DIDEL,DIW,DIEDA,DG,DICR
"RTN","IBCSCE",44,0)
 D EN^DGREGAED(IBDFN,.IBFL)
"RTN","IBCSCE",45,0)
 Q 1
"RTN","IBCSCE",46,0)
 ;IBCSCE
"RTN","IBCSCH")
0^40^B48120299
"RTN","IBCSCH",1,0)
IBCSCH ;ALB/MJB - MCCR HELP ROUTINE ;03 JUN 88 15:25
"RTN","IBCSCH",2,0)
 ;;2.0;INTEGRATED BILLING;**52,80,106,124,138,51,148,137,161,245,232,287,348,349,374,371,395,400,432,447**;21-MAR-94;Build 80
"RTN","IBCSCH",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCSCH",4,0)
 ;
"RTN","IBCSCH",5,0)
 ;MAP TO DGCRSCH
"RTN","IBCSCH",6,0)
 ;
"RTN","IBCSCH",7,0)
 N I,C,IBSCNNZ,IBQ,IBPRNT,Z S IBSCNNZ=$$UP^XLFSTR($G(IBSCNN)),IBQ=0
"RTN","IBCSCH",8,0)
 I '$D(IBPAR) D  Q:IBQ
"RTN","IBCSCH",9,0)
 . I $F(".?1500.?HCFA.","."_$G(IBSCNNZ)_"."),$$FT^IBCEF(IBIFN)=2 S IBQ=1,IBPRNT=2 D BL24(IBIFN,0) Q
"RTN","IBCSCH",10,0)
 . I $G(IBSCNNZ)="?SC" S IBQ=1 D DISPSC(IBIFN) Q
"RTN","IBCSCH",11,0)
 . I $G(IBSCNNZ)="?INS" S IBQ=1 D INSDSPL(IBIFN) Q
"RTN","IBCSCH",12,0)
 . I $G(IBSCNNZ)="?INX" S IBQ=1 D INSDSPLX(IBIFN) Q
"RTN","IBCSCH",13,0)
 . I $G(IBSCNNZ)="?PRV" S IBQ=1 D DISPROPT(IBIFN) Q
"RTN","IBCSCH",14,0)
 . I $G(IBSCNNZ)="?CHG" S IBQ=1 D DISPCHG^IBCRBH1(IBIFN) Q
"RTN","IBCSCH",15,0)
 . I $G(IBSCNNZ)="?PRC" S IBQ=1 D DISPPRC^IBCSCH1(IBIFN) Q
"RTN","IBCSCH",16,0)
 . I $G(IBSCNNZ)="?CPT" S IBQ=1 D BCPTCHG^IBCRBH2(IBIFN) Q
"RTN","IBCSCH",17,0)
 . I $G(IBSCNNZ)="?INC" S IBQ=1 D EDIT^IBCBB(IBIFN) Q
"RTN","IBCSCH",18,0)
 . I $G(IBSCNNZ)="?CLA",$$CK0^IBCIUT1() S IBQ=1 D CLA^IBCISC(IBIFN) Q
"RTN","IBCSCH",19,0)
 . I $G(IBSCNNZ)="?MRA",$$MCRONBIL^IBEFUNC(IBIFN),$T(SCR^IBCEMVU)'="" S IBQ=1 D SCR^IBCEMVU(IBIFN) Q
"RTN","IBCSCH",20,0)
 . I $G(IBSCNNZ)="?ID" S IBQ=1 D DISPID^IBCEF74(IBIFN) Q
"RTN","IBCSCH",21,0)
 . I $G(IBSCNNZ)="?RX" S IBQ=1 D DISPRX^IBCSCH1(IBIFN) Q
"RTN","IBCSCH",22,0)
 . Q
"RTN","IBCSCH",23,0)
 ;
"RTN","IBCSCH",24,0)
 S IBH("HELP")="" D ^IBCSCU,H^IBCSCU K IBH("HELP") W !,"Enter '^' to stop the display ",$S(IBV:"",1:"and edit "),"of data,"
"RTN","IBCSCH",25,0)
 W:'$D(IBPAR) " '^N' to jump to screen #N (see",!,"listing below), <RET> to continue on to the next available screen" I IBV W "." G M
"RTN","IBCSCH",26,0)
 W " or enter",!,"the field group number(s) you wish to edit using commas and dashes as",!,"delimiters.  Those groups enclosed in brackets ""[]"" are editable while those"
"RTN","IBCSCH",27,0)
 W !,"enclosed in arrows ""<>"" are not."
"RTN","IBCSCH",28,0)
 G:$D(IBPAR) M1
"RTN","IBCSCH",29,0)
M W "  Special help screens:"
"RTN","IBCSCH",30,0)
 W !,?5,"Enter '?SC' to view SC Status and Rated Disabilities."
"RTN","IBCSCH",31,0)
 W !,?5,"Enter '?INS' to view the patients insurance policies."
"RTN","IBCSCH",32,0)
 W !,?5,"Enter '?INX' to view the patients insurance policies with comments."
"RTN","IBCSCH",33,0)
 W !,?5,"Enter '?PRV' to view provider specific information."
"RTN","IBCSCH",34,0)
 W !,?5,"Enter '?PRC' to view all procedures on the bill and related data."
"RTN","IBCSCH",35,0)
 W !,?5,"Enter '?CHG' to view all items on the bill with potential charges."
"RTN","IBCSCH",36,0)
 W !,?5,"Enter '?CPT' to view all charges for selected CPT codes and bill type."
"RTN","IBCSCH",37,0)
 I $$FT^IBCEF(IBIFN)=2 W !,?5,"Enter '?1500' to view how block 24 will print on a CMS-1500."
"RTN","IBCSCH",38,0)
 W !,?5,"Enter '?INC' to execute the edits & view the bill inconsistencies."
"RTN","IBCSCH",39,0)
 I $$CK0^IBCIUT1() W !?5,"Enter '?CLA' to view the ClaimsManager options."
"RTN","IBCSCH",40,0)
 I $$MCRONBIL^IBEFUNC(IBIFN) W !?5,"Enter '?MRA' to view Medicare Remittance Advice EOB's on file."
"RTN","IBCSCH",41,0)
 W !,?5,"Enter '?ID' to view all IDs to be electronically transmitted on this claim."
"RTN","IBCSCH",42,0)
 W !,?5,"Enter '?RX' to view all prescriptions on this claim."
"RTN","IBCSCH",43,0)
 ;
"RTN","IBCSCH",44,0)
 D S W ! F I=$Y:1:20 W !
"RTN","IBCSCH",45,0)
 S Z="PRESS <RETURN> KEY" X IBWW W " to RETURN to SCREEN ",+IBSR
"RTN","IBCSCH",46,0)
 R X:DTIME
"RTN","IBCSCH",47,0)
 Q
"RTN","IBCSCH",48,0)
 ;
"RTN","IBCSCH",49,0)
M1 N I,Z S Z="DATA GROUPS ON PARAMETER SCREEN" W !! X IBWW D @(IBSR1_IBSR) D W W ! F I=$Y:1:20 W !
"RTN","IBCSCH",50,0)
 S Z="PRESS <RETURN> KEY" X IBWW W " to RETURN to PARAMETER SCREEN"
"RTN","IBCSCH",51,0)
 R X:DTIME
"RTN","IBCSCH",52,0)
 Q
"RTN","IBCSCH",53,0)
 ;
"RTN","IBCSCH",54,0)
 ;
"RTN","IBCSCH",55,0)
PAR S X="Fed Tax #, BC/BS #, MAS Svc Pointer^Bill Signer, Billing Supervisor^Security Parameters, Outpatient CPT parameters ^Remarks, Mailgroups^Agent Cashier Address/Phone" Q
"RTN","IBCSCH",56,0)
 ;
"RTN","IBCSCH",57,0)
S ; display the available screen data
"RTN","IBCSCH",58,0)
 N C,I,Z,J W ! S Z="AVAILABLE SCREENS" X IBWW
"RTN","IBCSCH",59,0)
 ; Start IB*2.0*447 BI
"RTN","IBCSCH",60,0)
 ;S X="Demographic^Employment^Payer^Inpatient Event^Outpatient Event^Inpatient Billing - General^Outpatient Billing - General^Billing - Claim Information^Locally Defined^Billing - Specific"
"RTN","IBCSCH",61,0)
 S X="Demographic^Employment^Payer^Inpatient Event^Outpatient Event^Inpatient Billing - General^Outpatient Billing - General^Billing - Claim Information^Ambulance^Billing - Specific^Locally Defined"
"RTN","IBCSCH",62,0)
 ; End IB*2.0*447 BI
"RTN","IBCSCH",63,0)
 S C=0 F I=1:1 S J=$P(X,"^",I) Q:J=""  I '$E(IBVV,I) S C=C+1,Z="^"_I,IBW=(C#2) W:'(C#2) ?41 X IBWW S Z=$S(I?1N:" ",1:" ")_J_" Data" W Z
"RTN","IBCSCH",64,0)
 Q
"RTN","IBCSCH",65,0)
 ;
"RTN","IBCSCH",66,0)
W ;
"RTN","IBCSCH",67,0)
 N I,J,Z
"RTN","IBCSCH",68,0)
 F I=1:1 S J=$P(X,"^",I) Q:J=""  S Z=I,IBW=(I#2) W:'(I#2) ?42 X IBWW W " "_J
"RTN","IBCSCH",69,0)
 W:'(I-1)#2 ! Q
"RTN","IBCSCH",70,0)
 Q
"RTN","IBCSCH",71,0)
 ;IBCSCH
"RTN","IBCSCH",72,0)
 ;
"RTN","IBCSCH",73,0)
 ;
"RTN","IBCSCH",74,0)
BL24(IBIFN,IBNOSHOW) ; display block 24 of CMS-1500
"RTN","IBCSCH",75,0)
 ; IBNOSHOW = 1 for not to show error/warning text line
"RTN","IBCSCH",76,0)
 N X,Y,DIR,IBPG,IBLN,IBCOL,IBX,IBQ,IBLC,IBLIN,IBPFORM,IBD,IBC1,Z,Z0,IBXDATA,IBXSAVE,IBNXPG
"RTN","IBCSCH",77,0)
 K ^TMP("IBXSAVE",$J)
"RTN","IBCSCH",78,0)
 S IBQ=0,IBLC=9 Q:'$G(IBIFN)  K ^TMP("IBXDISP",$J)
"RTN","IBCSCH",79,0)
 ;
"RTN","IBCSCH",80,0)
 S IBLIN=$$BOX24D^IBCEF11()
"RTN","IBCSCH",81,0)
 S IBPFORM=$S($P($G(^IBE(353,2,2)),U,8):$P(^(2),U,8),1:2)
"RTN","IBCSCH",82,0)
 S IBX=$$BILLN^IBCEFG0(0,"1^99",IBLIN,+IBIFN,IBPFORM)
"RTN","IBCSCH",83,0)
 ;
"RTN","IBCSCH",84,0)
 W @IOF,!,"Example of diagnoses, procedures and charges printing on the CMS-1500"
"RTN","IBCSCH",85,0)
 W !,"--------------------------------------------------------------------------------"
"RTN","IBCSCH",86,0)
 ;
"RTN","IBCSCH",87,0)
 ; box 19 - lines 36-37
"RTN","IBCSCH",88,0)
 F Z=+IBLIN,IBLIN+1 I $D(^TMP("IBXDISP",$J,1,Z)) S Z0=$G(^TMP("IBXDISP",$J,1,Z,+$O(^TMP("IBXDISP",$J,1,Z,20),-1))) I Z0'="" S:Z=+IBLIN Z0="BOX 19 DATA: "_Z0 W !,Z0
"RTN","IBCSCH",89,0)
 ;
"RTN","IBCSCH",90,0)
 ; box 21 - lines 39-41
"RTN","IBCSCH",91,0)
 W !,"21. diagnosis"
"RTN","IBCSCH",92,0)
 I $D(^TMP("IBXDISP",$J,2,IBLIN+3)) W ?16,"(1st 4 only)"
"RTN","IBCSCH",93,0)
 W !,?5,"1. ",$G(^TMP("IBXDISP",$J,1,IBLIN+3,3)),?25,"3. ",$G(^TMP("IBXDISP",$J,1,IBLIN+3,30))
"RTN","IBCSCH",94,0)
 W !,?5,"2. ",$G(^TMP("IBXDISP",$J,1,IBLIN+5,3)),?25,"4. ",$G(^TMP("IBXDISP",$J,1,IBLIN+5,30))
"RTN","IBCSCH",95,0)
 ;
"RTN","IBCSCH",96,0)
 ; box 24 - lines 44-55
"RTN","IBCSCH",97,0)
 D PG
"RTN","IBCSCH",98,0)
 S IBPG=0 F  S IBPG=$O(^TMP("IBXDISP",$J,IBPG)) Q:'IBPG  D  Q:IBQ
"RTN","IBCSCH",99,0)
 . I '$D(^TMP("IBXDISP",$J,IBPG,IBLIN+9)) Q   ; no line's on this page
"RTN","IBCSCH",100,0)
 . F IBLN=IBLIN+8:1:+$P(IBLIN,U,2) S IBCOL=$O(^TMP("IBXDISP",$J,IBPG,IBLN,0)) Q:'IBCOL&'$O(^TMP("IBXDISP",$J,IBPG,IBLN))  S IBLC=IBLC+1 I IBCOL D  Q:IBQ
"RTN","IBCSCH",101,0)
 .. S IBCOL=0,IBC1=1 F  S IBCOL=$O(^TMP("IBXDISP",$J,IBPG,IBLN,IBCOL)) Q:'IBCOL  I $TR($G(^(IBCOL))," ")'="" D
"RTN","IBCSCH",102,0)
 ... W:IBC1 ! S IBC1=0 W ?(IBCOL-1),$G(^TMP("IBXDISP",$J,IBPG,IBLN,IBCOL))
"RTN","IBCSCH",103,0)
 . S IBNXPG=$O(^TMP("IBXDISP",$J,IBPG))   ; next page
"RTN","IBCSCH",104,0)
 . I 'IBQ,IBNXPG,$D(^TMP("IBXDISP",$J,IBNXPG,IBLIN+9)) S IBLIN=$$BOX24D^IBCEF11(),IBQ=$$PAUSE^IBCSCH1(IBLC) Q:IBQ  S IBLC=9 W @IOF D PG
"RTN","IBCSCH",105,0)
 . Q
"RTN","IBCSCH",106,0)
 ;
"RTN","IBCSCH",107,0)
 W !,"--------------------------------------------------------------------------------"
"RTN","IBCSCH",108,0)
 I 'IBPG,'IBQ S IBQ=$$PAUSE^IBCSCH1(IBLC)
"RTN","IBCSCH",109,0)
 K ^TMP("IBXDISP",$J),^TMP("IBXSAVE",$J)
"RTN","IBCSCH",110,0)
 Q
"RTN","IBCSCH",111,0)
 ;
"RTN","IBCSCH",112,0)
PG ; Display box 24 letters at top of charge list
"RTN","IBCSCH",113,0)
 W !,"24. A             B  C    D                 E         F     G H I    J"
"RTN","IBCSCH",114,0)
 W !,"--------------------------------------------------------------------------------"
"RTN","IBCSCH",115,0)
 Q
"RTN","IBCSCH",116,0)
 ;
"RTN","IBCSCH",117,0)
INSDSPL(IBIFN) ; Display patient's policies
"RTN","IBCSCH",118,0)
 N DIR,X,Y,IBX,DFN,IBDTIN,IBCOVEXT W @IOF
"RTN","IBCSCH",119,0)
 S IBX=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(IBX,U,2),IBDTIN=$P(IBX,U,3),IBCOVEXT=1
"RTN","IBCSCH",120,0)
 I +DFN D DISPDT^IBCNS W ! S DIR("A")="Press RETURN to continue",DIR(0)="E" D ^DIR K DIR
"RTN","IBCSCH",121,0)
 Q
"RTN","IBCSCH",122,0)
 ;
"RTN","IBCSCH",123,0)
INSDSPLX(IBIFN) ; Display patient's policies extended (?INX)
"RTN","IBCSCH",124,0)
 N IBX,DFN,IBDATE S IBX=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(IBX,U,2),IBDATE=$P(IBX,U,3) D DISP^IBCNS3(DFN,IBDATE,123)
"RTN","IBCSCH",125,0)
 Q
"RTN","IBCSCH",126,0)
 ;
"RTN","IBCSCH",127,0)
DISPSC(IBIFN) ; display patients SC Status and Rated Disabilities
"RTN","IBCSCH",128,0)
 N IB0,DFN,IBSC,IBX,VAEL,VAERR
"RTN","IBCSCH",129,0)
 S IB0=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(IB0,U,2),IBSC=$P(IB0,U,18)
"RTN","IBCSCH",130,0)
 W !,@IOF,!,"SC Status and Rated Disabilities for ",$P($G(^DPT(+$G(DFN),0)),U,1)
"RTN","IBCSCH",131,0)
 W !,"--------------------------------------------------------------------------------",!
"RTN","IBCSCH",132,0)
 I +$G(IBIFN) W !," SC At Time Of Care: ",$S(IBSC=1:"Yes",IBSC=0:"No",1:"")
"RTN","IBCSCH",133,0)
 I +$G(DFN) D ELIG^VADPT D DIS^DGRPDB
"RTN","IBCSCH",134,0)
 W !!,"--------------------------------------------------------------------------------"
"RTN","IBCSCH",135,0)
 S IBX=$$PAUSE^IBCSCH1(19)
"RTN","IBCSCH",136,0)
 Q
"RTN","IBCSCH",137,0)
 ;
"RTN","IBCSCH",138,0)
DISPROPT(IBIFN) ; prompt for VA or Non-VA provider.
"RTN","IBCSCH",139,0)
 N X,Y,DIR
"RTN","IBCSCH",140,0)
 S DIR(0)="SAO^V:VA PROVIDER;N:NON-VA PROVIDER",DIR("A")="(V)A or (N)on-VA Provider: ",DIR("B")="V"
"RTN","IBCSCH",141,0)
 D ^DIR
"RTN","IBCSCH",142,0)
 I Y="V" D DISPPRV^IBCSCH2(IBIFN) Q
"RTN","IBCSCH",143,0)
 I Y="N" D DISPNVA^IBCSCH2(IBIFN)
"RTN","IBCSCH",144,0)
 Q
"RTN","IBCSCH",145,0)
 ;
"RTN","IBCSCP")
0^7^B11636365
"RTN","IBCSCP",1,0)
IBCSCP ;ALB/MRL - BILLING SCREEN PROCESSOR ;01 JUN 88 12:00
"RTN","IBCSCP",2,0)
 ;;2.0;INTEGRATED BILLING;**52,51,161,266,432,447**;21-MAR-94;Build 80
"RTN","IBCSCP",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCSCP",4,0)
 ;
"RTN","IBCSCP",5,0)
 ;MAP TO DGCRSCP
"RTN","IBCSCP",6,0)
 ;
"RTN","IBCSCP",7,0)
 D Q1 W !
"RTN","IBCSCP",8,0)
 S IBCSCPP=$S($L(IBV1)>1:"1-"_$L(IBV1),1:1)
"RTN","IBCSCP",9,0)
 F I=$Y:1:20 W !
"RTN","IBCSCP",10,0)
 S IBPOPOUT=0
"RTN","IBCSCP",11,0)
 S (ICDVDT,ICPTVDT)=$$BDATE^IBACSV(IBIFN) ;ICD/CPT version date
"RTN","IBCSCP",12,0)
 ; IB*2.0*447 BI Start
"RTN","IBCSCP",13,0)
 ;W "<RET> to ",$S(+IBSR<10:"CONTINUE",1:"QUIT") W:$S(+IBSR=9&(IBV1'["0"):0,1:'IBV) ", ",IBCSCPP," to EDIT," W " '^N' for screen N, or '^' to QUIT: " R IBSCNN:DTIME S IBCITOUT='$T G Q:'$T I IBSCNN="" S X1=2 G NOMO
"RTN","IBCSCP",14,0)
 W "<RET> to ",$S(+IBSR<11:"CONTINUE",1:"QUIT") W:$S(+IBSR=11&(IBV1'["0"):0,1:'IBV) ", ",IBCSCPP," to EDIT," W " '^N' for screen N, or '^' to QUIT: " R IBSCNN:DTIME S IBCITOUT='$T G Q:'$T I IBSCNN="" S X1=2 G NOMO
"RTN","IBCSCP",15,0)
 ; IB*2.0*447 BI End
"RTN","IBCSCP",16,0)
 G AN:IBSCNN?1"^"1N.N
"RTN","IBCSCP",17,0)
 I IBSCNN?1"^".E S IBPOPOUT=1 G Q
"RTN","IBCSCP",18,0)
 I IBSCNN'?1N.E D ^IBCSCH S X=IBSR,X1=2 G NOMO2
"RTN","IBCSCP",19,0)
 I IBSCNN?1N1"-"1N S IBDR20=IBSCNN,IBSCNN="" F I=+IBDR20:1:$P(IBDR20,"-",2) S IBSCNN=IBSCNN_I_","
"RTN","IBCSCP",20,0)
 ; IB*2.0*447 BI Start
"RTN","IBCSCP",21,0)
 S IBDR20="" F J=1:1 S I=$P(IBSCNN,",",J) Q:I=""!($L(I)>3)  I I<11 S:I'["-"&(IBDR20'[I_",") IBDR20=IBDR20_I_"," I I["-" S I1=$P(I,"-",1),I2=$P(I,"-",2) F I3=I1:1:I2 S IBDR20=IBDR20_I3_"," I I3>11 Q
"RTN","IBCSCP",22,0)
 ; IB*2.0*447 BI End
"RTN","IBCSCP",23,0)
 S DGDR1="" F J=1:1 S I=$P(IBDR20,",",J) Q:I=""  I '$E(IBV1,I) S DGDR1=DGDR1_(I+(IBSR*10))_","
"RTN","IBCSCP",24,0)
 I DGDR1']"" D ^IBCSCH S X=IBSR,X1=2 G NOMO2
"RTN","IBCSCP",25,0)
 S IBDR20=DGDR1 D ^IBCSCE S X=IBSR,X1=2 G NOMO2
"RTN","IBCSCP",26,0)
Q K IBSR,IBVV,VADM,IBVI,IBVO,ICDVDT,ICPTVDT
"RTN","IBCSCP",27,0)
 ;
"RTN","IBCSCP",28,0)
 ; If Ingenix ClaimsManager found some errors and the user is trying
"RTN","IBCSCP",29,0)
 ; to exit from these screens, then capture the user's comments.
"RTN","IBCSCP",30,0)
 ; Exit by time-out or by "^" pop out.
"RTN","IBCSCP",31,0)
 ; Here, it's important to preserve the value of $T since it is
"RTN","IBCSCP",32,0)
 ; being looked at by IBCB.
"RTN","IBCSCP",33,0)
 ;
"RTN","IBCSCP",34,0)
 S IBCIT("SAVE THE VALUE OF $T")=$T       ; save $T
"RTN","IBCSCP",35,0)
 I $$CM^IBCIUT1(IBIFN),$P($G(^IBA(351.9,IBIFN,0)),U,2)=4,($G(IBPOPOUT)!$G(IBCITOUT)) D COMMENT^IBCIUT7(IBIFN,1)
"RTN","IBCSCP",36,0)
 I IBCIT("SAVE THE VALUE OF $T")          ; restore $T
"RTN","IBCSCP",37,0)
 ;
"RTN","IBCSCP",38,0)
Q1 K %DT,C,DGA,DGA1,DGA2,DGAD,DGCC,IBSCNN,IBCSCPP,IBDR20,DGDR1,DGST,DGAAC,DGRCD,IBCPTX,IBCITOUT,IBCIT
"RTN","IBCSCP",39,0)
 K IBA,IBCPT,IBREVC,IBYN,IBZZ,IBABRT,IB,IBDD,IBIDS,IBIR,IBIRN,IBISEX,IBIUTL,IBU,IBUN,IBW,IBWW,DGPT,IBICD,IBHC,IBCC,IBDI,IBDIN,IBDPT,IBUCH
"RTN","IBCSCP",40,0)
 K DIC,DIWF,DIWL,I,I1,I2,I3,J,X,X1,X2,X3,Y,Z,Z1,Z2
"RTN","IBCSCP",41,0)
 Q
"RTN","IBCSCP",42,0)
 ; IB*2.0*447 BI Start
"RTN","IBCSCP",43,0)
NOMO S I=IBSR,J=1 I +IBSR=11 S X=IBSR G NOMO2
"RTN","IBCSCP",44,0)
NOMO1 S I=I+1,J=+$E(IBVV,I),X=I S:J&(+X=11) IBSR=X G NOMO2:+X=11 I J G NOMO1
"RTN","IBCSCP",45,0)
NOMO2 I +IBSR=11&(IBSCNN="") S X1=3,IBSR1=""
"RTN","IBCSCP",46,0)
 S:(+IBSR=10)&(IBSCNN="") IBSR1="" S X=$P($T(@(IBSR1_X)),";;",X1) G @X
"RTN","IBCSCP",47,0)
 Q
"RTN","IBCSCP",48,0)
 ; IB*2.0*447 BI End
"RTN","IBCSCP",49,0)
 ;
"RTN","IBCSCP",50,0)
AN S X=+$E(IBSCNN,2,99),X1=$P($T(@X),";;",2) I X1]"",'$E(IBVV,X) S IBSR1="",X1=2 G NOMO2
"RTN","IBCSCP",51,0)
 ; IB*2.0*447 BI Start
"RTN","IBCSCP",52,0)
 S Z="INVALID SCREEN NUMBER...VALID SCREENS ARE " F I=1:1:11 I '$E(IBVV,I) S Z=Z_I_$S(I<11:",",1:".")
"RTN","IBCSCP",53,0)
 ; IB*2.0*447 BI End
"RTN","IBCSCP",54,0)
 W !,*7 D W H 1 S X=IBSR,X1=2 G NOMO2
"RTN","IBCSCP",55,0)
W ;I IOST="C-QUME",$L(IBVI)'=2 W Z
"RTN","IBCSCP",56,0)
 W IBVI,Z,IBVO
"RTN","IBCSCP",57,0)
 Q
"RTN","IBCSCP",58,0)
1 ;;^IBCSC1;;^IBCSC2
"RTN","IBCSCP",59,0)
2 ;;^IBCSC2;;^IBCSC3
"RTN","IBCSCP",60,0)
3 ;;^IBCSC3;;^IBCSC4
"RTN","IBCSCP",61,0)
4 ;;^IBCSC4;;^IBCSC5
"RTN","IBCSCP",62,0)
5 ;;^IBCSC5;;^IBCSC6
"RTN","IBCSCP",63,0)
6 ;;^IBCSC6;;^IBCSC7
"RTN","IBCSCP",64,0)
7 ;;^IBCSC7;;^IBCSC8
"RTN","IBCSCP",65,0)
8 ;;^IBCSC8;;^IBCSC9
"RTN","IBCSCP",66,0)
9 ;;^IBCSC9;;^IBCSC10
"RTN","IBCSCP",67,0)
 ; IB*2.0*447 BI Start
"RTN","IBCSCP",68,0)
10 ;;^IBCSC10;;^IBCSC11
"RTN","IBCSCP",69,0)
210 ;;^IBCSC102;;^IBCSC11
"RTN","IBCSCP",70,0)
H10 ;;^IBCSC10H;;^IBCSC11
"RTN","IBCSCP",71,0)
11 ;;^IBCSC11;;Q^IBCSCP
"RTN","IBCSCP",72,0)
 ; IB*2.0*447 BI End
"RTN","IBCSCP",73,0)
PAR ;;^IBCPAR;;^IBCPAR
"RTN","IBCSCP",74,0)
 ;IBCSCP
"RTN","IBCSCU")
0^41^B12535542
"RTN","IBCSCU",1,0)
IBCSCU ;ALB/MJB - MCCR SCREEN UTILITY ROUTINE ;27 MAY 88 11:09
"RTN","IBCSCU",2,0)
 ;;2.0;INTEGRATED BILLING;**52,51,348,432,447**;21-MAR-94;Build 80
"RTN","IBCSCU",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCSCU",4,0)
 ;
"RTN","IBCSCU",5,0)
 ;MAP TO DGCRSCU
"RTN","IBCSCU",6,0)
 ;
"RTN","IBCSCU",7,0)
 S IBW=1,IBU="UNSPECIFIED",IBUN=IBU_" [NOT REQUIRED]",IBV=$S($D(IBV):IBV,1:1) D HOME^%ZIS
"RTN","IBCSCU",8,0)
 ;S IBWW1="X ""F Z2=1:1:(Z1-$L(Z)) S Z=Z_"""" """""" W Z Q"
"RTN","IBCSCU",9,0)
 S (IBVO,IBVI)="" I $S('$D(IOST(0)):1,'$D(^DG(43,1,0)):1,'$P(^DG(43,1,0),"^",36):1,$D(^DG(43,1,"TERM",IOST(0))):1,1:0) G M
"RTN","IBCSCU",10,0)
 ;
"RTN","IBCSCU",11,0)
 I $D(IOST(0)) S X="IOINHI;IOINLOW;IOINORM" D ENDR^%ZISS
"RTN","IBCSCU",12,0)
 I $L(IOINHI),$L(IOINLOW) S IBVI=IOINHI,IBVO=$S(IOINORM]"":IOINORM,1:IBINLOW)
"RTN","IBCSCU",13,0)
 D KILL^%ZISS
"RTN","IBCSCU",14,0)
 ;I $D(^%ZIS(2,IOST(0),7)) S I=^(7) I $L($P(I,"^",1)),$L($P(I,"^",2)) S IBVI=$P(I,"^",1),IBVO=$S($P(I,"^",3)]"":$P(I,"^",3),1:$P(I,"^",2))
"RTN","IBCSCU",15,0)
 ;
"RTN","IBCSCU",16,0)
M ;I $L(IBVI_IBVO)>4 S X=80 X ^%ZOSF("RM")
"RTN","IBCSCU",17,0)
 S IBWW="W:IBW ! S Z=$S(IBV:""<""_Z_"">"",$E(IBV1,Z):""<""_Z_"">"",1:""[""_Z_""]"") W:$E(Z)=""["" IBVI,Z,IBVO W:$E(Z)'=""["" Z Q"
"RTN","IBCSCU",18,0)
 ;S IBWW="W:IBW ! S Z=$S(IOST=""C-QUME""&($L(IBVI)'=2):Z,IBV:""<""_Z_"">"",$E(IBV1,Z):""<""_Z_"">"",1:""[""_Z_""]"") W:$E(Z)=""["" @IBVI,Z,@IBVO W:$E(Z)'=""["" Z Q"
"RTN","IBCSCU",19,0)
 I $D(IBPAR) S IBV=0,IBVV="00000" Q
"RTN","IBCSCU",20,0)
 S IBBNO=$P(^DGCR(399,IBIFN,0),"^",1)
"RTN","IBCSCU",21,0)
 S IBVV=$S('$$INPAT^IBCEF(IBIFN):"00010100001",1:"00001010001"),X="63266556"      ; IB*2.0*447 BI
"RTN","IBCSCU",22,0)
 I $P($G(^IBE(353,+$P($G(^DGCR(399,IBIFN,0)),U,19),2)),U,9)'="",$S($D(^DGCR(399,IBIFN,"I1")):1,1:$P($G(^DGCR(399,IBIFN,"M")),U,11)) S $E(IBVV,11)="0"
"RTN","IBCSCU",23,0)
 Q
"RTN","IBCSCU",24,0)
 ;
"RTN","IBCSCU",25,0)
H ;Screen Header
"RTN","IBCSCU",26,0)
 S L="",$P(L,"=",81)=""
"RTN","IBCSCU",27,0)
 I $D(IBH("HELP")) S X="HELP SCREEN" W @IOF,!?(40-($L(X)\2)),IBVI,X,IBVO,!,L G HQ
"RTN","IBCSCU",28,0)
 ; IB*2.0*447 BI Start
"RTN","IBCSCU",29,0)
 S X=$P("DEMOGRAPHIC^EMPLOYMENT^PAYER^EVENT - INPATIENT^EVENT - OUTPATIENT^BILLING - GENERAL^BILLING - GENERAL^BILLING - CLAIM^AMBULANCE^BILLING - SPECIFIC^LOCALLY DEFINED","^",IBSR)_" INFORMATION",X1="SCREEN <"_+IBSR_">"
"RTN","IBCSCU",30,0)
 ; IB*2.0*447 BI End
"RTN","IBCSCU",31,0)
 N IB0,IBT S IB0=$G(^DGCR(399,IBIFN,0)),IBT=$P(IB0,U,19),DGINPT=$S($$INPAT^IBCEF(IBIFN):"Inpat",1:"Outpat")
"RTN","IBCSCU",32,0)
 ;
"RTN","IBCSCU",33,0)
 W @IOF                                          ; clear screen
"RTN","IBCSCU",34,0)
 W !,VADM(1)                                     ; name
"RTN","IBCSCU",35,0)
 W "   ",$P(VADM(2),"^",2)                       ; ssn
"RTN","IBCSCU",36,0)
 W "   BILL#: ",IBBNO_" - "_DGINPT,"/"           ; claim# - type
"RTN","IBCSCU",37,0)
 I IBT=2 W "1500"                                ; form type 2
"RTN","IBCSCU",38,0)
 I IBT=3 W $TR($P($G(^IBE(353,3,0)),U,1),"-")    ; form type 3
"RTN","IBCSCU",39,0)
 W ?(80-$L(X1)),X1                               ; screen#
"RTN","IBCSCU",40,0)
 W !,L                                           ; separator line
"RTN","IBCSCU",41,0)
 W !?(40-($L(X)\2)),IBVI,X,IBVO                  ; screen description
"RTN","IBCSCU",42,0)
HQ ;
"RTN","IBCSCU",43,0)
 K L,DGINPT
"RTN","IBCSCU",44,0)
 Q
"RTN","IBCSCU",45,0)
 ;
"RTN","IBCSCU",46,0)
A ;Format Address(es)
"RTN","IBCSCU",47,0)
 N Y F I=IBA1:1:IBA1+2 I $P(IB(IBAD),U,I)]"" S IBA(IBA2)=$P(IB(IBAD),U,I),IBA2=IBA2+2
"RTN","IBCSCU",48,0)
 I IBA2=1 S IBA(1)="STREET ADDRESS UNKNOWN",IBA2=IBA2+2
"RTN","IBCSCU",49,0)
 S J=$S($D(^DIC(5,+$P(IB(IBAD),U,IBA1+4),0)):$P(^(0),U,2),1:""),J(1)=$P(IB(IBAD),U,IBA1+3),J(2)=$P(IB(IBAD),U,IBA1+11),IBA(IBA2)=$S(J(1)]""&(J]""):J(1)_", "_J,J(1)]"":J(1),J]"":J,1:"CITY/STATE UNKNOWN")
"RTN","IBCSCU",50,0)
 S Y=$S(IBAD=.11!(IBAD=.121):$P(IB(IBAD),U,IBA1+11),IBAD=.25:$P($G(^DPT(+$G(DFN),.22)),U,6),IBAD=.311:$P($G(^DPT(+$G(DFN),.22)),U,5),1:"") D ZIPOUT^VAFADDR
"RTN","IBCSCU",51,0)
 S IBA(IBA2)=IBA(IBA2)_" "_Y F I=0:0 S I=$O(IBA(I)) Q:I=""  S IBA(I)=$E(IBA(I),1,25)
"RTN","IBCSCU",52,0)
 K IBA1,I,J Q
"RTN","IBCU5")
0^68^B14664584
"RTN","IBCU5",1,0)
IBCU5 ;ALB/AAS - MCCR MAILING ADDRESS UTILITY ROUTINE ;26-FEB-90
"RTN","IBCU5",2,0)
 ;;2.0;INTEGRATED BILLING;**8,52,80,117,51,206,447**;21-MAR-94;Build 80
"RTN","IBCU5",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IBCU5",4,0)
 ;
"RTN","IBCU5",5,0)
 ;MAP TO DGCRU5
"RTN","IBCU5",6,0)
 ;
"RTN","IBCU5",7,0)
EN ;Entry from X-REF from who's responsible
"RTN","IBCU5",8,0)
 ;doesn't set primary insurance field, must be second trigger.
"RTN","IBCU5",9,0)
 S X=$P(^DGCR(399,DA,0),"^",11)
"RTN","IBCU5",10,0)
 I X="p" D MAILP G ENQ
"RTN","IBCU5",11,0)
 I X="o" S DGTAG=$S('$D(^DGCR(399,DA,"M")):"MAILP",'$P(^("M"),"^",11):"MAILP",'$D(^DIC(4,$P(^("M"),"^",11),0)):"MAILP",1:"MAILIN") D @DGTAG G ENQ
"RTN","IBCU5",12,0)
 I X="i",+$G(^DGCR(399,DA,"MP")) D MAILA G ENQ
"RTN","IBCU5",13,0)
ENQ K DGTAG Q
"RTN","IBCU5",14,0)
 ;
"RTN","IBCU5",15,0)
EN1 ;Now Trigger of primary insurance policy from who's responsible
"RTN","IBCU5",16,0)
 ;if only one active policy
"RTN","IBCU5",17,0)
 ;; old Trigger of primary insurer from who's responsible
"RTN","IBCU5",18,0)
 ;Only should be called if primary insurer is null (condition of trigger)
"RTN","IBCU5",19,0)
 ;return ifn of insurer in X
"RTN","IBCU5",20,0)
 ;
"RTN","IBCU5",21,0)
 S X=""
"RTN","IBCU5",22,0)
 I $S('$D(IBAC):1,IBAC=6:1,1:0) Q
"RTN","IBCU5",23,0)
 ;
"RTN","IBCU5",24,0)
 S IBINDT=$S($G(IBIDS(151)):IBIDS(151),$P($G(^DGCR(399,DA,"U")),"^"):$P($G(^DGCR(399,DA,"U")),"^"),1:DT)
"RTN","IBCU5",25,0)
 D ALL^IBCNS1(DFN,"IBDD",2,IBINDT)
"RTN","IBCU5",26,0)
 I $G(IBDD(0))=1 S X=+$O(IBDD(0)) G EN1Q
"RTN","IBCU5",27,0)
 ;
"RTN","IBCU5",28,0)
 ;S IBOUTP=1,IBINDT=$S($G(IBIDS(151)):IBIDS(151),$P($G(^DGCR(399,DA,"U")),"^"):$P($G(^DGCR(399,DA,"U")),"^"),1:DT)
"RTN","IBCU5",29,0)
 ;D ^IBCNS I IBINS S X=IBDD($O(IBDD(0))) S:$O(IBDD(+X)) X="" S X=$S($D(^DIC(36,+X,0)):+X,1:"") G EN1Q
"RTN","IBCU5",30,0)
 S X=""
"RTN","IBCU5",31,0)
EN1Q K IBDD,IBINS,IBIN Q
"RTN","IBCU5",32,0)
 ;
"RTN","IBCU5",33,0)
MAILA ;Store Mailing Address for Bill Payer Carrier (and if not copying  bill or bill not authorized,
"RTN","IBCU5",34,0)
 ; insert Attending Physican Id [36,.1] into Form Locator 92 [399,213]
"RTN","IBCU5",35,0)
 ;
"RTN","IBCU5",36,0)
 S DA=$S('$D(DA):IBIFN,DA']"":IBIFN,1:DA)
"RTN","IBCU5",37,0)
 G MAILQ:$P(^DGCR(399,DA,0),U,11)="p" ; Patient is responsible for bill
"RTN","IBCU5",38,0)
 G MAILQ:$P(^DGCR(399,DA,0),U,11)="o" ; Other party is responsible for bill
"RTN","IBCU5",39,0)
 ;
"RTN","IBCU5",40,0)
 S IB01=+$G(^DGCR(399,DA,"MP"))
"RTN","IBCU5",41,0)
 G MAILQ:'$D(^DIC(36,+IB01,0)) ; Bad insurance data
"RTN","IBCU5",42,0)
 ;
"RTN","IBCU5",43,0)
 S IB02=$$ADD^IBCNADD(DA)
"RTN","IBCU5",44,0)
 ;
"RTN","IBCU5",45,0)
 D UPDMA(DA,IB01,IB02)
"RTN","IBCU5",46,0)
 ;
"RTN","IBCU5",47,0)
 ; Removed reference to obsolete data field with IB*2.0*447 BI
"RTN","IBCU5",48,0)
 ;I '$D(IBCAN)!($G(IBAC)<3) S $P(^DGCR(399,DA,"U1"),U,13)=$P($G(^DIC(36,+IB01,0)),U,10)
"RTN","IBCU5",49,0)
 ;
"RTN","IBCU5",50,0)
MAILQ K IB01,IB02,IB03 Q
"RTN","IBCU5",51,0)
 ;
"RTN","IBCU5",52,0)
UPDMA(DA,IB01,IB02) ; Update insurance company mailing address in file 399
"RTN","IBCU5",53,0)
 ; DA = bill ifn
"RTN","IBCU5",54,0)
 ;IB02 = string returned from call to ADD^IBCNADD
"RTN","IBCU5",55,0)
 ;IB01 = insurance company ifn
"RTN","IBCU5",56,0)
 S $P(^DGCR(399,DA,"M"),"^",4,9)=$E($P($G(^DIC(36,+IB01,0)),"^",1),1,30)_"^"_$P(IB02,"^",1)_"^"_$P(IB02,"^",2)_"^"_$P(IB02,"^",4)_"^"_$P(IB02,"^",5)_"^"_$P(IB02,"^",6)
"RTN","IBCU5",57,0)
 ;
"RTN","IBCU5",58,0)
 ; -- if send bill to employer, piece 7 = name
"RTN","IBCU5",59,0)
 I $P(IB02,"^",8)'="",+$P(IB02,"^",8)'=$P(IB02,"^",8) S $P(^DGCR(399,DA,"M"),"^",4)=$P(IB02,"^",8)
"RTN","IBCU5",60,0)
 ;
"RTN","IBCU5",61,0)
 S $P(^DGCR(399,DA,"M1"),U,1)=$P(IB02,U,3)
"RTN","IBCU5",62,0)
 Q
"RTN","IBCU5",63,0)
 ;
"RTN","IBCU5",64,0)
MAILIN ;Store Mailing Address for Institution
"RTN","IBCU5",65,0)
 S DA=$S('$D(DA):IBIFN,DA']"":IBIFN,1:DA),X=$P(^DGCR(399,DA,"M"),"^",11) G:X']"" MAILINQ G:'$D(^DIC(4,X,0)) MAILINQ
"RTN","IBCU5",66,0)
 S IB01=^DIC(4,X,0),IB02=$S($D(^(1)):^(1),1:"")
"RTN","IBCU5",67,0)
 S $P(^DGCR(399,IBIFN,"M"),"^",4,9)=$P(IB01,U,1)_"^"_$P(IB02,U,1)_"^"_$P(IB02,U,2)_"^"_$P(IB02,U,3)_"^"_$P(IB01,U,2)_"^"_$TR($P(IB02,U,4),"-")
"RTN","IBCU5",68,0)
 S $P(^DGCR(399,IBIFN,"M1"),"^",1)=""
"RTN","IBCU5",69,0)
MAILINQ K IB01,IB02,IB03 Q
"RTN","IBCU5",70,0)
 ;
"RTN","IBCU5",71,0)
MAILP ;Store Patient Mailing address
"RTN","IBCU5",72,0)
 N DFN,VAPA,DGNAM,IBCONF
"RTN","IBCU5",73,0)
 S DA=$S('$D(DA):IBIFN,DA']"":IBIFN,1:DA)
"RTN","IBCU5",74,0)
 S DFN=$P(^DGCR(399,DA,0),"^",2),VAPA("P")="" D DEM^VADPT,ADD^VADPT
"RTN","IBCU5",75,0)
 S IBCONF=$S('$G(VAPA(12)):0,$P($G(VAPA(22,3)),U,3)'="Y":0,1:1) ; Confidential Address
"RTN","IBCU5",76,0)
 S DGNAM=$P(VADM(1),",",2)_" "_$P(VADM(1),",",1)
"RTN","IBCU5",77,0)
 S DGNAM=$S($E(VADM(5))'="F":"MR.",'$D(^DIC(11,+$P(^DPT(DFN,0),"^",5),0)):"MS.","DMW"[$E(^DIC(11,$P(^DPT(DFN,0),"^",5),0)):"MRS.",1:"MS.")_DGNAM
"RTN","IBCU5",78,0)
 S $P(^DGCR(399,DA,"M"),"^",4)=DGNAM
"RTN","IBCU5",79,0)
 I IBCONF D  ; use conf. address for mailing
"RTN","IBCU5",80,0)
 . S $P(^DGCR(399,DA,"M"),"^",5,9)=VAPA(13)_"^"_VAPA(14)_"^"_VAPA(16)_"^"_+VAPA(17)_"^"_$P(VAPA(18),U,1)
"RTN","IBCU5",81,0)
 . S $P(^DGCR(399,DA,"M1"),"^",1)=VAPA(15)
"RTN","IBCU5",82,0)
 I 'IBCONF D
"RTN","IBCU5",83,0)
 . S $P(^DGCR(399,DA,"M"),"^",5,9)=VAPA(1)_"^"_VAPA(2)_"^"_VAPA(4)_"^"_+VAPA(5)_"^"_$P(VAPA(11),U,1)
"RTN","IBCU5",84,0)
 . S $P(^DGCR(399,DA,"M1"),"^",1)=VAPA(3)
"RTN","IBCU5",85,0)
MAILPQ Q
"RTN","IBCU5",86,0)
 ;
"RTN","IBCU5",87,0)
INSUR ;
"RTN","IBCU5",88,0)
 Q
"RTN","IBCU5",89,0)
DEL S $P(^DGCR(399,DA,"M"),"^",4,9)="^^^^^",$P(^("M1"),"^",1)=""
"RTN","IBCU5",90,0)
 Q
"RTN","IBCU61")
0^45^B6243488
"RTN","IBCU61",1,0)
IBCU61 ;ALB/AAS - DELETE ENTRIES IN REVENUE CODE MULT. ; 4-MAY-90
"RTN","IBCU61",2,0)
 ;;2.0;INTEGRATED BILLING;**153,447**;21-MAR-94;Build 80
"RTN","IBCU61",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IBCU61",4,0)
 ;
"RTN","IBCU61",5,0)
 ;MAP TO DGCRU61
"RTN","IBCU61",6,0)
 ;
"RTN","IBCU61",7,0)
ALL ;delete all revenue codes that may have been set up automatically
"RTN","IBCU61",8,0)
 ;ie = $d(^IB(399.5,"d",code ifn))
"RTN","IBCU61",9,0)
 K DA S DA(1)=IBIFN,DA=0 I '$G(IBAUTO) W !,"Removing old Revenue Codes."
"RTN","IBCU61",10,0)
 F DGII=0:0 S DA=$O(^DGCR(399,IBIFN,"RC",DA)) Q:DA<1  S X=$G(^DGCR(399,IBIFN,"RC",DA,0)) D
"RTN","IBCU61",11,0)
 . ;remove revenue codes pre-defined for automatic use AND revenue codes for BASC charges (are automatically created)
"RTN","IBCU61",12,0)
 . ;I $D(^DGCR(399.5,"D",+$P(X,"^")))!($D(^DGCR(399,"ASC1",+$P(X,U,6),IBIFN)))!(+$P(X,U,8)) W:'$G(IBAUTO) "." D DEL
"RTN","IBCU61",13,0)
 . ; IB*2.0*447 BI Added a filter to avoid updating a MANUALLY EDITED revenue code.
"RTN","IBCU61",14,0)
 . I $D(^DGCR(399.5,"D",+$P(X,"^")))!($D(^DGCR(399,"ASC1",+$P(X,U,6),IBIFN)))!(+$P(X,U,8))!('+$P(X,U,16)) W:'$G(IBAUTO) "." D DEL
"RTN","IBCU61",15,0)
 Q
"RTN","IBCU61",16,0)
DEL S DIK="^DGCR(399,"_DA(1)_",""RC""," D ^DIK L ^DGCR(399,IBIFN):1
"RTN","IBCU61",17,0)
 Q
"RTN","IBCU61",18,0)
 ;
"RTN","IBCU61",19,0)
GVAR ;I $D(PTF),PTF]"",$D(^DGPT(PTF,0)),'$P(^DGPT(PTF,0),"^",6),$D(DGPTUPDT) D UPDT^DGPTUTL S DGPTUPDT="" ;if open, update ptf record
"RTN","IBCU61",20,0)
 S IBND0=$S('$D(^DGCR(399,IBIFN,0)):"",1:^(0))
"RTN","IBCU61",21,0)
 S IBNDU=$S('$D(^DGCR(399,IBIFN,"U")):"",1:^("U"))
"RTN","IBCU61",22,0)
 I '$D(IBIDS(.03)) S IBIDS(.03)=$P(IBND0,"^",3)
"RTN","IBCU61",23,0)
 I '$D(IBIDS(.05)) S IBIDS(.05)=$P(IBND0,"^",5)
"RTN","IBCU61",24,0)
 I '$D(IBIDS(.06)) S IBIDS(.06)=$P(IBND0,"^",6)
"RTN","IBCU61",25,0)
 I '$D(IBIDS(.11)) S IBIDS(.11)=$P(IBND0,"^",11)
"RTN","IBCU61",26,0)
 I '$D(IBIDS(.19)) S IBIDS(.19)=$P(IBND0,"^",19)
"RTN","IBCU61",27,0)
 I '$D(IBIDS(151)) S IBIDS(151)=$S(+IBNDU:+IBNDU,1:IBIDS(.03))
"RTN","IBCU61",28,0)
 I '$D(IBIDS(152)) S IBIDS(152)=$S(+$P(IBNDU,"^",2):$P(IBNDU,"^",2),1:IBIDS(.03))
"RTN","IBCU61",29,0)
 I '$D(IBIDS(101)),IBIDS(.11)="i",$D(^DGCR(399,IBIFN,"M")),+^("M"),$D(^DIC(36,+^("M"),0)) S IBIDS(101)=+^DGCR(399,IBIFN,"M")
"RTN","IBCU61",30,0)
 I IBIDS(.11)="i",'$D(IBIDS(101)) S IBQUIT=1 Q
"RTN","IBCU61",31,0)
 ;I IBIDS(.11)="i" S DGINPAR=$S('$D(^DIC(36,+IBIDS(101),0)):"",1:$P(^(0),"^",6,10))
"RTN","IBCU61",32,0)
 I IBIDS(.11)="i" S DGINPAR=$S('$D(^DIC(36,+IBIDS(101),0)):"",1:$P(^(0),"^",6,15))
"RTN","IBCU61",33,0)
 ;
"RTN","IBCU61",34,0)
CAT ;check patient bills to see if Means Test. set IBIDS(.11)="y" (yes)
"RTN","IBCU61",35,0)
 ;I IBIDS(.11)="p",$P(^PRCA(430.2,$P(^DGCR(399.3,$P(^DGCR(399,IBIFN,0),"^",7),0),"^",6),0),"^",6)="C" S IBIDS(.11)="c"
"RTN","IBCU61",36,0)
 I IBIDS(.11)="p",$P($$CATN^PRCAFN(+$P(^DGCR(399.3,+$P(^DGCR(399,IBIFN,0),"^",7),0),"^",6)),"^",3)="C" S IBIDS(.11)="y"
"RTN","IBCU61",37,0)
 Q
"RTN","IBCU62")
0^46^B10149874
"RTN","IBCU62",1,0)
IBCU62 ;ALB/AAS - UTILITY ROUTINE TO SET BEDSECTION/REVENUE CODES FROM PTF DATA ; 29-OCT-90
"RTN","IBCU62",2,0)
 ;;2.0;INTEGRATED BILLING;**133,447**;21-MAR-94;Build 80
"RTN","IBCU62",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IBCU62",4,0)
 ;
"RTN","IBCU62",5,0)
 ;MAP TO DGCRU62
"RTN","IBCU62",6,0)
 ;
"RTN","IBCU62",7,0)
SETREV ;find current active revenue codes for bedsection
"RTN","IBCU62",8,0)
 S (DGREV,DGBR)=0,DGACTDT=-(IBIDS(151)+.01) K DGFND
"RTN","IBCU62",9,0)
 F  S DGACTDT=$O(^DGCR(399.5,"AIVDT",DGBSI,DGACTDT)) Q:'DGACTDT!($D(DGFND))  D
"RTN","IBCU62",10,0)
 . F  S DGREV=$O(^DGCR(399.5,"AIVDT",DGBSI,DGACTDT,DGREV)) Q:'DGREV  D
"RTN","IBCU62",11,0)
 .. F  S DGBR=$O(^DGCR(399.5,"AIVDT",DGBSI,DGACTDT,DGREV,DGBR)) Q:'DGBR  D CHKREV,STORREV:IBCHK
"RTN","IBCU62",12,0)
 Q
"RTN","IBCU62",13,0)
CHKREV ;check if billing rate (dgbr) is active, and use with payer.
"RTN","IBCU62",14,0)
 S IBCHK=0
"RTN","IBCU62",15,0)
 S DGBRN=^DGCR(399.5,DGBR,0) I '$P(DGBRN,"^",5) Q  ;quit if inactive
"RTN","IBCU62",16,0)
 I IBIDS(.11)="i",$P(DGINPAR,"^",2)="",+$P(DGBRN,"^",7) Q  ;quit if non-standard rate
"RTN","IBCU62",17,0)
 I IBIDS(.11)'="i",+$P(DGBRN,"^",7) Q  ;non-standard rates only for ins.
"RTN","IBCU62",18,0)
 S DGREV00="00"_DGREV I IBIDS(.11)="i",$P(DGINPAR,"^",2)]"",$P(DGINPAR,"^",2)'[$E(DGREV00,$L(DGREV00)-2,$L(DGREV00)) Q  ;quit if revenue code not in exception list 
"RTN","IBCU62",19,0)
 I $P(DGBRN,U,6)[IBIDS(.11) S:'$D(DGFND) DGFND="" S IBCHK=1 Q
"RTN","IBCU62",20,0)
 Q
"RTN","IBCU62",21,0)
STORREV ;store revenue code in revenue code file
"RTN","IBCU62",22,0)
 S X=$P(^DGCR(399.5,DGBR,0),"^",3),DGAMNT=$P(^(0),"^",4),DA(1)=IBIFN,DIC(0)="L",DIC="^DGCR(399,IBIFN,""RC"",",DGFUNC="Adding"
"RTN","IBCU62",23,0)
 I $D(^DGCR(399,IBIFN,"RC","ABS",X,DGBSI)) S DA=$O(^DGCR(399,IBIFN,"RC","ABS",X,DGBSI,0)),DGFUNC="Editing" G EDITREV
"RTN","IBCU62",24,0)
 D FILE,WRT
"RTN","IBCU62",25,0)
 Q
"RTN","IBCU62",26,0)
 ;
"RTN","IBCU62",27,0)
FILE ;manually file entry, index with ix1^dik to use compiled x-ref
"RTN","IBCU62",28,0)
 I '$D(DGREVHDR) D REVHDR
"RTN","IBCU62",29,0)
 I IBIDS(.11)="c",IBIDS(.05)<3 S DGBSLOS=1
"RTN","IBCU62",30,0)
 L ^DGCR(399,IBIFN):1
"RTN","IBCU62",31,0)
 S DA=$P(^DGCR(399,IBIFN,"RC",0),"^",3)
"RTN","IBCU62",32,0)
 F DGLL=0:0 S DA=DA+1 Q:'$D(^DGCR(399,IBIFN,"RC",DA,0))
"RTN","IBCU62",33,0)
 ;S ^DGCR(399,IBIFN,"RC",DA,0)=X_"^"_DGAMNT_"^"_DGBSLOS_"^^"_DGBSI_$S($D(DGPROC)&($D(DGDIV)):"^"_DGPROC_"^"_DGDIV,1:"")
"RTN","IBCU62",34,0)
 S ^DGCR(399,IBIFN,"RC",DA,0)=X_"^"_DGAMNT_"^"_DGBSLOS_"^^"_DGBSI_"^"_$G(DGPROC)_"^"_$G(DGDIV)_"^"_1
"RTN","IBCU62",35,0)
 S ^DGCR(399,IBIFN,"RC",0)=$P(^DGCR(399,IBIFN,"RC",0),"^",1,2)_"^"_DA_"^"_($P(^DGCR(399,IBIFN,"RC",0),"^",4)+1)
"RTN","IBCU62",36,0)
 S DIK="^DGCR(399,"_DA(1)_",""RC""," D IX1^DIK L ^DGCR(399,IBIFN):1
"RTN","IBCU62",37,0)
 Q
"RTN","IBCU62",38,0)
 ;
"RTN","IBCU62",39,0)
EDITREV ;edit revenue code data.
"RTN","IBCU62",40,0)
 I '$D(DGREVHDR) D REVHDR
"RTN","IBCU62",41,0)
 I $P(^DGCR(399,IBIFN,"RC",DA,0),U,16) Q  ; IB*2.0*447 BI
"RTN","IBCU62",42,0)
 I IBIDS(.11)="c",IBIDS(.05)<3 S DGBSLOS=1
"RTN","IBCU62",43,0)
 S DIE=DIC,DA(1)=IBIFN,DR=".02///"_DGAMNT_";.03///"_DGBSLOS_";.05///"_DGBS D ^DIE
"RTN","IBCU62",44,0)
 ;
"RTN","IBCU62",45,0)
WRT ;S Z="00"_$P(^DGCR(399.5,DGBR,0),"^",3) W:'$G(IBAUTO) !,DGFUNC,?12,$E(Z,($L(Z)-2),$L(Z)),?24,DGBSLOS,?31,"$",$J(DGAMNT,8,2),?44,DGBS
"RTN","IBCU62",46,0)
 S Z="00"_$P(^DGCR(399.5,DGBR,0),"^",3)
"RTN","IBCU62",47,0)
 W:'$G(IBAUTO) !,DGFUNC,?12,$E(Z,($L(Z)-2),$L(Z)),?24,DGBSLOS,?31,"$",$J(DGAMNT,8,2),?44,DGBS I +$G(DGPROC) W ?65,$P($$CPT^ICPTCOD(+DGPROC),U,2)
"RTN","IBCU62",48,0)
 Q
"RTN","IBCU62",49,0)
REVHDR S DGREVHDR=1 W:'$G(IBAUTO) !,"Updating Revenue Codes",!?10,"REV. CODE",?22,"UNITS",?31,"CHARGE",?44,"BEDSECTION" I $D(DGPROC) W:'$G(IBAUTO) ?65,"PROCEDURE"
"RTN","IBCU7")
0^57^B81426431
"RTN","IBCU7",1,0)
IBCU7 ;ALB/AAS - INTERCEPT SCREEN INPUT OF PROCEDURE CODES ;29-OCT-91
"RTN","IBCU7",2,0)
 ;;2.0;INTEGRATED BILLING;**62,52,106,125,51,137,210,245,228,260,348,371,432,447**;21-MAR-94;Build 80
"RTN","IBCU7",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCU7",4,0)
 ;
"RTN","IBCU7",5,0)
 ;MAP TO DGCRU7
"RTN","IBCU7",6,0)
 ;
"RTN","IBCU7",7,0)
CHKX ;  -interception of input x from Additional Procedure input
"RTN","IBCU7",8,0)
 G:X=" " CHKXQ
"RTN","IBCU7",9,0)
 I $$INPAT^IBCEF(DA(1)),'$P($G(^IBE(350.9,1,1)),"^",15),X'?1A1N D  G CHKXQ
"RTN","IBCU7",10,0)
 . K X
"RTN","IBCU7",11,0)
 . D EN^DDIOL("Site param does not allow entry of non-PTF procedures") ;Fileman error here will be: The previous error occurred when performing an action specified in a Pre-lookup transform (7.5 node).
"RTN","IBCU7",12,0)
 G:'$D(^UTILITY($J,"IB")) CHKXQ
"RTN","IBCU7",13,0)
 S M=($A($E(X,1))-64),S=+$E(X,2) Q:'$G(^UTILITY($J,"IB",M,S))  S X="`"_+^(S)
"RTN","IBCU7",14,0)
 I $D(DGPROCDT),DGPROCDT'=$P($G(^UTILITY($J,"IB",M,1)),"^",2) S DGPROCDT=$P(^(1),"^",2) W !!,"Procedure Date: " S Y=DGPROCDT X ^DD("DD") W Y,!
"RTN","IBCU7",15,0)
CHKXQ Q
"RTN","IBCU7",16,0)
 ;
"RTN","IBCU7",17,0)
CODMUL ;Date oriented entry of procedure
"RTN","IBCU7",18,0)
DELASK I $D(IBZ20),IBZ20,IBZ20'=$P(^DGCR(399,IBIFN,0),U,9) S %=2 W !,"SINCE THE PROCEDURE CODING METHOD HAS BEEN CHANGED, DO YOU WANT TO DELETE ALL",!,"PROCEDURE CODES IN THIS BILL"
"RTN","IBCU7",19,0)
 I  D YN^DICN Q:%=-1  D:%=1 DELADD I %Y?1."?" W !!,"If you answer 'Yes', all procedure codes will be DELETED from this bill.",! G DELASK
"RTN","IBCU7",20,0)
 K %,%Y,DA,IBZ20,DIK ;W !,"Procedure Entry:"
"RTN","IBCU7",21,0)
 ;
"RTN","IBCU7",22,0)
CODDT I $D(IBIFN),$D(^DGCR(399,IBIFN,0)),$P(^(0),U,9) S DIC("V")=$S($P(^(0),U,9)=9:"I +Y(0)=80.1",$P(^(0),U,9)=4!($P(^(0),U,9)=5):"I +Y(0)=81",1:"")
"RTN","IBCU7",23,0)
 I $P($G(^DGCR(399,IBIFN,0)),"^",5)<3 S IBZTYPE=1 I $P($G(^UTILITY($J,"IB",1,1)),"^",2) S DGPROCDT=$P(^(1),"^",2) D ASKCOD
"RTN","IBCU7",24,0)
 S X=$$PRCDIV^IBCU71(IBIFN) I +X W !!,$P(X,U,2),!
"RTN","IBCU7",25,0)
 N Z,Z0 S Z=$G(^DGCR(399,IBIFN,"U")),Z0=$$FMTE^XLFDT($P(Z,U),"2D")_"-"_$$FMTE^XLFDT($P(Z,U,2),"2D")
"RTN","IBCU7",26,0)
 W !,"Select PROCEDURE DATE"_$S($TR(Z0,"-")'="":" ("_Z0_")",1:"")_": " R X:DTIME G:'$T!("^"[X) CODQ D:X["?" CODHLP
"RTN","IBCU7",27,0)
 S IBEX=0 D  ; Get procedure date
"RTN","IBCU7",28,0)
 . I X=" ",$D(DGPROCDT),DGPROCDT?7N S Y=DGPROCDT D D^DIQ W "   (",Y,")" Q
"RTN","IBCU7",29,0)
 . I X=" ",+$P($G(^DGCR(399,IBIFN,"OP",0)),"^",4) S (DGPROCDT,Y)=$O(^DGCR(399,IBIFN,"OP",0)) D D^DIQ W "   (",Y,")" Q
"RTN","IBCU7",30,0)
 . S %DT="EXP",%DT(0)=-DT D ^%DT K %DT I Y<1 S IBEX=1 Q
"RTN","IBCU7",31,0)
 . I '$$OPV2^IBCU41(Y,IBIFN,1) S IBEX=1 Q
"RTN","IBCU7",32,0)
 . S:'$G(IBZTYPE) X=$$OPV^IBCU41(Y,IBIFN) S DGPROCDT=Y
"RTN","IBCU7",33,0)
 I 'IBEX D ASKCOD,ADDCPT^IBCU71:$D(DGCPT)
"RTN","IBCU7",34,0)
 K IBEX
"RTN","IBCU7",35,0)
 G CODDT
"RTN","IBCU7",36,0)
 ;
"RTN","IBCU7",37,0)
ASKCOD N Z,Z0,DA,IBACT,IBQUIT,IBLNPRV  ;WCJ;2.0*432
"RTN","IBCU7",38,0)
 N IBPOPOUT  S IBPOPOUT=0  ; IB*2.0*447 BI
"RTN","IBCU7",39,0)
 K DGCPT
"RTN","IBCU7",40,0)
 S DGCPT=0,DGCPTUP=$P($G(^IBE(350.9,1,1)),"^",19),DGADDVST=0,IBFT=$P($G(^DGCR(399,IBIFN,0)),"^",19)
"RTN","IBCU7",41,0)
 I '$D(^DGCR(399,IBIFN,"CP",0)) S ^DGCR(399,IBIFN,"CP",0)=U_$$GETSPEC^IBEFUNC(399,304)
"RTN","IBCU7",42,0)
 ;
"RTN","IBCU7",43,0)
 F  S IBQUIT=0 D  Q:IBQUIT
"RTN","IBCU7",44,0)
 . S IBPOPOUT=0
"RTN","IBCU7",45,0)
 . S DIC("A")="   Select PROCEDURE: "
"RTN","IBCU7",46,0)
 . S DIC="^DGCR(399,"_IBIFN_",""CP"","
"RTN","IBCU7",47,0)
 . S DIC(0)="AEQMNL"
"RTN","IBCU7",48,0)
 . S DIC("S")="I '$D(DIV(""S""))&($P(^(0),U,2)=DGPROCDT)"
"RTN","IBCU7",49,0)
 . S DIC("DR")="1///^S X=DGPROCDT"
"RTN","IBCU7",50,0)
 . S DA(1)=IBIFN,DLAYGO=399
"RTN","IBCU7",51,0)
 . W ! D ^DIC I Y<1 S IBQUIT=1 Q
"RTN","IBCU7",52,0)
 . S IBPROCP=+Y
"RTN","IBCU7",53,0)
 . ; If we just added inactive code - it must be deleted.
"RTN","IBCU7",54,0)
 . S IBACT=0 ; Active flag
"RTN","IBCU7",55,0)
 . I Y["ICD0" S IBACT=$$ICD0ACT^IBACSV(+$P(Y,U,2),DGPROCDT)
"RTN","IBCU7",56,0)
 . I Y["ICPT" S IBACT=$$CPTACT^IBACSV(+$P(Y,U,2),DGPROCDT)
"RTN","IBCU7",57,0)
 . S DGCPTNEW=$P(Y,"^",3) ;Was the procedure just added?
"RTN","IBCU7",58,0)
 . I DGCPTNEW,'IBACT D DELPROC Q
"RTN","IBCU7",59,0)
 . I 'IBACT W !,*7,"Warning:  Procedure code is inactive on this date",!
"RTN","IBCU7",60,0)
 . I DGCPTNEW,$D(^UTILITY($J,"IB")),$$INPAT^IBCEF(IBIFN),Y["ICPT(" D DATA^IBCU74(Y,.IBLNPRV)
"RTN","IBCU7",61,0)
 . S DGADDVST=$S(DGCPTNEW:1,$D(DGADDVST):DGADDVST,1:0)
"RTN","IBCU7",62,0)
 . N IBPRV,IBPRVO,IBPRVN
"RTN","IBCU7",63,0)
 . ;
"RTN","IBCU7",64,0)
 . ; Line level provider function by form type.
"RTN","IBCU7",65,0)
 . ;     CMS-1500 (FORM TYPE=2)
"RTN","IBCU7",66,0)
 . ;              RENDERING PROVIDER, REFERRING PROVIDER,
"RTN","IBCU7",67,0)
 . ;              and SUPERVISING PROVIDER.
"RTN","IBCU7",68,0)
 . ;     UB-04 (FORM TYPE=3)
"RTN","IBCU7",69,0)
 . ;              RENDERING PROVIDER, REFERRING PROVIDER,
"RTN","IBCU7",70,0)
 . ;              OPERATING PROVIDER, and OTHER OPERATING
"RTN","IBCU7",71,0)
 . ;              PROVIDER.
"RTN","IBCU7",72,0)
 . ;
"RTN","IBCU7",73,0)
 . ; Removed: Call to $$MAINPRV^IBCEU(IBIFN) is for claim
"RTN","IBCU7",74,0)
 . ;          level provider defaults.
"RTN","IBCU7",75,0)
 . ;     1. For new line level providers we don't need
"RTN","IBCU7",76,0)
 . ;        or want default claim level provider
"RTN","IBCU7",77,0)
 . ;        (requirement).
"RTN","IBCU7",78,0)
 . ;     2. We don't want to default claim level to
"RTN","IBCU7",79,0)
 . ;        line level provider (requirement).
"RTN","IBCU7",80,0)
 . ;
"RTN","IBCU7",81,0)
 . K DIC("V")  ; DEM;432 - KILL DIC("V") because this was for previous variable pointer use.
"RTN","IBCU7",82,0)
 . ;
"RTN","IBCU7",83,0)
 . N IBPROCSV  ; DEM;432 - Variable IBPROCSV is variable to preserve value of 'Y', which is procedure code info returned by call to ^DIC.
"RTN","IBCU7",84,0)
 . S IBPROCSV=Y  ; DEM;432 - Preserve value of Y for after calls to FileMan (Y = procedure code info returned by call to ^DIC).
"RTN","IBCU7",85,0)
 . K DR   ;WCJ;IB*2.0*432
"RTN","IBCU7",86,0)
 . ; START IB*2.0*447 BI
"RTN","IBCU7",87,0)
 . ;I Y["ICPT" S DR=".01;16",DIE=DIC,(IBPROCP,DA)=+Y D ^DIE Q:'$D(DA)!($E($G(Y))=U)  K DR ;
"RTN","IBCU7",88,0)
 . I Y["ICPT" S DR=".01;16",DIE=DIC,(IBPROCP,DA)=+Y D ^DIE Q:'$D(DA)!($D(Y))  K DR ;
"RTN","IBCU7",89,0)
 . ; END IB*2.0*447 BI
"RTN","IBCU7",90,0)
 . S DR=""
"RTN","IBCU7",91,0)
 . D EN^IBCU7B ; DEM;432 - Call to line level provider user input.
"RTN","IBCU7",92,0)
 . S Y=IBPROCSV  ; DEM;432 - Restore value of Y after calls to FileMan
"RTN","IBCU7",93,0)
 . K IBPROCSV
"RTN","IBCU7",94,0)
 . K DR   ;WCJ;IB*2.0*432
"RTN","IBCU7",95,0)
 . I IBPOPOUT Q   ; IB*2.0*447 BI
"RTN","IBCU7",96,0)
 . S DR="" I Y["ICPT" S DR="6;5//"_$$DEFDIV(IBIFN)_";"
"RTN","IBCU7",97,0)
 . S DR=DR_$S(IBFT=2:"8;9;17//NO;",1:"")_3,DIE=DIC,(IBPROCP,DA)=+Y D ^DIE Q:'$D(DA)!($E($G(Y))=U)
"RTN","IBCU7",98,0)
 . K DR   ;WCJ;IB*2.0*432
"RTN","IBCU7",99,0)
 . I IBFT=3 D:'$$INPAT^IBCEF(IBIFN) ATTACH  ; DEM;432 - Prompt for Attachment Control Number.
"RTN","IBCU7",100,0)
 . ; DEM;432 - Add Additional OB Minutes to DR string for call to DIE.
"RTN","IBCU7",101,0)
 . S DR=$$SPCUNIT(IBIFN,IBPROCP) S:DR["15;" DR=DR_"74Additional OB Minutes" D ^DIE ; miles/minutes/hours
"RTN","IBCU7",102,0)
 . ;
"RTN","IBCU7",103,0)
 . I IBFT=2 D
"RTN","IBCU7",104,0)
 .. D DX^IBCU72(IBIFN,IBPROCP)
"RTN","IBCU7",105,0)
 .. S X=$$ADDTNL(IBIFN,.DA)
"RTN","IBCU7",106,0)
 . Q:$$INPAT^IBCEF(IBIFN)  ;only outpatient bills
"RTN","IBCU7",107,0)
 . ;add procedures to array for download to PCE: dgcpt(assoc clinic,cpt,'provider^first dx^modifiers',cnt)=""
"RTN","IBCU7",108,0)
 . S DGPROC=$G(^DGCR(399,IBIFN,"CP",+DA,0))
"RTN","IBCU7",109,0)
 . S X=$P(DGPROC,U,18)_U_+$G(^IBA(362.3,+$P(DGPROC,U,11),0))_U_$P(DGPROC,U,15)
"RTN","IBCU7",110,0)
 . I 'DGCPTNEW,$P(DGPROC,"^",7)="" S DGCPTNEW=2
"RTN","IBCU7",111,0)
 . I DGCPTUP,DGCPTNEW S DGCPT=DGCPT+1 I $P(DGPROC,"^",7) S DGCPT($P(DGPROC,"^",7),+DGPROC,X,DGCPT)=""
"RTN","IBCU7",112,0)
 . ; add visit date to bill
"RTN","IBCU7",113,0)
 . I DGADDVST S (X,DINUM)=DGPROCDT D VFILE1^IBCOPV1 K DINUM,X,DGNOADD,DGADDVST
"RTN","IBCU7",114,0)
 ; Delete modifers with only a sequence #, no code
"RTN","IBCU7",115,0)
 S Z=0 F  S Z=$O(^DGCR(399,IBIFN,"CP",Z)) Q:'Z  S Z0=0 F  S Z0=$O(^DGCR(399,IBIFN,"CP",Z,"MOD",Z0)) Q:'Z0  I $P($G(^(Z0,0)),U,2)="" S DA(2)=IBIFN,DA(1)=Z,DA=Z0,DIK="^DGCR(399,"_DA(2)_",""CP"","_DA(1)_",""MOD""," D ^DIK
"RTN","IBCU7",116,0)
 Q
"RTN","IBCU7",117,0)
CODQ K %DT,DGPROC,DIC,DIE,DR,DGPROCDT,IBPROCP,DLAYGO
"RTN","IBCU7",118,0)
 K IBFT,DGNOADD,DGADDVST,DGCPT,DGCPTUP,IBZTYPE,DGCPTNEW
"RTN","IBCU7",119,0)
 Q
"RTN","IBCU7",120,0)
 ;
"RTN","IBCU7",121,0)
DELPROC ; Remove the selected procedure, because of inactive status (cancel selection)
"RTN","IBCU7",122,0)
 W !!,*7,"The Procedure code is inactive on ",$$DAT1^IBOUTL(DGPROCDT),"."
"RTN","IBCU7",123,0)
 W !,"Please select another Procedure."
"RTN","IBCU7",124,0)
 S DA(1)=IBIFN,DA=+Y,DIK="^DGCR(399,"_IBIFN_",""CP"","
"RTN","IBCU7",125,0)
 D ^DIK
"RTN","IBCU7",126,0)
 Q
"RTN","IBCU7",127,0)
 ;
"RTN","IBCU7",128,0)
DELADD N Z,Z0,DA,DIK,X,Y
"RTN","IBCU7",129,0)
 S DA(1)=IBIFN
"RTN","IBCU7",130,0)
 ;Delete references to proc on rev codes
"RTN","IBCU7",131,0)
 S Z=0 F  S Z=$O(^DGCR(399,IBIFN,"RC",Z)) Q:'Z  S Z0=$G(^(Z,0)) I Z0'="",$P(Z0,U,15)!$S($P(Z0,U,10)=3:$P(Z0,U,11),1:0) S DIE="^DGCR(399,"_DA(1)_",""RC"",",DA=Z,DR=".11///@;.15///@"_$S($P(Z0,U,8):"",1:";.08////1") D ^DIE
"RTN","IBCU7",132,0)
 S DIK="^DGCR(399,"_DA(1)_",""CP""," F DA=0:0 S DA=$O(^DGCR(399,DA(1),"CP",DA)) Q:'DA  D ^DIK
"RTN","IBCU7",133,0)
 S DGRVRCAL=1
"RTN","IBCU7",134,0)
 Q
"RTN","IBCU7",135,0)
 ;
"RTN","IBCU7",136,0)
DTMES ;Message if procedure date not in date range
"RTN","IBCU7",137,0)
 Q:'$D(IBIFN)  Q:'$D(^DGCR(399,IBIFN,"U"))  S DGNODUU=^("U")
"RTN","IBCU7",138,0)
 G:X'<$P(DGNODUU,"^")&(X'>$P(DGNODUU,"^",2)) DTMESQ
"RTN","IBCU7",139,0)
 W *7,!!?3,"Date must be within STATEMENT COVERS FROM and STATEMENT COVERS TO period."
"RTN","IBCU7",140,0)
 S Y=$P(DGNODUU,"^") X ^DD("DD")
"RTN","IBCU7",141,0)
 W !?3,"Enter a date between ",Y," and " S Y=$P(DGNODUU,"^",2) X ^DD("DD") W Y,!
"RTN","IBCU7",142,0)
 K X,Y
"RTN","IBCU7",143,0)
DTMESQ K DGNODUU Q
"RTN","IBCU7",144,0)
 ;
"RTN","IBCU7",145,0)
CODHLP ;Display Additional Procedure codes
"RTN","IBCU7",146,0)
 N I,J,Y,IBMOD
"RTN","IBCU7",147,0)
 I '$O(^DGCR(399,IBIFN,"CP",0)) W !!?5,"No Codes Entered!",! Q
"RTN","IBCU7",148,0)
 F I=0:0 S I=$O(^DGCR(399,IBIFN,"CP",I)) Q:'I  S Y=$G(^(I,0)) S Z=$$PRCNM^IBCSCH1($P(Y,"^",1),$P(Y,"^",2)) W !?5,$E($P(Z,"^",2),1,28),?35,"- ",$P(Z,"^") D
"RTN","IBCU7",149,0)
 . N IBY
"RTN","IBCU7",150,0)
 . S IBY=$P(Y,U,2)
"RTN","IBCU7",151,0)
 . S IBMOD=$$GETMOD^IBEFUNC(IBIFN,I,1)
"RTN","IBCU7",152,0)
 . I IBMOD'="" S IBMOD="/"_IBMOD W IBMOD
"RTN","IBCU7",153,0)
 . W ?60,"Date: " S Y=IBY D DT^DIQ
"RTN","IBCU7",154,0)
 ;
"RTN","IBCU7",155,0)
 K Z Q
"RTN","IBCU7",156,0)
 ;
"RTN","IBCU7",157,0)
DICV I $D(IBIFN),$D(^DGCR(399,IBIFN,0)),$P(^(0),U,9) S DIC("V")=$S($P(^(0),U,9)=9:"I +Y(0)=80.1",$P(^(0),U,9)=4!($P(^(0),U,9)=5):"I +Y(0)=81",1:"")
"RTN","IBCU7",158,0)
 Q
"RTN","IBCU7",159,0)
 ;
"RTN","IBCU7",160,0)
DEFDIV(IBIFN) ; Find default division for bill IBIFN
"RTN","IBCU7",161,0)
 Q $P($G(^DG(40.8,+$P($G(^DGCR(399,IBIFN,0)),U,22),0)),U)
"RTN","IBCU7",162,0)
 ;
"RTN","IBCU7",163,0)
ADDTNL(IBIFN,DA) ;
"RTN","IBCU7",164,0)
 N DR,IBOK,X,Y,DIR
"RTN","IBCU7",165,0)
 S IBOK=1
"RTN","IBCU7",166,0)
 S DR="19;50.09;50.08" D ^DIE
"RTN","IBCU7",167,0)
 ;I '($$FT^IBCEF(IBIFN)'=3&($$INPAT^IBCEF(IBIFN))) D ATTACH  ; DEM;432 - Prompt for Attachment Control Number.
"RTN","IBCU7",168,0)
 I '($$FT^IBCEF(IBIFN)=3&($$INPAT^IBCEF(IBIFN))) D ATTACH  ; DEM;432 - Prompt for Attachment Control Number.
"RTN","IBCU7",169,0)
 I $D(Y) S IBOK=0 G ADDTNLQ
"RTN","IBCU7",170,0)
 S DIR("B")="NO",DIR("A")="EDIT CMS-1500 SPECIAL PROGRAM FIELDS and BOX 19?: ",DIR("A",1)=" ",DIR(0)="YA"
"RTN","IBCU7",171,0)
 S DIR("?",1)="Respond YES only if you need to add/edit data for chiropractic visits,"
"RTN","IBCU7",172,0)
 S DIR("?")="EPSDT care, or if billing for HOSPICE and attending is not a hospice employee."
"RTN","IBCU7",173,0)
 D ^DIR K DIR
"RTN","IBCU7",174,0)
 I Y'=1 S IBOK=0 G ADDTNLQ
"RTN","IBCU7",175,0)
 S DR="W !,""  <<EPSDT>>"";50.07;W !!,""  <<HOSPICE>>"";50.03"
"RTN","IBCU7",176,0)
 D ^DIE
"RTN","IBCU7",177,0)
 W !
"RTN","IBCU7",178,0)
ADDTNLQ Q IBOK
"RTN","IBCU7",179,0)
 ;
"RTN","IBCU7",180,0)
XTRA1(Y) ;
"RTN","IBCU7",181,0)
 K Y
"RTN","IBCU7",182,0)
 Q
"RTN","IBCU7",183,0)
 ;
"RTN","IBCU7",184,0)
SPCUNIT(IBIFN,DA) ; return fields for special units if applicable, in DR form
"RTN","IBCU7",185,0)
 N IB0,IBCPT,IBDR,IBCT,IBFT,DFN S IBDR=""
"RTN","IBCU7",186,0)
 S IB0=$G(^DGCR(399,+$G(IBIFN),0)),IBCT=$P(IB0,U,27),IBFT=$P(IB0,U,19),DFN=$P(IB0,U,2)
"RTN","IBCU7",187,0)
 S IBCPT=$G(^DGCR(399,+$G(IBIFN),"CP",+$G(DA),0)) I IBCPT'["ICPT" G SPCUNTQ
"RTN","IBCU7",188,0)
 I +$$ITMUNIT^IBCRU4(+IBCPT,5,IBCT) S IBDR="15;" D SROMIN^IBCU74(IBIFN,DA) G SPCUNTQ ; minutes
"RTN","IBCU7",189,0)
 I +$$ITMUNIT^IBCRU4(+IBCPT,4,IBCT) S IBDR="21;" G SPCUNTQ ; miles
"RTN","IBCU7",190,0)
 I +$$ITMUNIT^IBCRU4(+IBCPT,6,IBCT) S IBDR="22//"_$$OBSHOUR^IBCU74(DFN,$P(IBCPT,U,2))_";" G SPCUNTQ ; hours
"RTN","IBCU7",191,0)
 I +IBFT=2,$P($G(^IBE(353.2,+$P(IBCPT,U,10),0)),U,2)="ANESTHESIA" S IBDR="15;" ; minutes
"RTN","IBCU7",192,0)
SPCUNTQ Q IBDR
"RTN","IBCU7",193,0)
 ;
"RTN","IBCU7",194,0)
ATTACH ; DEM;432 - Attachment control number.
"RTN","IBCU7",195,0)
 ; Ask if user wants to enter Attachment Control Number.
"RTN","IBCU7",196,0)
 N DIR,X,Y,DA,DIE,DR
"RTN","IBCU7",197,0)
 S DIR("A")="Enter Attachment Control Number"
"RTN","IBCU7",198,0)
 S DIR(0)="Y",DIR("B")="NO"
"RTN","IBCU7",199,0)
 D ^DIR
"RTN","IBCU7",200,0)
 Q:'Y
"RTN","IBCU7",201,0)
 ; User chose to enter Attachment Control Number.
"RTN","IBCU7",202,0)
 ; User enters Attachment Control fields.
"RTN","IBCU7",203,0)
 S DA(1)=IBIFN,DA=IBPROCP
"RTN","IBCU7",204,0)
 S DIE="^DGCR(399,"_DA(1)_",""CP"","
"RTN","IBCU7",205,0)
 S DR="71Report Type;72Report Transmission Method;70Attachment Control Number"
"RTN","IBCU7",206,0)
 D ^DIE
"RTN","IBCU7",207,0)
 Q
"RTN","IBCU7B")
0^58^B55412712
"RTN","IBCU7B",1,0)
IBCU7B ;ALB/DEM - LINE LEVEL PROVIDER USER INPUT ;27-SEP-2010
"RTN","IBCU7B",2,0)
 ;;2.0;INTEGRATED BILLING;**432,447**;21-MAR-94;Build 80
"RTN","IBCU7B",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCU7B",4,0)
 Q
"RTN","IBCU7B",5,0)
 ;
"RTN","IBCU7B",6,0)
EN ;
"RTN","IBCU7B",7,0)
 ;
"RTN","IBCU7B",8,0)
 N X,DIC,DIE,DR,DA,DLAYGO,PRVFUN,DIPA,Y,DO,DD,I  ; ,IBPOPOUT IB*2.0*447 BI
"RTN","IBCU7B",9,0)
 I '$D(IBLNPRV("IBCCPT")) N IBLNPRV  ; DEM;432 - Coming from routine IBCCPT.
"RTN","IBCU7B",10,0)
 S:'$G(IBFT) IBFT=$$FT^IBCEF(IBIFN)  ;DEM;432 - Form Type for claim.
"RTN","IBCU7B",11,0)
 I IBFT=3,$$INPAT^IBCEF(IBIFN) Q   ;WCJ*2.0*432 Don't ask line level providers if INPAT UB
"RTN","IBCU7B",12,0)
 Q:(IBFT'=2)&(IBFT'=3)  ;DEM;432 - Must be CMS-1500 (2) or UB-04 (3) Form Type.
"RTN","IBCU7B",13,0)
 S:IBFT=2 PRVFUN(2)="Rendering,Referring,Supervising"  ;DEM;432 - Allowable provider functions for CMS-1500.
"RTN","IBCU7B",14,0)
 S:IBFT=3 PRVFUN(3)="Rendering,Referring,Operating,Other Operating"  ;DEM;432 - Allowable provider functions for UB-04.
"RTN","IBCU7B",15,0)
 ; IB*2.0*447 BI
"RTN","IBCU7B",16,0)
 ; F PRVFUN("CNT")=1:1:$L(PRVFUN(IBFT),",") S PRVFUN=$P(PRVFUN(IBFT),",",PRVFUN("CNT")) D  I $G(IBPOPOUT) K IBPOPOUT Q
"RTN","IBCU7B",17,0)
 F PRVFUN("CNT")=1:1:$L(PRVFUN(IBFT),",") S PRVFUN=$P(PRVFUN(IBFT),",",PRVFUN("CNT")) D  I $G(IBPOPOUT) Q
"RTN","IBCU7B",18,0)
 . S X=$S(PRVFUN="Rendering":3,PRVFUN="Referring":1,PRVFUN="Supervising":5,PRVFUN="Operating":2,1:9)  ;DEM;432 - X=Provider Function Code Number.
"RTN","IBCU7B",19,0)
 . ;I $D(IBLNPRV("IBCCPT")),X'=3 Q  ; DEM;432 - Coming from routine IBCCPT, only interested in RENDERING PROVIDER.
"RTN","IBCU7B",20,0)
 . K DA,DO,DD
"RTN","IBCU7B",21,0)
 . S DA(2)=IBIFN,DA(1)=IBPROCP  ;DEM;432 - Set up DA array for call to FILE^DICN.
"RTN","IBCU7B",22,0)
 . S DIC="^DGCR(399,"_DA(2)_",""CP"","_DA(1)_",""LNPRV"","  ;DEM;432 - Global root of Line Provider multiple.
"RTN","IBCU7B",23,0)
 . S DIC(0)="L"
"RTN","IBCU7B",24,0)
 . S DIC("DR")=".01////"_X  ;DEM;432 - Stuff X (provider function) into new entry.
"RTN","IBCU7B",25,0)
 . I '$D(^DGCR(399,DA(2),"CP",DA(1),"LNPRV","B",X)) D FILE^DICN  ; DEM;432 - Add new entry.
"RTN","IBCU7B",26,0)
 . S DA=+$O(^DGCR(399,DA(2),"CP",DA(1),"LNPRV","B",X,0))  ;DEM;432 - Get DA of line provider entry.
"RTN","IBCU7B",27,0)
 . S DIPA("RF")=X  ;DEM;432 - Save provider function in DIPA("RF") for later use in call to DIE.
"RTN","IBCU7B",28,0)
 . S DIE=DIC
"RTN","IBCU7B",29,0)
 . K DIC,DO,DD,DR,X,Y
"RTN","IBCU7B",30,0)
 . D DRARRY  ;DEM;432 - Set up DR array for call to DIE.
"RTN","IBCU7B",31,0)
 . ;
"RTN","IBCU7B",32,0)
 . ; DEM;432 - Variable IBLNPRV is a flag for called code
"RTN","IBCU7B",33,0)
 . ;           that we are coming from line level provider
"RTN","IBCU7B",34,0)
 . ;           user input (example, EXTCR^IBCEU5).
"RTN","IBCU7B",35,0)
 . ;
"RTN","IBCU7B",36,0)
 . S IBLNPRV=1
"RTN","IBCU7B",37,0)
 . ; preserve DA values
"RTN","IBCU7B",38,0)
 . S IBLNPRV("LNPRVIEN")=DA  ;DEM;432 - DA of line provider entry to edit.
"RTN","IBCU7B",39,0)
 . S IBLNPRV("PROCIEN")=DA(1)  ;DEM;432 - DA(1) is procedure code multiple IEN.
"RTN","IBCU7B",40,0)
 . S DLAYGO=399  ;DEM;432 - Set DLAYGO.
"RTN","IBCU7B",41,0)
 . D ^DIE
"RTN","IBCU7B",42,0)
 . ; IB*2.0*447 BI Changed to correct for empty provider types in global.
"RTN","IBCU7B",43,0)
 . ;I ($G(Y)="^")!($G(Y)=-1) S IBPOPOUT=1 Q  ; User entered caret ("^"), so exit line provider entry.
"RTN","IBCU7B",44,0)
 . I ($D(Y)) S IBPOPOUT=1  ; User entered caret ("^"), so exit line provider entry.
"RTN","IBCU7B",45,0)
 . ; DEM;432 - If line provider zero node exist, and no provider, then delete entry.  Reset DA
"RTN","IBCU7B",46,0)
 . S DA=IBLNPRV("LNPRVIEN"),DA(1)=IBLNPRV("PROCIEN")
"RTN","IBCU7B",47,0)
 . I $D(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV",IBLNPRV("LNPRVIEN"),0))#10,'$P(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV",IBLNPRV("LNPRVIEN"),0),U,2) S DR=".01///@" D ^DIE
"RTN","IBCU7B",48,0)
 . K DIC,DIE,DR,DA,X,Y,DO,DD,DLAYGO,DIPA  ;DEM;432 - Clean up.
"RTN","IBCU7B",49,0)
 . Q
"RTN","IBCU7B",50,0)
 ;
"RTN","IBCU7B",51,0)
 K IBLNPRV,PRVFUN
"RTN","IBCU7B",52,0)
 ;
"RTN","IBCU7B",53,0)
END ;
"RTN","IBCU7B",54,0)
 Q
"RTN","IBCU7B",55,0)
 ;
"RTN","IBCU7B",56,0)
DRARRY ; Set of DR array for user input.
"RTN","IBCU7B",57,0)
 ;
"RTN","IBCU7B",58,0)
 ; DEM;432 - DIE uses DR to execute individual DR array elements, so
"RTN","IBCU7B",59,0)
 ;           need to leave DR(1,399.0404) undefined for DIE to move
"RTN","IBCU7B",60,0)
 ;           DR string into DR(1,399.0404).
"RTN","IBCU7B",61,0)
 ;
"RTN","IBCU7B",62,0)
 ; Note: 'B' line tags represent DR string branching.
"RTN","IBCU7B",63,0)
 ;
"RTN","IBCU7B",64,0)
 ; 399.0404,.01 LINE FUNCTION.
"RTN","IBCU7B",65,0)
 ; Stuff value from FILE^DICN add above (DIPA("RF")) into .01 field.
"RTN","IBCU7B",66,0)
 ; Also, need to set up DIPA("I#") array from claim level for later reference in DR array.
"RTN","IBCU7B",67,0)
 S DR=".01///^S X=DIPA(""RF"");K DIPA S DIPA(""RF"")=X,DIPA(""I1"")=$D(^DGCR(399,DA(2),""I1"")),DIPA(""I2"")=$D(^(""I2"")),DIPA(""I3"")=$D(^(""I3""))"
"RTN","IBCU7B",68,0)
 ;
"RTN","IBCU7B",69,0)
 ; 399.0404,.02 LINE PERFORMED BY.
"RTN","IBCU7B",70,0)
 ; If no provider entered by user, then delete entry (accomplished by
"RTN","IBCU7B",71,0)
 ; deleting .01 field, LINE FUNCTION field).
"RTN","IBCU7B",72,0)
 ; Branch to end (@499) if no provider entered.
"RTN","IBCU7B",73,0)
 ;S:'$D(IBLNPRV("IBCCPT")) DR(1,399.0404,1)=".02"_PRVFUN_$S(PRVFUN'["Operating":" Provider",1:" Physician")_";S:X DIPA(""PRF"")=X,Y=""@4"";.01///@;S Y=""@499"""
"RTN","IBCU7B",74,0)
 ;S:$D(IBLNPRV("IBCCPT")) DR(1,399.0404,1)=".02///"_IBLNPRV("IBCCPT")_";.02Rendering;S:X DIPA(""PRF"")=X,Y=""@4"";.01///@;S Y=""@499"""
"RTN","IBCU7B",75,0)
 S DR(1,399.0404,1)=""
"RTN","IBCU7B",76,0)
 S:$D(IBLNPRV("IBCCPT"))&(PRVFUN["Rendering") DR(1,399.0404,1)=".02///"_IBLNPRV("IBCCPT")_";"
"RTN","IBCU7B",77,0)
 S DR(1,399.0404,1)=DR(1,399.0404,1)_".02"_PRVFUN_$S(PRVFUN'["Operating":" Provider",1:" Physician")_";S:X DIPA(""PRF"")=X,Y=""@4"";.01///@;S Y=""@499"""
"RTN","IBCU7B",78,0)
 ; Branch to @48 if VA PROVIDER.
"RTN","IBCU7B",79,0)
 ; IF Non-VA PROVIDER, then file changes to IB NON/OTHER VA BILLING PROVIDER File (#355.93) for user input.
"RTN","IBCU7B",80,0)
 ; DR string syntax ";^355.93^IBA(355.93," accomplishes variable pointer file change.
"RTN","IBCU7B",81,0)
 ; See DR array DR(2,355.93) and DR(2,355.93,SEQ #) below for details.
"RTN","IBCU7B",82,0)
 ;
"RTN","IBCU7B",83,0)
 S DR(1,399.0404,2)="@4;N Z1 S Z1=$P($G(^DGCR(399,DA(2),""CP"",DA(1),""LNPRV"",DA,0)),U,2) S DIPA(""NVA_PRV"")=$S(Z1[""IBA(355.93"":+Z1,1:0) S X=+X I DIPA(""NVA_PRV"")=0 S Y=""@48"""
"RTN","IBCU7B",84,0)
 S DR(1,399.0404,3)="S:$D(^XUSEC(""IB PROVIDER EDIT"",DUZ)) DLAYGO=355.93;^355.93^IBA(355.93,"
"RTN","IBCU7B",85,0)
 ;
"RTN","IBCU7B",86,0)
NVAPRV ; Start of user input into IB NON/OTHER VA BILLING PROVIDER File (#355.93).
"RTN","IBCU7B",87,0)
 ;
"RTN","IBCU7B",88,0)
 S DR(2,355.93)="S DIPA(""NVA_PRV-0"")=$G(^IBA(355.93,DIPA(""NVA_PRV""),0))"
"RTN","IBCU7B",89,0)
 ;
"RTN","IBCU7B",90,0)
 ; Branch to @42 if PROVIDER TYPE equals '1' FOR FACILITY/GROUP.
"RTN","IBCU7B",91,0)
 ; Branch to @41 if CREDENTIALS are not NULL.
"RTN","IBCU7B",92,0)
 S DR(2,355.93,1)="S:$P(DIPA(""NVA_PRV-0""),U,2)=1 Y=""@42"";S:$P(DIPA(""NVA_PRV-0""),U,3)'="""" Y=""@41"""
"RTN","IBCU7B",93,0)
 ;
"RTN","IBCU7B",94,0)
 ; 355.93,.03 CREDENTIALS.
"RTN","IBCU7B",95,0)
 S DR(2,355.93)="S DIPA(""NVA_PRV-0"")=$G(^IBA(355.93,DIPA(""NVA_PRV""),0))"
"RTN","IBCU7B",96,0)
 ;
"RTN","IBCU7B",97,0)
 ; Branch to @42 if PROVIDER TYPE equals '1' FOR FACILITY/GROUP.
"RTN","IBCU7B",98,0)
 ; Branch to @41 if CREDENTIALS are not NULL.
"RTN","IBCU7B",99,0)
 S DR(2,355.93,1)="S:$P(DIPA(""NVA_PRV-0""),U,2)=1 Y=""@42"";S:$P(DIPA(""NVA_PRV-0""),U,3)'="""" Y=""@41"""
"RTN","IBCU7B",100,0)
 ;
"RTN","IBCU7B",101,0)
 ; 355.93,.03 CREDENTIALS.
"RTN","IBCU7B",102,0)
 S DR(2,355.93,2)=".03"
"RTN","IBCU7B",103,0)
B41 ;
"RTN","IBCU7B",104,0)
 ; 355.93,.04 SPECIALTY.
"RTN","IBCU7B",105,0)
 ; Branch to @45 if CREDENTIALS are not NULL.
"RTN","IBCU7B",106,0)
 S DR(2,355.93,3)="@41;S:$P(DIPA(""NVA_PRV-0""),U,3)'="""" Y=""@45"";.04;S Y=""@45"""
"RTN","IBCU7B",107,0)
B42 ;
"RTN","IBCU7B",108,0)
 ; 355.93,.05 STREET ADDRESS.
"RTN","IBCU7B",109,0)
 ; 355.93,.06 CITY.
"RTN","IBCU7B",110,0)
 ; 355.93,.07 STATE.
"RTN","IBCU7B",111,0)
 ; Branch to @43 if there is an STREET ADDRESS, CITY, and STATE.
"RTN","IBCU7B",112,0)
 S DR(2,355.93,4)="@42;S:$P(DIPA(""NVA_PRV-0""),U,5)'=""""&($P(DIPA(""NVA_PRV-0""),U,6)'="""")&($P(DIPA(""NVA_PRV-0""),U,7)'="""") Y=""@43"""
"RTN","IBCU7B",113,0)
 ; 355.93,.05 STREET ADDRESS.
"RTN","IBCU7B",114,0)
 ; 355.93,.1 STREET ADDRESS LINE 2.
"RTN","IBCU7B",115,0)
 ; 355.93,.06 CITY.
"RTN","IBCU7B",116,0)
 ; 355.93,.07 STATE.
"RTN","IBCU7B",117,0)
 ; 355.93,.08 ZIP CODE.
"RTN","IBCU7B",118,0)
 S DR(2,355.93,5)=".05;.1;.06;.07;.08"
"RTN","IBCU7B",119,0)
B43 ;
"RTN","IBCU7B",120,0)
 ; 355.93,.09 FACILITY DEFAULT ID NUMBER.
"RTN","IBCU7B",121,0)
 ; Branch to @44 if there is a FACILITY DEFAULT ID NUMBER.
"RTN","IBCU7B",122,0)
 S DR(2,355.93,6)="@43;S:$P(DIPA(""NVA_PRV-0""),U,9)'="""" Y=""@44"";.09LAB OR FACILITY PRIMARY ID"
"RTN","IBCU7B",123,0)
B44 ;
"RTN","IBCU7B",124,0)
 ; 355.93,.11 X12 TYPE OF FACILITY.
"RTN","IBCU7B",125,0)
 ; Branch to @45 if there is a X12 TYPE OF FACILITY.
"RTN","IBCU7B",126,0)
 S DR(2,355.93,7)="@44;S:$P(DIPA(""NVA_PRV-0""),U,11)'="""" Y=""@45"";.11"
"RTN","IBCU7B",127,0)
B45 ;
"RTN","IBCU7B",128,0)
 ; 355.93,41.01 NPI.
"RTN","IBCU7B",129,0)
 ; Branch to @46 if there is an NPI.
"RTN","IBCU7B",130,0)
 S DR(2,355.93,8)="@45;S:$P(DIPA(""NVA_PRV-0""),U,14)'="""" Y=""@46"";D EN2^IBCEP82(DIPA(""NVA_PRV""),4)"
"RTN","IBCU7B",131,0)
B46 ;
"RTN","IBCU7B",132,0)
 ; 355.93,42 TAXONOMY CODE.
"RTN","IBCU7B",133,0)
 ; Branch to @47 if there is TAXONOMY data.
"RTN","IBCU7B",134,0)
 ; 355.93,42 TAXONOMY CODE is a multiple (Sub-File 355.9342). We want 'ALL'
"RTN","IBCU7B",135,0)
 ; fields from TAXONOMY CODE Sub-File 355.9342. Thus,
"RTN","IBCU7B",136,0)
 ; DR string S DR(4,355.9342)=".01:.03" below.
"RTN","IBCU7B",137,0)
 S DR(2,355.93,9)="@46;S:$D(^IBA(355.93,DIPA(""NVA_PRV""),""TAXONOMY""))>0 Y=""@47"";42"
"RTN","IBCU7B",138,0)
 S DR(3,355.9342)=".01:.03"
"RTN","IBCU7B",139,0)
B47 ;
"RTN","IBCU7B",140,0)
 ; End of data entry for IB NON/OTHER VA BILLING PROVIDER File (#399.53).
"RTN","IBCU7B",141,0)
 S DR(2,355.93,10)="@47"
"RTN","IBCU7B",142,0)
 ;
"RTN","IBCU7B",143,0)
B48 ;
"RTN","IBCU7B",144,0)
 ;
"RTN","IBCU7B",145,0)
LNPRV ; User input into LINE PROVIDER Sub-File 399.0404.
"RTN","IBCU7B",146,0)
 ;
"RTN","IBCU7B",147,0)
 S DR(1,399.0404,4)="@48"
"RTN","IBCU7B",148,0)
 S DR(1,399.0404,5)="S DIK=""^DGCR(399,""_DA(2)_"",""""CP"""",""_DA(1)_"",""""LNPRV"""","",DIK(1)="".02"" D EN1^DIK K DIK"
"RTN","IBCU7B",149,0)
 ; 399.0404,.15 LINE TAXONOMY.
"RTN","IBCU7B",150,0)
 S DR(1,399.0404,6)=".15Line Level Taxonomy"
"RTN","IBCU7B",151,0)
 S DR(1,399.0404,7)="D DISPTAX^IBCEP81($P($G(^DGCR(399,DA(2),""CP"",DA(1),""LNPRV"",DA,0)),U,15),"""")"
"RTN","IBCU7B",152,0)
 S DR(1,399.0404,8)="N Z S Z=$$EXPAND^IBTRE(399.0404,.08,$P($G(^DGCR(399,DA(2),""CP"",DA(1),""LNPRV"",DA,0)),U,8)) S DIPA(""SPC"")=$S(Z'="""":Z,1:""UNSPECIFIED"")"
"RTN","IBCU7B",153,0)
 S DR(1,399.0404,9)="W !,""    Prov Specialty On File:  "",DIPA(""SPC"")"
"RTN","IBCU7B",154,0)
 S DR(1,399.0404,10)="S DIPA(""CRD"")=$$CRED^IBCEU($P($G(^DGCR(399,DA(2),""CP"",DA(1),""LNPRV"",DA,0)),U,2))"
"RTN","IBCU7B",155,0)
 ; 399.0404,.03 LINE CREDENTIALS
"RTN","IBCU7B",156,0)
 S DR(1,399.0404,11)=".03;K DIPA(""W1"") S:$G(DIPA(""CRD""))'=$P($G(^DGCR(399,DA(2),""CP"",DA(1),""LNPRV"",DA,0)),U,3) DIPA(""W1"")=1"
"RTN","IBCU7B",157,0)
 S DR(1,399.0404,12)="I $G(DIPA(""W1"")) D WRT1^IBCSC10H($G(DIPA(""CRD"")))"
"RTN","IBCU7B",158,0)
 ; Branch to @405 if File #399 PRIMARY NODE is non numeric.
"RTN","IBCU7B",159,0)
 S DR(1,399.0404,13)="K DIPA(""W1"") I '$G(DIPA(""I1"")) S Y=""@405"""
"RTN","IBCU7B",160,0)
 ; Branching based on DIPA("EDIT") - DIPA("EDIT") set in PROVID^IBCEP2B call
"RTN","IBCU7B",161,0)
 S DR(1,399.0404,14)="D PROVID^IBCEP2B(DA(2),DA,1,.DIPA) S Y=$S(DIPA(""EDIT"")<0:""@482"",DIPA(""EDIT"")=1:""@491"",DIPA(""EDIT"")=2:""@471"",1:"""")"
"RTN","IBCU7B",162,0)
B482 ;
"RTN","IBCU7B",163,0)
 ; Branch to @405 if File #399 SECORDARY NODE is non numeric.
"RTN","IBCU7B",164,0)
 S DR(1,399.0404,15)="@482;I '$G(DIPA(""I2"")) S Y=""@405"""
"RTN","IBCU7B",165,0)
 S DR(1,399.0404,16)="D PROVID^IBCEP2B(DA(2),DA,2,.DIPA)"
"RTN","IBCU7B",166,0)
 ; Branching based on DIPA("EDIT") - DIPA("EDIT") set in PROVID^IBCEP2B call.
"RTN","IBCU7B",167,0)
 S DR(1,399.0404,17)="S Y=$S(DIPA(""EDIT"")<0:""@483"",DIPA(""EDIT"")=1:""@492"",DIPA(""EDIT"")=2:""@472"",1:"""")"
"RTN","IBCU7B",168,0)
B483 ;
"RTN","IBCU7B",169,0)
 ; Branch to @405 if File #399 TERTIARY NODE is non numeric.
"RTN","IBCU7B",170,0)
 S DR(1,399.0404,18)="@483;I '$G(DIPA(""I3"")) S Y=""@405"""
"RTN","IBCU7B",171,0)
 S DR(1,399.0404,19)="D PROVID^IBCEP2B(DA(2),DA,3,.DIPA)"
"RTN","IBCU7B",172,0)
 ; Branching based on DIPA("EDIT") - DIPA("EDIT") set in PROVID^IBCEP2B call.
"RTN","IBCU7B",173,0)
 S DR(1,399.0404,20)="S Y=$S(DIPA(""EDIT"")<0:""@405"",DIPA(""EDIT"")=1:""@493"",DIPA(""EDIT"")=2:""@473"",1:"""");S Y=""@405"""
"RTN","IBCU7B",174,0)
B491 ;
"RTN","IBCU7B",175,0)
 ; 399.0404,.12 LINE PRIM INS PROVIDER ID TYPE.
"RTN","IBCU7B",176,0)
 ; 399.0404,.05 LINE PRIMARY INS CO ID NUMBER.
"RTN","IBCU7B",177,0)
 ; Branch to @482.
"RTN","IBCU7B",178,0)
 S DR(1,399.0404,21)="@491;.12R~T;.05T;S Y=""@482"""
"RTN","IBCU7B",179,0)
B492 ;
"RTN","IBCU7B",180,0)
 ; 399.0404,.13 LINE SEC INS PROVIDER ID TYPE.
"RTN","IBCU7B",181,0)
 ; 399.0404,.06 LINE SECONDARY INS CO ID NUMBER.
"RTN","IBCU7B",182,0)
 ; Branch to @483.
"RTN","IBCU7B",183,0)
 S DR(1,399.0404,22)="@492;.13R~T;.06T;S Y=""@483"""
"RTN","IBCU7B",184,0)
B493 ;
"RTN","IBCU7B",185,0)
 ; 399.0404,.14 LINE TERT INS PROVIDER ID TYPE.
"RTN","IBCU7B",186,0)
 ; 399.0404,.07 LINE TERTIARY INS CO ID NUMBER.
"RTN","IBCU7B",187,0)
 ; Branch to @405.
"RTN","IBCU7B",188,0)
 S DR(1,399.0404,23)="@493;.14R~T;.07T;S Y=""@405"""
"RTN","IBCU7B",189,0)
B471 ;
"RTN","IBCU7B",190,0)
 ; 399.0404,.12 LINE PRIM INS PROVIDER ID TYPE.
"RTN","IBCU7B",191,0)
 ; 399.0404,.05 LINE PRIMARY INS CO ID NUMBER.
"RTN","IBCU7B",192,0)
 ; Branch to @482.
"RTN","IBCU7B",193,0)
 S DR(1,399.0404,24)="@471;.12////^S X=DIPA(""PRIDT"");.05////^S X=DIPA(""PRID"");S Y=""@482"""
"RTN","IBCU7B",194,0)
B472 ;
"RTN","IBCU7B",195,0)
 ; 399.0404,.13 LINE SEC INS PROVIDER ID TYPE.
"RTN","IBCU7B",196,0)
 ; 399.0404,.06 LINE SECONDARY INS CO ID NUMBER.
"RTN","IBCU7B",197,0)
 ; Branch to @483.
"RTN","IBCU7B",198,0)
 S DR(1,399.0404,25)="@472;.13////^S X=DIPA(""PRIDT"");.06////^S X=DIPA(""PRID"");S Y=""@483"""
"RTN","IBCU7B",199,0)
B473 ;
"RTN","IBCU7B",200,0)
 ; 399.0404,.14 LINE TERT INS PROVIDER ID TYPE.
"RTN","IBCU7B",201,0)
 ; 399.0404,.07 LINE TERTIARY INS CO ID NUMBER.
"RTN","IBCU7B",202,0)
 ; Branch to @405.
"RTN","IBCU7B",203,0)
 S DR(1,399.0404,26)="@473;.14////^S X=DIPA(""PRIDT"");.07////^S X=DIPA(""PRID"");S Y=""@405"""
"RTN","IBCU7B",204,0)
B405 ;
"RTN","IBCU7B",205,0)
 S DR(1,399.0404,27)="@405"
"RTN","IBCU7B",206,0)
 ;
"RTN","IBCU7B",207,0)
B499 ;
"RTN","IBCU7B",208,0)
 ; End of user input @499 and W @IOF.
"RTN","IBCU7B",209,0)
 S DR(1,399.0404,28)="@499;W @IOF"
"RTN","IBCU7B",210,0)
 Q
"RTN","IBCU9")
0^47^B4596044
"RTN","IBCU9",1,0)
IBCU9 ;ALB/BI - BILLING UTILITY ROUTINE (CONTINUED) ;01 JUL 2011 11:13
"RTN","IBCU9",2,0)
 ;;2.0;INTEGRATED BILLING;**447**;01-JUL-2011;Build 80
"RTN","IBCU9",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBCU9",4,0)
 Q
"RTN","IBCU9",5,0)
 ;
"RTN","IBCU9",6,0)
CMAEDALL(IBIEN)  ; Clear all manually edited flags for a claim.
"RTN","IBCU9",7,0)
 N IBRCIEN S IBRCIEN=0
"RTN","IBCU9",8,0)
 F  S IBRCIEN=$O(^DGCR(399,IBIEN,"RC",IBRCIEN)) Q:+IBRCIEN=0  D
"RTN","IBCU9",9,0)
 . D CMAEDIND(IBIEN,IBRCIEN)
"RTN","IBCU9",10,0)
 Q
"RTN","IBCU9",11,0)
 ;
"RTN","IBCU9",12,0)
CMAEDIND(IBIEN,IBRCIEN)  ; Clear individual manually edited flags for a revenue code.
"RTN","IBCU9",13,0)
 S $P(^DGCR(399,IBIEN,"RC",IBRCIEN,0),U,16)=""
"RTN","IBCU9",14,0)
 Q
"RTN","IBCU9",15,0)
 ;
"RTN","IBCU9",16,0)
FROMPROC(IBIEN,IBCPIEN,IBFLG)  ; Clear individual manually edited flag if procedures match.
"RTN","IBCU9",17,0)
 I $G(IBIEN)="" Q
"RTN","IBCU9",18,0)
 I $G(IBCPIEN)="" Q
"RTN","IBCU9",19,0)
 I $G(IBFLG)="" Q
"RTN","IBCU9",20,0)
 I IBFLG="E",IBCPIEN=$O(^DGCR(399,IBIEN,"CP",0)) D CMAEDALL(IBIEN) Q
"RTN","IBCU9",21,0)
 I IBFLG="D",IBCPIEN=$O(^DGCR(399,IBIEN,"CP",0)) D PROC1DEL(IBIEN) Q
"RTN","IBCU9",22,0)
 N IBRC0,IBRCPRSP
"RTN","IBCU9",23,0)
 N IBRCIEN S IBRCIEN=0
"RTN","IBCU9",24,0)
 F  S IBRCIEN=$O(^DGCR(399,IBIEN,"RC",IBRCIEN)) Q:+IBRCIEN=0  D
"RTN","IBCU9",25,0)
 . S IBRC0=$G(^DGCR(399,IBIEN,"RC",IBRCIEN,0)),IBRCPRSP=$P(IBRC0,U,11)
"RTN","IBCU9",26,0)
 . I IBRCPRSP=IBCPIEN D CMAEDIND(IBIEN,IBRCIEN)
"RTN","IBCU9",27,0)
 Q
"RTN","IBCU9",28,0)
 ;
"RTN","IBCU9",29,0)
PROC1DEL(IBIEN)  ; The first procedure was deleted, determine division change.
"RTN","IBCU9",30,0)
 N IBCPIEN1,IBCPIEN2
"RTN","IBCU9",31,0)
 S IBCPIEN1=$O(^DGCR(399,IBIEN,"CP",0)) I IBCPIEN1="" Q
"RTN","IBCU9",32,0)
 S IBCPIEN2=$O(^DGCR(399,IBIEN,"CP",IBCPIEN1)) I IBCPIEN2="" D CMAEDALL(IBIEN) Q
"RTN","IBCU9",33,0)
 I $P($G(^DGCR(399,IBIEN,"CP",IBCPIEN1,0)),U,6)'=$P($G(^DGCR(399,IBIEN,"CP",IBCPIEN2,0)),U,6) D CMAEDALL(IBIEN)
"RTN","IBCU9",34,0)
 Q
"RTN","IBJTTC")
0^21^B69337757
"RTN","IBJTTC",1,0)
IBJTTC ;ALB/ARH/PJH - TPI AR COMMENT HISTORY ; 3/18/11 2:15pm
"RTN","IBJTTC",2,0)
 ;;2.0;INTEGRATED BILLING;**39,377,431,432,447**;21-MAR-94;Build 80
"RTN","IBJTTC",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBJTTC",4,0)
 ;
"RTN","IBJTTC",5,0)
 ; AR Profile of Comments:  This screen prints the following Comments:
"RTN","IBJTTC",6,0)
 ;    Bill Comments (430,98)  - entered during auditing
"RTN","IBJTTC",7,0)
 ;    For each COMMENT Transaction:
"RTN","IBJTTC",8,0)
 ;           Brief Comment (433,5.02)
"RTN","IBJTTC",9,0)
 ;           Transaction Comment (433,86)
"RTN","IBJTTC",10,0)
 ;           Comment (433,41)
"RTN","IBJTTC",11,0)
 ;
"RTN","IBJTTC",12,0)
EN ; -- main entry point for IBJT AR COMMENT HISTORY
"RTN","IBJTTC",13,0)
 D EN^VALM("IBJT AR COMMENT HISTORY")
"RTN","IBJTTC",14,0)
 Q
"RTN","IBJTTC",15,0)
 ;
"RTN","IBJTTC",16,0)
HDR ; -- header code
"RTN","IBJTTC",17,0)
 D HDR^IBJTU1(+IBIFN,+DFN,13)
"RTN","IBJTTC",18,0)
 Q
"RTN","IBJTTC",19,0)
 ;
"RTN","IBJTTC",20,0)
INIT ; -- init variables and list array
"RTN","IBJTTC",21,0)
 K ^TMP("IBJTTC",$J)
"RTN","IBJTTC",22,0)
 I '$G(DFN)!'$G(IBIFN) S VALMQUIT="" G INITQ
"RTN","IBJTTC",23,0)
 D BLD
"RTN","IBJTTC",24,0)
INITQ Q
"RTN","IBJTTC",25,0)
 ;
"RTN","IBJTTC",26,0)
HELP ; -- help code
"RTN","IBJTTC",27,0)
 S X="?" D DISP^XQORM1 W !!
"RTN","IBJTTC",28,0)
 Q
"RTN","IBJTTC",29,0)
 ;
"RTN","IBJTTC",30,0)
EXIT ; -- exit code
"RTN","IBJTTC",31,0)
 K ^TMP("IBJTTC",$J)
"RTN","IBJTTC",32,0)
 D CLEAR^VALM1
"RTN","IBJTTC",33,0)
 Q
"RTN","IBJTTC",34,0)
 ;
"RTN","IBJTTC",35,0)
BLD ;
"RTN","IBJTTC",36,0)
 N CMLN,CMSTR,X,IBCNT,IBZ,IB0,IBI,IBX,IBD,IBDATE,IBDUZ,IBRCT5,IBLN,IBSTR,IBK,IBJ,DIWL,DIWR,DIWF,COM
"RTN","IBJTTC",37,0)
 ; HIPAA 5010
"RTN","IBJTTC",38,0)
 N IB3611,FOUND
"RTN","IBJTTC",39,0)
 ;
"RTN","IBJTTC",40,0)
 S VALMCNT=0,IBLN=0
"RTN","IBJTTC",41,0)
 ;
"RTN","IBJTTC",42,0)
 ; Bill Comments (430,98)
"RTN","IBJTTC",43,0)
 K COM,^UTILITY($J,"W") D BCOM^RCJIBFN2(IBIFN) I $D(COM)>10 D
"RTN","IBJTTC",44,0)
 . S IBSTR="",IBD="AR BILL COMMENTS:" S IBSTR=$$SETLN(IBD,IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN)
"RTN","IBJTTC",45,0)
 . S IBSTR="",IBSTR=$$SETLN("--------------------------",IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN)
"RTN","IBJTTC",46,0)
 . ;
"RTN","IBJTTC",47,0)
 . S IBJ="" F  S IBJ=$O(COM(IBJ)) Q:'IBJ  S X=$G(COM(IBJ)) I X'="" S DIWL=1,DIWR=54,DIWF=""  D ^DIWP
"RTN","IBJTTC",48,0)
 . ;
"RTN","IBJTTC",49,0)
 . I $D(^UTILITY($J,"W")) S (IBK,IBCNT)=0 F  S IBK=$O(^UTILITY($J,"W",1,IBK)) Q:'IBK  D
"RTN","IBJTTC",50,0)
 .. S IBD=$G(^UTILITY($J,"W",1,IBK,0)) S IBSTR=$$SETLN(IBD,IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN),IBSTR=""
"RTN","IBJTTC",51,0)
 . K ^UTILITY($J,"W")
"RTN","IBJTTC",52,0)
 ; AR profile of comment transactions  (433: 5.02, 41, 86)
"RTN","IBJTTC",53,0)
 K ^TMP("RCJIB",$J),^UTILITY($J,"W") D TRN^RCJIBFN2(IBIFN)
"RTN","IBJTTC",54,0)
 ;
"RTN","IBJTTC",55,0)
 ;HIPAA 5010 - check if contact data has been added as a comment 
"RTN","IBJTTC",56,0)
 I '$$CONTACT D
"RTN","IBJTTC",57,0)
 .;Check for payer contact data in all entries associated with the bill # (IBIFN)
"RTN","IBJTTC",58,0)
 .S (FOUND,IB3611)=0 F  S IB3611=$O(^IBM(361.1,"B",IBIFN,IB3611)) Q:'IB3611  Q:FOUND  S FOUND=$$EN^RCDPAYER(IB3611)
"RTN","IBJTTC",59,0)
 .Q:'FOUND  ; payer contact data does not exist in any of the EOB entries related to claim
"RTN","IBJTTC",60,0)
 .;Add canned text as a brief comment in file #433 which will serve as a notice that contact data came from 835 ERA
"RTN","IBJTTC",61,0)
 .D ADD^RCDPAYER(IBIFN) ;IA 5549
"RTN","IBJTTC",62,0)
 .;Rebuild AR profile of comment transactions
"RTN","IBJTTC",63,0)
 .K ^TMP("RCJIB",$J),^UTILITY($J,"W") D TRN^RCJIBFN2(IBIFN)
"RTN","IBJTTC",64,0)
 ;
"RTN","IBJTTC",65,0)
 I $D(^TMP("RCJIB",$J)) S IBI="" F  S IBI=$O(^TMP("RCJIB",$J,IBI)) Q:'IBI  D
"RTN","IBJTTC",66,0)
 . S IBX=$G(^TMP("RCJIB",$J,IBI)) I $$STNO^RCJIBFN2(+$P(IBX,U,3))'["COMMENT" Q
"RTN","IBJTTC",67,0)
 . S IBRCT5=$$N5^RCJIBFN1(IBI)
"RTN","IBJTTC",68,0)
 . S IBSTR="",IBLN=$$SET(IBSTR,IBLN)
"RTN","IBJTTC",69,0)
 . S IBD=$P(IBX,U,1) S IBSTR=$$SETLN(IBD,IBSTR,2,8)
"RTN","IBJTTC",70,0)
 . S IBD=$$DATE(+$P(IBX,U,2)) S IBSTR=$$SETLN(IBD,IBSTR,14,8)
"RTN","IBJTTC",71,0)
 . S IBD=$P(IBRCT5,U,1) S IBSTR=$$SETLN(IBD,IBSTR,25,30)
"RTN","IBJTTC",72,0)
 . S IBD="FOLLOW-UP DT: "_$$DATE(+$P(IBRCT5,U,2)) S IBSTR=$$SETLN(IBD,IBSTR,57,22)
"RTN","IBJTTC",73,0)
 . S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
"RTN","IBJTTC",74,0)
 .;HIPAA 5010 - check if this comment is contact data
"RTN","IBJTTC",75,0)
 .I $P(IBRCT5,U)["ERA Payer Contact Information" D
"RTN","IBJTTC",76,0)
 ..N CONTACT,PHONE,FAX,EMAIL,WEB,NAME,EXT,PAYER,HAVPAYER
"RTN","IBJTTC",77,0)
 ..;Display contact data IA 5549
"RTN","IBJTTC",78,0)
 ..; primary, secondary, and tertiary contact data need to be displayed.  Display of contact data
"RTN","IBJTTC",79,0)
 ..; should only occur for each unique payer at BILL (B) x-ref of IBM(361.1,"B",IBIFN). 
"RTN","IBJTTC",80,0)
 ..; evaluation starts with the most recent entry.
"RTN","IBJTTC",81,0)
 ..; Contact data belonging to more than one payer can be distinguished by payer name
"RTN","IBJTTC",82,0)
 ..S (HAVPAYER,IB3611)=""
"RTN","IBJTTC",83,0)
 ..F  S IB3611=$O(^IBM(361.1,"B",IBIFN,IB3611),-1) Q:'IB3611  S CONTACT=$$EN^RCDPAYER(IB3611) D
"RTN","IBJTTC",84,0)
 ...Q:'CONTACT
"RTN","IBJTTC",85,0)
 ...S PAYER=$P($G(^IBM(361.1,IB3611,0)),U,2),PAYER=$$EXTERNAL^DILFD(361.1,.02,,PAYER) ;IA 4051
"RTN","IBJTTC",86,0)
 ...Q:PAYER=HAVPAYER  ; payer contact data has already been displayed
"RTN","IBJTTC",87,0)
 ...S HAVPAYER=PAYER
"RTN","IBJTTC",88,0)
 ...S FAX=$P(CONTACT,U,5),EMAIL=$P(CONTACT,U,6),WEB=$P(CONTACT,U,3)
"RTN","IBJTTC",89,0)
 ...S PHONE=$P(CONTACT,U,4),EXT=$P(CONTACT,U,7),NAME=$P(CONTACT,U,2)
"RTN","IBJTTC",90,0)
 ...S IBD="Payer Name: "_PAYER
"RTN","IBJTTC",91,0)
 ...S IBSTR=$$SETLN(IBD,IBSTR,25,78)
"RTN","IBJTTC",92,0)
 ...S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
"RTN","IBJTTC",93,0)
 ...I NAME]"" D
"RTN","IBJTTC",94,0)
 ....S IBD="Contact Name: "_NAME
"RTN","IBJTTC",95,0)
 ....S IBSTR=$$SETLN(IBD,IBSTR,25,78)
"RTN","IBJTTC",96,0)
 ....S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
"RTN","IBJTTC",97,0)
 ...I PHONE]"" D
"RTN","IBJTTC",98,0)
 ....S IBD="Phone Number: "_PHONE S:EXT]"" IBD=IBD_" Ext: "_EXT
"RTN","IBJTTC",99,0)
 ....S IBSTR=$$SETLN(IBD,IBSTR,25,78)
"RTN","IBJTTC",100,0)
 ....S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
"RTN","IBJTTC",101,0)
 ...I FAX]"" D
"RTN","IBJTTC",102,0)
 ....S IBD="Facsimile Number: "_FAX
"RTN","IBJTTC",103,0)
 ....S IBSTR=$$SETLN(IBD,IBSTR,25,78)
"RTN","IBJTTC",104,0)
 ....S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
"RTN","IBJTTC",105,0)
 ...I EMAIL]"" D
"RTN","IBJTTC",106,0)
 ....S IBD="Email Address: "_EMAIL
"RTN","IBJTTC",107,0)
 ....S IBSTR=$$SETLN(IBD,IBSTR,25,78)
"RTN","IBJTTC",108,0)
 ....S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
"RTN","IBJTTC",109,0)
 ...I WEB]"" D
"RTN","IBJTTC",110,0)
 ....S IBD="Website Address:"_$E(WEB,1,40)
"RTN","IBJTTC",111,0)
 ....S IBSTR=$$SETLN(IBD,IBSTR,25,78)
"RTN","IBJTTC",112,0)
 ....S IBLN=$$SET(IBSTR,IBLN),IBSTR="" Q:$L(WEB)<41
"RTN","IBJTTC",113,0)
 ....S IBSTR=$$SETLN($E(WEB,41,96),IBSTR,25,78)
"RTN","IBJTTC",114,0)
 ....S IBLN=$$SET(IBSTR,IBLN),IBSTR="" Q:$L(WEB)<97
"RTN","IBJTTC",115,0)
 ....S IBSTR=$$SETLN($E(WEB,97,115),IBSTR,25,78)
"RTN","IBJTTC",116,0)
 ....S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
"RTN","IBJTTC",117,0)
 ...S IBLN=$$SET(IBSTR,IBLN)
"RTN","IBJTTC",118,0)
 . ;
"RTN","IBJTTC",119,0)
 . ;   -- transaction comments (86)
"RTN","IBJTTC",120,0)
 . S X=$P($G(^TMP("RCJIB",$J,IBI)),U,6) I X'="" S DIWL=1,DIWR=54,DIWF=""  D ^DIWP
"RTN","IBJTTC",121,0)
 . ;
"RTN","IBJTTC",122,0)
 . ;   -- comments  (86 & 41)
"RTN","IBJTTC",123,0)
 . K COM D N7^RCJIBFN1(IBI) I $D(COM)>2 D
"RTN","IBJTTC",124,0)
 .. S IBJ="" F  S IBJ=$O(COM(IBJ)) Q:'IBJ  S X=$G(COM(IBJ)) I X'="" S DIWL=1,DIWR=54,DIWF=""  D ^DIWP
"RTN","IBJTTC",125,0)
 . ;
"RTN","IBJTTC",126,0)
 . I $D(^UTILITY($J,"W")) S (IBK,IBCNT)=0 F  S IBK=$O(^UTILITY($J,"W",1,IBK)) Q:'IBK  D
"RTN","IBJTTC",127,0)
 .. S IBD=$G(^UTILITY($J,"W",1,IBK,0)) S IBSTR=$$SETLN(IBD,IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN),IBSTR=""
"RTN","IBJTTC",128,0)
 . K ^UTILITY($J,"W")
"RTN","IBJTTC",129,0)
 K ^TMP("RCJIB",$J),^UTILITY($J,"W")
"RTN","IBJTTC",130,0)
 ; MRA comments
"RTN","IBJTTC",131,0)
 ; check if we have any comments to display
"RTN","IBJTTC",132,0)
 I $D(^DGCR(399,IBIFN,"TXC","B")) D
"RTN","IBJTTC",133,0)
 .S IBLN=$$SET("",IBLN)
"RTN","IBJTTC",134,0)
 .S IBSTR="",IBSTR=$$SETLN("MRA REQUEST CLAIM COMMENTS",IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN)
"RTN","IBJTTC",135,0)
 .S IBSTR="",IBSTR=$$SETLN("--------------------------",IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN)
"RTN","IBJTTC",136,0)
 .; loop through all available comments
"RTN","IBJTTC",137,0)
 .S IBDATE="" F  S IBDATE=$O(^DGCR(399,IBIFN,"TXC","B",IBDATE),-1) Q:IBDATE=""  D
"RTN","IBJTTC",138,0)
 ..S IBZ=$O(^DGCR(399,IBIFN,"TXC","B",IBDATE,"")),IB0=^DGCR(399,IBIFN,"TXC",IBZ,0),IBDUZ=$P(IB0,U,2)
"RTN","IBJTTC",139,0)
 ..;S IBLN=$$SET("",IBLN)
"RTN","IBJTTC",140,0)
 ..S IBSTR=""
"RTN","IBJTTC",141,0)
 ..S IBSTR=$$SETLN($$FMTE^XLFDT(IBDATE,"2Z"),IBSTR,14,8)
"RTN","IBJTTC",142,0)
 ..S IBSTR=$$SETLN($J("Entered by "_$$GET1^DIQ(200,IBDUZ,.01),54),IBSTR,25,54)
"RTN","IBJTTC",143,0)
 ..S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
"RTN","IBJTTC",144,0)
 ..; loop through comment lines
"RTN","IBJTTC",145,0)
 ..S CMLN=0 F  S CMLN=$O(^DGCR(399,IBIFN,"TXC",IBZ,1,CMLN)) Q:CMLN=""  D
"RTN","IBJTTC",146,0)
 ...S X=^DGCR(399,IBIFN,"TXC",IBZ,1,CMLN,0) I X'="" S DIWL=1,DIWR=54,DIWF=""  D ^DIWP
"RTN","IBJTTC",147,0)
 ...Q
"RTN","IBJTTC",148,0)
 ..I $D(^UTILITY($J,"W")) S IBK=0 F  S IBK=$O(^UTILITY($J,"W",1,IBK)) Q:'IBK  D
"RTN","IBJTTC",149,0)
 ...S CMSTR=$G(^UTILITY($J,"W",1,IBK,0)) S IBSTR=$$SETLN(CMSTR,IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN),IBSTR=""
"RTN","IBJTTC",150,0)
 ...Q
"RTN","IBJTTC",151,0)
 ..K ^UTILITY($J,"W")
"RTN","IBJTTC",152,0)
 ..Q
"RTN","IBJTTC",153,0)
 .;D CLEAN^DILF
"RTN","IBJTTC",154,0)
 .Q
"RTN","IBJTTC",155,0)
 D EOBC ; IB*2.0*432
"RTN","IBJTTC",156,0)
 D MDACMTS ; IB*2.0*447 BI
"RTN","IBJTTC",157,0)
 D CLEAN^DILF
"RTN","IBJTTC",158,0)
 ;
"RTN","IBJTTC",159,0)
 I IBLN=0 S IBLN=$$SET("",IBLN),IBLN=$$SET("No Comment Transactions Exist For This Account.",IBLN)
"RTN","IBJTTC",160,0)
 S VALMCNT=IBLN
"RTN","IBJTTC",161,0)
 Q
"RTN","IBJTTC",162,0)
 ;
"RTN","IBJTTC",163,0)
EOBC ; check for new EOB comments IB*2.0*432
"RTN","IBJTTC",164,0)
 I $D(^DGCR(399,IBIFN,"TXC2","B")) D
"RTN","IBJTTC",165,0)
 .S IBLN=$$SET("",IBLN)
"RTN","IBJTTC",166,0)
 .S IBSTR="",IBSTR=$$SETLN("COB MANAGMENT CLAIM COMMENTS",IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN)
"RTN","IBJTTC",167,0)
 .S IBSTR="",IBSTR=$$SETLN("----------------------------",IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN)
"RTN","IBJTTC",168,0)
 .; loop through all available comments
"RTN","IBJTTC",169,0)
 .S IBDATE="" F  S IBDATE=$O(^DGCR(399,IBIFN,"TXC2","B",IBDATE),-1) Q:IBDATE=""  D
"RTN","IBJTTC",170,0)
 ..S IBZ=$O(^DGCR(399,IBIFN,"TXC2","B",IBDATE,"")),IB0=^DGCR(399,IBIFN,"TXC2",IBZ,0),IBDUZ=$P(IB0,U,2)
"RTN","IBJTTC",171,0)
 ..;S IBLN=$$SET("",IBLN)
"RTN","IBJTTC",172,0)
 ..S IBSTR=""
"RTN","IBJTTC",173,0)
 ..S IBSTR=$$SETLN($$FMTE^XLFDT(IBDATE,"2Z"),IBSTR,14,8)
"RTN","IBJTTC",174,0)
 ..S IBSTR=$$SETLN($J("Entered by "_$$GET1^DIQ(200,IBDUZ,.01),54),IBSTR,25,54)
"RTN","IBJTTC",175,0)
 ..S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
"RTN","IBJTTC",176,0)
 ..; loop through comment lines
"RTN","IBJTTC",177,0)
 ..S CMLN=0 F  S CMLN=$O(^DGCR(399,IBIFN,"TXC2",IBZ,1,CMLN)) Q:CMLN=""  D
"RTN","IBJTTC",178,0)
 ...S X=^DGCR(399,IBIFN,"TXC2",IBZ,1,CMLN,0) I X'="" S DIWL=1,DIWR=54,DIWF=""  D ^DIWP
"RTN","IBJTTC",179,0)
 ...Q
"RTN","IBJTTC",180,0)
 ..I $D(^UTILITY($J,"W")) S IBK=0 F  S IBK=$O(^UTILITY($J,"W",1,IBK)) Q:'IBK  D
"RTN","IBJTTC",181,0)
 ...S CMSTR=$G(^UTILITY($J,"W",1,IBK,0)) S IBSTR=$$SETLN(CMSTR,IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN),IBSTR=""
"RTN","IBJTTC",182,0)
 ...Q
"RTN","IBJTTC",183,0)
 ..K ^UTILITY($J,"W")
"RTN","IBJTTC",184,0)
 ..Q
"RTN","IBJTTC",185,0)
 .Q
"RTN","IBJTTC",186,0)
 Q
"RTN","IBJTTC",187,0)
 ;
"RTN","IBJTTC",188,0)
CONTACT() ;HIPAA 5010 check for contact data in comments
"RTN","IBJTTC",189,0)
 N FOUND,IBI
"RTN","IBJTTC",190,0)
 S FOUND=0,IBI=""
"RTN","IBJTTC",191,0)
 F  S IBI=$O(^TMP("RCJIB",$J,IBI)) Q:'IBI  D  Q:FOUND
"RTN","IBJTTC",192,0)
 .S IBX=$G(^TMP("RCJIB",$J,IBI)) Q:$$STNO^RCJIBFN2(+$P(IBX,U,3))'["COMMENT"
"RTN","IBJTTC",193,0)
 .S:$P($$N5^RCJIBFN1(IBI),U)["ERA Payer Contact Information" FOUND=1
"RTN","IBJTTC",194,0)
 Q FOUND
"RTN","IBJTTC",195,0)
 ;
"RTN","IBJTTC",196,0)
DATE(X) ; date in external format
"RTN","IBJTTC",197,0)
 N Y S Y="" I +X S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
"RTN","IBJTTC",198,0)
 Q Y
"RTN","IBJTTC",199,0)
 ;
"RTN","IBJTTC",200,0)
SETLN(STR,IBX,COL,WD) ;
"RTN","IBJTTC",201,0)
 S IBX=$$SETSTR^VALM1(STR,IBX,COL,WD)
"RTN","IBJTTC",202,0)
 Q IBX
"RTN","IBJTTC",203,0)
 ;
"RTN","IBJTTC",204,0)
SET(STR,LN) ; set up TMP array with screen data
"RTN","IBJTTC",205,0)
 S LN=LN+1 D SET^VALM10(LN,STR)
"RTN","IBJTTC",206,0)
SETQ Q LN
"RTN","IBJTTC",207,0)
 ;
"RTN","IBJTTC",208,0)
MDACMTS ; Check for MDA comments, Load for List Manager Screen IB*2.0*447 BI
"RTN","IBJTTC",209,0)
 ; INTEGRATION CONTROL REGISTRATION is contained in DBIA #5696.
"RTN","IBJTTC",210,0)
 D MCOM^PRCAMDA2(IBIFN,.IBLN)
"RTN","IBJTTC",211,0)
 Q
"RTN","IBOTR2")
0^27^B22290146
"RTN","IBOTR2",1,0)
IBOTR2 ;ALB/CPM - INSURANCE PAYMENT TREND REPORT - COMPILATION ;5-JUN-91
"RTN","IBOTR2",2,0)
 ;;2.0;INTEGRATED BILLING;**21,42,52,80,100,118,128,451,447**;21-MAR-94;Build 80
"RTN","IBOTR2",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified.
"RTN","IBOTR2",4,0)
 ;
"RTN","IBOTR2",5,0)
 ;MAP TO DGCROTR2
"RTN","IBOTR2",6,0)
 ;
"RTN","IBOTR2",7,0)
 ;***
"RTN","IBOTR2",8,0)
 ;S XRTL=$ZU(0),XRTN="IBOTR-2" D T0^%ZOSV ;start rt clock
"RTN","IBOTR2",9,0)
 ;
"RTN","IBOTR2",10,0)
 I $G(IBXTRACT) D E^IBJDE(8,1) ; Change extract status.
"RTN","IBOTR2",11,0)
 ;
"RTN","IBOTR2",12,0)
 K ^TMP($J) S IBQUIT=0
"RTN","IBOTR2",13,0)
 S IBDA="" F  S IBDA=$O(^DGCR(399,"AD",IBRT,IBDA)) Q:'IBDA  D  Q:IBQUIT
"RTN","IBOTR2",14,0)
 .D COMP I IBDA#100=0 S IBQUIT=$$STOP^IBOUTL("Trend Report")
"RTN","IBOTR2",15,0)
 ;
"RTN","IBOTR2",16,0)
 ; - Write the output report.
"RTN","IBOTR2",17,0)
 I 'IBQUIT D
"RTN","IBOTR2",18,0)
 .I 'IBSDIV D:"OP"[IBSORT SORT D EN^IBOTR3(0) Q
"RTN","IBOTR2",19,0)
 .S IBDIV=0 F  S IBDIV=$S('VAUTD:$O(VAUTD(IBDIV)),1:$O(^DG(40.8,IBDIV))) Q:'IBDIV  D:"OP"[IBSORT SORT D EN^IBOTR3(IBDIV) Q:IBQUIT
"RTN","IBOTR2",20,0)
 ;
"RTN","IBOTR2",21,0)
 ;***
"RTN","IBOTR2",22,0)
 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOTR2" D T1^%ZOSV ;stop rt clock
"RTN","IBOTR2",23,0)
ENQ I $D(ZTQUEUED) S ZTREQ="@" Q
"RTN","IBOTR2",24,0)
 K IB,IBAO,IBAP,IBCNT,IBDA,DFN,IBBC,DIC,DA,DR,DIQ,IBDP,IBDBC,IBSCF,IBSCT
"RTN","IBOTR2",25,0)
 K IBCFL,IBDIV,IBQUIT,IBEVT,^TMP($J) D ^%ZISC
"RTN","IBOTR2",26,0)
 Q
"RTN","IBOTR2",27,0)
 ;
"RTN","IBOTR2",28,0)
COMP ; - Compile Bill-Accounts Receivable records for report.
"RTN","IBOTR2",29,0)
 S IBD=$G(^DGCR(399,IBDA,0)) I IBD="" Q
"RTN","IBOTR2",30,0)
 ;
"RTN","IBOTR2",31,0)
 ; - Get division, if necessary.
"RTN","IBOTR2",32,0)
 I 'IBSDIV S IBDIV=0
"RTN","IBOTR2",33,0)
 E  S IBDIV=$$DIV^IBJDF2(IBDA) I 'IBDIV S IBDIV=+$$PRIM^VASITE()
"RTN","IBOTR2",34,0)
 I IBSDIV,'VAUTD,'$D(VAUTD(IBDIV)) Q  ;  Not a selected division.
"RTN","IBOTR2",35,0)
 ;
"RTN","IBOTR2",36,0)
 ; - Exclude receivables referred to Regional Counsel, if necessary.
"RTN","IBOTR2",37,0)
 I 'IBINRC,$P($G(^PRCA(430,IBDA,6)),U,4) Q
"RTN","IBOTR2",38,0)
 ;
"RTN","IBOTR2",39,0)
 ; IB*2.0*451 - get EEOB indicator '%' for bill
"RTN","IBOTR2",40,0)
 S IBPFLAG=$$EEOB^IBOA31(IBDA) ; get 1st/3rd party payment when applicable
"RTN","IBOTR2",41,0)
 S IBBN=$P(IBD,U),DFN=+$P(IBD,U,2),IBEVT=+$P(IBD,U,3),IBBC=$P(IBD,U,5)
"RTN","IBOTR2",42,0)
 S:IBBN="" IBBN="NULL" Q:IBBRT="O"&("12"[IBBC)  Q:IBBRT="I"&("34"[IBBC)
"RTN","IBOTR2",43,0)
 S IBDBC=$$CLO^PRCAFN(IBDA) Q:IBARST="O"&(IBDBC>-2)!(IBARST="C"&(IBDBC<-1))
"RTN","IBOTR2",44,0)
 I IBDBC>0 S IBBN=$G(IBPFLAG)_IBBN_"*" ; add EEOB indicator
"RTN","IBOTR2",45,0)
 E  S IBD=$P($$STA^PRCAFN(IBDA),U,2),IBDBC=$S($L(IBD)>8:$E(IBD,1,8),1:IBD)
"RTN","IBOTR2",46,0)
 I $D(IBBRN),IBBRN="S" S IBBRTY=$S("12"[IBBC:"I",1:"O")
"RTN","IBOTR2",47,0)
 ;
"RTN","IBOTR2",48,0)
 ; - Perform edits for insurance company.
"RTN","IBOTR2",49,0)
 S IBD=$P($G(^DGCR(399,IBDA,"MP")),U),IBINS=$P($G(^DIC(36,+IBD,0)),U)
"RTN","IBOTR2",50,0)
 I $G(IBICPT) Q:'$D(IBICPT(+IBD))  G CANC
"RTN","IBOTR2",51,0)
 I IBICF'="@",IBD="" Q
"RTN","IBOTR2",52,0)
 I $D(IBIC) Q:IBIC="ALL"&(IBD="")  Q:IBIC="NULL"&(IBD]"")
"RTN","IBOTR2",53,0)
 I IBINS="" S IBINS="UNKNOWN" G CANC
"RTN","IBOTR2",54,0)
 I $G(IBIC)="ALL" G CANC
"RTN","IBOTR2",55,0)
 I IBICF="@",IBICL="zzzzz" G CANC
"RTN","IBOTR2",56,0)
 I IBICF]IBINS!(IBINS]IBICL) Q
"RTN","IBOTR2",57,0)
 ;
"RTN","IBOTR2",58,0)
CANC ; - Keep cancelled bills if CANCEL BILL? field was selected or answer
"RTN","IBOTR2",59,0)
 ;   to 'Do you want to include cancelled receivables?' prompt was YES.
"RTN","IBOTR2",60,0)
 S IBCFL=0,IBINS=IBINS_"@@"_IBD Q:'$D(^DGCR(399,IBDA,"S"))  S IBD=^("S")
"RTN","IBOTR2",61,0)
 S IBCNC=0 I "^26^39^"[(U_$P($G(^PRCA(430,IBDA,0)),U,8)_U) S IBCNC=1
"RTN","IBOTR2",62,0)
 I $G(IBCANC),($P(IBD,U,16)!(IBCNC)) S IBCFL=1 G PTDE ; Add canc. bill.
"RTN","IBOTR2",63,0)
 I $G(IBAF)'=16 Q:$P(IBD,U,16)!(IBCNC)  ;      Bill has been cancelled.
"RTN","IBOTR2",64,0)
 ;
"RTN","IBOTR2",65,0)
PTDE ; - Perform Printed/Treatment date edits.
"RTN","IBOTR2",66,0)
 S IBDP=$P(IBD,U,12)
"RTN","IBOTR2",67,0)
 I IBDF=1 Q:IBDP<IBBDT!(IBDP>IBEDT)  ;   Date printed is out of range.
"RTN","IBOTR2",68,0)
 S IBD=$G(^DGCR(399,IBDA,"U")),IBSCF=$P(IBD,U),IBSCT=$P(IBD,U,2)
"RTN","IBOTR2",69,0)
 I IBDF=2 Q:IBSCT<IBBDT!(IBSCF>IBEDT)  ; Treatment dates out of range.
"RTN","IBOTR2",70,0)
 I '$D(IBAF) G BUILD
"RTN","IBOTR2",71,0)
 ;
"RTN","IBOTR2",72,0)
 ; - Find the selected field value and compare to selection parameters.
"RTN","IBOTR2",73,0)
 K IB S DIC=399,DA=IBDA,DR=IBAF,DIQ="IB" S:IBAFD DIQ(0)="I"
"RTN","IBOTR2",74,0)
 D EN^DIQ1 K DIQ S:IBAFD IB(399,IBDA,IBAF)=IB(399,IBDA,IBAF,"I")
"RTN","IBOTR2",75,0)
 S IB=$G(IB(399,IBDA,IBAF)) I IB="",IBAFF'="@" Q
"RTN","IBOTR2",76,0)
 I $D(IBAFZ) Q:IBAFZ="ALL"&(IB="")  Q:IBAFZ="NULL"&(IB]"")
"RTN","IBOTR2",77,0)
 I IB=""!($G(IBAFZ)="ALL") G BUILD
"RTN","IBOTR2",78,0)
 I IBAFF="@",IBAFL="" G BUILD
"RTN","IBOTR2",79,0)
 I +IBAFF=IBAFF,+IBAFL=IBAFL Q:IB<IBAFF!(IB>IBAFL)
"RTN","IBOTR2",80,0)
 E  Q:IBAFF]IB!(IB]IBAFL)
"RTN","IBOTR2",81,0)
 ;
"RTN","IBOTR2",82,0)
BUILD ; - Retrieve A/R data and build sort global.
"RTN","IBOTR2",83,0)
 N IBGRP
"RTN","IBOTR2",84,0)
 S IBAO=$$ORI^PRCAFN(IBDA) S:IBAO<0 IBAO=0
"RTN","IBOTR2",85,0)
 S IBAP=$$TPR^PRCAFN(IBDA) S:IBAP<0 IBAP=0
"RTN","IBOTR2",86,0)
 ; Add group number to report P447
"RTN","IBOTR2",87,0)
 S IBGRP=$$POLICY^IBCEF(IBDA,18) S:IBGRP="" IBGRP=0
"RTN","IBOTR2",88,0)
 ;S ^TMP($J,"IBOTR",IBDIV,IBBRTY,IBINS,$$NAMAGE(DFN,IBEVT)_"@@"_IBBN)=U_IBSCF_U_IBSCT_U_IBDP_U_IBDBC_U_IBAO_U_IBAP_U_IBCFL
"RTN","IBOTR2",89,0)
 S ^TMP($J,"IBOTR",IBDIV,IBBRTY,IBINS,IBGRP,$$NAMAGE(DFN,IBEVT)_"@@"_IBBN)=U_IBSCF_U_IBSCT_U_IBDP_U_IBDBC_U_IBAO_U_IBAP_U_IBCFL
"RTN","IBOTR2",90,0)
 I "OP"[IBSORT D
"RTN","IBOTR2",91,0)
 .;S ^TMP($J,"IBOTR",IBDIV,IBBRTY,IBINS)=$G(^TMP($J,"IBOTR",IBDIV,IBBRTY,IBINS))+$S(IBSORT="O":(IBAO-IBAP),1:IBAP)
"RTN","IBOTR2",92,0)
 .S ^TMP($J,"IBOTR",IBDIV,IBBRTY,IBINS,IBGRP)=$G(^TMP($J,"IBOTR",IBDIV,IBBRTY,IBINS))+$S(IBSORT="O":(IBAO-IBAP),1:IBAP)
"RTN","IBOTR2",93,0)
 Q
"RTN","IBOTR2",94,0)
 ;
"RTN","IBOTR2",95,0)
SORT ; - Create sort global based on amount owed/amount paid, if necessary.  Add Group# w/ p447
"RTN","IBOTR2",96,0)
 N IBGRP
"RTN","IBOTR2",97,0)
 I 'IBSDIV S IBDIV=0
"RTN","IBOTR2",98,0)
 S IBX="" F  S IBX=$O(^TMP($J,"IBOTR",IBDIV,IBX)) Q:IBX=""  D
"RTN","IBOTR2",99,0)
 .S IBINS="" F  S IBINS=$O(^TMP($J,"IBOTR",IBDIV,IBX,IBINS)) Q:IBINS=""  D
"RTN","IBOTR2",100,0)
 ..S IBGRP="" F  S IBGRP=$O(^TMP($J,"IBOTR",IBDIV,IBX,IBINS,IBGRP)) Q:IBGRP=""  D
"RTN","IBOTR2",101,0)
 ...;S IBXX=^(IBGRP),^TMP($J,"IBOTRS",IBDIV,IBX,-IBXX,IBINS,IBGRP)=""
"RTN","IBOTR2",102,0)
 ...S IBXX=$G(^TMP($J,"IBOTR",IBDIV,IBX,IBINS,IBGRP)),^TMP($J,"IBOTRS",IBDIV,IBX,-IBXX,IBINS,IBGRP)=""
"RTN","IBOTR2",103,0)
 K IBX,IBXX
"RTN","IBOTR2",104,0)
 Q
"RTN","IBOTR2",105,0)
 ;
"RTN","IBOTR2",106,0)
NAMAGE(DFN,EVT) ; - Return patient name and age.
"RTN","IBOTR2",107,0)
 ;  Input: DFN = Pointer to patient in file #2
"RTN","IBOTR2",108,0)
 ;         EVT = Event Date of claim
"RTN","IBOTR2",109,0)
 ; Output: Patient name (1st 18 chars.)_"("_Age_")"
"RTN","IBOTR2",110,0)
 ; Output after patch 447: Patient name (1st 16 chars.)_"("_Age_")"
"RTN","IBOTR2",111,0)
 N DPT0,X,X1,X2
"RTN","IBOTR2",112,0)
 S DPT0=$G(^DPT(DFN,0)),X2=$P(DPT0,U,3)
"RTN","IBOTR2",113,0)
 I 'X2 S X="UNK"
"RTN","IBOTR2",114,0)
 E  S X1=EVT S:'X1 X1=DT D ^%DTC S X=X\365.25
"RTN","IBOTR2",115,0)
 ;Q $E($P(DPT0,U),1,18)_" ("_X_")"
"RTN","IBOTR2",116,0)
 Q $E($P(DPT0,U),1,16)_" ("_X_")"
"RTN","IBOTR3")
0^28^B29774240
"RTN","IBOTR3",1,0)
IBOTR3 ;ALB/CPM - INSURANCE PAYMENT TREND REPORT - OUTPUT ;5-JUN-91
"RTN","IBOTR3",2,0)
 ;;2.0;INTEGRATED BILLING;**42,80,100,118,128,133,447**;21-MAR-94;Build 80
"RTN","IBOTR3",3,0)
 ;;Per VHA Directive 2004-38, this routine should not be modified.
"RTN","IBOTR3",4,0)
 ;
"RTN","IBOTR3",5,0)
 ;MAP TO DGCROTR3
"RTN","IBOTR3",6,0)
 ;
"RTN","IBOTR3",7,0)
EN(IBDIV) ; - Entry point from IBOTR2.
"RTN","IBOTR3",8,0)
 ;
"RTN","IBOTR3",9,0)
 ; - Extract zero totals if no data available.
"RTN","IBOTR3",10,0)
 I $G(IBXTRACT),'$D(^TMP($J,"IBOTR",IBDIV)) D  G END
"RTN","IBOTR3",11,0)
 .S IBUNPD=0 F X=1:1:8 S IBTT(X)=0
"RTN","IBOTR3",12,0)
 .D E^IBJDE(8,0)
"RTN","IBOTR3",13,0)
 ;
"RTN","IBOTR3",14,0)
 I $G(IBXTRACT) G IBX ; Calculate grand totals for extract.
"RTN","IBOTR3",15,0)
 ;
"RTN","IBOTR3",16,0)
 S IBPAG=0,IBLINE="",$P(IBLINE,"-",IOM)="-",Y=DT D D^DIQ S IBTDT=Y
"RTN","IBOTR3",17,0)
 I $D(IBAF) D ADDFLD^IBOTR4
"RTN","IBOTR3",18,0)
 I '$D(^TMP($J,"IBOTR",IBDIV)) D  S IBCALC=3 D PAUSE G END
"RTN","IBOTR3",19,0)
 .S IBX=$S("Bb"'[IBBRT:IBBRT,IBBRN="C":"A",1:"I")
"RTN","IBOTR3",20,0)
 .D HDR W !!,"  NO INFORMATION MATCHES SELECTION CRITERIA."
"RTN","IBOTR3",21,0)
 ;
"RTN","IBOTR3",22,0)
IBX S IBX="" F  S IBX=$O(^TMP($J,"IBOTR",IBDIV,IBX)) Q:IBX=""  D  Q:IBQUIT
"RTN","IBOTR3",23,0)
 .I IBPRNT'="G"!('$G(IBG)) S IBTT="0^0^0^0^0^0^0^0^0^0"
"RTN","IBOTR3",24,0)
 .D:'$G(IBXTRACT) HDR Q:IBQUIT  D INS
"RTN","IBOTR3",25,0)
 ;
"RTN","IBOTR3",26,0)
END K IBINS,IBPAG,IBLINE,IBTDT,IBX,IBTT,IBTI,IBCALC,IBBN,IBD,IBDS,IBAFT
"RTN","IBOTR3",27,0)
 K IBAMT,IBG,IBI,IBPERC,IBUNPD,X,X1,X2,IBGRP
"RTN","IBOTR3",28,0)
 Q
"RTN","IBOTR3",29,0)
 ;
"RTN","IBOTR3",30,0)
INS ; - Loop through each insurance company or amount.
"RTN","IBOTR3",31,0)
 I IBSORT="I" D
"RTN","IBOTR3",32,0)
 .S IBINS="" F  S IBINS=$O(^TMP($J,"IBOTR",IBDIV,IBX,IBINS)) Q:IBINS=""  D BILLNO Q:IBQUIT
"RTN","IBOTR3",33,0)
 I IBSORT'="I" D
"RTN","IBOTR3",34,0)
 .S IBAMT="" F  S IBAMT=$O(^TMP($J,"IBOTRS",IBDIV,IBX,IBAMT)) Q:IBAMT=""  S IBINS="" F  S IBINS=$O(^TMP($J,"IBOTRS",IBDIV,IBX,IBAMT,IBINS)) Q:IBINS=""!(IBQUIT)  D BILLNO Q:IBQUIT
"RTN","IBOTR3",35,0)
 ;
"RTN","IBOTR3",36,0)
 ; - Extract grand totals data.
"RTN","IBOTR3",37,0)
 I $G(IBXTRACT),'IBQUIT D  Q
"RTN","IBOTR3",38,0)
 .S IBUNPD=$J($P(IBTT,U,2)-$P(IBTT,U,5),0,2)
"RTN","IBOTR3",39,0)
 .F X=1:1:8 S IBTT(X)=$S(19'[X:$J($P(IBTT,U,X),0,2),1:$P(IBTT,U,X))
"RTN","IBOTR3",40,0)
 .D E^IBJDE(8,0)
"RTN","IBOTR3",41,0)
 ;
"RTN","IBOTR3",42,0)
 I 'IBQUIT,'$G(IBG) D GTOT^IBOTR4 ; Write grand totals for report.
"RTN","IBOTR3",43,0)
 Q
"RTN","IBOTR3",44,0)
 ;
"RTN","IBOTR3",45,0)
BILLNO ; - Loop through all bills for an insurance company.
"RTN","IBOTR3",46,0)
 I $G(IBXTRACT) G LOOP
"RTN","IBOTR3",47,0)
 I $Y>(IOSL-15) S IBCALC=15 D PAUSE Q:IBQUIT  D HDR Q:IBQUIT
"RTN","IBOTR3",48,0)
 I IBPRNT'="G" S IBDS=0,IBTI="0^0^0^0" D INSADD
"RTN","IBOTR3",49,0)
 E  I $G(IBG) S IBTT="0^0^0^0^0^0^0^0^0^0" D INSADD
"RTN","IBOTR3",50,0)
LOOP ; add group# for p447 
"RTN","IBOTR3",51,0)
 ;S IBBN="" F  S IBBN=$O(^TMP($J,"IBOTR",IBDIV,IBX,IBINS,IBBN)) Q:IBBN=""  S IBD=^(IBBN) D DETAIL Q:IBQUIT
"RTN","IBOTR3",52,0)
 S IBGRP="" F  S IBGRP=$O(^TMP($J,"IBOTR",IBDIV,IBX,IBINS,IBGRP)) Q:IBGRP=""!(IBQUIT)  D
"RTN","IBOTR3",53,0)
 .I IBPRNT="M" W !!,"Group #"_$S(IBGRP'=0:IBGRP,1:":  None Defined")
"RTN","IBOTR3",54,0)
 .S IBBN="" F  S IBBN=$O(^TMP($J,"IBOTR",IBDIV,IBX,IBINS,IBGRP,IBBN)) Q:IBBN=""  S IBD=^(IBBN) D DETAIL Q:IBQUIT
"RTN","IBOTR3",55,0)
 I 'IBQUIT D
"RTN","IBOTR3",56,0)
 .I IBPRNT'="G" D SUBTOT^IBOTR4 ; Write insurance co. sub-totals.
"RTN","IBOTR3",57,0)
 .E  D:$G(IBG) GTOT^IBOTR4 ;      Write insurance co. grand totals.
"RTN","IBOTR3",58,0)
 Q
"RTN","IBOTR3",59,0)
 ;
"RTN","IBOTR3",60,0)
DETAIL ; - Write out detail lines.
"RTN","IBOTR3",61,0)
 N IBPEN S IBPEN=$S($P(IBBN,"@@",2)["*":0,1:$P(IBD,U,6)-$P(IBD,U,7))
"RTN","IBOTR3",62,0)
 G:IBPRNT="S" SUBTOT G:IBPRNT="G" GNDTOT
"RTN","IBOTR3",63,0)
 I $Y>(IOSL-7) S IBCALC=7 D PAUSE Q:IBQUIT  D HDR Q:IBQUIT  D INSADD
"RTN","IBOTR3",64,0)
 ;W !,$P(IBBN,"@@",2),?10,$P(IBBN,"@@"),?34,$$DATE($P(IBD,U,2))
"RTN","IBOTR3",65,0)
 W !,$P(IBBN,"@@",2),?13,$P(IBBN,"@@"),?35,$$DATE($P(IBD,U,2))
"RTN","IBOTR3",66,0)
 W ?44,$$DATE($P(IBD,U,3)),?54,$$DATE($P(IBD,U,4))
"RTN","IBOTR3",67,0)
 W ?64,$S($P(IBD,U,5):$$DATE($P(IBD,U,5)),1:$P(IBD,U,5))
"RTN","IBOTR3",68,0)
 S X1=$S($P(IBD,U,5):$P(IBD,U,5),1:DT),X2=$P(IBD,U,4) D ^%DTC S IBDS=IBDS+X
"RTN","IBOTR3",69,0)
 W ?74,$J(X,4),?79,$J($P(IBD,U,6),11,2),?91,$J($P(IBD,U,7),10,2)
"RTN","IBOTR3",70,0)
 W ?102,$J($P(IBD,U,6)-$P(IBD,U,7),11,2),?114,$J(IBPEN,11,2)
"RTN","IBOTR3",71,0)
 W ?126,$J($S(+$P(IBD,U,6)=0:0,1:$P(IBD,U,7)/$P(IBD,U,6)*100),6,2)
"RTN","IBOTR3",72,0)
 ;
"RTN","IBOTR3",73,0)
SUBTOT ; - Update sub-totals.
"RTN","IBOTR3",74,0)
 S $P(IBTI,U)=$P(IBTI,U)+1,$P(IBTI,U,2)=$P(IBTI,U,2)+$P(IBD,U,6)
"RTN","IBOTR3",75,0)
 S $P(IBTI,U,3)=$P(IBTI,U,3)+$P(IBD,U,7),$P(IBTI,U,4)=$P(IBTI,U,4)+IBPEN
"RTN","IBOTR3",76,0)
 ;
"RTN","IBOTR3",77,0)
GNDTOT ; - Update grand totals.
"RTN","IBOTR3",78,0)
 S $P(IBTT,U)=$P(IBTT,U)+1,$P(IBTT,U,2)=$P(IBTT,U,2)+$P(IBD,U,6)
"RTN","IBOTR3",79,0)
 I +$P($P(IBBN,"@@"),"(",2)<65 S $P(IBTT,U,3)=$P(IBTT,U,3)+$P(IBD,U,6),$P(IBTT,U,6)=$P(IBTT,U,6)+$P(IBD,U,7)
"RTN","IBOTR3",80,0)
 E  S $P(IBTT,U,4)=$P(IBTT,U,4)+$P(IBD,U,6),$P(IBTT,U,7)=$P(IBTT,U,7)+$P(IBD,U,7)
"RTN","IBOTR3",81,0)
 S $P(IBTT,U,5)=$P(IBTT,U,5)+$P(IBD,U,7),$P(IBTT,U,8)=$P(IBTT,U,8)+IBPEN
"RTN","IBOTR3",82,0)
 I $G(IBCANC),$P(IBD,U,8) S $P(IBTT,U,9)=$P(IBTT,U,9)+1,$P(IBTT,U,10)=$P(IBTT,U,10)+$P(IBD,U,6)
"RTN","IBOTR3",83,0)
 Q
"RTN","IBOTR3",84,0)
 ;
"RTN","IBOTR3",85,0)
HDR ; - Print the report header.
"RTN","IBOTR3",86,0)
 S IBPAG=IBPAG+1 W @IOF,IBRTN," PAYMENT TREND REPORT - "
"RTN","IBOTR3",87,0)
 W $S(IBX="I":"INPATIENT",IBX="O":"OUTPATIENT",1:"COMBINED INPATIENT AND OUTPATIENT")," BILLING"
"RTN","IBOTR3",88,0)
 W ?109,IBTDT,"   PAGE ",$J(IBPAG,3),!
"RTN","IBOTR3",89,0)
 I IBDIV W "For: ",$P($G(^DG(40.8,IBDIV,0)),U)," - "
"RTN","IBOTR3",90,0)
 W IBDFN,": ",$$DATE(IBBDT)," - ",$$DATE(IBEDT)
"RTN","IBOTR3",91,0)
 I IBPRNT="M" W ?82,"Note: '*' after the Bill No. denotes a CLOSED bill"
"RTN","IBOTR3",92,0)
 W:$D(IBAF) !,IBAFT G:IBPRNT="G" HDL
"RTN","IBOTR3",93,0)
 ;W !!,"BILL",?10,"PATIENT",?55,"DATE",?64,"DATE BILL",?75,"#"
"RTN","IBOTR3",94,0)
 W !!,"BILL",?13,"PATIENT",?55,"DATE",?64,"DATE BILL",?75,"#"
"RTN","IBOTR3",95,0)
 W ?83,"AMOUNT",?93,"AMOUNT",?106,"AMOUNT",?117,"AMOUNT",?127,"PERC"
"RTN","IBOTR3",96,0)
 ;W !,"NUMBER",?10,"NAME (AGE)",?34,"BILL FROM  -  TO",?54,"PRINTED"
"RTN","IBOTR3",97,0)
 W !,"NUMBER",?13,"NAME (AGE)",?35,"BILL FROM  -  TO",?54,"PRINTED"
"RTN","IBOTR3",98,0)
 W ?65,"CLOSED",?74,"DAYS",?83,"BILLED",?92,"COLLECTED",?106,"UNPAID"
"RTN","IBOTR3",99,0)
 W ?117,"PENDING",?127,"COLL"
"RTN","IBOTR3",100,0)
HDL W !,IBLINE
"RTN","IBOTR3",101,0)
 I IBPRNT="M" W !?56,"M A I N  R E P O R T"
"RTN","IBOTR3",102,0)
 I IBPRNT="G" W !?55,"G R A N D  T O T A L S",!
"RTN","IBOTR3",103,0)
 I IBPRNT="S" W !?49,"S U M M A R Y  S T A T I S T I C S"
"RTN","IBOTR3",104,0)
 I "OP"[IBSORT W !?30,"S O R T E D  B Y  A M O U N T  ",$S(IBSORT="O":"O W E",1:"P A I")," D - H I G H E S T  T O  L O W E S T"
"RTN","IBOTR3",105,0)
 S IBQUIT=$$STOP^IBOUTL("Trend Report")
"RTN","IBOTR3",106,0)
 Q
"RTN","IBOTR3",107,0)
 ;
"RTN","IBOTR3",108,0)
DATE(IBX) S:IBX]"" IBX=$E(IBX,4,5)_"/"_$E(IBX,6,7)_"/"_$E(IBX,2,3) Q IBX
"RTN","IBOTR3",109,0)
 ;
"RTN","IBOTR3",110,0)
PAUSE I $E(IOST,1,2)'="C-" Q
"RTN","IBOTR3",111,0)
 I IOSL<60 F IBI=$Y:1:(IOSL-IBCALC) W !
"RTN","IBOTR3",112,0)
 S DIR(0)="E" D ^DIR K DIR
"RTN","IBOTR3",113,0)
 I $D(DIRUT)!($D(DUOUT)) S IBQUIT=1 K DIRUT,DTOUT,DUOUT
"RTN","IBOTR3",114,0)
 Q
"RTN","IBOTR3",115,0)
 ;
"RTN","IBOTR3",116,0)
INSADD ; - Display Insurance Company name and address.
"RTN","IBOTR3",117,0)
 ; Input: IBINS
"RTN","IBOTR3",118,0)
 N D,PH,IEN
"RTN","IBOTR3",119,0)
 W !!?16,"INSURANCE CARRIER: ",$P(IBINS,"@@")
"RTN","IBOTR3",120,0)
 S IEN=$P(IBINS,"@@",2) G:'IEN INSADQ
"RTN","IBOTR3",121,0)
 S D=$G(^DIC(36,IEN,.11)),PH=$P($G(^(.13)),U) G:D="" INSADQ
"RTN","IBOTR3",122,0)
 W:$P(D,U)]"" !?35,$P(D,U)
"RTN","IBOTR3",123,0)
 W:$P(D,U,2)]"" !?35,$P(D,U,2)
"RTN","IBOTR3",124,0)
 W:$P(D,U,3)]"" !?35,$P(D,U,3)
"RTN","IBOTR3",125,0)
 W:$P(D,U)]""!($P(D,U,2)]"")!($P(D,U,3)]"") !?35
"RTN","IBOTR3",126,0)
 W $P(D,U,4) W:$P(D,U,4)]""&($P(D,U,5)]"") ", "
"RTN","IBOTR3",127,0)
 W $P($G(^DIC(5,+$P(D,U,5),0)),U)
"RTN","IBOTR3",128,0)
 W:$P(D,U,6)]""&($P(D,U,4)]""!($P(D,U,5)]"")) "   "
"RTN","IBOTR3",129,0)
 W $P(D,U,6) W:PH]"" $J("",8),"Phone: ",PH
"RTN","IBOTR3",130,0)
INSADQ W ! Q
"RTN","IBY447PO")
0^^B4342146
"RTN","IBY447PO",1,0)
IBY447PO ;ALB/GEF - Post-Installation for IB patch 447 ;19-APR-2011
"RTN","IBY447PO",2,0)
 ;;2.0;INTEGRATED BILLING;**447**;19-APR-11;Build 80
"RTN","IBY447PO",3,0)
 D RIT,TPB,CRD
"RTN","IBY447PO",4,0)
 Q
"RTN","IBY447PO",5,0)
 ;
"RTN","IBY447PO",6,0)
RIT ; recompile billing screen templates
"RTN","IBY447PO",7,0)
 N X,Y,DMAX,IBN
"RTN","IBY447PO",8,0)
 D MES^XPDUTL("Recompiling Input Templates for Billing Screens ...")
"RTN","IBY447PO",9,0)
 F IBN=1:1:9,"10","102","10H" D
"RTN","IBY447PO",10,0)
 .S X="IBXS"_$S(IBN=10:"A",IBN="102":"A2",IBN="10H":"AH",1:IBN)
"RTN","IBY447PO",11,0)
 .S Y=$$FIND1^DIC(.402,,"X","IB SCREEN"_IBN,"B")
"RTN","IBY447PO",12,0)
 .S DMAX=$$ROUSIZE^DILF
"RTN","IBY447PO",13,0)
 .I Y D EN^DIEZ
"RTN","IBY447PO",14,0)
 D MES^XPDUTL(" Done.")
"RTN","IBY447PO",15,0)
 Q
"RTN","IBY447PO",16,0)
 ;
"RTN","IBY447PO",17,0)
TPB ; Change THIRD PARTY BILLING menu mnemonic
"RTN","IBY447PO",18,0)
 NEW MENUIEN,ITEMIEN,STOP,IBX,DIE,DA,DR
"RTN","IBY447PO",19,0)
 D MES^XPDUTL("Updating THIRD PARTY BILLING menu mnemonic ....")
"RTN","IBY447PO",20,0)
 ;
"RTN","IBY447PO",21,0)
 S MENUIEN=$O(^DIC(19,"B","IB BILLING CLERK MENU",0)) D UBCG
"RTN","IBY447PO",22,0)
 S MENUIEN=$O(^DIC(19,"B","IB BILLING SUPERVISOR MENU",0)) D UBCG
"RTN","IBY447PO",23,0)
 Q
"RTN","IBY447PO",24,0)
 ;
"RTN","IBY447PO",25,0)
UBCG ;
"RTN","IBY447PO",26,0)
 Q:'MENUIEN 
"RTN","IBY447PO",27,0)
 S ITEMIEN=0 F  S ITEMIEN=$O(^DIC(19,MENUIEN,10,ITEMIEN)) Q:'ITEMIEN  D
"RTN","IBY447PO",28,0)
 . S IBX=$P($G(^DIC(19,MENUIEN,10,ITEMIEN,0)),U,2) Q:$E(IBX,1,2)'="UB"
"RTN","IBY447PO",29,0)
 . S DIE="^DIC(19,"_MENUIEN_",10,"
"RTN","IBY447PO",30,0)
 . S DA=ITEMIEN,DA(1)=MENUIEN
"RTN","IBY447PO",31,0)
 . S DR="2////TPB"
"RTN","IBY447PO",32,0)
 . D ^DIE
"RTN","IBY447PO",33,0)
 Q
"RTN","IBY447PO",34,0)
CRD ; fix mis-match between claim and account number from patch 433
"RTN","IBY447PO",35,0)
 N IBN,IBDT,IBC,IBAR,X
"RTN","IBY447PO",36,0)
 ; Start with install date of patch 433
"RTN","IBY447PO",37,0)
 S X=$$INSTALDT^XPDUTL("IB*2.0*433",.IBDT) Q:X<1
"RTN","IBY447PO",38,0)
 S IBDT=$P($O(IBDT("")),".")
"RTN","IBY447PO",39,0)
 S IBDT=IBDT-1 F  S IBDT=$O(^DGCR(399,"APD",IBDT)) Q:'IBDT  D
"RTN","IBY447PO",40,0)
 .S IBN=0 F  S IBN=$O(^DGCR(399,"APD",IBDT,IBN)) Q:'IBN  D
"RTN","IBY447PO",41,0)
 ..; only look at claims with iteration numbers
"RTN","IBY447PO",42,0)
 ..S IBC=$P($G(^DGCR(399,IBN,0)),"^") Q:IBC'["-"
"RTN","IBY447PO",43,0)
 ..S IBAR=$P($P($G(^PRCA(430,IBN,0)),"^"),"-",2,3)
"RTN","IBY447PO",44,0)
 ..Q:IBC=IBAR
"RTN","IBY447PO",45,0)
 ..; claim does not match AR, fix claim
"RTN","IBY447PO",46,0)
 ..S $P(^DGCR(399,IBN,0),"^")=IBAR,^DGCR(399,"B",IBAR,IBN)=""
"RTN","IBY447PO",47,0)
 ..K ^DGCR(399,"B",IBC,IBN)
"RTN","IBY447PO",48,0)
 Q
"RTN","IBY447PR")
0^^B24484648
"RTN","IBY447PR",1,0)
IBY447PR ;ALB/WCJ - Pre-Installation for IB patch 447 ;19-APR-2011
"RTN","IBY447PR",2,0)
 ;;2.0;INTEGRATED BILLING;**447**;19-APR-11;Build 80
"RTN","IBY447PR",3,0)
 ;
"RTN","IBY447PR",4,0)
 D DELOF       ; delete all output formatter data elements included in build
"RTN","IBY447PR",5,0)
 D NMCHG
"RTN","IBY447PR",6,0)
 Q
"RTN","IBY447PR",7,0)
 ;
"RTN","IBY447PR",8,0)
NMCHG   ; change name and abbreviation of some 355.1 entries prior to install
"RTN","IBY447PR",9,0)
 N DATA,IEN,FLAGS,FDA,ERR,LN
"RTN","IBY447PR",10,0)
 F LN=3:1:5 D
"RTN","IBY447PR",11,0)
 .S DATA=$P($T(NMC3551+LN),";;",2) Q:DATA=""
"RTN","IBY447PR",12,0)
 .S IEN=$O(^IBE(355.1,"B",$P(DATA,U,2),"")) Q:IEN=""
"RTN","IBY447PR",13,0)
 .S FDA(355.1,IEN_",",.01)=$P(DATA,U,3),FDA(355.1,IEN_",",.02)=$P(DATA,U,4)
"RTN","IBY447PR",14,0)
 .D FILE^DIE(,"FDA")
"RTN","IBY447PR",15,0)
 Q
"RTN","IBY447PR",16,0)
 ;
"RTN","IBY447PR",17,0)
INCLUDE(FILE,Y) ; function to determine if output formatter entry should be
"RTN","IBY447PR",18,0)
 ; included in the build
"RTN","IBY447PR",19,0)
 ; FILE=5,6,7 indicating file 364.x
"RTN","IBY447PR",20,0)
 ; Y=ien to file
"RTN","IBY447PR",21,0)
 ;
"RTN","IBY447PR",22,0)
 NEW OK,LN,TAG,DATA
"RTN","IBY447PR",23,0)
 S OK=0
"RTN","IBY447PR",24,0)
 F LN=2:1 S TAG="ENT"_FILE_"+"_LN,DATA=$P($T(@TAG),";;",2) Q:DATA=""  I $F(DATA,U_Y_U) S OK=1 Q
"RTN","IBY447PR",25,0)
INCLUDEX ;
"RTN","IBY447PR",26,0)
 Q OK
"RTN","IBY447PR",27,0)
 ;
"RTN","IBY447PR",28,0)
DELOF   ; Delete included output formatter entries
"RTN","IBY447PR",29,0)
 NEW FILE,DIK,LN,TAG,DATA,PCE,DA,Y
"RTN","IBY447PR",30,0)
 F FILE=5,6,7 S DIK="^IBA(364."_FILE_"," F LN=2:1 S TAG="ENT"_FILE_"+"_LN,DATA=$P($T(@TAG),";;",2) Q:DATA=""  D
"RTN","IBY447PR",31,0)
 . F PCE=2:1 S DA=$P(DATA,U,PCE) Q:'DA  I $D(^IBA("364."_FILE,DA,0)) D ^DIK
"RTN","IBY447PR",32,0)
 . Q
"RTN","IBY447PR",33,0)
 ;
"RTN","IBY447PR",34,0)
 ; Also delete output formatter entries which are not going to be
"RTN","IBY447PR",35,0)
 ; re-added later.  These are non-functioning entries in file 364.6.
"RTN","IBY447PR",36,0)
 S DIK="^IBA(364.6,"
"RTN","IBY447PR",37,0)
 F LN=2:1 S TAG="DEL6"_"+"_LN,DATA=$P($T(@TAG),";;",2) Q:DATA=""  D
"RTN","IBY447PR",38,0)
 . F PCE=2:1 S DA=$P(DATA,U,PCE) Q:'DA  I $D(^IBA("364.6",DA,0)) D ^DIK
"RTN","IBY447PR",39,0)
 ;
"RTN","IBY447PR",40,0)
 ; Also delete output formatter entries which are not going to be
"RTN","IBY447PR",41,0)
 ; re-added later.  These are non-functioning entries in file 364.7.
"RTN","IBY447PR",42,0)
 S DIK="^IBA(364.7,"
"RTN","IBY447PR",43,0)
 F LN=2:1 S TAG="DEL7"_"+"_LN,DATA=$P($T(@TAG),";;",2) Q:DATA=""  D
"RTN","IBY447PR",44,0)
 . F PCE=2:1 S DA=$P(DATA,U,PCE) Q:'DA  I $D(^IBA("364.7",DA,0)) D ^DIK
"RTN","IBY447PR",45,0)
 ;
"RTN","IBY447PR",46,0)
DELOFX  ;
"RTN","IBY447PR",47,0)
 Q
"RTN","IBY447PR",48,0)
 ;
"RTN","IBY447PR",49,0)
INC3551(Y) ; function to determine if entry in TYPE OF PLAN file (355.1) should be included in the build
"RTN","IBY447PR",50,0)
 ; Y - ien to file
"RTN","IBY447PR",51,0)
 N DATA,ENTRY,LN,OK,TAG
"RTN","IBY447PR",52,0)
 S OK=0,ENTRY=U_$P($G(^IBE(355.1,Y,0)),U)_U
"RTN","IBY447PR",53,0)
 F LN=2:1 S TAG="ENT3551+"_LN,DATA=$P($T(@TAG),";;",2) Q:DATA=""  I $F(DATA,ENTRY) S OK=1 Q
"RTN","IBY447PR",54,0)
 Q OK
"RTN","IBY447PR",55,0)
 ;
"RTN","IBY447PR",56,0)
INC3508(Y) ; function to determine if entry in IB ERROR file (350.8) should be included in the build
"RTN","IBY447PR",57,0)
 ; Y - ien to file
"RTN","IBY447PR",58,0)
 N DATA,ENTRY,LN,OK,TAG
"RTN","IBY447PR",59,0)
 S OK=0,ENTRY=U_$P($G(^IBE(350.8,Y,0)),U,3)_U
"RTN","IBY447PR",60,0)
 F LN=2:1 S TAG="ENT3508+"_LN,DATA=$P($T(@TAG),";;",2) Q:DATA=""  I $F(DATA,ENTRY) S OK=1 Q
"RTN","IBY447PR",61,0)
 Q OK
"RTN","IBY447PR",62,0)
 ;
"RTN","IBY447PR",63,0)
 ;;
"RTN","IBY447PR",64,0)
 ;
"RTN","IBY447PR",65,0)
 ;-----------------------------------------------------------------------
"RTN","IBY447PR",66,0)
 ; 364.5 entries modified:
"RTN","IBY447PR",67,0)
 ; 79 Modified, SDD Section 3.2.3.1, BEN
"RTN","IBY447PR",68,0)
 ;
"RTN","IBY447PR",69,0)
ENT5 ; output formatter entries in file 364.5 to be included
"RTN","IBY447PR",70,0)
 ;
"RTN","IBY447PR",71,0)
 ;;^79^
"RTN","IBY447PR",72,0)
 ;;
"RTN","IBY447PR",73,0)
 ;
"RTN","IBY447PR",74,0)
 ;-----------------------------------------------------------------------
"RTN","IBY447PR",75,0)
 ; 364.6 entries modified:
"RTN","IBY447PR",76,0)
 ;  107 - OI1-9
"RTN","IBY447PR",77,0)
 ;  111 - OI1-10
"RTN","IBY447PR",78,0)
 ;  891 - COB1-10
"RTN","IBY447PR",79,0)
 ;  962 - COB1-12
"RTN","IBY447PR",80,0)
 ; 1045 - SUB2-1.5
"RTN","IBY447PR",81,0)
 ; 1487 - CMS-1500 BX-24F CHARGES
"RTN","IBY447PR",82,0)
 ; 1938 - AMB-2
"RTN","IBY447PR",83,0)
 ; 1939 - AMB1-1
"RTN","IBY447PR",84,0)
 ; 1940 - AMB-3
"RTN","IBY447PR",85,0)
 ; 1941 - AMB-4
"RTN","IBY447PR",86,0)
 ; 1942 - AMB-5
"RTN","IBY447PR",87,0)
 ; 1943 - AMB-6
"RTN","IBY447PR",88,0)
 ; 1944 - AMB-7
"RTN","IBY447PR",89,0)
 ; 1945 - AMB1-2
"RTN","IBY447PR",90,0)
 ; 1946 - AMB1-3
"RTN","IBY447PR",91,0)
 ; 1947 - AMB1-4
"RTN","IBY447PR",92,0)
 ; 1948 - AMB1-5
"RTN","IBY447PR",93,0)
 ; 1949 - AMB1-6
"RTN","IBY447PR",94,0)
 ; 1950 - AMB1-7
"RTN","IBY447PR",95,0)
 ; 1951 - AMB-8
"RTN","IBY447PR",96,0)
 ; 2209 - AMB-1.9
"RTN","IBY447PR",97,0)
 ; 2210 - AMB-99.9
"RTN","IBY447PR",98,0)
 ; 2211 - AMB1-1.9
"RTN","IBY447PR",99,0)
 ; 2212 - AMB1-8
"RTN","IBY447PR",100,0)
 ; 2213 - AMB1-99.9
"RTN","IBY447PR",101,0)
 ; 2214 - AMB2-1
"RTN","IBY447PR",102,0)
 ; 2215 - AMB2-1.9
"RTN","IBY447PR",103,0)
 ; 2216 - AMB2-2
"RTN","IBY447PR",104,0)
 ; 2217 - AMB2-3
"RTN","IBY447PR",105,0)
 ; 2218 - AMB2-4
"RTN","IBY447PR",106,0)
 ; 2219 - AMB2-5
"RTN","IBY447PR",107,0)
 ; 2220 - AMB2-6
"RTN","IBY447PR",108,0)
 ; 2221 - AMB2-7
"RTN","IBY447PR",109,0)
 ; 2222 - AMB2-8
"RTN","IBY447PR",110,0)
 ; 2223 - AMB2-99.9
"RTN","IBY447PR",111,0)
 ; 2224 - COB1-7
"RTN","IBY447PR",112,0)
 ; 2225 - OI1A-1
"RTN","IBY447PR",113,0)
 ; 2226 - OI1A-2
"RTN","IBY447PR",114,0)
 ; 2227 - OI1A-3
"RTN","IBY447PR",115,0)
 ;
"RTN","IBY447PR",116,0)
ENT6 ; output formatter entries in file 364.6 to be included
"RTN","IBY447PR",117,0)
 ;
"RTN","IBY447PR",118,0)
 ;;^107^111^891^962^1045^1487^
"RTN","IBY447PR",119,0)
 ;;^1938^1939^1940^1941^1942^1943^1944^1945^1946^1947^1948^1949^1950^1951^
"RTN","IBY447PR",120,0)
 ;;^2209^2210^2211^2212^2213^2214^2215^2216^2217^2218^2219^2220^2221^2222^
"RTN","IBY447PR",121,0)
 ;;^2223^2224^2225^2226^2227^
"RTN","IBY447PR",122,0)
 ;;
"RTN","IBY447PR",123,0)
 ;
"RTN","IBY447PR",124,0)
 ;-----------------------------------------------------------------------
"RTN","IBY447PR",125,0)
 ; 364.7 entries modified:
"RTN","IBY447PR",126,0)
 ;   37 Modified, SDD Sections 3.2.1.5 & 3.2.1.6, BEN
"RTN","IBY447PR",127,0)
 ;  103 - CL1-23
"RTN","IBY447PR",128,0)
 ;  130 - OI1-10
"RTN","IBY447PR",129,0)
 ;  205 - SUB2-2
"RTN","IBY447PR",130,0)
 ;  206 - SUB2-3
"RTN","IBY447PR",131,0)
 ;  209 - SUB2-1.5
"RTN","IBY447PR",132,0)
 ; 1015 - GEN-7
"RTN","IBY447PR",133,0)
 ; 1403 Modified, SDD Sections 3.2.1.5 & 3.2.1.6, BEN
"RTN","IBY447PR",134,0)
 ; 1638 - AMB-2
"RTN","IBY447PR",135,0)
 ; 1639 - AMB1-1
"RTN","IBY447PR",136,0)
 ; 1640 - AMB-3
"RTN","IBY447PR",137,0)
 ; 1641 - AMB-4
"RTN","IBY447PR",138,0)
 ; 1642 - AMB-5
"RTN","IBY447PR",139,0)
 ; 1643 - AMB-6
"RTN","IBY447PR",140,0)
 ; 1644 - AMB-7
"RTN","IBY447PR",141,0)
 ; 1645 - AMB1-2
"RTN","IBY447PR",142,0)
 ; 1646 - AMB1-3
"RTN","IBY447PR",143,0)
 ; 1647 - AMB1-4
"RTN","IBY447PR",144,0)
 ; 1648 - AMB1-5
"RTN","IBY447PR",145,0)
 ; 1649 - AMB1-6
"RTN","IBY447PR",146,0)
 ; 1650 - AMB1-7
"RTN","IBY447PR",147,0)
 ; 1651 - AMB-8
"RTN","IBY447PR",148,0)
 ; 1909 - AMB-1.9
"RTN","IBY447PR",149,0)
 ; 1910 - AMB-99.9
"RTN","IBY447PR",150,0)
 ; 1911 - AMB1-1.9
"RTN","IBY447PR",151,0)
 ; 1912 - AMB1-8
"RTN","IBY447PR",152,0)
 ; 1913 - AMB1-99.9
"RTN","IBY447PR",153,0)
 ; 1914 - AMB2-1
"RTN","IBY447PR",154,0)
 ; 1915 - AMB2-1.9
"RTN","IBY447PR",155,0)
 ; 1916 - AMB2-2
"RTN","IBY447PR",156,0)
 ; 1917 - AMB2-3
"RTN","IBY447PR",157,0)
 ; 1918 - AMB2-4
"RTN","IBY447PR",158,0)
 ; 1919 - AMB2-5
"RTN","IBY447PR",159,0)
 ; 1920 - AMB2-6
"RTN","IBY447PR",160,0)
 ; 1921 - AMB2-7
"RTN","IBY447PR",161,0)
 ; 1922 - AMB2-8
"RTN","IBY447PR",162,0)
 ; 1923 - AMB2-99.9
"RTN","IBY447PR",163,0)
 ; 1924 - COB1-7
"RTN","IBY447PR",164,0)
 ; 1925 - OI1A-1
"RTN","IBY447PR",165,0)
 ; 1926 - OI1A-2
"RTN","IBY447PR",166,0)
 ; 1927 - OIAA-3
"RTN","IBY447PR",167,0)
 ; 
"RTN","IBY447PR",168,0)
 ;
"RTN","IBY447PR",169,0)
ENT7 ; output formatter entries in file 364.7 to be included
"RTN","IBY447PR",170,0)
 ;
"RTN","IBY447PR",171,0)
 ;;^37^103^130^205^206^209^1015^1403^
"RTN","IBY447PR",172,0)
 ;;^1638^1639^1640^1641^1642^1643^1644^1645^1646^1647^1648^1649^1650^1651^
"RTN","IBY447PR",173,0)
 ;;^1909^1910^1911^1912^1913^1914^1915^1916^1917^1918^1919^1920^1921^1922^
"RTN","IBY447PR",174,0)
 ;;^1923^1924^1925^1926^1927^
"RTN","IBY447PR",175,0)
 ;;
"RTN","IBY447PR",176,0)
 ;
"RTN","IBY447PR",177,0)
 ;-----------------------------------------------------------------------
"RTN","IBY447PR",178,0)
DEL6    ; remove output formatter entries in file 364.6 (not re-added)
"RTN","IBY447PR",179,0)
 ;
"RTN","IBY447PR",180,0)
 ;;^813^
"RTN","IBY447PR",181,0)
 ;;
"RTN","IBY447PR",182,0)
 ;
"RTN","IBY447PR",183,0)
 ;-----------------------------------------------------------------------
"RTN","IBY447PR",184,0)
DEL7    ; remove output formatter entries in file 364.7 (not re-added)
"RTN","IBY447PR",185,0)
 ;
"RTN","IBY447PR",186,0)
 ;;^843^
"RTN","IBY447PR",187,0)
 ;;
"RTN","IBY447PR",188,0)
 ;
"RTN","IBY447PR",189,0)
 Q
"RTN","IBY447PR",190,0)
 ;
"RTN","IBY447PR",191,0)
ENT3508 ; entries in file 350.8 to be included
"RTN","IBY447PR",192,0)
 ;
"RTN","IBY447PR",193,0)
 ;;^IB344^IB345^IB346^IB347^IB348^IB349^
"RTN","IBY447PR",194,0)
 ;;
"RTN","IBY447PR",195,0)
 ;
"RTN","IBY447PR",196,0)
 Q
"RTN","IBY447PR",197,0)
 ;
"RTN","IBY447PR",198,0)
NMC3551 ; entries in file 355.1 to change name prior to install
"RTN","IBY447PR",199,0)
 ; ^OLD NAME^NEW NAME^NEW ABBREVIATION
"RTN","IBY447PR",200,0)
 ; 
"RTN","IBY447PR",201,0)
 ;;^MEDIGAP (SUPPLEMENTAL)^MEDIGAP PLAN C^MGC
"RTN","IBY447PR",202,0)
 ;;^MEDIGAP (SUPPL - COINS, DED, PART B EXC)^MEDIGAP PLAN F^MGF
"RTN","IBY447PR",203,0)
 ;;^MEDICARE SECONDARY^MEDICARE SECONDARY (NO B EXC)^MS
"RTN","IBY447PR",204,0)
 ;;
"RTN","IBY447PR",205,0)
 ;
"RTN","IBY447PR",206,0)
 Q
"RTN","IBY447PR",207,0)
 ;
"RTN","IBY447PR",208,0)
ENT3551 ; entries in file 355.1 to be included
"RTN","IBY447PR",209,0)
 ;
"RTN","IBY447PR",210,0)
 ;;^MEDIGAP PLAN F^MEDIGAP PLAN A^MEDIGAP PLAN B^MEDIGAP PLAN D^MEDIGAP PLAN G^MEDIGAP PLAN K^
"RTN","IBY447PR",211,0)
 ;;^MEDIGAP PLAN L^MEDIGAP PLAN M^MEDIGAP PLAN N^MEDICARE SECONDARY (B EXC)^MEDIGAP PLAN C^
"RTN","IBY447PR",212,0)
 ;;^MEDICARE SUPPLEMENTAL^CARVE-OUT^MEDICARE SECONDARY (NO B EXC)^COMPREHENSIVE MAJOR MEDICAL^
"RTN","IBY447PR",213,0)
 ;;^PREFERRED PROVIDER ORGANIZATION (PPO)^RETIREE^MENTAL HEALTH^MEDICAL EXPENSE (OPT/PROF)^
"RTN","IBY447PR",214,0)
 ;;^POINT OF SERVICE^SURGICAL EXPENSE INSURANCE^
"RTN","IBY447PR",215,0)
 ;
"RTN","IBY447PR",216,0)
 Q
"SEC","^DIC",353.4,353.4,0,"AUDIT")
@
"SEC","^DIC",353.4,353.4,0,"DD")
@
"SEC","^DIC",353.4,353.4,0,"DEL")
@
"SEC","^DIC",353.4,353.4,0,"LAYGO")
@
"SEC","^DIC",353.4,353.4,0,"RD")
@
"SEC","^DIC",353.4,353.4,0,"WR")
@
"SEC","^DIC",353.5,353.5,0,"AUDIT")
@
"SEC","^DIC",353.5,353.5,0,"DD")
@
"SEC","^DIC",353.5,353.5,0,"DEL")
@
"SEC","^DIC",353.5,353.5,0,"LAYGO")
@
"SEC","^DIC",353.5,353.5,0,"RD")
@
"SEC","^DIC",353.5,353.5,0,"WR")
@
"SEC","^DIC",355.1,355.1,0,"AUDIT")
@
"SEC","^DIC",355.1,355.1,0,"DD")
@
"SEC","^DIC",355.1,355.1,0,"DEL")
@
"SEC","^DIC",355.1,355.1,0,"LAYGO")
@
"SEC","^DIC",355.1,355.1,0,"WR")
@
"UP",399,399.0292,-1)
399^U9
"UP",399,399.0292,0)
399.0292
"UP",399,399.0304,-1)
399^CP
"UP",399,399.0304,0)
399.0304
"UP",399,399.042,-1)
399^RC
"UP",399,399.042,0)
399.042
"VER")
8.0^22.0
"^DD",350.8,350.8,0)
FIELD^^10^7
"^DD",350.8,350.8,0,"DDA")
N
"^DD",350.8,350.8,0,"DT")
2930322
"^DD",350.8,350.8,0,"ID",.03)
W "   ",$P(^(0),U,3)
"^DD",350.8,350.8,0,"IX","AC",350.8,.03)

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

"^DD",350.8,350.8,0,"IX","C",350.8,.03)

"^DD",350.8,350.8,0,"NM","IB ERROR")
 
"^DD",350.8,350.8,0,"PT",399,36)

"^DD",350.8,350.8,0,"VRPK")
IB
"^DD",350.8,350.8,.01,0)
NAME^RF^^0;1^K:$L(X)>30!(X?.N)!($L(X)<3)!'(X'?1P.E) X
"^DD",350.8,350.8,.01,1,0)
^.1
"^DD",350.8,350.8,.01,1,1,0)
350.8^B
"^DD",350.8,350.8,.01,1,1,1)
S ^IBE(350.8,"B",$E(X,1,30),DA)=""
"^DD",350.8,350.8,.01,1,1,2)
K ^IBE(350.8,"B",$E(X,1,30),DA)
"^DD",350.8,350.8,.01,3)
NAME MUST BE 3-30 CHARACTERS, NOT NUMERIC OR STARTING WITH PUNCTUATION
"^DD",350.8,350.8,.01,21,0)
^^2^2^2910305^^
"^DD",350.8,350.8,.01,21,1,0)
This is a free text name of the entry.  It should be namespaced with
"^DD",350.8,350.8,.01,21,2,0)
the namespace of the package reporting the error.
"^DD",350.8,350.8,.02,0)
ERROR MESSAGE^F^^0;2^K:$L(X)>80!($L(X)<3) X
"^DD",350.8,350.8,.02,3)
Answer must be 3-80 characters in length.
"^DD",350.8,350.8,.02,21,0)
^^3^3^2940209^^^^
"^DD",350.8,350.8,.02,21,1,0)
This is the text of the message as it will be displayed to a user or
"^DD",350.8,350.8,.02,21,2,0)
posted in a bulletin.  It should be as meaningful as possible to the
"^DD",350.8,350.8,.02,21,3,0)
person seeing the message.
"^DD",350.8,350.8,.03,0)
ERROR CODE^F^^0;3^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>9!($L(X)<1) X
"^DD",350.8,350.8,.03,1,0)
^.1
"^DD",350.8,350.8,.03,1,1,0)
350.8^AC
"^DD",350.8,350.8,.03,1,1,1)
S ^IBE(350.8,"AC",$E(X,1,30),DA)=""
"^DD",350.8,350.8,.03,1,1,2)
K ^IBE(350.8,"AC",$E(X,1,30),DA)
"^DD",350.8,350.8,.03,1,2,0)
350.8^C
"^DD",350.8,350.8,.03,1,2,1)
S ^IBE(350.8,"C",$E(X,1,30),DA)=""
"^DD",350.8,350.8,.03,1,2,2)
K ^IBE(350.8,"C",$E(X,1,30),DA)
"^DD",350.8,350.8,.03,3)
Answer must be 1-9 characters in length.
"^DD",350.8,350.8,.03,21,0)
^^9^9^2920219^^^^
"^DD",350.8,350.8,.03,21,1,0)
This is the error code that will be passed to or determined by
"^DD",350.8,350.8,.03,21,2,0)
Integrated Billing.  The format for the Error Code should be
"^DD",350.8,350.8,.03,21,3,0)
nnxxx, where nn is the reporting package namespace and xxx are numeric
"^DD",350.8,350.8,.03,21,4,0)
values.
"^DD",350.8,350.8,.03,21,5,0)
 
"^DD",350.8,350.8,.03,21,6,0)
This is the error code that will be passed as the second piece of
"^DD",350.8,350.8,.03,21,7,0)
the variable Y to IB when +Y=-1.  More than one error code can be
"^DD",350.8,350.8,.03,21,8,0)
placed in the second ^ piece of Y delimited by semi-colons.  Applications
"^DD",350.8,350.8,.03,21,9,0)
may call ^IBAERR to display the error message(s).
"^DD",350.8,350.8,.03,"DT")
2920219
"^DD",350.8,350.8,.04,0)
PACKAGE REPORTING ERROR^S^1:INTEGRATED BILLING;2:ACCOUNTS RECEIVABLE;3:PHARMACY;^0;4^Q
"^DD",350.8,350.8,.04,21,0)
^^2^2^2920415^^^
"^DD",350.8,350.8,.04,21,1,0)
This is the package that requested this entry in this file and will
"^DD",350.8,350.8,.04,21,2,0)
report it to IB as an error if the conditions are detected.
"^DD",350.8,350.8,.05,0)
ERROR ACTION^S^1:DISPLAY MESSAGE;2:SEND BULLETIN;3:EDIT FILE;^0;5^Q
"^DD",350.8,350.8,.05,21,0)
^^6^6^2910227^
"^DD",350.8,350.8,.05,21,1,0)
This is the type of action that should be taken when this error is
"^DD",350.8,350.8,.05,21,2,0)
reported to IB.  If action other than displaying a message is indicated
"^DD",350.8,350.8,.05,21,3,0)
then the MUMPS code in the ERROR ACTION field will be executed.
"^DD",350.8,350.8,.05,21,4,0)
 
"^DD",350.8,350.8,.05,21,5,0)
Currently only display actions are implemented.  Please contact the 
"^DD",350.8,350.8,.05,21,6,0)
developing ISC if other action types are desired.
"^DD",350.8,350.8,.06,0)
CORRESPONDING ALERT^P354.5'^IBE(354.5,^0;6^Q
"^DD",350.8,350.8,.06,21,0)
^^1^1^2940209^
"^DD",350.8,350.8,.06,21,1,0)
This is the type of alert that should be sent when this error occurs.
"^DD",350.8,350.8,.06,"DT")
2930322
"^DD",350.8,350.8,10,0)
EXECUTABLE LOGIC^K^^10;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
"^DD",350.8,350.8,10,3)
This is Standard MUMPS code.
"^DD",350.8,350.8,10,21,0)
^^2^2^2910227^
"^DD",350.8,350.8,10,21,1,0)
This is the MUMPS code that will be executed if an error is reported
"^DD",350.8,350.8,10,21,2,0)
with an ERROR ACTION of other than to display a message.
"^DD",353,353,2.09,0)
LOCAL BILLING SCREEN^*P353'^IBE(353,^2;9^S DIC("S")="I $P($G(^IBE(353,+Y,2)),U,2)=""S""" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X
"^DD",353,353,2.09,3)
Enter the name of the screen to be used as the local billing screen.
"^DD",353,353,2.09,12)
Must be a screen form.
"^DD",353,353,2.09,12.1)
S DIC("S")="I $P($G(^IBE(353,+Y,2)),U,2)=""S"""
"^DD",353,353,2.09,21,0)
^^2^2^3110606^^
"^DD",353,353,2.09,21,1,0)
This is the form that will be used to build the local billing screen
"^DD",353,353,2.09,21,2,0)
for enter/edit a bill.
"^DD",353,353,2.09,"DT")
3110606
"^DD",353.4,353.4,0)
FIELD^^.02^2
"^DD",353.4,353.4,0,"DDA")
N
"^DD",353.4,353.4,0,"DT")
3110419
"^DD",353.4,353.4,0,"ID",.02)
W "   ",$P(^(0),U,2)
"^DD",353.4,353.4,0,"IX","B",353.4,.01)

"^DD",353.4,353.4,0,"NM","TRANSPORT REASON CODE")

"^DD",353.4,353.4,0,"PT",399,288)

"^DD",353.4,353.4,0,"VRPK")
IB
"^DD",353.4,353.4,.01,0)
CODE^RF^^0;1^K:$L(X)>1!($L(X)<1)!'(X'?1P.E) X
"^DD",353.4,353.4,.01,1,0)
^.1
"^DD",353.4,353.4,.01,1,1,0)
353.4^B
"^DD",353.4,353.4,.01,1,1,1)
S ^IBE(353.4,"B",$E(X,1,30),DA)=""
"^DD",353.4,353.4,.01,1,1,2)
K ^IBE(353.4,"B",$E(X,1,30),DA)
"^DD",353.4,353.4,.01,3)
Answer must be 1 character in length.
"^DD",353.4,353.4,.01,21,0)
^^2^2^3110603^
"^DD",353.4,353.4,.01,21,1,0)
This is the Ambulance Transport Reason Code associated with a reason for 
"^DD",353.4,353.4,.01,21,2,0)
ambulance transportation.
"^DD",353.4,353.4,.01,"DT")
3110603
"^DD",353.4,353.4,.02,0)
REASON^RF^^0;2^K:$L(X)>200!($L(X)<1) X
"^DD",353.4,353.4,.02,3)
Answer must be 1-200 characters in length.
"^DD",353.4,353.4,.02,21,0)
^^1^1^3110603^
"^DD",353.4,353.4,.02,21,1,0)
This is the reason ambulance transportation was required.
"^DD",353.4,353.4,.02,"DT")
3110603
"^DD",353.5,353.5,0)
FIELD^^.02^2
"^DD",353.5,353.5,0,"DDA")
N
"^DD",353.5,353.5,0,"DT")
3110513
"^DD",353.5,353.5,0,"ID",.02)
W "   ",$P(^(0),U,2)
"^DD",353.5,353.5,0,"IX","B",353.5,.01)

"^DD",353.5,353.5,0,"NM","AMBULANCE CONDITION INDICATORS")

"^DD",353.5,353.5,0,"PT",399.0292,.01)

"^DD",353.5,353.5,0,"VRPK")
IB
"^DD",353.5,353.5,.01,0)
CODE^RF^^0;1^K:$L(X)>2!($L(X)<1)!'(X'?1P.E) X
"^DD",353.5,353.5,.01,1,0)
^.1
"^DD",353.5,353.5,.01,1,1,0)
353.5^B
"^DD",353.5,353.5,.01,1,1,1)
S ^IBE(353.5,"B",$E(X,1,30),DA)=""
"^DD",353.5,353.5,.01,1,1,2)
K ^IBE(353.5,"B",$E(X,1,30),DA)
"^DD",353.5,353.5,.01,3)
Answer must be 1-2 characters in length.
"^DD",353.5,353.5,.01,21,0)
^^2^2^3110603^
"^DD",353.5,353.5,.01,21,1,0)
This is the Ambulance Condition Code associated with the patient's 
"^DD",353.5,353.5,.01,21,2,0)
condition in relation to ambulance transportation.
"^DD",353.5,353.5,.01,"DT")
3110603
"^DD",353.5,353.5,.02,0)
CONDITION^RF^^0;2^K:$L(X)>200!($L(X)<1) X
"^DD",353.5,353.5,.02,3)
Answer must be 1-200 characters in length.
"^DD",353.5,353.5,.02,21,0)
^^1^1^3110603^
"^DD",353.5,353.5,.02,21,1,0)
This is the patient's condition in relation to ambulance transportation.
"^DD",353.5,353.5,.02,"DT")
3110603
"^DD",355.1,355.1,0)
FIELD^^14^6
"^DD",355.1,355.1,0,"DDA")
N
"^DD",355.1,355.1,0,"DT")
3110512
"^DD",355.1,355.1,0,"ID",.03)
W "   ",@("$P($P($C(59)_$S($D(^DD(355.1,.03,0)):$P(^(0),U,3),1:0)_$E("_DIC_"Y,0),0),$C(59)_$P(^(0),U,3)_"":"",2),$C(59),1)")
"^DD",355.1,355.1,0,"IX","C",355.1,.03)

"^DD",355.1,355.1,0,"IX","D",355.1,.02)

"^DD",355.1,355.1,0,"NM","TYPE OF PLAN")

"^DD",355.1,355.1,0,"PT",355.3,.09)

"^DD",355.1,355.1,0,"PT",355.33,40.09)

"^DD",355.1,355.1,0,"VRPK")
IB
"^DD",355.1,355.1,.01,0)
NAME^RF^^0;1^K:$L(X)>40!($L(X)<3)!'(X'?1P.E) X
"^DD",355.1,355.1,.01,1,0)
^.1^^0
"^DD",355.1,355.1,.01,3)
Enter the name of this type of policy that best describes the policy.  Answer must be 3-40 characters in length.
"^DD",355.1,355.1,.01,21,0)
^.001^10^10^3090504^^^^
"^DD",355.1,355.1,.01,21,1,0)
There are a number of different types of policies, some have very
"^DD",355.1,355.1,.01,21,2,0)
specific types of coverage while others cover a much broader
"^DD",355.1,355.1,.01,21,3,0)
range of care.  This is the name of the type of policy.  Select
"^DD",355.1,355.1,.01,21,4,0)
the name that best describes the type of policy.  This is a list of 
"^DD",355.1,355.1,.01,21,5,0)
standard types of policies.
"^DD",355.1,355.1,.01,21,6,0)
 
"^DD",355.1,355.1,.01,21,7,0)
The type of policy may be dependent on the type of coverage provided
"^DD",355.1,355.1,.01,21,8,0)
by the insurance company and may affect the type of benefits that are
"^DD",355.1,355.1,.01,21,9,0)
available for the policy.  This will be used in determining if the
"^DD",355.1,355.1,.01,21,10,0)
reimbursement from the insurance company is appropriate for this policy.
"^DD",355.1,355.1,.01,"DT")
3090615
"^DD",355.1,355.1,.02,0)
ABBREVIATION^F^^0;2^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>8!($L(X)<2) X
"^DD",355.1,355.1,.02,1,0)
^.1
"^DD",355.1,355.1,.02,1,1,0)
355.1^D
"^DD",355.1,355.1,.02,1,1,1)
S ^IBE(355.1,"D",$E(X,1,30),DA)=""
"^DD",355.1,355.1,.02,1,1,2)
K ^IBE(355.1,"D",$E(X,1,30),DA)
"^DD",355.1,355.1,.02,1,1,"DT")
2930603
"^DD",355.1,355.1,.02,3)
Enter the standard abbreviation.  Answer must be 2-8 characters in length.
"^DD",355.1,355.1,.02,21,0)
^^3^3^2930603^
"^DD",355.1,355.1,.02,21,1,0)
Enter the standard abbreviation for this type of policy.  The abbreviation
"^DD",355.1,355.1,.02,21,2,0)
will be used on standard displays of policy information where space is
"^DD",355.1,355.1,.02,21,3,0)
limited.
"^DD",355.1,355.1,.02,"DT")
2930603
"^DD",355.1,355.1,.03,0)
MAJOR CATEGORY^S^1:MAJOR MEDICAL;2:DENTAL;3:HMO;4:PPO;5:MEDICARE;6:MEDICAIDE;7:CHAMPUS;8:WORKMANS COMP;9:INDEMNITY;10:PRESCRIPTION;11:MEDICARE SUPPLEMENTAL;12:ALL OTHER;^0;3^Q
"^DD",355.1,355.1,.03,1,0)
^.1
"^DD",355.1,355.1,.03,1,1,0)
355.1^C
"^DD",355.1,355.1,.03,1,1,1)
S ^IBE(355.1,"C",$E(X,1,30),DA)=""
"^DD",355.1,355.1,.03,1,1,2)
K ^IBE(355.1,"C",$E(X,1,30),DA)
"^DD",355.1,355.1,.03,1,1,"DT")
2930603
"^DD",355.1,355.1,.03,9)
@
"^DD",355.1,355.1,.03,21,0)
^^3^3^2940111^^^
"^DD",355.1,355.1,.03,21,1,0)
Each type of policy must be identified with a major category.  It is the
"^DD",355.1,355.1,.03,21,2,0)
major category field that will be used to determine the type of policy
"^DD",355.1,355.1,.03,21,3,0)
internally by the computer.
"^DD",355.1,355.1,.03,"DT")
2940111
"^DD",355.1,355.1,.04,0)
INACTIVE^S^1:YES;^0;4^Q
"^DD",355.1,355.1,.04,3)
Enter Yes if this Type of Plan should be Inactivated.
"^DD",355.1,355.1,.04,21,0)
^^1^1^2970811^
"^DD",355.1,355.1,.04,21,1,0)
An Inactive Type of Plan should no longer be used to define Plans.
"^DD",355.1,355.1,.04,"DT")
2970811
"^DD",355.1,355.1,10,0)
DESCRIPTION^355.11^^10;0
"^DD",355.1,355.1,10,21,0)
^^1^1^2930603^
"^DD",355.1,355.1,10,21,1,0)
Enter a one or two sentence description of the type of policy.
"^DD",355.1,355.1,14,0)
EFFECTIVE DATE^355.14D^^14;0
"^DD",355.1,355.1,14,21,0)
^.001^11^11^3110524^^^^
"^DD",355.1,355.1,14,21,1,0)
The effective date multiple contains the date(s) on which 
"^DD",355.1,355.1,14,21,2,0)
the coverage amounts paid by a supplemental Type of Plan 
"^DD",355.1,355.1,14,21,3,0)
go into effect or change.  The percentages paid are 
"^DD",355.1,355.1,14,21,4,0)
stored within this Effective Date multiple by Group Code 
"^DD",355.1,355.1,14,21,5,0)
and Reason Code.  When these percentages change, a new 
"^DD",355.1,355.1,14,21,6,0)
effective date should be entered along with each Group 
"^DD",355.1,355.1,14,21,7,0)
and Reason Code for which this plan pays.  If there is no 
"^DD",355.1,355.1,14,21,8,0)
effective date entry or the effective date is AFTER the 
"^DD",355.1,355.1,14,21,9,0)
claim service From date, the secondary balance due will 
"^DD",355.1,355.1,14,21,10,0)
be calculated as 100% of Patient Responsibility as 
"^DD",355.1,355.1,14,21,11,0)
indicated on the Medicare-equivalent Remittance Advice (MRA).
"^DD",355.1,355.1,14,23,0)
^.001^10^10^3110524^^^^
"^DD",355.1,355.1,14,23,1,0)
If the Type of Plan assigned to the insurance plan on a claim,
"^DD",355.1,355.1,14,23,2,0)
has an effective date on or before the claim service From date:  
"^DD",355.1,355.1,14,23,3,0)
(File#399 Field#151 FIELD NAME: STATEMENT COVERS FROM Global Location: U;1) 
"^DD",355.1,355.1,14,23,4,0)
the balance due for the secondary claim will be based on the 
"^DD",355.1,355.1,14,23,5,0)
patient responsibility multiplied by any percentages stored in
"^DD",355.1,355.1,14,23,6,0)
the effective date multiple, plus excess charges if applicable.  
"^DD",355.1,355.1,14,23,7,0)
If there is no effective date entry or the effective date is 
"^DD",355.1,355.1,14,23,8,0)
AFTER the claim From service date, the secondary balance due will
"^DD",355.1,355.1,14,23,9,0)
be calculated as 100% of Patient Responsibility as indicated on 
"^DD",355.1,355.1,14,23,10,0)
the Medicare-equivalent Remittance Advice.  
"^DD",355.1,355.11,0)
DESCRIPTION SUB-FIELD^^.01^1
"^DD",355.1,355.11,0,"DT")
2930603
"^DD",355.1,355.11,0,"NM","DESCRIPTION")

"^DD",355.1,355.11,0,"UP")
355.1
"^DD",355.1,355.11,.01,0)
DESCRIPTION^W^^0;1^Q
"^DD",355.1,355.11,.01,"DT")
2930603
"^DD",355.1,355.14,0)
EFFECTIVE DATE SUB-FIELD^^1^2
"^DD",355.1,355.14,0,"DT")
3110512
"^DD",355.1,355.14,0,"IX","B",355.14,.01)

"^DD",355.1,355.14,0,"NM","EFFECTIVE DATE")

"^DD",355.1,355.14,0,"UP")
355.1
"^DD",355.1,355.14,.01,0)
EFFECTIVE DATE^DI^^0;1^S %DT="EX" D ^%DT S X=Y K:Y<1 X
"^DD",355.1,355.14,.01,1,0)
^.1
"^DD",355.1,355.14,.01,1,1,0)
355.14^B
"^DD",355.1,355.14,.01,1,1,1)
S ^IBE(355.1,DA(1),14,"B",$E(X,1,30),DA)=""
"^DD",355.1,355.14,.01,1,1,2)
K ^IBE(355.1,DA(1),14,"B",$E(X,1,30),DA)
"^DD",355.1,355.14,.01,3)
Enter the date the Type Of Plan Percentages paid became effective.
"^DD",355.1,355.14,.01,21,0)
^^10^10^3110524^
"^DD",355.1,355.14,.01,21,1,0)
This is the date on which the coverage amounts paid by a 
"^DD",355.1,355.14,.01,21,2,0)
supplemental Type of Plan go into effect.  The percentages 
"^DD",355.1,355.14,.01,21,3,0)
paid are stored by Date, Group Code and Reason Code.  When 
"^DD",355.1,355.14,.01,21,4,0)
these percentages change, a new effective date should be 
"^DD",355.1,355.14,.01,21,5,0)
entered along with each Group and Reason Code for which 
"^DD",355.1,355.14,.01,21,6,0)
this plan pays.  If there is no effective date entry or 
"^DD",355.1,355.14,.01,21,7,0)
the effective date is AFTER the claim service From date, 
"^DD",355.1,355.14,.01,21,8,0)
the secondary balance due will be calculated as 100% of 
"^DD",355.1,355.14,.01,21,9,0)
Patient Responsibility as indicated on the 
"^DD",355.1,355.14,.01,21,10,0)
Medicare-equivalent Remittance Advice (MRA).  
"^DD",355.1,355.14,.01,"DT")
3110510
"^DD",355.1,355.14,1,0)
GROUP CODE^355.141S^^1;0
"^DD",355.1,355.14,1,21,0)
^.001^4^4^3110524^^^^
"^DD",355.1,355.14,1,21,1,0)
These are the group code(s) for which this type of plan pays all 
"^DD",355.1,355.14,1,21,2,0)
or a percentage of the  adjustments made to the original claim by 
"^DD",355.1,355.14,1,21,3,0)
the payer during adjudication.  For example, if there is an entry 
"^DD",355.1,355.14,1,21,4,0)
for Group Code CO, this plan pays all or part of Excess Charges.
"^DD",355.1,355.14,1,23,0)
^.001^7^7^3110524^^^^
"^DD",355.1,355.14,1,23,1,0)
If the claim's Type of Plan entry has an effective date on or
"^DD",355.1,355.14,1,23,2,0)
before the claim service From date, the balance due for the secondary
"^DD",355.1,355.14,1,23,3,0)
claim will be based on the patient responsibility multiplied by
"^DD",355.1,355.14,1,23,4,0)
any percentages stored in the effective date multiple, plus
"^DD",355.1,355.14,1,23,5,0)
excess charges if the Group Code CO is contained within this multiple.
"^DD",355.1,355.14,1,23,6,0)
Claim Service From Date is:
"^DD",355.1,355.14,1,23,7,0)
File #399 Field #151 FIELD NAME: STATEMENT COVERS FROM Global Location:U;1
"^DD",355.1,355.141,0)
GROUP CODE SUB-FIELD^^1^2
"^DD",355.1,355.141,0,"DT")
3110512
"^DD",355.1,355.141,0,"IX","B",355.141,.01)

"^DD",355.1,355.141,0,"NM","GROUP CODE")

"^DD",355.1,355.141,0,"UP")
355.14
"^DD",355.1,355.141,.01,0)
GROUP CODE^MRSI^CO:Contractual Obligations;CR:Corrections and Reversals;OA:Other Adjustments;PI:Payor Initiated Reductions;PR:Patient Responsibility;MM:Medicare Message;^0;1^Q
"^DD",355.1,355.141,.01,1,0)
^.1
"^DD",355.1,355.141,.01,1,1,0)
355.141^B
"^DD",355.1,355.141,.01,1,1,1)
S ^IBE(355.1,DA(2),14,DA(1),1,"B",$E(X,1,30),DA)=""
"^DD",355.1,355.141,.01,1,1,2)
K ^IBE(355.1,DA(2),14,DA(1),1,"B",$E(X,1,30),DA)
"^DD",355.1,355.141,.01,3)
Enter a valid group code covered by this type of plan.
"^DD",355.1,355.141,.01,21,0)
^.001^4^4^3110524^^
"^DD",355.1,355.141,.01,21,1,0)
This is the group code for which this type of plan pays all or a 
"^DD",355.1,355.141,.01,21,2,0)
percentage of the  adjustments made to the original claim by the 
"^DD",355.1,355.141,.01,21,3,0)
payer during adjudication.  For example, if there is an entry for 
"^DD",355.1,355.141,.01,21,4,0)
Group Code CO, this plan pays all or part of Excess Charges.
"^DD",355.1,355.141,.01,"DT")
3110512
"^DD",355.1,355.141,1,0)
REASON CODE^355.1411^^1;0
"^DD",355.1,355.141,1,21,0)
^.001^6^6^3110524^^^^
"^DD",355.1,355.141,1,21,1,0)
This multiple stores the Reason Code(s) for which, when associated with 
"^DD",355.1,355.141,1,21,2,0)
the correct Group Code, this Type of Plan pays all or a percentage of the 
"^DD",355.1,355.141,1,21,3,0)
adjustments made to the original claim by the payer during adjudication.
"^DD",355.1,355.141,1,21,4,0)
For example, if there is an entry of Reason Code 1 with the Group Code 
"^DD",355.1,355.141,1,21,5,0)
of PR, then this plan pays all or a percentage of the Patient's Deductable 
"^DD",355.1,355.141,1,21,6,0)
as indicated on the Medicare-equivalent Remittance Advice (MRA).
"^DD",355.1,355.141,1,23,0)
^.001^6^6^3110524^^^^
"^DD",355.1,355.141,1,23,1,0)
If the claim's type of plan entry has an effective date on or
"^DD",355.1,355.141,1,23,2,0)
before the claim service From date, the balance due for the secondary
"^DD",355.1,355.141,1,23,3,0)
claim will be based on the patient responsibility multiplied by
"^DD",355.1,355.141,1,23,4,0)
any percentages stored in the effective date multiple, plus
"^DD",355.1,355.141,1,23,5,0)
excess charges if the Group Code CO is contained within this multiple
"^DD",355.1,355.141,1,23,6,0)
and is associated with the correct Reason Code.
"^DD",355.1,355.1411,0)
REASON CODE SUB-FIELD^^2^3
"^DD",355.1,355.1411,0,"DT")
3110512
"^DD",355.1,355.1411,0,"IX","B",355.1411,.01)

"^DD",355.1,355.1411,0,"NM","REASON CODE")

"^DD",355.1,355.1411,0,"UP")
355.141
"^DD",355.1,355.1411,.01,0)
REASON CODE^MRFI^^0;1^K:$L(X)>4!($L(X)<1) X
"^DD",355.1,355.1411,.01,1,0)
^.1
"^DD",355.1,355.1411,.01,1,1,0)
355.1411^B
"^DD",355.1,355.1411,.01,1,1,1)
S ^IBE(355.1,DA(3),14,DA(2),1,DA(1),1,"B",$E(X,1,30),DA)=""
"^DD",355.1,355.1411,.01,1,1,2)
K ^IBE(355.1,DA(3),14,DA(2),1,DA(1),1,"B",$E(X,1,30),DA)
"^DD",355.1,355.1411,.01,3)
Answer must be 1-4 characters in length.
"^DD",355.1,355.1411,.01,21,0)
^.001^6^6^3110524^^^^
"^DD",355.1,355.1411,.01,21,1,0)
This is the Reason Code for which, when associated with the correct 
"^DD",355.1,355.1411,.01,21,2,0)
Group Code, this Type of Plan pays all or a percentage of the 
"^DD",355.1,355.1411,.01,21,3,0)
adjustments made to the original claim by the payer during adjudication.
"^DD",355.1,355.1411,.01,21,4,0)
Example, if there is an entry of Reason Code 1 with the Group Code of PR, 
"^DD",355.1,355.1411,.01,21,5,0)
then this plan pays all or a percentage of the Patient's Deductable 
"^DD",355.1,355.1411,.01,21,6,0)
as indicated on the Medicare-equivalent Remittance Advice (MRA).
"^DD",355.1,355.1411,.01,23,0)
^.001^7^7^3110524^^^^
"^DD",355.1,355.1411,.01,23,1,0)
If the claim's Type of Plan entry has an effective date on or
"^DD",355.1,355.1411,.01,23,2,0)
before the claim service From date, the balance due for the secondary
"^DD",355.1,355.1411,.01,23,3,0)
claim will be based on the patient responsibility multiplied by
"^DD",355.1,355.1411,.01,23,4,0)
any percentages stored in the effective date multiple underneath
"^DD",355.1,355.1411,.01,23,5,0)
the appropriate reason codes, plus excess charges if the Group Code CO is
"^DD",355.1,355.1411,.01,23,6,0)
contained within this multiple and is associated with the correct Reason
"^DD",355.1,355.1411,.01,23,7,0)
Code.
"^DD",355.1,355.1411,.01,"DT")
3110512
"^DD",355.1,355.1411,1,0)
PART A PERCENTAGE^RNJ3,0I^^0;2^K:+X'=X!(X>100)!(X<0)!(X?.E1"."1.N) X
"^DD",355.1,355.1411,1,1,0)
^.1^^0
"^DD",355.1,355.1411,1,3)
Type a number between 0 and 100, 0 decimal digits.
"^DD",355.1,355.1411,1,21,0)
^^5^5^3110509^
"^DD",355.1,355.1411,1,21,1,0)
This is the percentage (0-100) that this Type of Plan pays for PART A 
"^DD",355.1,355.1411,1,21,2,0)
amounts returned under a Group and Reason code on an MRA.  Example,
"^DD",355.1,355.1411,1,21,3,0)
if this plan pays 50% of the Part A Deductible, enter a Group Code of PR
"^DD",355.1,355.1411,1,21,4,0)
in the Group Code multiple, a Reason Code of 1 in the Reason Code multiple,
"^DD",355.1,355.1411,1,21,5,0)
 and a 50 in this field.
"^DD",355.1,355.1411,1,23,0)
^^7^7^3110509^
"^DD",355.1,355.1411,1,23,1,0)
If the claim's type of plan entry has an effective date on or
"^DD",355.1,355.1411,1,23,2,0)
before the claim service date, the balance due for the secondary
"^DD",355.1,355.1411,1,23,3,0)
claim will be based on the patient responsibility multiplied by
"^DD",355.1,355.1411,1,23,4,0)
any percentages stored in the effective date multiple, plus
"^DD",355.1,355.1411,1,23,5,0)
excess charges if the Group Code CO is contained within this multiple
"^DD",355.1,355.1411,1,23,6,0)
and is associated with the correct Reason Code.
"^DD",355.1,355.1411,1,23,7,0)
Part A charges are calculated on Inpatient Institutional Claims.
"^DD",355.1,355.1411,1,"DT")
3110510
"^DD",355.1,355.1411,2,0)
PART B PERCENTAGE^RNJ3,0I^^0;3^K:+X'=X!(X>100)!(X<0)!(X?.E1"."1N.N) X
"^DD",355.1,355.1411,2,3)
Type a number between 0 and 100, 0 decimal digits.
"^DD",355.1,355.1411,2,21,0)
^.001^5^5^3110509^^
"^DD",355.1,355.1411,2,21,1,0)
This is the percentage (0-100) that this plan pays for PART B amounts 
"^DD",355.1,355.1411,2,21,2,0)
returned under a Group and Reason code on an MRA.  Example, if this 
"^DD",355.1,355.1411,2,21,3,0)
plan pays 75% of Part B Co-payments, enter a Group Code of PR in the 
"^DD",355.1,355.1411,2,21,4,0)
Group Code multiple,a Reason Code of 2 in the Reason Code multiple, 
"^DD",355.1,355.1411,2,21,5,0)
and a 75 in this field.  
"^DD",355.1,355.1411,2,23,0)
^.001^8^8^3110509^^
"^DD",355.1,355.1411,2,23,1,0)
If the claim's Type of Plan entry has an effective date on or before 
"^DD",355.1,355.1411,2,23,2,0)
the claim service From date, the balance due for the secondary claim
"^DD",355.1,355.1411,2,23,3,0)
will be based on the patient responsibility multiplied by any 
"^DD",355.1,355.1411,2,23,4,0)
percentages stored in the effective date multiple, plus excess changes 
"^DD",355.1,355.1411,2,23,5,0)
if the Group Code of CO is contained within this multiple and is 
"^DD",355.1,355.1411,2,23,6,0)
associated with the correct Reason Code.  Part B charges are 
"^DD",355.1,355.1411,2,23,7,0)
calculated on Outpatient Institutional claims and all Professional 
"^DD",355.1,355.1411,2,23,8,0)
claims.  
"^DD",355.1,355.1411,2,"DT")
3110510
"^DD",355.93,355.93,.16,0)
LICENSE STATE^P5'^DIC(5,^0;16^Q
"^DD",355.93,355.93,.16,3)
Enter the state which issued the license of the individual or facility.
"^DD",355.93,355.93,.16,21,0)
^^3^3^3111108^
"^DD",355.93,355.93,.16,21,1,0)
This is the state which issued the STATE LICENSE #(#.12) field 
"^DD",355.93,355.93,.16,21,2,0)
of the non-VA individual or facility that rendered the care that is being 
"^DD",355.93,355.93,.16,21,3,0)
billed by the VA.
"^DD",355.93,355.93,.16,"DT")
3111108
"^DD",361.1,361.1,.04,0)
EOB TYPE^SO^0:NORMAL EOB;1:MEDICARE MRA;^0;4^Q
"^DD",361.1,361.1,.04,2)
S Y(0)=Y S Y=$S(Y=0:"NORMAL EOB",1:"MRA") N Z S Z=$O(^(8,0)) I $O(^IBM(361.1,D0,8,Z),-1)'=Z S Y=Y_" (SPLIT TO MORE CLAIMS)"
"^DD",361.1,361.1,.04,2.1)
S Y=$S(Y=0:"NORMAL EOB",1:"MRA") N Z S Z=$O(^(8,0)) I $O(^IBM(361.1,D0,8,Z),-1)'=Z S Y=Y_" (SPLIT TO MORE CLAIMS)"
"^DD",361.1,361.1,.04,3)
Enter 1 if an MRA from MEDICARE
"^DD",361.1,361.1,.04,21,0)
^.001^2^2^3001130^^
"^DD",361.1,361.1,.04,21,1,0)
This field indicates whether this EOB contains actual payment data or is
"^DD",361.1,361.1,.04,21,2,0)
simply an MRA received from MEDICARE.
"^DD",361.1,361.1,.04,"DT")
3110606
"^DD",361.1,361.1,.05,0)
ENTRY DATE/TIME^RD^^0;5^S %DT="ESTXR" D ^%DT S X=Y K:Y<1 X
"^DD",361.1,361.1,.05,1,0)
^.1^^0
"^DD",361.1,361.1,.05,3)
Enter the date and time this entry is added to the file
"^DD",361.1,361.1,.05,21,0)
^.001^2^2^3110321^^^^
"^DD",361.1,361.1,.05,21,1,0)
This is the date and time that this EOB entry was added to the Vista file.
"^DD",361.1,361.1,.05,21,2,0)
This is not mapped from the 835 transmission.
"^DD",361.1,361.1,.05,"DT")
3110606
"^DD",364.5,364.5,0)
FIELD^^3^11
"^DD",364.5,364.5,0,"DDA")
N
"^DD",364.5,364.5,0,"DT")
2960311
"^DD",364.5,364.5,0,"ID",.05)
S %I=Y,Y=$S('$D(^(0)):"",$D(^DIC(+$P(^(0),U,5),0))#2:$P(^(0),U,1),1:""),C=$P(^DD(1,.01,0),U,2) D Y^DIQ:Y]"" W "   ",Y,@("$E("_DIC_"%I,0),0)") S Y=%I K %I
"^DD",364.5,364.5,0,"IX","B",364.5,.01)

"^DD",364.5,364.5,0,"NM","IB DATA ELEMENT DEFINITION")

"^DD",364.5,364.5,0,"PT",364.7,.03)

"^DD",364.5,364.5,0,"VRPK")
IB
"^DD",364.5,364.5,.01,0)
NAME^RF^^0;1^K:$L(X)>30!($L(X)<3)!'(X'?1P.E) X
"^DD",364.5,364.5,.01,1,0)
^.1
"^DD",364.5,364.5,.01,1,1,0)
364.5^B
"^DD",364.5,364.5,.01,1,1,1)
S ^IBA(364.5,"B",$E(X,1,30),DA)=""
"^DD",364.5,364.5,.01,1,1,2)
K ^IBA(364.5,"B",$E(X,1,30),DA)
"^DD",364.5,364.5,.01,3)
Answer must be 3-30 characters in length.
"^DD",364.5,364.5,.01,21,0)
^^1^1^2951205^
"^DD",364.5,364.5,.01,21,1,0)
The name to be used to uniquely identify this data element.
"^DD",364.5,364.5,.01,"DT")
2951219
"^DD",364.5,364.5,.02,0)
SECURITY LEVEL^RS^N:NATIONAL,NO EDIT;L:LOCAL;^0;2^Q
"^DD",364.5,364.5,.02,21,0)
^^2^2^2960215^^^^
"^DD",364.5,364.5,.02,21,1,0)
If this field is set to N (NATIONAL,NO EDIT), this is a secured data
"^DD",364.5,364.5,.02,21,2,0)
element and will not be allowed to be edited or deleted.
"^DD",364.5,364.5,.02,"DT")
2960215
"^DD",364.5,364.5,.03,0)
TYPE OF ELEMENT^RS^F:NON-MULTIPLE FILEMAN FIELD;E:EXTRACTED VIA CODE;C:CONSTANT VALUE;^0;3^Q
"^DD",364.5,364.5,.03,1,0)
^.1
"^DD",364.5,364.5,.03,1,1,0)
^^TRIGGER^364.5^.04
"^DD",364.5,364.5,.03,1,1,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X="FC",Y(1)=X S X=Y(0),X=X S Y=X,X=Y(1),X=X S X=X[Y I X S X=DIV S Y(1)=$S($D(^IBA(364.5,D0,0)):^(0),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X="I" X ^DD(364.5,.03,1,1,1.4)
"^DD",364.5,364.5,.03,1,1,1.4)
S DIH=$S($D(^IBA(364.5,DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,4)=DIV,DIH=364.5,DIG=.04 D ^DICR:$O(^DD(DIH,DIG,1,0))>0
"^DD",364.5,364.5,.03,1,1,2)
Q
"^DD",364.5,364.5,.03,1,1,3)
DO NOT DELETE
"^DD",364.5,364.5,.03,1,1,"%D",0)
^^1^1^2960215^
"^DD",364.5,364.5,.03,1,1,"%D",1,0)
If TYPE OF ELEMENT is 'F' or 'C' then ELEMENT CATEGORY must be 'I'. 
"^DD",364.5,364.5,.03,1,1,"CREATE CONDITION")
"FC"[INTERNAL(TYPE OF ELEMENT)
"^DD",364.5,364.5,.03,1,1,"CREATE VALUE")
S X="I"
"^DD",364.5,364.5,.03,1,1,"DELETE VALUE")
NO EFFECT
"^DD",364.5,364.5,.03,1,1,"DT")
2960215
"^DD",364.5,364.5,.03,1,1,"FIELD")
ELEMENT CATEGORY
"^DD",364.5,364.5,.03,1,2,0)
^^TRIGGER^364.5^.06
"^DD",364.5,364.5,.03,1,2,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X'="F" I X S X=DIV S Y(1)=$S($D(^IBA(364.5,D0,0)):^(0),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" X ^DD(364.5,.03,1,2,1.4)
"^DD",364.5,364.5,.03,1,2,1.4)
S DIH=$S($D(^IBA(364.5,DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,6)=DIV,DIH=364.5,DIG=.06 D ^DICR:$O(^DD(DIH,DIG,1,0))>0
"^DD",364.5,364.5,.03,1,2,2)
Q
"^DD",364.5,364.5,.03,1,2,3)
DO NOT DELETE
"^DD",364.5,364.5,.03,1,2,"%D",0)
^^2^2^2960215^
"^DD",364.5,364.5,.03,1,2,"%D",1,0)
This triggers the FILEMAN FIELD REFERENCE field to null if the element type
"^DD",364.5,364.5,.03,1,2,"%D",2,0)
is not FILEMAN field type of element.
"^DD",364.5,364.5,.03,1,2,"CREATE CONDITION")
INTERNAL(TYPE OF ELEMENT)'="F"
"^DD",364.5,364.5,.03,1,2,"CREATE VALUE")
@
"^DD",364.5,364.5,.03,1,2,"DELETE VALUE")
NO EFFECT
"^DD",364.5,364.5,.03,1,2,"DT")
2960215
"^DD",364.5,364.5,.03,1,2,"FIELD")
FILEMAN FIELD REFERENCE
"^DD",364.5,364.5,.03,1,3,0)
^^TRIGGER^364.5^.08
"^DD",364.5,364.5,.03,1,3,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X'="C" I X S X=DIV S Y(1)=$S($D(^IBA(364.5,D0,0)):^(0),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(364.5,.03,1,3,1.4)
"^DD",364.5,364.5,.03,1,3,1.4)
S DIH=$S($D(^IBA(364.5,DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,8)=DIV,DIH=364.5,DIG=.08 D ^DICR:$O(^DD(DIH,DIG,1,0))>0
"^DD",364.5,364.5,.03,1,3,2)
Q
"^DD",364.5,364.5,.03,1,3,3)
DO NOT DELETE
"^DD",364.5,364.5,.03,1,3,"%D",0)
^^2^2^2960215^
"^DD",364.5,364.5,.03,1,3,"%D",1,0)
This triggers the CONSTANT VALUE field to null if the element type is not
"^DD",364.5,364.5,.03,1,3,"%D",2,0)
CONSTANT type of element.
"^DD",364.5,364.5,.03,1,3,"CREATE CONDITION")
INTERNAL(TYPE OF ELEMENT)'="C"
"^DD",364.5,364.5,.03,1,3,"CREATE VALUE")
@
"^DD",364.5,364.5,.03,1,3,"DELETE VALUE")
NO EFFECT
"^DD",364.5,364.5,.03,1,3,"DT")
2960215
"^DD",364.5,364.5,.03,1,3,"FIELD")
CONSTANT VALUE
"^DD",364.5,364.5,.03,1,4,0)
^^TRIGGER^364.5^1
"^DD",364.5,364.5,.03,1,4,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X'="E" I X S X=DIV S Y(1)=$S($D(^IBA(364.5,D0,1)):^(1),1:"") S X=$E(Y(1),1,245),X=X S DIU=X K Y S X="" X ^DD(364.5,.03,1,4,1.4)
"^DD",364.5,364.5,.03,1,4,1.4)
S DIH=$S($D(^IBA(364.5,DIV(0),1)):^(1),1:""),DIV=X S DE=0-$L(DIH),DIU=$E(DIH,1,245),Y=$E(DIH,246,999),^(1)=$J("",$S(DE>0:DE,1:0))_DIV_$S(Y?." ":"",1:$J("",245-$L(DIV))_Y),DIH=364.5,DIG=1 D ^DICR:$O(^DD(DIH,DIG,1,0))>0
"^DD",364.5,364.5,.03,1,4,2)
Q
"^DD",364.5,364.5,.03,1,4,3)
DO NOT DELETE
"^DD",364.5,364.5,.03,1,4,"%D",0)
^^2^2^2960215^
"^DD",364.5,364.5,.03,1,4,"%D",1,0)
This triggers the EXTRACT CODE field to null if the element type is not an
"^DD",364.5,364.5,.03,1,4,"%D",2,0)
EXTRACTED VIA CODE type of element.
"^DD",364.5,364.5,.03,1,4,"CREATE CONDITION")
INTERNAL(TYPE OF ELEMENT)'="E"
"^DD",364.5,364.5,.03,1,4,"CREATE VALUE")
@
"^DD",364.5,364.5,.03,1,4,"DELETE VALUE")
NO EFFECT
"^DD",364.5,364.5,.03,1,4,"DT")
2960215
"^DD",364.5,364.5,.03,1,4,"FIELD")
EXTRACT CODE
"^DD",364.5,364.5,.03,21,0)
^^3^3^2951207^^
"^DD",364.5,364.5,.03,21,1,0)
The type of data element being defined as needed by one or more forms.  This
"^DD",364.5,364.5,.03,21,2,0)
field determines the type of retrieval needed to get the actual data element's
"^DD",364.5,364.5,.03,21,3,0)
value for a given bill.
"^DD",364.5,364.5,.03,"DT")
2960215
"^DD",364.5,364.5,.04,0)
ELEMENT CATEGORY^RSX^I:INDIVIDUAL ELEMENT;G:GROUP ELEMENT;^0;4^I $P($G(^IBA(364.5,DA,0)),U,3)="F",$G(X)="G" K X
"^DD",364.5,364.5,.04,1,0)
^.1
"^DD",364.5,364.5,.04,1,1,0)
^^TRIGGER^364.5^.06
"^DD",364.5,364.5,.04,1,1,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X="G" I X S X=DIV S Y(1)=$S($D(^IBA(364.5,D0,0)):^(0),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" X ^DD(364.5,.04,1,1,1.4)
"^DD",364.5,364.5,.04,1,1,1.4)
S DIH=$S($D(^IBA(364.5,DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,6)=DIV,DIH=364.5,DIG=.06 D ^DICR:$O(^DD(DIH,DIG,1,0))>0
"^DD",364.5,364.5,.04,1,1,2)
Q
"^DD",364.5,364.5,.04,1,1,"CREATE CONDITION")
INTERNAL(ELEMENT CATEGORY)="G"
"^DD",364.5,364.5,.04,1,1,"CREATE VALUE")
""
"^DD",364.5,364.5,.04,1,1,"DELETE VALUE")
NO EFFECT
"^DD",364.5,364.5,.04,1,1,"FIELD")
FILEMAN FIELD REFERENCE
"^DD",364.5,364.5,.04,3)
This indicates an INDIVIDUAL or GROUP of elements will be returned.  Group is not valid for Fileman type elements.
"^DD",364.5,364.5,.04,5,1,0)
364.5^.03^1
"^DD",364.5,364.5,.04,21,0)
^^3^3^2951205^
"^DD",364.5,364.5,.04,21,1,0)
This defines whether the data element to be extracted is a single piece of data
"^DD",364.5,364.5,.04,21,2,0)
or is a string of related data.  Fileman field references must be designated as
"^DD",364.5,364.5,.04,21,3,0)
individual elements.
"^DD",364.5,364.5,.04,"DT")
2960215
"^DD",364.5,364.5,.05,0)
BASE FILE^P1'^DIC(^0;5^Q
"^DD",364.5,364.5,.05,3)
Enter the Fileman file to be used as a 'base' to extract the data from.
"^DD",364.5,364.5,.05,21,0)
^^2^2^2960311^
"^DD",364.5,364.5,.05,21,1,0)
This is the number of the Fileman file to be used as a 'base' to extract
"^DD",364.5,364.5,.05,21,2,0)
data for this field.
"^DD",364.5,364.5,.05,"DT")
2960311
"^DD",364.5,364.5,.06,0)
FILEMAN FIELD REFERENCE^FX^^0;6^K:$L(X)>65!($L(X)<1) X I $D(X),$P($G(^IBA(364.5,DA,0)),U,4)="G" K X
"^DD",364.5,364.5,.06,1,0)
^.1
"^DD",364.5,364.5,.06,1,1,0)
^^TRIGGER^364.5^.07
"^DD",364.5,364.5,.06,1,1,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0)="" I X S X=DIV S Y(1)=$S($D(^IBA(364.5,D0,0)):^(0),1:"") S X=$P(Y(1),U,7),X=X S DIU=X K Y S X="" X ^DD(364.5,.06,1,1,1.4)
"^DD",364.5,364.5,.06,1,1,1.4)
S DIH=$S($D(^IBA(364.5,DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,7)=DIV,DIH=364.5,DIG=.07 D ^DICR:$O(^DD(DIH,DIG,1,0))>0
"^DD",364.5,364.5,.06,1,1,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^IBA(364.5,D0,0)):^(0),1:"") S X=$P(Y(1),U,7),X=X S DIU=X K Y S X="" X ^DD(364.5,.06,1,1,2.4)
"^DD",364.5,364.5,.06,1,1,2.4)
S DIH=$S($D(^IBA(364.5,DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,7)=DIV,DIH=364.5,DIG=.07 D ^DICR:$O(^DD(DIH,DIG,1,0))>0
"^DD",364.5,364.5,.06,1,1,"CREATE CONDITION")
FILEMAN FIELD REFERENCE=""
"^DD",364.5,364.5,.06,1,1,"CREATE VALUE")
@
"^DD",364.5,364.5,.06,1,1,"DELETE VALUE")
@
"^DD",364.5,364.5,.06,1,1,"FIELD")
#.07
"^DD",364.5,364.5,.06,3)
Must be a valid Fileman reference and ELEMENT CATEGORY must not be GROUP.
"^DD",364.5,364.5,.06,5,1,0)
364.5^.04^1
"^DD",364.5,364.5,.06,5,2,0)
364.5^.03^2
"^DD",364.5,364.5,.06,21,0)
^^6^6^2951221^^^
"^DD",364.5,364.5,.06,21,1,0)
The valid Fileman field reference or simple Fileman navigation to be used
"^DD",364.5,364.5,.06,21,2,0)
to extract using the $$GET^DIQ utility. Note this will not return true
"^DD",364.5,364.5,.06,21,3,0)
multiple entries.  Word-processing type fields are able to be retrieved,
"^DD",364.5,364.5,.06,21,4,0)
however.  No syntax check is made on this field so the user must be careful
"^DD",364.5,364.5,.06,21,5,0)
to type a valid Fileman expression.  This must be designated as an
"^DD",364.5,364.5,.06,21,6,0)
INDIVIDUAL element, not a group element.
"^DD",364.5,364.5,.06,"DT")
2951221
"^DD",364.5,364.5,.07,0)
FILEMAN RETURN FORMAT^S^I:INTERNAL;E:EXTERNAL;^0;7^Q
"^DD",364.5,364.5,.07,5,1,0)
364.5^.06^1
"^DD",364.5,364.5,.07,21,0)
^^5^5^2951205^
"^DD",364.5,364.5,.07,21,1,0)
This is the format for the retrieved data for Fileman-type data elements.  It
"^DD",364.5,364.5,.07,21,2,0)
is recommended to use Internal format whenever possible to keep the data
"^DD",364.5,364.5,.07,21,3,0)
element definitions in this file as generic as possible to avoid duplication.  
"^DD",364.5,364.5,.07,21,4,0)
The format capabilities of the forms generator should be used to interpret and
"^DD",364.5,364.5,.07,21,5,0)
reformat the data element when needed.
"^DD",364.5,364.5,.07,"DT")
2951205
"^DD",364.5,364.5,.08,0)
CONSTANT VALUE^F^^0;8^K:$L(X)>80!($L(X)<1) X
"^DD",364.5,364.5,.08,3)
Answer must be 1-80 characters in length.
"^DD",364.5,364.5,.08,5,1,0)
364.5^.03^3
"^DD",364.5,364.5,.08,21,0)
^^1^1^2951205^
"^DD",364.5,364.5,.08,21,1,0)
The specific value that this data element should return for this data element.
"^DD",364.5,364.5,.08,"DT")
2951205
"^DD",364.5,364.5,1,0)
EXTRACT CODE^K^^1;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
"^DD",364.5,364.5,1,3)
This is Standard MUMPS code.
"^DD",364.5,364.5,1,5,1,0)
364.5^.03^4
"^DD",364.5,364.5,1,9)
@
"^DD",364.5,364.5,1,21,0)
^^7^7^2951207^^^
"^DD",364.5,364.5,1,21,1,0)
The code to be executed by the forms generator to return the value(s) of the
"^DD",364.5,364.5,1,21,2,0)
data element.  If no ARRAY ROOT field is completed for this data element, the
"^DD",364.5,364.5,1,21,3,0)
code should set the variable IBXDATA or the array IBXDATA(1) through IBXDATA(n)
"^DD",364.5,364.5,1,21,4,0)
where n=the total # of iterations of the data element retrieved.  If the ARRAY 
"^DD",364.5,364.5,1,21,5,0)
ROOT field has been completed for this data element, this code should set the
"^DD",364.5,364.5,1,21,6,0)
variable referenced there.  IBXIEN is assumed to be the internal entry number
"^DD",364.5,364.5,1,21,7,0)
of the  file (referenced by the variable IBXFILE) entry.
"^DD",364.5,364.5,1,"DT")
2951205
"^DD",364.5,364.5,2,0)
ARRAY ROOT^F^^2;E1,50^K:$L(X)>50!($L(X)<1) X
"^DD",364.5,364.5,2,3)
Answer must be a valid array root name.
"^DD",364.5,364.5,2,21,0)
^^3^3^2960117^^
"^DD",364.5,364.5,2,21,1,0)
 The local or global base root where multiple-valued output or word processing
"^DD",364.5,364.5,2,21,2,0)
data is to be stored for this data element.  IBXDATA is the default if there
"^DD",364.5,364.5,2,21,3,0)
is no data in this field.  Example of a global array: ^TMP($J)
"^DD",364.5,364.5,2,"DT")
2960117
"^DD",364.5,364.5,3,0)
DESCRIPTION^364.53^^3;0
"^DD",364.5,364.53,0)
DESCRIPTION SUB-FIELD^^.01^1
"^DD",364.5,364.53,0,"DT")
2951205
"^DD",364.5,364.53,0,"NM","DESCRIPTION")

"^DD",364.5,364.53,0,"UP")
364.5
"^DD",364.5,364.53,.01,0)
DESCRIPTION^W^^0;1^Q
"^DD",364.5,364.53,.01,3)
Enter a description of the data element being defined.
"^DD",364.5,364.53,.01,21,0)
^^1^1^2951205^
"^DD",364.5,364.53,.01,21,1,0)
This is a free text description of the data that this data element represents.
"^DD",364.5,364.53,.01,"DT")
2951205
"^DD",364.6,364.6,0)
FIELD^^.13^13
"^DD",364.6,364.6,0,"DDA")
N
"^DD",364.6,364.6,0,"DT")
3071126
"^DD",364.6,364.6,0,"ID",.04)
W "   ",$P(^(0),U,4)
"^DD",364.6,364.6,0,"ID",.05)
W "   ",$P(^(0),U,5)
"^DD",364.6,364.6,0,"ID",.08)
W "   ",$P(^(0),U,8)
"^DD",364.6,364.6,0,"ID",.1)
W "   ",$P(^(0),U,10)
"^DD",364.6,364.6,0,"IX","APAR",364.6,.01)

"^DD",364.6,364.6,0,"IX","APAR1",364.6,.03)

"^DD",364.6,364.6,0,"IX","ASEQ",364.6,.01)

"^DD",364.6,364.6,0,"IX","ASEQ1",364.6,.04)

"^DD",364.6,364.6,0,"IX","ASEQ2",364.6,.05)

"^DD",364.6,364.6,0,"IX","ASEQ3",364.6,.08)

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

"^DD",364.6,364.6,0,"NM","IB FORM SKELETON DEFINITION")
 
"^DD",364.6,364.6,0,"PT",364.6,.03)

"^DD",364.6,364.6,0,"PT",364.7,.01)

"^DD",364.6,364.6,0,"VRPK")
IB
"^DD",364.6,364.6,.01,0)
BILL FORM^RP353'X^IBE(353,^0;1^I $$DUP^IBCEFG0($G(DA),X,1) K X
"^DD",364.6,364.6,.01,1,0)
^.1
"^DD",364.6,364.6,.01,1,1,0)
364.6^B
"^DD",364.6,364.6,.01,1,1,1)
S ^IBA(364.6,"B",$E(X,1,30),DA)=""
"^DD",364.6,364.6,.01,1,1,2)
K ^IBA(364.6,"B",$E(X,1,30),DA)
"^DD",364.6,364.6,.01,1,2,0)
364.6^ASEQ^MUMPS
"^DD",364.6,364.6,.01,1,2,1)
N Z0,Z1,Z2,Z3 S Z0=$G(^IBA(364.6,DA,0)),Z1=$P(Z0,U,4),Z2=$P(Z0,U,5),Z3=$P(Z0,U,8) I Z1,Z2,Z3 S ^IBA(364.6,"ASEQ",+X,Z1,Z2,Z3,DA)=""
"^DD",364.6,364.6,.01,1,2,2)
N Z0,Z1,Z2,Z3 S Z0=$G(^IBA(364.6,DA,0)),Z1=$P(Z0,U,4),Z2=$P(Z0,U,5),Z3=$P(Z0,U,8) I Z1,Z2,Z3 K ^IBA(364.6,"ASEQ",+X,Z1,Z2,Z3,DA)
"^DD",364.6,364.6,.01,1,2,3)
DO NOT DELETE
"^DD",364.6,364.6,.01,1,2,"%D",0)
^^1^1^2960117^^
"^DD",364.6,364.6,.01,1,2,"%D",1,0)
This xref contains the sequence to use to extract or print the form fields.
"^DD",364.6,364.6,.01,1,2,"DT")
2960116
"^DD",364.6,364.6,.01,1,3,0)
364.6^APAR^MUMPS
"^DD",364.6,364.6,.01,1,3,1)
N Z0 S Z0=$P($G(^IBA(364.6,DA,0)),U,3) I Z0,Z0'=X S ^IBA(364.6,"APAR",$E(X,1,30),Z0,DA)=""
"^DD",364.6,364.6,.01,1,3,2)
N Z0 S Z0=$P($G(^IBA(364.6,DA,0)),U,3) I Z0,Z0'=X K ^IBA(364.6,"APAR",$E(X,1,30),Z0,DA)
"^DD",364.6,364.6,.01,1,3,3)
DO NOT DELETE
"^DD",364.6,364.6,.01,1,3,"%D",0)
^^1^1^2960117^
"^DD",364.6,364.6,.01,1,3,"%D",1,0)
Xref by bill form and associated form field definition.
"^DD",364.6,364.6,.01,1,3,"DT")
2960117
"^DD",364.6,364.6,.01,1,4,0)
^^TRIGGER^364.6^.03
"^DD",364.6,364.6,.01,1,4,1)
X ^DD(364.6,.01,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^IBA(364.6,D0,0)):^(0),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$S('$D(D0):"",D0<0:"",1:D0) X ^DD(364.6,.01,1,4,1.4)
"^DD",364.6,364.6,.01,1,4,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(364.6,.01,1,4,69.2) S X=$P($P(Y(102),$C(59)_$P(Y(101),U,2)_":",2),$C(59),1)="BILLING SCREEN" S D0=I(0,0)
"^DD",364.6,364.6,.01,1,4,1.4)
S DIH=$G(^IBA(364.6,DIV(0),0)),DIV=X S $P(^(0),U,3)=DIV,DIH=364.6,DIG=.03 D ^DICR
"^DD",364.6,364.6,.01,1,4,2)
X ^DD(364.6,.01,1,4,2.3) I X S X=DIV S Y(1)=$S($D(^IBA(364.6,D0,0)):^(0),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" S DIH=$G(^IBA(364.6,DIV(0),0)),DIV=X S $P(^(0),U,3)=DIV,DIH=364.6,DIG=.03 D ^DICR
"^DD",364.6,364.6,.01,1,4,2.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(364.6,.01,1,4,79.2) S Y(101)=$S($D(^IBE(353,D0,2)):^(2),1:"") S X=$P($P(Y(102),$C(59)_$P(Y(101),U,2)_":",2),$C(59),1)="BILLING SCREEN" S D0=I(0,0)
"^DD",364.6,364.6,.01,1,4,3)
DO NOT DELETE
"^DD",364.6,364.6,.01,1,4,69.2)
S I(0,0)=$G(D0),D0=Y(0) S:'D0!'$D(^IBE(353,+D0,0)) D0=-1 S Y(102)=$C(59)_$P($G(^DD(353,2.02,0)),U,3),Y(101)=$S($D(^IBE(353,D0,2)):^(2),1:"")
"^DD",364.6,364.6,.01,1,4,79.2)
S I(0,0)=$G(D0),Y(1)=$S($D(^IBA(364.6,D0,0)):^(0),1:""),D0=$P(Y(1),U,1) S:'D0!'$D(^IBE(353,+D0,0)) D0=-1 S Y(102)=$C(59)_$P($G(^DD(353,2.02,0)),U,3)
"^DD",364.6,364.6,.01,1,4,"%D",0)
^^1^1^3000613^
"^DD",364.6,364.6,.01,1,4,"%D",1,0)
This trigger is needed for the local screen 9 logic to work correctly.
"^DD",364.6,364.6,.01,1,4,"CREATE CONDITION")
BILL FORM:FORMAT TYPE="BILLING SCREEN"
"^DD",364.6,364.6,.01,1,4,"CREATE VALUE")
NUMBER
"^DD",364.6,364.6,.01,1,4,"DELETE CONDITION")
BILL FORM:FORMAT TYPE="BILLING SCREEN"
"^DD",364.6,364.6,.01,1,4,"DELETE VALUE")
@
"^DD",364.6,364.6,.01,1,4,"DT")
3000613
"^DD",364.6,364.6,.01,1,4,"FIELD")
ASSOCIATED FORM DEFINITION
"^DD",364.6,364.6,.01,3)
Enter a BILLING FORM that the data element will appear on.
"^DD",364.6,364.6,.01,21,0)
^^2^2^2960318^^^^
"^DD",364.6,364.6,.01,21,1,0)
Identifies a billing 'form' or 'screen' where the data element is used.
"^DD",364.6,364.6,.01,21,2,0)
The combination of form/page/line/column must be unique.
"^DD",364.6,364.6,.01,"DT")
3000613
"^DD",364.6,364.6,.02,0)
SECURITY LEVEL^SX^N:NATIONAL,NO EDIT;L:LOCAL;^0;2^I X="N",$P($G(^IBA(364.6,DA,0)),U,3) K X
"^DD",364.6,364.6,.02,3)
Enter an N if no editing is allowed, L if editing is OK because this entry is associated with a locally defined form.
"^DD",364.6,364.6,.02,5,1,0)
364.6^.03^7
"^DD",364.6,364.6,.02,21,0)
^.001^4^4^3001030^^
"^DD",364.6,364.6,.02,21,1,0)
This field determines whether or not editing of the entry is allowed.  If
"^DD",364.6,364.6,.02,21,2,0)
the security level of the entry is NATIONAL (N), no local editing is
"^DD",364.6,364.6,.02,21,3,0)
allowed.  If the security level of the entry is LOCAL (L), it may be
"^DD",364.6,364.6,.02,21,4,0)
edited.
"^DD",364.6,364.6,.02,"DT")
2960117
"^DD",364.6,364.6,.03,0)
ASSOCIATED FORM DEFINITION^P364.6'^IBA(364.6,^0;3^Q
"^DD",364.6,364.6,.03,1,0)
^.1
"^DD",364.6,364.6,.03,1,1,0)
364.6^APAR1^MUMPS
"^DD",364.6,364.6,.03,1,1,1)
N Z0 S Z0=+$G(^IBA(364.6,DA,0)) I Z0,Z0'=X S ^IBA(364.6,"APAR",Z0,$E(X,1,30),DA)=""
"^DD",364.6,364.6,.03,1,1,2)
N Z0 S Z0=+$G(^IBA(364.6,DA,0)) I Z0,Z0'=X K ^IBA(364.6,"APAR",Z0,$E(X,1,30),DA)
"^DD",364.6,364.6,.03,1,1,3)
DO NOT DELETE
"^DD",364.6,364.6,.03,1,1,"%D",0)
^^1^1^2960117^^
"^DD",364.6,364.6,.03,1,1,"%D",1,0)
Xref by bill form and associated form field definition.
"^DD",364.6,364.6,.03,1,1,"DT")
2960117
"^DD",364.6,364.6,.03,1,2,0)
^^TRIGGER^364.6^.04
"^DD",364.6,364.6,.03,1,2,1)
X ^DD(364.6,.03,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^IBA(364.6,D0,0)):^(0),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(364.6,.03,1,2,1.4)
"^DD",364.6,364.6,.03,1,2,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(364.6,.03,1,2,69.2) S Y(101)=$S($D(^IBE(353,D0,2)):^(2),1:"") S X=$P($P(Y(102),$C(59)_$P(Y(101),U,2)_":",2),$C(59),1)'="BILLING SCREEN" S D0=I(0,0)
"^DD",364.6,364.6,.03,1,2,1.4)
S DIH=$S($D(^IBA(364.6,DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,4)=DIV,DIH=364.6,DIG=.04 D ^DICR
"^DD",364.6,364.6,.03,1,2,2)
Q
"^DD",364.6,364.6,.03,1,2,3)
DO NOT DELETE
"^DD",364.6,364.6,.03,1,2,69.2)
S I(0,0)=$S($D(D0):D0,1:""),Y(1)=$S($D(^IBA(364.6,D0,0)):^(0),1:""),D0=$P(Y(1),U,1) S:'$D(^IBE(353,+D0,0)) D0=-1 S Y(102)=$C(59)_$S($D(^DD(353,2.02,0)):$P(^(0),U,3),1:"")
"^DD",364.6,364.6,.03,1,2,"%D",0)
^.101^2^2^3000424^^
"^DD",364.6,364.6,.03,1,2,"%D",1,0)
If an associated form that is not a screen form, page is taken from the
"^DD",364.6,364.6,.03,1,2,"%D",2,0)
associated with field definition.
"^DD",364.6,364.6,.03,1,2,"CREATE CONDITION")
BILL FORM:FORMAT TYPE'="BILLING SCREEN"
"^DD",364.6,364.6,.03,1,2,"CREATE VALUE")
@
"^DD",364.6,364.6,.03,1,2,"DELETE VALUE")
NO EFFECT
"^DD",364.6,364.6,.03,1,2,"DT")
3000405
"^DD",364.6,364.6,.03,1,2,"FIELD")
PAGE OR SEQUENCE
"^DD",364.6,364.6,.03,1,3,0)
^^TRIGGER^364.6^.05
"^DD",364.6,364.6,.03,1,3,1)
X ^DD(364.6,.03,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^IBA(364.6,D0,0)):^(0),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X="" X ^DD(364.6,.03,1,3,1.4)
"^DD",364.6,364.6,.03,1,3,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(364.6,.03,1,3,69.2) S Y(101)=$S($D(^IBE(353,D0,2)):^(2),1:"") S X=$P($P(Y(102),$C(59)_$P(Y(101),U,2)_":",2),$C(59),1)'="BILLING SCREEN" S D0=I(0,0)
"^DD",364.6,364.6,.03,1,3,1.4)
S DIH=$S($D(^IBA(364.6,DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,5)=DIV,DIH=364.6,DIG=.05 D ^DICR
"^DD",364.6,364.6,.03,1,3,2)
Q
"^DD",364.6,364.6,.03,1,3,3)
DO NOT DELETE
"^DD",364.6,364.6,.03,1,3,69.2)
S I(0,0)=$S($D(D0):D0,1:""),Y(1)=$S($D(^IBA(364.6,D0,0)):^(0),1:""),D0=$P(Y(1),U,1) S:'$D(^IBE(353,+D0,0)) D0=-1 S Y(102)=$C(59)_$S($D(^DD(353,2.02,0)):$P(^(0),U,3),1:"")
"^DD",364.6,364.6,.03,1,3,"%D",0)
^^2^2^3000405^
"^DD",364.6,364.6,.03,1,3,"%D",1,0)
If an associated form that is not a screen form, line is taken from the
"^DD",364.6,364.6,.03,1,3,"%D",2,0)
associated with field definition.
"^DD",364.6,364.6,.03,1,3,"CREATE CONDITION")
BILL FORM:FORMAT TYPE'="BILLING SCREEN"
"^DD",364.6,364.6,.03,1,3,"CREATE VALUE")
@
"^DD",364.6,364.6,.03,1,3,"DELETE VALUE")
NO EFFECT
"^DD",364.6,364.6,.03,1,3,"DT")
3000405
"^DD",364.6,364.6,.03,1,3,"FIELD")
FIRST LINE NUMBER
"^DD",364.6,364.6,.03,1,4,0)
^^TRIGGER^364.6^.08
"^DD",364.6,364.6,.03,1,4,1)
X ^DD(364.6,.03,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^IBA(364.6,D0,0)):^(0),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(364.6,.03,1,4,1.4)
"^DD",364.6,364.6,.03,1,4,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(364.6,.03,1,4,69.2) S Y(101)=$S($D(^IBE(353,D0,2)):^(2),1:"") S X=$P($P(Y(102),$C(59)_$P(Y(101),U,2)_":",2),$C(59),1)'="BILLING SCREEN" S D0=I(0,0)
"^DD",364.6,364.6,.03,1,4,1.4)
S DIH=$S($D(^IBA(364.6,DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,8)=DIV,DIH=364.6,DIG=.08 D ^DICR
"^DD",364.6,364.6,.03,1,4,2)
Q
"^DD",364.6,364.6,.03,1,4,3)
DO NOT DELETE
"^DD",364.6,364.6,.03,1,4,69.2)
S I(0,0)=$S($D(D0):D0,1:""),Y(1)=$S($D(^IBA(364.6,D0,0)):^(0),1:""),D0=$P(Y(1),U,1) S:'$D(^IBE(353,+D0,0)) D0=-1 S Y(102)=$C(59)_$S($D(^DD(353,2.02,0)):$P(^(0),U,3),1:"")
"^DD",364.6,364.6,.03,1,4,"%D",0)
^^2^2^3000405^
"^DD",364.6,364.6,.03,1,4,"%D",1,0)
If an associated form that is not a screen form, column is taken from the
"^DD",364.6,364.6,.03,1,4,"%D",2,0)
associated with field definition.
"^DD",364.6,364.6,.03,1,4,"CREATE CONDITION")
BILL FORM:FORMAT TYPE'="BILLING SCREEN"
"^DD",364.6,364.6,.03,1,4,"CREATE VALUE")
@
"^DD",364.6,364.6,.03,1,4,"DELETE VALUE")
NO EFFECT
"^DD",364.6,364.6,.03,1,4,"DT")
3000405
"^DD",364.6,364.6,.03,1,4,"FIELD")
STARTING COLUMN
"^DD",364.6,364.6,.03,1,5,0)
^^TRIGGER^364.6^.09
"^DD",364.6,364.6,.03,1,5,1)
X ^DD(364.6,.03,1,5,1.3) I X S X=DIV S Y(1)=$S($D(^IBA(364.6,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X="" X ^DD(364.6,.03,1,5,1.4)
"^DD",364.6,364.6,.03,1,5,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(364.6,.03,1,5,69.2) S Y(101)=$S($D(^IBE(353,D0,2)):^(2),1:"") S X=$P($P(Y(102),$C(59)_$P(Y(101),U,2)_":",2),$C(59),1)'="BILLING SCREEN" S D0=I(0,0)
"^DD",364.6,364.6,.03,1,5,1.4)
S DIH=$S($D(^IBA(364.6,DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,9)=DIV,DIH=364.6,DIG=.09 D ^DICR:$O(^DD(DIH,DIG,1,0))>0
"^DD",364.6,364.6,.03,1,5,2)
Q
"^DD",364.6,364.6,.03,1,5,3)
DO NOT DELETE
"^DD",364.6,364.6,.03,1,5,69.2)
S I(0,0)=$S($D(D0):D0,1:""),Y(1)=$S($D(^IBA(364.6,D0,0)):^(0),1:""),D0=$P(Y(1),U,1) S:'$D(^IBE(353,+D0,0)) D0=-1 S Y(102)=$C(59)_$S($D(^DD(353,2.02,0)):$P(^(0),U,3),1:"")
"^DD",364.6,364.6,.03,1,5,"%D",0)
^^2^2^3000405^
"^DD",364.6,364.6,.03,1,5,"%D",1,0)
If an associated form that is not a screen form, length is taken from the
"^DD",364.6,364.6,.03,1,5,"%D",2,0)
associated with field definition.
"^DD",364.6,364.6,.03,1,5,"CREATE CONDITION")
BILL FORM:FORMAT TYPE'="BILLING SCREEN"
"^DD",364.6,364.6,.03,1,5,"CREATE VALUE")
@
"^DD",364.6,364.6,.03,1,5,"DELETE VALUE")
NO EFFECT
"^DD",364.6,364.6,.03,1,5,"DT")
3000405
"^DD",364.6,364.6,.03,1,5,"FIELD")
LENGTH
"^DD",364.6,364.6,.03,1,6,0)
^^TRIGGER^364.6^.06
"^DD",364.6,364.6,.03,1,6,1)
X ^DD(364.6,.03,1,6,1.3) I X S X=DIV S Y(1)=$S($D(^IBA(364.6,D0,0)):^(0),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" X ^DD(364.6,.03,1,6,1.4)
"^DD",364.6,364.6,.03,1,6,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(364.6,.03,1,6,69.2) S Y(101)=$S($D(^IBE(353,D0,2)):^(2),1:"") S X=$P($P(Y(102),$C(59)_$P(Y(101),U,2)_":",2),$C(59),1)'="BILLING SCREEN" S D0=I(0,0)
"^DD",364.6,364.6,.03,1,6,1.4)
S DIH=$S($D(^IBA(364.6,DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,6)=DIV,DIH=364.6,DIG=.06 D ^DICR:$O(^DD(DIH,DIG,1,0))>0
"^DD",364.6,364.6,.03,1,6,2)
Q
"^DD",364.6,364.6,.03,1,6,3)
DO NOT DELETE
"^DD",364.6,364.6,.03,1,6,69.2)
S I(0,0)=$S($D(D0):D0,1:""),Y(1)=$S($D(^IBA(364.6,D0,0)):^(0),1:""),D0=$P(Y(1),U,1) S:'$D(^IBE(353,+D0,0)) D0=-1 S Y(102)=$C(59)_$S($D(^DD(353,2.02,0)):$P(^(0),U,3),1:"")
"^DD",364.6,364.6,.03,1,6,"%D",0)
^^2^2^3000405^
"^DD",364.6,364.6,.03,1,6,"%D",1,0)
If associated form that is not a screen form, the max number lines is taken
"^DD",364.6,364.6,.03,1,6,"%D",2,0)
from the associated with field definition.
"^DD",364.6,364.6,.03,1,6,"CREATE CONDITION")
BILL FORM:FORMAT TYPE'="BILLING SCREEN"
"^DD",364.6,364.6,.03,1,6,"CREATE VALUE")
@
"^DD",364.6,364.6,.03,1,6,"DELETE VALUE")
NO EFFECT
"^DD",364.6,364.6,.03,1,6,"DT")
3000405
"^DD",364.6,364.6,.03,1,6,"FIELD")
MAX NUMBER LINES
"^DD",364.6,364.6,.03,1,7,0)
^^TRIGGER^364.6^.02
"^DD",364.6,364.6,.03,1,7,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^IBA(364.6,D0,0)):^(0),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X="L" X ^DD(364.6,.03,1,7,1.4)
"^DD",364.6,364.6,.03,1,7,1.4)
S DIH=$S($D(^IBA(364.6,DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,2)=DIV,DIH=364.6,DIG=.02 D ^DICR:$O(^DD(DIH,DIG,1,0))>0
"^DD",364.6,364.6,.03,1,7,2)
Q
"^DD",364.6,364.6,.03,1,7,3)
DO NOT DELETE
"^DD",364.6,364.6,.03,1,7,"%D",0)
^^1^1^2960117^
"^DD",364.6,364.6,.03,1,7,"%D",1,0)
Only local entries can be associated.
"^DD",364.6,364.6,.03,1,7,"CREATE VALUE")
"L"
"^DD",364.6,364.6,.03,1,7,"DELETE VALUE")
NO EFFECT
"^DD",364.6,364.6,.03,1,7,"DT")
2960117
"^DD",364.6,364.6,.03,1,7,"FIELD")
SECURITY LEVEL
"^DD",364.6,364.6,.03,3)
Enter the form definition record this definition will override.
"^DD",364.6,364.6,.03,5,1,0)
364.6^.01^4
"^DD",364.6,364.6,.03,21,0)
^^1^1^2960117^^
"^DD",364.6,364.6,.03,21,1,0)
The form definition record this definition will override.
"^DD",364.6,364.6,.03,"DT")
3000414
"^DD",364.6,364.6,.04,0)
PAGE OR SEQUENCE^FX^^0;4^K:$L(X)>20!($L(X)<1) X I $D(X),$S($P($G(^IBE(353,+$G(^IBA(364.6,+DA,0)),2)),U,2)="S":0,1:$P($G(^IBA(364.6,DA,0)),U,3))!$$DUP^IBCEFG0(DA,X,2) K X
"^DD",364.6,364.6,.04,1,0)
^.1^^-1
"^DD",364.6,364.6,.04,1,1,0)
364.6^ASEQ1^MUMPS
"^DD",364.6,364.6,.04,1,1,1)
N Z0,Z1,Z2,Z3 S Z0=$G(^IBA(364.6,DA,0)),Z1=+Z0,Z2=$P(Z0,U,5),Z3=$P(Z0,U,8) I Z1,Z2,Z3 S ^IBA(364.6,"ASEQ",Z1,$E(X,1,30),Z2,Z3,DA)=""
"^DD",364.6,364.6,.04,1,1,2)
N Z0,Z1,Z2,Z3 S Z0=$G(^IBA(364.6,DA,0)),Z1=+Z0,Z2=$P(Z0,U,5),Z3=$P(Z0,U,8) I Z1,Z2,Z3 K ^IBA(364.6,"ASEQ",Z1,$E(X,1,30),Z2,Z3,DA)
"^DD",364.6,364.6,.04,1,1,3)
DO NOT DELETE
"^DD",364.6,364.6,.04,1,1,"%D",0)
^^1^1^2960117^
"^DD",364.6,364.6,.04,1,1,"%D",1,0)
This xref contains the sequence to use to extract or print the form fields.
"^DD",364.6,364.6,.04,1,1,"DT")
2960117
"^DD",364.6,364.6,.04,3)
This data must be 1-20 char long, can't be an assoc form, and must be a unique form/page/line/column.
"^DD",364.6,364.6,.04,5,1,0)
364.6^.03^2
"^DD",364.6,364.6,.04,21,0)
^^4^4^2960318^^^^
"^DD",364.6,364.6,.04,21,1,0)
This field is used to specify the page, section, transaction segment, etc.
"^DD",364.6,364.6,.04,21,2,0)
that the data element is to be associated with.  This field will be used as
"^DD",364.6,364.6,.04,21,3,0)
the second-level sort field when extracting data fields for this form.
"^DD",364.6,364.6,.04,21,4,0)
The combination of form/page/line/column must be unique.
"^DD",364.6,364.6,.04,"DT")
3000428
"^DD",364.6,364.6,.05,0)
FIRST LINE NUMBER^NJ4,0X^^0;5^K:+X'=X!(X>9999)!(X<0)!(X?.E1"."1N.N) X I $D(X),$S($P($G(^IBE(353,+$G(^IBA(364.6,+DA,0)),2)),U,2)="S":0,1:$P($G(^IBA(364.6,DA,0)),U,3))!$$DUP^IBCEFG0(DA,X,3) K X
"^DD",364.6,364.6,.05,.1)
LINE
"^DD",364.6,364.6,.05,1,0)
^.1
"^DD",364.6,364.6,.05,1,1,0)
364.6^ASEQ2^MUMPS
"^DD",364.6,364.6,.05,1,1,1)
N Z0,Z1,Z2,Z3 S Z0=$G(^IBA(364.6,DA,0)),Z1=+Z0,Z2=$P(Z0,U,4),Z3=$P(Z0,U,8) I Z1,Z2'="",Z3 S ^IBA(364.6,"ASEQ",Z1,Z2,$E(X,1,30),Z3,DA)=""
"^DD",364.6,364.6,.05,1,1,2)
N Z0,Z1,Z2,Z3 S Z0=$G(^IBA(364.6,DA,0)),Z1=+Z0,Z2=$P(Z0,U,4),Z3=$P(Z0,U,8) I Z1,Z2'="",Z3 K ^IBA(364.6,"ASEQ",Z1,Z2,$E(X,1,30),Z3,DA)
"^DD",364.6,364.6,.05,1,1,3)
DO NOT DELETE
"^DD",364.6,364.6,.05,1,1,"%D",0)
^^1^1^2960117^^^^
"^DD",364.6,364.6,.05,1,1,"%D",1,0)
This xref contains the sequence to use to extract or print the form fields.
"^DD",364.6,364.6,.05,1,1,"DT")
2960117
"^DD",364.6,364.6,.05,3)
Type a # 0-9999, 0 Decimals, can't be assoc form, need unique form/pg/line/col.
"^DD",364.6,364.6,.05,5,1,0)
364.6^.03^3
"^DD",364.6,364.6,.05,21,0)
^^5^5^2960318^^^
"^DD",364.6,364.6,.05,21,1,0)
If this is a printed form, this is the first line number that this data
"^DD",364.6,364.6,.05,21,2,0)
element will appear on.  For transmitted forms, this is assumed to always
"^DD",364.6,364.6,.05,21,3,0)
be a 1.  This will be used as the third-level sort field when extracting
"^DD",364.6,364.6,.05,21,4,0)
data fields for this form.  The combination of form/page/line/column must
"^DD",364.6,364.6,.05,21,5,0)
be unique.
"^DD",364.6,364.6,.05,"DT")
3000428
"^DD",364.6,364.6,.06,0)
MAX NUMBER LINES^NJ3,0X^^0;6^K:+X'=X!(X>999)!(X<0)!(X?.E1"."1N.N) X I $D(X),$P($G(^IBA(364.6,DA,0)),U,3) K X
"^DD",364.6,364.6,.06,3)
Type a Number between 0 and 999, 0 Decimal Digits (can't be an associated form).
"^DD",364.6,364.6,.06,5,1,0)
364.6^.03^6
"^DD",364.6,364.6,.06,21,0)
^^2^2^2951205^
"^DD",364.6,364.6,.06,21,1,0)
If a printed form, this is the highest numbered line number that this data
"^DD",364.6,364.6,.06,21,2,0)
element is allowed to print on.
"^DD",364.6,364.6,.06,"DT")
2960117
"^DD",364.6,364.6,.07,0)
LOCAL OVERRIDE ALLOWED^S^0:NO;1:YES;^0;7^Q
"^DD",364.6,364.6,.07,3)
Enter 0 (NO) to prevent local override, 1 to allow local override.
"^DD",364.6,364.6,.07,21,0)
^.001^2^2^3020822^^
"^DD",364.6,364.6,.07,21,1,0)
This controls whether or not the output forms generator will allow for a
"^DD",364.6,364.6,.07,21,2,0)
redefinition of this record via a local override.
"^DD",364.6,364.6,.07,"DT")
2960311
"^DD",364.6,364.6,.08,0)
STARTING COLUMN OR PIECE^NJ3,1X^^0;8^K:+X'=X!(X>999)!(X<0)!($S(X[".":X'?.E1"."1.2N,1:0)) X I $D(X),$S($P($G(^IBE(353,+$G(^IBA(364.6,+DA,0)),2)),U,2)="S":0,1:$P($G(^IBA(364.6,DA,0)),U,3))!$$DUP^IBCEFG0(DA,X,4) K X
"^DD",364.6,364.6,.08,.1)
COLUMN
"^DD",364.6,364.6,.08,1,0)
^.1
"^DD",364.6,364.6,.08,1,1,0)
364.6^ASEQ3^MUMPS
"^DD",364.6,364.6,.08,1,1,1)
N Z0,Z1,Z2,Z3 S Z0=$G(^IBA(364.6,DA,0)),Z1=+Z0,Z2=$P(Z0,U,4),Z3=$P(Z0,U,5) I Z1,Z2'="",Z3 S ^IBA(364.6,"ASEQ",Z1,Z2,Z3,$E(X,1,30),DA)=""
"^DD",364.6,364.6,.08,1,1,2)
N Z0,Z1,Z2,Z3 S Z0=$G(^IBA(364.6,DA,0)),Z1=+Z0,Z2=$P(Z0,U,4),Z3=$P(Z0,U,5) I Z1,Z2'="",Z3 K ^IBA(364.6,"ASEQ",Z1,Z2,Z3,$E(X,1,30),DA)
"^DD",364.6,364.6,.08,1,1,3)
DO NOT DELETE
"^DD",364.6,364.6,.08,1,1,"%D",0)
^^1^1^2960117^
"^DD",364.6,364.6,.08,1,1,"%D",1,0)
This xref contains the sequence to use to extract or print the form fields.
"^DD",364.6,364.6,.08,1,1,"DT")
2960117
"^DD",364.6,364.6,.08,1,2,0)
^^TRIGGER^364.6^.11
"^DD",364.6,364.6,.08,1,2,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0)["." I X S X=DIV S Y(1)=$S($D(^IBA(364.6,D0,0)):^(0),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=1 X ^DD(364.6,.08,1,2,1.4)
"^DD",364.6,364.6,.08,1,2,1.4)
S DIH=$S($D(^IBA(364.6,DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,11)=DIV,DIH=364.6,DIG=.11 D ^DICR:$O(^DD(DIH,DIG,1,0))>0
"^DD",364.6,364.6,.08,1,2,2)
Q
"^DD",364.6,364.6,.08,1,2,3)
DO NOT DELETE
"^DD",364.6,364.6,.08,1,2,"%D",0)
^^2^2^2960126^^^
"^DD",364.6,364.6,.08,1,2,"%D",1,0)
If the starting column or piece is not a whole number, this must be a
"^DD",364.6,364.6,.08,1,2,"%D",2,0)
calculate only field - no output.
"^DD",364.6,364.6,.08,1,2,"CREATE CONDITION")
STARTING COLUMN OR PIECE["."
"^DD",364.6,364.6,.08,1,2,"CREATE VALUE")
S X=1
"^DD",364.6,364.6,.08,1,2,"DELETE VALUE")
NO EFFECT
"^DD",364.6,364.6,.08,1,2,"DT")
2960126
"^DD",364.6,364.6,.08,1,2,"FIELD")
#.11
"^DD",364.6,364.6,.08,3)
Type a # 0-9999, 1-2 Decimals, can't be assoc form, need unique form/pg/line/col.
"^DD",364.6,364.6,.08,5,1,0)
364.6^.03^4
"^DD",364.6,364.6,.08,21,0)
^^5^5^2960318^^^^
"^DD",364.6,364.6,.08,21,1,0)
This is the column on the form, position in the data string (for non-printed
"^DD",364.6,364.6,.08,21,2,0)
forms) -  starting at position 1, or delimited piece that this data element
"^DD",364.6,364.6,.08,21,3,0)
is to be printed or stored in.  This will be used as the fourth-level sort
"^DD",364.6,364.6,.08,21,4,0)
field when extracting data fields for this form.  The combination of
"^DD",364.6,364.6,.08,21,5,0)
form/page/line/column must be unique.
"^DD",364.6,364.6,.08,"DT")
3000428
"^DD",364.6,364.6,.09,0)
LENGTH^NJ3,0X^^0;9^K:+X'=X!(X>250)!(X<1)!(X?.E1"."1N.N) X I $D(X),$P($G(^IBA(364.6,DA,0)),U,3),$P($G(^IBE(353,+^IBA(364.6,DA,0),2)),U,2)'="S" K X
"^DD",364.6,364.6,.09,3)
Type a Number between 1 and 250, 0 Decimal Digits (can't be an associated form).
"^DD",364.6,364.6,.09,5,1,0)
364.6^.03^5
"^DD",364.6,364.6,.09,21,0)
^^3^3^2951205^
"^DD",364.6,364.6,.09,21,1,0)
The length desired for the data element.  If present, this field will be used
"^DD",364.6,364.6,.09,21,2,0)
to truncate or pad the data element to this length after the element has been
"^DD",364.6,364.6,.09,21,3,0)
passed through the routine identified in the FORMAT ROUTINE field.
"^DD",364.6,364.6,.09,"DT")
3000111
"^DD",364.6,364.6,.1,0)
SHORT DESCRIPTION^F^^0;10^K:$L(X)>40!($L(X)<1) X
"^DD",364.6,364.6,.1,3)
Answer must be 1-40 characters in length
"^DD",364.6,364.6,.1,21,0)
^^2^2^3071126^
"^DD",364.6,364.6,.1,21,1,0)
This is a short description of the field that is used as an identifier to
"^DD",364.6,364.6,.1,21,2,0)
make lookups on this file meaningful.
"^DD",364.6,364.6,.1,"DT")
3080310
"^DD",364.6,364.6,.11,0)
CALCULATE ONLY OR OUTPUT^S^1:CALCULATE ONLY;0:OUTPUT;^0;11^Q
"^DD",364.6,364.6,.11,3)
Enter 1 if this field is used for calculation purposes and is not meant to be output
"^DD",364.6,364.6,.11,5,1,0)
364.6^.08^2
"^DD",364.6,364.6,.11,21,0)
^^4^4^2960715^^^^
"^DD",364.6,364.6,.11,21,1,0)
This field is set to 1 if there is a need to do a special extract or
"^DD",364.6,364.6,.11,21,2,0)
calculation at some point in the processing, but no output is desired
"^DD",364.6,364.6,.11,21,3,0)
from the field's code execution.  Used to set up arrays for group elements
"^DD",364.6,364.6,.11,21,4,0)
then the individual elements are output separately.
"^DD",364.6,364.6,.11,"DT")
2960715
"^DD",364.6,364.6,.12,0)
TRANSMIT IGNORES IF NULL^S^0:FALSE;1:TRUE;^0;12^Q
"^DD",364.6,364.6,.12,3)
Enter 1 (TRUE) if there should be no entry made in the output global if the data value of the element is null.
"^DD",364.6,364.6,.12,21,0)
^.001^5^5^3001030^^^
"^DD",364.6,364.6,.12,21,1,0)
This field can be used to suppress output of a field if its value is null.
"^DD",364.6,364.6,.12,21,2,0)
If not suppressed, an entry is made in the output global used by the
"^DD",364.6,364.6,.12,21,3,0)
formatter, regardless of the contents of the data for this field.
"^DD",364.6,364.6,.12,21,4,0)
Supressing the value results in no output to the formatter's output
"^DD",364.6,364.6,.12,21,5,0)
global if the value of the data for this field is determined to be null.
"^DD",364.6,364.6,.12,"DT")
2991006
"^DD",364.6,364.6,.13,0)
DATA REQUIRED FOR FIELD^S^1:YES;0:NO;^0;13^Q
"^DD",364.6,364.6,.13,3)
Enter yes if there should always be data in this field.
"^DD",364.6,364.6,.13,21,0)
^^2^2^3000216^
"^DD",364.6,364.6,.13,21,1,0)
This field is a flag that will stop the output of a record if this field
"^DD",364.6,364.6,.13,21,2,0)
indicates data is required and the data extracted is null.
"^DD",364.6,364.6,.13,"DT")
3000216
"^DD",364.7,364.7,0)
FIELD^^3^12
"^DD",364.7,364.7,0,"DDA")
N
"^DD",364.7,364.7,0,"DT")
2960710
"^DD",364.7,364.7,0,"ID",.03)
S %I=Y,Y=$S('$D(^(0)):"",$D(^IBA(364.5,+$P(^(0),U,3),0))#2:$P(^(0),U,1),1:""),C=$P(^DD(364.5,.01,0),U,2) D Y^DIQ:Y]"" W "   ",Y,@("$E("_DIC_"%I,0),0)") S Y=%I K %I
"^DD",364.7,364.7,0,"IX","AINS",364.7,.01)

"^DD",364.7,364.7,0,"IX","AINS1",364.7,.05)

"^DD",364.7,364.7,0,"IX","AINTYP",364.7,.01)

"^DD",364.7,364.7,0,"IX","AINTYP1",364.7,.05)

"^DD",364.7,364.7,0,"IX","AINTYP2",364.7,.06)

"^DD",364.7,364.7,0,"IX","ATYPE",364.7,.01)

"^DD",364.7,364.7,0,"IX","ATYPE1",364.7,.06)

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

"^DD",364.7,364.7,0,"IX","C",364.7,.03)

"^DD",364.7,364.7,0,"NM","IB FORM FIELD CONTENT")
 
"^DD",364.7,364.7,0,"VRPK")
IB
"^DD",364.7,364.7,.01,0)
FORM FIELD REFERENCE^RP364.6'^IBA(364.6,^0;1^Q
"^DD",364.7,364.7,.01,1,0)
^.1
"^DD",364.7,364.7,.01,1,1,0)
364.7^B
"^DD",364.7,364.7,.01,1,1,1)
S ^IBA(364.7,"B",$E(X,1,30),DA)=""
"^DD",364.7,364.7,.01,1,1,2)
K ^IBA(364.7,"B",$E(X,1,30),DA)
"^DD",364.7,364.7,.01,1,2,0)
364.7^ATYPE^MUMPS
"^DD",364.7,364.7,.01,1,2,1)
N Z1,Z0 S Z0=$G(^IBA(364.7,DA,0)),Z1=$P(Z0,U,6) I Z1'="",$P($G(^IBA(364.6,+X,0)),U,3),'$P(Z0,U,5) S ^IBA(364.7,"ATYPE",$P(^IBA(364.6,+X,0),U,3),Z1,DA)=""
"^DD",364.7,364.7,.01,1,2,2)
N Z0,Z1 S Z0=$G(^IBA(364.7,DA,0)),Z1=$P(Z0,U,6) I Z1'="",$P($G(^IBA(364.6,+X,0)),U,3) K ^IBA(364.7,"ATYPE",$P(^IBA(364.6,+X,0),U,3),Z1,DA)
"^DD",364.7,364.7,.01,1,2,3)
DO NOT DELETE
"^DD",364.7,364.7,.01,1,2,"%D",0)
^^1^1^2980104^^^^
"^DD",364.7,364.7,.01,1,2,"%D",1,0)
Xref by form and bill type
"^DD",364.7,364.7,.01,1,2,"DT")
2960117
"^DD",364.7,364.7,.01,1,3,0)
364.7^AINTYP^MUMPS
"^DD",364.7,364.7,.01,1,3,1)
N Z0,Z1,Z2 S Z0=$G(^IBA(364.7,DA,0)),Z1=$P(Z0,U,5),Z2=$P(Z0,U,6) I Z1,Z2'="",$P($G(^IBA(364.6,+X,0)),U,3) S ^IBA(364.7,"AINTYP",$P(^IBA(364.6,+X,0),U,3),Z1,Z2,DA)=""
"^DD",364.7,364.7,.01,1,3,2)
N Z0,Z1,Z2 S Z0=$G(^IBA(364.7,DA,0)),Z1=$P(Z0,U,5),Z2=$P(Z0,U,6) I Z1,Z2'="",$P($G(^IBA(364.6,+X,0)),U,3) K ^IBA(364.7,"AINTYP",$P(^IBA(364.6,+X,0),U,3),Z1,Z2,DA)
"^DD",364.7,364.7,.01,1,3,3)
DO NOT DELETE
"^DD",364.7,364.7,.01,1,3,"%D",0)
^^1^1^2971231^^^
"^DD",364.7,364.7,.01,1,3,"%D",1,0)
Xref by form, insurance company and bill type
"^DD",364.7,364.7,.01,1,3,"DT")
2960117
"^DD",364.7,364.7,.01,1,4,0)
364.7^AINS^MUMPS
"^DD",364.7,364.7,.01,1,4,1)
N Z0,Z1 S Z0=$G(^IBA(364.7,DA,0)),Z1=$P(Z0,U,5) I Z1,$P($G(^IBA(364.6,+X,0)),U,3),$P(Z0,U,6)="" S ^IBA(364.7,"AINS",$P(^IBA(364.6,+X,0),U,3),Z1,DA)=""
"^DD",364.7,364.7,.01,1,4,2)
N Z0,Z1 S Z0=$G(^IBA(364.7,DA,0)),Z1=$P(Z0,U,5) I Z1,$P($G(^IBA(364.6,+X,0)),U,3) K ^IBA(364.7,"AINS",$P(^IBA(364.6,+X,0),U,3),Z1,DA)
"^DD",364.7,364.7,.01,1,4,3)
DO NOT DELETE
"^DD",364.7,364.7,.01,1,4,"%D",0)
^^1^1^2971231^^
"^DD",364.7,364.7,.01,1,4,"%D",1,0)
Xref by form field and insurance company
"^DD",364.7,364.7,.01,1,4,"DT")
2960118
"^DD",364.7,364.7,.01,3)
Enter the billing form that this field is associated with
"^DD",364.7,364.7,.01,21,0)
^^2^2^2951207^^^^
"^DD",364.7,364.7,.01,21,1,0)
This is a pointer to the billing form field that this field is associated
"^DD",364.7,364.7,.01,21,2,0)
with.
"^DD",364.7,364.7,.01,"DT")
3000428
"^DD",364.7,364.7,.02,0)
SECURITY LEVEL^S^N:NATIONAL,NO EDIT;L:LOCAL;^0;2^Q
"^DD",364.7,364.7,.02,3)
Enter N for nationally released fields (no edit) or L for locally added fields.
"^DD",364.7,364.7,.02,21,0)
^^3^3^2951219^^^
"^DD",364.7,364.7,.02,21,1,0)
This field determines whether or not editing of the entry is allowed.  For
"^DD",364.7,364.7,.02,21,2,0)
NATIONAL (N) field, no local editing is allowed.  If LOCAL (L) field is
"^DD",364.7,364.7,.02,21,3,0)
created, editing is allowed.
"^DD",364.7,364.7,.02,"DT")
3000428
"^DD",364.7,364.7,.03,0)
DATA ELEMENT^P364.5'^IBA(364.5,^0;3^Q
"^DD",364.7,364.7,.03,1,0)
^.1
"^DD",364.7,364.7,.03,1,1,0)
364.7^C
"^DD",364.7,364.7,.03,1,1,1)
S ^IBA(364.7,"C",$E(X,1,30),DA)=""
"^DD",364.7,364.7,.03,1,1,2)
K ^IBA(364.7,"C",$E(X,1,30),DA)
"^DD",364.7,364.7,.03,1,1,3)
DO NOT DELETE
"^DD",364.7,364.7,.03,1,1,"%D",0)
^^1^1^2960702^
"^DD",364.7,364.7,.03,1,1,"%D",1,0)
Xref by DATA ELEMENT NAME
"^DD",364.7,364.7,.03,1,1,"DT")
2960702
"^DD",364.7,364.7,.03,3)
Enter the data element that will define this form field.  If used on a screen, it must be a fileman type.
"^DD",364.7,364.7,.03,21,0)
^^1^1^2960627^^^^
"^DD",364.7,364.7,.03,21,1,0)
This identifies the data element that be extracted for this entry.
"^DD",364.7,364.7,.03,23,0)
^^4^4^2960627^^^^
"^DD",364.7,364.7,.03,23,1,0)
This is the data element that will be allowed to be displayed/edited on a
"^DD",364.7,364.7,.03,23,2,0)
screen, extracted for a transmit, or printed on a printed form.  If used on
"^DD",364.7,364.7,.03,23,3,0)
a screen, the data element must be a fileman type and a local field (>10000
"^DD",364.7,364.7,.03,23,4,0)
for ifn and on a node >10000) to be editable.
"^DD",364.7,364.7,.03,"DT")
2960702
"^DD",364.7,364.7,.04,0)
SCREEN PROMPT^FX^^0;4^K:$L(X)>70!($L(X)<1) X I $D(X),$P($G(^IBE(353,+$G(^IBA(364.6,+$G(^IBA(364.7,DA,0)),0)),2)),U,2)'="S" K X
"^DD",364.7,364.7,.04,.1)
 
"^DD",364.7,364.7,.04,1,0)
^.1^^0
"^DD",364.7,364.7,.04,3)
Answer must be 1-70 characters in length.
"^DD",364.7,364.7,.04,21,0)
3^^2^2^2960321^^^^
"^DD",364.7,364.7,.04,21,1,0)
This is used only by screen-type forms to place a prompt on the screen
"^DD",364.7,364.7,.04,21,2,0)
for a particular field.
"^DD",364.7,364.7,.04,23,0)
^^3^3^2960321^^^^
"^DD",364.7,364.7,.04,23,1,0)
This is the prompt that will preceed the data element defined for this
"^DD",364.7,364.7,.04,23,2,0)
entry.  If no data element, this prompt will display.  This field is only
"^DD",364.7,364.7,.04,23,3,0)
used for screen-type forms.
"^DD",364.7,364.7,.04,"DT")
2960321
"^DD",364.7,364.7,.05,0)
INSURANCE COMPANY^P36'^DIC(36,^0;5^Q
"^DD",364.7,364.7,.05,1,0)
^.1
"^DD",364.7,364.7,.05,1,1,0)
364.7^AINS1^MUMPS
"^DD",364.7,364.7,.05,1,1,1)
N Z0,Z1 S Z0=$G(^IBA(364.7,DA,0)),Z1=$P($G(^IBA(364.6,+Z0,0)),U,3) I Z1,$P(Z0,U,6)="" S ^IBA(364.7,"AINS",Z1,$E(X,1,30),DA)=""
"^DD",364.7,364.7,.05,1,1,2)
N Z0,Z1,Z2 S Z0=$G(^IBA(364.7,DA,0)),Z1=$P($G(^IBA(364.6,+Z0,0)),U,3),Z2=$P(Z0,U,6) K ^IBA(364.7,"AINS",Z1,$E(X,1,30),DA) I Z2'="",$D(^IBA(364.7,"AINTYP",Z1,X,Z2,DA)) S ^IBA(364.7,"ATYPE",Z1,Z2,DA)=""
"^DD",364.7,364.7,.05,1,1,3)
DO NOT DELETE
"^DD",364.7,364.7,.05,1,1,"%D",0)
^^1^1^2960118^
"^DD",364.7,364.7,.05,1,1,"%D",1,0)
Xref by form field and insurance company.
"^DD",364.7,364.7,.05,1,1,"DT")
2960118
"^DD",364.7,364.7,.05,1,2,0)
364.7^AINTYP1^MUMPS
"^DD",364.7,364.7,.05,1,2,1)
N Z0,Z1,Z2 S Z0=$G(^IBA(364.7,DA,0)),Z1=+$P($G(^IBA(364.6,+Z0,0)),U,3),Z2=$P(Z0,U,6) I Z1,Z2'="" S ^IBA(364.7,"AINTYP",Z1,$E(X,1,30),Z2,DA)="" K ^IBA(364.7,"ATYPE",Z1,Z2,DA),^IBA(364.7,"AINS",Z1,X,DA)
"^DD",364.7,364.7,.05,1,2,2)
N Z0,Z1,Z2 S Z0=$G(^IBA(364.7,DA,0)),Z1=+$P($G(^IBA(364.6,+Z0,0)),U,3),Z2=$P(Z0,U,6) K:Z1&(Z2'="") ^IBA(364.7,"AINTYP",Z1,$E(X,1,30),Z2,DA)
"^DD",364.7,364.7,.05,1,2,3)
DO NOT DELETE
"^DD",364.7,364.7,.05,1,2,"%D",0)
^^1^1^2960117^^^^
"^DD",364.7,364.7,.05,1,2,"%D",1,0)
Xref by insurance company and bill type
"^DD",364.7,364.7,.05,1,2,"DT")
2960117
"^DD",364.7,364.7,.05,3)
Enter the name of the insurance company that this field is associated with.
"^DD",364.7,364.7,.05,21,0)
^^2^2^2951207^
"^DD",364.7,364.7,.05,21,1,0)
This is the insurance company who has a need for other than the standard
"^DD",364.7,364.7,.05,21,2,0)
data in this field.
"^DD",364.7,364.7,.05,"DT")
3000428
"^DD",364.7,364.7,.06,0)
BILL TYPE^S^I:INPATIENT;O:OUTPATIENT;^0;6^Q
"^DD",364.7,364.7,.06,1,0)
^.1
"^DD",364.7,364.7,.06,1,1,0)
364.7^ATYPE1^MUMPS
"^DD",364.7,364.7,.06,1,1,1)
N Z0,Z1 S Z0=$G(^IBA(364.7,DA,0)),Z1=$P($G(^IBA(364.6,+Z0,0)),U,3) I Z1,'$P(Z0,U,5) S ^IBA(364.7,"ATYPE",Z1,$E(X,1,30),DA)=""
"^DD",364.7,364.7,.06,1,1,2)
N Z0,Z1,Z2 S Z0=$G(^IBA(364.7,DA,0)),Z1=$P($G(^IBA(364.6,+Z0,0)),U,3),Z2=$P(Z0,U,5) I Z1 K ^IBA(364.7,"ATYPE",Z1,$E(X,1,30),DA) I Z2,$D(^IBA(364.7,"AINTYP",Z1,Z2,X,DA)) S ^IBA(364.7,"AINS",Z1,Z2,DA)=""
"^DD",364.7,364.7,.06,1,1,3)
DO NOT DELETE
"^DD",364.7,364.7,.06,1,1,"%D",0)
^^1^1^2960117^^
"^DD",364.7,364.7,.06,1,1,"%D",1,0)
Xref by form and bill type.
"^DD",364.7,364.7,.06,1,1,"DT")
2960117
"^DD",364.7,364.7,.06,1,2,0)
364.7^AINTYP2^MUMPS
"^DD",364.7,364.7,.06,1,2,1)
N Z0,Z1,Z2 S Z0=$G(^IBA(364.7,DA,0)),Z1=+$P($G(^IBA(364.6,+Z0,0)),U,3),Z2=$P(Z0,U,5) I Z1,Z2 K:'$D(^IBA(364.7,"AINTYP",Z1,Z2,X,DA)) ^IBA(364.7,"AINS",Z1,Z2,DA) S ^IBA(364.7,"AINTYP",Z1,Z2,$E(X,1,30),DA)=""
"^DD",364.7,364.7,.06,1,2,2)
N Z0,Z1,Z2 S Z0=$G(^IBA(364.7,DA,0)),Z1=+$P($G(^IBA(364.6,+Z0,0)),U,3),Z2=$P(Z0,U,5) K:Z1&Z2 ^IBA(364.7,"AINTYP",Z1,Z2,$E(X,1,30),DA)
"^DD",364.7,364.7,.06,1,2,3)
DO NOT DELETE
"^DD",364.7,364.7,.06,1,2,"%D",0)
^^1^1^2960117^^^^
"^DD",364.7,364.7,.06,1,2,"%D",1,0)
Xref by form, insurance company and bill type
"^DD",364.7,364.7,.06,1,2,"DT")
2960117
"^DD",364.7,364.7,.06,3)
Enter the type of the bill.
"^DD",364.7,364.7,.06,21,0)
^^1^1^2960117^^
"^DD",364.7,364.7,.06,21,1,0)
This is the type of bill that requires this field.
"^DD",364.7,364.7,.06,"DT")
3000428
"^DD",364.7,364.7,.07,0)
PAD CHARACTER^S^ZL:ZERO PAD ON LEFT;ZR:ZERO PAD ON RIGHT;SL:SPACE PAD ON LEFT;SR:SPACE PAD ON RIGHT;N:NO PAD REQUIRED;^0;7^Q
"^DD",364.7,364.7,.07,3)
Enter the code that corresponds to the format and pad character to use for the data output in this field.
"^DD",364.7,364.7,.07,21,0)
^^3^3^2960126^^
"^DD",364.7,364.7,.07,21,1,0)
If present, this defines the character to be used to pad the DATA
"^DD",364.7,364.7,.07,21,2,0)
ELEMENT to its desired length and the orientation of the padding characters
"^DD",364.7,364.7,.07,21,3,0)
to the left or right of the data.  The default is space pad to the right.
"^DD",364.7,364.7,.07,"DT")
2960126
"^DD",364.7,364.7,.08,0)
REQUIRED^S^0:NO;1:YES;^0;8^Q
"^DD",364.7,364.7,.08,3)
Enter 1 (YES) if this data element is on a local screen 9 form and the data is required for the bill to be authorized.
"^DD",364.7,364.7,.08,21,0)
^.001^4^4^3001030^^
"^DD",364.7,364.7,.08,21,1,0)
This field controls the required/not required status of a data element
"^DD",364.7,364.7,.08,21,2,0)
on a local screen 9 form.  If this field is 1 (YES), this data element
"^DD",364.7,364.7,.08,21,3,0)
is always required to have data (not null) in order for a bill to be
"^DD",364.7,364.7,.08,21,4,0)
authorized.
"^DD",364.7,364.7,.08,"DT")
2951207
"^DD",364.7,364.7,.09,0)
EDIT STATUS^S^E:EDITABLE;D:DISPLAY ONLY;^0;9^Q
"^DD",364.7,364.7,.09,3)
Enter 'E' to enable editing for this field, 'D' for a display only field.
"^DD",364.7,364.7,.09,21,0)
^^2^2^2960320^
"^DD",364.7,364.7,.09,21,1,0)
This field is used to control whether or not a data element on a screen is
"^DD",364.7,364.7,.09,21,2,0)
editable or for display-only purposes.
"^DD",364.7,364.7,.09,"DT")
2960320
"^DD",364.7,364.7,.1,0)
EDIT GROUP NUMBER^NJ2,0^^0;10^K:+X'=X!(X>99)!(X<1)!(X?.E1"."1N.N) X
"^DD",364.7,364.7,.1,3)
 Enter the edit group # that this field will be included in.  Valid #'s are 1-99.
"^DD",364.7,364.7,.1,21,0)
^^6^6^2960321^^
"^DD",364.7,364.7,.1,21,1,0)
This field contains the # of the edit group that the screen data element
"^DD",364.7,364.7,.1,21,2,0)
will be included with.  When this group # is selected on an edit screen,
"^DD",364.7,364.7,.1,21,3,0)
all data elements assigned to this group # on this screen will be presented
"^DD",364.7,364.7,.1,21,4,0)
for editing.  If no # is entered here, this field will not be available for
"^DD",364.7,364.7,.1,21,5,0)
editing.  This field will only apply to screen-type forms' editable data
"^DD",364.7,364.7,.1,21,6,0)
element descriptions.
"^DD",364.7,364.7,.1,"DT")
2960321
"^DD",364.7,364.7,1,0)
FORMAT CODE^K^^1;E1,245^K:$L(X)>245 X D:$D(X) ^DIM
"^DD",364.7,364.7,1,3)
This is Standard MUMPS code.
"^DD",364.7,364.7,1,9)
@
"^DD",364.7,364.7,1,21,0)
^^8^8^2951207^
"^DD",364.7,364.7,1,21,1,0)
This is the code that will be xecuted to format the 'raw' data element
"^DD",364.7,364.7,1,21,2,0)
value that is returned from the execution of the DATA ELEMENT's definition.
"^DD",364.7,364.7,1,21,3,0)
This code can assume the variable/array IBXDATA is available as input and
"^DD",364.7,364.7,1,21,4,0)
should set this variable/array as its output.  Standard calls for data
"^DD",364.7,364.7,1,21,5,0)
formatting have been provided.  The variables IBXPG, IBXLN, IBXCOL are the
"^DD",364.7,364.7,1,21,6,0)
only IBX* variables that should be changed in this routine.  These represent
"^DD",364.7,364.7,1,21,7,0)
the page, line, column as the first 3 levels of subscript for the output
"^DD",364.7,364.7,1,21,8,0)
array.
"^DD",364.7,364.7,1,"DT")
2951207
"^DD",364.7,364.7,3,0)
FORMAT CODE DESCRIPTION^364.73^^3;0
"^DD",364.7,364.7,3,21,0)
^.001^1^1^3110609^^^
"^DD",364.7,364.7,3,21,1,0)
This field describes the function of the format code entered.
"^DD",364.7,364.7,3,"DT")
2960710
"^DD",364.7,364.73,0)
FORMAT CODE DESCRIPTION SUB-FIELD^^.01^1
"^DD",364.7,364.73,0,"DT")
2960710
"^DD",364.7,364.73,0,"NM","FORMAT CODE DESCRIPTION")
 
"^DD",364.7,364.73,0,"UP")
364.7
"^DD",364.7,364.73,.01,0)
FORMAT CODE DESCRIPTION^W^^0;1^Q
"^DD",364.7,364.73,.01,3)
Enter a description of the processing logic of the format code.
"^DD",364.7,364.73,.01,21,0)
^.001^1^1^3110609^^^^
"^DD",364.7,364.73,.01,21,1,0)
This is a description of the processing logic of the format code.
"^DD",364.7,364.73,.01,"DT")
2960710
"^DD",399,399,.05,0)
BILL CLASSIFICATION^RSX^1:INPATIENT (MEDICARE PART A);2:HUMANITARIAN EMERGENCY (INPT./MEDICARE PART B);3:OUTPATIENT;4:HUMANITARIAN EMERGENCY (OPT./ESRD);^0;5^Q
"^DD",399,399,.05,.1)
TYPE OF BILL (2ND DIGIT)
"^DD",399,399,.05,1,0)
^.1
"^DD",399,399,.05,1,1,0)
399^ABT
"^DD",399,399,.05,1,1,1)
S ^DGCR(399,"ABT",$E(X,1,30),DA)=""
"^DD",399,399,.05,1,1,2)
K ^DGCR(399,"ABT",$E(X,1,30),DA)
"^DD",399,399,.05,1,2,0)
^^TRIGGER^399^.25
"^DD",399,399,.05,1,2,1)
X ^DD(399,.05,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,25),X=X S DIU=X K Y S X=DIV S X=$$TRIG05^IBCU4(X,D0) S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,25)=DIV,DIH=399,DIG=.25 D ^DICR
"^DD",399,399,.05,1,2,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P($G(^DGCR(399.1,+$P(Y(1),U,25),0)),U)=""
"^DD",399,399,.05,1,2,2)
Q
"^DD",399,399,.05,1,2,"CREATE CONDITION")
UB-04 BILL CLASSIFICATION=""
"^DD",399,399,.05,1,2,"CREATE VALUE")
S X=$$TRIG05^IBCU4(X,D0)
"^DD",399,399,.05,1,2,"DELETE VALUE")
NO EFFECT
"^DD",399,399,.05,1,2,"DT")
3070116
"^DD",399,399,.05,1,2,"FIELD")
UB-04 BILL CLASSIFICATION
"^DD",399,399,.05,1,3,0)
^^TRIGGER^399^158
"^DD",399,399,.05,1,3,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,.05,1,3,69.3) S Y(7)=$G(X) S X=Y(0),X=X S X=X=3,Y=X,X=Y(6),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=3 X ^DD(399,.05,1,3,1.4)
"^DD",399,399,.05,1,3,1.4)
S DIH=$G(^DGCR(399,DIV(0),"U")),DIV=X S $P(^("U"),U,8)=DIV,DIH=399,DIG=158 D ^DICR
"^DD",399,399,.05,1,3,2)
Q
"^DD",399,399,.05,1,3,69.2)
S Y(2)=$C(59)_$P($G(^DD(399,158,0)),U,3),Y(5)=$S($D(^DGCR(399,D0,0)):^(0),1:""),Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"")
"^DD",399,399,.05,1,3,69.3)
X ^DD(399,.05,1,3,69.2) S X=$P($P(Y(2),$C(59)_$P(Y(1),U,8)_":",2),$C(59))="",Y(3)=$G(X),Y(4)=$G(X) S X=$P(Y(5),U,27),X=X S X=X=1,Y=X,X=Y(3),X=X&Y,Y(6)=$G(X)
"^DD",399,399,.05,1,3,"%D",0)
^^4^4^3110728^
"^DD",399,399,.05,1,3,"%D",1,0)
This trigger is designed to set the TYPE OF ADMISSION to "3 for 
"^DD",399,399,.05,1,3,"%D",2,0)
ELECTIVE", if it is empty, when the BILL CHARGE TYPE field is equal to "1 
"^DD",399,399,.05,1,3,"%D",3,0)
for INSTITUTIONAL" and the BILL CLASSIFICATION field is equal to "3 for 
"^DD",399,399,.05,1,3,"%D",4,0)
OUTPATIENT".
"^DD",399,399,.05,1,3,"CREATE CONDITION")
(#158="")&(INTERNAL(#.27)=1)&(INTERNAL(#.05)=3)
"^DD",399,399,.05,1,3,"CREATE VALUE")
S X=3
"^DD",399,399,.05,1,3,"DELETE VALUE")
NO EFFECT
"^DD",399,399,.05,1,3,"DT")
3110728
"^DD",399,399,.05,1,3,"FIELD")
TYPE OF ADMISSION
"^DD",399,399,.05,3)
Enter the code which designates inpatient or outpatient care.
"^DD",399,399,.05,21,0)
^^1^1^2931220^^^^
"^DD",399,399,.05,21,1,0)
This code identifies the care being billed for as inpatient or outpatient.
"^DD",399,399,.05,"DT")
3110728
"^DD",399,399,.27,0)
BILL CHARGE TYPE^S^1:INSTITUTIONAL;2:PROFESSIONAL;^0;27^Q
"^DD",399,399,.27,1,0)
^.1
"^DD",399,399,.27,1,1,0)
^^TRIGGER^399^.19
"^DD",399,399,.27,1,1,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=$$FT^IBCU3(DA,1) X ^DD(399,.27,1,1,1.4)
"^DD",399,399,.27,1,1,1.4)
S DIH=$S($D(^DGCR(399,DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,19)=DIV,DIH=399,DIG=.19 D ^DICR
"^DD",399,399,.27,1,1,2)
Q
"^DD",399,399,.27,1,1,"%D",0)
^^1^1^2990305^
"^DD",399,399,.27,1,1,"%D",1,0)
Sets the bill Form Type based on Insurance, Charge Type, and Site default.
"^DD",399,399,.27,1,1,"CREATE VALUE")
S X=$$FT^IBCU3(DA,1)
"^DD",399,399,.27,1,1,"DELETE VALUE")
NO EFFECT
"^DD",399,399,.27,1,1,"DT")
2990305
"^DD",399,399,.27,1,1,"FIELD")
FORM TYPE
"^DD",399,399,.27,1,2,0)
^^TRIGGER^399^158
"^DD",399,399,.27,1,2,1)
X ^DD(399,.27,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=3 S DIH=$G(^DGCR(399,DIV(0),"U")),DIV=X S $P(^("U"),U,8)=DIV,DIH=399,DIG=158 D ^DICR
"^DD",399,399,.27,1,2,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,.27,1,2,69.3) S Y(6)=$G(X) S X=$P(Y(7),U,5),X=X S X=X=3,Y=X,X=Y(5),X=X&Y
"^DD",399,399,.27,1,2,2)
Q
"^DD",399,399,.27,1,2,69.2)
S Y(2)=$C(59)_$P($G(^DD(399,158,0)),U,3),Y(7)=$S($D(^DGCR(399,D0,0)):^(0),1:""),Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"")
"^DD",399,399,.27,1,2,69.3)
X ^DD(399,.27,1,2,69.2) S X=$P($P(Y(2),$C(59)_$P(Y(1),U,8)_":",2),$C(59))="",Y(3)=$G(X),Y(4)=$G(X) S X=Y(0),X=X S X=X=1,Y=X,X=Y(3),X=X&Y,Y(5)=$G(X)
"^DD",399,399,.27,1,2,"%D",0)
^^4^4^3110728^
"^DD",399,399,.27,1,2,"%D",1,0)
This trigger is designed to set the TYPE OF ADMISSION to "3 for 
"^DD",399,399,.27,1,2,"%D",2,0)
ELECTIVE", if it is empty, when the BILL CHARGE TYPE field is equal to "1
"^DD",399,399,.27,1,2,"%D",3,0)
for INSTITUTIONAL" and the BILL CLASSIFICATION field is equal to "3 for
"^DD",399,399,.27,1,2,"%D",4,0)
OUTPATIENT".
"^DD",399,399,.27,1,2,"CREATE CONDITION")
(#158="")&(INTERNAL(#.27)=1)&(INTERNAL(#.05)=3)
"^DD",399,399,.27,1,2,"CREATE VALUE")
S X=3
"^DD",399,399,.27,1,2,"DELETE VALUE")
NO EFFECT
"^DD",399,399,.27,1,2,"DT")
3110728
"^DD",399,399,.27,1,2,"FIELD")
TYPE OF ADMISSION
"^DD",399,399,.27,3)
Enter the part of the service to the patient this bill covers.
"^DD",399,399,.27,21,0)
^^3^3^2981007^^^^
"^DD",399,399,.27,21,1,0)
The service to the patient may have two components, institutional/facility
"^DD",399,399,.27,21,2,0)
and professional.  If this bill only has charges for one of these
"^DD",399,399,.27,21,3,0)
components then enter that component.
"^DD",399,399,.27,"DT")
3110728
"^DD",399,399,287,0)
PATIENT WEIGHT (LB)^NJ4,0^^U7;1^K:+X'=X!(X>1000)!(X<1)!(X?.E1"."1N.N) X
"^DD",399,399,287,3)
Enter a whole number for the patient's weight (1-1000 Pounds).
"^DD",399,399,287,21,0)
^^1^1^3110728^
"^DD",399,399,287,21,1,0)
This is a whole number for the patient's weight.
"^DD",399,399,287,"DT")
3110728
"^DD",399,399,288,0)
TRANSPORT REASON CODE^P353.4'^IBE(353.4,^U7;2^Q
"^DD",399,399,288,3)
Select the code indicating the reason for transport.
"^DD",399,399,288,21,0)
^^1^1^3110727^
"^DD",399,399,288,21,1,0)
This is the code indicating the reason for transport.
"^DD",399,399,288,"DT")
3110728
"^DD",399,399,289,0)
AMBULANCE TRANSPORT DISTANCE^NJ5,0^^U7;3^K:+X'=X!(X>10000)!(X<0)!(X?.E1"."1.N) X
"^DD",399,399,289,3)
Enter a whole number for the distance traveled during transport (0-10000 Miles).
"^DD",399,399,289,21,0)
^^1^1^3110728^
"^DD",399,399,289,21,1,0)
This is a whole number for the distance traveled during transport.
"^DD",399,399,289,"DT")
3110728
"^DD",399,399,290,0)
ROUND TRIP PURPOSE DESCRIPTION^F^^U7;4^K:$L(X)>80!($L(X)<1) X
"^DD",399,399,290,3)
Enter a free text explanation of the purpose of the R/T service (1-80 characters).
"^DD",399,399,290,21,0)
^^1^1^3110728^
"^DD",399,399,290,21,1,0)
This is a free text explanation of the purpose of the R/T service.
"^DD",399,399,290,"DT")
3110728
"^DD",399,399,291,0)
STRETCHER PURPOSE DESCRIPTION^F^^U7;5^K:$L(X)>80!($L(X)<1) X
"^DD",399,399,291,3)
Enter a free text explanation of why a stretcher was used (1-80 characters).
"^DD",399,399,291,21,0)
^^1^1^3110728^
"^DD",399,399,291,21,1,0)
This is a free text explanation of why a stretcher was used.
"^DD",399,399,291,"DT")
3110728
"^DD",399,399,292,0)
AMBULANCE CONDITION INDICATOR^399.0292PA^^U9;0
"^DD",399,399,292,21,0)
^^2^2^3110809^^
"^DD",399,399,292,21,1,0)
This allows up to five patient condition indicators to describe the 
"^DD",399,399,292,21,2,0)
patient during ambulance pickup, transport, and drop off.
"^DD",399,399,304,0)
PROCEDURES^399.0304IVA^^CP;0
"^DD",399,399,304,21,0)
^^1^1^2940214^^^^
"^DD",399,399,304,21,1,0)
These are ICD or CPT procedures that are associated with this bill.
"^DD",399,399,304,23,0)
^^1^1^2940120^^^^
"^DD",399,399,304,23,1,0)
 
"^DD",399,399,304,"DT")
2911101
"^DD",399,399.0292,0)
AMBULANCE CONDITION INDICATOR SUB-FIELD^^.01^1
"^DD",399,399.0292,0,"DIK")
IBXX
"^DD",399,399.0292,0,"DT")
3110728
"^DD",399,399.0292,0,"IX","B",399.0292,.01)

"^DD",399,399.0292,0,"NM","AMBULANCE CONDITION INDICATOR")

"^DD",399,399.0292,0,"UP")
399
"^DD",399,399.0292,.01,0)
AMBULANCE CONDITION INDICATOR^M*P353.5'^IBE(353.5,^0;1^S DIC("S")="I $$SCREEN1^IBCSC9(DA(1))" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X
"^DD",399,399.0292,.01,1,0)
^.1
"^DD",399,399.0292,.01,1,1,0)
399.0292^B
"^DD",399,399.0292,.01,1,1,1)
S ^DGCR(399,DA(1),"U9","B",$E(X,1,30),DA)=""
"^DD",399,399.0292,.01,1,1,2)
K ^DGCR(399,DA(1),"U9","B",$E(X,1,30),DA)
"^DD",399,399.0292,.01,3)
Select an Ambulance Condition Indicator.  Answer must be 1-2 characters in length.
"^DD",399,399.0292,.01,12)
This limits the entry to five condition indicators.
"^DD",399,399.0292,.01,12.1)
S DIC("S")="I $$SCREEN1^IBCSC9(DA(1))"
"^DD",399,399.0292,.01,21,0)
^^2^2^3110810^
"^DD",399,399.0292,.01,21,1,0)
This is the Ambulance Condition Code associated with the patient's 
"^DD",399,399.0292,.01,21,2,0)
condition in relation to ambulance transportation.
"^DD",399,399.0292,.01,"DT")
3110810
"^DD",399,399.0304,0)
PROCEDURES SUB-FIELD^^50.08^37
"^DD",399,399.0304,0,"NM","PROCEDURES")

"^DD",399,399.0304,.01,0)
PROCEDURES^MV^^0;1^
"^DD",399,399.0304,.01,1,0)
^.1
"^DD",399,399.0304,.01,1,1,0)
399.0304^B
"^DD",399,399.0304,.01,1,1,1)
S ^DGCR(399,DA(1),"CP","B",$E(X,1,30),DA)=""
"^DD",399,399.0304,.01,1,1,2)
K ^DGCR(399,DA(1),"CP","B",$E(X,1,30),DA)
"^DD",399,399.0304,.01,1,1,3)
Required Index for Variable Pointer
"^DD",399,399.0304,.01,1,2,0)
399^ASD^MUMPS
"^DD",399,399.0304,.01,1,2,1)
I $P(X,";",2)="ICPT(",$D(^DGCR(399,DA(1),"CP",DA,0)),$P(^(0),"^",2) S ^DGCR(399,"ASD",-$P(^(0),"^",2),+X,DA(1),DA)=""
"^DD",399,399.0304,.01,1,2,2)
I $P(X,";",2)="ICPT(",$D(^DGCR(399,DA(1),"CP",DA,0)),$P(^(0),"^",2) K ^DGCR(399,"ASD",-$P(^(0),"^",2),+X,DA(1),DA)
"^DD",399,399.0304,.01,1,2,3)
DO NOT DELETE
"^DD",399,399.0304,.01,1,2,"%D",0)
^^1^1^2930513^^^
"^DD",399,399.0304,.01,1,2,"%D",1,0)
Index procedure date and all CPT procedures.
"^DD",399,399.0304,.01,1,2,"DT")
2920311
"^DD",399,399.0304,.01,1,3,0)
^^TRIGGER^399.0304^20
"^DD",399,399.0304,.01,1,3,1)
Q
"^DD",399,399.0304,.01,1,3,2)
K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DGCR(399,D0,"CP",D1,0)):^(0),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(399.0304,.01,1,3,2.4)
"^DD",399,399.0304,.01,1,3,2.4)
S DIH=$G(^DGCR(399,DIV(0),"CP",DIV(1),0)),DIV=X S $P(^(0),U,20)=DIV,DIH=399.0304,DIG=20 D ^DICR
"^DD",399,399.0304,.01,1,3,3)
Do Not Delete
"^DD",399,399.0304,.01,1,3,"%D",0)
^.101^1^1^3010510^^
"^DD",399,399.0304,.01,1,3,"%D",1,0)
Delete the Outpatient Encounter link if the Procedure is modified.
"^DD",399,399.0304,.01,1,3,"CREATE VALUE")
NO EFFECT
"^DD",399,399.0304,.01,1,3,"DELETE VALUE")
@
"^DD",399,399.0304,.01,1,3,"DT")
3010510
"^DD",399,399.0304,.01,1,3,"FIELD")
OUTPATIENT ENCOUNTER
"^DD",399,399.0304,.01,3)
Procedure coding must match the PROCEDURE CODING METHOD entry for this bill.
"^DD",399,399.0304,.01,4)
D 3^IBCSCH1
"^DD",399,399.0304,.01,7.5)
D ^IBCU7
"^DD",399,399.0304,.01,21,0)
^^2^2^2930513^^^^
"^DD",399,399.0304,.01,21,1,0)
These are ICD, CPT, or HCFA procedure codes associated with the episode
"^DD",399,399.0304,.01,21,2,0)
of care on this bill.
"^DD",399,399.0304,.01,23,0)
^^1^1^2930513^^^
"^DD",399,399.0304,.01,23,1,0)
 
"^DD",399,399.0304,.01,"DEL",1,0)
N IBZ S IBZ=$$RXLINK^IBCSC5C(DA(1),DA) I IBZ D EN^DDIOL("  Can't delete this procedure while linked to RX revenue code #"_IBZ)
"^DD",399,399.0304,.01,"DT")
3110706
"^DD",399,399.0304,.01,"V",0)
^.12P^2^2
"^DD",399,399.0304,.01,"V",1,0)
81^CPT^1^CPT^y^n
"^DD",399,399.0304,.01,"V",1,1)
S ICPTVDT=$$BDATE^IBACSV($G(DA(1)),$G(DA)),DIC("S")="I $$CPTACT^IBACSV(+Y,ICPTVDT)",DIC("W")="D EN^DDIOL(""   ""_$P($$CPT^IBACSV(+Y,ICPTVDT),U,2),,""?0"")"
"^DD",399,399.0304,.01,"V",1,2)
Only codes active for the date of service may be selected.
"^DD",399,399.0304,.01,"V",2,0)
80.1^ICD operation/procedure^2^ICD^y^n
"^DD",399,399.0304,.01,"V",2,1)
S ICDVDT=$$BDATE^IBACSV($G(DA(1)),$G(DA)),DIC("S")="I $$ICD0ACT^IBACSV(+Y,ICDVDT)",DIC("W")="D EN^DDIOL(""   ""_$P($$ICD0^IBACSV(+Y,ICDVDT),U,4),,""?0"")"
"^DD",399,399.0304,.01,"V",2,2)
Only codes active for the date of service may be selected.
"^DD",399,399.0304,5,0)
DIVISION^P40.8'^DG(40.8,^0;6^Q
"^DD",399,399.0304,5,1,0)
^.1^^0
"^DD",399,399.0304,5,3)
Enter the division where this procedure was performed if the CPT charges are based on region and if it is different than the bills Default Division.
"^DD",399,399.0304,5,5,1,0)
399.0304^6^1
"^DD",399,399.0304,5,21,0)
^^3^3^2961001^^^^
"^DD",399,399.0304,5,21,1,0)
Enter the Division at which this procedure was performed.  This is only
"^DD",399,399.0304,5,21,2,0)
required if the bill's charges are based on CPT and region and the
"^DD",399,399.0304,5,21,3,0)
division is different than the bill's Default Division.
"^DD",399,399.0304,5,"DT")
3110706
"^DD",399,399.042,.02,0)
CHARGES^RNJ10,2^^0;2^S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>9999999.99)!(X<0) X
"^DD",399,399.042,.02,1,0)
^.1^^-1
"^DD",399,399.042,.02,1,1,0)
399.042^TC1^MUMPS
"^DD",399,399.042,.02,1,1,1)
D 21^IBCU2
"^DD",399,399.042,.02,1,1,2)
D 22^IBCU2
"^DD",399,399.042,.02,1,1,"%D",0)
^^1^1^2940214^
"^DD",399,399.042,.02,1,1,"%D",1,0)
Sets/deletes total charges.
"^DD",399,399.042,.02,1,1,"DT")
2920921
"^DD",399,399.042,.02,1,2,0)
^^TRIGGER^399.042^.16
"^DD",399,399.042,.02,1,2,1)
K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(0)=X S X=+$G(IBMAED) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"RC",D1,0)):^(0),1:"") S X=$P(Y(1),U,16),X=X S DIU=X K Y S X=DIV S X=1 X ^DD(399.042,.02,1,2,1.4)
"^DD",399,399.042,.02,1,2,1.4)
S DIH=$G(^DGCR(399,DIV(0),"RC",DIV(1),0)),DIV=X S $P(^(0),U,16)=DIV,DIH=399.042,DIG=.16 D ^DICR
"^DD",399,399.042,.02,1,2,2)
K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(0)=X S X=+$G(IBMAED) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"RC",D1,0)):^(0),1:"") S X=$P(Y(1),U,16),X=X S DIU=X K Y S X=DIV S X=1 X ^DD(399.042,.02,1,2,2.4)
"^DD",399,399.042,.02,1,2,2.4)
S DIH=$G(^DGCR(399,DIV(0),"RC",DIV(1),0)),DIV=X S $P(^(0),U,16)=DIV,DIH=399.042,DIG=.16 D ^DICR
"^DD",399,399.042,.02,1,2,3)
This is a software controlled field and should not be manually edited by a user.
"^DD",399,399.042,.02,1,2,"%D",0)
^^4^4^3110701^
"^DD",399,399.042,.02,1,2,"%D",1,0)
This trigger is designed to set the MANUALLY EDITED flag when a user 
"^DD",399,399.042,.02,1,2,"%D",2,0)
directly edits the CHARGE value for the REVENUE CODE.  This is used in 
"^DD",399,399.042,.02,1,2,"%D",3,0)
the process of preventing the auto charge update from changing user 
"^DD",399,399.042,.02,1,2,"%D",4,0)
entered values.
"^DD",399,399.042,.02,1,2,"CREATE CONDITION")
S X=+$G(IBMAED)
"^DD",399,399.042,.02,1,2,"CREATE VALUE")
S X=1
"^DD",399,399.042,.02,1,2,"DELETE CONDITION")
S X=+$G(IBMAED)
"^DD",399,399.042,.02,1,2,"DELETE VALUE")
S X=1
"^DD",399,399.042,.02,1,2,"DT")
3110701
"^DD",399,399.042,.02,1,2,"FIELD")
MANUALLY EDITED
"^DD",399,399.042,.02,3)
Type a dollar amount between 0 and 9999999.99, 2 decimal digits.
"^DD",399,399.042,.02,21,0)
^.001^3^3^3100924^^^
"^DD",399,399.042,.02,21,1,0)
This is the unit charge for this revenue code.  It will be
"^DD",399,399.042,.02,21,2,0)
multiplied times the number of units to determine the total cost for
"^DD",399,399.042,.02,21,3,0)
this revenue code.
"^DD",399,399.042,.02,"DT")
3100924
"^DD",399,399.042,.16,0)
MANUALLY EDITED^S^0:NO;1:YES;^0;16^Q
"^DD",399,399.042,.16,3)
Were revenue code CHARGES manually changed by the user?
"^DD",399,399.042,.16,5,1,0)
399.042^.02^2
"^DD",399,399.042,.16,9)
^
"^DD",399,399.042,.16,21,0)
^^2^2^3110719^
"^DD",399,399.042,.16,21,1,0)
This field indicates whether the user manually changed the CHARGES (#.02) 
"^DD",399,399.042,.16,21,2,0)
field.
"^DD",399,399.042,.16,23,0)
^^11^11^3110719^
"^DD",399,399.042,.16,23,1,0)
This field indicates whether the user manually changed the CHARGES (#.02) 
"^DD",399,399.042,.16,23,2,0)
field.  It is triggered (set to 1 or yes) when the user makes changes to
"^DD",399,399.042,.16,23,3,0)
the CHARGES (#.02) field.  It can also be triggered (reset to empty) when 
"^DD",399,399.042,.16,23,4,0)
BILL CHARGE TYPE (#399,.27), DIVISION (#399.0304,5), or PROCEDURES 
"^DD",399,399.042,.16,23,5,0)
(#399.0304,.01) fields are changed.
"^DD",399,399.042,.16,23,6,0)
 
"^DD",399,399.042,.16,23,7,0)
This field is used in routines IBCU61 and IBCU62 fields to determine if 
"^DD",399,399.042,.16,23,8,0)
the REVENUE CODE should be removed and replaced during the "automated 
"^DD",399,399.042,.16,23,9,0)
revenue code generation" process.  If the MANUALLY EDITED field is equal 
"^DD",399,399.042,.16,23,10,0)
to "1" then the REVENUE CODE should not be changed by the "automated 
"^DD",399,399.042,.16,23,11,0)
revenue code generation" process.
"^DD",399,399.042,.16,"DT")
3110719
"^DIC",350.8,350.8,0)
IB ERROR
"^DIC",350.8,350.8,0,"GL")
^IBE(350.8,
"^DIC",350.8,350.8,"%D",0)
^^11^11^2940214^^^^
"^DIC",350.8,350.8,"%D",1,0)
This file contains errors for billing functions.  It may be used by
"^DIC",350.8,350.8,"%D",2,0)
applications, IB or AR.  The normal format for a routine to return
"^DIC",350.8,350.8,"%D",3,0)
an error is to return the variable:
"^DIC",350.8,350.8,"%D",4,0)
  Y=1^... a successful event occured
"^DIC",350.8,350.8,"%D",5,0)
  Y=-1^error code[;error code;error code...]^additional text
"^DIC",350.8,350.8,"%D",6,0)
The error messages can be displayed by calling routine ^IBAERR.  If
"^DIC",350.8,350.8,"%D",7,0)
the error occurs in a tasked job ($D(ZTQUEUED)'=0) the routine will
"^DIC",350.8,350.8,"%D",8,0)
put the error message in a bulletin and post it to the group defined
"^DIC",350.8,350.8,"%D",9,0)
in the IB SITE PARAMETER FILE.
"^DIC",350.8,350.8,"%D",10,0)
 
"^DIC",350.8,350.8,"%D",11,0)
Per VHA Directive 10-93-142, this file definition should not be modified.
"^DIC",350.8,"B","IB ERROR",350.8)

"^DIC",353.4,353.4,0)
TRANSPORT REASON CODE^353.4
"^DIC",353.4,353.4,0,"GL")
^IBE(353.4,
"^DIC",353.4,353.4,"%",0)
^1.005^^0
"^DIC",353.4,353.4,"%D",0)
^^3^3^3110606^
"^DIC",353.4,353.4,"%D",1,0)
This file contains Ambulance Transport Reason Codes and Ambulance 
"^DIC",353.4,353.4,"%D",2,0)
Transport Reasons used to identify why ambulance transportation was 
"^DIC",353.4,353.4,"%D",3,0)
required.  This file comes pre-populated and should not be edited.
"^DIC",353.4,"B","TRANSPORT REASON CODE",353.4)

"^DIC",353.5,353.5,0)
AMBULANCE CONDITION INDICATORS^353.5
"^DIC",353.5,353.5,0,"GL")
^IBE(353.5,
"^DIC",353.5,353.5,"%",0)
^1.005^^0
"^DIC",353.5,353.5,"%D",0)
^^3^3^3110606^
"^DIC",353.5,353.5,"%D",1,0)
This file contains patient conditions in relation (pickup, during, and 
"^DIC",353.5,353.5,"%D",2,0)
drop-off) to ambulance transportation.  This file comes pre-populated and 
"^DIC",353.5,353.5,"%D",3,0)
should not be edited.
"^DIC",353.5,"B","AMBULANCE CONDITION INDICATORS",353.5)

"^DIC",355.1,355.1,0)
TYPE OF PLAN^355.1I
"^DIC",355.1,355.1,0,"GL")
^IBE(355.1,
"^DIC",355.1,355.1,"%",0)
^1.005^^0
"^DIC",355.1,355.1,"%D",0)
^1.001^6^6^3110509^^^^
"^DIC",355.1,355.1,"%D",1,0)
This file contains the standard types of plans that an insurance
"^DIC",355.1,355.1,"%D",2,0)
company may provide.  The type of plan may be dependent on the type
"^DIC",355.1,355.1,"%D",3,0)
of coverage provided by the insurance company and may affect the type
"^DIC",355.1,355.1,"%D",4,0)
of benefits that are available for the plan.
"^DIC",355.1,355.1,"%D",5,0)
 
"^DIC",355.1,355.1,"%D",6,0)
Per VHA Directive 10-93-142, this file definition should not be modified.
"^DIC",355.1,"B","TYPE OF PLAN",355.1)

"^DIC",364.5,364.5,0)
IB DATA ELEMENT DEFINITION^364.5
"^DIC",364.5,364.5,0,"GL")
^IBA(364.5,
"^DIC",364.5,364.5,"%D",0)
^^8^8^2970606^^^^
"^DIC",364.5,364.5,"%D",1,0)
DO NOT delete entries or edit data in this file with VA File Manager.
"^DIC",364.5,364.5,"%D",2,0)
 
"^DIC",364.5,364.5,"%D",3,0)
This file contains the definition of all data elements that are needed for
"^DIC",364.5,364.5,"%D",4,0)
various forms throughout the MCCR DHCP system.  It contains the 'blueprint'
"^DIC",364.5,364.5,"%D",5,0)
for how to extract the data for each data element entry.
"^DIC",364.5,364.5,"%D",6,0)
 
"^DIC",364.5,364.5,"%D",7,0)
Entries in this file that are designated as having a SECURITY LEVEL of
"^DIC",364.5,364.5,"%D",8,0)
NATIONAL should not be deleted or edited.
"^DIC",364.5,"B","IB DATA ELEMENT DEFINITION",364.5)

"^DIC",364.6,364.6,0)
IB FORM SKELETON DEFINITION^364.6P
"^DIC",364.6,364.6,0,"GL")
^IBA(364.6,
"^DIC",364.6,364.6,"%D",0)
^^10^10^2970606^^^^
"^DIC",364.6,364.6,"%D",1,0)
DO NOT delete entries or edit data in this file with VA File Manager.
"^DIC",364.6,364.6,"%D",2,0)
 
"^DIC",364.6,364.6,"%D",3,0)
This file contains records that define the skeleton makeup of forms for
"^DIC",364.6,364.6,"%D",4,0)
the IB system.  This definition includes the absolute position of every
"^DIC",364.6,364.6,"%D",5,0)
field that can be output on the form, the length each field must be limited
"^DIC",364.6,364.6,"%D",6,0)
to, and some descriptive information.   This includes printed forms,
"^DIC",364.6,364.6,"%D",7,0)
transmittable output files, and special local billing screens.
"^DIC",364.6,364.6,"%D",8,0)
 
"^DIC",364.6,364.6,"%D",9,0)
Entries in this file that are designated as having a SECURITY LEVEL of
"^DIC",364.6,364.6,"%D",10,0)
NATIONAL should not be deleted or edited.
"^DIC",364.6,"B","IB FORM SKELETON DEFINITION",364.6)

"^DIC",364.7,364.7,0)
IB FORM FIELD CONTENT^364.7P
"^DIC",364.7,364.7,0,"GL")
^IBA(364.7,
"^DIC",364.7,364.7,"%D",0)
^1.001^9^9^3030331^^^^
"^DIC",364.7,364.7,"%D",1,0)
DO NOT delete entries or edit data in this file with VA File Manager.
"^DIC",364.7,364.7,"%D",2,0)
 
"^DIC",364.7,364.7,"%D",3,0)
This is the file that contains the specific fields to be used to produce
"^DIC",364.7,364.7,"%D",4,0)
the associated form or screen.  If there is no insurance company or bill
"^DIC",364.7,364.7,"%D",5,0)
type specified for an entry, this is assumed to be the default definition
"^DIC",364.7,364.7,"%D",6,0)
of the field.
"^DIC",364.7,364.7,"%D",7,0)
 
"^DIC",364.7,364.7,"%D",8,0)
Entries in this file that are designated as having a SECURITY LEVEL of
"^DIC",364.7,364.7,"%D",9,0)
NATIONAL should not be deleted or edited.
"^DIC",364.7,"B","IB FORM FIELD CONTENT",364.7)

**END**
**END**