source: FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHQR13.m@ 1101

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

initial load of FOIAVistA 6/30/08 version
File size: 5.1 KB
Line 
1DVBHQR13 ;ALB/JLU;part of the c&p/birls striper routines ; 7/11/05 12:45pm
2 ;;4.0;HINQ;**15,32,35,49**;03/25/92
3 ;
4INC ;INCOME-SEGMENT.
5 S $P(DVBINC,U,1)=$E(X,1),$P(DVBINC,U,2)=$E(X,2)
6 S $P(DVBINC,U,3)=$E(X,3),$P(DVBINC,U,4)=$E(X,4)
7 S $P(DVBINC,U,5)=$E(X,5),$P(DVBINC,U,6)=$E(X,6)
8 S $P(DVBINC,U,7)=$E(X,7),$P(DVBINC,U,8)=$E(X,8)
9 S $P(DVBINC,U,9)=$E(X,9),$P(DVBINC,U,10)=$E(X,10)
10 S $P(DVBINC,U,11)=$E(X,11),$P(DVBINC,U,12)=$E(X,12,16)
11 S $P(DVBINC,U,13)=$E(X,17,21),$P(DVBINC,U,14)=$E(X,22,25)
12 S DVBV1=$E(X,26,30)
13 I DVBV1?4N1A!(DVBV1["{") S DVBV2=5 D SIGN^DVBHUTIL Q:$G(DVBERCS)
14 S $P(DVBINC,U,15)=+DVBV1,$P(DVBINC,U,16)=$E(X,31)
15 S DVBV1=$E(X,32,36)
16 I DVBV1?4N1A!(DVBV1["{") S DVBV2=5 D SIGN^DVBHUTIL Q:$G(DVBERCS)
17 S $P(DVBINC,U,17)=DVBV1,$P(DVBINC,U,18)=$E(X,37)
18 S $P(DVBINC,U,19)=$E(X,38,39),$P(DVBINC,U,20)=$E(X,40)
19 S $P(DVBINC,U,21)=$E(X,41),$P(DVBINC,U,22)=$E(X,42)
20 S $P(DVBINC,U,23)=$E(X,43),$P(DVBINC,U,24)=$E(X,44,45)
21 S $P(DVBINC,U,25)=$E(X,46),$P(DVBINC,U,26)=$E(X,47)
22 S $P(DVBINC,U,27)=$E(X,48),$P(DVBINC,U,28)=$E(X,49)
23 S DVBV1=$E(X,50,54)
24 I DVBV1?4N1A!(DVBV1["{") S DVBV2=5 D SIGN^DVBHUTIL Q:$G(DVBERCS)
25 S $P(DVBINC,U,29)=DVBV1,$P(DVBINC,U,30)=$E(X,55)
26 S L=56 D RON
27 ;all records now "A" ;I $P(DVBINC,U,1)="A" S L=51 D RON
28 ;E D BINC
29 ;
30MONRET ;MONTHLY-RETIREMENT-SEGMENT.
31 S DVBV1=$E(X,1,2)
32 I DVBV1?1N1A!(DVBV1["{") S DVBV2=2 D SIGN^DVBHUTIL Q:$G(DVBERCS)
33 S $P(DVBMON,U,1)=DVBV1,$P(DVBMON,U,2)=$E(X,3,5)
34 S L=6 D RON
35 F LP=1:1:10 D RET1 S L=16 D RON
36 ;
37BIRL ;BIRLS DATA.
38 S DVBSSN=$E(X,1,9),X=$E(X,10,999)
39 S J=-8 F I=2:1:4 S J=J+9,DVBSN(I)=$E(X,J,J+8)
40 S L=J+9 D RON
41 ;
42NAM S J=-62 F I=1:1:3 S J=J+63 I $E(X,J,J+62)'=" " S DVBPNAM(I)=$E(X,J,J+62)
43 S L=J+63 D RON
44 ;
45DOD S $P(DVBP(6),U,1)=$E(X,1,8),X=$E(X,9,999)
46 ;
47BOS S J=-3 F I=2:1:4 S J=J+4 S DVBBOS(I)=$E(X,J,J+3)
48 S X=$E(X,J+4,999)
49 ;
50EOD ;Get EODs. Assuming dates sent in as MMDDCCYY.
51 S J=-7 F I=2:1:4 S J=J+8,DVBEOD(I)=($E(X,J+4,J+5)-17)_$E(X,J+6,J+7)_$E(X,J,J+3)
52 S L=J+8 D RON
53 ;
54RAD ;Get RADs. Assuming dates sent in as MMDDCCYY.
55 S J=-7 F I=2:1:4 D
56 . S J=J+8,DVBRAD(I)=($E(X,J+4,J+5)-17)_$E(X,J+6,J+7)_$E(X,J,J+3)
57 S L=J+8 D RON
58 ;
59SVC S J=-2 F I=2:1:4 S J=J+3,DVBCSVC(I)=$E(X,J,J+2)
60 S L=J+3 D RON
61 ;
62POW D POW^DVBHUTL1
63 ;
64 I +Y S Y=$S($E(Y,1,2):+$E(Y,1,2)_" yr ",1:"")_$S($E(Y,3,4):+$E(Y,3,4)_" mo ",1:"")_$S($E(Y,5,6):+$E(Y,5,6)_" days ",1:""),DVBTOTAS=Y
65 S L=11 D RON
66 ;
67 S $P(DVBBIR,U,18)=$E(X,1,3),X=$E(X,4,999)
68 S $P(DVBP(6),U,3)=$E(X,1),$P(DVBP(6),U,2)=$E(X,2)
69 S $P(DVBP(6),U,4)=$E(X,3),$P(DVBBIR,U,22)=$E(X,4)
70 S $P(DVBP(6),U,5)=$E(X,5),$P(DVBBIR,U,24)=$E(X,6)
71 S $P(DVBBIR,U,25)=$E(X,7),$P(DVBP(6),U,6)=$E(X,8)
72 S $P(DVBP(6),U,7)=$E(X,9),$P(DVBBIR,U,28)=$E(X,10)
73 S $P(DVBP(6),U,8)=$E(X,11),$P(DVBBIR,U,30)=$E(X,12)
74 ;order of response string has been changed DVB*5.3*49
75 S L=13 D RON
76 D DIAG^DVBHQR11
77 Q
78 ;quitting here, DVB*4*49 obviates the necessity for the ADJ subroutine
79 ;End of BIRLS segment.
80 ;
81ADJ ;
82 Q ;DVB*4*49
83 Q:'$D(DVBRETT) Q:'$D(DVBRETO)
84 I $D(DVBSSA),+DVBSSA Q
85 I DVBRETT="S" S DVBSSA=DVBRETO,DVBRETO=0
86 ;This section is to determine the Permanent and total Indicator.
87 S DVBPTI=" "
88 I $D(DVBFUF),$P(DVBFUF,U,1)'=" " D SPTI Q
89 I $D(DVBVET),$P(DVBVET,U,1)="A",$P(DVBP(2),U,7)>0,$P(DVBP(2),U,7)<4 D SPTI Q
90 F LP1=1:1:9 S LP2=$P(DVBP(3),U,2+LP1) I $E(LP2,7,8)="01" D SPTI Q
91 Q ;END OF THE C&P/BIRLS STRING
92 ;
93SPTI ;Sets the Permanent and total indicator.
94 S DVBPTI="N"
95 ;
96BINC ;B type of income segment
97 S DVBV1=$E(X,1,5)
98 I DVBV1?4N1A!(DVBV1["{") S DVBV2=5 D SIGN^DVBHUTIL Q:$G(DVBERCS)
99 S DVBEINC=+DVBV1
100 S DVBV1=$E(X,6,10)
101 I DVBV1?4N1A!(DVBV1["{") S DVBV2=5 D SIGN^DVBHUTIL Q:$G(DVBERCS)
102 S DVBSSA=+DVBV1,DVBRETT=$E(X,11)
103 S DVBV1=$E(X,12,16)
104 I DVBV1?4N1A!(DVBV1["{") S DVBV2=5 D SIGN^DVBHUTIL Q:$G(DVBERCS)
105 S DVBRETO=+DVBV1
106 S DVBV1=$E(X,17,21)
107 I DVBV1?4N1A!(DVBV1["{") S DVBV2=5 D SIGN^DVBHUTIL Q:$G(DVBERCS)
108 S DVBOINC=+DVBV1,$P(DVBINC,U,36)=$E(X,22,25)
109 S L=26 D RON
110 I $P(DVBINC,U,1)="B" S L=26 D RON Q
111 E D CINC
112 Q
113 ;
114CINC ;C type of the income segment
115 S DVBV1=$E(X,1,5)
116 I DVBV1?4N1A!(DVBV1["{") S DVBV2=5 D SIGN^DVBHUTIL Q:$G(DVBERCS)
117 S DVBSPENC=+DVBV1
118 S DVBV1=$E(X,6,10)
119 I DVBV1?4N1A!(DVBV1["{") S DVBV2=5 D SIGN^DVBHUTIL Q:$G(DVBERCS)
120 S DVBSPSSA=+DVBV1,DVBSPRET=$E(X,11)
121 S DVBV1=$E(X,12,16)
122 I DVBV1?4N1A!(DVBV1["{") S DVBV2=5 D SIGN^DVBHUTIL Q:$G(DVBERCS)
123 S DVBSPETO=+DVBV1
124 S DVBV1=$E(X,17,21)
125 I DVBV1?4N1A!(DVBV1["{") S DVBV2=5 D SIGN^DVBHUTIL Q:$G(DVBERCS)
126 S DVBSPINC=+DVBV1
127 S $P(DVBINC,U,42)=$E(X,22,25)
128 S L=26 D RON
129 Q
130 ;
131RET1 S DVBRTYP=$E(X,1,3) Q:DVBRTYP'?3N
132 S DVBV1=$E(X,4,9)
133 I DVBV1?5N1A!(DVBV1["{") S DVBV2=6 D SIGN^DVBHUTIL Q:$G(DVBERCS)
134 S DVBRTYPE(+DVBRTYP)=+$E(DVBV1,1,4)_"."_$E(DVBV1,5,6)
135 S DVBV1=$E(X,10,15)
136 I DVBV1?5N1A!(DVBV1["{") S DVBV2=6 D SIGN^DVBHUTIL Q:$G(DVBERCS)
137 S DVBRTYPE(+DVBRTYP)=DVBRTYPE(+DVBRTYP)_U_+$E(DVBV1,1,4)_"."_$E(DVBV1,5,6)
138 Q
139 ;
140RON 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
141 I $D(X(2)) S X=X_$E(X(2),1,LY),X(2)=$E(X(2),LY+1,999) Q
142 Q
143 ;
144RON1 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))
145 ;;;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)
146 QUIT
Note: See TracBrowser for help on using the repository browser.