RMPRAVR ;PHX/JLT-ADD MODIFY REPAIR AUTO ADPT ;8/29/1994
;;3.0;PROSTHETICS;;Feb 09, 1996
ENT ;ENTER AUTO-ADAPTIVE TRANSACTION
L +^RMPR(667,RMPRDA,0):1 I '$T W !,"Someone else is editing this record!" Q
W ! K DIR,DIC S DIC="^RMPR(667.1,",DIC(0)="AEQZ",DIC("A")="ITEM: ",DIC("W")="I $D(DZ) W:DZ[""?"" $E(^(0),31,70)" D ^DIC G:+Y'>0 EDT
S RMPRC(3)=+Y
S Y=RMPRC(5) D DD^%DT S DIR("B")=Y,DIR(0)="667.3,.01" D ^DIR G:$D(DTOUT)!($D(DIRUT)) EDT S RMPRC(5)=Y
K Y,DA,DIR S DIR(0)="667.3,8",DIR("B")="INITIAL ISSUE" D ^DIR G:$D(DTOUT)!(X["^") EDT S RMPRC(8)=Y
K Y,DA,DIR S DIR(0)="667.3,9",DIR("B")="SC/OP" D ^DIR G:$D(DTOUT)!(X["^") EDT S RMPRC(9)=Y
K DIR I $D(RMPRC(9)),RMPRC(9)=4 S DIR(0)="667.3,10" D ^DIR G:$D(DTOUT)!(X["^") EDT S RMPRC(10)=Y
K DIR,DA,Y S DIR(0)="667.3,11",DIR("B")="COMMERCIAL" D ^DIR G:$D(DTOUT)!(X["^") EDT S RMPRC(11)=Y
K Y,DA,DIR S DIR(0)="667.3,6" D ^DIR G:$D(DTOUT)!(X["^") EDT S RMPRC(6)=Y
K Y,DA S DIR(0)="667.3,3" D ^DIR G:$D(DTOUT)!($D(DIRUT)) EDT S RMPRC(4)=Y
K Y,DA S DIR(0)="667.3,2.5",DIR("B")=1 D ^DIR G:$D(DTOUT)!($D(DIRUT)) EDT S QTY=Y
FILE I $D(RMPRG) G GGC
L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC
S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1,$P(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0)
GGC S X=RMPRC(5),DIC(0)="ZL",DIC="^RMPR(667.3,",DLAYGO=667.3 K DD,DO D FILE^DICN I +Y'>0 W !!,$C(7),"RECORD NOT ENTERED SEE YOUR IRM SERVICE" G EXIT
S RDA=+Y,$P(^RMPR(667.3,RDA,0),U,2)=RMPRDA,$P(^(0),U,3)=RMPRC(3),$P(^(0),U,4)=RMPRC(4),$P(^(0),U,5)=RMPRAM,$P(^(0),U,6)=RMPRC(6),$P(^(0),U,7)=QTY,$P(^(0),U,8)=RMPRC(8),$P(^(0),U,9)=RMPRC(9)
S $P(^RMPR(667.3,RDA,0),U,11)=RMPRC(11) S:$D(RMPRC(10)) $P(^(0),U,10)=RMPRC(10) S ^(2)=RMPR("STA")_"^"_DUZ,^(3)=RMPRG,DA=RDA,DIK="^RMPR(667.3," D IX1^DIK S RMPRADD=1
S DA=RDA,DR="5",DIE="^RMPR(667.3," D ^DIE
K DA,DLAYGO G ENT
EDT I '$D(RMPRADD) W !!,?5,$C(7),"< NO RECORD ADDED >" G EXIT
W ! K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="Would you like to Edit/Delete an item " D ^DIR G:$D(DTOUT)!($D(DIRUT))!(Y=0) EXIT
LP D DSP G:'$D(RID) EDT
S DA=+Y,DR=".01;8;9;S:$P(^RMPR(667.3,DA,0),U,9)=""4"" Y=""@5"";10///@;11;2;6;4;3;2.5;5;S Y="""";@5;10;11;2;6;4;3;2.5;5",DIE="^RMPR(667.3," D ^DIE K:'$D(DA) RID(RY) G:$O(RID(0)) EDT
EXIT K DIR,DIC,DA,Y S DIR(0)="Y",DIR("B")="NO",DIR("A")="Would you like to add an another Item " W ! D ^DIR I +Y=1 G ENT
L:$D(RMPRDA) -^RMPR(667,RMPRDA,0) W:'$D(RMPRADD) !!,$C(7),"NO ITEMS ADDED TO THIS RECORD",! K RMPRDA,RMPRC,RMPRGO,RMPRADD,DIC,DIR,DIE,RDA,REX,RLF,RID,RMPRITM,RMPRED,RMPREP,RMRPITM,Y,RMPRG,RMPR45,DLAYGO
D:'$D(DTOUT) LINK^RMPRS K DR,RC,RV,RY,RMPRAM,RMPRDFN,RMPRDOB,RMPRNAM,RMPRSSN,RMPRR,RA,RAC,RB,RD,RE,RF,RK,RLP,QTY Q
LK ;LOOK UP
S RA=$P(^RMPR(667,+Y,0),U,2) I +RA W ?40,$E($P(^DPT(RA,0),U,1),1,15),?60,$P(^RMPR(667,+Y,0),U,7) K RAA
Q
EIT ;ENTER/EDIT AUTO-ADAPTIVE EQUIPMENT
S DIC=667.1,DIC(0)="AEQML",DLAYGO=667.1 D ^DIC K DLAYGO I +Y'>0 K DIC Q
S RMPRA=+Y L +^RMPR(667.1,+Y,0):1 I $T=0 W !,$C(7),?5,"Someone else is Editing this entry!" K DIC,DA,Y,RMPRA G EIT
S DA=+Y,DIE="^RMPR(667.1,",DR=".01" D ^DIE L -^RMPR(667.1,RMPRA,0) K DIC,DIE,DA,RMPRA,Y G EIT
EMN ;ENTER/EDIT VEHICLE MANUFACTURERS
S DIC=667.2,DIC(0)="AEQML",DLAYGO=667.2 D ^DIC K DLAYGO I +Y'>0 K DIC Q
S RMPRA=+Y L +^RMPR(667.2,+Y,0):3 I $T=0 W !,?5,$C(7),!,"Someone else is Editing the entry!" K DIC,DA,Y,RMPRA Q
S DA=+Y,DIE=667.2,DR=".01" D ^DIE L -^RMPR(667.2,RMPRA,0) K DIC,DA,Y,RMPRA G EMN
DSP ;DISPLAY ITEMS ON VEHICLE OF RECORD ENTRY
I '$D(^RMPR(667.3,"AD",RMPRDA)) W !!,"No Items for the V.O.R",$C(7) G EXIT
S RV=0 F RK=0:0 S RK=$O(^RMPR(667.3,"AD",RMPRDA,RK)) Q:RK'>0 F RE=0:0 S RE=$O(^RMPR(667.3,"AD",RMPRDA,RK,RE)) Q:RE'>0 I $D(^RMPR(667.3,RE,0)),$P(^(3),U)=RMPRG S RV=RV+1,RID(RV)=+RE_"^"_^(0)_"^"_$S($D(^(3)):^(3),1:0) D WR
Q:'$D(RID)
W ! K DIR S DIR(0)="N",DIR("A")="Please enter Item Number" D ^DIR I $D(DTOUT)!($D(DIRUT)) K RID Q
I $D(RID(+Y)) S RMPRR=$P(RID(Y),"^",2,13),RY=Y,Y=+RID(+Y) Q
W $C(7) G DSP
WR W !,RV W ?10 I $P(RID(RV),U,4),$D(^RMPR(667.1,$P(RID(RV),U,4),0)) W $E($P(^(0),U),1,30) W ?45,"$ ",$P(RID(RV),U,5) W ?60 W $S($P(RID(RV),U,6)["R":"REPAIR",$P(RID(RV),U,6)["A":"VAN MOD",$P(RID(RV),U,6)["B":"ADAP EQP",1:"UNK")
Q
DSPR ;DISPLAY REPAIR ITEMS ON VEHICLE OF RECORD
I '$D(^RMPR(667.3,"AD",RMPRDA)) W !!,"No Items for the V.O.R",$C(7) G EXIT
I $D(RMPRED) S RV=0,RI=0 F RK=0:0 S RK=$O(^RMPR(667.3,"AD",RMPRDA,RK)) Q:RK'>0 F RE=0:0 S RE=$O(^RMPR(667.3,"AD",RMPRDA,RK,RE)) Q:RE'>0 I $D(^RMPR(667.3,RE,0)) S RV=RV+1,RID(RV)=+RE_"^"_^(0) D WR
I $D(RMPREP) S RV=0,RI=0 F RK=0:0 S RK=$O(^RMPR(667.3,"AD",RMPRDA,RK)) Q:RK'>0 F RE=0:0 S RE=$O(^RMPR(667.3,"AD",RMPRDA,RK,RE)) Q:RE'>0 I $D(^RMPR(667.3,RE,0)),$P(^(0),U,8)'="X" S RV=RV+1,RID(RV)=+RE_"^"_^(0) D WR
Q:'$D(RID)
W ! K DIR S DIR(0)="N",DIR("A")="Please enter Item Number" D ^DIR I $D(DTOUT)!($D(DIRUT)) K RID Q
I $D(RID(+Y)) S RMPRR=$P(RID(Y),"^",2,13),RY=Y,Y=+RID(+Y) Q
W $C(7) G DSPR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRAVR 4983 printed Apr 09, 2024@21:37:27 Page 2
RMPRAVR ;PHX/JLT-ADD MODIFY REPAIR AUTO ADPT ;8/29/1994
+1 ;;3.0;PROSTHETICS;;Feb 09, 1996
ENT ;ENTER AUTO-ADAPTIVE TRANSACTION
+1 LOCK +^RMPR(667,RMPRDA,0):1
IF '$TEST
WRITE !,"Someone else is editing this record!"
QUIT
+2 WRITE !
KILL DIR,DIC
SET DIC="^RMPR(667.1,"
SET DIC(0)="AEQZ"
SET DIC("A")="ITEM: "
SET DIC("W")="I $D(DZ) W:DZ[""?"" $E(^(0),31,70)"
DO ^DIC
if +Y'>0
GOTO EDT
+3 SET RMPRC(3)=+Y
+4 SET Y=RMPRC(5)
DO DD^%DT
SET DIR("B")=Y
SET DIR(0)="667.3,.01"
DO ^DIR
if $DATA(DTOUT)!($DATA(DIRUT))
GOTO EDT
SET RMPRC(5)=Y
+5 KILL Y,DA,DIR
SET DIR(0)="667.3,8"
SET DIR("B")="INITIAL ISSUE"
DO ^DIR
if $DATA(DTOUT)!(X["^")
GOTO EDT
SET RMPRC(8)=Y
+6 KILL Y,DA,DIR
SET DIR(0)="667.3,9"
SET DIR("B")="SC/OP"
DO ^DIR
if $DATA(DTOUT)!(X["^")
GOTO EDT
SET RMPRC(9)=Y
+7 KILL DIR
IF $DATA(RMPRC(9))
IF RMPRC(9)=4
SET DIR(0)="667.3,10"
DO ^DIR
if $DATA(DTOUT)!(X["^")
GOTO EDT
SET RMPRC(10)=Y
+8 KILL DIR,DA,Y
SET DIR(0)="667.3,11"
SET DIR("B")="COMMERCIAL"
DO ^DIR
if $DATA(DTOUT)!(X["^")
GOTO EDT
SET RMPRC(11)=Y
+9 KILL Y,DA,DIR
SET DIR(0)="667.3,6"
DO ^DIR
if $DATA(DTOUT)!(X["^")
GOTO EDT
SET RMPRC(6)=Y
+10 KILL Y,DA
SET DIR(0)="667.3,3"
DO ^DIR
if $DATA(DTOUT)!($DATA(DIRUT))
GOTO EDT
SET RMPRC(4)=Y
+11 KILL Y,DA
SET DIR(0)="667.3,2.5"
SET DIR("B")=1
DO ^DIR
if $DATA(DTOUT)!($DATA(DIRUT))
GOTO EDT
SET QTY=Y
FILE IF $DATA(RMPRG)
GOTO GGC
+1 LOCK +^RMPR(669.9,RMPRSITE,0):999
IF $TEST=0
SET RMPRG=DT_99
GOTO GGC
+2 SET RMPRG=$PIECE(^RMPR(669.9,RMPRSITE,0),U,7)
SET RMPRG=RMPRG-1
SET $PIECE(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG
LOCK -^RMPR(669.9,RMPRSITE,0)
GGC SET X=RMPRC(5)
SET DIC(0)="ZL"
SET DIC="^RMPR(667.3,"
SET DLAYGO=667.3
KILL DD,DO
DO FILE^DICN
IF +Y'>0
WRITE !!,$CHAR(7),"RECORD NOT ENTERED SEE YOUR IRM SERVICE"
GOTO EXIT
+1 SET RDA=+Y
SET $PIECE(^RMPR(667.3,RDA,0),U,2)=RMPRDA
SET $PIECE(^(0),U,3)=RMPRC(3)
SET $PIECE(^(0),U,4)=RMPRC(4)
SET $PIECE(^(0),U,5)=RMPRAM
SET $PIECE(^(0),U,6)=RMPRC(6)
SET $PIECE(^(0),U,7)=QTY
SET $PIECE(^(0),U,8)=RMPRC(8)
SET $PIECE(^(0),U,9)=RMPRC(9)
+2 SET $PIECE(^RMPR(667.3,RDA,0),U,11)=RMPRC(11)
if $DATA(RMPRC(10))
SET $PIECE(^(0),U,10)=RMPRC(10)
SET ^(2)=RMPR("STA")_"^"_DUZ
SET ^(3)=RMPRG
SET DA=RDA
SET DIK="^RMPR(667.3,"
DO IX1^DIK
SET RMPRADD=1
+3 SET DA=RDA
SET DR="5"
SET DIE="^RMPR(667.3,"
DO ^DIE
+4 KILL DA,DLAYGO
GOTO ENT
EDT IF '$DATA(RMPRADD)
WRITE !!,?5,$CHAR(7),"< NO RECORD ADDED >"
GOTO EXIT
+1 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Would you like to Edit/Delete an item "
DO ^DIR
if $DATA(DTOUT)!($DATA(DIRUT))!(Y=0)
GOTO EXIT
LP DO DSP
if '$DATA(RID)
GOTO EDT
+1 SET DA=+Y
SET DR=".01;8;9;S:$P(^RMPR(667.3,DA,0),U,9)=""4"" Y=""@5"";10///@;11;2;6;4;3;2.5;5;S Y="""";@5;10;11;2;6;4;3;2.5;5"
SET DIE="^RMPR(667.3,"
DO ^DIE
if '$DATA(DA)
KILL RID(RY)
if $ORDER(RID(0))
GOTO EDT
EXIT KILL DIR,DIC,DA,Y
SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Would you like to add an another Item "
WRITE !
DO ^DIR
IF +Y=1
GOTO ENT
+1 if $DATA(RMPRDA)
LOCK -^RMPR(667,RMPRDA,0)
if '$DATA(RMPRADD)
WRITE !!,$CHAR(7),"NO ITEMS ADDED TO THIS RECORD",!
KILL RMPRDA,RMPRC,RMPRGO,RMPRADD,DIC,DIR,DIE,RDA,REX,RLF,RID,RMPRITM,RMPRED,RMPREP,RMRPITM,Y,RMPRG,RMPR45,DLAYGO
+2 if '$DATA(DTOUT)
DO LINK^RMPRS
KILL DR,RC,RV,RY,RMPRAM,RMPRDFN,RMPRDOB,RMPRNAM,RMPRSSN,RMPRR,RA,RAC,RB,RD,RE,RF,RK,RLP,QTY
QUIT
LK ;LOOK UP
+1 SET RA=$PIECE(^RMPR(667,+Y,0),U,2)
IF +RA
WRITE ?40,$EXTRACT($PIECE(^DPT(RA,0),U,1),1,15),?60,$PIECE(^RMPR(667,+Y,0),U,7)
KILL RAA
+2 QUIT
EIT ;ENTER/EDIT AUTO-ADAPTIVE EQUIPMENT
+1 SET DIC=667.1
SET DIC(0)="AEQML"
SET DLAYGO=667.1
DO ^DIC
KILL DLAYGO
IF +Y'>0
KILL DIC
QUIT
+2 SET RMPRA=+Y
LOCK +^RMPR(667.1,+Y,0):1
IF $TEST=0
WRITE !,$CHAR(7),?5,"Someone else is Editing this entry!"
KILL DIC,DA,Y,RMPRA
GOTO EIT
+3 SET DA=+Y
SET DIE="^RMPR(667.1,"
SET DR=".01"
DO ^DIE
LOCK -^RMPR(667.1,RMPRA,0)
KILL DIC,DIE,DA,RMPRA,Y
GOTO EIT
EMN ;ENTER/EDIT VEHICLE MANUFACTURERS
+1 SET DIC=667.2
SET DIC(0)="AEQML"
SET DLAYGO=667.2
DO ^DIC
KILL DLAYGO
IF +Y'>0
KILL DIC
QUIT
+2 SET RMPRA=+Y
LOCK +^RMPR(667.2,+Y,0):3
IF $TEST=0
WRITE !,?5,$CHAR(7),!,"Someone else is Editing the entry!"
KILL DIC,DA,Y,RMPRA
QUIT
+3 SET DA=+Y
SET DIE=667.2
SET DR=".01"
DO ^DIE
LOCK -^RMPR(667.2,RMPRA,0)
KILL DIC,DA,Y,RMPRA
GOTO EMN
DSP ;DISPLAY ITEMS ON VEHICLE OF RECORD ENTRY
+1 IF '$DATA(^RMPR(667.3,"AD",RMPRDA))
WRITE !!,"No Items for the V.O.R",$CHAR(7)
GOTO EXIT
+2 SET RV=0
FOR RK=0:0
SET RK=$ORDER(^RMPR(667.3,"AD",RMPRDA,RK))
if RK'>0
QUIT
FOR RE=0:0
SET RE=$ORDER(^RMPR(667.3,"AD",RMPRDA,RK,RE))
if RE'>0
QUIT
IF $DATA(^RMPR(667.3,RE,0))
IF $PIECE(^(3),U)=RMPRG
SET RV=RV+1
SET RID(RV)=+RE_"^"_^(0)_"^"_$SELECT($DATA(^(3)):^(3),1:0)
DO WR
+3 if '$DATA(RID)
QUIT
+4 WRITE !
KILL DIR
SET DIR(0)="N"
SET DIR("A")="Please enter Item Number"
DO ^DIR
IF $DATA(DTOUT)!($DATA(DIRUT))
KILL RID
QUIT
+5 IF $DATA(RID(+Y))
SET RMPRR=$PIECE(RID(Y),"^",2,13)
SET RY=Y
SET Y=+RID(+Y)
QUIT
+6 WRITE $CHAR(7)
GOTO DSP
WR WRITE !,RV
WRITE ?10
IF $PIECE(RID(RV),U,4)
IF $DATA(^RMPR(667.1,$PIECE(RID(RV),U,4),0))
WRITE $EXTRACT($PIECE(^(0),U),1,30)
WRITE ?45,"$ ",$PIECE(RID(RV),U,5)
WRITE ?60
WRITE $SELECT($PIECE(RID(RV),U,6)["R":"REPAIR",$PIECE(RID(RV),U,6)["A":"VAN MOD",$PIECE(RID(RV),U,6)["B":"ADAP EQP",1:"UNK")
+1 QUIT
DSPR ;DISPLAY REPAIR ITEMS ON VEHICLE OF RECORD
+1 IF '$DATA(^RMPR(667.3,"AD",RMPRDA))
WRITE !!,"No Items for the V.O.R",$CHAR(7)
GOTO EXIT
+2 IF $DATA(RMPRED)
SET RV=0
SET RI=0
FOR RK=0:0
SET RK=$ORDER(^RMPR(667.3,"AD",RMPRDA,RK))
if RK'>0
QUIT
FOR RE=0:0
SET RE=$ORDER(^RMPR(667.3,"AD",RMPRDA,RK,RE))
if RE'>0
QUIT
IF $DATA(^RMPR(667.3,RE,0))
SET RV=RV+1
SET RID(RV)=+RE_"^"_^(0)
DO WR
+3 IF $DATA(RMPREP)
SET RV=0
SET RI=0
FOR RK=0:0
SET RK=$ORDER(^RMPR(667.3,"AD",RMPRDA,RK))
if RK'>0
QUIT
FOR RE=0:0
SET RE=$ORDER(^RMPR(667.3,"AD",RMPRDA,RK,RE))
if RE'>0
QUIT
IF $DATA(^RMPR(667.3,RE,0))
IF $PIECE(^(0),U,8)'="X"
SET RV=RV+1
SET RID(RV)=+RE_"^"_^(0)
DO WR
+4 if '$DATA(RID)
QUIT
+5 WRITE !
KILL DIR
SET DIR(0)="N"
SET DIR("A")="Please enter Item Number"
DO ^DIR
IF $DATA(DTOUT)!($DATA(DIRUT))
KILL RID
QUIT
+6 IF $DATA(RID(+Y))
SET RMPRR=$PIECE(RID(Y),"^",2,13)
SET RY=Y
SET Y=+RID(+Y)
QUIT
+7 WRITE $CHAR(7)
GOTO DSPR
