APCLBIN1 ; IHS/CMI/LAB - MAKES AGE BIN REPORTS ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
I '$D(APCLZZZ) S (APCLZZZ,APCLXXX)=0
S APCLZZZ=APCLZZZ+1
VAR S APCLDFN=@$S($D(APCLDEEP):($E("DDDDDD",1,APCLDEEP)_"D0"),$D(DD0):"DD0",1:"D0"),APCLVAL=Y I '$D(^DPT(APCLDFN)) D FAIL Q
S DOB=$P(^DPT(APCLDFN,0),U,3)
I DOB="" D FAIL Q
I $E(IOST)="C",APCLZZZ>1 W *13,APCLZZZ I APCLXXX W " (",APCLXXX,")"
I APCLVAL="" S APCLVAL="UNSPECIFIED"
I $D(APCLBIN) D ATT Q
REP I '$D(APCLAGEG) D SETBIN
S APCLNN=APCLAGEG,APCLA=""
S DIOEND="D BLIST^APCLBIN1"
I $E(IOST)="C" W !!!!,"CRUNCH, CRUNCH....",!!
K ^TMP("APCLAGE",$J)
F I=1:1 S APCLX=$P(APCLNN,";",I) Q:APCLX="" D SETA
S APCLBIN=APCLA,G="^TMP(""APCLAGE"",$J)"
F I=1:1:$L(APCLA,";") S @G@("B",I)=0
D ATT
Q
;
FAIL S APCLXXX=APCLXXX+1
I APCLZZZ>1 W *13,APCLZZZ," (",APCLXXX,")"
Q
;
SETA S APCLY=$P(APCLX,":"),APCLZ=$P(APCLX,":",2)
I APCLA]"" S APCLA=APCLA_";"
S APCLA=APCLA_(DT+1-(10000*(APCLZ+1)))_":"_(DT-(APCLY*10000))
Q
;
ATT S APCLA=APCLBIN
F I=1:1 S APCLNN=$P(APCLA,";",I) Q:APCLNN="" S APCLX=$P(APCLNN,":"),APCLY=$P(APCLNN,":",2) I DOB'<APCLX,DOB'>APCLY D SETV Q
Q
;
SETV I '$D(@G@("V",APCLVAL)) S ^(APCLVAL)=0
S @G@("V",APCLVAL)=@G@("V",APCLVAL)+1
S @G@("B",I)=@G@("B",I)+1
I '$D(@G@(1,APCLVAL,I)) S ^(I)=0
S @G@(1,APCLVAL,I)=@G@(1,APCLVAL,I)+1
Q
;
BLIST I $E(IOST)="C" W !!,"<>" H 2
;
D HEADER
BLVAR S G="^TMP(""APCLAGE"",$J)",N=""
S APCLLINE=""
F APCLLINE=1:1 S I=0,N=$O(@G@(1,N)) Q:N="" D:'(APCLLINE#(IOSL-8)) PAUSE Q:APCLLINE=999999 W !,$E(N,1,12) D B1
W !!,"TOTAL"
S (I,APCLZ)=0 F J=12:7 S I=$O(@G@("B",I)) Q:'I W ?J,$J(^(I),6) S APCLZ=APCLZ+^(I)
W ?J,$J(APCLZ,6)
I $D(APCLXXX),APCLXXX W !!,APCLXXX," ENTR",$S(APCLXXX>1:"IES",1:"Y")," NOT INCLUDED BECAUSE OF BAD POINTERS OR LACK OF DOB"
I $E(IOST)'?1"C" W:$D(IOF) @IOF D ^%ZISC G EXIT
D ^%ZISC R !!,"<>",APCLX:DTIME
EXIT K ^TMP("APCLAGE",$J),X,Y,Z,APCLNN,APCLVAL,APCLAV,APCLDFN,DOB,APCLSNA,APCLSNO,A,G,APCLDEEP,APCLZZZ,APCLXXX,APCLLINE,APCLBIN,N,APCLAGEG
Q
;
B1 F J=12:7 S I=I+1 Q:I>$L(APCLAGEG,";") W ?J,$J($S($D(@G@(1,N,I)):^(I),1:"."),6) I I+1>$L(APCLAGEG,";") W ?(J+7),$J(@G@("V",N),6) Q
Q
PAUSE I $E(IOST)="C" R !,"<>",APCLQ:DTIME S:'$T!(APCLQ=U) APCLLINE=999999 K APCLQ
D HEADER
Q
;
;W !?35,"AGE GROUPS",!
W ! D HDR^APCLAGE
I '$D(APCLSNA) S APCLSNA="ATTRIBUTE"
S APCLNN=$E(APCLSNA,1,12) I $L(APCLNN)<12 S APCLNN=APCLNN_$J("",12-$L(APCLNN))
W APCLNN
S APCLNN=APCLAGEG,APCLI=0
S APCLJ=""
F APCLJ=14:7 S APCLI=APCLI+1,APCLX=$P(APCLNN,";",APCLI) Q:APCLX="" W ?APCLJ,$S($P(APCLX,":")=$P(APCLX,":",2):" ",1:($P(APCLX,":")_"-")),$P(APCLX,":",2)
W ?(APCLJ+2),"TOT"
S APCLX="",$P(APCLX,"-",80)="" W !,APCLX
K APCLI,APCLJ,APCLX
Q
;
;
SETBIN ;
S APCLAGEG="0:0;1:4;5:14;15:19;20:24;25:44;45:64;65:125"
Q
APCLBIN1 ; IHS/CMI/LAB - MAKES AGE BIN REPORTS ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 IF '$DATA(APCLZZZ)
SET (APCLZZZ,APCLXXX)=0
+3 SET APCLZZZ=APCLZZZ+1
VAR SET APCLDFN=@$SELECT($DATA(APCLDEEP):($EXTRACT("DDDDDD",1,APCLDEEP)_"D0"),$DATA(DD0):"DD0",1:"D0")
SET APCLVAL=Y
IF '$DATA(^DPT(APCLDFN))
DO FAIL
QUIT
+1 SET DOB=$PIECE(^DPT(APCLDFN,0),U,3)
+2 IF DOB=""
DO FAIL
QUIT
+3 IF $EXTRACT(IOST)="C"
IF APCLZZZ>1
WRITE *13,APCLZZZ
IF APCLXXX
WRITE " (",APCLXXX,")"
+4 IF APCLVAL=""
SET APCLVAL="UNSPECIFIED"
+5 IF $DATA(APCLBIN)
DO ATT
QUIT
REP IF '$DATA(APCLAGEG)
DO SETBIN
+1 SET APCLNN=APCLAGEG
SET APCLA=""
+2 SET DIOEND="D BLIST^APCLBIN1"
+3 IF $EXTRACT(IOST)="C"
WRITE !!!!,"CRUNCH, CRUNCH....",!!
+4 KILL ^TMP("APCLAGE",$JOB)
+5 FOR I=1:1
SET APCLX=$PIECE(APCLNN,";",I)
IF APCLX=""
QUIT
DO SETA
+6 SET APCLBIN=APCLA
SET G="^TMP(""APCLAGE"",$J)"
+7 FOR I=1:1:$LENGTH(APCLA,";")
SET @G@("B",I)=0
+8 DO ATT
+9 QUIT
+10 ;
FAIL SET APCLXXX=APCLXXX+1
+1 IF APCLZZZ>1
WRITE *13,APCLZZZ," (",APCLXXX,")"
+2 QUIT
+3 ;
SETA SET APCLY=$PIECE(APCLX,":")
SET APCLZ=$PIECE(APCLX,":",2)
+1 IF APCLA]""
SET APCLA=APCLA_";"
+2 SET APCLA=APCLA_(DT+1-(10000*(APCLZ+1)))_":"_(DT-(APCLY*10000))
+3 QUIT
+4 ;
ATT SET APCLA=APCLBIN
+1 FOR I=1:1
SET APCLNN=$PIECE(APCLA,";",I)
IF APCLNN=""
QUIT
SET APCLX=$PIECE(APCLNN,":")
SET APCLY=$PIECE(APCLNN,":",2)
IF DOB'<APCLX
IF DOB'>APCLY
DO SETV
QUIT
+2 QUIT
+3 ;
SETV IF '$DATA(@G@("V",APCLVAL))
SET ^(APCLVAL)=0
+1 SET @G@("V",APCLVAL)=@G@("V",APCLVAL)+1
+2 SET @G@("B",I)=@G@("B",I)+1
+3 IF '$DATA(@G@(1,APCLVAL,I))
SET ^(I)=0
+4 SET @G@(1,APCLVAL,I)=@G@(1,APCLVAL,I)+1
+5 QUIT
+6 ;
BLIST IF $EXTRACT(IOST)="C"
WRITE !!,"<>"
HANG 2
+1 ;
+2 DO HEADER
BLVAR SET G="^TMP(""APCLAGE"",$J)"
SET N=""
+1 SET APCLLINE=""
+2 FOR APCLLINE=1:1
SET I=0
SET N=$ORDER(@G@(1,N))
IF N=""
QUIT
IF '(APCLLINE#(IOSL-8))
DO PAUSE
IF APCLLINE=999999
QUIT
WRITE !,$EXTRACT(N,1,12)
DO B1
+3 WRITE !!,"TOTAL"
+4 SET (I,APCLZ)=0
FOR J=12:7
SET I=$ORDER(@G@("B",I))
IF 'I
QUIT
WRITE ?J,$JUSTIFY(^(I),6)
SET APCLZ=APCLZ+^(I)
+5 WRITE ?J,$JUSTIFY(APCLZ,6)
+6 IF $DATA(APCLXXX)
IF APCLXXX
WRITE !!,APCLXXX," ENTR",$SELECT(APCLXXX>1:"IES",1:"Y")," NOT INCLUDED BECAUSE OF BAD POINTERS OR LACK OF DOB"
+7 IF $EXTRACT(IOST)'?1"C"
IF $DATA(IOF)
WRITE @IOF
DO ^%ZISC
GOTO EXIT
+8 DO ^%ZISC
READ !!,"<>",APCLX:DTIME
EXIT KILL ^TMP("APCLAGE",$JOB),X,Y,Z,APCLNN,APCLVAL,APCLAV,APCLDFN,DOB,APCLSNA,APCLSNO,A,G,APCLDEEP,APCLZZZ,APCLXXX,APCLLINE,APCLBIN,N,APCLAGEG
+1 QUIT
+2 ;
B1 FOR J=12:7
SET I=I+1
IF I>$LENGTH(APCLAGEG,";")
QUIT
WRITE ?J,$JUSTIFY($SELECT($DATA(@G@(1,N,I)):^(I),1:"."),6)
IF I+1>$LENGTH(APCLAGEG,";")
WRITE ?(J+7),$JUSTIFY(@G@("V",N),6)
QUIT
+1 QUIT
PAUSE IF $EXTRACT(IOST)="C"
READ !,"<>",APCLQ:DTIME
IF '$TEST!(APCLQ=U)
SET APCLLINE=999999
KILL APCLQ
+1 DO HEADER
+2 QUIT
+3 ;
WRITE @IOF
+1 ;W !?35,"AGE GROUPS",!
+2 WRITE !
DO HDR^APCLAGE
+3 IF '$DATA(APCLSNA)
SET APCLSNA="ATTRIBUTE"
+4 SET APCLNN=$EXTRACT(APCLSNA,1,12)
IF $LENGTH(APCLNN)<12
SET APCLNN=APCLNN_$JUSTIFY("",12-$LENGTH(APCLNN))
+5 WRITE APCLNN
+6 SET APCLNN=APCLAGEG
SET APCLI=0
+7 SET APCLJ=""
+8 FOR APCLJ=14:7
SET APCLI=APCLI+1
SET APCLX=$PIECE(APCLNN,";",APCLI)
IF APCLX=""
QUIT
WRITE ?APCLJ,$SELECT($PIECE(APCLX,":")=$PIECE(APCLX,":",2):" ",1:($PIECE(APCLX,":")_"-")),$PIECE(APCLX,":",2)
+9 WRITE ?(APCLJ+2),"TOT"
+10 SET APCLX=""
SET $PIECE(APCLX,"-",80)=""
WRITE !,APCLX
+11 KILL APCLI,APCLJ,APCLX
+12 QUIT
+13 ;
+14 ;
SETBIN ;
+1 SET APCLAGEG="0:0;1:4;5:14;15:19;20:24;25:44;45:64;65:125"
+2 QUIT
