source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ6B.m@ 1742

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

initial load of WorldVistAEHR
File size: 5.0 KB
Line 
1PRCHQ6B ;(WASH IRMFO)/LKG-RFQ SERVER UNPACKING VENDOR QUOTE ;9/11/96 15:41
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5ITEM S PRCIENS="+1,"_PRC("D1")_","_PRC("D0")_",",PRCAR(444.026,PRCIENS,.01)=+$P(PRCX,U,2)
6 D UPDATE^DIE("E","PRCAR","PRCENUM") D:$D(^TMP("DIERR",$J)) ERRCOPY^PRCHQ6A
7 I $G(PRCENUM(1))'?1.N S PRCERR=16 G ERR
8 S PRC("D2")=PRCENUM(1),PRCIENS=PRC("D2")_","_PRC("D1")_","_PRC("D0")_","
9 K PRCAR,PRCENUM S PRCITEMS=PRCITEMS+1
10 S PRCY=$P(PRCX,U,3) S:$L(PRCY)>4 PRCAR(444.026,PRCIENS,5)=PRCY
11 S PRCAR(444.026,PRCIENS,4)=$P(PRCY,"-")
12 S PRCY=$P(PRCX,U,5) S:PRCY]"" PRCAR(444.026,PRCIENS,1)=PRCY
13 S PRCY=$P(PRCX,U,6) S:PRCY]"" PRCAR(444.026,PRCIENS,8)=PRCY
14 S PRCY=$P(PRCX,U,7) S:PRCY]"" PRCAR(444.026,PRCIENS,7)=PRCY
15 S PRCAR(444.026,PRCIENS,2)=$P(PRCX,U,8)/100
16 S PRCAR(444.026,PRCIENS,3)=$P(PRCX,U,9)
17 S PRCAR(444.026,PRCIENS,13)=$P(PRCX,U,10)/10000
18 S PRCY=$P(PRCX,U,12)
19 I PRCY]"" D
20 . S PRCY="."_PRCY*100
21 . S PRCAR(444.026,PRCIENS,14)=PRCY
22 S PRCY=$P(PRCX,U,13) S:PRCY]"" PRCAR(444.026,PRCIENS,15)=PRCY/100
23 S PRCY=$P(PRCX,U,19) S:PRCY]"" PRCAR(444.026,PRCIENS,16)=PRCY
24 S PRCY=$P(PRCX,U,23) S:PRCY]"" PRCAR(444.026,PRCIENS,9)=PRCY
25 S PRCY=$P(PRCX,U,24) S:PRCY]"" PRCAR(444.026,PRCIENS,10)=PRCY
26 S PRCY=$P(PRCX,U,22) S:PRCY]""&(PRCY'="000000") PRCAR(444.026,PRCIENS,6)=$S($D(^PRC(444.2,PRCY,0)):$P(^(0),U),1:PRCY)
27 S PRCY=$P(PRCX,U,25) S:PRCY]"" PRCAR(444.026,PRCIENS,12)=$S(PRCY="HM":"HAZARDOUS MATERIAL",1:PRCY)
28 S PRCY=$P(PRCX,U,26) S:PRCY]"" PRCAR(444.026,PRCIENS,11)=$S(PRCY="O":"ORIGIN",PRCY="D":"DESTINATION",1:PRCY)
29 S PRCAR(444.026,PRCIENS,18)=$FN($G(PRCAR(444.026,PRCIENS,13))*$G(PRCAR(444.026,PRCIENS,2)),"",2)
30 S X=$S($G(PRCAR(444.026,PRCIENS,14))>0:PRCAR(444.026,PRCIENS,18)*PRCAR(444.026,PRCIENS,14)/100,1:$G(PRCAR(444.026,PRCIENS,15)))
31 S:X>0 PRCAR(444.026,PRCIENS,18)=$FN(PRCAR(444.026,PRCIENS,18)-X,"",2) K X
32 D FILE^DIE("E","PRCAR") K PRCAR D:$D(^TMP("DIERR",$J)) ERRCOPY^PRCHQ6A
33 K ^TMP($J,"DE") S PRCJ=0
34 F S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) Q:PRCI="" S PRCX=$G(^(PRCI,0)) Q:$P(PRCX,U)'="DE" D
35 . S PRCJ=PRCJ+1,^TMP($J,"DE",PRCJ,0)=$P(PRCX,U,4)
36 D:PRCJ>0 WP^DIE(444.026,PRCIENS,1.5,"","^TMP($J,""DE"")")
37 D:$D(^TMP("DIERR",$J)) ERRCOPY^PRCHQ6A
38 K ^TMP($J,"DE")
39 G EX:PRCI="",EX:$P(PRCX,U)="$",ITEM:$P(PRCX,U)="IT"
40 I $P(PRCX,U)'="SC" S PRCERR=12 G ERR
41DELSCHED ;Delivery Schedule Loop
42 S PRCIENS="+1,"_PRC("D2")_","_PRC("D1")_","_PRC("D0")_","
43 S PRCAR(444.027,PRCIENS,.01)=+$P(PRCX,U,3)
44 D UPDATE^DIE("E","PRCAR","PRCENUM") D:$D(^TMP("DIERR",$J)) ERRCOPY^PRCHQ6A
45 I $G(PRCENUM(1))'?1.N S PRCERR=17 G ERR
46 S PRC("D3")=PRCENUM(1)
47 S PRCIENS=PRC("D3")_","_PRC("D2")_","_PRC("D1")_","_PRC("D0")_","
48 K PRCAR,PRCENUM
49 S PRCAR(444.027,PRCIENS,2)=$P(PRCX,U,4)/100
50 S PRCAR(444.027,PRCIENS,3)=$P(PRCX,U,5)
51 S X=$$JD2FMD^PRCHQ7($P(PRCX,U,6)),X=+$E(X,4,5)_"/"_(+$E(X,6,7))_"/"_($E(X,1,3)+1700)
52 S PRCAR(444.027,PRCIENS,1)=X K X
53 D FILE^DIE("E","PRCAR") K PRCAR D:$D(^TMP("DIERR",$J)) ERRCOPY^PRCHQ6A
54 S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) G:PRCI="" EX
55 S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0))
56 G DELSCHED:$P(PRCX,U)="SC",ITEM:$P(PRCX,U)="IT"
57 I $P(PRCX,U)'="$",$P(PRCX,U)'="~" S PRCERR=13 G ERR
58EX ;
59 I $D(PRC("D0")),$D(PRC("D1")) D QUOTETOT^PRCHQ1B(PRC("D0"),PRC("D1"))
60 I $G(PRCITEMS)'=$G(PRCICNT) S PRCERR=14 G ERR
61 I $D(^TMP($J,"PRCERR")) G ERR
62EX1 L:$D(PRC("D0")) -^PRC(444,PRC("D0"))
63 K PRC,PRCAR,PRCDA,PRCDB,PRCDBI,PRCEFFDT,PRCENUM,PRCERR,PRCI,PRCICNT,PRCITEMS
64 K PRCIENS,PRCJ,PRCNUM,PRCRCVDT,PRCREF,PRCRFQ,PRCVCN,PRCVCP,PRCVDA,PRCVEN
65 K PRCX,PRCY,X,Y,PRCVNM
66 S:$D(ZTQUEUED) ZTREQ="@"
67 Q
68ERR ;
69 K ^TMP($J,"MSG")
70 S ^TMP($J,"MSG",1,0)="During the filing of an 843 Transaction (Vendor's Quote) from vendor"
71 S ^TMP($J,"MSG",2,0)=$G(PRCDB)_" for RFQ # "_$G(PRCRFQ)_", the following errors"
72 S ^TMP($J,"MSG",3,0)="occurred: ",PRCJ=3
73 S:$D(PRCERR) PRCJ=PRCJ+1,^TMP($J,"MSG",PRCJ,0)=$P($T(TXT+PRCERR),";;",2)
74 I $D(^TMP($J,"PRCERR")) D
75 . S PRCX=0
76 . F S PRCX=$O(^TMP($J,"PRCERR",PRCX)) Q:PRCX'?1.N D
77 . . S:$D(^TMP($J,"PRCERR",PRCX)) PRCJ=PRCJ+1,^TMP($J,"MSG",PRCJ,0)=^(PRCX)
78 S XMTEXT="^TMP($J,""MSG"","
79 I $D(PRC("D0")) S X=$P($G(^PRC(444,PRC("D0"),0)),U,4) S:X?1.N XMY(X)=""
80 S XMY("G.PRCHQ RFQ")="" ;,XMDUZ="843 Vendor Quote Filer"
81 S XMSUB="Error filing Quote for RFQ #: "_$G(PRCRFQ)
82 D ^XMD K XMZ,^TMP($J,"MSG"),^TMP($J,"PRCERR"),XMY,XMTEXT,XMSUB
83 G EX1
84TXT ;Error Messages
85 ;;No segments to process in the File #423.6 entry.
86 ;;Initial segment not 'ISM' for 843 Transaction (Vendor's Quote).
87 ;;No 'HE' segment.
88 ;;Referenced RFQ not found in REQUEST FOR QUOTATION File (#444).
89 ;;Unable to lock RFQ entry - timed out.
90 ;;No 'VE' Segment.
91 ;;Unable to add submitting vendor to RFQ VENDOR File (#444.1).
92 ;;Unable to add entry to QUOTES multiple of File (#444).
93 ;;Unable to lock QUOTES entry - timed out.
94 ;;No 'AC' segment.
95 ;;No 'IT' segment.
96 ;;Segment type 'SC' expected but not found.
97 ;;Inappropriate segment type following 'SC' segment.
98 ;;Number of Items Processed does not equal Number of Items
99 ;;Unable to add Prompt Pay Terms
100 ;;Unable to add entry to ITEM multiple
101 ;;Unable to add entry to DELIVERY SCHEDULE multiple
Note: See TracBrowser for help on using the repository browser.