- 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 Mar 13, 2025@21:14:39 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
