RMPRAVR1 ;PHX/JLT-ENTER EDIT AUTO ADAPTIVE TRANS ;8/29/1994
;;3.0;PROSTHETICS;;Feb 09, 1996
DIC K DIC,RMPRG D HOME^%ZIS W !!,@IOF D DIV4^RMPRSIT G:$D(X) QUIT K DIC S DIC=667,DIC(0)="AEQMZN",DIC("A")="Please Enter Patient Name or Vehicle ID#: ",DIC("W")="D LK^RMPRAVR"
S DIC("S")="I $D(^(2)) I $P(^(2),U,1)=1,$P(^RMPR(667,+Y,0),U,10)=RMPR(""STA"")" I RMPRSITE=1 S DIC("S")=DIC("S")_"!($P(^(0),U,10)="""")"
D ^DIC I +Y'>0 K DIC G:$D(RMPRED)!($D(RMPREP)) QUIT G EDT
L +^RMPR(667,+Y,0):1 I $T=0 W !,$C(7),?5,"Someone else is Editing this entry!" G QUIT
S RMPRDA=+Y I +$P(^RMPR(667,+Y,0),U,2),$D(^DPT($P(^(0),U,2),0)) S RMPRDFN=$P(^RMPR(667,+Y,0),U,2)
G:$D(RMPRED) EDIT G:$D(RMPREP) REP
ENT 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
K DIR,DIC S 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 DA,Y,DIR S DIR(0)="667.3,6" D ^DIR G:$D(DTOUT)!(X["^") EDT S RMPRC(6)=Y
K DA,Y,DIR S DIR(0)="667.3,3" D ^DIR G:$D(DTOUT)!($D(DIRUT)) EDT S RMPRC(4)=Y
K DA,Y 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)="Z",DIC="^RMPR(667.3," K DD,DO D FILE^DICN I +Y'>0 W !!,$C(7),"RECORD NOT ENTERED SEE YOUR IRM SERVICE" G EDT
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 K DA S RMPRADD=1
S DA=+Y,DR="5",DIE=DIC D ^DIE K DA G ENT
EDT I '$D(RMPRADD) W !!,$C(7),?5,"< NO RECORD ADDED >" G QUIT
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 K RID D DSP^RMPRAVR G:'$D(RID) EXIT
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 ;ASK ADD ANOTHER ITEM BEFORE KILLING VARIABLES
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
QUIT ;KILL VARIABLES
L:$D(RMPRDA) -^RMPR(667,RMPRDA,0) D:'$D(DTOUT) LINK^RMPRS K X,Y,DA,RMPRDA,RMPRC,RDA,DR,DIE,DIC,DIR,DIK,RMPREP,RMPRED,RMPRDFN,RID,RMPRR,RMPRINFO,RZZZ,RC,RJ,RK,RT,RMPRG,RMPRITM,RMPRAM,RV,RE,RI,RY,QTY,RA,RMPRADD Q
EDIT I '$D(^RMPR(667.3,"AD",RMPRDA)) W !,"No Item for this V.O.R",$C(7) G QUIT
D DSPR^RMPRAVR G:'$D(RID) DIC S RMPRITM=$P(RMPRR,U,3)
S DIE="^RMPR(667.3,",(RDA,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" D ^DIE L:$D(DA) -^RMPR(667.3,DA,0) W ! G EDIT
REP I $D(RMPRG) G RLP
L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G RLP
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)
RLP I '$D(^RMPR(667.3,"AD",RMPRDA)) W !!,"No Item for V.O.R",$C(7) H 3 G QUIT
W !! D DSPR^RMPRAVR G:'$D(RID) DIC S:$D(RID) RMPRITM=$P(RMPRR,U,3)
S X=DT,DIC(0)="Z",DIC="^RMPR(667.3," K DD,DO D FILE^DICN I +Y'>0 W !!,$C(7),"RECORD NOT ENTERED SEE YOUR IRM SERVICE" G QUIT
S RDA=+Y,$P(^RMPR(667.3,RDA,0),U,2)=RMPRDA,$P(^(0),U,3)=RMPRITM,$P(^(0),U,5)=RMPRAM,$P(^(0),U,6)=$P(RMPRR,U,6),$P(^(0),U,7)=1,$P(^(0),U,8)="X"
S $P(^RMPR(667.3,RDA,0),U,9)=$P(RMPRR,U,9),$P(^(0),U,10)=$P(RMPRR,U,10),$P(^(0),U,11)=$P(RMPRR,U,11),^(2)=RMPR("STA")_"^"_DUZ,^(3)=$S($D(RMPRG):RMPRG,1:0),DA=RDA,DIK="^RMPR(667.3," D IX1^DIK
S DA=+Y,DIE=DIC,DR=".01;8;9;S:$P(^RMPR(667.3,DA,0),U,9)=""4"" Y=""@5"";10///@;11;2;6;3;2.5;5;S Y="""";@5;10;11;2;6;3;2.5;5" D ^DIE
I $D(^RMPR(667.3,+RDA,0)),'$P(^(0),U,4) S DA=RDA,DIK="^RMPR(667.3," D ^DIK W !!,?5,$C(7),"Deleted..." H 3
W @IOF G REP
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRAVR1 4534 printed Apr 09, 2024@21:39:09 Page 2
RMPRAVR1 ;PHX/JLT-ENTER EDIT AUTO ADAPTIVE TRANS ;8/29/1994
+1 ;;3.0;PROSTHETICS;;Feb 09, 1996
DIC KILL DIC,RMPRG
DO HOME^%ZIS
WRITE !!,@IOF
DO DIV4^RMPRSIT
if $DATA(X)
GOTO QUIT
KILL DIC
SET DIC=667
SET DIC(0)="AEQMZN"
SET DIC("A")="Please Enter Patient Name or Vehicle ID#: "
SET DIC("W")="D LK^RMPRAVR"
+1 SET DIC("S")="I $D(^(2)) I $P(^(2),U,1)=1,$P(^RMPR(667,+Y,0),U,10)=RMPR(""STA"")"
IF RMPRSITE=1
SET DIC("S")=DIC("S")_"!($P(^(0),U,10)="""")"
+2 DO ^DIC
IF +Y'>0
KILL DIC
if $DATA(RMPRED)!($DATA(RMPREP))
GOTO QUIT
GOTO EDT
+3 LOCK +^RMPR(667,+Y,0):1
IF $TEST=0
WRITE !,$CHAR(7),?5,"Someone else is Editing this entry!"
GOTO QUIT
+4 SET RMPRDA=+Y
IF +$PIECE(^RMPR(667,+Y,0),U,2)
IF $DATA(^DPT($PIECE(^(0),U,2),0))
SET RMPRDFN=$PIECE(^RMPR(667,+Y,0),U,2)
+5 if $DATA(RMPRED)
GOTO EDIT
if $DATA(RMPREP)
GOTO REP
ENT 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
SET RMPRC(3)=+Y
+1 KILL DIR,DIC
SET DIR(0)="667.3,.01"
DO ^DIR
if $DATA(DTOUT)!($DATA(DIRUT))
GOTO EDT
SET RMPRC(5)=Y
+2 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
+3 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
+4 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
+5 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
+6 KILL DA,Y,DIR
SET DIR(0)="667.3,6"
DO ^DIR
if $DATA(DTOUT)!(X["^")
GOTO EDT
SET RMPRC(6)=Y
+7 KILL DA,Y,DIR
SET DIR(0)="667.3,3"
DO ^DIR
if $DATA(DTOUT)!($DATA(DIRUT))
GOTO EDT
SET RMPRC(4)=Y
+8 KILL DA,Y
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)="Z"
SET DIC="^RMPR(667.3,"
KILL DD,DO
DO FILE^DICN
IF +Y'>0
WRITE !!,$CHAR(7),"RECORD NOT ENTERED SEE YOUR IRM SERVICE"
GOTO EDT
+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
KILL DA
SET RMPRADD=1
+3 SET DA=+Y
SET DR="5"
SET DIE=DIC
DO ^DIE
KILL DA
GOTO ENT
EDT IF '$DATA(RMPRADD)
WRITE !!,$CHAR(7),?5,"< NO RECORD ADDED >"
GOTO QUIT
+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 KILL RID
DO DSP^RMPRAVR
if '$DATA(RID)
GOTO EXIT
+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 ;ASK ADD ANOTHER ITEM BEFORE KILLING VARIABLES
+1 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
QUIT ;KILL VARIABLES
+1 if $DATA(RMPRDA)
LOCK -^RMPR(667,RMPRDA,0)
if '$DATA(DTOUT)
DO LINK^RMPRS
KILL X,Y,DA,RMPRDA,RMPRC,RDA,DR,DIE,DIC,DIR,DIK,RMPREP,RMPRED,RMPRDFN,RID,RMPRR,RMPRINFO,RZZZ,RC,RJ,RK,RT,RMPRG,RMPRITM,RMPRAM,RV,RE,RI,RY,QTY,RA,RMPRADD
QUIT
EDIT IF '$DATA(^RMPR(667.3,"AD",RMPRDA))
WRITE !,"No Item for this V.O.R",$CHAR(7)
GOTO QUIT
+1 DO DSPR^RMPRAVR
if '$DATA(RID)
GOTO DIC
SET RMPRITM=$PIECE(RMPRR,U,3)
+2 SET DIE="^RMPR(667.3,"
SET (RDA,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"
DO ^DIE
if $DATA(DA)
LOCK -^RMPR(667.3,DA,0)
WRITE !
GOTO EDIT
REP IF $DATA(RMPRG)
GOTO RLP
+1 LOCK +^RMPR(669.9,RMPRSITE,0):999
IF $TEST=0
SET RMPRG=DT_99
GOTO RLP
+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)
RLP IF '$DATA(^RMPR(667.3,"AD",RMPRDA))
WRITE !!,"No Item for V.O.R",$CHAR(7)
HANG 3
GOTO QUIT
+1 WRITE !!
DO DSPR^RMPRAVR
if '$DATA(RID)
GOTO DIC
if $DATA(RID)
SET RMPRITM=$PIECE(RMPRR,U,3)
+2 SET X=DT
SET DIC(0)="Z"
SET DIC="^RMPR(667.3,"
KILL DD,DO
DO FILE^DICN
IF +Y'>0
WRITE !!,$CHAR(7),"RECORD NOT ENTERED SEE YOUR IRM SERVICE"
GOTO QUIT
+3 SET RDA=+Y
SET $PIECE(^RMPR(667.3,RDA,0),U,2)=RMPRDA
SET $PIECE(^(0),U,3)=RMPRITM
SET $PIECE(^(0),U,5)=RMPRAM
SET $PIECE(^(0),U,6)=$PIECE(RMPRR,U,6)
SET $PIECE(^(0),U,7)=1
SET $PIECE(^(0),U,8)="X"
+4 SET $PIECE(^RMPR(667.3,RDA,0),U,9)=$PIECE(RMPRR,U,9)
SET $PIECE(^(0),U,10)=$PIECE(RMPRR,U,10)
SET $PIECE(^(0),U,11)=$PIECE(RMPRR,U,11)
SET ^(2)=RMPR("STA")_"^"_DUZ
SET ^(3)=$SELECT($DATA(RMPRG):RMPRG,1:0)
SET DA=RDA
SET DIK="^RMPR(667.3,"
DO IX1^DIK
+5 SET DA=+Y
SET DIE=DIC
SET DR=".01;8;9;S:$P(^RMPR(667.3,DA,0),U,9)=""4"" Y=""@5"";10///@;11;2;6;3;2.5;5;S Y="""";@5;10;11;2;6;3;2.5;5"
DO ^DIE
+6 IF $DATA(^RMPR(667.3,+RDA,0))
IF '$PIECE(^(0),U,4)
SET DA=RDA
SET DIK="^RMPR(667.3,"
DO ^DIK
WRITE !!,?5,$CHAR(7),"Deleted..."
HANG 3
+7 WRITE @IOF
GOTO REP
