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,220**;Oct 20, 2000;Build 23
;Per VA Directive 6402, this routine should not be modified.
;
;PRC*5.1*220 Removed check/query/invoke FPDS messaging
;
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 ;PRC*5.1*220
;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 -^PRC(442,PRCHPO) 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 -^PRC(442,PRCHPO) K PRC,PRCHI,PRCHFLG G Q^PRCHNPO4
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHFPDE 6347 printed Sep 23, 2025@19:43:38 Page 2
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,220**;Oct 20, 2000;Build 23
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*220 Removed check/query/invoke FPDS messaging
+4 ;
EN1 ;EDIT FPDS DATA ON P.O. AFTER BEING SIGNED BY P.A.
+1 IF $DATA(PRCHAM)
SET PRCHFLG=""
+2 ;Newing variables for amends
NEW PRCHER,PRCHAM,PRCHAMDA,PRCHAMT,PRCHDUZ
+3 IF $DATA(PRCHPO)
SET PRCHPOO=PRCHPO
NEW PRCHPO
SET PRCHPO=PRCHPOO
KILL PRCHPOO
+4 if '$DATA(PRCHPO)
DO ST^PRCHE
if '$DATA(PRC("SITE"))
QUIT
EN10 if '$DATA(PRCHPO)!'$DATA(PRCHFLG)
DO LOOK
if '$DATA(PRCHPO)
GOTO Q
DO LCK1^PRCHE
if '$DATA(DA)
GOTO EN10
SET PRCHEST=$PIECE(^PRC(442,PRCHPO,0),U,13)
+1 SET X=$GET(^PRC(442,PRCHPO,1))
SET PRCHV=+X
SET PRCHDT=$SELECT($PIECE(X,U,15)<2881001:0,$PIECE(X,U,15)>2880930:1,1:"")
SET PRCHSC=""
IF $DATA(^PRCD(420.8,+$PIECE(X,U,7),0))
SET PRCHSC=$PIECE(^(0),U,1)
+2 ;
+3 ;PRC*5.1*79 - check for canceled orders or ineligible orders, i.e. RMPR
+4 IF $PIECE(^PRC(442,PRCHPO,7),U,2)=45!($GET(PRCHSC)="")
DO OUT
GOTO EN10
+5 IF $PIECE(^PRC(442,PRCHPO,7),U,2)'>10
DO EN^DDIOL("This Purchase Order has not been properly completed.")
GOTO EN10
+6 IF "0139"[PRCHSC
DO OUT
GOTO EN10
+7 ;End check for PRC*5.1*79
+8 IF PRCHDT=""
DO EN^DDIOL("Purchase Order has no date. ","","!")
GOTO EN10
+9 IF 'PRCHDT
WRITE $CHAR(7),!,"This option only available for P.O.'s beyond FY 1988!"
GOTO EN10
+10 SET Y=$GET(^PRC(440,PRCHV,2))
SET PRCHN("LSA")=$PIECE(Y,U,5)
SET PRCHN("MB")=$SELECT(PRCHDT:$PIECE(Y,U,3),1:$PIECE(Y,U,6))
+11 SET PRCHN("SFC")=$PIECE(^PRC(442,PRCHPO,0),U,19)
SET PRCHN("MP")=$PIECE($GET(^PRCD(442.5,+$PIECE(^PRC(442,PRCHPO,0),U,2),0)),U,3)
IF 'PRCHN("MP")
WRITE !,$CHAR(7),"Method of Processing not entered!"
GOTO Q
+12 SET PRCHBO=$SELECT(PRCHDT:1.1,1:1)
KILL PRCHB
+13 if PRCHDT&("013"[PRCHSC)
GOTO ASK
IF $ORDER(^PRC(440,PRCHV,PRCHBO,0))
SET PRCHB(0)="^442.16PA^"_$PIECE(^(0),U,3,4)
FOR I=0:0
SET I=$ORDER(^PRC(440,PRCHV,PRCHBO,I))
if 'I
QUIT
SET PRCHB(I)=I
+14 IF PRCHDT
IF '$DATA(PRCHB)
DO ER3^PRCHNPO6
GOTO EN10
+15 ;
ASK WRITE !!,$CHAR(7),"ARE YOU SURE YOU WANT TO RE-ENTER THE FPDS CODES "
DO YN^DICN
if ($DATA(PRCHFLG)>0)&(%=-1)
QUIT
if ($DATA(PRCHFLG)=0)&(%=-1)
GOTO EN10
+1 if %=0
DO W
if %=0
GOTO ASK
if ($DATA(PRCHFLG)>0)&(%'=1)
QUIT
if ($DATA(PRCHFLG)=0)&(%'=1)
GOTO EN10
+2 IF 'PRCHDT!("013"'[PRCHSC)
DO EN6^PRCHNPO2
if '$DATA(PRCHPO)
GOTO EN10
+3 KILL PRCH
SET PRCHEC=0
FOR I=0:0
SET I=$ORDER(^PRC(442,PRCHPO,2,I))
if 'I
QUIT
IF $DATA(^(I,0))
SET X=^(0)
SET Y=$GET(^(2))
DO TBL
+4 ;
+5 ;Clear node 25 of any FPDS data, PRC*5.1*79
+6 KILL ^PRC(442,PRCHPO,9),^PRC(442,PRCHPO,25)
SET ^(9,0)="^442.1A^^"
SET $PIECE(^PRC(442,PRCHPO,0),U,15)=0
+7 WRITE $CHAR(7),!!,"PREVIOUS FPDS CODES HAVE BEEN DELETED!",!!
+8 SET PRCHY=0
IF PRCHEST>0
IF PRCHEC>0
SET PRCHY=PRCHEST/PRCHEC
SET Y=$PIECE(PRCHY,".",2)
IF $LENGTH(Y)>2
SET PRCHY=$PIECE(PRCHY,".",1)+$JUSTIFY("."_Y,2,2)
+9 SET DIE="^PRC(442,"
SET DR="[PRCHAMT89]"
SET DA=PRCHPO
+10 IF PRCHDT
DO FPDS^PRCHFPD2
if $DATA(PRCHFLG)>0&(%=-1)
QUIT
if 'PRCHFPDS
GOTO EN10
+11 SET PRCH=""
FOR PRCHI=1:1
SET PRCH=$ORDER(PRCH("AM",PRCH))
if PRCH=""
QUIT
DO TYPE^PRCHNPO1
SET PRCHAMT=+PRCH("AM",PRCH)
SET PRCHCN=$SELECT(PRCH=".OM":"",1:PRCH)
WRITE ?40,"AMOUNT: ",PRCHAMT
SET PRCHAMT=""""_PRCHAMT_""""
SET DIE("NO^")="NO"
DO ^DIE
+12 ;PRC*5.1*79 - call new input templates for FPDS data.
+13 ;Check a regular PO from a Purchasing Agent.
+14 ;PRC*5.1*100 - if the user times out and does not complete the input
+15 ;template for the new FPDS, don't allow electronic sig. Check the last
+16 ;field required for the PO, based on the source code.
+17 ;
+18 IF ("25"[PRCHSC)
IF $DATA(^PRC(442,PRCHPO,14))
Begin DoDot:1
+19 SET DR="[PRCH NEW PO FPDS]"
DO ^DIE
+20 IF '$DATA(^PRC(442,PRCHPO,25))
DO STOP
QUIT
+21 IF $PIECE(^PRC(442,PRCHPO,25),U,6)=""
DO STOP
QUIT
+22 ;Fund agency code & fund agency office code can be empty in pairs only.
+23 IF +$PIECE(^PRC(442,PRCHPO,25),U,7)>0
IF $PIECE(^PRC(442,PRCHPO,25),U,8)=""
DO STOP
QUIT
End DoDot:1
if $GET(PRCHER)=1
GOTO Q
+24 ;End of changes for PRC*5.1*100.
+25 ;
+26 ;For FPDS purposes, consider any PO with any of the following source
+27 ;codes as a delivery order:
+28 ;PRC*5.1*100 - if the user times out, don't allow electronic sig.
+29 IF ("467B"[PRCHSC)&($DATA(^PRC(442,PRCHPO,14)))
Begin DoDot:1
+30 SET DR="[PRCH NEW PO FPDS]"
DO ^DIE
+31 IF '$DATA(^PRC(442,PRCHPO,25))
DO STOP
QUIT
+32 IF $PIECE(^PRC(442,PRCHPO,25),U,15)=""
DO STOP
QUIT
+33 IF '$TEST
DO POP^PRCHNPO1
End DoDot:1
if $GET(PRCHER)=1
GOTO Q
+34 ;
+35 ;Quit if type code, pref, program, etc., are not defined.
+36 IF '$DATA(^PRC(442,PRCHPO,9))
DO STOP
GOTO Q
+37 DO EN^DDIOL("Ok, let me save your changes.....done!","","!!?3")
DO ^PRCHSF
+38 ;End of changes for PRC*5.1*100.
+39 ;
+40 ;Send HL7 message to the AAC
+41 ;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 ;PRC*5.1*220
+42 ;End changes for PRC*5.1*79
+43 KILL DIE
FOR I=0:0
if '$DATA(PRCHPO)
QUIT
SET I=$ORDER(^PRC(442,PRCHPO,9,I))
if 'I
QUIT
if $PIECE(^(I,0),U,2)=""
DO ER2^PRCHNPO6
if '$ORDER(^(1,0))
DO ER3^PRCHNPO6
+44 LOCK -^PRC(442,PRCHPO)
IF $DATA(PRCHFLG)
KILL PRCHFLG
QUIT
+45 GOTO EN10
+46 ;
OUT ;Tell the user that the PO is not eligible for FPDS
+1 DO EN^DDIOL("This PO is not required for FPDS.","","!!?10")
+2 QUIT
+3 ;
STOP ;PRC*5.1*100 - quit if all the FPDS info was not entered.
+1 DO EN^DDIOL("WARNING: YOU HAVE NOT ENTERED ALL THE FPDS DATA - NO MESSAGE GENERATED.","","!!?5")
SET PRCHER=1
+2 QUIT
+3 ;End of changes for PRC*5.1*100.
+4 ;
TBL ;TABLE LINE/ITEM AMOUNTS MINUS DISCOUNTS BY CONTRACT NO.
+1 SET PRCHCN=$SELECT($PIECE(Y,U,2)'="":$PIECE(Y,U,2),1:".OM")
if '$DATA(PRCH("AM",PRCHCN))
SET PRCH("AM",PRCHCN)=""
SET PRCHEC=PRCHEC+1
+2 SET PRCH("AM",PRCHCN)=($PIECE(PRCH("AM",PRCHCN),U,1)+1)_"^"_($PIECE(PRCH("AM",PRCHCN),U,2)+Y-$PIECE(Y,U,6))_"^"_($PIECE(PRCH("AM",PRCHCN),U,3))_+X_","
if $LENGTH(PRCH("AM",PRCHCN))<240
QUIT
+3 ;
CNDNS NEW X,Y,I,J,C
SET C=","
SET X=$PIECE(PRCH("AM",PRCHCN),U,3)
+1 FOR I=1:1:999
if $PIECE(X,C,I)=""
QUIT
IF $PIECE(X,C,I)?.N
IF $PIECE(X,C,I+1)=($PIECE(X,C,I)+1)
FOR J=I+1:1:999
IF ($PIECE(X,C,J+1)'?1N.N)!(($PIECE(X,C,J)+1)'=$PIECE(X,C,J+1))
SET Y=C_$PIECE(X,C,I+1,J-1)_C
SET $PIECE(PRCH("AM",PRCHCN),U,3)=$PIECE(X,Y,1)_":1:"_$PIECE(X,Y,2)
SET I=999
SET J=999
+2 QUIT
+3 ;
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"
+1 KILL PRCHPO,PRCHNEW,DA,DIC,D0,DQ
SET DIC("S")="I +^(0)=PRC(""SITE"") S PRCHX=+$G(^(7)) I $D(^PRCD(442.3,PRCHX,0)),$P(^(0),U,2)>9"
+2 SET DIC="^PRC(442,"
SET DIC(0)="QEAMZ"
SET D="C"
SET DIC("A")="PURCHASE ORDER: "
if '$DATA(DIC("S"))
SET DIC("S")="I +$P(^(0),U,1)=PRC(""SITE"")"
+3 WRITE !!
DO IX^DIC
KILL DIC
SET X=""
if +Y<0
QUIT
SET (PRCHPO,DA)=+Y
+4 QUIT
+5 ;
ER WRITE !,$SELECT('PRCHDT:" Breakout Code is undefined.",1:" Socioeconomic Group (FY89) not defined in Vendor file."),$CHAR(7)
KILL PRCHPO
+1 QUIT
+2 ;
W WRITE !!,?10," Enter either Yes/No or enter ""^"" to exit."
+1 WRITE !!,"This option will delete all FPDS codes that were previously entered",!,"for this Purchase Order, then allow you to re-enter them."
+2 QUIT
+3 ;
+4 ;
Q LOCK -^PRC(442,PRCHPO)
KILL PRC,PRCHI,PRCHFLG
GOTO Q^PRCHNPO4
