Routine: RMPRED4

RMPRED4 ;PHX/RFM,RVD-EDIT ISSUE FROM STOCK ;8/29/1994

 ;;3.0;PROSTHETICS;**33,35,46,53,62,154**;Feb 09, 1996;Build 6

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

 ;RVD patch #62 - PCE interface

 K DIR

 ;I $P(R1(0),U,13)=11&($P(R1(0),U,14)="C")&'$G(RMLOC) D

 S DIR(0)="667.3,3",DIR("A")="UNIT COST",DIR("B")=$P(R1(0),U,16)/$P(R1(0),U,7)

 I $D(RMLOC),$D(RMHCDA),$D(RMITDA) S DIR("B")=$$COST^RMPR5NU1

 D ^DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT) CO^RMPRED6

 S (ACNT,RMPRREL)=Y*$P(R1(0),U,7),$P(R3("D"),U,16)=ACNT,$P(R1(0),U,16)=ACNT

 K DIR

QTY ;

 S DIR(0)="660,5",DIR("B")=$P(R1(0),U,7),RMPRCUST=$P(R1(0),U,16)/$P(R1(0),U,7) D ^DIR G:$D(DIRUT) CO^RMPRED6

 I $D(RMUBA),((RMUBA+$P(R1(0),U,7))-Y<0) D LOWBA^RMPRSTI G LOC^RMPRED6

 S $P(R1(0),U,7)=Y,$P(R1(0),U,16)=Y*RMPRCUST K DIR

DATE S:$P(R1(0),U,12) DIR("B")=$P(R3("D"),U,12) S DIR("A")="DELIVERY DATE",DIR(0)="660,10" D ^DIR K DIR

 G:X["^" CO^RMPRED6 G:$D(DTOUT) EXIT W:$P(R1(0),U,12)&(X="@") !?5,"Deleted..." H 1 I $P(R1(0),U,12)=""&(X="@") W ?16,"??" G DATE

 S $P(R1(0),U,12)=Y,Y=$P(R1(0),U,12) D DD^%DT S $P(R3("D"),U,12)=Y

REQ S DIR(0)="660,9" S:$P(R1(0),U,11)'="" DIR("B")=$P(R1(0),U,11) D ^DIR G:$D(DIRUT) CO^RMPRED6 G:$D(DTOUT) EXIT

 I X["^" W !,"Jumping not allowed!" G REQ

 I $P(R1(0),U,11)'=""&(X="@") W !?5,"Deleted..." H 1 S $P(R1(0),U,11)="" G LOT

 S $P(R1(0),U,11)=X

LOT K DIR S DIR(0)="660,21" S:$P(R1(0),U,24)'="" DIR("B")=$P(R1(0),U,24) D ^DIR G:$D(DUOUT) CO^RMPRED6

 I X["^" W !,"Jumping not allowed!" G LOT

 I $P(R1(0),U,24)'=""&(X="@") W !?5,"Deleted..." H 1 S $P(R1(0),U,24)="" G REMA

 S $P(R1(0),U,24)=X

REMA K DIR S DIR(0)="660,16" S:$P(R1(0),U,18)'="" DIR("B")=$P(R1(0),U,18) D ^DIR G:$D(DIRUT) CO^RMPRED6 G:$D(DTOUT) EXIT

 I X["^" W !,"Jumping not allowed!" G REMA

 I $P(R1(0),U,18)'=""&(X="@") W !?5,"Deleted..." H 1 S $P(R1(0),U,18)="" G CC

 S $P(R1(0),U,18)=X

CC G CO^RMPRED6

POST ;POSTS EDITED TRANSACTION TO 660

 W !,"Posting...."

 S RIPNEW=$P($G(R1(1)),U,3),RITNEW=$P(R1(0),U,6),RMQNEW=$P(R1(0),U,7)

 S:$G(RITNEW) RITNEW=$P($G(^RMPR(661,RITNEW,0)),U,1)

 S:$G(RITOLD) RITOLD=$P($G(^RMPR(661,RITOLD,0)),U,1)

 S ^RMPR(660,RMPRIEN,0)=R1(0),^("AM")=R1("AM"),^(1)=R1(1),^(2)=R1(2)

 I RMHCNEW'=RMHCOLD D

 .K ^RMPR(660,RMPRIEN,"DES")

 .MERGE ^RMPR(660,RMPRIEN,"DES")=^RMPR(661.1,RMHCNEW,2)

 .S $P(^RMPR(660,RMPRIEN,"DES",0),U,2)=""

 S DIK="^RMPR(660,",DA=RMPRIEN D IX1^DIK K DIK

 S RMVAR=RMLOCNEW_"^"_RMHCNEW_"^"_RMHCOLD_"^"_RMLOCOLD_"^"_RMITNEW_"^"_RMITOLD_"^"_RMQNEW_"^"_RMQOLD_"^"_RMSO_"^"_RMDFN

 I $G(RMQOLD)'=$G(RMQNEW)&($G(RMLOCNEW)=$G(RMLOCOLD))&($G(RMHCNEW)=$G(RMHCOLD))&(RMITNEW=RMITOLD) D QTYN^RMPRED5(RMVAR) G EXIT

 I $G(RMHCOLD)'=$G(RMHCNEW)!(RMITNEW'=RMITOLD)!($G(RMLOCNEW)'=$G(RMLOCOLD)) D NHCPC^RMPRED5(RMVAR)

 G EXIT

 ;end posting (edit 2319)

DEL1 ;ENTRY POINT TO DELETE AN ISSUE FROM STOCK

 K DIR

 S DIR("A")="Are you sure you want to DELETE this entry",DIR("B")="N",DIR(0)="Y"

 D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT) G EXIT

 I Y'=1 G CO^RMPRED6

 I $P(^RMPR(669.9,RMPRSITE,0),U,3)'=1!(RMPRPF=11) G DEL2

 I $G(RMPRIP),+$P(^RMPR(660,RMPRIEN,1),U,3)

 I  S DIC="^PRCP(445,",DIC(0)="M",X=RMPRIP,DIC("S")="I $P(^(0),U,2)=""Y"",$D(^PRCP(445,+Y,4,DUZ,0))" D ^DIC G:+Y<0 ERR K DIC S PRCP("I")=+Y,RMPRDTD=1

 I '$D(RMPRDTD) S DIC="^PRCP(445,",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,2)=""Y"",$D(^PRCP(445,+Y,4,DUZ,0))" D ^DIC K DIC S PRCP("I")=+Y

 S PRCP("ITEM")=$P(R3("D"),U,6),PRCP("QTY")=$P(R1(0),U,7),PRCP("TYP")="A" D ^PRCPUSA G:$D(PRCP("ITEM")) ERR

DEL2 I RMPRPF=11 S RM1=$G(^RMPR(660,RMPRIEN,1)),R6612=$P(RM1,U,5) D:$G(R6612)

 .S RM0=$G(^RMPR(660,RMPRIEN,0)),RMQTY=$P(RM0,U,7)

 .S RM10=$G(^RMPR(660,RMPRIEN,10))

 .;check if SUSPENSE and PCE entry has been created.  added by #62.

 .S RMIPCE=$P(RM10,U,12) I RMIPCE D

 ..S RMCHK=$$DEL^RMPRPCED(RMPRIEN)

 .;if no pce link, only delete entry in #668

 .I 'RMIPCE D

 ..S RMAMIS=$G(^RMPR(660,RMPRIEN,"AMS"))

 ..S RMIE68=$O(^RMPR(668,"F",RMPRIEN,0))

 ..Q:'$G(RMIE68)

 ..S DA=$O(^RMPR(668,RMIE68,10,"B",RMPRIEN,0))

 ..S DA(1)=RMIE68,DIK="^RMPR(668,"_DA(1)_",10," D ^DIK

 ..S RMAMIEN=$O(^RMPR(668,RMIE68,11,"B",RMAMIS,0)),RMCNT=0

 ..F I=0:0 S I=$O(^RMPR(668,RMIE68,10,"B",I)) Q:I'>0  D

 ...S RMAMIS68=$G(^RMPR(660,I,"AMS")) S:RMAMIS68=RMAMIS RMCNT=RMCNT+1

 ..I RMCNT=1 D

 ...S DA=RMAMIEN

 ...S DA(1)=RMIE68,DIK="^RMPR(668,"_DA(1)_",11,"

 ...D ^DIK

 .S RMSTO=$G(^RMPR(661.2,R6612,0)),RMLOC=$P(RMSTO,U,16)

 .S RMDAHC=$P(RM1,U,4),RMIT=$P(RMSTO,U,9)

 .S RMHCDA=$O(^RMPR(661.3,RMLOC,1,"B",RMDAHC,0))

 .Q:'$G(RMHCDA)

 .S:$D(^RMPR(661.3,RMLOC,1,RMHCDA)) RMITDA=$O(^RMPR(661.3,RMLOC,1,RMHCDA,1,"B",RMIT,0))

 .Q:'$G(RMITDA)

 .S RBAL=0 D

 ..S RMBA=$P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,2),RBAL=RMBA+RMQTY

 ..S (RAVA,RAV)=$P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,10)

 ..S $P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,2)=RBAL

 ..S $P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,3)=RBAL*RAV

 ..S $P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,12)=RMQTY

 .D BAL^RMPR5NU1

 .S X=DT,DIC(0)="AEQL",DLAYGO=661.2,DIC="^RMPR(661.2," K DD,DO

 .D FILE^DICN K DLAYGO S RMCOM="Returned from STOCK ISSUE"

 .S ^RMPR(661.2,+Y,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^"_RMQTY_"^"_RMIT_"^^"_RMQTY_"^"_RMTOBA_"^"_RMCOM_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLOC_"^"_RAVA

 .S DA=+Y,DIK=DIC D IX1^DIK

 .W !,"****Current Balance @ Location ",$P(^RMPR(661.3,RMLOC,0),U,1)," is now: ",RBAL

 S DIK="^RMPR(660,",DA=RMPRIEN D ^DIK

 W $C(7),!?10,"Deleted..." H 1

 G EXIT

ERR W !!,"Error encountered while posting to GIP.  Patient 10-2319 not deleted!! Please check with your Application Coordinator." H 5 G EXIT

EXIT ;KILL VARIABLES AND EXIT ROUTINE

 I $G(RMPRIEN),$D(^RMPR(660,RMPRIEN)) L -^RMPR(660,RMPRIEN)

 N RMPRSITE,RMPR D KILL^XUSCLEAN Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRED4   5750     printed  Feb 19, 2025@00:00:46                                                                                                                                                                                                     Page 2

RMPRED4   ;PHX/RFM,RVD-EDIT ISSUE FROM STOCK ;8/29/1994

 +1       ;;3.0;PROSTHETICS;**33,35,46,53,62,154**;Feb 09, 1996;Build 6

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

 +3       ;

 +4       ;RVD patch #62 - PCE interface

 +5        KILL DIR

 +6       ;I $P(R1(0),U,13)=11&($P(R1(0),U,14)="C")&'$G(RMLOC) D

 +7        SET DIR(0)="667.3,3"

           SET DIR("A")="UNIT COST"

           SET DIR("B")=$PIECE(R1(0),U,16)/$PIECE(R1(0),U,7)

 +8        IF $DATA(RMLOC)

               IF $DATA(RMHCDA)

                   IF $DATA(RMITDA)

                       SET DIR("B")=$$COST^RMPR5NU1

 +9        DO ^DIR

           if $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)

               GOTO CO^RMPRED6

 +10       SET (ACNT,RMPRREL)=Y*$PIECE(R1(0),U,7)

           SET $PIECE(R3("D"),U,16)=ACNT

           SET $PIECE(R1(0),U,16)=ACNT

 +11       KILL DIR

QTY       ;

 +1        SET DIR(0)="660,5"

           SET DIR("B")=$PIECE(R1(0),U,7)

           SET RMPRCUST=$PIECE(R1(0),U,16)/$PIECE(R1(0),U,7)

           DO ^DIR

           if $DATA(DIRUT)

               GOTO CO^RMPRED6

 +2        IF $DATA(RMUBA)

               IF ((RMUBA+$PIECE(R1(0),U,7))-Y<0)

                   DO LOWBA^RMPRSTI

                   GOTO LOC^RMPRED6

 +3        SET $PIECE(R1(0),U,7)=Y

           SET $PIECE(R1(0),U,16)=Y*RMPRCUST

           KILL DIR

DATE       if $PIECE(R1(0),U,12)

               SET DIR("B")=$PIECE(R3("D"),U,12)

           SET DIR("A")="DELIVERY DATE"

           SET DIR(0)="660,10"

           DO ^DIR

           KILL DIR

 +1        if X["^"

               GOTO CO^RMPRED6

           if $DATA(DTOUT)

               GOTO EXIT

           if $PIECE(R1(0),U,12)&(X="@")

               WRITE !?5,"Deleted..."

           HANG 1

           IF $PIECE(R1(0),U,12)=""&(X="@")

               WRITE ?16,"??"

               GOTO DATE

 +2        SET $PIECE(R1(0),U,12)=Y

           SET Y=$PIECE(R1(0),U,12)

           DO DD^%DT

           SET $PIECE(R3("D"),U,12)=Y

REQ        SET DIR(0)="660,9"

           if $PIECE(R1(0),U,11)'=""

               SET DIR("B")=$PIECE(R1(0),U,11)

           DO ^DIR

           if $DATA(DIRUT)

               GOTO CO^RMPRED6

           if $DATA(DTOUT)

               GOTO EXIT

 +1        IF X["^"

               WRITE !,"Jumping not allowed!"

               GOTO REQ

 +2        IF $PIECE(R1(0),U,11)'=""&(X="@")

               WRITE !?5,"Deleted..."

               HANG 1

               SET $PIECE(R1(0),U,11)=""

               GOTO LOT

 +3        SET $PIECE(R1(0),U,11)=X

LOT        KILL DIR

           SET DIR(0)="660,21"

           if $PIECE(R1(0),U,24)'=""

               SET DIR("B")=$PIECE(R1(0),U,24)

           DO ^DIR

           if $DATA(DUOUT)

               GOTO CO^RMPRED6

 +1        IF X["^"

               WRITE !,"Jumping not allowed!"

               GOTO LOT

 +2        IF $PIECE(R1(0),U,24)'=""&(X="@")

               WRITE !?5,"Deleted..."

               HANG 1

               SET $PIECE(R1(0),U,24)=""

               GOTO REMA

 +3        SET $PIECE(R1(0),U,24)=X

REMA       KILL DIR

           SET DIR(0)="660,16"

           if $PIECE(R1(0),U,18)'=""

               SET DIR("B")=$PIECE(R1(0),U,18)

           DO ^DIR

           if $DATA(DIRUT)

               GOTO CO^RMPRED6

           if $DATA(DTOUT)

               GOTO EXIT

 +1        IF X["^"

               WRITE !,"Jumping not allowed!"

               GOTO REMA

 +2        IF $PIECE(R1(0),U,18)'=""&(X="@")

               WRITE !?5,"Deleted..."

               HANG 1

               SET $PIECE(R1(0),U,18)=""

               GOTO CC

 +3        SET $PIECE(R1(0),U,18)=X

CC         GOTO CO^RMPRED6

 +1       ;

POST      ;POSTS EDITED TRANSACTION TO 660

 +1        WRITE !,"Posting...."

 +2        SET RIPNEW=$PIECE($GET(R1(1)),U,3)

           SET RITNEW=$PIECE(R1(0),U,6)

           SET RMQNEW=$PIECE(R1(0),U,7)

 +3        if $GET(RITNEW)

               SET RITNEW=$PIECE($GET(^RMPR(661,RITNEW,0)),U,1)

 +4        if $GET(RITOLD)

               SET RITOLD=$PIECE($GET(^RMPR(661,RITOLD,0)),U,1)

 +5        SET ^RMPR(660,RMPRIEN,0)=R1(0)

           SET ^("AM")=R1("AM")

           SET ^(1)=R1(1)

           SET ^(2)=R1(2)

 +6        IF RMHCNEW'=RMHCOLD

               Begin DoDot:1

 +7                KILL ^RMPR(660,RMPRIEN,"DES")

 +8                MERGE ^RMPR(660,RMPRIEN,"DES")=^RMPR(661.1,RMHCNEW,2)

 +9                SET $PIECE(^RMPR(660,RMPRIEN,"DES",0),U,2)=""

               End DoDot:1

 +10       SET DIK="^RMPR(660,"

           SET DA=RMPRIEN

           DO IX1^DIK

           KILL DIK

 +11       SET RMVAR=RMLOCNEW_"^"_RMHCNEW_"^"_RMHCOLD_"^"_RMLOCOLD_"^"_RMITNEW_"^"_RMITOLD_"^"_RMQNEW_"^"_RMQOLD_"^"_RMSO_"^"_RMDFN

 +12       IF $GET(RMQOLD)'=$GET(RMQNEW)&($GET(RMLOCNEW)=$GET(RMLOCOLD))&($GET(RMHCNEW)=$GET(RMHCOLD))&(RMITNEW=RMITOLD)

               DO QTYN^RMPRED5(RMVAR)

               GOTO EXIT

 +13       IF $GET(RMHCOLD)'=$GET(RMHCNEW)!(RMITNEW'=RMITOLD)!($GET(RMLOCNEW)'=$GET(RMLOCOLD))

               DO NHCPC^RMPRED5(RMVAR)

 +14       GOTO EXIT

 +15      ;end posting (edit 2319)

 +16      ;

DEL1      ;ENTRY POINT TO DELETE AN ISSUE FROM STOCK

 +1        KILL DIR

 +2        SET DIR("A")="Are you sure you want to DELETE this entry"

           SET DIR("B")="N"

           SET DIR(0)="Y"

 +3        DO ^DIR

           IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)

               GOTO EXIT

 +4        IF Y'=1

               GOTO CO^RMPRED6

 +5        IF $PIECE(^RMPR(669.9,RMPRSITE,0),U,3)'=1!(RMPRPF=11)

               GOTO DEL2

 +6        IF $GET(RMPRIP)

               IF +$PIECE(^RMPR(660,RMPRIEN,1),U,3)

 +7       IF $TEST

               SET DIC="^PRCP(445,"

               SET DIC(0)="M"

               SET X=RMPRIP

               SET DIC("S")="I $P(^(0),U,2)=""Y"",$D(^PRCP(445,+Y,4,DUZ,0))"

               DO ^DIC

               if +Y<0

                   GOTO ERR

               KILL DIC

               SET PRCP("I")=+Y

               SET RMPRDTD=1

 +8        IF '$DATA(RMPRDTD)

               SET DIC="^PRCP(445,"

               SET DIC(0)="AEMQ"

               SET DIC("S")="I $P(^(0),U,2)=""Y"",$D(^PRCP(445,+Y,4,DUZ,0))"

               DO ^DIC

               KILL DIC

               SET PRCP("I")=+Y

 +9        SET PRCP("ITEM")=$PIECE(R3("D"),U,6)

           SET PRCP("QTY")=$PIECE(R1(0),U,7)

           SET PRCP("TYP")="A"

           DO ^PRCPUSA

           if $DATA(PRCP("ITEM"))

               GOTO ERR

DEL2       IF RMPRPF=11

               SET RM1=$GET(^RMPR(660,RMPRIEN,1))

               SET R6612=$PIECE(RM1,U,5)

               if $GET(R6612)

                   Begin DoDot:1

 +1                    SET RM0=$GET(^RMPR(660,RMPRIEN,0))

                       SET RMQTY=$PIECE(RM0,U,7)

 +2                    SET RM10=$GET(^RMPR(660,RMPRIEN,10))

 +3       ;check if SUSPENSE and PCE entry has been created.  added by #62.

 +4                    SET RMIPCE=$PIECE(RM10,U,12)

                       IF RMIPCE

                           Begin DoDot:2

 +5                            SET RMCHK=$$DEL^RMPRPCED(RMPRIEN)

                           End DoDot:2

 +6       ;if no pce link, only delete entry in #668

 +7                    IF 'RMIPCE

                           Begin DoDot:2

 +8                            SET RMAMIS=$GET(^RMPR(660,RMPRIEN,"AMS"))

 +9                            SET RMIE68=$ORDER(^RMPR(668,"F",RMPRIEN,0))

 +10                           if '$GET(RMIE68)

                                   QUIT

 +11                           SET DA=$ORDER(^RMPR(668,RMIE68,10,"B",RMPRIEN,0))

 +12                           SET DA(1)=RMIE68

                               SET DIK="^RMPR(668,"_DA(1)_",10,"

                               DO ^DIK

 +13                           SET RMAMIEN=$ORDER(^RMPR(668,RMIE68,11,"B",RMAMIS,0))

                               SET RMCNT=0

 +14                           FOR I=0:0

                                   SET I=$ORDER(^RMPR(668,RMIE68,10,"B",I))

                                   if I'>0

                                       QUIT

                                   Begin DoDot:3

 +15                                   SET RMAMIS68=$GET(^RMPR(660,I,"AMS"))

                                       if RMAMIS68=RMAMIS

                                           SET RMCNT=RMCNT+1

                                   End DoDot:3

 +16                           IF RMCNT=1

                                   Begin DoDot:3

 +17                                   SET DA=RMAMIEN

 +18                                   SET DA(1)=RMIE68

                                       SET DIK="^RMPR(668,"_DA(1)_",11,"

 +19                                   DO ^DIK

                                   End DoDot:3

                           End DoDot:2

 +20                   SET RMSTO=$GET(^RMPR(661.2,R6612,0))

                       SET RMLOC=$PIECE(RMSTO,U,16)

 +21                   SET RMDAHC=$PIECE(RM1,U,4)

                       SET RMIT=$PIECE(RMSTO,U,9)

 +22                   SET RMHCDA=$ORDER(^RMPR(661.3,RMLOC,1,"B",RMDAHC,0))

 +23                   if '$GET(RMHCDA)

                           QUIT

 +24                   if $DATA(^RMPR(661.3,RMLOC,1,RMHCDA))

                           SET RMITDA=$ORDER(^RMPR(661.3,RMLOC,1,RMHCDA,1,"B",RMIT,0))

 +25                   if '$GET(RMITDA)

                           QUIT

 +26                   SET RBAL=0

                       Begin DoDot:2

 +27                       SET RMBA=$PIECE(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,2)

                           SET RBAL=RMBA+RMQTY

 +28                       SET (RAVA,RAV)=$PIECE(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,10)

 +29                       SET $PIECE(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,2)=RBAL

 +30                       SET $PIECE(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,3)=RBAL*RAV

 +31                       SET $PIECE(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,12)=RMQTY

                       End DoDot:2

 +32                   DO BAL^RMPR5NU1

 +33                   SET X=DT

                       SET DIC(0)="AEQL"

                       SET DLAYGO=661.2

                       SET DIC="^RMPR(661.2,"

                       KILL DD,DO

 +34                   DO FILE^DICN

                       KILL DLAYGO

                       SET RMCOM="Returned from STOCK ISSUE"

 +35                   SET ^RMPR(661.2,+Y,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^"_RMQTY_"^"_RMIT_"^^"_RMQTY_"^"_RMTOBA_"^"_RMCOM_"^"_$JUSTIFY(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLOC_"^"_RAVA

 +36                   SET DA=+Y

                       SET DIK=DIC

                       DO IX1^DIK

 +37                   WRITE !,"****Current Balance @ Location ",$PIECE(^RMPR(661.3,RMLOC,0),U,1)," is now: ",RBAL

                   End DoDot:1

 +38       SET DIK="^RMPR(660,"

           SET DA=RMPRIEN

           DO ^DIK

 +39       WRITE $CHAR(7),!?10,"Deleted..."

           HANG 1

 +40       GOTO EXIT

ERR        WRITE !!,"Error encountered while posting to GIP.  Patient 10-2319 not deleted!! Please check with your Application Coordinator."

           HANG 5

           GOTO EXIT

EXIT      ;KILL VARIABLES AND EXIT ROUTINE

 +1        IF $GET(RMPRIEN)

               IF $DATA(^RMPR(660,RMPRIEN))

                   LOCK -^RMPR(660,RMPRIEN)

 +2        NEW RMPRSITE,RMPR

           DO KILL^XUSCLEAN

           QUIT

RMPRED4.m