source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ1B.m@ 1078

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

initial load of WorldVistAEHR

File size: 5.6 KB
Line 
1PRCHQ1B ;(WASH ISC)/LKG - Request for Quotation ;8/6/96 20:48
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4BOCINP ;Input transform for BOC
5 N PRC2237,Z0,DIC
6 S PRC2237=$P($G(^PRC(444,D0,0)),U,9) I PRC2237'?1.N K X Q
7 S Z0=$S($D(^PRCS(410,PRC2237,3)):+$P(^(3),U,3),1:0)
8 I 'Z0!'$D(^PRCD(420.1,Z0,1,0)) K X Q
9 S DIC="^PRCD(420.1,Z0,1,",DIC(0)="EMQZ" D ^DIC
10 I +Y'>0 K X Q
11 S X=+$P(Y(0),U) I '$D(^PRCD(420.2,X,0)) K X Q
12 Q
13BOCHLP ;Executable help for BOC
14 N PRCTXT,PRC2237,D,Z0,DIC,PRCDA S PRCDA=D0
15 S PRCTXT(1)="Major budget object code classifications are:"
16 S PRCTXT(2)="10 thru 13 - Personal Services and Benefits"
17 S PRCTXT(3)=" 21 - Travel and Transportation of Persons"
18 S PRCTXT(4)=" 22 - Transportation of Things"
19 S PRCTXT(5)=" 23 - Rent, Communications, and Utilities"
20 S PRCTXT(6)=" 24 - Printing and Reproduction"
21 S PRCTXT(7)=" 25 - Other Services"
22 S PRCTXT(8)=" 26 - Supplies and Materials"
23 S PRCTXT(9)="31 thru 33 - Acquisition of Capital Assets"
24 D EN^DDIOL(.PRCTXT)
25 S PRC2237=$P($G(^PRC(444,PRCDA,0)),U,9)
26 I PRC2237'?1.N D EN^DDIOL("2237 pointer is missing so can't determine available BOCs.") Q
27 S X="?",Z0=$S($D(^PRCS(410,PRC2237,3)):+$P(^(3),U,3),1:0)
28 I 'Z0!'$D(^PRCD(420.1,Z0,1,0)) D EN^DDIOL("2237's Cost Center is missing so can't determine available BOCs.") Q
29 S DIC="^PRCD(420.1,Z0,1,",DIC(0)="QEM" D ^DIC
30 Q
31LINENET() ;Calculates the net line amount for item in quote
32 ;;Net = Unit_Price * Quantity - Volume_Discount
33 N PRCX,PRCY
34 S PRCX=$$GET^DDSVAL(444.026,.DA,13)*$$GET^DDSVAL(444.026,.DA,2)
35 S PRCY=+$$GET^DDSVAL(444.026,.DA,14)
36 S PRCY=$S(PRCY>0:PRCX*PRCY/100,1:$$GET^DDSVAL(444.026,.DA,15))
37 S:PRCY>0 PRCX=PRCX-PRCY
38 Q $FN(PRCX,"",2)
39STATUSDT ;Sets/Clears Date assigned critical statuses
40 N PRCI S PRCI=$S(X=0:16,X=2:15,X=3:12,X=4:13,X=5:14,1:"")
41 I PRCI]"" D
42 . N %,%H,%I,X D NOW^%DTC
43 . S $P(^PRC(444,DA,1),U,PRCI)=%
44 I X=1!(X=2) D
45 . S $P(^PRC(444,DA,1),U,12,13)="^"
46 Q
47DUN(Z) ;Returns Dun number for Solicited Vendor (Z=5) or Quote Vendor (Z=8)
48 N X,Y S Y=""
49 I $D(D0),$D(D1) D
50 . S X=$P($G(^PRC(444,D0,Z,D1,0)),U) Q:X=""
51 . S Y=$S($P(X,";",2)[440:$P($G(^PRC(440,$P(X,";"),7)),U,12),1:$P($G(^PRC(444.1,$P(X,";"),0)),U,2))
52 Q Y
53QUOTETOT(PRCD0,PRCD1) ;Sets Total for Quote in field #8 of subfile #444.024
54 N PRCX,PRCI,DA,DIC,DIE,DR S PRCX=0,PRCI=0
55 F S PRCI=$O(^PRC(444,PRCD0,8,PRCD1,3,PRCI)) Q:PRCI'?1.N D
56 . S PRCX=PRCX+$P($G(^PRC(444,PRCD0,8,PRCD1,3,PRCI,1)),U,7)
57 S PRCX=PRCX+$P($G(^PRC(444,PRCD0,8,PRCD1,1)),U,2)
58 S DA=PRCD1,DA(1)=PRCD0,DIE="^PRC(444,DA(1),8,",DR="8///^S X=PRCX"
59 D ^DIE
60 Q
61PUBLIC ;Sets Required status of Transmit to Public field
62 N PRCX,PRCIENS
63 S PRCX=$$GET^DDSVAL(444,DA,6,"","I"),PRCX=$S(PRCX="m":0,1:1)
64 S PRCIENS=DA_","
65 D REQ^DDSUTL(2,"PRCHQ7",6,PRCX,PRCIENS)
66 Q
67PUBLIC2 ;Sets Require status of Transmit to Public when Method
68 ;of Processing Changes.
69 N PRCX,PRCIENS
70 S PRCIENS=DA_",",PRCX=$S(X="m":0,1:1)
71 D REQ^DDSUTL(2,"PRCHQ7",6,PRCX,PRCIENS)
72 Q
73FCP ;Input Transform for Fund Control Point
74 N Z0,DIC
75 S Z0=$E($P(^PRC(444,DA,0),U),1,3) K:'Z0 X Q:'Z0
76 Q:'$D(^PRC(420,Z0,1,0))
77 S DIC="^PRC(420,Z0,1,",DIC(0)="QEMNZ" D ^DIC S X=$P(Y(0),U)
78 K:Y'>0 X
79 Q
80FCPHLP ;Executable Help for Fund Control Point
81 N ZD,Z0,DIC
82 S:$D(D)#10=1 ZD=D,X="?",Z0=$E($P(^PRC(444,DA,0),U),1,3) Q:'Z0
83 Q:'$D(^PRC(420,Z0,1,0))
84 S DIC="^PRC(420,Z0,1,",DIC(0)="QEM" D ^DIC S:$D(ZD)#10=1 D=ZD
85 Q
86REQDFLD1 ;Checks required fields in Item edit page
87 N PRCIT,PRCJ,PRCAR,PRCWP
88 S PRCJ=1
89 S PRCIT=$$GET^DDSVAL(444.019,.DA,.01)
90 I PRCIT="" S PRCJ=PRCJ+1,PRCAR(PRCJ)="Line Item # is missing"
91 S PRCWP=$$GET^DDSVAL(444.019,.DA,1.5)
92 I $P($G(@PRCWP@(0)),U,4)'>0 S PRCJ=PRCJ+1,PRCAR(PRCJ)="Description is missing for Item #"_PRCIT
93 I $$GET^DDSVAL(444.019,.DA,1.6)="" S PRCJ=PRCJ+1,PRCAR(PRCJ)="Short Description is missing for Item #"_PRCIT
94 I $$GET^DDSVAL(444.019,.DA,3)="" S PRCJ=PRCJ+1,PRCAR(PRCJ)="Unit of Purchase is missing for Item #"_PRCIT
95 I $$GET^DDSVAL(444.019,.DA,2)="" S PRCJ=PRCJ+1,PRCAR(PRCJ)="Quantity is missing for Item #"_PRCIT
96 I $$GET^DDSVAL(444.019,.DA,6)="" S PRCJ=PRCJ+1,PRCAR(PRCJ)="SIC Code is missing for Item #"_PRCIT
97 I $$GET^DDSVAL(444.019,.DA,4)="" S PRCJ=PRCJ+1,PRCAR(PRCJ)="Federal Supply Class is missing for Item #"_PRCIT
98 I $$GET^DDSVAL(444.019,.DA,12.5)="" S PRCJ=PRCJ+1,PRCAR(PRCJ)="BOC is missing for Item #"_PRCIT
99 I PRCJ>1 D
100 . S PRCAR(1)="** Warning: The following Required Fields were not completed: "
101 . D HLP^DDSUTL(.PRCAR) D HLP^DDSUTL("$$EOP")
102 Q
103REQDFLD2 ;Checks required fields in Delivery Schedule
104 N PRCDS,PRCJ,PRCAR S PRCJ=1
105 Q:$G(DA)'>0
106 S PRCDS=$$GET^DDSVAL(444.039,.DA,.01) Q:PRCDS=""
107 I $$GET^DDSVAL(444.039,.DA,1)="" S PRCJ=PRCJ+1,PRCAR(PRCJ)="Delivery Date is missing for Delivery Schedule #"_PRCDS
108 I $$GET^DDSVAL(444.039,.DA,2)="" S PRCJ=PRCJ+1,PRCAR(PRCJ)="Quantity is missing for Delivery Schedule #"_PRCDS
109 I PRCJ>1 D
110 . S PRCAR(1)="** Warning: The following Required Fields were not completed: "
111 . D HLP^DDSUTL(.PRCAR) D HLP^DDSUTL("$$EOP")
112 Q
113METHOD(PRCX) ;Additional Data Validation for Method of Solicitation
114 Q:PRCX="m" N PRCVEN
115 S PRCVEN=$$GET^DDSVAL(444.01,.DA,.01,"","I")
116 I PRCVEN'["PRC(440" S DDSERROR=1
117 I PRCVEN["PRC(440",$P($G(^PRC(440,+PRCVEN,3)),U,2)'="Y" S DDSERROR=1
118 I PRCVEN["PRC(440",$P($G(^PRC(440,+PRCVEN,7)),U,12)="" S DDSERROR=1
119 D:$G(DDSERROR)=1 HLP^DDSUTL("Only MANUAL method is available for Non-EDI Vendor or vendor without Dun#.")
120 Q
121DBCHK(PRCX) ;Validates Dun & Bradstreet # by Mod 10 and Mod 10 plus 5
122 N I,T,V,W,Y,Z S Y=$E(PRCX,$L(PRCX))
123 S W="" F I=1:1:$L(PRCX)-1 S Z=$E(PRCX,I),W=W_(1+(I#2=0)*Z)
124 S T=0 F I=1:1:$L(W) S T=T+$E(W,I)
125 S V=T\10+1*10-T,V=$E(V,$L(V))
126 I V=Y Q 1 ;Mod 10 checksum
127 S V=V+5,V=$E(V,$L(V)) I V=Y Q 1 ;Mod 10 plus 5 checksum
128 Q 0
Note: See TracBrowser for help on using the repository browser.