source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ2B.m@ 1581

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

initial load of FOIAVistA 6/30/08 version
File size: 6.6 KB
Line 
1PRCHQ2B ;(WASH IRMFO)/LKG-RFQ Enter/Edit cont ;9/8/96 21:07
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 I $P(PRC410(3),U,4)]"" D
5 . S ^PRC(444,PRCDA,5,0)="^"_$P(^DD(444,20,0),U,2)_"^1^1"
6 . S ^PRC(444,PRCDA,5,1,0)=$P(PRC410(3),U,4)_";PRC(440,"
7 I $P(PRC410(3),U,4)="" D
8 . N DIC,DIE,DR,Y,DA
9 . S DIC=444.1,DIC(0)="XL",DLAYGO=444.1,X=$P(PRC410(2),U) D ^DIC K DLAYGO
10 . Q:+Y<1
11 . S ^PRC(444,PRCDA,5,0)="^"_$P(^DD(444,20,0),U,2)_"^1^1"
12 . S ^PRC(444,PRCDA,5,1,0)=+Y_";PRC(444.1,"
13 . I $P(Y,U,3) D
14 . . S DA=+Y,DIE=444.1 L +^PRC(444.1,DA):5 E W !,"Vendor ",$P(PRC410(2),U)," is being edited by another user." Q
15 . . S PRCX=$P(PRC410(2),U,2) I PRCX]"" S DR="1///^S X=PRCX" D ^DIE
16 . . S PRCX=$P(PRC410(2),U,3) I PRCX]"" S DR="2///^S X=PRCX" D ^DIE
17 . . S PRCX=$P(PRC410(2),U,4) I PRCX]"" S DR="3///^S X=PRCX" D ^DIE
18 . . S PRCX=$P(PRC410(2),U,5) I PRCX]"" S DR="4///^S X=PRCX" D ^DIE
19 . . S PRCX=$P(PRC410(2),U,6) I PRCX]"" S DR="4.2///^S X=PRCX" D ^DIE
20 . . S PRCX=$P(PRC410(2),U,7) I PRCX]"" S DR="4.4////^S X=PRCX" D ^DIE
21 . . S PRCX=$P(PRC410(2),U,8) I PRCX]"" S DR="4.6///^S X=PRCX" D ^DIE
22 . . S PRCX=$P(PRC410(2),U,9) I PRCX]"" S DR="4.8///^S X=PRCX" D ^DIE
23 . . S PRCX=$P(PRC410(2),U,10) I PRCX]"" S DR="5///^S X=PRCX" D ^DIE
24 . . L -^PRC(444.1,DA)
25 S DA=PRCDA410,DIE="^PRC(443,",DR="1.5////79" D ^DIE K DA,DIE,DR
26 L:$D(PRCDA410) -(^PRCS(410,PRCDA410),^PRC(443,PRCDA410))
27 K DA,I,PRCDA410,PRC410,PRC443,PRCE,PRCI,PRCJ,PRCK,PRCL,PRCM,PRCN,PRCP,PRCQ,PRCX,PRCY,X,Y
28 K DIR S DIR(0)="YA",DIR("A")="Do you wish to import items from an additional 2237? "
29 S DIR("B")="NO"
30 S DIR("?",1)="If you answer 'YES', you will be prompted for an Assigned to Purchasing Agent"
31 S DIR("?",2)="2237 with the same Fund Control Point."
32 S DIR("?")="All item information on that 2237 will be imported into this RFQ"
33 D ^DIR K DIR G INDX:$D(DIRUT),INDX:Y'=1
34 S PRCX=$P($P(^PRC(444,PRCDA,0),U,14)," ")
35LOOP K DIC S DIC="^PRC(443,",DIC(0)="AEMN"
36 S DIC("S")="I "";70;80;""[("";""_$P(^(0),U,7)_"";""),PRCX=$P($P($G(^PRCS(410,Y,0)),U),""-"",4),$P($G(^PRCS(410,Y,4)),U,5)="""""
37 S DIC("A")="Enter additional 2237 Transaction #: " D ^DIC K DIC
38 I Y<1!$D(DTOUT)!$D(DUOUT) G INDX
39 S PRCDA410=+Y
40 L +^PRC(443,PRCDA410):5 E W !,"Work Sheet entry in use, please try later!" G INDX
41 L +^PRCS(410,PRCDA410):5 E W !,"Someone is editing the source 2237, please try later!" G INDX
42 W !,"Importing item information into this RFQ entry..."
43 S PRC410(3)=$G(^PRCS(410,PRCDA410,3))
44 D IT^PRCHQ2A
45 S DA=PRCDA410,DIE="^PRC(443,",DR="1.5////79" D ^DIE K DA,DIE,DR
46 L -(^PRCS(410,PRCDA410),^PRC(443,PRCDA410))
47 K PRCDA410
48 G LOOP
49INDX ;Index the entry
50 K PRC410
51 D NOW^%DTC S $P(^PRC(444,PRCDA,1),U,9,10)=DUZ_U_% K %,%H,%I
52 W !,"Building the cross references..."
53 S DIK="^PRC(444,",DA=PRCDA D IX1^DIK K DA,DIK
54 G:$D(DUOUT)!$D(DIRUT)!$D(DTOUT) OUT
55CONT D EDIT L -^PRC(444,PRCDA)
56 I '$D(DTOUT)&'$D(DUOUT)&'$D(DIRUT)&'$D(DIROUT) G B^PRCHQ2:$G(PRCNEW),A^PRCHQ2
57OUT ;
58 L:$D(PRCDA410) -(^PRCS(410,PRCDA410),^PRC(443,PRCDA410))
59 L:$D(PRCDA) -^PRC(444,PRCDA)
60 K DA,DIC,DIRUT,DIROUT,DTOUT,DUOUT,PRCDA,PRCDA410,PRCOUT,PRCX,X,Y,PRCNEW,PRCEDIT
61 Q
62EDIT ;Edit RFQ
63 N %,%H,%I
64 I PRCEDIT="s" D
65 . K DA S DDSPARM="CS"
66 . S DDSFILE=444,DR="[PRCHQ1]",DA=PRCDA,DDSPAGE=1 D ^DDS
67 . K DA,DDSFILE,DR,DDSPAGE,DDSPARM,DIMSG,PRCMSG,%
68 I PRCEDIT="i" D
69 . N PRCMSG,PRCI,PRCX,PRCRD,PRCRQD,PRCDA2,PRCITMO,PRCIEN,PRCVEN
70 . S PRCMSG="" D ESIG^PRCUESIG(DUZ,.PRCMSG)
71 . I PRCMSG'=1 D EN^DDIOL("Electronic Signature Failed, Edit aborted") S PRCERR=10 Q
72 . K DA S DIE="^PRC(444,",DA=PRCDA,DR="[PRCHQ RFQ REQUEST]" D ^DIE K DIE,DR
73 . D NOW^%DTC S $P(^PRC(444,PRCDA,1),U,9,10)=DUZ_U_%
74 . I $D(DTOUT) S PRCERR=10 Q
75 . I $D(DUOUT) K DIR S DIR(0)="YA",DIR("A")="Do you wish to continue? ",DIR("B")="NO" D ^DIR K DIR I Y'=1 S PRCERR=10 Q
76 . K DUOUT
77 . S PRCI=0
78 . F S PRCI=$O(^PRC(444,PRCDA,5,PRCI)) Q:+PRCI'=PRCI D Q:$G(PRCERR)
79 . . S PRCX=$G(^PRC(444,PRCDA,5,PRCI,0)) Q:$P(PRCX,U)'["PRC(444.1,"
80 . . W !!,"Editing Solicited Vendor in RFQ Temporary Vendor File..."
81 . . L +^PRC(444.1,+PRCX):3 E S X="Vendor "_$P($G(^PRC(444.1,+PRCX,0)),U)_" is locked, please try later!" D EN^DDIOL(X) Q
82 . . K DA S DA=+PRCX,DIE="^PRC(444.1,",DR=".01;18.3;38;4.8;5;46;1R;2;3;4;4.2R;4.4R;4.6"
83 . . D ^DIE K DIE,DR,DA L -^PRC(444.1,+PRCX)
84 . . I $D(DTOUT) S PRCERR=10 Q
85 . . I $D(DUOUT) K DIR S DIR(0)="YA",DIR("A")="Do you wish to continue? ",DIR("B")="NO" D ^DIR K DIR I Y'=1 S PRCERR=10 Q
86 . . K DUOUT
87 . K DIR S DIR(0)="YA",DIR("A")="Do you wish to view the RFQ? "
88 . S DIR("B")="YES" D ^DIR K DIR I $D(DIROUT)!$D(DIRUT) S PRCERR=10 Q
89 . I Y=1 D
90 . . S PRCRFQ=$P($G(^PRC(444,PRCDA,0)),U)
91 . . S DIC=444,BY=.01,FLDS="[PRCHQ RFQ FULL]",L=0,(FR,TO)=PRCRFQ,DHD="@"
92 . . D EN1^DIP K BY,DIC,DHD,FLDS,FR,L,TO
93 I $G(DDSCHANG)=1!($G(DDSSAVE)=1)!(PRCEDIT="i"&'$G(PRCERR)) D
94 . N PRCRFQ,PRCTYPE,PRCNOPRT S PRCRFQ=$P(^PRC(444,PRCDA,0),U)
95 . K DIR S DIR(0)="YA",DIR("A")="Do you wish to transmit this RFQ to vendors? "
96 . S DIR("B")="YES",DIR("?")="Accept default of 'YES' to transmit, enter 'NO' to avoid transmitting."
97 . D ^DIR K DIR Q:Y'=1!$D(DIRUT)!$D(DIROUT)!$D(DTOUT)!$D(DUOUT)
98 . I $P($G(^PRC(444,PRCDA,1)),U,8)'="y",$P($G(^PRC(444,PRCDA,5,0)),U,4)'>0 D EN^DDIOL("Warning - Transmit aborted as there are NO RECIPIENTS!") Q
99 . S PRCTYPE="00"
100 . K PRCERR
101 . D TRANS840^PRCHQ4A(PRCTYPE)
102 . I $G(PRCERR) D EN^DDIOL("Due to Error Conditions Transmission Was Aborted!") Q
103 . S PRCNOPRT=$$MANUAL
104 . I $P($G(^PRC(444,PRCDA,1)),U,11)=""&PRCNOPRT D EN^DDIOL("RFQ has not been transmitted, use option Edit Incomplete RFQ to complete.") Q
105 . D:PRCNOPRT EN^DDIOL("Required manual RFQs were not printed, use option Manual Print of RFQ.")
106 . I $P($G(^PRC(444,PRCDA,1)),U,11)]""!('PRCNOPRT) D
107 . . N PRCAR,PRCSTAT,PRCSTRG
108 . . S PRCSTRG="CANCELLED^INCOMPLETE^PENDING QUOTES^CLOSED^EVALUATION COMPLETE^AWARDED",PRCSTAT=$P(PRCSTRG,U,$P(^PRC(444,PRCDA,0),U,8)+1)
109 . . K DA S DA=PRCDA,DR="7////2",DIE="^PRC(444," D ^DIE K DA,DIE,DR
110 . . S PRCAR(1)="The status of RFQ #: "_PRCRFQ_" has been changed from"
111 . . S PRCAR(2)=" '"_PRCSTAT_"' to '"_$P(PRCSTRG,U,$P($G(^PRC(444,PRCDA,0)),U,8)+1)_"'."
112 . . D EN^DDIOL(.PRCAR)
113 K DDSCHANG,DDSSAVE,PRCERR
114 Q
115MANUAL() ;Print Manual RFQ
116 N X,Y,POP,%,%H,%I,DA
117 S X=0,Y=0
118 F S X=$O(^PRC(444,PRCDA,5,X)) Q:+X'=X I $P($G(^PRC(444,PRCDA,5,X,0)),U,2)="m" S Y=1 Q
119 I 'Y D EN^DDIOL("There are no vendors for Manual Solicitation") Q 0
120MANA K %ZIS S %ZIS("A")="90 Column Printer for Manual RFQ: "
121 S %ZIS("B")="",%ZIS="PQ" D ^%ZIS I POP Q 1
122 I $E(IOST)'="P"!(IOM'>89) D ^%ZISC,EN^DDIOL("Device must be a printer supporting 90 characters per line.") G MANA
123 I $D(IO("Q")) S ZTRTN="PROCESS^PRCHQM1",ZTSAVE("DA")=PRCDA D ^%ZTLOAD,HOME^%ZIS G:$G(ZTSK)>0 XMANUAL Q 1
124 S DA=PRCDA D PROCESS^PRCHQM1
125XMANUAL ;
126 Q 0
Note: See TracBrowser for help on using the repository browser.