Routine: APCLCH2

APCLCH2 ; IHS/CMI/LAB - DX BY COMMUNITY LOCAL,SECONDARY,TERTIARY ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

START ;

 S APCLJOB=$J,APCLBTH=$H

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

 D XTMP^APCLOSUT("APCLCH2","PCC - DX TALLY")

 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,DA 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("APCLCH2",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

CHECK ;check each community entry for existence of facility identification

 K APCLQUIT

 W !!,"Checking community table for required items..."

 S (APCLX,C)=0 F  S APCLX=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"COMMUNITIES",APCLX)) Q:APCLX'=+APCLX!($D(APCLQUIT))  D

 .S (L,S,T)=0 S:'$P(^AUTTCOM(APCLX,0),U,15) L=1

 .I '$P(^AUTTCOM(APCLX,0),U,16) S S=1

 .I '$P(^AUTTCOM(APCLX,0),U,17) S T=1

 .I 'L,'S,'T Q

 .S C=C+1

 .I $Y>(IOSL-2) D PAUSE Q:$D(APCLQUIT)

 .W !,$P(^AUTTCOM(APCLX,0),U)," is missing "

 .W "facility identification in the community table."

 I 'C  W !,"ALL are okay.",!!,"Be sure to utilize a printer with 132 margin print capability.",! G ZIS

CHECK1 ;

 W !!,"Since some of the community entries are missing data, I cannot continue.",!,"See your site manager about fixing the community entries.",!,"You may now select other communities or exit the report.",! G COMM

ZIS ;

DEMO ;

 D DEMOCHK^APCLUTL(.APCLDEMO)

 I APCLDEMO=-1 G COMM

 W !! S XBRP="^APCLCH2P",XBRC="^APCLCH21",XBNS="APCL",XBRX="XIT^APCLCH2"

 D ^XBDBQUE

 D XIT

PAUSE ;

 S DIR(0)="E",DIR("A")="Press return to continue or '^' to quit" D ^DIR K DIR,DA

 S:$D(DIRUT) APCLQUIT=1

 W:$D(IOF) @IOF

XIT ;

 K APCLQUIT,APCLCOMT,APCLBD,APCLED,APCLDFN,APCLSD,APCLX,APCLY,APCLER,APCL1,APCL2,APCL3,APCLBDO,APCLBT,APCLBTH,APCLC,APCLCOM,APCLCOMI,APCLLOC,APCLTYPE

 K APCLDX,APCLEDO,APCLET,APCLF,APCLI,APCLJOB,APCLLFAC,APCLP,APCLPG,APCLSFAC,APCLSU,APCLSUF,APCLTFAC,APCLV,APCLVCNT,APCLVLOC

 K L,M,S,T,X,X1,X2,Y,Z,B

 D KILL^AUPNPAT

 D ^XBFMK

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("APCLCH2",APCLJOB,APCLBTH,"COMMUNITIES",+Y)=""

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("APCLCH2",APCLJOB,APCLBTH,"COMMUNITIES",X)=""

T ;taxonomy - call qman interface

 K ^XTMP("APCLCH2",APCLJOB,APCLBTH,"COMMUNITIES")

ASK ; Get community name or cohort

 K APCLCOMM

 R:'$D(^XTMP("APCLCH2",APCLJOB,APCLBTH,"COMMUNITIES")) !,"Enter community or [search template name: ",X:DTIME

 R:$D(^XTMP("APCLCH2",APCLJOB,APCLBTH,"COMMUNITIES")) !,"Enter ANOTHER community or [search template name: ",X:DTIME

 I X=""&('$D(^XTMP("APCLCH2",APCLJOB,APCLBTH,"COMMUNITIES"))) S APCLQUIT=1 W !!,$C(7),$C(7),"No communities selected!!",! Q

 Q:X=""

 I "^"[X K ^XTMP("APCLCH2",APCLJOB,APCLBTH,"COMMUNITIES") S APCLQUIT=1 W !!,"Okay - exiting....try again later" Q

 I $E(X)'="[" S APCLCOMM=""

 E  S X=$E(X,2,99)

 I '$D(APCLCOMM) S DIC("S")="I $P(^(0),U,15)=9999999.05"

 S DIC=$S($D(APCLCOMM):"^AUTTCOM(",1:"^ATXAX("),DIC(0)="EQM" D ^DIC K DIC

 I Y=-1 G ASK

 I $D(APCLCOMM) S ^XTMP("APCLCH2",APCLJOB,APCLBTH,"COMMUNITIES",+Y)=""

 E  S X=0 F  S X=$O(^ATXAX(+Y,21,X)) Q:'X  S Z=$P(^ATXAX(+Y,21,X,0),U) I Z]"" S ^XTMP("APCLCH2",APCLJOB,APCLBTH,"COMMUNITIES",$O(^AUTTCOM("B",Z,0)))=""

 K APCLCOMM

 G ASK

INFORM ;tell user what is going on

 W:$D(IOF) @IOF

 W !!?5,"DIAGNOSES BY A COMMUNITY'S LOCAL, SECONDARY AND TERTIARY FACILITIES"

 W !!,"This report will present a tally of all diagnoses for patients in a community",!,"or communities you select.  The report will tally the diagnoses for"

 W !,"the community's local, secondary and tertiary facilities.  Each community's",!,"report will be 2 pages long, 1 page for outpatient diagnoses and 1 for ",!,"inpatient diagnoses.",!!

SET ;EP - ENTRY POINT

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

 .S APCLF=0 F  S APCLF=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLC,APCLF)) Q:APCLF'=+APCLF  D

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

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

 ..S APCL1="OUTCATC",APCL3="OUTCAT" D SET1

 ..S APCL1="INCATC",APCL3="INCAT" D SET1

SET1 ;

 S APCL2="^XTMP(""APCLCH2"",APCLJOB,APCLBTH,""DATA"",APCLC,APCLF,"""_APCL3_""",X)"

 S X="" F  S X=$O(@APCL2) Q:X=""  S %=^(X) S ^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLC,APCLF,APCL1,9999999-%,X)=%

APCLCH2   ; IHS/CMI/LAB - DX BY COMMUNITY LOCAL,SECONDARY,TERTIARY ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;

 +3       ;

START     ;

 +1        SET APCLJOB=$JOB

           SET APCLBTH=$HOROLOG

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

 +3        DO XTMP^APCLOSUT("APCLCH2","PCC - DX TALLY")

 +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,DA

           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("APCLCH2",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

CHECK     ;check each community entry for existence of facility identification

 +1        KILL APCLQUIT

 +2        WRITE !!,"Checking community table for required items..."

 +3        SET (APCLX,C)=0

FOR

               SET APCLX=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"COMMUNITIES",APCLX))

               IF APCLX'=+APCLX!($DATA(APCLQUIT))

                   QUIT

               Begin DoDot:1

 +4                SET (L,S,T)=0

                   IF '$PIECE(^AUTTCOM(APCLX,0),U,15)

                       SET L=1

 +5                IF '$PIECE(^AUTTCOM(APCLX,0),U,16)

                       SET S=1

 +6                IF '$PIECE(^AUTTCOM(APCLX,0),U,17)

                       SET T=1

 +7                IF 'L

                       IF 'S

                           IF 'T

                               QUIT

 +8                SET C=C+1

 +9                IF $Y>(IOSL-2)

                       DO PAUSE

                       IF $DATA(APCLQUIT)

                           QUIT

 +10               WRITE !,$PIECE(^AUTTCOM(APCLX,0),U)," is missing "

 +11               WRITE "facility identification in the community table."

               End DoDot:1

 +12       IF 'C

               WRITE !,"ALL are okay.",!!,"Be sure to utilize a printer with 132 margin print capability.",!

               GOTO ZIS

CHECK1    ;

 +1        WRITE !!,"Since some of the community entries are missing data, I cannot continue.",!,"See your site manager about fixing the community entries.",!,"You may now select other communities or exit the report.",!

           GOTO COMM

ZIS       ;

DEMO      ;

 +1        DO DEMOCHK^APCLUTL(.APCLDEMO)

 +2        IF APCLDEMO=-1

               GOTO COMM

 +3        WRITE !!

           SET XBRP="^APCLCH2P"

           SET XBRC="^APCLCH21"

           SET XBNS="APCL"

           SET XBRX="XIT^APCLCH2"

 +4        DO ^XBDBQUE

 +5        DO XIT

 +6        QUIT

 +7       ;

PAUSE     ;

 +1        SET DIR(0)="E"

           SET DIR("A")="Press return to continue or '^' to quit"

           DO ^DIR

           KILL DIR,DA

 +2        IF $DATA(DIRUT)

               SET APCLQUIT=1

 +3        IF $DATA(IOF)

               WRITE @IOF

 +4        QUIT

XIT       ;

 +1        KILL APCLQUIT,APCLCOMT,APCLBD,APCLED,APCLDFN,APCLSD,APCLX,APCLY,APCLER,APCL1,APCL2,APCL3,APCLBDO,APCLBT,APCLBTH,APCLC,APCLCOM,APCLCOMI,APCLLOC,APCLTYPE

 +2        KILL APCLDX,APCLEDO,APCLET,APCLF,APCLI,APCLJOB,APCLLFAC,APCLP,APCLPG,APCLSFAC,APCLSU,APCLSUF,APCLTFAC,APCLV,APCLVCNT,APCLVLOC

 +3        KILL L,M,S,T,X,X1,X2,Y,Z,B

 +4        DO KILL^AUPNPAT

 +5        DO ^XBFMK

 +6        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("APCLCH2",APCLJOB,APCLBTH,"COMMUNITIES",+Y)=""

 +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("APCLCH2",APCLJOB,APCLBTH,"COMMUNITIES",X)=""

 +2        QUIT

 +3       ;

T         ;taxonomy - call qman interface

 +1        KILL ^XTMP("APCLCH2",APCLJOB,APCLBTH,"COMMUNITIES")

ASK       ; Get community name or cohort

 +1        KILL APCLCOMM

 +2        IF '$DATA(^XTMP("APCLCH2",APCLJOB,APCLBTH,"COMMUNITIES"))

               READ !,"Enter community or [search template name: ",X:DTIME

 +3        IF $DATA(^XTMP("APCLCH2",APCLJOB,APCLBTH,"COMMUNITIES"))

               READ !,"Enter ANOTHER community or [search template name: ",X:DTIME

 +4        IF X=""&('$DATA(^XTMP("APCLCH2",APCLJOB,APCLBTH,"COMMUNITIES")))

               SET APCLQUIT=1

               WRITE !!,$CHAR(7),$CHAR(7),"No communities selected!!",!

               QUIT

 +5        IF X=""

               QUIT

 +6        IF "^"[X

               KILL ^XTMP("APCLCH2",APCLJOB,APCLBTH,"COMMUNITIES")

               SET APCLQUIT=1

               WRITE !!,"Okay - exiting....try again later"

               QUIT

 +7        IF $EXTRACT(X)'="["

               SET APCLCOMM=""

 +8       IF '$TEST

               SET X=$EXTRACT(X,2,99)

 +9        IF '$DATA(APCLCOMM)

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

 +10       SET DIC=$SELECT($DATA(APCLCOMM):"^AUTTCOM(",1:"^ATXAX(")

           SET DIC(0)="EQM"

           DO ^DIC

           KILL DIC

 +11       IF Y=-1

               GOTO ASK

 +12       IF $DATA(APCLCOMM)

               SET ^XTMP("APCLCH2",APCLJOB,APCLBTH,"COMMUNITIES",+Y)=""

 +13      IF '$TEST

               SET X=0

FOR

                   SET X=$ORDER(^ATXAX(+Y,21,X))

                   IF 'X

                       QUIT

                   SET Z=$PIECE(^ATXAX(+Y,21,X,0),U)

                   IF Z]""

                       SET ^XTMP("APCLCH2",APCLJOB,APCLBTH,"COMMUNITIES",$ORDER(^AUTTCOM("B",Z,0)))=""

 +14       KILL APCLCOMM

 +15       GOTO ASK

 +16       QUIT

INFORM    ;tell user what is going on

 +1       ;

 +2        IF $DATA(IOF)

               WRITE @IOF

 +3        WRITE !!?5,"DIAGNOSES BY A COMMUNITY'S LOCAL, SECONDARY AND TERTIARY FACILITIES"

 +4        WRITE !!,"This report will present a tally of all diagnoses for patients in a community",!,"or communities you select.  The report will tally the diagnoses for"

 +5        WRITE !,"the community's local, secondary and tertiary facilities.  Each community's",!,"report will be 2 pages long, 1 page for outpatient diagnoses and 1 for ",!,"inpatient diagnoses.",!!

 +6        QUIT

SET       ;EP - ENTRY POINT

 +1        SET APCLC=""

FOR

               SET APCLC=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLC))

               IF APCLC=""

                   QUIT

               Begin DoDot:1

 +2                SET APCLF=0

FOR

                       SET APCLF=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLC,APCLF))

                       IF APCLF'=+APCLF

                           QUIT

                       Begin DoDot:2

 +3                        SET APCL1="OUTDXC"

                           SET APCL3="OUTDX"

                           DO SET1

 +4                        SET APCL1="INDXC"

                           SET APCL3="INDX"

                           DO SET1

 +5                        SET APCL1="OUTCATC"

                           SET APCL3="OUTCAT"

                           DO SET1

 +6                        SET APCL1="INCATC"

                           SET APCL3="INCAT"

                           DO SET1

                       End DoDot:2

               End DoDot:1

 +7        QUIT

SET1      ;

 +1        SET APCL2="^XTMP(""APCLCH2"",APCLJOB,APCLBTH,""DATA"",APCLC,APCLF,"""_APCL3_""",X)"

 +2        SET X=""

FOR

               SET X=$ORDER(@APCL2)

               IF X=""

                   QUIT

               SET %=^(X)

               SET ^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLC,APCLF,APCL1,9999999-%,X)=%

 +3        QUIT

APCLCH2.m