- DVBHQR3 ;ISC-ALBANY/PKE-parse Birls response ; 8/19/87 06:44 ;
- ;;V4.0;HINQ;;03/25/92
- ;abbreviated name, number parser
- G EN
- RON S LP=(L\246)+1,L2=L#245 S:L2=0 L2=245 S L3=L1-(245-L2) ;maybe +1
- I $D(X(LP)) S X=$E(X(LP),L2,L2+L1-1) I $L(X)<L1,$D(X(LP+1)) S X=X_$E(X(LP+1),1,L3) Q
- Q
- FOLDER Q:'+DVBFL(I) S Z=0,Z=$O(^DIC(4,"D",+DVBFL(I),Z)) I Z,$D(^DIC(4,Z,0)) S DVBFL(I)=Z_" - "_$P(^(0),U) Q
- Q
- BOS S Z=DVBBOS(I),DVBBOS(I)=$S(Z="A ":"ARMY",Z="AF ":"AFOR",1:Z) Q
- ;
- EN S L=1,L1=27 D RON S DVBABREV=$E(X,5) D:DVBABREV="N" NAME D:DVBABREV="M" NUMBER Q
- ;
- NAME S DFN=+$E(X,8,21),DVBLEN=$E(X,22,25),DVBRECN=+$E(X,26,27) I 'DVBRECN K DVBRECN Q
- ;
- S L=28,L1=53 D RON
- F I=1:1:DVBRECN D PARSE
- Q
- PARSE S LF=$F(X,"@"),X=$E(X,1,LF-1)
- I LF,$L(X)
- E Q
- S DVBCN(I)=$E(X,1,9),DVBSSN(I)=$E(X,10,18),DVBSN(I)=$E(X,19,27),DVBPAYN(I)=$E(X,28,29),DVBDOB(I)=$E(X,30,33),DVBDOD(I)=$E(X,34,37)
- S DVBEOD(I)=$E(X,38,41),DVBRAD(I)=$E(X,42,45),DVBBOS(I)=$E(X,46,49),DVBFL(I)=$E(X,50,52),L=L+LF-1 D RON,FOLDER,BOS Q
- ;
- NUMBER S DFN=+$E(X,8,21),DVBLEN=$E(X,22,25),DVBRECN=+$E(X,26,27) I 'DVBRECN K DVBRECN Q
- S L=28,L1=67 D RON
- F I=1:1:DVBRECN D PARSE1
- Q
- PARSE1 S LF=$F(X,"@"),X=$E(X,1,LF-1)
- I LF,$L(X)
- E Q
- S DVBNAM(I)=$E(X,1,36),DVBCN(I)=$E(X,37,45),DVBPAYN(I)=$E(X,46,47),DVBFL(I)=$E(X,48,50),DVBEOD(I)=$E(X,51,54),DVBRAD(I)=$E(X,55,58),DVBDOB(I)=$E(X,59,62),DVBDOD(I)=$E(X,63,66),L=L+LF-1 D RON,FOLDER Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBHQR3 1431 printed Feb 18, 2025@23:25:16 Page 2
- DVBHQR3 ;ISC-ALBANY/PKE-parse Birls response ; 8/19/87 06:44 ;
- +1 ;;V4.0;HINQ;;03/25/92
- +2 ;abbreviated name, number parser
- +3 GOTO EN
- RON ;maybe +1
- SET LP=(L\246)+1
- SET L2=L#245
- if L2=0
- SET L2=245
- SET L3=L1-(245-L2)
- +1 IF $DATA(X(LP))
- SET X=$EXTRACT(X(LP),L2,L2+L1-1)
- IF $LENGTH(X)<L1
- IF $DATA(X(LP+1))
- SET X=X_$EXTRACT(X(LP+1),1,L3)
- QUIT
- +2 QUIT
- FOLDER if '+DVBFL(I)
- QUIT
- SET Z=0
- SET Z=$ORDER(^DIC(4,"D",+DVBFL(I),Z))
- IF Z
- IF $DATA(^DIC(4,Z,0))
- SET DVBFL(I)=Z_" - "_$PIECE(^(0),U)
- QUIT
- +1 QUIT
- BOS SET Z=DVBBOS(I)
- SET DVBBOS(I)=$SELECT(Z="A ":"ARMY",Z="AF ":"AFOR",1:Z)
- QUIT
- +1 ;
- EN SET L=1
- SET L1=27
- DO RON
- SET DVBABREV=$EXTRACT(X,5)
- if DVBABREV="N"
- DO NAME
- if DVBABREV="M"
- DO NUMBER
- QUIT
- +1 ;
- NAME SET DFN=+$EXTRACT(X,8,21)
- SET DVBLEN=$EXTRACT(X,22,25)
- SET DVBRECN=+$EXTRACT(X,26,27)
- IF 'DVBRECN
- KILL DVBRECN
- QUIT
- +1 ;
- +2 SET L=28
- SET L1=53
- DO RON
- +3 FOR I=1:1:DVBRECN
- DO PARSE
- +4 QUIT
- PARSE SET LF=$FIND(X,"@")
- SET X=$EXTRACT(X,1,LF-1)
- +1 IF LF
- IF $LENGTH(X)
- +2 IF '$TEST
- QUIT
- +3 SET DVBCN(I)=$EXTRACT(X,1,9)
- SET DVBSSN(I)=$EXTRACT(X,10,18)
- SET DVBSN(I)=$EXTRACT(X,19,27)
- SET DVBPAYN(I)=$EXTRACT(X,28,29)
- SET DVBDOB(I)=$EXTRACT(X,30,33)
- SET DVBDOD(I)=$EXTRACT(X,34,37)
- +4 SET DVBEOD(I)=$EXTRACT(X,38,41)
- SET DVBRAD(I)=$EXTRACT(X,42,45)
- SET DVBBOS(I)=$EXTRACT(X,46,49)
- SET DVBFL(I)=$EXTRACT(X,50,52)
- SET L=L+LF-1
- DO RON
- DO FOLDER
- DO BOS
- QUIT
- +5 ;
- NUMBER SET DFN=+$EXTRACT(X,8,21)
- SET DVBLEN=$EXTRACT(X,22,25)
- SET DVBRECN=+$EXTRACT(X,26,27)
- IF 'DVBRECN
- KILL DVBRECN
- QUIT
- +1 SET L=28
- SET L1=67
- DO RON
- +2 FOR I=1:1:DVBRECN
- DO PARSE1
- +3 QUIT
- PARSE1 SET LF=$FIND(X,"@")
- SET X=$EXTRACT(X,1,LF-1)
- +1 IF LF
- IF $LENGTH(X)
- +2 IF '$TEST
- QUIT
- +3 SET DVBNAM(I)=$EXTRACT(X,1,36)
- SET DVBCN(I)=$EXTRACT(X,37,45)
- SET DVBPAYN(I)=$EXTRACT(X,46,47)
- SET DVBFL(I)=$EXTRACT(X,48,50)
- SET DVBEOD(I)=$EXTRACT(X,51,54)
- SET DVBRAD(I)=$EXTRACT(X,55,58)
- SET DVBDOB(I)=$EXTRACT(X,59,62)
- SET DVBDOD(I)=$EXTRACT(X,63,66)
- SET L=L+LF-1
- DO RON
- DO FOLDER
- QUIT
- +4 QUIT
