RMPR29 ;PHX/JLT-ENTER/EDIT 2529-3 [ 10/01/94 5:29 AM ]
;;3.0;PROSTHETICS;**12,41,62,128**;Feb 09, 1996
;RVD patch #62 - PCE and suspense link
CREATE ;CREATE 2529-3
K RMPREDIT,RMPRTMP,RMPR25,^TMP($J,"RMPRPCE") D DIV4^RMPRSIT G:$D(X) EXIT1
D GETPAT^RMPRUTIL I '$D(RMPRDFN) G EXIT1
VIEW ;CREATE 2529-3 VIA LAB MENU
N RMPRDA,RMPRWO,RMPRJOB S RMPRF=4 D ^RMPRPAT I $D(RMPRKILL) G EXIT
S DIC="^RMPR(664.1,",DIC(0)="ZL",X=DT
S DLAYGO=664.1 D FILE^DICN K DLAYGO,DIC
G:+Y'>0 EXIT1
S RMPRDA=+Y,$P(^RMPR(664.1,RMPRDA,0),U,2)=RMPRDFN,$P(^(0),U,3)=RMPR("STA"),$P(^(0),U,17)="I"
S IDEF=$$STA^RMPR31U(RMPR("STA"))
S DA=RMPRDA,DIK="^RMPR(664.1," D IX1^DIK
K DR,DA,DIC,Y,DIE D KVAR^VADPT
S DFN=$P(^RMPR(664.1,RMPRDA,0),U,2),VAIP("D")="L"
D IN5^VADPT S VAINDT=$P($G(VAIP(3)),U) D INP^VADPT
I VAIN(1) S DR=".11R;.04R//^S X=$G(IDEF);2R;12//^S X=$P(VAIN(4),U,2);12.1//^S X=$P(VAIN(2),U,2);12.2//^S X=VAIN(9);12.3//^S X=$P(VAIN(3),U,2);12.4;.09R"
I 'VAIN(1) S DR=".11R;.04R//^S X=$G(IDEF);2R;.09R"
EDT ;EDIT/DELETE 2529-3
I $G(RMPRDA)>0,$G(RMPRDA)'="" G ST
K DR,DIC D DIV4^RMPRSIT G:$D(X) EXIT1
S RMPREDIT=1
S DIC="^RMPR(664.1,",DIC(0)="AEQM",DR=".01"
;screen on complete, delete status
S DIC("S")="I $P(^(0),U,17)'=""D""&($P(^(0),U,17)'=""C"")"
S DIC("W")="D EN3^RMPRD1"
D ^DIC K DIC
G:+Y'>0 EXIT1 S RMPRDA=+Y
I $G(RMPRDA)'>0 Q
L +^RMPR(664.1,RMPRDA,0):1
I '$T W $C(7),!!,?5,"Someone is already editing this entry" G EXIT
D DSP^RMPR29R K DIR
S DIR(0)="Y",DIR("A")="Would you like to Edit this Entry"
S DIR("B")="YES" D ^DIR
G:$D(DTOUT)!($D(DIRUT)) EXIT K DKILL,IKILL G:+Y=0 DEL
ST ;set data in 2529-3 file
S RMPRDFN=$P(^RMPR(664.1,RMPRDA,0),U,2),DA=RMPRDA,DIE="^RMPR(664.1,"
I '$D(DR),'$D(^RMPR(664.1,RMPRDA,"CDR")) S DR=".11R;.04;2R;.09R"
I '$D(DR),$D(^RMPR(664.1,RMPRDA,"CDR")) S DR=".11R;.04R;2R;12;12.1;12.2;12.3;12.4;.09R"
D ^DIE G:$D(Y)!($D(DTOUT)) CHK^RMPR29D
GD ;Display work order
D DIS^RMPR29W(RMPRDFN,RMPRDA) G:$G(X)="^" CHK^RMPR29D G:+Y'>0 ITM
K DR,DA,DIC,DIE
S DIC="^RMPR(664.1,"_RMPRDA_",1,"
S DIC("P")="664.15PA",DA(1)=RMPRDA
S DIC(0)="EQMZL",X=Y(0,0),ELG=$P(Y(0),U,3)
D ^DIC
I +Y'>0 K DIC G GD
S DIE=DIC K DIC
S DA(1)=RMPRDA,DA=+Y
S DR="1///^S X=ELG;.01;1"
D ^DIE G:$D(DTOUT)!($D(Y)) CHK^RMPR29D G GD
ITM ;EDIT 2529-3 ITEM
K DIR S DA=RMPRDA,DIC="^RMPR(664.1,"_RMPRDA_",2,"
S DIC("P")="664.16PA",DA(1)=RMPRDA,DIC(0)="AEQMZL"
S DIC("W")="S RA=$P(^(0),U,1) I +RA W ?16,$$ITM^RMPR31U(RA)"
D ^DIC K DIC G:+Y'>0 CHK^RMPR29D
S RY=$P(Y,U,2) D ITA^RMPR29U(RY)
S DA=+Y,DIE="^RMPR(664.1,"_RMPRDA_",2,"
S DR="8R;9R;13;7;2R;3R;12"
D ^DIE G:$D(DTOUT) CHK^RMPR29D
S RMTYPE=$P(^RMPR(664.1,RMPRDA,2,DA,0),U,7)
I $D(DA) S RDATA=RMTYPE_"^"_RMPRDA_"^"_DA D CHKCPT^RMPR29U(RDATA)
I $D(DA) S RY=$P(^RMPR(664.1,DA(1),2,DA,0),U),HCPCS=$P($G(^(2)),U,1),RMCPT=$P($G(^(2)),U,2) D ITA^RMPR29U(RY)
K RMTYPE,RDATA,RMCPT
D G ITM
LAB ;ASK TO POST REQUEST
S DIR(0)="Y",DIR("A")="Would you like to review this request"
S DIR("B")="YES" D ^DIR G:$D(DTOUT)!($D(DIRUT)) EXIT
I Y=1 S IOP="HOME" D PRT^RMPR29R
K DIR S DIR(0)="Y",DIR("A")="Would you like to post this request"
S DIR("B")="YES" D ^DIR G:$D(DTOUT)!($D(DIRUT)) EXIT
I +Y=0 W !!,?5,$C(7),"Request not posted!!" G:$D(RMPR25) RDL G EXIT
;set temp transaction flag if needed
K RMPRTMP I $P(^RMPR(664.1,RMPRDA,0),U,15)'=RMPR("STA") S RMPRTMP=1
S RMPRWO=$P(^RMPR(664.1,RMPRDA,0),U,13) G:RMPRWO'="" SG S SCR=$P(^(0),U,11)
D CR^RMPR29U(SCR)
I '$D(RMPRWO) W !!,?5,$C(7),"Request not posted!!" G EXIT
SG ;set 2529-3 global
S $P(^RMPR(664.1,RMPRDA,0),U,13)=$G(RMPRWO)
;set no admin count/no lab count
I $P(^RMPR(664.1,RMPRDA,0),U,15)=RMPR("STA")&($P(^(0),U,4)'=RMPR("STA")) S $P(^(0),U,23)=1
I $P(^RMPR(664.1,RMPRDA,0),U,15)'=RMPR("STA") S $P(^(0),U,20)=1 S:$D(RMPR25) $P(^RMPR(664.1,RMPRDA,0),U,23)=1 S DIE="^RMPR(664.1,",DA=RMPRDA,DR="16///^S X=""PC""" D ^DIE
I '$P(^RMPR(664.1,RMPRDA,0),U,20) S DIE="^RMPR(664.1,",DA=RMPRDA,DR="16///^S X=""P""" D ^DIE
S $P(^RMPR(664.1,RMPRDA,0),U,5)=DUZ,$P(^(0),U,18)=DT D ^RMPR29A
I $G(RMPRWO)'="" W !!,?5,"Assigned Work Order Number: ",RMPRWO D:'$D(RMPRTMP) LOC^RMPR29R
;added by #62
I $G(DA660),'$D(^RMPR(660,DA660,10)) D
.S (RMPCAMIS,RMPRDFN)=""
.S RMPCAMIS=$G(^RMPR(660,DA660,"AMS"))
.S:$D(^RMPR(660,DA660,0)) RMPRDFN=$P(^RMPR(660,DA660,0),U,2)
.I RMPCAMIS,RMPRDFN S ^TMP($J,"RMPRPCE",660,DA660)=RMPCAMIS_"^"_RMPRDFN
;suspense record inquiry
D LINK^RMPRS
W !! S DIR(0)="Y",DIR("A")="Would you like to print this 2529-3 request"
S DIR("B")="YES" D ^DIR G:$D(DTOUT)!($D(DIRUT)) EXIT
I Y=1 D PRT^RMPR29R
;
EXIT ;common exit point for both RMPR29 and RMPR29A
;
L:+$G(RMPRDA) -^RMPR(664.1,+RMPRDA,0)
S:$D(RMPR25)&($D(RMPRDA)) RMPRRDA=RMPRDA
I '$D(RMPR25)&('$D(RMPREDIT)) W !! S DIR(0)="Y",DIR("A")="Would you like to Process another 2529-3 Request",DIR("B")="YES" D ^DIR G:+Y=1 CREATE
D KVAR^VADPT
K ^TMP($J,"RMPRPCE")
N RMPR,RMPRSITE D KILL^XUSCLEAN
Q
EXIT1 ;exit on error
L:+$G(RMPRDA) -^RMPR(664.1,+RMPRDA,0)
N RMPR,RMPRSITE D KVAR^VADPT,KILL^XUSCLEAN Q
DEL ;delete status 2529-3
K DIR,Y
S DIR(0)="Y",DIR("A")="Would you like to Delete this 2529-3 Entry"
S DIR("B")="NO" D ^DIR G:$D(DTOUT)!($D(DIRUT)) EXIT1
;if not drop into edit mode
I +Y=0 G:$D(DKILL) GD G:$D(IKILL) ITM G CHK^RMPR29D
;if it has a work order number, only mark as deleted
;delete entry in the 2319 record.
N BO
S BO=0
F S BO=$O(^RMPR(664.1,RMPRDA,2,BO)) Q:BO'>0 D
.S DA=$P(^RMPR(664.1,RMPRDA,2,BO,0),U,5)
.Q:DA=""
.S DIK="^RMPR(660," D ^DIK
W !,?5,"Updated 10-2319"
K DA,DIK
I $P(^RMPR(664.1,RMPRDA,0),U,13)'="" S DIE="^RMPR(664.1,",DA=RMPRDA,DR="16///^S X=""D""" D ^DIE W !,?5,$C(7),"Marked As Deleted..." G EXIT
RDL ;delete record
;the record is only deleted from 664.1 when the user creats a new
;and then at end say's no do not post. Once it is posted, then
;it must only be marked as deleted.
S DA=RMPRDA,DIK="^RMPR(664.1,"
D ^DIK K DIK W !!,?5,$C(7),"Deleted..."
;delete the 2319 record
N BO
S DA=0,BO=0
F S BO=$O(^RMPR(664.1,RMPRDA,2,BO)) Q:BO'>0 D
.S DA=$P(^RMPR(664.1,RMPRDA,2,BO,0),U,5)
.Q:DA=""
.S DIK="^RMPR(660," D ^DIK
K DIK,DA,RMPRDA
W !!,?5,"Updated 10-2319",!
G EXIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR29 6281 printed Oct 16, 2024@18:32:39 Page 2
RMPR29 ;PHX/JLT-ENTER/EDIT 2529-3 [ 10/01/94 5:29 AM ]
+1 ;;3.0;PROSTHETICS;**12,41,62,128**;Feb 09, 1996
+2 ;RVD patch #62 - PCE and suspense link
CREATE ;CREATE 2529-3
+1 KILL RMPREDIT,RMPRTMP,RMPR25,^TMP($JOB,"RMPRPCE")
DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT1
+2 DO GETPAT^RMPRUTIL
IF '$DATA(RMPRDFN)
GOTO EXIT1
VIEW ;CREATE 2529-3 VIA LAB MENU
+1 NEW RMPRDA,RMPRWO,RMPRJOB
SET RMPRF=4
DO ^RMPRPAT
IF $DATA(RMPRKILL)
GOTO EXIT
+2 SET DIC="^RMPR(664.1,"
SET DIC(0)="ZL"
SET X=DT
+3 SET DLAYGO=664.1
DO FILE^DICN
KILL DLAYGO,DIC
+4 if +Y'>0
GOTO EXIT1
+5 SET RMPRDA=+Y
SET $PIECE(^RMPR(664.1,RMPRDA,0),U,2)=RMPRDFN
SET $PIECE(^(0),U,3)=RMPR("STA")
SET $PIECE(^(0),U,17)="I"
+6 SET IDEF=$$STA^RMPR31U(RMPR("STA"))
+7 SET DA=RMPRDA
SET DIK="^RMPR(664.1,"
DO IX1^DIK
+8 KILL DR,DA,DIC,Y,DIE
DO KVAR^VADPT
+9 SET DFN=$PIECE(^RMPR(664.1,RMPRDA,0),U,2)
SET VAIP("D")="L"
+10 DO IN5^VADPT
SET VAINDT=$PIECE($GET(VAIP(3)),U)
DO INP^VADPT
+11 IF VAIN(1)
SET DR=".11R;.04R//^S X=$G(IDEF);2R;12//^S X=$P(VAIN(4),U,2);12.1//^S X=$P(VAIN(2),U,2);12.2//^S X=VAIN(9);12.3//^S X=$P(VAIN(3),U,2);12.4;.09R"
+12 IF 'VAIN(1)
SET DR=".11R;.04R//^S X=$G(IDEF);2R;.09R"
EDT ;EDIT/DELETE 2529-3
+1 IF $GET(RMPRDA)>0
IF $GET(RMPRDA)'=""
GOTO ST
+2 KILL DR,DIC
DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT1
+3 SET RMPREDIT=1
+4 SET DIC="^RMPR(664.1,"
SET DIC(0)="AEQM"
SET DR=".01"
+5 ;screen on complete, delete status
+6 SET DIC("S")="I $P(^(0),U,17)'=""D""&($P(^(0),U,17)'=""C"")"
+7 SET DIC("W")="D EN3^RMPRD1"
+8 DO ^DIC
KILL DIC
+9 if +Y'>0
GOTO EXIT1
SET RMPRDA=+Y
+10 IF $GET(RMPRDA)'>0
QUIT
+11 LOCK +^RMPR(664.1,RMPRDA,0):1
+12 IF '$TEST
WRITE $CHAR(7),!!,?5,"Someone is already editing this entry"
GOTO EXIT
+13 DO DSP^RMPR29R
KILL DIR
+14 SET DIR(0)="Y"
SET DIR("A")="Would you like to Edit this Entry"
+15 SET DIR("B")="YES"
DO ^DIR
+16 if $DATA(DTOUT)!($DATA(DIRUT))
GOTO EXIT
KILL DKILL,IKILL
if +Y=0
GOTO DEL
ST ;set data in 2529-3 file
+1 SET RMPRDFN=$PIECE(^RMPR(664.1,RMPRDA,0),U,2)
SET DA=RMPRDA
SET DIE="^RMPR(664.1,"
+2 IF '$DATA(DR)
IF '$DATA(^RMPR(664.1,RMPRDA,"CDR"))
SET DR=".11R;.04;2R;.09R"
+3 IF '$DATA(DR)
IF $DATA(^RMPR(664.1,RMPRDA,"CDR"))
SET DR=".11R;.04R;2R;12;12.1;12.2;12.3;12.4;.09R"
+4 DO ^DIE
if $DATA(Y)!($DATA(DTOUT))
GOTO CHK^RMPR29D
GD ;Display work order
+1 DO DIS^RMPR29W(RMPRDFN,RMPRDA)
if $GET(X)="^"
GOTO CHK^RMPR29D
if +Y'>0
GOTO ITM
+2 KILL DR,DA,DIC,DIE
+3 SET DIC="^RMPR(664.1,"_RMPRDA_",1,"
+4 SET DIC("P")="664.15PA"
SET DA(1)=RMPRDA
+5 SET DIC(0)="EQMZL"
SET X=Y(0,0)
SET ELG=$PIECE(Y(0),U,3)
+6 DO ^DIC
+7 IF +Y'>0
KILL DIC
GOTO GD
+8 SET DIE=DIC
KILL DIC
+9 SET DA(1)=RMPRDA
SET DA=+Y
+10 SET DR="1///^S X=ELG;.01;1"
+11 DO ^DIE
if $DATA(DTOUT)!($DATA(Y))
GOTO CHK^RMPR29D
GOTO GD
ITM ;EDIT 2529-3 ITEM
+1 KILL DIR
SET DA=RMPRDA
SET DIC="^RMPR(664.1,"_RMPRDA_",2,"
+2 SET DIC("P")="664.16PA"
SET DA(1)=RMPRDA
SET DIC(0)="AEQMZL"
+3 SET DIC("W")="S RA=$P(^(0),U,1) I +RA W ?16,$$ITM^RMPR31U(RA)"
+4 DO ^DIC
KILL DIC
if +Y'>0
GOTO CHK^RMPR29D
+5 SET RY=$PIECE(Y,U,2)
DO ITA^RMPR29U(RY)
+6 SET DA=+Y
SET DIE="^RMPR(664.1,"_RMPRDA_",2,"
+7 SET DR="8R;9R;13;7;2R;3R;12"
+8 DO ^DIE
if $DATA(DTOUT)
GOTO CHK^RMPR29D
+9 SET RMTYPE=$PIECE(^RMPR(664.1,RMPRDA,2,DA,0),U,7)
+10 IF $DATA(DA)
SET RDATA=RMTYPE_"^"_RMPRDA_"^"_DA
DO CHKCPT^RMPR29U(RDATA)
+11 IF $DATA(DA)
SET RY=$PIECE(^RMPR(664.1,DA(1),2,DA,0),U)
SET HCPCS=$PIECE($GET(^(2)),U,1)
SET RMCPT=$PIECE($GET(^(2)),U,2)
DO ITA^RMPR29U(RY)
+12 KILL RMTYPE,RDATA,RMCPT
D GOTO ITM
LAB ;ASK TO POST REQUEST
+1 SET DIR(0)="Y"
SET DIR("A")="Would you like to review this request"
+2 SET DIR("B")="YES"
DO ^DIR
if $DATA(DTOUT)!($DATA(DIRUT))
GOTO EXIT
+3 IF Y=1
SET IOP="HOME"
DO PRT^RMPR29R
+4 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Would you like to post this request"
+5 SET DIR("B")="YES"
DO ^DIR
if $DATA(DTOUT)!($DATA(DIRUT))
GOTO EXIT
+6 IF +Y=0
WRITE !!,?5,$CHAR(7),"Request not posted!!"
if $DATA(RMPR25)
GOTO RDL
GOTO EXIT
+7 ;set temp transaction flag if needed
+8 KILL RMPRTMP
IF $PIECE(^RMPR(664.1,RMPRDA,0),U,15)'=RMPR("STA")
SET RMPRTMP=1
+9 SET RMPRWO=$PIECE(^RMPR(664.1,RMPRDA,0),U,13)
if RMPRWO'=""
GOTO SG
SET SCR=$PIECE(^(0),U,11)
+10 DO CR^RMPR29U(SCR)
+11 IF '$DATA(RMPRWO)
WRITE !!,?5,$CHAR(7),"Request not posted!!"
GOTO EXIT
SG ;set 2529-3 global
+1 SET $PIECE(^RMPR(664.1,RMPRDA,0),U,13)=$GET(RMPRWO)
+2 ;set no admin count/no lab count
+3 IF $PIECE(^RMPR(664.1,RMPRDA,0),U,15)=RMPR("STA")&($PIECE(^(0),U,4)'=RMPR("STA"))
SET $PIECE(^(0),U,23)=1
+4 IF $PIECE(^RMPR(664.1,RMPRDA,0),U,15)'=RMPR("STA")
SET $PIECE(^(0),U,20)=1
if $DATA(RMPR25)
SET $PIECE(^RMPR(664.1,RMPRDA,0),U,23)=1
SET DIE="^RMPR(664.1,"
SET DA=RMPRDA
SET DR="16///^S X=""PC"""
DO ^DIE
+5 IF '$PIECE(^RMPR(664.1,RMPRDA,0),U,20)
SET DIE="^RMPR(664.1,"
SET DA=RMPRDA
SET DR="16///^S X=""P"""
DO ^DIE
+6 SET $PIECE(^RMPR(664.1,RMPRDA,0),U,5)=DUZ
SET $PIECE(^(0),U,18)=DT
DO ^RMPR29A
+7 IF $GET(RMPRWO)'=""
WRITE !!,?5,"Assigned Work Order Number: ",RMPRWO
if '$DATA(RMPRTMP)
DO LOC^RMPR29R
+8 ;added by #62
+9 IF $GET(DA660)
IF '$DATA(^RMPR(660,DA660,10))
Begin DoDot:1
+10 SET (RMPCAMIS,RMPRDFN)=""
+11 SET RMPCAMIS=$GET(^RMPR(660,DA660,"AMS"))
+12 if $DATA(^RMPR(660,DA660,0))
SET RMPRDFN=$PIECE(^RMPR(660,DA660,0),U,2)
+13 IF RMPCAMIS
IF RMPRDFN
SET ^TMP($JOB,"RMPRPCE",660,DA660)=RMPCAMIS_"^"_RMPRDFN
End DoDot:1
+14 ;suspense record inquiry
+15 DO LINK^RMPRS
+16 WRITE !!
SET DIR(0)="Y"
SET DIR("A")="Would you like to print this 2529-3 request"
+17 SET DIR("B")="YES"
DO ^DIR
if $DATA(DTOUT)!($DATA(DIRUT))
GOTO EXIT
+18 IF Y=1
DO PRT^RMPR29R
+19 ;
EXIT ;common exit point for both RMPR29 and RMPR29A
+1 ;
+2 if +$GET(RMPRDA)
LOCK -^RMPR(664.1,+RMPRDA,0)
+3 if $DATA(RMPR25)&($DATA(RMPRDA))
SET RMPRRDA=RMPRDA
+4 IF '$DATA(RMPR25)&('$DATA(RMPREDIT))
WRITE !!
SET DIR(0)="Y"
SET DIR("A")="Would you like to Process another 2529-3 Request"
SET DIR("B")="YES"
DO ^DIR
if +Y=1
GOTO CREATE
+5 DO KVAR^VADPT
+6 KILL ^TMP($JOB,"RMPRPCE")
+7 NEW RMPR,RMPRSITE
DO KILL^XUSCLEAN
+8 QUIT
EXIT1 ;exit on error
+1 if +$GET(RMPRDA)
LOCK -^RMPR(664.1,+RMPRDA,0)
+2 NEW RMPR,RMPRSITE
DO KVAR^VADPT
DO KILL^XUSCLEAN
QUIT
DEL ;delete status 2529-3
+1 KILL DIR,Y
+2 SET DIR(0)="Y"
SET DIR("A")="Would you like to Delete this 2529-3 Entry"
+3 SET DIR("B")="NO"
DO ^DIR
if $DATA(DTOUT)!($DATA(DIRUT))
GOTO EXIT1
+4 ;if not drop into edit mode
+5 IF +Y=0
if $DATA(DKILL)
GOTO GD
if $DATA(IKILL)
GOTO ITM
GOTO CHK^RMPR29D
+6 ;if it has a work order number, only mark as deleted
+7 ;delete entry in the 2319 record.
+8 NEW BO
+9 SET BO=0
+10 FOR
SET BO=$ORDER(^RMPR(664.1,RMPRDA,2,BO))
if BO'>0
QUIT
Begin DoDot:1
+11 SET DA=$PIECE(^RMPR(664.1,RMPRDA,2,BO,0),U,5)
+12 if DA=""
QUIT
+13 SET DIK="^RMPR(660,"
DO ^DIK
End DoDot:1
+14 WRITE !,?5,"Updated 10-2319"
+15 KILL DA,DIK
+16 IF $PIECE(^RMPR(664.1,RMPRDA,0),U,13)'=""
SET DIE="^RMPR(664.1,"
SET DA=RMPRDA
SET DR="16///^S X=""D"""
DO ^DIE
WRITE !,?5,$CHAR(7),"Marked As Deleted..."
GOTO EXIT
RDL ;delete record
+1 ;the record is only deleted from 664.1 when the user creats a new
+2 ;and then at end say's no do not post. Once it is posted, then
+3 ;it must only be marked as deleted.
+4 SET DA=RMPRDA
SET DIK="^RMPR(664.1,"
+5 DO ^DIK
KILL DIK
WRITE !!,?5,$CHAR(7),"Deleted..."
+6 ;delete the 2319 record
+7 NEW BO
+8 SET DA=0
SET BO=0
+9 FOR
SET BO=$ORDER(^RMPR(664.1,RMPRDA,2,BO))
if BO'>0
QUIT
Begin DoDot:1
+10 SET DA=$PIECE(^RMPR(664.1,RMPRDA,2,BO,0),U,5)
+11 if DA=""
QUIT
+12 SET DIK="^RMPR(660,"
DO ^DIK
End DoDot:1
+13 KILL DIK,DA,RMPRDA
+14 WRITE !!,?5,"Updated 10-2319",!
+15 GOTO EXIT
