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

AMHLESF1.m

Go to the documentation of this file. 
  1. AMHLESF1 ; IHS/CMI/LAB - ;
  1.  ;;4.0;IHS BEHAVIORAL HEALTH;**6**;JUN 02, 2010;Build 10
  1.  ;
  1. EN ;
  1.  W:$D(IOF) @IOF
  1.  W !!,$$CTR("*** Print Suicide Reporting Form ***"),!!
  1.  S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC
  1.  I Y=-1 D EXIT Q
  1.  I $G(AUPNDOD)]"" W !!?10,"***** PATIENT'S DATE OF DEATH IS ",$$FMTE^XLFDT(AUPNDOD),!! H 2
  1.  S DFN=+Y
  1.  W !
  1.  D EP(DFN)
  1.  D EXIT
  1.  Q
  1. EP(AMHSF) ;EP - when form is known
  1. ZIS ;
  1.  W ! 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) D EXIT Q
  1.  S AMHOPT=Y
  1.  I Y="B" D BROWSE,EXIT Q
  1.  S XBRP="PRINT^AMHLESF1",XBRC="",XBRX="EXIT^AMHLESF1",XBNS="AMH*;DFN"
  1.  D ^XBDBQUE
  1.  D EXIT
  1.  Q
  1. BROWSE ;
  1.  S XBRP="VIEWR^XBLM(""PRINT^AMHLESF1"")"
  1.  S XBRC="",XBRX="EXIT^AMHLESF1",XBIOP=0 D ^XBDBQUE
  1.  Q
  1. EXIT ;
  1.  K AMHOPT,AMHSF,AMHX,AMHOD,AMHSQIT,AMHQUIT
  1.  ;D EN^XBVK("AMH")
  1.  D ^XBFMK
  1.  Q
  1. EP2(AMHSF) ;
  1.  S DFN=$P(^AMHPSUIC(AMHSF,0),U,4)
  1.  K ^TMP("AMHS",$J,"DCS")
  1.  S ^TMP("AMHS",$J,"DCS",0)=0
  1.  D SETARRAY
  1.  Q
  1. SETARRAY ;set up array containing suicide form
  1.  S X="Suicide Reporting Form                       Date Printed:  "_$$FMTE^XLFDT(DT) D S(X)
  1.  S X="1. Case #: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.01),$E(X,40)="Local Case #: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.02) D S(X,1)
  1.  S X="2. PROVIDER INITIALS: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.031),$E(X,40)="3. PROVIDER DISCIPLINE: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.032) D S(X,1)
  1.  S X="4. SEX: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.041),$E(X,25)="5. DOB: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.042),$E(X,58)="6. AGE: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.043) D S(X)
  1.  S X="7. EMPLOYMENT STATUS: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.05) D S(X)
  1.  S X="8. DATE OF ACT: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.06) D S(X)
  1.  S X="9. TRIBE: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.044) D S(X)
  1.  S X="10. COMMUNITY OF RESIDENCE: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.045) D S(X)
  1.  S X="11. COMMUNITY WHERE ACT OCCURRED: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.07) D S(X)
  1.  S X="12. RELATIONSHIP STATUS: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.08) D S(X,1)
  1.  ;I $P(^AMHPSUIC(AMHSF,0),U,9)]"" S X="    RELATIONSHIP IF OTHER: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.09) D S(X)
  1.  S X="13. EDUCATION: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.11) D S(X,1)
  1.  I $P(^AMHPSUIC(AMHSF,0),U,12)]"" S X="    IF LESS THAN 12 YEARS, HIGHEST GRADE COMPLETED: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.12) D S(X)
  1.  S X="14. SUICIDAL BEHAVIOR: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.131) D S(X,1)
  1. MET ;
  1.  K AMHOD,AMHO S Y="",Z=0 F  S Z=$O(^AMHPSUIC(AMHSF,11,Z)) Q:Z'=+Z  S Y=Y_$$EXTSET^XBFUNC(9002011.6511,.01,$P(^AMHPSUIC(AMHSF,11,Z,0),U))_"  " D
  1.  .I $P(^AMHPSUIC(AMHSF,11,Z,0),U,2)]"" S AMHO(Z)=$P(^AMHPSUIC(AMHSF,11,Z,0),U,2)
  1.  .S A=0 F  S A=$O(^AMHPSUIC(AMHSF,11,Z,11,A)) Q:A'=+A  D
  1.  ..S AMHOD(Z,A)=$P(^AMHTSDRG($P(^AMHPSUIC(AMHSF,11,Z,11,A,0),U),0),U) S %=$P(^AMHPSUIC(AMHSF,11,Z,11,A,0),U,2) I %]"" S AMHOD(Z,A)=AMHOD(Z,A)_" - "_%
  1.  ..Q
  1.  S X="15. METHOD: "_Y D
  1.  .K ^UTILITY($J,"W") S DIWL=0,DIWR=65 D ^DIWP
  1.  .D S($G(^UTILITY($J,"W",0,1,0)))
  1.  .S AMHX=1 F  S AMHX=$O(^UTILITY($J,"W",0,AMHX)) Q:AMHX'=+AMHX  D S("    "_$G(^UTILITY($J,"W",0,AMHX,0)))
  1.  .K ^UTILITY($J,"W")
  1.  I $D(AMHO) S X="    OTHER METHOD: " D
  1.  .S A=0 F  S A=$O(AMHO(A)) Q:A'=+A  S X=X_AMHO(A)_" "
  1.  .D S(X)
  1.  I $D(AMHOD) D
  1.  .S X="    DRUGS W/OVERDOSE: " D S(X)
  1.  .S Y=0 F  S Y=$O(AMHOD(Y)) Q:Y'=+Y  D
  1.  ..S A=0 F  S A=$O(AMHOD(Y,A)) Q:A'=+A  S X="     "_AMHOD(Y,A) D
  1.  ...K ^UTILITY($J,"W") S DIWL=0,DIWR=72 D ^DIWP
  1.  ...D S($G(^UTILITY($J,"W",0,1,0)))
  1.  ...S AMHX=1 F  S AMHX=$O(^UTILITY($J,"W",0,AMHX)) Q:AMHX'=+AMHX  D S("     "_$G(^UTILITY($J,"W",0,AMHX,0)))
  1.  ...K ^UTILITY($J,"W")
  1.  S X="16. PREVIOUS ATTEMPTS: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.14) D S(X,1)
  1. DRUG ;
  1.  S X="17. SUBSTANCE USE INVOLVED: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.26) D S(X,1)
  1.  I $P(^AMHPSUIC(AMHSF,0),U,26)=2 D
  1.  .S X="    ALCOHOL OR DRUGS INVOLVED: "
  1.  .S Y=0 F  S Y=$O(^AMHPSUIC(AMHSF,15,Y)) Q:Y'=+Y  D
  1.  ..S A=$P(^AMHPSUIC(AMHSF,15,Y,0),U) I A S X="     "_$P($G(^AMHTSSU(A,0)),U) D S(X)
  1.  ..S X=$P(^AMHPSUIC(AMHSF,15,Y,0),U,2) I X]"" S X="     OTHER DRUG: "_X D
  1.  ...K ^UTILITY($J,"W") S DIWL=0,DIWR=72 D ^DIWP
  1.  ...D S($G(^UTILITY($J,"W",0,1,0)))
  1.  ...S AMHX=1 F  S AMHX=$O(^UTILITY($J,"W",0,AMHX)) Q:AMHX'=+AMHX  D S("     "_$G(^UTILITY($J,"W",0,AMHX,0)))
  1.  ...K ^UTILITY($J,"W")
  1.  S X="18. LOCATION OF ACT: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.15) D S(X,1)
  1.  I $P($G(^AMHPSUIC(AMHSF,14)),U)]"" S X="18.1 LOCATION OF ACT, IF OTHER: "_$$VAL^XBDIQ1(9002011.65,AMHSF,1401) D
  1.  .K ^UTILITY($J,"W") S DIWL=0,DIWR=70 D ^DIWP
  1.  .D S($G(^UTILITY($J,"W",0,1,0)))
  1.  .S AMHX=1 F  S AMHX=$O(^UTILITY($J,"W",0,AMHX)) Q:AMHX'=+AMHX  D S("     "_$G(^UTILITY($J,"W",0,AMHX,0)))
  1.  .K ^UTILITY($J,"W")
  1.  I $$VERSION^XPDUTL("AMH")<4 D  I 1
  1.  .S X="19. LETHALITY: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.24) D S(X,1)
  1.  .S X="20. CONTRIBUTING FACTORS: " D S(X,1)
  1.  .S AMHZ=0 F  S AMHZ=$O(^AMHPSUIC(AMHSF,13,AMHZ)) Q:AMHZ'=+AMHZ  S X="      "_$P(^AMHTSCF($P(^AMHPSUIC(AMHSF,13,AMHZ,0),U),0),U) S:$P(^AMHPSUIC(AMHSF,13,Z,0),U,2)]"" X=X_" - "_$P(^AMHPSUIC(AMHSF,13,AMHZ,0),U,2) D S(X)
  1.  .S X="21. DISPOSITION: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.25) D S(X,1)
  1.  .I $P($G(^AMHPSUIC(AMHSF,14)),U,2)]"" S X="21.1 DISPOSITION, IF OTHER: "_$$VAL^XBDIQ1(9002011.65,AMHSF,1402) D S(X)
  1.  .;S X="20b. INTERVENTION (COMPLETED): "_$$VAL^XBDIQ1(9002011.65,AMHSF,.17) D S(X,1)
  1.  .;S X="  Describe in our own words what you believe contributed to this " D S(X,1)
  1.  E  D
  1.  .S X="19. CONTRIBUTING FACTORS: " D S(X,1)
  1.  .S AMHZ=0 F  S AMHZ=$O(^AMHPSUIC(AMHSF,13,AMHZ)) Q:AMHZ'=+AMHZ  S X="      "_$P(^AMHTSCF($P(^AMHPSUIC(AMHSF,13,AMHZ,0),U),0),U) S:$P(^AMHPSUIC(AMHSF,13,AMHZ,0),U,2)]"" X=X_" - "_$P(^AMHPSUIC(AMHSF,13,AMHZ,0),U,2) D
  1.  ..K ^UTILITY($J,"W") S DIWL=0,DIWR=70 D ^DIWP
  1.  ..D S($G(^UTILITY($J,"W",0,1,0)))
  1.  ..S AMHX=1 F  S AMHX=$O(^UTILITY($J,"W",0,AMHX)) Q:AMHX'=+AMHX  D S("     "_$G(^UTILITY($J,"W",0,AMHX,0)))
  1.  ..K ^UTILITY($J,"W")
  1.  .S X="20. DISPOSITION: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.25) D S(X,1)
  1.  .I $P($G(^AMHPSUIC(AMHSF,14)),U,2)]"" S X="20.1 DISPOSITION, IF OTHER: "_$$VAL^XBDIQ1(9002011.65,AMHSF,1402) D
  1.  ..K ^UTILITY($J,"W") S DIWL=0,DIWR=70 D ^DIWP
  1.  ..D S($G(^UTILITY($J,"W",0,1,0)))
  1.  ..S AMHX=1 F  S AMHX=$O(^UTILITY($J,"W",0,AMHX)) Q:AMHX'=+AMHX  D S("     "_$G(^UTILITY($J,"W",0,AMHX,0)))
  1.  ..K ^UTILITY($J,"W")
  1.  S X="  Other Relevant Information: (OPTIONAL)" D S(X,1)
  1.  S X="  " D S(X,1)
  1. WP ;
  1.  K ^UTILITY($J,"W")
  1.  S AMHX=0
  1.  S DIWL=5,DIWR=75 F  S AMHX=$O(^AMHPSUIC(AMHSF,41,AMHX)) Q:AMHX'=+AMHX  D
  1.  .S X=$TR(^AMHPSUIC(AMHSF,41,AMHX,0),$C(10)) D ^DIWP
  1.  .Q
  1. WPS ;
  1.  S Z=0 F  S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z  S X="",$E(X,5)=^UTILITY($J,"W",DIWL,Z,0) D S(X)
  1.  K DIWL,DIWR,DIWF,Z
  1.  K ^UTILITY($J,"W"),AMHX
  1.  S X="DIVISION: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.28) D S(X,1)
  1.  S X="DATE LAST MODIFIED: "_$$VAL^XBDIQ1(9002011.65,AMHSF,.21) D S(X,1)
  1.  S X="USER LAST UPDATED:  "_$$VAL^XBDIQ1(9002011.65,AMHSF,.22) D S(X)
  1.  S X="EDIT HISTORY: " D S(X)
  1.  S F=0 F  S F=$O(^AMHPSUIC(AMHSF,51,F)) Q:F'=+F  D
  1.  .Q:'$D(^AMHPSUIC(AMHSF,51,F,0))
  1.  .Q:$P(^AMHPSUIC(AMHSF,51,F,0),U)=""
  1.  .Q:$P(^AMHPSUIC(AMHSF,51,F,0),U,2)=""
  1.  .S X="  "_$$FMTE^XLFDT($P(^AMHPSUIC(AMHSF,51,F,0),U),"1P"),$E(X,30)=$P($G(^VA(200,$P(^AMHPSUIC(AMHSF,51,F,0),U,2),0)),U) D S(X)
  1.  Q
  1. S(Y,F,C,T) ;set up array
  1.  I '$G(F) S F=0
  1.  I '$G(T) S T=0
  1.  ;blank lines
  1.  F F=1:1:F S X="" D S1
  1.  S X=Y
  1.  I $G(C) S L=$L(Y),T=(80-L)/2 D  D S1 Q
  1.  .F %=1:1:(T-1) S X=" "_X
  1.  F %=1:1:T S X=" "_Y
  1.  D S1
  1.  Q
  1. S1 ;
  1.  S %=$P(^TMP("AMHS",$J,"DCS",0),U)+1,$P(^TMP("AMHS",$J,"DCS",0),U)=%
  1.  S ^TMP("AMHS",$J,"DCS",%)=X
  1.  Q
  1. PRINT ;
  1.  K ^TMP("AMHS",$J)
  1.  D EP2(AMHSF) ;gather up data
  1. W ;write out array
  1.  W:$D(IOF) @IOF
  1.  K AMHQUIT
  1.  W !,"********** CONFIDENTIAL PATIENT INFORMATION ["_$P(^VA(200,DUZ,0),U,2)_"]  "_$$FMTE^XLFDT(DT)_" **********"
  1.  S AMHX=0 F  S AMHX=$O(^TMP("AMHS",$J,"DCS",AMHX)) Q:AMHX'=+AMHX!($D(AMHQUIT))  D
  1.  .I $Y>(IOSL-3) D HEADER Q:$D(AMHQUIT)
  1.  .W !,^TMP("AMHS",$J,"DCS",AMHX)
  1.  .Q
  1.  I $D(AMHQUIT) S AMHSQIT=1
  1.  D EOJ
  1.  Q
  1.  ;
  1. EOJ ;
  1.  K ^TMP("AMHS",$J)
  1.  K AMHX,AMHQUIT,AMHY,AMHSBEG,AMHSTOB,AMHSUPI,AMHSED,AMHTOBN,AMHTOB,AMHOD,AMHO,X,Y,Z,AMHOPT,AMHSF,AMHSQIT,AMHOD
  1.  K N,%,T,F,X,Y,B,C,E,F,H,L,N,P,T,W
  1.  Q
  1.  I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S AMHQUIT="" Q
  1. HEAD1 ;
  1.  W:$D(IOF) @IOF
  1.  W !,"********** CONFIDENTIAL PATIENT INFORMATION ["_$P(^VA(200,DUZ,0),U,2)_"]  "_$$FMTE^XLFDT(DT)_" **********",!!
  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. 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.  ;----------