AMHRPSU2 ; IHS/CMI/LAB - Suicide Form data element tally ;
;;4.0;IHS BEHAVIORAL HEALTH;**1,8**;JUN 02, 2010;Build 7
;
;
START ;
D EN^XBVK("AMH")
W:$D(IOF) @IOF
W !!,"Aggregate Suicide Data Report - Selected Variables"
W !!,"This report will tally the data items selected by the user for Suicide",!,"Forms in a date range.",!!
;D PAUSE
;GETDATES ;
D DBHUSRP^AMHUTIL
BD ;
S DIR(0)="D^::EP",DIR("A")="Enter Beginning Date of Suicide Act",DIR("?")="Enter the beginning date of suicide act for the search." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
G:$D(DIRUT) EOJ
S AMHBD=Y
ED ;
S DIR(0)="DA^::EP",DIR("A")="Enter Ending Date of Suicide Act: " D ^DIR K DIR,DA S:$D(DUOUT) DIRUT=1
G:$D(DIRUT) EOJ
I Y<AMHBD W !,"Ending date must be greater than or equal to beginning date!" G ED
S AMHED=Y
S X1=AMHBD,X2=-1 D C^%DTC S AMHSD=X
I $D(AMHQUIT) D EOJ Q
D ADD
S AMHTCW=0,AMHPCNT=0
S AMHPTVS="S",AMHXREF="SU"
S AMHRPTC=7
SCREEN ;
K ^AMHTRPT(AMHRPT,11) S AMHCNTL="S",AMHTYPE="SU",AMHPTTX="Suicide Form",AMHPTTS="Suicide Forms" D ^AMHRL4 K AMHRDTR,AMHCNTL I $D(AMHQUIT) D DEL^AMHRL G EOJ
DEMO ;
D DEMOCHK^AMHUTIL1(.AMHDEMO)
I AMHDEMO=-1 G BD
ZIS ;
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) G EOJ
I $G(Y)="B" D BROWSE,EOJ Q
W !! S XBRP="PRINT^AMHRPSU2",XBRC="PROC^AMHRPSU2",XBNS="AMH",XBRX="EOJ^AMHRPSU2"
D ^XBDBQUE
D EOJ
Q
BROWSE ;
S XBRP="VIEWR^XBLM(""PRINT^AMHRPSU2"")"
S XBNS="AMH",XBRC="PROC^AMHRPSU2",XBRX="EOJ^AMHRPSU2",XBIOP=0 D ^XBDBQUE
Q
;
ADD ;EP
S %H=$H D YX^%DTC S X=$P(^VA(200,DUZ,0),U)_"-"_Y,DIC(0)="L",DIC="^AMHTRPT(",DLAYGO=9002013.8,DIADD=1 D ^DIC K DIC,DA,DR,DIADD,DLAYGO I Y=-1 W !!,"UNABLE TO CREATE REPORT FILE ENTRY - NOTIFY SITE MANAGER!" S AMHQUIT=1 Q
S AMHRPT=+Y
K DIC,DIADD,DLAYGO,DR,DA,DD,X,Y,DINUM
;DELETE ALL 11 MULTIPLE HERE
K ^AMHTRPT(AMHRPT,11)
Q
PAUSE ;
S DIR(0)="E",DIR("A")="Press return to continue or '^' to quit" D ^DIR K DIR,DA
S:$D(DIRUT) AMHQUIT=1
W:$D(IOF) @IOF
Q
EOJ ;
D DEL^AMHRL
D EN^XBVK("AMH")
K L,M,S,T,X,X1,X2,Y,Z,B
D KILL^AUPNPAT
D ^XBFMK
Q
PROC ;EP
S AMHJ=$J,AMHH=$H
K ^XTMP("AMHRPSU2",AMHJ,AMHH)
D XTMP("AMHRPSU2","AMH - SUICIDE")
V ; Run by visit date
K AMHTOT,AMHIA,AMHCS S AMHTOT=0,AMHIA=0,AMHCS=0
;S AMHR=0 F S AMHR=$O(^AMHPSUIC(AMHR)) Q:AMHR'=+AMHR D V1
F S AMHSD=$O(^AMHPSUIC("AD",AMHSD)) Q:AMHSD=""!((AMHSD\1)>AMHED) D V1
Q
;
V1 ;
S AMHR="" F S AMHR=$O(^AMHPSUIC("AD",AMHSD,AMHR)) Q:AMHR'=+AMHR D V2
Q
;
V2 ;
S AMHR0=^AMHPSUIC(AMHR,0)
S DFN=$P(AMHR0,U,4)
;I DFN,'$$ALLOWP^AMHUTIL(DUZ,DFN) Q
Q:$$DEMO^AMHUTIL1(DFN,$G(AMHDEMO))
D SCREENS
Q:$D(AMHSKIP)
S AMHTOT=AMHTOT+1
S AMHSUC=$P(^AMHPSUIC(AMHR,0),U,7) I $D(AMHCOMM),'$D(AMHCOMM(AMHSUC)) Q
S A=$$VAL^XBDIQ1(9002011.65,AMHR,.043)
;tally each date element
S AMHC=0 F AMHX=.131,.032,.03,.041,.05,.044,.045,.08,.11 D
.S AMHC=AMHC+1
.S X=$$VAL^XBDIQ1(9002011.65,AMHR,AMHX),Y=$$VALI^XBDIQ1(9002011.65,AMHR,AMHX) I Y="" S Y=X
.S:Y="" Y="ZZZZZ" S:X="" X="DATA NOT ENTERED" S ^(X)=$S($D(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
;method 10
S AMHC=10 S Z=0 F S Z=$O(^AMHPSUIC(AMHR,11,Z)) Q:Z'=+Z D
.S Y=$P(^AMHPSUIC(AMHR,11,Z,0),U),X=$$EXTSET^XBFUNC(9002011.6511,.01,Y)
.S:Y="" Y="ZZZZZ" S:X="" X="DATA NOT ENTERED" S ^(X)=$S($D(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
.;METHOD IF OTHER
.I $P(^AMHPSUIC(AMHR,11,Z,0),U,2)]"" S (X,Y)=$P(^AMHPSUIC(AMHR,11,Z,0),U,2),^(X)=$S($D(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",11,Y,X)):^(X)+1,1:1)
S AMHC=12,X=$$VAL^XBDIQ1(9002011.65,AMHR,.14),Y=$$VALI^XBDIQ1(9002011.65,AMHR,.14)
S:Y="" Y="ZZZZZ" S:X="" X="DATA NOT ENTERED" S ^(X)=$S($D(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
;sub use 11
S AMHC=13 S Y=$P(^AMHPSUIC(AMHR,0),U,26),X=$$EXTSET^XBFUNC(9002011.65,.26,Y)
S:Y="" Y="ZZZZZ" S:X="" X="DATA NOT ENTERED" S ^(X)=$S($D(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
S AMHC=14,X=$$VAL^XBDIQ1(9002011.65,AMHR,.15),Y=$$VALI^XBDIQ1(9002011.65,AMHR,.15)
S:Y="" Y="ZZZZZ" S:X="" X="DATA NOT ENTERED" S ^(X)=$S($D(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
I $P($G(^AMHPSUIC(AMHR,14)),U)]"" D
.S AMHC=15,X=$$VAL^XBDIQ1(9002011.65,AMHR,1401),Y=$$VALI^XBDIQ1(9002011.65,AMHR,1401) ;OTHER LOC OF ACT VALUES
.S:Y="" Y="ZZZZZ" S:X="" X="DATA NOT ENTERED" S ^(X)=$S($D(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
;cont fact 15
S AMHC=19 S Z=0 F S Z=$O(^AMHPSUIC(AMHR,13,Z)) Q:Z'=+Z D
.S Y=$P(^AMHPSUIC(AMHR,13,Z,0),U),Y=$P(^AMHTSCF(Y,0),U,2),X=$P(^AMHTSCF(Y,0),U,1)
.S:Y="" Y="ZZZZZ" S:X="" X="DATA NOT ENTERED" S ^(X)=$S($D(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
.;cf IF OTHER
.I $P(^AMHPSUIC(AMHR,13,Z,0),U,2)]"" S (X,Y)=$P(^AMHPSUIC(AMHR,13,Z,0),U,2),^(X)=$S($D(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",20,Y,X)):^(X)+1,1:1)
S AMHC=17 S X=$$VAL^XBDIQ1(9002011.65,AMHR,.25),Y=$$VALI^XBDIQ1(9002011.65,AMHR,.25) D
.S:Y="" Y="ZZZZZ" S:X="" X="DATA NOT ENTERED" S ^(X)=$S($D(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
I $P($G(^AMHPSUIC(AMHR,14)),U,2)]"" D
.S AMHC=18,X=$$VAL^XBDIQ1(9002011.65,AMHR,1402),Y=$$VALI^XBDIQ1(9002011.65,AMHR,1402) ;OTHER LOC OF ACT VALUES
.S:Y="" Y="ZZZZZ" S:X="" X="DATA NOT ENTERED" S ^(X)=$S($D(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
I AMHBD<$$DV4^AMHUTIL S AMHC=16 S X=$$VAL^XBDIQ1(9002011.65,AMHR,.24),Y=$$VALI^XBDIQ1(9002011.65,AMHR,.24) D
.S:Y="" Y="ZZZZZ" S:X="" X="DATA NOT ENTERED" S ^(X)=$S($D(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
.Q
S AMHC=21 S Z=0 F S Z=$O(^AMHPSUIC(AMHR,15,Z)) Q:Z'=+Z D
.S Y=$P(^AMHPSUIC(AMHR,15,Z,0),U),X=$P(^AMHTSSU(Y,0),U,1)
.S:Y="" Y="ZZZZZ" S:X="" X="DATA NOT ENTERED" S ^(X)=$S($D(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
.;cf IF OTHER
.I $P(^AMHPSUIC(AMHR,15,Z,0),U,2)]"" S (X,Y)=$P(^AMHPSUIC(AMHR,15,Z,0),U,2),^(X)=$S($D(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",22,Y,X)):^(X)+1,1:1)
S P=$P(^AMHPSUIC(AMHR,0),U,4)
S AMHC=23,X=$$RACE^AGUTL(P)
S (X,Y)=$P(X,U,2)
I X="" S X="UNKNOWN",Y="ZZZZZ"
S ^(X)=$S($D(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
S AMHC=24,(X,Y)=$$ETHN^AMHRPSU1($P(^AMHPSUIC(AMHR,0),U,4),"E")
I X="" S X="UNKNOWN",Y="ZZZZZ"
S ^(X)=$S($D(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
S AMHC=25,(X,Y)=$$VAL^XBDIQ1(2,P,1901)
I X="" S X="UNKNOWN",Y="ZZZZZ"
S ^(X)=$S($D(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
Q
SCREENS ;
K AMHSKIP
S AMHI=0 F S AMHI=$O(^AMHTRPT(AMHRPT,11,AMHI)) Q:AMHI'=+AMHI!($D(AMHSKIP)) D
.I '$P(^AMHSORT(AMHI,0),U,8) D SINGLE Q
.D MULT
.Q
Q
SINGLE ;
K AMHSPEC
S X="",AMHX=0
X:$D(^AMHSORT(AMHI,1)) ^(1)
I X="" S AMHSKIP="" Q
I '$D(AMHSPEC),'$D(^AMHTRPT(AMHRPT,11,AMHI,11,"B",X)) S AMHSKIP="" Q
Q
MULT ;
K AMHFOUN,AMHSKIP,X S AMHX=0,X=""
X:$D(^AMHSORT(AMHI,1)) ^(1)
I '$L($O(X)) S AMHSKIP="" Q
S Y="" F S Y=$O(X(Y)) Q:Y="" I $D(^AMHTRPT(AMHRPT,11,AMHI,11,"B",Y)) S AMHFOUN="" Q
S:'$D(AMHFOUN) AMHSKIP=""
Q
PRINT ;EP called from xbdbque
S AMHPG=0
K AMHQUIT
S AMHSUIC=1
D COVPAGE^AMHRPTCP
I 'AMHTOT D HEAD W !!,"No Suicide Forms to Report" G DONE
I $D(AMHQUIT) G DONE
D HEAD Q:$D(AMHQUIT)
W !,"Total # of Suicide Forms: ",AMHTOT,!?63,"REPORT TOTALS"
S AMHV="" F S AMHV=$O(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHV)) Q:AMHV=""!($D(AMHQUIT)) D
.I $Y>(IOSL-6) D HEAD Q:$D(AMHQUIT)
.S AMHL=$P($T(@AMHV),";;",2) W !?1,$$LBLK(AMHL,28)
.S AMHY="" F S AMHY=$O(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHV,AMHY)) Q:AMHY=""!($D(AMHQUIT)) D
..S AMHX="" S AMHX=$O(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHV,AMHY,AMHX)) Q:AMHX=""!($D(AMHQUIT)) D
...S X=^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHV,AMHY,AMHX)
...W ?31,$E(AMHX,1,30),?63,$J(X,4) S T=AMHTOT W ?72,$J(((X/T)*100),3,0)_"%",!
..Q
.Q
DONE ;
I $E(IOST)="C",IO=IO(0) S DIR(0)="EO",DIR("A")="End of report. PRESS RETURN" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
K ^XTMP("AMHRPSU2",AMHJ,AMHH)
Q
HEAD ;EP
G:'AMHPG HEAD1
K DIR 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 S AMHPG=AMHPG+1
W !,$$LOC,?35,$$FMTE^XLFDT(DT),?70,"Page ",AMHPG,!
S X="***** AGGREGATED SUICIDE DATA *****" W !,?((80-$L(X))/2),X,!
S X="Act Occurred: "_$$FMTE^XLFDT(AMHBD)_" - "_$$FMTE^XLFDT(AMHED) W $$CTR(X),!
W $TR($J("",80)," ","-"),!
Q
LBLK(V,L) ;left blank fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V=" "_V
Q V
RBLK(V,L) ;EP right blank fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V=V_" "
Q V
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
EOP ;EP - End of page.
Q:$E(IOST)'="C"
Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
NEW DIR
K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
S DIR(0)="E" D ^DIR
Q
;----------
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")
;----------
XTMP(N,D) ;EP - set xtmp 0 node
Q:$G(N)=""
S ^XTMP(N,0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_$G(D)
Q
;
LABEL ;
1 ;;Suicidal Behavior:
2 ;;Event logged by Discipline:
3 ;;Event logged by Provider:
4 ;;Sex:
5 ;;Employed:
6 ;;Tribe of Enrollment:
7 ;;Community of Residence:
8 ;;Relationship:
9 ;;Education:
10 ;;Method:
11 ;;Method if Other:
12 ;;Previous Attempts:
13 ;;Substance Use Involved:
14 ;;Location of Act:
15 ;;Other location of Act:
16 ;;Lethality:
17 ;;Disposition:
18 ;;Disposition if OTHER:
19 ;;Contributing Factors:
20 ;;Contributing Factor if OTHER:
21 ;;Substance Drugs:
22 ;;Substance Drugs if OTHER:
23 ;;Race:
24 ;;Ethnicity:
25 ;;Veteran's Status
AMHRPSU2 ; IHS/CMI/LAB - Suicide Form data element tally ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**1,8**;JUN 02, 2010;Build 7
+2 ;
+3 ;
START ;
+1 DO EN^XBVK("AMH")
+2 IF $DATA(IOF)
WRITE @IOF
+3 WRITE !!,"Aggregate Suicide Data Report - Selected Variables"
+4 WRITE !!,"This report will tally the data items selected by the user for Suicide",!,"Forms in a date range.",!!
+5 ;D PAUSE
+6 ;GETDATES ;
+7 DO DBHUSRP^AMHUTIL
BD ;
+1 SET DIR(0)="D^::EP"
SET DIR("A")="Enter Beginning Date of Suicide Act"
SET DIR("?")="Enter the beginning date of suicide act for the search."
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO EOJ
+3 SET AMHBD=Y
ED ;
+1 SET DIR(0)="DA^::EP"
SET DIR("A")="Enter Ending Date of Suicide Act: "
DO ^DIR
KILL DIR,DA
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO EOJ
+3 IF Y<AMHBD
WRITE !,"Ending date must be greater than or equal to beginning date!"
GOTO ED
+4 SET AMHED=Y
+5 SET X1=AMHBD
SET X2=-1
DO C^%DTC
SET AMHSD=X
+6 IF $DATA(AMHQUIT)
DO EOJ
QUIT
+7 DO ADD
+8 SET AMHTCW=0
SET AMHPCNT=0
+9 SET AMHPTVS="S"
SET AMHXREF="SU"
+10 SET AMHRPTC=7
SCREEN ;
+1 KILL ^AMHTRPT(AMHRPT,11)
SET AMHCNTL="S"
SET AMHTYPE="SU"
SET AMHPTTX="Suicide Form"
SET AMHPTTS="Suicide Forms"
DO ^AMHRL4
KILL AMHRDTR,AMHCNTL
IF $DATA(AMHQUIT)
DO DEL^AMHRL
GOTO EOJ
DEMO ;
+1 DO DEMOCHK^AMHUTIL1(.AMHDEMO)
+2 IF AMHDEMO=-1
GOTO BD
ZIS ;
+1 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)
GOTO EOJ
+3 IF $GET(Y)="B"
DO BROWSE
DO EOJ
QUIT
+4 WRITE !!
SET XBRP="PRINT^AMHRPSU2"
SET XBRC="PROC^AMHRPSU2"
SET XBNS="AMH"
SET XBRX="EOJ^AMHRPSU2"
+5 DO ^XBDBQUE
+6 DO EOJ
+7 QUIT
BROWSE ;
+1 SET XBRP="VIEWR^XBLM(""PRINT^AMHRPSU2"")"
+2 SET XBNS="AMH"
SET XBRC="PROC^AMHRPSU2"
SET XBRX="EOJ^AMHRPSU2"
SET XBIOP=0
DO ^XBDBQUE
+3 QUIT
+4 ;
ADD ;EP
+1 SET %H=$HOROLOG
DO YX^%DTC
SET X=$PIECE(^VA(200,DUZ,0),U)_"-"_Y
SET DIC(0)="L"
SET DIC="^AMHTRPT("
SET DLAYGO=9002013.8
SET DIADD=1
DO ^DIC
KILL DIC,DA,DR,DIADD,DLAYGO
IF Y=-1
WRITE !!,"UNABLE TO CREATE REPORT FILE ENTRY - NOTIFY SITE MANAGER!"
SET AMHQUIT=1
QUIT
+2 SET AMHRPT=+Y
+3 KILL DIC,DIADD,DLAYGO,DR,DA,DD,X,Y,DINUM
+4 ;DELETE ALL 11 MULTIPLE HERE
+5 KILL ^AMHTRPT(AMHRPT,11)
+6 QUIT
PAUSE ;
+1 SET DIR(0)="E"
SET DIR("A")="Press return to continue or '^' to quit"
DO ^DIR
KILL DIR,DA
+2 IF $DATA(DIRUT)
SET AMHQUIT=1
+3 IF $DATA(IOF)
WRITE @IOF
+4 QUIT
EOJ ;
+1 DO DEL^AMHRL
+2 DO EN^XBVK("AMH")
+3 KILL L,M,S,T,X,X1,X2,Y,Z,B
+4 DO KILL^AUPNPAT
+5 DO ^XBFMK
+6 QUIT
PROC ;EP
+1 SET AMHJ=$JOB
SET AMHH=$HOROLOG
+2 KILL ^XTMP("AMHRPSU2",AMHJ,AMHH)
+3 DO XTMP("AMHRPSU2","AMH - SUICIDE")
V ; Run by visit date
+1 KILL AMHTOT,AMHIA,AMHCS
SET AMHTOT=0
SET AMHIA=0
SET AMHCS=0
+2 ;S AMHR=0 F S AMHR=$O(^AMHPSUIC(AMHR)) Q:AMHR'=+AMHR D V1
+3 FOR
SET AMHSD=$ORDER(^AMHPSUIC("AD",AMHSD))
IF AMHSD=""!((AMHSD\1)>AMHED)
QUIT
DO V1
+4 QUIT
+5 ;
V1 ;
+1 SET AMHR=""
FOR
SET AMHR=$ORDER(^AMHPSUIC("AD",AMHSD,AMHR))
IF AMHR'=+AMHR
QUIT
DO V2
+2 QUIT
+3 ;
V2 ;
+1 SET AMHR0=^AMHPSUIC(AMHR,0)
+2 SET DFN=$PIECE(AMHR0,U,4)
+3 ;I DFN,'$$ALLOWP^AMHUTIL(DUZ,DFN) Q
+4 IF $$DEMO^AMHUTIL1(DFN,$GET(AMHDEMO))
QUIT
+5 DO SCREENS
+6 IF $DATA(AMHSKIP)
QUIT
+7 SET AMHTOT=AMHTOT+1
+8 SET AMHSUC=$PIECE(^AMHPSUIC(AMHR,0),U,7)
IF $DATA(AMHCOMM)
IF '$DATA(AMHCOMM(AMHSUC))
QUIT
+9 SET A=$$VAL^XBDIQ1(9002011.65,AMHR,.043)
+10 ;tally each date element
+11 SET AMHC=0
FOR AMHX=.131,.032,.03,.041,.05,.044,.045,.08,.11
Begin DoDot:1
+12 SET AMHC=AMHC+1
+13 SET X=$$VAL^XBDIQ1(9002011.65,AMHR,AMHX)
SET Y=$$VALI^XBDIQ1(9002011.65,AMHR,AMHX)
IF Y=""
SET Y=X
+14 IF Y=""
SET Y="ZZZZZ"
IF X=""
SET X="DATA NOT ENTERED"
SET ^(X)=$SELECT($DATA(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
End DoDot:1
+15 ;method 10
+16 SET AMHC=10
SET Z=0
FOR
SET Z=$ORDER(^AMHPSUIC(AMHR,11,Z))
IF Z'=+Z
QUIT
Begin DoDot:1
+17 SET Y=$PIECE(^AMHPSUIC(AMHR,11,Z,0),U)
SET X=$$EXTSET^XBFUNC(9002011.6511,.01,Y)
+18 IF Y=""
SET Y="ZZZZZ"
IF X=""
SET X="DATA NOT ENTERED"
SET ^(X)=$SELECT($DATA(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
+19 ;METHOD IF OTHER
+20 IF $PIECE(^AMHPSUIC(AMHR,11,Z,0),U,2)]""
SET (X,Y)=$PIECE(^AMHPSUIC(AMHR,11,Z,0),U,2)
SET ^(X)=$SELECT($DATA(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",11,Y,X)):^(X)+1,1:1)
End DoDot:1
+21 SET AMHC=12
SET X=$$VAL^XBDIQ1(9002011.65,AMHR,.14)
SET Y=$$VALI^XBDIQ1(9002011.65,AMHR,.14)
+22 IF Y=""
SET Y="ZZZZZ"
IF X=""
SET X="DATA NOT ENTERED"
SET ^(X)=$SELECT($DATA(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
+23 ;sub use 11
+24 SET AMHC=13
SET Y=$PIECE(^AMHPSUIC(AMHR,0),U,26)
SET X=$$EXTSET^XBFUNC(9002011.65,.26,Y)
+25 IF Y=""
SET Y="ZZZZZ"
IF X=""
SET X="DATA NOT ENTERED"
SET ^(X)=$SELECT($DATA(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
+26 SET AMHC=14
SET X=$$VAL^XBDIQ1(9002011.65,AMHR,.15)
SET Y=$$VALI^XBDIQ1(9002011.65,AMHR,.15)
+27 IF Y=""
SET Y="ZZZZZ"
IF X=""
SET X="DATA NOT ENTERED"
SET ^(X)=$SELECT($DATA(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
+28 IF $PIECE($GET(^AMHPSUIC(AMHR,14)),U)]""
Begin DoDot:1
+29 ;OTHER LOC OF ACT VALUES
SET AMHC=15
SET X=$$VAL^XBDIQ1(9002011.65,AMHR,1401)
SET Y=$$VALI^XBDIQ1(9002011.65,AMHR,1401)
+30 IF Y=""
SET Y="ZZZZZ"
IF X=""
SET X="DATA NOT ENTERED"
SET ^(X)=$SELECT($DATA(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
End DoDot:1
+31 ;cont fact 15
+32 SET AMHC=19
SET Z=0
FOR
SET Z=$ORDER(^AMHPSUIC(AMHR,13,Z))
IF Z'=+Z
QUIT
Begin DoDot:1
+33 SET Y=$PIECE(^AMHPSUIC(AMHR,13,Z,0),U)
SET Y=$PIECE(^AMHTSCF(Y,0),U,2)
SET X=$PIECE(^AMHTSCF(Y,0),U,1)
+34 IF Y=""
SET Y="ZZZZZ"
IF X=""
SET X="DATA NOT ENTERED"
SET ^(X)=$SELECT($DATA(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
+35 ;cf IF OTHER
+36 IF $PIECE(^AMHPSUIC(AMHR,13,Z,0),U,2)]""
SET (X,Y)=$PIECE(^AMHPSUIC(AMHR,13,Z,0),U,2)
SET ^(X)=$SELECT($DATA(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",20,Y,X)):^(X)+1,1:1)
End DoDot:1
+37 SET AMHC=17
SET X=$$VAL^XBDIQ1(9002011.65,AMHR,.25)
SET Y=$$VALI^XBDIQ1(9002011.65,AMHR,.25)
Begin DoDot:1
+38 IF Y=""
SET Y="ZZZZZ"
IF X=""
SET X="DATA NOT ENTERED"
SET ^(X)=$SELECT($DATA(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
End DoDot:1
+39 IF $PIECE($GET(^AMHPSUIC(AMHR,14)),U,2)]""
Begin DoDot:1
+40 ;OTHER LOC OF ACT VALUES
SET AMHC=18
SET X=$$VAL^XBDIQ1(9002011.65,AMHR,1402)
SET Y=$$VALI^XBDIQ1(9002011.65,AMHR,1402)
+41 IF Y=""
SET Y="ZZZZZ"
IF X=""
SET X="DATA NOT ENTERED"
SET ^(X)=$SELECT($DATA(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
End DoDot:1
+42 IF AMHBD<$$DV4^AMHUTIL
SET AMHC=16
SET X=$$VAL^XBDIQ1(9002011.65,AMHR,.24)
SET Y=$$VALI^XBDIQ1(9002011.65,AMHR,.24)
Begin DoDot:1
+43 IF Y=""
SET Y="ZZZZZ"
IF X=""
SET X="DATA NOT ENTERED"
SET ^(X)=$SELECT($DATA(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
+44 QUIT
End DoDot:1
+45 SET AMHC=21
SET Z=0
FOR
SET Z=$ORDER(^AMHPSUIC(AMHR,15,Z))
IF Z'=+Z
QUIT
Begin DoDot:1
+46 SET Y=$PIECE(^AMHPSUIC(AMHR,15,Z,0),U)
SET X=$PIECE(^AMHTSSU(Y,0),U,1)
+47 IF Y=""
SET Y="ZZZZZ"
IF X=""
SET X="DATA NOT ENTERED"
SET ^(X)=$SELECT($DATA(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
+48 ;cf IF OTHER
+49 IF $PIECE(^AMHPSUIC(AMHR,15,Z,0),U,2)]""
SET (X,Y)=$PIECE(^AMHPSUIC(AMHR,15,Z,0),U,2)
SET ^(X)=$SELECT($DATA(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",22,Y,X)):^(X)+1,1:1)
End DoDot:1
+50 SET P=$PIECE(^AMHPSUIC(AMHR,0),U,4)
+51 SET AMHC=23
SET X=$$RACE^AGUTL(P)
+52 SET (X,Y)=$PIECE(X,U,2)
+53 IF X=""
SET X="UNKNOWN"
SET Y="ZZZZZ"
+54 SET ^(X)=$SELECT($DATA(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
+55 SET AMHC=24
SET (X,Y)=$$ETHN^AMHRPSU1($PIECE(^AMHPSUIC(AMHR,0),U,4),"E")
+56 IF X=""
SET X="UNKNOWN"
SET Y="ZZZZZ"
+57 SET ^(X)=$SELECT($DATA(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
+58 SET AMHC=25
SET (X,Y)=$$VAL^XBDIQ1(2,P,1901)
+59 IF X=""
SET X="UNKNOWN"
SET Y="ZZZZZ"
+60 SET ^(X)=$SELECT($DATA(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHC,Y,X)):^(X)+1,1:1)
+61 QUIT
SCREENS ;
+1 KILL AMHSKIP
+2 SET AMHI=0
FOR
SET AMHI=$ORDER(^AMHTRPT(AMHRPT,11,AMHI))
IF AMHI'=+AMHI!($DATA(AMHSKIP))
QUIT
Begin DoDot:1
+3 IF '$PIECE(^AMHSORT(AMHI,0),U,8)
DO SINGLE
QUIT
+4 DO MULT
+5 QUIT
End DoDot:1
+6 QUIT
SINGLE ;
+1 KILL AMHSPEC
+2 SET X=""
SET AMHX=0
+3 IF $DATA(^AMHSORT(AMHI,1))
XECUTE ^(1)
+4 IF X=""
SET AMHSKIP=""
QUIT
+5 IF '$DATA(AMHSPEC)
IF '$DATA(^AMHTRPT(AMHRPT,11,AMHI,11,"B",X))
SET AMHSKIP=""
QUIT
+6 QUIT
MULT ;
+1 KILL AMHFOUN,AMHSKIP,X
SET AMHX=0
SET X=""
+2 IF $DATA(^AMHSORT(AMHI,1))
XECUTE ^(1)
+3 IF '$LENGTH($ORDER(X))
SET AMHSKIP=""
QUIT
+4 SET Y=""
FOR
SET Y=$ORDER(X(Y))
IF Y=""
QUIT
IF $DATA(^AMHTRPT(AMHRPT,11,AMHI,11,"B",Y))
SET AMHFOUN=""
QUIT
+5 IF '$DATA(AMHFOUN)
SET AMHSKIP=""
+6 QUIT
PRINT ;EP called from xbdbque
+1 SET AMHPG=0
+2 KILL AMHQUIT
+3 SET AMHSUIC=1
+4 DO COVPAGE^AMHRPTCP
+5 IF 'AMHTOT
DO HEAD
WRITE !!,"No Suicide Forms to Report"
GOTO DONE
+6 IF $DATA(AMHQUIT)
GOTO DONE
+7 DO HEAD
IF $DATA(AMHQUIT)
QUIT
+8 WRITE !,"Total # of Suicide Forms: ",AMHTOT,!?63,"REPORT TOTALS"
+9 SET AMHV=""
FOR
SET AMHV=$ORDER(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHV))
IF AMHV=""!($DATA(AMHQUIT))
QUIT
Begin DoDot:1
+10 IF $Y>(IOSL-6)
DO HEAD
IF $DATA(AMHQUIT)
QUIT
+11 SET AMHL=$PIECE($TEXT(@AMHV),";;",2)
WRITE !?1,$$LBLK(AMHL,28)
+12 SET AMHY=""
FOR
SET AMHY=$ORDER(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHV,AMHY))
IF AMHY=""!($DATA(AMHQUIT))
QUIT
Begin DoDot:2
+13 SET AMHX=""
SET AMHX=$ORDER(^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHV,AMHY,AMHX))
IF AMHX=""!($DATA(AMHQUIT))
QUIT
Begin DoDot:3
+14 SET X=^XTMP("AMHRPSU2",AMHJ,AMHH,"TALLY","TOTAL",AMHV,AMHY,AMHX)
+15 WRITE ?31,$EXTRACT(AMHX,1,30),?63,$JUSTIFY(X,4)
SET T=AMHTOT
WRITE ?72,$JUSTIFY(((X/T)*100),3,0)_"%",!
End DoDot:3
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
DONE ;
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
SET DIR(0)="EO"
SET DIR("A")="End of report. PRESS RETURN"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 KILL ^XTMP("AMHRPSU2",AMHJ,AMHH)
+3 QUIT
HEAD ;EP
+1 IF 'AMHPG
GOTO HEAD1
+2 KILL DIR
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
SET AMHPG=AMHPG+1
+2 WRITE !,$$LOC,?35,$$FMTE^XLFDT(DT),?70,"Page ",AMHPG,!
+3 SET X="***** AGGREGATED SUICIDE DATA *****"
WRITE !,?((80-$LENGTH(X))/2),X,!
+4 SET X="Act Occurred: "_$$FMTE^XLFDT(AMHBD)_" - "_$$FMTE^XLFDT(AMHED)
WRITE $$CTR(X),!
+5 WRITE $TRANSLATE($JUSTIFY("",80)," ","-"),!
+6 QUIT
LBLK(V,L) ;left blank fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V=" "_V
+3 QUIT V
RBLK(V,L) ;EP right blank fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V=V_" "
+3 QUIT V
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 ;----------
EOP ;EP - End of page.
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))
QUIT
+3 NEW DIR
+4 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+5 SET DIR(0)="E"
DO ^DIR
+6 QUIT
+7 ;----------
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 ;----------
XTMP(N,D) ;EP - set xtmp 0 node
+1 IF $GET(N)=""
QUIT
+2 SET ^XTMP(N,0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_$GET(D)
+3 QUIT
+4 ;
LABEL ;
1 ;;Suicidal Behavior:
2 ;;Event logged by Discipline:
3 ;;Event logged by Provider:
4 ;;Sex:
5 ;;Employed:
6 ;;Tribe of Enrollment:
7 ;;Community of Residence:
8 ;;Relationship:
9 ;;Education:
10 ;;Method:
11 ;;Method if Other:
12 ;;Previous Attempts:
13 ;;Substance Use Involved:
14 ;;Location of Act:
15 ;;Other location of Act:
16 ;;Lethality:
17 ;;Disposition:
18 ;;Disposition if OTHER:
19 ;;Contributing Factors:
20 ;;Contributing Factor if OTHER:
21 ;;Substance Drugs:
22 ;;Substance Drugs if OTHER:
23 ;;Race:
24 ;;Ethnicity:
25 ;;Veteran's Status
