IBCRETP.m

IBCRETP ;LL/ELZ - RATES: TRANSFER PRICING CM FAST ENTER/EDIT ; 24-AUG-1999

 ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

 ;

ENTER ; OPTION:  Transfer Pricing rates fast enter - this requires billing

 ; rate names are not changed.  Will set up charge sets if not defined.

 ;

 N DIR,DIRUT,DTOUT,DUOUT,X,Y,IBARR,IBRATE,IBEFDT,IBRVCD,IBCS,IBA

 W @IOF W !!,?10,"Fast Enter of Transfer Pricing Rates",!!

 ;

 S DIR(0)="SO^I:Inpatient;O:Outpatient",DIR("A")="Enter which rates" D ^DIR K DIR

 S IBRATE=$S(Y="I":"1^TP INPATIENT",Y="O":"2^TP OUTPATIENT",1:"") Q:'IBRATE

 ;

 S IBEFDT=$$GETDT^IBCRU1() I IBEFDT'?7N Q

 ;

 S IBCS=$$FAC(IBRATE)

 D EDITCI(IBCS,IBEFDT)

 Q

 ;

FAC(TYPE) ; ask facility, create charge sets and billing region if not defined, return chargeset

 N DIC,X,Y,DTOUT,DUOUT,IBFAC,IBCS,IBRG

 ;

 S DIC="^DIC(4,",DIC(0)="AEMNQ" D ^DIC Q:Y<1 0 S IBFAC=Y

 ;

 S IBCS=$$TPCS^IBCRU7(TYPE,+IBFAC) Q:IBCS IBCS

 ;

 ; add billing region and charge set to charge master

 S IBRG=$$RG(IBFAC) Q:'IBRG 0

 S IBCS=$$ACS(TYPE,IBRG,IBFAC)

 Q IBCS

 ;

RG(INST) ; add a new Billing Region for Transfer pricing (363.31)

 ; input institution 0 by ref and institution pointer

 ; returns billing region IFN ^ name

 N IBNAME,IBRG,X,Y,DLAYGO,DIC,DA,DTOUT,DUOUT,MSG,D0

 I $G(INST)="" Q 0

 ;

 F X=0,1,3,99 S INST(X)=$G(^DIC(4,+INST,X))

 S IBNAME=$$NNT^XUAF4(+INST)

 S IBNAME="TP "_$S($P(IBNAME,"^",3)="VISN":$P(IBNAME,"^"),1:$P(INST(99),"^")_" "_$P(INST(1),"^",3))_$S($P(INST(0),"^",2)&($P(IBNAME,"^",3)'="VISN"):", "_$P($G(^DIC(5,$P(INST(0),"^",2),0)),"^",2),1:"")

 S IBRG=$O(^IBE(363.31,"B",IBNAME,0)) I IBRG Q IBRG_"^"_IBNAME

 ;

 K D0 S DLAYGO=363.31,DIC="^IBE(363.31,",DIC(0)="L",X=$E(IBNAME,1,30) D FILE^DICN I Y<1 Q 0

 S IBRG=Y D MSG("     Added Billing Region "_$P(IBRG,"^",2))

 ;

 K DA S DIC(0)="L",DA(1)=+IBRG,DIC=DIC_DA(1)_",21,",X=+INST D FILE^DICN

 D MSG("     with"_$S(Y>0:"",1:"OUT")_" Institution "_$P(INST(0),"^"))

 ;

 D MSGP Q IBRG

 ;

ACS(RATE,RG,FAC) ; find or add charge set

 ; returns IFN of new charge set, 0 otherwise, input is in internal^external format

 N IBOK,IBNAME,IBEVENT,IBFN,IBBR,IBBE,IBJ,DD,DO,DLAYDO,DINUM,DIC,DA,X,Y,DR,DIE,IBA,IBCSN,MSG S IBOK=1

 S RATE=$G(RATE),RG=$G(RG),FAC=$G(FAC) I RATE="" G ACSQ

 ;

 S IBNAME="TP-"_$S((+RATE)=1:"INPT ",1:"OPT ")_$S($E($P(FAC,"^",2),1,5)="VISN ":$P(FAC,"^",2),1:+FAC)

 S IBEVENT=$S(RATE[" I":"INPATIENT DRG",1:"PROCEDURE")

 S IBFN=$O(^IBE(363.1,"B",$E(IBNAME,1,30),0)) I +IBFN S IBOK=0 D MSG("     *** Charge Set "_$E(IBNAME,1,30)_" found")

 S IBBR=$O(^IBE(363.3,"B",$P(RATE,"^",2),0)) I 'IBBR S IBOK=0 D MSG("     *** Error: "_RATE_" Billing Rate does not exist")

 S IBBE=$$MCCRUTL(IBEVENT,14) I 'IBBE S IBOK=0 D MSG("     *** Error: "_IBEVENT_" Billable Event undefined")

 I '$D(^IBE(363.3,+RG)) S IBOK=0 D MSG("     *** Error: "_$P($E(RG,1,30),"^",2)_" Billing Region does not exist")

 I '$G(IBOK) G ACSQ

 ;

 F IBJ=1:1 S IBFN=$G(^IBE(363.1,IBJ,0)) I IBFN="" S DINUM=IBJ Q

 ;

 K DD,DO S DLAYGO=363.1,DIC="^IBE(363.1,",DIC(0)="L",X=$E(IBNAME,1,30) D FILE^DICN K DIC K DIC,DINUM,DLAYGO I Y<1 K X,Y Q

 S IBFN=+Y,IBCSN=$P(Y,U,2)

 ;

 S DR=".02////"_IBBR_";.03////"_IBBE_";.07////"_(+RG)

 S DIE="^IBE(363.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y

 S IBA(1)="     "_$E(IBNAME,1,30)_" Charge Set "_$S('$G(IBFN):"NOT ",1:"")_"added"

 ;

ACSQ D MSGP

 Q +$G(IBFN)

 ;

MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name 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,"B",X,IBX)) Q:'IBX  I $P($G(^DGCR(399.1,IBX,0)),U,+$G(P)) S IBY=IBX

 Q IBY

 ;

MSG(X) ; add message to end of message list, reserves IBA(1) for primary message

 N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1

 S IBA(IBX)=$G(X)

 Q

MSGP ; print error messages in IBA

 N IBX S IBX="" F  S IBX=$O(IBA(IBX)) Q:'IBX  W !,IBA(IBX)

 Q

 ;

EDITCI(IBCSFN,IBDT) ; Enter/Edit Charge Items

 N IBCS0,IBBR0,IBBRFN,IBITEM,IBBRBI,IBCIFN,IBX,DIE,DR,DA,X,Y

 ;

CS I '$G(IBCSFN) S IBCSFN=+$$GETCS^IBCRU1 Q:IBCSFN'>0

 D DISPCS^IBCRU7(+IBCSFN)

 ;

 S IBCS0=$G(^IBE(363.1,+IBCSFN,0)),IBBRFN=$P(IBCS0,U,2)

 S IBBR0=$G(^IBE(363.3,+IBBRFN,0)),IBBRBI=$P(IBBR0,U,4)

 W !!,"Enter/edit a billable item (",$$BITM(IBBRBI),") for Charge Set ",$P(IBCS0,U,1)

 ;

CI W ! S IBITEM=$$GETITEM^IBCRU1(IBCSFN,"",1) I +IBITEM<1 Q

 I '$$ITFILE^IBCRU2(IBBRBI,+IBITEM) W !!,$$BITM(IBBRBI)," ",$P(IBITEM,U,2)," CURRENTLY INACTIVE",!

 ;

EF D DISPCI^IBCRU5(+IBCSFN,+IBITEM)

 I IBDT<1 S IBDT="" W "   ... no change" G CI

 D SCRNDSPL

 ;

 S IBCIFN=$$FINDCI(+IBCSFN,+IBITEM,IBDT) I IBCIFN<0 G EF

 ;

 I IBCIFN>0 W !,?50,"Editing Charge Item!"

 ;

 I 'IBCIFN D  I 'IBCIFN W !!,"A charge can not be added for this item!",! Q

 . S IBCIFN=$$ADDCI^IBCREF(+IBCSFN,+IBITEM,IBDT) W !,?50,"Adding a new Charge Item!"

 ;

 S DR=$$DR01(+$P(IBITEM,U,4))_";.03;.04;.05;"

 ;

 I $P(IBITEM,U,4)=81 S DR=DR_".07"

 ;

DIE S DIDEL=363.2,DIE="^IBA(363.2,",DA=+IBCIFN D ^DIE K DIE,DR,X,DIDEL

 ;

        I $D(DA),$D(Y)=0 S IBX=$$RQCI^IBCREU1(+IBCIFN) I +IBX

 D DISPCSL^IBCRU7(+IBCSFN)

 G CI

 Q

BITM(X) ; return external form of billable item

 S X=+$G(X) S X=$$EXPAND^IBCRU1(363.3,.04,X)

 Q X

FINDCI(IBCSFN,IBITEM,IBDT) ; find item to edit returns CIIFN or 0 (new) or -1 (error)

 ;

 N IBY,IBI,IBCNT,DIR,X,Y,IBARR S IBY=-1

 S IBI=$O(^IBA(363.2,"AIVDTS"_IBCSFN,+IBITEM,-IBDT,0)) I 'IBI S IBY=0 G FCQ ; none found

 ;

 S (IBI,IBCNT)=0 F  S IBI=$O(^IBA(363.2,"AIVDTS"_IBCSFN,+IBITEM,-IBDT,+IBI)) Q:'IBI  D

 . S IBCNT=IBCNT+1,IBARR(IBCNT)=IBI D DISPCIL^IBCRU5(IBI,IBCNT)

 I +IBCNT S DIR(0)="NO^1:"_IBCNT D ^DIR I Y>0 S IBY=$G(IBARR(Y))

 I '$D(DTOUT),'$D(DUOUT),IBY<1 S DIR(0)="Y",DIR("A")="Add a new Charge Item? " S DIR("B")="Y" D ^DIR I Y=1 S IBY=0

FCQ Q IBY

 ;

DR01(FILE) ; return DR string for editing the .01 field of charge item

 N IBX S IBX=""

 I +$G(FILE) S IBX="S DIC(""V"")=""I +Y(0)="_+FILE_""";.01;K DIC(""V"")"

 Q IBX

 ;

SCRNDSPL ; if this edit is called from the screen return the items and dates edited so screen can be

 ; redisplayed with the new/edited items

 I $D(IBSRNITM) S IBSRNITM=IBITEM

 I $D(IBSRNBDT),IBSRNBDT>IBDT S IBSRNBDT=IBDT

 I $D(IBSRNEDT),+IBSRNEDT,IBSRNEDT<IBDT S IBSRNEDT=IBDT

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBCRETP   6289     printed  Apr 23, 2025@18:33:40                                                                                                                                                                                                     Page 2

IBCRETP   ;LL/ELZ - RATES: TRANSFER PRICING CM FAST ENTER/EDIT ; 24-AUG-1999

 +1       ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

ENTER     ; OPTION:  Transfer Pricing rates fast enter - this requires billing

 +1       ; rate names are not changed.  Will set up charge sets if not defined.

 +2       ;

 +3        NEW DIR,DIRUT,DTOUT,DUOUT,X,Y,IBARR,IBRATE,IBEFDT,IBRVCD,IBCS,IBA

 +4        WRITE @IOF

           WRITE !!,?10,"Fast Enter of Transfer Pricing Rates",!!

 +5       ;

 +6        SET DIR(0)="SO^I:Inpatient;O:Outpatient"

           SET DIR("A")="Enter which rates"

           DO ^DIR

           KILL DIR

 +7        SET IBRATE=$SELECT(Y="I":"1^TP INPATIENT",Y="O":"2^TP OUTPATIENT",1:"")

           if 'IBRATE

               QUIT 

 +8       ;

 +9        SET IBEFDT=$$GETDT^IBCRU1()

           IF IBEFDT'?7N

               QUIT 

 +10      ;

 +11       SET IBCS=$$FAC(IBRATE)

 +12       DO EDITCI(IBCS,IBEFDT)

 +13       QUIT 

 +14      ;

FAC(TYPE) ; ask facility, create charge sets and billing region if not defined, return chargeset

 +1        NEW DIC,X,Y,DTOUT,DUOUT,IBFAC,IBCS,IBRG

 +2       ;

 +3        SET DIC="^DIC(4,"

           SET DIC(0)="AEMNQ"

           DO ^DIC

           if Y<1

               QUIT 0

           SET IBFAC=Y

 +4       ;

 +5        SET IBCS=$$TPCS^IBCRU7(TYPE,+IBFAC)

           if IBCS

               QUIT IBCS

 +6       ;

 +7       ; add billing region and charge set to charge master

 +8        SET IBRG=$$RG(IBFAC)

           if 'IBRG

               QUIT 0

 +9        SET IBCS=$$ACS(TYPE,IBRG,IBFAC)

 +10       QUIT IBCS

 +11      ;

RG(INST)  ; add a new Billing Region for Transfer pricing (363.31)

 +1       ; input institution 0 by ref and institution pointer

 +2       ; returns billing region IFN ^ name

 +3        NEW IBNAME,IBRG,X,Y,DLAYGO,DIC,DA,DTOUT,DUOUT,MSG,D0

 +4        IF $GET(INST)=""

               QUIT 0

 +5       ;

 +6        FOR X=0,1,3,99

               SET INST(X)=$GET(^DIC(4,+INST,X))

 +7        SET IBNAME=$$NNT^XUAF4(+INST)

 +8        SET IBNAME="TP "_$SELECT($PIECE(IBNAME,"^",3)="VISN":$PIECE(IBNAME,"^"),1:$PIECE(INST(99),"^")_" "_$PIECE(INST(1),"^",3))_$SELECT($PIECE(INST(0),"^",2)&($PIECE(IBNAME,"^",3)'="VISN"):", "_$PIECE($GET(^DIC(5,$PIECE(INST(0),"^",2),0)),"^",2),1:""

)

 +9        SET IBRG=$ORDER(^IBE(363.31,"B",IBNAME,0))

           IF IBRG

               QUIT IBRG_"^"_IBNAME

 +10      ;

 +11       KILL D0

           SET DLAYGO=363.31

           SET DIC="^IBE(363.31,"

           SET DIC(0)="L"

           SET X=$EXTRACT(IBNAME,1,30)

           DO FILE^DICN

           IF Y<1

               QUIT 0

 +12       SET IBRG=Y

           DO MSG("     Added Billing Region "_$PIECE(IBRG,"^",2))

 +13      ;

 +14       KILL DA

           SET DIC(0)="L"

           SET DA(1)=+IBRG

           SET DIC=DIC_DA(1)_",21,"

           SET X=+INST

           DO FILE^DICN

 +15       DO MSG("     with"_$SELECT(Y>0:"",1:"OUT")_" Institution "_$PIECE(INST(0),"^"))

 +16      ;

 +17       DO MSGP

           QUIT IBRG

 +18      ;

ACS(RATE,RG,FAC) ; find or add charge set

 +1       ; returns IFN of new charge set, 0 otherwise, input is in internal^external format

 +2        NEW IBOK,IBNAME,IBEVENT,IBFN,IBBR,IBBE,IBJ,DD,DO,DLAYDO,DINUM,DIC,DA,X,Y,DR,DIE,IBA,IBCSN,MSG

           SET IBOK=1

 +3        SET RATE=$GET(RATE)

           SET RG=$GET(RG)

           SET FAC=$GET(FAC)

           IF RATE=""

               GOTO ACSQ

 +4       ;

 +5        SET IBNAME="TP-"_$SELECT((+RATE)=1:"INPT ",1:"OPT ")_$SELECT($EXTRACT($PIECE(FAC,"^",2),1,5)="VISN ":$PIECE(FAC,"^",2),1:+FAC)

 +6        SET IBEVENT=$SELECT(RATE[" I":"INPATIENT DRG",1:"PROCEDURE")

 +7        SET IBFN=$ORDER(^IBE(363.1,"B",$EXTRACT(IBNAME,1,30),0))

           IF +IBFN

               SET IBOK=0

               DO MSG("     *** Charge Set "_$EXTRACT(IBNAME,1,30)_" found")

 +8        SET IBBR=$ORDER(^IBE(363.3,"B",$PIECE(RATE,"^",2),0))

           IF 'IBBR

               SET IBOK=0

               DO MSG("     *** Error: "_RATE_" Billing Rate does not exist")

 +9        SET IBBE=$$MCCRUTL(IBEVENT,14)

           IF 'IBBE

               SET IBOK=0

               DO MSG("     *** Error: "_IBEVENT_" Billable Event undefined")

 +10       IF '$DATA(^IBE(363.3,+RG))

               SET IBOK=0

               DO MSG("     *** Error: "_$PIECE($EXTRACT(RG,1,30),"^",2)_" Billing Region does not exist")

 +11       IF '$GET(IBOK)

               GOTO ACSQ

 +12      ;

 +13       FOR IBJ=1:1

               SET IBFN=$GET(^IBE(363.1,IBJ,0))

               IF IBFN=""

                   SET DINUM=IBJ

                   QUIT 

 +14      ;

 +15       KILL DD,DO

           SET DLAYGO=363.1

           SET DIC="^IBE(363.1,"

           SET DIC(0)="L"

           SET X=$EXTRACT(IBNAME,1,30)

           DO FILE^DICN

           KILL DIC

           KILL DIC,DINUM,DLAYGO

           IF Y<1

               KILL X,Y

               QUIT 

 +16       SET IBFN=+Y

           SET IBCSN=$PIECE(Y,U,2)

 +17      ;

 +18       SET DR=".02////"_IBBR_";.03////"_IBBE_";.07////"_(+RG)

 +19       SET DIE="^IBE(363.1,"

           SET DA=+IBFN

           DO ^DIE

           KILL DIE,DA,DR,X,Y

 +20       SET IBA(1)="     "_$EXTRACT(IBNAME,1,30)_" Charge Set "_$SELECT('$GET(IBFN):"NOT ",1:"")_"added"

 +21      ;

ACSQ       DO MSGP

 +1        QUIT +$GET(IBFN)

 +2       ;

MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true

 +1        NEW IBX,IBY

           SET IBY=""

 +2        IF $GET(X)'=""

               SET IBX=0

               FOR 

                   SET IBX=$ORDER(^DGCR(399.1,"B",X,IBX))

                   if 'IBX

                       QUIT 

                   IF $PIECE($GET(^DGCR(399.1,IBX,0)),U,+$GET(P))

                       SET IBY=IBX

 +3        QUIT IBY

 +4       ;

MSG(X)    ; add message to end of message list, reserves IBA(1) for primary message

 +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 

MSGP      ; print error messages in IBA

 +1        NEW IBX

           SET IBX=""

           FOR 

               SET IBX=$ORDER(IBA(IBX))

               if 'IBX

                   QUIT 

               WRITE !,IBA(IBX)

 +2        QUIT 

 +3       ;

EDITCI(IBCSFN,IBDT) ; Enter/Edit Charge Items

 +1        NEW IBCS0,IBBR0,IBBRFN,IBITEM,IBBRBI,IBCIFN,IBX,DIE,DR,DA,X,Y

 +2       ;

CS         IF '$GET(IBCSFN)

               SET IBCSFN=+$$GETCS^IBCRU1

               if IBCSFN'>0

                   QUIT 

 +1        DO DISPCS^IBCRU7(+IBCSFN)

 +2       ;

 +3        SET IBCS0=$GET(^IBE(363.1,+IBCSFN,0))

           SET IBBRFN=$PIECE(IBCS0,U,2)

 +4        SET IBBR0=$GET(^IBE(363.3,+IBBRFN,0))

           SET IBBRBI=$PIECE(IBBR0,U,4)

 +5        WRITE !!,"Enter/edit a billable item (",$$BITM(IBBRBI),") for Charge Set ",$PIECE(IBCS0,U,1)

 +6       ;

CI         WRITE !

           SET IBITEM=$$GETITEM^IBCRU1(IBCSFN,"",1)

           IF +IBITEM<1

               QUIT 

 +1        IF '$$ITFILE^IBCRU2(IBBRBI,+IBITEM)

               WRITE !!,$$BITM(IBBRBI)," ",$PIECE(IBITEM,U,2)," CURRENTLY INACTIVE",!

 +2       ;

EF         DO DISPCI^IBCRU5(+IBCSFN,+IBITEM)

 +1        IF IBDT<1

               SET IBDT=""

               WRITE "   ... no change"

               GOTO CI

 +2        DO SCRNDSPL

 +3       ;

 +4        SET IBCIFN=$$FINDCI(+IBCSFN,+IBITEM,IBDT)

           IF IBCIFN<0

               GOTO EF

 +5       ;

 +6        IF IBCIFN>0

               WRITE !,?50,"Editing Charge Item!"

 +7       ;

 +8        IF 'IBCIFN

               Begin DoDot:1

 +9                SET IBCIFN=$$ADDCI^IBCREF(+IBCSFN,+IBITEM,IBDT)

                   WRITE !,?50,"Adding a new Charge Item!"

               End DoDot:1

               IF 'IBCIFN

                   WRITE !!,"A charge can not be added for this item!",!

                   QUIT 

 +10      ;

 +11       SET DR=$$DR01(+$PIECE(IBITEM,U,4))_";.03;.04;.05;"

 +12      ;

 +13       IF $PIECE(IBITEM,U,4)=81

               SET DR=DR_".07"

 +14      ;

DIE        SET DIDEL=363.2

           SET DIE="^IBA(363.2,"

           SET DA=+IBCIFN

           DO ^DIE

           KILL DIE,DR,X,DIDEL

 +1       ;

 +2        IF $DATA(DA)

               IF $DATA(Y)=0

                   SET IBX=$$RQCI^IBCREU1(+IBCIFN)

                   IF +IBX

 +3        DO DISPCSL^IBCRU7(+IBCSFN)

 +4        GOTO CI

 +5        QUIT 

BITM(X)   ; return external form of billable item

 +1        SET X=+$GET(X)

           SET X=$$EXPAND^IBCRU1(363.3,.04,X)

 +2        QUIT X

FINDCI(IBCSFN,IBITEM,IBDT) ; find item to edit returns CIIFN or 0 (new) or -1 (error)

 +1       ;

 +2        NEW IBY,IBI,IBCNT,DIR,X,Y,IBARR

           SET IBY=-1

 +3       ; none found

           SET IBI=$ORDER(^IBA(363.2,"AIVDTS"_IBCSFN,+IBITEM,-IBDT,0))

           IF 'IBI

               SET IBY=0

               GOTO FCQ

 +4       ;

 +5        SET (IBI,IBCNT)=0

           FOR 

               SET IBI=$ORDER(^IBA(363.2,"AIVDTS"_IBCSFN,+IBITEM,-IBDT,+IBI))

               if 'IBI

                   QUIT 

               Begin DoDot:1

 +6                SET IBCNT=IBCNT+1

                   SET IBARR(IBCNT)=IBI

                   DO DISPCIL^IBCRU5(IBI,IBCNT)

               End DoDot:1

 +7        IF +IBCNT

               SET DIR(0)="NO^1:"_IBCNT

               DO ^DIR

               IF Y>0

                   SET IBY=$GET(IBARR(Y))

 +8        IF '$DATA(DTOUT)

               IF '$DATA(DUOUT)

                   IF IBY<1

                       SET DIR(0)="Y"

                       SET DIR("A")="Add a new Charge Item? "

                       SET DIR("B")="Y"

                       DO ^DIR

                       IF Y=1

                           SET IBY=0

FCQ        QUIT IBY

 +1       ;

DR01(FILE) ; return DR string for editing the .01 field of charge item

 +1        NEW IBX

           SET IBX=""

 +2        IF +$GET(FILE)

               SET IBX="S DIC(""V"")=""I +Y(0)="_+FILE_""";.01;K DIC(""V"")"

 +3        QUIT IBX

 +4       ;

SCRNDSPL  ; if this edit is called from the screen return the items and dates edited so screen can be

 +1       ; redisplayed with the new/edited items

 +2        IF $DATA(IBSRNITM)

               SET IBSRNITM=IBITEM

 +3        IF $DATA(IBSRNBDT)

               IF IBSRNBDT>IBDT

                   SET IBSRNBDT=IBDT

 +4        IF $DATA(IBSRNEDT)

               IF +IBSRNEDT

                   IF IBSRNEDT<IBDT

                       SET IBSRNEDT=IBDT

 +5        QUIT