- 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 Feb 18, 2025@23:32:10 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 ;