source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4P22.m@ 677

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

initial load of FOIAVistA 6/30/08 version
File size: 4.7 KB
Line 
1RMPR4P22 ;PHX/HNC/RVD-CONT PURCHASE CARD ;3/1/1996
2 ;;3.0;PROSTHETICS;**3,20,26,90,115,132**;Feb 09, 1996;Build 13
3 S RO=0,J2=0 F I=1:1 S RO=$O(R664(1,RO)) Q:RO'>0 D Q:$D(J1)
4 .I I>2 S J1=1 W !!,?9,"***SEE ATTACHED CONTINUATION SHEET FOR ITEM DESCRIPTION(S)***",! Q
5 .I $D(R664(1,RO,1,0)) S RP=0 F J=1:1 S RP=$O(R664(1,RO,1,RP)) Q:RP="" S J2=J2+1 D Q:$D(J1)
6 ..I J2+I>2 S J1=1 W !!,?9,"***SEE ATTACHED CONTINUATION SHEET FOR ITEM DESCRIPTION(S)***",! Q
7 .Q:$D(J1)
8 .S RMPRCNT=0
9 .S RMPRSSM(1)=$P($G(R664(1,RO,0)),U,15)
10 .S RMPRSSM(2)=$P($G(R664(1,RO,2)),U,1)
11 .S RMPRSSM(3)=$P($G(R664(1,RO,2)),U,2)
12 .S RMPRSSM(4)=$P($G(R664(1,RO,2)),U,3)
13 .F II=1:1:4 S:RMPRSSM(II)'="" RMPRCNT=RMPRCNT+1
14 .K II I J2+I+(RMPRCNT+1\2)>2 S J1=1 W !!,?9,"***SEE ATTACHED CONTINUATION SHEET FOR ITEM DESCRIPTION(S)***",!
15 D ADD
16 S RO=0 F S RO=$O(R664(1,RO)) Q:RO'>0 D:'$D(RMPRMOR)&($Y>36) CONT D:$D(RMPRMOR)&($Y>56) CONT D:'$D(RMPRMOR) ADD D START
17 I '$D(RMPRMOR)&($Y<37) F W ! Q:$Y>36
18 Q
19START W !,"#"_RO_"."
20 S RMPRI=$S($P(R664(1,RO,0),U,7)'="":$P(R664(1,RO,0),U,7),1:$P(R664(1,RO,0),U,3))
21 W ?4,$P(R664(1,RO,0),U,2)
22 W ?50,$J($P(R664(1,RO,0),U,4),6) S RMPRUT=$P(R664(1,RO,0),U,5) W:$D(^PRCD(420.5,+RMPRUT,0)) ?61,$P(^PRCD(420.5,+RMPRUT,0),U,1),?65,$J($FN(RMPRI,"P",2),6)
23ZWE S RMPRTOT=RMPRI*$P(R664(1,RO,0),U,4) W ?72,$J($FN(RMPRTOT,"P",2),8) D EXT
24 Q
25EXT ;CHECKING FOR EXTENDED DESCRIPTION
26 ;serial number
27 N RMPRCNT,RMPRSSM,LNCT
28 S RMPRCNT=0,LNCT=0
29 S RMPRSSM(1)=$P($G(R664(1,RO,0)),U,15)
30 S RMPRSSM(2)=$P($G(R664(1,RO,2)),U,1)
31 S RMPRSSM(3)=$P($G(R664(1,RO,2)),U,2)
32 S RMPRSSM(4)=$P($G(R664(1,RO,2)),U,3)
33 I RMPRSSM(1)'="" D
34 .I LNCT#2=0 D:$D(RMPRMOR)&($Y>56) CONT W !
35 .W " Serial Number: "_RMPRSSM(1) S LNCT=LNCT+1
36 I RMPRSSM(4)'="" D
37 .I LNCT#2=0 D:$D(RMPRMOR)&($Y>56) CONT W !
38 .W " Lot #: "_RMPRSSM(4) S LNCT=LNCT+1
39 I RMPRSSM(3)'="" D
40 .I LNCT#2=0 D:$D(RMPRMOR)&($Y>56) CONT W !
41 .W " Model: "_RMPRSSM(3) S LNCT=LNCT+1
42 I RMPRSSM(2)'="" D
43 .I LNCT#2=0 D:$D(RMPRMOR)&($Y>56) CONT W !
44 .W " Make: "_RMPRSSM(2)
45 K RMPRSSM,RMPRCNT,LNCT
46 ;
47 S RMPRCH=$G(R664(1,RO,1,0))
48 I RMPRCH="" Q
49 ;S (RMPR90,RMPRX)=$Q(R664(1,RO,0,0))
50 ;S RMPRX=$E(RMPRX,1,10)
51 ;Q:RMPR90=""
52 S RMPR90=0
53 F S RMPR90=$O(R664(1,RO,1,RMPR90)) Q:RMPR90="" D
54 .D:$D(RMPRMOR)&($Y>56) CONT
55 .D:'$D(RMPRMOR)&($Y>36) CONT
56 .W !,R664(1,RO,1,RMPR90,0)
57 ;F S RMPR90=$Q(@RMPR90) Q:RMPRX'=$E(RMPR90,1,10) D:$D(RMPRMOR)&($Y>57) CONT D:'$D(RMPRMOR)&($Y>36) CONT
58 ;D WRI
59 Q
60WRI ;CONTINUATION OF 10-2421
61 W !,@RMPR90
62 Q
63CONT D:'$D(RMPRMOR) CON
64 I $G(RMPRMOR)=1 W !!,?9,"***CONTINUATION OF PURCHASE CARD ITEMS ON NEXT PAGE***"
65 W @IOF,!,"CONTINUATION OF PURCHASE CARD ",?27,"ORDER NUMBER: ",$P($G(^RMPR(664,RMPRA,4)),U,5),?71,"PAGE ",RMPRPAGE S RMPRMOR=1,RMPRPAGE=RMPRPAGE+1 D HDR^RMPR4P21
66 Q
67ADD S (RMPRAMT2,RMPRAMT,RMPRAMT1,RMPRAMTN)=0
68 S RMSHI=$S($P(R664(0),U,11)'="":$P(R664(0),U,11),1:$P(R664(0),U,10))
69 S RC=0 F S RC=$O(R664(1,RC)) Q:RC=""!(RC["B") S RMPRI=$S($P(R664(1,RC,0),U,7)'="":$P(R664(1,RC,0),U,7),1:$P(R664(1,RC,0),U,3)) D ADD1
70 I $D(R664(2)) S RMPRDISC=$S($P(R664(2),U,6)'="":$P(R664(2),U,6),1:"") I $D(RMPRDISC) S RMPRAMT2=$J(RMPRDISC*RMPRAMT/100,0,2),RMPRAMTN=RMPRAMT-$J(RMPRAMT2,0,2),RMPRAMTN=$J(RMPRAMTN+RMSHI,0,2) Q
71 Q
72ADD1 S RMPRAMT1=$J($P(R664(1,RC,0),U,4)*RMPRI,0,2) S RMPRAMT=RMPRAMT+RMPRAMT1 Q
73CON ;CONTINUATION OF 2421
74 W !,RMPRB,!,"16. Contract Number: " S RO("C")=$O(R664(1,0)) W:RO("C") $P(R664(1,RO("C"),0),U,14) W ?61,"Subtotal: ",$J($FN(RMPRAMT,"P",2),8)
75 W !," ACCT.#: ",RMPRVACN K RMPRVACN
76 W ?28,"Discount $" I $D(RMPRAMT2) W $J($FN(RMPRAMT2,"P",2),7)
77 W ?45,"Shipping: ",$J($FN(RMSHI,"P",2),5)
78 W ?62,"Total",?69,"$",$J($FN(RMPRAMTN,"P",2),9)
79 W !,RMPRB,!,"17. Signature of"
80 W ?28,"18. DATE",?39,"19. Signature and Title of",?70,"20. Date"
81 W !,?5,"Requesting Official",?39,"Contracting/Accountable Officer"
82 W !!,?5,RDUZ,?39,RMPR("SIG")
83 W !,RMPRB,!?25,"Order and Receipt Action",!,RMPRB
84 W !,"21. Order Number",?18,"22. Exp Date",?37,"23. Date Item Received",?62,"24. Date Delivered"
85 I DUZ=$P(^RMPR(664,RMPRA,0),U,9)!($D(^XUSEC("RMPR FCP MANAGER",DUZ))) D
86 .;W !,"************"
87 .N RMPRPRCD
88 .S RMPRPRCD=$$DEC^RMPR4LI($P(^RMPR(664,RMPRA,4),U,1),$P(^RMPR(664,RMPRA,0),U,9),RMPRA)
89 .;W $E(RMPRPRCD,13,16)
90 .W !,RMPRPRCD
91 E W !,?3,"encrypted"
92 ;W !,?3,$$DEC^RMPR4LI($P(^RMPR(664,RMPRA,4),U,1),DUZ,RMPRA)
93 ;DATE REMOVED
94 W !,RMPRB
95 W !,"25. The articles or services listed herein have been received, or rendered",!,"ordered in the quantity and quality specified originally or as shown by"
96 W !,"authenticated changes, except as noted.",!!?40,"Signature of Veteran or VA Official",!,RMPRB
97 ;W !?30,"VOUCHER AUDIT BLOCK (For use by VA Facility only)",!,RMPRB
98 ;W !,"Bank Authorization Number: ",$P(^RMPR(664,RMPRA,4),U,2)
99 W !,?$X+6,"Acct. Symbol ",$$STA^RMPRUTIL,"-"_$P($G(^RMPR(664,RMPRA,4)),U,5)
100 W !,RMPRB,!,?52,"ADP Form 10-2421PC APR 1991" S RMPRMOR1=1
101 Q
Note: See TracBrowser for help on using the repository browser.