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

APCLDE1.m

Go to the documentation of this file. 
  1. APCLDE1 ; IHS/CMI/LAB - list DEPRESSION ; 
  1.  ;;2.0;IHS PCC SUITE;**2,8,11**;MAY 14, 2009;Build 58
  1.  ;
  1.  ;
  1. INFORM ;
  1.  W !,$$CTR($$USR)
  1.  W !,$$LOC()
  1.  W !!,$$CTR("TALLY AND LISTING OF PATIENTS RECEIVING DEPRESSION SCREENING, INCLUDING REFUSALS",80)
  1.  W !!,"This report will tally and optionally list all patients who have had "
  1.  W !,"DEPRESSION screening or a refusal documented in the time frame specified by "
  1.  W !,"the user.  Depression Screening is defined as any of the following documented:"
  1.  W !?5,"- Depression Screening Exam (Exam code 36)"
  1.  W !?5,"- Measurements: PHQ2, PHQ9, PHQT"
  1.  W !?5,"- Diagnoses V79.0 (there are no ICD10 codes), 14.1 (Behavioral Hlth Code)"
  1.  W !?5,"- Education Topics: DEP-SCR"
  1.  W !?5,"- refusal of exam code 36"
  1.  W !,"This report will tally the patients by age, gender, screening exam result,"
  1.  W !,"provider (either exam provider, if available, or primary provider on the "
  1.  W !,"visit), clinic, date of screening, designated PCP, MH Provider, SS Provider"
  1.  W !,"and A/SA Provider."
  1.  W !,"  Notes:  "
  1.  W !?10,"- the last screening/refusal for each patient is used.  If a patient"
  1.  W !?10,"  was screened more than once in the time period, only the latest"
  1.  W !?10,"  is used in this report."
  1.  W !?10,"- this report will optionally, look at both PCC and the Behavioral"
  1.  W !?10,"   Health databases for evidence of screening/refusal"
  1.  W !?10,"- this is a tally of Patients, not visits or screenings"
  1.  W !
  1.  D PAUSE^APCLVL01
  1.  D XIT
  1.  S APCLEXC=$O(^AUTTEXAM("C",36,0))
  1.  I 'APCLEXC W !!,"Exam code 36 is missing from the EXAM table.  Cannot run report.",! H 3 D XIT Q
  1.  ;
  1. DATES K APCLED,APCLBD
  1.  W !,"Please enter the date range during which the screening was done.",!,"To get all screenings ever put in a long date range like 01/01/1980 ",!,"to the present date.",!
  1.  K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Date for Screening"
  1.  D ^DIR Q:Y<1  S APCLBD=Y
  1.  K DIR S DIR(0)="DO^:DT:EXP",DIR("A")="Enter Ending Date for Screening"
  1.  D ^DIR Q:Y<1  S APCLED=Y
  1.  ;
  1.  I APCLED<APCLBD D  G DATES
  1.  . W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
  1.  ;
  1. TALLY ;which items to tally
  1.  K APCLTALL
  1.  W !!,"Please select which items you wish to tally on this report:",!
  1.  W !?3,"0)  Do not include any Tallies",?40,"6)  Date of Screening"
  1.  W !?3,"1)  Type/Result of Screening",?40,"7)  Primary Provider on Visit"
  1.  W !?3,"2)  Gender",?40,"8)  Designated Primary Care Provider"
  1.  W !?3,"3)  Age of Patient"  ;,?40,"9)  Designated SS Provider (BH)"
  1.  W !?3,"4)  Provider who Screened"  ;,?40,"10) Designated ASA/CD Provider (BH)"
  1.  W !?3,"5)  Clinic",?40  ;,"11) Designated Primary Care Provider"
  1.  K DIR S DIR(0)="L^0:8",DIR("A")="Which items should be tallied",DIR("B")="" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G DATES
  1.  I Y="" G DATES
  1.  S APCLTALL=Y
  1.  S A=Y,C="" F I=1:1 S C=$P(A,",",I) Q:C=""  S APCLTALL(C)=""
  1. EXCL ;
  1.  S APCLEXPC=""
  1.  W !!,"Would you like to include screenings recorded in the Behavioral Clinics"
  1.  W !,"Mental Health (14); DEPRESSION and Substance Abuse (43), Medical Social"
  1.  S DIR(0)="Y",DIR("A")="Services, Behavioral Health (C4) and Telebehavioral Health (C9): ",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G DATES
  1.  S APCLEXPC=Y
  1. LIST ;
  1.  S APCLLIST=""
  1.  W !
  1.  S DIR(0)="Y",DIR("A")="Would you like to include a list of patients screened",DIR("B")="Y" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G DATES
  1.  S APCLLIST=Y
  1.  I 'APCLLIST G ZIS
  1. LIST1 ;
  1.  S APCLSORT=""
  1.  W !
  1.  S DIR(0)="S^H:Health Record Number;N:Patient Name;P:Provider who screened;C:Clinic;R:Result of Exam;D:Date Screened;A:Age of Patient at Screening;G:Gender of Patient;T:Terminal Digit HRN"
  1.  S DIR("A")="How would you like the list to be sorted",DIR("B")="H"
  1.  KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G LIST
  1.  S APCLSORT=Y
  1. DP ;
  1.  S APCLDP=""
  1.  W !
  1.  S DIR(0)="Y",DIR("A")="Display the Patient's Designated Providers on the list",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G LIST
  1.  S APCLDP=Y
  1. ZIS ;
  1.  S XBRP="PRINT^APCLDE1P",XBRC="PROC^APCLDE1",XBRX="XIT^APCLDE1",XBNS="APC"
  1.  D ^XBDBQUE
  1.  D XIT
  1.  Q
  1. XIT ;
  1.  D EN^XBVK("APC")
  1.  D ^XBFMK
  1.  Q
  1. PROC ;
  1.  S APCLCNT=0
  1.  S APCLH=$H,APCLJ=$J
  1.  K ^XTMP("APCLDE1",APCLJ,APCLH)
  1.  D XTMP^APCLOSUT("APCLDE1","DEPRESSION SCREENING REPORT")
  1.  ;now go through BH
  1.  S DFN=0 F  S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN  D
  1.  .;Q:'$$ALLOWP^APCUTIL(DUZ,DFN)  ;allowed to see this patient?
  1.  .S APCALSC="" I APCLEXPC S APCALSC=$$BHALCS(DFN,APCLBD,APCLED),APCPFI="BH"  ;include refusals
  1.  .S APCPCALS=""  S APCPCALS=$$PCCALCS(DFN,APCLBD,APCLED)  ;include refusals
  1.  .I $P(APCPCALS,U,1)>$P(APCALSC,U,1) S APCALSC=APCPCALS,APCPFI="PCC"
  1.  .S APCLEFS="" S APCLEFS=$$REFUSAL(DFN,9999999.15,$O(^AUTTEXAM("C",36,0)),APCLBD,APCLED)
  1.  .I $P(APCLEFS,U,1)>$P(APCALSC,U,1) S APCALSC=APCLEFS,APCPFI="PCC"
  1.  .I APCALSC="" Q  ;no screeningsI APCALSC="" Q  ;no screenings
  1.  .S ^XTMP("APCLDE1",APCLJ,APCLH,"PTS",DFN)=APCALSC,$P(^XTMP("APCLDE1",APCLJ,APCLH,"PTS",DFN),U,20)=APCPFI
  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)
  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.  ;----------
  1. BHALCS(P,BDATE,EDATE) ;EP - pass back last BH screening
  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,".")>EDATE)!(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^APCUTIL(DUZ,V)
  1.  ..;get measurements 
  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") 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,5)
  1.  ..I E]"" S R=$$BHRT(V,"DEPRESSION SCREENING",$$VAL^XBDIQ1(9002011,V,1405),P,$P($G(^AMHREC(V,14)),U,6),$P($G(^AMHREC(V,17)),U,1))
  1.  ..I R]"" Q
  1.  ..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.  ..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) ;EP
  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  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^APCAPI(P,BDATE,EDATE,"A")
  1.  NEW R,V,APCLDATE,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^APCUTIL(DUZ,V)
  1.  ..S APCLDATE=$P($P(^AUPNVSIT(V,0),U),".")
  1.  ..S DFN=$P(^AUPNVSIT(V,0),U,5)
  1.  ..Q:DFN=""
  1.  ..;Q:'$$ALLOWP^APCUTIL(DUZ,DFN)
  1.  ..I 'APCLEXPC S C=$$CLINIC^APCLV(V,"C") I C=14!(C=43)!(C=48)!(C="C4")!(C="C9") Q
  1.  ..I APCLEXPC,$D(^AHHREC("AVISIT",V)) Q  ;in BH module so already got it
  1.  ..S R=$$PCCSCR^APCLDE2(V)
  1.  Q R
  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 T=""
  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) ;EP
  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=1204
  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"