IBYP573A.m

IBYP573A ;ALB/CXW - IB*2.0*573 POST INIT: BILLING REGION UPDATE ;09-30-2016

 ;;2.0;INTEGRATED BILLING;**573**;21-MAR-94;Build 42

 ;;Per VA Directive 6402, this routine should not be modified.

 ;

 Q

TYPE ; change facility type from 3-NPB to 2-PBO for primary division

 N IBA,IBARY,IBCNT,IBI,IBLN,IBLND,IBHDV,IBBDV,IBBIEN,DA,DIE,DR,X,Y S IBCNT=0

 D MSG("")

 D MSG("      >> Updating Billing Regions with Provider Based (Facility Type 2)")

 F IBI=1:1 S IBLN=$P($T(NPBTX+IBI^IBYP573B),";;",2) Q:IBLN=""  D

 . S IBHDV=$P(IBLN,U) Q:IBHDV=""

 . S ^TMP("IB573",$J,IBHDV,IBI)=""

 ;

 ; update type with 2 if not match

 S IBBIEN=0 F  S IBBIEN=$O(^IBE(363.31,IBBIEN)) Q:'IBBIEN  D

 . S IBLND=$G(^IBE(363.31,IBBIEN,0)) Q:IBLND=""

 . Q:$E(IBLND,1,3)'="RC "

 . S IBBDV=$P(IBLND," ",2) Q:IBBDV=""

 . Q:'$D(^TMP("IB573",$J,IBBDV))

 . Q:$P(IBLND,U,3)=2

 . ;

 . S DIE="^IBE(363.31,",DA=IBBIEN,DR=".03///2"

 . D ^DIE K DIE,DR,DA,X,Y

 . S IBCNT=IBCNT+1,IBARY($P(IBLND,U))=""

 ;

 ; display region name by order

 S IBBDV="" F  S IBBDV=$O(IBARY(IBBDV)) Q:IBBDV=""  D MSG("         "_IBBDV)

 D MSG("         Done.  "_IBCNT_" facility type of billing regions changed")

 K ^TMP("IB573",$J)

 Q

 ;

MSG(IBA) ;

 D MES^XPDUTL(IBA)

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBYP573A   1236     printed  Mar 13, 2025@21:41:18                                                                                                                                                                                                    Page 2

IBYP573A  ;ALB/CXW - IB*2.0*573 POST INIT: BILLING REGION UPDATE ;09-30-2016

 +1       ;;2.0;INTEGRATED BILLING;**573**;21-MAR-94;Build 42

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3       ;

 +4        QUIT 

TYPE      ; change facility type from 3-NPB to 2-PBO for primary division

 +1        NEW IBA,IBARY,IBCNT,IBI,IBLN,IBLND,IBHDV,IBBDV,IBBIEN,DA,DIE,DR,X,Y

           SET IBCNT=0

 +2        DO MSG("")

 +3        DO MSG("      >> Updating Billing Regions with Provider Based (Facility Type 2)")

 +4        FOR IBI=1:1

               SET IBLN=$PIECE($TEXT(NPBTX+IBI^IBYP573B),";;",2)

               if IBLN=""

                   QUIT 

               Begin DoDot:1

 +5                SET IBHDV=$PIECE(IBLN,U)

                   if IBHDV=""

                       QUIT 

 +6                SET ^TMP("IB573",$JOB,IBHDV,IBI)=""

               End DoDot:1

 +7       ;

 +8       ; update type with 2 if not match

 +9        SET IBBIEN=0

           FOR 

               SET IBBIEN=$ORDER(^IBE(363.31,IBBIEN))

               if 'IBBIEN

                   QUIT 

               Begin DoDot:1

 +10               SET IBLND=$GET(^IBE(363.31,IBBIEN,0))

                   if IBLND=""

                       QUIT 

 +11               if $EXTRACT(IBLND,1,3)'="RC "

                       QUIT 

 +12               SET IBBDV=$PIECE(IBLND," ",2)

                   if IBBDV=""

                       QUIT 

 +13               if '$DATA(^TMP("IB573",$JOB,IBBDV))

                       QUIT 

 +14               if $PIECE(IBLND,U,3)=2

                       QUIT 

 +15      ;

 +16               SET DIE="^IBE(363.31,"

                   SET DA=IBBIEN

                   SET DR=".03///2"

 +17               DO ^DIE

                   KILL DIE,DR,DA,X,Y

 +18               SET IBCNT=IBCNT+1

                   SET IBARY($PIECE(IBLND,U))=""

               End DoDot:1

 +19      ;

 +20      ; display region name by order

 +21       SET IBBDV=""

           FOR 

               SET IBBDV=$ORDER(IBARY(IBBDV))

               if IBBDV=""

                   QUIT 

               DO MSG("         "_IBBDV)

 +22       DO MSG("         Done.  "_IBCNT_" facility type of billing regions changed")

 +23       KILL ^TMP("IB573",$JOB)

 +24       QUIT 

 +25      ;

MSG(IBA)  ;

 +1        DO MES^XPDUTL(IBA)

 +2        QUIT