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

PRCFDO.m

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