AGERRAUD.m

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))