source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ13A.m@ 1420

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

initial load of WorldVistAEHR
File size: 4.5 KB
Line 
1PRCHQ13A ;(WASH IRMFO)/LKG-RFQ Award ;8/6/96 20:46
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN ;Entry point for awarding evaluation complete RFQs
5 K DIC S DIC="^PRC(444,",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,8)=4"
6 S DIC("A")="Select RFQ to Award: " D ^DIC K DIC
7 G EX1:+Y<1!$D(DTOUT)!$D(DUOUT)
8 S PRCDA=+Y,PRCRFQ=$P(Y,U,2)
9 L +^PRC(444,PRCDA):5 E W !,"This RFQ entry is in use, please try later!" G EN
10 K DIR S DIR(0)="YA",DIR("A")="Do you wish to review this RFQ? "
11 S DIR("B")="YES",DIR("?")="Answer 'YES' if you wish to view the RFQ before proceeding with the award."
12 D ^DIR K DIR
13 I Y=1 D G:Y'=1 A
14 . N L,DIC,DR,FLDS,BY,FR,TO,IOP S DIC=444,BY=.01,(FR,TO)=PRCRFQ,L=0,IOP="HOME"
15 . S FLDS="[PRCHQ RFQ FULL]" D EN1^DIP K DIC,FLDS,BY,FR,DR,L
16 . S DIR(0)="YA",DIR("A")="Is this the correct RFQ? ",DIR("B")="NO"
17 . S DIR("?")="Answer 'NO' to abort the Award."
18 . D ^DIR K DIR
19 S PRCMSG="" D ESIG^PRCUESIG(DUZ,.PRCMSG) G:PRCMSG'=1 EX1
20 D AWARD(PRCDA)
21A L -^PRC(444,PRCDA)
22 G EN:'$D(DIRUT)&'$D(DIROUT)
23EX1 L:$D(PRCDA) -^PRC(444,PRCDA)
24 K DIC,DTOUT,DUOUT,DIRUT,DIROUT,PRCDA,PRCRFQ,X,Y,PRCMSG
25 Q
26 ;;Driver for calls to set up 2237 and PO documents
27AWARD(PRCRFQDA) ;Entry point for creating 2237 and PO documents
28 N PRCQDA,PRCNLNK S PRCQDA=0 K ^TMP($J,"RFQ")
29 F S PRCQDA=$O(^PRC(444,PRCRFQDA,2,"AJ",PRCQDA)) Q:+PRCQDA'=PRCQDA D
30 . N PRCAR,PRCX
31 . S PRCV=$P($G(^PRC(444,PRCRFQDA,8,PRCQDA,0)),U)
32 . I '$D(@("^"_$P(PRCV,";",2)_(+PRCV)_",0)")) S PRCAR="Vendor submitting Quote #"_PRCQDA_" is not in the database!" D EN^DDIOL(PRCAR) K PRCAR Q
33 . I PRCV["PRC(444.1",$P($G(^PRC(444.1,+PRCV,0)),U,9)="" D Q:PRCNLNK
34 . . K PRCAR S PRCX=^PRC(444.1,+PRCV,0),PRCNLNK=0
35 . . S PRCAR(1)="Vendor "_$P(PRCX,U)_" Dun # "_$P(PRCX,U,2)_" must be linked to an"
36 . . S PRCAR(2)="existing File #440 entry before he can receive awards."
37 . . D EN^DDIOL(.PRCAR) K PRCAR
38 . . K DIR S DIR(0)="YA",DIR("A")="Do you wish to link the vendor at this time? "
39 . . S DIR("B")="YES",DIR("?")="Answer 'YES' to continue or 'NO' to bypass this vendor"
40 . . D ^DIR K DIR
41 . . I Y'=1 D EN^DDIOL("Bypassing this vendor") S PRCNLNK=1 Q
42 . . S DA=+PRCV,DIE=444.1,DR=60 D ^DIE K DIE,DR,DA
43 . . I $P(^PRC(444.1,+PRCV,0),U,9)="" D EN^DDIOL("Bypassing this vendor") S PRCNLNK=1 Q
44 . S PRCI=0
45 . F S PRCI=$O(^PRC(444,PRCRFQDA,2,"AJ",PRCQDA,PRCI)) Q:+PRCI'=PRCI D
46 . . S PRCLN=$P($G(^PRC(444,PRCRFQDA,2,PRCI,0)),U) Q:PRCLN=""
47 . . Q:$P($G(^PRC(444,PRCRFQDA,2,PRCI,3)),U,6)]""
48 . . S PRCITM=$P(^PRC(444,PRCRFQDA,2,PRCI,0),U,4)
49 . . I PRCITM]"" D Q:$G(PRCSKIP)
50 . . . S PRCSKIP=0
51 . . . S PRCVEN=$S(PRCV["PRC(444.1":$P(^PRC(444.1,+PRCV,0),U,9),1:+PRCV)
52 . . . I '$D(^PRC(441,PRCITM,2,PRCVEN)) D
53 . . . . K PRCAR
54 . . . . S PRCAR(1)="Vendor "_$P($G(^PRC(440,PRCVEN,0)),U)_" Dun # "_$P($G(^PRC(440,PRCVEN,7)),U,12)_" must be associated"
55 . . . . S PRCAR(2)="with ITEM MASTER File entry #"_PRCITM_" before he can be awarded this"
56 . . . . S PRCAR(3)="item."
57 . . . . D EN^DDIOL(.PRCAR) K PRCAR S PRCSKIP=1
58 . . S PRCK=$O(^PRC(444,PRCRFQDA,8,PRCQDA,3,"B",PRCLN,"")) Q:PRCK=""
59 . . S PRCFOB=$P($G(^PRC(444,PRCRFQDA,8,PRCQDA,3,PRCK,0)),U,10)
60 . . S:PRCFOB="" PRCFOB=$P($G(^PRC(444,PRCRFQDA,8,PRCQDA,1)),U)
61 . . S:PRCFOB="" PRCFOB=$P($G(^PRC(444,PRCRFQDA,1)),U)
62 . . S ^TMP($J,"RFQ",PRCRFQDA,PRCQDA,PRCFOB,PRCI)=""
63 S PRCQDA=0
64 F S PRCQDA=$O(^TMP($J,"RFQ",PRCRFQDA,PRCQDA)) Q:PRCQDA="" D
65 . S PRCFOB=""
66 . F S PRCFOB=$O(^TMP($J,"RFQ",PRCRFQDA,PRCQDA,PRCFOB)) Q:PRCFOB="" D
67 . . S PRC2237=$$REQUEST^PRCHQ410(PRCRFQDA,PRCQDA,"^TMP($J,""RFQ"",PRCRFQDA,PRCQDA,PRCFOB)")
68 . . I PRC2237>0 D
69 . . . K PRCAR S PRCAR="2237 #"_$P($G(^PRCS(410,PRC2237,0)),U)_" has been built for Quote #"_PRCQDA_"." D EN^DDIOL(PRCAR) K PRCAR
70 . . . S PRCRFQPO=$$POBLD^PRCHQ15(PRC2237,PRCRFQDA,PRCQDA,PRCFOB)
71 . . . I PRCRFQPO'="" K PRCAR S PRCAR="PO #"_PRCRFQPO_" has been built for Quote #"_PRCQDA_"." D EN^DDIOL(PRCAR) K PRCAR
72 S PRCI=0,PRCAWARD=1
73 F S PRCI=$O(^PRC(444,PRCRFQDA,2,PRCI)) Q:+PRCI'=PRCI D Q:'PRCAWARD
74 . I $P($G(^PRC(444,PRCRFQDA,2,PRCI,3)),U,6)="" S PRCAWARD=0
75 I PRCAWARD,$P(^PRC(444,PRCRFQDA,0),U,8)'=5 D
76 . S PRCOSTAT=$P("CANCELLED^INCOMPLETE^PENDING QUOTES^CLOSED^EVALUATION COMPLETE^AWARDED",U,$P(^PRC(444,PRCRFQDA,0),U,8)+1)
77 . K DA,DR S DA=PRCRFQDA,DIE=444,DR="7////5" D ^DIE K DIE,DR
78 . K PRCAR S PRCAR(1)="The Status of RFQ #"_$P(^PRC(444,PRCRFQDA,0),U)_" has been changed from"
79 . S PRCAR(2)=PRCOSTAT_" to AWARDED."
80 . D EN^DDIOL(.PRCAR) K PRCAR
81EX K DA,DIE,DR,PRCAR,PRC2237,PRCAWARD,PRCFOB,PRCI,PRCITM,PRCK,PRCLN,PRCOSTAT
82 K PRCQDA,PRCRFQPO,PRCSKIP,PRCV,PRCVEN,PRCX
83 Q
Note: See TracBrowser for help on using the repository browser.