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