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) ****************
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
K APCHDMPT,APCHS,APCHSDF1,APCHSEXD,APCHSTAX,APCHSTEX
Q
;
;
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
Q
;
;
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
Q
;
;
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
Q
;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
Q
;
;
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
Q
;
;
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
Q
;
;
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
Q
;
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 ;
Q
;
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 ;
Q
;
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 ;
Q
;
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) ****************
+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
+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 ;
