source: FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHQR2.m@ 1800

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

initial load of FOIAVistA 6/30/08 version
File size: 4.8 KB
Line 
1DVBHQR2 ;ISC-ALBANY/PKE/JLU-parse Birls response ;1/26/88 19:49
2 ;;4.0;HINQ;**53,49**;03/25/92
3 S DFN=+$E(X(1),8,21),XMDUZ=DUZ,DVBLEN=+$E(X(1),22,25),X=$E(X(1),26,999)
4 ;
5 S DVBCAP="BIRLS Response only - No C&P Record Found",DVBCN=$E(X,1,9)
6 I $E(DVBCN,9)=" " S DVBCN=$E(DVBCN,1,8)
7 Q:'$L(X)
8 S DVBNAME=$E(X,10,72)
9 S L=73 D RON
10 ;
11 S DVBDOB=$E(X,1,8),DVBFL=$E(X,9,11)
12FOLDER I +DVBFL S Y=0,Y=$O(^DIC(4,"D",+DVBFL,Y)) I Y S Y=$S($D(^DIC(4,Y,0)):$P(^DIC(4,Y,99),U,1)_" - "_$P(^(0),U),1:""),DVBFL=Y
13 I DVBFL=" " K DVBFL
14 ;
15 S $P(DVBBIR,U,5)=$E(X,12),DVBPOA=$E(X,13,15)
16 ;
17 D POA
18 ;
19 S $P(DVBBIR,U,7)=$E(X,16) ;clothing allowance indicator
20 S L=17 D RON
21 ;
22MOR S (DVBDXNO,DVBDXSC)=0
23 F I=1:1:9 S Y=$E(X,1,4),DXP(I)=$E(X,5,7),DXP1(I)=$S($E(X,9)="Y":1,1:0)_U_$E(X,8),DX(I)="",L=10 S:$E(X,9)="Y" DVBDXSC=DVBDXSC+1 D RON F L=1:1:4 S Z=$E(Y,L) Q:Z=" " S:Z'?1N Z=$A(Z)-64 S:Z>9 Z=0 S DX(I)=DX(I)_Z
24 ;
25 F I=0:0 S I=$O(DX(I)) Q:'I S Y=DX(I),DX(I)=$S($O(^DIC(31,"C",+DX(I),0)):$O(^(0)),1:"") S DVBDX(I)=Y_"^"_DX(I)_"^"_DXP(I)_"^"_1 S:+Y>0 DVBDXNO=DVBDXNO+1
26 ;
27 ;DVB*4*49 - sort by SC%
28 N DVBCT,DVBDD,DVBE,DVBEE
29 F DVBE=0:0 S DVBE=$O(DVBDX(DVBE)) Q:DVBE'>0 S DVBDD(+$P(DVBDX(DVBE),U,3),DVBE)=DVBDX(DVBE)
30 S DVBE="",DVBCT=1
31 F S DVBE=$O(DVBDD(DVBE),-1) Q:DVBE']"" D
32 . F DVBEE=0:0 S DVBEE=$O(DVBDD(DVBE,DVBEE)) Q:DVBEE'>0 D
33 . . S DVBDX(DVBCT)=DVBDD(DVBE,DVBEE) S DVBCT=DVBCT+1
34 K DVBDD,DX,DXP
35 S $P(DVBBIR,U,8)=$E(X,1),$P(DVBBIR,U,9)=$E(X,2)
36 S $P(DVBBIR,U,10)=$E(X,3),DVBDXPCT=$E(X,4,6),$P(DVBBIR,U,11)=$E(X,4,6)
37 S L=7 D RON
38 D BIRL^DVBHQR13
39 Q
40 ;
41RON S X=$E(X,L,999),LX=$L(X),LY=254-LX I $D(X(2)),(LX+$L(X(2)))<256 S X=X_X(2) K X(2) D RON1 Q
42 I $D(X(2)) S X=X_$E(X(2),1,LY),X(2)=$E(X(2),LY+1,999) Q
43 Q
44 ;
45RON1 I $D(X(3)),'$D(X(2)) S X(2)=X(3) K X(3) I $D(X(4)),'$D(X(3)) S X(3)=X(4) K X(4) I $D(X(5)),'$D(X(4)) S X(4)=X(5) K X(5)
46 QUIT
47 ;
48POA ;DVB*4*49 - new Power of Attorney codes
49 I DVBPOA'?1.3N D POA3 Q
50 I +DVBPOA>99 Q
51 I '+DVBPOA K DVBPOA Q
52 I $L(DVBPOA)=3 S DVBPOA=+$E(DVBPOA,2,3)
53 I DVBPOA>73,DVBPOA<100 S Y=DVBPOA D POA2 S DVBPOA=Y_" - "_DVBPOA Q
54 ;
55EEE ;
56 S Y=0 F I=3,7,12,24,29,32,43,53,55,56,61,62,63,64,65,66,67,68,70,71 S Y=Y+1 IF I=+DVBPOA D POA1 S DVBPOA=Y_" - "_DVBPOA Q
57 ;
58 S Y=DVBPOA,Y=$S(+Y=2:402,Y=+5:405,Y=36:436,Y=37:437,Y=38:438,Y=42:442,Y=52:452,Y=55:455,Y=60:460,Y>9:3_Y,1:30_Y)
59 S Z=0,Z=$O(^DIC(4,"D",Y,Z)) I Z,$D(^DIC(4,Z,0)) S Y=+$P(^(0),U,2) I $D(^DIC(5,Y,0)) S DVBPOA="State of "_$P(^(0),U)_" Department of Veterans - "_DVBPOA Q
60 Q
61POA1 S Y=$P($T(POA1+Y),";;",2) Q
623 ;;Polish Legion of Amer. Veterans, USA
637 ;;The Retired Enlisted Association
6412 ;;Gold Star Wives of America Inc.
6524 ;;National Amputation Foundation, Inc.
6629 ;;Vietnam Era Veterans Association
6732 ;;Virgin Islands Office of Veterans Affairs
6843 ;;Swords to Plowshares
6953 ;;Northern Mariana Islands Dept VA
7055 ;;Puerto Rico Public Advocate for Veterans Affairs
7156 ;;Guam Office of Veterans Affairs
7261 ;;American Defenders of Bataan & Corregidor, Inc.
7362 ;;Noncommissioned Officers Assoc., USA
7463 ;;Veteran Assistance Foundation, Inc.
7564 ;;Nat. Assn. of County Veterans Affairs Office
7665 ;;American Ex-Prisoners of War, Inc.
7766 ;;Private Attorney with Exclusive Contact
7867 ;;American Samoa Veterans Affirs Office
7968 ;;American GI Forum, National Veterans' Outreach Program
8070 ;;Vietnam Veterans of America
8171 ;;Paralyzed Veterans of America
82 ;
83POA2 S Y=Y-73,Y=$P($T(POA2+Y),";;",2) Q
8474 ;;The American Legion
85 ;;American National Red Cross
86 ;;American Veterans Committee
87 ;;AMVETS
88 ;;Army and Air Force Mutual Aid Assoc.
89 ;;Army and Navy Union, USA
908 ;;Blinded Veterans Assoc.
91 ;;Catholic War Veterans, USA
92 ;;National Veterans Legal Services Program
93 ;;Disabled American Veterans
94 ;;National Association for Black Veterans, Inc.
95 ;;Fleet Reserve Assoc.
96 ;;Jewish War Veterans
97 ;;Legion of Valor, USA
98 ;;Marine Corps League
99 ;;Military Order of the Purple Heart
1009 ;;Eastern Paralyzed Veterans Association
101 ;;African American PTSD Association
102 ;;Veterans of the Vietnam War, Inc.
103 ;;Navy Mutual Aid Assoc.
104 ;;National Veterans Organization of America, Inc.
105 ;;Italian American War Veterans
106 ;;United Spanish War Veterans
107 ;;Veterans of Foreign Wars of the United States
108 ;;Veterans of WWI of the USA, Inc
109 ;;Agent
110 Q
111POA3 ;DVB*4*49 - Power of Att. codes with alpha characters
112 I $L(DVBPOA)=3 S DVBPOA=$E(DVBPOA,2,3)
113 N DVBX,DVBXX
114 I $E(DVBPOA)="0" D
115 . F DVBX=65:1:82 S DVBXX=$C(DVBX) I DVBXX=$E(DVBPOA,2) S Y=DVBX D POA33 S DVBPOA=Y_" - "_DVBPOA Q
116 Q
117POA33 S Y=Y-64,Y=$P($T(POA33+Y),";;",2) Q
118 ;;Mark R. Caldwell
119 ;;Kenneth M. Carpenter
120 ;;Stephen L. DeVita
121 ;;William G. Smith
122 ;;Legal Aid Society of Cincinatti
123 ;;Irving M. Solotoff
124 ;;Leroy A. St. John
125 ;;Rashid L. Malik
126 ;;Berry, Kelley & Reiman
127 ;;Nancy E Killeen
128 ;;Hill & Ponton Professional Assoc.
129 ;;Richard A laPointe
130 ;;Lisa Ann Lee
131 ;;Betty L. G. Jones
132 ;;
133 ;;Barbara J. Cook
134 ;;Law Offices of Theodore Jarvi
135 ;;Chisholm, Chisholm & Kilpatrick LLP
136 Q
Note: See TracBrowser for help on using the repository browser.