DVBAB53 ;ALB/SPH - CAPRI DISCHARGE REPORT ; 3/5/12 11:30am
;;2.7;AMIE;**35,99,100,149,179,185**;Apr 10, 1995;Build 18
;Per VHA Directive 2004-038, this routine should not be modified.
;
;Input: ZMSG - Output Array for discharge report (By Ref)
; BDATE - Beginning date for eport (FM Format)
; EDATE - Ending date for report (FM Format)
; ADTYPE - Valid discharge code values include:
; A : Recieving A&A
; P : Pension
; S : Service Connected
; L : All discharge types
; 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 discharge report
STRT(ZMSG,BDATE,EDATE,ADTYPE,DVBADLMTR) ;
N DVBAFNLDTE,MA1
I BDATE'["." S BDATE=BDATE-.0001 ; DVBA*2.7*99
S DVBABCNT=0
S RONUM=0
S RO="N"
S HEAD="",HEAD1=""
S DVBAFNLDTE=$S(+$G(DVBADLMTR):+$P(DVBADLMTR,"."),1:0)
S DVBADLMTR=$S('+$G(DVBADLMTR):"",1:"^")
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 ; DVBA*2.7*99 commented out
.I '$D(DISTYPE(+TDIS)) Q
.S TDIS=$S($P(^DG(405.2,+TDIS,0),U,1)]"":$P(^(0),U,1),1:"Unknown discharge type")
.S MA1=$P(MA,".",1)
.S ^TMP($J,MA1,XCN,CFLOC,MB,DA)=RCVAA_U_RCVPEN_U_CNUM_U_TDIS
.Q
Q
;
PRINTB S RCVAA=$P(DATA,U),RCVPEN=$P(DATA,U,2),CNUM=$P(DATA,U,3),TDIS=$P(DATA,U,4),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,!!
;create delimited/non-delimited report
D:($G(DVBADLMTR)'="") PRINTD
D:($G(DVBADLMTR)="") PRINTND
Q
;
PRINTND ;create non-delimited discharge report
S ^TMP("DVBAR",$J,DVBABCNT)="",DVBABCNT=DVBABCNT+1
;
S ^TMP("DVBAR",$J,DVBABCNT)=" Patient Name: "_PNAM S DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)=" Claim No: "_CNUM S DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)=" Claim Folder Loc: "_CFLOC S DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)=" Social Sec No: "_SSN S DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)=" Discharge Date: "_$$FMTE^XLFDT(DCHGDT,"5DZ"),DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)=" Type of Discharge: "_TDIS,DVBABCNT=DVBABCNT+1
D LOS^DVBAUTIL
S ^TMP("DVBAR",$J,DVBABCNT)=" Length of Stay: "_LOS_$S(LOS="":"Discharged same day",LOS=1:" day",1:" days"),DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)=" Bed Service: "_BEDSEC,DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)=" Recv A&A?: "_$S(RCVAA="0":"NO",RCVAA="1":"YES",1:"Not specified"),DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)=" Pension?: "_$S(RCVPEN="0":"NO",RCVPEN="1":"YES",1:"Not specified"),DVBABCNT=DVBABCNT+1
;
;
; ELIG INFO...
S ELIG=DVBAELIG,INCMP=""
;S ZMSG(DVBABCNT)=" Eligibility data: "
I ELIG]"" S ELIG=ELIG_" ("_$S(DVBAELST="P":"Pend Ver",DVBAELST="R":"Pend Re-verif",DVBAELST="V":"Verified",1:"Not Verified")_")"
I $D(^DPT(DA,.29)) S INCMP=$S($P(^(.29),U,12)=1:"Incompetent",1:"")
S ^TMP("DVBAR",$J,DVBABCNT)=" Eligibility data: "_ELIG_$S(((ELIG]"")&(INCMP]"")):", ",1:"") S DVBABCNT=DVBABCNT+1
W:$X>60 !?26 S ^TMP("DVBAR",$J,DVBABCNT)=INCMP S DVBABCNT=DVBABCNT+1
Q
;END OF ELIG INFO
;
;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
;
PRINTD ;create delimited discharge report
N ELIG,INCMP,DVBATMP,X,X1,X2,X3
D:('$D(^XTMP("DVBA_DISCHARGE_RPT"_$J,0))) COLHDR
S ^TMP("DVBAR",$J,DVBABCNT)=PNAM_DVBADLMTR_CNUM_DVBADLMTR_CFLOC_DVBADLMTR_SSN_DVBADLMTR
S ^TMP("DVBAR",$J,DVBABCNT)=^TMP("DVBAR",$J,DVBABCNT)_$$FMTE^XLFDT(DCHGDT,"5DZ")_DVBADLMTR_TDIS_DVBADLMTR
D LOS^DVBAUTIL
S ^TMP("DVBAR",$J,DVBABCNT)=^TMP("DVBAR",$J,DVBABCNT)_LOS_$S(LOS="":"Discharged same day",LOS=1:" day",1:" days")_DVBADLMTR
S ^TMP("DVBAR",$J,DVBABCNT)=^TMP("DVBAR",$J,DVBABCNT)_BEDSEC_DVBADLMTR_$S(RCVAA="0":"NO",RCVAA="1":"YES",1:"Not specified")_DVBADLMTR
S ^TMP("DVBAR",$J,DVBABCNT)=^TMP("DVBAR",$J,DVBABCNT)_$S(RCVPEN="0":"NO",RCVPEN="1":"YES",1:"Not specified")_DVBADLMTR
;
S ELIG=DVBAELIG,INCMP=""
I ELIG]"" S ELIG=ELIG_" ("_$S(DVBAELST="P":"Pend Ver",DVBAELST="R":"Pend Re-verif",DVBAELST="V":"Verified",1:"Not Verified")_")"
I $D(^DPT(DA,.29)) S INCMP=$S($P(^(.29),U,12)=1:"Incompetent",1:"")
;
S ^TMP("DVBAR",$J,DVBABCNT)=^TMP("DVBAR",$J,DVBABCNT)_ELIG_$S(((ELIG]"")&(INCMP]"")):", ",1:"")_INCMP
;
S DVBATMP=^TMP("DVBAR",$J,DVBABCNT)
S X=$P(DVBATMP,DVBADLMTR,4)
I $L(X)'>9 S X=""""_$E("000000000",1,9-$L(X))_X_"""",X1=$E(X,1,4),X2=$E(X,5,6),X3=$E(X,7,11),X=X1_"-"_X2_"-"_X3
I $E(X,10,10)'?.N S X=""""_$E("0000000000",1,10-$L(X))_X_"""",X1=$E(X,1,4),X2=$E(X,5,6),X3=$E(X,7,12),X=X1_"-"_X2_"-"_X3
S $P(DVBATMP,DVBADLMTR,4)=X
S X=$P(DVBATMP,DVBADLMTR,2)
S X=$C(160)_X
S $P(DVBATMP,DVBADLMTR,2)=X
F I=1:1:$L(DVBATMP,DVBADLMTR) I $P(DVBATMP,DVBADLMTR,I)["," S $P(DVBATMP,DVBADLMTR,I)=""""_$P(DVBATMP,DVBADLMTR,I)_""""
S DVBATMP=$TR(DVBATMP,DVBADLMTR,",")
S ^TMP("DVBAR",$J,DVBABCNT)=DVBATMP
;
S DVBABCNT=DVBABCNT+1
Q
;
PRINT U IO S QUIT=""
S MA="" F G=0:0 S MA=$O(^TMP($J,MA)) Q:MA=""!(QUIT=1) S XCN="" F M=0:0 S XCN=$O(^TMP($J,MA,XCN)) Q:XCN=""!(QUIT=1) S CFLOC="" F J=0:0 S CFLOC=$O(^TMP($J,MA,XCN,CFLOC)) Q:CFLOC=""!(QUIT=1) D PRINT1
Q
PRINT1 S ADM="" F K=0:0 S ADM=$O(^TMP($J,MA,XCN,CFLOC,ADM)) Q:ADM=""!(QUIT=1) S DA="" F L=0:0 S DA=$O(^TMP($J,MA,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
;S 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^DVBAB99("DVBA DISCHARGE TYPES")
D ACCEPT^DVBALD
I '$D(DVBACEPT) D KILL^DVBAUTIL Q
I '$O(^TMP("DVBA",$J,"DUP",0)) D KILL^DVBAUTIL Q
M DISTYPE=^TMP("DVBA",$J,"DUP")
;
; DVBA*2.7*100 - commented out next line
; 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="DISTYPE(","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)) D H 2 G KILL
.N DVBAERTXT S DVBAERTXT="No data found for parameters entered."
.U IO W !!,*7,DVBAERTXT,!!
.S:($G(DVBADLMTR)'="") ^TMP("DVBAR",$J,DVBABCNT)=DVBAERTXT
D PRINT K:(DVBAFNLDTE=$P(EDATE,".")) ^XTMP("DVBA_DISCHARGE_RPT"_$J,0)
I $D(DVBAQUIT) K DVBAON2,DISTYPE G KILL^DVBAUTIL
;
KILL K:(DVBAFNLDTE=$P(EDATE,".")) ^XTMP("DVBA_DISCHARGE_RPT"_$J,0)
S ZMSG=$NA(^TMP("DVBAR",$J))
D ^%ZISC D:$D(ZTQUEUED) KILL^%ZTLOAD S X=4 K DVBAON2,DISTYPE G FINAL^DVBAUTIL
;
DEQUE K ^TMP($J) G GO
;
COLHDR ;Column header for delimited report
N DVBADLMTR
S DVBADLMTR=","
S ^TMP("DVBAR",$J,DVBABCNT)="Patient Name"_DVBADLMTR_"Claim No"_DVBADLMTR_"Claim Folder Loc"_DVBADLMTR
S ^TMP("DVBAR",$J,DVBABCNT)=(^TMP("DVBAR",$J,DVBABCNT))_"Social Sec No"_DVBADLMTR_"Discharge Date"_DVBADLMTR
S ^TMP("DVBAR",$J,DVBABCNT)=(^TMP("DVBAR",$J,DVBABCNT))_"Type of Discharge"_DVBADLMTR_"Length of Stay"_DVBADLMTR
S ^TMP("DVBAR",$J,DVBABCNT)=(^TMP("DVBAR",$J,DVBABCNT))_"Bed Service"_DVBADLMTR_"Recv A&A?"_DVBADLMTR
S ^TMP("DVBAR",$J,DVBABCNT)=(^TMP("DVBAR",$J,DVBABCNT))_"Pension?"_DVBADLMTR_"Eligibility Data"
S DVBABCNT=DVBABCNT+1
;set global entry so header is only created once for job ($J)
S ^XTMP("DVBA_DISCHARGE_RPT"_$J,0)=DT_U_DT_U_BDATE_U_EDATE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAB53 8705 printed Nov 22, 2024@16:50:40 Page 2
DVBAB53 ;ALB/SPH - CAPRI DISCHARGE REPORT ; 3/5/12 11:30am
+1 ;;2.7;AMIE;**35,99,100,149,179,185**;Apr 10, 1995;Build 18
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;Input: ZMSG - Output Array for discharge report (By Ref)
+5 ; BDATE - Beginning date for eport (FM Format)
+6 ; EDATE - Ending date for report (FM Format)
+7 ; ADTYPE - Valid discharge code values include:
+8 ; A : Recieving A&A
+9 ; P : Pension
+10 ; S : Service Connected
+11 ; L : All discharge types
+12 ; DVBADLMTR - Indicates if report should be delimitted (Optional)
+13 ; CAPRI currently executes RPC by each day in
+14 ; date range, so DVBADLMTR should equal the
+15 ; final EDATE in range so that XTMP global
+16 ; can be killed.
+17 ;Output: ^TMP("DVBAR",$J) contains delimited/non-delimited discharge report
STRT(ZMSG,BDATE,EDATE,ADTYPE,DVBADLMTR) ;
+1 NEW DVBAFNLDTE,MA1
+2 ; DVBA*2.7*99
IF BDATE'["."
SET BDATE=BDATE-.0001
+3 SET DVBABCNT=0
+4 SET RONUM=0
+5 SET RO="N"
+6 SET HEAD=""
SET HEAD1=""
+7 SET DVBAFNLDTE=$SELECT(+$GET(DVBADLMTR):+$PIECE(DVBADLMTR,"."),1:0)
+8 SET DVBADLMTR=$SELECT('+$GET(DVBADLMTR):"",1:"^")
+9 KILL ^TMP($JOB)
GOTO TERM
+10 ;
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 ; I '$D(^TMP("DVBA",$J,"DUP",+TDIS)) Q ; DVBA*2.7*99 commented out
+4 IF '$DATA(DISTYPE(+TDIS))
QUIT
+5 SET TDIS=$SELECT($PIECE(^DG(405.2,+TDIS,0),U,1)]"":$PIECE(^(0),U,1),1:"Unknown discharge type")
+6 SET MA1=$PIECE(MA,".",1)
+7 SET ^TMP($JOB,MA1,XCN,CFLOC,MB,DA)=RCVAA_U_RCVPEN_U_CNUM_U_TDIS
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
PRINTB SET RCVAA=$PIECE(DATA,U)
SET RCVPEN=$PIECE(DATA,U,2)
SET CNUM=$PIECE(DATA,U,3)
SET TDIS=$PIECE(DATA,U,4)
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 ;create delimited/non-delimited report
+4 if ($GET(DVBADLMTR)'="")
DO PRINTD
+5 if ($GET(DVBADLMTR)="")
DO PRINTND
+6 QUIT
+7 ;
PRINTND ;create non-delimited discharge report
+1 SET ^TMP("DVBAR",$JOB,DVBABCNT)=""
SET DVBABCNT=DVBABCNT+1
+2 ;
+3 SET ^TMP("DVBAR",$JOB,DVBABCNT)=" Patient Name: "_PNAM
SET DVBABCNT=DVBABCNT+1
+4 SET ^TMP("DVBAR",$JOB,DVBABCNT)=" Claim No: "_CNUM
SET DVBABCNT=DVBABCNT+1
+5 SET ^TMP("DVBAR",$JOB,DVBABCNT)=" Claim Folder Loc: "_CFLOC
SET DVBABCNT=DVBABCNT+1
+6 SET ^TMP("DVBAR",$JOB,DVBABCNT)=" Social Sec No: "_SSN
SET DVBABCNT=DVBABCNT+1
+7 SET ^TMP("DVBAR",$JOB,DVBABCNT)=" Discharge Date: "_$$FMTE^XLFDT(DCHGDT,"5DZ")
SET DVBABCNT=DVBABCNT+1
+8 SET ^TMP("DVBAR",$JOB,DVBABCNT)=" Type of Discharge: "_TDIS
SET DVBABCNT=DVBABCNT+1
+9 DO LOS^DVBAUTIL
+10 SET ^TMP("DVBAR",$JOB,DVBABCNT)=" Length of Stay: "_LOS_$SELECT(LOS="":"Discharged same day",LOS=1:" day",1:" days")
SET DVBABCNT=DVBABCNT+1
+11 SET ^TMP("DVBAR",$JOB,DVBABCNT)=" Bed Service: "_BEDSEC
SET DVBABCNT=DVBABCNT+1
+12 SET ^TMP("DVBAR",$JOB,DVBABCNT)=" Recv A&A?: "_$SELECT(RCVAA="0":"NO",RCVAA="1":"YES",1:"Not specified")
SET DVBABCNT=DVBABCNT+1
+13 SET ^TMP("DVBAR",$JOB,DVBABCNT)=" Pension?: "_$SELECT(RCVPEN="0":"NO",RCVPEN="1":"YES",1:"Not specified")
SET DVBABCNT=DVBABCNT+1
+14 ;
+15 ;
+16 ; ELIG INFO...
+17 SET ELIG=DVBAELIG
SET INCMP=""
+18 ;S ZMSG(DVBABCNT)=" Eligibility data: "
+19 IF ELIG]""
SET ELIG=ELIG_" ("_$SELECT(DVBAELST="P":"Pend Ver",DVBAELST="R":"Pend Re-verif",DVBAELST="V":"Verified",1:"Not Verified")_")"
+20 IF $DATA(^DPT(DA,.29))
SET INCMP=$SELECT($PIECE(^(.29),U,12)=1:"Incompetent",1:"")
+21 SET ^TMP("DVBAR",$JOB,DVBABCNT)=" Eligibility data: "_ELIG_$SELECT(((ELIG]"")&(INCMP]"")):", ",1:"")
SET DVBABCNT=DVBABCNT+1
+22 if $X>60
WRITE !?26
SET ^TMP("DVBAR",$JOB,DVBABCNT)=INCMP
SET DVBABCNT=DVBABCNT+1
+23 QUIT
+24 ;END OF ELIG INFO
+25 ;
+26 ;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
+27 SET DVBAON2=""
+28 QUIT
+29 ;
PRINTD ;create delimited discharge report
+1 NEW ELIG,INCMP,DVBATMP,X,X1,X2,X3
+2 if ('$DATA(^XTMP("DVBA_DISCHARGE_RPT"_$JOB,0)))
DO COLHDR
+3 SET ^TMP("DVBAR",$JOB,DVBABCNT)=PNAM_DVBADLMTR_CNUM_DVBADLMTR_CFLOC_DVBADLMTR_SSN_DVBADLMTR
+4 SET ^TMP("DVBAR",$JOB,DVBABCNT)=^TMP("DVBAR",$JOB,DVBABCNT)_$$FMTE^XLFDT(DCHGDT,"5DZ")_DVBADLMTR_TDIS_DVBADLMTR
+5 DO LOS^DVBAUTIL
+6 SET ^TMP("DVBAR",$JOB,DVBABCNT)=^TMP("DVBAR",$JOB,DVBABCNT)_LOS_$SELECT(LOS="":"Discharged same day",LOS=1:" day",1:" days")_DVBADLMTR
+7 SET ^TMP("DVBAR",$JOB,DVBABCNT)=^TMP("DVBAR",$JOB,DVBABCNT)_BEDSEC_DVBADLMTR_$SELECT(RCVAA="0":"NO",RCVAA="1":"YES",1:"Not specified")_DVBADLMTR
+8 SET ^TMP("DVBAR",$JOB,DVBABCNT)=^TMP("DVBAR",$JOB,DVBABCNT)_$SELECT(RCVPEN="0":"NO",RCVPEN="1":"YES",1:"Not specified")_DVBADLMTR
+9 ;
+10 SET ELIG=DVBAELIG
SET INCMP=""
+11 IF ELIG]""
SET ELIG=ELIG_" ("_$SELECT(DVBAELST="P":"Pend Ver",DVBAELST="R":"Pend Re-verif",DVBAELST="V":"Verified",1:"Not Verified")_")"
+12 IF $DATA(^DPT(DA,.29))
SET INCMP=$SELECT($PIECE(^(.29),U,12)=1:"Incompetent",1:"")
+13 ;
+14 SET ^TMP("DVBAR",$JOB,DVBABCNT)=^TMP("DVBAR",$JOB,DVBABCNT)_ELIG_$SELECT(((ELIG]"")&(INCMP]"")):", ",1:"")_INCMP
+15 ;
+16 SET DVBATMP=^TMP("DVBAR",$JOB,DVBABCNT)
+17 SET X=$PIECE(DVBATMP,DVBADLMTR,4)
+18 IF $LENGTH(X)'>9
SET X=""""_$EXTRACT("000000000",1,9-$LENGTH(X))_X_""""
SET X1=$EXTRACT(X,1,4)
SET X2=$EXTRACT(X,5,6)
SET X3=$EXTRACT(X,7,11)
SET X=X1_"-"_X2_"-"_X3
+19 IF $EXTRACT(X,10,10)'?.N
SET X=""""_$EXTRACT("0000000000",1,10-$LENGTH(X))_X_""""
SET X1=$EXTRACT(X,1,4)
SET X2=$EXTRACT(X,5,6)
SET X3=$EXTRACT(X,7,12)
SET X=X1_"-"_X2_"-"_X3
+20 SET $PIECE(DVBATMP,DVBADLMTR,4)=X
+21 SET X=$PIECE(DVBATMP,DVBADLMTR,2)
+22 SET X=$CHAR(160)_X
+23 SET $PIECE(DVBATMP,DVBADLMTR,2)=X
+24 FOR I=1:1:$LENGTH(DVBATMP,DVBADLMTR)
IF $PIECE(DVBATMP,DVBADLMTR,I)[","
SET $PIECE(DVBATMP,DVBADLMTR,I)=""""_$PIECE(DVBATMP,DVBADLMTR,I)_""""
+25 SET DVBATMP=$TRANSLATE(DVBATMP,DVBADLMTR,",")
+26 SET ^TMP("DVBAR",$JOB,DVBABCNT)=DVBATMP
+27 ;
+28 SET DVBABCNT=DVBABCNT+1
+29 QUIT
+30 ;
PRINT USE IO
SET QUIT=""
+1 SET MA=""
FOR G=0:0
SET MA=$ORDER(^TMP($JOB,MA))
if MA=""!(QUIT=1)
QUIT
SET XCN=""
FOR M=0:0
SET XCN=$ORDER(^TMP($JOB,MA,XCN))
if XCN=""!(QUIT=1)
QUIT
SET CFLOC=""
FOR J=0:0
SET CFLOC=$ORDER(^TMP($JOB,MA,XCN,CFLOC))
if CFLOC=""!(QUIT=1)
QUIT
DO PRINT1
+2 QUIT
PRINT1 SET ADM=""
FOR K=0:0
SET ADM=$ORDER(^TMP($JOB,MA,XCN,CFLOC,ADM))
if ADM=""!(QUIT=1)
QUIT
SET DA=""
FOR L=0:0
SET DA=$ORDER(^TMP($JOB,MA,XCN,CFLOC,ADM,DA))
if DA=""!(QUIT=1)
QUIT
SET DATA=^(DA)
DO PRINTB
+1 QUIT
+2 ;
TERM ;D HOME^%ZIS K NOASK
+1 ;
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")
+1 SET DSRP=1
+2 ;S HEAD1="FOR "_$P(DTAR,U,1)_" ON "_FDT(0) W !,HEAD1
+3 ;
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 ;W @IOF
+2 ;K DVBACEPT
+3 DO EN^DVBAB99("DVBA DISCHARGE TYPES")
+4 DO ACCEPT^DVBALD
+5 IF '$DATA(DVBACEPT)
DO KILL^DVBAUTIL
QUIT
+6 IF '$ORDER(^TMP("DVBA",$JOB,"DUP",0))
DO KILL^DVBAUTIL
QUIT
+7 MERGE DISTYPE=^TMP("DVBA",$JOB,"DUP")
+8 ;
+9 ; DVBA*2.7*100 - commented out next line
+10 ; W !!! S %ZIS="Q" D ^%ZIS K %ZIS G:POP KILL^DVBAUTIL
+11 ;
QUEUE IF $DATA(IO("Q"))
SET ZTRTN="DEQUE^DVBADSRT"
SET ZTIO=ION
SET NOASK=1
SET ZTDESC="AMIE DISCHARGE REPORT"
FOR I="DISTYPE(","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))
Begin DoDot:1
+2 NEW DVBAERTXT
SET DVBAERTXT="No data found for parameters entered."
+3 USE IO
WRITE !!,*7,DVBAERTXT,!!
+4 if ($GET(DVBADLMTR)'="")
SET ^TMP("DVBAR",$JOB,DVBABCNT)=DVBAERTXT
End DoDot:1
HANG 2
GOTO KILL
+5 DO PRINT
if (DVBAFNLDTE=$PIECE(EDATE,"."))
KILL ^XTMP("DVBA_DISCHARGE_RPT"_$JOB,0)
+6 IF $DATA(DVBAQUIT)
KILL DVBAON2,DISTYPE
GOTO KILL^DVBAUTIL
+7 ;
KILL if (DVBAFNLDTE=$PIECE(EDATE,"."))
KILL ^XTMP("DVBA_DISCHARGE_RPT"_$JOB,0)
+1 SET ZMSG=$NAME(^TMP("DVBAR",$JOB))
+2 DO ^%ZISC
if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
SET X=4
KILL DVBAON2,DISTYPE
GOTO FINAL^DVBAUTIL
+3 ;
DEQUE KILL ^TMP($JOB)
GOTO GO
+1 ;
COLHDR ;Column header for delimited report
+1 NEW DVBADLMTR
+2 SET DVBADLMTR=","
+3 SET ^TMP("DVBAR",$JOB,DVBABCNT)="Patient Name"_DVBADLMTR_"Claim No"_DVBADLMTR_"Claim Folder Loc"_DVBADLMTR
+4 SET ^TMP("DVBAR",$JOB,DVBABCNT)=(^TMP("DVBAR",$JOB,DVBABCNT))_"Social Sec No"_DVBADLMTR_"Discharge Date"_DVBADLMTR
+5 SET ^TMP("DVBAR",$JOB,DVBABCNT)=(^TMP("DVBAR",$JOB,DVBABCNT))_"Type of Discharge"_DVBADLMTR_"Length of Stay"_DVBADLMTR
+6 SET ^TMP("DVBAR",$JOB,DVBABCNT)=(^TMP("DVBAR",$JOB,DVBABCNT))_"Bed Service"_DVBADLMTR_"Recv A&A?"_DVBADLMTR
+7 SET ^TMP("DVBAR",$JOB,DVBABCNT)=(^TMP("DVBAR",$JOB,DVBABCNT))_"Pension?"_DVBADLMTR_"Eligibility Data"
+8 SET DVBABCNT=DVBABCNT+1
+9 ;set global entry so header is only created once for job ($J)
+10 SET ^XTMP("DVBA_DISCHARGE_RPT"_$JOB,0)=DT_U_DT_U_BDATE_U_EDATE
+11 QUIT
