IBCRHBS4 ;ALB/ARH - RATES: UPLOAD (RC 2+) SELECT SITES ; 10-OCT-03
;;2.0;INTEGRATED BILLING;**245**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;
SELSITE() ; select one site to calculate RC charges for
; return: 0 or 'IFN of site in IBCR RC SITE ^ site number ^ site name ^ 3-digit zip ^ type'
;
D SETRGZIP^IBCRHBSZ,CHKRGZIP^IBCRHBSZ
;
N IBSNAME,IBSELDIV,IBX,IBXIFN,IBMCDV
W !!!,"Select Site to calculate Reasonable Charges v"_$$VERSION^IBCRHBRV_" for load into Charge Master"
W !,"--------------------------------------------------------------------------------"
;
SELECT S (IBSELDIV,IBMCDV)=0
S IBSNAME=$$ASKNAM I IBSNAME="" G SSQ
;
S IBXIFN=$$LSTSITE(IBSNAME) I +IBXIFN'>0 G SELECT
S IBSELDIV=$G(^XTMP("IBCR RC SITE",IBXIFN)) I IBSELDIV="" G SELECT
S IBSELDIV=IBXIFN_U_IBSELDIV
;
I $$DV999(IBSELDIV) S IBSELDIV=$$ASKDV(IBSELDIV) I IBSELDIV="" G SELECT
;
I '$$RECHK(IBSELDIV) G SELECT
;
S IBX=$P(IBSELDIV,U,2) D MSGSITE^IBCRHBRV(IBX),MSGVERS^IBCRHBRV(IBX),MSGDIV^IBCRHBSZ(IBX)
;
I '$$CONT(IBSELDIV) G SELECT
;
SSQ Q IBSELDIV
;
ASKNAM() ; ask the user to enter the name of a site/division, return upper case name entered or null
N DIR,DIRUT,DUOUT,X,Y,IBX,IBY S IBX=""
S DIR("?",1)="All or some divisions whose care is billed from your site may have charges."
S DIR("?",2)="Some charges are unique to a single division, others cover multiple divisions."
S DIR("?",3)="This may result in multiple sets in the Charge Master."
S DIR("?",4)="Enter '??' for a complete list of divisions."
S DIR("?",5)="Enter a division number or name for a matching list.",DIR("?",6)=""
S DIR("?")="Select a division that will be billed at your site.",DIR("??")="^D LSTALL^IBCRHBS4"
S DIR(0)="FO",DIR("A")="Select Division" W !! D ^DIR K DIR S IBX=Y I $D(DIRUT) S IBX=""
I IBX'="" S IBX=$$UP^XLFSTR(IBX)
Q IBX
;
CONT(SITE) ; as user if they want to load this division, return 1 if accept division and calculate charges, else 0
N DIR,DIRUT,DUOUT,X,Y,IBX S IBX=0
W !,?15,$P(SITE,U,2),?27,$P(SITE,U,3),?60,$P(SITE,U,4),?67,$P(SITE,U,5),!
S DIR("?")="Enter 'Y' if the care provided at this division is billed at your site and you need this divisions charges loaded on your system."
S DIR("A")="Calculate RC v"_$$VERSION^IBCRHBRV_" charges for this division"
S DIR(0)="YO" D ^DIR K DIR I Y=1 S IBX=Y
Q IBX
;
LSTALL ; list all sites, user cannot select, nothing returned
N IBX,IBCNT,IBEND,IBXIFN,IBNODE,DIR,DIRUT,DUOUT,DTOUT,X,Y S (IBCNT,IBEND)=0 W !
;
S IBX="" F S IBX=$O(^XTMP("IBCR RC SITE","C",IBX)) Q:IBX="" D Q:$D(DIRUT)
. S IBXIFN="" F S IBXIFN=$O(^XTMP("IBCR RC SITE","B",IBX,IBXIFN)) Q:'IBXIFN D Q:$D(DIRUT)
.. S IBNODE=$G(^XTMP("IBCR RC SITE",IBXIFN))
.. W !,?10,$P(IBNODE,U,1),?22,$P(IBNODE,U,2),?60,$P(IBNODE,U,3),?67,$P(IBNODE,U,4)
.. S IBCNT=IBCNT+1,IBEND=0 I '(IBCNT#21) W ! S DIR(0)="E" D ^DIR K DIR W ! S IBEND=1
I 'IBEND,'$D(DIRUT) W ! S DIR(0)="E" D ^DIR K DIR W !
Q
;
LSTSITE(SNAME) ; search, display, selecy from list of sites
; returns 'site IFN in IBCR RC SITE' if one selected, 0 if none selected, -1 if ^
;
N IBX,IBL,IBXIFN,IBNODE,IBCNT,IBEND,IBSEL,SELARR,DIR,DIRUT,DUOUT,X,Y S (IBSEL,IBEND,IBCNT)=0 W !
;
S IBX=SNAME,IBL=$L(SNAME) I SNAME'="" S IBX=$E(SNAME,1,$L(SNAME)-1)_$C($A($E(SNAME,$L(SNAME)))-1)_"~"
;
F S IBX=$O(^XTMP("IBCR RC SITE","B",IBX)) Q:IBX=""!($E(IBX,1,IBL)'=SNAME) D Q:IBSEL'=0
. S IBXIFN="" F S IBXIFN=$O(^XTMP("IBCR RC SITE","B",IBX,IBXIFN)) Q:'IBXIFN D Q:IBSEL'=0
.. S IBNODE=$G(^XTMP("IBCR RC SITE",IBXIFN))
.. S IBCNT=IBCNT+1,SELARR(IBCNT)=IBXIFN
.. W !,?4,IBCNT,")",?10,$P(IBNODE,U,1),?22,$P(IBNODE,U,2),?60,$P(IBNODE,U,3),?67,$P(IBNODE,U,4)
.. S IBEND=0 I '(IBCNT#21) S IBSEL=$$ASKSEL(IBCNT) S IBEND=1
I SNAME'="",IBCNT'>0 W ?40,"??"
;
I IBSEL=0,IBCNT>1,'IBEND S IBSEL=$$ASKSEL(IBCNT)
I IBSEL=0,IBCNT=1 S IBSEL=1
;
I IBSEL>0,$D(SELARR(+IBSEL)) S IBSEL=SELARR(+IBSEL)
;
Q IBSEL
;
ASKSEL(CNT) ; ask user to select from list of sites, returns number selected, 0 if none selected, -1 if ^
;
N DIR,DIRUT,DUOUT,DTOUT,X,Y,IBX S IBX=0 W !
S DIR("?")="Enter return to continue, enter '^' to exit, or enter the number preceding the site you want to select. The number may be no greater than "_CNT
S DIR(0)="NO^1:"_CNT_":0",DIR("A")=" Press return to continue or select a site" D ^DIR
S IBX=$S($D(DUOUT)!$D(DTOUT):-1,+Y>0:+Y,1:0) W !
Q IBX
;
DV999(SITE) ; check if Site is an valid site or a temporary placeholder
N IBX S IBX=0 I +$G(SITE) I ($P(SITE,U,2)?1"9".2N.1"X".1N)!($P(SITE,U,5)="") S IBX=1
Q IBX
;
ASKDV(SITE) ; Get new Division number, Name and Type for invalid sites
; return: "" or 'IFN of site in IBCR RC SITE ^ site number ^ site name ^ 3-digit zip ^ type'
N IBNDIV,IBNM,IBTYP,IBNEW,IBI,IBX,X,Y,DIR,DIRUT,DUOUT,DTOUT S IBNEW="" I '$G(SITE) G ASKDVQ
;
W !!,"--------------------------------------------------------------------------------"
W !,"'",$P(SITE,U,2)," - ",$P(SITE,U,3),"' is an invalid site number, you may now enter",!,"the correct information on the site you are loading charges for.",!
;
I $P(SITE,U,2)="999" S IBNDIV=$P(SITE,U,2),IBNM=$P(SITE,U,3) G ASKTYP
;
S DIR("?")=$P(SITE,U,2)_" is not a valid site number, if you know the correct number for this division you may change it now."
S DIR(0)="F^3:7^I X'?3N,X'?3N1.4UN K X",DIR("A")="Site Division Number" D ^DIR K DIR I $D(DIRUT) G ASKDVQ
S IBNDIV=Y
;
I '$O(^DG(40.8,"C",IBNDIV,0)) W !!,">> ",IBNDIV," is not a valid Medical Center division on your system.",!!
;
I $E(IBNDIV)<9 S IBX=$$SITEDV^IBCRHBSZ(IBNDIV) I +IBX S IBNEW=IBX W !!,"**Site exists." G ASKDVQ
;
S IBX=$$RGDV^IBCRHBSZ(IBNDIV)
I +IBX,+$P(IBX,U,5) S IBNEW=+SITE_U_$P(IBX,U,2,5) W !!,"** Region ",IBNDIV," already exists." G ASKDVQ
I +IBX,'$P(IBX,U,5) S IBNDIV=$P(IBX,U,2),IBNM=$P(IBX,U,3) W !!,"** Region ",IBNDIV," already exists." G ASKTYP
;
;
S DIR(0)="F^3:25",DIR("A")="Location of Site, City" D ^DIR K DIR G:$D(DIRUT) ASKDVQ S IBNM=Y
S DIR(0)="P^5:AEQMZ",DIR("A")="Location of Site, State" D ^DIR K DIR G:$D(DIRUT) ASKDVQ
S IBNM=IBNM_", "_$P(Y(0),U,2)
;
;
W !!,"*** IT IS VERY IMPORTANT THAT TYPE OF FACILITY BE SET CORRECTLY"
W !,"*** IF THERE IS ANY DOUBT OF THE TYPE OF FACILITY THEN CONTACT THE CBO ",!,?4,"OR ENTER A NOIS BEFORE CONTINUING"
ASKTYP S DIR("?",1)="If unsure of the correct Type of Facility for the site then STOP, "
S DIR("?",2)="contact the CBO or enter a NOIS to get the correct Type of Facility.",DIR("?",3)=" "
S DIR("?")="The Type of Facility determines the charges loaded for the site."
;
S DIR(0)="S^1:Inpatient Facility (Provider Based);2:Outpatient Facility (Provider Based);3:Freestanding (Non-Provider Based)",DIR("A")="Type of Facility" D ^DIR I $D(DIRUT) G ASKDVQ
S IBTYP=Y
;
I $P(SITE,U,2)="999" S IBNDIV="999A"_IBTYP
;
S IBNEW=$P(SITE,U,1)_U_IBNDIV_U_IBNM_U_$P(SITE,U,4)_U_IBTYP
;
ASKDVQ W !!,"--------------------------------------------------------------------------------",!
Q IBNEW
;
RECHK(SITE) ; re-check site against existing region, Division number and Type are critical
N IBX,IBY,IBOK,DA,DIC,DIE,DR S IBOK=1,SITE=$G(SITE),IBX=$P($G(SITE),U,2),IBY=0
I IBX'="" S IBY=$$RGDV^IBCRHBSZ(IBX)
;
I +IBY,'$P(IBY,U,5),+$P(SITE,U,5) D ; needed for cases where region exists but division not in host file
. S DR=".03////"_+$P(SITE,U,5),DIE="^IBE(363.31,",DA=+IBY D ^DIE K DIE,DIC,DA,DR S $P(IBY,U,5)=$P(SITE,U,5)
;
I +IBY I ($P(SITE,U,2)'=$P(IBY,U,2))!($P(SITE,U,5)'=$P(IBY,U,5)) D
. S IBOK=0 W !,"*** Error: Division selected does not match existing Region"
. W !,?10,$P(SITE,U,2),?20,$P(SITE,U,3),?55,$P(SITE,U,4),?65,$P(SITE,U,5)
. W !,?10,$P(IBY,U,2),?20,$P(IBY,U,3),?55,$P(IBY,U,4),?65,$P(IBY,U,5)
;
I ($P(SITE,U,4)="")!('$P(SITE,U,5)) D
. S IBOK=0 W !,"** Error: Required data missing (zip or type):"
. W !,?10,$P(SITE,U,2),?20,$P(SITE,U,3),?55,$P(SITE,U,4),?65,$P(SITE,U,5)
;
I $P(SITE,U,4)'="",'$O(^XTMP("IBCR RC E","A",$P(SITE,U,4),0)) D
. S IBOK=0 W !,"** Error: No Area Factors defined for site/zip:"
. W !,?10,$P(SITE,U,2),?20,$P(SITE,U,3),?55,$P(SITE,U,4),?65,$P(SITE,U,5)
Q IBOK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRHBS4 8245 printed Dec 13, 2024@02:19:27 Page 2
IBCRHBS4 ;ALB/ARH - RATES: UPLOAD (RC 2+) SELECT SITES ; 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 ;
SELSITE() ; select one site to calculate RC charges for
+1 ; return: 0 or 'IFN of site in IBCR RC SITE ^ site number ^ site name ^ 3-digit zip ^ type'
+2 ;
+3 DO SETRGZIP^IBCRHBSZ
DO CHKRGZIP^IBCRHBSZ
+4 ;
+5 NEW IBSNAME,IBSELDIV,IBX,IBXIFN,IBMCDV
+6 WRITE !!!,"Select Site to calculate Reasonable Charges v"_$$VERSION^IBCRHBRV_" for load into Charge Master"
+7 WRITE !,"--------------------------------------------------------------------------------"
+8 ;
SELECT SET (IBSELDIV,IBMCDV)=0
+1 SET IBSNAME=$$ASKNAM
IF IBSNAME=""
GOTO SSQ
+2 ;
+3 SET IBXIFN=$$LSTSITE(IBSNAME)
IF +IBXIFN'>0
GOTO SELECT
+4 SET IBSELDIV=$GET(^XTMP("IBCR RC SITE",IBXIFN))
IF IBSELDIV=""
GOTO SELECT
+5 SET IBSELDIV=IBXIFN_U_IBSELDIV
+6 ;
+7 IF $$DV999(IBSELDIV)
SET IBSELDIV=$$ASKDV(IBSELDIV)
IF IBSELDIV=""
GOTO SELECT
+8 ;
+9 IF '$$RECHK(IBSELDIV)
GOTO SELECT
+10 ;
+11 SET IBX=$PIECE(IBSELDIV,U,2)
DO MSGSITE^IBCRHBRV(IBX)
DO MSGVERS^IBCRHBRV(IBX)
DO MSGDIV^IBCRHBSZ(IBX)
+12 ;
+13 IF '$$CONT(IBSELDIV)
GOTO SELECT
+14 ;
SSQ QUIT IBSELDIV
+1 ;
ASKNAM() ; ask the user to enter the name of a site/division, return upper case name entered or null
+1 NEW DIR,DIRUT,DUOUT,X,Y,IBX,IBY
SET IBX=""
+2 SET DIR("?",1)="All or some divisions whose care is billed from your site may have charges."
+3 SET DIR("?",2)="Some charges are unique to a single division, others cover multiple divisions."
+4 SET DIR("?",3)="This may result in multiple sets in the Charge Master."
+5 SET DIR("?",4)="Enter '??' for a complete list of divisions."
+6 SET DIR("?",5)="Enter a division number or name for a matching list."
SET DIR("?",6)=""
+7 SET DIR("?")="Select a division that will be billed at your site."
SET DIR("??")="^D LSTALL^IBCRHBS4"
+8 SET DIR(0)="FO"
SET DIR("A")="Select Division"
WRITE !!
DO ^DIR
KILL DIR
SET IBX=Y
IF $DATA(DIRUT)
SET IBX=""
+9 IF IBX'=""
SET IBX=$$UP^XLFSTR(IBX)
+10 QUIT IBX
+11 ;
CONT(SITE) ; as user if they want to load this division, return 1 if accept division and calculate charges, else 0
+1 NEW DIR,DIRUT,DUOUT,X,Y,IBX
SET IBX=0
+2 WRITE !,?15,$PIECE(SITE,U,2),?27,$PIECE(SITE,U,3),?60,$PIECE(SITE,U,4),?67,$PIECE(SITE,U,5),!
+3 SET DIR("?")="Enter 'Y' if the care provided at this division is billed at your site and you need this divisions charges loaded on your system."
+4 SET DIR("A")="Calculate RC v"_$$VERSION^IBCRHBRV_" charges for this division"
+5 SET DIR(0)="YO"
DO ^DIR
KILL DIR
IF Y=1
SET IBX=Y
+6 QUIT IBX
+7 ;
LSTALL ; list all sites, user cannot select, nothing returned
+1 NEW IBX,IBCNT,IBEND,IBXIFN,IBNODE,DIR,DIRUT,DUOUT,DTOUT,X,Y
SET (IBCNT,IBEND)=0
WRITE !
+2 ;
+3 SET IBX=""
FOR
SET IBX=$ORDER(^XTMP("IBCR RC SITE","C",IBX))
if IBX=""
QUIT
Begin DoDot:1
+4 SET IBXIFN=""
FOR
SET IBXIFN=$ORDER(^XTMP("IBCR RC SITE","B",IBX,IBXIFN))
if 'IBXIFN
QUIT
Begin DoDot:2
+5 SET IBNODE=$GET(^XTMP("IBCR RC SITE",IBXIFN))
+6 WRITE !,?10,$PIECE(IBNODE,U,1),?22,$PIECE(IBNODE,U,2),?60,$PIECE(IBNODE,U,3),?67,$PIECE(IBNODE,U,4)
+7 SET IBCNT=IBCNT+1
SET IBEND=0
IF '(IBCNT#21)
WRITE !
SET DIR(0)="E"
DO ^DIR
KILL DIR
WRITE !
SET IBEND=1
End DoDot:2
if $DATA(DIRUT)
QUIT
End DoDot:1
if $DATA(DIRUT)
QUIT
+8 IF 'IBEND
IF '$DATA(DIRUT)
WRITE !
SET DIR(0)="E"
DO ^DIR
KILL DIR
WRITE !
+9 QUIT
+10 ;
LSTSITE(SNAME) ; search, display, selecy from list of sites
+1 ; returns 'site IFN in IBCR RC SITE' if one selected, 0 if none selected, -1 if ^
+2 ;
+3 NEW IBX,IBL,IBXIFN,IBNODE,IBCNT,IBEND,IBSEL,SELARR,DIR,DIRUT,DUOUT,X,Y
SET (IBSEL,IBEND,IBCNT)=0
WRITE !
+4 ;
+5 SET IBX=SNAME
SET IBL=$LENGTH(SNAME)
IF SNAME'=""
SET IBX=$EXTRACT(SNAME,1,$LENGTH(SNAME)-1)_$CHAR($ASCII($EXTRACT(SNAME,$LENGTH(SNAME)))-1)_"~"
+6 ;
+7 FOR
SET IBX=$ORDER(^XTMP("IBCR RC SITE","B",IBX))
if IBX=""!($EXTRACT(IBX,1,IBL)'=SNAME)
QUIT
Begin DoDot:1
+8 SET IBXIFN=""
FOR
SET IBXIFN=$ORDER(^XTMP("IBCR RC SITE","B",IBX,IBXIFN))
if 'IBXIFN
QUIT
Begin DoDot:2
+9 SET IBNODE=$GET(^XTMP("IBCR RC SITE",IBXIFN))
+10 SET IBCNT=IBCNT+1
SET SELARR(IBCNT)=IBXIFN
+11 WRITE !,?4,IBCNT,")",?10,$PIECE(IBNODE,U,1),?22,$PIECE(IBNODE,U,2),?60,$PIECE(IBNODE,U,3),?67,$PIECE(IBNODE,U,4)
+12 SET IBEND=0
IF '(IBCNT#21)
SET IBSEL=$$ASKSEL(IBCNT)
SET IBEND=1
End DoDot:2
if IBSEL'=0
QUIT
End DoDot:1
if IBSEL'=0
QUIT
+13 IF SNAME'=""
IF IBCNT'>0
WRITE ?40,"??"
+14 ;
+15 IF IBSEL=0
IF IBCNT>1
IF 'IBEND
SET IBSEL=$$ASKSEL(IBCNT)
+16 IF IBSEL=0
IF IBCNT=1
SET IBSEL=1
+17 ;
+18 IF IBSEL>0
IF $DATA(SELARR(+IBSEL))
SET IBSEL=SELARR(+IBSEL)
+19 ;
+20 QUIT IBSEL
+21 ;
ASKSEL(CNT) ; ask user to select from list of sites, returns number selected, 0 if none selected, -1 if ^
+1 ;
+2 NEW DIR,DIRUT,DUOUT,DTOUT,X,Y,IBX
SET IBX=0
WRITE !
+3 SET DIR("?")="Enter return to continue, enter '^' to exit, or enter the number preceding the site you want to select. The number may be no greater than "_CNT
+4 SET DIR(0)="NO^1:"_CNT_":0"
SET DIR("A")=" Press return to continue or select a site"
DO ^DIR
+5 SET IBX=$SELECT($DATA(DUOUT)!$DATA(DTOUT):-1,+Y>0:+Y,1:0)
WRITE !
+6 QUIT IBX
+7 ;
DV999(SITE) ; check if Site is an valid site or a temporary placeholder
+1 NEW IBX
SET IBX=0
IF +$GET(SITE)
IF ($PIECE(SITE,U,2)?1"9".2N.1"X".1N)!($PIECE(SITE,U,5)="")
SET IBX=1
+2 QUIT IBX
+3 ;
ASKDV(SITE) ; Get new Division number, Name and Type for invalid sites
+1 ; return: "" or 'IFN of site in IBCR RC SITE ^ site number ^ site name ^ 3-digit zip ^ type'
+2 NEW IBNDIV,IBNM,IBTYP,IBNEW,IBI,IBX,X,Y,DIR,DIRUT,DUOUT,DTOUT
SET IBNEW=""
IF '$GET(SITE)
GOTO ASKDVQ
+3 ;
+4 WRITE !!,"--------------------------------------------------------------------------------"
+5 WRITE !,"'",$PIECE(SITE,U,2)," - ",$PIECE(SITE,U,3),"' is an invalid site number, you may now enter",!,"the correct information on the site you are loading charges for.",!
+6 ;
+7 IF $PIECE(SITE,U,2)="999"
SET IBNDIV=$PIECE(SITE,U,2)
SET IBNM=$PIECE(SITE,U,3)
GOTO ASKTYP
+8 ;
+9 SET DIR("?")=$PIECE(SITE,U,2)_" is not a valid site number, if you know the correct number for this division you may change it now."
+10 SET DIR(0)="F^3:7^I X'?3N,X'?3N1.4UN K X"
SET DIR("A")="Site Division Number"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO ASKDVQ
+11 SET IBNDIV=Y
+12 ;
+13 IF '$ORDER(^DG(40.8,"C",IBNDIV,0))
WRITE !!,">> ",IBNDIV," is not a valid Medical Center division on your system.",!!
+14 ;
+15 IF $EXTRACT(IBNDIV)<9
SET IBX=$$SITEDV^IBCRHBSZ(IBNDIV)
IF +IBX
SET IBNEW=IBX
WRITE !!,"**Site exists."
GOTO ASKDVQ
+16 ;
+17 SET IBX=$$RGDV^IBCRHBSZ(IBNDIV)
+18 IF +IBX
IF +$PIECE(IBX,U,5)
SET IBNEW=+SITE_U_$PIECE(IBX,U,2,5)
WRITE !!,"** Region ",IBNDIV," already exists."
GOTO ASKDVQ
+19 IF +IBX
IF '$PIECE(IBX,U,5)
SET IBNDIV=$PIECE(IBX,U,2)
SET IBNM=$PIECE(IBX,U,3)
WRITE !!,"** Region ",IBNDIV," already exists."
GOTO ASKTYP
+20 ;
+21 ;
+22 SET DIR(0)="F^3:25"
SET DIR("A")="Location of Site, City"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO ASKDVQ
SET IBNM=Y
+23 SET DIR(0)="P^5:AEQMZ"
SET DIR("A")="Location of Site, State"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO ASKDVQ
+24 SET IBNM=IBNM_", "_$PIECE(Y(0),U,2)
+25 ;
+26 ;
+27 WRITE !!,"*** IT IS VERY IMPORTANT THAT TYPE OF FACILITY BE SET CORRECTLY"
+28 WRITE !,"*** IF THERE IS ANY DOUBT OF THE TYPE OF FACILITY THEN CONTACT THE CBO ",!,?4,"OR ENTER A NOIS BEFORE CONTINUING"
ASKTYP SET DIR("?",1)="If unsure of the correct Type of Facility for the site then STOP, "
+1 SET DIR("?",2)="contact the CBO or enter a NOIS to get the correct Type of Facility."
SET DIR("?",3)=" "
+2 SET DIR("?")="The Type of Facility determines the charges loaded for the site."
+3 ;
+4 SET DIR(0)="S^1:Inpatient Facility (Provider Based);2:Outpatient Facility (Provider Based);3:Freestanding (Non-Provider Based)"
SET DIR("A")="Type of Facility"
DO ^DIR
IF $DATA(DIRUT)
GOTO ASKDVQ
+5 SET IBTYP=Y
+6 ;
+7 IF $PIECE(SITE,U,2)="999"
SET IBNDIV="999A"_IBTYP
+8 ;
+9 SET IBNEW=$PIECE(SITE,U,1)_U_IBNDIV_U_IBNM_U_$PIECE(SITE,U,4)_U_IBTYP
+10 ;
ASKDVQ WRITE !!,"--------------------------------------------------------------------------------",!
+1 QUIT IBNEW
+2 ;
RECHK(SITE) ; re-check site against existing region, Division number and Type are critical
+1 NEW IBX,IBY,IBOK,DA,DIC,DIE,DR
SET IBOK=1
SET SITE=$GET(SITE)
SET IBX=$PIECE($GET(SITE),U,2)
SET IBY=0
+2 IF IBX'=""
SET IBY=$$RGDV^IBCRHBSZ(IBX)
+3 ;
+4 ; needed for cases where region exists but division not in host file
IF +IBY
IF '$PIECE(IBY,U,5)
IF +$PIECE(SITE,U,5)
Begin DoDot:1
+5 SET DR=".03////"_+$PIECE(SITE,U,5)
SET DIE="^IBE(363.31,"
SET DA=+IBY
DO ^DIE
KILL DIE,DIC,DA,DR
SET $PIECE(IBY,U,5)=$PIECE(SITE,U,5)
End DoDot:1
+6 ;
+7 IF +IBY
IF ($PIECE(SITE,U,2)'=$PIECE(IBY,U,2))!($PIECE(SITE,U,5)'=$PIECE(IBY,U,5))
Begin DoDot:1
+8 SET IBOK=0
WRITE !,"*** Error: Division selected does not match existing Region"
+9 WRITE !,?10,$PIECE(SITE,U,2),?20,$PIECE(SITE,U,3),?55,$PIECE(SITE,U,4),?65,$PIECE(SITE,U,5)
+10 WRITE !,?10,$PIECE(IBY,U,2),?20,$PIECE(IBY,U,3),?55,$PIECE(IBY,U,4),?65,$PIECE(IBY,U,5)
End DoDot:1
+11 ;
+12 IF ($PIECE(SITE,U,4)="")!('$PIECE(SITE,U,5))
Begin DoDot:1
+13 SET IBOK=0
WRITE !,"** Error: Required data missing (zip or type):"
+14 WRITE !,?10,$PIECE(SITE,U,2),?20,$PIECE(SITE,U,3),?55,$PIECE(SITE,U,4),?65,$PIECE(SITE,U,5)
End DoDot:1
+15 ;
+16 IF $PIECE(SITE,U,4)'=""
IF '$ORDER(^XTMP("IBCR RC E","A",$PIECE(SITE,U,4),0))
Begin DoDot:1
+17 SET IBOK=0
WRITE !,"** Error: No Area Factors defined for site/zip:"
+18 WRITE !,?10,$PIECE(SITE,U,2),?20,$PIECE(SITE,U,3),?55,$PIECE(SITE,U,4),?65,$PIECE(SITE,U,5)
End DoDot:1
+19 QUIT IBOK
