- IB20P561 ;ALB/CXW - IB*2.0*561 POST INIT: REVENUE CODE FOR MS-DRGS; 03-03-2016
- ;;2.0;INTEGRATED BILLING;**561**;21-MAR-94;Build 36
- ;;Per VA Directive 6402, this routine should not be modified.
- Q
- ;
- POST ;
- N IBA,IBDT317,IBDT318 S U="^"
- D MSG(" Revenue Code 124 for Mental Health Diagnosis Post-Install .....")
- ; effective date of RC v3.17 or RC v3.18
- S IBDT317=3151001,IBDT318=3160101
- D RVDRG(IBDT317,IBDT318)
- D MSG(" Revenue Code 124 for Mental Health Diagnosis Post-Install Complete")
- Q
- ;
- ;
- RVDRG(IBDT317,IBDT318) ; default rvc to 124 for DRGs in Reasonable Charges (#363.2)
- ;
- N IB561,IBCNT,IBCNO,IBRVC,IBCS,IBCS0,IBBR0,IBDRGC,IBDRGF,IBXRF,IBITM,IBNEF,IBCI,IBCI0,IBCIA
- N DA,DIE,DR,DT,X,X1,X2,Y
- S (IBCNO,IBCNT)=0,IB561="IB20P561"
- ;
- ; charge items for drgs store in xtmp for 30 days for tracking purpose
- ; xtmp(name,0)=purge dt_U_today dt_U_patch#_U_total update_U_total rec.
- ; xtmp(name,charge set ien,charge item ien)=charge item before update
- K ^XTMP(IB561)
- S DT=$$DT^XLFDT,X1=DT,X2=30 D C^%DTC
- S ^XTMP(IB561,0)=X_U_DT_U_"IB*2.0*561 POST-INIT"
- ;
- D MSG("")
- D MSG(" >> Adding 124 for MH DRGs on 1-OCT-15 or 1-JAN-16: 881, 882, 883, 885 & 886...")
- S IBRVC=$O(^DGCR(399.2,"B",124,0))
- I 'IBRVC D MSG(" ** Error: Revenue Code 124 undefined, not added") G RVDRGQ
- ;
- S IBCS=0 F S IBCS=$O(^IBE(363.1,IBCS)) Q:'IBCS D
- . S IBCS0=$G(^IBE(363.1,IBCS,0)) Q:IBCS0=""
- . S IBBR0=$G(^IBE(363.3,+$P(IBCS0,U,2),0)) I IBBR0'["RC INPATIENT" Q
- . ;
- . S IBXRF="AIVDTS"_IBCS
- . S IBITM=0 F S IBITM=$O(^IBA(363.2,IBXRF,IBITM)) Q:'IBITM D
- .. S IBNEF="" F S IBNEF=$O(^IBA(363.2,IBXRF,IBITM,IBNEF)) Q:IBNEF="" I (IBNEF=-IBDT317)!(IBNEF=-IBDT318) D
- ... S IBCI=0 F S IBCI=$O(^IBA(363.2,IBXRF,IBITM,IBNEF,IBCI)) Q:'IBCI D
- .... S IBCIA=$G(^IBA(363.2,IBCI,0)) Q:IBCIA=""
- .... S IBCI0=$P(IBCIA,U,1)
- .... S IBDRGC=$P(IBCI0,";",1)
- .... S IBDRGF=$P(IBCI0,";",2) Q:IBDRGF'="ICD("
- .... I '$F("^881^882^883^885^886^",(U_IBDRGC_U)) Q
- .... S ^XTMP(IB561,IBCS,+IBCI)=IBCIA
- .... S IBCNO=IBCNO+1
- .... I $P(IBCIA,U,6)=IBRVC Q
- .... ;
- .... S DIE="^IBA(363.2,",DA=+IBCI
- .... S DR=".06///"_IBRVC D ^DIE K DIE,DA,DR,X,Y
- .... S IBCNT=IBCNT+1
- ;
- RVDRGQ S $P(^XTMP(IB561,0),U,4)=IBCNT_U_IBCNO
- D MSG(" Done. "_IBCNT_" existing inpatient charge items updated (#363.2)")
- D MSG("")
- Q
- ;
- ;
- MSG(IBA) ;
- D MES^XPDUTL(IBA)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P561 2402 printed Mar 13, 2025@21:08:30 Page 2
- IB20P561 ;ALB/CXW - IB*2.0*561 POST INIT: REVENUE CODE FOR MS-DRGS; 03-03-2016
- +1 ;;2.0;INTEGRATED BILLING;**561**;21-MAR-94;Build 36
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 QUIT
- +4 ;
- POST ;
- +1 NEW IBA,IBDT317,IBDT318
- SET U="^"
- +2 DO MSG(" Revenue Code 124 for Mental Health Diagnosis Post-Install .....")
- +3 ; effective date of RC v3.17 or RC v3.18
- +4 SET IBDT317=3151001
- SET IBDT318=3160101
- +5 DO RVDRG(IBDT317,IBDT318)
- +6 DO MSG(" Revenue Code 124 for Mental Health Diagnosis Post-Install Complete")
- +7 QUIT
- +8 ;
- +9 ;
- RVDRG(IBDT317,IBDT318) ; default rvc to 124 for DRGs in Reasonable Charges (#363.2)
- +1 ;
- +2 NEW IB561,IBCNT,IBCNO,IBRVC,IBCS,IBCS0,IBBR0,IBDRGC,IBDRGF,IBXRF,IBITM,IBNEF,IBCI,IBCI0,IBCIA
- +3 NEW DA,DIE,DR,DT,X,X1,X2,Y
- +4 SET (IBCNO,IBCNT)=0
- SET IB561="IB20P561"
- +5 ;
- +6 ; charge items for drgs store in xtmp for 30 days for tracking purpose
- +7 ; xtmp(name,0)=purge dt_U_today dt_U_patch#_U_total update_U_total rec.
- +8 ; xtmp(name,charge set ien,charge item ien)=charge item before update
- +9 KILL ^XTMP(IB561)
- +10 SET DT=$$DT^XLFDT
- SET X1=DT
- SET X2=30
- DO C^%DTC
- +11 SET ^XTMP(IB561,0)=X_U_DT_U_"IB*2.0*561 POST-INIT"
- +12 ;
- +13 DO MSG("")
- +14 DO MSG(" >> Adding 124 for MH DRGs on 1-OCT-15 or 1-JAN-16: 881, 882, 883, 885 & 886...")
- +15 SET IBRVC=$ORDER(^DGCR(399.2,"B",124,0))
- +16 IF 'IBRVC
- DO MSG(" ** Error: Revenue Code 124 undefined, not added")
- GOTO RVDRGQ
- +17 ;
- +18 SET IBCS=0
- FOR
- SET IBCS=$ORDER(^IBE(363.1,IBCS))
- if 'IBCS
- QUIT
- Begin DoDot:1
- +19 SET IBCS0=$GET(^IBE(363.1,IBCS,0))
- if IBCS0=""
- QUIT
- +20 SET IBBR0=$GET(^IBE(363.3,+$PIECE(IBCS0,U,2),0))
- IF IBBR0'["RC INPATIENT"
- QUIT
- +21 ;
- +22 SET IBXRF="AIVDTS"_IBCS
- +23 SET IBITM=0
- FOR
- SET IBITM=$ORDER(^IBA(363.2,IBXRF,IBITM))
- if 'IBITM
- QUIT
- Begin DoDot:2
- +24 SET IBNEF=""
- FOR
- SET IBNEF=$ORDER(^IBA(363.2,IBXRF,IBITM,IBNEF))
- if IBNEF=""
- QUIT
- IF (IBNEF=-IBDT317)!(IBNEF=-IBDT318)
- Begin DoDot:3
- +25 SET IBCI=0
- FOR
- SET IBCI=$ORDER(^IBA(363.2,IBXRF,IBITM,IBNEF,IBCI))
- if 'IBCI
- QUIT
- Begin DoDot:4
- +26 SET IBCIA=$GET(^IBA(363.2,IBCI,0))
- if IBCIA=""
- QUIT
- +27 SET IBCI0=$PIECE(IBCIA,U,1)
- +28 SET IBDRGC=$PIECE(IBCI0,";",1)
- +29 SET IBDRGF=$PIECE(IBCI0,";",2)
- if IBDRGF'="ICD("
- QUIT
- +30 IF '$FIND("^881^882^883^885^886^",(U_IBDRGC_U))
- QUIT
- +31 SET ^XTMP(IB561,IBCS,+IBCI)=IBCIA
- +32 SET IBCNO=IBCNO+1
- +33 IF $PIECE(IBCIA,U,6)=IBRVC
- QUIT
- +34 ;
- +35 SET DIE="^IBA(363.2,"
- SET DA=+IBCI
- +36 SET DR=".06///"_IBRVC
- DO ^DIE
- KILL DIE,DA,DR,X,Y
- +37 SET IBCNT=IBCNT+1
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +38 ;
- RVDRGQ SET $PIECE(^XTMP(IB561,0),U,4)=IBCNT_U_IBCNO
- +1 DO MSG(" Done. "_IBCNT_" existing inpatient charge items updated (#363.2)")
- +2 DO MSG("")
- +3 QUIT
- +4 ;
- +5 ;
- MSG(IBA) ;
- +1 DO MES^XPDUTL(IBA)
- +2 QUIT
