source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ4.m@ 1096

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

WorldVistAEHR overlayed on FOIAVistA
File size: 7.0 KB
Line 
1PRCHQ4 ;WOIFO/LKG-RFQ Set up Transmission Records ;7/25/05 15:27
2 ;;5.1;IFCAP;**63**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4HE ;Set up Heading segment
5 N PRCN0,PRCN1,PRCA,PRCB,PRCZ,DA,DIC,DR,DIQ,X,Y
6 S PRCN0=$G(^PRC(444,PRCDA,0)),PRCN1=$G(^PRC(444,PRCDA,1))
7 S X=$P(PRCN0,U,2) D JDN^PRCUTL S PRCA="HE^^"_Y_"^^"
8 S X=$P(PRCN1,U,2) D JDN^PRCUTL S PRCA=PRCA_Y_"^"
9 S PRCB=$P(PRCN0,U,3),X=$P(PRCB,".") D JDN^PRCUTL S X=$P(PRCB,".",2)
10 S X=X_$E("000000",$L(X)+1,6),PRCA=PRCA_Y_"^"_X_"^^^^^0^0^0^^^^^|"
11 K DA S DA=$P(PRCN0,U,4) I DA?1.N D
12 . K ^UTILITY("DIQ1",$J)
13 . S DIC=200,DR=".01;.135",DIQ(0)="I" D EN^DIQ1 K DIC,DIQ,DR
14 . S $P(PRCA,"^",8,9)=^UTILITY("DIQ1",$J,200,DA,.01,"I")_"^"_^UTILITY("DIQ1",$J,200,DA,.135,"I")
15 . K ^UTILITY("DIQ1",$J)
16 S ^TMP($J,"STRING",1)=PRCA
17 I $P(PRCA,U,3)'?7N S PRCZ(1)="Invalid RFQ Reference Date"
18 I $P(PRCA,U,5)'?7N S PRCZ(2)="Invalid Requested Delivery Date"
19 I $P(PRCA,U,6)'?7N S PRCZ(3)="Invalid RFQ Bids Due Date"
20 I $P(PRCA,U,7)'?6N S PRCZ(4)="Invalid RFQ Bids Due Time"
21 I $P(PRCA,U,8)="" S PRCZ(5)="Contracting Officer's Name is missing"
22 I $P(PRCA,U,9)="" S PRCZ(6)="Contracting Officer's Commercial Phone # is missing"
23 I $D(PRCZ) S PRCERR=3 D EN^DDIOL(.PRCZ)
24 Q
25VELST(PRCN) ;Gets list of solicited vendors from RFQ and invokes 'VE' setup
26 N PRCX,PRCY,X,PRCW S PRCX=0,PRCW=0
27 F S PRCX=$O(^PRC(444,PRCDA,5,PRCX)) Q:PRCX'?1.N D
28 . S PRCY=$G(^PRC(444,PRCDA,5,PRCX,0)) Q:PRCY=""
29 . S:$P(PRCY,U,2)="" $P(PRCY,U,2)=$P(^PRC(444,PRCDA,0),U,7),$P(^PRC(444,PRCDA,5,PRCX,0),U,2)=$P(PRCY,U,2)
30 . Q:";b;e;"'[(";"_$P(PRCY,U,2)_";")
31 . S PRCY=$P(PRCY,U)
32 . S X=$S(PRCY["PRC(440,":$P($G(^PRC(440,$P(PRCY,";"),7)),U,12),1:$P($G(^PRC(444.1,$P(PRCY,";"),0)),U,2))
33 . I X="" D DUNERR(PRCY) Q
34 . D VE(X,.PRCN) S PRCW=PRCW+1
35 I $P($G(^PRC(444,PRCDA,1)),U,8)="y" D VE("PUBLIC",.PRCN) S PRCW=PRCW+1
36 Q PRCW
37VE(PRCD,PRCC) ;Set up Vendor segment
38 S PRCC=PRCC+1
39 S ^TMP($J,"STRING",PRCC)="VE^"_PRCD_"^^^^^^^^^^^^^^^^^^|"
40 S ^TMP($J,"VE",PRCD)=""
41 Q
42ST(PRCC) ;Setting up Ship to segment
43 N PRCX,PRCY,DA,DIC,DR
44 S PRCY=$G(^PRC(444,PRCDA,0)),PRCX=$P(PRCY,U,10)
45 S:PRCX="" PRCX=$E($P(PRCY,U),1,3)
46 S PRCY=$P($G(^PRC(444,PRCDA,1)),U,3) Q:PRCY'?1.N
47 S PRCX=$G(^PRC(411,PRCX,1,PRCY,0)) Q:PRCX=""
48 S PRCC=PRCC+1
49 I $P(PRCX,U,9)]"" S ^TMP($J,"STRING",PRCC)="ST^"_$P(PRCX,U,9)_"^^^^^^^^^|" G STX
50 S PRCY="ST^^"_$P(PRCX,U)_"^"_$P(PRCX,U,2)_"^"_$P(PRCX,U,3)_"^"_$P(PRCX,U,4)
51 S PRCY=PRCY_"^^"_$P(PRCX,U,5)_"^^"_$TR($P(PRCX,U,7),"-")_"^|"
52 S DA=$P(PRCX,U,6) I DA?1.N D
53 . K ^UTILITY("DIQ1",$J) S DIC=5,DR=1 D EN^DIQ1
54 . S $P(PRCY,U,9)=$E(^UTILITY("DIQ1",$J,5,DA,1),1,2) K ^UTILITY("DIQ1",$J)
55 S ^TMP($J,"STRING",PRCC)=PRCY
56STX Q
57MI(PRCRFQ,PRCC) ;Set up Miscellaneous Information segment
58 N PRCY
59 S PRCY="MI^^^^"_PRCRFQ_"^^^^^^|",PRCC=PRCC+1
60 S ^TMP($J,"STRING",PRCC)=PRCY
61 Q
62AC(PRCC) ;Set up Accounting Information segment
63 N PRCY
64 S PRCY="AC^^"_$P($G(^PRC(444,PRCDA,1)),U)_"^^^^^^^^^^^^^^^^|",PRCC=PRCC+1
65 S ^TMP($J,"STRING",PRCC)=PRCY
66 Q
67TX(PRCN,PRCC) ;Set up Text segment (i.e. Administrative Certification
68 ;;or 864 text)
69 ;;Syntax of call: S X=$$TX^PRCHQ4(ARG1,.ARG2)
70 ;; Returns number of lines in reformatted Word Processing field
71 ;;ARG1: CLOSED GLOBAL ROOT
72 ;;ARG2: CURRENT MESSAGE LINE COUNT
73 N PRCI,PRCT,PRCX,X,DIWL,DIWR,DIWF
74 S PRCX=0,DIWL=1,DIWR=70,DIWF="" K ^UTILITY($J,"W")
75 F S PRCX=$O(@PRCN@(PRCX)) Q:PRCX="" D
76 . Q:'$D(@PRCN@(PRCX,0)) S X=@PRCN@(PRCX,0) D ^DIWP
77 ;I PRCN="^PRC(444,PRCDA,4)",$G(PRCTYPE)="00",$P($G(^PRC(444,PRCDA,1)),U,8)="y" D
78 ;. S X="If you are not an electronic trading partner with VA, you may submit" D ^DIWP
79 ;. S X="your bid by mail or FAX to the Contracting Office. If you would" D ^DIWP
80 ;. S X="like to register as a VA Electronic Trading Partner, please contact" D ^DIWP
81 ;. S X="your Software Provider or VA EDI Staff at 512-326-6463." D ^DIWP
82 S PRCT=$G(^UTILITY($J,"W",1))+0
83 F PRCI=1:1:PRCT D
84 . S PRCC=PRCC+1,X=$G(^UTILITY($J,"W",1,PRCI,0)) S:$L(X)=0 X=" " S X=$TR(X,"^")
85 . S ^TMP($J,"STRING",PRCC)="TX^"_PRCI_"^"_X_"^|"
86 K ^UTILITY($J,"W")
87 Q PRCT
88IT(PRCC) ;Set up Item segment (Also calls SC and DE to set up Delivery
89 ;;Schedule and Description segments for item.)
90 N PRCA,PRCB,PRCD,PRCE,PRCF,PRCG,PRCH,PRCK,PRCL,PRCY,PRCCNT
91 S PRCA=0,PRCCNT=0
92 F S PRCA=$O(^PRC(444,PRCDA,2,PRCA)) Q:PRCA'?1.N D
93 . S PRCL=0
94 . S PRCB=$G(^PRC(444,PRCDA,2,PRCA,0)) Q:PRCB=""
95 . S PRCD=$G(^PRC(444,PRCDA,2,PRCA,1)),PRCG=$P(PRCB,U)
96 . S PRCY="IT^"_PRCG_"^"_$S($P(PRCB,U,6)]"":$P(PRCB,U,6),$P(PRCB,U,5)>0:$P($G(^PRC(441.2,$P(PRCB,U,5),0)),U),1:"")_"^^^",PRCCNT=PRCCNT+1
97 . I $P($G(^PRC(444,PRCDA,5,0)),U,4)=1,$P($G(^PRC(444,PRCDA,1)),U,8)'="y" S $P(PRCY,U,5)=$P($G(^PRC(444,PRCDA,5)),U,2)
98 . S PRCY=PRCY_$P(PRCB,U,9)_"^"_$P(PRCB,U,8)_"^"_($P(PRCB,U,2)*100)_"^^"
99 . S PRCE=$P(PRCB,U,3) S:PRCE?1.N PRCH=$P($G(^PRCD(420.5,PRCE,0)),U),$P(PRCY,U,9)=PRCH
100 . S PRCY=PRCY_"^^^^^^^^^^^^^"
101 . S PRCE=$P(PRCB,U,7) S:PRCE?1.N PRCE=$P($P($G(^PRC(444.2,PRCE,0)),U)," "),$P(PRCY,U,22)=PRCE
102 . S $P(PRCY,U,23,29)=$P(PRCD,U)_"^"_$P(PRCD,U,2)_"^"_$P(PRCB,U,11)_"^"_$P($G(^PRC(444,PRCDA,1)),U)_"^^^|"
103 . S PRCC=PRCC+1,^TMP($J,"STRING",PRCC)=PRCY
104 . S PRCF=PRCC
105 . S $P(^TMP($J,"STRING",PRCF),U,21)=$$DE("^PRC(444,PRCDA,2,PRCA,2)",PRCG,.PRCC)
106 . S $P(^TMP($J,"STRING",PRCF),U,27)=$$SC("^PRC(444,PRCDA,2,PRCA,4)",PRCG,PRCH,.PRCC,.PRCL)
107 . I $P(^TMP($J,"STRING",PRCF),U,3)="" S PRCK(1)="Item #"_$P(PRCB,U)_": FSC and NSN missing"
108 . I $P(^TMP($J,"STRING",PRCF),U,8)'>0 S PRCK(2)="Item #"_$P(PRCB,U)_": Quantity not greater than zero"
109 . I $P(^TMP($J,"STRING",PRCF),U,9)="" S PRCK(3)="Item #"_$P(PRCB,U)_": Unit of Purchase missing"
110 . I $P(^TMP($J,"STRING",PRCF),U,22)="" S PRCK(4)="Item #"_$P(PRCB,U)_": SIC Code missing"
111 . I $P(^TMP($J,"STRING",PRCF),U,21)'>0 S PRCK(5)="Item #"_$P(PRCB,U)_": Item Description missing"
112 . I $P(^TMP($J,"STRING",PRCF),U,27)>0,$P(^(PRCF),U,8)'=PRCL S PRCK(6)="Item #"_$P(PRCB,U)_": Total of Delivery Schedule NOT EQUAL to Line Quantity"
113 S:PRCCNT>0 $P(^TMP($J,"STRING",1),U,12)=PRCCNT
114 I PRCCNT'>0 S PRCK(7)="No Items in RFQ"
115 I $D(PRCK) S PRCERR=2 D EN^DDIOL(.PRCK)
116 Q
117SC(PRCN,PRCIT,PRCU,PRCC,PRCJ) ;Set up Delivery Schedule for item
118 N PRCW,PRCX,PRCY,PRCZ,X,Y
119 S PRCX=0,PRCW=0
120 F S PRCX=$O(@PRCN@(PRCX)) Q:PRCX'?1.N D
121 . S PRCZ=$G(@PRCN@(PRCX,0)) Q:PRCZ=""
122 . S X=$P(PRCZ,U,2) D JDN^PRCUTL
123 . S PRCY="SC^"_PRCIT_"^"_$P(PRCZ,U)_"^"_($P(PRCZ,U,3)*100)_"^"_PRCU
124 . S PRCY=PRCY_"^"_Y_"^|",PRCC=PRCC+1,PRCJ=PRCJ+$P(PRCY,U,4)
125 . S ^TMP($J,"STRING",PRCC)=PRCY,PRCW=PRCW+1
126 Q PRCW
127DE(PRCN,PRCIT,PRCC) ;Set up Item Description segments
128 N PRCI,PRCT,PRCX,X,DIWL,DIWR,DIWF
129 S PRCX=0,DIWL=1,DIWR=70,DIWF="" K ^UTILITY($J,"W")
130 F S PRCX=$O(@PRCN@(PRCX)) Q:PRCX="" D
131 . Q:'$D(@PRCN@(PRCX,0)) S X=@PRCN@(PRCX,0) D ^DIWP
132 S PRCT=$G(^UTILITY($J,"W",1))
133 F PRCI=1:1:PRCT D
134 . S PRCC=PRCC+1,X=$G(^UTILITY($J,"W",1,PRCI,0)) S:$L(X)=0 X=" " S X=$TR(X,"^")
135 . S ^TMP($J,"STRING",PRCC)="DE^"_PRCIT_"^"_PRCI_"^"_X_"^|"
136 K ^UTILITY($J,"W")
137 Q PRCT
138DUNERR(PRCA) ;Displays the Error Message for Vendor Lacking Dun #
139 Q:$D(ZTQUEUED)
140 N PRCB S PRCB="^"_$P(PRCA,";",2)_$P(PRCA,";")_",0)"
141 S PRCB=$P(@PRCB,U)_" lacks a Dun # so NOT a recipient"
142 D EN^DDIOL(PRCB)
143 Q
Note: See TracBrowser for help on using the repository browser.