DVBAB9 ;ALB/SPH - CAPRI DISCHARGE REPORT ;09/06/00
;;2.7;AMIE;**35**;Apr 10, 1995
;
STRT(MSG,BDATE,EDATE,RONUM,DUZ) ;
S DVBACEPT=1 ; Force to find all d/c types
;
K ^TMP($J) G TERM
;
SET Q:'$D(^DPT(DA,0)) S DFN=DA,DVBASC="" D RCV^DVBAVDPT Q:CFLOC'=RONUM&(RO="Y")&(CFLOC'=0)&(CFLOC'=376) Q:ADTYPE="S"&(DVBASC'="Y") Q:ADTYPE="A"&(RCVAA'=1) Q:ADTYPE="P"&(RCVPEN'="1")
S TDIS=$S($D(^DGPM(+MB,0)):$P(^(0),U,18),1:"")
I $D(^DG(405.2,+TDIS,0)) DO
.I '$D(^TMP("DVBA",$J,"DUP",+TDIS)) Q
.S TDIS=$S($P(^DG(405.2,+TDIS,0),U,1)]"":$P(^(0),U,1),1:"Unknown discharge type")
.S ^TMP($J,XCN,CFLOC,MB,DA)=MA_U_RCVAA_U_RCVPEN_U_CNUM_U_TDIS
.Q
Q
;
PRINTB S MA=$P(DATA,U),RCVAA=$P(DATA,U,2),RCVPEN=$P(DATA,U,3),CNUM=$P(DATA,U,4),TDIS=$P(DATA,U,5),DFN=DA,QUIT1=1 D DCHGDT^DVBAVDPT
W:(IOST?1"C-".E)!($D(DVBAON2)) @IOF
W !!!,?(80-$L(HEAD)\2),HEAD,!,?(80-$L(HEAD1)\2),HEAD1,!!
W ?10,"Patient Name:",?26,PNAM,!!,?14,"Claim No:",?26,CNUM,!,?6,"Claim Folder Loc:",?26,CFLOC,!,?9,"Social Sec No:",?26,SSN,!
W ?8,"Discharge Date:",?26,$$FMTE^XLFDT(DCHGDT,"5DZ"),!,?5,"Type of Discharge:",?26,TDIS,!
D LOS^DVBAUTIL W ?8,"Length of Stay:",?26,LOS_$S(LOS="":"Discharged same day",LOS=1:" day",1:" days"),!
W ?11,"Bed Service:",?26,BEDSEC,!
W ?13,"Recv A&A?:",?26,$S(RCVAA="0":"NO",RCVAA="1":"YES",1:"Not specified"),!
W ?14,"Pension?:",?26,$S(RCVPEN="0":"NO",RCVPEN="1":"YES",1:"Not specified"),! D ELIG^DVBAVDPT
I IOST?1"C-".E W *7,!,"Press RETURN to continue or ""^"" to stop " R ANS:DTIME S:ANS=U!('$T) QUIT=1 I ANS=U S DVBAQUIT=1
S DVBAON2=""
Q
;
PRINT U IO S QUIT=""
S XCN="" F M=0:0 S XCN=$O(^TMP($J,XCN)) Q:XCN=""!(QUIT=1) S CFLOC="" F J=0:0 S CFLOC=$O(^TMP($J,XCN,CFLOC)) Q:CFLOC=""!(QUIT=1) D PRINT1
Q
PRINT1 S ADM="" F K=0:0 S ADM=$O(^TMP($J,XCN,CFLOC,ADM)) Q:ADM=""!(QUIT=1) S DA="" F L=0:0 S DA=$O(^TMP($J,XCN,CFLOC,ADM,DA)) Q:DA=""!(QUIT=1) S DATA=^(DA) D PRINTB
Q
;
TERM D HOME^%ZIS K NOASK
;
SETUP W @IOF,!,"VARO DISCHARGE REPORT" D NOPARM^DVBAUTL2 G:$D(DVBAQUIT) KILL^DVBAUTIL S DTAR=^DVB(396.1,1,0),FDT(0)=$$FMTE^XLFDT(DT,"5DZ")
S DSRP=1,HEAD1="FOR "_$P(DTAR,U,1)_" ON "_FDT(0) W !,HEAD1
;
EN1 ;W !!,"Please enter dates for search, oldest date first, most recent date last.",!!,"Last report was run on " S Y=$P(DTAR,U,4) X ^DD("DD") W Y,!!
;D DATE^DVBAUTIL
;G:X=""!(Y<0) KILL
;
ADTYPE ;D ADTYPE^DVBAUTL2 G:$D(DVBAQUIT) KILL^DVBAUTIL
W @IOF
;K DVBACEPT
;D EN^VALM("DVBA DISCHARGE TYPES")
I '$D(DVBACEPT) D KILL^DVBAUTIL Q
I '$O(^TMP("DVBA",$J,"DUP",0)) D KILL^DVBAUTIL Q
;
W !!! S %ZIS="Q" D ^%ZIS K %ZIS G:POP KILL^DVBAUTIL
;
QUEUE I $D(IO("Q")) S ZTRTN="DEQUE^DVBADSRT",ZTIO=ION,NOASK=1,ZTDESC="AMIE DISCHARGE REPORT" F I="^TMP(""DVBA"",$J,""DUP""","ADTYPE","DVBATYPS","BDATE","BDATE1","EDATE","FDT(0)","HEAD","HEAD1","HD","RO","RONUM","NOASK" S ZTSAVE(I)=""
I $D(IO("Q")) D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued.",! G KILL
;
GO S MA=BDATE F J=0:0 S MA=$O(^DGPM("AMV3",MA)) Q:MA>EDATE!(MA="") W:'$D(NOASK) "." F DA=0:0 S DA=$O(^DGPM("AMV3",MA,DA)) Q:DA="" F MB=0:0 S MB=$O(^DGPM("AMV3",MA,DA,MB)) Q:MB="" D SET
I '$D(^TMP($J)) U IO W !!,*7,"No data found for parameters entered.",!! H 2 G KILL
D PRINT I $D(DVBAQUIT) K DVBAON2 G KILL^DVBAUTIL
;
KILL D ^%ZISC D:$D(ZTQUEUED) KILL^%ZTLOAD S X=4 K DVBAON2 G FINAL^DVBAUTIL
;
DEQUE K ^TMP($J) G GO
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAB9 3360 printed Dec 13, 2024@01:40:42 Page 2
DVBAB9 ;ALB/SPH - CAPRI DISCHARGE REPORT ;09/06/00
+1 ;;2.7;AMIE;**35**;Apr 10, 1995
+2 ;
STRT(MSG,BDATE,EDATE,RONUM,DUZ) ;
+1 ; Force to find all d/c types
SET DVBACEPT=1
+2 ;
+3 KILL ^TMP($JOB)
GOTO TERM
+4 ;
SET if '$DATA(^DPT(DA,0))
QUIT
SET DFN=DA
SET DVBASC=""
DO RCV^DVBAVDPT
if CFLOC'=RONUM&(RO="Y")&(CFLOC'=0)&(CFLOC'=376)
QUIT
if ADTYPE="S"&(DVBASC'="Y")
QUIT
if ADTYPE="A"&(RCVAA'=1)
QUIT
if ADTYPE="P"&(RCVPEN'="1")
QUIT
+1 SET TDIS=$SELECT($DATA(^DGPM(+MB,0)):$PIECE(^(0),U,18),1:"")
+2 IF $DATA(^DG(405.2,+TDIS,0))
Begin DoDot:1
+3 IF '$DATA(^TMP("DVBA",$JOB,"DUP",+TDIS))
QUIT
+4 SET TDIS=$SELECT($PIECE(^DG(405.2,+TDIS,0),U,1)]"":$PIECE(^(0),U,1),1:"Unknown discharge type")
+5 SET ^TMP($JOB,XCN,CFLOC,MB,DA)=MA_U_RCVAA_U_RCVPEN_U_CNUM_U_TDIS
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
PRINTB SET MA=$PIECE(DATA,U)
SET RCVAA=$PIECE(DATA,U,2)
SET RCVPEN=$PIECE(DATA,U,3)
SET CNUM=$PIECE(DATA,U,4)
SET TDIS=$PIECE(DATA,U,5)
SET DFN=DA
SET QUIT1=1
DO DCHGDT^DVBAVDPT
+1 if (IOST?1"C-".E)!($DATA(DVBAON2))
WRITE @IOF
+2 WRITE !!!,?(80-$LENGTH(HEAD)\2),HEAD,!,?(80-$LENGTH(HEAD1)\2),HEAD1,!!
+3 WRITE ?10,"Patient Name:",?26,PNAM,!!,?14,"Claim No:",?26,CNUM,!,?6,"Claim Folder Loc:",?26,CFLOC,!,?9,"Social Sec No:",?26,SSN,!
+4 WRITE ?8,"Discharge Date:",?26,$$FMTE^XLFDT(DCHGDT,"5DZ"),!,?5,"Type of Discharge:",?26,TDIS,!
+5 DO LOS^DVBAUTIL
WRITE ?8,"Length of Stay:",?26,LOS_$SELECT(LOS="":"Discharged same day",LOS=1:" day",1:" days"),!
+6 WRITE ?11,"Bed Service:",?26,BEDSEC,!
+7 WRITE ?13,"Recv A&A?:",?26,$SELECT(RCVAA="0":"NO",RCVAA="1":"YES",1:"Not specified"),!
+8 WRITE ?14,"Pension?:",?26,$SELECT(RCVPEN="0":"NO",RCVPEN="1":"YES",1:"Not specified"),!
DO ELIG^DVBAVDPT
+9 IF IOST?1"C-".E
WRITE *7,!,"Press RETURN to continue or ""^"" to stop "
READ ANS:DTIME
if ANS=U!('$TEST)
SET QUIT=1
IF ANS=U
SET DVBAQUIT=1
+10 SET DVBAON2=""
+11 QUIT
+12 ;
PRINT USE IO
SET QUIT=""
+1 SET XCN=""
FOR M=0:0
SET XCN=$ORDER(^TMP($JOB,XCN))
if XCN=""!(QUIT=1)
QUIT
SET CFLOC=""
FOR J=0:0
SET CFLOC=$ORDER(^TMP($JOB,XCN,CFLOC))
if CFLOC=""!(QUIT=1)
QUIT
DO PRINT1
+2 QUIT
PRINT1 SET ADM=""
FOR K=0:0
SET ADM=$ORDER(^TMP($JOB,XCN,CFLOC,ADM))
if ADM=""!(QUIT=1)
QUIT
SET DA=""
FOR L=0:0
SET DA=$ORDER(^TMP($JOB,XCN,CFLOC,ADM,DA))
if DA=""!(QUIT=1)
QUIT
SET DATA=^(DA)
DO PRINTB
+1 QUIT
+2 ;
TERM DO HOME^%ZIS
KILL NOASK
+1 ;
SETUP WRITE @IOF,!,"VARO DISCHARGE REPORT"
DO NOPARM^DVBAUTL2
if $DATA(DVBAQUIT)
GOTO KILL^DVBAUTIL
SET DTAR=^DVB(396.1,1,0)
SET FDT(0)=$$FMTE^XLFDT(DT,"5DZ")
+1 SET DSRP=1
SET HEAD1="FOR "_$PIECE(DTAR,U,1)_" ON "_FDT(0)
WRITE !,HEAD1
+2 ;
EN1 ;W !!,"Please enter dates for search, oldest date first, most recent date last.",!!,"Last report was run on " S Y=$P(DTAR,U,4) X ^DD("DD") W Y,!!
+1 ;D DATE^DVBAUTIL
+2 ;G:X=""!(Y<0) KILL
+3 ;
ADTYPE ;D ADTYPE^DVBAUTL2 G:$D(DVBAQUIT) KILL^DVBAUTIL
+1 WRITE @IOF
+2 ;K DVBACEPT
+3 ;D EN^VALM("DVBA DISCHARGE TYPES")
+4 IF '$DATA(DVBACEPT)
DO KILL^DVBAUTIL
QUIT
+5 IF '$ORDER(^TMP("DVBA",$JOB,"DUP",0))
DO KILL^DVBAUTIL
QUIT
+6 ;
+7 WRITE !!!
SET %ZIS="Q"
DO ^%ZIS
KILL %ZIS
if POP
GOTO KILL^DVBAUTIL
+8 ;
QUEUE IF $DATA(IO("Q"))
SET ZTRTN="DEQUE^DVBADSRT"
SET ZTIO=ION
SET NOASK=1
SET ZTDESC="AMIE DISCHARGE REPORT"
FOR I="^TMP(""DVBA"",$J,""DUP""","ADTYPE","DVBATYPS","BDATE","BDATE1","EDATE","FDT(0)","HEAD","HEAD1","HD","RO","RONUM","NOASK"
SET ZTSAVE(I)=""
+1 IF $DATA(IO("Q"))
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !!,"Request queued.",!
GOTO KILL
+2 ;
GO SET MA=BDATE
FOR J=0:0
SET MA=$ORDER(^DGPM("AMV3",MA))
if MA>EDATE!(MA="")
QUIT
if '$DATA(NOASK)
WRITE "."
FOR DA=0:0
SET DA=$ORDER(^DGPM("AMV3",MA,DA))
if DA=""
QUIT
FOR MB=0:0
SET MB=$ORDER(^DGPM("AMV3",MA,DA,MB))
if MB=""
QUIT
DO SET
+1 IF '$DATA(^TMP($JOB))
USE IO
WRITE !!,*7,"No data found for parameters entered.",!!
HANG 2
GOTO KILL
+2 DO PRINT
IF $DATA(DVBAQUIT)
KILL DVBAON2
GOTO KILL^DVBAUTIL
+3 ;
KILL DO ^%ZISC
if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
SET X=4
KILL DVBAON2
GOTO FINAL^DVBAUTIL
+1 ;
DEQUE KILL ^TMP($JOB)
GOTO GO
