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