source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRAVR.m@ 1397

Last change on this file since 1397 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.8 KB
Line 
1RMPRAVR ;PHX/JLT-ADD MODIFY REPAIR AUTO ADPT ;8/29/1994
2 ;;3.0;PROSTHETICS;;Feb 09, 1996
3ENT ;ENTER AUTO-ADAPTIVE TRANSACTION
4 L +^RMPR(667,RMPRDA,0):1 I '$T W !,"Someone else is editing this record!" Q
5 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
6 S RMPRC(3)=+Y
7 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
8 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
9 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
10 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
11 K DIR,DA,Y S DIR(0)="667.3,11",DIR("B")="COMMERCIAL" D ^DIR G:$D(DTOUT)!(X["^") EDT S RMPRC(11)=Y
12 K Y,DA,DIR S DIR(0)="667.3,6" D ^DIR G:$D(DTOUT)!(X["^") EDT S RMPRC(6)=Y
13 K Y,DA S DIR(0)="667.3,3" D ^DIR G:$D(DTOUT)!($D(DIRUT)) EDT S RMPRC(4)=Y
14 K Y,DA S DIR(0)="667.3,2.5",DIR("B")=1 D ^DIR G:$D(DTOUT)!($D(DIRUT)) EDT S QTY=Y
15FILE I $D(RMPRG) G GGC
16 L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC
17 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)
18GGC 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
19 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)
20 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
21 S DA=RDA,DR="5",DIE="^RMPR(667.3," D ^DIE
22 K DA,DLAYGO G ENT
23EDT I '$D(RMPRADD) W !!,?5,$C(7),"< NO RECORD ADDED >" G EXIT
24 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
25LP D DSP G:'$D(RID) EDT
26 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
27EXIT 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
28 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
29 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
30LK ;LOOK UP
31 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
32 Q
33EIT ;ENTER/EDIT AUTO-ADAPTIVE EQUIPMENT
34 S DIC=667.1,DIC(0)="AEQML",DLAYGO=667.1 D ^DIC K DLAYGO I +Y'>0 K DIC Q
35 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
36 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
37EMN ;ENTER/EDIT VEHICLE MANUFACTURERS
38 S DIC=667.2,DIC(0)="AEQML",DLAYGO=667.2 D ^DIC K DLAYGO I +Y'>0 K DIC Q
39 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
40 S DA=+Y,DIE=667.2,DR=".01" D ^DIE L -^RMPR(667.2,RMPRA,0) K DIC,DA,Y,RMPRA G EMN
41DSP ;DISPLAY ITEMS ON VEHICLE OF RECORD ENTRY
42 I '$D(^RMPR(667.3,"AD",RMPRDA)) W !!,"No Items for the V.O.R",$C(7) G EXIT
43 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
44 Q:'$D(RID)
45 W ! K DIR S DIR(0)="N",DIR("A")="Please enter Item Number" D ^DIR I $D(DTOUT)!($D(DIRUT)) K RID Q
46 I $D(RID(+Y)) S RMPRR=$P(RID(Y),"^",2,13),RY=Y,Y=+RID(+Y) Q
47 W $C(7) G DSP
48WR 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")
49 Q
50DSPR ;DISPLAY REPAIR ITEMS ON VEHICLE OF RECORD
51 I '$D(^RMPR(667.3,"AD",RMPRDA)) W !!,"No Items for the V.O.R",$C(7) G EXIT
52 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
53 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
54 Q:'$D(RID)
55 W ! K DIR S DIR(0)="N",DIR("A")="Please enter Item Number" D ^DIR I $D(DTOUT)!($D(DIRUT)) K RID Q
56 I $D(RID(+Y)) S RMPRR=$P(RID(Y),"^",2,13),RY=Y,Y=+RID(+Y) Q
57 W $C(7) G DSPR
Note: See TracBrowser for help on using the repository browser.