DVBARADM ;ALB/GTS-557/THM-READMISSION REPORT ; 1/23/91 8:01 AM
;;2.7;AMIE;**1,17**;Apr 10, 1995
;
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)=""
I RCVPEN S ^TMP("DVBA",$J,"PEN",DFN)=""
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,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,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,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("om^ospital",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="" 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))) W *7,!!,"No data found for parameters entered.",!! H 2 D:$D(ZTQUEUED) KILL^%ZTLOAD G KILL^DVBAUTIL
G ^DVBARAD1
;
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[HDVBARADM 4118 printed Sep 23, 2025@19:17:58 Page 2
DVBARADM ;ALB/GTS-557/THM-READMISSION REPORT ; 1/23/91 8:01 AM
+1 ;;2.7;AMIE;**1,17**;Apr 10, 1995
+2 ;
+3 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)=""
+2 IF RCVPEN
SET ^TMP("DVBA",$JOB,"PEN",DFN)=""
+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,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,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,XCN,CFLOC,VY,DFN,"LADM")=LADMDT_U_TDIS
End DoDot:1
+16 KILL DVBARADQ
+17 SET (VX,VY)=9999999
+18 QUIT
+19 ;
TERM DO HOME^%ZIS
KILL ^TMP("DVBA",$JOB),^TMP("DVBA","PEN",$JOB),^TMP("DVBA","A&A",$JOB),NOASK
+1 DO NOPARM^DVBAUTL2
if $DATA(DVBAQUIT)
GOTO KILL^DVBAUTIL
+2 ;
SETUP WRITE @IOF,!,"VARO RE-ADMISSION REPORT"
SET DTAR=^DVB(396.1,1,0)
SET FDT(0)=$$FMTE^XLFDT(DT,"5DZ")
+1 SET HEAD="RE-ADMISSION REPORT"
SET HEAD1="FOR "_$PIECE(DTAR,U,1)_" ON "_FDT(0)
+2 WRITE !,HEAD1
EN1 WRITE !!,"Please enter admission dates for search, oldest date first,",!,"most recent date last.",!!,"Last report was run on "
SET Y=$PIECE(DTAR,U,7)
XECUTE ^DD("DD")
WRITE Y,!!
+1 DO DATE^DVBAUTIL
if Y<0
GOTO KILL^DVBAUTIL
+2 SET BDATE1=BDATE+.5
SET HEADDT="Date range: "_$$FMTE^XLFDT(BDATE1,"5DZ")_" to "_$$FMTE^XLFDT(EDATE,"5DZ")
+3 ;
ASK WRITE !!,"Do you want (H)ospital or Hospital-(D)om H// "
READ DVBAH:DTIME
if '$TEST!(DVBAH=U)
GOTO 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("om^ospital",U,Z),!!
+7 SET %ZIS("B")="0;P-OTHER"
SET %ZIS("A")="Printing device: "
SET %ZIS="AEQ"
DO ^%ZIS
if POP
GOTO 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
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)))
WRITE *7,!!,"No data found for parameters entered.",!!
HANG 2
if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
GOTO KILL^DVBAUTIL
+6 GOTO ^DVBARAD1
+7 ;
DQ KILL ^TMP("DVBA",$JOB),^TMP("DVBA","PEN",$JOB),^TMP("DVBA","A&A",$JOB)
+1 GOTO GO
