Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AMHRDE31

AMHRDE31.m

Go to the documentation of this file. 
  1. AMHRDE31 ; IHS/CMI/LAB - list DEPRESSION screenings ;
  1.  ;;4.0;IHS BEHAVIORAL HEALTH;**6**;JUN 02, 2010;Build 10
  1.  ;
  1.  ;
  1. PROC ;
  1.  S AMHRCNT=0
  1.  S AMHRH=$H,AMHRJ=$J
  1.  K ^XTMP("AMHRDE3",AMHRJ,AMHRH)
  1.  D XTMP^AMHUTIL("AMHRDE3","DEPRESSION SCREENING REPORT")
  1.  ;go through exam DEPRESSION, then through AUPNPREF for refusals
  1.  S DFN=0 F  S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN  D
  1.  .Q:'$D(^DPT(DFN,0))
  1.  .Q:$P(^DPT(DFN,0),U,19)  ;merged away
  1.  .Q:'$$ALLOWP^AMHUTIL(DUZ,DFN)
  1.  .Q:$$DEMO^AMHUTIL1(DFN,$G(AMHDEMO))
  1.  .I AMHRSEX'[$P(^DPT(DFN,0),U,2) Q  ;not right gender
  1.  .I AMHRDESP]"",$P($G(^AMHPATR(DFN,0)),U,2)'=AMHRDESP Q  ;not correct designated mh provider
  1.  .I AMHRSSP]"",$P($G(^AMHPATR(DFN,0)),U,3)'=AMHRSSP Q
  1.  .I AMHRCDP]"",$P($G(^AMHPATR(DFN,0)),U,4)'=AMHRCDP Q
  1.  .S AMHALSC=$$BHALCS(DFN,AMHRBD,AMHRED),AMHPFI="BH"  ;include refusals
  1.  .S AMHPCALS="" I AMHREXPC S AMHPCALS=$$PCCALCS(DFN,AMHRBD,AMHRED)  ;include refusals
  1.  .I $P(AMHPCALS,U,1)>$P(AMHALSC,U,1) S AMHALSC=AMHPCALS,AMHPFI="PCC"
  1.  .S AMHREFS="" I AMHREXPC S AMHREFS=$$REFUSAL(DFN,9999999.15,$O(^AUTTEXAM("C",36,0)),AMHRBD,AMHRED)
  1.  .I $P(AMHREFS,U,1)>$P(AMHALSC,U,1) S AMHALSC=AMHREFS,AMHPFI="PCC"
  1.  .I AMHALSC="" Q  ;no screenings
  1.  .S ^XTMP("AMHRDE3",AMHRJ,AMHRH,"PTS",DFN)=AMHALSC,$P(^XTMP("AMHRDE3",AMHRJ,AMHRH,"PTS",DFN),U,20)=AMHPFI
  1.  .Q
  1.  Q
  1. BHALCS(P,BDATE,EDATE) ;
  1.  I '$G(P) Q ""
  1.  I '$G(BDATE) Q ""
  1.  I '$G(EDATE) Q ""
  1.  ;loop through all of this patient's visits in date range
  1.  NEW SDATE,X,V,D,R,M,E
  1.  S R=""
  1.  S SDATE=9999999-$$FMADD^XLFDT(EDATE,1),SDATE=SDATE_".9999"
  1.  F  S SDATE=$O(^AMHREC("AE",P,SDATE)) Q:SDATE'=+SDATE!($P(SDATE,".")>(9999999-BDATE))!(R]"")  D
  1.  .S V=0 F  S V=$O(^AMHREC("AE",P,SDATE,V)) Q:V'=+V!(R]"")  D
  1.  ..Q:'$D(^AMHREC(V,0))
  1.  ..Q:'$$ALLOWVI^AMHUTIL(DUZ,V)
  1.  ..S AMHRDATE=$P($P(^AMHREC(V,0),U),".")
  1.  ..S X=$$AGE^AUPNPAT(DFN,AMHRDATE)
  1.  ..I $D(AMHRAGET),X>$P(AMHRAGET,"-",2) Q
  1.  ..I $D(AMHRAGET),X<$P(AMHRAGET,"-",1) Q
  1.  ..;clinic check
  1.  ..I $D(AMHRCLNT) S X=$P(^AMHREC(V,0),U,25) Q:X=""  Q:'$D(AMHRCLNT(X))
  1.  ..;PRIMARY PROVIDER CHECK
  1.  ..S X=$$BHPPIN(V)
  1.  ..I $D(AMHRPROV),X="" Q  ;want only certain primary providers on visit
  1.  ..I $D(AMHRPROV),'$D(AMHRPROV(X)) Q  ;want one provider and it's not this one
  1.  ..I AMHRPPUN,X'="" Q  ;want only unknown and this one has a primary provider
  1.  ..;get measurements PHQ
  1.  ..S X=0 F  S X=$O(^AMHRMSR("AD",V,X)) Q:X'=+X!(R]"")  D
  1.  ...S M=$$VAL^XBDIQ1(9002011.12,X,.01)
  1.  ...I M="PHQ2"!(M="PHQ9")!(M="PHQT") D
  1.  ....S E=$P($G(^AMHRMSR(X,12)),U,4)
  1.  ....I $D(AMHRSPRV),E="" Q  ;want only certain SCR providers on visit
  1.  ....I $D(AMHRSPRV),'$D(AMHRSPRV(E)) Q  ;want one provider and it's not this one
  1.  ....I AMHRSPUN,E'="" Q  ;want only unknown and this one has a SCR provider
  1.  ....;check result
  1.  ....S E=$P(^AMHRMSR(X,0),U,4)
  1.  ....I M="PHQ2",E="",'$D(AMHRREST(6)) Q
  1.  ....I M="PHQ2",E<3,'$D(AMHRREST(1)) Q
  1.  ....I M="PHQ2",E>2,'$D(AMHRREST(2)) Q
  1.  ....I M="PHQ9",E="",'$D(AMHRREST(6)) Q
  1.  ....I M="PHQ9",E<5,'$D(AMHRREST(1)) Q
  1.  ....I M="PHQ9",E>4,'$D(AMHRREST(2)) Q
  1.  ....I M="PHQT",E="",'$D(AMHRREST(6)) Q
  1.  ....I M="PHQT",E<11,'$D(AMHRREST(1)) Q
  1.  ....I M="PHQT",E>10,'$D(AMHRREST(2)) Q
  1.  ....S R=$$BHRT(V,M,$P(^AMHRMSR(X,0),U,4),P,$$VALI^XBDIQ1(9002011.12,X,1204))
  1.  ..I R]"" Q
  1.  ..;get exam
  1.  ..S E=$P($G(^AMHREC(V,14)),U,3)
  1.  ..I E="" G BHHF
  1.  ..S AMHRRES=$$VAL^XBDIQ1(9002011,V,1403) S:AMHRRES["REFUSED" AMHRRES="REFUSED SCREENING" S:AMHRRES["NEGATIVE" AMHRRES="NEGATIVE"
  1.  ..I AMHRRES="NEGATIVE",'$D(AMHRREST(1)) G BHHF
  1.  ..I AMHRRES="POSITIVE",'$D(AMHRREST(2)) G BHHF
  1.  ..I AMHRRES["REFUSED",'$D(AMHRREST(3)) G BHHF  ;do not want refusals
  1.  ..I AMHRRES["UNABLE",'$D(AMHRREST(4)) G BHHF  ;do not want unables
  1.  ..I AMHRRES["REFERRAL",'$D(AMHRREST(5)) G BHHF  ;don't want referrals
  1.  ..I AMHRRES="",'$D(AMHRREST(6)) G BHHF
  1.  ..S E=$P($G(^AMHREC(V,14)),U,4)
  1.  ..I $D(AMHRSPRV),E="" G BHHF  ;want only certain SCR providers on visit
  1.  ..I $D(AMHRSPRV),'$D(AMHRSPRV(E)) G BHHF  ;want one provider and it's not this one
  1.  ..I AMHRSPUN,E'="" G BHHF  ;want only unknown and this one has a SCR provider
  1.  ..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))
  1.  ..I R]"" Q
  1. BHHF ..;
  1.  ..I $D(AMHRREST(6)) S X=0 F  S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(R]"")  D
  1.  ...S M=$$VAL^XBDIQ1(9002011.01,X,.01)
  1.  ...I M="14.1"!(M="V79.0") S R=$$BHRT(V,M,"",P,$$VALI^XBDIQ1(9002011.01,X,1204))
  1.  ..I R]"" Q
  1.  ..I $D(AMHRREST(6)) S X=0 F  S X=$O(^AMHREDU("AD",V,X)) Q:X'=+X!(R]"")  D
  1.  ...S M=$$VAL^XBDIQ1(9002011.05,X,.01)
  1.  ...I M="DEP-SCR" S R=$$BHRT(V,M,"",P,$$VALI^XBDIQ1(9002011.05,X,.04),$P($G(^AMHREDU(V,11)),U,1))
  1.  ..I R]"" Q
  1.  Q R
  1. BHRT(V,TYPE,RES,PAT,PROVSCRN,COMMENT) ;
  1.  S PROVSCRN=$G(PROVSCRN)
  1.  S COMMENT=$G(COMMENT)
  1.  NEW T,D
  1.  S (D,T)=$P($P(^AMHREC(V,0),U),".")
  1.  S $P(T,U,2)=TYPE_";"_RES
  1.  S $P(T,U,3)=$P(^DPT(PAT,0),U,2)
  1.  S $P(T,U,4)=$$AGE^AUPNPAT(PAT,D)
  1.  S $P(T,U,5)=$S($G(PROVSCRN)]"":$P(^VA(200,PROVSCRN,0),U),1:"UNKNOWN")
  1.  S $P(T,U,6)=$$VAL^XBDIQ1(9002011,V,.25)
  1.  S $P(T,U,7)=$$BHPPNAME(V)
  1.  S $P(T,U,8)=$$VAL^XBDIQ1(9002011.55,PAT,.02)
  1.  S $P(T,U,9)=$$VAL^XBDIQ1(9002011.55,PAT,.03)
  1.  S $P(T,U,10)=$$VAL^XBDIQ1(9002011.55,PAT,.04)
  1.  S $P(T,U,11)=$$VAL^XBDIQ1(9000001,PAT,.14)
  1.  S $P(T,U,13)=V
  1.  S $P(T,U,12)=COMMENT
  1.  S $P(T,U,15)=PAT
  1.  S $P(T,U,20)="BH"
  1.  Q T
  1.  ;
  1. PCCALCS(P,BDATE,EDATE) ;EP - get alcohol screening from pcc
  1.  I '$G(P) Q ""
  1.  I '$G(BDATE) Q ""
  1.  I '$G(EDATE) Q ""
  1.  NEW T
  1.  ;S T=$$LASTALC^APCLAPI(P,BDATE,EDATE,"A")
  1.  NEW R,V,AMHRDATE,SDATE
  1.  S R=""
  1.  S SDATE=9999999-$$FMADD^XLFDT(EDATE,1),SDATE=SDATE_".9999"
  1.  F  S SDATE=$O(^AUPNVSIT("AA",P,SDATE)) Q:SDATE'=+SDATE!($P(SDATE,".")>(9999999-BDATE))!(R]"")  D
  1.  .S V=0 F  S V=$O(^AUPNVSIT("AA",P,SDATE,V)) Q:V'=+V!(R]"")  D
  1.  ..Q:'$D(^AUPNVSIT(V,0))
  1.  ..Q:'$$ALLOWPCC^AMHUTIL(DUZ,V)
  1.  ..S AMHRDATE=$P($P(^AUPNVSIT(V,0),U),".")
  1.  ..S DFN=$P(^AUPNVSIT(V,0),U,5)
  1.  ..Q:DFN=""
  1.  ..Q:'$$ALLOWP^AMHUTIL(DUZ,DFN)
  1.  ..S X=$$AGE^AUPNPAT(DFN,AMHRDATE)
  1.  ..I $D(AMHRAGET),X>$P(AMHRAGET,"-",2) Q
  1.  ..I $D(AMHRAGET),X<$P(AMHRAGET,"-",1) Q
  1.  ..;clinic check
  1.  ..I $D(AMHRCLNT) S X=$P(^AUPNVSIT(V,0),U,8) Q:X=""  Q:'$D(AMHRCLNT(X))
  1.  ..;PRIMARY PROVIDER CHECK
  1.  ..S X=$$PRIMPROV^APCLV(V)
  1.  ..I $D(AMHRPROV),X="" Q  ;want only certain primary providers on visit
  1.  ..I $D(AMHRPROV),'$D(AMHRPROV(X)) Q  ;want one provider and it's not this one
  1.  ..I AMHRPPUN,X'="" Q  ;want only unknown and this one has a primary provider
  1.  ..S R=$$PCCSCR(V)
  1.  Q R
  1. PCCSCR(V) ;is there a screening?  return in R
  1.  ;get measurements AUDC, AUDT, CRFTT
  1.  NEW R,X,M,P,E
  1.  S R=""
  1.  S P=$P(^AUPNVSIT(V,0),U,5)
  1.  S D=$P($P(^AUPNVSIT(V,0),U),".")
  1.  S X=0 F  S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X  D
  1.  .S M=$$VAL^XBDIQ1(9000010.01,X,.01)
  1.  .I M="PHQ2"!(M="PHQ9")!(M="PHQT") D
  1.  ..S E=$P($G(^AUPNVMSR(X,12)),U,4)
  1.  ..I $D(AMHRSPRV),E="" Q  ;want only certain SCR providers on visit
  1.  ..I $D(AMHRSPRV),'$D(AMHRSPRV(E)) Q  ;want one provider and it's not this one
  1.  ..I AMHRSPUN,E'="" Q  ;want only unknown and this one has a SCR provider
  1.  ..;check result
  1.  ..S E=$P(^AUPNVMSR(X,0),U,4)
  1.  ..I M="PHQ2",E="",'$D(AMHRREST(6)) Q
  1.  ..I M="PHQ2",E<3,'$D(AMHRREST(1)) Q
  1.  ..I M="PHQ2",E>2,'$D(AMHRREST(2)) Q
  1.  ..I M="PHQ9",E="",'$D(AMHRREST(6)) Q
  1.  ..I M="PHQ9",E<5,'$D(AMHRREST(1)) Q
  1.  ..I M="PHQ9",E>4,'$D(AMHRREST(2)) Q
  1.  ..I M="PHQT",E="",'$D(AMHRREST(6)) Q
  1.  ..I M="PHQT",E<11,'$D(AMHRREST(1)) Q
  1.  ..I M="PHQT",E>10,'$D(AMHRREST(2)) Q
  1.  ..S T=D_U_M_U_$$VAL^XBDIQ1(9000010.01,X,.04)_U_V_U_9000010.01_U_X
  1.  ..S R=$$PCCV^AMHRDE1(T,P)
  1.  I R]"" Q R
  1.  ;get exam
  1.  S X=0 F  S X=$O(^AUPNVXAM("AD",V,X)) Q:X'=+X  D
  1.  .S M=$$VAL^XBDIQ1(9000010.13,X,.01)
  1.  .I M="DEPRESSION SCREENING" D
  1.  ..S E=$P($G(^AUPNVXAM(X,12)),U,4)
  1.  ..I $D(AMHRSPRV),E="" Q  ;want only certain SCR providers on visit
  1.  ..I $D(AMHRSPRV),'$D(AMHRSPRV(E)) Q  ;want one provider and it's not this one
  1.  ..I AMHRSPUN,E'="" Q  ;want only unknown and this one has a SCR provider
  1.  ..;check result
  1.  ..S E=$P(^AUPNVXAM(X,0),U,4)
  1.  ..I E="",'$D(AMHRREST(6)) Q
  1.  ..I E="N",'$D(AMHRREST(1)) Q
  1.  ..I E="PO",'$D(AMHRREST(2)) Q
  1.  ..I E="RF",'$D(AMHRREST(5)) Q
  1.  ..S T=D_U_M_U_$$VAL^XBDIQ1(9000010.13,X,.04)_U_V_U_9000010.13_U_X
  1.  ..S R=$$PCCV^AMHRDE1(T,P)
  1.  I R]"" Q R
  1.  ;get pov
  1.  I $D(AMHRREST(6)) S X=0 F  S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X  D
  1.  .S M=$$VAL^XBDIQ1(9000010.07,X,.01)
  1.  .I M="V79.0" D
  1.  ..S T=D_U_M_U_U_V_U_9000010.07_U_X
  1.  ..S R=$$PCCV^AMHRDE1(T,P)
  1.  I R]"" Q R
  1.  ;get education
  1.  I $D(AMHRREST(6)) S X=0 F  S X=$O(^AUPNVPED("AD",V,X)) Q:X'=+X  D
  1.  .S M=$$VAL^XBDIQ1(9000010.16,X,.01)
  1.  .I M="DEP-SCR" D
  1.  ..S T=D_U_M_U_U_V_U_9000010.16_U_X
  1.  ..S R=$$PCCV^AMHRDE1(T,P)
  1.  I R]"" Q R
  1.  Q R
  1.  ;
  1. REFUSAL(PAT,F,I,B,E) ;EP
  1.  I '$G(PAT) Q ""
  1.  I '$G(F) Q ""
  1.  I '$G(I) Q ""
  1.  I $G(B)="" Q ""
  1.  I $G(E)="" Q ""
  1.  NEW T,X,Y,%DT S X=B,%DT="P" D ^%DT S B=Y
  1.  S X=E,%DT="P" D ^%DT S E=Y
  1.  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
  1.  .S T=D
  1.  .S $P(T,U,2)="REFUSED;"_$$VAL^XBDIQ1(9000022,Y,.07)
  1.  .S $P(T,U,3)=$P(^DPT(PAT,0),U,2)
  1.  .S $P(T,U,4)=$$AGE^AUPNPAT(PAT,D)
  1.  .S $P(T,U,5)=$$VAL^XBDIQ1(9000022,Y,1204) I $P(T,U,5)="" S $P(T,U,5)="UNKNOWN"
  1.  .S $P(T,U,6)="UNKNOWN"
  1.  .S $P(T,U,7)="UNKNOWN"
  1.  .S $P(T,U,8)=$$VAL^XBDIQ1(9002011.55,PAT,.02)
  1.  .S $P(T,U,9)=$$VAL^XBDIQ1(9002011.55,PAT,.03)
  1.  .S $P(T,U,10)=$$VAL^XBDIQ1(9002011.55,PAT,.04)
  1.  .S $P(T,U,11)=$$VAL^XBDIQ1(9000001,PAT,.14)
  1.  Q T
  1. PCCV(S,PAT) ;
  1.  NEW T
  1.  S T=""
  1.  S $P(T,U)=$P(S,U)
  1.  S $P(T,U,2)=$P(S,U,2)_";"_$P(S,U,3)
  1.  S $P(T,U,3)=$P(^DPT(PAT,0),U,2)
  1.  S $P(T,U,4)=$$AGE^AUPNPAT(PAT,$P(S,U))
  1.  S $P(T,U,5)=$$SCRNPCC(S)
  1.  S $P(T,U,6)=$$VAL^XBDIQ1(9000010,$P(S,U,4),.08)
  1.  S $P(T,U,7)=$$PRIMPROV^APCLV($P(S,U,4),"N")
  1.  S $P(T,U,8)=$$VAL^XBDIQ1(9002011.55,PAT,.02)
  1.  S $P(T,U,9)=$$VAL^XBDIQ1(9002011.55,PAT,.03)
  1.  S $P(T,U,10)=$$VAL^XBDIQ1(9002011.55,PAT,.04)
  1.  S $P(T,U,11)=$$VAL^XBDIQ1(9000001,PAT,.14)
  1.  S $P(T,U,14)=$P(S,U,4)
  1.  S $P(T,U,15)=PAT
  1.  S $P(T,U,20)="PCC"
  1.  Q T
  1. SCRNPCC(T) ;get screening provider based on v file
  1.  NEW S,F
  1.  S F=1202
  1.  I $P(T,U,5)=9000010.16!($P(T,U,5)=9000010.23) S F=".05"
  1.  S S=$$VAL^XBDIQ1($P(T,U,5),$P(T,U,6),F)
  1.  I S]"" Q S
  1.  Q "UNKNOWN"
  1. BHPPIN(R) ;
  1.  NEW %,%1
  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.  Q %1
  1. BHPPNAME(R) ;EP primary provider internal # from 200
  1.  NEW %,%1
  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)
  1.  I %1]"" Q %1
  1.  Q "UNKNOWN"
  1. SPRV(E) ;
  1.  I $P($G(^AUPNVXAM(E,12)),U,4) Q $$VAL^XBDIQ1(9000010.13,E,1204)
  1.  Q "UNKNOWN"
  1. PRVREF(R) ;
  1.  I $P($G(^AUPNPREF(R,12)),U,4)]"" Q $$VAL^XBDIQ1(9000022,R,1204)
  1.  Q "UNKNOWN"
  1. PPV(V) ;
  1.  NEW %
  1.  S %=$$PRIMPROV^APCLV(V,"N")
  1.  I %]"" Q %
  1.  Q "UNKNOWN"
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. EOP ;EP - End of page.
  1.  Q:$E(IOST)'="C"
  1.  Q:IO'=IO(0)
  1.  Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
  1.  NEW DIR
  1.  K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
  1.  W !
  1.  S DIR("A")="End of Report.  Press Enter",DIR(0)="E" D ^DIR
  1.  Q
  1.  ;----------
  1. USR() ;EP - Return name of current user from ^VA(200.
  1.  Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1.  ;----------
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  1.  Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1.  ;----------