source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ1C.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 5.4 KB
Line 
1PRCHQ1C ;(WASH IRMFO)/LKG-RFQ INPUT TRANSFORMS ETC (CONT) ;9/5/96 13:25
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4STUFFITM(PRCX,D0,D1) ;Stuff Item Master file info
5 N PRCDT,PRCI,PRCV,PRCW,PRCY,PRCZ,%,%H,%I,X D NOW^%DTC S PRCDT=X
6 I PRCX]"" D
7 . S PRCZ=$G(^PRC(441,PRCX,0)) Q:PRCZ=""
8 . S $P(^PRC(444,D0,2,D1,5),U)=$P(PRCZ,U,2)
9 . K ^PRC(444,D0,2,D1,2)
10 . I $P($G(^PRC(441,PRCX,1,0)),U,4)>0 D
11 . . S PRCY=0,PRCI=0
12 . . F S PRCY=$O(^PRC(441,PRCX,1,PRCY)) Q:+PRCY'=PRCY D
13 . . . Q:'$D(^PRC(441,PRCX,1,PRCY,0)) S PRCW=^(0)
14 . . . S PRCI=PRCI+1,^PRC(444,D0,2,D1,2,PRCI,0)=PRCW
15 . . S ^PRC(444,D0,2,D1,2,0)="^^"_PRCI_"^"_PRCI_"^"_PRCDT
16 . S $P(^PRC(444,D0,2,D1,0),U,5)=$P(PRCZ,U,3)
17 . S $P(^PRC(444,D0,2,D1,0),U,11)=$P(PRCZ,U,14)
18 . S $P(^PRC(444,D0,2,D1,0),U,7)=$P($G(^PRC(441,PRCX,3)),U,10)
19 . S $P(^PRC(444,D0,2,D1,0),U,6)=$P(PRCZ,U,5)
20 . S $P(^PRC(444,D0,2,D1,0),U,9)=$P($G(^PRC(441,PRCX,3)),U,5)
21 . S PRCY=$P(PRCZ,U,4)
22 . I PRCY="" S $P(^PRC(444,D0,2,D1,1),U,3,7)="^^^^" Q
23 . S PRCZ=$G(^PRC(441,PRCX,2,PRCY,0)) Q:PRCZ=""
24 . S $P(^PRC(444,D0,2,D1,1),U,3,7)=PRCY_U_$P(PRCZ,U,4)_U_$P(PRCZ,U,2)_U_$P(PRCZ,U,7)_U_$P(PRCZ,U,6)
25 . S $P(^PRC(444,D0,2,D1,0),U,8)=$P(PRCZ,U,5)
26 . S PRCW=$P(PRCZ,U,8),PRCV=$P(PRCZ,U,7) S:PRCW]"" PRCW="PACKAGING MULTIPLE: "_PRCW
27 . S:PRCV]"" PRCW=PRCW_"/"_$P($G(^PRCD(420.5,PRCV,0)),U)
28 . S:PRCV]"" $P(^PRC(444,D0,2,D1,0),U,3)=PRCV
29 . I PRCW]"" D
30 . . S PRCI=$P($G(^PRC(444,D0,2,D1,2,0)),U,3)
31 . . S PRCI=PRCI+1,^PRC(444,D0,2,D1,2,PRCI,0)=PRCW
32 . . S ^PRC(444,D0,2,D1,2,0)="^^"_PRCI_"^"_PRCI_"^"_PRCDT
33 I PRCX="" D
34 . S $P(^PRC(444,D0,2,D1,5),U)="" K ^PRC(444,D0,2,D1,2)
35 . S $P(^PRC(444,D0,2,D1,0),U,3,9)="^^^^^^",$P(^(0),U,11)=""
36 . S $P(^PRC(444,D0,2,D1,1),U,3,7)="^^^^"
37 Q
38ADMCERT(D0) ;Lookup and add Administrative Certification
39 N DIR,DIC,X,Y,DIRUT,DIROUT,DTOUT,DUOUT,%,%H,%I,PRCDT,PRCI,PRCJ,PRCX,PRCY,PRCZ
40 D NOW^%DTC S PRCDT=X
41 S PRCJ=+$P($G(^PRC(444,D0,4,0)),U,4)
42 W !,"There are currently ",PRCJ," lines of Administrative Certification."
43 S DIR(0)="YA",DIR("A")="Do you wish to add a standard Administrative Certification phrase? "
44 S DIR("B")="YES" D ^DIR K DIR
45 I $D(DIRUT)!$D(DIROUT) S X="^" Q X
46 I Y'=1 S X="" Q X
47ADMLOOP S DIC=442.7,DIC(0)="AEMZ" D ^DIC K DIC
48 I $D(DUOUT)!$D(DTOUT) S X="^" Q X
49 I Y<1 S X="" Q X
50 S PRCX=+Y,PRCY=0,PRCJ=$P($G(^PRC(444,D0,4,0)),U,3,4),PRCI=$P(PRCJ,U),PRCJ=$P(PRCJ,U,2)
51 ;Adding a blank line between each Administrative Cert.
52 I PRCI>0 D
53 . S PRCI=PRCI+1
54 . S PRCJ=PRCJ+1
55 . S ^PRC(444,D0,4,PRCI,0)=" "
56 F S PRCY=$O(^PRC(442.7,PRCX,1,PRCY)) Q:+PRCY'=PRCY D
57 . Q:'$D(^PRC(442.7,PRCX,1,PRCY,0)) S PRCZ=^(0)
58 . S PRCI=PRCI+1,PRCJ=PRCJ+1,^PRC(444,D0,4,PRCI,0)=PRCZ
59 ;I PRCI>0 S PRCI=PRCI+1,PRCJ=PRCJ+1,^PRC(444,D0,4,PRCI,0)=PRCTILDA
60 S:PRCJ>0 ^PRC(444,D0,4,0)="^^"_PRCI_"^"_PRCJ_"^"_PRCDT
61 W !,"Administrative Certification phrase #",PRCX," has been added."
62 G ADMLOOP
63 ;
64QUOTEDUE(PRCX,PRCY,PRCZ) ;Input transform for Date Quote Due in Input Template
65 N X1,X2,%Y,X
66 S X1=PRCX,X2=PRCY D ^%DTC I X<3 W !,"Quote Due Date must be at least 3 days after RFQ Reference Date." Q 1
67 I PRCX'<PRCZ W !,"Quote Due Date must be before Required Delivery Date." Q 13
68 S X=""
69 Q X
70DELTOTAL(D0,D1) ;Check Delivery Total
71 N PRCX,PRCY S PRCX=""
72 Q:$P($G(^PRC(444,D0,2,D1,4,0)),U,4)'>0 PRCX
73 S PRCX=0,PRCY=0
74 F S PRCX=$O(^PRC(444,D0,2,D1,4,PRCX)) Q:+PRCX'=PRCX D
75 . S PRCY=PRCY+$P($G(^PRC(444,D0,2,D1,4,PRCX,0)),U,3)
76 S PRCX=+$P($G(^PRC(444,D0,2,D1,0)),U,2)
77 I PRCX'=PRCY W !,"Total Quantity of Delivery Schedule does NOT equal Item Quantity.",!," ",PRCY," versus ",PRCX S PRCX=20 Q PRCX
78 S PRCX=""
79 Q PRCX
80NSN(PRCY) ;Validation of National Stock #
81 N PRCX
82 Q:PRCY="" PRCY
83 I '$D(^PRC(441.2,+PRCY,0)) W !,"Invalid NSN - First 4 characters must be a FSC Code." Q 5
84 S PRCX=$O(^PRC(441,"BB",PRCY,0))
85 S:PRCX=PRCITMO PRCX=$O(^PRC(441,"BB",PRCY,PRCX))
86 I PRCX'="" W !,"This NSN has already been assigned to Item #",PRCX Q 5
87 S PRCY=""
88 Q PRCY
89PREF ;User enter editing preference into file #444.4
90 K DIC,DA
91 I '$D(^PRC(444.4,DUZ)) D I Y<1!(+Y'=DUZ) W !,"Entry not properly added!" Q
92 . K DD,DO S DIC="^PRC(444.4,",DIC(0)="LX",X=DUZ,DLAYGO=444.4,DINUM=X
93 . D FILE^DICN K DIC,DLAYGO
94 K DA S DA=DUZ,DIE="^PRC(444.4,",DR=1 D ^DIE K DIE,DR,DA,DTOUT,DUOUT
95 Q
96EDITOR() ;Returns the chosen editor
97 N X,Y,DIR,DIRUT,DIROUT,DTOUT,DUOUT S X="" Q:$D(DUZ)#10'=1 X
98 S X=$P($G(^PRC(444.4,DUZ,0)),U,2) I X="i"!(X="s") Q X
99 S DIR(0)="SMA^i:Input Template;s:ScreenMan Form",DIR("A")="Enter Desired Input Mode: "
100 S DIR("?",1)="Here you can indicate if you wish to edit in scroll mode with FileMan"
101 S DIR("?")=" Input Templates or screen mode with ScreenMan"
102 D ^DIR I $D(DIROUT)!$D(DIRUT)!$D(DTOUT) S X="" Q X
103 Q Y
104LINENETS(D0,D1) ;Stuffs net line amounts for items in quote
105 ;;Net = Unit_Price * Quantity - Volume_Discount
106 N PRCX,PRCY,PRCV,PRCW,PRCDA3
107 S PRCDA3=0
108 F S PRCDA3=$O(^PRC(444,D0,8,D1,3,PRCDA3)) Q:+PRCDA3'=PRCDA3 D
109 . S PRCV=$G(^PRC(444,D0,8,D1,3,PRCDA3,0)),PRCW=$G(^(1))
110 . S PRCX=$P(PRCW,U,3)*$P(PRCV,U,2),PRCY=+$P(PRCW,U,4)
111 . S PRCY=$S(PRCY>0:PRCX*PRCY/100,1:$P(PRCW,U,5))
112 . S:PRCY>0 PRCX=PRCX-PRCY
113 . S $P(^PRC(444,D0,8,D1,3,PRCDA3,1),U,7)=$FN(PRCX,"",2)
114 Q
115METHOD(PRCX,PRCVEN) ;Additional Validation for Method of Solicitation
116 N PRCERR,PRCY S PRCY=""
117 Q:PRCX="m" PRCY
118 I PRCVEN'["PRC(440" S PRCERR=1 G METHMSG
119 S:$P($G(^PRC(440,+PRCVEN,3)),U,2)'="Y" PRCERR=1
120 S:$P($G(^PRC(440,+PRCVEN,7)),U,12)="" PRCERR=1
121METHMSG I $G(PRCERR) D EN^DDIOL("Only MANUAL method is available for Non-EDI Vendor or vendor without Dun#.") Q 1
122 Q PRCY
Note: See TracBrowser for help on using the repository browser.