- 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
