- 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
