Summary Table
Categories |
Total Count |
PII |
0 |
URL |
0 |
DNS |
0 |
EKL |
0 |
IP |
0 |
PORT |
0 |
VsID |
0 |
CF |
0 |
AI |
0 |
VPD |
0 |
PL |
0 |
Other |
0 |
File Content
KIDS Distribution saved on May 21, 2019@13:50:57
Version 2 build 2
**KIDS**:IB*2.0*645^
**INSTALL NAME**
IB*2.0*645
"BLD",11269,0)
IB*2.0*645^INTEGRATED BILLING^0^3190521^y
"BLD",11269,4,0)
^9.64PA^^
"BLD",11269,6.3)
14
"BLD",11269,"INID")
^n
"BLD",11269,"INIT")
POSTINIT^IB20P645
"BLD",11269,"KRN",0)
^9.67PA^1.5^24
"BLD",11269,"KRN",.4,0)
.4
"BLD",11269,"KRN",.401,0)
.401
"BLD",11269,"KRN",.402,0)
.402
"BLD",11269,"KRN",.403,0)
.403
"BLD",11269,"KRN",.5,0)
.5
"BLD",11269,"KRN",.84,0)
.84
"BLD",11269,"KRN",1.5,0)
1.5
"BLD",11269,"KRN",1.6,0)
1.6
"BLD",11269,"KRN",1.61,0)
1.61
"BLD",11269,"KRN",1.62,0)
1.62
"BLD",11269,"KRN",3.6,0)
3.6
"BLD",11269,"KRN",3.8,0)
3.8
"BLD",11269,"KRN",9.2,0)
9.2
"BLD",11269,"KRN",9.8,0)
9.8
"BLD",11269,"KRN",9.8,"NM",0)
^9.68A^3^3
"BLD",11269,"KRN",9.8,"NM",1,0)
IB20P645^^0^B123706935
"BLD",11269,"KRN",9.8,"NM",2,0)
IBOA32^^0^B8874260
"BLD",11269,"KRN",9.8,"NM",3,0)
IBARX^^0^B56596853
"BLD",11269,"KRN",9.8,"NM","B","IB20P645",1)
"BLD",11269,"KRN",9.8,"NM","B","IBARX",3)
"BLD",11269,"KRN",9.8,"NM","B","IBOA32",2)
"BLD",11269,"KRN",19,0)
19
"BLD",11269,"KRN",19.1,0)
19.1
"BLD",11269,"KRN",101,0)
101
"BLD",11269,"KRN",409.61,0)
409.61
"BLD",11269,"KRN",771,0)
771
"BLD",11269,"KRN",779.2,0)
779.2
"BLD",11269,"KRN",870,0)
870
"BLD",11269,"KRN",8989.51,0)
8989.51
"BLD",11269,"KRN",8989.52,0)
8989.52
"BLD",11269,"KRN",8994,0)
8994
"BLD",11269,"KRN","B",.4,.4)
"BLD",11269,"KRN","B",.401,.401)
"BLD",11269,"KRN","B",.402,.402)
"BLD",11269,"KRN","B",.403,.403)
"BLD",11269,"KRN","B",.5,.5)
"BLD",11269,"KRN","B",.84,.84)
"BLD",11269,"KRN","B",1.5,1.5)
"BLD",11269,"KRN","B",1.6,1.6)
"BLD",11269,"KRN","B",1.61,1.61)
"BLD",11269,"KRN","B",1.62,1.62)
"BLD",11269,"KRN","B",3.6,3.6)
"BLD",11269,"KRN","B",3.8,3.8)
"BLD",11269,"KRN","B",9.2,9.2)
"BLD",11269,"KRN","B",9.8,9.8)
"BLD",11269,"KRN","B",19,19)
"BLD",11269,"KRN","B",19.1,19.1)
"BLD",11269,"KRN","B",101,101)
"BLD",11269,"KRN","B",409.61,409.61)
"BLD",11269,"KRN","B",771,771)
"BLD",11269,"KRN","B",779.2,779.2)
"BLD",11269,"KRN","B",870,870)
"BLD",11269,"KRN","B",8989.51,8989.51)
"BLD",11269,"KRN","B",8989.52,8989.52)
"BLD",11269,"KRN","B",8994,8994)
"BLD",11269,"QDEF")
^^^^NO^^^^NO^^NO
"BLD",11269,"QUES",0)
^9.62^^
"BLD",11269,"REQB",0)
^9.611^3^3
"BLD",11269,"REQB",1,0)
IB*2.0*618^1
"BLD",11269,"REQB",2,0)
IB*2.0*451^1
"BLD",11269,"REQB",3,0)
IB*2.0*632^1
"BLD",11269,"REQB","B","IB*2.0*451",2)
"BLD",11269,"REQB","B","IB*2.0*618",1)
"BLD",11269,"REQB","B","IB*2.0*632",3)
"INIT")
POSTINIT^IB20P645
"MBREQ")
0
"PKG",230,-1)
1^1
"PKG",230,0)
INTEGRATED BILLING^IB^INTEGRATED BILLING
"PKG",230,22,0)
^9.49I^1^1
"PKG",230,22,1,0)
2.0^2940321^2940525
"PKG",230,22,1,"PAH",1,0)
645^3190521
"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")
3
"RTN","IB20P645")
0^1^B123706935
"RTN","IB20P645",1,0)
IB20P645 ;SAB/Albany - IB*2.0*645 POST INSTALL;12/11/17 2:10pm
"RTN","IB20P645",2,0)
;;2.0;Integrated Billing;**645**;Mar 20, 1995;Build 14
"RTN","IB20P645",3,0)
;Per VA Directive 6402, this routine should not be modified.
"RTN","IB20P645",4,0)
Q
"RTN","IB20P645",5,0)
;
"RTN","IB20P645",6,0)
POSTINIT ;Post Install for IB*2.0*645
"RTN","IB20P645",7,0)
D BMES^XPDUTL(" >> Starting the Post-Initialization routine for IB*2.0*645 ")
"RTN","IB20P645",8,0)
; Update Community Care No Fault Rate Schedules if necessary and add 2019 CC RX Rate Schedules
"RTN","IB20P645",9,0)
D UPDNFRS
"RTN","IB20P645",10,0)
D UPDTRRS
"RTN","IB20P645",11,0)
D RTIN
"RTN","IB20P645",12,0)
D CORACT
"RTN","IB20P645",13,0)
D BMES^XPDUTL(" >> End of the Post-Initialization routine for IB*2.0*645")
"RTN","IB20P645",14,0)
Q
"RTN","IB20P645",15,0)
;
"RTN","IB20P645",16,0)
UPDNFRS ; Update No Fault and 2019 RX Rate Schedules (363)
"RTN","IB20P645",17,0)
D MES^XPDUTL(" -> Updating Community Care No Fault and RX Rate Schedules for file 363 ...")
"RTN","IB20P645",18,0)
N IBA,IBCNT,IBI,IBLN,IBFN,IBRT,IBBS,IBCNTCS,IBDISP,IBJ,IBLNCS,IBCS,IBCSFN,IBADMIN,DD,DO
"RTN","IB20P645",19,0)
N DLAYGO,DIC,DIE,DA,DR,RXDT,X,Y,IBCPNM,IBEDT,IBNM
"RTN","IB20P645",20,0)
S IBCNT=0
"RTN","IB20P645",21,0)
F IBI=2:1 S IBLN=$P($T(RSF+IBI),";;",2) Q:IBLN="END" I $E(IBLN)?1A D
"RTN","IB20P645",22,0)
. ;Check for problems
"RTN","IB20P645",23,0)
. S IBBS=$P(IBLN,U,4) I IBBS'="" S IBBS=$$MCCRUTL(IBBS,13) Q:'IBBS ;Billable service invalid
"RTN","IB20P645",24,0)
. S IBRT=$P(IBLN,U,2),IBRT=$O(^DGCR(399.3,"B",IBRT,0)) D Q:'IBRT
"RTN","IB20P645",25,0)
.. I 'IBRT D MSG(" **** Rate Type "_$P(IBLN,U,2)_" not defined, RS "_$P(IBLN,U,1)_" not created")
"RTN","IB20P645",26,0)
.. I +$P($G(^DGCR(399.3,+IBRT,0)),U,3) S IBRT=0 D MSG(" **** Rate Type "_$P(IBLN,U,2)_" not Active, RS "_$P(IBLN,U,1)_" not created")
"RTN","IB20P645",27,0)
. ;No problems found, so create entry
"RTN","IB20P645",28,0)
. ;Locate existing entry.
"RTN","IB20P645",29,0)
. S Y=-1,IBNM=$P(IBLN,U),IBEDT=$P(IBLN,U,6)
"RTN","IB20P645",30,0)
. S IBJ=0 F S IBJ=$O(^IBE(363,"B",IBNM,IBJ)) Q:'IBJ D Q:Y>-1
"RTN","IB20P645",31,0)
. . I ($D(^IBE(363,IBJ,11))>9),(IBNM'["RX"),(IBNM'["PHARM") S Y=0 Q ;Rate Schedule correctly defined, skip.
"RTN","IB20P645",32,0)
. . I (IBNM'["RX"),(IBNM'["PHARM") S Y=IBJ Q ;Non RX Rate schedule
"RTN","IB20P645",33,0)
. . I $P(^IBE(363,IBJ,0),U,5)="" S Y=IBJ Q ;Empty RX Rate schedule, use it.
"RTN","IB20P645",34,0)
. . I ($P(^IBE(363,IBJ,0),U,5)=IBEDT),($D(^IBE(363,IBJ,11))>9) S Y=0 Q ;Rate rate exists correctly, skip
"RTN","IB20P645",35,0)
. . I ($P(^IBE(363,IBJ,0),U,5)=IBEDT),($D(^IBE(363,IBJ,11))<10) S Y=IBJ ;Rate rate exists incorrectly, update it.
"RTN","IB20P645",36,0)
. Q:Y=0 ; correctly defined, no need to update. Go find next schedule.
"RTN","IB20P645",37,0)
. I Y=-1 D ; If no entry found in Rate Schedule file, create a new entry
"RTN","IB20P645",38,0)
.. K DD,DO,Y
"RTN","IB20P645",39,0)
.. S DLAYGO=363,DIC="^IBE(363,",DIC(0)="L",X=$P(IBLN,U,1)
"RTN","IB20P645",40,0)
.. D FILE^DICN K DIC,DINUM,DLAYGO
"RTN","IB20P645",41,0)
. I Y<1 K X,Y Q
"RTN","IB20P645",42,0)
. S IBFN=+Y,IBCNT=IBCNT+1
"RTN","IB20P645",43,0)
. S IBCPNM=$P(IBLN,U,5)
"RTN","IB20P645",44,0)
. S RXDT=$$RXDT(IBCPNM,IBEDT)
"RTN","IB20P645",45,0)
. S DR=".02////"_IBRT_";.03////"_$P(IBLN,U,3) I +IBBS S DR=DR_";.04////"_IBBS
"RTN","IB20P645",46,0)
. S DR=DR_";.05////"_$P(RXDT,U)
"RTN","IB20P645",47,0)
. I $P(RXDT,U,2) S DR=DR_";.06////"_$P(RXDT,U,2)
"RTN","IB20P645",48,0)
. I (($P(IBLN,U,1)["RX")!($P(IBLN,U,1)["PHARM")),($G(IBDISP)]"") S DR=DR_";1.01///"_IBDISP
"RTN","IB20P645",49,0)
. I (($P(IBLN,U,1)["RX")!($P(IBLN,U,1)["PHARM")),($G(IBADMIN)]"") S DR=DR_";10////"_IBADMIN
"RTN","IB20P645",50,0)
. S DIE="^IBE(363,",DA=+Y D ^DIE K DIE,DA,DR,X,Y
"RTN","IB20P645",51,0)
. S IBCNTCS=0
"RTN","IB20P645",52,0)
. ; Retrieve name of Charge Set to copy
"RTN","IB20P645",53,0)
. I IBRT="" D MSG(" **** Rate Type "_$P(IBLN,U,2)_" missing Charge Set Information, RS "_$P(IBLN,U,1)_" not created") Q
"RTN","IB20P645",54,0)
. ; add all Reasonable Charges Charge Sets to the Rate Schedule.
"RTN","IB20P645",55,0)
. S IBCNTCS=$$RSCS(IBFN,IBCPNM,$P(RXDT,U))
"RTN","IB20P645",56,0)
. D MES^XPDUTL(" Total Reasonable Charge Set"_$S(IBCNTCS=1:" ",1:"s ")_IBCNTCS_" added to Rate Schedule "_$P(IBLN,U,1)_".")
"RTN","IB20P645",57,0)
D MES^XPDUTL(" Rate Schedules completed.")
"RTN","IB20P645",58,0)
Q ;ADDRS
"RTN","IB20P645",59,0)
;
"RTN","IB20P645",60,0)
UPDTRRS ; Update TRICARE and DOD Rate Schedules (363) to interagency
"RTN","IB20P645",61,0)
D MES^XPDUTL(" -> Updating TRICARE and DOD Rate Schedules for file 363 ...")
"RTN","IB20P645",62,0)
N IBA,IBCNT,IBI,IBLN,IBFN,IBRT,IBBS,IBCNTCS,IBDISP,IBJ,IBLNCS,IBCS,IBCSFN,IBADMIN,DD,DO
"RTN","IB20P645",63,0)
N DLAYGO,DIC,DIE,DA,DR,RXDT,X,Y,IBCPNM,IBEDT,IBNM,DIK,IBK
"RTN","IB20P645",64,0)
S IBCNT=0
"RTN","IB20P645",65,0)
F IBI=2:1 S IBLN=$P($T(TRSF+IBI),";;",2) Q:IBLN="END" I $E(IBLN)?1A D
"RTN","IB20P645",66,0)
. ;Check for problems
"RTN","IB20P645",67,0)
. S IBBS=$P(IBLN,U,4) I IBBS'="" S IBBS=$$MCCRUTL(IBBS,13) Q:'IBBS ;Billable service invalid
"RTN","IB20P645",68,0)
. S IBRT=$P(IBLN,U,2),IBRT=$O(^DGCR(399.3,"B",IBRT,0)) D Q:'IBRT
"RTN","IB20P645",69,0)
.. I 'IBRT D MSG(" **** Rate Type "_$P(IBLN,U,2)_" not defined, RS "_$P(IBLN,U,1)_" not created")
"RTN","IB20P645",70,0)
.. I +$P($G(^DGCR(399.3,+IBRT,0)),U,3) S IBRT=0 D MSG(" **** Rate Type "_$P(IBLN,U,2)_" not Active, RS "_$P(IBLN,U,1)_" not created")
"RTN","IB20P645",71,0)
. ;Locate existing entry.
"RTN","IB20P645",72,0)
. S Y=-1,IBNM=$P(IBLN,U),IBEDT=$P(IBLN,U,6)
"RTN","IB20P645",73,0)
. S IBJ=0 F S IBJ=$O(^IBE(363,"B",IBNM,IBJ)) Q:'IBJ D Q:Y>-1
"RTN","IB20P645",74,0)
. . I (IBNM'["RX"),(IBNM'["PHARM") S Y=IBJ Q ;Non RX Rate schedule
"RTN","IB20P645",75,0)
. . I $P(^IBE(363,IBJ,0),U,5)="" S Y=IBJ Q ;Empty RX Rate schedule, use it.
"RTN","IB20P645",76,0)
. . I ($P(^IBE(363,IBJ,0),U,5)=IBEDT) S Y=IBJ ;Correct Pharmacy rate schedule found
"RTN","IB20P645",77,0)
. Q:Y=-1 ; If no entry Quit
"RTN","IB20P645",78,0)
. ; Cleanly Remove existing Charge sets from the Rate Schedule.
"RTN","IB20P645",79,0)
. S IBK=0 F S IBK=$O(^IBE(363,IBJ,11,IBK)) Q:'IBK D
"RTN","IB20P645",80,0)
. . N X,Y,DA,DIK
"RTN","IB20P645",81,0)
. . S DA=IBK,DA(1)=IBJ S DIK="^IBE(363,"_DA(1)_",11,"
"RTN","IB20P645",82,0)
. . D ^DIK
"RTN","IB20P645",83,0)
. ;Update the Rate Schedule with IA info and add the new IA charge sets
"RTN","IB20P645",84,0)
. S IBFN=+IBJ,IBCNT=IBCNT+1
"RTN","IB20P645",85,0)
. S IBCPNM=$P(IBLN,U,5)
"RTN","IB20P645",86,0)
. S RXDT=$$RXDT(IBCPNM,IBEDT)
"RTN","IB20P645",87,0)
. S DR=".02////"_IBRT_";.03////"_$P(IBLN,U,3) I +IBBS S DR=DR_";.04////"_IBBS
"RTN","IB20P645",88,0)
. S DR=DR_";.05////"_$P(RXDT,U)
"RTN","IB20P645",89,0)
. I $P(RXDT,U,2) S DR=DR_";.06////"_$P(RXDT,U,2)
"RTN","IB20P645",90,0)
. I (($P(IBLN,U,1)["RX")!($P(IBLN,U,1)["PHARM")),($G(IBDISP)]"") S DR=DR_";1.01///"_IBDISP
"RTN","IB20P645",91,0)
. I (($P(IBLN,U,1)["RX")!($P(IBLN,U,1)["PHARM")),($G(IBADMIN)]"") S DR=DR_";10////"_IBADMIN
"RTN","IB20P645",92,0)
. S DIE="^IBE(363,",DA=+IBJ D ^DIE K DIE,DA,DR,X,Y
"RTN","IB20P645",93,0)
. S IBCNTCS=0
"RTN","IB20P645",94,0)
. ; Retrieve name of Charge Set to copy
"RTN","IB20P645",95,0)
. I IBRT="" D MSG(" **** Rate Type "_$P(IBLN,U,2)_" missing Charge Set Information, RS "_$P(IBLN,U,1)_" not created") Q
"RTN","IB20P645",96,0)
. ; add all Reasonable Charges Charge Sets to the Rate Schedule.
"RTN","IB20P645",97,0)
. S IBCNTCS=$$RSCS(IBFN,IBCPNM,$P(RXDT,U))
"RTN","IB20P645",98,0)
. D MES^XPDUTL(" Total Reasonable Charge Set"_$S(IBCNTCS=1:" ",1:"s ")_IBCNTCS_" added to Rate Schedule "_$P(IBLN,U,1)_".")
"RTN","IB20P645",99,0)
D MES^XPDUTL(" Rate Schedules completed.")
"RTN","IB20P645",100,0)
Q ;UPDTRRS
"RTN","IB20P645",101,0)
;
"RTN","IB20P645",102,0)
RTIN ; Inactivate the DOD SNF Rate Schedules to prevent duplicate charges
"RTN","IB20P645",103,0)
D MES^XPDUTL(" -> Inactivating the DOD SNF Rate Schedules ...")
"RTN","IB20P645",104,0)
N IBA,IBCNT,IBI,IBLN,IBFN,IBRT,IBBS,IBCNTCS,IBDISP,IBJ,IBLNCS,IBCS,IBCSFN,IBADMIN,DD,DO
"RTN","IB20P645",105,0)
N DLAYGO,DIC,DIE,DA,DR,RXDT,X,Y,IBCPNM,IBEDT,IBNM,DIK,IBK
"RTN","IB20P645",106,0)
S IBCNT=0
"RTN","IB20P645",107,0)
F IBI=1:1 S IBLN=$P($T(RTINDATA+IBI),";;",2) Q:IBLN="END" D
"RTN","IB20P645",108,0)
. ;Locate existing entry.
"RTN","IB20P645",109,0)
. S IBNM=$P(IBLN,U)
"RTN","IB20P645",110,0)
. S IBJ=0,IBJ=$O(^IBE(363,"B",IBNM,IBJ))
"RTN","IB20P645",111,0)
. Q:'IBJ
"RTN","IB20P645",112,0)
. ;Update the Rate Schedule an INACTIVE Date
"RTN","IB20P645",113,0)
. S IBFN=+IBJ,IBCNT=IBCNT+1
"RTN","IB20P645",114,0)
. S DR=".06////"_$P(IBLN,U,2)
"RTN","IB20P645",115,0)
. S DIE="^IBE(363,",DA=+IBJ D ^DIE K DIE,DA,DR,X,Y
"RTN","IB20P645",116,0)
. S IBCNTCS=0
"RTN","IB20P645",117,0)
D MES^XPDUTL(" DOD Rate Schedules inactivated.")
"RTN","IB20P645",118,0)
Q
"RTN","IB20P645",119,0)
;
"RTN","IB20P645",120,0)
RSCS(IBFN,IBCPNM,RXDT) ; add existing Charge Sets to FR
"RTN","IB20P645",121,0)
; copy the Charge Sets from the corresponding RI RS (v2)
"RTN","IB20P645",122,0)
; IBFN - Rate Schedule IEN
"RTN","IB20P645",123,0)
; IBCPNM - Charge Set to copy
"RTN","IB20P645",124,0)
; RXDT - last effective date of charge set being copied.
"RTN","IB20P645",125,0)
N IBCNT,IBNRS,IBRSNM,IBTY,IBVDT,IBCOPY,IBCS,IBCS0,IBXFN,IBCSFN,IBCSNM,IBCSAA,IBNAME
"RTN","IB20P645",126,0)
S (IBCNT,IBCOPY)=0
"RTN","IB20P645",127,0)
S IBNRS=$G(^IBE(363,+$G(IBFN),0)),IBRSNM=$P(IBNRS,"^",1)
"RTN","IB20P645",128,0)
S IBTY=$P(IBNRS,"^",3)
"RTN","IB20P645",129,0)
S IBVDT=RXDT
"RTN","IB20P645",130,0)
;Q:IBVDT="" 0
"RTN","IB20P645",131,0)
S IBCOPY=+$$RSEXISTS(IBVDT,IBCPNM)
"RTN","IB20P645",132,0)
I 'IBCOPY G RSCSQ
"RTN","IB20P645",133,0)
I +$P($G(^IBE(363,+IBCOPY,0)),U,3)=IBTY D
"RTN","IB20P645",134,0)
. S IBXFN=0 F S IBXFN=$O(^IBE(363,IBCOPY,11,IBXFN)) Q:'IBXFN D
"RTN","IB20P645",135,0)
.. S IBCS=$G(^IBE(363,IBCOPY,11,IBXFN,0)),IBCSFN=+IBCS
"RTN","IB20P645",136,0)
.. I +$$RSCSFILE(IBFN,$P($G(^IBE(363.1,IBCSFN,0)),U,1),$P(IBCS,U,2)) S IBCNT=IBCNT+1
"RTN","IB20P645",137,0)
RSCSQ Q IBCNT
"RTN","IB20P645",138,0)
;
"RTN","IB20P645",139,0)
;
"RTN","IB20P645",140,0)
RSCSFILE(IBFN,IBCSNM,IBCSAA) ; Add Charge Set to a Rate Schedule
"RTN","IB20P645",141,0)
N IBX,DD,DO,DLAYGO,DIC,DA,DR,X,Y,IBCSFN S IBX=0
"RTN","IB20P645",142,0)
I $G(^IBE(363,+$G(IBFN),0))="" G RSCSFQ
"RTN","IB20P645",143,0)
I $G(IBCSNM)="" G RSCSFQ
"RTN","IB20P645",144,0)
S IBCSFN=$O(^IBE(363.1,"B",IBCSNM,0)) I 'IBCSFN G RSCSFQ
"RTN","IB20P645",145,0)
I $O(^IBE(363,IBFN,11,"B",IBCSFN,0)) G RSCSFQ
"RTN","IB20P645",146,0)
S DLAYGO=363,DA(1)=+IBFN,DIC="^IBE(363,"_DA(1)_",11,",DIC(0)="L"
"RTN","IB20P645",147,0)
S X=IBCSNM,DIC("DR")=".02///"_$G(IBCSAA),DIC("P")="363.0011P"
"RTN","IB20P645",148,0)
D ^DIC S:+Y IBX=1
"RTN","IB20P645",149,0)
RSCSFQ Q IBX
"RTN","IB20P645",150,0)
;
"RTN","IB20P645",151,0)
;
"RTN","IB20P645",152,0)
RSEXISTS(IBVDT,IBNAME) ; return RS IFN if Rate Schedule exists for Effective Date
"RTN","IB20P645",153,0)
N IBX,IBRSFN,IBRS0 S IBX=0
"RTN","IB20P645",154,0)
S IBRSFN=0 F S IBRSFN=$O(^IBE(363,IBRSFN)) Q:'IBRSFN D I IBX Q
"RTN","IB20P645",155,0)
. S IBRS0=$G(^IBE(363,IBRSFN,0))
"RTN","IB20P645",156,0)
. I $P(IBRS0,U,1)=IBNAME,$P(IBRS0,U,5)=IBVDT S IBX=IBRSFN
"RTN","IB20P645",157,0)
Q IBX
"RTN","IB20P645",158,0)
;
"RTN","IB20P645",159,0)
MSG(X) ;
"RTN","IB20P645",160,0)
N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
"RTN","IB20P645",161,0)
S IBA(IBX)=$G(X)
"RTN","IB20P645",162,0)
Q ;MSG
"RTN","IB20P645",163,0)
;
"RTN","IB20P645",164,0)
MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
"RTN","IB20P645",165,0)
N IBX,IBY S IBY=""
"RTN","IB20P645",166,0)
I $G(X)'="" S IBX=0 F S IBX=$O(^DGCR(399.1,"B",X,IBX)) Q:'IBX I $P($G(^DGCR(399.1,IBX,0)),U,+$G(P)) S IBY=IBX
"RTN","IB20P645",167,0)
Q IBY
"RTN","IB20P645",168,0)
;
"RTN","IB20P645",169,0)
RXDT(IBCPNM,IBEDT) ;Copy the active charge schedule from charge set being copied.
"RTN","IB20P645",170,0)
; update Fee information if Pharmacy.
"RTN","IB20P645",171,0)
N IBEFLG,IBD
"RTN","IB20P645",172,0)
S IBEDT=$G(IBEDT) ; Set to NULL if not passed in
"RTN","IB20P645",173,0)
S IBCS=""
"RTN","IB20P645",174,0)
;If no Effective Date sent, get the latest entry.
"RTN","IB20P645",175,0)
I IBEDT="" S IBCS=$O(^IBE(363,"B",IBCPNM,IBCS),-1)
"RTN","IB20P645",176,0)
;If Effective date sent, loop through the entries to find the entry
"RTN","IB20P645",177,0)
; with the correct effective date.
"RTN","IB20P645",178,0)
I (IBEDT=3150101),(IBCPNM="TR-RX") S IBEDT=3150220 ; FOR TR-PHARM 2015 populating only
"RTN","IB20P645",179,0)
I IBEDT'="" D
"RTN","IB20P645",180,0)
. S IBEFLG=0
"RTN","IB20P645",181,0)
. F S IBCS=$O(^IBE(363,"B",IBCPNM,IBCS),-1) Q:'IBCS D Q:IBEFLG
"RTN","IB20P645",182,0)
.. S IBD=$G(^IBE(363,IBCS,0))
"RTN","IB20P645",183,0)
.. I $P(IBD,U,5)=IBEDT S IBEFLG=1
"RTN","IB20P645",184,0)
Q:IBCS="" ""
"RTN","IB20P645",185,0)
S IBCS0=^IBE(363,IBCS,0)
"RTN","IB20P645",186,0)
I (IBCPNM["RX")!(IBCPNM["PHARM") S IBDISP=$P($G(^IBE(363,IBCS,1)),U,1),IBADMIN=$G(^IBE(363,IBCS,10))
"RTN","IB20P645",187,0)
Q $P(IBCS0,U,5,6) ;return effective and end dates
"RTN","IB20P645",188,0)
;
"RTN","IB20P645",189,0)
RSF ;Rate Schedules (363) for Community Care No Fault Rate Types and 2019 Pharmacy
"RTN","IB20P645",190,0)
;;Rate Schedule Name^Rate Type^Bill Type^Billable Service^Rate Schedule to copy for Charge Sets
"RTN","IB20P645",191,0)
;;CCC-NF-INPT^CHOICE NO-FAULT AUTO^1^^RI-INPT
"RTN","IB20P645",192,0)
;;CCC-NF-SNF^CHOICE NO-FAULT AUTO^1^SKILLED NURSING^RI-SNF
"RTN","IB20P645",193,0)
;;CCC-NF-OPT^CHOICE NO-FAULT AUTO^3^^RI-OPT
"RTN","IB20P645",194,0)
;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^RI-RX^3140101
"RTN","IB20P645",195,0)
;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^RI-RX^3150101
"RTN","IB20P645",196,0)
;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^RI-RX^3160101
"RTN","IB20P645",197,0)
;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^RI-RX^3170101
"RTN","IB20P645",198,0)
;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^RI-RX^3180101
"RTN","IB20P645",199,0)
;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^RI-RX^3190101
"RTN","IB20P645",200,0)
;;CC-NF-INPT^CC NO-FAULT AUTO^1^^RI-INPT
"RTN","IB20P645",201,0)
;;CC-NF-SNF^CC NO-FAULT AUTO^1^SKILLED NURSING^RI-SNF
"RTN","IB20P645",202,0)
;;CC-NF-OPT^CC NO-FAULT AUTO^3^^RI-OPT
"RTN","IB20P645",203,0)
;;CC-NF-RX^CC NO-FAULT AUTO^3^^RI-RX^3140101
"RTN","IB20P645",204,0)
;;CC-NF-RX^CC NO-FAULT AUTO^3^^RI-RX^3150101
"RTN","IB20P645",205,0)
;;CC-NF-RX^CC NO-FAULT AUTO^3^^RI-RX^3160101
"RTN","IB20P645",206,0)
;;CC-NF-RX^CC NO-FAULT AUTO^3^^RI-RX^3170101
"RTN","IB20P645",207,0)
;;CC-NF-RX^CC NO-FAULT AUTO^3^^RI-RX^3180101
"RTN","IB20P645",208,0)
;;CC-NF-RX^CC NO-FAULT AUTO^3^^RI-RX^3190101
"RTN","IB20P645",209,0)
;;CCN-NF-INPT^CCN NO-FAULT AUTO^1^^RI-INPT
"RTN","IB20P645",210,0)
;;CCN-NF-SNF^CCN NO-FAULT AUTO^1^SKILLED NURSING^RI-SNF
"RTN","IB20P645",211,0)
;;CCN-NF-OPT^CCN NO-FAULT AUTO^3^^RI-OPT
"RTN","IB20P645",212,0)
;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^RI-RX^3140101
"RTN","IB20P645",213,0)
;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^RI-RX^3150101
"RTN","IB20P645",214,0)
;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^RI-RX^3160101
"RTN","IB20P645",215,0)
;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^RI-RX^3170101
"RTN","IB20P645",216,0)
;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^RI-RX^3180101
"RTN","IB20P645",217,0)
;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^RI-RX^3190101
"RTN","IB20P645",218,0)
;;CCC-RI-RX^CHOICE REIMB INS^3^^RI-RX^3190101
"RTN","IB20P645",219,0)
;;CC-RI-RX^CC REIMB INS^3^^RI-RX^3190101
"RTN","IB20P645",220,0)
;;CCN-RI-RX^CCN REIMB INS^3^^RI-RX^3190101
"RTN","IB20P645",221,0)
;;CC-DOD-RX^CC MTF REIMB INS^3^^RI-RX^3190101
"RTN","IB20P645",222,0)
;;CCC-TF-RX^CHOICE TORT FEASOR^3^^TF-RX^3190101
"RTN","IB20P645",223,0)
;;CC-TF-RX^CC TORT FEASOR^3^^TF-RX^3190101
"RTN","IB20P645",224,0)
;;CCN-TF-RX^CCN TORT FEASOR^3^^TF-RX^3190101
"RTN","IB20P645",225,0)
;;CCC-WC-RX^CHOICE WORKERS' COMP^3^^WC-RX^3190101
"RTN","IB20P645",226,0)
;;CC-WC-RX^CC WORKERS' COMP^3^^WC-RX^3190101
"RTN","IB20P645",227,0)
;;CCN-WC-RX^CCN WORKERS' COMP^3^^WC-RX^3190101
"RTN","IB20P645",228,0)
;;TR-PHARM^TRICARE PHARMACY^3^^TR-RX^3190101
"RTN","IB20P645",229,0)
;;END
"RTN","IB20P645",230,0)
TRSF ;New Rate Schedules (363) for the new DOD and TRICARE Rate Types
"RTN","IB20P645",231,0)
;;DOD-DIS EXAM-OPT^DOD DISABILITY EVALUATION^3^OUTPATIENT VISIT^RI-OPT
"RTN","IB20P645",232,0)
;;DOD-SCI-INPT^DOD SPINAL CORD INJURY^1^INPATIENT^IA-INPT
"RTN","IB20P645",233,0)
;;DOD-SCI-OPT^DOD SPINAL CORD INJURY^3^OUTPATIENT VISIT^RI-OPT
"RTN","IB20P645",234,0)
;;DOD-TBI-INPT^DOD TRAUMATIC BRAIN INJURY^1^INPATIENT^IA-INPT
"RTN","IB20P645",235,0)
;;DOD-TBI-OPT^DOD TRAUMATIC BRAIN INJURY^3^OUTPATIENT VISIT^RI-OPT
"RTN","IB20P645",236,0)
;;DOD-BR-INPT^DOD BLIND REHABILITATION^1^INPATIENT^IA-INPT
"RTN","IB20P645",237,0)
;;DOD-BR-OPT^DOD BLIND REHABILITATION^3^OUTPATIENT VISIT^RI-OPT
"RTN","IB20P645",238,0)
;;TR-DENTAL^TRICARE DENTAL^3^OUTPATIENT VISIT^RI-OPT
"RTN","IB20P645",239,0)
;;TR-PHARM^TRICARE PHARMACY^3^^TR-RX^3140101
"RTN","IB20P645",240,0)
;;TR-PHARM^TRICARE PHARMACY^3^^TR-RX^3150101
"RTN","IB20P645",241,0)
;;TR-PHARM^TRICARE PHARMACY^3^^TR-RX^3160101
"RTN","IB20P645",242,0)
;;TR-PHARM^TRICARE PHARMACY^3^^TR-RX^3170101
"RTN","IB20P645",243,0)
;;TR-PHARM^TRICARE PHARMACY^3^^TR-RX^3180101
"RTN","IB20P645",244,0)
;;END
"RTN","IB20P645",245,0)
RTINDATA ;Rate Schedules to set an inactive date on.
"RTN","IB20P645",246,0)
;;DOD-SCI-SNF^3031225
"RTN","IB20P645",247,0)
;;DOD-TBI-SNF^3031225
"RTN","IB20P645",248,0)
;;DOD-BR-SNF^3031225
"RTN","IB20P645",249,0)
;;END
"RTN","IB20P645",250,0)
CORACT ; Add new ACTION TYPE ENTRIES (350.1)
"RTN","IB20P645",251,0)
;
"RTN","IB20P645",252,0)
D MES^XPDUTL(" -> Updating the CC RX Eligibility Logic fields ...")
"RTN","IB20P645",253,0)
N IBI,IBJ,IBLN
"RTN","IB20P645",254,0)
N X,Y,DIE,DA,DR,DTOUT
"RTN","IB20P645",255,0)
N IBIEN,IBLAST,IBBEG,IBEND
"RTN","IB20P645",256,0)
N IBEL,IBEL1,IBEL2,IBEL3
"RTN","IB20P645",257,0)
;
"RTN","IB20P645",258,0)
; Correct the Eligibility Logic
"RTN","IB20P645",259,0)
S IBEL1="S X=0,X1="_$C(34)_$C(34)_",X2="_$C(34)_$C(34)
"RTN","IB20P645",260,0)
S IBEL2=" G:'$D(VAEL) 1^IBAERR I VAEL(4),'+VAEL(3),'IBDOM,'$$RXEXMT^IBARXEU0(DFN,DT) "
"RTN","IB20P645",261,0)
S IBEL3="S X=1,X2=$P(^IBE(350.1,DA,0),"_$C(34)_"^"_$C(34)_",4) D COST^IBAUTL"
"RTN","IB20P645",262,0)
S IBEL=IBEL1_IBEL2_IBEL3
"RTN","IB20P645",263,0)
;
"RTN","IB20P645",264,0)
; Store in affected CC RX Action Types
"RTN","IB20P645",265,0)
F IBI=1:1 S IBLN=$P($T(ACTDAT+IBI),";;",2) Q:IBLN="END" I $E(IBLN)?1A D
"RTN","IB20P645",266,0)
. ;Locate existing entry.
"RTN","IB20P645",267,0)
. S IBNM=$P(IBLN,U),IBEDT=$P(IBLN,U,6)
"RTN","IB20P645",268,0)
. S IBJ=0 S IBJ=$O(^IBE(350.1,"B",IBNM,IBJ))
"RTN","IB20P645",269,0)
. I +IBJ<1 K X,Y Q ;not found, exit
"RTN","IB20P645",270,0)
. S DR="40////"_IBEL
"RTN","IB20P645",271,0)
. S DIE="^IBE(350.1,",DA=+IBJ
"RTN","IB20P645",272,0)
. D ^DIE
"RTN","IB20P645",273,0)
D MES^XPDUTL(" Eligibility Logic updates completed.")
"RTN","IB20P645",274,0)
Q
"RTN","IB20P645",275,0)
;
"RTN","IB20P645",276,0)
ACTDAT ; Data for the new ACTION TYPE fields. (All categories will be updated)
"RTN","IB20P645",277,0)
;;CHOICE (RX) NEW
"RTN","IB20P645",278,0)
;;CC (RX) NEW
"RTN","IB20P645",279,0)
;;CCN (RX) NEW
"RTN","IB20P645",280,0)
;;CC MTF (RX) NEW
"RTN","IB20P645",281,0)
;;END
"RTN","IBARX")
0^3^B56596853
"RTN","IBARX",1,0)
IBARX ;ALB/AAS - INTEGRATED BILLING, PHARMACY COPAY INTERFACE;8/30/17 3:42pm
"RTN","IBARX",2,0)
;;2.0;INTEGRATED BILLING;**101,150,156,168,186,237,308,563,604,645**;21-MAR-94;Build 14
"RTN","IBARX",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","IBARX",4,0)
;
"RTN","IBARX",5,0)
XTYPE ; - tag XTYPE - returns array of billable action types for service
"RTN","IBARX",6,0)
; - see IBARXDOC for documentation
"RTN","IBARX",7,0)
;
"RTN","IBARX",8,0)
X1 K Y D INSTAL I '$T S Y=-1 Q
"RTN","IBARX",9,0)
N I,J,X1,X2,DA,DFN,IBCAP S Y=1,IBSAVX=X,IBTAG=1,IBWHER=5
"RTN","IBARX",10,0)
;
"RTN","IBARX",11,0)
D CHKX^IBAUTL G:+Y<1 XTYPEQ
"RTN","IBARX",12,0)
;
"RTN","IBARX",13,0)
I '$D(^IBE(350.1,"ANEW",IBSERV,1,1)) D S Y=-1 G XTYPEQ
"RTN","IBARX",14,0)
.I '$D(ZTQUEUED) W !!,*7,"WARNING: Pharmacy Copay not working,",!," Check IB SERVICE/SECTION in Pharmacy Site File.",!!
"RTN","IBARX",15,0)
.D E3^IBAERR
"RTN","IBARX",16,0)
;
"RTN","IBARX",17,0)
N X D ELIG^VADPT,INP^VADPT,DOM S Y=1
"RTN","IBARX",18,0)
;IB*2.0*645 - Modified copay check to include Community Care Action Types with Fee Basis.
"RTN","IBARX",19,0)
F I=0:0 S I=$O(^IBE(350.1,"ANEW",IBSERV,1,I)) Q:'I I $D(^IBE(350.1,I,40)),$$NFEECCRX($P(^IBE(350.1,I,0),U,1)) S DA=I X ^IBE(350.1,DA,40) S Y(DA,X)=I_"^"_X1_"^"_X2 S:'$G(IBCAP) IBCAP=X
"RTN","IBARX",20,0)
;
"RTN","IBARX",21,0)
I $G(IBCAP),$G(DFN) D NEW^IBARXPFS(DFN)
"RTN","IBARX",22,0)
;
"RTN","IBARX",23,0)
XTYPEQ K X1,X2,IBSERV,VAEL,VA,VAERR,IBDOM,VAIN,IBSAVX,IBTAG,IBWHER
"RTN","IBARX",24,0)
;
"RTN","IBARX",25,0)
Q
"RTN","IBARX",26,0)
;
"RTN","IBARX",27,0)
DOM S IBDOM=0 I $D(VAIN(4)),$D(^DIC(42,+VAIN(4),0)),$P(^(0),"^",3)="D" S IBDOM=1
"RTN","IBARX",28,0)
Q
"RTN","IBARX",29,0)
NEW ; - process new/renew/refill rx for charges
"RTN","IBARX",30,0)
; - see IBARXDOC for documentation
"RTN","IBARX",31,0)
;
"RTN","IBARX",32,0)
N1 K Y,IBSAVX D INSTAL I '$T S Y=-1 Q
"RTN","IBARX",33,0)
N I,J,X1,X2,DA,DFN,IBEXMP,IBEFDT
"RTN","IBARX",34,0)
S IBWHER=1,IBSAVX=X,Y=1,IBTAG=2 D CHKX^IBAUTL I +Y<1 G NEWQ
"RTN","IBARX",35,0)
I $D(X)<11 S Y="-1^IB010" G NEWQ
"RTN","IBARX",36,0)
S J="" F S J=$O(X(J)) Q:J="" S IBSAVX(J)=X(J)
"RTN","IBARX",37,0)
D ARPARM^IBAUTL I +Y<1 G NEWQ
"RTN","IBARX",38,0)
;
"RTN","IBARX",39,0)
; -- check rx exemption in case refill is exempt
"RTN","IBARX",40,0)
; -- if exempt set amount to each rx and total to zero
"RTN","IBARX",41,0)
; 1= exempt, 0= non-exempt, -1=copay off (manila)
"RTN","IBARX",42,0)
S IBEXMP=+$$RXEXMT^IBARXEU0(DFN,DT)
"RTN","IBARX",43,0)
I IBEXMP'=0 D S Y="1^0" G NEWQ
"RTN","IBARX",44,0)
.S IBJ=""
"RTN","IBARX",45,0)
.; changed return value 6th piece is the exempt flag
"RTN","IBARX",46,0)
.F S IBJ=$O(IBSAVX(IBJ)) Q:IBJ="" S $P(Y(IBJ),"^",6)=IBEXMP
"RTN","IBARX",47,0)
.Q
"RTN","IBARX",48,0)
;
"RTN","IBARX",49,0)
; check to see if billing has been tracked across facilities before,
"RTN","IBARX",50,0)
; if not, start now.
"RTN","IBARX",51,0)
D TRACK^IBARXMN(DFN) I +Y<1 G NEWQ
"RTN","IBARX",52,0)
;
"RTN","IBARX",53,0)
S IBTOTL=0
"RTN","IBARX",54,0)
D BILLNO^IBAUTL I +Y<1 G NEWQ
"RTN","IBARX",55,0)
;
"RTN","IBARX",56,0)
S IBTOTL=0,IBJ="",IBSEQNO=$P(^IBE(350.1,IBATYP,0),"^",5) I 'IBSEQNO S Y="-1^IB023" G NEWQ
"RTN","IBARX",57,0)
F S IBJ=$O(IBSAVX(IBJ)) Q:IBJ="" S IBX=IBSAVX(IBJ) D RX^IBARX1
"RTN","IBARX",58,0)
I +Y<1 G NEWQ
"RTN","IBARX",59,0)
;
"RTN","IBARX",60,0)
; changed to only do if charge exists
"RTN","IBARX",61,0)
D:IBTOTL ^IBAFIL
"RTN","IBARX",62,0)
;
"RTN","IBARX",63,0)
S IBJ="" F S IBJ=$O(IBSAVY(IBJ)) Q:IBJ="" S Y(IBJ)=IBSAVY(IBJ)
"RTN","IBARX",64,0)
S:+Y>0 Y="1^"_IBTOTL S X=IBSAVX
"RTN","IBARX",65,0)
;
"RTN","IBARX",66,0)
NEWQ D:+Y<1 ^IBAERR
"RTN","IBARX",67,0)
D END
"RTN","IBARX",68,0)
Q
"RTN","IBARX",69,0)
;
"RTN","IBARX",70,0)
INSTAL I $S($D(^IBE(350.9,1,0)):1,$D(^IB(0)):1,1:0)
"RTN","IBARX",71,0)
Q
"RTN","IBARX",72,0)
;
"RTN","IBARX",73,0)
CANCEL ; - cancel charges for a rx
"RTN","IBARX",74,0)
; - see IBARXDOC for documentation
"RTN","IBARX",75,0)
;
"RTN","IBARX",76,0)
C1 K Y,IBSAVX N I,J,X1,X2,DA,DFN I '$G(IBUPDATE) N IBCAP,IBAMP,IBSAVXMC
"RTN","IBARX",77,0)
S IBWHER=1,IBSAVX=X,Y=1,IBTAG=3 D CHKX^IBAUTL I +Y<1 G CANQ
"RTN","IBARX",78,0)
I $D(X)<11 S Y="-1^IB010" G CANQ
"RTN","IBARX",79,0)
S J="" F S J=$O(X(J)) Q:J="" S IBSAVX(J)=X(J)
"RTN","IBARX",80,0)
D ARPARM^IBAUTL I +Y<1 G CANQ
"RTN","IBARX",81,0)
;
"RTN","IBARX",82,0)
S IBJ="",IBTOTL=0
"RTN","IBARX",83,0)
F S IBJ=$O(IBSAVX(IBJ)) Q:IBJ="" S IBX=IBSAVX(IBJ) D CANRX^IBARX1 I +IBY(IBJ)'<1 D ^IBAFIL:$P(IBND,"^",5)'=8 I +Y<1 S IBY(IBJ)=Y
"RTN","IBARX",84,0)
I +Y<1 S IBT="",IBY=Y,IBM="" F S IBM=$O(IBY(IBM)) Q:IBM="" I +IBY(IBM)<1 S Y=IBY(IBM) D ^IBAERR S Y(IBM)=IBY(IBM),Y=IBY
"RTN","IBARX",85,0)
CANQ D:+Y<1 ^IBAERR:('$D(IBT))
"RTN","IBARX",86,0)
S X=IBSAVX
"RTN","IBARX",87,0)
M IBSAVXMC=Y
"RTN","IBARX",88,0)
D END
"RTN","IBARX",89,0)
;
"RTN","IBARX",90,0)
; now that I have cancelled lets see if there are some to be billed
"RTN","IBARX",91,0)
I '$G(IBUPDATE),$D(IBCAP)>10 D QCAN^IBARXMC(DFN,.IBCAP,.IBSAVXMC)
"RTN","IBARX",92,0)
;S IBD=0 F S IBD=$O(IBCAP(IBD)) Q:IBD<1 D CANCEL^IBARXMC(DFN,IBD)
"RTN","IBARX",93,0)
Q
"RTN","IBARX",94,0)
;
"RTN","IBARX",95,0)
UPDATE ; - will cancel current open charge and create updated entry
"RTN","IBARX",96,0)
; - see IBARXDOC for documentation
"RTN","IBARX",97,0)
;
"RTN","IBARX",98,0)
U1 K Y,IBSAVX N I,J,X1,X2,DA,DFN,IBEXMP,IBUPDATE,IBCAP,IBEFDT,IBAMP,IBSAVXMC
"RTN","IBARX",99,0)
S IBUPDATE=1 ; new flag so we know we are updating
"RTN","IBARX",100,0)
S IBWHER=1,IBSAVX=X,Y=1,IBTAG=4 D CHKX^IBAUTL I +Y<1 G UPDQ
"RTN","IBARX",101,0)
S IBSAVXU=IBSAVX
"RTN","IBARX",102,0)
I $D(X)<11 S Y="-1^IB010" G UPDQ
"RTN","IBARX",103,0)
S J="" F S J=$O(X(J)) Q:J="" S IBSAVXU(J)=X(J),X(J)=$P(X(J),"^",3,4) D EFDT^IBARXMU($P(X(J),"^"),.IBEFDT)
"RTN","IBARX",104,0)
;
"RTN","IBARX",105,0)
D CANCEL
"RTN","IBARX",106,0)
U2 K X
"RTN","IBARX",107,0)
S X=IBSAVXU S J="" F S J=$O(IBSAVXU(J)) Q:J="" S X(J)=$P(IBSAVXU(J),"^",1,3)
"RTN","IBARX",108,0)
S IBSAVX=X,Y=1,IBTAG=4 D CHKX^IBAUTL I +Y<1 G UPDQ
"RTN","IBARX",109,0)
D ARPARM^IBAUTL I +Y<1 G UPDQ
"RTN","IBARX",110,0)
;
"RTN","IBARX",111,0)
; -- check rx exemption in case refill is exempt
"RTN","IBARX",112,0)
; -- if exempt set amount to each rx and total to zero
"RTN","IBARX",113,0)
S IBEXMP=+$$RXEXMT^IBARXEU0(DFN,DT)
"RTN","IBARX",114,0)
I IBEXMP'=0 D S Y="1^0" G UPDQ
"RTN","IBARX",115,0)
.; changed return value 6th piece is the exempt flag
"RTN","IBARX",116,0)
.S IBJ="" F S IBJ=$O(IBSAVXU(IBJ)) Q:IBJ="" S $P(Y(IBJ),"^",6)=IBEXMP
"RTN","IBARX",117,0)
.Q
"RTN","IBARX",118,0)
;
"RTN","IBARX",119,0)
S IBATYP=$P(^IBE(350.1,+IBATYP,0),"^",7) I '$D(^IBE(350.1,+IBATYP,0)) S Y="-1^IB008" G UPDQ ;update type action
"RTN","IBARX",120,0)
;
"RTN","IBARX",121,0)
D BILLNO^IBAUTL G:+Y<1 UPDQ
"RTN","IBARX",122,0)
S IBTOTL=0,IBNOS="",IBSEQNO=$P(^IBE(350.1,IBATYP,0),"^",5) I 'IBSEQNO S Y="-1^IB023" G UPDQ
"RTN","IBARX",123,0)
S IBJ="" F S IBJ=$O(IBSAVXU(IBJ)) Q:IBJ="" S IBX=IBSAVXU(IBJ) S:$D(IBEFDT(+$P(IBX,"^",3))) IBEFDT=IBEFDT(+$P(IBX,"^",3)) D UCHPAR,RX^IBARX1:'$D(IBSAVY(IBJ)) S IBEFDT=0
"RTN","IBARX",124,0)
D ^IBAFIL
"RTN","IBARX",125,0)
;
"RTN","IBARX",126,0)
S IBJ="" F S IBJ=$O(IBSAVY(IBJ)) Q:IBJ="" S Y(IBJ)=IBSAVY(IBJ),$P(Y(IBJ),"^",6)=+$G(IBEXMP) S:+Y(IBJ)<1 Y=Y(IBJ)
"RTN","IBARX",127,0)
S:+Y>0 Y="1^"_IBTOTL S X=IBSAVXU
"RTN","IBARX",128,0)
;
"RTN","IBARX",129,0)
; now that I have the update done lets see if there are some to be billed
"RTN","IBARX",130,0)
I $D(IBCAP)>10 D QCAN^IBARXMC(DFN,.IBCAP,.IBSAVXMC)
"RTN","IBARX",131,0)
;S IBD=0 F S IBD=$O(IBCAP(IBD)) Q:IBD<1 D CANCEL^IBARXMC(DFN,IBD)
"RTN","IBARX",132,0)
;
"RTN","IBARX",133,0)
UPDQ D:+Y<1 ^IBAERR
"RTN","IBARX",134,0)
K IBSAVXU
"RTN","IBARX",135,0)
END K %,%H,%I,K,X1,X2,X3,IBSERV,IBATYP,IBAFY,IBDUZ,IBNOW,IBSAVX,IBTOTL,IBX,IBT,IBCHRG,IBDESC,IBFAC,IBIL,IBN,IBNOS,IBSEQNO,IBSITE,IBTAG,IBTRAN,IBCRES,IBJ,IBLAST,IBND,IBY,IBPARNT,IBUNIT,IBJ,IBARTYP,IBI,IBSAVY,IBWHER,IBTIER
"RTN","IBARX",136,0)
Q
"RTN","IBARX",137,0)
UCHPAR ; Check that IB action and its parent exist.
"RTN","IBARX",138,0)
S IBPARNT=$P(IBX,"^",3)
"RTN","IBARX",139,0)
I '$D(^IB(+IBPARNT,0)) S IBSAVY(IBJ)="-1^IB021" G UCHPARQ
"RTN","IBARX",140,0)
S IBPARNT=$P(^IB(+IBPARNT,0),"^",9)
"RTN","IBARX",141,0)
I '$D(^IB(+IBPARNT,0)) S IBSAVY(IBJ)="-1^IB027"
"RTN","IBARX",142,0)
UCHPARQ Q
"RTN","IBARX",143,0)
;
"RTN","IBARX",144,0)
STATUS(X) ; returns the status of a transaction in 350
"RTN","IBARX",145,0)
; - see IBARXDOC for documentation
"RTN","IBARX",146,0)
;
"RTN","IBARX",147,0)
N Y S Y=$G(^IB(X,0))
"RTN","IBARX",148,0)
Q +$S($P(Y,"^",5)=10:2,1:$P($G(^IBE(350.1,+$P(Y,"^",3),0)),"^",5))
"RTN","IBARX",149,0)
;
"RTN","IBARX",150,0)
CANIBAM ; used by pso to cancel a 354.71 transaction
"RTN","IBARX",151,0)
; - see IBARXDOC for documentation
"RTN","IBARX",152,0)
N IBZ,IBXX,IBYY,IBCAP
"RTN","IBARX",153,0)
M IBXX=X
"RTN","IBARX",154,0)
S IBXX=0 F S IBXX=$O(IBXX(IBXX)) Q:IBXX="" D
"RTN","IBARX",155,0)
. N IBY
"RTN","IBARX",156,0)
. S IBZ=$G(^IBAM(354.71,+IBXX(IBXX),0))
"RTN","IBARX",157,0)
. I $P(IBZ,"^",4) S IBYY(IBXX)="-1^Transaction has been billed" Q
"RTN","IBARX",158,0)
. I $P(IBZ,"^",5)="Y"!($P(IBZ,"^",5)="X") S IBYY(IBXX)="-1^Transaction already cancelled" Q
"RTN","IBARX",159,0)
. S IBZ=$$CANCEL^IBARXMN($P(IBZ,"^",2),+IBXX(IBXX),.IBY,$P(IBXX(IBXX),"^",2))
"RTN","IBARX",160,0)
. S IBYY(IBXX)=$S($P($G(IBY),"^")=-1:IBY,1:IBZ)
"RTN","IBARX",161,0)
K Y M Y=IBYY
"RTN","IBARX",162,0)
Q
"RTN","IBARX",163,0)
;
"RTN","IBARX",164,0)
UPIBAM ; - will cancel current potential charge and create updated entry
"RTN","IBARX",165,0)
; - see IBARXDOC for documentation
"RTN","IBARX",166,0)
;
"RTN","IBARX",167,0)
N IBXX,IBYY,IBWHER,IBTAG,IBZ,IBX,IBY,IBSAVX,IBA,IBAM,IBATYP,IBCAP,IBDESC,IBDUZ,IBSERV,IBTCH
"RTN","IBARX",168,0)
M IBXX=X
"RTN","IBARX",169,0)
S IBA=$O(X("")) I IBA="" S (Y)="-1^Invalid Subscript in X" Q
"RTN","IBARX",170,0)
S IBWHER=1,Y=1,IBTAG=4,IBSAVX=X D CHKX^IBAUTL I +Y<1 S Y(IBA)=Y Q
"RTN","IBARX",171,0)
S IBZ=$G(^IBAM(354.71,+$P($G(IBXX(IBA)),"^",3),0))
"RTN","IBARX",172,0)
;
"RTN","IBARX",173,0)
; check out the transaction sent
"RTN","IBARX",174,0)
I 'IBZ S (Y,Y(IBA))="-1^Not a valid transaction number" Q
"RTN","IBARX",175,0)
I $P(IBZ,"^",4) S (Y,Y(IBA))="-1^Transaction has been billed" Q
"RTN","IBARX",176,0)
I $P(IBZ,"^",5)="Y"!($P(IBZ,"^",5)="X") S (Y,Y(IBA))="-1^Transaction already cancelled" Q
"RTN","IBARX",177,0)
;
"RTN","IBARX",178,0)
; cancel that transaction
"RTN","IBARX",179,0)
S IBX=$$CANCEL^IBARXMN($P(IBZ,"^",2),$P($G(IBXX(IBA)),"^",3),.Y,$P(IBXX(IBA),"^",4)) I +Y<1 S Y(IBA)=Y Q
"RTN","IBARX",180,0)
;
"RTN","IBARX",181,0)
; create the new updated transaction
"RTN","IBARX",182,0)
S IBX=IBXX(IBA) D BDESC^IBARX1 S IBATYP=$P(^IBE(350.1,+IBATYP,0),"^",7),DA=IBATYP D COST^IBAUTL S IBTCH=$P(IBX,"^",2)*X1
"RTN","IBARX",183,0)
S IBAM=$$ADD^IBARXMN($P(IBZ,"^",2),"^^"_$P(IBZ,"^",3)_"^^P^"_$P(IBXX(IBA),"^")_"^"_$P(IBXX(IBA),"^",2)_"^"_IBTCH_"^"_IBDESC_"^"_$$PARENT^IBARXMC($P(IBXX(IBA),"^",3))_"^0^"_IBTCH_"^"_(+$P($$SITE^IBARXMU,"^",3)),IBATYP)
"RTN","IBARX",184,0)
I IBAM<1 S (Y,Y(IBA))="-1^IB316" Q
"RTN","IBARX",185,0)
;
"RTN","IBARX",186,0)
S Y(IBA)=IBAM,Y=1
"RTN","IBARX",187,0)
;
"RTN","IBARX",188,0)
Q
"RTN","IBARX",189,0)
;
"RTN","IBARX",190,0)
;IB*2.0*645 - added routine NFEECCRX
"RTN","IBARX",191,0)
NFEECCRX(IBACTNM) ;Determine if the Action Type is a Non-Fee RX Action type for the co-payment indicator
"RTN","IBARX",192,0)
;
"RTN","IBARX",193,0)
;Input: IBACTNM Name of the Action Type from File 350.1, field 1
"RTN","IBARX",194,0)
;Output: 0 - Fee or Community Care RX copay or non RX
"RTN","IBARX",195,0)
; 1 - Non Fee Basis or Community Care RX Copay
"RTN","IBARX",196,0)
N IBFLG
"RTN","IBARX",197,0)
S IBFLG=1
"RTN","IBARX",198,0)
I IBACTNM'["RX" Q 0 ;Non RX Copay
"RTN","IBARX",199,0)
I IBACTNM["FEE" Q 0 ;Fee Basis NSC RX Copay
"RTN","IBARX",200,0)
I IBACTNM["CHOICE" Q 0 ;Choice RX Copay
"RTN","IBARX",201,0)
I IBACTNM["CC" Q 0 ;CC, CCN, or CC MTF RX Copays
"RTN","IBARX",202,0)
Q IBFLG ;Copay is NSC or SC RX
"RTN","IBOA32")
0^2^B8874260
"RTN","IBOA32",1,0)
IBOA32 ;ALB/CPM - PRINT ALL BILLS FOR A PATIENT (CON'T) ;28-JAN-92
"RTN","IBOA32",2,0)
;;2.0;INTEGRATED BILLING;**7,95,347,433,451,645**;21-MAR-94;Build 14
"RTN","IBOA32",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","IBOA32",4,0)
;
"RTN","IBOA32",5,0)
;MAP TO DGCRA32
"RTN","IBOA32",6,0)
;
"RTN","IBOA32",7,0)
; Print out IB Actions onto the list.
"RTN","IBOA32",8,0)
D:($Y>(IOSL-5)) HDR^IBOA31 Q:IBQUIT
"RTN","IBOA32",9,0)
N IBND,IBND1,X,IBX,IENS,IBRXN,IBRX,IBRF,IBRDT,IBPFLAG,IBIEN,IBTYPE
"RTN","IBOA32",10,0)
S IBND=$G(^IB($E(IBIFN,1,$L(IBIFN)-1),0)),IBND1=$G(^(1))
"RTN","IBOA32",11,0)
S (IBRXN,IBRX,IBRF,IBRDT,IBX)=0
"RTN","IBOA32",12,0)
I $P(IBND,"^",4)["52:" S IBRXN=$P($P(IBND,"^",4),":",2),IBRX=$P($P(IBND,"^",8),"-"),IBRF=$P($P(IBND,"^",4),":",3)
"RTN","IBOA32",13,0)
I IBRF>0 S IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,IBRF,52,.01)
"RTN","IBOA32",14,0)
E S IBRDT=$$FILE^IBRXUTL(+IBRXN,22),IBX=$$APPT^IBCU3(IBRDT,DFN)
"RTN","IBOA32",15,0)
; IB*2.0*451 - Check for EEOB on associated 3rd party bills and attach EOB indicator '%' if applicable
"RTN","IBOA32",16,0)
S IBPFLAG="" I $P(IBND,"^",11)'="" S IBPFLAG=$$IBEEOBCK^IBJDF41($P(IBND,"^",11),DFN) ; Pass AR BILL#, Pat ID
"RTN","IBOA32",17,0)
W !,IBPFLAG,$S($P(IBND,"^",11)]"":$P($P(IBND,"^",11),"-",2),$P(IBND,"^",5)=99:"",$P(IBND,"^",5)=10:"",1:"Pending")
"RTN","IBOA32",18,0)
; IB*2.0*451 - make space for EEOB indicator '%' next to the bill #
"RTN","IBOA32",19,0)
W ?9,$$DAT1^IBOUTL($S($P(IBND,"^",11)="":"",$P(IBND,"^",5)>2&($P(IBND,"^",5)'=99):$P(IBND1,"^",4)\1,1:""))
"RTN","IBOA32",20,0)
; Patch IB*2.0*645 - adding community care - action types
"RTN","IBOA32",21,0)
S IBIEN=$G(^IBE(350.1,+$P(IBND,"^",3),0))
"RTN","IBOA32",22,0)
S IBIEN=+$P(IBND,"^",3)
"RTN","IBOA32",23,0)
S IBTYPE=$$GETATYPE(IBIEN)
"RTN","IBOA32",24,0)
;W ?19,$E($P(IBTYPE," ",1,$L($P($P($G(^IBE(350.1,+$P(IBND,"^",3),0)),"^")," ",2,99)," ")-1),1,17)
"RTN","IBOA32",25,0)
W ?19,IBTYPE
"RTN","IBOA32",26,0)
W ?38,$E($S($P(IBND,"^",4)["350:":$E($P(IBND,"^",8),1,14),$P(IBND,"^",3)<7:"Rx:"_IBRX_$S(IBRF>0:"("_IBRF_")",1:""),$P(IBND1,"^",5):"CHAMPVA SUBSIST",1:"AUT MEANS TEST"),1,14)
"RTN","IBOA32",27,0)
W:IBX=1 ?54,"*"
"RTN","IBOA32",28,0)
W ?55,$$DAT1^IBOUTL(-IBDT)
"RTN","IBOA32",29,0)
W ?65,$$DAT1^IBOUTL($S(IBRXN>0:IBRDT,$P(IBND,"^",14):$P(IBND,"^",14),1:$P(IBND1,"^",2)\1))
"RTN","IBOA32",30,0)
W ?75,$$DAT1^IBOUTL($S($P(IBND,"^",15):$P(IBND,"^",15),1:$P(IBND1,"^",2)\1))
"RTN","IBOA32",31,0)
W ?90,"N/A",?95,$E($P($G(^IBE(350.21,+$P(IBND,"^",5),0)),"^",2),1,17)
"RTN","IBOA32",32,0)
Q
"RTN","IBOA32",33,0)
;
"RTN","IBOA32",34,0)
UTIL ; Gather all IB Actions for a patient.
"RTN","IBOA32",35,0)
N DATE,IBN,X,A,B,C,D,E,IBNX
"RTN","IBOA32",36,0)
S IBN=0 F S IBN=$O(^IB("C",DFN,IBN)) Q:'IBN S X=$G(^IB(IBN,0)) D:X
"RTN","IBOA32",37,0)
. I 'IBIBRX,$E($G(^IBE(350.1,+$P(X,"^",3),0)),1,3)="PSO" Q
"RTN","IBOA32",38,0)
. Q:$P(X,"^",8)["ADMISSION"
"RTN","IBOA32",39,0)
. Q:'$D(^IB("APDT",IBN))
"RTN","IBOA32",40,0)
. S (C,D)="",C=$O(^IB("APDT",IBN,C)),D=$O(^IB("APDT",IBN,C,D))
"RTN","IBOA32",41,0)
. S E=$P($G(^IB(D,0)),U,3)
"RTN","IBOA32",42,0)
. S A=$P($G(^IBE(350.1,E,0)),U,5)
"RTN","IBOA32",43,0)
. S IBNX=$S(A=2:$P($Q(^IB("APDT",IBN,C,D)),")",1),A=3:$P($Q(^IB("APDT",IBN,C,D)),")",1),1:IBN)
"RTN","IBOA32",44,0)
. I (A=2)!(A=3) D
"RTN","IBOA32",45,0)
.. I IBNX["[""" S IBNX="^"_$P(IBNX,"]",2)
"RTN","IBOA32",46,0)
. I $P(IBNX,",",4)>0 S IBNX=$P(IBNX,",",4)
"RTN","IBOA32",47,0)
. S DATE=$P($G(^IB(+$P(X,"^",16),0)),"^",17)
"RTN","IBOA32",48,0)
. S:'DATE DATE=$P($G(^IB(IBNX,1)),"^",5)
"RTN","IBOA32",49,0)
. S:'DATE DATE=$P($G(^IB(IBNX,1)),"^",2)\1
"RTN","IBOA32",50,0)
. S:DATE ^UTILITY($J,-DATE,IBNX_"X")=""
"RTN","IBOA32",51,0)
Q
"RTN","IBOA32",52,0)
;
"RTN","IBOA32",53,0)
GETATYPE(IBIEN) ; Patch IB*2.0*645 - added community care - action types
"RTN","IBOA32",54,0)
S IBTYPE=$P(^IBE(350.1,IBIEN,0),"^") I $E(IBTYPE,1,2)="DG" Q $E($P(IBTYPE," ",2,99),1,17)
"RTN","IBOA32",55,0)
I $E(IBTYPE,1,3)="PSO" Q $E($P(IBTYPE," ",2,99),1,17)
"RTN","IBOA32",56,0)
Q $E(IBTYPE,1,17)
"VER")
8.0^22.2
**END**
**END**