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