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

AMHRSR3.m

Go to the documentation of this file. 
  1. AMHRSR3 ; IHS/CMI/LAB - list SUICIDE RISK ASSESSMENT screenings ;
  1.  ;;4.0;IHS BEHAVIORAL HEALTH;**8**;JUN 02, 2010;Build 7
  1.  ;
  1.  ;
  1. INFORM ;
  1.  W !,$$CTR($$USR)
  1.  W !,$$LOC()
  1.  W !!,$$CTR("LISTING OF PATIENTS RECEIVING SUICIDE RISK ASSESSMENT,INCLUDING REFUSALS",80)
  1.  W !!,"This report will tally and optionally list all patients who have had"
  1.  W !,"Suicide Risk Assessments or a refusal documeted in the time frame specified"
  1.  W !,"by the user.  Suicide Risk Assessment is defined as any of the following"
  1.  W !,"documented:"
  1.  W !?10,"- Suicide Risk Assessment (Exam code 43)"
  1.  W !?10,"- refusal of exam code 43"
  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 visit),"
  1.  W !,"clinic, date of screening, designated PCP, MH Provider, SS Provider and A/SA"
  1.  W !,"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 !!,"You will be able to choose the patients by age, gender, clinic, primary "
  1.  W !,"provider or result of the screening."
  1.  W !
  1.  D DBHUSR^AMHUTIL
  1.  D XIT
  1.  S AMHREXC=$O(^AUTTEXAM("C",43,0))
  1.  I 'AMHREXC W !!,"Exam code 43 is missing from the EXAM table.  Cannot run report.",! H 3 D XIT Q
  1.  ;
  1. DATES K AMHRED,AMHRBD
  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 AMHRBD=Y
  1.  K DIR S DIR(0)="DO^:DT:EXP",DIR("A")="Enter Ending Date for Screening"
  1.  D ^DIR Q:Y<1  S AMHRED=Y
  1.  ;
  1.  I AMHRED<AMHRBD D  G DATES
  1.  . W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
  1.  ;
  1. EXCL ;
  1.  S AMHREXPC=""
  1.  W !!,"Would you like to include screenings documented in non-behavioral health"
  1.  S DIR(0)="Y",DIR("A")="clinics (those documented in PCC)",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G DATES
  1.  S AMHREXPC=Y
  1. SEX ;
  1.  S AMHRSEX=""
  1.  S DIR(0)="S^F:FEMALES Only;M:MALES Only;B:Both MALE and FEMALES",DIR("A")="Include which patients in the list",DIR("B")="F" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G EXCL
  1.  S AMHRSEX=Y
  1.  I AMHRSEX="B" S AMHRSEX="MF"
  1. AGE ;Age Screening
  1.  K AMHRAGE,AMHRAGET
  1.  W ! S DIR(0)="YO",DIR("A")="Would you like to restrict the report by Patient age range",DIR("B")="YES"
  1.  S DIR("?")="If you wish to include visits from ALL age ranges, anwser No.  If you wish to list visits for only patients within a particular age range, enter Yes."
  1.  D ^DIR K DIR
  1.  G:$D(DIRUT) SEX
  1.  I 'Y G RESULT
  1.  ;
  1. AGER ;Age Screening
  1.  W !
  1.  S DIR(0)="FO^1:7",DIR("A")="Enter an Age Range (e.g. 5-12,1-1)" D ^DIR
  1.  I Y="" W !!,"No age range entered." G AGE
  1.  I Y'?1.3N1"-"1.3N W !!,$C(7),$C(7),"Enter a numeric range in the format nnn-nnn. e.g. 0-5, 0-99, 5-20." G AGER
  1.  S AMHRAGET=Y
  1. RESULT ;result screenig
  1.  K AMHRREST
  1.  W !!,"You can limit the list to only patients who have had a screening"
  1.  W !,"in the time period on which the result was any combination of the"
  1.  W !,"following: (e.g. to get only those patients who have had a result of "
  1.  W !,"Present enter 2 to get all patients who have had a screening result of"
  1.  W !,"Past or Present, enter 2,3)",!
  1.  W !?3,"1)  Low"
  1.  W !?3,"2)  Moderate"
  1.  W !?3,"3)  High"
  1.  W !?3,"4)  Refused"
  1.  W !?3,"5)  Unable to Screen"
  1.  w !?3,"6)  Referral Needed"
  1.  W !?3,"7)  Screenings done with no result entered"
  1.  W !
  1.  K DIR S DIR(0)="L^1:7",DIR("A")="Which result values do you want included on this list",DIR("B")="" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G AGE
  1.  I Y="" G AGE
  1.  S AMHRREST=Y
  1.  S A=Y,C="" F I=1:1 S C=$P(A,",",I) Q:C=""  S AMHRREST(C)=""
  1. CLINIC ;
  1.  K AMHRCLNT
  1.  W ! S DIR(0)="Y",DIR("A")="Include visits to ALL clinics",DIR("B")="Yes" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  G:$D(DIRUT) RESULT
  1.  I Y=1 G PRIMPRV
  1. CLINIC1 ;
  1.  S X="CLINIC",DIC="^AMQQ(5,",DIC(0)="FM",DIC("S")="I $P(^(0),U,14)" D ^DIC K DIC,DA I Y=-1 W "OOPS - QMAN NOT CURRENT - QUITTING" G XIT
  1.  D PEP^AMQQGTX0(+Y,"AMHRCLNT(")
  1.  I '$D(AMHRCLNT) G CLINIC
  1.  I $D(AMHRCLNT("*")) K AMHRCLNT
  1. PRIMPRV ;
  1.  S (AMHRDISC,AMHRPSRT,AMHRPPUN)="" K AMHRPROV
  1.  S DIR(0)="SO^O:One Provider Only;P:Any/All Providers (including unknown);U:Unknown Provider Only"
  1.  S DIR("A")="Report should include visits whose PRIMARY PROVIDER on the visit is"
  1.  S DIR("?")="If you wish to count only one primary provider of service enter a 'O'.  To include ALL providers enter an 'A'.  To include all providers of one discipline enter a 'D'." D ^DIR K DIR
  1.  G:$D(DIRUT) XIT
  1.  S AMHRPSRT=Y
  1.  I Y="P" K AMHRPROV G PRVSCR
  1.  I Y="U" S AMHRPPUN=1 G PRVSCR
  1. PRV1 ;
  1.  I $P(^DD(9000010.06,.01,0),U,2)[200 S DIC="^VA(200,",DIC(0)="AEMQ",D="AK.PROVIDER",DIC("A")="Enter PROVIDER (Lastname,Firstname): " D MIX^DIC1 K DIC,D
  1.  I $P(^DD(9000010.06,.01,0),U,2)[6 S DIC="^DIC(6,",DIC(0)="AEMQ",DIC("A")="Enter PROVIDER (Lastname,Firstname): " D ^DIC K DIC
  1.  I $D(DTOUT)!(Y=-1) G PRIMPRV
  1.  S AMHRPROV=+Y
  1. PRVSCR ;
  1.  S (AMHRSSRT,AMHRSPUN)="" K AMHRSPRV
  1.  S DIR(0)="SO^O:One Provider Only;P:Any/All Providers (including unknown);U:Unknown Provider Only"
  1.  S DIR("A")="Select which providers who performed the screening should be included"
  1.  S DIR("?")="If you wish to count only one Provider enter a 'O'.  To include ALL providers enter an 'A'.  To include all providers of one discipline enter a 'D'." D ^DIR K DIR
  1.  G:$D(DIRUT) XIT
  1.  S AMHRSSRT=Y
  1.  I Y="P" K AMHRSPRV G DESPRV
  1.  I Y="U" S AMHRSPUN=1 G DESPRV
  1. SCRPRV1 ;
  1.  S DIC="^VA(200,",DIC(0)="AEMQ",D="AK.PROVIDER",DIC("A")="Enter PROVIDER (Lastname,Firstname): " D MIX^DIC1 K DIC,D
  1.  I $D(DTOUT)!(Y=-1) G PRVSCR
  1.  S AMHRSPRV=+Y
  1. DESPRV ;
  1.  S AMHRDESP=""
  1.  W !!,"Would you like to limit the list to just patients who have"
  1.  S DIR(0)="Y",DIR("A")="a particular designated Mental Health provider",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G PRIMPRV
  1.  I 'Y S AMHRDESP="" G SSPRV
  1. DESPRV1 ;
  1.  S DIC="^VA(200,",DIC(0)="AEMQ",D="AK.PROVIDER",DIC("A")="Enter PROVIDER (Lastname,Firstname): " D MIX^DIC1 K DIC,D
  1.  I $D(DTOUT)!(Y=-1) G DESPRV
  1.  S AMHRDESP=+Y
  1. SSPRV ;
  1.  S AMHRSSP=""
  1.  W !!,"Would you like to limit the list to just patients who have"
  1.  S DIR(0)="Y",DIR("A")="a particular designated Social Services provider",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G DESPRV
  1.  I 'Y S AMHRSSP="" G CDPRV
  1. SSPRV1 ;
  1.  S DIC="^VA(200,",DIC(0)="AEMQ",D="AK.PROVIDER",DIC("A")="Enter PROVIDER (Lastname,Firstname): " D MIX^DIC1 K DIC,D
  1.  I $D(DTOUT)!(Y=-1) G SSPRV
  1.  S AMHRSSP=+Y
  1. CDPRV ;
  1.  S AMHRCDP=""
  1.  W !!,"Would you like to limit the list to just patients who have"
  1.  S DIR(0)="Y",DIR("A")="a particular designated ASA/CD provider",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G SSPRV
  1.  I 'Y S AMHRCDP="" G TEMP
  1. CDPRV1 ;
  1.  S DIC="^VA(200,",DIC(0)="AEMQ",D="AK.PROVIDER",DIC("A")="Enter PROVIDER (Lastname,Firstname): " D MIX^DIC1 K DIC,D
  1.  I $D(DTOUT)!(Y=-1) G CDPRV
  1.  S AMHRCDP=+Y
  1. TEMP ;TEMPLATE OR LIST
  1.  S AMHRTMPL="",AMHRSTMP=""
  1.  S DIR(0)="SO^L:List of Patient Screenings;S:Create a Search Template of Patients",DIR("B")="L",DIR("A")="Select Report Type"
  1.  D ^DIR K DIR
  1.  I $D(DIRUT) G DESPRV
  1.  S AMHRTMPL=Y
  1.  I AMHRTMPL="S" D ^AMHRSTMP G:AMHRSTMP="" TEMP G DEMO
  1. LIST1 ;
  1.  S AMHRSORT=""
  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 PRIMPRV
  1.  S AMHRSORT=Y
  1. DP ;
  1.  S AMHRDP=""
  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 LIST1
  1.  S AMHRDP=Y
  1. DEMO ;
  1.  D DEMOCHK^AMHUTIL1(.AMHDEMO)
  1.  I AMHDEMO=-1 G TEMP
  1. ZIS ;
  1.  S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to ",DIR("B")="P" K DA D ^DIR K DIR
  1.  I $D(DIRUT) G XIT
  1.  I $G(Y)="B" D BROWSE,XIT Q
  1.  S XBRP="PRINT^AMHRSR3P",XBRC="PROC^AMHRSR31",XBRX="XIT^AMHRSR3",XBNS="AMH"
  1.  D ^XBDBQUE
  1.  D XIT
  1.  Q
  1. BROWSE ;
  1.  S XBRP="VIEWR^XBLM(""^AMHRSR3P"")"
  1.  S XBNS="AMH",XBRC="PROC^AMHRSR31",XBRX="XIT^AMHRSR3",XBIOP=0 D ^XBDBQUE
  1.  Q
  1. XIT ;
  1.  D EN^XBVK("AMHR")
  1.  D ^XBFMK
  1.  Q
  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.  ;----------