- 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 ;