- 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
