DVBHQR1 ;ISC-ALBANY/PKE/JLU - parse HINQ response;27 SEP 85 10:56 am
;;4.0;HINQ;**5,32,53,49,65**;03/25/92;Build 19
; PROCESSING THE C&P RECORD AND THEN THE BIRLS RECORD
BASIC S DFN=+$E(X(1),8,21),DVBLEN=$E(X(1),22,25),X=$E(X(1),26,999),DVBCN=$E(X,1,9)
;
;DVB*4*49 - claim # no longer coming as last 2 chars first
S $P(DVBBAS(1),U,3)=$E(X,10),$P(DVBBAS(1),U,4)=$E(X,11,12)
S $P(DVBBAS(1),U,5)=$E(X,13,17),$P(DVBBAS(1),U,6)="A"
;all records after DVB*4*49 will be sent as type "A"
;beginning of basic seg A,B,C,E,F
S DVBNAME=$E(X,19,25)
S $P(DVBBAS(1),U,8)=$E(X,26,27)
S $P(DVBBAS(1),U,9)=$E(X,28),$P(DVBBAS(1),U,10)=$E(X,29,33)
S DVBFL=$E(X,34,35)
I +DVBFL S Y=$S($D(^DIC(4,"D",3_DVBFL)):$O(^(3_DVBFL,"")),$D(^DIC(4,"D",4_DVBFL)):$O(^(4_DVBFL,"")),1:"") I Y S Y=$S($D(^DIC(4,Y,0)):$P(^DIC(4,Y,99),U,1)_" - "_$P(^(0),U),1:""),DVBFL=Y
I DVBFL="" S DVBFL="UNABLE TO DETERMINE"
S $P(DVBBAS(1),U,12)=$E(X,36),$P(DVBBAS(1),U,13)=$E(X,37)
S $P(DVBBAS(1),U,14)=$E(X,38),$P(DVBBAS(1),U,15)=$E(X,39)
S $P(DVBBAS(1),U,16)=$E(X,40)
S DVBV1=$E(X,41)
;I DVBV1?1A!(DVBV1["{") S DVBV2=1 D SIGN^DVBHUTIL
S $P(DVBBAS(1),U,17)=DVBV1
S $P(DVBBAS(1),U,18)=$E(X,42)
I $P(DVBBAS(1),U,6)="D" S $P(DVBBAS(1),U,19)=$E(X,43),$P(DVBBAS(1),U,20)=$E(X,44,45) S L=161 D RON G STAT^DVBHQR11 ;end of BASIC D segment
S $P(DVBBAS(1),U,19)=$E(X,43,45)
S DVBV1=+$E(X,46,51)
I DVBV1?5N1A!(DVBV1["{") S DVBV2=6 D SIGN^DVBHUTIL Q:$G(DVBERCS)
S $P(DVBBAS(1),U,20)=+$E(DVBV1,1,$L(DVBV1)-2)_"."_$E(DVBV1,$L(DVBV1)-1,$L(DVBV1))
S L=52 D RON
S $P(DVBBAS(1),U,21)=$E(X,1,8)
S DVBV1=+$E(X,9,14)
I DVBV1?5N1A!(DVBV1["{") S DVBV2=6 D SIGN^DVBHUTIL Q:$G(DVBERCS)
S DVBCHECK=+$E(DVBV1,1,$L(DVBV1)-2)_"."_$E(DVBV1,$L(DVBV1)-1,$L(DVBV1))
S $P(DVBBAS(1),U,23)=$E(X,15)
S $P(DVBP(1),U,4)=$E(X,16,17)
S DVBV1=$E(X,18)
I DVBV1?1A!(DVBV1["{") S DVBV2=1 D SIGN^DVBHUTIL Q:$G(DVBERCS)
S DVBADRLN=DVBV1
S DVBV1=$E(X,19)
I DVBV1?1A!(DVBV1["{") S DVBV2=1 D SIGN^DVBHUTIL Q:$G(DVBERCS)
S $P(DVBBAS(1),U,26)=DVBV1
S $P(DVBBAS(1),U,27)=$E(X,20)
S DVBFIDUC=$E(X,21,22)
I +DVBFIDUC S Y=$S($D(^DIC(4,"D",3_DVBFIDUC)):$O(^(3_DVBFIDUC,"")),$D(^DIC(4,"D",4_DVBFIDUC)):$O(^(4_DVBFIDUC,"")),1:"") I Y S Y=$S($D(^DIC(4,Y,0)):$P(^DIC(4,Y,99),U,1)_" - "_$P(^(0),U),1:""),DVBFIDUC=Y
I DVBFIDUC=99 S DVBFIDUC=""
S $P(DVBBAS(1),U,29)=$E(X,23,24),$P(DVBBAS(1),U,30)=$E(X,25)
S $P(DVBBAS(1),U,31)=$E(X,26),$P(DVBBAS(1),U,32)=$E(X,27,28)
S $P(DVBBAS(1),U,33)=$E(X,29,30),$P(DVBBAS(1),U,34)=$E(X,31)
S $P(DVBBAS(1),U,35)=$E(X,32)
;need to calculate power of attorney from C&P
S DVBPOA="0"_$E(X,33,34) D POA^DVBHQR2
S $P(DVBBAS(1),U,37)=$E(X,35)
S DVBV1=$E(X,36)
I DVBV1?1A!(DVBV1["{") S DVBV2=1 D SIGN^DVBHUTIL Q:$G(DVBERCS)
S $P(DVBBAS(1),U,38)=DVBV1
S $P(DVBBAS(1),U,39)=$E(X,37,41),$P(DVBBAS(1),U,40)=$E(X,42,43)
S $P(DVBP(1),U,5)=$E(X,44,45)
S $P(DVBBAS(1),U,42)=$E(X,46,47)
S DVBAAHB=$E(X,48)
S L=49 D RON
S $P(DVBBAS(2),U,1)=$E(X,1),$P(DVBBAS(2),U,2)=$E(X,2)
S $P(DVBP(1),U,8)=$E(X,3)
S $P(DVBBAS(2),U,4)=$E(X,4)
S $P(DVBBAS(2),U,5)=$E(X,5),$P(DVBBAS(2),U,6)=$E(X,6)
S $P(DVBBAS(2),U,7)=$E(X,7),$P(DVBBAS(2),U,8)=$E(X,8)
S $P(DVBBAS(2),U,9)=$E(X,9),$P(DVBBAS(2),U,10)=$E(X,10)
S $P(DVBP(1),U,2)=$E(X,11),$P(DVBP(1),U,1)=$E(X,12)
S $P(DVBP(1),U,7)=$E(X,13),$P(DVBP(1),U,6)=$E(X,14)
S DVBCSVC(1)=$E(X,15)
;;;S DVBCSVC(1)=5
S $P(DVBP(1),U,3)=$E(X,16,23)
S $P(DVBBAS(2),U,17)=$E(X,24)
S $P(DVBBAS(2),U,18)=$E(X,25),$P(DVBBAS(2),U,19)=$E(X,26)
S DVBPOW=$E(X,27)
S $P(DVBBAS(2),U,21)=$E(X,28),$P(DVBBAS(2),U,22)=$E(X,29)
S $P(DVBBAS(2),U,23)=$E(X,30),$P(DVBBAS(2),U,24)=$E(X,31)
S $P(DVBBAS(2),U,25)=$E(X,32),$P(DVBBAS(2),U,26)=$E(X,33)
S $P(DVBBAS(2),U,27)=$E(X,34),$P(DVBBAS(2),U,28)=$E(X,35)
S $P(DVBBAS(2),U,29)=$E(X,36),$P(DVBBAS(2),U,30)=$E(X,37)
S $P(DVBBAS(2),U,31)=$E(X,38),$P(DVBBAS(2),U,32)=$E(X,39)
S $P(DVBBAS(2),U,33)=$E(X,40),$P(DVBBAS(2),U,34)=$E(X,41)
S $P(DVBBAS(2),U,35)=$E(X,42),$P(DVBBAS(2),U,36)=$E(X,43)
S $P(DVBBAS(2),U,37)=$E(X,44),$P(DVBBAS(2),U,38)=$E(X,45)
S $P(DVBBAS(2),U,39)=$E(X,46),$P(DVBBAS(2),U,40)=$E(X,47)
S $P(DVBBAS(2),U,41)=$E(X,48),$P(DVBBAS(2),U,42)=$E(X,49)
S $P(DVBBAS(2),U,43)=$E(X,50),$P(DVBBAS(2),U,44)=$E(X,51)
S $P(DVBBAS(2),U,45)=$E(X,52),$P(DVBBAS(2),U,46)=$E(X,53)
S $P(DVBBAS(2),U,47)=$E(X,54),$P(DVBBAS(2),U,48)=$E(X,55,57)
S $P(DVBBAS(2),U,49)=$E(X,58),$P(DVBBAS(2),U,50)=$E(X,59,61)
S L=62 D RON
;
;check pension dates DVB*4.0*65
D PENSION^DVBHQR11
;
;end of basic segment A,B,C,E,F
;
G STAT^DVBHQR11
;
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))
;;;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)
QUIT
END K NAM,NUM Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBHQR1 4966 printed Dec 13, 2024@01:58:49 Page 2
DVBHQR1 ;ISC-ALBANY/PKE/JLU - parse HINQ response;27 SEP 85 10:56 am
+1 ;;4.0;HINQ;**5,32,53,49,65**;03/25/92;Build 19
+2 ; PROCESSING THE C&P RECORD AND THEN THE BIRLS RECORD
BASIC SET DFN=+$EXTRACT(X(1),8,21)
SET DVBLEN=$EXTRACT(X(1),22,25)
SET X=$EXTRACT(X(1),26,999)
SET DVBCN=$EXTRACT(X,1,9)
+1 ;
+2 ;DVB*4*49 - claim # no longer coming as last 2 chars first
+3 SET $PIECE(DVBBAS(1),U,3)=$EXTRACT(X,10)
SET $PIECE(DVBBAS(1),U,4)=$EXTRACT(X,11,12)
+4 SET $PIECE(DVBBAS(1),U,5)=$EXTRACT(X,13,17)
SET $PIECE(DVBBAS(1),U,6)="A"
+5 ;all records after DVB*4*49 will be sent as type "A"
+6 ;beginning of basic seg A,B,C,E,F
+7 SET DVBNAME=$EXTRACT(X,19,25)
+8 SET $PIECE(DVBBAS(1),U,8)=$EXTRACT(X,26,27)
+9 SET $PIECE(DVBBAS(1),U,9)=$EXTRACT(X,28)
SET $PIECE(DVBBAS(1),U,10)=$EXTRACT(X,29,33)
+10 SET DVBFL=$EXTRACT(X,34,35)
+11 IF +DVBFL
SET Y=$SELECT($DATA(^DIC(4,"D",3_DVBFL)):$ORDER(^(3_DVBFL,"")),$DATA(^DIC(4,"D",4_DVBFL)):$ORDER(^(4_DVBFL,"")),1:"")
IF Y
SET Y=$SELECT($DATA(^DIC(4,Y,0)):$PIECE(^DIC(4,Y,99),U,1)_" - "_$PIECE(^(0),U),1:"")
SET DVBFL=Y
+12 IF DVBFL=""
SET DVBFL="UNABLE TO DETERMINE"
+13 SET $PIECE(DVBBAS(1),U,12)=$EXTRACT(X,36)
SET $PIECE(DVBBAS(1),U,13)=$EXTRACT(X,37)
+14 SET $PIECE(DVBBAS(1),U,14)=$EXTRACT(X,38)
SET $PIECE(DVBBAS(1),U,15)=$EXTRACT(X,39)
+15 SET $PIECE(DVBBAS(1),U,16)=$EXTRACT(X,40)
+16 SET DVBV1=$EXTRACT(X,41)
+17 ;I DVBV1?1A!(DVBV1["{") S DVBV2=1 D SIGN^DVBHUTIL
+18 SET $PIECE(DVBBAS(1),U,17)=DVBV1
+19 SET $PIECE(DVBBAS(1),U,18)=$EXTRACT(X,42)
+20 ;end of BASIC D segment
IF $PIECE(DVBBAS(1),U,6)="D"
SET $PIECE(DVBBAS(1),U,19)=$EXTRACT(X,43)
SET $PIECE(DVBBAS(1),U,20)=$EXTRACT(X,44,45)
SET L=161
DO RON
GOTO STAT^DVBHQR11
+21 SET $PIECE(DVBBAS(1),U,19)=$EXTRACT(X,43,45)
+22 SET DVBV1=+$EXTRACT(X,46,51)
+23 IF DVBV1?5N1A!(DVBV1["{")
SET DVBV2=6
DO SIGN^DVBHUTIL
if $GET(DVBERCS)
QUIT
+24 SET $PIECE(DVBBAS(1),U,20)=+$EXTRACT(DVBV1,1,$LENGTH(DVBV1)-2)_"."_$EXTRACT(DVBV1,$LENGTH(DVBV1)-1,$LENGTH(DVBV1))
+25 SET L=52
DO RON
+26 SET $PIECE(DVBBAS(1),U,21)=$EXTRACT(X,1,8)
+27 SET DVBV1=+$EXTRACT(X,9,14)
+28 IF DVBV1?5N1A!(DVBV1["{")
SET DVBV2=6
DO SIGN^DVBHUTIL
if $GET(DVBERCS)
QUIT
+29 SET DVBCHECK=+$EXTRACT(DVBV1,1,$LENGTH(DVBV1)-2)_"."_$EXTRACT(DVBV1,$LENGTH(DVBV1)-1,$LENGTH(DVBV1))
+30 SET $PIECE(DVBBAS(1),U,23)=$EXTRACT(X,15)
+31 SET $PIECE(DVBP(1),U,4)=$EXTRACT(X,16,17)
+32 SET DVBV1=$EXTRACT(X,18)
+33 IF DVBV1?1A!(DVBV1["{")
SET DVBV2=1
DO SIGN^DVBHUTIL
if $GET(DVBERCS)
QUIT
+34 SET DVBADRLN=DVBV1
+35 SET DVBV1=$EXTRACT(X,19)
+36 IF DVBV1?1A!(DVBV1["{")
SET DVBV2=1
DO SIGN^DVBHUTIL
if $GET(DVBERCS)
QUIT
+37 SET $PIECE(DVBBAS(1),U,26)=DVBV1
+38 SET $PIECE(DVBBAS(1),U,27)=$EXTRACT(X,20)
+39 SET DVBFIDUC=$EXTRACT(X,21,22)
+40 IF +DVBFIDUC
SET Y=$SELECT($DATA(^DIC(4,"D",3_DVBFIDUC)):$ORDER(^(3_DVBFIDUC,"")),$DATA(^DIC(4,"D",4_DVBFIDUC)):$ORDER(^(4_DVBFIDUC,"")),1:"")
IF Y
SET Y=$SELECT($DATA(^DIC(4,Y,0)):$PIECE(^DIC(4,Y,99),U,1)_" - "_$PIECE(^(0),U),1:"")
SET DVBFIDUC=Y
+41 IF DVBFIDUC=99
SET DVBFIDUC=""
+42 SET $PIECE(DVBBAS(1),U,29)=$EXTRACT(X,23,24)
SET $PIECE(DVBBAS(1),U,30)=$EXTRACT(X,25)
+43 SET $PIECE(DVBBAS(1),U,31)=$EXTRACT(X,26)
SET $PIECE(DVBBAS(1),U,32)=$EXTRACT(X,27,28)
+44 SET $PIECE(DVBBAS(1),U,33)=$EXTRACT(X,29,30)
SET $PIECE(DVBBAS(1),U,34)=$EXTRACT(X,31)
+45 SET $PIECE(DVBBAS(1),U,35)=$EXTRACT(X,32)
+46 ;need to calculate power of attorney from C&P
+47 SET DVBPOA="0"_$EXTRACT(X,33,34)
DO POA^DVBHQR2
+48 SET $PIECE(DVBBAS(1),U,37)=$EXTRACT(X,35)
+49 SET DVBV1=$EXTRACT(X,36)
+50 IF DVBV1?1A!(DVBV1["{")
SET DVBV2=1
DO SIGN^DVBHUTIL
if $GET(DVBERCS)
QUIT
+51 SET $PIECE(DVBBAS(1),U,38)=DVBV1
+52 SET $PIECE(DVBBAS(1),U,39)=$EXTRACT(X,37,41)
SET $PIECE(DVBBAS(1),U,40)=$EXTRACT(X,42,43)
+53 SET $PIECE(DVBP(1),U,5)=$EXTRACT(X,44,45)
+54 SET $PIECE(DVBBAS(1),U,42)=$EXTRACT(X,46,47)
+55 SET DVBAAHB=$EXTRACT(X,48)
+56 SET L=49
DO RON
+57 SET $PIECE(DVBBAS(2),U,1)=$EXTRACT(X,1)
SET $PIECE(DVBBAS(2),U,2)=$EXTRACT(X,2)
+58 SET $PIECE(DVBP(1),U,8)=$EXTRACT(X,3)
+59 SET $PIECE(DVBBAS(2),U,4)=$EXTRACT(X,4)
+60 SET $PIECE(DVBBAS(2),U,5)=$EXTRACT(X,5)
SET $PIECE(DVBBAS(2),U,6)=$EXTRACT(X,6)
+61 SET $PIECE(DVBBAS(2),U,7)=$EXTRACT(X,7)
SET $PIECE(DVBBAS(2),U,8)=$EXTRACT(X,8)
+62 SET $PIECE(DVBBAS(2),U,9)=$EXTRACT(X,9)
SET $PIECE(DVBBAS(2),U,10)=$EXTRACT(X,10)
+63 SET $PIECE(DVBP(1),U,2)=$EXTRACT(X,11)
SET $PIECE(DVBP(1),U,1)=$EXTRACT(X,12)
+64 SET $PIECE(DVBP(1),U,7)=$EXTRACT(X,13)
SET $PIECE(DVBP(1),U,6)=$EXTRACT(X,14)
+65 SET DVBCSVC(1)=$EXTRACT(X,15)
+66 ;;;S DVBCSVC(1)=5
+67 SET $PIECE(DVBP(1),U,3)=$EXTRACT(X,16,23)
+68 SET $PIECE(DVBBAS(2),U,17)=$EXTRACT(X,24)
+69 SET $PIECE(DVBBAS(2),U,18)=$EXTRACT(X,25)
SET $PIECE(DVBBAS(2),U,19)=$EXTRACT(X,26)
+70 SET DVBPOW=$EXTRACT(X,27)
+71 SET $PIECE(DVBBAS(2),U,21)=$EXTRACT(X,28)
SET $PIECE(DVBBAS(2),U,22)=$EXTRACT(X,29)
+72 SET $PIECE(DVBBAS(2),U,23)=$EXTRACT(X,30)
SET $PIECE(DVBBAS(2),U,24)=$EXTRACT(X,31)
+73 SET $PIECE(DVBBAS(2),U,25)=$EXTRACT(X,32)
SET $PIECE(DVBBAS(2),U,26)=$EXTRACT(X,33)
+74 SET $PIECE(DVBBAS(2),U,27)=$EXTRACT(X,34)
SET $PIECE(DVBBAS(2),U,28)=$EXTRACT(X,35)
+75 SET $PIECE(DVBBAS(2),U,29)=$EXTRACT(X,36)
SET $PIECE(DVBBAS(2),U,30)=$EXTRACT(X,37)
+76 SET $PIECE(DVBBAS(2),U,31)=$EXTRACT(X,38)
SET $PIECE(DVBBAS(2),U,32)=$EXTRACT(X,39)
+77 SET $PIECE(DVBBAS(2),U,33)=$EXTRACT(X,40)
SET $PIECE(DVBBAS(2),U,34)=$EXTRACT(X,41)
+78 SET $PIECE(DVBBAS(2),U,35)=$EXTRACT(X,42)
SET $PIECE(DVBBAS(2),U,36)=$EXTRACT(X,43)
+79 SET $PIECE(DVBBAS(2),U,37)=$EXTRACT(X,44)
SET $PIECE(DVBBAS(2),U,38)=$EXTRACT(X,45)
+80 SET $PIECE(DVBBAS(2),U,39)=$EXTRACT(X,46)
SET $PIECE(DVBBAS(2),U,40)=$EXTRACT(X,47)
+81 SET $PIECE(DVBBAS(2),U,41)=$EXTRACT(X,48)
SET $PIECE(DVBBAS(2),U,42)=$EXTRACT(X,49)
+82 SET $PIECE(DVBBAS(2),U,43)=$EXTRACT(X,50)
SET $PIECE(DVBBAS(2),U,44)=$EXTRACT(X,51)
+83 SET $PIECE(DVBBAS(2),U,45)=$EXTRACT(X,52)
SET $PIECE(DVBBAS(2),U,46)=$EXTRACT(X,53)
+84 SET $PIECE(DVBBAS(2),U,47)=$EXTRACT(X,54)
SET $PIECE(DVBBAS(2),U,48)=$EXTRACT(X,55,57)
+85 SET $PIECE(DVBBAS(2),U,49)=$EXTRACT(X,58)
SET $PIECE(DVBBAS(2),U,50)=$EXTRACT(X,59,61)
+86 SET L=62
DO RON
+87 ;
+88 ;check pension dates DVB*4.0*65
+89 DO PENSION^DVBHQR11
+90 ;
+91 ;end of basic segment A,B,C,E,F
+92 ;
+93 GOTO STAT^DVBHQR11
+94 ;
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 ;;;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)
+2 QUIT
END KILL NAM,NUM
QUIT
+1 QUIT
