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

IB20P424.m

Go to the documentation of this file. 
  1. IB20P424 ;ALB/CXW-IB*2*424 POST INIT RS FOR CHAMPVA/CHAMPVA RI;16-SEP-09
  1.  ;;2.0;INTEGRATED BILLING;**424**;21-MAR-94;Build 4
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ; 
  1.  Q
  1. POST ;
  1.  N IBA,IBEFFDT,EFFDT
  1.  D MSG("    IB*2*424 Post-Install ....."),MSG(" ")
  1.  ;
  1.  S IBEFFDT=3100101 ;            effective date of new RS
  1.  ;
  1.  D ADDORS(IBEFFDT) ;     inactivate existing CHAMPVA/CHAMPVA RI Rate Schedules
  1.  D ADDNRS(IBEFFDT) ;     add new Rate Schedules linking CHAMPVA Reasonable Charges
  1.  ;
  1.  D MSG("    IB*2*424 Post-Install Complete")
  1.  Q
  1.  ;
  1. ADDORS(EFFDT) ;Inactivate Existing CHAMPVA/CHAMPVA RI Rate Schedules
  1.  N INEFFDT,IBORS,IBORSFN,IBORSNM,IBORSTY,IBRATY,IBCNT
  1.  S IBCNT=0
  1.  ;
  1.  ;return the day before the effective date
  1.  I +$G(EFFDT) S INEFFDT=$$FMADD^XLFDT(EFFDT,-1)
  1.  I 'INEFFDT D MSG("**Error: No Date, could not inactivate old RS for CHAMPVA/CHAMPVA RI") Q
  1.  ;
  1.  S IBORSFN=0 F  S IBORSFN=$O(^IBE(363,IBORSFN)) Q:'IBORSFN  D
  1.  . S IBORS=$G(^IBE(363,IBORSFN,0))
  1.  . ;
  1.  . S IBORSNM=$P(IBORS,U,1)
  1.  . S IBORSTY=$P(IBORS,U,2)
  1.  . Q:'IBORSTY   ;quit if no rate type
  1.  . ;
  1.  . S IBRATY=$P($G(^DGCR(399.3,+IBORSTY,0)),U,1)
  1.  . I IBRATY'["CHAMPVA" Q  ; CHAMPVA/CHAMPVA RI only
  1.  . ;
  1.  . I $P(IBORS,U,5)=EFFDT Q  ;quit if active date exists
  1.  . I ($P(IBORS,U,6)="")!($P(IBORS,U,6)>INEFFDT) D
  1.  . . S IBCNT=IBCNT+1,DR=".06////"_INEFFDT,DIE="^IBE(363,",DA=+IBORSFN D ^DIE K DIE,DA,DR,X,Y
  1.  . . D MSG("      >> Inactivating Rate Schedule: "_IBORSNM)
  1.  D MSG("Total Rate Schedules: "_IBCNT_$S(IBCNT=1:" has",1:" have")_" been inactivated on "_$$FMTE^XLFDT(INEFFDT,2)_" (363)")
  1.  D MSG(" ")
  1.  Q
  1. ADDNRS(EFFDT) ; add CAHMPVA/CHAMPVA REIMB. INS. Rate Schedules (363) if they don't exist
  1.  ;
  1.  N IBI,IBJ,IBCNT,IBCNTCS,IBNRS,IBBVS,IBRT,IBDT,IBRS,IBFN
  1.  S IBCNT=0,IBDT=+$G(EFFDT)
  1.  I 'IBDT D MSG("**Error: No Date, could not link Rate Schedules to Charge Sets") Q
  1.  F IBI=1:1 S IBNRS=$P($T(NRSF+IBI),";;",2) Q:+IBNRS!(IBNRS="")  I $E(IBNRS)?1A D
  1.  . I $O(^IBE(363,"B",$P(IBNRS,U,1),0)) D MSG("** No Change, Rate Schedule linking "_$P(IBNRS,U,1)_" and RC already exists") Q
  1.  . S IBBVS=$P(IBNRS,U,4) I IBBVS'="" S IBBVS=$$MCCRUTL(IBBVS,13) D  Q:'IBBVS
  1.  .. I 'IBBVS D MSG("** Error: Billable Service "_$P(IBNRS,U,4)_" not defined, "_$P(IBNRS,U,1)_" not created") Q
  1.  . ;
  1.  . S IBRT=$P(IBNRS,U,2),IBRT=$O(^DGCR(399.3,"B",IBRT,0)) D  Q:'IBRT
  1.  .. I 'IBRT D MSG("** Error: Rate Type "_$P(IBNRS,U,2)_" not defined, "_$P(IBNRS,U,1)_" not created!!!")
  1.  .. I +$P($G(^DGCR(399.3,+IBRT,0)),U,3) S IBRT=0 D MSG("** Warning: Rate Type "_$P(IBNRS,U,2)_" not Active, RS "_$P(IBNRS,U,1)_" not created")
  1.  . ;
  1.  . F IBJ=1:1 S IBRS=$G(^IBE(363,IBJ,0)) I IBRS="" S DINUM=IBJ Q
  1.  . ;
  1.  . K DD,DO S DLAYGO=363,DIC="^IBE(363,",DIC(0)="L",X=$P(IBNRS,U,1) D FILE^DICN K DIC,DINUM,DLAYGO I Y<1 K X,Y Q
  1.  . S IBFN=+Y,IBCNT=IBCNT+1,IBCNTCS=0
  1.  . ;
  1.  . S DR=".02////"_IBRT_";.03////"_$P(IBNRS,U,3) S:+IBBVS DR=DR_";.04////"_IBBVS S DR=DR_";.05////"_IBDT
  1.  . ;I $P(IBNRS,U,6)'="" S DR=DR_";1.02////"_$P(IBNRS,U,6) ;admin fee
  1.  . I $P(IBNRS,U,7)'="" S DR=DR_";10////^S X=$P(IBNRS,U,7)"
  1.  . S DIE="^IBE(363,",DA=+Y D ^DIE K DIE,DA,DR,X,Y
  1.  . D MSG("      >> Adding Rate Schedule: "_$P(IBNRS,U))
  1.  . S IBCNTCS=IBCNTCS+$$RSCS(IBFN) ; add all Reasonable Charges Charge Sets
  1.  . ;
  1.  . I 'IBCNTCS D MSG("** Warning: No Charge Sets added to RS "_$P(IBNRS,U,1))
  1.  D MSG("Total Rate Schedules: "_IBCNT_$S(IBCNT=1:" has",1:" have")_" been added and activated on "_$$FMTE^XLFDT(IBDT,2)_" (363)")
  1.  D MSG(" ")
  1.  Q
  1.  ;
  1. RSCS(IBFN) ; add existing Charge Sets to RC, return number added
  1.  ; copy the Charge Sets from the corresponding RI RS (v2)
  1.  ; add the Charge Sets - RX COST
  1.  N IBCNT,IBNRS,IBRSNM,IBTY,IBVDT,IBCOPY,IBCS,IBXFN,IBCSFN,IBCSNM,IBCSAA
  1.  S (IBCNT,IBCOPY)=0
  1.  ;
  1.  S IBNRS=$G(^IBE(363,+$G(IBFN),0)),IBRSNM=$P(IBNRS,U,1)
  1.  S IBTY=$P(IBNRS,U,3)
  1.  S IBVDT=$$VERSDT^IBCRU8(2)
  1.  I IBRSNM["INPT" S IBCOPY=+$$RSEXISTS(IBVDT,"RI-INPT")
  1.  I IBRSNM["SNF" S IBCOPY=+$$RSEXISTS(IBVDT,"RI-SNF")
  1.  I IBRSNM["OPT" S IBCOPY=+$$RSEXISTS(IBVDT,"RI-OPT")
  1.  I IBRSNM["RX",+$$RSCSFILE(IBFN,"RX COST",1) S IBCNT=IBCNT+1
  1.  ;
  1.  I 'IBCOPY G RSCSQ
  1.  I +$P($G(^IBE(363,+IBCOPY,0)),U,3)=IBTY D
  1.  . ;
  1.  . S IBXFN=0 F  S IBXFN=$O(^IBE(363,IBCOPY,11,IBXFN)) Q:'IBXFN  D
  1.  .. S IBCS=$G(^IBE(363,IBCOPY,11,IBXFN,0)),IBCSFN=+IBCS
  1.  .. I +$$RSCSFILE(IBFN,$P($G(^IBE(363.1,IBCSFN,0)),U,1),$P(IBCS,U,2)) S IBCNT=IBCNT+1
  1.  ;
  1. RSCSQ Q IBCNT
  1.  ;
  1. RSCSFILE(IBFN,IBCSNM,IBCSAA) ; Add Charge Set to a Rate Schedule
  1.  N IBX,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y,IBCSFN S IBX=0
  1.  I $G(^IBE(363,+$G(IBFN),0))="" G RSCSFQ
  1.  I $G(IBCSNM)="" G RSCSFQ
  1.  S IBCSFN=$O(^IBE(363.1,"B",IBCSNM,0)) I 'IBCSFN G RSCSFQ
  1.  I $O(^IBE(363,IBFN,11,"B",IBCSFN,0)) G RSCSFQ
  1.  ;
  1.  S DLAYGO=363,DA(1)=+IBFN,DIC="^IBE(363,"_DA(1)_",11,",DIC(0)="L",X=IBCSNM,DIC("DR")=".02////"_$G(IBCSAA),DIC("P")="363.0011P" D ^DIC K DIC,DIE S IBX=1
  1. RSCSFQ Q IBX
  1.  ;
  1. RSEXISTS(EFFDT,NAME) ; return RS IFN if Rate Schedule exists for Effective Date
  1.  N IBX,IBRSFN,IBRS0 S IBX=0
  1.  I +$G(EFFDT),$G(NAME)'="" S IBRSFN=0 F  S IBRSFN=$O(^IBE(363,IBRSFN))  Q:'IBRSFN  D  I IBX Q
  1.  . S IBRS0=$G(^IBE(363,IBRSFN,0))
  1.  . I $P(IBRS0,U,1)=NAME,$P(IBRS0,U,5)=EFFDT S IBX=IBRSFN
  1.  Q IBX
  1.  ;
  1. MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
  1.  N IBX,IBY S IBY=""
  1.  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
  1.  Q IBY
  1.  ;
  1.  ;
  1. MSG(X) ;
  1.  D MES^XPDUTL(X)
  1.  Q
  1. NRSF ;New Rate Schedules (363)
  1.  ;; rs name^rate type^bill type^billable service^effective date^
  1.  ;; administrative fee^adjustment
  1.  ;;CVA-INPT^CHAMPVA^1^^^^
  1.  ;;CVA-SNF^CHAMPVA^1^SKILLED NURSING^^^
  1.  ;;CVA-OPT^CHAMPVA^3^^^^
  1.  ;;CVA-RX^CHAMPVA^3^^^^S X=X+5
  1.  ;;CVA RI-INPT^CHAMPVA REIMB. INS.^1^^^^
  1.  ;;CVA RI-SNF^CHAMPVA REIMB. INS.^1^SKILLED NURSING^^^
  1.  ;;CVA RI-OPT^CHAMPVA REIMB. INS.^3^^^^
  1.  ;;CVA RI-RX^CHAMPVA REIMB. INS.^3^^^^S X=X+5
  1.  ;;
  1.  ;