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

FBAASDR.m

Go to the documentation of this file.
  1. FBAASDR ;WOIFO/SAB - FEE 1358 SEGREGATION OF DUTIES REPORT ;11/18/2010
  1. ;;3.5;FEE BASIS;**117**;JAN 30, 1995;Build 9
  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,FBALL,FBDT1,FBDT2,%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 FBDT1=Y
  1. ;
  1. ; ask to date
  1. S DIR(0)="DA^"_FBDT1_"::EX",DIR("A")="To Date: "
  1. ; default to date is last day of specified month
  1. S X=FBDT1 D DAYS^FBAAUTL1
  1. S DIR("B")=$$FMTE^XLFDT($E(FBDT1,1,5)_X)
  1. D ^DIR K DIR G:$D(DIRUT) EXIT
  1. S FBDT2=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 FBSTALL=Y
  1. S FBSTN=""
  1. ; if not all stations ask station
  1. I 'FBSTALL D G:FBSTN="" EXIT
  1. . S FBSTN=""
  1. . S DIC="^PRC(411,",DIC(0)="AQEM"
  1. . D ^DIC Q:Y<0
  1. . S FBSTN=$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 FBORV=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^FBAASDR",ZTDESC="Fee 1358 Segregation of Duty Report"
  1. . F FBX="FBDT*","FBORV","FBSTALL","FBSTN" S ZTSAVE(FBX)=""
  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 FBC("CER")=0 ; initialize count of certifications
  1. S FBC("OBL")=0 ; initialize count of obligations
  1. S FBC("VIO")=0 ; initialize count of obligations with a violation
  1. ;
  1. ; find fee certification events during specified period
  1. ; loop thru Fee Basis Batch by "ADS" x-ref (DATE SUPERVISOR CLOSED)
  1. S FBDT=FBDT1-.000001
  1. F S FBDT=$O(^FBAA(161.7,"ADS",FBDT)) Q:FBDT=""!($P(FBDT,".")>FBDT2) D
  1. . S FBDA=0
  1. . F S FBDA=$O(^FBAA(161.7,"ADS",FBDT,FBDA)) Q:'FBDA D
  1. . . N FBSTB
  1. . . S FBY0=$G(^FBAA(161.7,FBDA,0))
  1. . . ;
  1. . . ; skip batch that is only pricer released and not yet certified
  1. . . ; if TYPE = "B9" and CONTRACT HOSPITAL BATCH = "Y" and
  1. . . ; BATCH EXEMPT '= "Y" then STATUS must be R, T, or V to proceed
  1. . . I $P(FBY0,U,3)="B9",$P(FBY0,U,15)="Y",$P(FBY0,U,18)'="Y","^R^T^V^"'[(U_$P($G(^FBAA(161.7,FBDA,"ST")),U)_U) Q
  1. . . ;
  1. . . S FBOB=$P(FBY0,U,8)_"-"_$P(FBY0,U,2) ; full 1358 obligation number
  1. . . ;
  1. . . ; if report not for all stations, skip batch from different station
  1. . . I 'FBSTALL D I FBSTB'=FBSTN Q
  1. . . . S FBSTB=$$SUB^FBAAUTL5(FBOB)
  1. . . . I FBSTB="" S FBSTB=+FBOB
  1. . . ;
  1. . . ; add event to ^TMP($J,1358 #,date/time,batch #)=certifier
  1. . . S ^TMP($J,FBOB,FBDT,$P(FBY0,U))=$P(FBY0,U,7)
  1. . . S FBC("CER")=FBC("CER")+1 ; incr count of certifications
  1. ;
  1. ; loop thru obligations and add IFCAP events and actors to ^TMP
  1. S FBOB="" F S FBOB=$O(^TMP($J,FBOB)) Q:FBOB="" D
  1. . S FBC("OBL")=FBC("OBL")+1 ; incr count of 1358s
  1. . N FBARR,FBX
  1. . S FBX=$$EV1358^PRCEMOA(FBOB,"FBARR")
  1. . I FBX'=1 S ^TMP($J,FBOB)=FBX Q ; error reported by the API
  1. . S FBDT=""
  1. . F S FBDT=$O(FBARR(FBDT)) Q:FBDT=""!($P(FBDT,".")>FBDT2) D
  1. . . S FBEV="" F S FBEV=$O(FBARR(FBDT,FBEV)) Q:FBEV="" D
  1. . . . S ^TMP($J,FBOB,FBDT,FBEV)=FBARR(FBDT,FBEV)
  1. ;
  1. ; loop thru obligations and add segregation of duty violations to ^TMP
  1. S FBOB="" F S FBOB=$O(^TMP($J,FBOB)) Q:FBOB="" D
  1. . Q:$P($G(^TMP($J,FBOB)),U)="E" ; skip because missing IFCAP events
  1. . ;
  1. . N FBAPP,FBOBL,FBREQ,FBVIO
  1. . S FBVIO=0 ; init violation flag for the 1358
  1. . ; loop thru date/time stamps
  1. . S FBDT="" F S FBDT=$O(^TMP($J,FBOB,FBDT)) Q:FBDT="" D
  1. . . ; loop thru events
  1. . . S FBEV="" F S FBEV=$O(^TMP($J,FBOB,FBDT,FBEV)) Q:FBEV="" D
  1. . . . N FBX
  1. . . . S FBX=$G(^TMP($J,FBOB,FBDT,FBEV))
  1. . . . ; process fee certification event
  1. . . . I FBEV D
  1. . . . . ; check fo violation
  1. . . . . I FBX,$D(FBREQ(FBX)) S FBVIO=1,^TMP($J,FBOB,FBDT,FBEV,"V1")="User previously acted as requestor on a prior 1358 event."
  1. . . . . I FBX,$D(FBAPP(FBX)) S FBVIO=1,^TMP($J,FBOB,FBDT,FBEV,"V2")="User previously acted as approver on a prior 1358 event."
  1. . . . . I FBX,$D(FBOBL(FBX)) S FBVIO=1,^TMP($J,FBOB,FBDT,FBEV,"V3")="User previously acted as obligator on a prior 1358 event."
  1. . . . ; process an IFCAP event
  1. . . . I "^O^A^"[(U_FBEV_U) D
  1. . . . . ; save IFCAP actors in lists
  1. . . . . I $P(FBX,U,1) S FBREQ($P(FBX,U,1))=""
  1. . . . . I $P(FBX,U,2) S FBAPP($P(FBX,U,2))=""
  1. . . . . I $P(FBX,U,3) S FBOBL($P(FBX,U,3))=""
  1. . . . . ; check for violation on IFCAP event
  1. . . . . I $P(FBX,U,2)=$P(FBX,U,1) S FBVIO=1,^TMP($J,FBOB,FBDT,FBEV,"V1")="Approver previously acted as requestor on this transaction."
  1. . . . . I $P(FBX,U,3)=$P(FBX,U,1) S FBVIO=1,^TMP($J,FBOB,FBDT,FBEV,"V2")="Obligator previously acted as requester on this transaction."
  1. . . . . I $P(FBX,U,3)=$P(FBX,U,2) S FBVIO=1,^TMP($J,FBOB,FBDT,FBEV,"V3")="Obligator previously acted as approver on this transaction."
  1. . ;
  1. . I FBVIO D ; violation was found
  1. . . S ^TMP($J,FBOB)="V" ; flag 1358
  1. . . S FBC("VIO")=FBC("VIO")+1 ; incr count of 1358 with violation
  1. ;
  1. PRINT ; report data
  1. S (FBQUIT,FBPG)=0 D NOW^%DTC S Y=% D DD^%DT S FBDTR=Y
  1. K FBDL
  1. S FBDL="",$P(FBDL,"-",80)=""
  1. S FBDL("CH")=$E(FBDL,1,10)_" "_$E(FBDL,1,14)_" "_$E(FBDL,1,11)_" "_$E(FBDL,1,9)_" "_$E(FBDL,1,30)
  1. ;
  1. ; build page header text for selection criteria
  1. K FBHDT
  1. S FBHDT(1)=" Including Certifications from "
  1. S FBHDT(1)=FBHDT(1)_$$FMTE^XLFDT(FBDT1)_" to "_$$FMTE^XLFDT(FBDT2)
  1. S FBHDT(1)=FBHDT(1)_" for "
  1. S FBHDT(1)=FBHDT(1)_$S(FBSTALL:"all stations",1:"Station "_FBSTN)
  1. S:FBORV FBHDT(2)=" Only 1358s with a segregation of duty violation shown."
  1. ;
  1. D HD
  1. ;
  1. ; loop thru obligations
  1. S FBOB="" F S FBOB=$O(^TMP($J,FBOB)) Q:FBOB="" D Q:FBQUIT
  1. . N FBERR,FBEVFP,FBOBX,FBVIO
  1. . S FBOBX=$G(^TMP($J,FBOB))
  1. . S FBERR=$S($P(FBOBX,U)="E":1,1:0) ; set true if error from IFCAP
  1. . S FBVIO=$S($P(FBOBX,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 FBORV,'FBERR,'FBVIO Q
  1. . ;
  1. . ; check for page break
  1. . I $Y+7>IOSL D HD Q:FBQUIT
  1. . ;
  1. . W !,FBDL("CH")
  1. . W !,FBOB
  1. . ;
  1. . I FBERR D
  1. . . W !,"IFCAP events for this 1358 missing due to following error:"
  1. . . W !,$P(FBOBX,U,2),!
  1. . ;
  1. . S FBEVFP=1 ; init flag as true (Event - First Printed for 1358)
  1. . ; loop thru date/times
  1. . S FBDT="" F S FBDT=$O(^TMP($J,FBOB,FBDT)) Q:FBDT="" D Q:FBQUIT
  1. . . ; loop thru events
  1. . . S FBEV=""
  1. . . F S FBEV=$O(^TMP($J,FBOB,FBDT,FBEV)) Q:FBEV="" D Q:FBQUIT
  1. . . . N FBX,FBV
  1. . . . ; if only reporting violations, don't print certify event without
  1. . . . I FBORV,FBEV,$O(^TMP($J,FBOB,FBDT,FBEV,"V"))="" Q
  1. . . . I 'FBEVFP,$Y+5>IOSL D HD Q:FBQUIT D HDEV
  1. . . . I 'FBEVFP W !
  1. . . . I FBEVFP S FBEVFP=0
  1. . . . S FBX=$G(^TMP($J,FBOB,FBDT,FBEV))
  1. . . . W ?11,$$FMTE^XLFDT(FBDT,"2MZ")
  1. . . . W ?26,$S(FBEV="O":"OBLIGATE",FBEV="A":"ADJUST",1:FBEV)
  1. . . . I FBEV W ?38,"CERTIFIER",?49,$$GET1^DIQ(200,FBX,.01)
  1. . . . I FBEV="O"!(FBEV="A") D
  1. . . . . W ?38,"REQUESTOR" W:$P(FBX,U) ?49,$$GET1^DIQ(200,$P(FBX,U),.01)
  1. . . . . W !,?38,"APPROVER" W:$P(FBX,U,2) ?49,$$GET1^DIQ(200,$P(FBX,U,2),.01)
  1. . . . . W !,?38,"OBLIGATOR" W:$P(FBX,U,3) ?49,$$GET1^DIQ(200,$P(FBX,U,3),.01)
  1. . . . ; list any violations found for this event (max is 3)
  1. . . . S FBV="" F S FBV=$O(^TMP($J,FBOB,FBDT,FBEV,FBV)) Q:FBV="" D
  1. . . . . N FBXV
  1. . . . . S FBXV=$G(^TMP($J,FBOB,FBDT,FBEV,FBV))
  1. . . . . I FBXV]"" W !,?8,"***",FBXV
  1. ;
  1. I FBQUIT W !!,"REPORT STOPPED AT USER REQUEST"
  1. E D ; report footer
  1. . I $Y+5>IOSL D HD Q:FBQUIT
  1. . W !,FBDL("CH")
  1. . W !!," ",FBC("CER")," batch certification",$S(FBC("CER")=1:" was",1:"s were")," found during the report period."
  1. . Q:FBC("OBL")=0
  1. . W !," ",FBC("OBL")," 1358 Obligation",$S(FBC("OBL")=1:" is",1:"s are")," referenced."
  1. . W !," A violation of segregation of duties was detected on ",$S(FBC("VIO")=0:"none",1:FBC("VIO"))," of the 1358s."
  1. I 'FBQUIT,$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 FBC,FBDA,FBDL,FBDT,FBDT1,FBDT2,FBDTR,FBEV,FBHDT,FBOB,FBORV
  1. K FBPG,FBSTALL,FBSTN,FBQUIT,FBY0
  1. K DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1. Q
  1. ;
  1. HD ; page header
  1. N FBI
  1. I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1,FBQUIT=1 Q
  1. I $E(IOST,1,2)="C-",FBPG S DIR(0)="E" D ^DIR K DIR I 'Y S FBQUIT=1 Q
  1. I $E(IOST,1,2)="C-"!FBPG W @IOF
  1. S FBPG=FBPG+1
  1. W !,"Fee Basis 1358 Segregation of Duties",?49,FBDTR,?72,"page ",FBPG
  1. S FBI=0 F S FBI=$O(FBHDT(FBI)) Q:'FBI W !,FBHDT(FBI)
  1. W !!,"1358",?11,"DATE/TIME",?26,"EVENT/BATCH",?38,"ROLE",?49,"NAME"
  1. Q
  1. ;
  1. HDEV ; page header for continued event
  1. W !,FBOB," (continued from previous page)"
  1. Q
  1. ;
  1. ;FBAASDR