- DVBHQR12 ;ALB/JLU;ROUTINE FOR C&P AND BIRLS ;8/28/91
- ;;4.0;HINQ;**32,35,49**;03/25/92
- ; PROCESSING THE C&P RECORD AND THEN THE BIRLS RECORD
- ;
- DEDBL ; The deduction balance segment "E" and "F"
- EDEDBL S $P(DVBDBE,U,1)=$E(X,1),$P(DVBDBE,U,2)=$E(X,2,3)
- S $P(DVBDBE,U,3)=$E(X,4)
- S DVBV1=$E(X,5,10) I DVBV1?5N1A!(DVBV1["{") S DVBV2=6 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S $P(DVBDBE,U,4)=+$E(DVBV1,1,4)_"."_$E(DVBV1,5,6)
- S DVBV1=$E(X,11,18) I DVBV1?7N1A!(DVBV1["{") S DVBV2=6 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S DVBP(5)=+$E(DVBV1,1,6)_"."_$E(DVBV1,7,8)_U
- S DVBV1=$E(X,19,25) I DVBV1?6N1A!(DVBV1["{") S DVBV2=7 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S $P(DVBDBE,U,6)=+$E(DVBV1,1,5)_"."_$E(DVBV1,6,7),$P(DVBDBE,U,7)=$E(X,26,27)
- S $P(DVBDBE,U,8)=$E(X,28,29),$P(DVBDBE,U,9)=$E(X,30)
- S L=31 D RON
- ;
- FDEDBL S $P(DVBDBF,U,1)=$E(X,1),$P(DVBDBF,U,2)=$E(X,2,3)
- S $P(DVBDBF,U,3)=$E(X,4)
- S DVBV1=$E(X,5,12) I DVBV1?7N1A!(DVBV1["{") S DVBV2=8 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S $P(DVBDBF,U,4)=+$E(DVBV1,1,6)_"."_$E(DVBV1,7,8),$P(DVBDBF,U,5)=$E(X,13,14)
- S $P(DVBDBF,U,6)=$E(X,15)
- S L=16 D RON
- ;
- REF ;REFERENCE-NUMBER-DATA.
- S $P(DVBREF,U,1)=$E(X,1,9),$P(DVBREF,U,2)=$E(X,10,18)
- S $P(DVBREF,U,3)=$E(X,19,27)
- S L=28 D RON
- ;make a call to INC^DVBHQR13, as the future segments will no longer be
- ;included in the VBA response message after DVB*4*49
- G INC^DVBHQR13
- ;
- FUT ;DVB*4*49 - the call to G INC^DVBHQR13 is made in REF, and this code
- ;will be skipped
- ;FUTURE DATA.
- ;A-TYPE-FUTURE-DATA:
- S DVBP(3)="A"_"^"_9_"^"
- F XX=1:8:65 S DVBP(3)=DVBP(3)_$E(X,XX,XX+7)_"^"
- S L=XX+8 D RON
- ;E/F-TYPE-FUTURE-DATA:
- D FUTE,FUTF
- ;
- 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
- ;
- FUTE ;future segment type E
- S $P(DVBFUE,U)=$E(X,1)
- S $P(DVBFUE,U,2)=$E(X,2,9),$P(DVBFUE,U,3)=$E(X,10)
- S DVBV1=$E(X,11,16)
- I DVBV1?5N1A!(DVBV1["{") S DVBV2=6 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S $P(DVBFUE,U,4)=+$E(DVBV1,1,4)_"."_$E(DVBV1,5,6),$P(DVBFUE,U,5)=$E(X,17)
- S $P(DVBFUE,U,6)=$E(X,18,19),$P(DVBFUE,U,7)=$E(X,20,21)
- S $P(DVBFUE,U,8)=$E(X,22,23),$P(DVBFUE,U,9)=$E(24,25)
- S $P(DVBFUE,U,10)=$E(X,26),$P(DVBFUE,U,11)=$E(X,27)
- S $P(DVBFUE,U,12)=$E(X,28,32),$P(DVBFUE,U,13)=$E(X,33,34)
- S $P(DVBFUE,U,14)=$E(X,35),$P(DVBFUE,U,15)=$E(X,36)
- S $P(DVBFUE,U,16)=$E(X,37),$P(DVBFUE,U,17)=$E(X,38,40)
- S L=41 D RON
- I $P(DVBFUE,U,3) D LONGE
- E S L=31 D RON
- Q
- ;
- LONGE S LP1=18
- F LP=1:6:25 S DVBV1=$E(X,LP,LP+5) D LONCH S $P(DVBFUE,U,LP1)=+$E(DVBV1,1,4)_"."_$E(DVBV1,5,6),LP1=LP1+1
- S L=31 D RON
- Q
- ;
- LONCH I DVBV1?5N1A!(DVBV1["{") S DVBV2=6 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- Q
- ;
- FUTF ;F subsegment of the future segment.
- S $P(DVBFUF,U)=$E(X,1)
- S $P(DVBFUF,U,2)=$E(X,2,9),$P(DVBFUF,U,3)=$E(X,10)
- S $P(DVBFUF,U,4)=$E(X,11,18),$P(DVBFUF,U,5)=$E(X,19,26)
- S $P(DVBFUF,U,6)=$E(X,27),$P(DVBFUF,U,7)=$E(X,28)
- S $P(DVBFUF,U,8)=$E(X,29),$P(DVBFUF,U,9)=$E(X,30,31)
- S $P(DVBFUF,U,10)=$E(X,32),$P(DVBFUF,U,11)=$E(X,33)
- S DVBV1=$E(X,34)
- I DVBV1?1A!(DVBV1["{") S DVBV2=1 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S $P(DVBFUF,U,12)=DVBV1
- S DVBV1=$E(X,35)
- I DVBV1?1A!(DVBV1["{") S DVBV2=1 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S $P(DVBFUF,U,13)=DVBV1
- S $P(DVBFUF,U,14)=$E(X,36)
- S L=37 D RON
- S DVBV1=$E(X,1,2)
- I DVBV1?1N1A!(DVBV1["{") S DVBV2=2 D SIGN^DVBHUTIL Q:$G(DVBERCS)
- S $P(DVBFUF,U,15)=DVBV1
- S $P(DVBFUF,U,16)=$E(X,3,5),$P(DVBFUF,U,17)=$E(X,6,9)
- S $P(DVBFUF,U,18)=$E(X,10,11),$P(DVBFUF,U,19)=$E(X,12,15)
- S $P(DVBFUF,U,20)=$E(X,16,17),$P(DVBFUF,U,21)=$E(X,18,21)
- S $P(DVBFUF,U,22)=$E(X,22,23),$P(DVBFUF,U,23)=$E(X,24,27)
- S $P(DVBFUF,U,24)=$E(X,28,29),$P(DVBFUF,U,25)=$E(X,30,33)
- S $P(DVBFUF,U,26)=$E(X,34,35),$P(DVBFUF,U,27)=$E(X,36,39)
- S $P(DVBFUF,U,28)=$E(X,40,41),$P(DVBFUF,U,29)=$E(X,42,44)
- S L=45 D RON
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBHQR12 3953 printed Feb 18, 2025@23:25:13 Page 2
- DVBHQR12 ;ALB/JLU;ROUTINE FOR C&P AND BIRLS ;8/28/91
- +1 ;;4.0;HINQ;**32,35,49**;03/25/92
- +2 ; PROCESSING THE C&P RECORD AND THEN THE BIRLS RECORD
- +3 ;
- DEDBL ; The deduction balance segment "E" and "F"
- EDEDBL SET $PIECE(DVBDBE,U,1)=$EXTRACT(X,1)
- SET $PIECE(DVBDBE,U,2)=$EXTRACT(X,2,3)
- +1 SET $PIECE(DVBDBE,U,3)=$EXTRACT(X,4)
- +2 SET DVBV1=$EXTRACT(X,5,10)
- IF DVBV1?5N1A!(DVBV1["{")
- SET DVBV2=6
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +3 SET $PIECE(DVBDBE,U,4)=+$EXTRACT(DVBV1,1,4)_"."_$EXTRACT(DVBV1,5,6)
- +4 SET DVBV1=$EXTRACT(X,11,18)
- IF DVBV1?7N1A!(DVBV1["{")
- SET DVBV2=6
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +5 SET DVBP(5)=+$EXTRACT(DVBV1,1,6)_"."_$EXTRACT(DVBV1,7,8)_U
- +6 SET DVBV1=$EXTRACT(X,19,25)
- IF DVBV1?6N1A!(DVBV1["{")
- SET DVBV2=7
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +7 SET $PIECE(DVBDBE,U,6)=+$EXTRACT(DVBV1,1,5)_"."_$EXTRACT(DVBV1,6,7)
- SET $PIECE(DVBDBE,U,7)=$EXTRACT(X,26,27)
- +8 SET $PIECE(DVBDBE,U,8)=$EXTRACT(X,28,29)
- SET $PIECE(DVBDBE,U,9)=$EXTRACT(X,30)
- +9 SET L=31
- DO RON
- +10 ;
- FDEDBL SET $PIECE(DVBDBF,U,1)=$EXTRACT(X,1)
- SET $PIECE(DVBDBF,U,2)=$EXTRACT(X,2,3)
- +1 SET $PIECE(DVBDBF,U,3)=$EXTRACT(X,4)
- +2 SET DVBV1=$EXTRACT(X,5,12)
- IF DVBV1?7N1A!(DVBV1["{")
- SET DVBV2=8
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +3 SET $PIECE(DVBDBF,U,4)=+$EXTRACT(DVBV1,1,6)_"."_$EXTRACT(DVBV1,7,8)
- SET $PIECE(DVBDBF,U,5)=$EXTRACT(X,13,14)
- +4 SET $PIECE(DVBDBF,U,6)=$EXTRACT(X,15)
- +5 SET L=16
- DO RON
- +6 ;
- REF ;REFERENCE-NUMBER-DATA.
- +1 SET $PIECE(DVBREF,U,1)=$EXTRACT(X,1,9)
- SET $PIECE(DVBREF,U,2)=$EXTRACT(X,10,18)
- +2 SET $PIECE(DVBREF,U,3)=$EXTRACT(X,19,27)
- +3 SET L=28
- DO RON
- +4 ;make a call to INC^DVBHQR13, as the future segments will no longer be
- +5 ;included in the VBA response message after DVB*4*49
- +6 GOTO INC^DVBHQR13
- +7 ;
- FUT ;DVB*4*49 - the call to G INC^DVBHQR13 is made in REF, and this code
- +1 ;will be skipped
- +2 ;FUTURE DATA.
- +3 ;A-TYPE-FUTURE-DATA:
- +4 SET DVBP(3)="A"_"^"_9_"^"
- +5 FOR XX=1:8:65
- SET DVBP(3)=DVBP(3)_$EXTRACT(X,XX,XX+7)_"^"
- +6 SET L=XX+8
- DO RON
- +7 ;E/F-TYPE-FUTURE-DATA:
- +8 DO FUTE
- DO FUTF
- +9 ;
- 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 ;
- FUTE ;future segment type E
- +1 SET $PIECE(DVBFUE,U)=$EXTRACT(X,1)
- +2 SET $PIECE(DVBFUE,U,2)=$EXTRACT(X,2,9)
- SET $PIECE(DVBFUE,U,3)=$EXTRACT(X,10)
- +3 SET DVBV1=$EXTRACT(X,11,16)
- +4 IF DVBV1?5N1A!(DVBV1["{")
- SET DVBV2=6
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +5 SET $PIECE(DVBFUE,U,4)=+$EXTRACT(DVBV1,1,4)_"."_$EXTRACT(DVBV1,5,6)
- SET $PIECE(DVBFUE,U,5)=$EXTRACT(X,17)
- +6 SET $PIECE(DVBFUE,U,6)=$EXTRACT(X,18,19)
- SET $PIECE(DVBFUE,U,7)=$EXTRACT(X,20,21)
- +7 SET $PIECE(DVBFUE,U,8)=$EXTRACT(X,22,23)
- SET $PIECE(DVBFUE,U,9)=$EXTRACT(24,25)
- +8 SET $PIECE(DVBFUE,U,10)=$EXTRACT(X,26)
- SET $PIECE(DVBFUE,U,11)=$EXTRACT(X,27)
- +9 SET $PIECE(DVBFUE,U,12)=$EXTRACT(X,28,32)
- SET $PIECE(DVBFUE,U,13)=$EXTRACT(X,33,34)
- +10 SET $PIECE(DVBFUE,U,14)=$EXTRACT(X,35)
- SET $PIECE(DVBFUE,U,15)=$EXTRACT(X,36)
- +11 SET $PIECE(DVBFUE,U,16)=$EXTRACT(X,37)
- SET $PIECE(DVBFUE,U,17)=$EXTRACT(X,38,40)
- +12 SET L=41
- DO RON
- +13 IF $PIECE(DVBFUE,U,3)
- DO LONGE
- +14 IF '$TEST
- SET L=31
- DO RON
- +15 QUIT
- +16 ;
- LONGE SET LP1=18
- +1 FOR LP=1:6:25
- SET DVBV1=$EXTRACT(X,LP,LP+5)
- DO LONCH
- SET $PIECE(DVBFUE,U,LP1)=+$EXTRACT(DVBV1,1,4)_"."_$EXTRACT(DVBV1,5,6)
- SET LP1=LP1+1
- +2 SET L=31
- DO RON
- +3 QUIT
- +4 ;
- LONCH IF DVBV1?5N1A!(DVBV1["{")
- SET DVBV2=6
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +1 QUIT
- +2 ;
- FUTF ;F subsegment of the future segment.
- +1 SET $PIECE(DVBFUF,U)=$EXTRACT(X,1)
- +2 SET $PIECE(DVBFUF,U,2)=$EXTRACT(X,2,9)
- SET $PIECE(DVBFUF,U,3)=$EXTRACT(X,10)
- +3 SET $PIECE(DVBFUF,U,4)=$EXTRACT(X,11,18)
- SET $PIECE(DVBFUF,U,5)=$EXTRACT(X,19,26)
- +4 SET $PIECE(DVBFUF,U,6)=$EXTRACT(X,27)
- SET $PIECE(DVBFUF,U,7)=$EXTRACT(X,28)
- +5 SET $PIECE(DVBFUF,U,8)=$EXTRACT(X,29)
- SET $PIECE(DVBFUF,U,9)=$EXTRACT(X,30,31)
- +6 SET $PIECE(DVBFUF,U,10)=$EXTRACT(X,32)
- SET $PIECE(DVBFUF,U,11)=$EXTRACT(X,33)
- +7 SET DVBV1=$EXTRACT(X,34)
- +8 IF DVBV1?1A!(DVBV1["{")
- SET DVBV2=1
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +9 SET $PIECE(DVBFUF,U,12)=DVBV1
- +10 SET DVBV1=$EXTRACT(X,35)
- +11 IF DVBV1?1A!(DVBV1["{")
- SET DVBV2=1
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +12 SET $PIECE(DVBFUF,U,13)=DVBV1
- +13 SET $PIECE(DVBFUF,U,14)=$EXTRACT(X,36)
- +14 SET L=37
- DO RON
- +15 SET DVBV1=$EXTRACT(X,1,2)
- +16 IF DVBV1?1N1A!(DVBV1["{")
- SET DVBV2=2
- DO SIGN^DVBHUTIL
- if $GET(DVBERCS)
- QUIT
- +17 SET $PIECE(DVBFUF,U,15)=DVBV1
- +18 SET $PIECE(DVBFUF,U,16)=$EXTRACT(X,3,5)
- SET $PIECE(DVBFUF,U,17)=$EXTRACT(X,6,9)
- +19 SET $PIECE(DVBFUF,U,18)=$EXTRACT(X,10,11)
- SET $PIECE(DVBFUF,U,19)=$EXTRACT(X,12,15)
- +20 SET $PIECE(DVBFUF,U,20)=$EXTRACT(X,16,17)
- SET $PIECE(DVBFUF,U,21)=$EXTRACT(X,18,21)
- +21 SET $PIECE(DVBFUF,U,22)=$EXTRACT(X,22,23)
- SET $PIECE(DVBFUF,U,23)=$EXTRACT(X,24,27)
- +22 SET $PIECE(DVBFUF,U,24)=$EXTRACT(X,28,29)
- SET $PIECE(DVBFUF,U,25)=$EXTRACT(X,30,33)
- +23 SET $PIECE(DVBFUF,U,26)=$EXTRACT(X,34,35)
- SET $PIECE(DVBFUF,U,27)=$EXTRACT(X,36,39)
- +24 SET $PIECE(DVBFUF,U,28)=$EXTRACT(X,40,41)
- SET $PIECE(DVBFUF,U,29)=$EXTRACT(X,42,44)
- +25 SET L=45
- DO RON
- +26 QUIT