PRCEMOA ;WOIFO/SAB - 1358 OBLIGATION APIS ;6/30/11 15:34
V ;;5.1;IFCAP;**152,158**;Oct 20, 2000;Build 1
;;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
UOKCERT(PRCOUT,PRC1358,PRCPER) ; User OK as Certifier for a 1358
; This API verifies that the person would not violate segregation of
; duty when certifying an invoice associated with a 1358 obligation
; by ensuring that they have not previously acted as a requestor,
; approver, or obligator on that 1358.
;
; inputs
; PRCOUT - output variable, passed by reference
; PRC1358 - 1358 obligation number (e.g. 688-C15001)
; PRCPER - User, NEW PERSON (#200) file IEN
; output
; PRCOUT will be set equal to one of the following values
; =1 if person can certify an invoice associated with the 1358
; =0^text if person not OK as certifier due to segregation of duties
; where text is of the form
; You are the 'role' of 'an event'.
; e.g. "You are the Requestor of an Adjustment to the 1358."
; =E^text if problem with inputs or the 1358 data
; where list of possible error text is:
; The 1358 number was not specified.
; The Person was not specified.
; The 1358 was not found in file 442.
; The document is not a 1358.
; The PRIMARY 2237 value is missing.
;
N PRC410P,PRC442,PRCLIST,PRCODI
S PRCOUT=1 ; init output value
;
; verify inputs
D
. N PRCY0
. ; check for required inputs
. I $G(PRC1358)="" S PRCOUT="E^The 1358 number was not specified." Q
. I $G(PRCPER)="" S PRCOUT="E^The Person was not specified." Q
. ;
. ; find 1358 in file 442
. S PRC442=$O(^PRC(442,"B",PRC1358,0))
. I PRC442'>0 S PRCOUT="E^The 1358 was not found in file 442." Q
. ;
. S PRCY0=$G(^PRC(442,PRC442,0))
. ;
. ; Verify METHOD OF PROCESSING = IEN 21 1358 OBLIGATION
. I $P(PRCY0,U,2)'=21 S PRCOUT="E^The document is not a 1358." Q
. ;
. ; get PRIMARY 2237
. S PRC410P=$P(PRCY0,U,12)
. I PRC410P="" S PRCOUT="E^The PRIMARY 2237 value is missing." Q
;
; loop thru OBLIGATION DATA multiple
I PRCOUT D
. S PRCODI=0
. F S PRCODI=$O(^PRC(442,PRC442,10,PRCODI)) Q:'PRCODI D Q:'PRCOUT
. . N PRC410,PRC410A,PRC7Y,PRCACT,PRCEVENT,PRCODY0,PRCROLE
. . S PRCODY0=$G(^PRC(442,PRC442,10,PRCODI,0))
. . ;
. . ; skip entries that are not SO or AR code sheet (excludes PV)
. . Q:"^SO^AR^"'[(U_$E(PRCODY0,1,2)_U)
. . ;
. . S PRC410A=$P(PRCODY0,U,11) ; 1358 ADJUSTMENT
. . S PRC410=$S(PRC410A]"":PRC410A,1:PRC410P) ; associated 410 entry
. . ;
. . ; 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"
. . ;
. . I $P(PRCODY0,U,2) S PRCACT($P(PRCODY0,U,2))="O" ; OBLIGATED BY
. . ; get REQUESTOR and APPROVER from file 410
. . S PRC7Y=$G(^PRCS(410,PRC410,7))
. . I $P(PRC7Y,U,1) S PRCACT($P(PRC7Y,U,1))="R" ; REQUESTOR
. . I $P(PRC7Y,U,3) S PRCACT($P(PRC7Y,U,3))="A" ; APPROVING OFFICIAL
. . ;
. . ; check if person acted on this 1358 event in IFCAP
. . S PRCROLE=$G(PRCACT(PRCPER))
. . I PRCROLE]"" D
. . . S PRCOUT="0^You are the "
. . . S PRCOUT=PRCOUT_$S(PRCROLE="R":"Requestor",PRCROLE="A":"Approving Official",1:"Obligator")
. . . S PRCOUT=PRCOUT_" "_$S(PRCEVENT="O":"of the 1358",1:"of an Adjustment to the 1358")_"."
;
Q
;
EV1358(PRC1358,PRCARR) ; Events (and Actors) for a 1358
; input
; PRC1358 - 1358 number (e.g. 688-C15001)
; PRCARR - (optional) results array name, passed by value,
; closed root, default value is "^TMP(""PRC1358"",$J)"
; The root must NOT be a variable name newed by this API
; (PRC1358,PRCARR,PRC410P,PRC442,PRCLIST,PRCODI,PRCRET)
; return value = 1 or E^text
; = 1 if no problems
; = E^text if problem with inputs or 1358 data
; List of possible errors
; The array name is invalid.
; The 1358 number was not specified.
; The 1358 was not found in file 442.
; The document is not a 1358.
; The PRIMARY 2237 value is missing.
; output
; PRCARR - array is initialized and populated
; PRCARR(DATE/TIME,EVENT)=REQUESTOR^APPROVER^OBLIGATOR
; where
; DATE/TIME is a FileMan Date/Time (internal format) when
; the transaction was obligated
; EVENT is O (OBLIGATE), or A (ADJUST)
; REQUESTOR is a NEW PERSON ien or null value
; APPROVER is a NEW PERSON ien or null value
; OBLIGATOR is a NEW PERSON ien or null value
; e.g. ^TMP("PRCS1358",$J,3101005.091223,"O")=134^5432^43
; ^TMP("PRCS1358",$J,3101007.101501,"A")=134^9473^4677
;
N PRC410P,PRC442,PRCLIST,PRCODI,PRCRET
K ^TMP("PRC1358",$J) ; init results
S PRCRET=1 ; init return value
;
; verify inputs
D
. N PRCY0
. ; check optional array root name
. I "^PRC1358^PRCARR^PRC410P^PRC442^PRCLIST^PRCODI^PRCRET^"[(U_$P($G(PRCARR),"(")_U) S PRCRET="E^The array name is invalid." Q
. ;
. ; check for required inputs
. I $G(PRC1358)="" S PRCRET="E^The 1358 number was not specified." Q
. ;
. ; find 1358 in file 442
. S PRC442=$O(^PRC(442,"B",PRC1358,0))
. I PRC442'>0 S PRCRET="E^The 1358 was not found in file 442." Q
. ;
. S PRCY0=$G(^PRC(442,PRC442,0))
. ;
. ; Verify METHOD OF PROCESSING = IEN 21 1358 OBLIGATION
. I $P(PRCY0,U,2)'=21 S PRCRET="E^The document is not a 1358." Q
. ;
. ; get PRIMARY 2237
. S PRC410P=$P(PRCY0,U,12)
. I PRC410P="" S PRCRET="E^The PRIMARY 2237 value is missing." Q
;
; loop thru OBLIGATION DATA multiple
I PRCRET D
. S PRCODI=0 F S PRCODI=$O(^PRC(442,PRC442,10,PRCODI)) Q:'PRCODI D
. . N PRC410,PRC410A,PRC7Y,PRCDT,PRCODY0,PRCEVENT,PRCRA,PRCRO,PRCRR
. . S PRCODY0=$G(^PRC(442,PRC442,10,PRCODI,0))
. . ;
. . ; skip entries that are not SO or AR code sheet (excludes PV)
. . Q:"^SO^AR^"'[(U_$E(PRCODY0,1,2)_U)
. . ;
. . S PRCDT=$P(PRCODY0,U,6) ; DATE SIGNED
. . S PRC410A=$P(PRCODY0,U,11) ; 1358 ADJUSTMENT
. . S PRC410=$S(PRC410A]"":PRC410A,1:PRC410P) ; associated 410 entry
. . ;
. . ; 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"
. . ;
. . S PRCRO=$P(PRCODY0,U,2) ; OBLIGATED BY
. . ; get REQUESTOR and APPROVER from file 410
. . S PRC7Y=$G(^PRCS(410,PRC410,7))
. . S PRCRR=$P(PRC7Y,U,1) ; REQUESTOR
. . S PRCRA=$P(PRC7Y,U,3) ; APPROVING OFFICIAL
. . ;
. . ; save data to ^TMP
. . S ^TMP("PRC1358",$J,PRCDT,PRCEVENT)=$G(PRCRR)_U_$G(PRCRA)_U_$G(PRCRO)
;
; if an output array was specified, move the data to it
I PRCRET,$G(PRCARR)]"",$D(^TMP("PRC1358",$J)) D
. Q:($NA(@PRCARR,2))=("^TMP(""PRC1358"","_$J_")") ; same as default
. K @PRCARR
. M @PRCARR=^TMP("PRC1358",$J)
. K ^TMP("PRC1358",$J)
;
Q PRCRET
;
;
AUTHR(PRCSTR) ;Returns string AuthorityDesc^Sub-AuthorityDesc for 1358 request
; given string of AuthorityIEN^Sub-AuthorityIEN
N PRCX S PRCX=""
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)
Q PRCX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCEMOA 7423 printed Sep 23, 2025@19:37:33 Page 2
PRCEMOA ;WOIFO/SAB - 1358 OBLIGATION APIS ;6/30/11 15:34
V ;;5.1;IFCAP;**152,158**;Oct 20, 2000;Build 1
+1 ;;Per VHA Directive 2004-038, this routine should not be modified.
+2 QUIT
+3 ;
UOKCERT(PRCOUT,PRC1358,PRCPER) ; User OK as Certifier for a 1358
+1 ; This API verifies that the person would not violate segregation of
+2 ; duty when certifying an invoice associated with a 1358 obligation
+3 ; by ensuring that they have not previously acted as a requestor,
+4 ; approver, or obligator on that 1358.
+5 ;
+6 ; inputs
+7 ; PRCOUT - output variable, passed by reference
+8 ; PRC1358 - 1358 obligation number (e.g. 688-C15001)
+9 ; PRCPER - User, NEW PERSON (#200) file IEN
+10 ; output
+11 ; PRCOUT will be set equal to one of the following values
+12 ; =1 if person can certify an invoice associated with the 1358
+13 ; =0^text if person not OK as certifier due to segregation of duties
+14 ; where text is of the form
+15 ; You are the 'role' of 'an event'.
+16 ; e.g. "You are the Requestor of an Adjustment to the 1358."
+17 ; =E^text if problem with inputs or the 1358 data
+18 ; where list of possible error text is:
+19 ; The 1358 number was not specified.
+20 ; The Person was not specified.
+21 ; The 1358 was not found in file 442.
+22 ; The document is not a 1358.
+23 ; The PRIMARY 2237 value is missing.
+24 ;
+25 NEW PRC410P,PRC442,PRCLIST,PRCODI
+26 ; init output value
SET PRCOUT=1
+27 ;
+28 ; verify inputs
+29 Begin DoDot:1
+30 NEW PRCY0
+31 ; check for required inputs
+32 IF $GET(PRC1358)=""
SET PRCOUT="E^The 1358 number was not specified."
QUIT
+33 IF $GET(PRCPER)=""
SET PRCOUT="E^The Person was not specified."
QUIT
+34 ;
+35 ; find 1358 in file 442
+36 SET PRC442=$ORDER(^PRC(442,"B",PRC1358,0))
+37 IF PRC442'>0
SET PRCOUT="E^The 1358 was not found in file 442."
QUIT
+38 ;
+39 SET PRCY0=$GET(^PRC(442,PRC442,0))
+40 ;
+41 ; Verify METHOD OF PROCESSING = IEN 21 1358 OBLIGATION
+42 IF $PIECE(PRCY0,U,2)'=21
SET PRCOUT="E^The document is not a 1358."
QUIT
+43 ;
+44 ; get PRIMARY 2237
+45 SET PRC410P=$PIECE(PRCY0,U,12)
+46 IF PRC410P=""
SET PRCOUT="E^The PRIMARY 2237 value is missing."
QUIT
End DoDot:1
+47 ;
+48 ; loop thru OBLIGATION DATA multiple
+49 IF PRCOUT
Begin DoDot:1
+50 SET PRCODI=0
+51 FOR
SET PRCODI=$ORDER(^PRC(442,PRC442,10,PRCODI))
if 'PRCODI
QUIT
Begin DoDot:2
+52 NEW PRC410,PRC410A,PRC7Y,PRCACT,PRCEVENT,PRCODY0,PRCROLE
+53 SET PRCODY0=$GET(^PRC(442,PRC442,10,PRCODI,0))
+54 ;
+55 ; skip entries that are not SO or AR code sheet (excludes PV)
+56 if "^SO^AR^"'[(U_$EXTRACT(PRCODY0,1,2)_U)
QUIT
+57 ;
+58 ; 1358 ADJUSTMENT
SET PRC410A=$PIECE(PRCODY0,U,11)
+59 ; associated 410 entry
SET PRC410=$SELECT(PRC410A]"":PRC410A,1:PRC410P)
+60 ;
+61 ; determine event type and if not rebuild add 410 entry to list
+62 ; rebuild
IF $DATA(PRCLIST(PRC410))
SET PRCEVENT="R"
+63 IF '$TEST
SET PRCEVENT=$SELECT(PRC410A]"":"A",1:"O")
SET PRCLIST(PRC410)=""
+64 ;
+65 ; quit if rebuild since that does not impact certifier role
+66 if PRCEVENT="R"
QUIT
+67 ;
+68 ; OBLIGATED BY
IF $PIECE(PRCODY0,U,2)
SET PRCACT($PIECE(PRCODY0,U,2))="O"
+69 ; get REQUESTOR and APPROVER from file 410
+70 SET PRC7Y=$GET(^PRCS(410,PRC410,7))
+71 ; REQUESTOR
IF $PIECE(PRC7Y,U,1)
SET PRCACT($PIECE(PRC7Y,U,1))="R"
+72 ; APPROVING OFFICIAL
IF $PIECE(PRC7Y,U,3)
SET PRCACT($PIECE(PRC7Y,U,3))="A"
+73 ;
+74 ; check if person acted on this 1358 event in IFCAP
+75 SET PRCROLE=$GET(PRCACT(PRCPER))
+76 IF PRCROLE]""
Begin DoDot:3
+77 SET PRCOUT="0^You are the "
+78 SET PRCOUT=PRCOUT_$SELECT(PRCROLE="R":"Requestor",PRCROLE="A":"Approving Official",1:"Obligator")
+79 SET PRCOUT=PRCOUT_" "_$SELECT(PRCEVENT="O":"of the 1358",1:"of an Adjustment to the 1358")_"."
End DoDot:3
End DoDot:2
if 'PRCOUT
QUIT
End DoDot:1
+80 ;
+81 QUIT
+82 ;
EV1358(PRC1358,PRCARR) ; Events (and Actors) for a 1358
+1 ; input
+2 ; PRC1358 - 1358 number (e.g. 688-C15001)
+3 ; PRCARR - (optional) results array name, passed by value,
+4 ; closed root, default value is "^TMP(""PRC1358"",$J)"
+5 ; The root must NOT be a variable name newed by this API
+6 ; (PRC1358,PRCARR,PRC410P,PRC442,PRCLIST,PRCODI,PRCRET)
+7 ; return value = 1 or E^text
+8 ; = 1 if no problems
+9 ; = E^text if problem with inputs or 1358 data
+10 ; List of possible errors
+11 ; The array name is invalid.
+12 ; The 1358 number was not specified.
+13 ; The 1358 was not found in file 442.
+14 ; The document is not a 1358.
+15 ; The PRIMARY 2237 value is missing.
+16 ; output
+17 ; PRCARR - array is initialized and populated
+18 ; PRCARR(DATE/TIME,EVENT)=REQUESTOR^APPROVER^OBLIGATOR
+19 ; where
+20 ; DATE/TIME is a FileMan Date/Time (internal format) when
+21 ; the transaction was obligated
+22 ; EVENT is O (OBLIGATE), or A (ADJUST)
+23 ; REQUESTOR is a NEW PERSON ien or null value
+24 ; APPROVER is a NEW PERSON ien or null value
+25 ; OBLIGATOR is a NEW PERSON ien or null value
+26 ; e.g. ^TMP("PRCS1358",$J,3101005.091223,"O")=134^5432^43
+27 ; ^TMP("PRCS1358",$J,3101007.101501,"A")=134^9473^4677
+28 ;
+29 NEW PRC410P,PRC442,PRCLIST,PRCODI,PRCRET
+30 ; init results
KILL ^TMP("PRC1358",$JOB)
+31 ; init return value
SET PRCRET=1
+32 ;
+33 ; verify inputs
+34 Begin DoDot:1
+35 NEW PRCY0
+36 ; check optional array root name
+37 IF "^PRC1358^PRCARR^PRC410P^PRC442^PRCLIST^PRCODI^PRCRET^"[(U_$PIECE($GET(PRCARR),"(")_U)
SET PRCRET="E^The array name is invalid."
QUIT
+38 ;
+39 ; check for required inputs
+40 IF $GET(PRC1358)=""
SET PRCRET="E^The 1358 number was not specified."
QUIT
+41 ;
+42 ; find 1358 in file 442
+43 SET PRC442=$ORDER(^PRC(442,"B",PRC1358,0))
+44 IF PRC442'>0
SET PRCRET="E^The 1358 was not found in file 442."
QUIT
+45 ;
+46 SET PRCY0=$GET(^PRC(442,PRC442,0))
+47 ;
+48 ; Verify METHOD OF PROCESSING = IEN 21 1358 OBLIGATION
+49 IF $PIECE(PRCY0,U,2)'=21
SET PRCRET="E^The document is not a 1358."
QUIT
+50 ;
+51 ; get PRIMARY 2237
+52 SET PRC410P=$PIECE(PRCY0,U,12)
+53 IF PRC410P=""
SET PRCRET="E^The PRIMARY 2237 value is missing."
QUIT
End DoDot:1
+54 ;
+55 ; loop thru OBLIGATION DATA multiple
+56 IF PRCRET
Begin DoDot:1
+57 SET PRCODI=0
FOR
SET PRCODI=$ORDER(^PRC(442,PRC442,10,PRCODI))
if 'PRCODI
QUIT
Begin DoDot:2
+58 NEW PRC410,PRC410A,PRC7Y,PRCDT,PRCODY0,PRCEVENT,PRCRA,PRCRO,PRCRR
+59 SET PRCODY0=$GET(^PRC(442,PRC442,10,PRCODI,0))
+60 ;
+61 ; skip entries that are not SO or AR code sheet (excludes PV)
+62 if "^SO^AR^"'[(U_$EXTRACT(PRCODY0,1,2)_U)
QUIT
+63 ;
+64 ; DATE SIGNED
SET PRCDT=$PIECE(PRCODY0,U,6)
+65 ; 1358 ADJUSTMENT
SET PRC410A=$PIECE(PRCODY0,U,11)
+66 ; associated 410 entry
SET PRC410=$SELECT(PRC410A]"":PRC410A,1:PRC410P)
+67 ;
+68 ; determine event type and if not rebuild add 410 entry to list
+69 ; REBUILD
IF $DATA(PRCLIST(PRC410))
SET PRCEVENT="R"
+70 IF '$TEST
SET PRCEVENT=$SELECT(PRC410A]"":"A",1:"O")
SET PRCLIST(PRC410)=""
+71 ;
+72 ; quit if rebuild since that does not impact certifier role
+73 if PRCEVENT="R"
QUIT
+74 ;
+75 ; OBLIGATED BY
SET PRCRO=$PIECE(PRCODY0,U,2)
+76 ; get REQUESTOR and APPROVER from file 410
+77 SET PRC7Y=$GET(^PRCS(410,PRC410,7))
+78 ; REQUESTOR
SET PRCRR=$PIECE(PRC7Y,U,1)
+79 ; APPROVING OFFICIAL
SET PRCRA=$PIECE(PRC7Y,U,3)
+80 ;
+81 ; save data to ^TMP
+82 SET ^TMP("PRC1358",$JOB,PRCDT,PRCEVENT)=$GET(PRCRR)_U_$GET(PRCRA)_U_$GET(PRCRO)
End DoDot:2
End DoDot:1
+83 ;
+84 ; if an output array was specified, move the data to it
+85 IF PRCRET
IF $GET(PRCARR)]""
IF $DATA(^TMP("PRC1358",$JOB))
Begin DoDot:1
+86 ; same as default
if ($NAME(@PRCARR,2))=("^TMP(""PRC1358"","_$JOB_")")
QUIT
+87 KILL @PRCARR
+88 MERGE @PRCARR=^TMP("PRC1358",$JOB)
+89 KILL ^TMP("PRC1358",$JOB)
End DoDot:1
+90 ;
+91 QUIT PRCRET
+92 ;
+93 ;
AUTHR(PRCSTR) ;Returns string AuthorityDesc^Sub-AuthorityDesc for 1358 request
+1 ; given string of AuthorityIEN^Sub-AuthorityIEN
+2 NEW PRCX
SET PRCX=""
+3 IF PRCSTR]""
SET PRCX=$PIECE($GET(^PRCS(410.9,+PRCSTR,0)),U,2)_"^"_$PIECE($GET(^PRCS(410.9,+$PIECE(PRCSTR,U,2),0)),U,2)
+4 QUIT PRCX
