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 22, 2018@11:34:55
TEST
**KIDS**:IB*2.0*618^
**INSTALL NAME**
IB*2.0*618
"BLD",10661,0)
IB*2.0*618^INTEGRATED BILLING^0^3180522^y
"BLD",10661,4,0)
^9.64PA^350.1^1
"BLD",10661,4,350.1,0)
350.1
"BLD",10661,4,350.1,2,0)
^9.641^350.1^1
"BLD",10661,4,350.1,2,350.1,0)
IB ACTION TYPE (File-top level)
"BLD",10661,4,350.1,2,350.1,1,0)
^9.6411^.12^1
"BLD",10661,4,350.1,2,350.1,1,.12,0)
INACTIVE
"BLD",10661,4,350.1,222)
y^y^p^^^^n^^n
"BLD",10661,4,350.1,224)
"BLD",10661,4,"APDD",350.1,350.1)
"BLD",10661,4,"APDD",350.1,350.1,.12)
"BLD",10661,4,"B",350.1,350.1)
"BLD",10661,6.3)
18
"BLD",10661,"ABPKG")
n
"BLD",10661,"INIT")
POSTINIT^IB20P618
"BLD",10661,"KRN",0)
^9.67PA^779.2^20
"BLD",10661,"KRN",.4,0)
.4
"BLD",10661,"KRN",.401,0)
.401
"BLD",10661,"KRN",.402,0)
.402
"BLD",10661,"KRN",.403,0)
.403
"BLD",10661,"KRN",.5,0)
.5
"BLD",10661,"KRN",.84,0)
.84
"BLD",10661,"KRN",3.6,0)
3.6
"BLD",10661,"KRN",3.8,0)
3.8
"BLD",10661,"KRN",9.2,0)
9.2
"BLD",10661,"KRN",9.8,0)
9.8
"BLD",10661,"KRN",9.8,"NM",0)
^9.68A^7^5
"BLD",10661,"KRN",9.8,"NM",1,0)
IBP618B^^0^B104039647
"BLD",10661,"KRN",9.8,"NM",2,0)
IBP618A^^0^B84858209
"BLD",10661,"KRN",9.8,"NM",3,0)
IB20P618^^0^B134924268
"BLD",10661,"KRN",9.8,"NM",4,0)
IBECEA3^^0^B75927900
"BLD",10661,"KRN",9.8,"NM",7,0)
IBECEA33^^0^B23530923
"BLD",10661,"KRN",9.8,"NM","B","IB20P618",3)
"BLD",10661,"KRN",9.8,"NM","B","IBECEA3",4)
"BLD",10661,"KRN",9.8,"NM","B","IBECEA33",7)
"BLD",10661,"KRN",9.8,"NM","B","IBP618A",2)
"BLD",10661,"KRN",9.8,"NM","B","IBP618B",1)
"BLD",10661,"KRN",19,0)
19
"BLD",10661,"KRN",19.1,0)
19.1
"BLD",10661,"KRN",101,0)
101
"BLD",10661,"KRN",409.61,0)
409.61
"BLD",10661,"KRN",771,0)
771
"BLD",10661,"KRN",779.2,0)
779.2
"BLD",10661,"KRN",870,0)
870
"BLD",10661,"KRN",8989.51,0)
8989.51
"BLD",10661,"KRN",8989.52,0)
8989.52
"BLD",10661,"KRN",8994,0)
8994
"BLD",10661,"KRN","B",.4,.4)
"BLD",10661,"KRN","B",.401,.401)
"BLD",10661,"KRN","B",.402,.402)
"BLD",10661,"KRN","B",.403,.403)
"BLD",10661,"KRN","B",.5,.5)
"BLD",10661,"KRN","B",.84,.84)
"BLD",10661,"KRN","B",3.6,3.6)
"BLD",10661,"KRN","B",3.8,3.8)
"BLD",10661,"KRN","B",9.2,9.2)
"BLD",10661,"KRN","B",9.8,9.8)
"BLD",10661,"KRN","B",19,19)
"BLD",10661,"KRN","B",19.1,19.1)
"BLD",10661,"KRN","B",101,101)
"BLD",10661,"KRN","B",409.61,409.61)
"BLD",10661,"KRN","B",771,771)
"BLD",10661,"KRN","B",779.2,779.2)
"BLD",10661,"KRN","B",870,870)
"BLD",10661,"KRN","B",8989.51,8989.51)
"BLD",10661,"KRN","B",8989.52,8989.52)
"BLD",10661,"KRN","B",8994,8994)
"BLD",10661,"QDEF")
^^^^NO^^^^NO^^NO
"BLD",10661,"QUES",0)
^9.62^^
"BLD",10661,"REQB",0)
^9.611^1^1
"BLD",10661,"REQB",1,0)
PRCA*4.5*338^1
"BLD",10661,"REQB","B","PRCA*4.5*338",1)
"FIA",350.1)
IB ACTION TYPE
"FIA",350.1,0)
^IBE(350.1,
"FIA",350.1,0,0)
350.1
"FIA",350.1,0,1)
y^y^p^^^^n^^n
"FIA",350.1,0,10)
"FIA",350.1,0,11)
"FIA",350.1,0,"RLRO")
"FIA",350.1,0,"VR")
2.0^IB
"FIA",350.1,350.1)
1
"FIA",350.1,350.1,.12)
"INIT")
POSTINIT^IB20P618
"MBREQ")
0
"PKG",49,-1)
1^1
"PKG",49,0)
INTEGRATED BILLING^IB^INTEGRATED BILLING
"PKG",49,20,0)
^9.402P^1^1
"PKG",49,20,1,0)
2^^IBAXDR
"PKG",49,20,1,1)
"PKG",49,20,"B",2,1)
"PKG",49,22,0)
^9.49I^1^1
"PKG",49,22,1,0)
2.0^3051119^2960627
"PKG",49,22,1,"PAH",1,0)
618^3180522
"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")
5
"RTN","IB20P618")
0^3^B134924268
"RTN","IB20P618",1,0)
IB20P618 ;SAB/Albany - IB*2.0*618 POST INSTALL;12/11/17 2:10pm
"RTN","IB20P618",2,0)
;;2.0;Integrated Billing;**618**;Mar 20, 1995;Build 18
"RTN","IB20P618",3,0)
;Per VA Directive 6402, this routine should not be modified.
"RTN","IB20P618",4,0)
Q
"RTN","IB20P618",5,0)
;
"RTN","IB20P618",6,0)
POSTINIT ;Post Install for IB*2.0*618
"RTN","IB20P618",7,0)
D BMES^XPDUTL(" >> Starting the Post-Initialization routine for IB*2.0*618 ")
"RTN","IB20P618",8,0)
; Adding AR CATEGORIES and REVENUE SOURCE CODES
"RTN","IB20P618",9,0)
D RTADD
"RTN","IB20P618",10,0)
D RTUPD
"RTN","IB20P618",11,0)
D ADDRS
"RTN","IB20P618",12,0)
D IBUPD
"RTN","IB20P618",13,0)
D ADDACT^IBP618A
"RTN","IB20P618",14,0)
D UPDACT^IBP618B
"RTN","IB20P618",15,0)
D ADDACTCH^IBP618B
"RTN","IB20P618",16,0)
D BMES^XPDUTL(" >> End of the Post-Initialization routine for IB*2.0*618")
"RTN","IB20P618",17,0)
Q
"RTN","IB20P618",18,0)
;
"RTN","IB20P618",19,0)
RTADD ;Add New rate types to the Rate type File
"RTN","IB20P618",20,0)
;
"RTN","IB20P618",21,0)
N LOOP,FDA,FDAIEN,DATA,BRF,ARCAT,CHK
"RTN","IB20P618",22,0)
;
"RTN","IB20P618",23,0)
D MES^XPDUTL(" -> Adding new Rate Type entries to file 399.3 ...")
"RTN","IB20P618",24,0)
; Add new Rate Types
"RTN","IB20P618",25,0)
F LOOP=2:1 S DATA=$T(RTDATA+LOOP) Q:$P(DATA,";",3)="END" D
"RTN","IB20P618",26,0)
. ;Clear the array
"RTN","IB20P618",27,0)
. K FDA
"RTN","IB20P618",28,0)
. ;Check to insure that the rate type doesn't exist already
"RTN","IB20P618",29,0)
. S CHK="" ; Initialized the check variable
"RTN","IB20P618",30,0)
. S CHK=$O(^DGCR(399.3,"B",$P(DATA,";",3),""))
"RTN","IB20P618",31,0)
. Q:CHK'=""
"RTN","IB20P618",32,0)
. ;Store in array for adding to the file (#399.3).
"RTN","IB20P618",33,0)
. S FDA(399.3,"+1,",.01)=$P(DATA,";",3) ;Rate Type Name
"RTN","IB20P618",34,0)
. S FDA(399.3,"+1,",.02)=$P(DATA,";",4) ;Bill Name
"RTN","IB20P618",35,0)
. S FDA(399.3,"+1,",.03)=$P(DATA,";",5) ;Inactive Flag
"RTN","IB20P618",36,0)
. S FDA(399.3,"+1,",.04)=$P(DATA,";",6) ;Abbreviation
"RTN","IB20P618",37,0)
. S FDA(399.3,"+1,",.05)=$P(DATA,";",7) ;Third Party?
"RTN","IB20P618",38,0)
. S ARCAT=$P(DATA,";",8) ;AR Cat
"RTN","IB20P618",39,0)
. S:ARCAT'="" ARCAT=$O(^PRCA(430.2,"AC",ARCAT,"")) ;Find local IEN for AR Cat
"RTN","IB20P618",40,0)
. S FDA(399.3,"+1,",.06)=ARCAT ;AR Cat
"RTN","IB20P618",41,0)
. S FDA(399.3,"+1,",.07)=$P(DATA,";",9) ;Responsible?
"RTN","IB20P618",42,0)
. S FDA(399.3,"+1,",.08)=$P(DATA,";",10) ;Reimbursable
"RTN","IB20P618",43,0)
. S FDA(399.3,"+1,",.09)=$P(DATA,";",11) ;NSC Statement
"RTN","IB20P618",44,0)
. S FDA(399.3,"+1,",.1)=$P(DATA,";",12) ;Electronic Transmit
"RTN","IB20P618",45,0)
. S BRF=$P(DATA,";",13) ;Bill Resulting From (BRF) (430.6)
"RTN","IB20P618",46,0)
. S:BRF'="" BRF=$O(^PRCA(430.6,"B",BRF,"")) ;Find local IEN for BRF
"RTN","IB20P618",47,0)
. S FDA(399.3,"+1,",.11)=BRF
"RTN","IB20P618",48,0)
. S FDA(399.3,"+1,",.12)=$P(DATA,";",14) ;Collect?
"RTN","IB20P618",49,0)
. ;Add to the file.
"RTN","IB20P618",50,0)
. D UPDATE^DIE(,"FDA","FDAIEN")
"RTN","IB20P618",51,0)
. S FDAIEN=FDAIEN(1) K FDAIEN(1)
"RTN","IB20P618",52,0)
D MES^XPDUTL(" New Rate Types added.")
"RTN","IB20P618",53,0)
Q
"RTN","IB20P618",54,0)
;
"RTN","IB20P618",55,0)
RTDATA ; New RATE TYPE data. (Internal data format
"RTN","IB20P618",56,0)
;;name;billname;inactive; abbreviation;thirdparty;AR Cat #;resp;reimb;nsc;etransmit;billfrom;collect?
"RTN","IB20P618",57,0)
;;CC WORKERS' COMP;CC WORKERS' COMP;;CC WC;1;51;i;1;1;1;;
"RTN","IB20P618",58,0)
;;CC NO-FAULT AUTO;CC NO-FAULT AUTO;;CC NF;1;51;i;1;1;1;;
"RTN","IB20P618",59,0)
;;CC TORT FEASOR;CC TORT FEASOR;;CC TF;1;51;i;1;1;1;;
"RTN","IB20P618",60,0)
;;CC CHOICE WORKERS' COMP;CC CHOICE WORKERS' COMP;;CCC WC;1;50;i;1;1;1;;
"RTN","IB20P618",61,0)
;;CC CHOICE NO-FAULT AUTO;CC CHOICE NO-FAULT AUTO;;CCC NF;1;50;i;1;1;1;;
"RTN","IB20P618",62,0)
;;CC CHOICE TORT FEASOR;CC CHOICE TORT FEASOR;;CCC TF;1;50;i;1;1;1;;
"RTN","IB20P618",63,0)
;;CCN CHOICE WORKERS' COMP;CCN CHOICE WORKERS' COMP;;CCN WC;1;52;i;1;1;1;;
"RTN","IB20P618",64,0)
;;CCN CHOICE NO-FAULT AUTO;CCN CHOICE NO-FAULT AUTO;;CCN NF;1;52;i;1;1;1;;
"RTN","IB20P618",65,0)
;;CCN CHOICE TORT FEASOR;CCN CHOICE TORT FEASOR;;CCN TF;1;52;i;1;1;1;;
"RTN","IB20P618",66,0)
;;CC CHOICE REIMB INS;CC CHOICE REIMB INS;;CCC REIM;1;50;i;1;1;1;HI;1
"RTN","IB20P618",67,0)
;;CC REIMB INS;CC REIMB INS;;CC REIM;1;51;i;1;1;1;HI;1
"RTN","IB20P618",68,0)
;;CCN REIMB INS;CCN REIMB INS;;CCN REIM;1;52;i;1;1;1;HI;1
"RTN","IB20P618",69,0)
;;CC MTF REIMB INS;CC MTF REIMB INS;;CCD REIM;1;53;i;1;1;1;HI;1
"RTN","IB20P618",70,0)
;;DOD DISABILITY ENVALUATION;DOD DISABILITY EVALUATION;;TR IDES;1;37;i;1;1;1;HI;1
"RTN","IB20P618",71,0)
;;DOD SPINAL CORD INJURY;DOD SPINAL CORD INJURY;;TRSPINAL;1;37;i;1;1;1;HI;1
"RTN","IB20P618",72,0)
;;DOD TRAUMATIC BRAIN INJURY;DOD TRAUMATIC BRAIN INJURY;;TR TBI;1;37;i;1;1;1;HI;1
"RTN","IB20P618",73,0)
;;DOD BLIND REHABILITATION;DOD BLIND REHABILITATION;;TRREHAB;1;37;i;1;1;1;HI;1
"RTN","IB20P618",74,0)
;;TRICARE DENTAL;TRICARE DENTAL;;TR DENTAL;1;37;i;1;1;1;HI;1
"RTN","IB20P618",75,0)
;;TRICARE PHARMACY;TRICARE PHARMACY;;TR RX;1;37;i;1;1;1;HI;1
"RTN","IB20P618",76,0)
;;END
"RTN","IB20P618",77,0)
;
"RTN","IB20P618",78,0)
RTUPD ; Update the FEE REIMB INS entry in the Rate Type File (399.3) to inactivate
"RTN","IB20P618",79,0)
N LIEN,X,Y,DIE,DA,DR,DTOUT,DATA
"RTN","IB20P618",80,0)
;
"RTN","IB20P618",81,0)
D MES^XPDUTL(" -> Inactivating the FEE REIMB INS Rate Type...")
"RTN","IB20P618",82,0)
S LIEN=$O(^DGCR(399.3,"B","FEE REIMB INS",""))
"RTN","IB20P618",83,0)
Q:'LIEN
"RTN","IB20P618",84,0)
; File the update
"RTN","IB20P618",85,0)
S DR=".03////1;"
"RTN","IB20P618",86,0)
S DIE="^DGCR(399.3,",DA=LIEN
"RTN","IB20P618",87,0)
D ^DIE
"RTN","IB20P618",88,0)
;
"RTN","IB20P618",89,0)
Q
"RTN","IB20P618",90,0)
ADDRS ; Add Rate Schedules (363) for FEE REIMB INS
"RTN","IB20P618",91,0)
D MES^XPDUTL(" -> Adding new Rate Schedules to file 363 ...")
"RTN","IB20P618",92,0)
N IBA,IBCNT,IBI,IBLN,IBFN,IBRT,IBBS,IBCNTCS,IBDISP,IBJ,IBLNCS,IBCS,IBCSFN,IBADMIN,DD,DO,DLAYGO,DIC,DIE,DA,DR,RXDT,X,Y,IBCPNM S IBCNT=0
"RTN","IB20P618",93,0)
F IBI=2:1 S IBLN=$P($T(RSF+IBI),";;",2) Q:IBLN="END" I $E(IBLN)?1A D
"RTN","IB20P618",94,0)
. ;Check for problems
"RTN","IB20P618",95,0)
. I $O(^IBE(363,"B",$P(IBLN,U,1),0)) Q ;Already exists
"RTN","IB20P618",96,0)
. S IBBS=$P(IBLN,U,4) I IBBS'="" S IBBS=$$MCCRUTL(IBBS,13) Q:'IBBS ;Billable service invalid
"RTN","IB20P618",97,0)
. S IBRT=$P(IBLN,U,2),IBRT=$O(^DGCR(399.3,"B",IBRT,0)) D Q:'IBRT
"RTN","IB20P618",98,0)
.. I 'IBRT D MSG(" **** Rate Type "_$P(IBLN,U,2)_" not defined, RS "_$P(IBLN,U,1)_" not created")
"RTN","IB20P618",99,0)
.. I +$P($G(^DGCR(399.3,+IBRT,0)),U,3) S IBRT=0 D MSG(" **** Rate Type "_$P(IBLN,U,2)_" not Active, RS "_$P(IBLN,U,1)_" not created")
"RTN","IB20P618",100,0)
. ;No problems found, so create entry
"RTN","IB20P618",101,0)
. K DD,DO
"RTN","IB20P618",102,0)
. S DLAYGO=363,DIC="^IBE(363,",DIC(0)="L",X=$P(IBLN,U,1)
"RTN","IB20P618",103,0)
. D FILE^DICN K DIC,DINUM,DLAYGO
"RTN","IB20P618",104,0)
. I Y<1 K X,Y Q
"RTN","IB20P618",105,0)
. S IBFN=+Y,IBCNT=IBCNT+1
"RTN","IB20P618",106,0)
. S IBCPNM=$P(IBLN,U,5)
"RTN","IB20P618",107,0)
. S RXDT=$$RXDT(IBCPNM)
"RTN","IB20P618",108,0)
. S DR=".02////"_IBRT_";.03////"_$P(IBLN,U,3) I +IBBS S DR=DR_";.04////"_IBBS
"RTN","IB20P618",109,0)
. S DR=DR_";.05////"_RXDT
"RTN","IB20P618",110,0)
. I ($P(IBLN,U,1)["RX"),($G(IBDISP)]"") S DR=DR_";1.01///"_IBDISP
"RTN","IB20P618",111,0)
. I ($P(IBLN,U,1)["RX"),($G(IBADMIN)]"") S DR=DR_";1.02////"_IBADMIN
"RTN","IB20P618",112,0)
. S DIE="^IBE(363,",DA=+Y D ^DIE K DIE,DA,DR,X,Y
"RTN","IB20P618",113,0)
. S IBCNTCS=0
"RTN","IB20P618",114,0)
. ; Retrieve name of Charge Set to copy
"RTN","IB20P618",115,0)
. I IBRT="" D MSG(" **** Rate Type "_$P(IBLN,U,2)_" missing Charge Set Information, RS "_$P(IBLN,U,1)_" not created") Q
"RTN","IB20P618",116,0)
. ; add all Reasonable Charges Charge Sets to the Rate Schedule.
"RTN","IB20P618",117,0)
. S IBCNTCS=$$RSCS(IBFN,IBCPNM,RXDT)
"RTN","IB20P618",118,0)
. D MES^XPDUTL(" Total Reasonable Charge Set"_$S(IBCNTCS=1:" ",1:"s ")_IBCNTCS_" added to Rate Schedule "_$P(IBLN,U,1)_".")
"RTN","IB20P618",119,0)
D MES^XPDUTL(" Rate Schedules completed.")
"RTN","IB20P618",120,0)
Q ;ADDRS
"RTN","IB20P618",121,0)
;
"RTN","IB20P618",122,0)
RSCS(IBFN,IBCPNM,RXDT) ; add existing Charge Sets to FR
"RTN","IB20P618",123,0)
; copy the Charge Sets from the corresponding RI RS (v2)
"RTN","IB20P618",124,0)
; IBFN - Rate Schedule IEN
"RTN","IB20P618",125,0)
; IBCPNM - Charge Set to copy
"RTN","IB20P618",126,0)
; RXDT - last effective date of charge set being copied.
"RTN","IB20P618",127,0)
N IBCNT,IBNRS,IBRSNM,IBTY,IBVDT,IBCOPY,IBCS,IBCS0,IBXFN,IBCSFN,IBCSNM,IBCSAA,IBNAME
"RTN","IB20P618",128,0)
S (IBCNT,IBCOPY)=0
"RTN","IB20P618",129,0)
S IBNRS=$G(^IBE(363,+$G(IBFN),0)),IBRSNM=$P(IBNRS,"^",1)
"RTN","IB20P618",130,0)
S IBTY=$P(IBNRS,"^",3)
"RTN","IB20P618",131,0)
S IBVDT=RXDT
"RTN","IB20P618",132,0)
Q:IBVDT="" 0
"RTN","IB20P618",133,0)
S IBCOPY=+$$RSEXISTS(IBVDT,IBCPNM)
"RTN","IB20P618",134,0)
I 'IBCOPY G RSCSQ
"RTN","IB20P618",135,0)
I +$P($G(^IBE(363,+IBCOPY,0)),U,3)=IBTY D
"RTN","IB20P618",136,0)
. S IBXFN=0 F S IBXFN=$O(^IBE(363,IBCOPY,11,IBXFN)) Q:'IBXFN D
"RTN","IB20P618",137,0)
.. S IBCS=$G(^IBE(363,IBCOPY,11,IBXFN,0)),IBCSFN=+IBCS
"RTN","IB20P618",138,0)
.. I +$$RSCSFILE(IBFN,$P($G(^IBE(363.1,IBCSFN,0)),U,1),$P(IBCS,U,2)) S IBCNT=IBCNT+1
"RTN","IB20P618",139,0)
RSCSQ Q IBCNT
"RTN","IB20P618",140,0)
;
"RTN","IB20P618",141,0)
;
"RTN","IB20P618",142,0)
RSCSFILE(IBFN,IBCSNM,IBCSAA) ; Add Charge Set to a Rate Schedule
"RTN","IB20P618",143,0)
N IBX,DD,DO,DLAYGO,DIC,DA,DR,X,Y,IBCSFN S IBX=0
"RTN","IB20P618",144,0)
I $G(^IBE(363,+$G(IBFN),0))="" G RSCSFQ
"RTN","IB20P618",145,0)
I $G(IBCSNM)="" G RSCSFQ
"RTN","IB20P618",146,0)
S IBCSFN=$O(^IBE(363.1,"B",IBCSNM,0)) I 'IBCSFN G RSCSFQ
"RTN","IB20P618",147,0)
I $O(^IBE(363,IBFN,11,"B",IBCSFN,0)) G RSCSFQ
"RTN","IB20P618",148,0)
S DLAYGO=363,DA(1)=+IBFN,DIC="^IBE(363,"_DA(1)_",11,",DIC(0)="L"
"RTN","IB20P618",149,0)
S X=IBCSNM,DIC("DR")=".02///"_$G(IBCSAA),DIC("P")="363.0011P"
"RTN","IB20P618",150,0)
D ^DIC S:+Y IBX=1
"RTN","IB20P618",151,0)
RSCSFQ Q IBX
"RTN","IB20P618",152,0)
;
"RTN","IB20P618",153,0)
;
"RTN","IB20P618",154,0)
RSEXISTS(IBVDT,IBNAME) ; return RS IFN if Rate Schedule exists for Effective Date
"RTN","IB20P618",155,0)
N IBX,IBRSFN,IBRS0 S IBX=0
"RTN","IB20P618",156,0)
S IBRSFN=0 F S IBRSFN=$O(^IBE(363,IBRSFN)) Q:'IBRSFN D I IBX Q
"RTN","IB20P618",157,0)
. S IBRS0=$G(^IBE(363,IBRSFN,0))
"RTN","IB20P618",158,0)
. I $P(IBRS0,U,1)=IBNAME,$P(IBRS0,U,5)=IBVDT S IBX=IBRSFN
"RTN","IB20P618",159,0)
Q IBX
"RTN","IB20P618",160,0)
;
"RTN","IB20P618",161,0)
MSG(X) ;
"RTN","IB20P618",162,0)
N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
"RTN","IB20P618",163,0)
S IBA(IBX)=$G(X)
"RTN","IB20P618",164,0)
Q ;MSG
"RTN","IB20P618",165,0)
;
"RTN","IB20P618",166,0)
MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
"RTN","IB20P618",167,0)
N IBX,IBY S IBY=""
"RTN","IB20P618",168,0)
I $G(X)'="" S IBX=0 F S IBX=$O(^DGCR(399.1,"B",X,IBX)) Q:'IBX I $P($G(^DGCR(399.1,IBX,0)),U,+$G(P)) S IBY=IBX
"RTN","IB20P618",169,0)
Q IBY
"RTN","IB20P618",170,0)
;
"RTN","IB20P618",171,0)
RXDT(IBCPNM) ;Copy the active charge schedule from charge set being copied.
"RTN","IB20P618",172,0)
; update Fee information if Pharmacy.
"RTN","IB20P618",173,0)
S IBCS="",IBCS=$O(^IBE(363,"B",IBCPNM,IBCS),-1)
"RTN","IB20P618",174,0)
Q:IBCS="" ""
"RTN","IB20P618",175,0)
S IBCS0=^IBE(363,IBCS,0)
"RTN","IB20P618",176,0)
I IBCPNM["RX" S IBDISP=$P($G(^IBE(363,IBCS,1)),U,1),IBADMIN=$G(^IBE(363,IBCS,10))
"RTN","IB20P618",177,0)
Q $P(IBCS0,U,5)
"RTN","IB20P618",178,0)
;
"RTN","IB20P618",179,0)
RSF ;Rate Schedules (363) for the new Community Care Rate Types.
"RTN","IB20P618",180,0)
;;Rate Schedule Name^Rate Type^Bill Type^Billable Service^Rate Schedule to copy for Charge Sets
"RTN","IB20P618",181,0)
;;CCC-NF-INPT^CC CHOICE NO-FAULT AUTO^1^^NF-INPT
"RTN","IB20P618",182,0)
;;CCC-NF-SNF^CC CHOICE NO-FAULT AUTO^1^SKILLED NURSING^NF-SNF
"RTN","IB20P618",183,0)
;;CCC-NF-OPT^CC CHOICE NO-FAULT AUTO^3^^NF-OPT
"RTN","IB20P618",184,0)
;;CCC-NF-RX^CC CHOICE NO-FAULT AUTO^3^^NF-RX
"RTN","IB20P618",185,0)
;;CC-NF-INPT^CC NO-FAULT AUTO^1^^NF-INPT
"RTN","IB20P618",186,0)
;;CC-NF-SNF^CC NO-FAULT AUTO^1^SKILLED NURSING^NF-SNF
"RTN","IB20P618",187,0)
;;CC-NF-OPT^CC NO-FAULT AUTO^3^^NF-OPT
"RTN","IB20P618",188,0)
;;CC-NF-RX^CC NO-FAULT AUTO^3^^NF-RX
"RTN","IB20P618",189,0)
;;CCN-NF-INPT^CCN CHOICE NO-FAULT AUTO^1^^NF-INPT
"RTN","IB20P618",190,0)
;;CCN-NF-SNF^CCN CHOICE NO-FAULT AUTO^1^SKILLED NURSING^NF-SNF
"RTN","IB20P618",191,0)
;;CCN-NF-OPT^CCN CHOICE NO-FAULT AUTO^3^^NF-OPT
"RTN","IB20P618",192,0)
;;CCN-NF-RX^CCN CHOICE NO-FAULT AUTO^3^^NF-RX
"RTN","IB20P618",193,0)
;;CCC-RI-INPT^CC CHOICE REIMB INS^1^^RI-INPT
"RTN","IB20P618",194,0)
;;CCC-RI-SNF^CC CHOICE REIMB INS^1^SKILLED NURSING^RI-SNF
"RTN","IB20P618",195,0)
;;CCC-RI-OPT^CC CHOICE REIMB INS^3^^RI-OPT
"RTN","IB20P618",196,0)
;;CCC-RI-RX^CC CHOICE REIMB INS^3^^RI-RX
"RTN","IB20P618",197,0)
;;CC-RI-INPT^CC REIMB INS^1^^RI-INPT
"RTN","IB20P618",198,0)
;;CC-RI-SNF^CC REIMB INS^1^SKILLED NURSING^RI-SNF
"RTN","IB20P618",199,0)
;;CC-RI-OPT^CC REIMB INS^3^^RI-OPT
"RTN","IB20P618",200,0)
;;CC-RI-RX^CC REIMB INS^3^^RI-RX
"RTN","IB20P618",201,0)
;;CCN-RI-INPT^CCN REIMB INS^1^^RI-INPT
"RTN","IB20P618",202,0)
;;CCN-RI-SNF^CCN REIMB INS^1^SKILLED NURSING^RI-SNF
"RTN","IB20P618",203,0)
;;CCN-RI-OPT^CCN REIMB INS^3^^RI-OPT
"RTN","IB20P618",204,0)
;;CCN-RI-RX^CCN REIMB INS^3^^RI-RX
"RTN","IB20P618",205,0)
;;CC-DOD-INPT^CC MTF REIMB INS^1^INPATIENT^TRRI-INPT
"RTN","IB20P618",206,0)
;;CC-DOD-SNF^CC MTF REIMB INS^1^SKILLED NURSING^TRRI-SNF
"RTN","IB20P618",207,0)
;;CC-DOD-OPT^CC MTF REIMB INS^3^OUTPATIENT VISIT^TRRI-OPT
"RTN","IB20P618",208,0)
;;CC-DOD-RX^CC MTF REIMB INS^3^^TRRI-RX
"RTN","IB20P618",209,0)
;;CCC-TF-INPT^CC CHOICE TORT FEASOR^1^^TF-INPT
"RTN","IB20P618",210,0)
;;CCC-TF-SNF^CC CHOICE TORT FEASOR^1^SKILLED NURSING^TF-SNF
"RTN","IB20P618",211,0)
;;CCC-TF-OPT^CC CHOICE TORT FEASOR^3^^TF-OPT
"RTN","IB20P618",212,0)
;;CCC-TF-RX^CC CHOICE TORT FEASOR^3^^TF-RX
"RTN","IB20P618",213,0)
;;CC-TF-INPT^CC TORT FEASOR^1^^TF-INPT
"RTN","IB20P618",214,0)
;;CC-TF-SNF^CC TORT FEASOR^1^SKILLED NURSING^TF-SNF
"RTN","IB20P618",215,0)
;;CC-TF-OPT^CC TORT FEASOR^3^^TF-OPT
"RTN","IB20P618",216,0)
;;CC-TF-RX^CC TORT FEASOR^3^^TF-RX
"RTN","IB20P618",217,0)
;;CCN-TF-INPT^CCN CHOICE TORT FEASOR^1^^TF-INPT
"RTN","IB20P618",218,0)
;;CCN-TF-SNF^CCN CHOICE TORT FEASOR^1^SKILLED NURSING^TF-SNF
"RTN","IB20P618",219,0)
;;CCN-TF-OPT^CCN CHOICE TORT FEASOR^3^^TF-OPT
"RTN","IB20P618",220,0)
;;CCN-TF-RX^CCN CHOICE TORT FEASOR^3^^TF-RX
"RTN","IB20P618",221,0)
;;CCC-WC-INPT^CC CHOICE WORKERS' COMP^1^^WC-INPT
"RTN","IB20P618",222,0)
;;CCC-WC-SNF^CC CHOICE WORKERS' COMP^1^SKILLED NURSING^WC-SNF
"RTN","IB20P618",223,0)
;;CCC-WC-OPT^CC CHOICE WORKERS' COMP^3^^WC-OPT
"RTN","IB20P618",224,0)
;;CCC-WC-RX^CC CHOICE WORKERS' COMP^3^^WC-RX
"RTN","IB20P618",225,0)
;;CC-WC-INPT^CC WORKERS' COMP^1^^WC-INPT
"RTN","IB20P618",226,0)
;;CC-WC-SNF^CC WORKERS' COMP^1^SKILLED NURSING^WC-SNF
"RTN","IB20P618",227,0)
;;CC-WC-OPT^CC WORKERS' COMP^3^^WC-OPT
"RTN","IB20P618",228,0)
;;CC-WC-RX^CC WORKERS' COMP^3^^WC-RX
"RTN","IB20P618",229,0)
;;CCN-WC-INPT^CCN CHOICE WORKERS' COMP^1^^WC-INPT
"RTN","IB20P618",230,0)
;;CCN-WC-SNF^CCN CHOICE WORKERS' COMP^1^SKILLED NURSING^WC-SNF
"RTN","IB20P618",231,0)
;;CCN-WC-OPT^CCN CHOICE WORKERS' COMP^3^^WC-OPT
"RTN","IB20P618",232,0)
;;CCN-WC-RX^CCN CHOICE WORKERS' COMP^3^^WC-RX
"RTN","IB20P618",233,0)
;;DOD-DIS EXAM-OPT^DOD DISABILITY EVALUATION^3^OUTPATIENT VISIT^TR-OPT
"RTN","IB20P618",234,0)
;;DOD-SCI-INPT^DOD SPINAL CORD INJURY^1^INPATIENT^TR-INPT
"RTN","IB20P618",235,0)
;;DOD-SCI-OPT^DOD SPINAL CORD INJURY^3^OUTPATIENT VISIT^TR-OPT
"RTN","IB20P618",236,0)
;;DOD-SCI-SNF^DOD SPINAL CORD INJURY^1^SKILLED NURSING^TR-SNF
"RTN","IB20P618",237,0)
;;DOD-TBI-INPT^DOD TRAUMATIC BRAIN INJURY^1^INPATIENT^TR-INPT
"RTN","IB20P618",238,0)
;;DOD-TBI-OPT^DOD TRAUMATIC BRAIN INJURY^3^OUTPATIENT VISIT^TR-OPT
"RTN","IB20P618",239,0)
;;DOD-TBI-SNF^DOD TRAUMATIC BRAIN INJURY^1^SKILLED NURSING^TR-SNF
"RTN","IB20P618",240,0)
;;DOD-BR-INPT^DOD BLIND REHABILITATION^1^INPATIENT^TR-INPT
"RTN","IB20P618",241,0)
;;DOD-BR-OPT^DOD BLIND REHABILITATION^3^OUTPATIENT VISIT^TR-OPT
"RTN","IB20P618",242,0)
;;DOD-BR-SNF^DOD BLIND REHABILITATION^1^SKILLED NURSING^TR-SNF
"RTN","IB20P618",243,0)
;;TR-DENTAL^TRICARE DENTAL^3^OUTPATIENT VISIT^TR-OPT
"RTN","IB20P618",244,0)
;;TR-PHARM^TRICARE PHARMACY^3^^TR-RX
"RTN","IB20P618",245,0)
;;END
"RTN","IB20P618",246,0)
;
"RTN","IB20P618",247,0)
IBUPD ; Inactivate FEE Service Entries
"RTN","IB20P618",248,0)
;
"RTN","IB20P618",249,0)
N LOOP,LIEN,IBDATA
"RTN","IB20P618",250,0)
N X,Y,DIE,DA,DR,DTOUT,DATA
"RTN","IB20P618",251,0)
;
"RTN","IB20P618",252,0)
; Grab all of the entries to update
"RTN","IB20P618",253,0)
F LOOP=1:1:24 D
"RTN","IB20P618",254,0)
. ;Extract the new ACTION TYPE to be added.
"RTN","IB20P618",255,0)
. S IBDATA=$T(IBDDAT+LOOP)
"RTN","IB20P618",256,0)
. S IBDATA=$P(IBDATA,";;",2)
"RTN","IB20P618",257,0)
. ;Store in array for adding to the file (#350.1).
"RTN","IB20P618",258,0)
. Q:IBDATA="" ;go to next entry if Category is not to be updated.
"RTN","IB20P618",259,0)
. S LIEN=$O(^IBE(350.1,"B",IBDATA,"")) ; find ACTION TYPE entry
"RTN","IB20P618",260,0)
. Q:LIEN=""
"RTN","IB20P618",261,0)
. ;
"RTN","IB20P618",262,0)
. ; File the update along with inactivate the ACTION TYPE
"RTN","IB20P618",263,0)
. S DR=".12////1;"
"RTN","IB20P618",264,0)
. S DIE="^IBE(350.1,",DA=LIEN
"RTN","IB20P618",265,0)
. D ^DIE
"RTN","IB20P618",266,0)
. K DR ;Clear update array before next use
"RTN","IB20P618",267,0)
;
"RTN","IB20P618",268,0)
S DR=""
"RTN","IB20P618",269,0)
D MES^XPDUTL(" -> Data added to the ACTION TYPE (350.1) INACTIVE field.")
"RTN","IB20P618",270,0)
Q
"RTN","IB20P618",271,0)
;
"RTN","IB20P618",272,0)
IBDDAT ; Fee Service to inactivate
"RTN","IB20P618",273,0)
;;DG FEE SERVICE (INPT) CANCEL
"RTN","IB20P618",274,0)
;;DG FEE SERVICE (INPT) NEW
"RTN","IB20P618",275,0)
;;DG FEE SERVICE (INPT) UPDATE
"RTN","IB20P618",276,0)
;;DG FEE SERVICE (OPT) CANCEL
"RTN","IB20P618",277,0)
;;DG FEE SERVICE (OPT) NEW
"RTN","IB20P618",278,0)
;;DG FEE SERVICE (OPT) UPDATE
"RTN","IB20P618",279,0)
;;DG LTC FEE INPT CNH CANCEL
"RTN","IB20P618",280,0)
;;DG LTC FEE INPT CNH NEW
"RTN","IB20P618",281,0)
;;DG LTC FEE INPT CNH UPDATE
"RTN","IB20P618",282,0)
;;DG LTC FEE INPT RESPITE CANCEL
"RTN","IB20P618",283,0)
;;DG LTC FEE INPT RESPITE NEW
"RTN","IB20P618",284,0)
;;DG LTC FEE INPT RESPITE UPDATE
"RTN","IB20P618",285,0)
;;DG LTC FEE OPT ADHC CANCEL
"RTN","IB20P618",286,0)
;;DG LTC FEE OPT ADHC NEW
"RTN","IB20P618",287,0)
;;DG LTC FEE OPT ADHC UPDATE
"RTN","IB20P618",288,0)
;;DG LTC FEE OPT RESPITE CANCEL
"RTN","IB20P618",289,0)
;;DG LTC FEE OPT RESPITE NEW
"RTN","IB20P618",290,0)
;;DG LTC FEE OPT RESPITE UPDATE
"RTN","IB20P618",291,0)
;;FEE SERV INPT PER DIEM CANCEL
"RTN","IB20P618",292,0)
;;FEE SERV INPT PER DIEM NEW
"RTN","IB20P618",293,0)
;;FEE SERV INPT PER DIEM UPDATE
"RTN","IB20P618",294,0)
;;FEE SERV NSC RX COPAY CANCEL
"RTN","IB20P618",295,0)
;;FEE SERV NSC RX COPAY NEW
"RTN","IB20P618",296,0)
;;FEE SERV NSC RX COPAY UPDATE
"RTN","IB20P618",297,0)
;;END
"RTN","IBECEA3")
0^4^B75927900
"RTN","IBECEA3",1,0)
IBECEA3 ;ALB/CPM - Cancel/Edit/Add... Add a Charge ;30-MAR-93
"RTN","IBECEA3",2,0)
;;2.0;INTEGRATED BILLING;**7,57,52,132,150,153,166,156,167,176,198,188,183,202,240,312,402,454,563,618**;21-MAR-94;Build 18
"RTN","IBECEA3",3,0)
;;Per VA Directive 6402, this routine should not be modified.
"RTN","IBECEA3",4,0)
;
"RTN","IBECEA3",5,0)
ADD ; Add a Charge protocol
"RTN","IBECEA3",6,0)
N IBGMT,IBGMTR,IBUSNM ;IN*2.0*618 Add IBUSNM
"RTN","IBECEA3",7,0)
S (IBGMT,IBGMTR)=0
"RTN","IBECEA3",8,0)
S IBCOMMIT=0,IBEXSTAT=$$RXST^IBARXEU(DFN,DT),IBCATC=$$BILST^DGMTUB(DFN),IBCVAEL=$$CVA^IBAUTL5(DFN),IBLTCST=$$LTCST^IBAECU(DFN,DT,1)
"RTN","IBECEA3",9,0)
;I 'IBCVAEL,'IBCATC,'$G(IBRX),+IBEXSTAT<1 W !!,"This patient has never been Means Test billable." S VALMBCK="" D PAUSE^VALM1 G ADDQ1
"RTN","IBECEA3",10,0)
;
"RTN","IBECEA3",11,0)
; - clear screen and begin
"RTN","IBECEA3",12,0)
D CLOCK^IBAUTL3 I 'IBCLDA S (IBMED,IBCLDAY,IBCLDOL,IBCLDT)=0
"RTN","IBECEA3",13,0)
D HDR^IBECEAU("A D D")
"RTN","IBECEA3",14,0)
I IBY<0 D NODED^IBECEAU3 G ADDQ
"RTN","IBECEA3",15,0)
;
"RTN","IBECEA3",16,0)
; - ask for the charge type
"RTN","IBECEA3",17,0)
D CHTYP^IBECEA33 G:IBY<0 ADDQ
"RTN","IBECEA3",18,0)
;
"RTN","IBECEA3",19,0)
;***IB*2.0*618 change to add more Action Types to this list...
"RTN","IBECEA3",20,0)
;N IBAFEE S:$P($G(^IBE(350.1,+$G(IBATYP),0)),"^",8)="FEE SERVICE/OUTPATIENT" IBAFEE=IBATYP
"RTN","IBECEA3",21,0)
; Allow user to add an extra "co-payment" charge if the Action Type
"RTN","IBECEA3",22,0)
; selected is an Outpatient FEE BASIS, CC or CCN charge type
"RTN","IBECEA3",23,0)
N IBAFEE
"RTN","IBECEA3",24,0)
S IBUSNM=$P($G(^IBE(350.1,+$G(IBATYP),0)),"^",8)
"RTN","IBECEA3",25,0)
I IBUSNM'="" D
"RTN","IBECEA3",26,0)
. I IBUSNM="FEE SERVICE/OUTPATIENT" S IBAFEE=IBATYP Q
"RTN","IBECEA3",27,0)
. I (IBUSNM["CC")!(IBUSNM["CHOICE") D
"RTN","IBECEA3",28,0)
. . I (IBUSNM["OPT")!(IBUSNM["OUTPATIENT") S IBAFEE=IBATYP
"RTN","IBECEA3",29,0)
;*** END IB*2.0*618 ***
"RTN","IBECEA3",30,0)
;
"RTN","IBECEA3",31,0)
; - process CHAMPVA charges
"RTN","IBECEA3",32,0)
I IBXA=6 D CHMPVA^IBECEA32 G ADDQ
"RTN","IBECEA3",33,0)
;
"RTN","IBECEA3",34,0)
; - process TRICARE charges
"RTN","IBECEA3",35,0)
I IBXA=7 D CUS^IBECEA35 G ADDQ
"RTN","IBECEA3",36,0)
;
"RTN","IBECEA3",37,0)
; - display MT billing clock data
"RTN","IBECEA3",38,0)
I IBXA=2,$P($G(^IBE(350.1,+IBATYP,0)),"^",8)'["NHCU",IBCLDAY>90 S IBMED=IBMED/2
"RTN","IBECEA3",39,0)
I IBXA=1,IBCLDAY>90 D MED^IBECEA34 G:IBY<0 ADDQ
"RTN","IBECEA3",40,0)
I "^1^2^3^"[("^"_IBXA_"^"),IBCLDA W !!," ** Active Billing Clock ** # Inpt Days: ",IBCLDAY," ",$$INPT^IBECEAU(IBCLDAY)," 90 days: $",+IBCLDOL,!
"RTN","IBECEA3",41,0)
;
"RTN","IBECEA3",42,0)
; - if LTC OPT (non-institutional) and CD display message of warning
"RTN","IBECEA3",43,0)
I IBXA=8,$$CDEXMPT^IBAECU(DFN,DT) W !!," ** Patient is currently Catastrophically Disabled",!
"RTN","IBECEA3",44,0)
;
"RTN","IBECEA3",45,0)
; - display LTC billing clock data
"RTN","IBECEA3",46,0)
I IBXA>7,IBXA<10 D G:IBCLDA<1 ADDQ
"RTN","IBECEA3",47,0)
. N IBCLZ
"RTN","IBECEA3",48,0)
. S IBCLDA=$O(^IBA(351.81,"AE",DFN,9999999),-1)
"RTN","IBECEA3",49,0)
. S:IBCLDA IBCLDA=$O(^IBA(351.81,"AE",DFN,IBCLDA,0))
"RTN","IBECEA3",50,0)
. I 'IBCLDA W !!," ** Patient has no LTC billing clock **" Q
"RTN","IBECEA3",51,0)
. S IBCLZ=^IBA(351.81,IBCLDA,0)
"RTN","IBECEA3",52,0)
. W !!," **Last LTC Billing Clock Start Date: ",$$FMTE^XLFDT($P(IBCLZ,"^",3))," Free Days Remaining: ",+$P(IBCLZ,"^",6)
"RTN","IBECEA3",53,0)
. I $P(IBCLZ,"^",6) W !,"The patient must use his free days first." S IBCLDA=0
"RTN","IBECEA3",54,0)
;
"RTN","IBECEA3",55,0)
; - ask date, units and maybe tier for rx copay charge
"RTN","IBECEA3",56,0)
I IBXA=5 D G ADDQ:IBY<0,PROC
"RTN","IBECEA3",57,0)
. N IBA,IBB,IBC,IBX
"RTN","IBECEA3",58,0)
. S IBLIM=DT D FR^IBECEAU2(0) Q:IBY<0
"RTN","IBECEA3",59,0)
. S (IBTO,IBEFDT)=IBFR
"RTN","IBECEA3",60,0)
. ;
"RTN","IBECEA3",61,0)
. ; ask tier if needed
"RTN","IBECEA3",62,0)
. S IBTIER=$$TIER^IBECEAU2(IBATYP,IBEFDT) Q:IBY<0
"RTN","IBECEA3",63,0)
. ;
"RTN","IBECEA3",64,0)
. ; ask units
"RTN","IBECEA3",65,0)
. D UNIT^IBECEAU2(0) Q:IBY<0
"RTN","IBECEA3",66,0)
. ;
"RTN","IBECEA3",67,0)
. ; has patient been previously tracked for cap info
"RTN","IBECEA3",68,0)
. D TRACK^IBARXMN(DFN)
"RTN","IBECEA3",69,0)
. ;
"RTN","IBECEA3",70,0)
. D CTBB^IBECEAU3
"RTN","IBECEA3",71,0)
. ;
"RTN","IBECEA3",72,0)
. ; check if above cap
"RTN","IBECEA3",73,0)
. I IBY'<0 D
"RTN","IBECEA3",74,0)
.. N IBB,IBN,DIR,DIRUT,DUOUT,DTOUT,X,Y
"RTN","IBECEA3",75,0)
.. D NEW^IBARXMC(1,IBCHG,IBFR,.IBB,.IBN) Q:'IBN
"RTN","IBECEA3",76,0)
.. ;
"RTN","IBECEA3",77,0)
.. ; display message ask to proceed
"RTN","IBECEA3",78,0)
.. W !!,"This charge will put the patient > $",$J(IBN,0,2)," above their cap amount."
"RTN","IBECEA3",79,0)
.. S DIR(0)="Y",DIR("A")="Okay to proceed" D ^DIR S:'Y IBY=-1
"RTN","IBECEA3",80,0)
.. ;
"RTN","IBECEA3",81,0)
S IBLIM=$S(IBXA=4!(IBXA=3):DT,1:$$FMADD^XLFDT(DT,-1))
"RTN","IBECEA3",82,0)
;
"RTN","IBECEA3",83,0)
FR ; - ask 'bill from' date
"RTN","IBECEA3",84,0)
D FR^IBECEAU2(0) G:IBY<0 ADDQ
"RTN","IBECEA3",85,0)
;
"RTN","IBECEA3",86,0)
S IBGMT=$$ISGMTPT^IBAGMT(DFN,IBFR),IBGMTR=0 ;GMT Copayment Status
"RTN","IBECEA3",87,0)
I IBGMT>0,IBXA>0,IBXA<4 W !,"The patient has GMT Copayment Status."
"RTN","IBECEA3",88,0)
; - check the MT billing clock
"RTN","IBECEA3",89,0)
I IBXA'=8,IBXA'=9 D CLMSG^IBECEA33 G:IBY<0 ADDQ
"RTN","IBECEA3",90,0)
;Adjust Deductible for GMT patient
"RTN","IBECEA3",91,0)
I IBGMT>0,IBXA>0,IBXA<4,$G(IBMED) S IBMED=$$REDUCE^IBAGMT(IBMED) W !,"Medicare Deductible reduced due to GMT Copayment Status ($",$J(IBMED,"",2),")."
"RTN","IBECEA3",92,0)
;
"RTN","IBECEA3",93,0)
; - check LTC non-institutional (opt) for CD exemption
"RTN","IBECEA3",94,0)
I IBXA=8,$$CDEXMPT^IBAECU(DFN,IBFR) W !,"Patient is LTC non-institutional exempt, Catastrophically Disabled" G ADDQ
"RTN","IBECEA3",95,0)
;
"RTN","IBECEA3",96,0)
; - check the LTC billing clock
"RTN","IBECEA3",97,0)
I IBXA>7,IBXA<10 D I IBY<0 W !!,"The patient has no LTC clock active for the date.",! G ADDQ
"RTN","IBECEA3",98,0)
. N IBCLZ S IBCLZ=^IBA(351.81,IBCLDA,0)
"RTN","IBECEA3",99,0)
. ;
"RTN","IBECEA3",100,0)
. ; is this the clock and within the date range
"RTN","IBECEA3",101,0)
. I IBFR'<$P(IBCLZ,"^",3),$$YR^IBAECU($P(IBCLZ,"^",3),IBFR) S IBY=-1 Q
"RTN","IBECEA3",102,0)
. ;
"RTN","IBECEA3",103,0)
. ; look for another clock that might fit the date
"RTN","IBECEA3",104,0)
. I IBFR<$P(IBCLZ,"^",3) S IBCLDA=$O(^IBA(351.81,"AE",DFN,IBFR+1),-1) I 'IBCLDA!($$YR^IBAECU($P($G(^IBA(351.81,+IBCLDA,0)),"^",3),IBFR)) S IBY=-1
"RTN","IBECEA3",105,0)
;
"RTN","IBECEA3",106,0)
; - calculate the MT inpt copay charge
"RTN","IBECEA3",107,0)
I IBXA=2 S IBDT=IBFR D COPAY^IBAUTL2 G ADDQ:IBY<0 S:IBGMT>0 IBGMTR=1,IBCHG=$$REDUCE^IBAGMT(IBCHG) I IBCHG+IBCLDOL<IBMED W *7," ($",IBCHG,"/day)" W:IBGMTR " GMT Rate"
"RTN","IBECEA3",108,0)
;
"RTN","IBECEA3",109,0)
; - find the correct clock from the 'bill from' date (ignore LTC)
"RTN","IBECEA3",110,0)
I IBXA'=8,IBXA'=9,('IBCLDA!(IBCLDA&(IBFR<IBCLDT))) D NOCL^IBECEA33 G:IBY<0 ADDQ
"RTN","IBECEA3",111,0)
;
"RTN","IBECEA3",112,0)
; - perform outpatient edits
"RTN","IBECEA3",113,0)
N IBSTOPDA
"RTN","IBECEA3",114,0)
I IBXA=4 D G ADDQ:IBY<0,PROC
"RTN","IBECEA3",115,0)
. ; for visits prior to 12/6/01 or FEE
"RTN","IBECEA3",116,0)
. I IBFR<3011206!($G(IBAFEE)) D OPT^IBECEA33 Q
"RTN","IBECEA3",117,0)
. ; for visits on or after 12/5/01
"RTN","IBECEA3",118,0)
. D OPT^IBEMTSCU
"RTN","IBECEA3",119,0)
;
"RTN","IBECEA3",120,0)
; - if LTC outpatient calculate the charge
"RTN","IBECEA3",121,0)
I IBXA=8 D G:IBY<0 ADDQ S (IBDT,IBTO,IBEVDT)=IBFR,IBDESC=$P(^IBE(350.1,IBATYP,0),"^",8),IBUNIT=1,IBEVDA="*" D COST^IBAUTL2,CALC^IBAECO,CTBB^IBECEAU3 G @$S(IBCHG:"PROC",1:"ADDQ")
"RTN","IBECEA3",122,0)
. ;
"RTN","IBECEA3",123,0)
. ; is this day already a free day
"RTN","IBECEA3",124,0)
. I $D(^IBA(351.81,IBCLDA,1,"AC",IBFR)) W !!,"This day is already marked as a Free Day." S IBY=-1
"RTN","IBECEA3",125,0)
. ;
"RTN","IBECEA3",126,0)
. ; have we already billed for this day
"RTN","IBECEA3",127,0)
. I $$BFO^IBECEAU(DFN,IBFR) W !!,"This patient has already been billed for this date." S IBY=-1
"RTN","IBECEA3",128,0)
;
"RTN","IBECEA3",129,0)
; - find per diem charge and description
"RTN","IBECEA3",130,0)
I IBXA=3 D I 'IBCHG W !!,"Unable to determine the per diem rate. Please check your rate table." G ADDQ
"RTN","IBECEA3",131,0)
.N IBDT S IBDT=IBFR,IBGMTR=0 D COST^IBAUTL2
"RTN","IBECEA3",132,0)
.I IBGMT>0 S IBGMTR=1,IBCHG=$$REDUCE^IBAGMT(IBCHG)
"RTN","IBECEA3",133,0)
.S IBDESC="" X:$D(^IBE(350.1,IBATYP,20)) ^(20)
"RTN","IBECEA3",134,0)
;
"RTN","IBECEA3",135,0)
; - calculate charge for the inpatient copay
"RTN","IBECEA3",136,0)
I IBXA=2,IBCHG+IBCLDOL'<IBMED S IBCHG=IBMED-IBCLDOL,IBUNIT=1,IBTO=IBFR D CTBB^IBECEAU3 G EV
"RTN","IBECEA3",137,0)
;
"RTN","IBECEA3",138,0)
TO ; - ask 'bill to' date
"RTN","IBECEA3",139,0)
D TO^IBECEAU2(0) G:IBY<0 ADDQ
"RTN","IBECEA3",140,0)
;
"RTN","IBECEA3",141,0)
I IBXA>0,IBXA<4,IBGMT'=$$ISGMTPT^IBAGMT(DFN,IBTO) W !!,"The patient's GMT Copayment status changed within the specified period!",! G ADDQ
"RTN","IBECEA3",142,0)
;
"RTN","IBECEA3",143,0)
; - calculate unit charge for LTC inpatient in IBCHG
"RTN","IBECEA3",144,0)
I IBXA=9 S IBDT=IBFR,IBEVDA=$$EVF^IBECEA31(DFN,IBFR,IBTO,IBNH),IBEVDT=$E(IBFR,1,5)_"01" D:IBEVDA<1 G ADDQ:IBY<0 D COST^IBAUTL2 I $E(IBFR,1,5)'=$E(IBTO,1,5) W !!," LTC Copayment charges cannot go from one month to another." G ADDQ
"RTN","IBECEA3",145,0)
. D NOEV^IBECEA31 I '$G(IBDG)!(IBY<0) S IBY=-1 Q
"RTN","IBECEA3",146,0)
. ; - build the event record
"RTN","IBECEA3",147,0)
. N IBNHLTC S IBNHLTC=1 D ADEV^IBECEA31
"RTN","IBECEA3",148,0)
;
"RTN","IBECEA3",149,0)
;
"RTN","IBECEA3",150,0)
; - calculate units and total charge
"RTN","IBECEA3",151,0)
S IBUNIT=$$FMDIFF^XLFDT(IBTO,IBFR) S:IBXA'=3!(IBFR=IBTO) IBUNIT=IBUNIT+1
"RTN","IBECEA3",152,0)
I IBXA=1 D:IBGMT>0 D FEPR^IBECEA32 G ADDQ:IBY<0,EV
"RTN","IBECEA3",153,0)
. S IBGMTR=1
"RTN","IBECEA3",154,0)
. W !,"The patient has GMT Copayment Status! GMT rate must be applied.",!
"RTN","IBECEA3",155,0)
S IBCHG=IBCHG*IBUNIT S:IBXA=2 IBCHG=$S(IBCLDOL+IBCHG>IBMED:IBMED-IBCLDOL,1:IBCHG)
"RTN","IBECEA3",156,0)
;
"RTN","IBECEA3",157,0)
; adjust the LTC charge based on the calculated copay cap
"RTN","IBECEA3",158,0)
I IBXA=9 D CALC^IBAECI G:IBY<1!('IBCHG) ADDQ S IBDESC="LTC INPATIENT COPAY"
"RTN","IBECEA3",159,0)
;
"RTN","IBECEA3",160,0)
D CTBB^IBECEAU3 W:IBXA=3!(IBXA=9) " (for ",IBUNIT," day",$E("s",IBUNIT>1),")" W:IBGMTR " GMT Rate"
"RTN","IBECEA3",161,0)
;
"RTN","IBECEA3",162,0)
EV ; - find event record, or select admission for linkage
"RTN","IBECEA3",163,0)
I IBXA'=9 S IBEVDA=$$EVF^IBECEA31(DFN,IBFR,IBTO,IBNH)
"RTN","IBECEA3",164,0)
I IBEVDA'>0 D NOEV^IBECEA31 G ADDQ:IBY<0,PROC
"RTN","IBECEA3",165,0)
S IBSL=$P($G(^IB(+IBEVDA,0)),"^",4)
"RTN","IBECEA3",166,0)
W !!,"Linked charge to ",$$TYP(),"admission on ",$$DAT1^IBOUTL($P(IBEVDA,"^",2))," ("
"RTN","IBECEA3",167,0)
W $S($P(IBEVDA,"^",3)=9999999:"Still admitted)",1:"Discharged on "_$$DAT1^IBOUTL($P(IBEVDA,"^",3))_$S($P(IBEVDA,"^",3)>DT:" [pseudo])",1:")"))," ..."
"RTN","IBECEA3",168,0)
S IBEVDA=+IBEVDA
"RTN","IBECEA3",169,0)
I '$G(IBSIBC) D SPEC^IBECEA32(0,$O(^IBE(351.2,"AD",IBEVDA,0)))
"RTN","IBECEA3",170,0)
;
"RTN","IBECEA3",171,0)
;
"RTN","IBECEA3",172,0)
PROC ; - okay to proceed?
"RTN","IBECEA3",173,0)
D PROC^IBECEAU4("add") G:IBY<0 ADDQ
"RTN","IBECEA3",174,0)
;
"RTN","IBECEA3",175,0)
; - build the event record first if necessary
"RTN","IBECEA3",176,0)
I $G(IBDG),IBXA'=9 D @("ADEV^IBECEA3"_$S($G(IBFEEV):4,1:1)) G:IBY<0 ADDQ
"RTN","IBECEA3",177,0)
;
"RTN","IBECEA3",178,0)
; - disposition the special inpatient billing case, if necessary
"RTN","IBECEA3",179,0)
I $G(IBSIBC) D CEA^IBAMTI1(IBSIBC,IBEVDA)
"RTN","IBECEA3",180,0)
;
"RTN","IBECEA3",181,0)
; - generate entry in file #354.71 and #350
"RTN","IBECEA3",182,0)
I IBXA=5 W !!,"Building the new transaction... " S IBAM=$$ADD^IBARXMN(DFN,"^^"_IBEFDT_"^^P^^"_IBUNIT_"^"_IBCHG_"^"_IBDESC_"^^"_IBCHG_"^0^"_IBSITE_"^^^^^^^"_$G(IBTIER)) G:IBAM<0 ADDQ
"RTN","IBECEA3",183,0)
D ADD^IBECEAU3 G:IBY<0 ADDQ W "done."
"RTN","IBECEA3",184,0)
;
"RTN","IBECEA3",185,0)
; - pass the charge off to AR on-line
"RTN","IBECEA3",186,0)
W !,"Passing the charge directly to Accounts Receivable... "
"RTN","IBECEA3",187,0)
D PASSCH^IBECEA22 W:IBY>0 "done." G:IBY<0 ADDQ
"RTN","IBECEA3",188,0)
;
"RTN","IBECEA3",189,0)
; - review the special inpatient billing case
"RTN","IBECEA3",190,0)
I $G(IBSIBC1) D CHK^IBAMTI1(IBSIBC1,IBEVDA)
"RTN","IBECEA3",191,0)
;
"RTN","IBECEA3",192,0)
; - handle updating of clock
"RTN","IBECEA3",193,0)
I IBXA'=8,IBXA'=9 D CLUPD^IBECEA32
"RTN","IBECEA3",194,0)
;
"RTN","IBECEA3",195,0)
ADDQ ; - display error, rebuild list, and quit
"RTN","IBECEA3",196,0)
D ERR^IBECEAU4:IBY<0,PAUSE^IBECEAU S VALMBCK="R"
"RTN","IBECEA3",197,0)
I IBCOMMIT S IBBG=VALMBG W !,"Rebuilding list of charges..." D ARRAY^IBECEA0 S VALMBG=IBBG
"RTN","IBECEA3",198,0)
K IBMED,IBCLDA,IBCLDT,IBCLDOL,IBCLDAY,IBATYP,IBDG,IBSEQNO,IBXA,IBNH,IBBS,IBLIM,IBFR,IBTO,IBRTED,IBSIBC,IBSIBC1,IBBG,IBFEEV,IBAM
"RTN","IBECEA3",199,0)
K IBX,IBCHG,IBUNIT,IBDESC,IBDT,IBEVDT,IBEVDA,IBSL,IBNOS,IBN,IBTOTL,IBARTYP,IBIL,IBTRAN,IBAFY,IBCVA,IBCLSF,IBDD,IBND,VADM,VA,VAERR,IBADJMED
"RTN","IBECEA3",200,0)
ADDQ1 K IBEXSTAT,IBCOMMIT,IBCATC,IBCVAEL,IBLTCST,IBTIER,IBEFDT
"RTN","IBECEA3",201,0)
Q
"RTN","IBECEA3",202,0)
;
"RTN","IBECEA3",203,0)
;
"RTN","IBECEA3",204,0)
TYP() ; Return descriptive admission type.
"RTN","IBECEA3",205,0)
N X S X=""
"RTN","IBECEA3",206,0)
I IBNH'=2 G TYPQ
"RTN","IBECEA3",207,0)
I $G(IBADJMED) S X=$S(IBADJMED=1:"C",1:"H")
"RTN","IBECEA3",208,0)
E S X=$S($P($G(^IBE(350.1,+IBATYP,0)),"^")["NHCU":"C",1:"H")
"RTN","IBECEA3",209,0)
S X=$S(X="C":"CNH ",1:"Contract Hospital ")
"RTN","IBECEA3",210,0)
TYPQ Q X
"RTN","IBECEA33")
0^7^B23530923
"RTN","IBECEA33",1,0)
IBECEA33 ;ALB/CPM-Cancel/Edit/Add... More Add Utilities ; 23-APR-93
"RTN","IBECEA33",2,0)
;;2.0;INTEGRATED BILLING;**57,52,132,153,167,176,188,618**;21-MAR-94;Build 18
"RTN","IBECEA33",3,0)
;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","IBECEA33",4,0)
;
"RTN","IBECEA33",5,0)
NOCL ; Find the correct clock from the 'bill from' date.
"RTN","IBECEA33",6,0)
N IBCLST,IBALR S IBALR=0
"RTN","IBECEA33",7,0)
I IBCLDA S IBALR=1 W !!,"The Bill From date is prior to the start of the active clock..."
"RTN","IBECEA33",8,0)
D CLSTR^IBECEAU1(DFN,IBFR)
"RTN","IBECEA33",9,0)
I 'IBCLDA D G NOCLQ
"RTN","IBECEA33",10,0)
.I IBALR W !!,"This patient has no clock which would cover this date. You should use the",!,"Clock Maintenance option to adjust this patient's clocks before proceeding." S IBY=-1 Q
"RTN","IBECEA33",11,0)
.W !!,"Please note that I cannot find an active or closed clock for this patient",!,"on this date.",!
"RTN","IBECEA33",12,0)
D CLDATA^IBAUTL3,DED^IBAUTL3 I IBY<0 D NODED^IBECEAU3 G NOCLQ
"RTN","IBECEA33",13,0)
I IBXA=2,$P($G(^IBE(350.1,IBATYP,0)),"^",8)'["NHCU",IBCLDAY>90 S IBMED=IBMED/2
"RTN","IBECEA33",14,0)
I IBXA=1,IBCLDAY>90,$G(IBADJMED)'=1 S:$G(IBADJMED)=2 IBMED=IBMED/2 I '$G(IBADJMED) D MED^IBECEA34 G:IBY<0 NOCLQ
"RTN","IBECEA33",15,0)
S IBLIM=$S($P(IBCLST,"^",10):$P(IBCLST,"^",10),1:$$FMADD^XLFDT(IBCLDT,364))
"RTN","IBECEA33",16,0)
W !!?5,"This charge will be billed under the following closed clock:"
"RTN","IBECEA33",17,0)
W !!?6,"Begin Date: ",$$DAT1^IBOUTL(IBCLDT)," # Inpt Days: ",IBCLDAY
"RTN","IBECEA33",18,0)
W !?5,"Closed Date: ",$$DAT1^IBOUTL($P(IBCLST,"^",10))," ",$$INPT^IBECEAU(IBCLDAY)," 90 Days: $",+IBCLDOL
"RTN","IBECEA33",19,0)
I IBXA=2,IBCLDOL'<IBMED S IBY=-1 W !!?5,"This patient has been billed the full copayment under this billing clock!",!?5,"You cannot add another copay charge starting on this date."
"RTN","IBECEA33",20,0)
NOCLQ Q
"RTN","IBECEA33",21,0)
;
"RTN","IBECEA33",22,0)
OPT ; Check for a C&P exam and determine the outpatient copay rate.
"RTN","IBECEA33",23,0)
I $$CNP^IBECEAU(DFN,IBFR) D I IBY<0 G OPTQ
"RTN","IBECEA33",24,0)
.N DIR,DIRUT,DUOUT,DTOUT,Y
"RTN","IBECEA33",25,0)
.W !!,"This patient had a Compensation & Pension exam on this date."
"RTN","IBECEA33",26,0)
.S DIR(0)="Y",DIR("A")="Do you still want to add a charge"
"RTN","IBECEA33",27,0)
.S DIR("?")="Enter 'Y' to continue to add the charge, or 'N' or '^' to quit"
"RTN","IBECEA33",28,0)
.D ^DIR S:'Y IBY=-1
"RTN","IBECEA33",29,0)
;
"RTN","IBECEA33",30,0)
N IBDT,IBX,IBBS,IBTYPE
"RTN","IBECEA33",31,0)
S (IBDT,IBTO)=IBFR,IBX="O",(IBTYPE,IBUNIT)=1,IBEVDA="*"
"RTN","IBECEA33",32,0)
D:$G(IBATYP)=74 CHRG^IBECEAU5 D:$G(IBATYP)'=74 TYPE^IBAUTL2
"RTN","IBECEA33",33,0)
D CTBB^IBECEAU3:IBY>0
"RTN","IBECEA33",34,0)
OPTQ Q
"RTN","IBECEA33",35,0)
;
"RTN","IBECEA33",36,0)
CHTYP ; Ask for the Charge Type
"RTN","IBECEA33",37,0)
;*** IB*2.0*618 add check for inactive field when building the list of Action Types.
"RTN","IBECEA33",38,0)
S DIC="^IBE(350.1,",DIC(0)="AEMQZ",D="E",DIC("S")="I '$P($G(^(0)),U,12),$P(^(0),U)'[""MEDICARE"",$P(^(0),U)'[""CHAMPVA SUB""",DIC("A")="Select CHARGE TYPE: "
"RTN","IBECEA33",39,0)
D IX^DIC K DIC S IBATYP=+Y I Y<0 S IBY=-1 W !!,"No CHARGE TYPE entered - transaction cannot be completed." G CHTYPQ
"RTN","IBECEA33",40,0)
;
"RTN","IBECEA33",41,0)
; - perform charge type edits
"RTN","IBECEA33",42,0)
S IBSEQNO=$P(Y(0),"^",5),IBXA=$P(Y(0),"^",11),IBNH=$S(IBXA=1:2,IBXA=9&(Y(0)["FEE"):2,1:$P(Y(0),"^",8)["NHCU")
"RTN","IBECEA33",43,0)
I 'IBSEQNO S IBY="-1^IB023" G CHTYPQ
"RTN","IBECEA33",44,0)
I IBXA=7 G CHTYPQ
"RTN","IBECEA33",45,0)
I IBXA=6 G:IBCVAEL CHTYPQ W !!,"This patient does not have a Primary Eligibility of CHAMPVA.",! G CHTYP
"RTN","IBECEA33",46,0)
I 'IBCATC,IBXA'=5,IBXA'=8,IBXA'=9 W !!,"This patient has never been Means Test billable...",!,"You may only select a Pharmacy copay charge type.",! G CHTYP
"RTN","IBECEA33",47,0)
I +IBEXSTAT,IBXA=5 W !!,"Patient is Exempt from Medication Copayment",!,$P(IBEXSTAT,"^",4),! G CHTYP
"RTN","IBECEA33",48,0)
I IBLTCST=0,IBXA>7,IBXA<10 W !!,"This patient has no LTC (1010EC) information on file.",!,"You cannot select a LTC charge type.",! G CHTYP
"RTN","IBECEA33",49,0)
I +IBLTCST=1,IBXA>7,IBXA<10 W !!,"This patient is Exempt from LTC Charges.",! G CHTYP
"RTN","IBECEA33",50,0)
S:IBXA=2 IBBS=$O(^DGCR(399.1,"AC",IBATYP,0))
"RTN","IBECEA33",51,0)
I IBXA=3 D
"RTN","IBECEA33",52,0)
.N DIR,DIRUT,DTOUT,DUOUT,DIROUT,TYPE
"RTN","IBECEA33",53,0)
.S TYPE=$S(Y(0,0)["NHCU PER DIEM":"N",1:"H")
"RTN","IBECEA33",54,0)
.S DIR(0)="Y",DIR("A")=" Is this charge for a "_$S(TYPE="N":"CNH",1:"Contract Hospital")_" admission",DIR("B")="NO"
"RTN","IBECEA33",55,0)
.S DIR("?")="Enter '<CR>' if the charge is for a VA "_$S(TYPE="N":"NHCU",1:"Hospital")_" admission, 'Y' for a "_$S(TYPE="N":"CNH",1:"Contract Hospital")_" admission, or '^' to quit."
"RTN","IBECEA33",56,0)
.W ! D ^DIR I $D(DIRUT)!$D(DUOUT) S IBY=-1 Q
"RTN","IBECEA33",57,0)
.I Y S IBNH=2
"RTN","IBECEA33",58,0)
I IBXA>7,IBXA<10,IBNH'=2 S IBNH=3
"RTN","IBECEA33",59,0)
CHTYPQ Q
"RTN","IBECEA33",60,0)
;
"RTN","IBECEA33",61,0)
CLMSG ; Check the Medicare Deductible and Billing Clock
"RTN","IBECEA33",62,0)
I 'IBMED S IBCLDT=IBFR D DED^IBAUTL3 I IBY<0 D NODED^IBECEAU3 G CLMSGQ
"RTN","IBECEA33",63,0)
I "^1^2^"[("^"_IBXA_"^"),IBCLDA,IBFR'<IBCLDT,IBCLDOL'<IBMED S IBY=-1 D
"RTN","IBECEA33",64,0)
.W !!?5,*7,"This patient has already been billed the Medicare Deductible ($",IBMED,")"
"RTN","IBECEA33",65,0)
.W !?5,"for his current 90 days of care. If you know this not to be the case,"
"RTN","IBECEA33",66,0)
.W !?5,"please adjust the billing clock before proceeding."
"RTN","IBECEA33",67,0)
CLMSGQ Q
"RTN","IBP618A")
0^2^B84858209
"RTN","IBP618A",1,0)
IBP618A ;SAB/Albany - IB*2.0*618 POST INSTALL (CONT'D);12/11/17 2:10pm
"RTN","IBP618A",2,0)
;;2.0;Integrated Billing;**618**;Mar 20, 1995;Build 18
"RTN","IBP618A",3,0)
;Per VA Directive 6402, this routine should not be modified.
"RTN","IBP618A",4,0)
Q
"RTN","IBP618A",5,0)
;
"RTN","IBP618A",6,0)
ADDACT ; Add new ACTION TYPE ENTRIES (350.1)
"RTN","IBP618A",7,0)
;
"RTN","IBP618A",8,0)
N IBLOOP,IBDATA,FDA,IBARCAT,IBSVC,FDAIEN
"RTN","IBP618A",9,0)
N X,Y,DIE,DA,DR,DTOUT
"RTN","IBP618A",10,0)
N IBSL,IBSL1,IBSL1TXT,IBSL2,IBSL2TXT,IBSL3,IBSL3TX1,IBSL3TX2,IBSL3TX3
"RTN","IBP618A",11,0)
N IBIEN,IBLAST,IBBEG,IBEND
"RTN","IBP618A",12,0)
N IBEL,IBEL1,IBEL2,IBEL3,IBDQDASH
"RTN","IBP618A",13,0)
;
"RTN","IBP618A",14,0)
; Define the Logic field information
"RTN","IBP618A",15,0)
; Set Logic
"RTN","IBP618A",16,0)
S IBDQDASH=$c(95)_$c(34)_$c(45)_$c(34)_$c(95)
"RTN","IBP618A",17,0)
S IBSL2TXT="FEE OPT COPAYMENT"
"RTN","IBP618A",18,0)
S IBSL2="S IBDESC="_$C(34)_IBSL2TXT_$C(34)
"RTN","IBP618A",19,0)
S IBSL1TXT="INPT PER DIEM"
"RTN","IBP618A",20,0)
S IBSL1="S IBDESC="_$C(34)_IBSL1TXT_$C(34)
"RTN","IBP618A",21,0)
S IBSL3TX1="S:'$D(^(10)) X="""" I $D(^(10)) X ^(10) S X=$S($D(Y(0)):$P(Y(0),U),1:""UNK"") "
"RTN","IBP618A",22,0)
S IBSL3TX2="I $D(Y(0)) S X=X_""-""_$S($$DRUG^IBRXUTL1(+$P(Y(0),U,6))'="""":$$DRUG^IBRXUTL1(+$P(Y(0),U,6)),1:"_"""UNK DRUG"""_")"
"RTN","IBP618A",23,0)
S IBSL3TX3=",X=$E(X,1,18)_""-""_$S($D(IBUNIT):IBUNIT,$D(IBX):$P(IBX,U,2),1:"""")"
"RTN","IBP618A",24,0)
S IBSL3=IBSL3TX1_IBSL3TX2_IBSL3TX3
"RTN","IBP618A",25,0)
;
"RTN","IBP618A",26,0)
; Eligibility Logic
"RTN","IBP618A",27,0)
S IBEL1="S X=0,X1="""_",X2="_""""_" "
"RTN","IBP618A",28,0)
S IBEL2="G:'$D(VAEL) 1^IBAERR I VAEL(4),'+VAEL(3),'IBDOM,'$$RXEXMT^IBARXEU0(DFN,DT) "
"RTN","IBP618A",29,0)
S IBEL3="S X=1,X2=$P(^IBE(350.1,DA,0),"_""_"^"_""_",4) D COST^IBAUTL"
"RTN","IBP618A",30,0)
S IBEL=IBEL1_IBEL2_IBEL3
"RTN","IBP618A",31,0)
S IBLAST=1
"RTN","IBP618A",32,0)
S IBIEN="" F S IBIEN=$O(^IBE(350.1,IBIEN)) Q:IBIEN="" S:$G(IBIEN) IBLAST=IBIEN
"RTN","IBP618A",33,0)
S IBBEG=IBLAST
"RTN","IBP618A",34,0)
;
"RTN","IBP618A",35,0)
D MES^XPDUTL(" -> Adding new AT entries to file 350.1 ...")
"RTN","IBP618A",36,0)
F IBLOOP=1:1 S IBDATA=$T(ACTDAT+IBLOOP) Q:IBDATA=" ;;END" D
"RTN","IBP618A",37,0)
. ;Clear the array
"RTN","IBP618A",38,0)
. K FDA
"RTN","IBP618A",39,0)
. ;Extract the new ACTION TYPE to be added.
"RTN","IBP618A",40,0)
. Q:$D(^IBE(350.1,"B",$P(IBDATA,";",3))) ; Quit loop if action type exist
"RTN","IBP618A",41,0)
. ;Store in array for adding to the file (#350.1).
"RTN","IBP618A",42,0)
. S FDA(350.1,"+1,",.01)=$P(IBDATA,";",3) ;Name
"RTN","IBP618A",43,0)
. S FDA(350.1,"+1,",.02)=$P(IBDATA,";",4) ;Abbreviation
"RTN","IBP618A",44,0)
. S IBARCAT=$P(IBDATA,";",5) ;AR Cat (Charge Code)
"RTN","IBP618A",45,0)
. S:IBARCAT'="" IBARCAT=$O(^PRCA(430.2,"B",IBARCAT,"")) ;Find local IEN for AR Cat
"RTN","IBP618A",46,0)
. S FDA(350.1,"+1,",.03)=IBARCAT
"RTN","IBP618A",47,0)
. S IBSVC=$P(IBDATA,";",6) ;Service
"RTN","IBP618A",48,0)
. S:IBSVC'="" IBSVC=$O(^DIC(49,"B",IBSVC,"")) ;Find local IEN for Service
"RTN","IBP618A",49,0)
. S FDA(350.1,"+1,",.04)=IBSVC
"RTN","IBP618A",50,0)
. S FDA(350.1,"+1,",.05)=$P(IBDATA,";",7) ;Seq Number
"RTN","IBP618A",51,0)
. S FDA(350.1,"+1,",.08)=$P(IBDATA,";",8) ;User Lookup Name
"RTN","IBP618A",52,0)
. S FDA(350.1,"+1,",.1)=$P(IBDATA,";",9) ;Place on Hold
"RTN","IBP618A",53,0)
. S FDA(350.1,"+1,",.11)=$P(IBDATA,";",10) ;Billing Group
"RTN","IBP618A",54,0)
. I $P(IBDATA,";",11)'="" S FDA(350.1,"+1,",10)=$P(IBDATA,";",11) ;Parent Logic
"RTN","IBP618A",55,0)
. I $P(IBDATA,";",12)'="" S FDA(350.1,"+1,",20)=@$P(IBDATA,";",12) ;Set Logic
"RTN","IBP618A",56,0)
. I $P(IBDATA,";",13)'="" S FDA(350.1,"+1,",30)=$P(IBDATA,";",13) ;Full Logic
"RTN","IBP618A",57,0)
. I $P(IBDATA,";",14)'="" S FDA(350.1,"+1,",40)=@$P(IBDATA,";",14) ;Eligibility Logic
"RTN","IBP618A",58,0)
. ;Add to the IB file.
"RTN","IBP618A",59,0)
. D UPDATE^DIE(,"FDA","FDAIEN")
"RTN","IBP618A",60,0)
. S FDAIEN=FDAIEN(1) K FDAIEN(1)
"RTN","IBP618A",61,0)
D MES^XPDUTL(" New ACTION TYPES added.")
"RTN","IBP618A",62,0)
Q
"RTN","IBP618A",63,0)
;
"RTN","IBP618A",64,0)
ACTDAT ; Data for the new ACTION TYPE fields. (All categories will be updated)
"RTN","IBP618A",65,0)
;;CHOICE (INPT) CANCEL;CAN CCCI;CC CHOICE FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",66,0)
;;CHOICE (INPT) NEW;NEW CCCI;CC CHOICE FIRST PARTY;BUSINESS OFFICE;1;CHOICE INPATIENT;1;1;;;;
"RTN","IBP618A",67,0)
;;CHOICE (INPT) UPDATE;UPD CCCI;CC CHOICE FIRST PARTY;BUSINESS OFFICE;3;;1;1;;;;
"RTN","IBP618A",68,0)
;;CHOICE (PER DIEM) CANCEL;CAN CCCP;CC CHOICE FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",69,0)
;;CHOICE (PER DIEM) NEW;NEW CCCP;CC CHOICE FIRST PARTY;BUSINESS OFFICE;1;CHOICE PER DIEM;1;1;;IBSL1;;
"RTN","IBP618A",70,0)
;;CHOICE (PER DIEM) UPDATE;UPD CCCP;CC CHOICE FIRST PARTY;BUSINESS OFFICE;3;;1;1;;;;
"RTN","IBP618A",71,0)
;;CHOICE (OPT) CANCEL;CAN CCCO;CC CHOICE FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",72,0)
;;CHOICE (OPT) NEW;NEW CCCO;CC CHOICE FIRST PARTY;BUSINESS OFFICE;1;CHOICE OUTPATIENT;1;4;;IBSL2;;
"RTN","IBP618A",73,0)
;;CHOICE (OPT) UPDATE;UPD CCCO;CC CHOICE FIRST PARTY;BUSINESS OFFICE;3;;1;4;;;;
"RTN","IBP618A",74,0)
;;CHOICE (RX) CANCEL;CAN CCCR;CC CHOICE FIRST PARTY;PHARMACY;2;;;;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;
"RTN","IBP618A",75,0)
;;CHOICE (RX) NEW;NEW CCCR;CC CHOICE FIRST PARTY;PHARMACY;1;CHOICE RX;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;IBEL
"RTN","IBP618A",76,0)
;;CHOICE (RX) UPDATE;UPD CCCR;CC CHOICE FIRST PARTY;PHARMACY;3;;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;
"RTN","IBP618A",77,0)
;;CC (INPT) CANCEL;CAN CCIP;CC FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",78,0)
;;CC (INPT) NEW;NEW CCIP;CC FIRST PARTY;BUSINESS OFFICE;1;CC INPATIENT;1;1;;;;
"RTN","IBP618A",79,0)
;;CC (INPT) UPDATE;UPD CCIP;CC FIRST PARTY;BUSINESS OFFICE;3;;1;1;;;;
"RTN","IBP618A",80,0)
;;CC (PER DIEM) CANCEL;CAN CCPD;CC FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",81,0)
;;CC (PER DIEM) NEW;NEW CCPD;CC FIRST PARTY;BUSINESS OFFICE;1;CC PER DIEM;1;1;;IBSL1;;
"RTN","IBP618A",82,0)
;;CC (PER DIEM) UPDATE;UPD CCPD;CC FIRST PARTY;BUSINESS OFFICE;3;;1;1;;;;
"RTN","IBP618A",83,0)
;;CC (OPT) CANCEL;CAN CCO;CC FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",84,0)
;;CC (OPT) NEW;NEW CCO;CC FIRST PARTY;BUSINESS OFFICE;1;CC OUTPATIENT;1;4;;IBSL2;;
"RTN","IBP618A",85,0)
;;CC (OPT) UPDATE;UPD CCO;CC FIRST PARTY;BUSINESS OFFICE;3;;1;4;;;;
"RTN","IBP618A",86,0)
;;CC (RX) CANCEL;CAN CCRX;CC FIRST PARTY;PHARMACY;2;;;;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;
"RTN","IBP618A",87,0)
;;CC (RX) NEW;NEW CCRX;CC FIRST PARTY;PHARMACY;1;CC RX COPAY;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;IBEL
"RTN","IBP618A",88,0)
;;CC (RX) UPDATE;UPD CCRX;CC FIRST PARTY;PHARMACY;3;;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;
"RTN","IBP618A",89,0)
;;CCN (INPT) CANCEL;CAN CCNI;CCN FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",90,0)
;;CCN (INPT) NEW;NEW CCNI;CCN FIRST PARTY;BUSINESS OFFICE;1;CCN INPATIENT;1;1;;;;
"RTN","IBP618A",91,0)
;;CCN (INPT) UPDATE;UPD CCNI;CCN FIRST PARTY;BUSINESS OFFICE;3;;1;1;;;;
"RTN","IBP618A",92,0)
;;CCN (PER DIEM) CANCEL;CAN CCNP;CCN FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",93,0)
;;CCN (PER DIEM) NEW;NEW CCNP;CCN FIRST PARTY;BUSINESS OFFICE;1;CCN PER DIEM;1;1;;IBSL1;;
"RTN","IBP618A",94,0)
;;CCN (PER DIEM) UPDATE;UPD CCNP;CCN FIRST PARTY;BUSINESS OFFICE;3;;1;1;;;;
"RTN","IBP618A",95,0)
;;CCN (OPT) CANCEL;CAN CCNO;CCN FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",96,0)
;;CCN (OPT) NEW;NEW CCNO;CCN FIRST PARTY;BUSINESS OFFICE;1;CCN OUTPATIENT;1;4;;IBSL2;;
"RTN","IBP618A",97,0)
;;CCN (OPT) UPDATE;UPD CCNO;CCN FIRST PARTY;BUSINESS OFFICE;3;;1;4;;;;
"RTN","IBP618A",98,0)
;;CCN (RX) CANCEL;CAN CCNR;CCN FIRST PARTY;PHARMACY;2;;;;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;
"RTN","IBP618A",99,0)
;;CCN (RX) NEW;NEW CCNR;CCN FIRST PARTY;PHARMACY;1;CCN RX COPAY;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;IBEL
"RTN","IBP618A",100,0)
;;CCN (RX) UPDATE;UPD CCNR;CCN FIRST PARTY;PHARMACY;3;;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;
"RTN","IBP618A",101,0)
;;CC MTF (INPT) CANCEL;CAN CCDI;CC MTF FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",102,0)
;;CC MTF (INPT) NEW;NEW CCDI;CC MTF FIRST PARTY;BUSINESS OFFICE;1;CC MTF INPATIENT;1;1;;;;
"RTN","IBP618A",103,0)
;;CC MTF (INPT) UPDATE;UPD CCDI;CC MTF FIRST PARTY;BUSINESS OFFICE;3;;1;1;;;;
"RTN","IBP618A",104,0)
;;CC MTF (PER DIEM) CANCEL;CAN CCDP;CC MTF FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",105,0)
;;CC MTF (PER DIEM) NEW;NEW CCDP;CC MTF FIRST PARTY;BUSINESS OFFICE;1;CC MTF PER DIEM;1;1;;IBSL1;;
"RTN","IBP618A",106,0)
;;CC MTF (PER DIEM) UPDATE;UPD CCDP;CC MTF FIRST PARTY;BUSINESS OFFICE;3;;1;1;;;;
"RTN","IBP618A",107,0)
;;CC MTF (OPT) CANCEL;CAN CCDO;CC MTF FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",108,0)
;;CC MTF (OPT) NEW;NEW CCDO;CC MTF FIRST PARTY;BUSINESS OFFICE;1;CC MTF OUTPATIENT;1;4;;IBSL2;;
"RTN","IBP618A",109,0)
;;CC MTF (OPT) UPDATE;UPD CCDO;CC MTF FIRST PARTY;BUSINESS OFFICE;3;;1;4;;;;
"RTN","IBP618A",110,0)
;;CC MTF (RX) CANCEL;CAN CCDR;CC MTF FIRST PARTY;PHARMACY;2;;;;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;
"RTN","IBP618A",111,0)
;;CC MTF (RX) NEW;NEW CCDR;CC MTF FIRST PARTY;PHARMACY;1;CC MTF RX COPAY;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;IBEL
"RTN","IBP618A",112,0)
;;CC MTF (RX) UPDATE;UPD CCDR;CC MTF FIRST PARTY;PHARMACY;3;;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;
"RTN","IBP618A",113,0)
;;LTC CC INPT CNH CANCEL;C CCCNH;CC FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",114,0)
;;LTC CC INPT CNH NEW;N CCCNH;CC FIRST PARTY;BUSINESS OFFICE;1;CC LTC INPT CNH;1;9;;;;
"RTN","IBP618A",115,0)
;;LTC CC INPT CNH UPDATE;U CCCNH;CC FIRST PARTY;BUSINESS OFFICE;3;;1;9;;;;
"RTN","IBP618A",116,0)
;;LTC CC INPT RESPITE CANCEL;C CCIRES;CC FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",117,0)
;;LTC CC INPT RESPITE NEW;N CCIRES;CC FIRST PARTY;BUSINESS OFFICE;1;CC LTC INPT RESPITE;1;9;;;;
"RTN","IBP618A",118,0)
;;LTC CC INPT RESPITE UPDATE;U CCIRES;CC FIRST PARTY;BUSINESS OFFICE;3;;1;9;;;;
"RTN","IBP618A",119,0)
;;LTC CC OPT ADHC CANCEL;C CCADHC;CC FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",120,0)
;;LTC CC OPT ADHC NEW;N CCADHC;CC FIRST PARTY;BUSINESS OFFICE;1;CC LTC OPT ADHC;1;8;;;;
"RTN","IBP618A",121,0)
;;LTC CC OPT ADHC UPDATE;U CCADHC;CC FIRST PARTY;BUSINESS OFFICE;3;;1;8;;;;
"RTN","IBP618A",122,0)
;;LTC CC OPT RESPITE CANCEL;C CCORES;CC FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",123,0)
;;LTC CC OPT RESPITE NEW;N CCORES;CC FIRST PARTY;BUSINESS OFFICE;1;CC LTC OPT RESPITE;1;8;;;;
"RTN","IBP618A",124,0)
;;LTC CC OPT RESPITE UPDATE;U CCORES;CC FIRST PARTY;BUSINESS OFFICE;3;;1;8;;;;
"RTN","IBP618A",125,0)
;;LTC CCN INPT CNH CANCEL;C CCNCNH;CCN FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",126,0)
;;LTC CCN INPT CNH NEW;N CCNCNH;CCN FIRST PARTY;BUSINESS OFFICE;1;CCN LTC INPT CNH;1;9;;;;
"RTN","IBP618A",127,0)
;;LTC CCN INPT CNH UPDATE;U CCNCNH;CCN FIRST PARTY;BUSINESS OFFICE;3;;1;9;;;;
"RTN","IBP618A",128,0)
;;LTC CCN INPT RESPITE CANCEL;C CCNIRS;CCN FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",129,0)
;;LTC CCN INPT RESPITE NEW;N CCNIRS;CCN FIRST PARTY;BUSINESS OFFICE;1;CCN LTC INPT RESPITE;1;9;;;;
"RTN","IBP618A",130,0)
;;LTC CCN INPT RESPITE UPDATE;U CCNIRS;CCN FIRST PARTY;BUSINESS OFFICE;3;;1;9;;;;
"RTN","IBP618A",131,0)
;;LTC CCN OPT ADHC CANCEL;C CCNOAD;CCN FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",132,0)
;;LTC CCN OPT ADHC NEW;N CCNOAD;CCN FIRST PARTY;BUSINESS OFFICE;1;CCN LTC OPT ADHC;1;8;;;;
"RTN","IBP618A",133,0)
;;LTC CCN OPT ADHC UPDATE;U CCNOAD;CCN FIRST PARTY;BUSINESS OFFICE;3;;1;8;;;;
"RTN","IBP618A",134,0)
;;LTC CCN OPT RESPITE CANCEL;C CCNORS;CCN FIRST PARTY;BUSINESS OFFICE;2;;;;;;;;
"RTN","IBP618A",135,0)
;;LTC CCN OPT RESPITE NEW;N CCNORS;CCN FIRST PARTY;BUSINESS OFFICE;1;CCN LTC OPT RESPITE;1;8;;;;
"RTN","IBP618A",136,0)
;;LTC CCN OPT RESPITE UPDATE;U CCNORS;CCN FIRST PARTY;BUSINESS OFFICE;3;;1;8;;;;
"RTN","IBP618A",137,0)
;;LTC CHOICE INPT CNH CANCEL;C CCCCNH;CC CHOICE FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",138,0)
;;LTC CHOICE INPT CNH NEW;N CCCCNH;CC CHOICE FIRST PARTY;BUSINESS OFFICE;1;CHOICE LTC INPT CNH;1;9;;;;
"RTN","IBP618A",139,0)
;;LTC CHOICE INPT CNH UPDATE;U CCCCNH;CC CHOICE FIRST PARTY;BUSINESS OFFICE;3;;1;9;;;;
"RTN","IBP618A",140,0)
;;LTC CHOICE INPT RESPITE CANCEL;C CCCIRS;CC CHOICE FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",141,0)
;;LTC CHOICE INPT RESPITE NEW;N CCCIRS;CC CHOICE FIRST PARTY;BUSINESS OFFICE;1;CHOICE LTC INP RESPITE;1;9;;;;
"RTN","IBP618A",142,0)
;;LTC CHOICE INPT RESPITE UPDATE;U CCCIRS;CC CHOICE FIRST PARTY;BUSINESS OFFICE;3;;1;9;;;;
"RTN","IBP618A",143,0)
;;LTC CHOICE OPT ADHC CANCEL;C CCCOAD;CC CHOICE FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",144,0)
;;LTC CHOICE OPT ADHC NEW;N CCCOAD;CC CHOICE FIRST PARTY;BUSINESS OFFICE;1;CHOICE LTC OPT ADHC;1;8;;;;
"RTN","IBP618A",145,0)
;;LTC CHOICE OPT ADHC UPDATE;U CCCOAD;CC CHOICE FIRST PARTY;BUSINESS OFFICE;3;;1;8;;;;
"RTN","IBP618A",146,0)
;;LTC CHOICE OPT RESPITE CANCEL;C CCCORS;CC CHOICE FIRST PARTY;BUSINESS OFFICE;2;;;;;;;
"RTN","IBP618A",147,0)
;;LTC CHOICE OPT RESPITE NEW;N CCCORS;CC CHOICE FIRST PARTY;BUSINESS OFFICE;1;CHOICE LTC OPT RESPITE;1;8;;;;
"RTN","IBP618A",148,0)
;;LTC CHOICE OPT RESPITE UPDATE;U CCCORS;CC CHOICE FIRST PARTY;BUSINESS OFFICE;3;;1;8;;;;
"RTN","IBP618A",149,0)
;;END
"RTN","IBP618B")
0^1^B104039647
"RTN","IBP618B",1,0)
IBP618B ;SAB/Albany - IB*2.0*618 POST INSTALL (CONT'D);12/11/17 2:10pm
"RTN","IBP618B",2,0)
;;2.0;Integrated Billing;**618**;Mar 20, 1995;Build 18
"RTN","IBP618B",3,0)
;Per VA Directive 6402, this routine should not be modified.
"RTN","IBP618B",4,0)
Q
"RTN","IBP618B",5,0)
;
"RTN","IBP618B",6,0)
UPDACT ; Update the Action Type Fields for the new Action Types
"RTN","IBP618B",7,0)
;
"RTN","IBP618B",8,0)
N IBDATA,IBLOOP,IBIEN,IBACTNM
"RTN","IBP618B",9,0)
N X,Y,DIE,DA,DR,DTOUT,DATA ;^DIE variables
"RTN","IBP618B",10,0)
D MES^XPDUTL(" -> Updating the Action Type Fields in file 350.1 ...")
"RTN","IBP618B",11,0)
F IBLOOP=2:1 S IBDATA=$T(UPDDAT+IBLOOP) Q:IBDATA=" ;;END" D
"RTN","IBP618B",12,0)
. S IBACTNM=$P(IBDATA,";",3) ;Name of the Action Type
"RTN","IBP618B",13,0)
. ;Retrieve the IEN.
"RTN","IBP618B",14,0)
. S IBIEN=$O(^IBE(350.1,"B",IBACTNM,""))
"RTN","IBP618B",15,0)
. I IBIEN="" D MES^XPDUTL(" -> Action Type "_IBACTNM_" Is not in the Action Type file.") Q
"RTN","IBP618B",16,0)
. ;File the update
"RTN","IBP618B",17,0)
. S DR=".06///"_$P(IBDATA,";",4)_";"
"RTN","IBP618B",18,0)
. S DR=DR_".07///"_$P(IBDATA,";",5)_";"
"RTN","IBP618B",19,0)
. S DR=DR_".09///"_$P(IBDATA,";",6)
"RTN","IBP618B",20,0)
. Q:DR=""
"RTN","IBP618B",21,0)
. S DIE="^IBE(350.1,",DA=IBIEN
"RTN","IBP618B",22,0)
. D ^DIE
"RTN","IBP618B",23,0)
. K DR ;Clear update array before next use
"RTN","IBP618B",24,0)
D MES^XPDUTL(" -> Update completed ...")
"RTN","IBP618B",25,0)
;Clear the array
"RTN","IBP618B",26,0)
Q
"RTN","IBP618B",27,0)
;
"RTN","IBP618B",28,0)
UPDDAT ;
"RTN","IBP618B",29,0)
;;Action Type;Cancellation Action;Update Action;New Action
"RTN","IBP618B",30,0)
;;CHOICE (INPT) CANCEL;CHOICE (INPT) CANCEL;CHOICE (INPT) UPDATE;CHOICE (INPT) NEW
"RTN","IBP618B",31,0)
;;CHOICE (INPT) NEW;CHOICE (INPT) CANCEL;CHOICE (INPT) UPDATE;CHOICE (INPT) NEW
"RTN","IBP618B",32,0)
;;CHOICE (INPT) UPDATE;CHOICE (INPT) CANCEL;CHOICE (INPT) UPDATE;CHOICE (INPT) NEW
"RTN","IBP618B",33,0)
;;CHOICE (PER DIEM) CANCEL;CHOICE (PER DIEM) CANCEL;CHOICE (PER DIEM) UPDATE;CHOICE (PER DIEM) NEW
"RTN","IBP618B",34,0)
;;CHOICE (PER DIEM) NEW;CHOICE (PER DIEM) CANCEL;CHOICE (PER DIEM) UPDATE;CHOICE (PER DIEM) NEW
"RTN","IBP618B",35,0)
;;CHOICE (PER DIEM) UPDATE;CHOICE (PER DIEM) CANCEL;CHOICE (PER DIEM) UPDATE;CHOICE (PER DIEM) NEW
"RTN","IBP618B",36,0)
;;CHOICE (OPT) CANCEL;CHOICE (OPT) CANCEL;CHOICE (OPT) UPDATE;CHOICE (OPT) NEW
"RTN","IBP618B",37,0)
;;CHOICE (OPT) NEW;CHOICE (OPT) CANCEL;CHOICE (OPT) UPDATE;CHOICE (OPT) NEW
"RTN","IBP618B",38,0)
;;CHOICE (OPT) UPDATE;CHOICE (OPT) CANCEL;CHOICE (OPT) UPDATE;CHOICE (OPT) NEW
"RTN","IBP618B",39,0)
;;CHOICE (RX) CANCEL;CHOICE (RX) CANCEL;CHOICE (RX) UPDATE;CHOICE (RX) NEW
"RTN","IBP618B",40,0)
;;CHOICE (RX) NEW;CHOICE (RX) CANCEL;CHOICE (RX) UPDATE;CHOICE (RX) NEW
"RTN","IBP618B",41,0)
;;CHOICE (RX) UPDATE;CHOICE (RX) CANCEL;CHOICE (RX) UPDATE;CHOICE (RX) NEW
"RTN","IBP618B",42,0)
;;CC (INPT) CANCEL;CC (INPT) CANCEL;CC (INPT) UPDATE;CC (INPT) NEW
"RTN","IBP618B",43,0)
;;CC (INPT) NEW;CC (INPT) CANCEL;CC (INPT) UPDATE;CC (INPT) NEW
"RTN","IBP618B",44,0)
;;CC (INPT) UPDATE;CC (INPT) CANCEL;CC (INPT) UPDATE;CC (INPT) NEW
"RTN","IBP618B",45,0)
;;CC (PER DIEM) CANCEL;CC (PER DIEM) CANCEL;CC (PER DIEM) UPDATE;CC (PER DIEM) NEW
"RTN","IBP618B",46,0)
;;CC (PER DIEM) NEW;CC (PER DIEM) CANCEL;CC (PER DIEM) UPDATE;CC (PER DIEM) NEW
"RTN","IBP618B",47,0)
;;CC (PER DIEM) UPDATE;CC (PER DIEM) CANCEL;CC (PER DIEM) UPDATE;CC (PER DIEM) NEW
"RTN","IBP618B",48,0)
;;CC (OPT) CANCEL;CC (OPT) CANCEL;CC (OPT) UPDATE;CC (OPT) NEW
"RTN","IBP618B",49,0)
;;CC (OPT) NEW;CC (OPT) CANCEL;CC (OPT) UPDATE;CC (OPT) NEW
"RTN","IBP618B",50,0)
;;CC (OPT) UPDATE;CC (OPT) CANCEL;CC (OPT) UPDATE;CC (OPT) NEW
"RTN","IBP618B",51,0)
;;CC (RX) CANCEL;CC (RX) CANCEL;CC (RX) UPDATE;CC (RX) NEW
"RTN","IBP618B",52,0)
;;CC (RX) NEW;CC (RX) CANCEL;CC (RX) UPDATE;CC (RX) NEW
"RTN","IBP618B",53,0)
;;CC (RX) UPDATE;CC (RX) CANCEL;CC (RX) UPDATE;CC (RX) NEW
"RTN","IBP618B",54,0)
;;CCN (INPT) CANCEL;CCN (INPT) CANCEL;CCN (INPT) UPDATE;CCN (INPT) NEW
"RTN","IBP618B",55,0)
;;CCN (INPT) NEW;CCN (INPT) CANCEL;CCN (INPT) UPDATE;CCN (INPT) NEW
"RTN","IBP618B",56,0)
;;CCN (INPT) UPDATE;CCN (INPT) CANCEL;CCN (INPT) UPDATE;CCN (INPT) NEW
"RTN","IBP618B",57,0)
;;CCN (PER DIEM) CANCEL;CCN (PER DIEM) CANCEL;CCN (PER DIEM) UPDATE;CCN (PER DIEM) NEW
"RTN","IBP618B",58,0)
;;CCN (PER DIEM) NEW;CCN (PER DIEM) CANCEL;CCN (PER DIEM) UPDATE;CCN (PER DIEM) NEW
"RTN","IBP618B",59,0)
;;CCN (PER DIEM) UPDATE;CCN (PER DIEM) CANCEL;CCN (PER DIEM) UPDATE;CCN (PER DIEM) NEW
"RTN","IBP618B",60,0)
;;CCN (OPT) CANCEL;CCN (OPT) CANCEL;CCN (OPT) UPDATE;CCN (OPT) NEW
"RTN","IBP618B",61,0)
;;CCN (OPT) NEW;CCN (OPT) CANCEL;CCN (OPT) UPDATE;CCN (OPT) NEW
"RTN","IBP618B",62,0)
;;CCN (OPT) UPDATE;CCN (OPT) CANCEL;CCN (OPT) UPDATE;CCN (OPT) NEW
"RTN","IBP618B",63,0)
;;CCN (RX) CANCEL;CCN (RX) CANCEL;CCN (RX) UPDATE;CCN (RX) NEW
"RTN","IBP618B",64,0)
;;CCN (RX) NEW;CCN (RX) CANCEL;CCN (RX) UPDATE;CCN (RX) NEW
"RTN","IBP618B",65,0)
;;CCN (RX) UPDATE;CCN (RX) CANCEL;CCN (RX) UPDATE;CCN (RX) NEW
"RTN","IBP618B",66,0)
;;CC MTF (INPT) CANCEL;CC MTF (INPT) CANCEL;CC MTF (INPT) UPDATE;CC MTF (INPT) NEW
"RTN","IBP618B",67,0)
;;CC MTF (INPT) NEW;CC MTF (INPT) CANCEL;CC MTF (INPT) UPDATE;CC MTF (INPT) NEW
"RTN","IBP618B",68,0)
;;CC MTF (INPT) UPDATE;CC MTF (INPT) CANCEL;CC MTF (INPT) UPDATE;CC MTF (INPT) NEW
"RTN","IBP618B",69,0)
;;CC MTF (PER DIEM) CANCEL;CC MTF (PER DIEM) CANCEL;CC MTF (PER DIEM) UPDATE;CC MTF (PER DIEM) NEW
"RTN","IBP618B",70,0)
;;CC MTF (PER DIEM) NEW;CC MTF (PER DIEM) CANCEL;CC MTF (PER DIEM) UPDATE;CC MTF (PER DIEM) NEW
"RTN","IBP618B",71,0)
;;CC MTF (PER DIEM) UPDATE;CC MTF (PER DIEM) CANCEL;CC MTF (PER DIEM) UPDATE;CC MTF (PER DIEM) NEW
"RTN","IBP618B",72,0)
;;CC MTF (OPT) CANCEL;CC MTF (OPT) CANCEL;CC MTF (OPT) UPDATE;CC MTF (OPT) NEW
"RTN","IBP618B",73,0)
;;CC MTF (OPT) NEW;CC MTF (OPT) CANCEL;CC MTF (OPT) UPDATE;CC MTF (OPT) NEW
"RTN","IBP618B",74,0)
;;CC MTF (OPT) UPDATE;CC MTF (OPT) CANCEL;CC MTF (OPT) UPDATE;CC MTF (OPT) NEW
"RTN","IBP618B",75,0)
;;CC MTF (RX) CANCEL;CC MTF (RX) CANCEL;CC MTF (RX) UPDATE;CC MTF (RX) NEW
"RTN","IBP618B",76,0)
;;CC MTF (RX) NEW;CC MTF (RX) CANCEL;CC MTF (RX) UPDATE;CC MTF (RX) NEW
"RTN","IBP618B",77,0)
;;CC MTF (RX) UPDATE;CC MTF (RX) CANCEL;CC MTF (RX) UPDATE;CC MTF (RX) NEW
"RTN","IBP618B",78,0)
;;LTC CC INPT CNH CANCEL;LTC CC INPT CNH CANCEL;LTC CC INPT CNH UPDATE;LTC CC INPT CNH NEW
"RTN","IBP618B",79,0)
;;LTC CC INPT CNH NEW;LTC CC INPT CNH CANCEL;LTC CC INPT CNH UPDATE;LTC CC INPT CNH NEW
"RTN","IBP618B",80,0)
;;LTC CC INPT CNH UPDATE;LTC CC INPT CNH CANCEL;LTC CC INPT CNH UPDATE;LTC CC INPT CNH NEW
"RTN","IBP618B",81,0)
;;LTC CC INPT RESPITE CANCEL;LTC CC INPT RESPITE CANCEL;LTC CC INPT RESPITE UPDATE;LTC CC INPT RESPITE NEW
"RTN","IBP618B",82,0)
;;LTC CC INPT RESPITE NEW;LTC CC INPT RESPITE CANCEL;LTC CC INPT RESPITE UPDATE;LTC CC INPT RESPITE NEW
"RTN","IBP618B",83,0)
;;LTC CC INPT RESPITE UPDATE;LTC CC INPT RESPITE CANCEL;LTC CC INPT RESPITE UPDATE;LTC CC INPT RESPITE NEW
"RTN","IBP618B",84,0)
;;LTC CC OPT ADHC CANCEL;LTC CC OPT ADHC CANCEL;LTC CC OPT ADHC UPDATE;LTC CC OPT ADHC NEW
"RTN","IBP618B",85,0)
;;LTC CC OPT ADHC NEW;LTC CC OPT ADHC CANCEL;LTC CC OPT ADHC UPDATE;LTC CC OPT ADHC NEW
"RTN","IBP618B",86,0)
;;LTC CC OPT ADHC UPDATE;LTC CC OPT ADHC CANCEL;LTC CC OPT ADHC UPDATE;LTC CC OPT ADHC NEW
"RTN","IBP618B",87,0)
;;LTC CC OPT RESPITE CANCEL;LTC CC OPT RESPITE CANCEL;LTC CC OPT RESPITE UPDATE;LTC CC OPT RESPITE NEW
"RTN","IBP618B",88,0)
;;LTC CC OPT RESPITE NEW;LTC CC OPT RESPITE CANCEL;LTC CC OPT RESPITE UPDATE;LTC CC OPT RESPITE NEW
"RTN","IBP618B",89,0)
;;LTC CC OPT RESPITE UPDATE;LTC CC OPT RESPITE CANCEL;LTC CC OPT RESPITE UPDATE;LTC CC OPT RESPITE NEW
"RTN","IBP618B",90,0)
;;LTC CCN INPT CNH CANCEL;LTC CCN INPT CNH CANCEL;LTC CCN INPT CNH UPDATE;LTC CCN INPT CNH NEW
"RTN","IBP618B",91,0)
;;LTC CCN INPT CNH NEW;LTC CCN INPT CNH CANCEL;LTC CCN INPT CNH UPDATE;LTC CCN INPT CNH NEW
"RTN","IBP618B",92,0)
;;LTC CCN INPT CNH UPDATE;LTC CCN INPT CNH CANCEL;LTC CCN INPT CNH UPDATE;LTC CCN INPT CNH NEW
"RTN","IBP618B",93,0)
;;LTC CCN INPT RESPITE CANCEL;LTC CCN INPT RESPITE CANCEL;LTC CCN INPT RESPITE UPDATE;LTC CCN INPT RESPITE NEW
"RTN","IBP618B",94,0)
;;LTC CCN INPT RESPITE NEW;LTC CCN INPT RESPITE CANCEL;LTC CCN INPT RESPITE UPDATE;LTC CCN INPT RESPITE NEW
"RTN","IBP618B",95,0)
;;LTC CCN INPT RESPITE UPDATE;LTC CCN INPT RESPITE CANCEL;LTC CCN INPT RESPITE UPDATE;LTC CCN INPT RESPITE NEW
"RTN","IBP618B",96,0)
;;LTC CCN OPT ADHC CANCEL;LTC CCN OPT ADHC CANCEL;LTC CCN OPT ADHC UPDATE;LTC CCN OPT ADHC NEW
"RTN","IBP618B",97,0)
;;LTC CCN OPT ADHC NEW;LTC CCN OPT ADHC CANCEL;LTC CCN OPT ADHC UPDATE;LTC CCN OPT ADHC NEW
"RTN","IBP618B",98,0)
;;LTC CCN OPT ADHC UPDATE;LTC CCN OPT ADHC CANCEL;LTC CCN OPT ADHC UPDATE;LTC CCN OPT ADHC NEW
"RTN","IBP618B",99,0)
;;LTC CCN OPT RESPITE CANCEL;LTC CCN OPT RESPITE CANCEL;LTC CCN OPT RESPITE UPDATE;LTC CCN OPT RESPITE NEW
"RTN","IBP618B",100,0)
;;LTC CCN OPT RESPITE NEW;LTC CCN OPT RESPITE CANCEL;LTC CCN OPT RESPITE UPDATE;LTC CCN OPT RESPITE NEW
"RTN","IBP618B",101,0)
;;LTC CCN OPT RESPITE UPDATE;LTC CCN OPT RESPITE CANCEL;LTC CCN OPT RESPITE UPDATE;LTC CCN OPT RESPITE NEW
"RTN","IBP618B",102,0)
;;LTC CHOICE INPT CNH CANCEL;LTC CHOICE INPT CNH CANCEL;LTC CHOICE INPT CNH UPDATE;LTC CHOICE INPT CNH NEW
"RTN","IBP618B",103,0)
;;LTC CHOICE INPT CNH NEW;LTC CHOICE INPT CNH CANCEL;LTC CHOICE INPT CNH UPDATE;LTC CHOICE INPT CNH NEW
"RTN","IBP618B",104,0)
;;LTC CHOICE INPT CNH UPDATE;LTC CHOICE INPT CNH CANCEL;LTC CHOICE INPT CNH UPDATE;LTC CHOICE INPT CNH NEW
"RTN","IBP618B",105,0)
;;LTC CHOICE INPT RESPITE CANCEL;LTC CHOICE INPT RESPITE CANCEL;LTC CHOICE INPT RESPITE UPDATE;LTC CHOICE INPT RESPITE NEW
"RTN","IBP618B",106,0)
;;LTC CHOICE INPT RESPITE NEW;LTC CHOICE INPT RESPITE CANCEL;LTC CHOICE INPT RESPITE UPDATE;LTC CHOICE INPT RESPITE NEW
"RTN","IBP618B",107,0)
;;LTC CHOICE INPT RESPITE UPDATE;LTC CHOICE INPT RESPITE CANCEL;LTC CHOICE INPT RESPITE UPDATE;LTC CHOICE INPT RESPITE NEW
"RTN","IBP618B",108,0)
;;LTC CHOICE OPT ADHC CANCEL;LTC CHOICE OPT ADHC CANCEL;LTC CHOICE OPT ADHC UPDATE;LTC CHOICE OPT ADHC NEW
"RTN","IBP618B",109,0)
;;LTC CHOICE OPT ADHC NEW;LTC CHOICE OPT ADHC CANCEL;LTC CHOICE OPT ADHC UPDATE;LTC CHOICE OPT ADHC NEW
"RTN","IBP618B",110,0)
;;LTC CHOICE OPT ADHC UPDATE;LTC CHOICE OPT ADHC CANCEL;LTC CHOICE OPT ADHC UPDATE;LTC CHOICE OPT ADHC NEW
"RTN","IBP618B",111,0)
;;LTC CHOICE OPT RESPITE CANCEL;LTC CHOICE OPT RESPITE CANCEL;LTC CHOICE OPT RESPITE UPDATE;LTC CHOICE OPT RESPITE NEW
"RTN","IBP618B",112,0)
;;LTC CHOICE OPT RESPITE NEW;LTC CHOICE OPT RESPITE CANCEL;LTC CHOICE OPT RESPITE UPDATE;LTC CHOICE OPT RESPITE NEW
"RTN","IBP618B",113,0)
;;LTC CHOICE OPT RESPITE UPDATE;LTC CHOICE OPT RESPITE CANCEL;LTC CHOICE OPT RESPITE UPDATE;LTC CHOICE OPT RESPITE NEW
"RTN","IBP618B",114,0)
;;END
"RTN","IBP618B",115,0)
;
"RTN","IBP618B",116,0)
ADDACTCH ; Update the Action Charges
"RTN","IBP618B",117,0)
;
"RTN","IBP618B",118,0)
N IBLOOP,IBARRAY,IBACTYP,IBACTCH,IBATIEN,IBACIEN,IBEFDT,IBACTIEN,IBARYIEN,IBDATA
"RTN","IBP618B",119,0)
N X,Y,DIE,DA,DR,DTOUT,FDA,FDAIEN
"RTN","IBP618B",120,0)
;
"RTN","IBP618B",121,0)
; Define the Logic field information
"RTN","IBP618B",122,0)
; Set Logic
"RTN","IBP618B",123,0)
;
"RTN","IBP618B",124,0)
D MES^XPDUTL(" -> Adding new ACTION CHARGE entries to file 350.2 ...")
"RTN","IBP618B",125,0)
F IBLOOP=1:1:52 D
"RTN","IBP618B",126,0)
. S IBDATA=$T(ACTCHDAT+IBLOOP)
"RTN","IBP618B",127,0)
. ;Retrieve the mapping
"RTN","IBP618B",128,0)
. S IBACTYP=$P(IBDATA,";",3),IBACTCH=$P(IBDATA,";",4)
"RTN","IBP618B",129,0)
. ;determine if new entry for Action type/Action Charge combination
"RTN","IBP618B",130,0)
. S IBATIEN=$O(^IBE(350.1,"B",IBACTYP,""))
"RTN","IBP618B",131,0)
. S IBACIEN=$O(^IBE(350.2,"B",IBACTCH,""))
"RTN","IBP618B",132,0)
. ;
"RTN","IBP618B",133,0)
. ; Find the latest entry to copy from
"RTN","IBP618B",134,0)
. S IBEFDT=0 F S IBEFDT=$O(^IBE(350.2,"C",IBEFDT)) Q:'IBEFDT D
"RTN","IBP618B",135,0)
. . I $D(^IBE(350.2,"C",IBEFDT,IBACIEN)) S IBACTIEN=IBACIEN
"RTN","IBP618B",136,0)
. ; Add the new entry
"RTN","IBP618B",137,0)
. K FDA,IBARRAY ;Clear the arrays
"RTN","IBP618B",138,0)
. ;
"RTN","IBP618B",139,0)
. S IBARYIEN=IBACIEN_","
"RTN","IBP618B",140,0)
. ;Store in array for adding to the file (#350.1).
"RTN","IBP618B",141,0)
. D GETS^DIQ(350.2,IBARYIEN,"*","I","IBARRAY")
"RTN","IBP618B",142,0)
. S FDA(350.2,"+1,",.01)=IBARRAY(350.2,IBARYIEN,.01,"I") ;Key
"RTN","IBP618B",143,0)
. S FDA(350.2,"+1,",.02)=IBARRAY(350.2,IBARYIEN,.02,"I") ;Effective Date
"RTN","IBP618B",144,0)
. S FDA(350.2,"+1,",.03)=IBATIEN ;Action Type
"RTN","IBP618B",145,0)
. S FDA(350.2,"+1,",.04)=IBARRAY(350.2,IBARYIEN,.04,"I") ;Unit Charged Fixed
"RTN","IBP618B",146,0)
. S FDA(350.2,"+1,",.05)=IBARRAY(350.2,IBARYIEN,.05,"I") ;Inactivation Date
"RTN","IBP618B",147,0)
. S FDA(350.2,"+1,",.06)=IBARRAY(350.2,IBARYIEN,.06,"I") ;Additional Amount
"RTN","IBP618B",148,0)
. S FDA(350.2,"+1,",.07)=IBARRAY(350.2,IBARYIEN,.07,"I") ;CoPayment Tier
"RTN","IBP618B",149,0)
. S FDA(350.2,"+1,",10)=IBARRAY(350.2,IBARYIEN,10,"I") ;Unit Charge Logic
"RTN","IBP618B",150,0)
. S FDA(350.2,"+1,",20)=IBARRAY(350.2,IBARYIEN,20,"I") ;Additional Amount Logic
"RTN","IBP618B",151,0)
. ;Add to the IB file.
"RTN","IBP618B",152,0)
. D UPDATE^DIE(,"FDA","FDAIEN")
"RTN","IBP618B",153,0)
. S FDAIEN=FDAIEN(1) K FDAIEN(1)
"RTN","IBP618B",154,0)
D MES^XPDUTL(" New ACTION CHARGES added.")
"RTN","IBP618B",155,0)
K FDA,IBARRAY
"RTN","IBP618B",156,0)
Q
"RTN","IBP618B",157,0)
;
"RTN","IBP618B",158,0)
ACTCHDAT ; Action Charge Data
"RTN","IBP618B",159,0)
;;CHOICE (PER DIEM) NEW;FEE SERV INPT PER DIEM
"RTN","IBP618B",160,0)
;;CC (PER DIEM) NEW;FEE SERV INPT PER DIEM
"RTN","IBP618B",161,0)
;;CCN (PER DIEM) NEW;FEE SERV INPT PER DIEM
"RTN","IBP618B",162,0)
;;CC MTF (PER DIEM) NEW;FEE SERV INPT PER DIEM
"RTN","IBP618B",163,0)
;;LTC CC INPT CNH NEW;FEE LTC INPT CNH
"RTN","IBP618B",164,0)
;;LTC CCN INPT CNH NEW;FEE LTC INPT CNH
"RTN","IBP618B",165,0)
;;LTC CHOICE INPT CNH NEW;FEE LTC INPT CNH
"RTN","IBP618B",166,0)
;;LTC CC INPT RESPITE NEW;FEE LTC INPT RESPITE
"RTN","IBP618B",167,0)
;;LTC CCN INPT RESPITE NEW;FEE LTC INPT RESPITE
"RTN","IBP618B",168,0)
;;LTC CHOICE INPT RESPITE NEW;FEE LTC INPT RESPITE
"RTN","IBP618B",169,0)
;;LTC CC OPT ADHC NEW;FEE LTC OPT ADHC
"RTN","IBP618B",170,0)
;;LTC CCN OPT ADHC NEW;FEE LTC OPT ADHC
"RTN","IBP618B",171,0)
;;LTC CHOICE OPT ADHC NEW;FEE LTC OPT ADHC
"RTN","IBP618B",172,0)
;;LTC CC OPT RESPITE NEW;FEE LTC OPT RESPITE
"RTN","IBP618B",173,0)
;;LTC CCN OPT RESPITE NEW;FEE LTC OPT RESPITE
"RTN","IBP618B",174,0)
;;LTC CHOICE OPT RESPITE NEW;FEE LTC OPT RESPITE
"RTN","IBP618B",175,0)
;;CHOICE (RX) CANCEL;FEE SERV RX1
"RTN","IBP618B",176,0)
;;CHOICE (RX) CANCEL;FEE SERV RX3
"RTN","IBP618B",177,0)
;;CHOICE (RX) CANCEL;FEE SERV RX4
"RTN","IBP618B",178,0)
;;CHOICE (RX) NEW;FEE SERV RX1
"RTN","IBP618B",179,0)
;;CHOICE (RX) NEW;FEE SERV RX3
"RTN","IBP618B",180,0)
;;CHOICE (RX) NEW;FEE SERV RX4
"RTN","IBP618B",181,0)
;;CHOICE (RX) UPDATE;FEE SERV RX1
"RTN","IBP618B",182,0)
;;CHOICE (RX) UPDATE;FEE SERV RX3
"RTN","IBP618B",183,0)
;;CHOICE (RX) UPDATE;FEE SERV RX4
"RTN","IBP618B",184,0)
;;CC (RX) CANCEL;FEE SERV RX1
"RTN","IBP618B",185,0)
;;CC (RX) CANCEL;FEE SERV RX3
"RTN","IBP618B",186,0)
;;CC (RX) CANCEL;FEE SERV RX4
"RTN","IBP618B",187,0)
;;CC (RX) NEW;FEE SERV RX1
"RTN","IBP618B",188,0)
;;CC (RX) NEW;FEE SERV RX3
"RTN","IBP618B",189,0)
;;CC (RX) NEW;FEE SERV RX4
"RTN","IBP618B",190,0)
;;CC (RX) UPDATE;FEE SERV RX1
"RTN","IBP618B",191,0)
;;CC (RX) UPDATE;FEE SERV RX3
"RTN","IBP618B",192,0)
;;CC (RX) UPDATE;FEE SERV RX4
"RTN","IBP618B",193,0)
;;CCN (RX) CANCEL;FEE SERV RX1
"RTN","IBP618B",194,0)
;;CCN (RX) CANCEL;FEE SERV RX3
"RTN","IBP618B",195,0)
;;CCN (RX) CANCEL;FEE SERV RX4
"RTN","IBP618B",196,0)
;;CCN (RX) NEW;FEE SERV RX1
"RTN","IBP618B",197,0)
;;CCN (RX) NEW;FEE SERV RX3
"RTN","IBP618B",198,0)
;;CCN (RX) NEW;FEE SERV RX4
"RTN","IBP618B",199,0)
;;CCN (RX) UPDATE;FEE SERV RX1
"RTN","IBP618B",200,0)
;;CCN (RX) UPDATE;FEE SERV RX3
"RTN","IBP618B",201,0)
;;CCN (RX) UPDATE;FEE SERV RX4
"RTN","IBP618B",202,0)
;;CC MTF (RX) CANCEL;FEE SERV RX1
"RTN","IBP618B",203,0)
;;CC MTF (RX) CANCEL;FEE SERV RX3
"RTN","IBP618B",204,0)
;;CC MTF (RX) CANCEL;FEE SERV RX4
"RTN","IBP618B",205,0)
;;CC MTF (RX) NEW;FEE SERV RX1
"RTN","IBP618B",206,0)
;;CC MTF (RX) NEW;FEE SERV RX3
"RTN","IBP618B",207,0)
;;CC MTF (RX) NEW;FEE SERV RX4
"RTN","IBP618B",208,0)
;;CC MTF (RX) UPDATE;FEE SERV RX1
"RTN","IBP618B",209,0)
;;CC MTF (RX) UPDATE;FEE SERV RX3
"RTN","IBP618B",210,0)
;;CC MTF (RX) UPDATE;FEE SERV RX4
"RTN","IBP618B",211,0)
Q
"VER")
8.0^22.2
"^DD",350.1,350.1,.12,0)
INACTIVE^St11^^0;12^
"^DD",350.1,350.1,.12,3)
Enter the code which indicates whether or not you would like to inactivate this action type.
"^DD",350.1,350.1,.12,21,0)
^^1^1^3180312^
"^DD",350.1,350.1,.12,21,1,0)
This field indicates whether or not this Action Type has been inactivated.
"^DD",350.1,350.1,.12,"DT")
3180312
**END**
**END**