IBY399P1 ;ALB/ARH - IB*2*399 POST-INSTALL - RNB UPDATE ; 16-OCT-2008
;;2.0;INTEGRATED BILLING;**399**;21-MAR-94;Build 8
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; Update and Add to Reasons Not Billable List (356.8)
; This is the post-init routine to update the Reasons Not Billable, it checks that all standard RNBs exist,
; inactivates all non-standard RNBs and some selected standard RNBs, updates some ECME flags,
; adds the Code field to existing RNBs and adds many new RNBs with their related Code and ECME flags
;
Q
;
RNB ; Update and Add to Reasons Not Billable (356.8)
;
D OLDCHK ; check that all standard RNBs exist (39)
D NONSTD ; inactivate all existing non-standard RNBs
;
D INAC ; inactivate existing RNBs (5)
D ECME ; update ECME Paper Flag on existing RNBs (2)
D CODE ; add Code field data to existing RNBs (33)
D NEWR ; add new RNBs (51)
Q
;
OLDCHK ; check that standard RNB's exist on the site's system (set INCLUDE to check old and new RNBs)
N IBI,IBLN,IBNM,IBTOT,IBTNF S (IBTOT,IBTNF)=0
;
D MSG(" "),MSG("Check for the 39 Standard Reasons Not Billable (#356.8)...",1)
;
F IBI=1:1 S IBLN=$P($T(RNB+IBI^IBY399P2),";;",2,999) Q:IBLN="" I +IBLN D
. S IBNM=$P(IBLN,U,6) I $P(IBLN,U,2)="NEW",'$G(INCLUDE) Q
. ;
. S IBTOT=IBTOT+1 I '$O(^IBE(356.8,"B",IBNM,0)) S IBTNF=IBTNF+1 D MSG(IBNM_" not found")
;
I 'IBTNF D MSG("No Errors: All "_IBTOT_" Standard RNBs Found",2)
I +IBTNF D MSG("ERRORS Found: "_IBTNF_" of "_IBTOT_" Standard RNBs Not Found",2)
Q
;
NONSTD ; check site for any active Non-Standard RNB's and Inactivate them (356.8, .05)
N IBI,IBLN,IBNM,RNBS,IBRNB0,IBTOT,IBTCH S (IBTOT,IBTCH)=0
;
D MSG("Inactivate Any Active Non-Standard Reasons Not Billable (#356.8,.05)...",1)
;
; get list of all standard RNB's
F IBI=1:1 S IBLN=$P($T(RNB+IBI^IBY399P2),";;",2,999) Q:IBLN="" S IBNM=$P(IBLN,U,6) I IBNM'="" S RNBS(IBNM)=""
;
; compare standard RNB's with sites RNB's, inactivate any non-standard
S IBI=0 F S IBI=$O(^IBE(356.8,IBI)) Q:'IBI D
. S IBRNB0=$G(^IBE(356.8,IBI,0)),IBNM=$P(IBRNB0,U,1) I +$P(IBRNB0,U,5) Q
. ;
. S IBTOT=IBTOT+1 I $D(RNBS(IBNM)) Q
. S IBTCH=IBTCH+1 D MSG(IBNM_" not standard and has been inactivated") D EDIT(IBI,".02////@;.03////@;.05////1")
;
I 'IBTCH D MSG("No Change: No Active Non-Standard RNBs Found",2)
I +IBTCH D MSG("Updated: "_IBTCH_" of "_IBTOT_" Active Non-Standard RNBs Found and Inactivated",2)
Q
;
INAC ; Inactivate existing standard RNB's (356.8, .05) also remove ECME flags (356.8, .02, .03)
N IBI,IBLN,IBNM,IBRNB,IBRNB0,IBTOT,IBTNC,IBTNF,IBTCH S (IBTOT,IBTNC,IBTNF,IBTCH)=0
;
D MSG("Inactivate 5 Active Standard Reasons Not Billable (#356.8,.05)...",1)
;
F IBI=1:1 S IBLN=$P($T(INA+IBI^IBY399P2),";;",2,999) Q:'IBLN I $P(IBLN,U,2)="INA" D
. S IBNM=$P(IBLN,U,6) S IBRNB=$O(^IBE(356.8,"B",IBNM,0)),IBRNB0=$G(^IBE(356.8,+IBRNB,0))
. ;
. S IBTOT=IBTOT+1 I +$P(IBRNB0,U,5) S IBTNC=IBTNC+1 Q
. I 'IBRNB S IBTNF=IBTNF+1 D MSG(IBNM_" not found") Q
. S IBTCH=IBTCH+1 D MSG(IBNM_" has been inactivated") D EDIT(IBRNB,".02////@;.03////@;.05////1")
;
I 'IBTCH D MSG("No Change: "_IBTNC_" of "_IBTOT_" RNBs Already Inactive"_$$LN(IBTNF,"Not Found"),2)
I +IBTCH D MSG("Updated: "_IBTCH_" of "_IBTOT_" RNBs Inactivated"_$$LN(IBTNC,"Already Inactive")_$$LN(IBTNF,"Not Found"),2)
Q
;
ECME ; Reset ECME flags (356.8, .03)
N IBI,IBLN,IBNM,IBRNB,IBRNB0,IBTOT,IBTNC,IBTNF,IBTCH S (IBTOT,IBTNC,IBTNF,IBTCH)=0
;
D MSG("Reset 2 Reason Not Billable ECME Paper Flags (#356.8,.03)...",1)
;
F IBI=1:1 S IBLN=$P($T(OLD+IBI^IBY399P2),";;",2,999) Q:'IBLN I $P(IBLN,U,2)="OLD",$P(IBLN,U,5)'="" D
. S IBNM=$P(IBLN,U,6) S IBRNB=$O(^IBE(356.8,"B",IBNM,0)),IBRNB0=$G(^IBE(356.8,+IBRNB,0))
. ;
. S IBTOT=IBTOT+1 I $P(IBRNB0,U,3)=$P(IBLN,U,5) S IBTNC=IBTNC+1 Q
. I 'IBRNB S IBTNF=IBTNF+1 D MSG(IBNM_" not found") Q
. S IBTCH=IBTCH+1 D MSG(IBNM_" ECME Paper Flag to "_$$YN($P(IBLN,U,5))) D EDIT(IBRNB,".03////"_+$P(IBLN,U,5))
;
I 'IBTCH D MSG("No Change: "_IBTNC_" of "_IBTOT_" RNB ECME Paper Flags Already Reset"_$$LN(IBTNF,"Not Found"),2)
I +IBTCH D MSG("Updated: "_IBTCH_" of "_IBTOT_" RNB ECME Paper Flags Reset"_$$LN(IBTNC,"Already Reset")_$$LN(IBTNF,"Not Found"),2)
Q
;
;
CODE ; Set Code on Existing RNB's (356.8,.04)
N IBI,IBLN,IBNM,IBRNB,IBRNB0,IBTOT,IBTNC,IBTNF,IBTCH S (IBTOT,IBTNC,IBTNF,IBTCH)=0
;
D MSG("Add Code to 33 Existing RNBs (#356.8,.04)...",1)
;
F IBI=1:1 S IBLN=$P($T(OLD+IBI^IBY399P2),";;",2,999) Q:'IBLN I $P(IBLN,U,2)="OLD",$P(IBLN,U,3)'="" D
. S IBNM=$P(IBLN,U,6) S IBRNB=$O(^IBE(356.8,"B",IBNM,0)),IBRNB0=$G(^IBE(356.8,+IBRNB,0))
. ;
. S IBTOT=IBTOT+1 I $P(IBRNB0,U,4)=$P(IBLN,U,3) S IBTNC=IBTNC+1 Q
. I 'IBRNB S IBTNF=IBTNF+1 D MSG(IBNM_" not found") Q
. S IBTCH=IBTCH+1 D MSG(IBNM_" code added "_$P(IBLN,U,3)) D EDIT(IBRNB,".04///"_$P(IBLN,U,3))
;
I 'IBTCH D MSG("No Change: "_IBTNC_" of "_IBTOT_" Existing RNB Codes Already Set"_$$LN(IBTNF,"Not Found"),2)
I +IBTCH D MSG("Updated: "_IBTCH_" of "_IBTOT_" RNBs Code Set"_$$LN(IBTNC,"Codes Already Set")_$$LN(IBTNF,"Not Found"),2)
Q
;
;
NEWR ; Add new RNBs (if RNB already exists ensure Code is set)
N IBI,IBJ,IBLN,IBNM,IBRNB,IBRNB0,IBTOT,IBTNC,IBTCH,DIE,DIC,DR,DA,DD,DO,X,Y,DLAYGO,DINUM
S (IBTOT,IBTNC,IBTCH)=0 S DLAYGO=356.8
;
D MSG("Add 58 New Reasons Not Billable (#356.8)...",1)
;
F IBI=1:1 S IBLN=$P($T(NEW+IBI^IBY399P2),";;",2,999) Q:'IBLN I $P(IBLN,U,2)="NEW" D
. S IBNM=$P(IBLN,U,6) S IBRNB=$O(^IBE(356.8,"B",IBNM,0)),IBRNB0=$G(^IBE(356.8,+IBRNB,0))
. F IBJ=39:1 I '$D(^IBE(356.8,IBJ,0)),IBJ'=72,IBJ'=90 Q
. ;
. S IBTOT=IBTOT+1 I +IBRNB S IBTNC=IBTNC+1 D:$P(IBRNB0,U,4)'=$P(IBLN,U,3) EDIT(IBRNB,".04///"_$P(IBLN,U,3)) Q
. ;
. S DIC("DR")=".02////"_$P(IBLN,U,4)_";.03////"_$P(IBLN,U,5)_";.04///"_$P(IBLN,U,3)
. S DIC="^IBE(356.8,",DIC(0)="L",X=IBNM,DINUM=IBJ D FILE^DICN K DIC I 'Y D MSG(IBNM_" Not Added, ERROR ****") Q
. S IBTCH=IBTCH+1 D MSG(IBNM_" added")
;
I 'IBTCH D MSG("No Change: "_IBTNC_" of "_IBTOT_" New RNBs Already Exist",2)
I +IBTCH D MSG("Updated: "_IBTCH_" of "_IBTOT_" New RNBs Added"_$$LN(IBTNC,"Already Exist"),2)
Q
;
;
;
MSG(X,Y) ; set lines into patch install message, X is message, Y is line type (1-header, 2-result line)
N CNT,IBA S CNT=1,IBA(1)=" " I +$G(Y) S CNT=2,IBA(2)=IBA(1) I +$G(Y)=1 S IBA(2)=" >> "
S IBA(CNT)=IBA(CNT)_$G(X) D MES^XPDUTL(.IBA) K IBA
Q
;
LN(NUM,TXT) Q $S('$G(NUM):"",1:", "_$G(NUM)_" "_$G(TXT))
;
YN(X) Q $S(+$G(X):"Yes",1:"No")
;
EDIT(DA,DR) ; edit RNB field
N DIE,DIC,X,Y I +$G(DA),$G(DR)'="" S DIE="^IBE(356.8," D ^DIE K DA,DR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBY399P1 6701 printed Oct 16, 2024@18:34:35 Page 2
IBY399P1 ;ALB/ARH - IB*2*399 POST-INSTALL - RNB UPDATE ; 16-OCT-2008
+1 ;;2.0;INTEGRATED BILLING;**399**;21-MAR-94;Build 8
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Update and Add to Reasons Not Billable List (356.8)
+5 ; This is the post-init routine to update the Reasons Not Billable, it checks that all standard RNBs exist,
+6 ; inactivates all non-standard RNBs and some selected standard RNBs, updates some ECME flags,
+7 ; adds the Code field to existing RNBs and adds many new RNBs with their related Code and ECME flags
+8 ;
+9 QUIT
+10 ;
RNB ; Update and Add to Reasons Not Billable (356.8)
+1 ;
+2 ; check that all standard RNBs exist (39)
DO OLDCHK
+3 ; inactivate all existing non-standard RNBs
DO NONSTD
+4 ;
+5 ; inactivate existing RNBs (5)
DO INAC
+6 ; update ECME Paper Flag on existing RNBs (2)
DO ECME
+7 ; add Code field data to existing RNBs (33)
DO CODE
+8 ; add new RNBs (51)
DO NEWR
+9 QUIT
+10 ;
OLDCHK ; check that standard RNB's exist on the site's system (set INCLUDE to check old and new RNBs)
+1 NEW IBI,IBLN,IBNM,IBTOT,IBTNF
SET (IBTOT,IBTNF)=0
+2 ;
+3 DO MSG(" ")
DO MSG("Check for the 39 Standard Reasons Not Billable (#356.8)...",1)
+4 ;
+5 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(RNB+IBI^IBY399P2),";;",2,999)
if IBLN=""
QUIT
IF +IBLN
Begin DoDot:1
+6 SET IBNM=$PIECE(IBLN,U,6)
IF $PIECE(IBLN,U,2)="NEW"
IF '$GET(INCLUDE)
QUIT
+7 ;
+8 SET IBTOT=IBTOT+1
IF '$ORDER(^IBE(356.8,"B",IBNM,0))
SET IBTNF=IBTNF+1
DO MSG(IBNM_" not found")
End DoDot:1
+9 ;
+10 IF 'IBTNF
DO MSG("No Errors: All "_IBTOT_" Standard RNBs Found",2)
+11 IF +IBTNF
DO MSG("ERRORS Found: "_IBTNF_" of "_IBTOT_" Standard RNBs Not Found",2)
+12 QUIT
+13 ;
NONSTD ; check site for any active Non-Standard RNB's and Inactivate them (356.8, .05)
+1 NEW IBI,IBLN,IBNM,RNBS,IBRNB0,IBTOT,IBTCH
SET (IBTOT,IBTCH)=0
+2 ;
+3 DO MSG("Inactivate Any Active Non-Standard Reasons Not Billable (#356.8,.05)...",1)
+4 ;
+5 ; get list of all standard RNB's
+6 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(RNB+IBI^IBY399P2),";;",2,999)
if IBLN=""
QUIT
SET IBNM=$PIECE(IBLN,U,6)
IF IBNM'=""
SET RNBS(IBNM)=""
+7 ;
+8 ; compare standard RNB's with sites RNB's, inactivate any non-standard
+9 SET IBI=0
FOR
SET IBI=$ORDER(^IBE(356.8,IBI))
if 'IBI
QUIT
Begin DoDot:1
+10 SET IBRNB0=$GET(^IBE(356.8,IBI,0))
SET IBNM=$PIECE(IBRNB0,U,1)
IF +$PIECE(IBRNB0,U,5)
QUIT
+11 ;
+12 SET IBTOT=IBTOT+1
IF $DATA(RNBS(IBNM))
QUIT
+13 SET IBTCH=IBTCH+1
DO MSG(IBNM_" not standard and has been inactivated")
DO EDIT(IBI,".02////@;.03////@;.05////1")
End DoDot:1
+14 ;
+15 IF 'IBTCH
DO MSG("No Change: No Active Non-Standard RNBs Found",2)
+16 IF +IBTCH
DO MSG("Updated: "_IBTCH_" of "_IBTOT_" Active Non-Standard RNBs Found and Inactivated",2)
+17 QUIT
+18 ;
INAC ; Inactivate existing standard RNB's (356.8, .05) also remove ECME flags (356.8, .02, .03)
+1 NEW IBI,IBLN,IBNM,IBRNB,IBRNB0,IBTOT,IBTNC,IBTNF,IBTCH
SET (IBTOT,IBTNC,IBTNF,IBTCH)=0
+2 ;
+3 DO MSG("Inactivate 5 Active Standard Reasons Not Billable (#356.8,.05)...",1)
+4 ;
+5 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(INA+IBI^IBY399P2),";;",2,999)
if 'IBLN
QUIT
IF $PIECE(IBLN,U,2)="INA"
Begin DoDot:1
+6 SET IBNM=$PIECE(IBLN,U,6)
SET IBRNB=$ORDER(^IBE(356.8,"B",IBNM,0))
SET IBRNB0=$GET(^IBE(356.8,+IBRNB,0))
+7 ;
+8 SET IBTOT=IBTOT+1
IF +$PIECE(IBRNB0,U,5)
SET IBTNC=IBTNC+1
QUIT
+9 IF 'IBRNB
SET IBTNF=IBTNF+1
DO MSG(IBNM_" not found")
QUIT
+10 SET IBTCH=IBTCH+1
DO MSG(IBNM_" has been inactivated")
DO EDIT(IBRNB,".02////@;.03////@;.05////1")
End DoDot:1
+11 ;
+12 IF 'IBTCH
DO MSG("No Change: "_IBTNC_" of "_IBTOT_" RNBs Already Inactive"_$$LN(IBTNF,"Not Found"),2)
+13 IF +IBTCH
DO MSG("Updated: "_IBTCH_" of "_IBTOT_" RNBs Inactivated"_$$LN(IBTNC,"Already Inactive")_$$LN(IBTNF,"Not Found"),2)
+14 QUIT
+15 ;
ECME ; Reset ECME flags (356.8, .03)
+1 NEW IBI,IBLN,IBNM,IBRNB,IBRNB0,IBTOT,IBTNC,IBTNF,IBTCH
SET (IBTOT,IBTNC,IBTNF,IBTCH)=0
+2 ;
+3 DO MSG("Reset 2 Reason Not Billable ECME Paper Flags (#356.8,.03)...",1)
+4 ;
+5 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(OLD+IBI^IBY399P2),";;",2,999)
if 'IBLN
QUIT
IF $PIECE(IBLN,U,2)="OLD"
IF $PIECE(IBLN,U,5)'=""
Begin DoDot:1
+6 SET IBNM=$PIECE(IBLN,U,6)
SET IBRNB=$ORDER(^IBE(356.8,"B",IBNM,0))
SET IBRNB0=$GET(^IBE(356.8,+IBRNB,0))
+7 ;
+8 SET IBTOT=IBTOT+1
IF $PIECE(IBRNB0,U,3)=$PIECE(IBLN,U,5)
SET IBTNC=IBTNC+1
QUIT
+9 IF 'IBRNB
SET IBTNF=IBTNF+1
DO MSG(IBNM_" not found")
QUIT
+10 SET IBTCH=IBTCH+1
DO MSG(IBNM_" ECME Paper Flag to "_$$YN($PIECE(IBLN,U,5)))
DO EDIT(IBRNB,".03////"_+$PIECE(IBLN,U,5))
End DoDot:1
+11 ;
+12 IF 'IBTCH
DO MSG("No Change: "_IBTNC_" of "_IBTOT_" RNB ECME Paper Flags Already Reset"_$$LN(IBTNF,"Not Found"),2)
+13 IF +IBTCH
DO MSG("Updated: "_IBTCH_" of "_IBTOT_" RNB ECME Paper Flags Reset"_$$LN(IBTNC,"Already Reset")_$$LN(IBTNF,"Not Found"),2)
+14 QUIT
+15 ;
+16 ;
CODE ; Set Code on Existing RNB's (356.8,.04)
+1 NEW IBI,IBLN,IBNM,IBRNB,IBRNB0,IBTOT,IBTNC,IBTNF,IBTCH
SET (IBTOT,IBTNC,IBTNF,IBTCH)=0
+2 ;
+3 DO MSG("Add Code to 33 Existing RNBs (#356.8,.04)...",1)
+4 ;
+5 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(OLD+IBI^IBY399P2),";;",2,999)
if 'IBLN
QUIT
IF $PIECE(IBLN,U,2)="OLD"
IF $PIECE(IBLN,U,3)'=""
Begin DoDot:1
+6 SET IBNM=$PIECE(IBLN,U,6)
SET IBRNB=$ORDER(^IBE(356.8,"B",IBNM,0))
SET IBRNB0=$GET(^IBE(356.8,+IBRNB,0))
+7 ;
+8 SET IBTOT=IBTOT+1
IF $PIECE(IBRNB0,U,4)=$PIECE(IBLN,U,3)
SET IBTNC=IBTNC+1
QUIT
+9 IF 'IBRNB
SET IBTNF=IBTNF+1
DO MSG(IBNM_" not found")
QUIT
+10 SET IBTCH=IBTCH+1
DO MSG(IBNM_" code added "_$PIECE(IBLN,U,3))
DO EDIT(IBRNB,".04///"_$PIECE(IBLN,U,3))
End DoDot:1
+11 ;
+12 IF 'IBTCH
DO MSG("No Change: "_IBTNC_" of "_IBTOT_" Existing RNB Codes Already Set"_$$LN(IBTNF,"Not Found"),2)
+13 IF +IBTCH
DO MSG("Updated: "_IBTCH_" of "_IBTOT_" RNBs Code Set"_$$LN(IBTNC,"Codes Already Set")_$$LN(IBTNF,"Not Found"),2)
+14 QUIT
+15 ;
+16 ;
NEWR ; Add new RNBs (if RNB already exists ensure Code is set)
+1 NEW IBI,IBJ,IBLN,IBNM,IBRNB,IBRNB0,IBTOT,IBTNC,IBTCH,DIE,DIC,DR,DA,DD,DO,X,Y,DLAYGO,DINUM
+2 SET (IBTOT,IBTNC,IBTCH)=0
SET DLAYGO=356.8
+3 ;
+4 DO MSG("Add 58 New Reasons Not Billable (#356.8)...",1)
+5 ;
+6 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(NEW+IBI^IBY399P2),";;",2,999)
if 'IBLN
QUIT
IF $PIECE(IBLN,U,2)="NEW"
Begin DoDot:1
+7 SET IBNM=$PIECE(IBLN,U,6)
SET IBRNB=$ORDER(^IBE(356.8,"B",IBNM,0))
SET IBRNB0=$GET(^IBE(356.8,+IBRNB,0))
+8 FOR IBJ=39:1
IF '$DATA(^IBE(356.8,IBJ,0))
IF IBJ'=72
IF IBJ'=90
QUIT
+9 ;
+10 SET IBTOT=IBTOT+1
IF +IBRNB
SET IBTNC=IBTNC+1
if $PIECE(IBRNB0,U,4)'=$PIECE(IBLN,U,3)
DO EDIT(IBRNB,".04///"_$PIECE(IBLN,U,3))
QUIT
+11 ;
+12 SET DIC("DR")=".02////"_$PIECE(IBLN,U,4)_";.03////"_$PIECE(IBLN,U,5)_";.04///"_$PIECE(IBLN,U,3)
+13 SET DIC="^IBE(356.8,"
SET DIC(0)="L"
SET X=IBNM
SET DINUM=IBJ
DO FILE^DICN
KILL DIC
IF 'Y
DO MSG(IBNM_" Not Added, ERROR ****")
QUIT
+14 SET IBTCH=IBTCH+1
DO MSG(IBNM_" added")
End DoDot:1
+15 ;
+16 IF 'IBTCH
DO MSG("No Change: "_IBTNC_" of "_IBTOT_" New RNBs Already Exist",2)
+17 IF +IBTCH
DO MSG("Updated: "_IBTCH_" of "_IBTOT_" New RNBs Added"_$$LN(IBTNC,"Already Exist"),2)
+18 QUIT
+19 ;
+20 ;
+21 ;
MSG(X,Y) ; set lines into patch install message, X is message, Y is line type (1-header, 2-result line)
+1 NEW CNT,IBA
SET CNT=1
SET IBA(1)=" "
IF +$GET(Y)
SET CNT=2
SET IBA(2)=IBA(1)
IF +$GET(Y)=1
SET IBA(2)=" >> "
+2 SET IBA(CNT)=IBA(CNT)_$GET(X)
DO MES^XPDUTL(.IBA)
KILL IBA
+3 QUIT
+4 ;
LN(NUM,TXT) QUIT $SELECT('$GET(NUM):"",1:", "_$GET(NUM)_" "_$GET(TXT))
+1 ;
YN(X) QUIT $SELECT(+$GET(X):"Yes",1:"No")
+1 ;
EDIT(DA,DR) ; edit RNB field
+1 NEW DIE,DIC,X,Y
IF +$GET(DA)
IF $GET(DR)'=""
SET DIE="^IBE(356.8,"
DO ^DIE
KILL DA,DR
+2 QUIT
