AMHRAGS ; IHS/CMI/LAB - AGE/SEX REPORT ;
;;4.0;IHS BEHAVIORAL HEALTH;**1**;JUN 18, 2010;Build 8
;
PREPROC ;
D XTMP^AMHUTIL("AMHRAGS","BH CNTS BY AGE/SEX")
S AMHRNN=AMHRBIN,AMHRA="" F I=1:1 S AMHRX=$P(AMHRNN,";",I) Q:AMHRX="" D SETA
S AMHRDOBS=AMHRA
Q
SETA ;
S AMHRY=$P(AMHRX,"-"),AMHRZ=$P(AMHRX,"-",2)
I AMHRA]"" S AMHRA=AMHRA_";"
S AMHRA=AMHRA_(DT+1-(10000*(AMHRZ+1)))_"-"_(DT-(AMHRY*10000))
S ^XTMP("AMHRAGS",AMHJOB,AMHBTH,"TOTAL","AGE",I)=0
Q
SETTMP ;
Q:$P(AMHR0,U,8)=""
;Q:$D(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"PATIENT",$P(AMHR0,U,8))) ;quit if already counted this patient
S AMHPPOV=$O(^AMHRPRO("AD",AMHR,""))
S AMHRAGE="" D GETAGE
Q:'AMHRAGE
Q:AMHRSEX=""
D @(AMHRPROC_"^AMHRPTST")
Q:$D(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"PATIENT",$P(AMHR0,U,8),@AMHSORT))
S ^(AMHRAGE)=$S($D(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"AGE",AMHRSEX,@AMHSORT,AMHRAGE)):^(AMHRAGE)+1,1:1)
S ^(AMHRAGE)=$S($D(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"TOTAL",AMHRSEX,AMHRAGE)):^(AMHRAGE)+1,1:1)
S ^(@AMHSORT)=$S($D(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"TOTAL SORT",AMHRSEX,@AMHSORT)):^(@AMHSORT)+1,1:1)
S ^(AMHRAGE)=$S($D(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"AGE","B",@AMHSORT,AMHRAGE)):^(AMHRAGE)+1,1:1)
S ^(AMHRAGE)=$S($D(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"TOTAL","B",AMHRAGE)):^(AMHRAGE)+1,1:1)
S ^(@AMHSORT)=$S($D(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"TOTAL SORT","B",@AMHSORT)):^(@AMHSORT)+1,1:1)
S ^XTMP("AMHRAGS",AMHJOB,AMHBTH,"PATIENT",$P(AMHR0,U,8),@AMHSORT)=""
Q
GETAGE ;
S AMHRDOB=$P(^DPT($P(AMHR0,U,8),0),U,3) Q:AMHRDOB=""
S AMHRSEX=$P(^DPT($P(AMHR0,U,8),0),U,2)
ATT ;
F I=1:1 S AMHRNN=$P(AMHRA,";",I) Q:AMHRNN="" S AMHRX=$P(AMHRNN,"-"),AMHRY=$P(AMHRNN,"-",2) I AMHRDOB'<AMHRX,AMHRDOB'>AMHRY S AMHRAGE=I Q
Q
;
XIT ;
K AMHRY,AMHRX,AMHRA
Q
PRINT ;EP ;PRINT RECORD BY AGE/SEX
S AMHR132S="",$P(AMHR132S,"-",132)=""
D NOW^%DTC S Y=X D DD^%DT S AMHRDT=Y
D COVPAGE^AMHRPTCP
S AMHRPG=0,AMHSORT="",AMHRSEX=""
K AMHQUIT
I '$D(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"AGE")) D HEAD W !!,"No data to report.",! G DONE
F S AMHRSEX=$O(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"AGE",AMHRSEX)) Q:AMHRSEX=""!($D(AMHQUIT)) D SORT
DONE ;
D DONE^AMHLEIN,^AMHEKL
K ^XTMP("AMHRPT",AMHJOB,AMHBTH)
K ^XTMP("AMHRAGS",AMHJOB,AMHBTH),AMHJOB,AMHBTH
Q
SORT ;
D HEAD Q:$D(AMHQUIT)
S AMHSORT=""
F S AMHSORT=$O(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"AGE",AMHRSEX,AMHSORT)) Q:AMHSORT=""!($D(AMHQUIT)) D
.I $Y>(IOSL-5) D HEAD Q:$D(AMHQUIT)
.W !,$E(AMHSORT,1,30) S AMHRSRT2=$O(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"AGE",AMHRSEX,AMHSORT,"")) ;W ?32,$E(AMHRSRT2,1,9)
.N I,J,K S J=39 F I=1:1:$L(AMHRBIN,";") S K=$S($D(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"AGE",AMHRSEX,AMHSORT,I)):^(I),1:".") W ?J,$J(K,6) S J=J+9
.W ?J,$J(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"TOTAL SORT",AMHRSEX,AMHSORT),6)
.Q
Q:$D(AMHQUIT)
I $Y>(IOSL-5) D HEAD Q:$D(AMHQUIT)
S T=0 W !,"TOTAL:" S J=39 F I=1:1:$L(AMHRBIN,";") S K=$S($D(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"TOTAL",AMHRSEX,I)):^(I),1:".") W ?J,$J(K,6) S J=J+9,T=T+K
W ?J,$J(T,6)
Q
HEAD I 'AMHRPG 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 AMHRPG=AMHRPG+1
W !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
W !?37,"BEHAVIORAL HEALTH RECORD/ENCOUNTER COUNTS",?100,AMHRDT,?123,"Page ",AMHRPG,!
S AMHRLENG=15+$L(AMHTITL) W ?((132-AMHRLENG)/2),AMHTITL," BY AGE AND SEX",!
W ?43,"ENCOUNTER DATES: ",AMHBDD," TO ",AMHEDD,!
W !?61,"SEX: ",$S(AMHRSEX="M":"MALE",AMHRSEX="F":"FEMALE",1:"BOTH")
W !,AMHHD1 S J=41 F I=1:1:$L(AMHRBIN,";") S K=$P(AMHRBIN,";",I) Q:K="" W ?J,K S J=J+9
W ?J,"TOTAL"
W !,AMHR132S
Q
PI ;EP ;age/sex record counts interactive print ?
W !!
BIN D SETBIN
W !,"The Age Groups to be used are currently defined as:",! D LIST
S DIR(0)="Y",DIR("A")="Do you wish to modify these age groups" D ^DIR K DIR
I $D(DIRUT) S AMHQUIT="" G XIT
I Y=0 G XIT
RUN ;
K AMHQUIT S AMHRY="",AMHRA=-1 W ! F D AGE Q:AMHRX="" I $D(AMHQUIT) G BIN
D CLOSE I $D(AMHQUIT) G BIN
D LIST
G XIT
;
AGE ;
S AMHRX=""
S DIR(0)="NO^0:150:0",DIR("A")="Enter the starting age of the "_$S(AMHRY="":"first",1:"next")_" age group" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DUOUT)!($D(DTOUT)) S AMHQUIT="" Q
S AMHRX=Y
I Y="" Q
I AMHRX?1.3N,AMHRX>AMHRA D SET Q
W $C(7) W !,"Make sure the age is higher the beginning age of the previous group.",! G RUN
;
SET S AMHRA=AMHRX
I AMHRY="" S AMHRY=AMHRX Q
S AMHRY=AMHRY_"-"_(AMHRX-1)_";"_AMHRX
Q
;
CLOSE I AMHRY="" Q
GC ;
S DIR(0)="NO^0:150:0",DIR("A")="Enter the highest age for the last group" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DUOUT)!($D(DTOUT)) S AMHQUIT="" Q
S AMHRX=Y I Y="" S AMHRX=199
I AMHRX?1.3N,AMHRX'<AMHRA S AMHRY=AMHRY_"-"_AMHRX,AMHRBIN=AMHRY Q
W " ??",$C(7) G CLOSE
Q
;
;
LIST ;
S %=AMHRBIN
F I=1:1 S X=$P(%,";",I) Q:X="" W !,$P(X,"-")," - ",$P(X,"-",2)
W !
Q
;
SETBIN ;
S AMHRBIN="0-0;1-4;5-14;15-19;20-24;25-44;45-64;65-125"
Q
AMHRAGS ; IHS/CMI/LAB - AGE/SEX REPORT ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**1**;JUN 18, 2010;Build 8
+2 ;
PREPROC ;
+1 DO XTMP^AMHUTIL("AMHRAGS","BH CNTS BY AGE/SEX")
+2 SET AMHRNN=AMHRBIN
SET AMHRA=""
FOR I=1:1
SET AMHRX=$PIECE(AMHRNN,";",I)
IF AMHRX=""
QUIT
DO SETA
+3 SET AMHRDOBS=AMHRA
+4 QUIT
SETA ;
+1 SET AMHRY=$PIECE(AMHRX,"-")
SET AMHRZ=$PIECE(AMHRX,"-",2)
+2 IF AMHRA]""
SET AMHRA=AMHRA_";"
+3 SET AMHRA=AMHRA_(DT+1-(10000*(AMHRZ+1)))_"-"_(DT-(AMHRY*10000))
+4 SET ^XTMP("AMHRAGS",AMHJOB,AMHBTH,"TOTAL","AGE",I)=0
+5 QUIT
SETTMP ;
+1 IF $PIECE(AMHR0,U,8)=""
QUIT
+2 ;Q:$D(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"PATIENT",$P(AMHR0,U,8))) ;quit if already counted this patient
+3 SET AMHPPOV=$ORDER(^AMHRPRO("AD",AMHR,""))
+4 SET AMHRAGE=""
DO GETAGE
+5 IF 'AMHRAGE
QUIT
+6 IF AMHRSEX=""
QUIT
+7 DO @(AMHRPROC_"^AMHRPTST")
+8 IF $DATA(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"PATIENT",$PIECE(AMHR0,U,8),@AMHSORT))
QUIT
+9 SET ^(AMHRAGE)=$SELECT($DATA(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"AGE",AMHRSEX,@AMHSORT,AMHRAGE)):^(AMHRAGE)+1,1:1)
+10 SET ^(AMHRAGE)=$SELECT($DATA(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"TOTAL",AMHRSEX,AMHRAGE)):^(AMHRAGE)+1,1:1)
+11 SET ^(@AMHSORT)=$SELECT($DATA(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"TOTAL SORT",AMHRSEX,@AMHSORT)):^(@AMHSORT)+1,1:1)
+12 SET ^(AMHRAGE)=$SELECT($DATA(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"AGE","B",@AMHSORT,AMHRAGE)):^(AMHRAGE)+1,1:1)
+13 SET ^(AMHRAGE)=$SELECT($DATA(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"TOTAL","B",AMHRAGE)):^(AMHRAGE)+1,1:1)
+14 SET ^(@AMHSORT)=$SELECT($DATA(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"TOTAL SORT","B",@AMHSORT)):^(@AMHSORT)+1,1:1)
+15 SET ^XTMP("AMHRAGS",AMHJOB,AMHBTH,"PATIENT",$PIECE(AMHR0,U,8),@AMHSORT)=""
+16 QUIT
GETAGE ;
+1 SET AMHRDOB=$PIECE(^DPT($PIECE(AMHR0,U,8),0),U,3)
IF AMHRDOB=""
QUIT
+2 SET AMHRSEX=$PIECE(^DPT($PIECE(AMHR0,U,8),0),U,2)
ATT ;
+1 FOR I=1:1
SET AMHRNN=$PIECE(AMHRA,";",I)
IF AMHRNN=""
QUIT
SET AMHRX=$PIECE(AMHRNN,"-")
SET AMHRY=$PIECE(AMHRNN,"-",2)
IF AMHRDOB'<AMHRX
IF AMHRDOB'>AMHRY
SET AMHRAGE=I
QUIT
+2 QUIT
+3 ;
XIT ;
+1 KILL AMHRY,AMHRX,AMHRA
+2 QUIT
PRINT ;EP ;PRINT RECORD BY AGE/SEX
+1 SET AMHR132S=""
SET $PIECE(AMHR132S,"-",132)=""
+2 DO NOW^%DTC
SET Y=X
DO DD^%DT
SET AMHRDT=Y
+3 DO COVPAGE^AMHRPTCP
+4 SET AMHRPG=0
SET AMHSORT=""
SET AMHRSEX=""
+5 KILL AMHQUIT
+6 IF '$DATA(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"AGE"))
DO HEAD
WRITE !!,"No data to report.",!
GOTO DONE
+7 FOR
SET AMHRSEX=$ORDER(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"AGE",AMHRSEX))
IF AMHRSEX=""!($DATA(AMHQUIT))
QUIT
DO SORT
DONE ;
+1 DO DONE^AMHLEIN
DO ^AMHEKL
+2 KILL ^XTMP("AMHRPT",AMHJOB,AMHBTH)
+3 KILL ^XTMP("AMHRAGS",AMHJOB,AMHBTH),AMHJOB,AMHBTH
+4 QUIT
SORT ;
+1 DO HEAD
IF $DATA(AMHQUIT)
QUIT
+2 SET AMHSORT=""
+3 FOR
SET AMHSORT=$ORDER(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"AGE",AMHRSEX,AMHSORT))
IF AMHSORT=""!($DATA(AMHQUIT))
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-5)
DO HEAD
IF $DATA(AMHQUIT)
QUIT
+5 ;W ?32,$E(AMHRSRT2,1,9)
WRITE !,$EXTRACT(AMHSORT,1,30)
SET AMHRSRT2=$ORDER(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"AGE",AMHRSEX,AMHSORT,""))
+6 NEW I,J,K
SET J=39
FOR I=1:1:$LENGTH(AMHRBIN,";")
SET K=$SELECT($DATA(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"AGE",AMHRSEX,AMHSORT,I)):^(I),1:".")
WRITE ?J,$JUSTIFY(K,6)
SET J=J+9
+7 WRITE ?J,$JUSTIFY(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"TOTAL SORT",AMHRSEX,AMHSORT),6)
+8 QUIT
End DoDot:1
+9 IF $DATA(AMHQUIT)
QUIT
+10 IF $Y>(IOSL-5)
DO HEAD
IF $DATA(AMHQUIT)
QUIT
+11 SET T=0
WRITE !,"TOTAL:"
SET J=39
FOR I=1:1:$LENGTH(AMHRBIN,";")
SET K=$SELECT($DATA(^XTMP("AMHRAGS",AMHJOB,AMHBTH,"TOTAL",AMHRSEX,I)):^(I),1:".")
WRITE ?J,$JUSTIFY(K,6)
SET J=J+9
SET T=T+K
+12 WRITE ?J,$JUSTIFY(T,6)
+13 QUIT
HEAD IF 'AMHRPG
GOTO HEAD1
+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
SET AMHRPG=AMHRPG+1
+2 WRITE !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
+3 WRITE !?37,"BEHAVIORAL HEALTH RECORD/ENCOUNTER COUNTS",?100,AMHRDT,?123,"Page ",AMHRPG,!
+4 SET AMHRLENG=15+$LENGTH(AMHTITL)
WRITE ?((132-AMHRLENG)/2),AMHTITL," BY AGE AND SEX",!
+5 WRITE ?43,"ENCOUNTER DATES: ",AMHBDD," TO ",AMHEDD,!
+6 WRITE !?61,"SEX: ",$SELECT(AMHRSEX="M":"MALE",AMHRSEX="F":"FEMALE",1:"BOTH")
+7 WRITE !,AMHHD1
SET J=41
FOR I=1:1:$LENGTH(AMHRBIN,";")
SET K=$PIECE(AMHRBIN,";",I)
IF K=""
QUIT
WRITE ?J,K
SET J=J+9
+8 WRITE ?J,"TOTAL"
+9 WRITE !,AMHR132S
+10 QUIT
PI ;EP ;age/sex record counts interactive print ?
+1 WRITE !!
BIN DO SETBIN
+1 WRITE !,"The Age Groups to be used are currently defined as:",!
DO LIST
+2 SET DIR(0)="Y"
SET DIR("A")="Do you wish to modify these age groups"
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
SET AMHQUIT=""
GOTO XIT
+4 IF Y=0
GOTO XIT
RUN ;
+1 KILL AMHQUIT
SET AMHRY=""
SET AMHRA=-1
WRITE !
FOR
DO AGE
IF AMHRX=""
QUIT
IF $DATA(AMHQUIT)
GOTO BIN
+2 DO CLOSE
IF $DATA(AMHQUIT)
GOTO BIN
+3 DO LIST
+4 GOTO XIT
+5 ;
AGE ;
+1 SET AMHRX=""
+2 SET DIR(0)="NO^0:150:0"
SET DIR("A")="Enter the starting age of the "_$SELECT(AMHRY="":"first",1:"next")_" age group"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF $DATA(DUOUT)!($DATA(DTOUT))
SET AMHQUIT=""
QUIT
+4 SET AMHRX=Y
+5 IF Y=""
QUIT
+6 IF AMHRX?1.3N
IF AMHRX>AMHRA
DO SET
QUIT
+7 WRITE $CHAR(7)
WRITE !,"Make sure the age is higher the beginning age of the previous group.",!
GOTO RUN
+8 ;
SET SET AMHRA=AMHRX
+1 IF AMHRY=""
SET AMHRY=AMHRX
QUIT
+2 SET AMHRY=AMHRY_"-"_(AMHRX-1)_";"_AMHRX
+3 QUIT
+4 ;
CLOSE IF AMHRY=""
QUIT
GC ;
+1 SET DIR(0)="NO^0:150:0"
SET DIR("A")="Enter the highest age for the last group"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DUOUT)!($DATA(DTOUT))
SET AMHQUIT=""
QUIT
+3 SET AMHRX=Y
IF Y=""
SET AMHRX=199
+4 IF AMHRX?1.3N
IF AMHRX'<AMHRA
SET AMHRY=AMHRY_"-"_AMHRX
SET AMHRBIN=AMHRY
QUIT
+5 WRITE " ??",$CHAR(7)
GOTO CLOSE
+6 QUIT
+7 ;
+8 ;
LIST ;
+1 SET %=AMHRBIN
+2 FOR I=1:1
SET X=$PIECE(%,";",I)
IF X=""
QUIT
WRITE !,$PIECE(X,"-")," - ",$PIECE(X,"-",2)
+3 WRITE !
+4 QUIT
+5 ;
SETBIN ;
+1 SET AMHRBIN="0-0;1-4;5-14;15-19;20-24;25-44;45-64;65-125"
+2 QUIT
