APCLCH1.m

APCLCH1 ; IHS/CMI/LAB - COMMUNITY HEALTH PROFILE ;

 ;;2.0;IHS PCC SUITE;**2,7**;MAY 14, 2009

 ;

 ;

START ; 

 S APCLJOB=$J,APCLBTH=$H

 K ^XTMP("APCLCH1",APCLJOB,APCLBTH)

 D XTMP^APCLOSUT("APCLCH1","PCC - COMMUNITY HEALTH PROFILE")

 D INFORM

SU S B=$P(^AUTTLOC(DUZ(2),0),U,5) I B S S=$P(^AUTTSU(B,0),U),DIC("A")="Please Identify your Service Unit: "_S_"//"

 S DIC="^AUTTSU(",DIC(0)="AEMQZ" W ! D ^DIC K DIC

 I X="^" G XIT

 I X="" S (APCLSU,APCLSUF)=B G GETDATES

 G:Y=-1 GETDATES

 S (APCLSU,APCLSUF)=+Y

GETDATES ;

BD ;

 W !!,"Enter the time frame of interest.",! S DIR(0)="D^::EP",DIR("A")="Enter Beginning Visit Date",DIR("?")="Enter the beginning visit date for the search." D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 G:$D(DIRUT) XIT

 S APCLBD=Y

ED ;

 S DIR(0)="DA^::EP",DIR("A")="Enter Ending Visit Date:  " D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 G:$D(DIRUT) XIT

 I Y<APCLBD W !,"Ending date must be greater than or equal to beginning date!" G ED

 S APCLED=Y

 S X1=APCLBD,X2=-1 D C^%DTC S APCLSD=X

COMM ;

 S APCLCOMT="" K APCLQUIT,^XTMP("APCLCH1",APCLJOB,APCLBTH,"COMMUNITIES")

 K DIR S DIR(0)="S^O:ONE Particular Community;S:All Communities within the "_$P(^AUTTSU(APCLSU,0),U)_" SERVICE UNIT;T:A TAXONOMY or selected set of Communities"

 S DIR("A")="Enter a code indicating what COMMUNITIES of RESIDENCE are of interest",DIR("B")="O" K DA D ^DIR K DIR,DA

 G:$D(DIRUT) GETDATES

 S APCLCOMT=Y

 D @APCLCOMT

 G:$D(APCLQUIT) COMM

ST ;;template of patients?

 S APCLSEAT=""

 S DIR(0)="S^A:ALL PATIENTS;S:SEARCH TEMPLATE OF PATIENTS",DIR("A")="Include which patients in the tally of diagnoses",DIR("B")="A" KILL DA D ^DIR KILL DIR

 G:$D(DIRUT) COMM

 I Y="A" G ZIS

 S APCLSEAT=""

 ;

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

 I Y=-1 S APCLSEAT="" G ST

 S APCLSEAT=+Y

ZIS ;

DEMO ;

 D DEMOCHK^APCLUTL(.APCLDEMO)

 I APCLDEMO=-1 G COMM

 S XBRP="^APCLCH1P",XBRC="^APCLCH11",XBNS="APCL",XBRX="XIT^APCLCH1"

 D ^XBDBQUE

 Q

 ;

XIT ;

 K APCLQUIT,APCLCOMT,APCLBD,APCLED,APCLDFN,APCLSD,APCLX,APCLY,APCLER,APCL1,APCL2,APCL3,APCL4,APCLAGEP,APCLC,APCLCOMI,APCLLCOM,APCLMDFN,APCLSCOM,APCLSU,APCLSUF,APCLVAL

 D KILL^AUPNPAT

 D ^XBFMK

 Q

O ;one community

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

 I Y=-1 S APCLQUIT="" Q

 S ^XTMP("APCLCH1",APCLJOB,APCLBTH,"COMMUNITIES",$P(^AUTTCOM(+Y,0),U))=""

 Q

S ;all communities within APCLSU su

 S X=0 F  S X=$O(^AUTTCOM(X)) Q:X'=+X  I $P(^AUTTCOM(X,0),U,5)=APCLSU S ^XTMP("APCLCH1",APCLJOB,APCLBTH,"COMMUNITIES",$P(^AUTTCOM(X,0),U))=""

 Q

 ;

T ;taxonomy - call qman interface

 K APCLCOMM

 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" G XIT

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

 I '$D(APCLCOMM) G COMM

 I $D(APCLCOMM("*")) K APCLCOMM,^XTMP("APCLCH1",APCLJOB,APCLBTH,"COMMUNITIES") W !!,$C(7),$C(7),"ALL communities is NOT an option with this report",! G T

 S X="" F  S X=$O(APCLCOMM(X)) Q:X=""  S ^XTMP("APCLCH1",APCLJOB,APCLBTH,"COMMUNITIES",X)=""

 K APCLCOMM

 Q

INFORM ;tell user what is going on

 ;

 W:$D(IOF) @IOF

 W !!?10,"*************  COMMUNITY HEALTH PROFILE  ************"

 W !!,"This report will present a profile of health care for patients who reside in a",!,"community or communities that you select.  You will be asked to enter a date",!,"range and to identify the communities of interest.",!!

 Q

SET ;EP - ENTRY POINT

 S APCLC="" F  S APCLC=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLC)) Q:APCLC=""   D

 .S APCL4="REPORT",APCL1="OUTDXC",APCL3="OUTDX" D SET1

 .S APCL4="REPORT",APCL1="INDXC",APCL3="INDX" D SET1

 .S APCL4="REPORT",APCL1="INJC",APCL3="INJ" D SET1

 .S APCL4="REPORT",APCL1="DENTALC",APCL3="DENT" D SET1

 .S APCL4="REPORT",APCL1="SURG PROCC",APCL3="SURG PROC" D SET1

 D SETSU

 Q

SET1 ;

 S APCL2="^XTMP(""APCLCH1"",APCLJOB,APCLBTH,""RP"","""_APCLC_""","""_APCL4_""","""_APCL3_""",X)"

 S X="" F  S X=$O(@APCL2) Q:X=""  S %=^(X) S ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLC,APCL4,APCL1,9999999-%,X)=%

 Q

SETSU ;

 S APCL4="SU",APCL1="OUTDXC",APCL3="OUTDX" D SETSU1

 S APCL4="SU",APCL1="INDXC",APCL3="INDX" D SETSU1

 S APCL4="SU",APCL1="INJC",APCL3="INJ" D SETSU1

 S APCL4="SU",APCL1="DENTALC",APCL3="DENT" D SETSU1

 S APCL4="SU",APCL1="SURG PROCC",APCL3="SURG PROC" D SETSU1

 Q

SETSU1 ;

 S APCL2="^XTMP(""APCLCH1"",APCLJOB,APCLBTH,"""_APCL4_""","""_APCL3_""",X)"

 S X="" F  S X=$O(@APCL2) Q:X=""  S %=^(X) S ^XTMP("APCLCH1",APCLJOB,APCLBTH,APCL4,APCL1,9999999-%,X)=%

 Q

APCLCH1   ; IHS/CMI/LAB - COMMUNITY HEALTH PROFILE ;

 +1       ;;2.0;IHS PCC SUITE;**2,7**;MAY 14, 2009

 +2       ;

 +3       ;

START     ; 

 +1        SET APCLJOB=$JOB

           SET APCLBTH=$HOROLOG

 +2        KILL ^XTMP("APCLCH1",APCLJOB,APCLBTH)

 +3        DO XTMP^APCLOSUT("APCLCH1","PCC - COMMUNITY HEALTH PROFILE")

 +4        DO INFORM

SU         SET B=$PIECE(^AUTTLOC(DUZ(2),0),U,5)

           IF B

               SET S=$PIECE(^AUTTSU(B,0),U)

               SET DIC("A")="Please Identify your Service Unit: "_S_"//"

 +1        SET DIC="^AUTTSU("

           SET DIC(0)="AEMQZ"

           WRITE !

           DO ^DIC

           KILL DIC

 +2        IF X="^"

               GOTO XIT

 +3        IF X=""

               SET (APCLSU,APCLSUF)=B

               GOTO GETDATES

 +4        IF Y=-1

               GOTO GETDATES

 +5        SET (APCLSU,APCLSUF)=+Y

GETDATES  ;

BD        ;

 +1        WRITE !!,"Enter the time frame of interest.",!

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

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

           SET DIR("?")="Enter the beginning visit date for the search."

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO XIT

 +3        SET APCLBD=Y

ED        ;

 +1        SET DIR(0)="DA^::EP"

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

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO XIT

 +3        IF Y<APCLBD

               WRITE !,"Ending date must be greater than or equal to beginning date!"

               GOTO ED

 +4        SET APCLED=Y

 +5        SET X1=APCLBD

           SET X2=-1

           DO C^%DTC

           SET APCLSD=X

COMM      ;

 +1        SET APCLCOMT=""

           KILL APCLQUIT,^XTMP("APCLCH1",APCLJOB,APCLBTH,"COMMUNITIES")

 +2        KILL DIR

           SET DIR(0)="S^O:ONE Particular Community;S:All Communities within the "_$PIECE(^AUTTSU(APCLSU,0),U)_" SERVICE UNIT;T:A TAXONOMY or selected set of Communities"

 +3        SET DIR("A")="Enter a code indicating what COMMUNITIES of RESIDENCE are of interest"

           SET DIR("B")="O"

           KILL DA

           DO ^DIR

           KILL DIR,DA

 +4        IF $DATA(DIRUT)

               GOTO GETDATES

 +5        SET APCLCOMT=Y

 +6        DO @APCLCOMT

 +7        IF $DATA(APCLQUIT)

               GOTO COMM

ST        ;;template of patients?

 +1        SET APCLSEAT=""

 +2        SET DIR(0)="S^A:ALL PATIENTS;S:SEARCH TEMPLATE OF PATIENTS"

           SET DIR("A")="Include which patients in the tally of diagnoses"

           SET DIR("B")="A"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO COMM

 +4        IF Y="A"

               GOTO ZIS

 +5        SET APCLSEAT=""

 +6       ;

 +7        WRITE !

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

           SET DIC="^DIBT("

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

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC,DA,DR,DICR

 +8        IF Y=-1

               SET APCLSEAT=""

               GOTO ST

 +9        SET APCLSEAT=+Y

ZIS       ;

DEMO      ;

 +1        DO DEMOCHK^APCLUTL(.APCLDEMO)

 +2        IF APCLDEMO=-1

               GOTO COMM

 +3        SET XBRP="^APCLCH1P"

           SET XBRC="^APCLCH11"

           SET XBNS="APCL"

           SET XBRX="XIT^APCLCH1"

 +4        DO ^XBDBQUE

 +5        QUIT 

 +6       ;

XIT       ;

 +1        KILL APCLQUIT,APCLCOMT,APCLBD,APCLED,APCLDFN,APCLSD,APCLX,APCLY,APCLER,APCL1,APCL2,APCL3,APCL4,APCLAGEP,APCLC,APCLCOMI,APCLLCOM,APCLMDFN,APCLSCOM,APCLSU,APCLSUF,APCLVAL

 +2        DO KILL^AUPNPAT

 +3        DO ^XBFMK

 +4        QUIT 

O         ;one community

 +1        SET DIC="^AUTTCOM("

           SET DIC(0)="AEMQ"

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

           DO ^DIC

           KILL DIC

 +2        IF Y=-1

               SET APCLQUIT=""

               QUIT 

 +3        SET ^XTMP("APCLCH1",APCLJOB,APCLBTH,"COMMUNITIES",$PIECE(^AUTTCOM(+Y,0),U))=""

 +4        QUIT 

S         ;all communities within APCLSU su

 +1        SET X=0

           FOR 

               SET X=$ORDER(^AUTTCOM(X))

               IF X'=+X

                   QUIT 

               IF $PIECE(^AUTTCOM(X,0),U,5)=APCLSU

                   SET ^XTMP("APCLCH1",APCLJOB,APCLBTH,"COMMUNITIES",$PIECE(^AUTTCOM(X,0),U))=""

 +2        QUIT 

 +3       ;

T         ;taxonomy - call qman interface

 +1        KILL APCLCOMM

 +2        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"

               GOTO XIT

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

 +4        IF '$DATA(APCLCOMM)

               GOTO COMM

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

               KILL APCLCOMM,^XTMP("APCLCH1",APCLJOB,APCLBTH,"COMMUNITIES")

               WRITE !!,$CHAR(7),$CHAR(7),"ALL communities is NOT an option with this report",!

               GOTO T

 +6        SET X=""

           FOR 

               SET X=$ORDER(APCLCOMM(X))

               IF X=""

                   QUIT 

               SET ^XTMP("APCLCH1",APCLJOB,APCLBTH,"COMMUNITIES",X)=""

 +7        KILL APCLCOMM

 +8        QUIT 

INFORM    ;tell user what is going on

 +1       ;

 +2        IF $DATA(IOF)

               WRITE @IOF

 +3        WRITE !!?10,"*************  COMMUNITY HEALTH PROFILE  ************"

 +4        WRITE !!,"This report will present a profile of health care for patients who reside in a",!,"community or communities that you select.  You will be asked to enter a date",!,"range and to identify the communities of interest.",!!

 +5        QUIT 

SET       ;EP - ENTRY POINT

 +1        SET APCLC=""

           FOR 

               SET APCLC=$ORDER(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLC))

               IF APCLC=""

                   QUIT 

               Begin DoDot:1

 +2                SET APCL4="REPORT"

                   SET APCL1="OUTDXC"

                   SET APCL3="OUTDX"

                   DO SET1

 +3                SET APCL4="REPORT"

                   SET APCL1="INDXC"

                   SET APCL3="INDX"

                   DO SET1

 +4                SET APCL4="REPORT"

                   SET APCL1="INJC"

                   SET APCL3="INJ"

                   DO SET1

 +5                SET APCL4="REPORT"

                   SET APCL1="DENTALC"

                   SET APCL3="DENT"

                   DO SET1

 +6                SET APCL4="REPORT"

                   SET APCL1="SURG PROCC"

                   SET APCL3="SURG PROC"

                   DO SET1

               End DoDot:1

 +7        DO SETSU

 +8        QUIT 

SET1      ;

 +1        SET APCL2="^XTMP(""APCLCH1"",APCLJOB,APCLBTH,""RP"","""_APCLC_""","""_APCL4_""","""_APCL3_""",X)"

 +2        SET X=""

           FOR 

               SET X=$ORDER(@APCL2)

               IF X=""

                   QUIT 

               SET %=^(X)

               SET ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLC,APCL4,APCL1,9999999-%,X)=%

 +3        QUIT 

SETSU     ;

 +1        SET APCL4="SU"

           SET APCL1="OUTDXC"

           SET APCL3="OUTDX"

           DO SETSU1

 +2        SET APCL4="SU"

           SET APCL1="INDXC"

           SET APCL3="INDX"

           DO SETSU1

 +3        SET APCL4="SU"

           SET APCL1="INJC"

           SET APCL3="INJ"

           DO SETSU1

 +4        SET APCL4="SU"

           SET APCL1="DENTALC"

           SET APCL3="DENT"

           DO SETSU1

 +5        SET APCL4="SU"

           SET APCL1="SURG PROCC"

           SET APCL3="SURG PROC"

           DO SETSU1

 +6        QUIT 

SETSU1    ;

 +1        SET APCL2="^XTMP(""APCLCH1"",APCLJOB,APCLBTH,"""_APCL4_""","""_APCL3_""",X)"

 +2        SET X=""

           FOR 

               SET X=$ORDER(@APCL2)

               IF X=""

                   QUIT 

               SET %=^(X)

               SET ^XTMP("APCLCH1",APCLJOB,APCLBTH,APCL4,APCL1,9999999-%,X)=%

 +3        QUIT