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

APCDLES1.m

Go to the documentation of this file. 
  1. APCDLES1 ; IHS/CMI/LAB - SUICIDE FORM PART 2 ;
  1.  ;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009;Build 11
  1.  ;
  1. EN ;
  1.  W:$D(IOF) @IOF
  1.  W !!,$$CTR("*** Print Suicide Form ***"),!!
  1.  S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC
  1.  I Y=-1 D EXIT Q
  1.  S DFN=+Y
  1.  W !
  1.  D EP(DFN)
  1.  D EXIT
  1.  Q
  1. EP(APCDSF) ;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 APCDOPT=Y
  1.  I Y="B" D BROWSE,EXIT Q
  1.  S XBRP="PRINT^APCDLES1",XBRC="",XBRX="EXIT^APCDLES1",XBNS="APCD*;DFN"
  1.  D ^XBDBQUE
  1.  D EXIT
  1.  Q
  1. BROWSE ;
  1.  S XBRP="VIEWR^XBLM(""PRINT^APCDLES1"")"
  1.  S XBRC="",XBRX="EXIT^APCDLES1",XBIOP=0 D ^XBDBQUE
  1.  Q
  1. EXIT ;
  1.  K APCDOPT,APCDSF,APCDX,APCDOD,APCDSQIT,APCDQUIT,APCDO
  1.  ;D EN^XBVK("APCD")
  1.  D ^XBFMK
  1.  Q
  1. EP2(APCDSF) ;PEP - CALLED BY ICARE
  1.  NEW DFN,APCDO,APCDOD,X,Y,Z,A,DIWL,DIWR,DIWF,APCDX
  1.  S DFN=$P(^AMHPSUIC(APCDSF,0),U,4)
  1.  K ^TMP("APCDS",$J,"DCS")
  1.  S ^TMP("APCDS",$J,"DCS",0)=0
  1.  D SETARRAY
  1.  Q
  1. SETARRAY ;set up array containing dm care summary
  1.  S X="Suicide Reporting Form                   Date Printed:  "_$$FMTE^XLFDT(DT) D S(X)
  1.  S X="1. Case #: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.01),$E(X,40)="Local Case #: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.02) D S(X,1)
  1.  S X="2. PROVIDER INITIALS: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.031),$E(X,40)="3. PROVIDER DISCIPLINE: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.032) D S(X,1)
  1.  S X="4. SEX: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.041),$E(X,25)="5. DOB: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.042),$E(X,58)="6. AGE: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.043) D S(X)
  1.  S X="7. EMPLOYMENT STATUS: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.05) D S(X)
  1.  S X="8. DATE OF ACT: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.06) D S(X)
  1.  S X="9. TRIBE: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.044) D S(X)
  1.  S X="10. COMMUNITY OF RESIDENCE: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.045) D S(X)
  1.  S X="11. COMMUNITY WHERE ACT OCCURRED: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.07) D S(X)
  1.  S X="12. RELATIONSHIP STATUS: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.08) D S(X,1)
  1.  ;I $P(^AMHPSUIC(APCDSF,0),U,9)]"" S X="    RELATIONSHIP IF OTHER: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.09) D S(X)
  1.  S X="13. EDUCATION: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.11) D S(X,1)
  1.  I $P(^AMHPSUIC(APCDSF,0),U,12)]"" S X="    IF LESS THAN 12 YEARS, HIGHEST GRADE COMPLETED: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.12) D S(X)
  1.  S X="14. SELF DESTRUCTIVE ACT: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.13) D S(X,1)
  1. MET ;
  1.  K APCDOD,APCDO S Y="",Z=0 F  S Z=$O(^AMHPSUIC(APCDSF,11,Z)) Q:Z'=+Z  S Y=Y_$$EXTSET^XBFUNC(9002011.6511,.01,$P(^AMHPSUIC(APCDSF,11,Z,0),U))_"  " D
  1.  .I $P(^AMHPSUIC(APCDSF,11,Z,0),U,2)]"" S APCDO(Z)=$P(^AMHPSUIC(APCDSF,11,Z,0),U,2)
  1.  .S A=0 F  S A=$O(^AMHPSUIC(APCDSF,11,Z,11,A)) Q:A'=+A  D
  1.  ..S APCDOD(Z,A)=$P(^AMHTSDRG($P(^AMHPSUIC(APCDSF,11,Z,11,A,0),U),0),U)_"   "_$P(^AMHPSUIC(APCDSF,11,Z,11,A,0),U,2)
  1.  ..Q
  1.  S X="15. METHOD: "_Y D S(X,1)
  1.  I $D(APCDO) S X="    OTHER METHOD: " D
  1.  .S A=0 F  S A=$O(APCDO(A)) Q:A'=+A  S X=X_APCDO(A)_"  "
  1.  .D S(X)
  1.  I $D(APCDOD) D
  1.  .S X="    DRUGS W/OVERDOSE: "
  1.  .S Y=0 F  S Y=$O(APCDOD(Y)) Q:Y'=+Y  D
  1.  ..S A=0 F  S A=$O(APCDOD(Y,A)) Q:A'=+A  S X=X_APCDOD(Y,A)_"  "
  1.  .D S(X)
  1.  S X="16. PREVIOUS ATTEMPTS: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.14) D S(X,1)
  1. DRUG ;
  1.  S X="17. SUBSTANCE USE INVOLVED: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.26) D S(X,1)
  1.  I $P(^AMHPSUIC(APCDSF,0),U,26)=2 D
  1.  .S X="    ALCOHOL OR DRUGS INVOLVED: "
  1.  .S Y=0 F  S Y=$O(^AMHPSUIC(APCDSF,15,Y)) Q:Y'=+Y  D
  1.  ..S A=$P(^AMHPSUIC(APCDSF,15,Y,0),U) I A S X="     "_$P($G(^AMHTSSU(A,0)),U) D S(X)
  1.  ..S X=$P(^AMHPSUIC(APCDSF,15,Y,0),U,2) I X]"" S X="     OTHER DRUG: "_X D S(X)
  1.  S X="18. LOCATION OF ACT: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.15) D S(X,1)
  1.  I $P($G(^AMHPSUIC(APCDSF,14)),U)]"" S X="18.1 LOCATION OF ACT, IF OTHER: "_$$VAL^XBDIQ1(9002011.65,APCDSF,1401) D S(X)
  1.  ;S X="19. LETHALITY: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.24) D S(X,1)
  1.  S X="19. CONTRIBUTING FACTORS: " D S(X,1)
  1.  S Z=0 F  S Z=$O(^AMHPSUIC(APCDSF,13,Z)) Q:Z'=+Z  S X="      "_$P(^AMHTSCF($P(^AMHPSUIC(APCDSF,13,Z,0),U),0),U) S:$P(^AMHPSUIC(APCDSF,13,Z,0),U,2)]"" X=X_" - "_$P(^AMHPSUIC(APCDSF,13,Z,0),U,2) D S(X)
  1.  S X="20. DISPOSITION: "_$$VAL^XBDIQ1(9002011.65,APCDSF,.25) D S(X,1)
  1.  I $P($G(^AMHPSUIC(APCDSF,14)),U,2)]"" S X="20.1 DISPOSITION, IF OTHER: "_$$VAL^XBDIQ1(9002011.65,APCDSF,1402) D S(X)
  1.  ;S X="20b. INTERVENTION (COMPLETED): "_$$VAL^XBDIQ1(9002011.65,APCDSF,.17) D S(X,1)
  1.  ;S X="  Describe in our own words what you believe contributed to this " D S(X,1)
  1.  S X="  Other Relevant Information: (OPTIONAL)" D S(X,1)
  1. WP ;
  1.  K ^UTILITY($J,"W")
  1.  S APCDX=0
  1.  S DIWL=5,DIWR=75 F  S APCDX=$O(^AMHPSUIC(APCDSF,41,APCDX)) Q:APCDX'=+APCDX  D
  1.  .S X=^AMHPSUIC(APCDSF,41,APCDX,0) 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"),APCDX
  1.  Q
  1. S(Y,F,C,T) ;set up array
  1.  NEW X,L
  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("APCDS",$J,"DCS",0),U)+1,$P(^TMP("APCDS",$J,"DCS",0),U)=%
  1.  S ^TMP("APCDS",$J,"DCS",%)=X
  1.  Q
  1. PRINT ;
  1.  K ^TMP("APCDS",$J)
  1.  D EP2(APCDSF) ;gather up data
  1. W ;write out array
  1.  W:$D(IOF) @IOF
  1.  K APCDQUIT
  1.  W !,"********** CONFIDENTIAL PATIENT INFORMATION ["_$P(^VA(200,DUZ,0),U,2)_"]  "_$$FMTE^XLFDT(DT)_" **********"
  1.  S APCDX=0 F  S APCDX=$O(^TMP("APCDS",$J,"DCS",APCDX)) Q:APCDX'=+APCDX!($D(APCDQUIT))  D
  1.  .I $Y>(IOSL-3) D HEADER Q:$D(APCDQUIT)
  1.  .W !,^TMP("APCDS",$J,"DCS",APCDX)
  1.  .Q
  1.  I $D(APCDQUIT) S APCDSQIT=1
  1.  D EOJ
  1.  Q
  1.  ;
  1. EOJ ;
  1.  K ^TMP("APCDS",$J)
  1.  K APCDX,APCDQUIT,APCDY,APCDSBEG,APCDSTOB,APCDSUPI,APCDSED,APCDTOBN,APCDTOB,APCDOD,APCDO,X,Y,Z,APCDOPT,APCDSF,APCDSQIT,APCDOD
  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 APCDQUIT="" 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.  ;----------