source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRL9.m@ 1540

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

initial load of FOIAVistA 6/30/08 version
File size: 4.1 KB
Line 
1RMPRL9 ;PHX/HNB-DISPLAY ITEMS ON 1358 TRANSACTION ;8/29/1994
2 ;;3.0;PROSTHETICS;**19,90**;Feb 09, 1996
3 S:'$D(RMPRDELN) RMPRDELN="" S (RMPRI,RMPRCNT)=0,RMPRX="" D HOME^%ZIS W @IOF S:'$D(RMPRSER) RMPRSER=""
4 W ?0,$E($G(^UTILITY("DIQ1",$J,664.1,RMPRDA,.02)),1,30),?40,"WORK ORDER #: ",$G(^UTILITY("DIQ1",$J,664.1,RMPRDA,4))
5 S $P(LINE,"=",IOM)="",RZZZ=0
6 W !,LINE
7LI F S RMPRI=$O(^RMPR(664,RMPRA,1,RMPRI)) Q:RMPRI'>0!($G(RMPRX)="^") S RMPRCNT=RMPRCNT+1,RMPRI1=^RMPR(664,RMPRA,1,RMPRI,0) D PRT
8 I $G(RMPRX)="^" I $Y<17 F W ! Q:$Y>17
9 I $G(RMPRX)="^" Q
10 W !,?25,"TOTAL COST: ",?65,"$",$J(RZZZ,0,2)
11 I $Y<17 F W ! Q:$Y>17
12 Q
13PRT I RMPRCNT<0 W !,"NO ITEMS ON FILE" Q
14 W !!?5,"ITEM: "
15 S RMPRIT=$P(RMPRI1,U,1),RMPRIT1=$P(^RMPR(661,RMPRIT,0),U,1)
16 W $P(^PRC(441,RMPRIT1,0),U,1)," ",$P(^(0),U,2)," ",?45,"AMIS: " S RMPRAMIS=$S($P(RMPRI1,U,9)'="X":$P(^RMPR(661,RMPRIT,0),U,3),1:$P(^RMPR(661,RMPRIT,0),U,4))
17 W !!?5,"DESCRIPTION: ",$P(RMPRI1,U,2)
18 W !?5,"SERIAL NUMBER: " S RMPRSER=$S($P(^RMPR(664,RMPRA,1,RMPRI,0),U,15)]"":$P(^(0),U,15),$D(^RMPR(660,+$P(^(0),U,13),0)):$P(^(0),U,11),1:"") W RMPRSER
19 W !?5,"UNIT COST: ",$J($S($P(RMPRI1,U,7):$P(RMPRI1,U,7),1:$P(RMPRI1,U,3)),0,2),?25,"UNIT OF ISSUE: "
20 S RMPRU=$P(RMPRI1,U,5) W:RMPRU'="" $P(^PRCD(420.5,RMPRU,0),U,1),?45,"QTY: ",$P(RMPRI1,U,4),?55,"ITEM COST: "
21 S R1=$S($P(RMPRI1,U,7):$P(RMPRI1,U,7),1:$P(RMPRI1,U,3)),R2=$P(RMPRI1,U,4),RZZZ=RZZZ+(R1*R2) W $J(R1*R2,0,2)
22 W !?5,"TYPE: ",$S($P(RMPRI1,U,9)="X":"REPAIR",$P(RMPRI1,U,9)="I":"INITIAL",$P(RMPRI1,U,9)="R":"REPLACE",$P(RMPRI1,U,9)="S":"SPARE",$P(RMPRI1,U,9)="5":"RENTAL",1:"")
23 W ?25,"CATEGORY: ",$S($P(RMPRI1,U,10)=1:"SC/OP",$P(RMPRI1,U,10)=2:"SC/IP",$P(RMPRI1,U,10)=3:"NSC/IP",$P(RMPRI1,U,10)=4:"NSC/OP",1:"")
24 W ?44,"SPECIAL CATEGORY: "
25 W $S($P(RMPRI1,U,11)=1:"SPEC/LEG",$P(RMPRI1,U,11)=2:"A&A",$P(RMPRI1,U,11)=3:"PHC",$P(RMPRI1,U,11)=4:"ELIG/REF",1:"")
26ASK I $Y>17 R !!,"Enter '^' to Quit Display, <Return> to Continue : ",RMPRX:DTIME S:'$T RMPRX="^" Q:RMPRX="^"
27 Q
28C21 ;COMPLETE 2421 REQUEST FROM LAB
29 S RT=$O(^RMPR(664,RMPRA,1,0)) I RT>0,$D(^(RT,0)) S:$G(RMPRCONT)="" RMPRCONT=$P(^(0),U,14)
30 K FL D ^RMPRLI I RMPRX]"" G CHK
31L2 W !! K DIR S DIR(0)="FO",DIR("A")="Select Item to Edit",DIR("?")="^S ZFL=1 D ZDSP^RMPR21A" D ^DIR G:$D(DTOUT) EXIT G:$D(DIRUT) COT S DIC="^RMPR(661,",DIC(0)="EQMZ" D ^DIC G:+Y'>0 L2
32 D EDT^RMPRUTIL G:$D(DTOUT) EXIT G L2
33COT S DIE="^RMPR(664,",DR="4",DA=RMPRA D ^DIE I $D(DTOUT)!($D(Y)'=0) G CHK
34 S RMPRV=$P(^RMPR(664,RMPRA,0),U,4) G:'$D(^PRC(440,RMPRV,4)) L2 K DIR S DIR(0)="PO^PRC(440,"_RMPRV_",4,:QEM" S:$G(RMPRCONT)'="" DIR("B")=RMPRCONT D ^DIR I (Y'>0)&(X'="")&(X'["^") G COT
35 I X["^" G CHK
36 I Y>0,$P(^PRC(440,RMPRV,4,+Y,0),U,2)<DT W $C(7),!,"Sorry, contract has expired. Enter another contract or `return` to continue." G COT
37 K DIR,DA S:Y>0 (RMPRCONT,RMPRCTK)=$P(Y,U,2)
38 K DA S DIE="^RMPR(664,",DA=RMPRA,DR="11;17;20" D ^DIE G:$D(Y) CHK G:$D(DTOUT) EXIT
39 K DIR S:$G(RMPRDELN)'="" DIR("B")=RMPRDELN
40 S DIR(0)="SA^1:VETERAN;2:VAMC WAREHOUSE;3:PROSTHETICS;4:OTHER;",DIR("A")="DELIVER TO: "
41 D ^DIR G:$D(DIRUT) CHK G:$D(DTOUT) EXIT
42 S RMPRDELN=Y(0) I Y'=4 S $P(^RMPR(664,RMPRA,3),U)=RMPRDELN K RMPRDLC G CHK
43 S $P(^RMPR(664,RMPRA,3),U)=$S($G(RMPRDLC)'="":RMPRDLC,1:""),DIE="^RMPR(664,",DA=RMPRA,DR="19T" D ^DIE G:$D(DTOUT) EXIT S RMPRDLC=$P(^RMPR(664,RMPRA,3),U)
44CHK S FL=1 I $D(^RMPR(664,RMPRA,1)) S FL=0 F RI=0:0 S RI=$O(^RMPR(664,RMPRA,1,RI)) Q:RI'>0 I $D(^(RI,0)) S FL=1 I $P(^(0),U,4)=""!($P(^(0),U,5)="")!($P(^(0),U,9)="")!($P(^(0),U,10)="") S FL=0 Q
45 I $P($G(^RMPR(664,RMPRA,3)),U)="" W !!,$C(7),"Deliver To information is Missing!! 2421 is incomplete" G EXIT
46 I 'FL W !!,?5,$C(7),"REQUIRED ITEM INFORMATION IS MISSING",! G EXIT
47ASK5 S %=2 W !!,"Are you ready to POST to IFCAP and 10-2319 NOW" D YN^DICN G:%=1 FILE^RMPR21B G:$D(DTOUT) EXIT
48 I %=0 W !,"This will Create a Daily Transaction in the 1358 Module of IFCAP,",!,"and Create an Entry on the Prosthetic 10-2319 Record" G ASK5
49 I %'>0 S %=2 R !,"Do you want to delete the 2421 Request" D YN^DICN I $D(DTOUT)!(%=1) D DEL^RMPR29M(RMPRA) G KILL^RMPR21
50 G C21
51EXIT I '$D(DTOUT) K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do You want to delete the 2421 Request" D ^DIR Q:$D(DTOUT) I +Y=1 D DEL^RMPR29M(RMPRA) G KILL^RMPR21
52 Q
Note: See TracBrowser for help on using the repository browser.