APCLDE31.m

APCLDE31 ; IHS/CMI/LAB - list DEPRESSION screenings ; 

 ;;2.0;IHS PCC SUITE;**2,4,8,10**;MAY 14, 2009;Build 88

 ;

 ;

PROC ;

 S APCLCNT=0

 S APCLH=$H,APCLJ=$J

 K ^XTMP("APCLDE3",APCLJ,APCLH)

 D XTMP^APCLOSUT("APCLDE3","DEPRESSION SCREENING REPORT")

 ;go through exam DEPRESSION, then through AUPNPREF for refusals

 S DFN=0 F  S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN  D

 .Q:'$D(^DPT(DFN,0))

 .Q:$P(^DPT(DFN,0),U,19)  ;merged away

 .I APCLSEX'[$P(^DPT(DFN,0),U,2) Q  ;not right gender

 .I APCLDESP]"",$P($G(^APCPATR(DFN,0)),U,2)'=APCLDESP Q  ;not correct designated mh provider

 .I APCLSSP]"",$P($G(^APCPATR(DFN,0)),U,3)'=APCLSSP Q

 .I APCLCDP]"",$P($G(^APCPATR(DFN,0)),U,4)'=APCLCDP Q

 .S APCALSC="" I APCLEXPC S APCALSC=$$BHALCS(DFN,APCLBD,APCLED),APCPFI="BH"  ;include refusals

 .S APCPCALS="" S APCPCALS=$$PCCALCS(DFN,APCLBD,APCLED)  ;include refusals

 .I $P(APCPCALS,U,1)>$P(APCALSC,U,1) S APCALSC=APCPCALS,APCPFI="PCC"

 .S APCLEFS="" S APCLEFS=$$REFUSAL(DFN,9999999.15,$O(^AUTTEXAM("C",36,0)),APCLBD,APCLED)

 .I $P(APCLEFS,U,1)>$P(APCALSC,U,1) S APCALSC=APCLEFS,APCPFI="PCC"

 .I APCALSC="" Q  ;no screenings

 .S ^XTMP("APCLDE3",APCLJ,APCLH,"PTS",DFN)=APCALSC,$P(^XTMP("APCLDE3",APCLJ,APCLH,"PTS",DFN),U,20)=APCPFI

 .Q

 Q

BHALCS(P,BDATE,EDATE) ;

 I '$G(P) Q ""

 I '$G(BDATE) Q ""

 I '$G(EDATE) Q ""

 ;loop through all of this patient's visits in date range

 NEW SDATE,X,V,D,R,M,E

 S R=""

 S SDATE=9999999-$$FMADD^XLFDT(EDATE,1),SDATE=SDATE_".9999"

 F  S SDATE=$O(^AMHREC("AE",P,SDATE)) Q:SDATE'=+SDATE!($P(SDATE,".")>(9999999-BDATE))!(R]"")  D

 .S V=0 F  S V=$O(^AMHREC("AE",P,SDATE,V)) Q:V'=+V!(R]"")  D

 ..Q:'$D(^AMHREC(V,0))

 ..;Q:'$$ALLOWVI^APCUTIL(DUZ,V)

 ..S APCLDATE=$P($P(^AMHREC(V,0),U),".")

 ..S X=$$AGE^AUPNPAT(DFN,APCLDATE)

 ..I $D(APCLAGET),X>$P(APCLAGET,"-",2) Q

 ..I $D(APCLAGET),X<$P(APCLAGET,"-",1) Q

 ..;clinic check

 ..I $D(APCLCLNT) S X=$P(^AMHREC(V,0),U,25) Q:X=""  Q:'$D(APCLCLNT(X))

 ..;PRIMARY PROVIDER CHECK

 ..S X=$$BHPPIN(V)

 ..I $D(APCLPROV),X="" Q  ;want only certain primary providers on visit

 ..I $D(APCLPROV),APCLPROV'=X Q  ;want one provider and it's not this one

 ..I APCLPPUN,X'="" Q  ;want only unknown and this one has a primary provider

 ..;get measurements AUDC, AUDT, CRFTT

 ..S X=0 F  S X=$O(^AMHRMSR("AD",V,X)) Q:X'=+X!(R]"")  D

 ...S M=$$VAL^XBDIQ1(9002011.12,X,.01)

 ...I M="PHQ2"!(M="PHQ9") D

 ....S E=$P($G(^AMHRMSR(X,12)),U,4)

 ....I $D(APCLSPRV),E="" Q  ;want only certain SCR providers on visit

 ....I $D(APCLSPRV),APCLSPRV'=E Q  ;want one provider and it's not this one

 ....I APCLSPUN,E'="" Q  ;want only unknown and this one has a SCR provider

 ....;check result

 ....S E=$P(^AMHRMSR(X,0),U,4)

 ....I M="PHQ2",E="",'$D(APCLREST(5)) Q

 ....I M="PHQ2",E<3,'$D(APCLREST(1)) Q

 ....I M="PHQ2",E>2,'$D(APCLREST(2)) Q

 ....I M="PHQ9",E="",'$D(APCLREST(5)) Q

 ....I M="PHQ9",E<5,'$D(APCLREST(1)) Q

 ....I M="PHQ9",E>4,'$D(APCLREST(2)) Q

 ....I M="PHQT",E="",'$D(APCLREST(5)) Q

 ....I M="PHQT",E<11,'$D(APCLREST(1)) Q

 ....I M="PHQT",E>10,'$D(APCLREST(2)) Q

 ....S R=$$BHRT(V,M,$P(^AMHRMSR(X,0),U,4),P,$$VALI^XBDIQ1(9002011.12,X,1204))

 ..I R]"" Q

 ..;get exam

 ..S E=$P($G(^AMHREC(V,14)),U,3)

 ..I E="" G BHHF

 ..S APCLRES=$$VAL^XBDIQ1(9002011,V,1403) S:APCLRES["REFUSED" APCLRES="REFUSED SCREENING" S:APCLRES["NEGATIVE" APCLRES="NEGATIVE"

 ..I APCLRES="NEGATIVE",'$D(APCLREST(1)) G BHHF

 ..I APCLRES="POSITIVE",'$D(APCLREST(2)) G BHHF

 ..I APCLRES["REFUSED",'$D(APCLREST(3)) G BHHF  ;do not want refusals

 ..I APCLRES["UNABLE",'$D(APCLREST(4)) G BHHF  ;do not want unables

 ..I APCLRES="",'$D(APCLREST(5)) G BHHF

 ..S E=$P($G(^AMHREC(V,14)),U,4)

 ..I $D(APCLSPRV),E="" G BHHF  ;want only certain SCR providers on visit

 ..I $D(APCLSPRV),APCLSPRV'=E G BHHF  ;want one provider and it's not this one

 ..I APCLSPUN,E'="" G BHHF  ;want only unknown and this one has a SCR provider

 ..S R=$$BHRT(V,"DEPRESSION SCREENING",$$VAL^XBDIQ1(9002011,V,1403),P,$P($G(^AMHREC(V,14)),U,4),$P($G(^AMHREC(V,16)),U,1))

 ..I R]"" Q

BHHF ..;

 ..I $D(APCLREST(5)) S X=0 F  S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(R]"")  D

 ...S M=$$VAL^XBDIQ1(9002011.01,X,.01)

 ...I M="14.1"!(M="V79.0") S R=$$BHRT(V,M,"",P,$$VALI^XBDIQ1(9002011.01,X,1204))

 ..I R]"" Q

 ..I $D(APCLREST(5)) S X=0 F  S X=$O(^AMHREDU("AD",V,X)) Q:X'=+X!(R]"")  D

 ...S M=$$VAL^XBDIQ1(9002011.05,X,.01)

 ...I M="DEP-SCR" S R=$$BHRT(V,M,"",P,$$VALI^XBDIQ1(9002011.05,X,.04),$P($G(^AMHREDU(V,11)),U,1))

 ..I R]"" Q

 Q R

BHRT(V,TYPE,RES,PAT,PROVSCRN,COMMENT) ;

 S PROVSCRN=$G(PROVSCRN)

 S COMMENT=$G(COMMENT)

 NEW T,D

 S (D,T)=$P($P(^AMHREC(V,0),U),".")

 S $P(T,U,2)=TYPE_";"_RES

 S $P(T,U,3)=$P(^DPT(PAT,0),U,2)

 S $P(T,U,4)=$$AGE^AUPNPAT(PAT,D)

 S $P(T,U,5)=$S($G(PROVSCRN)]"":$P(^VA(200,PROVSCRN,0),U),1:"UNKNOWN")

 S $P(T,U,6)=$$VAL^XBDIQ1(9002011,V,.25)

 S $P(T,U,7)=$$BHPPNAME(V)

 S $P(T,U,8)=$$VAL^XBDIQ1(9002011.55,PAT,.02)

 S $P(T,U,9)=$$VAL^XBDIQ1(9002011.55,PAT,.03)

 S $P(T,U,10)=$$VAL^XBDIQ1(9002011.55,PAT,.04)

 S $P(T,U,11)=$$VAL^XBDIQ1(9000001,PAT,.14)

 S $P(T,U,13)=V

 S $P(T,U,12)=COMMENT

 S $P(T,U,15)=PAT

 S $P(T,U,20)="BH"

 Q T

 ;

PCCALCS(P,BDATE,EDATE) ;EP - get alcohol screening from pcc

 I '$G(P) Q ""

 I '$G(BDATE) Q ""

 I '$G(EDATE) Q ""

 NEW T

 ;S T=$$LASTALC^APCAPI(P,BDATE,EDATE,"A")

 NEW R,V,APCLDATE,SDATE

 S R=""

 S SDATE=9999999-$$FMADD^XLFDT(EDATE,1),SDATE=SDATE_".9999"

 F  S SDATE=$O(^AUPNVSIT("AA",P,SDATE)) Q:SDATE'=+SDATE!($P(SDATE,".")>(9999999-BDATE))!(R]"")  D

 .S V=0 F  S V=$O(^AUPNVSIT("AA",P,SDATE,V)) Q:V'=+V!(R]"")  D

 ..Q:'$D(^AUPNVSIT(V,0))

 ..;Q:'$$ALLOWPCC^APCUTIL(DUZ,V)

 ..I 'APCLEXPC S C=$$CLINIC^APCLV(V,"C") I C=14!(C=43)!(C=48)!(C="C4")!(C="C9") Q

 ..I APCLEXPC,$D(^AHHREC("AVISIT",V)) Q  ;in BH module so already got it

 ..S APCLDATE=$P($P(^AUPNVSIT(V,0),U),".")

 ..S DFN=$P(^AUPNVSIT(V,0),U,5)

 ..Q:DFN=""

 ..;Q:'$$ALLOWP^APCUTIL(DUZ,DFN)

 ..S X=$$AGE^AUPNPAT(DFN,APCLDATE)

 ..I $D(APCLAGET),X>$P(APCLAGET,"-",2) Q

 ..I $D(APCLAGET),X<$P(APCLAGET,"-",1) Q

 ..;clinic check

 ..I $D(APCLCLNT) S X=$P(^AUPNVSIT(V,0),U,8) Q:X=""  Q:'$D(APCLCLNT(X))

 ..;PRIMARY PROVIDER CHECK

 ..S X=$$PRIMPROV^APCLV(V)

 ..I $D(APCLPROV),X="" Q  ;want only certain primary providers on visit

 ..I $D(APCLPROV),APCLPROV'=X Q  ;want one provider and it's not this one

 ..I APCLPPUN,X'="" Q  ;want only unknown and this one has a primary provider

 ..S R=$$PCCSCR(V)

 Q R

PCCSCR(V) ;is there a screening?  return in R

 ;get measurements AUDC, AUDT, CRFTT

 NEW R,X,M,P,E

 S R=""

 S P=$P(^AUPNVSIT(V,0),U,5)

 S D=$P($P(^AUPNVSIT(V,0),U),".")

 S X=0 F  S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X  D

 .Q:$P($G(^AUPNVMSR(X,2)),U,1)

 .S M=$$VAL^XBDIQ1(9000010.01,X,.01)

 .I M="PHQ2"!(M="PHQ9")!(M="PHQT") D

 ..S E=$P($G(^AUPNVMSR(X,12)),U,4)

 ..I $D(APCLSPRV),E="" Q  ;want only certain SCR providers on visit

 ..I $D(APCLSPRV),APCLSPRV'=E Q  ;want one provider and it's not this one

 ..I APCLSPUN,E'="" Q  ;want only unknown and this one has a SCR provider

 ..;check result

 ..S E=$P(^AUPNVMSR(X,0),U,4)

 ..I M="PHQ2",E="",'$D(APCLREST(5)) Q

 ..I M="PHQ2",E<3,'$D(APCLREST(1)) Q

 ..I M="PHQ2",E>2,'$D(APCLREST(2)) Q

 ..I M="PHQ9",E="",'$D(APCLREST(5)) Q

 ..I M="PHQ9",E<5,'$D(APCLREST(1)) Q

 ..I M="PHQ9",E>4,'$D(APCLREST(2)) Q

 ..I M="PHQT",E="",'$D(APCLREST(5)) Q

 ..I M="PHQT",E<11,'$D(APCLREST(1)) Q

 ..I M="PHQT",E>10,'$D(APCLREST(2)) Q

 ..S T=D_U_M_U_$$VAL^XBDIQ1(9000010.01,X,.04)_U_V_U_9000010.01_U_X

 ..S R=$$PCCV^APCLDE1(T,P)

 I R]"" Q R

 ;get exam

 S X=0 F  S X=$O(^AUPNVXAM("AD",V,X)) Q:X'=+X  D

 .S M=$$VAL^XBDIQ1(9000010.13,X,.01)

 .I M="DEPRESSION SCREENING" D

 ..S E=$P($G(^AUPNVXAM(X,12)),U,4)

 ..I $D(APCLSPRV),E="" Q  ;want only certain SCR providers on visit

 ..I $D(APCLSPRV),APCLSPRV'=E Q  ;want one provider and it's not this one

 ..I APCLSPUN,E'="" Q  ;want only unknown and this one has a SCR provider

 ..;check result

 ..S E=$P(^AUPNVXAM(X,0),U,4)

 ..I E="",'$D(APCLREST(5)) Q

 ..I E="N",'$D(APCLREST(1)) Q

 ..I E="PO",'$D(APCLREST(2)) Q

 ..S T=D_U_M_U_$$VAL^XBDIQ1(9000010.13,X,.04)_U_V_U_9000010.13_U_X

 ..S R=$$PCCV^APCLDE1(T,P)

 I R]"" Q R

 ;get pov

 I $D(APCLREST(5)) S X=0 F  S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X  D

 .S M=$$VAL^XBDIQ1(9000010.07,X,.01)

 .I M="V79.0" D

 ..S T=D_U_M_U_U_V_U_9000010.07_U_X

 ..S R=$$PCCV^APCLDE1(T,P)

 I R]"" Q R

 ;get education

 I $D(APCLREST(5)) S X=0 F  S X=$O(^AUPNVPED("AD",V,X)) Q:X'=+X  D

 .S M=$$VAL^XBDIQ1(9000010.16,X,.01)

 .I M="DEP-SCR" D

 ..S T=D_U_M_U_U_V_U_9000010.16_U_X

 ..S R=$$PCCV^APCLDE1(T,P)

 I R]"" Q R

 Q R

 ;

REFUSAL(PAT,F,I,B,E) ;EP

 I '$G(PAT) Q ""

 I '$G(F) Q ""

 I '$G(I) Q ""

 I $G(B)="" Q ""

 I $G(E)="" Q ""

 NEW T,X,Y,%DT S X=B,%DT="P" D ^%DT S B=Y

 S X=E,%DT="P" D ^%DT S E=Y

 S (X,T)="" F  S X=$O(^AUPNPREF("AA",PAT,F,I,X)) Q:X'=+X!(T]"")  S Y=0 F  S Y=$O(^AUPNPREF("AA",PAT,F,I,X,Y)) Q:Y'=+Y  S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) D

 .S T=D

 .S $P(T,U,2)="REFUSED;"_$$VAL^XBDIQ1(9000022,Y,.07)

 .S $P(T,U,3)=$P(^DPT(PAT,0),U,2)

 .S $P(T,U,4)=$$AGE^AUPNPAT(PAT,D)

 .S $P(T,U,5)=$$VAL^XBDIQ1(9000022,Y,1204) I $P(T,U,5)="" S $P(T,U,5)="UNKNOWN"

 .S $P(T,U,6)="UNKNOWN"

 .S $P(T,U,7)="UNKNOWN"

 .S $P(T,U,8)=$$VAL^XBDIQ1(9002011.55,PAT,.02)

 .S $P(T,U,9)=$$VAL^XBDIQ1(9002011.55,PAT,.03)

 .S $P(T,U,10)=$$VAL^XBDIQ1(9002011.55,PAT,.04)

 .S $P(T,U,11)=$$VAL^XBDIQ1(9000001,PAT,.14)

 Q T

PCCV(S,PAT) ;

 NEW T

 S T=""

 S $P(T,U)=$P(S,U)

 S $P(T,U,2)=$P(S,U,2)_";"_$P(S,U,3)

 S $P(T,U,3)=$P(^DPT(PAT,0),U,2)

 S $P(T,U,4)=$$AGE^AUPNPAT(PAT,$P(S,U))

 S $P(T,U,5)=$$SCRNPCC(S)

 S $P(T,U,6)=$$VAL^XBDIQ1(9000010,$P(S,U,4),.08)

 S $P(T,U,7)=$$PRIMPROV^APCLV($P(S,U,4),"N")

 S $P(T,U,8)=$$VAL^XBDIQ1(9002011.55,PAT,.02)

 S $P(T,U,9)=$$VAL^XBDIQ1(9002011.55,PAT,.03)

 S $P(T,U,10)=$$VAL^XBDIQ1(9002011.55,PAT,.04)

 S $P(T,U,11)=$$VAL^XBDIQ1(9000001,PAT,.14)

 S $P(T,U,14)=$P(S,U,4)

 S $P(T,U,15)=PAT

 S $P(T,U,20)="PCC"

 Q T

SCRNPCC(T) ;get screening provider based on v file

 NEW S,F

 S F=1204

 I $P(T,U,5)=9000010.16!($P(T,U,5)=9000010.23) S F=".05"

 S S=$$VAL^XBDIQ1($P(T,U,5),$P(T,U,6),F)

 I S]"" Q S

 Q "UNKNOWN"

BHPPIN(R) ;

 NEW %,%1

 S %=0,%1="" F  S %=$O(^AMHRPROV("AD",R,%)) Q:%'=+%  I $P(^AMHRPROV(%,0),U,4)="P" S %1=$P(^AMHRPROV(%,0),U)

 Q %1

BHPPNAME(R) ;EP primary provider internal # from 200

 NEW %,%1

 S %=0,%1="" F  S %=$O(^AMHRPROV("AD",R,%)) Q:%'=+%  I $P(^AMHRPROV(%,0),U,4)="P" S %1=$P(^AMHRPROV(%,0),U),%1=$P($G(^VA(200,%1,0)),U)

 I %1]"" Q %1

 Q "UNKNOWN"

SPRV(E) ;

 I $P($G(^AUPNVXAM(E,12)),U,4) Q $$VAL^XBDIQ1(9000010.13,E,1204)

 Q "UNKNOWN"

PRVREF(R) ;

 I $P($G(^AUPNPREF(R,12)),U,4)]"" Q $$VAL^XBDIQ1(9000022,R,1204)

 Q "UNKNOWN"

PPV(V) ;

 NEW %

 S %=$$PRIMPROV^APCLV(V,"N")

 I %]"" Q %

 Q "UNKNOWN"

CTR(X,Y) ;EP - Center X in a field Y wide.

 Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X

 ;----------

EOP ;EP - End of page.

 Q:$E(IOST)'="C"

 Q:IO'=IO(0)

 Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))

 NEW DIR

 K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT

 W !

 S DIR("A")="End of Report.  Press Enter",DIR(0)="E" D ^DIR

 Q

 ;----------

USR() ;EP - Return name of current user from ^VA(200.

 Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")

 ;----------

LOC() ;EP - Return location name from file 4 based on DUZ(2).

 Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")

 ;----------

APCLDE31  ; IHS/CMI/LAB - list DEPRESSION screenings ; 

 +1       ;;2.0;IHS PCC SUITE;**2,4,8,10**;MAY 14, 2009;Build 88

 +2       ;

 +3       ;

PROC      ;

 +1        SET APCLCNT=0

 +2        SET APCLH=$HOROLOG

           SET APCLJ=$JOB

 +3        KILL ^XTMP("APCLDE3",APCLJ,APCLH)

 +4        DO XTMP^APCLOSUT("APCLDE3","DEPRESSION SCREENING REPORT")

 +5       ;go through exam DEPRESSION, then through AUPNPREF for refusals

 +6        SET DFN=0

           FOR 

               SET DFN=$ORDER(^AUPNPAT(DFN))

               IF DFN'=+DFN

                   QUIT 

               Begin DoDot:1

 +7                IF '$DATA(^DPT(DFN,0))

                       QUIT 

 +8       ;merged away

                   IF $PIECE(^DPT(DFN,0),U,19)

                       QUIT 

 +9       ;not right gender

                   IF APCLSEX'[$PIECE(^DPT(DFN,0),U,2)

                       QUIT 

 +10      ;not correct designated mh provider

                   IF APCLDESP]""

                       IF $PIECE($GET(^APCPATR(DFN,0)),U,2)'=APCLDESP

                           QUIT 

 +11               IF APCLSSP]""

                       IF $PIECE($GET(^APCPATR(DFN,0)),U,3)'=APCLSSP

                           QUIT 

 +12               IF APCLCDP]""

                       IF $PIECE($GET(^APCPATR(DFN,0)),U,4)'=APCLCDP

                           QUIT 

 +13      ;include refusals

                   SET APCALSC=""

                   IF APCLEXPC

                       SET APCALSC=$$BHALCS(DFN,APCLBD,APCLED)

                       SET APCPFI="BH"

 +14      ;include refusals

                   SET APCPCALS=""

                   SET APCPCALS=$$PCCALCS(DFN,APCLBD,APCLED)

 +15               IF $PIECE(APCPCALS,U,1)>$PIECE(APCALSC,U,1)

                       SET APCALSC=APCPCALS

                       SET APCPFI="PCC"

 +16               SET APCLEFS=""

                   SET APCLEFS=$$REFUSAL(DFN,9999999.15,$ORDER(^AUTTEXAM("C",36,0)),APCLBD,APCLED)

 +17               IF $PIECE(APCLEFS,U,1)>$PIECE(APCALSC,U,1)

                       SET APCALSC=APCLEFS

                       SET APCPFI="PCC"

 +18      ;no screenings

                   IF APCALSC=""

                       QUIT 

 +19               SET ^XTMP("APCLDE3",APCLJ,APCLH,"PTS",DFN)=APCALSC

                   SET $PIECE(^XTMP("APCLDE3",APCLJ,APCLH,"PTS",DFN),U,20)=APCPFI

 +20               QUIT 

               End DoDot:1

 +21       QUIT 

BHALCS(P,BDATE,EDATE) ;

 +1        IF '$GET(P)

               QUIT ""

 +2        IF '$GET(BDATE)

               QUIT ""

 +3        IF '$GET(EDATE)

               QUIT ""

 +4       ;loop through all of this patient's visits in date range

 +5        NEW SDATE,X,V,D,R,M,E

 +6        SET R=""

 +7        SET SDATE=9999999-$$FMADD^XLFDT(EDATE,1)

           SET SDATE=SDATE_".9999"

 +8        FOR 

               SET SDATE=$ORDER(^AMHREC("AE",P,SDATE))

               IF SDATE'=+SDATE!($PIECE(SDATE,".")>(9999999-BDATE))!(R]"")

                   QUIT 

               Begin DoDot:1

 +9                SET V=0

                   FOR 

                       SET V=$ORDER(^AMHREC("AE",P,SDATE,V))

                       IF V'=+V!(R]"")

                           QUIT 

                       Begin DoDot:2

 +10                       IF '$DATA(^AMHREC(V,0))

                               QUIT 

 +11      ;Q:'$$ALLOWVI^APCUTIL(DUZ,V)

 +12                       SET APCLDATE=$PIECE($PIECE(^AMHREC(V,0),U),".")

 +13                       SET X=$$AGE^AUPNPAT(DFN,APCLDATE)

 +14                       IF $DATA(APCLAGET)

                               IF X>$PIECE(APCLAGET,"-",2)

                                   QUIT 

 +15                       IF $DATA(APCLAGET)

                               IF X<$PIECE(APCLAGET,"-",1)

                                   QUIT 

 +16      ;clinic check

 +17                       IF $DATA(APCLCLNT)

                               SET X=$PIECE(^AMHREC(V,0),U,25)

                               IF X=""

                                   QUIT 

                               IF '$DATA(APCLCLNT(X))

                                   QUIT 

 +18      ;PRIMARY PROVIDER CHECK

 +19                       SET X=$$BHPPIN(V)

 +20      ;want only certain primary providers on visit

                           IF $DATA(APCLPROV)

                               IF X=""

                                   QUIT 

 +21      ;want one provider and it's not this one

                           IF $DATA(APCLPROV)

                               IF APCLPROV'=X

                                   QUIT 

 +22      ;want only unknown and this one has a primary provider

                           IF APCLPPUN

                               IF X'=""

                                   QUIT 

 +23      ;get measurements AUDC, AUDT, CRFTT

 +24                       SET X=0

                           FOR 

                               SET X=$ORDER(^AMHRMSR("AD",V,X))

                               IF X'=+X!(R]"")

                                   QUIT 

                               Begin DoDot:3

 +25                               SET M=$$VAL^XBDIQ1(9002011.12,X,.01)

 +26                               IF M="PHQ2"!(M="PHQ9")

                                       Begin DoDot:4

 +27                                       SET E=$PIECE($GET(^AMHRMSR(X,12)),U,4)

 +28      ;want only certain SCR providers on visit

                                           IF $DATA(APCLSPRV)

                                               IF E=""

                                                   QUIT 

 +29      ;want one provider and it's not this one

                                           IF $DATA(APCLSPRV)

                                               IF APCLSPRV'=E

                                                   QUIT 

 +30      ;want only unknown and this one has a SCR provider

                                           IF APCLSPUN

                                               IF E'=""

                                                   QUIT 

 +31      ;check result

 +32                                       SET E=$PIECE(^AMHRMSR(X,0),U,4)

 +33                                       IF M="PHQ2"

                                               IF E=""

                                                   IF '$DATA(APCLREST(5))

                                                       QUIT 

 +34                                       IF M="PHQ2"

                                               IF E<3

                                                   IF '$DATA(APCLREST(1))

                                                       QUIT 

 +35                                       IF M="PHQ2"

                                               IF E>2

                                                   IF '$DATA(APCLREST(2))

                                                       QUIT 

 +36                                       IF M="PHQ9"

                                               IF E=""

                                                   IF '$DATA(APCLREST(5))

                                                       QUIT 

 +37                                       IF M="PHQ9"

                                               IF E<5

                                                   IF '$DATA(APCLREST(1))

                                                       QUIT 

 +38                                       IF M="PHQ9"

                                               IF E>4

                                                   IF '$DATA(APCLREST(2))

                                                       QUIT 

 +39                                       IF M="PHQT"

                                               IF E=""

                                                   IF '$DATA(APCLREST(5))

                                                       QUIT 

 +40                                       IF M="PHQT"

                                               IF E<11

                                                   IF '$DATA(APCLREST(1))

                                                       QUIT 

 +41                                       IF M="PHQT"

                                               IF E>10

                                                   IF '$DATA(APCLREST(2))

                                                       QUIT 

 +42                                       SET R=$$BHRT(V,M,$PIECE(^AMHRMSR(X,0),U,4),P,$$VALI^XBDIQ1(9002011.12,X,1204))

                                       End DoDot:4

                               End DoDot:3

 +43                       IF R]""

                               QUIT 

 +44      ;get exam

 +45                       SET E=$PIECE($GET(^AMHREC(V,14)),U,3)

 +46                       IF E=""

                               GOTO BHHF

 +47                       SET APCLRES=$$VAL^XBDIQ1(9002011,V,1403)

                           IF APCLRES["REFUSED"

                               SET APCLRES="REFUSED SCREENING"

                           IF APCLRES["NEGATIVE"

                               SET APCLRES="NEGATIVE"

 +48                       IF APCLRES="NEGATIVE"

                               IF '$DATA(APCLREST(1))

                                   GOTO BHHF

 +49                       IF APCLRES="POSITIVE"

                               IF '$DATA(APCLREST(2))

                                   GOTO BHHF

 +50      ;do not want refusals

                           IF APCLRES["REFUSED"

                               IF '$DATA(APCLREST(3))

                                   GOTO BHHF

 +51      ;do not want unables

                           IF APCLRES["UNABLE"

                               IF '$DATA(APCLREST(4))

                                   GOTO BHHF

 +52                       IF APCLRES=""

                               IF '$DATA(APCLREST(5))

                                   GOTO BHHF

 +53                       SET E=$PIECE($GET(^AMHREC(V,14)),U,4)

 +54      ;want only certain SCR providers on visit

                           IF $DATA(APCLSPRV)

                               IF E=""

                                   GOTO BHHF

 +55      ;want one provider and it's not this one

                           IF $DATA(APCLSPRV)

                               IF APCLSPRV'=E

                                   GOTO BHHF

 +56      ;want only unknown and this one has a SCR provider

                           IF APCLSPUN

                               IF E'=""

                                   GOTO BHHF

 +57                       SET R=$$BHRT(V,"DEPRESSION SCREENING",$$VAL^XBDIQ1(9002011,V,1403),P,$PIECE($GET(^AMHREC(V,14)),U,4),$PIECE($GET(^AMHREC(V,16)),U,1))

 +58                       IF R]""

                               QUIT 

BHHF      ;

 +1                        IF $DATA(APCLREST(5))

                               SET X=0

                               FOR 

                                   SET X=$ORDER(^AMHRPRO("AD",V,X))

                                   IF X'=+X!(R]"")