IB20P645 ;SAB/Albany - IB*2.0*645 POST INSTALL;12/11/17 2:10pm
;;2.0;Integrated Billing;**645**;Mar 20, 1995;Build 16
;Per VA Directive 6402, this routine should not be modified.
Q
;
POSTINIT ;Post Install for IB*2.0*645
D BMES^XPDUTL(" >> Starting the Post-Initialization routine for IB*2.0*645 ")
; Update Community Care No Fault Rate Schedules if necessary and add 2019 CC RX Rate Schedules
D UPDNFRS
D UPDTRRS
D RTIN
D CORACT
D BMES^XPDUTL(" >> End of the Post-Initialization routine for IB*2.0*645")
Q
;
UPDNFRS ; Update No Fault and 2019 RX Rate Schedules (363)
D MES^XPDUTL(" -> Updating Community Care No Fault and RX Rate Schedules for file 363 ...")
N IBA,IBCNT,IBI,IBLN,IBFN,IBRT,IBBS,IBCNTCS,IBDISP,IBJ,IBLNCS,IBCS,IBCSFN,IBADMIN,DD,DO
N DLAYGO,DIC,DIE,DA,DR,RXDT,X,Y,IBCPNM,IBEDT,IBNM
S IBCNT=0
F IBI=2:1 S IBLN=$P($T(RSF+IBI),";;",2) Q:IBLN="END" I $E(IBLN)?1A D
. ;Check for problems
. S IBBS=$P(IBLN,U,4) I IBBS'="" S IBBS=$$MCCRUTL(IBBS,13) Q:'IBBS ;Billable service invalid
. S IBRT=$P(IBLN,U,2),IBRT=$O(^DGCR(399.3,"B",IBRT,0)) D Q:'IBRT
.. I 'IBRT D MSG(" **** Rate Type "_$P(IBLN,U,2)_" not defined, RS "_$P(IBLN,U,1)_" not created")
.. 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")
. ;No problems found, so create entry
. ;Locate existing entry.
. S Y=-1,IBNM=$P(IBLN,U),IBEDT=$P(IBLN,U,6)
. S IBJ=0 F S IBJ=$O(^IBE(363,"B",IBNM,IBJ)) Q:'IBJ D Q:Y>-1
. . I ($D(^IBE(363,IBJ,11))>9),(IBNM'["RX"),(IBNM'["PHARM") S Y=0 Q ;Rate Schedule correctly defined, skip.
. . I (IBNM'["RX"),(IBNM'["PHARM") S Y=IBJ Q ;Non RX Rate schedule
. . I $P(^IBE(363,IBJ,0),U,5)="" S Y=IBJ Q ;Empty RX Rate schedule, use it.
. . I ($P(^IBE(363,IBJ,0),U,5)=IBEDT),($D(^IBE(363,IBJ,11))>9) S Y=0 Q ;Rate rate exists correctly, skip
. . I ($P(^IBE(363,IBJ,0),U,5)=IBEDT),($D(^IBE(363,IBJ,11))<10) S Y=IBJ ;Rate rate exists incorrectly, update it.
. Q:Y=0 ; correctly defined, no need to update. Go find next schedule.
. I Y=-1 D ; If no entry found in Rate Schedule file, create a new entry
.. K DD,DO,Y
.. S DLAYGO=363,DIC="^IBE(363,",DIC(0)="L",X=$P(IBLN,U,1)
.. D FILE^DICN K DIC,DINUM,DLAYGO
. I Y<1 K X,Y Q
. S IBFN=+Y,IBCNT=IBCNT+1
. S IBCPNM=$P(IBLN,U,5)
. S RXDT=$$RXDT(IBCPNM,IBEDT)
. S DR=".02////"_IBRT_";.03////"_$P(IBLN,U,3) I +IBBS S DR=DR_";.04////"_IBBS
. S DR=DR_";.05////"_$P(RXDT,U)
. I $P(RXDT,U,2) S DR=DR_";.06////"_$P(RXDT,U,2)
. I (($P(IBLN,U,1)["RX")!($P(IBLN,U,1)["PHARM")),($G(IBDISP)]"") S DR=DR_";1.01///"_IBDISP
. I (($P(IBLN,U,1)["RX")!($P(IBLN,U,1)["PHARM")),($G(IBADMIN)]"") S DR=DR_";10////"_IBADMIN
. S DIE="^IBE(363,",DA=+Y D ^DIE K DIE,DA,DR,X,Y
. S IBCNTCS=0
. ; Retrieve name of Charge Set to copy
. I IBRT="" D MSG(" **** Rate Type "_$P(IBLN,U,2)_" missing Charge Set Information, RS "_$P(IBLN,U,1)_" not created") Q
. ; add all Reasonable Charges Charge Sets to the Rate Schedule.
. S IBCNTCS=$$RSCS(IBFN,IBCPNM,$P(RXDT,U))
. D MES^XPDUTL(" Total Reasonable Charge Set"_$S(IBCNTCS=1:" ",1:"s ")_IBCNTCS_" added to Rate Schedule "_$P(IBLN,U,1)_".")
D MES^XPDUTL(" Rate Schedules completed.")
Q ;ADDRS
;
UPDTRRS ; Update TRICARE and DOD Rate Schedules (363) to interagency
D MES^XPDUTL(" -> Updating TRICARE and DOD Rate Schedules for file 363 ...")
N IBA,IBCNT,IBI,IBLN,IBFN,IBRT,IBBS,IBCNTCS,IBDISP,IBJ,IBLNCS,IBCS,IBCSFN,IBADMIN,DD,DO
N DLAYGO,DIC,DIE,DA,DR,RXDT,X,Y,IBCPNM,IBEDT,IBNM,DIK,IBK
S IBCNT=0
F IBI=2:1 S IBLN=$P($T(TRSF+IBI),";;",2) Q:IBLN="END" I $E(IBLN)?1A D
. ;Check for problems
. S IBBS=$P(IBLN,U,4) I IBBS'="" S IBBS=$$MCCRUTL(IBBS,13) Q:'IBBS ;Billable service invalid
. S IBRT=$P(IBLN,U,2),IBRT=$O(^DGCR(399.3,"B",IBRT,0)) D Q:'IBRT
.. I 'IBRT D MSG(" **** Rate Type "_$P(IBLN,U,2)_" not defined, RS "_$P(IBLN,U,1)_" not created")
.. 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")
. ;Locate existing entry.
. S Y=-1,IBNM=$P(IBLN,U),IBEDT=$P(IBLN,U,6)
. S IBJ=0 F S IBJ=$O(^IBE(363,"B",IBNM,IBJ)) Q:'IBJ D Q:Y>-1
. . I (IBNM'["RX"),(IBNM'["PHARM") S Y=IBJ Q ;Non RX Rate schedule
. . I $P(^IBE(363,IBJ,0),U,5)="" S Y=IBJ Q ;Empty RX Rate schedule, use it.
. . I ($P(^IBE(363,IBJ,0),U,5)=IBEDT) S Y=IBJ ;Correct Pharmacy rate schedule found
. Q:Y=-1 ; If no entry Quit
. ; Cleanly Remove existing Charge sets from the Rate Schedule.
. S IBK=0 F S IBK=$O(^IBE(363,IBJ,11,IBK)) Q:'IBK D
. . N X,Y,DA,DIK
. . S DA=IBK,DA(1)=IBJ S DIK="^IBE(363,"_DA(1)_",11,"
. . D ^DIK
. ;Update the Rate Schedule with IA info and add the new IA charge sets
. S IBFN=+IBJ,IBCNT=IBCNT+1
. S IBCPNM=$P(IBLN,U,5)
. S RXDT=$$RXDT(IBCPNM,IBEDT)
. S DR=".02////"_IBRT_";.03////"_$P(IBLN,U,3) I +IBBS S DR=DR_";.04////"_IBBS
. S DR=DR_";.05////"_$P(RXDT,U)
. I $P(RXDT,U,2) S DR=DR_";.06////"_$P(RXDT,U,2)
. I (($P(IBLN,U,1)["RX")!($P(IBLN,U,1)["PHARM")),($G(IBDISP)]"") S DR=DR_";1.01///"_IBDISP
. I (($P(IBLN,U,1)["RX")!($P(IBLN,U,1)["PHARM")),($G(IBADMIN)]"") S DR=DR_";10////"_IBADMIN
. S DIE="^IBE(363,",DA=+IBJ D ^DIE K DIE,DA,DR,X,Y
. S IBCNTCS=0
. ; Retrieve name of Charge Set to copy
. I IBRT="" D MSG(" **** Rate Type "_$P(IBLN,U,2)_" missing Charge Set Information, RS "_$P(IBLN,U,1)_" not created") Q
. ; add all Reasonable Charges Charge Sets to the Rate Schedule.
. S IBCNTCS=$$RSCS(IBFN,IBCPNM,$P(RXDT,U))
. D MES^XPDUTL(" Total Reasonable Charge Set"_$S(IBCNTCS=1:" ",1:"s ")_IBCNTCS_" added to Rate Schedule "_$P(IBLN,U,1)_".")
D MES^XPDUTL(" Rate Schedules completed.")
Q ;UPDTRRS
;
RTIN ; Inactivate the DOD SNF Rate Schedules to prevent duplicate charges
D MES^XPDUTL(" -> Inactivating the DOD SNF Rate Schedules ...")
N IBA,IBCNT,IBI,IBLN,IBFN,IBRT,IBBS,IBCNTCS,IBDISP,IBJ,IBLNCS,IBCS,IBCSFN,IBADMIN,DD,DO
N DLAYGO,DIC,DIE,DA,DR,RXDT,X,Y,IBCPNM,IBEDT,IBNM,DIK,IBK
S IBCNT=0
F IBI=1:1 S IBLN=$P($T(RTINDATA+IBI),";;",2) Q:IBLN="END" D
. ;Locate existing entry.
. S IBNM=$P(IBLN,U)
. S IBJ=0,IBJ=$O(^IBE(363,"B",IBNM,IBJ))
. Q:'IBJ
. ;Update the Rate Schedule an INACTIVE Date
. S IBFN=+IBJ,IBCNT=IBCNT+1
. S DR=".06////"_$P(IBLN,U,2)
. S DIE="^IBE(363,",DA=+IBJ D ^DIE K DIE,DA,DR,X,Y
. S IBCNTCS=0
D MES^XPDUTL(" DOD Rate Schedules inactivated.")
Q
;
RSCS(IBFN,IBCPNM,RXDT) ; add existing Charge Sets to FR
; copy the Charge Sets from the corresponding RI RS (v2)
; IBFN - Rate Schedule IEN
; IBCPNM - Charge Set to copy
; RXDT - last effective date of charge set being copied.
N IBCNT,IBNRS,IBRSNM,IBTY,IBVDT,IBCOPY,IBCS,IBCS0,IBXFN,IBCSFN,IBCSNM,IBCSAA,IBNAME
S (IBCNT,IBCOPY)=0
S IBNRS=$G(^IBE(363,+$G(IBFN),0)),IBRSNM=$P(IBNRS,"^",1)
S IBTY=$P(IBNRS,"^",3)
S IBVDT=RXDT
;Q:IBVDT="" 0
S IBCOPY=+$$RSEXISTS(IBVDT,IBCPNM)
I 'IBCOPY G RSCSQ
I +$P($G(^IBE(363,+IBCOPY,0)),U,3)=IBTY D
. S IBXFN=0 F S IBXFN=$O(^IBE(363,IBCOPY,11,IBXFN)) Q:'IBXFN D
.. S IBCS=$G(^IBE(363,IBCOPY,11,IBXFN,0)),IBCSFN=+IBCS
.. I +$$RSCSFILE(IBFN,$P($G(^IBE(363.1,IBCSFN,0)),U,1),$P(IBCS,U,2)) S IBCNT=IBCNT+1
RSCSQ Q IBCNT
;
;
RSCSFILE(IBFN,IBCSNM,IBCSAA) ; Add Charge Set to a Rate Schedule
N IBX,DD,DO,DLAYGO,DIC,DA,DR,X,Y,IBCSFN S IBX=0
I $G(^IBE(363,+$G(IBFN),0))="" G RSCSFQ
I $G(IBCSNM)="" G RSCSFQ
S IBCSFN=$O(^IBE(363.1,"B",IBCSNM,0)) I 'IBCSFN G RSCSFQ
I $O(^IBE(363,IBFN,11,"B",IBCSFN,0)) G RSCSFQ
S DLAYGO=363,DA(1)=+IBFN,DIC="^IBE(363,"_DA(1)_",11,",DIC(0)="L"
S X=IBCSNM,DIC("DR")=".02///"_$G(IBCSAA),DIC("P")="363.0011P"
D ^DIC S:+Y IBX=1
RSCSFQ Q IBX
;
;
RSEXISTS(IBVDT,IBNAME) ; return RS IFN if Rate Schedule exists for Effective Date
N IBX,IBRSFN,IBRS0 S IBX=0
S IBRSFN=0 F S IBRSFN=$O(^IBE(363,IBRSFN)) Q:'IBRSFN D I IBX Q
. S IBRS0=$G(^IBE(363,IBRSFN,0))
. I $P(IBRS0,U,1)=IBNAME,$P(IBRS0,U,5)=IBVDT S IBX=IBRSFN
Q IBX
;
MSG(X) ;
N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
S IBA(IBX)=$G(X)
Q ;MSG
;
MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
N IBX,IBY S IBY=""
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
Q IBY
;
RXDT(IBCPNM,IBEDT) ;Copy the active charge schedule from charge set being copied.
; update Fee information if Pharmacy.
N IBEFLG,IBD
S IBEDT=$G(IBEDT) ; Set to NULL if not passed in
S IBCS=""
;If no Effective Date sent, get the latest entry.
I IBEDT="" S IBCS=$O(^IBE(363,"B",IBCPNM,IBCS),-1)
;If Effective date sent, loop through the entries to find the entry
; with the correct effective date.
I (IBEDT=3150101),(IBCPNM="TR-RX") S IBEDT=3150220 ; FOR TR-PHARM 2015 populating only
I IBEDT'="" D
. S IBEFLG=0
. F S IBCS=$O(^IBE(363,"B",IBCPNM,IBCS),-1) Q:'IBCS D Q:IBEFLG
.. S IBD=$G(^IBE(363,IBCS,0))
.. I $P(IBD,U,5)=IBEDT S IBEFLG=1
Q:IBCS="" ""
S IBCS0=^IBE(363,IBCS,0)
I (IBCPNM["RX")!(IBCPNM["PHARM") S IBDISP=$P($G(^IBE(363,IBCS,1)),U,1),IBADMIN=$G(^IBE(363,IBCS,10))
Q $P(IBCS0,U,5,6) ;return effective and end dates
;
RSF ;Rate Schedules (363) for Community Care No Fault Rate Types and 2019 Pharmacy
;;Rate Schedule Name^Rate Type^Bill Type^Billable Service^Rate Schedule to copy for Charge Sets
;;CCC-NF-INPT^CHOICE NO-FAULT AUTO^1^^RI-INPT
;;CCC-NF-SNF^CHOICE NO-FAULT AUTO^1^SKILLED NURSING^RI-SNF
;;CCC-NF-OPT^CHOICE NO-FAULT AUTO^3^^RI-OPT
;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^RI-RX^3140101
;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^RI-RX^3150101
;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^RI-RX^3160101
;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^RI-RX^3170101
;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^RI-RX^3180101
;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^RI-RX^3190101
;;CC-NF-INPT^CC NO-FAULT AUTO^1^^RI-INPT
;;CC-NF-SNF^CC NO-FAULT AUTO^1^SKILLED NURSING^RI-SNF
;;CC-NF-OPT^CC NO-FAULT AUTO^3^^RI-OPT
;;CC-NF-RX^CC NO-FAULT AUTO^3^^RI-RX^3140101
;;CC-NF-RX^CC NO-FAULT AUTO^3^^RI-RX^3150101
;;CC-NF-RX^CC NO-FAULT AUTO^3^^RI-RX^3160101
;;CC-NF-RX^CC NO-FAULT AUTO^3^^RI-RX^3170101
;;CC-NF-RX^CC NO-FAULT AUTO^3^^RI-RX^3180101
;;CC-NF-RX^CC NO-FAULT AUTO^3^^RI-RX^3190101
;;CCN-NF-INPT^CCN NO-FAULT AUTO^1^^RI-INPT
;;CCN-NF-SNF^CCN NO-FAULT AUTO^1^SKILLED NURSING^RI-SNF
;;CCN-NF-OPT^CCN NO-FAULT AUTO^3^^RI-OPT
;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^RI-RX^3140101
;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^RI-RX^3150101
;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^RI-RX^3160101
;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^RI-RX^3170101
;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^RI-RX^3180101
;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^RI-RX^3190101
;;CCC-RI-RX^CHOICE REIMB INS^3^^RI-RX^3190101
;;CC-RI-RX^CC REIMB INS^3^^RI-RX^3190101
;;CCN-RI-RX^CCN REIMB INS^3^^RI-RX^3190101
;;CC-DOD-RX^CC MTF REIMB INS^3^^RI-RX^3190101
;;CCC-TF-RX^CHOICE TORT FEASOR^3^^TF-RX^3190101
;;CC-TF-RX^CC TORT FEASOR^3^^TF-RX^3190101
;;CCN-TF-RX^CCN TORT FEASOR^3^^TF-RX^3190101
;;CCC-WC-RX^CHOICE WORKERS' COMP^3^^WC-RX^3190101
;;CC-WC-RX^CC WORKERS' COMP^3^^WC-RX^3190101
;;CCN-WC-RX^CCN WORKERS' COMP^3^^WC-RX^3190101
;;TR-PHARM^TRICARE PHARMACY^3^^TR-RX^3190101
;;END
TRSF ;New Rate Schedules (363) for the new DOD and TRICARE Rate Types
;;DOD-DIS EXAM-OPT^DOD DISABILITY EVALUATION^3^OUTPATIENT VISIT^RI-OPT
;;DOD-SCI-INPT^DOD SPINAL CORD INJURY^1^INPATIENT^IA-INPT
;;DOD-SCI-OPT^DOD SPINAL CORD INJURY^3^OUTPATIENT VISIT^RI-OPT
;;DOD-TBI-INPT^DOD TRAUMATIC BRAIN INJURY^1^INPATIENT^IA-INPT
;;DOD-TBI-OPT^DOD TRAUMATIC BRAIN INJURY^3^OUTPATIENT VISIT^RI-OPT
;;DOD-BR-INPT^DOD BLIND REHABILITATION^1^INPATIENT^IA-INPT
;;DOD-BR-OPT^DOD BLIND REHABILITATION^3^OUTPATIENT VISIT^RI-OPT
;;TR-DENTAL^TRICARE DENTAL^3^OUTPATIENT VISIT^RI-OPT
;;TR-PHARM^TRICARE PHARMACY^3^^TR-RX^3140101
;;TR-PHARM^TRICARE PHARMACY^3^^TR-RX^3150101
;;TR-PHARM^TRICARE PHARMACY^3^^TR-RX^3160101
;;TR-PHARM^TRICARE PHARMACY^3^^TR-RX^3170101
;;TR-PHARM^TRICARE PHARMACY^3^^TR-RX^3180101
;;END
RTINDATA ;Rate Schedules to set an inactive date on.
;;DOD-SCI-SNF^3031225
;;DOD-TBI-SNF^3031225
;;DOD-BR-SNF^3031225
;;END
CORACT ; Add new ACTION TYPE ENTRIES (350.1)
;
D MES^XPDUTL(" -> Updating the CC RX Eligibility Logic fields ...")
N IBI,IBJ,IBLN
N X,Y,DIE,DA,DR,DTOUT
N IBIEN,IBLAST,IBBEG,IBEND
N IBEL,IBEL1,IBEL2,IBEL3
;
; Correct the Eligibility Logic
S IBEL1="S X=0,X1="_$C(34)_$C(34)_",X2="_$C(34)_$C(34)
S IBEL2=" G:'$D(VAEL) 1^IBAERR I VAEL(4),'+VAEL(3),'IBDOM,'$$RXEXMT^IBARXEU0(DFN,DT) "
S IBEL3="S X=1,X2=$P(^IBE(350.1,DA,0),"_$C(34)_"^"_$C(34)_",4) D COST^IBAUTL"
S IBEL=IBEL1_IBEL2_IBEL3
;
; Store in affected CC RX Action Types
F IBI=1:1 S IBLN=$P($T(ACTDAT+IBI),";;",2) Q:IBLN="END" I $E(IBLN)?1A D
. ;Locate existing entry.
. S IBNM=$P(IBLN,U),IBEDT=$P(IBLN,U,6)
. S IBJ=0 S IBJ=$O(^IBE(350.1,"B",IBNM,IBJ))
. I +IBJ<1 K X,Y Q ;not found, exit
. S DR="40////"_IBEL
. S DIE="^IBE(350.1,",DA=+IBJ
. D ^DIE
D MES^XPDUTL(" Eligibility Logic updates completed.")
Q
;
ACTDAT ; Data for the new ACTION TYPE fields. (All categories will be updated)
;;CHOICE (RX) NEW
;;CC (RX) NEW
;;CCN (RX) NEW
;;CC MTF (RX) NEW
;;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P645 13452 printed Dec 13, 2024@02:04:16 Page 2
IB20P645 ;SAB/Albany - IB*2.0*645 POST INSTALL;12/11/17 2:10pm
+1 ;;2.0;Integrated Billing;**645**;Mar 20, 1995;Build 16
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
POSTINIT ;Post Install for IB*2.0*645
+1 DO BMES^XPDUTL(" >> Starting the Post-Initialization routine for IB*2.0*645 ")
+2 ; Update Community Care No Fault Rate Schedules if necessary and add 2019 CC RX Rate Schedules
+3 DO UPDNFRS
+4 DO UPDTRRS
+5 DO RTIN
+6 DO CORACT
+7 DO BMES^XPDUTL(" >> End of the Post-Initialization routine for IB*2.0*645")
+8 QUIT
+9 ;
UPDNFRS ; Update No Fault and 2019 RX Rate Schedules (363)
+1 DO MES^XPDUTL(" -> Updating Community Care No Fault and RX Rate Schedules for file 363 ...")
+2 NEW IBA,IBCNT,IBI,IBLN,IBFN,IBRT,IBBS,IBCNTCS,IBDISP,IBJ,IBLNCS,IBCS,IBCSFN,IBADMIN,DD,DO
+3 NEW DLAYGO,DIC,DIE,DA,DR,RXDT,X,Y,IBCPNM,IBEDT,IBNM
+4 SET IBCNT=0
+5 FOR IBI=2:1
SET IBLN=$PIECE($TEXT(RSF+IBI),";;",2)
if IBLN="END"
QUIT
IF $EXTRACT(IBLN)?1A
Begin DoDot:1
+6 ;Check for problems
+7 ;Billable service invalid
SET IBBS=$PIECE(IBLN,U,4)
IF IBBS'=""
SET IBBS=$$MCCRUTL(IBBS,13)
if 'IBBS
QUIT
+8 SET IBRT=$PIECE(IBLN,U,2)
SET IBRT=$ORDER(^DGCR(399.3,"B",IBRT,0))
Begin DoDot:2
+9 IF 'IBRT
DO MSG(" **** Rate Type "_$PIECE(IBLN,U,2)_" not defined, RS "_$PIECE(IBLN,U,1)_" not created")
+10 IF +$PIECE($GET(^DGCR(399.3,+IBRT,0)),U,3)
SET IBRT=0
DO MSG(" **** Rate Type "_$PIECE(IBLN,U,2)_" not Active, RS "_$PIECE(IBLN,U,1)_" not created")
End DoDot:2
if 'IBRT
QUIT
+11 ;No problems found, so create entry
+12 ;Locate existing entry.
+13 SET Y=-1
SET IBNM=$PIECE(IBLN,U)
SET IBEDT=$PIECE(IBLN,U,6)
+14 SET IBJ=0
FOR
SET IBJ=$ORDER(^IBE(363,"B",IBNM,IBJ))
if 'IBJ
QUIT
Begin DoDot:2
+15 ;Rate Schedule correctly defined, skip.
IF ($DATA(^IBE(363,IBJ,11))>9)
IF (IBNM'["RX")
IF (IBNM'["PHARM")
SET Y=0
QUIT
+16 ;Non RX Rate schedule
IF (IBNM'["RX")
IF (IBNM'["PHARM")
SET Y=IBJ
QUIT
+17 ;Empty RX Rate schedule, use it.
IF $PIECE(^IBE(363,IBJ,0),U,5)=""
SET Y=IBJ
QUIT
+18 ;Rate rate exists correctly, skip
IF ($PIECE(^IBE(363,IBJ,0),U,5)=IBEDT)
IF ($DATA(^IBE(363,IBJ,11))>9)
SET Y=0
QUIT
+19 ;Rate rate exists incorrectly, update it.
IF ($PIECE(^IBE(363,IBJ,0),U,5)=IBEDT)
IF ($DATA(^IBE(363,IBJ,11))<10)
SET Y=IBJ
End DoDot:2
if Y>-1
QUIT
+20 ; correctly defined, no need to update. Go find next schedule.
if Y=0
QUIT
+21 ; If no entry found in Rate Schedule file, create a new entry
IF Y=-1
Begin DoDot:2
+22 KILL DD,DO,Y
+23 SET DLAYGO=363
SET DIC="^IBE(363,"
SET DIC(0)="L"
SET X=$PIECE(IBLN,U,1)
+24 DO FILE^DICN
KILL DIC,DINUM,DLAYGO
End DoDot:2
+25 IF Y<1
KILL X,Y
QUIT
+26 SET IBFN=+Y
SET IBCNT=IBCNT+1
+27 SET IBCPNM=$PIECE(IBLN,U,5)
+28 SET RXDT=$$RXDT(IBCPNM,IBEDT)
+29 SET DR=".02////"_IBRT_";.03////"_$PIECE(IBLN,U,3)
IF +IBBS
SET DR=DR_";.04////"_IBBS
+30 SET DR=DR_";.05////"_$PIECE(RXDT,U)
+31 IF $PIECE(RXDT,U,2)
SET DR=DR_";.06////"_$PIECE(RXDT,U,2)
+32 IF (($PIECE(IBLN,U,1)["RX")!($PIECE(IBLN,U,1)["PHARM"))
IF ($GET(IBDISP)]"")
SET DR=DR_";1.01///"_IBDISP
+33 IF (($PIECE(IBLN,U,1)["RX")!($PIECE(IBLN,U,1)["PHARM"))
IF ($GET(IBADMIN)]"")
SET DR=DR_";10////"_IBADMIN
+34 SET DIE="^IBE(363,"
SET DA=+Y
DO ^DIE
KILL DIE,DA,DR,X,Y
+35 SET IBCNTCS=0
+36 ; Retrieve name of Charge Set to copy
+37 IF IBRT=""
DO MSG(" **** Rate Type "_$PIECE(IBLN,U,2)_" missing Charge Set Information, RS "_$PIECE(IBLN,U,1)_" not created")
QUIT
+38 ; add all Reasonable Charges Charge Sets to the Rate Schedule.
+39 SET IBCNTCS=$$RSCS(IBFN,IBCPNM,$PIECE(RXDT,U))
+40 DO MES^XPDUTL(" Total Reasonable Charge Set"_$SELECT(IBCNTCS=1:" ",1:"s ")_IBCNTCS_" added to Rate Schedule "_$PIECE(IBLN,U,1)_".")
End DoDot:1
+41 DO MES^XPDUTL(" Rate Schedules completed.")
+42 ;ADDRS
QUIT
+43 ;
UPDTRRS ; Update TRICARE and DOD Rate Schedules (363) to interagency
+1 DO MES^XPDUTL(" -> Updating TRICARE and DOD Rate Schedules for file 363 ...")
+2 NEW IBA,IBCNT,IBI,IBLN,IBFN,IBRT,IBBS,IBCNTCS,IBDISP,IBJ,IBLNCS,IBCS,IBCSFN,IBADMIN,DD,DO
+3 NEW DLAYGO,DIC,DIE,DA,DR,RXDT,X,Y,IBCPNM,IBEDT,IBNM,DIK,IBK
+4 SET IBCNT=0
+5 FOR IBI=2:1
SET IBLN=$PIECE($TEXT(TRSF+IBI),";;",2)
if IBLN="END"
QUIT
IF $EXTRACT(IBLN)?1A
Begin DoDot:1
+6 ;Check for problems
+7 ;Billable service invalid
SET IBBS=$PIECE(IBLN,U,4)
IF IBBS'=""
SET IBBS=$$MCCRUTL(IBBS,13)
if 'IBBS
QUIT
+8 SET IBRT=$PIECE(IBLN,U,2)
SET IBRT=$ORDER(^DGCR(399.3,"B",IBRT,0))
Begin DoDot:2
+9 IF 'IBRT
DO MSG(" **** Rate Type "_$PIECE(IBLN,U,2)_" not defined, RS "_$PIECE(IBLN,U,1)_" not created")
+10 IF +$PIECE($GET(^DGCR(399.3,+IBRT,0)),U,3)
SET IBRT=0
DO MSG(" **** Rate Type "_$PIECE(IBLN,U,2)_" not Active, RS "_$PIECE(IBLN,U,1)_" not created")
End DoDot:2
if 'IBRT
QUIT
+11 ;Locate existing entry.
+12 SET Y=-1
SET IBNM=$PIECE(IBLN,U)
SET IBEDT=$PIECE(IBLN,U,6)
+13 SET IBJ=0
FOR
SET IBJ=$ORDER(^IBE(363,"B",IBNM,IBJ))
if 'IBJ
QUIT
Begin DoDot:2
+14 ;Non RX Rate schedule
IF (IBNM'["RX")
IF (IBNM'["PHARM")
SET Y=IBJ
QUIT
+15 ;Empty RX Rate schedule, use it.
IF $PIECE(^IBE(363,IBJ,0),U,5)=""
SET Y=IBJ
QUIT
+16 ;Correct Pharmacy rate schedule found
IF ($PIECE(^IBE(363,IBJ,0),U,5)=IBEDT)
SET Y=IBJ
End DoDot:2
if Y>-1
QUIT
+17 ; If no entry Quit
if Y=-1
QUIT
+18 ; Cleanly Remove existing Charge sets from the Rate Schedule.
+19 SET IBK=0
FOR
SET IBK=$ORDER(^IBE(363,IBJ,11,IBK))
if 'IBK
QUIT
Begin DoDot:2
+20 NEW X,Y,DA,DIK
+21 SET DA=IBK
SET DA(1)=IBJ
SET DIK="^IBE(363,"_DA(1)_",11,"
+22 DO ^DIK
End DoDot:2
+23 ;Update the Rate Schedule with IA info and add the new IA charge sets
+24 SET IBFN=+IBJ
SET IBCNT=IBCNT+1
+25 SET IBCPNM=$PIECE(IBLN,U,5)
+26 SET RXDT=$$RXDT(IBCPNM,IBEDT)
+27 SET DR=".02////"_IBRT_";.03////"_$PIECE(IBLN,U,3)
IF +IBBS
SET DR=DR_";.04////"_IBBS
+28 SET DR=DR_";.05////"_$PIECE(RXDT,U)
+29 IF $PIECE(RXDT,U,2)
SET DR=DR_";.06////"_$PIECE(RXDT,U,2)
+30 IF (($PIECE(IBLN,U,1)["RX")!($PIECE(IBLN,U,1)["PHARM"))
IF ($GET(IBDISP)]"")
SET DR=DR_";1.01///"_IBDISP
+31 IF (($PIECE(IBLN,U,1)["RX")!($PIECE(IBLN,U,1)["PHARM"))
IF ($GET(IBADMIN)]"")
SET DR=DR_";10////"_IBADMIN
+32 SET DIE="^IBE(363,"
SET DA=+IBJ
DO ^DIE
KILL DIE,DA,DR,X,Y
+33 SET IBCNTCS=0
+34 ; Retrieve name of Charge Set to copy
+35 IF IBRT=""
DO MSG(" **** Rate Type "_$PIECE(IBLN,U,2)_" missing Charge Set Information, RS "_$PIECE(IBLN,U,1)_" not created")
QUIT
+36 ; add all Reasonable Charges Charge Sets to the Rate Schedule.
+37 SET IBCNTCS=$$RSCS(IBFN,IBCPNM,$PIECE(RXDT,U))
+38 DO MES^XPDUTL(" Total Reasonable Charge Set"_$SELECT(IBCNTCS=1:" ",1:"s ")_IBCNTCS_" added to Rate Schedule "_$PIECE(IBLN,U,1)_".")
End DoDot:1
+39 DO MES^XPDUTL(" Rate Schedules completed.")
+40 ;UPDTRRS
QUIT
+41 ;
RTIN ; Inactivate the DOD SNF Rate Schedules to prevent duplicate charges
+1 DO MES^XPDUTL(" -> Inactivating the DOD SNF Rate Schedules ...")
+2 NEW IBA,IBCNT,IBI,IBLN,IBFN,IBRT,IBBS,IBCNTCS,IBDISP,IBJ,IBLNCS,IBCS,IBCSFN,IBADMIN,DD,DO
+3 NEW DLAYGO,DIC,DIE,DA,DR,RXDT,X,Y,IBCPNM,IBEDT,IBNM,DIK,IBK
+4 SET IBCNT=0
+5 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(RTINDATA+IBI),";;",2)
if IBLN="END"
QUIT
Begin DoDot:1
+6 ;Locate existing entry.
+7 SET IBNM=$PIECE(IBLN,U)
+8 SET IBJ=0
SET IBJ=$ORDER(^IBE(363,"B",IBNM,IBJ))
+9 if 'IBJ
QUIT
+10 ;Update the Rate Schedule an INACTIVE Date
+11 SET IBFN=+IBJ
SET IBCNT=IBCNT+1
+12 SET DR=".06////"_$PIECE(IBLN,U,2)
+13 SET DIE="^IBE(363,"
SET DA=+IBJ
DO ^DIE
KILL DIE,DA,DR,X,Y
+14 SET IBCNTCS=0
End DoDot:1
+15 DO MES^XPDUTL(" DOD Rate Schedules inactivated.")
+16 QUIT
+17 ;
RSCS(IBFN,IBCPNM,RXDT) ; add existing Charge Sets to FR
+1 ; copy the Charge Sets from the corresponding RI RS (v2)
+2 ; IBFN - Rate Schedule IEN
+3 ; IBCPNM - Charge Set to copy
+4 ; RXDT - last effective date of charge set being copied.
+5 NEW IBCNT,IBNRS,IBRSNM,IBTY,IBVDT,IBCOPY,IBCS,IBCS0,IBXFN,IBCSFN,IBCSNM,IBCSAA,IBNAME
+6 SET (IBCNT,IBCOPY)=0
+7 SET IBNRS=$GET(^IBE(363,+$GET(IBFN),0))
SET IBRSNM=$PIECE(IBNRS,"^",1)
+8 SET IBTY=$PIECE(IBNRS,"^",3)
+9 SET IBVDT=RXDT
+10 ;Q:IBVDT="" 0
+11 SET IBCOPY=+$$RSEXISTS(IBVDT,IBCPNM)
+12 IF 'IBCOPY
GOTO RSCSQ
+13 IF +$PIECE($GET(^IBE(363,+IBCOPY,0)),U,3)=IBTY
Begin DoDot:1
+14 SET IBXFN=0
FOR
SET IBXFN=$ORDER(^IBE(363,IBCOPY,11,IBXFN))
if 'IBXFN
QUIT
Begin DoDot:2
+15 SET IBCS=$GET(^IBE(363,IBCOPY,11,IBXFN,0))
SET IBCSFN=+IBCS
+16 IF +$$RSCSFILE(IBFN,$PIECE($GET(^IBE(363.1,IBCSFN,0)),U,1),$PIECE(IBCS,U,2))
SET IBCNT=IBCNT+1
End DoDot:2
End DoDot:1
RSCSQ QUIT IBCNT
+1 ;
+2 ;
RSCSFILE(IBFN,IBCSNM,IBCSAA) ; Add Charge Set to a Rate Schedule
+1 NEW IBX,DD,DO,DLAYGO,DIC,DA,DR,X,Y,IBCSFN
SET IBX=0
+2 IF $GET(^IBE(363,+$GET(IBFN),0))=""
GOTO RSCSFQ
+3 IF $GET(IBCSNM)=""
GOTO RSCSFQ
+4 SET IBCSFN=$ORDER(^IBE(363.1,"B",IBCSNM,0))
IF 'IBCSFN
GOTO RSCSFQ
+5 IF $ORDER(^IBE(363,IBFN,11,"B",IBCSFN,0))
GOTO RSCSFQ
+6 SET DLAYGO=363
SET DA(1)=+IBFN
SET DIC="^IBE(363,"_DA(1)_",11,"
SET DIC(0)="L"
+7 SET X=IBCSNM
SET DIC("DR")=".02///"_$GET(IBCSAA)
SET DIC("P")="363.0011P"
+8 DO ^DIC
if +Y
SET IBX=1
RSCSFQ QUIT IBX
+1 ;
+2 ;
RSEXISTS(IBVDT,IBNAME) ; return RS IFN if Rate Schedule exists for Effective Date
+1 NEW IBX,IBRSFN,IBRS0
SET IBX=0
+2 SET IBRSFN=0
FOR
SET IBRSFN=$ORDER(^IBE(363,IBRSFN))
if 'IBRSFN
QUIT
Begin DoDot:1
+3 SET IBRS0=$GET(^IBE(363,IBRSFN,0))
+4 IF $PIECE(IBRS0,U,1)=IBNAME
IF $PIECE(IBRS0,U,5)=IBVDT
SET IBX=IBRSFN
End DoDot:1
IF IBX
QUIT
+5 QUIT IBX
+6 ;
MSG(X) ;
+1 NEW IBX
SET IBX=$ORDER(IBA(999999),-1)
if 'IBX
SET IBX=1
SET IBX=IBX+1
+2 SET IBA(IBX)=$GET(X)
+3 ;MSG
QUIT
+4 ;
MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
+1 NEW IBX,IBY
SET IBY=""
+2 IF $GET(X)'=""
SET IBX=0
FOR
SET IBX=$ORDER(^DGCR(399.1,"B",X,IBX))
if 'IBX
QUIT
IF $PIECE($GET(^DGCR(399.1,IBX,0)),U,+$GET(P))
SET IBY=IBX
+3 QUIT IBY
+4 ;
RXDT(IBCPNM,IBEDT) ;Copy the active charge schedule from charge set being copied.
+1 ; update Fee information if Pharmacy.
+2 NEW IBEFLG,IBD
+3 ; Set to NULL if not passed in
SET IBEDT=$GET(IBEDT)
+4 SET IBCS=""
+5 ;If no Effective Date sent, get the latest entry.
+6 IF IBEDT=""
SET IBCS=$ORDER(^IBE(363,"B",IBCPNM,IBCS),-1)
+7 ;If Effective date sent, loop through the entries to find the entry
+8 ; with the correct effective date.
+9 ; FOR TR-PHARM 2015 populating only
IF (IBEDT=3150101)
IF (IBCPNM="TR-RX")
SET IBEDT=3150220
+10 IF IBEDT'=""
Begin DoDot:1
+11 SET IBEFLG=0
+12 FOR
SET IBCS=$ORDER(^IBE(363,"B",IBCPNM,IBCS),-1)
if 'IBCS
QUIT
Begin DoDot:2
+13 SET IBD=$GET(^IBE(363,IBCS,0))
+14 IF $PIECE(IBD,U,5)=IBEDT
SET IBEFLG=1
End DoDot:2
if IBEFLG
QUIT
End DoDot:1
+15 if IBCS=""
QUIT ""
+16 SET IBCS0=^IBE(363,IBCS,0)
+17 IF (IBCPNM["RX")!(IBCPNM["PHARM")
SET IBDISP=$PIECE($GET(^IBE(363,IBCS,1)),U,1)
SET IBADMIN=$GET(^IBE(363,IBCS,10))
+18 ;return effective and end dates
QUIT $PIECE(IBCS0,U,5,6)
+19 ;
RSF ;Rate Schedules (363) for Community Care No Fault Rate Types and 2019 Pharmacy
+1 ;;Rate Schedule Name^Rate Type^Bill Type^Billable Service^Rate Schedule to copy for Charge Sets
+2 ;;CCC-NF-INPT^CHOICE NO-FAULT AUTO^1^^RI-INPT
+3 ;;CCC-NF-SNF^CHOICE NO-FAULT AUTO^1^SKILLED NURSING^RI-SNF
+4 ;;CCC-NF-OPT^CHOICE NO-FAULT AUTO^3^^RI-OPT
+5 ;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^RI-RX^3140101
+6 ;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^RI-RX^3150101
+7 ;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^RI-RX^3160101
+8 ;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^RI-RX^3170101
+9 ;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^RI-RX^3180101
+10 ;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^RI-RX^3190101
+11 ;;CC-NF-INPT^CC NO-FAULT AUTO^1^^RI-INPT
+12 ;;CC-NF-SNF^CC NO-FAULT AUTO^1^SKILLED NURSING^RI-SNF
+13 ;;CC-NF-OPT^CC NO-FAULT AUTO^3^^RI-OPT
+14 ;;CC-NF-RX^CC NO-FAULT AUTO^3^^RI-RX^3140101
+15 ;;CC-NF-RX^CC NO-FAULT AUTO^3^^RI-RX^3150101
+16 ;;CC-NF-RX^CC NO-FAULT AUTO^3^^RI-RX^3160101
+17 ;;CC-NF-RX^CC NO-FAULT AUTO^3^^RI-RX^3170101
+18 ;;CC-NF-RX^CC NO-FAULT AUTO^3^^RI-RX^3180101
+19 ;;CC-NF-RX^CC NO-FAULT AUTO^3^^RI-RX^3190101
+20 ;;CCN-NF-INPT^CCN NO-FAULT AUTO^1^^RI-INPT
+21 ;;CCN-NF-SNF^CCN NO-FAULT AUTO^1^SKILLED NURSING^RI-SNF
+22 ;;CCN-NF-OPT^CCN NO-FAULT AUTO^3^^RI-OPT
+23 ;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^RI-RX^3140101
+24 ;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^RI-RX^3150101
+25 ;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^RI-RX^3160101
+26 ;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^RI-RX^3170101
+27 ;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^RI-RX^3180101
+28 ;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^RI-RX^3190101
+29 ;;CCC-RI-RX^CHOICE REIMB INS^3^^RI-RX^3190101
+30 ;;CC-RI-RX^CC REIMB INS^3^^RI-RX^3190101
+31 ;;CCN-RI-RX^CCN REIMB INS^3^^RI-RX^3190101
+32 ;;CC-DOD-RX^CC MTF REIMB INS^3^^RI-RX^3190101
+33 ;;CCC-TF-RX^CHOICE TORT FEASOR^3^^TF-RX^3190101
+34 ;;CC-TF-RX^CC TORT FEASOR^3^^TF-RX^3190101
+35 ;;CCN-TF-RX^CCN TORT FEASOR^3^^TF-RX^3190101
+36 ;;CCC-WC-RX^CHOICE WORKERS' COMP^3^^WC-RX^3190101
+37 ;;CC-WC-RX^CC WORKERS' COMP^3^^WC-RX^3190101
+38 ;;CCN-WC-RX^CCN WORKERS' COMP^3^^WC-RX^3190101
+39 ;;TR-PHARM^TRICARE PHARMACY^3^^TR-RX^3190101
+40 ;;END
TRSF ;New Rate Schedules (363) for the new DOD and TRICARE Rate Types
+1 ;;DOD-DIS EXAM-OPT^DOD DISABILITY EVALUATION^3^OUTPATIENT VISIT^RI-OPT
+2 ;;DOD-SCI-INPT^DOD SPINAL CORD INJURY^1^INPATIENT^IA-INPT
+3 ;;DOD-SCI-OPT^DOD SPINAL CORD INJURY^3^OUTPATIENT VISIT^RI-OPT
+4 ;;DOD-TBI-INPT^DOD TRAUMATIC BRAIN INJURY^1^INPATIENT^IA-INPT
+5 ;;DOD-TBI-OPT^DOD TRAUMATIC BRAIN INJURY^3^OUTPATIENT VISIT^RI-OPT
+6 ;;DOD-BR-INPT^DOD BLIND REHABILITATION^1^INPATIENT^IA-INPT
+7 ;;DOD-BR-OPT^DOD BLIND REHABILITATION^3^OUTPATIENT VISIT^RI-OPT
+8 ;;TR-DENTAL^TRICARE DENTAL^3^OUTPATIENT VISIT^RI-OPT
+9 ;;TR-PHARM^TRICARE PHARMACY^3^^TR-RX^3140101
+10 ;;TR-PHARM^TRICARE PHARMACY^3^^TR-RX^3150101
+11 ;;TR-PHARM^TRICARE PHARMACY^3^^TR-RX^3160101
+12 ;;TR-PHARM^TRICARE PHARMACY^3^^TR-RX^3170101
+13 ;;TR-PHARM^TRICARE PHARMACY^3^^TR-RX^3180101
+14 ;;END
RTINDATA ;Rate Schedules to set an inactive date on.
+1 ;;DOD-SCI-SNF^3031225
+2 ;;DOD-TBI-SNF^3031225
+3 ;;DOD-BR-SNF^3031225
+4 ;;END
CORACT ; Add new ACTION TYPE ENTRIES (350.1)
+1 ;
+2 DO MES^XPDUTL(" -> Updating the CC RX Eligibility Logic fields ...")
+3 NEW IBI,IBJ,IBLN
+4 NEW X,Y,DIE,DA,DR,DTOUT
+5 NEW IBIEN,IBLAST,IBBEG,IBEND
+6 NEW IBEL,IBEL1,IBEL2,IBEL3
+7 ;
+8 ; Correct the Eligibility Logic
+9 SET IBEL1="S X=0,X1="_$CHAR(34)_$CHAR(34)_",X2="_$CHAR(34)_$CHAR(34)
+10 SET IBEL2=" G:'$D(VAEL) 1^IBAERR I VAEL(4),'+VAEL(3),'IBDOM,'$$RXEXMT^IBARXEU0(DFN,DT) "
+11 SET IBEL3="S X=1,X2=$P(^IBE(350.1,DA,0),"_$CHAR(34)_"^"_$CHAR(34)_",4) D COST^IBAUTL"
+12 SET IBEL=IBEL1_IBEL2_IBEL3
+13 ;
+14 ; Store in affected CC RX Action Types
+15 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(ACTDAT+IBI),";;",2)
if IBLN="END"
QUIT
IF $EXTRACT(IBLN)?1A
Begin DoDot:1
+16 ;Locate existing entry.
+17 SET IBNM=$PIECE(IBLN,U)
SET IBEDT=$PIECE(IBLN,U,6)
+18 SET IBJ=0
SET IBJ=$ORDER(^IBE(350.1,"B",IBNM,IBJ))
+19 ;not found, exit
IF +IBJ<1
KILL X,Y
QUIT
+20 SET DR="40////"_IBEL
+21 SET DIE="^IBE(350.1,"
SET DA=+IBJ
+22 DO ^DIE
End DoDot:1
+23 DO MES^XPDUTL(" Eligibility Logic updates completed.")
+24 QUIT
+25 ;
ACTDAT ; Data for the new ACTION TYPE fields. (All categories will be updated)
+1 ;;CHOICE (RX) NEW
+2 ;;CC (RX) NEW
+3 ;;CCN (RX) NEW
+4 ;;CC MTF (RX) NEW
+5 ;;END
