1 | PRCHQ41B ;WISC/KMB-CREATE 2237 FOR RFQ ;10/21/96 11:07
|
---|
2 | ;;5.1;IFCAP;;Oct 20, 2000
|
---|
3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
---|
4 | Q
|
---|
5 | IN D VENDOR
|
---|
6 | S X=$P($G(^PRC(444,SDA,0)),U,9),X=$S(X>0:$P($G(^PRCS(410,X,7)),U,3),1:0)
|
---|
7 | S DA=XDA,MESSAGE="" D ENCODE^PRCSC1(DA,X,.MESSAGE) K MESSAGE
|
---|
8 | S X=+$P($G(^PRCS(410,XDA,4)),U) D TRANS^PRCSES
|
---|
9 | K DA S PRCSSCP=0,DA=XDA
|
---|
10 | F PRCSSI=1:1 S PRCSSCP=$O(^PRCS(410,DA,12,PRCSSCP)) Q:PRCSSCP'>0 D
|
---|
11 | . Q:'$D(^PRCS(410,DA,12,PRCSSCP,0)) S X=$P(^(0),U,2) Q:X'>0
|
---|
12 | . S DA(1)=DA,DA=PRCSSCP D TRANS^PRCSEZZ
|
---|
13 | . S DA=DA(1)
|
---|
14 | S PRCSCP=$S($D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)):$P(^(0),U,12),1:"")
|
---|
15 | S X=$P(^PRCS(410,XDA,0),U),DIC="^PRC(443,",DIC(0)="L",DLAYGO=443
|
---|
16 | D ^DIC K DIC,DLAYGO,X S DA=+Y
|
---|
17 | L +^PRC(443,DA):15 E W !,"*** Unable to lock REQUEST WORKSHEET File entry!" L -^PRCS(410,XDA) G EX
|
---|
18 | S X=$G(^VA(200,DUZ,20))
|
---|
19 | S PRC("PER")=DUZ_U_$P(X,U,2)_U_$P(X,U,3)_U_$S($D(^VA(200,DUZ,.13)):$P(^(.13),U,2),1:"")
|
---|
20 | S DIE=443
|
---|
21 | S PRCX=$G(^PRC(443,PRC410DA,0))
|
---|
22 | S PRCY=$P(PRCX,U,9) I PRCY]"" S DR="9////^S X=PRCY" D ^DIE
|
---|
23 | S PRCY=$P(PRCX,U,10) I PRCY]"" S DR="10////^S X=PRCY" D ^DIE
|
---|
24 | S PRCY=$P(^PRCS(410,DA,0),U,6) I PRCY]"" S DR="11////^S X=PRCY" D ^DIE
|
---|
25 | S PRCY=$P(PRCX,U,12) I PRCY]"" S DR="13////^S X=PRCY" D ^DIE
|
---|
26 | S DR="1.5///70;2////^S X=+PRC(""PER"")" D ^DIE
|
---|
27 | K DIE,DR
|
---|
28 | D
|
---|
29 | . N PRCHG,P,PRCSIG,ROUTINE
|
---|
30 | . D ES1^PRCHG
|
---|
31 | L -^PRC(443,DA)
|
---|
32 | S DA=XDA D EN2^PRCPWI
|
---|
33 | ;
|
---|
34 | S PRCY=0
|
---|
35 | F S PRCY=$O(^TMP($J,"PRCHQ410",PRCY)) Q:PRCY="" D
|
---|
36 | . S DA(1)=PRCY L +^PRCS(410,DA(1)):15 E W !,"Unable to Lock Source 2237" Q
|
---|
37 | . S:'$D(^PRCS(410,PRCY,"CO",0)) ^(0)="^^^^"_DT
|
---|
38 | . S PRCV=$P(^PRCS(410,PRCY,"CO",0),U,3,4),PRCU=PRCV+1,PRCV=$P(PRCV,U,2)+1
|
---|
39 | . S ^PRCS(410,PRCY,"CO",PRCU,0)=" During RFQ Award, this request has been split with the following"
|
---|
40 | . S PRCU=PRCU+1,PRCV=PRCV+1,^PRCS(410,PRCY,"CO",PRCU,0)="items transfered to 2237 # "_$P($G(^PRCS(410,XDA,0)),U)_":"
|
---|
41 | . S PRCINV=$P($G(^PRCS(410,DA(1),0)),U,6),PRCZ=0,PRCTOT=0
|
---|
42 | . F S PRCZ=$O(^TMP($J,"PRCHQ410",PRCY,PRCZ)) Q:PRCZ="" D
|
---|
43 | . . K ^PRCS(410,DA(1),"IT","AB",PRCZ)
|
---|
44 | . . S DA=$O(^PRCS(410,DA(1),"IT","B",PRCZ,"")) Q:DA=""
|
---|
45 | . . S PRCW=$G(^PRCS(410,DA(1),"IT",DA,0)) Q:PRCW=""
|
---|
46 | . . S PRCTOT=$P(PRCW,U,2)*$P(PRCW,U,7)+PRCTOT
|
---|
47 | . . S $P(^PRCS(410,DA(1),"IT",DA,0),U,7)=0
|
---|
48 | . . S:$L(^PRCS(410,PRCY,"CO",PRCU,0))>72 PRCU=PRCU+1,PRCV=PRCV+1
|
---|
49 | . . S ^(0)=$G(^PRCS(410,PRCY,"CO",PRCU,0))_" "_PRCZ_","
|
---|
50 | . . S PRCITM=+$P(PRCW,U,5) D:$G(PRCINV)'="" KILLTRAN^PRCPUTRA(PRCINV,PRCITM,DA(1))
|
---|
51 | . S:'$D(^PRCS(410,DA(1),"IT","AB")) PRCTOT=PRCTOT+$P($G(^PRCS(410,DA(1),9)),U,4)
|
---|
52 | . S X=PRCTOT D TRANK^PRCSES
|
---|
53 | . S DA(1)=PRCY,PRCZ=$G(^PRCS(410,DA(1),4)),$P(PRCZ,U)=$P(PRCZ,U)-PRCTOT
|
---|
54 | . S:$P(PRCZ,U)<0 $P(PRCZ,U)=0 S $P(PRCZ,U,8)=$P(PRCZ,U,8)-PRCTOT S:$P(PRCZ,U,8)<0 $P(PRCZ,U,8)=0
|
---|
55 | . S ^PRCS(410,DA(1),4)=PRCZ
|
---|
56 | . I '$D(^PRCS(410,DA(1),"IT","AB")) D
|
---|
57 | . . S DA=0
|
---|
58 | . . F S DA=$O(^PRCS(410,DA(1),12,DA)) Q:+DA'=DA D
|
---|
59 | . . . S X=$P($G(^PRCS(410,DA(1),12,DA,0)),U,2) Q:X'>0
|
---|
60 | . . . D TRANK^PRCSEZZ
|
---|
61 | . I '$D(^PRCS(410,PRCY,"IT","AB")),$D(^PRC(443,PRCY,0)) D
|
---|
62 | . . K DA S DA=PRCY,DIK="^PRC(443," D ^DIK K DIK
|
---|
63 | . . S $P(^PRCS(410,PRCY,0),U,12)="O"
|
---|
64 | . S $P(^PRCS(410,PRCY,"CO",0),U,3,4)=PRCU_U_PRCV
|
---|
65 | . S ^(0)=$E(^PRCS(410,PRCY,"CO",PRCU,0),1,$L(^PRCS(410,PRCY,"CO",PRCU,0))-1)
|
---|
66 | . S DA=PRCY,PRCZ="",PRCX=$P($G(^PRCS(410,DA,7)),U,3) S:PRCX<1 PRCX=DUZ
|
---|
67 | . D REMOVE^PRCSC1(DA),ENCODE^PRCSC1(DA,PRCX,.PRCZ) K PRCZ
|
---|
68 | . L -^PRCS(410,PRCY)
|
---|
69 | L -^PRCS(410,XDA)
|
---|
70 | K ^TMP($J,"PRCHQ410")
|
---|
71 | EX QUIT XDA
|
---|
72 | ;
|
---|
73 | VENDOR ; determine vendor, put vendor data on 410 record
|
---|
74 | S V=$P($G(^PRC(444,SDA,8,QUOTE,0)),"^") Q:V=""
|
---|
75 | S VP=$P(V,";"),VF=$P(V,";",2),VF=$P($P(VF,","),"(",2)
|
---|
76 | Q:$G(^PRC(VF,VP,0))=""
|
---|
77 | I VF=444.1 D
|
---|
78 | . S PRCY=$P(^PRC(VF,VP,0),U,9) Q:PRCY=""
|
---|
79 | . Q:'$D(^PRC(440,PRCY))
|
---|
80 | . S VF=440,VP=PRCY
|
---|
81 | I VF=440 S ^PRCS(410,XDA,2)=$P(^PRC(440,VP,0),"^",1,10),$P(^PRCS(410,XDA,3),"^",4)=VP G VCR
|
---|
82 | S V=$P($G(^PRC(VF,VP,0)),"^")_"^"_$P($G(^PRC(VF,VP,1)),"^",1,7)
|
---|
83 | S $P(V,"^",9,10)=$P($G(^PRC(VF,VP,0)),"^",3)_"^"_$P($G(^(0)),"^",6)
|
---|
84 | S ^PRCS(410,XDA,2)=V
|
---|
85 | VCR S:$P(^PRCS(410,XDA,2),"^")'="" ^PRCS(410,"E",$E($P(^PRCS(410,XDA,2),"^"),1,30),XDA)=""
|
---|
86 | QUIT
|
---|
87 | ;
|
---|