source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ41B.m@ 810

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

initial load of WorldVistAEHR
File size: 4.0 KB
Line 
1PRCHQ41B ;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
5IN 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")
71EX QUIT XDA
72 ;
73VENDOR ; 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
85VCR S:$P(^PRCS(410,XDA,2),"^")'="" ^PRCS(410,"E",$E($P(^PRCS(410,XDA,2),"^"),1,30),XDA)=""
86 QUIT
87 ;
Note: See TracBrowser for help on using the repository browser.