Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPRC21

RMPRC21.m

Go to the documentation of this file.
  1. RMPRC21 ;PHX/HNB-CANCEL A 1358 PROSTHETIC REQUEST ;8/29/1994
  1. ;;3.0;PROSTHETICS;**62**;Feb 09, 1996
  1. ;
  1. ; RVD patch # 62 - call pce delete if PCE was recorded and cancelled.
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. EN ;entry point for Cancel a Transaction Option
  1. D DIV4^RMPRSIT G:$D(X) EXIT
  1. S PRCS("A")="Select OBLIGATION NUMBER: " D EN1^PRCS58 G:Y=-1 EXIT
  1. S RMPROB=$P(Y,U,2),RMPR("OB")=$P(Y(0),U,1)
  1. S DIC("A")="Select TRANSACTION: "
  1. S DIC("S")="S R90=^(0) I $P(R90,U,3)=RMPR(""OB""),('$P(R90,U,5)&'$P(R90,U,8)),($P(R90,U,14)=RMPR(""STA""))" I RMPRSITE=1 S DIC("S")=DIC("S")_"!($P(R90,U,14)="""")"
  1. S DIC="^RMPR(664,",DIC(0)="AEQM",DIC("W")="D EN2^RMPRD1"
  1. D ^DIC G:Y<0 EXIT S RMPRA=+Y K R90
  1. CL S B2=^RMPR(664,RMPRA,0) G:$P(B2,U,8) M4 G:$P(B2,U,5) M6
  1. L +^RMPR(664,RMPRA,0):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT
  1. K DIC,Y,DA S X=$P(B2,U,7),DIC=424,DIC(0)="MZ"
  1. D ^DIC S $P(B2,U,7)=+Y
  1. S RMPRDFN=$P(^RMPR(664,RMPRA,0),U,2),RMPRWO=$P(^(0),U,15),RMPRDA=$P(^(0),U,17),RMPRNAM=$P(^DPT(RMPRDFN,0),U,1),RMPRSSN=$P(^(0),U,9)
  1. D ^RMPRLI
  1. A W !!,"Do you really want to CANCEL this Transaction" S %=0 D YN^DICN G:%<0!(%=2) EXIT G:%=0 H
  1. S RMPRAR=$S($P(^RMPR(664,RMPRA,0),U,12)'="":$P(^(0),U,12),1:""),$P(^(0),U,12)=""
  1. D:RMPRAR'="" K660
  1. Q:$G(RMPRA)'>0
  1. S R1=0 F S R1=$O(^RMPR(664,RMPRA,1,R1)) Q:R1'>0 S RMPRAR=$S($P(^RMPR(664,RMPRA,1,R1,0),U,13)'="":$P(^(0),U,13),1:""),$P(^(0),U,13)="" G:RMPRAR="" M3 D K660
  1. C58 ;CLOSE OUT IFCAP DAILY RECORD
  1. I $D(RMPRWO),RMPRWO D D CA0^RMPR29M(RMPRDA,RMPRA)
  1. .S $P(^RMPR(664.2,RMPRWO,0),U,16,17)="" F DA=0:0 S DA=$O(^RMPR(664.2,RMPRWO,1,"AC",RMPRA,DA)) Q:DA'>0 S DIK="^RMPR(664.2,"_RMPRWO_",1,",DA(1)=RMPRWO D ^DIK
  1. I $P(B2,U,7)'>0 W !,$C(7),"DID NOT HAVE AN IFCAP DAILY RECORD" G K664
  1. D NOW^%DTC S PRCSX=$P(B2,U,7)_U_%_U_0_U_"Canceled"_U_1 D ^PRCS58CC
  1. I +Y=0 W !,$C(7),$C(7),"FAILED TO CLOSE IFCAP DAILY RECORD FOR THE FOLLOWING REASON ",$P(Y,U,2),!,"PLEASE CONTACT YOUR APPLICATION COORDINATOR!"
  1. G K664
  1. K660 ;DELETE APPLIANCE/REPAIR RECORDS
  1. D SS660 Q:$G(RMPRAR)'>0
  1. ;modified by #62
  1. ;call pce delete if patient encounter was recorded
  1. I $D(^RMPR(660,RMPRAR,10)),$P(^RMPR(660,RMPRAR,10),U,12) D
  1. .S RMCHK=0
  1. .S RMCHK=$$PCED^RMPRPCEP(RMPRAR)
  1. ;
  1. S DA=RMPRAR,DIK="^RMPR(660," D ^DIK W "."
  1. K RMPRAR
  1. Q
  1. SS660 ;set new status in 660.5
  1. W !!,"CANCELLING THE OBLIGATION!"
  1. I $G(RMPRF)'>0 S RMPRF=$P($G(^RMPR(664,RMPRA,2)),U,4)
  1. Q
  1. K664 ;CANCEL FLAG
  1. S $P(^RMPR(664,RMPRA,0),"^",5)=DT,$P(^RMPR(664,RMPRA,2),"^",2)=DUZ
  1. S DA=RMPRA,DR="3.1",DIE="^RMPR(664," D ^DIE W !,$C(7),$C(7),"Transaction Canceled and Deleted..." D LINK^RMPRS
  1. ;
  1. EXIT L:$D(RMPRA) -^RMPR(664,RMPRA,0)
  1. K LINE,PRCSCPAN,PRCSIP,RMPR("OB"),RMPRAMIS,RMPRA,RMPRAR,RMPRCNT
  1. K RMPRI,RMPRIT,RMPRIT1,RMPRU,RMPRX,X,PRCS,DIE,PRCSX,RMPRDFN,RMPRNAM
  1. K RMPROB,RMPRSSN,DR,PRC,RMPRC,DIC,DIK,%,R1,DA,B2,RMPRCK,DIC
  1. K DIK,I,Y,RAC,R90,RMPRN,^TMP($J)
  1. Q
  1. H W !,"By entering Yes, this will Delete the transaction in Prosthetics, and Cancel the Transaction in IFCAP." G A
  1. H2 W !,"By entering Yes, this will Cancel the Transaction in IFCAP,and NOT UPDATE the 10-2319." G M3A
  1. M3 W !,$C(7),$C(7),"TRANSACTION MISSING APPLIANCE/REPAIR RECORD!"
  1. M3A W !,"Do you still want to CANCEL this Transaction" S %=0 D YN^DICN G:%<0!(%=2) EXIT G:%=0 H2 G C58
  1. M4 W !,$C(7),$C(7),"This Transaction has already been Closed!" G EXIT
  1. M6 W !,$C(7),$C(7),"This transaction has already been Canceled!" G EXIT