- 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 Mar 13, 2025@20:45:07 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
