| 1 | PRCHQ6A ;(WASH IRMFO)/LKG-RFQ SERVER UNPACKING VENDOR QUOTE ;8/6/96 20:57
|
|---|
| 2 | ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | Q
|
|---|
| 5 | A I PRCVEN["PRC(440," D
|
|---|
| 6 | . K XMB,XMZ
|
|---|
| 7 | . F PRCJ=1:1:27 S XMB(PRCJ)=""
|
|---|
| 8 | . S XMB="PRCHQ 843 UPDATE VENDOR INFO"
|
|---|
| 9 | . S XMB(27)=PRCRFQ
|
|---|
| 10 | . S XMB(1)=$P(PRCX,U,2),XMB(2)=$P(PRCX,U,3),XMB(3)=$P(PRCX,U,11)
|
|---|
| 11 | . S XMB(4)=$P(PRCX,U,10),XMB(5)=$P(PRCX,U,4),XMB(6)=$P(PRCX,U,5)
|
|---|
| 12 | . S XMB(7)=$P(PRCX,U,6),XMB(8)=$P(PRCX,U,7),XMB(9)=$P(PRCX,U,8)
|
|---|
| 13 | . S XMB(10)=$P(PRCX,U,9)
|
|---|
| 14 | . S X=$P(PRCX,U,12),XMB(11)=$S(X=21:"SMALL",X="B9":"LARGE",1:"")
|
|---|
| 15 | . S XMB(12)=$S($P(PRCX,U,13)=22:"YES",1:"NO")
|
|---|
| 16 | . S XMB(13)=$S($P(PRCX,U,14)=23:"YES",1:"NO")
|
|---|
| 17 | . S XMB(14)=$S($P(PRCX,U,15)=24:"YES",1:"NO")
|
|---|
| 18 | . S XMB(15)=$S($P(PRCX,U,16)=25:"YES",1:"NO")
|
|---|
| 19 | . S XMB(16)=$S($P(PRCX,U,17)=27:"YES",1:"NO")
|
|---|
| 20 | . S XMB(17)=$S($P(PRCX,U,18)="A5":"YES",1:"NO")
|
|---|
| 21 | . S XMB(18)=$S($P(PRCX,U,19)="A6":"YES",1:"NO")
|
|---|
| 22 | . S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI))
|
|---|
| 23 | . S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0))
|
|---|
| 24 | . I $P(PRCX,U)="RT" D
|
|---|
| 25 | . . S XMB(19)=$P(PRCX,U,2),XMB(20)=$P(PRCX,U,3),XMB(21)=$P(PRCX,U,4)
|
|---|
| 26 | . . S XMB(22)=$P(PRCX,U,5),XMB(23)=$P(PRCX,U,6),XMB(24)=$P(PRCX,U,7)
|
|---|
| 27 | . . S XMB(25)=$P(PRCX,U,8),XMB(26)=$P(PRCX,U,9)
|
|---|
| 28 | . S XMDUZ="843 Vendor Quote Filer" D ^XMB K XMB,XMDUZ,XMZ
|
|---|
| 29 | I $P(PRCX,U)="RT" S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) I PRCI="" S PRCERR=10 G ERR^PRCHQ6B
|
|---|
| 30 | S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0)) I $P(PRCX,U)'="AC" S PRCERR=10 G ERR^PRCHQ6B
|
|---|
| 31 | K PRCAR S PRCIENS=PRC("D1")_","_PRC("D0")_","
|
|---|
| 32 | S:PRCREF]"" PRCAR(444.024,PRCIENS,1)=PRCREF
|
|---|
| 33 | S:PRCEFFDT]"" PRCAR(444.024,PRCIENS,2)=+$E(PRCEFFDT,4,5)_"/"_(+$E(PRCEFFDT,6,7))_"/"_($E(PRCEFFDT,1,3)+1700)
|
|---|
| 34 | S:PRCVCN]"" PRCAR(444.024,PRCIENS,4)=$E(PRCVCN,1,30)
|
|---|
| 35 | S:PRCVCP]"" PRCAR(444.024,PRCIENS,5)=PRCVCP
|
|---|
| 36 | S PRCY=$P(PRCX,U,3) S:PRCY]"" PRCAR(444.024,PRCIENS,6)=$S(PRCY="O":"ORIGIN",PRCY="D":"DESTINATION",1:PRCY)
|
|---|
| 37 | S PRCY=$P(PRCX,U,2) S:PRCY]"" PRCAR(444.024,PRCIENS,7)=PRCY/100
|
|---|
| 38 | S PRCY=$P(PRCX,U,4) S:PRCY]"" PRCAR(444.024,PRCIENS,8)=PRCY/100
|
|---|
| 39 | D FILE^DIE("E","PRCAR") K PRCAR,PRCENUM D:$D(^TMP("DIERR",$J)) ERRCOPY
|
|---|
| 40 | S PRCIENS="+1,"_PRCIENS
|
|---|
| 41 | S PRCY=$S($P(PRCX,U,5)>0:$P(PRCX,U,5),$P(PRCX,U,7)="N":"NET",1:"")
|
|---|
| 42 | S:PRCY?1.N PRCY="."_PRCY*100
|
|---|
| 43 | I PRCY]"" D G:$D(PRCERR) ERR^PRCHQ6B
|
|---|
| 44 | . S PRCAR(444.025,PRCIENS,.01)=PRCY,PRCAR(444.025,PRCIENS,1)=$P(PRCX,U,6)
|
|---|
| 45 | . D UPDATE^DIE("E","PRCAR","PRCENUM") D:$D(^TMP("DIERR",$J)) ERRCOPY
|
|---|
| 46 | . S:$G(PRCENUM(1))'?1.N PRCERR=15
|
|---|
| 47 | . K PRCIENS,PRCAR,PRCENUM
|
|---|
| 48 | S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) I PRCI="" S PRCERR=11 G ERR^PRCHQ6B
|
|---|
| 49 | S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0))
|
|---|
| 50 | I $P(PRCX,U)="TX" D
|
|---|
| 51 | . K ^TMP($J,"TX") S PRCJ=0
|
|---|
| 52 | . F D Q:$P(PRCX,U)'="TX"
|
|---|
| 53 | . . S PRCJ=PRCJ+1,^TMP($J,"TX",PRCJ,0)=$P(PRCX,U,3)
|
|---|
| 54 | . . S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI))
|
|---|
| 55 | . . S PRCX=$S(PRCI="":"",1:$G(^PRCF(423.6,PRCDA,1,PRCI,0)))
|
|---|
| 56 | . S PRCY=$P($G(^PRC(444,PRC("D0"),1)),U,5)+1,$P(^(1),U,5)=PRCY
|
|---|
| 57 | . S PRCIENS="+1,"_PRC("D0")_"," K PRCAR
|
|---|
| 58 | . S PRCAR(444.021,PRCIENS,.01)=PRCY,PRCENUM(1)=PRCY
|
|---|
| 59 | . D UPDATE^DIE("","PRCAR","PRCENUM") K PRCAR D:$D(^TMP("DIERR",$J)) ERRCOPY
|
|---|
| 60 | . S PRCIENS=PRCENUM(1)_","_PRC("D0")_"," K PRCENUM
|
|---|
| 61 | . S PRCAR(444.021,PRCIENS,1)="I",PRCAR(444.021,PRCIENS,2)=PRCDB
|
|---|
| 62 | . S:PRCVNM]"" PRCAR(444.021,PRCIENS,2.5)=PRCVNM
|
|---|
| 63 | . S PRCAR(444.021,PRCIENS,3)=PRCREF,PRCAR(444.021,PRCIENS,4)=999
|
|---|
| 64 | . S PRCAR(444.021,PRCIENS,5)=PRCEFFDT,PRCAR(444.021,PRCIENS,6)=PRCRCVDT
|
|---|
| 65 | . S PRCAR(444.021,PRCIENS,7)=PRCVCN,PRCAR(444.021,PRCIENS,8)=PRCVCP
|
|---|
| 66 | . S PRCAR(444.021,PRCIENS,9)="Comments submitted with 843 Transaction."
|
|---|
| 67 | . D FILE^DIE("","PRCAR") K PRCAR D:$D(^TMP("DIERR",$J)) ERRCOPY
|
|---|
| 68 | . D WP^DIE(444.021,PRCIENS,10,"","^TMP($J,""TX"")") D:$D(^TMP("DIERR",$J)) ERRCOPY
|
|---|
| 69 | . K ^TMP($J,"TX")
|
|---|
| 70 | . K XMB,XMY S XMB="PRCHQ 864 NORMAL",XMB(1)=$G(PRCRFQ),XMB(2)=$G(PRCDB),XMB(3)=$P($G(PRCIENS),",")
|
|---|
| 71 | . S X=$P($G(^PRC(444,PRC("D0"),0)),U,4) S:X?1.N XMY(X)=""
|
|---|
| 72 | . S XMDUZ="864 Text Message Filer" D ^XMB K XMB,XMDUZ,XMZ
|
|---|
| 73 | I PRCI="" S PRCERR=11 G ERR^PRCHQ6B
|
|---|
| 74 | S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0)) I $P(PRCX,U)'="IT" S PRCERR=11 G ERR^PRCHQ6B
|
|---|
| 75 | S PRCITEMS=0
|
|---|
| 76 | G ITEM^PRCHQ6B
|
|---|
| 77 | DELTNONE ;Delete Socioeconomic Group 'OO - None of the Above'
|
|---|
| 78 | N DA,DIK S DA(1)=PRCVDA,DA=$O(^PRC(444.1,DA(1),4,"B",161,"")) Q:DA=""
|
|---|
| 79 | S DIK="^PRC(444.1,DA(1),4," D ^DIK
|
|---|
| 80 | Q
|
|---|
| 81 | ERRCOPY ;Copy error messages to report file
|
|---|
| 82 | N PRCJ,PRCK S PRCK=$G(^TMP($J,"PRCERR")),PRCJ=0
|
|---|
| 83 | F S PRCJ=$O(^TMP("DIERR",$J,PRCJ)) Q:PRCJ'?1.N D
|
|---|
| 84 | . I $D(^TMP("DIERR",$J,PRCJ,"TEXT",1)) D
|
|---|
| 85 | . . S PRCK=PRCK+1,^TMP($J,"PRCERR",PRCK)=^TMP("DIERR",$J,PRCJ,"TEXT",1)
|
|---|
| 86 | . . 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")
|
|---|
| 87 | S:PRCK>0 ^TMP($J,"PRCERR")=PRCK
|
|---|
| 88 | K ^TMP("DIERR",$J)
|
|---|
| 89 | Q
|
|---|
