IBYPSA1 ;ALB/ARH - IB*2.0*245 POST INIT: REASONABLE CHARGES V2.0 CONT; 10-OCT-2003
 ;;2.0;INTEGRATED BILLING;**245**;21-MAR-94
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ;
 Q
 ;
ADDRB ; Add Billable Service (399.1, .2=1)
 N IBA,IBCNT,IBI,IBLN,IBFN,IBX,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y S IBCNT=0
 ;
 F IBI=1:1 S IBLN=$P($T(RBF+IBI),";;",2) Q:+IBLN!(IBLN="")  I $E(IBLN)?1A D
 . ;
 . I +$$MCCRUTL($P(IBLN,U,1),13) Q
 . ;
 . K DD,DO S DLAYGO=399.1,DIC="^DGCR(399.1,",DIC(0)="L",X=$P(IBLN,U,1) D FILE^DICN K DIC I Y<1 K X,Y Q
 . S IBFN=+Y,IBCNT=IBCNT+1
 . ;
 . S DR=".03////"_$P(IBLN,U,2)_";.2////"_1
 . S DIE="^DGCR(399.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
 . ;
 . S IBA(IBCNT+1)="             "_$P(IBLN,U,1)
 ;
RBQ S IBA(1)="      >> "_IBCNT_" Billable Services added (399.1)..."
 D MES^XPDUTL(.IBA)
 Q
 ;
ADDBS ; Add Bedsection (399.1, .12=1)
 N IBA,IBCNT,IBI,IBLN,IBRB,IBFN,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y S IBCNT=0
 ;
 F IBI=1:1 S IBLN=$P($T(BSF+IBI),";;",2) Q:+IBLN!(IBLN="")  I $E(IBLN)?1A D
 . ;
 . I +$$MCCRUTL($P(IBLN,U,1),5) Q
 . ;
 . S IBRB=$P(IBLN,U,3) I IBRB'="" S IBRB=$$MCCRUTL(IBRB,13) D  Q:'IBRB
 .. I 'IBRB D MSG("         *** Billable Service "_$P(IBLN,U,3)_" not defined, BS "_$P(IBLN,U,1)_" not created")
 . ;
 . K DD,DO S DLAYGO=399.1,DIC="^DGCR(399.1,",DIC(0)="L",X=$P(IBLN,U,1) D FILE^DICN K DIC I Y<1 K X,Y Q
 . S IBFN=+Y,IBCNT=IBCNT+1
 . ;
 . S DR=".03////"_$P(IBLN,U,2)_";.12////"_1 I +IBRB S DR=DR_";.25////"_IBRB
 . S DIE="^DGCR(399.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
 . ;
 . S IBA(IBCNT+1)="             "_$P(IBLN,U,1)
 ;
BSQ S IBA(1)="      >> "_IBCNT_" Bedsection added (399.1)..."
 D MES^XPDUTL(.IBA)
 Q
 ;
ADDBI ; Add Billing Items (363.21)
 N IBA,IBCNT,IBI,IBLN,IBFN,IBX,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y S IBCNT=0
 ;
 F IBI=1:1 S IBLN=$P($T(BIF+IBI),";;",2) Q:+IBLN!(IBLN="")  I $E(IBLN)?1A D
 . ;
 . S IBX=$O(^IBA(363.21,"B",$P(IBLN,U,1),0)) I +IBX,$P($G(^IBA(363.21,IBX,0)),U,2)=$P(IBLN,U,2) Q
 . ;
 . S DIC("DR")=".02////"_$P(IBLN,U,2)
 . K DD,DO S DLAYGO=363.21,DIC="^IBA(363.21,",DIC(0)="L",X=$P(IBLN,U,1) D FILE^DICN K DIC,DLAYGO I Y<1 K X,Y Q
 . S IBFN=+Y,IBCNT=IBCNT+1
 . ;
 . S IBA(IBCNT+1)="             "_$P(IBLN,U,1)
 ;
BIQ S IBA(1)="      >> "_IBCNT_" Billing Items added (363.21)..."
 D MES^XPDUTL(.IBA)
 Q
ADDBR ; Add Billing Rates (363.3)
 N IBA,IBCNT,IBI,IBJ,IBBR,IBLN,IBFN,DD,DO,DINUM,DLAYGO,DIC,DIE,DA,DR,X,Y S IBCNT=0
 ;
 F IBI=1:1 S IBLN=$P($T(BRF+IBI),";;",2) Q:+IBLN!(IBLN="")  I $E(IBLN)?1A D
 . ;
 . I $O(^IBE(363.3,"B",$P(IBLN,U,1),0)) Q
 . ;
 . F IBJ=1:1 S IBBR=$G(^IBE(363.3,IBJ,0)) I IBBR="" S DINUM=IBJ Q
 . ;
 . K DD,DO S DLAYGO=363.3,DIC="^IBE(363.3,",DIC(0)="L",X=$P(IBLN,U,1) D FILE^DICN K DIC I Y<1 K X,Y Q
 . S IBFN=+Y,IBCNT=IBCNT+1
 . ;
 . S DR=".02////"_$P(IBLN,U,2)_";.03////"_$P(IBLN,U,3)_";.04////"_$P(IBLN,U,4)_";.05////"_$P(IBLN,U,5)_";.06////"_$P(IBLN,U,6)
 . S DIE="^IBE(363.3,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
 . ;
 . S IBA(IBCNT+1)="             "_$P(IBLN,U,1)
 ;
BRQ S IBA(1)="      >> "_IBCNT_" Billing Rates added (363.3)..."
 D MES^XPDUTL(.IBA)
 Q
 ;
ADDRS ; add Rate Schedules (363) for Reasonable Charges, if this is the first time the patch is installed
 ; (charge sets will be added when rates are uploaded)
 N IBA,IBCNT,IBI,IBLN,IBFN,IBRT,IBBS,IBJ,IBLNCS,IBCS,IBCSFN,IBSTDT,IBRS,DINUM,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y S IBSTDT="",IBCNT=0
 ;
 I $O(^IBE(363.3,"B","RC PHYSICIAN MN",0)) G RSQ
 ;
 S IBSTDT=$$VERSDT^IBCRHBRV(2) ;I '$$PROD^IBCORC S IBSTDT=2981001
 ;
 F IBI=1:1 S IBLN=$P($T(RSF+IBI),";;",2) Q:+IBLN!(IBLN="")  I $E(IBLN)?1A D
 . ;
 . S IBBS=$P(IBLN,U,4) I IBBS'="" S IBBS=$$MCCRUTL(IBBS,13) D  Q:'IBBS
 .. I 'IBBS D MSG("         *** Billable Service "_$P(IBLN,U,4)_" not defined, RS "_$P(IBLN,U,1)_" not created")
 . ;
 . 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")
 . ;
 . F IBJ=1:1 S IBRS=$G(^IBE(363,IBJ,0)) I IBRS="" S DINUM=IBJ Q
 . ;
 . K DD,DO 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 DR=".02////"_IBRT_";.03////"_$P(IBLN,U,3) S:+IBBS DR=DR_";.04////"_IBBS S DR=DR_";.05////"_IBSTDT
 . S DIE="^IBE(363,",DA=+Y D ^DIE K DIE,DA,DR,X,Y
 . ;
 . ; charge sets (multiple)
 . S IBLNCS=$P(IBLN,":",2,999) I IBLNCS'="" F IBJ=1:1 S IBCS=$P(IBLNCS,":",IBJ) Q:IBCS=""  D
 .. S IBCSFN=$O(^IBE(363.1,"B",IBCS,0)) Q:'IBCSFN
 .. ;
 .. S DLAYGO=363,DA(1)=+IBFN,DIC="^IBE(363,"_DA(1)_",11,",DIC(0)="L",X=IBCS,DIC("DR")=".02////"_1,DIC("P")="363.0011P" D ^DIC K DIC,DIE
 ;
RSQ S IBA(1)="      >> "_IBCNT_" Rate Schedules added, active on "_$E(IBSTDT,4,5)_"/"_$E(IBSTDT,6,7)_"/"_$E(IBSTDT,2,3)_" (363)..."
 D MES^XPDUTL(.IBA)
 Q
 ;
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
 ;
MSG(X) ;
 N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
 S IBA(IBX)=$G(X)
 Q
 ;
 ;
RBF ; billable services (399.1,.2)
 ;; name ^ abbreviation
 ;; 
 ;;SKILLED NURSING^SNF
 ;;
 ;
BSF ;  Bedsections (399.1,.12)
 ;; name ^ abbreviation ^ other care
 ;;    
 ;;ICU^ICU
 ;;PARTIAL HOSPITALIZATION^PARTIAL HOSP
 ;;SKILLED NURSING CARE^SNF^SKILLED NURSING
 ;;SUB-ACUTE CARE^SUBACUTE^SKILLED NURSING
 ;;
 ;
BIF ;  Billing Items (363.21)
 ;; name ^ type
 ;;  
 ;;PARTIAL HOSPITALIZATION^9
 ;;
BRF ;  Billing Rates File (363.3)
 ;; name ^ abbreviation ^ distribution ^ billable item ^ charge method ^ base allowed
 ;; 
 ;;RC FACILITY PER DIEM^RC F/PD^1^1^1
 ;; 
 ;;RC FACILITY HR^RC F/HR^1^2^6^1
 ;;RC FACILITY ML^RC F/ML^1^2^4
 ;; 
 ;;RC MISCELLANEOUS^RC MISC^1^9^1
 ;; 
 ;;RC PHYSICIAN MN^RC P/MN^1^2^5^1
 ;;RC PHYSICIAN ML^RC P/ML^1^2^4
 ;;
RSF ;  Rate Schedules (363)
 ;; rs name ^ rate type ^ bill type ^ billable service ^ effective date ^^ charge sets
 ;; 
 ;;RI-INPT^REIMBURSABLE INS.^1^^
 ;;RI-SNF^REIMBURSABLE INS.^1^SKILLED NURSING^
 ;;RI-OPT^REIMBURSABLE INS.^3^^
 ;;RI-RX^REIMBURSABLE INS.^3^^^^:TL-RX FILL
 ;; 
 ;;NF-INPT^NO FAULT INS.^1^^
 ;;NF-SNF^NO FAULT INS.^1^SKILLED NURSING^
 ;;NF-OPT^NO FAULT INS.^3^^
 ;;NF-RX^NO FAULT INS.^3^^^^:TL-RX FILL
 ;; 
 ;;WC-INPT^WORKERS' COMP.^1^^
 ;;WC-SNF^WORKERS' COMP.^1^SKILLED NURSING^
 ;;WC-OPT^WORKERS' COMP.^3^^
 ;;WC-RX^WORKERS' COMP.^3^^^^:TL-RX FILL
 ;;
 
--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYPSA1   6730     printed  Sep 23, 2025@20:13:01                                                                                                                                                                                                     Page 2
IBYPSA1   ;ALB/ARH - IB*2.0*245 POST INIT: REASONABLE CHARGES V2.0 CONT; 10-OCT-2003
 +1       ;;2.0;INTEGRATED BILLING;**245**;21-MAR-94
 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.
 +3       ;
 +4       ;
 +5        QUIT 
 +6       ;
ADDRB     ; Add Billable Service (399.1, .2=1)
 +1        NEW IBA,IBCNT,IBI,IBLN,IBFN,IBX,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y
           SET IBCNT=0
 +2       ;
 +3        FOR IBI=1:1
               SET IBLN=$PIECE($TEXT(RBF+IBI),";;",2)
               if +IBLN!(IBLN="")
                   QUIT 
               IF $EXTRACT(IBLN)?1A
                   Begin DoDot:1
 +4       ;
 +5                    IF +$$MCCRUTL($PIECE(IBLN,U,1),13)
                           QUIT 
 +6       ;
 +7                    KILL DD,DO
                       SET DLAYGO=399.1
                       SET DIC="^DGCR(399.1,"
                       SET DIC(0)="L"
                       SET X=$PIECE(IBLN,U,1)
                       DO FILE^DICN
                       KILL DIC
                       IF Y<1
                           KILL X,Y
                           QUIT 
 +8                    SET IBFN=+Y
                       SET IBCNT=IBCNT+1
 +9       ;
 +10                   SET DR=".03////"_$PIECE(IBLN,U,2)_";.2////"_1
 +11                   SET DIE="^DGCR(399.1,"
                       SET DA=+IBFN
                       DO ^DIE
                       KILL DIE,DA,DR,X,Y
 +12      ;
 +13                   SET IBA(IBCNT+1)="             "_$PIECE(IBLN,U,1)
                   End DoDot:1
 +14      ;
RBQ        SET IBA(1)="      >> "_IBCNT_" Billable Services added (399.1)..."
 +1        DO MES^XPDUTL(.IBA)
 +2        QUIT 
 +3       ;
ADDBS     ; Add Bedsection (399.1, .12=1)
 +1        NEW IBA,IBCNT,IBI,IBLN,IBRB,IBFN,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y
           SET IBCNT=0
 +2       ;
 +3        FOR IBI=1:1
               SET IBLN=$PIECE($TEXT(BSF+IBI),";;",2)
               if +IBLN!(IBLN="")
                   QUIT 
               IF $EXTRACT(IBLN)?1A
                   Begin DoDot:1
 +4       ;
 +5                    IF +$$MCCRUTL($PIECE(IBLN,U,1),5)
                           QUIT 
 +6       ;
 +7                    SET IBRB=$PIECE(IBLN,U,3)
                       IF IBRB'=""
                           SET IBRB=$$MCCRUTL(IBRB,13)
                           Begin DoDot:2
 +8                            IF 'IBRB
                                   DO MSG("         *** Billable Service "_$PIECE(IBLN,U,3)_" not defined, BS "_$PIECE(IBLN,U,1)_" not created")
                           End DoDot:2
                           if 'IBRB
                               QUIT 
 +9       ;
 +10                   KILL DD,DO
                       SET DLAYGO=399.1
                       SET DIC="^DGCR(399.1,"
                       SET DIC(0)="L"
                       SET X=$PIECE(IBLN,U,1)
                       DO FILE^DICN
                       KILL DIC
                       IF Y<1
                           KILL X,Y
                           QUIT 
 +11                   SET IBFN=+Y
                       SET IBCNT=IBCNT+1
 +12      ;
 +13                   SET DR=".03////"_$PIECE(IBLN,U,2)_";.12////"_1
                       IF +IBRB
                           SET DR=DR_";.25////"_IBRB
 +14                   SET DIE="^DGCR(399.1,"
                       SET DA=+IBFN
                       DO ^DIE
                       KILL DIE,DA,DR,X,Y
 +15      ;
 +16                   SET IBA(IBCNT+1)="             "_$PIECE(IBLN,U,1)
                   End DoDot:1
 +17      ;
BSQ        SET IBA(1)="      >> "_IBCNT_" Bedsection added (399.1)..."
 +1        DO MES^XPDUTL(.IBA)
 +2        QUIT 
 +3       ;
ADDBI     ; Add Billing Items (363.21)
 +1        NEW IBA,IBCNT,IBI,IBLN,IBFN,IBX,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y
           SET IBCNT=0
 +2       ;
 +3        FOR IBI=1:1
               SET IBLN=$PIECE($TEXT(BIF+IBI),";;",2)
               if +IBLN!(IBLN="")
                   QUIT 
               IF $EXTRACT(IBLN)?1A
                   Begin DoDot:1
 +4       ;
 +5                    SET IBX=$ORDER(^IBA(363.21,"B",$PIECE(IBLN,U,1),0))
                       IF +IBX
                           IF $PIECE($GET(^IBA(363.21,IBX,0)),U,2)=$PIECE(IBLN,U,2)
                               QUIT 
 +6       ;
 +7                    SET DIC("DR")=".02////"_$PIECE(IBLN,U,2)
 +8                    KILL DD,DO
                       SET DLAYGO=363.21
                       SET DIC="^IBA(363.21,"
                       SET DIC(0)="L"
                       SET X=$PIECE(IBLN,U,1)
                       DO FILE^DICN
                       KILL DIC,DLAYGO
                       IF Y<1
                           KILL X,Y
                           QUIT 
 +9                    SET IBFN=+Y
                       SET IBCNT=IBCNT+1
 +10      ;
 +11                   SET IBA(IBCNT+1)="             "_$PIECE(IBLN,U,1)
                   End DoDot:1
 +12      ;
BIQ        SET IBA(1)="      >> "_IBCNT_" Billing Items added (363.21)..."
 +1        DO MES^XPDUTL(.IBA)
 +2        QUIT 
ADDBR     ; Add Billing Rates (363.3)
 +1        NEW IBA,IBCNT,IBI,IBJ,IBBR,IBLN,IBFN,DD,DO,DINUM,DLAYGO,DIC,DIE,DA,DR,X,Y
           SET IBCNT=0
 +2       ;
 +3        FOR IBI=1:1
               SET IBLN=$PIECE($TEXT(BRF+IBI),";;",2)
               if +IBLN!(IBLN="")
                   QUIT 
               IF $EXTRACT(IBLN)?1A
                   Begin DoDot:1
 +4       ;
 +5                    IF $ORDER(^IBE(363.3,"B",$PIECE(IBLN,U,1),0))
                           QUIT 
 +6       ;
 +7                    FOR IBJ=1:1
                           SET IBBR=$GET(^IBE(363.3,IBJ,0))
                           IF IBBR=""
                               SET DINUM=IBJ
                               QUIT 
 +8       ;
 +9                    KILL DD,DO
                       SET DLAYGO=363.3
                       SET DIC="^IBE(363.3,"
                       SET DIC(0)="L"
                       SET X=$PIECE(IBLN,U,1)
                       DO FILE^DICN
                       KILL DIC
                       IF Y<1
                           KILL X,Y
                           QUIT 
 +10                   SET IBFN=+Y
                       SET IBCNT=IBCNT+1
 +11      ;
 +12                   SET DR=".02////"_$PIECE(IBLN,U,2)_";.03////"_$PIECE(IBLN,U,3)_";.04////"_$PIECE(IBLN,U,4)_";.05////"_$PIECE(IBLN,U,5)_";.06////"_$PIECE(IBLN,U,6)
 +13                   SET DIE="^IBE(363.3,"
                       SET DA=+IBFN
                       DO ^DIE
                       KILL DIE,DA,DR,X,Y
 +14      ;
 +15                   SET IBA(IBCNT+1)="             "_$PIECE(IBLN,U,1)
                   End DoDot:1
 +16      ;
BRQ        SET IBA(1)="      >> "_IBCNT_" Billing Rates added (363.3)..."
 +1        DO MES^XPDUTL(.IBA)
 +2        QUIT 
 +3       ;
ADDRS     ; add Rate Schedules (363) for Reasonable Charges, if this is the first time the patch is installed
 +1       ; (charge sets will be added when rates are uploaded)
 +2        NEW IBA,IBCNT,IBI,IBLN,IBFN,IBRT,IBBS,IBJ,IBLNCS,IBCS,IBCSFN,IBSTDT,IBRS,DINUM,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y
           SET IBSTDT=""
           SET IBCNT=0
 +3       ;
 +4        IF $ORDER(^IBE(363.3,"B","RC PHYSICIAN MN",0))
               GOTO RSQ
 +5       ;
 +6       ;I '$$PROD^IBCORC S IBSTDT=2981001
           SET IBSTDT=$$VERSDT^IBCRHBRV(2)
 +7       ;
 +8        FOR IBI=1:1
               SET IBLN=$PIECE($TEXT(RSF+IBI),";;",2)
               if +IBLN!(IBLN="")
                   QUIT 
               IF $EXTRACT(IBLN)?1A
                   Begin DoDot:1
 +9       ;
 +10                   SET IBBS=$PIECE(IBLN,U,4)
                       IF IBBS'=""
                           SET IBBS=$$MCCRUTL(IBBS,13)
                           Begin DoDot:2
 +11                           IF 'IBBS
                                   DO MSG("         *** Billable Service "_$PIECE(IBLN,U,4)_" not defined, RS "_$PIECE(IBLN,U,1)_" not created")
                           End DoDot:2
                           if 'IBBS
                               QUIT 
 +12      ;
 +13                   SET IBRT=$PIECE(IBLN,U,2)
                       SET IBRT=$ORDER(^DGCR(399.3,"B",IBRT,0))
                       Begin DoDot:2
 +14                       IF 'IBRT
                               DO MSG("         *** Rate Type "_$PIECE(IBLN,U,2)_" not defined, RS "_$PIECE(IBLN,U,1)_" not created")
 +15                       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 
 +16      ;
 +17                   FOR IBJ=1:1
                           SET IBRS=$GET(^IBE(363,IBJ,0))
                           IF IBRS=""
                               SET DINUM=IBJ
                               QUIT 
 +18      ;
 +19                   KILL DD,DO
                       SET DLAYGO=363
                       SET DIC="^IBE(363,"
                       SET DIC(0)="L"
                       SET X=$PIECE(IBLN,U,1)
                       DO FILE^DICN
                       KILL DIC,DINUM,DLAYGO
                       IF Y<1
                           KILL X,Y
                           QUIT 
 +20                   SET IBFN=+Y
                       SET IBCNT=IBCNT+1
 +21      ;
 +22                   SET DR=".02////"_IBRT_";.03////"_$PIECE(IBLN,U,3)
                       if +IBBS
                           SET DR=DR_";.04////"_IBBS
                       SET DR=DR_";.05////"_IBSTDT
 +23                   SET DIE="^IBE(363,"
                       SET DA=+Y
                       DO ^DIE
                       KILL DIE,DA,DR,X,Y
 +24      ;
 +25      ; charge sets (multiple)
 +26                   SET IBLNCS=$PIECE(IBLN,":",2,999)
                       IF IBLNCS'=""
                           FOR IBJ=1:1
                               SET IBCS=$PIECE(IBLNCS,":",IBJ)
                               if IBCS=""
                                   QUIT 
                               Begin DoDot:2
 +27                               SET IBCSFN=$ORDER(^IBE(363.1,"B",IBCS,0))
                                   if 'IBCSFN
                                       QUIT 
 +28      ;
 +29                               SET DLAYGO=363
                                   SET DA(1)=+IBFN
                                   SET DIC="^IBE(363,"_DA(1)_",11,"
                                   SET DIC(0)="L"
                                   SET X=IBCS
                                   SET DIC("DR")=".02////"_1
                                   SET DIC("P")="363.0011P"
                                   DO ^DIC
                                   KILL DIC,DIE
                               End DoDot:2
                   End DoDot:1
 +30      ;
RSQ        SET IBA(1)="      >> "_IBCNT_" Rate Schedules added, active on "_$EXTRACT(IBSTDT,4,5)_"/"_$EXTRACT(IBSTDT,6,7)_"/"_$EXTRACT(IBSTDT,2,3)_" (363)..."
 +1        DO MES^XPDUTL(.IBA)
 +2        QUIT 
 +3       ;
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       ;
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        QUIT 
 +4       ;
 +5       ;
RBF       ; billable services (399.1,.2)
 +1       ;; name ^ abbreviation
 +2       ;; 
 +3       ;;SKILLED NURSING^SNF
 +4       ;;
 +5       ;
BSF       ;  Bedsections (399.1,.12)
 +1       ;; name ^ abbreviation ^ other care
 +2       ;;    
 +3       ;;ICU^ICU
 +4       ;;PARTIAL HOSPITALIZATION^PARTIAL HOSP
 +5       ;;SKILLED NURSING CARE^SNF^SKILLED NURSING
 +6       ;;SUB-ACUTE CARE^SUBACUTE^SKILLED NURSING
 +7       ;;
 +8       ;
BIF       ;  Billing Items (363.21)
 +1       ;; name ^ type
 +2       ;;  
 +3       ;;PARTIAL HOSPITALIZATION^9
 +4       ;;
BRF       ;  Billing Rates File (363.3)
 +1       ;; name ^ abbreviation ^ distribution ^ billable item ^ charge method ^ base allowed
 +2       ;; 
 +3       ;;RC FACILITY PER DIEM^RC F/PD^1^1^1
 +4       ;; 
 +5       ;;RC FACILITY HR^RC F/HR^1^2^6^1
 +6       ;;RC FACILITY ML^RC F/ML^1^2^4
 +7       ;; 
 +8       ;;RC MISCELLANEOUS^RC MISC^1^9^1
 +9       ;; 
 +10      ;;RC PHYSICIAN MN^RC P/MN^1^2^5^1
 +11      ;;RC PHYSICIAN ML^RC P/ML^1^2^4
 +12      ;;
RSF       ;  Rate Schedules (363)
 +1       ;; rs name ^ rate type ^ bill type ^ billable service ^ effective date ^^ charge sets
 +2       ;; 
 +3       ;;RI-INPT^REIMBURSABLE INS.^1^^
 +4       ;;RI-SNF^REIMBURSABLE INS.^1^SKILLED NURSING^
 +5       ;;RI-OPT^REIMBURSABLE INS.^3^^
 +6       ;;RI-RX^REIMBURSABLE INS.^3^^^^:TL-RX FILL
 +7       ;; 
 +8       ;;NF-INPT^NO FAULT INS.^1^^
 +9       ;;NF-SNF^NO FAULT INS.^1^SKILLED NURSING^
 +10      ;;NF-OPT^NO FAULT INS.^3^^
 +11      ;;NF-RX^NO FAULT INS.^3^^^^:TL-RX FILL
 +12      ;; 
 +13      ;;WC-INPT^WORKERS' COMP.^1^^
 +14      ;;WC-SNF^WORKERS' COMP.^1^SKILLED NURSING^
 +15      ;;WC-OPT^WORKERS' COMP.^3^^
 +16      ;;WC-RX^WORKERS' COMP.^3^^^^:TL-RX FILL
 +17      ;;