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

IB20P554.m

Go to the documentation of this file.
  1. IB20P554 ;ALB/DRF - IB*2.0*554 Post Init: Rate Type Update;09/30/15 7:55am
  1. ;;2.0;INTEGRATED BILLING;**554**;21-MAR-94;Build 81
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. Q
  1. ;
  1. POSTINIT ; Derived from IBYPPC, post-init for IB*2.0*52
  1. ;IB*2.0*554/DRF
  1. N I,J,RTDATA,DA,DR,DIC,DIE,DIK,X,Y
  1. D BMES^XPDUTL(" >> Starting the Post-Initialization routine ...")
  1. D ADDRT ; add Rate Type (399.3)
  1. D ADDER ; add Billing Errors (350.8)
  1. D ADDRS ; add Rate Schedules (363)
  1. D BMES^XPDUTL(" >> Completed the Post-Initialization routine.")
  1. Q ;POSTINIT
  1. ;
  1. ;
  1. ADDRT ;Add rate type for NON-VA reimbursable insurance
  1. N LIN,RTDATA,DIC,DIE,X,Y,J,DLAYGO,DR
  1. D MES^XPDUTL(" -> Adding new Rate Types to file 399.3 ...")
  1. F LIN=1:1 D Q:RTDATA="END"
  1. . S RTDATA=$P($T(NEWRT+LIN),";",3,99)
  1. . Q:RTDATA="END"
  1. . ; do a lookup and go on if exists.
  1. . S DIC="^DGCR(399.3,",X=$P(RTDATA,";") D ^DIC
  1. . I +Y>0 D Q
  1. .. D MES^XPDUTL(" "_$P(RTDATA,";")_" already exists.")
  1. . ; add entry
  1. . K DO
  1. . S DIC(0)="L",DLAYGO=399.3,DR=""
  1. . D FILE^DICN
  1. . I +Y=-1 D Q
  1. .. D MES^XPDUTL(" "_$P(RTDATA,";")_" failed to add!")
  1. . S DA=+Y
  1. . S DR=".02////"_$P(RTDATA,";",2)_";"
  1. . F J=3:1:6,8:1:11 S DR=$G(DR)_(J/100)_"///"_$P(RTDATA,";",J)_";"
  1. . S DIE=DIC K DIC
  1. . D ^DIE
  1. D MES^XPDUTL(" Rate Types completed.")
  1. Q ;ADDRT
  1. ;
  1. ;
  1. ADDER ;Add Billing Errors for NON-VA rate type
  1. D MES^XPDUTL(" -> Adding new Billing Errors to file 350.8 ...")
  1. F I=1:1 D Q:RTDATA="END"
  1. . S RTDATA=$P($T(NEWBE+I),";",3,99)
  1. . Q:RTDATA="END"
  1. . ; do a lookup and go on if exists.
  1. . S DIC="^IBE(350.8,",X=$P(RTDATA,";") D ^DIC
  1. . I +Y>0 D Q
  1. .. D MES^XPDUTL(" "_$P(RTDATA,";")_" already exists!")
  1. . ; add entry
  1. . S X=$P(RTDATA,";") D FILE^DICN
  1. . I +Y=-1 D Q
  1. .. D MES^XPDUTL(" "_$P(RTDATA,";")_" failed to add!")
  1. . ;set fields
  1. . S DIE=DIC K DIC
  1. . S DA=+Y
  1. . F J=2:1:5 S DR=$G(DR)_(J/100)_"////"_$P(RTDATA,";",J)_";"
  1. . D ^DIE
  1. D MES^XPDUTL(" -> Billing Errors completed.")
  1. Q ;ADDER
  1. ;
  1. ;
  1. ADDRS ; Add Rate Schedules (363) for FEE REIMB INS
  1. D MES^XPDUTL(" -> Adding new Rate Schedules to file 363 ...")
  1. N IBA,IBCNT,IBI,IBLN,IBFN,IBRT,IBBS,IBCNTCS,IBDISP,IBJ,IBLNCS,IBCS,IBCSFN,IBADMIN,DD,DO,DLAYGO,DIC,DIE,DA,DR,RXDT,X,Y S IBCNT=0
  1. F IBI=1:1 S IBLN=$P($T(RSF+IBI),";;",2) Q:IBLN="END" I $E(IBLN)?1A D
  1. . ;Check for problems
  1. . I $O(^IBE(363,"B",$P(IBLN,U,1),0)) Q ;Already exists
  1. . S IBBS=$P(IBLN,U,4) I IBBS'="" S IBBS=$$MCCRUTL(IBBS,13) Q:'IBBS ;Billable service invalid
  1. . S IBRT=$P(IBLN,U,2),IBRT=$O(^DGCR(399.3,"B",IBRT,0)) D Q:'IBRT
  1. .. I 'IBRT D MSG(" **** Rate Type "_$P(IBLN,U,2)_" not defined, RS "_$P(IBLN,U,1)_" not created")
  1. .. 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")
  1. . ;No problems found, so create entry
  1. . K DD,DO
  1. . S DLAYGO=363,DIC="^IBE(363,",DIC(0)="L",X=$P(IBLN,U,1)
  1. . D FILE^DICN K DIC,DINUM,DLAYGO
  1. . I Y<1 K X,Y Q
  1. . S IBFN=+Y,IBCNT=IBCNT+1
  1. . S DR=".02////"_IBRT_";.03////"_$P(IBLN,U,3) I +IBBS S DR=DR_";.04////"_IBBS
  1. . S DR=DR_";.05////"_$S($P(IBLN,U,1)["RX":3110318,1:3031219)
  1. . I $P(IBLN,U,1)["RX" S RXDT=$$RXDT()
  1. . I $P(IBLN,U,1)["RX",IBDISP]"" S DR=DR_";1.01///"_IBDISP
  1. . I $P(IBLN,U,1)["RX",IBADMIN]"" S DR=DR_";1.02////"_IBADMIN
  1. . S DIE="^IBE(363,",DA=+Y D ^DIE K DIE,DA,DR,X,Y
  1. . S IBCNTCS=0
  1. . ; add all Reasonable Charges Charge Sets
  1. . S IBCNTCS=$$RSCS(IBFN)
  1. . D MES^XPDUTL(" Total Reasonable Charge Set"_$S(IBCNTCS=1:" ",1:"s ")_IBCNTCS_" added to the rate schedule.")
  1. D MES^XPDUTL(" Rate Schedules completed.")
  1. Q ;ADDRS
  1. ;
  1. RSCS(IBFN) ; add existing Charge Sets to FR
  1. ; copy the Charge Sets from the corresponding RI RS (v2)
  1. N IBCNT,IBNRS,IBRSNM,IBTY,IBVDT,IBCOPY,IBCS,IBCS0,IBXFN,IBCSFN,IBCSNM,IBCSAA,IBNAME
  1. S (IBCNT,IBCOPY)=0
  1. S IBNRS=$G(^IBE(363,+$G(IBFN),0)),IBRSNM=$P(IBNRS,"^",1)
  1. S IBTY=$P(IBNRS,"^",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" S IBVDT=RXDT S IBCOPY=$$RSEXISTS(IBVDT,"RI-RX")
  1. I 'IBCOPY G RSCSQ
  1. I +$P($G(^IBE(363,+IBCOPY,0)),U,3)=IBTY D
  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. RSCSQ Q IBCNT
  1. ;
  1. ;
  1. RSCSFILE(IBFN,IBCSNM,IBCSAA) ; Add Charge Set to a Rate Schedule
  1. N IBX,DD,DO,DLAYGO,DIC,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. S DLAYGO=363,DA(1)=+IBFN,DIC="^IBE(363,"_DA(1)_",11,",DIC(0)="L"
  1. S X=IBCSNM,DIC("DR")=".02///"_$G(IBCSAA),DIC("P")="363.0011P"
  1. D ^DIC S:+Y IBX=1
  1. RSCSFQ Q IBX
  1. ;
  1. ;
  1. RSEXISTS(IBVDT,IBNAME) ; return RS IFN if Rate Schedule exists for Effective Date
  1. N IBX,IBRSFN,IBRS0 S IBX=0
  1. 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)=IBNAME,$P(IBRS0,U,5)=IBVDT S IBX=IBRSFN
  1. Q IBX
  1. ;
  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. N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
  1. S IBA(IBX)=$G(X)
  1. Q ;MSG
  1. ;
  1. ;
  1. RXDT() ;Copy the active RX charge schedule from RI to FR
  1. S IBCS="",IBCS=$O(^IBE(363,"B","RI-RX",IBCS),-1)
  1. S IBCS0=^IBE(363,IBCS,0)
  1. S IBDISP=$P($G(^IBE(363,IBCS,1)),U,1),IBADMIN=$G(^IBE(363,IBCS,10))
  1. Q $P(IBCS0,U,5)
  1. ;
  1. ;
  1. NEWRT ;Rate Type
  1. ;;FEE REIMB INS;FEE REIMB INS;;FEE INS;1;45;;1;1;1;28
  1. ;;END
  1. ;
  1. NEWBE ;Billing Errors
  1. ;;INCORRECT NON-VA RATE;Non-VA rate type used for bill that is not Non-VA;IB360;1;1
  1. ;;NON-VA RATE TYPE REQUIRED;Non-VA bill requires use of Non-VA rate type;IB361;1;1
  1. ;;END
  1. ;
  1. RSF ;Rate Schedules (363) for FEE REIMB INS
  1. ;;FR-INPT^FEE REIMB INS^1^INPATIENT
  1. ;;FR-SNF^FEE REIMB INS^1^SKILLED NURSING
  1. ;;FR-OPT^FEE REIMB INS^3
  1. ;;FR-RX^FEE REIMB INS^3
  1. ;;END
  1. ;
  1. CLM ;CLAIMS TRACKING TYPE FILE (356.6)
  1. ;;OPT-NON VA CARE^ONVC^2^1^1^1^^6
  1. ;;INP-NON VA CARE^INVC^1^^10^^^7
  1. ;;RX-NON VA CARE^RXNVC^3^1^5^1^^8
  1. ;;END