source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ410.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 5.7 KB
Line 
1PRCHQ410 ;WISC/KMB-CREATE 2237 FOR RFQ ;8/6/96 20:54
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;;Extrinsic function $$REQUEST^PRCHQ410(SDA,QUOTE,ITEMARR)
5 ;;Builds 2237 from winning quote during award
6 ;;Returns resulting 2237's internal entry # if exits normally; 0 if premature
7 ;;SDA - RFQ internal entry number
8 ;;QUOTE - Quote's internal entry number
9 ;;ITEMARR - Closed Global Root of Index for items assigned to Quote
10 ;; i.e. "^TMP($J,"RFQ",QUOTE,FOB_CODE)" where the descendents are
11 ;; ^TMP($J,"RFQ",QUOTE,FOB_CODE,RFQ_LINE_NBR_OF_ITEM)
12REQUEST(SDA,QUOTE,ITEMARR) ; create 2237 from RFQ
13 N CP,CTR,DA,DIC,DIE,DLAYGO,DR,STA,V,VF,VP,X,X1,XDA,Y,Z,ZP,TDATE,CDATE,TOTAL,MESSAGE
14 N PRC,PRCDA,PRCDRN,PRCSDA,PRC410DA,PRCQ,PRCU,PRCV,PRCW,PRCX,PRCY,PRCZ
15 N PRCCOUNT,PRCIENS,PRCINV,PRCITM,PRCNODE,PRCSCP,PRCSSCP,PRCSSI,PRCTOT
16 N PRCXND,PRCX1,PRCO2237
17 K ^TMP($J,"PRCHQ410") S XDA=0
18 G:'$D(SDA) EX
19 ;
20 S PRCX=0
21 F S PRCX=$O(@ITEMARR@(PRCX)) Q:PRCX="" I $D(^PRC(444,SDA,2,PRCX,3)),$P(^(3),U,6)="" Q
22 G:PRCX="" EX
23 S PRC410DA=$P($G(^PRC(444,SDA,0)),"^",9)
24 S (STA,PRC("SITE"))=$P(^PRC(444,SDA,0),"-"),PRC("SST")=$P($G(^(0)),"^",10)
25 S CP=$P(^PRC(444,SDA,0),U,14),PRC("CP")=$P($G(^PRC(420,STA,1,+CP,0)),"^")
26 G:PRC("CP")="" EX
27 D NOW^%DTC S PRC("FY")=$E(100+$E(X,2,3)+$S($E(X,4,5)>9:1,1:0),2,3)
28 S PRC("QTR")=$P("2^2^2^3^3^3^4^4^4^1^1^1","^",+$E(X,4,5))
29 S (Y,TDATE)=X D DD^%DT S CDATE=Y
30 ;
31 ;
32 S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
33 S PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
34 S X=$P(Z,"-",1,2)_"-"_$P(PRC("CP")," ")
35 D EN1^PRCSUT3 G:$G(X)']"" EX S (PRCX1,X1)=X D EN2^PRCSUT3 G:'$D(X1) EX S XDA=DA
36 L +^PRCS(410,DA):30 E W !,"Unable to lock 2237 entry" S XDA=0 G EX
37 S PRCXND=0,PRCCOUNT=0,TOTAL=+$P($G(^PRC(444,SDA,8,QUOTE,1)),U,2)
38 F S PRCXND=$O(@ITEMARR@(PRCXND)) Q:PRCXND="" D
39 . Q:$P($G(^PRC(444,SDA,2,PRCXND,3)),U,6)]""
40 . S PRCCOUNT=PRCCOUNT+1,X=$P(^PRC(444,SDA,2,PRCXND,0),U)
41 . S PRCDA=$O(^PRC(444,SDA,8,QUOTE,3,"B",X,"")) Q:PRCDA=""
42 . S PRCQ(0)=$G(^PRC(444,SDA,8,QUOTE,3,PRCDA,0)),PRCQ(1)=$G(^PRC(444,SDA,8,QUOTE,3,PRCDA,1))
43 . S:$G(PRCO2237)="" PRCO2237=$P($G(^PRC(444,SDA,2,PRCXND,3)),U)
44 . K DA,DIC S DA(1)=XDA,DIC="^PRCS(410,DA(1),""IT"",",DIC(0)="LX",DLAYGO=410.02
45 . S DIC("P")=$P(^DD(410,10,0),U,2),X=PRCCOUNT D ^DIC K DIC,DLAYGO
46 . Q:+Y<1 S PRCSDA=+Y
47 . S $P(^PRC(444,SDA,2,PRCXND,3),U,6,7)=XDA_U_PRCCOUNT
48 . S ^PRC(444,"AE",XDA,SDA,PRCXND)=""
49 . S PRCY=$G(^PRC(444,SDA,2,PRCXND,3)) S:PRCY>0 PRCZ=$P(PRCY,U,2)
50 . I PRCY>0,PRCZ>0 S ^TMP($J,"PRCHQ410",+PRCY,PRCZ)=""
51 . S DA=PRCSDA,DIE="^PRCS(410,DA(1),""IT"","
52 . S $P(^PRCS(410,XDA,"IT",DA,0),U,2)=$P(PRCQ(0),U,2)
53 . S DR="3////^S X=$P(PRCQ(0),U,3)" D ^DIE
54 . S PRCY=$P($G(^PRC(444,SDA,2,PRCXND,1)),U,8) I PRCY]"" S DR="4////^S X=$P($G(^PRCD(420.2,PRCY,0)),U)" D ^DIE
55 . S PRCY=$P($G(^PRC(444,SDA,2,PRCXND,0)),U,4) I PRCY]"" S DR="5///^S X=PRCY" D ^DIE
56 . S PRCY=$P(PRCQ(0),U,4) S:PRCY="" PRCY=$P(PRCQ(0),U,9) S:PRCY="" PRCY=$P(PRCQ(0),U,6)
57 . I PRCY]"" S DR="6///^S X=PRCY" D ^DIE
58 . S $P(^PRCS(410,XDA,"IT",DA,0),U,7)=$P(PRCQ(1),U,3)
59 . S TOTAL=$P(PRCQ(0),U,2)*$P(PRCQ(1),U,3)+TOTAL
60 . S PRCNODE=$S($P($G(^PRC(444,SDA,8,QUOTE,3,PRCDA,2,0)),U,4)>0:"^PRC(444,SDA,8,QUOTE,3,PRCDA,2)",1:"^PRC(444,SDA,2,PRCXND,2)")
61 . K ^TMP("DIERR",$J) S PRCIENS=PRCSDA_","_XDA_","
62 . D WP^DIE(410.02,PRCIENS,1,"",PRCNODE) K ^TMP("DIERR",$J)
63 . S ZP=0
64 . F S ZP=$O(^PRC(444,SDA,8,QUOTE,3,PRCDA,3,ZP)) Q:+ZP'=ZP D
65 . . S PRCY=$G(^PRC(444,SDA,8,QUOTE,3,PRCDA,3,ZP,0))
66 . . S CTR=$P(PRCY,U),X=PRCX1_"-"_PRCCOUNT_"-"_CTR K DIC
67 . . S DIC=410.6,DIC(0)="LX",DLAYGO=410.6 D ^DIC K DIC,DLAYGO
68 . . I +Y<1 W !,"Unable to add Delivery Schedule Entry" Q
69 . . S DA=+Y
70 . . L +^PRCS(410.6,DA):30 E W !,"Unable to lock Delivery Schedule Entry" Q
71 . . S DIE=410.6,DR="1////^S X=$P(PRCY,U,2);3////^S X=$P(PRCY,U,3)"
72 . . D ^DIE
73 . . S PRCY=$G(^PRC(444,SDA,2,PRCXND,4,CTR,0))
74 . . S:PRCY="" PRCY=$G(^PRC(444,SDA,2,PRCXND,4,1,0))
75 . . I PRCY]"" S DR="2////^S X=$P(PRCY,U,4);4////^S X=$P(PRCY,U,5)" D ^DIE
76 . . K DR,DIE L -^PRCS(410.6,DA)
77 . . S PRCDRN=DA K DA,DIC
78 . . S DA(2)=XDA,DA(1)=PRCSDA,DIC="^PRCS(410,DA(2),""IT"",DA(1),2,",DIC(0)="LX"
79 . . S DIC("P")=$P(^DD(410.02,12,0),U,2),X=CTR D ^DIC Q:+Y<1 S DA=+Y
80 . . S DIE=DIC K DIC S DR="1////^S X=PRCDRN" D ^DIE K DIE,DR,DA
81 K DA S DA=XDA
82 S DIE=410,DR="448////^S X=$P($G(^PRC(444,SDA,0)),U,10)" D ^DIE
83 S DR=".5///^S X=$P($P($G(^PRC(444,SDA,0)),U),""-"")" D ^DIE
84 S DR="1////O;3////4" D ^DIE
85 S PRCY=$P($G(^PRCS(410,PRC410DA,0)),U,6) I PRCY]"" S DR="4////^S X=PRCY" D ^DIE
86 S DR="5////^S X=$P(^PRCS(410,PRC410DA,1),U)" D ^DIE
87 S DR="6.3////^S X=$P($G(^PRC(444,SDA,0)),U,11)" D ^DIE
88 S DR="7.5////^S X=$P($G(^PRC(444,SDA,0)),U,6)" D ^DIE
89 S DR="7////^S X=$P($G(^PRC(444,SDA,1)),U,2)" D ^DIE
90 S $P(^PRCS(410,XDA,4),U)=TOTAL,$P(^PRCS(410,XDA,4),U,8)=TOTAL
91 S DR="21////^S X=TDATE" D ^DIE
92 S DR="15.5///^S X=$P($G(^PRCS(410,PRC410DA,3)),U,3)" D ^DIE
93 I PRCFOB="O" S X=$P($G(^PRC(444,SDA,8,QUOTE,1)),U,2) I X>0 S DR="48.1///"_X D ^DIE
94 S DR="50///^S X=PRCCOUNT" D ^DIE
95 S PRCY=$P($G(^PRCS(410,PRC410DA,7)),U) I PRCY]"" S DR="40////^S X=PRCY" D ^DIE
96 S PRCY=$P($G(^PRC(444,SDA,1)),U,4) I PRCY]"" S DR="46///^S X=PRCY" D ^DIE
97 S DR="56///60" D ^DIE
98 S:PRCO2237]"" PRCO2237=$S($D(^PRCS(410,PRCO2237,0)):$P(^(0),U),1:"")
99 I PRCO2237]"" S DR="51///^S X=PRCO2237" D ^DIE
100 K DIE,DR
101 S ^PRCS(410,XDA,"CO",0)="^^1^1^"_TDATE
102 S ^PRCS(410,XDA,"CO",1,0)="This 2237 is derived from RFQ #"_$P($G(^PRC(444,SDA,0)),U)
103 D ERS410^PRC0G(DA_"^A")
104 K ^TMP("DIERR",$J) S PRCIENS=XDA_","
105 D:$D(^PRC(444,SDA,3)) WP^DIE(410,PRCIENS,9,"","^PRC(444,SDA,3)")
106 K ^TMP("DIERR",$J) S PRCIENS=XDA_","
107 D:$D(^PRCS(410,PRC410DA,8)) WP^DIE(410,PRCIENS,45,"","^PRCS(410,PRC410DA,8)")
108 K ^TMP("DIERR",$J)
109 G IN^PRCHQ41B
110EX Q XDA
Note: See TracBrowser for help on using the repository browser.