DVBASPD2 ;ALB/GTS-557/THM,SBW-AMIE SPECIAL REPORT ; 3/MAY/2011
;;2.7;AMIE;**3,57,149,168,185**;Apr 10, 1995;Build 18
;Per VHA Directive 2004-038, this routine should not be modified.
;
K ^TMP($J) G TERM
SET Q:'$D(^DPT(DA,0)) S DFN=DA D RCV^DVBAVDPT Q:RCVPEN'=1&(REP="P") Q:RCVAA'=1&(REP="A") Q:CFLOC'=RONUM&(RO="Y")&(CFLOC'=0)&(CFLOC'=376)
S DCHPTR=$P(^DGPM(MB,0),U,17),TDIS=$S($D(^DGPM(+DCHPTR,0)):$P(^(0),U,18),1:"")
I +TDIS,'$D(^TMP("DVBA",$J,"DUP",+TDIS)) Q
S TDIS=$S($P($G(^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
;
PRINTB W:(IOST?1"C-".E)!($D(DVBAON2)) @IOF
W !!!,?(80-$L(HEAD)\2),HEAD,!,?(80-$L(HEAD1)\2),HEAD1,!!
W ?10,REP(0),?26,PNAM,!!,?14,REP(1),?26,CNUM,!,?6,REP(2),?26,XCFLOC,!,?9,REP(3),?26,SSN,!,?8,REP(4),?26,ADMDT,!,?3,REP(5),?26,DIAG,!
W ?8,REP(6),?26,DCHGDT,! W:DCHGDT]"" ?5,REP(7),?26,$$DIS,!
W ?11,REP(8),?26,BEDSEC,!,?13,REP(9),?26,$$RAA,!
W ?14,REP(10),?26,$$PEN,! 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 '$T S DVBAQUIT=1 I '$T S DVBAQUIT=1
S DVBAON2=""
Q
RAA() Q $S(RCVAA=0:"NO",RCVAA=1:"YES",1:"Not specified")
PEN() Q $S(RCVPEN=0:"NO",RCVPEN=1:"YES",1:"Not specified")
DIS() Q TDIS_$S(TO]"":" TO "_$S($D(^DIC(4,+TO,0)):$P(^(0),U,1),1:""),1:"")
SP(N,M) S $P(M," ",N-1)=" " Q M ;pass one arg, 2nd for local use
PRINTC F J=0:1:7 S ^TMP("DVBSPCRP",$J,DVBC+J)=DVBS(J) ;NakedRefs = ^TMP("DVBSPCRP",$J,DVBC+J)
S DVBC=DVBC+6,^TMP("DVBSPCRP",$J,DVBC)=$$SP(10)_REP(0)_PNAM
S ^(DVBC+2)=$$SP(14)_REP(1)_CNUM
S ^(DVBC+3)=$$SP(6)_REP(2)_XCFLOC
S ^(DVBC+4)=$$SP(9)_REP(3)_SSN
S ^(DVBC+5)=$$SP(8)_REP(4)_ADMDT
S ^(DVBC+6)=$$SP(3)_REP(5)_DIAG
S DVBC=DVBC+7,^(DVBC)=$$SP(8)_REP(6)_DCHGDT
I DCHGDT]"" D
.S DVBC=DVBC+1,^(DVBC)=$$SP(5)_REP(7)_$$DIS
S ^(DVBC+1)=$$SP(11)_REP(8)_BEDSEC
S ^(DVBC+2)=$$SP(13)_REP(9)_$$RAA
S DVBC=DVBC+3,^(DVBC)=$$SP(14)_REP(10)_$$PEN
D ELIG^DVBAVDPT
Q
;
PRINTD ;print delimited special report
N ELIG,INCMP,DVBADATA,DVBABRKER,X,X1,X2,X3
S DVBABRKER=$$BROKER^XWBLIB
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:"")
I INCMP]"",ELIG]"" S ELIG=ELIG_", "_INCMP
D:('DVBADHDR) COLHDR
S DVBADATA=PNAM_DVBADLMTR_CNUM_DVBADLMTR_XCFLOC_DVBADLMTR
S DVBADATA=DVBADATA_SSN_DVBADLMTR_ADMDT_DVBADLMTR_DIAG_DVBADLMTR_DCHGDT_DVBADLMTR
S DVBADATA=DVBADATA_$S(DCHGDT]"":$$DIS,1:"")_DVBADLMTR_BEDSEC_DVBADLMTR
S DVBADATA=DVBADATA_$$RAA_DVBADLMTR_$$PEN_DVBADLMTR_ELIG
;
S X=$P(DVBADATA,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(DVBADATA,DVBADLMTR,4)=X
S X=$P(DVBADATA,DVBADLMTR,2)
S X=$C(160)_X
S $P(DVBADATA,DVBADLMTR,2)=X
F I=1:1:$L(DVBADATA,DVBADLMTR) I $P(DVBADATA,DVBADLMTR,I)["," S $P(DVBADATA,DVBADLMTR,I)=""""_$P(DVBADATA,DVBADLMTR,I)_""""
S DVBADATA=$TR(DVBADATA,DVBADLMTR,",")
;
D:DVBABRKER
.S ^TMP("DVBSPCRP",$J,DVBC)=DVBADATA,DVBC=DVBC+1
D:('DVBABRKER)
.W !,DVBADATA
Q
;
PRINT S QUIT="",XCN=""
F S XCN=$O(^TMP($J,XCN)) Q:XCN=""!(QUIT=1) S XCFLOC="" F S XCFLOC=$O(^TMP($J,XCN,XCFLOC)) Q:XCFLOC=""!(QUIT=1) D PRINT1
Q
PRINT1 S ADM="" F S ADM=$O(^TMP($J,XCN,XCFLOC,ADM)) Q:ADM=""!(QUIT=1) D
.S DA="" F S DA=$O(^TMP($J,XCN,XCFLOC,ADM,DA)) Q:DA=""!(QUIT=1) D
..S DATA=^(DA),MA=$P(DATA,U),RCVAA=$P(DATA,U,2),RCVPEN=$P(DATA,U,3)
..S CNUM=$P(DATA,U,4),TDIS=$P(DATA,U,5),DFN=DA,TO="",QUIT1=1
..D ADM^DVBAVDPT
..S:ADMDT]"" ADMDT=$E(ADMDT,4,5)_"/"_$E(ADMDT,6,7)_"/"_$E(ADMDT,2,3)
..S:DCHGDT]"" DCHGDT=$E(DCHGDT,4,5)_"/"_$E(DCHGDT,6,7)_"/"_$E(DCHGDT,2,3)
..I $$BROKER^XWBLIB D @$S(($G(DVBADLMTR)=""):"PRINTC",1:"PRINTD") Q
..D @$S(($G(DVBADLMTR)=""):"PRINTB",1:"PRINTD")
Q
SETUP S RPT="VARO REPORT"_$S(REP="A":" FOR A & A",1:" FOR PENSION"),DTAR=^DVB(396.1,1,0),FDT(0)=$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)
S HEAD="SPECIAL "_$S(REP="A":"A & A",1:"PENSION")_" REPORT",HEAD1="FOR "_$P(DTAR,U,1)_" ON "_FDT(0)
S Y=$P(DTAR,U,9) X ^DD("DD") S REP("LRUN")="Last report was run on "_Y
S REP(0)="Patient Name:",REP(1)="Claim No:"
S REP(2)="Claim Folder Loc:",REP(3)="Social Sec No:"
S REP(4)="Admission Date:",REP(5)="Admitting Diagnosis:"
S REP(6)="Discharge Date:",REP(7)="Type of Discharge:"
S REP(8)="Bed Service:",REP(9)="Recv A&A?:",REP(10)="Pension?:"
Q
TERM D HOME^%ZIS,SETUP K NOASK
W @IOF,!,RPT,!,HEAD1
;
EN1 W !!,"Please enter dates for search, oldest date first, most recent date last.",!!,REP("LRUN"),!!
D DATE^DVBAUTIL
G:X=""!(Y<0) KILL
S %ZIS="Q" D ^%ZIS K %ZIS G:POP KILL^DVBAUTIL
;
QUEUE I $D(IO("Q")) S ZTRTN="DEQUE^DVBASPD2",ZTIO=ION,NOASK=1,ZTDESC="AMIE PENSION/A&A REPORT" F I="^TMP(""DVBA"",$J,""DUP"",","DVBATYPS","REP","FDT(0)","HEAD","HEAD1","BDATE","EDATE","TYPE","RO","RONUM","NOASK" S ZTSAVE(I)=""
I $D(IO("Q")) D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued.",!! G KILL
;
GO S MA=BDATE F S MA=$O(^DGPM("AMV1",MA)) Q:$P(MA,".")>EDATE!(MA="") W:'$D(NOASK) "." F DA=0:0 S DA=$O(^DGPM("AMV1",MA,DA)) Q:DA="" F MB=0:0 S MB=$O(^DGPM("AMV1",MA,DA,MB)) Q:MB="" D SET
S:'$D(^TMP($J)) ER="No data found for parameters entered."
G:$$BROKER^XWBLIB BROKER
U IO I $D(ER) W !!,*7,ER,!! G KILL
D PRINT
I $D(DVBAQUIT) D:$D(ZTQUEUED) KILL^%ZTLOAD K ER,DVBAON2 G KILL^DVBAUTIL
;
KILL D ^%ZISC D:$D(ZTQUEUED) KILL^%ZTLOAD S X=9 K ER,DVBAON2 G FINAL^DVBAUTIL
;
INIT ;add header info to report
I ($G(DVBADLMTR)'="") D Q ;no header info for delimited report
.S DVBC=1
F J=0,2,5,6,7 S DVBS(J)=" "
S $P(DVBS(1),"-",70)="-",DVBS(3)=$$SP(70-$L(HEAD)\2)_HEAD,DVBS(4)=$$SP(70-$L(HEAD1)\2)_HEAD1
S ^TMP("DVBSPCRP",$J,1)=" ",^(2)=RPT,^(3)=HEAD1,^(4)=" ",^(5)=REP("LRUN"),DVBC=6
F J=0:1:10 S REP(J)=REP(J)_" "
Q
BROKER I $D(ER) K ^TMP("DVBSPCRP",$J) S ^($J,1)=ER
E D INIT,PRINT
S X=9 G FINAL^DVBAUTIL
;
;Input: DVBADLMTR - Indicates if report should be delimited (Optional)
SPECRPT(ZMSG,DCTYPES,BDATE,EDATE,RONUM,REP,DVBADLMTR) ;
N I,J,REQ,DVBC,DVBACEPT,DVBS,ER,DVBADHDR
S DVBADLMTR=$S('+$G(DVBADLMTR):"",1:"^"),DVBADHDR=0
; If RONUM not passed set value to "0" (zero) in order to include data
; for all regional offices
I $G(RONUM)']"" S RONUM=0
S ZMSG=$NA(^TMP("DVBSPCRP",$J)),REQ=" IS REQUIRED"
S MB=" MUST BE ",TYPE="REPORT TYPE",BDT="BEGINNING DATE",EDT="ENDING DATE"
I $G(BDATE)="" S ER=BDT_REQ
I $G(EDATE)="" S ER=EDT_REQ
I EDATE<BDATE S ER=BDT_MB_"BEFORE THE "_EDT
I $G(REP)="" S ER=TYPE_REQ
I "^A^P"'[REP S ER=TYPE_MB_"'A' OR 'P'"
;Only validate RONUM to be valid Station Number if it isn't zero
I RONUM'="0"&(RONUM'?3N.4AN) S ER="REGIONAL OFFICE"_MB_"3 NUMBERS + OPTIONAL 1 TO 4 MODIFIER (MAX 7 CHARACTERS)"
K ^TMP("DVBSPCRP",$J) I $D(ER) S ^($J,1)=ER,X=9 G FINAL^DVBAUTIL
;If RONUM = 0 then RO set to "N" to include data for all ROs
;If RONUM passed then RO set to "Y" to include data for only passed RO
S (NOASK,DVBACEPT)=1,RO=$S(RONUM=0:"N",1:"Y")
F J=0:0 S J=$O(DCTYPES(J)) Q:'J S ^TMP("DVBA",$J,"DUP",DCTYPES(J))=""
D SETUP
DEQUE K ^TMP($J) G GO
;
COLHDR ;Column header for delimited report
N DVBACHDR,DVBABRKER,DVBADLMTR
S DVBADLMTR=","
S DVBABRKER=$$BROKER^XWBLIB
S DVBACHDR="Patient Name"_DVBADLMTR_"Claim No"_DVBADLMTR_"Claim Folder Loc"_DVBADLMTR
S DVBACHDR=DVBACHDR_"Social Sec No"_DVBADLMTR_"Admission Date"_DVBADLMTR_"Admitting Diagnosis"_DVBADLMTR
S DVBACHDR=DVBACHDR_"Discharge Date"_DVBADLMTR_"Type of Discharge"_DVBADLMTR_"Bed Service"_DVBADLMTR
S DVBACHDR=DVBACHDR_"Recv A&A?"_DVBADLMTR_"Pension?"_DVBADLMTR_"Eligibility Data"
S:DVBABRKER ^TMP("DVBSPCRP",$J,DVBC)=DVBACHDR,DVBC=DVBC+1
D:('DVBABRKER)
.W !,DVBACHDR
S DVBADHDR=1 ;set so header info only printed once
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBASPD2 8075 printed Sep 23, 2025@19:18:11 Page 2
DVBASPD2 ;ALB/GTS-557/THM,SBW-AMIE SPECIAL REPORT ; 3/MAY/2011
+1 ;;2.7;AMIE;**3,57,149,168,185**;Apr 10, 1995;Build 18
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 KILL ^TMP($JOB)
GOTO TERM
SET if '$DATA(^DPT(DA,0))
QUIT
SET DFN=DA
DO RCV^DVBAVDPT
if RCVPEN'=1&(REP="P")
QUIT
if RCVAA'=1&(REP="A")
QUIT
if CFLOC'=RONUM&(RO="Y")&(CFLOC'=0)&(CFLOC'=376)
QUIT
+1 SET DCHPTR=$PIECE(^DGPM(MB,0),U,17)
SET TDIS=$SELECT($DATA(^DGPM(+DCHPTR,0)):$PIECE(^(0),U,18),1:"")
+2 IF +TDIS
IF '$DATA(^TMP("DVBA",$JOB,"DUP",+TDIS))
QUIT
+3 SET TDIS=$SELECT($PIECE($GET(^DG(405.2,+TDIS,0)),U,1)]"":$PIECE(^(0),U,1),1:"Unknown discharge type")
+4 SET ^TMP($JOB,XCN,CFLOC,MB,DA)=MA_U_RCVAA_U_RCVPEN_U_CNUM_U_TDIS
+5 QUIT
+6 ;
PRINTB if (IOST?1"C-".E)!($DATA(DVBAON2))
WRITE @IOF
+1 WRITE !!!,?(80-$LENGTH(HEAD)\2),HEAD,!,?(80-$LENGTH(HEAD1)\2),HEAD1,!!
+2 WRITE ?10,REP(0),?26,PNAM,!!,?14,REP(1),?26,CNUM,!,?6,REP(2),?26,XCFLOC,!,?9,REP(3),?26,SSN,!,?8,REP(4),?26,ADMDT,!,?3,REP(5),?26,DIAG,!
+3 WRITE ?8,REP(6),?26,DCHGDT,!
if DCHGDT]""
WRITE ?5,REP(7),?26,$$DIS,!
+4 WRITE ?11,REP(8),?26,BEDSEC,!,?13,REP(9),?26,$$RAA,!
+5 WRITE ?14,REP(10),?26,$$PEN,!
DO ELIG^DVBAVDPT
+6 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 '$TEST
SET DVBAQUIT=1
IF '$TEST
SET DVBAQUIT=1
+7 SET DVBAON2=""
+8 QUIT
RAA() QUIT $SELECT(RCVAA=0:"NO",RCVAA=1:"YES",1:"Not specified")
PEN() QUIT $SELECT(RCVPEN=0:"NO",RCVPEN=1:"YES",1:"Not specified")
DIS() QUIT TDIS_$SELECT(TO]"":" TO "_$SELECT($DATA(^DIC(4,+TO,0)):$PIECE(^(0),U,1),1:""),1:"")
SP(N,M) ;pass one arg, 2nd for local use
SET $PIECE(M," ",N-1)=" "
QUIT M
PRINTC ;NakedRefs = ^TMP("DVBSPCRP",$J,DVBC+J)
FOR J=0:1:7
SET ^TMP("DVBSPCRP",$JOB,DVBC+J)=DVBS(J)
+1 SET DVBC=DVBC+6
SET ^TMP("DVBSPCRP",$JOB,DVBC)=$$SP(10)_REP(0)_PNAM
+2 SET ^(DVBC+2)=$$SP(14)_REP(1)_CNUM
+3 SET ^(DVBC+3)=$$SP(6)_REP(2)_XCFLOC
+4 SET ^(DVBC+4)=$$SP(9)_REP(3)_SSN
+5 SET ^(DVBC+5)=$$SP(8)_REP(4)_ADMDT
+6 SET ^(DVBC+6)=$$SP(3)_REP(5)_DIAG
+7 SET DVBC=DVBC+7
SET ^(DVBC)=$$SP(8)_REP(6)_DCHGDT
+8 IF DCHGDT]""
Begin DoDot:1
+9 SET DVBC=DVBC+1
SET ^(DVBC)=$$SP(5)_REP(7)_$$DIS
End DoDot:1
+10 SET ^(DVBC+1)=$$SP(11)_REP(8)_BEDSEC
+11 SET ^(DVBC+2)=$$SP(13)_REP(9)_$$RAA
+12 SET DVBC=DVBC+3
SET ^(DVBC)=$$SP(14)_REP(10)_$$PEN
+13 DO ELIG^DVBAVDPT
+14 QUIT
+15 ;
PRINTD ;print delimited special report
+1 NEW ELIG,INCMP,DVBADATA,DVBABRKER,X,X1,X2,X3
+2 SET DVBABRKER=$$BROKER^XWBLIB
+3 SET ELIG=DVBAELIG
SET INCMP=""
+4 IF ELIG]""
SET ELIG=ELIG_" ("_$SELECT(DVBAELST="P":"Pend Ver",DVBAELST="R":"Pend Re-verif",DVBAELST="V":"Verified",1:"Not Verified")_")"
+5 IF $DATA(^DPT(DA,.29))
SET INCMP=$SELECT($PIECE(^(.29),U,12)=1:"Incompetent",1:"")
+6 IF INCMP]""
IF ELIG]""
SET ELIG=ELIG_", "_INCMP
+7 if ('DVBADHDR)
DO COLHDR
+8 SET DVBADATA=PNAM_DVBADLMTR_CNUM_DVBADLMTR_XCFLOC_DVBADLMTR
+9 SET DVBADATA=DVBADATA_SSN_DVBADLMTR_ADMDT_DVBADLMTR_DIAG_DVBADLMTR_DCHGDT_DVBADLMTR
+10 SET DVBADATA=DVBADATA_$SELECT(DCHGDT]"":$$DIS,1:"")_DVBADLMTR_BEDSEC_DVBADLMTR
+11 SET DVBADATA=DVBADATA_$$RAA_DVBADLMTR_$$PEN_DVBADLMTR_ELIG
+12 ;
+13 SET X=$PIECE(DVBADATA,DVBADLMTR,4)
+14 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
+15 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
+16 SET $PIECE(DVBADATA,DVBADLMTR,4)=X
+17 SET X=$PIECE(DVBADATA,DVBADLMTR,2)
+18 SET X=$CHAR(160)_X
+19 SET $PIECE(DVBADATA,DVBADLMTR,2)=X
+20 FOR I=1:1:$LENGTH(DVBADATA,DVBADLMTR)
IF $PIECE(DVBADATA,DVBADLMTR,I)[","
SET $PIECE(DVBADATA,DVBADLMTR,I)=""""_$PIECE(DVBADATA,DVBADLMTR,I)_""""
+21 SET DVBADATA=$TRANSLATE(DVBADATA,DVBADLMTR,",")
+22 ;
+23 if DVBABRKER
Begin DoDot:1
+24 SET ^TMP("DVBSPCRP",$JOB,DVBC)=DVBADATA
SET DVBC=DVBC+1
End DoDot:1
+25 if ('DVBABRKER)
Begin DoDot:1
+26 WRITE !,DVBADATA
End DoDot:1
+27 QUIT
+28 ;
PRINT SET QUIT=""
SET XCN=""
+1 FOR
SET XCN=$ORDER(^TMP($JOB,XCN))
if XCN=""!(QUIT=1)
QUIT
SET XCFLOC=""
FOR
SET XCFLOC=$ORDER(^TMP($JOB,XCN,XCFLOC))
if XCFLOC=""!(QUIT=1)
QUIT
DO PRINT1
+2 QUIT
PRINT1 SET ADM=""
FOR
SET ADM=$ORDER(^TMP($JOB,XCN,XCFLOC,ADM))
if ADM=""!(QUIT=1)
QUIT
Begin DoDot:1
+1 SET DA=""
FOR
SET DA=$ORDER(^TMP($JOB,XCN,XCFLOC,ADM,DA))
if DA=""!(QUIT=1)
QUIT
Begin DoDot:2
+2 SET DATA=^(DA)
SET MA=$PIECE(DATA,U)
SET RCVAA=$PIECE(DATA,U,2)
SET RCVPEN=$PIECE(DATA,U,3)
+3 SET CNUM=$PIECE(DATA,U,4)
SET TDIS=$PIECE(DATA,U,5)
SET DFN=DA
SET TO=""
SET QUIT1=1
+4 DO ADM^DVBAVDPT
+5 if ADMDT]""
SET ADMDT=$EXTRACT(ADMDT,4,5)_"/"_$EXTRACT(ADMDT,6,7)_"/"_$EXTRACT(ADMDT,2,3)
+6 if DCHGDT]""
SET DCHGDT=$EXTRACT(DCHGDT,4,5)_"/"_$EXTRACT(DCHGDT,6,7)_"/"_$EXTRACT(DCHGDT,2,3)
+7 IF $$BROKER^XWBLIB
DO @$SELECT(($GET(DVBADLMTR)=""):"PRINTC",1:"PRINTD")
QUIT
+8 DO @$SELECT(($GET(DVBADLMTR)=""):"PRINTB",1:"PRINTD")
End DoDot:2
End DoDot:1
+9 QUIT
SETUP SET RPT="VARO REPORT"_$SELECT(REP="A":" FOR A & A",1:" FOR PENSION")
SET DTAR=^DVB(396.1,1,0)
SET FDT(0)=$EXTRACT(DT,4,5)_"-"_$EXTRACT(DT,6,7)_"-"_$EXTRACT(DT,2,3)
+1 SET HEAD="SPECIAL "_$SELECT(REP="A":"A & A",1:"PENSION")_" REPORT"
SET HEAD1="FOR "_$PIECE(DTAR,U,1)_" ON "_FDT(0)
+2 SET Y=$PIECE(DTAR,U,9)
XECUTE ^DD("DD")
SET REP("LRUN")="Last report was run on "_Y
+3 SET REP(0)="Patient Name:"
SET REP(1)="Claim No:"
+4 SET REP(2)="Claim Folder Loc:"
SET REP(3)="Social Sec No:"
+5 SET REP(4)="Admission Date:"
SET REP(5)="Admitting Diagnosis:"
+6 SET REP(6)="Discharge Date:"
SET REP(7)="Type of Discharge:"
+7 SET REP(8)="Bed Service:"
SET REP(9)="Recv A&A?:"
SET REP(10)="Pension?:"
+8 QUIT
TERM DO HOME^%ZIS
DO SETUP
KILL NOASK
+1 WRITE @IOF,!,RPT,!,HEAD1
+2 ;
EN1 WRITE !!,"Please enter dates for search, oldest date first, most recent date last.",!!,REP("LRUN"),!!
+1 DO DATE^DVBAUTIL
+2 if X=""!(Y<0)
GOTO KILL
+3 SET %ZIS="Q"
DO ^%ZIS
KILL %ZIS
if POP
GOTO KILL^DVBAUTIL
+4 ;
QUEUE IF $DATA(IO("Q"))
SET ZTRTN="DEQUE^DVBASPD2"
SET ZTIO=ION
SET NOASK=1
SET ZTDESC="AMIE PENSION/A&A REPORT"
FOR I="^TMP(""DVBA"",$J,""DUP"",","DVBATYPS","REP","FDT(0)","HEAD","HEAD1","BDATE","EDATE","TYPE","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
SET MA=$ORDER(^DGPM("AMV1",MA))
if $PIECE(MA,".")>EDATE!(MA="")
QUIT
if '$DATA(NOASK)
WRITE "."
FOR DA=0:0
SET DA=$ORDER(^DGPM("AMV1",MA,DA))
if DA=""
QUIT
FOR MB=0:0
SET MB=$ORDER(^DGPM("AMV1",MA,DA,MB))
if MB=""
QUIT
DO SET
+1 if '$DATA(^TMP($JOB))
SET ER="No data found for parameters entered."
+2 if $$BROKER^XWBLIB
GOTO BROKER
+3 USE IO
IF $DATA(ER)
WRITE !!,*7,ER,!!
GOTO KILL
+4 DO PRINT
+5 IF $DATA(DVBAQUIT)
if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
KILL ER,DVBAON2
GOTO KILL^DVBAUTIL
+6 ;
KILL DO ^%ZISC
if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
SET X=9
KILL ER,DVBAON2
GOTO FINAL^DVBAUTIL
+1 ;
INIT ;add header info to report
+1 ;no header info for delimited report
IF ($GET(DVBADLMTR)'="")
Begin DoDot:1
+2 SET DVBC=1
End DoDot:1
QUIT
+3 FOR J=0,2,5,6,7
SET DVBS(J)=" "
+4 SET $PIECE(DVBS(1),"-",70)="-"
SET DVBS(3)=$$SP(70-$LENGTH(HEAD)\2)_HEAD
SET DVBS(4)=$$SP(70-$LENGTH(HEAD1)\2)_HEAD1
+5 SET ^TMP("DVBSPCRP",$JOB,1)=" "
SET ^(2)=RPT
SET ^(3)=HEAD1
SET ^(4)=" "
SET ^(5)=REP("LRUN")
SET DVBC=6
+6 FOR J=0:1:10
SET REP(J)=REP(J)_" "
+7 QUIT
BROKER IF $DATA(ER)
KILL ^TMP("DVBSPCRP",$JOB)
SET ^($JOB,1)=ER
+1 IF '$TEST
DO INIT
DO PRINT
+2 SET X=9
GOTO FINAL^DVBAUTIL
+3 ;
+4 ;Input: DVBADLMTR - Indicates if report should be delimited (Optional)
SPECRPT(ZMSG,DCTYPES,BDATE,EDATE,RONUM,REP,DVBADLMTR) ;
+1 NEW I,J,REQ,DVBC,DVBACEPT,DVBS,ER,DVBADHDR
+2 SET DVBADLMTR=$SELECT('+$GET(DVBADLMTR):"",1:"^")
SET DVBADHDR=0
+3 ; If RONUM not passed set value to "0" (zero) in order to include data
+4 ; for all regional offices
+5 IF $GET(RONUM)']""
SET RONUM=0
+6 SET ZMSG=$NAME(^TMP("DVBSPCRP",$JOB))
SET REQ=" IS REQUIRED"
+7 SET MB=" MUST BE "
SET TYPE="REPORT TYPE"
SET BDT="BEGINNING DATE"
SET EDT="ENDING DATE"
+8 IF $GET(BDATE)=""
SET ER=BDT_REQ
+9 IF $GET(EDATE)=""
SET ER=EDT_REQ
+10 IF EDATE<BDATE
SET ER=BDT_MB_"BEFORE THE "_EDT
+11 IF $GET(REP)=""
SET ER=TYPE_REQ
+12 IF "^A^P"'[REP
SET ER=TYPE_MB_"'A' OR 'P'"
+13 ;Only validate RONUM to be valid Station Number if it isn't zero
+14 IF RONUM'="0"&(RONUM'?3N.4AN)
SET ER="REGIONAL OFFICE"_MB_"3 NUMBERS + OPTIONAL 1 TO 4 MODIFIER (MAX 7 CHARACTERS)"
+15 KILL ^TMP("DVBSPCRP",$JOB)
IF $DATA(ER)
SET ^($JOB,1)=ER
SET X=9
GOTO FINAL^DVBAUTIL
+16 ;If RONUM = 0 then RO set to "N" to include data for all ROs
+17 ;If RONUM passed then RO set to "Y" to include data for only passed RO
+18 SET (NOASK,DVBACEPT)=1
SET RO=$SELECT(RONUM=0:"N",1:"Y")
+19 FOR J=0:0
SET J=$ORDER(DCTYPES(J))
if 'J
QUIT
SET ^TMP("DVBA",$JOB,"DUP",DCTYPES(J))=""
+20 DO SETUP
DEQUE KILL ^TMP($JOB)
GOTO GO
+1 ;
COLHDR ;Column header for delimited report
+1 NEW DVBACHDR,DVBABRKER,DVBADLMTR
+2 SET DVBADLMTR=","
+3 SET DVBABRKER=$$BROKER^XWBLIB
+4 SET DVBACHDR="Patient Name"_DVBADLMTR_"Claim No"_DVBADLMTR_"Claim Folder Loc"_DVBADLMTR
+5 SET DVBACHDR=DVBACHDR_"Social Sec No"_DVBADLMTR_"Admission Date"_DVBADLMTR_"Admitting Diagnosis"_DVBADLMTR
+6 SET DVBACHDR=DVBACHDR_"Discharge Date"_DVBADLMTR_"Type of Discharge"_DVBADLMTR_"Bed Service"_DVBADLMTR
+7 SET DVBACHDR=DVBACHDR_"Recv A&A?"_DVBADLMTR_"Pension?"_DVBADLMTR_"Eligibility Data"
+8 if DVBABRKER
SET ^TMP("DVBSPCRP",$JOB,DVBC)=DVBACHDR
SET DVBC=DVBC+1
+9 if ('DVBABRKER)
Begin DoDot:1
+10 WRITE !,DVBACHDR
End DoDot:1
+11 ;set so header info only printed once
SET DVBADHDR=1
+12 QUIT
