source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHMA1.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 7.1 KB
Line 
1PRCHMA1 ;WISC/AKS/DWA-Amendments to purchase orders and requisitions ;6/8/96 13:42
2 ;;5.1;IFCAP;**22,40,79**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN4 ;Line Item edit
5 ;
6 ;MOP=Method of Processing
7 ;SSO=Supply Status Order
8 ;
9 N DIC,DIE,DA,DR,PRCHSTN,PRCHI,PRCHI1,PRCHO,PRCHEDI,PRCHSTN,PRCHPONO,DIE,DR,PRCHN,PRCHAREC,MOP,SSO
10 S MOP=$P($G(^PRC(442,PRCHPO,0)),U,2),SSO=$P($G(^PRC(442,PRCHPO,7)),U,2)
11 I ".27.28.33.25.26.30.31.40.41.32.34.37.38.46.47.48.49.96.97."[("."_SSO_".") D
12 . I MOP=25,$P(^PRC(442,PRCHPO,23),U,15)'="Y" Q
13 . I ".2.4.7.26."[("."_MOP_".") Q
14 . W !!
15 . W !,?15,"****************** TAKE NOTE!! ********************"
16 . W !,?15,"* *"
17 . W !,?15,"* This order has a Receiving Report previously *"
18 . W !,?15,"* processed. If this amendment will alter the *"
19 . W !,?15,"* Total Cost of any line item on the order *"
20 . W !,?15,"* remember to back out the previous Receiving *"
21 . W !,?15,"* Report with an Adjustment Voucher, process *"
22 . W !,?15,"* the amendment, and rerun the Receiving *"
23 . W !,?15,"* Report. *"
24 . W !,?15,"* *"
25 . W !,?15,"***************************************************"
26 . W !!
27 . Q
28 K MOP,SSO
29 D MV^PRCHMA0 I $G(PRCPROST)=6 S PRCHI=$O(^PRC(443.6,PRCRI(443.6),2,0)),PRCHI1=PRCHI,X=1,$P(PRCHI,U,2)=$P(^(PRCHI,0),U) G EN4A
30 S DA(1)=PRCHPO,DIC="^PRC(443.6,"_DA(1)_",2,",DIC(0)="AEQZ" D ^DIC Q:Y<0 S PRCHI=Y,PRCHI1=$P(Y,U,2)
31EN4A ;Called from routine PRCHMA2B for chenge vendor amendments to enable
32 ;line item edits for vendor specific information.
33 S PRCHO=+$G(^PRC(443.6,PRCHPO,2,+PRCHI,2))
34 S PRCHEDI=$G(^PRC(440,$P(^PRC(443.6,PRCHPO,1),U),3)) S:PRCHEDI]"" PRCHEDI=$P(PRCHEDI,U,2)
35 S PRCHSTN=$P($P(^PRC(443.6,PRCHPO,0),U),"-")
36 S PRCHPONO=$P(^PRC(443.6,PRCHPO,0),U)
37 I $G(PRCPROST)=6 D G EN4B
38 . N X
39 . S PRCRI(443.61)=$O(^PRC(443.6,PRCRI(443.6),2,0))
40 . I PRCRI(443.61) D EDIT^PRC0B(.X,"443.6;^PRC(443.6,;"_PRCRI(443.6)_"~443.61;^PRC(443.6,"_PRCRI(443.6)_",2,;"_PRCRI(443.61),"5///"_PRCPAMT)
41 . QUIT
42 S DIE="^PRC(443.6,",DA=PRCHPO
43 S DR=$S($D(PRCHREQ):"[PRCHRQITM]",1:"[PRCHLINE]"),DIE("NO^")="BACK"
44 ;I $G(PRCHVFLG)>0 S DR=$S($D(PRCHREQ):"[PRCH CHNGVEND RQ",1:"[PRCH CHNGVEND PO]"),DIE("NO^")="BACK"
45 I $G(PRCHAUTH)=1 S DR="[PRCH PURCHASE CARD AMEND]"
46 I $G(PRCHAUTH)=2 S DR="[PRCH DELIVERY ORDER AMEND]"
47 D ^DIE K DIE
48EN4B ;Called from routine PRCHMA2C for change vendor amendments to enable
49 ;line item edits if required information is missing.
50 S PRCHN=+$G(^PRC(443.6,PRCHPO,2,+PRCHI,2))
51 I PRCHO'=PRCHN S PRCHAMT=PRCHAMT+(PRCHN-PRCHO)
52 I $D(^PRC(443.6,PRCHPO,2,+PRCHI,2)),$P(^(2),U,6)>0 S PRCHAREC=1
53 I $P($G(^PRC(443.6,PRCHPO,2,+PRCHI,0)),U,2)'>$P($G(^(2)),U,8) D
54 .S PRCHX($P(PRCHI,U,2),"@")="^PRC(442,PRCHPO,2,""C"",X,"_+PRCHI_")"
55 E S PRCHX($P(PRCHI,U,2),$P(PRCHI,U,2))="^PRC(442,PRCHPO,2,""C"",X,"_+PRCHI_")"
56 S DELIVER=1 W !
57 D ERCHK,EN0^PRCHAMXH
58 K PRCHI
59 QUIT
60EN5 ;Source Code edit
61 N DIE,DR
62 S DIC="^PRCD(420.8,",DIC(0)="AEQ"
63 S:$D(PRCHREQ) DIC("S")="I ""134590""[$E(^(0))"
64 S:$P($G(^PRC(443.6,PRCHPO,1)),U,7)>0 DIC("B")=$P(^PRCD(420.8,$P(^(1),U,7),0),"^")
65 D ^DIC K DIC Q:Y<0
66 S DIE="^PRC(443.6,",DA=PRCHPO,DR="8////"_+Y D ^DIE K DIE W !
67 QUIT
68EN6 ;Edit Mail Invoice to
69 N DA,DIE,DR
70 S DA=PRCHPO,DIE="^PRC(443.6,",DR=.04 D ^DIE W !
71 QUIT
72EN7 ;Edit Method of Payment
73 N DA,DIE,DR
74 S DA=PRCHPO,DIE="^PRC(443.6,",DR=.02 D ^DIE W !
75 QUIT
76EN8 ;Administrative Certification add
77 N DIE,DA,DR,DLAYGO
78 D MVADM S DA(1)=PRCHPO
79 S DIC="^PRC(443.6,"_DA(1)_",15,",DIC(0)="AEQL",DLAYGO=443.6 D ^DIC K DIC
80 W !
81 QUIT
82EN9 ;Administrative Certification delete
83 N DIE,DA,DR
84 D MVADM S DA(1)=PRCHPO
85 S DIC="^PRC(443.6,"_DA(1)_",15,",DIC(0)="AEQ" D ^DIC K DIC
86 S DIE="^PRC(443.6,"_DA(1)_",15,",DA=+Y,DR=".01////@" D ^DIE K DIE
87 QUIT
88EN13 ;Replace P.O. Number
89 N X,I,PRCH0,PRCHO,PRCHNRQ,PRCHN,ER,OK,P2237
90 S (I,ER)=0,X=""
91 ;F S I=$O(^PRC(442,PRCHPO,11,I)) Q:'I I $D(^(I,0)) S X=$P(^(0),U,8) Q:X]""
92 D CAN^PRCHMA3
93 I $G(NOCAN)=1 W !?5,$S($D(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CANCEL !",$C(7) Q
94 I $G(PRCHAUTH)=1 D PAID^PRCHINQ I $G(PAID)=1 D Q
95 . W !,?5,"THERE HAS BEEN PAYMENT MADE FOR THIS PURCHASE CARD ORDER, CANNOT CANCEL !",$C(7)
96 I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)>2 D ERR Q
97 I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)=2 I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,2,0)),U,2)'=34 D ERR Q
98 S P2237=$P(^PRC(443.6,PRCHPO,0),U,12),OK=1 D:P2237>0 Q:OK=0
99 .I '$$VERIFY^PRCSC2(P2237) W !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR.",! S OK=0
100 I $D(PRCHREQ) S PRCHNRQ=PRCHREQ
101 S PRCH0=$G(^PRC(443.6,PRCHPO,0))
102 S PRCHO=$P(PRCH0,U),PRCH=PRCHPO D
103 .I $D(PRCHNRQ) S PRCHP("A")="REQUISITION NUMBER",PRCHP("T")=8,PRCHP("S")=1 D EN^PRCHPAT Q
104 .I $D(PRCHIMP) S PRCHP("A")="IMPREST FUND P.O.NO.: ",PRCHP("T")=7,PRCHP("S")=3 D EN^PRCHPAT Q
105 .D ENPO^PRCHUTL Q
106 I '$D(PRCHPO) S PRCHPO=PRCH Q
107 S PRCHN=$P(^PRC(442,PRCHPO,0),U),NDOC=$P(^(18),U,3)
108 N %X,%Y,DIE,DR,DA
109 S %X="^PRC(442,PRCH,",%Y="^PRC(443.6,PRCHPO," D %XY^%RCR
110 F I=6,10,11 K ^PRC(443.6,PRCHPO,I)
111 S DIE="^PRC(443.6,",DA=PRCHPO
112 S DR=".01///^S X=PRCHN;27///^S X=PRCHO;102///^S X=NDOC"
113 D ^DIE K DIE,DA,DR,NDOC
114 S DIE="^PRC(443.6,",DA=PRCH,DR="28///^S X=PRCHN" D ^DIE K DIE,DA,DR
115 S X=0,PRCHPO=PRCH D EN4^PRCHAMXB
116 S DA(1)=PRCH,DIE="^PRC(443.6,"_DA(1)_",6,",DA=PRCHAM,DR="9////^S X=$O(^PRCD(442.3,""C"",45,0))"
117 D ^DIE
118 S DELIVER=1,REPO=1,PRCHPO=PRCH,CAN=1 W !
119 QUIT
120MVADM ;Move Administrative Certifications from file 442
121 Q:$D(^PRC(443.6,PRCHPO,15,0))&($P($G(^(0)),U,4)>0) D WAIT^DICD
122 N %X,%Y
123 S %X="^PRC(442,PRCHPO,15,",%Y="^PRC(443.6,PRCHPO,15," D %XY^%RCR
124 S $P(^PRC(443.6,PRCHPO,15,0),U,2)=$P(^DD(443.6,24,0),U,2)
125 QUIT
126ERCHK N NODE0
127 S ERROR=0,NODE0=^PRC(443.6,PRCHPO,2,+PRCHI,0)
128 I '$O(^PRC(443.6,PRCHPO,2,+PRCHI,1,0)) W !,"Line item ",+NODE0," is missing its description!",! S ERROR=1
129 I $P(NODE0,U,4)="" W !,"Line item ",+NODE0," is missing BOC !",! S ERROR=1
130 I $G(PRCHAUTH)'=1,$D(PRCHREQ),$P(NODE0,U,13)="" W !,"Line item ",+NODE0," is missing NSN !",! S ERROR=1
131 I '$D(^PRC(443.6,PRCHPO,2,+PRCHI,2)) W !,"Line item ",+NODE0," is incomplete !",! S ERROR=1
132 I $P($G(^PRC(442,PRCHPO,23)),U,11)="D",$P($G(^PRC(443.6,PRCHPO,2,+PRCHI,2)),U,2)="" W !,"Line item ",+NODE0," does contain contract number.",! S ERROR=1
133 ;W:ERROR !,"Editing of the line item is required !",!
134 Q
135KILL ;Kill
136 K PRCF,RETURN,PRCHAM,PRCHPO,PRCHNEW,OUT,A,B,ER,FL,FIS,DELIVER,PRCHAMDA
137 K PRCHAV,PRCHL1,PRCHL2,ROU,DIC,I,PRCHAMT,PRCHAREC,PRCHEDI,X,Y,PRCHN
138 K PRCHO,PRCHX,PRCHIMP,PRCHNRQ,PRCHP,PRCHPO,REPO,PRCHNORE,%,%A,%B,D0,D1
139 K PRCHU,PRCHER,PRCHLN,PRCHRET,PRCHQ,AA,PRCHVN
140 Q
141ERR W !!?5,"To "_$S($D(PRCHREQ):$P(^PRCD(441.6,32,0),U,2),1:$P(^PRCD(442.2,32,0),U,2))_" it must be the ONLY change you",!?5,"are making on the amendment."
142 Q
143 ;
144PCD ;PRC*5.1*79 - Check line items of Detailed PC orders with source code=6
145 ;for missing contract number, called from PRCHMA.
146 I $P($G(^PRC(442,PRCHPO,23)),U,11)="P",$P($G(^PRC(442,PRCHPO,1)),U,7)=6,$P($G(^PRC(443.6,PRCHPO,2,PRCH,2)),U,2)="" D:LCNT>END TOP^PRCHMA W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing a required contract number.",$C(7) S PRCHER="",LNCT=LCNT+2
147 Q
Note: See TracBrowser for help on using the repository browser.