- 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 Feb 19, 2025@00:00:26 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
