DVBAB56 ;ALB/SPH - CAPRI READMISSION REPORT ; 3/22/12 8:34am
 ;;2.7;AMIE;**35,149,179**;Apr 10, 1995;Build 15
 ;Per VHA Directive 2004-038, this routine should not be modified.
 ;
 ;Input: ZMSG      - Output Array for Re-Admission report (By Ref)
 ;       BDATE     - Beginning date for eport (FM Format)
 ;       EDATE     - Ending date for report (FM Format)
 ;       DVBAH     - Specifies Hospital (H) or DOM (D)
 ;       DVBADLMTR - Indicates if report should be delimitted (Optional)
 ;                    CAPRI currently executes RPC by each day in
 ;                    date range, so DVBADLMTR should equal the
 ;                    final EDATE in range so that XTMP global
 ;                    can be killed.
 ;Output: ^TMP("DVBAR",$J) contains delimited/non-delimited re-admission report
STRT(ZMSG,BDATE,EDATE,DVBAH,DVBADLMTR)    ;
 
DVBAFNLDTE,SORTDT
 
DVBAFNLDTE=$S(+$G(DVBADLMTR):+$P(DVBADLMTR,"."),1:0)
 
DVBADLMTR=$S('+$G(DVBADLMTR):"",1:"^")
 
DVBABCNT=0
 
TERM
SORT 
RCV^DVBAVDPT I $D(RONUM),$D(ROQ:CFLOC'=RONUM&(RO="Y")
 
RCVAA ^TMP("DVBA",$J,"A&A",DFN)=DVBADT
 
RCVPEN ^TMP("DVBA",$J,"PEN",DFN)=DVBADT
 
Q
 
;
DCHGDT (LADMDT,LDCHGDT)="",DCHPTR=$P(^DGPM(VY,0),U,17),LADMDT=$P(^(0),U,1) DCHPTR]"",$D(^DGPM(+DCHPTR,0)) LDCHGDT=$P(^DGPM(+DCHPTR,0),U,1)
 
Q
 
;
CAL I="",ZI=1 DVBAI=0:0 I=$O(^DGPM("APID",DFN,I)) Q:I=""  J=0:0 J=$O(^DGPM("APID",DFN,I,J)) Q:J=""  ZJ=$S($D(^DGPM(J,0)):^(0),1:""I $P(ZJ,U,1)'>EDATE,$P(ZJ,U,2)=1 ^TMP("DVBA",$J,"ADM",DFN,ZI,J)="",ZI=ZI+1
 
VX=$O(^TMP("DVBA",$J,"ADM",DFN,1,0)) Q:VX=""  CURADMDT=$P(^DGPM(VX,0),U,1) Q:CURADMDT=""
 
VX=1:1 VX=$O(^TMP("DVBA",$J,"ADM",DFN,VX)) Q:VX=""  VY=0:0 VY=$O(^TMP("DVBA",$J,"ADM",DFN,VX,VY)) Q:VY=""  DCHGDT CURADMDT["."&(LADMDT["."SET
 
Q
TDIS TDIS=$S($D(^DGPM(+DCHPTR,0)):$P(^(0),U,18),1:""Q:TDIS=""
 
S:'$D(^DG(405.2,+TDIS,0)) TDIS="Unknown discharge type" I $D(^(0)) TDIS=$S($P(^DG(405.2,+TDIS,0),U,1)]"":$P(^(0),U,1),1:"Unknown discharge type")
 
Q
 
;
SET X1=CURADMDT,X2=LDCHGDT ^%DTC Q:X>185
 
X2=LADMDT,X1=LDCHGDT ^%DTC LOS=Q:LOS'>HOSPDAYS
 
DVBAT="A&A" DO  ;**Check last admission for A&A vet
 
.ADMDT=LADMDT
 
.ADM^DVBAVDPT,TDIS
 
.TDIS["IRREGULAR" DO  ;**Irregular discharge, set last admis info
 
..^TMP("DVBA",DVBAT,$J,SORTDT,XCN,CFLOC,VY,DFN,"LADM")=LADMDT_U_TDIS
 
I $D(TDIS),(TDIS'["IRREGULAR"&(DVBAT="A&A")) Q  ;**Quit
 
ADMDT=CURADMDT
 
ADM^DVBAVDPT,TDIS
 
; **Set current admis info
 
^TMP("DVBA",DVBAT,$J,SORTDT,XCN,CFLOC,VY,DFN)=CURADMDT_U_RCVAA_U_RCVPEN_U_CNUM_U_TDIS
 
DVBAT="PEN" DO  ;**Set last admis info for Pension vet
 
.ADMDT=LADMDT
 
.ADM^DVBAVDPT,TDIS
 
.^TMP("DVBA",DVBAT,$J,SORTDT,XCN,CFLOC,VY,DFN,"LADM")=LADMDT_U_TDIS
 
DVBARADQ
 
(VX,VY)=9999999
 
Q
 
;
TERM ;D HOME^%ZIS 
 
^TMP("DVBA",$J),^TMP("DVBA","PEN",$J),^TMP("DVBA","A&A",$J),NOASK
 
;D NOPARM^DVBAUTL2 G:$D(DVBAQUIT) KILL^DVBAUTIL
 ;
SETUP ;W @IOF,!,"VARO RE-ADMISSION REPORT" 
 
DTAR=^DVB(396.1,1,0),FDT(0)=$$FMTE^XLFDT(DT,"5DZ")
 
HEAD="RE-ADMISSION REPORT",HEAD1="FOR "_$P(DTAR,U,1)_" ON "_FDT(0)
 
;W !,HEAD1
EN1 ;W !!,"Please enter admission dates for search, oldest date first,",!,"most recent date last.",!!,"Last report was run on " S Y=$P(DTAR,U,7) X ^DD("DD") W Y,!!
 ;D DATE^DVBAUTIL G:Y<0 KILL^DVBAUTIL
 
BDATE1=BDATE+.5,HEADDT="Date range: "_$$FMTE^XLFDT(BDATE1,"5DZ")_" to "_$$FMTE^XLFDT(EDATE,"5DZ")
 
;
ASK ;W !!,"Do you want (H)ospital or Hospital-(D)om   H// " R DVBAH:DTIME G:'$T!(DVBAH=U) KILL^DVBAUTIL
 
DVBAH="" DVBAH="H" DVBAH
 
S:DVBAH="d" DVBAH="D"
 
S:DVBAH="h" DVBAH="H"
 
DVBAH'?1"H"&(DVBAH'?1"D"*7,!!,"Must be H for HOSPITAL or D for HOSPITAL-DOM",!! ASK
 
HEAD=HEAD_" ("_$S(DVBAH="H":"Hospital",DVBAH="D":"Hospital-Dom",1:"Unknown selection")_")"
 
Z=$S(DVBAH="D":1,DVBAH="H":2,1:0) W $P("Dom^Hospital",U,Z),!!
 
;S %ZIS("B")="0;P-OTHER",%ZIS("A")="Printing device: ",%ZIS="AEQ" D ^%ZIS G:POP KILL^DVBAUTIL
 
I $D(IO("Q")) I="NOASK","HEAD*","FDT(0)","DTAR","BDATE*","EDATE*","DVBAH" ZTSAVE(I)=""
 
I  S NOASK=1,ZTRTN="DQ^DVBARADM",ZTDESC="AMIE Re-admission Report",ZTIO=ION ^%ZTLOAD W:$D(ZTSK) !,"Request queued.",!! KILL^DVBAUTIL
GO '$D(NOASK!!,"Looking for Pension and A&A cases ...",!!
 
DVBADT=BDATE:0 DVBADT=$O(^DGPM("AMV1",DVBADT)) Q:DVBADT=""!(DVBADT>EDATE)  W:'$D(NOASK"." DFN=0:0 DFN=$O(^DGPM("AMV1",DVBADT,DFN)) Q:DFN=""  ADM=0:0 ADM=$O(^DGPM("AMV1",DVBADT,DFN,ADM)) Q:ADM=""  SORT
 
'$D(NOASK!!,"Examining cases found for re-admissions within 185 days ...",!!
 
DVBAT="PEN","A&A" HOSPDAYS=$S(DVBAT="PEN"&(DVBAH="H"):89,DVBAT="PEN"&(DVBAH="D"):59,1:29) DFN=0:0 DFN=$O(^TMP("DVBA",$J,DVBAT,DFN)) Q:DFN=""  SORTDT=^(DFNCAL W:'$D(NOASK"+"
 
^TMP("DVBA",$J,"PEN"),^TMP("DVBA",$J,"A&A")
 
'$D(^TMP("DVBA","PEN",$J))&('$D(^TMP("DVBA","A&A",$J))) D  H D:$D(ZTQUEUEDKILL^%ZTLOAD KILL^DVBAUTIL
 .
DVBAERTXT DVBAERTXT="No data found for parameters entered."
 
.DVBAERTXT S:($G(DVBADLMTR)'="") ^TMP("DVBAR",$J,DVBABCNT)=DVBAERTXT
 
^DVBAB98
 
;
DQ ^TMP("DVBA",$J),^TMP("DVBA","PEN",$J),^TMP("DVBA","A&A",$J)
 
GO