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]"")
QUIT
Begin DoDot:3
+2 SET M=$$VAL^XBDIQ1(9002011.01,X,.01)
+3 IF M="14.1"!(M="V79.0")
SET R=$$BHRT(V,M,"",P,$$VALI^XBDIQ1(9002011.01,X,1204))
End DoDot:3
+4 IF R]""
QUIT
+5 IF $DATA(APCLREST(5))
SET X=0
FOR
SET X=$ORDER(^AMHREDU("AD",V,X))
IF X'=+X!(R]"")
QUIT
Begin DoDot:3
+6 SET M=$$VAL^XBDIQ1(9002011.05,X,.01)
+7 IF M="DEP-SCR"
SET R=$$BHRT(V,M,"",P,$$VALI^XBDIQ1(9002011.05,X,.04),$PIECE($GET(^AMHREDU(V,11)),U,1))
End DoDot:3
+8 IF R]""
QUIT
End DoDot:2
End DoDot:1
+9 QUIT R
BHRT(V,TYPE,RES,PAT,PROVSCRN,COMMENT) ;
+1 SET PROVSCRN=$GET(PROVSCRN)
+2 SET COMMENT=$GET(COMMENT)
+3 NEW T,D
+4 SET (D,T)=$PIECE($PIECE(^AMHREC(V,0),U),".")
+5 SET $PIECE(T,U,2)=TYPE_";"_RES
+6 SET $PIECE(T,U,3)=$PIECE(^DPT(PAT,0),U,2)
+7 SET $PIECE(T,U,4)=$$AGE^AUPNPAT(PAT,D)
+8 SET $PIECE(T,U,5)=$SELECT($GET(PROVSCRN)]"":$PIECE(^VA(200,PROVSCRN,0),U),1:"UNKNOWN")
+9 SET $PIECE(T,U,6)=$$VAL^XBDIQ1(9002011,V,.25)
+10 SET $PIECE(T,U,7)=$$BHPPNAME(V)
+11 SET $PIECE(T,U,8)=$$VAL^XBDIQ1(9002011.55,PAT,.02)
+12 SET $PIECE(T,U,9)=$$VAL^XBDIQ1(9002011.55,PAT,.03)
+13 SET $PIECE(T,U,10)=$$VAL^XBDIQ1(9002011.55,PAT,.04)
+14 SET $PIECE(T,U,11)=$$VAL^XBDIQ1(9000001,PAT,.14)
+15 SET $PIECE(T,U,13)=V
+16 SET $PIECE(T,U,12)=COMMENT
+17 SET $PIECE(T,U,15)=PAT
+18 SET $PIECE(T,U,20)="BH"
+19 QUIT T
+20 ;
PCCALCS(P,BDATE,EDATE) ;EP - get alcohol screening from pcc
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(BDATE)
QUIT ""
+3 IF '$GET(EDATE)
QUIT ""
+4 NEW T
+5 ;S T=$$LASTALC^APCAPI(P,BDATE,EDATE,"A")
+6 NEW R,V,APCLDATE,SDATE
+7 SET R=""
+8 SET SDATE=9999999-$$FMADD^XLFDT(EDATE,1)
SET SDATE=SDATE_".9999"
+9 FOR
SET SDATE=$ORDER(^AUPNVSIT("AA",P,SDATE))
IF SDATE'=+SDATE!($PIECE(SDATE,".")>(9999999-BDATE))!(R]"")
QUIT
Begin DoDot:1
+10 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,SDATE,V))
IF V'=+V!(R]"")
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+12 ;Q:'$$ALLOWPCC^APCUTIL(DUZ,V)
+13 IF 'APCLEXPC
SET C=$$CLINIC^APCLV(V,"C")
IF C=14!(C=43)!(C=48)!(C="C4")!(C="C9")
QUIT
+14 ;in BH module so already got it
IF APCLEXPC
IF $DATA(^AHHREC("AVISIT",V))
QUIT
+15 SET APCLDATE=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+16 SET DFN=$PIECE(^AUPNVSIT(V,0),U,5)
+17 IF DFN=""
QUIT
+18 ;Q:'$$ALLOWP^APCUTIL(DUZ,DFN)
+19 SET X=$$AGE^AUPNPAT(DFN,APCLDATE)
+20 IF $DATA(APCLAGET)
IF X>$PIECE(APCLAGET,"-",2)
QUIT
+21 IF $DATA(APCLAGET)
IF X<$PIECE(APCLAGET,"-",1)
QUIT
+22 ;clinic check
+23 IF $DATA(APCLCLNT)
SET X=$PIECE(^AUPNVSIT(V,0),U,8)
IF X=""
QUIT
IF '$DATA(APCLCLNT(X))
QUIT
+24 ;PRIMARY PROVIDER CHECK
+25 SET X=$$PRIMPROV^APCLV(V)
+26 ;want only certain primary providers on visit
IF $DATA(APCLPROV)
IF X=""
QUIT
+27 ;want one provider and it's not this one
IF $DATA(APCLPROV)
IF APCLPROV'=X
QUIT
+28 ;want only unknown and this one has a primary provider
IF APCLPPUN
IF X'=""
QUIT
+29 SET R=$$PCCSCR(V)
End DoDot:2
End DoDot:1
+30 QUIT R
PCCSCR(V) ;is there a screening? return in R
+1 ;get measurements AUDC, AUDT, CRFTT
+2 NEW R,X,M,P,E
+3 SET R=""
+4 SET P=$PIECE(^AUPNVSIT(V,0),U,5)
+5 SET D=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+6 SET X=0
FOR
SET X=$ORDER(^AUPNVMSR("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+7 IF $PIECE($GET(^AUPNVMSR(X,2)),U,1)
QUIT
+8 SET M=$$VAL^XBDIQ1(9000010.01,X,.01)
+9 IF M="PHQ2"!(M="PHQ9")!(M="PHQT")
Begin DoDot:2
+10 SET E=$PIECE($GET(^AUPNVMSR(X,12)),U,4)
+11 ;want only certain SCR providers on visit
IF $DATA(APCLSPRV)
IF E=""
QUIT
+12 ;want one provider and it's not this one
IF $DATA(APCLSPRV)
IF APCLSPRV'=E
QUIT
+13 ;want only unknown and this one has a SCR provider
IF APCLSPUN
IF E'=""
QUIT
+14 ;check result
+15 SET E=$PIECE(^AUPNVMSR(X,0),U,4)
+16 IF M="PHQ2"
IF E=""
IF '$DATA(APCLREST(5))
QUIT
+17 IF M="PHQ2"
IF E<3
IF '$DATA(APCLREST(1))
QUIT
+18 IF M="PHQ2"
IF E>2
IF '$DATA(APCLREST(2))
QUIT
+19 IF M="PHQ9"
IF E=""
IF '$DATA(APCLREST(5))
QUIT
+20 IF M="PHQ9"
IF E<5
IF '$DATA(APCLREST(1))
QUIT
+21 IF M="PHQ9"
IF E>4
IF '$DATA(APCLREST(2))
QUIT
+22 IF M="PHQT"
IF E=""
IF '$DATA(APCLREST(5))
QUIT
+23 IF M="PHQT"
IF E<11
IF '$DATA(APCLREST(1))
QUIT
+24 IF M="PHQT"
IF E>10
IF '$DATA(APCLREST(2))
QUIT
+25 SET T=D_U_M_U_$$VAL^XBDIQ1(9000010.01,X,.04)_U_V_U_9000010.01_U_X
+26 SET R=$$PCCV^APCLDE1(T,P)
End DoDot:2
End DoDot:1
+27 IF R]""
QUIT R
+28 ;get exam
+29 SET X=0
FOR
SET X=$ORDER(^AUPNVXAM("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+30 SET M=$$VAL^XBDIQ1(9000010.13,X,.01)
+31 IF M="DEPRESSION SCREENING"
Begin DoDot:2
+32 SET E=$PIECE($GET(^AUPNVXAM(X,12)),U,4)
+33 ;want only certain SCR providers on visit
IF $DATA(APCLSPRV)
IF E=""
QUIT
+34 ;want one provider and it's not this one
IF $DATA(APCLSPRV)
IF APCLSPRV'=E
QUIT
+35 ;want only unknown and this one has a SCR provider
IF APCLSPUN
IF E'=""
QUIT
+36 ;check result
+37 SET E=$PIECE(^AUPNVXAM(X,0),U,4)
+38 IF E=""
IF '$DATA(APCLREST(5))
QUIT
+39 IF E="N"
IF '$DATA(APCLREST(1))
QUIT
+40 IF E="PO"
IF '$DATA(APCLREST(2))
QUIT
+41 SET T=D_U_M_U_$$VAL^XBDIQ1(9000010.13,X,.04)_U_V_U_9000010.13_U_X
+42 SET R=$$PCCV^APCLDE1(T,P)
End DoDot:2
End DoDot:1
+43 IF R]""
QUIT R
+44 ;get pov
+45 IF $DATA(APCLREST(5))
SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+46 SET M=$$VAL^XBDIQ1(9000010.07,X,.01)
+47 IF M="V79.0"
Begin DoDot:2
+48 SET T=D_U_M_U_U_V_U_9000010.07_U_X
+49 SET R=$$PCCV^APCLDE1(T,P)
End DoDot:2
End DoDot:1
+50 IF R]""
QUIT R
+51 ;get education
+52 IF $DATA(APCLREST(5))
SET X=0
FOR
SET X=$ORDER(^AUPNVPED("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+53 SET M=$$VAL^XBDIQ1(9000010.16,X,.01)
+54 IF M="DEP-SCR"
Begin DoDot:2
+55 SET T=D_U_M_U_U_V_U_9000010.16_U_X
+56 SET R=$$PCCV^APCLDE1(T,P)
End DoDot:2
End DoDot:1
+57 IF R]""
QUIT R
+58 QUIT R
+59 ;
REFUSAL(PAT,F,I,B,E) ;EP
+1 IF '$GET(PAT)
QUIT ""
+2 IF '$GET(F)
QUIT ""
+3 IF '$GET(I)
QUIT ""
+4 IF $GET(B)=""
QUIT ""
+5 IF $GET(E)=""
QUIT ""
+6 NEW T,X,Y,%DT
SET X=B
SET %DT="P"
DO ^%DT
SET B=Y
+7 SET X=E
SET %DT="P"
DO ^%DT
SET E=Y
+8 SET (X,T)=""
FOR
SET X=$ORDER(^AUPNPREF("AA",PAT,F,I,X))
IF X'=+X!(T]"")
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",PAT,F,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
Begin DoDot:1
+9 SET T=D
+10 SET $PIECE(T,U,2)="REFUSED;"_$$VAL^XBDIQ1(9000022,Y,.07)
+11 SET $PIECE(T,U,3)=$PIECE(^DPT(PAT,0),U,2)
+12 SET $PIECE(T,U,4)=$$AGE^AUPNPAT(PAT,D)
+13 SET $PIECE(T,U,5)=$$VAL^XBDIQ1(9000022,Y,1204)
IF $PIECE(T,U,5)=""
SET $PIECE(T,U,5)="UNKNOWN"
+14 SET $PIECE(T,U,6)="UNKNOWN"
+15 SET $PIECE(T,U,7)="UNKNOWN"
+16 SET $PIECE(T,U,8)=$$VAL^XBDIQ1(9002011.55,PAT,.02)
+17 SET $PIECE(T,U,9)=$$VAL^XBDIQ1(9002011.55,PAT,.03)
+18 SET $PIECE(T,U,10)=$$VAL^XBDIQ1(9002011.55,PAT,.04)
+19 SET $PIECE(T,U,11)=$$VAL^XBDIQ1(9000001,PAT,.14)
End DoDot:1
+20 QUIT T
PCCV(S,PAT) ;
+1 NEW T
+2 SET T=""
+3 SET $PIECE(T,U)=$PIECE(S,U)
+4 SET $PIECE(T,U,2)=$PIECE(S,U,2)_";"_$PIECE(S,U,3)
+5 SET $PIECE(T,U,3)=$PIECE(^DPT(PAT,0),U,2)
+6 SET $PIECE(T,U,4)=$$AGE^AUPNPAT(PAT,$PIECE(S,U))
+7 SET $PIECE(T,U,5)=$$SCRNPCC(S)
+8 SET $PIECE(T,U,6)=$$VAL^XBDIQ1(9000010,$PIECE(S,U,4),.08)
+9 SET $PIECE(T,U,7)=$$PRIMPROV^APCLV($PIECE(S,U,4),"N")
+10 SET $PIECE(T,U,8)=$$VAL^XBDIQ1(9002011.55,PAT,.02)
+11 SET $PIECE(T,U,9)=$$VAL^XBDIQ1(9002011.55,PAT,.03)
+12 SET $PIECE(T,U,10)=$$VAL^XBDIQ1(9002011.55,PAT,.04)
+13 SET $PIECE(T,U,11)=$$VAL^XBDIQ1(9000001,PAT,.14)
+14 SET $PIECE(T,U,14)=$PIECE(S,U,4)
+15 SET $PIECE(T,U,15)=PAT
+16 SET $PIECE(T,U,20)="PCC"
+17 QUIT T
SCRNPCC(T) ;get screening provider based on v file
+1 NEW S,F
+2 SET F=1204
+3 IF $PIECE(T,U,5)=9000010.16!($PIECE(T,U,5)=9000010.23)
SET F=".05"
+4 SET S=$$VAL^XBDIQ1($PIECE(T,U,5),$PIECE(T,U,6),F)
+5 IF S]""
QUIT S
+6 QUIT "UNKNOWN"
BHPPIN(R) ;
+1 NEW %,%1
+2 SET %=0
SET %1=""
FOR
SET %=$ORDER(^AMHRPROV("AD",R,%))
IF %'=+%
QUIT
IF $PIECE(^AMHRPROV(%,0),U,4)="P"
SET %1=$PIECE(^AMHRPROV(%,0),U)
+3 QUIT %1
BHPPNAME(R) ;EP primary provider internal # from 200
+1 NEW %,%1
+2 SET %=0
SET %1=""
FOR
SET %=$ORDER(^AMHRPROV("AD",R,%))
IF %'=+%
QUIT
IF $PIECE(^AMHRPROV(%,0),U,4)="P"
SET %1=$PIECE(^AMHRPROV(%,0),U)
SET %1=$PIECE($GET(^VA(200,%1,0)),U)
+3 IF %1]""
QUIT %1
+4 QUIT "UNKNOWN"
SPRV(E) ;
+1 IF $PIECE($GET(^AUPNVXAM(E,12)),U,4)
QUIT $$VAL^XBDIQ1(9000010.13,E,1204)
+2 QUIT "UNKNOWN"
PRVREF(R) ;
+1 IF $PIECE($GET(^AUPNPREF(R,12)),U,4)]""
QUIT $$VAL^XBDIQ1(9000022,R,1204)
+2 QUIT "UNKNOWN"
PPV(V) ;
+1 NEW %
+2 SET %=$$PRIMPROV^APCLV(V,"N")
+3 IF %]""
QUIT %
+4 QUIT "UNKNOWN"
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
EOP ;EP - End of page.
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 IF IO'=IO(0)
QUIT
+3 IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))
QUIT
+4 NEW DIR
+5 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+6 WRITE !
+7 SET DIR("A")="End of Report. Press Enter"
SET DIR(0)="E"
DO ^DIR
+8 QUIT
+9 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;----------
