/*-------------------------------------------------------------------------------

        © Copyright 2011-2013 University of Manitoba 

This program is free software: you can redistribute it and/or modify it 
under the terms of the GNU General Public License as published by the Free 
Software Foundation, either version 3 of the License, or (at your option) 
any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.

-----------------------------------------------------------------------------

This macro was original written to run on a specific dataset, This macro has 
been modified to allow it to run on multiple datasets or multiple cluster 
members within a specific cluster dataset.

The macro checks the agreement between a dataset and the registry data
(mhmrs_uniqphin_1970[regyr]) for the same individuals and produces Kappa
Statistics for sex and date of birth


Original program written by: Mahmoud Azimaee

Modified by: Say Hong

Please direct questions and comments to info@cpe.umanitoba.ca

Feb. 28, 2013


Macro Parameters:

Domain = Libname of the dataset

Db = Space separated list of dataset name or specific cluster dataset name

regyr = Latest year of available registry data (default value is 2012)

Sex = Sex variable (default value is sex)

M = Representing value for males (default value is 1)

F = Representing value for females (default value is 2)

Birthdt = Date of birth variable (default value is birthdt)

memnum = ALL or Space separated list of cluster members

/-------------------------------------------------------------------------------*/


%macro dq_agreement(domain=, db=, regyr=2012, phin=scrphin, sex=sex, M=1, F=2, birthdt=birthdt, memnum=);

%put;
%put NOTE: Agreement Macro;
%put NOTE: Original program written by Mahmoud Azimaee;
%put NOTE: Modified by Say Hong;
%put;

proc datasets nolist memtype=data;
  delete kappa;
quit;

%if %upcase(&memnum) ^=  %then %do;

  %if %sysfunc(countw(&db)) > 1 %then %do;
    %put WARNING: Too many cluster datasets have been listed on the parameter db;
    %put WARNING: If memnum is not empty, this macro can only run for one cluster dataset at a time;
	%put WARNING: This macro stop without executing;
    %return;
  %end;

  %if %upcase(&memnum) = ALL %then %do;
    ods output enginehost=clsmem;
    proc contents data=&domain..&db;
    run;
    ods output close;

    data _null_;
      set clsmem;
	  if label1 = 'Cluster Members are' then call symputx('clsmem', cvalue1);
    run;

    %let nmem = %sysfunc(countw(%bquote(&clsmem), %str(,)));
    %let members=;
	%let memnum=;
    %do i = 1 %to &nmem;
      %let temp=%scan(%scan(%bquote(&clsmem), &i, %str(,)), 1, '(');
	  %let members = &members &temp;
	  %let memnum = &memnum &i;
    %end;

    proc datasets nolist memtype=data lib=work;
      delete clsmem;
    quit;
  %end;

  %else %do;

    %let nmem=%sysfunc(countw(&memnum));

	ods output enginehost=clsmem;
	proc contents data=&domain..&db;
	run;
	ods output close;

	data _null_;
      set clsmem;
	  if label1 = 'Cluster Members are' then call symputx('clsmem', cvalue1);
    run;

	%let cnt = 1;
	%let members =;
	%let mem = %scan(&memnum, &cnt);
	%do %while(&mem ne);
	  %let temp=%scan(%scan(%bquote(&clsmem), &mem, %str(,)), 1, '(');
	  %let members = &members &temp;
	  %let cnt = %eval(&cnt+1);
	  %let mem = %scan(&memnum, &cnt);
	%end;

	proc datasets nolist memtype=data lib=work;
      delete clsmem;
    quit;
  %end;

%end;

%if %upcase(&phin) = SCRPHIN %then %let phintype=SCRPHINTYPE;
%else %let phintype = filephintype;

data reg;
  set registry.mhmrs_uniqphin_1970&regyr(keep=&phin ribirthdt sex rename=(sex=reg_sex));
  by &phin;
  if last.&phin;
run;

%if &memnum ^= %then %do;
  %do i = 1 %to &nmem;
    %let mem = %scan(&memnum, &i);
	proc sort data=&domain..&db(memnum=&mem keep=&phin &birthdt &sex &phintype) out=sorted&i;
	  by &phin;
	run;
  %end;

  %let n_dsn = &nmem;
  %let dsn_lst = &members;
%end;

%else %do;
/*  %if %sysfunc(countw(&db)) = 1 %then %do;
    proc sql noprint;
      select memname into :dsn_lst separated by ' ' from
      dictionary.members where libname = "%upcase(&domain)" and
      substr(memname, 1, %length(&db))="%upcase(&db)";
    quit;
  %end;
  %else %let dsn_lst = &db;*/
  %let dsn_lst = &db;
  %let n_dsn = %sysfunc(countw(&dsn_lst));
  %do i = 1 %to &n_dsn;
    proc sort data=&domain..%scan(&dsn_lst, &i)(keep=&phin &birthdt &sex &phintype) out=sorted&i;
	  by &phin;
    run;
  %end;

%end;

%do i = 1 %to &n_dsn;

  data demo&i;
    merge sorted&i(in=in_data) reg(in=in_reg);
    by &phin;
    if in_data;
    if last.&phin;
    if &phintype in ('0', '1', '2', '3', '6');
    reg_birth = substr(put(ribirthdt, yymmdd6.), 1, 4);
    data_birth = substr(put(&birthdt, yymmdd6.), 1, 4);
    if &sex = "&M" then &sex = '1';
    if &sex = "&F" then &sex = '2';
    if &sex ^ in ('1', '2') then &sex = ' ';
    if &sex = ' ' | reg_sex = ' ' then do;
      &sex = ' ';
      reg_sex = ' ';
    end;
    if reg_birth = ' ' | data_birth = ' ' then do;
      reg_birth = ' ';
      data_birth = ' ';
    end;
  run;

  proc freq data=demo&i noprint;
    tables &sex*reg_sex/list agree;
    output out=kappa_sex&i(keep=_kappa_) agree;
  run;

*** To have equal number of columns and rows which is required for KAPPA Agreement Test, this part of the macro 
	creates all possible combination of DOB (MMYY only) and then runs a PROC FREQ with the ZEROS option;

  proc freq data=demo&i noprint ;
    table reg_birth*data_birth  / sparse out=demo_out&i;
  run;

  data demo_out&i;
    set demo_out&i;
    if reg_birth='' | data_birth='' then delete;
  run;

  data reg_birth&i(keep=data_birth rename=(data_birth=birth)) data_birth&i(keep=reg_birth rename=(reg_birth=birth));
    set demo_out&i;
  run;

  data birth&i;
    set data_birth&i reg_birth&i;
    reg_birth=birth;
    rename birth=data_birth;
  run;

  proc sort data=birth&i nodupkey;
    by reg_birth data_birth;
  run;

  proc freq data=birth&i noprint;
    table reg_birth*data_birth/ sparse list out=demo_tmp&i;
  run;

  data demo_tmp&i;
    set demo_tmp&i;
    keep reg_birth data_birth;
  run;

  proc sort data=demo_tmp&i;
    by reg_birth data_birth;
  run;

  data demo_new&i;
    merge demo_out&i demo_tmp&i;
    by reg_birth data_birth;
    if Count=. then count=0;
    drop percent;
  run;

  proc freq data=demo_new&i noprint;
    table reg_birth*data_birth  / list AGREE ;
    weight count/ zeros;
    output out=kappa_dob&i(keep=_kappa_) agree;
  run;

  options mergenoby=nowarn;
  data kappa&i(drop=_kappa_sex _kappa_dob);
  %if &memnum ^= %then %do;
    length dataset $32 clustermem $32;
    retain dataset "&db" clustermem "%scan(&dsn_lst, &i)";
  %end;
  %else %do;
    length dataset $32;
	retain dataset "%scan(&dsn_lst, &i)";
  %end;
    merge kappa_sex&i(in=in_sex rename=(_kappa_=_kappa_sex)) kappa_dob&i(in=in_dob rename=(_kappa_=_kappa_dob));
    kappa_sex = input(put(_kappa_sex, 6.4), 8.);
	kappa_dob = input(put(_kappa_dob, 6.4), 8.);
  run;
  options mergenoby=warn;

%end;

data kappa;
  set kappa1-kappa&n_dsn;
  label
  %if &memnum ^= %then %do;
    dataset = 'Cluster Name'
    clustermem = 'Cluster Member'
  %end;
  %else dataset = 'Dataset Name';
	    kappa_sex = 'Degree of Agreement with Registry - Sex (Kappa Statistic)'
		kappa_dob = 'Degree of Agreement with Registry - Date of Birth (kappa Statistic)';
run;

proc print data=kappa label;
run;

%if %substr(&dq_dir, %length(&dq_dir), 1) = \ %then
%let dq_dir = %substr(&dq_dir, 1, %length(&dq_dir) - 1);

%if %substr(&sysscpl, 1, 3) = X64 or %substr(&sysscpl, 1, 3) = W64
%then %let dbms = excelcs;
%else %let dbms = excel;

proc export data=kappa outfile="&dq_dir\&dq_name..xls" dbms=&dbms label replace;
  sheet = 'agreement';
run;

proc datasets nolist memtype=data lib=work;
  delete sorted1-sorted&n_dsn demo1-demo&n_dsn demo_out1-demo_out&n_dsn kappa_dob1-kappa_dob&n_dsn
         kappa_sex1-kappa_sex&n_dsn reg_birth1-reg_birth&n_dsn data_birth1-data_birth&n_dsn
		 birth1-birth&n_dsn demo_tmp1-demo_tmp&n_dsn demo_new1-demo_new&n_dsn
		 kappa1-kappa&n_dsn reg;
quit;

%mend dq_agreement;