IBYPPT ;ALB/ARH - IB*2*134 POST INIT: UPDATE PROVIDER DISCOUNT AND REVENUE CODES AND CONDITION CODES ; 05/25/00
;;2.0;INTEGRATED BILLING;**134**;21-MAR-94
;
Q
POST ;
N IBA
S IBA(1)="",IBA(2)=" IB*2*134 Post-Install .....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
;
D CCE ; update condition codes, 1
D CCA ; add condition codes, 2
D RVN ; add revenue codes, 2
;
D PDDEL^IBYPPT1 ; delete all Provider Discount Sets and Links (363.34) for RC PROVIDER DISCOUNTS Special Group
D PDADD^IBYPPT1 ; add new Provider Discount Sets and Links (363.34) for RC PROVIDER DISCOUNTS Special Group
;
S IBA(1)="",IBA(2)=" IB*2*134 Post-Install Complete",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
;
Q
;
;
RVN ; add 2 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),";;",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_" Revenue Codes added (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
;
;
FRVN ; New Revenue Codes
;;951^ATHLETIC TRAINING^ATHLETIC TRAINING
;;952^KINESIOTHERAPY^KINESIOTHERAPY
;;
Q
;
MCCRUTL(X,P) ; returns IFN of item in 399.1 if Code is found and piece P is true
;
N IBX,IBY S IBY=""
I $G(X)'="" S IBX=0 F S IBX=$O(^DGCR(399.1,"C",X,IBX)) Q:'IBX I $P($G(^DGCR(399.1,IBX,0)),U,+$G(P)) S IBY=IBX
Q IBY
;
CCE ; Edit Condition Codes in 399.1 (#.22 - p15) update Name field (.01)
N DINUM,DLAYGO,DIC,DIE,DD,DO,DA,DR,X,Y,IBA,IBI,IBLN,IBCNT,IBJ,IBFN,IBDNM S IBCNT=0
;
F IBI=1:1 S IBLN=$P($T(FCCE+IBI),";;",2) Q:IBLN="" I $E(IBLN,1)'=" " D
. ;
. S IBFN=$$MCCRUTL($P(IBLN,U,1),15) Q:'IBFN
. ;
. S DR=".01////"_$P(IBLN,U,2)
. S DIE="^DGCR(399.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y S IBCNT=IBCNT+1
;
CCEQ S IBA(1)=" >> "_IBCNT_" Condition Codes updated (399.1)"
D MES^XPDUTL(.IBA)
Q
;
CCA ; Add Condition Codes to 399.1 (#.22 - p15)
; due to the conversion the condition codes must have IFNs greater than 79
N DINUM,DLAYGO,DIC,DIE,DD,DO,DA,DR,X,Y,IBA,IBI,IBLN,IBCNT,IBJ,IBFN,IBDNM S IBCNT=0
;
S IBDNM=$O(^DGCR(399.1,200),-1) I IBDNM'>79 S IBDNM=79
;
F IBI=1:1 S IBLN=$P($T(FCCA+IBI),";;",2) Q:IBLN="" I $E(IBLN,1)'=" " D
. ;
. I +$$MCCRUTL($P(IBLN,U,1),15) Q
. ;
. F IBJ=1:1 S IBDNM=IBDNM+1 Q:'$D(^DGCR(399.1,IBDNM,0))
. ;
. K DD,DO S DLAYGO=399.1,DINUM=IBDNM,DIC="^DGCR(399.1,",DIC(0)="L",X=$P(IBLN,U,2) D FILE^DICN K DIC I Y<1 K X,Y Q
. S IBFN=+Y,IBCNT=IBCNT+1
. ;
. S DR=".02////"_$P(IBLN,U,1)_";.22////"_1
. S DIE="^DGCR(399.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
;
CCAQ S IBA(1)=" >> "_IBCNT_" Condition Codes added (399.1)"
D MES^XPDUTL(.IBA)
Q
;
FCCA ; add condition codes (399.1)
;;
;;58^TERMINATED MEDICARE+CHOICE ORGANIZATION ENROLLEE
;;G0^DISTINCT MEDICAL VISIT
;;
FCCE ; edit condition codes (399.1)
;;
;;72^SELF CARE IN UNIT
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYPPT 3439 printed Apr 09, 2024@21:05:32 Page 2
IBYPPT ;ALB/ARH - IB*2*134 POST INIT: UPDATE PROVIDER DISCOUNT AND REVENUE CODES AND CONDITION CODES ; 05/25/00
+1 ;;2.0;INTEGRATED BILLING;**134**;21-MAR-94
+2 ;
+3 QUIT
POST ;
+1 NEW IBA
+2 SET IBA(1)=""
SET IBA(2)=" IB*2*134 Post-Install ....."
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+3 ;
+4 ; update condition codes, 1
DO CCE
+5 ; add condition codes, 2
DO CCA
+6 ; add revenue codes, 2
DO RVN
+7 ;
+8 ; delete all Provider Discount Sets and Links (363.34) for RC PROVIDER DISCOUNTS Special Group
DO PDDEL^IBYPPT1
+9 ; add new Provider Discount Sets and Links (363.34) for RC PROVIDER DISCOUNTS Special Group
DO PDADD^IBYPPT1
+10 ;
+11 SET IBA(1)=""
SET IBA(2)=" IB*2*134 Post-Install Complete"
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+12 ;
+13 QUIT
+14 ;
+15 ;
RVN ; add 2 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),";;",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_" Revenue Codes added (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 ;
+5 ;
FRVN ; New Revenue Codes
+1 ;;951^ATHLETIC TRAINING^ATHLETIC TRAINING
+2 ;;952^KINESIOTHERAPY^KINESIOTHERAPY
+3 ;;
+4 QUIT
+5 ;
MCCRUTL(X,P) ; returns IFN of item in 399.1 if Code is found and piece P is true
+1 ;
+2 NEW IBX,IBY
SET IBY=""
+3 IF $GET(X)'=""
SET IBX=0
FOR
SET IBX=$ORDER(^DGCR(399.1,"C",X,IBX))
if 'IBX
QUIT
IF $PIECE($GET(^DGCR(399.1,IBX,0)),U,+$GET(P))
SET IBY=IBX
+4 QUIT IBY
+5 ;
CCE ; Edit Condition Codes in 399.1 (#.22 - p15) update Name field (.01)
+1 NEW DINUM,DLAYGO,DIC,DIE,DD,DO,DA,DR,X,Y,IBA,IBI,IBLN,IBCNT,IBJ,IBFN,IBDNM
SET IBCNT=0
+2 ;
+3 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(FCCE+IBI),";;",2)
if IBLN=""
QUIT
IF $EXTRACT(IBLN,1)'=" "
Begin DoDot:1
+4 ;
+5 SET IBFN=$$MCCRUTL($PIECE(IBLN,U,1),15)
if 'IBFN
QUIT
+6 ;
+7 SET DR=".01////"_$PIECE(IBLN,U,2)
+8 SET DIE="^DGCR(399.1,"
SET DA=+IBFN
DO ^DIE
KILL DIE,DA,DR,X,Y
SET IBCNT=IBCNT+1
End DoDot:1
+9 ;
CCEQ SET IBA(1)=" >> "_IBCNT_" Condition Codes updated (399.1)"
+1 DO MES^XPDUTL(.IBA)
+2 QUIT
+3 ;
CCA ; Add Condition Codes to 399.1 (#.22 - p15)
+1 ; due to the conversion the condition codes must have IFNs greater than 79
+2 NEW DINUM,DLAYGO,DIC,DIE,DD,DO,DA,DR,X,Y,IBA,IBI,IBLN,IBCNT,IBJ,IBFN,IBDNM
SET IBCNT=0
+3 ;
+4 SET IBDNM=$ORDER(^DGCR(399.1,200),-1)
IF IBDNM'>79
SET IBDNM=79
+5 ;
+6 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(FCCA+IBI),";;",2)
if IBLN=""
QUIT
IF $EXTRACT(IBLN,1)'=" "
Begin DoDot:1
+7 ;
+8 IF +$$MCCRUTL($PIECE(IBLN,U,1),15)
QUIT
+9 ;
+10 FOR IBJ=1:1
SET IBDNM=IBDNM+1
if '$DATA(^DGCR(399.1,IBDNM,0))
QUIT
+11 ;
+12 KILL DD,DO
SET DLAYGO=399.1
SET DINUM=IBDNM
SET DIC="^DGCR(399.1,"
SET DIC(0)="L"
SET X=$PIECE(IBLN,U,2)
DO FILE^DICN
KILL DIC
IF Y<1
KILL X,Y
QUIT
+13 SET IBFN=+Y
SET IBCNT=IBCNT+1
+14 ;
+15 SET DR=".02////"_$PIECE(IBLN,U,1)_";.22////"_1
+16 SET DIE="^DGCR(399.1,"
SET DA=+IBFN
DO ^DIE
KILL DIE,DA,DR,X,Y
End DoDot:1
+17 ;
CCAQ SET IBA(1)=" >> "_IBCNT_" Condition Codes added (399.1)"
+1 DO MES^XPDUTL(.IBA)
+2 QUIT
+3 ;
FCCA ; add condition codes (399.1)
+1 ;;
+2 ;;58^TERMINATED MEDICARE+CHOICE ORGANIZATION ENROLLEE
+3 ;;G0^DISTINCT MEDICAL VISIT
+4 ;;
FCCE ; edit condition codes (399.1)
+1 ;;
+2 ;;72^SELF CARE IN UNIT
+3 ;;
