AMHRSU5 ; IHS/CMI/LAB - ; 20 Jun 2017 10:33 AM
;;4.0;IHS BEHAVIORAL HEALTH;**6,8**;JUN 02, 2010;Build 7
;
START ;
D XIT
I '$D(IOF) D HOME^%ZIS
W @(IOF),!!
D INFORM
DATES K AMHED,AMHBD
K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Visit Date"
D ^DIR G:Y<1 XIT S AMHBD=Y
K DIR S DIR(0)="DO^:DT:EXP",DIR("A")="Enter Ending Visit Date"
D ^DIR G:Y<1 XIT S AMHED=Y
;
I AMHED<AMHBD D G DATES
. W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
S AMHSD=$$FMADD^XLFDT(AMHBD,-1)_".9999"
;
PROG ;
S AMHPROG=""
S DIR(0)="S^O:ONE Program;A:ALL Programs",DIR("A")="Run the Report for which PROGRAM",DIR("B")="A" KILL DA D ^DIR KILL DIR
G:$D(DIRUT) DATES
I Y="A" G DEMO
S DIR(0)="9002011,.02",DIR("A")="Which PROGRAM" KILL DA D ^DIR KILL DIR
G:$D(DIRUT) PROG
I X="" G PROG
S AMHPROG=Y
DEMO ;
D DEMOCHK^AMHUTIL1(.AMHDEMO)
I AMHDEMO=-1 G PROG
ZIS ;call xbdbque
S XBRC="DRIVER^AMHRSU5",XBRP="PRINT^AMHRSU5",XBRX="XIT^AMHRSU5",XBNS="AMH"
D ^XBDBQUE
D XIT
Q
DRIVER ;EP entry point for taskman
D PROCESS
S AMHET=$H
Q
XIT ;
K DIR
D EN^XBVK("AMH") ;clean up AMH variables
D ^XBFMK ;clean up fileman variables
Q
;
PROCESS ;
D XTMP^AMHUTIL("AMHRSU5","BH - SUICIDE POV REPORT")
S (AMHBT,AMHBTH)=$H,AMHJOB=$J
K AMHMALEV,AMHFEMV,AMHALLV,AMHMALEP,AMHFEMP,AMHALLP
F X=1:1:13 S (AMHMALEV(X),AMHFEMV(X),AMHALLV(X),AMHMALEP(X),AMHFEMP(X),AMHALLP(X))=0
S AMHSD=$P(AMHBD,".")-1,AMHSD=AMHSD_".9999"
K AMHPRAT S AMHGRTA=0
S (AMHRCNT,AMHVIEN)=0 F S AMHSD=$O(^AMHREC("B",AMHSD)) Q:AMHSD=""!($P(AMHSD,".")>$P(AMHED,".")) D
.S AMHVIEN=0 F S AMHVIEN=$O(^AMHREC("B",AMHSD,AMHVIEN)) Q:AMHVIEN'=+AMHVIEN D
..S AMHV0=$G(^AMHREC(AMHVIEN,0))
..Q:AMHV0=""
..S DFN=$P(^AMHREC(AMHVIEN,0),U,8)
..Q:DFN=""
..Q:$$DEMO^AMHUTIL1(DFN,$G(AMHDEMO))
..I AMHPROG]"",$P(^AMHREC(AMHVIEN,0),U,2)'=AMHPROG Q ;not correct program visit
..Q:'$D(^AMHRPRO("AD",AMHVIEN)) ;no pOVS
..S AMHAGE=$$AGE^AUPNPAT(DFN,$P($P(AMHV0,U),"."))
..S A=$$AG(AMHAGE)
..D SETT(1,A,DFN)
..Q:'$$SUICPOV(AMHVIEN) ;no suicide pov
..D SETT(2,A,DFN)
..I $$SUICC(AMHVIEN,39) D SETT(3,A,DFN)
..I $$SUICC(AMHVIEN,40) D SETT(4,A,DFN)
..I $$SUICC(AMHVIEN,41) D SETT(5,A,DFN)
..I $$SUICC(AMHVIEN,"V62.84") D SETT(3,A,DFN)
..I $$SUICC(AMHVIEN,"R45.851") D SETT(3,A,DFN)
..I $$SUICC(AMHVIEN,"T14.91") D SETT(4,A,DFN)
..Q
.Q
S AMHET=$H
Q
;
SETT(P,A,D) ;
S $P(AMHALLV(13),U,P)=$P(AMHALLV(13),U,P)+1 ;all visits, all 39/40/41
I $P(^DPT(D,0),U,2)="M" S $P(AMHMALEV(13),U,P)=$P(AMHMALEV(13),U,P)+1
I $P(^DPT(D,0),U,2)="F" S $P(AMHFEMV(13),U,P)=$P(AMHFEMV(13),U,P)+1
S $P(AMHALLV(A),U,P)=$P(AMHALLV(A),U,P)+1
I $P(^DPT(D,0),U,2)="M" S $P(AMHMALEV(A),U,P)=$P(AMHMALEV(A),U,P)+1
I $P(^DPT(D,0),U,2)="F" S $P(AMHFEMV(A),U,P)=$P(AMHFEMV(A),U,P)+1
I $P($G(^XTMP("AMHRSU5",AMHJOB,AMHBTH,"PATIENTS",D)),U,P) Q
S $P(^XTMP("AMHRSU5",AMHJOB,AMHBTH,"PATIENTS",D),U,P)=1
S $P(AMHALLP(13),U,P)=$P(AMHALLP(13),U,P)+1
I $P(^DPT(D,0),U,2)="M" S $P(AMHMALEP(13),U,P)=$P(AMHMALEP(13),U,P)+1
I $P(^DPT(D,0),U,2)="F" S $P(AMHFEMP(13),U,P)=$P(AMHFEMP(13),U,P)+1
S $P(AMHALLP(A),U,P)=$P(AMHALLP(A),U,P)+1
I $P(^DPT(D,0),U,2)="M" S $P(AMHMALEP(A),U,P)=$P(AMHMALEP(A),U,P)+1
I $P(^DPT(D,0),U,2)="F" S $P(AMHFEMP(A),U,P)=$P(AMHFEMP(A),U,P)+1
Q
AG(A) ;
I A<5 Q 1
I A>4,A<10 Q 2
I A>9,A<15 Q 3
I A>14,A<20 Q 4
I A>19,A<25 Q 5
I A>24,A<35 Q 6
I A>34,A<45 Q 7
I A>44,A<55 Q 8
I A>54,A<65 Q 9
I A>64,A<75 Q 10
I A>74,A<85 Q 11
I A>84 Q 12
Q ""
SUICPOV(V) ;
S G=0
S X=0 F S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X D
.Q:'$D(^AMHRPRO(X,0))
.S Y=$P(^AMHRPRO(X,0),U)
.Q:'$D(^AMHPROB(Y,0))
.S Y=$P(^AMHPROB(Y,0),U)
.I Y=39!(Y=40)!(Y=41)!(Y="V62.84")!(Y="R45.851")!(Y="T14.91") S G=1
.Q
Q G
SUICC(V,C) ;
S G=0
S X=0 F S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X D
.Q:'$D(^AMHRPRO(X,0))
.S Y=$P(^AMHRPRO(X,0),U)
.Q:'$D(^AMHPROB(Y,0))
.S Y=$P(^AMHPROB(Y,0),U)
.I Y=C S G=1
.Q
Q G
PRINT ;EP - called from xbdbque
S Y=AMHBD D DD^%DT S AMHBDD=Y S Y=AMHED D DD^%DT S AMHEDD=Y
S AMHPG=0
K AMHQUIT
D PRINT1
DONE I $D(AMHET) S AMHDVTS=(86400*($P(AMHET,",")-$P(AMHBT,",")))+($P(AMHET,",",2)-$P(AMHBT,",",2)),AMHDVH=$P(AMHDVTS/3600,".") S:AMHDVH="" AMHDVH=0
S AMHDVTS=AMHDVTS-(AMHDVH*3600),AMHDVM=$P(AMHDVTS/60,".") S:AMHDVM="" AMHDVM=0 S AMHDVTS=AMHDVTS-(AMHDVM*60),AMHDVS=AMHDVTS W !!,"RUN TIME (H.M.S): ",AMHDVH,".",AMHDVM,".",AMHDVS
I $E(IOST)="C",IO=IO(0) S DIR("A")="End of Report, press Enter",DIR(0)="E" D ^DIR K DIR
W:$D(IOF) @IOF
Q
PRINT1 ;
S AMHSUBH="BOTH MALE AND FEMALE PATIENTS' VISITS"
D HEAD Q:$D(AMHQUIT)
F AMHX=1:1:13 D Q:$D(AMHQUIT)
.Q:$D(AMHQUIT)
.I $Y>(IOSL-2) D HEAD Q:$D(AMHQUIT)
.W !!?1,$P($T(@AMHX),";;",2)
.W ?13,$$RJ^XLFSTR($$C($P(AMHALLV(AMHX),U,1),0,6),6)
.S N=$P(AMHALLV(AMHX),U,1),D=$P(AMHALLV(13),U,1)
.I 'D W ?22,"0.0"
.I D W ?20,$J(((N/D)*100),5,1)
.;
.W ?27,$$RJ^XLFSTR($$C($P(AMHALLV(AMHX),U,3),0,6),6)
.S N=$P(AMHALLV(AMHX),U,3),D=$P(AMHALLV(AMHX),U,1)
.I 'D W ?35,"0.0"
.I D W ?34,$J(((N/D)*100),5,1)
.;
.W ?41,$$RJ^XLFSTR($$C($P(AMHALLV(AMHX),U,4),0,6),6)
.S N=$P(AMHALLV(AMHX),U,4),D=$P(AMHALLV(AMHX),U,1)
.I 'D W ?48,"0.0"
.I D W ?47,$J(((N/D)*100),5,1)
.;
.W ?54,$$RJ^XLFSTR($$C($P(AMHALLV(AMHX),U,5),0,6),6)
.S N=$P(AMHALLV(AMHX),U,5),D=$P(AMHALLV(AMHX),U,1)
.I 'D W ?64,"0.0"
.I D W ?62,$J(((N/D)*100),5,1)
.;
.W ?68,$$RJ^XLFSTR($$C($P(AMHALLV(AMHX),U,2),0,6),6)
.S N=$P(AMHALLV(AMHX),U,2),D=$P(AMHALLV(AMHX),U,1)
.I 'D W ?77,"0.0"
.I D W ?74,$J(((N/D)*100),5,1)
MALEV ;MALE VISITS
Q:$D(AMHQUIT)
S AMHSUBH="MALE PATIENTS VISITS"
D HEAD Q:$D(AMHQUIT)
F AMHX=1:1:13 D Q:$D(AMHQUIT)
.I $Y>(IOSL-2) D HEAD Q:$D(AMHQUIT)
.W !!?1,$P($T(@AMHX),";;",2)
.W ?13,$$RJ^XLFSTR($$C($P(AMHMALEV(AMHX),U,1),0,6),6)
.S N=$P(AMHMALEV(AMHX),U,1),D=$P(AMHMALEV(13),U,1)
.I 'D W ?22,"0.0"
.I D W ?20,$J(((N/D)*100),5,1)
.;
.W ?27,$$RJ^XLFSTR($$C($P(AMHMALEV(AMHX),U,3),0,6),6)
.S N=$P(AMHMALEV(AMHX),U,3),D=$P(AMHMALEV(AMHX),U,1)
.I 'D W ?35,"0.0"
.I D W ?34,$J(((N/D)*100),5,1)
.;
.W ?41,$$RJ^XLFSTR($$C($P(AMHMALEV(AMHX),U,4),0,6),6)
.S N=$P(AMHMALEV(AMHX),U,4),D=$P(AMHMALEV(AMHX),U,1)
.I 'D W ?48,"0.0"
.I D W ?47,$J(((N/D)*100),5,1)
.;
.W ?54,$$RJ^XLFSTR($$C($P(AMHMALEV(AMHX),U,5),0,6),6)
.S N=$P(AMHMALEV(AMHX),U,5),D=$P(AMHMALEV(AMHX),U,1)
.I 'D W ?64,"0.0"
.I D W ?61,$J(((N/D)*100),5,1)
.;
.W ?68,$$RJ^XLFSTR($$C($P(AMHMALEV(AMHX),U,2),0,6),6)
.S N=$P(AMHMALEV(AMHX),U,2),D=$P(AMHMALEV(AMHX),U,1)
.I 'D W ?77,"0.0"
.I D W ?77,$J(((N/D)*100),5,1)
;
FEMV ;FEMALE VISITSA
Q:$D(AMHQUIT)
S AMHSUBH="FEMALE PATIENTS VISITS"
D HEAD Q:$D(AMHQUIT)
F AMHX=1:1:13 D Q:$D(AMHQUIT)
.I $Y>(IOSL-2) D HEAD Q:$D(AMHQUIT)
.W !!?1,$P($T(@AMHX),";;",2)
.W ?13,$$RJ^XLFSTR($$C($P(AMHFEMV(AMHX),U,1),0,6),6)
.S N=$P(AMHFEMV(AMHX),U,1),D=$P(AMHFEMV(13),U,1)
.I 'D W ?22,"0.0"
.I D W ?20,$J(((N/D)*100),5,1)
.;
.W ?27,$$RJ^XLFSTR($$C($P(AMHFEMV(AMHX),U,3),0,6),6)
.S N=$P(AMHFEMV(AMHX),U,3),D=$P(AMHFEMV(AMHX),U,1)
.I 'D W ?35,"0.0"
.I D W ?34,$J(((N/D)*100),5,1)
.;
.W ?41,$$RJ^XLFSTR($$C($P(AMHFEMV(AMHX),U,4),0,6),6)
.S N=$P(AMHFEMV(AMHX),U,4),D=$P(AMHFEMV(AMHX),U,1)
.I 'D W ?48,"0.0"
.I D W ?47,$J(((N/D)*100),5,1)
.;
.W ?54,$$RJ^XLFSTR($$C($P(AMHFEMV(AMHX),U,5),0,6),6)
.S N=$P(AMHFEMV(AMHX),U,5),D=$P(AMHFEMV(AMHX),U,1)
.I 'D W ?64,"0.0"
.I D W ?61,$J(((N/D)*100),5,1)
.;
.W ?68,$$RJ^XLFSTR($$C($P(AMHFEMV(AMHX),U,2),0,6),6)
.S N=$P(AMHFEMV(AMHX),U,2),D=$P(AMHFEMV(AMHX),U,1)
.I 'D W ?77,"0.0"
.I D W ?77,$J(((N/D)*100),5,1)
;
PRINT2 ;
S AMHSUBH="UNDUPLICATED PATIENT COUNT - BOTH MALE AND FEMALE PATIENTS"
Q:$D(AMHQUIT)
D HEAD Q:$D(AMHQUIT)
F AMHX=1:1:13 D Q:$D(AMHQUIT)
.I $Y>(IOSL-2) D HEAD Q:$D(AMHQUIT)
.W !!?1,$P($T(@AMHX),";;",2)
.W ?13,$$RJ^XLFSTR($$C($P(AMHALLP(AMHX),U,1),0,6),6)
.S N=$P(AMHALLP(AMHX),U,1),D=$P(AMHALLP(13),U,1)
.I 'D W ?22,"0.0"
.I D W ?20,$J(((N/D)*100),5,1)
.;
.W ?27,$$RJ^XLFSTR($$C($P(AMHALLP(AMHX),U,3),0,6),6)
.S N=$P(AMHALLP(AMHX),U,3),D=$P(AMHALLP(AMHX),U,1)
.I 'D W ?35,"0.0"
.I D W ?34,$J(((N/D)*100),5,1)
.;
.W ?41,$$RJ^XLFSTR($$C($P(AMHALLP(AMHX),U,4),0,6),6)
.S N=$P(AMHALLP(AMHX),U,4),D=$P(AMHALLP(AMHX),U,1)
.I 'D W ?48,"0.0"
.I D W ?47,$J(((N/D)*100),5,1)
.;
.W ?54,$$RJ^XLFSTR($$C($P(AMHALLP(AMHX),U,5),0,6),6)
.S N=$P(AMHALLP(AMHX),U,5),D=$P(AMHALLP(AMHX),U,1)
.I 'D W ?64,"0.0"
.I D W ?61,$J(((N/D)*100),5,1)
.;
.W ?68,$$RJ^XLFSTR($$C($P(AMHALLP(AMHX),U,2),0,6),6)
.S N=$P(AMHALLP(AMHX),U,2),D=$P(AMHALLP(AMHX),U,1)
.I 'D W ?77,"0.0"
.I D W ?77,$J(((N/D)*100),5,1)
MALEP ;MALE PATS
Q:$D(AMHQUIT)
S AMHSUBH="UNDUPLICATED PATIENT COUNT - MALE PATIENTS"
D HEAD Q:$D(AMHQUIT)
F AMHX=1:1:13 D Q:$D(AMHQUIT)
.I $Y>(IOSL-2) D HEAD Q:$D(AMHQUIT)
.W !!?1,$P($T(@AMHX),";;",2)
.W ?13,$$RJ^XLFSTR($$C($P(AMHMALEP(AMHX),U,1),0,6),6)
.S N=$P(AMHMALEP(AMHX),U,1),D=$P(AMHMALEP(13),U,1)
.I 'D W ?22,"0.0"
.I D W ?20,$J(((N/D)*100),5,1)
.;
.W ?27,$$RJ^XLFSTR($$C($P(AMHMALEP(AMHX),U,3),0,6),6)
.S N=$P(AMHMALEP(AMHX),U,3),D=$P(AMHMALEP(AMHX),U,1)
.I 'D W ?35,"0.0"
.I D W ?34,$J(((N/D)*100),5,1)
.;
.W ?41,$$RJ^XLFSTR($$C($P(AMHMALEP(AMHX),U,4),0,6),6)
.S N=$P(AMHMALEP(AMHX),U,4),D=$P(AMHMALEP(AMHX),U,1)
.I 'D W ?48,"0.0"
.I D W ?47,$J(((N/D)*100),5,1)
.;
.W ?54,$$RJ^XLFSTR($$C($P(AMHMALEP(AMHX),U,5),0,6),6)
.S N=$P(AMHMALEP(AMHX),U,5),D=$P(AMHMALEP(AMHX),U,1)
.I 'D W ?64,"0.0"
.I D W ?61,$J(((N/D)*100),5,1)
.;
.W ?68,$$RJ^XLFSTR($$C($P(AMHMALEP(AMHX),U,2),0,6),6)
.S N=$P(AMHMALEP(AMHX),U,2),D=$P(AMHMALEP(AMHX),U,1)
.I 'D W ?77,"0.0"
.I D W ?77,$J(((N/D)*100),5,1)
;
FEMP ;FEMALE PATS
Q:$D(AMHQUIT)
S AMHSUBH="UNDUPLICATED PATIENT COUNT - FEMALE PATIENTS"
D HEAD
Q:$D(AMHQUIT)
F AMHX=1:1:13 D Q:$D(AMHQUIT)
.I $Y>(IOSL-2) D HEAD Q:$D(AMHQUIT)
.W !!?1,$P($T(@AMHX),";;",2)
.W ?13,$$RJ^XLFSTR($$C($P(AMHFEMP(AMHX),U,1),0,6),6)
.S N=$P(AMHFEMP(AMHX),U,1),D=$P(AMHFEMP(13),U,1)
.I 'D W ?22,"0.0"
.I D W ?20,$J(((N/D)*100),5,1)
.;
.W ?27,$$RJ^XLFSTR($$C($P(AMHFEMP(AMHX),U,3),0,6),6)
.S N=$P(AMHFEMP(AMHX),U,3),D=$P(AMHFEMP(AMHX),U,1)
.I 'D W ?35,"0.0"
.I D W ?34,$J(((N/D)*100),5,1)
.;
.W ?41,$$RJ^XLFSTR($$C($P(AMHFEMP(AMHX),U,4),0,6),6)
.S N=$P(AMHFEMP(AMHX),U,4),D=$P(AMHFEMP(AMHX),U,1)
.I 'D W ?48,"0.0"
.I D W ?47,$J(((N/D)*100),5,1)
.;
.W ?54,$$RJ^XLFSTR($$C($P(AMHFEMP(AMHX),U,5),0,6),6)
.S N=$P(AMHFEMP(AMHX),U,5),D=$P(AMHFEMP(AMHX),U,1)
.I 'D W ?64,"0.0"
.I D W ?61,$J(((N/D)*100),5,1)
.;
.W ?68,$$RJ^XLFSTR($$C($P(AMHFEMP(AMHX),U,2),0,6),6)
.S N=$P(AMHFEMP(AMHX),U,2),D=$P(AMHFEMP(AMHX),U,1)
.I 'D W ?77,"0.0"
.I D W ?77,$J(((N/D)*100),5,1)
;
Q
PAGEHEAD ;
HEAD ;EP;HEADER
I 'AMHPG G HEAD1
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 !,$$FMTE^XLFDT(DT),?70,"Page: ",AMHPG
W !?29,"Behavioral Health"
W !,$$CTR($$REPEAT^XLFSTR("*",35),80)
W !,$$CTR("* SUICIDE PURPOSE OF VISIT REPORT *",80)
W !,$$CTR($$REPEAT^XLFSTR("*",35),80)
S X="VISIT Date Range: "_AMHBDD_" through "_AMHEDD W !,$$CTR(X,80)
S X=AMHSUBH W !,$$CTR(X,80),!
S X="39, V62.84, R45.851 - Suicide Ideation; 40 & T14.91 - Suicide Attempt/Gesture;" W !,$$CTR(X,80),!
S X="41 - Suicide Completed" W $$CTR(X,80),!
W !,"AGE GROUP",?13,"# Encs",?27,"# w POV 39",?42,"w/ POV 40",?54,"w/ POV 41",?68,"w/ 39/40/41/"
W !?27,"V62.84/R45.851",?42,"& T14.91",?68,"V62.84/R45.851"
W !?15,"#",?22,"%",?29,"#",?36,"%",?43,"#",?50,"%",?56,"#",?63,"%",?70,"#",?77,"%"
W !,$$REPEAT^XLFSTR("-",80)
Q
C(X,X2,X3) ;
D COMMA^%DTC
Q $$STRIP^XLFSTR(X," ")
D(D) ;
I $G(D)="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
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("A")="End of report. Press Enter",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")
;----------
INFORM ;inform user what this report is all about
W !,$$CTR($$LOC)
W !!,$$CTR("BEHAVIORAL HEALTH SUICIDE PURPOSE OF VISIT REPORT")
W !!,"This report will display the Suicide POVs (39,40,41,V62.84, R45.851, T14.91)"
W !," as a percentage of the total number of Behavioral Health encounter"
W !,"records (Encs). Any records containing the ICD-9 code v62.84,"
W !,"Suicidal Ideation or ICD-10 code R45.851 will be included in "
W !,"the tallies for Problem code 39. Any records with ICD-10 Code T14.91"
W !,"will be included in the tallies for Problem code 40. A display by "
W !,"age and gender is also included."
W !
Q
OPRV ;one PROVIDER
S DIC="^VA(200,",DIC(0)="AEMQ",DIC("A")="Which PROVIDER: " D ^DIC K DIC
I Y=-1 S AMHQ="" Q
S AMHPRVS(+Y)=""
Q
SPRV ;taxonomy of PROVIDERS
S X="PRIMARY PROVIDER",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
D PEP^AMQQGTX0(+Y,"AMHPRVS(")
I '$D(AMHPRVS) S AMHQ="" Q
I $D(AMHPRVS("*")) S AMHPRVT="A" K AMHPRVS W !!,"**** all PROVIDERS will be included ****",! Q
Q
;
1 ;;1-4 yrs
2 ;;5-9 yrs
3 ;;10-14 yrs
4 ;;15-19 yrs
5 ;;20-24 yrs
6 ;;25-34 yrs
7 ;;35-44 yrs
8 ;;45-54 yrs
9 ;;55-64 yrs
10 ;;65-74 yrs
11 ;;75-84 yrs
12 ;;85+ yrs
13 ;;TOTAL
AMHRSU5 ; IHS/CMI/LAB - ; 20 Jun 2017 10:33 AM
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**6,8**;JUN 02, 2010;Build 7
+2 ;
START ;
+1 DO XIT
+2 IF '$DATA(IOF)
DO HOME^%ZIS
+3 WRITE @(IOF),!!
+4 DO INFORM
DATES KILL AMHED,AMHBD
+1 KILL DIR
WRITE !
SET DIR(0)="DO^::EXP"
SET DIR("A")="Enter Beginning Visit Date"
+2 DO ^DIR
IF Y<1
GOTO XIT
SET AMHBD=Y
+3 KILL DIR
SET DIR(0)="DO^:DT:EXP"
SET DIR("A")="Enter Ending Visit Date"
+4 DO ^DIR
IF Y<1
GOTO XIT
SET AMHED=Y
+5 ;
+6 IF AMHED<AMHBD
Begin DoDot:1
+7 WRITE !!,$CHAR(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
End DoDot:1
GOTO DATES
+8 SET AMHSD=$$FMADD^XLFDT(AMHBD,-1)_".9999"
+9 ;
PROG ;
+1 SET AMHPROG=""
+2 SET DIR(0)="S^O:ONE Program;A:ALL Programs"
SET DIR("A")="Run the Report for which PROGRAM"
SET DIR("B")="A"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO DATES
+4 IF Y="A"
GOTO DEMO
+5 SET DIR(0)="9002011,.02"
SET DIR("A")="Which PROGRAM"
KILL DA
DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)
GOTO PROG
+7 IF X=""
GOTO PROG
+8 SET AMHPROG=Y
DEMO ;
+1 DO DEMOCHK^AMHUTIL1(.AMHDEMO)
+2 IF AMHDEMO=-1
GOTO PROG
ZIS ;call xbdbque
+1 SET XBRC="DRIVER^AMHRSU5"
SET XBRP="PRINT^AMHRSU5"
SET XBRX="XIT^AMHRSU5"
SET XBNS="AMH"
+2 DO ^XBDBQUE
+3 DO XIT
+4 QUIT
DRIVER ;EP entry point for taskman
+1 DO PROCESS
+2 SET AMHET=$HOROLOG
+3 QUIT
XIT ;
+1 KILL DIR
+2 ;clean up AMH variables
DO EN^XBVK("AMH")
+3 ;clean up fileman variables
DO ^XBFMK
+4 QUIT
+5 ;
PROCESS ;
+1 DO XTMP^AMHUTIL("AMHRSU5","BH - SUICIDE POV REPORT")
+2 SET (AMHBT,AMHBTH)=$HOROLOG
SET AMHJOB=$JOB
+3 KILL AMHMALEV,AMHFEMV,AMHALLV,AMHMALEP,AMHFEMP,AMHALLP
+4 FOR X=1:1:13
SET (AMHMALEV(X),AMHFEMV(X),AMHALLV(X),AMHMALEP(X),AMHFEMP(X),AMHALLP(X))=0
+5 SET AMHSD=$PIECE(AMHBD,".")-1
SET AMHSD=AMHSD_".9999"
+6 KILL AMHPRAT
SET AMHGRTA=0
+7 SET (AMHRCNT,AMHVIEN)=0
FOR
SET AMHSD=$ORDER(^AMHREC("B",AMHSD))
IF AMHSD=""!($PIECE(AMHSD,".")>$PIECE(AMHED,"."))
QUIT
Begin DoDot:1
+8 SET AMHVIEN=0
FOR
SET AMHVIEN=$ORDER(^AMHREC("B",AMHSD,AMHVIEN))
IF AMHVIEN'=+AMHVIEN
QUIT
Begin DoDot:2
+9 SET AMHV0=$GET(^AMHREC(AMHVIEN,0))
+10 IF AMHV0=""
QUIT
+11 SET DFN=$PIECE(^AMHREC(AMHVIEN,0),U,8)
+12 IF DFN=""
QUIT
+13 IF $$DEMO^AMHUTIL1(DFN,$GET(AMHDEMO))
QUIT
+14 ;not correct program visit
IF AMHPROG]""
IF $PIECE(^AMHREC(AMHVIEN,0),U,2)'=AMHPROG
QUIT
+15 ;no pOVS
IF '$DATA(^AMHRPRO("AD",AMHVIEN))
QUIT
+16 SET AMHAGE=$$AGE^AUPNPAT(DFN,$PIECE($PIECE(AMHV0,U),"."))
+17 SET A=$$AG(AMHAGE)
+18 DO SETT(1,A,DFN)
+19 ;no suicide pov
IF '$$SUICPOV(AMHVIEN)
QUIT
+20 DO SETT(2,A,DFN)
+21 IF $$SUICC(AMHVIEN,39)
DO SETT(3,A,DFN)
+22 IF $$SUICC(AMHVIEN,40)
DO SETT(4,A,DFN)
+23 IF $$SUICC(AMHVIEN,41)
DO SETT(5,A,DFN)
+24 IF $$SUICC(AMHVIEN,"V62.84")
DO SETT(3,A,DFN)
+25 IF $$SUICC(AMHVIEN,"R45.851")
DO SETT(3,A,DFN)
+26 IF $$SUICC(AMHVIEN,"T14.91")
DO SETT(4,A,DFN)
+27 QUIT
End DoDot:2
+28 QUIT
End DoDot:1
+29 SET AMHET=$HOROLOG
+30 QUIT
+31 ;
SETT(P,A,D) ;
+1 ;all visits, all 39/40/41
SET $PIECE(AMHALLV(13),U,P)=$PIECE(AMHALLV(13),U,P)+1
+2 IF $PIECE(^DPT(D,0),U,2)="M"
SET $PIECE(AMHMALEV(13),U,P)=$PIECE(AMHMALEV(13),U,P)+1
+3 IF $PIECE(^DPT(D,0),U,2)="F"
SET $PIECE(AMHFEMV(13),U,P)=$PIECE(AMHFEMV(13),U,P)+1
+4 SET $PIECE(AMHALLV(A),U,P)=$PIECE(AMHALLV(A),U,P)+1
+5 IF $PIECE(^DPT(D,0),U,2)="M"
SET $PIECE(AMHMALEV(A),U,P)=$PIECE(AMHMALEV(A),U,P)+1
+6 IF $PIECE(^DPT(D,0),U,2)="F"
SET $PIECE(AMHFEMV(A),U,P)=$PIECE(AMHFEMV(A),U,P)+1
+7 IF $PIECE($GET(^XTMP("AMHRSU5",AMHJOB,AMHBTH,"PATIENTS",D)),U,P)
QUIT
+8 SET $PIECE(^XTMP("AMHRSU5",AMHJOB,AMHBTH,"PATIENTS",D),U,P)=1
+9 SET $PIECE(AMHALLP(13),U,P)=$PIECE(AMHALLP(13),U,P)+1
+10 IF $PIECE(^DPT(D,0),U,2)="M"
SET $PIECE(AMHMALEP(13),U,P)=$PIECE(AMHMALEP(13),U,P)+1
+11 IF $PIECE(^DPT(D,0),U,2)="F"
SET $PIECE(AMHFEMP(13),U,P)=$PIECE(AMHFEMP(13),U,P)+1
+12 SET $PIECE(AMHALLP(A),U,P)=$PIECE(AMHALLP(A),U,P)+1
+13 IF $PIECE(^DPT(D,0),U,2)="M"
SET $PIECE(AMHMALEP(A),U,P)=$PIECE(AMHMALEP(A),U,P)+1
+14 IF $PIECE(^DPT(D,0),U,2)="F"
SET $PIECE(AMHFEMP(A),U,P)=$PIECE(AMHFEMP(A),U,P)+1
+15 QUIT
AG(A) ;
+1 IF A<5
QUIT 1
+2 IF A>4
IF A<10
QUIT 2
+3 IF A>9
IF A<15
QUIT 3
+4 IF A>14
IF A<20
QUIT 4
+5 IF A>19
IF A<25
QUIT 5
+6 IF A>24
IF A<35
QUIT 6
+7 IF A>34
IF A<45
QUIT 7
+8 IF A>44
IF A<55
QUIT 8
+9 IF A>54
IF A<65
QUIT 9
+10 IF A>64
IF A<75
QUIT 10
+11 IF A>74
IF A<85
QUIT 11
+12 IF A>84
QUIT 12
+13 QUIT ""
SUICPOV(V) ;
+1 SET G=0
+2 SET X=0
FOR
SET X=$ORDER(^AMHRPRO("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+3 IF '$DATA(^AMHRPRO(X,0))
QUIT
+4 SET Y=$PIECE(^AMHRPRO(X,0),U)
+5 IF '$DATA(^AMHPROB(Y,0))
QUIT
+6 SET Y=$PIECE(^AMHPROB(Y,0),U)
+7 IF Y=39!(Y=40)!(Y=41)!(Y="V62.84")!(Y="R45.851")!(Y="T14.91")
SET G=1
+8 QUIT
End DoDot:1
+9 QUIT G
SUICC(V,C) ;
+1 SET G=0
+2 SET X=0
FOR
SET X=$ORDER(^AMHRPRO("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+3 IF '$DATA(^AMHRPRO(X,0))
QUIT
+4 SET Y=$PIECE(^AMHRPRO(X,0),U)
+5 IF '$DATA(^AMHPROB(Y,0))
QUIT
+6 SET Y=$PIECE(^AMHPROB(Y,0),U)
+7 IF Y=C
SET G=1
+8 QUIT
End DoDot:1
+9 QUIT G
PRINT ;EP - called from xbdbque
+1 SET Y=AMHBD
DO DD^%DT
SET AMHBDD=Y
SET Y=AMHED
DO DD^%DT
SET AMHEDD=Y
+2 SET AMHPG=0
+3 KILL AMHQUIT
+4 DO PRINT1
DONE IF $DATA(AMHET)
SET AMHDVTS=(86400*($PIECE(AMHET,",")-$PIECE(AMHBT,",")))+($PIECE(AMHET,",",2)-$PIECE(AMHBT,",",2))
SET AMHDVH=$PIECE(AMHDVTS/3600,".")
IF AMHDVH=""
SET AMHDVH=0
+1 SET AMHDVTS=AMHDVTS-(AMHDVH*3600)
SET AMHDVM=$PIECE(AMHDVTS/60,".")
IF AMHDVM=""
SET AMHDVM=0
SET AMHDVTS=AMHDVTS-(AMHDVM*60)
SET AMHDVS=AMHDVTS
WRITE !!,"RUN TIME (H.M.S): ",AMHDVH,".",AMHDVM,".",AMHDVS
+2 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
SET DIR("A")="End of Report, press Enter"
SET DIR(0)="E"
DO ^DIR
KILL DIR
+3 IF $DATA(IOF)
WRITE @IOF
+4 QUIT
PRINT1 ;
+1 SET AMHSUBH="BOTH MALE AND FEMALE PATIENTS' VISITS"
+2 DO HEAD
IF $DATA(AMHQUIT)
QUIT
+3 FOR AMHX=1:1:13
Begin DoDot:1
+4 IF $DATA(AMHQUIT)
QUIT
+5 IF $Y>(IOSL-2)
DO HEAD
IF $DATA(AMHQUIT)
QUIT
+6 WRITE !!?1,$PIECE($TEXT(@AMHX),";;",2)
+7 WRITE ?13,$$RJ^XLFSTR($$C($PIECE(AMHALLV(AMHX),U,1),0,6),6)
+8 SET N=$PIECE(AMHALLV(AMHX),U,1)
SET D=$PIECE(AMHALLV(13),U,1)
+9 IF 'D
WRITE ?22,"0.0"
+10 IF D
WRITE ?20,$JUSTIFY(((N/D)*100),5,1)
+11 ;
+12 WRITE ?27,$$RJ^XLFSTR($$C($PIECE(AMHALLV(AMHX),U,3),0,6),6)
+13 SET N=$PIECE(AMHALLV(AMHX),U,3)
SET D=$PIECE(AMHALLV(AMHX),U,1)
+14 IF 'D
WRITE ?35,"0.0"
+15 IF D
WRITE ?34,$JUSTIFY(((N/D)*100),5,1)
+16 ;
+17 WRITE ?41,$$RJ^XLFSTR($$C($PIECE(AMHALLV(AMHX),U,4),0,6),6)
+18 SET N=$PIECE(AMHALLV(AMHX),U,4)
SET D=$PIECE(AMHALLV(AMHX),U,1)
+19 IF 'D
WRITE ?48,"0.0"
+20 IF D
WRITE ?47,$JUSTIFY(((N/D)*100),5,1)
+21 ;
+22 WRITE ?54,$$RJ^XLFSTR($$C($PIECE(AMHALLV(AMHX),U,5),0,6),6)
+23 SET N=$PIECE(AMHALLV(AMHX),U,5)
SET D=$PIECE(AMHALLV(AMHX),U,1)
+24 IF 'D
WRITE ?64,"0.0"
+25 IF D
WRITE ?62,$JUSTIFY(((N/D)*100),5,1)
+26 ;
+27 WRITE ?68,$$RJ^XLFSTR($$C($PIECE(AMHALLV(AMHX),U,2),0,6),6)
+28 SET N=$PIECE(AMHALLV(AMHX),U,2)
SET D=$PIECE(AMHALLV(AMHX),U,1)
+29 IF 'D
WRITE ?77,"0.0"
+30 IF D
WRITE ?74,$JUSTIFY(((N/D)*100),5,1)
End DoDot:1
IF $DATA(AMHQUIT)
QUIT
MALEV ;MALE VISITS
+1 IF $DATA(AMHQUIT)
QUIT
+2 SET AMHSUBH="MALE PATIENTS VISITS"
+3 DO HEAD
IF $DATA(AMHQUIT)
QUIT
+4 FOR AMHX=1:1:13
Begin DoDot:1
+5 IF $Y>(IOSL-2)
DO HEAD
IF $DATA(AMHQUIT)
QUIT
+6 WRITE !!?1,$PIECE($TEXT(@AMHX),";;",2)
+7 WRITE ?13,$$RJ^XLFSTR($$C($PIECE(AMHMALEV(AMHX),U,1),0,6),6)
+8 SET N=$PIECE(AMHMALEV(AMHX),U,1)
SET D=$PIECE(AMHMALEV(13),U,1)
+9 IF 'D
WRITE ?22,"0.0"
+10 IF D
WRITE ?20,$JUSTIFY(((N/D)*100),5,1)
+11 ;
+12 WRITE ?27,$$RJ^XLFSTR($$C($PIECE(AMHMALEV(AMHX),U,3),0,6),6)
+13 SET N=$PIECE(AMHMALEV(AMHX),U,3)
SET D=$PIECE(AMHMALEV(AMHX),U,1)
+14 IF 'D
WRITE ?35,"0.0"
+15 IF D
WRITE ?34,$JUSTIFY(((N/D)*100),5,1)
+16 ;
+17 WRITE ?41,$$RJ^XLFSTR($$C($PIECE(AMHMALEV(AMHX),U,4),0,6),6)
+18 SET N=$PIECE(AMHMALEV(AMHX),U,4)
SET D=$PIECE(AMHMALEV(AMHX),U,1)
+19 IF 'D
WRITE ?48,"0.0"
+20 IF D
WRITE ?47,$JUSTIFY(((N/D)*100),5,1)
+21 ;
+22 WRITE ?54,$$RJ^XLFSTR($$C($PIECE(AMHMALEV(AMHX),U,5),0,6),6)
+23 SET N=$PIECE(AMHMALEV(AMHX),U,5)
SET D=$PIECE(AMHMALEV(AMHX),U,1)
+24 IF 'D
WRITE ?64,"0.0"
+25 IF D
WRITE ?61,$JUSTIFY(((N/D)*100),5,1)
+26 ;
+27 WRITE ?68,$$RJ^XLFSTR($$C($PIECE(AMHMALEV(AMHX),U,2),0,6),6)
+28 SET N=$PIECE(AMHMALEV(AMHX),U,2)
SET D=$PIECE(AMHMALEV(AMHX),U,1)
+29 IF 'D
WRITE ?77,"0.0"
+30 IF D
WRITE ?77,$JUSTIFY(((N/D)*100),5,1)
End DoDot:1
IF $DATA(AMHQUIT)
QUIT
+31 ;
FEMV ;FEMALE VISITSA
+1 IF $DATA(AMHQUIT)
QUIT
+2 SET AMHSUBH="FEMALE PATIENTS VISITS"
+3 DO HEAD
IF $DATA(AMHQUIT)
QUIT
+4 FOR AMHX=1:1:13
Begin DoDot:1
+5 IF $Y>(IOSL-2)
DO HEAD
IF $DATA(AMHQUIT)
QUIT
+6 WRITE !!?1,$PIECE($TEXT(@AMHX),";;",2)
+7 WRITE ?13,$$RJ^XLFSTR($$C($PIECE(AMHFEMV(AMHX),U,1),0,6),6)
+8 SET N=$PIECE(AMHFEMV(AMHX),U,1)
SET D=$PIECE(AMHFEMV(13),U,1)
+9 IF 'D
WRITE ?22,"0.0"
+10 IF D
WRITE ?20,$JUSTIFY(((N/D)*100),5,1)
+11 ;
+12 WRITE ?27,$$RJ^XLFSTR($$C($PIECE(AMHFEMV(AMHX),U,3),0,6),6)
+13 SET N=$PIECE(AMHFEMV(AMHX),U,3)
SET D=$PIECE(AMHFEMV(AMHX),U,1)
+14 IF 'D
WRITE ?35,"0.0"
+15 IF D
WRITE ?34,$JUSTIFY(((N/D)*100),5,1)
+16 ;
+17 WRITE ?41,$$RJ^XLFSTR($$C($PIECE(AMHFEMV(AMHX),U,4),0,6),6)
+18 SET N=$PIECE(AMHFEMV(AMHX),U,4)
SET D=$PIECE(AMHFEMV(AMHX),U,1)
+19 IF 'D
WRITE ?48,"0.0"
+20 IF D
WRITE ?47,$JUSTIFY(((N/D)*100),5,1)
+21 ;
+22 WRITE ?54,$$RJ^XLFSTR($$C($PIECE(AMHFEMV(AMHX),U,5),0,6),6)
+23 SET N=$PIECE(AMHFEMV(AMHX),U,5)
SET D=$PIECE(AMHFEMV(AMHX),U,1)
+24 IF 'D
WRITE ?64,"0.0"
+25 IF D
WRITE ?61,$JUSTIFY(((N/D)*100),5,1)
+26 ;
+27 WRITE ?68,$$RJ^XLFSTR($$C($PIECE(AMHFEMV(AMHX),U,2),0,6),6)
+28 SET N=$PIECE(AMHFEMV(AMHX),U,2)
SET D=$PIECE(AMHFEMV(AMHX),U,1)
+29 IF 'D
WRITE ?77,"0.0"
+30 IF D
WRITE ?77,$JUSTIFY(((N/D)*100),5,1)
End DoDot:1
IF $DATA(AMHQUIT)
QUIT
+31 ;
PRINT2 ;
+1 SET AMHSUBH="UNDUPLICATED PATIENT COUNT - BOTH MALE AND FEMALE PATIENTS"
+2 IF $DATA(AMHQUIT)
QUIT
+3 DO HEAD
IF $DATA(AMHQUIT)
QUIT
+4 FOR AMHX=1:1:13
Begin DoDot:1
+5 IF $Y>(IOSL-2)
DO HEAD
IF $DATA(AMHQUIT)
QUIT
+6 WRITE !!?1,$PIECE($TEXT(@AMHX),";;",2)
+7 WRITE ?13,$$RJ^XLFSTR($$C($PIECE(AMHALLP(AMHX),U,1),0,6),6)
+8 SET N=$PIECE(AMHALLP(AMHX),U,1)
SET D=$PIECE(AMHALLP(13),U,1)
+9 IF 'D
WRITE ?22,"0.0"
+10 IF D
WRITE ?20,$JUSTIFY(((N/D)*100),5,1)
+11 ;
+12 WRITE ?27,$$RJ^XLFSTR($$C($PIECE(AMHALLP(AMHX),U,3),0,6),6)
+13 SET N=$PIECE(AMHALLP(AMHX),U,3)
SET D=$PIECE(AMHALLP(AMHX),U,1)
+14 IF 'D
WRITE ?35,"0.0"
+15 IF D
WRITE ?34,$JUSTIFY(((N/D)*100),5,1)
+16 ;
+17 WRITE ?41,$$RJ^XLFSTR($$C($PIECE(AMHALLP(AMHX),U,4),0,6),6)
+18 SET N=$PIECE(AMHALLP(AMHX),U,4)
SET D=$PIECE(AMHALLP(AMHX),U,1)
+19 IF 'D
WRITE ?48,"0.0"
+20 IF D
WRITE ?47,$JUSTIFY(((N/D)*100),5,1)
+21 ;
+22 WRITE ?54,$$RJ^XLFSTR($$C($PIECE(AMHALLP(AMHX),U,5),0,6),6)
+23 SET N=$PIECE(AMHALLP(AMHX),U,5)
SET D=$PIECE(AMHALLP(AMHX),U,1)
+24 IF 'D
WRITE ?64,"0.0"
+25 IF D
WRITE ?61,$JUSTIFY(((N/D)*100),5,1)
+26 ;
+27 WRITE ?68,$$RJ^XLFSTR($$C($PIECE(AMHALLP(AMHX),U,2),0,6),6)
+28 SET N=$PIECE(AMHALLP(AMHX),U,2)
SET D=$PIECE(AMHALLP(AMHX),U,1)
+29 IF 'D
WRITE ?77,"0.0"
+30 IF D
WRITE ?77,$JUSTIFY(((N/D)*100),5,1)
End DoDot:1
IF $DATA(AMHQUIT)
QUIT
MALEP ;MALE PATS
+1 IF $DATA(AMHQUIT)
QUIT
+2 SET AMHSUBH="UNDUPLICATED PATIENT COUNT - MALE PATIENTS"
+3 DO HEAD
IF $DATA(AMHQUIT)
QUIT
+4 FOR AMHX=1:1:13
Begin DoDot:1
+5 IF $Y>(IOSL-2)
DO HEAD
IF $DATA(AMHQUIT)
QUIT
+6 WRITE !!?1,$PIECE($TEXT(@AMHX),";;",2)
+7 WRITE ?13,$$RJ^XLFSTR($$C($PIECE(AMHMALEP(AMHX),U,1),0,6),6)
+8 SET N=$PIECE(AMHMALEP(AMHX),U,1)
SET D=$PIECE(AMHMALEP(13),U,1)
+9 IF 'D
WRITE ?22,"0.0"
+10 IF D
WRITE ?20,$JUSTIFY(((N/D)*100),5,1)
+11 ;
+12 WRITE ?27,$$RJ^XLFSTR($$C($PIECE(AMHMALEP(AMHX),U,3),0,6),6)
+13 SET N=$PIECE(AMHMALEP(AMHX),U,3)
SET D=$PIECE(AMHMALEP(AMHX),U,1)
+14 IF 'D
WRITE ?35,"0.0"
+15 IF D
WRITE ?34,$JUSTIFY(((N/D)*100),5,1)
+16 ;
+17 WRITE ?41,$$RJ^XLFSTR($$C($PIECE(AMHMALEP(AMHX),U,4),0,6),6)
+18 SET N=$PIECE(AMHMALEP(AMHX),U,4)
SET D=$PIECE(AMHMALEP(AMHX),U,1)
+19 IF 'D
WRITE ?48,"0.0"
+20 IF D
WRITE ?47,$JUSTIFY(((N/D)*100),5,1)
+21 ;
+22 WRITE ?54,$$RJ^XLFSTR($$C($PIECE(AMHMALEP(AMHX),U,5),0,6),6)
+23 SET N=$PIECE(AMHMALEP(AMHX),U,5)
SET D=$PIECE(AMHMALEP(AMHX),U,1)
+24 IF 'D
WRITE ?64,"0.0"
+25 IF D
WRITE ?61,$JUSTIFY(((N/D)*100),5,1)
+26 ;
+27 WRITE ?68,$$RJ^XLFSTR($$C($PIECE(AMHMALEP(AMHX),U,2),0,6),6)
+28 SET N=$PIECE(AMHMALEP(AMHX),U,2)
SET D=$PIECE(AMHMALEP(AMHX),U,1)
+29 IF 'D
WRITE ?77,"0.0"
+30 IF D
WRITE ?77,$JUSTIFY(((N/D)*100),5,1)
End DoDot:1
IF $DATA(AMHQUIT)
QUIT
+31 ;
FEMP ;FEMALE PATS
+1 IF $DATA(AMHQUIT)
QUIT
+2 SET AMHSUBH="UNDUPLICATED PATIENT COUNT - FEMALE PATIENTS"
+3 DO HEAD
+4 IF $DATA(AMHQUIT)
QUIT
+5 FOR AMHX=1:1:13
Begin DoDot:1
+6 IF $Y>(IOSL-2)
DO HEAD
IF $DATA(AMHQUIT)
QUIT
+7 WRITE !!?1,$PIECE($TEXT(@AMHX),";;",2)
+8 WRITE ?13,$$RJ^XLFSTR($$C($PIECE(AMHFEMP(AMHX),U,1),0,6),6)
+9 SET N=$PIECE(AMHFEMP(AMHX),U,1)
SET D=$PIECE(AMHFEMP(13),U,1)
+10 IF 'D
WRITE ?22,"0.0"
+11 IF D
WRITE ?20,$JUSTIFY(((N/D)*100),5,1)
+12 ;
+13 WRITE ?27,$$RJ^XLFSTR($$C($PIECE(AMHFEMP(AMHX),U,3),0,6),6)
+14 SET N=$PIECE(AMHFEMP(AMHX),U,3)
SET D=$PIECE(AMHFEMP(AMHX),U,1)
+15 IF 'D
WRITE ?35,"0.0"
+16 IF D
WRITE ?34,$JUSTIFY(((N/D)*100),5,1)
+17 ;
+18 WRITE ?41,$$RJ^XLFSTR($$C($PIECE(AMHFEMP(AMHX),U,4),0,6),6)
+19 SET N=$PIECE(AMHFEMP(AMHX),U,4)
SET D=$PIECE(AMHFEMP(AMHX),U,1)
+20 IF 'D
WRITE ?48,"0.0"
+21 IF D
WRITE ?47,$JUSTIFY(((N/D)*100),5,1)
+22 ;
+23 WRITE ?54,$$RJ^XLFSTR($$C($PIECE(AMHFEMP(AMHX),U,5),0,6),6)
+24 SET N=$PIECE(AMHFEMP(AMHX),U,5)
SET D=$PIECE(AMHFEMP(AMHX),U,1)
+25 IF 'D
WRITE ?64,"0.0"
+26 IF D
WRITE ?61,$JUSTIFY(((N/D)*100),5,1)
+27 ;
+28 WRITE ?68,$$RJ^XLFSTR($$C($PIECE(AMHFEMP(AMHX),U,2),0,6),6)
+29 SET N=$PIECE(AMHFEMP(AMHX),U,2)
SET D=$PIECE(AMHFEMP(AMHX),U,1)
+30 IF 'D
WRITE ?77,"0.0"
+31 IF D
WRITE ?77,$JUSTIFY(((N/D)*100),5,1)
End DoDot:1
IF $DATA(AMHQUIT)
QUIT
+32 ;
+33 QUIT
PAGEHEAD ;
HEAD ;EP;HEADER
+1 IF 'AMHPG
GOTO HEAD1
+2 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 !,$$FMTE^XLFDT(DT),?70,"Page: ",AMHPG
+3 WRITE !?29,"Behavioral Health"
+4 WRITE !,$$CTR($$REPEAT^XLFSTR("*",35),80)
+5 WRITE !,$$CTR("* SUICIDE PURPOSE OF VISIT REPORT *",80)
+6 WRITE !,$$CTR($$REPEAT^XLFSTR("*",35),80)
+7 SET X="VISIT Date Range: "_AMHBDD_" through "_AMHEDD
WRITE !,$$CTR(X,80)
+8 SET X=AMHSUBH
WRITE !,$$CTR(X,80),!
+9 SET X="39, V62.84, R45.851 - Suicide Ideation; 40 & T14.91 - Suicide Attempt/Gesture;"
WRITE !,$$CTR(X,80),!
+10 SET X="41 - Suicide Completed"
WRITE $$CTR(X,80),!
+11 WRITE !,"AGE GROUP",?13,"# Encs",?27,"# w POV 39",?42,"w/ POV 40",?54,"w/ POV 41",?68,"w/ 39/40/41/"
+12 WRITE !?27,"V62.84/R45.851",?42,"& T14.91",?68,"V62.84/R45.851"
+13 WRITE !?15,"#",?22,"%",?29,"#",?36,"%",?43,"#",?50,"%",?56,"#",?63,"%",?70,"#",?77,"%"
+14 WRITE !,$$REPEAT^XLFSTR("-",80)
+15 QUIT
C(X,X2,X3) ;
+1 DO COMMA^%DTC
+2 QUIT $$STRIP^XLFSTR(X," ")
D(D) ;
+1 IF $GET(D)=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
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("A")="End of report. Press Enter"
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 ;----------
INFORM ;inform user what this report is all about
+1 WRITE !,$$CTR($$LOC)
+2 WRITE !!,$$CTR("BEHAVIORAL HEALTH SUICIDE PURPOSE OF VISIT REPORT")
+3 WRITE !!,"This report will display the Suicide POVs (39,40,41,V62.84, R45.851, T14.91)"
+4 WRITE !," as a percentage of the total number of Behavioral Health encounter"
+5 WRITE !,"records (Encs). Any records containing the ICD-9 code v62.84,"
+6 WRITE !,"Suicidal Ideation or ICD-10 code R45.851 will be included in "
+7 WRITE !,"the tallies for Problem code 39. Any records with ICD-10 Code T14.91"
+8 WRITE !,"will be included in the tallies for Problem code 40. A display by "
+9 WRITE !,"age and gender is also included."
+10 WRITE !
+11 QUIT
OPRV ;one PROVIDER
+1 SET DIC="^VA(200,"
SET DIC(0)="AEMQ"
SET DIC("A")="Which PROVIDER: "
DO ^DIC
KILL DIC
+2 IF Y=-1
SET AMHQ=""
QUIT
+3 SET AMHPRVS(+Y)=""
+4 QUIT
SPRV ;taxonomy of PROVIDERS
+1 SET X="PRIMARY PROVIDER"
SET DIC="^AMQQ(5,"
SET DIC(0)="FM"
SET DIC("S")="I $P(^(0),U,14)"
DO ^DIC
KILL DIC,DA
IF Y=-1
WRITE "OOPS - QMAN NOT CURRENT - QUITTING"
GOTO XIT
+2 DO PEP^AMQQGTX0(+Y,"AMHPRVS(")
+3 IF '$DATA(AMHPRVS)
SET AMHQ=""
QUIT
+4 IF $DATA(AMHPRVS("*"))
SET AMHPRVT="A"
KILL AMHPRVS
WRITE !!,"**** all PROVIDERS will be included ****",!
QUIT
+5 QUIT
+6 ;
1 ;;1-4 yrs
2 ;;5-9 yrs
3 ;;10-14 yrs
4 ;;15-19 yrs
5 ;;20-24 yrs
6 ;;25-34 yrs
7 ;;35-44 yrs
8 ;;45-54 yrs
9 ;;55-64 yrs
10 ;;65-74 yrs
11 ;;75-84 yrs
12 ;;85+ yrs
13 ;;TOTAL
