VAFCAUD ;BIR/CML-MPI/PD AUDIT FILE PRINT FOR A SPECIFIED PATIENT ;20 May 2013 2:25 PM
;;5.3;Registration;**477,712,863**;Aug 13, 1993;Build 2
;Reference to ^DIA(2 and data derived from the AUDIT file (#1.1)
;is supported by IA #2097 and #2602.
;Reference to ^ORD(101 supported by IA #2596
S QFLG=1
S RPCFLG=0 ;is this from an rpc call
BEGIN ;
W !!,"This option prints information from the AUDIT file (#1.1) for a"
W !,"selected patient and date range."
W !!,"For the PATIENT file (#2) entry selected, the report prints the"
W !,"patient name and DFN, date/time the field was edited, the user who"
W !,"made the change, the field edited, the old value, and the new value."
W !,"The option or protocol (if available) will also be displayed."
D ASK1
I $G(VAFCDFN) D ASK2
I $G(VAFCBDT),$G(VAFCEDT) D DEV
G QUIT
;
ASK1 ;Ask for PATIENT
W !
S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: " D ^DIC K DIC Q:Y<0 S VAFCDFN=+Y
;
DSP ;Display if audit data is available - **863 MVI_2039 (cml) new subroutine added to pick up audit data for multiple subfields
S (GOT,EARLY,EARLYM)=0,EARLYDT=""
S PTNM=$P(^DPT(VAFCDFN,0),"^")
;check top level audits
S IEN=0 F S IEN=$O(^DIA(2,"B",VAFCDFN,IEN)) Q:'IEN D
.I $D(^DIA(2,IEN,0)) S EDITDT=$P(^(0),"^",2),GOT=1 S:EARLY=0 EARLY=EDITDT S:EDITDT<EARLY EARLY=EDITDT
;check multiple level
S DFNMULT=VAFCDFN_",0" F S DFNMULT=$O(^DIA(2,"B",DFNMULT)) Q:DFNMULT="" Q:$P(DFNMULT,",")'=VAFCDFN I $D(^DIA(2,"B",DFNMULT)) D
.S IEN=0 F S IEN=$O(^DIA(2,"B",DFNMULT,IEN)) Q:'IEN I $D(^DIA(2,IEN,0)) S EDITDT=$P(^(0),"^",2),GOT=1 S:EARLYM=0 EARLYM=EDITDT S:EDITDT<EARLYM EARLYM=EDITDT
;
I 'GOT W !!,"There is no audit data available for any date for ",PTNM,"." G ASK1
I EARLYM=0,EARLY>0 S EARLYDT=EARLY
I EARLY=0,EARLYM>0 S EARLYDT=EARLYM
I EARLY>0,EARLYM>EARLY S EARLYDT=EARLY
I EARLYM>0,EARLY>EARLYM S EARLYDT=EARLYM
W !!,"The earliest audit data is "_$$FMTE^XLFDT(EARLYDT)_"."
Q
;
ASK2 ;Ask for Date Range
;I '$D(VAFCDFN)&($D(DFN)) S VAFCDFN=DFN
W !!,"Enter date range for data to be included in report."
K DIR,DIRUT,DTOUT,DUOUT
S DIR(0)="DAO^:DT:EPX",DIR("A")="Beginning Date: " D ^DIR K DIR Q:$D(DIRUT) S VAFCBDT=Y
S DIR(0)="DAO^"_VAFCBDT_":DT:EPX",DIR("A")="Ending Date: " D ^DIR K DIR Q:$D(DIRUT) S VAFCEDT=Y
Q
;
DEV W !!,"The right margin for this report is 80.",!!
S ZTSAVE("VAFCBDT")="",ZTSAVE("VAFCEDT")="",ZTSAVE("VAFCDFN")=""
D EN^XUTMDEVQ("START^VAFCAUD(VAFCDFN,VAFCBDT,VAFCEDT,RPCFLG)","MPI/PD - Print AUDIT File Data for a Specific Patient",.ZTSAVE) I 'POP Q
W !,"NO DEVICE SELECTED OR REPORT PRINTED!!"
G QUIT
;
START(VAFCDFN,VAFCBDT,VAFCEDT,RPCFLG) ;
N IEN
K ^TMP("VAFCAUD",$J)
;
LOOP ;Loop on "B" xref of the AUDIT file
S STOP=VAFCEDT+1
S IEN=0 F S IEN=$O(^DIA(2,"B",VAFCDFN,IEN)) Q:'IEN D
.I $D(^DIA(2,IEN,0)) S EDITDT=$P(^(0),U,2) I EDITDT>VAFCBDT,EDITDT<STOP D
..S ^TMP("VAFCAUD",$J,EDITDT,IEN)=""
;
;find any audit data for audited fields that are multiples - **863 MVI_2039 (cml)
S DFNMULT=VAFCDFN_",0" F S DFNMULT=$O(^DIA(2,"B",DFNMULT)) Q:DFNMULT="" Q:$P(DFNMULT,",")'=VAFCDFN I $D(^DIA(2,"B",DFNMULT)) D
.S IEN=0 F S IEN=$O(^DIA(2,"B",DFNMULT,IEN)) Q:'IEN D
..I $D(^DIA(2,IEN,0)) S EDITDT=$P(^(0),"^",2) I EDITDT>VAFCBDT,EDITDT<STOP S ^TMP("VAFCAUD",$J,EDITDT,IEN)=""
; ****863 MVI_2039 (cml) changes stop here
;
PRT ;Print report
S (PG,QFLG)=0,U="^",$P(LN,"-",81)="",SITE=$P($$SITE^VASITE(),U,2)
S PVAFCBDT=$$FMTE^XLFDT(VAFCBDT),PVAFCEDT=$$FMTE^XLFDT(VAFCEDT)
D NOW^%DTC S HDT=$$FMTE^XLFDT($E(%,1,12))
D HDR
I '$O(^TMP("VAFCAUD",$J,0)) W !!,"No audit data found in this date range for this patient." Q
S EDITDT=0 F S EDITDT=$O(^TMP("VAFCAUD",$J,EDITDT)) Q:QFLG Q:'EDITDT D
.S IEN=0 F S IEN=$O(^TMP("VAFCAUD",$J,EDITDT,IEN)) Q:QFLG Q:'IEN D
..S PRTDT=$$FMTE^XLFDT($E(EDITDT,1,12))
..S IEN0=^DIA(2,IEN,0)
..S FILE=2,FIELD=$P(IEN0,"^",3) I FIELD["," S FILE=+$P($G(^DD(2,$P(FIELD,","),0)),"^",2) Q:'FILE S FIELD=$P(FIELD,",",2) ;**863 MVI_2039 (cml)
..K VAFCARR1 D FIELD^DID(FILE,FIELD,"","LABEL","VAFCARR1") ;**712, **863 MVI_2039 (cml)
..S FLD=$G(VAFCARR1("LABEL")) Q:FLD=""
..S USER=$P(IEN0,U,4)
..I 'USER S USER="UNKNOWN"
..I USER'="UNKNOWN" S DIC="^VA(200,",DIC(0)="MZO",X="`"_USER D ^DIC S USER=$P(Y,"^",2)
..S OLD=$G(^DIA(2,IEN,2)) I OLD']"" S OLD="<no previous value>"
..S NEW=$G(^DIA(2,IEN,3)) I NEW']"" S NEW="<no current value>"
..K OPTDA1,OPTDA2,VAFCOPTN,OPTNM I $G(^DIA(2,IEN,4.1)) D
...S OPTDA1=+$P(^DIA(2,IEN,4.1),"^")
...I OPTDA1 S DIC=19,DR=".01",DA=OPTDA1,DIQ(0)="EI",DIQ="VAFCOPTN" D EN^DIQ1 K DIC,DR,DA,DIQ S VAFCOPTN=$G(VAFCOPTN(19,OPTDA1,.01,"E"))
...S OPTDA2=$P(^DIA(2,IEN,4.1),"^",2)
...I $P(OPTDA2,";",2)="ORD(101," S DIC=101,DR=".01",DA=+OPTDA2,DIQ(0)="EI",DIQ="VAFCOPTN" D EN^DIQ1 K DIC,DR,DA,DIQ S OPTNM=$G(VAFCOPTN(101,+OPTDA2,.01,"E")) Q
...I +OPTDA2 S DIC=19,DR=".01",DA=+OPTDA2,DIQ(0)="EI",DIQ="VAFCOPTN" D EN^DIQ1 K DIC,DR,DA,DIQ S OPTNM=$G(VAFCOPTN(19,+OPTDA2,.01,"E")) Q
..I 'RPCFLG D:$Y+4>IOSL HDR Q:QFLG
..W !,PRTDT,?20,FLD,?51,USER,!?20,OLD," / ",NEW
..I $G(VAFCOPTN)'="" W !?3,VAFCOPTN
..I $G(OPTNM)'="" W:$G(VAFCOPTN)="" !?3 W "/",$G(OPTNM)
..W !
Q
;
QUIT ;
I '$G(RPCFLG),$E(IOST,1,2)="C-"&('$G(QFLG)) S DIR(0)="E" D D ^DIR K DIR
.S SS=22-$Y F JJ=1:1:SS W !
I '$G(RPCFLG) D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
K ^TMP("VAFCAUD",$J)
K %,%I,C,VAFCDFN,EDITDT,FLD,HDT,IEN,IEN0,JJ,LN,NEW,OLD,OPTDA1,OPTDA2,VAFCOPTN,OPTNM,PG,PVAFCBDT,PVAFCEDT,PRTDT,POP
K QFLG,VAFCARR1,VAFCBDT,VAFCEDT,RPCFLG,SITE,SS,STOP,USER,X,Y,ZTSK
K SUB,FILE,FIELD,QQ,DFNMULT,EARLY,EARLYDT,EARLYM,GOT,PTNM ;**712, **863 MVI_2039 (cml)
Q
;
HDR ;HEADER
I 'RPCFLG I $E(IOST,1,2)="C-" S SS=22-$Y F JJ=1:1:SS W !
I 'RPCFLG I $E(IOST,1,2)="C-",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q
S PG=PG+1
I 'RPCFLG W:$Y!($E(IOST,1,2)="C-") @IOF
W !,"PATIENT AUDIT LIST at ",SITE," on ",HDT,?70,"Page: ",PG
W !,"Patient: ",$P(^DPT(VAFCDFN,0),U)," (DFN #",VAFCDFN,")"
W !,"Date Range: ",PVAFCBDT," to ",PVAFCEDT
W !!,"Date/Time Edited",?20,"Field Edited",?51,"Edited By"
W !?20,"Old Value / New Value",!?3,"Option/Protocol",!,LN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFCAUD 6236 printed Sep 23, 2025@20:37:26 Page 2
VAFCAUD ;BIR/CML-MPI/PD AUDIT FILE PRINT FOR A SPECIFIED PATIENT ;20 May 2013 2:25 PM
+1 ;;5.3;Registration;**477,712,863**;Aug 13, 1993;Build 2
+2 ;Reference to ^DIA(2 and data derived from the AUDIT file (#1.1)
+3 ;is supported by IA #2097 and #2602.
+4 ;Reference to ^ORD(101 supported by IA #2596
+5 SET QFLG=1
+6 ;is this from an rpc call
SET RPCFLG=0
BEGIN ;
+1 WRITE !!,"This option prints information from the AUDIT file (#1.1) for a"
+2 WRITE !,"selected patient and date range."
+3 WRITE !!,"For the PATIENT file (#2) entry selected, the report prints the"
+4 WRITE !,"patient name and DFN, date/time the field was edited, the user who"
+5 WRITE !,"made the change, the field edited, the old value, and the new value."
+6 WRITE !,"The option or protocol (if available) will also be displayed."
+7 DO ASK1
+8 IF $GET(VAFCDFN)
DO ASK2
+9 IF $GET(VAFCBDT)
IF $GET(VAFCEDT)
DO DEV
+10 GOTO QUIT
+11 ;
ASK1 ;Ask for PATIENT
+1 WRITE !
+2 SET DIC="^DPT("
SET DIC(0)="QEAM"
SET DIC("A")="Select PATIENT: "
DO ^DIC
KILL DIC
if Y<0
QUIT
SET VAFCDFN=+Y
+3 ;
DSP ;Display if audit data is available - **863 MVI_2039 (cml) new subroutine added to pick up audit data for multiple subfields
+1 SET (GOT,EARLY,EARLYM)=0
SET EARLYDT=""
+2 SET PTNM=$PIECE(^DPT(VAFCDFN,0),"^")
+3 ;check top level audits
+4 SET IEN=0
FOR
SET IEN=$ORDER(^DIA(2,"B",VAFCDFN,IEN))
if 'IEN
QUIT
Begin DoDot:1
+5 IF $DATA(^DIA(2,IEN,0))
SET EDITDT=$PIECE(^(0),"^",2)
SET GOT=1
if EARLY=0
SET EARLY=EDITDT
if EDITDT<EARLY
SET EARLY=EDITDT
End DoDot:1
+6 ;check multiple level
+7 SET DFNMULT=VAFCDFN_",0"
FOR
SET DFNMULT=$ORDER(^DIA(2,"B",DFNMULT))
if DFNMULT=""
QUIT
if $PIECE(DFNMULT,",")'=VAFCDFN
QUIT
IF $DATA(^DIA(2,"B",DFNMULT))
Begin DoDot:1
+8 SET IEN=0
FOR
SET IEN=$ORDER(^DIA(2,"B",DFNMULT,IEN))
if 'IEN
QUIT
IF $DATA(^DIA(2,IEN,0))
SET EDITDT=$PIECE(^(0),"^",2)
SET GOT=1
if EARLYM=0
SET EARLYM=EDITDT
if EDITDT<EARLYM
SET EARLYM=EDITDT
End DoDot:1
+9 ;
+10 IF 'GOT
WRITE !!,"There is no audit data available for any date for ",PTNM,"."
GOTO ASK1
+11 IF EARLYM=0
IF EARLY>0
SET EARLYDT=EARLY
+12 IF EARLY=0
IF EARLYM>0
SET EARLYDT=EARLYM
+13 IF EARLY>0
IF EARLYM>EARLY
SET EARLYDT=EARLY
+14 IF EARLYM>0
IF EARLY>EARLYM
SET EARLYDT=EARLYM
+15 WRITE !!,"The earliest audit data is "_$$FMTE^XLFDT(EARLYDT)_"."
+16 QUIT
+17 ;
ASK2 ;Ask for Date Range
+1 ;I '$D(VAFCDFN)&($D(DFN)) S VAFCDFN=DFN
+2 WRITE !!,"Enter date range for data to be included in report."
+3 KILL DIR,DIRUT,DTOUT,DUOUT
+4 SET DIR(0)="DAO^:DT:EPX"
SET DIR("A")="Beginning Date: "
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
SET VAFCBDT=Y
+5 SET DIR(0)="DAO^"_VAFCBDT_":DT:EPX"
SET DIR("A")="Ending Date: "
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
SET VAFCEDT=Y
+6 QUIT
+7 ;
DEV WRITE !!,"The right margin for this report is 80.",!!
+1 SET ZTSAVE("VAFCBDT")=""
SET ZTSAVE("VAFCEDT")=""
SET ZTSAVE("VAFCDFN")=""
+2 DO EN^XUTMDEVQ("START^VAFCAUD(VAFCDFN,VAFCBDT,VAFCEDT,RPCFLG)","MPI/PD - Print AUDIT File Data for a Specific Patient",.ZTSAVE)
IF 'POP
QUIT
+3 WRITE !,"NO DEVICE SELECTED OR REPORT PRINTED!!"
+4 GOTO QUIT
+5 ;
START(VAFCDFN,VAFCBDT,VAFCEDT,RPCFLG) ;
+1 NEW IEN
+2 KILL ^TMP("VAFCAUD",$JOB)
+3 ;
LOOP ;Loop on "B" xref of the AUDIT file
+1 SET STOP=VAFCEDT+1
+2 SET IEN=0
FOR
SET IEN=$ORDER(^DIA(2,"B",VAFCDFN,IEN))
if 'IEN
QUIT
Begin DoDot:1
+3 IF $DATA(^DIA(2,IEN,0))
SET EDITDT=$PIECE(^(0),U,2)
IF EDITDT>VAFCBDT
IF EDITDT<STOP
Begin DoDot:2
+4 SET ^TMP("VAFCAUD",$JOB,EDITDT,IEN)=""
End DoDot:2
End DoDot:1
+5 ;
+6 ;find any audit data for audited fields that are multiples - **863 MVI_2039 (cml)
+7 SET DFNMULT=VAFCDFN_",0"
FOR
SET DFNMULT=$ORDER(^DIA(2,"B",DFNMULT))
if DFNMULT=""
QUIT
if $PIECE(DFNMULT,",")'=VAFCDFN
QUIT
IF $DATA(^DIA(2,"B",DFNMULT))
Begin DoDot:1
+8 SET IEN=0
FOR
SET IEN=$ORDER(^DIA(2,"B",DFNMULT,IEN))
if 'IEN
QUIT
Begin DoDot:2
+9 IF $DATA(^DIA(2,IEN,0))
SET EDITDT=$PIECE(^(0),"^",2)
IF EDITDT>VAFCBDT
IF EDITDT<STOP
SET ^TMP("VAFCAUD",$JOB,EDITDT,IEN)=""
End DoDot:2
End DoDot:1
+10 ; ****863 MVI_2039 (cml) changes stop here
+11 ;
PRT ;Print report
+1 SET (PG,QFLG)=0
SET U="^"
SET $PIECE(LN,"-",81)=""
SET SITE=$PIECE($$SITE^VASITE(),U,2)
+2 SET PVAFCBDT=$$FMTE^XLFDT(VAFCBDT)
SET PVAFCEDT=$$FMTE^XLFDT(VAFCEDT)
+3 DO NOW^%DTC
SET HDT=$$FMTE^XLFDT($EXTRACT(%,1,12))
+4 DO HDR
+5 IF '$ORDER(^TMP("VAFCAUD",$JOB,0))
WRITE !!,"No audit data found in this date range for this patient."
QUIT
+6 SET EDITDT=0
FOR
SET EDITDT=$ORDER(^TMP("VAFCAUD",$JOB,EDITDT))
if QFLG
QUIT
if 'EDITDT
QUIT
Begin DoDot:1
+7 SET IEN=0
FOR
SET IEN=$ORDER(^TMP("VAFCAUD",$JOB,EDITDT,IEN))
if QFLG
QUIT
if 'IEN
QUIT
Begin DoDot:2
+8 SET PRTDT=$$FMTE^XLFDT($EXTRACT(EDITDT,1,12))
+9 SET IEN0=^DIA(2,IEN,0)
+10 ;**863 MVI_2039 (cml)
SET FILE=2
SET FIELD=$PIECE(IEN0,"^",3)
IF FIELD[","
SET FILE=+$PIECE($GET(^DD(2,$PIECE(FIELD,","),0)),"^",2)
if 'FILE
QUIT
SET FIELD=$PIECE(FIELD,",",2)
+11 ;**712, **863 MVI_2039 (cml)
KILL VAFCARR1
DO FIELD^DID(FILE,FIELD,"","LABEL","VAFCARR1")
+12 SET FLD=$GET(VAFCARR1("LABEL"))
if FLD=""
QUIT
+13 SET USER=$PIECE(IEN0,U,4)
+14 IF 'USER
SET USER="UNKNOWN"
+15 IF USER'="UNKNOWN"
SET DIC="^VA(200,"
SET DIC(0)="MZO"
SET X="`"_USER
DO ^DIC
SET USER=$PIECE(Y,"^",2)
+16 SET OLD=$GET(^DIA(2,IEN,2))
IF OLD']""
SET OLD="<no previous value>"
+17 SET NEW=$GET(^DIA(2,IEN,3))
IF NEW']""
SET NEW="<no current value>"
+18 KILL OPTDA1,OPTDA2,VAFCOPTN,OPTNM
IF $GET(^DIA(2,IEN,4.1))
Begin DoDot:3
+19 SET OPTDA1=+$PIECE(^DIA(2,IEN,4.1),"^")
+20 IF OPTDA1
SET DIC=19
SET DR=".01"
SET DA=OPTDA1
SET DIQ(0)="EI"
SET DIQ="VAFCOPTN"
DO EN^DIQ1
KILL DIC,DR,DA,DIQ
SET VAFCOPTN=$GET(VAFCOPTN(19,OPTDA1,.01,"E"))
+21 SET OPTDA2=$PIECE(^DIA(2,IEN,4.1),"^",2)
+22 IF $PIECE(OPTDA2,";",2)="ORD(101,"
SET DIC=101
SET DR=".01"
SET DA=+OPTDA2
SET DIQ(0)="EI"
SET DIQ="VAFCOPTN"
DO EN^DIQ1
KILL DIC,DR,DA,DIQ
SET OPTNM=$GET(VAFCOPTN(101,+OPTDA2,.01,"E"))
QUIT
+23 IF +OPTDA2
SET DIC=19
SET DR=".01"
SET DA=+OPTDA2
SET DIQ(0)="EI"
SET DIQ="VAFCOPTN"
DO EN^DIQ1
KILL DIC,DR,DA,DIQ
SET OPTNM=$GET(VAFCOPTN(19,+OPTDA2,.01,"E"))
QUIT
End DoDot:3
+24 IF 'RPCFLG
if $Y+4>IOSL
DO HDR
if QFLG
QUIT
+25 WRITE !,PRTDT,?20,FLD,?51,USER,!?20,OLD," / ",NEW
+26 IF $GET(VAFCOPTN)'=""
WRITE !?3,VAFCOPTN
+27 IF $GET(OPTNM)'=""
if $GET(VAFCOPTN)=""
WRITE !?3
WRITE "/",$GET(OPTNM)
+28 WRITE !
End DoDot:2
End DoDot:1
+29 QUIT
+30 ;
QUIT ;
+1 IF '$GET(RPCFLG)
IF $EXTRACT(IOST,1,2)="C-"&('$GET(QFLG))
SET DIR(0)="E"
Begin DoDot:1
+2 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
End DoDot:1
DO ^DIR
KILL DIR
+3 IF '$GET(RPCFLG)
DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 KILL ^TMP("VAFCAUD",$JOB)
+5 KILL %,%I,C,VAFCDFN,EDITDT,FLD,HDT,IEN,IEN0,JJ,LN,NEW,OLD,OPTDA1,OPTDA2,VAFCOPTN,OPTNM,PG,PVAFCBDT,PVAFCEDT,PRTDT,POP
+6 KILL QFLG,VAFCARR1,VAFCBDT,VAFCEDT,RPCFLG,SITE,SS,STOP,USER,X,Y,ZTSK
+7 ;**712, **863 MVI_2039 (cml)
KILL SUB,FILE,FIELD,QQ,DFNMULT,EARLY,EARLYDT,EARLYM,GOT,PTNM
+8 QUIT
+9 ;
HDR ;HEADER
+1 IF 'RPCFLG
IF $EXTRACT(IOST,1,2)="C-"
SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+2 IF 'RPCFLG
IF $EXTRACT(IOST,1,2)="C-"
IF PG>0
SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
IF 'Y
SET QFLG=1
QUIT
+3 SET PG=PG+1
+4 IF 'RPCFLG
if $Y!($EXTRACT(IOST,1,2)="C-")
WRITE @IOF
+5 WRITE !,"PATIENT AUDIT LIST at ",SITE," on ",HDT,?70,"Page: ",PG
+6 WRITE !,"Patient: ",$PIECE(^DPT(VAFCDFN,0),U)," (DFN #",VAFCDFN,")"
+7 WRITE !,"Date Range: ",PVAFCBDT," to ",PVAFCEDT
+8 WRITE !!,"Date/Time Edited",?20,"Field Edited",?51,"Edited By"
+9 WRITE !?20,"Old Value / New Value",!?3,"Option/Protocol",!,LN
+10 QUIT
