APCLBP.m

APCLBP ; IHS/CMI/LAB - AGE BUCKET/DIAGNOSIS REPORT ;

 ;;2.0;IHS PCC SUITE;**10,15**;MAY 14, 2009;Build 11

 ;

 ; If APCLREP (repeat) = 1 then the last tag executed in APCLTAG is

 ; repeated.

 ; If DIRUT = 1 execution starts at the tag in APCLTAG that is the one

 ; before the last one executed.

START ;

 S APCLERR=0,APCLREP=0,APCLTAGS="ASKPT\CMMNTS\CLINIC\DATERNG\AGE\SEX\INDBEN\RTYPE\ZIS"

 W !!?15,"*****  BLOOD PRESSURE OUT OF CONTROL REPORT  *****",!!

 D DESCR

 F APCLI=1:1:$L(APCLTAGS,"\") D @($P(APCLTAGS,"\",APCLI)) Q:APCLERR  Q:$G(Y)="^^"  S:APCLREP APCLREP=0,APCLI=APCLI-1 I $D(DIRUT) Q:APCLI=1  S APCLI=APCLI-2

 D EXIT

 Q

 ;

 ; Ask to search all patients or use a template

ASKPT ;

 S APCLTYPE=""

 S APCLSEAT=""

 K DIR,X,Y

 S DIR(0)="S^S:Search Template of Patients;P:Search All Patients"

 S DIR("A")="   Select List " D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 S APCLTYPE=Y

 D:APCLTYPE="S" TEMPLATE

 Q

 ;

 ; Template was selected

TEMPLATE ;

 ;

 W ! S DIC("S")="I $P(^(0),U,4)=9000001" S DIC="^DIBT(",DIC("A")="Enter Visit SEARCH TEMPLATE name: ",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DICR

 S:$D(DUOUT)!$D(DIRUT) APCLREP=1 S:Y<0 APCLREP=1

 ; If APCLREP = 1 the program will return to ASKPT (the last tag executed in the main for loop)

 I APCLREP K DIRUT,APCLTYPE Q

 S APCLSEAT=+Y

 Q

 ;

 ; Ask for communities

CMMNTS ;

 K APCLCOMM

 S DIR(0)="S^O:One particular Community;A:All Communities;S:Selected Set of Communities (Taxonomy)",DIR("A")="List patients who live in",DIR("B")="O" K DA D ^DIR K DIR

 Q:$D(DIRUT)

 I Y="A" W !!,"Patients from all communities will be included in the report.",! Q

 I Y="O" D  S:'$D(APCLCOMM) APCLREP=1 Q

 .S DIC="^AUTTCOM(",DIC(0)="AEMQ",DIC("A")="Which COMMUNITY: " D ^DIC K DIC

 .Q:Y=-1

 .S APCLCOMM($P(^AUTTCOM(+Y,0),U))=""

 S X="COMMUNITY",DIC="^AMQQ(5,",DIC(0)="FM",DIC("S")="I $P(^(0),U,14)" D ^DIC K DIC,DA I Y=-1 W "OOPS - QMAN NOT CURRENT - QUITTING" S APCLERR=1 Q

 D PEP^AMQQGTX0(+Y,"APCLCOMM(")

 I '$D(APCLCOMM) S APCLREP=1 Q

 I $D(APCLCOMM("*")) K APCLCOMM

 Q

 ;

 ; Ask for Clinic

CLINIC ;

 K APCLCLNT

 W ! S DIR(0)="Y",DIR("A")="Include visits to ALL clinics",DIR("B")="Yes" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 Q:$D(DIRUT)

 Q:Y=1

 S X="CLINIC",DIC="^AMQQ(5,",DIC(0)="FM",DIC("S")="I $P(^(0),U,14)" D ^DIC K DIC,DA I Y=-1 S APCLERR=1 W "OOPS - QMAN NOT CURRENT - QUITTING" Q

 D PEP^AMQQGTX0(+Y,"APCLCLNT(")

 I '$D(APCLCLNT) S APCLREP=1 Q

 I $D(APCLCLNT("*")) K APCLCLNT

 Q

 ;

 ; Ask for date range

DATERNG ;

BD ; Ask starting date

 I $D(DIRUT) S APCLI=APCLI-3 K DIRUT Q  ; temporary line

 S APCLSD=0,APCLED=9999999

 W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter beginning Visit Date" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 Q:$D(DIRUT)

 S APCLBD=Y,APCLSD=9999999-Y

 D ED

 Q

 ;

ED ; ask ending date

 W ! S DIR(0)="DA^"_APCLBD_":DT:EP",DIR("A")="Enter ending Visit Date:  " S Y=APCLBD D DD^%DT S Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 S:$D(DUOUT)!$D(DIRUT) APCLREP=1 S:Y<0 APCLREP=1

 ; If APCLREP = 1 the program will return to BD (the last tag executed in the main for loop)

 I APCLREP K DIRUT,APCLTYPE Q

 S APCLED=9999999-Y

 Q

 ;

AGE ;

 W !

 K APCLAGER

 S DIR(0)="FO^1:7",DIR("A")="Enter a Range of Ages (e.g. 5-12) [HIT RETURN TO INCLUDE ALL RANGES]" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I Y="" W !!,"No age range entered.  All ages will be included." K DIRUT Q

 Q:$D(DIRUT)

 I Y'?1.3N1"-"1.3N W !!,$C(7),$C(7),"Enter an age range in the format nnn-nnn.  E.g. 2-5, 12-74, 5-20." S APCLREP=1 Q

 I $P(Y,"-")<2 W !,$C(7),"Cannot run for patients under 2." S APCLREP=1 Q

 ;I $P(Y,"-",2)>74 W !,$C(7),"Cannot run for patients over 74." S APCLREP=1 Q

 S APCLAGER=Y

 Q

 ;

SEX ;

 S DIR(0)="S^M:Males;F:Females;U:Unknown Gender;B:ALL Genders",DIR("A")="Report should include",DIR("B")="B" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 S APCLSEX=Y

 Q

 ;

INDBEN ;

 W !

 S DIR(0)="Y",DIR("A")="Do you wish to include ONLY Indian/Alaska Native Beneficiaries",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 S APCLIBEN=Y

 Q

 ;

 ; Ask if suppressing identifying information

IDENT ;

 S DIR(0)="S^P:Patient Name;C:Chart #;B:Both;N:Neither",DIR("A")="Do you wish to suppress patient identifying data",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 S:$D(DUOUT)!$D(DIRUT) APCLREP=1 S:Y<0 APCLREP=1

 ; If APCLREP = 1 the program will return to RTYPE (the last tag executed in the main for loop)

 I APCLREP K DIRUT,APCLTYPE Q

 S APCLIDEN=$S(Y="P":1,Y="C":10,Y="B":11,1:0)

 Q

 ;

 ; Ask if Detail or Summary type report

RTYPE ;

 S DIR(0)="S^D:Detail;S:Summary;C:Cohort/Template Save",DIR("A")="Report type should be",DIR("B")="D" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 S APCLRTYP=Y

 Q:APCLRTYP="S"!$D(DIRUT)

 I APCLRTYP="D" D SORT Q

 ; Create a cohort/template

 D ^APCLSTMP

 I X="^^" S Y="^^" Q

 S:$D(DUOUT)!$D(DIRUT) APCLREP=1 S:$G(Y)<0 APCLREP=1

 K:APCLREP DIRUT

 Q

 ;

SORT ;

 S DIR(0)="S^P:Patient Name;A:Age of Patient",DIR("A")="Sort the report by",DIR("B")="P" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 S:$D(DUOUT)!$D(DIRUT) APCLREP=1 S:Y<0 APCLREP=1

 ; If APCLREP = 1 the program will return to RTYPE (the last tag executed in the main for loop)

 I APCLREP K DIRUT,APCLTYPE Q

 S APCLSORT=Y

 W ! D IDENT

 Q

 ;

DESCR ;

 W ?26,"LIST OF BLOOD PRESSURE OUT OF CONTROL PATIENTS"

 W !!,"This report will produce a listing of all patients for the specified age, sex,"

 W !,"communities, clinic and time period, who are considered out of control based on",!,"their mean Systolic or Diastolic blood pressure .",!

 W !,"Out of Control is defined as greater than or equal to 140/90."

 Q

 ;

ZIS ;

DEMO ;

 D DEMOCHK^APCLUTL(.APCLDEMO)

 I APCLDEMO=-1 G RTYPE

 S XBRC="^APCLBP1",XBNS="APCL",XBRX=""

 S XBRP=$S(APCLRTYP'="C":"^APCLBPP",1:"")

 D ^XBDBQUE

 Q

 ;

EXIT ;

 K APCL80,APCLA,APCLAGE,APCLAGER,APCLBD,APCLBHGH,APCLBMI,APCLBPC,APCLBPTY,APCLBPX,APCLBTH,APCLBTYP,APCLCBC,APCLCHT,APCLCLAS,APCLCLIN,APCLCLNC,APCLCMTS,APCLCMTY,APCLCOMM,APCLCPT,APCLCTB,APCLDT,APCLDTL,APCLED

 K APCLEDD,APCLER,APCLERR,APCLI,APCLIBEN,APCLIDEN,APCLJOB,APCLLENG,APCLMDBP,APCLMGI,APCLMHT,APCLMIEN,APCLMSBP,APCLMWT,APCLNAME,APCLOCTL,APCLPCT,APCLPG,APCLPTOT,APCLQUIT,APCLREF,APCLREP,APCLROHT,APCLROWT,APCLRPT

 K APCLRTYP,APCLSD,APCLSDD,APCLSEAT,APCLSEX,APCLSEXP,APCLSORT,APCLSRT,APCLTAGS,APCLTBP,APCLTDBP,APCLTOBC,APCLTOBP,APCLTOP,APCLTPOC,APCLTPT,APCLTSBP,APCLTYPE,APCLX,APCLY,DA,DFN,DIC,DIR,DIRUT,J,K,M,R,S,X,X1

 K X2,XBNS,XBRC,XBRP,XBRX,Y

 Q

APCLBP    ; IHS/CMI/LAB - AGE BUCKET/DIAGNOSIS REPORT ;

 +1       ;;2.0;IHS PCC SUITE;**10,15**;MAY 14, 2009;Build 11

 +2       ;

 +3       ; If APCLREP (repeat) = 1 then the last tag executed in APCLTAG is

 +4       ; repeated.

 +5       ; If DIRUT = 1 execution starts at the tag in APCLTAG that is the one

 +6       ; before the last one executed.

START     ;

 +1        SET APCLERR=0

           SET APCLREP=0

           SET APCLTAGS="ASKPT\CMMNTS\CLINIC\DATERNG\AGE\SEX\INDBEN\RTYPE\ZIS"

 +2        WRITE !!?15,"*****  BLOOD PRESSURE OUT OF CONTROL REPORT  *****",!!

 +3        DO DESCR

 +4        FOR APCLI=1:1:$LENGTH(APCLTAGS,"\")

               DO @($PIECE(APCLTAGS,"\",APCLI))

               IF APCLERR

                   QUIT 

               IF $GET(Y)="^^"

                   QUIT 

               IF APCLREP

                   SET APCLREP=0

                   SET APCLI=APCLI-1

               IF $DATA(DIRUT)

                   IF APCLI=1

                       QUIT 

                   SET APCLI=APCLI-2

 +5        DO EXIT

 +6        QUIT 

 +7       ;

 +8       ; Ask to search all patients or use a template

ASKPT     ;

 +1        SET APCLTYPE=""

 +2        SET APCLSEAT=""

 +3        KILL DIR,X,Y

 +4        SET DIR(0)="S^S:Search Template of Patients;P:Search All Patients"

 +5        SET DIR("A")="   Select List "

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +6        SET APCLTYPE=Y

 +7        IF APCLTYPE="S"

               DO TEMPLATE

 +8        QUIT 

 +9       ;

 +10      ; Template was selected

TEMPLATE  ;

 +1       ;

 +2        WRITE !

           SET DIC("S")="I $P(^(0),U,4)=9000001"

           SET DIC="^DIBT("

           SET DIC("A")="Enter Visit SEARCH TEMPLATE name: "

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC,DA,DR,DICR

 +3        IF $DATA(DUOUT)!$DATA(DIRUT)

               SET APCLREP=1

           IF Y<0

               SET APCLREP=1

 +4       ; If APCLREP = 1 the program will return to ASKPT (the last tag executed in the main for loop)

 +5        IF APCLREP

               KILL DIRUT,APCLTYPE

               QUIT 

 +6        SET APCLSEAT=+Y

 +7        QUIT 

 +8       ;

 +9       ; Ask for communities

CMMNTS    ;

 +1        KILL APCLCOMM

 +2        SET DIR(0)="S^O:One particular Community;A:All Communities;S:Selected Set of Communities (Taxonomy)"

           SET DIR("A")="List patients who live in"

           SET DIR("B")="O"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               QUIT 

 +4        IF Y="A"

               WRITE !!,"Patients from all communities will be included in the report.",!

               QUIT 

 +5        IF Y="O"

               Begin DoDot:1

 +6                SET DIC="^AUTTCOM("

                   SET DIC(0)="AEMQ"

                   SET DIC("A")="Which COMMUNITY: "

                   DO ^DIC

                   KILL DIC

 +7                IF Y=-1

                       QUIT 

 +8                SET APCLCOMM($PIECE(^AUTTCOM(+Y,0),U))=""

               End DoDot:1

               IF '$DATA(APCLCOMM)

                   SET APCLREP=1

               QUIT 

 +9        SET X="COMMUNITY"

           SET DIC="^AMQQ(5,"

           SET DIC(0)="FM"

           SET DIC("S")="I $P(^(0),U,14)"

           DO ^DIC

           KILL DIC,DA

           IF Y=-1

               WRITE "OOPS - QMAN NOT CURRENT - QUITTING"

               SET APCLERR=1

               QUIT 

 +10       DO PEP^AMQQGTX0(+Y,"APCLCOMM(")

 +11       IF '$DATA(APCLCOMM)

               SET APCLREP=1

               QUIT 

 +12       IF $DATA(APCLCOMM("*"))

               KILL APCLCOMM

 +13       QUIT 

 +14      ;

 +15      ; Ask for Clinic

CLINIC    ;

 +1        KILL APCLCLNT

 +2        WRITE !

           SET DIR(0)="Y"

           SET DIR("A")="Include visits to ALL clinics"

           SET DIR("B")="Yes"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +3        IF $DATA(DIRUT)

               QUIT 

 +4        IF Y=1

               QUIT 

 +5        SET X="CLINIC"

           SET DIC="^AMQQ(5,"

           SET DIC(0)="FM"

           SET DIC("S")="I $P(^(0),U,14)"

           DO ^DIC

           KILL DIC,DA

           IF Y=-1

               SET APCLERR=1

               WRITE "OOPS - QMAN NOT CURRENT - QUITTING"

               QUIT 

 +6        DO PEP^AMQQGTX0(+Y,"APCLCLNT(")

 +7        IF '$DATA(APCLCLNT)

               SET APCLREP=1

               QUIT 

 +8        IF $DATA(APCLCLNT("*"))

               KILL APCLCLNT

 +9        QUIT 

 +10      ;

 +11      ; Ask for date range

DATERNG   ;

BD        ; Ask starting date

 +1       ; temporary line

           IF $DATA(DIRUT)

               SET APCLI=APCLI-3

               KILL DIRUT

               QUIT 

 +2        SET APCLSD=0

           SET APCLED=9999999

 +3        WRITE !

           SET DIR(0)="D^:DT:EP"

           SET DIR("A")="Enter beginning Visit Date"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +4        IF $DATA(DIRUT)

               QUIT 

 +5        SET APCLBD=Y

           SET APCLSD=9999999-Y

 +6        DO ED

 +7        QUIT 

 +8       ;

ED        ; ask ending date

 +1        WRITE !

           SET DIR(0)="DA^"_APCLBD_":DT:EP"

           SET DIR("A")="Enter ending Visit Date:  "

           SET Y=APCLBD

           DO DD^%DT

           SET Y=""

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DUOUT)!$DATA(DIRUT)

               SET APCLREP=1

           IF Y<0

               SET APCLREP=1

 +3       ; If APCLREP = 1 the program will return to BD (the last tag executed in the main for loop)

 +4        IF APCLREP

               KILL DIRUT,APCLTYPE

               QUIT 

 +5        SET APCLED=9999999-Y

 +6        QUIT 

 +7       ;

AGE       ;

 +1        WRITE !

 +2        KILL APCLAGER

 +3        SET DIR(0)="FO^1:7"

           SET DIR("A")="Enter a Range of Ages (e.g. 5-12) [HIT RETURN TO INCLUDE ALL RANGES]"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +4        IF Y=""

               WRITE !!,"No age range entered.  All ages will be included."

               KILL DIRUT

               QUIT 

 +5        IF $DATA(DIRUT)

               QUIT 

 +6        IF Y'?1.3N1"-"1.3N

               WRITE !!,$CHAR(7),$CHAR(7),"Enter an age range in the format nnn-nnn.  E.g. 2-5, 12-74, 5-20."

               SET APCLREP=1

               QUIT 

 +7        IF $PIECE(Y,"-")<2

               WRITE !,$CHAR(7),"Cannot run for patients under 2."

               SET APCLREP=1

               QUIT 

 +8       ;I $P(Y,"-",2)>74 W !,$C(7),"Cannot run for patients over 74." S APCLREP=1 Q

 +9        SET APCLAGER=Y

 +10       QUIT 

 +11      ;

SEX       ;

 +1        SET DIR(0)="S^M:Males;F:Females;U:Unknown Gender;B:ALL Genders"

           SET DIR("A")="Report should include"

           SET DIR("B")="B"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        SET APCLSEX=Y

 +3        QUIT 

 +4       ;

INDBEN    ;

 +1        WRITE !

 +2        SET DIR(0)="Y"

           SET DIR("A")="Do you wish to include ONLY Indian/Alaska Native Beneficiaries"

           SET DIR("B")="N"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +3        SET APCLIBEN=Y

 +4        QUIT 

 +5       ;

 +6       ; Ask if suppressing identifying information

IDENT     ;

 +1        SET DIR(0)="S^P:Patient Name;C:Chart #;B:Both;N:Neither"

           SET DIR("A")="Do you wish to suppress patient identifying data"

           SET DIR("B")="N"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DUOUT)!$DATA(DIRUT)

               SET APCLREP=1

           IF Y<0

               SET APCLREP=1

 +3       ; If APCLREP = 1 the program will return to RTYPE (the last tag executed in the main for loop)

 +4        IF APCLREP

               KILL DIRUT,APCLTYPE

               QUIT 

 +5        SET APCLIDEN=$SELECT(Y="P":1,Y="C":10,Y="B":11,1:0)

 +6        QUIT 

 +7       ;

 +8       ; Ask if Detail or Summary type report

RTYPE     ;

 +1        SET DIR(0)="S^D:Detail;S:Summary;C:Cohort/Template Save"

           SET DIR("A")="Report type should be"

           SET DIR("B")="D"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        SET APCLRTYP=Y

 +3        IF APCLRTYP="S"!$DATA(DIRUT)

               QUIT 

 +4        IF APCLRTYP="D"

               DO SORT

               QUIT 

 +5       ; Create a cohort/template

 +6        DO ^APCLSTMP

 +7        IF X="^^"

               SET Y="^^"

               QUIT 

 +8        IF $DATA(DUOUT)!$DATA(DIRUT)

               SET APCLREP=1

           IF $GET(Y)<0

               SET APCLREP=1

 +9        IF APCLREP

               KILL DIRUT

 +10       QUIT 

 +11      ;

SORT      ;

 +1        SET DIR(0)="S^P:Patient Name;A:Age of Patient"

           SET DIR("A")="Sort the report by"

           SET DIR("B")="P"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DUOUT)!$DATA(DIRUT)

               SET APCLREP=1

           IF Y<0

               SET APCLREP=1

 +3       ; If APCLREP = 1 the program will return to RTYPE (the last tag executed in the main for loop)

 +4        IF APCLREP

               KILL DIRUT,APCLTYPE

               QUIT 

 +5        SET APCLSORT=Y

 +6        WRITE !

           DO IDENT

 +7        QUIT 

 +8       ;

DESCR     ;

 +1        WRITE ?26,"LIST OF BLOOD PRESSURE OUT OF CONTROL PATIENTS"

 +2        WRITE !!,"This report will produce a listing of all patients for the specified age, sex,"

 +3        WRITE !,"communities, clinic and time period, who are considered out of control based on",!,"their mean Systolic or Diastolic blood pressure .",!

 +4        WRITE !,"Out of Control is defined as greater than or equal to 140/90."

 +5        QUIT 

 +6       ;

ZIS       ;

DEMO      ;

 +1        DO DEMOCHK^APCLUTL(.APCLDEMO)

 +2        IF APCLDEMO=-1

               GOTO RTYPE

 +3        SET XBRC="^APCLBP1"

           SET XBNS="APCL"

           SET XBRX=""

 +4        SET XBRP=$SELECT(APCLRTYP'="C":"^APCLBPP",1:"")

 +5        DO ^XBDBQUE

 +6        QUIT 

 +7       ;

EXIT      ;

 +1        KILL APCL80,APCLA,APCLAGE,APCLAGER,APCLBD,APCLBHGH,APCLBMI,APCLBPC,APCLBPTY,APCLBPX,APCLBTH,APCLBTYP,APCLCBC,APCLCHT,APCLCLAS,APCLCLIN,APCLCLNC,APCLCMTS,APCLCMTY,APCLCOMM,APCLCPT,APCLCTB,APCLDT,APCLDTL,APCLED

 +2        KILL APCLEDD,APCLER,APCLERR,APCLI,APCLIBEN,APCLIDEN,APCLJOB,APCLLENG,APCLMDBP,APCLMGI,APCLMHT,APCLMIEN,APCLMSBP,APCLMWT,APCLNAME,APCLOCTL,APCLPCT,APCLPG,APCLPTOT,APCLQUIT,APCLREF,APCLREP,APCLROHT,APCLROWT,APCLRPT

 +3        KILL APCLRTYP,APCLSD,APCLSDD,APCLSEAT,APCLSEX,APCLSEXP,APCLSORT,APCLSRT,APCLTAGS,APCLTBP,APCLTDBP,APCLTOBC,APCLTOBP,APCLTOP,APCLTPOC,APCLTPT,APCLTSBP,APCLTYPE,APCLX,APCLY,DA,DFN,DIC,DIR,DIRUT,J,K,M,R,S,X,X1

 +4        KILL X2,XBNS,XBRC,XBRP,XBRX,Y

 +5        QUIT