PRCHAAC ;WIFO/CR-CREATE HL7 IFCAP MESSAGE FOR AUSTIN AUTOMATION CENTER ;2/22/05 10:50 AM
;;5.1;IFCAP;**79,121,220**;Oct 20, 2000;Build 23
;Per VA Directive 6402, this routine should not be modified.
; This routine will gather FPDS data for the new report requested
; by the Austin Automation Center (AAC), create an HL7 message, and send
; it to the Austin server via the VistA HL7 package.
;
AAC ; Start FPDS report here: Options for Detailed PC orders, Delivery
; orders, and regular purchase orders created by a Purchasing Agent.
; The variable PRCHPO is defined by the calling routines.
;
; The following segments will be used in the outgoing HL7 message:
; MSH,MFI,MFE,CDM,PRC,ZPO.
; Message Type: MFN Event Type: M01.
; The expected ACK from the AAC will consist of the following segments:
; MSH,MSA,MFI,MFA.
; Message Type: MFK Event Type: M01.
;
;PRC*5.1*220 Added (Q)uit to ensure no more order FPDS info will be transmitted
;
STOP Q ;Added quit to no longer process/transmit FPDS data ;PRC*5.1*220
; Get procurement detail for the purchase order.
N PRCAAD,PRCAMT,PRCAT,PRCATP,PRCBT,PRCBZ,PRCCB,PRCCH,PRCCV,PRCDB,PRCDD,PRCDES,PRCDS,PRCDUZ,PRCEC,PRCECC,PRCEPA,PRCEPAC,PRCLEN,PRCMOP,PRCRN,PRCRNC,PRCSW,PRCVEN
N PRCAID,PRCAM,PRCCAD,PRCCN,PRCPF,PRCH2237,PRCIDV,PRCPIID,PRCFSC,PRCFSCI,PRCPER,PRCPP,PRCTC,PRCCFG,PRCGFE,PRCOD,PRCOFC,PRCSPEC,PRCPT,PRCROOT
N PRCEP,PRCEPC,PRCFAC,PRCFOC,PRCIEN,PRCLID,PRCMN,PRCMY,PRCNOF,PRCPAS,PRCPBC,PRCPD,PRCRM,PRCRMC,PRCRT,PRCSP,PRCSPC,PRCTSA,PRCTSAC,PRCUCD,PRCUV
;
S U="^",PRCROOT=$P($G(^PRC(442,PRCHPO,0)),U,1),PRCROOT=$P(PRCROOT,"-")_$P(PRCROOT,"-",2)
; Check PO for FPDS data
I '$D(^PRC(442,PRCHPO,25))!('$D(^PRC(442,PRCHPO,9,1,0))) D EN^DDIOL("This PO is not required for FPDS transmission.") Q
;
S PRCMOP=$P(^PRC(442,PRCHPO,0),U,2)
S PRCMOP=$S(PRCMOP=25:"Y",1:"N") ; if a PC order, flag it with Y
; Vendor pointer and name
S PRCPT=$P(^PRC(442,PRCHPO,1),U,1),PRCVEN=$P(^PRC(440,PRCPT,0),U,1)
; If the vendor has '&' in its name, replace it with 'AND'
I PRCVEN["&" D
. S PRCSPEC("&")="AND"
. S PRCVEN=$$REPLACE^XLFSTR(PRCVEN,.PRCSPEC)
;
S PRCDB=$P($G(^PRC(440,PRCPT,7)),U,12) ; DUN & BRADSTREET #
S PRCBT=$P(^PRC(440,PRCPT,2),U,3) ; business type (size)
; Utimate Contract Value, Current Contract Value, and Dollars Obligated
; will equal the total amount of PO below.
S PRCAMT=$P(^PRC(442,PRCHPO,0),U,15) ; total amount of PO
I $G(PRCAMT)=0 D EN^DDIOL("A PO worth $0 is not required for FPDS transmission.") Q
; As requested by the AAC rep, get the line item with the larget $$ and
; report its FSC, Contract # if there is one, and the first 50 chars of
; its description. Report only the TOTAL AMOUNT of PO, not the largest
; line item's amount.
;
S PRCLID=$$LIDT^PRCHAAC3(PRCHPO) ; get line item detail
S PRCLEN=$P(PRCLID,U,3) ; line item description
; Strip any space in front of the line item description
S PRCDES=$$TRIM^XLFSTR(PRCLEN,"L"," ")
; Referenced Proc. Identifier (PIID) = contract number
S PRCCN=$P($G(PRCLID),U,5) ; contract number if available
S PRCFSCI=$P($G(PRCLID),U,6) ; internal FSC code or PSC code
S:$G(PRCFSCI)'="" PRCFSC=$P(^PRC(441.2,PRCFSCI,0),U,1) ; external FSC value
;
; Get the purchase order's date. This is the 'effective start date.'
I $D(^PRC(442,PRCHPO,1)) D ; all purchase orders
. S PRCOD=$P(^PRC(442,PRCHPO,1),U,15) ; purchase order date
. S PRCOD=$$FMTHL7^XLFDT(PRCOD) ; date in HL7 format
;
; Date signed: if the PO is a Detailed PC order, or a delivery order:
I $P(^PRC(442,PRCHPO,23),U,11)'="" D
. S PRCH2237=$P(^PRC(442,PRCHPO,13,0),U,3)
. S PRCDS=$P($P(^PRC(442,PRCHPO,13,PRCH2237,0),U,4),".",1)
. S PRCDS=$$FMTHL7^XLFDT(PRCDS) ; date signed (HL7 format)
;
; Date signed: if the Detailed PC order is from a Purchasing Agent:
I $P(^PRC(442,PRCHPO,0),U,2)=25,$P(^PRC(442,PRCHPO,23),U,11)="" D
. S PRCDS=$P($P(^PRC(442,PRCHPO,12),U,3),".",1) ; validation date/time
. S PRCDS=$$FMTHL7^XLFDT(PRCDS) ; date signed (HL7 format)
;
; Date signed: for any other PO:
I $D(^PRC(442,PRCHPO,10)) D
. S PRCDS=$P($P(^PRC(442,PRCHPO,10,1,0),U,6),".",1) ; date signed
. S PRCDS=$$FMTHL7^XLFDT(PRCDS) ; date signed (HL7 format)
;
; The delivery date is stored at the same node for all orders. This date
; is the same as 'effective end date'.
S PRCDD=$P(^PRC(442,PRCHPO,0),U,10)
S PRCDD=$$FMTHL7^XLFDT(PRCDD) ; convert to HL7 format
;
S PRCPD=$G(^PRC(442,PRCHPO,25)) ; po details new FPDS data node
S PRCEC=$P($G(PRCPD),U,12) ; extent competed pointer
S:$G(PRCEC)'="" PRCECC=$P(^PRCD(420.53,+PRCEC,0),U,1) ; extent competed code
S PRCRN=$P($G(PRCPD),U,1) ; reason not competed pointer
S:$G(PRCRN)'="" PRCRNC=$P(^PRCD(420.51,+PRCRN,0),U,1) ; reason not competed code
S PRCEPA=$P($G(PRCPD),U,10) ; EPA designated product pointer
S PRCEPAC=$P($G(^PRCD(420.55,+PRCEPA,0)),U,1) ; EPA code
S PRCPP=$P(PRCPD,U,15) ; place of perf. this station?
S PRCPF=$P(PRCPD,U,16) ; place of performance
S PRCCB=$P(PRCPD,U,11) ; contract bundling
S PRCDUZ=$P(^PRC(442,PRCHPO,1),U,10) ; pointer PA/PPM/Authorized Buyer
; Contracting officer's name in format 'last_name^first_name'
S PRCPER=PRCDUZ_U_$P($P(^VA(200,PRCDUZ,0),U,1),",",1)_U_$P($P(^VA(200,PRCDUZ,0),U,1),",",2)
;
; By agreement with the requestor, the following will be hard-coded
; values and will not be stored in IFCAP:
; GFE (Government Furnished Eqmt) = 'N'
S PRCGFE="N"
; Type of Contract = 'J'
S PRCTC="J"
; Contract Funded by Foreign Gov. = 'N'
S PRCCFG="N"
; Business Size = 'Small', 'Large', or 'Other'
S PRCBZ=$S(PRCBT=1:"SMALL",PRCBT=2:"LARGE",1:"OTHER")
; Synopsis Waiver = 'N'
S PRCSW="N"
; Agency Identifier = 3600
S PRCAID=3600
; Contracting Agency Code = 3600
S PRCCAD=3600
; Contracting Office Code = Station# preceeded by'00'
S PRCOFC="00"_$E(PRCROOT,1,3)
; Fee paid for use of Indefinite Delivery Vehicle (IDV) = $0
S PRCIDV=0
; Procurement identifier
S PRCPIID="V"_$E(PRCROOT,1,3) ; always "V"+Station Number
; End of hard-coded values. The rest of values come from the PO
;
; By the HL7 Standard, the following will be defined:
; Primary Key Value for segs MFE, CDM, and PRC: 'V'_Station#_PO Number.
; Charge Description Short, CDM seg: 'PROCUREMENT DETAIL FROM IFCAP'.
;
S PRCAAD=$P(PRCPD,U,4) ; alternative advertising
S PRCATP=$P(^PRC(442,PRCHPO,1),U,7) ; pointer for award type
S PRCAT=$P($G(^PRCD(420.8,+PRCATP,0)),U,1)
I "467B"[(PRCAT) S PRCAT="C" ; delivery orders (contracts)
I "25"[(PRCAT) S PRCAT="B" ; open market orders
;
; Get information for the record type
S PRCRT=+$P(^PRC(442,PRCHPO,7),U,2) ; supply status order
I PRCRT<20 D EN^DDIOL("This PO does not qualify for FPDS transmission") Q
S PRCIEN=0 F S PRCIEN=$O(^PRCD(442.3,PRCIEN)) Q:'PRCIEN D
. I $P(^PRCD(442.3,PRCIEN,0),U,2)=PRCRT D
.. I $P(^PRCD(442.3,PRCIEN,0),U,1)'["Amended" S PRCRT="A" ; award
.. I $P(^PRCD(442.3,PRCIEN,0),U,1)["Amended" S PRCRT="M" ; modification
.. I $P(^PRCD(442.3,PRCIEN,0),U,1)["Cancelled" S PRCRT="D" ; deletion (cancellation)
S PRCSP=$P(PRCPD,U,5) ; solicitation procedure pointer
S PRCSPC=$P($G(^PRCD(420.52,+PRCSP,0)),U,1) ; solicitation proc. code
S PRCEP=$P(PRCPD,U,6) ; evaluated preference pointer
S PRCEPC=$P($G(^PRCD(420.54,+PRCEP,0)),U,1) ; evaluated pref. code
S PRCFAC=$P(PRCPD,U,7) ; funding agency code
S PRCFOC=$P(PRCPD,U,8) ; funding agency office code
S PRCMY=$P(PRCPD,U,9) ; multiyear contract
S PRCPAS=$P(PRCPD,U,3) ; pre award synopsis
S PRCNOF=$P(PRCPD,U,2) ; number of offers
S PRCUV=PRCAMT ; ultimate contract value
S PRCCV=PRCAMT ; current contract value
S PRCTSA=$P(^PRC(442,PRCHPO,9,1,0),U,5) ; type set aside = pref. program
S PRCTSAC=$P(^PRCD(420.6,+PRCTSA,0),U,1) ; type set aside code
S PRCPBC=$P(PRCPD,U,13) ; perf. based service contract
S PRCCH=$P(PRCPD,U,14) ; Clinger Cohen Act
S PRCUCD=PRCDD ; ultimate completion date
; See if we have an amended order - authority = reason for amendment
I $D(^PRC(442,PRCHPO,6,0)) S PRCAM=1 D
. S PRCMN=$P(^PRC(442,PRCHPO,6,0),U,3) ; last amendment = modification #
. S PRCRM=$P(^PRC(442,PRCHPO,6,+PRCMN,0),U,4) ; reason for mod. pointer
. I 'PRCRM S PRCRMC="" Q
. S PRCRMC=$P(^PRCD(442.2,+PRCRM,0),U,1) ; reason mod. code desc.
. S PRCRMC=$S(PRCRMC="A":"D",PRCRMC="B":"M",PRCRMC="C":"B",PRCRMC="D":"D",PRCRMC="E":"N",1:"")
G ^PRCHAAC1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHAAC 8960 printed Sep 23, 2025@19:41:35 Page 2
PRCHAAC ;WIFO/CR-CREATE HL7 IFCAP MESSAGE FOR AUSTIN AUTOMATION CENTER ;2/22/05 10:50 AM
+1 ;;5.1;IFCAP;**79,121,220**;Oct 20, 2000;Build 23
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ; This routine will gather FPDS data for the new report requested
+4 ; by the Austin Automation Center (AAC), create an HL7 message, and send
+5 ; it to the Austin server via the VistA HL7 package.
+6 ;
AAC ; Start FPDS report here: Options for Detailed PC orders, Delivery
+1 ; orders, and regular purchase orders created by a Purchasing Agent.
+2 ; The variable PRCHPO is defined by the calling routines.
+3 ;
+4 ; The following segments will be used in the outgoing HL7 message:
+5 ; MSH,MFI,MFE,CDM,PRC,ZPO.
+6 ; Message Type: MFN Event Type: M01.
+7 ; The expected ACK from the AAC will consist of the following segments:
+8 ; MSH,MSA,MFI,MFA.
+9 ; Message Type: MFK Event Type: M01.
+10 ;
+11 ;PRC*5.1*220 Added (Q)uit to ensure no more order FPDS info will be transmitted
+12 ;
STOP ;Added quit to no longer process/transmit FPDS data ;PRC*5.1*220
QUIT
+1 ; Get procurement detail for the purchase order.
+2 NEW PRCAAD,PRCAMT,PRCAT,PRCATP,PRCBT,PRCBZ,PRCCB,PRCCH,PRCCV,PRCDB,PRCDD,PRCDES,PRCDS,PRCDUZ,PRCEC,PRCECC,PRCEPA,PRCEPAC,PRCLEN,PRCMOP,PRCRN,PRCRNC,PRCSW,PRCVEN
+3 NEW PRCAID,PRCAM,PRCCAD,PRCCN,PRCPF,PRCH2237,PRCIDV,PRCPIID,PRCFSC,PRCFSCI,PRCPER,PRCPP,PRCTC,PRCCFG,PRCGFE,PRCOD,PRCOFC,PRCSPEC,PRCPT,PRCROOT
+4 NEW PRCEP,PRCEPC,PRCFAC,PRCFOC,PRCIEN,PRCLID,PRCMN,PRCMY,PRCNOF,PRCPAS,PRCPBC,PRCPD,PRCRM,PRCRMC,PRCRT,PRCSP,PRCSPC,PRCTSA,PRCTSAC,PRCUCD,PRCUV
+5 ;
+6 SET U="^"
SET PRCROOT=$PIECE($GET(^PRC(442,PRCHPO,0)),U,1)
SET PRCROOT=$PIECE(PRCROOT,"-")_$PIECE(PRCROOT,"-",2)
+7 ; Check PO for FPDS data
+8 IF '$DATA(^PRC(442,PRCHPO,25))!('$DATA(^PRC(442,PRCHPO,9,1,0)))
DO EN^DDIOL("This PO is not required for FPDS transmission.")
QUIT
+9 ;
+10 SET PRCMOP=$PIECE(^PRC(442,PRCHPO,0),U,2)
+11 ; if a PC order, flag it with Y
SET PRCMOP=$SELECT(PRCMOP=25:"Y",1:"N")
+12 ; Vendor pointer and name
+13 SET PRCPT=$PIECE(^PRC(442,PRCHPO,1),U,1)
SET PRCVEN=$PIECE(^PRC(440,PRCPT,0),U,1)
+14 ; If the vendor has '&' in its name, replace it with 'AND'
+15 IF PRCVEN["&"
Begin DoDot:1
+16 SET PRCSPEC("&")="AND"
+17 SET PRCVEN=$$REPLACE^XLFSTR(PRCVEN,.PRCSPEC)
End DoDot:1
+18 ;
+19 ; DUN & BRADSTREET #
SET PRCDB=$PIECE($GET(^PRC(440,PRCPT,7)),U,12)
+20 ; business type (size)
SET PRCBT=$PIECE(^PRC(440,PRCPT,2),U,3)
+21 ; Utimate Contract Value, Current Contract Value, and Dollars Obligated
+22 ; will equal the total amount of PO below.
+23 ; total amount of PO
SET PRCAMT=$PIECE(^PRC(442,PRCHPO,0),U,15)
+24 IF $GET(PRCAMT)=0
DO EN^DDIOL("A PO worth $0 is not required for FPDS transmission.")
QUIT
+25 ; As requested by the AAC rep, get the line item with the larget $$ and
+26 ; report its FSC, Contract # if there is one, and the first 50 chars of
+27 ; its description. Report only the TOTAL AMOUNT of PO, not the largest
+28 ; line item's amount.
+29 ;
+30 ; get line item detail
SET PRCLID=$$LIDT^PRCHAAC3(PRCHPO)
+31 ; line item description
SET PRCLEN=$PIECE(PRCLID,U,3)
+32 ; Strip any space in front of the line item description
+33 SET PRCDES=$$TRIM^XLFSTR(PRCLEN,"L"," ")
+34 ; Referenced Proc. Identifier (PIID) = contract number
+35 ; contract number if available
SET PRCCN=$PIECE($GET(PRCLID),U,5)
+36 ; internal FSC code or PSC code
SET PRCFSCI=$PIECE($GET(PRCLID),U,6)
+37 ; external FSC value
if $GET(PRCFSCI)'=""
SET PRCFSC=$PIECE(^PRC(441.2,PRCFSCI,0),U,1)
+38 ;
+39 ; Get the purchase order's date. This is the 'effective start date.'
+40 ; all purchase orders
IF $DATA(^PRC(442,PRCHPO,1))
Begin DoDot:1
+41 ; purchase order date
SET PRCOD=$PIECE(^PRC(442,PRCHPO,1),U,15)
+42 ; date in HL7 format
SET PRCOD=$$FMTHL7^XLFDT(PRCOD)
End DoDot:1
+43 ;
+44 ; Date signed: if the PO is a Detailed PC order, or a delivery order:
+45 IF $PIECE(^PRC(442,PRCHPO,23),U,11)'=""
Begin DoDot:1
+46 SET PRCH2237=$PIECE(^PRC(442,PRCHPO,13,0),U,3)
+47 SET PRCDS=$PIECE($PIECE(^PRC(442,PRCHPO,13,PRCH2237,0),U,4),".",1)
+48 ; date signed (HL7 format)
SET PRCDS=$$FMTHL7^XLFDT(PRCDS)
End DoDot:1
+49 ;
+50 ; Date signed: if the Detailed PC order is from a Purchasing Agent:
+51 IF $PIECE(^PRC(442,PRCHPO,0),U,2)=25
IF $PIECE(^PRC(442,PRCHPO,23),U,11)=""
Begin DoDot:1
+52 ; validation date/time
SET PRCDS=$PIECE($PIECE(^PRC(442,PRCHPO,12),U,3),".",1)
+53 ; date signed (HL7 format)
SET PRCDS=$$FMTHL7^XLFDT(PRCDS)
End DoDot:1
+54 ;
+55 ; Date signed: for any other PO:
+56 IF $DATA(^PRC(442,PRCHPO,10))
Begin DoDot:1
+57 ; date signed
SET PRCDS=$PIECE($PIECE(^PRC(442,PRCHPO,10,1,0),U,6),".",1)
+58 ; date signed (HL7 format)
SET PRCDS=$$FMTHL7^XLFDT(PRCDS)
End DoDot:1
+59 ;
+60 ; The delivery date is stored at the same node for all orders. This date
+61 ; is the same as 'effective end date'.
+62 SET PRCDD=$PIECE(^PRC(442,PRCHPO,0),U,10)
+63 ; convert to HL7 format
SET PRCDD=$$FMTHL7^XLFDT(PRCDD)
+64 ;
+65 ; po details new FPDS data node
SET PRCPD=$GET(^PRC(442,PRCHPO,25))
+66 ; extent competed pointer
SET PRCEC=$PIECE($GET(PRCPD),U,12)
+67 ; extent competed code
if $GET(PRCEC)'=""
SET PRCECC=$PIECE(^PRCD(420.53,+PRCEC,0),U,1)
+68 ; reason not competed pointer
SET PRCRN=$PIECE($GET(PRCPD),U,1)
+69 ; reason not competed code
if $GET(PRCRN)'=""
SET PRCRNC=$PIECE(^PRCD(420.51,+PRCRN,0),U,1)
+70 ; EPA designated product pointer
SET PRCEPA=$PIECE($GET(PRCPD),U,10)
+71 ; EPA code
SET PRCEPAC=$PIECE($GET(^PRCD(420.55,+PRCEPA,0)),U,1)
+72 ; place of perf. this station?
SET PRCPP=$PIECE(PRCPD,U,15)
+73 ; place of performance
SET PRCPF=$PIECE(PRCPD,U,16)
+74 ; contract bundling
SET PRCCB=$PIECE(PRCPD,U,11)
+75 ; pointer PA/PPM/Authorized Buyer
SET PRCDUZ=$PIECE(^PRC(442,PRCHPO,1),U,10)
+76 ; Contracting officer's name in format 'last_name^first_name'
+77 SET PRCPER=PRCDUZ_U_$PIECE($PIECE(^VA(200,PRCDUZ,0),U,1),",",1)_U_$PIECE($PIECE(^VA(200,PRCDUZ,0),U,1),",",2)
+78 ;
+79 ; By agreement with the requestor, the following will be hard-coded
+80 ; values and will not be stored in IFCAP:
+81 ; GFE (Government Furnished Eqmt) = 'N'
+82 SET PRCGFE="N"
+83 ; Type of Contract = 'J'
+84 SET PRCTC="J"
+85 ; Contract Funded by Foreign Gov. = 'N'
+86 SET PRCCFG="N"
+87 ; Business Size = 'Small', 'Large', or 'Other'
+88 SET PRCBZ=$SELECT(PRCBT=1:"SMALL",PRCBT=2:"LARGE",1:"OTHER")
+89 ; Synopsis Waiver = 'N'
+90 SET PRCSW="N"
+91 ; Agency Identifier = 3600
+92 SET PRCAID=3600
+93 ; Contracting Agency Code = 3600
+94 SET PRCCAD=3600
+95 ; Contracting Office Code = Station# preceeded by'00'
+96 SET PRCOFC="00"_$EXTRACT(PRCROOT,1,3)
+97 ; Fee paid for use of Indefinite Delivery Vehicle (IDV) = $0
+98 SET PRCIDV=0
+99 ; Procurement identifier
+100 ; always "V"+Station Number
SET PRCPIID="V"_$EXTRACT(PRCROOT,1,3)
+101 ; End of hard-coded values. The rest of values come from the PO
+102 ;
+103 ; By the HL7 Standard, the following will be defined:
+104 ; Primary Key Value for segs MFE, CDM, and PRC: 'V'_Station#_PO Number.
+105 ; Charge Description Short, CDM seg: 'PROCUREMENT DETAIL FROM IFCAP'.
+106 ;
+107 ; alternative advertising
SET PRCAAD=$PIECE(PRCPD,U,4)
+108 ; pointer for award type
SET PRCATP=$PIECE(^PRC(442,PRCHPO,1),U,7)
+109 SET PRCAT=$PIECE($GET(^PRCD(420.8,+PRCATP,0)),U,1)
+110 ; delivery orders (contracts)
IF "467B"[(PRCAT)
SET PRCAT="C"
+111 ; open market orders
IF "25"[(PRCAT)
SET PRCAT="B"
+112 ;
+113 ; Get information for the record type
+114 ; supply status order
SET PRCRT=+$PIECE(^PRC(442,PRCHPO,7),U,2)
+115 IF PRCRT<20
DO EN^DDIOL("This PO does not qualify for FPDS transmission")
QUIT
+116 SET PRCIEN=0
FOR
SET PRCIEN=$ORDER(^PRCD(442.3,PRCIEN))
if 'PRCIEN
QUIT
Begin DoDot:1
+117 IF $PIECE(^PRCD(442.3,PRCIEN,0),U,2)=PRCRT
Begin DoDot:2
+118 ; award
IF $PIECE(^PRCD(442.3,PRCIEN,0),U,1)'["Amended"
SET PRCRT="A"
+119 ; modification
IF $PIECE(^PRCD(442.3,PRCIEN,0),U,1)["Amended"
SET PRCRT="M"
+120 ; deletion (cancellation)
IF $PIECE(^PRCD(442.3,PRCIEN,0),U,1)["Cancelled"
SET PRCRT="D"
End DoDot:2
End DoDot:1
+121 ; solicitation procedure pointer
SET PRCSP=$PIECE(PRCPD,U,5)
+122 ; solicitation proc. code
SET PRCSPC=$PIECE($GET(^PRCD(420.52,+PRCSP,0)),U,1)
+123 ; evaluated preference pointer
SET PRCEP=$PIECE(PRCPD,U,6)
+124 ; evaluated pref. code
SET PRCEPC=$PIECE($GET(^PRCD(420.54,+PRCEP,0)),U,1)
+125 ; funding agency code
SET PRCFAC=$PIECE(PRCPD,U,7)
+126 ; funding agency office code
SET PRCFOC=$PIECE(PRCPD,U,8)
+127 ; multiyear contract
SET PRCMY=$PIECE(PRCPD,U,9)
+128 ; pre award synopsis
SET PRCPAS=$PIECE(PRCPD,U,3)
+129 ; number of offers
SET PRCNOF=$PIECE(PRCPD,U,2)
+130 ; ultimate contract value
SET PRCUV=PRCAMT
+131 ; current contract value
SET PRCCV=PRCAMT
+132 ; type set aside = pref. program
SET PRCTSA=$PIECE(^PRC(442,PRCHPO,9,1,0),U,5)
+133 ; type set aside code
SET PRCTSAC=$PIECE(^PRCD(420.6,+PRCTSA,0),U,1)
+134 ; perf. based service contract
SET PRCPBC=$PIECE(PRCPD,U,13)
+135 ; Clinger Cohen Act
SET PRCCH=$PIECE(PRCPD,U,14)
+136 ; ultimate completion date
SET PRCUCD=PRCDD
+137 ; See if we have an amended order - authority = reason for amendment
+138 IF $DATA(^PRC(442,PRCHPO,6,0))
SET PRCAM=1
Begin DoDot:1
+139 ; last amendment = modification #
SET PRCMN=$PIECE(^PRC(442,PRCHPO,6,0),U,3)
+140 ; reason for mod. pointer
SET PRCRM=$PIECE(^PRC(442,PRCHPO,6,+PRCMN,0),U,4)
+141 IF 'PRCRM
SET PRCRMC=""
QUIT
+142 ; reason mod. code desc.
SET PRCRMC=$PIECE(^PRCD(442.2,+PRCRM,0),U,1)
+143 SET PRCRMC=$SELECT(PRCRMC="A":"D",PRCRMC="B":"M",PRCRMC="C":"B",PRCRMC="D":"D",PRCRMC="E":"N",1:"")
End DoDot:1
+144 GOTO ^PRCHAAC1
