PRCHFPDE ;SF-ISC/TKW-EDIT FPDS DATA ON P.O. AFTER SIGNED BY P.A. ;12-6-90/15:48
V ;;5.1;IFCAP;**79,100**;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
EN1 ;EDIT FPDS DATA ON P.O. AFTER BEING SIGNED BY P.A.
 I $D(PRCHAM) S PRCHFLG=""
 N PRCHER,PRCHAM,PRCHAMDA,PRCHAMT,PRCHDUZ ;Newing variables for amends
 I $D(PRCHPO) S PRCHPOO=PRCHPO N PRCHPO S PRCHPO=PRCHPOO K PRCHPOO
 D:'$D(PRCHPO) ST^PRCHE Q:'$D(PRC("SITE"))
EN10 D:'$D(PRCHPO)!'$D(PRCHFLG) LOOK G:'$D(PRCHPO) Q D LCK1^PRCHE G:'$D(DA) EN10 S PRCHEST=$P(^PRC(442,PRCHPO,0),U,13)
 S X=$G(^PRC(442,PRCHPO,1)),PRCHV=+X,PRCHDT=$S($P(X,U,15)<2881001:0,$P(X,U,15)>2880930:1,1:""),PRCHSC="" I $D(^PRCD(420.8,+$P(X,U,7),0)) S PRCHSC=$P(^(0),U,1)
 ;
 ;PRC*5.1*79 - check for canceled orders or ineligible orders, i.e. RMPR
 I $P(^PRC(442,PRCHPO,7),U,2)=45!($G(PRCHSC)="") D OUT G EN10
 I $P(^PRC(442,PRCHPO,7),U,2)'>10 D EN^DDIOL("This Purchase Order has not been properly completed.") G EN10
 I "0139"[PRCHSC D OUT G EN10
 ;End check for PRC*5.1*79
 I PRCHDT="" D EN^DDIOL("Purchase Order has no date. ","","!") G EN10
 I 'PRCHDT W $C(7),!,"This option only available for P.O.'s beyond FY 1988!" G EN10
 S Y=$G(^PRC(440,PRCHV,2)),PRCHN("LSA")=$P(Y,U,5),PRCHN("MB")=$S(PRCHDT:$P(Y,U,3),1:$P(Y,U,6))
 S PRCHN("SFC")=$P(^PRC(442,PRCHPO,0),U,19),PRCHN("MP")=$P($G(^PRCD(442.5,+$P(^PRC(442,PRCHPO,0),U,2),0)),U,3) I 'PRCHN("MP") W !,$C(7),"Method of Processing not entered!" G Q
 S PRCHBO=$S(PRCHDT:1.1,1:1) K PRCHB
 G:PRCHDT&("013"[PRCHSC) ASK I $O(^PRC(440,PRCHV,PRCHBO,0)) S PRCHB(0)="^442.16PA^"_$P(^(0),U,3,4) F I=0:0 S I=$O(^PRC(440,PRCHV,PRCHBO,I)) Q:'I  S PRCHB(I)=I
 I PRCHDT,'$D(PRCHB) D ER3^PRCHNPO6 G EN10
 ;
ASK W !!,$C(7),"ARE YOU SURE YOU WANT TO RE-ENTER THE FPDS CODES " D YN^DICN Q:($D(PRCHFLG)>0)&(%=-1)  G:($D(PRCHFLG)=0)&(%=-1) EN10
 D:%=0 W G:%=0 ASK Q:($D(PRCHFLG)>0)&(%'=1)  G:($D(PRCHFLG)=0)&(%'=1) EN10
 I 'PRCHDT!("013"'[PRCHSC) D EN6^PRCHNPO2 G EN10:'$D(PRCHPO)
 K PRCH S PRCHEC=0 F I=0:0 S I=$O(^PRC(442,PRCHPO,2,I)) Q:'I  I $D(^(I,0)) S X=^(0),Y=$G(^(2)) D TBL
 ;
 ;Clear node 25 of any FPDS data, PRC*5.1*79
 K ^PRC(442,PRCHPO,9),^PRC(442,PRCHPO,25) S ^(9,0)="^442.1A^^",$P(^PRC(442,PRCHPO,0),U,15)=0
 W $C(7),!!,"PREVIOUS FPDS CODES HAVE BEEN DELETED!",!!
 S PRCHY=0 I PRCHEST>0,PRCHEC>0 S PRCHY=PRCHEST/PRCHEC,Y=$P(PRCHY,".",2) I $L(Y)>2 S PRCHY=$P(PRCHY,".",1)+$J("."_Y,2,2)
 S DIE="^PRC(442,",DR="[PRCHAMT89]",DA=PRCHPO
 I PRCHDT D FPDS^PRCHFPD2 Q:$D(PRCHFLG)>0&(%=-1)  G:'PRCHFPDS EN10
 S PRCH="" F PRCHI=1:1 S PRCH=$O(PRCH("AM",PRCH)) Q:PRCH=""  D TYPE^PRCHNPO1 S PRCHAMT=+PRCH("AM",PRCH),PRCHCN=$S(PRCH=".OM":"",1:PRCH) W ?40,"AMOUNT: ",PRCHAMT S PRCHAMT=""""_PRCHAMT_"""",DIE("NO^")="NO" D ^DIE
 ;PRC*5.1*79 - call new input templates for FPDS data.
 ;Check a regular PO from a Purchasing Agent.
 ;PRC*5.1*100 - if the user times out and does not complete the input
 ;template for the new FPDS, don't allow electronic sig. Check the last
 ;field required for the PO, based on the source code.
 ;
 I ("25"[PRCHSC),$D(^PRC(442,PRCHPO,14)) D  G:$G(PRCHER)=1 Q
 . S DR="[PRCH NEW PO FPDS]" D ^DIE
 . I '$D(^PRC(442,PRCHPO,25)) D STOP Q
 . I $P(^PRC(442,PRCHPO,25),U,6)="" D STOP Q
 . ;Fund agency code & fund agency office code can be empty in pairs only.
 . I +$P(^PRC(442,PRCHPO,25),U,7)>0,$P(^PRC(442,PRCHPO,25),U,8)="" D STOP Q
 ;End of changes for PRC*5.1*100.
 ;
 ;For FPDS purposes, consider any PO with any of the following source
 ;codes as a delivery order:
 ;PRC*5.1*100 - if the user times out, don't allow electronic sig.
 I ("467B"[PRCHSC)&($D(^PRC(442,PRCHPO,14))) D  G:$G(PRCHER)=1 Q
 . S DR="[PRCH NEW PO FPDS]" D ^DIE
 . I '$D(^PRC(442,PRCHPO,25)) D STOP Q
 . I $P(^PRC(442,PRCHPO,25),U,15)="" D STOP Q 
 . E  D POP^PRCHNPO1
 ;
 ;Quit if type code, pref, program, etc., are not defined.
 I '$D(^PRC(442,PRCHPO,9)) D STOP G Q
 D EN^DDIOL("Ok, let me save your changes.....done!","","!!?3") D ^PRCHSF
 ;End of changes for PRC*5.1*100.
 ;
 ;Send HL7 message to the AAC
 I $P($G(^PRC(442,PRCHPO,25)),U,17)="YES",$P(^PRC(442,PRCHPO,0),U,15)>0 D EN^DDIOL("...now generating the FPDS message for the AAC","","!") D AAC^PRCHAAC
 ;End changes for PRC*5.1*79
 K DIE F I=0:0 Q:'$D(PRCHPO)  S I=$O(^PRC(442,PRCHPO,9,I)) Q:'I  D ER2^PRCHNPO6:$P(^(I,0),U,2)="",ER3^PRCHNPO6:'$O(^(1,0))
 L  I $D(PRCHFLG) K PRCHFLG Q
 G EN10
 ;
OUT ;Tell the user that the PO is not eligible for FPDS
 D EN^DDIOL("This PO is not required for FPDS.","","!!?10")
 Q
 ;
STOP ;PRC*5.1*100 - quit if all the FPDS info was not entered.
 D EN^DDIOL("WARNING: YOU HAVE NOT ENTERED ALL THE FPDS DATA - NO MESSAGE GENERATED.","","!!?5") S PRCHER=1
 Q
 ;End of changes for PRC*5.1*100.
 ;
TBL ;TABLE LINE/ITEM AMOUNTS MINUS DISCOUNTS BY CONTRACT NO.
 S PRCHCN=$S($P(Y,U,2)'="":$P(Y,U,2),1:".OM") S:'$D(PRCH("AM",PRCHCN)) PRCH("AM",PRCHCN)="",PRCHEC=PRCHEC+1
 S PRCH("AM",PRCHCN)=($P(PRCH("AM",PRCHCN),U,1)+1)_"^"_($P(PRCH("AM",PRCHCN),U,2)+Y-$P(Y,U,6))_"^"_($P(PRCH("AM",PRCHCN),U,3))_+X_"," Q:$L(PRCH("AM",PRCHCN))<240
 ;
CNDNS N X,Y,I,J,C S C=",",X=$P(PRCH("AM",PRCHCN),U,3)
 F I=1:1:999 Q:$P(X,C,I)=""  I $P(X,C,I)?.N,$P(X,C,I+1)=($P(X,C,I)+1) F J=I+1:1:999 I ($P(X,C,J+1)'?1N.N)!(($P(X,C,J)+1)'=$P(X,C,J+1)) S Y=C_$P(X,C,I+1,J-1)_C,$P(PRCH("AM",PRCHCN),U,3)=$P(X,Y,1)_":1:"_$P(X,Y,2),I=999,J=999
 Q
 ;
LOOK ;K PRCHPO,PRCHNEW,DA,DIC,D0,DQ S DIC("S")="I +^(0)=PRC(""SITE"") S PRCHX=$S($D(^(7)):+^(7),1:0) I $D(^PRCD(442.3,PRCHX,0)),$P(^(0),U,2)>9"
 K PRCHPO,PRCHNEW,DA,DIC,D0,DQ S DIC("S")="I +^(0)=PRC(""SITE"") S PRCHX=+$G(^(7)) I $D(^PRCD(442.3,PRCHX,0)),$P(^(0),U,2)>9"
 S DIC="^PRC(442,",DIC(0)="QEAMZ",D="C",DIC("A")="PURCHASE ORDER: " S:'$D(DIC("S")) DIC("S")="I +$P(^(0),U,1)=PRC(""SITE"")"
 W !! D IX^DIC K DIC S X="" Q:+Y<0  S (PRCHPO,DA)=+Y
 Q
 ;
ER W !,$S('PRCHDT:" Breakout Code is undefined.",1:" Socioeconomic Group (FY89) not defined in Vendor file."),$C(7) K PRCHPO
 Q
 ;
W W !!,?10," Enter either Yes/No  or  enter ""^"" to exit."
 W !!,"This option will delete all FPDS codes that were previously entered",!,"for this Purchase Order, then allow you to re-enter them."
 Q
 ;
 ;
Q L  K PRC,PRCHI,PRCHFLG G Q^PRCHNPO4