PRCHQRP4 ;WISC/KMB-DISPLAY ABS/AGGREGATE QUOTE ;8/6/96 21:05
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
START ;Entry point for aggregate report
W @IOF S DIC="^PRC(444,",DIC("S")="I $P(^(0),""^"",8)>1"
S DIC(0)="AEMQZ" D ^DIC K DIC I Y<0 K DTOUT,DUOUT,PRCDA,Y Q
S PRCDA=+Y
;
W ! S %ZIS="MQ" D ^%ZIS I POP K PRCDA,Y Q
I $D(IO("Q")) S ZTRTN="PROCESS^PRCHQRP4",ZTSAVE("DUZ")="",ZTSAVE("PRCDA")="" D ^%ZTLOAD,^%ZISC K ZTSK G START
D PROCESS,^%ZISC K PRCDA,Y G START
PROCESS ;
N Q,Z1,ITEMNO,ID,I,J,K,L,VEN,ID,ITEMNO,P,STRING,VDUN,VNAME,VN,FOB,TOT,FILE
N ZIP1,ZIP2,ZIP3,ZIP4,ZIP5,VENDOR,FLAG,PRCFLG,X,Y K ^TMP($J)
S ZIP1=$P($G(^PRC(444,PRCDA,0)),"^"),ZIP2=$P($G(^(0)),"^",3),ZIP3=$P($G(^(8,0)),"^",4)
S ZIP5=$P($G(^PRC(444,PRCDA,0)),"^",12) S:ZIP5'="" ZIP5=$P($G(^VA(200,ZIP5,0)),"^")
S ZIP4=$P($G(^PRC(444,PRCDA,2,0)),"^",4)
S Y=ZIP2 D DD^%DT S ZIP2=Y
D VENDOR,RFQLOAD^PRCHQRP3,DETAIL,WRITE
K PRCDA,^TMP($J) S:$D(ZTQUEUED) ZTREQ="@"
QUIT
WRITE ;
U IO S (P,Z1)=1 D HDR
I '$D(STRING) W !,"No dollar totals were entered for vendor quotes",!
S Q=""
F S Q=$O(STRING(Q)) Q:Q="" D Q:Z1[U
. S J=""
. F S J=$O(STRING(Q,J)) Q:J="" D Q:Z1[U
. . S K=""
. . F S K=$O(STRING(Q,J,K)) Q:K="" D Q:Z1[U
. . . I IOSL-$Y<6 D HDR Q:Z1[U
. . . W !,$P(STRING(Q,J,K),"^"),?20,$P(STRING(Q,J,K),"^",2),?25,$J($FN($P(STRING(Q,J,K),"^",3),"",2),10)
. . . W ?40,$P(STRING(Q,J,K),"^",4),?47,$P(STRING(Q,J,K),"^",5),?56,$P(STRING(Q,J,K),"^",6)
I Z1'[U,IOSL-$Y<14 R:$E(IOST,1,2)="C-"&'$D(ZTQUEUED) !,"Enter RETURN to continue or '^' to exit: ",Z1:DTIME W @IOF
D:Z1'[U LEGEND
I Z1'[U,$E(IOST,1,2)="C-",'$D(ZTQUEUED) R !,"Enter RETURN to continue ",Z1:DTIME
QUIT
HDR ;
I $E(IOST,1,2)="C-",P>1,'$D(ZTQUEUED) R !,"Enter RETURN to continue or '^' to exit: ",Z1:DTIME Q:Z1["^"
W @IOF
W !,"RFQ #",ZIP1,?70,"Page ",P,!,"Quotations Due Date: ",ZIP2,!,"Number of Quotes: ",ZIP3,!,"Number of Items on RFQ: ",ZIP4,!,"Point of Contact: ",ZIP5,!
W !,?20,"#Items",?30,"Total",?47,"Total"
W !,"Vendor",?20,"Quoted",?30,"Price",?40,"FOB",?47,"#Msgs.",?56,"Flags",!
F I=1:1:8 W "----------"
S P=P+1
QUIT
DETAIL ;
S I=0
F S I=$O(^PRC(444,PRCDA,8,I)) Q:+I'=I D
.S TOT=$P($G(^PRC(444,PRCDA,8,I,1)),"^",3) Q:+TOT=0
.S FOB=$P($G(^PRC(444,PRCDA,8,I,1)),"^")
.S J=0
.F S J=$O(^PRC(444,PRCDA,8,I,3,J)) Q:+J'=J D
. . S K=$G(^PRC(444,PRCDA,8,I,3,J,0)) Q:K=""
. . I $P(K,"^",10)]"",$P(K,"^",10)'=$P(FOB,"/") S $P(FOB,"/",FOB]""+1)=$P(K,"^",10)
.S VEN=$P($G(^PRC(444,PRCDA,8,I,0)),"^")
.S VN=$P(VEN,";"),FILE=$P(VEN,";",2),VNAME="^"_FILE_VN_",0)"
.S VDUN=0 S:FILE[440 VDUN=$P($G(^PRC(440,VN,7)),"^",12) S:FILE[444.1 VDUN=$P($G(^PRC(444.1,VN,0)),"^",2) S:VDUN="" VDUN=0
.S VNAME=$P($G(@VNAME),"^") Q:VNAME="" S VNAME=$E(VNAME,1,18)
.S ITEMNO=$P($G(^PRC(444,PRCDA,8,I,3,0)),"^",4)
.S STRING(TOT,VNAME,I)=VNAME_"^"_ITEMNO_"^"_TOT_"^"_FOB_"^"_$G(VENDOR(VDUN))
. K PRCFLG
. I FOB'=^TMP($J,"RFQ","FOB") S PRCFLG("FOB")=""
. I $P($G(^PRC(444,PRCDA,8,I,0)),"^",4)>^TMP($J,"RFQ","QUOTE DUE") S PRCFLG("RECVD DATE")=""
. I ^TMP($J,"RFQ","SET ASIDE") D
. . I FILE[440,$P($G(^PRC(440,VN,2)),"^",3)='1 S PRCFLG("SIZE")=""
. . I FILE[444.1,$P($G(^PRC(444.1,VN,0)),"^",5)'=1 S PRCFLG("SIZE")=""
. I $P($G(^PRC(444,PRCDA,8,I,3,0)),"^",4)'=^TMP($J,"RFQ","NBR ITEMS") S PRCFLG("NBR")=""
. I $P($G(^PRC(444,PRCDA,8,I,0)),"^",7)]"" S PRCFLG("CONTRACT")=""
. S J=0
. F S J=$O(^PRC(444,PRCDA,8,I,3,J)) Q:+J'=J D
. . S X=$G(^PRC(444,PRCDA,8,I,3,J,0)) Q:X=""
. . S L=$P(X,"^")
. . I $P(X,"^",2)'=$G(^TMP($J,"RFQ","ITEM",L,"QUANTITY")) S PRCFLG("QUANTITY")=""
. . S K=$S($P(X,"^",3)]"":$P($G(^PRCD(420.5,$P(X,"^",3),0)),"^",2),1:"")
. . I K'=$G(^TMP($J,"RFQ","ITEM",L,"UNIT")) S PRCFLG("UNIT")=""
. . I $P(X,"^",9)'=$G(^TMP($J,"RFQ","ITEM",L,"MFG PART")) S PRCFLG("MFG PART")=""
. . I $P($G(^PRC(444,PRCDA,8,I,3,J,1)),"^",6)]"" S PRCFLG("CONTRACT")=""
. . I $P(X,"^",4)]"" S PRCFLG("VENDOR PRODUCT #")=""
. . I $P(X,"^",8)'=$G(^TMP($J,"RFQ","ITEM",L,"NDC")) S PRCFLG("NDC")=""
. . I $P(X,"^",6)'=$G(^TMP($J,"RFQ","ITEM",L,"NSN")) S PRCFLG("NSN")=""
. S FLAG=""
. F J="FOB^F","QUANTITY^Q","UNIT^U","RECVD DATE^DT","SIZE^S","NBR^LI","CONTRACT^C","MFG PART^M","VENDOR PRODUCT #^V","NSN^NSN","NDC^NDC" I $D(PRCFLG($P(J,"^"))) S FLAG=FLAG_$S(FLAG]"":",",1:"")_$P(J,"^",2)
. S $P(STRING(TOT,VNAME,I),"^",6)=FLAG
QUIT
VENDOR ; determine 864 messages for each vendor
S J=0
F S J=$O(^PRC(444,PRCDA,7,J)) Q:+J'=J D
.S ID=$P($G(^PRC(444,PRCDA,7,J,0)),"^",3) Q:ID=""
.S:'$D(VENDOR(ID)) VENDOR(ID)=0 S VENDOR(ID)=VENDOR(ID)+1
QUIT
LEGEND ;Print Flags Legend at end of last page.
W !!,?5,"Flags Legend:"
W !,"F=FOB is Different from That Requested"
W !,"Q=Quantity Quoted is Different from RFQ"
W !,"U=Unit of Purchase is Different from RFQ"
W !,"DT=Quote Received at Station after Date/Time Set for Receipt of Quotes"
W !,"S=RFQ Set-Aside for Small Business But Size Status of Vendor is Large or Missing"
W !,"LI=Number of Line Items Quoted Differs from Number of RFQ Line Items"
W !,"C=Vendor Indicates Item(s) on Contract"
W !,"M=Quoted Mfg. Part Number is Different from that Requested"
W !,"V=Vendor has Quoted a Vendor Product Number"
W !,"NSN=National Stock Number Quoted is Different from that Requested"
W !,"NDC=National Drug Code is Different from that Requested"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQRP4 5445 printed Sep 23, 2025@19:46:06 Page 2
PRCHQRP4 ;WISC/KMB-DISPLAY ABS/AGGREGATE QUOTE ;8/6/96 21:05
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
START ;Entry point for aggregate report
+1 WRITE @IOF
SET DIC="^PRC(444,"
SET DIC("S")="I $P(^(0),""^"",8)>1"
+2 SET DIC(0)="AEMQZ"
DO ^DIC
KILL DIC
IF Y<0
KILL DTOUT,DUOUT,PRCDA,Y
QUIT
+3 SET PRCDA=+Y
+4 ;
+5 WRITE !
SET %ZIS="MQ"
DO ^%ZIS
IF POP
KILL PRCDA,Y
QUIT
+6 IF $DATA(IO("Q"))
SET ZTRTN="PROCESS^PRCHQRP4"
SET ZTSAVE("DUZ")=""
SET ZTSAVE("PRCDA")=""
DO ^%ZTLOAD
DO ^%ZISC
KILL ZTSK
GOTO START
+7 DO PROCESS
DO ^%ZISC
KILL PRCDA,Y
GOTO START
PROCESS ;
+1 NEW Q,Z1,ITEMNO,ID,I,J,K,L,VEN,ID,ITEMNO,P,STRING,VDUN,VNAME,VN,FOB,TOT,FILE
+2 NEW ZIP1,ZIP2,ZIP3,ZIP4,ZIP5,VENDOR,FLAG,PRCFLG,X,Y
KILL ^TMP($JOB)
+3 SET ZIP1=$PIECE($GET(^PRC(444,PRCDA,0)),"^")
SET ZIP2=$PIECE($GET(^(0)),"^",3)
SET ZIP3=$PIECE($GET(^(8,0)),"^",4)
+4 SET ZIP5=$PIECE($GET(^PRC(444,PRCDA,0)),"^",12)
if ZIP5'=""
SET ZIP5=$PIECE($GET(^VA(200,ZIP5,0)),"^")
+5 SET ZIP4=$PIECE($GET(^PRC(444,PRCDA,2,0)),"^",4)
+6 SET Y=ZIP2
DO DD^%DT
SET ZIP2=Y
+7 DO VENDOR
DO RFQLOAD^PRCHQRP3
DO DETAIL
DO WRITE
+8 KILL PRCDA,^TMP($JOB)
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+9 QUIT
WRITE ;
+1 USE IO
SET (P,Z1)=1
DO HDR
+2 IF '$DATA(STRING)
WRITE !,"No dollar totals were entered for vendor quotes",!
+3 SET Q=""
+4 FOR
SET Q=$ORDER(STRING(Q))
if Q=""
QUIT
Begin DoDot:1
+5 SET J=""
+6 FOR
SET J=$ORDER(STRING(Q,J))
if J=""
QUIT
Begin DoDot:2
+7 SET K=""
+8 FOR
SET K=$ORDER(STRING(Q,J,K))
if K=""
QUIT
Begin DoDot:3
+9 IF IOSL-$Y<6
DO HDR
if Z1[U
QUIT
+10 WRITE !,$PIECE(STRING(Q,J,K),"^"),?20,$PIECE(STRING(Q,J,K),"^",2),?25,$JUSTIFY($FNUMBER($PIECE(STRING(Q,J,K),"^",3),"",2),10)
+11 WRITE ?40,$PIECE(STRING(Q,J,K),"^",4),?47,$PIECE(STRING(Q,J,K),"^",5),?56,$PIECE(STRING(Q,J,K),"^",6)
End DoDot:3
if Z1[U
QUIT
End DoDot:2
if Z1[U
QUIT
End DoDot:1
if Z1[U
QUIT
+12 IF Z1'[U
IF IOSL-$Y<14
if $EXTRACT(IOST,1,2)="C-"&'$DATA(ZTQUEUED)
READ !,"Enter RETURN to continue or '^' to exit: ",Z1:DTIME
WRITE @IOF
+13 if Z1'[U
DO LEGEND
+14 IF Z1'[U
IF $EXTRACT(IOST,1,2)="C-"
IF '$DATA(ZTQUEUED)
READ !,"Enter RETURN to continue ",Z1:DTIME
+15 QUIT
HDR ;
+1 IF $EXTRACT(IOST,1,2)="C-"
IF P>1
IF '$DATA(ZTQUEUED)
READ !,"Enter RETURN to continue or '^' to exit: ",Z1:DTIME
if Z1["^"
QUIT
+2 WRITE @IOF
+3 WRITE !,"RFQ #",ZIP1,?70,"Page ",P,!,"Quotations Due Date: ",ZIP2,!,"Number of Quotes: ",ZIP3,!,"Number of Items on RFQ: ",ZIP4,!,"Point of Contact: ",ZIP5,!
+4 WRITE !,?20,"#Items",?30,"Total",?47,"Total"
+5 WRITE !,"Vendor",?20,"Quoted",?30,"Price",?40,"FOB",?47,"#Msgs.",?56,"Flags",!
+6 FOR I=1:1:8
WRITE "----------"
+7 SET P=P+1
+8 QUIT
DETAIL ;
+1 SET I=0
+2 FOR
SET I=$ORDER(^PRC(444,PRCDA,8,I))
if +I'=I
QUIT
Begin DoDot:1
+3 SET TOT=$PIECE($GET(^PRC(444,PRCDA,8,I,1)),"^",3)
if +TOT=0
QUIT
+4 SET FOB=$PIECE($GET(^PRC(444,PRCDA,8,I,1)),"^")
+5 SET J=0
+6 FOR
SET J=$ORDER(^PRC(444,PRCDA,8,I,3,J))
if +J'=J
QUIT
Begin DoDot:2
+7 SET K=$GET(^PRC(444,PRCDA,8,I,3,J,0))
if K=""
QUIT
+8 IF $PIECE(K,"^",10)]""
IF $PIECE(K,"^",10)'=$PIECE(FOB,"/")
SET $PIECE(FOB,"/",FOB]""+1)=$PIECE(K,"^",10)
End DoDot:2
+9 SET VEN=$PIECE($GET(^PRC(444,PRCDA,8,I,0)),"^")
+10 SET VN=$PIECE(VEN,";")
SET FILE=$PIECE(VEN,";",2)
SET VNAME="^"_FILE_VN_",0)"
+11 SET VDUN=0
if FILE[440
SET VDUN=$PIECE($GET(^PRC(440,VN,7)),"^",12)
if FILE[444.1
SET VDUN=$PIECE($GET(^PRC(444.1,VN,0)),"^",2)
if VDUN=""
SET VDUN=0
+12 SET VNAME=$PIECE($GET(@VNAME),"^")
if VNAME=""
QUIT
SET VNAME=$EXTRACT(VNAME,1,18)
+13 SET ITEMNO=$PIECE($GET(^PRC(444,PRCDA,8,I,3,0)),"^",4)
+14 SET STRING(TOT,VNAME,I)=VNAME_"^"_ITEMNO_"^"_TOT_"^"_FOB_"^"_$GET(VENDOR(VDUN))
+15 KILL PRCFLG
+16 IF FOB'=^TMP($JOB,"RFQ","FOB")
SET PRCFLG("FOB")=""
+17 IF $PIECE($GET(^PRC(444,PRCDA,8,I,0)),"^",4)>^TMP($JOB,"RFQ","QUOTE DUE")
SET PRCFLG("RECVD DATE")=""
+18 IF ^TMP($JOB,"RFQ","SET ASIDE")
Begin DoDot:2
+19 IF FILE[440
IF $PIECE($GET(^PRC(440,VN,2)),"^",3)='1
SET PRCFLG("SIZE")=""
+20 IF FILE[444.1
IF $PIECE($GET(^PRC(444.1,VN,0)),"^",5)'=1
SET PRCFLG("SIZE")=""
End DoDot:2
+21 IF $PIECE($GET(^PRC(444,PRCDA,8,I,3,0)),"^",4)'=^TMP($JOB,"RFQ","NBR ITEMS")
SET PRCFLG("NBR")=""
+22 IF $PIECE($GET(^PRC(444,PRCDA,8,I,0)),"^",7)]""
SET PRCFLG("CONTRACT")=""
+23 SET J=0
+24 FOR
SET J=$ORDER(^PRC(444,PRCDA,8,I,3,J))
if +J'=J
QUIT
Begin DoDot:2
+25 SET X=$GET(^PRC(444,PRCDA,8,I,3,J,0))
if X=""
QUIT
+26 SET L=$PIECE(X,"^")
+27 IF $PIECE(X,"^",2)'=$GET(^TMP($JOB,"RFQ","ITEM",L,"QUANTITY"))
SET PRCFLG("QUANTITY")=""
+28 SET K=$SELECT($PIECE(X,"^",3)]"":$PIECE($GET(^PRCD(420.5,$PIECE(X,"^",3),0)),"^",2),1:"")
+29 IF K'=$GET(^TMP($JOB,"RFQ","ITEM",L,"UNIT"))
SET PRCFLG("UNIT")=""
+30 IF $PIECE(X,"^",9)'=$GET(^TMP($JOB,"RFQ","ITEM",L,"MFG PART"))
SET PRCFLG("MFG PART")=""
+31 IF $PIECE($GET(^PRC(444,PRCDA,8,I,3,J,1)),"^",6)]""
SET PRCFLG("CONTRACT")=""
+32 IF $PIECE(X,"^",4)]""
SET PRCFLG("VENDOR PRODUCT #")=""
+33 IF $PIECE(X,"^",8)'=$GET(^TMP($JOB,"RFQ","ITEM",L,"NDC"))
SET PRCFLG("NDC")=""
+34 IF $PIECE(X,"^",6)'=$GET(^TMP($JOB,"RFQ","ITEM",L,"NSN"))
SET PRCFLG("NSN")=""
End DoDot:2
+35 SET FLAG=""
+36 FOR J="FOB^F","QUANTITY^Q","UNIT^U","RECVD DATE^DT","SIZE^S","NBR^LI","CONTRACT^C","MFG PART^M","VENDOR PRODUCT #^V","NSN^NSN","NDC^NDC"
IF $DATA(PRCFLG($PIECE(J,"^")))
SET FLAG=FLAG_$SELECT(FLAG]"":",",1:"")_$PIECE(J,"^",2)
+37 SET $PIECE(STRING(TOT,VNAME,I),"^",6)=FLAG
End DoDot:1
+38 QUIT
VENDOR ; determine 864 messages for each vendor
+1 SET J=0
+2 FOR
SET J=$ORDER(^PRC(444,PRCDA,7,J))
if +J'=J
QUIT
Begin DoDot:1
+3 SET ID=$PIECE($GET(^PRC(444,PRCDA,7,J,0)),"^",3)
if ID=""
QUIT
+4 if '$DATA(VENDOR(ID))
SET VENDOR(ID)=0
SET VENDOR(ID)=VENDOR(ID)+1
End DoDot:1
+5 QUIT
LEGEND ;Print Flags Legend at end of last page.
+1 WRITE !!,?5,"Flags Legend:"
+2 WRITE !,"F=FOB is Different from That Requested"
+3 WRITE !,"Q=Quantity Quoted is Different from RFQ"
+4 WRITE !,"U=Unit of Purchase is Different from RFQ"
+5 WRITE !,"DT=Quote Received at Station after Date/Time Set for Receipt of Quotes"
+6 WRITE !,"S=RFQ Set-Aside for Small Business But Size Status of Vendor is Large or Missing"
+7 WRITE !,"LI=Number of Line Items Quoted Differs from Number of RFQ Line Items"
+8 WRITE !,"C=Vendor Indicates Item(s) on Contract"
+9 WRITE !,"M=Quoted Mfg. Part Number is Different from that Requested"
+10 WRITE !,"V=Vendor has Quoted a Vendor Product Number"
+11 WRITE !,"NSN=National Stock Number Quoted is Different from that Requested"
+12 WRITE !,"NDC=National Drug Code is Different from that Requested"
+13 QUIT
