PRCHQ13A ;(WASH IRMFO)/LKG-RFQ Award ;8/6/96 20:46
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;Entry point for awarding evaluation complete RFQs
K DIC S DIC="^PRC(444,",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,8)=4"
S DIC("A")="Select RFQ to Award: " D ^DIC K DIC
G EX1:+Y<1!$D(DTOUT)!$D(DUOUT)
S PRCDA=+Y,PRCRFQ=$P(Y,U,2)
L +^PRC(444,PRCDA):5 E W !,"This RFQ entry is in use, please try later!" G EN
K DIR S DIR(0)="YA",DIR("A")="Do you wish to review this RFQ? "
S DIR("B")="YES",DIR("?")="Answer 'YES' if you wish to view the RFQ before proceeding with the award."
D ^DIR K DIR
I Y=1 D G:Y'=1 A
. N L,DIC,DR,FLDS,BY,FR,TO,IOP S DIC=444,BY=.01,(FR,TO)=PRCRFQ,L=0,IOP="HOME"
. S FLDS="[PRCHQ RFQ FULL]" D EN1^DIP K DIC,FLDS,BY,FR,DR,L
. S DIR(0)="YA",DIR("A")="Is this the correct RFQ? ",DIR("B")="NO"
. S DIR("?")="Answer 'NO' to abort the Award."
. D ^DIR K DIR
S PRCMSG="" D ESIG^PRCUESIG(DUZ,.PRCMSG) G:PRCMSG'=1 EX1
D AWARD(PRCDA)
A L -^PRC(444,PRCDA)
G EN:'$D(DIRUT)&'$D(DIROUT)
EX1 L:$D(PRCDA) -^PRC(444,PRCDA)
K DIC,DTOUT,DUOUT,DIRUT,DIROUT,PRCDA,PRCRFQ,X,Y,PRCMSG
Q
;;Driver for calls to set up 2237 and PO documents
AWARD(PRCRFQDA) ;Entry point for creating 2237 and PO documents
N PRCQDA,PRCNLNK S PRCQDA=0 K ^TMP($J,"RFQ")
F S PRCQDA=$O(^PRC(444,PRCRFQDA,2,"AJ",PRCQDA)) Q:+PRCQDA'=PRCQDA D
. N PRCAR,PRCX
. S PRCV=$P($G(^PRC(444,PRCRFQDA,8,PRCQDA,0)),U)
. 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
. I PRCV["PRC(444.1",$P($G(^PRC(444.1,+PRCV,0)),U,9)="" D Q:PRCNLNK
. . K PRCAR S PRCX=^PRC(444.1,+PRCV,0),PRCNLNK=0
. . S PRCAR(1)="Vendor "_$P(PRCX,U)_" Dun # "_$P(PRCX,U,2)_" must be linked to an"
. . S PRCAR(2)="existing File #440 entry before he can receive awards."
. . D EN^DDIOL(.PRCAR) K PRCAR
. . K DIR S DIR(0)="YA",DIR("A")="Do you wish to link the vendor at this time? "
. . S DIR("B")="YES",DIR("?")="Answer 'YES' to continue or 'NO' to bypass this vendor"
. . D ^DIR K DIR
. . I Y'=1 D EN^DDIOL("Bypassing this vendor") S PRCNLNK=1 Q
. . S DA=+PRCV,DIE=444.1,DR=60 D ^DIE K DIE,DR,DA
. . I $P(^PRC(444.1,+PRCV,0),U,9)="" D EN^DDIOL("Bypassing this vendor") S PRCNLNK=1 Q
. S PRCI=0
. F S PRCI=$O(^PRC(444,PRCRFQDA,2,"AJ",PRCQDA,PRCI)) Q:+PRCI'=PRCI D
. . S PRCLN=$P($G(^PRC(444,PRCRFQDA,2,PRCI,0)),U) Q:PRCLN=""
. . Q:$P($G(^PRC(444,PRCRFQDA,2,PRCI,3)),U,6)]""
. . S PRCITM=$P(^PRC(444,PRCRFQDA,2,PRCI,0),U,4)
. . I PRCITM]"" D Q:$G(PRCSKIP)
. . . S PRCSKIP=0
. . . S PRCVEN=$S(PRCV["PRC(444.1":$P(^PRC(444.1,+PRCV,0),U,9),1:+PRCV)
. . . I '$D(^PRC(441,PRCITM,2,PRCVEN)) D
. . . . K PRCAR
. . . . S PRCAR(1)="Vendor "_$P($G(^PRC(440,PRCVEN,0)),U)_" Dun # "_$P($G(^PRC(440,PRCVEN,7)),U,12)_" must be associated"
. . . . S PRCAR(2)="with ITEM MASTER File entry #"_PRCITM_" before he can be awarded this"
. . . . S PRCAR(3)="item."
. . . . D EN^DDIOL(.PRCAR) K PRCAR S PRCSKIP=1
. . S PRCK=$O(^PRC(444,PRCRFQDA,8,PRCQDA,3,"B",PRCLN,"")) Q:PRCK=""
. . S PRCFOB=$P($G(^PRC(444,PRCRFQDA,8,PRCQDA,3,PRCK,0)),U,10)
. . S:PRCFOB="" PRCFOB=$P($G(^PRC(444,PRCRFQDA,8,PRCQDA,1)),U)
. . S:PRCFOB="" PRCFOB=$P($G(^PRC(444,PRCRFQDA,1)),U)
. . S ^TMP($J,"RFQ",PRCRFQDA,PRCQDA,PRCFOB,PRCI)=""
S PRCQDA=0
F S PRCQDA=$O(^TMP($J,"RFQ",PRCRFQDA,PRCQDA)) Q:PRCQDA="" D
. S PRCFOB=""
. F S PRCFOB=$O(^TMP($J,"RFQ",PRCRFQDA,PRCQDA,PRCFOB)) Q:PRCFOB="" D
. . S PRC2237=$$REQUEST^PRCHQ410(PRCRFQDA,PRCQDA,"^TMP($J,""RFQ"",PRCRFQDA,PRCQDA,PRCFOB)")
. . I PRC2237>0 D
. . . K PRCAR S PRCAR="2237 #"_$P($G(^PRCS(410,PRC2237,0)),U)_" has been built for Quote #"_PRCQDA_"." D EN^DDIOL(PRCAR) K PRCAR
. . . S PRCRFQPO=$$POBLD^PRCHQ15(PRC2237,PRCRFQDA,PRCQDA,PRCFOB)
. . . I PRCRFQPO'="" K PRCAR S PRCAR="PO #"_PRCRFQPO_" has been built for Quote #"_PRCQDA_"." D EN^DDIOL(PRCAR) K PRCAR
S PRCI=0,PRCAWARD=1
F S PRCI=$O(^PRC(444,PRCRFQDA,2,PRCI)) Q:+PRCI'=PRCI D Q:'PRCAWARD
. I $P($G(^PRC(444,PRCRFQDA,2,PRCI,3)),U,6)="" S PRCAWARD=0
I PRCAWARD,$P(^PRC(444,PRCRFQDA,0),U,8)'=5 D
. S PRCOSTAT=$P("CANCELLED^INCOMPLETE^PENDING QUOTES^CLOSED^EVALUATION COMPLETE^AWARDED",U,$P(^PRC(444,PRCRFQDA,0),U,8)+1)
. K DA,DR S DA=PRCRFQDA,DIE=444,DR="7////5" D ^DIE K DIE,DR
. K PRCAR S PRCAR(1)="The Status of RFQ #"_$P(^PRC(444,PRCRFQDA,0),U)_" has been changed from"
. S PRCAR(2)=PRCOSTAT_" to AWARDED."
. D EN^DDIOL(.PRCAR) K PRCAR
EX K DA,DIE,DR,PRCAR,PRC2237,PRCAWARD,PRCFOB,PRCI,PRCITM,PRCK,PRCLN,PRCOSTAT
K PRCQDA,PRCRFQPO,PRCSKIP,PRCV,PRCVEN,PRCX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQ13A 4662 printed Dec 13, 2024@02:09:36 Page 2
PRCHQ13A ;(WASH IRMFO)/LKG-RFQ Award ;8/6/96 20:46
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;Entry point for awarding evaluation complete RFQs
+1 KILL DIC
SET DIC="^PRC(444,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $P(^(0),U,8)=4"
+2 SET DIC("A")="Select RFQ to Award: "
DO ^DIC
KILL DIC
+3 if +Y<1!$DATA(DTOUT)!$DATA(DUOUT)
GOTO EX1
+4 SET PRCDA=+Y
SET PRCRFQ=$PIECE(Y,U,2)
+5 LOCK +^PRC(444,PRCDA):5
IF '$TEST
WRITE !,"This RFQ entry is in use, please try later!"
GOTO EN
+6 KILL DIR
SET DIR(0)="YA"
SET DIR("A")="Do you wish to review this RFQ? "
+7 SET DIR("B")="YES"
SET DIR("?")="Answer 'YES' if you wish to view the RFQ before proceeding with the award."
+8 DO ^DIR
KILL DIR
+9 IF Y=1
Begin DoDot:1
+10 NEW L,DIC,DR,FLDS,BY,FR,TO,IOP
SET DIC=444
SET BY=.01
SET (FR,TO)=PRCRFQ
SET L=0
SET IOP="HOME"
+11 SET FLDS="[PRCHQ RFQ FULL]"
DO EN1^DIP
KILL DIC,FLDS,BY,FR,DR,L
+12 SET DIR(0)="YA"
SET DIR("A")="Is this the correct RFQ? "
SET DIR("B")="NO"
+13 SET DIR("?")="Answer 'NO' to abort the Award."
+14 DO ^DIR
KILL DIR
End DoDot:1
if Y'=1
GOTO A
+15 SET PRCMSG=""
DO ESIG^PRCUESIG(DUZ,.PRCMSG)
if PRCMSG'=1
GOTO EX1
+16 DO AWARD(PRCDA)
A LOCK -^PRC(444,PRCDA)
+1 if '$DATA(DIRUT)&'$DATA(DIROUT)
GOTO EN
EX1 if $DATA(PRCDA)
LOCK -^PRC(444,PRCDA)
+1 KILL DIC,DTOUT,DUOUT,DIRUT,DIROUT,PRCDA,PRCRFQ,X,Y,PRCMSG
+2 QUIT
+3 ;;Driver for calls to set up 2237 and PO documents
AWARD(PRCRFQDA) ;Entry point for creating 2237 and PO documents
+1 NEW PRCQDA,PRCNLNK
SET PRCQDA=0
KILL ^TMP($JOB,"RFQ")
+2 FOR
SET PRCQDA=$ORDER(^PRC(444,PRCRFQDA,2,"AJ",PRCQDA))
if +PRCQDA'=PRCQDA
QUIT
Begin DoDot:1
+3 NEW PRCAR,PRCX
+4 SET PRCV=$PIECE($GET(^PRC(444,PRCRFQDA,8,PRCQDA,0)),U)
+5 IF '$DATA(@("^"_$PIECE(PRCV,";",2)_(+PRCV)_",0)"))
SET PRCAR="Vendor submitting Quote #"_PRCQDA_" is not in the database!"
DO EN^DDIOL(PRCAR)
KILL PRCAR
QUIT
+6 IF PRCV["PRC(444.1"
IF $PIECE($GET(^PRC(444.1,+PRCV,0)),U,9)=""
Begin DoDot:2
+7 KILL PRCAR
SET PRCX=^PRC(444.1,+PRCV,0)
SET PRCNLNK=0
+8 SET PRCAR(1)="Vendor "_$PIECE(PRCX,U)_" Dun # "_$PIECE(PRCX,U,2)_" must be linked to an"
+9 SET PRCAR(2)="existing File #440 entry before he can receive awards."
+10 DO EN^DDIOL(.PRCAR)
KILL PRCAR
+11 KILL DIR
SET DIR(0)="YA"
SET DIR("A")="Do you wish to link the vendor at this time? "
+12 SET DIR("B")="YES"
SET DIR("?")="Answer 'YES' to continue or 'NO' to bypass this vendor"
+13 DO ^DIR
KILL DIR
+14 IF Y'=1
DO EN^DDIOL("Bypassing this vendor")
SET PRCNLNK=1
QUIT
+15 SET DA=+PRCV
SET DIE=444.1
SET DR=60
DO ^DIE
KILL DIE,DR,DA
+16 IF $PIECE(^PRC(444.1,+PRCV,0),U,9)=""
DO EN^DDIOL("Bypassing this vendor")
SET PRCNLNK=1
QUIT
End DoDot:2
if PRCNLNK
QUIT
+17 SET PRCI=0
+18 FOR
SET PRCI=$ORDER(^PRC(444,PRCRFQDA,2,"AJ",PRCQDA,PRCI))
if +PRCI'=PRCI
QUIT
Begin DoDot:2
+19 SET PRCLN=$PIECE($GET(^PRC(444,PRCRFQDA,2,PRCI,0)),U)
if PRCLN=""
QUIT
+20 if $PIECE($GET(^PRC(444,PRCRFQDA,2,PRCI,3)),U,6)]""
QUIT
+21 SET PRCITM=$PIECE(^PRC(444,PRCRFQDA,2,PRCI,0),U,4)
+22 IF PRCITM]""
Begin DoDot:3
+23 SET PRCSKIP=0
+24 SET PRCVEN=$SELECT(PRCV["PRC(444.1":$PIECE(^PRC(444.1,+PRCV,0),U,9),1:+PRCV)
+25 IF '$DATA(^PRC(441,PRCITM,2,PRCVEN))
Begin DoDot:4
+26 KILL PRCAR
+27 SET PRCAR(1)="Vendor "_$PIECE($GET(^PRC(440,PRCVEN,0)),U)_" Dun # "_$PIECE($GET(^PRC(440,PRCVEN,7)),U,12)_" must be associated"
+28 SET PRCAR(2)="with ITEM MASTER File entry #"_PRCITM_" before he can be awarded this"
+29 SET PRCAR(3)="item."
+30 DO EN^DDIOL(.PRCAR)
KILL PRCAR
SET PRCSKIP=1
End DoDot:4
End DoDot:3
if $GET(PRCSKIP)
QUIT
+31 SET PRCK=$ORDER(^PRC(444,PRCRFQDA,8,PRCQDA,3,"B",PRCLN,""))
if PRCK=""
QUIT
+32 SET PRCFOB=$PIECE($GET(^PRC(444,PRCRFQDA,8,PRCQDA,3,PRCK,0)),U,10)
+33 if PRCFOB=""
SET PRCFOB=$PIECE($GET(^PRC(444,PRCRFQDA,8,PRCQDA,1)),U)
+34 if PRCFOB=""
SET PRCFOB=$PIECE($GET(^PRC(444,PRCRFQDA,1)),U)
+35 SET ^TMP($JOB,"RFQ",PRCRFQDA,PRCQDA,PRCFOB,PRCI)=""
End DoDot:2
End DoDot:1
+36 SET PRCQDA=0
+37 FOR
SET PRCQDA=$ORDER(^TMP($JOB,"RFQ",PRCRFQDA,PRCQDA))
if PRCQDA=""
QUIT
Begin DoDot:1
+38 SET PRCFOB=""
+39 FOR
SET PRCFOB=$ORDER(^TMP($JOB,"RFQ",PRCRFQDA,PRCQDA,PRCFOB))
if PRCFOB=""
QUIT
Begin DoDot:2
+40 SET PRC2237=$$REQUEST^PRCHQ410(PRCRFQDA,PRCQDA,"^TMP($J,""RFQ"",PRCRFQDA,PRCQDA,PRCFOB)")
+41 IF PRC2237>0
Begin DoDot:3
+42 KILL PRCAR
SET PRCAR="2237 #"_$PIECE($GET(^PRCS(410,PRC2237,0)),U)_" has been built for Quote #"_PRCQDA_"."
DO EN^DDIOL(PRCAR)
KILL PRCAR
+43 SET PRCRFQPO=$$POBLD^PRCHQ15(PRC2237,PRCRFQDA,PRCQDA,PRCFOB)
+44 IF PRCRFQPO'=""
KILL PRCAR
SET PRCAR="PO #"_PRCRFQPO_" has been built for Quote #"_PRCQDA_"."
DO EN^DDIOL(PRCAR)
KILL PRCAR
End DoDot:3
End DoDot:2
End DoDot:1
+45 SET PRCI=0
SET PRCAWARD=1
+46 FOR
SET PRCI=$ORDER(^PRC(444,PRCRFQDA,2,PRCI))
if +PRCI'=PRCI
QUIT
Begin DoDot:1
+47 IF $PIECE($GET(^PRC(444,PRCRFQDA,2,PRCI,3)),U,6)=""
SET PRCAWARD=0
End DoDot:1
if 'PRCAWARD
QUIT
+48 IF PRCAWARD
IF $PIECE(^PRC(444,PRCRFQDA,0),U,8)'=5
Begin DoDot:1
+49 SET PRCOSTAT=$PIECE("CANCELLED^INCOMPLETE^PENDING QUOTES^CLOSED^EVALUATION COMPLETE^AWARDED",U,$PIECE(^PRC(444,PRCRFQDA,0),U,8)+1)
+50 KILL DA,DR
SET DA=PRCRFQDA
SET DIE=444
SET DR="7////5"
DO ^DIE
KILL DIE,DR
+51 KILL PRCAR
SET PRCAR(1)="The Status of RFQ #"_$PIECE(^PRC(444,PRCRFQDA,0),U)_" has been changed from"
+52 SET PRCAR(2)=PRCOSTAT_" to AWARDED."
+53 DO EN^DDIOL(.PRCAR)
KILL PRCAR
End DoDot:1
EX KILL DA,DIE,DR,PRCAR,PRC2237,PRCAWARD,PRCFOB,PRCI,PRCITM,PRCK,PRCLN,PRCOSTAT
+1 KILL PRCQDA,PRCRFQPO,PRCSKIP,PRCV,PRCVEN,PRCX
+2 QUIT
