Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DVBAB54

DVBAB54.m

Go to the documentation of this file. 
  1. DVBAB54 ;ALB/VM - CAPRI ADMISSION REPORT ; 3/5/12 11:31am
  1.  ;;2.7;AMIE;**35,149,179,185**;Apr 10, 1995;Build 18
  1.  ;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1.  ;Input: ZMSG  - Output Array for SC Veteran Admission report (By Ref)
  1.  ;       BDATE     - Beginning date for eport (FM Format)
  1.  ;       EDATE     - Ending date for report (FM Format)
  1.  ;       DVBADLMTR - Indicates if report should be delimited (Optional)
  1.  ;                    CAPRI currently executes RPC by each day in 
  1.  ;                    date range, so DVBADLMTR should equal the
  1.  ;                    final EDATE in range so that XTMP global
  1.  ;                    can be killed.
  1.  ;Output: ^TMP("DVBAR",$J) contains delimited/non-delimited SC Veteran Admission report 
  1. STRT(ZMSG,BDATE,EDATE,DVBADLMTR)  ;ENTER HERE
  1.  N DVBAFNLDTE,MA1,DVBATMP
  1.  S DVBABCNT=0,RO="N",RONUM=0
  1.  S DVBAFNLDTE=$S(+$G(DVBADLMTR):+$P(DVBADLMTR,"."),1:0)
  1.  S DVBADLMTR=$S('+$G(DVBADLMTR):"",1:"^")
  1.  K ^TMP($J) G TERM
  1. SET Q:'$D(^DPT(DA,0))  S DFN=DA,DVBASC="" D SC^DVBAVDPT Q:DVBASC'="Y"  Q:CFLOC'=RONUM&(RO="Y")&(CFLOC'=0)&(CFLOC'=376)  S MA1=$P(MA,".",1),^TMP($J,MA1,XCN,CFLOC,MB,DA)=MA
  1.  Q
  1.  ;
  1. PRINTB S ADMDT=$P(DATA,U),DFN=DA D ADM^DVBAVDPT
  1.  ;W:(IOST?1"C-".E)!($D(DVBAON2)) @IOF
  1.  ;W !!!,?(80-$L(HEAD)\2),HEAD,!,?(80-$L(HEAD1)\2),HEAD1,!!
  1.  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)
  1.  ;create delimited/non-delimited report
  1.  D:($G(DVBADLMTR)'="") PRINTD
  1.  D:($G(DVBADLMTR)="") PRINTND
  1.  S DVBAON2=""
  1.  Q
  1.  ;
  1. PRINTND ;create non-delimited admission report
  1.  S ^TMP("DVBAR",$J,DVBABCNT)="",DVBABCNT=DVBABCNT+1
  1.  S ^TMP("DVBAR",$J,DVBABCNT)="",DVBABCNT=DVBABCNT+1
  1.  S ^TMP("DVBAR",$J,DVBABCNT)="          Patient Name:   "_PNAM,DVBABCNT=DVBABCNT+1
  1.  S ^TMP("DVBAR",$J,DVBABCNT)="              Claim No:   "_CNUM,DVBABCNT=DVBABCNT+1
  1.  S ^TMP("DVBAR",$J,DVBABCNT)="      Claim Folder Loc:   "_CFLOC,DVBABCNT=DVBABCNT+1
  1.  S ^TMP("DVBAR",$J,DVBABCNT)="         Social Sec No:   "_SSN,DVBABCNT=DVBABCNT+1
  1.  S ^TMP("DVBAR",$J,DVBABCNT)="        Admission Date:   "_ADMDT,DVBABCNT=DVBABCNT+1
  1.  S ^TMP("DVBAR",$J,DVBABCNT)="   Admitting Diagnosis:   "_DIAG,DVBABCNT=DVBABCNT+1
  1.  S ^TMP("DVBAR",$J,DVBABCNT)="        Discharge Date:   "_DCHGDT,DVBABCNT=DVBABCNT+1
  1.  S ^TMP("DVBAR",$J,DVBABCNT)="           Bed Service:   "_BEDSEC,DVBABCNT=DVBABCNT+1
  1.  S ^TMP("DVBAR",$J,DVBABCNT)="             Recv A&A?:   "_$S(RCVAA=0:"NO",RCVAA=1:"YES",1:"Not specified"),DVBABCNT=DVBABCNT+1
  1.  S ^TMP("DVBAR",$J,DVBABCNT)="              Pension?:   "_$S(RCVPEN=0:"NO",RCVPEN=1:"YES",1:"Not specified"),DVBABCNT=DVBABCNT+1
  1.  ;D ELIG^DVBAVDPT
  1. ELIG S ELIG=DVBAELIG,INCMP=""
  1.  I ELIG]"" S ELIG=ELIG_" ("_$S(DVBAELST="P":"Pend Ver",DVBAELST="R":"Pend Re-verif",DVBAELST="V":"Verified",1:"Not Verified")_")"
  1.  I $D(^DPT(DA,.29)) S INCMP=$S($P(^(.29),U,12)=1:"Incompetent",1:"")
  1.  S ^TMP("DVBAR",$J,DVBABCNT)="      Eligibility data:   "_ELIG_$S(((ELIG]"")&(INCMP]"")):", ",1:""),DVBABCNT=DVBABCNT+1
  1.  I $X>60 S ^TMP("DVBAR",$J,DVBABCNT)=INCMP,DVBABCNT=DVBABCNT+1
  1.  ;Q
  1.  ;***VM-OUT*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
  1.  Q
  1.  ;
  1. PRINTD ;create delimited admission report
  1.  N ELIG,INCMP,X,X1,X2,X3
  1.  D:('$D(^XTMP("DVBA_SCADMSSN_RPT"_$J,0))) COLHDR
  1.  S ^TMP("DVBAR",$J,DVBABCNT)=PNAM_DVBADLMTR_CNUM_DVBADLMTR_CFLOC_DVBADLMTR_SSN_DVBADLMTR_ADMDT_DVBADLMTR
  1.  S ^TMP("DVBAR",$J,DVBABCNT)=^TMP("DVBAR",$J,DVBABCNT)_DIAG_DVBADLMTR_DCHGDT_DVBADLMTR_BEDSEC_DVBADLMTR
  1.  S ^TMP("DVBAR",$J,DVBABCNT)=^TMP("DVBAR",$J,DVBABCNT)_$S(RCVAA=0:"NO",RCVAA=1:"YES",1:"Not specified")_DVBADLMTR
  1.  S ^TMP("DVBAR",$J,DVBABCNT)=^TMP("DVBAR",$J,DVBABCNT)_$S(RCVPEN=0:"NO",RCVPEN=1:"YES",1:"Not specified")_DVBADLMTR
  1.  S ELIG=DVBAELIG,INCMP=""
  1.  I ELIG]"" S ELIG=ELIG_" ("_$S(DVBAELST="P":"Pend Ver",DVBAELST="R":"Pend Re-verif",DVBAELST="V":"Verified",1:"Not Verified")_")"
  1.  I $D(^DPT(DA,.29)) S INCMP=$S($P(^(.29),U,12)=1:"Incompetent",1:"")
  1.  S ^TMP("DVBAR",$J,DVBABCNT)=^TMP("DVBAR",$J,DVBABCNT)_ELIG_$S(((ELIG]"")&(INCMP]"")):", ",1:"")_INCMP
  1.  ;
  1.  S DVBATMP=^TMP("DVBAR",$J,DVBABCNT)
  1.  S X=$P(DVBATMP,DVBADLMTR,4)
  1.  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
  1.  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
  1.  S $P(DVBATMP,DVBADLMTR,4)=X
  1.  S X=$P(DVBATMP,DVBADLMTR,2)
  1.  S X=$C(160)_X
  1.  S $P(DVBATMP,DVBADLMTR,2)=X
  1.  F I=1:1:$L(DVBATMP,DVBADLMTR) I $P(DVBATMP,DVBADLMTR,I)["," S $P(DVBATMP,DVBADLMTR,I)=""""_$P(DVBATMP,DVBADLMTR,I)_""""
  1.  S DVBATMP=$TR(DVBATMP,DVBADLMTR,",")
  1.  S ^TMP("DVBAR",$J,DVBABCNT)=DVBATMP
  1.  ;
  1.  S DVBABCNT=DVBABCNT+1
  1.  Q
  1.  ;
  1. PRINT K MA S QUIT=""
  1.  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
  1.  Q
  1. 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
  1.  Q
  1.  ;
  1. TERM ;D HOME^%ZIS K NOASK
  1.  ;
  1.  ;W @IOF,!,"VARO SERVICE-CONNECTED ADMISSION REPORT" D NOPARM^DVBAUTL2 G:$D(DVBAQUIT) KILL^DVBAUTIL
  1.  S DTAR=^DVB(396.1,1,0),FDT(0)=$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)
  1.  S HEAD="SERVICE-CONNECTED ADMISSION REPORT",HEAD1="FOR "_$P(DTAR,U,1)_" ON "_FDT(0)
  1.  ;W !,HEAD1
  1.  ;W !!,"Please enter dates for search, oldest date first, most recent date last.",!!,"Last report was run on " S Y=$P(DTAR,U,8) X ^DD("DD") W Y,!!
  1.  ;D DATE^DVBAUTIL
  1.  ;G:X=""!(Y<0) KILL
  1.  ;S %ZIS="Q" D ^%ZIS K %ZIS G:POP KILL^DVBAUTIL
  1.  ;
  1.  ;I $D(IO("Q")) S ZTRTN="DEQUE^DVBASCRP",ZTIO=ION,NOASK=1,ZTDESC="AMIE SC ADMISSION REPORT" F I="FDT(0)","HEAD","HEAD1","BDATE","EDATE","TYPE","RO","RONUM","NOASK" S ZTSAVE(I)=""
  1.  ;I $D(IO("Q")) D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued.",!! G KILL
  1.  ;
  1. GO S MA=BDATE F J=0:0 S MA=$O(^DGPM("AMV1",MA)) Q:$P(MA,".")>EDATE!(MA="")  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 W:'$D(NOASK) "."
  1.  I '$D(^TMP($J)) S ^TMP("DVBAR",$J,DVBABCNT)="No data found for parameters entered." H 2 G KILL
  1.  D PRINT K:(DVBAFNLDTE=$P(EDATE,".")) ^XTMP("DVBA_SCADMSSN_RPT"_$J,0)
  1.  I $D(DVBAQUIT) K DVBAON2 D:$D(ZTQUEUED) KILL^%ZTLOAD G KILL^DVBAUTIL
  1.  ;
  1. KILL K:(DVBAFNLDTE=$P(EDATE,".")) ^XTMP("DVBA_SCADMSSN_RPT"_$J,0)
  1.  S ZMSG=$NA(^TMP("DVBAR",$J))
  1.  D:$D(ZTQUEUED) KILL^%ZTLOAD D ^%ZISC S X=8 K DVBAON2 G FINAL^DVBAUTIL
  1.  ;
  1. DEQUE K ^TMP($J) G GO
  1.  ;
  1. COLHDR ;Column header for delimited report
  1.  N DVBADLMTR
  1.  S DVBADLMTR=","
  1.  S ^TMP("DVBAR",$J,DVBABCNT)="Patient Name"_DVBADLMTR_"Claim No"_DVBADLMTR_"Claim Folder Loc"_DVBADLMTR
  1.  S ^TMP("DVBAR",$J,DVBABCNT)=(^TMP("DVBAR",$J,DVBABCNT))_"Social Sec No"_DVBADLMTR_"Admission Date"_DVBADLMTR
  1.  S ^TMP("DVBAR",$J,DVBABCNT)=(^TMP("DVBAR",$J,DVBABCNT))_"Admitting Diagnosis"_DVBADLMTR_"Discharge Date"_DVBADLMTR
  1.  S ^TMP("DVBAR",$J,DVBABCNT)=(^TMP("DVBAR",$J,DVBABCNT))_"Bed Service"_DVBADLMTR_"Recv A&A?"_DVBADLMTR
  1.  S ^TMP("DVBAR",$J,DVBABCNT)=(^TMP("DVBAR",$J,DVBABCNT))_"Pension?"_DVBADLMTR_"Eligibility Data"
  1.  S DVBABCNT=DVBABCNT+1
  1.  ;set global entry so header is only created once for job ($J)
  1.  S ^XTMP("DVBA_SCADMSSN_RPT"_$J,0)=DT_U_DT
  1.  Q