PRCFDO1 ;WOIFO/KCL - IFCAP/OLCS INTERFACE CONT. ;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
;
;
; This procedure is used to drive the process that will extract
; 1358 transactions for FY10 and FY11 and send them to the Online
; Certification System via MailMan messages. Each message will
; contain a maximum of 100 transaction records (200 message lines
; per batch).
;
; The following 1358 transaction types will be extracted
; and sent to OLCS:
; - Initial Obligation (when a 1358 is obligated in IFCAP)
; - Adjustment (increase/decrease to the 1358 obligated in IFCAP)
;
; Supported IAs:
; #10103: Allows use of supported Kernel call $$NOW^XLFDT
;
; Input: None
; Output: None
;
N PRC2237 ;Primary 2237-pointer to #410 file
N PRCPODT ;P.O. Date
N PRCIEN ;ien of record in #442 file
N PRC442Z ;zero node of #442 record
N PRCMSG ;closed root msg text array
N PRCCNT ;msg line count
N PRCINS ;array containing institution data
N PRCSTAT ;array containing extract statistics
N PRCPARM ;parameter
;
;init vars
S PRCPODT=3090930 ;scan start = 9/30/09
S PRCCNT=0
S PRCPARM="PRC OLCS 1358 EXTRACT"
S PRCMSG=$NA(^TMP("PRCOLCS",$J))
K @PRCMSG
;
;obtain site data and place into array
Q:'$$GETSITE(.PRCINS)
;
;init extract statistics array
Q:'$$INSTAT(.PRCINS,.PRCSTAT)
;
;primary loop thru purchase order creation dates
F S PRCPODT=$O(^PRC(442,"AB",PRCPODT)) Q:'PRCPODT D
. ;
. ;secondary loop thru purchase orders for the creation date
. S PRCIEN=0
. F S PRCIEN=$O(^PRC(442,"AB",PRCPODT,PRCIEN)) Q:'PRCIEN D
. . ;
. . ;get zero node of #442 record
. . S PRC442Z=$G(^PRC(442,PRCIEN,0))
. . ;
. . ;quit if Method of Processing '= MISC. OBLIGATION (1358)
. . Q:$P($G(PRC442Z),U,2)'=21
. . ;
. . ;quit if PRIMARY 2237 (pointer to #410) is missing
. . S PRC2237=$P($G(PRC442Z),U,12)
. . Q:PRC2237=""
. . ;
. . ;get/send 1358 transaction records
. . Q:'$$GET1358(PRCIEN,PRC2237,.PRCCNT,PRCMSG,.PRCINS,.PRCSTAT)
;
;send last partial batch of transactions if needed
I PRCCNT>0 D
. D MAIL^PRCFDO(PRCMSG) ;send partial batch msg
. S PRCSTAT("BATCH")=PRCSTAT("BATCH")+1 ;batch count
. K @PRCMSG ;cleanup msg text array
;
;set extract finish date/time into stats array and system parameter
S PRCSTAT("END")=$$NOW^XLFDT
S PRCSTAT("PARM")=PRCPARM
I $$SETPARM("SYS",PRCPARM,1,PRCSTAT("END")) D
. S PRCSTAT("PARMADD")="Successful"
E S PRCSTAT("PARMADD")="***FAILED***"
;
;send extract stats msg
D STATS(.PRCSTAT)
;
;cleanup task in ^XTMP if queued from POST2^PRC153P
I +$G(^XTMP("PRC153P","TASK")) K ^XTMP("PRC153P")
Q
;
;
GET1358(PRC442R,PRC410P,PRCCNT,PRCMSG,PRCIN,PRCST) ;Get & send 1358 transaction records
;
; This procedure obtains 1358 transaction records for 1358 initial
; obligations and adjustments (increase/decrease). It then sends those
; transaction records in a batch of 100 records (200 message lines per batch).
;
; Supported IAs:
; #3065 Allows use of supported Kernel call $$HLNAME^XLFNAME
; #10103 Allows use of supported Kernel call $$FMTHL7^XLFDT
; #10104 Allows use of supported Kernel call $$UP^XLFSTR
;
; Input:
; PRC442R - ien of record in #442 file
; PRC410R - ien of record in #410 file
; PRCCNT - msg line count, pass by reference
; PRCMSG - closed root msg text array
; PRCIN - institution data array, pass by reference
; PRCST - extract statistics array, pass by reference
;
; Output:
; Function Value - Returns 1 on success, 0 on failure
;
N PRCLIST ;list of #410 iens
N PRC410 ;ien of record in #410 file
N PRC410A ;1358 Adjustment
N PRC442I ;ien of record #442.09 subfile
N PRC7NODE ;7 node of #410 record
N PRCAPPID ;Approving Official (ptr to #200 file)
N PRCEVENT ;1358 event type
N PRCDNM ;array for call to HLNAME^XLFNAME
N PRCOBLID ;Obligated By (ptr to #200 file)
N PRCOBJ ;contains 1358 transaction object
N PRCODY0 ;zero node of #442.09 subfile record
N PRCREQID ;Requestor (ptr to #200 file)
N RESULT ;function return value
;
S RESULT=0
;
;quit if invalid input params
Q:+$G(PRC442R)'>0 RESULT
Q:+$G(PRC410P)'>0 RESULT
;
;place Facility-Name and Station-Number into 1358 transaction array
S PRCOBJ("FACNM")=$G(PRCIN("FACNAME"))
S PRCOBJ("FACNUM")=$G(PRCIN("FACNUMB"))
;
;loop thru OBLIGATION DATA (#442.09) multiple
S PRC442I=0
F S PRC442I=$O(^PRC(442,PRC442R,10,PRC442I)) Q:'PRC442I D
. ;
. ;get zero node of subfile record
. S PRCODY0=$G(^PRC(442,PRC442R,10,PRC442I,0))
. ;
. ;skip entries that are not SO or AR code sheet (excludes PV)
. Q:"^SO^AR^"'[(U_$E(PRCODY0,1,2)_U)
. ;
. ;1358 Adjustment (ptr to #410 file)
. S PRC410A=$P(PRCODY0,U,11)
. ;
. ;associated #410 entry
. S PRC410=$S(PRC410A]"":PRC410A,1:PRC410P)
. ;
. ;determine event type and if not rebuild add #410 entry to list
. I $D(PRCLIST(PRC410)) S PRCEVENT="R" ;Rebuild
. E S PRCEVENT=$S(PRC410A]"":"A",1:"O"),PRCLIST(PRC410)=""
. ;
. ;quit if rebuild since that does not impact certifier role
. Q:PRCEVENT="R"
. ;
. ;Obligation-Number
. S PRCOBJ("OBLNUM")=$P($G(^PRC(442,PRC442R,0)),U,1)
. ;
. ;Transaction-Type
. S PRCOBJ("TRANTYPE")=PRCEVENT
. ;
. ;Event-Date_Time (Date Signed) in HL7 format YYYYMMDDHHMMSS-XXXX
. ;where (-XXXX is the Greenwich Mean Time offset)
. S PRCOBJ("OBLDATE")=$$FMTHL7^XLFDT($P(PRCODY0,U,6))
. ;concatenate '00' seconds if Date Signed was filed precisely on the hour and minute
. I $L($P(PRCOBJ("OBLDATE"),"-"))=12 D
. . S PRCOBJ("OBLDATE")=$P(PRCOBJ("OBLDATE"),"-")_"00-"_$P(PRCOBJ("OBLDATE"),"-",2)
. ;
. ;get Requestor, Approver, Obligator iens
. S PRC7NODE=$G(^PRCS(410,PRC410,7))
. S PRCREQID=$P(PRC7NODE,U,1)
. S PRCAPPID=$P(PRC7NODE,U,3)
. S PRCOBLID=$P(PRCODY0,U,2)
. ;
. ;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 PRCOBJ("REQNAME")=$S(+PRCREQID>0:$$HLNAME^XLFNAME(.PRCDNM,"","|"),1:"")
. I PRCOBJ("REQNAME")]"" S PRCOBJ("REQNAME")=$P($$UP^XLFSTR(PRCOBJ("REQNAME")),"|",1,4)
. S PRCDNM("IENS")=+PRCAPPID_","
. S PRCOBJ("APPNAME")=$S(+PRCAPPID>0:$$HLNAME^XLFNAME(.PRCDNM,"","|"),1:"")
. I PRCOBJ("APPNAME")]"" S PRCOBJ("APPNAME")=$P($$UP^XLFSTR(PRCOBJ("APPNAME")),"|",1,4)
. S PRCDNM("IENS")=+PRCOBLID_","
. S PRCOBJ("OBLNAME")=$S(+PRCOBLID>0:$$HLNAME^XLFNAME(.PRCDNM,"","|"),1:"")
. I PRCOBJ("OBLNAME")]"" S PRCOBJ("OBLNAME")=$P($$UP^XLFSTR(PRCOBJ("OBLNAME")),"|",1,4)
. ;
. ;place Requestor, Approver, and Obligator IDs in format 'Station#-UserId'
. S PRCOBJ("REQID")=PRCOBJ("FACNUM")_"-"_PRCREQID
. S PRCOBJ("APPID")=PRCOBJ("FACNUM")_"-"_PRCAPPID
. S PRCOBJ("OBLID")=PRCOBJ("FACNUM")_"-"_PRCOBLID
. ;
. ;validate 1358 transaction data elements, don't check
. ;for required elements
. Q:'$$VALID^PRCFDO(.PRCOBJ,0)
. ;
. ;count of initial obligations and adjustments
. I PRCOBJ("TRANTYPE")="O" S PRCST("OBL")=PRCST("OBL")+1
. E S PRCST("ADJ")=PRCST("ADJ")+1
. ;
. ;build 1358 transaction msg
. D BLDMSG^PRCFDO(.PRCOBJ,.PRCCNT,"^","~",PRCMSG)
. S PRCST("SENT")=PRCST("SENT")+1 ;record count
. ;
. ;send 100 records per batch (= 200 lines per msg)
. I PRCCNT=200 D
. . D MAIL^PRCFDO(PRCMSG) ;send batch msg
. . K @PRCMSG ;reset msg text array
. . S PRCCNT=0 ;reset line count for next batch
. . S PRCST("BATCH")=PRCST("BATCH")+1 ;batch count
;
S RESULT=1
Q RESULT
;
;
STATS(PRCSTAT) ;Generate extract statistics message
;
; This procedure will generate a MailMan message containing statistics
; from the extract of 1358 transactions.
;
; Supported IAs:
; #10104 Allows use of supported Kernel call $$RJ^XLFSTR
; #10070 Allows use of supported MailMan call ^XMD
;
; Input:
; PRCSTAT - array containing the extract statistics
;
; Output: None
;
N DIFROM ;protect FM package
N XMDUZ ;sender
N XMSUB ;msg subject
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 PRCTXT ;msg text array
;
I '$D(XMY) S XMY(.5)=""
I +$G(PRCSTAT("USER")) S XMY(+$G(PRCSTAT("USER")))=""
S XMSUB="PRC*5.1*153-Extract Results-Station #"_$G(PRCSTAT("FACNUM"))
S XMDUZ="IFCAP/OLCS INTERFACE"
S PRCTXT(1)=""
S PRCTXT(2)=" >>>>>>>>>> Patch PRC*5.1*153-Extract 1358s Results <<<<<<<<<<"
S PRCTXT(3)=""
S PRCTXT(4)=" Date/Time extract job started: "_$$FMTE^XLFDT($G(PRCSTAT("START")),"1P")
S PRCTXT(5)=" Date/Time extract job stopped: "_$$FMTE^XLFDT($G(PRCSTAT("END")),"1P")
S PRCTXT(6)=""
S PRCTXT(7)=" Batch messages sent to OLCS: "_$$RJ^XLFSTR($G(PRCSTAT("BATCH")),6)
S PRCTXT(8)=" 1358 transactions sent to OLCS: "_$$RJ^XLFSTR($G(PRCSTAT("SENT")),6)
S PRCTXT(9)=" Initial Obligations: "_$$RJ^XLFSTR($G(PRCSTAT("OBL")),6)
S PRCTXT(10)=" Adjustments: "_$$RJ^XLFSTR($G(PRCSTAT("ADJ")),6)
S PRCTXT(11)=""
S PRCTXT(12)=" PARAMETERS (#8989.5) file update: "_$G(PRCSTAT("PARMADD"))
S PRCTXT(13)=" Parameter: "_$G(PRCSTAT("PARM"))
S XMTEXT="PRCTXT("
;send msg
D ^XMD
Q
;
;
INSTAT(PRCIN,PRCS) ;Initialize extract statistics array
;
; This function is used to initialize the array that will contain the
; extract statistics.
;
; Supported IAs:
; #10103: Allows use of supported Kernel call $$NOW^XLFDT
;
; Input:
; PRCIN - Array containing Institution_Name and Station_Number, passed
; by reference
; PRCS - (required) Result array passed by reference
;
; Output:
; Function Value - Returns 1 on success, 0 on failure
; PRCS - initialized extract statistics array
;
; Subscript Description
; --------- ------------------------------------------
; "FACNM" Institution Name
; "FACNUM" Station Number
; "START" Extract start date/time
; "END" Extract end date/time
; "BATCH" Count of batch messages sent
; "SENT" Count of 1358 transactions sent
; "OBL" Initial obligations count
; "ADJ" Adjustment event count
; "PARM" PARAMETERS (#8989.5) file entry
; "PARMADD" Entry added to PARAMETERS (#8989.5) file? (Y/N)
; "USER" User queuing/running extract
;
N RESULT ;function return value
;
S RESULT=0
S PRCS("FACNM")=$G(PRCIN("FACNAME"))
S PRCS("FACNUM")=$G(PRCIN("FACNUMB"))
S PRCS("START")=$$NOW^XLFDT
S PRCS("END")=""
S PRCS("BATCH")=0
S PRCS("SENT")=0
S PRCS("OBL")=0
S PRCS("ADJ")=0
S PRCS("PARM")=""
S PRCS("PARMADD")=""
S PRCS("USER")=$S($G(DUZ)>0:DUZ,1:"")
;
S RESULT=1
Q RESULT
;
;
GETSITE(PRCINST) ;Get site data
;
; This function is used to obtain the Institution_Name and Station_Number.
; The data will then be placed into an array format.
;
; Supported IAs:
; #2171 Allows use of supported Kernel call $$NS^XUAF4
; #2541 Allows use of supported Kernel call $$KSP^XUPARAM
;
; Input:
; PRCINST - (required) Result array passed by reference
;
; Output:
; Function Value - Returns 1 on success, 0 on failure
; PRCINST - Output array containing site data
;
; Subscript Description
; ---------- ----------------
; "FACNAME" institution name
; "FACNUMB" station number
;
N RESULT ;function return value
N PRCSITE ;caret-delimited string (institution_name^station_number)
;
S RESULT=0
;
;retrieve Institution Name and Station Number from the site's INSTITUTION file
S PRCSITE=$$NS^XUAF4(+$$KSP^XUPARAM("INST"))
S PRCINST("FACNAME")=$P($G(PRCSITE),U)
S PRCINST("FACNUMB")=$P($G(PRCSITE),U,2)
;
S RESULT=1
Q RESULT
;
;
SETPARM(PRCPENT,PRCPARM,PRCPINS,PRCPVAL) ;Add parameter value
;
; This function acts as wrapper for EN^XPAR and is used to add
; a new entry in the PARAMETERS (#8989.5) file.
;
; Supported IAs:
; #2263: Allows use of supported Kernel call EN^XPAR
;
; Input:
; PRCPENT - parameter entity
; PRCPARM - PARAMETER DEFINITION name
; PRCPINS - parameter instance
; PRCPVAL - parameter value
;
; Output:
; Function Value - Returns 1 if parameter value added, 0 otherwise
;
N RESULT
S RESULT=1
D EN^XPAR($G(PRCPENT),$G(PRCPARM),+$G(PRCPINS),$G(PRCPVAL),.PRCMSG)
I $G(PRCMSG) S RESULT=0
Q RESULT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFDO1 13117 printed Sep 23, 2025@19:39:09 Page 2
PRCFDO1 ;WOIFO/KCL - IFCAP/OLCS INTERFACE CONT. ;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 ;
+1 ;
+2 ; This procedure is used to drive the process that will extract
+3 ; 1358 transactions for FY10 and FY11 and send them to the Online
+4 ; Certification System via MailMan messages. Each message will
+5 ; contain a maximum of 100 transaction records (200 message lines
+6 ; per batch).
+7 ;
+8 ; The following 1358 transaction types will be extracted
+9 ; and sent to OLCS:
+10 ; - Initial Obligation (when a 1358 is obligated in IFCAP)
+11 ; - Adjustment (increase/decrease to the 1358 obligated in IFCAP)
+12 ;
+13 ; Supported IAs:
+14 ; #10103: Allows use of supported Kernel call $$NOW^XLFDT
+15 ;
+16 ; Input: None
+17 ; Output: None
+18 ;
+19 ;Primary 2237-pointer to #410 file
NEW PRC2237
+20 ;P.O. Date
NEW PRCPODT
+21 ;ien of record in #442 file
NEW PRCIEN
+22 ;zero node of #442 record
NEW PRC442Z
+23 ;closed root msg text array
NEW PRCMSG
+24 ;msg line count
NEW PRCCNT
+25 ;array containing institution data
NEW PRCINS
+26 ;array containing extract statistics
NEW PRCSTAT
+27 ;parameter
NEW PRCPARM
+28 ;
+29 ;init vars
+30 ;scan start = 9/30/09
SET PRCPODT=3090930
+31 SET PRCCNT=0
+32 SET PRCPARM="PRC OLCS 1358 EXTRACT"
+33 SET PRCMSG=$NAME(^TMP("PRCOLCS",$JOB))
+34 KILL @PRCMSG
+35 ;
+36 ;obtain site data and place into array
+37 if '$$GETSITE(.PRCINS)
QUIT
+38 ;
+39 ;init extract statistics array
+40 if '$$INSTAT(.PRCINS,.PRCSTAT)
QUIT
+41 ;
+42 ;primary loop thru purchase order creation dates
+43 FOR
SET PRCPODT=$ORDER(^PRC(442,"AB",PRCPODT))
if 'PRCPODT
QUIT
Begin DoDot:1
+44 ;
+45 ;secondary loop thru purchase orders for the creation date
+46 SET PRCIEN=0
+47 FOR
SET PRCIEN=$ORDER(^PRC(442,"AB",PRCPODT,PRCIEN))
if 'PRCIEN
QUIT
Begin DoDot:2
+48 ;
+49 ;get zero node of #442 record
+50 SET PRC442Z=$GET(^PRC(442,PRCIEN,0))
+51 ;
+52 ;quit if Method of Processing '= MISC. OBLIGATION (1358)
+53 if $PIECE($GET(PRC442Z),U,2)'=21
QUIT
+54 ;
+55 ;quit if PRIMARY 2237 (pointer to #410) is missing
+56 SET PRC2237=$PIECE($GET(PRC442Z),U,12)
+57 if PRC2237=""
QUIT
+58 ;
+59 ;get/send 1358 transaction records
+60 if '$$GET1358(PRCIEN,PRC2237,.PRCCNT,PRCMSG,.PRCINS,.PRCSTAT)
QUIT
End DoDot:2
End DoDot:1
+61 ;
+62 ;send last partial batch of transactions if needed
+63 IF PRCCNT>0
Begin DoDot:1
+64 ;send partial batch msg
DO MAIL^PRCFDO(PRCMSG)
+65 ;batch count
SET PRCSTAT("BATCH")=PRCSTAT("BATCH")+1
+66 ;cleanup msg text array
KILL @PRCMSG
End DoDot:1
+67 ;
+68 ;set extract finish date/time into stats array and system parameter
+69 SET PRCSTAT("END")=$$NOW^XLFDT
+70 SET PRCSTAT("PARM")=PRCPARM
+71 IF $$SETPARM("SYS",PRCPARM,1,PRCSTAT("END"))
Begin DoDot:1
+72 SET PRCSTAT("PARMADD")="Successful"
End DoDot:1
+73 IF '$TEST
SET PRCSTAT("PARMADD")="***FAILED***"
+74 ;
+75 ;send extract stats msg
+76 DO STATS(.PRCSTAT)
+77 ;
+78 ;cleanup task in ^XTMP if queued from POST2^PRC153P
+79 IF +$GET(^XTMP("PRC153P","TASK"))
KILL ^XTMP("PRC153P")
+80 QUIT
+81 ;
+82 ;
GET1358(PRC442R,PRC410P,PRCCNT,PRCMSG,PRCIN,PRCST) ;Get & send 1358 transaction records
+1 ;
+2 ; This procedure obtains 1358 transaction records for 1358 initial
+3 ; obligations and adjustments (increase/decrease). It then sends those
+4 ; transaction records in a batch of 100 records (200 message lines per batch).
+5 ;
+6 ; Supported IAs:
+7 ; #3065 Allows use of supported Kernel call $$HLNAME^XLFNAME
+8 ; #10103 Allows use of supported Kernel call $$FMTHL7^XLFDT
+9 ; #10104 Allows use of supported Kernel call $$UP^XLFSTR
+10 ;
+11 ; Input:
+12 ; PRC442R - ien of record in #442 file
+13 ; PRC410R - ien of record in #410 file
+14 ; PRCCNT - msg line count, pass by reference
+15 ; PRCMSG - closed root msg text array
+16 ; PRCIN - institution data array, pass by reference
+17 ; PRCST - extract statistics array, pass by reference
+18 ;
+19 ; Output:
+20 ; Function Value - Returns 1 on success, 0 on failure
+21 ;
+22 ;list of #410 iens
NEW PRCLIST
+23 ;ien of record in #410 file
NEW PRC410
+24 ;1358 Adjustment
NEW PRC410A
+25 ;ien of record #442.09 subfile
NEW PRC442I
+26 ;7 node of #410 record
NEW PRC7NODE
+27 ;Approving Official (ptr to #200 file)
NEW PRCAPPID
+28 ;1358 event type
NEW PRCEVENT
+29 ;array for call to HLNAME^XLFNAME
NEW PRCDNM
+30 ;Obligated By (ptr to #200 file)
NEW PRCOBLID
+31 ;contains 1358 transaction object
NEW PRCOBJ
+32 ;zero node of #442.09 subfile record
NEW PRCODY0
+33 ;Requestor (ptr to #200 file)
NEW PRCREQID
+34 ;function return value
NEW RESULT
+35 ;
+36 SET RESULT=0
+37 ;
+38 ;quit if invalid input params
+39 if +$GET(PRC442R)'>0
QUIT RESULT
+40 if +$GET(PRC410P)'>0
QUIT RESULT
+41 ;
+42 ;place Facility-Name and Station-Number into 1358 transaction array
+43 SET PRCOBJ("FACNM")=$GET(PRCIN("FACNAME"))
+44 SET PRCOBJ("FACNUM")=$GET(PRCIN("FACNUMB"))
+45 ;
+46 ;loop thru OBLIGATION DATA (#442.09) multiple
+47 SET PRC442I=0
+48 FOR
SET PRC442I=$ORDER(^PRC(442,PRC442R,10,PRC442I))
if 'PRC442I
QUIT
Begin DoDot:1
+49 ;
+50 ;get zero node of subfile record
+51 SET PRCODY0=$GET(^PRC(442,PRC442R,10,PRC442I,0))
+52 ;
+53 ;skip entries that are not SO or AR code sheet (excludes PV)
+54 if "^SO^AR^"'[(U_$EXTRACT(PRCODY0,1,2)_U)
QUIT
+55 ;
+56 ;1358 Adjustment (ptr to #410 file)
+57 SET PRC410A=$PIECE(PRCODY0,U,11)
+58 ;
+59 ;associated #410 entry
+60 SET PRC410=$SELECT(PRC410A]"":PRC410A,1:PRC410P)
+61 ;
+62 ;determine event type and if not rebuild add #410 entry to list
+63 ;Rebuild
IF $DATA(PRCLIST(PRC410))
SET PRCEVENT="R"
+64 IF '$TEST
SET PRCEVENT=$SELECT(PRC410A]"":"A",1:"O")
SET PRCLIST(PRC410)=""
+65 ;
+66 ;quit if rebuild since that does not impact certifier role
+67 if PRCEVENT="R"
QUIT
+68 ;
+69 ;Obligation-Number
+70 SET PRCOBJ("OBLNUM")=$PIECE($GET(^PRC(442,PRC442R,0)),U,1)
+71 ;
+72 ;Transaction-Type
+73 SET PRCOBJ("TRANTYPE")=PRCEVENT
+74 ;
+75 ;Event-Date_Time (Date Signed) in HL7 format YYYYMMDDHHMMSS-XXXX
+76 ;where (-XXXX is the Greenwich Mean Time offset)
+77 SET PRCOBJ("OBLDATE")=$$FMTHL7^XLFDT($PIECE(PRCODY0,U,6))
+78 ;concatenate '00' seconds if Date Signed was filed precisely on the hour and minute
+79 IF $LENGTH($PIECE(PRCOBJ("OBLDATE"),"-"))=12
Begin DoDot:2
+80 SET PRCOBJ("OBLDATE")=$PIECE(PRCOBJ("OBLDATE"),"-")_"00-"_$PIECE(PRCOBJ("OBLDATE"),"-",2)
End DoDot:2
+81 ;
+82 ;get Requestor, Approver, Obligator iens
+83 SET PRC7NODE=$GET(^PRCS(410,PRC410,7))
+84 SET PRCREQID=$PIECE(PRC7NODE,U,1)
+85 SET PRCAPPID=$PIECE(PRC7NODE,U,3)
+86 SET PRCOBLID=$PIECE(PRCODY0,U,2)
+87 ;
+88 ;set up array for call to HLNAME^XLFNAME
+89 SET PRCDNM("FILE")=200
+90 SET PRCDNM("FIELD")=.01
+91 ;place Requestor, Approver, and Obligator names
+92 ;in HL7 format. Name components (LAST|FIRST|MIDDLE|SUFFIX)
+93 SET PRCDNM("IENS")=+PRCREQID_","
+94 SET PRCOBJ("REQNAME")=$SELECT(+PRCREQID>0:$$HLNAME^XLFNAME(.PRCDNM,"","|"),1:"")
+95 IF PRCOBJ("REQNAME")]""
SET PRCOBJ("REQNAME")=$PIECE($$UP^XLFSTR(PRCOBJ("REQNAME")),"|",1,4)
+96 SET PRCDNM("IENS")=+PRCAPPID_","
+97 SET PRCOBJ("APPNAME")=$SELECT(+PRCAPPID>0:$$HLNAME^XLFNAME(.PRCDNM,"","|"),1:"")
+98 IF PRCOBJ("APPNAME")]""
SET PRCOBJ("APPNAME")=$PIECE($$UP^XLFSTR(PRCOBJ("APPNAME")),"|",1,4)
+99 SET PRCDNM("IENS")=+PRCOBLID_","
+100 SET PRCOBJ("OBLNAME")=$SELECT(+PRCOBLID>0:$$HLNAME^XLFNAME(.PRCDNM,"","|"),1:"")
+101 IF PRCOBJ("OBLNAME")]""
SET PRCOBJ("OBLNAME")=$PIECE($$UP^XLFSTR(PRCOBJ("OBLNAME")),"|",1,4)
+102 ;
+103 ;place Requestor, Approver, and Obligator IDs in format 'Station#-UserId'
+104 SET PRCOBJ("REQID")=PRCOBJ("FACNUM")_"-"_PRCREQID
+105 SET PRCOBJ("APPID")=PRCOBJ("FACNUM")_"-"_PRCAPPID
+106 SET PRCOBJ("OBLID")=PRCOBJ("FACNUM")_"-"_PRCOBLID
+107 ;
+108 ;validate 1358 transaction data elements, don't check
+109 ;for required elements
+110 if '$$VALID^PRCFDO(.PRCOBJ,0)
QUIT
+111 ;
+112 ;count of initial obligations and adjustments
+113 IF PRCOBJ("TRANTYPE")="O"
SET PRCST("OBL")=PRCST("OBL")+1
+114 IF '$TEST
SET PRCST("ADJ")=PRCST("ADJ")+1
+115 ;
+116 ;build 1358 transaction msg
+117 DO BLDMSG^PRCFDO(.PRCOBJ,.PRCCNT,"^","~",PRCMSG)
+118 ;record count
SET PRCST("SENT")=PRCST("SENT")+1
+119 ;
+120 ;send 100 records per batch (= 200 lines per msg)
+121 IF PRCCNT=200
Begin DoDot:2
+122 ;send batch msg
DO MAIL^PRCFDO(PRCMSG)
+123 ;reset msg text array
KILL @PRCMSG
+124 ;reset line count for next batch
SET PRCCNT=0
+125 ;batch count
SET PRCST("BATCH")=PRCST("BATCH")+1
End DoDot:2
End DoDot:1
+126 ;
+127 SET RESULT=1
+128 QUIT RESULT
+129 ;
+130 ;
STATS(PRCSTAT) ;Generate extract statistics message
+1 ;
+2 ; This procedure will generate a MailMan message containing statistics
+3 ; from the extract of 1358 transactions.
+4 ;
+5 ; Supported IAs:
+6 ; #10104 Allows use of supported Kernel call $$RJ^XLFSTR
+7 ; #10070 Allows use of supported MailMan call ^XMD
+8 ;
+9 ; Input:
+10 ; PRCSTAT - array containing the extract statistics
+11 ;
+12 ; Output: None
+13 ;
+14 ;protect FM package
NEW DIFROM
+15 ;sender
NEW XMDUZ
+16 ;msg subject
NEW XMSUB
+17 ;name of array (in open format) containing text of msg
NEW XMTEXT
+18 ;recipient array
NEW XMY
+19 ;returned msg #
NEW XMZ
+20 ;optional MM input vars
NEW XMMG,XMSTRIP,XMROU,XMYBLOB
+21 ;msg text array
NEW PRCTXT
+22 ;
+23 IF '$DATA(XMY)
SET XMY(.5)=""
+24 IF +$GET(PRCSTAT("USER"))
SET XMY(+$GET(PRCSTAT("USER")))=""
+25 SET XMSUB="PRC*5.1*153-Extract Results-Station #"_$GET(PRCSTAT("FACNUM"))
+26 SET XMDUZ="IFCAP/OLCS INTERFACE"
+27 SET PRCTXT(1)=""
+28 SET PRCTXT(2)=" >>>>>>>>>> Patch PRC*5.1*153-Extract 1358s Results <<<<<<<<<<"
+29 SET PRCTXT(3)=""
+30 SET PRCTXT(4)=" Date/Time extract job started: "_$$FMTE^XLFDT($GET(PRCSTAT("START")),"1P")
+31 SET PRCTXT(5)=" Date/Time extract job stopped: "_$$FMTE^XLFDT($GET(PRCSTAT("END")),"1P")
+32 SET PRCTXT(6)=""
+33 SET PRCTXT(7)=" Batch messages sent to OLCS: "_$$RJ^XLFSTR($GET(PRCSTAT("BATCH")),6)
+34 SET PRCTXT(8)=" 1358 transactions sent to OLCS: "_$$RJ^XLFSTR($GET(PRCSTAT("SENT")),6)
+35 SET PRCTXT(9)=" Initial Obligations: "_$$RJ^XLFSTR($GET(PRCSTAT("OBL")),6)
+36 SET PRCTXT(10)=" Adjustments: "_$$RJ^XLFSTR($GET(PRCSTAT("ADJ")),6)
+37 SET PRCTXT(11)=""
+38 SET PRCTXT(12)=" PARAMETERS (#8989.5) file update: "_$GET(PRCSTAT("PARMADD"))
+39 SET PRCTXT(13)=" Parameter: "_$GET(PRCSTAT("PARM"))
+40 SET XMTEXT="PRCTXT("
+41 ;send msg
+42 DO ^XMD
+43 QUIT
+44 ;
+45 ;
INSTAT(PRCIN,PRCS) ;Initialize extract statistics array
+1 ;
+2 ; This function is used to initialize the array that will contain the
+3 ; extract statistics.
+4 ;
+5 ; Supported IAs:
+6 ; #10103: Allows use of supported Kernel call $$NOW^XLFDT
+7 ;
+8 ; Input:
+9 ; PRCIN - Array containing Institution_Name and Station_Number, passed
+10 ; by reference
+11 ; PRCS - (required) Result array passed by reference
+12 ;
+13 ; Output:
+14 ; Function Value - Returns 1 on success, 0 on failure
+15 ; PRCS - initialized extract statistics array
+16 ;
+17 ; Subscript Description
+18 ; --------- ------------------------------------------
+19 ; "FACNM" Institution Name
+20 ; "FACNUM" Station Number
+21 ; "START" Extract start date/time
+22 ; "END" Extract end date/time
+23 ; "BATCH" Count of batch messages sent
+24 ; "SENT" Count of 1358 transactions sent
+25 ; "OBL" Initial obligations count
+26 ; "ADJ" Adjustment event count
+27 ; "PARM" PARAMETERS (#8989.5) file entry
+28 ; "PARMADD" Entry added to PARAMETERS (#8989.5) file? (Y/N)
+29 ; "USER" User queuing/running extract
+30 ;
+31 ;function return value
NEW RESULT
+32 ;
+33 SET RESULT=0
+34 SET PRCS("FACNM")=$GET(PRCIN("FACNAME"))
+35 SET PRCS("FACNUM")=$GET(PRCIN("FACNUMB"))
+36 SET PRCS("START")=$$NOW^XLFDT
+37 SET PRCS("END")=""
+38 SET PRCS("BATCH")=0
+39 SET PRCS("SENT")=0
+40 SET PRCS("OBL")=0
+41 SET PRCS("ADJ")=0
+42 SET PRCS("PARM")=""
+43 SET PRCS("PARMADD")=""
+44 SET PRCS("USER")=$SELECT($GET(DUZ)>0:DUZ,1:"")
+45 ;
+46 SET RESULT=1
+47 QUIT RESULT
+48 ;
+49 ;
GETSITE(PRCINST) ;Get site data
+1 ;
+2 ; This function is used to obtain the Institution_Name and Station_Number.
+3 ; The data will then be placed into an array format.
+4 ;
+5 ; Supported IAs:
+6 ; #2171 Allows use of supported Kernel call $$NS^XUAF4
+7 ; #2541 Allows use of supported Kernel call $$KSP^XUPARAM
+8 ;
+9 ; Input:
+10 ; PRCINST - (required) Result array passed by reference
+11 ;
+12 ; Output:
+13 ; Function Value - Returns 1 on success, 0 on failure
+14 ; PRCINST - Output array containing site data
+15 ;
+16 ; Subscript Description
+17 ; ---------- ----------------
+18 ; "FACNAME" institution name
+19 ; "FACNUMB" station number
+20 ;
+21 ;function return value
NEW RESULT
+22 ;caret-delimited string (institution_name^station_number)
NEW PRCSITE
+23 ;
+24 SET RESULT=0
+25 ;
+26 ;retrieve Institution Name and Station Number from the site's INSTITUTION file
+27 SET PRCSITE=$$NS^XUAF4(+$$KSP^XUPARAM("INST"))
+28 SET PRCINST("FACNAME")=$PIECE($GET(PRCSITE),U)
+29 SET PRCINST("FACNUMB")=$PIECE($GET(PRCSITE),U,2)
+30 ;
+31 SET RESULT=1
+32 QUIT RESULT
+33 ;
+34 ;
SETPARM(PRCPENT,PRCPARM,PRCPINS,PRCPVAL) ;Add parameter value
+1 ;
+2 ; This function acts as wrapper for EN^XPAR and is used to add
+3 ; a new entry in the PARAMETERS (#8989.5) file.
+4 ;
+5 ; Supported IAs:
+6 ; #2263: Allows use of supported Kernel call EN^XPAR
+7 ;
+8 ; Input:
+9 ; PRCPENT - parameter entity
+10 ; PRCPARM - PARAMETER DEFINITION name
+11 ; PRCPINS - parameter instance
+12 ; PRCPVAL - parameter value
+13 ;
+14 ; Output:
+15 ; Function Value - Returns 1 if parameter value added, 0 otherwise
+16 ;
+17 NEW RESULT
+18 SET RESULT=1
+19 DO EN^XPAR($GET(PRCPENT),$GET(PRCPARM),+$GET(PRCPINS),$GET(PRCPVAL),.PRCMSG)
+20 IF $GET(PRCMSG)
SET RESULT=0
+21 QUIT RESULT
