IB20P498 ;ALB/CXW - post init for IB*2.0*498 ;04-05-2013
;;2.0;INTEGRATED BILLING;**498**;21-MAR-94;Build 27
;;Per VHA Directive 2004-038, this routine should not be modified.
;
Q
;
POST ; update Rate Schedules (363) for CHAMPVA & CHAMPVA RI
D MES^XPDUTL("Patch Post-Install starts...")
;
N IBI,IBCNTCS,IBNRS,IBIDT,IBFN
F IBI=1:1 S IBNRS=$P($T(RSF+IBI),";;",2) Q:+IBNRS!(IBNRS="") I $E(IBNRS)?1A D
. S IBFN=$O(^IBE(363,"B",$P(IBNRS,U),0))
. I 'IBFN D MES^XPDUTL("** No Update, Rate Schedule "_$P(IBNRS,U)_" doesn't exist.") Q
. S IBIDT=+$P($G(^IBE(363,IBFN,0)),U,6)
. ; champva & champva reim. effective date 3100101
. I IBIDT,(IBIDT<3100101) D MES^XPDUTL("** No Update, Rate Schedule "_$P(IBNRS,U)_" is inactive from "_$$FMTE^XLFDT(IBIDT,2)_".") Q
. S IBCNTCS=0
. D MES^XPDUTL(" >> Updating "_$P(IBNRS,U)_" rate schedule for "_$P(IBNRS,U,2)_" rate type.")
. ; add all Reasonable Charges Charge Sets
. S IBCNTCS=$$RSCS(IBFN)
. D MES^XPDUTL(" Total Charge Set"_$S(IBCNTCS=1:" ",1:"s ")_IBCNTCS_" added to the rate schedule.")
;
D MES^XPDUTL("Patch Post-Install is complete.")
Q
;
RSCS(IBFN) ; add existing Charge Sets to CVA & CVA RI
; copy the Charge Sets from the corresponding RI RS (v2)
N IBCNT,IBNRS,IBRSNM,IBTY,IBVDT,IBCOPY,IBCS,IBXFN,IBCSFN,IBCSNM,IBCSAA,IBNAME
S (IBCNT,IBCOPY)=0
;
S IBNRS=$G(^IBE(363,+$G(IBFN),0)),IBRSNM=$P(IBNRS,U,1)
S IBTY=$P(IBNRS,U,3)
S IBVDT=$$VERSDT^IBCRU8(2)
I IBRSNM["INPT" S IBCOPY=+$$RSEXISTS(IBVDT,"RI-INPT")
I IBRSNM["SNF" S IBCOPY=+$$RSEXISTS(IBVDT,"RI-SNF")
I IBRSNM["OPT" S IBCOPY=+$$RSEXISTS(IBVDT,"RI-OPT")
;
I 'IBCOPY G RSCSQ
I +$P($G(^IBE(363,+IBCOPY,0)),U,3)=IBTY D
. S IBXFN=0 F S IBXFN=$O(^IBE(363,IBCOPY,11,IBXFN)) Q:'IBXFN D
.. S IBCS=$G(^IBE(363,IBCOPY,11,IBXFN,0)),IBCSFN=+IBCS
.. I +$$RSCSFILE(IBFN,$P($G(^IBE(363.1,IBCSFN,0)),U,1),$P(IBCS,U,2)) S IBCNT=IBCNT+1
;
RSCSQ Q IBCNT
;
RSCSFILE(IBFN,IBCSNM,IBCSAA) ; Add Charge Set to a Rate Schedule
N IBX,DD,DO,DLAYGO,DIC,DA,DR,X,Y,IBCSFN S IBX=0
I $G(^IBE(363,+$G(IBFN),0))="" G RSCSFQ
I $G(IBCSNM)="" G RSCSFQ
S IBCSFN=$O(^IBE(363.1,"B",IBCSNM,0)) I 'IBCSFN G RSCSFQ
I $O(^IBE(363,IBFN,11,"B",IBCSFN,0)) G RSCSFQ
;
S DLAYGO=363,DA(1)=+IBFN,DIC="^IBE(363,"_DA(1)_",11,",DIC(0)="L"
S X=IBCSNM,DIC("DR")=".02///"_$G(IBCSAA),DIC("P")="363.0011P" D ^DIC S:+Y IBX=1
RSCSFQ Q IBX
;
RSEXISTS(IBVDT,IBNAME) ; return RS IFN if Rate Schedule exists for Effective Date
N IBX,IBRSFN,IBRS0 S IBX=0
S IBRSFN=0 F S IBRSFN=$O(^IBE(363,IBRSFN)) Q:'IBRSFN D I IBX Q
. S IBRS0=$G(^IBE(363,IBRSFN,0))
. I $P(IBRS0,U,1)=IBNAME,$P(IBRS0,U,5)=IBVDT S IBX=IBRSFN
Q IBX
;
RSF ; Rate Schedules (363) for CHAMPVA & CHAMPVA RI
;; rs name^rate type
;;CVA-INPT^CHAMPVA
;;CVA-SNF^CHAMPVA
;;CVA-OPT^CHAMPVA
;;CVA RI-INPT^CHAMPVA REIMB. INS.
;;CVA RI-SNF^CHAMPVA REIMB. INS.
;;CVA RI-OPT^CHAMPVA REIMB. INS.
;;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P498 2932 printed Dec 13, 2024@02:03:16 Page 2
IB20P498 ;ALB/CXW - post init for IB*2.0*498 ;04-05-2013
+1 ;;2.0;INTEGRATED BILLING;**498**;21-MAR-94;Build 27
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
POST ; update Rate Schedules (363) for CHAMPVA & CHAMPVA RI
+1 DO MES^XPDUTL("Patch Post-Install starts...")
+2 ;
+3 NEW IBI,IBCNTCS,IBNRS,IBIDT,IBFN
+4 FOR IBI=1:1
SET IBNRS=$PIECE($TEXT(RSF+IBI),";;",2)
if +IBNRS!(IBNRS="")
QUIT
IF $EXTRACT(IBNRS)?1A
Begin DoDot:1
+5 SET IBFN=$ORDER(^IBE(363,"B",$PIECE(IBNRS,U),0))
+6 IF 'IBFN
DO MES^XPDUTL("** No Update, Rate Schedule "_$PIECE(IBNRS,U)_" doesn't exist.")
QUIT
+7 SET IBIDT=+$PIECE($GET(^IBE(363,IBFN,0)),U,6)
+8 ; champva & champva reim. effective date 3100101
+9 IF IBIDT
IF (IBIDT<3100101)
DO MES^XPDUTL("** No Update, Rate Schedule "_$PIECE(IBNRS,U)_" is inactive from "_$$FMTE^XLFDT(IBIDT,2)_".")
QUIT
+10 SET IBCNTCS=0
+11 DO MES^XPDUTL(" >> Updating "_$PIECE(IBNRS,U)_" rate schedule for "_$PIECE(IBNRS,U,2)_" rate type.")
+12 ; add all Reasonable Charges Charge Sets
+13 SET IBCNTCS=$$RSCS(IBFN)
+14 DO MES^XPDUTL(" Total Charge Set"_$SELECT(IBCNTCS=1:" ",1:"s ")_IBCNTCS_" added to the rate schedule.")
End DoDot:1
+15 ;
+16 DO MES^XPDUTL("Patch Post-Install is complete.")
+17 QUIT
+18 ;
RSCS(IBFN) ; add existing Charge Sets to CVA & CVA RI
+1 ; copy the Charge Sets from the corresponding RI RS (v2)
+2 NEW IBCNT,IBNRS,IBRSNM,IBTY,IBVDT,IBCOPY,IBCS,IBXFN,IBCSFN,IBCSNM,IBCSAA,IBNAME
+3 SET (IBCNT,IBCOPY)=0
+4 ;
+5 SET IBNRS=$GET(^IBE(363,+$GET(IBFN),0))
SET IBRSNM=$PIECE(IBNRS,U,1)
+6 SET IBTY=$PIECE(IBNRS,U,3)
+7 SET IBVDT=$$VERSDT^IBCRU8(2)
+8 IF IBRSNM["INPT"
SET IBCOPY=+$$RSEXISTS(IBVDT,"RI-INPT")
+9 IF IBRSNM["SNF"
SET IBCOPY=+$$RSEXISTS(IBVDT,"RI-SNF")
+10 IF IBRSNM["OPT"
SET IBCOPY=+$$RSEXISTS(IBVDT,"RI-OPT")
+11 ;
+12 IF 'IBCOPY
GOTO RSCSQ
+13 IF +$PIECE($GET(^IBE(363,+IBCOPY,0)),U,3)=IBTY
Begin DoDot:1
+14 SET IBXFN=0
FOR
SET IBXFN=$ORDER(^IBE(363,IBCOPY,11,IBXFN))
if 'IBXFN
QUIT
Begin DoDot:2
+15 SET IBCS=$GET(^IBE(363,IBCOPY,11,IBXFN,0))
SET IBCSFN=+IBCS
+16 IF +$$RSCSFILE(IBFN,$PIECE($GET(^IBE(363.1,IBCSFN,0)),U,1),$PIECE(IBCS,U,2))
SET IBCNT=IBCNT+1
End DoDot:2
End DoDot:1
+17 ;
RSCSQ QUIT IBCNT
+1 ;
RSCSFILE(IBFN,IBCSNM,IBCSAA) ; Add Charge Set to a Rate Schedule
+1 NEW IBX,DD,DO,DLAYGO,DIC,DA,DR,X,Y,IBCSFN
SET IBX=0
+2 IF $GET(^IBE(363,+$GET(IBFN),0))=""
GOTO RSCSFQ
+3 IF $GET(IBCSNM)=""
GOTO RSCSFQ
+4 SET IBCSFN=$ORDER(^IBE(363.1,"B",IBCSNM,0))
IF 'IBCSFN
GOTO RSCSFQ
+5 IF $ORDER(^IBE(363,IBFN,11,"B",IBCSFN,0))
GOTO RSCSFQ
+6 ;
+7 SET DLAYGO=363
SET DA(1)=+IBFN
SET DIC="^IBE(363,"_DA(1)_",11,"
SET DIC(0)="L"
+8 SET X=IBCSNM
SET DIC("DR")=".02///"_$GET(IBCSAA)
SET DIC("P")="363.0011P"
DO ^DIC
if +Y
SET IBX=1
RSCSFQ QUIT IBX
+1 ;
RSEXISTS(IBVDT,IBNAME) ; return RS IFN if Rate Schedule exists for Effective Date
+1 NEW IBX,IBRSFN,IBRS0
SET IBX=0
+2 SET IBRSFN=0
FOR
SET IBRSFN=$ORDER(^IBE(363,IBRSFN))
if 'IBRSFN
QUIT
Begin DoDot:1
+3 SET IBRS0=$GET(^IBE(363,IBRSFN,0))
+4 IF $PIECE(IBRS0,U,1)=IBNAME
IF $PIECE(IBRS0,U,5)=IBVDT
SET IBX=IBRSFN
End DoDot:1
IF IBX
QUIT
+5 QUIT IBX
+6 ;
RSF ; Rate Schedules (363) for CHAMPVA & CHAMPVA RI
+1 ;; rs name^rate type
+2 ;;CVA-INPT^CHAMPVA
+3 ;;CVA-SNF^CHAMPVA
+4 ;;CVA-OPT^CHAMPVA
+5 ;;CVA RI-INPT^CHAMPVA REIMB. INS.
+6 ;;CVA RI-SNF^CHAMPVA REIMB. INS.
+7 ;;CVA RI-OPT^CHAMPVA REIMB. INS.
+8 ;;
+9 ;
