source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ6A.m@ 1093

Last change on this file since 1093 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.5 KB
Line 
1PRCHQ6A ;(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
5A 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
77DELTNONE ;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
81ERRCOPY ;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
Note: See TracBrowser for help on using the repository browser.