- DVBHQR13 ;ALB/JLU;part of the c&p/birls striper routines ; 7/11/05 12:45pm
- ;;4.0;HINQ;**15,32,35,49**;03/25/92
- ;
- INC ;INCOME-SEGMENT.
- S $P(DVBINC,U,1)=$E(X,1),$P(DVBINC,U,2)=$E(X,2)
- S $P(DVBINC,U,3)=$E(X,3),$P(DVBINC,U,4)=$E(X,4)
- S $P(DVBINC,U,5)=$E(X,5),$P(DVBINC,U,6)=$E(X,6)
- S $P(DVBINC,U,7)=$E(X,7),$P(DVBINC,U,8)=$E(X,8)
- S $P(DVBINC,U,9)=$E(X,9),$P(DVBINC,U,10)=$E(X,10)
- S $P(DVBINC,U,11)=$E(X,11),$P(DVBINC,U,12)=$E(X,12,16)
- S $P(DVBINC,U,13)=$E(X,17,21),$P(DVBINC,U,14)=$E(X,22,25)
- S DVBV1=$E(X,26,30)
- I DVBV1?4N1A!(DVBV1["{") S DVBV2=5 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S $P(DVBINC,U,15)=+DVBV1,$P(DVBINC,U,16)=$E(X,31)
- S DVBV1=$E(X,32,36)
- I DVBV1?4N1A!(DVBV1["{") S DVBV2=5 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S $P(DVBINC,U,17)=DVBV1,$P(DVBINC,U,18)=$E(X,37)
- S $P(DVBINC,U,19)=$E(X,38,39),$P(DVBINC,U,20)=$E(X,40)
- S $P(DVBINC,U,21)=$E(X,41),$P(DVBINC,U,22)=$E(X,42)
- S $P(DVBINC,U,23)=$E(X,43),$P(DVBINC,U,24)=$E(X,44,45)
- S $P(DVBINC,U,25)=$E(X,46),$P(DVBINC,U,26)=$E(X,47)
- S $P(DVBINC,U,27)=$E(X,48),$P(DVBINC,U,28)=$E(X,49)
- S DVBV1=$E(X,50,54)
- I DVBV1?4N1A!(DVBV1["{") S DVBV2=5 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S $P(DVBINC,U,29)=DVBV1,$P(DVBINC,U,30)=$E(X,55)
- S L=56 D RON
- ;all records now "A" ;I $P(DVBINC,U,1)="A" S L=51 D RON
- ;E D BINC
- ;
- MONRET ;MONTHLY-RETIREMENT-SEGMENT.
- S DVBV1=$E(X,1,2)
- I DVBV1?1N1A!(DVBV1["{") S DVBV2=2 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S $P(DVBMON,U,1)=DVBV1,$P(DVBMON,U,2)=$E(X,3,5)
- S L=6 D RON
- F LP=1:1:10 D RET1 S L=16 D RON
- ;
- BIRL ;BIRLS DATA.
- S DVBSSN=$E(X,1,9),X=$E(X,10,999)
- S J=-8 F I=2:1:4 S J=J+9,DVBSN(I)=$E(X,J,J+8)
- S L=J+9 D RON
- ;
- NAM 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)
- S L=J+63 D RON
- ;
- DOD S $P(DVBP(6),U,1)=$E(X,1,8),X=$E(X,9,999)
- ;
- BOS S J=-3 F I=2:1:4 S J=J+4 S DVBBOS(I)=$E(X,J,J+3)
- S X=$E(X,J+4,999)
- ;
- EOD ;Get EODs. Assuming dates sent in as MMDDCCYY.
- 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)
- S L=J+8 D RON
- ;
- RAD ;Get RADs. Assuming dates sent in as MMDDCCYY.
- S J=-7 F I=2:1:4 D
- . S J=J+8,DVBRAD(I)=($E(X,J+4,J+5)-17)_$E(X,J+6,J+7)_$E(X,J,J+3)
- S L=J+8 D RON
- ;
- SVC S J=-2 F I=2:1:4 S J=J+3,DVBCSVC(I)=$E(X,J,J+2)
- S L=J+3 D RON
- ;
- POW D POW^DVBHUTL1
- ;
- 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
- S L=11 D RON
- ;
- S $P(DVBBIR,U,18)=$E(X,1,3),X=$E(X,4,999)
- S $P(DVBP(6),U,3)=$E(X,1),$P(DVBP(6),U,2)=$E(X,2)
- S $P(DVBP(6),U,4)=$E(X,3),$P(DVBBIR,U,22)=$E(X,4)
- S $P(DVBP(6),U,5)=$E(X,5),$P(DVBBIR,U,24)=$E(X,6)
- S $P(DVBBIR,U,25)=$E(X,7),$P(DVBP(6),U,6)=$E(X,8)
- S $P(DVBP(6),U,7)=$E(X,9),$P(DVBBIR,U,28)=$E(X,10)
- S $P(DVBP(6),U,8)=$E(X,11),$P(DVBBIR,U,30)=$E(X,12)
- ;order of response string has been changed DVB*5.3*49
- S L=13 D RON
- D DIAG^DVBHQR11
- Q
- ;quitting here, DVB*4*49 obviates the necessity for the ADJ subroutine
- ;End of BIRLS segment.
- ;
- ADJ ;
- Q ;DVB*4*49
- Q:'$D(DVBRETT) Q:'$D(DVBRETO)
- I $D(DVBSSA),+DVBSSA Q
- I DVBRETT="S" S DVBSSA=DVBRETO,DVBRETO=0
- ;This section is to determine the Permanent and total Indicator.
- S DVBPTI=" "
- I $D(DVBFUF),$P(DVBFUF,U,1)'=" " D SPTI Q
- I $D(DVBVET),$P(DVBVET,U,1)="A",$P(DVBP(2),U,7)>0,$P(DVBP(2),U,7)<4 D SPTI Q
- F LP1=1:1:9 S LP2=$P(DVBP(3),U,2+LP1) I $E(LP2,7,8)="01" D SPTI Q
- Q ;END OF THE C&P/BIRLS STRING
- ;
- SPTI ;Sets the Permanent and total indicator.
- S DVBPTI="N"
- ;
- BINC ;B type of income segment
- S DVBV1=$E(X,1,5)
- I DVBV1?4N1A!(DVBV1["{") S DVBV2=5 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S DVBEINC=+DVBV1
- S DVBV1=$E(X,6,10)
- I DVBV1?4N1A!(DVBV1["{") S DVBV2=5 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S DVBSSA=+DVBV1,DVBRETT=$E(X,11)
- S DVBV1=$E(X,12,16)
- I DVBV1?4N1A!(DVBV1["{") S DVBV2=5 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S DVBRETO=+DVBV1
- S DVBV1=$E(X,17,21)
- I DVBV1?4N1A!(DVBV1["{") S DVBV2=5 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S DVBOINC=+DVBV1,$P(DVBINC,U,36)=$E(X,22,25)
- S L=26 D RON
- I $P(DVBINC,U,1)="B" S L=26 D RON Q
- E D CINC
- Q
- ;
- CINC ;C type of the income segment
- S DVBV1=$E(X,1,5)
- I DVBV1?4N1A!(DVBV1["{") S DVBV2=5 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S DVBSPENC=+DVBV1
- S DVBV1=$E(X,6,10)
- I DVBV1?4N1A!(DVBV1["{") S DVBV2=5 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S DVBSPSSA=+DVBV1,DVBSPRET=$E(X,11)
- S DVBV1=$E(X,12,16)
- I DVBV1?4N1A!(DVBV1["{") S DVBV2=5 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S DVBSPETO=+DVBV1
- S DVBV1=$E(X,17,21)
- I DVBV1?4N1A!(DVBV1["{") S DVBV2=5 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S DVBSPINC=+DVBV1
- S $P(DVBINC,U,42)=$E(X,22,25)
- S L=26 D RON
- Q
- ;
- RET1 S DVBRTYP=$E(X,1,3) Q:DVBRTYP'?3N
- S DVBV1=$E(X,4,9)
- I DVBV1?5N1A!(DVBV1["{") S DVBV2=6 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S DVBRTYPE(+DVBRTYP)=+$E(DVBV1,1,4)_"."_$E(DVBV1,5,6)
- S DVBV1=$E(X,10,15)
- I DVBV1?5N1A!(DVBV1["{") S DVBV2=6 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S DVBRTYPE(+DVBRTYP)=DVBRTYPE(+DVBRTYP)_U_+$E(DVBV1,1,4)_"."_$E(DVBV1,5,6)
- Q
- ;
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBHQR13 5405 printed Feb 18, 2025@23:25:14 Page 2
- DVBHQR13 ;ALB/JLU;part of the c&p/birls striper routines ; 7/11/05 12:45pm
- +1 ;;4.0;HINQ;**15,32,35,49**;03/25/92
- +2 ;
- INC ;INCOME-SEGMENT.
- +1 SET $PIECE(DVBINC,U,1)=$EXTRACT(X,1)
- SET $PIECE(DVBINC,U,2)=$EXTRACT(X,2)
- +2 SET $PIECE(DVBINC,U,3)=$EXTRACT(X,3)
- SET $PIECE(DVBINC,U,4)=$EXTRACT(X,4)
- +3 SET $PIECE(DVBINC,U,5)=$EXTRACT(X,5)
- SET $PIECE(DVBINC,U,6)=$EXTRACT(X,6)
- +4 SET $PIECE(DVBINC,U,7)=$EXTRACT(X,7)
- SET $PIECE(DVBINC,U,8)=$EXTRACT(X,8)
- +5 SET $PIECE(DVBINC,U,9)=$EXTRACT(X,9)
- SET $PIECE(DVBINC,U,10)=$EXTRACT(X,10)
- +6 SET $PIECE(DVBINC,U,11)=$EXTRACT(X,11)
- SET $PIECE(DVBINC,U,12)=$EXTRACT(X,12,16)
- +7 SET $PIECE(DVBINC,U,13)=$EXTRACT(X,17,21)
- SET $PIECE(DVBINC,U,14)=$EXTRACT(X,22,25)
- +8 SET DVBV1=$EXTRACT(X,26,30)
- +9 IF DVBV1?4N1A!(DVBV1["{")
- SET DVBV2=5
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +10 SET $PIECE(DVBINC,U,15)=+DVBV1
- SET $PIECE(DVBINC,U,16)=$EXTRACT(X,31)
- +11 SET DVBV1=$EXTRACT(X,32,36)
- +12 IF DVBV1?4N1A!(DVBV1["{")
- SET DVBV2=5
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +13 SET $PIECE(DVBINC,U,17)=DVBV1
- SET $PIECE(DVBINC,U,18)=$EXTRACT(X,37)
- +14 SET $PIECE(DVBINC,U,19)=$EXTRACT(X,38,39)
- SET $PIECE(DVBINC,U,20)=$EXTRACT(X,40)
- +15 SET $PIECE(DVBINC,U,21)=$EXTRACT(X,41)
- SET $PIECE(DVBINC,U,22)=$EXTRACT(X,42)
- +16 SET $PIECE(DVBINC,U,23)=$EXTRACT(X,43)
- SET $PIECE(DVBINC,U,24)=$EXTRACT(X,44,45)
- +17 SET $PIECE(DVBINC,U,25)=$EXTRACT(X,46)
- SET $PIECE(DVBINC,U,26)=$EXTRACT(X,47)
- +18 SET $PIECE(DVBINC,U,27)=$EXTRACT(X,48)
- SET $PIECE(DVBINC,U,28)=$EXTRACT(X,49)
- +19 SET DVBV1=$EXTRACT(X,50,54)
- +20 IF DVBV1?4N1A!(DVBV1["{")
- SET DVBV2=5
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +21 SET $PIECE(DVBINC,U,29)=DVBV1
- SET $PIECE(DVBINC,U,30)=$EXTRACT(X,55)
- +22 SET L=56
- DO RON
- +23 ;all records now "A" ;I $P(DVBINC,U,1)="A" S L=51 D RON
- +24 ;E D BINC
- +25 ;
- MONRET ;MONTHLY-RETIREMENT-SEGMENT.
- +1 SET DVBV1=$EXTRACT(X,1,2)
- +2 IF DVBV1?1N1A!(DVBV1["{")
- SET DVBV2=2
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +3 SET $PIECE(DVBMON,U,1)=DVBV1
- SET $PIECE(DVBMON,U,2)=$EXTRACT(X,3,5)
- +4 SET L=6
- DO RON
- +5 FOR LP=1:1:10
- DO RET1
- SET L=16
- DO RON
- +6 ;
- BIRL ;BIRLS DATA.
- +1 SET DVBSSN=$EXTRACT(X,1,9)
- SET X=$EXTRACT(X,10,999)
- +2 SET J=-8
- FOR I=2:1:4
- SET J=J+9
- SET DVBSN(I)=$EXTRACT(X,J,J+8)
- +3 SET L=J+9
- DO RON
- +4 ;
- NAM SET J=-62
- FOR I=1:1:3
- SET J=J+63
- IF $EXTRACT(X,J,J+62)'=" "
- SET DVBPNAM(I)=$EXTRACT(X,J,J+62)
- +1 SET L=J+63
- DO RON
- +2 ;
- DOD SET $PIECE(DVBP(6),U,1)=$EXTRACT(X,1,8)
- SET X=$EXTRACT(X,9,999)
- +1 ;
- BOS SET J=-3
- FOR I=2:1:4
- SET J=J+4
- SET DVBBOS(I)=$EXTRACT(X,J,J+3)
- +1 SET X=$EXTRACT(X,J+4,999)
- +2 ;
- EOD ;Get EODs. Assuming dates sent in as MMDDCCYY.
- +1 SET J=-7
- FOR I=2:1:4
- SET J=J+8
- SET DVBEOD(I)=($EXTRACT(X,J+4,J+5)-17)_$EXTRACT(X,J+6,J+7)_$EXTRACT(X,J,J+3)
- +2 SET L=J+8
- DO RON
- +3 ;
- RAD ;Get RADs. Assuming dates sent in as MMDDCCYY.
- +1 SET J=-7
- FOR I=2:1:4
- Begin DoDot:1
- +2 SET J=J+8
- SET DVBRAD(I)=($EXTRACT(X,J+4,J+5)-17)_$EXTRACT(X,J+6,J+7)_$EXTRACT(X,J,J+3)
- End DoDot:1
- +3 SET L=J+8
- DO RON
- +4 ;
- SVC SET J=-2
- FOR I=2:1:4
- SET J=J+3
- SET DVBCSVC(I)=$EXTRACT(X,J,J+2)
- +1 SET L=J+3
- DO RON
- +2 ;
- POW DO POW^DVBHUTL1
- +1 ;
- +2 IF +Y
- SET Y=$SELECT($EXTRACT(Y,1,2):+$EXTRACT(Y,1,2)_" yr ",1:"")_$SELECT($EXTRACT(Y,3,4):+$EXTRACT(Y,3,4)_" mo ",1:"")_$SELECT($EXTRACT(Y,5,6):+$EXTRACT(Y,5,6)_" days ",1:"")
- SET DVBTOTAS=Y
- +3 SET L=11
- DO RON
- +4 ;
- +5 SET $PIECE(DVBBIR,U,18)=$EXTRACT(X,1,3)
- SET X=$EXTRACT(X,4,999)
- +6 SET $PIECE(DVBP(6),U,3)=$EXTRACT(X,1)
- SET $PIECE(DVBP(6),U,2)=$EXTRACT(X,2)
- +7 SET $PIECE(DVBP(6),U,4)=$EXTRACT(X,3)
- SET $PIECE(DVBBIR,U,22)=$EXTRACT(X,4)
- +8 SET $PIECE(DVBP(6),U,5)=$EXTRACT(X,5)
- SET $PIECE(DVBBIR,U,24)=$EXTRACT(X,6)
- +9 SET $PIECE(DVBBIR,U,25)=$EXTRACT(X,7)
- SET $PIECE(DVBP(6),U,6)=$EXTRACT(X,8)
- +10 SET $PIECE(DVBP(6),U,7)=$EXTRACT(X,9)
- SET $PIECE(DVBBIR,U,28)=$EXTRACT(X,10)
- +11 SET $PIECE(DVBP(6),U,8)=$EXTRACT(X,11)
- SET $PIECE(DVBBIR,U,30)=$EXTRACT(X,12)
- +12 ;order of response string has been changed DVB*5.3*49
- +13 SET L=13
- DO RON
- +14 DO DIAG^DVBHQR11
- +15 QUIT
- +16 ;quitting here, DVB*4*49 obviates the necessity for the ADJ subroutine
- +17 ;End of BIRLS segment.
- +18 ;
- ADJ ;
- +1 ;DVB*4*49
- QUIT
- +2 if '$DATA(DVBRETT)
- QUIT
- if '$DATA(DVBRETO)
- QUIT
- +3 IF $DATA(DVBSSA)
- IF +DVBSSA
- QUIT
- +4 IF DVBRETT="S"
- SET DVBSSA=DVBRETO
- SET DVBRETO=0
- +5 ;This section is to determine the Permanent and total Indicator.
- +6 SET DVBPTI=" "
- +7 IF $DATA(DVBFUF)
- IF $PIECE(DVBFUF,U,1)'=" "
- DO SPTI
- QUIT
- +8 IF $DATA(DVBVET)
- IF $PIECE(DVBVET,U,1)="A"
- IF $PIECE(DVBP(2),U,7)>0
- IF $PIECE(DVBP(2),U,7)<4
- DO SPTI
- QUIT
- +9 FOR LP1=1:1:9
- SET LP2=$PIECE(DVBP(3),U,2+LP1)
- IF $EXTRACT(LP2,7,8)="01"
- DO SPTI
- QUIT
- +10 ;END OF THE C&P/BIRLS STRING
- QUIT
- +11 ;
- SPTI ;Sets the Permanent and total indicator.
- +1 SET DVBPTI="N"
- +2 ;
- BINC ;B type of income segment
- +1 SET DVBV1=$EXTRACT(X,1,5)
- +2 IF DVBV1?4N1A!(DVBV1["{")
- SET DVBV2=5
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +3 SET DVBEINC=+DVBV1
- +4 SET DVBV1=$EXTRACT(X,6,10)
- +5 IF DVBV1?4N1A!(DVBV1["{")
- SET DVBV2=5
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +6 SET DVBSSA=+DVBV1
- SET DVBRETT=$EXTRACT(X,11)
- +7 SET DVBV1=$EXTRACT(X,12,16)
- +8 IF DVBV1?4N1A!(DVBV1["{")
- SET DVBV2=5
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +9 SET DVBRETO=+DVBV1
- +10 SET DVBV1=$EXTRACT(X,17,21)
- +11 IF DVBV1?4N1A!(DVBV1["{")
- SET DVBV2=5
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +12 SET DVBOINC=+DVBV1
- SET $PIECE(DVBINC,U,36)=$EXTRACT(X,22,25)
- +13 SET L=26
- DO RON
- +14 IF $PIECE(DVBINC,U,1)="B"
- SET L=26
- DO RON
- QUIT
- +15 IF '$TEST
- DO CINC
- +16 QUIT
- +17 ;
- CINC ;C type of the income segment
- +1 SET DVBV1=$EXTRACT(X,1,5)
- +2 IF DVBV1?4N1A!(DVBV1["{")
- SET DVBV2=5
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +3 SET DVBSPENC=+DVBV1
- +4 SET DVBV1=$EXTRACT(X,6,10)
- +5 IF DVBV1?4N1A!(DVBV1["{")
- SET DVBV2=5
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +6 SET DVBSPSSA=+DVBV1
- SET DVBSPRET=$EXTRACT(X,11)
- +7 SET DVBV1=$EXTRACT(X,12,16)
- +8 IF DVBV1?4N1A!(DVBV1["{")
- SET DVBV2=5
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +9 SET DVBSPETO=+DVBV1
- +10 SET DVBV1=$EXTRACT(X,17,21)
- +11 IF DVBV1?4N1A!(DVBV1["{")
- SET DVBV2=5
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +12 SET DVBSPINC=+DVBV1
- +13 SET $PIECE(DVBINC,U,42)=$EXTRACT(X,22,25)
- +14 SET L=26
- DO RON
- +15 QUIT
- +16 ;
- RET1 SET DVBRTYP=$EXTRACT(X,1,3)
- if DVBRTYP'?3N
- QUIT
- +1 SET DVBV1=$EXTRACT(X,4,9)
- +2 IF DVBV1?5N1A!(DVBV1["{")
- SET DVBV2=6
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +3 SET DVBRTYPE(+DVBRTYP)=+$EXTRACT(DVBV1,1,4)_"."_$EXTRACT(DVBV1,5,6)
- +4 SET DVBV1=$EXTRACT(X,10,15)
- +5 IF DVBV1?5N1A!(DVBV1["{")
- SET DVBV2=6
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +6 SET DVBRTYPE(+DVBRTYP)=DVBRTYPE(+DVBRTYP)_U_+$EXTRACT(DVBV1,1,4)_"."_$EXTRACT(DVBV1,5,6)
- +7 QUIT
- +8 ;
- 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