- 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 Mar 13, 2025@20:46:55 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
