- IBCRHBR4 ;ALB/ARH - RATES: UPLOAD (RC) SELECT SITES ; 10-OCT-1998
- ;;2.0;INTEGRATED BILLING;**106,138,148**;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'
- ;
- D SETRGZIP,CHKRGZIP
- ;
- 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
- ;
- S IBX=$P(IBSELDIV,U,2) D MSGSITE^IBCRHBRV(IBX),MSGVERS^IBCRHBRV(IBX),MSGDIV(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^IBCRHBR4"
- 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),!
- 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 !,?15,$P(IBNODE,U,1),?27,$P(IBNODE,U,2),?65,$P(IBNODE,U,3)
- .. 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 !,?9,IBCNT,")",?15,$P(IBNODE,U,1),?27,$P(IBNODE,U,2),?65,$P(IBNODE,U,3)
- .. 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
- ;
- ;
- 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)
- ; the 3-digit zip was not available with RC v1, so Regions created for RC v1 will not have this field set
- ;
- N DIE,DIC,DA,DR,X,Y,IBRGFN,IBLN,IBZIP 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 " Q:$P(IBLN,U,2)'=""
- . ;
- . S IBZIP=$P($$SITEDV($P(IBLN," ",2)),U,4) Q:IBZIP'?3N
- . ;
- . S DIE="^IBE(363.31,",DA=IBRGFN,DR=".02////"_IBZIP D ^DIE K DIE,DIC,DA,DR
- Q
- ;
- SITEDV(DIV) ; return the 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'
- ;
- 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
- ;
- CHKRGZIP ; for all existing Billing Regions, check to ensure each division assigned is actually within that Region
- ; 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,IBRGZIP,IBDVFN,IBDV,IBDVLN,IBDVZIP,ARRAY,DA,DIK,DIC,DIR,X,Y 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 "
- . S IBRGZIP=$P($$SITEDV($P(IBLN," ",2)),U,4) Q:IBRGZIP'?3N
- . ;
- . 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 IBDVZIP=$P($$SITEDV($P(IBDVLN,U,2)),U,4) Q:IBDVZIP'?3N
- .. ;
- .. I IBRGZIP=IBDVZIP Q
- .. S ARRAY(IBRGFN)=IBLN,ARRAY(IBRGFN,IBDV)=$P(IBDVLN,U,1,2)_U_IBDVZIP
- .. S DA(1)=IBRGFN,DIK="^IBE(363.31,"_DA(1)_",11,",DA=IBDVFN D ^DIK
- ;
- I $O(ARRAY(0)) D
- . W @IOF,!,"********************************************************************************"
- . W !,"Incorrect Billing Regions found in the Charge Master."
- . W !!,"Billing Regions are defined by the 3-digit zip code identifier of the primary",!,"division. Only Divisions with the same 3-digit zip code identifier should",!,"be assigned to a Billing Region."
- . W !!,"There were Divisions incorrectly associated with Billing Regions in the",!,"Charge Master. For the following Billing Regions, the corresponding 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),")"
- .. ;
- .. 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),")",!
- . W !,"********************************************************************************",!
- . S DIR(0)="E" D ^DIR K DIR W @IOF
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRHBR4 8229 printed Feb 18, 2025@23:45:41 Page 2
- IBCRHBR4 ;ALB/ARH - RATES: UPLOAD (RC) SELECT SITES ; 10-OCT-1998
- +1 ;;2.0;INTEGRATED BILLING;**106,138,148**;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'
- +2 ;
- +3 DO SETRGZIP
- DO CHKRGZIP
- +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 SET IBX=$PIECE(IBSELDIV,U,2)
- DO MSGSITE^IBCRHBRV(IBX)
- DO MSGVERS^IBCRHBRV(IBX)
- DO MSGDIV(IBX)
- +8 ;
- +9 IF '$$CONT(IBSELDIV)
- GOTO SELECT
- +10 ;
- 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^IBCRHBR4"
- +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),!
- +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 !,?15,$PIECE(IBNODE,U,1),?27,$PIECE(IBNODE,U,2),?65,$PIECE(IBNODE,U,3)
- +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 !,?9,IBCNT,")",?15,$PIECE(IBNODE,U,1),?27,$PIECE(IBNODE,U,2),?65,$PIECE(IBNODE,U,3)
- +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 ;
- +8 ;
- 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 ; the 3-digit zip was not available with RC v1, so Regions created for RC v1 will not have this field set
- +2 ;
- +3 NEW DIE,DIC,DA,DR,X,Y,IBRGFN,IBLN,IBZIP
- IF $$VERSION^IBCRHBRV=1
- QUIT
- +4 ;
- +5 SET IBRGFN=0
- FOR
- SET IBRGFN=$ORDER(^IBE(363.31,IBRGFN))
- if 'IBRGFN
- QUIT
- Begin DoDot:1
- +6 SET IBLN=$GET(^IBE(363.31,IBRGFN,0))
- if $EXTRACT(IBLN,1,3)'="RC "
- QUIT
- if $PIECE(IBLN,U,2)'=""
- QUIT
- +7 ;
- +8 SET IBZIP=$PIECE($$SITEDV($PIECE(IBLN," ",2)),U,4)
- if IBZIP'?3N
- QUIT
- +9 ;
- +10 SET DIE="^IBE(363.31,"
- SET DA=IBRGFN
- SET DR=".02////"_IBZIP
- DO ^DIE
- KILL DIE,DIC,DA,DR
- End DoDot:1
- +11 QUIT
- +12 ;
- SITEDV(DIV) ; return the 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'
- +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 ;
- CHKRGZIP ; for all existing Billing Regions, check to ensure each division assigned is actually within that Region
- +1 ; the 3-digit zip of the Regions Divisions must match the 3-digit zip of the Regions primary division
- +2 ; if the 3-digit zips do not match, the Division is deleted from the Region
- +3 ;
- +4 NEW IBRGFN,IBLN,IBRGZIP,IBDVFN,IBDV,IBDVLN,IBDVZIP,ARRAY,DA,DIK,DIC,DIR,X,Y
- IF $$VERSION^IBCRHBRV=1
- QUIT
- +5 ;
- +6 SET IBRGFN=0
- FOR
- SET IBRGFN=$ORDER(^IBE(363.31,IBRGFN))
- if 'IBRGFN
- QUIT
- Begin DoDot:1
- +7 SET IBLN=$GET(^IBE(363.31,IBRGFN,0))
- if $EXTRACT(IBLN,1,3)'="RC "
- QUIT
- +8 SET IBRGZIP=$PIECE($$SITEDV($PIECE(IBLN," ",2)),U,4)
- if IBRGZIP'?3N
- QUIT
- +9 ;
- +10 SET IBDVFN=0
- FOR
- SET IBDVFN=$ORDER(^IBE(363.31,IBRGFN,11,IBDVFN))
- if 'IBDVFN
- QUIT
- Begin DoDot:2
- +11 SET IBDV=+$GET(^IBE(363.31,IBRGFN,11,IBDVFN,0))
- if 'IBDV
- QUIT
- +12 SET IBDVLN=$GET(^DG(40.8,+IBDV,0))
- if IBDVLN=""
- QUIT
- +13 SET IBDVZIP=$PIECE($$SITEDV($PIECE(IBDVLN,U,2)),U,4)
- if IBDVZIP'?3N
- QUIT
- +14 ;
- +15 IF IBRGZIP=IBDVZIP
- QUIT
- +16 SET ARRAY(IBRGFN)=IBLN
- SET ARRAY(IBRGFN,IBDV)=$PIECE(IBDVLN,U,1,2)_U_IBDVZIP
- +17 SET DA(1)=IBRGFN
- SET DIK="^IBE(363.31,"_DA(1)_",11,"
- SET DA=IBDVFN
- DO ^DIK
- End DoDot:2
- End DoDot:1
- +18 ;
- +19 IF $ORDER(ARRAY(0))
- Begin DoDot:1
- +20 WRITE @IOF,!,"********************************************************************************"
- +21 WRITE !,"Incorrect Billing Regions found in the Charge Master."
- +22 WRITE !!,"Billing Regions are defined by the 3-digit zip code identifier of the primary",!,"division. Only Divisions with the same 3-digit zip code identifier should",!,"be assigned to a Billing Region."
- +23 WRITE !!,"There were Divisions incorrectly associated with Billing Regions in the",!,"Charge Master. For the following Billing Regions, the corresponding Division",!,"has been deleted."
- +24 WRITE !!,?3,"Billing Region",?43,"Division(s) Deleted",!,?3,"--------------------------------------------------------------------------"
- +25 ;
- +26 SET IBRGFN=0
- FOR
- SET IBRGFN=$ORDER(ARRAY(IBRGFN))
- if 'IBRGFN
- QUIT
- Begin DoDot:2
- +27 SET IBLN=ARRAY(IBRGFN)
- WRITE !,?3,$EXTRACT($PIECE(IBLN,U,1),1,23),?26,"(",$PIECE(IBLN,U,2),")"
- +28 ;
- +29 SET IBDV=0
- FOR
- SET IBDV=$ORDER(ARRAY(IBRGFN,IBDV))
- if 'IBDV
- QUIT
- Begin DoDot:3
- +30 SET IBLN=ARRAY(IBRGFN,IBDV)
- WRITE ?43,$PIECE(IBLN,U,2),?50,$EXTRACT($PIECE(IBLN,U,1),1,20),?72,"(",$PIECE(IBLN,U,3),")",!
- End DoDot:3
- End DoDot:2
- +31 WRITE !,"********************************************************************************",!
- +32 SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- WRITE @IOF
- End DoDot:1
- +33 QUIT