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

RMPRE29C.m

Go to the documentation of this file.
  1. RMPRE29C ;PHX/JLT,RVD-EDIT 2319 ;10/2/03 13:04
  1. ;;3.0;PROSTHETICS;**150**;Feb 09, 1996;Build 10
  1. ;
  1. ;Used to carve out edting of Vendor, Quantity and Cost
  1. ;uses DBIA # 1995 & 1997.
  1. W ! S DIC="^RMPR(660,",DIC(0)="AEMQZ",DIC("A")="Select PATIENT: "
  1. S DIC("W")="D EN^RMPRD1",RMEND=0
  1. S DIC("S")="I ($P(^(0),U,6)!($P(^(0),U,26)'="""")),($P(^(0),U,13)'=11)" W !
  1. D ^DIC G:+Y'>0 EXIT L +^RMPR(660,+Y,0):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT
  1. S DIE=DIC,(RMPRDA,DA)=+Y
  1. S R1(0)=$G(^RMPR(660,RMPRDA,0)),R1(1)=$G(^(1)),R1("AM")=$G(^("AM"))
  1. S RMTOTCOS=$P(R1(0),U,16)
  1. ;
  1. S DR="7;5;14" D ^DIE
  1. I RMTOTCOS'=$P(^RMPR(660,DA,0),U,16) S DR="35////^S X=DUZ;36////^S X=DT" D ^DIE
  1. I $D(DTOUT)!('$G(Y))!($D(DUOUT))
  1. L -^RMPR(660,RMPRDA,0)
  1. K DIR W ! S DIR(0)="Y",DIR("A")="Would You like to Edit another Entry (Y/N) " D ^DIR
  1. G:'$D(DTOUT)&(Y>0) RMPRE29C
  1. EXIT ;
  1. N RMPR,RMPRSITE D KILL^XUSCLEAN
  1. K DIC,DIE,DIR,%,X,Y
  1. Q