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
