source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ15.m@ 846

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

initial load of WorldVistAEHR
File size: 6.9 KB
Line 
1PRCHQ15 ;(WASH IRMFO)/LKG-Create Initial #442 entry from 2237 ;9/30/96 14:59
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4POBLD(PRCHSY,PRCRFQDA,PRCQUOTE,PRCFOB) ;Given 2237 IEN build its PO
5 N PRC410,PRCCOUNT,PRC,DIE,DR,PRCDSCNT,PRCHPO,PRCHSP,PRCHSX,PRCI,PRCIEN
6 N PRCLN,PRCX,PRCY,PRCZ,X,Y,PRCDA410,PRCHHM,PRCHPONO,PRCCOST,PRCH,PRCHN,PRCHS
7 N PRCHCC,PRCHITM,PRCHZ,PRCHZ1,PRCHZ2,PRCHZ3
8 G:'$D(^PRCS(410,PRCHSY)) EX
9 S PRC410(0)=$G(^PRCS(410,PRCHSY,0)) G:PRC410(0)="" EX
10 S PRC("SITE")=$P(PRC410(0),U,5)
11 I '$D(PRC("PER")) D
12 . I $D(DUZ)#2,+DUZ>0 S PRC("PER")=+DUZ
13 . S X=$S('$D(^VA(200,+PRC("PER"),20)):"",1:^VA(200,+PRC("PER"),20))
14 . S $P(PRC("PER"),U,2,4)=$P(X,U,2)_U_$P(X,U,3)_U_$S($D(^VA(200,+PRC("PER"),.13)):$P(^(.13),U,2),1:"")
15 S:PRC("SITE")]"" PRC("PARAM")=$G(^PRC(411,PRC("SITE"),0))
16 S PRCHSX=$P(PRC410(0),U),PRC("FY")=$P(PRCHSX,"-",2),PRC("QTR")=$P(PRCHSX,"-",3)
17 S PRCI=0
18GETNUM D ENPO^PRCHUTL
19 I '$D(PRCHPO) D G GETNUM:Y=1,EX
20 . N DIR S DIR(0)="YA",DIR("A")="No PO Number was entered, do you want to try again? "
21 . S DIR("B")="YES",DIR("?")="Answer 'YES' to return to prompt for PO Number"
22 . D ^DIR
23 S PRCI=PRCI+1
24 L +^PRC(442,DA):5 E W !,"Another user is editing this entry!" K DA G:PRCI<10 GETNUM W !,"Lock Table Problem - Please contact IRM!" S PRCHPO="" G EX
25 S DIE=442,DA=PRCHPO,DR="42///^S X=$P(^PRC(444,PRCRFQDA,0),U)"
26 N PONUM S PONUM=$P($P($G(^PRC(442,PRCHPO,0)),"^"),"-",2)
27 D ^DIE
28 ;If an order is Certified then INV Address should be FISCAL,
29 ;otherwise it will be FMS. <<<< nois DUB-0597-31814 <<<<
30 I $E(PONUM,1)'="C" D
31 . S DR=".02////1;.08////N;.04///FMS;.1///TODAY" D ^DIE
32 . Q
33 I $E(PONUM,1)="C" D
34 . S DR=".02////2;.08////N;.04///FISCAL;.1///TODAY" D ^DIE
35 . Q
36 S PRCY=$P(PRC410(0),U,10) I PRCY]"" S DR="31////^S X=PRCY" D ^DIE
37 S PRCY=$P($G(^PRCS(410,PRCHSY,3)),U,4) I PRCY]"" S DR="5////^S X=PRCY" D ^DIE
38 S X=$P(^PRCS(410,PRCHSY,3),U),$P(^PRC(442,PRCHPO,0),U,3)=X,^PRC(442,"E",$P(X," "),PRCHPO)="",PRC("CP")=X
39 S PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
40 S PRC("APP")=$P($$ACC^PRC0C(PRC("SITE"),+PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY")),U,11)
41 S $P(^PRC(442,PRCHPO,0),U,4)=PRC("APP")
42 S PRCY=$P($G(^PRC(420,PRC("SITE"),1,$P(PRCHSX,"-",4),0)),U,12)
43 I PRCY]"" S DR=".03////^S X=PRCY" D ^DIE
44 S PRCHN("MP")=$S($D(^PRCD(442.5,+$P(^PRC(442,DA,0),U,2),0)):$P(^(0),U,3),1:"")
45 S PRCHN("SFC")=+$P(^PRC(442,DA,0),U,19)
46 D EN2^PRCHNPO3
47 S PRCY=$P($G(^PRCS(410,PRCHSY,3)),U,3) I PRCY]"" S DR="2///^S X=PRCY" D ^DIE
48 S PRCY=$P($G(^PRCS(410,PRCHSY,3)),U,5) I PRCY]"" S DR="5.2////^S X=PRCY" D ^DIE
49 S PRCY=$P($G(^PRC(444,PRCRFQDA,1)),U,3) I PRCY]"" S DR="5.4////^S X=PRCY" D ^DIE
50 S PRCY=$P($G(^PRCS(410,PRCHSY,9)),U) I PRCY]"" S DR="5.6///^S X=PRCY" D ^DIE
51 S DR="6.4////^S X=PRCFOB" D ^DIE
52 S PRCY=$P($G(^PRCS(410,PRCHSY,1)),U,4) I PRCY]"" S DR="7////^S X=PRCY" D ^DIE
53 S PRCY=$P($G(^PRCS(410,PRCHSY,9)),U,4) I PRCY>0 S $P(^PRC(442,PRCHPO,0),U,13)=PRCY
54 S DR="16////^S X=DUZ" D ^DIE
55 S DR="26///^S X=PRC(""BBFY"")" D ^DIE
56 S PRCHSY(0)=^PRC(443,PRCHSY,0)
57 S PRCHS="" D ^PRCHSP1
58 S PRCHSP="",PRCH="",PRCDA410=PRCHSY D LST1^PRCHNPO2 S PRCHSY=PRCDA410 K PRCHSY(0)
59 S PRCX=0,PRCCOUNT=0
60 F S PRCX=$O(^PRC(442,PRCHPO,2,PRCX)) Q:+PRCX'=PRCX S PRCCOUNT=PRCCOUNT+1
61 S PRCIEN=0
62 F S PRCIEN=$O(^PRCS(410,PRCHSY,"IT",PRCIEN)) Q:+PRCIEN'=PRCIEN D
63 . S PRCZ=^PRCS(410,PRCHSY,"IT",PRCIEN,0)
64 . S PRCX=$P(PRCZ,U,3) S:PRCX]"" $P(^PRC(442,PRCHPO,2,PRCIEN,0),U,3)=PRCX
65 . S PRCX=$P(PRCZ,U,6) S:PRCX]"" $P(^PRC(442,PRCHPO,2,PRCIEN,0),U,6)=PRCX
66 . I $P($G(^PRCS(410,PRCHSY,"IT",PRCIEN,1,0)),U,4)>0 D
67 . . N IENS S IENS=PRCIEN_","_PRCHPO_"," K ^TMP("DIERR",$J)
68 . . D WP^DIE(442.01,IENS,1,"","^PRCS(410,PRCHSY,""IT"",PRCIEN,1)")
69 . . K ^TMP("DIERR",$J)
70 . S PRCX=0
71 . F S PRCX=$O(^PRC(444,"AE",PRCHSY,PRCRFQDA,PRCX)) Q:PRCX="" Q:$P($G(^PRC(444,PRCRFQDA,2,PRCX,3)),U,7)=PRCIEN
72 . Q:PRCX=""
73 . S PRCLN=$P($G(^PRC(444,PRCRFQDA,2,PRCX,0)),U)
74 . S PRCY=$O(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,"B",PRCLN,"")) Q:PRCY=""
75 . S $P(^PRC(442,PRCHPO,2,PRCIEN,2),U,14)=$P($G(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,PRCY,0)),U,11)
76 . S $P(^PRC(442,PRCHPO,2,PRCIEN,4),U,17)=$P($G(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,PRCY,1)),U)
77 . S $P(^PRC(442,PRCHPO,2,PRCIEN,4),U,18)=$P($G(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,PRCY,1)),U,2)
78 . S:$P($G(^PRC(442,PRCHPO,2,PRCIEN,0)),U,13)="" $P(^PRC(442,PRCHPO,2,PRCIEN,0),U,13)=$P($G(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,PRCY,0)),U,6)
79 . S:$P($G(^PRC(442,PRCHPO,2,PRCIEN,2)),U,3)="" $P(^PRC(442,PRCHPO,2,PRCIEN,2),U,3)=$P($G(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,PRCY,0)),U,5)
80 . S X=$P($G(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,PRCY,1)),U,6)
81 . S:X="" X=$P($G(^PRC(444,PRCRFQDA,8,PRCQUOTE,0)),U,7)
82 . I X]"" D
83 . . S Y=$P($G(^PRC(442,PRCHPO,1)),U) I Y="" K X Q
84 . . I '$D(^PRC(440,Y,4,"B",$E(X,1,30))) K X Q
85 . . S $P(^PRC(442,PRCHPO,2,PRCIEN,2),U,2)=X
86 . . S ^PRC(442,PRCHPO,2,"AC",$E(X,1,30),PRCIEN)=""
87 . S PRCCOST=$P($G(^PRC(444,PRCRFQDA,8,PRCQUOTE,3,PRCY,1)),U,3,5)
88 . S PRCDSCNT=$P(PRCCOST,U,2,3),PRCCOST=$FN($P(PRCCOST,U),"",4)
89 . S $P(^PRC(442,PRCHPO,2,PRCIEN,0),U,9)=PRCCOST
90 . S $P(^PRC(442,PRCHPO,2,PRCIEN,2),U)=$FN(PRCCOST*$P(^PRC(442,PRCHPO,2,PRCIEN,0),U,2),"",4)
91 . I $P(PRCDSCNT,U)'>0,$P(PRCDSCNT,U,2)'>0 Q
92 . K DA,DIC,DD,DO S DA(1)=PRCHPO,DIC="^PRC(442,DA(1),3,",X=PRCIEN,DIC(0)="LX"
93 . S DLAYGO=442.03,DIC("P")=$P(^DD(442,14,0),U,2) D FILE^DICN K DIC,DLAYGO
94 . Q:+Y<1 S DA=+Y
95 . S PRCX=$S($P(PRCDSCNT,U)>0:$P(PRCDSCNT,U),1:"$"_$P(PRCDSCNT,U,2))
96 . S DIE="^PRC(442,DA(1),3,",DR="1////^S X=PRCX" D ^DIE
97 . S PRCZ=$G(^PRCS(410,PRCHSY,"IT",PRCIEN,0))
98 . S PRCX=$S($P(PRCDSCNT,U)>0:PRCDSCNT/100*$P(PRCZ,U,2)*$P(PRCZ,U,7),1:$P(PRCDSCNT,U,2))
99 . S PRCX=$FN(PRCX,"",2),$P(^PRC(442,PRCHPO,2,PRCIEN,2),U,6)=PRCX
100 . S DR="2///^S X=PRCX;3///1" D ^DIE
101 . S PRCCOUNT=PRCCOUNT+1,DR="5///^S X=PRCCOUNT" D ^DIE
102 S PRCCOUNT=PRCCOUNT+1
103 K DA,DIE S DIE=442,DA=PRCHPO,DR="15///^S X=PRCCOUNT" D ^DIE
104 S PRCX=0
105 F S PRCX=$O(^PRC(444,PRCRFQDA,8,PRCQUOTE,2,PRCX)) Q:+PRCX'=PRCX D
106 . S PRCY=$G(^PRC(444,PRCRFQDA,8,PRCQUOTE,2,PRCX,0)) Q:PRCY=""
107 . S X=$P(PRCY,U)
108 . K DA,DIC S DA(1)=PRCHPO,DIC="^PRC(442,DA(1),5,",DIC(0)="LX"
109 . S DIC("P")=$P(^DD(442,9.2,0),U,2),DLAYGO=442.06 D ^DIC K DIC,DLAYGO
110 . Q:+Y<1
111 . S DA=+Y,DIE="^PRC(442,DA(1),5,",PRCY=$P(PRCY,U,2)
112 . S DR="1///^S X=PRCY" D ^DIE
113 S PRCX=0,PRCY=0
114 F S PRCX=$O(^PRC(442,PRCHPO,2,PRCX)) Q:+PRCX'=PRCX D
115 . S PRCZ=$G(^PRC(442,PRCHPO,2,PRCX,2)) Q:PRCZ=""
116 . S PRCY=$P(PRCZ,U)-$P(PRCZ,U,6)+PRCY
117 S ^PRC(442,PRCHPO,9,0)="^"_$P(^DD(442,35,0),U,2)_"^1^1"
118 S PRCY=$FN(PRCY,"",2)
119 S $P(^PRC(442,PRCHPO,9,1,0),U)=PRCY,$P(^PRC(442,PRCHPO,0),U,15)=PRCY
120 S $P(^PRC(442,PRCHPO,1),U,8)=$P(^PRC(444,PRCRFQDA,8,PRCQUOTE,0),U,2)
121 I PRCFOB="O" W !!,"As FOB is Origin, you will now be prompted for the Shipping BOC.",! S DIE=442,DA=PRCHPO,DR="13.05R" D ^DIE
122 S PRCX=$P(^PRC(442,PRCHPO,1),U)
123 I PRCX'="",$P($G(^PRC(440,PRCX,3)),U,2)="Y" D
124 . W !,"As this PO has an EDI Vendor, you will be asked about Special Handling."
125 . S DIE=442,DR="18.6//NO;S:X'=""Y"" Y=0;18.7",DA=PRCHPO
126 . D ^DIE K DIE,DR
127EX L:$G(PRCHPO)>0 -^PRC(442,PRCHPO)
128 Q $S($G(PRCHPO)>0:$P($G(^PRC(442,PRCHPO,0)),U),1:"")
Note: See TracBrowser for help on using the repository browser.