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

DVBHQR2.m

Go to the documentation of this file. 
  1. DVBHQR2 ;ISC-ALBANY/PKE/JLU-parse Birls response ;1/26/88  19:49
  1.  ;;4.0;HINQ;**53,49**;03/25/92 
  1.  S DFN=+$E(X(1),8,21),XMDUZ=DUZ,DVBLEN=+$E(X(1),22,25),X=$E(X(1),26,999)
  1.  ;
  1.  S DVBCAP="BIRLS Response only - No C&P Record Found",DVBCN=$E(X,1,9)
  1.  I $E(DVBCN,9)=" " S DVBCN=$E(DVBCN,1,8)
  1.  Q:'$L(X)
  1.  S DVBNAME=$E(X,10,72)
  1.  S L=73 D RON
  1.  ;
  1.  S DVBDOB=$E(X,1,8),DVBFL=$E(X,9,11)
  1. FOLDER 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
  1.  I DVBFL="   " K DVBFL
  1.  ;
  1.  S $P(DVBBIR,U,5)=$E(X,12),DVBPOA=$E(X,13,15)
  1.  ;
  1.  D POA
  1.  ;
  1.  S $P(DVBBIR,U,7)=$E(X,16) ;clothing allowance indicator
  1.  S L=17 D RON
  1.  ;
  1. MOR S (DVBDXNO,DVBDXSC)=0
  1.  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
  1.  ;
  1.  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
  1.  ;
  1.  ;DVB*4*49 - sort by SC%
  1.  N DVBCT,DVBDD,DVBE,DVBEE
  1.  F DVBE=0:0 S DVBE=$O(DVBDX(DVBE)) Q:DVBE'>0  S DVBDD(+$P(DVBDX(DVBE),U,3),DVBE)=DVBDX(DVBE)
  1.  S DVBE="",DVBCT=1
  1.  F  S DVBE=$O(DVBDD(DVBE),-1) Q:DVBE']""  D
  1.  . F DVBEE=0:0 S DVBEE=$O(DVBDD(DVBE,DVBEE)) Q:DVBEE'>0  D
  1.  . . S DVBDX(DVBCT)=DVBDD(DVBE,DVBEE) S DVBCT=DVBCT+1
  1.  K DVBDD,DX,DXP
  1.  S $P(DVBBIR,U,8)=$E(X,1),$P(DVBBIR,U,9)=$E(X,2)
  1.  S $P(DVBBIR,U,10)=$E(X,3),DVBDXPCT=$E(X,4,6),$P(DVBBIR,U,11)=$E(X,4,6)
  1.  S L=7 D RON
  1.  D BIRL^DVBHQR13
  1.  Q
  1.  ;
  1. RON 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
  1.  I $D(X(2)) S X=X_$E(X(2),1,LY),X(2)=$E(X(2),LY+1,999) Q
  1.  Q
  1.  ;
  1. RON1 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)
  1.  QUIT
  1.  ;
  1. POA ;DVB*4*49 - new Power of Attorney codes
  1.  I DVBPOA'?1.3N D POA3 Q
  1.  I +DVBPOA>99 Q
  1.  I '+DVBPOA K DVBPOA Q
  1.  I $L(DVBPOA)=3 S DVBPOA=+$E(DVBPOA,2,3)
  1.  I DVBPOA>73,DVBPOA<100 S Y=DVBPOA D POA2 S DVBPOA=Y_" - "_DVBPOA Q
  1.  ;
  1. EEE ;
  1.  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
  1.  ;
  1.  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)
  1.  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
  1.  Q
  1. POA1 S Y=$P($T(POA1+Y),";;",2) Q
  1. 3 ;;Polish Legion of Amer. Veterans, USA
  1. 7 ;;The Retired Enlisted Association
  1. 12 ;;Gold Star Wives of America Inc.
  1. 24 ;;National Amputation Foundation, Inc.
  1. 29 ;;Vietnam Era Veterans Association
  1. 32 ;;Virgin Islands Office of Veterans Affairs
  1. 43 ;;Swords to Plowshares
  1. 53 ;;Northern Mariana Islands Dept VA
  1. 55 ;;Puerto Rico Public Advocate for Veterans Affairs
  1. 56 ;;Guam Office of Veterans Affairs
  1. 61 ;;American Defenders of Bataan & Corregidor, Inc.
  1. 62 ;;Noncommissioned Officers Assoc., USA
  1. 63 ;;Veteran Assistance Foundation, Inc.
  1. 64 ;;Nat. Assn. of County Veterans Affairs Office
  1. 65 ;;American Ex-Prisoners of War, Inc.
  1. 66 ;;Private Attorney with Exclusive Contact
  1. 67 ;;American Samoa Veterans Affirs Office
  1. 68 ;;American GI Forum, National Veterans' Outreach Program
  1. 70 ;;Vietnam Veterans of America
  1. 71 ;;Paralyzed Veterans of America
  1.  ;
  1. POA2 S Y=Y-73,Y=$P($T(POA2+Y),";;",2) Q
  1. 74 ;;The American Legion
  1.  ;;American National Red Cross
  1.  ;;American Veterans Committee
  1.  ;;AMVETS
  1.  ;;Army and Air Force Mutual Aid Assoc.
  1.  ;;Army and Navy Union, USA
  1. 8 ;;Blinded Veterans Assoc.
  1.  ;;Catholic War Veterans, USA
  1.  ;;National Veterans Legal Services Program
  1.  ;;Disabled American Veterans
  1.  ;;National Association for Black Veterans, Inc.
  1.  ;;Fleet  Reserve Assoc.
  1.  ;;Jewish War Veterans
  1.  ;;Legion of Valor, USA
  1.  ;;Marine Corps League
  1.  ;;Military Order of the Purple Heart
  1. 9 ;;Eastern Paralyzed Veterans Association
  1.  ;;African American PTSD Association
  1.  ;;Veterans of the Vietnam War, Inc.
  1.  ;;Navy Mutual Aid Assoc.
  1.  ;;National Veterans Organization of America, Inc.
  1.  ;;Italian American War Veterans
  1.  ;;United Spanish War Veterans
  1.  ;;Veterans of Foreign Wars of the United States
  1.  ;;Veterans of WWI of the USA, Inc
  1.  ;;Agent
  1.  Q
  1. POA3 ;DVB*4*49 - Power of Att. codes with alpha characters
  1.  I $L(DVBPOA)=3 S DVBPOA=$E(DVBPOA,2,3)
  1.  N DVBX,DVBXX
  1.  I $E(DVBPOA)="0" D
  1.  . F DVBX=65:1:82 S DVBXX=$C(DVBX) I DVBXX=$E(DVBPOA,2) S Y=DVBX D POA33 S DVBPOA=Y_" - "_DVBPOA Q
  1.  Q
  1. POA33 S Y=Y-64,Y=$P($T(POA33+Y),";;",2) Q
  1.  ;;Mark R. Caldwell
  1.  ;;Kenneth M. Carpenter
  1.  ;;Stephen L. DeVita
  1.  ;;William G. Smith
  1.  ;;Legal Aid Society of Cincinatti
  1.  ;;Irving M. Solotoff
  1.  ;;Leroy A. St. John
  1.  ;;Rashid L. Malik
  1.  ;;Berry, Kelley & Reiman
  1.  ;;Nancy E Killeen
  1.  ;;Hill & Ponton Professional Assoc.
  1.  ;;Richard A laPointe
  1.  ;;Lisa Ann Lee
  1.  ;;Betty L. G. Jones
  1.  ;;
  1.  ;;Barbara J. Cook
  1.  ;;Law Offices of Theodore Jarvi
  1.  ;;Chisholm, Chisholm & Kilpatrick LLP
  1.  Q