Routine: APCHS11G

APCHS11G ; IHS/CMI/LAB - HEALTH SUMMARY SURVEILLANCE ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ;PATCH 2 commented out writing of date

 ; *All DM surveillances use the data fetcher for value.  Data is

 ;  returned in array APCHS(1)

 ; ******** SURVEILLANCE - HARD CODE (for DM patients) ****************

DMFOOT ;ENTRY POINT - diabetic foot exam

 K APCHSEXD,APCHSDF1,APCHSTEX,APCHSTAX

 D DMCHK ;                      is patient diabetic?

 Q:'APCHDMPT

 K APCHS

 S APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST EXAM DIABETIC FOOT EXAM","APCHS(")

 G:APCHSERR DMFOOTX

 ; *array APCHS(1)="DATE^RESULT^EXAM^VXAM IEN^AUPNVXAM^VISIT IEN"

 K APCHSERR

 S APCHSDIS="DM FOOT EXAM, COMPLETE"

 S APCHSINT=365

 S APCHSEXD=$O(^AUTTEXAM("B","DIABETIC FOOT EXAM, COMPLETE",0))

 S APCHSDF1=9999999.15

 S APCHSIVD=$S($D(APCHS(1)):9999999-$P($P(APCHS(1),U,1),".",1),1:"")

 D DFSURV^APCHS11 ;            computes/print exam due date

DMFOOTX ;

 K APCHDMPT,APCHS,APCHSDF1,APCHSEXD,APCHSTAX,APCHSTEX

DMEYE ;ENTRY POINT - diabetic eye exam

 K APCHSEXD,APCHSDF1,APCHSTEX,APCHSTAX

 D DMCHK ;                      is patient diabetic?

 Q:'APCHDMPT

 K APCHS

 S APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST EXAM DIABETIC EYE EXAM","APCHS(")

 G:APCHSERR DMEYEX

 ; *array APCHS(1)="DATE^RESULT^EXAM^VXAM IEN^AUPNVXAM^VISIT IEN"

 K APCHSERR

 S APCHSDIS="DM EYE EXAM"

 S APCHSINT=365

 S APCHSEXD=$O(^AUTTEXAM("B","DIABETIC EYE EXAM",0))

 S APCHSDF1=9999999.15

 S APCHSIVD=$S($D(APCHS(1)):9999999-$P($P(APCHS(1),U,1),".",1),1:"")

 D DFSURV^APCHS11 ;            computes/print exam due date

DMEYEX ;

 K APCHDMPT,APCHS,APCHSDF1,APCHSEXD,APCHSTAX,APCHSTEX

DMCHOL ;ENTRY POINT - diabetic CHOLESTEROL lab

 K APCHSEXD,APCHSDF1,APCHSTEX,APCHSTAX

 D DMCHK

 Q:'APCHDMPT

 K APCHS

 S APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST LAB [DM AUDIT CHOLESTEROL TAX;","APCHS(")

 I APCHSERR D

 .  S:APCHSERR=7 APCHSTEX(1)="DM AUDIT CHOLESTEROL TAXONOMY does not",APCHSTEX(2)=" exist!  Unable to determine Cholesterol",APCHSTEX(3)=" status for this patient.",APCHSTEX(4)=" Notify Site Manager."

 .  S:APCHSERR'=7 APCHSTEX(1)="Unable to determine Cholesterol status",APCHSTEX(2)=" for this patient.  Notify Site Manager."

 .  Q

 ; *array APCHS(1)="DATE^RESULT^LAB TEST^VLAB IEN^AUPNVLAB^VISIT IEN"

 K APCHSERR

 S APCHSDIS="DM CHOLESTEROL"

 S APCHSINT=365

 S APCHSIVD=$S($D(APCHS(1)):9999999-$P($P(APCHS(1),U,1),".",1),1:"")

 S APCHSDF1=60,APCHSTAX=$O(^ATXLAB("B","DM AUDIT CHOLESTEROL TAX",0))

 D DFSURV^APCHS11 ;            computes/print cholesterol due date

DMCHOLX ;

 K APCHDMPT,APCHS,APCHSDF1,APCHSEXD,APCHSTAX,APCHSTEX

DMUPRO ;ENTRY POINT - diabetic urine protein

 K APCHSEXD,APCHSDF1,APCHSTEX,APCHSTAX

 D DMCHK

 Q:'APCHDMPT

 K APCHS

 S APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST LAB [DM AUDIT URINE PROTEIN TAX;","APCHS(")

 I APCHSERR D

 .  S:APCHSERR=7 APCHSTEX(1)="DM AUDIT URINE PROTEIN TAXONOMY does not",APCHSTEX(2)=" exist!  Unable to determine Urine Protein",APCHSTEX(3)=" status for this patient.",APCHSTEX(4)=" Notify Site Manager."

 .  S:APCHSERR'=7 APCHSTEX(1)="Unable to determine Urine Protein status",APCHSTEX(2)=" for this patient.  Notify Site Manager."

 .  Q

 ; *array APCHS(1)="DATE^RESULT^LAB TEST^VLAB IEN^AUPNVLAB^VISIT IEN"

 K APCHSERR

 S APCHSDIS="DM URINE PROTEIN"

 S APCHSINT=365

 S APCHSIVD=$S($D(APCHS(1)):9999999-$P($P(APCHS(1),U,1),".",1),1:"")

 S APCHSDF1=60,APCHSTAX=$O(^ATXLAB("B","DM AUDIT URINE PROTEIN TAX",0))

 D DFSURV^APCHS11 ;            computes/print cholesterol due date

 D DMCHK

 Q:'APCHDMPT

 K APCHS

DMUPROX ;

 K APCHDMPT,APCHS,APCHSDF1,APCHSEXD,APCHSTAX,APCHSTEX

 ;IHS/CMI/LAB moved line below from above

DMCREAT ;ENTRY POINT - diabetic CREATININE lab

 K APCHSEXD,APCHSDF1,APCHSTEX,APCHSTAX

 D DMCHK

 Q:'APCHDMPT

 K APCHS

 S APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST LAB [DM AUDIT CREATININE TAX;","APCHS(")

 I APCHSERR D

 .  S:APCHSERR=7 APCHSTEX(1)="DM AUDIT CREATININE TAXONOMY does not",APCHSTEX(2)=" exist!  Unable to determine Creatinine",APCHSTEX(3)=" status for this patient.",APCHSTEX(4)=" Notify Site Manager."

 .  S:APCHSERR'=7 APCHSTEX(1)="Unable to determine Creatinine status",APCHSTEX(2)=" for this patient.  Notify Site Manager."

 .  Q

 ; *array APCHS(1)="DATE^RESULT^LAB TEST^VLAB IEN^AUPNVLAB^VISIT IEN"

 K APCHSERR

 S APCHSDIS="DM CREATININE"

 S APCHSINT=365

 S APCHSIVD=$S($D(APCHS(1)):9999999-$P($P(APCHS(1),U,1),".",1),1:"")

 S APCHSDF1=60,APCHSTAX=$O(^ATXLAB("B","DM AUDIT CREATININE TAX",0))

 D DFSURV^APCHS11 ;            computes/print creatinine due date

DMCREATX ;

 K APCHDMPT,APCHS,APCHSDF1,APCHSEXD,APCHSTAX,APCHSTEX

DMTRIGL ;ENTRY POINT - diabetic TRIGLYCERIDE lab

 K APCHSEXD,APCHSDF1,APCHSTEX,APCHSTAX

 D DMCHK

 Q:'APCHDMPT

 K APCHS

 S APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST LAB [DM AUDIT TRIGLYCERIDE TAX;","APCHS(")

 I APCHSERR D

 .  S:APCHSERR=7 APCHSTEX(1)="DM AUDIT TRIGLYCERIDE TAXONOMY does not",APCHSTEX(2)=" exist!  Unable to determine Triglyceride",APCHSTEX(3)=" status for this patient.",APCHSTEX(4)=" Notify Site Manager."

 .  S:APCHSERR'=7 APCHSTEX(1)="Unable to determine Triglyceride status",APCHSTEX(2)=" for this patient.  Notify Site Manager."

 .  Q

 ; *array APCHS(1)="DATE^RESULT^LAB TEST^VLAB IEN^AUPNVLAB^VISIT IEN"

 K APCHSERR

 S APCHSDIS="DM TRIGLYCERIDE"

 S APCHSINT=365

 S APCHSIVD=$S($D(APCHS(1)):9999999-$P($P(APCHS(1),U,1),".",1),1:"")

 S APCHSDF1=60,APCHSTAX=$O(^ATXLAB("B","DM AUDIT TRIGLYCERIDE TAX",0))

 D DFSURV^APCHS11 ;            computes/print triglyceride due date

DMTRIGLX ;

 K APCHDMPT,APCHS,APCHSDF1,APCHSEXD,APCHSTAX,APCHSTEX

DMDENTL ;ENTRY POINT - diabetic DENTAL exam

 ;IHS/CMI/LAB - modified this sub routine

 K APCHSEXD,APCHSDF1,APCHSTEX,APCHSTAX

 D DMCHK

 Q:'APCHDMPT

 K APCHS

 S APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST ADA [DM AUDIT DENTAL EXAM ADA CODES;","APCHS(")

 I APCHSERR D

 .  S:APCHSERR=7 APCHSTEX(1)="DM AUDIT DENTAL EXAM TAXONOMY does not",APCHSTEX(2)=" exist!  Unable to determine Dental Exam",APCHSTEX(3)=" status for this patient.",APCHSTEX(4)=" Notify Site Manager."

 .  S:APCHSERR'=7 APCHSTEX(1)="Unable to determine Dental Exam status",APCHSTEX(2)=" for this patient.  Notify Site Manager."

 .  Q

 ; *array APCHS(1)="DATE^ADA CODE^ADA CODE^VDEN IEN^AUPNVDEN^VISIT IEN"

 K APCHSERR

 NEW DENTDATE S DENTDATE=$P($G(APCHS(1)),U)

 K APCHS

 NEW % S %=APCHSPAT_"^LAST EXAM DENTAL",E=$$START1^APCLDF(%,"APCHS(")

 S %=$P($G(APCHS(1)),U)

 S DENTDATE=$S(DENTDATE>%:DENTDATE,1:%)

 S APCHSEXD=$O(^AUTTEXAM("B","DENTAL EXAM",0))

 S APCHSDF1=9999999.15

 S APCHSDIS="DM DENTAL EXAM"

 S APCHSINT=365

 S APCHSIVD=$S(DENTDATE]"":9999999-DENTDATE,1:"")

 D DFSURV^APCHS11 ;            computes/print dental exam due date

DMDENTLX ;

 K APCHDMPT,APCHS,APCHSDF1,APCHSEXD,APCHSTAX,APCHSTEX

DMCHK ;is pt diabetic?             YES - APCHDMPT=1   NO - APCHDMPT=0

 S APCHDMPT=0

 D SURVDM ;                   is pt on SURVEILLANCE DIABETES taxonomy?

 G:APCHDMPT DMCHKX

 D PBLIST ;                  does a problem DM dx exist for pt?

 G:APCHDMPT DMCHKX

 D DMPOV ;                    does a DM pov exit for pt?

DMCHKX ;exit out of dm pt check

SURVDM ;check SURVEILLANCE DIABETES taxonomy for pt

 S APCHSURD=$O(^ATXAX("B","SURVEILLANCE DIABETES",""))

 Q:'APCHSURD

 S:$D(^ATXPAT(APCHSURD,11,APCHSPAT)) APCHDMPT=1

SURVDMX ;

PBLIST ;get first dm dx from problem list

 K APCHS

 S APCHSERR=$$START1^APCLDF(APCHSPAT_"^FIRST PROBLEM [DM AUDIT PROBLEM DIABETES DX","APCHS(")

 G:APCHSERR PBLISTX

 S:$D(APCHS(1)) APCHDMPT=1

PBLISTX ;

DMPOV ;does pt have a DM pov?

 K APCHS

 S APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST DX [SURVEILLANCE DIABETES","APCHS(")

 G:APCHSERR DMPOVX

 S:$D(APCHS(1)) APCHDMPT=1

DMPOVX ;

APCHS11G  ; IHS/CMI/LAB - HEALTH SUMMARY SURVEILLANCE ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;PATCH 2 commented out writing of date

 +3       ;

 +4       ;

 +5       ; *All DM surveillances use the data fetcher for value.  Data is

 +6       ;  returned in array APCHS(1)

 +7       ;

 +8       ; ******** SURVEILLANCE - HARD CODE (for DM patients) ****************

DMFOOT    ;ENTRY POINT - diabetic foot exam

 +1        KILL APCHSEXD,APCHSDF1,APCHSTEX,APCHSTAX

 +2       ;                      is patient diabetic?

           DO DMCHK

 +3        IF 'APCHDMPT

               QUIT

 +4        KILL APCHS

 +5        SET APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST EXAM DIABETIC FOOT EXAM","APCHS(")

 +6        IF APCHSERR

               GOTO DMFOOTX

 +7       ; *array APCHS(1)="DATE^RESULT^EXAM^VXAM IEN^AUPNVXAM^VISIT IEN"

 +8        KILL APCHSERR

 +9        SET APCHSDIS="DM FOOT EXAM, COMPLETE"

 +10       SET APCHSINT=365

 +11       SET APCHSEXD=$ORDER(^AUTTEXAM("B","DIABETIC FOOT EXAM, COMPLETE",0))

 +12       SET APCHSDF1=9999999.15

 +13       SET APCHSIVD=$SELECT($DATA(APCHS(1)):9999999-$PIECE($PIECE(APCHS(1),U,1),".",1),1:"")

 +14      ;            computes/print exam due date

           DO DFSURV^APCHS11

DMFOOTX   ;

 +1        KILL APCHDMPT,APCHS,APCHSDF1,APCHSEXD,APCHSTAX,APCHSTEX

 +2        QUIT

 +3       ;

 +4       ;

DMEYE     ;ENTRY POINT - diabetic eye exam

 +1        KILL APCHSEXD,APCHSDF1,APCHSTEX,APCHSTAX

 +2       ;                      is patient diabetic?

           DO DMCHK

 +3        IF 'APCHDMPT

               QUIT

 +4        KILL APCHS

 +5        SET APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST EXAM DIABETIC EYE EXAM","APCHS(")

 +6        IF APCHSERR

               GOTO DMEYEX

 +7       ; *array APCHS(1)="DATE^RESULT^EXAM^VXAM IEN^AUPNVXAM^VISIT IEN"

 +8        KILL APCHSERR

 +9        SET APCHSDIS="DM EYE EXAM"

 +10       SET APCHSINT=365

 +11       SET APCHSEXD=$ORDER(^AUTTEXAM("B","DIABETIC EYE EXAM",0))

 +12       SET APCHSDF1=9999999.15

 +13       SET APCHSIVD=$SELECT($DATA(APCHS(1)):9999999-$PIECE($PIECE(APCHS(1),U,1),".",1),1:"")

 +14      ;            computes/print exam due date

           DO DFSURV^APCHS11

DMEYEX    ;

 +1        KILL APCHDMPT,APCHS,APCHSDF1,APCHSEXD,APCHSTAX,APCHSTEX

 +2        QUIT

 +3       ;

 +4       ;

DMCHOL    ;ENTRY POINT - diabetic CHOLESTEROL lab

 +1        KILL APCHSEXD,APCHSDF1,APCHSTEX,APCHSTAX

 +2        DO DMCHK

 +3        IF 'APCHDMPT

               QUIT

 +4        KILL APCHS

 +5        SET APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST LAB [DM AUDIT CHOLESTEROL TAX;","APCHS(")

 +6        IF APCHSERR

               Begin DoDot:1

 +7                IF APCHSERR=7

                       SET APCHSTEX(1)="DM AUDIT CHOLESTEROL TAXONOMY does not"

                       SET APCHSTEX(2)=" exist!  Unable to determine Cholesterol"

                       SET APCHSTEX(3)=" status for this patient."

                       SET APCHSTEX(4)=" Notify Site Manager."

 +8                IF APCHSERR'=7

                       SET APCHSTEX(1)="Unable to determine Cholesterol status"

                       SET APCHSTEX(2)=" for this patient.  Notify Site Manager."

 +9                QUIT

               End DoDot:1

 +10      ; *array APCHS(1)="DATE^RESULT^LAB TEST^VLAB IEN^AUPNVLAB^VISIT IEN"

 +11       KILL APCHSERR

 +12       SET APCHSDIS="DM CHOLESTEROL"

 +13       SET APCHSINT=365

 +14       SET APCHSIVD=$SELECT($DATA(APCHS(1)):9999999-$PIECE($PIECE(APCHS(1),U,1),".",1),1:"")

 +15       SET APCHSDF1=60

           SET APCHSTAX=$ORDER(^ATXLAB("B","DM AUDIT CHOLESTEROL TAX",0))

 +16      ;            computes/print cholesterol due date

           DO DFSURV^APCHS11

DMCHOLX   ;

 +1        KILL APCHDMPT,APCHS,APCHSDF1,APCHSEXD,APCHSTAX,APCHSTEX

 +2        QUIT

 +3       ;

 +4       ;

DMUPRO    ;ENTRY POINT - diabetic urine protein

 +1        KILL APCHSEXD,APCHSDF1,APCHSTEX,APCHSTAX

 +2        DO DMCHK

 +3        IF 'APCHDMPT

               QUIT

 +4        KILL APCHS

 +5        SET APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST LAB [DM AUDIT URINE PROTEIN TAX;","APCHS(")

 +6        IF APCHSERR

               Begin DoDot:1

 +7                IF APCHSERR=7

                       SET APCHSTEX(1)="DM AUDIT URINE PROTEIN TAXONOMY does not"

                       SET APCHSTEX(2)=" exist!  Unable to determine Urine Protein"

                       SET APCHSTEX(3)=" status for this patient."

                       SET APCHSTEX(4)=" Notify Site Manager."

 +8                IF APCHSERR'=7

                       SET APCHSTEX(1)="Unable to determine Urine Protein status"

                       SET APCHSTEX(2)=" for this patient.  Notify Site Manager."

 +9                QUIT

               End DoDot:1

 +10      ; *array APCHS(1)="DATE^RESULT^LAB TEST^VLAB IEN^AUPNVLAB^VISIT IEN"

 +11       KILL APCHSERR

 +12       SET APCHSDIS="DM URINE PROTEIN"

 +13       SET APCHSINT=365

 +14       SET APCHSIVD=$SELECT($DATA(APCHS(1)):9999999-$PIECE($PIECE(APCHS(1),U,1),".",1),1:"")

 +15       SET APCHSDF1=60

           SET APCHSTAX=$ORDER(^ATXLAB("B","DM AUDIT URINE PROTEIN TAX",0))

 +16      ;            computes/print cholesterol due date

           DO DFSURV^APCHS11

 +17       DO DMCHK

 +18       IF 'APCHDMPT

               QUIT

 +19       KILL APCHS

DMUPROX   ;

 +1        KILL APCHDMPT,APCHS,APCHSDF1,APCHSEXD,APCHSTAX,APCHSTEX

 +2        QUIT

 +3       ;IHS/CMI/LAB moved line below from above

DMCREAT   ;ENTRY POINT - diabetic CREATININE lab

 +1        KILL APCHSEXD,APCHSDF1,APCHSTEX,APCHSTAX

 +2        DO DMCHK

 +3        IF 'APCHDMPT

               QUIT

 +4        KILL APCHS

 +5        SET APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST LAB [DM AUDIT CREATININE TAX;","APCHS(")

 +6        IF APCHSERR

               Begin DoDot:1

 +7                IF APCHSERR=7

                       SET APCHSTEX(1)="DM AUDIT CREATININE TAXONOMY does not"

                       SET APCHSTEX(2)=" exist!  Unable to determine Creatinine"

                       SET APCHSTEX(3)=" status for this patient."

                       SET APCHSTEX(4)=" Notify Site Manager."

 +8                IF APCHSERR'=7

                       SET APCHSTEX(1)="Unable to determine Creatinine status"

                       SET APCHSTEX(2)=" for this patient.  Notify Site Manager."

 +9                QUIT

               End DoDot:1

 +10      ; *array APCHS(1)="DATE^RESULT^LAB TEST^VLAB IEN^AUPNVLAB^VISIT IEN"

 +11       KILL APCHSERR

 +12       SET APCHSDIS="DM CREATININE"

 +13       SET APCHSINT=365

 +14       SET APCHSIVD=$SELECT($DATA(APCHS(1)):9999999-$PIECE($PIECE(APCHS(1),U,1),".",1),1:"")

 +15       SET APCHSDF1=60

           SET APCHSTAX=$ORDER(^ATXLAB("B","DM AUDIT CREATININE TAX",0))

 +16      ;            computes/print creatinine due date

           DO DFSURV^APCHS11

DMCREATX  ;

 +1        KILL APCHDMPT,APCHS,APCHSDF1,APCHSEXD,APCHSTAX,APCHSTEX

 +2        QUIT

 +3       ;

 +4       ;

DMTRIGL   ;ENTRY POINT - diabetic TRIGLYCERIDE lab

 +1        KILL APCHSEXD,APCHSDF1,APCHSTEX,APCHSTAX

 +2        DO DMCHK

 +3        IF 'APCHDMPT

               QUIT

 +4        KILL APCHS

 +5        SET APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST LAB [DM AUDIT TRIGLYCERIDE TAX;","APCHS(")

 +6        IF APCHSERR

               Begin DoDot:1

 +7                IF APCHSERR=7

                       SET APCHSTEX(1)="DM AUDIT TRIGLYCERIDE TAXONOMY does not"

                       SET APCHSTEX(2)=" exist!  Unable to determine Triglyceride"

                       SET APCHSTEX(3)=" status for this patient."

                       SET APCHSTEX(4)=" Notify Site Manager."

 +8                IF APCHSERR'=7

                       SET APCHSTEX(1)="Unable to determine Triglyceride status"

                       SET APCHSTEX(2)=" for this patient.  Notify Site Manager."

 +9                QUIT

               End DoDot:1

 +10      ; *array APCHS(1)="DATE^RESULT^LAB TEST^VLAB IEN^AUPNVLAB^VISIT IEN"

 +11       KILL APCHSERR

 +12       SET APCHSDIS="DM TRIGLYCERIDE"

 +13       SET APCHSINT=365

 +14       SET APCHSIVD=$SELECT($DATA(APCHS(1)):9999999-$PIECE($PIECE(APCHS(1),U,1),".",1),1:"")

 +15       SET APCHSDF1=60

           SET APCHSTAX=$ORDER(^ATXLAB("B","DM AUDIT TRIGLYCERIDE TAX",0))

 +16      ;            computes/print triglyceride due date

           DO DFSURV^APCHS11

DMTRIGLX  ;

 +1        KILL APCHDMPT,APCHS,APCHSDF1,APCHSEXD,APCHSTAX,APCHSTEX

 +2        QUIT

 +3       ;

 +4       ;

DMDENTL   ;ENTRY POINT - diabetic DENTAL exam

 +1       ;IHS/CMI/LAB - modified this sub routine

 +2        KILL APCHSEXD,APCHSDF1,APCHSTEX,APCHSTAX

 +3        DO DMCHK

 +4        IF 'APCHDMPT

               QUIT

 +5        KILL APCHS

 +6        SET APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST ADA [DM AUDIT DENTAL EXAM ADA CODES;","APCHS(")

 +7        IF APCHSERR

               Begin DoDot:1

 +8                IF APCHSERR=7

                       SET APCHSTEX(1)="DM AUDIT DENTAL EXAM TAXONOMY does not"

                       SET APCHSTEX(2)=" exist!  Unable to determine Dental Exam"

                       SET APCHSTEX(3)=" status for this patient."

                       SET APCHSTEX(4)=" Notify Site Manager."

 +9                IF APCHSERR'=7

                       SET APCHSTEX(1)="Unable to determine Dental Exam status"

                       SET APCHSTEX(2)=" for this patient.  Notify Site Manager."

 +10               QUIT

               End DoDot:1

 +11      ; *array APCHS(1)="DATE^ADA CODE^ADA CODE^VDEN IEN^AUPNVDEN^VISIT IEN"

 +12       KILL APCHSERR

 +13       NEW DENTDATE

           SET DENTDATE=$PIECE($GET(APCHS(1)),U)

 +14       KILL APCHS

 +15       NEW %

           SET %=APCHSPAT_"^LAST EXAM DENTAL"

           SET E=$$START1^APCLDF(%,"APCHS(")

 +16       SET %=$PIECE($GET(APCHS(1)),U)

 +17       SET DENTDATE=$SELECT(DENTDATE>%:DENTDATE,1:%)

 +18       SET APCHSEXD=$ORDER(^AUTTEXAM("B","DENTAL EXAM",0))

 +19       SET APCHSDF1=9999999.15

 +20       SET APCHSDIS="DM DENTAL EXAM"

 +21       SET APCHSINT=365

 +22       SET APCHSIVD=$SELECT(DENTDATE]"":9999999-DENTDATE,1:"")

 +23      ;            computes/print dental exam due date

           DO DFSURV^APCHS11

DMDENTLX  ;

 +1        KILL APCHDMPT,APCHS,APCHSDF1,APCHSEXD,APCHSTAX,APCHSTEX

 +2        QUIT

 +3       ;

 +4       ;

DMCHK     ;is pt diabetic?             YES - APCHDMPT=1   NO - APCHDMPT=0

 +1        SET APCHDMPT=0

 +2       ;                   is pt on SURVEILLANCE DIABETES taxonomy?

           DO SURVDM

 +3        IF APCHDMPT

               GOTO DMCHKX

 +4       ;                  does a problem DM dx exist for pt?

           DO PBLIST

 +5        IF APCHDMPT

               GOTO DMCHKX

 +6       ;                    does a DM pov exit for pt?

           DO DMPOV

DMCHKX    ;exit out of dm pt check

 +1        QUIT

 +2       ;

SURVDM    ;check SURVEILLANCE DIABETES taxonomy for pt

 +1        SET APCHSURD=$ORDER(^ATXAX("B","SURVEILLANCE DIABETES",""))

 +2        IF 'APCHSURD

               QUIT

 +3        IF $DATA(^ATXPAT(APCHSURD,11,APCHSPAT))

               SET APCHDMPT=1

SURVDMX   ;

 +1        QUIT

 +2       ;

PBLIST    ;get first dm dx from problem list

 +1        KILL APCHS

 +2        SET APCHSERR=$$START1^APCLDF(APCHSPAT_"^FIRST PROBLEM [DM AUDIT PROBLEM DIABETES DX","APCHS(")

 +3        IF APCHSERR

               GOTO PBLISTX

 +4        IF $DATA(APCHS(1))

               SET APCHDMPT=1

PBLISTX   ;

 +1        QUIT

 +2       ;

DMPOV     ;does pt have a DM pov?

 +1        KILL APCHS

 +2        SET APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST DX [SURVEILLANCE DIABETES","APCHS(")

 +3        IF APCHSERR

               GOTO DMPOVX

 +4        IF $DATA(APCHS(1))

               SET APCHDMPT=1

DMPOVX    ;

 +1        QUIT

 +2       ;

APCHS11G.m