Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHAAC

PRCHAAC.m

Go to the documentation of this file. 
  1. 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
  1.  ;Per VA Directive 6402, this routine should not be modified.
  1.  ; This routine will gather FPDS data for the new report requested
  1.  ; by the Austin Automation Center (AAC), create an HL7 message, and send
  1.  ; it to the Austin server via the VistA HL7 package.
  1.  ;
  1. AAC ; Start FPDS report here: Options for Detailed PC orders, Delivery
  1.  ; orders, and regular purchase orders created by a Purchasing Agent.
  1.  ; The variable PRCHPO is defined by the calling routines.
  1.  ;
  1.  ; The following segments will be used in the outgoing HL7 message:
  1.  ; MSH,MFI,MFE,CDM,PRC,ZPO.
  1.  ; Message Type: MFN  Event Type: M01.
  1.  ; The expected ACK from the AAC will consist of the following segments:
  1.  ; MSH,MSA,MFI,MFA.
  1.  ; Message Type: MFK  Event Type: M01.
  1.  ;
  1.  ;PRC*5.1*220 Added (Q)uit to ensure no more order FPDS info will be transmitted
  1.  ;
  1. STOP Q    ;Added quit to no longer process/transmit FPDS data    ;PRC*5.1*220
  1.  ; Get procurement detail for the purchase order.
  1.  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
  1.  N PRCAID,PRCAM,PRCCAD,PRCCN,PRCPF,PRCH2237,PRCIDV,PRCPIID,PRCFSC,PRCFSCI,PRCPER,PRCPP,PRCTC,PRCCFG,PRCGFE,PRCOD,PRCOFC,PRCSPEC,PRCPT,PRCROOT
  1.  N PRCEP,PRCEPC,PRCFAC,PRCFOC,PRCIEN,PRCLID,PRCMN,PRCMY,PRCNOF,PRCPAS,PRCPBC,PRCPD,PRCRM,PRCRMC,PRCRT,PRCSP,PRCSPC,PRCTSA,PRCTSAC,PRCUCD,PRCUV
  1.  ;
  1.  S U="^",PRCROOT=$P($G(^PRC(442,PRCHPO,0)),U,1),PRCROOT=$P(PRCROOT,"-")_$P(PRCROOT,"-",2)
  1.  ; Check PO for FPDS data 
  1.  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
  1.  ;
  1.  S PRCMOP=$P(^PRC(442,PRCHPO,0),U,2)
  1.  S PRCMOP=$S(PRCMOP=25:"Y",1:"N")        ; if a PC order, flag it with Y
  1.  ; Vendor pointer and name
  1.  S PRCPT=$P(^PRC(442,PRCHPO,1),U,1),PRCVEN=$P(^PRC(440,PRCPT,0),U,1)
  1.  ; If the vendor has '&' in its name, replace it with 'AND'
  1.  I PRCVEN["&" D
  1.  . S PRCSPEC("&")="AND"
  1.  . S PRCVEN=$$REPLACE^XLFSTR(PRCVEN,.PRCSPEC)
  1.  ;
  1.  S PRCDB=$P($G(^PRC(440,PRCPT,7)),U,12)  ; DUN & BRADSTREET #
  1.  S PRCBT=$P(^PRC(440,PRCPT,2),U,3)       ; business type (size)
  1.  ; Utimate Contract Value, Current Contract Value, and Dollars Obligated
  1.  ; will equal the total amount of PO below.
  1.  S PRCAMT=$P(^PRC(442,PRCHPO,0),U,15)    ; total amount of PO
  1.  I $G(PRCAMT)=0 D EN^DDIOL("A PO worth $0 is not required for FPDS transmission.") Q
  1.  ; As requested by the AAC rep, get the line item with the larget $$ and
  1.  ; report its FSC, Contract # if there is one, and the first 50 chars of
  1.  ; its description. Report only the TOTAL AMOUNT of PO, not the largest
  1.  ; line item's amount.  
  1.  ; 
  1.  S PRCLID=$$LIDT^PRCHAAC3(PRCHPO)        ; get line item detail
  1.  S PRCLEN=$P(PRCLID,U,3)                 ; line item description
  1.  ; Strip any space in front of the line item description
  1.  S PRCDES=$$TRIM^XLFSTR(PRCLEN,"L"," ")
  1.  ; Referenced Proc. Identifier (PIID) = contract number
  1.  S PRCCN=$P($G(PRCLID),U,5)              ; contract number if available
  1.  S PRCFSCI=$P($G(PRCLID),U,6)            ; internal FSC code or PSC code
  1.  S:$G(PRCFSCI)'="" PRCFSC=$P(^PRC(441.2,PRCFSCI,0),U,1)  ; external FSC value
  1.  ;
  1.  ; Get the purchase order's date. This is the 'effective start date.' 
  1.  I $D(^PRC(442,PRCHPO,1)) D                 ; all purchase orders
  1.  . S PRCOD=$P(^PRC(442,PRCHPO,1),U,15)      ; purchase order date
  1.  . S PRCOD=$$FMTHL7^XLFDT(PRCOD)            ; date in HL7 format
  1.  ;  
  1.  ; Date signed: if the PO is a Detailed PC order, or a delivery order:
  1.  I $P(^PRC(442,PRCHPO,23),U,11)'="" D
  1.  . S PRCH2237=$P(^PRC(442,PRCHPO,13,0),U,3)
  1.  . S PRCDS=$P($P(^PRC(442,PRCHPO,13,PRCH2237,0),U,4),".",1)
  1.  . S PRCDS=$$FMTHL7^XLFDT(PRCDS)       ; date signed (HL7 format)
  1.  ;
  1.  ; Date signed: if the Detailed PC order is from a Purchasing Agent:
  1.  I $P(^PRC(442,PRCHPO,0),U,2)=25,$P(^PRC(442,PRCHPO,23),U,11)="" D
  1.  . S PRCDS=$P($P(^PRC(442,PRCHPO,12),U,3),".",1) ; validation date/time
  1.  . S PRCDS=$$FMTHL7^XLFDT(PRCDS)        ; date signed (HL7 format)
  1.  ;
  1.  ; Date signed: for any other PO:
  1.  I $D(^PRC(442,PRCHPO,10)) D
  1.  . S PRCDS=$P($P(^PRC(442,PRCHPO,10,1,0),U,6),".",1)  ; date signed
  1.  . S PRCDS=$$FMTHL7^XLFDT(PRCDS)            ; date signed (HL7 format)
  1.  ;
  1.  ; The delivery date is stored at the same node for all orders. This date
  1.  ; is the same as 'effective end date'.
  1.  S PRCDD=$P(^PRC(442,PRCHPO,0),U,10)
  1.  S PRCDD=$$FMTHL7^XLFDT(PRCDD)           ; convert to HL7 format
  1.  ;
  1.  S PRCPD=$G(^PRC(442,PRCHPO,25))         ; po details new FPDS data node
  1.  S PRCEC=$P($G(PRCPD),U,12)              ; extent competed pointer
  1.  S:$G(PRCEC)'="" PRCECC=$P(^PRCD(420.53,+PRCEC,0),U,1) ; extent competed code
  1.  S PRCRN=$P($G(PRCPD),U,1)               ; reason not competed pointer
  1.  S:$G(PRCRN)'="" PRCRNC=$P(^PRCD(420.51,+PRCRN,0),U,1) ; reason not competed code
  1.  S PRCEPA=$P($G(PRCPD),U,10)            ; EPA designated product pointer
  1.  S PRCEPAC=$P($G(^PRCD(420.55,+PRCEPA,0)),U,1) ; EPA code
  1.  S PRCPP=$P(PRCPD,U,15)                 ; place of perf. this station?
  1.  S PRCPF=$P(PRCPD,U,16)                 ; place of performance
  1.  S PRCCB=$P(PRCPD,U,11)                 ; contract bundling
  1.  S PRCDUZ=$P(^PRC(442,PRCHPO,1),U,10)   ; pointer PA/PPM/Authorized Buyer
  1.  ; Contracting officer's name in format 'last_name^first_name'
  1.  S PRCPER=PRCDUZ_U_$P($P(^VA(200,PRCDUZ,0),U,1),",",1)_U_$P($P(^VA(200,PRCDUZ,0),U,1),",",2)
  1.  ;
  1.  ; By agreement with the requestor, the following will be hard-coded
  1.  ; values and will not be stored in IFCAP:
  1.  ; GFE (Government Furnished Eqmt) = 'N'
  1.  S PRCGFE="N"
  1.  ; Type of Contract = 'J'
  1.  S PRCTC="J"
  1.  ; Contract Funded by Foreign Gov. = 'N'
  1.  S PRCCFG="N"
  1.  ; Business Size = 'Small', 'Large', or 'Other'
  1.  S PRCBZ=$S(PRCBT=1:"SMALL",PRCBT=2:"LARGE",1:"OTHER")
  1.  ; Synopsis Waiver = 'N'
  1.  S PRCSW="N"
  1.  ; Agency Identifier = 3600
  1.  S PRCAID=3600
  1.  ; Contracting Agency Code = 3600
  1.  S PRCCAD=3600
  1.  ; Contracting Office Code = Station# preceeded by'00'
  1.  S PRCOFC="00"_$E(PRCROOT,1,3)
  1.  ; Fee paid for use of Indefinite Delivery Vehicle (IDV) = $0
  1.  S PRCIDV=0
  1.  ; Procurement identifier
  1.  S PRCPIID="V"_$E(PRCROOT,1,3)       ; always "V"+Station Number
  1.  ; End of hard-coded values. The rest of values come from the PO
  1.  ; 
  1.  ; By the HL7 Standard, the following will be defined:
  1.  ; Primary Key Value for segs MFE, CDM, and PRC: 'V'_Station#_PO Number.
  1.  ; Charge Description Short, CDM seg: 'PROCUREMENT DETAIL FROM IFCAP'.
  1.  ; 
  1.  S PRCAAD=$P(PRCPD,U,4)                    ; alternative advertising
  1.  S PRCATP=$P(^PRC(442,PRCHPO,1),U,7)       ; pointer for award type
  1.  S PRCAT=$P($G(^PRCD(420.8,+PRCATP,0)),U,1)
  1.  I "467B"[(PRCAT) S PRCAT="C"              ; delivery orders (contracts)
  1.  I "25"[(PRCAT) S PRCAT="B"                ; open market orders
  1.  ;
  1.  ; Get information for the record type
  1.  S PRCRT=+$P(^PRC(442,PRCHPO,7),U,2)        ; supply status order
  1.  I PRCRT<20 D EN^DDIOL("This PO does not qualify for FPDS transmission") Q
  1.  S PRCIEN=0 F  S PRCIEN=$O(^PRCD(442.3,PRCIEN)) Q:'PRCIEN  D
  1.  . I $P(^PRCD(442.3,PRCIEN,0),U,2)=PRCRT D
  1.  .. I $P(^PRCD(442.3,PRCIEN,0),U,1)'["Amended" S PRCRT="A" ; award
  1.  .. I $P(^PRCD(442.3,PRCIEN,0),U,1)["Amended" S PRCRT="M" ; modification
  1.  .. I $P(^PRCD(442.3,PRCIEN,0),U,1)["Cancelled" S PRCRT="D" ; deletion (cancellation)
  1.  S PRCSP=$P(PRCPD,U,5)                  ; solicitation procedure pointer
  1.  S PRCSPC=$P($G(^PRCD(420.52,+PRCSP,0)),U,1) ; solicitation proc. code
  1.  S PRCEP=$P(PRCPD,U,6)               ; evaluated preference pointer
  1.  S PRCEPC=$P($G(^PRCD(420.54,+PRCEP,0)),U,1) ; evaluated pref. code
  1.  S PRCFAC=$P(PRCPD,U,7)              ; funding agency code
  1.  S PRCFOC=$P(PRCPD,U,8)              ; funding agency office code
  1.  S PRCMY=$P(PRCPD,U,9)               ; multiyear contract
  1.  S PRCPAS=$P(PRCPD,U,3)              ; pre award synopsis
  1.  S PRCNOF=$P(PRCPD,U,2)              ; number of offers
  1.  S PRCUV=PRCAMT                      ; ultimate contract value
  1.  S PRCCV=PRCAMT                      ; current contract value
  1.  S PRCTSA=$P(^PRC(442,PRCHPO,9,1,0),U,5) ; type set aside = pref. program
  1.  S PRCTSAC=$P(^PRCD(420.6,+PRCTSA,0),U,1) ; type set aside code
  1.  S PRCPBC=$P(PRCPD,U,13)             ; perf. based service contract
  1.  S PRCCH=$P(PRCPD,U,14)              ; Clinger Cohen Act
  1.  S PRCUCD=PRCDD                      ; ultimate completion date
  1.  ; See if we have an amended order - authority = reason for amendment
  1.  I $D(^PRC(442,PRCHPO,6,0)) S PRCAM=1 D
  1.  . S PRCMN=$P(^PRC(442,PRCHPO,6,0),U,3) ; last amendment = modification #
  1.  . S PRCRM=$P(^PRC(442,PRCHPO,6,+PRCMN,0),U,4) ; reason for mod. pointer
  1.  . I 'PRCRM S PRCRMC="" Q
  1.  . S PRCRMC=$P(^PRCD(442.2,+PRCRM,0),U,1) ; reason mod. code desc.
  1.  . S PRCRMC=$S(PRCRMC="A":"D",PRCRMC="B":"M",PRCRMC="C":"B",PRCRMC="D":"D",PRCRMC="E":"N",1:"")
  1.  G ^PRCHAAC1