- 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 Jan 18, 2025@03:02:41 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