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

PRCFSDR.m

Go to the documentation of this file. 
  1. 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
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1.  ; IAs
  1.  ;  #10003  DD^%DT
  1.  ;  #10000  NOW^%DTC
  1.  ;  #10086  %ZIS, HOME^%ZIS
  1.  ;  #10089  %ZISC
  1.  ;  #10063  %ZTLOAD, $$S^%ZTLOAD
  1.  ;  #2056   $$GET1^DIQ
  1.  ;  #10026  DIR
  1.  ;  #5574   $$EV1358^PRCEMOA
  1.  ;  #10103  $$FMADD^XLFDT, $$FMTE^XLFDT
  1.  ;  #5582   ^PRC(411,
  1.  ;
  1.  N DIR,DIROUT,DIRUT,DTOUT,DUOUT,PRCALL,PRCDT1,PRCDT2,%ZIS,POP,X,Y
  1.  ;
  1.  ; ask from date
  1.  S DIR(0)="D^::EX",DIR("A")="From Date"
  1.  ;   default from date is first day of previous month
  1.  S DIR("B")=$$FMTE^XLFDT($E($$FMADD^XLFDT($E(DT,1,5)_"01",-1),1,5)_"01")
  1.  D ^DIR K DIR G:$D(DIRUT) EXIT
  1.  S PRCDT1=Y
  1.  ;
  1.  ; ask to date
  1.  S DIR(0)="DA^"_PRCDT1_"::EX",DIR("A")="To Date: "
  1.  ;   default to date is last day of specified month
  1.  S X=PRCDT1 D DAYS
  1.  S DIR("B")=$$FMTE^XLFDT($E(PRCDT1,1,5)_X)
  1.  D ^DIR K DIR G:$D(DIRUT) EXIT
  1.  S:$P(Y,".",2)="" $P(Y,".",2)="235959"
  1.  S PRCDT2=Y
  1.  ;
  1.  ; ask if all stations
  1.  S DIR(0)="Y",DIR("A")="For all stations",DIR("B")="YES"
  1.  D ^DIR K DIR G:$G(DIRUT) EXIT
  1.  S PRCSTALL=Y
  1.  S PRCSTN=""
  1.  ; if not all stations ask station
  1.  I 'PRCSTALL D  G:PRCSTN="" EXIT
  1.  . S PRCSTN=""
  1.  . S DIC="^PRC(411,",DIC(0)="AQEM"
  1.  . D ^DIC Q:Y<0
  1.  . S PRCSTN=$P(Y,U,2)
  1.  ;
  1.  ; ask if violations only
  1.  S DIR(0)="Y",DIR("A")="Only list 1358s with a violation (Y/N)"
  1.  S DIR("B")="YES"
  1.  D ^DIR K DIR G:$D(DIRUT) EXIT
  1.  S PRCORV=Y
  1.  ;
  1.  ; ask device
  1.  S %ZIS="Q" D ^%ZIS G:POP EXIT
  1.  I $D(IO("Q")) D  G EXIT
  1.  . N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC,ZTSK
  1.  . S ZTRTN="QEN^PRCFSDR",ZTDESC="IFCAP 1358 Segregation of Duties Report"
  1.  . F PRCX="PRCDT*","PRCORV","PRCSTALL","PRCSTN" S ZTSAVE(PRCX)=""
  1.  . D ^%ZTLOAD,HOME^%ZIS
  1.  ;
  1. QEN ; queued entry
  1.  U IO
  1.  ;
  1. GATHER ; collect and sort data
  1.  N %
  1.  K ^TMP($J)
  1.  ;
  1.  S PRCC("CER")=0 ; initialize count of certifications
  1.  S PRCC("OBL")=0 ; initialize count of obligations
  1.  S PRCC("VIO")=0 ; initialize count of obligations with a violation
  1.  ;
  1.  ; find invoice certification events during specified period
  1.  ; Loop through Invoice Tracking file #421.5 using "AF" index on CERTIFIED BY SIG DATE/TIME (#61.9)
  1.  S PRCSDT=PRCDT1-.000001
  1.  F  S PRCSDT=$O(^PRCF(421.5,"AF",PRCSDT)) Q:PRCSDT=""!(PRCSDT>PRCDT2)  D
  1.  . S PRCDA=0
  1.  . F  S PRCDA=$O(^PRCF(421.5,"AF",PRCSDT,PRCDA)) Q:'PRCDA  D
  1.  . . N PRCNOD0,PRCNOD1,PRCNOD2,PRCNOD21,PRCPO,PRCDT,PRCSTB
  1.  . . S PRCNOD0=$G(^PRCF(421.5,PRCDA,0)),PRCNOD1=$G(^(1)),PRCNOD2=$G(^(2)),PRCNOD21=$G(^(2.1))
  1.  . . S PRCPO=$P(PRCNOD0,U,7) Q:PRCPO'>0  Q:$$GET1^DIQ(442,PRCPO_",",.02)'["1358"
  1.  . . Q:$P(PRCNOD2,U,10)'>0  S PRCDT=$P(PRCNOD21,U,5) Q:PRCDT<PRCDT1  Q:PRCDT>PRCDT2
  1.  . . S PRCOB=$P(PRCNOD1,U,3) ; full 1358 obligation number
  1.  . . ;
  1.  . . ; if report not for all stations, skip invoice certification from different station
  1.  . . I 'PRCSTALL D  I PRCSTB'=PRCSTN Q
  1.  . . . S PRCSTB=$$GET1^DIQ(442,PRCPO_",",31) S:PRCSTB="" PRCSTB=$P(PRCNOD1,U,2)
  1.  . . . I PRCSTB="" S PRCSTB=+PRCOB
  1.  . . ;
  1.  . . ; add event to ^TMP($J,1358 #,date/time,invoice #)=certifier
  1.  . . S ^TMP($J,PRCOB,PRCDT,$P(PRCNOD0,U))=$P(PRCNOD2,U,10)
  1.  . . S PRCC("CER")=PRCC("CER")+1 ; incr count of certifications
  1.  ;
  1.  ; loop thru obligations and add IFCAP events and actors to ^TMP
  1.  S PRCOB="" F  S PRCOB=$O(^TMP($J,PRCOB)) Q:PRCOB=""  D
  1.  . S PRCC("OBL")=PRCC("OBL")+1 ; incr count of 1358s
  1.  . N PRCARRAY,PRCX
  1.  . S PRCX=$$EV1358^PRCEMOA(PRCOB,"PRCARRAY")
  1.  . I PRCX'=1 S ^TMP($J,PRCOB)=PRCX Q  ; error reported by the API
  1.  . S PRCDT=""
  1.  . F  S PRCDT=$O(PRCARRAY(PRCDT)) Q:PRCDT=""!($P(PRCDT,".")>PRCDT2)  D
  1.  . . S PRCEV="" F  S PRCEV=$O(PRCARRAY(PRCDT,PRCEV)) Q:PRCEV=""  D
  1.  . . . S ^TMP($J,PRCOB,PRCDT,PRCEV)=PRCARRAY(PRCDT,PRCEV)
  1.  ;
  1.  ; loop thru obligations and add segregation of duty violations to ^TMP
  1.  S PRCOB="" F  S PRCOB=$O(^TMP($J,PRCOB)) Q:PRCOB=""  D
  1.  . Q:$P($G(^TMP($J,PRCOB)),U)="E"  ; skip because missing IFCAP events
  1.  . ;
  1.  . N PRCAPP,PRCOBL,PRCREQ,PRCVIO
  1.  . S PRCVIO=0 ; init violation flag for the 1358
  1.  . ; loop thru date/time stamps
  1.  . S PRCDT="" F  S PRCDT=$O(^TMP($J,PRCOB,PRCDT)) Q:PRCDT=""  D
  1.  . . ; loop thru events
  1.  . . S PRCEV="" F  S PRCEV=$O(^TMP($J,PRCOB,PRCDT,PRCEV)) Q:PRCEV=""  D
  1.  . . . N PRCX
  1.  . . . S PRCX=$G(^TMP($J,PRCOB,PRCDT,PRCEV))
  1.  . . . ; process IFCAP certification event
  1.  . . . I PRCEV D
  1.  . . . . ; check fo violation
  1.  . . . . I PRCX,$D(PRCREQ(PRCX)) S PRCVIO=1,^TMP($J,PRCOB,PRCDT,PRCEV,"V1")="User previously acted as requestor on a prior 1358 event."
  1.  . . . . I PRCX,$D(PRCAPP(PRCX)) S PRCVIO=1,^TMP($J,PRCOB,PRCDT,PRCEV,"V2")="User previously acted as approver on a prior 1358 event."
  1.  . . . . I PRCX,$D(PRCOBL(PRCX)) S PRCVIO=1,^TMP($J,PRCOB,PRCDT,PRCEV,"V3")="User previously acted as obligator on a prior 1358 event."
  1.  . . . ; process an IFCAP event
  1.  . . . I "^O^A^"[(U_PRCEV_U) D
  1.  . . . . ; save IFCAP actors in lists
  1.  . . . . I $P(PRCX,U,1) S PRCREQ($P(PRCX,U,1))=""
  1.  . . . . I $P(PRCX,U,2) S PRCAPP($P(PRCX,U,2))=""
  1.  . . . . I $P(PRCX,U,3) S PRCOBL($P(PRCX,U,3))=""
  1.  . . . . ; check for violation on IFCAP event
  1.  . . . . 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."
  1.  . . . . 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."
  1.  . . . . 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."
  1.  . ;
  1.  . I PRCVIO D  ; violation was found
  1.  . . S ^TMP($J,PRCOB)="V" ; flag 1358
  1.  . . S PRCC("VIO")=PRCC("VIO")+1 ; incr count of 1358 with violation
  1.  ;
  1. PRINT ; report data
  1.  S (PRCQUIT,PRCPG)=0 D NOW^%DTC S Y=% D DD^%DT S PRCDTR=Y
  1.  K PRCDL
  1.  S PRCDL="",$P(PRCDL,"-",80)=""
  1.  S PRCDL("CH")=$E(PRCDL,1,10)_" "_$E(PRCDL,1,14)_" "_$E(PRCDL,1,11)_" "_$E(PRCDL,1,9)_"  "_$E(PRCDL,1,30)
  1.  ;
  1.  ; build page header text for selection criteria
  1.  K PRCHDT
  1.  S PRCHDT(1)="  Including Certifications from "
  1.  S PRCHDT(1)=PRCHDT(1)_$$FMTE^XLFDT(PRCDT1)_" to "_$$FMTE^XLFDT(PRCDT2)
  1.  S PRCHDT(1)=PRCHDT(1)_" for "
  1.  S PRCHDT(1)=PRCHDT(1)_$S(PRCSTALL:"all stations",1:"Station "_PRCSTN)
  1.  S:PRCORV PRCHDT(2)="  Only 1358s with a segregation of duty violation shown."
  1.  ;
  1.  D HD
  1.  ;
  1.  ; loop thru obligations
  1.  S PRCOB="" F  S PRCOB=$O(^TMP($J,PRCOB)) Q:PRCOB=""  D  Q:PRCQUIT
  1.  . N PRCERR,PRCEVFP,PRCOBX,PRCVIO
  1.  . S PRCOBX=$G(^TMP($J,PRCOB))
  1.  . S PRCERR=$S($P(PRCOBX,U)="E":1,1:0) ; set true if error from IFCAP
  1.  . S PRCVIO=$S($P(PRCOBX,U)="V":1,1:0) ; set true if violation was found
  1.  . ;
  1.  . ; if only reporting violations then skip 1358 when no error/violation
  1.  . I PRCORV,'PRCERR,'PRCVIO Q
  1.  . ;
  1.  . ; check for page break
  1.  . I $Y+7>IOSL D HD Q:PRCQUIT
  1.  . ; 
  1.  . W !,PRCDL("CH")
  1.  . W !,PRCOB
  1.  . ;
  1.  . I PRCERR D
  1.  . . W !,"IFCAP events for this 1358 missing due to following error:"
  1.  . . W !,$P(PRCOBX,U,2),!
  1.  . ;
  1.  . S PRCEVFP=1 ; init flag as true (Event - First Printed for 1358)
  1.  . ; loop thru date/times
  1.  . S PRCDT="" F  S PRCDT=$O(^TMP($J,PRCOB,PRCDT)) Q:PRCDT=""  D  Q:PRCQUIT
  1.  . . ; loop thru events
  1.  . . S PRCEV=""
  1.  . . F  S PRCEV=$O(^TMP($J,PRCOB,PRCDT,PRCEV)) Q:PRCEV=""  D  Q:PRCQUIT
  1.  . . . N PRCX,PRCV
  1.  . . . ; if only reporting violations, don't print certify event without
  1.  . . . I PRCORV,PRCEV,$O(^TMP($J,PRCOB,PRCDT,PRCEV,"V"))="" Q
  1.  . . . I 'PRCEVFP,$Y+5>IOSL D HD Q:PRCQUIT  D HDEV
  1.  . . . I 'PRCEVFP W !
  1.  . . . I PRCEVFP S PRCEVFP=0
  1.  . . . S PRCX=$G(^TMP($J,PRCOB,PRCDT,PRCEV))
  1.  . . . W ?11,$$FMTE^XLFDT(PRCDT,"2MZ")
  1.  . . . W ?26,$S(PRCEV="O":"OBLIGATE",PRCEV="A":"ADJUST",1:PRCEV)
  1.  . . . I PRCEV W ?38,"CERTIFIER",?49,$$GET1^DIQ(200,PRCX,.01)
  1.  . . . I PRCEV="O"!(PRCEV="A") D
  1.  . . . . W ?38,"REQUESTOR" W:$P(PRCX,U) ?49,$$GET1^DIQ(200,$P(PRCX,U),.01)
  1.  . . . . W !,?38,"APPROVER" W:$P(PRCX,U,2) ?49,$$GET1^DIQ(200,$P(PRCX,U,2),.01)
  1.  . . . . W !,?38,"OBLIGATOR" W:$P(PRCX,U,3) ?49,$$GET1^DIQ(200,$P(PRCX,U,3),.01)
  1.  . . . ; list any violations found for this event (max is 3)
  1.  . . . S PRCV="" F  S PRCV=$O(^TMP($J,PRCOB,PRCDT,PRCEV,PRCV)) Q:PRCV=""  D
  1.  . . . . N PRCXV
  1.  . . . . S PRCXV=$G(^TMP($J,PRCOB,PRCDT,PRCEV,PRCV))
  1.  . . . . I PRCXV]"" W !,?8,"***",PRCXV
  1.  ;
  1.  I PRCQUIT W !!,"REPORT STOPPED AT USER REQUEST"
  1.  E  D  ; report footer
  1.  . I $Y+5>IOSL D HD Q:PRCQUIT
  1.  . W !,PRCDL("CH")
  1.  . W !!,"  ",PRCC("CER")," invoice certification",$S(PRCC("CER")=1:" was",1:"s were")," found during the report period."
  1.  . Q:PRCC("OBL")=0
  1.  . W !,"  ",PRCC("OBL")," 1358 Obligation",$S(PRCC("OBL")=1:" is",1:"s are")," referenced."
  1.  . W !,"  A violation of segregation of duties was detected on ",$S(PRCC("VIO")=0:"none",1:PRCC("VIO"))," of the 1358s."
  1.  I 'PRCQUIT,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR
  1.  D ^%ZISC
  1.  ;
  1. EXIT ;
  1.  I $D(ZTQUEUED) S ZTREQ="@"
  1.  K ^TMP($J)
  1.  K PRCC,PRCDA,PRCDL,PRCDT,PRCDT1,PRCDT2,PRCDTR,PRCEV,PRCHDT,PRCOB,PRCORV
  1.  K PRCPG,PRCSDT,PRCSTALL,PRCSTN,PRCQUIT
  1.  K DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1.  Q
  1.  ;
  1. HD ; page header
  1.  N PRCI
  1.  I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1,PRCQUIT=1 Q
  1.  I $E(IOST,1,2)="C-",PRCPG S DIR(0)="E" D ^DIR K DIR I 'Y S PRCQUIT=1 Q
  1.  I $E(IOST,1,2)="C-"!PRCPG W @IOF
  1.  S PRCPG=PRCPG+1
  1.  W !,"IFCAP 1358 Segregation of Duties",?49,PRCDTR,?72,"page ",PRCPG
  1.  S PRCI=0 F  S PRCI=$O(PRCHDT(PRCI)) Q:'PRCI  W !,PRCHDT(PRCI)
  1.  W !!,"1358",?11,"DATE/TIME",?26,"EVENT/INV#",?38,"ROLE",?49,"NAME"
  1.  Q
  1.  ;
  1. HDEV ; page header for continued event
  1.  W !,PRCOB," (continued from previous page)"
  1.  Q
  1.  ;
  1. DAYS ;CALCULATES THE NUMBER OF DAYS IN MONTH - Copied from routine FBAAUTL1
  1.  N X1
  1.  S X1=X,X=+$E(X,4,5),X=$S("^1^3^5^7^8^10^12^"[("^"_X_"^"):31,X=2:28,1:30)
  1.  I X=28 D
  1.  . N YEAR
  1.  . S YEAR=$E(X1,1,3)+1700
  1.  . I $S(YEAR#400=0:1,YEAR#4=0&'(YEAR#100=0):1,1:0) S X=29
  1.  Q
  1.  ; 
  1.  ;PRCFSDR