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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRAP 1800 printed Oct 16, 2024@18:34:34 Page 2
RMPRAP ;PHX/RFM-ADD NEW PROSTHETIC PATIENT ;8/29/1994
+1 ;;3.0;PROSTHETICS;;Feb 09, 1996
+2 IF '$DATA(RMPR)
DO DIV4^RMPRSIT
if $DATA(X)
QUIT
+3 KILL DIE,DIC,RMPRSSN,RMPRF,RMPRDOB,RMPRNAM,RMPRDFN,DA,X,Y
+4 DO GETPAT^RMPRUTIL
SET RMPRF="X"
+5 IF '$DATA(RMPRDFN)
GOTO EXIT
LOCK +^RMPR(665,DA,0):1
IF $TEST=0
WRITE !,?5,"Some one else is editing this entry!"
GOTO EXIT
+6 SET DA=RMPRDFN
SET DIE="^RMPR(665,"
SET DR=2
DO ^DIE
LOCK -^RMPR(665,RMPRDFN,0)
IF X=""
GOTO EXIT
DIS ;ADD PSC ITEMS TO PROSTHETICS PATIENT FILE
+1 if '$DATA(RMPRFLAG)
SET RMPRF=""
IF '$DATA(RMPRFLAG)
SET RMPRBAC1=1
DO ^RMPRPAT
+2 SET %=2
READ !,"Add/Edit/View Patient PSC"
DO YN^DICN
+3 IF $DATA(RMPRFLAG)
if %=2
QUIT
if %=1
GOTO COD
if %=0
GOTO MES
IF %=-1
SET RMPRDIE=1
QUIT
+4 if $DATA(DTOUT)
GOTO EXIT
if %<0
GOTO RMPRAP
if %=0
GOTO MES
if %=2
GOTO RMPRAP
COD SET RFL=1
DO DT^RMPRPSC
if $DATA(RMPRFLAG)
QUIT
PSC IF '$DATA(RFL)
KILL DIE
SET RFL=1
DO DT^RMPRPSC
if $DATA(RMPRFLAG)
QUIT
GOTO RMPRAP
EXIT if $DATA(RMPRFLAG)
QUIT
END KILL 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
QUIT
MES WRITE !,"Enter `YES` or `NO`"
GOTO DIS
CLA ;CLOTHING ALLOWANCE ENTER/EDIT
+1 KILL RMPRDFN
WRITE !
DO GETPAT^RMPRUTIL
if '$DATA(RMPRDFN)
GOTO END
+2 SET DIC="^RMPR(665,"_RMPRDFN_",6,"
if '$DATA(^RMPR(665,RMPRDFN,6,0))
SET ^RMPR(665,RMPRDFN,6,0)="^665.02DA^^"
CAE SET DA(1)=RMPRDFN
SET DIC="^RMPR(665,"_DA(1)_",6,"
if '$DATA(^RMPR(665,RMPRDFN,6,0))
SET ^RMPR(665,RMPRDFN,6,0)="^665.02DA^^"
SET DIC(0)="AEQMZL"
SET DLAYGO=665
DO ^DIC
KILL DLAYGO
if +Y'>0
GOTO CLA
SET DA(1)=RMPRDFN
SET (RMPRDA,DA)=+Y
SET DIE=DIC
+1 LOCK +^RMPR(665,DA(1),6):1
IF $TEST=0
WRITE !,$CHAR(7),"Someone else is Editing this entry!"
GOTO END
+2 SET 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;"
+3 DO ^DIE
LOCK -^RMPR(665,RMPRDFN,6)
+4 IF $DATA(DA)
IF $PIECE(^RMPR(665,RMPRDFN,6,DA,0),U,2)=""
SET DIK=DIC
SET DA(1)=RMPRDFN
DO ^DIK
WRITE !,$CHAR(7),?5,"Deleted..."
+5 WRITE !
GOTO CAE
