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)    ;
 
DVBAFNLDTE,MA1
 
BDATE'["." BDATE=BDATE-.0001   ; DVBA*2.7*99
 
DVBABCNT=0
 
RONUM=0
 
RO="N"
 
HEAD="",HEAD1=""
 
DVBAFNLDTE=$S(+$G(DVBADLMTR):+$P(DVBADLMTR,"."),1:0)
 
DVBADLMTR=$S('+$G(DVBADLMTR):"",1:"^")
 
^TMP($JTERM
 
;
SET Q:'$D(^DPT(DA,0))  DFN=DA,DVBASC="" 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")
 
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
 
.'$D(DISTYPE(+TDIS)) Q
 
.TDIS=$S($P(^DG(405.2,+TDIS,0),U,1)]"":$P(^(0),U,1),1:"Unknown discharge type")
 .
MA1=$P(MA,".",1)
 .
^TMP($J,MA1,XCN,CFLOC,MB,DA)=RCVAA_U_RCVPEN_U_CNUM_U_TDIS
 
.Q
 Q
 
;
PRINTB RCVAA=$P(DATA,U),RCVPEN=$P(DATA,U,2),CNUM=$P(DATA,U,3),TDIS=$P(DATA,U,4),DFN=DA,QUIT1=1 DCHGDT^DVBAVDPT
 
W:(IOST?1"C-".E)!($D(DVBAON2)) @IOF
 
!!!,?(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
 
^TMP("DVBAR",$J,DVBABCNT)="",DVBABCNT=DVBABCNT+1
 
;
 
^TMP("DVBAR",$J,DVBABCNT)="          Patient Name:    "_PNAM  DVBABCNT=DVBABCNT+1
 
^TMP("DVBAR",$J,DVBABCNT)="              Claim No:    "_CNUM  DVBABCNT=DVBABCNT+1
 
^TMP("DVBAR",$J,DVBABCNT)="      Claim Folder Loc:    "_CFLOC  DVBABCNT=DVBABCNT+1
 
^TMP("DVBAR",$J,DVBABCNT)="         Social Sec No:    "_SSN  DVBABCNT=DVBABCNT+1
 
^TMP("DVBAR",$J,DVBABCNT)="        Discharge Date:    "_$$FMTE^XLFDT(DCHGDT,"5DZ"),DVBABCNT=DVBABCNT+1
 
^TMP("DVBAR",$J,DVBABCNT)="     Type of Discharge:    "_TDIS,DVBABCNT=DVBABCNT+1
 
LOS^DVBAUTIL
 
^TMP("DVBAR",$J,DVBABCNT)="        Length of Stay:    "_LOS_$S(LOS="":"Discharged same day",LOS=1:" day",1:" days"),DVBABCNT=DVBABCNT+1
 
^TMP("DVBAR",$J,DVBABCNT)="           Bed Service:    "_BEDSEC,DVBABCNT=DVBABCNT+1
 
^TMP("DVBAR",$J,DVBABCNT)="             Recv A&A?:    "_$S(RCVAA="0":"NO",RCVAA="1":"YES",1:"Not specified"),DVBABCNT=DVBABCNT+1
 
^TMP("DVBAR",$J,DVBABCNT)="              Pension?:    "_$S(RCVPEN="0":"NO",RCVPEN="1":"YES",1:"Not specified"),DVBABCNT=DVBABCNT+1
 
;
 ;
 ; ELIG INFO...
 
ELIG=DVBAELIG,INCMP=""
 ;S ZMSG(DVBABCNT)="      Eligibility data:    "
 
ELIG]"" ELIG=ELIG_" ("_$S(DVBAELST="P":"Pend Ver",DVBAELST="R":"Pend Re-verif",DVBAELST="V":"Verified",1:"Not Verified")_")"
 
I $D(^DPT(DA,.29)) INCMP=$S($P(^(.29),U,12)=1:"Incompetent",1:"")
 
^TMP("DVBAR",$J,DVBABCNT)="      Eligibility data:    "_ELIG_$S(((ELIG]"")&(INCMP]"")):", ",1:"")  DVBABCNT=DVBABCNT+1
 
W:$X>60 !?26 ^TMP("DVBAR",$J,DVBABCNT)=INCMP  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
 
DVBAON2=""
 
Q
 
;
PRINTD ;create delimited discharge report
 
ELIG,INCMP,DVBATMP,X,X1,X2,X3
 
D:('$D(^XTMP("DVBA_DISCHARGE_RPT"_$J,0))) COLHDR
 
^TMP("DVBAR",$J,DVBABCNT)=PNAM_DVBADLMTR_CNUM_DVBADLMTR_CFLOC_DVBADLMTR_SSN_DVBADLMTR
 
^TMP("DVBAR",$J,DVBABCNT)=^TMP("DVBAR",$J,DVBABCNT)_$$FMTE^XLFDT(DCHGDT,"5DZ")_DVBADLMTR_TDIS_DVBADLMTR
 
LOS^DVBAUTIL
 
^TMP("DVBAR",$J,DVBABCNT)=^TMP("DVBAR",$J,DVBABCNT)_LOS_$S(LOS="":"Discharged same day",LOS=1:" day",1:" days")_DVBADLMTR
 
^TMP("DVBAR",$J,DVBABCNT)=^TMP("DVBAR",$J,DVBABCNT)_BEDSEC_DVBADLMTR_$S(RCVAA="0":"NO",RCVAA="1":"YES",1:"Not specified")_DVBADLMTR
 
^TMP("DVBAR",$J,DVBABCNT)=^TMP("DVBAR",$J,DVBABCNT)_$S(RCVPEN="0":"NO",RCVPEN="1":"YES",1:"Not specified")_DVBADLMTR
 
;
 
ELIG=DVBAELIG,INCMP=""
 
ELIG]"" ELIG=ELIG_" ("_$S(DVBAELST="P":"Pend Ver",DVBAELST="R":"Pend Re-verif",DVBAELST="V":"Verified",1:"Not Verified")_")"
 
I $D(^DPT(DA,.29)) INCMP=$S($P(^(.29),U,12)=1:"Incompetent",1:"")
 
;
 
^TMP("DVBAR",$J,DVBABCNT)=^TMP("DVBAR",$J,DVBABCNT)_ELIG_$S(((ELIG]"")&(INCMP]"")):", ",1:"")_INCMP
 
;
 
DVBATMP=^TMP("DVBAR",$J,DVBABCNT)
 
X=$P(DVBATMP,DVBADLMTR,4)
 
I $L(X)'>9 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)'?.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
 
X=$P(DVBATMP,DVBADLMTR,2)
 
X=$C(160)_X
 
S $P(DVBATMP,DVBADLMTR,2)=X
 
I=1:1:$L(DVBATMP,DVBADLMTRI $P(DVBATMP,DVBADLMTR,I)["," S $P(DVBATMP,DVBADLMTR,I)=""""_$P(DVBATMP,DVBADLMTR,I)_""""
 
DVBATMP=$TR(DVBATMP,DVBADLMTR,",")
 
^TMP("DVBAR",$J,DVBABCNT)=DVBATMP
 
;
 
DVBABCNT=DVBABCNT+1
 
Q
 
;
PRINT IO QUIT=""
 
MA="" G=0:0 MA=$O(^TMP($J,MA)) Q:MA=""!(QUIT=1)  XCN="" M=0:0 XCN=$O(^TMP($J,MA,XCN)) Q:XCN=""!(QUIT=1)  CFLOC="" J=0:0 CFLOC=$O(^TMP($J,MA,XCN,CFLOC)) Q:CFLOC=""!(QUIT=1)  PRINT1
 
Q
PRINT1 ADM="" K=0:0 ADM=$O(^TMP($J,MA,XCN,CFLOC,ADM)) Q:ADM=""!(QUIT=1)  DA="" L=0:0 DA=$O(^TMP($J,MA,XCN,CFLOC,ADM,DA)) Q:DA=""!(QUIT=1)  DATA=^(DAPRINTB
 
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")
 
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
 
EN^DVBAB99("DVBA DISCHARGE TYPES")
 
ACCEPT^DVBALD
 
'$D(DVBACEPTKILL^DVBAUTIL Q
 I 
'$O(^TMP("DVBA",$J,"DUP",0)) 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")) ZTRTN="DEQUE^DVBADSRT",ZTIO=ION,NOASK=1,ZTDESC="AMIE DISCHARGE REPORT" I="DISTYPE(","ADTYPE","DVBATYPS","BDATE","BDATE1","EDATE","FDT(0)","HEAD","HEAD1","HD","RO","RONUM","NOASK" ZTSAVE(I)=""
 
I $D(IO("Q")) ^%ZTLOAD W:$D(ZTSK) !!,"Request queued.",! KILL
 
;
GO MA=BDATE J=0:0 MA=$O(^DGPM("AMV3",MA)) Q:MA>EDATE!(MA="")  W:'$D(NOASK"." DA=0:0 DA=$O(^DGPM("AMV3",MA,DA)) Q:DA=""  MB=0:0 MB=$O(^DGPM("AMV3",MA,DA,MB)) Q:MB=""  SET
 
'$D(^TMP($J)) D  H KILL
 
.DVBAERTXT DVBAERTXT="No data found for parameters entered."
 
.IO !!,*7,DVBAERTXT,!!
 .
S:($G(DVBADLMTR)'="") ^TMP("DVBAR",$J,DVBABCNT)=DVBAERTXT
 
PRINT K:(DVBAFNLDTE=$P(EDATE,".")) ^XTMP("DVBA_DISCHARGE_RPT"_$J,0)
 
I $D(DVBAQUITDVBAON2,DISTYPE KILL^DVBAUTIL
 
;
KILL K:(DVBAFNLDTE=$P(EDATE,".")) ^XTMP("DVBA_DISCHARGE_RPT"_$J,0)
 
ZMSG=$NA(^TMP("DVBAR",$J))
 
^%ZISC D:$D(ZTQUEUEDKILL^%ZTLOAD X=4 DVBAON2,DISTYPE FINAL^DVBAUTIL
 
;
DEQUE ^TMP($JGO
 
;
COLHDR ;Column header for delimited report
 
DVBADLMTR
 
DVBADLMTR=","
 
^TMP("DVBAR",$J,DVBABCNT)="Patient Name"_DVBADLMTR_"Claim No"_DVBADLMTR_"Claim Folder Loc"_DVBADLMTR
 
^TMP("DVBAR",$J,DVBABCNT)=(^TMP("DVBAR",$J,DVBABCNT))_"Social Sec No"_DVBADLMTR_"Discharge Date"_DVBADLMTR
 
^TMP("DVBAR",$J,DVBABCNT)=(^TMP("DVBAR",$J,DVBABCNT))_"Type of Discharge"_DVBADLMTR_"Length of Stay"_DVBADLMTR
 
^TMP("DVBAR",$J,DVBABCNT)=(^TMP("DVBAR",$J,DVBABCNT))_"Bed Service"_DVBADLMTR_"Recv A&A?"_DVBADLMTR
 
^TMP("DVBAR",$J,DVBABCNT)=(^TMP("DVBAR",$J,DVBABCNT))_"Pension?"_DVBADLMTR_"Eligibility Data"
 
DVBABCNT=DVBABCNT+1
 
;set global entry so header is only created once for job ($J)
 
^XTMP("DVBA_DISCHARGE_RPT"_$J,0)=DT_U_DT_U_BDATE_U_EDATE
 
Q