Routine: APCLHDD

APCLHDD ; IHS/CMI/LAB - hospital discharge list ;

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

 ;This report replaces the old fileman HDD report

 W:$D(IOF) @IOF W !!?20,"LISTING OF HOSPITAL DISCHARGES BY DATE AND LOCATION",!!

 W "This report is for direct services only, contract health discharges are not"

 W !,"included.",!!

GETDATES ;

BD ;get beginning date

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

 I $D(DIRUT) G END

 S APCLBD=Y

ED ;get ending date

 W ! S DIR(0)="DA^"_APCLBD_":DT:EP",DIR("A")="Enter ending Discharge Date:  " S Y=APCLBD D DD^%DT S 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

LOC ;

 S DIR(0)="YO",DIR("A")="Include DISCHARGES from ALL Locations",DIR("?")="If you wish to include visits from ALL locations answer Yes.  If you wish to tabulate for only one location of encounter enter NO." D ^DIR K DIR

 G:$D(DIRUT) BD

 I Y=1 S APCLLOC="" G ZIS

LOC1 ;enter location

 S DIC("A")="Which Location: ",DIC="^AUTTLOC(",DIC(0)="AEMQ" D ^DIC K DIC,DA G:Y<0 LOC

 S APCLLOC=+Y

ZIS ;

DEMO ;

 D DEMOCHK^APCLUTL(.APCLDEMO)

 I APCLDEMO=-1 G LOC

 S XBRC="PROC^APCLHDD",XBRP="PRINT^APCLHDD",XBNS="APCL",XBRX="END^APCLHDD"

 D ^XBDBQUE

END ;EP

 D EN^XBVK("APCL")

PROC ;EP

 S APCLJOB=$J,APCLBT=$H

 D XTMP^APCLOSUT("APCLHDD","PCC DISCHARGES")

 S APCLDDT=APCLBD-.0001

 F  S APCLDDT=$O(^AUPNVINP("B",APCLDDT)) Q:APCLDDT=""!($P(APCLDDT,".")>APCLED)  D

 .S APCLHDFN=0 F  S APCLHDFN=$O(^AUPNVINP("B",APCLDDT,APCLHDFN)) Q:APCLHDFN'=+APCLHDFN  D

 ..Q:'$D(^AUPNVINP(APCLHDFN,0))

 ..S APCLVDFN=$P(^AUPNVINP(APCLHDFN,0),U,3)

 ..Q:'APCLVDFN

 ..Q:'$D(^AUPNVSIT(APCLVDFN,0))

 ..Q:$P(^AUPNVSIT(APCLVDFN,0),U,11)

 ..Q:$P(^AUPNVSIT(APCLVDFN,0),U,7)'="H"

 ..I APCLLOC,$P(^AUPNVSIT(APCLVDFN,0),U,6)'=APCLLOC Q  ;not location of interest

 ..S APCLVLOC=$P(^AUPNVSIT(APCLVDFN,0),U,6),DFN=$P(^AUPNVSIT(APCLVDFN,0),U,5)  Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))

 ..S APCLNAME=$P(^DPT(DFN,0),U)

 ..S ^XTMP("APCLHDD",APCLJOB,APCLBT,APCLVLOC,APCLDDT,APCLVDFN)=APCLNAME_U_$$HRN^AUPNPAT(DFN,DUZ(2))_U_$$DATE($P($P(^AUPNVSIT(APCLVDFN,0),U),"."))_U_$$DATE($P($P(^AUPNVINP(APCLHDFN,0),U),"."))_U_$$VAL^XBDIQ1(9000010.02,APCLHDFN,.05)

DATE(D) ;

 Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))

PRINT ;EP

INIT ;initialize variables

 S APCLSTOP="",APCLPAGE=0

 I '$D(^XTMP("APCLHDD",APCLJOB,APCLBT)) D HEAD W !,"No discharges to report."  D END1 Q

 S APCLVLOC=0

 F  S APCLVLOC=$O(^XTMP("APCLHDD",APCLJOB,APCLBT,APCLVLOC)) Q:APCLVLOC=""!(APCLSTOP="^")  D

 .D HEAD

 .W !,"LOCATION: ",$P(^DIC(4,APCLVLOC,0),U)

 .S APCLCNT=0

 .S APCLDDT=0 F  S APCLDDT=$O(^XTMP("APCLHDD",APCLJOB,APCLBT,APCLVLOC,APCLDDT)) Q:APCLDDT=""!(APCLSTOP="^")  D

 ..S APCLVDFN=0 F  S APCLVDFN=$O(^XTMP("APCLHDD",APCLJOB,APCLBT,APCLVLOC,APCLDDT,APCLVDFN)) Q:APCLVDFN'=+APCLVDFN!(APCLSTOP="^")  D

 ...S APCLX=^XTMP("APCLHDD",APCLJOB,APCLBT,APCLVLOC,APCLDDT,APCLVDFN)

 ...I $Y>(IOSL-5) D HEAD Q:APCLSTOP="^"

 ...W !,$E($P(APCLX,U),1,25),?27,$P(APCLX,U,2),?35,$P(APCLX,U,3),?46,$P(APCLX,U,4),?57,$P(APCLX,U,5)

 ...S APCLCNT=APCLCNT+1

 .I APCLSTOP="" W !!,"Total Discharges for ",$P(^DIC(4,APCLVLOC,0),U),":  ",APCLCNT

END1 ;

 K ^XTMP("APCLHDD",APCLJOB,APCLBT)

HEAD I 'APCLPAGE G HEAD1

 I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCLSTOP="^" Q

HEAD1 ;

 S APCLPAGE=APCLPAGE+1

 W:$D(IOF) @IOF,!?11,"*****Confidential Patient Data Covered by Privacy Act*****"

 S X=$P(^DIC(4,DUZ(2),0),"^"),APCLPAGE=APCLPAGE+1

 W !,$P(^VA(200,DUZ,0),"^",2),?(80-$L(X)/2),X,?72,"Page ",APCLPAGE

 W !,$$CTR("HOSPITAL DISCHARGE LISTING BY DISCHARGE DATE")

 W !?23,"for ",$$FMTE^XLFDT(APCLBD)," to ",$$FMTE^XLFDT(APCLED)

 S X=$S(APCLLOC:"Location of Encounter: "_$P(^DIC(4,APCLLOC,0),U),1:"All Locations")

 W !!,"NAME",?27,"HRCN",?35,"ADMIT DATE",?46,"DISCH DATE",?57,"DISCHARGE SERVICE",!

 W $TR($J("",80)," ","-"),!

CTR(X,Y) ;EP - Center X in a field Y wide.

 Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X

 ;----------

APCLHDD   ; IHS/CMI/LAB - hospital discharge list ;

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

 +2       ;This report replaces the old fileman HDD report

 +3       ;

 +4        IF $DATA(IOF)

               WRITE @IOF

           WRITE !!?20,"LISTING OF HOSPITAL DISCHARGES BY DATE AND LOCATION",!!

 +5        WRITE "This report is for direct services only, contract health discharges are not"

 +6        WRITE !,"included.",!!

GETDATES  ;

BD        ;get beginning date

 +1        WRITE !

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

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

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO END

 +3        SET APCLBD=Y

ED        ;get ending date

 +1        WRITE !

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

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

           SET Y=APCLBD

           DO DD^%DT

           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       ;

 +6       ;

LOC       ;

 +1        SET DIR(0)="YO"

           SET DIR("A")="Include DISCHARGES from ALL Locations"

           SET DIR("?")="If you wish to include visits from ALL locations answer Yes.  If you wish to tabulate for only one location of encounter enter NO."

           DO ^DIR

           KILL DIR

 +2        IF $DATA(DIRUT)

               GOTO BD

 +3        IF Y=1

               SET APCLLOC=""

               GOTO ZIS

LOC1      ;enter location

 +1        SET DIC("A")="Which Location: "

           SET DIC="^AUTTLOC("

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC,DA

           IF Y<0

               GOTO LOC

 +2        SET APCLLOC=+Y

ZIS       ;

DEMO      ;

 +1        DO DEMOCHK^APCLUTL(.APCLDEMO)

 +2        IF APCLDEMO=-1

               GOTO LOC

 +3        SET XBRC="PROC^APCLHDD"

           SET XBRP="PRINT^APCLHDD"

           SET XBNS="APCL"

           SET XBRX="END^APCLHDD"

 +4        DO ^XBDBQUE

END       ;EP

 +1        DO EN^XBVK("APCL")

 +2        QUIT

PROC      ;EP

 +1       ;

 +2        SET APCLJOB=$JOB

           SET APCLBT=$HOROLOG

 +3        DO XTMP^APCLOSUT("APCLHDD","PCC DISCHARGES")

 +4        SET APCLDDT=APCLBD-.0001

 +5        FOR

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

               IF APCLDDT=""!($PIECE(APCLDDT,".")>APCLED)

                   QUIT

               Begin DoDot:1

 +6                SET APCLHDFN=0

FOR

                       SET APCLHDFN=$ORDER(^AUPNVINP("B",APCLDDT,APCLHDFN))

                       IF APCLHDFN'=+APCLHDFN

                           QUIT

                       Begin DoDot:2

 +7                        IF '$DATA(^AUPNVINP(APCLHDFN,0))

                               QUIT

 +8                        SET APCLVDFN=$PIECE(^AUPNVINP(APCLHDFN,0),U,3)

 +9                        IF 'APCLVDFN

                               QUIT

 +10                       IF '$DATA(^AUPNVSIT(APCLVDFN,0))

                               QUIT

 +11                       IF $PIECE(^AUPNVSIT(APCLVDFN,0),U,11)

                               QUIT

 +12                       IF $PIECE(^AUPNVSIT(APCLVDFN,0),U,7)'="H"

                               QUIT

 +13      ;not location of interest

                           IF APCLLOC

                               IF $PIECE(^AUPNVSIT(APCLVDFN,0),U,6)'=APCLLOC

                                   QUIT

 +14                       SET APCLVLOC=$PIECE(^AUPNVSIT(APCLVDFN,0),U,6)

                           SET DFN=$PIECE(^AUPNVSIT(APCLVDFN,0),U,5)

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

                               QUIT

 +15                       SET APCLNAME=$PIECE(^DPT(DFN,0),U)

 +16                       SET ^XTMP("APCLHDD",APCLJOB,APCLBT,APCLVLOC,APCLDDT,APCLVDFN)=APCLNAME_U_$$HRN^AUPNPAT(DFN,DUZ(2))_U_$$DATE($PIECE($PIECE(^AUPNVSIT(APCLVDFN,0),U),"."))_U_$$DATE($PIECE($PIECE(^AUPNVINP(APCLHDFN,0),U),"."))_U_$$VAL^XBDIQ1(900001

0.02,APCLHDFN,.05)

                       End DoDot:2

               End DoDot:1

 +17       QUIT

DATE(D)   ;

 +1        QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_(1700+$EXTRACT(D,1,3))

PRINT     ;EP

INIT      ;initialize variables

 +1        SET APCLSTOP=""

           SET APCLPAGE=0

 +2        IF '$DATA(^XTMP("APCLHDD",APCLJOB,APCLBT))

               DO HEAD

               WRITE !,"No discharges to report."

               DO END1

               QUIT

 +3        SET APCLVLOC=0

 +4        FOR

               SET APCLVLOC=$ORDER(^XTMP("APCLHDD",APCLJOB,APCLBT,APCLVLOC))

               IF APCLVLOC=""!(APCLSTOP="^")

                   QUIT

               Begin DoDot:1

 +5                DO HEAD

 +6                WRITE !,"LOCATION: ",$PIECE(^DIC(4,APCLVLOC,0),U)

 +7                SET APCLCNT=0

 +8                SET APCLDDT=0

FOR

                       SET APCLDDT=$ORDER(^XTMP("APCLHDD",APCLJOB,APCLBT,APCLVLOC,APCLDDT))

                       IF APCLDDT=""!(APCLSTOP="^")

                           QUIT

                       Begin DoDot:2

 +9                        SET APCLVDFN=0

FOR

                               SET APCLVDFN=$ORDER(^XTMP("APCLHDD",APCLJOB,APCLBT,APCLVLOC,APCLDDT,APCLVDFN))

                               IF APCLVDFN'=+APCLVDFN!(APCLSTOP="^")

                                   QUIT

                               Begin DoDot:3

 +10                               SET APCLX=^XTMP("APCLHDD",APCLJOB,APCLBT,APCLVLOC,APCLDDT,APCLVDFN)

 +11                               IF $Y>(IOSL-5)

                                       DO HEAD

                                       IF APCLSTOP="^"

                                           QUIT

 +12                               WRITE !,$EXTRACT($PIECE(APCLX,U),1,25),?27,$PIECE(APCLX,U,2),?35,$PIECE(APCLX,U,3),?46,$PIECE(APCLX,U,4),?57,$PIECE(APCLX,U,5)

 +13                               SET APCLCNT=APCLCNT+1

                               End DoDot:3

                       End DoDot:2

 +14               IF APCLSTOP=""

                       WRITE !!,"Total Discharges for ",$PIECE(^DIC(4,APCLVLOC,0),U),":  ",APCLCNT

               End DoDot:1

END1      ;

 +1        KILL ^XTMP("APCLHDD",APCLJOB,APCLBT)

 +2        QUIT

HEAD       IF 'APCLPAGE

               GOTO HEAD1

 +1        IF $EXTRACT(IOST)="C"

               IF IO=IO(0)

                   WRITE !

                   SET DIR(0)="EO"

                   DO ^DIR

                   KILL DIR

                   IF Y=0!(Y="^")!($DATA(DTOUT))

                       SET APCLSTOP="^"

                       QUIT

HEAD1     ;

 +1        SET APCLPAGE=APCLPAGE+1

 +2        IF $DATA(IOF)

               WRITE @IOF,!?11,"*****Confidential Patient Data Covered by Privacy Act*****"

 +3        SET X=$PIECE(^DIC(4,DUZ(2),0),"^")

           SET APCLPAGE=APCLPAGE+1

 +4        WRITE !,$PIECE(^VA(200,DUZ,0),"^",2),?(80-$LENGTH(X)/2),X,?72,"Page ",APCLPAGE

 +5        WRITE !,$$CTR("HOSPITAL DISCHARGE LISTING BY DISCHARGE DATE")

 +6        WRITE !?23,"for ",$$FMTE^XLFDT(APCLBD)," to ",$$FMTE^XLFDT(APCLED)

 +7        SET X=$SELECT(APCLLOC:"Location of Encounter: "_$PIECE(^DIC(4,APCLLOC,0),U),1:"All Locations")

 +8        WRITE !!,"NAME",?27,"HRCN",?35,"ADMIT DATE",?46,"DISCH DATE",?57,"DISCHARGE SERVICE",!

 +9        WRITE $TRANSLATE($JUSTIFY("",80)," ","-"),!

 +10       QUIT

 +11      ;

CTR(X,Y)  ;EP - Center X in a field Y wide.

 +1        QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X

 +2       ;----------

APCLHDD.m