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

PRCEMOA.m

Go to the documentation of this file.
  1. PRCEMOA ;WOIFO/SAB - 1358 OBLIGATION APIS ;6/30/11 15:34
  1. V ;;5.1;IFCAP;**152,158**;Oct 20, 2000;Build 1
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. Q
  1. ;
  1. UOKCERT(PRCOUT,PRC1358,PRCPER) ; User OK as Certifier for a 1358
  1. ; This API verifies that the person would not violate segregation of
  1. ; duty when certifying an invoice associated with a 1358 obligation
  1. ; by ensuring that they have not previously acted as a requestor,
  1. ; approver, or obligator on that 1358.
  1. ;
  1. ; inputs
  1. ; PRCOUT - output variable, passed by reference
  1. ; PRC1358 - 1358 obligation number (e.g. 688-C15001)
  1. ; PRCPER - User, NEW PERSON (#200) file IEN
  1. ; output
  1. ; PRCOUT will be set equal to one of the following values
  1. ; =1 if person can certify an invoice associated with the 1358
  1. ; =0^text if person not OK as certifier due to segregation of duties
  1. ; where text is of the form
  1. ; You are the 'role' of 'an event'.
  1. ; e.g. "You are the Requestor of an Adjustment to the 1358."
  1. ; =E^text if problem with inputs or the 1358 data
  1. ; where list of possible error text is:
  1. ; The 1358 number was not specified.
  1. ; The Person was not specified.
  1. ; The 1358 was not found in file 442.
  1. ; The document is not a 1358.
  1. ; The PRIMARY 2237 value is missing.
  1. ;
  1. N PRC410P,PRC442,PRCLIST,PRCODI
  1. S PRCOUT=1 ; init output value
  1. ;
  1. ; verify inputs
  1. D
  1. . N PRCY0
  1. . ; check for required inputs
  1. . I $G(PRC1358)="" S PRCOUT="E^The 1358 number was not specified." Q
  1. . I $G(PRCPER)="" S PRCOUT="E^The Person was not specified." Q
  1. . ;
  1. . ; find 1358 in file 442
  1. . S PRC442=$O(^PRC(442,"B",PRC1358,0))
  1. . I PRC442'>0 S PRCOUT="E^The 1358 was not found in file 442." Q
  1. . ;
  1. . S PRCY0=$G(^PRC(442,PRC442,0))
  1. . ;
  1. . ; Verify METHOD OF PROCESSING = IEN 21 1358 OBLIGATION
  1. . I $P(PRCY0,U,2)'=21 S PRCOUT="E^The document is not a 1358." Q
  1. . ;
  1. . ; get PRIMARY 2237
  1. . S PRC410P=$P(PRCY0,U,12)
  1. . I PRC410P="" S PRCOUT="E^The PRIMARY 2237 value is missing." Q
  1. ;
  1. ; loop thru OBLIGATION DATA multiple
  1. I PRCOUT D
  1. . S PRCODI=0
  1. . F S PRCODI=$O(^PRC(442,PRC442,10,PRCODI)) Q:'PRCODI D Q:'PRCOUT
  1. . . N PRC410,PRC410A,PRC7Y,PRCACT,PRCEVENT,PRCODY0,PRCROLE
  1. . . S PRCODY0=$G(^PRC(442,PRC442,10,PRCODI,0))
  1. . . ;
  1. . . ; skip entries that are not SO or AR code sheet (excludes PV)
  1. . . Q:"^SO^AR^"'[(U_$E(PRCODY0,1,2)_U)
  1. . . ;
  1. . . S PRC410A=$P(PRCODY0,U,11) ; 1358 ADJUSTMENT
  1. . . S PRC410=$S(PRC410A]"":PRC410A,1:PRC410P) ; associated 410 entry
  1. . . ;
  1. . . ; determine event type and if not rebuild add 410 entry to list
  1. . . I $D(PRCLIST(PRC410)) S PRCEVENT="R" ; rebuild
  1. . . E S PRCEVENT=$S(PRC410A]"":"A",1:"O"),PRCLIST(PRC410)=""
  1. . . ;
  1. . . ; quit if rebuild since that does not impact certifier role
  1. . . Q:PRCEVENT="R"
  1. . . ;
  1. . . I $P(PRCODY0,U,2) S PRCACT($P(PRCODY0,U,2))="O" ; OBLIGATED BY
  1. . . ; get REQUESTOR and APPROVER from file 410
  1. . . S PRC7Y=$G(^PRCS(410,PRC410,7))
  1. . . I $P(PRC7Y,U,1) S PRCACT($P(PRC7Y,U,1))="R" ; REQUESTOR
  1. . . I $P(PRC7Y,U,3) S PRCACT($P(PRC7Y,U,3))="A" ; APPROVING OFFICIAL
  1. . . ;
  1. . . ; check if person acted on this 1358 event in IFCAP
  1. . . S PRCROLE=$G(PRCACT(PRCPER))
  1. . . I PRCROLE]"" D
  1. . . . S PRCOUT="0^You are the "
  1. . . . S PRCOUT=PRCOUT_$S(PRCROLE="R":"Requestor",PRCROLE="A":"Approving Official",1:"Obligator")
  1. . . . S PRCOUT=PRCOUT_" "_$S(PRCEVENT="O":"of the 1358",1:"of an Adjustment to the 1358")_"."
  1. ;
  1. Q
  1. ;
  1. EV1358(PRC1358,PRCARR) ; Events (and Actors) for a 1358
  1. ; input
  1. ; PRC1358 - 1358 number (e.g. 688-C15001)
  1. ; PRCARR - (optional) results array name, passed by value,
  1. ; closed root, default value is "^TMP(""PRC1358"",$J)"
  1. ; The root must NOT be a variable name newed by this API
  1. ; (PRC1358,PRCARR,PRC410P,PRC442,PRCLIST,PRCODI,PRCRET)
  1. ; return value = 1 or E^text
  1. ; = 1 if no problems
  1. ; = E^text if problem with inputs or 1358 data
  1. ; List of possible errors
  1. ; The array name is invalid.
  1. ; The 1358 number was not specified.
  1. ; The 1358 was not found in file 442.
  1. ; The document is not a 1358.
  1. ; The PRIMARY 2237 value is missing.
  1. ; output
  1. ; PRCARR - array is initialized and populated
  1. ; PRCARR(DATE/TIME,EVENT)=REQUESTOR^APPROVER^OBLIGATOR
  1. ; where
  1. ; DATE/TIME is a FileMan Date/Time (internal format) when
  1. ; the transaction was obligated
  1. ; EVENT is O (OBLIGATE), or A (ADJUST)
  1. ; REQUESTOR is a NEW PERSON ien or null value
  1. ; APPROVER is a NEW PERSON ien or null value
  1. ; OBLIGATOR is a NEW PERSON ien or null value
  1. ; e.g. ^TMP("PRCS1358",$J,3101005.091223,"O")=134^5432^43
  1. ; ^TMP("PRCS1358",$J,3101007.101501,"A")=134^9473^4677
  1. ;
  1. N PRC410P,PRC442,PRCLIST,PRCODI,PRCRET
  1. K ^TMP("PRC1358",$J) ; init results
  1. S PRCRET=1 ; init return value
  1. ;
  1. ; verify inputs
  1. D
  1. . N PRCY0
  1. . ; check optional array root name
  1. . I "^PRC1358^PRCARR^PRC410P^PRC442^PRCLIST^PRCODI^PRCRET^"[(U_$P($G(PRCARR),"(")_U) S PRCRET="E^The array name is invalid." Q
  1. . ;
  1. . ; check for required inputs
  1. . I $G(PRC1358)="" S PRCRET="E^The 1358 number was not specified." Q
  1. . ;
  1. . ; find 1358 in file 442
  1. . S PRC442=$O(^PRC(442,"B",PRC1358,0))
  1. . I PRC442'>0 S PRCRET="E^The 1358 was not found in file 442." Q
  1. . ;
  1. . S PRCY0=$G(^PRC(442,PRC442,0))
  1. . ;
  1. . ; Verify METHOD OF PROCESSING = IEN 21 1358 OBLIGATION
  1. . I $P(PRCY0,U,2)'=21 S PRCRET="E^The document is not a 1358." Q
  1. . ;
  1. . ; get PRIMARY 2237
  1. . S PRC410P=$P(PRCY0,U,12)
  1. . I PRC410P="" S PRCRET="E^The PRIMARY 2237 value is missing." Q
  1. ;
  1. ; loop thru OBLIGATION DATA multiple
  1. I PRCRET D
  1. . S PRCODI=0 F S PRCODI=$O(^PRC(442,PRC442,10,PRCODI)) Q:'PRCODI D
  1. . . N PRC410,PRC410A,PRC7Y,PRCDT,PRCODY0,PRCEVENT,PRCRA,PRCRO,PRCRR
  1. . . S PRCODY0=$G(^PRC(442,PRC442,10,PRCODI,0))
  1. . . ;
  1. . . ; skip entries that are not SO or AR code sheet (excludes PV)
  1. . . Q:"^SO^AR^"'[(U_$E(PRCODY0,1,2)_U)
  1. . . ;
  1. . . S PRCDT=$P(PRCODY0,U,6) ; DATE SIGNED
  1. . . S PRC410A=$P(PRCODY0,U,11) ; 1358 ADJUSTMENT
  1. . . S PRC410=$S(PRC410A]"":PRC410A,1:PRC410P) ; associated 410 entry
  1. . . ;
  1. . . ; determine event type and if not rebuild add 410 entry to list
  1. . . I $D(PRCLIST(PRC410)) S PRCEVENT="R" ; REBUILD
  1. . . E S PRCEVENT=$S(PRC410A]"":"A",1:"O"),PRCLIST(PRC410)=""
  1. . . ;
  1. . . ; quit if rebuild since that does not impact certifier role
  1. . . Q:PRCEVENT="R"
  1. . . ;
  1. . . S PRCRO=$P(PRCODY0,U,2) ; OBLIGATED BY
  1. . . ; get REQUESTOR and APPROVER from file 410
  1. . . S PRC7Y=$G(^PRCS(410,PRC410,7))
  1. . . S PRCRR=$P(PRC7Y,U,1) ; REQUESTOR
  1. . . S PRCRA=$P(PRC7Y,U,3) ; APPROVING OFFICIAL
  1. . . ;
  1. . . ; save data to ^TMP
  1. . . S ^TMP("PRC1358",$J,PRCDT,PRCEVENT)=$G(PRCRR)_U_$G(PRCRA)_U_$G(PRCRO)
  1. ;
  1. ; if an output array was specified, move the data to it
  1. I PRCRET,$G(PRCARR)]"",$D(^TMP("PRC1358",$J)) D
  1. . Q:($NA(@PRCARR,2))=("^TMP(""PRC1358"","_$J_")") ; same as default
  1. . K @PRCARR
  1. . M @PRCARR=^TMP("PRC1358",$J)
  1. . K ^TMP("PRC1358",$J)
  1. ;
  1. Q PRCRET
  1. ;
  1. ;
  1. AUTHR(PRCSTR) ;Returns string AuthorityDesc^Sub-AuthorityDesc for 1358 request
  1. ; given string of AuthorityIEN^Sub-AuthorityIEN
  1. N PRCX S PRCX=""
  1. I PRCSTR]"" S PRCX=$P($G(^PRCS(410.9,+PRCSTR,0)),U,2)_"^"_$P($G(^PRCS(410.9,+$P(PRCSTR,U,2),0)),U,2)
  1. Q PRCX