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 ---[H[J[2J[HIBYP573A 1236 printed Dec 13, 2024@02:36:07 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
