- AZLPTBLD ;PROGRAM TO LOAD ADA CODES TO GLOBAL FILE [ 12/20/85 2:27 PM ]
- ;READS TAPE FROM DEN LIBRARIAN FILE TBLDPR2 (DPSC,DFM)
- D INIT
- C UDEV
- O UDEV:("EFU":81:81)
- U UDEV W *5
- ;READ TO SKIP TAPE MARK
- U UDEV R REC R REC
- F I=0:0 D RD1 Q:REC=""
- U 0 W !!,"E N D O F B U I L D "
- U 0 W !,"NUMBER OF RECORDS READ= ",RI
- C UDEV
- W !!,"RECORDS TO GLOBAL= ",DA
- I NEXT>0 W !,"ERRORS HAVE OCCURED, D ^%GL FOR ^DFMEADA"
- S ^AUTTADA(0)="ADA CODE^9999999.31I^"_DA_"^"_DA
- K F1,F2,F3,F4,BC1,BC2,BC3,BC4,EC1,EC2,EC3,RI,REC,UDEV,NEXT
- Q
- RD1 U UDEV R REC
- S RI=RI+1
- Q:REC=""
- I $E(REC,3,4)'="DC" G RD1
- S V1=$E(REC,BC1,EC1)
- S V2=$E(REC,BC2,EC2)
- I $E(REC,60)'="T" S V3=$E(REC,62,66),V4=$E(REC,54) G ESPCS
- S V3=$E(REC,BC3,EC3)
- S V4=$E(REC,BC4)
- ESPCS ; ELIMINATE TRAILING SPACES AND LEADING ZEROES
- F I=$L(V2):-1:1 I $E(V2,I)'=" " S V2=$E(V2,1,I) S:V2=" " V2="" Q
- S STP=$L(V3)
- F I=1:1:STP Q:$E(V3,1,1)'="0" S LV3=$L(V3) S V3=$E(V3,2,LV3)
- S:V3="0" V3=""
- S:V4=" " V4=""
- S DA=DA+1
- S DR=F1_V1_F2_V2_F3_V3_F4_V4
- D ^DIE
- D:$D(Y)'=0 ERROR
- U 0 W !,"RECORD INSERTED ",$E(REC,8,61)
- Q
- ERROR ; THIS ROUTINE WILL LOAD AN ERROR GLOBAL
- S NEXT=NEXT+1,^DFMEADA(NEXT)=REC
- Q
- INIT ;ROUTINE TO SET UP VARIABLES
- K F1,F2,F3,F4,BC1,BC2,BC3,BC4,EC1,EC2,EC3,RI,REC,NEXT,UDEV,^AUTTADA,^DFMEADA
- S ^AUTTADA(0)="ADA CODE^9999999.31I^"
- S BC1=8,EC1=11,BC2=12,EC2=51,BC3=61,EC3=65,BC4=53
- S F1=".01///",F2=";.02///",F3=";.04///",F4=";.05///"
- S RI=0,DA=0,NEXT=0
- S UDEV=48
- S DIE="^AUTTADA("
- Q
- AZLPTBLD ;PROGRAM TO LOAD ADA CODES TO GLOBAL FILE [ 12/20/85 2:27 PM ]
- +1 ;READS TAPE FROM DEN LIBRARIAN FILE TBLDPR2 (DPSC,DFM)
- +2 DO INIT
- +3 CLOSE UDEV
- +4 OPEN UDEV:("EFU":81:81)
- +5 USE UDEV
- WRITE *5
- +6 ;READ TO SKIP TAPE MARK
- +7 USE UDEV
- READ REC
- READ REC
- +8 FOR I=0:0
- DO RD1
- IF REC=""
- QUIT
- +9 USE 0
- WRITE !!,"E N D O F B U I L D "
- +10 USE 0
- WRITE !,"NUMBER OF RECORDS READ= ",RI
- +11 CLOSE UDEV
- +12 WRITE !!,"RECORDS TO GLOBAL= ",DA
- +13 IF NEXT>0
- WRITE !,"ERRORS HAVE OCCURED, D ^%GL FOR ^DFMEADA"
- +14 SET ^AUTTADA(0)="ADA CODE^9999999.31I^"_DA_"^"_DA
- +15 KILL F1,F2,F3,F4,BC1,BC2,BC3,BC4,EC1,EC2,EC3,RI,REC,UDEV,NEXT
- +16 QUIT
- RD1 USE UDEV
- READ REC
- +1 SET RI=RI+1
- +2 IF REC=""
- QUIT
- +3 IF $EXTRACT(REC,3,4)'="DC"
- GOTO RD1
- +4 SET V1=$EXTRACT(REC,BC1,EC1)
- +5 SET V2=$EXTRACT(REC,BC2,EC2)
- +6 IF $EXTRACT(REC,60)'="T"
- SET V3=$EXTRACT(REC,62,66)
- SET V4=$EXTRACT(REC,54)
- GOTO ESPCS
- +7 SET V3=$EXTRACT(REC,BC3,EC3)
- +8 SET V4=$EXTRACT(REC,BC4)
- ESPCS ; ELIMINATE TRAILING SPACES AND LEADING ZEROES
- +1 FOR I=$LENGTH(V2):-1:1
- IF $EXTRACT(V2,I)'=" "
- SET V2=$EXTRACT(V2,1,I)
- IF V2=" "
- SET V2=""
- QUIT
- +2 SET STP=$LENGTH(V3)
- +3 FOR I=1:1:STP
- IF $EXTRACT(V3,1,1)'="0"
- QUIT
- SET LV3=$LENGTH(V3)
- SET V3=$EXTRACT(V3,2,LV3)
- +4 IF V3="0"
- SET V3=""
- +5 IF V4=" "
- SET V4=""
- +6 SET DA=DA+1
- +7 SET DR=F1_V1_F2_V2_F3_V3_F4_V4
- +8 DO ^DIE
- +9 IF $DATA(Y)'=0
- DO ERROR
- +10 USE 0
- WRITE !,"RECORD INSERTED ",$EXTRACT(REC,8,61)
- +11 QUIT
- ERROR ; THIS ROUTINE WILL LOAD AN ERROR GLOBAL
- +1 SET NEXT=NEXT+1
- SET ^DFMEADA(NEXT)=REC
- +2 QUIT
- INIT ;ROUTINE TO SET UP VARIABLES
- +1 KILL F1,F2,F3,F4,BC1,BC2,BC3,BC4,EC1,EC2,EC3,RI,REC,NEXT,UDEV,^AUTTADA,^DFMEADA
- +2 SET ^AUTTADA(0)="ADA CODE^9999999.31I^"
- +3 SET BC1=8
- SET EC1=11
- SET BC2=12
- SET EC2=51
- SET BC3=61
- SET EC3=65
- SET BC4=53
- +4 SET F1=".01///"
- SET F2=";.02///"
- SET F3=";.04///"
- SET F4=";.05///"
- +5 SET RI=0
- SET DA=0
- SET NEXT=0
- +6 SET UDEV=48
- +7 SET DIE="^AUTTADA("
- +8 QUIT
