Routine: IB20P645

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.

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")

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.")

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.")

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  Mar 13, 2025@21:09:03                                                                                                                                                                                                   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

IB20P645.m