IBCRHBSZ ;ALB/ARH - RATES: UPLOAD (RC 2+) DIVISION FUNCTIONS ; 10-OCT-03
;;2.0;INTEGRATED BILLING;**245**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;
SITEDV(DIV) ; return the host file site data on the division passed in
; input: site number, output: 0 or 'IFN of site in IBCR RC SITE ^ site number ^ site name ^ 3-digit zip ^ type'
;
N IBY,IBX,IBLN S (IBY,IBX)=0
I +$G(DIV) S IBY=$O(^XTMP("IBCR RC SITE","C",DIV_" ",0))
I +IBY S IBLN=$G(^XTMP("IBCR RC SITE",IBY)) I IBLN'="" S IBX=IBY_U_IBLN
Q IBX
;
RGDV(DV) ; return Billing Region data on division passed in
; Input: site number, output 0 or 'IFN of region in 363.31 ^ site number ^ site city,st ^ 3-digit zip ^ type'
N IBRG,IBX,IBY,IBFND S IBFND=0
I $G(DV)'="" S IBRG="RC "_DV F S IBRG=$O(^IBE(363.31,"B",IBRG)) Q:$E(IBRG,1,2)'="RC" D Q:IBFND
. I IBRG'[(" "_DV_" ") Q
. S IBY=$O(^IBE(363.31,"B",IBRG,0)) I 'IBY Q
. S IBX=$G(^IBE(363.31,+IBY,0))
. S IBFND=IBY_U_DV_U_$P($P(IBX,U,1)," - ",2)_U_$P(IBX,U,2,3)
Q IBFND
;
MSGDIV(SITE) ; check if division selected is defined as a division (40.8) on the system
N IBMCDV,IBRG,IBX,IBY,IBFND S (IBMCDV,IBFND)="",SITE=$G(SITE)
I SITE'="" S IBMCDV=+$O(^DG(40.8,"C",SITE,0))
I +IBMCDV S IBX=$G(^DG(40.8,+IBMCDV,0)) D
. W !!,?5,$P(IBX,U,2),?15,$P(IBX,U,1)," is a valid Medical Center division on your system.",!
. S IBRG="RC" F S IBRG=$O(^IBE(363.31,"B",IBRG)) Q:$E(IBRG,1,2)'="RC" D Q:IBFND
.. I IBRG[(" "_SITE_" ") S IBFND=1 Q
.. S IBY=$O(^IBE(363.31,"B",IBRG,0)) I 'IBY Q
.. I '$O(^IBE(363.31,IBY,11,"B",+IBMCDV,0)) Q
.. W !!,?5,SITE," is already assigned to Billing Region: ",IBRG,! S IBFND=1
I 'IBMCDV W !!,?5,"*** ",SITE," is NOT defined as a Medical Center Division on your system ***",!
Q
;
;
; ***************************************************************************************
;
SETRGZIP ; for all existing Billing Regions, set the sites 3-digit zip code into the Identifier field (363.31,.02)
; and set the Facility type into the Type field (363.31,.03)
; the 3-digit zip was not available with RC v1, so Regions created for RC v1 will not have this field set
; the type field was not available until RC v2, so Regions created before RC 2 will not have this field set
;
N DIE,DIC,DA,DR,X,Y,IBRGFN,IBLN,IBZIP,IBSITE,IBTYPE I $$VERSION^IBCRHBRV=1 Q
;
S IBRGFN=0 F S IBRGFN=$O(^IBE(363.31,IBRGFN)) Q:'IBRGFN D
. S IBLN=$G(^IBE(363.31,IBRGFN,0)) Q:$E(IBLN,1,3)'="RC " I $P(IBLN,U,2)'="",$P(IBLN,U,3)'="" Q
. ;
. S IBSITE=$$SITEDV($P(IBLN," ",2))
. S IBZIP=$P(IBSITE,U,4) Q:IBZIP'?3N
. S IBTYPE=$P(IBSITE,U,5) Q:IBTYPE=""
. ;
. S DR=""
. I $P(IBLN,U,2)="" S DR=".02////"_IBZIP_";"
. I $P(IBLN,U,3)="" S DR=DR_".03////"_IBTYPE
. I DR'="" S DIE="^IBE(363.31,",DA=IBRGFN D ^DIE K DIE,DIC,DA,DR
Q
;
CHKRGZIP ; for all existing Billing Regions, check to ensure each division assigned is actually within that Region
; Check the Billing Region zip/type against the Host files zip/type for the site
; Also the 3-digit zip of the Regions Divisions must match the 3-digit zip of the Regions primary division
; if the 3-digit zips do not match, the Division is deleted from the Region
;
N IBRGFN,IBLN,IBRGSITE,IBRGZIP,IBRGTYPE,IBDVFN,IBDV,IBDVLN,IBDVSITE,IBDVZIP,IBDVTYPE,ARRAY,ARRAY2,DA,DIK,DIC,DIR,X,Y
;
S IBRGFN=0 F S IBRGFN=$O(^IBE(363.31,IBRGFN)) Q:'IBRGFN D
. S IBLN=$G(^IBE(363.31,IBRGFN,0)) Q:$E(IBLN,1,3)'="RC "
. S IBRGSITE=$$SITEDV($P(IBLN," ",2))
. S IBRGZIP=$P(IBRGSITE,U,4)
. S IBRGTYPE=$P(IBRGSITE,U,5)
. I IBRGZIP'?3N,IBRGTYPE="" Q
. ;
. ; check region settings against settings for primary division in host files
. I $P(IBLN,U,2)'=IBRGZIP S ARRAY2($P(IBLN,U,1))=$P(IBLN,U,2)_U_+$P(IBLN,U,3)_U_IBRGZIP_U_+IBRGTYPE
. I +IBRGTYPE,$P(IBLN,U,3)'=IBRGTYPE S ARRAY2($P(IBLN,U,1))=$P(IBLN,U,2)_U_+$P(IBLN,U,3)_U_IBRGZIP_U_+IBRGTYPE
.
. ; check regions primary division against the assigned divisions
. S IBDVFN=0 F S IBDVFN=$O(^IBE(363.31,IBRGFN,11,IBDVFN)) Q:'IBDVFN D
.. S IBDV=+$G(^IBE(363.31,IBRGFN,11,IBDVFN,0)) Q:'IBDV
.. S IBDVLN=$G(^DG(40.8,+IBDV,0)) Q:IBDVLN=""
.. S IBDVSITE=$$SITEDV($P(IBDVLN,U,2))
.. S IBDVZIP=$P(IBDVSITE,U,4)
.. S IBDVTYPE=$P(IBDVSITE,U,5)
.. I IBDVZIP'?3N,IBDVTYPE="" Q
.. ;
.. I IBRGZIP=IBDVZIP,IBRGTYPE=IBDVTYPE Q
.. I IBRGTYPE=1,IBDVTYPE<3 Q
.. S ARRAY(IBRGFN)=IBLN,ARRAY(IBRGFN,IBDV)=$P(IBDVLN,U,1,2)_U_IBDVZIP_U_IBDVTYPE
.. S DA(1)=IBRGFN,DIK="^IBE(363.31,"_DA(1)_",11,",DA=IBDVFN D ^DIK
;
I $O(ARRAY2(""))'="" D
. ; check region settings against settings for primary division in host files
. W @IOF,!,"********************************************************************************"
. W !,"Error Found: Billing Regions found in Charge Master with Incorrect Zip or Type."
. W !,"Billing Regions are defined by both the 3-digit zip code and Type of Facility."
. W !!,"There are Charge Master Billing Regions whose Zip or Type do not match the "
. W !,"settings of that primary division in the new host files.",!
. ;
. W !!,?3,"Billing Region",?32,"CM Zip-Type",?47,"HF Zip-Type",!,?3,"--------------------------------------------------------------------------"
. S IBRGFN="" F S IBRGFN=$O(ARRAY2(IBRGFN)) Q:IBRGFN="" D
.. S IBLN=ARRAY2(IBRGFN) W !,?3,IBRGFN,?35,$P(IBLN,U,1),"-",$P(IBLN,U,2),?50,$P(IBLN,U,3),"-",$P(IBLN,U,4)
. ;
. W !!,"IT IS POSSIBLE THERE ARE PROBLEMS WITH THE CHARGES, PLEASE CONTACT SUPPORT."
. W !,"********************************************************************************",!
. S DIR(0)="E" D ^DIR K DIR W @IOF
;
I $O(ARRAY(0)) D
. ; check regions primary division against the assigned divisions
. W @IOF,!,"********************************************************************************"
. W !,"Error Found: Incorrect Billing Regions found in the Charge Master."
. W !!,"Billing Regions are defined by the 3-digit zip code identifier and "
. W !,"Type of Facility of the primary division. Only Divisions with the "
. W !,"same 3-digit zip code and type should be assigned to a Billing Region."
. W !!,"There were Divisions incorrectly associated with Billing Regions in the"
. W !,"Charge Master. For the following Billing Regions, the corresponding "
. W !,"Division has been deleted."
. W !!,?3,"Billing Region",?43,"Division(s) Deleted",!,?3,"--------------------------------------------------------------------------"
. ;
. S IBRGFN=0 F S IBRGFN=$O(ARRAY(IBRGFN)) Q:'IBRGFN D
.. S IBLN=ARRAY(IBRGFN) W !,?3,$E($P(IBLN,U,1),1,23),?26,"(",$P(IBLN,U,2),"-",$P(IBLN,U,3),")"
.. ;
.. S IBDV=0 F S IBDV=$O(ARRAY(IBRGFN,IBDV)) Q:'IBDV D
... S IBLN=ARRAY(IBRGFN,IBDV) W ?43,$P(IBLN,U,2),?50,$E($P(IBLN,U,1),1,20),?72,"(",$P(IBLN,U,3),"-",$P(IBLN,U,4),")",!
. ;
. W !,"IT IS LIKELY THE ABOVE DIVISIONS NO LONGER HAVE ANY REASONABLE CHARGES ASSIGNED."
. W !,"********************************************************************************",!
. S DIR(0)="E" D ^DIR K DIR W @IOF
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRHBSZ 7054 printed Apr 09, 2024@21:03:12 Page 2
IBCRHBSZ ;ALB/ARH - RATES: UPLOAD (RC 2+) DIVISION FUNCTIONS ; 10-OCT-03
+1 ;;2.0;INTEGRATED BILLING;**245**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;
SITEDV(DIV) ; return the host file site data on the division passed in
+1 ; input: site number, output: 0 or 'IFN of site in IBCR RC SITE ^ site number ^ site name ^ 3-digit zip ^ type'
+2 ;
+3 NEW IBY,IBX,IBLN
SET (IBY,IBX)=0
+4 IF +$GET(DIV)
SET IBY=$ORDER(^XTMP("IBCR RC SITE","C",DIV_" ",0))
+5 IF +IBY
SET IBLN=$GET(^XTMP("IBCR RC SITE",IBY))
IF IBLN'=""
SET IBX=IBY_U_IBLN
+6 QUIT IBX
+7 ;
RGDV(DV) ; return Billing Region data on division passed in
+1 ; Input: site number, output 0 or 'IFN of region in 363.31 ^ site number ^ site city,st ^ 3-digit zip ^ type'
+2 NEW IBRG,IBX,IBY,IBFND
SET IBFND=0
+3 IF $GET(DV)'=""
SET IBRG="RC "_DV
FOR
SET IBRG=$ORDER(^IBE(363.31,"B",IBRG))
if $EXTRACT(IBRG,1,2)'="RC"
QUIT
Begin DoDot:1
+4 IF IBRG'[(" "_DV_" ")
QUIT
+5 SET IBY=$ORDER(^IBE(363.31,"B",IBRG,0))
IF 'IBY
QUIT
+6 SET IBX=$GET(^IBE(363.31,+IBY,0))
+7 SET IBFND=IBY_U_DV_U_$PIECE($PIECE(IBX,U,1)," - ",2)_U_$PIECE(IBX,U,2,3)
End DoDot:1
if IBFND
QUIT
+8 QUIT IBFND
+9 ;
MSGDIV(SITE) ; check if division selected is defined as a division (40.8) on the system
+1 NEW IBMCDV,IBRG,IBX,IBY,IBFND
SET (IBMCDV,IBFND)=""
SET SITE=$GET(SITE)
+2 IF SITE'=""
SET IBMCDV=+$ORDER(^DG(40.8,"C",SITE,0))
+3 IF +IBMCDV
SET IBX=$GET(^DG(40.8,+IBMCDV,0))
Begin DoDot:1
+4 WRITE !!,?5,$PIECE(IBX,U,2),?15,$PIECE(IBX,U,1)," is a valid Medical Center division on your system.",!
+5 SET IBRG="RC"
FOR
SET IBRG=$ORDER(^IBE(363.31,"B",IBRG))
if $EXTRACT(IBRG,1,2)'="RC"
QUIT
Begin DoDot:2
+6 IF IBRG[(" "_SITE_" ")
SET IBFND=1
QUIT
+7 SET IBY=$ORDER(^IBE(363.31,"B",IBRG,0))
IF 'IBY
QUIT
+8 IF '$ORDER(^IBE(363.31,IBY,11,"B",+IBMCDV,0))
QUIT
+9 WRITE !!,?5,SITE," is already assigned to Billing Region: ",IBRG,!
SET IBFND=1
End DoDot:2
if IBFND
QUIT
End DoDot:1
+10 IF 'IBMCDV
WRITE !!,?5,"*** ",SITE," is NOT defined as a Medical Center Division on your system ***",!
+11 QUIT
+12 ;
+13 ;
+14 ; ***************************************************************************************
+15 ;
SETRGZIP ; for all existing Billing Regions, set the sites 3-digit zip code into the Identifier field (363.31,.02)
+1 ; and set the Facility type into the Type field (363.31,.03)
+2 ; the 3-digit zip was not available with RC v1, so Regions created for RC v1 will not have this field set
+3 ; the type field was not available until RC v2, so Regions created before RC 2 will not have this field set
+4 ;
+5 NEW DIE,DIC,DA,DR,X,Y,IBRGFN,IBLN,IBZIP,IBSITE,IBTYPE
IF $$VERSION^IBCRHBRV=1
QUIT
+6 ;
+7 SET IBRGFN=0
FOR
SET IBRGFN=$ORDER(^IBE(363.31,IBRGFN))
if 'IBRGFN
QUIT
Begin DoDot:1
+8 SET IBLN=$GET(^IBE(363.31,IBRGFN,0))
if $EXTRACT(IBLN,1,3)'="RC "
QUIT
IF $PIECE(IBLN,U,2)'=""
IF $PIECE(IBLN,U,3)'=""
QUIT
+9 ;
+10 SET IBSITE=$$SITEDV($PIECE(IBLN," ",2))
+11 SET IBZIP=$PIECE(IBSITE,U,4)
if IBZIP'?3N
QUIT
+12 SET IBTYPE=$PIECE(IBSITE,U,5)
if IBTYPE=""
QUIT
+13 ;
+14 SET DR=""
+15 IF $PIECE(IBLN,U,2)=""
SET DR=".02////"_IBZIP_";"
+16 IF $PIECE(IBLN,U,3)=""
SET DR=DR_".03////"_IBTYPE
+17 IF DR'=""
SET DIE="^IBE(363.31,"
SET DA=IBRGFN
DO ^DIE
KILL DIE,DIC,DA,DR
End DoDot:1
+18 QUIT
+19 ;
CHKRGZIP ; for all existing Billing Regions, check to ensure each division assigned is actually within that Region
+1 ; Check the Billing Region zip/type against the Host files zip/type for the site
+2 ; Also the 3-digit zip of the Regions Divisions must match the 3-digit zip of the Regions primary division
+3 ; if the 3-digit zips do not match, the Division is deleted from the Region
+4 ;
+5 NEW IBRGFN,IBLN,IBRGSITE,IBRGZIP,IBRGTYPE,IBDVFN,IBDV,IBDVLN,IBDVSITE,IBDVZIP,IBDVTYPE,ARRAY,ARRAY2,DA,DIK,DIC,DIR,X,Y
+6 ;
+7 SET IBRGFN=0
FOR
SET IBRGFN=$ORDER(^IBE(363.31,IBRGFN))
if 'IBRGFN
QUIT
Begin DoDot:1
+8 SET IBLN=$GET(^IBE(363.31,IBRGFN,0))
if $EXTRACT(IBLN,1,3)'="RC "
QUIT
+9 SET IBRGSITE=$$SITEDV($PIECE(IBLN," ",2))
+10 SET IBRGZIP=$PIECE(IBRGSITE,U,4)
+11 SET IBRGTYPE=$PIECE(IBRGSITE,U,5)
+12 IF IBRGZIP'?3N
IF IBRGTYPE=""
QUIT
+13 ;
+14 ; check region settings against settings for primary division in host files
+15 IF $PIECE(IBLN,U,2)'=IBRGZIP
SET ARRAY2($PIECE(IBLN,U,1))=$PIECE(IBLN,U,2)_U_+$PIECE(IBLN,U,3)_U_IBRGZIP_U_+IBRGTYPE
+16 IF +IBRGTYPE
IF $PIECE(IBLN,U,3)'=IBRGTYPE
SET ARRAY2($PIECE(IBLN,U,1))=$PIECE(IBLN,U,2)_U_+$PIECE(IBLN,U,3)_U_IBRGZIP_U_+IBRGTYPE
+17 +18 ; check regions primary division against the assigned divisions
+19 SET IBDVFN=0
FOR
SET IBDVFN=$ORDER(^IBE(363.31,IBRGFN,11,IBDVFN))
if 'IBDVFN
QUIT
Begin DoDot:2
+20 SET IBDV=+$GET(^IBE(363.31,IBRGFN,11,IBDVFN,0))
if 'IBDV
QUIT
+21 SET IBDVLN=$GET(^DG(40.8,+IBDV,0))
if IBDVLN=""
QUIT
+22 SET IBDVSITE=$$SITEDV($PIECE(IBDVLN,U,2))
+23 SET IBDVZIP=$PIECE(IBDVSITE,U,4)
+24 SET IBDVTYPE=$PIECE(IBDVSITE,U,5)
+25 IF IBDVZIP'?3N
IF IBDVTYPE=""
QUIT
+26 ;
+27 IF IBRGZIP=IBDVZIP
IF IBRGTYPE=IBDVTYPE
QUIT
+28 IF IBRGTYPE=1
IF IBDVTYPE<3
QUIT
+29 SET ARRAY(IBRGFN)=IBLN
SET ARRAY(IBRGFN,IBDV)=$PIECE(IBDVLN,U,1,2)_U_IBDVZIP_U_IBDVTYPE
+30 SET DA(1)=IBRGFN
SET DIK="^IBE(363.31,"_DA(1)_",11,"
SET DA=IBDVFN
DO ^DIK
End DoDot:2
End DoDot:1
+31 ;
+32 IF $ORDER(ARRAY2(""))'=""
Begin DoDot:1
+33 ; check region settings against settings for primary division in host files
+34 WRITE @IOF,!,"********************************************************************************"
+35 WRITE !,"Error Found: Billing Regions found in Charge Master with Incorrect Zip or Type."
+36 WRITE !,"Billing Regions are defined by both the 3-digit zip code and Type of Facility."
+37 WRITE !!,"There are Charge Master Billing Regions whose Zip or Type do not match the "
+38 WRITE !,"settings of that primary division in the new host files.",!
+39 ;
+40 WRITE !!,?3,"Billing Region",?32,"CM Zip-Type",?47,"HF Zip-Type",!,?3,"--------------------------------------------------------------------------"
+41 SET IBRGFN=""
FOR
SET IBRGFN=$ORDER(ARRAY2(IBRGFN))
if IBRGFN=""
QUIT
Begin DoDot:2
+42 SET IBLN=ARRAY2(IBRGFN)
WRITE !,?3,IBRGFN,?35,$PIECE(IBLN,U,1),"-",$PIECE(IBLN,U,2),?50,$PIECE(IBLN,U,3),"-",$PIECE(IBLN,U,4)
End DoDot:2
+43 ;
+44 WRITE !!,"IT IS POSSIBLE THERE ARE PROBLEMS WITH THE CHARGES, PLEASE CONTACT SUPPORT."
+45 WRITE !,"********************************************************************************",!
+46 SET DIR(0)="E"
DO ^DIR
KILL DIR
WRITE @IOF
End DoDot:1
+47 ;
+48 IF $ORDER(ARRAY(0))
Begin DoDot:1
+49 ; check regions primary division against the assigned divisions
+50 WRITE @IOF,!,"********************************************************************************"
+51 WRITE !,"Error Found: Incorrect Billing Regions found in the Charge Master."
+52 WRITE !!,"Billing Regions are defined by the 3-digit zip code identifier and "
+53 WRITE !,"Type of Facility of the primary division. Only Divisions with the "
+54 WRITE !,"same 3-digit zip code and type should be assigned to a Billing Region."
+55 WRITE !!,"There were Divisions incorrectly associated with Billing Regions in the"
+56 WRITE !,"Charge Master. For the following Billing Regions, the corresponding "
+57 WRITE !,"Division has been deleted."
+58 WRITE !!,?3,"Billing Region",?43,"Division(s) Deleted",!,?3,"--------------------------------------------------------------------------"
+59 ;
+60 SET IBRGFN=0
FOR
SET IBRGFN=$ORDER(ARRAY(IBRGFN))
if 'IBRGFN
QUIT
Begin DoDot:2
+61 SET IBLN=ARRAY(IBRGFN)
WRITE !,?3,$EXTRACT($PIECE(IBLN,U,1),1,23),?26,"(",$PIECE(IBLN,U,2),"-",$PIECE(IBLN,U,3),")"
+62 ;
+63 SET IBDV=0
FOR
SET IBDV=$ORDER(ARRAY(IBRGFN,IBDV))
if 'IBDV
QUIT
Begin DoDot:3
+64 SET IBLN=ARRAY(IBRGFN,IBDV)
WRITE ?43,$PIECE(IBLN,U,2),?50,$EXTRACT($PIECE(IBLN,U,1),1,20),?72,"(",$PIECE(IBLN,U,3),"-",$PIECE(IBLN,U,4),")",!
End DoDot:3
End DoDot:2
+65 ;
+66 WRITE !,"IT IS LIKELY THE ABOVE DIVISIONS NO LONGER HAVE ANY REASONABLE CHARGES ASSIGNED."
+67 WRITE !,"********************************************************************************",!
+68 SET DIR(0)="E"
DO ^DIR
KILL DIR
WRITE @IOF
End DoDot:1
+69 QUIT
