- 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 Feb 18, 2025@23:06:53 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
