PRCHQ6B ;(WASH IRMFO)/LKG-RFQ SERVER UNPACKING VENDOR QUOTE ;9/11/96 15:41
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
ITEM S PRCIENS="+1,"_PRC("D1")_","_PRC("D0")_",",PRCAR(444.026,PRCIENS,.01)=+$P(PRCX,U,2)
D UPDATE^DIE("E","PRCAR","PRCENUM") D:$D(^TMP("DIERR",$J)) ERRCOPY^PRCHQ6A
I $G(PRCENUM(1))'?1.N S PRCERR=16 G ERR
S PRC("D2")=PRCENUM(1),PRCIENS=PRC("D2")_","_PRC("D1")_","_PRC("D0")_","
K PRCAR,PRCENUM S PRCITEMS=PRCITEMS+1
S PRCY=$P(PRCX,U,3) S:$L(PRCY)>4 PRCAR(444.026,PRCIENS,5)=PRCY
S PRCAR(444.026,PRCIENS,4)=$P(PRCY,"-")
S PRCY=$P(PRCX,U,5) S:PRCY]"" PRCAR(444.026,PRCIENS,1)=PRCY
S PRCY=$P(PRCX,U,6) S:PRCY]"" PRCAR(444.026,PRCIENS,8)=PRCY
S PRCY=$P(PRCX,U,7) S:PRCY]"" PRCAR(444.026,PRCIENS,7)=PRCY
S PRCAR(444.026,PRCIENS,2)=$P(PRCX,U,8)/100
S PRCAR(444.026,PRCIENS,3)=$P(PRCX,U,9)
S PRCAR(444.026,PRCIENS,13)=$P(PRCX,U,10)/10000
S PRCY=$P(PRCX,U,12)
I PRCY]"" D
. S PRCY="."_PRCY*100
. S PRCAR(444.026,PRCIENS,14)=PRCY
S PRCY=$P(PRCX,U,13) S:PRCY]"" PRCAR(444.026,PRCIENS,15)=PRCY/100
S PRCY=$P(PRCX,U,19) S:PRCY]"" PRCAR(444.026,PRCIENS,16)=PRCY
S PRCY=$P(PRCX,U,23) S:PRCY]"" PRCAR(444.026,PRCIENS,9)=PRCY
S PRCY=$P(PRCX,U,24) S:PRCY]"" PRCAR(444.026,PRCIENS,10)=PRCY
S PRCY=$P(PRCX,U,22) S:PRCY]""&(PRCY'="000000") PRCAR(444.026,PRCIENS,6)=$S($D(^PRC(444.2,PRCY,0)):$P(^(0),U),1:PRCY)
S PRCY=$P(PRCX,U,25) S:PRCY]"" PRCAR(444.026,PRCIENS,12)=$S(PRCY="HM":"HAZARDOUS MATERIAL",1:PRCY)
S PRCY=$P(PRCX,U,26) S:PRCY]"" PRCAR(444.026,PRCIENS,11)=$S(PRCY="O":"ORIGIN",PRCY="D":"DESTINATION",1:PRCY)
S PRCAR(444.026,PRCIENS,18)=$FN($G(PRCAR(444.026,PRCIENS,13))*$G(PRCAR(444.026,PRCIENS,2)),"",2)
S X=$S($G(PRCAR(444.026,PRCIENS,14))>0:PRCAR(444.026,PRCIENS,18)*PRCAR(444.026,PRCIENS,14)/100,1:$G(PRCAR(444.026,PRCIENS,15)))
S:X>0 PRCAR(444.026,PRCIENS,18)=$FN(PRCAR(444.026,PRCIENS,18)-X,"",2) K X
D FILE^DIE("E","PRCAR") K PRCAR D:$D(^TMP("DIERR",$J)) ERRCOPY^PRCHQ6A
K ^TMP($J,"DE") S PRCJ=0
F S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) Q:PRCI="" S PRCX=$G(^(PRCI,0)) Q:$P(PRCX,U)'="DE" D
. S PRCJ=PRCJ+1,^TMP($J,"DE",PRCJ,0)=$P(PRCX,U,4)
D:PRCJ>0 WP^DIE(444.026,PRCIENS,1.5,"","^TMP($J,""DE"")")
D:$D(^TMP("DIERR",$J)) ERRCOPY^PRCHQ6A
K ^TMP($J,"DE")
G EX:PRCI="",EX:$P(PRCX,U)="$",ITEM:$P(PRCX,U)="IT"
I $P(PRCX,U)'="SC" S PRCERR=12 G ERR
DELSCHED ;Delivery Schedule Loop
S PRCIENS="+1,"_PRC("D2")_","_PRC("D1")_","_PRC("D0")_","
S PRCAR(444.027,PRCIENS,.01)=+$P(PRCX,U,3)
D UPDATE^DIE("E","PRCAR","PRCENUM") D:$D(^TMP("DIERR",$J)) ERRCOPY^PRCHQ6A
I $G(PRCENUM(1))'?1.N S PRCERR=17 G ERR
S PRC("D3")=PRCENUM(1)
S PRCIENS=PRC("D3")_","_PRC("D2")_","_PRC("D1")_","_PRC("D0")_","
K PRCAR,PRCENUM
S PRCAR(444.027,PRCIENS,2)=$P(PRCX,U,4)/100
S PRCAR(444.027,PRCIENS,3)=$P(PRCX,U,5)
S X=$$JD2FMD^PRCHQ7($P(PRCX,U,6)),X=+$E(X,4,5)_"/"_(+$E(X,6,7))_"/"_($E(X,1,3)+1700)
S PRCAR(444.027,PRCIENS,1)=X K X
D FILE^DIE("E","PRCAR") K PRCAR D:$D(^TMP("DIERR",$J)) ERRCOPY^PRCHQ6A
S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) G:PRCI="" EX
S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0))
G DELSCHED:$P(PRCX,U)="SC",ITEM:$P(PRCX,U)="IT"
I $P(PRCX,U)'="$",$P(PRCX,U)'="~" S PRCERR=13 G ERR
EX ;
I $D(PRC("D0")),$D(PRC("D1")) D QUOTETOT^PRCHQ1B(PRC("D0"),PRC("D1"))
I $G(PRCITEMS)'=$G(PRCICNT) S PRCERR=14 G ERR
I $D(^TMP($J,"PRCERR")) G ERR
EX1 L:$D(PRC("D0")) -^PRC(444,PRC("D0"))
K PRC,PRCAR,PRCDA,PRCDB,PRCDBI,PRCEFFDT,PRCENUM,PRCERR,PRCI,PRCICNT,PRCITEMS
K PRCIENS,PRCJ,PRCNUM,PRCRCVDT,PRCREF,PRCRFQ,PRCVCN,PRCVCP,PRCVDA,PRCVEN
K PRCX,PRCY,X,Y,PRCVNM
S:$D(ZTQUEUED) ZTREQ="@"
Q
ERR ;
K ^TMP($J,"MSG")
S ^TMP($J,"MSG",1,0)="During the filing of an 843 Transaction (Vendor's Quote) from vendor"
S ^TMP($J,"MSG",2,0)=$G(PRCDB)_" for RFQ # "_$G(PRCRFQ)_", the following errors"
S ^TMP($J,"MSG",3,0)="occurred: ",PRCJ=3
S:$D(PRCERR) PRCJ=PRCJ+1,^TMP($J,"MSG",PRCJ,0)=$P($T(TXT+PRCERR),";;",2)
I $D(^TMP($J,"PRCERR")) D
. S PRCX=0
. F S PRCX=$O(^TMP($J,"PRCERR",PRCX)) Q:PRCX'?1.N D
. . S:$D(^TMP($J,"PRCERR",PRCX)) PRCJ=PRCJ+1,^TMP($J,"MSG",PRCJ,0)=^(PRCX)
S XMTEXT="^TMP($J,""MSG"","
I $D(PRC("D0")) S X=$P($G(^PRC(444,PRC("D0"),0)),U,4) S:X?1.N XMY(X)=""
S XMY("G.PRCHQ RFQ")="" ;,XMDUZ="843 Vendor Quote Filer"
S XMSUB="Error filing Quote for RFQ #: "_$G(PRCRFQ)
D ^XMD K XMZ,^TMP($J,"MSG"),^TMP($J,"PRCERR"),XMY,XMTEXT,XMSUB
G EX1
TXT ;Error Messages
;;No segments to process in the File #423.6 entry.
;;Initial segment not 'ISM' for 843 Transaction (Vendor's Quote).
;;No 'HE' segment.
;;Referenced RFQ not found in REQUEST FOR QUOTATION File (#444).
;;Unable to lock RFQ entry - timed out.
;;No 'VE' Segment.
;;Unable to add submitting vendor to RFQ VENDOR File (#444.1).
;;Unable to add entry to QUOTES multiple of File (#444).
;;Unable to lock QUOTES entry - timed out.
;;No 'AC' segment.
;;No 'IT' segment.
;;Segment type 'SC' expected but not found.
;;Inappropriate segment type following 'SC' segment.
;;Number of Items Processed does not equal Number of Items
;;Unable to add Prompt Pay Terms
;;Unable to add entry to ITEM multiple
;;Unable to add entry to DELIVERY SCHEDULE multiple
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQ6B 5228 printed Apr 09, 2024@21:20:19 Page 2
PRCHQ6B ;(WASH IRMFO)/LKG-RFQ SERVER UNPACKING VENDOR QUOTE ;9/11/96 15:41
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
ITEM SET PRCIENS="+1,"_PRC("D1")_","_PRC("D0")_","
SET PRCAR(444.026,PRCIENS,.01)=+$PIECE(PRCX,U,2)
+1 DO UPDATE^DIE("E","PRCAR","PRCENUM")
if $DATA(^TMP("DIERR",$JOB))
DO ERRCOPY^PRCHQ6A
+2 IF $GET(PRCENUM(1))'?1.N
SET PRCERR=16
GOTO ERR
+3 SET PRC("D2")=PRCENUM(1)
SET PRCIENS=PRC("D2")_","_PRC("D1")_","_PRC("D0")_","
+4 KILL PRCAR,PRCENUM
SET PRCITEMS=PRCITEMS+1
+5 SET PRCY=$PIECE(PRCX,U,3)
if $LENGTH(PRCY)>4
SET PRCAR(444.026,PRCIENS,5)=PRCY
+6 SET PRCAR(444.026,PRCIENS,4)=$PIECE(PRCY,"-")
+7 SET PRCY=$PIECE(PRCX,U,5)
if PRCY]""
SET PRCAR(444.026,PRCIENS,1)=PRCY
+8 SET PRCY=$PIECE(PRCX,U,6)
if PRCY]""
SET PRCAR(444.026,PRCIENS,8)=PRCY
+9 SET PRCY=$PIECE(PRCX,U,7)
if PRCY]""
SET PRCAR(444.026,PRCIENS,7)=PRCY
+10 SET PRCAR(444.026,PRCIENS,2)=$PIECE(PRCX,U,8)/100
+11 SET PRCAR(444.026,PRCIENS,3)=$PIECE(PRCX,U,9)
+12 SET PRCAR(444.026,PRCIENS,13)=$PIECE(PRCX,U,10)/10000
+13 SET PRCY=$PIECE(PRCX,U,12)
+14 IF PRCY]""
Begin DoDot:1
+15 SET PRCY="."_PRCY*100
+16 SET PRCAR(444.026,PRCIENS,14)=PRCY
End DoDot:1
+17 SET PRCY=$PIECE(PRCX,U,13)
if PRCY]""
SET PRCAR(444.026,PRCIENS,15)=PRCY/100
+18 SET PRCY=$PIECE(PRCX,U,19)
if PRCY]""
SET PRCAR(444.026,PRCIENS,16)=PRCY
+19 SET PRCY=$PIECE(PRCX,U,23)
if PRCY]""
SET PRCAR(444.026,PRCIENS,9)=PRCY
+20 SET PRCY=$PIECE(PRCX,U,24)
if PRCY]""
SET PRCAR(444.026,PRCIENS,10)=PRCY
+21 SET PRCY=$PIECE(PRCX,U,22)
if PRCY]""&(PRCY'="000000")
SET PRCAR(444.026,PRCIENS,6)=$SELECT($DATA(^PRC(444.2,PRCY,0)):$PIECE(^(0),U),1:PRCY)
+22 SET PRCY=$PIECE(PRCX,U,25)
if PRCY]""
SET PRCAR(444.026,PRCIENS,12)=$SELECT(PRCY="HM":"HAZARDOUS MATERIAL",1:PRCY)
+23 SET PRCY=$PIECE(PRCX,U,26)
if PRCY]""
SET PRCAR(444.026,PRCIENS,11)=$SELECT(PRCY="O":"ORIGIN",PRCY="D":"DESTINATION",1:PRCY)
+24 SET PRCAR(444.026,PRCIENS,18)=$FNUMBER($GET(PRCAR(444.026,PRCIENS,13))*$GET(PRCAR(444.026,PRCIENS,2)),"",2)
+25 SET X=$SELECT($GET(PRCAR(444.026,PRCIENS,14))>0:PRCAR(444.026,PRCIENS,18)*PRCAR(444.026,PRCIENS,14)/100,1:$GET(PRCAR(444.026,PRCIENS,15)))
+26 if X>0
SET PRCAR(444.026,PRCIENS,18)=$FNUMBER(PRCAR(444.026,PRCIENS,18)-X,"",2)
KILL X
+27 DO FILE^DIE("E","PRCAR")
KILL PRCAR
if $DATA(^TMP("DIERR",$JOB))
DO ERRCOPY^PRCHQ6A
+28 KILL ^TMP($JOB,"DE")
SET PRCJ=0
+29 FOR
SET PRCI=$ORDER(^PRCF(423.6,PRCDA,1,PRCI))
if PRCI=""
QUIT
SET PRCX=$GET(^(PRCI,0))
if $PIECE(PRCX,U)'="DE"
QUIT
Begin DoDot:1
+30 SET PRCJ=PRCJ+1
SET ^TMP($JOB,"DE",PRCJ,0)=$PIECE(PRCX,U,4)
End DoDot:1
+31 if PRCJ>0
DO WP^DIE(444.026,PRCIENS,1.5,"","^TMP($J,""DE"")")
+32 if $DATA(^TMP("DIERR",$JOB))
DO ERRCOPY^PRCHQ6A
+33 KILL ^TMP($JOB,"DE")
+34 if PRCI=""
GOTO EX
if $PIECE(PRCX,U)="$"
GOTO EX
if $PIECE(PRCX,U)="IT"
GOTO ITEM
+35 IF $PIECE(PRCX,U)'="SC"
SET PRCERR=12
GOTO ERR
DELSCHED ;Delivery Schedule Loop
+1 SET PRCIENS="+1,"_PRC("D2")_","_PRC("D1")_","_PRC("D0")_","
+2 SET PRCAR(444.027,PRCIENS,.01)=+$PIECE(PRCX,U,3)
+3 DO UPDATE^DIE("E","PRCAR","PRCENUM")
if $DATA(^TMP("DIERR",$JOB))
DO ERRCOPY^PRCHQ6A
+4 IF $GET(PRCENUM(1))'?1.N
SET PRCERR=17
GOTO ERR
+5 SET PRC("D3")=PRCENUM(1)
+6 SET PRCIENS=PRC("D3")_","_PRC("D2")_","_PRC("D1")_","_PRC("D0")_","
+7 KILL PRCAR,PRCENUM
+8 SET PRCAR(444.027,PRCIENS,2)=$PIECE(PRCX,U,4)/100
+9 SET PRCAR(444.027,PRCIENS,3)=$PIECE(PRCX,U,5)
+10 SET X=$$JD2FMD^PRCHQ7($PIECE(PRCX,U,6))
SET X=+$EXTRACT(X,4,5)_"/"_(+$EXTRACT(X,6,7))_"/"_($EXTRACT(X,1,3)+1700)
+11 SET PRCAR(444.027,PRCIENS,1)=X
KILL X
+12 DO FILE^DIE("E","PRCAR")
KILL PRCAR
if $DATA(^TMP("DIERR",$JOB))
DO ERRCOPY^PRCHQ6A
+13 SET PRCI=$ORDER(^PRCF(423.6,PRCDA,1,PRCI))
if PRCI=""
GOTO EX
+14 SET PRCX=$GET(^PRCF(423.6,PRCDA,1,PRCI,0))
+15 if $PIECE(PRCX,U)="SC"
GOTO DELSCHED
if $PIECE(PRCX,U)="IT"
GOTO ITEM
+16 IF $PIECE(PRCX,U)'="$"
IF $PIECE(PRCX,U)'="~"
SET PRCERR=13
GOTO ERR
EX ;
+1 IF $DATA(PRC("D0"))
IF $DATA(PRC("D1"))
DO QUOTETOT^PRCHQ1B(PRC("D0"),PRC("D1"))
+2 IF $GET(PRCITEMS)'=$GET(PRCICNT)
SET PRCERR=14
GOTO ERR
+3 IF $DATA(^TMP($JOB,"PRCERR"))
GOTO ERR
EX1 if $DATA(PRC("D0"))
LOCK -^PRC(444,PRC("D0"))
+1 KILL PRC,PRCAR,PRCDA,PRCDB,PRCDBI,PRCEFFDT,PRCENUM,PRCERR,PRCI,PRCICNT,PRCITEMS
+2 KILL PRCIENS,PRCJ,PRCNUM,PRCRCVDT,PRCREF,PRCRFQ,PRCVCN,PRCVCP,PRCVDA,PRCVEN
+3 KILL PRCX,PRCY,X,Y,PRCVNM
+4 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 QUIT
ERR ;
+1 KILL ^TMP($JOB,"MSG")
+2 SET ^TMP($JOB,"MSG",1,0)="During the filing of an 843 Transaction (Vendor's Quote) from vendor"
+3 SET ^TMP($JOB,"MSG",2,0)=$GET(PRCDB)_" for RFQ # "_$GET(PRCRFQ)_", the following errors"
+4 SET ^TMP($JOB,"MSG",3,0)="occurred: "
SET PRCJ=3
+5 if $DATA(PRCERR)
SET PRCJ=PRCJ+1
SET ^TMP($JOB,"MSG",PRCJ,0)=$PIECE($TEXT(TXT+PRCERR),";;",2)
+6 IF $DATA(^TMP($JOB,"PRCERR"))
Begin DoDot:1
+7 SET PRCX=0
+8 FOR
SET PRCX=$ORDER(^TMP($JOB,"PRCERR",PRCX))
if PRCX'?1.N
QUIT
Begin DoDot:2
+9 if $DATA(^TMP($JOB,"PRCERR",PRCX))
SET PRCJ=PRCJ+1
SET ^TMP($JOB,"MSG",PRCJ,0)=^(PRCX)
End DoDot:2
End DoDot:1
+10 SET XMTEXT="^TMP($J,""MSG"","
+11 IF $DATA(PRC("D0"))
SET X=$PIECE($GET(^PRC(444,PRC("D0"),0)),U,4)
if X?1.N
SET XMY(X)=""
+12 ;,XMDUZ="843 Vendor Quote Filer"
SET XMY("G.PRCHQ RFQ")=""
+13 SET XMSUB="Error filing Quote for RFQ #: "_$GET(PRCRFQ)
+14 DO ^XMD
KILL XMZ,^TMP($JOB,"MSG"),^TMP($JOB,"PRCERR"),XMY,XMTEXT,XMSUB
+15 GOTO EX1
TXT ;Error Messages
+1 ;;No segments to process in the File #423.6 entry.
+2 ;;Initial segment not 'ISM' for 843 Transaction (Vendor's Quote).
+3 ;;No 'HE' segment.
+4 ;;Referenced RFQ not found in REQUEST FOR QUOTATION File (#444).
+5 ;;Unable to lock RFQ entry - timed out.
+6 ;;No 'VE' Segment.
+7 ;;Unable to add submitting vendor to RFQ VENDOR File (#444.1).
+8 ;;Unable to add entry to QUOTES multiple of File (#444).
+9 ;;Unable to lock QUOTES entry - timed out.
+10 ;;No 'AC' segment.
+11 ;;No 'IT' segment.
+12 ;;Segment type 'SC' expected but not found.
+13 ;;Inappropriate segment type following 'SC' segment.
+14 ;;Number of Items Processed does not equal Number of Items
+15 ;;Unable to add Prompt Pay Terms
+16 ;;Unable to add entry to ITEM multiple
+17 ;;Unable to add entry to DELIVERY SCHEDULE multiple
