AZLPTLAB ;PROGRAM TO LOAD LAB CODES TO GLOBAL FILE [ 12/10/85 1:25 PM ]
;READS TAPE FROM LAB LIBRARIAN FILE TBLEF04 (DPSC,DFM)
D INIT
C UDEV
O UDEV:("EFU":81:81)
U UDEV W *5
;READ TO SKIP TAPE MARK
U UDEV 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
U 0 W !,"BEGINING COUNT-RECORDS IN GLOBAL",DFN
U 0 W !,"RECORDS ADDED TO GLOBAL",RTG
C UDEV
W !!,"TOTAL RECORDS IN GLOBAL= ",DA
I NEXT>0 W !,"ERRORS HAVE OCCURED, D ^%GL FOR ^DFMELAB"
K F1,F2,BC1,BC2,EC1,EC2,RI,REC,UDEV,DFN,RG,GCD,DG,RTG,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)
U 0 W !,"CURRENT TAPE CODE",V2
S V2=$E(REC,BC2,EC2)
ESPCS ; ELIMINATE TRAILING SPACES AND LEADING ZEROES
F I=$L(V1):-1:1 I $E(V1,I)'=" " S V1=$E(V1,1,I) S:V1=" " V1="" Q
I V2<GCD G WGLOBL
I V2=GCD U 0 W !,"SKIP CODE ALREADY ON FILE",GCD G RD1
F I2=0:0 D RDG Q:GCD'<V2
I V2=GCD U 0 W !,"SKIP CODE ALREADY ON FILE",GCD G RD1
WGLOBL ; ADD NEW CODE TO GLOBAL
S DA=DA+1,RTG=RTG+1
S DR=F1_V1_F2_V2
D ^DIE
D:$D(Y)'=0 ERROR
U 0 W !,"RECORD INSERTED ",$E(REC,8,42)
Q
RDG ;READ NEXT GLOBAL RECORD
I RG>DFN S GCD=999999 Q
S RG=RG+1,GCD=$P(^AUTTLAB(RG,0),"^",2)
U 0 W !,"CURRENT GLOBAL CODE",GCD
Q
ERROR ; THIS ROUTINE WILL LOAD AN ERROR GLOBAL
S NEXT=NEXT+1,^DFMELAB(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,DFN,DG,GCD,RTG,^DFMELAB
S BC1=13,EC1=42,BC2=8,EC2=12
S F1=".01///",F2=";.02///"
S DFN=$P(^AUTTLAB(0),"^",4),DG=0,RG=1,RTG=0,GCD="",RI=0,DA=DFN,NEXT=0
S UDEV=48
S DIE="^AUTTLAB("
Q
AZLPTLAB ;PROGRAM TO LOAD LAB CODES TO GLOBAL FILE [ 12/10/85 1:25 PM ]
+1 ;READS TAPE FROM LAB LIBRARIAN FILE TBLEF04 (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
+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 USE 0
WRITE !,"BEGINING COUNT-RECORDS IN GLOBAL",DFN
+12 USE 0
WRITE !,"RECORDS ADDED TO GLOBAL",RTG
+13 CLOSE UDEV
+14 WRITE !!,"TOTAL RECORDS IN GLOBAL= ",DA
+15 IF NEXT>0
WRITE !,"ERRORS HAVE OCCURED, D ^%GL FOR ^DFMELAB"
+16 KILL F1,F2,BC1,BC2,EC1,EC2,RI,REC,UDEV,DFN,RG,GCD,DG,RTG,NEXT
+17 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 USE 0
WRITE !,"CURRENT TAPE CODE",V2
+6 SET V2=$EXTRACT(REC,BC2,EC2)
ESPCS ; ELIMINATE TRAILING SPACES AND LEADING ZEROES
+1 FOR I=$LENGTH(V1):-1:1
IF $EXTRACT(V1,I)'=" "
SET V1=$EXTRACT(V1,1,I)
IF V1=" "
SET V1=""
QUIT
+2 IF V2<GCD
GOTO WGLOBL
+3 IF V2=GCD
USE 0
WRITE !,"SKIP CODE ALREADY ON FILE",GCD
GOTO RD1
+4 FOR I2=0:0
DO RDG
IF GCD'<V2
QUIT
+5 IF V2=GCD
USE 0
WRITE !,"SKIP CODE ALREADY ON FILE",GCD
GOTO RD1
WGLOBL ; ADD NEW CODE TO GLOBAL
+1 SET DA=DA+1
SET RTG=RTG+1
+2 SET DR=F1_V1_F2_V2
+3 DO ^DIE
+4 IF $DATA(Y)'=0
DO ERROR
+5 USE 0
WRITE !,"RECORD INSERTED ",$EXTRACT(REC,8,42)
+6 QUIT
RDG ;READ NEXT GLOBAL RECORD
+1 IF RG>DFN
SET GCD=999999
QUIT
+2 SET RG=RG+1
SET GCD=$PIECE(^AUTTLAB(RG,0),"^",2)
+3 USE 0
WRITE !,"CURRENT GLOBAL CODE",GCD
+4 QUIT
ERROR ; THIS ROUTINE WILL LOAD AN ERROR GLOBAL
+1 SET NEXT=NEXT+1
SET ^DFMELAB(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,DFN,DG,GCD,RTG,^DFMELAB
+2 SET BC1=13
SET EC1=42
SET BC2=8
SET EC2=12
+3 SET F1=".01///"
SET F2=";.02///"
+4 SET DFN=$PIECE(^AUTTLAB(0),"^",4)
SET DG=0
SET RG=1
SET RTG=0
SET GCD=""
SET RI=0
SET DA=DFN
SET NEXT=0
+5 SET UDEV=48
+6 SET DIE="^AUTTLAB("
+7 QUIT
