Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AMQQRMA

AMQQRMA.m

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