AMQQRMA ; IHS/CMI/THL - RMAN AGE CATEGORY REPORT ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;-----
RUN D CURR
I $D(AMQQQUIT) G EXIT
S AMQV("OPTION")="AGE"
EXIT K %Y,A,B,C,I,X,Y,Z,N
Q
;
CURR W @IOF
I $D(^AMQQ(8,DUZ(2),3)) S AMQQRMB=^(3) W !!,"CURRENT SET UP"
W !
D LIST
ASK W !,"Do you want to define a new set of age groups"
S %=2
D YN^DICN
I $E(%Y)=U S AMQQQUIT="" G CEXIT
I %=0 W !,"Answering yes will allow you to define a new set of age groups.",! G ASK
I "Nn"'[%Y D NEWAGE
AGIN W !,"Do you want to have ages calculated as of a date other than today's date"
S %=2
D YN^DICN
I %=0 W !,"QMAN will detemine the ages of patients based on the date you enter subsequent",!,"to answering yes to this question.",! G AGIN
I $E(%Y)=U S AMQQQUIT="",AMQQRERF="" G CEXIT
I "Nn"'[%Y D NEWDATE I 1
E S AMQQDTE=DT
I '$G(^AMQQ(8,DUZ(2),3))="" Q
CEXIT K DUOUT,DTOUT
Q
;
NEWDATE ; Get new date
S %DT="AEX"
S %DT("A")="Enter date relative to which age will be calculated: "
D ^%DT
Q:U[X
S AMQQDTE=Y
I Y<0,X]"" G NEWDATE
Q
;
NEWAGE S %=""
S A=-1
W !,"If you exceed 8 groups, the display will wrap...",!!
F N=1:1 D AGE Q:X="" I $D(AMQQQUIT) G EXIT
D CLOSE
I $D(AMQQQUIT) G NEXIT
D LIST
NEXIT K X,Y,Z,%,I,L,A
Q
;
AGE W !,"Enter the starting age of the ",$S(%="":"first",1:"next")," age group: "
R X:DTIME I '$T S X=U
I X=U S AMQQQUIT="" Q
I X="" Q
I X?1."?" D HELP G AGE
I X?1.3N,X>A D SET Q
W " ??",*7
G AGE
;
SET S A=X
I %="" S %=X Q
S %=%_":"_(X-1)_";"_X
Q
;
CLOSE I %="" Q
GC W !,"Enter the highest age for the last group: "
R X:DTIME I '$T S X=U
I X=U S AMQQQUIT="" Q
I X?1."?" D HELP G GC
I X="" S X=199
I X>199 S X=199
I X?1.3N,X'<A S %=%_":"_X,^AMQQ(8,DUZ(2),3)=%,AMQQRMB=% Q
W " ??",*7
G GC
;
HELP W !,"Enter an age between 0 and 199. Ages must be entered in ascending order.",!
Q
;
LIST I $G(^AMQQ(8,DUZ(2),3))="" W !!,"At the present time, no set of age groups is on file",!! Q
W !,"AGE GROUPS =>",!
S %=^AMQQ(8,DUZ(2),3)
F I=1:1 S X=$P(%,";",I) Q:X="" W !,$P(X,":"),$S($P(X,":",2)=199:"+",1:" - ") I $P(X,":",2)'=199 W $P(X,":",2)
W !!
Q
;
BUCKET ; ENTRY POINT FROM AMQQCMPL
D VAR
I $D(AMQQQUIT) Q
D DEV
I $D(AMQQQUIT) Q
I '$D(AMQQRMA)!('$D(AMQQRMB)) S AMQQQUIT="" Q
S AMQQRMFL="^AMQQRMA1"
I $D(IO("Q")) D AGETASK Q
U IO D AGERUN D ^%ZISC
Q
;
VAR K ^UTILITY("AMQQ",$J,"AGE")
F X=0:0 S X=$O(^UTILITY("AMQQ",$J,"VAR NAME",X)) Q:'X S Y=+^(X) D V1
I '$D(^UTILITY("AMQQ",$J,"AGE")) S %="" G VARQ
S (%,Z)="" F I=1:1 S Z=$O(^UTILITY("AMQQ",$J,"AGE",1,Z)) Q:Z="" S C=^(Z) D V2
VARQ ;
D CLIN
W !!,"Subtotaling Options:"
W !!,"You now have the option of choosing an attribute such as Sex, Community,"
W !,"or Tribe that will allow subtotaling (i.e. cross-tabulation) of your"
W !,"Age Distribution Report. You may only select one attribute to subtotal by,"
W !,"and that attribute must have been included in your search logic in order to"
W !,"be one of your choices below. If you have not used any demographic attributes"
W !,"in your search, you will have no subtotaling option and will see only the"
W !,"choices 'None, Help, and Exit.' When you have only those choices, choose None"
W !,"and you will get your Age Distribution Report with no subtotaling.",!
K AMQQBUCV,AMQQBUCC,AMQQTMPM,AMQQCNTP
S DIR(0)="SO^"_$S(%="":%,1:(%_";"))_"8:NONE;9:HELP;0:EXIT"
S DIR("B")="NONE"
S DIR("A")=$C(10)_" Your choice"
S DIR("?")="Select an option or type '??' for instructions"
S DIR("??")="AMQQAGE"
D ^DIR
K DIR
I $G(DUOUT)+$G(DTOUT)+'Y K DTOUT,DIRUT,DUOUT S AMQQQUIT="",AMQQOPT("SPEC")="" K AMQQPCE Q
I Y<8,$D(AMQQPCE(Y)) S Y=AMQQPCE(Y)
I Y<8 S AMQQRMA=^UTILITY("AMQQ",$J,"AGE",2,Y)
I Y=8 S AMQQRMA=""
I Y=9 S XQH="AMQQAGE" D EN^XQH G VAR
K A,B,C,X,Y,Z,%,^UTILITY("AMQQ",$J,"AGE")
Q
;
CLIN ;
NEW AMQQI,AMQQNCHK,AMQQDFN
F AMQQI=1:1 Q:'$D(^UTILITY("AMQQ",$J,"Q",AMQQI)) S AMQQDFN=$O(^AMQQ(5,"B",$P(^(AMQQI),U,2),"")) I AMQQDFN,^UTILITY("AMQQ",$J,"Q",AMQQI)'["EXISTS",$P(^AMQQ(5,AMQQDFN,0),U,19)="C" S AMQQNCHK="" Q
Q:$D(AMQQNCHK)
S AMQQBUCC=0
F AMQQPCE=1:1 Q:$P(%,";",AMQQPCE)="" S AMQQBUCV=$P($P(%,";",AMQQPCE),":",2) I AMQQBUCV]"" S AMQQBUCV=$O(^AMQQ(5,"B",AMQQBUCV,"")) I AMQQBUCV D
.I $P(^AMQQ(5,AMQQBUCV,0),U,19)="C" D
..S AMQQBUCC="C"
..S $P(%,";",AMQQPCE)=""
I AMQQBUCC="C",AMQQPCE>2 D
.S AMQQTMP=""
.S AMQQCNTP=0
.F AMQQPCE=1:1:10 I $P(%,";",AMQQPCE)]"" S AMQQCNTP=AMQQCNTP+1,AMQQPCE(AMQQCNTP)=AMQQPCE S AMQQTMP=AMQQTMP_AMQQCNTP_":"_$P($P(%,";",AMQQPCE),":",2)_";"
.S %=AMQQTMP
.I $E(%,$L(AMQQTMP))=";" S %=$E(%,1,($L(%)-1))
Q
;
V1 F %=0:0 S %=$O(^UTILITY("AMQQ",$J,"Q",%)) Q:'% I +^(%)=Y S Y=^(%) Q
I '% Q
S A=$P(Y,U,2)
S B=$P(Y,U,3)
S C=+Y
S C=$G(^AMQQ(1,C,4,1,1))
I A=""!(B="") Q
I "SLG"'[B Q
Q:$D(^UTILITY("AMQQ",$J,"AGE",1,A)) S ^(A)=X_";"_C_";"_A
Q
;
V2 I %'="" S %=%_";"
S %=%_I_":"_Z
S ^UTILITY("AMQQ",$J,"AGE",2,I)=C
Q
;
DEV W !
S %ZIS="Q"
S %ZIS("B")=""
D ^%ZIS
S AMQQIOP=IO
I POP K POP S AMQQQUIT="" Q
D PRINT^AMQQSEC E W " <= Not a secure device!!",*7 G DEV
I $D(IO("Q")),IO=IO(0) W !!,"You can not queue a job to a slave printer..Try again",!!,*7 G DEV
Q
;
AGETASK S ZTRTN="AGERUN^AMQQRMA"
S ZTIO=ION
S ZTDTH="NOW"
S ZTDESC="QUERY UTILITY AGE DISTRIBUTION UTILITY"
F I=1:1 S %=$P("AMQQRM*;AMQV(;AMQQ200(;AMQQRV;AMQQNV;AMQQDTE;AMQQXV;^UTILITY(""AMQQ"",$J,;^UTILITY(""AMQQ RAND"",$J,;^UTILITY(""AMQQ TAX"",$J,",";",I) Q:%="" S ZTSAVE(%)=""
D ^%ZTLOAD
D ^%ZISC
W !!,$S($D(ZTSK):"Request queued!",1:"Request cancelled!"),!!!
H 3
W @IOF
Q
;
AGERUN I IOST'["P" W @IOF
X AMQV(0)
D PRINT^AMQQRMA1
I IOST["P-" W @IOF
I $D(ZTQUEUED) D EXIT2^AMQQKILL S ZTREQ="@"
Q
;
AMQQRMA ; IHS/CMI/THL - RMAN AGE CATEGORY REPORT ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;-----
RUN DO CURR
+1 IF $DATA(AMQQQUIT)
GOTO EXIT
+2 SET AMQV("OPTION")="AGE"
EXIT KILL %Y,A,B,C,I,X,Y,Z,N
+1 QUIT
+2 ;
CURR WRITE @IOF
+1 IF $DATA(^AMQQ(8,DUZ(2),3))
SET AMQQRMB=^(3)
WRITE !!,"CURRENT SET UP"
+2 WRITE !
+3 DO LIST
ASK WRITE !,"Do you want to define a new set of age groups"
+1 SET %=2
+2 DO YN^DICN
+3 IF $EXTRACT(%Y)=U
SET AMQQQUIT=""
GOTO CEXIT
+4 IF %=0
WRITE !,"Answering yes will allow you to define a new set of age groups.",!
GOTO ASK
+5 IF "Nn"'[%Y
DO NEWAGE
AGIN WRITE !,"Do you want to have ages calculated as of a date other than today's date"
+1 SET %=2
+2 DO YN^DICN
+3 IF %=0
WRITE !,"QMAN will detemine the ages of patients based on the date you enter subsequent",!,"to answering yes to this question.",!
GOTO AGIN
+4 IF $EXTRACT(%Y)=U
SET AMQQQUIT=""
SET AMQQRERF=""
GOTO CEXIT
+5 IF "Nn"'[%Y
DO NEWDATE
IF 1
+6 IF '$TEST
SET AMQQDTE=DT
+7 IF '$GET(^AMQQ(8,DUZ(2),3))=""
QUIT
CEXIT KILL DUOUT,DTOUT
+1 QUIT
+2 ;
NEWDATE ; Get new date
+1 SET %DT="AEX"
+2 SET %DT("A")="Enter date relative to which age will be calculated: "
+3 DO ^%DT
+4 IF U[X
QUIT
+5 SET AMQQDTE=Y
+6 IF Y<0
IF X]""
GOTO NEWDATE
+7 QUIT
+8 ;
NEWAGE SET %=""
+1 SET A=-1
+2 WRITE !,"If you exceed 8 groups, the display will wrap...",!!
+3 FOR N=1:1
DO AGE
IF X=""
QUIT
IF $DATA(AMQQQUIT)
GOTO EXIT
+4 DO CLOSE
+5 IF $DATA(AMQQQUIT)
GOTO NEXIT
+6 DO LIST
NEXIT KILL X,Y,Z,%,I,L,A
+1 QUIT
+2 ;
AGE WRITE !,"Enter the starting age of the ",$SELECT(%="":"first",1:"next")," age group: "
+1 READ X:DTIME
IF '$TEST
SET X=U
+2 IF X=U
SET AMQQQUIT=""
QUIT
+3 IF X=""
QUIT
+4 IF X?1."?"
DO HELP
GOTO AGE
+5 IF X?1.3N
IF X>A
DO SET
QUIT
+6 WRITE " ??",*7
+7 GOTO AGE
+8 ;
SET SET A=X
+1 IF %=""
SET %=X
QUIT
+2 SET %=%_":"_(X-1)_";"_X
+3 QUIT
+4 ;
CLOSE IF %=""
QUIT
GC WRITE !,"Enter the highest age for the last group: "
+1 READ X:DTIME
IF '$TEST
SET X=U
+2 IF X=U
SET AMQQQUIT=""
QUIT
+3 IF X?1."?"
DO HELP
GOTO GC
+4 IF X=""
SET X=199
+5 IF X>199
SET X=199
+6 IF X?1.3N
IF X'<A
SET %=%_":"_X
SET ^AMQQ(8,DUZ(2),3)=%
SET AMQQRMB=%
QUIT
+7 WRITE " ??",*7
+8 GOTO GC
+9 ;
HELP WRITE !,"Enter an age between 0 and 199. Ages must be entered in ascending order.",!
+1 QUIT
+2 ;
LIST IF $GET(^AMQQ(8,DUZ(2),3))=""
WRITE !!,"At the present time, no set of age groups is on file",!!
QUIT
+1 WRITE !,"AGE GROUPS =>",!
+2 SET %=^AMQQ(8,DUZ(2),3)
+3 FOR I=1:1
SET X=$PIECE(%,";",I)
IF X=""
QUIT
WRITE !,$PIECE(X,":"),$SELECT($PIECE(X,":",2)=199:"+",1:" - ")
IF $PIECE(X,":",2)'=199
WRITE $PIECE(X,":",2)
+4 WRITE !!
+5 QUIT
+6 ;
BUCKET ; ENTRY POINT FROM AMQQCMPL
+1 DO VAR
+2 IF $DATA(AMQQQUIT)
QUIT
+3 DO DEV
+4 IF $DATA(AMQQQUIT)
QUIT
+5 IF '$DATA(AMQQRMA)!('$DATA(AMQQRMB))
SET AMQQQUIT=""
QUIT
+6 SET AMQQRMFL="^AMQQRMA1"
+7 IF $DATA(IO("Q"))
DO AGETASK
QUIT
+8 USE IO
DO AGERUN
DO ^%ZISC
+9 QUIT
+10 ;
VAR KILL ^UTILITY("AMQQ",$JOB,"AGE")
+1 FOR X=0:0
SET X=$ORDER(^UTILITY("AMQQ",$JOB,"VAR NAME",X))
IF 'X
QUIT
SET Y=+^(X)
DO V1
+2 IF '$DATA(^UTILITY("AMQQ",$JOB,"AGE"))
SET %=""
GOTO VARQ
+3 SET (%,Z)=""
FOR I=1:1
SET Z=$ORDER(^UTILITY("AMQQ",$JOB,"AGE",1,Z))
IF Z=""
QUIT
SET C=^(Z)
DO V2
VARQ ;
+1 DO CLIN
+2 WRITE !!,"Subtotaling Options:"
+3 WRITE !!,"You now have the option of choosing an attribute such as Sex, Community,"
+4 WRITE !,"or Tribe that will allow subtotaling (i.e. cross-tabulation) of your"
+5 WRITE !,"Age Distribution Report. You may only select one attribute to subtotal by,"
+6 WRITE !,"and that attribute must have been included in your search logic in order to"
+7 WRITE !,"be one of your choices below. If you have not used any demographic attributes"
+8 WRITE !,"in your search, you will have no subtotaling option and will see only the"
+9 WRITE !,"choices 'None, Help, and Exit.' When you have only those choices, choose None"
+10 WRITE !,"and you will get your Age Distribution Report with no subtotaling.",!
+11 KILL AMQQBUCV,AMQQBUCC,AMQQTMPM,AMQQCNTP
+12 SET DIR(0)="SO^"_$SELECT(%="":%,1:(%_";"))_"8:NONE;9:HELP;0:EXIT"
+13 SET DIR("B")="NONE"
+14 SET DIR("A")=$CHAR(10)_" Your choice"
+15 SET DIR("?")="Select an option or type '??' for instructions"
+16 SET DIR("??")="AMQQAGE"
+17 DO ^DIR
+18 KILL DIR
+19 IF $GET(DUOUT)+$GET(DTOUT)+'Y
KILL DTOUT,DIRUT,DUOUT
SET AMQQQUIT=""
SET AMQQOPT("SPEC")=""
KILL AMQQPCE
QUIT
+20 IF Y<8
IF $DATA(AMQQPCE(Y))
SET Y=AMQQPCE(Y)
+21 IF Y<8
SET AMQQRMA=^UTILITY("AMQQ",$JOB,"AGE",2,Y)
+22 IF Y=8
SET AMQQRMA=""
+23 IF Y=9
SET XQH="AMQQAGE"
DO EN^XQH
GOTO VAR
+24 KILL A,B,C,X,Y,Z,%,^UTILITY("AMQQ",$JOB,"AGE")
+25 QUIT
+26 ;
CLIN ;
+1 NEW AMQQI,AMQQNCHK,AMQQDFN
+2 FOR AMQQI=1:1
IF '$DATA(^UTILITY("AMQQ",$JOB,"Q",AMQQI))
QUIT
SET AMQQDFN=$ORDER(^AMQQ(5,"B",$PIECE(^(AMQQI),U,2),""))
IF AMQQDFN
IF ^UTILITY("AMQQ",$JOB,"Q",AMQQI)'["EXISTS"
IF $PIECE(^AMQQ(5,AMQQDFN,0),U,19)="C"
SET AMQQNCHK=""
QUIT
+3 IF $DATA(AMQQNCHK)
QUIT
+4 SET AMQQBUCC=0
+5 FOR AMQQPCE=1:1
IF $PIECE(%,";",AMQQPCE)=""
QUIT
SET AMQQBUCV=$PIECE($PIECE(%,";",AMQQPCE),":",2)
IF AMQQBUCV]""
SET AMQQBUCV=$ORDER(^AMQQ(5,"B",AMQQBUCV,""))
IF AMQQBUCV
Begin DoDot:1
+6 IF $PIECE(^AMQQ(5,AMQQBUCV,0),U,19)="C"
Begin DoDot:2
+7 SET AMQQBUCC="C"
+8 SET $PIECE(%,";",AMQQPCE)=""
End DoDot:2
End DoDot:1
+9 IF AMQQBUCC="C"
IF AMQQPCE>2
Begin DoDot:1
+10 SET AMQQTMP=""
+11 SET AMQQCNTP=0
+12 FOR AMQQPCE=1:1:10
IF $PIECE(%,";",AMQQPCE)]""
SET AMQQCNTP=AMQQCNTP+1
SET AMQQPCE(AMQQCNTP)=AMQQPCE
SET AMQQTMP=AMQQTMP_AMQQCNTP_":"_$PIECE($PIECE(%,";",AMQQPCE),":",2)_";"
+13 SET %=AMQQTMP
+14 IF $EXTRACT(%,$LENGTH(AMQQTMP))=";"
SET %=$EXTRACT(%,1,($LENGTH(%)-1))
End DoDot:1
+15 QUIT
+16 ;
V1 FOR %=0:0
SET %=$ORDER(^UTILITY("AMQQ",$JOB,"Q",%))
IF '%
QUIT
IF +^(%)=Y
SET Y=^(%)
QUIT
+1 IF '%
QUIT
+2 SET A=$PIECE(Y,U,2)
+3 SET B=$PIECE(Y,U,3)
+4 SET C=+Y
+5 SET C=$GET(^AMQQ(1,C,4,1,1))
+6 IF A=""!(B="")
QUIT
+7 IF "SLG"'[B
QUIT
+8 IF $DATA(^UTILITY("AMQQ",$JOB,"AGE",1,A))
QUIT
SET ^(A)=X_";"_C_";"_A
+9 QUIT
+10 ;
V2 IF %'=""
SET %=%_";"
+1 SET %=%_I_":"_Z
+2 SET ^UTILITY("AMQQ",$JOB,"AGE",2,I)=C
+3 QUIT
+4 ;
DEV WRITE !
+1 SET %ZIS="Q"
+2 SET %ZIS("B")=""
+3 DO ^%ZIS
+4 SET AMQQIOP=IO
+5 IF POP
KILL POP
SET AMQQQUIT=""
QUIT
+6 DO PRINT^AMQQSEC
IF '$TEST
WRITE " <= Not a secure device!!",*7
GOTO DEV
+7 IF $DATA(IO("Q"))
IF IO=IO(0)
WRITE !!,"You can not queue a job to a slave printer..Try again",!!,*7
GOTO DEV
+8 QUIT
+9 ;
AGETASK SET ZTRTN="AGERUN^AMQQRMA"
+1 SET ZTIO=ION
+2 SET ZTDTH="NOW"
+3 SET ZTDESC="QUERY UTILITY AGE DISTRIBUTION UTILITY"
+4 FOR I=1:1
SET %=$PIECE("AMQQRM*;AMQV(;AMQQ200(;AMQQRV;AMQQNV;AMQQDTE;AMQQXV;^UTILITY(""AMQQ"",$J,;^UTILITY(""AMQQ RAND"",$J,;^UTILITY(""AMQQ TAX"",$J,",";",I)
IF %=""
QUIT
SET ZTSAVE(%)=""
+5 DO ^%ZTLOAD
+6 DO ^%ZISC
+7 WRITE !!,$SELECT($DATA(ZTSK):"Request queued!",1:"Request cancelled!"),!!!
+8 HANG 3
+9 WRITE @IOF
+10 QUIT
+11 ;
AGERUN IF IOST'["P"
WRITE @IOF
+1 XECUTE AMQV(0)
+2 DO PRINT^AMQQRMA1
+3 IF IOST["P-"
WRITE @IOF
+4 IF $DATA(ZTQUEUED)
DO EXIT2^AMQQKILL
SET ZTREQ="@"
+5 QUIT
+6 ;
