source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRAP.m@ 1700

RMPRAP ;PHX/RFM-ADD NEW PROSTHETIC PATIENT ;8/29/1994
 ;;3.0;PROSTHETICS;;Feb 09, 1996
 I '$D(RMPR) D DIV4^RMPRSIT Q:$D(X)
 K DIE,DIC,RMPRSSN,RMPRF,RMPRDOB,RMPRNAM,RMPRDFN,DA,X,Y
 D GETPAT^RMPRUTIL S RMPRF="X"
 I '$D(RMPRDFN) G EXIT L +^RMPR(665,DA,0):1 I $T=0 W !,?5,"Some one else is editing this entry!" G EXIT
 S DA=RMPRDFN,DIE="^RMPR(665,",DR=2 D ^DIE L -^RMPR(665,RMPRDFN,0) I X="" G EXIT
DIS ;ADD PSC ITEMS TO PROSTHETICS PATIENT FILE
 S:'$D(RMPRFLAG) RMPRF="" I '$D(RMPRFLAG) S RMPRBAC1=1 D ^RMPRPAT
 S %=2 R !,"Add/Edit/View Patient PSC" D YN^DICN
 I $D(RMPRFLAG) Q:%=2  G:%=1 COD G:%=0 MES I %=-1 S RMPRDIE=1 Q
 G EXIT:$D(DTOUT),RMPRAP:%<0,MES:%=0,RMPRAP:%=2
COD S RFL=1 D DT^RMPRPSC Q:$D(RMPRFLAG)
PSC I '$D(RFL) K DIE S RFL=1 D DT^RMPRPSC Q:$D(RMPRFLAG)  G RMPRAP
EXIT Q:$D(RMPRFLAG)
END K RMPRF,%,X,Y,RFL,RMPRDFN,RMPRDOB,RMPRE,RMPRNAM,RMPRSSN,RMPRX,RMPRHIS,RMPRDIS,PRC,RMPR1,RMPR2,RMPR3,RMPR4,DIR,DR,DIC,DIE,PRCSI,PRCSQTT,RMPR660,RMPRDA,RMPRDELN,RMPRKILL Q
MES W !,"Enter `YES` or `NO`" G DIS
CLA ;CLOTHING ALLOWANCE ENTER/EDIT
 K RMPRDFN W ! D GETPAT^RMPRUTIL G:'$D(RMPRDFN) END
 S DIC="^RMPR(665,"_RMPRDFN_",6," S:'$D(^RMPR(665,RMPRDFN,6,0)) ^RMPR(665,RMPRDFN,6,0)="^665.02DA^^"
CAE S DA(1)=RMPRDFN,DIC="^RMPR(665,"_DA(1)_",6," S:'$D(^RMPR(665,RMPRDFN,6,0)) ^RMPR(665,RMPRDFN,6,0)="^665.02DA^^" S DIC(0)="AEQMZL",DLAYGO=665 D ^DIC K DLAYGO G:+Y'>0 CLA S DA(1)=RMPRDFN,(RMPRDA,DA)=+Y,DIE=DIC
 L +^RMPR(665,DA(1),6):1 I $T=0 W !,$C(7),"Someone else is Editing this entry!" G END
 S DR=".01;1;I $P(^RMPR(665,DA(1),6,DA,0),U,2)=""N"" S Y=""@1"";2;@1;4;I $P(^RMPR(665,DA(1),6,DA,0),U,4)=""N"" S Y=""@2"";5;6;@2;3;"
 D ^DIE L -^RMPR(665,RMPRDFN,6)
 I $D(DA) I $P(^RMPR(665,RMPRDFN,6,DA,0),U,2)="" S DIK=DIC,DA(1)=RMPRDFN D ^DIK W !,$C(7),?5,"Deleted..."
 W ! G CAE