- 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
