- 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 Jan 18, 2025@03:35:10 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