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")
Q
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)
Q
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)
Q
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)," ","-"),!
Q
;
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 ;----------
