PRCHQ13 ;(WASH IRMFO)/LKG-RFQ Award ;10/7/96 12:24
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN 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
G OUT:+Y<1!$D(DTOUT)!$D(DUOUT)
S PRCDA=+Y
L +^PRC(444,PRCDA):5 E W !,"RFQ #"_$P(Y,U,2)_" is being edited by another user, please try later" G OUT
S DDSFILE=444,DR="[PRCHQ5]",DA=PRCDA,DDSPARM="C" D ^DDS
K DA,DDSFILE,DDSPARM,DIMSG,DR
I $G(DDSCHANG)=1 D
. S PRCI=0,PRCEVAL=1
. 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
. I PRCEVAL D
. . S DIE=444,DA=PRCDA,DR="7////4;25////^S X=DUZ" D ^DIE K DIE,DR,DA
. . N PRC S PRC(1)="The status of RFQ #"_$P(^PRC(444,PRCDA,0),U)_" has been changed"
. . S PRC(2)="from CLOSED to EVALUATION COMPLETE"
. . D EN^DDIOL(.PRC)
. K DIR S DIR(0)="YA",DIR("B")=$S(PRCEVAL:"YES",1:"NO")
. S DIR("A")="Do you wish to now award items assigned to vendors? "
. S DIR("?",1)="Enter 'YES' to create 2237(s) and PO(s) for items"
. S DIR("?")="already assigned but not awarded"
. D ^DIR K DIR Q:Y'=1
. D AWARD^PRCHQ13A(PRCDA)
L -^PRC(444,PRCDA) K DDSCHANG
I '$D(DTOUT),'$D(DUOUT),'$D(DIRUT),'$D(DIROUT) G EN
OUT K PRCDA,DTOUT,DUOUT,PRCMSG,DA,X,Y,PRCI,PRCEVAL,DIRUT,DIROUT
Q
BLDAR(PRCDA) ;Build array of Quoting Vendors for each RFQ Line Item
N PRCDA1,PRCDA2,PRCLN,PRCVEN,PRCRDT
K ^TMP($J,"VB"),^TMP($J,"VC")
S PRCDA1=0
F S PRCDA1=$O(^PRC(444,PRCDA,8,PRCDA1)) Q:+PRCDA1'=PRCDA1 D
. Q:'$D(^PRC(444,PRCDA,8,PRCDA1,0)) S PRCVEN=$P(^(0),U),PRCRDT=$P(^(0),U,4)
. 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:"")
. S PRCDA2=0
. F S PRCDA2=$O(^PRC(444,PRCDA,8,PRCDA1,3,PRCDA2)) Q:+PRCDA2'=PRCDA2 D
. . Q:'$D(^PRC(444,PRCDA,8,PRCDA1,3,PRCDA2,0)) S PRCLN=$P(^(0),U)
. . S ^TMP($J,"VB",PRCLN,PRCDA1)=PRCDA2_"^"_PRCVEN
. . 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
Q
HLP(PRCLN) ;Executable help
S ^TMP($J,"VC",PRCLN,.1)="Enter the index value for the selected quote."
S ^TMP($J,"VC",PRCLN,.2)="The quotes which included RFQ Line Item #"_PRCLN_" are:"
S ^TMP($J,"VC",PRCLN,.3)=" "
D EN^DDIOL("","^TMP($J,""VC"",PRCLN)")
Q
INVALID(PRCLN,PRCX) ;When passed RFQ Line # (in PRCLN), check if Quote #
;;(passed in PRCX) is valid
N PRCY S PRCY=0
S:$D(^TMP($J,"VB",PRCLN,PRCX))#10'=1 PRCY=1
Q PRCY
QUOTECHK ;Reject selection if quote did not include the item
N PRCZ S PRCZ=$P(^PRC(444,D0,2,D1,0),U)
I $$INVALID(PRCZ,X) D EN^DDIOL("Selected quote did NOT include this item.") K X
Q
EXHLP ;setup for executable help
N PRCZ S PRCZ=$P(^PRC(444,D0,2,D1,0),U)
D HLP(PRCZ)
Q
PUT ;Stuff selected vendor and quote information on item
N PRCDA1,PRCDA2,PRCLN,PRCVEN,PRCX
I $G(X)="" D Q
. F PRCX=17,23.5,18,19 D PUT^DDSVAL(444.019,.DA,PRCX,"@","","E")
S PRCDA1=X
S PRCLN=$$GET^DDSVAL(444.019,.DA,.01)
Q:'$D(^TMP($J,"VB",PRCLN,PRCDA1)) S PRCDA2=^(PRCDA1)
S PRCVEN=$P(PRCDA2,"^",2),PRCDA2=$P(PRCDA2,"^")
D PUT^DDSVAL(444.019,.DA,17,PRCVEN,"","I")
D PUT^DDSVAL(444.019,.DA,23.5,PRCDA2,"","I")
S PRCX=$P($G(^PRC(444,PRCDA,8,PRCDA1,3,PRCDA2,0)),U,3)
I PRCX]"" D PUT^DDSVAL(444.019,.DA,18,PRCX,"","I")
S PRCX=$P($G(^PRC(444,PRCDA,8,PRCDA1,3,PRCDA2,1)),U,3)
I PRCX]"" D PUT^DDSVAL(444.019,.DA,19,PRCX,"","I")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQ13 3605 printed Apr 09, 2024@21:00:29 Page 2
PRCHQ13 ;(WASH IRMFO)/LKG-RFQ Award ;10/7/96 12:24
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN KILL DIC
SET DIC=444
SET DIC(0)="AEMQ"
SET DIC("S")="I $P(^(0),U,8)=3,$P($G(^(8,0)),U,4)>0"
DO ^DIC
KILL DIC
+1 if +Y<1!$DATA(DTOUT)!$DATA(DUOUT)
GOTO OUT
+2 SET PRCDA=+Y
+3 LOCK +^PRC(444,PRCDA):5
IF '$TEST
WRITE !,"RFQ #"_$PIECE(Y,U,2)_" is being edited by another user, please try later"
GOTO OUT
+4 SET DDSFILE=444
SET DR="[PRCHQ5]"
SET DA=PRCDA
SET DDSPARM="C"
DO ^DDS
+5 KILL DA,DDSFILE,DDSPARM,DIMSG,DR
+6 IF $GET(DDSCHANG)=1
Begin DoDot:1
+7 SET PRCI=0
SET PRCEVAL=1
+8 FOR
SET PRCI=$ORDER(^PRC(444,PRCDA,2,PRCI))
if +PRCI'=PRCI
QUIT
IF $PIECE($GET(^PRC(444,PRCDA,2,PRCI,3)),U,8)=""
SET PRCEVAL=0
QUIT
+9 IF PRCEVAL
Begin DoDot:2
+10 SET DIE=444
SET DA=PRCDA
SET DR="7////4;25////^S X=DUZ"
DO ^DIE
KILL DIE,DR,DA
+11 NEW PRC
SET PRC(1)="The status of RFQ #"_$PIECE(^PRC(444,PRCDA,0),U)_" has been changed"
+12 SET PRC(2)="from CLOSED to EVALUATION COMPLETE"
+13 DO EN^DDIOL(.PRC)
End DoDot:2
+14 KILL DIR
SET DIR(0)="YA"
SET DIR("B")=$SELECT(PRCEVAL:"YES",1:"NO")
+15 SET DIR("A")="Do you wish to now award items assigned to vendors? "
+16 SET DIR("?",1)="Enter 'YES' to create 2237(s) and PO(s) for items"
+17 SET DIR("?")="already assigned but not awarded"
+18 DO ^DIR
KILL DIR
if Y'=1
QUIT
+19 DO AWARD^PRCHQ13A(PRCDA)
End DoDot:1
+20 LOCK -^PRC(444,PRCDA)
KILL DDSCHANG
+21 IF '$DATA(DTOUT)
IF '$DATA(DUOUT)
IF '$DATA(DIRUT)
IF '$DATA(DIROUT)
GOTO EN
OUT KILL PRCDA,DTOUT,DUOUT,PRCMSG,DA,X,Y,PRCI,PRCEVAL,DIRUT,DIROUT
+1 QUIT
BLDAR(PRCDA) ;Build array of Quoting Vendors for each RFQ Line Item
+1 NEW PRCDA1,PRCDA2,PRCLN,PRCVEN,PRCRDT
+2 KILL ^TMP($JOB,"VB"),^TMP($JOB,"VC")
+3 SET PRCDA1=0
+4 FOR
SET PRCDA1=$ORDER(^PRC(444,PRCDA,8,PRCDA1))
if +PRCDA1'=PRCDA1
QUIT
Begin DoDot:1
+5 if '$DATA(^PRC(444,PRCDA,8,PRCDA1,0))
QUIT
SET PRCVEN=$PIECE(^(0),U)
SET PRCRDT=$PIECE(^(0),U,4)
+6 SET PRCRDT=+$EXTRACT(PRCRDT,4,5)_"/"_(+$EXTRACT(PRCRDT,6,7))_"/"_$EXTRACT(PRCRDT,2,3)_$SELECT($PIECE(PRCRDT,".",2)]"":"@"_$EXTRACT($PIECE(PRCRDT,".",2)_"000000",1,4),1:"")
+7 SET PRCDA2=0
+8 FOR
SET PRCDA2=$ORDER(^PRC(444,PRCDA,8,PRCDA1,3,PRCDA2))
if +PRCDA2'=PRCDA2
QUIT
Begin DoDot:2
+9 if '$DATA(^PRC(444,PRCDA,8,PRCDA1,3,PRCDA2,0))
QUIT
SET PRCLN=$PIECE(^(0),U)
+10 SET ^TMP($JOB,"VB",PRCLN,PRCDA1)=PRCDA2_"^"_PRCVEN
+11 SET ^TMP($JOB,"VC",PRCLN,PRCDA1)=PRCDA1_$EXTRACT(" ",$LENGTH(PRCDA1)+1,4)_$EXTRACT($PIECE(@("^"_$PIECE(PRCVEN,";",2)_...
... $PIECE(PRCVEN,";")_",0)"),U),1,25)_" Net Line Amt $"_$FNUMBER($PIECE($GET(^PRC(444,PRCDA,8,PRCDA1,3,PRCDA2,1)),U,7)+0,",",2)_" Rcvd: "_PRCRDT
End DoDot:2
End DoDot:1
+12 QUIT
HLP(PRCLN) ;Executable help
+1 SET ^TMP($JOB,"VC",PRCLN,.1)="Enter the index value for the selected quote."
+2 SET ^TMP($JOB,"VC",PRCLN,.2)="The quotes which included RFQ Line Item #"_PRCLN_" are:"
+3 SET ^TMP($JOB,"VC",PRCLN,.3)=" "
+4 DO EN^DDIOL("","^TMP($J,""VC"",PRCLN)")
+5 QUIT
INVALID(PRCLN,PRCX) ;When passed RFQ Line # (in PRCLN), check if Quote #
+1 ;;(passed in PRCX) is valid
+2 NEW PRCY
SET PRCY=0
+3 if $DATA(^TMP($JOB,"VB",PRCLN,PRCX))#10'=1
SET PRCY=1
+4 QUIT PRCY
QUOTECHK ;Reject selection if quote did not include the item
+1 NEW PRCZ
SET PRCZ=$PIECE(^PRC(444,D0,2,D1,0),U)
+2 IF $$INVALID(PRCZ,X)
DO EN^DDIOL("Selected quote did NOT include this item.")
KILL X
+3 QUIT
EXHLP ;setup for executable help
+1 NEW PRCZ
SET PRCZ=$PIECE(^PRC(444,D0,2,D1,0),U)
+2 DO HLP(PRCZ)
+3 QUIT
PUT ;Stuff selected vendor and quote information on item
+1 NEW PRCDA1,PRCDA2,PRCLN,PRCVEN,PRCX
+2 IF $GET(X)=""
Begin DoDot:1
+3 FOR PRCX=17,23.5,18,19
DO PUT^DDSVAL(444.019,.DA,PRCX,"@","","E")
End DoDot:1
QUIT
+4 SET PRCDA1=X
+5 SET PRCLN=$$GET^DDSVAL(444.019,.DA,.01)
+6 if '$DATA(^TMP($JOB,"VB",PRCLN,PRCDA1))
QUIT
SET PRCDA2=^(PRCDA1)
+7 SET PRCVEN=$PIECE(PRCDA2,"^",2)
SET PRCDA2=$PIECE(PRCDA2,"^")
+8 DO PUT^DDSVAL(444.019,.DA,17,PRCVEN,"","I")
+9 DO PUT^DDSVAL(444.019,.DA,23.5,PRCDA2,"","I")
+10 SET PRCX=$PIECE($GET(^PRC(444,PRCDA,8,PRCDA1,3,PRCDA2,0)),U,3)
+11 IF PRCX]""
DO PUT^DDSVAL(444.019,.DA,18,PRCX,"","I")
+12 SET PRCX=$PIECE($GET(^PRC(444,PRCDA,8,PRCDA1,3,PRCDA2,1)),U,3)
+13 IF PRCX]""
DO PUT^DDSVAL(444.019,.DA,19,PRCX,"","I")
+14 QUIT
