Process Census in MPRO database

MPRO Macro programs in DPL called by above Memo-list. Note: for display in this webpage, HTML tag brackets changed to [ ] \1 *** GLOBAL edits ;com=com+"###" ;CLEAR qbar ;CLEAR qfirn \2 Insert line numbers DN znum PREC 0 znum=znum+1 ;Qsurcount=znum ;all records for indexing sched=znum ;only add cn ------ \3 Add sched numbers DN znum DC zsch,zlet,ztemp PREC 0 znum=znum+1 ztemp=znum TLU zlet=A,ztemp IFP sched GOTO LAB1 sched=zsch GOTO LABexit LAB1: zsch=sched zlet=" " znum=0 LABexit: sched="Ad"+sched+zlet \4 Copy surname DC zsur IF addr cn "-------" GOTO LAB2 IF addr cn "(p" GOTO LAB2 IFA sur GOTO LAB1 zsur=sur GOTO LABexit LAB1: sur=zsur GOTO LABexit LAB2: CLEAR sur LABexit: \A Format A for Website DC zwhen zwhen=Qwhen IF Qwhen GT 1700 GOTO LAB1 zwhen="" LAB1: qbar=Sched+"`"+Sur+"`"+Fir+"`"+Age qbar=qbar+"`"+Gender+"`"+Occ+"`"+zwhen+"`"+Born IF sched nc "a" GOTO LABexit qbar=qbar+"`"+address LABexit: \B Format B for Website qbar=Sched+"`"+Addr+"`"+Fir+"`"+Sur+"`"+Gender qbar=qbar+"`"+Age+"`"+Occ+"`"+Born \C Best guess YoB from 1841 age ;Checked and works OK 7 Feb 99 ;Census taken Sunday 6 Jun 1841 DC zchar DN zage,znum,zlen PREC 0 IFA age GOTO LAB5 ;no age given RIGHTSTR age,1,zchar ;get rightmost age character IF zchar EQ "m" GOTO LAB3 IF zchar EQ "w" GOTO LAB4 IF zchar EQ "d" GOTO LAB4 zage=age ;convert age GE 1 to number IF zage GT 15 GOTO LAB1 ;Age LE 15, so is exact znum=1841-zage ;calculate YoB Qwhen=znum GOTO LABexit LAB1: IF zchar EQ "0" GOTO LAB2 IF zchar EQ "5" GOTO LAB2 ;Age NOT a multiple of 5, so is exact znum=1841-zage ;calculate YoB Qwhen=znum GOTO LABexit LAB2: ;Age IS a multiple of 5 znum=1841-zage-2 ;calculate YoB, for multiple of 5 Qwhen=znum GOTO LABexit LAB3: ;Age given in months LENSTR age,zlen zlen=zlen-1 LEFTSTR age,zlen,zchar;get number part of age in months zage=zchar IF zage LE 5 GOTO LAB4 ;Age is GT 5 months znum=1841-1 ;calculate YoB Qwhen=znum GOTO LABexit LAB4: ;Age is LE 5 months znum=1841 ;YoB is Census year 1841 Qwhen=znum GOTO LABexit LAB5: Qwhen=0 LABexit: \D Format for e-mail Qbar=Sched+"-"+Fir+"-"+Sur+"-"+pos+"-"+cond+"-"+Age+"-"+Gender Qbar=qbar+"-"+Occ+"-"+Born+"-"+Com \E Format for Index CLEAR qbar IFA link91 THEN LAB1 qbar=link91+"^" LAB1: IFA link51 THEN LAB2 qbar=qbar+"[A NAME="+link51+"][/A]^" LAB2: qbar=qbar+sched+"`[A HREF="+qfirn+"#"+sched+"]" qbar=qbar+sur+" "+fir+"[/A] "+age \F Generate Qsurn DC zmid, zend DN znum PREC 0 SLICE sched,3,2,zmid ;enter correct numbers SLICE sched,5,2,zend ;enter correct numbers znum=zmid znum=2379+zmid ;enter correct number before running qsurn=znum+zend \G Format C for Website qbar=sched+"`"+fir+"`"+sur+"`"+gen+"`"+age+"`"+born qbar=qbar+"`"+occ+"`"+addr \H Change place in SCHED DC ztemp SLICE sched,3,5,ztemp sched="Ib"+ztemp \I SETCASE SETCASE pos,F SETCASE con,F SETCASE gen,F \J Increase SCHED numbers by 6 ;Works well 3 May 99 DC zmid,zend,zinc DN znum ;Mk322b PREC 0 SLICE sch,3,3,zmid ;322 SLICE sch,6,2,zend ;b znum=zmid ;322 znum=znum+6 ;328 zinc=znum ;328 sch='Mk'+zinc+zend ;Mk328b \K Remove 0 from SCHED numbers ;Works OK 30 Jun 99 DC zfront, zmid ;Mk006za SLICE sch,1,2,zfront ;Mk SLICE sch,4,4,zmid ;06za sch=zfront+zmid ;Mk06za \L Insert 0 in SCHED numbers ;Works OK 16 Jul 00 ;Edit zpla to suit the place to be processed ;select QSURC to choose records to be processed DN znum,zlen,zpla PREC 0 DC zleft,zright ;Mk1za zpla=2 ;****number of place letters**** LEFTSTR sch,zpla,zleft ;Mk LENSTR sch,zlen zlen=zlen-zpla RIGHTSTR sch,zlen,zright ;1za sch=zleft+"0"+zright ;Mk01za \M 1851 LIST format for LSPRO CLEAR qbar IFA link81 THEN LAB1 qbar=link81+"^" LAB1: IFA link71 THEN LAB2 qbar=qbar+"[A NAME="+link71+"][/A]^" LAB2: IF addr NC "---" THEN LAB4 qbar=qbar+"[A NAME="+sched+"][/A][FONT COLOR=red]" qbar=qbar+hou+"---"+fir+"---["+page+"]" IFA addr THEN LAB3 qbar=qbar+addr LAB3: qbar=qbar+"[/FONT]" GOTO LAB5 LAB4: qbar=qbar+"[A NAME="+sched+"][/A]" qbar=qbar+sched+"`"+fir+"`"+sur+"`" qbar=qbar+age+"`"+gen+"`"+born+"`"+occ qbar=qbar+"`"+com LAB5: \N 1851 INDEX format for LSPRO DC zsched DN zlen,znum PREC 0 LENSTR sched,zlen znum=zlen-1 LEFTSTR sched,znum,zsched CLEAR qbar qbar=zsched+"`"+sur+" "+fir+" ("+age+")" \P 1851 Insert Menu links DC zA, zB, ztemp, zsched zA='[A NAME="' zB='"][/A][A HREF="#Menu"](Back to the Menu)[/A]ª' SLICE sched,4,2,ztemp ;sched ends in "0space" SLICE sched 1,4,zsched ;placecode+digits eg Ad80 IF ztemp NE '0 ' GOTO LABexit ;sched NE in "0space" qoccname=zA+zsched+zB LABexit: \Q Chapman Codes to Link41 (strays) ;after running, search as follows: ;IFP link41 ;inspect, add codes or stops to Table C if necessary DC ztemp CLEAR Link41 IFA born GOTO LABexit IFTLU C,born THEN LAB1a RIGHTSTR born,4,ztemp IF ztemp NB " " GOTO LABexit ;eg " LAN" RIGHTSTR born,3,ztemp Link41=ztemp IFTLU C,link41 THEN LABexit ;Chapman codes in Table C GOTO LABexit LAB1a: Link41=born GOTO LABexit LABexit: \R 1851 Strays format to LSPRO qbar=born+"`"+sur+"`"+fir+"`"+age+"`"+occ qbar=qbar+"`[A HREF="+qfirn+"#"+sch+"]"+sch+"[/A]" \S Remove lead blank from add DC zchar DN znum PREC 0 LENSTR add,znum znum=znum-1 RIGHTSTR add,znum,zchar IF add NB " " GOTO LAB1 add=zchar LAB1: \T Transfer addr to next line ;Index on Qfirc (ie Sched inverted) DC zchar DN zqfirc,znum PREC 0 IFA page THEN LAB1 zchar=page zqfirc=qfirc znum=qfirc+1 LAB1: IF qfirc NE znum THEN LAB2 page=zchar LAB2: \U Every tenth sched DC zchar,zdigit,zsched DN zlen PREC 0 CLEAR qagen zsched=sched LENSTR zsched,zlen LEFTSTR zsched,zlen,zchar RIGHTSTR zchar,1,zdigit IF zdigit NE "0" THEN LAB1 IF addr NC "---" THEN LAB1 qagen="[A HREF=#"+zsched+"]("+zsched+")[/A]" LAB1: \V Index links qagen="[A HREF=#"+link51+"]("+link51+")[/A]" \W remove trailing blank from sched DC zchar DN zlen PREC 0 CLEAR qagen LENSTR sched,zlen zlen=zlen-1 RIGHTSTR sched,1,zchar IF zchar NE " " THEN LAB1 LEFTSTR sched,zlen,qagen LAB1:

Compiled, formatted, hyperlinked, encoded, and copyright © 2008, . All Rights Reserved.