IBYPSP ;ALB/CXW - IB*2.0*427 POST INIT: REASONABLE CHARGES V3.5 ; 01/12/10
;;2.0;INTEGRATED BILLING;**427**;21-MAR-94;Build 7
;;Per VHA Directive 2004-038, this routine should not be modified.
;
Q
;
CPTLK ; called by IBYP427
;
D RVA ; activate Revenue Codes (399.2,2)
;
D RVD^IBYPSP1 ; delete existing Revenue Code - CPT Links (#363.33)
D RVL^IBYPSP1 ; add new/updated Revenue Code - CPT Links (#363.33)
Q
;
RVA ; activate Revenue Codes exported in RV-CPT links (399.2,2), if currently inactive
N IBA,IBX,IBLN,IBI,IBRV,IBRVFN,IBRVLN,IBACT,IBCNT,IBJ,DD,DO,DIC,DIE,DA,DR,X,Y S IBCNT=0,IBACT=""
;
F IBX=1:1 S IBLN=$P($T(FRVA+IBX),";;",2) Q:IBLN="" D
. F IBI=1:1 S IBRV=$P(IBLN,",",IBI) Q:IBRV'?3N D
.. ;
.. S IBRVFN=$O(^DGCR(399.2,"B",IBRV,0)) Q:'IBRVFN
.. S IBRVLN=$G(^DGCR(399.2,+IBRVFN,0)) Q:IBRVLN=""
.. I +$P(IBRVLN,U,3) Q
.. ;
.. S IBCNT=IBCNT+1,IBACT=IBACT_IBRV_","
.. S DR="2////1",DIE="^DGCR(399.2,",DA=+IBRVFN D ^DIE K DIE,DIC,DA,DR,X,Y
;
I IBCNT>0 S IBJ=0 F IBI=1:15 S IBJ=IBJ+15 S IBLN=$P(IBACT,",",IBI,IBJ) Q:IBLN="" D MSG(" "_IBLN)
;
RVAQ S IBA(1)="",IBA(2)=" >> "_IBCNT_" Revenue Codes activated (399.2)..." D MSG(" ")
D MES^XPDUTL(.IBA)
Q
;
;
MSG(X) ;
N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
S IBA(IBX)=$G(X)
Q
;
FRVA ; Revenue Codes to Activate (399.2,2)
;;160,251,252,255,258,259,260,264,270,271,272,273,275,276,277,278,279,290,292,294,
;;299,321,329,331,335,343,350,361,369,374,381,382,383,384,389,419,421,424,431,444,
;;472,483,513,516,519,530,531,540,541,542,544,545,549,551,552,560,561,570,571,580,
;;581,589,601,614,618,634,640,649,651,660,720,732,760,820,821,822,823,825,831,835,
;;881,903,923,929,940,942,963,974,975,987,
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYPSP 1768 printed Nov 22, 2024@17:46:51 Page 2
IBYPSP ;ALB/CXW - IB*2.0*427 POST INIT: REASONABLE CHARGES V3.5 ; 01/12/10
+1 ;;2.0;INTEGRATED BILLING;**427**;21-MAR-94;Build 7
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
CPTLK ; called by IBYP427
+1 ;
+2 ; activate Revenue Codes (399.2,2)
DO RVA
+3 ;
+4 ; delete existing Revenue Code - CPT Links (#363.33)
DO RVD^IBYPSP1
+5 ; add new/updated Revenue Code - CPT Links (#363.33)
DO RVL^IBYPSP1
+6 QUIT
+7 ;
RVA ; activate Revenue Codes exported in RV-CPT links (399.2,2), if currently inactive
+1 NEW IBA,IBX,IBLN,IBI,IBRV,IBRVFN,IBRVLN,IBACT,IBCNT,IBJ,DD,DO,DIC,DIE,DA,DR,X,Y
SET IBCNT=0
SET IBACT=""
+2 ;
+3 FOR IBX=1:1
SET IBLN=$PIECE($TEXT(FRVA+IBX),";;",2)
if IBLN=""
QUIT
Begin DoDot:1
+4 FOR IBI=1:1
SET IBRV=$PIECE(IBLN,",",IBI)
if IBRV'?3N
QUIT
Begin DoDot:2
+5 ;
+6 SET IBRVFN=$ORDER(^DGCR(399.2,"B",IBRV,0))
if 'IBRVFN
QUIT
+7 SET IBRVLN=$GET(^DGCR(399.2,+IBRVFN,0))
if IBRVLN=""
QUIT
+8 IF +$PIECE(IBRVLN,U,3)
QUIT
+9 ;
+10 SET IBCNT=IBCNT+1
SET IBACT=IBACT_IBRV_","
+11 SET DR="2////1"
SET DIE="^DGCR(399.2,"
SET DA=+IBRVFN
DO ^DIE
KILL DIE,DIC,DA,DR,X,Y
End DoDot:2
End DoDot:1
+12 ;
+13 IF IBCNT>0
SET IBJ=0
FOR IBI=1:15
SET IBJ=IBJ+15
SET IBLN=$PIECE(IBACT,",",IBI,IBJ)
if IBLN=""
QUIT
DO MSG(" "_IBLN)
+14 ;
RVAQ SET IBA(1)=""
SET IBA(2)=" >> "_IBCNT_" Revenue Codes activated (399.2)..."
DO MSG(" ")
+1 DO MES^XPDUTL(.IBA)
+2 QUIT
+3 ;
+4 ;
MSG(X) ;
+1 NEW IBX
SET IBX=$ORDER(IBA(999999),-1)
if 'IBX
SET IBX=1
SET IBX=IBX+1
+2 SET IBA(IBX)=$GET(X)
+3 QUIT
+4 ;
FRVA ; Revenue Codes to Activate (399.2,2)
+1 ;;160,251,252,255,258,259,260,264,270,271,272,273,275,276,277,278,279,290,292,294,
+2 ;;299,321,329,331,335,343,350,361,369,374,381,382,383,384,389,419,421,424,431,444,
+3 ;;472,483,513,516,519,530,531,540,541,542,544,545,549,551,552,560,561,570,571,580,
+4 ;;581,589,601,614,618,634,640,649,651,660,720,732,760,820,821,822,823,825,831,835,
+5 ;;881,903,923,929,940,942,963,974,975,987,
+6 ;;
