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