AMQQRMA1 ; IHS/CMI/THL - MAKES AGE BIN REPORTS ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;-----
I '$D(AMQQBZZZ) S (AMQQBZZZ,AMQQBXXX)=0
S AMQQBZZZ=AMQQBZZZ+1
VAR S AMQQBDFN=AMQP(0)
S AMQQBVAL=AMQP(+AMQQRMA)
I '$D(^DPT(AMQQBDFN)) D FAIL Q
I AMQQRMA="" S AMQQBVAL=""
S AMQQBDOB=$P(^DPT(AMQQBDFN,0),U,3)
I AMQQBDOB="" D FAIL Q
I IOST["C-",AMQQBZZZ>1 W $C(13),AMQQBZZZ I AMQQBXXX W " (",AMQQBXXX,")"
I AMQQBVAL="" S AMQQBVAL="UNSPECIFIED"
I $D(AMQQBBIN) D ATT Q
S AMQQBNN=AMQQRMB
S AMQQBA=""
I IOST["C-" W !!!!,"CRUNCH, CRUNCH....",!!
K ^UTILITY("BIN",$J)
F I=1:1 S AMQQBX=$P(AMQQBNN,";",I) Q:AMQQBX="" D SETA
S AMQQBBIN=AMQQBA
S G="^UTILITY(""AMQQ"",$J,""BIN"")"
F I=1:1:$L(AMQQBA,";") S @G@("B",I)=0
D ATT
Q
;
FAIL S AMQQBXXX=AMQQBXXX+1
I AMQQBZZZ>1 W $C(13),AMQQBZZZ," (",AMQQBXXX,")"
Q
;
SETA S AMQQBY=$P(AMQQBX,":")
S AMQQBZ=$P(AMQQBX,":",2)
I AMQQBA'="" S AMQQBA=AMQQBA_";"
S AMQQBA=AMQQBA_(AMQQDTE+1-(10000*(AMQQBZ+1)))_":"_(AMQQDTE-(AMQQBY*10000))
Q
;
ATT S AMQQBA=AMQQBBIN
F I=1:1 S AMQQBNN=$P(AMQQBA,";",I) Q:AMQQBNN="" S AMQQBX=$P(AMQQBNN,":"),AMQQBY=$P(AMQQBNN,":",2) I AMQQBDOB'<AMQQBX,AMQQBDOB'>AMQQBY D SETV Q
Q
;
SETV S:$G(AMQQBVAL)="" AMQQBVAL="UNSPECIFIED"
I '$D(@G@("V",AMQQBVAL)) S ^(AMQQBVAL)=0
S @G@("V",AMQQBVAL)=@G@("V",AMQQBVAL)+1
S @G@("B",I)=@G@("B",I)+1
I '$D(@G@(1,AMQQBVAL,I)) S ^(I)=0
S @G@(1,AMQQBVAL,I)=@G@(1,AMQQBVAL,I)+1
Q
;
PRINT ; ENTRY POINT
I IOST["P" D
.N AMQQRV,AMQQXV,AMQQNV
.S AMQQXV=""
.S (AMQQNV,AMQQRV)="AMQQXV"
.D COVER^AMQQCMPP
D HEADER
BLVAR S G="^UTILITY(""AMQQ"",$J,""BIN"")"
S N=""
I AMQQRMA="" G TOT
F AMQQBLIN=1:1 S I=0,N=$O(@G@(1,N)) Q:N="" D:'(AMQQBLIN#(IOSL-4)) PAUSE Q:AMQQBLIN=999999 D TRANS,B1
TOT W !!,"TOTAL"
S (I,AMQQBZ)=0
F J=16:7 S I=$O(@G@("B",I)) Q:'I W ?J,^(I) S AMQQBZ=AMQQBZ+^(I)
W ?J,AMQQBZ
I $D(AMQQBXXX),AMQQBXXX W !!,AMQQBXXX," ENTR",$S(AMQQBXXX>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
R !!,"<>",AMQQBX:DTIME
EXIT K ^UTILITY("AMQQ",$J,"BIN"),X,Y,Z,AMQQBNN,AMQQBVAL,AMQQBAV,AMQQBDFN,AMQQBDOB,AMQQBSNA,AMQQBSNO,A,G,AMQQBZZZ,AMQQBXXX,AMQQBLIN,AMQQBBIN,N,AMQQBA,AMQQBX,AMQQBY,AMQQBZ,AMQQRMA,AMQQRMB,AMQQRMFL,%,A,I,J,AMQQDTE
Q
;
B1 F J=16:7 S I=I+1 Q:I>$L(AMQQRMB,";") W ?J,$S($D(@G@(1,N,I)):^(I),1:".") I I+1>$L(AMQQRMB,";") W ?(J+7),@G@("V",N) Q
Q
;
PAUSE I IOST["C-" R !,"<>",AMQQBQ:DTIME S:'$T!(AMQQBQ=U) AMQQBLIN=999999 K AMQQBQ
D HEADER
Q
;
W !,?35,"AGE GROUPS",!
S AMQQBSNA=$P(AMQQRMA,";",3)
I AMQQBSNA="" S AMQQBSNA="ATTRIBUTE"
S AMQQBNN=$E(AMQQBSNA,1,12)
I $L(AMQQBNN)<12 S AMQQBNN=AMQQBNN_$J("",12-$L(AMQQBNN))
W AMQQBNN
S AMQQBNN=AMQQRMB
S AMQQBI=0
S AMQQBJ=""
F AMQQBJ=14:7 S AMQQBI=AMQQBI+1,AMQQBX=$P(AMQQBNN,";",AMQQBI) Q:AMQQBX="" D
.W ?(AMQQBJ+($P(AMQQBX,":",2)=199)),$S($P(AMQQBX,":")=$P(AMQQBX,":",2):" ",1:($P(AMQQBX,":")_$S($P(AMQQBX,":",2)=199:"+",1:"-"))) I $P(AMQQBX,":",2)'=199 W $P(AMQQBX,":",2)
W ?(AMQQBJ+2),"TOT"
S AMQQBX=""
S $P(AMQQBX,"-",80)=""
W !,AMQQBX
K AMQQBI,AMQQBJ,AMQQBX
Q
;
TRANS N X,%
S X=N
S %=$P(AMQQRMA,";",2)
I %="" W !,$E(X,1,12) Q
X %
W !,$E(X,1,12)
Q
;
AMQQRMA1 ; IHS/CMI/THL - MAKES AGE BIN REPORTS ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;-----
+3 IF '$DATA(AMQQBZZZ)
SET (AMQQBZZZ,AMQQBXXX)=0
+4 SET AMQQBZZZ=AMQQBZZZ+1
VAR SET AMQQBDFN=AMQP(0)
+1 SET AMQQBVAL=AMQP(+AMQQRMA)
+2 IF '$DATA(^DPT(AMQQBDFN))
DO FAIL
QUIT
+3 IF AMQQRMA=""
SET AMQQBVAL=""
+4 SET AMQQBDOB=$PIECE(^DPT(AMQQBDFN,0),U,3)
+5 IF AMQQBDOB=""
DO FAIL
QUIT
+6 IF IOST["C-"
IF AMQQBZZZ>1
WRITE $CHAR(13),AMQQBZZZ
IF AMQQBXXX
WRITE " (",AMQQBXXX,")"
+7 IF AMQQBVAL=""
SET AMQQBVAL="UNSPECIFIED"
+8 IF $DATA(AMQQBBIN)
DO ATT
QUIT
+9 SET AMQQBNN=AMQQRMB
+10 SET AMQQBA=""
+11 IF IOST["C-"
WRITE !!!!,"CRUNCH, CRUNCH....",!!
+12 KILL ^UTILITY("BIN",$JOB)
+13 FOR I=1:1
SET AMQQBX=$PIECE(AMQQBNN,";",I)
IF AMQQBX=""
QUIT
DO SETA
+14 SET AMQQBBIN=AMQQBA
+15 SET G="^UTILITY(""AMQQ"",$J,""BIN"")"
+16 FOR I=1:1:$LENGTH(AMQQBA,";")
SET @G@("B",I)=0
+17 DO ATT
+18 QUIT
+19 ;
FAIL SET AMQQBXXX=AMQQBXXX+1
+1 IF AMQQBZZZ>1
WRITE $CHAR(13),AMQQBZZZ," (",AMQQBXXX,")"
+2 QUIT
+3 ;
SETA SET AMQQBY=$PIECE(AMQQBX,":")
+1 SET AMQQBZ=$PIECE(AMQQBX,":",2)
+2 IF AMQQBA'=""
SET AMQQBA=AMQQBA_";"
+3 SET AMQQBA=AMQQBA_(AMQQDTE+1-(10000*(AMQQBZ+1)))_":"_(AMQQDTE-(AMQQBY*10000))
+4 QUIT
+5 ;
ATT SET AMQQBA=AMQQBBIN
+1 FOR I=1:1
SET AMQQBNN=$PIECE(AMQQBA,";",I)
IF AMQQBNN=""
QUIT
SET AMQQBX=$PIECE(AMQQBNN,":")
SET AMQQBY=$PIECE(AMQQBNN,":",2)
IF AMQQBDOB'<AMQQBX
IF AMQQBDOB'>AMQQBY
DO SETV
QUIT
+2 QUIT
+3 ;
SETV IF $GET(AMQQBVAL)=""
SET AMQQBVAL="UNSPECIFIED"
+1 IF '$DATA(@G@("V",AMQQBVAL))
SET ^(AMQQBVAL)=0
+2 SET @G@("V",AMQQBVAL)=@G@("V",AMQQBVAL)+1
+3 SET @G@("B",I)=@G@("B",I)+1
+4 IF '$DATA(@G@(1,AMQQBVAL,I))
SET ^(I)=0
+5 SET @G@(1,AMQQBVAL,I)=@G@(1,AMQQBVAL,I)+1
+6 QUIT
+7 ;
PRINT ; ENTRY POINT
+1 IF IOST["P"
Begin DoDot:1
+2 NEW AMQQRV,AMQQXV,AMQQNV
+3 SET AMQQXV=""
+4 SET (AMQQNV,AMQQRV)="AMQQXV"
+5 DO COVER^AMQQCMPP
End DoDot:1
+6 DO HEADER
BLVAR SET G="^UTILITY(""AMQQ"",$J,""BIN"")"
+1 SET N=""
+2 IF AMQQRMA=""
GOTO TOT
+3 FOR AMQQBLIN=1:1
SET I=0
SET N=$ORDER(@G@(1,N))
IF N=""
QUIT
IF '(AMQQBLIN#(IOSL-4))
DO PAUSE
IF AMQQBLIN=999999
QUIT
DO TRANS
DO B1
TOT WRITE !!,"TOTAL"
+1 SET (I,AMQQBZ)=0
+2 FOR J=16:7
SET I=$ORDER(@G@("B",I))
IF 'I
QUIT
WRITE ?J,^(I)
SET AMQQBZ=AMQQBZ+^(I)
+3 WRITE ?J,AMQQBZ
+4 IF $DATA(AMQQBXXX)
IF AMQQBXXX
WRITE !!,AMQQBXXX," ENTR",$SELECT(AMQQBXXX>1:"IES",1:"Y")," NOT INCLUDED BECAUSE OF BAD POINTERS OR LACK OF DOB"
+5 IF IOST'?1"C-".E
WRITE @IOF
DO ^%ZISC
GOTO EXIT
+6 DO ^%ZISC
+7 READ !!,"<>",AMQQBX:DTIME
EXIT KILL ^UTILITY("AMQQ",$JOB,"BIN"),X,Y,Z,AMQQBNN,AMQQBVAL,AMQQBAV,AMQQBDFN,AMQQBDOB,AMQQBSNA,AMQQBSNO,A,G,AMQQBZZZ,AMQQBXXX,AMQQBLIN,AMQQBBIN,N,AMQQBA,AMQQBX,AMQQBY,AMQQBZ,AMQQRMA,AMQQRMB,AMQQRMFL,%,A,I,J,AMQQDTE
+1 QUIT
+2 ;
B1 FOR J=16:7
SET I=I+1
IF I>$LENGTH(AMQQRMB,";")
QUIT
WRITE ?J,$SELECT($DATA(@G@(1,N,I)):^(I),1:".")
IF I+1>$LENGTH(AMQQRMB,";")
WRITE ?(J+7),@G@("V",N)
QUIT
+1 QUIT
+2 ;
PAUSE IF IOST["C-"
READ !,"<>",AMQQBQ:DTIME
IF '$TEST!(AMQQBQ=U)
SET AMQQBLIN=999999
KILL AMQQBQ
+1 DO HEADER
+2 QUIT
+3 ;
+1 WRITE !,?35,"AGE GROUPS",!
+2 SET AMQQBSNA=$PIECE(AMQQRMA,";",3)
+3 IF AMQQBSNA=""
SET AMQQBSNA="ATTRIBUTE"
+4 SET AMQQBNN=$EXTRACT(AMQQBSNA,1,12)
+5 IF $LENGTH(AMQQBNN)<12
SET AMQQBNN=AMQQBNN_$JUSTIFY("",12-$LENGTH(AMQQBNN))
+6 WRITE AMQQBNN
+7 SET AMQQBNN=AMQQRMB
+8 SET AMQQBI=0
+9 SET AMQQBJ=""
+10 FOR AMQQBJ=14:7
SET AMQQBI=AMQQBI+1
SET AMQQBX=$PIECE(AMQQBNN,";",AMQQBI)
IF AMQQBX=""
QUIT
Begin DoDot:1
+11 WRITE ?(AMQQBJ+($PIECE(AMQQBX,":",2)=199)),$SELECT($PIECE(AMQQBX,":")=$PIECE(AMQQBX,":",2):" ",1:($PIECE(AMQQBX,":")_$SELECT($PIECE(AMQQBX,":",2)=199:"+",1:"-")))
IF $PIECE(AMQQBX,":",2)'=199
WRITE $PIECE(AMQQBX,":",2)
End DoDot:1
+12 WRITE ?(AMQQBJ+2),"TOT"
+13 SET AMQQBX=""
+14 SET $PIECE(AMQQBX,"-",80)=""
+15 WRITE !,AMQQBX
+16 KILL AMQQBI,AMQQBJ,AMQQBX
+17 QUIT
+18 ;
TRANS NEW X,%
+1 SET X=N
+2 SET %=$PIECE(AMQQRMA,";",2)
+3 IF %=""
WRITE !,$EXTRACT(X,1,12)
QUIT
+4 XECUTE %
+5 WRITE !,$EXTRACT(X,1,12)
+6 QUIT
+7 ;
