- DVBHQR11 ;ISC-ALBANY/PKE - parse HINQ response;6/10/09 7:39pm
- ;;4.0;HINQ;**32,35,49,63,65**;03/25/92;Build 19
- ;
- ;
- STAT ;Parse Statistics Segment for the records that have it.
- I ($P(DVBBAS(1),U,6)="A"!($P(DVBBAS(1),U,6)="E")),$P(DVBBAS(1),U,4)="00" D ASTAT
- I $P(DVBBAS(1),U,6)="B"!($P(DVBBAS(1),U,6)="F") D BSTAT
- I $P(DVBBAS(1),U,6)="E",$P(DVBBAS(1),U,4)'="00" D BSTAT
- I $P(DVBBAS(1),U,6)="C",$P(DVBBAS(1),U,4)=10 D CSTAT
- I $P(DVBBAS(1),U,6)="C",$P(DVBBAS(1),U,4)'=10 S DVBVET="C^^^^"
- ;
- G CHILD ;changing the order of the response message - diag will
- ;come at the very end to accommodate variable length records
- ;
- DIAG ;Diagnostics Segment.
- K DXP,DX,DVBDX,DVBEFF
- N DVBCUR,DVBEXT,DVBORIG
- ;with the HINQ replacement, interim solution (DVB*4*49) there are
- ;several changes to the diagnostic segment. Total # codes, Add'l
- ;codes, length of segment are not longer being sent. # SC Codes is
- ;being stored in DVBDXNO. The for loop at DIAG+15 will terminate
- ;after DVBDXNO, the 6 code limit from VBA has been increased to 150.
- ;Total # of SC Diagnostic Codes.
- S DVBV1=$E(X,1,3)
- I DVBV1["{" S DVBV2=2 D SIGN^DVBHUTIL Q:$G(DVBERCS) ;????
- S DVBDXNO=+DVBV1
- ;Combined Degree of Disability, Effective Date of Combined SC% Eval
- S DVBDXPCT=$E(X,4,6)
- S DVBDXPCT=$TR(DVBDXPCT," ")
- S DVBEFF=$E(X,7,14)
- S DVBEFF=$TR(DVBEFF," ")
- S L=15 D RON S L=1
- ;Y=Diagnostic Codes; DXP(I)=Percent of Disability:
- F I=1:1:DVBDXNO D
- . D RON S L=1
- . I $E(X,L,L+3)[" "!($E(X,L,L+3)']"") S L=L+25 Q
- . S Y=$E(X,L,L+3),DXP(I)=$E(X,L+4,L+6)
- . S DVBEXT(I)=$E(X,L+7,L+8)
- . S DVBEXT(I)=$TR(DVBEXT(I)," ")
- . S DVBORIG(I)=$E(X,L+9,L+16)
- . S DVBORIG(I)=$TR(DVBORIG(I)," ")
- . S DVBCUR(I)=$E(X,L+17,L+24)
- . S DVBCUR(I)=$TR(DVBCUR(I)," ")
- . S L=L+25 I DXP(I)'=" " S DX(I)="" F J=1:1:4 S Z=$E(Y,J) S:Z'?1N Z=$A(Z)-64 S:Z>9 Z=0 S DX(I)=DX(I)_Z
- 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)_"^"_$G(DVBEXT(I))_"^"_$G(DVBORIG(I))_"^"_$G(DVBCUR(I))
- ;
- ;sorting by SC% so that they will be saved and displayed that way
- N DVBCT,DVBDD,DVBE,DVBEE
- F DVBE=0:0 S DVBE=$O(DVBDX(DVBE)) Q:DVBE'>0 S DVBDD(+$P(DVBDX(DVBE),U,3),DVBE)=DVBDX(DVBE)
- S DVBE="",DVBCT=1
- F S DVBE=$O(DVBDD(DVBE),-1) Q:DVBE']"" D
- . F DVBEE=0:0 S DVBEE=$O(DVBDD(DVBE,DVBEE)) Q:DVBEE'>0 D
- . . S DVBDX(DVBCT)=DVBDD(DVBE,DVBEE) S DVBCT=DVBCT+1
- K DVBDD,DX,DXP
- Q
- S L=L+1 D RON
- ;
- CHILD ;Child-Birth-Data.
- S $P(DVBCHI,U,1)=$E(X,1,2)
- S DVBV1=$E(X,3,4)
- I DVBV1?1N1A!(DVBV1["{") S DVBV2=2 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S DVBCHNO=DVBV1,L=5,J1=0 D RON
- I 'DVBCHNO S DVBCHNO=0 F DVBV=1:1:20 S L=20 D RON
- E F DVBV=1:1:20 S DVBV1=$E(X,1,19),L=20 D RON I DVBV'>DVBCHNO S DVBCHDOB=$E(DVBV1,1,8) S:DVBCHDOB?8N J1=J1+1,DVBCHILD(J1)=$E(DVBV1,9)_U_$E(DVBV1,10,19)_U_DVBCHDOB
- K DVBCHDOB,J1,DVBV1,DVBV
- ;
- WITH ;WITHHOLDING-APPORTIONED-SEGMENT.
- S $P(DVBWIT,U,1)=$E(X,1),DVBV1=$E(X,2,7)
- I DVBV1?5N1A!(DVBV1["{") S DVBV2=6 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S $P(DVBWIT,U,2)=+$E(DVBV1,1,4)_"."_$E(DVBV1,5,6)
- S DVBV1=$E(X,8,13)
- I DVBV1?5N1A!(DVBV1["{") S DVBV2=6 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S $P(DVBWIT,U,3)=+$E(DVBV1,1,4)_"."_$E(DVBV1,5,6)
- S DVBV1=$E(X,14,19)
- I DVBV1?5N1A!(DVBV1["{") S DVBV2=6 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S $P(DVBWIT,U,4)=+$E(DVBV1,1,4)_"."_$E(DVBV1,5,6),$P(DVBWIT,U,5)=$E(X,20)
- S L=21 D RON
- ;
- NMADR ;ADDRESS-SEGMENT.
- S M("+")=7 F I=65:1:70 S M($C(I))=71-I
- S M("-")=15 F I=74:1:80 S M($C(I))=88-I
- F I=84:1:88 S M($C(I))=104-I
- S M("&")=7
- ;Blank & Length of Segment:
- S $P(DVBADD,U,1)=$E(X,1),DVBV1=$E(X,2,4)
- I DVBV1?2N1A!(DVBV1["{") S DVBV2=3 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S $P(DVBADD,U,2)=DVBV1
- ;Sequence Control:
- S $P(DVBADD,U,3)=$E(X,5)
- ;Name Line Indicator:
- S $P(DVBADD,U,4)=$E(X,6)
- ;Zip Code:
- S DVBZIP=$E(X,7,15)
- S DVBZIP=$E(DVBZIP,1,5) ;use only 1st 5 digits - DVB*4*49
- S L=16,L1=15
- F I=1:1:DVBADRLN Q:$E(X,L)=" "!($E(X,L)="") Q:'$G(M($E(X,L))) S M=M($E(X,L)),DVBADR(I)=$E(X,L+1,L+M),L=L+M+1,L1=L1+M+1 D RON S L=1
- S $P(DVBADD,U,18)=145-L1
- S L=$P(DVBADD,U,18)+1 D RON
- K M,L1
- ;instead of calling DEDBL^DVBHQR12 call REF^DVBHQR12, since the DED/BAL
- ;segments will no longer be included in the VBA resp message, DVB*4*49
- G REF^DVBHQR12
- ;
- 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
- I $D(X(2)) S X=X_$E(X(2),1,LY),X(2)=$E(X(2),LY+1,999) Q
- Q
- ;
- RON1 F Z1=3:1:99 I $D(X(Z1)),'$D(X(Z1-1)) S X(Z1-1)=X(Z1) K X(Z1) Q:'$O(X(Z1))
- QUIT
- ;
- ASTAT ;Statistics Segment of Type A Record.
- S $P(DVBVET,U,1)="A",$P(DVBVET,U,2)=$E(X,1)
- S $P(DVBVET,U,3)=$E(X,2)
- S DVBBOS(1)=$E(X,3),DVBEOD(1)=$E(X,4,11),DVBRAD(1)=$E(X,12,19),DVBASVC=$E(X,20),DVBDOB=$E(X,21,28)
- S $P(DVBVET,U,9)=$E(X,29,30),$P(DVBVET,U,10)=$E(X,31)
- S $P(DVBP(2),U,2)=$E(X,32)
- S DVBEI=$E(X,33),DVBCI=$E(X,34)
- S $P(DVBVET,U,14)=$E(X,35)
- S DVBCPS=$E(X,36)
- S DVBPTI=$E(X,37)
- S $P(DVBP(2),U,6)=$E(X,38,39),$P(DVBP(2),U,3)=$E(X,40,41),$P(DVBP(2),U,1)=$E(X,42,43),$P(DVBP(2),U,4)=$E(X,44),$P(DVBP(2),U,5)=$E(X,45)
- S L=46 D RON
- S DVBSPDOB=$E(X,1,8)
- ;leave spouse DOB in format MMDDYYYY
- S DVBSPNAM=$E(X,9,18) ;;;DVBPTI=$E(X,40)
- ;Hospitalized SMC code:
- S $P(DVBVET,U,24)=$E(X,19,20)
- ;DOB of Father:
- S $P(DVBVET,U,25)=$E(X,21,28)
- ;DOB of Mother:
- S $P(DVBVET,U,26)=$E(X,29,36)
- ;Blanks:
- S $P(DVBVET,U,27)=$E(X,37,40)
- ;P&T disability and dental
- S DVBPTIDT=$E(X,41,48) ;DVB*4*65
- S DVBDENTI=$E(X,49) ;DVB*4*65
- S L=50 D RON
- ;
- Q
- ;
- BSTAT ;Statistics Segment of Type B Record.
- S $P(DVBVET,U,1)="B",$P(DVBVET,U,2)=$E(X,1)
- S $P(DVBVET,U,3)=$E(X,2)
- S DVBBOS(1)=$E(X,3),DVBEOD(1)=$E(X,4,11),DVBRAD(1)=$E(X,12,19),DVBASVC=$E(X,20),DVBDOB=$E(X,21,28)
- S DVBDOB=$E(DVBDOB,5,8)_$E(DVBDOB,1,4)
- S $P(DVBVET,U,9)=$E(X,29,30),$P(DVBVET,U,10)=$E(X,31,37)
- ;Age at Death & Death Date:
- S $P(DVBVET,U,11)=$E(X,38,39),$P(DVBVET,U,12)=$E(X,40,47)
- ;Blank & Pay Grade
- S $P(DVBVET,U,13)=$E(X,48),$P(DVBVET,U,14)=$E(X,49,50)
- ;DOB of Payee & DOB of 3rd Party:
- S $P(DVBVET,U,15)=$E(X,51,58),$P(DVBVET,U,16)=$E(X,59,66)
- ;Name of 3rd Party & Filler
- S $P(DVBVET,U,17)=$E(X,67,73),$P(DVBVET,U,18)=$E(74,85)
- S L=86 D RON
- Q
- ;
- CSTAT ;Statistics Segment of Type C Record.
- S $P(DVBVET,U,1)="C",$P(DVBVET,U,2)=$E(X,1)
- ;CP-APPORT-SPOUSE NAME & DOB
- S $P(DVBVET,U,3)=$E(X,2,11),$P(DVBVET,U,4)=$E(X,12,19)
- S $P(DVBVET,U,5)=$E(X,20,25)
- S L=86 D RON
- Q
- ;
- PENSION ;DVB*4*65
- S $P(DVBP(1),U,10)=$E(X,1,8),$P(DVBP(1),U,11)=$E(X,9,20),$P(DVBP(1),U,12)=$E(X,21,28),$P(DVBP(1),U,13)=$E(X,29,40),$P(DVBP(1),U,14)=$E(X,41,52),$P(DVBP(1),U,15)=$E(X,53,64),$P(DVBP(1),U,16)=$E(X,65,76)
- S L=77 D RON
- ;
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBHQR11 6741 printed Feb 18, 2025@23:25:12 Page 2
- DVBHQR11 ;ISC-ALBANY/PKE - parse HINQ response;6/10/09 7:39pm
- +1 ;;4.0;HINQ;**32,35,49,63,65**;03/25/92;Build 19
- +2 ;
- +3 ;
- STAT ;Parse Statistics Segment for the records that have it.
- +1 IF ($PIECE(DVBBAS(1),U,6)="A"!($PIECE(DVBBAS(1),U,6)="E"))
- IF $PIECE(DVBBAS(1),U,4)="00"
- DO ASTAT
- +2 IF $PIECE(DVBBAS(1),U,6)="B"!($PIECE(DVBBAS(1),U,6)="F")
- DO BSTAT
- +3 IF $PIECE(DVBBAS(1),U,6)="E"
- IF $PIECE(DVBBAS(1),U,4)'="00"
- DO BSTAT
- +4 IF $PIECE(DVBBAS(1),U,6)="C"
- IF $PIECE(DVBBAS(1),U,4)=10
- DO CSTAT
- +5 IF $PIECE(DVBBAS(1),U,6)="C"
- IF $PIECE(DVBBAS(1),U,4)'=10
- SET DVBVET="C^^^^"
- +6 ;
- +7 ;changing the order of the response message - diag will
- GOTO CHILD
- +8 ;come at the very end to accommodate variable length records
- +9 ;
- DIAG ;Diagnostics Segment.
- +1 KILL DXP,DX,DVBDX,DVBEFF
- +2 NEW DVBCUR,DVBEXT,DVBORIG
- +3 ;with the HINQ replacement, interim solution (DVB*4*49) there are
- +4 ;several changes to the diagnostic segment. Total # codes, Add'l
- +5 ;codes, length of segment are not longer being sent. # SC Codes is
- +6 ;being stored in DVBDXNO. The for loop at DIAG+15 will terminate
- +7 ;after DVBDXNO, the 6 code limit from VBA has been increased to 150.
- +8 ;Total # of SC Diagnostic Codes.
- +9 SET DVBV1=$EXTRACT(X,1,3)
- +10 ;????
- IF DVBV1["{"
- SET DVBV2=2
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +11 SET DVBDXNO=+DVBV1
- +12 ;Combined Degree of Disability, Effective Date of Combined SC% Eval
- +13 SET DVBDXPCT=$EXTRACT(X,4,6)
- +14 SET DVBDXPCT=$TRANSLATE(DVBDXPCT," ")
- +15 SET DVBEFF=$EXTRACT(X,7,14)
- +16 SET DVBEFF=$TRANSLATE(DVBEFF," ")
- +17 SET L=15
- DO RON
- SET L=1
- +18 ;Y=Diagnostic Codes; DXP(I)=Percent of Disability:
- +19 FOR I=1:1:DVBDXNO
- Begin DoDot:1
- +20 DO RON
- SET L=1
- +21 IF $EXTRACT(X,L,L+3)[" "!($EXTRACT(X,L,L+3)']"")
- SET L=L+25
- QUIT
- +22 SET Y=$EXTRACT(X,L,L+3)
- SET DXP(I)=$EXTRACT(X,L+4,L+6)
- +23 SET DVBEXT(I)=$EXTRACT(X,L+7,L+8)
- +24 SET DVBEXT(I)=$TRANSLATE(DVBEXT(I)," ")
- +25 SET DVBORIG(I)=$EXTRACT(X,L+9,L+16)
- +26 SET DVBORIG(I)=$TRANSLATE(DVBORIG(I)," ")
- +27 SET DVBCUR(I)=$EXTRACT(X,L+17,L+24)
- +28 SET DVBCUR(I)=$TRANSLATE(DVBCUR(I)," ")
- +29 SET L=L+25
- IF DXP(I)'=" "
- SET DX(I)=""
- FOR J=1:1:4
- SET Z=$EXTRACT(Y,J)
- if Z'?1N
- SET Z=$ASCII(Z)-64
- if Z>9
- SET Z=0
- SET DX(I)=DX(I)_Z
- End DoDot:1
- +30 FOR I=0:0
- SET I=$ORDER(DX(I))
- if 'I
- QUIT
- SET Y=DX(I)
- SET DX(I)=$SELECT($ORDER(^DIC(31,"C",+DX(I),0)):$ORDER(^(0)),1:"")
- SET DVBDX(I)=Y_"^"_DX(I)_"^"_DXP(I)_"^"_$GET(DVBEXT(I))_"^"_$GET(DVBORIG(I))_"^"_$GET(DVBCUR(I))
- +31 ;
- +32 ;sorting by SC% so that they will be saved and displayed that way
- +33 NEW DVBCT,DVBDD,DVBE,DVBEE
- +34 FOR DVBE=0:0
- SET DVBE=$ORDER(DVBDX(DVBE))
- if DVBE'>0
- QUIT
- SET DVBDD(+$PIECE(DVBDX(DVBE),U,3),DVBE)=DVBDX(DVBE)
- +35 SET DVBE=""
- SET DVBCT=1
- +36 FOR
- SET DVBE=$ORDER(DVBDD(DVBE),-1)
- if DVBE']""
- QUIT
- Begin DoDot:1
- +37 FOR DVBEE=0:0
- SET DVBEE=$ORDER(DVBDD(DVBE,DVBEE))
- if DVBEE'>0
- QUIT
- Begin DoDot:2
- +38 SET DVBDX(DVBCT)=DVBDD(DVBE,DVBEE)
- SET DVBCT=DVBCT+1
- End DoDot:2
- End DoDot:1
- +39 KILL DVBDD,DX,DXP
- +40 QUIT
- +41 SET L=L+1
- DO RON
- +42 ;
- CHILD ;Child-Birth-Data.
- +1 SET $PIECE(DVBCHI,U,1)=$EXTRACT(X,1,2)
- +2 SET DVBV1=$EXTRACT(X,3,4)
- +3 IF DVBV1?1N1A!(DVBV1["{")
- SET DVBV2=2
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +4 SET DVBCHNO=DVBV1
- SET L=5
- SET J1=0
- DO RON
- +5 IF 'DVBCHNO
- SET DVBCHNO=0
- FOR DVBV=1:1:20
- SET L=20
- DO RON
- +6 IF '$TEST
- FOR DVBV=1:1:20
- SET DVBV1=$EXTRACT(X,1,19)
- SET L=20
- DO RON
- IF DVBV'>DVBCHNO
- SET DVBCHDOB=$EXTRACT(DVBV1,1,8)
- if DVBCHDOB?8N
- SET J1=J1+1
- SET DVBCHILD(J1)=$EXTRACT(DVBV1,9)_U_$EXTRACT(DVBV1,10,19)_U_DVBCHDOB
- +7 KILL DVBCHDOB,J1,DVBV1,DVBV
- +8 ;
- WITH ;WITHHOLDING-APPORTIONED-SEGMENT.
- +1 SET $PIECE(DVBWIT,U,1)=$EXTRACT(X,1)
- SET DVBV1=$EXTRACT(X,2,7)
- +2 IF DVBV1?5N1A!(DVBV1["{")
- SET DVBV2=6
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +3 SET $PIECE(DVBWIT,U,2)=+$EXTRACT(DVBV1,1,4)_"."_$EXTRACT(DVBV1,5,6)
- +4 SET DVBV1=$EXTRACT(X,8,13)
- +5 IF DVBV1?5N1A!(DVBV1["{")
- SET DVBV2=6
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +6 SET $PIECE(DVBWIT,U,3)=+$EXTRACT(DVBV1,1,4)_"."_$EXTRACT(DVBV1,5,6)
- +7 SET DVBV1=$EXTRACT(X,14,19)
- +8 IF DVBV1?5N1A!(DVBV1["{")
- SET DVBV2=6
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +9 SET $PIECE(DVBWIT,U,4)=+$EXTRACT(DVBV1,1,4)_"."_$EXTRACT(DVBV1,5,6)
- SET $PIECE(DVBWIT,U,5)=$EXTRACT(X,20)
- +10 SET L=21
- DO RON
- +11 ;
- NMADR ;ADDRESS-SEGMENT.
- +1 SET M("+")=7
- FOR I=65:1:70
- SET M($CHAR(I))=71-I
- +2 SET M("-")=15
- FOR I=74:1:80
- SET M($CHAR(I))=88-I
- +3 FOR I=84:1:88
- SET M($CHAR(I))=104-I
- +4 SET M("&")=7
- +5 ;Blank & Length of Segment:
- +6 SET $PIECE(DVBADD,U,1)=$EXTRACT(X,1)
- SET DVBV1=$EXTRACT(X,2,4)
- +7 IF DVBV1?2N1A!(DVBV1["{")
- SET DVBV2=3
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +8 SET $PIECE(DVBADD,U,2)=DVBV1
- +9 ;Sequence Control:
- +10 SET $PIECE(DVBADD,U,3)=$EXTRACT(X,5)
- +11 ;Name Line Indicator:
- +12 SET $PIECE(DVBADD,U,4)=$EXTRACT(X,6)
- +13 ;Zip Code:
- +14 SET DVBZIP=$EXTRACT(X,7,15)
- +15 ;use only 1st 5 digits - DVB*4*49
- SET DVBZIP=$EXTRACT(DVBZIP,1,5)
- +16 SET L=16
- SET L1=15
- +17 FOR I=1:1:DVBADRLN
- if $EXTRACT(X,L)=" "!($EXTRACT(X,L)="")
- QUIT
- if '$GET(M($EXTRACT(X,L)))
- QUIT
- SET M=M($EXTRACT(X,L))
- SET DVBADR(I)=$EXTRACT(X,L+1,L+M)
- SET L=L+M+1
- SET L1=L1+M+1
- DO RON
- SET L=1
- +18 SET $PIECE(DVBADD,U,18)=145-L1
- +19 SET L=$PIECE(DVBADD,U,18)+1
- DO RON
- +20 KILL M,L1
- +21 ;instead of calling DEDBL^DVBHQR12 call REF^DVBHQR12, since the DED/BAL
- +22 ;segments will no longer be included in the VBA resp message, DVB*4*49
- +23 GOTO REF^DVBHQR12
- +24 ;
- RON SET X=$EXTRACT(X,L,999)
- SET LX=$LENGTH(X)
- SET LY=254-LX
- IF $DATA(X(2))
- IF (LX+$LENGTH(X(2)))<256
- SET X=X_X(2)
- KILL X(2)
- DO RON1
- QUIT
- +1 IF $DATA(X(2))
- SET X=X_$EXTRACT(X(2),1,LY)
- SET X(2)=$EXTRACT(X(2),LY+1,999)
- QUIT
- +2 QUIT
- +3 ;
- RON1 FOR Z1=3:1:99
- IF $DATA(X(Z1))
- IF '$DATA(X(Z1-1))
- SET X(Z1-1)=X(Z1)
- KILL X(Z1)
- if '$ORDER(X(Z1))
- QUIT
- +1 QUIT
- +2 ;
- ASTAT ;Statistics Segment of Type A Record.
- +1 SET $PIECE(DVBVET,U,1)="A"
- SET $PIECE(DVBVET,U,2)=$EXTRACT(X,1)
- +2 SET $PIECE(DVBVET,U,3)=$EXTRACT(X,2)
- +3 SET DVBBOS(1)=$EXTRACT(X,3)
- SET DVBEOD(1)=$EXTRACT(X,4,11)
- SET DVBRAD(1)=$EXTRACT(X,12,19)
- SET DVBASVC=$EXTRACT(X,20)
- SET DVBDOB=$EXTRACT(X,21,28)
- +4 SET $PIECE(DVBVET,U,9)=$EXTRACT(X,29,30)
- SET $PIECE(DVBVET,U,10)=$EXTRACT(X,31)
- +5 SET $PIECE(DVBP(2),U,2)=$EXTRACT(X,32)
- +6 SET DVBEI=$EXTRACT(X,33)
- SET DVBCI=$EXTRACT(X,34)
- +7 SET $PIECE(DVBVET,U,14)=$EXTRACT(X,35)
- +8 SET DVBCPS=$EXTRACT(X,36)
- +9 SET DVBPTI=$EXTRACT(X,37)
- +10 SET $PIECE(DVBP(2),U,6)=$EXTRACT(X,38,39)
- SET $PIECE(DVBP(2),U,3)=$EXTRACT(X,40,41)
- SET $PIECE(DVBP(2),U,1)=$EXTRACT(X,42,43)
- SET $PIECE(DVBP(2),U,4)=$EXTRACT(X,44)
- SET $PIECE(DVBP(2),U,5)=$EXTRACT(X,45)
- +11 SET L=46
- DO RON
- +12 SET DVBSPDOB=$EXTRACT(X,1,8)
- +13 ;leave spouse DOB in format MMDDYYYY
- +14 ;;;DVBPTI=$E(X,40)
- SET DVBSPNAM=$EXTRACT(X,9,18)
- +15 ;Hospitalized SMC code:
- +16 SET $PIECE(DVBVET,U,24)=$EXTRACT(X,19,20)
- +17 ;DOB of Father:
- +18 SET $PIECE(DVBVET,U,25)=$EXTRACT(X,21,28)
- +19 ;DOB of Mother:
- +20 SET $PIECE(DVBVET,U,26)=$EXTRACT(X,29,36)
- +21 ;Blanks:
- +22 SET $PIECE(DVBVET,U,27)=$EXTRACT(X,37,40)
- +23 ;P&T disability and dental
- +24 ;DVB*4*65
- SET DVBPTIDT=$EXTRACT(X,41,48)
- +25 ;DVB*4*65
- SET DVBDENTI=$EXTRACT(X,49)
- +26 SET L=50
- DO RON
- +27 ;
- +28 QUIT
- +29 ;
- BSTAT ;Statistics Segment of Type B Record.
- +1 SET $PIECE(DVBVET,U,1)="B"
- SET $PIECE(DVBVET,U,2)=$EXTRACT(X,1)
- +2 SET $PIECE(DVBVET,U,3)=$EXTRACT(X,2)
- +3 SET DVBBOS(1)=$EXTRACT(X,3)
- SET DVBEOD(1)=$EXTRACT(X,4,11)
- SET DVBRAD(1)=$EXTRACT(X,12,19)
- SET DVBASVC=$EXTRACT(X,20)
- SET DVBDOB=$EXTRACT(X,21,28)
- +4 SET DVBDOB=$EXTRACT(DVBDOB,5,8)_$EXTRACT(DVBDOB,1,4)
- +5 SET $PIECE(DVBVET,U,9)=$EXTRACT(X,29,30)
- SET $PIECE(DVBVET,U,10)=$EXTRACT(X,31,37)
- +6 ;Age at Death & Death Date:
- +7 SET $PIECE(DVBVET,U,11)=$EXTRACT(X,38,39)
- SET $PIECE(DVBVET,U,12)=$EXTRACT(X,40,47)
- +8 ;Blank & Pay Grade
- +9 SET $PIECE(DVBVET,U,13)=$EXTRACT(X,48)
- SET $PIECE(DVBVET,U,14)=$EXTRACT(X,49,50)
- +10 ;DOB of Payee & DOB of 3rd Party:
- +11 SET $PIECE(DVBVET,U,15)=$EXTRACT(X,51,58)
- SET $PIECE(DVBVET,U,16)=$EXTRACT(X,59,66)
- +12 ;Name of 3rd Party & Filler
- +13 SET $PIECE(DVBVET,U,17)=$EXTRACT(X,67,73)
- SET $PIECE(DVBVET,U,18)=$EXTRACT(74,85)
- +14 SET L=86
- DO RON
- +15 QUIT
- +16 ;
- CSTAT ;Statistics Segment of Type C Record.
- +1 SET $PIECE(DVBVET,U,1)="C"
- SET $PIECE(DVBVET,U,2)=$EXTRACT(X,1)
- +2 ;CP-APPORT-SPOUSE NAME & DOB
- +3 SET $PIECE(DVBVET,U,3)=$EXTRACT(X,2,11)
- SET $PIECE(DVBVET,U,4)=$EXTRACT(X,12,19)
- +4 SET $PIECE(DVBVET,U,5)=$EXTRACT(X,20,25)
- +5 SET L=86
- DO RON
- +6 QUIT
- +7 ;
- PENSION ;DVB*4*65
- +1 SET $PIECE(DVBP(1),U,10)=$EXTRACT(X,1,8)
- SET $PIECE(DVBP(1),U,11)=$EXTRACT(X,9,20)
- SET $PIECE(DVBP(1),U,12)=$EXTRACT(X,21,28)
- SET $PIECE(DVBP(1),U,13)=$EXTRACT(X,29,40)
- SET $PIECE(DVBP(1),U,14)=$EXTRACT(X,41,52)
- SET $PIECE(DVBP(1),U,15)=$EXTRACT(X,53,64)
- SET $PIECE(DVBP(1),U,16)=$EXTRACT(X,65,76)
- +2 SET L=77
- DO RON
- +3 ;
- +4 QUIT
- +5 ;
