RGMTAUDP ;BIR/CML,PTD-MPI/PD AUDIT File Print of Patient Data ; 4/7/14 6:47pm
;;1.0;CLINICAL INFO RESOURCE NETWORK;**19,30,46,60,61**;30 Apr 99;Build 2
;Reference to ^DD(2 supported by IA #2695.
;Reference to ^DIA(2 and data derived from the AUDIT file (#1.1)
;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.
;
BEGIN ;
S QFLG=1
W @IOF
W !,"This option prints a customized report of information stored in the AUDIT"
W !,"file (#1.1) for fields being audited in the PATIENT file (#2). For a"
W !,"specified date range, you can view all audited fields or selected fields."
W !,"You can also opt to print only edits that were done by a specific user."
W !!,"- If selected fields are viewed, you can choose to see data for all or"
W !," selected patients."
W !,"- If ALL audited fields are viewed, you must choose patients to examine."
;
ASKFLD ;Ask for Data Fields
I '$O(^DD(2,"AUDIT",0)) W !!,"No fields are currently being audited in the PATIENT file (#2)." G QUIT
W !
K DIR S DIR(0)="SAM^A:ALL;S:SELECTED;"
S DIR("A")="Do you want to see (A)LL or (S)ELECTED audited fields? "
S DIR("B")="A"
S DIR("?",1)="Enter:"
S DIR("?",2)=" ""A"" to see ALL audited fields in the PATIENT file (#2)."
S DIR("?")=" ""S"" to select specific audited fields."
D ^DIR G:$D(DIRUT) QUIT S ANS1=Y
;
FLDLOOP ;
W ! K FLD
;stuff all fields
I ANS1="A" D G ASKPAT
.S FLD=0 F S FLD=$O(^DD(2,"AUDIT",FLD)) Q:'FLD S FLD(2,FLD)="" ;**60 MVI_1901 (cml)
.S FILE=2 F S FILE=$O(^DD(FILE)) Q:FILE>2.999 S FLD=0 F S FLD=$O(^DD(FILE,"AUDIT",FLD)) Q:'FLD S FLD(FILE,FLD)="" ;**60 MVI_1901 (cml)
;
;ask for specific fields
S RGERR=0 D FLDLIST
; **60 MVI_1901 (cml)changes start here
K DIR W !
S DIR(0)="NAO^1:"_MAX_":0^K:'$D(FLDCNT(X)) X S RGERR=1" S DIR("A")="Select list number 1-"_MAX_": "
S DIR("?")="^D FLDLIST^RGMTAUDP"
F QQ=0:0 S RGERR=0 D ^DIR Q:$D(DIRUT) S SEL(+Y)=""
S CNT=0 F S CNT=$O(SEL(CNT)) Q:'CNT S FILE=$O(FLDCNT(CNT,0)),FLDLP=$O(FLDCNT(CNT,FILE,0)),FLD(FILE,FLDLP)=""
; **60 MVI_1901 (cml) changes stop here
;
ASKPAT ;Ask for Patient
I '$O(FLD(0))!($D(DUOUT)) S QFLG=1 G QUIT
I ANS1="A" S ANS2="S" G PATLOOP
K DIR S DIR(0)="SAM^A:ALL;S:SELECTED;"
S DIR("A")="Do you want to see audited data for (A)LL or (S)ELECTED patients? "
S DIR("B")="S"
S DIR("?",1)="Enter:"
S DIR("?",2)=" ""A"" to see audited fields for ALL patients."
S DIR("?")=" ""S"" to select specific patients(s)."
W ! D ^DIR G:$D(DIRUT) QUIT S ANS2=Y
PATLOOP ;
W ! K PAT
I ANS2="A" S PAT("ALL")="" G ASKDT
;ask for specific patient(s)
F QQ=0:0 S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: " D ^DIC K DIC Q:Y<0 S RGDFN=+Y D
.I '$O(^DIA(2,"B",RGDFN,0)) W $C(7),!?5,"This patient has no audit data available for any date." Q
.S PAT(RGDFN)=""
;
ASKDT ;Ask for Date Range
I '$D(PAT)!($D(DUOUT)) S QFLG=1 G QUIT
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
;
ASKUSER ;Ask if data is wanted only a specific user
K USERSCRN
W ! S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you want to find only the edits made by a specific user"
D ^DIR K DIR I +Y'=1 G DEV
;
S DIC="^VA(200,",DIC(0)="QEAM",DIC("A")="Select USER: "
D ^DIC K DIC G:+Y<0 QUIT S USERSCRN=+Y
;
DEV W !!,"The right margin for this report is 80.",!!
I ANS2="A" S IOP="Q" W "Because you selected ALL patients, you MUST queue this report.",!!
S ZTSAVE("RGBDT")="",ZTSAVE("RGEDT")="",ZTSAVE("ANS2")="",ZTSAVE("FLD(")="",ZTSAVE("PAT(")="",%ZIS("B")=""
S ZTSAVE("USERSCRN")=""
D EN^XUTMDEVQ("START^RGMTAUDP","MPI/PD - Print AUDIT File Data from the PATIENT file",.ZTSAVE,.%ZIS) I 'POP Q
W !,"NO DEVICE SELECTED OR REPORT PRINTED!!"
S QFLG=1 G QUIT
;
START ;
K ^TMP("RGMTAUDP",$J),^TMP("RGMTAUDP2",$J) S U="^"
S STOP=RGEDT+1
I ANS2="A" D
.S CNT=0
.S RGDFN=0 F S RGDFN=$O(^DIA(2,"B",RGDFN)) Q:'RGDFN S CNT=CNT+1 S:'(CNT#10000) ^TMP("RGMTAUDP",$J,"@@@@","CUR DFN")=RGDFN D LOOP
I ANS2="S" D
.S RGDFN=0 F S RGDFN=$O(PAT(RGDFN)) Q:'RGDFN D LOOP
G PRT
;
LOOP ;Loop on "B" xref of the AUDIT file
Q:'$D(^DPT(RGDFN,0))
;I ANS2="S" D
;. S PATNM=$P(^DPT(RGDFN,0),U)_U_RGDFN
;**61 - MVI_3413 (ckn)
;Remedy ticket 946297 - Undefined error issue
S PATNM=$P(^DPT(RGDFN,0),U)_U_RGDFN
I $P(PATNM,U)="" Q
S IEN=0 F S IEN=$O(^DIA(2,"B",RGDFN,IEN)) Q:'IEN D
.I $D(^DIA(2,IEN,0)) S IEN0=(^(0)),EDITDT=$P(IEN0,U,2) I EDITDT>RGBDT,EDITDT<STOP D
..S FLD=$P(IEN0,U,3) I $D(FLD(2,FLD)) D
...S USER=$P(IEN0,U,4)
...I $D(USERSCRN) I USER'=USERSCRN Q
...S ^TMP("RGMTAUDP",$J,PATNM,EDITDT,IEN)=""
;
;add new FOR loop to 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)) S IEN=0 F S IEN=$O(^DIA(2,"B",DFNMULT,IEN)) Q:'IEN D
.I $D(^DIA(2,IEN,0)) S IEN0=(^(0)),EDITDT=$P(^(0),U,2) I EDITDT>RGBDT,EDITDT<STOP D
..S FLD=$P(IEN0,U,3),PC1=$P(FLD,","),PC2=$P(FLD,",",2),FILE=+$P($G(^DD(2,PC1,0)),"^",2) I FILE,$D(FLD(FILE,PC2)) D
...S USER=$P(IEN0,U,4)
...I $D(USERSCRN) I USER'=USERSCRN Q
...S PATNM=$P(^DPT(RGDFN,0),U)_U_RGDFN,^TMP("RGMTAUDP",$J,PATNM,EDITDT,IEN)=""
;
I ANS2="S" D
. I '$D(^TMP("RGMTAUDP",$J,PATNM)) S ^TMP("RGMTAUDP2",$J,"NO AUDIT",PATNM)=" has no audit data available for selected parameters."
Q
;
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 '$D(^TMP("RGMTAUDP",$J)) W !!,"No audit data found in this date range for specified parameters." G QUIT
S PATNM="@@@@" F S PATNM=$O(^TMP("RGMTAUDP",$J,PATNM)) Q:PATNM="" Q:QFLG D
.D:$Y+4>IOSL HDR Q:QFLG
.W !!,"==> ",$P(PATNM,U)," (DFN #",$P(PATNM,U,2),")"
.S EDITDT=0 F S EDITDT=$O(^TMP("RGMTAUDP",$J,PATNM,EDITDT)) Q:QFLG Q:'EDITDT D
..S IEN=0 F S IEN=$O(^TMP("RGMTAUDP",$J,PATNM,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,OPTION,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="OPTION" D EN^DIQ1 K DIC,DR,DA,DIQ S OPTION=$G(OPTION(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="OPTION" D EN^DIQ1 K DIC,DR,DA,DIQ S OPTNM=$G(OPTION(101,+OPTDA2,.01,"E")) Q
....I +OPTDA2 S DIC=19,DR=".01",DA=+OPTDA2,DIQ(0)="EI",DIQ="OPTION" D EN^DIQ1 K DIC,DR,DA,DIQ S OPTNM=$G(OPTION(19,+OPTDA2,.01,"E")) Q
...D:$Y+5>IOSL HDR Q:QFLG W !!,PRTDT,?20,FLD,?51,USER,!?20,OLD," / ",NEW
...I $G(OPTION)'="" W !?3,OPTION I $G(OPTNM)'="" W "/",OPTNM
I $D(^TMP("RGMTAUDP2",$J,"NO AUDIT")) D
. S PATNM="@@@@",RGNAUD="" F S PATNM=$O(^TMP("RGMTAUDP2",$J,"NO AUDIT",PATNM)) Q:PATNM="" D
.. Q:QFLG
.. S RGNAUD=$P(^TMP("RGMTAUDP2",$J,"NO AUDIT",PATNM),U)
.. W !!,"==> ",$P(PATNM,U)," (DFN #",$P(PATNM,U,2),")"_RGNAUD
;
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("RGMTAUDP",$J),^TMP("RGMTAUDP2",$J)
K %,%I,ANS1,ANS2,CNT,RGDFN,DIR,DIRUT,DTOUT,DUOUT,EDITDT,FLD,FLDLP,FLDNM,HDR,DFNMULT,FIELD,FILE,SUB,MAX,PC1,PC2,SEL ;**60 MVI_1901 (cml)
K HDT,IEN,IEN0,JJ,LN,NEW,OLD,OPTDA1,OPTDA2,OPTION,OPTNM,PAT,PATNM,PG,PRGBDT,PRGEDT,PRTDT,QFLG,QQ,RGARR,RGBDT,RGNAUD
K RGEDT,RGERR,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 !,"Date Range: ",PRGBDT," to ",PRGEDT
W !!,"Date/Time Edited",?20,"Field Edited",?51,"Edited By",!?20,"Old Value / New Value"
W !?3,"Option/Protocol",!,LN
Q
;
FLDLIST ;Help for Field # List
K RG N DIR S QFLG=0 I RGERR W $C(7)," ??"
S HDR="Select a LIST NUMBER from the audited field(s) in the PATIENT file:"
W @IOF,HDR,!
;
; **60 MVI_1901 (cml)changes start here
K FLD,FLDCNT
S FLD=0 F S FLD=$O(^DD(2,"AUDIT",FLD)) Q:'FLD S FLD(2,FLD)=""
S FILE=2 F S FILE=$O(^DD(FILE)) Q:FILE>2.999 Q:'FILE S FLD=0 F S FLD=$O(^DD(FILE,"AUDIT",FLD)) Q:'FLD S FLD(FILE,FLD)=""
I '$D(FLD) W !!,"No fields are currently being audited in the Patient file." Q
; set up counter array
S (CNT,FILE)=0 F S FILE=$O(FLD(FILE)) Q:'FILE S FLDLP=0 F S FLDLP=$O(FLD(FILE,FLDLP)) Q:'FLDLP S CNT=CNT+1,FLDCNT(CNT,FILE,FLDLP)=""
K FLD S MAX=CNT
;
S CNT=0 F S CNT=$O(FLDCNT(CNT)) Q:'CNT S FILE=0 F S FILE=$O(FLDCNT(CNT,FILE)) Q:'FILE S FLDLP=0 F S FLDLP=$O(FLDCNT(CNT,FILE,FLDLP)) Q:'FLDLP Q:QFLG D
. ; **60 MVI_1901 (cml) changes stop here
.I $Y+6>IOSL D Q:QFLG
..S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q
..E W @IOF,HDR,!
.K RGARR D FIELD^DID(FILE,FLDLP,"","LABEL","RGARR")
.S FLDNM=$G(RGARR("LABEL")) Q:FLDNM=""
.W !,CNT,". ",FILE,",",FLDLP,?17,FLDNM ;**60 MVI_1901 (cml)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGMTAUDP 10164 printed Nov 22, 2024@16:52:27 Page 2
RGMTAUDP ;BIR/CML,PTD-MPI/PD AUDIT File Print of Patient Data ; 4/7/14 6:47pm
+1 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**19,30,46,60,61**;30 Apr 99;Build 2
+2 ;Reference to ^DD(2 supported by IA #2695.
+3 ;Reference to ^DIA(2 and data derived from the AUDIT file (#1.1)
+4 ;supported by IA #2097 and #2602.
+5 ;Reference to ^ORD(101 supported by IA #2596
+6 ;**60 MVI_1901 (cml) made extensive changes to accommodate the audit data for multiple subfields within the PATIENT file.
+7 ;
BEGIN ;
+1 SET QFLG=1
+2 WRITE @IOF
+3 WRITE !,"This option prints a customized report of information stored in the AUDIT"
+4 WRITE !,"file (#1.1) for fields being audited in the PATIENT file (#2). For a"
+5 WRITE !,"specified date range, you can view all audited fields or selected fields."
+6 WRITE !,"You can also opt to print only edits that were done by a specific user."
+7 WRITE !!,"- If selected fields are viewed, you can choose to see data for all or"
+8 WRITE !," selected patients."
+9 WRITE !,"- If ALL audited fields are viewed, you must choose patients to examine."
+10 ;
ASKFLD ;Ask for Data Fields
+1 IF '$ORDER(^DD(2,"AUDIT",0))
WRITE !!,"No fields are currently being audited in the PATIENT file (#2)."
GOTO QUIT
+2 WRITE !
+3 KILL DIR
SET DIR(0)="SAM^A:ALL;S:SELECTED;"
+4 SET DIR("A")="Do you want to see (A)LL or (S)ELECTED audited fields? "
+5 SET DIR("B")="A"
+6 SET DIR("?",1)="Enter:"
+7 SET DIR("?",2)=" ""A"" to see ALL audited fields in the PATIENT file (#2)."
+8 SET DIR("?")=" ""S"" to select specific audited fields."
+9 DO ^DIR
if $DATA(DIRUT)
GOTO QUIT
SET ANS1=Y
+10 ;
FLDLOOP ;
+1 WRITE !
KILL FLD
+2 ;stuff all fields
+3 IF ANS1="A"
Begin DoDot:1
+4 ;**60 MVI_1901 (cml)
SET FLD=0
FOR
SET FLD=$ORDER(^DD(2,"AUDIT",FLD))
if 'FLD
QUIT
SET FLD(2,FLD)=""
+5 ;**60 MVI_1901 (cml)
SET FILE=2
FOR
SET FILE=$ORDER(^DD(FILE))
if FILE>2.999
QUIT
SET FLD=0
FOR
SET FLD=$ORDER(^DD(FILE,"AUDIT",FLD))
if 'FLD
QUIT
SET FLD(FILE,FLD)=""
End DoDot:1
GOTO ASKPAT
+6 ;
+7 ;ask for specific fields
+8 SET RGERR=0
DO FLDLIST
+9 ; **60 MVI_1901 (cml)changes start here
+10 KILL DIR
WRITE !
+11 SET DIR(0)="NAO^1:"_MAX_":0^K:'$D(FLDCNT(X)) X S RGERR=1"
SET DIR("A")="Select list number 1-"_MAX_": "
+12 SET DIR("?")="^D FLDLIST^RGMTAUDP"
+13 FOR QQ=0:0
SET RGERR=0
DO ^DIR
if $DATA(DIRUT)
QUIT
SET SEL(+Y)=""
+14 SET CNT=0
FOR
SET CNT=$ORDER(SEL(CNT))
if 'CNT
QUIT
SET FILE=$ORDER(FLDCNT(CNT,0))
SET FLDLP=$ORDER(FLDCNT(CNT,FILE,0))
SET FLD(FILE,FLDLP)=""
+15 ; **60 MVI_1901 (cml) changes stop here
+16 ;
ASKPAT ;Ask for Patient
+1 IF '$ORDER(FLD(0))!($DATA(DUOUT))
SET QFLG=1
GOTO QUIT
+2 IF ANS1="A"
SET ANS2="S"
GOTO PATLOOP
+3 KILL DIR
SET DIR(0)="SAM^A:ALL;S:SELECTED;"
+4 SET DIR("A")="Do you want to see audited data for (A)LL or (S)ELECTED patients? "
+5 SET DIR("B")="S"
+6 SET DIR("?",1)="Enter:"
+7 SET DIR("?",2)=" ""A"" to see audited fields for ALL patients."
+8 SET DIR("?")=" ""S"" to select specific patients(s)."
+9 WRITE !
DO ^DIR
if $DATA(DIRUT)
GOTO QUIT
SET ANS2=Y
PATLOOP ;
+1 WRITE !
KILL PAT
+2 IF ANS2="A"
SET PAT("ALL")=""
GOTO ASKDT
+3 ;ask for specific patient(s)
+4 FOR QQ=0:0
SET DIC="^DPT("
SET DIC(0)="QEAM"
SET DIC("A")="Select PATIENT: "
DO ^DIC
KILL DIC
if Y<0
QUIT
SET RGDFN=+Y
Begin DoDot:1
+5 IF '$ORDER(^DIA(2,"B",RGDFN,0))
WRITE $CHAR(7),!?5,"This patient has no audit data available for any date."
QUIT
+6 SET PAT(RGDFN)=""
End DoDot:1
+7 ;
ASKDT ;Ask for Date Range
+1 IF '$DATA(PAT)!($DATA(DUOUT))
SET QFLG=1
GOTO QUIT
+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 ;
ASKUSER ;Ask if data is wanted only a specific user
+1 KILL USERSCRN
+2 WRITE !
SET DIR(0)="Y"
SET DIR("B")="No"
SET DIR("A")="Do you want to find only the edits made by a specific user"
+3 DO ^DIR
KILL DIR
IF +Y'=1
GOTO DEV
+4 ;
+5 SET DIC="^VA(200,"
SET DIC(0)="QEAM"
SET DIC("A")="Select USER: "
+6 DO ^DIC
KILL DIC
if +Y<0
GOTO QUIT
SET USERSCRN=+Y
+7 ;
DEV WRITE !!,"The right margin for this report is 80.",!!
+1 IF ANS2="A"
SET IOP="Q"
WRITE "Because you selected ALL patients, you MUST queue this report.",!!
+2 SET ZTSAVE("RGBDT")=""
SET ZTSAVE("RGEDT")=""
SET ZTSAVE("ANS2")=""
SET ZTSAVE("FLD(")=""
SET ZTSAVE("PAT(")=""
SET %ZIS("B")=""
+3 SET ZTSAVE("USERSCRN")=""
+4 DO EN^XUTMDEVQ("START^RGMTAUDP","MPI/PD - Print AUDIT File Data from the PATIENT file",.ZTSAVE,.%ZIS)
IF 'POP
QUIT
+5 WRITE !,"NO DEVICE SELECTED OR REPORT PRINTED!!"
+6 SET QFLG=1
GOTO QUIT
+7 ;
START ;
+1 KILL ^TMP("RGMTAUDP",$JOB),^TMP("RGMTAUDP2",$JOB)
SET U="^"
+2 SET STOP=RGEDT+1
+3 IF ANS2="A"
Begin DoDot:1
+4 SET CNT=0
+5 SET RGDFN=0
FOR
SET RGDFN=$ORDER(^DIA(2,"B",RGDFN))
if 'RGDFN
QUIT
SET CNT=CNT+1
if '(CNT#10000)
SET ^TMP("RGMTAUDP",$JOB,"@@@@","CUR DFN")=RGDFN
DO LOOP
End DoDot:1
+6 IF ANS2="S"
Begin DoDot:1
+7 SET RGDFN=0
FOR
SET RGDFN=$ORDER(PAT(RGDFN))
if 'RGDFN
QUIT
DO LOOP
End DoDot:1
+8 GOTO PRT
+9 ;
LOOP ;Loop on "B" xref of the AUDIT file
+1 if '$DATA(^DPT(RGDFN,0))
QUIT
+2 ;I ANS2="S" D
+3 ;. S PATNM=$P(^DPT(RGDFN,0),U)_U_RGDFN
+4 ;**61 - MVI_3413 (ckn)
+5 ;Remedy ticket 946297 - Undefined error issue
+6 SET PATNM=$PIECE(^DPT(RGDFN,0),U)_U_RGDFN
+7 IF $PIECE(PATNM,U)=""
QUIT
+8 SET IEN=0
FOR
SET IEN=$ORDER(^DIA(2,"B",RGDFN,IEN))
if 'IEN
QUIT
Begin DoDot:1
+9 IF $DATA(^DIA(2,IEN,0))
SET IEN0=(^(0))
SET EDITDT=$PIECE(IEN0,U,2)
IF EDITDT>RGBDT
IF EDITDT<STOP
Begin DoDot:2
+10 SET FLD=$PIECE(IEN0,U,3)
IF $DATA(FLD(2,FLD))
Begin DoDot:3
+11 SET USER=$PIECE(IEN0,U,4)
+12 IF $DATA(USERSCRN)
IF USER'=USERSCRN
QUIT
+13 SET ^TMP("RGMTAUDP",$JOB,PATNM,EDITDT,IEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+14 ;
+15 ;add new FOR loop to find any audit data for audited fields that are multiples - **60 MVI_1901 (cml)
+16 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))
SET IEN=0
FOR
SET IEN=$ORDER(^DIA(2,"B",DFNMULT,IEN))
if 'IEN
QUIT
Begin DoDot:1
+17 IF $DATA(^DIA(2,IEN,0))
SET IEN0=(^(0))
SET EDITDT=$PIECE(^(0),U,2)
IF EDITDT>RGBDT
IF EDITDT<STOP
Begin DoDot:2
+18 SET FLD=$PIECE(IEN0,U,3)
SET PC1=$PIECE(FLD,",")
SET PC2=$PIECE(FLD,",",2)
SET FILE=+$PIECE($GET(^DD(2,PC1,0)),"^",2)
IF FILE
IF $DATA(FLD(FILE,PC2))
Begin DoDot:3
+19 SET USER=$PIECE(IEN0,U,4)
+20 IF $DATA(USERSCRN)
IF USER'=USERSCRN
QUIT
+21 SET PATNM=$PIECE(^DPT(RGDFN,0),U)_U_RGDFN
SET ^TMP("RGMTAUDP",$JOB,PATNM,EDITDT,IEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+22 ;
+23 IF ANS2="S"
Begin DoDot:1
+24 IF '$DATA(^TMP("RGMTAUDP",$JOB,PATNM))
SET ^TMP("RGMTAUDP2",$JOB,"NO AUDIT",PATNM)=" has no audit data available for selected parameters."
End DoDot:1
+25 QUIT
+26 ;
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 '$DATA(^TMP("RGMTAUDP",$JOB))
WRITE !!,"No audit data found in this date range for specified parameters."
GOTO QUIT
+6 SET PATNM="@@@@"
FOR
SET PATNM=$ORDER(^TMP("RGMTAUDP",$JOB,PATNM))
if PATNM=""
QUIT
if QFLG
QUIT
Begin DoDot:1
+7 if $Y+4>IOSL
DO HDR
if QFLG
QUIT
+8 WRITE !!,"==> ",$PIECE(PATNM,U)," (DFN #",$PIECE(PATNM,U,2),")"
+9 SET EDITDT=0
FOR
SET EDITDT=$ORDER(^TMP("RGMTAUDP",$JOB,PATNM,EDITDT))
if QFLG
QUIT
if 'EDITDT
QUIT
Begin DoDot:2
+10 SET IEN=0
FOR
SET IEN=$ORDER(^TMP("RGMTAUDP",$JOB,PATNM,EDITDT,IEN))
if QFLG
QUIT
if 'IEN
QUIT
Begin DoDot:3
+11 SET PRTDT=$$FMTE^XLFDT($EXTRACT(EDITDT,1,12))
+12 SET IEN0=^DIA(2,IEN,0)
+13 ;**60 MVI_1901 (cml) modified to pick up audit data for multiple subfields and check for bad DD references
+14 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)
+15 KILL RGARR
DO FIELD^DID(FILE,FIELD,"","LABEL","RGARR")
+16 SET FLD=$GET(RGARR("LABEL"))
if FLD=""
QUIT
+17 ; **60 MVI_1901 (cml) changes stop here
+18 SET USER=$PIECE(IEN0,U,4)
+19 IF 'USER
SET USER="UNKNOWN"
+20 IF USER'="UNKNOWN"
SET DIC="^VA(200,"
SET DIC(0)="MZO"
SET X="`"_USER
DO ^DIC
SET USER=$PIECE(Y,"^",2)
+21 SET OLD=$GET(^DIA(2,IEN,2))
IF OLD']""
SET OLD="<no previous value>"
+22 SET NEW=$GET(^DIA(2,IEN,3))
IF NEW']""
SET NEW="<no current value>"
+23 KILL OPTDA1,OPTDA2,OPTION,OPTNM
IF $GET(^DIA(2,IEN,4.1))
Begin DoDot:4
+24 SET OPTDA1=+$PIECE(^DIA(2,IEN,4.1),"^")
+25 IF OPTDA1
SET DIC=19
SET DR=".01"
SET DA=OPTDA1
SET DIQ(0)="EI"
SET DIQ="OPTION"
DO EN^DIQ1
KILL DIC,DR,DA,DIQ
SET OPTION=$GET(OPTION(19,OPTDA1,.01,"E"))
+26 SET OPTDA2=$PIECE(^DIA(2,IEN,4.1),"^",2)
+27 IF $PIECE(OPTDA2,";",2)="ORD(101,"
SET DIC=101
SET DR=".01"
SET DA=+OPTDA2
SET DIQ(0)="EI"
SET DIQ="OPTION"
DO EN^DIQ1
KILL DIC,DR,DA,DIQ
SET OPTNM=$GET(OPTION(101,+OPTDA2,.01,"E"))
QUIT
+28 IF +OPTDA2
SET DIC=19
SET DR=".01"
SET DA=+OPTDA2
SET DIQ(0)="EI"
SET DIQ="OPTION"
DO EN^DIQ1
KILL DIC,DR,DA,DIQ
SET OPTNM=$GET(OPTION(19,+OPTDA2,.01,"E"))
QUIT
End DoDot:4
+29 if $Y+5>IOSL
DO HDR
if QFLG
QUIT
WRITE !!,PRTDT,?20,FLD,?51,USER,!?20,OLD," / ",NEW
+30 IF $GET(OPTION)'=""
WRITE !?3,OPTION
IF $GET(OPTNM)'=""
WRITE "/",OPTNM
End DoDot:3
End DoDot:2
End DoDot:1
+31 IF $DATA(^TMP("RGMTAUDP2",$JOB,"NO AUDIT"))
Begin DoDot:1
+32 SET PATNM="@@@@"
SET RGNAUD=""
FOR
SET PATNM=$ORDER(^TMP("RGMTAUDP2",$JOB,"NO AUDIT",PATNM))
if PATNM=""
QUIT
Begin DoDot:2
+33 if QFLG
QUIT
+34 SET RGNAUD=$PIECE(^TMP("RGMTAUDP2",$JOB,"NO AUDIT",PATNM),U)
+35 WRITE !!,"==> ",$PIECE(PATNM,U)," (DFN #",$PIECE(PATNM,U,2),")"_RGNAUD
End DoDot:2
End DoDot:1
+36 ;
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("RGMTAUDP",$JOB),^TMP("RGMTAUDP2",$JOB)
+4 ;**60 MVI_1901 (cml)
KILL %,%I,ANS1,ANS2,CNT,RGDFN,DIR,DIRUT,DTOUT,DUOUT,EDITDT,FLD,FLDLP,FLDNM,HDR,DFNMULT,FIELD,FILE,SUB,MAX,PC1,PC2,SEL
+5 KILL HDT,IEN,IEN0,JJ,LN,NEW,OLD,OPTDA1,OPTDA2,OPTION,OPTNM,PAT,PATNM,PG,PRGBDT,PRGEDT,PRTDT,QFLG,QQ,RGARR,RGBDT,RGNAUD
+6 KILL RGEDT,RGERR,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 !,"Date Range: ",PRGBDT," to ",PRGEDT
+6 WRITE !!,"Date/Time Edited",?20,"Field Edited",?51,"Edited By",!?20,"Old Value / New Value"
+7 WRITE !?3,"Option/Protocol",!,LN
+8 QUIT
+9 ;
FLDLIST ;Help for Field # List
+1 KILL RG
NEW DIR
SET QFLG=0
IF RGERR
WRITE $CHAR(7)," ??"
+2 SET HDR="Select a LIST NUMBER from the audited field(s) in the PATIENT file:"
+3 WRITE @IOF,HDR,!
+4 ;
+5 ; **60 MVI_1901 (cml)changes start here
+6 KILL FLD,FLDCNT
+7 SET FLD=0
FOR
SET FLD=$ORDER(^DD(2,"AUDIT",FLD))
if 'FLD
QUIT
SET FLD(2,FLD)=""
+8 SET FILE=2
FOR
SET FILE=$ORDER(^DD(FILE))
if FILE>2.999
QUIT
if 'FILE
QUIT
SET FLD=0
FOR
SET FLD=$ORDER(^DD(FILE,"AUDIT",FLD))
if 'FLD
QUIT
SET FLD(FILE,FLD)=""
+9 IF '$DATA(FLD)
WRITE !!,"No fields are currently being audited in the Patient file."
QUIT
+10 ; set up counter array
+11 SET (CNT,FILE)=0
FOR
SET FILE=$ORDER(FLD(FILE))
if 'FILE
QUIT
SET FLDLP=0
FOR
SET FLDLP=$ORDER(FLD(FILE,FLDLP))
if 'FLDLP
QUIT
SET CNT=CNT+1
SET FLDCNT(CNT,FILE,FLDLP)=""
+12 KILL FLD
SET MAX=CNT
+13 ;
+14 SET CNT=0
FOR
SET CNT=$ORDER(FLDCNT(CNT))
if 'CNT
QUIT
SET FILE=0
FOR
SET FILE=$ORDER(FLDCNT(CNT,FILE))
if 'FILE
QUIT
SET FLDLP=0
FOR
SET FLDLP=$ORDER(FLDCNT(CNT,FILE,FLDLP))
if 'FLDLP
QUIT
if QFLG
QUIT
Begin DoDot:1
+15 ; **60 MVI_1901 (cml) changes stop here
+16 IF $Y+6>IOSL
Begin DoDot:2
+17 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
IF 'Y
SET QFLG=1
QUIT
+18 IF '$TEST
WRITE @IOF,HDR,!
End DoDot:2
if QFLG
QUIT
+19 KILL RGARR
DO FIELD^DID(FILE,FLDLP,"","LABEL","RGARR")
+20 SET FLDNM=$GET(RGARR("LABEL"))
if FLDNM=""
QUIT
+21 ;**60 MVI_1901 (cml)
WRITE !,CNT,". ",FILE,",",FLDLP,?17,FLDNM
End DoDot:1
+22 QUIT
