- 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 Feb 18, 2025@23:23:04 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