AGERRAUD ;IHS/ASDS/TPF - EDIT CHECK ERROR AUDIT CAPTURE AND PRINT ROUTINE;
;;7.1;PATIENT REGISTRATION;**1,2,3,11**;AUG 25, 2005;Build 1
;IHS/OIT/NKD AG*7.1*11 SAC REQUIREMENT ROUTINE TOO LARGE MOVED SUBRTNS
;
;THIS ROUTINE WILL COLLECT THE ERRORS/WARNINGS
;WHICH ARE FOUND WHILE 'SCANNING' THROUGH THE PATIENT FILE.
;THE ERRORS FOUND ARE THEN AVAILABLE FOR PRINTING USING THE 'AG FULL
;PATIENT AUDIT REPORTS' OPTION
;THE AUDIT WILL BE RUN SPECIFIC TO THE SITE (DUZ(2) UNDER WHICH
;IT IS RUN. FOR MULTI DIVISION SITES THE USER RUNNING THE ADUIT
;SHOULD LOG INTO EACH SITE, RUN THE AUDIT, THEN PRINT THE REPORTS
;WHEN THE AUDIT IS FINISHED. THEN LOG INTO ANOTHER SITE, RUN THE AUDIT
;AND DO THE REPORTS. ERRORS REPORTED FOR ONE SITE MAY BE DUPLICATED
;ON ANOTHER BECAUSE THE PATIENT HAS AN HRN FOR EACH SITE
;
CAPTURE(AUDITERR,PDFN) ;EP
;IF PATIENT RECORD FOR DATE IS NOT THERE CREATE IT
I '$D(^AGERRAUD("C",PDFN,DTREC)) S PTREC=$$NEWPT(DTREC,PDFN)
E S PTREC=$O(^AGERRAUD("C",PDFN,DTREC,""))
I $G(PTREC)<0 W:'$D(ZTQUEUED) !,"UNABLE TO CREATE PATIENT ENTRY IN 'ERROR/WARNING AUDIT' FILE!!" H 3 D EXITCAP Q
S ERRREC=""
F S ERRREC=$O(AUDITERR(ERRREC)) Q:ERRREC="" D
.Q:+AUDITERR(ERRREC)=0
.S ERRCODE=ERRREC
.I '$D(^AGERRAUD("D",ERRCODE,DTREC,PTREC)) S ERRREC=$$NEWERR(ERRCODE,PTREC,DTREC)
.E Q ;ELSE ERROR ALREADY RECORDED FOR THIS PATIENT NO NEED FOR DUP ENTRY
.I $G(ERRREC)<0 W:'$D(ZTQUEUED) !,"UNABLE TO CREATE ERROR CODE ENTRY IN 'ERROR/WARNING AUDIT' FILE!!" H 3 D EXITCAP Q
Q
EXITCAP ;EP - CLEANUP CAPTURE VARS
K DTREC,PDFN,PTREC,ERRREC,ERRCODE
Q
NEWPT(DTREC,PDFN) ;ADD PATIENT
K DIC,DIE,DR,DA
S DA(1)=DTREC
S DIC="^AGERRAUD("_DA(1)_",1,"
S DIC(0)="L"
S X="`"_PDFN
D ^DIC
Q:Y<0 0
S PTREC=+Y
S FAC=0
F S FAC=$O(^AUPNPAT(PDFN,41,FAC)) Q:'FAC D
.S UPDDATE=$P($G(^AUPNPAT(PDFN,0)),U,3) ;DATE OF LAST REG. UPDATE
.;IF THERE IS NO DATE OF LAST REG UPDATE FOR THE PATIENT IT MEANS
.;THE PATIENT WAS REGISTERED BUT NEVER EDITED. IN THIS CASE
.;USE THE DATE ESTABLISHED FIELD. IF THERE IS NO DATE ESTABLISHED
.;FOR THIS PATIENT, SET THE DATE TO DT-40000 (4 YEARS AGO)
.I UPDDATE="" S UPDDATE=$P($G(^AUPNPAT(PDFN,0)),U,2) ;DATE ESTABLISHED
.I UPDDATE="" S UPDDATE=DT-30000
.S ^AGERRAUD("E",FAC,PDFN)=UPDDATE
K FAC
Q PTREC
NEWERR(ERRCODE,PTREC,DTREC) ;EP - ADD ERRORS
K DIC,DIE,DR,DA
S DA(2)=DTREC
S DA(1)=PTREC
S DIC(0)="L"
S DIC="^AGERRAUD("_DA(2)_",1,"_DA(1)_",1,"
S X="`"_ERRCODE
D ^DIC
;Q:Y<0
Q:Y<0 -1 ;AG*7.1*3
S ERRREC=+Y
Q ERRREC
EDENTRY(ERRCODE,PDFN) ;EP
K DIC,DIE,DR,DA
S DTIEN=$O(^AGERRAUD("B",DT,""))
S (DA,PTREC)=$O(^AGERRAUD("C",PDFN,DTIEN,""))
S DIE="^AGERRAUD("_DTIEN_",1,"_PTREC_","
S DR=.01
S DR(2,9009061.60101)=".01////^S X=ERRCODE"
D ^DIE
Q
PRINT ;EP
S NOERR=0 ;IHS/SD/TPF 2/21/2006 IM19869
S:$G(AGLINE("EQ"))="" $P(AGLINE("EQ"),"=",81)=""
;AG*7.1*11 SAC REQ ROUTINE TOO LARGE
;D HDR
D HDR^AGERRAU1
S ERRDT=$O(^AGERRAUD("B",""),-1)
I 'ERRDT W !!,"NO RECORDS FOUND IN 'AG ERROR/WARNING AUDIT' FILE",!,"YOU MUST FIRST CHOOSE THE FAUD 'FAUD FULL PATIENT FILE AUDIT' OPTION FIRST!!" H 3 Q
;AG*7.1*3 IM23869
S E=$O(^AGERRAUD("E",""))
I 'E W !!,"NO ERRORS WERE FOUND." D H 3 S NOERR=1 D ^%ZISC Q
.W !,$P($G(^AGERRAUD(1,0)),U,2)," RECORDS OUT OF ",$P($G(^AUPNPAT(0)),U,4),!," RECORDS IN THE PATIENT FILE WERE SCREENED FROM ERROR PROCESSING"
.W !,"IF THE NUMBER OF RECORDS SKIPPED IS VERY CLOSE TO THE NUMBER OF PATIENT RECORDS TRY RUNNING THE FAUD AGAIN"
S DTREC=$O(^AGERRAUD("B",ERRDT,""))
S LASTBEG=$P($G(^AGERRAUD(DTREC,0)),U,3)
S LASTFIN=$P($G(^AGERRAUD(DTREC,0)),U,4)
I LASTFIN="" S X1=DT,X2=LASTBEG D ^%DTC S DURATION=+X
I 'LASTFIN D Q
.W !!,"THE AUDIT REPORT IS CURRENTLY RUNNING"
.S Y=LASTBEG X ^DD("DD") S LASTBEG=Y
.W !,"IT WAS STARTED ON ",LASTBEG
.I $G(DURATION)>0 D Q
..W !,"THE AUDIT WAS STARTED ",DURATION," DAY",$S(DURATION>1:"S",1:"")," AGO"
..W !,"IT SHOULD NOT TAKE THIS LONG. PLEASE REPORT THIS TO YOUR SITE MANAGER." H 2
.W !,"TRY AGAIN LATER."
.H 2
S LASTRUN=$P($G(^AGERRAUD(DTREC,0)),U,3)
S Y=LASTRUN X ^DD("DD") S LASTRUN=Y
W !!
;AG*7.1*11 SAC REQ ROUTINE TOO LARGE
;D CENTER("AUDIT REPORT LAST RUN ON "_LASTRUN)
D CENTER^AGERRAU1("AUDIT REPORT LAST RUN ON "_LASTRUN)
W !
ASKEWB ;EP - ASK IF ERRORS ONLY, WARNINGS ONLY, OR BOTH
K DIR
S DIR(0)="SOX^E:Errors Only;W:Warnings Only;B:Both"
S DIR("A")="Select one of the following"
D ^DIR
I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) D EXIT Q
S CODETYPE=Y
S PGNUM=0
ASKTYPE ;EP
K DIR
S DIR(0)="SOX^S:Summarized Error/Warning;D:Detailed Error/Warning"
S DIR("A")="Select Summary or Detail"
D ^DIR
I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) D EXIT Q
S RPTTYPE=Y
;ASK FOR WHAT ERRORS THEY ARE LOOKING FOR
ASKERR ;EP
K DIR
S DIR("A")="Choose Error/Warning Type"
S DIR(0)="SOX^A:ALL;S:SOME"
D ^DIR
G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) ASKTYPE
;I Y="A" S ASKSOME="ALL" D PRTALL(ASKSOME) G PRINT
I Y="A" S ASKSOME="ALL" D PRTALL(ASKSOME) Q:$G(NOERR) G PRINT ;IHS/SD/TPF 2/21/2006 IM19869
K ASKSOME
ASKSOME ;EP
K DIR
S DIR("A")="Enter "_$S($G(ASKSOME)'="":"more",1:"the")_" error codes you wish to print"
I CODETYPE'="B" S DIR("S")="I $P(^(0),U,2)=CODETYPE"
S DIR(0)="PO^9009061.5:EM"
D ^DIR
G:X=""&('$D(ASKSOME)) PRINT
I X="",$D(ASKSOME) D PRTALL(U_ASKSOME) Q:$G(NOERR) G PRINT ;IHS/SD/TPF 2/21/2006 IM19869
;MAKE SURE THE ERROR CODE MATCHES THE TYPE OF ERROR
;SELECTED (ERRORS ONLY,WARNINGS ONLY). DISREGARD IF
;SELECTION WAS BOTH.
K ERRRESP
I $P($G(^AGEDERRS(+Y,0)),U,2)'=CODETYPE,CODETYPE'="B" D G ASKSOME
. S ERRRESP=$S(CODETYPE="E":"ERROR",CODETYPE="W":"WARNING")
. W !,"THIS IS NOT A ",ERRRESP," CODE"
I +Y I $G(ASKSOME)'[Y S ASKSOME=$G(ASKSOME)_+Y_U G ASKSOME
G PRINT
PRTALL(ASKSOME) ;EP
D ASKLOC
I '$D(AORONE) G PRINT
I AORONE="O" D LOCSEL I FACSEL="" G PRINT
D ASKDATE
D ^%ZIS Q:POP
U IO
D NOW^%DTC S Y=% D DD^%DT S REPTIME=Y
S ERRTYP="E"
K ^XTMP("AGERRAUD",$J)
;AT THIS TIME THE REQUIREMENT ASKED FOR A DAILY AUDIT. THERE
;SHOULD BE NO MORE THAN ONE DATE ENTRY. WE WILL LOOK ONLY AT THE
;LAST ENTRY.
S ERRDT=$O(^AGERRAUD("B",""),-1)
;I 'ERRDT W !,"NO RECORDS FOUND IN 'AG ERROR/WARNING AUDIT' FILE" H 3 Q
I 'ERRDT W !,"NO RECORDS FOUND IN 'AG ERROR/WARNING AUDIT' FILE" H 3 S NOERR=1 D ^%ZISC Q ;IHS/SD/TPF 2/21/2006 IM19869
S DTREC=$O(^AGERRAUD("B",ERRDT,""))
;FIRST SORT BY ERROR TYPE
;I '$D(^AGERRAUD("D")) W !,"NO ERRORS FOUND" H 2 Q
;I '$D(^AGERRAUD("D")),($$ERRSITE'="") W !,"NO ERRORS FOUND FOR SITE '"_$P($G(^DIC(4,$$ERRSITE,0)),U)_"'" H 2 Q
I '$D(^AGERRAUD("D")) W !,"NO ERRORS FOUND IN THE 'AG ERROR/WARNING AUDIT' FILE" H 2 S NOERR=1 D ^%ZISC Q ;IHS/SD/TPF 2/21/2006 IM19869
I '$D(^AGERRAUD("D")),($$ERRSITE'="") W !,"NO ERRORS FOUND FOR SITE '"_$P($G(^DIC(4,$$ERRSITE,0)),U)_"' IN THE 'AG ERROR/WARNING AUDIT' FILE" H 2 S NOERR=1 D ^%ZISC Q ;IHS/SD/TPF 2/21/2006 IM19869
S ERRCODE=0
F S ERRCODE=$O(^AGERRAUD("D",ERRCODE)) Q:'ERRCODE D
.I ASKSOME'="ALL" Q:ASKSOME'[(U_ERRCODE_U)
.S ERRNODE=$G(^AGEDERRS(ERRCODE,0))
.S ERRTYPE=$P(ERRNODE,U,2)
.Q:ERRTYPE'=CODETYPE&(CODETYPE'="B")
.S PTREC=0
.F NUMPT=1:1 S PTREC=$O(^AGERRAUD("D",ERRCODE,DTREC,PTREC)) Q:'PTREC D
..S PDFN=$P($G(^AGERRAUD(DTREC,1,PTREC,0)),U)
..I RPTTYPE="D" D
...I AORONE="A" D
....S FAC=0
....F S FAC=$O(^AGERRAUD("E",FAC)) Q:'FAC D
.....Q:'$D(^AGERRAUD("E",FAC,PDFN))
.....Q:$G(^AGERRAUD("E",FAC,PDFN))<NEWMIN
.....S ^XTMP("AGERRAUD",$J,FAC,ERRTYPE,ERRCODE,PDFN)=""
...I AORONE="O" D
....F SEL=1:1 S FAC=$P(FACSEL,",",SEL) Q:FAC="" D
.....Q:'$D(^AGERRAUD("E",FAC,PDFN))
.....Q:$G(^AGERRAUD("E",FAC,PDFN))<NEWMIN
.....S ^XTMP("AGERRAUD",$J,FAC,ERRTYPE,ERRCODE,PDFN)=""
..I RPTTYPE="S" D
...I AORONE="A" D
....S FAC=0
....F S FAC=$O(^AGERRAUD("E",FAC)) Q:'FAC D
.....Q:'$D(^AGERRAUD("E",FAC,PDFN))
.....Q:$G(^AGERRAUD("E",FAC,PDFN))<NEWMIN
.....S ^XTMP("AGERRAUD",$J,FAC,ERRTYPE,ERRCODE)=$P($G(^XTMP("AGERRAUD",$J,FAC,ERRTYPE,ERRCODE)),U)+1
...I AORONE="O" D
....F SEL=1:1 S FAC=$P(FACSEL,",",SEL) Q:FAC="" D
.....Q:'$D(^AGERRAUD("E",FAC,PDFN))
.....Q:$G(^AGERRAUD("E",FAC,PDFN))<NEWMIN
.....S ^XTMP("AGERRAUD",$J,FAC,ERRTYPE,ERRCODE)=$P($G(^XTMP("AGERRAUD",$J,FAC,ERRTYPE,ERRCODE)),U)+1
I RPTTYPE="D" D DETAIL Q
;AG*7.1*11 SAC REQ ROUTINE TOO LARGE
;D SUMMARY
D SUMMARY^AGERRAU1
Q
DETAIL ;EP
S ESCAPE=0
S FAC=0
;AG*7.1*1 ADDED NEXT TWO LINES IM19869
I $G(FACSEL)'="",('$D(^XTMP("AGERRAUD",$J,FACSEL))) S NOERR=1 W !,"NO ERRORS FOUND" D:$D(IO("SD")) ^%ZISC Q:IOST'[("C-") Q:$D(IO("S")) I (IOST[("C-")) K DIR S DIR(0)="E" D ^DIR D ^%ZISC Q
I '$O(^XTMP("AGERRAUD",$J,FAC)) S NOERR=1 W !,"NO ERRORS FOUND" Q:IOST'[("C-") Q:$D(IO("S")) I (IOST[("C-")) K DIR S DIR(0)="E" D ^DIR D ^%ZISC Q
F S FAC=$O(^XTMP("AGERRAUD",$J,FAC)) Q:'FAC D Q:ESCAPE
.S ERRTYPE="",OLDERR=""
.F S ERRTYPE=$O(^XTMP("AGERRAUD",$J,FAC,ERRTYPE)) Q:ERRTYPE="" D Q:ESCAPE
..S ERRCODE="",CODEOLD=""
..F S ERRCODE=$O(^XTMP("AGERRAUD",$J,FAC,ERRTYPE,ERRCODE)) Q:ERRCODE="" D Q:ESCAPE
...;AG*7.1*11 SAC REQ ROUTINE TOO LARGE
...;I ERRCODE'=CODEOLD S CODEOLD=ERRCODE D PRTHDR,DETHDR(ERRCODE)
...I ERRCODE'=CODEOLD S CODEOLD=ERRCODE D PRTHDR^AGERRAU1,DETHDR^AGERRAU1(ERRCODE)
...S PDFN=""
...F S PDFN=$O(^XTMP("AGERRAUD",$J,FAC,ERRTYPE,ERRCODE,PDFN)) Q:PDFN="" D Q:ESCAPE
....S NUMPT=$P($G(^XTMP("AGERRAUD",$J,FAC,ERRTYPE,ERRCODE,PDFN)),U)
....S PNAME=$P($G(^DPT(PDFN,0)),U)
....S PDOB=$P($G(^DPT(PDFN,0)),U,3)
....S PHRN=$P($G(^AUPNPAT(PDFN,41,FAC,0)),U,2)
....W !,$E(PNAME,1,20)
....W ?22,PHRN
....W:$G(DUZ(0))["@" "("_PDFN_")"
....W ?37,$P($G(^DIC(4,FAC,0)),U)
....S Y=PDOB X ^DD("DD") S PDOB=Y
....W ?69,PDOB
....;NOTE: HEADER IS 8 LINES
....;ADDED A CHECK FOR SLAVE PRINTER IN ALL LINES BELOW WITH A DIR CALL AG*7.1*1 IM19869
....;AG*7.1*11 SAC REQ ROUTINE TOO LARGE
....;I ($Y>(IOSL-4)!($Y=(IOSL-4))),(IOST[("C-")) Q:$D(IO("S")) W ! K DIR S DIR(0)="E" D:'ESCAPE ^DIR S ESCAPE=X=U Q:'$O(^XTMP("AGERRAUD",$J,FAC,ERRTYPE,ERRCODE,PDFN)) D:'ESCAPE PRTHDR,DETHDR(ERRCODE) Q
....I ($Y>(IOSL-4)!($Y=(IOSL-4))),(IOST[("C-")) Q:$D(IO("S")) W ! K DIR S DIR(0)="E" D:'ESCAPE ^DIR S ESCAPE=X=U Q:'$O(^XTMP("AGERRAUD",$J,FAC,ERRTYPE,ERRCODE,PDFN)) D:'ESCAPE PRTHDR^AGERRAU1,DETHDR^AGERRAU1(ERRCODE) Q
....;AG*7.1*11 SAC REQ ROUTINE TOO LARGE
....;I $Y>(IOSL-4)!($Y=(IOSL-4)) Q:'$O(^XTMP("AGERRAUD",$J,FAC,ERRTYPE,ERRCODE,PDFN)) D PRTHDR,DETHDR(ERRCODE) Q
....I $Y>(IOSL-4)!($Y=(IOSL-4)) Q:'$O(^XTMP("AGERRAUD",$J,FAC,ERRTYPE,ERRCODE,PDFN)) D PRTHDR^AGERRAU1,DETHDR^AGERRAU1(ERRCODE) Q
...I ($Y<(IOSL-4)!($Y=(IOSL-4))),(IOST[("C-")) Q:'$O(^XTMP("AGERRAUD",$J,FAC,ERRTYPE,ERRCODE)) Q:$D(IO("S")) K DIR S DIR(0)="E" D ^DIR S ESCAPE=X=U
..I $Y<(IOSL-4)!($Y=(IOSL-4)),(IOST[("C-")) Q:'$O(^XTMP("AGERRAUD",$J,FAC,ERRTYPE)) Q:$D(IO("S")) K DIR S DIR(0)="E" D ^DIR S ESCAPE=X=U
.I $Y<(IOSL-4)!($Y=(IOSL-4)),(IOST[("C-")) Q:'$O(^XTMP("AGERRAUD",$J,FAC)) Q:$D(IO("S")) K DIR S DIR(0)="E" D ^DIR S ESCAPE=X=U
I (IOST[("C-")) Q:ESCAPE Q:$D(IO("S")) K DIR S DIR(0)="E" D ^DIR S ESCAPE=X=U
D ^%ZISC
Q
LOCSEL ;EP - DETERMINE IF ALL LOCATIONS OR SELECTED LOCATIONS
S FACSEL=""
K DIR
F I=1:1 D Q:X=""!($D(DTOUT))!($D(DUOUT))!($D(DIROUT))
.S DIR("A")="Select Location "
.S DIR("S")="I $D(^AGERRAUD(""E"",+Y))"
.S DIR(0)="PO^9999999.06:EMZ"
.D ^DIR Q:Y=-1
.I FACSEL="" S FACSEL=+Y
.E S FACSEL=FACSEL_","_+Y
.K DIR
Q
ASKLOC ;EP - ASK IF ALL LOCATIONS OR LET USER SELECT LOCATIONS
K DIR,AORONE
S DIR(0)="SMX^A:All Locations;O:One Location"
D ^DIR Q:Y=-1
Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))
S AORONE=X
Q
ASKDATE ;EP - ASK FOR BEGINNING DATE FOR THE REPORT. THE DEFAULT WILL
;BE 3 YEARS BACK.
S Y=DT-30000 X ^DD("DD")
S MINDT=Y
W !!,"The audit pulls all patients who are active in at least one facility,"
W !,"not deceased, have a last updated date of not more than three years"
W !,"ago, and have some form of an active insurance eligibility in"
W !,"Medicare, Medicaid, Private or Railroad insurance."
W !!,"Those patients whose DATE OF LAST REG UPDATE field is greater than"
W !,MINDT," are not included in this audit!"
W !
ASKAGAIN ;SHOW DEFAULT DATE AND CONFIRM
K DIR
S DIR("A",1)="If you choose NO to continue, you will be prompted for a new date."
S DIR("A",2)="If you accept the default date, the report will include all of the"
S DIR("A",3)="patients that have been included in the audit file."
S DIR("A",4)=" "
S DIR("B")="YES"
S DIR("A")="Continue?"
S DIR(0)="Y"
D ^DIR
Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))
I Y=1 S NEWMIN=DT-30000 Q
DTAGAIN ;EP - PROMPT TO CHANGE BEGINNING DATE
K DIR,NEWMIN
S DIR("B")=MINDT
S DIR(0)="DO"
D ^DIR
I Y<MINDT!(Y>DT) W !!,"The date must be between ",MINDT," and TODAY" G DTAGAIN
Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))
S NEWMIN=Y
X ^DD("DD")
W !!,"You have entered ",Y,!
K DIR
S DIR("B")="YES"
S DIR("A")="Continue?"
S DIR(0)="Y"
D ^DIR
I Y=0 G DTAGAIN
Q
;DETERMINE WHAT SITE THE AUDIT WAS PERFORMED ON
ERRSITE() ;EP
N PDFN
Q $P($G(^AGERRAUD(1,0)),U,7)
EXIT ;EP - CLEANUP AND EXIT
K ASKSOME,CENTER,ERRCODE,ERRDESCR,ERRNODE,ERRREC,ERRTYP,ERRTYPE,ESCAPE,NUMPT,PDFN,PDOB
K PFAC,PHRN,PNAME,POP,PTREC,REPTIME,RPTTYPE
K CODETYPE,PGNUM,FAC,UPDDATE,ERRRESP,^XTMP("AGERRAUD",$J)
Q
AGERRAUD ;IHS/ASDS/TPF - EDIT CHECK ERROR AUDIT CAPTURE AND PRINT ROUTINE;
+1 ;;7.1;PATIENT REGISTRATION;**1,2,3,11**;AUG 25, 2005;Build 1
+2 ;IHS/OIT/NKD AG*7.1*11 SAC REQUIREMENT ROUTINE TOO LARGE MOVED SUBRTNS
+3 ;
+4 ;THIS ROUTINE WILL COLLECT THE ERRORS/WARNINGS
+5 ;WHICH ARE FOUND WHILE 'SCANNING' THROUGH THE PATIENT FILE.
+6 ;THE ERRORS FOUND ARE THEN AVAILABLE FOR PRINTING USING THE 'AG FULL
+7 ;PATIENT AUDIT REPORTS' OPTION
+8 ;THE AUDIT WILL BE RUN SPECIFIC TO THE SITE (DUZ(2) UNDER WHICH
+9 ;IT IS RUN. FOR MULTI DIVISION SITES THE USER RUNNING THE ADUIT
+10 ;SHOULD LOG INTO EACH SITE, RUN THE AUDIT, THEN PRINT THE REPORTS
+11 ;WHEN THE AUDIT IS FINISHED. THEN LOG INTO ANOTHER SITE, RUN THE AUDIT
+12 ;AND DO THE REPORTS. ERRORS REPORTED FOR ONE SITE MAY BE DUPLICATED
+13 ;ON ANOTHER BECAUSE THE PATIENT HAS AN HRN FOR EACH SITE
+14 ;
CAPTURE(AUDITERR,PDFN) ;EP
+1 ;IF PATIENT RECORD FOR DATE IS NOT THERE CREATE IT
+2 IF '$DATA(^AGERRAUD("C",PDFN,DTREC))
SET PTREC=$$NEWPT(DTREC,PDFN)
+3 IF '$TEST
SET PTREC=$ORDER(^AGERRAUD("C",PDFN,DTREC,""))
+4 IF $GET(PTREC)<0
IF '$DATA(ZTQUEUED)
WRITE !,"UNABLE TO CREATE PATIENT ENTRY IN 'ERROR/WARNING AUDIT' FILE!!"
HANG 3
DO EXITCAP
QUIT
+5 SET ERRREC=""
+6 FOR
SET ERRREC=$ORDER(AUDITERR(ERRREC))
IF ERRREC=""
QUIT
Begin DoDot:1
+7 IF +AUDITERR(ERRREC)=0
QUIT
+8 SET ERRCODE=ERRREC
+9 IF '$DATA(^AGERRAUD("D",ERRCODE,DTREC,PTREC))
SET ERRREC=$$NEWERR(ERRCODE,PTREC,DTREC)
+10 ;ELSE ERROR ALREADY RECORDED FOR THIS PATIENT NO NEED FOR DUP ENTRY
IF '$TEST
QUIT
+11 IF $GET(ERRREC)<0
IF '$DATA(ZTQUEUED)
WRITE !,"UNABLE TO CREATE ERROR CODE ENTRY IN 'ERROR/WARNING AUDIT' FILE!!"
HANG 3
DO EXITCAP
QUIT
End DoDot:1
+12 QUIT
EXITCAP ;EP - CLEANUP CAPTURE VARS
+1 KILL DTREC,PDFN,PTREC,ERRREC,ERRCODE
+2 QUIT
NEWPT(DTREC,PDFN) ;ADD PATIENT
+1 KILL DIC,DIE,DR,DA
+2 SET DA(1)=DTREC
+3 SET DIC="^AGERRAUD("_DA(1)_",1,"
+4 SET DIC(0)="L"
+5 SET X="`"_PDFN
+6 DO ^DIC
+7 IF Y<0
QUIT 0
+8 SET PTREC=+Y
+9 SET FAC=0
+10 FOR
SET FAC=$ORDER(^AUPNPAT(PDFN,41,FAC))
IF 'FAC
QUIT
Begin DoDot:1
+11 ;DATE OF LAST REG. UPDATE
SET UPDDATE=$PIECE($GET(^AUPNPAT(PDFN,0)),U,3)
+12 ;IF THERE IS NO DATE OF LAST REG UPDATE FOR THE PATIENT IT MEANS
+13 ;THE PATIENT WAS REGISTERED BUT NEVER EDITED. IN THIS CASE
+14 ;USE THE DATE ESTABLISHED FIELD. IF THERE IS NO DATE ESTABLISHED
+15 ;FOR THIS PATIENT, SET THE DATE TO DT-40000 (4 YEARS AGO)
+16 ;DATE ESTABLISHED
IF UPDDATE=""
SET UPDDATE=$PIECE($GET(^AUPNPAT(PDFN,0)),U,2)
+17 IF UPDDATE=""
SET UPDDATE=DT-30000
+18 SET ^AGERRAUD("E",FAC,PDFN)=UPDDATE
End DoDot:1
+19 KILL FAC
+20 QUIT PTREC
NEWERR(ERRCODE,PTREC,DTREC) ;EP - ADD ERRORS
+1 KILL DIC,DIE,DR,DA
+2 SET DA(2)=DTREC
+3 SET DA(1)=PTREC
+4 SET DIC(0)="L"
+5 SET DIC="^AGERRAUD("_DA(2)_",1,"_DA(1)_",1,"
+6 SET X="`"_ERRCODE
+7 DO ^DIC
+8 ;Q:Y<0
+9 ;AG*7.1*3
IF Y<0
QUIT -1
+10 SET ERRREC=+Y
+11 QUIT ERRREC
EDENTRY(ERRCODE,PDFN) ;EP
+1 KILL DIC,DIE,DR,DA
+2 SET DTIEN=$ORDER(^AGERRAUD("B",DT,""))
+3 SET (DA,PTREC)=$ORDER(^AGERRAUD("C",PDFN,DTIEN,""))
+4 SET DIE="^AGERRAUD("_DTIEN_",1,"_PTREC_","
+5 SET DR=.01
+6 SET DR(2,9009061.60101)=".01////^S X=ERRCODE"
+7 DO ^DIE
+8 QUIT
PRINT ;EP
+1 ;IHS/SD/TPF 2/21/2006 IM19869
SET NOERR=0
+2 IF $GET(AGLINE("EQ"))=""
SET $PIECE(AGLINE("EQ"),"=",81)=""
+3 ;AG*7.1*11 SAC REQ ROUTINE TOO LARGE
+4 ;D HDR
+5 DO HDR^AGERRAU1
+6 SET ERRDT=$ORDER(^AGERRAUD("B",""),-1)
+7 IF 'ERRDT
WRITE !!,"NO RECORDS FOUND IN 'AG ERROR/WARNING AUDIT' FILE",!,"YOU MUST FIRST CHOOSE THE FAUD 'FAUD FULL PATIENT FILE AUDIT' OPTION FIRST!!"
HANG 3
QUIT
+8 ;AG*7.1*3 IM23869
+9 SET E=$ORDER(^AGERRAUD("E",""))
+10 IF 'E
WRITE !!,"NO ERRORS WERE FOUND."
Begin DoDot:1
+11 WRITE !,$PIECE($GET(^AGERRAUD(1,0)),U,2)," RECORDS OUT OF ",$PIECE($GET(^AUPNPAT(0)),U,4),!," RECORDS IN THE PATIENT FILE WERE SCREENED FROM ERROR PROCESSING"
+12 WRITE !,"IF THE NUMBER OF RECORDS SKIPPED IS VERY CLOSE TO THE NUMBER OF PATIENT RECORDS TRY RUNNING THE FAUD AGAIN"
End DoDot:1
HANG 3
SET NOERR=1
DO ^%ZISC
QUIT
+13 SET DTREC=$ORDER(^AGERRAUD("B",ERRDT,""))
+14 SET LASTBEG=$PIECE($GET(^AGERRAUD(DTREC,0)),U,3)
+15 SET LASTFIN=$PIECE($GET(^AGERRAUD(DTREC,0)),U,4)
+16 IF LASTFIN=""
SET X1=DT
SET X2=LASTBEG
DO ^%DTC
SET DURATION=+X
+17 IF 'LASTFIN
Begin DoDot:1
+18 WRITE !!,"THE AUDIT REPORT IS CURRENTLY RUNNING"
+19 SET Y=LASTBEG
XECUTE ^DD("DD")
SET LASTBEG=Y
+20 WRITE !,"IT WAS STARTED ON ",LASTBEG
+21 IF $GET(DURATION)>0
Begin DoDot:2
+22 WRITE !,"THE AUDIT WAS STARTED ",DURATION," DAY",$SELECT(DURATION>1:"S",1:"")," AGO"
+23 WRITE !,"IT SHOULD NOT TAKE THIS LONG. PLEASE REPORT THIS TO YOUR SITE MANAGER."
HANG 2
End DoDot:2
QUIT
+24 WRITE !,"TRY AGAIN LATER."
+25 HANG 2
End DoDot:1
QUIT
+26 SET LASTRUN=$PIECE($GET(^AGERRAUD(DTREC,0)),U,3)
+27 SET Y=LASTRUN
XECUTE ^DD("DD")
SET LASTRUN=Y
+28 WRITE !!
+29 ;AG*7.1*11 SAC REQ ROUTINE TOO LARGE
+30 ;D CENTER("AUDIT REPORT LAST RUN ON "_LASTRUN)
+31 DO CENTER^AGERRAU1("AUDIT REPORT LAST RUN ON "_LASTRUN)
+32 WRITE !
ASKEWB ;EP - ASK IF ERRORS ONLY, WARNINGS ONLY, OR BOTH
+1 KILL DIR
+2 SET DIR(0)="SOX^E:Errors Only;W:Warnings Only;B:Both"
+3 SET DIR("A")="Select one of the following"
+4 DO ^DIR
+5 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
DO EXIT
QUIT
+6 SET CODETYPE=Y
+7 SET PGNUM=0
ASKTYPE ;EP
+1 KILL DIR
+2 SET DIR(0)="SOX^S:Summarized Error/Warning;D:Detailed Error/Warning"
+3 SET DIR("A")="Select Summary or Detail"
+4 DO ^DIR
+5 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
DO EXIT
QUIT
+6 SET RPTTYPE=Y
+7 ;ASK FOR WHAT ERRORS THEY ARE LOOKING FOR
ASKERR ;EP
+1 KILL DIR
+2 SET DIR("A")="Choose Error/Warning Type"
+3 SET DIR(0)="SOX^A:ALL;S:SOME"
+4 DO ^DIR
+5 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
GOTO ASKTYPE
+6 ;I Y="A" S ASKSOME="ALL" D PRTALL(ASKSOME) G PRINT
+7 ;IHS/SD/TPF 2/21/2006 IM19869
IF Y="A"
SET ASKSOME="ALL"
DO PRTALL(ASKSOME)
IF $GET(NOERR)
QUIT
GOTO PRINT
+8 KILL ASKSOME
ASKSOME ;EP
+1 KILL DIR
+2 SET DIR("A")="Enter "_$SELECT($GET(ASKSOME)'="":"more",1:"the")_" error codes you wish to print"
+3 IF CODETYPE'="B"
SET DIR("S")="I $P(^(0),U,2)=CODETYPE"
+4 SET DIR(0)="PO^9009061.5:EM"
+5 DO ^DIR
+6 IF X=""&('$DATA(ASKSOME))
GOTO PRINT
+7 ;IHS/SD/TPF 2/21/2006 IM19869
IF X=""
IF $DATA(ASKSOME)
DO PRTALL(U_ASKSOME)
IF $GET(NOERR)
QUIT
GOTO PRINT
+8 ;MAKE SURE THE ERROR CODE MATCHES THE TYPE OF ERROR
+9 ;SELECTED (ERRORS ONLY,WARNINGS ONLY). DISREGARD IF
+10 ;SELECTION WAS BOTH.
+11 KILL ERRRESP
+12 IF $PIECE($GET(^AGEDERRS(+Y,0)),U,2)'=CODETYPE
IF CODETYPE'="B"
Begin DoDot:1
+13 SET ERRRESP=$SELECT(CODETYPE="E":"ERROR",CODETYPE="W":"WARNING")
+14 WRITE !,"THIS IS NOT A ",ERRRESP," CODE"
End DoDot:1
GOTO ASKSOME
+15 IF +Y
IF $GET(ASKSOME)'[Y
SET ASKSOME=$GET(ASKSOME)_+Y_U
GOTO ASKSOME
+16 GOTO PRINT
PRTALL(ASKSOME) ;EP
+1 DO ASKLOC
+2 IF '$DATA(AORONE)
GOTO PRINT
+3 IF AORONE="O"
DO LOCSEL
IF FACSEL=""
GOTO PRINT
+4 DO ASKDATE
+5 DO ^%ZIS
IF POP
QUIT
+6 USE IO
+7 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET REPTIME=Y
+8 SET ERRTYP="E"
+9 KILL ^XTMP("AGERRAUD",$JOB)
+10 ;AT THIS TIME THE REQUIREMENT ASKED FOR A DAILY AUDIT. THERE
+11 ;SHOULD BE NO MORE THAN ONE DATE ENTRY. WE WILL LOOK ONLY AT THE
+12 ;LAST ENTRY.
+13 SET ERRDT=$ORDER(^AGERRAUD("B",""),-1)
+14 ;I 'ERRDT W !,"NO RECORDS FOUND IN 'AG ERROR/WARNING AUDIT' FILE" H 3 Q
+15 ;IHS/SD/TPF 2/21/2006 IM19869
IF 'ERRDT
WRITE !,"NO RECORDS FOUND IN 'AG ERROR/WARNING AUDIT' FILE"
HANG 3
SET NOERR=1
DO ^%ZISC
QUIT
+16 SET DTREC=$ORDER(^AGERRAUD("B",ERRDT,""))
+17 ;FIRST SORT BY ERROR TYPE
+18 ;I '$D(^AGERRAUD("D")) W !,"NO ERRORS FOUND" H 2 Q
+19 ;I '$D(^AGERRAUD("D")),($$ERRSITE'="") W !,"NO ERRORS FOUND FOR SITE '"_$P($G(^DIC(4,$$ERRSITE,0)),U)_"'" H 2 Q
+20 ;IHS/SD/TPF 2/21/2006 IM19869
IF '$DATA(^AGERRAUD("D"))
WRITE !,"NO ERRORS FOUND IN THE 'AG ERROR/WARNING AUDIT' FILE"
HANG 2
SET NOERR=1
DO ^%ZISC
QUIT
+21 ;IHS/SD/TPF 2/21/2006 IM19869
IF '$DATA(^AGERRAUD("D"))
IF ($$ERRSITE'="")
WRITE !,"NO ERRORS FOUND FOR SITE '"_$PIECE($GET(^DIC(4,$$ERRSITE,0)),U)_"' IN THE 'AG ERROR/WARNING AUDIT' FILE"
HANG 2
SET NOERR=1
DO ^%ZISC
QUIT
+22 SET ERRCODE=0
+23 FOR
SET ERRCODE=$ORDER(^AGERRAUD("D",ERRCODE))
IF 'ERRCODE
QUIT
Begin DoDot:1
+24 IF ASKSOME'="ALL"
IF ASKSOME'[(U_ERRCODE_U)
QUIT
+25 SET ERRNODE=$GET(^AGEDERRS(ERRCODE,0))
+26 SET ERRTYPE=$PIECE(ERRNODE,U,2)
+27 IF ERRTYPE'=CODETYPE&(CODETYPE'="B")
QUIT
+28 SET PTREC=0
+29 FOR NUMPT=1:1
SET PTREC=$ORDER(^AGERRAUD("D",ERRCODE,DTREC,PTREC))
IF 'PTREC
QUIT
Begin DoDot:2
+30 SET PDFN=$PIECE($GET(^AGERRAUD(DTREC,1,PTREC,0)),U)
+31 IF RPTTYPE="D"
Begin DoDot:3
+32 IF AORONE="A"
Begin DoDot:4
+33 SET FAC=0
+34 FOR
SET FAC=$ORDER(^AGERRAUD("E",FAC))
IF 'FAC
QUIT
Begin DoDot:5
+35 IF '$DATA(^AGERRAUD("E",FAC,PDFN))
QUIT
+36 IF $GET(^AGERRAUD("E",FAC,PDFN))<NEWMIN
QUIT
+37 SET ^XTMP("AGERRAUD",$JOB,FAC,ERRTYPE,ERRCODE,PDFN)=""
End DoDot:5
End DoDot:4
+38 IF AORONE="O"
Begin DoDot:4
+39 FOR SEL=1:1
SET FAC=$PIECE(FACSEL,",",SEL)
IF FAC=""
QUIT
Begin DoDot:5
+40 IF '$DATA(^AGERRAUD("E",FAC,PDFN))
QUIT
+41 IF $GET(^AGERRAUD("E",FAC,PDFN))<NEWMIN
QUIT
+42 SET ^XTMP("AGERRAUD",$JOB,FAC,ERRTYPE,ERRCODE,PDFN)=""
End DoDot:5
End DoDot:4
End DoDot:3
+43 IF RPTTYPE="S"
Begin DoDot:3
+44 IF AORONE="A"
Begin DoDot:4
+45 SET FAC=0
+46 FOR
SET FAC=$ORDER(^AGERRAUD("E",FAC))
IF 'FAC
QUIT
Begin DoDot:5
+47 IF '$DATA(^AGERRAUD("E",FAC,PDFN))
QUIT
+48 IF $GET(^AGERRAUD("E",FAC,PDFN))<NEWMIN
QUIT
+49 SET ^XTMP("AGERRAUD",$JOB,FAC,ERRTYPE,ERRCODE)=$PIECE($GET(^XTMP("AGERRAUD",$JOB,FAC,ERRTYPE,ERRCODE)),U)+1
End DoDot:5
End DoDot:4
+50 IF AORONE="O"
Begin DoDot:4
+51 FOR SEL=1:1
SET FAC=$PIECE(FACSEL,",",SEL)
IF FAC=""
QUIT
Begin DoDot:5
+52 IF '$DATA(^AGERRAUD("E",FAC,PDFN))
QUIT
+53 IF $GET(^AGERRAUD("E",FAC,PDFN))<NEWMIN
QUIT
+54 SET ^XTMP("AGERRAUD",$JOB,FAC,ERRTYPE,ERRCODE)=$PIECE($GET(^XTMP("AGERRAUD",$JOB,FAC,ERRTYPE,ERRCODE)),U)+1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+55 IF RPTTYPE="D"
DO DETAIL
QUIT
+56 ;AG*7.1*11 SAC REQ ROUTINE TOO LARGE
+57 ;D SUMMARY
+58 DO SUMMARY^AGERRAU1
+59 QUIT
DETAIL ;EP
+1 SET ESCAPE=0
+2 SET FAC=0
+3 ;AG*7.1*1 ADDED NEXT TWO LINES IM19869
+4 IF $GET(FACSEL)'=""
IF ('$DATA(^XTMP("AGERRAUD",$JOB,FACSEL)))
SET NOERR=1
WRITE !,"NO ERRORS FOUND"
IF $DATA(IO("SD"))
DO ^%ZISC
IF IOST'[("C-")
QUIT
IF $DATA(IO("S"))
QUIT
IF (IOST[("C-"))
KILL DIR
SET DIR(0)="E"
DO ^DIR
DO ^%ZISC
QUIT
+5 IF '$ORDER(^XTMP("AGERRAUD",$JOB,FAC))
SET NOERR=1
WRITE !,"NO ERRORS FOUND"
IF IOST'[("C-")
QUIT
IF $DATA(IO("S"))
QUIT
IF (IOST[("C-"))
KILL DIR
SET DIR(0)="E"
DO ^DIR
DO ^%ZISC
QUIT
+6 FOR
SET FAC=$ORDER(^XTMP("AGERRAUD",$JOB,FAC))
IF 'FAC
QUIT
Begin DoDot:1
+7 SET ERRTYPE=""
SET OLDERR=""
+8 FOR
SET ERRTYPE=$ORDER(^XTMP("AGERRAUD",$JOB,FAC,ERRTYPE))
IF ERRTYPE=""
QUIT
Begin DoDot:2
+9 SET ERRCODE=""
SET CODEOLD=""
+10 FOR
SET ERRCODE=$ORDER(^XTMP("AGERRAUD",$JOB,FAC,ERRTYPE,ERRCODE))
IF ERRCODE=""
QUIT
Begin DoDot:3
+11 ;AG*7.1*11 SAC REQ ROUTINE TOO LARGE
+12 ;I ERRCODE'=CODEOLD S CODEOLD=ERRCODE D PRTHDR,DETHDR(ERRCODE)
+13 IF ERRCODE'=CODEOLD
SET CODEOLD=ERRCODE
DO PRTHDR^AGERRAU1
DO DETHDR^AGERRAU1(ERRCODE)
+14 SET PDFN=""
+15 FOR
SET PDFN=$ORDER(^XTMP("AGERRAUD",$JOB,FAC,ERRTYPE,ERRCODE,PDFN))
IF PDFN=""
QUIT
Begin DoDot:4
+16 SET NUMPT=$PIECE($GET(^XTMP("AGERRAUD",$JOB,FAC,ERRTYPE,ERRCODE,PDFN)),U)
+17 SET PNAME=$PIECE($GET(^DPT(PDFN,0)),U)
+18 SET PDOB=$PIECE($GET(^DPT(PDFN,0)),U,3)
+19 SET PHRN=$PIECE($GET(^AUPNPAT(PDFN,41,FAC,0)),U,2)
+20 WRITE !,$EXTRACT(PNAME,1,20)
+21 WRITE ?22,PHRN
+22 IF $GET(DUZ(0))["@"
WRITE "("_PDFN_")"
+23 WRITE ?37,$PIECE($GET(^DIC(4,FAC,0)),U)
+24 SET Y=PDOB
XECUTE ^DD("DD")
SET PDOB=Y
+25 WRITE ?69,PDOB
+26 ;NOTE: HEADER IS 8 LINES
+27 ;ADDED A CHECK FOR SLAVE PRINTER IN ALL LINES BELOW WITH A DIR CALL AG*7.1*1 IM19869
+28 ;AG*7.1*11 SAC REQ ROUTINE TOO LARGE
+29 ;I ($Y>(IOSL-4)!($Y=(IOSL-4))),(IOST[("C-")) Q:$D(IO("S")) W ! K DIR S DIR(0)="E" D:'ESCAPE ^DIR S ESCAPE=X=U Q:'$O(^XTMP("AGERRAUD",$J,FAC,ERRTYPE,ERRCODE,PDFN)) D:'ESCAPE PRTHDR,DETHDR(ERRCODE) Q
+30 IF ($Y>(IOSL-4)!($Y=(IOSL-4)))
IF (IOST[("C-"))
IF $DATA(IO("S"))
QUIT
WRITE !
KILL DIR
SET DIR(0)="E"
IF 'ESCAPE
DO ^DIR
SET ESCAPE=X=U
IF '$ORDER(^XTMP("AGERRAUD",$JOB,FAC,ERRTYPE,ERRCODE,PDFN))
QUIT
IF 'ESCAPE
DO PRTHDR^AGERRAU1
DO DETHDR^AGERRAU1(ERRCODE)
QUIT
+31 ;AG*7.1*11 SAC REQ ROUTINE TOO LARGE
+32 ;I $Y>(IOSL-4)!($Y=(IOSL-4)) Q:'$O(^XTMP("AGERRAUD",$J,FAC,ERRTYPE,ERRCODE,PDFN)) D PRTHDR,DETHDR(ERRCODE) Q
+33 IF $Y>(IOSL-4)!($Y=(IOSL-4))
IF '$ORDER(^XTMP("AGERRAUD",$JOB,FAC,ERRTYPE,ERRCODE,PDFN))
QUIT
DO PRTHDR^AGERRAU1
DO DETHDR^AGERRAU1(ERRCODE)
QUIT
End DoDot:4
IF ESCAPE
QUIT
+34 IF ($Y<(IOSL-4)!($Y=(IOSL-4)))
IF (IOST[("C-"))
IF '$ORDER(^XTMP("AGERRAUD",$JOB,FAC,ERRTYPE,ERRCODE))
QUIT
IF $DATA(IO("S"))
QUIT
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET ESCAPE=X=U
End DoDot:3
IF ESCAPE
QUIT
+35 IF $Y<(IOSL-4)!($Y=(IOSL-4))
IF (IOST[("C-"))
IF '$ORDER(^XTMP("AGERRAUD",$JOB,FAC,ERRTYPE))
QUIT
IF $DATA(IO("S"))
QUIT
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET ESCAPE=X=U
End DoDot:2
IF ESCAPE
QUIT
+36 IF $Y<(IOSL-4)!($Y=(IOSL-4))
IF (IOST[("C-"))
IF '$ORDER(^XTMP("AGERRAUD",$JOB,FAC))
QUIT
IF $DATA(IO("S"))
QUIT
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET ESCAPE=X=U
End DoDot:1
IF ESCAPE
QUIT
+37 IF (IOST[("C-"))
IF ESCAPE
QUIT
IF $DATA(IO("S"))
QUIT
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET ESCAPE=X=U
+38 DO ^%ZISC
+39 QUIT
LOCSEL ;EP - DETERMINE IF ALL LOCATIONS OR SELECTED LOCATIONS
+1 SET FACSEL=""
+2 KILL DIR
+3 FOR I=1:1
Begin DoDot:1
+4 SET DIR("A")="Select Location "
+5 SET DIR("S")="I $D(^AGERRAUD(""E"",+Y))"
+6 SET DIR(0)="PO^9999999.06:EMZ"
+7 DO ^DIR
IF Y=-1
QUIT
+8 IF FACSEL=""
SET FACSEL=+Y
+9 IF '$TEST
SET FACSEL=FACSEL_","_+Y
+10 KILL DIR
End DoDot:1
IF X=""!($DATA(DTOUT))!($DATA(DUOUT))!($DATA(DIROUT))
QUIT
+11 QUIT
ASKLOC ;EP - ASK IF ALL LOCATIONS OR LET USER SELECT LOCATIONS
+1 KILL DIR,AORONE
+2 SET DIR(0)="SMX^A:All Locations;O:One Location"
+3 DO ^DIR
IF Y=-1
QUIT
+4 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))
QUIT
+5 SET AORONE=X
+6 QUIT
ASKDATE ;EP - ASK FOR BEGINNING DATE FOR THE REPORT. THE DEFAULT WILL
+1 ;BE 3 YEARS BACK.
+2 SET Y=DT-30000
XECUTE ^DD("DD")
+3 SET MINDT=Y
+4 WRITE !!,"The audit pulls all patients who are active in at least one facility,"
+5 WRITE !,"not deceased, have a last updated date of not more than three years"
+6 WRITE !,"ago, and have some form of an active insurance eligibility in"
+7 WRITE !,"Medicare, Medicaid, Private or Railroad insurance."
+8 WRITE !!,"Those patients whose DATE OF LAST REG UPDATE field is greater than"
+9 WRITE !,MINDT," are not included in this audit!"
+10 WRITE !
ASKAGAIN ;SHOW DEFAULT DATE AND CONFIRM
+1 KILL DIR
+2 SET DIR("A",1)="If you choose NO to continue, you will be prompted for a new date."
+3 SET DIR("A",2)="If you accept the default date, the report will include all of the"
+4 SET DIR("A",3)="patients that have been included in the audit file."
+5 SET DIR("A",4)=" "
+6 SET DIR("B")="YES"
+7 SET DIR("A")="Continue?"
+8 SET DIR(0)="Y"
+9 DO ^DIR
+10 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))
QUIT
+11 IF Y=1
SET NEWMIN=DT-30000
QUIT
DTAGAIN ;EP - PROMPT TO CHANGE BEGINNING DATE
+1 KILL DIR,NEWMIN
+2 SET DIR("B")=MINDT
+3 SET DIR(0)="DO"
+4 DO ^DIR
+5 IF Y<MINDT!(Y>DT)
WRITE !!,"The date must be between ",MINDT," and TODAY"
GOTO DTAGAIN
+6 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))
QUIT
+7 SET NEWMIN=Y
+8 XECUTE ^DD("DD")
+9 WRITE !!,"You have entered ",Y,!
+10 KILL DIR
+11 SET DIR("B")="YES"
+12 SET DIR("A")="Continue?"
+13 SET DIR(0)="Y"
+14 DO ^DIR
+15 IF Y=0
GOTO DTAGAIN
+16 QUIT
+17 ;DETERMINE WHAT SITE THE AUDIT WAS PERFORMED ON
ERRSITE() ;EP
+1 NEW PDFN
+2 QUIT $PIECE($GET(^AGERRAUD(1,0)),U,7)
EXIT ;EP - CLEANUP AND EXIT
+1 KILL ASKSOME,CENTER,ERRCODE,ERRDESCR,ERRNODE,ERRREC,ERRTYP,ERRTYPE,ESCAPE,NUMPT,PDFN,PDOB
+2 KILL PFAC,PHRN,PNAME,POP,PTREC,REPTIME,RPTTYPE
+3 KILL CODETYPE,PGNUM,FAC,UPDDATE,ERRRESP,^XTMP("AGERRAUD",$JOB)
+4 QUIT
