source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO7.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: 8.8 KB
RevLine 
[613]1PRCHNPO7 ;WISC/RHD-MISCELLANEOUS ROUTINES FROM P.O.ADD/EDIT 442 ; 7/27/05 10:16am
2V ;;5.1;IFCAP;**79,100**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EN1 ;INPUT TRANSFORM-FILE 442, NSN #9.5
6 I '$D(^PRC(441.2,+X,0)) W !!,$C(7),"Invalid NSN--first 4 characters must be FSC code!!" K X Q
7 S PRCHCI=+$P(^PRC(442,DA(1),2,DA,0),U,5)
8 S Z=$O(^PRC(441,"BB",X,0)) S:Z=PRCHCI Z=$O(^(Z)) I Z W !!,$C(7),"This NSN has already been assigned to item # "_$O(^(0))_"!!" K X Q
9 I $P(^PRC(441.2,+X,0),U,4)="" W $C(7),!,"Commodity Code missing on this FSC--Required for LOG code sheets!" K X Q
10 S $P(^PRC(442,DA(1),2,DA,2),U,3)=+X
11 Q:$P(^PRC(442,DA(1),2,DA,0),U,5)=""
12 S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(442,DA(1),0) S PRCHCPO=DA(1) D EN5^PRCHCRD
13 S PRCHSAVX=X,X=+X
14 G EN11
15 ;
16EN10 ;UPDATE FEDERAL SUPPLY CLASSIFICATION/PRODUCT SERVICE CODE (FSC/PSC), field #8, file #442.
17 ;PRC*5.1*79: if entering a service item, don't check for commodity code.
18 ;The field title is now called 'FSC/PSC' to hold either a Federal Supply
19 ;Classification (FSC) code or a Product Service Code (PSC) to support a
20 ;new FPDS report for the Austin Automation Center (AAC). The variable
21 ;PRCSAVE is killed in various PO input templates where it is used.
22 ;
23 I '$D(PRCSAVE)&(X'=$P(^PRC(441.2,+X,0),U,1))&($P(^PRC(442,DA(1),2,DA,0),U,5)'="") D EN102 K A,X Q
24 ;
25 I ($P(^PRC(441.2,+X,0),U,4)="")&(X=$P(^PRC(441.2,+X,0),U,1)) D EN104 K A,X Q
26 S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(442,DA(1),0)
27 I $G(PRCSAVE)="G"&(X'=$P(^PRC(441.2,+X,0),U,1)) D EN102 K A,X Q
28 ;
29 I $G(PRCSAVE)="S"&(X=$P(^PRC(441.2,+X,0),U,1))&($P(^PRC(442,DA(1),2,DA,0),U,5)="") D EN103 K A,X Q
30 ;
31EN11 S PRCHCI=+$P(^PRC(442,DA(1),2,DA,0),U,5),PRCHCPO=DA(1) I $D(^PRC(441,+PRCHCI,0)) D EN8^PRCHCRD1
32 S:$D(PRCHSAVX) X=PRCHSAVX K PRCHSAVX
33 Q
34 ;
35EN100 ;Come here for amended orders - check FSC/PSC, field #8, file #443.6.
36 ;PRC*5.1*79: if entering a service item, don't check for commodity code
37 I X=""&($P(^PRC(443.6,DA(1),2,DA,2),U,3)="") D EN^DDIOL("This field is Required!!") S Y="@6" Q
38 I '$D(PRCSAVE)&(X'=$P(^PRC(441.2,+X,0),U,1))&($P(^PRC(443.6,DA(1),2,DA,0),U,5)'="") D EN102 K A,X Q
39 ;
40 I ($P(^PRC(441.2,+X,0),U,4)="")&(X=$P(^PRC(441.2,+X,0),U,1)) D EN104 K A,X Q
41 S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(442,DA(1),0)
42 I $G(PRCSAVE)="G"&(X'=$P(^PRC(441.2,+X,0),U,1)) D EN102 K A,X Q
43 ;
44 I $G(PRCSAVE)="S"&(X=$P(^PRC(441.2,+X,0),U,1))&($P(^PRC(443.6,DA(1),2,DA,0),U,5)="") D EN103 K A,X Q
45 ;
46 S PRCHCI=+$P(^PRC(443.6,DA(1),2,DA,0),U,5),PRCHCPO=DA(1) I $D(^PRC(441,+PRCHCI,0)) D EN8^PRCHCRD1
47 S:$D(PRCHSAVX) X=PRCHSAVX K PRCHSAVX
48 Q
49 ;
50EN101 ;Check Request for Quotations - check FSC/PSC, field #4, file #444.
51 I '$D(PRCSAVE)&($P(^PRC(444,DA(1),2,DA,0),U,4)'="")&(X'=$P(^PRC(441.2,+X,0),U,1)) D EN102 K A,X Q
52 ;
53 I ($P(^PRC(441.2,+X,0),U,4)="")&(X=$P(^PRC(441.2,+X,0),U,1)) D EN104 K A,X Q
54 I $G(PRCSAVE)="G"&(X'=$P(^PRC(441.2,+X,0),U,1)) D EN102 K A,X Q
55 ;
56 I $G(PRCSAVE)="S"&(X=$P(^PRC(441.2,+X,0),U,1)) D EN103 K A,X Q
57 ;
58 S PRCHCI=+$P(^PRC(444,DA(1),2,DA,0),U,5),PRCHCPO=DA(1) I $D(^PRC(441,+PRCHCI,0)) D EN8^PRCHCRD1
59 S:$D(PRCHSAVX) X=PRCHSAVX K PRCHSAVX
60 Q
61 ;
62EN102 ;Stop assignment of a PSC to an item.
63 S A(1)="This is a Product Service Code - Not allowed on ITEMS!!"
64 S A(2,"F")="!"
65 D EN^DDIOL(.A)
66 Q
67 ;
68EN103 ;Stop assignment of an FSC to a service.
69 S A(1)="This is a Federal Supply Classification Code - Not allowed on SERVICES!!"
70 S A(2,"F")="!"
71 D EN^DDIOL(.A)
72 Q
73 ;
74EN104 ;Stop user if commodity code is missing.
75 S A(1)="Commodity Code missing on this Federal Supply Classification--Required for LOG code sheets!"
76 S A(2,"F")="!"
77 D EN^DDIOL(.A)
78 Q
79 ;
80EN105 ;Stop a PO if a line item does not contain an FSC or PSC. This tag is
81 ;called from the routine PRCHNP04. Do not clean up variables here.
82 ;This check is for all POs that may be required by FPDS. PRC*5.1*100.
83 I $P(^PRC(442,PRCHPO,1),U,7)]"" D
84 . S PRCHITM=0 F S PRCHITM=$O(^PRC(442,PRCHPO,2,PRCHITM)) Q:'PRCHITM I $P($G(^PRC(442,PRCHPO,2,PRCHITM,2)),U,3)="" D EN^DDIOL("Line item "_PRCHITM_" on this PO does not contain an FSC or PSC.","","!!?5") S ERROR=1
85 ;End of changes for PRC*5.1*79
86 Q
87 ;
88EN106 ;PRC*5.1*100: stop amended PO with line items lacking an FSC or PSC.
89 I $P(^PRC(443.6,PRCHPO,1),U,7)]"" D
90 . S PRCHITM=0 F S PRCHITM=$O(^PRC(443.6,PRCHPO,2,PRCHITM)) Q:'PRCHITM I $P($G(^PRC(443.6,PRCHPO,2,PRCHITM,2)),U,3)="" D EN^DDIOL("Line item "_PRCHITM_" on this PO does not contain an FSC or PSC.","","!!?5") S ERROR=1
91 Q
92 ;
93EN2 ;IF 'ESTIMATED P.O.' MOVE VERBAGE INTO COMMENTS
94 D EN2A
95 Q:'$D(^PRC(442,PRCHPO,7)) Q:$P(^(7),U,3)'="Y" S WX="*** ESTIMATED PURCHASE ORDER ***" I $D(^PRC(442,PRCHPO,4,1,0)),^(0)[WX K WX Q
96 S WX=WX_" ",PRCH="^PRC(442,PRCHPO,4," D WORD^PRCHUTL K PRCH
97 Q
98 ;
99EN2A ;CHECK DELIVERY SCHEDULES-QUANTITY DELIVERED MUST BE >0
100 N NUM,J,K,DA
101 S NUM=$P(^PRC(442,PRCHPO,0),U)
102 I $D(^PRC(442.8,"AC",NUM)) D
103 . F J=0:0 S J=$O(^PRC(442.8,"AC",NUM,J)) Q:J'>0 D
104 . . F K=0:0 S K=$O(^PRC(442.8,"AC",NUM,J,K)) Q:K'>0 D
105 . . . I $P(^PRC(442.8,K,0),U,5)'>0 S DIK="^PRC(442.8,",DA=K D ^DIK K DIK
106 Q
107EN3 ;COMPLETE DEPOT/GSA PUSH ORDERS
108 S I=$P(^PRC(442,PRCHPO,0),U,15)
109 W !!,"Total Dollar Amount: "_I_" //" R X:DTIME S:'$T X="^" S:X="" X=I I X["^" S X=1 G EN31
110 I X=""!(X=0) G EN30
111 I X["?" W !!,"You can either enter the total dollar amount for the entire PUSH, or just the",!,"dollar amount for this part (regular, subsistence or drugs). This is just",!,"used to update the P.O.register." G EN3
112 S:X["$" X=$P(X,"$",2) I X'?.N.1".".2N!(X>9999999.99)!(X<1) W $C(7),"??" G EN3
113 S $P(^PRC(442,PRCHPO,0),U,15)=X
114 ;
115EN30 S X=1,%A="Complete this Requisition ",%B="This action will change the status to 'Transaction Complete'.",%=1 D ^PRCFYN I %=1 S X=40
116 ;
117EN31 S DA=PRCHPO D ENS^PRCHSTAT
118 Q
119 ;
120EN6 ;FILE 442, SKU #9.4
121 D VEN Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="")
122 S:'$D(PRC("SITE")) PRC("SITE")=$P($P(^PRC(442,DA(1),0),U,1),"-",1) S PRCHCV=$P(^PRC(442,DA(1),1),U,1),PRCHCI=$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN10^PRCHCRD1
123 Q
124 ;
125EN7 ;FILE 442, UNIT CONVERSION FACTOR #9.7
126 D VEN Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="")
127 S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(442,DA(1),0) S PRCHCV=+$P(^PRC(442,DA(1),1),U,1),PRCHCI=+$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN11^PRCHCRD1
128 Q
129 ;
130VEN I $S('$D(^PRC(442,DA(1),1)):1,$P(^(1),U,1)="":1,1:0) W !!,"Vendor must be entered before items ! ",$C(7) K X
131 Q
132 ;
133VENA I $S('$D(^PRC(442,DA,1)):1,$P(^(1),U,1)="":1,1:0) W !!,"Vendor must be entered before items ! ",$C(7) K X
134 Q
135 ;
136VEN1 I $S('$D(^PRC(443.6,DA(1),1)):1,$P(^(1),U,1)="":1,1:0) W !!,"Vendor must be entered before items ! ",$C(7) K X
137 Q
138 ;
139VEN1A I $S('$D(^PRC(443.6,DA,1)):1,$P(^(1),U,1)="":1,1:0) W !!,"Vendor must be entered before items ! ",$C(7) K X
140 Q
141 ;
142 ;
143 ;
144SUPBOC(QUIETLY) ;stmts.to compute pre-implied BOC, moved from template PRCH2138 into this routine and also called in BOC input transform
145 N PRCHIDA,SPFCP,PRCHBOCC,ACCT
146 S:$G(QUIETLY)=-1 X=$P($G(^PRC(442,DA(1),2,DA,0)),U,4)
147 D VEN Q:'$D(X) ""
148 S PRCHIDA=+$P(^PRC(442,DA(1),2,DA,0),U,5),SPFCP=+$P(^PRC(442,DA(1),0),U,19)
149 I SPFCP=2 D
150 . S PRCHN("SFC")=SPFCP,ACCT=$$ACCT^PRCPUX1($E($$NSN^PRCPUX1(PRCHIDA),1,4))
151 . D ;:$D(ACCT)
152 . . S PRCHBOCC=$P($G(^PRCD(420.2,$S(ACCT=1:2697,ACCT=2:2698,ACCT=3:2699,ACCT=6:2699,ACCT=8:2696,1:2699),0)),U)
153 . . I PRCHBOCC S $P(^PRC(442,DA(1),2,DA,0),U,4)=PRCHBOCC D
154 . . . I PRCHBOCC'=X,PRCHBOCC W:'$G(QUIETLY) !,?5,"BOC must be ",PRCHBOCC,!,?5,"For a supply fund order, a BOC ",X," is invalid.",! S X=PRCHBOCC
155 Q X
156 ;
157 ;
158 ;
159EN8 ;FILE 442, ITEM #40; BOC #3.5 -- Z0 must = BOC on entry
160 N DIC D VEN Q:'$D(X)
161 S DIC="^PRCD(420.1,"_Z0_",1,",DIC(0)="QEMZ"
162 I $P(^PRC(442,DA(1),0),U,19)'=2 D
163 . D ^DIC K:Y<0 X K Z0
164 . I $D(X) S X=$P(Y(0,0),"^",1) D
165 . . S PRCHBOC=+Y ;D EN2^PRCHNPO8
166 . . W !,X
167 Q
168 ;
169 ;
170EN88 ;FILE 442, EST. SHIPPING BOC #13.05 -- Z0 must = BOC on entry
171 N DIC D VENA Q:'$D(X)
172 S DIC="^PRCD(420.1,"_Z0_",1,",DIC(0)="QEMZ" D ^DIC K:Y<0 X K Z0
173 I $D(X) S X=$P(Y(0,0),"^",1) W !,X
174 Q
175 ;
176EN9 ;CHECK FOR PAYMENT FIELDS AND OTHER FIELDS IN VENDOR FILE
177 ;CALLED FROM FILE 442 INPUT TEMPLATES.
178 ;FLAG --is set to 1 in template when certain VENDOR conditions are met
179 S PRCHOV7=$G(^PRC(440,+^PRC(442,D0,1),7)) G:PRCHOV7="" EXIT
180 I $P(PRCHOV7,U,3)]"",($P(PRCHOV7,U,7)]""),($P(PRCHOV7,U,8)]""),($P(PRCHOV7,U,9)]""),$P(PRCHOV3,U,11)]"",$P(PRCHOV3,U,14)]"",$P(PRCHOV3,U,13)]"",FLAG S Y="@20" G EXIT
181 S VEN=+^PRC(442,D0,1),%X="^PRC(440,VEN,",%Y="^PRC(440.3,VEN," D %XY^%RCR K VEN
182EXIT Q
183 ;
184EN12 ;UPDATE NATIONAL DRUG CODE #9.3
185 D VEN Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="")
186 S:'$D(PRC("SITE")) PRC("SITE")=$P($P(^PRC(442,DA(1),0),U,1),"-",1) S PRCHCV=$P(^PRC(442,DA(1),1),U,1),PRCHCI=$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN12^PRCHCRD1
187 Q
188 ;
189EN13 ;FILE 443.6, ITEM #40;BOC #3.5, EST. SHIPPING BOC #13.05
190 D VEN1 Q:'$D(X) S DIC="^PRCD(420.1,"_Z0_",1,",DIC(0)="QEMZ" D ^DIC K:Y<0 X K DIC,Z0 I $D(X) S X=$P(Y(0,0),"^",1) W !,X
191 Q
192EN133 ;FILE 443.6, EST. SHIPPING BOC #13.05
193 D VEN1A Q:'$D(X) S DIC="^PRCD(420.1,"_Z0_",1,",DIC(0)="QEMZ" D ^DIC K:Y<0 X K DIC,Z0 I $D(X) S X=$P(Y(0,0),"^",1) W !,X
194 Q
Note: See TracBrowser for help on using the repository browser.