IBYP520 ;ALB/CXW - IB*2.0*520 POST INIT: REVISED REASONABLE CHARGES V3.14; 02-21-2014
;;2.0;INTEGRATED BILLING;**520**;21-MAR-94;Build 32
;;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
POST ;
N IBA,U S U="^"
S IBA(1)="",IBA(2)=" Revised Reasonable Charges v3.14 Post-Install .....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
; Inactivate RC charges with effective date 10/01/2013 in #363.2
D CHGINA("")
; Delete RC v3.14 charges with effective date 01/01/2014 in #363.2
D PURGE
S IBA(1)="",IBA(2)=" Revised Reasonable Charges v3.14 Post-Install Complete",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
;
Q
;
CHGINA(VERS) ; inactive charges from previous versions of Reasonable Charges
; VERS = version to begin inactivations with (1, 1.1, 1.2, ...)
; - Inactive date added is the first RC Version Inactive date after the effective date of the charge
; - if the charge already has an inactive date less than the Version Inactive Date then no change is made
;
N IBA,IBI,IBX,IBSTART,IBENDATE,IBCS,IBCS0,IBBR0,IBXRF,IBITM,IBNEF,IBCI,IBCI0,IBCIEF,IBCIIA,IBNEWIA
N DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y,IBCNT S IBCNT=0
;
S IBA(1)=" >> Inactivating Existing Reasonable Charges v3.13, Please Wait..." D MES^XPDUTL(.IBA) K IBA
;
S IBSTART="" I $G(VERS)'="" S IBSTART=$$VERSDT^IBCRHBRV(VERS)
S IBENDATE=$$VERSEND^IBCRHBRV
;
S IBCS=0 F S IBCS=$O(^IBE(363.1,IBCS)) Q:'IBCS D
. S IBCS0=$G(^IBE(363.1,IBCS,0)) Q:IBCS0=""
. S IBBR0=$G(^IBE(363.3,+$P(IBCS0,U,2),0)) I $E(IBBR0,1,3)'="RC " Q
. ;
. S IBXRF="AIVDTS"_IBCS
. S IBITM=0 F S IBITM=$O(^IBA(363.2,IBXRF,IBITM)) Q:'IBITM D
.. S IBNEF="" F S IBNEF=$O(^IBA(363.2,IBXRF,IBITM,IBNEF)) Q:IBNEF="" Q:-IBNEF<IBSTART D
... ;
... S IBCI=0 F S IBCI=$O(^IBA(363.2,IBXRF,IBITM,IBNEF,IBCI)) Q:'IBCI D
.... S IBCI0=$G(^IBA(363.2,IBCI,0)) Q:IBCI0=""
.... S IBCIEF=$P(IBCI0,U,3),IBCIIA=$P(IBCI0,U,4),IBNEWIA=""
.... ;
.... F IBI=2:1 S IBX=+$P(IBENDATE,";",IBI) S IBNEWIA=IBX Q:'IBX Q:IBCIEF'>IBX
.... ;
.... I 'IBNEWIA Q
.... I +IBCIIA,IBCIIA'>IBNEWIA Q
.... ;
.... S DR=".04///"_+IBNEWIA,DIE="^IBA(363.2,",DA=+IBCI D ^DIE K DIE,DIC,DA,DR,X,Y S IBCNT=IBCNT+1
;
S IBA(1)=" Done. "_IBCNT_" existing charges inactivated",IBA(2)="" D MES^XPDUTL(.IBA) K IBA
Q
;
PURGE ; delete all charges v3.14 with an effective date 01/01/2014
N X,X1,X2,DA,DIK,IB11,IBA,IBBR0,IBBR,IBEFDT,IBCI,IBCNT,IBCNT2
N IBCS,IBCS0,IBFN,IBITM,IBNEF,IBRG,IBXRF
; xtmp(ibyp520,0)=purge date^today date^patch #^total charge set deleted
; xtmp(ibyp520,csien)=name^"deleted"
K ^XTMP("IBYP520")
S DT=$$DT^XLFDT,X1=DT,X2=30 D C^%DTC
S ^XTMP("IBYP520",0)=X_U_DT_U_"IB*2.0*520 POST-INIT"
S IBA(1)=" >> Removing Existing Reasonable Charges v3.14, Please Wait..." D MES^XPDUTL(.IBA) K IBA
S (IBCNT,IBCNT2)=0,IBEFDT=3140101
; find the charge item in the charge set
S IBCS=0 F S IBCS=$O(^IBE(363.1,IBCS)) Q:'IBCS D
. S IBCS0=$G(^IBE(363.1,IBCS,0)) Q:IBCS0=""
. S IBBR0=$G(^IBE(363.3,+$P(IBCS0,U,2),0)) I $E(IBBR0,1,3)'="RC " Q
. S IBXRF="AIVDTS"_IBCS
. S IBITM=0 F S IBITM=$O(^IBA(363.2,IBXRF,IBITM)) Q:'IBITM D
.. S IBNEF="" F S IBNEF=$O(^IBA(363.2,IBXRF,IBITM,IBNEF)) Q:IBNEF="" I IBNEF=-IBEFDT D
... S IBCI=0 F S IBCI=$O(^IBA(363.2,IBXRF,IBITM,IBNEF,IBCI)) Q:'IBCI D
.... I $G(^IBA(363.2,+$G(IBCI),0))="" Q
.... ;
.... ; delete the entry if exists in the file
.... S DA=IBCI S DIK="^IBA(363.2," D ^DIK
.... S IBCNT=IBCNT+1
... S:'$D(^XTMP("IBYP520",IBCS)) ^XTMP("IBYP520",IBCS)=$P(IBCS0,U,1)
;
; delete a charge set including all pointers created in rc 3.14 (*513)
S IBCS=0 F S IBCS=$O(^XTMP("IBYP520",IBCS)) Q:'IBCS D
. ; quit if va cost (ien=2)
. S IBCS0=$G(^IBE(363.1,+IBCS,0)),IBBR=+$P(IBCS0,U,2),IBBR0=$G(^IBE(363.3,+IBBR,0))
. I '$P(IBBR0,U,4)!($P(IBBR0,U,5)=2) Q
. I $E(IBBR0,1,2)'="RC" Q
. ; quit if CS has associated charge item
. ; quit if CS has pointed to awp CS in site parameter
. I $O(^IBA(363.2,"AIVDTS"_+IBCS,""))'="" Q
. I $P($G(^IBE(350.9,1,9)),U,12)=+IBCS Q
. ;
. ; remove from rate schedule
. S IBFN=0 F S IBFN=$O(^IBE(363,"C",+IBCS,IBFN)) Q:'IBFN D
.. S IB11="" F S IB11=$O(^IBE(363,"C",+IBCS,IBFN,IB11)) Q:'IB11 D
... I +$G(^IBE(363,+IBFN,11,+IB11,0))=+IBCS S DA(1)=+IBFN,DA=+IB11,DIK="^IBE(363,"_DA(1)_",11," D ^DIK
. ;
. ; remove from special groups
. S IBFN=0 F S IBFN=$O(^IBE(363.32,IBFN)) Q:'IBFN D
.. S IB11=0 F S IB11=$O(^IBE(363.32,IBFN,11,IB11)) Q:'IB11 D
... I +$P($G(^IBE(363.32,IBFN,11,IB11,0)),U,2)=+IBCS S DA(1)=+IBFN,DA=+IB11,DIK="^IBE(363.32,"_DA(1)_",11," D ^DIK
. ;
. ; remove region (or division) if not assigned to another charge set
. S IBRG=$P($G(^IBE(363.1,+IBCS,0)),U,7)
. I +IBRG S IBFN=0 F S IBFN=$O(^IBE(363.1,IBFN)) Q:'IBFN D
.. I +IBFN'=+IBCS,$P($G(^IBE(363.1,+IBFN,0)),U,7)=IBRG S IBRG=0
. I +IBRG S DA=+IBRG,DIK="^IBE(363.31," D ^DIK
. ;
. ; remove charge set
. S DA=+IBCS,DIK="^IBE(363.1," D ^DIK
. S $P(^XTMP("IBYP520",IBCS),U,2)="deleted"
. S IBCNT2=IBCNT2+1
S $P(^XTMP("IBYP520",0),U,4)=IBCNT2
S IBCS=IBCNT2_" charge sets deleted"
S IBA(1)=" Done. "_IBCNT_" existing charges deleted and "_IBCS D MES^XPDUTL(.IBA) K IBA
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYP520 5248 printed Dec 13, 2024@02:36:02 Page 2
IBYP520 ;ALB/CXW - IB*2.0*520 POST INIT: REVISED REASONABLE CHARGES V3.14; 02-21-2014
+1 ;;2.0;INTEGRATED BILLING;**520**;21-MAR-94;Build 32
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;
POST ;
+1 NEW IBA,U
SET U="^"
+2 SET IBA(1)=""
SET IBA(2)=" Revised Reasonable Charges v3.14 Post-Install ....."
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+3 ; Inactivate RC charges with effective date 10/01/2013 in #363.2
+4 DO CHGINA("")
+5 ; Delete RC v3.14 charges with effective date 01/01/2014 in #363.2
+6 DO PURGE
+7 SET IBA(1)=""
SET IBA(2)=" Revised Reasonable Charges v3.14 Post-Install Complete"
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+8 ;
+9 QUIT
+10 ;
CHGINA(VERS) ; inactive charges from previous versions of Reasonable Charges
+1 ; VERS = version to begin inactivations with (1, 1.1, 1.2, ...)
+2 ; - Inactive date added is the first RC Version Inactive date after the effective date of the charge
+3 ; - if the charge already has an inactive date less than the Version Inactive Date then no change is made
+4 ;
+5 NEW IBA,IBI,IBX,IBSTART,IBENDATE,IBCS,IBCS0,IBBR0,IBXRF,IBITM,IBNEF,IBCI,IBCI0,IBCIEF,IBCIIA,IBNEWIA
+6 NEW DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y,IBCNT
SET IBCNT=0
+7 ;
+8 SET IBA(1)=" >> Inactivating Existing Reasonable Charges v3.13, Please Wait..."
DO MES^XPDUTL(.IBA)
KILL IBA
+9 ;
+10 SET IBSTART=""
IF $GET(VERS)'=""
SET IBSTART=$$VERSDT^IBCRHBRV(VERS)
+11 SET IBENDATE=$$VERSEND^IBCRHBRV
+12 ;
+13 SET IBCS=0
FOR
SET IBCS=$ORDER(^IBE(363.1,IBCS))
if 'IBCS
QUIT
Begin DoDot:1
+14 SET IBCS0=$GET(^IBE(363.1,IBCS,0))
if IBCS0=""
QUIT
+15 SET IBBR0=$GET(^IBE(363.3,+$PIECE(IBCS0,U,2),0))
IF $EXTRACT(IBBR0,1,3)'="RC "
QUIT
+16 ;
+17 SET IBXRF="AIVDTS"_IBCS
+18 SET IBITM=0
FOR
SET IBITM=$ORDER(^IBA(363.2,IBXRF,IBITM))
if 'IBITM
QUIT
Begin DoDot:2
+19 SET IBNEF=""
FOR
SET IBNEF=$ORDER(^IBA(363.2,IBXRF,IBITM,IBNEF))
if IBNEF=""
QUIT
if -IBNEF<IBSTART
QUIT
Begin DoDot:3
+20 ;
+21 SET IBCI=0
FOR
SET IBCI=$ORDER(^IBA(363.2,IBXRF,IBITM,IBNEF,IBCI))
if 'IBCI
QUIT
Begin DoDot:4
+22 SET IBCI0=$GET(^IBA(363.2,IBCI,0))
if IBCI0=""
QUIT
+23 SET IBCIEF=$PIECE(IBCI0,U,3)
SET IBCIIA=$PIECE(IBCI0,U,4)
SET IBNEWIA=""
+24 ;
+25 FOR IBI=2:1
SET IBX=+$PIECE(IBENDATE,";",IBI)
SET IBNEWIA=IBX
if 'IBX
QUIT
if IBCIEF'>IBX
QUIT
+26 ;
+27 IF 'IBNEWIA
QUIT
+28 IF +IBCIIA
IF IBCIIA'>IBNEWIA
QUIT
+29 ;
+30 SET DR=".04///"_+IBNEWIA
SET DIE="^IBA(363.2,"
SET DA=+IBCI
DO ^DIE
KILL DIE,DIC,DA,DR,X,Y
SET IBCNT=IBCNT+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+31 ;
+32 SET IBA(1)=" Done. "_IBCNT_" existing charges inactivated"
SET IBA(2)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+33 QUIT
+34 ;
PURGE ; delete all charges v3.14 with an effective date 01/01/2014
+1 NEW X,X1,X2,DA,DIK,IB11,IBA,IBBR0,IBBR,IBEFDT,IBCI,IBCNT,IBCNT2
+2 NEW IBCS,IBCS0,IBFN,IBITM,IBNEF,IBRG,IBXRF
+3 ; xtmp(ibyp520,0)=purge date^today date^patch #^total charge set deleted
+4 ; xtmp(ibyp520,csien)=name^"deleted"
+5 KILL ^XTMP("IBYP520")
+6 SET DT=$$DT^XLFDT
SET X1=DT
SET X2=30
DO C^%DTC
+7 SET ^XTMP("IBYP520",0)=X_U_DT_U_"IB*2.0*520 POST-INIT"
+8 SET IBA(1)=" >> Removing Existing Reasonable Charges v3.14, Please Wait..."
DO MES^XPDUTL(.IBA)
KILL IBA
+9 SET (IBCNT,IBCNT2)=0
SET IBEFDT=3140101
+10 ; find the charge item in the charge set
+11 SET IBCS=0
FOR
SET IBCS=$ORDER(^IBE(363.1,IBCS))
if 'IBCS
QUIT
Begin DoDot:1
+12 SET IBCS0=$GET(^IBE(363.1,IBCS,0))
if IBCS0=""
QUIT
+13 SET IBBR0=$GET(^IBE(363.3,+$PIECE(IBCS0,U,2),0))
IF $EXTRACT(IBBR0,1,3)'="RC "
QUIT
+14 SET IBXRF="AIVDTS"_IBCS
+15 SET IBITM=0
FOR
SET IBITM=$ORDER(^IBA(363.2,IBXRF,IBITM))
if 'IBITM
QUIT
Begin DoDot:2
+16 SET IBNEF=""
FOR
SET IBNEF=$ORDER(^IBA(363.2,IBXRF,IBITM,IBNEF))
if IBNEF=""
QUIT
IF IBNEF=-IBEFDT
Begin DoDot:3
+17 SET IBCI=0
FOR
SET IBCI=$ORDER(^IBA(363.2,IBXRF,IBITM,IBNEF,IBCI))
if 'IBCI
QUIT
Begin DoDot:4
+18 IF $GET(^IBA(363.2,+$GET(IBCI),0))=""
QUIT
+19 ;
+20 ; delete the entry if exists in the file
+21 SET DA=IBCI
SET DIK="^IBA(363.2,"
DO ^DIK
+22 SET IBCNT=IBCNT+1
End DoDot:4
+23 if '$DATA(^XTMP("IBYP520",IBCS))
SET ^XTMP("IBYP520",IBCS)=$PIECE(IBCS0,U,1)
End DoDot:3
End DoDot:2
End DoDot:1
+24 ;
+25 ; delete a charge set including all pointers created in rc 3.14 (*513)
+26 SET IBCS=0
FOR
SET IBCS=$ORDER(^XTMP("IBYP520",IBCS))
if 'IBCS
QUIT
Begin DoDot:1
+27 ; quit if va cost (ien=2)
+28 SET IBCS0=$GET(^IBE(363.1,+IBCS,0))
SET IBBR=+$PIECE(IBCS0,U,2)
SET IBBR0=$GET(^IBE(363.3,+IBBR,0))
+29 IF '$PIECE(IBBR0,U,4)!($PIECE(IBBR0,U,5)=2)
QUIT
+30 IF $EXTRACT(IBBR0,1,2)'="RC"
QUIT
+31 ; quit if CS has associated charge item
+32 ; quit if CS has pointed to awp CS in site parameter
+33 IF $ORDER(^IBA(363.2,"AIVDTS"_+IBCS,""))'=""
QUIT
+34 IF $PIECE($GET(^IBE(350.9,1,9)),U,12)=+IBCS
QUIT
+35 ;
+36 ; remove from rate schedule
+37 SET IBFN=0
FOR
SET IBFN=$ORDER(^IBE(363,"C",+IBCS,IBFN))
if 'IBFN
QUIT
Begin DoDot:2
+38 SET IB11=""
FOR
SET IB11=$ORDER(^IBE(363,"C",+IBCS,IBFN,IB11))
if 'IB11
QUIT
Begin DoDot:3
+39 IF +$GET(^IBE(363,+IBFN,11,+IB11,0))=+IBCS
SET DA(1)=+IBFN
SET DA=+IB11
SET DIK="^IBE(363,"_DA(1)_",11,"
DO ^DIK
End DoDot:3
End DoDot:2
+40 ;
+41 ; remove from special groups
+42 SET IBFN=0
FOR
SET IBFN=$ORDER(^IBE(363.32,IBFN))
if 'IBFN
QUIT
Begin DoDot:2
+43 SET IB11=0
FOR
SET IB11=$ORDER(^IBE(363.32,IBFN,11,IB11))
if 'IB11
QUIT
Begin DoDot:3
+44 IF +$PIECE($GET(^IBE(363.32,IBFN,11,IB11,0)),U,2)=+IBCS
SET DA(1)=+IBFN
SET DA=+IB11
SET DIK="^IBE(363.32,"_DA(1)_",11,"
DO ^DIK
End DoDot:3
End DoDot:2
+45 ;
+46 ; remove region (or division) if not assigned to another charge set
+47 SET IBRG=$PIECE($GET(^IBE(363.1,+IBCS,0)),U,7)
+48 IF +IBRG
SET IBFN=0
FOR
SET IBFN=$ORDER(^IBE(363.1,IBFN))
if 'IBFN
QUIT
Begin DoDot:2
+49 IF +IBFN'=+IBCS
IF $PIECE($GET(^IBE(363.1,+IBFN,0)),U,7)=IBRG
SET IBRG=0
End DoDot:2
+50 IF +IBRG
SET DA=+IBRG
SET DIK="^IBE(363.31,"
DO ^DIK
+51 ;
+52 ; remove charge set
+53 SET DA=+IBCS
SET DIK="^IBE(363.1,"
DO ^DIK
+54 SET $PIECE(^XTMP("IBYP520",IBCS),U,2)="deleted"
+55 SET IBCNT2=IBCNT2+1
End DoDot:1
+56 SET $PIECE(^XTMP("IBYP520",0),U,4)=IBCNT2
+57 SET IBCS=IBCNT2_" charge sets deleted"
+58 SET IBA(1)=" Done. "_IBCNT_" existing charges deleted and "_IBCS
DO MES^XPDUTL(.IBA)
KILL IBA
+59 QUIT
+60 ;
