- 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 Feb 19, 2025@00:03:03 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