IB3PSOU ;WOIFO/PLT-Outpatient Pharmacy Administrative Fee Change Update ;8/17/10 10:24
;;2.0;INTEGRATED BILLING;**437,510,538**;21-MAR-94;Build 29
;;Per VA Directive 6402, this routine should not be modified.
QUIT ;invalid entry
; Procedure updates rate schedules for default rate types or types
; specified in IBRATY by inactivating currently active rate
; schedules with date (IBDFFDT-1 ) that contain either RX Cost or
; TL Fill charge sets. Procedure adds new rate schedules for the
; rate types defined, setting the activation date to IBDFFDT and
; updating any defined Fees or adjustment. When rate schedules
; updated by this procedure also contain additional charge sets
; other than RX Cost or TL Fill then a separate rate schedule is
; created with those additional charge sets and the original fees
; and adjustments are maintained.
;
; Default Rate Types: REIMBURSABLE INS., NO FAULT INS., TORT
; FEASOR, WORKERS' COMP.
;
;Input parameters:
;
; IBRATY: (optional) rate type names separated by ^. If defined
; use these rate types instead of default types.
; IBDFFDT: (required) Effective date in form mm/dd/yyyy for new rate
; schedules.
; IBADFE: (optional) not currently in use.
; IBDISP: (required) Dispense Fee: to contain the new annual
; administrative fee for rate schedules.
; IBADJUST: (optional) if defined must be MUMPS code to define a
; unique adjustment to the rate schedule. If not defined default
; adjustment is S X = X + $G(IBADFE) + $G(IBDISP)
;
;ibraty=rate type name of file #399.3^rate type name^rate type name...
; =""for all-reimbursable ins., no fault ins., tort feasor, works' comp.
;ibeffdt=effective external date (mm/dd/yyyy)
;ibadfe=administrative fee (ddd.cc)
;ibdisp=dispensing fee (ddd.cc)
;ibadjust=adjustment mumps code
ENT(IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST) ;update admin/disp fee and adjustment of file #363
N A,B,X,Y,IBA,IBB,IBC,IBINADT,IBRFRC,IBRCOST
S:IBRATY="" IBRATY="REIMBURSABLE INS.^NO FAULT INS.^WORKERS' COMP.^TORT FEASOR"
S IBRATY="^"_IBRATY_"^"
S X=IBEFFDT D ^%DT S IBEFFDT=Y,IBINADT=$$FMADD^XLFDT(IBEFFDT,-1)
;get iens of 'tl-rx fill' and 'rx cost' of charge set file #363.1
;set ien of 'ia-rx fill' in ibrfrc to create ia-rx rate schedule *538
S (IBRFRC,IBRCOST)="^" F A="TL-RX FILL","RX COST","IA-RX FILL" S B=0 F B=$O(^IBE(363.1,"B",A,B)) QUIT:'B S IBRFRC=IBRFRC_B_"^" S:A="RX COST" IBRCOST=IBRCOST_B_"^"
;loop through charge set iens of 'ti-rx til' and'rx cost' in ibrfrc
F IBA=2:1 S IBB=$P(IBRFRC,U,IBA) QUIT:'IBB D
. N IBIEN,IBRTNM
. ;find rate schedule with no inactive date, effective date<ibeffdt, rate type contained in ibraty
. S IBIEN=0 F S IBIEN=$O(^IBE(363,"C",IBB,IBIEN)) QUIT:'IBIEN S A=^IBE(363,IBIEN,0),IBRTNM=$P(^DGCR(399.3,$P(A,U,2),0),U) I '$P(A,U,6),$P(A,U,5)<IBEFFDT,$P(A,U,2),IBRATY[("^"_IBRTNM_"^") D
.. ;copy-to new entry, and copy-to new entry again if the copy-from entry has charge set other than 'tr-rf fill' and 'rx cost'
.. S IBC=$$COPY(IBIEN,"") S:IBC IBC=$$COPY(IBIEN,1)
.. ;inactivate the copy-from entry.
.. D INACT(IBIEN)
.. QUIT
. QUIT
QUIT
;
;
;ibien=the ien of the copy-from rate schedule file #363
;ibc="" copy and update adm, disp, adj including only charge sets for 'tr-rf fill' and 'rx cost'
; =1 copy and no update including all other charge set only
COPY(IBIEN,IBC) ;extrinsic function ="" or 1
N IBD,IBE,IBNIEN,IBRS0,IBRS1,IBRS10,IBRS11,IBRSCS
;copy-to a new entry from ibien containing charge set iba
N IBNRX S IBNRX=""
S IBRS0=$G(^IBE(363,IBIEN,0)),IBRS1=$G(^(1)),IBRS10=$G(^(10)),IBRS11=$G(^(11)) D QUIT:'$G(IBNIEN)
. ;add new charge set hmn/inelig-rx *510
. I 'IBC,'$O(^IBE(363,"B",$P($P(IBRS0,U),"-")_"-RX",0)) S IBNRX=$P($P(IBRS0,U),"-")_"-RX"
. ;add new entry of file #363
. N DO,DIC,DA,X,DINUM,Y,DTOUT,DUOUT
. N DIE,DA,DR
. S DIC="^IBE(363,",DIC(0)="F",X=$S(IBNRX="":$P(IBRS0,U),1:IBNRX)
. ;copy data fields with new administration fee
. S DIC("DR")=".02////"_$P(IBRS0,U,2)_";.03////"_$P(IBRS0,U,3)_";.04////"_$P(IBRS0,U,4)_";.05////"_IBEFFDT
. ;reserve adm, disp values
. I IBC S DIC("DR")=DIC("DR")_";1.01////"_$P(IBRS1,U)_";1.02////"_$P(IBRS1,U,2)
. ;update adm, disp values
. I 'IBC S DIC("DR")=DIC("DR")_";1.01////"_$G(IBDISP)_";1.02////"_$G(IBADFE)
. D FILE^DICN I Y<0 D MES^XPDUTL("The Rate Schedule "_X_" update failed") QUIT
. S IBNIEN=+Y
. ;set adjustment value
. S DIE="^IBE(363,",DA=IBNIEN,DR="10////"_$S('IBC:$G(IBADJUST),1:IBRS10)
. D ^DIE
. QUIT
;copy/edit charge set multiple.
S IBRSCS=0 F S IBRSCS=$O(^IBE(363,IBIEN,11,IBRSCS)) QUIT:'IBRSCS S IBD=^(IBRSCS,0) D
. N DO,DIC,DA,X,DINUM,Y,DTOUT,DUOUT
. I IBC,IBRFRC[("^"_$P(IBD,U)_"^") QUIT
. I 'IBC,IBRFRC'[("^"_$P(IBD,U)_"^") S IBE=1 QUIT
. ;change charge set 'tr-rf fill' to 'rx cost'
. I 'IBC,IBRCOST'[("^"_$P(IBD,U)_"^") S $P(IBD,U)=$P(IBRCOST,U,2),$P(IBD,U,2)=1
. ;not 'rx cost' the auto add is null - comment out *510
. ;S:IBC $P(IBD,U,2)=""
. S DIC="^IBE(363,"_IBNIEN_",11,",DIC(0)="F",DA(1)=IBNIEN,X=$P(IBD,U),DINUM=$S(IBNRX="":IBRSCS,1:1),DIC("DR")=".02////"_$P(IBD,U,2)
. D FILE^DICN I Y<0 D MES^XPDUTL("The Rate Schedule "_$P(IBRS0,U)_"'s Charge Set "_X_" update failed")
. QUIT
QUIT $G(IBE)
;
;ibien=the ien of the file #363
INACT(IBIEN) ;inactivate the copy-from rate schedule
N D,D0,DI,DIC,DQ,DIE,DA,DR,DTOUT
S DIE="^IBE(363,",DA=IBIEN,DR=".06////"_IBINADT D ^DIE
QUIT
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB3PSOU 5539 printed Sep 23, 2025@19:41:58 Page 2
IB3PSOU ;WOIFO/PLT-Outpatient Pharmacy Administrative Fee Change Update ;8/17/10 10:24
+1 ;;2.0;INTEGRATED BILLING;**437,510,538**;21-MAR-94;Build 29
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;invalid entry
QUIT
+4 ; Procedure updates rate schedules for default rate types or types
+5 ; specified in IBRATY by inactivating currently active rate
+6 ; schedules with date (IBDFFDT-1 ) that contain either RX Cost or
+7 ; TL Fill charge sets. Procedure adds new rate schedules for the
+8 ; rate types defined, setting the activation date to IBDFFDT and
+9 ; updating any defined Fees or adjustment. When rate schedules
+10 ; updated by this procedure also contain additional charge sets
+11 ; other than RX Cost or TL Fill then a separate rate schedule is
+12 ; created with those additional charge sets and the original fees
+13 ; and adjustments are maintained.
+14 ;
+15 ; Default Rate Types: REIMBURSABLE INS., NO FAULT INS., TORT
+16 ; FEASOR, WORKERS' COMP.
+17 ;
+18 ;Input parameters:
+19 ;
+20 ; IBRATY: (optional) rate type names separated by ^. If defined
+21 ; use these rate types instead of default types.
+22 ; IBDFFDT: (required) Effective date in form mm/dd/yyyy for new rate
+23 ; schedules.
+24 ; IBADFE: (optional) not currently in use.
+25 ; IBDISP: (required) Dispense Fee: to contain the new annual
+26 ; administrative fee for rate schedules.
+27 ; IBADJUST: (optional) if defined must be MUMPS code to define a
+28 ; unique adjustment to the rate schedule. If not defined default
+29 ; adjustment is S X = X + $G(IBADFE) + $G(IBDISP)
+30 ;
+31 ;ibraty=rate type name of file #399.3^rate type name^rate type name...
+32 ; =""for all-reimbursable ins., no fault ins., tort feasor, works' comp.
+33 ;ibeffdt=effective external date (mm/dd/yyyy)
+34 ;ibadfe=administrative fee (ddd.cc)
+35 ;ibdisp=dispensing fee (ddd.cc)
+36 ;ibadjust=adjustment mumps code
ENT(IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST) ;update admin/disp fee and adjustment of file #363
+1 NEW A,B,X,Y,IBA,IBB,IBC,IBINADT,IBRFRC,IBRCOST
+2 if IBRATY=""
SET IBRATY="REIMBURSABLE INS.^NO FAULT INS.^WORKERS' COMP.^TORT FEASOR"
+3 SET IBRATY="^"_IBRATY_"^"
+4 SET X=IBEFFDT
DO ^%DT
SET IBEFFDT=Y
SET IBINADT=$$FMADD^XLFDT(IBEFFDT,-1)
+5 ;get iens of 'tl-rx fill' and 'rx cost' of charge set file #363.1
+6 ;set ien of 'ia-rx fill' in ibrfrc to create ia-rx rate schedule *538
+7 SET (IBRFRC,IBRCOST)="^"
FOR A="TL-RX FILL","RX COST","IA-RX FILL"
SET B=0
FOR B=$ORDER(^IBE(363.1,"B",A,B))
if 'B
QUIT
SET IBRFRC=IBRFRC_B_"^"
if A="RX COST"
SET IBRCOST=IBRCOST_B_"^"
+8 ;loop through charge set iens of 'ti-rx til' and'rx cost' in ibrfrc
+9 FOR IBA=2:1
SET IBB=$PIECE(IBRFRC,U,IBA)
if 'IBB
QUIT
Begin DoDot:1
+10 NEW IBIEN,IBRTNM
+11 ;find rate schedule with no inactive date, effective date<ibeffdt, rate type contained in ibraty
+12 SET IBIEN=0
FOR
SET IBIEN=$ORDER(^IBE(363,"C",IBB,IBIEN))
if 'IBIEN
QUIT
SET A=^IBE(363,IBIEN,0)
SET IBRTNM=$PIECE(^DGCR(399.3,$PIECE(A,U,2),0),U)
IF '$PIECE(A,U,6)
IF $PIECE(A,U,5)<IBEFFDT
IF $PIECE(A,U,2)
IF IBRATY[("^"_IBRTNM_"^")
Begin DoDot:2
+13 ;copy-to new entry, and copy-to new entry again if the copy-from entry has charge set other than 'tr-rf fill' and 'rx cost'
+14 SET IBC=$$COPY(IBIEN,"")
if IBC
SET IBC=$$COPY(IBIEN,1)
+15 ;inactivate the copy-from entry.
+16 DO INACT(IBIEN)
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 QUIT
+20 ;
+21 ;
+22 ;ibien=the ien of the copy-from rate schedule file #363
+23 ;ibc="" copy and update adm, disp, adj including only charge sets for 'tr-rf fill' and 'rx cost'
+24 ; =1 copy and no update including all other charge set only
COPY(IBIEN,IBC) ;extrinsic function ="" or 1
+1 NEW IBD,IBE,IBNIEN,IBRS0,IBRS1,IBRS10,IBRS11,IBRSCS
+2 ;copy-to a new entry from ibien containing charge set iba
+3 NEW IBNRX
SET IBNRX=""
+4 SET IBRS0=$GET(^IBE(363,IBIEN,0))
SET IBRS1=$GET(^(1))
SET IBRS10=$GET(^(10))
SET IBRS11=$GET(^(11))
Begin DoDot:1
+5 ;add new charge set hmn/inelig-rx *510
+6 IF 'IBC
IF '$ORDER(^IBE(363,"B",$PIECE($PIECE(IBRS0,U),"-")_"-RX",0))
SET IBNRX=$PIECE($PIECE(IBRS0,U),"-")_"-RX"
+7 ;add new entry of file #363
+8 NEW DO,DIC,DA,X,DINUM,Y,DTOUT,DUOUT
+9 NEW DIE,DA,DR
+10 SET DIC="^IBE(363,"
SET DIC(0)="F"
SET X=$SELECT(IBNRX="":$PIECE(IBRS0,U),1:IBNRX)
+11 ;copy data fields with new administration fee
+12 SET DIC("DR")=".02////"_$PIECE(IBRS0,U,2)_";.03////"_$PIECE(IBRS0,U,3)_";.04////"_$PIECE(IBRS0,U,4)_";.05////"_IBEFFDT
+13 ;reserve adm, disp values
+14 IF IBC
SET DIC("DR")=DIC("DR")_";1.01////"_$PIECE(IBRS1,U)_";1.02////"_$PIECE(IBRS1,U,2)
+15 ;update adm, disp values
+16 IF 'IBC
SET DIC("DR")=DIC("DR")_";1.01////"_$GET(IBDISP)_";1.02////"_$GET(IBADFE)
+17 DO FILE^DICN
IF Y<0
DO MES^XPDUTL("The Rate Schedule "_X_" update failed")
QUIT
+18 SET IBNIEN=+Y
+19 ;set adjustment value
+20 SET DIE="^IBE(363,"
SET DA=IBNIEN
SET DR="10////"_$SELECT('IBC:$GET(IBADJUST),1:IBRS10)
+21 DO ^DIE
+22 QUIT
End DoDot:1
if '$GET(IBNIEN)
QUIT
+23 ;copy/edit charge set multiple.
+24 SET IBRSCS=0
FOR
SET IBRSCS=$ORDER(^IBE(363,IBIEN,11,IBRSCS))
if 'IBRSCS
QUIT
SET IBD=^(IBRSCS,0)
Begin DoDot:1
+25 NEW DO,DIC,DA,X,DINUM,Y,DTOUT,DUOUT
+26 IF IBC
IF IBRFRC[("^"_$PIECE(IBD,U)_"^")
QUIT
+27 IF 'IBC
IF IBRFRC'[("^"_$PIECE(IBD,U)_"^")
SET IBE=1
QUIT
+28 ;change charge set 'tr-rf fill' to 'rx cost'
+29 IF 'IBC
IF IBRCOST'[("^"_$PIECE(IBD,U)_"^")
SET $PIECE(IBD,U)=$PIECE(IBRCOST,U,2)
SET $PIECE(IBD,U,2)=1
+30 ;not 'rx cost' the auto add is null - comment out *510
+31 ;S:IBC $P(IBD,U,2)=""
+32 SET DIC="^IBE(363,"_IBNIEN_",11,"
SET DIC(0)="F"
SET DA(1)=IBNIEN
SET X=$PIECE(IBD,U)
SET DINUM=$SELECT(IBNRX="":IBRSCS,1:1)
SET DIC("DR")=".02////"_$PIECE(IBD,U,2)
+33 DO FILE^DICN
IF Y<0
DO MES^XPDUTL("The Rate Schedule "_$PIECE(IBRS0,U)_"'s Charge Set "_X_" update failed")
+34 QUIT
End DoDot:1
+35 QUIT $GET(IBE)
+36 ;
+37 ;ibien=the ien of the file #363
INACT(IBIEN) ;inactivate the copy-from rate schedule
+1 NEW D,D0,DI,DIC,DQ,DIE,DA,DR,DTOUT
+2 SET DIE="^IBE(363,"
SET DA=IBIEN
SET DR=".06////"_IBINADT
DO ^DIE
+3 QUIT
+4 ;
