source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ13.m@ 1114

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

initial load of FOIAVistA 6/30/08 version
File size: 3.4 KB
Line 
1PRCHQ13 ;(WASH IRMFO)/LKG-RFQ Award ;10/7/96 12:24
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN K DIC S DIC=444,DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,8)=3,$P($G(^(8,0)),U,4)>0" D ^DIC K DIC
5 G OUT:+Y<1!$D(DTOUT)!$D(DUOUT)
6 S PRCDA=+Y
7 L +^PRC(444,PRCDA):5 E W !,"RFQ #"_$P(Y,U,2)_" is being edited by another user, please try later" G OUT
8 S DDSFILE=444,DR="[PRCHQ5]",DA=PRCDA,DDSPARM="C" D ^DDS
9 K DA,DDSFILE,DDSPARM,DIMSG,DR
10 I $G(DDSCHANG)=1 D
11 . S PRCI=0,PRCEVAL=1
12 . F S PRCI=$O(^PRC(444,PRCDA,2,PRCI)) Q:+PRCI'=PRCI I $P($G(^PRC(444,PRCDA,2,PRCI,3)),U,8)="" S PRCEVAL=0 Q
13 . I PRCEVAL D
14 . . S DIE=444,DA=PRCDA,DR="7////4;25////^S X=DUZ" D ^DIE K DIE,DR,DA
15 . . N PRC S PRC(1)="The status of RFQ #"_$P(^PRC(444,PRCDA,0),U)_" has been changed"
16 . . S PRC(2)="from CLOSED to EVALUATION COMPLETE"
17 . . D EN^DDIOL(.PRC)
18 . K DIR S DIR(0)="YA",DIR("B")=$S(PRCEVAL:"YES",1:"NO")
19 . S DIR("A")="Do you wish to now award items assigned to vendors? "
20 . S DIR("?",1)="Enter 'YES' to create 2237(s) and PO(s) for items"
21 . S DIR("?")="already assigned but not awarded"
22 . D ^DIR K DIR Q:Y'=1
23 . D AWARD^PRCHQ13A(PRCDA)
24 L -^PRC(444,PRCDA) K DDSCHANG
25 I '$D(DTOUT),'$D(DUOUT),'$D(DIRUT),'$D(DIROUT) G EN
26OUT K PRCDA,DTOUT,DUOUT,PRCMSG,DA,X,Y,PRCI,PRCEVAL,DIRUT,DIROUT
27 Q
28BLDAR(PRCDA) ;Build array of Quoting Vendors for each RFQ Line Item
29 N PRCDA1,PRCDA2,PRCLN,PRCVEN,PRCRDT
30 K ^TMP($J,"VB"),^TMP($J,"VC")
31 S PRCDA1=0
32 F S PRCDA1=$O(^PRC(444,PRCDA,8,PRCDA1)) Q:+PRCDA1'=PRCDA1 D
33 . Q:'$D(^PRC(444,PRCDA,8,PRCDA1,0)) S PRCVEN=$P(^(0),U),PRCRDT=$P(^(0),U,4)
34 . S PRCRDT=+$E(PRCRDT,4,5)_"/"_(+$E(PRCRDT,6,7))_"/"_$E(PRCRDT,2,3)_$S($P(PRCRDT,".",2)]"":"@"_$E($P(PRCRDT,".",2)_"000000",1,4),1:"")
35 . S PRCDA2=0
36 . F S PRCDA2=$O(^PRC(444,PRCDA,8,PRCDA1,3,PRCDA2)) Q:+PRCDA2'=PRCDA2 D
37 . . Q:'$D(^PRC(444,PRCDA,8,PRCDA1,3,PRCDA2,0)) S PRCLN=$P(^(0),U)
38 . . S ^TMP($J,"VB",PRCLN,PRCDA1)=PRCDA2_"^"_PRCVEN
39 . . S ^TMP($J,"VC",PRCLN,PRCDA1)=PRCDA1_$E(" ",$L(PRCDA1)+1,4)_$E($P(@("^"_$P(PRCVEN,";",2)_$P(PRCVEN,";")_",0)"),U),1,25)_" Net Line Amt $"_$FN($P($G(^PRC(444,PRCDA,8,PRCDA1,3,PRCDA2,1)),U,7)+0,",",2)_" Rcvd: "_PRCRDT
40 Q
41HLP(PRCLN) ;Executable help
42 S ^TMP($J,"VC",PRCLN,.1)="Enter the index value for the selected quote."
43 S ^TMP($J,"VC",PRCLN,.2)="The quotes which included RFQ Line Item #"_PRCLN_" are:"
44 S ^TMP($J,"VC",PRCLN,.3)=" "
45 D EN^DDIOL("","^TMP($J,""VC"",PRCLN)")
46 Q
47INVALID(PRCLN,PRCX) ;When passed RFQ Line # (in PRCLN), check if Quote #
48 ;;(passed in PRCX) is valid
49 N PRCY S PRCY=0
50 S:$D(^TMP($J,"VB",PRCLN,PRCX))#10'=1 PRCY=1
51 Q PRCY
52QUOTECHK ;Reject selection if quote did not include the item
53 N PRCZ S PRCZ=$P(^PRC(444,D0,2,D1,0),U)
54 I $$INVALID(PRCZ,X) D EN^DDIOL("Selected quote did NOT include this item.") K X
55 Q
56EXHLP ;setup for executable help
57 N PRCZ S PRCZ=$P(^PRC(444,D0,2,D1,0),U)
58 D HLP(PRCZ)
59 Q
60PUT ;Stuff selected vendor and quote information on item
61 N PRCDA1,PRCDA2,PRCLN,PRCVEN,PRCX
62 I $G(X)="" D Q
63 . F PRCX=17,23.5,18,19 D PUT^DDSVAL(444.019,.DA,PRCX,"@","","E")
64 S PRCDA1=X
65 S PRCLN=$$GET^DDSVAL(444.019,.DA,.01)
66 Q:'$D(^TMP($J,"VB",PRCLN,PRCDA1)) S PRCDA2=^(PRCDA1)
67 S PRCVEN=$P(PRCDA2,"^",2),PRCDA2=$P(PRCDA2,"^")
68 D PUT^DDSVAL(444.019,.DA,17,PRCVEN,"","I")
69 D PUT^DDSVAL(444.019,.DA,23.5,PRCDA2,"","I")
70 S PRCX=$P($G(^PRC(444,PRCDA,8,PRCDA1,3,PRCDA2,0)),U,3)
71 I PRCX]"" D PUT^DDSVAL(444.019,.DA,18,PRCX,"","I")
72 S PRCX=$P($G(^PRC(444,PRCDA,8,PRCDA1,3,PRCDA2,1)),U,3)
73 I PRCX]"" D PUT^DDSVAL(444.019,.DA,19,PRCX,"","I")
74 Q
Note: See TracBrowser for help on using the repository browser.