- 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 Apr 23, 2025@18:24:05 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
