source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRAVR1.m@ 1700

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

initial load of FOIAVistA 6/30/08 version
File size: 4.4 KB
Line 
1RMPRAVR1 ;PHX/JLT-ENTER EDIT AUTO ADAPTIVE TRANS ;8/29/1994
2 ;;3.0;PROSTHETICS;;Feb 09, 1996
3DIC 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"
4 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)="""")"
5 D ^DIC I +Y'>0 K DIC G:$D(RMPRED)!($D(RMPREP)) QUIT G EDT
6 L +^RMPR(667,+Y,0):1 I $T=0 W !,$C(7),?5,"Someone else is Editing this entry!" G QUIT
7 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)
8 G:$D(RMPRED) EDIT G:$D(RMPREP) REP
9ENT 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
10 K DIR,DIC S DIR(0)="667.3,.01" D ^DIR G:$D(DTOUT)!($D(DIRUT)) EDT S RMPRC(5)=Y
11 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
12 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
13 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
14 K DIR,DA,Y S DIR(0)="667.3,11",DIR("B")="COMMERCIAL" D ^DIR G:$D(DTOUT)!(X["^") EDT S RMPRC(11)=Y
15 K DA,Y,DIR S DIR(0)="667.3,6" D ^DIR G:$D(DTOUT)!(X["^") EDT S RMPRC(6)=Y
16 K DA,Y,DIR S DIR(0)="667.3,3" D ^DIR G:$D(DTOUT)!($D(DIRUT)) EDT S RMPRC(4)=Y
17 K DA,Y S DIR(0)="667.3,2.5",DIR("B")=1 D ^DIR G:$D(DTOUT)!($D(DIRUT)) EDT S QTY=Y
18FILE I $D(RMPRG) G GGC
19 L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC
20 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)
21GGC 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
22 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)
23 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
24 S DA=+Y,DR="5",DIE=DIC D ^DIE K DA G ENT
25EDT I '$D(RMPRADD) W !!,$C(7),?5,"< NO RECORD ADDED >" G QUIT
26 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
27LP K RID D DSP^RMPRAVR G:'$D(RID) EXIT
28 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
29EXIT ;ASK ADD ANOTHER ITEM BEFORE KILLING VARIABLES
30 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
31QUIT ;KILL VARIABLES
32 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
33EDIT I '$D(^RMPR(667.3,"AD",RMPRDA)) W !,"No Item for this V.O.R",$C(7) G QUIT
34 D DSPR^RMPRAVR G:'$D(RID) DIC S RMPRITM=$P(RMPRR,U,3)
35 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
36REP I $D(RMPRG) G RLP
37 L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G RLP
38 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)
39RLP I '$D(^RMPR(667.3,"AD",RMPRDA)) W !!,"No Item for V.O.R",$C(7) H 3 G QUIT
40 W !! D DSPR^RMPRAVR G:'$D(RID) DIC S:$D(RID) RMPRITM=$P(RMPRR,U,3)
41 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
42 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"
43 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
44 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
45 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
46 W @IOF G REP
Note: See TracBrowser for help on using the repository browser.