IBYP584A ;ALB/CXW - IB*2.0*584 POST INIT: BILLING REGION UPDATE ;12-27-2016
;;2.0;INTEGRATED BILLING;**584**;21-MAR-94;Build 40
;;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),";;",2) Q:IBLN="" D
. S IBHDV=$P(IBLN,U) Q:IBHDV=""
. S ^TMP("IB584",$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("IB584",$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("IB584",$J)
Q
;
MSG(IBA) ;
D MES^XPDUTL(IBA)
Q
; 13 from Non-Provider Based (type 3) to Provider Based Outpt (type 2)
NPBTX ; station^location^state^zip 3^VN
;;402QB^HOULTON VA CLINIC, ME^ME^047^1
;;436GJ^MILES CITY VA CLINIC, MT^MT^593^19
;;568HA^NEWCASTLE, WY^WY^827^23
;;573GN^PERRY VA CLINIC, FL^FL^323^8
;;573QJ^JACKSONVILLE 2 VA CLINIC, FL^FL^322^8
;;626GJ^HOPKINSVILLE VA CLINIC, KY^KY^422^9
;;626GN^ATHENS VA CLINIC, TN^TN^373^9
;;631QA^PLANTATION STREET VA CLINIC, MA^MA^016^1
;;652GB^FREDERICKSBURG 2 VA CLINIC, VA^VA^224^6
;;655QB^GRAND TRAVERSE VA CLINIC, MI^MI^496^10
;;658GA^TAZEWELL VA CLINIC, VA^VA^246^6
;;659BZ^SOUTH CAHRLOTTE VA CLINIC, NC^NC^282^6
;;671GC^DEL RIO VA CLINIC, TX^TX^788^17
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYP584A 1925 printed Dec 13, 2024@02:36:10 Page 2
IBYP584A ;ALB/CXW - IB*2.0*584 POST INIT: BILLING REGION UPDATE ;12-27-2016
+1 ;;2.0;INTEGRATED BILLING;**584**;21-MAR-94;Build 40
+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),";;",2)
if IBLN=""
QUIT
Begin DoDot:1
+5 SET IBHDV=$PIECE(IBLN,U)
if IBHDV=""
QUIT
+6 SET ^TMP("IB584",$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("IB584",$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("IB584",$JOB)
+24 QUIT
+25 ;
MSG(IBA) ;
+1 DO MES^XPDUTL(IBA)
+2 QUIT
+3 ; 13 from Non-Provider Based (type 3) to Provider Based Outpt (type 2)
NPBTX ; station^location^state^zip 3^VN
+1 ;;402QB^HOULTON VA CLINIC, ME^ME^047^1
+2 ;;436GJ^MILES CITY VA CLINIC, MT^MT^593^19
+3 ;;568HA^NEWCASTLE, WY^WY^827^23
+4 ;;573GN^PERRY VA CLINIC, FL^FL^323^8
+5 ;;573QJ^JACKSONVILLE 2 VA CLINIC, FL^FL^322^8
+6 ;;626GJ^HOPKINSVILLE VA CLINIC, KY^KY^422^9
+7 ;;626GN^ATHENS VA CLINIC, TN^TN^373^9
+8 ;;631QA^PLANTATION STREET VA CLINIC, MA^MA^016^1
+9 ;;652GB^FREDERICKSBURG 2 VA CLINIC, VA^VA^224^6
+10 ;;655QB^GRAND TRAVERSE VA CLINIC, MI^MI^496^10
+11 ;;658GA^TAZEWELL VA CLINIC, VA^VA^246^6
+12 ;;659BZ^SOUTH CAHRLOTTE VA CLINIC, NC^NC^282^6
+13 ;;671GC^DEL RIO VA CLINIC, TX^TX^788^17
+14 ;
+15 QUIT
