PRCHQ6A ;(WASH IRMFO)/LKG-RFQ SERVER UNPACKING VENDOR QUOTE ;8/6/96  20:57
 ;;5.1;IFCAP;;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
A I PRCVEN["PRC(440," D
 . K XMB,XMZ
 . F PRCJ=1:1:27 S XMB(PRCJ)=""
 . S XMB="PRCHQ 843 UPDATE VENDOR INFO"
 . S XMB(27)=PRCRFQ
 . S XMB(1)=$P(PRCX,U,2),XMB(2)=$P(PRCX,U,3),XMB(3)=$P(PRCX,U,11)
 . S XMB(4)=$P(PRCX,U,10),XMB(5)=$P(PRCX,U,4),XMB(6)=$P(PRCX,U,5)
 . S XMB(7)=$P(PRCX,U,6),XMB(8)=$P(PRCX,U,7),XMB(9)=$P(PRCX,U,8)
 . S XMB(10)=$P(PRCX,U,9)
 . S X=$P(PRCX,U,12),XMB(11)=$S(X=21:"SMALL",X="B9":"LARGE",1:"")
 . S XMB(12)=$S($P(PRCX,U,13)=22:"YES",1:"NO")
 . S XMB(13)=$S($P(PRCX,U,14)=23:"YES",1:"NO")
 . S XMB(14)=$S($P(PRCX,U,15)=24:"YES",1:"NO")
 . S XMB(15)=$S($P(PRCX,U,16)=25:"YES",1:"NO")
 . S XMB(16)=$S($P(PRCX,U,17)=27:"YES",1:"NO")
 . S XMB(17)=$S($P(PRCX,U,18)="A5":"YES",1:"NO")
 . S XMB(18)=$S($P(PRCX,U,19)="A6":"YES",1:"NO")
 . S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI))
 . S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0))
 . I $P(PRCX,U)="RT" D
 . . S XMB(19)=$P(PRCX,U,2),XMB(20)=$P(PRCX,U,3),XMB(21)=$P(PRCX,U,4)
 . . S XMB(22)=$P(PRCX,U,5),XMB(23)=$P(PRCX,U,6),XMB(24)=$P(PRCX,U,7)
 . . S XMB(25)=$P(PRCX,U,8),XMB(26)=$P(PRCX,U,9)
 . S XMDUZ="843 Vendor Quote Filer" D ^XMB K XMB,XMDUZ,XMZ
 I $P(PRCX,U)="RT" S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) I PRCI="" S PRCERR=10 G ERR^PRCHQ6B
 S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0)) I $P(PRCX,U)'="AC" S PRCERR=10 G ERR^PRCHQ6B
 K PRCAR S PRCIENS=PRC("D1")_","_PRC("D0")_","
 S:PRCREF]"" PRCAR(444.024,PRCIENS,1)=PRCREF
 S:PRCEFFDT]"" PRCAR(444.024,PRCIENS,2)=+$E(PRCEFFDT,4,5)_"/"_(+$E(PRCEFFDT,6,7))_"/"_($E(PRCEFFDT,1,3)+1700)
 S:PRCVCN]"" PRCAR(444.024,PRCIENS,4)=$E(PRCVCN,1,30)
 S:PRCVCP]"" PRCAR(444.024,PRCIENS,5)=PRCVCP
 S PRCY=$P(PRCX,U,3) S:PRCY]"" PRCAR(444.024,PRCIENS,6)=$S(PRCY="O":"ORIGIN",PRCY="D":"DESTINATION",1:PRCY)
 S PRCY=$P(PRCX,U,2) S:PRCY]"" PRCAR(444.024,PRCIENS,7)=PRCY/100
 S PRCY=$P(PRCX,U,4) S:PRCY]"" PRCAR(444.024,PRCIENS,8)=PRCY/100
 D FILE^DIE("E","PRCAR") K PRCAR,PRCENUM D:$D(^TMP("DIERR",$J)) ERRCOPY
 S PRCIENS="+1,"_PRCIENS
 S PRCY=$S($P(PRCX,U,5)>0:$P(PRCX,U,5),$P(PRCX,U,7)="N":"NET",1:"")
 S:PRCY?1.N PRCY="."_PRCY*100
 I PRCY]"" D  G:$D(PRCERR) ERR^PRCHQ6B
 . S PRCAR(444.025,PRCIENS,.01)=PRCY,PRCAR(444.025,PRCIENS,1)=$P(PRCX,U,6)
 . D UPDATE^DIE("E","PRCAR","PRCENUM") D:$D(^TMP("DIERR",$J)) ERRCOPY
 . S:$G(PRCENUM(1))'?1.N PRCERR=15
 . K PRCIENS,PRCAR,PRCENUM
 S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) I PRCI="" S PRCERR=11 G ERR^PRCHQ6B
 S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0))
 I $P(PRCX,U)="TX" D
 . K ^TMP($J,"TX") S PRCJ=0
 . F  D  Q:$P(PRCX,U)'="TX"
 . . S PRCJ=PRCJ+1,^TMP($J,"TX",PRCJ,0)=$P(PRCX,U,3)
 . . S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI))
 . . S PRCX=$S(PRCI="":"",1:$G(^PRCF(423.6,PRCDA,1,PRCI,0)))
 . S PRCY=$P($G(^PRC(444,PRC("D0"),1)),U,5)+1,$P(^(1),U,5)=PRCY
 . S PRCIENS="+1,"_PRC("D0")_"," K PRCAR
 . S PRCAR(444.021,PRCIENS,.01)=PRCY,PRCENUM(1)=PRCY
 . D UPDATE^DIE("","PRCAR","PRCENUM") K PRCAR D:$D(^TMP("DIERR",$J)) ERRCOPY
 . S PRCIENS=PRCENUM(1)_","_PRC("D0")_"," K PRCENUM
 . S PRCAR(444.021,PRCIENS,1)="I",PRCAR(444.021,PRCIENS,2)=PRCDB
 . S:PRCVNM]"" PRCAR(444.021,PRCIENS,2.5)=PRCVNM
 . S PRCAR(444.021,PRCIENS,3)=PRCREF,PRCAR(444.021,PRCIENS,4)=999
 . S PRCAR(444.021,PRCIENS,5)=PRCEFFDT,PRCAR(444.021,PRCIENS,6)=PRCRCVDT
 . S PRCAR(444.021,PRCIENS,7)=PRCVCN,PRCAR(444.021,PRCIENS,8)=PRCVCP
 . S PRCAR(444.021,PRCIENS,9)="Comments submitted with 843 Transaction."
 . D FILE^DIE("","PRCAR") K PRCAR D:$D(^TMP("DIERR",$J)) ERRCOPY
 . D WP^DIE(444.021,PRCIENS,10,"","^TMP($J,""TX"")") D:$D(^TMP("DIERR",$J)) ERRCOPY
 . K ^TMP($J,"TX")
 . K XMB,XMY S XMB="PRCHQ 864 NORMAL",XMB(1)=$G(PRCRFQ),XMB(2)=$G(PRCDB),XMB(3)=$P($G(PRCIENS),",")
 . S X=$P($G(^PRC(444,PRC("D0"),0)),U,4) S:X?1.N XMY(X)=""
 . S XMDUZ="864 Text Message Filer" D ^XMB K XMB,XMDUZ,XMZ
 I PRCI="" S PRCERR=11 G ERR^PRCHQ6B
 S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0)) I $P(PRCX,U)'="IT" S PRCERR=11 G ERR^PRCHQ6B
 S PRCITEMS=0
 G ITEM^PRCHQ6B
DELTNONE ;Delete Socioeconomic Group 'OO - None of the Above'
 N DA,DIK S DA(1)=PRCVDA,DA=$O(^PRC(444.1,DA(1),4,"B",161,"")) Q:DA=""
 S DIK="^PRC(444.1,DA(1),4," D ^DIK
 Q
ERRCOPY ;Copy error messages to report file
 N PRCJ,PRCK S PRCK=$G(^TMP($J,"PRCERR")),PRCJ=0
 F  S PRCJ=$O(^TMP("DIERR",$J,PRCJ)) Q:PRCJ'?1.N  D
 . I $D(^TMP("DIERR",$J,PRCJ,"TEXT",1)) D
 . . S PRCK=PRCK+1,^TMP($J,"PRCERR",PRCK)=^TMP("DIERR",$J,PRCJ,"TEXT",1)
 . . S:$D(^TMP("DIERR",$J,PRCJ,"PARAM","IENS")) ^TMP($J,"PRCERR",PRCK)=$E(^TMP($J,"PRCERR",PRCK),1,220)_"-IENS: "_^TMP("DIERR",$J,PRCJ,"PARAM","IENS")
 S:PRCK>0 ^TMP($J,"PRCERR")=PRCK
 K ^TMP("DIERR",$J)
 Q