FBFPAR ;WOIFO/SAB-FPPS AUDIT REPORT ;7/18/2003
;;3.5;FEE BASIS;**61**;JAN 30, 1995
;
; ask if BY INVOICE or BY DATE RANGE
S DIR(0)="S^I:Invoice;D:Date Range"
S DIR("A")="Report one invoice or report by Date Range"
S DIR("B")="Date Range"
S DIR("?",1)="Enter I to print the audit data for one invoice."
S DIR("?",2)="Enter D to print all audit data for a date range."
S DIR("?")="Enter a code from the list."
D ^DIR K DIR G:$D(DIRUT) EXIT
S FBRANGE=$S(Y="D":1,1:0)
;
I FBRANGE D G:$D(DIRUT) EXIT
. ; ask dates
. S DIR(0)="D^::EX",DIR("A")="From Date"
. ; default from date is first day of current month
. S DIR("B")=$$FMTE^XLFDT($E(DT,1,5)_"01")
. D ^DIR K DIR Q:$D(DIRUT)
. S FBDT1=Y
. 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 Q:$D(DIRUT)
. S FBDT2=Y
;
; If not date range then ask invoice
I 'FBRANGE D G:$D(DIRUT) EXIT
. S DIR(0)="N",DIR("A")="Invoice Number: "
. D ^DIR K DIR Q:$D(DIRUT)
. S FBAAIN=Y
;
; ask device
S %ZIS="QM" D ^%ZIS G:POP EXIT
I $D(IO("Q")) D G EXIT
. S ZTRTN="QEN^FBFPAR",ZTDESC="FPPS Audit Report"
. F FBX="FBAAIN","FBDT*","FBRANGE" S ZTSAVE(FBX)=""
. D ^%ZTLOAD,HOME^%ZIS K ZTSK
;
QEN ; queued entry
U IO
;
GATHER ; collect and sort data
S FBQUIT=0
;
PRINT ; report data
S FBPG=0 D NOW^%DTC S Y=% D DD^%DT S FBDTR=Y
K FBDL S FBDL="",$P(FBDL,"-",IOM)=""
;
; build page header text for selection criteria
S:FBRANGE FBHDT(1)=" For "_$$FMTE^XLFDT(FBDT1)_" through "_$$FMTE^XLFDT(FBDT2)
;
D HD
;
; Initialize Counter
S FBC=0
;
; if by date range
I FBRANGE D
. S FBDT=FBDT1-.0000001
. F S FBDT=$O(^FB(163.7,"C",FBDT)) Q:'FBDT!(FBDT>(FBDT2_".999999")) D Q:FBQUIT
. . S FBDA=0 F S FBDA=$O(^FB(163.7,"C",FBDT,FBDA)) Q:'FBDA D Q:FBQUIT
. . . D PRINT1
;
; if by invoice
I 'FBRANGE D
. S FBDA=0 F S FBDA=$O(^FB(163.7,"B",FBAAIN,FBDA)) Q:'FBDA D Q:FBQUIT
. . D PRINT1
;
I FBC=0 W !,"no Audit entries found."
;
I FBQUIT W !!,"REPORT STOPPED AT USER REQUEST"
;
I 'FBQUIT,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR
D ^%ZISC
;
EXIT ;
I $D(ZTQUEUED) S ZTREQ="@"
K FBAAIN,FBC,FBDT,FBDT1,FBDT2,FBDTR,FBHDT,FBIENS,FBRANGE,FBPG,FBQUIT,FBX
K %,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,I,J,POP,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 !,"FPPS Data Audit Report "
I FBRANGE W "by Date Range"
E W "for Invoice: ",FBAAIN
W ?49,FBDTR,?72,"page ",FBPG
S FBI=0 F S FBI=$O(FBHDT(FBI)) Q:'FBI W !,FBHDT(FBI)
W !!,"Date/Time Changed",?19,"File",?27,"IENS",?58,"User"
W !,FBDL
Q
;
PRINT1 ; Print one audit record (FBDA)
N FB,FBADT
S FBC=FBC+1
I $Y+9>IOSL D HD Q:FBQUIT
W !
;
S FBIENS=FBDA_","
D GETS^DIQ(163.7,FBIENS,"*","","FB")
S FBADT=$$FMTE^XLFDT($$GET1^DIQ(163.7,FBIENS,1,"I"),"2F")
W !,FBADT,?19,FB(163.7,FBIENS,2),?27,FB(163.7,FBIENS,3)
W ?58,$E(FB(163.7,FBIENS,7),1,20)
W !?4,"Field: "
W $$GET1^DID(FB(163.7,FBIENS,2),FB(163.7,FBIENS,4),"","LABEL")
W ?27,"Old Field Value: ",FB(163.7,FBIENS,5)
W !
I FBRANGE W ?4,"Invoice: ",FB(163.7,FBIENS,.01)
W ?27,"New Field Value: ",FB(163.7,FBIENS,6)
;
; if prescription subfile then write more info to identify
I FB(163.7,FBIENS,2)="162.11" D
. W !,?4,"Prescription: "
. W $$GET1^DIQ(162.11,FB(163.7,FBIENS,3),.01)
;
; if service provided subfile then write more info to identify
I FB(163.7,FBIENS,2)="162.03" D
. N FBDA
. D DA^DILF(FB(163.7,FBIENS,3),.FBDA)
. W !,?4,"Patient: "
. W $$GET1^DIQ(162,FBDA(3)_",",.01)
. W ?40,"Vendor: "
. W $E($$GET1^DIQ(162.01,FBDA(2)_","_FBDA(3)_",",.01),1,30)
. W !,?4,"Date of Service: "
. W $$GET1^DIQ(162.02,FBDA(1)_","_FBDA(2)_","_FBDA(3)_",",.01)
. W ?36,"Service Provided: "
. W $$GET1^DIQ(162.03,FB(163.7,FBIENS,3),.01)
Q
;
;FBFPAR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBFPAR 4089 printed Apr 09, 2024@21:02:51 Page 2
FBFPAR ;WOIFO/SAB-FPPS AUDIT REPORT ;7/18/2003
+1 ;;3.5;FEE BASIS;**61**;JAN 30, 1995
+2 ;
+3 ; ask if BY INVOICE or BY DATE RANGE
+4 SET DIR(0)="S^I:Invoice;D:Date Range"
+5 SET DIR("A")="Report one invoice or report by Date Range"
+6 SET DIR("B")="Date Range"
+7 SET DIR("?",1)="Enter I to print the audit data for one invoice."
+8 SET DIR("?",2)="Enter D to print all audit data for a date range."
+9 SET DIR("?")="Enter a code from the list."
+10 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EXIT
+11 SET FBRANGE=$SELECT(Y="D":1,1:0)
+12 ;
+13 IF FBRANGE
Begin DoDot:1
+14 ; ask dates
+15 SET DIR(0)="D^::EX"
SET DIR("A")="From Date"
+16 ; default from date is first day of current month
+17 SET DIR("B")=$$FMTE^XLFDT($EXTRACT(DT,1,5)_"01")
+18 DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+19 SET FBDT1=Y
+20 SET DIR(0)="DA^"_FBDT1_"::EX"
SET DIR("A")="To Date: "
+21 ; default to date is last day of specified month
+22 SET X=FBDT1
DO DAYS^FBAAUTL1
+23 SET DIR("B")=$$FMTE^XLFDT($EXTRACT(FBDT1,1,5)_X)
+24 DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+25 SET FBDT2=Y
End DoDot:1
if $DATA(DIRUT)
GOTO EXIT
+26 ;
+27 ; If not date range then ask invoice
+28 IF 'FBRANGE
Begin DoDot:1
+29 SET DIR(0)="N"
SET DIR("A")="Invoice Number: "
+30 DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+31 SET FBAAIN=Y
End DoDot:1
if $DATA(DIRUT)
GOTO EXIT
+32 ;
+33 ; ask device
+34 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO EXIT
+35 IF $DATA(IO("Q"))
Begin DoDot:1
+36 SET ZTRTN="QEN^FBFPAR"
SET ZTDESC="FPPS Audit Report"
+37 FOR FBX="FBAAIN","FBDT*","FBRANGE"
SET ZTSAVE(FBX)=""
+38 DO ^%ZTLOAD
DO HOME^%ZIS
KILL ZTSK
End DoDot:1
GOTO EXIT
+39 ;
QEN ; queued entry
+1 USE IO
+2 ;
GATHER ; collect and sort data
+1 SET FBQUIT=0
+2 ;
PRINT ; report data
+1 SET FBPG=0
DO NOW^%DTC
SET Y=%
DO DD^%DT
SET FBDTR=Y
+2 KILL FBDL
SET FBDL=""
SET $PIECE(FBDL,"-",IOM)=""
+3 ;
+4 ; build page header text for selection criteria
+5 if FBRANGE
SET FBHDT(1)=" For "_$$FMTE^XLFDT(FBDT1)_" through "_$$FMTE^XLFDT(FBDT2)
+6 ;
+7 DO HD
+8 ;
+9 ; Initialize Counter
+10 SET FBC=0
+11 ;
+12 ; if by date range
+13 IF FBRANGE
Begin DoDot:1
+14 SET FBDT=FBDT1-.0000001
+15 FOR
SET FBDT=$ORDER(^FB(163.7,"C",FBDT))
if 'FBDT!(FBDT>(FBDT2_".999999"))
QUIT
Begin DoDot:2
+16 SET FBDA=0
FOR
SET FBDA=$ORDER(^FB(163.7,"C",FBDT,FBDA))
if 'FBDA
QUIT
Begin DoDot:3
+17 DO PRINT1
End DoDot:3
if FBQUIT
QUIT
End DoDot:2
if FBQUIT
QUIT
End DoDot:1
+18 ;
+19 ; if by invoice
+20 IF 'FBRANGE
Begin DoDot:1
+21 SET FBDA=0
FOR
SET FBDA=$ORDER(^FB(163.7,"B",FBAAIN,FBDA))
if 'FBDA
QUIT
Begin DoDot:2
+22 DO PRINT1
End DoDot:2
if FBQUIT
QUIT
End DoDot:1
+23 ;
+24 IF FBC=0
WRITE !,"no Audit entries found."
+25 ;
+26 IF FBQUIT
WRITE !!,"REPORT STOPPED AT USER REQUEST"
+27 ;
+28 IF 'FBQUIT
IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
KILL DIR
+29 DO ^%ZISC
+30 ;
EXIT ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 KILL FBAAIN,FBC,FBDT,FBDT1,FBDT2,FBDTR,FBHDT,FBIENS,FBRANGE,FBPG,FBQUIT,FBX
+3 KILL %,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,I,J,POP,X,Y
+4 QUIT
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 !,"FPPS Data Audit Report "
+7 IF FBRANGE
WRITE "by Date Range"
+8 IF '$TEST
WRITE "for Invoice: ",FBAAIN
+9 WRITE ?49,FBDTR,?72,"page ",FBPG
+10 SET FBI=0
FOR
SET FBI=$ORDER(FBHDT(FBI))
if 'FBI
QUIT
WRITE !,FBHDT(FBI)
+11 WRITE !!,"Date/Time Changed",?19,"File",?27,"IENS",?58,"User"
+12 WRITE !,FBDL
+13 QUIT
+14 ;
PRINT1 ; Print one audit record (FBDA)
+1 NEW FB,FBADT
+2 SET FBC=FBC+1
+3 IF $Y+9>IOSL
DO HD
if FBQUIT
QUIT
+4 WRITE !
+5 ;
+6 SET FBIENS=FBDA_","
+7 DO GETS^DIQ(163.7,FBIENS,"*","","FB")
+8 SET FBADT=$$FMTE^XLFDT($$GET1^DIQ(163.7,FBIENS,1,"I"),"2F")
+9 WRITE !,FBADT,?19,FB(163.7,FBIENS,2),?27,FB(163.7,FBIENS,3)
+10 WRITE ?58,$EXTRACT(FB(163.7,FBIENS,7),1,20)
+11 WRITE !?4,"Field: "
+12 WRITE $$GET1^DID(FB(163.7,FBIENS,2),FB(163.7,FBIENS,4),"","LABEL")
+13 WRITE ?27,"Old Field Value: ",FB(163.7,FBIENS,5)
+14 WRITE !
+15 IF FBRANGE
WRITE ?4,"Invoice: ",FB(163.7,FBIENS,.01)
+16 WRITE ?27,"New Field Value: ",FB(163.7,FBIENS,6)
+17 ;
+18 ; if prescription subfile then write more info to identify
+19 IF FB(163.7,FBIENS,2)="162.11"
Begin DoDot:1
+20 WRITE !,?4,"Prescription: "
+21 WRITE $$GET1^DIQ(162.11,FB(163.7,FBIENS,3),.01)
End DoDot:1
+22 ;
+23 ; if service provided subfile then write more info to identify
+24 IF FB(163.7,FBIENS,2)="162.03"
Begin DoDot:1
+25 NEW FBDA
+26 DO DA^DILF(FB(163.7,FBIENS,3),.FBDA)
+27 WRITE !,?4,"Patient: "
+28 WRITE $$GET1^DIQ(162,FBDA(3)_",",.01)
+29 WRITE ?40,"Vendor: "
+30 WRITE $EXTRACT($$GET1^DIQ(162.01,FBDA(2)_","_FBDA(3)_",",.01),1,30)
+31 WRITE !,?4,"Date of Service: "
+32 WRITE $$GET1^DIQ(162.02,FBDA(1)_","_FBDA(2)_","_FBDA(3)_",",.01)
+33 WRITE ?36,"Service Provided: "
+34 WRITE $$GET1^DIQ(162.03,FB(163.7,FBIENS,3),.01)
End DoDot:1
+35 QUIT
+36 ;
+37 ;FBFPAR
