IBYPPS ;ALB/ARH - IB*2*119 POST INIT: UPDATE REVENUE CODES AND LINKS ; 09/07/99
;;2.0;INTEGRATED BILLING;**119**;21-MAR-94
;
Q
POST ;
N IBA
S IBA(1)="",IBA(2)=" IB*2*119 Post-Install .....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
;
D RVN ; new revenue codes, 38
D RVU ; update revenue codes, 50
D RVI ; inactivate revenue codes, 10
D RVA ; activate revenue codes, 3
D RVL ; add new revenue code - CPT links, 1
;
S IBA(1)="",IBA(2)=" IB*2*119 Post-Install Complete",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
;
Q
;
RVA ; activate 3 Revenue Codes exported in RV-CPT links (399.2,2), if currently inactive
; (771 and 904 links exported with RC patch but rv not activated because was not defined)
N IBA,IBLN,IBI,IBRV,IBRVFN,IBRVLN,IBCNG,IBCNT,IBJ,DD,DO,DIC,DIE,DA,DR,X,Y S IBCNT=0,IBCNG=""
;
S IBLN=$P($T(FRVA+1^IBYPPS1),";;",2)
;
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,IBCNG=IBCNG_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(IBCNG,",",IBI,IBJ) Q:IBLN="" D MSG(" "_IBLN)
;
RVAQ S IBA(1)=" >> "_IBCNT_" Revenue Codes activated (399.2)..." D MSG(" ")
D MES^XPDUTL(.IBA)
Q
;
RVI ; inactivate 10 Revenue Codes (399.2,2)
; (no longer valid revenue codes according to NUBC)
N IBA,IBLN,IBI,IBRV,IBRVFN,IBRVLN,IBCNG,IBCNT,IBJ,DD,DO,DIC,DIE,DA,DR,X,Y S IBCNT=0,IBCNG=""
;
F IBI=1:1 S IBLN=$P($T(FRVI+IBI^IBYPPS1),";;",2) Q:IBLN="" D
. ;
. S IBRV=$P(IBLN,U,1) Q:IBRV'?3N
. ;
. S IBRVFN=$O(^DGCR(399.2,"B",IBRV,0)) Q:'IBRVFN
. S IBRVLN=$G(^DGCR(399.2,+IBRVFN,0)) Q:IBRVLN=""
. ;
. S IBCNT=IBCNT+1,IBCNG=IBCNG_IBRV_","
. S DR="2////0",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(IBCNG,",",IBI,IBJ) Q:IBLN="" D MSG(" "_IBLN)
;
RVIQ S IBA(1)=" >> "_IBCNT_" Revenue Codes inactivated (399.2)..." D MSG(" ")
D MES^XPDUTL(.IBA)
Q
;
RVU ; update 50 Revenue Codes (399.2)
; (update abbreviation and description to match current NUBC, previously different definitions)
N IBA,IBLN,IBI,IBRV,IBRVFN,IBCNG,IBCNT,IBJ,DD,DO,DIC,DIE,DA,DR,X,Y S IBCNT=0,IBCNG=""
;
F IBI=1:1 S IBLN=$P($T(FRVU+IBI^IBYPPS1),";;",2,999) Q:IBLN="" D
. ;
. S IBRV=$P(IBLN,U,1) Q:IBRV'?3N
. S IBRVFN=$O(^DGCR(399.2,"B",IBRV,0)) Q:'IBRVFN
. ;
. S IBCNT=IBCNT+1,IBCNG=IBCNG_IBRV_","
. S DR="1///"_$P(IBLN,U,2)_";3///"_$P(IBLN,U,3),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(IBCNG,",",IBI,IBJ) Q:IBLN="" D MSG(" "_IBLN)
;
RVUQ S IBA(1)=" >> "_IBCNT_" Revenue Codes updated (399.2)..." D MSG(" ")
D MES^XPDUTL(.IBA)
Q
;
RVN ; add 38 new Revenue Codes (399.2)
; (update abbreviation and description to match current NUBC, previously all reserved)
N IBA,IBLN,IBI,IBRV,IBRVFN,IBCNG,IBCNT,IBJ,DD,DO,DIC,DIE,DA,DR,X,Y S IBCNT=0,IBCNG=""
;
F IBI=1:1 S IBLN=$P($T(FRVN+IBI^IBYPPS1),";;",2,999) Q:IBLN="" D
. ;
. S IBRV=$P(IBLN,U,1) Q:IBRV'?3N
. S IBRVFN=$O(^DGCR(399.2,"B",IBRV,0)) Q:'IBRVFN
. ;
. S IBCNT=IBCNT+1,IBCNG=IBCNG_IBRV_","
. S DR="1///"_$P(IBLN,U,2)_";3///"_$P(IBLN,U,3),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(IBCNG,",",IBI,IBJ) Q:IBLN="" D MSG(" "_IBLN)
;
RVNQ S IBA(1)=" >> "_IBCNT_" New Revenue Codes added (399.2)..." D MSG(" ")
D MES^XPDUTL(.IBA)
Q
;
RVL ; add 4 Revenue Codes - CPT links for observation care (363.33)
N IBA,IBLN,IBI,IBSGFN,IBRV,IBRVFN,IBRVLN,IBLINK,IBP1,IBP2,IBCNT,DD,DO,DIC,DIE,DA,DR,X,Y,DLAYGO S IBCNT=0
;
S IBSGFN=$O(^IBE(363.32,"B","STANDARD RVCD LINKS",0)) I 'IBSGFN D MSG(" ** STANDARD RVCD LINKS Special Group not found, no links added.")
;
I +IBSGFN F IBI=1:1 S IBLN=$P($T(FRVL+IBI^IBYPPS1),";;",2,999) Q:IBLN="" D
. ;
. S IBRV=$P(IBLN,U,1) Q:IBRV'?3N
. S IBLINK=IBRV_": "_$P(IBLN,U,2)_$S($P(IBLN,U,3)'="":"-",1:"")_$P(IBLN,U,3)
. ;
. 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,2)["*RESERVED" Q
. ;
. Q:$P(IBLN,U,2)=""
. S IBP1=$O(^ICPT("B",$P(IBLN,U,2),0)) Q:'IBP1
. S IBP2="" I $P(IBLN,U,3)'="" S IBP2=$O(^ICPT("B",$P(IBLN,U,3),0)) Q:'IBP2
. ;
. I $O(^IBE(363.33,"AGP",IBSGFN,IBP1,0)) D MSG(" ** "_IBLINK_", not added, a link already exists for "_$P(IBLN,U,2)) Q
. ;
. S IBCNT=IBCNT+1
. S DIC("DR")=".02////"_+IBSGFN_";.03////"_+IBP1 I +IBP2 S DIC("DR")=DIC("DR")_";.04////"_+IBP2
. K DD,DO S DLAYGO=363.33,DIC="^IBE(363.33,",DIC(0)="L",X=+IBRVFN D FILE^DICN K DIC,X,Y
. ;
. D MSG(" "_IBLINK_" added")
;
RVLQ S IBA(1)=" >> "_IBCNT_" New Revenue Code - CPT Links added (363.33)..." 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYPPS 5137 printed Dec 13, 2024@02:36:33 Page 2
IBYPPS ;ALB/ARH - IB*2*119 POST INIT: UPDATE REVENUE CODES AND LINKS ; 09/07/99
+1 ;;2.0;INTEGRATED BILLING;**119**;21-MAR-94
+2 ;
+3 QUIT
POST ;
+1 NEW IBA
+2 SET IBA(1)=""
SET IBA(2)=" IB*2*119 Post-Install ....."
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+3 ;
+4 ; new revenue codes, 38
DO RVN
+5 ; update revenue codes, 50
DO RVU
+6 ; inactivate revenue codes, 10
DO RVI
+7 ; activate revenue codes, 3
DO RVA
+8 ; add new revenue code - CPT links, 1
DO RVL
+9 ;
+10 SET IBA(1)=""
SET IBA(2)=" IB*2*119 Post-Install Complete"
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+11 ;
+12 QUIT
+13 ;
RVA ; activate 3 Revenue Codes exported in RV-CPT links (399.2,2), if currently inactive
+1 ; (771 and 904 links exported with RC patch but rv not activated because was not defined)
+2 NEW IBA,IBLN,IBI,IBRV,IBRVFN,IBRVLN,IBCNG,IBCNT,IBJ,DD,DO,DIC,DIE,DA,DR,X,Y
SET IBCNT=0
SET IBCNG=""
+3 ;
+4 SET IBLN=$PIECE($TEXT(FRVA+1^IBYPPS1),";;",2)
+5 ;
+6 FOR IBI=1:1
SET IBRV=$PIECE(IBLN,",",IBI)
if IBRV'?3N
QUIT
Begin DoDot:1
+7 ;
+8 SET IBRVFN=$ORDER(^DGCR(399.2,"B",IBRV,0))
if 'IBRVFN
QUIT
+9 SET IBRVLN=$GET(^DGCR(399.2,+IBRVFN,0))
if IBRVLN=""
QUIT
+10 IF +$PIECE(IBRVLN,U,3)
QUIT
+11 ;
+12 SET IBCNT=IBCNT+1
SET IBCNG=IBCNG_IBRV_","
+13 SET DR="2////1"
SET DIE="^DGCR(399.2,"
SET DA=+IBRVFN
DO ^DIE
KILL DIE,DIC,DA,DR,X,Y
End DoDot:1
+14 ;
+15 IF IBCNT>0
SET IBJ=0
FOR IBI=1:15
SET IBJ=IBJ+15
SET IBLN=$PIECE(IBCNG,",",IBI,IBJ)
if IBLN=""
QUIT
DO MSG(" "_IBLN)
+16 ;
RVAQ SET IBA(1)=" >> "_IBCNT_" Revenue Codes activated (399.2)..."
DO MSG(" ")
+1 DO MES^XPDUTL(.IBA)
+2 QUIT
+3 ;
RVI ; inactivate 10 Revenue Codes (399.2,2)
+1 ; (no longer valid revenue codes according to NUBC)
+2 NEW IBA,IBLN,IBI,IBRV,IBRVFN,IBRVLN,IBCNG,IBCNT,IBJ,DD,DO,DIC,DIE,DA,DR,X,Y
SET IBCNT=0
SET IBCNG=""
+3 ;
+4 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(FRVI+IBI^IBYPPS1),";;",2)
if IBLN=""
QUIT
Begin DoDot:1
+5 ;
+6 SET IBRV=$PIECE(IBLN,U,1)
if IBRV'?3N
QUIT
+7 ;
+8 SET IBRVFN=$ORDER(^DGCR(399.2,"B",IBRV,0))
if 'IBRVFN
QUIT
+9 SET IBRVLN=$GET(^DGCR(399.2,+IBRVFN,0))
if IBRVLN=""
QUIT
+10 ;
+11 SET IBCNT=IBCNT+1
SET IBCNG=IBCNG_IBRV_","
+12 SET DR="2////0"
SET DIE="^DGCR(399.2,"
SET DA=+IBRVFN
DO ^DIE
KILL DIE,DIC,DA,DR,X,Y
End DoDot:1
+13 ;
+14 IF IBCNT>0
SET IBJ=0
FOR IBI=1:15
SET IBJ=IBJ+15
SET IBLN=$PIECE(IBCNG,",",IBI,IBJ)
if IBLN=""
QUIT
DO MSG(" "_IBLN)
+15 ;
RVIQ SET IBA(1)=" >> "_IBCNT_" Revenue Codes inactivated (399.2)..."
DO MSG(" ")
+1 DO MES^XPDUTL(.IBA)
+2 QUIT
+3 ;
RVU ; update 50 Revenue Codes (399.2)
+1 ; (update abbreviation and description to match current NUBC, previously different definitions)
+2 NEW IBA,IBLN,IBI,IBRV,IBRVFN,IBCNG,IBCNT,IBJ,DD,DO,DIC,DIE,DA,DR,X,Y
SET IBCNT=0
SET IBCNG=""
+3 ;
+4 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(FRVU+IBI^IBYPPS1),";;",2,999)
if IBLN=""
QUIT
Begin DoDot:1
+5 ;
+6 SET IBRV=$PIECE(IBLN,U,1)
if IBRV'?3N
QUIT
+7 SET IBRVFN=$ORDER(^DGCR(399.2,"B",IBRV,0))
if 'IBRVFN
QUIT
+8 ;
+9 SET IBCNT=IBCNT+1
SET IBCNG=IBCNG_IBRV_","
+10 SET DR="1///"_$PIECE(IBLN,U,2)_";3///"_$PIECE(IBLN,U,3)
SET DIE="^DGCR(399.2,"
SET DA=+IBRVFN
DO ^DIE
KILL DIE,DIC,DA,DR,X,Y
End DoDot:1
+11 ;
+12 IF IBCNT>0
SET IBJ=0
FOR IBI=1:15
SET IBJ=IBJ+15
SET IBLN=$PIECE(IBCNG,",",IBI,IBJ)
if IBLN=""
QUIT
DO MSG(" "_IBLN)
+13 ;
RVUQ SET IBA(1)=" >> "_IBCNT_" Revenue Codes updated (399.2)..."
DO MSG(" ")
+1 DO MES^XPDUTL(.IBA)
+2 QUIT
+3 ;
RVN ; add 38 new Revenue Codes (399.2)
+1 ; (update abbreviation and description to match current NUBC, previously all reserved)
+2 NEW IBA,IBLN,IBI,IBRV,IBRVFN,IBCNG,IBCNT,IBJ,DD,DO,DIC,DIE,DA,DR,X,Y
SET IBCNT=0
SET IBCNG=""
+3 ;
+4 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(FRVN+IBI^IBYPPS1),";;",2,999)
if IBLN=""
QUIT
Begin DoDot:1
+5 ;
+6 SET IBRV=$PIECE(IBLN,U,1)
if IBRV'?3N
QUIT
+7 SET IBRVFN=$ORDER(^DGCR(399.2,"B",IBRV,0))
if 'IBRVFN
QUIT
+8 ;
+9 SET IBCNT=IBCNT+1
SET IBCNG=IBCNG_IBRV_","
+10 SET DR="1///"_$PIECE(IBLN,U,2)_";3///"_$PIECE(IBLN,U,3)
SET DIE="^DGCR(399.2,"
SET DA=+IBRVFN
DO ^DIE
KILL DIE,DIC,DA,DR,X,Y
End DoDot:1
+11 ;
+12 IF IBCNT>0
SET IBJ=0
FOR IBI=1:15
SET IBJ=IBJ+15
SET IBLN=$PIECE(IBCNG,",",IBI,IBJ)
if IBLN=""
QUIT
DO MSG(" "_IBLN)
+13 ;
RVNQ SET IBA(1)=" >> "_IBCNT_" New Revenue Codes added (399.2)..."
DO MSG(" ")
+1 DO MES^XPDUTL(.IBA)
+2 QUIT
+3 ;
RVL ; add 4 Revenue Codes - CPT links for observation care (363.33)
+1 NEW IBA,IBLN,IBI,IBSGFN,IBRV,IBRVFN,IBRVLN,IBLINK,IBP1,IBP2,IBCNT,DD,DO,DIC,DIE,DA,DR,X,Y,DLAYGO
SET IBCNT=0
+2 ;
+3 SET IBSGFN=$ORDER(^IBE(363.32,"B","STANDARD RVCD LINKS",0))
IF 'IBSGFN
DO MSG(" ** STANDARD RVCD LINKS Special Group not found, no links added.")
+4 ;
+5 IF +IBSGFN
FOR IBI=1:1
SET IBLN=$PIECE($TEXT(FRVL+IBI^IBYPPS1),";;",2,999)
if IBLN=""
QUIT
Begin DoDot:1
+6 ;
+7 SET IBRV=$PIECE(IBLN,U,1)
if IBRV'?3N
QUIT
+8 SET IBLINK=IBRV_": "_$PIECE(IBLN,U,2)_$SELECT($PIECE(IBLN,U,3)'="":"-",1:"")_$PIECE(IBLN,U,3)
+9 ;
+10 SET IBRVFN=$ORDER(^DGCR(399.2,"B",IBRV,0))
if 'IBRVFN
QUIT
+11 SET IBRVLN=$GET(^DGCR(399.2,+IBRVFN,0))
if IBRVLN=""
QUIT
+12 IF $PIECE(IBRVLN,U,2)["*RESERVED"
QUIT
+13 ;
+14 if $PIECE(IBLN,U,2)=""
QUIT
+15 SET IBP1=$ORDER(^ICPT("B",$PIECE(IBLN,U,2),0))
if 'IBP1
QUIT
+16 SET IBP2=""
IF $PIECE(IBLN,U,3)'=""
SET IBP2=$ORDER(^ICPT("B",$PIECE(IBLN,U,3),0))
if 'IBP2
QUIT
+17 ;
+18 IF $ORDER(^IBE(363.33,"AGP",IBSGFN,IBP1,0))
DO MSG(" ** "_IBLINK_", not added, a link already exists for "_$PIECE(IBLN,U,2))
QUIT
+19 ;
+20 SET IBCNT=IBCNT+1
+21 SET DIC("DR")=".02////"_+IBSGFN_";.03////"_+IBP1
IF +IBP2
SET DIC("DR")=DIC("DR")_";.04////"_+IBP2
+22 KILL DD,DO
SET DLAYGO=363.33
SET DIC="^IBE(363.33,"
SET DIC(0)="L"
SET X=+IBRVFN
DO FILE^DICN
KILL DIC,X,Y
+23 ;
+24 DO MSG(" "_IBLINK_" added")
End DoDot:1
+25 ;
RVLQ SET IBA(1)=" >> "_IBCNT_" New Revenue Code - CPT Links added (363.33)..."
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
