source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO4.m@ 619

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

initial load of WorldVistAEHR
File size: 9.5 KB
Line 
1PRCHNPO4 ;WOIFO/RSD/RHD-CONT. OF NEW PO--COMPLETE PROCESSING IN SUPPLY ;4/22/98 06:21
2V ;;5.1;IFCAP;**51,56,81,79**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5PHA S ERROR="" I $G(PRCHPC)'=1 D NEW^PRCOEDC(PRCHPO,.ERROR) I ERROR'="" W !!?5,"Procurement History transaction error " G ERR^PRCHNPO
6 N RBD,RBDT,RBQT,RBFY,CCHK,FCHK,REFMOP S REFMOP=$P($G(^PRC(442,PRCHPO,0)),U,2)
7 I REFMOP=25 S RBDT=$$DATE^PRC0C($P($G(^PRC(442,PRCHPO,1)),U,15),"I"),RBFY=$E(RBDT,3,4),RBQT=$P(RBDT,"^",2),RBD=$$QTRDATE^PRC0D(RBFY,RBQT),RBD=$P(RBD,"^",7)
8 S PRC("CP")=$P($G(^PRC(442,PRCHPO,0)),"^",3)
9 S CCHK=$P($G(^PRC(442,PRCHPO,0)),U,15)
10 I $G(PRCHPC)="",CCHK'="" N BRCHK,BRCOST S BRCHK=$P($G(^PRC(442,PRCHPO,0)),"^",12),BRCOST=$P($G(^PRCS(410,+BRCHK,4)),"^") S:BRCOST'="" CCHK=CCHK-BRCOST
11 I REFMOP=25 S FCHK=$$OVCOM^PRCS0A(PRC("SITE")_"^"_PRC("CP")_"^"_$P($$DATE^PRC0C(RBD,"I"),"^",1,2),CCHK,2) I FCHK'=0 W !,"Insufficient funds for this request." H 2 G ERR^PRCHNPO
12 I $P($G(^PRC(442,PRCHPO,0)),U,2)=25 S FILE=442 D LIMIT^PRCHCD0 I $G(ERROR) K FILE,ERROR G ERR^PRCHNPO
13 ;I $G(PRCHPC)=2 S $P(^PRC(442,PRCHPO,0),U,15)=PRCHTAMT
14 I $P($G(^PRC(442,PRCHPO,23)),U,11)="D" D G:$G(ERROR)=1 ERR^PRCHNPO
15 . S PRCHITM=0 F S PRCHITM=$O(^PRC(442,PRCHPO,2,PRCHITM)) Q:'PRCHITM I $P($G(^PRC(442,PRCHPO,2,PRCHITM,2)),U,2)="" W !!,?5,"One or more of the items on this delivery order",!,?5,"does not contain contract number." S ERROR=1
16 ;
17 ; New check for FPDS, PRC*5.1*79
18 ; Check Detailed PC orders with source code 6 and contract items only
19 I $P($G(^PRC(442,PRCHPO,23)),U,11)="P"&($P($G(^PRC(442,PRCHPO,1)),U,7)=6) D G:$G(ERROR)=1 ERR^PRCHNPO
20 . S PRCHITM=0 F S PRCHITM=$O(^PRC(442,PRCHPO,2,PRCHITM)) Q:'PRCHITM I $P($G(^PRC(442,PRCHPO,2,PRCHITM,2)),U,2)="" W !!,?5,"Line item "_PRCHITM_" on this purchase card order",!,?5,"does not contain a required contract number." S ERROR=1
21 D EN105^PRCHNPO7 G:$G(ERROR)=1 ERR^PRCHNPO
22 ; End of new check for FPDS
23 ;
24FS S PRCHN("SFC")=$P(^PRC(442,PRCHPO,0),U,19)
25 ; SET STATUS TO 'Ordered (no Fiscal Action Required)' IF IMPREST FUNDS METHOD OF PROCESSING, OR IF SPECIAL CONTROL POINT FOR SUPPLY FUND (POSTED).
26 ; SET STATUS TO 'Transaction Complete' FOR CERTIFIED INVOICES ORDERED FOR SUPPLY FUND.
27 ; SET STATUS TO 'Pending Fiscal Action' OTHERWISE.
28 S PRCHSTAT=10,%A="Send to Fiscal Service"
29 I PRCHN("SFC")=2!(PRCHN("MP")=25) S PRCHSTAT=22,%A="Print Purchase Order"
30 S FILE=442 D:$D(PRCHPO) CHECK^PRCHSWCH
31 I $G(PRCHOBL)=1 S PRCHSTAT=22,%A="Print Purchase Order "
32 I PRCHN("MP")=2,PRCHN("SFC")=2 S PRCHSTAT=40
33 ;
34ASK I '$G(PRCHPC),'$G(PRCHDELV) D G Q:%=2&(PRCHN("MP")'=25)!(%<0),FS:%=0
35 . W ! S %A=" "_%A,%B="",%=1 D ^PRCFYN
36 . S NOPRINT="" I %=2 S NOPRINT=1
37 S P=+$P($G(^PRC(442,PRCHPO,1)),U,10),DA=PRCHPO
38 I 'P W !!,"P.O. is missing the Purchasing Agent and must be re-edited !",$C(7) G Q
39 I P'=DUZ W !!,"You must be the Purchasing Agent listed on P.O. to sign it.",$C(7) S DIR(0)="EAO",DIR("A")="Press <Return> to continue " D ^DIR K DIR(0),DIR("A") G Q
40 I $G(PRCHPHAM),$P(^PRC(442,PRCHPO,0),U,15)=0 D G:%'=1 ERR^PRCHNPO
41 . W !!,?5,"This pharmacy order is a no charge order." S %A=" Would you like to sign this order",%B="",%=2 D ^PRCFYN
42 S X=$P($G(^PRC(442,PRCHPO,1)),U)
43 ;
44 ; Begin modifications for PRC*5.1*56
45 I X]"",$P($G(^PRC(440,X,3)),U,2)="Y",";P;S;"[(";"_$P($G(^PRC(442,PRCHPO,23)),U,11)_";") D
46 . S MSG1=" This order will not be sent via EDI."
47 . S MSG2="To place a Purchase Card order via EDI please use the Purchasing Agent Menu."
48 . W !!!," ***** TAKE NOTE *****"
49 . W !!,?2,MSG1,!!,MSG2,!!
50 . K MSG1,MSG2
51 . Q
52 ; End modifications for PRC*5.1*56
53 I X]"",$P($G(^PRC(440,X,3)),U,2)="Y",";P;S;"'[(";"_$P($G(^PRC(442,PRCHPO,23)),U,11)_";") D G:$G(X)="ABORT" Q I $D(DTOUT)!$D(Y) W $C(7),!!,"The 'Do You Want to Send This EDI?' question was bypassed - You must reedit PO" K DTOUT G Q
54 . N PRCY S PRCY=""
55 . I $P($G(^PRC(442,PRCHPO,0)),U,2)=25 D
56 . . N PRCX
57 . . S PRCX=$P($G(^PRC(442,PRCHPO,23)),U,8)
58 . . S:PRCX'="" PRCX=$P($G(^PRC(440.5,PRCX,2)),U,4)
59 . . D NOW^%DTC
60 . . I ($E(PRCX,6,7)>0&(X>PRCX))!(+$E(PRCX,6,7)=0&(X\100>(PRCX\100))) D
61 . . . W !!,"In File #440.5, the Expiration Date for this card is blank or this card has"
62 . . . W !,?5,"expired! An EDI order will reject. Please contact your Purchase"
63 . . . W !,?5,"Card Coordinator." S PRCY="NO"
64 . N DIE,DR,DA
65 . S DIE=442,DR="116///@;S Y=""@1"";@1;116Do You Want to Send This EDI?~R",DA=PRCHPO D ^DIE
66 . Q:$D(DTOUT)!$D(Y)
67 . I $P($G(^PRC(442,PRCHPO,12)),U,16)="y",PRCY="NO" D
68 . . S X="ABORT"
69 . . W !,"As you have elected to send this order EDI, please ask the Purchase Card"
70 . . W !,"Coordinator to update the Card's Expiration Date before completing this"
71 . . W !,"Purchase Order. - You must reedit this PO."
72 ; UPDATE STATUS, P.A.SIGNATURE & BOC DATA, IN P.O.
73 S PRCSIG="" D ESIG^PRCUESIG(DUZ,.PRCSIG) S ROUTINE="PRCUESIG" I PRCSIG<1 D QQ G Q
74 ;Following line added in P194: go create new txn # if PC order modified
75 ;to new FCP
76 D CHECKFCP^PRCHNPOA(PRCHPO)
77 ;I $P($G(^PRC(442,PRCHPO,23)),U,11)="D",$P(^PRC(442,PRCHPO,0),U,2)=26 S $P(^PRC(442,PRCHPO,24),U)=1
78 I $G(PRCHPC)!$G(PRCHDELV) D G Q:%<0,FS:%=0
79 . I $G(PRCPROST) S PRCPROST=3.9,NOPRINT=1,%=2 QUIT
80 . S %A=$S($G(PRCHPC):"Print Purchase Card Order ",1:"Print Delivery Order")
81 . W ! S %A=" "_%A,%B="",%=1 D ^PRCFYN
82 . S NOPRINT="" I %=2 S NOPRINT=1
83 ;
84 S X=$S($G(PRCHPHAM)'="":30,1:PRCHSTAT),DA=PRCHPO D ENS^PRCHSTAT
85 S (D0,DA)=PRCHPO D ^PRCHSF ;CALLS ROUTINE FOR FMS PROCESSING
86 S %DT="T",X="NOW" D ^%DT S PRCSIG="" D ENCODE^PRCHES5(DA,DUZ,.PRCSIG)
87 S ROUTINE=$T(+0) I PRCSIG<1 D QQ G Q
88 S D0=PRCHPO K D1 S:'$D(DT) DT=$P(Y,".",1)
89 ;
90 I $G(PRCHPC)!$G(PRCHDELV) D
91 . I $P($G(^PRC(442,PRCHPO,23)),U,8)]"" D
92 . . S PRCHCD=$P(^PRC(442,PRCHPO,23),U,8)
93 . . S PRCHPOMT=$P(^PRC(442,PRCHPO,0),U,15)
94 . S PODA=DA,DA=CDA S X=$P(^PRC(442,PRCHPO,0),U,15) D ESIG^PRCH410 S DA=PODA K PODA
95 ; IF SUPPLY FUND, NOT CERTIFIED INVOICE, SET FLAG NOTIFYING PPM TO CREATE LOG CODE SHEETS
96 S PRCHPOMT=$P(^PRC(442,PRCHPO,0),U,15),PRCHCD=$P(^PRC(442,PRCHPO,23),U,8)
97 I $P($G(^PRC(442,PRCHPO,0)),U,2)=25,$G(PRCHCD)'="" S $P(^PRC(440.5,PRCHCD,2),U)=+$P($G(^PRC(440.5,PRCHCD,2)),U)+PRCHPOMT
98 I PRCHN("SFC")=2 S $P(^PRC(442,PRCHPO,18),U,12)=1
99 I PRCHN("SFC")=2,PRCHN("MP")'=2 S $P(^PRC(442,PRCHPO,18),U,11)="N",^PRC(442,"AE","N",PRCHPO)=""
100 ; IF SUPPLY FUND, CERTIFIED INVOICE, UPDATE CONTROL POINT OBLIGATED BALANCE.
101 ;
102ISMS ;I PRCHSC=9 ;;I $D(PRCHISMS) ;CHECK ISMS SWITCH AND IF TRUE CREATE ISMS TRANSACTION
103 ;I PRCHSC=1 D:0 EN11^PRCHEI
104 ;I PRCHSC=9 S PRCHTRAN="PO1" D EN11^PRCHEI(PRCHTRAN)
105 ;
106 ; PRC*5.1*81 - if site runs DynaMed, may need to build update txn
107 I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 D UPD^PRCV442A(PRCHPO)
108 ;
109EDI ;CHECK TO SEE IF IT IS AN EDI PO AND SEND TO AUSTIN
110 ;I $G(PRCHSTAT)'="",PRCHSTAT'=10 N PRCOPODA S PRCOPODA=PRCHPO D ^PRCOEDI
111 I PRCHN("MP")=25 D S $P(^PRC(442,PRCHPO,24),U)=1 G INV
112 . I $G(PRCHPC)'=1 N PRCOPODA S PRCOPODA=PRCHPO W !!,"...now generating the PHA transaction" D ^PRCOEDI
113 .;Create FPDS message for the AAC, PRC*5.1*79
114 . I $P(^PRC(442,PRCHPO,0),U,15)>0,$D(^PRC(442,PRCHPO,25)) D
115 . . D EN^DDIOL("...now generating the FPDS message for the AAC","","!!"),EN^DDIOL(" ") D AAC^PRCHAAC
116 .;End of changes for PRC*5.1*79
117 . I '$P($G(^PRC(442,PRCHPO,23)),U,11) D
118 . . I '$P(^PRC(442,PRCHPO,0),U,12) S DA=PRCHPO D START^PRCH410 D Q
119 . . . S PODA=PRCHPO,DA=CDA S X=$P(^PRC(442,PRCHPO,0),U,15) D ESIG^PRCH410 S DA=PODA K PODA
120 . . I $P(^PRC(442,PRCHPO,0),U,12) D COMM^PRCSPC(PRCHPO,$P(^PRC(442,PRCHPO,0),U,10))
121 I $G(PRCHSTAT)'="",PRCHSTAT'=10 D S:$P(^PRC(442,PRCHPO,0),U,2)=26 $P(^PRC(442,PRCHPO,24),U)=1 G INV
122 . Q:$P(^PRC(442,PRCHPO,0),U,2)=2
123 . N PRCOPODA S PRCOPODA=PRCHPO D ^PRCOEDI,SUPP^PRCFFMO
124 I $G(PRCHOBL)=2 N PRCOPODA S PRCOPODA=PRCHPO W !!,"...now generating the PHA transaction" D ^PRCOEDI
125 ;
126 ;update due-ins at the inventory point
127INV G:$P($G(^PRC(442,PRCHPO,23)),U,11)="S" PRT
128 G:$G(PRCHPHAM) PRT
129 S FLG=0 I $P(^PRC(442,PRCHPO,0),U,2)=2 D
130 .S N=0 F S N=$O(^PRC(442,PRCHPO,2,N)) Q:'N!(FLG) I $P(^(N,0),U,5)]"" S FLG=1
131 .K N
132 I $P($G(^PRC(442,PRCHPO,23)),U,11)'="S" I '$G(PRCHPHAM) D
133 . I $P(^PRC(442,PRCHPO,0),U,2)'=2 S DA=PRCHPO D UPDATE^PRCPWIU
134 . I ($P(^PRC(442,PRCHPO,0),U,2)=2)&(FLG) S DA=PRCHPO D UPDATE^PRCPWIU
135 K FLG
136 ;S DA=PRCHPO D UPDATE^PRCPWIU
137 ;
138PRT ;IF IMPREST FUND PO, PRINT A COPY ON BOTH IMPREST FUND & FISCAL PRINTER.
139 ;IF SUPPLY FUND PO, PRINT A COPY IN P&C AND ONE IN FISCAL.
140 ; OTHERWISE, PRINT A COPY IN FISCAL
141 ;IF SUPPLY FUND PAYMENT IN ADVANCE, PRINT 2 MORE COPIES IN FISCAL.
142 K PRCHQ S (D0,DA)=PRCHPO,PRCHQ="^PRCHFPNT"
143 ;
144 I PRCHN("MP")=12 S PRCHQ("DEST2")="IFP" D ^PRCHQUE
145 I '$G(NOPRINT) I PRCHN("SFC")=2!(PRCHN("MP")=25) S:PRCHN("MP")'=25 PRCHQ("DEST")="S8" D ^PRCHQUE S (D0,DA)=PRCHPO,PRCHQ="^PRCHFPNT"
146 ;
147 K PRCHQ S (D0,DA)=PRCHPO,PRCHQ="^PRCHFPNT"
148 I PRCHN("MP")'=25 S PRCHQ("DEST")="F" D ^PRCHQUE
149 I PRCHN("SFC")=2,PRCHN("MP")=3 F PRCHI=1,2 S (D0,DA)=PRCHPO,PRCHQ="^PRCHFPNT",PRCHQ("DEST")="F" D ^PRCHQUE
150 G Q
151 ;
152QQ N:'$D(ROUTINE) ROUTINE S:$G(ROUTINE)="" ROUTINE=$T(+0) N DIR
153 W !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG) W:PRCSIG=0!(PRCSIG=-3) !,"Notify Application Coordinator!",$C(7)
154 S DIR(0)="EAO",DIR("A")="Press <return> to continue" D ^DIR K PRCSIG
155 Q
156 ;
157Q L K PRCH,PRCHAC,PRCHACT,PRCHAM,PRCHAMT,PRCHB,PRCHBO,PRCHCN,PRCHCNT,PRCHD,PRCHDA,PRCHDT,PRCHEC,PRCHEDI,PRCHER,PRCHES,PRCHEST,PRCHESTL,PRCHFPDS,PRCHI,PRCHL0,PRCHL1,PRCHL2,PRCHL3,PRCHLCNT,PRCHLI,PRCSIG,ROUTINE
158 K PRCHN,PRCHNM,PRCHNRQ,PRCHP,PRCHPO,PRCHPONO,PRCHQ,PRCHS,PRCHSC,PRCHSTAT,PRCHTTT,PRCHV,PRCHVAR,PRCHX,PRCHY,DIC,DIE,DR,D0,DA,X,Y,Z,I,J,K,P,ZTSK
159 K ERROR,ITEMCNT,M,M0,PRCHFCP,PRCHLOG,PRCHSTN,ZTDESC,ZTRTN,ZTUCI,A,B,C,V3,PRCHXXD0,F1,I1,POP,PRCHLN,SUBACC,ERROR1,NOPRINT
160 Q
Note: See TracBrowser for help on using the repository browser.