PRCFSDR ;WOIFO/SAB/LKG - IFCAP 1358 SEGREGATION OF DUTIES REPORT ;12/29/10 10:48
;;5.1;IFCAP;**154**;OCT 20, 2000;Build 5
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; IAs
; #10003 DD^%DT
; #10000 NOW^%DTC
; #10086 %ZIS, HOME^%ZIS
; #10089 %ZISC
; #10063 %ZTLOAD, $$S^%ZTLOAD
; #2056 $$GET1^DIQ
; #10026 DIR
; #5574 $$EV1358^PRCEMOA
; #10103 $$FMADD^XLFDT, $$FMTE^XLFDT
; #5582 ^PRC(411,
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,PRCALL,PRCDT1,PRCDT2,%ZIS,POP,X,Y
;
; ask from date
S DIR(0)="D^::EX",DIR("A")="From Date"
; default from date is first day of previous month
S DIR("B")=$$FMTE^XLFDT($E($$FMADD^XLFDT($E(DT,1,5)_"01",-1),1,5)_"01")
D ^DIR K DIR G:$D(DIRUT) EXIT
S PRCDT1=Y
;
; ask to date
S DIR(0)="DA^"_PRCDT1_"::EX",DIR("A")="To Date: "
; default to date is last day of specified month
S X=PRCDT1 D DAYS
S DIR("B")=$$FMTE^XLFDT($E(PRCDT1,1,5)_X)
D ^DIR K DIR G:$D(DIRUT) EXIT
S:$P(Y,".",2)="" $P(Y,".",2)="235959"
S PRCDT2=Y
;
; ask if all stations
S DIR(0)="Y",DIR("A")="For all stations",DIR("B")="YES"
D ^DIR K DIR G:$G(DIRUT) EXIT
S PRCSTALL=Y
S PRCSTN=""
; if not all stations ask station
I 'PRCSTALL D G:PRCSTN="" EXIT
. S PRCSTN=""
. S DIC="^PRC(411,",DIC(0)="AQEM"
. D ^DIC Q:Y<0
. S PRCSTN=$P(Y,U,2)
;
; ask if violations only
S DIR(0)="Y",DIR("A")="Only list 1358s with a violation (Y/N)"
S DIR("B")="YES"
D ^DIR K DIR G:$D(DIRUT) EXIT
S PRCORV=Y
;
; ask device
S %ZIS="Q" D ^%ZIS G:POP EXIT
I $D(IO("Q")) D G EXIT
. N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC,ZTSK
. S ZTRTN="QEN^PRCFSDR",ZTDESC="IFCAP 1358 Segregation of Duties Report"
. F PRCX="PRCDT*","PRCORV","PRCSTALL","PRCSTN" S ZTSAVE(PRCX)=""
. D ^%ZTLOAD,HOME^%ZIS
;
QEN ; queued entry
U IO
;
GATHER ; collect and sort data
N %
K ^TMP($J)
;
S PRCC("CER")=0 ; initialize count of certifications
S PRCC("OBL")=0 ; initialize count of obligations
S PRCC("VIO")=0 ; initialize count of obligations with a violation
;
; find invoice certification events during specified period
; Loop through Invoice Tracking file #421.5 using "AF" index on CERTIFIED BY SIG DATE/TIME (#61.9)
S PRCSDT=PRCDT1-.000001
F S PRCSDT=$O(^PRCF(421.5,"AF",PRCSDT)) Q:PRCSDT=""!(PRCSDT>PRCDT2) D
. S PRCDA=0
. F S PRCDA=$O(^PRCF(421.5,"AF",PRCSDT,PRCDA)) Q:'PRCDA D
. . N PRCNOD0,PRCNOD1,PRCNOD2,PRCNOD21,PRCPO,PRCDT,PRCSTB
. . S PRCNOD0=$G(^PRCF(421.5,PRCDA,0)),PRCNOD1=$G(^(1)),PRCNOD2=$G(^(2)),PRCNOD21=$G(^(2.1))
. . S PRCPO=$P(PRCNOD0,U,7) Q:PRCPO'>0 Q:$$GET1^DIQ(442,PRCPO_",",.02)'["1358"
. . Q:$P(PRCNOD2,U,10)'>0 S PRCDT=$P(PRCNOD21,U,5) Q:PRCDT<PRCDT1 Q:PRCDT>PRCDT2
. . S PRCOB=$P(PRCNOD1,U,3) ; full 1358 obligation number
. . ;
. . ; if report not for all stations, skip invoice certification from different station
. . I 'PRCSTALL D I PRCSTB'=PRCSTN Q
. . . S PRCSTB=$$GET1^DIQ(442,PRCPO_",",31) S:PRCSTB="" PRCSTB=$P(PRCNOD1,U,2)
. . . I PRCSTB="" S PRCSTB=+PRCOB
. . ;
. . ; add event to ^TMP($J,1358 #,date/time,invoice #)=certifier
. . S ^TMP($J,PRCOB,PRCDT,$P(PRCNOD0,U))=$P(PRCNOD2,U,10)
. . S PRCC("CER")=PRCC("CER")+1 ; incr count of certifications
;
; loop thru obligations and add IFCAP events and actors to ^TMP
S PRCOB="" F S PRCOB=$O(^TMP($J,PRCOB)) Q:PRCOB="" D
. S PRCC("OBL")=PRCC("OBL")+1 ; incr count of 1358s
. N PRCARRAY,PRCX
. S PRCX=$$EV1358^PRCEMOA(PRCOB,"PRCARRAY")
. I PRCX'=1 S ^TMP($J,PRCOB)=PRCX Q ; error reported by the API
. S PRCDT=""
. F S PRCDT=$O(PRCARRAY(PRCDT)) Q:PRCDT=""!($P(PRCDT,".")>PRCDT2) D
. . S PRCEV="" F S PRCEV=$O(PRCARRAY(PRCDT,PRCEV)) Q:PRCEV="" D
. . . S ^TMP($J,PRCOB,PRCDT,PRCEV)=PRCARRAY(PRCDT,PRCEV)
;
; loop thru obligations and add segregation of duty violations to ^TMP
S PRCOB="" F S PRCOB=$O(^TMP($J,PRCOB)) Q:PRCOB="" D
. Q:$P($G(^TMP($J,PRCOB)),U)="E" ; skip because missing IFCAP events
. ;
. N PRCAPP,PRCOBL,PRCREQ,PRCVIO
. S PRCVIO=0 ; init violation flag for the 1358
. ; loop thru date/time stamps
. S PRCDT="" F S PRCDT=$O(^TMP($J,PRCOB,PRCDT)) Q:PRCDT="" D
. . ; loop thru events
. . S PRCEV="" F S PRCEV=$O(^TMP($J,PRCOB,PRCDT,PRCEV)) Q:PRCEV="" D
. . . N PRCX
. . . S PRCX=$G(^TMP($J,PRCOB,PRCDT,PRCEV))
. . . ; process IFCAP certification event
. . . I PRCEV D
. . . . ; check fo violation
. . . . I PRCX,$D(PRCREQ(PRCX)) S PRCVIO=1,^TMP($J,PRCOB,PRCDT,PRCEV,"V1")="User previously acted as requestor on a prior 1358 event."
. . . . I PRCX,$D(PRCAPP(PRCX)) S PRCVIO=1,^TMP($J,PRCOB,PRCDT,PRCEV,"V2")="User previously acted as approver on a prior 1358 event."
. . . . I PRCX,$D(PRCOBL(PRCX)) S PRCVIO=1,^TMP($J,PRCOB,PRCDT,PRCEV,"V3")="User previously acted as obligator on a prior 1358 event."
. . . ; process an IFCAP event
. . . I "^O^A^"[(U_PRCEV_U) D
. . . . ; save IFCAP actors in lists
. . . . I $P(PRCX,U,1) S PRCREQ($P(PRCX,U,1))=""
. . . . I $P(PRCX,U,2) S PRCAPP($P(PRCX,U,2))=""
. . . . I $P(PRCX,U,3) S PRCOBL($P(PRCX,U,3))=""
. . . . ; check for violation on IFCAP event
. . . . I $P(PRCX,U,2)=$P(PRCX,U,1) S PRCVIO=1,^TMP($J,PRCOB,PRCDT,PRCEV,"V1")="Approver previously acted as requestor on this transaction."
. . . . I $P(PRCX,U,3)=$P(PRCX,U,1) S PRCVIO=1,^TMP($J,PRCOB,PRCDT,PRCEV,"V2")="Obligator previously acted as requester on this transaction."
. . . . I $P(PRCX,U,3)=$P(PRCX,U,2) S PRCVIO=1,^TMP($J,PRCOB,PRCDT,PRCEV,"V3")="Obligator previously acted as approver on this transaction."
. ;
. I PRCVIO D ; violation was found
. . S ^TMP($J,PRCOB)="V" ; flag 1358
. . S PRCC("VIO")=PRCC("VIO")+1 ; incr count of 1358 with violation
;
PRINT ; report data
S (PRCQUIT,PRCPG)=0 D NOW^%DTC S Y=% D DD^%DT S PRCDTR=Y
K PRCDL
S PRCDL="",$P(PRCDL,"-",80)=""
S PRCDL("CH")=$E(PRCDL,1,10)_" "_$E(PRCDL,1,14)_" "_$E(PRCDL,1,11)_" "_$E(PRCDL,1,9)_" "_$E(PRCDL,1,30)
;
; build page header text for selection criteria
K PRCHDT
S PRCHDT(1)=" Including Certifications from "
S PRCHDT(1)=PRCHDT(1)_$$FMTE^XLFDT(PRCDT1)_" to "_$$FMTE^XLFDT(PRCDT2)
S PRCHDT(1)=PRCHDT(1)_" for "
S PRCHDT(1)=PRCHDT(1)_$S(PRCSTALL:"all stations",1:"Station "_PRCSTN)
S:PRCORV PRCHDT(2)=" Only 1358s with a segregation of duty violation shown."
;
D HD
;
; loop thru obligations
S PRCOB="" F S PRCOB=$O(^TMP($J,PRCOB)) Q:PRCOB="" D Q:PRCQUIT
. N PRCERR,PRCEVFP,PRCOBX,PRCVIO
. S PRCOBX=$G(^TMP($J,PRCOB))
. S PRCERR=$S($P(PRCOBX,U)="E":1,1:0) ; set true if error from IFCAP
. S PRCVIO=$S($P(PRCOBX,U)="V":1,1:0) ; set true if violation was found
. ;
. ; if only reporting violations then skip 1358 when no error/violation
. I PRCORV,'PRCERR,'PRCVIO Q
. ;
. ; check for page break
. I $Y+7>IOSL D HD Q:PRCQUIT
. ;
. W !,PRCDL("CH")
. W !,PRCOB
. ;
. I PRCERR D
. . W !,"IFCAP events for this 1358 missing due to following error:"
. . W !,$P(PRCOBX,U,2),!
. ;
. S PRCEVFP=1 ; init flag as true (Event - First Printed for 1358)
. ; loop thru date/times
. S PRCDT="" F S PRCDT=$O(^TMP($J,PRCOB,PRCDT)) Q:PRCDT="" D Q:PRCQUIT
. . ; loop thru events
. . S PRCEV=""
. . F S PRCEV=$O(^TMP($J,PRCOB,PRCDT,PRCEV)) Q:PRCEV="" D Q:PRCQUIT
. . . N PRCX,PRCV
. . . ; if only reporting violations, don't print certify event without
. . . I PRCORV,PRCEV,$O(^TMP($J,PRCOB,PRCDT,PRCEV,"V"))="" Q
. . . I 'PRCEVFP,$Y+5>IOSL D HD Q:PRCQUIT D HDEV
. . . I 'PRCEVFP W !
. . . I PRCEVFP S PRCEVFP=0
. . . S PRCX=$G(^TMP($J,PRCOB,PRCDT,PRCEV))
. . . W ?11,$$FMTE^XLFDT(PRCDT,"2MZ")
. . . W ?26,$S(PRCEV="O":"OBLIGATE",PRCEV="A":"ADJUST",1:PRCEV)
. . . I PRCEV W ?38,"CERTIFIER",?49,$$GET1^DIQ(200,PRCX,.01)
. . . I PRCEV="O"!(PRCEV="A") D
. . . . W ?38,"REQUESTOR" W:$P(PRCX,U) ?49,$$GET1^DIQ(200,$P(PRCX,U),.01)
. . . . W !,?38,"APPROVER" W:$P(PRCX,U,2) ?49,$$GET1^DIQ(200,$P(PRCX,U,2),.01)
. . . . W !,?38,"OBLIGATOR" W:$P(PRCX,U,3) ?49,$$GET1^DIQ(200,$P(PRCX,U,3),.01)
. . . ; list any violations found for this event (max is 3)
. . . S PRCV="" F S PRCV=$O(^TMP($J,PRCOB,PRCDT,PRCEV,PRCV)) Q:PRCV="" D
. . . . N PRCXV
. . . . S PRCXV=$G(^TMP($J,PRCOB,PRCDT,PRCEV,PRCV))
. . . . I PRCXV]"" W !,?8,"***",PRCXV
;
I PRCQUIT W !!,"REPORT STOPPED AT USER REQUEST"
E D ; report footer
. I $Y+5>IOSL D HD Q:PRCQUIT
. W !,PRCDL("CH")
. W !!," ",PRCC("CER")," invoice certification",$S(PRCC("CER")=1:" was",1:"s were")," found during the report period."
. Q:PRCC("OBL")=0
. W !," ",PRCC("OBL")," 1358 Obligation",$S(PRCC("OBL")=1:" is",1:"s are")," referenced."
. W !," A violation of segregation of duties was detected on ",$S(PRCC("VIO")=0:"none",1:PRCC("VIO"))," of the 1358s."
I 'PRCQUIT,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR
D ^%ZISC
;
EXIT ;
I $D(ZTQUEUED) S ZTREQ="@"
K ^TMP($J)
K PRCC,PRCDA,PRCDL,PRCDT,PRCDT1,PRCDT2,PRCDTR,PRCEV,PRCHDT,PRCOB,PRCORV
K PRCPG,PRCSDT,PRCSTALL,PRCSTN,PRCQUIT
K DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
Q
;
HD ; page header
N PRCI
I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1,PRCQUIT=1 Q
I $E(IOST,1,2)="C-",PRCPG S DIR(0)="E" D ^DIR K DIR I 'Y S PRCQUIT=1 Q
I $E(IOST,1,2)="C-"!PRCPG W @IOF
S PRCPG=PRCPG+1
W !,"IFCAP 1358 Segregation of Duties",?49,PRCDTR,?72,"page ",PRCPG
S PRCI=0 F S PRCI=$O(PRCHDT(PRCI)) Q:'PRCI W !,PRCHDT(PRCI)
W !!,"1358",?11,"DATE/TIME",?26,"EVENT/INV#",?38,"ROLE",?49,"NAME"
Q
;
HDEV ; page header for continued event
W !,PRCOB," (continued from previous page)"
Q
;
DAYS ;CALCULATES THE NUMBER OF DAYS IN MONTH - Copied from routine FBAAUTL1
N X1
S X1=X,X=+$E(X,4,5),X=$S("^1^3^5^7^8^10^12^"[("^"_X_"^"):31,X=2:28,1:30)
I X=28 D
. N YEAR
. S YEAR=$E(X1,1,3)+1700
. I $S(YEAR#400=0:1,YEAR#4=0&'(YEAR#100=0):1,1:0) S X=29
Q
;
;PRCFSDR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFSDR 9875 printed Oct 16, 2024@18:05:08 Page 2
PRCFSDR ;WOIFO/SAB/LKG - IFCAP 1358 SEGREGATION OF DUTIES REPORT ;12/29/10 10:48
+1 ;;5.1;IFCAP;**154**;OCT 20, 2000;Build 5
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; IAs
+5 ; #10003 DD^%DT
+6 ; #10000 NOW^%DTC
+7 ; #10086 %ZIS, HOME^%ZIS
+8 ; #10089 %ZISC
+9 ; #10063 %ZTLOAD, $$S^%ZTLOAD
+10 ; #2056 $$GET1^DIQ
+11 ; #10026 DIR
+12 ; #5574 $$EV1358^PRCEMOA
+13 ; #10103 $$FMADD^XLFDT, $$FMTE^XLFDT
+14 ; #5582 ^PRC(411,
+15 ;
+16 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,PRCALL,PRCDT1,PRCDT2,%ZIS,POP,X,Y
+17 ;
+18 ; ask from date
+19 SET DIR(0)="D^::EX"
SET DIR("A")="From Date"
+20 ; default from date is first day of previous month
+21 SET DIR("B")=$$FMTE^XLFDT($EXTRACT($$FMADD^XLFDT($EXTRACT(DT,1,5)_"01",-1),1,5)_"01")
+22 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EXIT
+23 SET PRCDT1=Y
+24 ;
+25 ; ask to date
+26 SET DIR(0)="DA^"_PRCDT1_"::EX"
SET DIR("A")="To Date: "
+27 ; default to date is last day of specified month
+28 SET X=PRCDT1
DO DAYS
+29 SET DIR("B")=$$FMTE^XLFDT($EXTRACT(PRCDT1,1,5)_X)
+30 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EXIT
+31 if $PIECE(Y,".",2)=""
SET $PIECE(Y,".",2)="235959"
+32 SET PRCDT2=Y
+33 ;
+34 ; ask if all stations
+35 SET DIR(0)="Y"
SET DIR("A")="For all stations"
SET DIR("B")="YES"
+36 DO ^DIR
KILL DIR
if $GET(DIRUT)
GOTO EXIT
+37 SET PRCSTALL=Y
+38 SET PRCSTN=""
+39 ; if not all stations ask station
+40 IF 'PRCSTALL
Begin DoDot:1
+41 SET PRCSTN=""
+42 SET DIC="^PRC(411,"
SET DIC(0)="AQEM"
+43 DO ^DIC
if Y<0
QUIT
+44 SET PRCSTN=$PIECE(Y,U,2)
End DoDot:1
if PRCSTN=""
GOTO EXIT
+45 ;
+46 ; ask if violations only
+47 SET DIR(0)="Y"
SET DIR("A")="Only list 1358s with a violation (Y/N)"
+48 SET DIR("B")="YES"
+49 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EXIT
+50 SET PRCORV=Y
+51 ;
+52 ; ask device
+53 SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO EXIT
+54 IF $DATA(IO("Q"))
Begin DoDot:1
+55 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC,ZTSK
+56 SET ZTRTN="QEN^PRCFSDR"
SET ZTDESC="IFCAP 1358 Segregation of Duties Report"
+57 FOR PRCX="PRCDT*","PRCORV","PRCSTALL","PRCSTN"
SET ZTSAVE(PRCX)=""
+58 DO ^%ZTLOAD
DO HOME^%ZIS
End DoDot:1
GOTO EXIT
+59 ;
QEN ; queued entry
+1 USE IO
+2 ;
GATHER ; collect and sort data
+1 NEW %
+2 KILL ^TMP($JOB)
+3 ;
+4 ; initialize count of certifications
SET PRCC("CER")=0
+5 ; initialize count of obligations
SET PRCC("OBL")=0
+6 ; initialize count of obligations with a violation
SET PRCC("VIO")=0
+7 ;
+8 ; find invoice certification events during specified period
+9 ; Loop through Invoice Tracking file #421.5 using "AF" index on CERTIFIED BY SIG DATE/TIME (#61.9)
+10 SET PRCSDT=PRCDT1-.000001
+11 FOR
SET PRCSDT=$ORDER(^PRCF(421.5,"AF",PRCSDT))
if PRCSDT=""!(PRCSDT>PRCDT2)
QUIT
Begin DoDot:1
+12 SET PRCDA=0
+13 FOR
SET PRCDA=$ORDER(^PRCF(421.5,"AF",PRCSDT,PRCDA))
if 'PRCDA
QUIT
Begin DoDot:2
+14 NEW PRCNOD0,PRCNOD1,PRCNOD2,PRCNOD21,PRCPO,PRCDT,PRCSTB
+15 SET PRCNOD0=$GET(^PRCF(421.5,PRCDA,0))
SET PRCNOD1=$GET(^(1))
SET PRCNOD2=$GET(^(2))
SET PRCNOD21=$GET(^(2.1))
+16 SET PRCPO=$PIECE(PRCNOD0,U,7)
if PRCPO'>0
QUIT
if $$GET1^DIQ(442,PRCPO_",",.02)'["1358"
QUIT
+17 if $PIECE(PRCNOD2,U,10)'>0
QUIT
SET PRCDT=$PIECE(PRCNOD21,U,5)
if PRCDT<PRCDT1
QUIT
if PRCDT>PRCDT2
QUIT
+18 ; full 1358 obligation number
SET PRCOB=$PIECE(PRCNOD1,U,3)
+19 ;
+20 ; if report not for all stations, skip invoice certification from different station
+21 IF 'PRCSTALL
Begin DoDot:3
+22 SET PRCSTB=$$GET1^DIQ(442,PRCPO_",",31)
if PRCSTB=""
SET PRCSTB=$PIECE(PRCNOD1,U,2)
+23 IF PRCSTB=""
SET PRCSTB=+PRCOB
End DoDot:3
IF PRCSTB'=PRCSTN
QUIT
+24 ;
+25 ; add event to ^TMP($J,1358 #,date/time,invoice #)=certifier
+26 SET ^TMP($JOB,PRCOB,PRCDT,$PIECE(PRCNOD0,U))=$PIECE(PRCNOD2,U,10)
+27 ; incr count of certifications
SET PRCC("CER")=PRCC("CER")+1
End DoDot:2
End DoDot:1
+28 ;
+29 ; loop thru obligations and add IFCAP events and actors to ^TMP
+30 SET PRCOB=""
FOR
SET PRCOB=$ORDER(^TMP($JOB,PRCOB))
if PRCOB=""
QUIT
Begin DoDot:1
+31 ; incr count of 1358s
SET PRCC("OBL")=PRCC("OBL")+1
+32 NEW PRCARRAY,PRCX
+33 SET PRCX=$$EV1358^PRCEMOA(PRCOB,"PRCARRAY")
+34 ; error reported by the API
IF PRCX'=1
SET ^TMP($JOB,PRCOB)=PRCX
QUIT
+35 SET PRCDT=""
+36 FOR
SET PRCDT=$ORDER(PRCARRAY(PRCDT))
if PRCDT=""!($PIECE(PRCDT,".")>PRCDT2)
QUIT
Begin DoDot:2
+37 SET PRCEV=""
FOR
SET PRCEV=$ORDER(PRCARRAY(PRCDT,PRCEV))
if PRCEV=""
QUIT
Begin DoDot:3
+38 SET ^TMP($JOB,PRCOB,PRCDT,PRCEV)=PRCARRAY(PRCDT,PRCEV)
End DoDot:3
End DoDot:2
End DoDot:1
+39 ;
+40 ; loop thru obligations and add segregation of duty violations to ^TMP
+41 SET PRCOB=""
FOR
SET PRCOB=$ORDER(^TMP($JOB,PRCOB))
if PRCOB=""
QUIT
Begin DoDot:1
+42 ; skip because missing IFCAP events
if $PIECE($GET(^TMP($JOB,PRCOB)),U)="E"
QUIT
+43 ;
+44 NEW PRCAPP,PRCOBL,PRCREQ,PRCVIO
+45 ; init violation flag for the 1358
SET PRCVIO=0
+46 ; loop thru date/time stamps
+47 SET PRCDT=""
FOR
SET PRCDT=$ORDER(^TMP($JOB,PRCOB,PRCDT))
if PRCDT=""
QUIT
Begin DoDot:2
+48 ; loop thru events
+49 SET PRCEV=""
FOR
SET PRCEV=$ORDER(^TMP($JOB,PRCOB,PRCDT,PRCEV))
if PRCEV=""
QUIT
Begin DoDot:3
+50 NEW PRCX
+51 SET PRCX=$GET(^TMP($JOB,PRCOB,PRCDT,PRCEV))
+52 ; process IFCAP certification event
+53 IF PRCEV
Begin DoDot:4
+54 ; check fo violation
+55 IF PRCX
IF $DATA(PRCREQ(PRCX))
SET PRCVIO=1
SET ^TMP($JOB,PRCOB,PRCDT,PRCEV,"V1")="User previously acted as requestor on a prior 1358 event."
+56 IF PRCX
IF $DATA(PRCAPP(PRCX))
SET PRCVIO=1
SET ^TMP($JOB,PRCOB,PRCDT,PRCEV,"V2")="User previously acted as approver on a prior 1358 event."
+57 IF PRCX
IF $DATA(PRCOBL(PRCX))
SET PRCVIO=1
SET ^TMP($JOB,PRCOB,PRCDT,PRCEV,"V3")="User previously acted as obligator on a prior 1358 event."
End DoDot:4
+58 ; process an IFCAP event
+59 IF "^O^A^"[(U_PRCEV_U)
Begin DoDot:4
+60 ; save IFCAP actors in lists
+61 IF $PIECE(PRCX,U,1)
SET PRCREQ($PIECE(PRCX,U,1))=""
+62 IF $PIECE(PRCX,U,2)
SET PRCAPP($PIECE(PRCX,U,2))=""
+63 IF $PIECE(PRCX,U,3)
SET PRCOBL($PIECE(PRCX,U,3))=""
+64 ; check for violation on IFCAP event
+65 IF $PIECE(PRCX,U,2)=$PIECE(PRCX,U,1)
SET PRCVIO=1
SET ^TMP($JOB,PRCOB,PRCDT,PRCEV,"V1")="Approver previously acted as requestor on this transaction."
+66 IF $PIECE(PRCX,U,3)=$PIECE(PRCX,U,1)
SET PRCVIO=1
SET ^TMP($JOB,PRCOB,PRCDT,PRCEV,"V2")="Obligator previously acted as requester on this transaction."
+67 IF $PIECE(PRCX,U,3)=$PIECE(PRCX,U,2)
SET PRCVIO=1
SET ^TMP($JOB,PRCOB,PRCDT,PRCEV,"V3")="Obligator previously acted as approver on this transaction."
End DoDot:4
End DoDot:3
End DoDot:2
+68 ;
+69 ; violation was found
IF PRCVIO
Begin DoDot:2
+70 ; flag 1358
SET ^TMP($JOB,PRCOB)="V"
+71 ; incr count of 1358 with violation
SET PRCC("VIO")=PRCC("VIO")+1
End DoDot:2
End DoDot:1
+72 ;
PRINT ; report data
+1 SET (PRCQUIT,PRCPG)=0
DO NOW^%DTC
SET Y=%
DO DD^%DT
SET PRCDTR=Y
+2 KILL PRCDL
+3 SET PRCDL=""
SET $PIECE(PRCDL,"-",80)=""
+4 SET PRCDL("CH")=$EXTRACT(PRCDL,1,10)_" "_$EXTRACT(PRCDL,1,14)_" "_$EXTRACT(PRCDL,1,11)_" "_$EXTRACT(PRCDL,1,9)_" "_$EXTRACT(PRCDL,1,30)
+5 ;
+6 ; build page header text for selection criteria
+7 KILL PRCHDT
+8 SET PRCHDT(1)=" Including Certifications from "
+9 SET PRCHDT(1)=PRCHDT(1)_$$FMTE^XLFDT(PRCDT1)_" to "_$$FMTE^XLFDT(PRCDT2)
+10 SET PRCHDT(1)=PRCHDT(1)_" for "
+11 SET PRCHDT(1)=PRCHDT(1)_$SELECT(PRCSTALL:"all stations",1:"Station "_PRCSTN)
+12 if PRCORV
SET PRCHDT(2)=" Only 1358s with a segregation of duty violation shown."
+13 ;
+14 DO HD
+15 ;
+16 ; loop thru obligations
+17 SET PRCOB=""
FOR
SET PRCOB=$ORDER(^TMP($JOB,PRCOB))
if PRCOB=""
QUIT
Begin DoDot:1
+18 NEW PRCERR,PRCEVFP,PRCOBX,PRCVIO
+19 SET PRCOBX=$GET(^TMP($JOB,PRCOB))
+20 ; set true if error from IFCAP
SET PRCERR=$SELECT($PIECE(PRCOBX,U)="E":1,1:0)
+21 ; set true if violation was found
SET PRCVIO=$SELECT($PIECE(PRCOBX,U)="V":1,1:0)
+22 ;
+23 ; if only reporting violations then skip 1358 when no error/violation
+24 IF PRCORV
IF 'PRCERR
IF 'PRCVIO
QUIT
+25 ;
+26 ; check for page break
+27 IF $Y+7>IOSL
DO HD
if PRCQUIT
QUIT
+28 ;
+29 WRITE !,PRCDL("CH")
+30 WRITE !,PRCOB
+31 ;
+32 IF PRCERR
Begin DoDot:2
+33 WRITE !,"IFCAP events for this 1358 missing due to following error:"
+34 WRITE !,$PIECE(PRCOBX,U,2),!
End DoDot:2
+35 ;
+36 ; init flag as true (Event - First Printed for 1358)
SET PRCEVFP=1
+37 ; loop thru date/times
+38 SET PRCDT=""
FOR
SET PRCDT=$ORDER(^TMP($JOB,PRCOB,PRCDT))
if PRCDT=""
QUIT
Begin DoDot:2
+39 ; loop thru events
+40 SET PRCEV=""
+41 FOR
SET PRCEV=$ORDER(^TMP($JOB,PRCOB,PRCDT,PRCEV))
if PRCEV=""
QUIT
Begin DoDot:3
+42 NEW PRCX,PRCV
+43 ; if only reporting violations, don't print certify event without
+44 IF PRCORV
IF PRCEV
IF $ORDER(^TMP($JOB,PRCOB,PRCDT,PRCEV,"V"))=""
QUIT
+45 IF 'PRCEVFP
IF $Y+5>IOSL
DO HD
if PRCQUIT
QUIT
DO HDEV
+46 IF 'PRCEVFP
WRITE !
+47 IF PRCEVFP
SET PRCEVFP=0
+48 SET PRCX=$GET(^TMP($JOB,PRCOB,PRCDT,PRCEV))
+49 WRITE ?11,$$FMTE^XLFDT(PRCDT,"2MZ")
+50 WRITE ?26,$SELECT(PRCEV="O":"OBLIGATE",PRCEV="A":"ADJUST",1:PRCEV)
+51 IF PRCEV
WRITE ?38,"CERTIFIER",?49,$$GET1^DIQ(200,PRCX,.01)
+52 IF PRCEV="O"!(PRCEV="A")
Begin DoDot:4
+53 WRITE ?38,"REQUESTOR"
if $PIECE(PRCX,U)
WRITE ?49,$$GET1^DIQ(200,$PIECE(PRCX,U),.01)
+54 WRITE !,?38,"APPROVER"
if $PIECE(PRCX,U,2)
WRITE ?49,$$GET1^DIQ(200,$PIECE(PRCX,U,2),.01)
+55 WRITE !,?38,"OBLIGATOR"
if $PIECE(PRCX,U,3)
WRITE ?49,$$GET1^DIQ(200,$PIECE(PRCX,U,3),.01)
End DoDot:4
+56 ; list any violations found for this event (max is 3)
+57 SET PRCV=""
FOR
SET PRCV=$ORDER(^TMP($JOB,PRCOB,PRCDT,PRCEV,PRCV))
if PRCV=""
QUIT
Begin DoDot:4
+58 NEW PRCXV
+59 SET PRCXV=$GET(^TMP($JOB,PRCOB,PRCDT,PRCEV,PRCV))
+60 IF PRCXV]""
WRITE !,?8,"***",PRCXV
End DoDot:4
End DoDot:3
if PRCQUIT
QUIT
End DoDot:2
if PRCQUIT
QUIT
End DoDot:1
if PRCQUIT
QUIT
+61 ;
+62 IF PRCQUIT
WRITE !!,"REPORT STOPPED AT USER REQUEST"
+63 ; report footer
IF '$TEST
Begin DoDot:1
+64 IF $Y+5>IOSL
DO HD
if PRCQUIT
QUIT
+65 WRITE !,PRCDL("CH")
+66 WRITE !!," ",PRCC("CER")," invoice certification",$SELECT(PRCC("CER")=1:" was",1:"s were")," found during the report period."
+67 if PRCC("OBL")=0
QUIT
+68 WRITE !," ",PRCC("OBL")," 1358 Obligation",$SELECT(PRCC("OBL")=1:" is",1:"s are")," referenced."
+69 WRITE !," A violation of segregation of duties was detected on ",$SELECT(PRCC("VIO")=0:"none",1:PRCC("VIO"))," of the 1358s."
End DoDot:1
+70 IF 'PRCQUIT
IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
KILL DIR
+71 DO ^%ZISC
+72 ;
EXIT ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 KILL ^TMP($JOB)
+3 KILL PRCC,PRCDA,PRCDL,PRCDT,PRCDT1,PRCDT2,PRCDTR,PRCEV,PRCHDT,PRCOB,PRCORV
+4 KILL PRCPG,PRCSDT,PRCSTALL,PRCSTN,PRCQUIT
+5 KILL DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+6 QUIT
+7 ;
HD ; page header
+1 NEW PRCI
+2 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
SET PRCQUIT=1
QUIT
+3 IF $EXTRACT(IOST,1,2)="C-"
IF PRCPG
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET PRCQUIT=1
QUIT
+4 IF $EXTRACT(IOST,1,2)="C-"!PRCPG
WRITE @IOF
+5 SET PRCPG=PRCPG+1
+6 WRITE !,"IFCAP 1358 Segregation of Duties",?49,PRCDTR,?72,"page ",PRCPG
+7 SET PRCI=0
FOR
SET PRCI=$ORDER(PRCHDT(PRCI))
if 'PRCI
QUIT
WRITE !,PRCHDT(PRCI)
+8 WRITE !!,"1358",?11,"DATE/TIME",?26,"EVENT/INV#",?38,"ROLE",?49,"NAME"
+9 QUIT
+10 ;
HDEV ; page header for continued event
+1 WRITE !,PRCOB," (continued from previous page)"
+2 QUIT
+3 ;
DAYS ;CALCULATES THE NUMBER OF DAYS IN MONTH - Copied from routine FBAAUTL1
+1 NEW X1
+2 SET X1=X
SET X=+$EXTRACT(X,4,5)
SET X=$SELECT("^1^3^5^7^8^10^12^"[("^"_X_"^"):31,X=2:28,1:30)
+3 IF X=28
Begin DoDot:1
+4 NEW YEAR
+5 SET YEAR=$EXTRACT(X1,1,3)+1700
+6 IF $SELECT(YEAR#400=0:1,YEAR#4=0&'(YEAR#100=0):1,1:0)
SET X=29
End DoDot:1
+7 QUIT
+8 ;
+9 ;PRCFSDR
