90 lines
4.5 KiB
Mathematica
90 lines
4.5 KiB
Mathematica
|
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
|