Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IB3PSOU

IB3PSOU.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. QUIT ;invalid entry
  1. ; Procedure updates rate schedules for default rate types or types
  1. ; specified in IBRATY by inactivating currently active rate
  1. ; schedules with date (IBDFFDT-1 ) that contain either RX Cost or
  1. ; TL Fill charge sets. Procedure adds new rate schedules for the
  1. ; rate types defined, setting the activation date to IBDFFDT and
  1. ; updating any defined Fees or adjustment. When rate schedules
  1. ; updated by this procedure also contain additional charge sets
  1. ; other than RX Cost or TL Fill then a separate rate schedule is
  1. ; created with those additional charge sets and the original fees
  1. ; and adjustments are maintained.
  1. ;
  1. ; Default Rate Types: REIMBURSABLE INS., NO FAULT INS., TORT
  1. ; FEASOR, WORKERS' COMP.
  1. ;
  1. ;Input parameters:
  1. ;
  1. ; IBRATY: (optional) rate type names separated by ^. If defined
  1. ; use these rate types instead of default types.
  1. ; IBDFFDT: (required) Effective date in form mm/dd/yyyy for new rate
  1. ; schedules.
  1. ; IBADFE: (optional) not currently in use.
  1. ; IBDISP: (required) Dispense Fee: to contain the new annual
  1. ; administrative fee for rate schedules.
  1. ; IBADJUST: (optional) if defined must be MUMPS code to define a
  1. ; unique adjustment to the rate schedule. If not defined default
  1. ; adjustment is S X = X + $G(IBADFE) + $G(IBDISP)
  1. ;
  1. ;ibraty=rate type name of file #399.3^rate type name^rate type name...
  1. ; =""for all-reimbursable ins., no fault ins., tort feasor, works' comp.
  1. ;ibeffdt=effective external date (mm/dd/yyyy)
  1. ;ibadfe=administrative fee (ddd.cc)
  1. ;ibdisp=dispensing fee (ddd.cc)
  1. ;ibadjust=adjustment mumps code
  1. ENT(IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST) ;update admin/disp fee and adjustment of file #363
  1. N A,B,X,Y,IBA,IBB,IBC,IBINADT,IBRFRC,IBRCOST
  1. S:IBRATY="" IBRATY="REIMBURSABLE INS.^NO FAULT INS.^WORKERS' COMP.^TORT FEASOR"
  1. S IBRATY="^"_IBRATY_"^"
  1. S X=IBEFFDT D ^%DT S IBEFFDT=Y,IBINADT=$$FMADD^XLFDT(IBEFFDT,-1)
  1. ;get iens of 'tl-rx fill' and 'rx cost' of charge set file #363.1
  1. ;set ien of 'ia-rx fill' in ibrfrc to create ia-rx rate schedule *538
  1. 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_"^"
  1. ;loop through charge set iens of 'ti-rx til' and'rx cost' in ibrfrc
  1. F IBA=2:1 S IBB=$P(IBRFRC,U,IBA) QUIT:'IBB D
  1. . N IBIEN,IBRTNM
  1. . ;find rate schedule with no inactive date, effective date<ibeffdt, rate type contained in ibraty
  1. . 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
  1. .. ;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'
  1. .. S IBC=$$COPY(IBIEN,"") S:IBC IBC=$$COPY(IBIEN,1)
  1. .. ;inactivate the copy-from entry.
  1. .. D INACT(IBIEN)
  1. .. QUIT
  1. . QUIT
  1. QUIT
  1. ;
  1. ;
  1. ;ibien=the ien of the copy-from rate schedule file #363
  1. ;ibc="" copy and update adm, disp, adj including only charge sets for 'tr-rf fill' and 'rx cost'
  1. ; =1 copy and no update including all other charge set only
  1. COPY(IBIEN,IBC) ;extrinsic function ="" or 1
  1. N IBD,IBE,IBNIEN,IBRS0,IBRS1,IBRS10,IBRS11,IBRSCS
  1. ;copy-to a new entry from ibien containing charge set iba
  1. N IBNRX S IBNRX=""
  1. S IBRS0=$G(^IBE(363,IBIEN,0)),IBRS1=$G(^(1)),IBRS10=$G(^(10)),IBRS11=$G(^(11)) D QUIT:'$G(IBNIEN)
  1. . ;add new charge set hmn/inelig-rx *510
  1. . I 'IBC,'$O(^IBE(363,"B",$P($P(IBRS0,U),"-")_"-RX",0)) S IBNRX=$P($P(IBRS0,U),"-")_"-RX"
  1. . ;add new entry of file #363
  1. . N DO,DIC,DA,X,DINUM,Y,DTOUT,DUOUT
  1. . N DIE,DA,DR
  1. . S DIC="^IBE(363,",DIC(0)="F",X=$S(IBNRX="":$P(IBRS0,U),1:IBNRX)
  1. . ;copy data fields with new administration fee
  1. . S DIC("DR")=".02////"_$P(IBRS0,U,2)_";.03////"_$P(IBRS0,U,3)_";.04////"_$P(IBRS0,U,4)_";.05////"_IBEFFDT
  1. . ;reserve adm, disp values
  1. . I IBC S DIC("DR")=DIC("DR")_";1.01////"_$P(IBRS1,U)_";1.02////"_$P(IBRS1,U,2)
  1. . ;update adm, disp values
  1. . I 'IBC S DIC("DR")=DIC("DR")_";1.01////"_$G(IBDISP)_";1.02////"_$G(IBADFE)
  1. . D FILE^DICN I Y<0 D MES^XPDUTL("The Rate Schedule "_X_" update failed") QUIT
  1. . S IBNIEN=+Y
  1. . ;set adjustment value
  1. . S DIE="^IBE(363,",DA=IBNIEN,DR="10////"_$S('IBC:$G(IBADJUST),1:IBRS10)
  1. . D ^DIE
  1. . QUIT
  1. ;copy/edit charge set multiple.
  1. S IBRSCS=0 F S IBRSCS=$O(^IBE(363,IBIEN,11,IBRSCS)) QUIT:'IBRSCS S IBD=^(IBRSCS,0) D
  1. . N DO,DIC,DA,X,DINUM,Y,DTOUT,DUOUT
  1. . I IBC,IBRFRC[("^"_$P(IBD,U)_"^") QUIT
  1. . I 'IBC,IBRFRC'[("^"_$P(IBD,U)_"^") S IBE=1 QUIT
  1. . ;change charge set 'tr-rf fill' to 'rx cost'
  1. . I 'IBC,IBRCOST'[("^"_$P(IBD,U)_"^") S $P(IBD,U)=$P(IBRCOST,U,2),$P(IBD,U,2)=1
  1. . ;not 'rx cost' the auto add is null - comment out *510
  1. . ;S:IBC $P(IBD,U,2)=""
  1. . 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)
  1. . D FILE^DICN I Y<0 D MES^XPDUTL("The Rate Schedule "_$P(IBRS0,U)_"'s Charge Set "_X_" update failed")
  1. . QUIT
  1. QUIT $G(IBE)
  1. ;
  1. ;ibien=the ien of the file #363
  1. INACT(IBIEN) ;inactivate the copy-from rate schedule
  1. N D,D0,DI,DIC,DQ,DIE,DA,DR,DTOUT
  1. S DIE="^IBE(363,",DA=IBIEN,DR=".06////"_IBINADT D ^DIE
  1. QUIT
  1. ;