source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQRP4.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 5.2 KB
Line 
1PRCHQRP4 ;WISC/KMB-DISPLAY ABS/AGGREGATE QUOTE ;8/6/96 21:05
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4START ;Entry point for aggregate report
5 W @IOF S DIC="^PRC(444,",DIC("S")="I $P(^(0),""^"",8)>1"
6 S DIC(0)="AEMQZ" D ^DIC K DIC I Y<0 K DTOUT,DUOUT,PRCDA,Y Q
7 S PRCDA=+Y
8 ;
9 W ! S %ZIS="MQ" D ^%ZIS I POP K PRCDA,Y Q
10 I $D(IO("Q")) S ZTRTN="PROCESS^PRCHQRP4",ZTSAVE("DUZ")="",ZTSAVE("PRCDA")="" D ^%ZTLOAD,^%ZISC K ZTSK G START
11 D PROCESS,^%ZISC K PRCDA,Y G START
12PROCESS ;
13 N Q,Z1,ITEMNO,ID,I,J,K,L,VEN,ID,ITEMNO,P,STRING,VDUN,VNAME,VN,FOB,TOT,FILE
14 N ZIP1,ZIP2,ZIP3,ZIP4,ZIP5,VENDOR,FLAG,PRCFLG,X,Y K ^TMP($J)
15 S ZIP1=$P($G(^PRC(444,PRCDA,0)),"^"),ZIP2=$P($G(^(0)),"^",3),ZIP3=$P($G(^(8,0)),"^",4)
16 S ZIP5=$P($G(^PRC(444,PRCDA,0)),"^",12) S:ZIP5'="" ZIP5=$P($G(^VA(200,ZIP5,0)),"^")
17 S ZIP4=$P($G(^PRC(444,PRCDA,2,0)),"^",4)
18 S Y=ZIP2 D DD^%DT S ZIP2=Y
19 D VENDOR,RFQLOAD^PRCHQRP3,DETAIL,WRITE
20 K PRCDA,^TMP($J) S:$D(ZTQUEUED) ZTREQ="@"
21 QUIT
22WRITE ;
23 U IO S (P,Z1)=1 D HDR
24 I '$D(STRING) W !,"No dollar totals were entered for vendor quotes",!
25 S Q=""
26 F S Q=$O(STRING(Q)) Q:Q="" D Q:Z1[U
27 . S J=""
28 . F S J=$O(STRING(Q,J)) Q:J="" D Q:Z1[U
29 . . S K=""
30 . . F S K=$O(STRING(Q,J,K)) Q:K="" D Q:Z1[U
31 . . . I IOSL-$Y<6 D HDR Q:Z1[U
32 . . . W !,$P(STRING(Q,J,K),"^"),?20,$P(STRING(Q,J,K),"^",2),?25,$J($FN($P(STRING(Q,J,K),"^",3),"",2),10)
33 . . . W ?40,$P(STRING(Q,J,K),"^",4),?47,$P(STRING(Q,J,K),"^",5),?56,$P(STRING(Q,J,K),"^",6)
34 I Z1'[U,IOSL-$Y<14 R:$E(IOST,1,2)="C-"&'$D(ZTQUEUED) !,"Enter RETURN to continue or '^' to exit: ",Z1:DTIME W @IOF
35 D:Z1'[U LEGEND
36 I Z1'[U,$E(IOST,1,2)="C-",'$D(ZTQUEUED) R !,"Enter RETURN to continue ",Z1:DTIME
37 QUIT
38HDR ;
39 I $E(IOST,1,2)="C-",P>1,'$D(ZTQUEUED) R !,"Enter RETURN to continue or '^' to exit: ",Z1:DTIME Q:Z1["^"
40 W @IOF
41 W !,"RFQ #",ZIP1,?70,"Page ",P,!,"Quotations Due Date: ",ZIP2,!,"Number of Quotes: ",ZIP3,!,"Number of Items on RFQ: ",ZIP4,!,"Point of Contact: ",ZIP5,!
42 W !,?20,"#Items",?30,"Total",?47,"Total"
43 W !,"Vendor",?20,"Quoted",?30,"Price",?40,"FOB",?47,"#Msgs.",?56,"Flags",!
44 F I=1:1:8 W "----------"
45 S P=P+1
46 QUIT
47DETAIL ;
48 S I=0
49 F S I=$O(^PRC(444,PRCDA,8,I)) Q:+I'=I D
50 .S TOT=$P($G(^PRC(444,PRCDA,8,I,1)),"^",3) Q:+TOT=0
51 .S FOB=$P($G(^PRC(444,PRCDA,8,I,1)),"^")
52 .S J=0
53 .F S J=$O(^PRC(444,PRCDA,8,I,3,J)) Q:+J'=J D
54 . . S K=$G(^PRC(444,PRCDA,8,I,3,J,0)) Q:K=""
55 . . I $P(K,"^",10)]"",$P(K,"^",10)'=$P(FOB,"/") S $P(FOB,"/",FOB]""+1)=$P(K,"^",10)
56 .S VEN=$P($G(^PRC(444,PRCDA,8,I,0)),"^")
57 .S VN=$P(VEN,";"),FILE=$P(VEN,";",2),VNAME="^"_FILE_VN_",0)"
58 .S VDUN=0 S:FILE[440 VDUN=$P($G(^PRC(440,VN,7)),"^",12) S:FILE[444.1 VDUN=$P($G(^PRC(444.1,VN,0)),"^",2) S:VDUN="" VDUN=0
59 .S VNAME=$P($G(@VNAME),"^") Q:VNAME="" S VNAME=$E(VNAME,1,18)
60 .S ITEMNO=$P($G(^PRC(444,PRCDA,8,I,3,0)),"^",4)
61 .S STRING(TOT,VNAME,I)=VNAME_"^"_ITEMNO_"^"_TOT_"^"_FOB_"^"_$G(VENDOR(VDUN))
62 . K PRCFLG
63 . I FOB'=^TMP($J,"RFQ","FOB") S PRCFLG("FOB")=""
64 . I $P($G(^PRC(444,PRCDA,8,I,0)),"^",4)>^TMP($J,"RFQ","QUOTE DUE") S PRCFLG("RECVD DATE")=""
65 . I ^TMP($J,"RFQ","SET ASIDE") D
66 . . I FILE[440,$P($G(^PRC(440,VN,2)),"^",3)='1 S PRCFLG("SIZE")=""
67 . . I FILE[444.1,$P($G(^PRC(444.1,VN,0)),"^",5)'=1 S PRCFLG("SIZE")=""
68 . I $P($G(^PRC(444,PRCDA,8,I,3,0)),"^",4)'=^TMP($J,"RFQ","NBR ITEMS") S PRCFLG("NBR")=""
69 . I $P($G(^PRC(444,PRCDA,8,I,0)),"^",7)]"" S PRCFLG("CONTRACT")=""
70 . S J=0
71 . F S J=$O(^PRC(444,PRCDA,8,I,3,J)) Q:+J'=J D
72 . . S X=$G(^PRC(444,PRCDA,8,I,3,J,0)) Q:X=""
73 . . S L=$P(X,"^")
74 . . I $P(X,"^",2)'=$G(^TMP($J,"RFQ","ITEM",L,"QUANTITY")) S PRCFLG("QUANTITY")=""
75 . . S K=$S($P(X,"^",3)]"":$P($G(^PRCD(420.5,$P(X,"^",3),0)),"^",2),1:"")
76 . . I K'=$G(^TMP($J,"RFQ","ITEM",L,"UNIT")) S PRCFLG("UNIT")=""
77 . . I $P(X,"^",9)'=$G(^TMP($J,"RFQ","ITEM",L,"MFG PART")) S PRCFLG("MFG PART")=""
78 . . I $P($G(^PRC(444,PRCDA,8,I,3,J,1)),"^",6)]"" S PRCFLG("CONTRACT")=""
79 . . I $P(X,"^",4)]"" S PRCFLG("VENDOR PRODUCT #")=""
80 . . I $P(X,"^",8)'=$G(^TMP($J,"RFQ","ITEM",L,"NDC")) S PRCFLG("NDC")=""
81 . . I $P(X,"^",6)'=$G(^TMP($J,"RFQ","ITEM",L,"NSN")) S PRCFLG("NSN")=""
82 . S FLAG=""
83 . F J="FOB^F","QUANTITY^Q","UNIT^U","RECVD DATE^DT","SIZE^S","NBR^LI","CONTRACT^C","MFG PART^M","VENDOR PRODUCT #^V","NSN^NSN","NDC^NDC" I $D(PRCFLG($P(J,"^"))) S FLAG=FLAG_$S(FLAG]"":",",1:"")_$P(J,"^",2)
84 . S $P(STRING(TOT,VNAME,I),"^",6)=FLAG
85 QUIT
86VENDOR ; determine 864 messages for each vendor
87 S J=0
88 F S J=$O(^PRC(444,PRCDA,7,J)) Q:+J'=J D
89 .S ID=$P($G(^PRC(444,PRCDA,7,J,0)),"^",3) Q:ID=""
90 .S:'$D(VENDOR(ID)) VENDOR(ID)=0 S VENDOR(ID)=VENDOR(ID)+1
91 QUIT
92LEGEND ;Print Flags Legend at end of last page.
93 W !!,?5,"Flags Legend:"
94 W !,"F=FOB is Different from That Requested"
95 W !,"Q=Quantity Quoted is Different from RFQ"
96 W !,"U=Unit of Purchase is Different from RFQ"
97 W !,"DT=Quote Received at Station after Date/Time Set for Receipt of Quotes"
98 W !,"S=RFQ Set-Aside for Small Business But Size Status of Vendor is Large or Missing"
99 W !,"LI=Number of Line Items Quoted Differs from Number of RFQ Line Items"
100 W !,"C=Vendor Indicates Item(s) on Contract"
101 W !,"M=Quoted Mfg. Part Number is Different from that Requested"
102 W !,"V=Vendor has Quoted a Vendor Product Number"
103 W !,"NSN=National Stock Number Quoted is Different from that Requested"
104 W !,"NDC=National Drug Code is Different from that Requested"
105 Q
Note: See TracBrowser for help on using the repository browser.