RGMTAUD ;BIR/CML-MPI/PD AUDIT FILE PRINT FOR A SPECIFIED PATIENT ;20 May 2013 2:06 PM
;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,19,20,30,60**;30 Apr 99;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
;
;**60 MVI_1901 (cml) made extensive changes to accommodate the audit data for multiple subfields within the PATIENT file.
;
S QFLG=1
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."
;
ASK1 ;Ask for PATIENT
W !
S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: " D ^DIC K DIC G:Y<0 QUIT S RGDFN=+Y
;
DSP ;Display if audit data is available - **60 MVI_1901 (cml) new subroutine added to pick up audit data for multiple subfields
S (GOT,EARLY,EARLYM)=0,EARLYDT=""
S PTNM=$P(^DPT(RGDFN,0),"^")
;check top level audits
S IEN=0 F S IEN=$O(^DIA(2,"B",RGDFN,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=RGDFN_",0" F S DFNMULT=$O(^DIA(2,"B",DFNMULT)) Q:DFNMULT="" Q:$P(DFNMULT,",")'=RGDFN 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)_"."
;
ASK2 ;Ask for Date Range
I '$D(RGDFN)&($D(DFN)) S RGDFN=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 G:$D(DIRUT) QUIT
S RGBDT=Y,DIR(0)="DAO^"_RGBDT_":DT:EPX",DIR("A")="Ending Date: " D ^DIR K DIR G:$D(DIRUT) QUIT S RGEDT=Y
;
DEV W !!,"The right margin for this report is 80.",!!
S ZTSAVE("RGBDT")="",ZTSAVE("RGEDT")="",ZTSAVE("RGDFN")=""
D EN^XUTMDEVQ("START^RGMTAUD","MPI/PD - Print AUDIT File Data for a Specific Patient",.ZTSAVE) I 'POP Q
W !,"NO DEVICE SELECTED OR REPORT PRINTED!!"
G QUIT
;
START ;
K ^TMP("RGMTAUD",$J) S U="^"
;
LOOP ;Loop on "B" xref of the AUDIT file
S STOP=RGEDT+1
S IEN=0 F S IEN=$O(^DIA(2,"B",RGDFN,IEN)) Q:'IEN D
.I $D(^DIA(2,IEN,0)) S EDITDT=$P(^(0),U,2) I EDITDT>RGBDT,EDITDT<STOP D
..S ^TMP("RGMTAUD",$J,EDITDT,IEN)=""
;
;find any audit data for audited fields that are multiples - **60 MVI_1901 (cml)
S DFNMULT=RGDFN_",0" F S DFNMULT=$O(^DIA(2,"B",DFNMULT)) Q:DFNMULT="" Q:$P(DFNMULT,",")'=RGDFN 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>RGBDT,EDITDT<STOP S ^TMP("RGMTAUD",$J,EDITDT,IEN)=""
; **60 MVI_1901 (cml) changes stop here
;
PRT ;Print report
S (PG,QFLG)=0,U="^",$P(LN,"-",81)="",SITE=$P($$SITE^VASITE(),U,2)
S PRGBDT=$$FMTE^XLFDT(RGBDT),PRGEDT=$$FMTE^XLFDT(RGEDT)
D NOW^%DTC S HDT=$$FMTE^XLFDT($E(%,1,12))
D HDR
I '$O(^TMP("RGMTAUD",$J,0)) W !!,"No audit data found in this date range for this patient." G QUIT
S EDITDT=0 F S EDITDT=$O(^TMP("RGMTAUD",$J,EDITDT)) Q:QFLG Q:'EDITDT D
.S IEN=0 F S IEN=$O(^TMP("RGMTAUD",$J,EDITDT,IEN)) Q:QFLG Q:'IEN D
..S PRTDT=$$FMTE^XLFDT($E(EDITDT,1,12))
..S IEN0=^DIA(2,IEN,0)
.. ;**60 MVI_1901 (cml) modified to pick up audit data for multiple subfields and check for bad DD references
..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)
..K RGARR D FIELD^DID(FILE,FIELD,"","LABEL","RGARR")
..S FLD=$G(RGARR("LABEL")) Q:FLD=""
.. ; **60 MVI_1901 (cml) changes stop here
..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,RGOPTN,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="RGOPTN" D EN^DIQ1 K DIC,DR,DA,DIQ S RGOPTN=$G(RGOPTN(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="RGOPTN" D EN^DIQ1 K DIC,DR,DA,DIQ S OPTNM=$G(RGOPTN(101,+OPTDA2,.01,"E")) Q
...I +OPTDA2 S DIC=19,DR=".01",DA=+OPTDA2,DIQ(0)="EI",DIQ="RGOPTN" D EN^DIQ1 K DIC,DR,DA,DIQ S OPTNM=$G(RGOPTN(19,+OPTDA2,.01,"E")) Q
..D:$Y+4>IOSL HDR Q:QFLG W !!,PRTDT,?20,FLD,?51,USER,!?20,OLD," / ",NEW
..I $G(RGOPTN)'="" W !?3,RGOPTN ;**20
..I $G(OPTNM)'="" W:$G(RGOPTN)="" !?3 W "/",$G(OPTNM) ;**20
;
QUIT ;
I $E(IOST,1,2)="C-"&('QFLG) S DIR(0)="E" D D ^DIR K DIR
.S SS=22-$Y F JJ=1:1:SS W !
K ^TMP("RGMTAUD",$J)
K %,%I,DFN,RGDFN,EDITDT,FLD,HDT,IEN,IEN0,JJ,LN,NEW,OLD,OPTDA1,OPTDA2,RGOPTN,OPTNM,PG,PRGBDT,PRGEDT,PRTDT
K DFNMULT,EARLY,EARLYDT,EARLYM,FIELD,FILE,GOT,PTNM,QQ,SUB ;**60 MVI_1901 (cml)
K QFLG,RGARR,RGBDT,RGEDT,SITE,SS,STOP,USER,X,Y,ZTSK
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" Q
;
HDR ;HEADER
I $E(IOST,1,2)="C-" S SS=22-$Y F JJ=1:1:SS W !
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 W:$Y!($E(IOST,1,2)="C-") @IOF
W !,"PATIENT AUDIT LIST at ",SITE," on ",HDT,?72,"Page: ",PG
W !,"Patient: ",$P(^DPT(RGDFN,0),U)," (DFN #",RGDFN,")"
W !,"Date Range: ",PRGBDT," to ",PRGEDT
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[HRGMTAUD 6115 printed Apr 09, 2024@20:47:49 Page 2
RGMTAUD ;BIR/CML-MPI/PD AUDIT FILE PRINT FOR A SPECIFIED PATIENT ;20 May 2013 2:06 PM
+1 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,19,20,30,60**;30 Apr 99;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 ;
+6 ;**60 MVI_1901 (cml) made extensive changes to accommodate the audit data for multiple subfields within the PATIENT file.
+7 ;
+8 SET QFLG=1
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 ;
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
GOTO QUIT
SET RGDFN=+Y
+3 ;
DSP ;Display if audit data is available - **60 MVI_1901 (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(RGDFN,0),"^")
+3 ;check top level audits
+4 SET IEN=0
FOR
SET IEN=$ORDER(^DIA(2,"B",RGDFN,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=RGDFN_",0"
FOR
SET DFNMULT=$ORDER(^DIA(2,"B",DFNMULT))
if DFNMULT=""
QUIT
if $PIECE(DFNMULT,",")'=RGDFN
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 ;
ASK2 ;Ask for Date Range
+1 IF '$DATA(RGDFN)&($DATA(DFN))
SET RGDFN=DFN
+2 WRITE !!,"Enter date range for data to be included in report."
+3 KILL DIR,DIRUT,DTOUT,DUOUT
SET DIR(0)="DAO^:DT:EPX"
SET DIR("A")="Beginning Date: "
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO QUIT
+4 SET RGBDT=Y
SET DIR(0)="DAO^"_RGBDT_":DT:EPX"
SET DIR("A")="Ending Date: "
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO QUIT
SET RGEDT=Y
+5 ;
DEV WRITE !!,"The right margin for this report is 80.",!!
+1 SET ZTSAVE("RGBDT")=""
SET ZTSAVE("RGEDT")=""
SET ZTSAVE("RGDFN")=""
+2 DO EN^XUTMDEVQ("START^RGMTAUD","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 ;
+1 KILL ^TMP("RGMTAUD",$JOB)
SET U="^"
+2 ;
LOOP ;Loop on "B" xref of the AUDIT file
+1 SET STOP=RGEDT+1
+2 SET IEN=0
FOR
SET IEN=$ORDER(^DIA(2,"B",RGDFN,IEN))
if 'IEN
QUIT
Begin DoDot:1
+3 IF $DATA(^DIA(2,IEN,0))
SET EDITDT=$PIECE(^(0),U,2)
IF EDITDT>RGBDT
IF EDITDT<STOP
Begin DoDot:2
+4 SET ^TMP("RGMTAUD",$JOB,EDITDT,IEN)=""
End DoDot:2
End DoDot:1
+5 ;
+6 ;find any audit data for audited fields that are multiples - **60 MVI_1901 (cml)
+7 SET DFNMULT=RGDFN_",0"
FOR
SET DFNMULT=$ORDER(^DIA(2,"B",DFNMULT))
if DFNMULT=""
QUIT
if $PIECE(DFNMULT,",")'=RGDFN
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>RGBDT
IF EDITDT<STOP
SET ^TMP("RGMTAUD",$JOB,EDITDT,IEN)=""
End DoDot:2
End DoDot:1
+10 ; **60 MVI_1901 (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 PRGBDT=$$FMTE^XLFDT(RGBDT)
SET PRGEDT=$$FMTE^XLFDT(RGEDT)
+3 DO NOW^%DTC
SET HDT=$$FMTE^XLFDT($EXTRACT(%,1,12))
+4 DO HDR
+5 IF '$ORDER(^TMP("RGMTAUD",$JOB,0))
WRITE !!,"No audit data found in this date range for this patient."
GOTO QUIT
+6 SET EDITDT=0
FOR
SET EDITDT=$ORDER(^TMP("RGMTAUD",$JOB,EDITDT))
if QFLG
QUIT
if 'EDITDT
QUIT
Begin DoDot:1
+7 SET IEN=0
FOR
SET IEN=$ORDER(^TMP("RGMTAUD",$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 ;**60 MVI_1901 (cml) modified to pick up audit data for multiple subfields and check for bad DD references
+11 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)
+12 KILL RGARR
DO FIELD^DID(FILE,FIELD,"","LABEL","RGARR")
+13 SET FLD=$GET(RGARR("LABEL"))
if FLD=""
QUIT
+14 ; **60 MVI_1901 (cml) changes stop here
+15 SET USER=$PIECE(IEN0,U,4)
+16 IF 'USER
SET USER="UNKNOWN"
+17 IF USER'="UNKNOWN"
SET DIC="^VA(200,"
SET DIC(0)="MZO"
SET X="`"_USER
DO ^DIC
SET USER=$PIECE(Y,"^",2)
+18 SET OLD=$GET(^DIA(2,IEN,2))
IF OLD']""
SET OLD="<no previous value>"
+19 SET NEW=$GET(^DIA(2,IEN,3))
IF NEW']""
SET NEW="<no current value>"
+20 KILL OPTDA1,OPTDA2,RGOPTN,OPTNM
IF $GET(^DIA(2,IEN,4.1))
Begin DoDot:3
+21 SET OPTDA1=+$PIECE(^DIA(2,IEN,4.1),"^")
+22 IF OPTDA1
SET DIC=19
SET DR=".01"
SET DA=OPTDA1
SET DIQ(0)="EI"
SET DIQ="RGOPTN"
DO EN^DIQ1
KILL DIC,DR,DA,DIQ
SET RGOPTN=$GET(RGOPTN(19,OPTDA1,.01,"E"))
+23 SET OPTDA2=$PIECE(^DIA(2,IEN,4.1),"^",2)
+24 IF $PIECE(OPTDA2,";",2)="ORD(101,"
SET DIC=101
SET DR=".01"
SET DA=+OPTDA2
SET DIQ(0)="EI"
SET DIQ="RGOPTN"
DO EN^DIQ1
KILL DIC,DR,DA,DIQ
SET OPTNM=$GET(RGOPTN(101,+OPTDA2,.01,"E"))
QUIT
+25 IF +OPTDA2
SET DIC=19
SET DR=".01"
SET DA=+OPTDA2
SET DIQ(0)="EI"
SET DIQ="RGOPTN"
DO EN^DIQ1
KILL DIC,DR,DA,DIQ
SET OPTNM=$GET(RGOPTN(19,+OPTDA2,.01,"E"))
QUIT
End DoDot:3
+26 if $Y+4>IOSL
DO HDR
if QFLG
QUIT
WRITE !!,PRTDT,?20,FLD,?51,USER,!?20,OLD," / ",NEW
+27 ;**20
IF $GET(RGOPTN)'=""
WRITE !?3,RGOPTN
+28 ;**20
IF $GET(OPTNM)'=""
if $GET(RGOPTN)=""
WRITE !?3
WRITE "/",$GET(OPTNM)
End DoDot:2
End DoDot:1
+29 ;
QUIT ;
+1 IF $EXTRACT(IOST,1,2)="C-"&('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 KILL ^TMP("RGMTAUD",$JOB)
+4 KILL %,%I,DFN,RGDFN,EDITDT,FLD,HDT,IEN,IEN0,JJ,LN,NEW,OLD,OPTDA1,OPTDA2,RGOPTN,OPTNM,PG,PRGBDT,PRGEDT,PRTDT
+5 ;**60 MVI_1901 (cml)
KILL DFNMULT,EARLY,EARLYDT,EARLYM,FIELD,FILE,GOT,PTNM,QQ,SUB
+6 KILL QFLG,RGARR,RGBDT,RGEDT,SITE,SS,STOP,USER,X,Y,ZTSK
+7 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+8 ;
HDR ;HEADER
+1 IF $EXTRACT(IOST,1,2)="C-"
SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+2 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
if $Y!($EXTRACT(IOST,1,2)="C-")
WRITE @IOF
+4 WRITE !,"PATIENT AUDIT LIST at ",SITE," on ",HDT,?72,"Page: ",PG
+5 WRITE !,"Patient: ",$PIECE(^DPT(RGDFN,0),U)," (DFN #",RGDFN,")"
+6 WRITE !,"Date Range: ",PRGBDT," to ",PRGEDT
+7 WRITE !!,"Date/Time Edited",?20,"Field Edited",?51,"Edited By"
+8 WRITE !?20,"Old Value / New Value",!?3,"Option/Protocol",!,LN
+9 QUIT
