148 lines
7.1 KiB
Mathematica
148 lines
7.1 KiB
Mathematica
PRCHMA1 ;WISC/AKS/DWA-Amendments to purchase orders and requisitions ;6/8/96 13:42
|
|
;;5.1;IFCAP;**22,40,79**;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
EN4 ;Line Item edit
|
|
;
|
|
;MOP=Method of Processing
|
|
;SSO=Supply Status Order
|
|
;
|
|
N DIC,DIE,DA,DR,PRCHSTN,PRCHI,PRCHI1,PRCHO,PRCHEDI,PRCHSTN,PRCHPONO,DIE,DR,PRCHN,PRCHAREC,MOP,SSO
|
|
S MOP=$P($G(^PRC(442,PRCHPO,0)),U,2),SSO=$P($G(^PRC(442,PRCHPO,7)),U,2)
|
|
I ".27.28.33.25.26.30.31.40.41.32.34.37.38.46.47.48.49.96.97."[("."_SSO_".") D
|
|
. I MOP=25,$P(^PRC(442,PRCHPO,23),U,15)'="Y" Q
|
|
. I ".2.4.7.26."[("."_MOP_".") Q
|
|
. W !!
|
|
. W !,?15,"****************** TAKE NOTE!! ********************"
|
|
. W !,?15,"* *"
|
|
. W !,?15,"* This order has a Receiving Report previously *"
|
|
. W !,?15,"* processed. If this amendment will alter the *"
|
|
. W !,?15,"* Total Cost of any line item on the order *"
|
|
. W !,?15,"* remember to back out the previous Receiving *"
|
|
. W !,?15,"* Report with an Adjustment Voucher, process *"
|
|
. W !,?15,"* the amendment, and rerun the Receiving *"
|
|
. W !,?15,"* Report. *"
|
|
. W !,?15,"* *"
|
|
. W !,?15,"***************************************************"
|
|
. W !!
|
|
. Q
|
|
K MOP,SSO
|
|
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
|
|
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)
|
|
EN4A ;Called from routine PRCHMA2B for chenge vendor amendments to enable
|
|
;line item edits for vendor specific information.
|
|
S PRCHO=+$G(^PRC(443.6,PRCHPO,2,+PRCHI,2))
|
|
S PRCHEDI=$G(^PRC(440,$P(^PRC(443.6,PRCHPO,1),U),3)) S:PRCHEDI]"" PRCHEDI=$P(PRCHEDI,U,2)
|
|
S PRCHSTN=$P($P(^PRC(443.6,PRCHPO,0),U),"-")
|
|
S PRCHPONO=$P(^PRC(443.6,PRCHPO,0),U)
|
|
I $G(PRCPROST)=6 D G EN4B
|
|
. N X
|
|
. S PRCRI(443.61)=$O(^PRC(443.6,PRCRI(443.6),2,0))
|
|
. 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)
|
|
. QUIT
|
|
S DIE="^PRC(443.6,",DA=PRCHPO
|
|
S DR=$S($D(PRCHREQ):"[PRCHRQITM]",1:"[PRCHLINE]"),DIE("NO^")="BACK"
|
|
;I $G(PRCHVFLG)>0 S DR=$S($D(PRCHREQ):"[PRCH CHNGVEND RQ",1:"[PRCH CHNGVEND PO]"),DIE("NO^")="BACK"
|
|
I $G(PRCHAUTH)=1 S DR="[PRCH PURCHASE CARD AMEND]"
|
|
I $G(PRCHAUTH)=2 S DR="[PRCH DELIVERY ORDER AMEND]"
|
|
D ^DIE K DIE
|
|
EN4B ;Called from routine PRCHMA2C for change vendor amendments to enable
|
|
;line item edits if required information is missing.
|
|
S PRCHN=+$G(^PRC(443.6,PRCHPO,2,+PRCHI,2))
|
|
I PRCHO'=PRCHN S PRCHAMT=PRCHAMT+(PRCHN-PRCHO)
|
|
I $D(^PRC(443.6,PRCHPO,2,+PRCHI,2)),$P(^(2),U,6)>0 S PRCHAREC=1
|
|
I $P($G(^PRC(443.6,PRCHPO,2,+PRCHI,0)),U,2)'>$P($G(^(2)),U,8) D
|
|
.S PRCHX($P(PRCHI,U,2),"@")="^PRC(442,PRCHPO,2,""C"",X,"_+PRCHI_")"
|
|
E S PRCHX($P(PRCHI,U,2),$P(PRCHI,U,2))="^PRC(442,PRCHPO,2,""C"",X,"_+PRCHI_")"
|
|
S DELIVER=1 W !
|
|
D ERCHK,EN0^PRCHAMXH
|
|
K PRCHI
|
|
QUIT
|
|
EN5 ;Source Code edit
|
|
N DIE,DR
|
|
S DIC="^PRCD(420.8,",DIC(0)="AEQ"
|
|
S:$D(PRCHREQ) DIC("S")="I ""134590""[$E(^(0))"
|
|
S:$P($G(^PRC(443.6,PRCHPO,1)),U,7)>0 DIC("B")=$P(^PRCD(420.8,$P(^(1),U,7),0),"^")
|
|
D ^DIC K DIC Q:Y<0
|
|
S DIE="^PRC(443.6,",DA=PRCHPO,DR="8////"_+Y D ^DIE K DIE W !
|
|
QUIT
|
|
EN6 ;Edit Mail Invoice to
|
|
N DA,DIE,DR
|
|
S DA=PRCHPO,DIE="^PRC(443.6,",DR=.04 D ^DIE W !
|
|
QUIT
|
|
EN7 ;Edit Method of Payment
|
|
N DA,DIE,DR
|
|
S DA=PRCHPO,DIE="^PRC(443.6,",DR=.02 D ^DIE W !
|
|
QUIT
|
|
EN8 ;Administrative Certification add
|
|
N DIE,DA,DR,DLAYGO
|
|
D MVADM S DA(1)=PRCHPO
|
|
S DIC="^PRC(443.6,"_DA(1)_",15,",DIC(0)="AEQL",DLAYGO=443.6 D ^DIC K DIC
|
|
W !
|
|
QUIT
|
|
EN9 ;Administrative Certification delete
|
|
N DIE,DA,DR
|
|
D MVADM S DA(1)=PRCHPO
|
|
S DIC="^PRC(443.6,"_DA(1)_",15,",DIC(0)="AEQ" D ^DIC K DIC
|
|
S DIE="^PRC(443.6,"_DA(1)_",15,",DA=+Y,DR=".01////@" D ^DIE K DIE
|
|
QUIT
|
|
EN13 ;Replace P.O. Number
|
|
N X,I,PRCH0,PRCHO,PRCHNRQ,PRCHN,ER,OK,P2237
|
|
S (I,ER)=0,X=""
|
|
;F S I=$O(^PRC(442,PRCHPO,11,I)) Q:'I I $D(^(I,0)) S X=$P(^(0),U,8) Q:X]""
|
|
D CAN^PRCHMA3
|
|
I $G(NOCAN)=1 W !?5,$S($D(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CANCEL !",$C(7) Q
|
|
I $G(PRCHAUTH)=1 D PAID^PRCHINQ I $G(PAID)=1 D Q
|
|
. W !,?5,"THERE HAS BEEN PAYMENT MADE FOR THIS PURCHASE CARD ORDER, CANNOT CANCEL !",$C(7)
|
|
I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)>2 D ERR Q
|
|
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
|
|
S P2237=$P(^PRC(443.6,PRCHPO,0),U,12),OK=1 D:P2237>0 Q:OK=0
|
|
.I '$$VERIFY^PRCSC2(P2237) W !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR.",! S OK=0
|
|
I $D(PRCHREQ) S PRCHNRQ=PRCHREQ
|
|
S PRCH0=$G(^PRC(443.6,PRCHPO,0))
|
|
S PRCHO=$P(PRCH0,U),PRCH=PRCHPO D
|
|
.I $D(PRCHNRQ) S PRCHP("A")="REQUISITION NUMBER",PRCHP("T")=8,PRCHP("S")=1 D EN^PRCHPAT Q
|
|
.I $D(PRCHIMP) S PRCHP("A")="IMPREST FUND P.O.NO.: ",PRCHP("T")=7,PRCHP("S")=3 D EN^PRCHPAT Q
|
|
.D ENPO^PRCHUTL Q
|
|
I '$D(PRCHPO) S PRCHPO=PRCH Q
|
|
S PRCHN=$P(^PRC(442,PRCHPO,0),U),NDOC=$P(^(18),U,3)
|
|
N %X,%Y,DIE,DR,DA
|
|
S %X="^PRC(442,PRCH,",%Y="^PRC(443.6,PRCHPO," D %XY^%RCR
|
|
F I=6,10,11 K ^PRC(443.6,PRCHPO,I)
|
|
S DIE="^PRC(443.6,",DA=PRCHPO
|
|
S DR=".01///^S X=PRCHN;27///^S X=PRCHO;102///^S X=NDOC"
|
|
D ^DIE K DIE,DA,DR,NDOC
|
|
S DIE="^PRC(443.6,",DA=PRCH,DR="28///^S X=PRCHN" D ^DIE K DIE,DA,DR
|
|
S X=0,PRCHPO=PRCH D EN4^PRCHAMXB
|
|
S DA(1)=PRCH,DIE="^PRC(443.6,"_DA(1)_",6,",DA=PRCHAM,DR="9////^S X=$O(^PRCD(442.3,""C"",45,0))"
|
|
D ^DIE
|
|
S DELIVER=1,REPO=1,PRCHPO=PRCH,CAN=1 W !
|
|
QUIT
|
|
MVADM ;Move Administrative Certifications from file 442
|
|
Q:$D(^PRC(443.6,PRCHPO,15,0))&($P($G(^(0)),U,4)>0) D WAIT^DICD
|
|
N %X,%Y
|
|
S %X="^PRC(442,PRCHPO,15,",%Y="^PRC(443.6,PRCHPO,15," D %XY^%RCR
|
|
S $P(^PRC(443.6,PRCHPO,15,0),U,2)=$P(^DD(443.6,24,0),U,2)
|
|
QUIT
|
|
ERCHK N NODE0
|
|
S ERROR=0,NODE0=^PRC(443.6,PRCHPO,2,+PRCHI,0)
|
|
I '$O(^PRC(443.6,PRCHPO,2,+PRCHI,1,0)) W !,"Line item ",+NODE0," is missing its description!",! S ERROR=1
|
|
I $P(NODE0,U,4)="" W !,"Line item ",+NODE0," is missing BOC !",! S ERROR=1
|
|
I $G(PRCHAUTH)'=1,$D(PRCHREQ),$P(NODE0,U,13)="" W !,"Line item ",+NODE0," is missing NSN !",! S ERROR=1
|
|
I '$D(^PRC(443.6,PRCHPO,2,+PRCHI,2)) W !,"Line item ",+NODE0," is incomplete !",! S ERROR=1
|
|
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
|
|
;W:ERROR !,"Editing of the line item is required !",!
|
|
Q
|
|
KILL ;Kill
|
|
K PRCF,RETURN,PRCHAM,PRCHPO,PRCHNEW,OUT,A,B,ER,FL,FIS,DELIVER,PRCHAMDA
|
|
K PRCHAV,PRCHL1,PRCHL2,ROU,DIC,I,PRCHAMT,PRCHAREC,PRCHEDI,X,Y,PRCHN
|
|
K PRCHO,PRCHX,PRCHIMP,PRCHNRQ,PRCHP,PRCHPO,REPO,PRCHNORE,%,%A,%B,D0,D1
|
|
K PRCHU,PRCHER,PRCHLN,PRCHRET,PRCHQ,AA,PRCHVN
|
|
Q
|
|
ERR 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."
|
|
Q
|
|
;
|
|
PCD ;PRC*5.1*79 - Check line items of Detailed PC orders with source code=6
|
|
;for missing contract number, called from PRCHMA.
|
|
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
|
|
Q
|