PRCFDO ;WOIFO/KCL,MM - IFCAP/OLCS INTERFACE ;2/24/2011
V ;;5.1;IFCAP;**153**;Oct 20, 2000;Build 10
;Per VHA Directive 2004-038, this routine should not be modified.
;
;direct entry not permitted
Q
;
OLCSMSG ;Generate 1358 transaction message
;
; This procedure is called when the following events occur in IFCAP:
; - OBLIGATION event (when a new 1358 transaction is obligated)
; - ADJUSTMENT event (when an increase/decrease adjustment
; transaction is obligated)
;
; It will act as a driver for building and sending a 1358 transaction
; message to the Online Certification System via MailMan.
;
; Input: None
; Output: None
;
N PRCCNT ;msg text line counter
N PRCDATA ;1358 data elements array
N PRCMSG ;closed root array of MailMan text lines
;
;get 1358 transaction data elements
Q:'$$OLCSDATA(.PRCDATA)
;
;validate 1358 transaction data elements, don't
;check for required elements
Q:'$$VALID(.PRCDATA,0)
;
;build 1358 transaction msg
S PRCMSG=$NA(^TMP("PRCOLCS",$J))
K @PRCMSG
S PRCCNT=0
D BLDMSG(.PRCDATA,.PRCCNT,"^","~",PRCMSG)
;
;send 1358 transaction msg
D MAIL(PRCMSG)
;
;cleanup
K PRCDATA
K @PRCMSG
Q
;
;
OLCSDATA(PRCDF) ;Get 1358 data elements
;
; This function is used to place 1358 transaction data elements into
; an array format.
;
; Supported IAs:
; The following IAs allow use of supported Kernel calls:
; #2171 $$NS^XUAF4
; #2541 $$KSP^XUPARAM
; #3065 $$HLNAME^XLFNAME
; #10103 $$FMTHL7^XLFDT
; #10104 $$UP^XLFSTR
;
; Input:
; PRCDF - (required) Result array passed by reference
;
; Output:
; Function Value - Returns 1 on success, 0 on failure
; PRCDF - Output array containing 1358 transaction data elements
;
; Subscript Data Element
; --------- ------------
; "FACNM" Facility-Name
; "FACNUM" Station-Number
; "OBLNUM" Obligation-Number
; "TRANTYPE" Transaction-Type
; "OBLDATE" Event-Date-Time
; "REQNAME" Requestor-Name
; "REQID" Requestor-ID
; "APPNAME" Approver-Name
; "APPID" Approver-ID
; "OBLNAME" Obligator-Name
; "OBLID" Obligator-ID
;
N PRCDFNUM ;station #
N PRCDNM ;array for call to HLNAME^XLFNAME
N PRCSITE ;institution_name^station_number
N PRCREQID ;Requestor DUZ
N PRCAPPID ;Approving Official DUZ
N PRCOBLID ;Obligator DUZ
N PRCOBLD ;Date Signed from Obligation Data multiple
N PRCSUB ;array subscripts
N RESULT ;function result
;
S RESULT=0
;
;init output array
K PRCDF S PRCDF=""
F PRCSUB="FACNM","FACNUM","OBLNUM","TRANTYPE","OBLDATE","REQNAME","REQID","APPNAME","APPID","OBLNAME","OBLID" S PRCDF(PRCSUB)=""
;
;Facility-Name and Station-Number
S PRCSITE=$$NS^XUAF4(+$$KSP^XUPARAM("INST"))
S PRCDF("FACNM")=$P($G(PRCSITE),"^")
S PRCDFNUM=$P($G(PRCSITE),"^",2)
S PRCDF("FACNUM")=PRCDFNUM
;
;Obligation-Number from file #442 record
S PRCDF("OBLNUM")=$P($G(PO(0)),"^")
;
;Transaction-Type (O=Obligated & A=Adjustment)
S PRCDF("TRANTYPE")=$S($G(PRCFSC)=1:"O",1:"A")
;
;Event-Date_Time (Date Signed) in HL7 format YYYYMMDDHHMMSS-XXXX
;where (-XXXX is the Greenwich Mean Time offset)
S PRCOBLD=$$OBL(+PO,PRCDF("TRANTYPE"),$G(TRDA))
S PRCDF("OBLDATE")=$$FMTHL7^XLFDT($G(PRCOBLD))
;concatenate '00' seconds if Date Signed was filed precisely on the hour and minute
I $L($P(PRCDF("OBLDATE"),"-"))=12 D
. S PRCDF("OBLDATE")=$P(PRCDF("OBLDATE"),"-")_"00-"_$P(PRCDF("OBLDATE"),"-",2)
;
;get Requestor, Approver, and Obligator iens
;TRNODE(7) contains Requestor (#40) from file #410 record
S PRCREQID=$P($G(TRNODE(7)),"^")
;TRNODE(7) contains Approving Official (#42) from file #410 record
S PRCAPPID=$P($G(TRNODE(7)),"^",3)
;Obligator=DUZ
S PRCOBLID=+$G(PRC("PER"))
;
;set up array for call to HLNAME^XLFNAME
S PRCDNM("FILE")=200
S PRCDNM("FIELD")=.01
;place Requestor, Approver, and Obligator names
;in HL7 format. Name components (LAST|FIRST|MIDDLE|SUFFIX)
S PRCDNM("IENS")=+PRCREQID_","
S PRCDF("REQNAME")=$S(+PRCREQID>0:$$HLNAME^XLFNAME(.PRCDNM,"","|"),1:"")
I PRCDF("REQNAME")]"" S PRCDF("REQNAME")=$P($$UP^XLFSTR(PRCDF("REQNAME")),"|",1,4)
S PRCDNM("IENS")=+PRCAPPID_","
S PRCDF("APPNAME")=$S(+PRCAPPID>0:$$HLNAME^XLFNAME(.PRCDNM,"","|"),1:"")
I PRCDF("APPNAME")]"" S PRCDF("APPNAME")=$P($$UP^XLFSTR(PRCDF("APPNAME")),"|",1,4)
S PRCDNM("IENS")=+PRCOBLID_","
S PRCDF("OBLNAME")=$S(+PRCOBLID>0:$$HLNAME^XLFNAME(.PRCDNM,"","|"),1:"")
I PRCDF("OBLNAME")]"" S PRCDF("OBLNAME")=$P($$UP^XLFSTR(PRCDF("OBLNAME")),"|",1,4)
;
;place Requestor, Approver, and Obligator IDs in format 'Station#-UserId'
S PRCDF("REQID")=PRCDFNUM_"-"_PRCREQID
S PRCDF("APPID")=PRCDFNUM_"-"_PRCAPPID
S PRCDF("OBLID")=PRCDFNUM_"-"_PRCOBLID
;
S RESULT=1
Q RESULT
;
;
OBL(POIEN,TRANTYPE,PRCF410) ;Get Date Signed for current obligation
;
; Input:
; POIEN - (required) IEN in Procurement & Accounting Transactions (#442) file
; TRANTYPE - (required) 'O'bligated or 'A'djustment
; PRCF410 - IEN in Control Point Activity (#410)
;
; Output:
; PRCFDS - Date Signed (#5) field in Obligation Data (#442.09) multiple in PRC(442)
;
N PRCFI,PRCFDS
S PRCFDS=""
I +$G(PO)'>0 Q PRCFDS
I $G(TRANTYPE)="" Q PRCFDS
S PRCF410=$G(PRCF410)
S PRCFI=0
;Loop through Obligation Data multiple
F S PRCFI=$O(^PRC(442,+PO,10,PRCFI)) Q:PRCFI'>0 D Q:PRCFDS'=""
.N PRCF0
.S PRCF0=$G(^PRC(442,+PO,10,PRCFI,0))
.;Skip entries that are not SO or AR code sheets (excludes PV)
.Q:"^SO^AR^"'[("^"_$E(PRCF0,1,2)_"^")
.;If transaction type is for the new 1358 obligation, 1358 Adjustment field
.;will be null and transaction type will be set to 'O'bligation.
.I $P(PRCF0,"^",11)="",(TRANTYPE="O") D
..;Date Signed (#5) field for initial obligation
..S PRCFDS=$P(PRCF0,"^",6)
.;If 1358 Adjustment field is defined and transaction type set to
.;'A'djustment, compare 410 IEN in 1358 Adjustment field with 410
.;IEN for current obligation.
.I $P(PRCF0,"^",11)'="",(TRANTYPE="A") D
..I $P(PRCF0,"^",11)'=+PRCF410 Q
..;Date Signed field for current adjustment obligation
..S PRCFDS=$P(PRCF0,"^",6)
Q PRCFDS
;
;
VALID(PRCDF,PRCREQ,PRCER) ;Validate 1358 transaction array
;
; This function performs validation checks on elements in the 1358 transaction array.
;
; Input:
; PRCDF - array containing 1358 transaction data elements, passed by reference
; PRCREQ - (optional) check for required data elements? 1=Yes|0=No default=1
;
; Output:
; Function Value - Returns 1 if validation checks passed, 0 otherwise
; PRCER - (optional) if validation checks fail, an error message
; is returned, pass by reference
;
N PRCTXT ;temporary error text
N RESULT ;function result
;
;init vars
S (PRCER,PRCTXT)=""
S PRCREQ=$S($G(PRCREQ)=0:0,1:1)
;
S RESULT=1
;
;if needed, check for required data elements
I PRCREQ D
. S PRCTXT="data element is missing."
. I $G(PRCDF("FACNM"))="" S RESULT=0,PRCER="Facility-Name "_PRCTXT Q
. I $G(PRCDF("FACNUM"))="" S RESULT=0,PRCER="Station-Number "_PRCTXT Q
. I $G(PRCDF("OBLNUM"))="" S RESULT=0,PRCER="Obligation-Number "_PRCTXT Q
. I $G(PRCDF("TRANTYPE"))="" S RESULT=0,PRCER="Transaction-Type "_PRCTXT Q
. I $G(PRCDF("OBLDATE"))="" S RESULT=0,PRCER="Event-Date-Time "_PRCTXT Q
. I $G(PRCDF("REQNAME"))="" S RESULT=0,PRCER="Requestor-Name "_PRCTXT Q
. I $G(PRCDF("REQID"))="" S RESULT=0,PRCER="Requestor-ID "_PRCTXT Q
. I $G(PRCDF("APPNAME"))="" S RESULT=0,PRCER="Approver-Name "_PRCTXT Q
. I $G(PRCDF("APPID"))="" S RESULT=0,PRCER="Approver-ID "_PRCTXT Q
. I $G(PRCDF("OBLNAME"))="" S RESULT=0,PRCER="Obligator-Name "_PRCTXT Q
. I $G(PRCDF("OBLID"))="" S RESULT=0,PRCER="Obligator-ID "_PRCTXT Q
;
;if error not encountered, check max field lengths
I RESULT D
. S PRCTXT="exceeds maximum field length."
. I $L($G(PRCDF("FACNM")))>30 S RESULT=0,PRCER="Facility-Name "_PRCTXT Q
. I $L($G(PRCDF("FACNUM")))>3 S RESULT=0,PRCER="Station-Number "_PRCTXT Q
. I $L($G(PRCDF("OBLNUM")))>10 S RESULT=0,PRCER="Obligation-Number "_PRCTXT Q
. I $L($G(PRCDF("TRANTYPE")))>1 S RESULT=0,PRCER="Transaction-Type "_PRCTXT Q
. I $L($G(PRCDF("OBLDATE")))>19 S RESULT=0,PRCER="Event-Date-Time "_PRCTXT Q
. I $L($G(PRCDF("REQNAME")))>35 S RESULT=0,PRCER="Requestor-Name "_PRCTXT Q
. I $L($G(PRCDF("REQID")))>16 S RESULT=0,PRCER="Requestor-ID "_PRCTXT Q
. I $L($G(PRCDF("APPNAME")))>35 S RESULT=0,PRCER="Approver-Name "_PRCTXT Q
. I $L($G(PRCDF("APPID")))>16 S RESULT=0,PRCER="Approver-ID "_PRCTXT Q
. I $L($G(PRCDF("OBLNAME")))>35 S RESULT=0,PRCER="Obligator-Name "_PRCTXT Q
. I $L($G(PRCDF("OBLID")))>16 S RESULT=0,PRCER="Obligator-ID "_PRCTXT Q
;
;if error not encountered, check for valid set of codes
I RESULT D
. S PRCTXT="contains an invalid set of codes."
. I ($G(PRCDF("TRANTYPE"))'="O")&($G(PRCDF("TRANTYPE"))'="A") S RESULT=0,PRCER="Transaction-Type "_PRCTXT Q
;
Q RESULT
;
;
BLDMSG(PRCDFA,PRCCTR,PRCDEL,PRCEOR,PRCXMTXT) ;Build 1358 transaction message
;
; This procedure is used to build a 1358 transaction message.
;
; Input:
; PRCDFA - (required) array containing 1358 transaction data elements
; PRCCTR - as number of lines in message, passed by reference
; PRCDEL - data field delimiter, default="^"
; PRCEOR - end of record indicator, default="~"
;
; Output:
; PRCXMTXT - array of MailMan text lines
;
N PRCREC ;temp var containing record line
;
;set default field delimiter and end of record indicator if not passed
S:$G(PRCDEL)']"" PRCDEL="^"
S:$G(PRCEOR)']"" PRCEOR="~"
;
;msg line count
S PRCCTR=+$G(PRCCTR)
;
;build Line 1 of 1358 transaction record
;Station Name^Station Number^1358 Obligation #^Transaction Type^Event Date/Time^
S PRCREC=PRCDFA("FACNM")_PRCDEL_PRCDFA("FACNUM")_PRCDEL_PRCDFA("OBLNUM")_PRCDEL
S PRCREC=PRCREC_PRCDFA("TRANTYPE")_PRCDEL_PRCDFA("OBLDATE")_PRCDEL
;
;add line to msg
D ADDLINE(PRCREC,.PRCCTR,PRCXMTXT)
K PRCREC
;
;build Line 2 of 1358 transaction record
;Requestor Name^Requestor ID^Approver Name^Approver ID^Obligation Name^Obligation ID
S PRCREC=PRCDFA("REQNAME")_PRCDEL_PRCDFA("REQID")_PRCDEL_PRCDFA("APPNAME")_PRCDEL
S PRCREC=PRCREC_PRCDFA("APPID")_PRCDEL_PRCDFA("OBLNAME")_PRCDEL_PRCDFA("OBLID")_PRCDEL
;
;add end of record indicator
S PRCREC=PRCREC_PRCEOR
;
;add line to msg
D ADDLINE(PRCREC,.PRCCTR,PRCXMTXT)
K PRCREC
Q
;
;
ADDLINE(PRCTEXT,PRCNT,PRCXMTXT) ;Add lines of text to message array
;
; Input:
; PRCTEXT - as line of text to be inserted into msg
; PRCNT - as number of lines in msg, passed by reference
;
; Output:
; PRCXMTXT - array containing msg text
;
S PRCNT=PRCNT+1
S @PRCXMTXT@(PRCNT)=PRCTEXT
Q
;
;
MAIL(PRCXMTXT) ;Send 1358 transaction mail message
;
; * Send messages to production queue Q-OLP.DOMAIN.EXT
; [If PRC*5.1*153 installed in a production account]
;
; * Send messages to mail group G.OLP
; [If PRC*5.1*153 installed in a test account
; AND
; Nationally released version of PRC*5.1*153 is not installed]
;
; * Do not send messages
; [If PRC*5.1*153 installed in a test account
; AND
; Nationally released version of PRC*5.1*153 is installed]
;
; Supported IAs:
; #10070: Allows use of supported MailMan call ^XMD
; #2054: Allows use of supported FM call $$OREF^DILF
; #4440: Allows use of supported Kernel call $$PROD^XUPROD
; #10141: Allows use of supported Kernel call $$INSTALDT^XPDUTL
;
; Input:
; PRCXMTXT - array containing message text
;
; Output: None
;
N DIFROM ;protect FM package
N XMDUZ ;sender
N XMSUB ;subj
N XMTEXT ;name of array (in open format) containing text of msg
N XMY ;recipient array
N XMZ ;returned msg #
N XMMG,XMSTRIP,XMROU,XMYBLOB ;optional MM input vars
N PRCACCT ;account
N PRCREC ;recipient
;
D
. ;quit if production account
. I $$PROD^XUPROD S PRCACCT=1 Q
. ;
. ;otherwise, retrieve all dates/times that an install was performed
. ;and determine if nationally released version of patch was installed
. N PRCINST,PRCINST1
. S PRCINST1=""
. S PRCINST=$$INSTALDT^XPDUTL("PRC*5.1*153",.PRCINST)
. I +PRCINST>0 D
. . N PRCINSTD S PRCINSTD=0
. . ;loop thru install dates/times
. . F S PRCINSTD=$O(PRCINST(PRCINSTD)) Q:'PRCINSTD D Q:PRCINST1="P"
. . . N PRCINST0
. . . S PRCINST0=$G(PRCINST(PRCINSTD))
. . . I +$P(PRCINST0,"^",2)>0 S PRCINST1="P" Q
. . . S PRCINST1="T"
. S PRCACCT=$S(PRCINST1="T":2,1:0)
;
S PRCREC=$S(PRCACCT=1:"XXX@Q-OLP.DOMAIN.EXT",PRCACCT=2:"G.OLP",1:0)
Q:PRCREC=0
;
S XMY(PRCREC)=""
S XMSUB="1358 TRANSACTION"
S XMDUZ="IFCAP/OLCS INTERFACE"
S XMTEXT=$$OREF^DILF(PRCXMTXT)
;
;send
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFDO 13111 printed Sep 23, 2025@19:39:08 Page 2
PRCFDO ;WOIFO/KCL,MM - IFCAP/OLCS INTERFACE ;2/24/2011
V ;;5.1;IFCAP;**153**;Oct 20, 2000;Build 10
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;
+3 ;direct entry not permitted
+4 QUIT
+5 ;
OLCSMSG ;Generate 1358 transaction message
+1 ;
+2 ; This procedure is called when the following events occur in IFCAP:
+3 ; - OBLIGATION event (when a new 1358 transaction is obligated)
+4 ; - ADJUSTMENT event (when an increase/decrease adjustment
+5 ; transaction is obligated)
+6 ;
+7 ; It will act as a driver for building and sending a 1358 transaction
+8 ; message to the Online Certification System via MailMan.
+9 ;
+10 ; Input: None
+11 ; Output: None
+12 ;
+13 ;msg text line counter
NEW PRCCNT
+14 ;1358 data elements array
NEW PRCDATA
+15 ;closed root array of MailMan text lines
NEW PRCMSG
+16 ;
+17 ;get 1358 transaction data elements
+18 if '$$OLCSDATA(.PRCDATA)
QUIT
+19 ;
+20 ;validate 1358 transaction data elements, don't
+21 ;check for required elements
+22 if '$$VALID(.PRCDATA,0)
QUIT
+23 ;
+24 ;build 1358 transaction msg
+25 SET PRCMSG=$NAME(^TMP("PRCOLCS",$JOB))
+26 KILL @PRCMSG
+27 SET PRCCNT=0
+28 DO BLDMSG(.PRCDATA,.PRCCNT,"^","~",PRCMSG)
+29 ;
+30 ;send 1358 transaction msg
+31 DO MAIL(PRCMSG)
+32 ;
+33 ;cleanup
+34 KILL PRCDATA
+35 KILL @PRCMSG
+36 QUIT
+37 ;
+38 ;
OLCSDATA(PRCDF) ;Get 1358 data elements
+1 ;
+2 ; This function is used to place 1358 transaction data elements into
+3 ; an array format.
+4 ;
+5 ; Supported IAs:
+6 ; The following IAs allow use of supported Kernel calls:
+7 ; #2171 $$NS^XUAF4
+8 ; #2541 $$KSP^XUPARAM
+9 ; #3065 $$HLNAME^XLFNAME
+10 ; #10103 $$FMTHL7^XLFDT
+11 ; #10104 $$UP^XLFSTR
+12 ;
+13 ; Input:
+14 ; PRCDF - (required) Result array passed by reference
+15 ;
+16 ; Output:
+17 ; Function Value - Returns 1 on success, 0 on failure
+18 ; PRCDF - Output array containing 1358 transaction data elements
+19 ;
+20 ; Subscript Data Element
+21 ; --------- ------------
+22 ; "FACNM" Facility-Name
+23 ; "FACNUM" Station-Number
+24 ; "OBLNUM" Obligation-Number
+25 ; "TRANTYPE" Transaction-Type
+26 ; "OBLDATE" Event-Date-Time
+27 ; "REQNAME" Requestor-Name
+28 ; "REQID" Requestor-ID
+29 ; "APPNAME" Approver-Name
+30 ; "APPID" Approver-ID
+31 ; "OBLNAME" Obligator-Name
+32 ; "OBLID" Obligator-ID
+33 ;
+34 ;station #
NEW PRCDFNUM
+35 ;array for call to HLNAME^XLFNAME
NEW PRCDNM
+36 ;institution_name^station_number
NEW PRCSITE
+37 ;Requestor DUZ
NEW PRCREQID
+38 ;Approving Official DUZ
NEW PRCAPPID
+39 ;Obligator DUZ
NEW PRCOBLID
+40 ;Date Signed from Obligation Data multiple
NEW PRCOBLD
+41 ;array subscripts
NEW PRCSUB
+42 ;function result
NEW RESULT
+43 ;
+44 SET RESULT=0
+45 ;
+46 ;init output array
+47 KILL PRCDF
SET PRCDF=""
+48 FOR PRCSUB="FACNM","FACNUM","OBLNUM","TRANTYPE","OBLDATE","REQNAME","REQID","APPNAME","APPID","OBLNAME","OBLID"
SET PRCDF(PRCSUB)=""
+49 ;
+50 ;Facility-Name and Station-Number
+51 SET PRCSITE=$$NS^XUAF4(+$$KSP^XUPARAM("INST"))
+52 SET PRCDF("FACNM")=$PIECE($GET(PRCSITE),"^")
+53 SET PRCDFNUM=$PIECE($GET(PRCSITE),"^",2)
+54 SET PRCDF("FACNUM")=PRCDFNUM
+55 ;
+56 ;Obligation-Number from file #442 record
+57 SET PRCDF("OBLNUM")=$PIECE($GET(PO(0)),"^")
+58 ;
+59 ;Transaction-Type (O=Obligated & A=Adjustment)
+60 SET PRCDF("TRANTYPE")=$SELECT($GET(PRCFSC)=1:"O",1:"A")
+61 ;
+62 ;Event-Date_Time (Date Signed) in HL7 format YYYYMMDDHHMMSS-XXXX
+63 ;where (-XXXX is the Greenwich Mean Time offset)
+64 SET PRCOBLD=$$OBL(+PO,PRCDF("TRANTYPE"),$GET(TRDA))
+65 SET PRCDF("OBLDATE")=$$FMTHL7^XLFDT($GET(PRCOBLD))
+66 ;concatenate '00' seconds if Date Signed was filed precisely on the hour and minute
+67 IF $LENGTH($PIECE(PRCDF("OBLDATE"),"-"))=12
Begin DoDot:1
+68 SET PRCDF("OBLDATE")=$PIECE(PRCDF("OBLDATE"),"-")_"00-"_$PIECE(PRCDF("OBLDATE"),"-",2)
End DoDot:1
+69 ;
+70 ;get Requestor, Approver, and Obligator iens
+71 ;TRNODE(7) contains Requestor (#40) from file #410 record
+72 SET PRCREQID=$PIECE($GET(TRNODE(7)),"^")
+73 ;TRNODE(7) contains Approving Official (#42) from file #410 record
+74 SET PRCAPPID=$PIECE($GET(TRNODE(7)),"^",3)
+75 ;Obligator=DUZ
+76 SET PRCOBLID=+$GET(PRC("PER"))
+77 ;
+78 ;set up array for call to HLNAME^XLFNAME
+79 SET PRCDNM("FILE")=200
+80 SET PRCDNM("FIELD")=.01
+81 ;place Requestor, Approver, and Obligator names
+82 ;in HL7 format. Name components (LAST|FIRST|MIDDLE|SUFFIX)
+83 SET PRCDNM("IENS")=+PRCREQID_","
+84 SET PRCDF("REQNAME")=$SELECT(+PRCREQID>0:$$HLNAME^XLFNAME(.PRCDNM,"","|"),1:"")
+85 IF PRCDF("REQNAME")]""
SET PRCDF("REQNAME")=$PIECE($$UP^XLFSTR(PRCDF("REQNAME")),"|",1,4)
+86 SET PRCDNM("IENS")=+PRCAPPID_","
+87 SET PRCDF("APPNAME")=$SELECT(+PRCAPPID>0:$$HLNAME^XLFNAME(.PRCDNM,"","|"),1:"")
+88 IF PRCDF("APPNAME")]""
SET PRCDF("APPNAME")=$PIECE($$UP^XLFSTR(PRCDF("APPNAME")),"|",1,4)
+89 SET PRCDNM("IENS")=+PRCOBLID_","
+90 SET PRCDF("OBLNAME")=$SELECT(+PRCOBLID>0:$$HLNAME^XLFNAME(.PRCDNM,"","|"),1:"")
+91 IF PRCDF("OBLNAME")]""
SET PRCDF("OBLNAME")=$PIECE($$UP^XLFSTR(PRCDF("OBLNAME")),"|",1,4)
+92 ;
+93 ;place Requestor, Approver, and Obligator IDs in format 'Station#-UserId'
+94 SET PRCDF("REQID")=PRCDFNUM_"-"_PRCREQID
+95 SET PRCDF("APPID")=PRCDFNUM_"-"_PRCAPPID
+96 SET PRCDF("OBLID")=PRCDFNUM_"-"_PRCOBLID
+97 ;
+98 SET RESULT=1
+99 QUIT RESULT
+100 ;
+101 ;
OBL(POIEN,TRANTYPE,PRCF410) ;Get Date Signed for current obligation
+1 ;
+2 ; Input:
+3 ; POIEN - (required) IEN in Procurement & Accounting Transactions (#442) file
+4 ; TRANTYPE - (required) 'O'bligated or 'A'djustment
+5 ; PRCF410 - IEN in Control Point Activity (#410)
+6 ;
+7 ; Output:
+8 ; PRCFDS - Date Signed (#5) field in Obligation Data (#442.09) multiple in PRC(442)
+9 ;
+10 NEW PRCFI,PRCFDS
+11 SET PRCFDS=""
+12 IF +$GET(PO)'>0
QUIT PRCFDS
+13 IF $GET(TRANTYPE)=""
QUIT PRCFDS
+14 SET PRCF410=$GET(PRCF410)
+15 SET PRCFI=0
+16 ;Loop through Obligation Data multiple
+17 FOR
SET PRCFI=$ORDER(^PRC(442,+PO,10,PRCFI))
if PRCFI'>0
QUIT
Begin DoDot:1
+18 NEW PRCF0
+19 SET PRCF0=$GET(^PRC(442,+PO,10,PRCFI,0))
+20 ;Skip entries that are not SO or AR code sheets (excludes PV)
+21 if "^SO^AR^"'[("^"_$EXTRACT(PRCF0,1,2)_"^")
QUIT
+22 ;If transaction type is for the new 1358 obligation, 1358 Adjustment field
+23 ;will be null and transaction type will be set to 'O'bligation.
+24 IF $PIECE(PRCF0,"^",11)=""
IF (TRANTYPE="O")
Begin DoDot:2
+25 ;Date Signed (#5) field for initial obligation
+26 SET PRCFDS=$PIECE(PRCF0,"^",6)
End DoDot:2
+27 ;If 1358 Adjustment field is defined and transaction type set to
+28 ;'A'djustment, compare 410 IEN in 1358 Adjustment field with 410
+29 ;IEN for current obligation.
+30 IF $PIECE(PRCF0,"^",11)'=""
IF (TRANTYPE="A")
Begin DoDot:2
+31 IF $PIECE(PRCF0,"^",11)'=+PRCF410
QUIT
+32 ;Date Signed field for current adjustment obligation
+33 SET PRCFDS=$PIECE(PRCF0,"^",6)
End DoDot:2
End DoDot:1
if PRCFDS'=""
QUIT
+34 QUIT PRCFDS
+35 ;
+36 ;
VALID(PRCDF,PRCREQ,PRCER) ;Validate 1358 transaction array
+1 ;
+2 ; This function performs validation checks on elements in the 1358 transaction array.
+3 ;
+4 ; Input:
+5 ; PRCDF - array containing 1358 transaction data elements, passed by reference
+6 ; PRCREQ - (optional) check for required data elements? 1=Yes|0=No default=1
+7 ;
+8 ; Output:
+9 ; Function Value - Returns 1 if validation checks passed, 0 otherwise
+10 ; PRCER - (optional) if validation checks fail, an error message
+11 ; is returned, pass by reference
+12 ;
+13 ;temporary error text
NEW PRCTXT
+14 ;function result
NEW RESULT
+15 ;
+16 ;init vars
+17 SET (PRCER,PRCTXT)=""
+18 SET PRCREQ=$SELECT($GET(PRCREQ)=0:0,1:1)
+19 ;
+20 SET RESULT=1
+21 ;
+22 ;if needed, check for required data elements
+23 IF PRCREQ
Begin DoDot:1
+24 SET PRCTXT="data element is missing."
+25 IF $GET(PRCDF("FACNM"))=""
SET RESULT=0
SET PRCER="Facility-Name "_PRCTXT
QUIT
+26 IF $GET(PRCDF("FACNUM"))=""
SET RESULT=0
SET PRCER="Station-Number "_PRCTXT
QUIT
+27 IF $GET(PRCDF("OBLNUM"))=""
SET RESULT=0
SET PRCER="Obligation-Number "_PRCTXT
QUIT
+28 IF $GET(PRCDF("TRANTYPE"))=""
SET RESULT=0
SET PRCER="Transaction-Type "_PRCTXT
QUIT
+29 IF $GET(PRCDF("OBLDATE"))=""
SET RESULT=0
SET PRCER="Event-Date-Time "_PRCTXT
QUIT
+30 IF $GET(PRCDF("REQNAME"))=""
SET RESULT=0
SET PRCER="Requestor-Name "_PRCTXT
QUIT
+31 IF $GET(PRCDF("REQID"))=""
SET RESULT=0
SET PRCER="Requestor-ID "_PRCTXT
QUIT
+32 IF $GET(PRCDF("APPNAME"))=""
SET RESULT=0
SET PRCER="Approver-Name "_PRCTXT
QUIT
+33 IF $GET(PRCDF("APPID"))=""
SET RESULT=0
SET PRCER="Approver-ID "_PRCTXT
QUIT
+34 IF $GET(PRCDF("OBLNAME"))=""
SET RESULT=0
SET PRCER="Obligator-Name "_PRCTXT
QUIT
+35 IF $GET(PRCDF("OBLID"))=""
SET RESULT=0
SET PRCER="Obligator-ID "_PRCTXT
QUIT
End DoDot:1
+36 ;
+37 ;if error not encountered, check max field lengths
+38 IF RESULT
Begin DoDot:1
+39 SET PRCTXT="exceeds maximum field length."
+40 IF $LENGTH($GET(PRCDF("FACNM")))>30
SET RESULT=0
SET PRCER="Facility-Name "_PRCTXT
QUIT
+41 IF $LENGTH($GET(PRCDF("FACNUM")))>3
SET RESULT=0
SET PRCER="Station-Number "_PRCTXT
QUIT
+42 IF $LENGTH($GET(PRCDF("OBLNUM")))>10
SET RESULT=0
SET PRCER="Obligation-Number "_PRCTXT
QUIT
+43 IF $LENGTH($GET(PRCDF("TRANTYPE")))>1
SET RESULT=0
SET PRCER="Transaction-Type "_PRCTXT
QUIT
+44 IF $LENGTH($GET(PRCDF("OBLDATE")))>19
SET RESULT=0
SET PRCER="Event-Date-Time "_PRCTXT
QUIT
+45 IF $LENGTH($GET(PRCDF("REQNAME")))>35
SET RESULT=0
SET PRCER="Requestor-Name "_PRCTXT
QUIT
+46 IF $LENGTH($GET(PRCDF("REQID")))>16
SET RESULT=0
SET PRCER="Requestor-ID "_PRCTXT
QUIT
+47 IF $LENGTH($GET(PRCDF("APPNAME")))>35
SET RESULT=0
SET PRCER="Approver-Name "_PRCTXT
QUIT
+48 IF $LENGTH($GET(PRCDF("APPID")))>16
SET RESULT=0
SET PRCER="Approver-ID "_PRCTXT
QUIT
+49 IF $LENGTH($GET(PRCDF("OBLNAME")))>35
SET RESULT=0
SET PRCER="Obligator-Name "_PRCTXT
QUIT
+50 IF $LENGTH($GET(PRCDF("OBLID")))>16
SET RESULT=0
SET PRCER="Obligator-ID "_PRCTXT
QUIT
End DoDot:1
+51 ;
+52 ;if error not encountered, check for valid set of codes
+53 IF RESULT
Begin DoDot:1
+54 SET PRCTXT="contains an invalid set of codes."
+55 IF ($GET(PRCDF("TRANTYPE"))'="O")&($GET(PRCDF("TRANTYPE"))'="A")
SET RESULT=0
SET PRCER="Transaction-Type "_PRCTXT
QUIT
End DoDot:1
+56 ;
+57 QUIT RESULT
+58 ;
+59 ;
BLDMSG(PRCDFA,PRCCTR,PRCDEL,PRCEOR,PRCXMTXT) ;Build 1358 transaction message
+1 ;
+2 ; This procedure is used to build a 1358 transaction message.
+3 ;
+4 ; Input:
+5 ; PRCDFA - (required) array containing 1358 transaction data elements
+6 ; PRCCTR - as number of lines in message, passed by reference
+7 ; PRCDEL - data field delimiter, default="^"
+8 ; PRCEOR - end of record indicator, default="~"
+9 ;
+10 ; Output:
+11 ; PRCXMTXT - array of MailMan text lines
+12 ;
+13 ;temp var containing record line
NEW PRCREC
+14 ;
+15 ;set default field delimiter and end of record indicator if not passed
+16 if $GET(PRCDEL)']""
SET PRCDEL="^"
+17 if $GET(PRCEOR)']""
SET PRCEOR="~"
+18 ;
+19 ;msg line count
+20 SET PRCCTR=+$GET(PRCCTR)
+21 ;
+22 ;build Line 1 of 1358 transaction record
+23 ;Station Name^Station Number^1358 Obligation #^Transaction Type^Event Date/Time^
+24 SET PRCREC=PRCDFA("FACNM")_PRCDEL_PRCDFA("FACNUM")_PRCDEL_PRCDFA("OBLNUM")_PRCDEL
+25 SET PRCREC=PRCREC_PRCDFA("TRANTYPE")_PRCDEL_PRCDFA("OBLDATE")_PRCDEL
+26 ;
+27 ;add line to msg
+28 DO ADDLINE(PRCREC,.PRCCTR,PRCXMTXT)
+29 KILL PRCREC
+30 ;
+31 ;build Line 2 of 1358 transaction record
+32 ;Requestor Name^Requestor ID^Approver Name^Approver ID^Obligation Name^Obligation ID
+33 SET PRCREC=PRCDFA("REQNAME")_PRCDEL_PRCDFA("REQID")_PRCDEL_PRCDFA("APPNAME")_PRCDEL
+34 SET PRCREC=PRCREC_PRCDFA("APPID")_PRCDEL_PRCDFA("OBLNAME")_PRCDEL_PRCDFA("OBLID")_PRCDEL
+35 ;
+36 ;add end of record indicator
+37 SET PRCREC=PRCREC_PRCEOR
+38 ;
+39 ;add line to msg
+40 DO ADDLINE(PRCREC,.PRCCTR,PRCXMTXT)
+41 KILL PRCREC
+42 QUIT
+43 ;
+44 ;
ADDLINE(PRCTEXT,PRCNT,PRCXMTXT) ;Add lines of text to message array
+1 ;
+2 ; Input:
+3 ; PRCTEXT - as line of text to be inserted into msg
+4 ; PRCNT - as number of lines in msg, passed by reference
+5 ;
+6 ; Output:
+7 ; PRCXMTXT - array containing msg text
+8 ;
+9 SET PRCNT=PRCNT+1
+10 SET @PRCXMTXT@(PRCNT)=PRCTEXT
+11 QUIT
+12 ;
+13 ;
MAIL(PRCXMTXT) ;Send 1358 transaction mail message
+1 ;
+2 ; * Send messages to production queue Q-OLP.DOMAIN.EXT
+3 ; [If PRC*5.1*153 installed in a production account]
+4 ;
+5 ; * Send messages to mail group G.OLP
+6 ; [If PRC*5.1*153 installed in a test account
+7 ; AND
+8 ; Nationally released version of PRC*5.1*153 is not installed]
+9 ;
+10 ; * Do not send messages
+11 ; [If PRC*5.1*153 installed in a test account
+12 ; AND
+13 ; Nationally released version of PRC*5.1*153 is installed]
+14 ;
+15 ; Supported IAs:
+16 ; #10070: Allows use of supported MailMan call ^XMD
+17 ; #2054: Allows use of supported FM call $$OREF^DILF
+18 ; #4440: Allows use of supported Kernel call $$PROD^XUPROD
+19 ; #10141: Allows use of supported Kernel call $$INSTALDT^XPDUTL
+20 ;
+21 ; Input:
+22 ; PRCXMTXT - array containing message text
+23 ;
+24 ; Output: None
+25 ;
+26 ;protect FM package
NEW DIFROM
+27 ;sender
NEW XMDUZ
+28 ;subj
NEW XMSUB
+29 ;name of array (in open format) containing text of msg
NEW XMTEXT
+30 ;recipient array
NEW XMY
+31 ;returned msg #
NEW XMZ
+32 ;optional MM input vars
NEW XMMG,XMSTRIP,XMROU,XMYBLOB
+33 ;account
NEW PRCACCT
+34 ;recipient
NEW PRCREC
+35 ;
+36 Begin DoDot:1
+37 ;quit if production account
+38 IF $$PROD^XUPROD
SET PRCACCT=1
QUIT
+39 ;
+40 ;otherwise, retrieve all dates/times that an install was performed
+41 ;and determine if nationally released version of patch was installed
+42 NEW PRCINST,PRCINST1
+43 SET PRCINST1=""
+44 SET PRCINST=$$INSTALDT^XPDUTL("PRC*5.1*153",.PRCINST)
+45 IF +PRCINST>0
Begin DoDot:2
+46 NEW PRCINSTD
SET PRCINSTD=0
+47 ;loop thru install dates/times
+48 FOR
SET PRCINSTD=$ORDER(PRCINST(PRCINSTD))
if 'PRCINSTD
QUIT
Begin DoDot:3
+49 NEW PRCINST0
+50 SET PRCINST0=$GET(PRCINST(PRCINSTD))
+51 IF +$PIECE(PRCINST0,"^",2)>0
SET PRCINST1="P"
QUIT
+52 SET PRCINST1="T"
End DoDot:3
if PRCINST1="P"
QUIT
End DoDot:2
+53 SET PRCACCT=$SELECT(PRCINST1="T":2,1:0)
End DoDot:1
+54 ;
+55 SET PRCREC=$SELECT(PRCACCT=1:"XXX@Q-OLP.DOMAIN.EXT",PRCACCT=2:"G.OLP",1:0)
+56 if PRCREC=0
QUIT
+57 ;
+58 SET XMY(PRCREC)=""
+59 SET XMSUB="1358 TRANSACTION"
+60 SET XMDUZ="IFCAP/OLCS INTERFACE"
+61 SET XMTEXT=$$OREF^DILF(PRCXMTXT)
+62 ;
+63 ;send
+64 DO ^XMD
+65 QUIT
