- 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 Mar 13, 2025@21:36:47 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
