AMERBIN ; IHS/ANMC/GIS - MAKES AGE BIN REPORTS ;
;;3.0;ER VISIT SYSTEM;;FEB 23, 2009
;
N AMERA,AMERX,AMERY,AMERZ,%DT,AMERLINE
I '$D(AMERZZZ) S (AMERZZZ,AMERXXX)=0
S AMERZZZ=AMERZZZ+1
VAR S AMERDFN=@$S($D(AMERDEEP):($E("DDDDDD",1,AMERDEEP)_"D0"),$D(DD0):"DD0",1:"D0"),AMERVAL=Y I '$D(^DPT(AMERDFN)) D FAIL Q
S AMERDOB=$P(^DPT(AMERDFN,0),U,3)
I AMERDOB="" D FAIL Q
I IOST["C-",AMERZZZ>1 W *13,AMERZZZ I AMERXXX W " (",AMERXXX,")"
I AMERVAL="" S AMERVAL="UNSPECIFIED"
I $D(AMERBIN) D ATT Q
REP I '$D(^TMP("AMERAGE",$J)) D SETBIN
S AMERNN=^TMP("AMERAGE",$J),AMERA=""
S DIOEND="D BLIST^AMERBIN"
I IOST["C-" W !!!!,"CRUNCH, CRUNCH....",!!
K ^TMP("AMERBIN",$J)
F I=1:1 S AMERX=$P(AMERNN,";",I) Q:AMERX="" D SETA
S AMERBIN=AMERA
F I=1:1:$L(AMERA,";") S ^TMP("AMERBIN",$J,"B",I)=0
D ATT
Q
;
FAIL S AMERXXX=AMERXXX+1
I AMERZZZ>1 W *13,AMERZZZ," (",AMERXXX,")"
Q
;
SETA S AMERY=$P(AMERX,":"),AMERZ=$P(AMERX,":",2)
I AMERA'="" S AMERA=AMERA_";"
S AMERA=AMERA_(DT+1-(10000*(AMERZ+1)))_":"_(DT-(AMERY*10000))
Q
;
ATT S AMERA=AMERBIN
F I=1:1 S AMERNN=$P(AMERA,";",I) Q:AMERNN="" S AMERX=$P(AMERNN,":"),AMERY=$P(AMERNN,":",2) I AMERDOB'<AMERX,AMERDOB'>AMERY D SETV Q
Q
;
SETV ;
I '$D(^TMP("AMERBIN",$J,"V",AMERVAL)) S ^(AMERVAL)=0
S ^TMP("AMERBIN",$J,"V",AMERVAL)=^TMP("AMERBIN",$J,"V",AMERVAL)+1
S ^TMP("AMERBIN",$J,"B",I)=^TMP("AMERBIN",$J,"B",I)+1
I '$D(^TMP("AMERBIN",$J,1,AMERVAL,I)) S ^(I)=0
S ^TMP("AMERBIN",$J,1,AMERVAL,I)=^TMP("AMERBIN",$J,1,AMERVAL,I)+1
Q
;
BLIST ; I IOST["C-" R !!,"<>",AMERX#1:DTIME
I '$D(^TMP("AMERAGE",$J)) D SETBIN
D HEADER
BLVAR ;
S N=""
S AMERLINE=""
F AMERLINE=1:1 S I=0,N=$O(^TMP("AMERBIN",$J,1,N)) Q:N="" D:'(AMERLINE#(IOSL-4)) PAUSE Q:AMERLINE=999999 W !,$E(N,1,12) D B1
W !!,"TOTAL"
S (I,AMERZ)=0 F J=16:7 S I=$O(^TMP("AMERBIN",$J,"B",I)) Q:'I W ?J,^(I) S AMERZ=AMERZ+^(I)
W ?J,AMERZ
I $D(AMERXXX),AMERXXX W !!,AMERXXX," ENTR",$S(AMERXXX>1:"IES",1:"Y")," NOT INCLUDED BECAUSE OF BAD POINTERS OR LACK OF DOB"
I IOST'?1"C-".E W @IOF D ^%ZISC G EXIT
D ^%ZISC W !! S DIR(0)="E",DIR("A")="<>" D ^DIR S AMERX=Y K DIR,Y
EXIT K ^TMP("AMERBIN",$J),^TMP("AMERAGE",$J),X,Y,Z,AMERNN,AMERVAL,AMERAV,AMERDFN,AMERDOB,AMERSNA,AMERSNO,A,G,AMERDEEP,AMERZZZ,AMERXXX,AMERLINE,AMERBIN,N
Q
;
B1 ;
F J=16:7 D
.S I=I+1 Q:I>$L(^TMP("AMERAGE",$J),";")
.W ?J,$S($D(^TMP("AMERBIN",$J,1,N,I)):^(I),1:".")
.I I+1>$L(^TMP("AMERAGE",$J),";") W ?(J+7),^TMP("AMERBIN",$J,"V",N)
Q
;
PAUSE ;
I IOST["C-" W ! S DIR(0)="E",DIR("A")="<>" D ^DIR S AMERQ=Y K DIR,Y
S:'$T!(AMERQ=U) AMERLINE=999999 K AMERQ
D HEADER
Q
;
W !,?35,"AGE GROUPS",!
I '$D(AMERSNA) S AMERSNA="ATTRIBUTE"
S AMERNN=$E(AMERSNA,1,12) I $L(AMERNN)<12 S AMERNN=AMERNN_$J("",12-$L(AMERNN))
W AMERNN
S AMERNN=^TMP("AMERAGE",$J),AMERI=0
S AMERJ=""
F AMERJ=14:7 S AMERI=AMERI+1,AMERX=$P(AMERNN,";",AMERI) Q:AMERX="" W ?AMERJ,$S($P(AMERX,":")=$P(AMERX,":",2):" ",1:($P(AMERX,":")_"-")),$P(AMERX,":",2)
W ?(AMERJ+2),"TOT"
S AMERX="",$P(AMERX,"-",80)="" W !,AMERX
K AMERI,AMERJ,AMERX
Q
;
SETBIN S ^TMP("AMERAGE",$J)="0:1;2:4;5:12;13:19;20:39;40:59;60:79;80:199"
Q
AMERBIN ; IHS/ANMC/GIS - MAKES AGE BIN REPORTS ;
+1 ;;3.0;ER VISIT SYSTEM;;FEB 23, 2009
+2 ;
+3 NEW AMERA,AMERX,AMERY,AMERZ,%DT,AMERLINE
+4 IF '$DATA(AMERZZZ)
SET (AMERZZZ,AMERXXX)=0
+5 SET AMERZZZ=AMERZZZ+1
VAR SET AMERDFN=@$SELECT($DATA(AMERDEEP):($EXTRACT("DDDDDD",1,AMERDEEP)_"D0"),$DATA(DD0):"DD0",1:"D0")
SET AMERVAL=Y
IF '$DATA(^DPT(AMERDFN))
DO FAIL
QUIT
+1 SET AMERDOB=$PIECE(^DPT(AMERDFN,0),U,3)
+2 IF AMERDOB=""
DO FAIL
QUIT
+3 IF IOST["C-"
IF AMERZZZ>1
WRITE *13,AMERZZZ
IF AMERXXX
WRITE " (",AMERXXX,")"
+4 IF AMERVAL=""
SET AMERVAL="UNSPECIFIED"
+5 IF $DATA(AMERBIN)
DO ATT
QUIT
REP IF '$DATA(^TMP("AMERAGE",$JOB))
DO SETBIN
+1 SET AMERNN=^TMP("AMERAGE",$JOB)
SET AMERA=""
+2 SET DIOEND="D BLIST^AMERBIN"
+3 IF IOST["C-"
WRITE !!!!,"CRUNCH, CRUNCH....",!!
+4 KILL ^TMP("AMERBIN",$JOB)
+5 FOR I=1:1
SET AMERX=$PIECE(AMERNN,";",I)
IF AMERX=""
QUIT
DO SETA
+6 SET AMERBIN=AMERA
+7 FOR I=1:1:$LENGTH(AMERA,";")
SET ^TMP("AMERBIN",$JOB,"B",I)=0
+8 DO ATT
+9 QUIT
+10 ;
FAIL SET AMERXXX=AMERXXX+1
+1 IF AMERZZZ>1
WRITE *13,AMERZZZ," (",AMERXXX,")"
+2 QUIT
+3 ;
SETA SET AMERY=$PIECE(AMERX,":")
SET AMERZ=$PIECE(AMERX,":",2)
+1 IF AMERA'=""
SET AMERA=AMERA_";"
+2 SET AMERA=AMERA_(DT+1-(10000*(AMERZ+1)))_":"_(DT-(AMERY*10000))
+3 QUIT
+4 ;
ATT SET AMERA=AMERBIN
+1 FOR I=1:1
SET AMERNN=$PIECE(AMERA,";",I)
IF AMERNN=""
QUIT
SET AMERX=$PIECE(AMERNN,":")
SET AMERY=$PIECE(AMERNN,":",2)
IF AMERDOB'<AMERX
IF AMERDOB'>AMERY
DO SETV
QUIT
+2 QUIT
+3 ;
SETV ;
+1 IF '$DATA(^TMP("AMERBIN",$JOB,"V",AMERVAL))
SET ^(AMERVAL)=0
+2 SET ^TMP("AMERBIN",$JOB,"V",AMERVAL)=^TMP("AMERBIN",$JOB,"V",AMERVAL)+1
+3 SET ^TMP("AMERBIN",$JOB,"B",I)=^TMP("AMERBIN",$JOB,"B",I)+1
+4 IF '$DATA(^TMP("AMERBIN",$JOB,1,AMERVAL,I))
SET ^(I)=0
+5 SET ^TMP("AMERBIN",$JOB,1,AMERVAL,I)=^TMP("AMERBIN",$JOB,1,AMERVAL,I)+1
+6 QUIT
+7 ;
BLIST ; I IOST["C-" R !!,"<>",AMERX#1:DTIME
+1 IF '$DATA(^TMP("AMERAGE",$JOB))
DO SETBIN
+2 DO HEADER
BLVAR ;
+1 SET N=""
+2 SET AMERLINE=""
+3 FOR AMERLINE=1:1
SET I=0
SET N=$ORDER(^TMP("AMERBIN",$JOB,1,N))
IF N=""
QUIT
IF '(AMERLINE#(IOSL-4))
DO PAUSE
IF AMERLINE=999999
QUIT
WRITE !,$EXTRACT(N,1,12)
DO B1
+4 WRITE !!,"TOTAL"
+5 SET (I,AMERZ)=0
FOR J=16:7
SET I=$ORDER(^TMP("AMERBIN",$JOB,"B",I))
IF 'I
QUIT
WRITE ?J,^(I)
SET AMERZ=AMERZ+^(I)
+6 WRITE ?J,AMERZ
+7 IF $DATA(AMERXXX)
IF AMERXXX
WRITE !!,AMERXXX," ENTR",$SELECT(AMERXXX>1:"IES",1:"Y")," NOT INCLUDED BECAUSE OF BAD POINTERS OR LACK OF DOB"
+8 IF IOST'?1"C-".E
WRITE @IOF
DO ^%ZISC
GOTO EXIT
+9 DO ^%ZISC
WRITE !!
SET DIR(0)="E"
SET DIR("A")="<>"
DO ^DIR
SET AMERX=Y
KILL DIR,Y
EXIT KILL ^TMP("AMERBIN",$JOB),^TMP("AMERAGE",$JOB),X,Y,Z,AMERNN,AMERVAL,AMERAV,AMERDFN,AMERDOB,AMERSNA,AMERSNO,A,G,AMERDEEP,AMERZZZ,AMERXXX,AMERLINE,AMERBIN,N
+1 QUIT
+2 ;
B1 ;
+1 FOR J=16:7
Begin DoDot:1
+2 SET I=I+1
IF I>$LENGTH(^TMP("AMERAGE",$JOB),";")
QUIT
+3 WRITE ?J,$SELECT($DATA(^TMP("AMERBIN",$JOB,1,N,I)):^(I),1:".")
+4 IF I+1>$LENGTH(^TMP("AMERAGE",$JOB),";")
WRITE ?(J+7),^TMP("AMERBIN",$JOB,"V",N)
End DoDot:1
+5 QUIT
+6 ;
PAUSE ;
+1 IF IOST["C-"
WRITE !
SET DIR(0)="E"
SET DIR("A")="<>"
DO ^DIR
SET AMERQ=Y
KILL DIR,Y
+2 IF '$TEST!(AMERQ=U)
SET AMERLINE=999999
KILL AMERQ
+3 DO HEADER
+4 QUIT
+5 ;
+1 WRITE !,?35,"AGE GROUPS",!
+2 IF '$DATA(AMERSNA)
SET AMERSNA="ATTRIBUTE"
+3 SET AMERNN=$EXTRACT(AMERSNA,1,12)
IF $LENGTH(AMERNN)<12
SET AMERNN=AMERNN_$JUSTIFY("",12-$LENGTH(AMERNN))
+4 WRITE AMERNN
+5 SET AMERNN=^TMP("AMERAGE",$JOB)
SET AMERI=0
+6 SET AMERJ=""
+7 FOR AMERJ=14:7
SET AMERI=AMERI+1
SET AMERX=$PIECE(AMERNN,";",AMERI)
IF AMERX=""
QUIT
WRITE ?AMERJ,$SELECT($PIECE(AMERX,":")=$PIECE(AMERX,":",2):" ",1:($PIECE(AMERX,":")_"-")),$PIECE(AMERX,":",2)
+8 WRITE ?(AMERJ+2),"TOT"
+9 SET AMERX=""
SET $PIECE(AMERX,"-",80)=""
WRITE !,AMERX
+10 KILL AMERI,AMERJ,AMERX
+11 QUIT
+12 ;
SETBIN SET ^TMP("AMERAGE",$JOB)="0:1;2:4;5:12;13:19;20:39;40:59;60:79;80:199"
+1 QUIT
