PRCHAAC1 ;WIFO/CR-CONT. OF IFCAP HL7 MESSAGE TO AUSTIN ;3/4/05 11:43 AM
;;5.1;IFCAP;**79,105**;Oct 20, 2000;Build 4
;Per VHA Directive 10-93-142, this routine should not be modified.
;
; This routine is called from the routine PRCHAAC.
; Set up HL7 environment for message.
K HLA,HL,HLFS,HLCS,HLRS
N PRCAPPO,PRCPPA,PRCERR,PRCMID,PRCMSG,PRCSEG,PRCSUB,PRCPROT,PRCRSULT,PRCOPTNS
S PRCDUZ=$G(DUZ) I +PRCDUZ'>0 D EN^DDIOL("User undefined","","!!?5") Q 0 ;DUZ is system-supplied
S PRCPROT="PRC_IFCAP_01_EV_AAC"
D INIT^HLFNC2(PRCPROT,.HL)
I $G(HL) D Q 0 ;tell user if there was an error
. S PRCMSG=0
. I $P(HL,"^",2)]"" D
.. D:'$D(ZTQUEUED) EN^DDIOL("Error: "_$P(HL,"^",2)_" occurred. Please try later.")
;
S HLFS=$G(HL("FS")) ;field separator
S HLCS=$E(HL("ECH"),1) ;component separator
S HLRS=$E(HL("ECH"),2) ;repetition separator
;
;======== MFI Segment ===========
S PRCSEG="MFI"_HLFS_"CDM"_HLFS_HLFS_"UPD"_HLFS_HLFS_HLFS_"AL"
S HLA("HLS",1)=PRCSEG
;
;======== MFE Segment ===========
S PRCSEG="MFE"_HLFS_"MAD"_HLFS_HLFS
S $P(PRCSEG,HLFS,5)="V"_PRCROOT_HLFS_"CE" ;primary key value
S HLA("HLS",2)=PRCSEG
;
;======== CDM Segment ===========
S PRCSEG="CDM"
S $P(PRCSEG,HLFS,2)="V"_PRCROOT ;primary key value
S $P(PRCSEG,HLFS,4)="PROCUREMENT DETAIL FROM IFCAP"
S $P(PRCSEG,HLFS,12)=PRCCN ;contract number
S:$G(PRCAM)="" $P(PRCSEG,HLFS,13)=PRCVEN_HLCS_HLCS_PRCDB
S HLA("HLS",3)=PRCSEG
;
;======== PRC Segment ===========
S PRCSEG="PRC"
S $P(PRCSEG,HLFS,2)="V"_PRCROOT ;primary key value
S:$G(PRCAM)="" $P(PRCSEG,HLFS,10)="0"_HLCS_"US"
S $P(PRCSEG,HLFS,11)=PRCAMT_HLCS_"US"
S $P(PRCSEG,HLFS,12)=$G(PRCOD) ;effective start date = P.O. Date
S $P(PRCSEG,HLFS,13)=$G(PRCDD) ;effective end date = delivery date
S HLA("HLS",4)=PRCSEG
;
;======== ZPO Segment ===========
; Purchase order details - check if this PO has been amended and get
; just a few fields for this segment as requested by Austin Automation
; Center (AAC)
I $D(^PRC(442,PRCHPO,6,0)) G AMEND
S PRCSEG="ZPO"
S:$G(PRCECC)'="" $P(PRCSEG,HLFS,2)=PRCECC ;extent competed
S:$G(PRCRNC)'="" $P(PRCSEG,HLFS,3)=PRCRNC ;reason not competed
S $P(PRCSEG,HLFS,4)=PRCEPAC ;EPA designated product
S:$G(PRCFSC)'="" $P(PRCSEG,HLFS,5)=PRCFSC ;Federal Supply Class. (or PSC code)
S $P(PRCSEG,HLFS,6)=PRCPP ;place of performance question
S $P(PRCSEG,HLFS,7)=PRCPF ;place of performance
S $P(PRCSEG,HLFS,8)=PRCCB ;contract bundling
S $P(PRCSEG,HLFS,9)="N" ;government furnished eqmt.
S $P(PRCSEG,HLFS,10)=PRCPER ;DUZ^LastName^FirstName (contr. officer)
S $P(PRCSEG,HLFS,11)=PRCMOP ;method of processing
S $P(PRCSEG,HLFS,12)="J" ;type of contract
S $P(PRCSEG,HLFS,13)=PRCAAD ;alternative advertising
S $P(PRCSEG,HLFS,14)=$G(PRCDS) ;date PO was signed
S $P(PRCSEG,HLFS,15)=PRCAT ;award type
S $P(PRCSEG,HLFS,16)=PRCRT ;record type
S $P(PRCSEG,HLFS,17)=PRCSPC ;solicitation procedure
S $P(PRCSEG,HLFS,18)=PRCEPC ;evaluated preference
S $P(PRCSEG,HLFS,19)=PRCFAC ;funding agency code
S $P(PRCSEG,HLFS,20)="N" ;contract funded by foreign gov.
S $P(PRCSEG,HLFS,21)=PRCFOC ;funding agency office code
S $P(PRCSEG,HLFS,22)=PRCMY ;multiyear (for contracts)
S $P(PRCSEG,HLFS,23)=PRCPAS ;pre award synopsis
S $P(PRCSEG,HLFS,24)="N" ;synopsis waiver
S $P(PRCSEG,HLFS,25)=PRCNOF ;number of offers
S $P(PRCSEG,HLFS,26)=PRCUV_HLCS_"US" ;ultimate contract value
S $P(PRCSEG,HLFS,27)=PRCCV_HLCS_"US" ;current contract value
S $P(PRCSEG,HLFS,28)=PRCDES ;description of reqmt. (line item)
S $P(PRCSEG,HLFS,29)=3600 ;agency identifier
S $P(PRCSEG,HLFS,30)=PRCBZ ;business size
S $P(PRCSEG,HLFS,31)=PRCTSAC ;type set aside
S $P(PRCSEG,HLFS,32)=PRCPBC ;perf. based service contract
S $P(PRCSEG,HLFS,33)=3600 ;contracting agency code
S $P(PRCSEG,HLFS,34)=PRCOFC ;contracting office code
S $P(PRCSEG,HLFS,35)=PRCCH ;Clinger Cohen Act
S $P(PRCSEG,HLFS,37)=PRCUCD ;ultimate completion date
S HLA("HLS",5)=PRCSEG
G GEN
;
AMEND ; Get ready for a short amended message
S PRCSEG="ZPO"
S $P(PRCSEG,HLFS,14)=PRCDS ;date PO was signed
S $P(PRCSEG,HLFS,16)=PRCRT ;record type
S $P(PRCSEG,HLFS,20)="N" ;contract funded by foreign govt.
S $P(PRCSEG,HLFS,26)=PRCUV_HLCS_"US" ;ultimate contract value
S $P(PRCSEG,HLFS,27)=PRCCV_HLCS_"US" ;current contract value
S $P(PRCSEG,HLFS,29)=3600 ;agency identifier
S $P(PRCSEG,HLFS,33)=3600 ;contracting agency code
S $P(PRCSEG,HLFS,34)=PRCOFC ;contracting office code
S $P(PRCSEG,HLFS,36)=$G(PRCMN) ;modification number (amendment #)
S $P(PRCSEG,HLFS,38)=$G(PRCRMC) ;reason for mod. (amend authority)
S HLA("HLS",5)=PRCSEG
;
; Call HL7 to build/send message and get its number (PRCMID)
GEN D GENERATE^HLMA(PRCPROT,"LM",1,.PRCRSULT,"",.PRCOPTNS)
I $P(PRCRSULT,U,1)]"" S PRCMID=$P(PRCRSULT,U,1)
S PRCSUB=$S(PRCMID>0:"PRCHAAC1;"_PRCMID,1:"PRCHAAC1;"_"No MID")
MAIL2 ;
S MSG(1,0)="The following Purchase Order transaction has been sent "
S MSG(2,0)="to the Austin Automation Center (AAC) to report"
S MSG(3,0)="required FPDS information. Please keep this information"
S MSG(4,0)="for two weeks for tracking purposes."
S MSG(5,0)=" "
S MSG(6,0)="Purchase Order Number: "_$E(PRCROOT,1,3)_"-"_$E(PRCROOT,4,9)
S MSG(7,0)=" "
S MSG(8,0)="The HL7 Message # is: "_PRCMID
S XMSUB="Message for PO #: "_$E(PRCROOT,1,3)_"-"_$E(PRCROOT,4,9)_" to the AAC"
; Get approving official for a delivery order, certified invoice, etc.
I $D(^PRC(442,PRCHPO,10)) D
. I $P(^PRC(442,PRCHPO,23),U,11)="D" S PRCAPPO=$P(^PRC(442,PRCHPO,10,1,0),U,2)
. E S PRCAPPO=$P(^PRC(442,PRCHPO,10,1,0),U,2)
;
; Get approving official for an order created by a purchasing agent
I $P($G(^PRC(442,PRCHPO,23)),U,11)="" D
. I '$D(^PRC(442,PRCHPO,13)) Q
. S PRC2237=$P(^PRC(442,PRCHPO,13,0),U,3)
. S PRCAPPO=$P(^PRC(442,PRCHPO,13,PRC2237,0),U,2)
;
; Get authorized buyer for all POs
S PRCPPA=$P(^PRC(442,PRCHPO,1),U,10)
S XMDUZ=PRCDUZ
S XMY(PRCPPA)=""
S:$G(PRCAPPO)'="" XMY(PRCAPPO)=""
S XMTEXT="MSG("
D ^XMD
;
D LOG^PRCHAAC2 ;log record of outgoing message to the AAC
; Keep track of any error found
I $P(PRCRSULT,U,2,3)]"",+PRCMID=0 D
. S PRCMID=$P(PRCRSULT,U,2,3)
. S PRCERR=1
. D REC^PRCHAAC2
K HLA,HL,HLFS,HLCS,HLRS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHAAC1 6719 printed Oct 16, 2024@18:06:17 Page 2
PRCHAAC1 ;WIFO/CR-CONT. OF IFCAP HL7 MESSAGE TO AUSTIN ;3/4/05 11:43 AM
+1 ;;5.1;IFCAP;**79,105**;Oct 20, 2000;Build 4
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; This routine is called from the routine PRCHAAC.
+5 ; Set up HL7 environment for message.
+6 KILL HLA,HL,HLFS,HLCS,HLRS
+7 NEW PRCAPPO,PRCPPA,PRCERR,PRCMID,PRCMSG,PRCSEG,PRCSUB,PRCPROT,PRCRSULT,PRCOPTNS
+8 ;DUZ is system-supplied
SET PRCDUZ=$GET(DUZ)
IF +PRCDUZ'>0
DO EN^DDIOL("User undefined","","!!?5")
QUIT 0
+9 SET PRCPROT="PRC_IFCAP_01_EV_AAC"
+10 DO INIT^HLFNC2(PRCPROT,.HL)
+11 ;tell user if there was an error
IF $GET(HL)
Begin DoDot:1
+12 SET PRCMSG=0
+13 IF $PIECE(HL,"^",2)]""
Begin DoDot:2
+14 if '$DATA(ZTQUEUED)
DO EN^DDIOL("Error: "_$PIECE(HL,"^",2)_" occurred. Please try later.")
End DoDot:2
End DoDot:1
QUIT 0
+15 ;
+16 ;field separator
SET HLFS=$GET(HL("FS"))
+17 ;component separator
SET HLCS=$EXTRACT(HL("ECH"),1)
+18 ;repetition separator
SET HLRS=$EXTRACT(HL("ECH"),2)
+19 ;
+20 ;======== MFI Segment ===========
+21 SET PRCSEG="MFI"_HLFS_"CDM"_HLFS_HLFS_"UPD"_HLFS_HLFS_HLFS_"AL"
+22 SET HLA("HLS",1)=PRCSEG
+23 ;
+24 ;======== MFE Segment ===========
+25 SET PRCSEG="MFE"_HLFS_"MAD"_HLFS_HLFS
+26 ;primary key value
SET $PIECE(PRCSEG,HLFS,5)="V"_PRCROOT_HLFS_"CE"
+27 SET HLA("HLS",2)=PRCSEG
+28 ;
+29 ;======== CDM Segment ===========
+30 SET PRCSEG="CDM"
+31 ;primary key value
SET $PIECE(PRCSEG,HLFS,2)="V"_PRCROOT
+32 SET $PIECE(PRCSEG,HLFS,4)="PROCUREMENT DETAIL FROM IFCAP"
+33 ;contract number
SET $PIECE(PRCSEG,HLFS,12)=PRCCN
+34 if $GET(PRCAM)=""
SET $PIECE(PRCSEG,HLFS,13)=PRCVEN_HLCS_HLCS_PRCDB
+35 SET HLA("HLS",3)=PRCSEG
+36 ;
+37 ;======== PRC Segment ===========
+38 SET PRCSEG="PRC"
+39 ;primary key value
SET $PIECE(PRCSEG,HLFS,2)="V"_PRCROOT
+40 if $GET(PRCAM)=""
SET $PIECE(PRCSEG,HLFS,10)="0"_HLCS_"US"
+41 SET $PIECE(PRCSEG,HLFS,11)=PRCAMT_HLCS_"US"
+42 ;effective start date = P.O. Date
SET $PIECE(PRCSEG,HLFS,12)=$GET(PRCOD)
+43 ;effective end date = delivery date
SET $PIECE(PRCSEG,HLFS,13)=$GET(PRCDD)
+44 SET HLA("HLS",4)=PRCSEG
+45 ;
+46 ;======== ZPO Segment ===========
+47 ; Purchase order details - check if this PO has been amended and get
+48 ; just a few fields for this segment as requested by Austin Automation
+49 ; Center (AAC)
+50 IF $DATA(^PRC(442,PRCHPO,6,0))
GOTO AMEND
+51 SET PRCSEG="ZPO"
+52 ;extent competed
if $GET(PRCECC)'=""
SET $PIECE(PRCSEG,HLFS,2)=PRCECC
+53 ;reason not competed
if $GET(PRCRNC)'=""
SET $PIECE(PRCSEG,HLFS,3)=PRCRNC
+54 ;EPA designated product
SET $PIECE(PRCSEG,HLFS,4)=PRCEPAC
+55 ;Federal Supply Class. (or PSC code)
if $GET(PRCFSC)'=""
SET $PIECE(PRCSEG,HLFS,5)=PRCFSC
+56 ;place of performance question
SET $PIECE(PRCSEG,HLFS,6)=PRCPP
+57 ;place of performance
SET $PIECE(PRCSEG,HLFS,7)=PRCPF
+58 ;contract bundling
SET $PIECE(PRCSEG,HLFS,8)=PRCCB
+59 ;government furnished eqmt.
SET $PIECE(PRCSEG,HLFS,9)="N"
+60 ;DUZ^LastName^FirstName (contr. officer)
SET $PIECE(PRCSEG,HLFS,10)=PRCPER
+61 ;method of processing
SET $PIECE(PRCSEG,HLFS,11)=PRCMOP
+62 ;type of contract
SET $PIECE(PRCSEG,HLFS,12)="J"
+63 ;alternative advertising
SET $PIECE(PRCSEG,HLFS,13)=PRCAAD
+64 ;date PO was signed
SET $PIECE(PRCSEG,HLFS,14)=$GET(PRCDS)
+65 ;award type
SET $PIECE(PRCSEG,HLFS,15)=PRCAT
+66 ;record type
SET $PIECE(PRCSEG,HLFS,16)=PRCRT
+67 ;solicitation procedure
SET $PIECE(PRCSEG,HLFS,17)=PRCSPC
+68 ;evaluated preference
SET $PIECE(PRCSEG,HLFS,18)=PRCEPC
+69 ;funding agency code
SET $PIECE(PRCSEG,HLFS,19)=PRCFAC
+70 ;contract funded by foreign gov.
SET $PIECE(PRCSEG,HLFS,20)="N"
+71 ;funding agency office code
SET $PIECE(PRCSEG,HLFS,21)=PRCFOC
+72 ;multiyear (for contracts)
SET $PIECE(PRCSEG,HLFS,22)=PRCMY
+73 ;pre award synopsis
SET $PIECE(PRCSEG,HLFS,23)=PRCPAS
+74 ;synopsis waiver
SET $PIECE(PRCSEG,HLFS,24)="N"
+75 ;number of offers
SET $PIECE(PRCSEG,HLFS,25)=PRCNOF
+76 ;ultimate contract value
SET $PIECE(PRCSEG,HLFS,26)=PRCUV_HLCS_"US"
+77 ;current contract value
SET $PIECE(PRCSEG,HLFS,27)=PRCCV_HLCS_"US"
+78 ;description of reqmt. (line item)
SET $PIECE(PRCSEG,HLFS,28)=PRCDES
+79 ;agency identifier
SET $PIECE(PRCSEG,HLFS,29)=3600
+80 ;business size
SET $PIECE(PRCSEG,HLFS,30)=PRCBZ
+81 ;type set aside
SET $PIECE(PRCSEG,HLFS,31)=PRCTSAC
+82 ;perf. based service contract
SET $PIECE(PRCSEG,HLFS,32)=PRCPBC
+83 ;contracting agency code
SET $PIECE(PRCSEG,HLFS,33)=3600
+84 ;contracting office code
SET $PIECE(PRCSEG,HLFS,34)=PRCOFC
+85 ;Clinger Cohen Act
SET $PIECE(PRCSEG,HLFS,35)=PRCCH
+86 ;ultimate completion date
SET $PIECE(PRCSEG,HLFS,37)=PRCUCD
+87 SET HLA("HLS",5)=PRCSEG
+88 GOTO GEN
+89 ;
AMEND ; Get ready for a short amended message
+1 SET PRCSEG="ZPO"
+2 ;date PO was signed
SET $PIECE(PRCSEG,HLFS,14)=PRCDS
+3 ;record type
SET $PIECE(PRCSEG,HLFS,16)=PRCRT
+4 ;contract funded by foreign govt.
SET $PIECE(PRCSEG,HLFS,20)="N"
+5 ;ultimate contract value
SET $PIECE(PRCSEG,HLFS,26)=PRCUV_HLCS_"US"
+6 ;current contract value
SET $PIECE(PRCSEG,HLFS,27)=PRCCV_HLCS_"US"
+7 ;agency identifier
SET $PIECE(PRCSEG,HLFS,29)=3600
+8 ;contracting agency code
SET $PIECE(PRCSEG,HLFS,33)=3600
+9 ;contracting office code
SET $PIECE(PRCSEG,HLFS,34)=PRCOFC
+10 ;modification number (amendment #)
SET $PIECE(PRCSEG,HLFS,36)=$GET(PRCMN)
+11 ;reason for mod. (amend authority)
SET $PIECE(PRCSEG,HLFS,38)=$GET(PRCRMC)
+12 SET HLA("HLS",5)=PRCSEG
+13 ;
+14 ; Call HL7 to build/send message and get its number (PRCMID)
GEN DO GENERATE^HLMA(PRCPROT,"LM",1,.PRCRSULT,"",.PRCOPTNS)
+1 IF $PIECE(PRCRSULT,U,1)]""
SET PRCMID=$PIECE(PRCRSULT,U,1)
+2 SET PRCSUB=$SELECT(PRCMID>0:"PRCHAAC1;"_PRCMID,1:"PRCHAAC1;"_"No MID")
MAIL2 ;
+1 SET MSG(1,0)="The following Purchase Order transaction has been sent "
+2 SET MSG(2,0)="to the Austin Automation Center (AAC) to report"
+3 SET MSG(3,0)="required FPDS information. Please keep this information"
+4 SET MSG(4,0)="for two weeks for tracking purposes."
+5 SET MSG(5,0)=" "
+6 SET MSG(6,0)="Purchase Order Number: "_$EXTRACT(PRCROOT,1,3)_"-"_$EXTRACT(PRCROOT,4,9)
+7 SET MSG(7,0)=" "
+8 SET MSG(8,0)="The HL7 Message # is: "_PRCMID
+9 SET XMSUB="Message for PO #: "_$EXTRACT(PRCROOT,1,3)_"-"_$EXTRACT(PRCROOT,4,9)_" to the AAC"
+10 ; Get approving official for a delivery order, certified invoice, etc.
+11 IF $DATA(^PRC(442,PRCHPO,10))
Begin DoDot:1
+12 IF $PIECE(^PRC(442,PRCHPO,23),U,11)="D"
SET PRCAPPO=$PIECE(^PRC(442,PRCHPO,10,1,0),U,2)
+13 IF '$TEST
SET PRCAPPO=$PIECE(^PRC(442,PRCHPO,10,1,0),U,2)
End DoDot:1
+14 ;
+15 ; Get approving official for an order created by a purchasing agent
+16 IF $PIECE($GET(^PRC(442,PRCHPO,23)),U,11)=""
Begin DoDot:1
+17 IF '$DATA(^PRC(442,PRCHPO,13))
QUIT
+18 SET PRC2237=$PIECE(^PRC(442,PRCHPO,13,0),U,3)
+19 SET PRCAPPO=$PIECE(^PRC(442,PRCHPO,13,PRC2237,0),U,2)
End DoDot:1
+20 ;
+21 ; Get authorized buyer for all POs
+22 SET PRCPPA=$PIECE(^PRC(442,PRCHPO,1),U,10)
+23 SET XMDUZ=PRCDUZ
+24 SET XMY(PRCPPA)=""
+25 if $GET(PRCAPPO)'=""
SET XMY(PRCAPPO)=""
+26 SET XMTEXT="MSG("
+27 DO ^XMD
+28 ;
+29 ;log record of outgoing message to the AAC
DO LOG^PRCHAAC2
+30 ; Keep track of any error found
+31 IF $PIECE(PRCRSULT,U,2,3)]""
IF +PRCMID=0
Begin DoDot:1
+32 SET PRCMID=$PIECE(PRCRSULT,U,2,3)
+33 SET PRCERR=1
+34 DO REC^PRCHAAC2
End DoDot:1
+35 KILL HLA,HL,HLFS,HLCS,HLRS
+36 QUIT
