source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHAAC.m@ 1111

Last change on this file since 1111 was 613, checked in by George Lilly, 15 years ago

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