DVBAB98 ;ALB/SPH - CAPRI CONVERSION OF DVBARAD1 FOR SUPPORT ; 3/22/12 8:33am
;;2.7;AMIE;**35,149,179,185**;Apr 10, 1995;Build 18
;Per VHA Directive 2004-038, this routine should not be modified.
;
S ZX="PENSION ",ZY="A & A "
S MSG="" F ZZ=1:1:7 S MSG=MSG_ZX
S MSG1="" F ZZ=1:1:7 S MSG1=MSG1_ZY
U IO K DVBAQUIT
F DVBAT="PEN","A&A" W:((IOST?1"C-".E)!(IOST'?1"P-OTHER".E)) @IOF W !!!!!!!!!! D PRINT Q:$D(DVBAQUIT)
S ZMSG=$NA(^TMP("DVBAR",$J))
G KILL
;
PRINTB S DATA1=$S($D(^TMP("DVBA",DVBAT,$J,SORTDT,XCN,XCFLOC,K,DA,"LADM")):^("LADM"),1:"") S (LADMDT,ADMDT)=$P(DATA1,U),LTDIS=$P(DATA1,U,2),DFN=DA,QUIT1=1 K DATA1 D ADM^DVBAVDPT K QUIT1,DVBAQ
S LBEDSEC=BEDSEC,LDIAG=DIAG,LDCHGDT=DCHGDT,ADMDT=$P(DATA,U),RCVAA=$P(DATA,U,2),RCVPEN=$P(DATA,U,3),CNUM=$P(DATA,U,4),TDIS=$P(DATA,U,5) D ADM^DVBAVDPT
S RCVPEN=$S(RCVPEN=0:"NO",RCVPEN=1:"YES",1:"Not specified"),RCVAA=$S(RCVAA=0:"NO",RCVAA=1:"YES",1:"Not specified")
W @IOF,!!!,?(80-$L(HEAD)\2),HEAD,!,?(80-$L(HEAD1)\2),HEAD1,!,?(80-$L(HEADDT)\2),HEADDT,!!!
S:ADMDT]"" ADMDT=$$FMTE^XLFDT(ADMDT,"5DZ")
S:DCHGDT]"" DCHGDT=$$FMTE^XLFDT(DCHGDT,"5DZ")
S:LADMDT]"" LADMDT=$$FMTE^XLFDT(LADMDT,"5DZ")
S:LDCHGDT]"" LDCHGDT=$$FMTE^XLFDT(LDCHGDT,"5DZ")
;create delimited/non-delimited report
D:($G(DVBADLMTR)'="") PRINTD
D:($G(DVBADLMTR)="") PRINTND
Q
;
PRINTND ;create non-delimited re-admission report
S ^TMP("DVBAR",$J,DVBABCNT)="",DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)="Patient: "_PNAM_" SSN: "_SSN_" Claim Folder Loc: "_CFLOC,DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)="Claim #: "_CNUM_" Pension: "_RCVPEN_" A&A: "_RCVAA,DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)="================================================================================",DVBABCNT=DVBABCNT+1
D ELIG
S ^TMP("DVBAR",$J,DVBABCNT)="Current Admission Data:",DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)="-----------------------",DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)="Admission Date: "_ADMDT,DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)="Admitting Diagnosis: "_DIAG,DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)="Discharge Date: "_DCHGDT,DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)="Discharge Type: "_TDIS,DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)="Bed Service: "_BEDSEC,DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)="",DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)="Prior Admission Data:",DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)="---------------------",DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)="Admission Date: "_LADMDT,DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)="Admitting Diagnosis: "_LDIAG,DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)="Discharge Date: "_LDCHGDT,DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)="Discharge Type: "_LTDIS,DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)="Bed Service: "_LBEDSEC,DVBABCNT=DVBABCNT+1
S ^TMP("DVBAR",$J,DVBABCNT)="",DVBABCNT=DVBABCNT+1
;I IOST?1"C-".E W *7,!,"Press RETURN to continue or ""^"" to stop " R ANS:DTIME S:ANS=U!('$T) XCN="ZZZZ" I '$T S DVBAQUIT=1
Q
;
PRINTD ;create delimited re-admission report
N DVBATMP,X,X1,X2,X3
D:('$D(^XTMP("DVBA_READMISSION_RPT"_$J,0))) COLHDR
S ^TMP("DVBAR",$J,DVBABCNT)=PNAM_DVBADLMTR_SSN_DVBADLMTR_CFLOC_DVBADLMTR_CNUM_DVBADLMTR_RCVPEN_DVBADLMTR_RCVAA_DVBADLMTR
D ELIG
S ^TMP("DVBAR",$J,DVBABCNT)=^TMP("DVBAR",$J,DVBABCNT)_ADMDT_DVBADLMTR_DIAG_DVBADLMTR_DCHGDT_DVBADLMTR_TDIS_DVBADLMTR_BEDSEC_DVBADLMTR
S ^TMP("DVBAR",$J,DVBABCNT)=^TMP("DVBAR",$J,DVBABCNT)_LADMDT_DVBADLMTR_LDIAG_DVBADLMTR_LDCHGDT_DVBADLMTR_LTDIS_DVBADLMTR_LBEDSEC
;
S DVBATMP=^TMP("DVBAR",$J,DVBABCNT)
S X=$P(DVBATMP,DVBADLMTR,2)
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,2)=X
S X=$P(DVBATMP,DVBADLMTR,4)
S X=$C(160)_X
S $P(DVBATMP,DVBADLMTR,4)=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 S NODTA=1 S (SORTDT,XCN,XCFLOC,ANS)=""
I $D(^TMP("DVBA",DVBAT,$J)) F XLINE=1:1:5 W ?5,$S(DVBAT="PEN":MSG,DVBAT="A&A":MSG1,1:""),!!
F G=0:0 S SORTDT=$O(^TMP("DVBA",DVBAT,$J,SORTDT)) Q:SORTDT="" F DVBAM=0:0 S XCN=$O(^TMP("DVBA",DVBAT,$J,SORTDT,XCN)) Q:XCN="" D PRINT1
Q
PRINT1 F J=0:0 S XCFLOC=$O(^TMP("DVBA",DVBAT,$J,SORTDT,XCN,XCFLOC)) Q:XCFLOC="" F K=0:0 S K=$O(^TMP("DVBA",DVBAT,$J,SORTDT,XCN,XCFLOC,K)) Q:K="" D PRINTC
Q
PRINTC F DA=0:0 S DA=$O(^TMP("DVBA",DVBAT,$J,SORTDT,XCN,XCFLOC,K,DA)) Q:DA="" S DATA=^(DA) D PRINTB
Q
;
KILL K ^TMP("DVBA","A&A",$J),^TMP("DVBA","PEN",$J)
K:(DVBAFNLDTE=$P(EDATE,".")) ^XTMP("DVBA_READMISSION_RPT"_$J,0)
D ^%ZISC S X=7 D:$D(ZTQUEUED) KILL^%ZTLOAD G FINAL^DVBAUTIL
;
ELIG S ELIG=DVBAELIG,INCMP=0
W "Eligibility: "
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)),$P(^(.29),U,1)]"" S INCMP=1 ;date ruled incomp, VA
I $D(^DPT(DA,.29)),$P(^(.29),U,12)=1 S INCMP=1 ;ruled incomp field
W ELIG_$S(ELIG]"":", ",1:"") W:$X>60 !?14 W $S(INCMP=1:"Incompetent",1:""),!
Q
;
COLHDR ;Column header for delimited report
N DVBADLMTR
S DVBADLMTR=","
S ^TMP("DVBAR",$J,DVBABCNT)="Patient"_DVBADLMTR_"SSN"_DVBADLMTR_"Claim Folder Loc"_DVBADLMTR
S ^TMP("DVBAR",$J,DVBABCNT)=(^TMP("DVBAR",$J,DVBABCNT))_"Claim #"_DVBADLMTR_"Pension"_DVBADLMTR_"A&A"_DVBADLMTR
S ^TMP("DVBAR",$J,DVBABCNT)=(^TMP("DVBAR",$J,DVBABCNT))_"Current Admission Date"_DVBADLMTR_"Current Admitting Diagnosis"_DVBADLMTR
S ^TMP("DVBAR",$J,DVBABCNT)=(^TMP("DVBAR",$J,DVBABCNT))_"Current Discharge Date"_DVBADLMTR_"Current Discharge Type"_DVBADLMTR
S ^TMP("DVBAR",$J,DVBABCNT)=(^TMP("DVBAR",$J,DVBABCNT))_"Current Bed Service"_DVBADLMTR_"Prior Admission Date"_DVBADLMTR
S ^TMP("DVBAR",$J,DVBABCNT)=(^TMP("DVBAR",$J,DVBABCNT))_"Prior Admitting Diagnosis"_DVBADLMTR_"Prior Discharge Date"_DVBADLMTR
S ^TMP("DVBAR",$J,DVBABCNT)=(^TMP("DVBAR",$J,DVBABCNT))_"Prior Discharge Type"_DVBADLMTR_"Prior Bed Service"
S DVBABCNT=DVBABCNT+1
S ^XTMP("DVBA_READMISSION_RPT"_$J,0)=DT_U_DT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAB98 6445 printed Sep 23, 2025@19:16:45 Page 2
DVBAB98 ;ALB/SPH - CAPRI CONVERSION OF DVBARAD1 FOR SUPPORT ; 3/22/12 8:33am
+1 ;;2.7;AMIE;**35,149,179,185**;Apr 10, 1995;Build 18
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 SET ZX="PENSION "
SET ZY="A & A "
+5 SET MSG=""
FOR ZZ=1:1:7
SET MSG=MSG_ZX
+6 SET MSG1=""
FOR ZZ=1:1:7
SET MSG1=MSG1_ZY
+7 USE IO
KILL DVBAQUIT
+8 FOR DVBAT="PEN","A&A"
if ((IOST?1"C-".E)!(IOST'?1"P-OTHER".E))
WRITE @IOF
WRITE !!!!!!!!!!
DO PRINT
if $DATA(DVBAQUIT)
QUIT
+9 SET ZMSG=$NAME(^TMP("DVBAR",$JOB))
+10 GOTO KILL
+11 ;
PRINTB SET DATA1=$SELECT($DATA(^TMP("DVBA",DVBAT,$JOB,SORTDT,XCN,XCFLOC,K,DA,"LADM")):^("LADM"),1:"")
SET (LADMDT,ADMDT)=$PIECE(DATA1,U)
SET LTDIS=$PIECE(DATA1,U,2)
SET DFN=DA
SET QUIT1=1
KILL DATA1
DO ADM^DVBAVDPT
KILL QUIT1,DVBAQ
+1 SET LBEDSEC=BEDSEC
SET LDIAG=DIAG
SET LDCHGDT=DCHGDT
SET ADMDT=$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)
DO ADM^DVBAVDPT
+2 SET RCVPEN=$SELECT(RCVPEN=0:"NO",RCVPEN=1:"YES",1:"Not specified")
SET RCVAA=$SELECT(RCVAA=0:"NO",RCVAA=1:"YES",1:"Not specified")
+3 WRITE @IOF,!!!,?(80-$LENGTH(HEAD)\2),HEAD,!,?(80-$LENGTH(HEAD1)\2),HEAD1,!,?(80-$LENGTH(HEADDT)\2),HEADDT,!!!
+4 if ADMDT]""
SET ADMDT=$$FMTE^XLFDT(ADMDT,"5DZ")
+5 if DCHGDT]""
SET DCHGDT=$$FMTE^XLFDT(DCHGDT,"5DZ")
+6 if LADMDT]""
SET LADMDT=$$FMTE^XLFDT(LADMDT,"5DZ")
+7 if LDCHGDT]""
SET LDCHGDT=$$FMTE^XLFDT(LDCHGDT,"5DZ")
+8 ;create delimited/non-delimited report
+9 if ($GET(DVBADLMTR)'="")
DO PRINTD
+10 if ($GET(DVBADLMTR)="")
DO PRINTND
+11 QUIT
+12 ;
PRINTND ;create non-delimited re-admission report
+1 SET ^TMP("DVBAR",$JOB,DVBABCNT)=""
SET DVBABCNT=DVBABCNT+1
+2 SET ^TMP("DVBAR",$JOB,DVBABCNT)="Patient: "_PNAM_" SSN: "_SSN_" Claim Folder Loc: "_CFLOC
SET DVBABCNT=DVBABCNT+1
+3 SET ^TMP("DVBAR",$JOB,DVBABCNT)="Claim #: "_CNUM_" Pension: "_RCVPEN_" A&A: "_RCVAA
SET DVBABCNT=DVBABCNT+1
+4 SET ^TMP("DVBAR",$JOB,DVBABCNT)="================================================================================"
SET DVBABCNT=DVBABCNT+1
+5 DO ELIG
+6 SET ^TMP("DVBAR",$JOB,DVBABCNT)="Current Admission Data:"
SET DVBABCNT=DVBABCNT+1
+7 SET ^TMP("DVBAR",$JOB,DVBABCNT)="-----------------------"
SET DVBABCNT=DVBABCNT+1
+8 SET ^TMP("DVBAR",$JOB,DVBABCNT)="Admission Date: "_ADMDT
SET DVBABCNT=DVBABCNT+1
+9 SET ^TMP("DVBAR",$JOB,DVBABCNT)="Admitting Diagnosis: "_DIAG
SET DVBABCNT=DVBABCNT+1
+10 SET ^TMP("DVBAR",$JOB,DVBABCNT)="Discharge Date: "_DCHGDT
SET DVBABCNT=DVBABCNT+1
+11 SET ^TMP("DVBAR",$JOB,DVBABCNT)="Discharge Type: "_TDIS
SET DVBABCNT=DVBABCNT+1
+12 SET ^TMP("DVBAR",$JOB,DVBABCNT)="Bed Service: "_BEDSEC
SET DVBABCNT=DVBABCNT+1
+13 SET ^TMP("DVBAR",$JOB,DVBABCNT)=""
SET DVBABCNT=DVBABCNT+1
+14 SET ^TMP("DVBAR",$JOB,DVBABCNT)="Prior Admission Data:"
SET DVBABCNT=DVBABCNT+1
+15 SET ^TMP("DVBAR",$JOB,DVBABCNT)="---------------------"
SET DVBABCNT=DVBABCNT+1
+16 SET ^TMP("DVBAR",$JOB,DVBABCNT)="Admission Date: "_LADMDT
SET DVBABCNT=DVBABCNT+1
+17 SET ^TMP("DVBAR",$JOB,DVBABCNT)="Admitting Diagnosis: "_LDIAG
SET DVBABCNT=DVBABCNT+1
+18 SET ^TMP("DVBAR",$JOB,DVBABCNT)="Discharge Date: "_LDCHGDT
SET DVBABCNT=DVBABCNT+1
+19 SET ^TMP("DVBAR",$JOB,DVBABCNT)="Discharge Type: "_LTDIS
SET DVBABCNT=DVBABCNT+1
+20 SET ^TMP("DVBAR",$JOB,DVBABCNT)="Bed Service: "_LBEDSEC
SET DVBABCNT=DVBABCNT+1
+21 SET ^TMP("DVBAR",$JOB,DVBABCNT)=""
SET DVBABCNT=DVBABCNT+1
+22 ;I IOST?1"C-".E W *7,!,"Press RETURN to continue or ""^"" to stop " R ANS:DTIME S:ANS=U!('$T) XCN="ZZZZ" I '$T S DVBAQUIT=1
+23 QUIT
+24 ;
PRINTD ;create delimited re-admission report
+1 NEW DVBATMP,X,X1,X2,X3
+2 if ('$DATA(^XTMP("DVBA_READMISSION_RPT"_$JOB,0)))
DO COLHDR
+3 SET ^TMP("DVBAR",$JOB,DVBABCNT)=PNAM_DVBADLMTR_SSN_DVBADLMTR_CFLOC_DVBADLMTR_CNUM_DVBADLMTR_RCVPEN_DVBADLMTR_RCVAA_DVBADLMTR
+4 DO ELIG
+5 SET ^TMP("DVBAR",$JOB,DVBABCNT)=^TMP("DVBAR",$JOB,DVBABCNT)_ADMDT_DVBADLMTR_DIAG_DVBADLMTR_DCHGDT_DVBADLMTR_TDIS_DVBADLMTR_BEDSEC_DVBADLMTR
+6 SET ^TMP("DVBAR",$JOB,DVBABCNT)=^TMP("DVBAR",$JOB,DVBABCNT)_LADMDT_DVBADLMTR_LDIAG_DVBADLMTR_LDCHGDT_DVBADLMTR_LTDIS_DVBADLMTR_LBEDSEC
+7 ;
+8 SET DVBATMP=^TMP("DVBAR",$JOB,DVBABCNT)
+9 SET X=$PIECE(DVBATMP,DVBADLMTR,2)
+10 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
+11 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
+12 SET $PIECE(DVBATMP,DVBADLMTR,2)=X
+13 SET X=$PIECE(DVBATMP,DVBADLMTR,4)
+14 SET X=$CHAR(160)_X
+15 SET $PIECE(DVBATMP,DVBADLMTR,4)=X
+16 FOR I=1:1:$LENGTH(DVBATMP,DVBADLMTR)
IF $PIECE(DVBATMP,DVBADLMTR,I)[","
SET $PIECE(DVBATMP,DVBADLMTR,I)=""""_$PIECE(DVBATMP,DVBADLMTR,I)_""""
+17 SET DVBATMP=$TRANSLATE(DVBATMP,DVBADLMTR,",")
+18 SET ^TMP("DVBAR",$JOB,DVBABCNT)=DVBATMP
+19 ;
+20 SET DVBABCNT=DVBABCNT+1
+21 QUIT
+22 ;
PRINT SET NODTA=1
SET (SORTDT,XCN,XCFLOC,ANS)=""
+1 IF $DATA(^TMP("DVBA",DVBAT,$JOB))
FOR XLINE=1:1:5
WRITE ?5,$SELECT(DVBAT="PEN":MSG,DVBAT="A&A":MSG1,1:""),!!
+2 FOR G=0:0
SET SORTDT=$ORDER(^TMP("DVBA",DVBAT,$JOB,SORTDT))
if SORTDT=""
QUIT
FOR DVBAM=0:0
SET XCN=$ORDER(^TMP("DVBA",DVBAT,$JOB,SORTDT,XCN))
if XCN=""
QUIT
DO PRINT1
+3 QUIT
PRINT1 FOR J=0:0
SET XCFLOC=$ORDER(^TMP("DVBA",DVBAT,$JOB,SORTDT,XCN,XCFLOC))
if XCFLOC=""
QUIT
FOR K=0:0
SET K=$ORDER(^TMP("DVBA",DVBAT,$JOB,SORTDT,XCN,XCFLOC,K))
if K=""
QUIT
DO PRINTC
+1 QUIT
PRINTC FOR DA=0:0
SET DA=$ORDER(^TMP("DVBA",DVBAT,$JOB,SORTDT,XCN,XCFLOC,K,DA))
if DA=""
QUIT
SET DATA=^(DA)
DO PRINTB
+1 QUIT
+2 ;
KILL KILL ^TMP("DVBA","A&A",$JOB),^TMP("DVBA","PEN",$JOB)
+1 if (DVBAFNLDTE=$PIECE(EDATE,"."))
KILL ^XTMP("DVBA_READMISSION_RPT"_$JOB,0)
+2 DO ^%ZISC
SET X=7
if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
GOTO FINAL^DVBAUTIL
+3 ;
ELIG SET ELIG=DVBAELIG
SET INCMP=0
+1 WRITE "Eligibility: "
+2 IF ELIG]""
SET ELIG=ELIG_" ("_$SELECT(DVBAELST="P":"Pend Ver",DVBAELST="R":"Pend Re-verif",DVBAELST="V":"Verified",1:"Not Verified")_")"
+3 ;date ruled incomp, VA
IF $DATA(^DPT(DA,.29))
IF $PIECE(^(.29),U,1)]""
SET INCMP=1
+4 ;ruled incomp field
IF $DATA(^DPT(DA,.29))
IF $PIECE(^(.29),U,12)=1
SET INCMP=1
+5 WRITE ELIG_$SELECT(ELIG]"":", ",1:"")
if $X>60
WRITE !?14
WRITE $SELECT(INCMP=1:"Incompetent",1:""),!
+6 QUIT
+7 ;
COLHDR ;Column header for delimited report
+1 NEW DVBADLMTR
+2 SET DVBADLMTR=","
+3 SET ^TMP("DVBAR",$JOB,DVBABCNT)="Patient"_DVBADLMTR_"SSN"_DVBADLMTR_"Claim Folder Loc"_DVBADLMTR
+4 SET ^TMP("DVBAR",$JOB,DVBABCNT)=(^TMP("DVBAR",$JOB,DVBABCNT))_"Claim #"_DVBADLMTR_"Pension"_DVBADLMTR_"A&A"_DVBADLMTR
+5 SET ^TMP("DVBAR",$JOB,DVBABCNT)=(^TMP("DVBAR",$JOB,DVBABCNT))_"Current Admission Date"_DVBADLMTR_"Current Admitting Diagnosis"_DVBADLMTR
+6 SET ^TMP("DVBAR",$JOB,DVBABCNT)=(^TMP("DVBAR",$JOB,DVBABCNT))_"Current Discharge Date"_DVBADLMTR_"Current Discharge Type"_DVBADLMTR
+7 SET ^TMP("DVBAR",$JOB,DVBABCNT)=(^TMP("DVBAR",$JOB,DVBABCNT))_"Current Bed Service"_DVBADLMTR_"Prior Admission Date"_DVBADLMTR
+8 SET ^TMP("DVBAR",$JOB,DVBABCNT)=(^TMP("DVBAR",$JOB,DVBABCNT))_"Prior Admitting Diagnosis"_DVBADLMTR_"Prior Discharge Date"_DVBADLMTR
+9 SET ^TMP("DVBAR",$JOB,DVBABCNT)=(^TMP("DVBAR",$JOB,DVBABCNT))_"Prior Discharge Type"_DVBADLMTR_"Prior Bed Service"
+10 SET DVBABCNT=DVBABCNT+1
+11 SET ^XTMP("DVBA_READMISSION_RPT"_$JOB,0)=DT_U_DT
+12 QUIT
