APCLTAX.m

APCLTAX ; IHS/CMI/LAB - REPORT FOR ANMC ;

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

 ;

 ;

INFORM ;

 W:$D(IOF) @IOF

 W !!,?20,"*********HOSPITAL DISCHARGE BY RANGE OF TAXONOMY*******",!

 W !!,?40,"TEMPLATE CREATION",!!

 W !!,"This is a special report written to create a patient search template.",!,"The patients selected will be based on the following criteria:",!,?5,"- living patients with a discharge in a user defined time frame"

 W !?5,"- excluding patients discharged before they were 10 days old",!?5,"- excluding patients whose LOS was less than 1",!?5,"- excluding patients whose primary dx is not in a user selected taxonomy",!

GETDATES ;

BD ;get beginning date

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

 I $D(DIRUT) G XIT

 S APCLBD=Y

ED ;get ending date

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

 I $D(DIRUT) G BD

 S APCLED=Y

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

 ;

TAX ;get icd taxonomy

 S APCLTAX=""

 S DIC="^ATXAX(",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,15)=80",DIC("A")="Enter the Diagnoses Taxonomy: "

 D ^DIC K DIC,DA

 I Y=-1 G BD

 S APCLTAX=+Y

SEARCH ;

 S APCLSRCH=""

 S DIC="^DIBT(",DIC(0)="AELMQZ",DIC("A")="Search Template: ",DIC("DR")="2///"_DT_";4///9000001;5///"_DUZ

 W !

 D ^DIC

 I +Y<1 W !!,"No Search Template selected." G TAX

 I +Y,$D(^DIBT(+Y)) W !!,"An unduplicated patient list resulting from this report will be stored in the",!!?20,"**  ",Y(0,0),"  ** Search Template." K ^DIBT(+Y,1)

 ;

 S APCLSRCH=+Y

DEMO ;

 D DEMOCHK^APCLUTL(.APCLDEMO)

 I APCLDEMO=-1 G SEARCH

GO ;process

 W !!,"OKAY -- HOLD ON WHILE I FIND ALL THE DISCHARGES..."

START ;

 S APCLPCNT=0

 ;

V ; Run by visit date

 S APCLODAT=APCLSD_".9999" F  S APCLODAT=$O(^AUPNVINP("B",APCLODAT)) Q:APCLODAT=""!((APCLODAT\1)>APCLED)  D V1

 ;

 W !!,"ALL DONE - FOUND ",APCLPCNT," PATIENTS.",!

END ;EOJ

 D XIT

 K APCLTAX,APCLSRCH,APCLBD,APCLSD,APCLODAT,APCLED,APCLVSIT,APCLVDFN,APCLP,APCLVREC,APCLFOUN,APCLPCNT,DFN

 Q

V1 ;

 S APCLVDFN="" F  S APCLVDFN=$O(^AUPNVINP("B",APCLODAT,APCLVDFN)) Q:APCLVDFN'=+APCLVDFN  I $D(^AUPNVINP(APCLVDFN,0)) S APCLVREC=^(0) D PROC

 Q

PROC ;

 S DFN=$P(APCLVREC,U,2)

 Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))

 Q:$P($G(^DPT(DFN,.35)),U)]""

 S X2=$P(^DPT(DFN,0),U,3) Q:X2=""  S X1=$P($P(APCLVREC,U),".") D ^%DTC

 Q:X<10  ;QUIT IF LESS THAN 10 DAYS OLD

 S APCLVSIT=$P(APCLVREC,U,3)

 S X1=$P($P(APCLVREC,U),"."),X2=$P($P(^AUPNVSIT(APCLVSIT,0),U),".") D ^%DTC

 Q:X<1

DXHIT ;

 K APCLFOUN,APCLP S APCL1=0 F  S APCL1=$O(^AUPNVPOV("AD",APCLVSIT,APCL1)) Q:APCL1=""  I $P(^AUPNVPOV(APCL1,0),U,4)="P" S APCLP=APCL1

 I '$D(APCLP) S APCLP=$O(^AUPNVPOV("AD",APCLVSIT,0))

 Q:'$D(APCLP)  ;NO POV

 Q:APCLP=""

 Q:'$$ICD^ATXAPI($P(^AUPNVPOV(APCLP,0),U),APCLTAX,9)

 S APCLPCNT=APCLPCNT+1

 S ^DIBT(APCLSRCH,1,DFN)=""

 W "."

 Q

XIT ;

 K APCLSITE,APCLRPT,APCLINFO,APCLSORT,APCLPROC,APCLINF,APCLBD,APCLED,APCLSD,APCLDT,APCLLOC,APCLODAT,APCLVDFN,APCLVLOC,APCLVREC,APCLCLIN,APCLSKIP,APCL1,APCL2,APCLAP,APCLDISC,APCLPPOV,APCLX,APCLHIGH,APCLDATE,APCLPRNT,APCLJOB,APCLAPCC

 K APCLDX,APCLLOW,APCLICD,APCLDA1,APCLDA2,APCLY,APCLTITL,APCL80S,APCLEDD,APCLHD1,APCLHD2,APCLLENG,APCLLOCT,APCLPG,APCLSRT2,APCLTOT,APCLBDD,APCLPROV,APCLSEC,APCLZ,APCLADIS,APCLQUIT,APCLLOCC,APCLBT,APCLBTH

 K APCLJOB,APCLRXCL,APCLOTHC

 K X,X1,X2,IO("Q"),%,Y,POP,DIRUT,ZTSK,ZTQUEUED,H,S,TS,M

 Q

APCLTAX   ; IHS/CMI/LAB - REPORT FOR ANMC ;

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

 +2       ;

 +3       ;

INFORM    ;

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        WRITE !!,?20,"*********HOSPITAL DISCHARGE BY RANGE OF TAXONOMY*******",!

 +3        WRITE !!,?40,"TEMPLATE CREATION",!!

 +4        WRITE !!,"This is a special report written to create a patient search template.",!,"The patients selected will be based on the following criteria:",!,?5,"- living patients with a discharge in a user defined time frame"

 +5        WRITE !?5,"- excluding patients discharged before they were 10 days old",!?5,"- excluding patients whose LOS was less than 1",!?5,"- excluding patients whose primary dx is not in a user selected taxonomy",!

GETDATES  ;

BD        ;get beginning date

 +1        WRITE !

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

           SET DIR("A")="Enter beginning Discharge Date for Search"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO XIT

 +3        SET APCLBD=Y

ED        ;get ending date

 +1        WRITE !

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

           SET DIR("A")="Enter ending Discharge Date for Search"

           SET Y=APCLBD

           DO DD^%DT

           SET DIR("B")=Y

           SET Y=""

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO BD

 +3        SET APCLED=Y

 +4        SET X1=APCLBD

           SET X2=-1

           DO C^%DTC

           SET APCLSD=X

 +5       ;

TAX       ;get icd taxonomy

 +1        SET APCLTAX=""

 +2        SET DIC="^ATXAX("

           SET DIC(0)="AEMQ"

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

           SET DIC("A")="Enter the Diagnoses Taxonomy: "

 +3        DO ^DIC

           KILL DIC,DA

 +4        IF Y=-1

               GOTO BD

 +5        SET APCLTAX=+Y

SEARCH    ;

 +1        SET APCLSRCH=""

 +2        SET DIC="^DIBT("

           SET DIC(0)="AELMQZ"

           SET DIC("A")="Search Template: "

           SET DIC("DR")="2///"_DT_";4///9000001;5///"_DUZ

 +3        WRITE !

 +4        DO ^DIC

 +5        IF +Y<1

               WRITE !!,"No Search Template selected."

               GOTO TAX

 +6        IF +Y

               IF $DATA(^DIBT(+Y))

                   WRITE !!,"An unduplicated patient list resulting from this report will be stored in the",!!?20,"**  ",Y(0,0),"  ** Search Template."

                   KILL ^DIBT(+Y,1)

 +7       ;

 +8        SET APCLSRCH=+Y

DEMO      ;

 +1        DO DEMOCHK^APCLUTL(.APCLDEMO)

 +2        IF APCLDEMO=-1

               GOTO SEARCH

GO        ;process

 +1        WRITE !!,"OKAY -- HOLD ON WHILE I FIND ALL THE DISCHARGES..."

START     ;

 +1        SET APCLPCNT=0

 +2       ;

V         ; Run by visit date

 +1        SET APCLODAT=APCLSD_".9999"

           FOR 

               SET APCLODAT=$ORDER(^AUPNVINP("B",APCLODAT))

               IF APCLODAT=""!((APCLODAT\1)>APCLED)

                   QUIT 

               DO V1

 +2       ;

 +3        WRITE !!,"ALL DONE - FOUND ",APCLPCNT," PATIENTS.",!

END       ;EOJ

 +1        DO XIT

 +2        KILL APCLTAX,APCLSRCH,APCLBD,APCLSD,APCLODAT,APCLED,APCLVSIT,APCLVDFN,APCLP,APCLVREC,APCLFOUN,APCLPCNT,DFN

 +3        QUIT 

V1        ;

 +1        SET APCLVDFN=""

           FOR 

               SET APCLVDFN=$ORDER(^AUPNVINP("B",APCLODAT,APCLVDFN))

               IF APCLVDFN'=+APCLVDFN

                   QUIT 

               IF $DATA(^AUPNVINP(APCLVDFN,0))

                   SET APCLVREC=^(0)

                   DO PROC

 +2        QUIT 

PROC      ;

 +1        SET DFN=$PIECE(APCLVREC,U,2)

 +2        IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))

               QUIT 

 +3        IF $PIECE($GET(^DPT(DFN,.35)),U)]""

               QUIT 

 +4        SET X2=$PIECE(^DPT(DFN,0),U,3)

           IF X2=""

               QUIT 

           SET X1=$PIECE($PIECE(APCLVREC,U),".")

           DO ^%DTC

 +5       ;QUIT IF LESS THAN 10 DAYS OLD

           IF X<10

               QUIT 

 +6        SET APCLVSIT=$PIECE(APCLVREC,U,3)

 +7        SET X1=$PIECE($PIECE(APCLVREC,U),".")

           SET X2=$PIECE($PIECE(^AUPNVSIT(APCLVSIT,0),U),".")

           DO ^%DTC

 +8        IF X<1

               QUIT 

DXHIT     ;

 +1        KILL APCLFOUN,APCLP

           SET APCL1=0

           FOR 

               SET APCL1=$ORDER(^AUPNVPOV("AD",APCLVSIT,APCL1))

               IF APCL1=""

                   QUIT 

               IF $PIECE(^AUPNVPOV(APCL1,0),U,4)="P"

                   SET APCLP=APCL1

 +2        IF '$DATA(APCLP)

               SET APCLP=$ORDER(^AUPNVPOV("AD",APCLVSIT,0))

 +3       ;NO POV

           IF '$DATA(APCLP)

               QUIT 

 +4        IF APCLP=""

               QUIT 

 +5        IF '$$ICD^ATXAPI($PIECE(^AUPNVPOV(APCLP,0),U),APCLTAX,9)

               QUIT 

 +6        SET APCLPCNT=APCLPCNT+1

 +7        SET ^DIBT(APCLSRCH,1,DFN)=""

 +8        WRITE "."

 +9        QUIT 

XIT       ;

 +1        KILL APCLSITE,APCLRPT,APCLINFO,APCLSORT,APCLPROC,APCLINF,APCLBD,APCLED,APCLSD,APCLDT,APCLLOC,APCLODAT,APCLVDFN,APCLVLOC,APCLVREC,APCLCLIN,APCLSKIP,APCL1,APCL2,APCLAP,APCLDISC,APCLPPOV,APCLX,APCLHIGH,APCLDATE,APCLPRNT,APCLJOB,APCLAPCC

 +2        KILL APCLDX,APCLLOW,APCLICD,APCLDA1,APCLDA2,APCLY,APCLTITL,APCL80S,APCLEDD,APCLHD1,APCLHD2,APCLLENG,APCLLOCT,APCLPG,APCLSRT2,APCLTOT,APCLBDD,APCLPROV,APCLSEC,APCLZ,APCLADIS,APCLQUIT,APCLLOCC,APCLBT,APCLBTH

 +3        KILL APCLJOB,APCLRXCL,APCLOTHC

 +4        KILL X,X1,X2,IO("Q"),%,Y,POP,DIRUT,ZTSK,ZTQUEUED,H,S,TS,M

 +5        QUIT