PRCHQ4 ;WOIFO/LKG-RFQ Set up Transmission Records ;7/25/05 15:27
;;5.1;IFCAP;**63,114**;Oct 20, 2000;Build 4
;Per VHA Directive 2004-038, this routine should not be modified.
HE ;Set up Heading segment
N PRCN0,PRCN1,PRCA,PRCB,PRCZ,DA,DIC,DR,DIQ,X,Y
S PRCN0=$G(^PRC(444,PRCDA,0)),PRCN1=$G(^PRC(444,PRCDA,1))
S X=$P(PRCN0,U,2) D JDN^PRCUTL S PRCA="HE^^"_Y_"^^"
S X=$P(PRCN1,U,2) D JDN^PRCUTL S PRCA=PRCA_Y_"^"
S PRCB=$P(PRCN0,U,3),X=$P(PRCB,".") D JDN^PRCUTL S X=$P(PRCB,".",2)
S X=X_$E("000000",$L(X)+1,6),PRCA=PRCA_Y_"^"_X_"^^^^^0^0^0^^^^^|"
K DA S DA=$P(PRCN0,U,4) I DA?1.N D
. K ^UTILITY("DIQ1",$J)
. S DIC=200,DR=".01;.135",DIQ(0)="I" D EN^DIQ1 K DIC,DIQ,DR
. S $P(PRCA,"^",8,9)=^UTILITY("DIQ1",$J,200,DA,.01,"I")_"^"_^UTILITY("DIQ1",$J,200,DA,.135,"I")
. K ^UTILITY("DIQ1",$J)
S ^TMP($J,"STRING",1)=PRCA
I $P(PRCA,U,3)'?7N S PRCZ(1)="Invalid RFQ Reference Date"
I $P(PRCA,U,5)'?7N S PRCZ(2)="Invalid Requested Delivery Date"
I $P(PRCA,U,6)'?7N S PRCZ(3)="Invalid RFQ Bids Due Date"
I $P(PRCA,U,7)'?6N S PRCZ(4)="Invalid RFQ Bids Due Time"
I $P(PRCA,U,8)="" S PRCZ(5)="Contracting Officer's Name is missing"
I $P(PRCA,U,9)="" S PRCZ(6)="Contracting Officer's Commercial Phone # is missing"
I $D(PRCZ) S PRCERR=3 D EN^DDIOL(.PRCZ)
Q
VELST(PRCN) ;Gets list of solicited vendors from RFQ and invokes 'VE' setup
N PRCX,PRCY,X,PRCW S PRCX=0,PRCW=0
F S PRCX=$O(^PRC(444,PRCDA,5,PRCX)) Q:PRCX'?1.N D
. S PRCY=$G(^PRC(444,PRCDA,5,PRCX,0)) Q:PRCY=""
. S:$P(PRCY,U,2)="" $P(PRCY,U,2)=$P(^PRC(444,PRCDA,0),U,7),$P(^PRC(444,PRCDA,5,PRCX,0),U,2)=$P(PRCY,U,2)
. Q:";b;e;"'[(";"_$P(PRCY,U,2)_";")
. S PRCY=$P(PRCY,U)
. S X=$S(PRCY["PRC(440,":$P($G(^PRC(440,$P(PRCY,";"),7)),U,12),1:$P($G(^PRC(444.1,$P(PRCY,";"),0)),U,2))
. I X="" D DUNERR(PRCY) Q
. D VE(X,.PRCN) S PRCW=PRCW+1
I $P($G(^PRC(444,PRCDA,1)),U,8)="y" D VE("PUBLIC",.PRCN) S PRCW=PRCW+1
Q PRCW
VE(PRCD,PRCC) ;Set up Vendor segment
S PRCC=PRCC+1
S ^TMP($J,"STRING",PRCC)="VE^"_PRCD_"^^^^^^^^^^^^^^^^^^|"
S ^TMP($J,"VE",PRCD)=""
Q
ST(PRCC) ;Setting up Ship to segment
N PRCX,PRCY,DA,DIC,DR
S PRCY=$G(^PRC(444,PRCDA,0)),PRCX=$P(PRCY,U,10)
S:PRCX="" PRCX=$E($P(PRCY,U),1,3)
S PRCY=$P($G(^PRC(444,PRCDA,1)),U,3) Q:PRCY'?1.N
S PRCX=$G(^PRC(411,PRCX,1,PRCY,0)) Q:PRCX=""
S PRCC=PRCC+1
I $P(PRCX,U,9)]"" S ^TMP($J,"STRING",PRCC)="ST^"_$P(PRCX,U,9)_"^^^^^^^^^|" G STX
S PRCY="ST^^"_$P(PRCX,U)_"^"_$P(PRCX,U,2)_"^"_$P(PRCX,U,3)_"^"_$P(PRCX,U,4)
S PRCY=PRCY_"^^"_$P(PRCX,U,5)_"^^"_$TR($P(PRCX,U,7),"-")_"^|"
S DA=$P(PRCX,U,6) I DA?1.N D
. K ^UTILITY("DIQ1",$J) S DIC=5,DR=1 D EN^DIQ1
. S $P(PRCY,U,9)=$E(^UTILITY("DIQ1",$J,5,DA,1),1,2) K ^UTILITY("DIQ1",$J)
S ^TMP($J,"STRING",PRCC)=PRCY
STX Q
MI(PRCRFQ,PRCC) ;Set up Miscellaneous Information segment
N PRCY
S PRCY="MI^^^^"_PRCRFQ_"^^^^^^|",PRCC=PRCC+1
S ^TMP($J,"STRING",PRCC)=PRCY
Q
AC(PRCC) ;Set up Accounting Information segment
N PRCY
S PRCY="AC^^"_$P($G(^PRC(444,PRCDA,1)),U)_"^^^^^^^^^^^^^^^^|",PRCC=PRCC+1
S ^TMP($J,"STRING",PRCC)=PRCY
Q
TX(PRCN,PRCC) ;Set up Text segment (i.e. Administrative Certification
;;or 864 text)
;;Syntax of call: S X=$$TX^PRCHQ4(ARG1,.ARG2)
;; Returns number of lines in reformatted Word Processing field
;;ARG1: CLOSED GLOBAL ROOT
;;ARG2: CURRENT MESSAGE LINE COUNT
N PRCI,PRCT,PRCX,X,DIWL,DIWR,DIWF
S PRCX=0,DIWL=1,DIWR=70,DIWF="" K ^UTILITY($J,"W")
F S PRCX=$O(@PRCN@(PRCX)) Q:PRCX="" D
. Q:'$D(@PRCN@(PRCX,0)) S X=@PRCN@(PRCX,0) D ^DIWP
;I PRCN="^PRC(444,PRCDA,4)",$G(PRCTYPE)="00",$P($G(^PRC(444,PRCDA,1)),U,8)="y" D
;. S X="If you are not an electronic trading partner with VA, you may submit" D ^DIWP
;. S X="your bid by mail or FAX to the Contracting Office. If you would" D ^DIWP
;. S X="like to register as a VA Electronic Trading Partner, please contact" D ^DIWP
;. S X="your Software Provider or VA EDI Staff at 512-326-6463." D ^DIWP
S PRCT=$G(^UTILITY($J,"W",1))+0
F PRCI=1:1:PRCT D
. S PRCC=PRCC+1,X=$G(^UTILITY($J,"W",1,PRCI,0)) S:$L(X)=0 X=" " S X=$TR(X,"^")
. S ^TMP($J,"STRING",PRCC)="TX^"_PRCI_"^"_X_"^|"
K ^UTILITY($J,"W")
Q PRCT
IT(PRCC) ;Set up Item segment (Also calls SC and DE to set up Delivery
;;Schedule and Description segments for item.)
N PRCA,PRCB,PRCD,PRCE,PRCF,PRCG,PRCH,PRCK,PRCL,PRCY,PRCCNT
S PRCA=0,PRCCNT=0
F S PRCA=$O(^PRC(444,PRCDA,2,PRCA)) Q:PRCA'?1.N D
. S PRCL=0
. S PRCB=$G(^PRC(444,PRCDA,2,PRCA,0)) Q:PRCB=""
. S PRCD=$G(^PRC(444,PRCDA,2,PRCA,1)),PRCG=$P(PRCB,U)
. S PRCY="IT^"_PRCG_"^"_$S($P(PRCB,U,6)]"":$P(PRCB,U,6),$P(PRCB,U,5)>0:$P($G(^PRC(441.2,$P(PRCB,U,5),0)),U),1:"")_"^^^",PRCCNT=PRCCNT+1
. I $P($G(^PRC(444,PRCDA,5,0)),U,4)=1,$P($G(^PRC(444,PRCDA,1)),U,8)'="y" S $P(PRCY,U,5)=$P($G(^PRC(444,PRCDA,2,PRCA,5)),U,2)
. S PRCY=PRCY_$P(PRCB,U,9)_"^"_$P(PRCB,U,8)_"^"_($P(PRCB,U,2)*100)_"^^"
. S PRCE=$P(PRCB,U,3) S:PRCE?1.N PRCH=$P($G(^PRCD(420.5,PRCE,0)),U),$P(PRCY,U,9)=PRCH
. S PRCY=PRCY_"^^^^^^^^^^^^^"
. S PRCE=$P(PRCB,U,7) S:PRCE?1.N PRCE=$P($P($G(^PRC(444.2,PRCE,0)),U)," "),$P(PRCY,U,22)=PRCE
. S $P(PRCY,U,23,29)=$P(PRCD,U)_"^"_$P(PRCD,U,2)_"^"_$P(PRCB,U,11)_"^"_$P($G(^PRC(444,PRCDA,1)),U)_"^^^|"
. S PRCC=PRCC+1,^TMP($J,"STRING",PRCC)=PRCY
. S PRCF=PRCC
. S $P(^TMP($J,"STRING",PRCF),U,21)=$$DE("^PRC(444,PRCDA,2,PRCA,2)",PRCG,.PRCC)
. S $P(^TMP($J,"STRING",PRCF),U,27)=$$SC("^PRC(444,PRCDA,2,PRCA,4)",PRCG,PRCH,.PRCC,.PRCL)
. I $P(^TMP($J,"STRING",PRCF),U,3)="" S PRCK(1)="Item #"_$P(PRCB,U)_": FSC and NSN missing"
. I $P(^TMP($J,"STRING",PRCF),U,8)'>0 S PRCK(2)="Item #"_$P(PRCB,U)_": Quantity not greater than zero"
. I $P(^TMP($J,"STRING",PRCF),U,9)="" S PRCK(3)="Item #"_$P(PRCB,U)_": Unit of Purchase missing"
. I $P(^TMP($J,"STRING",PRCF),U,22)="" S PRCK(4)="Item #"_$P(PRCB,U)_": SIC Code missing"
. I $P(^TMP($J,"STRING",PRCF),U,21)'>0 S PRCK(5)="Item #"_$P(PRCB,U)_": Item Description missing"
. I $P(^TMP($J,"STRING",PRCF),U,27)>0,$P(^(PRCF),U,8)'=PRCL S PRCK(6)="Item #"_$P(PRCB,U)_": Total of Delivery Schedule NOT EQUAL to Line Quantity"
S:PRCCNT>0 $P(^TMP($J,"STRING",1),U,12)=PRCCNT
I PRCCNT'>0 S PRCK(7)="No Items in RFQ"
I $D(PRCK) S PRCERR=2 D EN^DDIOL(.PRCK)
Q
SC(PRCN,PRCIT,PRCU,PRCC,PRCJ) ;Set up Delivery Schedule for item
N PRCW,PRCX,PRCY,PRCZ,X,Y
S PRCX=0,PRCW=0
F S PRCX=$O(@PRCN@(PRCX)) Q:PRCX'?1.N D
. S PRCZ=$G(@PRCN@(PRCX,0)) Q:PRCZ=""
. S X=$P(PRCZ,U,2) D JDN^PRCUTL
. S PRCY="SC^"_PRCIT_"^"_$P(PRCZ,U)_"^"_($P(PRCZ,U,3)*100)_"^"_PRCU
. S PRCY=PRCY_"^"_Y_"^|",PRCC=PRCC+1,PRCJ=PRCJ+$P(PRCY,U,4)
. S ^TMP($J,"STRING",PRCC)=PRCY,PRCW=PRCW+1
Q PRCW
DE(PRCN,PRCIT,PRCC) ;Set up Item Description segments
N PRCI,PRCT,PRCX,X,DIWL,DIWR,DIWF
S PRCX=0,DIWL=1,DIWR=70,DIWF="" K ^UTILITY($J,"W")
F S PRCX=$O(@PRCN@(PRCX)) Q:PRCX="" D
. Q:'$D(@PRCN@(PRCX,0)) S X=@PRCN@(PRCX,0) D ^DIWP
S PRCT=$G(^UTILITY($J,"W",1))
F PRCI=1:1:PRCT D
. S PRCC=PRCC+1,X=$G(^UTILITY($J,"W",1,PRCI,0)) S:$L(X)=0 X=" " S X=$TR(X,"^")
. S ^TMP($J,"STRING",PRCC)="DE^"_PRCIT_"^"_PRCI_"^"_X_"^|"
K ^UTILITY($J,"W")
Q PRCT
DUNERR(PRCA) ;Displays the Error Message for Vendor Lacking Dun #
Q:$D(ZTQUEUED)
N PRCB S PRCB="^"_$P(PRCA,";",2)_$P(PRCA,";")_",0)"
S PRCB=$P(@PRCB,U)_" lacks a Dun # so NOT a recipient"
D EN^DDIOL(PRCB)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQ4 7300 printed Apr 09, 2024@21:06:57 Page 2
PRCHQ4 ;WOIFO/LKG-RFQ Set up Transmission Records ;7/25/05 15:27
+1 ;;5.1;IFCAP;**63,114**;Oct 20, 2000;Build 4
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
HE ;Set up Heading segment
+1 NEW PRCN0,PRCN1,PRCA,PRCB,PRCZ,DA,DIC,DR,DIQ,X,Y
+2 SET PRCN0=$GET(^PRC(444,PRCDA,0))
SET PRCN1=$GET(^PRC(444,PRCDA,1))
+3 SET X=$PIECE(PRCN0,U,2)
DO JDN^PRCUTL
SET PRCA="HE^^"_Y_"^^"
+4 SET X=$PIECE(PRCN1,U,2)
DO JDN^PRCUTL
SET PRCA=PRCA_Y_"^"
+5 SET PRCB=$PIECE(PRCN0,U,3)
SET X=$PIECE(PRCB,".")
DO JDN^PRCUTL
SET X=$PIECE(PRCB,".",2)
+6 SET X=X_$EXTRACT("000000",$LENGTH(X)+1,6)
SET PRCA=PRCA_Y_"^"_X_"^^^^^0^0^0^^^^^|"
+7 KILL DA
SET DA=$PIECE(PRCN0,U,4)
IF DA?1.N
Begin DoDot:1
+8 KILL ^UTILITY("DIQ1",$JOB)
+9 SET DIC=200
SET DR=".01;.135"
SET DIQ(0)="I"
DO EN^DIQ1
KILL DIC,DIQ,DR
+10 SET $PIECE(PRCA,"^",8,9)=^UTILITY("DIQ1",$JOB,200,DA,.01,"I")_"^"_^UTILITY("DIQ1",$JOB,200,DA,.135,"I")
+11 KILL ^UTILITY("DIQ1",$JOB)
End DoDot:1
+12 SET ^TMP($JOB,"STRING",1)=PRCA
+13 IF $PIECE(PRCA,U,3)'?7N
SET PRCZ(1)="Invalid RFQ Reference Date"
+14 IF $PIECE(PRCA,U,5)'?7N
SET PRCZ(2)="Invalid Requested Delivery Date"
+15 IF $PIECE(PRCA,U,6)'?7N
SET PRCZ(3)="Invalid RFQ Bids Due Date"
+16 IF $PIECE(PRCA,U,7)'?6N
SET PRCZ(4)="Invalid RFQ Bids Due Time"
+17 IF $PIECE(PRCA,U,8)=""
SET PRCZ(5)="Contracting Officer's Name is missing"
+18 IF $PIECE(PRCA,U,9)=""
SET PRCZ(6)="Contracting Officer's Commercial Phone # is missing"
+19 IF $DATA(PRCZ)
SET PRCERR=3
DO EN^DDIOL(.PRCZ)
+20 QUIT
VELST(PRCN) ;Gets list of solicited vendors from RFQ and invokes 'VE' setup
+1 NEW PRCX,PRCY,X,PRCW
SET PRCX=0
SET PRCW=0
+2 FOR
SET PRCX=$ORDER(^PRC(444,PRCDA,5,PRCX))
if PRCX'?1.N
QUIT
Begin DoDot:1
+3 SET PRCY=$GET(^PRC(444,PRCDA,5,PRCX,0))
if PRCY=""
QUIT
+4 if $PIECE(PRCY,U,2)=""
SET $PIECE(PRCY,U,2)=$PIECE(^PRC(444,PRCDA,0),U,7)
SET $PIECE(^PRC(444,PRCDA,5,PRCX,0),U,2)=$PIECE(PRCY,U,2)
+5 if ";b;e;"'[(";"_$PIECE(PRCY,U,2)_";")
QUIT
+6 SET PRCY=$PIECE(PRCY,U)
+7 SET X=$SELECT(PRCY["PRC(440,":$PIECE($GET(^PRC(440,$PIECE(PRCY,";"),7)),U,12),1:$PIECE($GET(^PRC(444.1,$PIECE(PRCY,";"),0)),U,2))
+8 IF X=""
DO DUNERR(PRCY)
QUIT
+9 DO VE(X,.PRCN)
SET PRCW=PRCW+1
End DoDot:1
+10 IF $PIECE($GET(^PRC(444,PRCDA,1)),U,8)="y"
DO VE("PUBLIC",.PRCN)
SET PRCW=PRCW+1
+11 QUIT PRCW
VE(PRCD,PRCC) ;Set up Vendor segment
+1 SET PRCC=PRCC+1
+2 SET ^TMP($JOB,"STRING",PRCC)="VE^"_PRCD_"^^^^^^^^^^^^^^^^^^|"
+3 SET ^TMP($JOB,"VE",PRCD)=""
+4 QUIT
ST(PRCC) ;Setting up Ship to segment
+1 NEW PRCX,PRCY,DA,DIC,DR
+2 SET PRCY=$GET(^PRC(444,PRCDA,0))
SET PRCX=$PIECE(PRCY,U,10)
+3 if PRCX=""
SET PRCX=$EXTRACT($PIECE(PRCY,U),1,3)
+4 SET PRCY=$PIECE($GET(^PRC(444,PRCDA,1)),U,3)
if PRCY'?1.N
QUIT
+5 SET PRCX=$GET(^PRC(411,PRCX,1,PRCY,0))
if PRCX=""
QUIT
+6 SET PRCC=PRCC+1
+7 IF $PIECE(PRCX,U,9)]""
SET ^TMP($JOB,"STRING",PRCC)="ST^"_$PIECE(PRCX,U,9)_"^^^^^^^^^|"
GOTO STX
+8 SET PRCY="ST^^"_$PIECE(PRCX,U)_"^"_$PIECE(PRCX,U,2)_"^"_$PIECE(PRCX,U,3)_"^"_$PIECE(PRCX,U,4)
+9 SET PRCY=PRCY_"^^"_$PIECE(PRCX,U,5)_"^^"_$TRANSLATE($PIECE(PRCX,U,7),"-")_"^|"
+10 SET DA=$PIECE(PRCX,U,6)
IF DA?1.N
Begin DoDot:1
+11 KILL ^UTILITY("DIQ1",$JOB)
SET DIC=5
SET DR=1
DO EN^DIQ1
+12 SET $PIECE(PRCY,U,9)=$EXTRACT(^UTILITY("DIQ1",$JOB,5,DA,1),1,2)
KILL ^UTILITY("DIQ1",$JOB)
End DoDot:1
+13 SET ^TMP($JOB,"STRING",PRCC)=PRCY
STX QUIT
MI(PRCRFQ,PRCC) ;Set up Miscellaneous Information segment
+1 NEW PRCY
+2 SET PRCY="MI^^^^"_PRCRFQ_"^^^^^^|"
SET PRCC=PRCC+1
+3 SET ^TMP($JOB,"STRING",PRCC)=PRCY
+4 QUIT
AC(PRCC) ;Set up Accounting Information segment
+1 NEW PRCY
+2 SET PRCY="AC^^"_$PIECE($GET(^PRC(444,PRCDA,1)),U)_"^^^^^^^^^^^^^^^^|"
SET PRCC=PRCC+1
+3 SET ^TMP($JOB,"STRING",PRCC)=PRCY
+4 QUIT
TX(PRCN,PRCC) ;Set up Text segment (i.e. Administrative Certification
+1 ;;or 864 text)
+2 ;;Syntax of call: S X=$$TX^PRCHQ4(ARG1,.ARG2)
+3 ;; Returns number of lines in reformatted Word Processing field
+4 ;;ARG1: CLOSED GLOBAL ROOT
+5 ;;ARG2: CURRENT MESSAGE LINE COUNT
+6 NEW PRCI,PRCT,PRCX,X,DIWL,DIWR,DIWF
+7 SET PRCX=0
SET DIWL=1
SET DIWR=70
SET DIWF=""
KILL ^UTILITY($JOB,"W")
+8 FOR
SET PRCX=$ORDER(@PRCN@(PRCX))
if PRCX=""
QUIT
Begin DoDot:1
+9 if '$DATA(@PRCN@(PRCX,0))
QUIT
SET X=@PRCN@(PRCX,0)
DO ^DIWP
End DoDot:1
+10 ;I PRCN="^PRC(444,PRCDA,4)",$G(PRCTYPE)="00",$P($G(^PRC(444,PRCDA,1)),U,8)="y" D
+11 ;. S X="If you are not an electronic trading partner with VA, you may submit" D ^DIWP
+12 ;. S X="your bid by mail or FAX to the Contracting Office. If you would" D ^DIWP
+13 ;. S X="like to register as a VA Electronic Trading Partner, please contact" D ^DIWP
+14 ;. S X="your Software Provider or VA EDI Staff at 512-326-6463." D ^DIWP
+15 SET PRCT=$GET(^UTILITY($JOB,"W",1))+0
+16 FOR PRCI=1:1:PRCT
Begin DoDot:1
+17 SET PRCC=PRCC+1
SET X=$GET(^UTILITY($JOB,"W",1,PRCI,0))
if $LENGTH(X)=0
SET X=" "
SET X=$TRANSLATE(X,"^")
+18 SET ^TMP($JOB,"STRING",PRCC)="TX^"_PRCI_"^"_X_"^|"
End DoDot:1
+19 KILL ^UTILITY($JOB,"W")
+20 QUIT PRCT
IT(PRCC) ;Set up Item segment (Also calls SC and DE to set up Delivery
+1 ;;Schedule and Description segments for item.)
+2 NEW PRCA,PRCB,PRCD,PRCE,PRCF,PRCG,PRCH,PRCK,PRCL,PRCY,PRCCNT
+3 SET PRCA=0
SET PRCCNT=0
+4 FOR
SET PRCA=$ORDER(^PRC(444,PRCDA,2,PRCA))
if PRCA'?1.N
QUIT
Begin DoDot:1
+5 SET PRCL=0
+6 SET PRCB=$GET(^PRC(444,PRCDA,2,PRCA,0))
if PRCB=""
QUIT
+7 SET PRCD=$GET(^PRC(444,PRCDA,2,PRCA,1))
SET PRCG=$PIECE(PRCB,U)
+8 SET PRCY="IT^"_PRCG_"^"_$SELECT($PIECE(PRCB,U,6)]"":$PIECE(PRCB,U,6),$PIECE(PRCB,U,5)>0:$PIECE($GET(^PRC(441.2,$PIECE(PRCB,U,5),0)),U),1:"")_"^^^"
SET PRCCNT=PRCCNT+1
+9 IF $PIECE($GET(^PRC(444,PRCDA,5,0)),U,4)=1
IF $PIECE($GET(^PRC(444,PRCDA,1)),U,8)'="y"
SET $PIECE(PRCY,U,5)=$PIECE($GET(^PRC(444,PRCDA,2,PRCA,5)),U,2)
+10 SET PRCY=PRCY_$PIECE(PRCB,U,9)_"^"_$PIECE(PRCB,U,8)_"^"_($PIECE(PRCB,U,2)*100)_"^^"
+11 SET PRCE=$PIECE(PRCB,U,3)
if PRCE?1.N
SET PRCH=$PIECE($GET(^PRCD(420.5,PRCE,0)),U)
SET $PIECE(PRCY,U,9)=PRCH
+12 SET PRCY=PRCY_"^^^^^^^^^^^^^"
+13 SET PRCE=$PIECE(PRCB,U,7)
if PRCE?1.N
SET PRCE=$PIECE($PIECE($GET(^PRC(444.2,PRCE,0)),U)," ")
SET $PIECE(PRCY,U,22)=PRCE
+14 SET $PIECE(PRCY,U,23,29)=$PIECE(PRCD,U)_"^"_$PIECE(PRCD,U,2)_"^"_$PIECE(PRCB,U,11)_"^"_$PIECE($GET(^PRC(444,PRCDA,1)),U)_"^^^|"
+15 SET PRCC=PRCC+1
SET ^TMP($JOB,"STRING",PRCC)=PRCY
+16 SET PRCF=PRCC
+17 SET $PIECE(^TMP($JOB,"STRING",PRCF),U,21)=$$DE("^PRC(444,PRCDA,2,PRCA,2)",PRCG,.PRCC)
+18 SET $PIECE(^TMP($JOB,"STRING",PRCF),U,27)=$$SC("^PRC(444,PRCDA,2,PRCA,4)",PRCG,PRCH,.PRCC,.PRCL)
+19 IF $PIECE(^TMP($JOB,"STRING",PRCF),U,3)=""
SET PRCK(1)="Item #"_$PIECE(PRCB,U)_": FSC and NSN missing"
+20 IF $PIECE(^TMP($JOB,"STRING",PRCF),U,8)'>0
SET PRCK(2)="Item #"_$PIECE(PRCB,U)_": Quantity not greater than zero"
+21 IF $PIECE(^TMP($JOB,"STRING",PRCF),U,9)=""
SET PRCK(3)="Item #"_$PIECE(PRCB,U)_": Unit of Purchase missing"
+22 IF $PIECE(^TMP($JOB,"STRING",PRCF),U,22)=""
SET PRCK(4)="Item #"_$PIECE(PRCB,U)_": SIC Code missing"
+23 IF $PIECE(^TMP($JOB,"STRING",PRCF),U,21)'>0
SET PRCK(5)="Item #"_$PIECE(PRCB,U)_": Item Description missing"
+24 IF $PIECE(^TMP($JOB,"STRING",PRCF),U,27)>0
IF $PIECE(^(PRCF),U,8)'=PRCL
SET PRCK(6)="Item #"_$PIECE(PRCB,U)_": Total of Delivery Schedule NOT EQUAL to Line Quantity"
End DoDot:1
+25 if PRCCNT>0
SET $PIECE(^TMP($JOB,"STRING",1),U,12)=PRCCNT
+26 IF PRCCNT'>0
SET PRCK(7)="No Items in RFQ"
+27 IF $DATA(PRCK)
SET PRCERR=2
DO EN^DDIOL(.PRCK)
+28 QUIT
SC(PRCN,PRCIT,PRCU,PRCC,PRCJ) ;Set up Delivery Schedule for item
+1 NEW PRCW,PRCX,PRCY,PRCZ,X,Y
+2 SET PRCX=0
SET PRCW=0
+3 FOR
SET PRCX=$ORDER(@PRCN@(PRCX))
if PRCX'?1.N
QUIT
Begin DoDot:1
+4 SET PRCZ=$GET(@PRCN@(PRCX,0))
if PRCZ=""
QUIT
+5 SET X=$PIECE(PRCZ,U,2)
DO JDN^PRCUTL
+6 SET PRCY="SC^"_PRCIT_"^"_$PIECE(PRCZ,U)_"^"_($PIECE(PRCZ,U,3)*100)_"^"_PRCU
+7 SET PRCY=PRCY_"^"_Y_"^|"
SET PRCC=PRCC+1
SET PRCJ=PRCJ+$PIECE(PRCY,U,4)
+8 SET ^TMP($JOB,"STRING",PRCC)=PRCY
SET PRCW=PRCW+1
End DoDot:1
+9 QUIT PRCW
DE(PRCN,PRCIT,PRCC) ;Set up Item Description segments
+1 NEW PRCI,PRCT,PRCX,X,DIWL,DIWR,DIWF
+2 SET PRCX=0
SET DIWL=1
SET DIWR=70
SET DIWF=""
KILL ^UTILITY($JOB,"W")
+3 FOR
SET PRCX=$ORDER(@PRCN@(PRCX))
if PRCX=""
QUIT
Begin DoDot:1
+4 if '$DATA(@PRCN@(PRCX,0))
QUIT
SET X=@PRCN@(PRCX,0)
DO ^DIWP
End DoDot:1
+5 SET PRCT=$GET(^UTILITY($JOB,"W",1))
+6 FOR PRCI=1:1:PRCT
Begin DoDot:1
+7 SET PRCC=PRCC+1
SET X=$GET(^UTILITY($JOB,"W",1,PRCI,0))
if $LENGTH(X)=0
SET X=" "
SET X=$TRANSLATE(X,"^")
+8 SET ^TMP($JOB,"STRING",PRCC)="DE^"_PRCIT_"^"_PRCI_"^"_X_"^|"
End DoDot:1
+9 KILL ^UTILITY($JOB,"W")
+10 QUIT PRCT
DUNERR(PRCA) ;Displays the Error Message for Vendor Lacking Dun #
+1 if $DATA(ZTQUEUED)
QUIT
+2 NEW PRCB
SET PRCB="^"_$PIECE(PRCA,";",2)_$PIECE(PRCA,";")_",0)"
+3 SET PRCB=$PIECE(@PRCB,U)_" lacks a Dun # so NOT a recipient"
+4 DO EN^DDIOL(PRCB)
+5 QUIT
