source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBAVDPT.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 2.9 KB
Line 
1DVBAVDPT ;ALB/JLU,557/THM-GET VARIABLES VIA ^VADPT ; 1/23/91 8:02 AM
2 ;;2.7;AMIE;**57,108**;Apr 10, 1995
3 W *7,!!,"NOT a stand-alone program !",!!,*7 Q
4 ;
5DCHGDT ;entry point for all reports that use discharge dates
6 ;called by D DCHGDT^DVBAVDPT
7 S DCHGDT=MA,VAINDT=$S(MA[".":MA-.000002,1:MA),VA200="" D INP^VADPT K VA200 S ADMDT=$P(VAIN(7),".") G EN
8 ;
9ADM ;entry point for all reports that use admission dates
10 ;called by D ADM^DVBAVDPT only
11 I $D(MA),MA]"" S (ADMDT,VAINDT)=MA S VA200="" D INP^VADPT K VA200 S ADMNUM=VAIN(1),DCHGDT="",DCHPTR=$S($D(^DGPM(+ADMNUM,0)):$P(^(0),U,17),1:"") G:DCHPTR="" EN I DCHPTR]"",$D(^DGPM(DCHPTR,0)) S DCHGDT=$P(^(0),U,1) G EN
12 S VAINDT=$S($D(ADMDT):ADMDT,1:""),VA200="" D INP^VADPT K VA200 S ADMNUM=VAIN(1),DCHGDT="",DCHPTR=$S($D(^DGPM(+ADMNUM,0)):$P(^(0),U,17),1:"") I DCHPTR]"",$D(^DGPM(DCHPTR,0)) S DCHGDT=$P(^(0),U,1)
13 Q:$D(DVBARADQ)
14 ;
15EN ;general entry point
16 S (DVBAELIG,DVBAELST)="" I $D(^DPT(DFN,.36)),$P(^(.36),U)]"" S DVBAELIG=$S($D(^DIC(8,+^(.36),0)):$P(^(0),U,6),1:"")
17 I DVBAELIG]"",$D(^DPT(DFN,.361)),^(.361)]"" S DVBAELST=$P(^(.361),U)
18 S PNAM=$P(^DPT(DFN,0),U),SSN=$P(^(0),U,9),WARD=$P(VAIN(4),U),DIAG=VAIN(9),ADMNUM=VAIN(1)
19 S WARD=$S($D(^DIC(42,+WARD,0)):^(0),1:""),BEDSEC=$S($P(WARD,U,2)]"":$P(WARD,U,2),1:"UNKNOWN"),WARD=$S($P(WARD,U)]"":$P(WARD,U),1:"UNKNOWN")
20 K VAEL,VAERR,VADM,VAIN,VAINDT,DVBAPGM,VAMB,ADMNUM,DVBAX,DVBAY
21RCV ;A&A and Pension
22 ;
23 ;* QUIT1 set by DVBAADRP, DVBACMRP, DVBADSNT, DVBADSRP, DVBADSRT,
24 ;* DVBARAD1, DVBASPD2
25 Q:$D(QUIT1) S RCVAA=$S($D(^DPT(DFN,.362)):^(.362),1:""),RCVPEN=$P(RCVAA,U,14),RCVAA=$P(RCVAA,U,12)
26 S RCVAA=$S(RCVAA="Y":1,RCVAA="N":0,1:""),RCVPEN=$S(RCVPEN="Y":1,RCVPEN="N":0,1:"")
27SC ;Service Connection
28 S DVBASC=$S($D(^DPT(DFN,.3)):$P(^(.3),U),1:"")
29CNUM ;Claim Number and Location
30 S CNUM=$S($D(^DPT(DFN,.31)):^(.31),1:"")
31 S CFLOC=+$P(CNUM,U,4)
32 S CNUM=$P(CNUM,U,3)
33 S:CNUM="" CNUM="UNKNOWN"
34 S XCN=$E(CNUM,$L(CNUM)-1,$L(CNUM))
35 ; DVBA*2.7*108 - Modified next line for null values
36 ; S CFLOC=$S($D(^DIC(4,CFLOC,99)):$P(^(99),U,1),1:"UNKNOWN")
37 S CFLOC=$P($G(^DIC(4,CFLOC,99)),"^") S:CFLOC="" CFLOC="UNKNOWN"
38 Q
39 ;
40ELIG N ED S ELIG=DVBAELIG,INCMP="",ED="Eligibility data:"
41 I ELIG]"" S ELIG=ELIG_" ("_$S(DVBAELST="P":"Pend Ver",DVBAELST="R":"Pend Re-verif",DVBAELST="V":"Verified",1:"Not Verified")_")"
42 I $D(^DPT(DA,.29)) S INCMP=$S($P(^(.29),U,12)=1:"Incompetent",1:"")
43 I INCMP]"",ELIG]"" S ELIG=ELIG_", "
44 I '$D(DVBC)!'$$BROKER^XWBLIB W ?6,ED,?26,ELIG W:$X>60 !?26 W INCMP,! Q
45 S DVBC=DVBC+1,ED=" "_ED_" ",^TMP("DVBSPCRP",$J,DVBC)=ED_ELIG
46 I $L(^(DVBC))<60 S ^(DVBC)=^(DVBC)_INCMP ;NakedRefs = ^TMP("DVBSPCRP",$J,DVBC)
47 E S DVBC=DVBC+1,$P(^(DVBC)," ",25)=" "_INCMP
48 S DVBC=DVBC+1
49 Q
50 ;
51NOTES ;Supported fields for this routine
52 ;.362 Disability Ret from Military
53 ;.291 Date ruled incomp (VA)
54 ;.292 Date ruled incomp (civil)
55 ;.293 Rated incomp?
56 ;.313 Claim number
57 ;.312 Claim folder loc (as free text)
58 ;2.101 Log-in date/time
59 ;File 44 field .02 Bedsection
60 ;Elig file Print name
Note: See TracBrowser for help on using the repository browser.