FBAASDR ;WOIFO/SAB - FEE 1358 SEGREGATION OF DUTIES REPORT ;11/18/2010
;;3.5;FEE BASIS;**117**;JAN 30, 1995;Build 9
;;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,FBALL,FBDT1,FBDT2,%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 FBDT1=Y
;
; ask to date
S DIR(0)="DA^"_FBDT1_"::EX",DIR("A")="To Date: "
; default to date is last day of specified month
S X=FBDT1 D DAYS^FBAAUTL1
S DIR("B")=$$FMTE^XLFDT($E(FBDT1,1,5)_X)
D ^DIR K DIR G:$D(DIRUT) EXIT
S FBDT2=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 FBSTALL=Y
S FBSTN=""
; if not all stations ask station
I 'FBSTALL D G:FBSTN="" EXIT
. S FBSTN=""
. S DIC="^PRC(411,",DIC(0)="AQEM"
. D ^DIC Q:Y<0
. S FBSTN=$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 FBORV=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^FBAASDR",ZTDESC="Fee 1358 Segregation of Duty Report"
. F FBX="FBDT*","FBORV","FBSTALL","FBSTN" S ZTSAVE(FBX)=""
. D ^%ZTLOAD,HOME^%ZIS
;
QEN ; queued entry
U IO
;
GATHER ; collect and sort data
N %
K ^TMP($J)
;
S FBC("CER")=0 ; initialize count of certifications
S FBC("OBL")=0 ; initialize count of obligations
S FBC("VIO")=0 ; initialize count of obligations with a violation
;
; find fee certification events during specified period
; loop thru Fee Basis Batch by "ADS" x-ref (DATE SUPERVISOR CLOSED)
S FBDT=FBDT1-.000001
F S FBDT=$O(^FBAA(161.7,"ADS",FBDT)) Q:FBDT=""!($P(FBDT,".")>FBDT2) D
. S FBDA=0
. F S FBDA=$O(^FBAA(161.7,"ADS",FBDT,FBDA)) Q:'FBDA D
. . N FBSTB
. . S FBY0=$G(^FBAA(161.7,FBDA,0))
. . ;
. . ; skip batch that is only pricer released and not yet certified
. . ; if TYPE = "B9" and CONTRACT HOSPITAL BATCH = "Y" and
. . ; BATCH EXEMPT '= "Y" then STATUS must be R, T, or V to proceed
. . 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
. . ;
. . S FBOB=$P(FBY0,U,8)_"-"_$P(FBY0,U,2) ; full 1358 obligation number
. . ;
. . ; if report not for all stations, skip batch from different station
. . I 'FBSTALL D I FBSTB'=FBSTN Q
. . . S FBSTB=$$SUB^FBAAUTL5(FBOB)
. . . I FBSTB="" S FBSTB=+FBOB
. . ;
. . ; add event to ^TMP($J,1358 #,date/time,batch #)=certifier
. . S ^TMP($J,FBOB,FBDT,$P(FBY0,U))=$P(FBY0,U,7)
. . S FBC("CER")=FBC("CER")+1 ; incr count of certifications
;
; loop thru obligations and add IFCAP events and actors to ^TMP
S FBOB="" F S FBOB=$O(^TMP($J,FBOB)) Q:FBOB="" D
. S FBC("OBL")=FBC("OBL")+1 ; incr count of 1358s
. N FBARR,FBX
. S FBX=$$EV1358^PRCEMOA(FBOB,"FBARR")
. I FBX'=1 S ^TMP($J,FBOB)=FBX Q ; error reported by the API
. S FBDT=""
. F S FBDT=$O(FBARR(FBDT)) Q:FBDT=""!($P(FBDT,".")>FBDT2) D
. . S FBEV="" F S FBEV=$O(FBARR(FBDT,FBEV)) Q:FBEV="" D
. . . S ^TMP($J,FBOB,FBDT,FBEV)=FBARR(FBDT,FBEV)
;
; loop thru obligations and add segregation of duty violations to ^TMP
S FBOB="" F S FBOB=$O(^TMP($J,FBOB)) Q:FBOB="" D
. Q:$P($G(^TMP($J,FBOB)),U)="E" ; skip because missing IFCAP events
. ;
. N FBAPP,FBOBL,FBREQ,FBVIO
. S FBVIO=0 ; init violation flag for the 1358
. ; loop thru date/time stamps
. S FBDT="" F S FBDT=$O(^TMP($J,FBOB,FBDT)) Q:FBDT="" D
. . ; loop thru events
. . S FBEV="" F S FBEV=$O(^TMP($J,FBOB,FBDT,FBEV)) Q:FBEV="" D
. . . N FBX
. . . S FBX=$G(^TMP($J,FBOB,FBDT,FBEV))
. . . ; process fee certification event
. . . I FBEV D
. . . . ; check fo violation
. . . . I FBX,$D(FBREQ(FBX)) S FBVIO=1,^TMP($J,FBOB,FBDT,FBEV,"V1")="User previously acted as requestor on a prior 1358 event."
. . . . I FBX,$D(FBAPP(FBX)) S FBVIO=1,^TMP($J,FBOB,FBDT,FBEV,"V2")="User previously acted as approver on a prior 1358 event."
. . . . I FBX,$D(FBOBL(FBX)) S FBVIO=1,^TMP($J,FBOB,FBDT,FBEV,"V3")="User previously acted as obligator on a prior 1358 event."
. . . ; process an IFCAP event
. . . I "^O^A^"[(U_FBEV_U) D
. . . . ; save IFCAP actors in lists
. . . . I $P(FBX,U,1) S FBREQ($P(FBX,U,1))=""
. . . . I $P(FBX,U,2) S FBAPP($P(FBX,U,2))=""
. . . . I $P(FBX,U,3) S FBOBL($P(FBX,U,3))=""
. . . . ; check for violation on IFCAP event
. . . . 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."
. . . . 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."
. . . . 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."
. ;
. I FBVIO D ; violation was found
. . S ^TMP($J,FBOB)="V" ; flag 1358
. . S FBC("VIO")=FBC("VIO")+1 ; incr count of 1358 with violation
;
PRINT ; report data
S (FBQUIT,FBPG)=0 D NOW^%DTC S Y=% D DD^%DT S FBDTR=Y
K FBDL
S FBDL="",$P(FBDL,"-",80)=""
S FBDL("CH")=$E(FBDL,1,10)_" "_$E(FBDL,1,14)_" "_$E(FBDL,1,11)_" "_$E(FBDL,1,9)_" "_$E(FBDL,1,30)
;
; build page header text for selection criteria
K FBHDT
S FBHDT(1)=" Including Certifications from "
S FBHDT(1)=FBHDT(1)_$$FMTE^XLFDT(FBDT1)_" to "_$$FMTE^XLFDT(FBDT2)
S FBHDT(1)=FBHDT(1)_" for "
S FBHDT(1)=FBHDT(1)_$S(FBSTALL:"all stations",1:"Station "_FBSTN)
S:FBORV FBHDT(2)=" Only 1358s with a segregation of duty violation shown."
;
D HD
;
; loop thru obligations
S FBOB="" F S FBOB=$O(^TMP($J,FBOB)) Q:FBOB="" D Q:FBQUIT
. N FBERR,FBEVFP,FBOBX,FBVIO
. S FBOBX=$G(^TMP($J,FBOB))
. S FBERR=$S($P(FBOBX,U)="E":1,1:0) ; set true if error from IFCAP
. S FBVIO=$S($P(FBOBX,U)="V":1,1:0) ; set true if violation was found
. ;
. ; if only reporting violations then skip 1358 when no error/violation
. I FBORV,'FBERR,'FBVIO Q
. ;
. ; check for page break
. I $Y+7>IOSL D HD Q:FBQUIT
. ;
. W !,FBDL("CH")
. W !,FBOB
. ;
. I FBERR D
. . W !,"IFCAP events for this 1358 missing due to following error:"
. . W !,$P(FBOBX,U,2),!
. ;
. S FBEVFP=1 ; init flag as true (Event - First Printed for 1358)
. ; loop thru date/times
. S FBDT="" F S FBDT=$O(^TMP($J,FBOB,FBDT)) Q:FBDT="" D Q:FBQUIT
. . ; loop thru events
. . S FBEV=""
. . F S FBEV=$O(^TMP($J,FBOB,FBDT,FBEV)) Q:FBEV="" D Q:FBQUIT
. . . N FBX,FBV
. . . ; if only reporting violations, don't print certify event without
. . . I FBORV,FBEV,$O(^TMP($J,FBOB,FBDT,FBEV,"V"))="" Q
. . . I 'FBEVFP,$Y+5>IOSL D HD Q:FBQUIT D HDEV
. . . I 'FBEVFP W !
. . . I FBEVFP S FBEVFP=0
. . . S FBX=$G(^TMP($J,FBOB,FBDT,FBEV))
. . . W ?11,$$FMTE^XLFDT(FBDT,"2MZ")
. . . W ?26,$S(FBEV="O":"OBLIGATE",FBEV="A":"ADJUST",1:FBEV)
. . . I FBEV W ?38,"CERTIFIER",?49,$$GET1^DIQ(200,FBX,.01)
. . . I FBEV="O"!(FBEV="A") D
. . . . W ?38,"REQUESTOR" W:$P(FBX,U) ?49,$$GET1^DIQ(200,$P(FBX,U),.01)
. . . . W !,?38,"APPROVER" W:$P(FBX,U,2) ?49,$$GET1^DIQ(200,$P(FBX,U,2),.01)
. . . . W !,?38,"OBLIGATOR" W:$P(FBX,U,3) ?49,$$GET1^DIQ(200,$P(FBX,U,3),.01)
. . . ; list any violations found for this event (max is 3)
. . . S FBV="" F S FBV=$O(^TMP($J,FBOB,FBDT,FBEV,FBV)) Q:FBV="" D
. . . . N FBXV
. . . . S FBXV=$G(^TMP($J,FBOB,FBDT,FBEV,FBV))
. . . . I FBXV]"" W !,?8,"***",FBXV
;
I FBQUIT W !!,"REPORT STOPPED AT USER REQUEST"
E D ; report footer
. I $Y+5>IOSL D HD Q:FBQUIT
. W !,FBDL("CH")
. W !!," ",FBC("CER")," batch certification",$S(FBC("CER")=1:" was",1:"s were")," found during the report period."
. Q:FBC("OBL")=0
. W !," ",FBC("OBL")," 1358 Obligation",$S(FBC("OBL")=1:" is",1:"s are")," referenced."
. W !," A violation of segregation of duties was detected on ",$S(FBC("VIO")=0:"none",1:FBC("VIO"))," of the 1358s."
I 'FBQUIT,$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 FBC,FBDA,FBDL,FBDT,FBDT1,FBDT2,FBDTR,FBEV,FBHDT,FBOB,FBORV
K FBPG,FBSTALL,FBSTN,FBQUIT,FBY0
K DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
Q
;
HD ; page header
N FBI
I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1,FBQUIT=1 Q
I $E(IOST,1,2)="C-",FBPG S DIR(0)="E" D ^DIR K DIR I 'Y S FBQUIT=1 Q
I $E(IOST,1,2)="C-"!FBPG W @IOF
S FBPG=FBPG+1
W !,"Fee Basis 1358 Segregation of Duties",?49,FBDTR,?72,"page ",FBPG
S FBI=0 F S FBI=$O(FBHDT(FBI)) Q:'FBI W !,FBHDT(FBI)
W !!,"1358",?11,"DATE/TIME",?26,"EVENT/BATCH",?38,"ROLE",?49,"NAME"
Q
;
HDEV ; page header for continued event
W !,FBOB," (continued from previous page)"
Q
;
;FBAASDR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAASDR 9215 printed Oct 16, 2024@17:57:28 Page 2
FBAASDR ;WOIFO/SAB - FEE 1358 SEGREGATION OF DUTIES REPORT ;11/18/2010
+1 ;;3.5;FEE BASIS;**117**;JAN 30, 1995;Build 9
+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,FBALL,FBDT1,FBDT2,%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 FBDT1=Y
+24 ;
+25 ; ask to date
+26 SET DIR(0)="DA^"_FBDT1_"::EX"
SET DIR("A")="To Date: "
+27 ; default to date is last day of specified month
+28 SET X=FBDT1
DO DAYS^FBAAUTL1
+29 SET DIR("B")=$$FMTE^XLFDT($EXTRACT(FBDT1,1,5)_X)
+30 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EXIT
+31 SET FBDT2=Y
+32 ;
+33 ; ask if all stations
+34 SET DIR(0)="Y"
SET DIR("A")="For all stations"
SET DIR("B")="YES"
+35 DO ^DIR
KILL DIR
if $GET(DIRUT)
GOTO EXIT
+36 SET FBSTALL=Y
+37 SET FBSTN=""
+38 ; if not all stations ask station
+39 IF 'FBSTALL
Begin DoDot:1
+40 SET FBSTN=""
+41 SET DIC="^PRC(411,"
SET DIC(0)="AQEM"
+42 DO ^DIC
if Y<0
QUIT
+43 SET FBSTN=$PIECE(Y,U,2)
End DoDot:1
if FBSTN=""
GOTO EXIT
+44 ;
+45 ; ask if violations only
+46 SET DIR(0)="Y"
SET DIR("A")="Only list 1358s with a violation (Y/N)"
+47 SET DIR("B")="YES"
+48 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EXIT
+49 SET FBORV=Y
+50 ;
+51 ; ask device
+52 SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO EXIT
+53 IF $DATA(IO("Q"))
Begin DoDot:1
+54 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC,ZTSK
+55 SET ZTRTN="QEN^FBAASDR"
SET ZTDESC="Fee 1358 Segregation of Duty Report"
+56 FOR FBX="FBDT*","FBORV","FBSTALL","FBSTN"
SET ZTSAVE(FBX)=""
+57 DO ^%ZTLOAD
DO HOME^%ZIS
End DoDot:1
GOTO EXIT
+58 ;
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 FBC("CER")=0
+5 ; initialize count of obligations
SET FBC("OBL")=0
+6 ; initialize count of obligations with a violation
SET FBC("VIO")=0
+7 ;
+8 ; find fee certification events during specified period
+9 ; loop thru Fee Basis Batch by "ADS" x-ref (DATE SUPERVISOR CLOSED)
+10 SET FBDT=FBDT1-.000001
+11 FOR
SET FBDT=$ORDER(^FBAA(161.7,"ADS",FBDT))
if FBDT=""!($PIECE(FBDT,".")>FBDT2)
QUIT
Begin DoDot:1
+12 SET FBDA=0
+13 FOR
SET FBDA=$ORDER(^FBAA(161.7,"ADS",FBDT,FBDA))
if 'FBDA
QUIT
Begin DoDot:2
+14 NEW FBSTB
+15 SET FBY0=$GET(^FBAA(161.7,FBDA,0))
+16 ;
+17 ; skip batch that is only pricer released and not yet certified
+18 ; if TYPE = "B9" and CONTRACT HOSPITAL BATCH = "Y" and
+19 ; BATCH EXEMPT '= "Y" then STATUS must be R, T, or V to proceed
+20 IF $PIECE(FBY0,U,3)="B9"
IF $PIECE(FBY0,U,15)="Y"
IF $PIECE(FBY0,U,18)'="Y"
IF "^R^T^V^"'[(U_$PIECE($GET(^FBAA(161.7,FBDA,"ST")),U)_U)
QUIT
+21 ;
+22 ; full 1358 obligation number
SET FBOB=$PIECE(FBY0,U,8)_"-"_$PIECE(FBY0,U,2)
+23 ;
+24 ; if report not for all stations, skip batch from different station
+25 IF 'FBSTALL
Begin DoDot:3
+26 SET FBSTB=$$SUB^FBAAUTL5(FBOB)
+27 IF FBSTB=""
SET FBSTB=+FBOB
End DoDot:3
IF FBSTB'=FBSTN
QUIT
+28 ;
+29 ; add event to ^TMP($J,1358 #,date/time,batch #)=certifier
+30 SET ^TMP($JOB,FBOB,FBDT,$PIECE(FBY0,U))=$PIECE(FBY0,U,7)
+31 ; incr count of certifications
SET FBC("CER")=FBC("CER")+1
End DoDot:2
End DoDot:1
+32 ;
+33 ; loop thru obligations and add IFCAP events and actors to ^TMP
+34 SET FBOB=""
FOR
SET FBOB=$ORDER(^TMP($JOB,FBOB))
if FBOB=""
QUIT
Begin DoDot:1
+35 ; incr count of 1358s
SET FBC("OBL")=FBC("OBL")+1
+36 NEW FBARR,FBX
+37 SET FBX=$$EV1358^PRCEMOA(FBOB,"FBARR")
+38 ; error reported by the API
IF FBX'=1
SET ^TMP($JOB,FBOB)=FBX
QUIT
+39 SET FBDT=""
+40 FOR
SET FBDT=$ORDER(FBARR(FBDT))
if FBDT=""!($PIECE(FBDT,".")>FBDT2)
QUIT
Begin DoDot:2
+41 SET FBEV=""
FOR
SET FBEV=$ORDER(FBARR(FBDT,FBEV))
if FBEV=""
QUIT
Begin DoDot:3
+42 SET ^TMP($JOB,FBOB,FBDT,FBEV)=FBARR(FBDT,FBEV)
End DoDot:3
End DoDot:2
End DoDot:1
+43 ;
+44 ; loop thru obligations and add segregation of duty violations to ^TMP
+45 SET FBOB=""
FOR
SET FBOB=$ORDER(^TMP($JOB,FBOB))
if FBOB=""
QUIT
Begin DoDot:1
+46 ; skip because missing IFCAP events
if $PIECE($GET(^TMP($JOB,FBOB)),U)="E"
QUIT
+47 ;
+48 NEW FBAPP,FBOBL,FBREQ,FBVIO
+49 ; init violation flag for the 1358
SET FBVIO=0
+50 ; loop thru date/time stamps
+51 SET FBDT=""
FOR
SET FBDT=$ORDER(^TMP($JOB,FBOB,FBDT))
if FBDT=""
QUIT
Begin DoDot:2
+52 ; loop thru events
+53 SET FBEV=""
FOR
SET FBEV=$ORDER(^TMP($JOB,FBOB,FBDT,FBEV))
if FBEV=""
QUIT
Begin DoDot:3
+54 NEW FBX
+55 SET FBX=$GET(^TMP($JOB,FBOB,FBDT,FBEV))
+56 ; process fee certification event
+57 IF FBEV
Begin DoDot:4
+58 ; check fo violation
+59 IF FBX
IF $DATA(FBREQ(FBX))
SET FBVIO=1
SET ^TMP($JOB,FBOB,FBDT,FBEV,"V1")="User previously acted as requestor on a prior 1358 event."
+60 IF FBX
IF $DATA(FBAPP(FBX))
SET FBVIO=1
SET ^TMP($JOB,FBOB,FBDT,FBEV,"V2")="User previously acted as approver on a prior 1358 event."
+61 IF FBX
IF $DATA(FBOBL(FBX))
SET FBVIO=1
SET ^TMP($JOB,FBOB,FBDT,FBEV,"V3")="User previously acted as obligator on a prior 1358 event."
End DoDot:4
+62 ; process an IFCAP event
+63 IF "^O^A^"[(U_FBEV_U)
Begin DoDot:4
+64 ; save IFCAP actors in lists
+65 IF $PIECE(FBX,U,1)
SET FBREQ($PIECE(FBX,U,1))=""
+66 IF $PIECE(FBX,U,2)
SET FBAPP($PIECE(FBX,U,2))=""
+67 IF $PIECE(FBX,U,3)
SET FBOBL($PIECE(FBX,U,3))=""
+68 ; check for violation on IFCAP event
+69 IF $PIECE(FBX,U,2)=$PIECE(FBX,U,1)
SET FBVIO=1
SET ^TMP($JOB,FBOB,FBDT,FBEV,"V1")="Approver previously acted as requestor on this transaction."
+70 IF $PIECE(FBX,U,3)=$PIECE(FBX,U,1)
SET FBVIO=1
SET ^TMP($JOB,FBOB,FBDT,FBEV,"V2")="Obligator previously acted as requester on this transaction."
+71 IF $PIECE(FBX,U,3)=$PIECE(FBX,U,2)
SET FBVIO=1
SET ^TMP($JOB,FBOB,FBDT,FBEV,"V3")="Obligator previously acted as approver on this transaction."
End DoDot:4
End DoDot:3
End DoDot:2
+72 ;
+73 ; violation was found
IF FBVIO
Begin DoDot:2
+74 ; flag 1358
SET ^TMP($JOB,FBOB)="V"
+75 ; incr count of 1358 with violation
SET FBC("VIO")=FBC("VIO")+1
End DoDot:2
End DoDot:1
+76 ;
PRINT ; report data
+1 SET (FBQUIT,FBPG)=0
DO NOW^%DTC
SET Y=%
DO DD^%DT
SET FBDTR=Y
+2 KILL FBDL
+3 SET FBDL=""
SET $PIECE(FBDL,"-",80)=""
+4 SET FBDL("CH")=$EXTRACT(FBDL,1,10)_" "_$EXTRACT(FBDL,1,14)_" "_$EXTRACT(FBDL,1,11)_" "_$EXTRACT(FBDL,1,9)_" "_$EXTRACT(FBDL,1,30)
+5 ;
+6 ; build page header text for selection criteria
+7 KILL FBHDT
+8 SET FBHDT(1)=" Including Certifications from "
+9 SET FBHDT(1)=FBHDT(1)_$$FMTE^XLFDT(FBDT1)_" to "_$$FMTE^XLFDT(FBDT2)
+10 SET FBHDT(1)=FBHDT(1)_" for "
+11 SET FBHDT(1)=FBHDT(1)_$SELECT(FBSTALL:"all stations",1:"Station "_FBSTN)
+12 if FBORV
SET FBHDT(2)=" Only 1358s with a segregation of duty violation shown."
+13 ;
+14 DO HD
+15 ;
+16 ; loop thru obligations
+17 SET FBOB=""
FOR
SET FBOB=$ORDER(^TMP($JOB,FBOB))
if FBOB=""
QUIT
Begin DoDot:1
+18 NEW FBERR,FBEVFP,FBOBX,FBVIO
+19 SET FBOBX=$GET(^TMP($JOB,FBOB))
+20 ; set true if error from IFCAP
SET FBERR=$SELECT($PIECE(FBOBX,U)="E":1,1:0)
+21 ; set true if violation was found
SET FBVIO=$SELECT($PIECE(FBOBX,U)="V":1,1:0)
+22 ;
+23 ; if only reporting violations then skip 1358 when no error/violation
+24 IF FBORV
IF 'FBERR
IF 'FBVIO
QUIT
+25 ;
+26 ; check for page break
+27 IF $Y+7>IOSL
DO HD
if FBQUIT
QUIT
+28 ;
+29 WRITE !,FBDL("CH")
+30 WRITE !,FBOB
+31 ;
+32 IF FBERR
Begin DoDot:2
+33 WRITE !,"IFCAP events for this 1358 missing due to following error:"
+34 WRITE !,$PIECE(FBOBX,U,2),!
End DoDot:2
+35 ;
+36 ; init flag as true (Event - First Printed for 1358)
SET FBEVFP=1
+37 ; loop thru date/times
+38 SET FBDT=""
FOR
SET FBDT=$ORDER(^TMP($JOB,FBOB,FBDT))
if FBDT=""
QUIT
Begin DoDot:2
+39 ; loop thru events
+40 SET FBEV=""
+41 FOR
SET FBEV=$ORDER(^TMP($JOB,FBOB,FBDT,FBEV))
if FBEV=""
QUIT
Begin DoDot:3
+42 NEW FBX,FBV
+43 ; if only reporting violations, don't print certify event without
+44 IF FBORV
IF FBEV
IF $ORDER(^TMP($JOB,FBOB,FBDT,FBEV,"V"))=""
QUIT
+45 IF 'FBEVFP
IF $Y+5>IOSL
DO HD
if FBQUIT
QUIT
DO HDEV
+46 IF 'FBEVFP
WRITE !
+47 IF FBEVFP
SET FBEVFP=0
+48 SET FBX=$GET(^TMP($JOB,FBOB,FBDT,FBEV))
+49 WRITE ?11,$$FMTE^XLFDT(FBDT,"2MZ")
+50 WRITE ?26,$SELECT(FBEV="O":"OBLIGATE",FBEV="A":"ADJUST",1:FBEV)
+51 IF FBEV
WRITE ?38,"CERTIFIER",?49,$$GET1^DIQ(200,FBX,.01)
+52 IF FBEV="O"!(FBEV="A")
Begin DoDot:4
+53 WRITE ?38,"REQUESTOR"
if $PIECE(FBX,U)
WRITE ?49,$$GET1^DIQ(200,$PIECE(FBX,U),.01)
+54 WRITE !,?38,"APPROVER"
if $PIECE(FBX,U,2)
WRITE ?49,$$GET1^DIQ(200,$PIECE(FBX,U,2),.01)
+55 WRITE !,?38,"OBLIGATOR"
if $PIECE(FBX,U,3)
WRITE ?49,$$GET1^DIQ(200,$PIECE(FBX,U,3),.01)
End DoDot:4
+56 ; list any violations found for this event (max is 3)
+57 SET FBV=""
FOR
SET FBV=$ORDER(^TMP($JOB,FBOB,FBDT,FBEV,FBV))
if FBV=""
QUIT
Begin DoDot:4
+58 NEW FBXV
+59 SET FBXV=$GET(^TMP($JOB,FBOB,FBDT,FBEV,FBV))
+60 IF FBXV]""
WRITE !,?8,"***",FBXV
End DoDot:4
End DoDot:3
if FBQUIT
QUIT
End DoDot:2
if FBQUIT
QUIT
End DoDot:1
if FBQUIT
QUIT
+61 ;
+62 IF FBQUIT
WRITE !!,"REPORT STOPPED AT USER REQUEST"
+63 ; report footer
IF '$TEST
Begin DoDot:1
+64 IF $Y+5>IOSL
DO HD
if FBQUIT
QUIT
+65 WRITE !,FBDL("CH")
+66 WRITE !!," ",FBC("CER")," batch certification",$SELECT(FBC("CER")=1:" was",1:"s were")," found during the report period."
+67 if FBC("OBL")=0
QUIT
+68 WRITE !," ",FBC("OBL")," 1358 Obligation",$SELECT(FBC("OBL")=1:" is",1:"s are")," referenced."
+69 WRITE !," A violation of segregation of duties was detected on ",$SELECT(FBC("VIO")=0:"none",1:FBC("VIO"))," of the 1358s."
End DoDot:1
+70 IF 'FBQUIT
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 FBC,FBDA,FBDL,FBDT,FBDT1,FBDT2,FBDTR,FBEV,FBHDT,FBOB,FBORV
+4 KILL FBPG,FBSTALL,FBSTN,FBQUIT,FBY0
+5 KILL DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+6 QUIT
+7 ;
HD ; page header
+1 NEW FBI
+2 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
SET FBQUIT=1
QUIT
+3 IF $EXTRACT(IOST,1,2)="C-"
IF FBPG
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET FBQUIT=1
QUIT
+4 IF $EXTRACT(IOST,1,2)="C-"!FBPG
WRITE @IOF
+5 SET FBPG=FBPG+1
+6 WRITE !,"Fee Basis 1358 Segregation of Duties",?49,FBDTR,?72,"page ",FBPG
+7 SET FBI=0
FOR
SET FBI=$ORDER(FBHDT(FBI))
if 'FBI
QUIT
WRITE !,FBHDT(FBI)
+8 WRITE !!,"1358",?11,"DATE/TIME",?26,"EVENT/BATCH",?38,"ROLE",?49,"NAME"
+9 QUIT
+10 ;
HDEV ; page header for continued event
+1 WRITE !,FBOB," (continued from previous page)"
+2 QUIT
+3 ;
+4 ;FBAASDR
